packages feed

ghc (empty) → 8.2.1

raw patch · 527 files changed

+340738/−0 lines, 527 filesdep +Win32dep +arraydep +basesetup-changed

Dependencies added: Win32, array, base, binary, bytestring, containers, deepseq, directory, filepath, ghc-boot, ghc-boot-th, ghci, hoopl, hpc, process, template-haskell, terminfo, time, transformers, unix

Files

+ HsVersions.h view
@@ -0,0 +1,69 @@+#ifndef HSVERSIONS_H+#define HSVERSIONS_H++#if 0++IMPORTANT!  If you put extra tabs/spaces in these macro definitions,+you will screw up the layout where they are used in case expressions!++(This is cpp-dependent, of course)++#endif++/* Useful in the headers that we share with the RTS */+#define COMPILING_GHC 1++/* Pull in all the platform defines for this build (foo_TARGET_ARCH etc.) */+#include "ghc_boot_platform.h"++/* Pull in the autoconf defines (HAVE_FOO), but don't include+ * ghcconfig.h, because that will include ghcplatform.h which has the+ * wrong platform settings for the compiler (it has the platform+ * settings for the target plat instead). */+#include "ghcautoconf.h"++#define GLOBAL_VAR(name,value,ty)  \+{-# NOINLINE name #-};             \+name :: IORef (ty);                \+name = Util.global (value);++#define GLOBAL_VAR_M(name,value,ty) \+{-# NOINLINE name #-};              \+name :: IORef (ty);                 \+name = Util.globalM (value);+++#define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \+{-# NOINLINE name #-};                                      \+name :: IORef (ty);                                         \+name = Util.sharedGlobal (value) (accessor);                \+foreign import ccall unsafe saccessor                       \+  accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));++#define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty)  \+{-# NOINLINE name #-};                                         \+name :: IORef (ty);                                            \+name = Util.sharedGlobalM (value) (accessor);                  \+foreign import ccall unsafe saccessor                          \+  accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));+++#define ASSERT(e)      if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else+#define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else+#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $++-- Examples:   Assuming   flagSet :: String -> m Bool+--+--    do { c   <- getChar; MASSERT( isUpper c ); ... }+--    do { c   <- getChar; MASSERT2( isUpper c, text "Bad" ); ... }+--    do { str <- getStr;  ASSERTM( flagSet str ); .. }+--    do { str <- getStr;  ASSERTM2( flagSet str, text "Bad" ); .. }+--    do { str <- getStr;  WARNM2( flagSet str, text "Flag is set" ); .. }+#define MASSERT(e)      ASSERT(e) return ()+#define MASSERT2(e,msg) ASSERT2(e,msg) return ()+#define ASSERTM(e)      do { bool <- e; MASSERT(bool) }+#define ASSERTM2(e,msg) do { bool <- e; MASSERT2(bool,msg) }+#define WARNM2(e,msg)   do { bool <- e; WARN(bool, msg) return () }++#endif /* HsVersions.h */+
+ LICENSE view
@@ -0,0 +1,31 @@+The Glasgow Haskell Compiler License++Copyright 2002, The University Court of the University of Glasgow. +All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.+ +- 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.+ +- Neither name of the University 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 UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE 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+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Unique.h view
@@ -0,0 +1,5 @@+/* unique has the following structure:+ * HsInt unique =+ *    (unique_tag << (sizeof (HsInt) - UNIQUE_TAG_BITS)) | unique_number+ */+#define UNIQUE_TAG_BITS 8
+ autogen/CodeGen.Platform.hs view
@@ -0,0 +1,1137 @@++import CmmExpr+#if !(MACHREGS_i386 || MACHREGS_x86_64 || MACHREGS_sparc || MACHREGS_powerpc)+import Panic+#endif+import Reg++#include "ghcautoconf.h"+#include "stg/MachRegs.h"++#if MACHREGS_i386 || MACHREGS_x86_64++# if MACHREGS_i386+#  define eax 0+#  define ebx 1+#  define ecx 2+#  define edx 3+#  define esi 4+#  define edi 5+#  define ebp 6+#  define esp 7+# endif++# if MACHREGS_x86_64+#  define rax   0+#  define rbx   1+#  define rcx   2+#  define rdx   3+#  define rsi   4+#  define rdi   5+#  define rbp   6+#  define rsp   7+#  define r8    8+#  define r9    9+#  define r10   10+#  define r11   11+#  define r12   12+#  define r13   13+#  define r14   14+#  define r15   15+# endif++# define fake0 16+# define fake1 17+# define fake2 18+# define fake3 19+# define fake4 20+# define fake5 21++# define xmm0  24+# define xmm1  25+# define xmm2  26+# define xmm3  27+# define xmm4  28+# define xmm5  29+# define xmm6  30+# define xmm7  31+# define xmm8  32+# define xmm9  33+# define xmm10 34+# define xmm11 35+# define xmm12 36+# define xmm13 37+# define xmm14 38+# define xmm15 39++# define ymm0  40+# define ymm1  41+# define ymm2  42+# define ymm3  43+# define ymm4  44+# define ymm5  45+# define ymm6  46+# define ymm7  47+# define ymm8  48+# define ymm9  49+# define ymm10 50+# define ymm11 51+# define ymm12 52+# define ymm13 53+# define ymm14 54+# define ymm15 55++# define zmm0  56+# define zmm1  57+# define zmm2  58+# define zmm3  59+# define zmm4  60+# define zmm5  61+# define zmm6  62+# define zmm7  63+# define zmm8  64+# define zmm9  65+# define zmm10 66+# define zmm11 67+# define zmm12 68+# define zmm13 69+# define zmm14 70+# define zmm15 71++-- Note: these are only needed for ARM/ARM64 because globalRegMaybe is now used in CmmSink.hs.+-- Since it's only used to check 'isJust', the actual values don't matter, thus+-- I'm not sure if these are the correct numberings.+-- Normally, the register names are just stringified as part of the REG() macro++#elif MACHREGS_powerpc || MACHREGS_arm || MACHREGS_aarch64++# define r0 0+# define r1 1+# define r2 2+# define r3 3+# define r4 4+# define r5 5+# define r6 6+# define r7 7+# define r8 8+# define r9 9+# define r10 10+# define r11 11+# define r12 12+# define r13 13+# define r14 14+# define r15 15+# define r16 16+# define r17 17+# define r18 18+# define r19 19+# define r20 20+# define r21 21+# define r22 22+# define r23 23+# define r24 24+# define r25 25+# define r26 26+# define r27 27+# define r28 28+# define r29 29+# define r30 30+# define r31 31++-- See note above. These aren't actually used for anything except satisfying the compiler for globalRegMaybe+-- so I'm unsure if they're the correct numberings, should they ever be attempted to be used in the NCG. +#if MACHREGS_aarch64 || MACHREGS_arm+# define s0 32+# define s1 33+# define s2 34+# define s3 35+# define s4 36+# define s5 37+# define s6 38+# define s7 39+# define s8 40+# define s9 41+# define s10 42+# define s11 43+# define s12 44+# define s13 45+# define s14 46+# define s15 47+# define s16 48+# define s17 49+# define s18 50+# define s19 51+# define s20 52+# define s21 53+# define s22 54+# define s23 55+# define s24 56+# define s25 57+# define s26 58+# define s27 59+# define s28 60+# define s29 61+# define s30 62+# define s31 63++# define d0 32+# define d1 33+# define d2 34+# define d3 35+# define d4 36+# define d5 37+# define d6 38+# define d7 39+# define d8 40+# define d9 41+# define d10 42+# define d11 43+# define d12 44+# define d13 45+# define d14 46+# define d15 47+# define d16 48+# define d17 49+# define d18 50+# define d19 51+# define d20 52+# define d21 53+# define d22 54+# define d23 55+# define d24 56+# define d25 57+# define d26 58+# define d27 59+# define d28 60+# define d29 61+# define d30 62+# define d31 63+#endif++# if MACHREGS_darwin+#  define f0  32+#  define f1  33+#  define f2  34+#  define f3  35+#  define f4  36+#  define f5  37+#  define f6  38+#  define f7  39+#  define f8  40+#  define f9  41+#  define f10 42+#  define f11 43+#  define f12 44+#  define f13 45+#  define f14 46+#  define f15 47+#  define f16 48+#  define f17 49+#  define f18 50+#  define f19 51+#  define f20 52+#  define f21 53+#  define f22 54+#  define f23 55+#  define f24 56+#  define f25 57+#  define f26 58+#  define f27 59+#  define f28 60+#  define f29 61+#  define f30 62+#  define f31 63+# else+#  define fr0  32+#  define fr1  33+#  define fr2  34+#  define fr3  35+#  define fr4  36+#  define fr5  37+#  define fr6  38+#  define fr7  39+#  define fr8  40+#  define fr9  41+#  define fr10 42+#  define fr11 43+#  define fr12 44+#  define fr13 45+#  define fr14 46+#  define fr15 47+#  define fr16 48+#  define fr17 49+#  define fr18 50+#  define fr19 51+#  define fr20 52+#  define fr21 53+#  define fr22 54+#  define fr23 55+#  define fr24 56+#  define fr25 57+#  define fr26 58+#  define fr27 59+#  define fr28 60+#  define fr29 61+#  define fr30 62+#  define fr31 63+# endif++#elif MACHREGS_sparc++# define g0  0+# define g1  1+# define g2  2+# define g3  3+# define g4  4+# define g5  5+# define g6  6+# define g7  7++# define o0  8+# define o1  9+# define o2  10+# define o3  11+# define o4  12+# define o5  13+# define o6  14+# define o7  15++# define l0  16+# define l1  17+# define l2  18+# define l3  19+# define l4  20+# define l5  21+# define l6  22+# define l7  23++# define i0  24+# define i1  25+# define i2  26+# define i3  27+# define i4  28+# define i5  29+# define i6  30+# define i7  31++# define f0  32+# define f1  33+# define f2  34+# define f3  35+# define f4  36+# define f5  37+# define f6  38+# define f7  39+# define f8  40+# define f9  41+# define f10 42+# define f11 43+# define f12 44+# define f13 45+# define f14 46+# define f15 47+# define f16 48+# define f17 49+# define f18 50+# define f19 51+# define f20 52+# define f21 53+# define f22 54+# define f23 55+# define f24 56+# define f25 57+# define f26 58+# define f27 59+# define f28 60+# define f29 61+# define f30 62+# define f31 63++#endif++callerSaves :: GlobalReg -> Bool+#ifdef CALLER_SAVES_Base+callerSaves BaseReg           = True+#endif+#ifdef CALLER_SAVES_R1+callerSaves (VanillaReg 1 _)  = True+#endif+#ifdef CALLER_SAVES_R2+callerSaves (VanillaReg 2 _)  = True+#endif+#ifdef CALLER_SAVES_R3+callerSaves (VanillaReg 3 _)  = True+#endif+#ifdef CALLER_SAVES_R4+callerSaves (VanillaReg 4 _)  = True+#endif+#ifdef CALLER_SAVES_R5+callerSaves (VanillaReg 5 _)  = True+#endif+#ifdef CALLER_SAVES_R6+callerSaves (VanillaReg 6 _)  = True+#endif+#ifdef CALLER_SAVES_R7+callerSaves (VanillaReg 7 _)  = True+#endif+#ifdef CALLER_SAVES_R8+callerSaves (VanillaReg 8 _)  = True+#endif+#ifdef CALLER_SAVES_R9+callerSaves (VanillaReg 9 _)  = True+#endif+#ifdef CALLER_SAVES_R10+callerSaves (VanillaReg 10 _) = True+#endif+#ifdef CALLER_SAVES_F1+callerSaves (FloatReg 1)      = True+#endif+#ifdef CALLER_SAVES_F2+callerSaves (FloatReg 2)      = True+#endif+#ifdef CALLER_SAVES_F3+callerSaves (FloatReg 3)      = True+#endif+#ifdef CALLER_SAVES_F4+callerSaves (FloatReg 4)      = True+#endif+#ifdef CALLER_SAVES_F5+callerSaves (FloatReg 5)      = True+#endif+#ifdef CALLER_SAVES_F6+callerSaves (FloatReg 6)      = True+#endif+#ifdef CALLER_SAVES_D1+callerSaves (DoubleReg 1)     = True+#endif+#ifdef CALLER_SAVES_D2+callerSaves (DoubleReg 2)     = True+#endif+#ifdef CALLER_SAVES_D3+callerSaves (DoubleReg 3)     = True+#endif+#ifdef CALLER_SAVES_D4+callerSaves (DoubleReg 4)     = True+#endif+#ifdef CALLER_SAVES_D5+callerSaves (DoubleReg 5)     = True+#endif+#ifdef CALLER_SAVES_D6+callerSaves (DoubleReg 6)     = True+#endif+#ifdef CALLER_SAVES_L1+callerSaves (LongReg 1)       = True+#endif+#ifdef CALLER_SAVES_Sp+callerSaves Sp                = True+#endif+#ifdef CALLER_SAVES_SpLim+callerSaves SpLim             = True+#endif+#ifdef CALLER_SAVES_Hp+callerSaves Hp                = True+#endif+#ifdef CALLER_SAVES_HpLim+callerSaves HpLim             = True+#endif+#ifdef CALLER_SAVES_CCCS+callerSaves CCCS              = True+#endif+#ifdef CALLER_SAVES_CurrentTSO+callerSaves CurrentTSO        = True+#endif+#ifdef CALLER_SAVES_CurrentNursery+callerSaves CurrentNursery    = True+#endif+callerSaves _                 = False++activeStgRegs :: [GlobalReg]+activeStgRegs = [+#ifdef REG_Base+    BaseReg+#endif+#ifdef REG_Sp+    ,Sp+#endif+#ifdef REG_Hp+    ,Hp+#endif+#ifdef REG_R1+    ,VanillaReg 1 VGcPtr+#endif+#ifdef REG_R2+    ,VanillaReg 2 VGcPtr+#endif+#ifdef REG_R3+    ,VanillaReg 3 VGcPtr+#endif+#ifdef REG_R4+    ,VanillaReg 4 VGcPtr+#endif+#ifdef REG_R5+    ,VanillaReg 5 VGcPtr+#endif+#ifdef REG_R6+    ,VanillaReg 6 VGcPtr+#endif+#ifdef REG_R7+    ,VanillaReg 7 VGcPtr+#endif+#ifdef REG_R8+    ,VanillaReg 8 VGcPtr+#endif+#ifdef REG_R9+    ,VanillaReg 9 VGcPtr+#endif+#ifdef REG_R10+    ,VanillaReg 10 VGcPtr+#endif+#ifdef REG_SpLim+    ,SpLim+#endif+#if MAX_REAL_XMM_REG != 0+#ifdef REG_F1+    ,FloatReg 1+#endif+#ifdef REG_D1+    ,DoubleReg 1+#endif+#ifdef REG_XMM1+    ,XmmReg 1+#endif+#ifdef REG_YMM1+    ,YmmReg 1+#endif+#ifdef REG_ZMM1+    ,ZmmReg 1+#endif+#ifdef REG_F2+    ,FloatReg 2+#endif+#ifdef REG_D2+    ,DoubleReg 2+#endif+#ifdef REG_XMM2+    ,XmmReg 2+#endif+#ifdef REG_YMM2+    ,YmmReg 2+#endif+#ifdef REG_ZMM2+    ,ZmmReg 2+#endif+#ifdef REG_F3+    ,FloatReg 3+#endif+#ifdef REG_D3+    ,DoubleReg 3+#endif+#ifdef REG_XMM3+    ,XmmReg 3+#endif+#ifdef REG_YMM3+    ,YmmReg 3+#endif+#ifdef REG_ZMM3+    ,ZmmReg 3+#endif+#ifdef REG_F4+    ,FloatReg 4+#endif+#ifdef REG_D4+    ,DoubleReg 4+#endif+#ifdef REG_XMM4+    ,XmmReg 4+#endif+#ifdef REG_YMM4+    ,YmmReg 4+#endif+#ifdef REG_ZMM4+    ,ZmmReg 4+#endif+#ifdef REG_F5+    ,FloatReg 5+#endif+#ifdef REG_D5+    ,DoubleReg 5+#endif+#ifdef REG_XMM5+    ,XmmReg 5+#endif+#ifdef REG_YMM5+    ,YmmReg 5+#endif+#ifdef REG_ZMM5+    ,ZmmReg 5+#endif+#ifdef REG_F6+    ,FloatReg 6+#endif+#ifdef REG_D6+    ,DoubleReg 6+#endif+#ifdef REG_XMM6+    ,XmmReg 6+#endif+#ifdef REG_YMM6+    ,YmmReg 6+#endif+#ifdef REG_ZMM6+    ,ZmmReg 6+#endif+#else /* MAX_REAL_XMM_REG == 0 */+#ifdef REG_F1+    ,FloatReg 1+#endif+#ifdef REG_F2+    ,FloatReg 2+#endif+#ifdef REG_F3+    ,FloatReg 3+#endif+#ifdef REG_F4+    ,FloatReg 4+#endif+#ifdef REG_F5+    ,FloatReg 5+#endif+#ifdef REG_F6+    ,FloatReg 6+#endif+#ifdef REG_D1+    ,DoubleReg 1+#endif+#ifdef REG_D2+    ,DoubleReg 2+#endif+#ifdef REG_D3+    ,DoubleReg 3+#endif+#ifdef REG_D4+    ,DoubleReg 4+#endif+#ifdef REG_D5+    ,DoubleReg 5+#endif+#ifdef REG_D6+    ,DoubleReg 6+#endif+#endif /* MAX_REAL_XMM_REG == 0 */+    ]++haveRegBase :: Bool+#ifdef REG_Base+haveRegBase = True+#else+haveRegBase = False+#endif++--  | Returns 'Nothing' if this global register is not stored+-- in a real machine register, otherwise returns @'Just' reg@, where+-- reg is the machine register it is stored in.+globalRegMaybe :: GlobalReg -> Maybe RealReg+#if MACHREGS_i386 || MACHREGS_x86_64 || MACHREGS_sparc || MACHREGS_powerpc || MACHREGS_arm || MACHREGS_aarch64+# ifdef REG_Base+globalRegMaybe BaseReg                  = Just (RealRegSingle REG_Base)+# endif+# ifdef REG_R1+globalRegMaybe (VanillaReg 1 _)         = Just (RealRegSingle REG_R1)+# endif+# ifdef REG_R2+globalRegMaybe (VanillaReg 2 _)         = Just (RealRegSingle REG_R2)+# endif+# ifdef REG_R3+globalRegMaybe (VanillaReg 3 _)         = Just (RealRegSingle REG_R3)+# endif+# ifdef REG_R4+globalRegMaybe (VanillaReg 4 _)         = Just (RealRegSingle REG_R4)+# endif+# ifdef REG_R5+globalRegMaybe (VanillaReg 5 _)         = Just (RealRegSingle REG_R5)+# endif+# ifdef REG_R6+globalRegMaybe (VanillaReg 6 _)         = Just (RealRegSingle REG_R6)+# endif+# ifdef REG_R7+globalRegMaybe (VanillaReg 7 _)         = Just (RealRegSingle REG_R7)+# endif+# ifdef REG_R8+globalRegMaybe (VanillaReg 8 _)         = Just (RealRegSingle REG_R8)+# endif+# ifdef REG_R9+globalRegMaybe (VanillaReg 9 _)         = Just (RealRegSingle REG_R9)+# endif+# ifdef REG_R10+globalRegMaybe (VanillaReg 10 _)        = Just (RealRegSingle REG_R10)+# endif+# ifdef REG_F1+globalRegMaybe (FloatReg 1)             = Just (RealRegSingle REG_F1)+# endif+# ifdef REG_F2+globalRegMaybe (FloatReg 2)             = Just (RealRegSingle REG_F2)+# endif+# ifdef REG_F3+globalRegMaybe (FloatReg 3)             = Just (RealRegSingle REG_F3)+# endif+# ifdef REG_F4+globalRegMaybe (FloatReg 4)             = Just (RealRegSingle REG_F4)+# endif+# ifdef REG_F5+globalRegMaybe (FloatReg 5)             = Just (RealRegSingle REG_F5)+# endif+# ifdef REG_F6+globalRegMaybe (FloatReg 6)             = Just (RealRegSingle REG_F6)+# endif+# ifdef REG_D1+globalRegMaybe (DoubleReg 1)            =+#  if MACHREGS_sparc+                                          Just (RealRegPair REG_D1 (REG_D1 + 1))+#  else+                                          Just (RealRegSingle REG_D1)+#  endif+# endif+# ifdef REG_D2+globalRegMaybe (DoubleReg 2)            =+#  if MACHREGS_sparc+                                          Just (RealRegPair REG_D2 (REG_D2 + 1))+#  else+                                          Just (RealRegSingle REG_D2)+#  endif+# endif+# ifdef REG_D3+globalRegMaybe (DoubleReg 3)            =+#  if MACHREGS_sparc+                                          Just (RealRegPair REG_D3 (REG_D3 + 1))+#  else+                                          Just (RealRegSingle REG_D3)+#  endif+# endif+# ifdef REG_D4+globalRegMaybe (DoubleReg 4)            =+#  if MACHREGS_sparc+                                          Just (RealRegPair REG_D4 (REG_D4 + 1))+#  else+                                          Just (RealRegSingle REG_D4)+#  endif+# endif+# ifdef REG_D5+globalRegMaybe (DoubleReg 5)            =+#  if MACHREGS_sparc+                                          Just (RealRegPair REG_D5 (REG_D5 + 1))+#  else+                                          Just (RealRegSingle REG_D5)+#  endif+# endif+# ifdef REG_D6+globalRegMaybe (DoubleReg 6)            =+#  if MACHREGS_sparc+                                          Just (RealRegPair REG_D6 (REG_D6 + 1))+#  else+                                          Just (RealRegSingle REG_D6)+#  endif+# endif+# if MAX_REAL_XMM_REG != 0+#  ifdef REG_XMM1+globalRegMaybe (XmmReg 1)               = Just (RealRegSingle REG_XMM1)+#  endif+#  ifdef REG_XMM2+globalRegMaybe (XmmReg 2)               = Just (RealRegSingle REG_XMM2)+#  endif+#  ifdef REG_XMM3+globalRegMaybe (XmmReg 3)               = Just (RealRegSingle REG_XMM3)+#  endif+#  ifdef REG_XMM4+globalRegMaybe (XmmReg 4)               = Just (RealRegSingle REG_XMM4)+#  endif+#  ifdef REG_XMM5+globalRegMaybe (XmmReg 5)               = Just (RealRegSingle REG_XMM5)+#  endif+#  ifdef REG_XMM6+globalRegMaybe (XmmReg 6)               = Just (RealRegSingle REG_XMM6)+#  endif+# endif+# if MAX_REAL_YMM_REG != 0+#  ifdef REG_YMM1+globalRegMaybe (YmmReg 1)               = Just (RealRegSingle REG_YMM1)+#  endif+#  ifdef REG_YMM2+globalRegMaybe (YmmReg 2)               = Just (RealRegSingle REG_YMM2)+#  endif+#  ifdef REG_YMM3+globalRegMaybe (YmmReg 3)               = Just (RealRegSingle REG_YMM3)+#  endif+#  ifdef REG_YMM4+globalRegMaybe (YmmReg 4)               = Just (RealRegSingle REG_YMM4)+#  endif+#  ifdef REG_YMM5+globalRegMaybe (YmmReg 5)               = Just (RealRegSingle REG_YMM5)+#  endif+#  ifdef REG_YMM6+globalRegMaybe (YmmReg 6)               = Just (RealRegSingle REG_YMM6)+#  endif+# endif+# if MAX_REAL_ZMM_REG != 0+#  ifdef REG_ZMM1+globalRegMaybe (ZmmReg 1)               = Just (RealRegSingle REG_ZMM1)+#  endif+#  ifdef REG_ZMM2+globalRegMaybe (ZmmReg 2)               = Just (RealRegSingle REG_ZMM2)+#  endif+#  ifdef REG_ZMM3+globalRegMaybe (ZmmReg 3)               = Just (RealRegSingle REG_ZMM3)+#  endif+#  ifdef REG_ZMM4+globalRegMaybe (ZmmReg 4)               = Just (RealRegSingle REG_ZMM4)+#  endif+#  ifdef REG_ZMM5+globalRegMaybe (ZmmReg 5)               = Just (RealRegSingle REG_ZMM5)+#  endif+#  ifdef REG_ZMM6+globalRegMaybe (ZmmReg 6)               = Just (RealRegSingle REG_ZMM6)+#  endif+# endif+# ifdef REG_Sp+globalRegMaybe Sp                       = Just (RealRegSingle REG_Sp)+# endif+# ifdef REG_Lng1+globalRegMaybe (LongReg 1)              = Just (RealRegSingle REG_Lng1)+# endif+# ifdef REG_Lng2+globalRegMaybe (LongReg 2)              = Just (RealRegSingle REG_Lng2)+# endif+# ifdef REG_SpLim+globalRegMaybe SpLim                    = Just (RealRegSingle REG_SpLim)+# endif+# ifdef REG_Hp+globalRegMaybe Hp                       = Just (RealRegSingle REG_Hp)+# endif+# ifdef REG_HpLim+globalRegMaybe HpLim                    = Just (RealRegSingle REG_HpLim)+# endif+# ifdef REG_CurrentTSO+globalRegMaybe CurrentTSO               = Just (RealRegSingle REG_CurrentTSO)+# endif+# ifdef REG_CurrentNursery+globalRegMaybe CurrentNursery           = Just (RealRegSingle REG_CurrentNursery)+# endif+# ifdef REG_MachSp+globalRegMaybe MachSp                   = Just (RealRegSingle REG_MachSp)+# endif+globalRegMaybe _                        = Nothing+#elif MACHREGS_NO_REGS+globalRegMaybe _ = Nothing+#else+globalRegMaybe = panic "globalRegMaybe not defined for this platform"+#endif++freeReg :: RegNo -> Bool++#if MACHREGS_i386 || MACHREGS_x86_64++# if MACHREGS_i386+freeReg esp = False -- %esp is the C stack pointer+freeReg esi = False -- Note [esi/edi not allocatable]+freeReg edi = False+# endif+# if MACHREGS_x86_64+freeReg rsp = False  --        %rsp is the C stack pointer+# endif++{-+Note [esi/edi not allocatable]++%esi is mapped to R1, so %esi would normally be allocatable while it+is not being used for R1.  However, %esi has no 8-bit version on x86,+and the linear register allocator is not sophisticated enough to+handle this irregularity (we need more RegClasses).  The+graph-colouring allocator also cannot handle this - it was designed+with more flexibility in mind, but the current implementation is+restricted to the same set of classes as the linear allocator.++Hence, on x86 esi and edi are treated as not allocatable.+-}++-- split patterns in two functions to prevent overlaps+freeReg r         = freeRegBase r++freeRegBase :: RegNo -> Bool+# ifdef REG_Base+freeRegBase REG_Base  = False+# endif+# ifdef REG_Sp+freeRegBase REG_Sp    = False+# endif+# ifdef REG_SpLim+freeRegBase REG_SpLim = False+# endif+# ifdef REG_Hp+freeRegBase REG_Hp    = False+# endif+# ifdef REG_HpLim+freeRegBase REG_HpLim = False+# endif+-- All other regs are considered to be "free", because we can track+-- their liveness accurately.+freeRegBase _ = True++#elif MACHREGS_powerpc++freeReg 0 = False -- Used by code setting the back chain pointer+                  -- in stack reallocations on Linux+                  -- r0 is not usable in all insns so also reserved+                  -- on Darwin.+freeReg 1 = False -- The Stack Pointer+# if !MACHREGS_darwin+-- most non-darwin powerpc OSes use r2 as a TOC pointer or something like that+freeReg 2 = False+freeReg 13 = False -- reserved for system thread ID on 64 bit+-- at least linux in -fPIC relies on r30 in PLT stubs+freeReg 30 = False+{- TODO: reserve r13 on 64 bit systems only and r30 on 32 bit respectively.+   For now we use r30 on 64 bit and r13 on 32 bit as a temporary register+   in stack handling code. See compiler/nativeGen/PPC/Ppr.hs.++   Later we might want to reserve r13 and r30 only where it is required.+   Then use r12 as temporary register, which is also what the C ABI does.+-}++# endif+# ifdef REG_Base+freeReg REG_Base  = False+# endif+# ifdef REG_R1+freeReg REG_R1    = False+# endif+# ifdef REG_R2+freeReg REG_R2    = False+# endif+# ifdef REG_R3+freeReg REG_R3    = False+# endif+# ifdef REG_R4+freeReg REG_R4    = False+# endif+# ifdef REG_R5+freeReg REG_R5    = False+# endif+# ifdef REG_R6+freeReg REG_R6    = False+# endif+# ifdef REG_R7+freeReg REG_R7    = False+# endif+# ifdef REG_R8+freeReg REG_R8    = False+# endif+# ifdef REG_R9+freeReg REG_R9    = False+# endif+# ifdef REG_R10+freeReg REG_R10   = False+# endif+# ifdef REG_F1+freeReg REG_F1    = False+# endif+# ifdef REG_F2+freeReg REG_F2    = False+# endif+# ifdef REG_F3+freeReg REG_F3    = False+# endif+# ifdef REG_F4+freeReg REG_F4    = False+# endif+# ifdef REG_F5+freeReg REG_F5    = False+# endif+# ifdef REG_F6+freeReg REG_F6    = False+# endif+# ifdef REG_D1+freeReg REG_D1    = False+# endif+# ifdef REG_D2+freeReg REG_D2    = False+# endif+# ifdef REG_D3+freeReg REG_D3    = False+# endif+# ifdef REG_D4+freeReg REG_D4    = False+# endif+# ifdef REG_D5+freeReg REG_D5    = False+# endif+# ifdef REG_D6+freeReg REG_D6    = False+# endif+# ifdef REG_Sp+freeReg REG_Sp    = False+# endif+# ifdef REG_Su+freeReg REG_Su    = False+# endif+# ifdef REG_SpLim+freeReg REG_SpLim = False+# endif+# ifdef REG_Hp+freeReg REG_Hp    = False+# endif+# ifdef REG_HpLim+freeReg REG_HpLim = False+# endif+freeReg _ = True++#elif MACHREGS_sparc++-- SPARC regs used by the OS / ABI+-- %g0(r0) is always zero+freeReg g0  = False++-- %g5(r5) - %g7(r7)+--  are reserved for the OS+freeReg g5  = False+freeReg g6  = False+freeReg g7  = False++-- %o6(r14)+--  is the C stack pointer+freeReg o6  = False++-- %o7(r15)+--  holds the C return address+freeReg o7  = False++-- %i6(r30)+--  is the C frame pointer+freeReg i6  = False++-- %i7(r31)+--  is used for C return addresses+freeReg i7  = False++-- %f0(r32) - %f1(r32)+--  are C floating point return regs+freeReg f0  = False+freeReg f1  = False++{-+freeReg regNo+    -- don't release high half of double regs+    | regNo >= f0+    , regNo <  NCG_FirstFloatReg+    , regNo `mod` 2 /= 0+    = False+-}++# ifdef REG_Base+freeReg REG_Base  = False+# endif+# ifdef REG_R1+freeReg REG_R1    = False+# endif+# ifdef REG_R2+freeReg REG_R2    = False+# endif+# ifdef REG_R3+freeReg REG_R3    = False+# endif+# ifdef REG_R4+freeReg REG_R4    = False+# endif+# ifdef REG_R5+freeReg REG_R5    = False+# endif+# ifdef REG_R6+freeReg REG_R6    = False+# endif+# ifdef REG_R7+freeReg REG_R7    = False+# endif+# ifdef REG_R8+freeReg REG_R8    = False+# endif+# ifdef REG_R9+freeReg REG_R9    = False+# endif+# ifdef REG_R10+freeReg REG_R10   = False+# endif+# ifdef REG_F1+freeReg REG_F1    = False+# endif+# ifdef REG_F2+freeReg REG_F2    = False+# endif+# ifdef REG_F3+freeReg REG_F3    = False+# endif+# ifdef REG_F4+freeReg REG_F4    = False+# endif+# ifdef REG_F5+freeReg REG_F5    = False+# endif+# ifdef REG_F6+freeReg REG_F6    = False+# endif+# ifdef REG_D1+freeReg REG_D1    = False+# endif+# ifdef REG_D1_2+freeReg REG_D1_2  = False+# endif+# ifdef REG_D2+freeReg REG_D2    = False+# endif+# ifdef REG_D2_2+freeReg REG_D2_2  = False+# endif+# ifdef REG_D3+freeReg REG_D3    = False+# endif+# ifdef REG_D3_2+freeReg REG_D3_2  = False+# endif+# ifdef REG_D4+freeReg REG_D4    = False+# endif+# ifdef REG_D4_2+freeReg REG_D4_2  = False+# endif+# ifdef REG_D5+freeReg REG_D5    = False+# endif+# ifdef REG_D5_2+freeReg REG_D5_2  = False+# endif+# ifdef REG_D6+freeReg REG_D6    = False+# endif+# ifdef REG_D6_2+freeReg REG_D6_2  = False+# endif+# ifdef REG_Sp+freeReg REG_Sp    = False+# endif+# ifdef REG_Su+freeReg REG_Su    = False+# endif+# ifdef REG_SpLim+freeReg REG_SpLim = False+# endif+# ifdef REG_Hp+freeReg REG_Hp    = False+# endif+# ifdef REG_HpLim+freeReg REG_HpLim = False+# endif+freeReg _ = True++#else++freeReg = panic "freeReg not defined for this platform"++#endif+
+ autogen/Config.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE CPP #-}+module Config where++#include "ghc_boot_platform.h"++data IntegerLibrary = IntegerGMP+                    | IntegerSimple+                    deriving Eq++cBuildPlatformString :: String+cBuildPlatformString = BuildPlatform_NAME+cHostPlatformString :: String+cHostPlatformString = HostPlatform_NAME+cTargetPlatformString :: String+cTargetPlatformString = TargetPlatform_NAME++cProjectName          :: String+cProjectName          = "The Glorious Glasgow Haskell Compilation System"+cProjectGitCommitId   :: String+cProjectGitCommitId   = "0cee25253f9f2cb4f19f021fd974bdad3c26a80b"+cProjectVersion       :: String+cProjectVersion       = "8.2.1"+cProjectVersionInt    :: String+cProjectVersionInt    = "802"+cProjectPatchLevel    :: String+cProjectPatchLevel    = "1"+cProjectPatchLevel1   :: String+cProjectPatchLevel1   = "1"+cProjectPatchLevel2   :: String+cProjectPatchLevel2   = ""+cBooterVersion        :: String+cBooterVersion        = "8.0.2"+cStage                :: String+cStage                = show (STAGE :: Int)+cIntegerLibrary       :: String+cIntegerLibrary       = "integer-gmp"+cIntegerLibraryType   :: IntegerLibrary+cIntegerLibraryType   = IntegerGMP+cSupportsSplitObjs    :: String+cSupportsSplitObjs    = "YES"+cGhcWithInterpreter   :: String+cGhcWithInterpreter   = "YES"+cGhcWithNativeCodeGen :: String+cGhcWithNativeCodeGen = "YES"+cGhcWithSMP           :: String+cGhcWithSMP           = "YES"+cGhcRTSWays           :: String+cGhcRTSWays           = "l debug thr thr_debug thr_l  dyn debug_dyn thr_dyn thr_debug_dyn l_dyn thr_l_dyn"+cGhcRtsWithLibdw      :: Bool+cGhcRtsWithLibdw      = False+cGhcEnableTablesNextToCode :: String+cGhcEnableTablesNextToCode = "YES"+cLeadingUnderscore    :: String+cLeadingUnderscore    = "NO"+cGHC_UNLIT_PGM        :: String+cGHC_UNLIT_PGM        = "unlit"+cGHC_SPLIT_PGM        :: String+cGHC_SPLIT_PGM        = "ghc-split"+cLibFFI               :: Bool+cLibFFI               = False+cGhcThreaded :: Bool+cGhcThreaded = True+cGhcDebugged :: Bool+cGhcDebugged = False
+ autogen/GHCConstantsHaskellExports.hs view
@@ -0,0 +1,125 @@+    cONTROL_GROUP_CONST_291,+    sTD_HDR_SIZE,+    pROF_HDR_SIZE,+    bLOCK_SIZE,+    bLOCKS_PER_MBLOCK,+    tICKY_BIN_COUNT,+    oFFSET_StgRegTable_rR1,+    oFFSET_StgRegTable_rR2,+    oFFSET_StgRegTable_rR3,+    oFFSET_StgRegTable_rR4,+    oFFSET_StgRegTable_rR5,+    oFFSET_StgRegTable_rR6,+    oFFSET_StgRegTable_rR7,+    oFFSET_StgRegTable_rR8,+    oFFSET_StgRegTable_rR9,+    oFFSET_StgRegTable_rR10,+    oFFSET_StgRegTable_rF1,+    oFFSET_StgRegTable_rF2,+    oFFSET_StgRegTable_rF3,+    oFFSET_StgRegTable_rF4,+    oFFSET_StgRegTable_rF5,+    oFFSET_StgRegTable_rF6,+    oFFSET_StgRegTable_rD1,+    oFFSET_StgRegTable_rD2,+    oFFSET_StgRegTable_rD3,+    oFFSET_StgRegTable_rD4,+    oFFSET_StgRegTable_rD5,+    oFFSET_StgRegTable_rD6,+    oFFSET_StgRegTable_rXMM1,+    oFFSET_StgRegTable_rXMM2,+    oFFSET_StgRegTable_rXMM3,+    oFFSET_StgRegTable_rXMM4,+    oFFSET_StgRegTable_rXMM5,+    oFFSET_StgRegTable_rXMM6,+    oFFSET_StgRegTable_rYMM1,+    oFFSET_StgRegTable_rYMM2,+    oFFSET_StgRegTable_rYMM3,+    oFFSET_StgRegTable_rYMM4,+    oFFSET_StgRegTable_rYMM5,+    oFFSET_StgRegTable_rYMM6,+    oFFSET_StgRegTable_rZMM1,+    oFFSET_StgRegTable_rZMM2,+    oFFSET_StgRegTable_rZMM3,+    oFFSET_StgRegTable_rZMM4,+    oFFSET_StgRegTable_rZMM5,+    oFFSET_StgRegTable_rZMM6,+    oFFSET_StgRegTable_rL1,+    oFFSET_StgRegTable_rSp,+    oFFSET_StgRegTable_rSpLim,+    oFFSET_StgRegTable_rHp,+    oFFSET_StgRegTable_rHpLim,+    oFFSET_StgRegTable_rCCCS,+    oFFSET_StgRegTable_rCurrentTSO,+    oFFSET_StgRegTable_rCurrentNursery,+    oFFSET_StgRegTable_rHpAlloc,+    oFFSET_stgEagerBlackholeInfo,+    oFFSET_stgGCEnter1,+    oFFSET_stgGCFun,+    oFFSET_Capability_r,+    oFFSET_bdescr_start,+    oFFSET_bdescr_free,+    oFFSET_bdescr_blocks,+    oFFSET_bdescr_flags,+    sIZEOF_CostCentreStack,+    oFFSET_CostCentreStack_mem_alloc,+    oFFSET_CostCentreStack_scc_count,+    oFFSET_StgHeader_ccs,+    oFFSET_StgHeader_ldvw,+    sIZEOF_StgSMPThunkHeader,+    oFFSET_StgEntCounter_allocs,+    oFFSET_StgEntCounter_allocd,+    oFFSET_StgEntCounter_registeredp,+    oFFSET_StgEntCounter_link,+    oFFSET_StgEntCounter_entry_count,+    sIZEOF_StgUpdateFrame_NoHdr,+    sIZEOF_StgMutArrPtrs_NoHdr,+    oFFSET_StgMutArrPtrs_ptrs,+    oFFSET_StgMutArrPtrs_size,+    sIZEOF_StgSmallMutArrPtrs_NoHdr,+    oFFSET_StgSmallMutArrPtrs_ptrs,+    sIZEOF_StgArrBytes_NoHdr,+    oFFSET_StgArrBytes_bytes,+    oFFSET_StgTSO_alloc_limit,+    oFFSET_StgTSO_cccs,+    oFFSET_StgTSO_stackobj,+    oFFSET_StgStack_sp,+    oFFSET_StgStack_stack,+    oFFSET_StgUpdateFrame_updatee,+    oFFSET_StgFunInfoExtraFwd_arity,+    sIZEOF_StgFunInfoExtraRev,+    oFFSET_StgFunInfoExtraRev_arity,+    mAX_SPEC_SELECTEE_SIZE,+    mAX_SPEC_AP_SIZE,+    mIN_PAYLOAD_SIZE,+    mIN_INTLIKE,+    mAX_INTLIKE,+    mIN_CHARLIKE,+    mAX_CHARLIKE,+    mUT_ARR_PTRS_CARD_BITS,+    mAX_Vanilla_REG,+    mAX_Float_REG,+    mAX_Double_REG,+    mAX_Long_REG,+    mAX_XMM_REG,+    mAX_Real_Vanilla_REG,+    mAX_Real_Float_REG,+    mAX_Real_Double_REG,+    mAX_Real_XMM_REG,+    mAX_Real_Long_REG,+    rESERVED_C_STACK_BYTES,+    rESERVED_STACK_WORDS,+    aP_STACK_SPLIM,+    wORD_SIZE,+    dOUBLE_SIZE,+    cINT_SIZE,+    cLONG_SIZE,+    cLONG_LONG_SIZE,+    bITMAP_BITS_SHIFT,+    tAG_BITS,+    wORDS_BIGENDIAN,+    dYNAMIC_BY_DEFAULT,+    lDV_SHIFT,+    iLDV_CREATE_MASK,+    iLDV_STATE_CREATE,+    iLDV_STATE_USE,
+ autogen/GHCConstantsHaskellType.hs view
@@ -0,0 +1,134 @@+data PlatformConstants = PlatformConstants {+    pc_platformConstants :: ()+    , pc_CONTROL_GROUP_CONST_291 :: Int+    , pc_STD_HDR_SIZE :: Int+    , pc_PROF_HDR_SIZE :: Int+    , pc_BLOCK_SIZE :: Int+    , pc_BLOCKS_PER_MBLOCK :: Int+    , pc_TICKY_BIN_COUNT :: Int+    , pc_OFFSET_StgRegTable_rR1 :: Int+    , pc_OFFSET_StgRegTable_rR2 :: Int+    , pc_OFFSET_StgRegTable_rR3 :: Int+    , pc_OFFSET_StgRegTable_rR4 :: Int+    , pc_OFFSET_StgRegTable_rR5 :: Int+    , pc_OFFSET_StgRegTable_rR6 :: Int+    , pc_OFFSET_StgRegTable_rR7 :: Int+    , pc_OFFSET_StgRegTable_rR8 :: Int+    , pc_OFFSET_StgRegTable_rR9 :: Int+    , pc_OFFSET_StgRegTable_rR10 :: Int+    , pc_OFFSET_StgRegTable_rF1 :: Int+    , pc_OFFSET_StgRegTable_rF2 :: Int+    , pc_OFFSET_StgRegTable_rF3 :: Int+    , pc_OFFSET_StgRegTable_rF4 :: Int+    , pc_OFFSET_StgRegTable_rF5 :: Int+    , pc_OFFSET_StgRegTable_rF6 :: Int+    , pc_OFFSET_StgRegTable_rD1 :: Int+    , pc_OFFSET_StgRegTable_rD2 :: Int+    , pc_OFFSET_StgRegTable_rD3 :: Int+    , pc_OFFSET_StgRegTable_rD4 :: Int+    , pc_OFFSET_StgRegTable_rD5 :: Int+    , pc_OFFSET_StgRegTable_rD6 :: Int+    , pc_OFFSET_StgRegTable_rXMM1 :: Int+    , pc_OFFSET_StgRegTable_rXMM2 :: Int+    , pc_OFFSET_StgRegTable_rXMM3 :: Int+    , pc_OFFSET_StgRegTable_rXMM4 :: Int+    , pc_OFFSET_StgRegTable_rXMM5 :: Int+    , pc_OFFSET_StgRegTable_rXMM6 :: Int+    , pc_OFFSET_StgRegTable_rYMM1 :: Int+    , pc_OFFSET_StgRegTable_rYMM2 :: Int+    , pc_OFFSET_StgRegTable_rYMM3 :: Int+    , pc_OFFSET_StgRegTable_rYMM4 :: Int+    , pc_OFFSET_StgRegTable_rYMM5 :: Int+    , pc_OFFSET_StgRegTable_rYMM6 :: Int+    , pc_OFFSET_StgRegTable_rZMM1 :: Int+    , pc_OFFSET_StgRegTable_rZMM2 :: Int+    , pc_OFFSET_StgRegTable_rZMM3 :: Int+    , pc_OFFSET_StgRegTable_rZMM4 :: Int+    , pc_OFFSET_StgRegTable_rZMM5 :: Int+    , pc_OFFSET_StgRegTable_rZMM6 :: Int+    , pc_OFFSET_StgRegTable_rL1 :: Int+    , pc_OFFSET_StgRegTable_rSp :: Int+    , pc_OFFSET_StgRegTable_rSpLim :: Int+    , pc_OFFSET_StgRegTable_rHp :: Int+    , pc_OFFSET_StgRegTable_rHpLim :: Int+    , pc_OFFSET_StgRegTable_rCCCS :: Int+    , pc_OFFSET_StgRegTable_rCurrentTSO :: Int+    , pc_OFFSET_StgRegTable_rCurrentNursery :: Int+    , pc_OFFSET_StgRegTable_rHpAlloc :: Int+    , pc_OFFSET_stgEagerBlackholeInfo :: Int+    , pc_OFFSET_stgGCEnter1 :: Int+    , pc_OFFSET_stgGCFun :: Int+    , pc_OFFSET_Capability_r :: Int+    , pc_OFFSET_bdescr_start :: Int+    , pc_OFFSET_bdescr_free :: Int+    , pc_OFFSET_bdescr_blocks :: Int+    , pc_OFFSET_bdescr_flags :: Int+    , pc_SIZEOF_CostCentreStack :: Int+    , pc_OFFSET_CostCentreStack_mem_alloc :: Int+    , pc_REP_CostCentreStack_mem_alloc :: Int+    , pc_OFFSET_CostCentreStack_scc_count :: Int+    , pc_REP_CostCentreStack_scc_count :: Int+    , pc_OFFSET_StgHeader_ccs :: Int+    , pc_OFFSET_StgHeader_ldvw :: Int+    , pc_SIZEOF_StgSMPThunkHeader :: Int+    , pc_OFFSET_StgEntCounter_allocs :: Int+    , pc_REP_StgEntCounter_allocs :: Int+    , pc_OFFSET_StgEntCounter_allocd :: Int+    , pc_REP_StgEntCounter_allocd :: Int+    , pc_OFFSET_StgEntCounter_registeredp :: Int+    , pc_OFFSET_StgEntCounter_link :: Int+    , pc_OFFSET_StgEntCounter_entry_count :: Int+    , pc_SIZEOF_StgUpdateFrame_NoHdr :: Int+    , pc_SIZEOF_StgMutArrPtrs_NoHdr :: Int+    , pc_OFFSET_StgMutArrPtrs_ptrs :: Int+    , pc_OFFSET_StgMutArrPtrs_size :: Int+    , pc_SIZEOF_StgSmallMutArrPtrs_NoHdr :: Int+    , pc_OFFSET_StgSmallMutArrPtrs_ptrs :: Int+    , pc_SIZEOF_StgArrBytes_NoHdr :: Int+    , pc_OFFSET_StgArrBytes_bytes :: Int+    , pc_OFFSET_StgTSO_alloc_limit :: Int+    , pc_OFFSET_StgTSO_cccs :: Int+    , pc_OFFSET_StgTSO_stackobj :: Int+    , pc_OFFSET_StgStack_sp :: Int+    , pc_OFFSET_StgStack_stack :: Int+    , pc_OFFSET_StgUpdateFrame_updatee :: Int+    , pc_OFFSET_StgFunInfoExtraFwd_arity :: Int+    , pc_REP_StgFunInfoExtraFwd_arity :: Int+    , pc_SIZEOF_StgFunInfoExtraRev :: Int+    , pc_OFFSET_StgFunInfoExtraRev_arity :: Int+    , pc_REP_StgFunInfoExtraRev_arity :: Int+    , pc_MAX_SPEC_SELECTEE_SIZE :: Int+    , pc_MAX_SPEC_AP_SIZE :: Int+    , pc_MIN_PAYLOAD_SIZE :: Int+    , pc_MIN_INTLIKE :: Int+    , pc_MAX_INTLIKE :: Int+    , pc_MIN_CHARLIKE :: Int+    , pc_MAX_CHARLIKE :: Int+    , pc_MUT_ARR_PTRS_CARD_BITS :: Int+    , pc_MAX_Vanilla_REG :: Int+    , pc_MAX_Float_REG :: Int+    , pc_MAX_Double_REG :: Int+    , pc_MAX_Long_REG :: Int+    , pc_MAX_XMM_REG :: Int+    , pc_MAX_Real_Vanilla_REG :: Int+    , pc_MAX_Real_Float_REG :: Int+    , pc_MAX_Real_Double_REG :: Int+    , pc_MAX_Real_XMM_REG :: Int+    , pc_MAX_Real_Long_REG :: Int+    , pc_RESERVED_C_STACK_BYTES :: Int+    , pc_RESERVED_STACK_WORDS :: Int+    , pc_AP_STACK_SPLIM :: Int+    , pc_WORD_SIZE :: Int+    , pc_DOUBLE_SIZE :: Int+    , pc_CINT_SIZE :: Int+    , pc_CLONG_SIZE :: Int+    , pc_CLONG_LONG_SIZE :: Int+    , pc_BITMAP_BITS_SHIFT :: Int+    , pc_TAG_BITS :: Int+    , pc_WORDS_BIGENDIAN :: Bool+    , pc_DYNAMIC_BY_DEFAULT :: Bool+    , pc_LDV_SHIFT :: Int+    , pc_ILDV_CREATE_MASK :: Integer+    , pc_ILDV_STATE_CREATE :: Integer+    , pc_ILDV_STATE_USE :: Integer+  } deriving Read
+ autogen/GHCConstantsHaskellWrappers.hs view
@@ -0,0 +1,250 @@+cONTROL_GROUP_CONST_291 :: DynFlags -> Int+cONTROL_GROUP_CONST_291 dflags = pc_CONTROL_GROUP_CONST_291 (sPlatformConstants (settings dflags))+sTD_HDR_SIZE :: DynFlags -> Int+sTD_HDR_SIZE dflags = pc_STD_HDR_SIZE (sPlatformConstants (settings dflags))+pROF_HDR_SIZE :: DynFlags -> Int+pROF_HDR_SIZE dflags = pc_PROF_HDR_SIZE (sPlatformConstants (settings dflags))+bLOCK_SIZE :: DynFlags -> Int+bLOCK_SIZE dflags = pc_BLOCK_SIZE (sPlatformConstants (settings dflags))+bLOCKS_PER_MBLOCK :: DynFlags -> Int+bLOCKS_PER_MBLOCK dflags = pc_BLOCKS_PER_MBLOCK (sPlatformConstants (settings dflags))+tICKY_BIN_COUNT :: DynFlags -> Int+tICKY_BIN_COUNT dflags = pc_TICKY_BIN_COUNT (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rR1 :: DynFlags -> Int+oFFSET_StgRegTable_rR1 dflags = pc_OFFSET_StgRegTable_rR1 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rR2 :: DynFlags -> Int+oFFSET_StgRegTable_rR2 dflags = pc_OFFSET_StgRegTable_rR2 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rR3 :: DynFlags -> Int+oFFSET_StgRegTable_rR3 dflags = pc_OFFSET_StgRegTable_rR3 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rR4 :: DynFlags -> Int+oFFSET_StgRegTable_rR4 dflags = pc_OFFSET_StgRegTable_rR4 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rR5 :: DynFlags -> Int+oFFSET_StgRegTable_rR5 dflags = pc_OFFSET_StgRegTable_rR5 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rR6 :: DynFlags -> Int+oFFSET_StgRegTable_rR6 dflags = pc_OFFSET_StgRegTable_rR6 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rR7 :: DynFlags -> Int+oFFSET_StgRegTable_rR7 dflags = pc_OFFSET_StgRegTable_rR7 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rR8 :: DynFlags -> Int+oFFSET_StgRegTable_rR8 dflags = pc_OFFSET_StgRegTable_rR8 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rR9 :: DynFlags -> Int+oFFSET_StgRegTable_rR9 dflags = pc_OFFSET_StgRegTable_rR9 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rR10 :: DynFlags -> Int+oFFSET_StgRegTable_rR10 dflags = pc_OFFSET_StgRegTable_rR10 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rF1 :: DynFlags -> Int+oFFSET_StgRegTable_rF1 dflags = pc_OFFSET_StgRegTable_rF1 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rF2 :: DynFlags -> Int+oFFSET_StgRegTable_rF2 dflags = pc_OFFSET_StgRegTable_rF2 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rF3 :: DynFlags -> Int+oFFSET_StgRegTable_rF3 dflags = pc_OFFSET_StgRegTable_rF3 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rF4 :: DynFlags -> Int+oFFSET_StgRegTable_rF4 dflags = pc_OFFSET_StgRegTable_rF4 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rF5 :: DynFlags -> Int+oFFSET_StgRegTable_rF5 dflags = pc_OFFSET_StgRegTable_rF5 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rF6 :: DynFlags -> Int+oFFSET_StgRegTable_rF6 dflags = pc_OFFSET_StgRegTable_rF6 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rD1 :: DynFlags -> Int+oFFSET_StgRegTable_rD1 dflags = pc_OFFSET_StgRegTable_rD1 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rD2 :: DynFlags -> Int+oFFSET_StgRegTable_rD2 dflags = pc_OFFSET_StgRegTable_rD2 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rD3 :: DynFlags -> Int+oFFSET_StgRegTable_rD3 dflags = pc_OFFSET_StgRegTable_rD3 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rD4 :: DynFlags -> Int+oFFSET_StgRegTable_rD4 dflags = pc_OFFSET_StgRegTable_rD4 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rD5 :: DynFlags -> Int+oFFSET_StgRegTable_rD5 dflags = pc_OFFSET_StgRegTable_rD5 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rD6 :: DynFlags -> Int+oFFSET_StgRegTable_rD6 dflags = pc_OFFSET_StgRegTable_rD6 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rXMM1 :: DynFlags -> Int+oFFSET_StgRegTable_rXMM1 dflags = pc_OFFSET_StgRegTable_rXMM1 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rXMM2 :: DynFlags -> Int+oFFSET_StgRegTable_rXMM2 dflags = pc_OFFSET_StgRegTable_rXMM2 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rXMM3 :: DynFlags -> Int+oFFSET_StgRegTable_rXMM3 dflags = pc_OFFSET_StgRegTable_rXMM3 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rXMM4 :: DynFlags -> Int+oFFSET_StgRegTable_rXMM4 dflags = pc_OFFSET_StgRegTable_rXMM4 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rXMM5 :: DynFlags -> Int+oFFSET_StgRegTable_rXMM5 dflags = pc_OFFSET_StgRegTable_rXMM5 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rXMM6 :: DynFlags -> Int+oFFSET_StgRegTable_rXMM6 dflags = pc_OFFSET_StgRegTable_rXMM6 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rYMM1 :: DynFlags -> Int+oFFSET_StgRegTable_rYMM1 dflags = pc_OFFSET_StgRegTable_rYMM1 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rYMM2 :: DynFlags -> Int+oFFSET_StgRegTable_rYMM2 dflags = pc_OFFSET_StgRegTable_rYMM2 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rYMM3 :: DynFlags -> Int+oFFSET_StgRegTable_rYMM3 dflags = pc_OFFSET_StgRegTable_rYMM3 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rYMM4 :: DynFlags -> Int+oFFSET_StgRegTable_rYMM4 dflags = pc_OFFSET_StgRegTable_rYMM4 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rYMM5 :: DynFlags -> Int+oFFSET_StgRegTable_rYMM5 dflags = pc_OFFSET_StgRegTable_rYMM5 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rYMM6 :: DynFlags -> Int+oFFSET_StgRegTable_rYMM6 dflags = pc_OFFSET_StgRegTable_rYMM6 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rZMM1 :: DynFlags -> Int+oFFSET_StgRegTable_rZMM1 dflags = pc_OFFSET_StgRegTable_rZMM1 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rZMM2 :: DynFlags -> Int+oFFSET_StgRegTable_rZMM2 dflags = pc_OFFSET_StgRegTable_rZMM2 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rZMM3 :: DynFlags -> Int+oFFSET_StgRegTable_rZMM3 dflags = pc_OFFSET_StgRegTable_rZMM3 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rZMM4 :: DynFlags -> Int+oFFSET_StgRegTable_rZMM4 dflags = pc_OFFSET_StgRegTable_rZMM4 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rZMM5 :: DynFlags -> Int+oFFSET_StgRegTable_rZMM5 dflags = pc_OFFSET_StgRegTable_rZMM5 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rZMM6 :: DynFlags -> Int+oFFSET_StgRegTable_rZMM6 dflags = pc_OFFSET_StgRegTable_rZMM6 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rL1 :: DynFlags -> Int+oFFSET_StgRegTable_rL1 dflags = pc_OFFSET_StgRegTable_rL1 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rSp :: DynFlags -> Int+oFFSET_StgRegTable_rSp dflags = pc_OFFSET_StgRegTable_rSp (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rSpLim :: DynFlags -> Int+oFFSET_StgRegTable_rSpLim dflags = pc_OFFSET_StgRegTable_rSpLim (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rHp :: DynFlags -> Int+oFFSET_StgRegTable_rHp dflags = pc_OFFSET_StgRegTable_rHp (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rHpLim :: DynFlags -> Int+oFFSET_StgRegTable_rHpLim dflags = pc_OFFSET_StgRegTable_rHpLim (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rCCCS :: DynFlags -> Int+oFFSET_StgRegTable_rCCCS dflags = pc_OFFSET_StgRegTable_rCCCS (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rCurrentTSO :: DynFlags -> Int+oFFSET_StgRegTable_rCurrentTSO dflags = pc_OFFSET_StgRegTable_rCurrentTSO (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rCurrentNursery :: DynFlags -> Int+oFFSET_StgRegTable_rCurrentNursery dflags = pc_OFFSET_StgRegTable_rCurrentNursery (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rHpAlloc :: DynFlags -> Int+oFFSET_StgRegTable_rHpAlloc dflags = pc_OFFSET_StgRegTable_rHpAlloc (sPlatformConstants (settings dflags))+oFFSET_stgEagerBlackholeInfo :: DynFlags -> Int+oFFSET_stgEagerBlackholeInfo dflags = pc_OFFSET_stgEagerBlackholeInfo (sPlatformConstants (settings dflags))+oFFSET_stgGCEnter1 :: DynFlags -> Int+oFFSET_stgGCEnter1 dflags = pc_OFFSET_stgGCEnter1 (sPlatformConstants (settings dflags))+oFFSET_stgGCFun :: DynFlags -> Int+oFFSET_stgGCFun dflags = pc_OFFSET_stgGCFun (sPlatformConstants (settings dflags))+oFFSET_Capability_r :: DynFlags -> Int+oFFSET_Capability_r dflags = pc_OFFSET_Capability_r (sPlatformConstants (settings dflags))+oFFSET_bdescr_start :: DynFlags -> Int+oFFSET_bdescr_start dflags = pc_OFFSET_bdescr_start (sPlatformConstants (settings dflags))+oFFSET_bdescr_free :: DynFlags -> Int+oFFSET_bdescr_free dflags = pc_OFFSET_bdescr_free (sPlatformConstants (settings dflags))+oFFSET_bdescr_blocks :: DynFlags -> Int+oFFSET_bdescr_blocks dflags = pc_OFFSET_bdescr_blocks (sPlatformConstants (settings dflags))+oFFSET_bdescr_flags :: DynFlags -> Int+oFFSET_bdescr_flags dflags = pc_OFFSET_bdescr_flags (sPlatformConstants (settings dflags))+sIZEOF_CostCentreStack :: DynFlags -> Int+sIZEOF_CostCentreStack dflags = pc_SIZEOF_CostCentreStack (sPlatformConstants (settings dflags))+oFFSET_CostCentreStack_mem_alloc :: DynFlags -> Int+oFFSET_CostCentreStack_mem_alloc dflags = pc_OFFSET_CostCentreStack_mem_alloc (sPlatformConstants (settings dflags))+oFFSET_CostCentreStack_scc_count :: DynFlags -> Int+oFFSET_CostCentreStack_scc_count dflags = pc_OFFSET_CostCentreStack_scc_count (sPlatformConstants (settings dflags))+oFFSET_StgHeader_ccs :: DynFlags -> Int+oFFSET_StgHeader_ccs dflags = pc_OFFSET_StgHeader_ccs (sPlatformConstants (settings dflags))+oFFSET_StgHeader_ldvw :: DynFlags -> Int+oFFSET_StgHeader_ldvw dflags = pc_OFFSET_StgHeader_ldvw (sPlatformConstants (settings dflags))+sIZEOF_StgSMPThunkHeader :: DynFlags -> Int+sIZEOF_StgSMPThunkHeader dflags = pc_SIZEOF_StgSMPThunkHeader (sPlatformConstants (settings dflags))+oFFSET_StgEntCounter_allocs :: DynFlags -> Int+oFFSET_StgEntCounter_allocs dflags = pc_OFFSET_StgEntCounter_allocs (sPlatformConstants (settings dflags))+oFFSET_StgEntCounter_allocd :: DynFlags -> Int+oFFSET_StgEntCounter_allocd dflags = pc_OFFSET_StgEntCounter_allocd (sPlatformConstants (settings dflags))+oFFSET_StgEntCounter_registeredp :: DynFlags -> Int+oFFSET_StgEntCounter_registeredp dflags = pc_OFFSET_StgEntCounter_registeredp (sPlatformConstants (settings dflags))+oFFSET_StgEntCounter_link :: DynFlags -> Int+oFFSET_StgEntCounter_link dflags = pc_OFFSET_StgEntCounter_link (sPlatformConstants (settings dflags))+oFFSET_StgEntCounter_entry_count :: DynFlags -> Int+oFFSET_StgEntCounter_entry_count dflags = pc_OFFSET_StgEntCounter_entry_count (sPlatformConstants (settings dflags))+sIZEOF_StgUpdateFrame_NoHdr :: DynFlags -> Int+sIZEOF_StgUpdateFrame_NoHdr dflags = pc_SIZEOF_StgUpdateFrame_NoHdr (sPlatformConstants (settings dflags))+sIZEOF_StgMutArrPtrs_NoHdr :: DynFlags -> Int+sIZEOF_StgMutArrPtrs_NoHdr dflags = pc_SIZEOF_StgMutArrPtrs_NoHdr (sPlatformConstants (settings dflags))+oFFSET_StgMutArrPtrs_ptrs :: DynFlags -> Int+oFFSET_StgMutArrPtrs_ptrs dflags = pc_OFFSET_StgMutArrPtrs_ptrs (sPlatformConstants (settings dflags))+oFFSET_StgMutArrPtrs_size :: DynFlags -> Int+oFFSET_StgMutArrPtrs_size dflags = pc_OFFSET_StgMutArrPtrs_size (sPlatformConstants (settings dflags))+sIZEOF_StgSmallMutArrPtrs_NoHdr :: DynFlags -> Int+sIZEOF_StgSmallMutArrPtrs_NoHdr dflags = pc_SIZEOF_StgSmallMutArrPtrs_NoHdr (sPlatformConstants (settings dflags))+oFFSET_StgSmallMutArrPtrs_ptrs :: DynFlags -> Int+oFFSET_StgSmallMutArrPtrs_ptrs dflags = pc_OFFSET_StgSmallMutArrPtrs_ptrs (sPlatformConstants (settings dflags))+sIZEOF_StgArrBytes_NoHdr :: DynFlags -> Int+sIZEOF_StgArrBytes_NoHdr dflags = pc_SIZEOF_StgArrBytes_NoHdr (sPlatformConstants (settings dflags))+oFFSET_StgArrBytes_bytes :: DynFlags -> Int+oFFSET_StgArrBytes_bytes dflags = pc_OFFSET_StgArrBytes_bytes (sPlatformConstants (settings dflags))+oFFSET_StgTSO_alloc_limit :: DynFlags -> Int+oFFSET_StgTSO_alloc_limit dflags = pc_OFFSET_StgTSO_alloc_limit (sPlatformConstants (settings dflags))+oFFSET_StgTSO_cccs :: DynFlags -> Int+oFFSET_StgTSO_cccs dflags = pc_OFFSET_StgTSO_cccs (sPlatformConstants (settings dflags))+oFFSET_StgTSO_stackobj :: DynFlags -> Int+oFFSET_StgTSO_stackobj dflags = pc_OFFSET_StgTSO_stackobj (sPlatformConstants (settings dflags))+oFFSET_StgStack_sp :: DynFlags -> Int+oFFSET_StgStack_sp dflags = pc_OFFSET_StgStack_sp (sPlatformConstants (settings dflags))+oFFSET_StgStack_stack :: DynFlags -> Int+oFFSET_StgStack_stack dflags = pc_OFFSET_StgStack_stack (sPlatformConstants (settings dflags))+oFFSET_StgUpdateFrame_updatee :: DynFlags -> Int+oFFSET_StgUpdateFrame_updatee dflags = pc_OFFSET_StgUpdateFrame_updatee (sPlatformConstants (settings dflags))+oFFSET_StgFunInfoExtraFwd_arity :: DynFlags -> Int+oFFSET_StgFunInfoExtraFwd_arity dflags = pc_OFFSET_StgFunInfoExtraFwd_arity (sPlatformConstants (settings dflags))+sIZEOF_StgFunInfoExtraRev :: DynFlags -> Int+sIZEOF_StgFunInfoExtraRev dflags = pc_SIZEOF_StgFunInfoExtraRev (sPlatformConstants (settings dflags))+oFFSET_StgFunInfoExtraRev_arity :: DynFlags -> Int+oFFSET_StgFunInfoExtraRev_arity dflags = pc_OFFSET_StgFunInfoExtraRev_arity (sPlatformConstants (settings dflags))+mAX_SPEC_SELECTEE_SIZE :: DynFlags -> Int+mAX_SPEC_SELECTEE_SIZE dflags = pc_MAX_SPEC_SELECTEE_SIZE (sPlatformConstants (settings dflags))+mAX_SPEC_AP_SIZE :: DynFlags -> Int+mAX_SPEC_AP_SIZE dflags = pc_MAX_SPEC_AP_SIZE (sPlatformConstants (settings dflags))+mIN_PAYLOAD_SIZE :: DynFlags -> Int+mIN_PAYLOAD_SIZE dflags = pc_MIN_PAYLOAD_SIZE (sPlatformConstants (settings dflags))+mIN_INTLIKE :: DynFlags -> Int+mIN_INTLIKE dflags = pc_MIN_INTLIKE (sPlatformConstants (settings dflags))+mAX_INTLIKE :: DynFlags -> Int+mAX_INTLIKE dflags = pc_MAX_INTLIKE (sPlatformConstants (settings dflags))+mIN_CHARLIKE :: DynFlags -> Int+mIN_CHARLIKE dflags = pc_MIN_CHARLIKE (sPlatformConstants (settings dflags))+mAX_CHARLIKE :: DynFlags -> Int+mAX_CHARLIKE dflags = pc_MAX_CHARLIKE (sPlatformConstants (settings dflags))+mUT_ARR_PTRS_CARD_BITS :: DynFlags -> Int+mUT_ARR_PTRS_CARD_BITS dflags = pc_MUT_ARR_PTRS_CARD_BITS (sPlatformConstants (settings dflags))+mAX_Vanilla_REG :: DynFlags -> Int+mAX_Vanilla_REG dflags = pc_MAX_Vanilla_REG (sPlatformConstants (settings dflags))+mAX_Float_REG :: DynFlags -> Int+mAX_Float_REG dflags = pc_MAX_Float_REG (sPlatformConstants (settings dflags))+mAX_Double_REG :: DynFlags -> Int+mAX_Double_REG dflags = pc_MAX_Double_REG (sPlatformConstants (settings dflags))+mAX_Long_REG :: DynFlags -> Int+mAX_Long_REG dflags = pc_MAX_Long_REG (sPlatformConstants (settings dflags))+mAX_XMM_REG :: DynFlags -> Int+mAX_XMM_REG dflags = pc_MAX_XMM_REG (sPlatformConstants (settings dflags))+mAX_Real_Vanilla_REG :: DynFlags -> Int+mAX_Real_Vanilla_REG dflags = pc_MAX_Real_Vanilla_REG (sPlatformConstants (settings dflags))+mAX_Real_Float_REG :: DynFlags -> Int+mAX_Real_Float_REG dflags = pc_MAX_Real_Float_REG (sPlatformConstants (settings dflags))+mAX_Real_Double_REG :: DynFlags -> Int+mAX_Real_Double_REG dflags = pc_MAX_Real_Double_REG (sPlatformConstants (settings dflags))+mAX_Real_XMM_REG :: DynFlags -> Int+mAX_Real_XMM_REG dflags = pc_MAX_Real_XMM_REG (sPlatformConstants (settings dflags))+mAX_Real_Long_REG :: DynFlags -> Int+mAX_Real_Long_REG dflags = pc_MAX_Real_Long_REG (sPlatformConstants (settings dflags))+rESERVED_C_STACK_BYTES :: DynFlags -> Int+rESERVED_C_STACK_BYTES dflags = pc_RESERVED_C_STACK_BYTES (sPlatformConstants (settings dflags))+rESERVED_STACK_WORDS :: DynFlags -> Int+rESERVED_STACK_WORDS dflags = pc_RESERVED_STACK_WORDS (sPlatformConstants (settings dflags))+aP_STACK_SPLIM :: DynFlags -> Int+aP_STACK_SPLIM dflags = pc_AP_STACK_SPLIM (sPlatformConstants (settings dflags))+wORD_SIZE :: DynFlags -> Int+wORD_SIZE dflags = pc_WORD_SIZE (sPlatformConstants (settings dflags))+dOUBLE_SIZE :: DynFlags -> Int+dOUBLE_SIZE dflags = pc_DOUBLE_SIZE (sPlatformConstants (settings dflags))+cINT_SIZE :: DynFlags -> Int+cINT_SIZE dflags = pc_CINT_SIZE (sPlatformConstants (settings dflags))+cLONG_SIZE :: DynFlags -> Int+cLONG_SIZE dflags = pc_CLONG_SIZE (sPlatformConstants (settings dflags))+cLONG_LONG_SIZE :: DynFlags -> Int+cLONG_LONG_SIZE dflags = pc_CLONG_LONG_SIZE (sPlatformConstants (settings dflags))+bITMAP_BITS_SHIFT :: DynFlags -> Int+bITMAP_BITS_SHIFT dflags = pc_BITMAP_BITS_SHIFT (sPlatformConstants (settings dflags))+tAG_BITS :: DynFlags -> Int+tAG_BITS dflags = pc_TAG_BITS (sPlatformConstants (settings dflags))+wORDS_BIGENDIAN :: DynFlags -> Bool+wORDS_BIGENDIAN dflags = pc_WORDS_BIGENDIAN (sPlatformConstants (settings dflags))+dYNAMIC_BY_DEFAULT :: DynFlags -> Bool+dYNAMIC_BY_DEFAULT dflags = pc_DYNAMIC_BY_DEFAULT (sPlatformConstants (settings dflags))+lDV_SHIFT :: DynFlags -> Int+lDV_SHIFT dflags = pc_LDV_SHIFT (sPlatformConstants (settings dflags))+iLDV_CREATE_MASK :: DynFlags -> Integer+iLDV_CREATE_MASK dflags = pc_ILDV_CREATE_MASK (sPlatformConstants (settings dflags))+iLDV_STATE_CREATE :: DynFlags -> Integer+iLDV_STATE_CREATE dflags = pc_ILDV_STATE_CREATE (sPlatformConstants (settings dflags))+iLDV_STATE_USE :: DynFlags -> Integer+iLDV_STATE_USE dflags = pc_ILDV_STATE_USE (sPlatformConstants (settings dflags))
+ autogen/ghc_boot_platform.h view
@@ -0,0 +1,33 @@+#ifndef __PLATFORM_H__+#define __PLATFORM_H__++#define BuildPlatform_NAME  "x86_64-unknown-linux"+#define HostPlatform_NAME   "x86_64-unknown-linux"+#define TargetPlatform_NAME "x86_64-unknown-linux"++#define x86_64_unknown_linux_BUILD 1+#define x86_64_unknown_linux_HOST 1+#define x86_64_unknown_linux_TARGET 1++#define x86_64_BUILD_ARCH 1+#define x86_64_HOST_ARCH 1+#define x86_64_TARGET_ARCH 1+#define BUILD_ARCH "x86_64"+#define HOST_ARCH "x86_64"+#define TARGET_ARCH "x86_64"++#define linux_BUILD_OS 1+#define linux_HOST_OS 1+#define linux_TARGET_OS 1+#define BUILD_OS "linux"+#define HOST_OS "linux"+#define TARGET_OS "linux"++#define unknown_BUILD_VENDOR 1+#define unknown_HOST_VENDOR 1+#define unknown_TARGET_VENDOR  1+#define BUILD_VENDOR "unknown"+#define HOST_VENDOR "unknown"+#define TARGET_VENDOR "unknown"++#endif /* __PLATFORM_H__ */
+ autogen/primop-can-fail.hs-incl view
@@ -0,0 +1,178 @@+primOpCanFail IntQuotOp = True+primOpCanFail IntRemOp = True+primOpCanFail IntQuotRemOp = True+primOpCanFail WordQuotOp = True+primOpCanFail WordRemOp = True+primOpCanFail WordQuotRemOp = True+primOpCanFail WordQuotRem2Op = True+primOpCanFail DoubleDivOp = True+primOpCanFail DoubleLogOp = True+primOpCanFail DoubleAsinOp = True+primOpCanFail DoubleAcosOp = True+primOpCanFail FloatDivOp = True+primOpCanFail FloatLogOp = True+primOpCanFail FloatAsinOp = True+primOpCanFail FloatAcosOp = True+primOpCanFail ReadArrayOp = True+primOpCanFail WriteArrayOp = True+primOpCanFail IndexArrayOp = True+primOpCanFail CopyArrayOp = True+primOpCanFail CopyMutableArrayOp = True+primOpCanFail CloneArrayOp = True+primOpCanFail CloneMutableArrayOp = True+primOpCanFail FreezeArrayOp = True+primOpCanFail ThawArrayOp = True+primOpCanFail ReadSmallArrayOp = True+primOpCanFail WriteSmallArrayOp = True+primOpCanFail IndexSmallArrayOp = True+primOpCanFail CopySmallArrayOp = True+primOpCanFail CopySmallMutableArrayOp = True+primOpCanFail CloneSmallArrayOp = True+primOpCanFail CloneSmallMutableArrayOp = True+primOpCanFail FreezeSmallArrayOp = True+primOpCanFail ThawSmallArrayOp = True+primOpCanFail IndexByteArrayOp_Char = True+primOpCanFail IndexByteArrayOp_WideChar = True+primOpCanFail IndexByteArrayOp_Int = True+primOpCanFail IndexByteArrayOp_Word = True+primOpCanFail IndexByteArrayOp_Addr = True+primOpCanFail IndexByteArrayOp_Float = True+primOpCanFail IndexByteArrayOp_Double = True+primOpCanFail IndexByteArrayOp_StablePtr = True+primOpCanFail IndexByteArrayOp_Int8 = True+primOpCanFail IndexByteArrayOp_Int16 = True+primOpCanFail IndexByteArrayOp_Int32 = True+primOpCanFail IndexByteArrayOp_Int64 = True+primOpCanFail IndexByteArrayOp_Word8 = True+primOpCanFail IndexByteArrayOp_Word16 = True+primOpCanFail IndexByteArrayOp_Word32 = True+primOpCanFail IndexByteArrayOp_Word64 = True+primOpCanFail ReadByteArrayOp_Char = True+primOpCanFail ReadByteArrayOp_WideChar = True+primOpCanFail ReadByteArrayOp_Int = True+primOpCanFail ReadByteArrayOp_Word = True+primOpCanFail ReadByteArrayOp_Addr = True+primOpCanFail ReadByteArrayOp_Float = True+primOpCanFail ReadByteArrayOp_Double = True+primOpCanFail ReadByteArrayOp_StablePtr = True+primOpCanFail ReadByteArrayOp_Int8 = True+primOpCanFail ReadByteArrayOp_Int16 = True+primOpCanFail ReadByteArrayOp_Int32 = True+primOpCanFail ReadByteArrayOp_Int64 = True+primOpCanFail ReadByteArrayOp_Word8 = True+primOpCanFail ReadByteArrayOp_Word16 = True+primOpCanFail ReadByteArrayOp_Word32 = True+primOpCanFail ReadByteArrayOp_Word64 = True+primOpCanFail WriteByteArrayOp_Char = True+primOpCanFail WriteByteArrayOp_WideChar = True+primOpCanFail WriteByteArrayOp_Int = True+primOpCanFail WriteByteArrayOp_Word = True+primOpCanFail WriteByteArrayOp_Addr = True+primOpCanFail WriteByteArrayOp_Float = True+primOpCanFail WriteByteArrayOp_Double = True+primOpCanFail WriteByteArrayOp_StablePtr = True+primOpCanFail WriteByteArrayOp_Int8 = True+primOpCanFail WriteByteArrayOp_Int16 = True+primOpCanFail WriteByteArrayOp_Int32 = True+primOpCanFail WriteByteArrayOp_Int64 = True+primOpCanFail WriteByteArrayOp_Word8 = True+primOpCanFail WriteByteArrayOp_Word16 = True+primOpCanFail WriteByteArrayOp_Word32 = True+primOpCanFail WriteByteArrayOp_Word64 = True+primOpCanFail CopyByteArrayOp = True+primOpCanFail CopyMutableByteArrayOp = True+primOpCanFail CopyByteArrayToAddrOp = True+primOpCanFail CopyMutableByteArrayToAddrOp = True+primOpCanFail CopyAddrToByteArrayOp = True+primOpCanFail SetByteArrayOp = True+primOpCanFail AtomicReadByteArrayOp_Int = True+primOpCanFail AtomicWriteByteArrayOp_Int = True+primOpCanFail CasByteArrayOp_Int = True+primOpCanFail FetchAddByteArrayOp_Int = True+primOpCanFail FetchSubByteArrayOp_Int = True+primOpCanFail FetchAndByteArrayOp_Int = True+primOpCanFail FetchNandByteArrayOp_Int = True+primOpCanFail FetchOrByteArrayOp_Int = True+primOpCanFail FetchXorByteArrayOp_Int = True+primOpCanFail IndexArrayArrayOp_ByteArray = True+primOpCanFail IndexArrayArrayOp_ArrayArray = True+primOpCanFail ReadArrayArrayOp_ByteArray = True+primOpCanFail ReadArrayArrayOp_MutableByteArray = True+primOpCanFail ReadArrayArrayOp_ArrayArray = True+primOpCanFail ReadArrayArrayOp_MutableArrayArray = True+primOpCanFail WriteArrayArrayOp_ByteArray = True+primOpCanFail WriteArrayArrayOp_MutableByteArray = True+primOpCanFail WriteArrayArrayOp_ArrayArray = True+primOpCanFail WriteArrayArrayOp_MutableArrayArray = True+primOpCanFail CopyArrayArrayOp = True+primOpCanFail CopyMutableArrayArrayOp = True+primOpCanFail IndexOffAddrOp_Char = True+primOpCanFail IndexOffAddrOp_WideChar = True+primOpCanFail IndexOffAddrOp_Int = True+primOpCanFail IndexOffAddrOp_Word = True+primOpCanFail IndexOffAddrOp_Addr = True+primOpCanFail IndexOffAddrOp_Float = True+primOpCanFail IndexOffAddrOp_Double = True+primOpCanFail IndexOffAddrOp_StablePtr = True+primOpCanFail IndexOffAddrOp_Int8 = True+primOpCanFail IndexOffAddrOp_Int16 = True+primOpCanFail IndexOffAddrOp_Int32 = True+primOpCanFail IndexOffAddrOp_Int64 = True+primOpCanFail IndexOffAddrOp_Word8 = True+primOpCanFail IndexOffAddrOp_Word16 = True+primOpCanFail IndexOffAddrOp_Word32 = True+primOpCanFail IndexOffAddrOp_Word64 = True+primOpCanFail ReadOffAddrOp_Char = True+primOpCanFail ReadOffAddrOp_WideChar = True+primOpCanFail ReadOffAddrOp_Int = True+primOpCanFail ReadOffAddrOp_Word = True+primOpCanFail ReadOffAddrOp_Addr = True+primOpCanFail ReadOffAddrOp_Float = True+primOpCanFail ReadOffAddrOp_Double = True+primOpCanFail ReadOffAddrOp_StablePtr = True+primOpCanFail ReadOffAddrOp_Int8 = True+primOpCanFail ReadOffAddrOp_Int16 = True+primOpCanFail ReadOffAddrOp_Int32 = True+primOpCanFail ReadOffAddrOp_Int64 = True+primOpCanFail ReadOffAddrOp_Word8 = True+primOpCanFail ReadOffAddrOp_Word16 = True+primOpCanFail ReadOffAddrOp_Word32 = True+primOpCanFail ReadOffAddrOp_Word64 = True+primOpCanFail WriteOffAddrOp_Char = True+primOpCanFail WriteOffAddrOp_WideChar = True+primOpCanFail WriteOffAddrOp_Int = True+primOpCanFail WriteOffAddrOp_Word = True+primOpCanFail WriteOffAddrOp_Addr = True+primOpCanFail WriteOffAddrOp_Float = True+primOpCanFail WriteOffAddrOp_Double = True+primOpCanFail WriteOffAddrOp_StablePtr = True+primOpCanFail WriteOffAddrOp_Int8 = True+primOpCanFail WriteOffAddrOp_Int16 = True+primOpCanFail WriteOffAddrOp_Int32 = True+primOpCanFail WriteOffAddrOp_Int64 = True+primOpCanFail WriteOffAddrOp_Word8 = True+primOpCanFail WriteOffAddrOp_Word16 = True+primOpCanFail WriteOffAddrOp_Word32 = True+primOpCanFail WriteOffAddrOp_Word64 = True+primOpCanFail ReadMutVarOp = True+primOpCanFail WriteMutVarOp = True+primOpCanFail AtomicModifyMutVarOp = True+primOpCanFail ReallyUnsafePtrEqualityOp = True+primOpCanFail DataToTagOp = True+primOpCanFail (VecInsertOp _ _ _) = True+primOpCanFail (VecDivOp _ _ _) = True+primOpCanFail (VecQuotOp _ _ _) = True+primOpCanFail (VecRemOp _ _ _) = True+primOpCanFail (VecIndexByteArrayOp _ _ _) = True+primOpCanFail (VecReadByteArrayOp _ _ _) = True+primOpCanFail (VecWriteByteArrayOp _ _ _) = True+primOpCanFail (VecIndexOffAddrOp _ _ _) = True+primOpCanFail (VecReadOffAddrOp _ _ _) = True+primOpCanFail (VecWriteOffAddrOp _ _ _) = True+primOpCanFail (VecIndexScalarByteArrayOp _ _ _) = True+primOpCanFail (VecReadScalarByteArrayOp _ _ _) = True+primOpCanFail (VecWriteScalarByteArrayOp _ _ _) = True+primOpCanFail (VecIndexScalarOffAddrOp _ _ _) = True+primOpCanFail (VecReadScalarOffAddrOp _ _ _) = True+primOpCanFail (VecWriteScalarOffAddrOp _ _ _) = True+primOpCanFail _ = False
+ autogen/primop-code-size.hs-incl view
@@ -0,0 +1,48 @@+primOpCodeSize OrdOp = 0+primOpCodeSize IntAddCOp = 2+primOpCodeSize IntSubCOp = 2+primOpCodeSize ChrOp = 0+primOpCodeSize Int2WordOp = 0+primOpCodeSize Word2IntOp = 0+primOpCodeSize DoubleExpOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleLogOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleSqrtOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleSinOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleCosOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleTanOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleAsinOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleAcosOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleAtanOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleSinhOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleCoshOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleTanhOp =  primOpCodeSizeForeignCall +primOpCodeSize DoublePowerOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatExpOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatLogOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatSqrtOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatSinOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatCosOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatTanOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatAsinOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatAcosOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatAtanOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatSinhOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatCoshOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatTanhOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatPowerOp =  primOpCodeSizeForeignCall +primOpCodeSize WriteArrayOp = 2+primOpCodeSize CopyByteArrayOp =  primOpCodeSizeForeignCall + 4+primOpCodeSize CopyMutableByteArrayOp =  primOpCodeSizeForeignCall + 4 +primOpCodeSize CopyByteArrayToAddrOp =  primOpCodeSizeForeignCall + 4+primOpCodeSize CopyMutableByteArrayToAddrOp =  primOpCodeSizeForeignCall + 4+primOpCodeSize CopyAddrToByteArrayOp =  primOpCodeSizeForeignCall + 4+primOpCodeSize SetByteArrayOp =  primOpCodeSizeForeignCall + 4 +primOpCodeSize Addr2IntOp = 0+primOpCodeSize Int2AddrOp = 0+primOpCodeSize WriteMutVarOp =  primOpCodeSizeForeignCall +primOpCodeSize TouchOp =  0 +primOpCodeSize ParOp =  primOpCodeSizeForeignCall +primOpCodeSize SparkOp =  primOpCodeSizeForeignCall +primOpCodeSize AddrToAnyOp = 0+primOpCodeSize AnyToAddrOp = 0+primOpCodeSize _ =  primOpCodeSizeDefault
+ autogen/primop-commutable.hs-incl view
@@ -0,0 +1,28 @@+commutableOp CharEqOp = True+commutableOp CharNeOp = True+commutableOp IntAddOp = True+commutableOp IntMulOp = True+commutableOp IntMulMayOfloOp = True+commutableOp AndIOp = True+commutableOp OrIOp = True+commutableOp XorIOp = True+commutableOp IntEqOp = True+commutableOp IntNeOp = True+commutableOp WordAddOp = True+commutableOp WordAdd2Op = True+commutableOp WordMulOp = True+commutableOp WordMul2Op = True+commutableOp AndOp = True+commutableOp OrOp = True+commutableOp XorOp = True+commutableOp DoubleEqOp = True+commutableOp DoubleNeOp = True+commutableOp DoubleAddOp = True+commutableOp DoubleMulOp = True+commutableOp FloatEqOp = True+commutableOp FloatNeOp = True+commutableOp FloatAddOp = True+commutableOp FloatMulOp = True+commutableOp (VecAddOp _ _ _) = True+commutableOp (VecMulOp _ _ _) = True+commutableOp _ = False
+ autogen/primop-data-decl.hs-incl view
@@ -0,0 +1,451 @@+data PrimOp+   = CharGtOp+   | CharGeOp+   | CharEqOp+   | CharNeOp+   | CharLtOp+   | CharLeOp+   | OrdOp+   | IntAddOp+   | IntSubOp+   | IntMulOp+   | IntMulMayOfloOp+   | IntQuotOp+   | IntRemOp+   | IntQuotRemOp+   | AndIOp+   | OrIOp+   | XorIOp+   | NotIOp+   | IntNegOp+   | IntAddCOp+   | IntSubCOp+   | IntGtOp+   | IntGeOp+   | IntEqOp+   | IntNeOp+   | IntLtOp+   | IntLeOp+   | ChrOp+   | Int2WordOp+   | Int2FloatOp+   | Int2DoubleOp+   | Word2FloatOp+   | Word2DoubleOp+   | ISllOp+   | ISraOp+   | ISrlOp+   | WordAddOp+   | WordSubCOp+   | WordAdd2Op+   | WordSubOp+   | WordMulOp+   | WordMul2Op+   | WordQuotOp+   | WordRemOp+   | WordQuotRemOp+   | WordQuotRem2Op+   | AndOp+   | OrOp+   | XorOp+   | NotOp+   | SllOp+   | SrlOp+   | Word2IntOp+   | WordGtOp+   | WordGeOp+   | WordEqOp+   | WordNeOp+   | WordLtOp+   | WordLeOp+   | PopCnt8Op+   | PopCnt16Op+   | PopCnt32Op+   | PopCnt64Op+   | PopCntOp+   | Clz8Op+   | Clz16Op+   | Clz32Op+   | Clz64Op+   | ClzOp+   | Ctz8Op+   | Ctz16Op+   | Ctz32Op+   | Ctz64Op+   | CtzOp+   | BSwap16Op+   | BSwap32Op+   | BSwap64Op+   | BSwapOp+   | Narrow8IntOp+   | Narrow16IntOp+   | Narrow32IntOp+   | Narrow8WordOp+   | Narrow16WordOp+   | Narrow32WordOp+   | DoubleGtOp+   | DoubleGeOp+   | DoubleEqOp+   | DoubleNeOp+   | DoubleLtOp+   | DoubleLeOp+   | DoubleAddOp+   | DoubleSubOp+   | DoubleMulOp+   | DoubleDivOp+   | DoubleNegOp+   | DoubleFabsOp+   | Double2IntOp+   | Double2FloatOp+   | DoubleExpOp+   | DoubleLogOp+   | DoubleSqrtOp+   | DoubleSinOp+   | DoubleCosOp+   | DoubleTanOp+   | DoubleAsinOp+   | DoubleAcosOp+   | DoubleAtanOp+   | DoubleSinhOp+   | DoubleCoshOp+   | DoubleTanhOp+   | DoublePowerOp+   | DoubleDecode_2IntOp+   | DoubleDecode_Int64Op+   | FloatGtOp+   | FloatGeOp+   | FloatEqOp+   | FloatNeOp+   | FloatLtOp+   | FloatLeOp+   | FloatAddOp+   | FloatSubOp+   | FloatMulOp+   | FloatDivOp+   | FloatNegOp+   | FloatFabsOp+   | Float2IntOp+   | FloatExpOp+   | FloatLogOp+   | FloatSqrtOp+   | FloatSinOp+   | FloatCosOp+   | FloatTanOp+   | FloatAsinOp+   | FloatAcosOp+   | FloatAtanOp+   | FloatSinhOp+   | FloatCoshOp+   | FloatTanhOp+   | FloatPowerOp+   | Float2DoubleOp+   | FloatDecode_IntOp+   | NewArrayOp+   | SameMutableArrayOp+   | ReadArrayOp+   | WriteArrayOp+   | SizeofArrayOp+   | SizeofMutableArrayOp+   | IndexArrayOp+   | UnsafeFreezeArrayOp+   | UnsafeThawArrayOp+   | CopyArrayOp+   | CopyMutableArrayOp+   | CloneArrayOp+   | CloneMutableArrayOp+   | FreezeArrayOp+   | ThawArrayOp+   | CasArrayOp+   | NewSmallArrayOp+   | SameSmallMutableArrayOp+   | ReadSmallArrayOp+   | WriteSmallArrayOp+   | SizeofSmallArrayOp+   | SizeofSmallMutableArrayOp+   | IndexSmallArrayOp+   | UnsafeFreezeSmallArrayOp+   | UnsafeThawSmallArrayOp+   | CopySmallArrayOp+   | CopySmallMutableArrayOp+   | CloneSmallArrayOp+   | CloneSmallMutableArrayOp+   | FreezeSmallArrayOp+   | ThawSmallArrayOp+   | CasSmallArrayOp+   | NewByteArrayOp_Char+   | NewPinnedByteArrayOp_Char+   | NewAlignedPinnedByteArrayOp_Char+   | MutableByteArrayIsPinnedOp+   | ByteArrayIsPinnedOp+   | ByteArrayContents_Char+   | SameMutableByteArrayOp+   | ShrinkMutableByteArrayOp_Char+   | ResizeMutableByteArrayOp_Char+   | UnsafeFreezeByteArrayOp+   | SizeofByteArrayOp+   | SizeofMutableByteArrayOp+   | GetSizeofMutableByteArrayOp+   | IndexByteArrayOp_Char+   | IndexByteArrayOp_WideChar+   | IndexByteArrayOp_Int+   | IndexByteArrayOp_Word+   | IndexByteArrayOp_Addr+   | IndexByteArrayOp_Float+   | IndexByteArrayOp_Double+   | IndexByteArrayOp_StablePtr+   | IndexByteArrayOp_Int8+   | IndexByteArrayOp_Int16+   | IndexByteArrayOp_Int32+   | IndexByteArrayOp_Int64+   | IndexByteArrayOp_Word8+   | IndexByteArrayOp_Word16+   | IndexByteArrayOp_Word32+   | IndexByteArrayOp_Word64+   | ReadByteArrayOp_Char+   | ReadByteArrayOp_WideChar+   | ReadByteArrayOp_Int+   | ReadByteArrayOp_Word+   | ReadByteArrayOp_Addr+   | ReadByteArrayOp_Float+   | ReadByteArrayOp_Double+   | ReadByteArrayOp_StablePtr+   | ReadByteArrayOp_Int8+   | ReadByteArrayOp_Int16+   | ReadByteArrayOp_Int32+   | ReadByteArrayOp_Int64+   | ReadByteArrayOp_Word8+   | ReadByteArrayOp_Word16+   | ReadByteArrayOp_Word32+   | ReadByteArrayOp_Word64+   | WriteByteArrayOp_Char+   | WriteByteArrayOp_WideChar+   | WriteByteArrayOp_Int+   | WriteByteArrayOp_Word+   | WriteByteArrayOp_Addr+   | WriteByteArrayOp_Float+   | WriteByteArrayOp_Double+   | WriteByteArrayOp_StablePtr+   | WriteByteArrayOp_Int8+   | WriteByteArrayOp_Int16+   | WriteByteArrayOp_Int32+   | WriteByteArrayOp_Int64+   | WriteByteArrayOp_Word8+   | WriteByteArrayOp_Word16+   | WriteByteArrayOp_Word32+   | WriteByteArrayOp_Word64+   | CopyByteArrayOp+   | CopyMutableByteArrayOp+   | CopyByteArrayToAddrOp+   | CopyMutableByteArrayToAddrOp+   | CopyAddrToByteArrayOp+   | SetByteArrayOp+   | AtomicReadByteArrayOp_Int+   | AtomicWriteByteArrayOp_Int+   | CasByteArrayOp_Int+   | FetchAddByteArrayOp_Int+   | FetchSubByteArrayOp_Int+   | FetchAndByteArrayOp_Int+   | FetchNandByteArrayOp_Int+   | FetchOrByteArrayOp_Int+   | FetchXorByteArrayOp_Int+   | NewArrayArrayOp+   | SameMutableArrayArrayOp+   | UnsafeFreezeArrayArrayOp+   | SizeofArrayArrayOp+   | SizeofMutableArrayArrayOp+   | IndexArrayArrayOp_ByteArray+   | IndexArrayArrayOp_ArrayArray+   | ReadArrayArrayOp_ByteArray+   | ReadArrayArrayOp_MutableByteArray+   | ReadArrayArrayOp_ArrayArray+   | ReadArrayArrayOp_MutableArrayArray+   | WriteArrayArrayOp_ByteArray+   | WriteArrayArrayOp_MutableByteArray+   | WriteArrayArrayOp_ArrayArray+   | WriteArrayArrayOp_MutableArrayArray+   | CopyArrayArrayOp+   | CopyMutableArrayArrayOp+   | AddrAddOp+   | AddrSubOp+   | AddrRemOp+   | Addr2IntOp+   | Int2AddrOp+   | AddrGtOp+   | AddrGeOp+   | AddrEqOp+   | AddrNeOp+   | AddrLtOp+   | AddrLeOp+   | IndexOffAddrOp_Char+   | IndexOffAddrOp_WideChar+   | IndexOffAddrOp_Int+   | IndexOffAddrOp_Word+   | IndexOffAddrOp_Addr+   | IndexOffAddrOp_Float+   | IndexOffAddrOp_Double+   | IndexOffAddrOp_StablePtr+   | IndexOffAddrOp_Int8+   | IndexOffAddrOp_Int16+   | IndexOffAddrOp_Int32+   | IndexOffAddrOp_Int64+   | IndexOffAddrOp_Word8+   | IndexOffAddrOp_Word16+   | IndexOffAddrOp_Word32+   | IndexOffAddrOp_Word64+   | ReadOffAddrOp_Char+   | ReadOffAddrOp_WideChar+   | ReadOffAddrOp_Int+   | ReadOffAddrOp_Word+   | ReadOffAddrOp_Addr+   | ReadOffAddrOp_Float+   | ReadOffAddrOp_Double+   | ReadOffAddrOp_StablePtr+   | ReadOffAddrOp_Int8+   | ReadOffAddrOp_Int16+   | ReadOffAddrOp_Int32+   | ReadOffAddrOp_Int64+   | ReadOffAddrOp_Word8+   | ReadOffAddrOp_Word16+   | ReadOffAddrOp_Word32+   | ReadOffAddrOp_Word64+   | WriteOffAddrOp_Char+   | WriteOffAddrOp_WideChar+   | WriteOffAddrOp_Int+   | WriteOffAddrOp_Word+   | WriteOffAddrOp_Addr+   | WriteOffAddrOp_Float+   | WriteOffAddrOp_Double+   | WriteOffAddrOp_StablePtr+   | WriteOffAddrOp_Int8+   | WriteOffAddrOp_Int16+   | WriteOffAddrOp_Int32+   | WriteOffAddrOp_Int64+   | WriteOffAddrOp_Word8+   | WriteOffAddrOp_Word16+   | WriteOffAddrOp_Word32+   | WriteOffAddrOp_Word64+   | NewMutVarOp+   | ReadMutVarOp+   | WriteMutVarOp+   | SameMutVarOp+   | AtomicModifyMutVarOp+   | CasMutVarOp+   | CatchOp+   | RaiseOp+   | RaiseIOOp+   | MaskAsyncExceptionsOp+   | MaskUninterruptibleOp+   | UnmaskAsyncExceptionsOp+   | MaskStatus+   | AtomicallyOp+   | RetryOp+   | CatchRetryOp+   | CatchSTMOp+   | Check+   | NewTVarOp+   | ReadTVarOp+   | ReadTVarIOOp+   | WriteTVarOp+   | SameTVarOp+   | NewMVarOp+   | TakeMVarOp+   | TryTakeMVarOp+   | PutMVarOp+   | TryPutMVarOp+   | ReadMVarOp+   | TryReadMVarOp+   | SameMVarOp+   | IsEmptyMVarOp+   | DelayOp+   | WaitReadOp+   | WaitWriteOp+   | ForkOp+   | ForkOnOp+   | KillThreadOp+   | YieldOp+   | MyThreadIdOp+   | LabelThreadOp+   | IsCurrentThreadBoundOp+   | NoDuplicateOp+   | ThreadStatusOp+   | MkWeakOp+   | MkWeakNoFinalizerOp+   | AddCFinalizerToWeakOp+   | DeRefWeakOp+   | FinalizeWeakOp+   | TouchOp+   | MakeStablePtrOp+   | DeRefStablePtrOp+   | EqStablePtrOp+   | MakeStableNameOp+   | EqStableNameOp+   | StableNameToIntOp+   | CompactNewOp+   | CompactResizeOp+   | CompactContainsOp+   | CompactContainsAnyOp+   | CompactGetFirstBlockOp+   | CompactGetNextBlockOp+   | CompactAllocateBlockOp+   | CompactFixupPointersOp+   | CompactAdd+   | CompactAddWithSharing+   | CompactSize+   | ReallyUnsafePtrEqualityOp+   | ParOp+   | SparkOp+   | SeqOp+   | GetSparkOp+   | NumSparks+   | DataToTagOp+   | TagToEnumOp+   | AddrToAnyOp+   | AnyToAddrOp+   | MkApUpd0_Op+   | NewBCOOp+   | UnpackClosureOp+   | GetApStackValOp+   | GetCCSOfOp+   | GetCurrentCCSOp+   | ClearCCSOp+   | TraceEventOp+   | TraceMarkerOp+   | VecBroadcastOp PrimOpVecCat Length Width+   | VecPackOp PrimOpVecCat Length Width+   | VecUnpackOp PrimOpVecCat Length Width+   | VecInsertOp PrimOpVecCat Length Width+   | VecAddOp PrimOpVecCat Length Width+   | VecSubOp PrimOpVecCat Length Width+   | VecMulOp PrimOpVecCat Length Width+   | VecDivOp PrimOpVecCat Length Width+   | VecQuotOp PrimOpVecCat Length Width+   | VecRemOp PrimOpVecCat Length Width+   | VecNegOp PrimOpVecCat Length Width+   | VecIndexByteArrayOp PrimOpVecCat Length Width+   | VecReadByteArrayOp PrimOpVecCat Length Width+   | VecWriteByteArrayOp PrimOpVecCat Length Width+   | VecIndexOffAddrOp PrimOpVecCat Length Width+   | VecReadOffAddrOp PrimOpVecCat Length Width+   | VecWriteOffAddrOp PrimOpVecCat Length Width+   | VecIndexScalarByteArrayOp PrimOpVecCat Length Width+   | VecReadScalarByteArrayOp PrimOpVecCat Length Width+   | VecWriteScalarByteArrayOp PrimOpVecCat Length Width+   | VecIndexScalarOffAddrOp PrimOpVecCat Length Width+   | VecReadScalarOffAddrOp PrimOpVecCat Length Width+   | VecWriteScalarOffAddrOp PrimOpVecCat Length Width+   | PrefetchByteArrayOp3+   | PrefetchMutableByteArrayOp3+   | PrefetchAddrOp3+   | PrefetchValueOp3+   | PrefetchByteArrayOp2+   | PrefetchMutableByteArrayOp2+   | PrefetchAddrOp2+   | PrefetchValueOp2+   | PrefetchByteArrayOp1+   | PrefetchMutableByteArrayOp1+   | PrefetchAddrOp1+   | PrefetchValueOp1+   | PrefetchByteArrayOp0+   | PrefetchMutableByteArrayOp0+   | PrefetchAddrOp0+   | PrefetchValueOp0
+ autogen/primop-fixity.hs-incl view
@@ -0,0 +1,20 @@+primOpFixity IntAddOp = Just (Fixity NoSourceText 6 InfixL)+primOpFixity IntSubOp = Just (Fixity NoSourceText 6 InfixL)+primOpFixity IntMulOp = Just (Fixity NoSourceText 7 InfixL)+primOpFixity IntGtOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity IntGeOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity IntEqOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity IntNeOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity IntLtOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity IntLeOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity DoubleGtOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity DoubleGeOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity DoubleEqOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity DoubleNeOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity DoubleLtOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity DoubleLeOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity DoubleAddOp = Just (Fixity NoSourceText 6 InfixL)+primOpFixity DoubleSubOp = Just (Fixity NoSourceText 6 InfixL)+primOpFixity DoubleMulOp = Just (Fixity NoSourceText 7 InfixL)+primOpFixity DoubleDivOp = Just (Fixity NoSourceText 7 InfixL)+primOpFixity _ = Nothing
+ autogen/primop-has-side-effects.hs-incl view
@@ -0,0 +1,211 @@+primOpHasSideEffects NewArrayOp = True+primOpHasSideEffects ReadArrayOp = True+primOpHasSideEffects WriteArrayOp = True+primOpHasSideEffects UnsafeFreezeArrayOp = True+primOpHasSideEffects UnsafeThawArrayOp = True+primOpHasSideEffects CopyArrayOp = True+primOpHasSideEffects CopyMutableArrayOp = True+primOpHasSideEffects CloneArrayOp = True+primOpHasSideEffects CloneMutableArrayOp = True+primOpHasSideEffects FreezeArrayOp = True+primOpHasSideEffects ThawArrayOp = True+primOpHasSideEffects CasArrayOp = True+primOpHasSideEffects NewSmallArrayOp = True+primOpHasSideEffects ReadSmallArrayOp = True+primOpHasSideEffects WriteSmallArrayOp = True+primOpHasSideEffects UnsafeFreezeSmallArrayOp = True+primOpHasSideEffects UnsafeThawSmallArrayOp = True+primOpHasSideEffects CopySmallArrayOp = True+primOpHasSideEffects CopySmallMutableArrayOp = True+primOpHasSideEffects CloneSmallArrayOp = True+primOpHasSideEffects CloneSmallMutableArrayOp = True+primOpHasSideEffects FreezeSmallArrayOp = True+primOpHasSideEffects ThawSmallArrayOp = True+primOpHasSideEffects CasSmallArrayOp = True+primOpHasSideEffects NewByteArrayOp_Char = True+primOpHasSideEffects NewPinnedByteArrayOp_Char = True+primOpHasSideEffects NewAlignedPinnedByteArrayOp_Char = True+primOpHasSideEffects ShrinkMutableByteArrayOp_Char = True+primOpHasSideEffects ResizeMutableByteArrayOp_Char = True+primOpHasSideEffects UnsafeFreezeByteArrayOp = True+primOpHasSideEffects ReadByteArrayOp_Char = True+primOpHasSideEffects ReadByteArrayOp_WideChar = True+primOpHasSideEffects ReadByteArrayOp_Int = True+primOpHasSideEffects ReadByteArrayOp_Word = True+primOpHasSideEffects ReadByteArrayOp_Addr = True+primOpHasSideEffects ReadByteArrayOp_Float = True+primOpHasSideEffects ReadByteArrayOp_Double = True+primOpHasSideEffects ReadByteArrayOp_StablePtr = True+primOpHasSideEffects ReadByteArrayOp_Int8 = True+primOpHasSideEffects ReadByteArrayOp_Int16 = True+primOpHasSideEffects ReadByteArrayOp_Int32 = True+primOpHasSideEffects ReadByteArrayOp_Int64 = True+primOpHasSideEffects ReadByteArrayOp_Word8 = True+primOpHasSideEffects ReadByteArrayOp_Word16 = True+primOpHasSideEffects ReadByteArrayOp_Word32 = True+primOpHasSideEffects ReadByteArrayOp_Word64 = True+primOpHasSideEffects WriteByteArrayOp_Char = True+primOpHasSideEffects WriteByteArrayOp_WideChar = True+primOpHasSideEffects WriteByteArrayOp_Int = True+primOpHasSideEffects WriteByteArrayOp_Word = True+primOpHasSideEffects WriteByteArrayOp_Addr = True+primOpHasSideEffects WriteByteArrayOp_Float = True+primOpHasSideEffects WriteByteArrayOp_Double = True+primOpHasSideEffects WriteByteArrayOp_StablePtr = True+primOpHasSideEffects WriteByteArrayOp_Int8 = True+primOpHasSideEffects WriteByteArrayOp_Int16 = True+primOpHasSideEffects WriteByteArrayOp_Int32 = True+primOpHasSideEffects WriteByteArrayOp_Int64 = True+primOpHasSideEffects WriteByteArrayOp_Word8 = True+primOpHasSideEffects WriteByteArrayOp_Word16 = True+primOpHasSideEffects WriteByteArrayOp_Word32 = True+primOpHasSideEffects WriteByteArrayOp_Word64 = True+primOpHasSideEffects CopyByteArrayOp = True+primOpHasSideEffects CopyMutableByteArrayOp = True+primOpHasSideEffects CopyByteArrayToAddrOp = True+primOpHasSideEffects CopyMutableByteArrayToAddrOp = True+primOpHasSideEffects CopyAddrToByteArrayOp = True+primOpHasSideEffects SetByteArrayOp = True+primOpHasSideEffects AtomicReadByteArrayOp_Int = True+primOpHasSideEffects AtomicWriteByteArrayOp_Int = True+primOpHasSideEffects CasByteArrayOp_Int = True+primOpHasSideEffects FetchAddByteArrayOp_Int = True+primOpHasSideEffects FetchSubByteArrayOp_Int = True+primOpHasSideEffects FetchAndByteArrayOp_Int = True+primOpHasSideEffects FetchNandByteArrayOp_Int = True+primOpHasSideEffects FetchOrByteArrayOp_Int = True+primOpHasSideEffects FetchXorByteArrayOp_Int = True+primOpHasSideEffects NewArrayArrayOp = True+primOpHasSideEffects UnsafeFreezeArrayArrayOp = True+primOpHasSideEffects ReadArrayArrayOp_ByteArray = True+primOpHasSideEffects ReadArrayArrayOp_MutableByteArray = True+primOpHasSideEffects ReadArrayArrayOp_ArrayArray = True+primOpHasSideEffects ReadArrayArrayOp_MutableArrayArray = True+primOpHasSideEffects WriteArrayArrayOp_ByteArray = True+primOpHasSideEffects WriteArrayArrayOp_MutableByteArray = True+primOpHasSideEffects WriteArrayArrayOp_ArrayArray = True+primOpHasSideEffects WriteArrayArrayOp_MutableArrayArray = True+primOpHasSideEffects CopyArrayArrayOp = True+primOpHasSideEffects CopyMutableArrayArrayOp = True+primOpHasSideEffects ReadOffAddrOp_Char = True+primOpHasSideEffects ReadOffAddrOp_WideChar = True+primOpHasSideEffects ReadOffAddrOp_Int = True+primOpHasSideEffects ReadOffAddrOp_Word = True+primOpHasSideEffects ReadOffAddrOp_Addr = True+primOpHasSideEffects ReadOffAddrOp_Float = True+primOpHasSideEffects ReadOffAddrOp_Double = True+primOpHasSideEffects ReadOffAddrOp_StablePtr = True+primOpHasSideEffects ReadOffAddrOp_Int8 = True+primOpHasSideEffects ReadOffAddrOp_Int16 = True+primOpHasSideEffects ReadOffAddrOp_Int32 = True+primOpHasSideEffects ReadOffAddrOp_Int64 = True+primOpHasSideEffects ReadOffAddrOp_Word8 = True+primOpHasSideEffects ReadOffAddrOp_Word16 = True+primOpHasSideEffects ReadOffAddrOp_Word32 = True+primOpHasSideEffects ReadOffAddrOp_Word64 = True+primOpHasSideEffects WriteOffAddrOp_Char = True+primOpHasSideEffects WriteOffAddrOp_WideChar = True+primOpHasSideEffects WriteOffAddrOp_Int = True+primOpHasSideEffects WriteOffAddrOp_Word = True+primOpHasSideEffects WriteOffAddrOp_Addr = True+primOpHasSideEffects WriteOffAddrOp_Float = True+primOpHasSideEffects WriteOffAddrOp_Double = True+primOpHasSideEffects WriteOffAddrOp_StablePtr = True+primOpHasSideEffects WriteOffAddrOp_Int8 = True+primOpHasSideEffects WriteOffAddrOp_Int16 = True+primOpHasSideEffects WriteOffAddrOp_Int32 = True+primOpHasSideEffects WriteOffAddrOp_Int64 = True+primOpHasSideEffects WriteOffAddrOp_Word8 = True+primOpHasSideEffects WriteOffAddrOp_Word16 = True+primOpHasSideEffects WriteOffAddrOp_Word32 = True+primOpHasSideEffects WriteOffAddrOp_Word64 = True+primOpHasSideEffects NewMutVarOp = True+primOpHasSideEffects ReadMutVarOp = True+primOpHasSideEffects WriteMutVarOp = True+primOpHasSideEffects AtomicModifyMutVarOp = True+primOpHasSideEffects CasMutVarOp = True+primOpHasSideEffects CatchOp = True+primOpHasSideEffects RaiseOp = True+primOpHasSideEffects RaiseIOOp = True+primOpHasSideEffects MaskAsyncExceptionsOp = True+primOpHasSideEffects MaskUninterruptibleOp = True+primOpHasSideEffects UnmaskAsyncExceptionsOp = True+primOpHasSideEffects MaskStatus = True+primOpHasSideEffects AtomicallyOp = True+primOpHasSideEffects RetryOp = True+primOpHasSideEffects CatchRetryOp = True+primOpHasSideEffects CatchSTMOp = True+primOpHasSideEffects Check = True+primOpHasSideEffects NewTVarOp = True+primOpHasSideEffects ReadTVarOp = True+primOpHasSideEffects ReadTVarIOOp = True+primOpHasSideEffects WriteTVarOp = True+primOpHasSideEffects NewMVarOp = True+primOpHasSideEffects TakeMVarOp = True+primOpHasSideEffects TryTakeMVarOp = True+primOpHasSideEffects PutMVarOp = True+primOpHasSideEffects TryPutMVarOp = True+primOpHasSideEffects ReadMVarOp = True+primOpHasSideEffects TryReadMVarOp = True+primOpHasSideEffects IsEmptyMVarOp = True+primOpHasSideEffects DelayOp = True+primOpHasSideEffects WaitReadOp = True+primOpHasSideEffects WaitWriteOp = True+primOpHasSideEffects ForkOp = True+primOpHasSideEffects ForkOnOp = True+primOpHasSideEffects KillThreadOp = True+primOpHasSideEffects YieldOp = True+primOpHasSideEffects MyThreadIdOp = True+primOpHasSideEffects LabelThreadOp = True+primOpHasSideEffects IsCurrentThreadBoundOp = True+primOpHasSideEffects NoDuplicateOp = True+primOpHasSideEffects ThreadStatusOp = True+primOpHasSideEffects MkWeakOp = True+primOpHasSideEffects MkWeakNoFinalizerOp = True+primOpHasSideEffects AddCFinalizerToWeakOp = True+primOpHasSideEffects DeRefWeakOp = True+primOpHasSideEffects FinalizeWeakOp = True+primOpHasSideEffects TouchOp = True+primOpHasSideEffects MakeStablePtrOp = True+primOpHasSideEffects DeRefStablePtrOp = True+primOpHasSideEffects EqStablePtrOp = True+primOpHasSideEffects MakeStableNameOp = True+primOpHasSideEffects CompactNewOp = True+primOpHasSideEffects CompactResizeOp = True+primOpHasSideEffects CompactAllocateBlockOp = True+primOpHasSideEffects CompactFixupPointersOp = True+primOpHasSideEffects CompactAdd = True+primOpHasSideEffects CompactAddWithSharing = True+primOpHasSideEffects CompactSize = True+primOpHasSideEffects ParOp = True+primOpHasSideEffects SparkOp = True+primOpHasSideEffects GetSparkOp = True+primOpHasSideEffects NumSparks = True+primOpHasSideEffects NewBCOOp = True+primOpHasSideEffects TraceEventOp = True+primOpHasSideEffects TraceMarkerOp = True+primOpHasSideEffects (VecReadByteArrayOp _ _ _) = True+primOpHasSideEffects (VecWriteByteArrayOp _ _ _) = True+primOpHasSideEffects (VecReadOffAddrOp _ _ _) = True+primOpHasSideEffects (VecWriteOffAddrOp _ _ _) = True+primOpHasSideEffects (VecReadScalarByteArrayOp _ _ _) = True+primOpHasSideEffects (VecWriteScalarByteArrayOp _ _ _) = True+primOpHasSideEffects (VecReadScalarOffAddrOp _ _ _) = True+primOpHasSideEffects (VecWriteScalarOffAddrOp _ _ _) = True+primOpHasSideEffects PrefetchByteArrayOp3 = True+primOpHasSideEffects PrefetchMutableByteArrayOp3 = True+primOpHasSideEffects PrefetchAddrOp3 = True+primOpHasSideEffects PrefetchValueOp3 = True+primOpHasSideEffects PrefetchByteArrayOp2 = True+primOpHasSideEffects PrefetchMutableByteArrayOp2 = True+primOpHasSideEffects PrefetchAddrOp2 = True+primOpHasSideEffects PrefetchValueOp2 = True+primOpHasSideEffects PrefetchByteArrayOp1 = True+primOpHasSideEffects PrefetchMutableByteArrayOp1 = True+primOpHasSideEffects PrefetchAddrOp1 = True+primOpHasSideEffects PrefetchValueOp1 = True+primOpHasSideEffects PrefetchByteArrayOp0 = True+primOpHasSideEffects PrefetchMutableByteArrayOp0 = True+primOpHasSideEffects PrefetchAddrOp0 = True+primOpHasSideEffects PrefetchValueOp0 = True+primOpHasSideEffects _ = False
+ autogen/primop-list.hs-incl view
@@ -0,0 +1,1070 @@+   [CharGtOp+   , CharGeOp+   , CharEqOp+   , CharNeOp+   , CharLtOp+   , CharLeOp+   , OrdOp+   , IntAddOp+   , IntSubOp+   , IntMulOp+   , IntMulMayOfloOp+   , IntQuotOp+   , IntRemOp+   , IntQuotRemOp+   , AndIOp+   , OrIOp+   , XorIOp+   , NotIOp+   , IntNegOp+   , IntAddCOp+   , IntSubCOp+   , IntGtOp+   , IntGeOp+   , IntEqOp+   , IntNeOp+   , IntLtOp+   , IntLeOp+   , ChrOp+   , Int2WordOp+   , Int2FloatOp+   , Int2DoubleOp+   , Word2FloatOp+   , Word2DoubleOp+   , ISllOp+   , ISraOp+   , ISrlOp+   , WordAddOp+   , WordSubCOp+   , WordAdd2Op+   , WordSubOp+   , WordMulOp+   , WordMul2Op+   , WordQuotOp+   , WordRemOp+   , WordQuotRemOp+   , WordQuotRem2Op+   , AndOp+   , OrOp+   , XorOp+   , NotOp+   , SllOp+   , SrlOp+   , Word2IntOp+   , WordGtOp+   , WordGeOp+   , WordEqOp+   , WordNeOp+   , WordLtOp+   , WordLeOp+   , PopCnt8Op+   , PopCnt16Op+   , PopCnt32Op+   , PopCnt64Op+   , PopCntOp+   , Clz8Op+   , Clz16Op+   , Clz32Op+   , Clz64Op+   , ClzOp+   , Ctz8Op+   , Ctz16Op+   , Ctz32Op+   , Ctz64Op+   , CtzOp+   , BSwap16Op+   , BSwap32Op+   , BSwap64Op+   , BSwapOp+   , Narrow8IntOp+   , Narrow16IntOp+   , Narrow32IntOp+   , Narrow8WordOp+   , Narrow16WordOp+   , Narrow32WordOp+   , DoubleGtOp+   , DoubleGeOp+   , DoubleEqOp+   , DoubleNeOp+   , DoubleLtOp+   , DoubleLeOp+   , DoubleAddOp+   , DoubleSubOp+   , DoubleMulOp+   , DoubleDivOp+   , DoubleNegOp+   , DoubleFabsOp+   , Double2IntOp+   , Double2FloatOp+   , DoubleExpOp+   , DoubleLogOp+   , DoubleSqrtOp+   , DoubleSinOp+   , DoubleCosOp+   , DoubleTanOp+   , DoubleAsinOp+   , DoubleAcosOp+   , DoubleAtanOp+   , DoubleSinhOp+   , DoubleCoshOp+   , DoubleTanhOp+   , DoublePowerOp+   , DoubleDecode_2IntOp+   , DoubleDecode_Int64Op+   , FloatGtOp+   , FloatGeOp+   , FloatEqOp+   , FloatNeOp+   , FloatLtOp+   , FloatLeOp+   , FloatAddOp+   , FloatSubOp+   , FloatMulOp+   , FloatDivOp+   , FloatNegOp+   , FloatFabsOp+   , Float2IntOp+   , FloatExpOp+   , FloatLogOp+   , FloatSqrtOp+   , FloatSinOp+   , FloatCosOp+   , FloatTanOp+   , FloatAsinOp+   , FloatAcosOp+   , FloatAtanOp+   , FloatSinhOp+   , FloatCoshOp+   , FloatTanhOp+   , FloatPowerOp+   , Float2DoubleOp+   , FloatDecode_IntOp+   , NewArrayOp+   , SameMutableArrayOp+   , ReadArrayOp+   , WriteArrayOp+   , SizeofArrayOp+   , SizeofMutableArrayOp+   , IndexArrayOp+   , UnsafeFreezeArrayOp+   , UnsafeThawArrayOp+   , CopyArrayOp+   , CopyMutableArrayOp+   , CloneArrayOp+   , CloneMutableArrayOp+   , FreezeArrayOp+   , ThawArrayOp+   , CasArrayOp+   , NewSmallArrayOp+   , SameSmallMutableArrayOp+   , ReadSmallArrayOp+   , WriteSmallArrayOp+   , SizeofSmallArrayOp+   , SizeofSmallMutableArrayOp+   , IndexSmallArrayOp+   , UnsafeFreezeSmallArrayOp+   , UnsafeThawSmallArrayOp+   , CopySmallArrayOp+   , CopySmallMutableArrayOp+   , CloneSmallArrayOp+   , CloneSmallMutableArrayOp+   , FreezeSmallArrayOp+   , ThawSmallArrayOp+   , CasSmallArrayOp+   , NewByteArrayOp_Char+   , NewPinnedByteArrayOp_Char+   , NewAlignedPinnedByteArrayOp_Char+   , MutableByteArrayIsPinnedOp+   , ByteArrayIsPinnedOp+   , ByteArrayContents_Char+   , SameMutableByteArrayOp+   , ShrinkMutableByteArrayOp_Char+   , ResizeMutableByteArrayOp_Char+   , UnsafeFreezeByteArrayOp+   , SizeofByteArrayOp+   , SizeofMutableByteArrayOp+   , GetSizeofMutableByteArrayOp+   , IndexByteArrayOp_Char+   , IndexByteArrayOp_WideChar+   , IndexByteArrayOp_Int+   , IndexByteArrayOp_Word+   , IndexByteArrayOp_Addr+   , IndexByteArrayOp_Float+   , IndexByteArrayOp_Double+   , IndexByteArrayOp_StablePtr+   , IndexByteArrayOp_Int8+   , IndexByteArrayOp_Int16+   , IndexByteArrayOp_Int32+   , IndexByteArrayOp_Int64+   , IndexByteArrayOp_Word8+   , IndexByteArrayOp_Word16+   , IndexByteArrayOp_Word32+   , IndexByteArrayOp_Word64+   , ReadByteArrayOp_Char+   , ReadByteArrayOp_WideChar+   , ReadByteArrayOp_Int+   , ReadByteArrayOp_Word+   , ReadByteArrayOp_Addr+   , ReadByteArrayOp_Float+   , ReadByteArrayOp_Double+   , ReadByteArrayOp_StablePtr+   , ReadByteArrayOp_Int8+   , ReadByteArrayOp_Int16+   , ReadByteArrayOp_Int32+   , ReadByteArrayOp_Int64+   , ReadByteArrayOp_Word8+   , ReadByteArrayOp_Word16+   , ReadByteArrayOp_Word32+   , ReadByteArrayOp_Word64+   , WriteByteArrayOp_Char+   , WriteByteArrayOp_WideChar+   , WriteByteArrayOp_Int+   , WriteByteArrayOp_Word+   , WriteByteArrayOp_Addr+   , WriteByteArrayOp_Float+   , WriteByteArrayOp_Double+   , WriteByteArrayOp_StablePtr+   , WriteByteArrayOp_Int8+   , WriteByteArrayOp_Int16+   , WriteByteArrayOp_Int32+   , WriteByteArrayOp_Int64+   , WriteByteArrayOp_Word8+   , WriteByteArrayOp_Word16+   , WriteByteArrayOp_Word32+   , WriteByteArrayOp_Word64+   , CopyByteArrayOp+   , CopyMutableByteArrayOp+   , CopyByteArrayToAddrOp+   , CopyMutableByteArrayToAddrOp+   , CopyAddrToByteArrayOp+   , SetByteArrayOp+   , AtomicReadByteArrayOp_Int+   , AtomicWriteByteArrayOp_Int+   , CasByteArrayOp_Int+   , FetchAddByteArrayOp_Int+   , FetchSubByteArrayOp_Int+   , FetchAndByteArrayOp_Int+   , FetchNandByteArrayOp_Int+   , FetchOrByteArrayOp_Int+   , FetchXorByteArrayOp_Int+   , NewArrayArrayOp+   , SameMutableArrayArrayOp+   , UnsafeFreezeArrayArrayOp+   , SizeofArrayArrayOp+   , SizeofMutableArrayArrayOp+   , IndexArrayArrayOp_ByteArray+   , IndexArrayArrayOp_ArrayArray+   , ReadArrayArrayOp_ByteArray+   , ReadArrayArrayOp_MutableByteArray+   , ReadArrayArrayOp_ArrayArray+   , ReadArrayArrayOp_MutableArrayArray+   , WriteArrayArrayOp_ByteArray+   , WriteArrayArrayOp_MutableByteArray+   , WriteArrayArrayOp_ArrayArray+   , WriteArrayArrayOp_MutableArrayArray+   , CopyArrayArrayOp+   , CopyMutableArrayArrayOp+   , AddrAddOp+   , AddrSubOp+   , AddrRemOp+   , Addr2IntOp+   , Int2AddrOp+   , AddrGtOp+   , AddrGeOp+   , AddrEqOp+   , AddrNeOp+   , AddrLtOp+   , AddrLeOp+   , IndexOffAddrOp_Char+   , IndexOffAddrOp_WideChar+   , IndexOffAddrOp_Int+   , IndexOffAddrOp_Word+   , IndexOffAddrOp_Addr+   , IndexOffAddrOp_Float+   , IndexOffAddrOp_Double+   , IndexOffAddrOp_StablePtr+   , IndexOffAddrOp_Int8+   , IndexOffAddrOp_Int16+   , IndexOffAddrOp_Int32+   , IndexOffAddrOp_Int64+   , IndexOffAddrOp_Word8+   , IndexOffAddrOp_Word16+   , IndexOffAddrOp_Word32+   , IndexOffAddrOp_Word64+   , ReadOffAddrOp_Char+   , ReadOffAddrOp_WideChar+   , ReadOffAddrOp_Int+   , ReadOffAddrOp_Word+   , ReadOffAddrOp_Addr+   , ReadOffAddrOp_Float+   , ReadOffAddrOp_Double+   , ReadOffAddrOp_StablePtr+   , ReadOffAddrOp_Int8+   , ReadOffAddrOp_Int16+   , ReadOffAddrOp_Int32+   , ReadOffAddrOp_Int64+   , ReadOffAddrOp_Word8+   , ReadOffAddrOp_Word16+   , ReadOffAddrOp_Word32+   , ReadOffAddrOp_Word64+   , WriteOffAddrOp_Char+   , WriteOffAddrOp_WideChar+   , WriteOffAddrOp_Int+   , WriteOffAddrOp_Word+   , WriteOffAddrOp_Addr+   , WriteOffAddrOp_Float+   , WriteOffAddrOp_Double+   , WriteOffAddrOp_StablePtr+   , WriteOffAddrOp_Int8+   , WriteOffAddrOp_Int16+   , WriteOffAddrOp_Int32+   , WriteOffAddrOp_Int64+   , WriteOffAddrOp_Word8+   , WriteOffAddrOp_Word16+   , WriteOffAddrOp_Word32+   , WriteOffAddrOp_Word64+   , NewMutVarOp+   , ReadMutVarOp+   , WriteMutVarOp+   , SameMutVarOp+   , AtomicModifyMutVarOp+   , CasMutVarOp+   , CatchOp+   , RaiseOp+   , RaiseIOOp+   , MaskAsyncExceptionsOp+   , MaskUninterruptibleOp+   , UnmaskAsyncExceptionsOp+   , MaskStatus+   , AtomicallyOp+   , RetryOp+   , CatchRetryOp+   , CatchSTMOp+   , Check+   , NewTVarOp+   , ReadTVarOp+   , ReadTVarIOOp+   , WriteTVarOp+   , SameTVarOp+   , NewMVarOp+   , TakeMVarOp+   , TryTakeMVarOp+   , PutMVarOp+   , TryPutMVarOp+   , ReadMVarOp+   , TryReadMVarOp+   , SameMVarOp+   , IsEmptyMVarOp+   , DelayOp+   , WaitReadOp+   , WaitWriteOp+   , ForkOp+   , ForkOnOp+   , KillThreadOp+   , YieldOp+   , MyThreadIdOp+   , LabelThreadOp+   , IsCurrentThreadBoundOp+   , NoDuplicateOp+   , ThreadStatusOp+   , MkWeakOp+   , MkWeakNoFinalizerOp+   , AddCFinalizerToWeakOp+   , DeRefWeakOp+   , FinalizeWeakOp+   , TouchOp+   , MakeStablePtrOp+   , DeRefStablePtrOp+   , EqStablePtrOp+   , MakeStableNameOp+   , EqStableNameOp+   , StableNameToIntOp+   , CompactNewOp+   , CompactResizeOp+   , CompactContainsOp+   , CompactContainsAnyOp+   , CompactGetFirstBlockOp+   , CompactGetNextBlockOp+   , CompactAllocateBlockOp+   , CompactFixupPointersOp+   , CompactAdd+   , CompactAddWithSharing+   , CompactSize+   , ReallyUnsafePtrEqualityOp+   , ParOp+   , SparkOp+   , SeqOp+   , GetSparkOp+   , NumSparks+   , DataToTagOp+   , TagToEnumOp+   , AddrToAnyOp+   , AnyToAddrOp+   , MkApUpd0_Op+   , NewBCOOp+   , UnpackClosureOp+   , GetApStackValOp+   , GetCCSOfOp+   , GetCurrentCCSOp+   , ClearCCSOp+   , TraceEventOp+   , TraceMarkerOp+   , (VecBroadcastOp IntVec 16 W8)+   , (VecBroadcastOp IntVec 8 W16)+   , (VecBroadcastOp IntVec 4 W32)+   , (VecBroadcastOp IntVec 2 W64)+   , (VecBroadcastOp IntVec 32 W8)+   , (VecBroadcastOp IntVec 16 W16)+   , (VecBroadcastOp IntVec 8 W32)+   , (VecBroadcastOp IntVec 4 W64)+   , (VecBroadcastOp IntVec 64 W8)+   , (VecBroadcastOp IntVec 32 W16)+   , (VecBroadcastOp IntVec 16 W32)+   , (VecBroadcastOp IntVec 8 W64)+   , (VecBroadcastOp WordVec 16 W8)+   , (VecBroadcastOp WordVec 8 W16)+   , (VecBroadcastOp WordVec 4 W32)+   , (VecBroadcastOp WordVec 2 W64)+   , (VecBroadcastOp WordVec 32 W8)+   , (VecBroadcastOp WordVec 16 W16)+   , (VecBroadcastOp WordVec 8 W32)+   , (VecBroadcastOp WordVec 4 W64)+   , (VecBroadcastOp WordVec 64 W8)+   , (VecBroadcastOp WordVec 32 W16)+   , (VecBroadcastOp WordVec 16 W32)+   , (VecBroadcastOp WordVec 8 W64)+   , (VecBroadcastOp FloatVec 4 W32)+   , (VecBroadcastOp FloatVec 2 W64)+   , (VecBroadcastOp FloatVec 8 W32)+   , (VecBroadcastOp FloatVec 4 W64)+   , (VecBroadcastOp FloatVec 16 W32)+   , (VecBroadcastOp FloatVec 8 W64)+   , (VecPackOp IntVec 16 W8)+   , (VecPackOp IntVec 8 W16)+   , (VecPackOp IntVec 4 W32)+   , (VecPackOp IntVec 2 W64)+   , (VecPackOp IntVec 32 W8)+   , (VecPackOp IntVec 16 W16)+   , (VecPackOp IntVec 8 W32)+   , (VecPackOp IntVec 4 W64)+   , (VecPackOp IntVec 64 W8)+   , (VecPackOp IntVec 32 W16)+   , (VecPackOp IntVec 16 W32)+   , (VecPackOp IntVec 8 W64)+   , (VecPackOp WordVec 16 W8)+   , (VecPackOp WordVec 8 W16)+   , (VecPackOp WordVec 4 W32)+   , (VecPackOp WordVec 2 W64)+   , (VecPackOp WordVec 32 W8)+   , (VecPackOp WordVec 16 W16)+   , (VecPackOp WordVec 8 W32)+   , (VecPackOp WordVec 4 W64)+   , (VecPackOp WordVec 64 W8)+   , (VecPackOp WordVec 32 W16)+   , (VecPackOp WordVec 16 W32)+   , (VecPackOp WordVec 8 W64)+   , (VecPackOp FloatVec 4 W32)+   , (VecPackOp FloatVec 2 W64)+   , (VecPackOp FloatVec 8 W32)+   , (VecPackOp FloatVec 4 W64)+   , (VecPackOp FloatVec 16 W32)+   , (VecPackOp FloatVec 8 W64)+   , (VecUnpackOp IntVec 16 W8)+   , (VecUnpackOp IntVec 8 W16)+   , (VecUnpackOp IntVec 4 W32)+   , (VecUnpackOp IntVec 2 W64)+   , (VecUnpackOp IntVec 32 W8)+   , (VecUnpackOp IntVec 16 W16)+   , (VecUnpackOp IntVec 8 W32)+   , (VecUnpackOp IntVec 4 W64)+   , (VecUnpackOp IntVec 64 W8)+   , (VecUnpackOp IntVec 32 W16)+   , (VecUnpackOp IntVec 16 W32)+   , (VecUnpackOp IntVec 8 W64)+   , (VecUnpackOp WordVec 16 W8)+   , (VecUnpackOp WordVec 8 W16)+   , (VecUnpackOp WordVec 4 W32)+   , (VecUnpackOp WordVec 2 W64)+   , (VecUnpackOp WordVec 32 W8)+   , (VecUnpackOp WordVec 16 W16)+   , (VecUnpackOp WordVec 8 W32)+   , (VecUnpackOp WordVec 4 W64)+   , (VecUnpackOp WordVec 64 W8)+   , (VecUnpackOp WordVec 32 W16)+   , (VecUnpackOp WordVec 16 W32)+   , (VecUnpackOp WordVec 8 W64)+   , (VecUnpackOp FloatVec 4 W32)+   , (VecUnpackOp FloatVec 2 W64)+   , (VecUnpackOp FloatVec 8 W32)+   , (VecUnpackOp FloatVec 4 W64)+   , (VecUnpackOp FloatVec 16 W32)+   , (VecUnpackOp FloatVec 8 W64)+   , (VecInsertOp IntVec 16 W8)+   , (VecInsertOp IntVec 8 W16)+   , (VecInsertOp IntVec 4 W32)+   , (VecInsertOp IntVec 2 W64)+   , (VecInsertOp IntVec 32 W8)+   , (VecInsertOp IntVec 16 W16)+   , (VecInsertOp IntVec 8 W32)+   , (VecInsertOp IntVec 4 W64)+   , (VecInsertOp IntVec 64 W8)+   , (VecInsertOp IntVec 32 W16)+   , (VecInsertOp IntVec 16 W32)+   , (VecInsertOp IntVec 8 W64)+   , (VecInsertOp WordVec 16 W8)+   , (VecInsertOp WordVec 8 W16)+   , (VecInsertOp WordVec 4 W32)+   , (VecInsertOp WordVec 2 W64)+   , (VecInsertOp WordVec 32 W8)+   , (VecInsertOp WordVec 16 W16)+   , (VecInsertOp WordVec 8 W32)+   , (VecInsertOp WordVec 4 W64)+   , (VecInsertOp WordVec 64 W8)+   , (VecInsertOp WordVec 32 W16)+   , (VecInsertOp WordVec 16 W32)+   , (VecInsertOp WordVec 8 W64)+   , (VecInsertOp FloatVec 4 W32)+   , (VecInsertOp FloatVec 2 W64)+   , (VecInsertOp FloatVec 8 W32)+   , (VecInsertOp FloatVec 4 W64)+   , (VecInsertOp FloatVec 16 W32)+   , (VecInsertOp FloatVec 8 W64)+   , (VecAddOp IntVec 16 W8)+   , (VecAddOp IntVec 8 W16)+   , (VecAddOp IntVec 4 W32)+   , (VecAddOp IntVec 2 W64)+   , (VecAddOp IntVec 32 W8)+   , (VecAddOp IntVec 16 W16)+   , (VecAddOp IntVec 8 W32)+   , (VecAddOp IntVec 4 W64)+   , (VecAddOp IntVec 64 W8)+   , (VecAddOp IntVec 32 W16)+   , (VecAddOp IntVec 16 W32)+   , (VecAddOp IntVec 8 W64)+   , (VecAddOp WordVec 16 W8)+   , (VecAddOp WordVec 8 W16)+   , (VecAddOp WordVec 4 W32)+   , (VecAddOp WordVec 2 W64)+   , (VecAddOp WordVec 32 W8)+   , (VecAddOp WordVec 16 W16)+   , (VecAddOp WordVec 8 W32)+   , (VecAddOp WordVec 4 W64)+   , (VecAddOp WordVec 64 W8)+   , (VecAddOp WordVec 32 W16)+   , (VecAddOp WordVec 16 W32)+   , (VecAddOp WordVec 8 W64)+   , (VecAddOp FloatVec 4 W32)+   , (VecAddOp FloatVec 2 W64)+   , (VecAddOp FloatVec 8 W32)+   , (VecAddOp FloatVec 4 W64)+   , (VecAddOp FloatVec 16 W32)+   , (VecAddOp FloatVec 8 W64)+   , (VecSubOp IntVec 16 W8)+   , (VecSubOp IntVec 8 W16)+   , (VecSubOp IntVec 4 W32)+   , (VecSubOp IntVec 2 W64)+   , (VecSubOp IntVec 32 W8)+   , (VecSubOp IntVec 16 W16)+   , (VecSubOp IntVec 8 W32)+   , (VecSubOp IntVec 4 W64)+   , (VecSubOp IntVec 64 W8)+   , (VecSubOp IntVec 32 W16)+   , (VecSubOp IntVec 16 W32)+   , (VecSubOp IntVec 8 W64)+   , (VecSubOp WordVec 16 W8)+   , (VecSubOp WordVec 8 W16)+   , (VecSubOp WordVec 4 W32)+   , (VecSubOp WordVec 2 W64)+   , (VecSubOp WordVec 32 W8)+   , (VecSubOp WordVec 16 W16)+   , (VecSubOp WordVec 8 W32)+   , (VecSubOp WordVec 4 W64)+   , (VecSubOp WordVec 64 W8)+   , (VecSubOp WordVec 32 W16)+   , (VecSubOp WordVec 16 W32)+   , (VecSubOp WordVec 8 W64)+   , (VecSubOp FloatVec 4 W32)+   , (VecSubOp FloatVec 2 W64)+   , (VecSubOp FloatVec 8 W32)+   , (VecSubOp FloatVec 4 W64)+   , (VecSubOp FloatVec 16 W32)+   , (VecSubOp FloatVec 8 W64)+   , (VecMulOp IntVec 16 W8)+   , (VecMulOp IntVec 8 W16)+   , (VecMulOp IntVec 4 W32)+   , (VecMulOp IntVec 2 W64)+   , (VecMulOp IntVec 32 W8)+   , (VecMulOp IntVec 16 W16)+   , (VecMulOp IntVec 8 W32)+   , (VecMulOp IntVec 4 W64)+   , (VecMulOp IntVec 64 W8)+   , (VecMulOp IntVec 32 W16)+   , (VecMulOp IntVec 16 W32)+   , (VecMulOp IntVec 8 W64)+   , (VecMulOp WordVec 16 W8)+   , (VecMulOp WordVec 8 W16)+   , (VecMulOp WordVec 4 W32)+   , (VecMulOp WordVec 2 W64)+   , (VecMulOp WordVec 32 W8)+   , (VecMulOp WordVec 16 W16)+   , (VecMulOp WordVec 8 W32)+   , (VecMulOp WordVec 4 W64)+   , (VecMulOp WordVec 64 W8)+   , (VecMulOp WordVec 32 W16)+   , (VecMulOp WordVec 16 W32)+   , (VecMulOp WordVec 8 W64)+   , (VecMulOp FloatVec 4 W32)+   , (VecMulOp FloatVec 2 W64)+   , (VecMulOp FloatVec 8 W32)+   , (VecMulOp FloatVec 4 W64)+   , (VecMulOp FloatVec 16 W32)+   , (VecMulOp FloatVec 8 W64)+   , (VecDivOp FloatVec 4 W32)+   , (VecDivOp FloatVec 2 W64)+   , (VecDivOp FloatVec 8 W32)+   , (VecDivOp FloatVec 4 W64)+   , (VecDivOp FloatVec 16 W32)+   , (VecDivOp FloatVec 8 W64)+   , (VecQuotOp IntVec 16 W8)+   , (VecQuotOp IntVec 8 W16)+   , (VecQuotOp IntVec 4 W32)+   , (VecQuotOp IntVec 2 W64)+   , (VecQuotOp IntVec 32 W8)+   , (VecQuotOp IntVec 16 W16)+   , (VecQuotOp IntVec 8 W32)+   , (VecQuotOp IntVec 4 W64)+   , (VecQuotOp IntVec 64 W8)+   , (VecQuotOp IntVec 32 W16)+   , (VecQuotOp IntVec 16 W32)+   , (VecQuotOp IntVec 8 W64)+   , (VecQuotOp WordVec 16 W8)+   , (VecQuotOp WordVec 8 W16)+   , (VecQuotOp WordVec 4 W32)+   , (VecQuotOp WordVec 2 W64)+   , (VecQuotOp WordVec 32 W8)+   , (VecQuotOp WordVec 16 W16)+   , (VecQuotOp WordVec 8 W32)+   , (VecQuotOp WordVec 4 W64)+   , (VecQuotOp WordVec 64 W8)+   , (VecQuotOp WordVec 32 W16)+   , (VecQuotOp WordVec 16 W32)+   , (VecQuotOp WordVec 8 W64)+   , (VecRemOp IntVec 16 W8)+   , (VecRemOp IntVec 8 W16)+   , (VecRemOp IntVec 4 W32)+   , (VecRemOp IntVec 2 W64)+   , (VecRemOp IntVec 32 W8)+   , (VecRemOp IntVec 16 W16)+   , (VecRemOp IntVec 8 W32)+   , (VecRemOp IntVec 4 W64)+   , (VecRemOp IntVec 64 W8)+   , (VecRemOp IntVec 32 W16)+   , (VecRemOp IntVec 16 W32)+   , (VecRemOp IntVec 8 W64)+   , (VecRemOp WordVec 16 W8)+   , (VecRemOp WordVec 8 W16)+   , (VecRemOp WordVec 4 W32)+   , (VecRemOp WordVec 2 W64)+   , (VecRemOp WordVec 32 W8)+   , (VecRemOp WordVec 16 W16)+   , (VecRemOp WordVec 8 W32)+   , (VecRemOp WordVec 4 W64)+   , (VecRemOp WordVec 64 W8)+   , (VecRemOp WordVec 32 W16)+   , (VecRemOp WordVec 16 W32)+   , (VecRemOp WordVec 8 W64)+   , (VecNegOp IntVec 16 W8)+   , (VecNegOp IntVec 8 W16)+   , (VecNegOp IntVec 4 W32)+   , (VecNegOp IntVec 2 W64)+   , (VecNegOp IntVec 32 W8)+   , (VecNegOp IntVec 16 W16)+   , (VecNegOp IntVec 8 W32)+   , (VecNegOp IntVec 4 W64)+   , (VecNegOp IntVec 64 W8)+   , (VecNegOp IntVec 32 W16)+   , (VecNegOp IntVec 16 W32)+   , (VecNegOp IntVec 8 W64)+   , (VecNegOp FloatVec 4 W32)+   , (VecNegOp FloatVec 2 W64)+   , (VecNegOp FloatVec 8 W32)+   , (VecNegOp FloatVec 4 W64)+   , (VecNegOp FloatVec 16 W32)+   , (VecNegOp FloatVec 8 W64)+   , (VecIndexByteArrayOp IntVec 16 W8)+   , (VecIndexByteArrayOp IntVec 8 W16)+   , (VecIndexByteArrayOp IntVec 4 W32)+   , (VecIndexByteArrayOp IntVec 2 W64)+   , (VecIndexByteArrayOp IntVec 32 W8)+   , (VecIndexByteArrayOp IntVec 16 W16)+   , (VecIndexByteArrayOp IntVec 8 W32)+   , (VecIndexByteArrayOp IntVec 4 W64)+   , (VecIndexByteArrayOp IntVec 64 W8)+   , (VecIndexByteArrayOp IntVec 32 W16)+   , (VecIndexByteArrayOp IntVec 16 W32)+   , (VecIndexByteArrayOp IntVec 8 W64)+   , (VecIndexByteArrayOp WordVec 16 W8)+   , (VecIndexByteArrayOp WordVec 8 W16)+   , (VecIndexByteArrayOp WordVec 4 W32)+   , (VecIndexByteArrayOp WordVec 2 W64)+   , (VecIndexByteArrayOp WordVec 32 W8)+   , (VecIndexByteArrayOp WordVec 16 W16)+   , (VecIndexByteArrayOp WordVec 8 W32)+   , (VecIndexByteArrayOp WordVec 4 W64)+   , (VecIndexByteArrayOp WordVec 64 W8)+   , (VecIndexByteArrayOp WordVec 32 W16)+   , (VecIndexByteArrayOp WordVec 16 W32)+   , (VecIndexByteArrayOp WordVec 8 W64)+   , (VecIndexByteArrayOp FloatVec 4 W32)+   , (VecIndexByteArrayOp FloatVec 2 W64)+   , (VecIndexByteArrayOp FloatVec 8 W32)+   , (VecIndexByteArrayOp FloatVec 4 W64)+   , (VecIndexByteArrayOp FloatVec 16 W32)+   , (VecIndexByteArrayOp FloatVec 8 W64)+   , (VecReadByteArrayOp IntVec 16 W8)+   , (VecReadByteArrayOp IntVec 8 W16)+   , (VecReadByteArrayOp IntVec 4 W32)+   , (VecReadByteArrayOp IntVec 2 W64)+   , (VecReadByteArrayOp IntVec 32 W8)+   , (VecReadByteArrayOp IntVec 16 W16)+   , (VecReadByteArrayOp IntVec 8 W32)+   , (VecReadByteArrayOp IntVec 4 W64)+   , (VecReadByteArrayOp IntVec 64 W8)+   , (VecReadByteArrayOp IntVec 32 W16)+   , (VecReadByteArrayOp IntVec 16 W32)+   , (VecReadByteArrayOp IntVec 8 W64)+   , (VecReadByteArrayOp WordVec 16 W8)+   , (VecReadByteArrayOp WordVec 8 W16)+   , (VecReadByteArrayOp WordVec 4 W32)+   , (VecReadByteArrayOp WordVec 2 W64)+   , (VecReadByteArrayOp WordVec 32 W8)+   , (VecReadByteArrayOp WordVec 16 W16)+   , (VecReadByteArrayOp WordVec 8 W32)+   , (VecReadByteArrayOp WordVec 4 W64)+   , (VecReadByteArrayOp WordVec 64 W8)+   , (VecReadByteArrayOp WordVec 32 W16)+   , (VecReadByteArrayOp WordVec 16 W32)+   , (VecReadByteArrayOp WordVec 8 W64)+   , (VecReadByteArrayOp FloatVec 4 W32)+   , (VecReadByteArrayOp FloatVec 2 W64)+   , (VecReadByteArrayOp FloatVec 8 W32)+   , (VecReadByteArrayOp FloatVec 4 W64)+   , (VecReadByteArrayOp FloatVec 16 W32)+   , (VecReadByteArrayOp FloatVec 8 W64)+   , (VecWriteByteArrayOp IntVec 16 W8)+   , (VecWriteByteArrayOp IntVec 8 W16)+   , (VecWriteByteArrayOp IntVec 4 W32)+   , (VecWriteByteArrayOp IntVec 2 W64)+   , (VecWriteByteArrayOp IntVec 32 W8)+   , (VecWriteByteArrayOp IntVec 16 W16)+   , (VecWriteByteArrayOp IntVec 8 W32)+   , (VecWriteByteArrayOp IntVec 4 W64)+   , (VecWriteByteArrayOp IntVec 64 W8)+   , (VecWriteByteArrayOp IntVec 32 W16)+   , (VecWriteByteArrayOp IntVec 16 W32)+   , (VecWriteByteArrayOp IntVec 8 W64)+   , (VecWriteByteArrayOp WordVec 16 W8)+   , (VecWriteByteArrayOp WordVec 8 W16)+   , (VecWriteByteArrayOp WordVec 4 W32)+   , (VecWriteByteArrayOp WordVec 2 W64)+   , (VecWriteByteArrayOp WordVec 32 W8)+   , (VecWriteByteArrayOp WordVec 16 W16)+   , (VecWriteByteArrayOp WordVec 8 W32)+   , (VecWriteByteArrayOp WordVec 4 W64)+   , (VecWriteByteArrayOp WordVec 64 W8)+   , (VecWriteByteArrayOp WordVec 32 W16)+   , (VecWriteByteArrayOp WordVec 16 W32)+   , (VecWriteByteArrayOp WordVec 8 W64)+   , (VecWriteByteArrayOp FloatVec 4 W32)+   , (VecWriteByteArrayOp FloatVec 2 W64)+   , (VecWriteByteArrayOp FloatVec 8 W32)+   , (VecWriteByteArrayOp FloatVec 4 W64)+   , (VecWriteByteArrayOp FloatVec 16 W32)+   , (VecWriteByteArrayOp FloatVec 8 W64)+   , (VecIndexOffAddrOp IntVec 16 W8)+   , (VecIndexOffAddrOp IntVec 8 W16)+   , (VecIndexOffAddrOp IntVec 4 W32)+   , (VecIndexOffAddrOp IntVec 2 W64)+   , (VecIndexOffAddrOp IntVec 32 W8)+   , (VecIndexOffAddrOp IntVec 16 W16)+   , (VecIndexOffAddrOp IntVec 8 W32)+   , (VecIndexOffAddrOp IntVec 4 W64)+   , (VecIndexOffAddrOp IntVec 64 W8)+   , (VecIndexOffAddrOp IntVec 32 W16)+   , (VecIndexOffAddrOp IntVec 16 W32)+   , (VecIndexOffAddrOp IntVec 8 W64)+   , (VecIndexOffAddrOp WordVec 16 W8)+   , (VecIndexOffAddrOp WordVec 8 W16)+   , (VecIndexOffAddrOp WordVec 4 W32)+   , (VecIndexOffAddrOp WordVec 2 W64)+   , (VecIndexOffAddrOp WordVec 32 W8)+   , (VecIndexOffAddrOp WordVec 16 W16)+   , (VecIndexOffAddrOp WordVec 8 W32)+   , (VecIndexOffAddrOp WordVec 4 W64)+   , (VecIndexOffAddrOp WordVec 64 W8)+   , (VecIndexOffAddrOp WordVec 32 W16)+   , (VecIndexOffAddrOp WordVec 16 W32)+   , (VecIndexOffAddrOp WordVec 8 W64)+   , (VecIndexOffAddrOp FloatVec 4 W32)+   , (VecIndexOffAddrOp FloatVec 2 W64)+   , (VecIndexOffAddrOp FloatVec 8 W32)+   , (VecIndexOffAddrOp FloatVec 4 W64)+   , (VecIndexOffAddrOp FloatVec 16 W32)+   , (VecIndexOffAddrOp FloatVec 8 W64)+   , (VecReadOffAddrOp IntVec 16 W8)+   , (VecReadOffAddrOp IntVec 8 W16)+   , (VecReadOffAddrOp IntVec 4 W32)+   , (VecReadOffAddrOp IntVec 2 W64)+   , (VecReadOffAddrOp IntVec 32 W8)+   , (VecReadOffAddrOp IntVec 16 W16)+   , (VecReadOffAddrOp IntVec 8 W32)+   , (VecReadOffAddrOp IntVec 4 W64)+   , (VecReadOffAddrOp IntVec 64 W8)+   , (VecReadOffAddrOp IntVec 32 W16)+   , (VecReadOffAddrOp IntVec 16 W32)+   , (VecReadOffAddrOp IntVec 8 W64)+   , (VecReadOffAddrOp WordVec 16 W8)+   , (VecReadOffAddrOp WordVec 8 W16)+   , (VecReadOffAddrOp WordVec 4 W32)+   , (VecReadOffAddrOp WordVec 2 W64)+   , (VecReadOffAddrOp WordVec 32 W8)+   , (VecReadOffAddrOp WordVec 16 W16)+   , (VecReadOffAddrOp WordVec 8 W32)+   , (VecReadOffAddrOp WordVec 4 W64)+   , (VecReadOffAddrOp WordVec 64 W8)+   , (VecReadOffAddrOp WordVec 32 W16)+   , (VecReadOffAddrOp WordVec 16 W32)+   , (VecReadOffAddrOp WordVec 8 W64)+   , (VecReadOffAddrOp FloatVec 4 W32)+   , (VecReadOffAddrOp FloatVec 2 W64)+   , (VecReadOffAddrOp FloatVec 8 W32)+   , (VecReadOffAddrOp FloatVec 4 W64)+   , (VecReadOffAddrOp FloatVec 16 W32)+   , (VecReadOffAddrOp FloatVec 8 W64)+   , (VecWriteOffAddrOp IntVec 16 W8)+   , (VecWriteOffAddrOp IntVec 8 W16)+   , (VecWriteOffAddrOp IntVec 4 W32)+   , (VecWriteOffAddrOp IntVec 2 W64)+   , (VecWriteOffAddrOp IntVec 32 W8)+   , (VecWriteOffAddrOp IntVec 16 W16)+   , (VecWriteOffAddrOp IntVec 8 W32)+   , (VecWriteOffAddrOp IntVec 4 W64)+   , (VecWriteOffAddrOp IntVec 64 W8)+   , (VecWriteOffAddrOp IntVec 32 W16)+   , (VecWriteOffAddrOp IntVec 16 W32)+   , (VecWriteOffAddrOp IntVec 8 W64)+   , (VecWriteOffAddrOp WordVec 16 W8)+   , (VecWriteOffAddrOp WordVec 8 W16)+   , (VecWriteOffAddrOp WordVec 4 W32)+   , (VecWriteOffAddrOp WordVec 2 W64)+   , (VecWriteOffAddrOp WordVec 32 W8)+   , (VecWriteOffAddrOp WordVec 16 W16)+   , (VecWriteOffAddrOp WordVec 8 W32)+   , (VecWriteOffAddrOp WordVec 4 W64)+   , (VecWriteOffAddrOp WordVec 64 W8)+   , (VecWriteOffAddrOp WordVec 32 W16)+   , (VecWriteOffAddrOp WordVec 16 W32)+   , (VecWriteOffAddrOp WordVec 8 W64)+   , (VecWriteOffAddrOp FloatVec 4 W32)+   , (VecWriteOffAddrOp FloatVec 2 W64)+   , (VecWriteOffAddrOp FloatVec 8 W32)+   , (VecWriteOffAddrOp FloatVec 4 W64)+   , (VecWriteOffAddrOp FloatVec 16 W32)+   , (VecWriteOffAddrOp FloatVec 8 W64)+   , (VecIndexScalarByteArrayOp IntVec 16 W8)+   , (VecIndexScalarByteArrayOp IntVec 8 W16)+   , (VecIndexScalarByteArrayOp IntVec 4 W32)+   , (VecIndexScalarByteArrayOp IntVec 2 W64)+   , (VecIndexScalarByteArrayOp IntVec 32 W8)+   , (VecIndexScalarByteArrayOp IntVec 16 W16)+   , (VecIndexScalarByteArrayOp IntVec 8 W32)+   , (VecIndexScalarByteArrayOp IntVec 4 W64)+   , (VecIndexScalarByteArrayOp IntVec 64 W8)+   , (VecIndexScalarByteArrayOp IntVec 32 W16)+   , (VecIndexScalarByteArrayOp IntVec 16 W32)+   , (VecIndexScalarByteArrayOp IntVec 8 W64)+   , (VecIndexScalarByteArrayOp WordVec 16 W8)+   , (VecIndexScalarByteArrayOp WordVec 8 W16)+   , (VecIndexScalarByteArrayOp WordVec 4 W32)+   , (VecIndexScalarByteArrayOp WordVec 2 W64)+   , (VecIndexScalarByteArrayOp WordVec 32 W8)+   , (VecIndexScalarByteArrayOp WordVec 16 W16)+   , (VecIndexScalarByteArrayOp WordVec 8 W32)+   , (VecIndexScalarByteArrayOp WordVec 4 W64)+   , (VecIndexScalarByteArrayOp WordVec 64 W8)+   , (VecIndexScalarByteArrayOp WordVec 32 W16)+   , (VecIndexScalarByteArrayOp WordVec 16 W32)+   , (VecIndexScalarByteArrayOp WordVec 8 W64)+   , (VecIndexScalarByteArrayOp FloatVec 4 W32)+   , (VecIndexScalarByteArrayOp FloatVec 2 W64)+   , (VecIndexScalarByteArrayOp FloatVec 8 W32)+   , (VecIndexScalarByteArrayOp FloatVec 4 W64)+   , (VecIndexScalarByteArrayOp FloatVec 16 W32)+   , (VecIndexScalarByteArrayOp FloatVec 8 W64)+   , (VecReadScalarByteArrayOp IntVec 16 W8)+   , (VecReadScalarByteArrayOp IntVec 8 W16)+   , (VecReadScalarByteArrayOp IntVec 4 W32)+   , (VecReadScalarByteArrayOp IntVec 2 W64)+   , (VecReadScalarByteArrayOp IntVec 32 W8)+   , (VecReadScalarByteArrayOp IntVec 16 W16)+   , (VecReadScalarByteArrayOp IntVec 8 W32)+   , (VecReadScalarByteArrayOp IntVec 4 W64)+   , (VecReadScalarByteArrayOp IntVec 64 W8)+   , (VecReadScalarByteArrayOp IntVec 32 W16)+   , (VecReadScalarByteArrayOp IntVec 16 W32)+   , (VecReadScalarByteArrayOp IntVec 8 W64)+   , (VecReadScalarByteArrayOp WordVec 16 W8)+   , (VecReadScalarByteArrayOp WordVec 8 W16)+   , (VecReadScalarByteArrayOp WordVec 4 W32)+   , (VecReadScalarByteArrayOp WordVec 2 W64)+   , (VecReadScalarByteArrayOp WordVec 32 W8)+   , (VecReadScalarByteArrayOp WordVec 16 W16)+   , (VecReadScalarByteArrayOp WordVec 8 W32)+   , (VecReadScalarByteArrayOp WordVec 4 W64)+   , (VecReadScalarByteArrayOp WordVec 64 W8)+   , (VecReadScalarByteArrayOp WordVec 32 W16)+   , (VecReadScalarByteArrayOp WordVec 16 W32)+   , (VecReadScalarByteArrayOp WordVec 8 W64)+   , (VecReadScalarByteArrayOp FloatVec 4 W32)+   , (VecReadScalarByteArrayOp FloatVec 2 W64)+   , (VecReadScalarByteArrayOp FloatVec 8 W32)+   , (VecReadScalarByteArrayOp FloatVec 4 W64)+   , (VecReadScalarByteArrayOp FloatVec 16 W32)+   , (VecReadScalarByteArrayOp FloatVec 8 W64)+   , (VecWriteScalarByteArrayOp IntVec 16 W8)+   , (VecWriteScalarByteArrayOp IntVec 8 W16)+   , (VecWriteScalarByteArrayOp IntVec 4 W32)+   , (VecWriteScalarByteArrayOp IntVec 2 W64)+   , (VecWriteScalarByteArrayOp IntVec 32 W8)+   , (VecWriteScalarByteArrayOp IntVec 16 W16)+   , (VecWriteScalarByteArrayOp IntVec 8 W32)+   , (VecWriteScalarByteArrayOp IntVec 4 W64)+   , (VecWriteScalarByteArrayOp IntVec 64 W8)+   , (VecWriteScalarByteArrayOp IntVec 32 W16)+   , (VecWriteScalarByteArrayOp IntVec 16 W32)+   , (VecWriteScalarByteArrayOp IntVec 8 W64)+   , (VecWriteScalarByteArrayOp WordVec 16 W8)+   , (VecWriteScalarByteArrayOp WordVec 8 W16)+   , (VecWriteScalarByteArrayOp WordVec 4 W32)+   , (VecWriteScalarByteArrayOp WordVec 2 W64)+   , (VecWriteScalarByteArrayOp WordVec 32 W8)+   , (VecWriteScalarByteArrayOp WordVec 16 W16)+   , (VecWriteScalarByteArrayOp WordVec 8 W32)+   , (VecWriteScalarByteArrayOp WordVec 4 W64)+   , (VecWriteScalarByteArrayOp WordVec 64 W8)+   , (VecWriteScalarByteArrayOp WordVec 32 W16)+   , (VecWriteScalarByteArrayOp WordVec 16 W32)+   , (VecWriteScalarByteArrayOp WordVec 8 W64)+   , (VecWriteScalarByteArrayOp FloatVec 4 W32)+   , (VecWriteScalarByteArrayOp FloatVec 2 W64)+   , (VecWriteScalarByteArrayOp FloatVec 8 W32)+   , (VecWriteScalarByteArrayOp FloatVec 4 W64)+   , (VecWriteScalarByteArrayOp FloatVec 16 W32)+   , (VecWriteScalarByteArrayOp FloatVec 8 W64)+   , (VecIndexScalarOffAddrOp IntVec 16 W8)+   , (VecIndexScalarOffAddrOp IntVec 8 W16)+   , (VecIndexScalarOffAddrOp IntVec 4 W32)+   , (VecIndexScalarOffAddrOp IntVec 2 W64)+   , (VecIndexScalarOffAddrOp IntVec 32 W8)+   , (VecIndexScalarOffAddrOp IntVec 16 W16)+   , (VecIndexScalarOffAddrOp IntVec 8 W32)+   , (VecIndexScalarOffAddrOp IntVec 4 W64)+   , (VecIndexScalarOffAddrOp IntVec 64 W8)+   , (VecIndexScalarOffAddrOp IntVec 32 W16)+   , (VecIndexScalarOffAddrOp IntVec 16 W32)+   , (VecIndexScalarOffAddrOp IntVec 8 W64)+   , (VecIndexScalarOffAddrOp WordVec 16 W8)+   , (VecIndexScalarOffAddrOp WordVec 8 W16)+   , (VecIndexScalarOffAddrOp WordVec 4 W32)+   , (VecIndexScalarOffAddrOp WordVec 2 W64)+   , (VecIndexScalarOffAddrOp WordVec 32 W8)+   , (VecIndexScalarOffAddrOp WordVec 16 W16)+   , (VecIndexScalarOffAddrOp WordVec 8 W32)+   , (VecIndexScalarOffAddrOp WordVec 4 W64)+   , (VecIndexScalarOffAddrOp WordVec 64 W8)+   , (VecIndexScalarOffAddrOp WordVec 32 W16)+   , (VecIndexScalarOffAddrOp WordVec 16 W32)+   , (VecIndexScalarOffAddrOp WordVec 8 W64)+   , (VecIndexScalarOffAddrOp FloatVec 4 W32)+   , (VecIndexScalarOffAddrOp FloatVec 2 W64)+   , (VecIndexScalarOffAddrOp FloatVec 8 W32)+   , (VecIndexScalarOffAddrOp FloatVec 4 W64)+   , (VecIndexScalarOffAddrOp FloatVec 16 W32)+   , (VecIndexScalarOffAddrOp FloatVec 8 W64)+   , (VecReadScalarOffAddrOp IntVec 16 W8)+   , (VecReadScalarOffAddrOp IntVec 8 W16)+   , (VecReadScalarOffAddrOp IntVec 4 W32)+   , (VecReadScalarOffAddrOp IntVec 2 W64)+   , (VecReadScalarOffAddrOp IntVec 32 W8)+   , (VecReadScalarOffAddrOp IntVec 16 W16)+   , (VecReadScalarOffAddrOp IntVec 8 W32)+   , (VecReadScalarOffAddrOp IntVec 4 W64)+   , (VecReadScalarOffAddrOp IntVec 64 W8)+   , (VecReadScalarOffAddrOp IntVec 32 W16)+   , (VecReadScalarOffAddrOp IntVec 16 W32)+   , (VecReadScalarOffAddrOp IntVec 8 W64)+   , (VecReadScalarOffAddrOp WordVec 16 W8)+   , (VecReadScalarOffAddrOp WordVec 8 W16)+   , (VecReadScalarOffAddrOp WordVec 4 W32)+   , (VecReadScalarOffAddrOp WordVec 2 W64)+   , (VecReadScalarOffAddrOp WordVec 32 W8)+   , (VecReadScalarOffAddrOp WordVec 16 W16)+   , (VecReadScalarOffAddrOp WordVec 8 W32)+   , (VecReadScalarOffAddrOp WordVec 4 W64)+   , (VecReadScalarOffAddrOp WordVec 64 W8)+   , (VecReadScalarOffAddrOp WordVec 32 W16)+   , (VecReadScalarOffAddrOp WordVec 16 W32)+   , (VecReadScalarOffAddrOp WordVec 8 W64)+   , (VecReadScalarOffAddrOp FloatVec 4 W32)+   , (VecReadScalarOffAddrOp FloatVec 2 W64)+   , (VecReadScalarOffAddrOp FloatVec 8 W32)+   , (VecReadScalarOffAddrOp FloatVec 4 W64)+   , (VecReadScalarOffAddrOp FloatVec 16 W32)+   , (VecReadScalarOffAddrOp FloatVec 8 W64)+   , (VecWriteScalarOffAddrOp IntVec 16 W8)+   , (VecWriteScalarOffAddrOp IntVec 8 W16)+   , (VecWriteScalarOffAddrOp IntVec 4 W32)+   , (VecWriteScalarOffAddrOp IntVec 2 W64)+   , (VecWriteScalarOffAddrOp IntVec 32 W8)+   , (VecWriteScalarOffAddrOp IntVec 16 W16)+   , (VecWriteScalarOffAddrOp IntVec 8 W32)+   , (VecWriteScalarOffAddrOp IntVec 4 W64)+   , (VecWriteScalarOffAddrOp IntVec 64 W8)+   , (VecWriteScalarOffAddrOp IntVec 32 W16)+   , (VecWriteScalarOffAddrOp IntVec 16 W32)+   , (VecWriteScalarOffAddrOp IntVec 8 W64)+   , (VecWriteScalarOffAddrOp WordVec 16 W8)+   , (VecWriteScalarOffAddrOp WordVec 8 W16)+   , (VecWriteScalarOffAddrOp WordVec 4 W32)+   , (VecWriteScalarOffAddrOp WordVec 2 W64)+   , (VecWriteScalarOffAddrOp WordVec 32 W8)+   , (VecWriteScalarOffAddrOp WordVec 16 W16)+   , (VecWriteScalarOffAddrOp WordVec 8 W32)+   , (VecWriteScalarOffAddrOp WordVec 4 W64)+   , (VecWriteScalarOffAddrOp WordVec 64 W8)+   , (VecWriteScalarOffAddrOp WordVec 32 W16)+   , (VecWriteScalarOffAddrOp WordVec 16 W32)+   , (VecWriteScalarOffAddrOp WordVec 8 W64)+   , (VecWriteScalarOffAddrOp FloatVec 4 W32)+   , (VecWriteScalarOffAddrOp FloatVec 2 W64)+   , (VecWriteScalarOffAddrOp FloatVec 8 W32)+   , (VecWriteScalarOffAddrOp FloatVec 4 W64)+   , (VecWriteScalarOffAddrOp FloatVec 16 W32)+   , (VecWriteScalarOffAddrOp FloatVec 8 W64)+   , PrefetchByteArrayOp3+   , PrefetchMutableByteArrayOp3+   , PrefetchAddrOp3+   , PrefetchValueOp3+   , PrefetchByteArrayOp2+   , PrefetchMutableByteArrayOp2+   , PrefetchAddrOp2+   , PrefetchValueOp2+   , PrefetchByteArrayOp1+   , PrefetchMutableByteArrayOp1+   , PrefetchAddrOp1+   , PrefetchValueOp1+   , PrefetchByteArrayOp0+   , PrefetchMutableByteArrayOp0+   , PrefetchAddrOp0+   , PrefetchValueOp0+   ]
+ autogen/primop-out-of-line.hs-incl view
@@ -0,0 +1,99 @@+primOpOutOfLine DoubleDecode_2IntOp = True+primOpOutOfLine DoubleDecode_Int64Op = True+primOpOutOfLine FloatDecode_IntOp = True+primOpOutOfLine NewArrayOp = True+primOpOutOfLine UnsafeThawArrayOp = True+primOpOutOfLine CopyArrayOp = True+primOpOutOfLine CopyMutableArrayOp = True+primOpOutOfLine CloneArrayOp = True+primOpOutOfLine CloneMutableArrayOp = True+primOpOutOfLine FreezeArrayOp = True+primOpOutOfLine ThawArrayOp = True+primOpOutOfLine CasArrayOp = True+primOpOutOfLine NewSmallArrayOp = True+primOpOutOfLine UnsafeThawSmallArrayOp = True+primOpOutOfLine CopySmallArrayOp = True+primOpOutOfLine CopySmallMutableArrayOp = True+primOpOutOfLine CloneSmallArrayOp = True+primOpOutOfLine CloneSmallMutableArrayOp = True+primOpOutOfLine FreezeSmallArrayOp = True+primOpOutOfLine ThawSmallArrayOp = True+primOpOutOfLine CasSmallArrayOp = True+primOpOutOfLine NewByteArrayOp_Char = True+primOpOutOfLine NewPinnedByteArrayOp_Char = True+primOpOutOfLine NewAlignedPinnedByteArrayOp_Char = True+primOpOutOfLine MutableByteArrayIsPinnedOp = True+primOpOutOfLine ByteArrayIsPinnedOp = True+primOpOutOfLine ShrinkMutableByteArrayOp_Char = True+primOpOutOfLine ResizeMutableByteArrayOp_Char = True+primOpOutOfLine NewArrayArrayOp = True+primOpOutOfLine CopyArrayArrayOp = True+primOpOutOfLine CopyMutableArrayArrayOp = True+primOpOutOfLine NewMutVarOp = True+primOpOutOfLine AtomicModifyMutVarOp = True+primOpOutOfLine CasMutVarOp = True+primOpOutOfLine CatchOp = True+primOpOutOfLine RaiseOp = True+primOpOutOfLine RaiseIOOp = True+primOpOutOfLine MaskAsyncExceptionsOp = True+primOpOutOfLine MaskUninterruptibleOp = True+primOpOutOfLine UnmaskAsyncExceptionsOp = True+primOpOutOfLine MaskStatus = True+primOpOutOfLine AtomicallyOp = True+primOpOutOfLine RetryOp = True+primOpOutOfLine CatchRetryOp = True+primOpOutOfLine CatchSTMOp = True+primOpOutOfLine Check = True+primOpOutOfLine NewTVarOp = True+primOpOutOfLine ReadTVarOp = True+primOpOutOfLine ReadTVarIOOp = True+primOpOutOfLine WriteTVarOp = True+primOpOutOfLine NewMVarOp = True+primOpOutOfLine TakeMVarOp = True+primOpOutOfLine TryTakeMVarOp = True+primOpOutOfLine PutMVarOp = True+primOpOutOfLine TryPutMVarOp = True+primOpOutOfLine ReadMVarOp = True+primOpOutOfLine TryReadMVarOp = True+primOpOutOfLine IsEmptyMVarOp = True+primOpOutOfLine DelayOp = True+primOpOutOfLine WaitReadOp = True+primOpOutOfLine WaitWriteOp = True+primOpOutOfLine ForkOp = True+primOpOutOfLine ForkOnOp = True+primOpOutOfLine KillThreadOp = True+primOpOutOfLine YieldOp = True+primOpOutOfLine MyThreadIdOp = True+primOpOutOfLine LabelThreadOp = True+primOpOutOfLine IsCurrentThreadBoundOp = True+primOpOutOfLine NoDuplicateOp = True+primOpOutOfLine ThreadStatusOp = True+primOpOutOfLine MkWeakOp = True+primOpOutOfLine MkWeakNoFinalizerOp = True+primOpOutOfLine AddCFinalizerToWeakOp = True+primOpOutOfLine DeRefWeakOp = True+primOpOutOfLine FinalizeWeakOp = True+primOpOutOfLine MakeStablePtrOp = True+primOpOutOfLine DeRefStablePtrOp = True+primOpOutOfLine MakeStableNameOp = True+primOpOutOfLine CompactNewOp = True+primOpOutOfLine CompactResizeOp = True+primOpOutOfLine CompactContainsOp = True+primOpOutOfLine CompactContainsAnyOp = True+primOpOutOfLine CompactGetFirstBlockOp = True+primOpOutOfLine CompactGetNextBlockOp = True+primOpOutOfLine CompactAllocateBlockOp = True+primOpOutOfLine CompactFixupPointersOp = True+primOpOutOfLine CompactAdd = True+primOpOutOfLine CompactAddWithSharing = True+primOpOutOfLine CompactSize = True+primOpOutOfLine GetSparkOp = True+primOpOutOfLine NumSparks = True+primOpOutOfLine MkApUpd0_Op = True+primOpOutOfLine NewBCOOp = True+primOpOutOfLine UnpackClosureOp = True+primOpOutOfLine GetApStackValOp = True+primOpOutOfLine ClearCCSOp = True+primOpOutOfLine TraceEventOp = True+primOpOutOfLine TraceMarkerOp = True+primOpOutOfLine _ = False
+ autogen/primop-primop-info.hs-incl view
@@ -0,0 +1,1069 @@+primOpInfo CharGtOp = mkCompare (fsLit "gtChar#") charPrimTy+primOpInfo CharGeOp = mkCompare (fsLit "geChar#") charPrimTy+primOpInfo CharEqOp = mkCompare (fsLit "eqChar#") charPrimTy+primOpInfo CharNeOp = mkCompare (fsLit "neChar#") charPrimTy+primOpInfo CharLtOp = mkCompare (fsLit "ltChar#") charPrimTy+primOpInfo CharLeOp = mkCompare (fsLit "leChar#") charPrimTy+primOpInfo OrdOp = mkGenPrimOp (fsLit "ord#")  [] [charPrimTy] (intPrimTy)+primOpInfo IntAddOp = mkDyadic (fsLit "+#") intPrimTy+primOpInfo IntSubOp = mkDyadic (fsLit "-#") intPrimTy+primOpInfo IntMulOp = mkDyadic (fsLit "*#") intPrimTy+primOpInfo IntMulMayOfloOp = mkDyadic (fsLit "mulIntMayOflo#") intPrimTy+primOpInfo IntQuotOp = mkDyadic (fsLit "quotInt#") intPrimTy+primOpInfo IntRemOp = mkDyadic (fsLit "remInt#") intPrimTy+primOpInfo IntQuotRemOp = mkGenPrimOp (fsLit "quotRemInt#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))+primOpInfo AndIOp = mkDyadic (fsLit "andI#") intPrimTy+primOpInfo OrIOp = mkDyadic (fsLit "orI#") intPrimTy+primOpInfo XorIOp = mkDyadic (fsLit "xorI#") intPrimTy+primOpInfo NotIOp = mkMonadic (fsLit "notI#") intPrimTy+primOpInfo IntNegOp = mkMonadic (fsLit "negateInt#") intPrimTy+primOpInfo IntAddCOp = mkGenPrimOp (fsLit "addIntC#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))+primOpInfo IntSubCOp = mkGenPrimOp (fsLit "subIntC#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))+primOpInfo IntGtOp = mkCompare (fsLit ">#") intPrimTy+primOpInfo IntGeOp = mkCompare (fsLit ">=#") intPrimTy+primOpInfo IntEqOp = mkCompare (fsLit "==#") intPrimTy+primOpInfo IntNeOp = mkCompare (fsLit "/=#") intPrimTy+primOpInfo IntLtOp = mkCompare (fsLit "<#") intPrimTy+primOpInfo IntLeOp = mkCompare (fsLit "<=#") intPrimTy+primOpInfo ChrOp = mkGenPrimOp (fsLit "chr#")  [] [intPrimTy] (charPrimTy)+primOpInfo Int2WordOp = mkGenPrimOp (fsLit "int2Word#")  [] [intPrimTy] (wordPrimTy)+primOpInfo Int2FloatOp = mkGenPrimOp (fsLit "int2Float#")  [] [intPrimTy] (floatPrimTy)+primOpInfo Int2DoubleOp = mkGenPrimOp (fsLit "int2Double#")  [] [intPrimTy] (doublePrimTy)+primOpInfo Word2FloatOp = mkGenPrimOp (fsLit "word2Float#")  [] [wordPrimTy] (floatPrimTy)+primOpInfo Word2DoubleOp = mkGenPrimOp (fsLit "word2Double#")  [] [wordPrimTy] (doublePrimTy)+primOpInfo ISllOp = mkGenPrimOp (fsLit "uncheckedIShiftL#")  [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo ISraOp = mkGenPrimOp (fsLit "uncheckedIShiftRA#")  [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo ISrlOp = mkGenPrimOp (fsLit "uncheckedIShiftRL#")  [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo WordAddOp = mkDyadic (fsLit "plusWord#") wordPrimTy+primOpInfo WordSubCOp = mkGenPrimOp (fsLit "subWordC#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, intPrimTy]))+primOpInfo WordAdd2Op = mkGenPrimOp (fsLit "plusWord2#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))+primOpInfo WordSubOp = mkDyadic (fsLit "minusWord#") wordPrimTy+primOpInfo WordMulOp = mkDyadic (fsLit "timesWord#") wordPrimTy+primOpInfo WordMul2Op = mkGenPrimOp (fsLit "timesWord2#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))+primOpInfo WordQuotOp = mkDyadic (fsLit "quotWord#") wordPrimTy+primOpInfo WordRemOp = mkDyadic (fsLit "remWord#") wordPrimTy+primOpInfo WordQuotRemOp = mkGenPrimOp (fsLit "quotRemWord#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))+primOpInfo WordQuotRem2Op = mkGenPrimOp (fsLit "quotRemWord2#")  [] [wordPrimTy, wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))+primOpInfo AndOp = mkDyadic (fsLit "and#") wordPrimTy+primOpInfo OrOp = mkDyadic (fsLit "or#") wordPrimTy+primOpInfo XorOp = mkDyadic (fsLit "xor#") wordPrimTy+primOpInfo NotOp = mkMonadic (fsLit "not#") wordPrimTy+primOpInfo SllOp = mkGenPrimOp (fsLit "uncheckedShiftL#")  [] [wordPrimTy, intPrimTy] (wordPrimTy)+primOpInfo SrlOp = mkGenPrimOp (fsLit "uncheckedShiftRL#")  [] [wordPrimTy, intPrimTy] (wordPrimTy)+primOpInfo Word2IntOp = mkGenPrimOp (fsLit "word2Int#")  [] [wordPrimTy] (intPrimTy)+primOpInfo WordGtOp = mkCompare (fsLit "gtWord#") wordPrimTy+primOpInfo WordGeOp = mkCompare (fsLit "geWord#") wordPrimTy+primOpInfo WordEqOp = mkCompare (fsLit "eqWord#") wordPrimTy+primOpInfo WordNeOp = mkCompare (fsLit "neWord#") wordPrimTy+primOpInfo WordLtOp = mkCompare (fsLit "ltWord#") wordPrimTy+primOpInfo WordLeOp = mkCompare (fsLit "leWord#") wordPrimTy+primOpInfo PopCnt8Op = mkMonadic (fsLit "popCnt8#") wordPrimTy+primOpInfo PopCnt16Op = mkMonadic (fsLit "popCnt16#") wordPrimTy+primOpInfo PopCnt32Op = mkMonadic (fsLit "popCnt32#") wordPrimTy+primOpInfo PopCnt64Op = mkGenPrimOp (fsLit "popCnt64#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo PopCntOp = mkMonadic (fsLit "popCnt#") wordPrimTy+primOpInfo Clz8Op = mkMonadic (fsLit "clz8#") wordPrimTy+primOpInfo Clz16Op = mkMonadic (fsLit "clz16#") wordPrimTy+primOpInfo Clz32Op = mkMonadic (fsLit "clz32#") wordPrimTy+primOpInfo Clz64Op = mkGenPrimOp (fsLit "clz64#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo ClzOp = mkMonadic (fsLit "clz#") wordPrimTy+primOpInfo Ctz8Op = mkMonadic (fsLit "ctz8#") wordPrimTy+primOpInfo Ctz16Op = mkMonadic (fsLit "ctz16#") wordPrimTy+primOpInfo Ctz32Op = mkMonadic (fsLit "ctz32#") wordPrimTy+primOpInfo Ctz64Op = mkGenPrimOp (fsLit "ctz64#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo CtzOp = mkMonadic (fsLit "ctz#") wordPrimTy+primOpInfo BSwap16Op = mkMonadic (fsLit "byteSwap16#") wordPrimTy+primOpInfo BSwap32Op = mkMonadic (fsLit "byteSwap32#") wordPrimTy+primOpInfo BSwap64Op = mkMonadic (fsLit "byteSwap64#") wordPrimTy+primOpInfo BSwapOp = mkMonadic (fsLit "byteSwap#") wordPrimTy+primOpInfo Narrow8IntOp = mkMonadic (fsLit "narrow8Int#") intPrimTy+primOpInfo Narrow16IntOp = mkMonadic (fsLit "narrow16Int#") intPrimTy+primOpInfo Narrow32IntOp = mkMonadic (fsLit "narrow32Int#") intPrimTy+primOpInfo Narrow8WordOp = mkMonadic (fsLit "narrow8Word#") wordPrimTy+primOpInfo Narrow16WordOp = mkMonadic (fsLit "narrow16Word#") wordPrimTy+primOpInfo Narrow32WordOp = mkMonadic (fsLit "narrow32Word#") wordPrimTy+primOpInfo DoubleGtOp = mkCompare (fsLit ">##") doublePrimTy+primOpInfo DoubleGeOp = mkCompare (fsLit ">=##") doublePrimTy+primOpInfo DoubleEqOp = mkCompare (fsLit "==##") doublePrimTy+primOpInfo DoubleNeOp = mkCompare (fsLit "/=##") doublePrimTy+primOpInfo DoubleLtOp = mkCompare (fsLit "<##") doublePrimTy+primOpInfo DoubleLeOp = mkCompare (fsLit "<=##") doublePrimTy+primOpInfo DoubleAddOp = mkDyadic (fsLit "+##") doublePrimTy+primOpInfo DoubleSubOp = mkDyadic (fsLit "-##") doublePrimTy+primOpInfo DoubleMulOp = mkDyadic (fsLit "*##") doublePrimTy+primOpInfo DoubleDivOp = mkDyadic (fsLit "/##") doublePrimTy+primOpInfo DoubleNegOp = mkMonadic (fsLit "negateDouble#") doublePrimTy+primOpInfo DoubleFabsOp = mkMonadic (fsLit "fabsDouble#") doublePrimTy+primOpInfo Double2IntOp = mkGenPrimOp (fsLit "double2Int#")  [] [doublePrimTy] (intPrimTy)+primOpInfo Double2FloatOp = mkGenPrimOp (fsLit "double2Float#")  [] [doublePrimTy] (floatPrimTy)+primOpInfo DoubleExpOp = mkMonadic (fsLit "expDouble#") doublePrimTy+primOpInfo DoubleLogOp = mkMonadic (fsLit "logDouble#") doublePrimTy+primOpInfo DoubleSqrtOp = mkMonadic (fsLit "sqrtDouble#") doublePrimTy+primOpInfo DoubleSinOp = mkMonadic (fsLit "sinDouble#") doublePrimTy+primOpInfo DoubleCosOp = mkMonadic (fsLit "cosDouble#") doublePrimTy+primOpInfo DoubleTanOp = mkMonadic (fsLit "tanDouble#") doublePrimTy+primOpInfo DoubleAsinOp = mkMonadic (fsLit "asinDouble#") doublePrimTy+primOpInfo DoubleAcosOp = mkMonadic (fsLit "acosDouble#") doublePrimTy+primOpInfo DoubleAtanOp = mkMonadic (fsLit "atanDouble#") doublePrimTy+primOpInfo DoubleSinhOp = mkMonadic (fsLit "sinhDouble#") doublePrimTy+primOpInfo DoubleCoshOp = mkMonadic (fsLit "coshDouble#") doublePrimTy+primOpInfo DoubleTanhOp = mkMonadic (fsLit "tanhDouble#") doublePrimTy+primOpInfo DoublePowerOp = mkDyadic (fsLit "**##") doublePrimTy+primOpInfo DoubleDecode_2IntOp = mkGenPrimOp (fsLit "decodeDouble_2Int#")  [] [doublePrimTy] ((mkTupleTy Unboxed [intPrimTy, wordPrimTy, wordPrimTy, intPrimTy]))+primOpInfo DoubleDecode_Int64Op = mkGenPrimOp (fsLit "decodeDouble_Int64#")  [] [doublePrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))+primOpInfo FloatGtOp = mkCompare (fsLit "gtFloat#") floatPrimTy+primOpInfo FloatGeOp = mkCompare (fsLit "geFloat#") floatPrimTy+primOpInfo FloatEqOp = mkCompare (fsLit "eqFloat#") floatPrimTy+primOpInfo FloatNeOp = mkCompare (fsLit "neFloat#") floatPrimTy+primOpInfo FloatLtOp = mkCompare (fsLit "ltFloat#") floatPrimTy+primOpInfo FloatLeOp = mkCompare (fsLit "leFloat#") floatPrimTy+primOpInfo FloatAddOp = mkDyadic (fsLit "plusFloat#") floatPrimTy+primOpInfo FloatSubOp = mkDyadic (fsLit "minusFloat#") floatPrimTy+primOpInfo FloatMulOp = mkDyadic (fsLit "timesFloat#") floatPrimTy+primOpInfo FloatDivOp = mkDyadic (fsLit "divideFloat#") floatPrimTy+primOpInfo FloatNegOp = mkMonadic (fsLit "negateFloat#") floatPrimTy+primOpInfo FloatFabsOp = mkMonadic (fsLit "fabsFloat#") floatPrimTy+primOpInfo Float2IntOp = mkGenPrimOp (fsLit "float2Int#")  [] [floatPrimTy] (intPrimTy)+primOpInfo FloatExpOp = mkMonadic (fsLit "expFloat#") floatPrimTy+primOpInfo FloatLogOp = mkMonadic (fsLit "logFloat#") floatPrimTy+primOpInfo FloatSqrtOp = mkMonadic (fsLit "sqrtFloat#") floatPrimTy+primOpInfo FloatSinOp = mkMonadic (fsLit "sinFloat#") floatPrimTy+primOpInfo FloatCosOp = mkMonadic (fsLit "cosFloat#") floatPrimTy+primOpInfo FloatTanOp = mkMonadic (fsLit "tanFloat#") floatPrimTy+primOpInfo FloatAsinOp = mkMonadic (fsLit "asinFloat#") floatPrimTy+primOpInfo FloatAcosOp = mkMonadic (fsLit "acosFloat#") floatPrimTy+primOpInfo FloatAtanOp = mkMonadic (fsLit "atanFloat#") floatPrimTy+primOpInfo FloatSinhOp = mkMonadic (fsLit "sinhFloat#") floatPrimTy+primOpInfo FloatCoshOp = mkMonadic (fsLit "coshFloat#") floatPrimTy+primOpInfo FloatTanhOp = mkMonadic (fsLit "tanhFloat#") floatPrimTy+primOpInfo FloatPowerOp = mkDyadic (fsLit "powerFloat#") floatPrimTy+primOpInfo Float2DoubleOp = mkGenPrimOp (fsLit "float2Double#")  [] [floatPrimTy] (doublePrimTy)+primOpInfo FloatDecode_IntOp = mkGenPrimOp (fsLit "decodeFloat_Int#")  [] [floatPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))+primOpInfo NewArrayOp = mkGenPrimOp (fsLit "newArray#")  [alphaTyVar, deltaTyVar] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))+primOpInfo SameMutableArrayOp = mkGenPrimOp (fsLit "sameMutableArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, mkMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)+primOpInfo ReadArrayOp = mkGenPrimOp (fsLit "readArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo WriteArrayOp = mkGenPrimOp (fsLit "writeArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo SizeofArrayOp = mkGenPrimOp (fsLit "sizeofArray#")  [alphaTyVar] [mkArrayPrimTy alphaTy] (intPrimTy)+primOpInfo SizeofMutableArrayOp = mkGenPrimOp (fsLit "sizeofMutableArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)+primOpInfo IndexArrayOp = mkGenPrimOp (fsLit "indexArray#")  [alphaTyVar] [mkArrayPrimTy alphaTy, intPrimTy] ((mkTupleTy Unboxed [alphaTy]))+primOpInfo UnsafeFreezeArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy alphaTy]))+primOpInfo UnsafeThawArrayOp = mkGenPrimOp (fsLit "unsafeThawArray#")  [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))+primOpInfo CopyArrayOp = mkGenPrimOp (fsLit "copyArray#")  [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyMutableArrayOp = mkGenPrimOp (fsLit "copyMutableArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CloneArrayOp = mkGenPrimOp (fsLit "cloneArray#")  [alphaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, intPrimTy] (mkArrayPrimTy alphaTy)+primOpInfo CloneMutableArrayOp = mkGenPrimOp (fsLit "cloneMutableArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))+primOpInfo FreezeArrayOp = mkGenPrimOp (fsLit "freezeArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy alphaTy]))+primOpInfo ThawArrayOp = mkGenPrimOp (fsLit "thawArray#")  [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))+primOpInfo CasArrayOp = mkGenPrimOp (fsLit "casArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))+primOpInfo NewSmallArrayOp = mkGenPrimOp (fsLit "newSmallArray#")  [alphaTyVar, deltaTyVar] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))+primOpInfo SameSmallMutableArrayOp = mkGenPrimOp (fsLit "sameSmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)+primOpInfo ReadSmallArrayOp = mkGenPrimOp (fsLit "readSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo WriteSmallArrayOp = mkGenPrimOp (fsLit "writeSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo SizeofSmallArrayOp = mkGenPrimOp (fsLit "sizeofSmallArray#")  [alphaTyVar] [mkSmallArrayPrimTy alphaTy] (intPrimTy)+primOpInfo SizeofSmallMutableArrayOp = mkGenPrimOp (fsLit "sizeofSmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)+primOpInfo IndexSmallArrayOp = mkGenPrimOp (fsLit "indexSmallArray#")  [alphaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy] ((mkTupleTy Unboxed [alphaTy]))+primOpInfo UnsafeFreezeSmallArrayOp = mkGenPrimOp (fsLit "unsafeFreezeSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy alphaTy]))+primOpInfo UnsafeThawSmallArrayOp = mkGenPrimOp (fsLit "unsafeThawSmallArray#")  [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))+primOpInfo CopySmallArrayOp = mkGenPrimOp (fsLit "copySmallArray#")  [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopySmallMutableArrayOp = mkGenPrimOp (fsLit "copySmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CloneSmallArrayOp = mkGenPrimOp (fsLit "cloneSmallArray#")  [alphaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, intPrimTy] (mkSmallArrayPrimTy alphaTy)+primOpInfo CloneSmallMutableArrayOp = mkGenPrimOp (fsLit "cloneSmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))+primOpInfo FreezeSmallArrayOp = mkGenPrimOp (fsLit "freezeSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy alphaTy]))+primOpInfo ThawSmallArrayOp = mkGenPrimOp (fsLit "thawSmallArray#")  [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))+primOpInfo CasSmallArrayOp = mkGenPrimOp (fsLit "casSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))+primOpInfo NewByteArrayOp_Char = mkGenPrimOp (fsLit "newByteArray#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))+primOpInfo NewPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newPinnedByteArray#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))+primOpInfo NewAlignedPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newAlignedPinnedByteArray#")  [deltaTyVar] [intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))+primOpInfo MutableByteArrayIsPinnedOp = mkGenPrimOp (fsLit "isMutableByteArrayPinned#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy)+primOpInfo ByteArrayIsPinnedOp = mkGenPrimOp (fsLit "isByteArrayPinned#")  [] [byteArrayPrimTy] (intPrimTy)+primOpInfo ByteArrayContents_Char = mkGenPrimOp (fsLit "byteArrayContents#")  [] [byteArrayPrimTy] (addrPrimTy)+primOpInfo SameMutableByteArrayOp = mkGenPrimOp (fsLit "sameMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy] (intPrimTy)+primOpInfo ShrinkMutableByteArrayOp_Char = mkGenPrimOp (fsLit "shrinkMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo ResizeMutableByteArrayOp_Char = mkGenPrimOp (fsLit "resizeMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))+primOpInfo UnsafeFreezeByteArrayOp = mkGenPrimOp (fsLit "unsafeFreezeByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, byteArrayPrimTy]))+primOpInfo SizeofByteArrayOp = mkGenPrimOp (fsLit "sizeofByteArray#")  [] [byteArrayPrimTy] (intPrimTy)+primOpInfo SizeofMutableByteArrayOp = mkGenPrimOp (fsLit "sizeofMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy)+primOpInfo GetSizeofMutableByteArrayOp = mkGenPrimOp (fsLit "getSizeofMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo IndexByteArrayOp_Char = mkGenPrimOp (fsLit "indexCharArray#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)+primOpInfo IndexByteArrayOp_WideChar = mkGenPrimOp (fsLit "indexWideCharArray#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)+primOpInfo IndexByteArrayOp_Int = mkGenPrimOp (fsLit "indexIntArray#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Word = mkGenPrimOp (fsLit "indexWordArray#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexByteArrayOp_Addr = mkGenPrimOp (fsLit "indexAddrArray#")  [] [byteArrayPrimTy, intPrimTy] (addrPrimTy)+primOpInfo IndexByteArrayOp_Float = mkGenPrimOp (fsLit "indexFloatArray#")  [] [byteArrayPrimTy, intPrimTy] (floatPrimTy)+primOpInfo IndexByteArrayOp_Double = mkGenPrimOp (fsLit "indexDoubleArray#")  [] [byteArrayPrimTy, intPrimTy] (doublePrimTy)+primOpInfo IndexByteArrayOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrArray#")  [alphaTyVar] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy)+primOpInfo IndexByteArrayOp_Int8 = mkGenPrimOp (fsLit "indexInt8Array#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Int16 = mkGenPrimOp (fsLit "indexInt16Array#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Int32 = mkGenPrimOp (fsLit "indexInt32Array#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Int64 = mkGenPrimOp (fsLit "indexInt64Array#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Word8 = mkGenPrimOp (fsLit "indexWord8Array#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexByteArrayOp_Word16 = mkGenPrimOp (fsLit "indexWord16Array#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexByteArrayOp_Word32 = mkGenPrimOp (fsLit "indexWord32Array#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexByteArrayOp_Word64 = mkGenPrimOp (fsLit "indexWord64Array#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)+primOpInfo ReadByteArrayOp_Char = mkGenPrimOp (fsLit "readCharArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))+primOpInfo ReadByteArrayOp_WideChar = mkGenPrimOp (fsLit "readWideCharArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))+primOpInfo ReadByteArrayOp_Int = mkGenPrimOp (fsLit "readIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Word = mkGenPrimOp (fsLit "readWordArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadByteArrayOp_Addr = mkGenPrimOp (fsLit "readAddrArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))+primOpInfo ReadByteArrayOp_Float = mkGenPrimOp (fsLit "readFloatArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy]))+primOpInfo ReadByteArrayOp_Double = mkGenPrimOp (fsLit "readDoubleArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))+primOpInfo ReadByteArrayOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrArray#")  [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy]))+primOpInfo ReadByteArrayOp_Int8 = mkGenPrimOp (fsLit "readInt8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Int16 = mkGenPrimOp (fsLit "readInt16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Int32 = mkGenPrimOp (fsLit "readInt32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Int64 = mkGenPrimOp (fsLit "readInt64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Word8 = mkGenPrimOp (fsLit "readWord8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadByteArrayOp_Word16 = mkGenPrimOp (fsLit "readWord16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadByteArrayOp_Word32 = mkGenPrimOp (fsLit "readWord32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadByteArrayOp_Word64 = mkGenPrimOp (fsLit "readWord64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo WriteByteArrayOp_Char = mkGenPrimOp (fsLit "writeCharArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_WideChar = mkGenPrimOp (fsLit "writeWideCharArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Int = mkGenPrimOp (fsLit "writeIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word = mkGenPrimOp (fsLit "writeWordArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Addr = mkGenPrimOp (fsLit "writeAddrArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Float = mkGenPrimOp (fsLit "writeFloatArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Double = mkGenPrimOp (fsLit "writeDoubleArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrArray#")  [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Int8 = mkGenPrimOp (fsLit "writeInt8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Int16 = mkGenPrimOp (fsLit "writeInt16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Int32 = mkGenPrimOp (fsLit "writeInt32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Int64 = mkGenPrimOp (fsLit "writeInt64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8 = mkGenPrimOp (fsLit "writeWord8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word16 = mkGenPrimOp (fsLit "writeWord16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word32 = mkGenPrimOp (fsLit "writeWord32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word64 = mkGenPrimOp (fsLit "writeWord64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyByteArrayOp = mkGenPrimOp (fsLit "copyByteArray#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyMutableByteArrayOp = mkGenPrimOp (fsLit "copyMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyByteArrayToAddrOp = mkGenPrimOp (fsLit "copyByteArrayToAddr#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyMutableByteArrayToAddrOp = mkGenPrimOp (fsLit "copyMutableByteArrayToAddr#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyAddrToByteArrayOp = mkGenPrimOp (fsLit "copyAddrToByteArray#")  [deltaTyVar] [addrPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo SetByteArrayOp = mkGenPrimOp (fsLit "setByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo AtomicReadByteArrayOp_Int = mkGenPrimOp (fsLit "atomicReadIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo AtomicWriteByteArrayOp_Int = mkGenPrimOp (fsLit "atomicWriteIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CasByteArrayOp_Int = mkGenPrimOp (fsLit "casIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo FetchAddByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAddIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo FetchSubByteArrayOp_Int = mkGenPrimOp (fsLit "fetchSubIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo FetchAndByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAndIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo FetchNandByteArrayOp_Int = mkGenPrimOp (fsLit "fetchNandIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo FetchOrByteArrayOp_Int = mkGenPrimOp (fsLit "fetchOrIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo FetchXorByteArrayOp_Int = mkGenPrimOp (fsLit "fetchXorIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo NewArrayArrayOp = mkGenPrimOp (fsLit "newArrayArray#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy]))+primOpInfo SameMutableArrayArrayOp = mkGenPrimOp (fsLit "sameMutableArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy] (intPrimTy)+primOpInfo UnsafeFreezeArrayArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayArrayPrimTy]))+primOpInfo SizeofArrayArrayOp = mkGenPrimOp (fsLit "sizeofArrayArray#")  [] [mkArrayArrayPrimTy] (intPrimTy)+primOpInfo SizeofMutableArrayArrayOp = mkGenPrimOp (fsLit "sizeofMutableArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy] (intPrimTy)+primOpInfo IndexArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "indexByteArrayArray#")  [] [mkArrayArrayPrimTy, intPrimTy] (byteArrayPrimTy)+primOpInfo IndexArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "indexArrayArrayArray#")  [] [mkArrayArrayPrimTy, intPrimTy] (mkArrayArrayPrimTy)+primOpInfo ReadArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "readByteArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, byteArrayPrimTy]))+primOpInfo ReadArrayArrayOp_MutableByteArray = mkGenPrimOp (fsLit "readMutableByteArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))+primOpInfo ReadArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "readArrayArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayArrayPrimTy]))+primOpInfo ReadArrayArrayOp_MutableArrayArray = mkGenPrimOp (fsLit "readMutableArrayArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy]))+primOpInfo WriteArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "writeByteArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteArrayArrayOp_MutableByteArray = mkGenPrimOp (fsLit "writeMutableByteArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "writeArrayArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkArrayArrayPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteArrayArrayOp_MutableArrayArray = mkGenPrimOp (fsLit "writeMutableArrayArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyArrayArrayOp = mkGenPrimOp (fsLit "copyArrayArray#")  [deltaTyVar] [mkArrayArrayPrimTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyMutableArrayArrayOp = mkGenPrimOp (fsLit "copyMutableArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo AddrAddOp = mkGenPrimOp (fsLit "plusAddr#")  [] [addrPrimTy, intPrimTy] (addrPrimTy)+primOpInfo AddrSubOp = mkGenPrimOp (fsLit "minusAddr#")  [] [addrPrimTy, addrPrimTy] (intPrimTy)+primOpInfo AddrRemOp = mkGenPrimOp (fsLit "remAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)+primOpInfo Addr2IntOp = mkGenPrimOp (fsLit "addr2Int#")  [] [addrPrimTy] (intPrimTy)+primOpInfo Int2AddrOp = mkGenPrimOp (fsLit "int2Addr#")  [] [intPrimTy] (addrPrimTy)+primOpInfo AddrGtOp = mkCompare (fsLit "gtAddr#") addrPrimTy+primOpInfo AddrGeOp = mkCompare (fsLit "geAddr#") addrPrimTy+primOpInfo AddrEqOp = mkCompare (fsLit "eqAddr#") addrPrimTy+primOpInfo AddrNeOp = mkCompare (fsLit "neAddr#") addrPrimTy+primOpInfo AddrLtOp = mkCompare (fsLit "ltAddr#") addrPrimTy+primOpInfo AddrLeOp = mkCompare (fsLit "leAddr#") addrPrimTy+primOpInfo IndexOffAddrOp_Char = mkGenPrimOp (fsLit "indexCharOffAddr#")  [] [addrPrimTy, intPrimTy] (charPrimTy)+primOpInfo IndexOffAddrOp_WideChar = mkGenPrimOp (fsLit "indexWideCharOffAddr#")  [] [addrPrimTy, intPrimTy] (charPrimTy)+primOpInfo IndexOffAddrOp_Int = mkGenPrimOp (fsLit "indexIntOffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexOffAddrOp_Word = mkGenPrimOp (fsLit "indexWordOffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexOffAddrOp_Addr = mkGenPrimOp (fsLit "indexAddrOffAddr#")  [] [addrPrimTy, intPrimTy] (addrPrimTy)+primOpInfo IndexOffAddrOp_Float = mkGenPrimOp (fsLit "indexFloatOffAddr#")  [] [addrPrimTy, intPrimTy] (floatPrimTy)+primOpInfo IndexOffAddrOp_Double = mkGenPrimOp (fsLit "indexDoubleOffAddr#")  [] [addrPrimTy, intPrimTy] (doublePrimTy)+primOpInfo IndexOffAddrOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrOffAddr#")  [alphaTyVar] [addrPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy)+primOpInfo IndexOffAddrOp_Int8 = mkGenPrimOp (fsLit "indexInt8OffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexOffAddrOp_Int16 = mkGenPrimOp (fsLit "indexInt16OffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexOffAddrOp_Int32 = mkGenPrimOp (fsLit "indexInt32OffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexOffAddrOp_Int64 = mkGenPrimOp (fsLit "indexInt64OffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexOffAddrOp_Word8 = mkGenPrimOp (fsLit "indexWord8OffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexOffAddrOp_Word16 = mkGenPrimOp (fsLit "indexWord16OffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexOffAddrOp_Word32 = mkGenPrimOp (fsLit "indexWord32OffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexOffAddrOp_Word64 = mkGenPrimOp (fsLit "indexWord64OffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)+primOpInfo ReadOffAddrOp_Char = mkGenPrimOp (fsLit "readCharOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))+primOpInfo ReadOffAddrOp_WideChar = mkGenPrimOp (fsLit "readWideCharOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))+primOpInfo ReadOffAddrOp_Int = mkGenPrimOp (fsLit "readIntOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadOffAddrOp_Word = mkGenPrimOp (fsLit "readWordOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadOffAddrOp_Addr = mkGenPrimOp (fsLit "readAddrOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))+primOpInfo ReadOffAddrOp_Float = mkGenPrimOp (fsLit "readFloatOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy]))+primOpInfo ReadOffAddrOp_Double = mkGenPrimOp (fsLit "readDoubleOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))+primOpInfo ReadOffAddrOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrOffAddr#")  [deltaTyVar, alphaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy]))+primOpInfo ReadOffAddrOp_Int8 = mkGenPrimOp (fsLit "readInt8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadOffAddrOp_Int16 = mkGenPrimOp (fsLit "readInt16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadOffAddrOp_Int32 = mkGenPrimOp (fsLit "readInt32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadOffAddrOp_Int64 = mkGenPrimOp (fsLit "readInt64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadOffAddrOp_Word8 = mkGenPrimOp (fsLit "readWord8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadOffAddrOp_Word16 = mkGenPrimOp (fsLit "readWord16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadOffAddrOp_Word32 = mkGenPrimOp (fsLit "readWord32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadOffAddrOp_Word64 = mkGenPrimOp (fsLit "readWord64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo WriteOffAddrOp_Char = mkGenPrimOp (fsLit "writeCharOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_WideChar = mkGenPrimOp (fsLit "writeWideCharOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Int = mkGenPrimOp (fsLit "writeIntOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word = mkGenPrimOp (fsLit "writeWordOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Addr = mkGenPrimOp (fsLit "writeAddrOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Float = mkGenPrimOp (fsLit "writeFloatOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Double = mkGenPrimOp (fsLit "writeDoubleOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrOffAddr#")  [alphaTyVar, deltaTyVar] [addrPrimTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Int8 = mkGenPrimOp (fsLit "writeInt8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Int16 = mkGenPrimOp (fsLit "writeInt16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Int32 = mkGenPrimOp (fsLit "writeInt32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Int64 = mkGenPrimOp (fsLit "writeInt64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word8 = mkGenPrimOp (fsLit "writeWord8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word16 = mkGenPrimOp (fsLit "writeWord16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word32 = mkGenPrimOp (fsLit "writeWord32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word64 = mkGenPrimOp (fsLit "writeWord64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo NewMutVarOp = mkGenPrimOp (fsLit "newMutVar#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutVarPrimTy deltaTy alphaTy]))+primOpInfo ReadMutVarOp = mkGenPrimOp (fsLit "readMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo WriteMutVarOp = mkGenPrimOp (fsLit "writeMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo SameMutVarOp = mkGenPrimOp (fsLit "sameMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, mkMutVarPrimTy deltaTy alphaTy] (intPrimTy)+primOpInfo AtomicModifyMutVarOp = mkGenPrimOp (fsLit "atomicModifyMutVar#")  [deltaTyVar, alphaTyVar, betaTyVar, gammaTyVar] [mkMutVarPrimTy deltaTy alphaTy, (mkFunTy (alphaTy) (betaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, gammaTy]))+primOpInfo CasMutVarOp = mkGenPrimOp (fsLit "casMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))+primOpInfo CatchOp = mkGenPrimOp (fsLit "catch#")  [alphaTyVar, betaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkFunTy (betaTy) ((mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo RaiseOp = mkGenPrimOp (fsLit "raise#")  [betaTyVar, runtimeRep1TyVar, openAlphaTyVar] [betaTy] (openAlphaTy)+primOpInfo RaiseIOOp = mkGenPrimOp (fsLit "raiseIO#")  [alphaTyVar, betaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy]))+primOpInfo MaskAsyncExceptionsOp = mkGenPrimOp (fsLit "maskAsyncExceptions#")  [alphaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo MaskUninterruptibleOp = mkGenPrimOp (fsLit "maskUninterruptible#")  [alphaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo UnmaskAsyncExceptionsOp = mkGenPrimOp (fsLit "unmaskAsyncExceptions#")  [alphaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo MaskStatus = mkGenPrimOp (fsLit "getMaskingState#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))+primOpInfo AtomicallyOp = mkGenPrimOp (fsLit "atomically#")  [alphaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo RetryOp = mkGenPrimOp (fsLit "retry#")  [alphaTyVar] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo CatchRetryOp = mkGenPrimOp (fsLit "catchRetry#")  [alphaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo CatchSTMOp = mkGenPrimOp (fsLit "catchSTM#")  [alphaTyVar, betaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkFunTy (betaTy) ((mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo Check = mkGenPrimOp (fsLit "check#")  [alphaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo NewTVarOp = mkGenPrimOp (fsLit "newTVar#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkTVarPrimTy deltaTy alphaTy]))+primOpInfo ReadTVarOp = mkGenPrimOp (fsLit "readTVar#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo ReadTVarIOOp = mkGenPrimOp (fsLit "readTVarIO#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo WriteTVarOp = mkGenPrimOp (fsLit "writeTVar#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo SameTVarOp = mkGenPrimOp (fsLit "sameTVar#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkTVarPrimTy deltaTy alphaTy] (intPrimTy)+primOpInfo NewMVarOp = mkGenPrimOp (fsLit "newMVar#")  [deltaTyVar, alphaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMVarPrimTy deltaTy alphaTy]))+primOpInfo TakeMVarOp = mkGenPrimOp (fsLit "takeMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo TryTakeMVarOp = mkGenPrimOp (fsLit "tryTakeMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))+primOpInfo PutMVarOp = mkGenPrimOp (fsLit "putMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo TryPutMVarOp = mkGenPrimOp (fsLit "tryPutMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadMVarOp = mkGenPrimOp (fsLit "readMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo TryReadMVarOp = mkGenPrimOp (fsLit "tryReadMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))+primOpInfo SameMVarOp = mkGenPrimOp (fsLit "sameMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkMVarPrimTy deltaTy alphaTy] (intPrimTy)+primOpInfo IsEmptyMVarOp = mkGenPrimOp (fsLit "isEmptyMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo DelayOp = mkGenPrimOp (fsLit "delay#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WaitReadOp = mkGenPrimOp (fsLit "waitRead#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WaitWriteOp = mkGenPrimOp (fsLit "waitWrite#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo ForkOp = mkGenPrimOp (fsLit "fork#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy]))+primOpInfo ForkOnOp = mkGenPrimOp (fsLit "forkOn#")  [alphaTyVar] [intPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy]))+primOpInfo KillThreadOp = mkGenPrimOp (fsLit "killThread#")  [alphaTyVar] [threadIdPrimTy, alphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo YieldOp = mkGenPrimOp (fsLit "yield#")  [] [mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo MyThreadIdOp = mkGenPrimOp (fsLit "myThreadId#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy]))+primOpInfo LabelThreadOp = mkGenPrimOp (fsLit "labelThread#")  [] [threadIdPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo IsCurrentThreadBoundOp = mkGenPrimOp (fsLit "isCurrentThreadBound#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))+primOpInfo NoDuplicateOp = mkGenPrimOp (fsLit "noDuplicate#")  [deltaTyVar] [mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo ThreadStatusOp = mkGenPrimOp (fsLit "threadStatus#")  [] [threadIdPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo MkWeakOp = mkGenPrimOp (fsLit "mkWeak#")  [runtimeRep1TyVar, openAlphaTyVar, betaTyVar, gammaTyVar] [openAlphaTy, betaTy, (mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, gammaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy]))+primOpInfo MkWeakNoFinalizerOp = mkGenPrimOp (fsLit "mkWeakNoFinalizer#")  [runtimeRep1TyVar, openAlphaTyVar, betaTyVar] [openAlphaTy, betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy]))+primOpInfo AddCFinalizerToWeakOp = mkGenPrimOp (fsLit "addCFinalizerToWeak#")  [betaTyVar] [addrPrimTy, addrPrimTy, intPrimTy, addrPrimTy, mkWeakPrimTy betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))+primOpInfo DeRefWeakOp = mkGenPrimOp (fsLit "deRefWeak#")  [alphaTyVar] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, alphaTy]))+primOpInfo FinalizeWeakOp = mkGenPrimOp (fsLit "finalizeWeak#")  [alphaTyVar, betaTyVar] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, (mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy])))]))+primOpInfo TouchOp = mkGenPrimOp (fsLit "touch#")  [runtimeRep1TyVar, openAlphaTyVar] [openAlphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo MakeStablePtrOp = mkGenPrimOp (fsLit "makeStablePtr#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStablePtrPrimTy alphaTy]))+primOpInfo DeRefStablePtrOp = mkGenPrimOp (fsLit "deRefStablePtr#")  [alphaTyVar] [mkStablePtrPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo EqStablePtrOp = mkGenPrimOp (fsLit "eqStablePtr#")  [alphaTyVar] [mkStablePtrPrimTy alphaTy, mkStablePtrPrimTy alphaTy] (intPrimTy)+primOpInfo MakeStableNameOp = mkGenPrimOp (fsLit "makeStableName#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStableNamePrimTy alphaTy]))+primOpInfo EqStableNameOp = mkGenPrimOp (fsLit "eqStableName#")  [alphaTyVar, betaTyVar] [mkStableNamePrimTy alphaTy, mkStableNamePrimTy betaTy] (intPrimTy)+primOpInfo StableNameToIntOp = mkGenPrimOp (fsLit "stableNameToInt#")  [alphaTyVar] [mkStableNamePrimTy alphaTy] (intPrimTy)+primOpInfo CompactNewOp = mkGenPrimOp (fsLit "compactNew#")  [] [wordPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, compactPrimTy]))+primOpInfo CompactResizeOp = mkGenPrimOp (fsLit "compactResize#")  [] [compactPrimTy, wordPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo CompactContainsOp = mkGenPrimOp (fsLit "compactContains#")  [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))+primOpInfo CompactContainsAnyOp = mkGenPrimOp (fsLit "compactContainsAny#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))+primOpInfo CompactGetFirstBlockOp = mkGenPrimOp (fsLit "compactGetFirstBlock#")  [] [compactPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy, wordPrimTy]))+primOpInfo CompactGetNextBlockOp = mkGenPrimOp (fsLit "compactGetNextBlock#")  [] [compactPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy, wordPrimTy]))+primOpInfo CompactAllocateBlockOp = mkGenPrimOp (fsLit "compactAllocateBlock#")  [] [wordPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy]))+primOpInfo CompactFixupPointersOp = mkGenPrimOp (fsLit "compactFixupPointers#")  [] [addrPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, compactPrimTy, addrPrimTy]))+primOpInfo CompactAdd = mkGenPrimOp (fsLit "compactAdd#")  [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo CompactAddWithSharing = mkGenPrimOp (fsLit "compactAddWithSharing#")  [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo CompactSize = mkGenPrimOp (fsLit "compactSize#")  [] [compactPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, wordPrimTy]))+primOpInfo ReallyUnsafePtrEqualityOp = mkGenPrimOp (fsLit "reallyUnsafePtrEquality#")  [alphaTyVar] [alphaTy, alphaTy] (intPrimTy)+primOpInfo ParOp = mkGenPrimOp (fsLit "par#")  [alphaTyVar] [alphaTy] (intPrimTy)+primOpInfo SparkOp = mkGenPrimOp (fsLit "spark#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo SeqOp = mkGenPrimOp (fsLit "seq#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo GetSparkOp = mkGenPrimOp (fsLit "getSpark#")  [deltaTyVar, alphaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))+primOpInfo NumSparks = mkGenPrimOp (fsLit "numSparks#")  [deltaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo DataToTagOp = mkGenPrimOp (fsLit "dataToTag#")  [alphaTyVar] [alphaTy] (intPrimTy)+primOpInfo TagToEnumOp = mkGenPrimOp (fsLit "tagToEnum#")  [alphaTyVar] [intPrimTy] (alphaTy)+primOpInfo AddrToAnyOp = mkGenPrimOp (fsLit "addrToAny#")  [alphaTyVar] [addrPrimTy] ((mkTupleTy Unboxed [alphaTy]))+primOpInfo AnyToAddrOp = mkGenPrimOp (fsLit "anyToAddr#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy]))+primOpInfo MkApUpd0_Op = mkGenPrimOp (fsLit "mkApUpd0#")  [alphaTyVar] [bcoPrimTy] ((mkTupleTy Unboxed [alphaTy]))+primOpInfo NewBCOOp = mkGenPrimOp (fsLit "newBCO#")  [alphaTyVar, deltaTyVar] [byteArrayPrimTy, byteArrayPrimTy, mkArrayPrimTy alphaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, bcoPrimTy]))+primOpInfo UnpackClosureOp = mkGenPrimOp (fsLit "unpackClosure#")  [alphaTyVar, betaTyVar] [alphaTy] ((mkTupleTy Unboxed [addrPrimTy, mkArrayPrimTy betaTy, byteArrayPrimTy]))+primOpInfo GetApStackValOp = mkGenPrimOp (fsLit "getApStackVal#")  [alphaTyVar, betaTyVar] [alphaTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, betaTy]))+primOpInfo GetCCSOfOp = mkGenPrimOp (fsLit "getCCSOf#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))+primOpInfo GetCurrentCCSOp = mkGenPrimOp (fsLit "getCurrentCCS#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))+primOpInfo ClearCCSOp = mkGenPrimOp (fsLit "clearCCS#")  [deltaTyVar, alphaTyVar] [(mkFunTy (mkStatePrimTy deltaTy) ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo TraceEventOp = mkGenPrimOp (fsLit "traceEvent#")  [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo TraceMarkerOp = mkGenPrimOp (fsLit "traceMarker#")  [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecBroadcastOp IntVec 16 W8) = mkGenPrimOp (fsLit "broadcastInt8X16#")  [] [intPrimTy] (int8X16PrimTy)+primOpInfo (VecBroadcastOp IntVec 8 W16) = mkGenPrimOp (fsLit "broadcastInt16X8#")  [] [intPrimTy] (int16X8PrimTy)+primOpInfo (VecBroadcastOp IntVec 4 W32) = mkGenPrimOp (fsLit "broadcastInt32X4#")  [] [intPrimTy] (int32X4PrimTy)+primOpInfo (VecBroadcastOp IntVec 2 W64) = mkGenPrimOp (fsLit "broadcastInt64X2#")  [] [intPrimTy] (int64X2PrimTy)+primOpInfo (VecBroadcastOp IntVec 32 W8) = mkGenPrimOp (fsLit "broadcastInt8X32#")  [] [intPrimTy] (int8X32PrimTy)+primOpInfo (VecBroadcastOp IntVec 16 W16) = mkGenPrimOp (fsLit "broadcastInt16X16#")  [] [intPrimTy] (int16X16PrimTy)+primOpInfo (VecBroadcastOp IntVec 8 W32) = mkGenPrimOp (fsLit "broadcastInt32X8#")  [] [intPrimTy] (int32X8PrimTy)+primOpInfo (VecBroadcastOp IntVec 4 W64) = mkGenPrimOp (fsLit "broadcastInt64X4#")  [] [intPrimTy] (int64X4PrimTy)+primOpInfo (VecBroadcastOp IntVec 64 W8) = mkGenPrimOp (fsLit "broadcastInt8X64#")  [] [intPrimTy] (int8X64PrimTy)+primOpInfo (VecBroadcastOp IntVec 32 W16) = mkGenPrimOp (fsLit "broadcastInt16X32#")  [] [intPrimTy] (int16X32PrimTy)+primOpInfo (VecBroadcastOp IntVec 16 W32) = mkGenPrimOp (fsLit "broadcastInt32X16#")  [] [intPrimTy] (int32X16PrimTy)+primOpInfo (VecBroadcastOp IntVec 8 W64) = mkGenPrimOp (fsLit "broadcastInt64X8#")  [] [intPrimTy] (int64X8PrimTy)+primOpInfo (VecBroadcastOp WordVec 16 W8) = mkGenPrimOp (fsLit "broadcastWord8X16#")  [] [wordPrimTy] (word8X16PrimTy)+primOpInfo (VecBroadcastOp WordVec 8 W16) = mkGenPrimOp (fsLit "broadcastWord16X8#")  [] [wordPrimTy] (word16X8PrimTy)+primOpInfo (VecBroadcastOp WordVec 4 W32) = mkGenPrimOp (fsLit "broadcastWord32X4#")  [] [wordPrimTy] (word32X4PrimTy)+primOpInfo (VecBroadcastOp WordVec 2 W64) = mkGenPrimOp (fsLit "broadcastWord64X2#")  [] [wordPrimTy] (word64X2PrimTy)+primOpInfo (VecBroadcastOp WordVec 32 W8) = mkGenPrimOp (fsLit "broadcastWord8X32#")  [] [wordPrimTy] (word8X32PrimTy)+primOpInfo (VecBroadcastOp WordVec 16 W16) = mkGenPrimOp (fsLit "broadcastWord16X16#")  [] [wordPrimTy] (word16X16PrimTy)+primOpInfo (VecBroadcastOp WordVec 8 W32) = mkGenPrimOp (fsLit "broadcastWord32X8#")  [] [wordPrimTy] (word32X8PrimTy)+primOpInfo (VecBroadcastOp WordVec 4 W64) = mkGenPrimOp (fsLit "broadcastWord64X4#")  [] [wordPrimTy] (word64X4PrimTy)+primOpInfo (VecBroadcastOp WordVec 64 W8) = mkGenPrimOp (fsLit "broadcastWord8X64#")  [] [wordPrimTy] (word8X64PrimTy)+primOpInfo (VecBroadcastOp WordVec 32 W16) = mkGenPrimOp (fsLit "broadcastWord16X32#")  [] [wordPrimTy] (word16X32PrimTy)+primOpInfo (VecBroadcastOp WordVec 16 W32) = mkGenPrimOp (fsLit "broadcastWord32X16#")  [] [wordPrimTy] (word32X16PrimTy)+primOpInfo (VecBroadcastOp WordVec 8 W64) = mkGenPrimOp (fsLit "broadcastWord64X8#")  [] [wordPrimTy] (word64X8PrimTy)+primOpInfo (VecBroadcastOp FloatVec 4 W32) = mkGenPrimOp (fsLit "broadcastFloatX4#")  [] [floatPrimTy] (floatX4PrimTy)+primOpInfo (VecBroadcastOp FloatVec 2 W64) = mkGenPrimOp (fsLit "broadcastDoubleX2#")  [] [doublePrimTy] (doubleX2PrimTy)+primOpInfo (VecBroadcastOp FloatVec 8 W32) = mkGenPrimOp (fsLit "broadcastFloatX8#")  [] [floatPrimTy] (floatX8PrimTy)+primOpInfo (VecBroadcastOp FloatVec 4 W64) = mkGenPrimOp (fsLit "broadcastDoubleX4#")  [] [doublePrimTy] (doubleX4PrimTy)+primOpInfo (VecBroadcastOp FloatVec 16 W32) = mkGenPrimOp (fsLit "broadcastFloatX16#")  [] [floatPrimTy] (floatX16PrimTy)+primOpInfo (VecBroadcastOp FloatVec 8 W64) = mkGenPrimOp (fsLit "broadcastDoubleX8#")  [] [doublePrimTy] (doubleX8PrimTy)+primOpInfo (VecPackOp IntVec 16 W8) = mkGenPrimOp (fsLit "packInt8X16#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X16PrimTy)+primOpInfo (VecPackOp IntVec 8 W16) = mkGenPrimOp (fsLit "packInt16X8#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X8PrimTy)+primOpInfo (VecPackOp IntVec 4 W32) = mkGenPrimOp (fsLit "packInt32X4#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X4PrimTy)+primOpInfo (VecPackOp IntVec 2 W64) = mkGenPrimOp (fsLit "packInt64X2#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy])] (int64X2PrimTy)+primOpInfo (VecPackOp IntVec 32 W8) = mkGenPrimOp (fsLit "packInt8X32#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X32PrimTy)+primOpInfo (VecPackOp IntVec 16 W16) = mkGenPrimOp (fsLit "packInt16X16#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X16PrimTy)+primOpInfo (VecPackOp IntVec 8 W32) = mkGenPrimOp (fsLit "packInt32X8#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X8PrimTy)+primOpInfo (VecPackOp IntVec 4 W64) = mkGenPrimOp (fsLit "packInt64X4#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int64X4PrimTy)+primOpInfo (VecPackOp IntVec 64 W8) = mkGenPrimOp (fsLit "packInt8X64#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X64PrimTy)+primOpInfo (VecPackOp IntVec 32 W16) = mkGenPrimOp (fsLit "packInt16X32#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X32PrimTy)+primOpInfo (VecPackOp IntVec 16 W32) = mkGenPrimOp (fsLit "packInt32X16#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X16PrimTy)+primOpInfo (VecPackOp IntVec 8 W64) = mkGenPrimOp (fsLit "packInt64X8#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int64X8PrimTy)+primOpInfo (VecPackOp WordVec 16 W8) = mkGenPrimOp (fsLit "packWord8X16#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X16PrimTy)+primOpInfo (VecPackOp WordVec 8 W16) = mkGenPrimOp (fsLit "packWord16X8#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X8PrimTy)+primOpInfo (VecPackOp WordVec 4 W32) = mkGenPrimOp (fsLit "packWord32X4#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word32X4PrimTy)+primOpInfo (VecPackOp WordVec 2 W64) = mkGenPrimOp (fsLit "packWord64X2#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy])] (word64X2PrimTy)+primOpInfo (VecPackOp WordVec 32 W8) = mkGenPrimOp (fsLit "packWord8X32#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X32PrimTy)+primOpInfo (VecPackOp WordVec 16 W16) = mkGenPrimOp (fsLit "packWord16X16#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X16PrimTy)+primOpInfo (VecPackOp WordVec 8 W32) = mkGenPrimOp (fsLit "packWord32X8#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word32X8PrimTy)+primOpInfo (VecPackOp WordVec 4 W64) = mkGenPrimOp (fsLit "packWord64X4#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word64X4PrimTy)+primOpInfo (VecPackOp WordVec 64 W8) = mkGenPrimOp (fsLit "packWord8X64#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X64PrimTy)+primOpInfo (VecPackOp WordVec 32 W16) = mkGenPrimOp (fsLit "packWord16X32#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X32PrimTy)+primOpInfo (VecPackOp WordVec 16 W32) = mkGenPrimOp (fsLit "packWord32X16#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word32X16PrimTy)+primOpInfo (VecPackOp WordVec 8 W64) = mkGenPrimOp (fsLit "packWord64X8#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word64X8PrimTy)+primOpInfo (VecPackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "packFloatX4#")  [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX4PrimTy)+primOpInfo (VecPackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "packDoubleX2#")  [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy])] (doubleX2PrimTy)+primOpInfo (VecPackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "packFloatX8#")  [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX8PrimTy)+primOpInfo (VecPackOp FloatVec 4 W64) = mkGenPrimOp (fsLit "packDoubleX4#")  [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])] (doubleX4PrimTy)+primOpInfo (VecPackOp FloatVec 16 W32) = mkGenPrimOp (fsLit "packFloatX16#")  [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX16PrimTy)+primOpInfo (VecPackOp FloatVec 8 W64) = mkGenPrimOp (fsLit "packDoubleX8#")  [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])] (doubleX8PrimTy)+primOpInfo (VecUnpackOp IntVec 16 W8) = mkGenPrimOp (fsLit "unpackInt8X16#")  [] [int8X16PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 8 W16) = mkGenPrimOp (fsLit "unpackInt16X8#")  [] [int16X8PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 4 W32) = mkGenPrimOp (fsLit "unpackInt32X4#")  [] [int32X4PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 2 W64) = mkGenPrimOp (fsLit "unpackInt64X2#")  [] [int64X2PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 32 W8) = mkGenPrimOp (fsLit "unpackInt8X32#")  [] [int8X32PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 16 W16) = mkGenPrimOp (fsLit "unpackInt16X16#")  [] [int16X16PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 8 W32) = mkGenPrimOp (fsLit "unpackInt32X8#")  [] [int32X8PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 4 W64) = mkGenPrimOp (fsLit "unpackInt64X4#")  [] [int64X4PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 64 W8) = mkGenPrimOp (fsLit "unpackInt8X64#")  [] [int8X64PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 32 W16) = mkGenPrimOp (fsLit "unpackInt16X32#")  [] [int16X32PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 16 W32) = mkGenPrimOp (fsLit "unpackInt32X16#")  [] [int32X16PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 8 W64) = mkGenPrimOp (fsLit "unpackInt64X8#")  [] [int64X8PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp WordVec 16 W8) = mkGenPrimOp (fsLit "unpackWord8X16#")  [] [word8X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 8 W16) = mkGenPrimOp (fsLit "unpackWord16X8#")  [] [word16X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 4 W32) = mkGenPrimOp (fsLit "unpackWord32X4#")  [] [word32X4PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 2 W64) = mkGenPrimOp (fsLit "unpackWord64X2#")  [] [word64X2PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 32 W8) = mkGenPrimOp (fsLit "unpackWord8X32#")  [] [word8X32PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 16 W16) = mkGenPrimOp (fsLit "unpackWord16X16#")  [] [word16X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 8 W32) = mkGenPrimOp (fsLit "unpackWord32X8#")  [] [word32X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 4 W64) = mkGenPrimOp (fsLit "unpackWord64X4#")  [] [word64X4PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 64 W8) = mkGenPrimOp (fsLit "unpackWord8X64#")  [] [word8X64PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 32 W16) = mkGenPrimOp (fsLit "unpackWord16X32#")  [] [word16X32PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 16 W32) = mkGenPrimOp (fsLit "unpackWord32X16#")  [] [word32X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 8 W64) = mkGenPrimOp (fsLit "unpackWord64X8#")  [] [word64X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "unpackFloatX4#")  [] [floatX4PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy]))+primOpInfo (VecUnpackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "unpackDoubleX2#")  [] [doubleX2PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy]))+primOpInfo (VecUnpackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "unpackFloatX8#")  [] [floatX8PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy]))+primOpInfo (VecUnpackOp FloatVec 4 W64) = mkGenPrimOp (fsLit "unpackDoubleX4#")  [] [doubleX4PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy]))+primOpInfo (VecUnpackOp FloatVec 16 W32) = mkGenPrimOp (fsLit "unpackFloatX16#")  [] [floatX16PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy]))+primOpInfo (VecUnpackOp FloatVec 8 W64) = mkGenPrimOp (fsLit "unpackDoubleX8#")  [] [doubleX8PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy]))+primOpInfo (VecInsertOp IntVec 16 W8) = mkGenPrimOp (fsLit "insertInt8X16#")  [] [int8X16PrimTy, intPrimTy, intPrimTy] (int8X16PrimTy)+primOpInfo (VecInsertOp IntVec 8 W16) = mkGenPrimOp (fsLit "insertInt16X8#")  [] [int16X8PrimTy, intPrimTy, intPrimTy] (int16X8PrimTy)+primOpInfo (VecInsertOp IntVec 4 W32) = mkGenPrimOp (fsLit "insertInt32X4#")  [] [int32X4PrimTy, intPrimTy, intPrimTy] (int32X4PrimTy)+primOpInfo (VecInsertOp IntVec 2 W64) = mkGenPrimOp (fsLit "insertInt64X2#")  [] [int64X2PrimTy, intPrimTy, intPrimTy] (int64X2PrimTy)+primOpInfo (VecInsertOp IntVec 32 W8) = mkGenPrimOp (fsLit "insertInt8X32#")  [] [int8X32PrimTy, intPrimTy, intPrimTy] (int8X32PrimTy)+primOpInfo (VecInsertOp IntVec 16 W16) = mkGenPrimOp (fsLit "insertInt16X16#")  [] [int16X16PrimTy, intPrimTy, intPrimTy] (int16X16PrimTy)+primOpInfo (VecInsertOp IntVec 8 W32) = mkGenPrimOp (fsLit "insertInt32X8#")  [] [int32X8PrimTy, intPrimTy, intPrimTy] (int32X8PrimTy)+primOpInfo (VecInsertOp IntVec 4 W64) = mkGenPrimOp (fsLit "insertInt64X4#")  [] [int64X4PrimTy, intPrimTy, intPrimTy] (int64X4PrimTy)+primOpInfo (VecInsertOp IntVec 64 W8) = mkGenPrimOp (fsLit "insertInt8X64#")  [] [int8X64PrimTy, intPrimTy, intPrimTy] (int8X64PrimTy)+primOpInfo (VecInsertOp IntVec 32 W16) = mkGenPrimOp (fsLit "insertInt16X32#")  [] [int16X32PrimTy, intPrimTy, intPrimTy] (int16X32PrimTy)+primOpInfo (VecInsertOp IntVec 16 W32) = mkGenPrimOp (fsLit "insertInt32X16#")  [] [int32X16PrimTy, intPrimTy, intPrimTy] (int32X16PrimTy)+primOpInfo (VecInsertOp IntVec 8 W64) = mkGenPrimOp (fsLit "insertInt64X8#")  [] [int64X8PrimTy, intPrimTy, intPrimTy] (int64X8PrimTy)+primOpInfo (VecInsertOp WordVec 16 W8) = mkGenPrimOp (fsLit "insertWord8X16#")  [] [word8X16PrimTy, wordPrimTy, intPrimTy] (word8X16PrimTy)+primOpInfo (VecInsertOp WordVec 8 W16) = mkGenPrimOp (fsLit "insertWord16X8#")  [] [word16X8PrimTy, wordPrimTy, intPrimTy] (word16X8PrimTy)+primOpInfo (VecInsertOp WordVec 4 W32) = mkGenPrimOp (fsLit "insertWord32X4#")  [] [word32X4PrimTy, wordPrimTy, intPrimTy] (word32X4PrimTy)+primOpInfo (VecInsertOp WordVec 2 W64) = mkGenPrimOp (fsLit "insertWord64X2#")  [] [word64X2PrimTy, wordPrimTy, intPrimTy] (word64X2PrimTy)+primOpInfo (VecInsertOp WordVec 32 W8) = mkGenPrimOp (fsLit "insertWord8X32#")  [] [word8X32PrimTy, wordPrimTy, intPrimTy] (word8X32PrimTy)+primOpInfo (VecInsertOp WordVec 16 W16) = mkGenPrimOp (fsLit "insertWord16X16#")  [] [word16X16PrimTy, wordPrimTy, intPrimTy] (word16X16PrimTy)+primOpInfo (VecInsertOp WordVec 8 W32) = mkGenPrimOp (fsLit "insertWord32X8#")  [] [word32X8PrimTy, wordPrimTy, intPrimTy] (word32X8PrimTy)+primOpInfo (VecInsertOp WordVec 4 W64) = mkGenPrimOp (fsLit "insertWord64X4#")  [] [word64X4PrimTy, wordPrimTy, intPrimTy] (word64X4PrimTy)+primOpInfo (VecInsertOp WordVec 64 W8) = mkGenPrimOp (fsLit "insertWord8X64#")  [] [word8X64PrimTy, wordPrimTy, intPrimTy] (word8X64PrimTy)+primOpInfo (VecInsertOp WordVec 32 W16) = mkGenPrimOp (fsLit "insertWord16X32#")  [] [word16X32PrimTy, wordPrimTy, intPrimTy] (word16X32PrimTy)+primOpInfo (VecInsertOp WordVec 16 W32) = mkGenPrimOp (fsLit "insertWord32X16#")  [] [word32X16PrimTy, wordPrimTy, intPrimTy] (word32X16PrimTy)+primOpInfo (VecInsertOp WordVec 8 W64) = mkGenPrimOp (fsLit "insertWord64X8#")  [] [word64X8PrimTy, wordPrimTy, intPrimTy] (word64X8PrimTy)+primOpInfo (VecInsertOp FloatVec 4 W32) = mkGenPrimOp (fsLit "insertFloatX4#")  [] [floatX4PrimTy, floatPrimTy, intPrimTy] (floatX4PrimTy)+primOpInfo (VecInsertOp FloatVec 2 W64) = mkGenPrimOp (fsLit "insertDoubleX2#")  [] [doubleX2PrimTy, doublePrimTy, intPrimTy] (doubleX2PrimTy)+primOpInfo (VecInsertOp FloatVec 8 W32) = mkGenPrimOp (fsLit "insertFloatX8#")  [] [floatX8PrimTy, floatPrimTy, intPrimTy] (floatX8PrimTy)+primOpInfo (VecInsertOp FloatVec 4 W64) = mkGenPrimOp (fsLit "insertDoubleX4#")  [] [doubleX4PrimTy, doublePrimTy, intPrimTy] (doubleX4PrimTy)+primOpInfo (VecInsertOp FloatVec 16 W32) = mkGenPrimOp (fsLit "insertFloatX16#")  [] [floatX16PrimTy, floatPrimTy, intPrimTy] (floatX16PrimTy)+primOpInfo (VecInsertOp FloatVec 8 W64) = mkGenPrimOp (fsLit "insertDoubleX8#")  [] [doubleX8PrimTy, doublePrimTy, intPrimTy] (doubleX8PrimTy)+primOpInfo (VecAddOp IntVec 16 W8) = mkDyadic (fsLit "plusInt8X16#") int8X16PrimTy+primOpInfo (VecAddOp IntVec 8 W16) = mkDyadic (fsLit "plusInt16X8#") int16X8PrimTy+primOpInfo (VecAddOp IntVec 4 W32) = mkDyadic (fsLit "plusInt32X4#") int32X4PrimTy+primOpInfo (VecAddOp IntVec 2 W64) = mkDyadic (fsLit "plusInt64X2#") int64X2PrimTy+primOpInfo (VecAddOp IntVec 32 W8) = mkDyadic (fsLit "plusInt8X32#") int8X32PrimTy+primOpInfo (VecAddOp IntVec 16 W16) = mkDyadic (fsLit "plusInt16X16#") int16X16PrimTy+primOpInfo (VecAddOp IntVec 8 W32) = mkDyadic (fsLit "plusInt32X8#") int32X8PrimTy+primOpInfo (VecAddOp IntVec 4 W64) = mkDyadic (fsLit "plusInt64X4#") int64X4PrimTy+primOpInfo (VecAddOp IntVec 64 W8) = mkDyadic (fsLit "plusInt8X64#") int8X64PrimTy+primOpInfo (VecAddOp IntVec 32 W16) = mkDyadic (fsLit "plusInt16X32#") int16X32PrimTy+primOpInfo (VecAddOp IntVec 16 W32) = mkDyadic (fsLit "plusInt32X16#") int32X16PrimTy+primOpInfo (VecAddOp IntVec 8 W64) = mkDyadic (fsLit "plusInt64X8#") int64X8PrimTy+primOpInfo (VecAddOp WordVec 16 W8) = mkDyadic (fsLit "plusWord8X16#") word8X16PrimTy+primOpInfo (VecAddOp WordVec 8 W16) = mkDyadic (fsLit "plusWord16X8#") word16X8PrimTy+primOpInfo (VecAddOp WordVec 4 W32) = mkDyadic (fsLit "plusWord32X4#") word32X4PrimTy+primOpInfo (VecAddOp WordVec 2 W64) = mkDyadic (fsLit "plusWord64X2#") word64X2PrimTy+primOpInfo (VecAddOp WordVec 32 W8) = mkDyadic (fsLit "plusWord8X32#") word8X32PrimTy+primOpInfo (VecAddOp WordVec 16 W16) = mkDyadic (fsLit "plusWord16X16#") word16X16PrimTy+primOpInfo (VecAddOp WordVec 8 W32) = mkDyadic (fsLit "plusWord32X8#") word32X8PrimTy+primOpInfo (VecAddOp WordVec 4 W64) = mkDyadic (fsLit "plusWord64X4#") word64X4PrimTy+primOpInfo (VecAddOp WordVec 64 W8) = mkDyadic (fsLit "plusWord8X64#") word8X64PrimTy+primOpInfo (VecAddOp WordVec 32 W16) = mkDyadic (fsLit "plusWord16X32#") word16X32PrimTy+primOpInfo (VecAddOp WordVec 16 W32) = mkDyadic (fsLit "plusWord32X16#") word32X16PrimTy+primOpInfo (VecAddOp WordVec 8 W64) = mkDyadic (fsLit "plusWord64X8#") word64X8PrimTy+primOpInfo (VecAddOp FloatVec 4 W32) = mkDyadic (fsLit "plusFloatX4#") floatX4PrimTy+primOpInfo (VecAddOp FloatVec 2 W64) = mkDyadic (fsLit "plusDoubleX2#") doubleX2PrimTy+primOpInfo (VecAddOp FloatVec 8 W32) = mkDyadic (fsLit "plusFloatX8#") floatX8PrimTy+primOpInfo (VecAddOp FloatVec 4 W64) = mkDyadic (fsLit "plusDoubleX4#") doubleX4PrimTy+primOpInfo (VecAddOp FloatVec 16 W32) = mkDyadic (fsLit "plusFloatX16#") floatX16PrimTy+primOpInfo (VecAddOp FloatVec 8 W64) = mkDyadic (fsLit "plusDoubleX8#") doubleX8PrimTy+primOpInfo (VecSubOp IntVec 16 W8) = mkDyadic (fsLit "minusInt8X16#") int8X16PrimTy+primOpInfo (VecSubOp IntVec 8 W16) = mkDyadic (fsLit "minusInt16X8#") int16X8PrimTy+primOpInfo (VecSubOp IntVec 4 W32) = mkDyadic (fsLit "minusInt32X4#") int32X4PrimTy+primOpInfo (VecSubOp IntVec 2 W64) = mkDyadic (fsLit "minusInt64X2#") int64X2PrimTy+primOpInfo (VecSubOp IntVec 32 W8) = mkDyadic (fsLit "minusInt8X32#") int8X32PrimTy+primOpInfo (VecSubOp IntVec 16 W16) = mkDyadic (fsLit "minusInt16X16#") int16X16PrimTy+primOpInfo (VecSubOp IntVec 8 W32) = mkDyadic (fsLit "minusInt32X8#") int32X8PrimTy+primOpInfo (VecSubOp IntVec 4 W64) = mkDyadic (fsLit "minusInt64X4#") int64X4PrimTy+primOpInfo (VecSubOp IntVec 64 W8) = mkDyadic (fsLit "minusInt8X64#") int8X64PrimTy+primOpInfo (VecSubOp IntVec 32 W16) = mkDyadic (fsLit "minusInt16X32#") int16X32PrimTy+primOpInfo (VecSubOp IntVec 16 W32) = mkDyadic (fsLit "minusInt32X16#") int32X16PrimTy+primOpInfo (VecSubOp IntVec 8 W64) = mkDyadic (fsLit "minusInt64X8#") int64X8PrimTy+primOpInfo (VecSubOp WordVec 16 W8) = mkDyadic (fsLit "minusWord8X16#") word8X16PrimTy+primOpInfo (VecSubOp WordVec 8 W16) = mkDyadic (fsLit "minusWord16X8#") word16X8PrimTy+primOpInfo (VecSubOp WordVec 4 W32) = mkDyadic (fsLit "minusWord32X4#") word32X4PrimTy+primOpInfo (VecSubOp WordVec 2 W64) = mkDyadic (fsLit "minusWord64X2#") word64X2PrimTy+primOpInfo (VecSubOp WordVec 32 W8) = mkDyadic (fsLit "minusWord8X32#") word8X32PrimTy+primOpInfo (VecSubOp WordVec 16 W16) = mkDyadic (fsLit "minusWord16X16#") word16X16PrimTy+primOpInfo (VecSubOp WordVec 8 W32) = mkDyadic (fsLit "minusWord32X8#") word32X8PrimTy+primOpInfo (VecSubOp WordVec 4 W64) = mkDyadic (fsLit "minusWord64X4#") word64X4PrimTy+primOpInfo (VecSubOp WordVec 64 W8) = mkDyadic (fsLit "minusWord8X64#") word8X64PrimTy+primOpInfo (VecSubOp WordVec 32 W16) = mkDyadic (fsLit "minusWord16X32#") word16X32PrimTy+primOpInfo (VecSubOp WordVec 16 W32) = mkDyadic (fsLit "minusWord32X16#") word32X16PrimTy+primOpInfo (VecSubOp WordVec 8 W64) = mkDyadic (fsLit "minusWord64X8#") word64X8PrimTy+primOpInfo (VecSubOp FloatVec 4 W32) = mkDyadic (fsLit "minusFloatX4#") floatX4PrimTy+primOpInfo (VecSubOp FloatVec 2 W64) = mkDyadic (fsLit "minusDoubleX2#") doubleX2PrimTy+primOpInfo (VecSubOp FloatVec 8 W32) = mkDyadic (fsLit "minusFloatX8#") floatX8PrimTy+primOpInfo (VecSubOp FloatVec 4 W64) = mkDyadic (fsLit "minusDoubleX4#") doubleX4PrimTy+primOpInfo (VecSubOp FloatVec 16 W32) = mkDyadic (fsLit "minusFloatX16#") floatX16PrimTy+primOpInfo (VecSubOp FloatVec 8 W64) = mkDyadic (fsLit "minusDoubleX8#") doubleX8PrimTy+primOpInfo (VecMulOp IntVec 16 W8) = mkDyadic (fsLit "timesInt8X16#") int8X16PrimTy+primOpInfo (VecMulOp IntVec 8 W16) = mkDyadic (fsLit "timesInt16X8#") int16X8PrimTy+primOpInfo (VecMulOp IntVec 4 W32) = mkDyadic (fsLit "timesInt32X4#") int32X4PrimTy+primOpInfo (VecMulOp IntVec 2 W64) = mkDyadic (fsLit "timesInt64X2#") int64X2PrimTy+primOpInfo (VecMulOp IntVec 32 W8) = mkDyadic (fsLit "timesInt8X32#") int8X32PrimTy+primOpInfo (VecMulOp IntVec 16 W16) = mkDyadic (fsLit "timesInt16X16#") int16X16PrimTy+primOpInfo (VecMulOp IntVec 8 W32) = mkDyadic (fsLit "timesInt32X8#") int32X8PrimTy+primOpInfo (VecMulOp IntVec 4 W64) = mkDyadic (fsLit "timesInt64X4#") int64X4PrimTy+primOpInfo (VecMulOp IntVec 64 W8) = mkDyadic (fsLit "timesInt8X64#") int8X64PrimTy+primOpInfo (VecMulOp IntVec 32 W16) = mkDyadic (fsLit "timesInt16X32#") int16X32PrimTy+primOpInfo (VecMulOp IntVec 16 W32) = mkDyadic (fsLit "timesInt32X16#") int32X16PrimTy+primOpInfo (VecMulOp IntVec 8 W64) = mkDyadic (fsLit "timesInt64X8#") int64X8PrimTy+primOpInfo (VecMulOp WordVec 16 W8) = mkDyadic (fsLit "timesWord8X16#") word8X16PrimTy+primOpInfo (VecMulOp WordVec 8 W16) = mkDyadic (fsLit "timesWord16X8#") word16X8PrimTy+primOpInfo (VecMulOp WordVec 4 W32) = mkDyadic (fsLit "timesWord32X4#") word32X4PrimTy+primOpInfo (VecMulOp WordVec 2 W64) = mkDyadic (fsLit "timesWord64X2#") word64X2PrimTy+primOpInfo (VecMulOp WordVec 32 W8) = mkDyadic (fsLit "timesWord8X32#") word8X32PrimTy+primOpInfo (VecMulOp WordVec 16 W16) = mkDyadic (fsLit "timesWord16X16#") word16X16PrimTy+primOpInfo (VecMulOp WordVec 8 W32) = mkDyadic (fsLit "timesWord32X8#") word32X8PrimTy+primOpInfo (VecMulOp WordVec 4 W64) = mkDyadic (fsLit "timesWord64X4#") word64X4PrimTy+primOpInfo (VecMulOp WordVec 64 W8) = mkDyadic (fsLit "timesWord8X64#") word8X64PrimTy+primOpInfo (VecMulOp WordVec 32 W16) = mkDyadic (fsLit "timesWord16X32#") word16X32PrimTy+primOpInfo (VecMulOp WordVec 16 W32) = mkDyadic (fsLit "timesWord32X16#") word32X16PrimTy+primOpInfo (VecMulOp WordVec 8 W64) = mkDyadic (fsLit "timesWord64X8#") word64X8PrimTy+primOpInfo (VecMulOp FloatVec 4 W32) = mkDyadic (fsLit "timesFloatX4#") floatX4PrimTy+primOpInfo (VecMulOp FloatVec 2 W64) = mkDyadic (fsLit "timesDoubleX2#") doubleX2PrimTy+primOpInfo (VecMulOp FloatVec 8 W32) = mkDyadic (fsLit "timesFloatX8#") floatX8PrimTy+primOpInfo (VecMulOp FloatVec 4 W64) = mkDyadic (fsLit "timesDoubleX4#") doubleX4PrimTy+primOpInfo (VecMulOp FloatVec 16 W32) = mkDyadic (fsLit "timesFloatX16#") floatX16PrimTy+primOpInfo (VecMulOp FloatVec 8 W64) = mkDyadic (fsLit "timesDoubleX8#") doubleX8PrimTy+primOpInfo (VecDivOp FloatVec 4 W32) = mkDyadic (fsLit "divideFloatX4#") floatX4PrimTy+primOpInfo (VecDivOp FloatVec 2 W64) = mkDyadic (fsLit "divideDoubleX2#") doubleX2PrimTy+primOpInfo (VecDivOp FloatVec 8 W32) = mkDyadic (fsLit "divideFloatX8#") floatX8PrimTy+primOpInfo (VecDivOp FloatVec 4 W64) = mkDyadic (fsLit "divideDoubleX4#") doubleX4PrimTy+primOpInfo (VecDivOp FloatVec 16 W32) = mkDyadic (fsLit "divideFloatX16#") floatX16PrimTy+primOpInfo (VecDivOp FloatVec 8 W64) = mkDyadic (fsLit "divideDoubleX8#") doubleX8PrimTy+primOpInfo (VecQuotOp IntVec 16 W8) = mkDyadic (fsLit "quotInt8X16#") int8X16PrimTy+primOpInfo (VecQuotOp IntVec 8 W16) = mkDyadic (fsLit "quotInt16X8#") int16X8PrimTy+primOpInfo (VecQuotOp IntVec 4 W32) = mkDyadic (fsLit "quotInt32X4#") int32X4PrimTy+primOpInfo (VecQuotOp IntVec 2 W64) = mkDyadic (fsLit "quotInt64X2#") int64X2PrimTy+primOpInfo (VecQuotOp IntVec 32 W8) = mkDyadic (fsLit "quotInt8X32#") int8X32PrimTy+primOpInfo (VecQuotOp IntVec 16 W16) = mkDyadic (fsLit "quotInt16X16#") int16X16PrimTy+primOpInfo (VecQuotOp IntVec 8 W32) = mkDyadic (fsLit "quotInt32X8#") int32X8PrimTy+primOpInfo (VecQuotOp IntVec 4 W64) = mkDyadic (fsLit "quotInt64X4#") int64X4PrimTy+primOpInfo (VecQuotOp IntVec 64 W8) = mkDyadic (fsLit "quotInt8X64#") int8X64PrimTy+primOpInfo (VecQuotOp IntVec 32 W16) = mkDyadic (fsLit "quotInt16X32#") int16X32PrimTy+primOpInfo (VecQuotOp IntVec 16 W32) = mkDyadic (fsLit "quotInt32X16#") int32X16PrimTy+primOpInfo (VecQuotOp IntVec 8 W64) = mkDyadic (fsLit "quotInt64X8#") int64X8PrimTy+primOpInfo (VecQuotOp WordVec 16 W8) = mkDyadic (fsLit "quotWord8X16#") word8X16PrimTy+primOpInfo (VecQuotOp WordVec 8 W16) = mkDyadic (fsLit "quotWord16X8#") word16X8PrimTy+primOpInfo (VecQuotOp WordVec 4 W32) = mkDyadic (fsLit "quotWord32X4#") word32X4PrimTy+primOpInfo (VecQuotOp WordVec 2 W64) = mkDyadic (fsLit "quotWord64X2#") word64X2PrimTy+primOpInfo (VecQuotOp WordVec 32 W8) = mkDyadic (fsLit "quotWord8X32#") word8X32PrimTy+primOpInfo (VecQuotOp WordVec 16 W16) = mkDyadic (fsLit "quotWord16X16#") word16X16PrimTy+primOpInfo (VecQuotOp WordVec 8 W32) = mkDyadic (fsLit "quotWord32X8#") word32X8PrimTy+primOpInfo (VecQuotOp WordVec 4 W64) = mkDyadic (fsLit "quotWord64X4#") word64X4PrimTy+primOpInfo (VecQuotOp WordVec 64 W8) = mkDyadic (fsLit "quotWord8X64#") word8X64PrimTy+primOpInfo (VecQuotOp WordVec 32 W16) = mkDyadic (fsLit "quotWord16X32#") word16X32PrimTy+primOpInfo (VecQuotOp WordVec 16 W32) = mkDyadic (fsLit "quotWord32X16#") word32X16PrimTy+primOpInfo (VecQuotOp WordVec 8 W64) = mkDyadic (fsLit "quotWord64X8#") word64X8PrimTy+primOpInfo (VecRemOp IntVec 16 W8) = mkDyadic (fsLit "remInt8X16#") int8X16PrimTy+primOpInfo (VecRemOp IntVec 8 W16) = mkDyadic (fsLit "remInt16X8#") int16X8PrimTy+primOpInfo (VecRemOp IntVec 4 W32) = mkDyadic (fsLit "remInt32X4#") int32X4PrimTy+primOpInfo (VecRemOp IntVec 2 W64) = mkDyadic (fsLit "remInt64X2#") int64X2PrimTy+primOpInfo (VecRemOp IntVec 32 W8) = mkDyadic (fsLit "remInt8X32#") int8X32PrimTy+primOpInfo (VecRemOp IntVec 16 W16) = mkDyadic (fsLit "remInt16X16#") int16X16PrimTy+primOpInfo (VecRemOp IntVec 8 W32) = mkDyadic (fsLit "remInt32X8#") int32X8PrimTy+primOpInfo (VecRemOp IntVec 4 W64) = mkDyadic (fsLit "remInt64X4#") int64X4PrimTy+primOpInfo (VecRemOp IntVec 64 W8) = mkDyadic (fsLit "remInt8X64#") int8X64PrimTy+primOpInfo (VecRemOp IntVec 32 W16) = mkDyadic (fsLit "remInt16X32#") int16X32PrimTy+primOpInfo (VecRemOp IntVec 16 W32) = mkDyadic (fsLit "remInt32X16#") int32X16PrimTy+primOpInfo (VecRemOp IntVec 8 W64) = mkDyadic (fsLit "remInt64X8#") int64X8PrimTy+primOpInfo (VecRemOp WordVec 16 W8) = mkDyadic (fsLit "remWord8X16#") word8X16PrimTy+primOpInfo (VecRemOp WordVec 8 W16) = mkDyadic (fsLit "remWord16X8#") word16X8PrimTy+primOpInfo (VecRemOp WordVec 4 W32) = mkDyadic (fsLit "remWord32X4#") word32X4PrimTy+primOpInfo (VecRemOp WordVec 2 W64) = mkDyadic (fsLit "remWord64X2#") word64X2PrimTy+primOpInfo (VecRemOp WordVec 32 W8) = mkDyadic (fsLit "remWord8X32#") word8X32PrimTy+primOpInfo (VecRemOp WordVec 16 W16) = mkDyadic (fsLit "remWord16X16#") word16X16PrimTy+primOpInfo (VecRemOp WordVec 8 W32) = mkDyadic (fsLit "remWord32X8#") word32X8PrimTy+primOpInfo (VecRemOp WordVec 4 W64) = mkDyadic (fsLit "remWord64X4#") word64X4PrimTy+primOpInfo (VecRemOp WordVec 64 W8) = mkDyadic (fsLit "remWord8X64#") word8X64PrimTy+primOpInfo (VecRemOp WordVec 32 W16) = mkDyadic (fsLit "remWord16X32#") word16X32PrimTy+primOpInfo (VecRemOp WordVec 16 W32) = mkDyadic (fsLit "remWord32X16#") word32X16PrimTy+primOpInfo (VecRemOp WordVec 8 W64) = mkDyadic (fsLit "remWord64X8#") word64X8PrimTy+primOpInfo (VecNegOp IntVec 16 W8) = mkMonadic (fsLit "negateInt8X16#") int8X16PrimTy+primOpInfo (VecNegOp IntVec 8 W16) = mkMonadic (fsLit "negateInt16X8#") int16X8PrimTy+primOpInfo (VecNegOp IntVec 4 W32) = mkMonadic (fsLit "negateInt32X4#") int32X4PrimTy+primOpInfo (VecNegOp IntVec 2 W64) = mkMonadic (fsLit "negateInt64X2#") int64X2PrimTy+primOpInfo (VecNegOp IntVec 32 W8) = mkMonadic (fsLit "negateInt8X32#") int8X32PrimTy+primOpInfo (VecNegOp IntVec 16 W16) = mkMonadic (fsLit "negateInt16X16#") int16X16PrimTy+primOpInfo (VecNegOp IntVec 8 W32) = mkMonadic (fsLit "negateInt32X8#") int32X8PrimTy+primOpInfo (VecNegOp IntVec 4 W64) = mkMonadic (fsLit "negateInt64X4#") int64X4PrimTy+primOpInfo (VecNegOp IntVec 64 W8) = mkMonadic (fsLit "negateInt8X64#") int8X64PrimTy+primOpInfo (VecNegOp IntVec 32 W16) = mkMonadic (fsLit "negateInt16X32#") int16X32PrimTy+primOpInfo (VecNegOp IntVec 16 W32) = mkMonadic (fsLit "negateInt32X16#") int32X16PrimTy+primOpInfo (VecNegOp IntVec 8 W64) = mkMonadic (fsLit "negateInt64X8#") int64X8PrimTy+primOpInfo (VecNegOp FloatVec 4 W32) = mkMonadic (fsLit "negateFloatX4#") floatX4PrimTy+primOpInfo (VecNegOp FloatVec 2 W64) = mkMonadic (fsLit "negateDoubleX2#") doubleX2PrimTy+primOpInfo (VecNegOp FloatVec 8 W32) = mkMonadic (fsLit "negateFloatX8#") floatX8PrimTy+primOpInfo (VecNegOp FloatVec 4 W64) = mkMonadic (fsLit "negateDoubleX4#") doubleX4PrimTy+primOpInfo (VecNegOp FloatVec 16 W32) = mkMonadic (fsLit "negateFloatX16#") floatX16PrimTy+primOpInfo (VecNegOp FloatVec 8 W64) = mkMonadic (fsLit "negateDoubleX8#") doubleX8PrimTy+primOpInfo (VecIndexByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16Array#")  [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8Array#")  [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4Array#")  [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64X2Array#")  [] [byteArrayPrimTy, intPrimTy] (int64X2PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8X32Array#")  [] [byteArrayPrimTy, intPrimTy] (int8X32PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16X16Array#")  [] [byteArrayPrimTy, intPrimTy] (int16X16PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32X8Array#")  [] [byteArrayPrimTy, intPrimTy] (int32X8PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64X4Array#")  [] [byteArrayPrimTy, intPrimTy] (int64X4PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8X64Array#")  [] [byteArrayPrimTy, intPrimTy] (int8X64PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16X32Array#")  [] [byteArrayPrimTy, intPrimTy] (int16X32PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32X16Array#")  [] [byteArrayPrimTy, intPrimTy] (int32X16PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64X8Array#")  [] [byteArrayPrimTy, intPrimTy] (int64X8PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8X16Array#")  [] [byteArrayPrimTy, intPrimTy] (word8X16PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16X8Array#")  [] [byteArrayPrimTy, intPrimTy] (word16X8PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32X4Array#")  [] [byteArrayPrimTy, intPrimTy] (word32X4PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64X2Array#")  [] [byteArrayPrimTy, intPrimTy] (word64X2PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8X32Array#")  [] [byteArrayPrimTy, intPrimTy] (word8X32PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16X16Array#")  [] [byteArrayPrimTy, intPrimTy] (word16X16PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32X8Array#")  [] [byteArrayPrimTy, intPrimTy] (word32X8PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64X4Array#")  [] [byteArrayPrimTy, intPrimTy] (word64X4PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8X64Array#")  [] [byteArrayPrimTy, intPrimTy] (word8X64PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16X32Array#")  [] [byteArrayPrimTy, intPrimTy] (word16X32PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32X16Array#")  [] [byteArrayPrimTy, intPrimTy] (word32X16PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64X8Array#")  [] [byteArrayPrimTy, intPrimTy] (word64X8PrimTy)+primOpInfo (VecIndexByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatX4Array#")  [] [byteArrayPrimTy, intPrimTy] (floatX4PrimTy)+primOpInfo (VecIndexByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleX2Array#")  [] [byteArrayPrimTy, intPrimTy] (doubleX2PrimTy)+primOpInfo (VecIndexByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatX8Array#")  [] [byteArrayPrimTy, intPrimTy] (floatX8PrimTy)+primOpInfo (VecIndexByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleX4Array#")  [] [byteArrayPrimTy, intPrimTy] (doubleX4PrimTy)+primOpInfo (VecIndexByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatX16Array#")  [] [byteArrayPrimTy, intPrimTy] (floatX16PrimTy)+primOpInfo (VecIndexByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleX8Array#")  [] [byteArrayPrimTy, intPrimTy] (doubleX8PrimTy)+primOpInfo (VecReadByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64X2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8X64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64X2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8X64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))+primOpInfo (VecReadByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatX4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))+primOpInfo (VecReadByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleX2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))+primOpInfo (VecReadByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatX8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))+primOpInfo (VecReadByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleX4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))+primOpInfo (VecReadByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatX16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))+primOpInfo (VecReadByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleX8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))+primOpInfo (VecWriteByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64X2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8X64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64X2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8X64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatX4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleX2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatX8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleX4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatX16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleX8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecIndexOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16OffAddr#")  [] [addrPrimTy, intPrimTy] (int8X16PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8OffAddr#")  [] [addrPrimTy, intPrimTy] (int16X8PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4OffAddr#")  [] [addrPrimTy, intPrimTy] (int32X4PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64X2OffAddr#")  [] [addrPrimTy, intPrimTy] (int64X2PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8X32OffAddr#")  [] [addrPrimTy, intPrimTy] (int8X32PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16X16OffAddr#")  [] [addrPrimTy, intPrimTy] (int16X16PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32X8OffAddr#")  [] [addrPrimTy, intPrimTy] (int32X8PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64X4OffAddr#")  [] [addrPrimTy, intPrimTy] (int64X4PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8X64OffAddr#")  [] [addrPrimTy, intPrimTy] (int8X64PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16X32OffAddr#")  [] [addrPrimTy, intPrimTy] (int16X32PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32X16OffAddr#")  [] [addrPrimTy, intPrimTy] (int32X16PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64X8OffAddr#")  [] [addrPrimTy, intPrimTy] (int64X8PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8X16OffAddr#")  [] [addrPrimTy, intPrimTy] (word8X16PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16X8OffAddr#")  [] [addrPrimTy, intPrimTy] (word16X8PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32X4OffAddr#")  [] [addrPrimTy, intPrimTy] (word32X4PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64X2OffAddr#")  [] [addrPrimTy, intPrimTy] (word64X2PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8X32OffAddr#")  [] [addrPrimTy, intPrimTy] (word8X32PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16X16OffAddr#")  [] [addrPrimTy, intPrimTy] (word16X16PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32X8OffAddr#")  [] [addrPrimTy, intPrimTy] (word32X8PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64X4OffAddr#")  [] [addrPrimTy, intPrimTy] (word64X4PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8X64OffAddr#")  [] [addrPrimTy, intPrimTy] (word8X64PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16X32OffAddr#")  [] [addrPrimTy, intPrimTy] (word16X32PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32X16OffAddr#")  [] [addrPrimTy, intPrimTy] (word32X16PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64X8OffAddr#")  [] [addrPrimTy, intPrimTy] (word64X8PrimTy)+primOpInfo (VecIndexOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatX4OffAddr#")  [] [addrPrimTy, intPrimTy] (floatX4PrimTy)+primOpInfo (VecIndexOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleX2OffAddr#")  [] [addrPrimTy, intPrimTy] (doubleX2PrimTy)+primOpInfo (VecIndexOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatX8OffAddr#")  [] [addrPrimTy, intPrimTy] (floatX8PrimTy)+primOpInfo (VecIndexOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleX4OffAddr#")  [] [addrPrimTy, intPrimTy] (doubleX4PrimTy)+primOpInfo (VecIndexOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatX16OffAddr#")  [] [addrPrimTy, intPrimTy] (floatX16PrimTy)+primOpInfo (VecIndexOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleX8OffAddr#")  [] [addrPrimTy, intPrimTy] (doubleX8PrimTy)+primOpInfo (VecReadOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64X2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8X64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64X2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8X64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))+primOpInfo (VecReadOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatX4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))+primOpInfo (VecReadOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleX2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))+primOpInfo (VecReadOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatX8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))+primOpInfo (VecReadOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleX4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))+primOpInfo (VecReadOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatX16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))+primOpInfo (VecReadOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleX8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))+primOpInfo (VecWriteOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64X2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8X64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64X2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8X64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatX4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleX2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatX8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleX4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatX16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleX8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X16#")  [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X8#")  [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X4#")  [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X2#")  [] [byteArrayPrimTy, intPrimTy] (int64X2PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X32#")  [] [byteArrayPrimTy, intPrimTy] (int8X32PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X16#")  [] [byteArrayPrimTy, intPrimTy] (int16X16PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X8#")  [] [byteArrayPrimTy, intPrimTy] (int32X8PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X4#")  [] [byteArrayPrimTy, intPrimTy] (int64X4PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X64#")  [] [byteArrayPrimTy, intPrimTy] (int8X64PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X32#")  [] [byteArrayPrimTy, intPrimTy] (int16X32PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X16#")  [] [byteArrayPrimTy, intPrimTy] (int32X16PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X8#")  [] [byteArrayPrimTy, intPrimTy] (int64X8PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X16#")  [] [byteArrayPrimTy, intPrimTy] (word8X16PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X8#")  [] [byteArrayPrimTy, intPrimTy] (word16X8PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X4#")  [] [byteArrayPrimTy, intPrimTy] (word32X4PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X2#")  [] [byteArrayPrimTy, intPrimTy] (word64X2PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X32#")  [] [byteArrayPrimTy, intPrimTy] (word8X32PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X16#")  [] [byteArrayPrimTy, intPrimTy] (word16X16PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X8#")  [] [byteArrayPrimTy, intPrimTy] (word32X8PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X4#")  [] [byteArrayPrimTy, intPrimTy] (word64X4PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X64#")  [] [byteArrayPrimTy, intPrimTy] (word8X64PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X32#")  [] [byteArrayPrimTy, intPrimTy] (word16X32PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X16#")  [] [byteArrayPrimTy, intPrimTy] (word32X16PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X8#")  [] [byteArrayPrimTy, intPrimTy] (word64X8PrimTy)+primOpInfo (VecIndexScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX4#")  [] [byteArrayPrimTy, intPrimTy] (floatX4PrimTy)+primOpInfo (VecIndexScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX2#")  [] [byteArrayPrimTy, intPrimTy] (doubleX2PrimTy)+primOpInfo (VecIndexScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX8#")  [] [byteArrayPrimTy, intPrimTy] (floatX8PrimTy)+primOpInfo (VecIndexScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX4#")  [] [byteArrayPrimTy, intPrimTy] (doubleX4PrimTy)+primOpInfo (VecIndexScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX16#")  [] [byteArrayPrimTy, intPrimTy] (floatX16PrimTy)+primOpInfo (VecIndexScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX8#")  [] [byteArrayPrimTy, intPrimTy] (doubleX8PrimTy)+primOpInfo (VecReadScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))+primOpInfo (VecReadScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))+primOpInfo (VecReadScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))+primOpInfo (VecReadScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))+primOpInfo (VecReadScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))+primOpInfo (VecReadScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))+primOpInfo (VecReadScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))+primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X16#")  [] [addrPrimTy, intPrimTy] (int8X16PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X8#")  [] [addrPrimTy, intPrimTy] (int16X8PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X4#")  [] [addrPrimTy, intPrimTy] (int32X4PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X2#")  [] [addrPrimTy, intPrimTy] (int64X2PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X32#")  [] [addrPrimTy, intPrimTy] (int8X32PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X16#")  [] [addrPrimTy, intPrimTy] (int16X16PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X8#")  [] [addrPrimTy, intPrimTy] (int32X8PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X4#")  [] [addrPrimTy, intPrimTy] (int64X4PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X64#")  [] [addrPrimTy, intPrimTy] (int8X64PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X32#")  [] [addrPrimTy, intPrimTy] (int16X32PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X16#")  [] [addrPrimTy, intPrimTy] (int32X16PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X8#")  [] [addrPrimTy, intPrimTy] (int64X8PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X16#")  [] [addrPrimTy, intPrimTy] (word8X16PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X8#")  [] [addrPrimTy, intPrimTy] (word16X8PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X4#")  [] [addrPrimTy, intPrimTy] (word32X4PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X2#")  [] [addrPrimTy, intPrimTy] (word64X2PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X32#")  [] [addrPrimTy, intPrimTy] (word8X32PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X16#")  [] [addrPrimTy, intPrimTy] (word16X16PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X8#")  [] [addrPrimTy, intPrimTy] (word32X8PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X4#")  [] [addrPrimTy, intPrimTy] (word64X4PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X64#")  [] [addrPrimTy, intPrimTy] (word8X64PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X32#")  [] [addrPrimTy, intPrimTy] (word16X32PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X16#")  [] [addrPrimTy, intPrimTy] (word32X16PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X8#")  [] [addrPrimTy, intPrimTy] (word64X8PrimTy)+primOpInfo (VecIndexScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX4#")  [] [addrPrimTy, intPrimTy] (floatX4PrimTy)+primOpInfo (VecIndexScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX2#")  [] [addrPrimTy, intPrimTy] (doubleX2PrimTy)+primOpInfo (VecIndexScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX8#")  [] [addrPrimTy, intPrimTy] (floatX8PrimTy)+primOpInfo (VecIndexScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX4#")  [] [addrPrimTy, intPrimTy] (doubleX4PrimTy)+primOpInfo (VecIndexScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX16#")  [] [addrPrimTy, intPrimTy] (floatX16PrimTy)+primOpInfo (VecIndexScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX8#")  [] [addrPrimTy, intPrimTy] (doubleX8PrimTy)+primOpInfo (VecReadScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X2#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X64#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X2#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X64#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))+primOpInfo (VecReadScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))+primOpInfo (VecReadScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX2#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))+primOpInfo (VecReadScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))+primOpInfo (VecReadScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))+primOpInfo (VecReadScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))+primOpInfo (VecReadScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))+primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X2#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X64#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X2#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X64#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX4#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX2#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX8#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX4#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX16#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX8#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchByteArrayOp3 = mkGenPrimOp (fsLit "prefetchByteArray3#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchMutableByteArrayOp3 = mkGenPrimOp (fsLit "prefetchMutableByteArray3#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchAddrOp3 = mkGenPrimOp (fsLit "prefetchAddr3#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchValueOp3 = mkGenPrimOp (fsLit "prefetchValue3#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchByteArrayOp2 = mkGenPrimOp (fsLit "prefetchByteArray2#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchMutableByteArrayOp2 = mkGenPrimOp (fsLit "prefetchMutableByteArray2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchAddrOp2 = mkGenPrimOp (fsLit "prefetchAddr2#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchValueOp2 = mkGenPrimOp (fsLit "prefetchValue2#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchByteArrayOp1 = mkGenPrimOp (fsLit "prefetchByteArray1#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchMutableByteArrayOp1 = mkGenPrimOp (fsLit "prefetchMutableByteArray1#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchAddrOp1 = mkGenPrimOp (fsLit "prefetchAddr1#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchValueOp1 = mkGenPrimOp (fsLit "prefetchValue1#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchByteArrayOp0 = mkGenPrimOp (fsLit "prefetchByteArray0#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchMutableByteArrayOp0 = mkGenPrimOp (fsLit "prefetchMutableByteArray0#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchAddrOp0 = mkGenPrimOp (fsLit "prefetchAddr0#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchValueOp0 = mkGenPrimOp (fsLit "prefetchValue0#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+ autogen/primop-strictness.hs-incl view
@@ -0,0 +1,22 @@+primOpStrictness CatchOp =  \ _arity -> mkClosedStrictSig [ lazyApply1Dmd+                                                 , lazyApply2Dmd+                                                 , topDmd] topRes +primOpStrictness RaiseOp =  \ _arity -> mkClosedStrictSig [topDmd] exnRes +primOpStrictness RaiseIOOp =  \ _arity -> mkClosedStrictSig [topDmd, topDmd] exnRes +primOpStrictness MaskAsyncExceptionsOp =  \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes +primOpStrictness MaskUninterruptibleOp =  \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes +primOpStrictness UnmaskAsyncExceptionsOp =  \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes +primOpStrictness AtomicallyOp =  \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes +primOpStrictness RetryOp =  \ _arity -> mkClosedStrictSig [topDmd] botRes +primOpStrictness CatchRetryOp =  \ _arity -> mkClosedStrictSig [ catchArgDmd+                                                 , lazyApply1Dmd+                                                 , topDmd ] topRes +primOpStrictness CatchSTMOp =  \ _arity -> mkClosedStrictSig [ lazyApply1Dmd+                                                 , lazyApply2Dmd+                                                 , topDmd ] topRes +primOpStrictness DataToTagOp =  \ _arity -> mkClosedStrictSig [evalDmd] topRes +primOpStrictness PrefetchValueOp3 =  \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes +primOpStrictness PrefetchValueOp2 =  \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes +primOpStrictness PrefetchValueOp1 =  \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes +primOpStrictness PrefetchValueOp0 =  \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes +primOpStrictness _ =  \ arity -> mkClosedStrictSig (replicate arity topDmd) topRes
+ autogen/primop-tag.hs-incl view
@@ -0,0 +1,1072 @@+maxPrimOpTag :: Int+maxPrimOpTag = 1069+primOpTag :: PrimOp -> Int+primOpTag CharGtOp = 1+primOpTag CharGeOp = 2+primOpTag CharEqOp = 3+primOpTag CharNeOp = 4+primOpTag CharLtOp = 5+primOpTag CharLeOp = 6+primOpTag OrdOp = 7+primOpTag IntAddOp = 8+primOpTag IntSubOp = 9+primOpTag IntMulOp = 10+primOpTag IntMulMayOfloOp = 11+primOpTag IntQuotOp = 12+primOpTag IntRemOp = 13+primOpTag IntQuotRemOp = 14+primOpTag AndIOp = 15+primOpTag OrIOp = 16+primOpTag XorIOp = 17+primOpTag NotIOp = 18+primOpTag IntNegOp = 19+primOpTag IntAddCOp = 20+primOpTag IntSubCOp = 21+primOpTag IntGtOp = 22+primOpTag IntGeOp = 23+primOpTag IntEqOp = 24+primOpTag IntNeOp = 25+primOpTag IntLtOp = 26+primOpTag IntLeOp = 27+primOpTag ChrOp = 28+primOpTag Int2WordOp = 29+primOpTag Int2FloatOp = 30+primOpTag Int2DoubleOp = 31+primOpTag Word2FloatOp = 32+primOpTag Word2DoubleOp = 33+primOpTag ISllOp = 34+primOpTag ISraOp = 35+primOpTag ISrlOp = 36+primOpTag WordAddOp = 37+primOpTag WordSubCOp = 38+primOpTag WordAdd2Op = 39+primOpTag WordSubOp = 40+primOpTag WordMulOp = 41+primOpTag WordMul2Op = 42+primOpTag WordQuotOp = 43+primOpTag WordRemOp = 44+primOpTag WordQuotRemOp = 45+primOpTag WordQuotRem2Op = 46+primOpTag AndOp = 47+primOpTag OrOp = 48+primOpTag XorOp = 49+primOpTag NotOp = 50+primOpTag SllOp = 51+primOpTag SrlOp = 52+primOpTag Word2IntOp = 53+primOpTag WordGtOp = 54+primOpTag WordGeOp = 55+primOpTag WordEqOp = 56+primOpTag WordNeOp = 57+primOpTag WordLtOp = 58+primOpTag WordLeOp = 59+primOpTag PopCnt8Op = 60+primOpTag PopCnt16Op = 61+primOpTag PopCnt32Op = 62+primOpTag PopCnt64Op = 63+primOpTag PopCntOp = 64+primOpTag Clz8Op = 65+primOpTag Clz16Op = 66+primOpTag Clz32Op = 67+primOpTag Clz64Op = 68+primOpTag ClzOp = 69+primOpTag Ctz8Op = 70+primOpTag Ctz16Op = 71+primOpTag Ctz32Op = 72+primOpTag Ctz64Op = 73+primOpTag CtzOp = 74+primOpTag BSwap16Op = 75+primOpTag BSwap32Op = 76+primOpTag BSwap64Op = 77+primOpTag BSwapOp = 78+primOpTag Narrow8IntOp = 79+primOpTag Narrow16IntOp = 80+primOpTag Narrow32IntOp = 81+primOpTag Narrow8WordOp = 82+primOpTag Narrow16WordOp = 83+primOpTag Narrow32WordOp = 84+primOpTag DoubleGtOp = 85+primOpTag DoubleGeOp = 86+primOpTag DoubleEqOp = 87+primOpTag DoubleNeOp = 88+primOpTag DoubleLtOp = 89+primOpTag DoubleLeOp = 90+primOpTag DoubleAddOp = 91+primOpTag DoubleSubOp = 92+primOpTag DoubleMulOp = 93+primOpTag DoubleDivOp = 94+primOpTag DoubleNegOp = 95+primOpTag DoubleFabsOp = 96+primOpTag Double2IntOp = 97+primOpTag Double2FloatOp = 98+primOpTag DoubleExpOp = 99+primOpTag DoubleLogOp = 100+primOpTag DoubleSqrtOp = 101+primOpTag DoubleSinOp = 102+primOpTag DoubleCosOp = 103+primOpTag DoubleTanOp = 104+primOpTag DoubleAsinOp = 105+primOpTag DoubleAcosOp = 106+primOpTag DoubleAtanOp = 107+primOpTag DoubleSinhOp = 108+primOpTag DoubleCoshOp = 109+primOpTag DoubleTanhOp = 110+primOpTag DoublePowerOp = 111+primOpTag DoubleDecode_2IntOp = 112+primOpTag DoubleDecode_Int64Op = 113+primOpTag FloatGtOp = 114+primOpTag FloatGeOp = 115+primOpTag FloatEqOp = 116+primOpTag FloatNeOp = 117+primOpTag FloatLtOp = 118+primOpTag FloatLeOp = 119+primOpTag FloatAddOp = 120+primOpTag FloatSubOp = 121+primOpTag FloatMulOp = 122+primOpTag FloatDivOp = 123+primOpTag FloatNegOp = 124+primOpTag FloatFabsOp = 125+primOpTag Float2IntOp = 126+primOpTag FloatExpOp = 127+primOpTag FloatLogOp = 128+primOpTag FloatSqrtOp = 129+primOpTag FloatSinOp = 130+primOpTag FloatCosOp = 131+primOpTag FloatTanOp = 132+primOpTag FloatAsinOp = 133+primOpTag FloatAcosOp = 134+primOpTag FloatAtanOp = 135+primOpTag FloatSinhOp = 136+primOpTag FloatCoshOp = 137+primOpTag FloatTanhOp = 138+primOpTag FloatPowerOp = 139+primOpTag Float2DoubleOp = 140+primOpTag FloatDecode_IntOp = 141+primOpTag NewArrayOp = 142+primOpTag SameMutableArrayOp = 143+primOpTag ReadArrayOp = 144+primOpTag WriteArrayOp = 145+primOpTag SizeofArrayOp = 146+primOpTag SizeofMutableArrayOp = 147+primOpTag IndexArrayOp = 148+primOpTag UnsafeFreezeArrayOp = 149+primOpTag UnsafeThawArrayOp = 150+primOpTag CopyArrayOp = 151+primOpTag CopyMutableArrayOp = 152+primOpTag CloneArrayOp = 153+primOpTag CloneMutableArrayOp = 154+primOpTag FreezeArrayOp = 155+primOpTag ThawArrayOp = 156+primOpTag CasArrayOp = 157+primOpTag NewSmallArrayOp = 158+primOpTag SameSmallMutableArrayOp = 159+primOpTag ReadSmallArrayOp = 160+primOpTag WriteSmallArrayOp = 161+primOpTag SizeofSmallArrayOp = 162+primOpTag SizeofSmallMutableArrayOp = 163+primOpTag IndexSmallArrayOp = 164+primOpTag UnsafeFreezeSmallArrayOp = 165+primOpTag UnsafeThawSmallArrayOp = 166+primOpTag CopySmallArrayOp = 167+primOpTag CopySmallMutableArrayOp = 168+primOpTag CloneSmallArrayOp = 169+primOpTag CloneSmallMutableArrayOp = 170+primOpTag FreezeSmallArrayOp = 171+primOpTag ThawSmallArrayOp = 172+primOpTag CasSmallArrayOp = 173+primOpTag NewByteArrayOp_Char = 174+primOpTag NewPinnedByteArrayOp_Char = 175+primOpTag NewAlignedPinnedByteArrayOp_Char = 176+primOpTag MutableByteArrayIsPinnedOp = 177+primOpTag ByteArrayIsPinnedOp = 178+primOpTag ByteArrayContents_Char = 179+primOpTag SameMutableByteArrayOp = 180+primOpTag ShrinkMutableByteArrayOp_Char = 181+primOpTag ResizeMutableByteArrayOp_Char = 182+primOpTag UnsafeFreezeByteArrayOp = 183+primOpTag SizeofByteArrayOp = 184+primOpTag SizeofMutableByteArrayOp = 185+primOpTag GetSizeofMutableByteArrayOp = 186+primOpTag IndexByteArrayOp_Char = 187+primOpTag IndexByteArrayOp_WideChar = 188+primOpTag IndexByteArrayOp_Int = 189+primOpTag IndexByteArrayOp_Word = 190+primOpTag IndexByteArrayOp_Addr = 191+primOpTag IndexByteArrayOp_Float = 192+primOpTag IndexByteArrayOp_Double = 193+primOpTag IndexByteArrayOp_StablePtr = 194+primOpTag IndexByteArrayOp_Int8 = 195+primOpTag IndexByteArrayOp_Int16 = 196+primOpTag IndexByteArrayOp_Int32 = 197+primOpTag IndexByteArrayOp_Int64 = 198+primOpTag IndexByteArrayOp_Word8 = 199+primOpTag IndexByteArrayOp_Word16 = 200+primOpTag IndexByteArrayOp_Word32 = 201+primOpTag IndexByteArrayOp_Word64 = 202+primOpTag ReadByteArrayOp_Char = 203+primOpTag ReadByteArrayOp_WideChar = 204+primOpTag ReadByteArrayOp_Int = 205+primOpTag ReadByteArrayOp_Word = 206+primOpTag ReadByteArrayOp_Addr = 207+primOpTag ReadByteArrayOp_Float = 208+primOpTag ReadByteArrayOp_Double = 209+primOpTag ReadByteArrayOp_StablePtr = 210+primOpTag ReadByteArrayOp_Int8 = 211+primOpTag ReadByteArrayOp_Int16 = 212+primOpTag ReadByteArrayOp_Int32 = 213+primOpTag ReadByteArrayOp_Int64 = 214+primOpTag ReadByteArrayOp_Word8 = 215+primOpTag ReadByteArrayOp_Word16 = 216+primOpTag ReadByteArrayOp_Word32 = 217+primOpTag ReadByteArrayOp_Word64 = 218+primOpTag WriteByteArrayOp_Char = 219+primOpTag WriteByteArrayOp_WideChar = 220+primOpTag WriteByteArrayOp_Int = 221+primOpTag WriteByteArrayOp_Word = 222+primOpTag WriteByteArrayOp_Addr = 223+primOpTag WriteByteArrayOp_Float = 224+primOpTag WriteByteArrayOp_Double = 225+primOpTag WriteByteArrayOp_StablePtr = 226+primOpTag WriteByteArrayOp_Int8 = 227+primOpTag WriteByteArrayOp_Int16 = 228+primOpTag WriteByteArrayOp_Int32 = 229+primOpTag WriteByteArrayOp_Int64 = 230+primOpTag WriteByteArrayOp_Word8 = 231+primOpTag WriteByteArrayOp_Word16 = 232+primOpTag WriteByteArrayOp_Word32 = 233+primOpTag WriteByteArrayOp_Word64 = 234+primOpTag CopyByteArrayOp = 235+primOpTag CopyMutableByteArrayOp = 236+primOpTag CopyByteArrayToAddrOp = 237+primOpTag CopyMutableByteArrayToAddrOp = 238+primOpTag CopyAddrToByteArrayOp = 239+primOpTag SetByteArrayOp = 240+primOpTag AtomicReadByteArrayOp_Int = 241+primOpTag AtomicWriteByteArrayOp_Int = 242+primOpTag CasByteArrayOp_Int = 243+primOpTag FetchAddByteArrayOp_Int = 244+primOpTag FetchSubByteArrayOp_Int = 245+primOpTag FetchAndByteArrayOp_Int = 246+primOpTag FetchNandByteArrayOp_Int = 247+primOpTag FetchOrByteArrayOp_Int = 248+primOpTag FetchXorByteArrayOp_Int = 249+primOpTag NewArrayArrayOp = 250+primOpTag SameMutableArrayArrayOp = 251+primOpTag UnsafeFreezeArrayArrayOp = 252+primOpTag SizeofArrayArrayOp = 253+primOpTag SizeofMutableArrayArrayOp = 254+primOpTag IndexArrayArrayOp_ByteArray = 255+primOpTag IndexArrayArrayOp_ArrayArray = 256+primOpTag ReadArrayArrayOp_ByteArray = 257+primOpTag ReadArrayArrayOp_MutableByteArray = 258+primOpTag ReadArrayArrayOp_ArrayArray = 259+primOpTag ReadArrayArrayOp_MutableArrayArray = 260+primOpTag WriteArrayArrayOp_ByteArray = 261+primOpTag WriteArrayArrayOp_MutableByteArray = 262+primOpTag WriteArrayArrayOp_ArrayArray = 263+primOpTag WriteArrayArrayOp_MutableArrayArray = 264+primOpTag CopyArrayArrayOp = 265+primOpTag CopyMutableArrayArrayOp = 266+primOpTag AddrAddOp = 267+primOpTag AddrSubOp = 268+primOpTag AddrRemOp = 269+primOpTag Addr2IntOp = 270+primOpTag Int2AddrOp = 271+primOpTag AddrGtOp = 272+primOpTag AddrGeOp = 273+primOpTag AddrEqOp = 274+primOpTag AddrNeOp = 275+primOpTag AddrLtOp = 276+primOpTag AddrLeOp = 277+primOpTag IndexOffAddrOp_Char = 278+primOpTag IndexOffAddrOp_WideChar = 279+primOpTag IndexOffAddrOp_Int = 280+primOpTag IndexOffAddrOp_Word = 281+primOpTag IndexOffAddrOp_Addr = 282+primOpTag IndexOffAddrOp_Float = 283+primOpTag IndexOffAddrOp_Double = 284+primOpTag IndexOffAddrOp_StablePtr = 285+primOpTag IndexOffAddrOp_Int8 = 286+primOpTag IndexOffAddrOp_Int16 = 287+primOpTag IndexOffAddrOp_Int32 = 288+primOpTag IndexOffAddrOp_Int64 = 289+primOpTag IndexOffAddrOp_Word8 = 290+primOpTag IndexOffAddrOp_Word16 = 291+primOpTag IndexOffAddrOp_Word32 = 292+primOpTag IndexOffAddrOp_Word64 = 293+primOpTag ReadOffAddrOp_Char = 294+primOpTag ReadOffAddrOp_WideChar = 295+primOpTag ReadOffAddrOp_Int = 296+primOpTag ReadOffAddrOp_Word = 297+primOpTag ReadOffAddrOp_Addr = 298+primOpTag ReadOffAddrOp_Float = 299+primOpTag ReadOffAddrOp_Double = 300+primOpTag ReadOffAddrOp_StablePtr = 301+primOpTag ReadOffAddrOp_Int8 = 302+primOpTag ReadOffAddrOp_Int16 = 303+primOpTag ReadOffAddrOp_Int32 = 304+primOpTag ReadOffAddrOp_Int64 = 305+primOpTag ReadOffAddrOp_Word8 = 306+primOpTag ReadOffAddrOp_Word16 = 307+primOpTag ReadOffAddrOp_Word32 = 308+primOpTag ReadOffAddrOp_Word64 = 309+primOpTag WriteOffAddrOp_Char = 310+primOpTag WriteOffAddrOp_WideChar = 311+primOpTag WriteOffAddrOp_Int = 312+primOpTag WriteOffAddrOp_Word = 313+primOpTag WriteOffAddrOp_Addr = 314+primOpTag WriteOffAddrOp_Float = 315+primOpTag WriteOffAddrOp_Double = 316+primOpTag WriteOffAddrOp_StablePtr = 317+primOpTag WriteOffAddrOp_Int8 = 318+primOpTag WriteOffAddrOp_Int16 = 319+primOpTag WriteOffAddrOp_Int32 = 320+primOpTag WriteOffAddrOp_Int64 = 321+primOpTag WriteOffAddrOp_Word8 = 322+primOpTag WriteOffAddrOp_Word16 = 323+primOpTag WriteOffAddrOp_Word32 = 324+primOpTag WriteOffAddrOp_Word64 = 325+primOpTag NewMutVarOp = 326+primOpTag ReadMutVarOp = 327+primOpTag WriteMutVarOp = 328+primOpTag SameMutVarOp = 329+primOpTag AtomicModifyMutVarOp = 330+primOpTag CasMutVarOp = 331+primOpTag CatchOp = 332+primOpTag RaiseOp = 333+primOpTag RaiseIOOp = 334+primOpTag MaskAsyncExceptionsOp = 335+primOpTag MaskUninterruptibleOp = 336+primOpTag UnmaskAsyncExceptionsOp = 337+primOpTag MaskStatus = 338+primOpTag AtomicallyOp = 339+primOpTag RetryOp = 340+primOpTag CatchRetryOp = 341+primOpTag CatchSTMOp = 342+primOpTag Check = 343+primOpTag NewTVarOp = 344+primOpTag ReadTVarOp = 345+primOpTag ReadTVarIOOp = 346+primOpTag WriteTVarOp = 347+primOpTag SameTVarOp = 348+primOpTag NewMVarOp = 349+primOpTag TakeMVarOp = 350+primOpTag TryTakeMVarOp = 351+primOpTag PutMVarOp = 352+primOpTag TryPutMVarOp = 353+primOpTag ReadMVarOp = 354+primOpTag TryReadMVarOp = 355+primOpTag SameMVarOp = 356+primOpTag IsEmptyMVarOp = 357+primOpTag DelayOp = 358+primOpTag WaitReadOp = 359+primOpTag WaitWriteOp = 360+primOpTag ForkOp = 361+primOpTag ForkOnOp = 362+primOpTag KillThreadOp = 363+primOpTag YieldOp = 364+primOpTag MyThreadIdOp = 365+primOpTag LabelThreadOp = 366+primOpTag IsCurrentThreadBoundOp = 367+primOpTag NoDuplicateOp = 368+primOpTag ThreadStatusOp = 369+primOpTag MkWeakOp = 370+primOpTag MkWeakNoFinalizerOp = 371+primOpTag AddCFinalizerToWeakOp = 372+primOpTag DeRefWeakOp = 373+primOpTag FinalizeWeakOp = 374+primOpTag TouchOp = 375+primOpTag MakeStablePtrOp = 376+primOpTag DeRefStablePtrOp = 377+primOpTag EqStablePtrOp = 378+primOpTag MakeStableNameOp = 379+primOpTag EqStableNameOp = 380+primOpTag StableNameToIntOp = 381+primOpTag CompactNewOp = 382+primOpTag CompactResizeOp = 383+primOpTag CompactContainsOp = 384+primOpTag CompactContainsAnyOp = 385+primOpTag CompactGetFirstBlockOp = 386+primOpTag CompactGetNextBlockOp = 387+primOpTag CompactAllocateBlockOp = 388+primOpTag CompactFixupPointersOp = 389+primOpTag CompactAdd = 390+primOpTag CompactAddWithSharing = 391+primOpTag CompactSize = 392+primOpTag ReallyUnsafePtrEqualityOp = 393+primOpTag ParOp = 394+primOpTag SparkOp = 395+primOpTag SeqOp = 396+primOpTag GetSparkOp = 397+primOpTag NumSparks = 398+primOpTag DataToTagOp = 399+primOpTag TagToEnumOp = 400+primOpTag AddrToAnyOp = 401+primOpTag AnyToAddrOp = 402+primOpTag MkApUpd0_Op = 403+primOpTag NewBCOOp = 404+primOpTag UnpackClosureOp = 405+primOpTag GetApStackValOp = 406+primOpTag GetCCSOfOp = 407+primOpTag GetCurrentCCSOp = 408+primOpTag ClearCCSOp = 409+primOpTag TraceEventOp = 410+primOpTag TraceMarkerOp = 411+primOpTag (VecBroadcastOp IntVec 16 W8) = 412+primOpTag (VecBroadcastOp IntVec 8 W16) = 413+primOpTag (VecBroadcastOp IntVec 4 W32) = 414+primOpTag (VecBroadcastOp IntVec 2 W64) = 415+primOpTag (VecBroadcastOp IntVec 32 W8) = 416+primOpTag (VecBroadcastOp IntVec 16 W16) = 417+primOpTag (VecBroadcastOp IntVec 8 W32) = 418+primOpTag (VecBroadcastOp IntVec 4 W64) = 419+primOpTag (VecBroadcastOp IntVec 64 W8) = 420+primOpTag (VecBroadcastOp IntVec 32 W16) = 421+primOpTag (VecBroadcastOp IntVec 16 W32) = 422+primOpTag (VecBroadcastOp IntVec 8 W64) = 423+primOpTag (VecBroadcastOp WordVec 16 W8) = 424+primOpTag (VecBroadcastOp WordVec 8 W16) = 425+primOpTag (VecBroadcastOp WordVec 4 W32) = 426+primOpTag (VecBroadcastOp WordVec 2 W64) = 427+primOpTag (VecBroadcastOp WordVec 32 W8) = 428+primOpTag (VecBroadcastOp WordVec 16 W16) = 429+primOpTag (VecBroadcastOp WordVec 8 W32) = 430+primOpTag (VecBroadcastOp WordVec 4 W64) = 431+primOpTag (VecBroadcastOp WordVec 64 W8) = 432+primOpTag (VecBroadcastOp WordVec 32 W16) = 433+primOpTag (VecBroadcastOp WordVec 16 W32) = 434+primOpTag (VecBroadcastOp WordVec 8 W64) = 435+primOpTag (VecBroadcastOp FloatVec 4 W32) = 436+primOpTag (VecBroadcastOp FloatVec 2 W64) = 437+primOpTag (VecBroadcastOp FloatVec 8 W32) = 438+primOpTag (VecBroadcastOp FloatVec 4 W64) = 439+primOpTag (VecBroadcastOp FloatVec 16 W32) = 440+primOpTag (VecBroadcastOp FloatVec 8 W64) = 441+primOpTag (VecPackOp IntVec 16 W8) = 442+primOpTag (VecPackOp IntVec 8 W16) = 443+primOpTag (VecPackOp IntVec 4 W32) = 444+primOpTag (VecPackOp IntVec 2 W64) = 445+primOpTag (VecPackOp IntVec 32 W8) = 446+primOpTag (VecPackOp IntVec 16 W16) = 447+primOpTag (VecPackOp IntVec 8 W32) = 448+primOpTag (VecPackOp IntVec 4 W64) = 449+primOpTag (VecPackOp IntVec 64 W8) = 450+primOpTag (VecPackOp IntVec 32 W16) = 451+primOpTag (VecPackOp IntVec 16 W32) = 452+primOpTag (VecPackOp IntVec 8 W64) = 453+primOpTag (VecPackOp WordVec 16 W8) = 454+primOpTag (VecPackOp WordVec 8 W16) = 455+primOpTag (VecPackOp WordVec 4 W32) = 456+primOpTag (VecPackOp WordVec 2 W64) = 457+primOpTag (VecPackOp WordVec 32 W8) = 458+primOpTag (VecPackOp WordVec 16 W16) = 459+primOpTag (VecPackOp WordVec 8 W32) = 460+primOpTag (VecPackOp WordVec 4 W64) = 461+primOpTag (VecPackOp WordVec 64 W8) = 462+primOpTag (VecPackOp WordVec 32 W16) = 463+primOpTag (VecPackOp WordVec 16 W32) = 464+primOpTag (VecPackOp WordVec 8 W64) = 465+primOpTag (VecPackOp FloatVec 4 W32) = 466+primOpTag (VecPackOp FloatVec 2 W64) = 467+primOpTag (VecPackOp FloatVec 8 W32) = 468+primOpTag (VecPackOp FloatVec 4 W64) = 469+primOpTag (VecPackOp FloatVec 16 W32) = 470+primOpTag (VecPackOp FloatVec 8 W64) = 471+primOpTag (VecUnpackOp IntVec 16 W8) = 472+primOpTag (VecUnpackOp IntVec 8 W16) = 473+primOpTag (VecUnpackOp IntVec 4 W32) = 474+primOpTag (VecUnpackOp IntVec 2 W64) = 475+primOpTag (VecUnpackOp IntVec 32 W8) = 476+primOpTag (VecUnpackOp IntVec 16 W16) = 477+primOpTag (VecUnpackOp IntVec 8 W32) = 478+primOpTag (VecUnpackOp IntVec 4 W64) = 479+primOpTag (VecUnpackOp IntVec 64 W8) = 480+primOpTag (VecUnpackOp IntVec 32 W16) = 481+primOpTag (VecUnpackOp IntVec 16 W32) = 482+primOpTag (VecUnpackOp IntVec 8 W64) = 483+primOpTag (VecUnpackOp WordVec 16 W8) = 484+primOpTag (VecUnpackOp WordVec 8 W16) = 485+primOpTag (VecUnpackOp WordVec 4 W32) = 486+primOpTag (VecUnpackOp WordVec 2 W64) = 487+primOpTag (VecUnpackOp WordVec 32 W8) = 488+primOpTag (VecUnpackOp WordVec 16 W16) = 489+primOpTag (VecUnpackOp WordVec 8 W32) = 490+primOpTag (VecUnpackOp WordVec 4 W64) = 491+primOpTag (VecUnpackOp WordVec 64 W8) = 492+primOpTag (VecUnpackOp WordVec 32 W16) = 493+primOpTag (VecUnpackOp WordVec 16 W32) = 494+primOpTag (VecUnpackOp WordVec 8 W64) = 495+primOpTag (VecUnpackOp FloatVec 4 W32) = 496+primOpTag (VecUnpackOp FloatVec 2 W64) = 497+primOpTag (VecUnpackOp FloatVec 8 W32) = 498+primOpTag (VecUnpackOp FloatVec 4 W64) = 499+primOpTag (VecUnpackOp FloatVec 16 W32) = 500+primOpTag (VecUnpackOp FloatVec 8 W64) = 501+primOpTag (VecInsertOp IntVec 16 W8) = 502+primOpTag (VecInsertOp IntVec 8 W16) = 503+primOpTag (VecInsertOp IntVec 4 W32) = 504+primOpTag (VecInsertOp IntVec 2 W64) = 505+primOpTag (VecInsertOp IntVec 32 W8) = 506+primOpTag (VecInsertOp IntVec 16 W16) = 507+primOpTag (VecInsertOp IntVec 8 W32) = 508+primOpTag (VecInsertOp IntVec 4 W64) = 509+primOpTag (VecInsertOp IntVec 64 W8) = 510+primOpTag (VecInsertOp IntVec 32 W16) = 511+primOpTag (VecInsertOp IntVec 16 W32) = 512+primOpTag (VecInsertOp IntVec 8 W64) = 513+primOpTag (VecInsertOp WordVec 16 W8) = 514+primOpTag (VecInsertOp WordVec 8 W16) = 515+primOpTag (VecInsertOp WordVec 4 W32) = 516+primOpTag (VecInsertOp WordVec 2 W64) = 517+primOpTag (VecInsertOp WordVec 32 W8) = 518+primOpTag (VecInsertOp WordVec 16 W16) = 519+primOpTag (VecInsertOp WordVec 8 W32) = 520+primOpTag (VecInsertOp WordVec 4 W64) = 521+primOpTag (VecInsertOp WordVec 64 W8) = 522+primOpTag (VecInsertOp WordVec 32 W16) = 523+primOpTag (VecInsertOp WordVec 16 W32) = 524+primOpTag (VecInsertOp WordVec 8 W64) = 525+primOpTag (VecInsertOp FloatVec 4 W32) = 526+primOpTag (VecInsertOp FloatVec 2 W64) = 527+primOpTag (VecInsertOp FloatVec 8 W32) = 528+primOpTag (VecInsertOp FloatVec 4 W64) = 529+primOpTag (VecInsertOp FloatVec 16 W32) = 530+primOpTag (VecInsertOp FloatVec 8 W64) = 531+primOpTag (VecAddOp IntVec 16 W8) = 532+primOpTag (VecAddOp IntVec 8 W16) = 533+primOpTag (VecAddOp IntVec 4 W32) = 534+primOpTag (VecAddOp IntVec 2 W64) = 535+primOpTag (VecAddOp IntVec 32 W8) = 536+primOpTag (VecAddOp IntVec 16 W16) = 537+primOpTag (VecAddOp IntVec 8 W32) = 538+primOpTag (VecAddOp IntVec 4 W64) = 539+primOpTag (VecAddOp IntVec 64 W8) = 540+primOpTag (VecAddOp IntVec 32 W16) = 541+primOpTag (VecAddOp IntVec 16 W32) = 542+primOpTag (VecAddOp IntVec 8 W64) = 543+primOpTag (VecAddOp WordVec 16 W8) = 544+primOpTag (VecAddOp WordVec 8 W16) = 545+primOpTag (VecAddOp WordVec 4 W32) = 546+primOpTag (VecAddOp WordVec 2 W64) = 547+primOpTag (VecAddOp WordVec 32 W8) = 548+primOpTag (VecAddOp WordVec 16 W16) = 549+primOpTag (VecAddOp WordVec 8 W32) = 550+primOpTag (VecAddOp WordVec 4 W64) = 551+primOpTag (VecAddOp WordVec 64 W8) = 552+primOpTag (VecAddOp WordVec 32 W16) = 553+primOpTag (VecAddOp WordVec 16 W32) = 554+primOpTag (VecAddOp WordVec 8 W64) = 555+primOpTag (VecAddOp FloatVec 4 W32) = 556+primOpTag (VecAddOp FloatVec 2 W64) = 557+primOpTag (VecAddOp FloatVec 8 W32) = 558+primOpTag (VecAddOp FloatVec 4 W64) = 559+primOpTag (VecAddOp FloatVec 16 W32) = 560+primOpTag (VecAddOp FloatVec 8 W64) = 561+primOpTag (VecSubOp IntVec 16 W8) = 562+primOpTag (VecSubOp IntVec 8 W16) = 563+primOpTag (VecSubOp IntVec 4 W32) = 564+primOpTag (VecSubOp IntVec 2 W64) = 565+primOpTag (VecSubOp IntVec 32 W8) = 566+primOpTag (VecSubOp IntVec 16 W16) = 567+primOpTag (VecSubOp IntVec 8 W32) = 568+primOpTag (VecSubOp IntVec 4 W64) = 569+primOpTag (VecSubOp IntVec 64 W8) = 570+primOpTag (VecSubOp IntVec 32 W16) = 571+primOpTag (VecSubOp IntVec 16 W32) = 572+primOpTag (VecSubOp IntVec 8 W64) = 573+primOpTag (VecSubOp WordVec 16 W8) = 574+primOpTag (VecSubOp WordVec 8 W16) = 575+primOpTag (VecSubOp WordVec 4 W32) = 576+primOpTag (VecSubOp WordVec 2 W64) = 577+primOpTag (VecSubOp WordVec 32 W8) = 578+primOpTag (VecSubOp WordVec 16 W16) = 579+primOpTag (VecSubOp WordVec 8 W32) = 580+primOpTag (VecSubOp WordVec 4 W64) = 581+primOpTag (VecSubOp WordVec 64 W8) = 582+primOpTag (VecSubOp WordVec 32 W16) = 583+primOpTag (VecSubOp WordVec 16 W32) = 584+primOpTag (VecSubOp WordVec 8 W64) = 585+primOpTag (VecSubOp FloatVec 4 W32) = 586+primOpTag (VecSubOp FloatVec 2 W64) = 587+primOpTag (VecSubOp FloatVec 8 W32) = 588+primOpTag (VecSubOp FloatVec 4 W64) = 589+primOpTag (VecSubOp FloatVec 16 W32) = 590+primOpTag (VecSubOp FloatVec 8 W64) = 591+primOpTag (VecMulOp IntVec 16 W8) = 592+primOpTag (VecMulOp IntVec 8 W16) = 593+primOpTag (VecMulOp IntVec 4 W32) = 594+primOpTag (VecMulOp IntVec 2 W64) = 595+primOpTag (VecMulOp IntVec 32 W8) = 596+primOpTag (VecMulOp IntVec 16 W16) = 597+primOpTag (VecMulOp IntVec 8 W32) = 598+primOpTag (VecMulOp IntVec 4 W64) = 599+primOpTag (VecMulOp IntVec 64 W8) = 600+primOpTag (VecMulOp IntVec 32 W16) = 601+primOpTag (VecMulOp IntVec 16 W32) = 602+primOpTag (VecMulOp IntVec 8 W64) = 603+primOpTag (VecMulOp WordVec 16 W8) = 604+primOpTag (VecMulOp WordVec 8 W16) = 605+primOpTag (VecMulOp WordVec 4 W32) = 606+primOpTag (VecMulOp WordVec 2 W64) = 607+primOpTag (VecMulOp WordVec 32 W8) = 608+primOpTag (VecMulOp WordVec 16 W16) = 609+primOpTag (VecMulOp WordVec 8 W32) = 610+primOpTag (VecMulOp WordVec 4 W64) = 611+primOpTag (VecMulOp WordVec 64 W8) = 612+primOpTag (VecMulOp WordVec 32 W16) = 613+primOpTag (VecMulOp WordVec 16 W32) = 614+primOpTag (VecMulOp WordVec 8 W64) = 615+primOpTag (VecMulOp FloatVec 4 W32) = 616+primOpTag (VecMulOp FloatVec 2 W64) = 617+primOpTag (VecMulOp FloatVec 8 W32) = 618+primOpTag (VecMulOp FloatVec 4 W64) = 619+primOpTag (VecMulOp FloatVec 16 W32) = 620+primOpTag (VecMulOp FloatVec 8 W64) = 621+primOpTag (VecDivOp FloatVec 4 W32) = 622+primOpTag (VecDivOp FloatVec 2 W64) = 623+primOpTag (VecDivOp FloatVec 8 W32) = 624+primOpTag (VecDivOp FloatVec 4 W64) = 625+primOpTag (VecDivOp FloatVec 16 W32) = 626+primOpTag (VecDivOp FloatVec 8 W64) = 627+primOpTag (VecQuotOp IntVec 16 W8) = 628+primOpTag (VecQuotOp IntVec 8 W16) = 629+primOpTag (VecQuotOp IntVec 4 W32) = 630+primOpTag (VecQuotOp IntVec 2 W64) = 631+primOpTag (VecQuotOp IntVec 32 W8) = 632+primOpTag (VecQuotOp IntVec 16 W16) = 633+primOpTag (VecQuotOp IntVec 8 W32) = 634+primOpTag (VecQuotOp IntVec 4 W64) = 635+primOpTag (VecQuotOp IntVec 64 W8) = 636+primOpTag (VecQuotOp IntVec 32 W16) = 637+primOpTag (VecQuotOp IntVec 16 W32) = 638+primOpTag (VecQuotOp IntVec 8 W64) = 639+primOpTag (VecQuotOp WordVec 16 W8) = 640+primOpTag (VecQuotOp WordVec 8 W16) = 641+primOpTag (VecQuotOp WordVec 4 W32) = 642+primOpTag (VecQuotOp WordVec 2 W64) = 643+primOpTag (VecQuotOp WordVec 32 W8) = 644+primOpTag (VecQuotOp WordVec 16 W16) = 645+primOpTag (VecQuotOp WordVec 8 W32) = 646+primOpTag (VecQuotOp WordVec 4 W64) = 647+primOpTag (VecQuotOp WordVec 64 W8) = 648+primOpTag (VecQuotOp WordVec 32 W16) = 649+primOpTag (VecQuotOp WordVec 16 W32) = 650+primOpTag (VecQuotOp WordVec 8 W64) = 651+primOpTag (VecRemOp IntVec 16 W8) = 652+primOpTag (VecRemOp IntVec 8 W16) = 653+primOpTag (VecRemOp IntVec 4 W32) = 654+primOpTag (VecRemOp IntVec 2 W64) = 655+primOpTag (VecRemOp IntVec 32 W8) = 656+primOpTag (VecRemOp IntVec 16 W16) = 657+primOpTag (VecRemOp IntVec 8 W32) = 658+primOpTag (VecRemOp IntVec 4 W64) = 659+primOpTag (VecRemOp IntVec 64 W8) = 660+primOpTag (VecRemOp IntVec 32 W16) = 661+primOpTag (VecRemOp IntVec 16 W32) = 662+primOpTag (VecRemOp IntVec 8 W64) = 663+primOpTag (VecRemOp WordVec 16 W8) = 664+primOpTag (VecRemOp WordVec 8 W16) = 665+primOpTag (VecRemOp WordVec 4 W32) = 666+primOpTag (VecRemOp WordVec 2 W64) = 667+primOpTag (VecRemOp WordVec 32 W8) = 668+primOpTag (VecRemOp WordVec 16 W16) = 669+primOpTag (VecRemOp WordVec 8 W32) = 670+primOpTag (VecRemOp WordVec 4 W64) = 671+primOpTag (VecRemOp WordVec 64 W8) = 672+primOpTag (VecRemOp WordVec 32 W16) = 673+primOpTag (VecRemOp WordVec 16 W32) = 674+primOpTag (VecRemOp WordVec 8 W64) = 675+primOpTag (VecNegOp IntVec 16 W8) = 676+primOpTag (VecNegOp IntVec 8 W16) = 677+primOpTag (VecNegOp IntVec 4 W32) = 678+primOpTag (VecNegOp IntVec 2 W64) = 679+primOpTag (VecNegOp IntVec 32 W8) = 680+primOpTag (VecNegOp IntVec 16 W16) = 681+primOpTag (VecNegOp IntVec 8 W32) = 682+primOpTag (VecNegOp IntVec 4 W64) = 683+primOpTag (VecNegOp IntVec 64 W8) = 684+primOpTag (VecNegOp IntVec 32 W16) = 685+primOpTag (VecNegOp IntVec 16 W32) = 686+primOpTag (VecNegOp IntVec 8 W64) = 687+primOpTag (VecNegOp FloatVec 4 W32) = 688+primOpTag (VecNegOp FloatVec 2 W64) = 689+primOpTag (VecNegOp FloatVec 8 W32) = 690+primOpTag (VecNegOp FloatVec 4 W64) = 691+primOpTag (VecNegOp FloatVec 16 W32) = 692+primOpTag (VecNegOp FloatVec 8 W64) = 693+primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 694+primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 695+primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 696+primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 697+primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 698+primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 699+primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 700+primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 701+primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 702+primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 703+primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 704+primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 705+primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 706+primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 707+primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 708+primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 709+primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 710+primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 711+primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 712+primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 713+primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 714+primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 715+primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 716+primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 717+primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 718+primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 719+primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 720+primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 721+primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 722+primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 723+primOpTag (VecReadByteArrayOp IntVec 16 W8) = 724+primOpTag (VecReadByteArrayOp IntVec 8 W16) = 725+primOpTag (VecReadByteArrayOp IntVec 4 W32) = 726+primOpTag (VecReadByteArrayOp IntVec 2 W64) = 727+primOpTag (VecReadByteArrayOp IntVec 32 W8) = 728+primOpTag (VecReadByteArrayOp IntVec 16 W16) = 729+primOpTag (VecReadByteArrayOp IntVec 8 W32) = 730+primOpTag (VecReadByteArrayOp IntVec 4 W64) = 731+primOpTag (VecReadByteArrayOp IntVec 64 W8) = 732+primOpTag (VecReadByteArrayOp IntVec 32 W16) = 733+primOpTag (VecReadByteArrayOp IntVec 16 W32) = 734+primOpTag (VecReadByteArrayOp IntVec 8 W64) = 735+primOpTag (VecReadByteArrayOp WordVec 16 W8) = 736+primOpTag (VecReadByteArrayOp WordVec 8 W16) = 737+primOpTag (VecReadByteArrayOp WordVec 4 W32) = 738+primOpTag (VecReadByteArrayOp WordVec 2 W64) = 739+primOpTag (VecReadByteArrayOp WordVec 32 W8) = 740+primOpTag (VecReadByteArrayOp WordVec 16 W16) = 741+primOpTag (VecReadByteArrayOp WordVec 8 W32) = 742+primOpTag (VecReadByteArrayOp WordVec 4 W64) = 743+primOpTag (VecReadByteArrayOp WordVec 64 W8) = 744+primOpTag (VecReadByteArrayOp WordVec 32 W16) = 745+primOpTag (VecReadByteArrayOp WordVec 16 W32) = 746+primOpTag (VecReadByteArrayOp WordVec 8 W64) = 747+primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 748+primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 749+primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 750+primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 751+primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 752+primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 753+primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 754+primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 755+primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 756+primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 757+primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 758+primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 759+primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 760+primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 761+primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 762+primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 763+primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 764+primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 765+primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 766+primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 767+primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 768+primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 769+primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 770+primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 771+primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 772+primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 773+primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 774+primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 775+primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 776+primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 777+primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 778+primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 779+primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 780+primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 781+primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 782+primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 783+primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 784+primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 785+primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 786+primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 787+primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 788+primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 789+primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 790+primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 791+primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 792+primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 793+primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 794+primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 795+primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 796+primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 797+primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 798+primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 799+primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 800+primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 801+primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 802+primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 803+primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 804+primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 805+primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 806+primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 807+primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 808+primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 809+primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 810+primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 811+primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 812+primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 813+primOpTag (VecReadOffAddrOp IntVec 16 W8) = 814+primOpTag (VecReadOffAddrOp IntVec 8 W16) = 815+primOpTag (VecReadOffAddrOp IntVec 4 W32) = 816+primOpTag (VecReadOffAddrOp IntVec 2 W64) = 817+primOpTag (VecReadOffAddrOp IntVec 32 W8) = 818+primOpTag (VecReadOffAddrOp IntVec 16 W16) = 819+primOpTag (VecReadOffAddrOp IntVec 8 W32) = 820+primOpTag (VecReadOffAddrOp IntVec 4 W64) = 821+primOpTag (VecReadOffAddrOp IntVec 64 W8) = 822+primOpTag (VecReadOffAddrOp IntVec 32 W16) = 823+primOpTag (VecReadOffAddrOp IntVec 16 W32) = 824+primOpTag (VecReadOffAddrOp IntVec 8 W64) = 825+primOpTag (VecReadOffAddrOp WordVec 16 W8) = 826+primOpTag (VecReadOffAddrOp WordVec 8 W16) = 827+primOpTag (VecReadOffAddrOp WordVec 4 W32) = 828+primOpTag (VecReadOffAddrOp WordVec 2 W64) = 829+primOpTag (VecReadOffAddrOp WordVec 32 W8) = 830+primOpTag (VecReadOffAddrOp WordVec 16 W16) = 831+primOpTag (VecReadOffAddrOp WordVec 8 W32) = 832+primOpTag (VecReadOffAddrOp WordVec 4 W64) = 833+primOpTag (VecReadOffAddrOp WordVec 64 W8) = 834+primOpTag (VecReadOffAddrOp WordVec 32 W16) = 835+primOpTag (VecReadOffAddrOp WordVec 16 W32) = 836+primOpTag (VecReadOffAddrOp WordVec 8 W64) = 837+primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 838+primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 839+primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 840+primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 841+primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 842+primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 843+primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 844+primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 845+primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 846+primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 847+primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 848+primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 849+primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 850+primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 851+primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 852+primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 853+primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 854+primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 855+primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 856+primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 857+primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 858+primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 859+primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 860+primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 861+primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 862+primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 863+primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 864+primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 865+primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 866+primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 867+primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 868+primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 869+primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 870+primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 871+primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 872+primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 873+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 874+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 875+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 876+primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 877+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 878+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 879+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 880+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 881+primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 882+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 883+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 884+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 885+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 886+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 887+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 888+primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 889+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 890+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 891+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 892+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 893+primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 894+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 895+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 896+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 897+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 898+primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 899+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 900+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 901+primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 902+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 903+primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 904+primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 905+primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 906+primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 907+primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 908+primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 909+primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 910+primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 911+primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 912+primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 913+primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 914+primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 915+primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 916+primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 917+primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 918+primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 919+primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 920+primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 921+primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 922+primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 923+primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 924+primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 925+primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 926+primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 927+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 928+primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 929+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 930+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 931+primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 932+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 933+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 934+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 935+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 936+primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 937+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 938+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 939+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 940+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 941+primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 942+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 943+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 944+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 945+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 946+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 947+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 948+primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 949+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 950+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 951+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 952+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 953+primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 954+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 955+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 956+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 957+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 958+primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 959+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 960+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 961+primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 962+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 963+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 964+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 965+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 966+primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 967+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 968+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 969+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 970+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 971+primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 972+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 973+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 974+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 975+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 976+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 977+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 978+primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 979+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 980+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 981+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 982+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 983+primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 984+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 985+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 986+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 987+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 988+primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 989+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 990+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 991+primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 992+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 993+primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 994+primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 995+primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 996+primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 997+primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 998+primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 999+primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1000+primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1001+primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1002+primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1003+primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1004+primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1005+primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1006+primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1007+primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1008+primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1009+primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1010+primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1011+primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1012+primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1013+primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1014+primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1015+primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1016+primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1017+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1018+primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1019+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1020+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1021+primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1022+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1023+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1024+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1025+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1026+primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1027+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1028+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1029+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1030+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1031+primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1032+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1033+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1034+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1035+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1036+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1037+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1038+primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1039+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1040+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1041+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1042+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1043+primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1044+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1045+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1046+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1047+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1048+primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1049+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1050+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1051+primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1052+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1053+primOpTag PrefetchByteArrayOp3 = 1054+primOpTag PrefetchMutableByteArrayOp3 = 1055+primOpTag PrefetchAddrOp3 = 1056+primOpTag PrefetchValueOp3 = 1057+primOpTag PrefetchByteArrayOp2 = 1058+primOpTag PrefetchMutableByteArrayOp2 = 1059+primOpTag PrefetchAddrOp2 = 1060+primOpTag PrefetchValueOp2 = 1061+primOpTag PrefetchByteArrayOp1 = 1062+primOpTag PrefetchMutableByteArrayOp1 = 1063+primOpTag PrefetchAddrOp1 = 1064+primOpTag PrefetchValueOp1 = 1065+primOpTag PrefetchByteArrayOp0 = 1066+primOpTag PrefetchMutableByteArrayOp0 = 1067+primOpTag PrefetchAddrOp0 = 1068+primOpTag PrefetchValueOp0 = 1069
+ autogen/primop-vector-tycons.hs-incl view
@@ -0,0 +1,30 @@+    , int8X16PrimTyCon+    , int16X8PrimTyCon+    , int32X4PrimTyCon+    , int64X2PrimTyCon+    , int8X32PrimTyCon+    , int16X16PrimTyCon+    , int32X8PrimTyCon+    , int64X4PrimTyCon+    , int8X64PrimTyCon+    , int16X32PrimTyCon+    , int32X16PrimTyCon+    , int64X8PrimTyCon+    , word8X16PrimTyCon+    , word16X8PrimTyCon+    , word32X4PrimTyCon+    , word64X2PrimTyCon+    , word8X32PrimTyCon+    , word16X16PrimTyCon+    , word32X8PrimTyCon+    , word64X4PrimTyCon+    , word8X64PrimTyCon+    , word16X32PrimTyCon+    , word32X16PrimTyCon+    , word64X8PrimTyCon+    , floatX4PrimTyCon+    , doubleX2PrimTyCon+    , floatX8PrimTyCon+    , doubleX4PrimTyCon+    , floatX16PrimTyCon+    , doubleX8PrimTyCon
+ autogen/primop-vector-tys-exports.hs-incl view
@@ -0,0 +1,30 @@+        int8X16PrimTy, int8X16PrimTyCon,+        int16X8PrimTy, int16X8PrimTyCon,+        int32X4PrimTy, int32X4PrimTyCon,+        int64X2PrimTy, int64X2PrimTyCon,+        int8X32PrimTy, int8X32PrimTyCon,+        int16X16PrimTy, int16X16PrimTyCon,+        int32X8PrimTy, int32X8PrimTyCon,+        int64X4PrimTy, int64X4PrimTyCon,+        int8X64PrimTy, int8X64PrimTyCon,+        int16X32PrimTy, int16X32PrimTyCon,+        int32X16PrimTy, int32X16PrimTyCon,+        int64X8PrimTy, int64X8PrimTyCon,+        word8X16PrimTy, word8X16PrimTyCon,+        word16X8PrimTy, word16X8PrimTyCon,+        word32X4PrimTy, word32X4PrimTyCon,+        word64X2PrimTy, word64X2PrimTyCon,+        word8X32PrimTy, word8X32PrimTyCon,+        word16X16PrimTy, word16X16PrimTyCon,+        word32X8PrimTy, word32X8PrimTyCon,+        word64X4PrimTy, word64X4PrimTyCon,+        word8X64PrimTy, word8X64PrimTyCon,+        word16X32PrimTy, word16X32PrimTyCon,+        word32X16PrimTy, word32X16PrimTyCon,+        word64X8PrimTy, word64X8PrimTyCon,+        floatX4PrimTy, floatX4PrimTyCon,+        doubleX2PrimTy, doubleX2PrimTyCon,+        floatX8PrimTy, floatX8PrimTyCon,+        doubleX4PrimTy, doubleX4PrimTyCon,+        floatX16PrimTy, floatX16PrimTyCon,+        doubleX8PrimTy, doubleX8PrimTyCon,
+ autogen/primop-vector-tys.hs-incl view
@@ -0,0 +1,180 @@+int8X16PrimTyConName :: Name+int8X16PrimTyConName = mkPrimTc (fsLit "Int8X16#") int8X16PrimTyConKey int8X16PrimTyCon+int8X16PrimTy :: Type+int8X16PrimTy = mkTyConTy int8X16PrimTyCon+int8X16PrimTyCon :: TyCon+int8X16PrimTyCon = pcPrimTyCon0 int8X16PrimTyConName (VecRep 16 Int8ElemRep)+int16X8PrimTyConName :: Name+int16X8PrimTyConName = mkPrimTc (fsLit "Int16X8#") int16X8PrimTyConKey int16X8PrimTyCon+int16X8PrimTy :: Type+int16X8PrimTy = mkTyConTy int16X8PrimTyCon+int16X8PrimTyCon :: TyCon+int16X8PrimTyCon = pcPrimTyCon0 int16X8PrimTyConName (VecRep 8 Int16ElemRep)+int32X4PrimTyConName :: Name+int32X4PrimTyConName = mkPrimTc (fsLit "Int32X4#") int32X4PrimTyConKey int32X4PrimTyCon+int32X4PrimTy :: Type+int32X4PrimTy = mkTyConTy int32X4PrimTyCon+int32X4PrimTyCon :: TyCon+int32X4PrimTyCon = pcPrimTyCon0 int32X4PrimTyConName (VecRep 4 Int32ElemRep)+int64X2PrimTyConName :: Name+int64X2PrimTyConName = mkPrimTc (fsLit "Int64X2#") int64X2PrimTyConKey int64X2PrimTyCon+int64X2PrimTy :: Type+int64X2PrimTy = mkTyConTy int64X2PrimTyCon+int64X2PrimTyCon :: TyCon+int64X2PrimTyCon = pcPrimTyCon0 int64X2PrimTyConName (VecRep 2 Int64ElemRep)+int8X32PrimTyConName :: Name+int8X32PrimTyConName = mkPrimTc (fsLit "Int8X32#") int8X32PrimTyConKey int8X32PrimTyCon+int8X32PrimTy :: Type+int8X32PrimTy = mkTyConTy int8X32PrimTyCon+int8X32PrimTyCon :: TyCon+int8X32PrimTyCon = pcPrimTyCon0 int8X32PrimTyConName (VecRep 32 Int8ElemRep)+int16X16PrimTyConName :: Name+int16X16PrimTyConName = mkPrimTc (fsLit "Int16X16#") int16X16PrimTyConKey int16X16PrimTyCon+int16X16PrimTy :: Type+int16X16PrimTy = mkTyConTy int16X16PrimTyCon+int16X16PrimTyCon :: TyCon+int16X16PrimTyCon = pcPrimTyCon0 int16X16PrimTyConName (VecRep 16 Int16ElemRep)+int32X8PrimTyConName :: Name+int32X8PrimTyConName = mkPrimTc (fsLit "Int32X8#") int32X8PrimTyConKey int32X8PrimTyCon+int32X8PrimTy :: Type+int32X8PrimTy = mkTyConTy int32X8PrimTyCon+int32X8PrimTyCon :: TyCon+int32X8PrimTyCon = pcPrimTyCon0 int32X8PrimTyConName (VecRep 8 Int32ElemRep)+int64X4PrimTyConName :: Name+int64X4PrimTyConName = mkPrimTc (fsLit "Int64X4#") int64X4PrimTyConKey int64X4PrimTyCon+int64X4PrimTy :: Type+int64X4PrimTy = mkTyConTy int64X4PrimTyCon+int64X4PrimTyCon :: TyCon+int64X4PrimTyCon = pcPrimTyCon0 int64X4PrimTyConName (VecRep 4 Int64ElemRep)+int8X64PrimTyConName :: Name+int8X64PrimTyConName = mkPrimTc (fsLit "Int8X64#") int8X64PrimTyConKey int8X64PrimTyCon+int8X64PrimTy :: Type+int8X64PrimTy = mkTyConTy int8X64PrimTyCon+int8X64PrimTyCon :: TyCon+int8X64PrimTyCon = pcPrimTyCon0 int8X64PrimTyConName (VecRep 64 Int8ElemRep)+int16X32PrimTyConName :: Name+int16X32PrimTyConName = mkPrimTc (fsLit "Int16X32#") int16X32PrimTyConKey int16X32PrimTyCon+int16X32PrimTy :: Type+int16X32PrimTy = mkTyConTy int16X32PrimTyCon+int16X32PrimTyCon :: TyCon+int16X32PrimTyCon = pcPrimTyCon0 int16X32PrimTyConName (VecRep 32 Int16ElemRep)+int32X16PrimTyConName :: Name+int32X16PrimTyConName = mkPrimTc (fsLit "Int32X16#") int32X16PrimTyConKey int32X16PrimTyCon+int32X16PrimTy :: Type+int32X16PrimTy = mkTyConTy int32X16PrimTyCon+int32X16PrimTyCon :: TyCon+int32X16PrimTyCon = pcPrimTyCon0 int32X16PrimTyConName (VecRep 16 Int32ElemRep)+int64X8PrimTyConName :: Name+int64X8PrimTyConName = mkPrimTc (fsLit "Int64X8#") int64X8PrimTyConKey int64X8PrimTyCon+int64X8PrimTy :: Type+int64X8PrimTy = mkTyConTy int64X8PrimTyCon+int64X8PrimTyCon :: TyCon+int64X8PrimTyCon = pcPrimTyCon0 int64X8PrimTyConName (VecRep 8 Int64ElemRep)+word8X16PrimTyConName :: Name+word8X16PrimTyConName = mkPrimTc (fsLit "Word8X16#") word8X16PrimTyConKey word8X16PrimTyCon+word8X16PrimTy :: Type+word8X16PrimTy = mkTyConTy word8X16PrimTyCon+word8X16PrimTyCon :: TyCon+word8X16PrimTyCon = pcPrimTyCon0 word8X16PrimTyConName (VecRep 16 Word8ElemRep)+word16X8PrimTyConName :: Name+word16X8PrimTyConName = mkPrimTc (fsLit "Word16X8#") word16X8PrimTyConKey word16X8PrimTyCon+word16X8PrimTy :: Type+word16X8PrimTy = mkTyConTy word16X8PrimTyCon+word16X8PrimTyCon :: TyCon+word16X8PrimTyCon = pcPrimTyCon0 word16X8PrimTyConName (VecRep 8 Word16ElemRep)+word32X4PrimTyConName :: Name+word32X4PrimTyConName = mkPrimTc (fsLit "Word32X4#") word32X4PrimTyConKey word32X4PrimTyCon+word32X4PrimTy :: Type+word32X4PrimTy = mkTyConTy word32X4PrimTyCon+word32X4PrimTyCon :: TyCon+word32X4PrimTyCon = pcPrimTyCon0 word32X4PrimTyConName (VecRep 4 Word32ElemRep)+word64X2PrimTyConName :: Name+word64X2PrimTyConName = mkPrimTc (fsLit "Word64X2#") word64X2PrimTyConKey word64X2PrimTyCon+word64X2PrimTy :: Type+word64X2PrimTy = mkTyConTy word64X2PrimTyCon+word64X2PrimTyCon :: TyCon+word64X2PrimTyCon = pcPrimTyCon0 word64X2PrimTyConName (VecRep 2 Word64ElemRep)+word8X32PrimTyConName :: Name+word8X32PrimTyConName = mkPrimTc (fsLit "Word8X32#") word8X32PrimTyConKey word8X32PrimTyCon+word8X32PrimTy :: Type+word8X32PrimTy = mkTyConTy word8X32PrimTyCon+word8X32PrimTyCon :: TyCon+word8X32PrimTyCon = pcPrimTyCon0 word8X32PrimTyConName (VecRep 32 Word8ElemRep)+word16X16PrimTyConName :: Name+word16X16PrimTyConName = mkPrimTc (fsLit "Word16X16#") word16X16PrimTyConKey word16X16PrimTyCon+word16X16PrimTy :: Type+word16X16PrimTy = mkTyConTy word16X16PrimTyCon+word16X16PrimTyCon :: TyCon+word16X16PrimTyCon = pcPrimTyCon0 word16X16PrimTyConName (VecRep 16 Word16ElemRep)+word32X8PrimTyConName :: Name+word32X8PrimTyConName = mkPrimTc (fsLit "Word32X8#") word32X8PrimTyConKey word32X8PrimTyCon+word32X8PrimTy :: Type+word32X8PrimTy = mkTyConTy word32X8PrimTyCon+word32X8PrimTyCon :: TyCon+word32X8PrimTyCon = pcPrimTyCon0 word32X8PrimTyConName (VecRep 8 Word32ElemRep)+word64X4PrimTyConName :: Name+word64X4PrimTyConName = mkPrimTc (fsLit "Word64X4#") word64X4PrimTyConKey word64X4PrimTyCon+word64X4PrimTy :: Type+word64X4PrimTy = mkTyConTy word64X4PrimTyCon+word64X4PrimTyCon :: TyCon+word64X4PrimTyCon = pcPrimTyCon0 word64X4PrimTyConName (VecRep 4 Word64ElemRep)+word8X64PrimTyConName :: Name+word8X64PrimTyConName = mkPrimTc (fsLit "Word8X64#") word8X64PrimTyConKey word8X64PrimTyCon+word8X64PrimTy :: Type+word8X64PrimTy = mkTyConTy word8X64PrimTyCon+word8X64PrimTyCon :: TyCon+word8X64PrimTyCon = pcPrimTyCon0 word8X64PrimTyConName (VecRep 64 Word8ElemRep)+word16X32PrimTyConName :: Name+word16X32PrimTyConName = mkPrimTc (fsLit "Word16X32#") word16X32PrimTyConKey word16X32PrimTyCon+word16X32PrimTy :: Type+word16X32PrimTy = mkTyConTy word16X32PrimTyCon+word16X32PrimTyCon :: TyCon+word16X32PrimTyCon = pcPrimTyCon0 word16X32PrimTyConName (VecRep 32 Word16ElemRep)+word32X16PrimTyConName :: Name+word32X16PrimTyConName = mkPrimTc (fsLit "Word32X16#") word32X16PrimTyConKey word32X16PrimTyCon+word32X16PrimTy :: Type+word32X16PrimTy = mkTyConTy word32X16PrimTyCon+word32X16PrimTyCon :: TyCon+word32X16PrimTyCon = pcPrimTyCon0 word32X16PrimTyConName (VecRep 16 Word32ElemRep)+word64X8PrimTyConName :: Name+word64X8PrimTyConName = mkPrimTc (fsLit "Word64X8#") word64X8PrimTyConKey word64X8PrimTyCon+word64X8PrimTy :: Type+word64X8PrimTy = mkTyConTy word64X8PrimTyCon+word64X8PrimTyCon :: TyCon+word64X8PrimTyCon = pcPrimTyCon0 word64X8PrimTyConName (VecRep 8 Word64ElemRep)+floatX4PrimTyConName :: Name+floatX4PrimTyConName = mkPrimTc (fsLit "FloatX4#") floatX4PrimTyConKey floatX4PrimTyCon+floatX4PrimTy :: Type+floatX4PrimTy = mkTyConTy floatX4PrimTyCon+floatX4PrimTyCon :: TyCon+floatX4PrimTyCon = pcPrimTyCon0 floatX4PrimTyConName (VecRep 4 FloatElemRep)+doubleX2PrimTyConName :: Name+doubleX2PrimTyConName = mkPrimTc (fsLit "DoubleX2#") doubleX2PrimTyConKey doubleX2PrimTyCon+doubleX2PrimTy :: Type+doubleX2PrimTy = mkTyConTy doubleX2PrimTyCon+doubleX2PrimTyCon :: TyCon+doubleX2PrimTyCon = pcPrimTyCon0 doubleX2PrimTyConName (VecRep 2 DoubleElemRep)+floatX8PrimTyConName :: Name+floatX8PrimTyConName = mkPrimTc (fsLit "FloatX8#") floatX8PrimTyConKey floatX8PrimTyCon+floatX8PrimTy :: Type+floatX8PrimTy = mkTyConTy floatX8PrimTyCon+floatX8PrimTyCon :: TyCon+floatX8PrimTyCon = pcPrimTyCon0 floatX8PrimTyConName (VecRep 8 FloatElemRep)+doubleX4PrimTyConName :: Name+doubleX4PrimTyConName = mkPrimTc (fsLit "DoubleX4#") doubleX4PrimTyConKey doubleX4PrimTyCon+doubleX4PrimTy :: Type+doubleX4PrimTy = mkTyConTy doubleX4PrimTyCon+doubleX4PrimTyCon :: TyCon+doubleX4PrimTyCon = pcPrimTyCon0 doubleX4PrimTyConName (VecRep 4 DoubleElemRep)+floatX16PrimTyConName :: Name+floatX16PrimTyConName = mkPrimTc (fsLit "FloatX16#") floatX16PrimTyConKey floatX16PrimTyCon+floatX16PrimTy :: Type+floatX16PrimTy = mkTyConTy floatX16PrimTyCon+floatX16PrimTyCon :: TyCon+floatX16PrimTyCon = pcPrimTyCon0 floatX16PrimTyConName (VecRep 16 FloatElemRep)+doubleX8PrimTyConName :: Name+doubleX8PrimTyConName = mkPrimTc (fsLit "DoubleX8#") doubleX8PrimTyConKey doubleX8PrimTyCon+doubleX8PrimTy :: Type+doubleX8PrimTy = mkTyConTy doubleX8PrimTyCon+doubleX8PrimTyCon :: TyCon+doubleX8PrimTyCon = pcPrimTyCon0 doubleX8PrimTyConName (VecRep 8 DoubleElemRep)
+ autogen/primop-vector-uniques.hs-incl view
@@ -0,0 +1,60 @@+int8X16PrimTyConKey :: Unique+int8X16PrimTyConKey = mkPreludeTyConUnique 300+int16X8PrimTyConKey :: Unique+int16X8PrimTyConKey = mkPreludeTyConUnique 301+int32X4PrimTyConKey :: Unique+int32X4PrimTyConKey = mkPreludeTyConUnique 302+int64X2PrimTyConKey :: Unique+int64X2PrimTyConKey = mkPreludeTyConUnique 303+int8X32PrimTyConKey :: Unique+int8X32PrimTyConKey = mkPreludeTyConUnique 304+int16X16PrimTyConKey :: Unique+int16X16PrimTyConKey = mkPreludeTyConUnique 305+int32X8PrimTyConKey :: Unique+int32X8PrimTyConKey = mkPreludeTyConUnique 306+int64X4PrimTyConKey :: Unique+int64X4PrimTyConKey = mkPreludeTyConUnique 307+int8X64PrimTyConKey :: Unique+int8X64PrimTyConKey = mkPreludeTyConUnique 308+int16X32PrimTyConKey :: Unique+int16X32PrimTyConKey = mkPreludeTyConUnique 309+int32X16PrimTyConKey :: Unique+int32X16PrimTyConKey = mkPreludeTyConUnique 310+int64X8PrimTyConKey :: Unique+int64X8PrimTyConKey = mkPreludeTyConUnique 311+word8X16PrimTyConKey :: Unique+word8X16PrimTyConKey = mkPreludeTyConUnique 312+word16X8PrimTyConKey :: Unique+word16X8PrimTyConKey = mkPreludeTyConUnique 313+word32X4PrimTyConKey :: Unique+word32X4PrimTyConKey = mkPreludeTyConUnique 314+word64X2PrimTyConKey :: Unique+word64X2PrimTyConKey = mkPreludeTyConUnique 315+word8X32PrimTyConKey :: Unique+word8X32PrimTyConKey = mkPreludeTyConUnique 316+word16X16PrimTyConKey :: Unique+word16X16PrimTyConKey = mkPreludeTyConUnique 317+word32X8PrimTyConKey :: Unique+word32X8PrimTyConKey = mkPreludeTyConUnique 318+word64X4PrimTyConKey :: Unique+word64X4PrimTyConKey = mkPreludeTyConUnique 319+word8X64PrimTyConKey :: Unique+word8X64PrimTyConKey = mkPreludeTyConUnique 320+word16X32PrimTyConKey :: Unique+word16X32PrimTyConKey = mkPreludeTyConUnique 321+word32X16PrimTyConKey :: Unique+word32X16PrimTyConKey = mkPreludeTyConUnique 322+word64X8PrimTyConKey :: Unique+word64X8PrimTyConKey = mkPreludeTyConUnique 323+floatX4PrimTyConKey :: Unique+floatX4PrimTyConKey = mkPreludeTyConUnique 324+doubleX2PrimTyConKey :: Unique+doubleX2PrimTyConKey = mkPreludeTyConUnique 325+floatX8PrimTyConKey :: Unique+floatX8PrimTyConKey = mkPreludeTyConUnique 326+doubleX4PrimTyConKey :: Unique+doubleX4PrimTyConKey = mkPreludeTyConUnique 327+floatX16PrimTyConKey :: Unique+floatX16PrimTyConKey = mkPreludeTyConUnique 328+doubleX8PrimTyConKey :: Unique+doubleX8PrimTyConKey = mkPreludeTyConUnique 329
+ backpack/BkpSyn.hs view
@@ -0,0 +1,83 @@+-- | This is the syntax for bkp files which are parsed in 'ghc --backpack'+-- mode.  This syntax is used purely for testing purposes.++module BkpSyn (+    -- * Backpack abstract syntax+    HsUnitId(..),+    LHsUnitId,+    HsModuleSubst,+    LHsModuleSubst,+    HsModuleId(..),+    LHsModuleId,+    HsComponentId(..),+    LHsUnit, HsUnit(..),+    LHsUnitDecl, HsUnitDecl(..),+    HsDeclType(..),+    IncludeDecl(..),+    LRenaming, Renaming(..),+    ) where++import HsSyn+import RdrName+import SrcLoc+import Outputable+import Module+import PackageConfig++{-+************************************************************************+*                                                                      *+                        User syntax+*                                                                      *+************************************************************************+-}++data HsComponentId = HsComponentId {+    hsPackageName :: PackageName,+    hsComponentId :: ComponentId+    }++instance Outputable HsComponentId where+    ppr (HsComponentId _pn cid) = ppr cid -- todo debug with pn++data HsUnitId n = HsUnitId (Located n) [LHsModuleSubst n]+type LHsUnitId n = Located (HsUnitId n)++type HsModuleSubst n = (Located ModuleName, LHsModuleId n)+type LHsModuleSubst n = Located (HsModuleSubst n)++data HsModuleId n = HsModuleVar (Located ModuleName)+                  | HsModuleId (LHsUnitId n) (Located ModuleName)+type LHsModuleId n = Located (HsModuleId n)++-- | Top level @unit@ declaration in a Backpack file.+data HsUnit n = HsUnit {+        hsunitName :: Located n,+        hsunitBody :: [LHsUnitDecl n]+    }+type LHsUnit n = Located (HsUnit n)++-- | A declaration in a package, e.g. a module or signature definition,+-- or an include.+data HsDeclType = ModuleD | SignatureD+data HsUnitDecl n+    = DeclD      HsDeclType (Located ModuleName) (Maybe (Located (HsModule RdrName)))+    | IncludeD   (IncludeDecl n)+type LHsUnitDecl n = Located (HsUnitDecl n)++-- | An include of another unit+data IncludeDecl n = IncludeDecl {+        idUnitId :: LHsUnitId n,+        idModRenaming :: Maybe [ LRenaming ],+        -- | Is this a @dependency signature@ include?  If so,+        -- we don't compile this include when we instantiate this+        -- unit (as there should not be any modules brought into+        -- scope.)+        idSignatureInclude :: Bool+    }++-- | Rename a module from one name to another.  The identity renaming+-- means that the module should be brought into scope.+data Renaming = Renaming { renameFrom :: Located ModuleName+                         , renameTo :: Maybe (Located ModuleName) }+type LRenaming = Located Renaming
+ backpack/DriverBkp.hs view
@@ -0,0 +1,823 @@+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}++-- | This is the driver for the 'ghc --backpack' mode, which+-- is a reimplementation of the "package manager" bits of+-- Backpack directly in GHC.  The basic method of operation+-- is to compile packages and then directly insert them into+-- GHC's in memory database.+--+-- The compilation products of this mode aren't really suitable+-- for Cabal, because GHC makes up component IDs for the things+-- it builds and doesn't serialize out the database contents.+-- But it's still handy for constructing tests.++module DriverBkp (doBackpack) where++#include "HsVersions.h"++-- In a separate module because it hooks into the parser.+import BkpSyn++import GHC hiding (Failed, Succeeded)+import Packages+import Parser+import Lexer+import GhcMonad+import DynFlags+import TcRnMonad+import TcRnDriver+import Module+import HscTypes+import StringBuffer+import FastString+import ErrUtils+import SrcLoc+import HscMain+import UniqFM+import UniqDFM+import Outputable+import Maybes+import HeaderInfo+import MkIface+import GhcMake+import UniqDSet+import PrelNames+import BasicTypes hiding (SuccessFlag(..))+import Finder+import Util++import qualified GHC.LanguageExtensions as LangExt++import Panic+import Data.List+import System.Exit+import Control.Monad+import System.FilePath+import Data.Version++-- for the unification+import Data.IORef+import Data.Map (Map)+import qualified Data.Map as Map++-- | Entry point to compile a Backpack file.+doBackpack :: [FilePath] -> Ghc ()+doBackpack [src_filename] = do+    -- Apply options from file to dflags+    dflags0 <- getDynFlags+    let dflags1 = dflags0+    src_opts <- liftIO $ getOptionsFromFile dflags1 src_filename+    (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts+    modifySession (\hsc_env -> hsc_env {hsc_dflags = dflags})+    -- Cribbed from: preprocessFile / DriverPipeline+    liftIO $ checkProcessArgsResult dflags unhandled_flags+    liftIO $ handleFlagWarnings dflags warns+    -- TODO: Preprocessing not implemented++    buf <- liftIO $ hGetStringBuffer src_filename+    let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great+    case unP parseBackpack (mkPState dflags buf loc) of+        PFailed span err -> do+            liftIO $ throwOneError (mkPlainErrMsg dflags span err)+        POk _ pkgname_bkp -> do+            -- OK, so we have an LHsUnit PackageName, but we want an+            -- LHsUnit HsComponentId.  So let's rename it.+            let bkp = renameHsUnits dflags (packageNameMap pkgname_bkp) pkgname_bkp+            initBkpM src_filename bkp $+                forM_ (zip [1..] bkp) $ \(i, lunit) -> do+                    let comp_name = unLoc (hsunitName (unLoc lunit))+                    msgTopPackage (i,length bkp) comp_name+                    innerBkpM $ do+                        let (cid, insts) = computeUnitId lunit+                        if null insts+                            then if cid == ComponentId (fsLit "main")+                                    then compileExe lunit+                                    else compileUnit cid []+                            else typecheckUnit cid insts+doBackpack _ =+    throwGhcException (CmdLineError "--backpack can only process a single file")++computeUnitId :: LHsUnit HsComponentId -> (ComponentId, [(ModuleName, Module)])+computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ])+  where+    cid = hsComponentId (unLoc (hsunitName unit))+    reqs = uniqDSetToList (unionManyUniqDSets (map (get_reqs . unLoc) (hsunitBody unit)))+    get_reqs (DeclD SignatureD (L _ modname) _) = unitUniqDSet modname+    get_reqs (DeclD ModuleD _ _) = emptyUniqDSet+    get_reqs (IncludeD (IncludeDecl (L _ hsuid) _ _)) =+        unitIdFreeHoles (convertHsUnitId hsuid)++-- | Tiny enum for all types of Backpack operations we may do.+data SessionType+    -- | A compilation operation which will result in a+    -- runnable executable being produced.+    = ExeSession+    -- | A type-checking operation which produces only+    -- interface files, no object files.+    | TcSession+    -- | A compilation operation which produces both+    -- interface files and object files.+    | CompSession+    deriving (Eq)++-- | Create a temporary Session to do some sort of type checking or+-- compilation.+withBkpSession :: ComponentId+               -> [(ModuleName, Module)]+               -> [(UnitId, ModRenaming)]+               -> SessionType   -- what kind of session are we doing+               -> BkpM a        -- actual action to run+               -> BkpM a+withBkpSession cid insts deps session_type do_this = do+    dflags <- getDynFlags+    let (ComponentId cid_fs) = cid+        is_primary = False+        uid_str = unpackFS (hashUnitId cid insts)+        cid_str = unpackFS cid_fs+        -- There are multiple units in a single Backpack file, so we+        -- need to separate out the results in those cases.  Right now,+        -- we follow this hierarchy:+        --      $outputdir/$compid          --> typecheck results+        --      $outputdir/$compid/$unitid  --> compile results+        key_base p | Just f <- p dflags = f+                   | otherwise          = "."+        sub_comp p | is_primary = p+                   | otherwise = p </> cid_str+        outdir p | CompSession <- session_type+                 -- Special case when package is definite+                 , not (null insts) = sub_comp (key_base p) </> uid_str+                 | otherwise = sub_comp (key_base p)+    withTempSession (overHscDynFlags (\dflags ->+      -- If we're type-checking an indefinite package, we want to+      -- turn on interface writing.  However, if the user also+      -- explicitly passed in `-fno-code`, we DON'T want to write+      -- interfaces unless the user also asked for `-fwrite-interface`.+      (case session_type of+        -- Make sure to write interfaces when we are type-checking+        -- indefinite packages.+        TcSession | hscTarget dflags /= HscNothing+                  -> flip gopt_set Opt_WriteInterface+                  | otherwise -> id+        CompSession -> id+        ExeSession -> id) $+      dflags {+        hscTarget   = case session_type of+                        TcSession -> HscNothing+                        _ -> hscTarget dflags,+        thisUnitIdInsts_ = Just insts,+        thisComponentId_ = Just cid,+        thisInstalledUnitId =+            case session_type of+                TcSession -> newInstalledUnitId cid Nothing+                -- No hash passed if no instances+                _ | null insts -> newInstalledUnitId cid Nothing+                  | otherwise  -> newInstalledUnitId cid (Just (hashUnitId cid insts)),+        -- Setup all of the output directories according to our hierarchy+        objectDir   = Just (outdir objectDir),+        hiDir       = Just (outdir hiDir),+        stubDir     = Just (outdir stubDir),+        -- Unset output-file for non exe builds+        outputFile  = if session_type == ExeSession+                        then outputFile dflags+                        else Nothing,+        -- Clear the import path so we don't accidentally grab anything+        importPaths = [],+        -- Synthesized the flags+        packageFlags = packageFlags dflags ++ map (\(uid0, rn) ->+          let uid = unwireUnitId dflags (improveUnitId (getPackageConfigMap dflags) $ renameHoleUnitId dflags (listToUFM insts) uid0)+          in ExposePackage+            (showSDoc dflags+                (text "-unit-id" <+> ppr uid <+> ppr rn))+            (UnitIdArg uid) rn) deps+      } )) $ do+        dflags <- getSessionDynFlags+        -- pprTrace "flags" (ppr insts <> ppr deps) $ return ()+        -- Calls initPackages+        _ <- setSessionDynFlags dflags+        do_this++withBkpExeSession :: [(UnitId, ModRenaming)] -> BkpM a -> BkpM a+withBkpExeSession deps do_this = do+    withBkpSession (ComponentId (fsLit "main")) [] deps ExeSession do_this++getSource :: ComponentId -> BkpM (LHsUnit HsComponentId)+getSource cid = do+    bkp_env <- getBkpEnv+    case Map.lookup cid (bkp_table bkp_env) of+        Nothing -> pprPanic "missing needed dependency" (ppr cid)+        Just lunit -> return lunit++typecheckUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM ()+typecheckUnit cid insts = do+    lunit <- getSource cid+    buildUnit TcSession cid insts lunit++compileUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM ()+compileUnit cid insts = do+    -- Let everyone know we're building this unit ID+    msgUnitId (newUnitId cid insts)+    lunit <- getSource cid+    buildUnit CompSession cid insts lunit++-- | Compute the dependencies with instantiations of a syntactic+-- HsUnit; e.g., wherever you see @dependency p[A=<A>]@ in a+-- unit file, return the 'UnitId' corresponding to @p[A=<A>]@.+-- The @include_sigs@ parameter controls whether or not we also+-- include @dependency signature@ declarations in this calculation.+--+-- Invariant: this NEVER returns InstalledUnitId.+hsunitDeps :: Bool {- include sigs -} -> HsUnit HsComponentId -> [(UnitId, ModRenaming)]+hsunitDeps include_sigs unit = concatMap get_dep (hsunitBody unit)+  where+    get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn is_sig)))+        | include_sigs || not is_sig = [(convertHsUnitId hsuid, go mb_lrn)]+        | otherwise = []+      where+        go Nothing = ModRenaming True []+        go (Just lrns) = ModRenaming False (map convRn lrns)+          where+            convRn (L _ (Renaming (L _ from) Nothing))         = (from, from)+            convRn (L _ (Renaming (L _ from) (Just (L _ to)))) = (from, to)+    get_dep _ = []++buildUnit :: SessionType -> ComponentId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM ()+buildUnit session cid insts lunit = do+    -- NB: include signature dependencies ONLY when typechecking.+    -- If we're compiling, it's not necessary to recursively+    -- compile a signature since it isn't going to produce+    -- any object files.+    let deps_w_rns = hsunitDeps (session == TcSession) (unLoc lunit)+        raw_deps = map fst deps_w_rns+    dflags <- getDynFlags+    -- The compilation dependencies are just the appropriately filled+    -- in unit IDs which must be compiled before we can compile.+    let hsubst = listToUFM insts+        deps0 = map (renameHoleUnitId dflags hsubst) raw_deps++    -- Build dependencies OR make sure they make sense. BUT NOTE,+    -- we can only check the ones that are fully filled; the rest+    -- we have to defer until we've typechecked our local signature.+    -- TODO: work this into GhcMake!!+    forM_ (zip [1..] deps0) $ \(i, dep) ->+        case session of+            TcSession -> return ()+            _ -> compileInclude (length deps0) (i, dep)++    dflags <- getDynFlags+    -- IMPROVE IT+    let deps = map (improveUnitId (getPackageConfigMap dflags)) deps0++    mb_old_eps <- case session of+                    TcSession -> fmap Just getEpsGhc+                    _ -> return Nothing++    conf <- withBkpSession cid insts deps_w_rns session $ do++        dflags <- getDynFlags+        mod_graph <- hsunitModuleGraph dflags (unLoc lunit)+        -- pprTrace "mod_graph" (ppr mod_graph) $ return ()++        msg <- mkBackpackMsg+        ok <- load' LoadAllTargets (Just msg) mod_graph+        when (failed ok) (liftIO $ exitWith (ExitFailure 1))++        let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags+            export_mod ms = (ms_mod_name ms, ms_mod ms)+            -- Export everything!+            mods = [ export_mod ms | ms <- mod_graph, ms_hsc_src ms == HsSrcFile ]++        -- Compile relevant only+        hsc_env <- getSession+        let home_mod_infos = eltsUDFM (hsc_HPT hsc_env)+            linkables = map (expectJust "bkp link" . hm_linkable)+                      . filter ((==HsSrcFile) . mi_hsc_src . hm_iface)+                      $ home_mod_infos+            getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)+            obj_files = concatMap getOfiles linkables++        let compat_fs = (case cid of ComponentId fs -> fs)+            compat_pn = PackageName compat_fs++        return InstalledPackageInfo {+            -- Stub data+            abiHash = "",+            sourcePackageId = SourcePackageId compat_fs,+            packageName = compat_pn,+            packageVersion = makeVersion [0],+            unitId = toInstalledUnitId (thisPackage dflags),+            sourceLibName = Nothing,+            componentId = cid,+            instantiatedWith = insts,+            -- Slight inefficiency here haha+            exposedModules = map (\(m,n) -> (m,Just n)) mods,+            hiddenModules = [], -- TODO: doc only+            depends = case session of+                        -- Technically, we should state that we depend+                        -- on all the indefinite libraries we used to+                        -- typecheck this.  However, this field isn't+                        -- really used for anything, so we leave it+                        -- blank for now.+                        TcSession -> []+                        _ -> map (toInstalledUnitId . unwireUnitId dflags)+                                $ deps ++ [ moduleUnitId mod+                                          | (_, mod) <- insts+                                          , not (isHoleModule mod) ],+            abiDepends = [],+            ldOptions = case session of+                            TcSession -> []+                            _ -> obj_files,+            importDirs = [ hi_dir ],+            exposed = False,+            indefinite = case session of+                            TcSession -> True+                            _ -> False,+            -- nope+            hsLibraries = [],+            extraLibraries = [],+            extraGHCiLibraries = [],+            libraryDynDirs = [],+            libraryDirs = [],+            frameworks = [],+            frameworkDirs = [],+            ccOptions = [],+            includes = [],+            includeDirs = [],+            haddockInterfaces = [],+            haddockHTMLs = [],+            trusted = False+            }+++    addPackage conf+    case mb_old_eps of+        Just old_eps -> updateEpsGhc_ (const old_eps)+        _ -> return ()++compileExe :: LHsUnit HsComponentId -> BkpM ()+compileExe lunit = do+    msgUnitId mainUnitId+    let deps_w_rns = hsunitDeps False (unLoc lunit)+        deps = map fst deps_w_rns+        -- no renaming necessary+    forM_ (zip [1..] deps) $ \(i, dep) ->+        compileInclude (length deps) (i, dep)+    withBkpExeSession deps_w_rns $ do+        dflags <- getDynFlags+        mod_graph <- hsunitModuleGraph dflags (unLoc lunit)+        msg <- mkBackpackMsg+        ok <- load' LoadAllTargets (Just msg) mod_graph+        when (failed ok) (liftIO $ exitWith (ExitFailure 1))++addPackage :: GhcMonad m => PackageConfig -> m ()+addPackage pkg = do+    dflags0 <- GHC.getSessionDynFlags+    case pkgDatabase dflags0 of+        Nothing -> panic "addPackage: called too early"+        Just pkgs -> do let dflags = dflags0 { pkgDatabase =+                            Just (pkgs ++ [("(in memory " ++ showSDoc dflags0 (ppr (unitId pkg)) ++ ")", [pkg])]) }+                        _ <- GHC.setSessionDynFlags dflags+                        -- By this time, the global ref has probably already+                        -- been forced, in which case doing this isn't actually+                        -- going to do you any good.+                        -- dflags <- GHC.getSessionDynFlags+                        -- liftIO $ setUnsafeGlobalDynFlags dflags+                        return ()++-- Precondition: UnitId is NOT InstalledUnitId+compileInclude :: Int -> (Int, UnitId) -> BkpM ()+compileInclude n (i, uid) = do+    hsc_env <- getSession+    let dflags = hsc_dflags hsc_env+    msgInclude (i, n) uid+    -- Check if we've compiled it already+    case lookupPackage dflags uid of+        Nothing -> do+            case splitUnitIdInsts uid of+                (_, Just indef) ->+                    innerBkpM $ compileUnit (indefUnitIdComponentId indef)+                                            (indefUnitIdInsts indef)+                _ -> return ()+        Just _ -> return ()++-- ----------------------------------------------------------------------------+-- Backpack monad++-- | Backpack monad is a 'GhcMonad' which also maintains a little extra state+-- beyond the 'Session', c.f. 'BkpEnv'.+type BkpM = IOEnv BkpEnv++-- | Backpack environment.  NB: this has a 'Session' and not an 'HscEnv',+-- because we are going to update the 'HscEnv' as we go.+data BkpEnv+    = BkpEnv {+        -- | The session+        bkp_session :: Session,+        -- | The filename of the bkp file we're compiling+        bkp_filename :: FilePath,+        -- | Table of source units which we know how to compile+        bkp_table :: Map ComponentId (LHsUnit HsComponentId),+        -- | When a package we are compiling includes another package+        -- which has not been compiled, we bump the level and compile+        -- that.+        bkp_level :: Int+    }++-- Blah, to get rid of the default instance for IOEnv+-- TODO: just make a proper new monad for BkpM, rather than use IOEnv+instance {-# OVERLAPPING #-} HasDynFlags BkpM where+    getDynFlags = fmap hsc_dflags getSession++instance GhcMonad BkpM where+    getSession = do+        Session s <- fmap bkp_session getEnv+        readMutVar s+    setSession hsc_env = do+        Session s <- fmap bkp_session getEnv+        writeMutVar s hsc_env++-- | Get the current 'BkpEnv'.+getBkpEnv :: BkpM BkpEnv+getBkpEnv = getEnv++-- | Get the nesting level, when recursively compiling modules.+getBkpLevel :: BkpM Int+getBkpLevel = bkp_level `fmap` getBkpEnv++-- | Apply a function on 'DynFlags' on an 'HscEnv'+overHscDynFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv+overHscDynFlags f hsc_env = hsc_env { hsc_dflags = f (hsc_dflags hsc_env) }++-- | Run a 'BkpM' computation, with the nesting level bumped one.+innerBkpM :: BkpM a -> BkpM a+innerBkpM do_this = do+    -- NB: withTempSession mutates, so we don't have to worry+    -- about bkp_session being stale.+    updEnv (\env -> env { bkp_level = bkp_level env + 1 }) do_this++-- | Update the EPS from a 'GhcMonad'. TODO move to appropriate library spot.+updateEpsGhc_ :: GhcMonad m => (ExternalPackageState -> ExternalPackageState) -> m ()+updateEpsGhc_ f = do+    hsc_env <- getSession+    liftIO $ atomicModifyIORef' (hsc_EPS hsc_env) (\x -> (f x, ()))++-- | Get the EPS from a 'GhcMonad'.+getEpsGhc :: GhcMonad m => m ExternalPackageState+getEpsGhc = do+    hsc_env <- getSession+    liftIO $ readIORef (hsc_EPS hsc_env)++-- | Run 'BkpM' in 'Ghc'.+initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a+initBkpM file bkp m = do+    reifyGhc $ \session -> do+    let env = BkpEnv {+                    bkp_session = session,+                    bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp],+                    bkp_filename = file,+                    bkp_level = 0+                }+    runIOEnv env m++-- ----------------------------------------------------------------------------+-- Messaging++-- | Print a compilation progress message, but with indentation according+-- to @level@ (for nested compilation).+backpackProgressMsg :: Int -> DynFlags -> String -> IO ()+backpackProgressMsg level dflags msg =+    compilationProgressMsg dflags $ replicate (level * 2) ' ' ++ msg++-- | Creates a 'Messager' for Backpack compilation; this is basically+-- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which+-- handles indentation.+mkBackpackMsg :: BkpM Messager+mkBackpackMsg = do+    level <- getBkpLevel+    return $ \hsc_env mod_index recomp mod_summary ->+      let dflags = hsc_dflags hsc_env+          showMsg msg reason =+            backpackProgressMsg level dflags $+                showModuleIndex mod_index +++                msg ++ showModMsg dflags (hscTarget dflags)+                                  (recompileRequired recomp) mod_summary+                    ++ reason+      in case recomp of+            MustCompile -> showMsg "Compiling " ""+            UpToDate+                | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping  " ""+                | otherwise -> return ()+            RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")++-- | 'PprStyle' for Backpack messages; here we usually want the module to+-- be qualified (so we can tell how it was instantiated.) But we try not+-- to qualify packages so we can use simple names for them.+backpackStyle :: DynFlags -> PprStyle+backpackStyle dflags =+    mkUserStyle dflags+        (QueryQualify neverQualifyNames+                      alwaysQualifyModules+                      neverQualifyPackages) AllTheWay++-- | Message when we initially process a Backpack unit.+msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM ()+msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do+    dflags <- getDynFlags+    level <- getBkpLevel+    liftIO . backpackProgressMsg level dflags+        $ showModuleIndex (i, n) ++ "Processing " ++ unpackFS fs_pn++-- | Message when we instantiate a Backpack unit.+msgUnitId :: UnitId -> BkpM ()+msgUnitId pk = do+    dflags <- getDynFlags+    level <- getBkpLevel+    liftIO . backpackProgressMsg level dflags+        $ "Instantiating " ++ renderWithStyle dflags (ppr pk)+                                (backpackStyle dflags)++-- | Message when we include a Backpack unit.+msgInclude :: (Int,Int) -> UnitId -> BkpM ()+msgInclude (i,n) uid = do+    dflags <- getDynFlags+    level <- getBkpLevel+    liftIO . backpackProgressMsg level dflags+        $ showModuleIndex (i, n) ++ "Including " +++          renderWithStyle dflags (ppr uid) (backpackStyle dflags)++-- ----------------------------------------------------------------------------+-- Conversion from PackageName to HsComponentId++type PackageNameMap a = Map PackageName a++-- For now, something really simple, since we're not actually going+-- to use this for anything+unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId)+unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })+    = (pn, HsComponentId pn (ComponentId fs))++packageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId+packageNameMap units = Map.fromList (map unitDefines units)++renameHsUnits :: DynFlags -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]+renameHsUnits dflags m units = map (fmap renameHsUnit) units+  where++    renamePackageName :: PackageName -> HsComponentId+    renamePackageName pn =+        case Map.lookup pn m of+            Nothing ->+                case lookupPackageName dflags pn of+                    Nothing -> error "no package name"+                    Just cid -> HsComponentId pn cid+            Just hscid -> hscid++    renameHsUnit :: HsUnit PackageName -> HsUnit HsComponentId+    renameHsUnit u =+        HsUnit {+            hsunitName = fmap renamePackageName (hsunitName u),+            hsunitBody = map (fmap renameHsUnitDecl) (hsunitBody u)+        }++    renameHsUnitDecl :: HsUnitDecl PackageName -> HsUnitDecl HsComponentId+    renameHsUnitDecl (DeclD a b c) = DeclD a b c+    renameHsUnitDecl (IncludeD idecl) =+        IncludeD IncludeDecl {+            idUnitId = fmap renameHsUnitId (idUnitId idecl),+            idModRenaming = idModRenaming idecl,+            idSignatureInclude = idSignatureInclude idecl+        }++    renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId+    renameHsUnitId (HsUnitId ln subst)+        = HsUnitId (fmap renamePackageName ln) (map (fmap renameHsModuleSubst) subst)++    renameHsModuleSubst :: HsModuleSubst PackageName -> HsModuleSubst HsComponentId+    renameHsModuleSubst (lk, lm)+        = (lk, fmap renameHsModuleId lm)++    renameHsModuleId :: HsModuleId PackageName -> HsModuleId HsComponentId+    renameHsModuleId (HsModuleVar lm) = HsModuleVar lm+    renameHsModuleId (HsModuleId luid lm) = HsModuleId (fmap renameHsUnitId luid) lm++convertHsUnitId :: HsUnitId HsComponentId -> UnitId+convertHsUnitId (HsUnitId (L _ hscid) subst)+    = newUnitId (hsComponentId hscid) (map (convertHsModuleSubst . unLoc) subst)++convertHsModuleSubst :: HsModuleSubst HsComponentId -> (ModuleName, Module)+convertHsModuleSubst (L _ modname, L _ m) = (modname, convertHsModuleId m)++convertHsModuleId :: HsModuleId HsComponentId -> Module+convertHsModuleId (HsModuleVar (L _ modname)) = mkHoleModule modname+convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsUnitId hsuid) modname++++{-+************************************************************************+*                                                                      *+                        Module graph construction+*                                                                      *+************************************************************************+-}++-- | This is our version of GhcMake.downsweep, but with a few modifications:+--+--  1. Every module is required to be mentioned, so we don't do any funny+--     business with targets or recursively grabbing dependencies.  (We+--     could support this in principle).+--  2. We support inline modules, whose summary we have to synthesize ourself.+--+-- We don't bother trying to support GhcMake for now, it's more trouble+-- than it's worth for inline modules.+hsunitModuleGraph :: DynFlags -> HsUnit HsComponentId -> BkpM ModuleGraph+hsunitModuleGraph dflags unit = do+    let decls = hsunitBody unit+        pn = hsPackageName (unLoc (hsunitName unit))++    --  1. Create a HsSrcFile/HsigFile summary for every+    --  explicitly mentioned module/signature.+    let get_decl (L _ (DeclD dt lmodname mb_hsmod)) = do+          let hsc_src = case dt of+                          ModuleD    -> HsSrcFile+                          SignatureD -> HsigFile+          Just `fmap` summariseDecl pn hsc_src lmodname mb_hsmod+        get_decl _ = return Nothing+    nodes <- catMaybes `fmap` mapM get_decl decls++    --  2. For each hole which does not already have an hsig file,+    --  create an "empty" hsig file to induce compilation for the+    --  requirement.+    let node_map = Map.fromList [ ((ms_mod_name n, ms_hsc_src n == HsigFile), n)+                                | n <- nodes ]+    req_nodes <- fmap catMaybes . forM (thisUnitIdInsts dflags) $ \(mod_name, _) ->+        let has_local = Map.member (mod_name, True) node_map+        in if has_local+            then return Nothing+            else fmap Just $ summariseRequirement pn mod_name++    -- 3. Return the kaboodle+    return (nodes ++ req_nodes)++summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary+summariseRequirement pn mod_name = do+    hsc_env <- getSession+    let dflags = hsc_dflags hsc_env++    let PackageName pn_fs = pn+    location <- liftIO $ mkHomeModLocation2 dflags mod_name+                 (unpackFS pn_fs </> moduleNameSlashes mod_name) "hsig"++    env <- getBkpEnv+    time <- liftIO $ getModificationUTCTime (bkp_filename env)+    hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)+    let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1)++    mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location++    extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name++    return ModSummary {+        ms_mod = mod,+        ms_hsc_src = HsigFile,+        ms_location = location,+        ms_hs_date = time,+        ms_obj_date = Nothing,+        ms_iface_date = hi_timestamp,+        ms_srcimps = [],+        ms_textual_imps = extra_sig_imports,+        ms_parsed_mod = Just (HsParsedModule {+                hpm_module = L loc (HsModule {+                        hsmodName = Just (L loc mod_name),+                        hsmodExports = Nothing,+                        hsmodImports = [],+                        hsmodDecls = [],+                        hsmodDeprecMessage = Nothing,+                        hsmodHaddockModHeader = Nothing+                    }),+                hpm_src_files = [],+                hpm_annotations = (Map.empty, Map.empty)+            }),+        ms_hspp_file = "", -- none, it came inline+        ms_hspp_opts = dflags,+        ms_hspp_buf = Nothing+        }++summariseDecl :: PackageName+              -> HscSource+              -> Located ModuleName+              -> Maybe (Located (HsModule RdrName))+              -> BkpM ModSummary+summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod+summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing+    = do hsc_env <- getSession+         let dflags = hsc_dflags hsc_env+         -- TODO: this looks for modules in the wrong place+         r <- liftIO $ summariseModule hsc_env+                         Map.empty -- GHC API recomp not supported+                         (hscSourceToIsBoot hsc_src)+                         lmodname+                         True -- Target lets you disallow, but not here+                         Nothing -- GHC API buffer support not supported+                         [] -- No exclusions+         case r of+            Nothing -> throwOneError (mkPlainErrMsg dflags loc (text "module" <+> ppr modname <+> text "was not found"))+            Just (Left err) -> throwOneError err+            Just (Right summary) -> return summary++-- | Up until now, GHC has assumed a single compilation target per source file.+-- Backpack files with inline modules break this model, since a single file+-- may generate multiple output files.  How do we decide to name these files?+-- Should there only be one output file? This function our current heuristic,+-- which is we make a "fake" module and use that.+hsModuleToModSummary :: PackageName+                     -> HscSource+                     -> ModuleName+                     -> Located (HsModule RdrName)+                     -> BkpM ModSummary+hsModuleToModSummary pn hsc_src modname+                     hsmod = do+    let imps = hsmodImports (unLoc hsmod)+        loc  = getLoc hsmod+    hsc_env <- getSession+    -- Sort of the same deal as in DriverPipeline's getLocation+    -- Use the PACKAGE NAME to find the location+    let PackageName unit_fs = pn+        dflags = hsc_dflags hsc_env+    -- Unfortunately, we have to define a "fake" location in+    -- order to appease the various code which uses the file+    -- name to figure out where to put, e.g. object files.+    -- To add insult to injury, we don't even actually use+    -- these filenames to figure out where the hi files go.+    -- A travesty!+    location0 <- liftIO $ mkHomeModLocation2 dflags modname+                             (unpackFS unit_fs </>+                              moduleNameSlashes modname)+                              (case hsc_src of+                                HsigFile -> "hsig"+                                HsBootFile -> "hs-boot"+                                HsSrcFile -> "hs")+    -- DANGEROUS: bootifying can POISON the module finder cache+    let location = case hsc_src of+                        HsBootFile -> addBootSuffixLocn location0+                        _ -> location0+    -- This duplicates a pile of logic in GhcMake+    env <- getBkpEnv+    time <- liftIO $ getModificationUTCTime (bkp_filename env)+    hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)++    -- Also copied from 'getImports'+    let (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps++             -- GHC.Prim doesn't exist physically, so don't go looking for it.+        ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)+                               ord_idecls++        implicit_prelude = xopt LangExt.ImplicitPrelude dflags+        implicit_imports = mkPrelImports modname loc+                                         implicit_prelude imps+        convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i)++    extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname++    let normal_imports = map convImport (implicit_imports ++ ordinary_imps)+    required_by_imports <- liftIO $ implicitRequirements hsc_env normal_imports++    -- So that Finder can find it, even though it doesn't exist...+    this_mod <- liftIO $ addHomeModuleToFinder hsc_env modname location+    return ModSummary {+            ms_mod = this_mod,+            ms_hsc_src = hsc_src,+            ms_location = location,+            ms_hspp_file = (case hiDir dflags of+                            Nothing -> ""+                            Just d -> d) </> ".." </> moduleNameSlashes modname <.> "hi",+            ms_hspp_opts = dflags,+            ms_hspp_buf = Nothing,+            ms_srcimps = map convImport src_idecls,+            ms_textual_imps = normal_imports+                           -- We have to do something special here:+                           -- due to merging, requirements may end up with+                           -- extra imports+                           ++ extra_sig_imports+                           ++ required_by_imports,+            -- This is our hack to get the parse tree to the right spot+            ms_parsed_mod = Just (HsParsedModule {+                    hpm_module = hsmod,+                    hpm_src_files = [], -- TODO if we preprocessed it+                    hpm_annotations = (Map.empty, Map.empty) -- BOGUS+                }),+            ms_hs_date = time,+            ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS+            ms_iface_date = hi_timestamp+        }++-- | Create a new, externally provided hashed unit id from+-- a hash.+newInstalledUnitId :: ComponentId -> Maybe FastString -> InstalledUnitId+newInstalledUnitId (ComponentId cid_fs) (Just fs)+    = InstalledUnitId (cid_fs `appendFS` mkFastString "+" `appendFS` fs)+newInstalledUnitId (ComponentId cid_fs) Nothing+    = InstalledUnitId cid_fs
+ backpack/NameShape.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE CPP #-}++module NameShape(+    NameShape(..),+    emptyNameShape,+    mkNameShape,+    extendNameShape,+    nameShapeExports,+    substNameShape,+    maybeSubstNameShape,+    ) where++#include "HsVersions.h"++import Outputable+import HscTypes+import Module+import UniqFM+import Avail+import FieldLabel++import Name+import NameEnv+import TcRnMonad+import Util+import IfaceEnv++import Control.Monad++-- Note [NameShape]+-- ~~~~~~~~~~~~~~~~+-- When we write a declaration in a signature, e.g., data T, we+-- ascribe to it a *name variable*, e.g., {m.T}.  This+-- name variable may be substituted with an actual original+-- name when the signature is implemented (or even if we+-- merge the signature with one which reexports this entity+-- from another module).++-- When we instantiate a signature m with a module M,+-- we also need to substitute over names.  To do so, we must+-- compute the *name substitution* induced by the *exports*+-- of the module in question.  A NameShape represents+-- such a name substitution for a single module instantiation.+-- The "shape" in the name comes from the fact that the computation+-- of a name substitution is essentially the *shaping pass* from+-- Backpack'14, but in a far more restricted form.++-- The name substitution for an export list is easy to explain.  If we are+-- filling the module variable <m>, given an export N of the form+-- M.n or {m'.n} (where n is an OccName), the induced name+-- substitution is from {m.n} to N.  So, for example, if we have+-- A=impl:B, and the exports of impl:B are impl:B.f and+-- impl:C.g, then our name substitution is {A.f} to impl:B.f+-- and {A.g} to impl:C.g+++++-- The 'NameShape' type is defined in TcRnTypes, because TcRnTypes+-- needs to refer to NameShape, and having TcRnTypes import+-- NameShape (even by SOURCE) would cause a large number of+-- modules to be pulled into the DynFlags cycle.+{-+data NameShape = NameShape {+        ns_mod_name :: ModuleName,+        ns_exports :: [AvailInfo],+        ns_map :: OccEnv Name+    }+-}++-- NB: substitution functions need 'HscEnv' since they need the name cache+-- to allocate new names if we change the 'Module' of a 'Name'++-- | Create an empty 'NameShape' (i.e., the renaming that+-- would occur with an implementing module with no exports)+-- for a specific hole @mod_name@.+emptyNameShape :: ModuleName -> NameShape+emptyNameShape mod_name = NameShape mod_name [] emptyOccEnv++-- | Create a 'NameShape' corresponding to an implementing+-- module for the hole @mod_name@ that exports a list of 'AvailInfo's.+mkNameShape :: ModuleName -> [AvailInfo] -> NameShape+mkNameShape mod_name as =+    NameShape mod_name as $ mkOccEnv $ do+        a <- as+        n <- availName a : availNamesWithSelectors a+        return (occName n, n)++-- | Given an existing 'NameShape', merge it with a list of 'AvailInfo's+-- with Backpack style mix-in linking.  This is used solely when merging+-- signatures together: we successively merge the exports of each+-- signature until we have the final, full exports of the merged signature.+--+-- What makes this operation nontrivial is what we are supposed to do when+-- we want to merge in an export for M.T when we already have an existing+-- export {H.T}.  What should happen in this case is that {H.T} should be+-- unified with @M.T@: we've determined a more *precise* identity for the+-- export at 'OccName' @T@.+--+-- Note that we don't do unrestricted unification: only name holes from+-- @ns_mod_name ns@ are flexible.  This is because we have a much more+-- restricted notion of shaping than in Backpack'14: we do shaping+-- *as* we do type-checking.  Thus, once we shape a signature, its+-- exports are *final* and we're not allowed to refine them further,+extendNameShape :: HscEnv -> NameShape -> [AvailInfo] -> IO (Either SDoc NameShape)+extendNameShape hsc_env ns as =+    case uAvailInfos (ns_mod_name ns) (ns_exports ns) as of+        Left err -> return (Left err)+        Right nsubst -> do+            as1 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) (ns_exports ns)+            as2 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) as+            let new_avails = mergeAvails as1 as2+            return . Right $ ns {+                ns_exports = new_avails,+                -- TODO: stop repeatedly rebuilding the OccEnv+                ns_map = mkOccEnv $ do+                            a <- new_avails+                            n <- availName a : availNames a+                            return (occName n, n)+                }++-- | The export list associated with this 'NameShape' (i.e., what+-- the exports of an implementing module which induces this 'NameShape'+-- would be.)+nameShapeExports :: NameShape -> [AvailInfo]+nameShapeExports = ns_exports++-- | Given a 'Name', substitute it according to the 'NameShape' implied+-- substitution, i.e. map @{A.T}@ to @M.T@, if the implementing module+-- exports @M.T@.+substNameShape :: NameShape -> Name -> Name+substNameShape ns n | nameModule n == ns_module ns+                    , Just n' <- lookupOccEnv (ns_map ns) (occName n)+                    = n'+                    | otherwise+                    = n++-- | Like 'substNameShape', but returns @Nothing@ if no substitution+-- works.+maybeSubstNameShape :: NameShape -> Name -> Maybe Name+maybeSubstNameShape ns n+    | nameModule n == ns_module ns+    = lookupOccEnv (ns_map ns) (occName n)+    | otherwise+    = Nothing++-- | The 'Module' of any 'Name's a 'NameShape' has action over.+ns_module :: NameShape -> Module+ns_module = mkHoleModule . ns_mod_name++{-+************************************************************************+*                                                                      *+                        Name substitutions+*                                                                      *+************************************************************************+-}++-- | Substitution on @{A.T}@.  We enforce the invariant that the+-- 'nameModule' of keys of this map have 'moduleUnitId' @hole@+-- (meaning that if we have a hole substitution, the keys of the map+-- are never affected.)  Alternately, this is isomorphic to+-- @Map ('ModuleName', 'OccName') 'Name'@.+type ShNameSubst = NameEnv Name++-- NB: In this module, we actually only ever construct 'ShNameSubst'+-- at a single 'ModuleName'.  But 'ShNameSubst' is more convenient to+-- work with.++-- | Substitute names in a 'Name'.+substName :: ShNameSubst -> Name -> Name+substName env n | Just n' <- lookupNameEnv env n = n'+                | otherwise                      = n++-- | Substitute names in an 'AvailInfo'.  This has special behavior+-- for type constructors, where it is sufficient to substitute the 'availName'+-- to induce a substitution on 'availNames'.+substNameAvailInfo :: HscEnv -> ShNameSubst -> AvailInfo -> IO AvailInfo+substNameAvailInfo _ env (Avail n) = return (Avail (substName env n))+substNameAvailInfo hsc_env env (AvailTC n ns fs) =+    let mb_mod = fmap nameModule (lookupNameEnv env n)+    in AvailTC (substName env n)+        <$> mapM (initIfaceLoad hsc_env . setNameModule mb_mod) ns+        <*> mapM (setNameFieldSelector hsc_env mb_mod) fs++-- | Set the 'Module' of a 'FieldSelector'+setNameFieldSelector :: HscEnv -> Maybe Module -> FieldLabel -> IO FieldLabel+setNameFieldSelector _ Nothing f = return f+setNameFieldSelector hsc_env mb_mod (FieldLabel l b sel) = do+    sel' <- initIfaceLoad hsc_env $ setNameModule mb_mod sel+    return (FieldLabel l b sel')++{-+************************************************************************+*                                                                      *+                        AvailInfo merging+*                                                                      *+************************************************************************+-}++-- | Merges to 'AvailInfo' lists together, assuming the 'AvailInfo's have+-- already been unified ('uAvailInfos').+mergeAvails :: [AvailInfo] -> [AvailInfo] -> [AvailInfo]+mergeAvails as1 as2 =+    let mkNE as = mkNameEnv [(availName a, a) | a <- as]+    in nameEnvElts (plusNameEnv_C plusAvail (mkNE as1) (mkNE as2))++{-+************************************************************************+*                                                                      *+                        AvailInfo unification+*                                                                      *+************************************************************************+-}++-- | Unify two lists of 'AvailInfo's, given an existing substitution @subst@,+-- with only name holes from @flexi@ unifiable (all other name holes rigid.)+uAvailInfos :: ModuleName -> [AvailInfo] -> [AvailInfo] -> Either SDoc ShNameSubst+uAvailInfos flexi as1 as2 = -- pprTrace "uAvailInfos" (ppr as1 $$ ppr as2) $+    let mkOE as = listToUFM $ do a <- as+                                 n <- availNames a+                                 return (nameOccName n, a)+    in foldM (\subst (a1, a2) -> uAvailInfo flexi subst a1 a2) emptyNameEnv+             (eltsUFM (intersectUFM_C (,) (mkOE as1) (mkOE as2)))+             -- Edward: I have to say, this is pretty clever.++-- | Unify two 'AvailInfo's, given an existing substitution @subst@,+-- with only name holes from @flexi@ unifiable (all other name holes rigid.)+uAvailInfo :: ModuleName -> ShNameSubst -> AvailInfo -> AvailInfo+           -> Either SDoc ShNameSubst+uAvailInfo flexi subst (Avail n1) (Avail n2) = uName flexi subst n1 n2+uAvailInfo flexi subst (AvailTC n1 _ _) (AvailTC n2 _ _) = uName flexi subst n1 n2+uAvailInfo _ _ a1 a2 = Left $ text "While merging export lists, could not combine"+                           <+> ppr a1 <+> text "with" <+> ppr a2+                           <+> parens (text "one is a type, the other is a plain identifier")++-- | Unify two 'Name's, given an existing substitution @subst@,+-- with only name holes from @flexi@ unifiable (all other name holes rigid.)+uName :: ModuleName -> ShNameSubst -> Name -> Name -> Either SDoc ShNameSubst+uName flexi subst n1 n2+    | n1 == n2      = Right subst+    | isFlexi n1    = uHoleName flexi subst n1 n2+    | isFlexi n2    = uHoleName flexi subst n2 n1+    | otherwise     = Left (text "While merging export lists, could not unify"+                         <+> ppr n1 <+> text "with" <+> ppr n2 $$ extra)+  where+    isFlexi n = isHoleName n && moduleName (nameModule n) == flexi+    extra | isHoleName n1 || isHoleName n2+          = text "Neither name variable originates from the current signature."+          | otherwise+          = empty++-- | Unify a name @h@ which 'isHoleName' with another name, given an existing+-- substitution @subst@, with only name holes from @flexi@ unifiable (all+-- other name holes rigid.)+uHoleName :: ModuleName -> ShNameSubst -> Name {- hole name -} -> Name+          -> Either SDoc ShNameSubst+uHoleName flexi subst h n =+    ASSERT( isHoleName h )+    case lookupNameEnv subst h of+        Just n' -> uName flexi subst n' n+                -- Do a quick check if the other name is substituted.+        Nothing | Just n' <- lookupNameEnv subst n ->+                    ASSERT( isHoleName n ) uName flexi subst h n'+                | otherwise ->+                    Right (extendNameEnv subst h n)
+ backpack/RnModIface.hs view
@@ -0,0 +1,707 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}++-- | This module implements interface renaming, which is+-- used to rewrite interface files on the fly when we+-- are doing indefinite typechecking and need instantiations+-- of modules which do not necessarily exist yet.++module RnModIface(+    rnModIface,+    rnModExports,+    tcRnModIface,+    tcRnModExports,+    ) where++#include "HsVersions.h"++import SrcLoc+import Outputable+import HscTypes+import Module+import UniqFM+import Avail+import IfaceSyn+import FieldLabel+import Var+import ErrUtils++import Name+import TcRnMonad+import Util+import Fingerprint+import BasicTypes++-- a bit vexing+import {-# SOURCE #-} LoadIface+import DynFlags++import qualified Data.Traversable as T++import Bag+import Data.IORef+import NameShape+import IfaceEnv++tcRnMsgMaybe :: IO (Either ErrorMessages a) -> TcM a+tcRnMsgMaybe do_this = do+    r <- liftIO $ do_this+    case r of+        Left errs -> do+            addMessages (emptyBag, errs)+            failM+        Right x -> return x++tcRnModIface :: [(ModuleName, Module)] -> Maybe NameShape -> ModIface -> TcM ModIface+tcRnModIface x y z = do+    hsc_env <- getTopEnv+    tcRnMsgMaybe $ rnModIface hsc_env x y z++tcRnModExports :: [(ModuleName, Module)] -> ModIface -> TcM [AvailInfo]+tcRnModExports x y = do+    hsc_env <- getTopEnv+    tcRnMsgMaybe $ rnModExports hsc_env x y++failWithRn :: SDoc -> ShIfM a+failWithRn doc = do+    errs_var <- fmap sh_if_errs getGblEnv+    dflags <- getDynFlags+    errs <- readTcRef errs_var+    -- TODO: maybe associate this with a source location?+    writeTcRef errs_var (errs `snocBag` mkPlainErrMsg dflags noSrcSpan doc)+    failM++-- | What we have is a generalized ModIface, which corresponds to+-- a module that looks like p[A=<A>]:B.  We need a *specific* ModIface, e.g.+-- p[A=q():A]:B (or maybe even p[A=<B>]:B) which we load+-- up (either to merge it, or to just use during typechecking).+--+-- Suppose we have:+--+--  p[A=<A>]:M  ==>  p[A=q():A]:M+--+-- Substitute all occurrences of <A> with q():A (renameHoleModule).+-- Then, for any Name of form {A.T}, replace the Name with+-- the Name according to the exports of the implementing module.+-- This works even for p[A=<B>]:M, since we just read in the+-- exports of B.hi, which is assumed to be ready now.+--+-- This function takes an optional 'NameShape', which can be used+-- to further refine the identities in this interface: suppose+-- we read a declaration for {H.T} but we actually know that this+-- should be Foo.T; then we'll also rename this (this is used+-- when loading an interface to merge it into a requirement.)+rnModIface :: HscEnv -> [(ModuleName, Module)] -> Maybe NameShape+           -> ModIface -> IO (Either ErrorMessages ModIface)+rnModIface hsc_env insts nsubst iface = do+    initRnIface hsc_env iface insts nsubst $ do+        mod <- rnModule (mi_module iface)+        sig_of <- case mi_sig_of iface of+                    Nothing -> return Nothing+                    Just x  -> fmap Just (rnModule x)+        exports <- mapM rnAvailInfo (mi_exports iface)+        decls <- mapM rnIfaceDecl' (mi_decls iface)+        insts <- mapM rnIfaceClsInst (mi_insts iface)+        fams <- mapM rnIfaceFamInst (mi_fam_insts iface)+        deps <- rnDependencies (mi_deps iface)+        -- TODO:+        -- mi_rules+        -- mi_vect_info (LOW PRIORITY)+        return iface { mi_module = mod+                     , mi_sig_of = sig_of+                     , mi_insts = insts+                     , mi_fam_insts = fams+                     , mi_exports = exports+                     , mi_decls = decls+                     , mi_deps = deps }++-- | Rename just the exports of a 'ModIface'.  Useful when we're doing+-- shaping prior to signature merging.+rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO (Either ErrorMessages [AvailInfo])+rnModExports hsc_env insts iface+    = initRnIface hsc_env iface insts Nothing+    $ mapM rnAvailInfo (mi_exports iface)++rnDependencies :: Rename Dependencies+rnDependencies deps = do+    orphs  <- rnDepModules dep_orphs deps+    finsts <- rnDepModules dep_finsts deps+    return deps { dep_orphs = orphs, dep_finsts = finsts }++rnDepModules :: (Dependencies -> [Module]) -> Dependencies -> ShIfM [Module]+rnDepModules sel deps = do+    hsc_env <- getTopEnv+    hmap <- getHoleSubst+    -- NB: It's not necessary to test if we're doing signature renaming,+    -- because ModIface will never contain module reference for itself+    -- in these dependencies.+    fmap (nubSort . concat) . T.forM (sel deps) $ \mod -> do+        dflags <- getDynFlags+        let mod' = renameHoleModule dflags hmap mod+        iface <- liftIO . initIfaceCheck (text "rnDepModule") hsc_env+                        $ loadSysInterface (text "rnDepModule") mod'+        return (mod' : sel (mi_deps iface))++{-+************************************************************************+*                                                                      *+                        ModIface substitution+*                                                                      *+************************************************************************+-}++-- | Run a computation in the 'ShIfM' monad.+initRnIface :: HscEnv -> ModIface -> [(ModuleName, Module)] -> Maybe NameShape+            -> ShIfM a -> IO (Either ErrorMessages a)+initRnIface hsc_env iface insts nsubst do_this = do+    errs_var <- newIORef emptyBag+    let dflags = hsc_dflags hsc_env+        hsubst = listToUFM insts+        rn_mod = renameHoleModule dflags hsubst+        env = ShIfEnv {+            sh_if_module = rn_mod (mi_module iface),+            sh_if_semantic_module = rn_mod (mi_semantic_module iface),+            sh_if_hole_subst = listToUFM insts,+            sh_if_shape = nsubst,+            sh_if_errs = errs_var+        }+    -- Modeled off of 'initTc'+    res <- initTcRnIf 'c' hsc_env env () $ tryM do_this+    msgs <- readIORef errs_var+    case res of+        Left _                          -> return (Left msgs)+        Right r | not (isEmptyBag msgs) -> return (Left msgs)+                | otherwise             -> return (Right r)++-- | Environment for 'ShIfM' monads.+data ShIfEnv = ShIfEnv {+        -- What we are renaming the ModIface to.  It assumed that+        -- the original mi_module of the ModIface is+        -- @generalizeModule (mi_module iface)@.+        sh_if_module :: Module,+        -- The semantic module that we are renaming to+        sh_if_semantic_module :: Module,+        -- Cached hole substitution, e.g.+        -- @sh_if_hole_subst == listToUFM . unitIdInsts . moduleUnitId . sh_if_module@+        sh_if_hole_subst :: ShHoleSubst,+        -- An optional name substitution to be applied when renaming+        -- the names in the interface.  If this is 'Nothing', then+        -- we just load the target interface and look at the export+        -- list to determine the renaming.+        sh_if_shape :: Maybe NameShape,+        -- Mutable reference to keep track of errors (similar to 'tcl_errs')+        sh_if_errs :: IORef ErrorMessages+    }++getHoleSubst :: ShIfM ShHoleSubst+getHoleSubst = fmap sh_if_hole_subst getGblEnv++type ShIfM = TcRnIf ShIfEnv ()+type Rename a = a -> ShIfM a+++rnModule :: Rename Module+rnModule mod = do+    hmap <- getHoleSubst+    dflags <- getDynFlags+    return (renameHoleModule dflags hmap mod)++rnAvailInfo :: Rename AvailInfo+rnAvailInfo (Avail n) = Avail <$> rnIfaceGlobal n+rnAvailInfo (AvailTC n ns fs) = do+    -- Why don't we rnIfaceGlobal the availName itself?  It may not+    -- actually be exported by the module it putatively is from, in+    -- which case we won't be able to tell what the name actually+    -- is.  But for the availNames they MUST be exported, so they+    -- will rename fine.+    ns' <- mapM rnIfaceGlobal ns+    fs' <- mapM rnFieldLabel fs+    case ns' ++ map flSelector fs' of+        [] -> panic "rnAvailInfoEmpty AvailInfo"+        (rep:rest) -> ASSERT2( all ((== nameModule rep) . nameModule) rest, ppr rep $$ hcat (map ppr rest) ) do+                         n' <- setNameModule (Just (nameModule rep)) n+                         return (AvailTC n' ns' fs')++rnFieldLabel :: Rename FieldLabel+rnFieldLabel (FieldLabel l b sel) = do+    sel' <- rnIfaceGlobal sel+    return (FieldLabel l b sel')+++++-- | The key function.  This gets called on every Name embedded+-- inside a ModIface.  Our job is to take a Name from some+-- generalized unit ID p[A=<A>, B=<B>], and change+-- it to the correct name for a (partially) instantiated unit+-- ID, e.g. p[A=q[]:A, B=<B>].+--+-- There are two important things to do:+--+-- If a hole is substituted with a real module implementation,+-- we need to look at that actual implementation to determine what+-- the true identity of this name should be.  We'll do this by+-- loading that module's interface and looking at the mi_exports.+--+-- However, there is one special exception: when we are loading+-- the interface of a requirement.  In this case, we may not have+-- the "implementing" interface, because we are reading this+-- interface precisely to "merge it in".+--+--     External case:+--         p[A=<B>]:A (and thisUnitId is something else)+--     We are loading this in order to determine B.hi!  So+--     don't load B.hi to find the exports.+--+--     Local case:+--         p[A=<A>]:A (and thisUnitId is p[A=<A>])+--     This should not happen, because the rename is not necessary+--     in this case, but if it does we shouldn't load A.hi!+--+-- Compare me with 'tcIfaceGlobal'!++-- In effect, this function needs compute the name substitution on the+-- fly.  What it has is the name that we would like to substitute.+-- If the name is not a hole name {M.x} (e.g. isHoleModule) then+-- no renaming can take place (although the inner hole structure must+-- be updated to account for the hole module renaming.)+rnIfaceGlobal :: Name -> ShIfM Name+rnIfaceGlobal n = do+    hsc_env <- getTopEnv+    let dflags = hsc_dflags hsc_env+    iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv+    mb_nsubst <- fmap sh_if_shape getGblEnv+    hmap <- getHoleSubst+    let m = nameModule n+        m' = renameHoleModule dflags hmap m+    case () of+       -- Did we encounter {A.T} while renaming p[A=<B>]:A? If so,+       -- do NOT assume B.hi is available.+       -- In this case, rename {A.T} to {B.T} but don't look up exports.+     _ | m' == iface_semantic_mod+       , isHoleModule m'+      -- NB: this could be Nothing for computeExports, we have+      -- nothing to say.+      -> do n' <- setNameModule (Just m') n+            case mb_nsubst of+                Nothing -> return n'+                Just nsubst ->+                    case maybeSubstNameShape nsubst n' of+                        -- TODO: would love to have context+                        -- TODO: This will give an unpleasant message if n'+                        -- is a constructor; then we'll suggest adding T+                        -- but it won't work.+                        Nothing -> failWithRn $ vcat [+                            text "The identifier" <+> ppr (occName n') <+>+                                text "does not exist in the local signature.",+                            parens (text "Try adding it to the export list of the hsig file.")+                            ]+                        Just n'' -> return n''+       -- Fastpath: we are renaming p[H=<H>]:A.T, in which case the+       -- export list is irrelevant.+       | not (isHoleModule m)+      -> setNameModule (Just m') n+       -- The substitution was from <A> to p[]:A.+       -- But this does not mean {A.T} goes to p[]:A.T:+       -- p[]:A may reexport T from somewhere else.  Do the name+       -- substitution.  Furthermore, we need+       -- to make sure we pick the accurate name NOW,+       -- or we might accidentally reject a merge.+       | otherwise+      -> do -- Make sure we look up the local interface if substitution+            -- went from <A> to <B>.+            let m'' = if isHoleModule m'+                        -- Pull out the local guy!!+                        then mkModule (thisPackage dflags) (moduleName m')+                        else m'+            iface <- liftIO . initIfaceCheck (text "rnIfaceGlobal") hsc_env+                            $ loadSysInterface (text "rnIfaceGlobal") m''+            let nsubst = mkNameShape (moduleName m) (mi_exports iface)+            case maybeSubstNameShape nsubst n of+                Nothing -> failWithRn $ vcat [+                    text "The identifier" <+> ppr (occName n) <+>+                        -- NB: report m' because it's more user-friendly+                        text "does not exist in the signature for" <+> ppr m',+                    parens (text "Try adding it to the export list in that hsig file.")+                    ]+                Just n' -> return n'++-- | Rename an implicit name, e.g., a DFun or coercion axiom.+-- Here is where we ensure that DFuns have the correct module as described in+-- Note [rnIfaceNeverExported].+rnIfaceNeverExported :: Name -> ShIfM Name+rnIfaceNeverExported name = do+    hmap <- getHoleSubst+    dflags <- getDynFlags+    iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv+    let m = renameHoleModule dflags hmap $ nameModule name+    -- Doublecheck that this DFun/coercion axiom was, indeed, locally defined.+    MASSERT2( iface_semantic_mod == m, ppr iface_semantic_mod <+> ppr m )+    setNameModule (Just m) name++-- Note [rnIfaceNeverExported]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- For the high-level overview, see+-- Note [Handling never-exported TyThings under Backpack]+--+-- When we see a reference to an entity that was defined in a signature,+-- 'rnIfaceGlobal' relies on the identifier in question being part of the+-- exports of the implementing 'ModIface', so that we can use the exports to+-- decide how to rename the identifier.  Unfortunately, references to 'DFun's+-- and 'CoAxiom's will run into trouble under this strategy, because they are+-- never exported.+--+-- Let us consider first what should happen in the absence of promotion.  In+-- this setting, a reference to a 'DFun' or a 'CoAxiom' can only occur inside+-- the signature *that is defining it* (as there are no Core terms in+-- typechecked-only interface files, there's no way for a reference to occur+-- besides from the defining 'ClsInst' or closed type family).  Thus,+-- it doesn't really matter what names we give the DFun/CoAxiom, as long+-- as it's consistent between the declaration site and the use site.+--+-- We have to make sure that these bogus names don't get propagated,+-- but it is fine: see Note [Signature merging DFuns] for the fixups+-- to the names we do before writing out the merged interface.+-- (It's even easier for instantiation, since the DFuns all get+-- dropped entirely; the instances are reexported implicitly.)+--+-- Unfortunately, this strategy is not enough in the presence of promotion+-- (see bug #13149), where modules which import the signature may make+-- reference to their coercions.  It's not altogether clear how to+-- fix this case, but it is definitely a bug!++-- PILES AND PILES OF BOILERPLATE++-- | Rename an 'IfaceClsInst', with special handling for an associated+-- dictionary function.+rnIfaceClsInst :: Rename IfaceClsInst+rnIfaceClsInst cls_inst = do+    n <- rnIfaceGlobal (ifInstCls cls_inst)+    tys <- mapM rnMaybeIfaceTyCon (ifInstTys cls_inst)++    dfun <- rnIfaceNeverExported (ifDFun cls_inst)+    return cls_inst { ifInstCls = n+                    , ifInstTys = tys+                    , ifDFun = dfun+                    }++rnMaybeIfaceTyCon :: Rename (Maybe IfaceTyCon)+rnMaybeIfaceTyCon Nothing = return Nothing+rnMaybeIfaceTyCon (Just tc) = Just <$> rnIfaceTyCon tc++rnIfaceFamInst :: Rename IfaceFamInst+rnIfaceFamInst d = do+    fam <- rnIfaceGlobal (ifFamInstFam d)+    tys <- mapM rnMaybeIfaceTyCon (ifFamInstTys d)+    axiom <- rnIfaceGlobal (ifFamInstAxiom d)+    return d { ifFamInstFam = fam, ifFamInstTys = tys, ifFamInstAxiom = axiom }++rnIfaceDecl' :: Rename (Fingerprint, IfaceDecl)+rnIfaceDecl' (fp, decl) = (,) fp <$> rnIfaceDecl decl++rnIfaceDecl :: Rename IfaceDecl+rnIfaceDecl d@IfaceId{} = do+            name <- case ifIdDetails d of+                      IfDFunId -> rnIfaceNeverExported (ifName d)+                      _ | isDefaultMethodOcc (occName (ifName d))+                        -> rnIfaceNeverExported (ifName d)+                      -- Typeable bindings. See Note [Grand plan for Typeable].+                      _ | isTypeableBindOcc (occName (ifName d))+                        -> rnIfaceNeverExported (ifName d)+                        | otherwise -> rnIfaceGlobal (ifName d)+            ty <- rnIfaceType (ifType d)+            details <- rnIfaceIdDetails (ifIdDetails d)+            info <- rnIfaceIdInfo (ifIdInfo d)+            return d { ifName = name+                     , ifType = ty+                     , ifIdDetails = details+                     , ifIdInfo = info+                     }+rnIfaceDecl d@IfaceData{} = do+            name <- rnIfaceGlobal (ifName d)+            binders <- mapM rnIfaceTyConBinder (ifBinders d)+            ctxt <- mapM rnIfaceType (ifCtxt d)+            cons <- rnIfaceConDecls (ifCons d)+            parent <- rnIfaceTyConParent (ifParent d)+            return d { ifName = name+                     , ifBinders = binders+                     , ifCtxt = ctxt+                     , ifCons = cons+                     , ifParent = parent+                     }+rnIfaceDecl d@IfaceSynonym{} = do+            name <- rnIfaceGlobal (ifName d)+            binders <- mapM rnIfaceTyConBinder (ifBinders d)+            syn_kind <- rnIfaceType (ifResKind d)+            syn_rhs <- rnIfaceType (ifSynRhs d)+            return d { ifName = name+                     , ifBinders = binders+                     , ifResKind = syn_kind+                     , ifSynRhs = syn_rhs+                     }+rnIfaceDecl d@IfaceFamily{} = do+            name <- rnIfaceGlobal (ifName d)+            binders <- mapM rnIfaceTyConBinder (ifBinders d)+            fam_kind <- rnIfaceType (ifResKind d)+            fam_flav <- rnIfaceFamTyConFlav (ifFamFlav d)+            return d { ifName = name+                     , ifBinders = binders+                     , ifResKind = fam_kind+                     , ifFamFlav = fam_flav+                     }+rnIfaceDecl d@IfaceClass{} = do+            name <- rnIfaceGlobal (ifName d)+            binders <- mapM rnIfaceTyConBinder (ifBinders d)+            body <- rnIfaceClassBody (ifBody d)+            return d { ifName    = name+                     , ifBinders = binders+                     , ifBody    = body+                     }+rnIfaceDecl d@IfaceAxiom{} = do+            name <- rnIfaceNeverExported (ifName d)+            tycon <- rnIfaceTyCon (ifTyCon d)+            ax_branches <- mapM rnIfaceAxBranch (ifAxBranches d)+            return d { ifName = name+                     , ifTyCon = tycon+                     , ifAxBranches = ax_branches+                     }+rnIfaceDecl d@IfacePatSyn{} =  do+            name <- rnIfaceGlobal (ifName d)+            let rnPat (n, b) = (,) <$> rnIfaceGlobal n <*> pure b+            pat_matcher <- rnPat (ifPatMatcher d)+            pat_builder <- T.traverse rnPat (ifPatBuilder d)+            pat_univ_bndrs <- mapM rnIfaceForAllBndr (ifPatUnivBndrs d)+            pat_ex_bndrs <- mapM rnIfaceForAllBndr (ifPatExBndrs d)+            pat_prov_ctxt <- mapM rnIfaceType (ifPatProvCtxt d)+            pat_req_ctxt <- mapM rnIfaceType (ifPatReqCtxt d)+            pat_args <- mapM rnIfaceType (ifPatArgs d)+            pat_ty <- rnIfaceType (ifPatTy d)+            return d { ifName = name+                     , ifPatMatcher = pat_matcher+                     , ifPatBuilder = pat_builder+                     , ifPatUnivBndrs = pat_univ_bndrs+                     , ifPatExBndrs = pat_ex_bndrs+                     , ifPatProvCtxt = pat_prov_ctxt+                     , ifPatReqCtxt = pat_req_ctxt+                     , ifPatArgs = pat_args+                     , ifPatTy = pat_ty+                     }++rnIfaceClassBody :: Rename IfaceClassBody+rnIfaceClassBody IfAbstractClass = return IfAbstractClass+rnIfaceClassBody d@IfConcreteClass{} = do+    ctxt <- mapM rnIfaceType (ifClassCtxt d)+    ats <- mapM rnIfaceAT (ifATs d)+    sigs <- mapM rnIfaceClassOp (ifSigs d)+    return d { ifClassCtxt = ctxt, ifATs = ats, ifSigs = sigs }++rnIfaceFamTyConFlav :: Rename IfaceFamTyConFlav+rnIfaceFamTyConFlav (IfaceClosedSynFamilyTyCon (Just (n, axs)))+    = IfaceClosedSynFamilyTyCon . Just <$> ((,) <$> rnIfaceNeverExported n+                                                <*> mapM rnIfaceAxBranch axs)+rnIfaceFamTyConFlav flav = pure flav++rnIfaceAT :: Rename IfaceAT+rnIfaceAT (IfaceAT decl mb_ty)+    = IfaceAT <$> rnIfaceDecl decl <*> T.traverse rnIfaceType mb_ty++rnIfaceTyConParent :: Rename IfaceTyConParent+rnIfaceTyConParent (IfDataInstance n tc args)+    = IfDataInstance <$> rnIfaceGlobal n+                     <*> rnIfaceTyCon tc+                     <*> rnIfaceTcArgs args+rnIfaceTyConParent IfNoParent = pure IfNoParent++rnIfaceConDecls :: Rename IfaceConDecls+rnIfaceConDecls (IfDataTyCon ds)+    = IfDataTyCon <$> mapM rnIfaceConDecl ds+rnIfaceConDecls (IfNewTyCon d) = IfNewTyCon <$> rnIfaceConDecl d+rnIfaceConDecls IfAbstractTyCon = pure IfAbstractTyCon++rnIfaceConDecl :: Rename IfaceConDecl+rnIfaceConDecl d = do+    con_name <- rnIfaceGlobal (ifConName d)+    con_ex_tvs <- mapM rnIfaceForAllBndr (ifConExTvs d)+    let rnIfConEqSpec (n,t) = (,) n <$> rnIfaceType t+    con_eq_spec <- mapM rnIfConEqSpec (ifConEqSpec d)+    con_ctxt <- mapM rnIfaceType (ifConCtxt d)+    con_arg_tys <- mapM rnIfaceType (ifConArgTys d)+    con_fields <- mapM rnFieldLabel (ifConFields d)+    let rnIfaceBang (IfUnpackCo co) = IfUnpackCo <$> rnIfaceCo co+        rnIfaceBang bang = pure bang+    con_stricts <- mapM rnIfaceBang (ifConStricts d)+    return d { ifConName = con_name+             , ifConExTvs = con_ex_tvs+             , ifConEqSpec = con_eq_spec+             , ifConCtxt = con_ctxt+             , ifConArgTys = con_arg_tys+             , ifConFields = con_fields+             , ifConStricts = con_stricts+             }++rnIfaceClassOp :: Rename IfaceClassOp+rnIfaceClassOp (IfaceClassOp n ty dm) =+    IfaceClassOp <$> rnIfaceGlobal n+                 <*> rnIfaceType ty+                 <*> rnMaybeDefMethSpec dm++rnMaybeDefMethSpec :: Rename (Maybe (DefMethSpec IfaceType))+rnMaybeDefMethSpec (Just (GenericDM ty)) = Just . GenericDM <$> rnIfaceType ty+rnMaybeDefMethSpec mb = return mb++rnIfaceAxBranch :: Rename IfaceAxBranch+rnIfaceAxBranch d = do+    ty_vars <- mapM rnIfaceTvBndr (ifaxbTyVars d)+    lhs <- rnIfaceTcArgs (ifaxbLHS d)+    rhs <- rnIfaceType (ifaxbRHS d)+    return d { ifaxbTyVars = ty_vars+             , ifaxbLHS = lhs+             , ifaxbRHS = rhs }++rnIfaceIdInfo :: Rename IfaceIdInfo+rnIfaceIdInfo NoInfo = pure NoInfo+rnIfaceIdInfo (HasInfo is) = HasInfo <$> mapM rnIfaceInfoItem is++rnIfaceInfoItem :: Rename IfaceInfoItem+rnIfaceInfoItem (HsUnfold lb if_unf)+    = HsUnfold lb <$> rnIfaceUnfolding if_unf+rnIfaceInfoItem i+    = pure i++rnIfaceUnfolding :: Rename IfaceUnfolding+rnIfaceUnfolding (IfCoreUnfold stable if_expr)+    = IfCoreUnfold stable <$> rnIfaceExpr if_expr+rnIfaceUnfolding (IfCompulsory if_expr)+    = IfCompulsory <$> rnIfaceExpr if_expr+rnIfaceUnfolding (IfInlineRule arity unsat_ok boring_ok if_expr)+    = IfInlineRule arity unsat_ok boring_ok <$> rnIfaceExpr if_expr+rnIfaceUnfolding (IfDFunUnfold bs ops)+    = IfDFunUnfold <$> rnIfaceBndrs bs <*> mapM rnIfaceExpr ops++rnIfaceExpr :: Rename IfaceExpr+rnIfaceExpr (IfaceLcl name) = pure (IfaceLcl name)+rnIfaceExpr (IfaceExt gbl) = IfaceExt <$> rnIfaceGlobal gbl+rnIfaceExpr (IfaceType ty) = IfaceType <$> rnIfaceType ty+rnIfaceExpr (IfaceCo co) = IfaceCo <$> rnIfaceCo co+rnIfaceExpr (IfaceTuple sort args) = IfaceTuple sort <$> rnIfaceExprs args+rnIfaceExpr (IfaceLam lam_bndr expr)+    = IfaceLam <$> rnIfaceLamBndr lam_bndr <*> rnIfaceExpr expr+rnIfaceExpr (IfaceApp fun arg)+    = IfaceApp <$> rnIfaceExpr fun <*> rnIfaceExpr arg+rnIfaceExpr (IfaceCase scrut case_bndr alts)+    = IfaceCase <$> rnIfaceExpr scrut+                <*> pure case_bndr+                <*> mapM rnIfaceAlt alts+rnIfaceExpr (IfaceECase scrut ty)+    = IfaceECase <$> rnIfaceExpr scrut <*> rnIfaceType ty+rnIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body)+    = IfaceLet <$> (IfaceNonRec <$> rnIfaceLetBndr bndr <*> rnIfaceExpr rhs)+               <*> rnIfaceExpr body+rnIfaceExpr (IfaceLet (IfaceRec pairs) body)+    = IfaceLet <$> (IfaceRec <$> mapM (\(bndr, rhs) ->+                                        (,) <$> rnIfaceLetBndr bndr+                                            <*> rnIfaceExpr rhs) pairs)+               <*> rnIfaceExpr body+rnIfaceExpr (IfaceCast expr co)+    = IfaceCast <$> rnIfaceExpr expr <*> rnIfaceCo co+rnIfaceExpr (IfaceLit lit) = pure (IfaceLit lit)+rnIfaceExpr (IfaceFCall cc ty) = IfaceFCall cc <$> rnIfaceType ty+rnIfaceExpr (IfaceTick tickish expr) = IfaceTick tickish <$> rnIfaceExpr expr++rnIfaceBndrs :: Rename [IfaceBndr]+rnIfaceBndrs = mapM rnIfaceBndr++rnIfaceBndr :: Rename IfaceBndr+rnIfaceBndr (IfaceIdBndr (fs, ty)) = IfaceIdBndr <$> ((,) fs <$> rnIfaceType ty)+rnIfaceBndr (IfaceTvBndr tv_bndr) = IfaceIdBndr <$> rnIfaceTvBndr tv_bndr++rnIfaceTvBndr :: Rename IfaceTvBndr+rnIfaceTvBndr (fs, kind) = (,) fs <$> rnIfaceType kind++rnIfaceTyConBinder :: Rename IfaceTyConBinder+rnIfaceTyConBinder (TvBndr tv vis) = TvBndr <$> rnIfaceTvBndr tv <*> pure vis++rnIfaceAlt :: Rename IfaceAlt+rnIfaceAlt (conalt, names, rhs)+     = (,,) <$> rnIfaceConAlt conalt <*> pure names <*> rnIfaceExpr rhs++rnIfaceConAlt :: Rename IfaceConAlt+rnIfaceConAlt (IfaceDataAlt data_occ) = IfaceDataAlt <$> rnIfaceGlobal data_occ+rnIfaceConAlt alt = pure alt++rnIfaceLetBndr :: Rename IfaceLetBndr+rnIfaceLetBndr (IfLetBndr fs ty info jpi)+    = IfLetBndr fs <$> rnIfaceType ty <*> rnIfaceIdInfo info <*> pure jpi++rnIfaceLamBndr :: Rename IfaceLamBndr+rnIfaceLamBndr (bndr, oneshot) = (,) <$> rnIfaceBndr bndr <*> pure oneshot++rnIfaceCo :: Rename IfaceCoercion+rnIfaceCo (IfaceReflCo role ty) = IfaceReflCo role <$> rnIfaceType ty+rnIfaceCo (IfaceFunCo role co1 co2)+    = IfaceFunCo role <$> rnIfaceCo co1 <*> rnIfaceCo co2+rnIfaceCo (IfaceTyConAppCo role tc cos)+    = IfaceTyConAppCo role <$> rnIfaceTyCon tc <*> mapM rnIfaceCo cos+rnIfaceCo (IfaceAppCo co1 co2)+    = IfaceAppCo <$> rnIfaceCo co1 <*> rnIfaceCo co2+rnIfaceCo (IfaceForAllCo bndr co1 co2)+    = IfaceForAllCo <$> rnIfaceTvBndr bndr <*> rnIfaceCo co1 <*> rnIfaceCo co2+rnIfaceCo (IfaceCoVarCo lcl) = IfaceCoVarCo <$> pure lcl+rnIfaceCo (IfaceAxiomInstCo n i cs)+    = IfaceAxiomInstCo <$> rnIfaceGlobal n <*> pure i <*> mapM rnIfaceCo cs+rnIfaceCo (IfaceUnivCo s r t1 t2)+    = IfaceUnivCo s r <$> rnIfaceType t1 <*> rnIfaceType t2+rnIfaceCo (IfaceSymCo c)+    = IfaceSymCo <$> rnIfaceCo c+rnIfaceCo (IfaceTransCo c1 c2)+    = IfaceTransCo <$> rnIfaceCo c1 <*> rnIfaceCo c2+rnIfaceCo (IfaceInstCo c1 c2)+    = IfaceInstCo <$> rnIfaceCo c1 <*> rnIfaceCo c2+rnIfaceCo (IfaceNthCo d c) = IfaceNthCo d <$> rnIfaceCo c+rnIfaceCo (IfaceLRCo lr c) = IfaceLRCo lr <$> rnIfaceCo c+rnIfaceCo (IfaceSubCo c) = IfaceSubCo <$> rnIfaceCo c+rnIfaceCo (IfaceAxiomRuleCo ax cos)+    = IfaceAxiomRuleCo ax <$> mapM rnIfaceCo cos+rnIfaceCo (IfaceKindCo c) = IfaceKindCo <$> rnIfaceCo c+rnIfaceCo (IfaceCoherenceCo c1 c2) = IfaceCoherenceCo <$> rnIfaceCo c1 <*> rnIfaceCo c2++rnIfaceTyCon :: Rename IfaceTyCon+rnIfaceTyCon (IfaceTyCon n info)+    = IfaceTyCon <$> rnIfaceGlobal n <*> pure info++rnIfaceExprs :: Rename [IfaceExpr]+rnIfaceExprs = mapM rnIfaceExpr++rnIfaceIdDetails :: Rename IfaceIdDetails+rnIfaceIdDetails (IfRecSelId (Left tc) b) = IfRecSelId <$> fmap Left (rnIfaceTyCon tc) <*> pure b+rnIfaceIdDetails (IfRecSelId (Right decl) b) = IfRecSelId <$> fmap Right (rnIfaceDecl decl) <*> pure b+rnIfaceIdDetails details = pure details++rnIfaceType :: Rename IfaceType+rnIfaceType (IfaceFreeTyVar n) = pure (IfaceFreeTyVar n)+rnIfaceType (IfaceTyVar   n)   = pure (IfaceTyVar n)+rnIfaceType (IfaceAppTy t1 t2)+    = IfaceAppTy <$> rnIfaceType t1 <*> rnIfaceType t2+rnIfaceType (IfaceLitTy l)         = return (IfaceLitTy l)+rnIfaceType (IfaceFunTy t1 t2)+    = IfaceFunTy <$> rnIfaceType t1 <*> rnIfaceType t2+rnIfaceType (IfaceDFunTy t1 t2)+    = IfaceDFunTy <$> rnIfaceType t1 <*> rnIfaceType t2+rnIfaceType (IfaceTupleTy s i tks)+    = IfaceTupleTy s i <$> rnIfaceTcArgs tks+rnIfaceType (IfaceTyConApp tc tks)+    = IfaceTyConApp <$> rnIfaceTyCon tc <*> rnIfaceTcArgs tks+rnIfaceType (IfaceForAllTy tv t)+    = IfaceForAllTy <$> rnIfaceForAllBndr tv <*> rnIfaceType t+rnIfaceType (IfaceCoercionTy co)+    = IfaceCoercionTy <$> rnIfaceCo co+rnIfaceType (IfaceCastTy ty co)+    = IfaceCastTy <$> rnIfaceType ty <*> rnIfaceCo co++rnIfaceForAllBndr :: Rename IfaceForAllBndr+rnIfaceForAllBndr (TvBndr tv vis) = TvBndr <$> rnIfaceTvBndr tv <*> pure vis++rnIfaceTcArgs :: Rename IfaceTcArgs+rnIfaceTcArgs (ITC_Invis t ts) = ITC_Invis <$> rnIfaceType t <*> rnIfaceTcArgs ts+rnIfaceTcArgs (ITC_Vis t ts) = ITC_Vis <$> rnIfaceType t <*> rnIfaceTcArgs ts+rnIfaceTcArgs ITC_Nil = pure ITC_Nil
+ basicTypes/Avail.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE CPP #-}+--+-- (c) The University of Glasgow+--++#include "HsVersions.h"++module Avail (+    Avails,+    AvailInfo(..),+    avail,+    availsToNameSet,+    availsToNameSetWithSelectors,+    availsToNameEnv,+    availName, availNames, availNonFldNames,+    availNamesWithSelectors,+    availFlds,+    stableAvailCmp,+    plusAvail,+    trimAvail,+    filterAvail,+    filterAvails,+    nubAvails+++  ) where++import Name+import NameEnv+import NameSet++import FieldLabel+import Binary+import ListSetOps+import Outputable+import Util++import Data.List ( find )+import Data.Function++-- -----------------------------------------------------------------------------+-- The AvailInfo type++-- | Records what things are "available", i.e. in scope+data AvailInfo = Avail Name      -- ^ An ordinary identifier in scope+               | AvailTC Name+                         [Name]+                         [FieldLabel]+                                 -- ^ A type or class in scope. Parameters:+                                 --+                                 --  1) The name of the type or class+                                 --  2) The available pieces of type or class,+                                 --     excluding field selectors.+                                 --  3) The record fields of the type+                                 --     (see Note [Representing fields in AvailInfo]).+                                 --+                                 -- The AvailTC Invariant:+                                 --   * If the type or class is itself+                                 --     to be in scope, it must be+                                 --     *first* in this list.  Thus,+                                 --     typically: @AvailTC Eq [Eq, ==, \/=]@+                deriving( Eq )+                        -- Equality used when deciding if the+                        -- interface has changed++-- | A collection of 'AvailInfo' - several things that are \"available\"+type Avails = [AvailInfo]++{-+Note [Representing fields in AvailInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When -XDuplicateRecordFields is disabled (the normal case), a+datatype like++  data T = MkT { foo :: Int }++gives rise to the AvailInfo++  AvailTC T [T, MkT] [FieldLabel "foo" False foo],++whereas if -XDuplicateRecordFields is enabled it gives++  AvailTC T [T, MkT] [FieldLabel "foo" True $sel:foo:MkT]++since the label does not match the selector name.++The labels in a field list are not necessarily unique:+data families allow the same parent (the family tycon) to have+multiple distinct fields with the same label. For example,++  data family F a+  data instance F Int  = MkFInt { foo :: Int }+  data instance F Bool = MkFBool { foo :: Bool}++gives rise to++  AvailTC F [F, MkFInt, MkFBool]+    [FieldLabel "foo" True $sel:foo:MkFInt, FieldLabel "foo" True $sel:foo:MkFBool].++Moreover, note that the flIsOverloaded flag need not be the same for+all the elements of the list.  In the example above, this occurs if+the two data instances are defined in different modules, one with+`-XDuplicateRecordFields` enabled and one with it disabled.  Thus it+is possible to have++  AvailTC F [F, MkFInt, MkFBool]+    [FieldLabel "foo" True $sel:foo:MkFInt, FieldLabel "foo" False foo].++If the two data instances are defined in different modules, both+without `-XDuplicateRecordFields`, it will be impossible to export+them from the same module (even with `-XDuplicateRecordfields`+enabled), because they would be represented identically.  The+workaround here is to enable `-XDuplicateRecordFields` on the defining+modules.+-}++-- | Compare lexicographically+stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering+stableAvailCmp (Avail n1)       (Avail n2)   = n1 `stableNameCmp` n2+stableAvailCmp (Avail {})         (AvailTC {})   = LT+stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) =+    (n `stableNameCmp` m) `thenCmp`+    (cmpList stableNameCmp ns ms) `thenCmp`+    (cmpList (stableNameCmp `on` flSelector) nfs mfs)+stableAvailCmp (AvailTC {})       (Avail {})     = GT++avail :: Name -> AvailInfo+avail n = Avail n++-- -----------------------------------------------------------------------------+-- Operations on AvailInfo++availsToNameSet :: [AvailInfo] -> NameSet+availsToNameSet avails = foldr add emptyNameSet avails+      where add avail set = extendNameSetList set (availNames avail)++availsToNameSetWithSelectors :: [AvailInfo] -> NameSet+availsToNameSetWithSelectors avails = foldr add emptyNameSet avails+      where add avail set = extendNameSetList set (availNamesWithSelectors avail)++availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo+availsToNameEnv avails = foldr add emptyNameEnv avails+     where add avail env = extendNameEnvList env+                                (zip (availNames avail) (repeat avail))++-- | Just the main name made available, i.e. not the available pieces+-- of type or class brought into scope by the 'GenAvailInfo'+availName :: AvailInfo -> Name+availName (Avail n)     = n+availName (AvailTC n _ _) = n++-- | All names made available by the availability information (excluding overloaded selectors)+availNames :: AvailInfo -> [Name]+availNames (Avail n)         = [n]+availNames (AvailTC _ ns fs) = ns ++ [ flSelector f | f <- fs, not (flIsOverloaded f) ]++-- | All names made available by the availability information (including overloaded selectors)+availNamesWithSelectors :: AvailInfo -> [Name]+availNamesWithSelectors (Avail n)         = [n]+availNamesWithSelectors (AvailTC _ ns fs) = ns ++ map flSelector fs++-- | Names for non-fields made available by the availability information+availNonFldNames :: AvailInfo -> [Name]+availNonFldNames (Avail n)        = [n]+availNonFldNames (AvailTC _ ns _) = ns++-- | Fields made available by the availability information+availFlds :: AvailInfo -> [FieldLabel]+availFlds (AvailTC _ _ fs) = fs+availFlds _                = []+++-- -----------------------------------------------------------------------------+-- Utility++plusAvail :: AvailInfo -> AvailInfo -> AvailInfo+plusAvail a1 a2+  | debugIsOn && availName a1 /= availName a2+  = pprPanic "RnEnv.plusAvail names differ" (hsep [ppr a1,ppr a2])+plusAvail a1@(Avail {})         (Avail {})        = a1+plusAvail (AvailTC _ [] [])     a2@(AvailTC {})   = a2+plusAvail a1@(AvailTC {})       (AvailTC _ [] []) = a1+plusAvail (AvailTC n1 (s1:ss1) fs1) (AvailTC n2 (s2:ss2) fs2)+  = case (n1==s1, n2==s2) of  -- Maintain invariant the parent is first+       (True,True)   -> AvailTC n1 (s1 : (ss1 `unionLists` ss2))+                                   (fs1 `unionLists` fs2)+       (True,False)  -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2)))+                                   (fs1 `unionLists` fs2)+       (False,True)  -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2))+                                   (fs1 `unionLists` fs2)+       (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2))+                                   (fs1 `unionLists` fs2)+plusAvail (AvailTC n1 ss1 fs1) (AvailTC _ [] fs2)+  = AvailTC n1 ss1 (fs1 `unionLists` fs2)+plusAvail (AvailTC n1 [] fs1)  (AvailTC _ ss2 fs2)+  = AvailTC n1 ss2 (fs1 `unionLists` fs2)+plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])++-- | trims an 'AvailInfo' to keep only a single name+trimAvail :: AvailInfo -> Name -> AvailInfo+trimAvail (Avail n)         _ = Avail n+trimAvail (AvailTC n ns fs) m = case find ((== m) . flSelector) fs of+    Just x  -> AvailTC n [] [x]+    Nothing -> ASSERT( m `elem` ns ) AvailTC n [m] []++-- | filters 'AvailInfo's by the given predicate+filterAvails  :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo]+filterAvails keep avails = foldr (filterAvail keep) [] avails++-- | filters an 'AvailInfo' by the given predicate+filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo]+filterAvail keep ie rest =+  case ie of+    Avail n | keep n    -> ie : rest+            | otherwise -> rest+    AvailTC tc ns fs ->+        let ns' = filter keep ns+            fs' = filter (keep . flSelector) fs in+        if null ns' && null fs' then rest else AvailTC tc ns' fs' : rest+++-- | Combines 'AvailInfo's from the same family+-- 'avails' may have several items with the same availName+-- E.g  import Ix( Ix(..), index )+-- will give Ix(Ix,index,range) and Ix(index)+-- We want to combine these; addAvail does that+nubAvails :: [AvailInfo] -> [AvailInfo]+nubAvails avails = nameEnvElts (foldl add emptyNameEnv avails)+  where+    add env avail = extendNameEnv_C plusAvail env (availName avail) avail++-- -----------------------------------------------------------------------------+-- Printing++instance Outputable AvailInfo where+   ppr = pprAvail++pprAvail :: AvailInfo -> SDoc+pprAvail (Avail n)+  = ppr n+pprAvail (AvailTC n ns fs)+  = ppr n <> braces (sep [ fsep (punctuate comma (map ppr ns)) <> semi+                         , fsep (punctuate comma (map (ppr . flLabel) fs))])++instance Binary AvailInfo where+    put_ bh (Avail aa) = do+            putByte bh 0+            put_ bh aa+    put_ bh (AvailTC ab ac ad) = do+            putByte bh 1+            put_ bh ab+            put_ bh ac+            put_ bh ad+    get bh = do+            h <- getByte bh+            case h of+              0 -> do aa <- get bh+                      return (Avail aa)+              _ -> do ab <- get bh+                      ac <- get bh+                      ad <- get bh+                      return (AvailTC ab ac ad)
+ basicTypes/BasicTypes.hs view
@@ -0,0 +1,1511 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1997-1998++\section[BasicTypes]{Miscellanous types}++This module defines a miscellaneously collection of very simple+types that++\begin{itemize}+\item have no other obvious home+\item don't depend on any other complicated types+\item are used in more than one "part" of the compiler+\end{itemize}+-}++{-# LANGUAGE DeriveDataTypeable #-}++module BasicTypes(+        Version, bumpVersion, initialVersion,++        LeftOrRight(..),+        pickLR,++        ConTag, ConTagZ, fIRST_TAG,++        Arity, RepArity, JoinArity,++        Alignment,++        FunctionOrData(..),++        WarningTxt(..), pprWarningTxtForMsg, StringLiteral(..),++        Fixity(..), FixityDirection(..),+        defaultFixity, maxPrecedence, minPrecedence,+        negateFixity, funTyFixity,+        compareFixity,+        LexicalFixity(..),++        RecFlag(..), isRec, isNonRec, boolToRecFlag,+        Origin(..), isGenerated,++        RuleName, pprRuleName,++        TopLevelFlag(..), isTopLevel, isNotTopLevel,++        DerivStrategy(..),++        OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,+        hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag,++        Boxity(..), isBoxed,++        TyPrec(..), maybeParen,++        TupleSort(..), tupleSortBoxity, boxityTupleSort,+        tupleParens,++        sumParens, pprAlternative,++        -- ** The OneShotInfo type+        OneShotInfo(..),+        noOneShotInfo, hasNoOneShotInfo, isOneShotInfo,+        bestOneShot, worstOneShot,++        OccInfo(..), noOccInfo, seqOccInfo, zapFragileOcc, isOneOcc,+        isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isManyOccs,+        strongLoopBreaker, weakLoopBreaker,++        InsideLam, insideLam, notInsideLam,+        OneBranch, oneBranch, notOneBranch,+        InterestingCxt,+        TailCallInfo(..), tailCallInfo, zapOccTailCallInfo,+        isAlwaysTailCalled,++        EP(..),++        DefMethSpec(..),+        SwapFlag(..), flipSwap, unSwap, isSwapped,++        CompilerPhase(..), PhaseNum,++        Activation(..), isActive, isActiveIn, competesWith,+        isNeverActive, isAlwaysActive, isEarlyActive,++        RuleMatchInfo(..), isConLike, isFunLike,+        InlineSpec(..), isEmptyInlineSpec,+        InlinePragma(..), defaultInlinePragma, alwaysInlinePragma,+        neverInlinePragma, dfunInlinePragma,+        isDefaultInlinePragma,+        isInlinePragma, isInlinablePragma, isAnyInlinePragma,+        inlinePragmaSpec, inlinePragmaSat,+        inlinePragmaActivation, inlinePragmaRuleMatchInfo,+        setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,+        pprInline, pprInlineDebug,++        SuccessFlag(..), succeeded, failed, successIf,++        FractionalLit(..), negateFractionalLit, integralFractionalLit,++        SourceText(..), pprWithSourceText,++        IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit,++        SpliceExplicitFlag(..)+   ) where++import FastString+import Outputable+import SrcLoc ( Located,unLoc )+import Data.Data hiding (Fixity, Prefix, Infix)+import Data.Function (on)++{-+************************************************************************+*                                                                      *+          Binary choice+*                                                                      *+************************************************************************+-}++data LeftOrRight = CLeft | CRight+                 deriving( Eq, Data )++pickLR :: LeftOrRight -> (a,a) -> a+pickLR CLeft  (l,_) = l+pickLR CRight (_,r) = r++instance Outputable LeftOrRight where+  ppr CLeft    = text "Left"+  ppr CRight   = text "Right"++{-+************************************************************************+*                                                                      *+\subsection[Arity]{Arity}+*                                                                      *+************************************************************************+-}++-- | The number of value arguments that can be applied to a value before it does+-- "real work". So:+--  fib 100     has arity 0+--  \x -> fib x has arity 1+-- See also Note [Definition of arity] in CoreArity+type Arity = Int++-- | Representation Arity+--+-- The number of represented arguments that can be applied to a value before it does+-- "real work". So:+--  fib 100                    has representation arity 0+--  \x -> fib x                has representation arity 1+--  \(# x, y #) -> fib (x + y) has representation arity 2+type RepArity = Int++-- | The number of arguments that a join point takes. Unlike the arity of a+-- function, this is a purely syntactic property and is fixed when the join+-- point is created (or converted from a value). Both type and value arguments+-- are counted.+type JoinArity = Int++{-+************************************************************************+*                                                                      *+              Constructor tags+*                                                                      *+************************************************************************+-}++-- | Constructor Tag+--+-- Type of the tags associated with each constructor possibility or superclass+-- selector+type ConTag = Int++-- | A *zero-indexed* constructor tag+type ConTagZ = Int++fIRST_TAG :: ConTag+-- ^ Tags are allocated from here for real constructors+--   or for superclass selectors+fIRST_TAG =  1++{-+************************************************************************+*                                                                      *+\subsection[Alignment]{Alignment}+*                                                                      *+************************************************************************+-}++type Alignment = Int -- align to next N-byte boundary (N must be a power of 2).++{-+************************************************************************+*                                                                      *+         One-shot information+*                                                                      *+************************************************************************+-}++-- | If the 'Id' is a lambda-bound variable then it may have lambda-bound+-- variable info. Sometimes we know whether the lambda binding this variable+-- is a \"one-shot\" lambda; that is, whether it is applied at most once.+--+-- This information may be useful in optimisation, as computations may+-- safely be floated inside such a lambda without risk of duplicating+-- work.+data OneShotInfo+  = NoOneShotInfo -- ^ No information+  | OneShotLam    -- ^ The lambda is applied at most once.+  deriving (Eq)++-- | It is always safe to assume that an 'Id' has no lambda-bound variable information+noOneShotInfo :: OneShotInfo+noOneShotInfo = NoOneShotInfo++isOneShotInfo, hasNoOneShotInfo :: OneShotInfo -> Bool+isOneShotInfo OneShotLam = True+isOneShotInfo _          = False++hasNoOneShotInfo NoOneShotInfo = True+hasNoOneShotInfo _             = False++worstOneShot, bestOneShot :: OneShotInfo -> OneShotInfo -> OneShotInfo+worstOneShot NoOneShotInfo _             = NoOneShotInfo+worstOneShot OneShotLam    os            = os++bestOneShot NoOneShotInfo os         = os+bestOneShot OneShotLam    _          = OneShotLam++pprOneShotInfo :: OneShotInfo -> SDoc+pprOneShotInfo NoOneShotInfo = empty+pprOneShotInfo OneShotLam    = text "OneShot"++instance Outputable OneShotInfo where+    ppr = pprOneShotInfo++{-+************************************************************************+*                                                                      *+           Swap flag+*                                                                      *+************************************************************************+-}++data SwapFlag+  = NotSwapped  -- Args are: actual,   expected+  | IsSwapped   -- Args are: expected, actual++instance Outputable SwapFlag where+  ppr IsSwapped  = text "Is-swapped"+  ppr NotSwapped = text "Not-swapped"++flipSwap :: SwapFlag -> SwapFlag+flipSwap IsSwapped  = NotSwapped+flipSwap NotSwapped = IsSwapped++isSwapped :: SwapFlag -> Bool+isSwapped IsSwapped  = True+isSwapped NotSwapped = False++unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b+unSwap NotSwapped f a b = f a b+unSwap IsSwapped  f a b = f b a++{-+************************************************************************+*                                                                      *+\subsection[FunctionOrData]{FunctionOrData}+*                                                                      *+************************************************************************+-}++data FunctionOrData = IsFunction | IsData+    deriving (Eq, Ord, Data)++instance Outputable FunctionOrData where+    ppr IsFunction = text "(function)"+    ppr IsData     = text "(data)"++{-+************************************************************************+*                                                                      *+\subsection[Version]{Module and identifier version numbers}+*                                                                      *+************************************************************************+-}++type Version = Int++bumpVersion :: Version -> Version+bumpVersion v = v+1++initialVersion :: Version+initialVersion = 1++{-+************************************************************************+*                                                                      *+                Deprecations+*                                                                      *+************************************************************************+-}++-- | A String Literal in the source, including its original raw format for use by+-- source to source manipulation tools.+data StringLiteral = StringLiteral+                       { sl_st :: SourceText, -- literal raw source.+                                              -- See not [Literal source text]+                         sl_fs :: FastString  -- literal string value+                       } deriving Data++instance Eq StringLiteral where+  (StringLiteral _ a) == (StringLiteral _ b) = a == b++instance Outputable StringLiteral where+  ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl)++-- | Warning Text+--+-- reason/explanation from a WARNING or DEPRECATED pragma+data WarningTxt = WarningTxt (Located SourceText)+                             [Located StringLiteral]+                | DeprecatedTxt (Located SourceText)+                                [Located StringLiteral]+    deriving (Eq, Data)++instance Outputable WarningTxt where+    ppr (WarningTxt    lsrc ws)+      = case unLoc lsrc of+          NoSourceText   -> pp_ws ws+          SourceText src -> text src <+> pp_ws ws <+> text "#-}"++    ppr (DeprecatedTxt lsrc  ds)+      = case unLoc lsrc of+          NoSourceText   -> pp_ws ds+          SourceText src -> text src <+> pp_ws ds <+> text "#-}"++pp_ws :: [Located StringLiteral] -> SDoc+pp_ws [l] = ppr $ unLoc l+pp_ws ws+  = text "["+    <+> vcat (punctuate comma (map (ppr . unLoc) ws))+    <+> text "]"+++pprWarningTxtForMsg :: WarningTxt -> SDoc+pprWarningTxtForMsg (WarningTxt    _ ws)+                     = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws))+pprWarningTxtForMsg (DeprecatedTxt _ ds)+                     = text "Deprecated:" <+>+                       doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds))++{-+************************************************************************+*                                                                      *+                Rules+*                                                                      *+************************************************************************+-}++type RuleName = FastString++pprRuleName :: RuleName -> SDoc+pprRuleName rn = doubleQuotes (ftext rn)++{-+************************************************************************+*                                                                      *+\subsection[Fixity]{Fixity info}+*                                                                      *+************************************************************************+-}++------------------------+data Fixity = Fixity SourceText Int FixityDirection+  -- Note [Pragma source text]+  deriving Data++instance Outputable Fixity where+    ppr (Fixity _ prec dir) = hcat [ppr dir, space, int prec]++instance Eq Fixity where -- Used to determine if two fixities conflict+  (Fixity _ p1 dir1) == (Fixity _ p2 dir2) = p1==p2 && dir1 == dir2++------------------------+data FixityDirection = InfixL | InfixR | InfixN+                     deriving (Eq, Data)++instance Outputable FixityDirection where+    ppr InfixL = text "infixl"+    ppr InfixR = text "infixr"+    ppr InfixN = text "infix"++------------------------+maxPrecedence, minPrecedence :: Int+maxPrecedence = 9+minPrecedence = 0++defaultFixity :: Fixity+defaultFixity = Fixity NoSourceText maxPrecedence InfixL++negateFixity, funTyFixity :: Fixity+-- Wired-in fixities+negateFixity = Fixity NoSourceText 6 InfixL  -- Fixity of unary negate+funTyFixity  = Fixity NoSourceText 0 InfixR  -- Fixity of '->'++{-+Consider++\begin{verbatim}+        a `op1` b `op2` c+\end{verbatim}+@(compareFixity op1 op2)@ tells which way to arrange application, or+whether there's an error.+-}++compareFixity :: Fixity -> Fixity+              -> (Bool,         -- Error please+                  Bool)         -- Associate to the right: a op1 (b op2 c)+compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2)+  = case prec1 `compare` prec2 of+        GT -> left+        LT -> right+        EQ -> case (dir1, dir2) of+                        (InfixR, InfixR) -> right+                        (InfixL, InfixL) -> left+                        _                -> error_please+  where+    right        = (False, True)+    left         = (False, False)+    error_please = (True,  False)++-- |Captures the fixity of declarations as they are parsed. This is not+-- necessarily the same as the fixity declaration, as the normal fixity may be+-- overridden using parens or backticks.+data LexicalFixity = Prefix | Infix deriving (Typeable,Data,Eq)++instance Outputable LexicalFixity where+  ppr Prefix = text "Prefix"+  ppr Infix  = text "Infix"++{-+************************************************************************+*                                                                      *+\subsection[Top-level/local]{Top-level/not-top level flag}+*                                                                      *+************************************************************************+-}++data TopLevelFlag+  = TopLevel+  | NotTopLevel++isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool++isNotTopLevel NotTopLevel = True+isNotTopLevel TopLevel    = False++isTopLevel TopLevel     = True+isTopLevel NotTopLevel  = False++instance Outputable TopLevelFlag where+  ppr TopLevel    = text "<TopLevel>"+  ppr NotTopLevel = text "<NotTopLevel>"++{-+************************************************************************+*                                                                      *+                Boxity flag+*                                                                      *+************************************************************************+-}++data Boxity+  = Boxed+  | Unboxed+  deriving( Eq, Data )++isBoxed :: Boxity -> Bool+isBoxed Boxed   = True+isBoxed Unboxed = False++instance Outputable Boxity where+  ppr Boxed   = text "Boxed"+  ppr Unboxed = text "Unboxed"++{-+************************************************************************+*                                                                      *+                Recursive/Non-Recursive flag+*                                                                      *+************************************************************************+-}++-- | Recursivity Flag+data RecFlag = Recursive+             | NonRecursive+             deriving( Eq, Data )++isRec :: RecFlag -> Bool+isRec Recursive    = True+isRec NonRecursive = False++isNonRec :: RecFlag -> Bool+isNonRec Recursive    = False+isNonRec NonRecursive = True++boolToRecFlag :: Bool -> RecFlag+boolToRecFlag True  = Recursive+boolToRecFlag False = NonRecursive++instance Outputable RecFlag where+  ppr Recursive    = text "Recursive"+  ppr NonRecursive = text "NonRecursive"++{-+************************************************************************+*                                                                      *+                Code origin+*                                                                      *+************************************************************************+-}++data Origin = FromSource+            | Generated+            deriving( Eq, Data )++isGenerated :: Origin -> Bool+isGenerated Generated = True+isGenerated FromSource = False++instance Outputable Origin where+  ppr FromSource  = text "FromSource"+  ppr Generated   = text "Generated"++{-+************************************************************************+*                                                                      *+                Deriving strategies+*                                                                      *+************************************************************************+-}++-- | Which technique the user explicitly requested when deriving an instance.+data DerivStrategy+  -- See Note [Deriving strategies] in TcDeriv+  = StockStrategy    -- ^ GHC's \"standard\" strategy, which is to implement a+                     --   custom instance for the data type. This only works+                     --   for certain types that GHC knows about (e.g., 'Eq',+                     --   'Show', 'Functor' when @-XDeriveFunctor@ is enabled,+                     --   etc.)+  | AnyclassStrategy -- ^ @-XDeriveAnyClass@+  | NewtypeStrategy  -- ^ @-XGeneralizedNewtypeDeriving@+  deriving (Eq, Data)++instance Outputable DerivStrategy where+    ppr StockStrategy    = text "stock"+    ppr AnyclassStrategy = text "anyclass"+    ppr NewtypeStrategy  = text "newtype"++{-+************************************************************************+*                                                                      *+                Instance overlap flag+*                                                                      *+************************************************************************+-}++-- | The semantics allowed for overlapping instances for a particular+-- instance. See Note [Safe Haskell isSafeOverlap] (in `InstEnv.hs`) for a+-- explanation of the `isSafeOverlap` field.+--+-- - 'ApiAnnotation.AnnKeywordId' :+--      'ApiAnnotation.AnnOpen' @'\{-\# OVERLAPPABLE'@ or+--                              @'\{-\# OVERLAPPING'@ or+--                              @'\{-\# OVERLAPS'@ or+--                              @'\{-\# INCOHERENT'@,+--      'ApiAnnotation.AnnClose' @`\#-\}`@,++-- For details on above see note [Api annotations] in ApiAnnotation+data OverlapFlag = OverlapFlag+  { overlapMode   :: OverlapMode+  , isSafeOverlap :: Bool+  } deriving (Eq, Data)++setOverlapModeMaybe :: OverlapFlag -> Maybe OverlapMode -> OverlapFlag+setOverlapModeMaybe f Nothing  = f+setOverlapModeMaybe f (Just m) = f { overlapMode = m }++hasIncoherentFlag :: OverlapMode -> Bool+hasIncoherentFlag mode =+  case mode of+    Incoherent   _ -> True+    _              -> False++hasOverlappableFlag :: OverlapMode -> Bool+hasOverlappableFlag mode =+  case mode of+    Overlappable _ -> True+    Overlaps     _ -> True+    Incoherent   _ -> True+    _              -> False++hasOverlappingFlag :: OverlapMode -> Bool+hasOverlappingFlag mode =+  case mode of+    Overlapping  _ -> True+    Overlaps     _ -> True+    Incoherent   _ -> True+    _              -> False++data OverlapMode  -- See Note [Rules for instance lookup] in InstEnv+  = NoOverlap SourceText+                  -- See Note [Pragma source text]+    -- ^ This instance must not overlap another `NoOverlap` instance.+    -- However, it may be overlapped by `Overlapping` instances,+    -- and it may overlap `Overlappable` instances.+++  | Overlappable SourceText+                  -- See Note [Pragma source text]+    -- ^ Silently ignore this instance if you find a+    -- more specific one that matches the constraint+    -- you are trying to resolve+    --+    -- Example: constraint (Foo [Int])+    --   instance                      Foo [Int]+    --   instance {-# OVERLAPPABLE #-} Foo [a]+    --+    -- Since the second instance has the Overlappable flag,+    -- the first instance will be chosen (otherwise+    -- its ambiguous which to choose)+++  | Overlapping SourceText+                  -- See Note [Pragma source text]+    -- ^ Silently ignore any more general instances that may be+    --   used to solve the constraint.+    --+    -- Example: constraint (Foo [Int])+    --   instance {-# OVERLAPPING #-} Foo [Int]+    --   instance                     Foo [a]+    --+    -- Since the first instance has the Overlapping flag,+    -- the second---more general---instance will be ignored (otherwise+    -- it is ambiguous which to choose)+++  | Overlaps SourceText+                  -- See Note [Pragma source text]+    -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags.++  | Incoherent SourceText+                  -- See Note [Pragma source text]+    -- ^ Behave like Overlappable and Overlapping, and in addition pick+    -- an an arbitrary one if there are multiple matching candidates, and+    -- don't worry about later instantiation+    --+    -- Example: constraint (Foo [b])+    -- instance {-# INCOHERENT -} Foo [Int]+    -- instance                   Foo [a]+    -- Without the Incoherent flag, we'd complain that+    -- instantiating 'b' would change which instance+    -- was chosen. See also note [Incoherent instances] in InstEnv++  deriving (Eq, Data)+++instance Outputable OverlapFlag where+   ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag)++instance Outputable OverlapMode where+   ppr (NoOverlap    _) = empty+   ppr (Overlappable _) = text "[overlappable]"+   ppr (Overlapping  _) = text "[overlapping]"+   ppr (Overlaps     _) = text "[overlap ok]"+   ppr (Incoherent   _) = text "[incoherent]"++pprSafeOverlap :: Bool -> SDoc+pprSafeOverlap True  = text "[safe]"+pprSafeOverlap False = empty++{-+************************************************************************+*                                                                      *+                Type precedence+*                                                                      *+************************************************************************+-}++data TyPrec   -- See Note [Precedence in types] in TyCoRep.hs+  = TopPrec         -- No parens+  | FunPrec         -- Function args; no parens for tycon apps+  | TyOpPrec        -- Infix operator+  | TyConPrec       -- Tycon args; no parens for atomic+  deriving( Eq, Ord )++maybeParen :: TyPrec -> TyPrec -> SDoc -> SDoc+maybeParen ctxt_prec inner_prec pretty+  | ctxt_prec < inner_prec = pretty+  | otherwise              = parens pretty++{-+************************************************************************+*                                                                      *+                Tuples+*                                                                      *+************************************************************************+-}++data TupleSort+  = BoxedTuple+  | UnboxedTuple+  | ConstraintTuple+  deriving( Eq, Data )++tupleSortBoxity :: TupleSort -> Boxity+tupleSortBoxity BoxedTuple      = Boxed+tupleSortBoxity UnboxedTuple    = Unboxed+tupleSortBoxity ConstraintTuple = Boxed++boxityTupleSort :: Boxity -> TupleSort+boxityTupleSort Boxed   = BoxedTuple+boxityTupleSort Unboxed = UnboxedTuple++tupleParens :: TupleSort -> SDoc -> SDoc+tupleParens BoxedTuple      p = parens p+tupleParens UnboxedTuple    p = text "(#" <+> p <+> ptext (sLit "#)")+tupleParens ConstraintTuple p   -- In debug-style write (% Eq a, Ord b %)+  = sdocWithPprDebug $ \dbg -> if dbg+      then text "(%" <+> p <+> ptext (sLit "%)")+      else parens p++{-+************************************************************************+*                                                                      *+                Sums+*                                                                      *+************************************************************************+-}++sumParens :: SDoc -> SDoc+sumParens p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)")++-- | Pretty print an alternative in an unboxed sum e.g. "| a | |".+pprAlternative :: (a -> SDoc) -- ^ The pretty printing function to use+               -> a           -- ^ The things to be pretty printed+               -> ConTag      -- ^ Alternative (one-based)+               -> Arity       -- ^ Arity+               -> SDoc        -- ^ 'SDoc' where the alternative havs been pretty+                              -- printed and finally packed into a paragraph.+pprAlternative pp x alt arity =+    fsep (replicate (alt - 1) vbar ++ [pp x] ++ replicate (arity - alt) vbar)++{-+************************************************************************+*                                                                      *+\subsection[Generic]{Generic flag}+*                                                                      *+************************************************************************++This is the "Embedding-Projection pair" datatype, it contains+two pieces of code (normally either RenamedExpr's or Id's)+If we have a such a pair (EP from to), the idea is that 'from' and 'to'+represents functions of type++        from :: T -> Tring+        to   :: Tring -> T++And we should have++        to (from x) = x++T and Tring are arbitrary, but typically T is the 'main' type while+Tring is the 'representation' type.  (This just helps us remember+whether to use 'from' or 'to'.+-}++-- | Embedding Projection pair+data EP a = EP { fromEP :: a,   -- :: T -> Tring+                 toEP   :: a }  -- :: Tring -> T++{-+Embedding-projection pairs are used in several places:++First of all, each type constructor has an EP associated with it, the+code in EP converts (datatype T) from T to Tring and back again.++Secondly, when we are filling in Generic methods (in the typechecker,+tcMethodBinds), we are constructing bimaps by induction on the structure+of the type of the method signature.+++************************************************************************+*                                                                      *+\subsection{Occurrence information}+*                                                                      *+************************************************************************++This data type is used exclusively by the simplifier, but it appears in a+SubstResult, which is currently defined in VarEnv, which is pretty near+the base of the module hierarchy.  So it seemed simpler to put the+defn of OccInfo here, safely at the bottom+-}++-- | identifier Occurrence Information+data OccInfo+  = ManyOccs        { occ_tail    :: !TailCallInfo }+                        -- ^ There are many occurrences, or unknown occurrences++  | IAmDead             -- ^ Marks unused variables.  Sometimes useful for+                        -- lambda and case-bound variables.++  | OneOcc          { occ_in_lam  :: !InsideLam+                    , occ_one_br  :: !OneBranch+                    , occ_int_cxt :: !InterestingCxt+                    , occ_tail    :: !TailCallInfo }+                        -- ^ Occurs exactly once (per branch), not inside a rule++  -- | This identifier breaks a loop of mutually recursive functions. The field+  -- marks whether it is only a loop breaker due to a reference in a rule+  | IAmALoopBreaker { occ_rules_only :: !RulesOnly+                    , occ_tail       :: !TailCallInfo }+                        -- Note [LoopBreaker OccInfo]++  deriving (Eq)++type RulesOnly = Bool++{-+Note [LoopBreaker OccInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~+   IAmALoopBreaker True  <=> A "weak" or rules-only loop breaker+                             Do not preInlineUnconditionally++   IAmALoopBreaker False <=> A "strong" loop breaker+                             Do not inline at all++See OccurAnal Note [Weak loop breakers]+-}++noOccInfo :: OccInfo+noOccInfo = ManyOccs { occ_tail = NoTailCallInfo }++isManyOccs :: OccInfo -> Bool+isManyOccs ManyOccs{} = True+isManyOccs _          = False++seqOccInfo :: OccInfo -> ()+seqOccInfo occ = occ `seq` ()++-----------------+-- | Interesting Context+type InterestingCxt = Bool      -- True <=> Function: is applied+                                --          Data value: scrutinised by a case with+                                --                      at least one non-DEFAULT branch++-----------------+-- | Inside Lambda+type InsideLam = Bool   -- True <=> Occurs inside a non-linear lambda+                        -- Substituting a redex for this occurrence is+                        -- dangerous because it might duplicate work.+insideLam, notInsideLam :: InsideLam+insideLam    = True+notInsideLam = False++-----------------+type OneBranch = Bool   -- True <=> Occurs in only one case branch+                        --      so no code-duplication issue to worry about+oneBranch, notOneBranch :: OneBranch+oneBranch    = True+notOneBranch = False++-----------------+data TailCallInfo = AlwaysTailCalled JoinArity -- See Note [TailCallInfo]+                  | NoTailCallInfo+  deriving (Eq)++tailCallInfo :: OccInfo -> TailCallInfo+tailCallInfo IAmDead   = NoTailCallInfo+tailCallInfo other     = occ_tail other++zapOccTailCallInfo :: OccInfo -> OccInfo+zapOccTailCallInfo IAmDead   = IAmDead+zapOccTailCallInfo occ       = occ { occ_tail = NoTailCallInfo }++isAlwaysTailCalled :: OccInfo -> Bool+isAlwaysTailCalled occ+  = case tailCallInfo occ of AlwaysTailCalled{} -> True+                             NoTailCallInfo     -> False++instance Outputable TailCallInfo where+  ppr (AlwaysTailCalled ar) = sep [ text "Tail", int ar ]+  ppr _                     = empty++-----------------+strongLoopBreaker, weakLoopBreaker :: OccInfo+strongLoopBreaker = IAmALoopBreaker False NoTailCallInfo+weakLoopBreaker   = IAmALoopBreaker True  NoTailCallInfo++isWeakLoopBreaker :: OccInfo -> Bool+isWeakLoopBreaker (IAmALoopBreaker{}) = True+isWeakLoopBreaker _                   = False++isStrongLoopBreaker :: OccInfo -> Bool+isStrongLoopBreaker (IAmALoopBreaker { occ_rules_only = False }) = True+  -- Loop-breaker that breaks a non-rule cycle+isStrongLoopBreaker _                                            = False++isDeadOcc :: OccInfo -> Bool+isDeadOcc IAmDead = True+isDeadOcc _       = False++isOneOcc :: OccInfo -> Bool+isOneOcc (OneOcc {}) = True+isOneOcc _           = False++zapFragileOcc :: OccInfo -> OccInfo+-- Keep only the most robust data: deadness, loop-breaker-hood+zapFragileOcc (OneOcc {}) = noOccInfo+zapFragileOcc occ         = zapOccTailCallInfo occ++instance Outputable OccInfo where+  -- only used for debugging; never parsed.  KSW 1999-07+  ppr (ManyOccs tails)     = pprShortTailCallInfo tails+  ppr IAmDead              = text "Dead"+  ppr (IAmALoopBreaker rule_only tails)+        = text "LoopBreaker" <> pp_ro <> pprShortTailCallInfo tails+        where+          pp_ro | rule_only = char '!'+                | otherwise = empty+  ppr (OneOcc inside_lam one_branch int_cxt tail_info)+        = text "Once" <> pp_lam <> pp_br <> pp_args <> pp_tail+        where+          pp_lam | inside_lam = char 'L'+                 | otherwise  = empty+          pp_br  | one_branch = empty+                 | otherwise  = char '*'+          pp_args | int_cxt   = char '!'+                  | otherwise = empty+          pp_tail             = pprShortTailCallInfo tail_info++pprShortTailCallInfo :: TailCallInfo -> SDoc+pprShortTailCallInfo (AlwaysTailCalled ar) = char 'T' <> brackets (int ar)+pprShortTailCallInfo NoTailCallInfo        = empty++{-+Note [TailCallInfo]+~~~~~~~~~~~~~~~~~~~+The occurrence analyser determines what can be made into a join point, but it+doesn't change the binder into a JoinId because then it would be inconsistent+with the occurrences. Thus it's left to the simplifier (or to simpleOptExpr) to+change the IdDetails.++The AlwaysTailCalled marker actually means slightly more than simply that the+function is always tail-called. See Note [Invariants on join points].++This info is quite fragile and should not be relied upon unless the occurrence+analyser has *just* run. Use 'Id.isJoinId_maybe' for the permanent state of+the join-point-hood of a binder; a join id itself will not be marked+AlwaysTailCalled.++Note that there is a 'TailCallInfo' on a 'ManyOccs' value. One might expect that+being tail-called would mean that the variable could only appear once per branch+(thus getting a `OneOcc { occ_one_br = True }` occurrence info), but a join+point can also be invoked from other join points, not just from case branches:++  let j1 x = ...+      j2 y = ... j1 z {- tail call -} ...+  in case w of+       A -> j1 v+       B -> j2 u+       C -> j2 q++Here both 'j1' and 'j2' will get marked AlwaysTailCalled, but j1 will get+ManyOccs and j2 will get `OneOcc { occ_one_br = True }`.++************************************************************************+*                                                                      *+                Default method specification+*                                                                      *+************************************************************************++The DefMethSpec enumeration just indicates what sort of default method+is used for a class. It is generated from source code, and present in+interface files; it is converted to Class.DefMethInfo before begin put in a+Class object.+-}++-- | Default Method Specification+data DefMethSpec ty+  = VanillaDM     -- Default method given with polymorphic code+  | GenericDM ty  -- Default method given with code of this type++instance Outputable (DefMethSpec ty) where+  ppr VanillaDM      = text "{- Has default method -}"+  ppr (GenericDM {}) = text "{- Has generic default method -}"++{-+************************************************************************+*                                                                      *+\subsection{Success flag}+*                                                                      *+************************************************************************+-}++data SuccessFlag = Succeeded | Failed++instance Outputable SuccessFlag where+    ppr Succeeded = text "Succeeded"+    ppr Failed    = text "Failed"++successIf :: Bool -> SuccessFlag+successIf True  = Succeeded+successIf False = Failed++succeeded, failed :: SuccessFlag -> Bool+succeeded Succeeded = True+succeeded Failed    = False++failed Succeeded = False+failed Failed    = True++{-+************************************************************************+*                                                                      *+\subsection{Source Text}+*                                                                      *+************************************************************************+Keeping Source Text for source to source conversions++Note [Pragma source text]+~~~~~~~~~~~~~~~~~~~~~~~~~+The lexer does a case-insensitive match for pragmas, as well as+accepting both UK and US spelling variants.++So++  {-# SPECIALISE #-}+  {-# SPECIALIZE #-}+  {-# Specialize #-}++will all generate ITspec_prag token for the start of the pragma.++In order to be able to do source to source conversions, the original+source text for the token needs to be preserved, hence the+`SourceText` field.++So the lexer will then generate++  ITspec_prag "{ -# SPECIALISE"+  ITspec_prag "{ -# SPECIALIZE"+  ITspec_prag "{ -# Specialize"++for the cases above.+ [without the space between '{' and '-', otherwise this comment won't parse]+++Note [Literal source text]+~~~~~~~~~~~~~~~~~~~~~~~~~~+The lexer/parser converts literals from their original source text+versions to an appropriate internal representation. This is a problem+for tools doing source to source conversions, so the original source+text is stored in literals where this can occur.++Motivating examples for HsLit++  HsChar          '\n'       == '\x20`+  HsCharPrim      '\x41`#    == `A`+  HsString        "\x20\x41" == " A"+  HsStringPrim    "\x20"#    == " "#+  HsInt           001        == 1+  HsIntPrim       002#       == 2#+  HsWordPrim      003##      == 3##+  HsInt64Prim     004##      == 4##+  HsWord64Prim    005##      == 5##+  HsInteger       006        == 6++For OverLitVal++  HsIntegral      003      == 0x003+  HsIsString      "\x41nd" == "And"+-}++ -- Note [Literal source text],[Pragma source text]+data SourceText = SourceText String+                | NoSourceText -- ^ For when code is generated, e.g. TH,+                               -- deriving. The pretty printer will then make+                               -- its own representation of the item.+                deriving (Data, Show, Eq )++instance Outputable SourceText where+  ppr (SourceText s) = text "SourceText" <+> text s+  ppr NoSourceText   = text "NoSourceText"++-- | Special combinator for showing string literals.+pprWithSourceText :: SourceText -> SDoc -> SDoc+pprWithSourceText NoSourceText     d = d+pprWithSourceText (SourceText src) _ = text src++{-+************************************************************************+*                                                                      *+\subsection{Activation}+*                                                                      *+************************************************************************++When a rule or inlining is active+-}++-- | Phase Number+type PhaseNum = Int  -- Compilation phase+                     -- Phases decrease towards zero+                     -- Zero is the last phase++data CompilerPhase+  = Phase PhaseNum+  | InitialPhase    -- The first phase -- number = infinity!++instance Outputable CompilerPhase where+   ppr (Phase n)    = int n+   ppr InitialPhase = text "InitialPhase"++-- See note [Pragma source text]+data Activation = NeverActive+                | AlwaysActive+                | ActiveBefore SourceText PhaseNum+                  -- Active only *strictly before* this phase+                | ActiveAfter SourceText PhaseNum+                  -- Active in this phase and later+                deriving( Eq, Data )+                  -- Eq used in comparing rules in HsDecls++-- | Rule Match Information+data RuleMatchInfo = ConLike                    -- See Note [CONLIKE pragma]+                   | FunLike+                   deriving( Eq, Data, Show )+        -- Show needed for Lexer.x++data InlinePragma            -- Note [InlinePragma]+  = InlinePragma+      { inl_src    :: SourceText -- Note [Pragma source text]+      , inl_inline :: InlineSpec -- See Note [inl_inline and inl_act]++      , inl_sat    :: Maybe Arity    -- Just n <=> Inline only when applied to n+                                     --            explicit (non-type, non-dictionary) args+                                     --   That is, inl_sat describes the number of *source-code*+                                     --   arguments the thing must be applied to.  We add on the+                                     --   number of implicit, dictionary arguments when making+                                     --   the Unfolding, and don't look at inl_sat further++      , inl_act    :: Activation     -- Says during which phases inlining is allowed+                                     -- See Note [inl_inline and inl_act]++      , inl_rule   :: RuleMatchInfo  -- Should the function be treated like a constructor?+    } deriving( Eq, Data )++-- | Inline Specification+data InlineSpec   -- What the user's INLINE pragma looked like+  = Inline+  | Inlinable+  | NoInline+  | EmptyInlineSpec  -- Used in a place-holder InlinePragma in SpecPrag or IdInfo,+                     -- where there isn't any real inline pragma at all+  deriving( Eq, Data, Show )+        -- Show needed for Lexer.x++{- Note [InlinePragma]+~~~~~~~~~~~~~~~~~~~~~~+This data type mirrors what you can write in an INLINE or NOINLINE pragma in+the source program.++If you write nothing at all, you get defaultInlinePragma:+   inl_inline = EmptyInlineSpec+   inl_act    = AlwaysActive+   inl_rule   = FunLike++It's not possible to get that combination by *writing* something, so+if an Id has defaultInlinePragma it means the user didn't specify anything.++If inl_inline = Inline or Inlineable, then the Id should have an InlineRule unfolding.++If you want to know where InlinePragmas take effect: Look in DsBinds.makeCorePair++Note [inl_inline and inl_act]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* inl_inline says what the user wrote: did she say INLINE, NOINLINE,+  INLINABLE, or nothing at all++* inl_act says in what phases the unfolding is active or inactive+  E.g  If you write INLINE[1]    then inl_act will be set to ActiveAfter 1+       If you write NOINLINE[1]  then inl_act will be set to ActiveBefore 1+       If you write NOINLINE[~1] then inl_act will be set to ActiveAfter 1+  So note that inl_act does not say what pragma you wrote: it just+  expresses its consequences++* inl_act just says when the unfolding is active; it doesn't say what+  to inline.  If you say INLINE f, then f's inl_act will be AlwaysActive,+  but in addition f will get a "stable unfolding" with UnfoldingGuidance+  that tells the inliner to be pretty eager about it.++Note [CONLIKE pragma]+~~~~~~~~~~~~~~~~~~~~~+The ConLike constructor of a RuleMatchInfo is aimed at the following.+Consider first+    {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-}+    g b bs = let x = b:bs in ..x...x...(r x)...+Now, the rule applies to the (r x) term, because GHC "looks through"+the definition of 'x' to see that it is (b:bs).++Now consider+    {-# RULE "r/f" forall v. r (f v) = f (v+1) #-}+    g v = let x = f v in ..x...x...(r x)...+Normally the (r x) would *not* match the rule, because GHC would be+scared about duplicating the redex (f v), so it does not "look+through" the bindings.++However the CONLIKE modifier says to treat 'f' like a constructor in+this situation, and "look through" the unfolding for x.  So (r x)+fires, yielding (f (v+1)).++This is all controlled with a user-visible pragma:+     {-# NOINLINE CONLIKE [1] f #-}++The main effects of CONLIKE are:++    - The occurrence analyser (OccAnal) and simplifier (Simplify) treat+      CONLIKE thing like constructors, by ANF-ing them++    - New function coreUtils.exprIsExpandable is like exprIsCheap, but+      additionally spots applications of CONLIKE functions++    - A CoreUnfolding has a field that caches exprIsExpandable++    - The rule matcher consults this field.  See+      Note [Expanding variables] in Rules.hs.+-}++isConLike :: RuleMatchInfo -> Bool+isConLike ConLike = True+isConLike _       = False++isFunLike :: RuleMatchInfo -> Bool+isFunLike FunLike = True+isFunLike _       = False++isEmptyInlineSpec :: InlineSpec -> Bool+isEmptyInlineSpec EmptyInlineSpec = True+isEmptyInlineSpec _               = False++defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma+  :: InlinePragma+defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE"+                                   , inl_act = AlwaysActive+                                   , inl_rule = FunLike+                                   , inl_inline = EmptyInlineSpec+                                   , inl_sat = Nothing }++alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline }+neverInlinePragma  = defaultInlinePragma { inl_act    = NeverActive }++inlinePragmaSpec :: InlinePragma -> InlineSpec+inlinePragmaSpec = inl_inline++-- A DFun has an always-active inline activation so that+-- exprIsConApp_maybe can "see" its unfolding+-- (However, its actual Unfolding is a DFunUnfolding, which is+--  never inlined other than via exprIsConApp_maybe.)+dfunInlinePragma   = defaultInlinePragma { inl_act  = AlwaysActive+                                         , inl_rule = ConLike }++isDefaultInlinePragma :: InlinePragma -> Bool+isDefaultInlinePragma (InlinePragma { inl_act = activation+                                    , inl_rule = match_info+                                    , inl_inline = inline })+  = isEmptyInlineSpec inline && isAlwaysActive activation && isFunLike match_info++isInlinePragma :: InlinePragma -> Bool+isInlinePragma prag = case inl_inline prag of+                        Inline -> True+                        _      -> False++isInlinablePragma :: InlinePragma -> Bool+isInlinablePragma prag = case inl_inline prag of+                           Inlinable -> True+                           _         -> False++isAnyInlinePragma :: InlinePragma -> Bool+-- INLINE or INLINABLE+isAnyInlinePragma prag = case inl_inline prag of+                        Inline    -> True+                        Inlinable -> True+                        _         -> False++inlinePragmaSat :: InlinePragma -> Maybe Arity+inlinePragmaSat = inl_sat++inlinePragmaActivation :: InlinePragma -> Activation+inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation++inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo+inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info++setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma+setInlinePragmaActivation prag activation = prag { inl_act = activation }++setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma+setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info }++instance Outputable Activation where+   ppr AlwaysActive       = empty+   ppr NeverActive        = brackets (text "~")+   ppr (ActiveBefore _ n) = brackets (char '~' <> int n)+   ppr (ActiveAfter  _ n) = brackets (int n)++instance Outputable RuleMatchInfo where+   ppr ConLike = text "CONLIKE"+   ppr FunLike = text "FUNLIKE"++instance Outputable InlineSpec where+   ppr Inline          = text "INLINE"+   ppr NoInline        = text "NOINLINE"+   ppr Inlinable       = text "INLINABLE"+   ppr EmptyInlineSpec = empty++instance Outputable InlinePragma where+  ppr = pprInline++pprInline :: InlinePragma -> SDoc+pprInline = pprInline' True++pprInlineDebug :: InlinePragma -> SDoc+pprInlineDebug = pprInline' False++pprInline' :: Bool -> InlinePragma -> SDoc+pprInline' emptyInline (InlinePragma { inl_inline = inline, inl_act = activation+                                    , inl_rule = info, inl_sat = mb_arity })+    = pp_inl inline <> pp_act inline activation <+> pp_sat <+> pp_info+    where+      pp_inl x = if emptyInline then empty else ppr x++      pp_act Inline   AlwaysActive = empty+      pp_act NoInline NeverActive  = empty+      pp_act _        act          = ppr act++      pp_sat | Just ar <- mb_arity = parens (text "sat-args=" <> int ar)+             | otherwise           = empty+      pp_info | isFunLike info = empty+              | otherwise      = ppr info++isActive :: CompilerPhase -> Activation -> Bool+isActive InitialPhase AlwaysActive      = True+isActive InitialPhase (ActiveBefore {}) = True+isActive InitialPhase _                 = False+isActive (Phase p)    act               = isActiveIn p act++isActiveIn :: PhaseNum -> Activation -> Bool+isActiveIn _ NeverActive        = False+isActiveIn _ AlwaysActive       = True+isActiveIn p (ActiveAfter _ n)  = p <= n+isActiveIn p (ActiveBefore _ n) = p >  n++competesWith :: Activation -> Activation -> Bool+-- See Note [Activation competition]+competesWith NeverActive       _                = False+competesWith _                 NeverActive      = False+competesWith AlwaysActive      _                = True++competesWith (ActiveBefore {})  AlwaysActive      = True+competesWith (ActiveBefore {})  (ActiveBefore {}) = True+competesWith (ActiveBefore _ a) (ActiveAfter _ b) = a < b++competesWith (ActiveAfter {})  AlwaysActive      = False+competesWith (ActiveAfter {})  (ActiveBefore {}) = False+competesWith (ActiveAfter _ a) (ActiveAfter _ b) = a >= b++{- Note [Competing activations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Sometimes a RULE and an inlining may compete, or two RULES.+See Note [Rules and inlining/other rules] in Desugar.++We say that act1 "competes with" act2 iff+   act1 is active in the phase when act2 *becomes* active+NB: remember that phases count *down*: 2, 1, 0!++It's too conservative to ensure that the two are never simultaneously+active.  For example, a rule might be always active, and an inlining+might switch on in phase 2.  We could switch off the rule, but it does+no harm.+-}++isNeverActive, isAlwaysActive, isEarlyActive :: Activation -> Bool+isNeverActive NeverActive = True+isNeverActive _           = False++isAlwaysActive AlwaysActive = True+isAlwaysActive _            = False++isEarlyActive AlwaysActive      = True+isEarlyActive (ActiveBefore {}) = True+isEarlyActive _                 = False++-- | Fractional Literal+--+-- Used (instead of Rational) to represent exactly the floating point literal that we+-- encountered in the user's source program. This allows us to pretty-print exactly what+-- the user wrote, which is important e.g. for floating point numbers that can't represented+-- as Doubles (we used to via Double for pretty-printing). See also #2245.+data FractionalLit+  = FL { fl_text :: String         -- How the value was written in the source+       , fl_value :: Rational      -- Numeric value of the literal+       }+  deriving (Data, Show)+  -- The Show instance is required for the derived Lexer.x:Token instance when DEBUG is on++negateFractionalLit :: FractionalLit -> FractionalLit+negateFractionalLit (FL { fl_text = '-':text, fl_value = value }) = FL { fl_text = text, fl_value = negate value }+negateFractionalLit (FL { fl_text = text, fl_value = value }) = FL { fl_text = '-':text, fl_value = negate value }++integralFractionalLit :: Integer -> FractionalLit+integralFractionalLit i = FL { fl_text = show i, fl_value = fromInteger i }++-- Comparison operations are needed when grouping literals+-- for compiling pattern-matching (module MatchLit)++instance Eq FractionalLit where+  (==) = (==) `on` fl_value++instance Ord FractionalLit where+  compare = compare `on` fl_value++instance Outputable FractionalLit where+  ppr = text . fl_text++{-+************************************************************************+*                                                                      *+    IntWithInf+*                                                                      *+************************************************************************++Represents an integer or positive infinity++-}++-- | An integer or infinity+data IntWithInf = Int {-# UNPACK #-} !Int+                | Infinity+  deriving Eq++-- | A representation of infinity+infinity :: IntWithInf+infinity = Infinity++instance Ord IntWithInf where+  compare Infinity Infinity = EQ+  compare (Int _)  Infinity = LT+  compare Infinity (Int _)  = GT+  compare (Int a)  (Int b)  = a `compare` b++instance Outputable IntWithInf where+  ppr Infinity = char '∞'+  ppr (Int n)  = int n++instance Num IntWithInf where+  (+) = plusWithInf+  (*) = mulWithInf++  abs Infinity = Infinity+  abs (Int n)  = Int (abs n)++  signum Infinity = Int 1+  signum (Int n)  = Int (signum n)++  fromInteger = Int . fromInteger++  (-) = panic "subtracting IntWithInfs"++intGtLimit :: Int -> IntWithInf -> Bool+intGtLimit _ Infinity = False+intGtLimit n (Int m)  = n > m++-- | Add two 'IntWithInf's+plusWithInf :: IntWithInf -> IntWithInf -> IntWithInf+plusWithInf Infinity _        = Infinity+plusWithInf _        Infinity = Infinity+plusWithInf (Int a)  (Int b)  = Int (a + b)++-- | Multiply two 'IntWithInf's+mulWithInf :: IntWithInf -> IntWithInf -> IntWithInf+mulWithInf Infinity _        = Infinity+mulWithInf _        Infinity = Infinity+mulWithInf (Int a)  (Int b)  = Int (a * b)++-- | Turn a positive number into an 'IntWithInf', where 0 represents infinity+treatZeroAsInf :: Int -> IntWithInf+treatZeroAsInf 0 = Infinity+treatZeroAsInf n = Int n++-- | Inject any integer into an 'IntWithInf'+mkIntWithInf :: Int -> IntWithInf+mkIntWithInf = Int++data SpliceExplicitFlag+          = ExplicitSplice | -- ^ <=> $(f x y)+            ImplicitSplice   -- ^ <=> f x y,  i.e. a naked top level expression+    deriving Data
+ basicTypes/ConLike.hs view
@@ -0,0 +1,192 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1998++\section[ConLike]{@ConLike@: Constructor-like things}+-}++{-# LANGUAGE CPP #-}++module ConLike (+          ConLike(..)+        , conLikeArity+        , conLikeFieldLabels+        , conLikeInstOrigArgTys+        , conLikeExTyVars+        , conLikeName+        , conLikeStupidTheta+        , conLikeWrapId_maybe+        , conLikeImplBangs+        , conLikeFullSig+        , conLikeResTy+        , conLikeFieldType+        , conLikesWithFields+        , conLikeIsInfix+    ) where++#include "HsVersions.h"++import DataCon+import PatSyn+import Outputable+import Unique+import Util+import Name+import BasicTypes+import TyCoRep (Type, ThetaType)+import Var+import Type (mkTyConApp)++import qualified Data.Data as Data++{-+************************************************************************+*                                                                      *+\subsection{Constructor-like things}+*                                                                      *+************************************************************************+-}++-- | A constructor-like thing+data ConLike = RealDataCon DataCon+             | PatSynCon PatSyn++{-+************************************************************************+*                                                                      *+\subsection{Instances}+*                                                                      *+************************************************************************+-}++instance Eq ConLike where+    (==) = eqConLike++eqConLike :: ConLike -> ConLike -> Bool+eqConLike x y = getUnique x == getUnique y++-- There used to be an Ord ConLike instance here that used Unique for ordering.+-- It was intentionally removed to prevent determinism problems.+-- See Note [Unique Determinism] in Unique.++instance Uniquable ConLike where+    getUnique (RealDataCon dc) = getUnique dc+    getUnique (PatSynCon ps)   = getUnique ps++instance NamedThing ConLike where+    getName (RealDataCon dc) = getName dc+    getName (PatSynCon ps)   = getName ps++instance Outputable ConLike where+    ppr (RealDataCon dc) = ppr dc+    ppr (PatSynCon ps) = ppr ps++instance OutputableBndr ConLike where+    pprInfixOcc (RealDataCon dc) = pprInfixOcc dc+    pprInfixOcc (PatSynCon ps) = pprInfixOcc ps+    pprPrefixOcc (RealDataCon dc) = pprPrefixOcc dc+    pprPrefixOcc (PatSynCon ps) = pprPrefixOcc ps++instance Data.Data ConLike where+    -- don't traverse?+    toConstr _   = abstractConstr "ConLike"+    gunfold _ _  = error "gunfold"+    dataTypeOf _ = mkNoRepType "ConLike"++-- | Number of arguments+conLikeArity :: ConLike -> Arity+conLikeArity (RealDataCon data_con) = dataConSourceArity data_con+conLikeArity (PatSynCon pat_syn)    = patSynArity pat_syn++-- | Names of fields used for selectors+conLikeFieldLabels :: ConLike -> [FieldLabel]+conLikeFieldLabels (RealDataCon data_con) = dataConFieldLabels data_con+conLikeFieldLabels (PatSynCon pat_syn)    = patSynFieldLabels pat_syn++-- | Returns just the instantiated /value/ argument types of a 'ConLike',+-- (excluding dictionary args)+conLikeInstOrigArgTys :: ConLike -> [Type] -> [Type]+conLikeInstOrigArgTys (RealDataCon data_con) tys =+    dataConInstOrigArgTys data_con tys+conLikeInstOrigArgTys (PatSynCon pat_syn) tys =+    patSynInstArgTys pat_syn tys++-- | Existentially quantified type variables+conLikeExTyVars :: ConLike -> [TyVar]+conLikeExTyVars (RealDataCon dcon1) = dataConExTyVars dcon1+conLikeExTyVars (PatSynCon psyn1)   = patSynExTyVars psyn1++conLikeName :: ConLike -> Name+conLikeName (RealDataCon data_con) = dataConName data_con+conLikeName (PatSynCon pat_syn)    = patSynName pat_syn++-- | The \"stupid theta\" of the 'ConLike', such as @data Eq a@ in:+--+-- > data Eq a => T a = ...+-- It is empty for `PatSynCon` as they do not allow such contexts.+conLikeStupidTheta :: ConLike -> ThetaType+conLikeStupidTheta (RealDataCon data_con) = dataConStupidTheta data_con+conLikeStupidTheta (PatSynCon {})         = []++-- | Returns the `Id` of the wrapper. This is also known as the builder in+-- some contexts. The value is Nothing only in the case of unidirectional+-- pattern synonyms.+conLikeWrapId_maybe :: ConLike -> Maybe Id+conLikeWrapId_maybe (RealDataCon data_con) = Just $ dataConWrapId data_con+conLikeWrapId_maybe (PatSynCon pat_syn)    = fst <$> patSynBuilder pat_syn++-- | Returns the strictness information for each constructor+conLikeImplBangs :: ConLike -> [HsImplBang]+conLikeImplBangs (RealDataCon data_con) = dataConImplBangs data_con+conLikeImplBangs (PatSynCon pat_syn)    =+    replicate (patSynArity pat_syn) HsLazy++-- | Returns the type of the whole pattern+conLikeResTy :: ConLike -> [Type] -> Type+conLikeResTy (RealDataCon con) tys = mkTyConApp (dataConTyCon con) tys+conLikeResTy (PatSynCon ps)    tys = patSynInstResTy ps tys++-- | The \"full signature\" of the 'ConLike' returns, in order:+--+-- 1) The universally quantified type variables+--+-- 2) The existentially quantified type variables+--+-- 3) The equality specification+--+-- 4) The provided theta (the constraints provided by a match)+--+-- 5) The required theta (the constraints required for a match)+--+-- 6) The original argument types (i.e. before+--    any change of the representation of the type)+--+-- 7) The original result type+conLikeFullSig :: ConLike+               -> ([TyVar], [TyVar], [EqSpec]+                  , ThetaType, ThetaType, [Type], Type)+conLikeFullSig (RealDataCon con) =+  let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con+  -- Required theta is empty as normal data cons require no additional+  -- constraints for a match+  in (univ_tvs, ex_tvs, eq_spec, theta, [], arg_tys, res_ty)+conLikeFullSig (PatSynCon pat_syn) =+ let (univ_tvs, req, ex_tvs, prov, arg_tys, res_ty) = patSynSig pat_syn+ -- eqSpec is empty+ in (univ_tvs, ex_tvs, [], prov, req, arg_tys, res_ty)++-- | Extract the type for any given labelled field of the 'ConLike'+conLikeFieldType :: ConLike -> FieldLabelString -> Type+conLikeFieldType (PatSynCon ps) label = patSynFieldType ps label+conLikeFieldType (RealDataCon dc) label = dataConFieldType dc label+++-- | The ConLikes that have *all* the given fields+conLikesWithFields :: [ConLike] -> [FieldLabelString] -> [ConLike]+conLikesWithFields con_likes lbls = filter has_flds con_likes+  where has_flds dc = all (has_fld dc) lbls+        has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc)++conLikeIsInfix :: ConLike -> Bool+conLikeIsInfix (RealDataCon dc) = dataConIsInfix dc+conLikeIsInfix (PatSynCon ps)   = patSynIsInfix  ps
+ basicTypes/ConLike.hs-boot view
@@ -0,0 +1,9 @@+module ConLike where+import {-# SOURCE #-} DataCon (DataCon)+import {-# SOURCE #-} PatSyn (PatSyn)+import Name ( Name )++data ConLike = RealDataCon DataCon+             | PatSynCon PatSyn++conLikeName :: ConLike -> Name
+ basicTypes/DataCon.hs view
@@ -0,0 +1,1324 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1998++\section[DataCon]{@DataCon@: Data Constructors}+-}++{-# LANGUAGE CPP, DeriveDataTypeable #-}++module DataCon (+        -- * Main data types+        DataCon, DataConRep(..),+        SrcStrictness(..), SrcUnpackedness(..),+        HsSrcBang(..), HsImplBang(..),+        StrictnessMark(..),+        ConTag,++        -- ** Equality specs+        EqSpec, mkEqSpec, eqSpecTyVar, eqSpecType,+        eqSpecPair, eqSpecPreds,+        substEqSpec, filterEqSpec,++        -- ** Field labels+        FieldLbl(..), FieldLabel, FieldLabelString,++        -- ** Type construction+        mkDataCon, buildAlgTyCon, buildSynTyCon, fIRST_TAG,++        -- ** Type deconstruction+        dataConRepType, dataConSig, dataConInstSig, dataConFullSig,+        dataConName, dataConIdentity, dataConTag, dataConTyCon,+        dataConOrigTyCon, dataConUserType,+        dataConUnivTyVars, dataConUnivTyVarBinders,+        dataConExTyVars, dataConExTyVarBinders,+        dataConAllTyVars,+        dataConEqSpec, dataConTheta,+        dataConStupidTheta,+        dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,+        dataConInstOrigArgTys, dataConRepArgTys,+        dataConFieldLabels, dataConFieldType, dataConFieldType_maybe,+        dataConSrcBangs,+        dataConSourceArity, dataConRepArity,+        dataConIsInfix,+        dataConWorkId, dataConWrapId, dataConWrapId_maybe,+        dataConImplicitTyThings,+        dataConRepStrictness, dataConImplBangs, dataConBoxer,++        splitDataProductType_maybe,++        -- ** Predicates on DataCons+        isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon,+        isUnboxedSumCon,+        isVanillaDataCon, classDataCon, dataConCannotMatch,+        isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked,+        specialPromotedDc, isLegacyPromotableDataCon, isLegacyPromotableTyCon,++        -- ** Promotion related functions+        promoteDataCon+    ) where++#include "HsVersions.h"++import {-# SOURCE #-} MkId( DataConBoxer )+import Type+import ForeignCall ( CType )+import Coercion+import Unify+import TyCon+import FieldLabel+import Class+import Name+import PrelNames+import Var+import Outputable+import ListSetOps+import Util+import BasicTypes+import FastString+import Module+import Binary+import UniqSet+import Unique( mkAlphaTyVarUnique )++import qualified Data.Data as Data+import Data.Char+import Data.Word+import Data.List( mapAccumL, find )++{-+Data constructor representation+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following Haskell data type declaration++        data T = T !Int ![Int]++Using the strictness annotations, GHC will represent this as++        data T = T Int# [Int]++That is, the Int has been unboxed.  Furthermore, the Haskell source construction++        T e1 e2++is translated to++        case e1 of { I# x ->+        case e2 of { r ->+        T x r }}++That is, the first argument is unboxed, and the second is evaluated.  Finally,+pattern matching is translated too:++        case e of { T a b -> ... }++becomes++        case e of { T a' b -> let a = I# a' in ... }++To keep ourselves sane, we name the different versions of the data constructor+differently, as follows.+++Note [Data Constructor Naming]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Each data constructor C has two, and possibly up to four, Names associated with it:++                   OccName   Name space   Name of   Notes+ ---------------------------------------------------------------------------+ The "data con itself"   C     DataName   DataCon   In dom( GlobalRdrEnv )+ The "worker data con"   C     VarName    Id        The worker+ The "wrapper data con"  $WC   VarName    Id        The wrapper+ The "newtype coercion"  :CoT  TcClsName  TyCon++EVERY data constructor (incl for newtypes) has the former two (the+data con itself, and its worker.  But only some data constructors have a+wrapper (see Note [The need for a wrapper]).++Each of these three has a distinct Unique.  The "data con itself" name+appears in the output of the renamer, and names the Haskell-source+data constructor.  The type checker translates it into either the wrapper Id+(if it exists) or worker Id (otherwise).++The data con has one or two Ids associated with it:++The "worker Id", is the actual data constructor.+* Every data constructor (newtype or data type) has a worker++* The worker is very like a primop, in that it has no binding.++* For a *data* type, the worker *is* the data constructor;+  it has no unfolding++* For a *newtype*, the worker has a compulsory unfolding which+  does a cast, e.g.+        newtype T = MkT Int+        The worker for MkT has unfolding+                \\(x:Int). x `cast` sym CoT+  Here CoT is the type constructor, witnessing the FC axiom+        axiom CoT : T = Int++The "wrapper Id", \$WC, goes as follows++* Its type is exactly what it looks like in the source program.++* It is an ordinary function, and it gets a top-level binding+  like any other function.++* The wrapper Id isn't generated for a data type if there is+  nothing for the wrapper to do.  That is, if its defn would be+        \$wC = C++Note [The need for a wrapper]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Why might the wrapper have anything to do?  Two reasons:++* Unboxing strict fields (with -funbox-strict-fields)+        data T = MkT !(Int,Int)+        \$wMkT :: (Int,Int) -> T+        \$wMkT (x,y) = MkT x y+  Notice that the worker has two fields where the wapper has+  just one.  That is, the worker has type+                MkT :: Int -> Int -> T++* Equality constraints for GADTs+        data T a where { MkT :: a -> T [a] }++  The worker gets a type with explicit equality+  constraints, thus:+        MkT :: forall a b. (a=[b]) => b -> T a++  The wrapper has the programmer-specified type:+        \$wMkT :: a -> T [a]+        \$wMkT a x = MkT [a] a [a] x+  The third argument is a coercion+        [a] :: [a]~[a]++INVARIANT: the dictionary constructor for a class+           never has a wrapper.+++A note about the stupid context+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Data types can have a context:++        data (Eq a, Ord b) => T a b = T1 a b | T2 a++and that makes the constructors have a context too+(notice that T2's context is "thinned"):++        T1 :: (Eq a, Ord b) => a -> b -> T a b+        T2 :: (Eq a) => a -> T a b++Furthermore, this context pops up when pattern matching+(though GHC hasn't implemented this, but it is in H98, and+I've fixed GHC so that it now does):++        f (T2 x) = x+gets inferred type+        f :: Eq a => T a b -> a++I say the context is "stupid" because the dictionaries passed+are immediately discarded -- they do nothing and have no benefit.+It's a flaw in the language.++        Up to now [March 2002] I have put this stupid context into the+        type of the "wrapper" constructors functions, T1 and T2, but+        that turned out to be jolly inconvenient for generics, and+        record update, and other functions that build values of type T+        (because they don't have suitable dictionaries available).++        So now I've taken the stupid context out.  I simply deal with+        it separately in the type checker on occurrences of a+        constructor, either in an expression or in a pattern.++        [May 2003: actually I think this decision could evasily be+        reversed now, and probably should be.  Generics could be+        disabled for types with a stupid context; record updates now+        (H98) needs the context too; etc.  It's an unforced change, so+        I'm leaving it for now --- but it does seem odd that the+        wrapper doesn't include the stupid context.]++[July 04] With the advent of generalised data types, it's less obvious+what the "stupid context" is.  Consider+        C :: forall a. Ord a => a -> a -> T (Foo a)+Does the C constructor in Core contain the Ord dictionary?  Yes, it must:++        f :: T b -> Ordering+        f = /\b. \x:T b.+            case x of+                C a (d:Ord a) (p:a) (q:a) -> compare d p q++Note that (Foo a) might not be an instance of Ord.++************************************************************************+*                                                                      *+\subsection{Data constructors}+*                                                                      *+************************************************************************+-}++-- | A data constructor+--+-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',+--             'ApiAnnotation.AnnClose','ApiAnnotation.AnnComma'++-- For details on above see note [Api annotations] in ApiAnnotation+data DataCon+  = MkData {+        dcName    :: Name,      -- This is the name of the *source data con*+                                -- (see "Note [Data Constructor Naming]" above)+        dcUnique :: Unique,     -- Cached from Name+        dcTag    :: ConTag,     -- ^ Tag, used for ordering 'DataCon's++        -- Running example:+        --+        --      *** As declared by the user+        --  data T a where+        --    MkT :: forall x y. (x~y,Ord x) => x -> y -> T (x,y)++        --      *** As represented internally+        --  data T a where+        --    MkT :: forall a. forall x y. (a~(x,y),x~y,Ord x) => x -> y -> T a+        --+        -- The next six fields express the type of the constructor, in pieces+        -- e.g.+        --+        --      dcUnivTyVars  = [a]+        --      dcExTyVars    = [x,y]+        --      dcEqSpec      = [a~(x,y)]+        --      dcOtherTheta  = [x~y, Ord x]+        --      dcOrigArgTys  = [x,y]+        --      dcRepTyCon       = T++        -- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE TYVARS+        -- FOR THE PARENT TyCon. (This is a change (Oct05): previously, vanilla+        -- datacons guaranteed to have the same type variables as their parent TyCon,+        -- but that seems ugly.)++        dcVanilla :: Bool,      -- True <=> This is a vanilla Haskell 98 data constructor+                                --          Its type is of form+                                --              forall a1..an . t1 -> ... tm -> T a1..an+                                --          No existentials, no coercions, nothing.+                                -- That is: dcExTyVars = dcEqSpec = dcOtherTheta = []+                -- NB 1: newtypes always have a vanilla data con+                -- NB 2: a vanilla constructor can still be declared in GADT-style+                --       syntax, provided its type looks like the above.+                --       The declaration format is held in the TyCon (algTcGadtSyntax)++        -- Universally-quantified type vars [a,b,c]+        -- INVARIANT: length matches arity of the dcRepTyCon+        -- INVARIANT: result type of data con worker is exactly (T a b c)+        dcUnivTyVars    :: [TyVarBinder],++        -- Existentially-quantified type vars [x,y]+        dcExTyVars     :: [TyVarBinder],++        -- INVARIANT: the UnivTyVars and ExTyVars all have distinct OccNames+        -- Reason: less confusing, and easier to generate IfaceSyn++        dcEqSpec :: [EqSpec],   -- Equalities derived from the result type,+                                -- _as written by the programmer_++                -- This field allows us to move conveniently between the two ways+                -- of representing a GADT constructor's type:+                --      MkT :: forall a b. (a ~ [b]) => b -> T a+                --      MkT :: forall b. b -> T [b]+                -- Each equality is of the form (a ~ ty), where 'a' is one of+                -- the universally quantified type variables++                -- The next two fields give the type context of the data constructor+                --      (aside from the GADT constraints,+                --       which are given by the dcExpSpec)+                -- In GADT form, this is *exactly* what the programmer writes, even if+                -- the context constrains only universally quantified variables+                --      MkT :: forall a b. (a ~ b, Ord b) => a -> T a b+        dcOtherTheta :: ThetaType,  -- The other constraints in the data con's type+                                    -- other than those in the dcEqSpec++        dcStupidTheta :: ThetaType,     -- The context of the data type declaration+                                        --      data Eq a => T a = ...+                                        -- or, rather, a "thinned" version thereof+                -- "Thinned", because the Report says+                -- to eliminate any constraints that don't mention+                -- tyvars free in the arg types for this constructor+                --+                -- INVARIANT: the free tyvars of dcStupidTheta are a subset of dcUnivTyVars+                -- Reason: dcStupidTeta is gotten by thinning the stupid theta from the tycon+                --+                -- "Stupid", because the dictionaries aren't used for anything.+                -- Indeed, [as of March 02] they are no longer in the type of+                -- the wrapper Id, because that makes it harder to use the wrap-id+                -- to rebuild values after record selection or in generics.++        dcOrigArgTys :: [Type],         -- Original argument types+                                        -- (before unboxing and flattening of strict fields)+        dcOrigResTy :: Type,            -- Original result type, as seen by the user+                -- NB: for a data instance, the original user result type may+                -- differ from the DataCon's representation TyCon.  Example+                --      data instance T [a] where MkT :: a -> T [a]+                -- The OrigResTy is T [a], but the dcRepTyCon might be :T123++        -- Now the strictness annotations and field labels of the constructor+        dcSrcBangs :: [HsSrcBang],+                -- See Note [Bangs on data constructor arguments]+                --+                -- The [HsSrcBang] as written by the programmer.+                --+                -- Matches 1-1 with dcOrigArgTys+                -- Hence length = dataConSourceArity dataCon++        dcFields  :: [FieldLabel],+                -- Field labels for this constructor, in the+                -- same order as the dcOrigArgTys;+                -- length = 0 (if not a record) or dataConSourceArity.++        -- The curried worker function that corresponds to the constructor:+        -- It doesn't have an unfolding; the code generator saturates these Ids+        -- and allocates a real constructor when it finds one.+        dcWorkId :: Id,++        -- Constructor representation+        dcRep      :: DataConRep,++        -- Cached; see Note [DataCon arities]+        -- INVARIANT: dcRepArity    == length dataConRepArgTys+        -- INVARIANT: dcSourceArity == length dcOrigArgTys+        dcRepArity    :: Arity,+        dcSourceArity :: Arity,++        -- Result type of constructor is T t1..tn+        dcRepTyCon  :: TyCon,           -- Result tycon, T++        dcRepType   :: Type,    -- Type of the constructor+                                --      forall a x y. (a~(x,y), x~y, Ord x) =>+                                --        x -> y -> T a+                                -- (this is *not* of the constructor wrapper Id:+                                --  see Note [Data con representation] below)+        -- Notice that the existential type parameters come *second*.+        -- Reason: in a case expression we may find:+        --      case (e :: T t) of+        --        MkT x y co1 co2 (d:Ord x) (v:r) (w:F s) -> ...+        -- It's convenient to apply the rep-type of MkT to 't', to get+        --      forall x y. (t~(x,y), x~y, Ord x) => x -> y -> T t+        -- and use that to check the pattern.  Mind you, this is really only+        -- used in CoreLint.+++        dcInfix :: Bool,        -- True <=> declared infix+                                -- Used for Template Haskell and 'deriving' only+                                -- The actual fixity is stored elsewhere++        dcPromoted :: TyCon    -- The promoted TyCon+                               -- See Note [Promoted data constructors] in TyCon+  }+++{- Note [TyVarBinders in DataCons]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For the TyVarBinders in a DataCon and PatSyn:++ * Each argument flag is Inferred or Specified.+   None are Required. (A DataCon is a term-level function; see+   Note [No Required TyBinder in terms] in TyCoRep.)++Why do we need the TyVarBinders, rather than just the TyVars?  So that+we can construct the right type for the DataCon with its foralls+attributed the correce visiblity.  That in turn governs whether you+can use visible type application at a call of the data constructor.++Note [DataCon arities]+~~~~~~~~~~~~~~~~~~~~~~+dcSourceArity does not take constraints into account,+but dcRepArity does.  For example:+   MkT :: Ord a => a -> T a+    dcSourceArity = 1+    dcRepArity    = 2+-}++-- | Data Constructor Representation+data DataConRep+  = NoDataConRep              -- No wrapper++  | DCR { dcr_wrap_id :: Id   -- Takes src args, unboxes/flattens,+                              -- and constructs the representation++        , dcr_boxer   :: DataConBoxer++        , dcr_arg_tys :: [Type]  -- Final, representation argument types,+                                 -- after unboxing and flattening,+                                 -- and *including* all evidence args++        , dcr_stricts :: [StrictnessMark]  -- 1-1 with dcr_arg_tys+                -- See also Note [Data-con worker strictness] in MkId.hs++        , dcr_bangs :: [HsImplBang]  -- The actual decisions made (including failures)+                                     -- about the original arguments; 1-1 with orig_arg_tys+                                     -- See Note [Bangs on data constructor arguments]++    }+-- Algebraic data types always have a worker, and+-- may or may not have a wrapper, depending on whether+-- the wrapper does anything.+--+-- Data types have a worker with no unfolding+-- Newtypes just have a worker, which has a compulsory unfolding (just a cast)++-- _Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments++-- The wrapper (if it exists) takes dcOrigArgTys as its arguments+-- The worker takes dataConRepArgTys as its arguments+-- If the worker is absent, dataConRepArgTys is the same as dcOrigArgTys++-- The 'NoDataConRep' case is important+-- Not only is this efficient,+-- but it also ensures that the wrapper is replaced+-- by the worker (because it *is* the worker)+-- even when there are no args. E.g. in+--              f (:) x+-- the (:) *is* the worker.+-- This is really important in rule matching,+-- (We could match on the wrappers,+-- but that makes it less likely that rules will match+-- when we bring bits of unfoldings together.)++-------------------------++-- | Haskell Source Bang+--+-- Bangs on data constructor arguments as the user wrote them in the+-- source code.+--+-- @(HsSrcBang _ SrcUnpack SrcLazy)@ and+-- @(HsSrcBang _ SrcUnpack NoSrcStrict)@ (without StrictData) makes no sense, we+-- emit a warning (in checkValidDataCon) and treat it like+-- @(HsSrcBang _ NoSrcUnpack SrcLazy)@+data HsSrcBang =+  HsSrcBang SourceText -- Note [Pragma source text] in BasicTypes+            SrcUnpackedness+            SrcStrictness+  deriving Data.Data++-- | Haskell Implementation Bang+--+-- Bangs of data constructor arguments as generated by the compiler+-- after consulting HsSrcBang, flags, etc.+data HsImplBang+  = HsLazy  -- ^ Lazy field+  | HsStrict  -- ^ Strict but not unpacked field+  | HsUnpack (Maybe Coercion)+    -- ^ Strict and unpacked field+    -- co :: arg-ty ~ product-ty HsBang+  deriving Data.Data++-- | Source Strictness+--+-- What strictness annotation the user wrote+data SrcStrictness = SrcLazy -- ^ Lazy, ie '~'+                   | SrcStrict -- ^ Strict, ie '!'+                   | NoSrcStrict -- ^ no strictness annotation+     deriving (Eq, Data.Data)++-- | Source Unpackedness+--+-- What unpackedness the user requested+data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified+                     | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified+                     | NoSrcUnpack -- ^ no unpack pragma+     deriving (Eq, Data.Data)++++-------------------------+-- StrictnessMark is internal only, used to indicate strictness+-- of the DataCon *worker* fields+data StrictnessMark = MarkedStrict | NotMarkedStrict++-- | An 'EqSpec' is a tyvar/type pair representing an equality made in+-- rejigging a GADT constructor+data EqSpec = EqSpec TyVar+                     Type++-- | Make an 'EqSpec'+mkEqSpec :: TyVar -> Type -> EqSpec+mkEqSpec tv ty = EqSpec tv ty++eqSpecTyVar :: EqSpec -> TyVar+eqSpecTyVar (EqSpec tv _) = tv++eqSpecType :: EqSpec -> Type+eqSpecType (EqSpec _ ty) = ty++eqSpecPair :: EqSpec -> (TyVar, Type)+eqSpecPair (EqSpec tv ty) = (tv, ty)++eqSpecPreds :: [EqSpec] -> ThetaType+eqSpecPreds spec = [ mkPrimEqPred (mkTyVarTy tv) ty+                   | EqSpec tv ty <- spec ]++-- | Substitute in an 'EqSpec'. Precondition: if the LHS of the EqSpec+-- is mapped in the substitution, it is mapped to a type variable, not+-- a full type.+substEqSpec :: TCvSubst -> EqSpec -> EqSpec+substEqSpec subst (EqSpec tv ty)+  = EqSpec tv' (substTy subst ty)+  where+    tv' = getTyVar "substEqSpec" (substTyVar subst tv)++-- | Filter out any TyBinders mentioned in an EqSpec+filterEqSpec :: [EqSpec] -> [TyVarBinder] -> [TyVarBinder]+filterEqSpec eq_spec+  = filter not_in_eq_spec+  where+    not_in_eq_spec bndr = let var = binderVar bndr in+                          all (not . (== var) . eqSpecTyVar) eq_spec++instance Outputable EqSpec where+  ppr (EqSpec tv ty) = ppr (tv, ty)++{- Note [Bangs on data constructor arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  data T = MkT !Int {-# UNPACK #-} !Int Bool++When compiling the module, GHC will decide how to represent+MkT, depending on the optimisation level, and settings of+flags like -funbox-small-strict-fields.++Terminology:+  * HsSrcBang:  What the user wrote+                Constructors: HsSrcBang++  * HsImplBang: What GHC decided+                Constructors: HsLazy, HsStrict, HsUnpack++* If T was defined in this module, MkT's dcSrcBangs field+  records the [HsSrcBang] of what the user wrote; in the example+    [ HsSrcBang _ NoSrcUnpack SrcStrict+    , HsSrcBang _ SrcUnpack SrcStrict+    , HsSrcBang _ NoSrcUnpack NoSrcStrictness]++* However, if T was defined in an imported module, the importing module+  must follow the decisions made in the original module, regardless of+  the flag settings in the importing module.+  Also see Note [Bangs on imported data constructors] in MkId++* The dcr_bangs field of the dcRep field records the [HsImplBang]+  If T was defined in this module, Without -O the dcr_bangs might be+    [HsStrict, HsStrict, HsLazy]+  With -O it might be+    [HsStrict, HsUnpack _, HsLazy]+  With -funbox-small-strict-fields it might be+    [HsUnpack, HsUnpack _, HsLazy]+  With -XStrictData it might be+    [HsStrict, HsUnpack _, HsStrict]++Note [Data con representation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The dcRepType field contains the type of the representation of a constructor+This may differ from the type of the constructor *Id* (built+by MkId.mkDataConId) for two reasons:+        a) the constructor Id may be overloaded, but the dictionary isn't stored+           e.g.    data Eq a => T a = MkT a a++        b) the constructor may store an unboxed version of a strict field.++Here's an example illustrating both:+        data Ord a => T a = MkT Int! a+Here+        T :: Ord a => Int -> a -> T a+but the rep type is+        Trep :: Int# -> a -> T a+Actually, the unboxed part isn't implemented yet!++++************************************************************************+*                                                                      *+\subsection{Instances}+*                                                                      *+************************************************************************+-}++instance Eq DataCon where+    a == b = getUnique a == getUnique b+    a /= b = getUnique a /= getUnique b++instance Uniquable DataCon where+    getUnique = dcUnique++instance NamedThing DataCon where+    getName = dcName++instance Outputable DataCon where+    ppr con = ppr (dataConName con)++instance OutputableBndr DataCon where+    pprInfixOcc con = pprInfixName (dataConName con)+    pprPrefixOcc con = pprPrefixName (dataConName con)++instance Data.Data DataCon where+    -- don't traverse?+    toConstr _   = abstractConstr "DataCon"+    gunfold _ _  = error "gunfold"+    dataTypeOf _ = mkNoRepType "DataCon"++instance Outputable HsSrcBang where+    ppr (HsSrcBang _ prag mark) = ppr prag <+> ppr mark++instance Outputable HsImplBang where+    ppr HsLazy                  = text "Lazy"+    ppr (HsUnpack Nothing)      = text "Unpacked"+    ppr (HsUnpack (Just co))    = text "Unpacked" <> parens (ppr co)+    ppr HsStrict                = text "StrictNotUnpacked"++instance Outputable SrcStrictness where+    ppr SrcLazy     = char '~'+    ppr SrcStrict   = char '!'+    ppr NoSrcStrict = empty++instance Outputable SrcUnpackedness where+    ppr SrcUnpack   = text "{-# UNPACK #-}"+    ppr SrcNoUnpack = text "{-# NOUNPACK #-}"+    ppr NoSrcUnpack = empty++instance Outputable StrictnessMark where+    ppr MarkedStrict    = text "!"+    ppr NotMarkedStrict = empty++instance Binary SrcStrictness where+    put_ bh SrcLazy     = putByte bh 0+    put_ bh SrcStrict   = putByte bh 1+    put_ bh NoSrcStrict = putByte bh 2++    get bh =+      do h <- getByte bh+         case h of+           0 -> return SrcLazy+           1 -> return SrcStrict+           _ -> return NoSrcStrict++instance Binary SrcUnpackedness where+    put_ bh SrcNoUnpack = putByte bh 0+    put_ bh SrcUnpack   = putByte bh 1+    put_ bh NoSrcUnpack = putByte bh 2++    get bh =+      do h <- getByte bh+         case h of+           0 -> return SrcNoUnpack+           1 -> return SrcUnpack+           _ -> return NoSrcUnpack++-- | Compare strictness annotations+eqHsBang :: HsImplBang -> HsImplBang -> Bool+eqHsBang HsLazy               HsLazy              = True+eqHsBang HsStrict             HsStrict            = True+eqHsBang (HsUnpack Nothing)   (HsUnpack Nothing)  = True+eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2))+  = eqType (coercionType c1) (coercionType c2)+eqHsBang _ _                                       = False++isBanged :: HsImplBang -> Bool+isBanged (HsUnpack {}) = True+isBanged (HsStrict {}) = True+isBanged HsLazy        = False++isSrcStrict :: SrcStrictness -> Bool+isSrcStrict SrcStrict = True+isSrcStrict _ = False++isSrcUnpacked :: SrcUnpackedness -> Bool+isSrcUnpacked SrcUnpack = True+isSrcUnpacked _ = False++isMarkedStrict :: StrictnessMark -> Bool+isMarkedStrict NotMarkedStrict = False+isMarkedStrict _               = True   -- All others are strict++{- *********************************************************************+*                                                                      *+\subsection{Construction}+*                                                                      *+********************************************************************* -}++-- | Build a new data constructor+mkDataCon :: Name+          -> Bool           -- ^ Is the constructor declared infix?+          -> TyConRepName   -- ^  TyConRepName for the promoted TyCon+          -> [HsSrcBang]    -- ^ Strictness/unpack annotations, from user+          -> [FieldLabel]   -- ^ Field labels for the constructor,+                            -- if it is a record, otherwise empty+          -> [TyVarBinder]  -- ^ Universals. See Note [TyVarBinders in DataCons]+          -> [TyVarBinder]  -- ^ Existentials.+                            -- (These last two must be Named and Inferred/Specified)+          -> [EqSpec]       -- ^ GADT equalities+          -> ThetaType      -- ^ Theta-type occuring before the arguments proper+          -> [Type]         -- ^ Original argument types+          -> Type           -- ^ Original result type+          -> RuntimeRepInfo -- ^ See comments on 'TyCon.RuntimeRepInfo'+          -> TyCon          -- ^ Representation type constructor+          -> ThetaType      -- ^ The "stupid theta", context of the data+                            -- declaration e.g. @data Eq a => T a ...@+          -> Id             -- ^ Worker Id+          -> DataConRep     -- ^ Representation+          -> DataCon+  -- Can get the tag from the TyCon++mkDataCon name declared_infix prom_info+          arg_stricts   -- Must match orig_arg_tys 1-1+          fields+          univ_tvs ex_tvs+          eq_spec theta+          orig_arg_tys orig_res_ty rep_info rep_tycon+          stupid_theta work_id rep+-- Warning: mkDataCon is not a good place to check invariants.+-- If the programmer writes the wrong result type in the decl, thus:+--      data T a where { MkT :: S }+-- then it's possible that the univ_tvs may hit an assertion failure+-- if you pull on univ_tvs.  This case is checked by checkValidDataCon,+-- so the error is detected properly... it's just that asaertions here+-- are a little dodgy.++  = con+  where+    is_vanilla = null ex_tvs && null eq_spec && null theta+    con = MkData {dcName = name, dcUnique = nameUnique name,+                  dcVanilla = is_vanilla, dcInfix = declared_infix,+                  dcUnivTyVars = univ_tvs,+                  dcExTyVars = ex_tvs,+                  dcEqSpec = eq_spec,+                  dcOtherTheta = theta,+                  dcStupidTheta = stupid_theta,+                  dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty,+                  dcRepTyCon = rep_tycon,+                  dcSrcBangs = arg_stricts,+                  dcFields = fields, dcTag = tag, dcRepType = rep_ty,+                  dcWorkId = work_id,+                  dcRep = rep,+                  dcSourceArity = length orig_arg_tys,+                  dcRepArity = length rep_arg_tys,+                  dcPromoted = promoted }++        -- The 'arg_stricts' passed to mkDataCon are simply those for the+        -- source-language arguments.  We add extra ones for the+        -- dictionary arguments right here.++    tag = assoc "mkDataCon" (tyConDataCons rep_tycon `zip` [fIRST_TAG..]) con+    rep_arg_tys = dataConRepArgTys con++    rep_ty = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $+             mkFunTys rep_arg_tys $+             mkTyConApp rep_tycon (mkTyVarTys (binderVars univ_tvs))++      -- See Note [Promoted data constructors] in TyCon+    prom_tv_bndrs = [ mkNamedTyConBinder vis tv+                    | TvBndr tv vis <- filterEqSpec eq_spec univ_tvs ++ ex_tvs ]++    prom_arg_bndrs = mkCleanAnonTyConBinders prom_tv_bndrs (theta ++ orig_arg_tys)+    prom_res_kind  = orig_res_ty+    promoted       = mkPromotedDataCon con name prom_info+                                       (prom_tv_bndrs ++ prom_arg_bndrs)+                                       prom_res_kind roles rep_info++    roles = map (const Nominal) (univ_tvs ++ ex_tvs) +++            map (const Representational) orig_arg_tys++mkCleanAnonTyConBinders :: [TyConBinder] -> [Type] -> [TyConBinder]+-- Make sure that the "anonymous" tyvars don't clash in+-- name or unique with the universal/existential ones.+-- Tiresome!  And unnecessary because these tyvars are never looked at+mkCleanAnonTyConBinders tc_bndrs tys+  = [ mkAnonTyConBinder (mkTyVar name ty)+    | (name, ty) <- fresh_names `zip` tys ]+  where+    fresh_names = freshNames (map getName (binderVars tc_bndrs))++freshNames :: [Name] -> [Name]+-- Make names whose Uniques and OccNames differ from+-- those in the 'avoid' list+freshNames avoids+  = [ mkSystemName uniq occ+    | n <- [0..]+    , let uniq = mkAlphaTyVarUnique n+          occ = mkTyVarOccFS (mkFastString ('x' : show n))++    , not (uniq `elementOfUniqSet` avoid_uniqs)+    , not (occ `elemOccSet` avoid_occs) ]++  where+    avoid_uniqs :: UniqSet Unique+    avoid_uniqs = mkUniqSet (map getUnique avoids)++    avoid_occs :: OccSet+    avoid_occs = mkOccSet (map getOccName avoids)++-- | The 'Name' of the 'DataCon', giving it a unique, rooted identification+dataConName :: DataCon -> Name+dataConName = dcName++-- | The tag used for ordering 'DataCon's+dataConTag :: DataCon -> ConTag+dataConTag  = dcTag++-- | The type constructor that we are building via this data constructor+dataConTyCon :: DataCon -> TyCon+dataConTyCon = dcRepTyCon++-- | The original type constructor used in the definition of this data+-- constructor.  In case of a data family instance, that will be the family+-- type constructor.+dataConOrigTyCon :: DataCon -> TyCon+dataConOrigTyCon dc+  | Just (tc, _) <- tyConFamInst_maybe (dcRepTyCon dc) = tc+  | otherwise                                          = dcRepTyCon dc++-- | The representation type of the data constructor, i.e. the sort+-- type that will represent values of this type at runtime+dataConRepType :: DataCon -> Type+dataConRepType = dcRepType++-- | Should the 'DataCon' be presented infix?+dataConIsInfix :: DataCon -> Bool+dataConIsInfix = dcInfix++-- | The universally-quantified type variables of the constructor+dataConUnivTyVars :: DataCon -> [TyVar]+dataConUnivTyVars (MkData { dcUnivTyVars = tvbs }) = binderVars tvbs++-- | 'TyBinder's for the universally-quantified type variables+dataConUnivTyVarBinders :: DataCon -> [TyVarBinder]+dataConUnivTyVarBinders = dcUnivTyVars++-- | The existentially-quantified type variables of the constructor+dataConExTyVars :: DataCon -> [TyVar]+dataConExTyVars (MkData { dcExTyVars = tvbs }) = binderVars tvbs++-- | 'TyBinder's for the existentially-quantified type variables+dataConExTyVarBinders :: DataCon -> [TyVarBinder]+dataConExTyVarBinders = dcExTyVars++-- | Both the universal and existentiatial type variables of the constructor+dataConAllTyVars :: DataCon -> [TyVar]+dataConAllTyVars (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs })+  = binderVars (univ_tvs ++ ex_tvs)++-- | Equalities derived from the result type of the data constructor, as written+-- by the programmer in any GADT declaration. This includes *all* GADT-like+-- equalities, including those written in by hand by the programmer.+dataConEqSpec :: DataCon -> [EqSpec]+dataConEqSpec (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta })+  = eq_spec +++    [ spec   -- heterogeneous equality+    | Just (tc, [_k1, _k2, ty1, ty2]) <- map splitTyConApp_maybe theta+    , tc `hasKey` heqTyConKey+    , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of+                    (Just tv1, _) -> [mkEqSpec tv1 ty2]+                    (_, Just tv2) -> [mkEqSpec tv2 ty1]+                    _             -> []+    ] +++    [ spec   -- homogeneous equality+    | Just (tc, [_k, ty1, ty2]) <- map splitTyConApp_maybe theta+    , tc `hasKey` eqTyConKey+    , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of+                    (Just tv1, _) -> [mkEqSpec tv1 ty2]+                    (_, Just tv2) -> [mkEqSpec tv2 ty1]+                    _             -> []+    ]+++-- | The *full* constraints on the constructor type.+dataConTheta :: DataCon -> ThetaType+dataConTheta (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta })+  = eqSpecPreds eq_spec ++ theta++-- | Get the Id of the 'DataCon' worker: a function that is the "actual"+-- constructor and has no top level binding in the program. The type may+-- be different from the obvious one written in the source program. Panics+-- if there is no such 'Id' for this 'DataCon'+dataConWorkId :: DataCon -> Id+dataConWorkId dc = dcWorkId dc++-- | Get the Id of the 'DataCon' wrapper: a function that wraps the "actual"+-- constructor so it has the type visible in the source program: c.f. 'dataConWorkId'.+-- Returns Nothing if there is no wrapper, which occurs for an algebraic data constructor+-- and also for a newtype (whose constructor is inlined compulsorily)+dataConWrapId_maybe :: DataCon -> Maybe Id+dataConWrapId_maybe dc = case dcRep dc of+                           NoDataConRep -> Nothing+                           DCR { dcr_wrap_id = wrap_id } -> Just wrap_id++-- | Returns an Id which looks like the Haskell-source constructor by using+-- the wrapper if it exists (see 'dataConWrapId_maybe') and failing over to+-- the worker (see 'dataConWorkId')+dataConWrapId :: DataCon -> Id+dataConWrapId dc = case dcRep dc of+                     NoDataConRep-> dcWorkId dc    -- worker=wrapper+                     DCR { dcr_wrap_id = wrap_id } -> wrap_id++-- | Find all the 'Id's implicitly brought into scope by the data constructor. Currently,+-- the union of the 'dataConWorkId' and the 'dataConWrapId'+dataConImplicitTyThings :: DataCon -> [TyThing]+dataConImplicitTyThings (MkData { dcWorkId = work, dcRep = rep })+  = [AnId work] ++ wrap_ids+  where+    wrap_ids = case rep of+                 NoDataConRep               -> []+                 DCR { dcr_wrap_id = wrap } -> [AnId wrap]++-- | The labels for the fields of this particular 'DataCon'+dataConFieldLabels :: DataCon -> [FieldLabel]+dataConFieldLabels = dcFields++-- | Extract the type for any given labelled field of the 'DataCon'+dataConFieldType :: DataCon -> FieldLabelString -> Type+dataConFieldType con label = case dataConFieldType_maybe con label of+      Just (_, ty) -> ty+      Nothing      -> pprPanic "dataConFieldType" (ppr con <+> ppr label)++-- | Extract the label and type for any given labelled field of the+-- 'DataCon', or return 'Nothing' if the field does not belong to it+dataConFieldType_maybe :: DataCon -> FieldLabelString+                       -> Maybe (FieldLabel, Type)+dataConFieldType_maybe con label+  = find ((== label) . flLabel . fst) (dcFields con `zip` dcOrigArgTys con)++-- | Strictness/unpack annotations, from user; or, for imported+-- DataCons, from the interface file+-- The list is in one-to-one correspondence with the arity of the 'DataCon'++dataConSrcBangs :: DataCon -> [HsSrcBang]+dataConSrcBangs = dcSrcBangs++-- | Source-level arity of the data constructor+dataConSourceArity :: DataCon -> Arity+dataConSourceArity (MkData { dcSourceArity = arity }) = arity++-- | Gives the number of actual fields in the /representation/ of the+-- data constructor. This may be more than appear in the source code;+-- the extra ones are the existentially quantified dictionaries+dataConRepArity :: DataCon -> Arity+dataConRepArity (MkData { dcRepArity = arity }) = arity++-- | Return whether there are any argument types for this 'DataCon's original source type+-- See Note [DataCon arities]+isNullarySrcDataCon :: DataCon -> Bool+isNullarySrcDataCon dc = dataConSourceArity dc == 0++-- | Return whether there are any argument types for this 'DataCon's runtime representation type+-- See Note [DataCon arities]+isNullaryRepDataCon :: DataCon -> Bool+isNullaryRepDataCon dc = dataConRepArity dc == 0++dataConRepStrictness :: DataCon -> [StrictnessMark]+-- ^ Give the demands on the arguments of a+-- Core constructor application (Con dc args)+dataConRepStrictness dc = case dcRep dc of+                            NoDataConRep -> [NotMarkedStrict | _ <- dataConRepArgTys dc]+                            DCR { dcr_stricts = strs } -> strs++dataConImplBangs :: DataCon -> [HsImplBang]+-- The implementation decisions about the strictness/unpack of each+-- source program argument to the data constructor+dataConImplBangs dc+  = case dcRep dc of+      NoDataConRep              -> replicate (dcSourceArity dc) HsLazy+      DCR { dcr_bangs = bangs } -> bangs++dataConBoxer :: DataCon -> Maybe DataConBoxer+dataConBoxer (MkData { dcRep = DCR { dcr_boxer = boxer } }) = Just boxer+dataConBoxer _ = Nothing++-- | The \"signature\" of the 'DataCon' returns, in order:+--+-- 1) The result of 'dataConAllTyVars',+--+-- 2) All the 'ThetaType's relating to the 'DataCon' (coercion, dictionary, implicit+--    parameter - whatever)+--+-- 3) The type arguments to the constructor+--+-- 4) The /original/ result type of the 'DataCon'+dataConSig :: DataCon -> ([TyVar], ThetaType, [Type], Type)+dataConSig con@(MkData {dcOrigArgTys = arg_tys, dcOrigResTy = res_ty})+  = (dataConAllTyVars con, dataConTheta con, arg_tys, res_ty)++dataConInstSig+  :: DataCon+  -> [Type]    -- Instantiate the *universal* tyvars with these types+  -> ([TyVar], ThetaType, [Type])  -- Return instantiated existentials+                                   -- theta and arg tys+-- ^ Instantantiate the universal tyvars of a data con,+--   returning the instantiated existentials, constraints, and args+dataConInstSig (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs+                       , dcEqSpec = eq_spec, dcOtherTheta  = theta+                       , dcOrigArgTys = arg_tys })+               univ_tys+  = ( ex_tvs'+    , substTheta subst (eqSpecPreds eq_spec ++ theta)+    , substTys   subst arg_tys)+  where+    univ_subst = zipTvSubst (binderVars univ_tvs) univ_tys+    (subst, ex_tvs') = mapAccumL Type.substTyVarBndr univ_subst $+                       binderVars ex_tvs+++-- | The \"full signature\" of the 'DataCon' returns, in order:+--+-- 1) The result of 'dataConUnivTyVars'+--+-- 2) The result of 'dataConExTyVars'+--+-- 3) The GADT equalities+--+-- 4) The result of 'dataConDictTheta'+--+-- 5) The original argument types to the 'DataCon' (i.e. before+--    any change of the representation of the type)+--+-- 6) The original result type of the 'DataCon'+dataConFullSig :: DataCon+               -> ([TyVar], [TyVar], [EqSpec], ThetaType, [Type], Type)+dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs,+                        dcEqSpec = eq_spec, dcOtherTheta = theta,+                        dcOrigArgTys = arg_tys, dcOrigResTy = res_ty})+  = (binderVars univ_tvs, binderVars ex_tvs, eq_spec, theta, arg_tys, res_ty)++dataConOrigResTy :: DataCon -> Type+dataConOrigResTy dc = dcOrigResTy dc++-- | The \"stupid theta\" of the 'DataCon', such as @data Eq a@ in:+--+-- > data Eq a => T a = ...+dataConStupidTheta :: DataCon -> ThetaType+dataConStupidTheta dc = dcStupidTheta dc++dataConUserType :: DataCon -> Type+-- ^ The user-declared type of the data constructor+-- in the nice-to-read form:+--+-- > T :: forall a b. a -> b -> T [a]+--+-- rather than:+--+-- > T :: forall a c. forall b. (c~[a]) => a -> b -> T c+--+-- NB: If the constructor is part of a data instance, the result type+-- mentions the family tycon, not the internal one.+dataConUserType (MkData { dcUnivTyVars = univ_tvs,+                          dcExTyVars = ex_tvs, dcEqSpec = eq_spec,+                          dcOtherTheta = theta, dcOrigArgTys = arg_tys,+                          dcOrigResTy = res_ty })+  = mkForAllTys (filterEqSpec eq_spec univ_tvs) $+    mkForAllTys ex_tvs $+    mkFunTys theta $+    mkFunTys arg_tys $+    res_ty++-- | Finds the instantiated types of the arguments required to construct a 'DataCon' representation+-- NB: these INCLUDE any dictionary args+--     but EXCLUDE the data-declaration context, which is discarded+-- It's all post-flattening etc; this is a representation type+dataConInstArgTys :: DataCon    -- ^ A datacon with no existentials or equality constraints+                                -- However, it can have a dcTheta (notably it can be a+                                -- class dictionary, with superclasses)+                  -> [Type]     -- ^ Instantiated at these types+                  -> [Type]+dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs,+                              dcExTyVars = ex_tvs}) inst_tys+ = ASSERT2( length univ_tvs == length inst_tys+          , text "dataConInstArgTys" <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys)+   ASSERT2( null ex_tvs, ppr dc )+   map (substTyWith (binderVars univ_tvs) inst_tys) (dataConRepArgTys dc)++-- | Returns just the instantiated /value/ argument types of a 'DataCon',+-- (excluding dictionary args)+dataConInstOrigArgTys+        :: DataCon      -- Works for any DataCon+        -> [Type]       -- Includes existential tyvar args, but NOT+                        -- equality constraints or dicts+        -> [Type]+-- For vanilla datacons, it's all quite straightforward+-- But for the call in MatchCon, we really do want just the value args+dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys,+                                  dcUnivTyVars = univ_tvs,+                                  dcExTyVars = ex_tvs}) inst_tys+  = ASSERT2( length tyvars == length inst_tys+          , text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys )+    map (substTyWith tyvars inst_tys) arg_tys+  where+    tyvars = binderVars (univ_tvs ++ ex_tvs)++-- | Returns the argument types of the wrapper, excluding all dictionary arguments+-- and without substituting for any type variables+dataConOrigArgTys :: DataCon -> [Type]+dataConOrigArgTys dc = dcOrigArgTys dc++-- | Returns the arg types of the worker, including *all*+-- evidence, after any flattening has been done and without substituting for+-- any type variables+dataConRepArgTys :: DataCon -> [Type]+dataConRepArgTys (MkData { dcRep = rep+                         , dcEqSpec = eq_spec+                         , dcOtherTheta = theta+                         , dcOrigArgTys = orig_arg_tys })+  = case rep of+      NoDataConRep -> ASSERT( null eq_spec ) theta ++ orig_arg_tys+      DCR { dcr_arg_tys = arg_tys } -> arg_tys++-- | The string @package:module.name@ identifying a constructor, which is attached+-- to its info table and used by the GHCi debugger and the heap profiler+dataConIdentity :: DataCon -> [Word8]+-- We want this string to be UTF-8, so we get the bytes directly from the FastStrings.+dataConIdentity dc = bytesFS (unitIdFS (moduleUnitId mod)) +++                  fromIntegral (ord ':') : bytesFS (moduleNameFS (moduleName mod)) +++                  fromIntegral (ord '.') : bytesFS (occNameFS (nameOccName name))+  where name = dataConName dc+        mod  = ASSERT( isExternalName name ) nameModule name++isTupleDataCon :: DataCon -> Bool+isTupleDataCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc++isUnboxedTupleCon :: DataCon -> Bool+isUnboxedTupleCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc++isUnboxedSumCon :: DataCon -> Bool+isUnboxedSumCon (MkData {dcRepTyCon = tc}) = isUnboxedSumTyCon tc++-- | Vanilla 'DataCon's are those that are nice boring Haskell 98 constructors+isVanillaDataCon :: DataCon -> Bool+isVanillaDataCon dc = dcVanilla dc++-- | Should this DataCon be allowed in a type even without -XDataKinds?+-- Currently, only Lifted & Unlifted+specialPromotedDc :: DataCon -> Bool+specialPromotedDc = isKindTyCon . dataConTyCon++-- | Was this datacon promotable before GHC 8.0? That is, is it promotable+-- without -XTypeInType+isLegacyPromotableDataCon :: DataCon -> Bool+isLegacyPromotableDataCon dc+  =  null (dataConEqSpec dc)  -- no GADTs+  && null (dataConTheta dc)   -- no context+  && not (isFamInstTyCon (dataConTyCon dc))   -- no data instance constructors+  && uniqSetAll isLegacyPromotableTyCon (tyConsOfType (dataConUserType dc))++-- | Was this tycon promotable before GHC 8.0? That is, is it promotable+-- without -XTypeInType+isLegacyPromotableTyCon :: TyCon -> Bool+isLegacyPromotableTyCon tc+  = isVanillaAlgTyCon tc ||+      -- This returns True more often than it should, but it's quite painful+      -- to make this fully accurate. And no harm is caused; we just don't+      -- require -XTypeInType every time we need to. (We'll always require+      -- -XDataKinds, though, so there's no standards-compliance issue.)+    isFunTyCon tc || isKindTyCon tc++classDataCon :: Class -> DataCon+classDataCon clas = case tyConDataCons (classTyCon clas) of+                      (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr+                      [] -> panic "classDataCon"++dataConCannotMatch :: [Type] -> DataCon -> Bool+-- Returns True iff the data con *definitely cannot* match a+--                  scrutinee of type (T tys)+--                  where T is the dcRepTyCon for the data con+dataConCannotMatch tys con+  | null inst_theta   = False   -- Common+  | all isTyVarTy tys = False   -- Also common+  | otherwise         = typesCantMatch (concatMap predEqs inst_theta)+  where+    (_, inst_theta, _) = dataConInstSig con tys++    -- TODO: could gather equalities from superclasses too+    predEqs pred = case classifyPredType pred of+                     EqPred NomEq ty1 ty2       -> [(ty1, ty2)]+                     ClassPred eq [_, ty1, ty2]+                       | eq `hasKey` eqTyConKey -> [(ty1, ty2)]+                     _                          -> []++{-+%************************************************************************+%*                                                                      *+        Promoting of data types to the kind level+*                                                                      *+************************************************************************++-}++promoteDataCon :: DataCon -> TyCon+promoteDataCon (MkData { dcPromoted = tc }) = tc++{-+************************************************************************+*                                                                      *+\subsection{Splitting products}+*                                                                      *+************************************************************************+-}++-- | Extract the type constructor, type argument, data constructor and it's+-- /representation/ argument types from a type if it is a product type.+--+-- Precisely, we return @Just@ for any type that is all of:+--+--  * Concrete (i.e. constructors visible)+--+--  * Single-constructor+--+--  * Not existentially quantified+--+-- Whether the type is a @data@ type or a @newtype@+splitDataProductType_maybe+        :: Type                         -- ^ A product type, perhaps+        -> Maybe (TyCon,                -- The type constructor+                  [Type],               -- Type args of the tycon+                  DataCon,              -- The data constructor+                  [Type])               -- Its /representation/ arg types++        -- Rejecting existentials is conservative.  Maybe some things+        -- could be made to work with them, but I'm not going to sweat+        -- it through till someone finds it's important.++splitDataProductType_maybe ty+  | Just (tycon, ty_args) <- splitTyConApp_maybe ty+  , Just con <- isDataProductTyCon_maybe tycon+  = Just (tycon, ty_args, con, dataConInstArgTys con ty_args)+  | otherwise+  = Nothing++{-+************************************************************************+*                                                                      *+              Building an algebraic data type+*                                                                      *+************************************************************************++buildAlgTyCon is here because it is called from TysWiredIn, which can+depend on this module, but not on BuildTyCl.+-}++buildAlgTyCon :: Name+              -> [TyVar]               -- ^ Kind variables and type variables+              -> [Role]+              -> Maybe CType+              -> ThetaType             -- ^ Stupid theta+              -> AlgTyConRhs+              -> Bool                  -- ^ True <=> was declared in GADT syntax+              -> AlgTyConFlav+              -> TyCon++buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs+              gadt_syn parent+  = mkAlgTyCon tc_name binders liftedTypeKind roles cType stupid_theta+               rhs parent gadt_syn+  where+    binders = mkTyConBindersPreferAnon ktvs liftedTypeKind++buildSynTyCon :: Name -> [TyConBinder] -> Kind   -- ^ /result/ kind+                  -> [Role] -> Type -> TyCon+buildSynTyCon name binders res_kind roles rhs+  = mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free+  where+    is_tau      = isTauTy rhs+    is_fam_free = isFamFreeTy rhs
+ basicTypes/DataCon.hs-boot view
@@ -0,0 +1,32 @@+module DataCon where+import Var( TyVar, TyVarBinder )+import Name( Name, NamedThing )+import {-# SOURCE #-} TyCon( TyCon )+import FieldLabel ( FieldLabel )+import Unique ( Uniquable )+import Outputable ( Outputable, OutputableBndr )+import BasicTypes (Arity)+import {-# SOURCE #-} TyCoRep ( Type, ThetaType )++data DataCon+data DataConRep+data EqSpec+filterEqSpec :: [EqSpec] -> [TyVarBinder] -> [TyVarBinder]++dataConName      :: DataCon -> Name+dataConTyCon     :: DataCon -> TyCon+dataConUnivTyVarBinders :: DataCon -> [TyVarBinder]+dataConExTyVars  :: DataCon -> [TyVar]+dataConExTyVarBinders :: DataCon -> [TyVarBinder]+dataConSourceArity  :: DataCon -> Arity+dataConFieldLabels :: DataCon -> [FieldLabel]+dataConInstOrigArgTys  :: DataCon -> [Type] -> [Type]+dataConStupidTheta :: DataCon -> ThetaType+dataConFullSig :: DataCon+               -> ([TyVar], [TyVar], [EqSpec], ThetaType, [Type], Type)++instance Eq DataCon+instance Uniquable DataCon+instance NamedThing DataCon+instance Outputable DataCon+instance OutputableBndr DataCon
+ basicTypes/Demand.hs view
@@ -0,0 +1,2173 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[Demand]{@Demand@: A decoupled implementation of a demand domain}+-}++{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances, RecordWildCards #-}++module Demand (+        StrDmd, UseDmd(..), Count,++        Demand, CleanDemand, getStrDmd, getUseDmd,+        mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd,+        toCleanDmd,+        absDmd, topDmd, botDmd, seqDmd,+        lubDmd, bothDmd,+        lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd,+        catchArgDmd,+        isTopDmd, isAbsDmd, isSeqDmd,+        peelUseCall, cleanUseDmd_maybe, strictenDmd, bothCleanDmd,+        addCaseBndrDmd,++        DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType,+        nopDmdType, botDmdType, mkDmdType,+        addDemand, removeDmdTyArgs,+        BothDmdArg, mkBothDmdArg, toBothDmdArg,++        DmdEnv, emptyDmdEnv,+        peelFV, findIdDemand,++        DmdResult, CPRResult,+        isBotRes, isTopRes,+        topRes, botRes, exnRes, cprProdRes,+        vanillaCprProdRes, cprSumRes,+        appIsBottom, isBottomingSig, pprIfaceStrictSig,+        trimCPRInfo, returnsCPR_maybe,+        StrictSig(..), mkStrictSig, mkClosedStrictSig,+        nopSig, botSig, exnSig, cprProdSig,+        isTopSig, hasDemandEnvSig,+        splitStrictSig, strictSigDmdEnv,+        increaseStrictSigArity,++        seqDemand, seqDemandList, seqDmdType, seqStrictSig,++        evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd,+        splitDmdTy, splitFVs,+        deferAfterIO,+        postProcessUnsat, postProcessDmdType,++        splitProdDmd_maybe, peelCallDmd, mkCallDmd, mkWorkerDemand,+        dmdTransformSig, dmdTransformDataConSig, dmdTransformDictSelSig,+        argOneShots, argsOneShots, saturatedByOneShots,+        trimToType, TypeShape(..),++        useCount, isUsedOnce, reuseEnv,+        killUsageDemand, killUsageSig, zapUsageDemand, zapUsageEnvSig,+        zapUsedOnceDemand, zapUsedOnceSig,+        strictifyDictDmd++     ) where++#include "HsVersions.h"++import DynFlags+import Outputable+import Var ( Var )+import VarEnv+import UniqFM+import Util+import BasicTypes+import Binary+import Maybes           ( orElse )++import Type            ( Type, isUnliftedType )+import TyCon           ( isNewTyCon, isClassTyCon )+import DataCon         ( splitDataProductType_maybe )++{-+************************************************************************+*                                                                      *+        Joint domain for Strictness and Absence+*                                                                      *+************************************************************************+-}++data JointDmd s u = JD { sd :: s, ud :: u }+  deriving ( Eq, Show )++getStrDmd :: JointDmd s u -> s+getStrDmd = sd++getUseDmd :: JointDmd s u -> u+getUseDmd = ud++-- Pretty-printing+instance (Outputable s, Outputable u) => Outputable (JointDmd s u) where+  ppr (JD {sd = s, ud = u}) = angleBrackets (ppr s <> char ',' <> ppr u)++-- Well-formedness preserving constructors for the joint domain+mkJointDmd :: s -> u -> JointDmd s u+mkJointDmd s u = JD { sd = s, ud = u }++mkJointDmds :: [s] -> [u] -> [JointDmd s u]+mkJointDmds ss as = zipWithEqual "mkJointDmds" mkJointDmd ss as+++{-+************************************************************************+*                                                                      *+            Strictness domain+*                                                                      *+************************************************************************++        Lazy+         |+  ExnStr x -+           |+        HeadStr+        /     \+    SCall      SProd+        \      /+        HyperStr++Note [Exceptions and strictness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Exceptions need rather careful treatment, especially because of 'catch'+('catch#'), 'catchSTM' ('catchSTM#'), and 'orElse' ('catchRetry#').+See Trac #11555, #10712 and #13330, and for some more background, #11222.++There are three main pieces.++* The Termination type includes ThrowsExn, meaning "under the given+  demand this expression either diverges or throws an exception".++  This is relatively uncontroversial. The primops raise# and+  raiseIO# both return ThrowsExn; nothing else does.++* An ArgStr has an ExnStr flag to say how to process the Termination+  result of the argument.  If the ExnStr flag is ExnStr, we squash+  ThrowsExn to topRes.  (This is done in postProcessDmdResult.)++Here is the key example++    catchRetry# (\s -> retry# s) blah++We analyse the argument (\s -> retry# s) with demand+    Str ExnStr (SCall HeadStr)+i.e. with the ExnStr flag set.+  - First we analyse the argument with the "clean-demand" (SCall+    HeadStr), getting a DmdResult of ThrowsExn from the saturated+    application of retry#.+  - Then we apply the post-processing for the shell, squashing the+    ThrowsExn to topRes.++This also applies uniformly to free variables.  Consider++    let r = \st -> retry# st+    in catchRetry# (\s -> ...(r s')..) handler st++If we give the first argument of catch a strict signature, we'll get a demand+'C(S)' for 'r'; that is, 'r' is definitely called with one argument, which+indeed it is.  But when we post-process the free-var demands on catchRetry#'s+argument (in postProcessDmdEnv), we'll give 'r' a demand of (Str ExnStr (SCall+HeadStr)); and if we feed that into r's RHS (which would be reasonable) we'll+squash the retry just as if we'd inlined 'r'.++* We don't try to get clever about 'catch#' and 'catchSTM#' at the moment. We+previously (#11222) tried to take advantage of the fact that 'catch#' calls its+first argument eagerly. See especially commit+9915b6564403a6d17651e9969e9ea5d7d7e78e7f. We analyzed that first argument with+a strict demand, and then performed a post-processing step at the end to change+ThrowsExn to TopRes.  The trouble, I believe, is that to use this approach+correctly, we'd need somewhat different information about that argument.+Diverges, ThrowsExn (i.e., diverges or throws an exception), and Dunno are the+wrong split here.  In order to evaluate part of the argument speculatively,+we'd need to know that it *does not throw an exception*. That is, that it+either diverges or succeeds. But we don't currently have a way to talk about+that. Abstractly and approximately,++catch# m f s = case ORACLE m s of+  DivergesOrSucceeds -> m s+  Fails exc -> f exc s++where the magical ORACLE determines whether or not (m s) throws an exception+when run, and if so which one. If we want, we can safely consider (catch# m f s)+strict in anything that both branches are strict in (by performing demand+analysis for 'catch#' in the same way we do for case). We could also safely+consider it strict in anything demanded by (m s) that is guaranteed not to+throw an exception under that demand, but I don't know if we have the means+to express that.++My mind keeps turning to this model (not as an actual change to the type, but+as a way to think about what's going on in the analysis):++newtype IO a = IO {unIO :: State# s -> (# s, (# SomeException | a #) #)}+instance Monad IO where+  return a = IO $ \s -> (# s, (# | a #) #)+  IO m >>= f = IO $ \s -> case m s of+    (# s', (# e | #) #) -> (# s', e #)+    (# s', (# | a #) #) -> unIO (f a) s+raiseIO# e s = (# s, (# e | #) #)+catch# m f s = case m s of+  (# s', (# e | #) #) -> f e s'+  res -> res++Thinking about it this way seems likely to be productive for analyzing IO+exception behavior, but imprecise exceptions and asynchronous exceptions remain+quite slippery beasts. Can we incorporate them? I think we can. We can imagine+applying 'seq#' to evaluate @m s@, determining whether it throws an imprecise+or asynchronous exception or whether it succeeds or throws an IO exception.+This confines the peculiarities to 'seq#', which is indeed rather essentially+peculiar.+-}++-- Vanilla strictness domain+data StrDmd+  = HyperStr             -- Hyper-strict+                         -- Bottom of the lattice+                         -- Note [HyperStr and Use demands]++  | SCall StrDmd         -- Call demand+                         -- Used only for values of function type++  | SProd [ArgStr]     -- Product+                         -- Used only for values of product type+                         -- Invariant: not all components are HyperStr (use HyperStr)+                         --            not all components are Lazy     (use HeadStr)++  | HeadStr              -- Head-Strict+                         -- A polymorphic demand: used for values of all types,+                         --                       including a type variable++  deriving ( Eq, Show )++type ArgStr = Str StrDmd++data Str s = Lazy         -- Lazy+                          -- Top of the lattice+           | Str ExnStr s+  deriving ( Eq, Show )++data ExnStr  -- See Note [Exceptions and strictness]+  = VanStr   -- "Vanilla" case, ordinary strictness++  | ExnStr   -- (Str ExnStr d) means be strict like 'd' but then degrade+             --                the Termination info ThrowsExn to Dunno+  deriving( Eq, Show )++-- Well-formedness preserving constructors for the Strictness domain+strBot, strTop :: ArgStr+strBot = Str VanStr HyperStr+strTop = Lazy++mkSCall :: StrDmd -> StrDmd+mkSCall HyperStr = HyperStr+mkSCall s        = SCall s++mkSProd :: [ArgStr] -> StrDmd+mkSProd sx+  | any isHyperStr sx = HyperStr+  | all isLazy     sx = HeadStr+  | otherwise         = SProd sx++isLazy :: ArgStr -> Bool+isLazy Lazy     = True+isLazy (Str {}) = False++isHyperStr :: ArgStr -> Bool+isHyperStr (Str _ HyperStr) = True+isHyperStr _                = False++-- Pretty-printing+instance Outputable StrDmd where+  ppr HyperStr      = char 'B'+  ppr (SCall s)     = char 'C' <> parens (ppr s)+  ppr HeadStr       = char 'S'+  ppr (SProd sx)    = char 'S' <> parens (hcat (map ppr sx))++instance Outputable ArgStr where+  ppr (Str x s)     = (case x of VanStr -> empty; ExnStr -> char 'x')+                      <> ppr s+  ppr Lazy          = char 'L'++lubArgStr :: ArgStr -> ArgStr -> ArgStr+lubArgStr Lazy        _           = Lazy+lubArgStr _           Lazy        = Lazy+lubArgStr (Str x1 s1) (Str x2 s2) = Str (x1 `lubExnStr` x2) (s1 `lubStr` s2)++lubExnStr :: ExnStr -> ExnStr -> ExnStr+lubExnStr VanStr VanStr = VanStr+lubExnStr _      _      = ExnStr   -- ExnStr is lazier++lubStr :: StrDmd -> StrDmd -> StrDmd+lubStr HyperStr s              = s+lubStr (SCall s1) HyperStr     = SCall s1+lubStr (SCall _)  HeadStr      = HeadStr+lubStr (SCall s1) (SCall s2)   = SCall (s1 `lubStr` s2)+lubStr (SCall _)  (SProd _)    = HeadStr+lubStr (SProd sx) HyperStr     = SProd sx+lubStr (SProd _)  HeadStr      = HeadStr+lubStr (SProd s1) (SProd s2)+    | length s1 == length s2   = mkSProd (zipWith lubArgStr s1 s2)+    | otherwise                = HeadStr+lubStr (SProd _) (SCall _)     = HeadStr+lubStr HeadStr   _             = HeadStr++bothArgStr :: ArgStr -> ArgStr -> ArgStr+bothArgStr Lazy        s           = s+bothArgStr s           Lazy        = s+bothArgStr (Str x1 s1) (Str x2 s2) = Str (x1 `bothExnStr` x2) (s1 `bothStr` s2)++bothExnStr :: ExnStr -> ExnStr -> ExnStr+bothExnStr ExnStr ExnStr = ExnStr+bothExnStr _      _      = VanStr++bothStr :: StrDmd -> StrDmd -> StrDmd+bothStr HyperStr _             = HyperStr+bothStr HeadStr s              = s+bothStr (SCall _)  HyperStr    = HyperStr+bothStr (SCall s1) HeadStr     = SCall s1+bothStr (SCall s1) (SCall s2)  = SCall (s1 `bothStr` s2)+bothStr (SCall _)  (SProd _)   = HyperStr  -- Weird++bothStr (SProd _)  HyperStr    = HyperStr+bothStr (SProd s1) HeadStr     = SProd s1+bothStr (SProd s1) (SProd s2)+    | length s1 == length s2   = mkSProd (zipWith bothArgStr s1 s2)+    | otherwise                = HyperStr  -- Weird+bothStr (SProd _) (SCall _)    = HyperStr++-- utility functions to deal with memory leaks+seqStrDmd :: StrDmd -> ()+seqStrDmd (SProd ds)   = seqStrDmdList ds+seqStrDmd (SCall s)    = seqStrDmd s+seqStrDmd _            = ()++seqStrDmdList :: [ArgStr] -> ()+seqStrDmdList [] = ()+seqStrDmdList (d:ds) = seqArgStr d `seq` seqStrDmdList ds++seqArgStr :: ArgStr -> ()+seqArgStr Lazy      = ()+seqArgStr (Str x s) = x `seq` seqStrDmd s++-- Splitting polymorphic demands+splitArgStrProdDmd :: Int -> ArgStr -> Maybe [ArgStr]+splitArgStrProdDmd n Lazy      = Just (replicate n Lazy)+splitArgStrProdDmd n (Str _ s) = splitStrProdDmd n s++splitStrProdDmd :: Int -> StrDmd -> Maybe [ArgStr]+splitStrProdDmd n HyperStr   = Just (replicate n strBot)+splitStrProdDmd n HeadStr    = Just (replicate n strTop)+splitStrProdDmd n (SProd ds) = WARN( not (ds `lengthIs` n),+                                     text "splitStrProdDmd" $$ ppr n $$ ppr ds )+                               Just ds+splitStrProdDmd _ (SCall {}) = Nothing+      -- This can happen when the programmer uses unsafeCoerce,+      -- and we don't then want to crash the compiler (Trac #9208)++{-+************************************************************************+*                                                                      *+            Absence domain+*                                                                      *+************************************************************************++         Used+         /   \+     UCall   UProd+         \   /+         UHead+          |+  Count x -+        |+       Abs+-}++-- Domain for genuine usage+data UseDmd+  = UCall Count UseDmd   -- Call demand for absence+                         -- Used only for values of function type++  | UProd [ArgUse]     -- Product+                         -- Used only for values of product type+                         -- See Note [Don't optimise UProd(Used) to Used]+                         -- [Invariant] Not all components are Abs+                         --             (in that case, use UHead)++  | UHead                -- May be used; but its sub-components are+                         -- definitely *not* used.  Roughly U(AAA)+                         -- Eg the usage of x in x `seq` e+                         -- A polymorphic demand: used for values of all types,+                         --                       including a type variable+                         -- Since (UCall _ Abs) is ill-typed, UHead doesn't+                         -- make sense for lambdas++  | Used                 -- May be used; and its sub-components may be used+                         -- Top of the lattice+  deriving ( Eq, Show )++-- Extended usage demand for absence and counting+type ArgUse = Use UseDmd++data Use u+  = Abs             -- Definitely unused+                    -- Bottom of the lattice++  | Use Count u     -- May be used with some cardinality+  deriving ( Eq, Show )++-- Abstract counting of usages+data Count = One | Many+  deriving ( Eq, Show )++-- Pretty-printing+instance Outputable ArgUse where+  ppr Abs           = char 'A'+  ppr (Use Many a)   = ppr a+  ppr (Use One  a)   = char '1' <> char '*' <> ppr a++instance Outputable UseDmd where+  ppr Used           = char 'U'+  ppr (UCall c a)    = char 'C' <> ppr c <> parens (ppr a)+  ppr UHead          = char 'H'+  ppr (UProd as)     = char 'U' <> parens (hcat (punctuate (char ',') (map ppr as)))++instance Outputable Count where+  ppr One  = char '1'+  ppr Many = text ""++useBot, useTop :: ArgUse+useBot     = Abs+useTop     = Use Many Used++mkUCall :: Count -> UseDmd -> UseDmd+--mkUCall c Used = Used c+mkUCall c a  = UCall c a++mkUProd :: [ArgUse] -> UseDmd+mkUProd ux+  | all (== Abs) ux    = UHead+  | otherwise          = UProd ux++lubCount :: Count -> Count -> Count+lubCount _ Many = Many+lubCount Many _ = Many+lubCount x _    = x++lubArgUse :: ArgUse -> ArgUse -> ArgUse+lubArgUse Abs x                   = x+lubArgUse x Abs                   = x+lubArgUse (Use c1 a1) (Use c2 a2) = Use (lubCount c1 c2) (lubUse a1 a2)++lubUse :: UseDmd -> UseDmd -> UseDmd+lubUse UHead       u               = u+lubUse (UCall c u) UHead           = UCall c u+lubUse (UCall c1 u1) (UCall c2 u2) = UCall (lubCount c1 c2) (lubUse u1 u2)+lubUse (UCall _ _) _               = Used+lubUse (UProd ux) UHead            = UProd ux+lubUse (UProd ux1) (UProd ux2)+     | length ux1 == length ux2    = UProd $ zipWith lubArgUse ux1 ux2+     | otherwise                   = Used+lubUse (UProd {}) (UCall {})       = Used+-- lubUse (UProd {}) Used             = Used+lubUse (UProd ux) Used             = UProd (map (`lubArgUse` useTop) ux)+lubUse Used       (UProd ux)       = UProd (map (`lubArgUse` useTop) ux)+lubUse Used _                      = Used  -- Note [Used should win]++-- `both` is different from `lub` in its treatment of counting; if+-- `both` is computed for two used, the result always has+--  cardinality `Many` (except for the inner demands of UCall demand -- [TODO] explain).+--  Also,  x `bothUse` x /= x (for anything but Abs).++bothArgUse :: ArgUse -> ArgUse -> ArgUse+bothArgUse Abs x                   = x+bothArgUse x Abs                   = x+bothArgUse (Use _ a1) (Use _ a2)   = Use Many (bothUse a1 a2)+++bothUse :: UseDmd -> UseDmd -> UseDmd+bothUse UHead       u               = u+bothUse (UCall c u) UHead           = UCall c u++-- Exciting special treatment of inner demand for call demands:+--    use `lubUse` instead of `bothUse`!+bothUse (UCall _ u1) (UCall _ u2)   = UCall Many (u1 `lubUse` u2)++bothUse (UCall {}) _                = Used+bothUse (UProd ux) UHead            = UProd ux+bothUse (UProd ux1) (UProd ux2)+      | length ux1 == length ux2    = UProd $ zipWith bothArgUse ux1 ux2+      | otherwise                   = Used+bothUse (UProd {}) (UCall {})       = Used+-- bothUse (UProd {}) Used             = Used  -- Note [Used should win]+bothUse Used (UProd ux)             = UProd (map (`bothArgUse` useTop) ux)+bothUse (UProd ux) Used             = UProd (map (`bothArgUse` useTop) ux)+bothUse Used _                      = Used  -- Note [Used should win]++peelUseCall :: UseDmd -> Maybe (Count, UseDmd)+peelUseCall (UCall c u)   = Just (c,u)+peelUseCall _             = Nothing++addCaseBndrDmd :: Demand    -- On the case binder+               -> [Demand]  -- On the components of the constructor+               -> [Demand]  -- Final demands for the components of the constructor+-- See Note [Demand on case-alternative binders]+addCaseBndrDmd (JD { sd = ms, ud = mu }) alt_dmds+  = case mu of+     Abs     -> alt_dmds+     Use _ u -> zipWith bothDmd alt_dmds (mkJointDmds ss us)+             where+                Just ss = splitArgStrProdDmd arity ms  -- Guaranteed not to be a call+                Just us = splitUseProdDmd      arity u   -- Ditto+  where+    arity = length alt_dmds++{- Note [Demand on case-alternative binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The demand on a binder in a case alternative comes+  (a) From the demand on the binder itself+  (b) From the demand on the case binder+Forgetting (b) led directly to Trac #10148.++Example. Source code:+  f x@(p,_) = if p then foo x else True++  foo (p,True) = True+  foo (p,q)    = foo (q,p)++After strictness analysis:+  f = \ (x_an1 [Dmd=<S(SL),1*U(U,1*U)>] :: (Bool, Bool)) ->+      case x_an1+      of wild_X7 [Dmd=<L,1*U(1*U,1*U)>]+      { (p_an2 [Dmd=<S,1*U>], ds_dnz [Dmd=<L,A>]) ->+      case p_an2 of _ {+        False -> GHC.Types.True;+        True -> foo wild_X7 }++It's true that ds_dnz is *itself* absent, but the use of wild_X7 means+that it is very much alive and demanded.  See Trac #10148 for how the+consequences play out.++This is needed even for non-product types, in case the case-binder+is used but the components of the case alternative are not.++Note [Don't optimise UProd(Used) to Used]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+These two UseDmds:+   UProd [Used, Used]   and    Used+are semantically equivalent, but we do not turn the former into+the latter, for a regrettable-subtle reason.  Suppose we did.+then+  f (x,y) = (y,x)+would get+  StrDmd = Str  = SProd [Lazy, Lazy]+  UseDmd = Used = UProd [Used, Used]+But with the joint demand of <Str, Used> doesn't convey any clue+that there is a product involved, and so the worthSplittingFun+will not fire.  (We'd need to use the type as well to make it fire.)+Moreover, consider+  g h p@(_,_) = h p+This too would get <Str, Used>, but this time there really isn't any+point in w/w since the components of the pair are not used at all.++So the solution is: don't aggressively collapse UProd [Used,Used] to+Used; intead leave it as-is. In effect we are using the UseDmd to do a+little bit of boxity analysis.  Not very nice.++Note [Used should win]+~~~~~~~~~~~~~~~~~~~~~~+Both in lubUse and bothUse we want (Used `both` UProd us) to be Used.+Why?  Because Used carries the implication the whole thing is used,+box and all, so we don't want to w/w it.  If we use it both boxed and+unboxed, then we are definitely using the box, and so we are quite+likely to pay a reboxing cost.  So we make Used win here.++Example is in the Buffer argument of GHC.IO.Handle.Internals.writeCharBuffer++Baseline: (A) Not making Used win (UProd wins)+Compare with: (B) making Used win for lub and both++            Min          -0.3%     -5.6%    -10.7%    -11.0%    -33.3%+            Max          +0.3%    +45.6%    +11.5%    +11.5%     +6.9%+ Geometric Mean          -0.0%     +0.5%     +0.3%     +0.2%     -0.8%++Baseline: (B) Making Used win for both lub and both+Compare with: (C) making Used win for both, but UProd win for lub++            Min          -0.1%     -0.3%     -7.9%     -8.0%     -6.5%+            Max          +0.1%     +1.0%    +21.0%    +21.0%     +0.5%+ Geometric Mean          +0.0%     +0.0%     -0.0%     -0.1%     -0.1%+-}++-- If a demand is used multiple times (i.e. reused), than any use-once+-- mentioned there, that is not protected by a UCall, can happen many times.+markReusedDmd :: ArgUse -> ArgUse+markReusedDmd Abs         = Abs+markReusedDmd (Use _ a)   = Use Many (markReused a)++markReused :: UseDmd -> UseDmd+markReused (UCall _ u)      = UCall Many u   -- No need to recurse here+markReused (UProd ux)       = UProd (map markReusedDmd ux)+markReused u                = u++isUsedMU :: ArgUse -> Bool+-- True <=> markReusedDmd d = d+isUsedMU Abs          = True+isUsedMU (Use One _)  = False+isUsedMU (Use Many u) = isUsedU u++isUsedU :: UseDmd -> Bool+-- True <=> markReused d = d+isUsedU Used           = True+isUsedU UHead          = True+isUsedU (UProd us)     = all isUsedMU us+isUsedU (UCall One _)  = False+isUsedU (UCall Many _) = True  -- No need to recurse++-- Squashing usage demand demands+seqUseDmd :: UseDmd -> ()+seqUseDmd (UProd ds)   = seqArgUseList ds+seqUseDmd (UCall c d)  = c `seq` seqUseDmd d+seqUseDmd _            = ()++seqArgUseList :: [ArgUse] -> ()+seqArgUseList []     = ()+seqArgUseList (d:ds) = seqArgUse d `seq` seqArgUseList ds++seqArgUse :: ArgUse -> ()+seqArgUse (Use c u)  = c `seq` seqUseDmd u+seqArgUse _          = ()++-- Splitting polymorphic Maybe-Used demands+splitUseProdDmd :: Int -> UseDmd -> Maybe [ArgUse]+splitUseProdDmd n Used        = Just (replicate n useTop)+splitUseProdDmd n UHead       = Just (replicate n Abs)+splitUseProdDmd n (UProd ds)  = WARN( not (ds `lengthIs` n),+                                      text "splitUseProdDmd" $$ ppr n+                                                             $$ ppr ds )+                                Just ds+splitUseProdDmd _ (UCall _ _) = Nothing+      -- This can happen when the programmer uses unsafeCoerce,+      -- and we don't then want to crash the compiler (Trac #9208)++useCount :: Use u -> Count+useCount Abs         = One+useCount (Use One _) = One+useCount _           = Many+++{-+************************************************************************+*                                                                      *+         Clean demand for Strictness and Usage+*                                                                      *+************************************************************************++This domain differst from JointDemand in the sence that pure absence+is taken away, i.e., we deal *only* with non-absent demands.++Note [Strict demands]+~~~~~~~~~~~~~~~~~~~~~+isStrictDmd returns true only of demands that are+   both strict+   and  used+In particular, it is False for <HyperStr, Abs>, which can and does+arise in, say (Trac #7319)+   f x = raise# <some exception>+Then 'x' is not used, so f gets strictness <HyperStr,Abs> -> .+Now the w/w generates+   fx = let x <HyperStr,Abs> = absentError "unused"+        in raise <some exception>+At this point we really don't want to convert to+   fx = case absentError "unused" of x -> raise <some exception>+Since the program is going to diverge, this swaps one error for another,+but it's really a bad idea to *ever* evaluate an absent argument.+In Trac #7319 we get+   T7319.exe: Oops!  Entered absent arg w_s1Hd{v} [lid] [base:GHC.Base.String{tc 36u}]++Note [Dealing with call demands]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Call demands are constructed and deconstructed coherently for+strictness and absence. For instance, the strictness signature for the+following function++f :: (Int -> (Int, Int)) -> (Int, Bool)+f g = (snd (g 3), True)++should be: <L,C(U(AU))>m+-}++type CleanDemand = JointDmd StrDmd UseDmd+     -- A demand that is at least head-strict++bothCleanDmd :: CleanDemand -> CleanDemand -> CleanDemand+bothCleanDmd (JD { sd = s1, ud = a1}) (JD { sd = s2, ud = a2})+  = JD { sd = s1 `bothStr` s2, ud = a1 `bothUse` a2 }++mkHeadStrict :: CleanDemand -> CleanDemand+mkHeadStrict cd = cd { sd = HeadStr }++mkOnceUsedDmd, mkManyUsedDmd :: CleanDemand -> Demand+mkOnceUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str VanStr s, ud = Use One a }+mkManyUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str VanStr s, ud = Use Many a }++evalDmd :: Demand+-- Evaluated strictly, and used arbitrarily deeply+evalDmd = JD { sd = Str VanStr HeadStr, ud = useTop }++mkProdDmd :: [Demand] -> CleanDemand+mkProdDmd dx+  = JD { sd = mkSProd $ map getStrDmd dx+       , ud = mkUProd $ map getUseDmd dx }++mkCallDmd :: CleanDemand -> CleanDemand+mkCallDmd (JD {sd = d, ud = u})+  = JD { sd = mkSCall d, ud = mkUCall One u }++-- See Note [Demand on the worker] in WorkWrap+mkWorkerDemand :: Int -> Demand+mkWorkerDemand n = JD { sd = Lazy, ud = Use One (go n) }+  where go 0 = Used+        go n = mkUCall One $ go (n-1)++cleanEvalDmd :: CleanDemand+cleanEvalDmd = JD { sd = HeadStr, ud = Used }++cleanEvalProdDmd :: Arity -> CleanDemand+cleanEvalProdDmd n = JD { sd = HeadStr, ud = UProd (replicate n useTop) }+++{-+************************************************************************+*                                                                      *+           Demand: combining stricness and usage+*                                                                      *+************************************************************************+-}++type Demand = JointDmd ArgStr ArgUse++lubDmd :: Demand -> Demand -> Demand+lubDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2})+ = JD { sd = s1 `lubArgStr` s2+      , ud = a1 `lubArgUse` a2 }++bothDmd :: Demand -> Demand -> Demand+bothDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2})+ = JD { sd = s1 `bothArgStr` s2+      , ud = a1 `bothArgUse` a2 }++lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd, catchArgDmd :: Demand++strictApply1Dmd = JD { sd = Str VanStr (SCall HeadStr)+                     , ud = Use Many (UCall One Used) }++-- First argument of catchRetry# and catchSTM#:+--    uses its arg once, applies it once+--    and catches exceptions (the ExnStr) part+catchArgDmd = JD { sd = Str ExnStr (SCall HeadStr)+                 , ud = Use One (UCall One Used) }++lazyApply1Dmd = JD { sd = Lazy+                   , ud = Use One (UCall One Used) }++-- Second argument of catch#:+--    uses its arg at most once, applies it once+--    but is lazy (might not be called at all)+lazyApply2Dmd = JD { sd = Lazy+                   , ud = Use One (UCall One (UCall One Used)) }++absDmd :: Demand+absDmd = JD { sd = Lazy, ud = Abs }++topDmd :: Demand+topDmd = JD { sd = Lazy, ud = useTop }++botDmd :: Demand+botDmd = JD { sd = strBot, ud = useBot }++seqDmd :: Demand+seqDmd = JD { sd = Str VanStr HeadStr, ud = Use One UHead }++oneifyDmd :: Demand -> Demand+oneifyDmd (JD { sd = s, ud = Use _ a }) = JD { sd = s, ud = Use One a }+oneifyDmd jd                            = jd++isTopDmd :: Demand -> Bool+-- Used to suppress pretty-printing of an uninformative demand+isTopDmd (JD {sd = Lazy, ud = Use Many Used}) = True+isTopDmd _                                    = False++isAbsDmd :: Demand -> Bool+isAbsDmd (JD {ud = Abs}) = True   -- The strictness part can be HyperStr+isAbsDmd _               = False  -- for a bottom demand++isSeqDmd :: Demand -> Bool+isSeqDmd (JD {sd = Str VanStr HeadStr, ud = Use _ UHead}) = True+isSeqDmd _                                                = False++isUsedOnce :: Demand -> Bool+isUsedOnce (JD { ud = a }) = case useCount a of+                               One  -> True+                               Many -> False++-- More utility functions for strictness+seqDemand :: Demand -> ()+seqDemand (JD {sd = s, ud = u}) = seqArgStr s `seq` seqArgUse u++seqDemandList :: [Demand] -> ()+seqDemandList [] = ()+seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds++isStrictDmd :: Demand -> Bool+-- See Note [Strict demands]+isStrictDmd (JD {ud = Abs})  = False+isStrictDmd (JD {sd = Lazy}) = False+isStrictDmd _                = True++isWeakDmd :: Demand -> Bool+isWeakDmd (JD {sd = s, ud = a}) = isLazy s && isUsedMU a++cleanUseDmd_maybe :: Demand -> Maybe UseDmd+cleanUseDmd_maybe (JD { ud = Use _ u }) = Just u+cleanUseDmd_maybe _                     = Nothing++splitFVs :: Bool   -- Thunk+         -> DmdEnv -> (DmdEnv, DmdEnv)+splitFVs is_thunk rhs_fvs+  | is_thunk  = nonDetFoldUFM_Directly add (emptyVarEnv, emptyVarEnv) rhs_fvs+                -- It's OK to use nonDetFoldUFM_Directly because we+                -- immediately forget the ordering by putting the elements+                -- in the envs again+  | otherwise = partitionVarEnv isWeakDmd rhs_fvs+  where+    add uniq dmd@(JD { sd = s, ud = u }) (lazy_fv, sig_fv)+      | Lazy <- s = (addToUFM_Directly lazy_fv uniq dmd, sig_fv)+      | otherwise = ( addToUFM_Directly lazy_fv uniq (JD { sd = Lazy, ud = u })+                    , addToUFM_Directly sig_fv  uniq (JD { sd = s,    ud = Abs }) )++data TypeShape = TsFun TypeShape+               | TsProd [TypeShape]+               | TsUnk++instance Outputable TypeShape where+  ppr TsUnk        = text "TsUnk"+  ppr (TsFun ts)   = text "TsFun" <> parens (ppr ts)+  ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss)++trimToType :: Demand -> TypeShape -> Demand+-- See Note [Trimming a demand to a type]+trimToType (JD { sd = ms, ud = mu }) ts+  = JD (go_ms ms ts) (go_mu mu ts)+  where+    go_ms :: ArgStr -> TypeShape -> ArgStr+    go_ms Lazy      _  = Lazy+    go_ms (Str x s) ts = Str x (go_s s ts)++    go_s :: StrDmd -> TypeShape -> StrDmd+    go_s HyperStr    _            = HyperStr+    go_s (SCall s)   (TsFun ts)   = SCall (go_s s ts)+    go_s (SProd mss) (TsProd tss)+      | equalLength mss tss       = SProd (zipWith go_ms mss tss)+    go_s _           _            = HeadStr++    go_mu :: ArgUse -> TypeShape -> ArgUse+    go_mu Abs _ = Abs+    go_mu (Use c u) ts = Use c (go_u u ts)++    go_u :: UseDmd -> TypeShape -> UseDmd+    go_u UHead       _          = UHead+    go_u (UCall c u) (TsFun ts) = UCall c (go_u u ts)+    go_u (UProd mus) (TsProd tss)+      | equalLength mus tss      = UProd (zipWith go_mu mus tss)+    go_u _           _           = Used++{-+Note [Trimming a demand to a type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:++  f :: a -> Bool+  f x = case ... of+          A g1 -> case (x |> g1) of (p,q) -> ...+          B    -> error "urk"++where A,B are the constructors of a GADT.  We'll get a U(U,U) demand+on x from the A branch, but that's a stupid demand for x itself, which+has type 'a'. Indeed we get ASSERTs going off (notably in+splitUseProdDmd, Trac #8569).++Bottom line: we really don't want to have a binder whose demand is more+deeply-nested than its type.  There are various ways to tackle this.+When processing (x |> g1), we could "trim" the incoming demand U(U,U)+to match x's type.  But I'm currently doing so just at the moment when+we pin a demand on a binder, in DmdAnal.findBndrDmd.+++Note [Threshold demands]+~~~~~~~~~~~~~~~~~~~~~~~~+Threshold usage demand is generated to figure out if+cardinality-instrumented demands of a binding's free variables should+be unleashed. See also [Aggregated demand for cardinality].++Note [Replicating polymorphic demands]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Some demands can be considered as polymorphic. Generally, it is+applicable to such beasts as tops, bottoms as well as Head-Used and+Head-stricts demands. For instance,++S ~ S(L, ..., L)++Also, when top or bottom is occurred as a result demand, it in fact+can be expanded to saturate a callee's arity.+-}++splitProdDmd_maybe :: Demand -> Maybe [Demand]+-- Split a product into its components, iff there is any+-- useful information to be extracted thereby+-- The demand is not necessarily strict!+splitProdDmd_maybe (JD { sd = s, ud = u })+  = case (s,u) of+      (Str _ (SProd sx), Use _ u) | Just ux <- splitUseProdDmd (length sx) u+                                  -> Just (mkJointDmds sx ux)+      (Str _ s, Use _ (UProd ux)) | Just sx <- splitStrProdDmd (length ux) s+                                  -> Just (mkJointDmds sx ux)+      (Lazy,    Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux)+      _ -> Nothing++{-+************************************************************************+*                                                                      *+                   Demand results+*                                                                      *+************************************************************************+++DmdResult:     Dunno CPRResult+               /+           ThrowsExn+             /+        Diverges+++CPRResult:         NoCPR+                   /    \+            RetProd    RetSum ConTag+++Product constructors return (Dunno (RetProd rs))+In a fixpoint iteration, start from Diverges+We have lubs, but not glbs; but that is ok.+-}++------------------------------------------------------------------------+-- Constructed Product Result+------------------------------------------------------------------------++data Termination r+  = Diverges    -- Definitely diverges+  | ThrowsExn   -- Definitely throws an exception or diverges+  | Dunno r     -- Might diverge or converge+  deriving( Eq, Show )++type DmdResult = Termination CPRResult++data CPRResult = NoCPR          -- Top of the lattice+               | RetProd        -- Returns a constructor from a product type+               | RetSum ConTag  -- Returns a constructor from a data type+               deriving( Eq, Show )++lubCPR :: CPRResult -> CPRResult -> CPRResult+lubCPR (RetSum t1) (RetSum t2)+  | t1 == t2                       = RetSum t1+lubCPR RetProd     RetProd     = RetProd+lubCPR _ _                     = NoCPR++lubDmdResult :: DmdResult -> DmdResult -> DmdResult+lubDmdResult Diverges       r              = r+lubDmdResult ThrowsExn      Diverges       = ThrowsExn+lubDmdResult ThrowsExn      r              = r+lubDmdResult (Dunno c1)     Diverges       = Dunno c1+lubDmdResult (Dunno c1)     ThrowsExn      = Dunno c1+lubDmdResult (Dunno c1)     (Dunno c2)     = Dunno (c1 `lubCPR` c2)+-- This needs to commute with defaultDmd, i.e.+-- defaultDmd (r1 `lubDmdResult` r2) = defaultDmd r1 `lubDmd` defaultDmd r2+-- (See Note [Default demand on free variables] for why)++bothDmdResult :: DmdResult -> Termination () -> DmdResult+-- See Note [Asymmetry of 'both' for DmdType and DmdResult]+bothDmdResult _ Diverges   = Diverges+bothDmdResult r ThrowsExn  = case r of { Diverges -> r; _ -> ThrowsExn }+bothDmdResult r (Dunno {}) = r+-- This needs to commute with defaultDmd, i.e.+-- defaultDmd (r1 `bothDmdResult` r2) = defaultDmd r1 `bothDmd` defaultDmd r2+-- (See Note [Default demand on free variables] for why)++instance Outputable r => Outputable (Termination r) where+  ppr Diverges      = char 'b'+  ppr ThrowsExn     = char 'x'+  ppr (Dunno c)     = ppr c++instance Outputable CPRResult where+  ppr NoCPR        = empty+  ppr (RetSum n)   = char 'm' <> int n+  ppr RetProd      = char 'm'++seqDmdResult :: DmdResult -> ()+seqDmdResult Diverges  = ()+seqDmdResult ThrowsExn = ()+seqDmdResult (Dunno c) = seqCPRResult c++seqCPRResult :: CPRResult -> ()+seqCPRResult NoCPR        = ()+seqCPRResult (RetSum n)   = n `seq` ()+seqCPRResult RetProd      = ()+++------------------------------------------------------------------------+-- Combined demand result                                             --+------------------------------------------------------------------------++-- [cprRes] lets us switch off CPR analysis+-- by making sure that everything uses TopRes+topRes, exnRes, botRes :: DmdResult+topRes = Dunno NoCPR+exnRes = ThrowsExn+botRes = Diverges++cprSumRes :: ConTag -> DmdResult+cprSumRes tag = Dunno $ RetSum tag++cprProdRes :: [DmdType] -> DmdResult+cprProdRes _arg_tys = Dunno $ RetProd++vanillaCprProdRes :: Arity -> DmdResult+vanillaCprProdRes _arity = Dunno $ RetProd++isTopRes :: DmdResult -> Bool+isTopRes (Dunno NoCPR) = True+isTopRes _             = False++isBotRes :: DmdResult -> Bool+-- True if the result diverges or throws an exception+isBotRes Diverges   = True+isBotRes ThrowsExn  = True+isBotRes (Dunno {}) = False++trimCPRInfo :: Bool -> Bool -> DmdResult -> DmdResult+trimCPRInfo trim_all trim_sums res+  = trimR res+  where+    trimR (Dunno c) = Dunno (trimC c)+    trimR res       = res++    trimC (RetSum n)   | trim_all || trim_sums = NoCPR+                       | otherwise             = RetSum n+    trimC RetProd      | trim_all  = NoCPR+                       | otherwise = RetProd+    trimC NoCPR = NoCPR++returnsCPR_maybe :: DmdResult -> Maybe ConTag+returnsCPR_maybe (Dunno c) = retCPR_maybe c+returnsCPR_maybe _         = Nothing++retCPR_maybe :: CPRResult -> Maybe ConTag+retCPR_maybe (RetSum t)  = Just t+retCPR_maybe RetProd     = Just fIRST_TAG+retCPR_maybe NoCPR       = Nothing++-- See Notes [Default demand on free variables]+-- and [defaultDmd vs. resTypeArgDmd]+defaultDmd :: Termination r -> Demand+defaultDmd (Dunno {}) = absDmd+defaultDmd _          = botDmd  -- Diverges or ThrowsExn++resTypeArgDmd :: Termination r -> Demand+-- TopRes and BotRes are polymorphic, so that+--      BotRes === (Bot -> BotRes) === ...+--      TopRes === (Top -> TopRes) === ...+-- This function makes that concrete+-- Also see Note [defaultDmd vs. resTypeArgDmd]+resTypeArgDmd (Dunno _) = topDmd+resTypeArgDmd _         = botDmd   -- Diverges or ThrowsExn++{-+Note [defaultDmd and resTypeArgDmd]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++These functions are similar: They express the demand on something not+explicitly mentioned in the environment resp. the argument list. Yet they are+different:+ * Variables not mentioned in the free variables environment are definitely+   unused, so we can use absDmd there.+ * Further arguments *can* be used, of course. Hence topDmd is used.++Note [Worthy functions for Worker-Wrapper split]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For non-bottoming functions a worker-wrapper transformation takes into+account several possibilities to decide if the function is worthy for+splitting:++1. The result is of product type and the function is strict in some+(or even all) of its arguments. The check that the argument is used is+more of sanity nature, since strictness implies usage. Example:++f :: (Int, Int) -> Int+f p = (case p of (a,b) -> a) + 1++should be splitted to++f :: (Int, Int) -> Int+f p = case p of (a,b) -> $wf a++$wf :: Int -> Int+$wf a = a + 1++2. Sometimes it also makes sense to perform a WW split if the+strictness analysis cannot say for sure if the function is strict in+components of its argument. Then we reason according to the inferred+usage information: if the function uses its product argument's+components, the WW split can be beneficial. Example:++g :: Bool -> (Int, Int) -> Int+g c p = case p of (a,b) ->+          if c then a else b++The function g is strict in is argument p and lazy in its+components. However, both components are used in the RHS. The idea is+since some of the components (both in this case) are used in the+right-hand side, the product must presumable be taken apart.++Therefore, the WW transform splits the function g to++g :: Bool -> (Int, Int) -> Int+g c p = case p of (a,b) -> $wg c a b++$wg :: Bool -> Int -> Int -> Int+$wg c a b = if c then a else b++3. If an argument is absent, it would be silly to pass it to a+function, hence the worker with reduced arity is generated.+++Note [Worker-wrapper for bottoming functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used not to split if the result is bottom.+[Justification:  there's no efficiency to be gained.]++But it's sometimes bad not to make a wrapper.  Consider+        fw = \x# -> let x = I# x# in case e of+                                        p1 -> error_fn x+                                        p2 -> error_fn x+                                        p3 -> the real stuff+The re-boxing code won't go away unless error_fn gets a wrapper too.+[We don't do reboxing now, but in general it's better to pass an+unboxed thing to f, and have it reboxed in the error cases....]++However we *don't* want to do this when the argument is not actually+taken apart in the function at all.  Otherwise we risk decomposing a+massive tuple which is barely used.  Example:++        f :: ((Int,Int) -> String) -> (Int,Int) -> a+        f g pr = error (g pr)++        main = print (f fst (1, error "no"))++Here, f does not take 'pr' apart, and it's stupid to do so.+Imagine that it had millions of fields. This actually happened+in GHC itself where the tuple was DynFlags+++************************************************************************+*                                                                      *+           Demand environments and types+*                                                                      *+************************************************************************+-}++type DmdEnv = VarEnv Demand   -- See Note [Default demand on free variables]++data DmdType = DmdType+                  DmdEnv        -- Demand on explicitly-mentioned+                                --      free variables+                  [Demand]      -- Demand on arguments+                  DmdResult     -- See [Nature of result demand]++{-+Note [Nature of result demand]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A DmdResult contains information about termination (currently distinguishing+definite divergence and no information; it is possible to include definite+convergence here), and CPR information about the result.++The semantics of this depends on whether we are looking at a DmdType, i.e. the+demand put on by an expression _under a specific incoming demand_ on its+environment, or at a StrictSig describing a demand transformer.++For a+ * DmdType, the termination information is true given the demand it was+   generated with, while for+ * a StrictSig it holds after applying enough arguments.++The CPR information, though, is valid after the number of arguments mentioned+in the type is given. Therefore, when forgetting the demand on arguments, as in+dmdAnalRhs, this needs to be considere (via removeDmdTyArgs).++Consider+  b2 x y = x `seq` y `seq` error (show x)+this has a strictness signature of+  <S><S>b+meaning that "b2 `seq` ()" and "b2 1 `seq` ()" might well terminate, but+for "b2 1 2 `seq` ()" we get definite divergence.++For comparison,+  b1 x = x `seq` error (show x)+has a strictness signature of+  <S>b+and "b1 1 `seq` ()" is known to terminate.++Now consider a function h with signature "<C(S)>", and the expression+  e1 = h b1+now h puts a demand of <C(S)> onto its argument, and the demand transformer+turns it into+  <S>b+Now the DmdResult "b" does apply to us, even though "b1 `seq` ()" does not+diverge, and we do not anything being passed to b.++Note [Asymmetry of 'both' for DmdType and DmdResult]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+'both' for DmdTypes is *asymmetrical*, because there is only one+result!  For example, given (e1 e2), we get a DmdType dt1 for e1, use+its arg demand to analyse e2 giving dt2, and then do (dt1 `bothType` dt2).+Similarly with+  case e of { p -> rhs }+we get dt_scrut from the scrutinee and dt_rhs from the RHS, and then+compute (dt_rhs `bothType` dt_scrut).++We+ 1. combine the information on the free variables,+ 2. take the demand on arguments from the first argument+ 3. combine the termination results, but+ 4. take CPR info from the first argument.++3 and 4 are implementd in bothDmdResult.+-}++-- Equality needed for fixpoints in DmdAnal+instance Eq DmdType where+  (==) (DmdType fv1 ds1 res1)+       (DmdType fv2 ds2 res2) = nonDetUFMToList fv1 == nonDetUFMToList fv2+         -- It's OK to use nonDetUFMToList here because we're testing for+         -- equality and even though the lists will be in some arbitrary+         -- Unique order, it is the same order for both+                              && ds1 == ds2 && res1 == res2++lubDmdType :: DmdType -> DmdType -> DmdType+lubDmdType d1 d2+  = DmdType lub_fv lub_ds lub_res+  where+    n = max (dmdTypeDepth d1) (dmdTypeDepth d2)+    (DmdType fv1 ds1 r1) = ensureArgs n d1+    (DmdType fv2 ds2 r2) = ensureArgs n d2++    lub_fv  = plusVarEnv_CD lubDmd fv1 (defaultDmd r1) fv2 (defaultDmd r2)+    lub_ds  = zipWithEqual "lubDmdType" lubDmd ds1 ds2+    lub_res = lubDmdResult r1 r2++{-+Note [The need for BothDmdArg]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Previously, the right argument to bothDmdType, as well as the return value of+dmdAnalStar via postProcessDmdType, was a DmdType. But bothDmdType only needs+to know about the free variables and termination information, but nothing about+the demand put on arguments, nor cpr information. So we make that explicit by+only passing the relevant information.+-}++type BothDmdArg = (DmdEnv, Termination ())++mkBothDmdArg :: DmdEnv -> BothDmdArg+mkBothDmdArg env = (env, Dunno ())++toBothDmdArg :: DmdType -> BothDmdArg+toBothDmdArg (DmdType fv _ r) = (fv, go r)+  where+    go (Dunno {}) = Dunno ()+    go ThrowsExn  = ThrowsExn+    go Diverges   = Diverges++bothDmdType :: DmdType -> BothDmdArg -> DmdType+bothDmdType (DmdType fv1 ds1 r1) (fv2, t2)+    -- See Note [Asymmetry of 'both' for DmdType and DmdResult]+    -- 'both' takes the argument/result info from its *first* arg,+    -- using its second arg just for its free-var info.+  = DmdType (plusVarEnv_CD bothDmd fv1 (defaultDmd r1) fv2 (defaultDmd t2))+            ds1+            (r1 `bothDmdResult` t2)++instance Outputable DmdType where+  ppr (DmdType fv ds res)+    = hsep [hcat (map ppr ds) <> ppr res,+            if null fv_elts then empty+            else braces (fsep (map pp_elt fv_elts))]+    where+      pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd+      fv_elts = nonDetUFMToList fv+        -- It's OK to use nonDetUFMToList here because we only do it for+        -- pretty printing++emptyDmdEnv :: VarEnv Demand+emptyDmdEnv = emptyVarEnv++-- nopDmdType is the demand of doing nothing+-- (lazy, absent, no CPR information, no termination information).+-- Note that it is ''not'' the top of the lattice (which would be "may use everything"),+-- so it is (no longer) called topDmd+nopDmdType, botDmdType, exnDmdType :: DmdType+nopDmdType = DmdType emptyDmdEnv [] topRes+botDmdType = DmdType emptyDmdEnv [] botRes+exnDmdType = DmdType emptyDmdEnv [] exnRes++cprProdDmdType :: Arity -> DmdType+cprProdDmdType arity+  = DmdType emptyDmdEnv [] (vanillaCprProdRes arity)++isTopDmdType :: DmdType -> Bool+isTopDmdType (DmdType env [] res)+  | isTopRes res && isEmptyVarEnv env = True+isTopDmdType _                        = False++mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType+mkDmdType fv ds res = DmdType fv ds res++dmdTypeDepth :: DmdType -> Arity+dmdTypeDepth (DmdType _ ds _) = length ds++-- Remove any demand on arguments. This is used in dmdAnalRhs on the body+removeDmdTyArgs :: DmdType -> DmdType+removeDmdTyArgs = ensureArgs 0++-- This makes sure we can use the demand type with n arguments,+-- It extends the argument list with the correct resTypeArgDmd+-- It also adjusts the DmdResult: Divergence survives additional arguments,+-- CPR information does not (and definite converge also would not).+ensureArgs :: Arity -> DmdType -> DmdType+ensureArgs n d | n == depth = d+               | otherwise  = DmdType fv ds' r'+  where depth = dmdTypeDepth d+        DmdType fv ds r = d++        ds' = take n (ds ++ repeat (resTypeArgDmd r))+        r' = case r of    -- See [Nature of result demand]+              Dunno _ -> topRes+              _       -> r+++seqDmdType :: DmdType -> ()+seqDmdType (DmdType env ds res) =+  seqDmdEnv env `seq` seqDemandList ds `seq` seqDmdResult res `seq` ()++seqDmdEnv :: DmdEnv -> ()+seqDmdEnv env = seqEltsUFM seqDemandList env++splitDmdTy :: DmdType -> (Demand, DmdType)+-- Split off one function argument+-- We already have a suitable demand on all+-- free vars, so no need to add more!+splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty)+splitDmdTy ty@(DmdType _ [] res_ty)       = (resTypeArgDmd res_ty, ty)++-- When e is evaluated after executing an IO action, and d is e's demand, then+-- what of this demand should we consider, given that the IO action can cleanly+-- exit?+-- * We have to kill all strictness demands (i.e. lub with a lazy demand)+-- * We can keep usage information (i.e. lub with an absent demand)+-- * We have to kill definite divergence+-- * We can keep CPR information.+-- See Note [IO hack in the demand analyser] in DmdAnal+deferAfterIO :: DmdType -> DmdType+deferAfterIO d@(DmdType _ _ res) =+    case d `lubDmdType` nopDmdType of+        DmdType fv ds _ -> DmdType fv ds (defer_res res)+  where+  defer_res r@(Dunno {}) = r+  defer_res _            = topRes  -- Diverges and ThrowsExn++strictenDmd :: Demand -> CleanDemand+strictenDmd (JD { sd = s, ud = u})+  = JD { sd = poke_s s, ud = poke_u u }+  where+    poke_s Lazy      = HeadStr+    poke_s (Str _ s) = s+    poke_u Abs       = UHead+    poke_u (Use _ u) = u++-- Deferring and peeling++type DmdShell   -- Describes the "outer shell"+                -- of a Demand+   = JointDmd (Str ()) (Use ())++toCleanDmd :: Demand -> Type -> (DmdShell, CleanDemand)+-- Splits a Demand into its "shell" and the inner "clean demand"+toCleanDmd (JD { sd = s, ud = u }) expr_ty+  = (JD { sd = ss, ud = us }, JD { sd = s', ud = u' })+    -- See Note [Analyzing with lazy demand and lambdas]+  where+    (ss, s') = case s of+                Str x s'           -> (Str x      (), s')+                Lazy | is_unlifted -> (Str VanStr (), HeadStr)+                     | otherwise   -> (Lazy,          HeadStr)++    (us, u') = case u of+                 Use c u'          -> (Use c   (), u')+                 Abs | is_unlifted -> (Use One (), Used)+                     | otherwise   -> (Abs,        Used)++    is_unlifted = isUnliftedType expr_ty+    -- See Note [Analysing with absent demand]+++-- This is used in dmdAnalStar when post-processing+-- a function's argument demand. So we only care about what+-- does to free variables, and whether it terminates.+-- see Note [The need for BothDmdArg]+postProcessDmdType :: DmdShell -> DmdType -> BothDmdArg+postProcessDmdType du@(JD { sd = ss }) (DmdType fv _ res_ty)+    = (postProcessDmdEnv du fv, term_info)+    where+       term_info = case postProcessDmdResult ss res_ty of+                     Dunno _   -> Dunno ()+                     ThrowsExn -> ThrowsExn+                     Diverges  -> Diverges++postProcessDmdResult :: Str () -> DmdResult -> DmdResult+postProcessDmdResult Lazy           _         = topRes+postProcessDmdResult (Str ExnStr _) ThrowsExn = topRes  -- Key point!+postProcessDmdResult _              res       = res++postProcessDmdEnv :: DmdShell -> DmdEnv -> DmdEnv+postProcessDmdEnv ds@(JD { sd = ss, ud = us }) env+  | Abs <- us       = emptyDmdEnv+    -- In this case (postProcessDmd ds) == id; avoid a redundant rebuild+    -- of the environment. Be careful, bad things will happen if this doesn't+    -- match postProcessDmd (see #13977).+  | Str VanStr _ <- ss+  , Use One _ <- us = env+  | otherwise       = mapVarEnv (postProcessDmd ds) env+  -- For the Absent case just discard all usage information+  -- We only processed the thing at all to analyse the body+  -- See Note [Always analyse in virgin pass]++reuseEnv :: DmdEnv -> DmdEnv+reuseEnv = mapVarEnv (postProcessDmd+                        (JD { sd = Str VanStr (), ud = Use Many () }))++postProcessUnsat :: DmdShell -> DmdType -> DmdType+postProcessUnsat ds@(JD { sd = ss }) (DmdType fv args res_ty)+  = DmdType (postProcessDmdEnv ds fv)+            (map (postProcessDmd ds) args)+            (postProcessDmdResult ss res_ty)++postProcessDmd :: DmdShell -> Demand -> Demand+postProcessDmd (JD { sd = ss, ud = us }) (JD { sd = s, ud = a})+  = JD { sd = s', ud = a' }+  where+    s' = case ss of+           Lazy         -> Lazy+           Str ExnStr _ -> markExnStr s+           Str VanStr _ -> s+    a' = case us of+           Abs        -> Abs+           Use Many _ -> markReusedDmd a+           Use One  _ -> a++markExnStr :: ArgStr -> ArgStr+markExnStr (Str VanStr s) = Str ExnStr s+markExnStr s              = s++-- Peels one call level from the demand, and also returns+-- whether it was unsaturated (separately for strictness and usage)+peelCallDmd :: CleanDemand -> (CleanDemand, DmdShell)+-- Exploiting the fact that+-- on the strictness side      C(B) = B+-- and on the usage side       C(U) = U+peelCallDmd (JD {sd = s, ud = u})+  = (JD { sd = s', ud = u' }, JD { sd = ss, ud = us })+  where+    (s', ss) = case s of+                 SCall s' -> (s',       Str VanStr ())+                 HyperStr -> (HyperStr, Str VanStr ())+                 _        -> (HeadStr,  Lazy)+    (u', us) = case u of+                 UCall c u' -> (u',   Use c    ())+                 _          -> (Used, Use Many ())+       -- The _ cases for usage includes UHead which seems a bit wrong+       -- because the body isn't used at all!+       -- c.f. the Abs case in toCleanDmd++-- Peels that multiple nestings of calls clean demand and also returns+-- whether it was unsaturated (separately for strictness and usage+-- see Note [Demands from unsaturated function calls]+peelManyCalls :: Int -> CleanDemand -> DmdShell+peelManyCalls n (JD { sd = str, ud = abs })+  = JD { sd = go_str n str, ud = go_abs n abs }+  where+    go_str :: Int -> StrDmd -> Str ()  -- True <=> unsaturated, defer+    go_str 0 _          = Str VanStr ()+    go_str _ HyperStr   = Str VanStr () -- == go_str (n-1) HyperStr, as HyperStr = Call(HyperStr)+    go_str n (SCall d') = go_str (n-1) d'+    go_str _ _          = Lazy++    go_abs :: Int -> UseDmd -> Use ()      -- Many <=> unsaturated, or at least+    go_abs 0 _              = Use One ()   --          one UCall Many in the demand+    go_abs n (UCall One d') = go_abs (n-1) d'+    go_abs _ _              = Use Many ()++{-+Note [Demands from unsaturated function calls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Consider a demand transformer d1 -> d2 -> r for f.+If a sufficiently detailed demand is fed into this transformer,+e.g <C(C(S)), C1(C1(S))> arising from "f x1 x2" in a strict, use-once context,+then d1 and d2 is precisely the demand unleashed onto x1 and x2 (similar for+the free variable environment) and furthermore the result information r is the+one we want to use.++An anonymous lambda is also an unsaturated function all (needs one argument,+none given), so this applies to that case as well.++But the demand fed into f might be less than <C(C(S)), C1(C1(S))>. There are a few cases:+ * Not enough demand on the strictness side:+   - In that case, we need to zap all strictness in the demand on arguments and+     free variables.+   - Furthermore, we remove CPR information. It could be left, but given the incoming+     demand is not enough to evaluate so far we just do not bother.+   - And finally termination information: If r says that f diverges for sure,+     then this holds when the demand guarantees that two arguments are going to+     be passed. If the demand is lower, we may just as well converge.+     If we were tracking definite convegence, than that would still hold under+     a weaker demand than expected by the demand transformer.+ * Not enough demand from the usage side: The missing usage can be expanded+   using UCall Many, therefore this is subsumed by the third case:+ * At least one of the uses has a cardinality of Many.+   - Even if f puts a One demand on any of its argument or free variables, if+     we call f multiple times, we may evaluate this argument or free variable+     multiple times. So forget about any occurrence of "One" in the demand.++In dmdTransformSig, we call peelManyCalls to find out if we are in any of these+cases, and then call postProcessUnsat to reduce the demand appropriately.++Similarly, dmdTransformDictSelSig and dmdAnal, when analyzing a Lambda, use+peelCallDmd, which peels only one level, but also returns the demand put on the+body of the function.+-}++peelFV :: DmdType -> Var -> (DmdType, Demand)+peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)+                               (DmdType fv' ds res, dmd)+  where+  fv' = fv `delVarEnv` id+  -- See Note [Default demand on free variables]+  dmd  = lookupVarEnv fv id `orElse` defaultDmd res++addDemand :: Demand -> DmdType -> DmdType+addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res++findIdDemand :: DmdType -> Var -> Demand+findIdDemand (DmdType fv _ res) id+  = lookupVarEnv fv id `orElse` defaultDmd res++{-+Note [Default demand on free variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the variable is not mentioned in the environment of a demand type,+its demand is taken to be a result demand of the type.+    For the stricness component,+     if the result demand is a Diverges, then we use HyperStr+                                         else we use Lazy+    For the usage component, we use Absent.+So we use either absDmd or botDmd.++Also note the equations for lubDmdResult (resp. bothDmdResult) noted there.++Note [Always analyse in virgin pass]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Tricky point: make sure that we analyse in the 'virgin' pass. Consider+   rec { f acc x True  = f (...rec { g y = ...g... }...)+         f acc x False = acc }+In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type.+That might mean that we analyse the sub-expression containing the+E = "...rec g..." stuff in a bottom demand.  Suppose we *didn't analyse*+E, but just returned botType.++Then in the *next* (non-virgin) iteration for 'f', we might analyse E+in a weaker demand, and that will trigger doing a fixpoint iteration+for g.  But *because it's not the virgin pass* we won't start g's+iteration at bottom.  Disaster.  (This happened in $sfibToList' of+nofib/spectral/fibheaps.)++So in the virgin pass we make sure that we do analyse the expression+at least once, to initialise its signatures.++Note [Analyzing with lazy demand and lambdas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The insight for analyzing lambdas follows from the fact that for+strictness S = C(L). This polymorphic expansion is critical for+cardinality analysis of the following example:++{-# NOINLINE build #-}+build g = (g (:) [], g (:) [])++h c z = build (\x ->+                let z1 = z ++ z+                 in if c+                    then \y -> x (y ++ z1)+                    else \y -> x (z1 ++ y))++One can see that `build` assigns to `g` demand <L,C(C1(U))>.+Therefore, when analyzing the lambda `(\x -> ...)`, we+expect each lambda \y -> ... to be annotated as "one-shot"+one. Therefore (\x -> \y -> x (y ++ z)) should be analyzed with a+demand <C(C(..), C(C1(U))>.++This is achieved by, first, converting the lazy demand L into the+strict S by the second clause of the analysis.++Note [Analysing with absent demand]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we analyse an expression with demand <L,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 postProcessDmdType.++* But in the case of an *unlifted type* we must be extra careful,+  because unlifted values are evaluated even if they are not used.+  Example (see Trac #9254):+     f :: (() -> (# Int#, () #)) -> ()+          -- Strictness signature is+          --    <C(S(LS)), 1*C1(U(A,1*U()))>+          -- I.e. calls k, but discards first component of result+     f k = case k () of (# _, r #) -> r++     g :: Int -> ()+     g y = f (\n -> (# case y of I# y2 -> y2, n #))++  Here f's strictness signature says (correctly) that it calls its+  argument function and ignores the first component of its result.+  This is correct in the sense that it'd be fine to (say) modify the+  function so that always returned 0# in the first component.++  But in function g, we *will* evaluate the 'case y of ...', because+  it has type Int#.  So 'y' will be evaluated.  So we must record this+  usage of 'y', else 'g' will say 'y' is absent, and will w/w so that+  'y' is bound to an aBSENT_ERROR thunk.++  An alternative would be to replace the 'case y of ...' with (say) 0#,+  but I have not tried that. It's not a common situation, but it is+  not theoretical: unsafePerformIO's implementation is very very like+  'f' above.+++************************************************************************+*                                                                      *+                     Demand signatures+*                                                                      *+************************************************************************++In a let-bound Id we record its strictness info.+In principle, this strictness info is a demand transformer, mapping+a demand on the Id into a DmdType, which gives+        a) the free vars of the Id's value+        b) the Id's arguments+        c) an indication of the result of applying+           the Id to its arguments++However, in fact we store in the Id an extremely emascuated demand+transfomer, namely++                a single DmdType+(Nevertheless we dignify StrictSig as a distinct type.)++This DmdType gives the demands unleashed by the Id when it is applied+to as many arguments as are given in by the arg demands in the DmdType.+Also see Note [Nature of result demand] for the meaning of a DmdResult in a+strictness signature.++If an Id is applied to less arguments than its arity, it means that+the demand on the function at a call site is weaker than the vanilla+call demand, used for signature inference. Therefore we place a top+demand on all arguments. Otherwise, the demand is specified by Id's+signature.++For example, the demand transformer described by the demand signature+        StrictSig (DmdType {x -> <S,1*U>} <L,A><L,U(U,U)>m)+says that when the function is applied to two arguments, it+unleashes demand <S,1*U> on the free var x, <L,A> on the first arg,+and <L,U(U,U)> on the second, then returning a constructor.++If this same function is applied to one arg, all we can say is that it+uses x with <L,U>, and its arg with demand <L,U>.+-}++newtype StrictSig = StrictSig DmdType+                  deriving( Eq )++instance Outputable StrictSig where+   ppr (StrictSig ty) = ppr ty++-- Used for printing top-level strictness pragmas in interface files+pprIfaceStrictSig :: StrictSig -> SDoc+pprIfaceStrictSig (StrictSig (DmdType _ dmds res))+  = hcat (map ppr dmds) <> ppr res++mkStrictSig :: DmdType -> StrictSig+mkStrictSig dmd_ty = StrictSig dmd_ty++mkClosedStrictSig :: [Demand] -> DmdResult -> StrictSig+mkClosedStrictSig ds res = mkStrictSig (DmdType emptyDmdEnv ds res)++splitStrictSig :: StrictSig -> ([Demand], DmdResult)+splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)++increaseStrictSigArity :: Int -> StrictSig -> StrictSig+-- Add extra arguments to a strictness signature+increaseStrictSigArity arity_increase (StrictSig (DmdType env dmds res))+  = StrictSig (DmdType env (replicate arity_increase topDmd ++ dmds) res)++isTopSig :: StrictSig -> Bool+isTopSig (StrictSig ty) = isTopDmdType ty++hasDemandEnvSig :: StrictSig -> Bool+hasDemandEnvSig (StrictSig (DmdType env _ _)) = not (isEmptyVarEnv env)++strictSigDmdEnv :: StrictSig -> DmdEnv+strictSigDmdEnv (StrictSig (DmdType env _ _)) = env++isBottomingSig :: StrictSig -> Bool+-- True if the signature diverges or throws an exception+isBottomingSig (StrictSig (DmdType _ _ res)) = isBotRes res++nopSig, botSig, exnSig :: StrictSig+nopSig = StrictSig nopDmdType+botSig = StrictSig botDmdType+exnSig = StrictSig exnDmdType++cprProdSig :: Arity -> StrictSig+cprProdSig arity = StrictSig (cprProdDmdType arity)++seqStrictSig :: StrictSig -> ()+seqStrictSig (StrictSig ty) = seqDmdType ty++dmdTransformSig :: StrictSig -> CleanDemand -> DmdType+-- (dmdTransformSig fun_sig dmd) considers a call to a function whose+-- signature is fun_sig, with demand dmd.  We return the demand+-- that the function places on its context (eg its args)+dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) cd+  = postProcessUnsat (peelManyCalls (length arg_ds) cd) dmd_ty+    -- see Note [Demands from unsaturated function calls]++dmdTransformDataConSig :: Arity -> StrictSig -> CleanDemand -> DmdType+-- Same as dmdTransformSig but for a data constructor (worker),+-- which has a special kind of demand transformer.+-- If the constructor is saturated, we feed the demand on+-- the result into the constructor arguments.+dmdTransformDataConSig arity (StrictSig (DmdType _ _ con_res))+                             (JD { sd = str, ud = abs })+  | Just str_dmds <- go_str arity str+  , Just abs_dmds <- go_abs arity abs+  = DmdType emptyDmdEnv (mkJointDmds str_dmds abs_dmds) con_res+                -- Must remember whether it's a product, hence con_res, not TopRes++  | otherwise   -- Not saturated+  = nopDmdType+  where+    go_str 0 dmd        = splitStrProdDmd arity dmd+    go_str n (SCall s') = go_str (n-1) s'+    go_str n HyperStr   = go_str (n-1) HyperStr+    go_str _ _          = Nothing++    go_abs 0 dmd            = splitUseProdDmd arity dmd+    go_abs n (UCall One u') = go_abs (n-1) u'+    go_abs _ _              = Nothing++dmdTransformDictSelSig :: StrictSig -> CleanDemand -> DmdType+-- Like dmdTransformDataConSig, we have a special demand transformer+-- for dictionary selectors.  If the selector is saturated (ie has one+-- argument: the dictionary), we feed the demand on the result into+-- the indicated dictionary component.+dmdTransformDictSelSig (StrictSig (DmdType _ [dict_dmd] _)) cd+   | (cd',defer_use) <- peelCallDmd cd+   , Just jds <- splitProdDmd_maybe dict_dmd+   = postProcessUnsat defer_use $+     DmdType emptyDmdEnv [mkOnceUsedDmd $ mkProdDmd $ map (enhance cd') jds] topRes+   | otherwise+   = nopDmdType              -- See Note [Demand transformer for a dictionary selector]+  where+    enhance cd old | isAbsDmd old = old+                   | otherwise    = mkOnceUsedDmd cd  -- This is the one!++dmdTransformDictSelSig _ _ = panic "dmdTransformDictSelSig: no args"++{-+Note [Demand transformer for a dictionary selector]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we evaluate (op dict-expr) under demand 'd', then we can push the demand 'd'+into the appropriate field of the dictionary. What *is* the appropriate field?+We just look at the strictness signature of the class op, which will be+something like: U(AAASAAAAA).  Then replace the 'S' by the demand 'd'.++For single-method classes, which are represented by newtypes the signature+of 'op' won't look like U(...), so the splitProdDmd_maybe will fail.+That's fine: if we are doing strictness analysis we are also doing inlining,+so we'll have inlined 'op' into a cast.  So we can bale out in a conservative+way, returning nopDmdType.++It is (just.. Trac #8329) possible to be running strictness analysis *without*+having inlined class ops from single-method classes.  Suppose you are using+ghc --make; and the first module has a local -O0 flag.  So you may load a class+without interface pragmas, ie (currently) without an unfolding for the class+ops.   Now if a subsequent module in the --make sweep has a local -O flag+you might do strictness analysis, but there is no inlining for the class op.+This is weird, so I'm not worried about whether this optimises brilliantly; but+it should not fall over.+-}++argsOneShots :: StrictSig -> Arity -> [[OneShotInfo]]+-- See Note [Computing one-shot info]+argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args+  | unsaturated_call = []+  | otherwise = go arg_ds+  where+    unsaturated_call = arg_ds `lengthExceeds` n_val_args++    go []               = []+    go (arg_d : arg_ds) = argOneShots arg_d `cons` go arg_ds++    -- Avoid list tail like [ [], [], [] ]+    cons [] [] = []+    cons a  as = a:as++-- saturatedByOneShots n C1(C1(...)) = True,+--   <=>+-- there are at least n nested C1(..) calls+-- See Note [Demand on the worker] in WorkWrap+saturatedByOneShots :: Int -> Demand -> Bool+saturatedByOneShots n (JD { ud = usg })+  = case usg of+      Use _ arg_usg -> go n arg_usg+      _             -> False+  where+    go 0 _             = True+    go n (UCall One u) = go (n-1) u+    go _ _             = False++argOneShots :: Demand          -- depending on saturation+            -> [OneShotInfo]+argOneShots (JD { ud = usg })+  = case usg of+      Use _ arg_usg -> go arg_usg+      _             -> []+  where+    go (UCall One  u) = OneShotLam : go u+    go (UCall Many u) = NoOneShotInfo : go u+    go _              = []++{- Note [Computing one-shot info]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a call+    f (\pqr. e1) (\xyz. e2) e3+where f has usage signature+    C1(C(C1(U))) C1(U) U+Then argsOneShots returns a [[OneShotInfo]] of+    [[OneShot,NoOneShotInfo,OneShot],  [OneShot]]+The occurrence analyser propagates this one-shot infor to the+binders \pqr and \xyz; see Note [Use one-shot information] in OccurAnal.+-}++-- appIsBottom returns true if an application to n args+-- would diverge or throw an exception+-- See Note [Unsaturated applications]+appIsBottom :: StrictSig -> Int -> Bool+appIsBottom (StrictSig (DmdType _ ds res)) n+            | isBotRes res                   = not $ lengthExceeds ds n+appIsBottom _                              _ = False++{-+Note [Unsaturated applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If a function having bottom as its demand result is applied to a less+number of arguments than its syntactic arity, we cannot say for sure+that it is going to diverge. This is the reason why we use the+function appIsBottom, which, given a strictness signature and a number+of arguments, says conservatively if the function is going to diverge+or not.++Zap absence or one-shot information, under control of flags++Note [Killing usage information]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The flags -fkill-one-shot and -fkill-absence let you switch off the generation+of absence or one-shot information altogether.  This is only used for performance+tests, to see how important they are.+-}++zapUsageEnvSig :: StrictSig -> StrictSig+-- Remove the usage environment from the demand+zapUsageEnvSig (StrictSig (DmdType _ ds r)) = mkClosedStrictSig ds r++zapUsageDemand :: Demand -> Demand+-- Remove the usage info, but not the strictness info, from the demand+zapUsageDemand = kill_usage $ KillFlags+    { kf_abs         = True+    , kf_used_once   = True+    , kf_called_once = True+    }++-- | Remove all 1* information (but not C1 information) from the demand+zapUsedOnceDemand :: Demand -> Demand+zapUsedOnceDemand = kill_usage $ KillFlags+    { kf_abs         = False+    , kf_used_once   = True+    , kf_called_once = False+    }++-- | Remove all 1* information (but not C1 information) from the strictness+--   signature+zapUsedOnceSig :: StrictSig -> StrictSig+zapUsedOnceSig (StrictSig (DmdType env ds r))+    = StrictSig (DmdType env (map zapUsedOnceDemand ds) r)++killUsageDemand :: DynFlags -> Demand -> Demand+-- See Note [Killing usage information]+killUsageDemand dflags dmd+  | Just kfs <- killFlags dflags = kill_usage kfs dmd+  | otherwise                    = dmd++killUsageSig :: DynFlags -> StrictSig -> StrictSig+-- See Note [Killing usage information]+killUsageSig dflags sig@(StrictSig (DmdType env ds r))+  | Just kfs <- killFlags dflags = StrictSig (DmdType env (map (kill_usage kfs) ds) r)+  | otherwise                    = sig++data KillFlags = KillFlags+    { kf_abs         :: Bool+    , kf_used_once   :: Bool+    , kf_called_once :: Bool+    }++killFlags :: DynFlags -> Maybe KillFlags+-- See Note [Killing usage information]+killFlags dflags+  | not kf_abs && not kf_used_once = Nothing+  | otherwise                      = Just (KillFlags {..})+  where+    kf_abs         = gopt Opt_KillAbsence dflags+    kf_used_once   = gopt Opt_KillOneShot dflags+    kf_called_once = kf_used_once++kill_usage :: KillFlags -> Demand -> Demand+kill_usage kfs (JD {sd = s, ud = u}) = JD {sd = s, ud = zap_musg kfs u}++zap_musg :: KillFlags -> ArgUse -> ArgUse+zap_musg kfs Abs+  | kf_abs kfs = useTop+  | otherwise  = Abs+zap_musg kfs (Use c u)+  | kf_used_once kfs = Use Many (zap_usg kfs u)+  | otherwise        = Use c    (zap_usg kfs u)++zap_usg :: KillFlags -> UseDmd -> UseDmd+zap_usg kfs (UCall c u)+    | kf_called_once kfs = UCall Many (zap_usg kfs u)+    | otherwise          = UCall c    (zap_usg kfs u)+zap_usg kfs (UProd us)   = UProd (map (zap_musg kfs) us)+zap_usg _   u            = u++-- If the argument is a used non-newtype dictionary, give it strict+-- demand. Also split the product type & demand and recur in order to+-- similarly strictify the argument's contained used non-newtype+-- superclass dictionaries. We use the demand as our recursive measure+-- to guarantee termination.+strictifyDictDmd :: Type -> Demand -> Demand+strictifyDictDmd ty dmd = case getUseDmd dmd of+  Use n _ |+    Just (tycon, _arg_tys, _data_con, inst_con_arg_tys)+      <- splitDataProductType_maybe ty,+    not (isNewTyCon tycon), isClassTyCon tycon -- is a non-newtype dictionary+    -> seqDmd `bothDmd` -- main idea: ensure it's strict+       case splitProdDmd_maybe dmd of+         -- superclass cycles should not be a problem, since the demand we are+         -- consuming would also have to be infinite in order for us to diverge+         Nothing -> dmd -- no components have interesting demand, so stop+                        -- looking for superclass dicts+         Just dmds+           | all (not . isAbsDmd) dmds -> evalDmd+             -- abstract to strict w/ arbitrary component use, since this+             -- smells like reboxing; results in CBV boxed+             --+             -- TODO revisit this if we ever do boxity analysis+           | otherwise -> case mkProdDmd $ zipWith strictifyDictDmd inst_con_arg_tys dmds of+               JD {sd = s,ud = a} -> JD (Str VanStr s) (Use n a)+             -- TODO could optimize with an aborting variant of zipWith since+             -- the superclass dicts are always a prefix+  _ -> dmd -- unused or not a dictionary++{-+Note [HyperStr and Use demands]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The information "HyperStr" needs to be in the strictness signature, and not in+the demand signature, because we still want to know about the demand on things. Consider++    f (x,y) True  = error (show x)+    f (x,y) False = x+1++The signature of f should be <S(SL),1*U(1*U(U),A)><S,1*U>m. If we were not+distinguishing the uses on x and y in the True case, we could either not figure+out how deeply we can unpack x, or that we do not have to pass y.+++************************************************************************+*                                                                      *+                     Serialisation+*                                                                      *+************************************************************************+-}++instance Binary StrDmd where+  put_ bh HyperStr     = do putByte bh 0+  put_ bh HeadStr      = do putByte bh 1+  put_ bh (SCall s)    = do putByte bh 2+                            put_ bh s+  put_ bh (SProd sx)   = do putByte bh 3+                            put_ bh sx+  get bh = do+         h <- getByte bh+         case h of+           0 -> do return HyperStr+           1 -> do return HeadStr+           2 -> do s  <- get bh+                   return (SCall s)+           _ -> do sx <- get bh+                   return (SProd sx)++instance Binary ExnStr where+  put_ bh VanStr = putByte bh 0+  put_ bh ExnStr = putByte bh 1++  get bh = do h <- getByte bh+              return (case h of+                        0 -> VanStr+                        _ -> ExnStr)++instance Binary ArgStr where+    put_ bh Lazy         = do+            putByte bh 0+    put_ bh (Str x s)    = do+            putByte bh 1+            put_ bh x+            put_ bh s++    get  bh = do+            h <- getByte bh+            case h of+              0 -> return Lazy+              _ -> do x <- get bh+                      s  <- get bh+                      return $ Str x s++instance Binary Count where+    put_ bh One  = do putByte bh 0+    put_ bh Many = do putByte bh 1++    get  bh = do h <- getByte bh+                 case h of+                   0 -> return One+                   _ -> return Many++instance Binary ArgUse where+    put_ bh Abs          = do+            putByte bh 0+    put_ bh (Use c u)    = do+            putByte bh 1+            put_ bh c+            put_ bh u++    get  bh = do+            h <- getByte bh+            case h of+              0 -> return Abs+              _ -> do c  <- get bh+                      u  <- get bh+                      return $ Use c u++instance Binary UseDmd where+    put_ bh Used         = do+            putByte bh 0+    put_ bh UHead        = do+            putByte bh 1+    put_ bh (UCall c u)    = do+            putByte bh 2+            put_ bh c+            put_ bh u+    put_ bh (UProd ux)   = do+            putByte bh 3+            put_ bh ux++    get  bh = do+            h <- getByte bh+            case h of+              0 -> return $ Used+              1 -> return $ UHead+              2 -> do c <- get bh+                      u <- get bh+                      return (UCall c u)+              _ -> do ux <- get bh+                      return (UProd ux)++instance (Binary s, Binary u) => Binary (JointDmd s u) where+    put_ bh (JD { sd = x, ud = y }) = do put_ bh x; put_ bh y+    get  bh = do+              x <- get bh+              y <- get bh+              return $ JD { sd = x, ud = y }++instance Binary StrictSig where+    put_ bh (StrictSig aa) = do+            put_ bh aa+    get bh = do+          aa <- get bh+          return (StrictSig aa)++instance Binary DmdType where+  -- Ignore DmdEnv when spitting out the DmdType+  put_ bh (DmdType _ ds dr)+       = do put_ bh ds+            put_ bh dr+  get bh+      = do ds <- get bh+           dr <- get bh+           return (DmdType emptyDmdEnv ds dr)++instance Binary DmdResult where+  put_ bh (Dunno c)     = do { putByte bh 0; put_ bh c }+  put_ bh ThrowsExn     = putByte bh 1+  put_ bh Diverges      = putByte bh 2++  get bh = do { h <- getByte bh+              ; case h of+                  0 -> do { c <- get bh; return (Dunno c) }+                  1 -> return ThrowsExn+                  _ -> return Diverges }++instance Binary CPRResult where+    put_ bh (RetSum n)   = do { putByte bh 0; put_ bh n }+    put_ bh RetProd      = putByte bh 1+    put_ bh NoCPR        = putByte bh 2++    get  bh = do+            h <- getByte bh+            case h of+              0 -> do { n <- get bh; return (RetSum n) }+              1 -> return RetProd+              _ -> return NoCPR
+ basicTypes/FieldLabel.hs view
@@ -0,0 +1,128 @@+{-+%+% (c) Adam Gundry 2013-2015+%++This module defines the representation of FieldLabels as stored in+TyCons.  As well as a selector name, these have some extra structure+to support the DuplicateRecordFields extension.++In the normal case (with NoDuplicateRecordFields), a datatype like++    data T = MkT { foo :: Int }++has++    FieldLabel { flLabel        = "foo"+               , flIsOverloaded = False+               , flSelector     = foo }.++In particular, the Name of the selector has the same string+representation as the label.  If DuplicateRecordFields+is enabled, however, the same declaration instead gives++    FieldLabel { flLabel        = "foo"+               , flIsOverloaded = True+               , flSelector     = $sel:foo:MkT }.++Now the name of the selector ($sel:foo:MkT) does not match the label of+the field (foo).  We must be careful not to show the selector name to+the user!  The point of mangling the selector name is to allow a+module to define the same field label in different datatypes:++    data T = MkT { foo :: Int }+    data U = MkU { foo :: Bool }++Now there will be two FieldLabel values for 'foo', one in T and one in+U.  They share the same label (FieldLabelString), but the selector+functions differ.++See also Note [Representing fields in AvailInfo] in Avail.++Note [Why selector names include data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++As explained above, a selector name includes the name of the first+data constructor in the type, so that the same label can appear+multiple times in the same module.  (This is irrespective of whether+the first constructor has that field, for simplicity.)++We use a data constructor name, rather than the type constructor name,+because data family instances do not have a representation type+constructor name generated until relatively late in the typechecking+process.++Of course, datatypes with no constructors cannot have any fields.++-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE StandaloneDeriving #-}++module FieldLabel ( FieldLabelString+                  , FieldLabelEnv+                  , FieldLbl(..)+                  , FieldLabel+                  , mkFieldLabelOccs+                  ) where++import OccName+import Name++import FastString+import FastStringEnv+import Outputable+import Binary++import Data.Data++-- | Field labels are just represented as strings;+-- they are not necessarily unique (even within a module)+type FieldLabelString = FastString++-- | A map from labels to all the auxiliary information+type FieldLabelEnv = DFastStringEnv FieldLabel+++type FieldLabel = FieldLbl Name++-- | Fields in an algebraic record type+data FieldLbl a = FieldLabel {+      flLabel        :: FieldLabelString, -- ^ User-visible label of the field+      flIsOverloaded :: Bool,             -- ^ Was DuplicateRecordFields on+                                          --   in the defining module for this datatype?+      flSelector     :: a                 -- ^ Record selector function+    }+  deriving (Eq, Functor, Foldable, Traversable)+deriving instance Data a => Data (FieldLbl a)++instance Outputable a => Outputable (FieldLbl a) where+    ppr fl = ppr (flLabel fl) <> braces (ppr (flSelector fl))++instance Binary a => Binary (FieldLbl a) where+    put_ bh (FieldLabel aa ab ac) = do+        put_ bh aa+        put_ bh ab+        put_ bh ac+    get bh = do+        ab <- get bh+        ac <- get bh+        ad <- get bh+        return (FieldLabel ab ac ad)+++-- | Record selector OccNames are built from the underlying field name+-- and the name of the first data constructor of the type, to support+-- duplicate record field names.+-- See Note [Why selector names include data constructors].+mkFieldLabelOccs :: FieldLabelString -> OccName -> Bool -> FieldLbl OccName+mkFieldLabelOccs lbl dc is_overloaded+  = FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded+               , flSelector = sel_occ }+  where+    str     = ":" ++ unpackFS lbl ++ ":" ++ occNameString dc+    sel_occ | is_overloaded = mkRecFldSelOcc str+            | otherwise     = mkVarOccFS lbl
+ basicTypes/Id.hs view
@@ -0,0 +1,946 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[Id]{@Ids@: Value and constructor identifiers}+-}++{-# LANGUAGE ImplicitParams, CPP #-}++-- |+-- #name_types#+-- GHC uses several kinds of name internally:+--+-- * 'OccName.OccName': see "OccName#name_types"+--+-- * 'RdrName.RdrName': see "RdrName#name_types"+--+-- * 'Name.Name': see "Name#name_types"+--+-- * 'Id.Id' represents names that not only have a 'Name.Name' but also a 'TyCoRep.Type' and some additional+--   details (a 'IdInfo.IdInfo' and one of 'Var.LocalIdDetails' or 'IdInfo.GlobalIdDetails') that+--   are added, modified and inspected by various compiler passes. These 'Var.Var' names may either+--   be global or local, see "Var#globalvslocal"+--+-- * 'Var.Var': see "Var#name_types"++module Id (+        -- * The main types+        Var, Id, isId,++        -- * In and Out variants+        InVar,  InId,+        OutVar, OutId,++        -- ** Simple construction+        mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo,+        mkLocalId, mkLocalCoVar, mkLocalIdOrCoVar,+        mkLocalIdOrCoVarWithInfo,+        mkLocalIdWithInfo, mkExportedLocalId, mkExportedVanillaId,+        mkSysLocal, mkSysLocalM, mkSysLocalOrCoVar, mkSysLocalOrCoVarM,+        mkUserLocal, mkUserLocalOrCoVar,+        mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal,+        mkWorkerId,++        -- ** Taking an Id apart+        idName, idType, idUnique, idInfo, idDetails,+        recordSelectorTyCon,++        -- ** Modifying an Id+        setIdName, setIdUnique, Id.setIdType,+        setIdExported, setIdNotExported,+        globaliseId, localiseId,+        setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,+        zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo,+        zapIdUsedOnceInfo, zapIdTailCallInfo,+        zapFragileIdInfo, zapIdStrictness,+        transferPolyIdInfo,++        -- ** Predicates on Ids+        isImplicitId, isDeadBinder,+        isStrictId,+        isExportedId, isLocalId, isGlobalId,+        isRecordSelector, isNaughtyRecordSelector,+        isPatSynRecordSelector,+        isDataConRecordSelector,+        isClassOpId_maybe, isDFunId,+        isPrimOpId, isPrimOpId_maybe,+        isFCallId, isFCallId_maybe,+        isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon,+        isConLikeId, isBottomingId, idIsFrom,+        hasNoBinding,++        -- ** Evidence variables+        DictId, isDictId, isEvVar,++        -- ** Join variables+        JoinId, isJoinId, isJoinId_maybe, idJoinArity,+        asJoinId, asJoinId_maybe, zapJoinId,++        -- ** Inline pragma stuff+        idInlinePragma, setInlinePragma, modifyInlinePragma,+        idInlineActivation, setInlineActivation, idRuleMatchInfo,++        -- ** One-shot lambdas+        isOneShotBndr, isProbablyOneShotLambda,+        setOneShotLambda, clearOneShotLambda,+        updOneShotInfo, setIdOneShotInfo,+        isStateHackType, stateHackOneShot, typeOneShot,++        -- ** Reading 'IdInfo' fields+        idArity,+        idCallArity, idFunRepArity,+        idUnfolding, realIdUnfolding,+        idSpecialisation, idCoreRules, idHasRules,+        idCafInfo,+        idOneShotInfo, idStateHackOneShotInfo,+        idOccInfo,+        isNeverLevPolyId,++        -- ** Writing 'IdInfo' fields+        setIdUnfolding, setCaseBndrEvald,+        setIdArity,+        setIdCallArity,++        setIdSpecialisation,+        setIdCafInfo,+        setIdOccInfo, zapIdOccInfo,++        setIdDemandInfo,+        setIdStrictness,++        idDemandInfo,+        idStrictness,++    ) where++#include "HsVersions.h"++import DynFlags+import CoreSyn ( CoreRule, evaldUnfolding, Unfolding( NoUnfolding ) )++import IdInfo+import BasicTypes++-- Imported and re-exported+import Var( Id, CoVar, DictId, JoinId,+            InId,  InVar,+            OutId, OutVar,+            idInfo, idDetails, setIdDetails, globaliseId, varType,+            isId, isLocalId, isGlobalId, isExportedId )+import qualified Var++import Type+import RepType+import TysPrim+import DataCon+import Demand+import Name+import Module+import Class+import {-# SOURCE #-} PrimOp (PrimOp)+import ForeignCall+import Maybes+import SrcLoc+import Outputable+import Unique+import UniqSupply+import FastString+import Util++-- infixl so you can say (id `set` a `set` b)+infixl  1 `setIdUnfolding`,+          `setIdArity`,+          `setIdCallArity`,+          `setIdOccInfo`,+          `setIdOneShotInfo`,++          `setIdSpecialisation`,+          `setInlinePragma`,+          `setInlineActivation`,+          `idCafInfo`,++          `setIdDemandInfo`,+          `setIdStrictness`,++          `asJoinId`,+          `asJoinId_maybe`++{-+************************************************************************+*                                                                      *+\subsection{Basic Id manipulation}+*                                                                      *+************************************************************************+-}++idName   :: Id -> Name+idName    = Var.varName++idUnique :: Id -> Unique+idUnique  = Var.varUnique++idType   :: Id -> Kind+idType    = Var.varType++setIdName :: Id -> Name -> Id+setIdName = Var.setVarName++setIdUnique :: Id -> Unique -> Id+setIdUnique = Var.setVarUnique++-- | Not only does this set the 'Id' 'Type', it also evaluates the type to try and+-- reduce space usage+setIdType :: Id -> Type -> Id+setIdType id ty = seqType ty `seq` Var.setVarType id ty++setIdExported :: Id -> Id+setIdExported = Var.setIdExported++setIdNotExported :: Id -> Id+setIdNotExported = Var.setIdNotExported++localiseId :: Id -> Id+-- Make an with the same unique and type as the+-- incoming Id, but with an *Internal* Name and *LocalId* flavour+localiseId id+  | ASSERT( isId id ) isLocalId id && isInternalName name+  = id+  | otherwise+  = Var.mkLocalVar (idDetails id) (localiseName name) (idType id) (idInfo id)+  where+    name = idName id++lazySetIdInfo :: Id -> IdInfo -> Id+lazySetIdInfo = Var.lazySetIdInfo++setIdInfo :: Id -> IdInfo -> Id+setIdInfo id info = info `seq` (lazySetIdInfo id info)+        -- Try to avoid spack leaks by seq'ing++modifyIdInfo :: (IdInfo -> IdInfo) -> Id -> Id+modifyIdInfo fn id = setIdInfo id (fn (idInfo id))++-- maybeModifyIdInfo tries to avoid unnecessary thrashing+maybeModifyIdInfo :: Maybe IdInfo -> Id -> Id+maybeModifyIdInfo (Just new_info) id = lazySetIdInfo id new_info+maybeModifyIdInfo Nothing         id = id++{-+************************************************************************+*                                                                      *+\subsection{Simple Id construction}+*                                                                      *+************************************************************************++Absolutely all Ids are made by mkId.  It is just like Var.mkId,+but in addition it pins free-tyvar-info onto the Id's type,+where it can easily be found.++Note [Free type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~+At one time we cached the free type variables of the type of an Id+at the root of the type in a TyNote.  The idea was to avoid repeating+the free-type-variable calculation.  But it turned out to slow down+the compiler overall. I don't quite know why; perhaps finding free+type variables of an Id isn't all that common whereas applying a+substitution (which changes the free type variables) is more common.+Anyway, we removed it in March 2008.+-}++-- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal"+mkGlobalId :: IdDetails -> Name -> Type -> IdInfo -> Id+mkGlobalId = Var.mkGlobalVar++-- | Make a global 'Id' without any extra information at all+mkVanillaGlobal :: Name -> Type -> Id+mkVanillaGlobal name ty = mkVanillaGlobalWithInfo name ty vanillaIdInfo++-- | Make a global 'Id' with no global information but some generic 'IdInfo'+mkVanillaGlobalWithInfo :: Name -> Type -> IdInfo -> Id+mkVanillaGlobalWithInfo = mkGlobalId VanillaId+++-- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal"+mkLocalId :: Name -> Type -> Id+mkLocalId name ty = mkLocalIdWithInfo name ty vanillaIdInfo+ -- It's tempting to ASSERT( not (isCoercionType ty) ), but don't. Sometimes,+ -- the type is a panic. (Search invented_id)++-- | Make a local CoVar+mkLocalCoVar :: Name -> Type -> CoVar+mkLocalCoVar name ty+  = ASSERT( isCoercionType ty )+    Var.mkLocalVar CoVarId name ty vanillaIdInfo++-- | Like 'mkLocalId', but checks the type to see if it should make a covar+mkLocalIdOrCoVar :: Name -> Type -> Id+mkLocalIdOrCoVar name ty+  | isCoercionType ty = mkLocalCoVar name ty+  | otherwise         = mkLocalId    name ty++-- | Make a local id, with the IdDetails set to CoVarId if the type indicates+-- so.+mkLocalIdOrCoVarWithInfo :: Name -> Type -> IdInfo -> Id+mkLocalIdOrCoVarWithInfo name ty info+  = Var.mkLocalVar details name ty info+  where+    details | isCoercionType ty = CoVarId+            | otherwise         = VanillaId++    -- proper ids only; no covars!+mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id+mkLocalIdWithInfo name ty info = Var.mkLocalVar VanillaId name ty info+        -- Note [Free type variables]++-- | Create a local 'Id' that is marked as exported.+-- This prevents things attached to it from being removed as dead code.+-- See Note [Exported LocalIds]+mkExportedLocalId :: IdDetails -> Name -> Type -> Id+mkExportedLocalId details name ty = Var.mkExportedLocalVar details name ty vanillaIdInfo+        -- Note [Free type variables]++mkExportedVanillaId :: Name -> Type -> Id+mkExportedVanillaId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo+        -- Note [Free type variables]+++-- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal")+-- that are created by the compiler out of thin air+mkSysLocal :: FastString -> Unique -> Type -> Id+mkSysLocal fs uniq ty = ASSERT( not (isCoercionType ty) )+                        mkLocalId (mkSystemVarName uniq fs) ty++-- | Like 'mkSysLocal', but checks to see if we have a covar type+mkSysLocalOrCoVar :: FastString -> Unique -> Type -> Id+mkSysLocalOrCoVar fs uniq ty+  = mkLocalIdOrCoVar (mkSystemVarName uniq fs) ty++mkSysLocalM :: MonadUnique m => FastString -> Type -> m Id+mkSysLocalM fs ty = getUniqueM >>= (\uniq -> return (mkSysLocal fs uniq ty))++mkSysLocalOrCoVarM :: MonadUnique m => FastString -> Type -> m Id+mkSysLocalOrCoVarM fs ty+  = getUniqueM >>= (\uniq -> return (mkSysLocalOrCoVar fs uniq ty))++-- | Create a user local 'Id'. These are local 'Id's (see "Var#globalvslocal") with a name and location that the user might recognize+mkUserLocal :: OccName -> Unique -> Type -> SrcSpan -> Id+mkUserLocal occ uniq ty loc = ASSERT( not (isCoercionType ty) )+                              mkLocalId (mkInternalName uniq occ loc) ty++-- | Like 'mkUserLocal', but checks if we have a coercion type+mkUserLocalOrCoVar :: OccName -> Unique -> Type -> SrcSpan -> Id+mkUserLocalOrCoVar occ uniq ty loc+  = mkLocalIdOrCoVar (mkInternalName uniq occ loc) ty++{-+Make some local @Ids@ for a template @CoreExpr@.  These have bogus+@Uniques@, but that's OK because the templates are supposed to be+instantiated before use.+-}++-- | Workers get local names. "CoreTidy" will externalise these if necessary+mkWorkerId :: Unique -> Id -> Type -> Id+mkWorkerId uniq unwrkr ty+  = mkLocalIdOrCoVar (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) ty++-- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings+mkTemplateLocal :: Int -> Type -> Id+mkTemplateLocal i ty = mkSysLocalOrCoVar (fsLit "v") (mkBuiltinUnique i) ty++-- | Create a template local for a series of types+mkTemplateLocals :: [Type] -> [Id]+mkTemplateLocals = mkTemplateLocalsNum 1++-- | Create a template local for a series of type, but start from a specified template local+mkTemplateLocalsNum :: Int -> [Type] -> [Id]+mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys++{- Note [Exported LocalIds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We use mkExportedLocalId for things like+ - Dictionary functions (DFunId)+ - Wrapper and matcher Ids for pattern synonyms+ - Default methods for classes+ - Pattern-synonym matcher and builder Ids+ - etc++They marked as "exported" in the sense that they should be kept alive+even if apparently unused in other bindings, and not dropped as dead+code by the occurrence analyser.  (But "exported" here does not mean+"brought into lexical scope by an import declaration". Indeed these+things are always internal Ids that the user never sees.)++It's very important that they are *LocalIds*, not GlobalIds, for lots+of reasons:++ * We want to treat them as free variables for the purpose of+   dependency analysis (e.g. CoreFVs.exprFreeVars).++ * Look them up in the current substitution when we come across+   occurrences of them (in Subst.lookupIdSubst). Lacking this we+   can get an out-of-date unfolding, which can in turn make the+   simplifier go into an infinite loop (Trac #9857)++ * Ensure that for dfuns that the specialiser does not float dict uses+   above their defns, which would prevent good simplifications happening.++ * The strictness analyser treats a occurrence of a GlobalId as+   imported and assumes it contains strictness in its IdInfo, which+   isn't true if the thing is bound in the same module as the+   occurrence.++In CoreTidy we must make all these LocalIds into GlobalIds, so that in+importing modules (in --make mode) we treat them as properly global.+That is what is happening in, say tidy_insts in TidyPgm.++************************************************************************+*                                                                      *+\subsection{Special Ids}+*                                                                      *+************************************************************************+-}++-- | If the 'Id' is that for a record selector, extract the 'sel_tycon'. Panic otherwise.+recordSelectorTyCon :: Id -> RecSelParent+recordSelectorTyCon id+  = case Var.idDetails id of+        RecSelId { sel_tycon = parent } -> parent+        _ -> panic "recordSelectorTyCon"+++isRecordSelector        :: Id -> Bool+isNaughtyRecordSelector :: Id -> Bool+isPatSynRecordSelector  :: Id -> Bool+isDataConRecordSelector  :: Id -> Bool+isPrimOpId              :: Id -> Bool+isFCallId               :: Id -> Bool+isDataConWorkId         :: Id -> Bool+isDFunId                :: Id -> Bool++isClassOpId_maybe       :: Id -> Maybe Class+isPrimOpId_maybe        :: Id -> Maybe PrimOp+isFCallId_maybe         :: Id -> Maybe ForeignCall+isDataConWorkId_maybe   :: Id -> Maybe DataCon++isRecordSelector id = case Var.idDetails id of+                        RecSelId {}     -> True+                        _               -> False++isDataConRecordSelector id = case Var.idDetails id of+                        RecSelId {sel_tycon = RecSelData _} -> True+                        _               -> False++isPatSynRecordSelector id = case Var.idDetails id of+                        RecSelId {sel_tycon = RecSelPatSyn _} -> True+                        _               -> False++isNaughtyRecordSelector id = case Var.idDetails id of+                        RecSelId { sel_naughty = n } -> n+                        _                               -> False++isClassOpId_maybe id = case Var.idDetails id of+                        ClassOpId cls -> Just cls+                        _other        -> Nothing++isPrimOpId id = case Var.idDetails id of+                        PrimOpId _ -> True+                        _          -> False++isDFunId id = case Var.idDetails id of+                        DFunId {} -> True+                        _         -> False++isPrimOpId_maybe id = case Var.idDetails id of+                        PrimOpId op -> Just op+                        _           -> Nothing++isFCallId id = case Var.idDetails id of+                        FCallId _ -> True+                        _         -> False++isFCallId_maybe id = case Var.idDetails id of+                        FCallId call -> Just call+                        _            -> Nothing++isDataConWorkId id = case Var.idDetails id of+                        DataConWorkId _ -> True+                        _               -> False++isDataConWorkId_maybe id = case Var.idDetails id of+                        DataConWorkId con -> Just con+                        _                 -> Nothing++isDataConId_maybe :: Id -> Maybe DataCon+isDataConId_maybe id = case Var.idDetails id of+                         DataConWorkId con -> Just con+                         DataConWrapId con -> Just con+                         _                 -> Nothing++isJoinId :: Var -> Bool+-- It is convenient in SetLevels.lvlMFE to apply isJoinId+-- to the free vars of an expression, so it's convenient+-- if it returns False for type variables+isJoinId id+  | isId id = case Var.idDetails id of+                JoinId {} -> True+                _         -> False+  | otherwise = False++isJoinId_maybe :: Var -> Maybe JoinArity+isJoinId_maybe id+ | isId id  = ASSERT2( isId id, ppr id )+              case Var.idDetails id of+                JoinId arity -> Just arity+                _            -> Nothing+ | otherwise = Nothing++idDataCon :: Id -> DataCon+-- ^ Get from either the worker or the wrapper 'Id' to the 'DataCon'. Currently used only in the desugarer.+--+-- INVARIANT: @idDataCon (dataConWrapId d) = d@: remember, 'dataConWrapId' can return either the wrapper or the worker+idDataCon id = isDataConId_maybe id `orElse` pprPanic "idDataCon" (ppr id)++hasNoBinding :: Id -> Bool+-- ^ Returns @True@ of an 'Id' which may not have a+-- binding, even though it is defined in this module.++-- Data constructor workers used to be things of this kind, but+-- they aren't any more.  Instead, we inject a binding for+-- them at the CorePrep stage.+-- EXCEPT: unboxed tuples, which definitely have no binding+hasNoBinding id = case Var.idDetails id of+                        PrimOpId _       -> True        -- See Note [Primop wrappers]+                        FCallId _        -> True+                        DataConWorkId dc -> isUnboxedTupleCon dc || isUnboxedSumCon dc+                        _                -> False++isImplicitId :: Id -> Bool+-- ^ 'isImplicitId' tells whether an 'Id's info is implied by other+-- declarations, so we don't need to put its signature in an interface+-- file, even if it's mentioned in some other interface unfolding.+isImplicitId id+  = case Var.idDetails id of+        FCallId {}       -> True+        ClassOpId {}     -> True+        PrimOpId {}      -> True+        DataConWorkId {} -> True+        DataConWrapId {} -> True+                -- These are implied by their type or class decl;+                -- remember that all type and class decls appear in the interface file.+                -- The dfun id is not an implicit Id; it must *not* be omitted, because+                -- it carries version info for the instance decl+        _               -> False++idIsFrom :: Module -> Id -> Bool+idIsFrom mod id = nameIsLocalOrFrom mod (idName id)++{-+Note [Primop wrappers]+~~~~~~~~~~~~~~~~~~~~~~+Currently hasNoBinding claims that PrimOpIds don't have a curried+function definition.  But actually they do, in GHC.PrimopWrappers,+which is auto-generated from prelude/primops.txt.pp.  So actually, hasNoBinding+could return 'False' for PrimOpIds.++But we'd need to add something in CoreToStg to swizzle any unsaturated+applications of GHC.Prim.plusInt# to GHC.PrimopWrappers.plusInt#.++Nota Bene: GHC.PrimopWrappers is needed *regardless*, because it's+used by GHCi, which does not implement primops direct at all.+-}++isDeadBinder :: Id -> Bool+isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr)+                  | otherwise = False   -- TyVars count as not dead++{-+************************************************************************+*                                                                      *+              Evidence variables+*                                                                      *+************************************************************************+-}++isEvVar :: Var -> Bool+isEvVar var = isPredTy (varType var)++isDictId :: Id -> Bool+isDictId id = isDictTy (idType id)++{-+************************************************************************+*                                                                      *+              Join variables+*                                                                      *+************************************************************************+-}++idJoinArity :: JoinId -> JoinArity+idJoinArity id = isJoinId_maybe id `orElse` pprPanic "idJoinArity" (ppr id)++asJoinId :: Id -> JoinArity -> JoinId+asJoinId id arity = WARN(not (isLocalId id),+                         text "global id being marked as join var:" <+> ppr id)+                    WARN(not (is_vanilla_or_join id),+                         ppr id <+> pprIdDetails (idDetails id))+                    id `setIdDetails` JoinId arity+  where+    is_vanilla_or_join id = case Var.idDetails id of+                              VanillaId -> True+                              JoinId {} -> True+                              _         -> False++zapJoinId :: Id -> Id+-- May be a regular id already+zapJoinId jid | isJoinId jid = zapIdTailCallInfo (jid `setIdDetails` VanillaId)+                                 -- Core Lint may complain if still marked+                                 -- as AlwaysTailCalled+              | otherwise    = jid++asJoinId_maybe :: Id -> Maybe JoinArity -> Id+asJoinId_maybe id (Just arity) = asJoinId id arity+asJoinId_maybe id Nothing      = zapJoinId id++{-+************************************************************************+*                                                                      *+\subsection{IdInfo stuff}+*                                                                      *+************************************************************************+-}++        ---------------------------------+        -- ARITY+idArity :: Id -> Arity+idArity id = arityInfo (idInfo id)++setIdArity :: Id -> Arity -> Id+setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id++idCallArity :: Id -> Arity+idCallArity id = callArityInfo (idInfo id)++setIdCallArity :: Id -> Arity -> Id+setIdCallArity id arity = modifyIdInfo (`setCallArityInfo` arity) id++idFunRepArity :: Id -> RepArity+idFunRepArity x = countFunRepArgs (idArity x) (idType x)++-- | Returns true if an application to n args would diverge+isBottomingId :: Var -> Bool+isBottomingId v+  | isId v    = isBottomingSig (idStrictness v)+  | otherwise = False++idStrictness :: Id -> StrictSig+idStrictness id = strictnessInfo (idInfo id)++setIdStrictness :: Id -> StrictSig -> Id+setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` sig) id++zapIdStrictness :: Id -> Id+zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` nopSig) id++-- | This predicate says whether the 'Id' has a strict demand placed on it or+-- has a type such that it can always be evaluated strictly (i.e an+-- unlifted type, as of GHC 7.6).  We need to+-- check separately whether the 'Id' has a so-called \"strict type\" because if+-- the demand for the given @id@ hasn't been computed yet but @id@ has a strict+-- type, we still want @isStrictId id@ to be @True@.+isStrictId :: Id -> Bool+isStrictId id+  = ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id )+         not (isJoinId id) && (+           (isStrictType (idType id)) ||+           -- Take the best of both strictnesses - old and new+           (isStrictDmd (idDemandInfo id))+         )++        ---------------------------------+        -- UNFOLDING+idUnfolding :: Id -> Unfolding+-- Do not expose the unfolding of a loop breaker!+idUnfolding id+  | isStrongLoopBreaker (occInfo info) = NoUnfolding+  | otherwise                          = unfoldingInfo info+  where+    info = idInfo id++realIdUnfolding :: Id -> Unfolding+-- Expose the unfolding if there is one, including for loop breakers+realIdUnfolding id = unfoldingInfo (idInfo id)++setIdUnfolding :: Id -> Unfolding -> Id+setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id++idDemandInfo       :: Id -> Demand+idDemandInfo       id = demandInfo (idInfo id)++setIdDemandInfo :: Id -> Demand -> Id+setIdDemandInfo id dmd = modifyIdInfo (`setDemandInfo` dmd) id++setCaseBndrEvald :: StrictnessMark -> Id -> Id+-- Used for variables bound by a case expressions, both the case-binder+-- itself, and any pattern-bound variables that are argument of a+-- strict constructor.  It just marks the variable as already-evaluated,+-- so that (for example) a subsequent 'seq' can be dropped+setCaseBndrEvald str id+  | isMarkedStrict str = id `setIdUnfolding` evaldUnfolding+  | otherwise          = id++        ---------------------------------+        -- SPECIALISATION++-- See Note [Specialisations and RULES in IdInfo] in IdInfo.hs++idSpecialisation :: Id -> RuleInfo+idSpecialisation id = ruleInfo (idInfo id)++idCoreRules :: Id -> [CoreRule]+idCoreRules id = ruleInfoRules (idSpecialisation id)++idHasRules :: Id -> Bool+idHasRules id = not (isEmptyRuleInfo (idSpecialisation id))++setIdSpecialisation :: Id -> RuleInfo -> Id+setIdSpecialisation id spec_info = modifyIdInfo (`setRuleInfo` spec_info) id++        ---------------------------------+        -- CAF INFO+idCafInfo :: Id -> CafInfo+idCafInfo id = cafInfo (idInfo id)++setIdCafInfo :: Id -> CafInfo -> Id+setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id++        ---------------------------------+        -- Occcurrence INFO+idOccInfo :: Id -> OccInfo+idOccInfo id = occInfo (idInfo id)++setIdOccInfo :: Id -> OccInfo -> Id+setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id++zapIdOccInfo :: Id -> Id+zapIdOccInfo b = b `setIdOccInfo` noOccInfo++{-+        ---------------------------------+        -- INLINING+The inline pragma tells us to be very keen to inline this Id, but it's still+OK not to if optimisation is switched off.+-}++idInlinePragma :: Id -> InlinePragma+idInlinePragma id = inlinePragInfo (idInfo id)++setInlinePragma :: Id -> InlinePragma -> Id+setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id++modifyInlinePragma :: Id -> (InlinePragma -> InlinePragma) -> Id+modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id++idInlineActivation :: Id -> Activation+idInlineActivation id = inlinePragmaActivation (idInlinePragma id)++setInlineActivation :: Id -> Activation -> Id+setInlineActivation id act = modifyInlinePragma id (\prag -> setInlinePragmaActivation prag act)++idRuleMatchInfo :: Id -> RuleMatchInfo+idRuleMatchInfo id = inlinePragmaRuleMatchInfo (idInlinePragma id)++isConLikeId :: Id -> Bool+isConLikeId id = isDataConWorkId id || isConLike (idRuleMatchInfo id)++{-+        ---------------------------------+        -- ONE-SHOT LAMBDAS+-}++idOneShotInfo :: Id -> OneShotInfo+idOneShotInfo id = oneShotInfo (idInfo id)++-- | Like 'idOneShotInfo', but taking the Horrible State Hack in to account+-- See Note [The state-transformer hack] in CoreArity+idStateHackOneShotInfo :: Id -> OneShotInfo+idStateHackOneShotInfo id+    | isStateHackType (idType id) = stateHackOneShot+    | otherwise                   = idOneShotInfo id++-- | Returns whether the lambda associated with the 'Id' is certainly applied at most once+-- This one is the "business end", called externally.+-- It works on type variables as well as Ids, returning True+-- Its main purpose is to encapsulate the Horrible State Hack+-- See Note [The state-transformer hack] in CoreArity+isOneShotBndr :: Var -> Bool+isOneShotBndr var+  | isTyVar var                              = True+  | OneShotLam <- idStateHackOneShotInfo var = True+  | otherwise                                = False++-- | Should we apply the state hack to values of this 'Type'?+stateHackOneShot :: OneShotInfo+stateHackOneShot = OneShotLam++typeOneShot :: Type -> OneShotInfo+typeOneShot ty+   | isStateHackType ty = stateHackOneShot+   | otherwise          = NoOneShotInfo++isStateHackType :: Type -> Bool+isStateHackType ty+  | hasNoStateHack unsafeGlobalDynFlags+  = False+  | otherwise+  = case tyConAppTyCon_maybe ty of+        Just tycon -> tycon == statePrimTyCon+        _          -> False+        -- This is a gross hack.  It claims that+        -- every function over realWorldStatePrimTy is a one-shot+        -- function.  This is pretty true in practice, and makes a big+        -- difference.  For example, consider+        --      a `thenST` \ r -> ...E...+        -- The early full laziness pass, if it doesn't know that r is one-shot+        -- will pull out E (let's say it doesn't mention r) to give+        --      let lvl = E in a `thenST` \ r -> ...lvl...+        -- When `thenST` gets inlined, we end up with+        --      let lvl = E in \s -> case a s of (r, s') -> ...lvl...+        -- and we don't re-inline E.+        --+        -- It would be better to spot that r was one-shot to start with, but+        -- I don't want to rely on that.+        --+        -- Another good example is in fill_in in PrelPack.hs.  We should be able to+        -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet.++isProbablyOneShotLambda :: Id -> Bool+isProbablyOneShotLambda id = case idStateHackOneShotInfo id of+                               OneShotLam    -> True+                               NoOneShotInfo -> False++setOneShotLambda :: Id -> Id+setOneShotLambda id = modifyIdInfo (`setOneShotInfo` OneShotLam) id++clearOneShotLambda :: Id -> Id+clearOneShotLambda id = modifyIdInfo (`setOneShotInfo` NoOneShotInfo) id++setIdOneShotInfo :: Id -> OneShotInfo -> Id+setIdOneShotInfo id one_shot = modifyIdInfo (`setOneShotInfo` one_shot) id++updOneShotInfo :: Id -> OneShotInfo -> Id+-- Combine the info in the Id with new info+updOneShotInfo id one_shot+  | do_upd    = setIdOneShotInfo id one_shot+  | otherwise = id+  where+    do_upd = case (idOneShotInfo id, one_shot) of+                (NoOneShotInfo, _) -> True+                (OneShotLam,    _) -> False++-- The OneShotLambda functions simply fiddle with the IdInfo flag+-- But watch out: this may change the type of something else+--      f = \x -> e+-- If we change the one-shot-ness of x, f's type changes++zapInfo :: (IdInfo -> Maybe IdInfo) -> Id -> Id+zapInfo zapper id = maybeModifyIdInfo (zapper (idInfo id)) id++zapLamIdInfo :: Id -> Id+zapLamIdInfo = zapInfo zapLamInfo++zapFragileIdInfo :: Id -> Id+zapFragileIdInfo = zapInfo zapFragileInfo++zapIdDemandInfo :: Id -> Id+zapIdDemandInfo = zapInfo zapDemandInfo++zapIdUsageInfo :: Id -> Id+zapIdUsageInfo = zapInfo zapUsageInfo++zapIdUsageEnvInfo :: Id -> Id+zapIdUsageEnvInfo = zapInfo zapUsageEnvInfo++zapIdUsedOnceInfo :: Id -> Id+zapIdUsedOnceInfo = zapInfo zapUsedOnceInfo++zapIdTailCallInfo :: Id -> Id+zapIdTailCallInfo = zapInfo zapTailCallInfo++{-+Note [transferPolyIdInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~+This transfer is used in two places:+        FloatOut (long-distance let-floating)+        SimplUtils.abstractFloats (short-distance let-floating)++Consider the short-distance let-floating:++   f = /\a. let g = rhs in ...++Then if we float thus++   g' = /\a. rhs+   f = /\a. ...[g' a/g]....++we *do not* want to lose g's+  * strictness information+  * arity+  * inline pragma (though that is bit more debatable)+  * occurrence info++Mostly this is just an optimisation, but it's *vital* to+transfer the occurrence info.  Consider++   NonRec { f = /\a. let Rec { g* = ..g.. } in ... }++where the '*' means 'LoopBreaker'.  Then if we float we must get++   Rec { g'* = /\a. ...(g' a)... }+   NonRec { f = /\a. ...[g' a/g]....}++where g' is also marked as LoopBreaker.  If not, terrible things+can happen if we re-simplify the binding (and the Simplifier does+sometimes simplify a term twice); see Trac #4345.++It's not so simple to retain+  * worker info+  * rules+so we simply discard those.  Sooner or later this may bite us.++If we abstract wrt one or more *value* binders, we must modify the+arity and strictness info before transferring it.  E.g.+      f = \x. e+-->+      g' = \y. \x. e+      + substitute (g' y) for g+Notice that g' has an arity one more than the original g+-}++transferPolyIdInfo :: Id        -- Original Id+                   -> [Var]     -- Abstract wrt these variables+                   -> Id        -- New Id+                   -> Id+transferPolyIdInfo old_id abstract_wrt new_id+  = modifyIdInfo transfer new_id+  where+    arity_increase = count isId abstract_wrt    -- Arity increases by the+                                                -- number of value binders++    old_info        = idInfo old_id+    old_arity       = arityInfo old_info+    old_inline_prag = inlinePragInfo old_info+    old_occ_info    = occInfo old_info+    new_arity       = old_arity + arity_increase+    new_occ_info    = zapOccTailCallInfo old_occ_info++    old_strictness  = strictnessInfo old_info+    new_strictness  = increaseStrictSigArity arity_increase old_strictness++    transfer new_info = new_info `setArityInfo` new_arity+                                 `setInlinePragInfo` old_inline_prag+                                 `setOccInfo` new_occ_info+                                 `setStrictnessInfo` new_strictness++isNeverLevPolyId :: Id -> Bool+isNeverLevPolyId = isNeverLevPolyIdInfo . idInfo
+ basicTypes/IdInfo.hs view
@@ -0,0 +1,622 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998++\section[IdInfo]{@IdInfos@: Non-essential information about @Ids@}++(And a pretty good illustration of quite a few things wrong with+Haskell. [WDP 94/11])+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}++module IdInfo (+        -- * The IdDetails type+        IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails,+        JoinArity, isJoinIdDetails_maybe,+        RecSelParent(..),++        -- * The IdInfo type+        IdInfo,         -- Abstract+        vanillaIdInfo, noCafIdInfo,++        -- ** The OneShotInfo type+        OneShotInfo(..),+        oneShotInfo, noOneShotInfo, hasNoOneShotInfo,+        setOneShotInfo,++        -- ** Zapping various forms of Info+        zapLamInfo, zapFragileInfo,+        zapDemandInfo, zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo,+        zapTailCallInfo, zapCallArityInfo,++        -- ** The ArityInfo type+        ArityInfo,+        unknownArity,+        arityInfo, setArityInfo, ppArityInfo,++        callArityInfo, setCallArityInfo,++        -- ** Demand and strictness Info+        strictnessInfo, setStrictnessInfo,+        demandInfo, setDemandInfo, pprStrictness,++        -- ** Unfolding Info+        unfoldingInfo, setUnfoldingInfo,++        -- ** The InlinePragInfo type+        InlinePragInfo,+        inlinePragInfo, setInlinePragInfo,++        -- ** The OccInfo type+        OccInfo(..),+        isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker,+        occInfo, setOccInfo,++        InsideLam, OneBranch,+        insideLam, notInsideLam, oneBranch, notOneBranch,++        TailCallInfo(..),+        tailCallInfo, isAlwaysTailCalled,++        -- ** The RuleInfo type+        RuleInfo(..),+        emptyRuleInfo,+        isEmptyRuleInfo, ruleInfoFreeVars,+        ruleInfoRules, setRuleInfoHead,+        ruleInfo, setRuleInfo,++        -- ** The CAFInfo type+        CafInfo(..),+        ppCafInfo, mayHaveCafRefs,+        cafInfo, setCafInfo,++        -- ** Tick-box Info+        TickBoxOp(..), TickBoxId,++        -- ** Levity info+        LevityInfo, levityInfo, setNeverLevPoly, setLevityInfoWithType,+        isNeverLevPolyIdInfo+    ) where++#include "HsVersions.h"++import CoreSyn++import Class+import {-# SOURCE #-} PrimOp (PrimOp)+import Name+import VarSet+import BasicTypes+import DataCon+import TyCon+import PatSyn+import Type+import ForeignCall+import Outputable+import Module+import Demand+import Util++-- infixl so you can say (id `set` a `set` b)+infixl  1 `setRuleInfo`,+          `setArityInfo`,+          `setInlinePragInfo`,+          `setUnfoldingInfo`,+          `setOneShotInfo`,+          `setOccInfo`,+          `setCafInfo`,+          `setStrictnessInfo`,+          `setDemandInfo`,+          `setNeverLevPoly`,+          `setLevityInfoWithType`++{-+************************************************************************+*                                                                      *+                     IdDetails+*                                                                      *+************************************************************************+-}++-- | Identifier Details+--+-- The 'IdDetails' of an 'Id' give stable, and necessary,+-- information about the Id.+data IdDetails+  = VanillaId++  -- | The 'Id' for a record selector+  | RecSelId+    { sel_tycon   :: RecSelParent+    , sel_naughty :: Bool       -- True <=> a "naughty" selector which can't actually exist, for example @x@ in:+                                --    data T = forall a. MkT { x :: a }+    }                           -- See Note [Naughty record selectors] in TcTyClsDecls++  | DataConWorkId DataCon       -- ^ The 'Id' is for a data constructor /worker/+  | DataConWrapId DataCon       -- ^ The 'Id' is for a data constructor /wrapper/++                                -- [the only reasons we need to know is so that+                                --  a) to support isImplicitId+                                --  b) when desugaring a RecordCon we can get+                                --     from the Id back to the data con]+  | ClassOpId Class             -- ^ The 'Id' is a superclass selector,+                                -- or class operation of a class++  | PrimOpId PrimOp             -- ^ The 'Id' is for a primitive operator+  | FCallId ForeignCall         -- ^ The 'Id' is for a foreign call.+                                -- Type will be simple: no type families, newtypes, etc++  | TickBoxOpId TickBoxOp       -- ^ The 'Id' is for a HPC tick box (both traditional and binary)++  | DFunId Bool                 -- ^ A dictionary function.+       -- Bool = True <=> the class has only one method, so may be+       --                  implemented with a newtype, so it might be bad+       --                  to be strict on this dictionary++  | CoVarId    -- ^ A coercion variable+               -- This only covers /un-lifted/ coercions, of type+               -- (t1 ~# t2) or (t1 ~R# t2), not their lifted variants+  | JoinId JoinArity           -- ^ An 'Id' for a join point taking n arguments+       -- Note [Join points] in CoreSyn++-- | Recursive Selector Parent+data RecSelParent = RecSelData TyCon | RecSelPatSyn PatSyn deriving Eq+  -- Either `TyCon` or `PatSyn` depending+  -- on the origin of the record selector.+  -- For a data type family, this is the+  -- /instance/ 'TyCon' not the family 'TyCon'++instance Outputable RecSelParent where+  ppr p = case p of+            RecSelData ty_con -> ppr ty_con+            RecSelPatSyn ps   -> ppr ps++-- | Just a synonym for 'CoVarId'. Written separately so it can be+-- exported in the hs-boot file.+coVarDetails :: IdDetails+coVarDetails = CoVarId++-- | Check if an 'IdDetails' says 'CoVarId'.+isCoVarDetails :: IdDetails -> Bool+isCoVarDetails CoVarId = True+isCoVarDetails _       = False++isJoinIdDetails_maybe :: IdDetails -> Maybe JoinArity+isJoinIdDetails_maybe (JoinId join_arity) = Just join_arity+isJoinIdDetails_maybe _                   = Nothing++instance Outputable IdDetails where+    ppr = pprIdDetails++pprIdDetails :: IdDetails -> SDoc+pprIdDetails VanillaId = empty+pprIdDetails other     = brackets (pp other)+ where+   pp VanillaId               = panic "pprIdDetails"+   pp (DataConWorkId _)       = text "DataCon"+   pp (DataConWrapId _)       = text "DataConWrapper"+   pp (ClassOpId {})          = text "ClassOp"+   pp (PrimOpId _)            = text "PrimOp"+   pp (FCallId _)             = text "ForeignCall"+   pp (TickBoxOpId _)         = text "TickBoxOp"+   pp (DFunId nt)             = text "DFunId" <> ppWhen nt (text "(nt)")+   pp (RecSelId { sel_naughty = is_naughty })+                              = brackets $ text "RecSel" <>+                                           ppWhen is_naughty (text "(naughty)")+   pp CoVarId                 = text "CoVarId"+   pp (JoinId arity)          = text "JoinId" <> parens (int arity)++{-+************************************************************************+*                                                                      *+\subsection{The main IdInfo type}+*                                                                      *+************************************************************************+-}++-- | Identifier Information+--+-- An 'IdInfo' gives /optional/ information about an 'Id'.  If+-- present it never lies, but it may not be present, in which case there+-- is always a conservative assumption which can be made.+--+-- Two 'Id's may have different info even though they have the same+-- 'Unique' (and are hence the same 'Id'); for example, one might lack+-- the properties attached to the other.+--+-- Most of the 'IdInfo' gives information about the value, or definition, of+-- the 'Id', independent of its usage. Exceptions to this+-- are 'demandInfo', 'occInfo', 'oneShotInfo' and 'callArityInfo'.+--+-- Performance note: when we update 'IdInfo', we have to reallocate this+-- entire record, so it is a good idea not to let this data structure get+-- too big.+data IdInfo+  = IdInfo {+        arityInfo       :: !ArityInfo,          -- ^ 'Id' arity+        ruleInfo        :: RuleInfo,            -- ^ Specialisations of the 'Id's function which exist+                                                -- See Note [Specialisations and RULES in IdInfo]+        unfoldingInfo   :: Unfolding,           -- ^ The 'Id's unfolding+        cafInfo         :: CafInfo,             -- ^ 'Id' CAF info+        oneShotInfo     :: OneShotInfo,         -- ^ Info about a lambda-bound variable, if the 'Id' is one+        inlinePragInfo  :: InlinePragma,        -- ^ Any inline pragma atached to the 'Id'+        occInfo         :: OccInfo,             -- ^ How the 'Id' occurs in the program++        strictnessInfo  :: StrictSig,      --  ^ A strictness signature++        demandInfo      :: Demand,       -- ^ ID demand information+        callArityInfo   :: !ArityInfo,   -- ^ How this is called.+                                         -- n <=> all calls have at least n arguments++        levityInfo      :: LevityInfo    -- ^ when applied, will this Id ever have a levity-polymorphic type?+    }++-- Setters++setRuleInfo :: IdInfo -> RuleInfo -> IdInfo+setRuleInfo       info sp = sp `seq` info { ruleInfo = sp }+setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo+setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr }+setOccInfo :: IdInfo -> OccInfo -> IdInfo+setOccInfo        info oc = oc `seq` info { occInfo = oc }+        -- Try to avoid spack leaks by seq'ing++setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo+setUnfoldingInfo info uf+  = -- We don't seq the unfolding, as we generate intermediate+    -- unfoldings which are just thrown away, so evaluating them is a+    -- waste of time.+    -- seqUnfolding uf `seq`+    info { unfoldingInfo = uf }++setArityInfo :: IdInfo -> ArityInfo -> IdInfo+setArityInfo      info ar  = info { arityInfo = ar  }+setCallArityInfo :: IdInfo -> ArityInfo -> IdInfo+setCallArityInfo info ar  = info { callArityInfo = ar  }+setCafInfo :: IdInfo -> CafInfo -> IdInfo+setCafInfo        info caf = info { cafInfo = caf }++setOneShotInfo :: IdInfo -> OneShotInfo -> IdInfo+setOneShotInfo      info lb = {-lb `seq`-} info { oneShotInfo = lb }++setDemandInfo :: IdInfo -> Demand -> IdInfo+setDemandInfo info dd = dd `seq` info { demandInfo = dd }++setStrictnessInfo :: IdInfo -> StrictSig -> IdInfo+setStrictnessInfo info dd = dd `seq` info { strictnessInfo = dd }++-- | Basic 'IdInfo' that carries no useful information whatsoever+vanillaIdInfo :: IdInfo+vanillaIdInfo+  = IdInfo {+            cafInfo             = vanillaCafInfo,+            arityInfo           = unknownArity,+            ruleInfo            = emptyRuleInfo,+            unfoldingInfo       = noUnfolding,+            oneShotInfo         = NoOneShotInfo,+            inlinePragInfo      = defaultInlinePragma,+            occInfo             = noOccInfo,+            demandInfo          = topDmd,+            strictnessInfo      = nopSig,+            callArityInfo       = unknownArity,+            levityInfo          = NoLevityInfo+           }++-- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references+noCafIdInfo :: IdInfo+noCafIdInfo  = vanillaIdInfo `setCafInfo`    NoCafRefs+        -- Used for built-in type Ids in MkId.++{-+************************************************************************+*                                                                      *+\subsection[arity-IdInfo]{Arity info about an @Id@}+*                                                                      *+************************************************************************++For locally-defined Ids, the code generator maintains its own notion+of their arities; so it should not be asking...  (but other things+besides the code-generator need arity info!)+-}++-- | Arity Information+--+-- An 'ArityInfo' of @n@ tells us that partial application of this+-- 'Id' to up to @n-1@ value arguments does essentially no work.+--+-- That is not necessarily the same as saying that it has @n@ leading+-- lambdas, because coerces may get in the way.+--+-- The arity might increase later in the compilation process, if+-- an extra lambda floats up to the binding site.+type ArityInfo = Arity++-- | It is always safe to assume that an 'Id' has an arity of 0+unknownArity :: Arity+unknownArity = 0++ppArityInfo :: Int -> SDoc+ppArityInfo 0 = empty+ppArityInfo n = hsep [text "Arity", int n]++{-+************************************************************************+*                                                                      *+\subsection{Inline-pragma information}+*                                                                      *+************************************************************************+-}++-- | Inline Pragma Information+--+-- Tells when the inlining is active.+-- When it is active the thing may be inlined, depending on how+-- big it is.+--+-- If there was an @INLINE@ pragma, then as a separate matter, the+-- RHS will have been made to look small with a Core inline 'Note'+--+-- The default 'InlinePragInfo' is 'AlwaysActive', so the info serves+-- entirely as a way to inhibit inlining until we want it+type InlinePragInfo = InlinePragma++{-+************************************************************************+*                                                                      *+               Strictness+*                                                                      *+************************************************************************+-}++pprStrictness :: StrictSig -> SDoc+pprStrictness sig = ppr sig++{-+************************************************************************+*                                                                      *+        RuleInfo+*                                                                      *+************************************************************************++Note [Specialisations and RULES in IdInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generally speaking, a GlobalId has an *empty* RuleInfo.  All their+RULES are contained in the globally-built rule-base.  In principle,+one could attach the to M.f the RULES for M.f that are defined in M.+But we don't do that for instance declarations and so we just treat+them all uniformly.++The EXCEPTION is PrimOpIds, which do have rules in their IdInfo. That is+jsut for convenience really.++However, LocalIds may have non-empty RuleInfo.  We treat them+differently because:+  a) they might be nested, in which case a global table won't work+  b) the RULE might mention free variables, which we use to keep things alive++In TidyPgm, when the LocalId becomes a GlobalId, its RULES are stripped off+and put in the global list.+-}++-- | Rule Information+--+-- Records the specializations of this 'Id' that we know about+-- in the form of rewrite 'CoreRule's that target them+data RuleInfo+  = RuleInfo+        [CoreRule]+        DVarSet         -- Locally-defined free vars of *both* LHS and RHS+                        -- of rules.  I don't think it needs to include the+                        -- ru_fn though.+                        -- Note [Rule dependency info] in OccurAnal++-- | Assume that no specilizations exist: always safe+emptyRuleInfo :: RuleInfo+emptyRuleInfo = RuleInfo [] emptyDVarSet++isEmptyRuleInfo :: RuleInfo -> Bool+isEmptyRuleInfo (RuleInfo rs _) = null rs++-- | Retrieve the locally-defined free variables of both the left and+-- right hand sides of the specialization rules+ruleInfoFreeVars :: RuleInfo -> DVarSet+ruleInfoFreeVars (RuleInfo _ fvs) = fvs++ruleInfoRules :: RuleInfo -> [CoreRule]+ruleInfoRules (RuleInfo rules _) = rules++-- | Change the name of the function the rule is keyed on on all of the 'CoreRule's+setRuleInfoHead :: Name -> RuleInfo -> RuleInfo+setRuleInfoHead fn (RuleInfo rules fvs)+  = RuleInfo (map (setRuleIdName fn) rules) fvs++{-+************************************************************************+*                                                                      *+\subsection[CG-IdInfo]{Code generator-related information}+*                                                                      *+************************************************************************+-}++-- CafInfo is used to build Static Reference Tables (see simplStg/SRT.hs).++-- | Constant applicative form Information+--+-- Records whether an 'Id' makes Constant Applicative Form references+data CafInfo+        = MayHaveCafRefs                -- ^ Indicates that the 'Id' is for either:+                                        --+                                        -- 1. A function or static constructor+                                        --    that refers to one or more CAFs, or+                                        --+                                        -- 2. A real live CAF++        | NoCafRefs                     -- ^ A function or static constructor+                                        -- that refers to no CAFs.+        deriving (Eq, Ord)++-- | Assumes that the 'Id' has CAF references: definitely safe+vanillaCafInfo :: CafInfo+vanillaCafInfo = MayHaveCafRefs++mayHaveCafRefs :: CafInfo -> Bool+mayHaveCafRefs  MayHaveCafRefs = True+mayHaveCafRefs _               = False++instance Outputable CafInfo where+   ppr = ppCafInfo++ppCafInfo :: CafInfo -> SDoc+ppCafInfo NoCafRefs = text "NoCafRefs"+ppCafInfo MayHaveCafRefs = empty++{-+************************************************************************+*                                                                      *+\subsection{Bulk operations on IdInfo}+*                                                                      *+************************************************************************+-}++-- | This is used to remove information on lambda binders that we have+-- setup as part of a lambda group, assuming they will be applied all at once,+-- but turn out to be part of an unsaturated lambda as in e.g:+--+-- > (\x1. \x2. e) arg1+zapLamInfo :: IdInfo -> Maybe IdInfo+zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand})+  | is_safe_occ occ && is_safe_dmd demand+  = Nothing+  | otherwise+  = Just (info {occInfo = safe_occ, demandInfo = topDmd})+  where+        -- The "unsafe" occ info is the ones that say I'm not in a lambda+        -- because that might not be true for an unsaturated lambda+    is_safe_occ occ | isAlwaysTailCalled occ     = False+    is_safe_occ (OneOcc { occ_in_lam = in_lam }) = in_lam+    is_safe_occ _other                           = True++    safe_occ = case occ of+                 OneOcc{} -> occ { occ_in_lam = True+                                 , occ_tail   = NoTailCallInfo }+                 IAmALoopBreaker{}+                          -> occ { occ_tail   = NoTailCallInfo }+                 _other   -> occ++    is_safe_dmd dmd = not (isStrictDmd dmd)++-- | Remove all demand info on the 'IdInfo'+zapDemandInfo :: IdInfo -> Maybe IdInfo+zapDemandInfo info = Just (info {demandInfo = topDmd})++-- | Remove usage (but not strictness) info on the 'IdInfo'+zapUsageInfo :: IdInfo -> Maybe IdInfo+zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)})++-- | Remove usage environment info from the strictness signature on the 'IdInfo'+zapUsageEnvInfo :: IdInfo -> Maybe IdInfo+zapUsageEnvInfo info+    | hasDemandEnvSig (strictnessInfo info)+    = Just (info {strictnessInfo = zapUsageEnvSig (strictnessInfo info)})+    | otherwise+    = Nothing++zapUsedOnceInfo :: IdInfo -> Maybe IdInfo+zapUsedOnceInfo info+    = Just $ info { strictnessInfo = zapUsedOnceSig    (strictnessInfo info)+                  , demandInfo     = zapUsedOnceDemand (demandInfo     info) }++zapFragileInfo :: IdInfo -> Maybe IdInfo+-- ^ Zap info that depends on free variables+zapFragileInfo info@(IdInfo { occInfo = occ, unfoldingInfo = unf })+  = new_unf `seq`  -- The unfolding field is not (currently) strict, so we+                   -- force it here to avoid a (zapFragileUnfolding unf) thunk+                   -- which might leak space+    Just (info `setRuleInfo` emptyRuleInfo+               `setUnfoldingInfo` new_unf+               `setOccInfo`       zapFragileOcc occ)+  where+    new_unf = zapFragileUnfolding unf++zapFragileUnfolding :: Unfolding -> Unfolding+zapFragileUnfolding unf+ | isFragileUnfolding unf = noUnfolding+ | otherwise              = unf++zapTailCallInfo :: IdInfo -> Maybe IdInfo+zapTailCallInfo info+  = case occInfo info of+      occ | isAlwaysTailCalled occ -> Just (info `setOccInfo` safe_occ)+          | otherwise              -> Nothing+        where+          safe_occ = occ { occ_tail = NoTailCallInfo }++zapCallArityInfo :: IdInfo -> IdInfo+zapCallArityInfo info = setCallArityInfo info 0++{-+************************************************************************+*                                                                      *+\subsection{TickBoxOp}+*                                                                      *+************************************************************************+-}++type TickBoxId = Int++-- | Tick box for Hpc-style coverage+data TickBoxOp+   = TickBox Module {-# UNPACK #-} !TickBoxId++instance Outputable TickBoxOp where+    ppr (TickBox mod n)         = text "tick" <+> ppr (mod,n)++{-+************************************************************************+*                                                                      *+   Levity+*                                                                      *+************************************************************************++Note [Levity info]+~~~~~~~~~~~~~~~~~~++Ids store whether or not they can be levity-polymorphic at any amount+of saturation. This is helpful in optimizing the levity-polymorphism check+done in the desugarer, where we can usually learn that something is not+levity-polymorphic without actually figuring out its type. See+isExprLevPoly in CoreUtils for where this info is used. Storing+this is required to prevent perf/compiler/T5631 from blowing up.++-}++-- See Note [Levity info]+data LevityInfo = NoLevityInfo  -- always safe+                | NeverLevityPolymorphic+  deriving Eq++instance Outputable LevityInfo where+  ppr NoLevityInfo           = text "NoLevityInfo"+  ppr NeverLevityPolymorphic = text "NeverLevityPolymorphic"++-- | Marks an IdInfo describing an Id that is never levity polymorphic (even when+-- applied). The Type is only there for checking that it's really never levity+-- polymorphic+setNeverLevPoly :: HasDebugCallStack => IdInfo -> Type -> IdInfo+setNeverLevPoly info ty+  = ASSERT2( not (resultIsLevPoly ty), ppr ty )+    info { levityInfo = NeverLevityPolymorphic }++setLevityInfoWithType :: IdInfo -> Type -> IdInfo+setLevityInfoWithType info ty+  | not (resultIsLevPoly ty)+  = info { levityInfo = NeverLevityPolymorphic }+  | otherwise+  = info++isNeverLevPolyIdInfo :: IdInfo -> Bool+isNeverLevPolyIdInfo info+  | NeverLevityPolymorphic <- levityInfo info = True+  | otherwise                                 = False
+ basicTypes/IdInfo.hs-boot view
@@ -0,0 +1,10 @@+module IdInfo where+import Outputable+data IdInfo+data IdDetails++vanillaIdInfo :: IdInfo+coVarDetails :: IdDetails+isCoVarDetails :: IdDetails -> Bool+pprIdDetails :: IdDetails -> SDoc+
+ basicTypes/Lexeme.hs view
@@ -0,0 +1,238 @@+-- (c) The GHC Team+--+-- Functions to evaluate whether or not a string is a valid identifier.+-- There is considerable overlap between the logic here and the logic+-- in Lexer.x, but sadly there seems to be way to merge them.++module Lexeme (+          -- * Lexical characteristics of Haskell names++          -- | Use these functions to figure what kind of name a 'FastString'+          -- represents; these functions do /not/ check that the identifier+          -- is valid.++        isLexCon, isLexVar, isLexId, isLexSym,+        isLexConId, isLexConSym, isLexVarId, isLexVarSym,+        startsVarSym, startsVarId, startsConSym, startsConId,++          -- * Validating identifiers++          -- | These functions (working over plain old 'String's) check+          -- to make sure that the identifier is valid.+        okVarOcc, okConOcc, okTcOcc,+        okVarIdOcc, okVarSymOcc, okConIdOcc, okConSymOcc++        -- Some of the exports above are not used within GHC, but may+        -- be of value to GHC API users.++  ) where++import FastString++import Data.Char+import qualified Data.Set as Set++import GHC.Lexeme++{-++************************************************************************+*                                                                      *+    Lexical categories+*                                                                      *+************************************************************************++These functions test strings to see if they fit the lexical categories+defined in the Haskell report.++Note [Classification of generated names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Some names generated for internal use can show up in debugging output,+e.g.  when using -ddump-simpl. These generated names start with a $+but should still be pretty-printed using prefix notation. We make sure+this is the case in isLexVarSym by only classifying a name as a symbol+if all its characters are symbols, not just its first one.+-}++isLexCon,   isLexVar,    isLexId,    isLexSym    :: FastString -> Bool+isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FastString -> Bool++isLexCon cs = isLexConId  cs || isLexConSym cs+isLexVar cs = isLexVarId  cs || isLexVarSym cs++isLexId  cs = isLexConId  cs || isLexVarId  cs+isLexSym cs = isLexConSym cs || isLexVarSym cs++-------------+isLexConId cs                           -- Prefix type or data constructors+  | nullFS cs          = False          --      e.g. "Foo", "[]", "(,)"+  | cs == (fsLit "[]") = True+  | otherwise          = startsConId (headFS cs)++isLexVarId cs                           -- Ordinary prefix identifiers+  | nullFS cs         = False           --      e.g. "x", "_x"+  | otherwise         = startsVarId (headFS cs)++isLexConSym cs                          -- Infix type or data constructors+  | nullFS cs          = False          --      e.g. ":-:", ":", "->"+  | cs == (fsLit "->") = True+  | otherwise          = startsConSym (headFS cs)++isLexVarSym fs                          -- Infix identifiers e.g. "+"+  | fs == (fsLit "~R#") = True+  | otherwise+  = case (if nullFS fs then [] else unpackFS fs) of+      [] -> False+      (c:cs) -> startsVarSym c && all isVarSymChar cs+        -- See Note [Classification of generated names]++{-++************************************************************************+*                                                                      *+    Detecting valid names for Template Haskell+*                                                                      *+************************************************************************++-}++----------------------+-- External interface+----------------------++-- | Is this an acceptable variable name?+okVarOcc :: String -> Bool+okVarOcc str@(c:_)+  | startsVarId c+  = okVarIdOcc str+  | startsVarSym c+  = okVarSymOcc str+okVarOcc _ = False++-- | Is this an acceptable constructor name?+okConOcc :: String -> Bool+okConOcc str@(c:_)+  | startsConId c+  = okConIdOcc str+  | startsConSym c+  = okConSymOcc str+  | str == "[]"+  = True+okConOcc _ = False++-- | Is this an acceptable type name?+okTcOcc :: String -> Bool+okTcOcc "[]" = True+okTcOcc "->" = True+okTcOcc "~"  = True+okTcOcc str@(c:_)+  | startsConId c+  = okConIdOcc str+  | startsConSym c+  = okConSymOcc str+  | startsVarSym c+  = okVarSymOcc str+okTcOcc _ = False++-- | Is this an acceptable alphanumeric variable name, assuming it starts+-- with an acceptable letter?+okVarIdOcc :: String -> Bool+okVarIdOcc str = okIdOcc str &&+                 -- admit "_" as a valid identifier.  Required to support typed+                 -- holes in Template Haskell.  See #10267+                 (str == "_" || not (str `Set.member` reservedIds))++-- | Is this an acceptable symbolic variable name, assuming it starts+-- with an acceptable character?+okVarSymOcc :: String -> Bool+okVarSymOcc str = all okSymChar str &&+                  not (str `Set.member` reservedOps) &&+                  not (isDashes str)++-- | Is this an acceptable alphanumeric constructor name, assuming it+-- starts with an acceptable letter?+okConIdOcc :: String -> Bool+okConIdOcc str = okIdOcc str ||+                 is_tuple_name1 True  str ||+                   -- Is it a boxed tuple...+                 is_tuple_name1 False str ||+                   -- ...or an unboxed tuple (Trac #12407)...+                 is_sum_name1 str+                   -- ...or an unboxed sum (Trac #12514)?+  where+    -- check for tuple name, starting at the beginning+    is_tuple_name1 True  ('(' : rest)       = is_tuple_name2 True  rest+    is_tuple_name1 False ('(' : '#' : rest) = is_tuple_name2 False rest+    is_tuple_name1 _     _                  = False++    -- check for tuple tail+    is_tuple_name2 True  ")"          = True+    is_tuple_name2 False "#)"         = True+    is_tuple_name2 boxed (',' : rest) = is_tuple_name2 boxed rest+    is_tuple_name2 boxed (ws  : rest)+      | isSpace ws                    = is_tuple_name2 boxed rest+    is_tuple_name2 _     _            = False++    -- check for sum name, starting at the beginning+    is_sum_name1 ('(' : '#' : rest) = is_sum_name2 False rest+    is_sum_name1 _                  = False++    -- check for sum tail, only allowing at most one underscore+    is_sum_name2 _          "#)"         = True+    is_sum_name2 underscore ('|' : rest) = is_sum_name2 underscore rest+    is_sum_name2 False      ('_' : rest) = is_sum_name2 True rest+    is_sum_name2 underscore (ws  : rest)+      | isSpace ws                       = is_sum_name2 underscore rest+    is_sum_name2 _          _            = False++-- | Is this an acceptable symbolic constructor name, assuming it+-- starts with an acceptable character?+okConSymOcc :: String -> Bool+okConSymOcc ":" = True+okConSymOcc str = all okSymChar str &&+                  not (str `Set.member` reservedOps)++----------------------+-- Internal functions+----------------------++-- | Is this string an acceptable id, possibly with a suffix of hashes,+-- but not worrying about case or clashing with reserved words?+okIdOcc :: String -> Bool+okIdOcc str+  = let hashes = dropWhile okIdChar str in+    all (== '#') hashes   -- -XMagicHash allows a suffix of hashes+                          -- of course, `all` says "True" to an empty list++-- | Is this character acceptable in an identifier (after the first letter)?+-- See alexGetByte in Lexer.x+okIdChar :: Char -> Bool+okIdChar c = case generalCategory c of+  UppercaseLetter -> True+  LowercaseLetter -> True+  TitlecaseLetter -> True+  ModifierLetter  -> True -- See #10196+  OtherLetter     -> True -- See #1103+  NonSpacingMark  -> True -- See #7650+  DecimalNumber   -> True+  OtherNumber     -> True -- See #4373+  _               -> c == '\'' || c == '_'++-- | All reserved identifiers. Taken from section 2.4 of the 2010 Report.+reservedIds :: Set.Set String+reservedIds = Set.fromList [ "case", "class", "data", "default", "deriving"+                           , "do", "else", "foreign", "if", "import", "in"+                           , "infix", "infixl", "infixr", "instance", "let"+                           , "module", "newtype", "of", "then", "type", "where"+                           , "_" ]++-- | All reserved operators. Taken from section 2.4 of the 2010 Report.+reservedOps :: Set.Set String+reservedOps = Set.fromList [ "..", ":", "::", "=", "\\", "|", "<-", "->"+                           , "@", "~", "=>" ]++-- | Does this string contain only dashes and has at least 2 of them?+isDashes :: String -> Bool+isDashes ('-' : '-' : rest) = all (== '-') rest+isDashes _                  = False
+ basicTypes/Literal.hs view
@@ -0,0 +1,603 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1998++\section[Literal]{@Literal@: Machine literals (unboxed, of course)}+-}++{-# LANGUAGE CPP, DeriveDataTypeable #-}++module Literal+        (+        -- * Main data type+          Literal(..)           -- Exported to ParseIface++        -- ** Creating Literals+        , mkMachInt, mkMachIntWrap+        , mkMachWord, mkMachWordWrap+        , mkMachInt64, mkMachInt64Wrap+        , mkMachWord64, mkMachWord64Wrap+        , mkMachFloat, mkMachDouble+        , mkMachChar, mkMachString+        , mkLitInteger++        -- ** Operations on Literals+        , literalType+        , absentLiteralOf+        , pprLiteral++        -- ** Predicates on Literals and their contents+        , litIsDupable, litIsTrivial, litIsLifted+        , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange+        , isZeroLit+        , litFitsInChar+        , litValue, isLitValue, isLitValue_maybe, mapLitValue++        -- ** Coercions+        , word2IntLit, int2WordLit+        , narrow8IntLit, narrow16IntLit, narrow32IntLit+        , narrow8WordLit, narrow16WordLit, narrow32WordLit+        , char2IntLit, int2CharLit+        , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit+        , nullAddrLit, float2DoubleLit, double2FloatLit+        ) where++#include "HsVersions.h"++import TysPrim+import PrelNames+import Type+import TyCon+import Outputable+import FastString+import BasicTypes+import Binary+import Constants+import DynFlags+import Platform+import UniqFM+import Util++import Data.ByteString (ByteString)+import Data.Int+import Data.Word+import Data.Char+import Data.Maybe ( isJust )+import Data.Data ( Data )+import Numeric ( fromRat )++{-+************************************************************************+*                                                                      *+\subsection{Literals}+*                                                                      *+************************************************************************+-}++-- | So-called 'Literal's are one of:+--+-- * An unboxed (/machine/) literal ('MachInt', 'MachFloat', etc.),+--   which is presumed to be surrounded by appropriate constructors+--   (@Int#@, etc.), so that the overall thing makes sense.+--+--   We maintain the invariant that the 'Integer' the Mach{Int,Word}*+--   constructors are actually in the (possibly target-dependent) range.+--   The mkMach{Int,Word}*Wrap smart constructors ensure this by applying+--   the target machine's wrapping semantics. Use these in situations+--   where you know the wrapping semantics are correct.+--+-- * The literal derived from the label mentioned in a \"foreign label\"+--   declaration ('MachLabel')+data Literal+  =     ------------------+        -- First the primitive guys+    MachChar    Char            -- ^ @Char#@ - at least 31 bits. Create with 'mkMachChar'++  | MachStr     ByteString      -- ^ A string-literal: stored and emitted+                                -- UTF-8 encoded, we'll arrange to decode it+                                -- at runtime.  Also emitted with a @'\0'@+                                -- terminator. Create with 'mkMachString'++  | MachNullAddr                -- ^ The @NULL@ pointer, the only pointer value+                                -- that can be represented as a Literal. Create+                                -- with 'nullAddrLit'++  | MachInt     Integer         -- ^ @Int#@ - according to target machine+  | MachInt64   Integer         -- ^ @Int64#@ - exactly 64 bits+  | MachWord    Integer         -- ^ @Word#@ - according to target machine+  | MachWord64  Integer         -- ^ @Word64#@ - exactly 64 bits++  | MachFloat   Rational        -- ^ @Float#@. Create with 'mkMachFloat'+  | MachDouble  Rational        -- ^ @Double#@. Create with 'mkMachDouble'++  | MachLabel   FastString+                (Maybe Int)+        FunctionOrData+                -- ^ A label literal. Parameters:+                --+                -- 1) The name of the symbol mentioned in the declaration+                --+                -- 2) The size (in bytes) of the arguments+                --    the label expects. Only applicable with+                --    @stdcall@ labels. @Just x@ => @\<x\>@ will+                --    be appended to label name when emitting assembly.++  | LitInteger Integer Type --  ^ Integer literals+                            -- See Note [Integer literals]+  deriving Data++{-+Note [Integer literals]+~~~~~~~~~~~~~~~~~~~~~~~+An Integer literal is represented using, well, an Integer, to make it+easier to write RULEs for them. They also contain the Integer type, so+that e.g. literalType can return the right Type for them.++They only get converted into real Core,+    mkInteger [c1, c2, .., cn]+during the CorePrep phase, although TidyPgm looks ahead at what the+core will be, so that it can see whether it involves CAFs.++When we initally build an Integer literal, notably when+deserialising it from an interface file (see the Binary instance+below), we don't have convenient access to the mkInteger Id.  So we+just use an error thunk, and fill in the real Id when we do tcIfaceLit+in TcIface.+++Binary instance+-}++instance Binary Literal where+    put_ bh (MachChar aa)     = do putByte bh 0; put_ bh aa+    put_ bh (MachStr ab)      = do putByte bh 1; put_ bh ab+    put_ bh (MachNullAddr)    = do putByte bh 2+    put_ bh (MachInt ad)      = do putByte bh 3; put_ bh ad+    put_ bh (MachInt64 ae)    = do putByte bh 4; put_ bh ae+    put_ bh (MachWord af)     = do putByte bh 5; put_ bh af+    put_ bh (MachWord64 ag)   = do putByte bh 6; put_ bh ag+    put_ bh (MachFloat ah)    = do putByte bh 7; put_ bh ah+    put_ bh (MachDouble ai)   = do putByte bh 8; put_ bh ai+    put_ bh (MachLabel aj mb fod)+        = do putByte bh 9+             put_ bh aj+             put_ bh mb+             put_ bh fod+    put_ bh (LitInteger i _) = do putByte bh 10; put_ bh i+    get bh = do+            h <- getByte bh+            case h of+              0 -> do+                    aa <- get bh+                    return (MachChar aa)+              1 -> do+                    ab <- get bh+                    return (MachStr ab)+              2 -> do+                    return (MachNullAddr)+              3 -> do+                    ad <- get bh+                    return (MachInt ad)+              4 -> do+                    ae <- get bh+                    return (MachInt64 ae)+              5 -> do+                    af <- get bh+                    return (MachWord af)+              6 -> do+                    ag <- get bh+                    return (MachWord64 ag)+              7 -> do+                    ah <- get bh+                    return (MachFloat ah)+              8 -> do+                    ai <- get bh+                    return (MachDouble ai)+              9 -> do+                    aj <- get bh+                    mb <- get bh+                    fod <- get bh+                    return (MachLabel aj mb fod)+              _ -> do+                    i <- get bh+                    -- See Note [Integer literals]+                    return $ mkLitInteger i (panic "Evaluated the place holder for mkInteger")++instance Outputable Literal where+    ppr lit = pprLiteral (\d -> d) lit++instance Eq Literal where+    a == b = case (a `compare` b) of { EQ -> True;   _ -> False }+    a /= b = case (a `compare` b) of { EQ -> False;  _ -> True  }++instance Ord Literal where+    a <= b = case (a `compare` b) of { LT -> True;  EQ -> True;  GT -> False }+    a <  b = case (a `compare` b) of { LT -> True;  EQ -> False; GT -> False }+    a >= b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }+    a >  b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }+    compare a b = cmpLit a b++{-+        Construction+        ~~~~~~~~~~~~+-}++-- | Creates a 'Literal' of type @Int#@+mkMachInt :: DynFlags -> Integer -> Literal+mkMachInt dflags x   = ASSERT2( inIntRange dflags x,  integer x )+                       MachInt x++-- | Creates a 'Literal' of type @Int#@.+--   If the argument is out of the (target-dependent) range, it is wrapped.+mkMachIntWrap :: DynFlags -> Integer -> Literal+mkMachIntWrap dflags i+ = MachInt $ case platformWordSize (targetPlatform dflags) of+   4 -> toInteger (fromIntegral i :: Int32)+   8 -> toInteger (fromIntegral i :: Int64)+   w -> panic ("toIntRange: Unknown platformWordSize: " ++ show w)++-- | Creates a 'Literal' of type @Word#@+mkMachWord :: DynFlags -> Integer -> Literal+mkMachWord dflags x   = ASSERT2( inWordRange dflags x, integer x )+                        MachWord x++-- | Creates a 'Literal' of type @Word#@.+--   If the argument is out of the (target-dependent) range, it is wrapped.+mkMachWordWrap :: DynFlags -> Integer -> Literal+mkMachWordWrap dflags i+ = MachWord $ case platformWordSize (targetPlatform dflags) of+   4 -> toInteger (fromInteger i :: Word32)+   8 -> toInteger (fromInteger i :: Word64)+   w -> panic ("toWordRange: Unknown platformWordSize: " ++ show w)++-- | Creates a 'Literal' of type @Int64#@+mkMachInt64 :: Integer -> Literal+mkMachInt64  x = ASSERT2( inInt64Range x, integer x )+                 MachInt64 x++-- | Creates a 'Literal' of type @Int64#@.+--   If the argument is out of the range, it is wrapped.+mkMachInt64Wrap :: Integer -> Literal+mkMachInt64Wrap  i = MachInt64 (toInteger (fromIntegral i :: Int64))++-- | Creates a 'Literal' of type @Word64#@+mkMachWord64 :: Integer -> Literal+mkMachWord64 x = ASSERT2( inWord64Range x, integer x )+                 MachWord64 x++-- | Creates a 'Literal' of type @Word64#@.+--   If the argument is out of the range, it is wrapped.+mkMachWord64Wrap :: Integer -> Literal+mkMachWord64Wrap i = MachWord64 (toInteger (fromIntegral i :: Word64))++-- | Creates a 'Literal' of type @Float#@+mkMachFloat :: Rational -> Literal+mkMachFloat = MachFloat++-- | Creates a 'Literal' of type @Double#@+mkMachDouble :: Rational -> Literal+mkMachDouble = MachDouble++-- | Creates a 'Literal' of type @Char#@+mkMachChar :: Char -> Literal+mkMachChar = MachChar++-- | Creates a 'Literal' of type @Addr#@, which is appropriate for passing to+-- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@+mkMachString :: String -> Literal+-- stored UTF-8 encoded+mkMachString s = MachStr (fastStringToByteString $ mkFastString s)++mkLitInteger :: Integer -> Type -> Literal+mkLitInteger = LitInteger++inIntRange, inWordRange :: DynFlags -> Integer -> Bool+inIntRange  dflags x = x >= tARGET_MIN_INT dflags && x <= tARGET_MAX_INT dflags+inWordRange dflags x = x >= 0                     && x <= tARGET_MAX_WORD dflags++inInt64Range, inWord64Range :: Integer -> Bool+inInt64Range x  = x >= toInteger (minBound :: Int64) &&+                  x <= toInteger (maxBound :: Int64)+inWord64Range x = x >= toInteger (minBound :: Word64) &&+                  x <= toInteger (maxBound :: Word64)++inCharRange :: Char -> Bool+inCharRange c =  c >= '\0' && c <= chr tARGET_MAX_CHAR++-- | Tests whether the literal represents a zero of whatever type it is+isZeroLit :: Literal -> Bool+isZeroLit (MachInt    0) = True+isZeroLit (MachInt64  0) = True+isZeroLit (MachWord   0) = True+isZeroLit (MachWord64 0) = True+isZeroLit (MachFloat  0) = True+isZeroLit (MachDouble 0) = True+isZeroLit _              = False++-- | Returns the 'Integer' contained in the 'Literal', for when that makes+-- sense, i.e. for 'Char', 'Int', 'Word' and 'LitInteger'.+litValue  :: Literal -> Integer+litValue l = case isLitValue_maybe l of+   Just x  -> x+   Nothing -> pprPanic "litValue" (ppr l)++-- | Returns the 'Integer' contained in the 'Literal', for when that makes+-- sense, i.e. for 'Char', 'Int', 'Word' and 'LitInteger'.+isLitValue_maybe  :: Literal -> Maybe Integer+isLitValue_maybe (MachChar   c)   = Just $ toInteger $ ord c+isLitValue_maybe (MachInt    i)   = Just i+isLitValue_maybe (MachInt64  i)   = Just i+isLitValue_maybe (MachWord   i)   = Just i+isLitValue_maybe (MachWord64 i)   = Just i+isLitValue_maybe (LitInteger i _) = Just i+isLitValue_maybe _                = Nothing++-- | Apply a function to the 'Integer' contained in the 'Literal', for when that+-- makes sense, e.g. for 'Char', 'Int', 'Word' and 'LitInteger'. For+-- fixed-size integral literals, the result will be wrapped in+-- accordance with the semantics of the target type.+mapLitValue  :: DynFlags -> (Integer -> Integer) -> Literal -> Literal+mapLitValue _      f (MachChar   c)   = mkMachChar (fchar c)+   where fchar = chr . fromInteger . f . toInteger . ord+mapLitValue dflags f (MachInt    i)   = mkMachIntWrap dflags (f i)+mapLitValue _      f (MachInt64  i)   = mkMachInt64Wrap (f i)+mapLitValue dflags f (MachWord   i)   = mkMachWordWrap dflags (f i)+mapLitValue _      f (MachWord64 i)   = mkMachWord64Wrap (f i)+mapLitValue _      f (LitInteger i t) = mkLitInteger (f i) t+mapLitValue _      _ l                = pprPanic "mapLitValue" (ppr l)++-- | Indicate if the `Literal` contains an 'Integer' value, e.g. 'Char',+-- 'Int', 'Word' and 'LitInteger'.+isLitValue  :: Literal -> Bool+isLitValue = isJust . isLitValue_maybe++{-+        Coercions+        ~~~~~~~~~+-}++narrow8IntLit, narrow16IntLit, narrow32IntLit,+  narrow8WordLit, narrow16WordLit, narrow32WordLit,+  char2IntLit, int2CharLit,+  float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit,+  float2DoubleLit, double2FloatLit+  :: Literal -> Literal++word2IntLit, int2WordLit :: DynFlags -> Literal -> Literal+word2IntLit dflags (MachWord w)+  | w > tARGET_MAX_INT dflags = MachInt (w - tARGET_MAX_WORD dflags - 1)+  | otherwise                 = MachInt w+word2IntLit _ l = pprPanic "word2IntLit" (ppr l)++int2WordLit dflags (MachInt i)+  | i < 0     = MachWord (1 + tARGET_MAX_WORD dflags + i)      -- (-1)  --->  tARGET_MAX_WORD+  | otherwise = MachWord i+int2WordLit _ l = pprPanic "int2WordLit" (ppr l)++narrow8IntLit    (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int8))+narrow8IntLit    l            = pprPanic "narrow8IntLit" (ppr l)+narrow16IntLit   (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int16))+narrow16IntLit   l            = pprPanic "narrow16IntLit" (ppr l)+narrow32IntLit   (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int32))+narrow32IntLit   l            = pprPanic "narrow32IntLit" (ppr l)+narrow8WordLit   (MachWord w) = MachWord (toInteger (fromInteger w :: Word8))+narrow8WordLit   l            = pprPanic "narrow8WordLit" (ppr l)+narrow16WordLit  (MachWord w) = MachWord (toInteger (fromInteger w :: Word16))+narrow16WordLit  l            = pprPanic "narrow16WordLit" (ppr l)+narrow32WordLit  (MachWord w) = MachWord (toInteger (fromInteger w :: Word32))+narrow32WordLit  l            = pprPanic "narrow32WordLit" (ppr l)++char2IntLit (MachChar c) = MachInt  (toInteger (ord c))+char2IntLit l            = pprPanic "char2IntLit" (ppr l)+int2CharLit (MachInt  i) = MachChar (chr (fromInteger i))+int2CharLit l            = pprPanic "int2CharLit" (ppr l)++float2IntLit (MachFloat f) = MachInt   (truncate    f)+float2IntLit l             = pprPanic "float2IntLit" (ppr l)+int2FloatLit (MachInt   i) = MachFloat (fromInteger i)+int2FloatLit l             = pprPanic "int2FloatLit" (ppr l)++double2IntLit (MachDouble f) = MachInt    (truncate    f)+double2IntLit l              = pprPanic "double2IntLit" (ppr l)+int2DoubleLit (MachInt    i) = MachDouble (fromInteger i)+int2DoubleLit l              = pprPanic "int2DoubleLit" (ppr l)++float2DoubleLit (MachFloat  f) = MachDouble f+float2DoubleLit l              = pprPanic "float2DoubleLit" (ppr l)+double2FloatLit (MachDouble d) = MachFloat  d+double2FloatLit l              = pprPanic "double2FloatLit" (ppr l)++nullAddrLit :: Literal+nullAddrLit = MachNullAddr++{-+        Predicates+        ~~~~~~~~~~+-}++-- | True if there is absolutely no penalty to duplicating the literal.+-- False principally of strings.+--+-- "Why?", you say? I'm glad you asked. Well, for one duplicating strings would+-- blow up code sizes. Not only this, it's also unsafe.+--+-- Consider a program that wants to traverse a string. One way it might do this+-- is to first compute the Addr# pointing to the end of the string, and then,+-- starting from the beginning, bump a pointer using eqAddr# to determine the+-- end. For instance,+--+-- @+-- -- Given pointers to the start and end of a string, count how many zeros+-- -- the string contains.+-- countZeros :: Addr# -> Addr# -> -> Int+-- countZeros start end = go start 0+--   where+--     go off n+--       | off `addrEq#` end = n+--       | otherwise         = go (off `plusAddr#` 1) n'+--       where n' | isTrue# (indexInt8OffAddr# off 0# ==# 0#) = n + 1+--                | otherwise                                 = n+-- @+--+-- Consider what happens if we considered strings to be trivial (and therefore+-- duplicable) and emitted a call like @countZeros "hello"# ("hello"#+-- `plusAddr`# 5)@. The beginning and end pointers do not belong to the same+-- string, meaning that an iteration like the above would blow up terribly.+-- This is what happened in #12757.+--+-- Ultimately the solution here is to make primitive strings a bit more+-- structured, ensuring that the compiler can't inline in ways that will break+-- user code. One approach to this is described in #8472.+litIsTrivial :: Literal -> Bool+--      c.f. CoreUtils.exprIsTrivial+litIsTrivial (MachStr _)      = False+litIsTrivial (LitInteger {})  = False+litIsTrivial _                = True++-- | True if code space does not go bad if we duplicate this literal+-- Currently we treat it just like 'litIsTrivial'+litIsDupable :: DynFlags -> Literal -> Bool+--      c.f. CoreUtils.exprIsDupable+litIsDupable _      (MachStr _)      = False+litIsDupable dflags (LitInteger i _) = inIntRange dflags i+litIsDupable _      _                = True++litFitsInChar :: Literal -> Bool+litFitsInChar (MachInt i) = i >= toInteger (ord minBound)+                         && i <= toInteger (ord maxBound)+litFitsInChar _           = False++litIsLifted :: Literal -> Bool+litIsLifted (LitInteger {}) = True+litIsLifted _               = False++{-+        Types+        ~~~~~+-}++-- | Find the Haskell 'Type' the literal occupies+literalType :: Literal -> Type+literalType MachNullAddr    = addrPrimTy+literalType (MachChar _)    = charPrimTy+literalType (MachStr  _)    = addrPrimTy+literalType (MachInt  _)    = intPrimTy+literalType (MachWord  _)   = wordPrimTy+literalType (MachInt64  _)  = int64PrimTy+literalType (MachWord64  _) = word64PrimTy+literalType (MachFloat _)   = floatPrimTy+literalType (MachDouble _)  = doublePrimTy+literalType (MachLabel _ _ _) = addrPrimTy+literalType (LitInteger _ t) = t++absentLiteralOf :: TyCon -> Maybe Literal+-- Return a literal of the appropriate primtive+-- TyCon, to use as a placeholder when it doesn't matter+absentLiteralOf tc = lookupUFM absent_lits (tyConName tc)++absent_lits :: UniqFM Literal+absent_lits = listToUFM [ (addrPrimTyConKey,    MachNullAddr)+                        , (charPrimTyConKey,    MachChar 'x')+                        , (intPrimTyConKey,     MachInt 0)+                        , (int64PrimTyConKey,   MachInt64 0)+                        , (floatPrimTyConKey,   MachFloat 0)+                        , (doublePrimTyConKey,  MachDouble 0)+                        , (wordPrimTyConKey,    MachWord 0)+                        , (word64PrimTyConKey,  MachWord64 0) ]++{-+        Comparison+        ~~~~~~~~~~+-}++cmpLit :: Literal -> Literal -> Ordering+cmpLit (MachChar      a)   (MachChar       b)   = a `compare` b+cmpLit (MachStr       a)   (MachStr        b)   = a `compare` b+cmpLit (MachNullAddr)      (MachNullAddr)       = EQ+cmpLit (MachInt       a)   (MachInt        b)   = a `compare` b+cmpLit (MachWord      a)   (MachWord       b)   = a `compare` b+cmpLit (MachInt64     a)   (MachInt64      b)   = a `compare` b+cmpLit (MachWord64    a)   (MachWord64     b)   = a `compare` b+cmpLit (MachFloat     a)   (MachFloat      b)   = a `compare` b+cmpLit (MachDouble    a)   (MachDouble     b)   = a `compare` b+cmpLit (MachLabel     a _ _) (MachLabel      b _ _) = a `compare` b+cmpLit (LitInteger    a _) (LitInteger     b _) = a `compare` b+cmpLit lit1                lit2                 | litTag lit1 < litTag lit2 = LT+                                                | otherwise                 = GT++litTag :: Literal -> Int+litTag (MachChar      _)   = 1+litTag (MachStr       _)   = 2+litTag (MachNullAddr)      = 3+litTag (MachInt       _)   = 4+litTag (MachWord      _)   = 5+litTag (MachInt64     _)   = 6+litTag (MachWord64    _)   = 7+litTag (MachFloat     _)   = 8+litTag (MachDouble    _)   = 9+litTag (MachLabel _ _ _)   = 10+litTag (LitInteger  {})    = 11++{-+        Printing+        ~~~~~~~~+* See Note [Printing of literals in Core]+-}++pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc+pprLiteral _       (MachChar c)     = pprPrimChar c+pprLiteral _       (MachStr s)      = pprHsBytes s+pprLiteral _       (MachNullAddr)   = text "__NULL"+pprLiteral _       (MachInt i)      = pprPrimInt i+pprLiteral _       (MachInt64 i)    = pprPrimInt64 i+pprLiteral _       (MachWord w)     = pprPrimWord w+pprLiteral _       (MachWord64 w)   = pprPrimWord64 w+pprLiteral _       (MachFloat f)    = float (fromRat f) <> primFloatSuffix+pprLiteral _       (MachDouble d)   = double (fromRat d) <> primDoubleSuffix+pprLiteral add_par (LitInteger i _) = pprIntegerVal add_par i+pprLiteral add_par (MachLabel l mb fod) = add_par (text "__label" <+> b <+> ppr fod)+    where b = case mb of+              Nothing -> pprHsString l+              Just x  -> doubleQuotes (text (unpackFS l ++ '@':show x))++pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc+-- See Note [Printing of literals in Core].+pprIntegerVal add_par i | i < 0     = add_par (integer i)+                        | otherwise = integer i++{-+Note [Printing of literals in Core]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The function `add_par` is used to wrap parenthesis around negative integers+(`LitInteger`) and labels (`MachLabel`), if they occur in a context requiring+an atomic thing (for example function application).++Although not all Core literals would be valid Haskell, we are trying to stay+as close as possible to Haskell syntax in the printing of Core, to make it+easier for a Haskell user to read Core.++To that end:+  * We do print parenthesis around negative `LitInteger`, because we print+  `LitInteger` using plain number literals (no prefix or suffix), and plain+  number literals in Haskell require parenthesis in contexts like function+  application (i.e. `1 - -1` is not valid Haskell).++  * We don't print parenthesis around other (negative) literals, because they+  aren't needed in GHC/Haskell either (i.e. `1# -# -1#` is accepted by GHC's+  parser).++Literal         Output             Output if context requires+                                   an atom (if different)+-------         -------            ----------------------+MachChar        'a'#+MachStr         "aaa"#+MachNullAddr    "__NULL"+MachInt         -1#+MachInt64       -1L#+MachWord         1##+MachWord64       1L##+MachFloat       -1.0#+MachDouble      -1.0##+LitInteger      -1                 (-1)+MachLabel       "__label" ...      ("__label" ...)+-}
+ basicTypes/MkId.hs view
@@ -0,0 +1,1570 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1998+++This module contains definitions for the IdInfo for things that+have a standard form, namely:++- data constructors+- record selectors+- method and superclass selectors+- primitive operations+-}++{-# LANGUAGE CPP #-}++module MkId (+        mkDictFunId, mkDictFunTy, mkDictSelId, mkDictSelRhs,++        mkPrimOpId, mkFCallId,++        wrapNewTypeBody, unwrapNewTypeBody,+        wrapFamInstBody, unwrapFamInstScrut,+        wrapTypeUnbranchedFamInstBody, unwrapTypeUnbranchedFamInstScrut,++        DataConBoxer(..), mkDataConRep, mkDataConWorkId,++        -- And some particular Ids; see below for why they are wired in+        wiredInIds, ghcPrimIds,+        unsafeCoerceName, unsafeCoerceId, realWorldPrimId,+        voidPrimId, voidArgId,+        nullAddrId, seqId, lazyId, lazyIdKey, runRWId,+        coercionTokenId, magicDictId, coerceId,+        proxyHashId, noinlineId, noinlineIdName,++        -- Re-export error Ids+        module PrelRules+    ) where++#include "HsVersions.h"++import Rules+import TysPrim+import TysWiredIn+import PrelRules+import Type+import FamInstEnv+import Coercion+import TcType+import MkCore+import CoreUtils        ( exprType, mkCast )+import CoreUnfold+import Literal+import TyCon+import CoAxiom+import Class+import NameSet+import Name+import PrimOp+import ForeignCall+import DataCon+import Id+import IdInfo+import Demand+import CoreSyn+import Unique+import UniqSupply+import PrelNames+import BasicTypes       hiding ( SuccessFlag(..) )+import Util+import Pair+import DynFlags+import Outputable+import FastString+import ListSetOps+import qualified GHC.LanguageExtensions as LangExt++import Data.Maybe       ( maybeToList )++{-+************************************************************************+*                                                                      *+\subsection{Wired in Ids}+*                                                                      *+************************************************************************++Note [Wired-in Ids]+~~~~~~~~~~~~~~~~~~~+There are several reasons why an Id might appear in the wiredInIds:++(1) The ghcPrimIds are wired in because they can't be defined in+    Haskell at all, although the can be defined in Core.  They have+    compulsory unfoldings, so they are always inlined and they  have+    no definition site.  Their home module is GHC.Prim, so they+    also have a description in primops.txt.pp, where they are called+    'pseudoops'.++(2) The 'error' function, eRROR_ID, is wired in because we don't yet have+    a way to express in an interface file that the result type variable+    is 'open'; that is can be unified with an unboxed type++    [The interface file format now carry such information, but there's+    no way yet of expressing at the definition site for these+    error-reporting functions that they have an 'open'+    result type. -- sof 1/99]++(3) Other error functions (rUNTIME_ERROR_ID) are wired in (a) because+    the desugarer generates code that mentions them directly, and+    (b) for the same reason as eRROR_ID++(4) lazyId is wired in because the wired-in version overrides the+    strictness of the version defined in GHC.Base++(5) noinlineId is wired in because when we serialize to interfaces+    we may insert noinline statements.++In cases (2-4), the function has a definition in a library module, and+can be called; but the wired-in version means that the details are+never read from that module's interface file; instead, the full definition+is right here.+-}++wiredInIds :: [Id]+wiredInIds+  =  [lazyId, dollarId, oneShotId, runRWId, noinlineId]+  ++ errorIds           -- Defined in MkCore+  ++ ghcPrimIds++-- These Ids are exported from GHC.Prim+ghcPrimIds :: [Id]+ghcPrimIds+  = [   -- These can't be defined in Haskell, but they have+        -- perfectly reasonable unfoldings in Core+    realWorldPrimId,+    voidPrimId,+    unsafeCoerceId,+    nullAddrId,+    seqId,+    magicDictId,+    coerceId,+    proxyHashId+    ]++{-+************************************************************************+*                                                                      *+\subsection{Data constructors}+*                                                                      *+************************************************************************++The wrapper for a constructor is an ordinary top-level binding that evaluates+any strict args, unboxes any args that are going to be flattened, and calls+the worker.++We're going to build a constructor that looks like:++        data (Data a, C b) =>  T a b = T1 !a !Int b++        T1 = /\ a b ->+             \d1::Data a, d2::C b ->+             \p q r -> case p of { p ->+                       case q of { q ->+                       Con T1 [a,b] [p,q,r]}}++Notice that++* d2 is thrown away --- a context in a data decl is used to make sure+  one *could* construct dictionaries at the site the constructor+  is used, but the dictionary isn't actually used.++* We have to check that we can construct Data dictionaries for+  the types a and Int.  Once we've done that we can throw d1 away too.++* We use (case p of q -> ...) to evaluate p, rather than "seq" because+  all that matters is that the arguments are evaluated.  "seq" is+  very careful to preserve evaluation order, which we don't need+  to be here.++  You might think that we could simply give constructors some strictness+  info, like PrimOps, and let CoreToStg do the let-to-case transformation.+  But we don't do that because in the case of primops and functions strictness+  is a *property* not a *requirement*.  In the case of constructors we need to+  do something active to evaluate the argument.++  Making an explicit case expression allows the simplifier to eliminate+  it in the (common) case where the constructor arg is already evaluated.++Note [Wrappers for data instance tycons]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the case of data instances, the wrapper also applies the coercion turning+the representation type into the family instance type to cast the result of+the wrapper.  For example, consider the declarations++  data family Map k :: * -> *+  data instance Map (a, b) v = MapPair (Map a (Pair b v))++The tycon to which the datacon MapPair belongs gets a unique internal+name of the form :R123Map, and we call it the representation tycon.+In contrast, Map is the family tycon (accessible via+tyConFamInst_maybe). A coercion allows you to move between+representation and family type.  It is accessible from :R123Map via+tyConFamilyCoercion_maybe and has kind++  Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v}++The wrapper and worker of MapPair get the types++        -- Wrapper+  $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v+  $WMapPair a b v = MapPair a b v `cast` sym (Co123Map a b v)++        -- Worker+  MapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v++This coercion is conditionally applied by wrapFamInstBody.++It's a bit more complicated if the data instance is a GADT as well!++   data instance T [a] where+        T1 :: forall b. b -> T [Maybe b]++Hence we translate to++        -- Wrapper+  $WT1 :: forall b. b -> T [Maybe b]+  $WT1 b v = T1 (Maybe b) b (Maybe b) v+                        `cast` sym (Co7T (Maybe b))++        -- Worker+  T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c++        -- Coercion from family type to representation type+  Co7T a :: T [a] ~ :R7T a++Note [Newtype datacons]+~~~~~~~~~~~~~~~~~~~~~~~+The "data constructor" for a newtype should always be vanilla.  At one+point this wasn't true, because the newtype arising from+     class C a => D a+looked like+       newtype T:D a = D:D (C a)+so the data constructor for T:C had a single argument, namely the+predicate (C a).  But now we treat that as an ordinary argument, not+part of the theta-type, so all is well.+++************************************************************************+*                                                                      *+\subsection{Dictionary selectors}+*                                                                      *+************************************************************************++Selecting a field for a dictionary.  If there is just one field, then+there's nothing to do.++Dictionary selectors may get nested forall-types.  Thus:++        class Foo a where+          op :: forall b. Ord b => a -> b -> b++Then the top-level type for op is++        op :: forall a. Foo a =>+              forall b. Ord b =>+              a -> b -> b++-}++mkDictSelId :: Name          -- Name of one of the *value* selectors+                             -- (dictionary superclass or method)+            -> Class -> Id+mkDictSelId name clas+  = mkGlobalId (ClassOpId clas) name sel_ty info+  where+    tycon          = classTyCon clas+    sel_names      = map idName (classAllSelIds clas)+    new_tycon      = isNewTyCon tycon+    [data_con]     = tyConDataCons tycon+    tyvars         = dataConUnivTyVarBinders data_con+    n_ty_args      = length tyvars+    arg_tys        = dataConRepArgTys data_con  -- Includes the dictionary superclasses+    val_index      = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name++    sel_ty = mkForAllTys tyvars $+             mkFunTy (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $+             getNth arg_tys val_index++    base_info = noCafIdInfo+                `setArityInfo`          1+                `setStrictnessInfo`     strict_sig+                `setLevityInfoWithType` sel_ty++    info | new_tycon+         = base_info `setInlinePragInfo` alwaysInlinePragma+                     `setUnfoldingInfo`  mkInlineUnfoldingWithArity 1+                                           (mkDictSelRhs clas val_index)+                   -- See Note [Single-method classes] in TcInstDcls+                   -- for why alwaysInlinePragma++         | otherwise+         = base_info `setRuleInfo` mkRuleInfo [rule]+                   -- Add a magic BuiltinRule, but no unfolding+                   -- so that the rule is always available to fire.+                   -- See Note [ClassOp/DFun selection] in TcInstDcls++    -- This is the built-in rule that goes+    --      op (dfT d1 d2) --->  opT d1 d2+    rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS`+                                     occNameFS (getOccName name)+                       , ru_fn    = name+                       , ru_nargs = n_ty_args + 1+                       , ru_try   = dictSelRule val_index n_ty_args }++        -- The strictness signature is of the form U(AAAVAAAA) -> T+        -- where the V depends on which item we are selecting+        -- It's worth giving one, so that absence info etc is generated+        -- even if the selector isn't inlined++    strict_sig = mkClosedStrictSig [arg_dmd] topRes+    arg_dmd | new_tycon = evalDmd+            | otherwise = mkManyUsedDmd $+                          mkProdDmd [ if name == sel_name then evalDmd else absDmd+                                    | sel_name <- sel_names ]++mkDictSelRhs :: Class+             -> Int         -- 0-indexed selector among (superclasses ++ methods)+             -> CoreExpr+mkDictSelRhs clas val_index+  = mkLams tyvars (Lam dict_id rhs_body)+  where+    tycon          = classTyCon clas+    new_tycon      = isNewTyCon tycon+    [data_con]     = tyConDataCons tycon+    tyvars         = dataConUnivTyVars data_con+    arg_tys        = dataConRepArgTys data_con  -- Includes the dictionary superclasses++    the_arg_id     = getNth arg_ids val_index+    pred           = mkClassPred clas (mkTyVarTys tyvars)+    dict_id        = mkTemplateLocal 1 pred+    arg_ids        = mkTemplateLocalsNum 2 arg_tys++    rhs_body | new_tycon = unwrapNewTypeBody tycon (mkTyVarTys tyvars) (Var dict_id)+             | otherwise = Case (Var dict_id) dict_id (idType the_arg_id)+                                [(DataAlt data_con, arg_ids, varToCoreExpr the_arg_id)]+                                -- varToCoreExpr needed for equality superclass selectors+                                --   sel a b d = case x of { MkC _ (g:a~b) _ -> CO g }++dictSelRule :: Int -> Arity -> RuleFun+-- Tries to persuade the argument to look like a constructor+-- application, using exprIsConApp_maybe, and then selects+-- from it+--       sel_i t1..tk (D t1..tk op1 ... opm) = opi+--+dictSelRule val_index n_ty_args _ id_unf _ args+  | (dict_arg : _) <- drop n_ty_args args+  , Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg+  = Just (getNth con_args val_index)+  | otherwise+  = Nothing++{-+************************************************************************+*                                                                      *+        Data constructors+*                                                                      *+************************************************************************+-}++mkDataConWorkId :: Name -> DataCon -> Id+mkDataConWorkId wkr_name data_con+  | isNewTyCon tycon+  = mkGlobalId (DataConWrapId data_con) wkr_name nt_wrap_ty nt_work_info+  | otherwise+  = mkGlobalId (DataConWorkId data_con) wkr_name alg_wkr_ty wkr_info++  where+    tycon = dataConTyCon data_con++        ----------- Workers for data types --------------+    alg_wkr_ty = dataConRepType data_con+    wkr_arity = dataConRepArity data_con+    wkr_info  = noCafIdInfo+                `setArityInfo`          wkr_arity+                `setStrictnessInfo`     wkr_sig+                `setUnfoldingInfo`      evaldUnfolding  -- Record that it's evaluated,+                                                        -- even if arity = 0+                `setLevityInfoWithType` alg_wkr_ty+                  -- NB: unboxed tuples have workers, so we can't use+                  -- setNeverLevPoly++    wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) (dataConCPR data_con)+        --      Note [Data-con worker strictness]+        -- Notice that we do *not* say the worker is strict+        -- even if the data constructor is declared strict+        --      e.g.    data T = MkT !(Int,Int)+        -- Why?  Because the *wrapper* is strict (and its unfolding has case+        -- expressions that do the evals) but the *worker* itself is not.+        -- If we pretend it is strict then when we see+        --      case x of y -> $wMkT y+        -- the simplifier thinks that y is "sure to be evaluated" (because+        --  $wMkT is strict) and drops the case.  No, $wMkT is not strict.+        --+        -- When the simplifier sees a pattern+        --      case e of MkT x -> ...+        -- it uses the dataConRepStrictness of MkT to mark x as evaluated;+        -- but that's fine... dataConRepStrictness comes from the data con+        -- not from the worker Id.++        ----------- Workers for newtypes --------------+    (nt_tvs, _, nt_arg_tys, _) = dataConSig data_con+    res_ty_args  = mkTyVarTys nt_tvs+    nt_wrap_ty   = dataConUserType data_con+    nt_work_info = noCafIdInfo          -- The NoCaf-ness is set by noCafIdInfo+                  `setArityInfo` 1      -- Arity 1+                  `setInlinePragInfo`     alwaysInlinePragma+                  `setUnfoldingInfo`      newtype_unf+                  `setLevityInfoWithType` nt_wrap_ty+    id_arg1      = mkTemplateLocal 1 (head nt_arg_tys)+    newtype_unf  = ASSERT2( isVanillaDataCon data_con &&+                            isSingleton nt_arg_tys, ppr data_con  )+                              -- Note [Newtype datacons]+                   mkCompulsoryUnfolding $+                   mkLams nt_tvs $ Lam id_arg1 $+                   wrapNewTypeBody tycon res_ty_args (Var id_arg1)++dataConCPR :: DataCon -> DmdResult+dataConCPR con+  | isDataTyCon tycon     -- Real data types only; that is,+                          -- not unboxed tuples or newtypes+  , null (dataConExTyVars con)  -- No existentials+  , wkr_arity > 0+  , wkr_arity <= mAX_CPR_SIZE+  = if is_prod then vanillaCprProdRes (dataConRepArity con)+               else cprSumRes (dataConTag con)+  | otherwise+  = topRes+  where+    is_prod   = isProductTyCon tycon+    tycon     = dataConTyCon con+    wkr_arity = dataConRepArity con++    mAX_CPR_SIZE :: Arity+    mAX_CPR_SIZE = 10+    -- We do not treat very big tuples as CPR-ish:+    --      a) for a start we get into trouble because there aren't+    --         "enough" unboxed tuple types (a tiresome restriction,+    --         but hard to fix),+    --      b) more importantly, big unboxed tuples get returned mainly+    --         on the stack, and are often then allocated in the heap+    --         by the caller.  So doing CPR for them may in fact make+    --         things worse.++{-+-------------------------------------------------+--         Data constructor representation+--+-- This is where we decide how to wrap/unwrap the+-- constructor fields+--+--------------------------------------------------+-}++type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr)+  -- Unbox: bind rep vars by decomposing src var++data Boxer = UnitBox | Boxer (TCvSubst -> UniqSM ([Var], CoreExpr))+  -- Box:   build src arg using these rep vars++-- | Data Constructor Boxer+newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind]))+                       -- Bind these src-level vars, returning the+                       -- rep-level vars to bind in the pattern++{-+Note [Inline partially-applied constructor wrappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We allow the wrapper to inline when partially applied to avoid+boxing values unnecessarily. For example, consider++   data Foo a = Foo !Int a++   instance Traversable Foo where+     traverse f (Foo i a) = Foo i <$> f a++This desugars to++   traverse f foo = case foo of+        Foo i# a -> let i = I# i#+                    in map ($WFoo i) (f a)++If the wrapper `$WFoo` is not inlined, we get a fruitless reboxing of `i`.+But if we inline the wrapper, we get++   map (\a. case i of I# i# a -> Foo i# a) (f a)++and now case-of-known-constructor eliminates the redundant allocation.+-}++mkDataConRep :: DynFlags+             -> FamInstEnvs+             -> Name+             -> Maybe [HsImplBang]+                -- See Note [Bangs on imported data constructors]+             -> DataCon+             -> UniqSM DataConRep+mkDataConRep dflags fam_envs wrap_name mb_bangs data_con+  | not wrapper_reqd+  = return NoDataConRep++  | otherwise+  = do { wrap_args <- mapM newLocal wrap_arg_tys+       ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers)+                                 initial_wrap_app++       ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info+             wrap_info = noCafIdInfo+                         `setArityInfo`         wrap_arity+                             -- It's important to specify the arity, so that partial+                             -- applications are treated as values+                         `setInlinePragInfo`    wrap_prag+                         `setUnfoldingInfo`     wrap_unf+                         `setStrictnessInfo`    wrap_sig+                             -- We need to get the CAF info right here because TidyPgm+                             -- does not tidy the IdInfo of implicit bindings (like the wrapper)+                             -- so it not make sure that the CAF info is sane+                         `setNeverLevPoly`      wrap_ty++             wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con)++             wrap_arg_dmds = map mk_dmd arg_ibangs+             mk_dmd str | isBanged str = evalDmd+                        | otherwise           = topDmd++             wrap_prag = alwaysInlinePragma `setInlinePragmaActivation`+                         ActiveAfter NoSourceText 2+                         -- See Note [Activation for data constructor wrappers]++             -- The wrapper will usually be inlined (see wrap_unf), so its+             -- strictness and CPR info is usually irrelevant. But this is+             -- not always the case; GHC may choose not to inline it. In+             -- particular, the wrapper constructor is not inlined inside+             -- an INLINE rhs or when it is not applied to any arguments.+             -- See Note [Inline partially-applied constructor wrappers]+             -- Passing Nothing here allows the wrapper to inline when+             -- unsaturated.+             wrap_unf = mkInlineUnfolding wrap_rhs+             wrap_tvs = (univ_tvs `minusList` map eqSpecTyVar eq_spec) ++ ex_tvs+             wrap_rhs = mkLams wrap_tvs $+                        mkLams wrap_args $+                        wrapFamInstBody tycon res_ty_args $+                        wrap_body++       ; return (DCR { dcr_wrap_id = wrap_id+                     , dcr_boxer   = mk_boxer boxers+                     , dcr_arg_tys = rep_tys+                     , dcr_stricts = rep_strs+                     , dcr_bangs   = arg_ibangs }) }++  where+    (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty)+      = dataConFullSig data_con+    res_ty_args  = substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec)) univ_tvs++    tycon        = dataConTyCon data_con       -- The representation TyCon (not family)+    wrap_ty      = dataConUserType data_con+    ev_tys       = eqSpecPreds eq_spec ++ theta+    all_arg_tys  = ev_tys ++ orig_arg_tys+    ev_ibangs    = map (const HsLazy) ev_tys+    orig_bangs   = dataConSrcBangs data_con++    wrap_arg_tys = theta ++ orig_arg_tys+    wrap_arity   = length wrap_arg_tys+             -- The wrap_args are the arguments *other than* the eq_spec+             -- Because we are going to apply the eq_spec args manually in the+             -- wrapper++    arg_ibangs =+      case mb_bangs of+        Nothing    -> zipWith (dataConSrcToImplBang dflags fam_envs)+                              orig_arg_tys orig_bangs+        Just bangs -> bangs++    (rep_tys_w_strs, wrappers)+      = unzip (zipWith dataConArgRep all_arg_tys (ev_ibangs ++ arg_ibangs))++    (unboxers, boxers) = unzip wrappers+    (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs)++    wrapper_reqd = not (isNewTyCon tycon)  -- Newtypes have only a worker+                && (any isBanged (ev_ibangs ++ arg_ibangs)+                      -- Some forcing/unboxing (includes eq_spec)+                    || isFamInstTyCon tycon  -- Cast result+                    || (not $ null eq_spec)) -- GADT++    initial_wrap_app = Var (dataConWorkId data_con)+                       `mkTyApps`  res_ty_args+                       `mkVarApps` ex_tvs+                       `mkCoApps`  map (mkReflCo Nominal . eqSpecType) eq_spec++    mk_boxer :: [Boxer] -> DataConBoxer+    mk_boxer boxers = DCB (\ ty_args src_vars ->+                      do { let (ex_vars, term_vars) = splitAtList ex_tvs src_vars+                               subst1 = zipTvSubst univ_tvs ty_args+                               subst2 = extendTvSubstList subst1 ex_tvs+                                                          (mkTyVarTys ex_vars)+                         ; (rep_ids, binds) <- go subst2 boxers term_vars+                         ; return (ex_vars ++ rep_ids, binds) } )++    go _ [] src_vars = ASSERT2( null src_vars, ppr data_con ) return ([], [])+    go subst (UnitBox : boxers) (src_var : src_vars)+      = do { (rep_ids2, binds) <- go subst boxers src_vars+           ; return (src_var : rep_ids2, binds) }+    go subst (Boxer boxer : boxers) (src_var : src_vars)+      = do { (rep_ids1, arg)  <- boxer subst+           ; (rep_ids2, binds) <- go subst boxers src_vars+           ; return (rep_ids1 ++ rep_ids2, NonRec src_var arg : binds) }+    go _ (_:_) [] = pprPanic "mk_boxer" (ppr data_con)++    mk_rep_app :: [(Id,Unboxer)] -> CoreExpr -> UniqSM CoreExpr+    mk_rep_app [] con_app+      = return con_app+    mk_rep_app ((wrap_arg, unboxer) : prs) con_app+      = do { (rep_ids, unbox_fn) <- unboxer wrap_arg+           ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids)+           ; return (unbox_fn expr) }++{- Note [Activation for data constructor wrappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The Activation on a data constructor wrapper allows it to inline in+Phase 2 and later (1, 0).  But not in the InitialPhase.  That gives+rewrite rules a chance to fire (in the InitialPhase) if they mention+a data constructor on the left+   RULE "foo"  f (K a b) = ...+Since the LHS of rules are simplified with InitialPhase, we won't+inline the wrapper on the LHS either.++People have asked for this before, but now that even the InitialPhase+does some inlining, it has become important.+++Note [Bangs on imported data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We pass Maybe [HsImplBang] to mkDataConRep to make use of HsImplBangs+from imported modules.++- Nothing <=> use HsSrcBangs+- Just bangs <=> use HsImplBangs++For imported types we can't work it all out from the HsSrcBangs,+because we want to be very sure to follow what the original module+(where the data type was declared) decided, and that depends on what+flags were enabled when it was compiled. So we record the decisions in+the interface file.++The HsImplBangs passed are in 1-1 correspondence with the+dataConOrigArgTys of the DataCon.++-}++-------------------------+newLocal :: Type -> UniqSM Var+newLocal ty = do { uniq <- getUniqueM+                 ; return (mkSysLocalOrCoVar (fsLit "dt") uniq ty) }++-- | Unpack/Strictness decisions from source module+dataConSrcToImplBang+   :: DynFlags+   -> FamInstEnvs+   -> Type+   -> HsSrcBang+   -> HsImplBang++dataConSrcToImplBang dflags fam_envs arg_ty+              (HsSrcBang ann unpk NoSrcStrict)+  | xopt LangExt.StrictData dflags -- StrictData => strict field+  = dataConSrcToImplBang dflags fam_envs arg_ty+                  (HsSrcBang ann unpk SrcStrict)+  | otherwise -- no StrictData => lazy field+  = HsLazy++dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy)+  = HsLazy++dataConSrcToImplBang dflags fam_envs arg_ty+    (HsSrcBang _ unpk_prag SrcStrict)+  | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas+          -- Don't unpack if we aren't optimising; rather arbitrarily,+          -- we use -fomit-iface-pragmas as the indication+  , let mb_co   = topNormaliseType_maybe fam_envs arg_ty+                     -- Unwrap type families and newtypes+        arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty }+  , isUnpackableType dflags fam_envs arg_ty'+  , (rep_tys, _) <- dataConArgUnpack arg_ty'+  , case unpk_prag of+      NoSrcUnpack ->+        gopt Opt_UnboxStrictFields dflags+            || (gopt Opt_UnboxSmallStrictFields dflags+                && length rep_tys <= 1) -- See Note [Unpack one-wide fields]+      srcUnpack -> isSrcUnpacked srcUnpack+  = case mb_co of+      Nothing     -> HsUnpack Nothing+      Just (co,_) -> HsUnpack (Just co)++  | otherwise -- Record the strict-but-no-unpack decision+  = HsStrict+++-- | Wrappers/Workers and representation following Unpack/Strictness+-- decisions+dataConArgRep+  :: Type+  -> HsImplBang+  -> ([(Type,StrictnessMark)] -- Rep types+     ,(Unboxer,Boxer))++dataConArgRep arg_ty HsLazy+  = ([(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))++dataConArgRep arg_ty HsStrict+  = ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer))++dataConArgRep arg_ty (HsUnpack Nothing)+  | (rep_tys, wrappers) <- dataConArgUnpack arg_ty+  = (rep_tys, wrappers)++dataConArgRep _ (HsUnpack (Just co))+  | let co_rep_ty = pSnd (coercionKind co)+  , (rep_tys, wrappers) <- dataConArgUnpack co_rep_ty+  = (rep_tys, wrapCo co co_rep_ty wrappers)+++-------------------------+wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer)+wrapCo co rep_ty (unbox_rep, box_rep)  -- co :: arg_ty ~ rep_ty+  = (unboxer, boxer)+  where+    unboxer arg_id = do { rep_id <- newLocal rep_ty+                        ; (rep_ids, rep_fn) <- unbox_rep rep_id+                        ; let co_bind = NonRec rep_id (Var arg_id `Cast` co)+                        ; return (rep_ids, Let co_bind . rep_fn) }+    boxer = Boxer $ \ subst ->+            do { (rep_ids, rep_expr)+                    <- case box_rep of+                         UnitBox -> do { rep_id <- newLocal (TcType.substTy subst rep_ty)+                                       ; return ([rep_id], Var rep_id) }+                         Boxer boxer -> boxer subst+               ; let sco = substCoUnchecked subst co+               ; return (rep_ids, rep_expr `Cast` mkSymCo sco) }++------------------------+seqUnboxer :: Unboxer+seqUnboxer v = return ([v], \e -> Case (Var v) v (exprType e) [(DEFAULT, [], e)])++unitUnboxer :: Unboxer+unitUnboxer v = return ([v], \e -> e)++unitBoxer :: Boxer+unitBoxer = UnitBox++-------------------------+dataConArgUnpack+   :: Type+   ->  ( [(Type, StrictnessMark)]   -- Rep types+       , (Unboxer, Boxer) )++dataConArgUnpack arg_ty+  | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty+  , Just con <- tyConSingleAlgDataCon_maybe tc+      -- NB: check for an *algebraic* data type+      -- A recursive newtype might mean that+      -- 'arg_ty' is a newtype+  , let rep_tys = dataConInstArgTys con tc_args+  = ASSERT( isVanillaDataCon con )+    ( rep_tys `zip` dataConRepStrictness con+    ,( \ arg_id ->+       do { rep_ids <- mapM newLocal rep_tys+          ; let unbox_fn body+                  = Case (Var arg_id) arg_id (exprType body)+                         [(DataAlt con, rep_ids, body)]+          ; return (rep_ids, unbox_fn) }+     , Boxer $ \ subst ->+       do { rep_ids <- mapM (newLocal . TcType.substTyUnchecked subst) rep_tys+          ; return (rep_ids, Var (dataConWorkId con)+                             `mkTyApps` (substTysUnchecked subst tc_args)+                             `mkVarApps` rep_ids ) } ) )+  | otherwise+  = pprPanic "dataConArgUnpack" (ppr arg_ty)+    -- An interface file specified Unpacked, but we couldn't unpack it++isUnpackableType :: DynFlags -> FamInstEnvs -> Type -> Bool+-- True if we can unpack the UNPACK the argument type+-- See Note [Recursive unboxing]+-- We look "deeply" inside rather than relying on the DataCons+-- we encounter on the way, because otherwise we might well+-- end up relying on ourselves!+isUnpackableType dflags fam_envs ty+  | Just (tc, _) <- splitTyConApp_maybe ty+  , Just con <- tyConSingleAlgDataCon_maybe tc+  , isVanillaDataCon con+  = ok_con_args (unitNameSet (getName tc)) con+  | otherwise+  = False+  where+    ok_arg tcs (ty, bang) = not (attempt_unpack bang) || ok_ty tcs norm_ty+        where+          norm_ty = topNormaliseType fam_envs ty+    ok_ty tcs ty+      | Just (tc, _) <- splitTyConApp_maybe ty+      , let tc_name = getName tc+      =  not (tc_name `elemNameSet` tcs)+      && case tyConSingleAlgDataCon_maybe tc of+            Just con | isVanillaDataCon con+                    -> ok_con_args (tcs `extendNameSet` getName tc) con+            _ -> True+      | otherwise+      = True++    ok_con_args tcs con+       = all (ok_arg tcs) (dataConOrigArgTys con `zip` dataConSrcBangs con)+         -- NB: dataConSrcBangs gives the *user* request;+         -- We'd get a black hole if we used dataConImplBangs++    attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict)+      = xopt LangExt.StrictData dflags+    attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict)+      = True+    attempt_unpack (HsSrcBang _  NoSrcUnpack SrcStrict)+      = True  -- Be conservative+    attempt_unpack (HsSrcBang _  NoSrcUnpack NoSrcStrict)+      = xopt LangExt.StrictData dflags -- Be conservative+    attempt_unpack _ = False++{-+Note [Unpack one-wide fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The flag UnboxSmallStrictFields ensures that any field that can+(safely) be unboxed to a word-sized unboxed field, should be so unboxed.+For example:++    data A = A Int#+    newtype B = B A+    data C = C !B+    data D = D !C+    data E = E !()+    data F = F !D+    data G = G !F !F++All of these should have an Int# as their representation, except+G which should have two Int#s.++However++    data T = T !(S Int)+    data S = S !a++Here we can represent T with an Int#.++Note [Recursive unboxing]+~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  data R = MkR {-# UNPACK #-} !S Int+  data S = MkS {-# UNPACK #-} !Int+The representation arguments of MkR are the *representation* arguments+of S (plus Int); the rep args of MkS are Int#.  This is all fine.++But be careful not to try to unbox this!+        data T = MkT {-# UNPACK #-} !T Int+Because then we'd get an infinite number of arguments.++Here is a more complicated case:+        data S = MkS {-# UNPACK #-} !T Int+        data T = MkT {-# UNPACK #-} !S Int+Each of S and T must decide independently whether to unpack+and they had better not both say yes. So they must both say no.++Also behave conservatively when there is no UNPACK pragma+        data T = MkS !T Int+with -funbox-strict-fields or -funbox-small-strict-fields+we need to behave as if there was an UNPACK pragma there.++But it's the *argument* type that matters. This is fine:+        data S = MkS S !Int+because Int is non-recursive.++************************************************************************+*                                                                      *+        Wrapping and unwrapping newtypes and type families+*                                                                      *+************************************************************************+-}++wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr+-- The wrapper for the data constructor for a newtype looks like this:+--      newtype T a = MkT (a,Int)+--      MkT :: forall a. (a,Int) -> T a+--      MkT = /\a. \(x:(a,Int)). x `cast` sym (CoT a)+-- where CoT is the coercion TyCon associated with the newtype+--+-- The call (wrapNewTypeBody T [a] e) returns the+-- body of the wrapper, namely+--      e `cast` (CoT [a])+--+-- If a coercion constructor is provided in the newtype, then we use+-- it, otherwise the wrap/unwrap are both no-ops+--+-- If the we are dealing with a newtype *instance*, we have a second coercion+-- identifying the family instance with the constructor of the newtype+-- instance.  This coercion is applied in any case (ie, composed with the+-- coercion constructor of the newtype or applied by itself).++wrapNewTypeBody tycon args result_expr+  = ASSERT( isNewTyCon tycon )+    wrapFamInstBody tycon args $+    mkCast result_expr (mkSymCo co)+  where+    co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args []++-- When unwrapping, we do *not* apply any family coercion, because this will+-- be done via a CoPat by the type checker.  We have to do it this way as+-- computing the right type arguments for the coercion requires more than just+-- a spliting operation (cf, TcPat.tcConPat).++unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr+unwrapNewTypeBody tycon args result_expr+  = ASSERT( isNewTyCon tycon )+    mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args [])++-- If the type constructor is a representation type of a data instance, wrap+-- the expression into a cast adjusting the expression type, which is an+-- instance of the representation type, to the corresponding instance of the+-- family instance type.+-- See Note [Wrappers for data instance tycons]+wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr+wrapFamInstBody tycon args body+  | Just co_con <- tyConFamilyCoercion_maybe tycon+  = mkCast body (mkSymCo (mkUnbranchedAxInstCo Representational co_con args []))+  | otherwise+  = body++-- Same as `wrapFamInstBody`, but for type family instances, which are+-- represented by a `CoAxiom`, and not a `TyCon`+wrapTypeFamInstBody :: CoAxiom br -> Int -> [Type] -> [Coercion]+                    -> CoreExpr -> CoreExpr+wrapTypeFamInstBody axiom ind args cos body+  = mkCast body (mkSymCo (mkAxInstCo Representational axiom ind args cos))++wrapTypeUnbranchedFamInstBody :: CoAxiom Unbranched -> [Type] -> [Coercion]+                              -> CoreExpr -> CoreExpr+wrapTypeUnbranchedFamInstBody axiom+  = wrapTypeFamInstBody axiom 0++unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr+unwrapFamInstScrut tycon args scrut+  | Just co_con <- tyConFamilyCoercion_maybe tycon+  = mkCast scrut (mkUnbranchedAxInstCo Representational co_con args []) -- data instances only+  | otherwise+  = scrut++unwrapTypeFamInstScrut :: CoAxiom br -> Int -> [Type] -> [Coercion]+                       -> CoreExpr -> CoreExpr+unwrapTypeFamInstScrut axiom ind args cos scrut+  = mkCast scrut (mkAxInstCo Representational axiom ind args cos)++unwrapTypeUnbranchedFamInstScrut :: CoAxiom Unbranched -> [Type] -> [Coercion]+                                 -> CoreExpr -> CoreExpr+unwrapTypeUnbranchedFamInstScrut axiom+  = unwrapTypeFamInstScrut axiom 0++{-+************************************************************************+*                                                                      *+\subsection{Primitive operations}+*                                                                      *+************************************************************************+-}++mkPrimOpId :: PrimOp -> Id+mkPrimOpId prim_op+  = id+  where+    (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op+    ty   = mkSpecForAllTys tyvars (mkFunTys arg_tys res_ty)+    name = mkWiredInName gHC_PRIM (primOpOcc prim_op)+                         (mkPrimOpIdUnique (primOpTag prim_op))+                         (AnId id) UserSyntax+    id   = mkGlobalId (PrimOpId prim_op) name ty info++    info = noCafIdInfo+           `setRuleInfo`           mkRuleInfo (maybeToList $ primOpRules name prim_op)+           `setArityInfo`          arity+           `setStrictnessInfo`     strict_sig+           `setInlinePragInfo`     neverInlinePragma+           `setLevityInfoWithType` res_ty+               -- We give PrimOps a NOINLINE pragma so that we don't+               -- get silly warnings from Desugar.dsRule (the inline_shadows_rule+               -- test) about a RULE conflicting with a possible inlining+               -- cf Trac #7287++-- For each ccall we manufacture a separate CCallOpId, giving it+-- a fresh unique, a type that is correct for this particular ccall,+-- and a CCall structure that gives the correct details about calling+-- convention etc.+--+-- The *name* of this Id is a local name whose OccName gives the full+-- details of the ccall, type and all.  This means that the interface+-- file reader can reconstruct a suitable Id++mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id+mkFCallId dflags uniq fcall ty+  = ASSERT( noFreeVarsOfType ty )+    -- A CCallOpId should have no free type variables;+    -- when doing substitutions won't substitute over it+    mkGlobalId (FCallId fcall) name ty info+  where+    occ_str = showSDoc dflags (braces (ppr fcall <+> ppr ty))+    -- The "occurrence name" of a ccall is the full info about the+    -- ccall; it is encoded, but may have embedded spaces etc!++    name = mkFCallName uniq occ_str++    info = noCafIdInfo+           `setArityInfo`          arity+           `setStrictnessInfo`     strict_sig+           `setLevityInfoWithType` ty++    (bndrs, _) = tcSplitPiTys ty+    arity      = count isAnonTyBinder bndrs+    strict_sig = mkClosedStrictSig (replicate arity topDmd) topRes+    -- the call does not claim to be strict in its arguments, since they+    -- may be lifted (foreign import prim) and the called code doesn't+    -- necessarily force them. See Trac #11076.+{-+************************************************************************+*                                                                      *+\subsection{DictFuns and default methods}+*                                                                      *+************************************************************************++Note [Dict funs and default methods]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Dict funs and default methods are *not* ImplicitIds.  Their definition+involves user-written code, so we can't figure out their strictness etc+based on fixed info, as we can for constructors and record selectors (say).++NB: See also Note [Exported LocalIds] in Id+-}++mkDictFunId :: Name      -- Name to use for the dict fun;+            -> [TyVar]+            -> ThetaType+            -> Class+            -> [Type]+            -> Id+-- Implements the DFun Superclass Invariant (see TcInstDcls)+-- See Note [Dict funs and default methods]++mkDictFunId dfun_name tvs theta clas tys+  = mkExportedLocalId (DFunId is_nt)+                      dfun_name+                      dfun_ty+  where+    is_nt = isNewTyCon (classTyCon clas)+    dfun_ty = mkDictFunTy tvs theta clas tys++mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type+mkDictFunTy tvs theta clas tys+ = mkSpecSigmaTy tvs theta (mkClassPred clas tys)++{-+************************************************************************+*                                                                      *+\subsection{Un-definable}+*                                                                      *+************************************************************************++These Ids can't be defined in Haskell.  They could be defined in+unfoldings in the wired-in GHC.Prim interface file, but we'd have to+ensure that they were definitely, definitely inlined, because there is+no curried identifier for them.  That's what mkCompulsoryUnfolding+does.  If we had a way to get a compulsory unfolding from an interface+file, we could do that, but we don't right now.++unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that+just gets expanded into a type coercion wherever it occurs.  Hence we+add it as a built-in Id with an unfolding here.++The type variables we use here are "open" type variables: this means+they can unify with both unlifted and lifted types.  Hence we provide+another gun with which to shoot yourself in the foot.+-}++lazyIdName, unsafeCoerceName, nullAddrName, seqName,+   realWorldName, voidPrimIdName, coercionTokenName,+   magicDictName, coerceName, proxyName, dollarName, oneShotName,+   runRWName, noinlineIdName :: Name+unsafeCoerceName  = mkWiredInIdName gHC_PRIM  (fsLit "unsafeCoerce#")  unsafeCoerceIdKey  unsafeCoerceId+nullAddrName      = mkWiredInIdName gHC_PRIM  (fsLit "nullAddr#")      nullAddrIdKey      nullAddrId+seqName           = mkWiredInIdName gHC_PRIM  (fsLit "seq")            seqIdKey           seqId+realWorldName     = mkWiredInIdName gHC_PRIM  (fsLit "realWorld#")     realWorldPrimIdKey realWorldPrimId+voidPrimIdName    = mkWiredInIdName gHC_PRIM  (fsLit "void#")          voidPrimIdKey      voidPrimId+lazyIdName        = mkWiredInIdName gHC_MAGIC (fsLit "lazy")           lazyIdKey          lazyId+coercionTokenName = mkWiredInIdName gHC_PRIM  (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId+magicDictName     = mkWiredInIdName gHC_PRIM  (fsLit "magicDict")      magicDictKey       magicDictId+coerceName        = mkWiredInIdName gHC_PRIM  (fsLit "coerce")         coerceKey          coerceId+proxyName         = mkWiredInIdName gHC_PRIM  (fsLit "proxy#")         proxyHashKey       proxyHashId+dollarName        = mkWiredInIdName gHC_BASE  (fsLit "$")              dollarIdKey        dollarId+oneShotName       = mkWiredInIdName gHC_MAGIC (fsLit "oneShot")        oneShotKey         oneShotId+runRWName         = mkWiredInIdName gHC_MAGIC (fsLit "runRW#")         runRWKey           runRWId+noinlineIdName    = mkWiredInIdName gHC_MAGIC (fsLit "noinline") noinlineIdKey noinlineId++dollarId :: Id  -- Note [dollarId magic]+dollarId = pcMiscPrelId dollarName ty+             (noCafIdInfo `setUnfoldingInfo` unf)+  where+    fun_ty = mkFunTy alphaTy openBetaTy+    ty     = mkSpecForAllTys [runtimeRep2TyVar, alphaTyVar, openBetaTyVar] $+             mkFunTy fun_ty fun_ty+    unf    = mkInlineUnfoldingWithArity 2 rhs+    [f,x]  = mkTemplateLocals [fun_ty, alphaTy]+    rhs    = mkLams [runtimeRep2TyVar, alphaTyVar, openBetaTyVar, f, x] $+             App (Var f) (Var x)++------------------------------------------------+proxyHashId :: Id+proxyHashId+  = pcMiscPrelId proxyName ty+       (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings]+                    `setNeverLevPoly`  ty )+  where+    -- proxy# :: forall k (a:k). Proxy# k a+    bndrs   = mkTemplateKiTyVars [liftedTypeKind] (\ks -> ks)+    [k,t]   = mkTyVarTys bndrs+    ty      = mkSpecForAllTys bndrs (mkProxyPrimTy k t)++------------------------------------------------+unsafeCoerceId :: Id+unsafeCoerceId+  = pcMiscPrelId unsafeCoerceName ty info+  where+    info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma+                       `setUnfoldingInfo`  mkCompulsoryUnfolding rhs++    -- unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)+    --                         (a :: TYPE r1) (b :: TYPE r2).+    --                         a -> b+    bndrs = mkTemplateKiTyVars [runtimeRepTy, runtimeRepTy]+                               (\ks -> map tYPE ks)++    [_, _, a, b] = mkTyVarTys bndrs++    ty  = mkSpecForAllTys bndrs (mkFunTy a b)++    [x] = mkTemplateLocals [a]+    rhs = mkLams (bndrs ++ [x]) $+          Cast (Var x) (mkUnsafeCo Representational a b)++------------------------------------------------+nullAddrId :: Id+-- nullAddr# :: Addr#+-- The reason it is here is because we don't provide+-- a way to write this literal in Haskell.+nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info+  where+    info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma+                       `setUnfoldingInfo`  mkCompulsoryUnfolding (Lit nullAddrLit)+                       `setNeverLevPoly`   addrPrimTy++------------------------------------------------+seqId :: Id     -- See Note [seqId magic]+seqId = pcMiscPrelId seqName ty info+  where+    info = noCafIdInfo `setInlinePragInfo` inline_prag+                       `setUnfoldingInfo`  mkCompulsoryUnfolding rhs+                       `setNeverLevPoly`   ty++    inline_prag+         = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter+                 NoSourceText 0+                  -- Make 'seq' not inline-always, so that simpleOptExpr+                  -- (see CoreSubst.simple_app) won't inline 'seq' on the+                  -- LHS of rules.  That way we can have rules for 'seq';+                  -- see Note [seqId magic]++    ty  = mkSpecForAllTys [alphaTyVar,betaTyVar]+                          (mkFunTy alphaTy (mkFunTy betaTy betaTy))++    [x,y] = mkTemplateLocals [alphaTy, betaTy]+    rhs = mkLams [alphaTyVar,betaTyVar,x,y] (Case (Var x) x betaTy [(DEFAULT, [], Var y)])++------------------------------------------------+lazyId :: Id    -- See Note [lazyId magic]+lazyId = pcMiscPrelId lazyIdName ty info+  where+    info = noCafIdInfo `setNeverLevPoly` ty+    ty  = mkSpecForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy)++noinlineId :: Id -- See Note [noinlineId magic]+noinlineId = pcMiscPrelId noinlineIdName ty info+  where+    info = noCafIdInfo `setNeverLevPoly` ty+    ty  = mkSpecForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy)++oneShotId :: Id -- See Note [The oneShot function]+oneShotId = pcMiscPrelId oneShotName ty info+  where+    info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma+                       `setUnfoldingInfo`  mkCompulsoryUnfolding rhs+    ty  = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar+                          , openAlphaTyVar, openBetaTyVar ]+                          (mkFunTy fun_ty fun_ty)+    fun_ty = mkFunTy openAlphaTy openBetaTy+    [body, x] = mkTemplateLocals [fun_ty, openAlphaTy]+    x' = setOneShotLambda x+    rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar+                 , openAlphaTyVar, openBetaTyVar+                 , body, x'] $+          Var body `App` Var x++runRWId :: Id -- See Note [runRW magic] in this module+runRWId = pcMiscPrelId runRWName ty info+  where+    info = noCafIdInfo `setInlinePragInfo` neverInlinePragma+                       `setStrictnessInfo` strict_sig+                       `setArityInfo`      1+    strict_sig = mkClosedStrictSig [strictApply1Dmd] topRes+      -- Important to express its strictness,+      -- since it is not inlined until CorePrep+      -- Also see Note [runRW arg] in CorePrep++    -- State# RealWorld+    stateRW = mkTyConApp statePrimTyCon [realWorldTy]+    -- o+    ret_ty  = openAlphaTy+    -- State# RealWorld -> o+    arg_ty  = stateRW `mkFunTy` ret_ty+    -- (State# RealWorld -> o) -> o+    ty      = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] $+              arg_ty `mkFunTy` ret_ty++--------------------------------------------------------------------------------+magicDictId :: Id  -- See Note [magicDictId magic]+magicDictId = pcMiscPrelId magicDictName ty info+  where+  info = noCafIdInfo `setInlinePragInfo` neverInlinePragma+                     `setNeverLevPoly`   ty+  ty   = mkSpecForAllTys [alphaTyVar] alphaTy++--------------------------------------------------------------------------------++coerceId :: Id+coerceId = pcMiscPrelId coerceName ty info+  where+    info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma+                       `setUnfoldingInfo`  mkCompulsoryUnfolding rhs+                       `setNeverLevPoly`   ty+    eqRTy     = mkTyConApp coercibleTyCon [ liftedTypeKind+                                          , alphaTy, betaTy ]+    eqRPrimTy = mkTyConApp eqReprPrimTyCon [ liftedTypeKind+                                           , liftedTypeKind+                                           , alphaTy, betaTy ]+    ty        = mkSpecForAllTys [alphaTyVar, betaTyVar] $+                mkFunTys [eqRTy, alphaTy] betaTy++    [eqR,x,eq] = mkTemplateLocals [eqRTy, alphaTy, eqRPrimTy]+    rhs = mkLams [alphaTyVar, betaTyVar, eqR, x] $+          mkWildCase (Var eqR) eqRTy betaTy $+          [(DataAlt coercibleDataCon, [eq], Cast (Var x) (mkCoVarCo eq))]++{-+Note [dollarId magic]+~~~~~~~~~~~~~~~~~~~~~+The only reason that ($) is wired in is so that its type can be+    forall (a:*, b:Open). (a->b) -> a -> b+That is, the return type can be unboxed.  E.g. this is OK+    foo $ True    where  foo :: Bool -> Int#+because ($) doesn't inspect or move the result of the call to foo.+See Trac #8739.++There is a special typing rule for ($) in TcExpr, so the type of ($)+isn't looked at there, BUT Lint subsequently (and rightly) complains+if sees ($) applied to Int# (say), unless we give it a wired-in type+as we do here.++Note [Unsafe coerce magic]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We define a *primitive*+   GHC.Prim.unsafeCoerce#+and then in the base library we define the ordinary function+   Unsafe.Coerce.unsafeCoerce :: forall (a:*) (b:*). a -> b+   unsafeCoerce x = unsafeCoerce# x++Notice that unsafeCoerce has a civilized (albeit still dangerous)+polymorphic type, whose type args have kind *.  So you can't use it on+unboxed values (unsafeCoerce 3#).++In contrast unsafeCoerce# is even more dangerous because you *can* use+it on unboxed things, (unsafeCoerce# 3#) :: Int. Its type is+   forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) (a: TYPE r1) (b: TYPE r2). a -> b++Note [seqId magic]+~~~~~~~~~~~~~~~~~~+'GHC.Prim.seq' is special in several ways.++a) In source Haskell its second arg can have an unboxed type+      x `seq` (v +# w)+   But see Note [Typing rule for seq] in TcExpr, which+   explains why we give seq itself an ordinary type+         seq :: forall a b. a -> b -> b+   and treat it as a language construct from a typing point of view.++b) Its fixity is set in LoadIface.ghcPrimIface++c) It has quite a bit of desugaring magic.+   See DsUtils.hs Note [Desugaring seq (1)] and (2) and (3)++d) There is some special rule handing: Note [User-defined RULES for seq]++Note [User-defined RULES for seq]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Roman found situations where he had+      case (f n) of _ -> e+where he knew that f (which was strict in n) would terminate if n did.+Notice that the result of (f n) is discarded. So it makes sense to+transform to+      case n of _ -> e++Rather than attempt some general analysis to support this, I've added+enough support that you can do this using a rewrite rule:++  RULE "f/seq" forall n.  seq (f n) = seq n++You write that rule.  When GHC sees a case expression that discards+its result, it mentally transforms it to a call to 'seq' and looks for+a RULE.  (This is done in Simplify.trySeqRules.)  As usual, the+correctness of the rule is up to you.++VERY IMPORTANT: to make this work, we give the RULE an arity of 1, not 2.+If we wrote+  RULE "f/seq" forall n e.  seq (f n) e = seq n e+with rule arity 2, then two bad things would happen:++  - The magical desugaring done in Note [seqId magic] item (c)+    for saturated application of 'seq' would turn the LHS into+    a case expression!++  - The code in Simplify.rebuildCase would need to actually supply+    the value argument, which turns out to be awkward.++Note [lazyId magic]+~~~~~~~~~~~~~~~~~~~+lazy :: forall a?. a? -> a?   (i.e. works for unboxed types too)++'lazy' is used to make sure that a sub-expression, and its free variables,+are truly used call-by-need, with no code motion.  Key examples:++* pseq:    pseq a b = a `seq` lazy b+  We want to make sure that the free vars of 'b' are not evaluated+  before 'a', even though the expression is plainly strict in 'b'.++* catch:   catch a b = catch# (lazy a) b+  Again, it's clear that 'a' will be evaluated strictly (and indeed+  applied to a state token) but we want to make sure that any exceptions+  arising from the evaluation of 'a' are caught by the catch (see+  Trac #11555).++Implementing 'lazy' is a bit tricky:++* It must not have a strictness signature: by being a built-in Id,+  all the info about lazyId comes from here, not from GHC.Base.hi.+  This is important, because the strictness analyser will spot it as+  strict!++* It must not have an unfolding: it gets "inlined" by a HACK in+  CorePrep. It's very important to do this inlining *after* unfoldings+  are exposed in the interface file.  Otherwise, the unfolding for+  (say) pseq in the interface file will not mention 'lazy', so if we+  inline 'pseq' we'll totally miss the very thing that 'lazy' was+  there for in the first place. See Trac #3259 for a real world+  example.++* Suppose CorePrep sees (catch# (lazy e) b).  At all costs we must+  avoid using call by value here:+     case e of r -> catch# r b+  Avoiding that is the whole point of 'lazy'.  So in CorePrep (which+  generate the 'case' expression for a call-by-value call) we must+  spot the 'lazy' on the arg (in CorePrep.cpeApp), and build a 'let'+  instead.++* lazyId is defined in GHC.Base, so we don't *have* to inline it.  If it+  appears un-applied, we'll end up just calling it.++Note [noinlineId magic]+~~~~~~~~~~~~~~~~~~~~~~~+noinline :: forall a. a -> a++'noinline' is used to make sure that a function f is never inlined,+e.g., as in 'noinline f x'.  Ordinarily, the identity function with NOINLINE+could be used to achieve this effect; however, this has the unfortunate+result of leaving a (useless) call to noinline at runtime.  So we have+a little bit of magic to optimize away 'noinline' after we are done+running the simplifier.++'noinline' needs to be wired-in because it gets inserted automatically+when we serialize an expression to the interface format, and we DON'T+want use its fingerprints.+++Note [runRW magic]+~~~~~~~~~~~~~~~~~~+Some definitions, for instance @runST@, must have careful control over float out+of the bindings in their body. Consider this use of @runST@,++    f x = runST ( \ s -> let (a, s')  = newArray# 100 [] s+                             (_, s'') = fill_in_array_or_something a x s'+                         in freezeArray# a s'' )++If we inline @runST@, we'll get:++    f x = let (a, s')  = newArray# 100 [] realWorld#{-NB-}+              (_, s'') = fill_in_array_or_something a x s'+          in freezeArray# a s''++And now if we allow the @newArray#@ binding to float out to become a CAF,+we end up with a result that is totally and utterly wrong:++    f = let (a, s')  = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!+        in \ x ->+            let (_, s'') = fill_in_array_or_something a x s'+            in freezeArray# a s''++All calls to @f@ will share a {\em single} array! Clearly this is nonsense and+must be prevented.++This is what @runRW#@ gives us: by being inlined extremely late in the+optimization (right before lowering to STG, in CorePrep), we can ensure that+no further floating will occur. This allows us to safely inline things like+@runST@, which are otherwise needlessly expensive (see #10678 and #5916).++While the definition of @GHC.Magic.runRW#@, we override its type in @MkId@+to be open-kinded,++    runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r)+           => (State# RealWorld -> (# State# RealWorld, o #))+                              -> (# State# RealWorld, o #)+++Note [The oneShot function]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the context of making left-folds fuse somewhat okish (see ticket #7994+and Note [Left folds via right fold]) it was determined that it would be useful+if library authors could explicitly tell the compiler that a certain lambda is+called at most once. The oneShot function allows that.++'oneShot' is open kinded, i.e. the type variables can refer to unlifted+types as well (Trac #10744); e.g.+   oneShot (\x:Int# -> x +# 1#)++Like most magic functions it has a compulsary unfolding, so there is no need+for a real definition somewhere. We have one in GHC.Magic for the convenience+of putting the documentation there.++It uses `setOneShotLambda` on the lambda's binder. That is the whole magic:++A typical call looks like+     oneShot (\y. e)+after unfolding the definition `oneShot = \f \x[oneshot]. f x` we get+     (\f \x[oneshot]. f x) (\y. e)+ --> \x[oneshot]. ((\y.e) x)+ --> \x[oneshot] e[x/y]+which is what we want.++It is only effective if the one-shot info survives as long as possible; in+particular it must make it into the interface in unfoldings. See Note [Preserve+OneShotInfo] in CoreTidy.++Also see https://ghc.haskell.org/trac/ghc/wiki/OneShot.+++Note [magicDictId magic]+~~~~~~~~~~~~~~~~~~~~~~~~~+The identifier `magicDict` is just a place-holder, which is used to+implement a primitve that we cannot define in Haskell but we can write+in Core.  It is declared with a place-holder type:++    magicDict :: forall a. a++The intention is that the identifier will be used in a very specific way,+to create dictionaries for classes with a single method.  Consider a class+like this:++   class C a where+     f :: T a++We are going to use `magicDict`, in conjunction with a built-in Prelude+rule, to cast values of type `T a` into dictionaries for `C a`.  To do+this, we define a function like this in the library:++  data WrapC a b = WrapC (C a => Proxy a -> b)++  withT :: (C a => Proxy a -> b)+        ->  T a -> Proxy a -> b+  withT f x y = magicDict (WrapC f) x y++The purpose of `WrapC` is to avoid having `f` instantiated.+Also, it avoids impredicativity, because `magicDict`'s type+cannot be instantiated with a forall.  The field of `WrapC` contains+a `Proxy` parameter which is used to link the type of the constraint,+`C a`, with the type of the `Wrap` value being made.++Next, we add a built-in Prelude rule (see prelude/PrelRules.hs),+which will replace the RHS of this definition with the appropriate+definition in Core.  The rewrite rule works as follows:++  magicDict @t (wrap @a @b f) x y+---->+  f (x `cast` co a) y++The `co` coercion is the newtype-coercion extracted from the type-class.+The type class is obtain by looking at the type of wrap.+++-------------------------------------------------------------+@realWorld#@ used to be a magic literal, \tr{void#}.  If things get+nasty as-is, change it back to a literal (@Literal@).++voidArgId is a Local Id used simply as an argument in functions+where we just want an arg to avoid having a thunk of unlifted type.+E.g.+        x = \ void :: Void# -> (# p, q #)++This comes up in strictness analysis++Note [evaldUnfoldings]+~~~~~~~~~~~~~~~~~~~~~~+The evaldUnfolding makes it look that some primitive value is+evaluated, which in turn makes Simplify.interestingArg return True,+which in turn makes INLINE things applied to said value likely to be+inlined.+-}++realWorldPrimId :: Id   -- :: State# RealWorld+realWorldPrimId = pcMiscPrelId realWorldName realWorldStatePrimTy+                     (noCafIdInfo `setUnfoldingInfo` evaldUnfolding    -- Note [evaldUnfoldings]+                                  `setOneShotInfo` stateHackOneShot+                                  `setNeverLevPoly` realWorldStatePrimTy)++voidPrimId :: Id     -- Global constant :: Void#+voidPrimId  = pcMiscPrelId voidPrimIdName voidPrimTy+                (noCafIdInfo `setUnfoldingInfo` evaldUnfolding     -- Note [evaldUnfoldings]+                             `setNeverLevPoly`  voidPrimTy)++voidArgId :: Id       -- Local lambda-bound :: Void#+voidArgId = mkSysLocal (fsLit "void") voidArgIdKey voidPrimTy++coercionTokenId :: Id         -- :: () ~ ()+coercionTokenId -- Used to replace Coercion terms when we go to STG+  = pcMiscPrelId coercionTokenName+                 (mkTyConApp eqPrimTyCon [liftedTypeKind, liftedTypeKind, unitTy, unitTy])+                 noCafIdInfo++pcMiscPrelId :: Name -> Type -> IdInfo -> Id+pcMiscPrelId name ty info+  = mkVanillaGlobalWithInfo name ty info+    -- We lie and say the thing is imported; otherwise, we get into+    -- a mess with dependency analysis; e.g., core2stg may heave in+    -- random calls to GHCbase.unpackPS__.  If GHCbase is the module+    -- being compiled, then it's just a matter of luck if the definition+    -- will be in "the right place" to be in scope.
+ basicTypes/MkId.hs-boot view
@@ -0,0 +1,15 @@+module MkId where+import Name( Name )+import Var( Id )+import Class( Class )+import {-# SOURCE #-} DataCon( DataCon )+import {-# SOURCE #-} PrimOp( PrimOp )++data DataConBoxer++mkDataConWorkId :: Name -> DataCon -> Id+mkDictSelId     :: Name -> Class   -> Id++mkPrimOpId      :: PrimOp -> Id++magicDictId :: Id
+ basicTypes/Module.hs view
@@ -0,0 +1,1275 @@+{-+(c) The University of Glasgow, 2004-2006+++Module+~~~~~~~~~~+Simply the name of a module, represented as a FastString.+These are Uniquable, hence we can build Maps with Modules as+the keys.+-}++{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Module+    (+        -- * The ModuleName type+        ModuleName,+        pprModuleName,+        moduleNameFS,+        moduleNameString,+        moduleNameSlashes, moduleNameColons,+        moduleStableString,+        moduleFreeHoles,+        moduleIsDefinite,+        mkModuleName,+        mkModuleNameFS,+        stableModuleNameCmp,++        -- * The UnitId type+        ComponentId(..),+        UnitId(..),+        unitIdFS,+        unitIdKey,+        IndefUnitId(..),+        IndefModule(..),+        indefUnitIdToUnitId,+        indefModuleToModule,+        InstalledUnitId(..),+        toInstalledUnitId,+        ShHoleSubst,++        unitIdIsDefinite,+        unitIdString,+        unitIdFreeHoles,++        newUnitId,+        newIndefUnitId,+        newSimpleUnitId,+        hashUnitId,+        fsToUnitId,+        stringToUnitId,+        stableUnitIdCmp,++        -- * HOLE renaming+        renameHoleUnitId,+        renameHoleModule,+        renameHoleUnitId',+        renameHoleModule',++        -- * Generalization+        splitModuleInsts,+        splitUnitIdInsts,+        generalizeIndefUnitId,+        generalizeIndefModule,++        -- * Parsers+        parseModuleName,+        parseUnitId,+        parseComponentId,+        parseModuleId,+        parseModSubst,++        -- * Wired-in UnitIds+        -- $wired_in_packages+        primUnitId,+        integerUnitId,+        baseUnitId,+        rtsUnitId,+        thUnitId,+        dphSeqUnitId,+        dphParUnitId,+        mainUnitId,+        thisGhcUnitId,+        isHoleModule,+        interactiveUnitId, isInteractiveModule,+        wiredInUnitIds,++        -- * The Module type+        Module(Module),+        moduleUnitId, moduleName,+        pprModule,+        mkModule,+        mkHoleModule,+        stableModuleCmp,+        HasModule(..),+        ContainsModule(..),++        -- * Installed unit ids and modules+        InstalledModule(..),+        InstalledModuleEnv,+        installedModuleEq,+        installedUnitIdEq,+        installedUnitIdString,+        fsToInstalledUnitId,+        componentIdToInstalledUnitId,+        stringToInstalledUnitId,+        emptyInstalledModuleEnv,+        lookupInstalledModuleEnv,+        extendInstalledModuleEnv,+        filterInstalledModuleEnv,+        delInstalledModuleEnv,+        DefUnitId(..),++        -- * The ModuleLocation type+        ModLocation(..),+        addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn,++        -- * Module mappings+        ModuleEnv,+        elemModuleEnv, extendModuleEnv, extendModuleEnvList,+        extendModuleEnvList_C, plusModuleEnv_C,+        delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv,+        lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv,+        moduleEnvKeys, moduleEnvElts, moduleEnvToList,+        unitModuleEnv, isEmptyModuleEnv,+        extendModuleEnvWith, filterModuleEnv,++        -- * ModuleName mappings+        ModuleNameEnv, DModuleNameEnv,++        -- * Sets of Modules+        ModuleSet,+        emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet+    ) where++import Config+import Outputable+import Unique+import UniqFM+import UniqDFM+import UniqDSet+import FastString+import Binary+import Util+import Data.List+import Data.Ord+import GHC.PackageDb (BinaryStringRep(..), DbUnitIdModuleRep(..), DbModule(..), DbUnitId(..))++import qualified Data.ByteString as BS+import qualified Data.ByteString.Unsafe as BS+import qualified Data.ByteString.Char8 as BS.Char8+import System.IO.Unsafe+import Foreign.Ptr (castPtr)+import GHC.Fingerprint+import Encoding++import qualified Text.ParserCombinators.ReadP as Parse+import Text.ParserCombinators.ReadP (ReadP, (<++))+import Data.Char (isAlphaNum)+import Control.DeepSeq+import Data.Coerce+import Data.Data+import Data.Function+import Data.Map (Map)+import Data.Set (Set)+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified FiniteMap as Map+import System.FilePath++import {-# SOURCE #-} DynFlags (DynFlags)+import {-# SOURCE #-} Packages (componentIdString, improveUnitId, PackageConfigMap, getPackageConfigMap, displayInstalledUnitId)++-- Note [The identifier lexicon]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Unit IDs, installed package IDs, ABI hashes, package names,+-- versions, there are a *lot* of different identifiers for closely+-- related things.  What do they all mean? Here's what.  (See also+-- https://ghc.haskell.org/trac/ghc/wiki/Commentary/Packages/Concepts )+--+-- THE IMPORTANT ONES+--+-- ComponentId: An opaque identifier provided by Cabal, which should+-- uniquely identify such things as the package name, the package+-- version, the name of the component, the hash of the source code+-- tarball, the selected Cabal flags, GHC flags, direct dependencies of+-- the component.  These are very similar to InstalledPackageId, but+-- an 'InstalledPackageId' implies that it identifies a package, while+-- a package may install multiple components with different+-- 'ComponentId's.+--      - Same as Distribution.Package.ComponentId+--+-- UnitId/InstalledUnitId: A ComponentId + a mapping from hole names+-- (ModuleName) to Modules.  This is how the compiler identifies instantiated+-- components, and also is the main identifier by which GHC identifies things.+--      - When Backpack is not being used, UnitId = ComponentId.+--        this means a useful fiction for end-users is that there are+--        only ever ComponentIds, and some ComponentIds happen to have+--        more information (UnitIds).+--      - Same as Language.Haskell.TH.Syntax:PkgName, see+--          https://ghc.haskell.org/trac/ghc/ticket/10279+--      - The same as PackageKey in GHC 7.10 (we renamed it because+--        they don't necessarily identify packages anymore.)+--      - Same as -this-package-key/-package-name flags+--      - An InstalledUnitId corresponds to an actual package which+--        we have installed on disk.  It could be definite or indefinite,+--        but if it's indefinite, it has nothing instantiated (we+--        never install partially instantiated units.)+--+-- Module/InstalledModule: A UnitId/InstalledUnitId + ModuleName. This is how+-- the compiler identifies modules (e.g. a Name is a Module + OccName)+--      - Same as Language.Haskell.TH.Syntax:Module+--+-- THE LESS IMPORTANT ONES+--+-- PackageName: The "name" field in a Cabal file, something like "lens".+--      - Same as Distribution.Package.PackageName+--      - DIFFERENT FROM Language.Haskell.TH.Syntax:PkgName, see+--          https://ghc.haskell.org/trac/ghc/ticket/10279+--      - DIFFERENT FROM -package-name flag+--      - DIFFERENT FROM the 'name' field in an installed package+--        information.  This field could more accurately be described+--        as a munged package name: when it's for the main library+--        it is the same as the package name, but if it's an internal+--        library it's a munged combination of the package name and+--        the component name.+--+-- LEGACY ONES+--+-- InstalledPackageId: This is what we used to call ComponentId.+-- It's a still pretty useful concept for packages that have only+-- one library; in that case the logical InstalledPackageId =+-- ComponentId.  Also, the Cabal nix-local-build continues to+-- compute an InstalledPackageId which is then forcibly used+-- for all components in a package.  This means that if a dependency+-- from one component in a package changes, the InstalledPackageId+-- changes: you don't get as fine-grained dependency tracking,+-- but it means your builds are hermetic.  Eventually, Cabal will+-- deal completely in components and we can get rid of this.+--+-- PackageKey: This is what we used to call UnitId.  We ditched+-- "Package" from the name when we realized that you might want to+-- assign different "PackageKeys" to components from the same package.+-- (For a brief, non-released period of time, we also called these+-- UnitKeys).++{-+************************************************************************+*                                                                      *+\subsection{Module locations}+*                                                                      *+************************************************************************+-}++-- | Module Location+--+-- Where a module lives on the file system: the actual locations+-- of the .hs, .hi and .o files, if we have them+data ModLocation+   = ModLocation {+        ml_hs_file   :: Maybe FilePath,+                -- The source file, if we have one.  Package modules+                -- probably don't have source files.++        ml_hi_file   :: FilePath,+                -- Where the .hi file is, whether or not it exists+                -- yet.  Always of form foo.hi, even if there is an+                -- hi-boot file (we add the -boot suffix later)++        ml_obj_file  :: FilePath+                -- Where the .o file is, whether or not it exists yet.+                -- (might not exist either because the module hasn't+                -- been compiled yet, or because it is part of a+                -- package with a .a file)+  } deriving Show++instance Outputable ModLocation where+   ppr = text . show++{-+For a module in another package, the hs_file and obj_file+components of ModLocation are undefined.++The locations specified by a ModLocation may or may not+correspond to actual files yet: for example, even if the object+file doesn't exist, the ModLocation still contains the path to+where the object file will reside if/when it is created.+-}++addBootSuffix :: FilePath -> FilePath+-- ^ Add the @-boot@ suffix to .hs, .hi and .o files+addBootSuffix path = path ++ "-boot"++addBootSuffix_maybe :: Bool -> FilePath -> FilePath+-- ^ Add the @-boot@ suffix if the @Bool@ argument is @True@+addBootSuffix_maybe is_boot path+ | is_boot   = addBootSuffix path+ | otherwise = path++addBootSuffixLocn :: ModLocation -> ModLocation+-- ^ Add the @-boot@ suffix to all file paths associated with the module+addBootSuffixLocn locn+  = locn { ml_hs_file  = fmap addBootSuffix (ml_hs_file locn)+         , ml_hi_file  = addBootSuffix (ml_hi_file locn)+         , ml_obj_file = addBootSuffix (ml_obj_file locn) }++{-+************************************************************************+*                                                                      *+\subsection{The name of a module}+*                                                                      *+************************************************************************+-}++-- | A ModuleName is essentially a simple string, e.g. @Data.List@.+newtype ModuleName = ModuleName FastString++instance Uniquable ModuleName where+  getUnique (ModuleName nm) = getUnique nm++instance Eq ModuleName where+  nm1 == nm2 = getUnique nm1 == getUnique nm2++instance Ord ModuleName where+  nm1 `compare` nm2 = stableModuleNameCmp nm1 nm2++instance Outputable ModuleName where+  ppr = pprModuleName++instance Binary ModuleName where+  put_ bh (ModuleName fs) = put_ bh fs+  get bh = do fs <- get bh; return (ModuleName fs)++instance BinaryStringRep ModuleName where+  fromStringRep = mkModuleNameFS . mkFastStringByteString+  toStringRep   = fastStringToByteString . moduleNameFS++instance Data ModuleName where+  -- don't traverse?+  toConstr _   = abstractConstr "ModuleName"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "ModuleName"++instance NFData ModuleName where+  rnf x = x `seq` ()++stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering+-- ^ Compares module names lexically, rather than by their 'Unique's+stableModuleNameCmp n1 n2 = moduleNameFS n1 `compare` moduleNameFS n2++pprModuleName :: ModuleName -> SDoc+pprModuleName (ModuleName nm) =+    getPprStyle $ \ sty ->+    if codeStyle sty+        then ztext (zEncodeFS nm)+        else ftext nm++moduleNameFS :: ModuleName -> FastString+moduleNameFS (ModuleName mod) = mod++moduleNameString :: ModuleName -> String+moduleNameString (ModuleName mod) = unpackFS mod++-- | Get a string representation of a 'Module' that's unique and stable+-- across recompilations.+-- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal"+moduleStableString :: Module -> String+moduleStableString Module{..} =+  "$" ++ unitIdString moduleUnitId ++ "$" ++ moduleNameString moduleName++mkModuleName :: String -> ModuleName+mkModuleName s = ModuleName (mkFastString s)++mkModuleNameFS :: FastString -> ModuleName+mkModuleNameFS s = ModuleName s++-- |Returns the string version of the module name, with dots replaced by slashes.+--+moduleNameSlashes :: ModuleName -> String+moduleNameSlashes = dots_to_slashes . moduleNameString+  where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c)++-- |Returns the string version of the module name, with dots replaced by colons.+--+moduleNameColons :: ModuleName -> String+moduleNameColons = dots_to_colons . moduleNameString+  where dots_to_colons = map (\c -> if c == '.' then ':' else c)++{-+************************************************************************+*                                                                      *+\subsection{A fully qualified module}+*                                                                      *+************************************************************************+-}++-- | A Module is a pair of a 'UnitId' and a 'ModuleName'.+--+-- Module variables (i.e. @<H>@) which can be instantiated to a+-- specific module at some later point in time are represented+-- with 'moduleUnitId' set to 'holeUnitId' (this allows us to+-- avoid having to make 'moduleUnitId' a partial operation.)+--+data Module = Module {+   moduleUnitId :: !UnitId,  -- pkg-1.0+   moduleName :: !ModuleName  -- A.B.C+  }+  deriving (Eq, Ord)++-- | Calculate the free holes of a 'Module'.  If this set is non-empty,+-- this module was defined in an indefinite library that had required+-- signatures.+--+-- If a module has free holes, that means that substitutions can operate on it;+-- if it has no free holes, substituting over a module has no effect.+moduleFreeHoles :: Module -> UniqDSet ModuleName+moduleFreeHoles m+    | isHoleModule m = unitUniqDSet (moduleName m)+    | otherwise = unitIdFreeHoles (moduleUnitId m)++-- | A 'Module' is definite if it has no free holes.+moduleIsDefinite :: Module -> Bool+moduleIsDefinite = isEmptyUniqDSet . moduleFreeHoles++-- | Create a module variable at some 'ModuleName'.+-- See Note [Representation of module/name variables]+mkHoleModule :: ModuleName -> Module+mkHoleModule = mkModule holeUnitId++instance Uniquable Module where+  getUnique (Module p n) = getUnique (unitIdFS p `appendFS` moduleNameFS n)++instance Outputable Module where+  ppr = pprModule++instance Binary Module where+  put_ bh (Module p n) = put_ bh p >> put_ bh n+  get bh = do p <- get bh; n <- get bh; return (Module p n)++instance Data Module where+  -- don't traverse?+  toConstr _   = abstractConstr "Module"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "Module"++instance NFData Module where+  rnf x = x `seq` ()++-- | This gives a stable ordering, as opposed to the Ord instance which+-- gives an ordering based on the 'Unique's of the components, which may+-- not be stable from run to run of the compiler.+stableModuleCmp :: Module -> Module -> Ordering+stableModuleCmp (Module p1 n1) (Module p2 n2)+   = (p1 `stableUnitIdCmp`  p2) `thenCmp`+     (n1 `stableModuleNameCmp` n2)++mkModule :: UnitId -> ModuleName -> Module+mkModule = Module++pprModule :: Module -> SDoc+pprModule mod@(Module p n)  = getPprStyle doc+ where+  doc sty+    | codeStyle sty =+        (if p == mainUnitId+                then empty -- never qualify the main package in code+                else ztext (zEncodeFS (unitIdFS p)) <> char '_')+            <> pprModuleName n+    | qualModule sty mod =+        if isHoleModule mod+            then angleBrackets (pprModuleName n)+            else ppr (moduleUnitId mod) <> char ':' <> pprModuleName n+    | otherwise =+        pprModuleName n++class ContainsModule t where+    extractModule :: t -> Module++class HasModule m where+    getModule :: m Module++instance DbUnitIdModuleRep InstalledUnitId ComponentId UnitId ModuleName Module where+  fromDbModule (DbModule uid mod_name)  = mkModule uid mod_name+  fromDbModule (DbModuleVar mod_name)   = mkHoleModule mod_name+  fromDbUnitId (DbUnitId cid insts)     = newUnitId cid insts+  fromDbUnitId (DbInstalledUnitId iuid) = DefiniteUnitId (DefUnitId iuid)+  -- GHC never writes to the database, so it's not needed+  toDbModule = error "toDbModule: not implemented"+  toDbUnitId = error "toDbUnitId: not implemented"++{-+************************************************************************+*                                                                      *+\subsection{ComponentId}+*                                                                      *+************************************************************************+-}++-- | A 'ComponentId' consists of the package name, package version, component+-- ID, the transitive dependencies of the component, and other information to+-- uniquely identify the source code and build configuration of a component.+--+-- This used to be known as an 'InstalledPackageId', but a package can contain+-- multiple components and a 'ComponentId' uniquely identifies a component+-- within a package.  When a package only has one component, the 'ComponentId'+-- coincides with the 'InstalledPackageId'+newtype ComponentId        = ComponentId        FastString deriving (Eq, Ord)++instance BinaryStringRep ComponentId where+  fromStringRep = ComponentId . mkFastStringByteString+  toStringRep (ComponentId s) = fastStringToByteString s++instance Uniquable ComponentId where+  getUnique (ComponentId n) = getUnique n++instance Outputable ComponentId where+  ppr cid@(ComponentId fs) =+    getPprStyle $ \sty ->+    sdocWithDynFlags $ \dflags ->+      case componentIdString dflags cid of+        Just str | not (debugStyle sty) -> text str+        _ -> ftext fs++{-+************************************************************************+*                                                                      *+\subsection{UnitId}+*                                                                      *+************************************************************************+-}++-- | A unit identifier identifies a (possibly partially) instantiated+-- library.  It is primarily used as part of 'Module', which in turn+-- is used in 'Name', which is used to give names to entities when+-- typechecking.+--+-- There are two possible forms for a 'UnitId'.  It can be a+-- 'DefiniteUnitId', in which case we just have a string that uniquely+-- identifies some fully compiled, installed library we have on disk.+-- However, when we are typechecking a library with missing holes,+-- we may need to instantiate a library on the fly (in which case+-- we don't have any on-disk representation.)  In that case, you+-- have an 'IndefiniteUnitId', which explicitly records the+-- instantiation, so that we can substitute over it.+data UnitId+    = IndefiniteUnitId {-# UNPACK #-} !IndefUnitId+    |   DefiniteUnitId {-# UNPACK #-} !DefUnitId+    deriving (Typeable)++unitIdFS :: UnitId -> FastString+unitIdFS (IndefiniteUnitId x) = indefUnitIdFS x+unitIdFS (DefiniteUnitId (DefUnitId x)) = installedUnitIdFS x++unitIdKey :: UnitId -> Unique+unitIdKey (IndefiniteUnitId x) = indefUnitIdKey x+unitIdKey (DefiniteUnitId (DefUnitId x)) = installedUnitIdKey x++-- | A unit identifier which identifies an indefinite+-- library (with holes) that has been *on-the-fly* instantiated+-- with a substitution 'indefUnitIdInsts'.  In fact, an indefinite+-- unit identifier could have no holes, but we haven't gotten+-- around to compiling the actual library yet.+--+-- An indefinite unit identifier pretty-prints to something like+-- @p[H=<H>,A=aimpl:A>]@ (@p@ is the 'ComponentId', and the+-- brackets enclose the module substitution).+data IndefUnitId+    = IndefUnitId {+        -- | A private, uniquely identifying representation of+        -- a UnitId.  This string is completely private to GHC+        -- and is just used to get a unique; in particular, we don't use it for+        -- symbols (indefinite libraries are not compiled).+        indefUnitIdFS :: FastString,+        -- | Cached unique of 'unitIdFS'.+        indefUnitIdKey :: Unique,+        -- | The component identity of the indefinite library that+        -- is being instantiated.+        indefUnitIdComponentId :: !ComponentId,+        -- | The sorted (by 'ModuleName') instantiations of this library.+        indefUnitIdInsts :: ![(ModuleName, Module)],+        -- | A cache of the free module variables of 'unitIdInsts'.+        -- This lets us efficiently tell if a 'UnitId' has been+        -- fully instantiated (free module variables are empty)+        -- and whether or not a substitution can have any effect.+        indefUnitIdFreeHoles :: UniqDSet ModuleName+    } deriving (Typeable)++instance Eq IndefUnitId where+  u1 == u2 = indefUnitIdKey u1 == indefUnitIdKey u2++instance Ord IndefUnitId where+  u1 `compare` u2 = indefUnitIdFS u1 `compare` indefUnitIdFS u2++instance Binary IndefUnitId where+  put_ bh indef = do+    put_ bh (indefUnitIdComponentId indef)+    put_ bh (indefUnitIdInsts indef)+  get bh = do+    cid   <- get bh+    insts <- get bh+    let fs = hashUnitId cid insts+    return IndefUnitId {+            indefUnitIdComponentId = cid,+            indefUnitIdInsts = insts,+            indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),+            indefUnitIdFS = fs,+            indefUnitIdKey = getUnique fs+           }++-- | Create a new 'IndefUnitId' given an explicit module substitution.+newIndefUnitId :: ComponentId -> [(ModuleName, Module)] -> IndefUnitId+newIndefUnitId cid insts =+    IndefUnitId {+        indefUnitIdComponentId = cid,+        indefUnitIdInsts = sorted_insts,+        indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),+        indefUnitIdFS = fs,+        indefUnitIdKey = getUnique fs+    }+  where+     fs = hashUnitId cid sorted_insts+     sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts++-- | Injects an 'IndefUnitId' (indefinite library which+-- was on-the-fly instantiated) to a 'UnitId' (either+-- an indefinite or definite library).+indefUnitIdToUnitId :: DynFlags -> IndefUnitId -> UnitId+indefUnitIdToUnitId dflags iuid =+    -- NB: suppose that we want to compare the indefinite+    -- unit id p[H=impl:H] against p+abcd (where p+abcd+    -- happens to be the existing, installed version of+    -- p[H=impl:H].  If we *only* wrap in p[H=impl:H]+    -- IndefiniteUnitId, they won't compare equal; only+    -- after improvement will the equality hold.+    improveUnitId (getPackageConfigMap dflags) $+        IndefiniteUnitId iuid++data IndefModule = IndefModule {+        indefModuleUnitId :: IndefUnitId,+        indefModuleName   :: ModuleName+    } deriving (Typeable, Eq, Ord)++instance Outputable IndefModule where+  ppr (IndefModule uid m) =+    ppr uid <> char ':' <> ppr m++-- | Injects an 'IndefModule' to 'Module' (see also+-- 'indefUnitIdToUnitId'.+indefModuleToModule :: DynFlags -> IndefModule -> Module+indefModuleToModule dflags (IndefModule iuid mod_name) =+    mkModule (indefUnitIdToUnitId dflags iuid) mod_name++-- | An installed unit identifier identifies a library which has+-- been installed to the package database.  These strings are+-- provided to us via the @-this-unit-id@ flag.  The library+-- in question may be definite or indefinite; if it is indefinite,+-- none of the holes have been filled (we never install partially+-- instantiated libraries.)  Put another way, an installed unit id+-- is either fully instantiated, or not instantiated at all.+--+-- Installed unit identifiers look something like @p+af23SAj2dZ219@,+-- or maybe just @p@ if they don't use Backpack.+newtype InstalledUnitId =+    InstalledUnitId {+      -- | The full hashed unit identifier, including the component id+      -- and the hash.+      installedUnitIdFS :: FastString+    }+   deriving (Typeable)++instance Binary InstalledUnitId where+  put_ bh (InstalledUnitId fs) = put_ bh fs+  get bh = do fs <- get bh; return (InstalledUnitId fs)++instance BinaryStringRep InstalledUnitId where+  fromStringRep bs = InstalledUnitId (mkFastStringByteString bs)+  -- GHC doesn't write to database+  toStringRep   = error "BinaryStringRep InstalledUnitId: not implemented"++instance Eq InstalledUnitId where+    uid1 == uid2 = installedUnitIdKey uid1 == installedUnitIdKey uid2++instance Ord InstalledUnitId where+    u1 `compare` u2 = installedUnitIdFS u1 `compare` installedUnitIdFS u2++instance Uniquable InstalledUnitId where+    getUnique = installedUnitIdKey++instance Outputable InstalledUnitId where+    ppr uid@(InstalledUnitId fs) =+        getPprStyle $ \sty ->+        sdocWithDynFlags $ \dflags ->+          case displayInstalledUnitId dflags uid of+            Just str | not (debugStyle sty) -> text str+            _ -> ftext fs++installedUnitIdKey :: InstalledUnitId -> Unique+installedUnitIdKey = getUnique . installedUnitIdFS++-- | Lossy conversion to the on-disk 'InstalledUnitId' for a component.+toInstalledUnitId :: UnitId -> InstalledUnitId+toInstalledUnitId (DefiniteUnitId (DefUnitId iuid)) = iuid+toInstalledUnitId (IndefiniteUnitId indef) =+    componentIdToInstalledUnitId (indefUnitIdComponentId indef)++installedUnitIdString :: InstalledUnitId -> String+installedUnitIdString = unpackFS . installedUnitIdFS++instance Outputable IndefUnitId where+    ppr uid =+      -- getPprStyle $ \sty ->+      ppr cid <>+        (if not (null insts) -- pprIf+          then+            brackets (hcat+                (punctuate comma $+                    [ ppr modname <> text "=" <> ppr m+                    | (modname, m) <- insts]))+          else empty)+     where+      cid   = indefUnitIdComponentId uid+      insts = indefUnitIdInsts uid++-- | A 'InstalledModule' is a 'Module' which contains a 'InstalledUnitId'.+data InstalledModule = InstalledModule {+   installedModuleUnitId :: !InstalledUnitId,+   installedModuleName :: !ModuleName+  }+  deriving (Eq, Ord)++instance Outputable InstalledModule where+  ppr (InstalledModule p n) =+    ppr p <> char ':' <> pprModuleName n++fsToInstalledUnitId :: FastString -> InstalledUnitId+fsToInstalledUnitId fs = InstalledUnitId fs++componentIdToInstalledUnitId :: ComponentId -> InstalledUnitId+componentIdToInstalledUnitId (ComponentId fs) = fsToInstalledUnitId fs++stringToInstalledUnitId :: String -> InstalledUnitId+stringToInstalledUnitId = fsToInstalledUnitId . mkFastString++-- | Test if a 'Module' corresponds to a given 'InstalledModule',+-- modulo instantiation.+installedModuleEq :: InstalledModule -> Module -> Bool+installedModuleEq imod mod =+    fst (splitModuleInsts mod) == imod++-- | Test if a 'UnitId' corresponds to a given 'InstalledUnitId',+-- modulo instantiation.+installedUnitIdEq :: InstalledUnitId -> UnitId -> Bool+installedUnitIdEq iuid uid =+    fst (splitUnitIdInsts uid) == iuid++-- | A 'DefUnitId' is an 'InstalledUnitId' with the invariant that+-- it only refers to a definite library; i.e., one we have generated+-- code for.+newtype DefUnitId = DefUnitId { unDefUnitId :: InstalledUnitId }+    deriving (Eq, Ord, Typeable)++instance Outputable DefUnitId where+    ppr (DefUnitId uid) = ppr uid++instance Binary DefUnitId where+    put_ bh (DefUnitId uid) = put_ bh uid+    get bh = do uid <- get bh; return (DefUnitId uid)++-- | A map keyed off of 'InstalledModule'+newtype InstalledModuleEnv elt = InstalledModuleEnv (Map InstalledModule elt)++emptyInstalledModuleEnv :: InstalledModuleEnv a+emptyInstalledModuleEnv = InstalledModuleEnv Map.empty++lookupInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> Maybe a+lookupInstalledModuleEnv (InstalledModuleEnv e) m = Map.lookup m e++extendInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> a -> InstalledModuleEnv a+extendInstalledModuleEnv (InstalledModuleEnv e) m x = InstalledModuleEnv (Map.insert m x e)++filterInstalledModuleEnv :: (InstalledModule -> a -> Bool) -> InstalledModuleEnv a -> InstalledModuleEnv a+filterInstalledModuleEnv f (InstalledModuleEnv e) =+  InstalledModuleEnv (Map.filterWithKey f e)++delInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> InstalledModuleEnv a+delInstalledModuleEnv (InstalledModuleEnv e) m = InstalledModuleEnv (Map.delete m e)++-- Note [UnitId to InstalledUnitId improvement]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Just because a UnitId is definite (has no holes) doesn't+-- mean it's necessarily a InstalledUnitId; it could just be+-- that over the course of renaming UnitIds on the fly+-- while typechecking an indefinite library, we+-- ended up with a fully instantiated unit id with no hash,+-- since we haven't built it yet.  This is fine.+--+-- However, if there is a hashed unit id for this instantiation+-- in the package database, we *better use it*, because+-- that hashed unit id may be lurking in another interface,+-- and chaos will ensue if we attempt to compare the two+-- (the unitIdFS for a UnitId never corresponds to a Cabal-provided+-- hash of a compiled instantiated library).+--+-- There is one last niggle: improvement based on the package database means+-- that we might end up developing on a package that is not transitively+-- depended upon by the packages the user specified directly via command line+-- flags.  This could lead to strange and difficult to understand bugs if those+-- instantiations are out of date.  The solution is to only improve a+-- unit id if the new unit id is part of the 'preloadClosure'; i.e., the+-- closure of all the packages which were explicitly specified.++-- | Retrieve the set of free holes of a 'UnitId'.+unitIdFreeHoles :: UnitId -> UniqDSet ModuleName+unitIdFreeHoles (IndefiniteUnitId x) = indefUnitIdFreeHoles x+-- Hashed unit ids are always fully instantiated+unitIdFreeHoles (DefiniteUnitId _) = emptyUniqDSet++instance Show UnitId where+    show = unitIdString++-- | A 'UnitId' is definite if it has no free holes.+unitIdIsDefinite :: UnitId -> Bool+unitIdIsDefinite = isEmptyUniqDSet . unitIdFreeHoles++-- | Generate a uniquely identifying 'FastString' for a unit+-- identifier.  This is a one-way function.  You can rely on one special+-- property: if a unit identifier is in most general form, its 'FastString'+-- coincides with its 'ComponentId'.  This hash is completely internal+-- to GHC and is not used for symbol names or file paths.+hashUnitId :: ComponentId -> [(ModuleName, Module)] -> FastString+hashUnitId cid sorted_holes =+    mkFastStringByteString+  . fingerprintUnitId (toStringRep cid)+  $ rawHashUnitId sorted_holes++-- | Generate a hash for a sorted module substitution.+rawHashUnitId :: [(ModuleName, Module)] -> Fingerprint+rawHashUnitId sorted_holes =+    fingerprintByteString+  . BS.concat $ do+        (m, b) <- sorted_holes+        [ toStringRep m,                BS.Char8.singleton ' ',+          fastStringToByteString (unitIdFS (moduleUnitId b)), BS.Char8.singleton ':',+          toStringRep (moduleName b),   BS.Char8.singleton '\n']++fingerprintByteString :: BS.ByteString -> Fingerprint+fingerprintByteString bs = unsafePerformIO+                         . BS.unsafeUseAsCStringLen bs+                         $ \(p,l) -> fingerprintData (castPtr p) l++fingerprintUnitId :: BS.ByteString -> Fingerprint -> BS.ByteString+fingerprintUnitId prefix (Fingerprint a b)+    = BS.concat+    $ [ prefix+      , BS.Char8.singleton '-'+      , BS.Char8.pack (toBase62Padded a)+      , BS.Char8.pack (toBase62Padded b) ]++-- | Create a new, un-hashed unit identifier.+newUnitId :: ComponentId -> [(ModuleName, Module)] -> UnitId+newUnitId cid [] = newSimpleUnitId cid -- TODO: this indicates some latent bug...+newUnitId cid insts = IndefiniteUnitId $ newIndefUnitId cid insts++pprUnitId :: UnitId -> SDoc+pprUnitId (DefiniteUnitId uid) = ppr uid+pprUnitId (IndefiniteUnitId uid) = ppr uid++instance Eq UnitId where+  uid1 == uid2 = unitIdKey uid1 == unitIdKey uid2++instance Uniquable UnitId where+  getUnique = unitIdKey++instance Ord UnitId where+  nm1 `compare` nm2 = stableUnitIdCmp nm1 nm2++instance Data UnitId where+  -- don't traverse?+  toConstr _   = abstractConstr "UnitId"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "UnitId"++instance NFData UnitId where+  rnf x = x `seq` ()++stableUnitIdCmp :: UnitId -> UnitId -> Ordering+-- ^ Compares package ids lexically, rather than by their 'Unique's+stableUnitIdCmp p1 p2 = unitIdFS p1 `compare` unitIdFS p2++instance Outputable UnitId where+   ppr pk = pprUnitId pk++-- Performance: would prefer to have a NameCache like thing+instance Binary UnitId where+  put_ bh (DefiniteUnitId def_uid) = do+    putByte bh 0+    put_ bh def_uid+  put_ bh (IndefiniteUnitId indef_uid) = do+    putByte bh 1+    put_ bh indef_uid+  get bh = do b <- getByte bh+              case b of+                0 -> fmap DefiniteUnitId   (get bh)+                _ -> fmap IndefiniteUnitId (get bh)++instance Binary ComponentId where+  put_ bh (ComponentId fs) = put_ bh fs+  get bh = do { fs <- get bh; return (ComponentId fs) }++-- | Create a new simple unit identifier (no holes) from a 'ComponentId'.+newSimpleUnitId :: ComponentId -> UnitId+newSimpleUnitId (ComponentId fs) = fsToUnitId fs++-- | Create a new simple unit identifier from a 'FastString'.  Internally,+-- this is primarily used to specify wired-in unit identifiers.+fsToUnitId :: FastString -> UnitId+fsToUnitId = DefiniteUnitId . DefUnitId . InstalledUnitId++stringToUnitId :: String -> UnitId+stringToUnitId = fsToUnitId . mkFastString++unitIdString :: UnitId -> String+unitIdString = unpackFS . unitIdFS++{-+************************************************************************+*                                                                      *+                        Hole substitutions+*                                                                      *+************************************************************************+-}++-- | Substitution on module variables, mapping module names to module+-- identifiers.+type ShHoleSubst = ModuleNameEnv Module++-- | Substitutes holes in a 'Module'.  NOT suitable for being called+-- directly on a 'nameModule', see Note [Representation of module/name variable].+-- @p[A=<A>]:B@ maps to @p[A=q():A]:B@ with @A=q():A@;+-- similarly, @<A>@ maps to @q():A@.+renameHoleModule :: DynFlags -> ShHoleSubst -> Module -> Module+renameHoleModule dflags = renameHoleModule' (getPackageConfigMap dflags)++-- | Substitutes holes in a 'UnitId', suitable for renaming when+-- an include occurs; see Note [Representation of module/name variable].+--+-- @p[A=<A>]@ maps to @p[A=<B>]@ with @A=<B>@.+renameHoleUnitId :: DynFlags -> ShHoleSubst -> UnitId -> UnitId+renameHoleUnitId dflags = renameHoleUnitId' (getPackageConfigMap dflags)++-- | Like 'renameHoleModule', but requires only 'PackageConfigMap'+-- so it can be used by "Packages".+renameHoleModule' :: PackageConfigMap -> ShHoleSubst -> Module -> Module+renameHoleModule' pkg_map env m+  | not (isHoleModule m) =+        let uid = renameHoleUnitId' pkg_map env (moduleUnitId m)+        in mkModule uid (moduleName m)+  | Just m' <- lookupUFM env (moduleName m) = m'+  -- NB m = <Blah>, that's what's in scope.+  | otherwise = m++-- | Like 'renameHoleUnitId, but requires only 'PackageConfigMap'+-- so it can be used by "Packages".+renameHoleUnitId' :: PackageConfigMap -> ShHoleSubst -> UnitId -> UnitId+renameHoleUnitId' pkg_map env uid =+    case uid of+      (IndefiniteUnitId+        IndefUnitId{ indefUnitIdComponentId = cid+                   , indefUnitIdInsts       = insts+                   , indefUnitIdFreeHoles   = fh })+          -> if isNullUFM (intersectUFM_C const (udfmToUfm fh) env)+                then uid+                -- Functorially apply the substitution to the instantiation,+                -- then check the 'PackageConfigMap' to see if there is+                -- a compiled version of this 'UnitId' we can improve to.+                -- See Note [UnitId to InstalledUnitId] improvement+                else improveUnitId pkg_map $+                        newUnitId cid+                            (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts)+      _ -> uid++-- | Given a possibly on-the-fly instantiated module, split it into+-- a 'Module' that we definitely can find on-disk, as well as an+-- instantiation if we need to instantiate it on the fly.  If the+-- instantiation is @Nothing@ no on-the-fly renaming is needed.+splitModuleInsts :: Module -> (InstalledModule, Maybe IndefModule)+splitModuleInsts m =+    let (uid, mb_iuid) = splitUnitIdInsts (moduleUnitId m)+    in (InstalledModule uid (moduleName m),+        fmap (\iuid -> IndefModule iuid (moduleName m)) mb_iuid)++-- | See 'splitModuleInsts'.+splitUnitIdInsts :: UnitId -> (InstalledUnitId, Maybe IndefUnitId)+splitUnitIdInsts (IndefiniteUnitId iuid) =+    (componentIdToInstalledUnitId (indefUnitIdComponentId iuid), Just iuid)+splitUnitIdInsts (DefiniteUnitId (DefUnitId uid)) = (uid, Nothing)++generalizeIndefUnitId :: IndefUnitId -> IndefUnitId+generalizeIndefUnitId IndefUnitId{ indefUnitIdComponentId = cid+                                 , indefUnitIdInsts = insts } =+    newIndefUnitId cid (map (\(m,_) -> (m, mkHoleModule m)) insts)++generalizeIndefModule :: IndefModule -> IndefModule+generalizeIndefModule (IndefModule uid n) = IndefModule (generalizeIndefUnitId uid) n++parseModuleName :: ReadP ModuleName+parseModuleName = fmap mkModuleName+                $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.")++parseUnitId :: ReadP UnitId+parseUnitId = parseFullUnitId <++ parseDefiniteUnitId <++ parseSimpleUnitId+  where+    parseFullUnitId = do+        cid <- parseComponentId+        insts <- parseModSubst+        return (newUnitId cid insts)+    parseDefiniteUnitId = do+        s <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+")+        return (stringToUnitId s)+    parseSimpleUnitId = do+        cid <- parseComponentId+        return (newSimpleUnitId cid)++parseComponentId :: ReadP ComponentId+parseComponentId = (ComponentId . mkFastString)  `fmap` Parse.munch1 abi_char+   where abi_char c = isAlphaNum c || c `elem` "-_."++parseModuleId :: ReadP Module+parseModuleId = parseModuleVar <++ parseModule+    where+      parseModuleVar = do+        _ <- Parse.char '<'+        modname <- parseModuleName+        _ <- Parse.char '>'+        return (mkHoleModule modname)+      parseModule = do+        uid <- parseUnitId+        _ <- Parse.char ':'+        modname <- parseModuleName+        return (mkModule uid modname)++parseModSubst :: ReadP [(ModuleName, Module)]+parseModSubst = Parse.between (Parse.char '[') (Parse.char ']')+      . flip Parse.sepBy (Parse.char ',')+      $ do k <- parseModuleName+           _ <- Parse.char '='+           v <- parseModuleId+           return (k, v)+++-- -----------------------------------------------------------------------------+-- $wired_in_packages+-- Certain packages are known to the compiler, in that we know about certain+-- entities that reside in these packages, and the compiler needs to+-- declare static Modules and Names that refer to these packages.  Hence+-- the wired-in packages can't include version numbers, since we don't want+-- to bake the version numbers of these packages into GHC.+--+-- So here's the plan.  Wired-in packages are still versioned as+-- normal in the packages database, and you can still have multiple+-- versions of them installed.  However, for each invocation of GHC,+-- only a single instance of each wired-in package will be recognised+-- (the desired one is selected via @-package@\/@-hide-package@), and GHC+-- will use the unversioned 'UnitId' below when referring to it,+-- including in .hi files and object file symbols.  Unselected+-- versions of wired-in packages will be ignored, as will any other+-- package that depends directly or indirectly on it (much as if you+-- had used @-ignore-package@).++-- Make sure you change 'Packages.findWiredInPackages' if you add an entry here++integerUnitId, primUnitId,+  baseUnitId, rtsUnitId,+  thUnitId, dphSeqUnitId, dphParUnitId,+  mainUnitId, thisGhcUnitId, interactiveUnitId  :: UnitId+primUnitId        = fsToUnitId (fsLit "ghc-prim")+integerUnitId     = fsToUnitId (fsLit n)+  where+    n = case cIntegerLibraryType of+        IntegerGMP    -> "integer-gmp"+        IntegerSimple -> "integer-simple"+baseUnitId        = fsToUnitId (fsLit "base")+rtsUnitId         = fsToUnitId (fsLit "rts")+thUnitId          = fsToUnitId (fsLit "template-haskell")+dphSeqUnitId      = fsToUnitId (fsLit "dph-seq")+dphParUnitId      = fsToUnitId (fsLit "dph-par")+thisGhcUnitId     = fsToUnitId (fsLit "ghc")+interactiveUnitId = fsToUnitId (fsLit "interactive")++-- | This is the package Id for the current program.  It is the default+-- package Id if you don't specify a package name.  We don't add this prefix+-- to symbol names, since there can be only one main package per program.+mainUnitId      = fsToUnitId (fsLit "main")++-- | This is a fake package id used to provide identities to any un-implemented+-- signatures.  The set of hole identities is global over an entire compilation.+-- Don't use this directly: use 'mkHoleModule' or 'isHoleModule' instead.+-- See Note [Representation of module/name variables]+holeUnitId :: UnitId+holeUnitId      = fsToUnitId (fsLit "hole")++isInteractiveModule :: Module -> Bool+isInteractiveModule mod = moduleUnitId mod == interactiveUnitId++-- Note [Representation of module/name variables]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- In our ICFP'16, we use <A> to represent module holes, and {A.T} to represent+-- name holes.  This could have been represented by adding some new cases+-- to the core data types, but this would have made the existing 'nameModule'+-- and 'moduleUnitId' partial, which would have required a lot of modifications+-- to existing code.+--+-- Instead, we adopted the following encoding scheme:+--+--      <A>   ===> hole:A+--      {A.T} ===> hole:A.T+--+-- This encoding is quite convenient, but it is also a bit dangerous too,+-- because if you have a 'hole:A' you need to know if it's actually a+-- 'Module' or just a module stored in a 'Name'; these two cases must be+-- treated differently when doing substitutions.  'renameHoleModule'+-- and 'renameHoleUnitId' assume they are NOT operating on a+-- 'Name'; 'NameShape' handles name substitutions exclusively.++isHoleModule :: Module -> Bool+isHoleModule mod = moduleUnitId mod == holeUnitId++wiredInUnitIds :: [UnitId]+wiredInUnitIds = [ primUnitId,+                       integerUnitId,+                       baseUnitId,+                       rtsUnitId,+                       thUnitId,+                       thisGhcUnitId,+                       dphSeqUnitId,+                       dphParUnitId ]++{-+************************************************************************+*                                                                      *+\subsection{@ModuleEnv@s}+*                                                                      *+************************************************************************+-}++-- | A map keyed off of 'Module's+newtype ModuleEnv elt = ModuleEnv (Map NDModule elt)++{-+Note [ModuleEnv performance and determinism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To prevent accidental reintroduction of nondeterminism the Ord instance+for Module was changed to not depend on Unique ordering and to use the+lexicographic order. This is potentially expensive, but when measured+there was no difference in performance.++To be on the safe side and not pessimize ModuleEnv uses nondeterministic+ordering on Module and normalizes by doing the lexicographic sort when+turning the env to a list.+See Note [Unique Determinism] for more information about the source of+nondeterminismand and Note [Deterministic UniqFM] for explanation of why+it matters for maps.+-}++newtype NDModule = NDModule { unNDModule :: Module }+  deriving Eq+  -- A wrapper for Module with faster nondeterministic Ord.+  -- Don't export, See [ModuleEnv performance and determinism]++instance Ord NDModule where+  compare (NDModule (Module p1 n1)) (NDModule (Module p2 n2)) =+    (getUnique p1 `nonDetCmpUnique` getUnique p2) `thenCmp`+    (getUnique n1 `nonDetCmpUnique` getUnique n2)++filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a+filterModuleEnv f (ModuleEnv e) =+  ModuleEnv (Map.filterWithKey (f . unNDModule) e)++elemModuleEnv :: Module -> ModuleEnv a -> Bool+elemModuleEnv m (ModuleEnv e) = Map.member (NDModule m) e++extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a+extendModuleEnv (ModuleEnv e) m x = ModuleEnv (Map.insert (NDModule m) x e)++extendModuleEnvWith :: (a -> a -> a) -> ModuleEnv a -> Module -> a+                    -> ModuleEnv a+extendModuleEnvWith f (ModuleEnv e) m x =+  ModuleEnv (Map.insertWith f (NDModule m) x e)++extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a+extendModuleEnvList (ModuleEnv e) xs =+  ModuleEnv (Map.insertList [(NDModule k, v) | (k,v) <- xs] e)++extendModuleEnvList_C :: (a -> a -> a) -> ModuleEnv a -> [(Module, a)]+                      -> ModuleEnv a+extendModuleEnvList_C f (ModuleEnv e) xs =+  ModuleEnv (Map.insertListWith f [(NDModule k, v) | (k,v) <- xs] e)++plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a+plusModuleEnv_C f (ModuleEnv e1) (ModuleEnv e2) =+  ModuleEnv (Map.unionWith f e1 e2)++delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a+delModuleEnvList (ModuleEnv e) ms =+  ModuleEnv (Map.deleteList (map NDModule ms) e)++delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a+delModuleEnv (ModuleEnv e) m = ModuleEnv (Map.delete (NDModule m) e)++plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a+plusModuleEnv (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.union e1 e2)++lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a+lookupModuleEnv (ModuleEnv e) m = Map.lookup (NDModule m) e++lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a+lookupWithDefaultModuleEnv (ModuleEnv e) x m =+  Map.findWithDefault x (NDModule m) e++mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b+mapModuleEnv f (ModuleEnv e) = ModuleEnv (Map.mapWithKey (\_ v -> f v) e)++mkModuleEnv :: [(Module, a)] -> ModuleEnv a+mkModuleEnv xs = ModuleEnv (Map.fromList [(NDModule k, v) | (k,v) <- xs])++emptyModuleEnv :: ModuleEnv a+emptyModuleEnv = ModuleEnv Map.empty++moduleEnvKeys :: ModuleEnv a -> [Module]+moduleEnvKeys (ModuleEnv e) = sort $ map unNDModule $ Map.keys e+  -- See Note [ModuleEnv performance and determinism]++moduleEnvElts :: ModuleEnv a -> [a]+moduleEnvElts e = map snd $ moduleEnvToList e+  -- See Note [ModuleEnv performance and determinism]++moduleEnvToList :: ModuleEnv a -> [(Module, a)]+moduleEnvToList (ModuleEnv e) =+  sortBy (comparing fst) [(m, v) | (NDModule m, v) <- Map.toList e]+  -- See Note [ModuleEnv performance and determinism]++unitModuleEnv :: Module -> a -> ModuleEnv a+unitModuleEnv m x = ModuleEnv (Map.singleton (NDModule m) x)++isEmptyModuleEnv :: ModuleEnv a -> Bool+isEmptyModuleEnv (ModuleEnv e) = Map.null e++-- | A set of 'Module's+type ModuleSet = Set NDModule++mkModuleSet     :: [Module] -> ModuleSet+extendModuleSet :: ModuleSet -> Module -> ModuleSet+emptyModuleSet  :: ModuleSet+moduleSetElts   :: ModuleSet -> [Module]+elemModuleSet   :: Module -> ModuleSet -> Bool++emptyModuleSet    = Set.empty+mkModuleSet       = Set.fromList . coerce+extendModuleSet s m = Set.insert (NDModule m) s+moduleSetElts     = sort . coerce . Set.toList+elemModuleSet     = Set.member . coerce++{-+A ModuleName has a Unique, so we can build mappings of these using+UniqFM.+-}++-- | A map keyed off of 'ModuleName's (actually, their 'Unique's)+type ModuleNameEnv elt = UniqFM elt+++-- | A map keyed off of 'ModuleName's (actually, their 'Unique's)+-- Has deterministic folds and can be deterministically converted to a list+type DModuleNameEnv elt = UniqDFM elt
+ basicTypes/Module.hs-boot view
@@ -0,0 +1,12 @@+module Module where+import FastString++data Module+data ModuleName+data UnitId+data InstalledUnitId+newtype ComponentId = ComponentId FastString++moduleName :: Module -> ModuleName+moduleUnitId :: Module -> UnitId+unitIdString :: UnitId -> String
+ basicTypes/Name.hs view
@@ -0,0 +1,710 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[Name]{@Name@: to transmit name info from renamer to typechecker}+-}++{-# LANGUAGE RecordWildCards #-}++-- |+-- #name_types#+-- GHC uses several kinds of name internally:+--+-- * 'OccName.OccName': see "OccName#name_types"+--+-- * 'RdrName.RdrName': see "RdrName#name_types"+--+-- *  'Name.Name' is the type of names that have had their scoping and binding resolved. They+--   have an 'OccName.OccName' but also a 'Unique.Unique' that disambiguates Names that have+--   the same 'OccName.OccName' and indeed is used for all 'Name.Name' comparison. Names+--   also contain information about where they originated from, see "Name#name_sorts"+--+-- * 'Id.Id': see "Id#name_types"+--+-- * 'Var.Var': see "Var#name_types"+--+-- #name_sorts#+-- Names are one of:+--+--  * External, if they name things declared in other modules. Some external+--    Names are wired in, i.e. they name primitives defined in the compiler itself+--+--  * Internal, if they name things in the module being compiled. Some internal+--    Names are system names, if they are names manufactured by the compiler++module Name (+        -- * The main types+        Name,                                   -- Abstract+        BuiltInSyntax(..),++        -- ** Creating 'Name's+        mkSystemName, mkSystemNameAt,+        mkInternalName, mkClonedInternalName, mkDerivedInternalName,+        mkSystemVarName, mkSysTvName,+        mkFCallName,+        mkExternalName, mkWiredInName,++        -- ** Manipulating and deconstructing 'Name's+        nameUnique, setNameUnique,+        nameOccName, nameModule, nameModule_maybe,+        setNameLoc,+        tidyNameOcc,+        localiseName,+        mkLocalisedOccName,++        nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt,++        -- ** Predicates on 'Name's+        isSystemName, isInternalName, isExternalName,+        isTyVarName, isTyConName, isDataConName,+        isValName, isVarName,+        isWiredInName, isBuiltInSyntax,+        isHoleName,+        wiredInNameTyThing_maybe,+        nameIsLocalOrFrom, nameIsHomePackage,+        nameIsHomePackageImport, nameIsFromExternalPackage,+        stableNameCmp,++        -- * Class 'NamedThing' and overloaded friends+        NamedThing(..),+        getSrcLoc, getSrcSpan, getOccString, getOccFS,++        pprInfixName, pprPrefixName, pprModulePrefix,+        nameStableString,++        -- Re-export the OccName stuff+        module OccName+    ) where++import {-# SOURCE #-} TyCoRep( TyThing )+import {-# SOURCE #-} PrelNames( starKindTyConKey, unicodeStarKindTyConKey )++import OccName+import Module+import SrcLoc+import Unique+import Util+import Maybes+import Binary+import DynFlags+import FastString+import Outputable++import Control.DeepSeq+import Data.Data++{-+************************************************************************+*                                                                      *+\subsection[Name-datatype]{The @Name@ datatype, and name construction}+*                                                                      *+************************************************************************+-}++-- | A unique, unambiguous name for something, containing information about where+-- that thing originated.+data Name = Name {+                n_sort :: NameSort,     -- What sort of name it is+                n_occ  :: !OccName,     -- Its occurrence name+                n_uniq :: {-# UNPACK #-} !Int,+                n_loc  :: !SrcSpan      -- Definition site+            }++-- NOTE: we make the n_loc field strict to eliminate some potential+-- (and real!) space leaks, due to the fact that we don't look at+-- the SrcLoc in a Name all that often.++data NameSort+  = External Module++  | WiredIn Module TyThing BuiltInSyntax+        -- A variant of External, for wired-in things++  | Internal            -- A user-defined Id or TyVar+                        -- defined in the module being compiled++  | System              -- A system-defined Id or TyVar.  Typically the+                        -- OccName is very uninformative (like 's')++instance Outputable NameSort where+  ppr (External _)    = text "external"+  ppr (WiredIn _ _ _) = text "wired-in"+  ppr  Internal       = text "internal"+  ppr  System         = text "system"++instance NFData Name where+  rnf Name{..} = rnf n_sort++instance NFData NameSort where+  rnf (External m) = rnf m+  rnf (WiredIn m t b) = rnf m `seq` t `seq` b `seq` ()+    -- XXX this is a *lie*, we're not going to rnf the TyThing, but+    -- since the TyThings for WiredIn Names are all static they can't+    -- be hiding space leaks or errors.+  rnf Internal = ()+  rnf System = ()++-- | BuiltInSyntax is for things like @(:)@, @[]@ and tuples,+-- which have special syntactic forms.  They aren't in scope+-- as such.+data BuiltInSyntax = BuiltInSyntax | UserSyntax++{-+Notes about the NameSorts:++1.  Initially, top-level Ids (including locally-defined ones) get External names,+    and all other local Ids get Internal names++2.  In any invocation of GHC, an External Name for "M.x" has one and only one+    unique.  This unique association is ensured via the Name Cache;+    see Note [The Name Cache] in IfaceEnv.++3.  Things with a External name are given C static labels, so they finally+    appear in the .o file's symbol table.  They appear in the symbol table+    in the form M.n.  If originally-local things have this property they+    must be made @External@ first.++4.  In the tidy-core phase, a External that is not visible to an importer+    is changed to Internal, and a Internal that is visible is changed to External++5.  A System Name differs in the following ways:+        a) has unique attached when printing dumps+        b) unifier eliminates sys tyvars in favour of user provs where possible++    Before anything gets printed in interface files or output code, it's+    fed through a 'tidy' processor, which zaps the OccNames to have+    unique names; and converts all sys-locals to user locals+    If any desugarer sys-locals have survived that far, they get changed to+    "ds1", "ds2", etc.++Built-in syntax => It's a syntactic form, not "in scope" (e.g. [])++Wired-in thing  => The thing (Id, TyCon) is fully known to the compiler,+                   not read from an interface file.+                   E.g. Bool, True, Int, Float, and many others++All built-in syntax is for wired-in things.+-}++instance HasOccName Name where+  occName = nameOccName++nameUnique              :: Name -> Unique+nameOccName             :: Name -> OccName+nameModule              :: Name -> Module+nameSrcLoc              :: Name -> SrcLoc+nameSrcSpan             :: Name -> SrcSpan++nameUnique  name = mkUniqueGrimily (n_uniq name)+nameOccName name = n_occ  name+nameSrcLoc  name = srcSpanStart (n_loc name)+nameSrcSpan name = n_loc  name++{-+************************************************************************+*                                                                      *+\subsection{Predicates on names}+*                                                                      *+************************************************************************+-}++isInternalName    :: Name -> Bool+isExternalName    :: Name -> Bool+isSystemName      :: Name -> Bool+isWiredInName     :: Name -> Bool++isWiredInName (Name {n_sort = WiredIn _ _ _}) = True+isWiredInName _                               = False++wiredInNameTyThing_maybe :: Name -> Maybe TyThing+wiredInNameTyThing_maybe (Name {n_sort = WiredIn _ thing _}) = Just thing+wiredInNameTyThing_maybe _                                   = Nothing++isBuiltInSyntax :: Name -> Bool+isBuiltInSyntax (Name {n_sort = WiredIn _ _ BuiltInSyntax}) = True+isBuiltInSyntax _                                           = False++isExternalName (Name {n_sort = External _})    = True+isExternalName (Name {n_sort = WiredIn _ _ _}) = True+isExternalName _                               = False++isInternalName name = not (isExternalName name)++isHoleName :: Name -> Bool+isHoleName = isHoleModule . nameModule++nameModule name =+  nameModule_maybe name `orElse`+  pprPanic "nameModule" (ppr (n_sort name) <+> ppr name)++nameModule_maybe :: Name -> Maybe Module+nameModule_maybe (Name { n_sort = External mod})    = Just mod+nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod+nameModule_maybe _                                  = Nothing++nameIsLocalOrFrom :: Module -> Name -> Bool+-- ^ Returns True if the name is+--   (a) Internal+--   (b) External but from the specified module+--   (c) External but from the 'interactive' package+--+-- The key idea is that+--    False means: the entity is defined in some other module+--                 you can find the details (type, fixity, instances)+--                     in some interface file+--                 those details will be stored in the EPT or HPT+--+--    True means:  the entity is defined in this module or earlier in+--                     the GHCi session+--                 you can find details (type, fixity, instances) in the+--                     TcGblEnv or TcLclEnv+--+-- The isInteractiveModule part is because successive interactions of a GCHi session+-- each give rise to a fresh module (Ghci1, Ghci2, etc), but they all come+-- from the magic 'interactive' package; and all the details are kept in the+-- TcLclEnv, TcGblEnv, NOT in the HPT or EPT.+-- See Note [The interactive package] in HscTypes++nameIsLocalOrFrom from name+  | Just mod <- nameModule_maybe name = from == mod || isInteractiveModule mod+  | otherwise                         = True++nameIsHomePackage :: Module -> Name -> Bool+-- True if the Name is defined in module of this package+nameIsHomePackage this_mod+  = \nm -> case n_sort nm of+              External nm_mod    -> moduleUnitId nm_mod == this_pkg+              WiredIn nm_mod _ _ -> moduleUnitId nm_mod == this_pkg+              Internal -> True+              System   -> False+  where+    this_pkg = moduleUnitId this_mod++nameIsHomePackageImport :: Module -> Name -> Bool+-- True if the Name is defined in module of this package+-- /other than/ the this_mod+nameIsHomePackageImport this_mod+  = \nm -> case nameModule_maybe nm of+              Nothing -> False+              Just nm_mod -> nm_mod /= this_mod+                          && moduleUnitId nm_mod == this_pkg+  where+    this_pkg = moduleUnitId this_mod++-- | Returns True if the Name comes from some other package: neither this+-- pacakge nor the interactive package.+nameIsFromExternalPackage :: UnitId -> Name -> Bool+nameIsFromExternalPackage this_pkg name+  | Just mod <- nameModule_maybe name+  , moduleUnitId mod /= this_pkg    -- Not this package+  , not (isInteractiveModule mod)       -- Not the 'interactive' package+  = True+  | otherwise+  = False++isTyVarName :: Name -> Bool+isTyVarName name = isTvOcc (nameOccName name)++isTyConName :: Name -> Bool+isTyConName name = isTcOcc (nameOccName name)++isDataConName :: Name -> Bool+isDataConName name = isDataOcc (nameOccName name)++isValName :: Name -> Bool+isValName name = isValOcc (nameOccName name)++isVarName :: Name -> Bool+isVarName = isVarOcc . nameOccName++isSystemName (Name {n_sort = System}) = True+isSystemName _                        = False++{-+************************************************************************+*                                                                      *+\subsection{Making names}+*                                                                      *+************************************************************************+-}++-- | Create a name which is (for now at least) local to the current module and hence+-- does not need a 'Module' to disambiguate it from other 'Name's+mkInternalName :: Unique -> OccName -> SrcSpan -> Name+mkInternalName uniq occ loc = Name { n_uniq = getKey uniq+                                   , n_sort = Internal+                                   , n_occ = occ+                                   , n_loc = loc }+        -- NB: You might worry that after lots of huffing and+        -- puffing we might end up with two local names with distinct+        -- uniques, but the same OccName.  Indeed we can, but that's ok+        --      * the insides of the compiler don't care: they use the Unique+        --      * when printing for -ddump-xxx you can switch on -dppr-debug to get the+        --        uniques if you get confused+        --      * for interface files we tidyCore first, which makes+        --        the OccNames distinct when they need to be++mkClonedInternalName :: Unique -> Name -> Name+mkClonedInternalName uniq (Name { n_occ = occ, n_loc = loc })+  = Name { n_uniq = getKey uniq, n_sort = Internal+         , n_occ = occ, n_loc = loc }++mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name+mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc })+  = Name { n_uniq = getKey uniq, n_sort = Internal+         , n_occ = derive_occ occ, n_loc = loc }++-- | Create a name which definitely originates in the given module+mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name+-- WATCH OUT! External Names should be in the Name Cache+-- (see Note [The Name Cache] in IfaceEnv), so don't just call mkExternalName+-- with some fresh unique without populating the Name Cache+mkExternalName uniq mod occ loc+  = Name { n_uniq = getKey uniq, n_sort = External mod,+           n_occ = occ, n_loc = loc }++-- | Create a name which is actually defined by the compiler itself+mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax -> Name+mkWiredInName mod occ uniq thing built_in+  = Name { n_uniq = getKey uniq,+           n_sort = WiredIn mod thing built_in,+           n_occ = occ, n_loc = wiredInSrcSpan }++-- | Create a name brought into being by the compiler+mkSystemName :: Unique -> OccName -> Name+mkSystemName uniq occ = mkSystemNameAt uniq occ noSrcSpan++mkSystemNameAt :: Unique -> OccName -> SrcSpan -> Name+mkSystemNameAt uniq occ loc = Name { n_uniq = getKey uniq, n_sort = System+                                   , n_occ = occ, n_loc = loc }++mkSystemVarName :: Unique -> FastString -> Name+mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs)++mkSysTvName :: Unique -> FastString -> Name+mkSysTvName uniq fs = mkSystemName uniq (mkOccNameFS tvName fs)++-- | Make a name for a foreign call+mkFCallName :: Unique -> String -> Name+mkFCallName uniq str = mkInternalName uniq (mkVarOcc str) noSrcSpan+   -- The encoded string completely describes the ccall++-- When we renumber/rename things, we need to be+-- able to change a Name's Unique to match the cached+-- one in the thing it's the name of.  If you know what I mean.+setNameUnique :: Name -> Unique -> Name+setNameUnique name uniq = name {n_uniq = getKey uniq}++-- This is used for hsigs: we want to use the name of the originally exported+-- entity, but edit the location to refer to the reexport site+setNameLoc :: Name -> SrcSpan -> Name+setNameLoc name loc = name {n_loc = loc}++tidyNameOcc :: Name -> OccName -> Name+-- We set the OccName of a Name when tidying+-- In doing so, we change System --> Internal, so that when we print+-- it we don't get the unique by default.  It's tidy now!+tidyNameOcc name@(Name { n_sort = System }) occ = name { n_occ = occ, n_sort = Internal}+tidyNameOcc name                            occ = name { n_occ = occ }++-- | Make the 'Name' into an internal name, regardless of what it was to begin with+localiseName :: Name -> Name+localiseName n = n { n_sort = Internal }++-- |Create a localised variant of a name.+--+-- If the name is external, encode the original's module name to disambiguate.+-- SPJ says: this looks like a rather odd-looking function; but it seems to+--           be used only during vectorisation, so I'm not going to worry+mkLocalisedOccName :: Module -> (Maybe String -> OccName -> OccName) -> Name -> OccName+mkLocalisedOccName this_mod mk_occ name = mk_occ origin (nameOccName name)+  where+    origin+      | nameIsLocalOrFrom this_mod name = Nothing+      | otherwise                       = Just (moduleNameColons . moduleName . nameModule $ name)++{-+************************************************************************+*                                                                      *+\subsection{Hashing and comparison}+*                                                                      *+************************************************************************+-}++cmpName :: Name -> Name -> Ordering+cmpName n1 n2 = n_uniq n1 `compare` n_uniq n2++-- | Compare Names lexicographically+-- This only works for Names that originate in the source code or have been+-- tidied.+stableNameCmp :: Name -> Name -> Ordering+stableNameCmp (Name { n_sort = s1, n_occ = occ1 })+              (Name { n_sort = s2, n_occ = occ2 })+  = (s1 `sort_cmp` s2) `thenCmp` (occ1 `compare` occ2)+    -- The ordinary compare on OccNames is lexicographic+  where+    -- Later constructors are bigger+    sort_cmp (External m1) (External m2)       = m1 `stableModuleCmp` m2+    sort_cmp (External {}) _                   = LT+    sort_cmp (WiredIn {}) (External {})        = GT+    sort_cmp (WiredIn m1 _ _) (WiredIn m2 _ _) = m1 `stableModuleCmp` m2+    sort_cmp (WiredIn {})     _                = LT+    sort_cmp Internal         (External {})    = GT+    sort_cmp Internal         (WiredIn {})     = GT+    sort_cmp Internal         Internal         = EQ+    sort_cmp Internal         System           = LT+    sort_cmp System           System           = EQ+    sort_cmp System           _                = GT++{-+************************************************************************+*                                                                      *+\subsection[Name-instances]{Instance declarations}+*                                                                      *+************************************************************************+-}++instance Eq Name where+    a == b = case (a `compare` b) of { EQ -> True;  _ -> False }+    a /= b = case (a `compare` b) of { EQ -> False; _ -> True }++instance Ord Name where+    a <= b = case (a `compare` b) of { LT -> True;  EQ -> True;  GT -> False }+    a <  b = case (a `compare` b) of { LT -> True;  EQ -> False; GT -> False }+    a >= b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }+    a >  b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }+    compare a b = cmpName a b++instance Uniquable Name where+    getUnique = nameUnique++instance NamedThing Name where+    getName n = n++instance Data Name where+  -- don't traverse?+  toConstr _   = abstractConstr "Name"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "Name"++{-+************************************************************************+*                                                                      *+\subsection{Binary}+*                                                                      *+************************************************************************+-}++-- | Assumes that the 'Name' is a non-binding one. See+-- 'IfaceSyn.putIfaceTopBndr' and 'IfaceSyn.getIfaceTopBndr' for serializing+-- binding 'Name's. See 'UserData' for the rationale for this distinction.+instance Binary Name where+   put_ bh name =+      case getUserData bh of+        UserData{ ud_put_nonbinding_name = put_name } -> put_name bh name++   get bh =+      case getUserData bh of+        UserData { ud_get_name = get_name } -> get_name bh++{-+************************************************************************+*                                                                      *+\subsection{Pretty printing}+*                                                                      *+************************************************************************+-}++instance Outputable Name where+    ppr name = pprName name++instance OutputableBndr Name where+    pprBndr _ name = pprName name+    pprInfixOcc  = pprInfixName+    pprPrefixOcc = pprPrefixName++pprName :: Name -> SDoc+pprName (Name {n_sort = sort, n_uniq = u, n_occ = occ})+  = getPprStyle $ \ sty ->+    case sort of+      WiredIn mod _ builtin   -> pprExternal sty uniq mod occ True  builtin+      External mod            -> pprExternal sty uniq mod occ False UserSyntax+      System                  -> pprSystem sty uniq occ+      Internal                -> pprInternal sty uniq occ+  where uniq = mkUniqueGrimily u++pprExternal :: PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc+pprExternal sty uniq mod occ is_wired is_builtin+  | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ+        -- In code style, always qualify+        -- ToDo: maybe we could print all wired-in things unqualified+        --       in code style, to reduce symbol table bloat?+  | debugStyle sty = pp_mod <> ppr_occ_name occ+                     <> braces (hsep [if is_wired then text "(w)" else empty,+                                      pprNameSpaceBrief (occNameSpace occ),+                                      pprUnique uniq])+  | BuiltInSyntax <- is_builtin = ppr_occ_name occ  -- Never qualify builtin syntax+  | otherwise                   =+        if isHoleModule mod+            then case qualName sty mod occ of+                    NameUnqual -> ppr_occ_name occ+                    _ -> braces (ppr (moduleName mod) <> dot <> ppr_occ_name occ)+            else pprModulePrefix sty mod occ <> ppr_occ_name occ+  where+    pp_mod = sdocWithDynFlags $ \dflags ->+             if gopt Opt_SuppressModulePrefixes dflags+             then empty+             else ppr mod <> dot++pprInternal :: PprStyle -> Unique -> OccName -> SDoc+pprInternal sty uniq occ+  | codeStyle sty  = pprUniqueAlways uniq+  | debugStyle sty = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ),+                                                       pprUnique uniq])+  | dumpStyle sty  = ppr_occ_name occ <> ppr_underscore_unique uniq+                        -- For debug dumps, we're not necessarily dumping+                        -- tidied code, so we need to print the uniques.+  | otherwise      = ppr_occ_name occ   -- User style++-- Like Internal, except that we only omit the unique in Iface style+pprSystem :: PprStyle -> Unique -> OccName -> SDoc+pprSystem sty uniq occ+  | codeStyle sty  = pprUniqueAlways uniq+  | debugStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq+                     <> braces (pprNameSpaceBrief (occNameSpace occ))+  | otherwise      = ppr_occ_name occ <> ppr_underscore_unique uniq+                                -- If the tidy phase hasn't run, the OccName+                                -- is unlikely to be informative (like 's'),+                                -- so print the unique+++pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc+-- Print the "M." part of a name, based on whether it's in scope or not+-- See Note [Printing original names] in HscTypes+pprModulePrefix sty mod occ = sdocWithDynFlags $ \dflags ->+  if gopt Opt_SuppressModulePrefixes dflags+  then empty+  else+    case qualName sty mod occ of              -- See Outputable.QualifyName:+      NameQual modname -> ppr modname <> dot       -- Name is in scope+      NameNotInScope1  -> ppr mod <> dot           -- Not in scope+      NameNotInScope2  -> ppr (moduleUnitId mod) <> colon     -- Module not in+                          <> ppr (moduleName mod) <> dot          -- scope either+      NameUnqual       -> empty                   -- In scope unqualified++pprUnique :: Unique -> SDoc+-- Print a unique unless we are suppressing them+pprUnique uniq+  = sdocWithDynFlags $ \dflags ->+    ppUnless (gopt Opt_SuppressUniques dflags) $+    pprUniqueAlways uniq++ppr_underscore_unique :: Unique -> SDoc+-- Print an underscore separating the name from its unique+-- But suppress it if we aren't printing the uniques anyway+ppr_underscore_unique uniq+  = sdocWithDynFlags $ \dflags ->+    ppUnless (gopt Opt_SuppressUniques dflags) $+    char '_' <> pprUniqueAlways uniq++ppr_occ_name :: OccName -> SDoc+ppr_occ_name occ = ftext (occNameFS occ)+        -- Don't use pprOccName; instead, just print the string of the OccName;+        -- we print the namespace in the debug stuff above++-- In code style, we Z-encode the strings.  The results of Z-encoding each FastString are+-- cached behind the scenes in the FastString implementation.+ppr_z_occ_name :: OccName -> SDoc+ppr_z_occ_name occ = ztext (zEncodeFS (occNameFS occ))++-- Prints (if mod information is available) "Defined at <loc>" or+--  "Defined in <mod>" information for a Name.+pprDefinedAt :: Name -> SDoc+pprDefinedAt name = text "Defined" <+> pprNameDefnLoc name++pprNameDefnLoc :: Name -> SDoc+-- Prints "at <loc>" or+--     or "in <mod>" depending on what info is available+pprNameDefnLoc name+  = case nameSrcLoc name of+         -- nameSrcLoc rather than nameSrcSpan+         -- It seems less cluttered to show a location+         -- rather than a span for the definition point+       RealSrcLoc s -> text "at" <+> ppr s+       UnhelpfulLoc s+         | isInternalName name || isSystemName name+         -> text "at" <+> ftext s+         | otherwise+         -> text "in" <+> quotes (ppr (nameModule name))+++-- | Get a string representation of a 'Name' that's unique and stable+-- across recompilations. Used for deterministic generation of binds for+-- derived instances.+-- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal$String"+nameStableString :: Name -> String+nameStableString Name{..} =+  nameSortStableString n_sort ++ "$" ++ occNameString n_occ++nameSortStableString :: NameSort -> String+nameSortStableString System = "$_sys"+nameSortStableString Internal = "$_in"+nameSortStableString (External mod) = moduleStableString mod+nameSortStableString (WiredIn mod _ _) = moduleStableString mod++{-+************************************************************************+*                                                                      *+\subsection{Overloaded functions related to Names}+*                                                                      *+************************************************************************+-}++-- | A class allowing convenient access to the 'Name' of various datatypes+class NamedThing a where+    getOccName :: a -> OccName+    getName    :: a -> Name++    getOccName n = nameOccName (getName n)      -- Default method++instance NamedThing e => NamedThing (GenLocated l e) where+    getName = getName . unLoc++getSrcLoc           :: NamedThing a => a -> SrcLoc+getSrcSpan          :: NamedThing a => a -> SrcSpan+getOccString        :: NamedThing a => a -> String+getOccFS            :: NamedThing a => a -> FastString++getSrcLoc           = nameSrcLoc           . getName+getSrcSpan          = nameSrcSpan          . getName+getOccString        = occNameString        . getOccName+getOccFS            = occNameFS            . getOccName++pprInfixName :: (Outputable a, NamedThing a) => a -> SDoc+-- See Outputable.pprPrefixVar, pprInfixVar;+-- add parens or back-quotes as appropriate+pprInfixName  n = pprInfixVar (isSymOcc (getOccName n)) (ppr n)++pprPrefixName :: NamedThing a => a -> SDoc+pprPrefixName thing+ | name `hasKey` starKindTyConKey || name `hasKey` unicodeStarKindTyConKey+ = ppr name   -- See Note [Special treatment for kind *]+ | otherwise+ = pprPrefixVar (isSymOcc (nameOccName name)) (ppr name)+ where+   name = getName thing++{-+Note [Special treatment for kind *]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Do not put parens around the kind '*'.  Even though it looks like+an operator, it is really a special case.++This pprPrefixName stuff is really only used when printing HsSyn,+which has to be polymorphic in the name type, and hence has to go via+the overloaded function pprPrefixOcc.  It's easier where we know the+type being pretty printed; eg the pretty-printing code in TyCoRep.++See Trac #7645, which led to this.+-}
+ basicTypes/Name.hs-boot view
@@ -0,0 +1,3 @@+module Name where++data Name
+ basicTypes/NameCache.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}++-- | The Name Cache+module NameCache+    ( lookupOrigNameCache+    , extendOrigNameCache+    , extendNameCache+    , initNameCache+    , NameCache(..), OrigNameCache+    ) where++import Module+import Name+import UniqSupply+import TysWiredIn+import Util+import Outputable+import PrelNames++#include "HsVersions.h"++{-++Note [The Name Cache]+~~~~~~~~~~~~~~~~~~~~~+The Name Cache makes sure that, during any invocation of GHC, each+External Name "M.x" has one, and only one globally-agreed Unique.++* The first time we come across M.x we make up a Unique and record that+  association in the Name Cache.++* When we come across "M.x" again, we look it up in the Name Cache,+  and get a hit.++The functions newGlobalBinder, allocateGlobalBinder do the main work.+When you make an External name, you should probably be calling one+of them.+++Note [Built-in syntax and the OrigNameCache]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Built-in syntax like tuples and unboxed sums are quite ubiquitous. To lower+their cost we use two tricks,++  a. We specially encode tuple and sum Names in interface files' symbol tables+     to avoid having to look up their names while loading interface files.+     Namely these names are encoded as by their Uniques. We know how to get from+     a Unique back to the Name which it represents via the mapping defined in+     the SumTupleUniques module. See Note [Symbol table representation of names]+     in BinIface and for details.++  b. We don't include them in the Orig name cache but instead parse their+     OccNames (in isBuiltInOcc_maybe) to avoid bloating the name cache with+     them.++Why is the second measure necessary? Good question; afterall, 1) the parser+emits built-in syntax directly as Exact RdrNames, and 2) built-in syntax never+needs to looked-up during interface loading due to (a). It turns out that there+are two reasons why we might look up an Orig RdrName for built-in syntax,++  * If you use setRdrNameSpace on an Exact RdrName it may be+    turned into an Orig RdrName.++  * Template Haskell turns a BuiltInSyntax Name into a TH.NameG+    (DsMeta.globalVar), and parses a NameG into an Orig RdrName+    (Convert.thRdrName).  So, e.g. $(do { reify '(,); ... }) will+    go this route (Trac #8954).++-}++-- | Per-module cache of original 'OccName's given 'Name's+type OrigNameCache   = ModuleEnv (OccEnv Name)++lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name+lookupOrigNameCache nc mod occ+  | mod == gHC_TYPES || mod == gHC_PRIM || mod == gHC_TUPLE+  , Just name <- isBuiltInOcc_maybe occ+  =     -- See Note [Known-key names], 3(c) in PrelNames+        -- Special case for tuples; there are too many+        -- of them to pre-populate the original-name cache+    Just name++  | otherwise+  = case lookupModuleEnv nc mod of+        Nothing      -> Nothing+        Just occ_env -> lookupOccEnv occ_env occ++extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache+extendOrigNameCache nc name+  = ASSERT2( isExternalName name, ppr name )+    extendNameCache nc (nameModule name) (nameOccName name) name++extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache+extendNameCache nc mod occ name+  = extendModuleEnvWith combine nc mod (unitOccEnv occ name)+  where+    combine _ occ_env = extendOccEnv occ_env occ name++-- | The NameCache makes sure that there is just one Unique assigned for+-- each original name; i.e. (module-name, occ-name) pair and provides+-- something of a lookup mechanism for those names.+data NameCache+ = NameCache {  nsUniqs :: !UniqSupply,+                -- ^ Supply of uniques+                nsNames :: !OrigNameCache+                -- ^ Ensures that one original name gets one unique+   }++-- | Return a function to atomically update the name cache.+initNameCache :: UniqSupply -> [Name] -> NameCache+initNameCache us names+  = NameCache { nsUniqs = us,+                nsNames = initOrigNames names }++initOrigNames :: [Name] -> OrigNameCache+initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
+ basicTypes/NameEnv.hs view
@@ -0,0 +1,151 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[NameEnv]{@NameEnv@: name environments}+-}++{-# LANGUAGE CPP #-}+module NameEnv (+        -- * Var, Id and TyVar environments (maps)+        NameEnv,++        -- ** Manipulating these environments+        mkNameEnv,+        emptyNameEnv, isEmptyNameEnv,+        unitNameEnv, nameEnvElts,+        extendNameEnv_C, extendNameEnv_Acc, extendNameEnv,+        extendNameEnvList, extendNameEnvList_C,+        filterNameEnv, anyNameEnv,+        plusNameEnv, plusNameEnv_C, alterNameEnv,+        lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv,+        elemNameEnv, mapNameEnv, disjointNameEnv,++        DNameEnv,++        emptyDNameEnv,+        lookupDNameEnv,+        mapDNameEnv,+        alterDNameEnv,+        -- ** Dependency analysis+        depAnal+    ) where++#include "HsVersions.h"++import Digraph+import Name+import UniqFM+import UniqDFM+import Maybes++{-+************************************************************************+*                                                                      *+\subsection{Name environment}+*                                                                      *+************************************************************************+-}++{-+Note [depAnal determinism]+~~~~~~~~~~~~~~~~~~~~~~~~~~+depAnal is deterministic provided it gets the nodes in a deterministic order.+The order of lists that get_defs and get_uses return doesn't matter, as these+are only used to construct the edges, and stronglyConnCompFromEdgedVertices is+deterministic even when the edges are not in deterministic order as explained+in Note [Deterministic SCC] in Digraph.+-}++depAnal :: (node -> [Name])      -- Defs+        -> (node -> [Name])      -- Uses+        -> [node]+        -> [SCC node]+-- Peform dependency analysis on a group of definitions,+-- where each definition may define more than one Name+--+-- The get_defs and get_uses functions are called only once per node+depAnal get_defs get_uses nodes+  = stronglyConnCompFromEdgedVerticesUniq (map mk_node keyed_nodes)+  where+    keyed_nodes = nodes `zip` [(1::Int)..]+    mk_node (node, key) = (node, key, mapMaybe (lookupNameEnv key_map) (get_uses node))++    key_map :: NameEnv Int   -- Maps a Name to the key of the decl that defines it+    key_map = mkNameEnv [(name,key) | (node, key) <- keyed_nodes, name <- get_defs node]++{-+************************************************************************+*                                                                      *+\subsection{Name environment}+*                                                                      *+************************************************************************+-}++-- | Name Environment+type NameEnv a = UniqFM a       -- Domain is Name++emptyNameEnv       :: NameEnv a+isEmptyNameEnv     :: NameEnv a -> Bool+mkNameEnv          :: [(Name,a)] -> NameEnv a+nameEnvElts        :: NameEnv a -> [a]+alterNameEnv       :: (Maybe a-> Maybe a) -> NameEnv a -> Name -> NameEnv a+extendNameEnv_C    :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a+extendNameEnv_Acc  :: (a->b->b) -> (a->b) -> NameEnv b -> Name -> a -> NameEnv b+extendNameEnv      :: NameEnv a -> Name -> a -> NameEnv a+plusNameEnv        :: NameEnv a -> NameEnv a -> NameEnv a+plusNameEnv_C      :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a+extendNameEnvList  :: NameEnv a -> [(Name,a)] -> NameEnv a+extendNameEnvList_C :: (a->a->a) -> NameEnv a -> [(Name,a)] -> NameEnv a+delFromNameEnv     :: NameEnv a -> Name -> NameEnv a+delListFromNameEnv :: NameEnv a -> [Name] -> NameEnv a+elemNameEnv        :: Name -> NameEnv a -> Bool+unitNameEnv        :: Name -> a -> NameEnv a+lookupNameEnv      :: NameEnv a -> Name -> Maybe a+lookupNameEnv_NF   :: NameEnv a -> Name -> a+filterNameEnv      :: (elt -> Bool) -> NameEnv elt -> NameEnv elt+anyNameEnv         :: (elt -> Bool) -> NameEnv elt -> Bool+mapNameEnv         :: (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2+disjointNameEnv    :: NameEnv a -> NameEnv a -> Bool++nameEnvElts x         = eltsUFM x+emptyNameEnv          = emptyUFM+isEmptyNameEnv        = isNullUFM+unitNameEnv x y       = unitUFM x y+extendNameEnv x y z   = addToUFM x y z+extendNameEnvList x l = addListToUFM x l+lookupNameEnv x y     = lookupUFM x y+alterNameEnv          = alterUFM+mkNameEnv     l       = listToUFM l+elemNameEnv x y          = elemUFM x y+plusNameEnv x y          = plusUFM x y+plusNameEnv_C f x y      = plusUFM_C f x y+extendNameEnv_C f x y z  = addToUFM_C f x y z+mapNameEnv f x           = mapUFM f x+extendNameEnv_Acc x y z a b  = addToUFM_Acc x y z a b+extendNameEnvList_C x y z = addListToUFM_C x y z+delFromNameEnv x y      = delFromUFM x y+delListFromNameEnv x y  = delListFromUFM x y+filterNameEnv x y       = filterUFM x y+anyNameEnv f x          = foldUFM ((||) . f) False x+disjointNameEnv x y     = isNullUFM (intersectUFM x y)++lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupNameEnv env n)++-- | Deterministic Name Environment+--+-- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need+-- DNameEnv.+type DNameEnv a = UniqDFM a++emptyDNameEnv :: DNameEnv a+emptyDNameEnv = emptyUDFM++lookupDNameEnv :: DNameEnv a -> Name -> Maybe a+lookupDNameEnv = lookupUDFM++mapDNameEnv :: (a -> b) -> DNameEnv a -> DNameEnv b+mapDNameEnv = mapUDFM++alterDNameEnv :: (Maybe a -> Maybe a) -> DNameEnv a -> Name -> DNameEnv a+alterDNameEnv = alterUDFM
+ basicTypes/NameSet.hs view
@@ -0,0 +1,212 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1998+-}++{-# LANGUAGE CPP #-}+module NameSet (+        -- * Names set type+        NameSet,++        -- ** Manipulating these sets+        emptyNameSet, unitNameSet, mkNameSet, unionNameSet, unionNameSets,+        minusNameSet, elemNameSet, extendNameSet, extendNameSetList,+        delFromNameSet, delListFromNameSet, isEmptyNameSet, filterNameSet,+        intersectsNameSet, intersectNameSet,+        nameSetAny, nameSetAll, nameSetElemsStable,++        -- * Free variables+        FreeVars,++        -- ** Manipulating sets of free variables+        isEmptyFVs, emptyFVs, plusFVs, plusFV,+        mkFVs, addOneFV, unitFV, delFV, delFVs,+        intersectFVs,++        -- * Defs and uses+        Defs, Uses, DefUse, DefUses,++        -- ** Manipulating defs and uses+        emptyDUs, usesOnly, mkDUs, plusDU,+        findUses, duDefs, duUses, allUses+    ) where++#include "HsVersions.h"++import Name+import UniqSet+import Data.List (sortBy)++{-+************************************************************************+*                                                                      *+\subsection[Sets of names}+*                                                                      *+************************************************************************+-}++type NameSet = UniqSet Name++emptyNameSet       :: NameSet+unitNameSet        :: Name -> NameSet+extendNameSetList   :: NameSet -> [Name] -> NameSet+extendNameSet    :: NameSet -> Name -> NameSet+mkNameSet          :: [Name] -> NameSet+unionNameSet      :: NameSet -> NameSet -> NameSet+unionNameSets  :: [NameSet] -> NameSet+minusNameSet       :: NameSet -> NameSet -> NameSet+elemNameSet        :: Name -> NameSet -> Bool+isEmptyNameSet     :: NameSet -> Bool+delFromNameSet     :: NameSet -> Name -> NameSet+delListFromNameSet :: NameSet -> [Name] -> NameSet+filterNameSet      :: (Name -> Bool) -> NameSet -> NameSet+intersectNameSet   :: NameSet -> NameSet -> NameSet+intersectsNameSet  :: NameSet -> NameSet -> Bool+-- ^ True if there is a non-empty intersection.+-- @s1 `intersectsNameSet` s2@ doesn't compute @s2@ if @s1@ is empty++isEmptyNameSet    = isEmptyUniqSet+emptyNameSet      = emptyUniqSet+unitNameSet       = unitUniqSet+mkNameSet         = mkUniqSet+extendNameSetList  = addListToUniqSet+extendNameSet   = addOneToUniqSet+unionNameSet     = unionUniqSets+unionNameSets = unionManyUniqSets+minusNameSet      = minusUniqSet+elemNameSet       = elementOfUniqSet+delFromNameSet    = delOneFromUniqSet+filterNameSet     = filterUniqSet+intersectNameSet  = intersectUniqSets++delListFromNameSet set ns = foldl delFromNameSet set ns++intersectsNameSet s1 s2 = not (isEmptyNameSet (s1 `intersectNameSet` s2))++nameSetAny :: (Name -> Bool) -> NameSet -> Bool+nameSetAny = uniqSetAny++nameSetAll :: (Name -> Bool) -> NameSet -> Bool+nameSetAll = uniqSetAll++-- | Get the elements of a NameSet with some stable ordering.+-- This only works for Names that originate in the source code or have been+-- tidied.+-- See Note [Deterministic UniqFM] to learn about nondeterminism+nameSetElemsStable :: NameSet -> [Name]+nameSetElemsStable ns =+  sortBy stableNameCmp $ nonDetEltsUniqSet ns+  -- It's OK to use nonDetEltsUniqSet here because we immediately sort+  -- with stableNameCmp++{-+************************************************************************+*                                                                      *+\subsection{Free variables}+*                                                                      *+************************************************************************++These synonyms are useful when we are thinking of free variables+-}++type FreeVars   = NameSet++plusFV   :: FreeVars -> FreeVars -> FreeVars+addOneFV :: FreeVars -> Name -> FreeVars+unitFV   :: Name -> FreeVars+emptyFVs :: FreeVars+plusFVs  :: [FreeVars] -> FreeVars+mkFVs    :: [Name] -> FreeVars+delFV    :: Name -> FreeVars -> FreeVars+delFVs   :: [Name] -> FreeVars -> FreeVars+intersectFVs :: FreeVars -> FreeVars -> FreeVars++isEmptyFVs :: NameSet -> Bool+isEmptyFVs  = isEmptyNameSet+emptyFVs    = emptyNameSet+plusFVs     = unionNameSets+plusFV      = unionNameSet+mkFVs       = mkNameSet+addOneFV    = extendNameSet+unitFV      = unitNameSet+delFV n s   = delFromNameSet s n+delFVs ns s = delListFromNameSet s ns+intersectFVs = intersectNameSet++{-+************************************************************************+*                                                                      *+                Defs and uses+*                                                                      *+************************************************************************+-}++-- | A set of names that are defined somewhere+type Defs = NameSet++-- | A set of names that are used somewhere+type Uses = NameSet++-- | @(Just ds, us) =>@ The use of any member of the @ds@+--                      implies that all the @us@ are used too.+--                      Also, @us@ may mention @ds@.+--+-- @Nothing =>@ Nothing is defined in this group, but+--              nevertheless all the uses are essential.+--              Used for instance declarations, for example+type DefUse  = (Maybe Defs, Uses)++-- | A number of 'DefUse's in dependency order: earlier 'Defs' scope over later 'Uses'+--   In a single (def, use) pair, the defs also scope over the uses+type DefUses = [DefUse]++emptyDUs :: DefUses+emptyDUs = []++usesOnly :: Uses -> DefUses+usesOnly uses = [(Nothing, uses)]++mkDUs :: [(Defs,Uses)] -> DefUses+mkDUs pairs = [(Just defs, uses) | (defs,uses) <- pairs]++plusDU :: DefUses -> DefUses -> DefUses+plusDU = (++)++duDefs :: DefUses -> Defs+duDefs dus = foldr get emptyNameSet dus+  where+    get (Nothing, _u1) d2 = d2+    get (Just d1, _u1) d2 = d1 `unionNameSet` d2++allUses :: DefUses -> Uses+-- ^ Just like 'duUses', but 'Defs' are not eliminated from the 'Uses' returned+allUses dus = foldr get emptyNameSet dus+  where+    get (_d1, u1) u2 = u1 `unionNameSet` u2++duUses :: DefUses -> Uses+-- ^ Collect all 'Uses', regardless of whether the group is itself used,+-- but remove 'Defs' on the way+duUses dus = foldr get emptyNameSet dus+  where+    get (Nothing,   rhs_uses) uses = rhs_uses `unionNameSet` uses+    get (Just defs, rhs_uses) uses = (rhs_uses `unionNameSet` uses)+                                     `minusNameSet` defs++findUses :: DefUses -> Uses -> Uses+-- ^ Given some 'DefUses' and some 'Uses', find all the uses, transitively.+-- The result is a superset of the input 'Uses'; and includes things defined+-- in the input 'DefUses' (but only if they are used)+findUses dus uses+  = foldr get uses dus+  where+    get (Nothing, rhs_uses) uses+        = rhs_uses `unionNameSet` uses+    get (Just defs, rhs_uses) uses+        | defs `intersectsNameSet` uses         -- Used+        || nameSetAny (startsWithUnderscore . nameOccName) defs+                -- At least one starts with an "_",+                -- so treat the group as used+        = rhs_uses `unionNameSet` uses+        | otherwise     -- No def is used+        = uses
+ basicTypes/OccName.hs view
@@ -0,0 +1,959 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- #name_types#+-- GHC uses several kinds of name internally:+--+-- * 'OccName.OccName' represents names as strings with just a little more information:+--   the \"namespace\" that the name came from, e.g. the namespace of value, type constructors or+--   data constructors+--+-- * 'RdrName.RdrName': see "RdrName#name_types"+--+-- * 'Name.Name': see "Name#name_types"+--+-- * 'Id.Id': see "Id#name_types"+--+-- * 'Var.Var': see "Var#name_types"++module OccName (+        -- * The 'NameSpace' type+        NameSpace, -- Abstract++        nameSpacesRelated,++        -- ** Construction+        -- $real_vs_source_data_constructors+        tcName, clsName, tcClsName, dataName, varName,+        tvName, srcDataName,++        -- ** Pretty Printing+        pprNameSpace, pprNonVarNameSpace, pprNameSpaceBrief,++        -- * The 'OccName' type+        OccName,        -- Abstract, instance of Outputable+        pprOccName,++        -- ** Construction+        mkOccName, mkOccNameFS,+        mkVarOcc, mkVarOccFS,+        mkDataOcc, mkDataOccFS,+        mkTyVarOcc, mkTyVarOccFS,+        mkTcOcc, mkTcOccFS,+        mkClsOcc, mkClsOccFS,+        mkDFunOcc,+        setOccNameSpace,+        demoteOccName,+        HasOccName(..),++        -- ** Derived 'OccName's+        isDerivedOccName,+        mkDataConWrapperOcc, mkWorkerOcc,+        mkMatcherOcc, mkBuilderOcc,+        mkDefaultMethodOcc, isDefaultMethodOcc, isTypeableBindOcc,+        mkNewTyCoOcc, mkClassOpAuxOcc,+        mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,+        mkClassDataConOcc, mkDictOcc, mkIPOcc,+        mkSpecOcc, mkForeignExportOcc, mkRepEqOcc,+        mkGenR, mkGen1R,+        mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc,+        mkSuperDictSelOcc, mkSuperDictAuxOcc,+        mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,+        mkInstTyCoOcc, mkEqPredCoOcc,+        mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc,+        mkPDataTyConOcc,  mkPDataDataConOcc,+        mkPDatasTyConOcc, mkPDatasDataConOcc,+        mkPReprTyConOcc,+        mkPADFunOcc,+        mkRecFldSelOcc,+        mkTyConRepOcc,++        -- ** Deconstruction+        occNameFS, occNameString, occNameSpace,++        isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc,+        parenSymOcc, startsWithUnderscore,++        isTcClsNameSpace, isTvNameSpace, isDataConNameSpace, isVarNameSpace, isValNameSpace,++        -- * The 'OccEnv' type+        OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv,+        lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv,+        occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C,+        extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv,+        alterOccEnv, pprOccEnv,++        -- * The 'OccSet' type+        OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet,+        extendOccSetList,+        unionOccSets, unionManyOccSets, minusOccSet, elemOccSet,+        isEmptyOccSet, intersectOccSet, intersectsOccSet,+        filterOccSet,++        -- * Tidying up+        TidyOccEnv, emptyTidyOccEnv, initTidyOccEnv,+        tidyOccName,+        tidyOccNames, avoidClashesOccEnv,++        -- FsEnv+        FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv+    ) where++import Util+import Unique+import DynFlags+import UniqFM+import UniqSet+import FastString+import FastStringEnv+import Outputable+import Lexeme+import Binary+import Control.DeepSeq+import Data.List (mapAccumL)+import Data.Char+import Data.Data++{-+************************************************************************+*                                                                      *+\subsection{Name space}+*                                                                      *+************************************************************************+-}++data NameSpace = VarName        -- Variables, including "real" data constructors+               | DataName       -- "Source" data constructors+               | TvName         -- Type variables+               | TcClsName      -- Type constructors and classes; Haskell has them+                                -- in the same name space for now.+               deriving( Eq, Ord )++-- Note [Data Constructors]+-- see also: Note [Data Constructor Naming] in DataCon.hs+--+-- $real_vs_source_data_constructors+-- There are two forms of data constructor:+--+--      [Source data constructors] The data constructors mentioned in Haskell source code+--+--      [Real data constructors] The data constructors of the representation type, which may not be the same as the source type+--+-- For example:+--+-- > data T = T !(Int, Int)+--+-- The source datacon has type @(Int, Int) -> T@+-- The real   datacon has type @Int -> Int -> T@+--+-- GHC chooses a representation based on the strictness etc.++tcName, clsName, tcClsName :: NameSpace+dataName, srcDataName      :: NameSpace+tvName, varName            :: NameSpace++-- Though type constructors and classes are in the same name space now,+-- the NameSpace type is abstract, so we can easily separate them later+tcName    = TcClsName           -- Type constructors+clsName   = TcClsName           -- Classes+tcClsName = TcClsName           -- Not sure which!++dataName    = DataName+srcDataName = DataName  -- Haskell-source data constructors should be+                        -- in the Data name space++tvName      = TvName+varName     = VarName++isDataConNameSpace :: NameSpace -> Bool+isDataConNameSpace DataName = True+isDataConNameSpace _        = False++isTcClsNameSpace :: NameSpace -> Bool+isTcClsNameSpace TcClsName = True+isTcClsNameSpace _         = False++isTvNameSpace :: NameSpace -> Bool+isTvNameSpace TvName = True+isTvNameSpace _      = False++isVarNameSpace :: NameSpace -> Bool     -- Variables or type variables, but not constructors+isVarNameSpace TvName  = True+isVarNameSpace VarName = True+isVarNameSpace _       = False++isValNameSpace :: NameSpace -> Bool+isValNameSpace DataName = True+isValNameSpace VarName  = True+isValNameSpace _        = False++pprNameSpace :: NameSpace -> SDoc+pprNameSpace DataName  = text "data constructor"+pprNameSpace VarName   = text "variable"+pprNameSpace TvName    = text "type variable"+pprNameSpace TcClsName = text "type constructor or class"++pprNonVarNameSpace :: NameSpace -> SDoc+pprNonVarNameSpace VarName = empty+pprNonVarNameSpace ns = pprNameSpace ns++pprNameSpaceBrief :: NameSpace -> SDoc+pprNameSpaceBrief DataName  = char 'd'+pprNameSpaceBrief VarName   = char 'v'+pprNameSpaceBrief TvName    = text "tv"+pprNameSpaceBrief TcClsName = text "tc"++-- demoteNameSpace lowers the NameSpace if possible.  We can not know+-- in advance, since a TvName can appear in an HsTyVar.+-- See Note [Demotion] in RnEnv+demoteNameSpace :: NameSpace -> Maybe NameSpace+demoteNameSpace VarName = Nothing+demoteNameSpace DataName = Nothing+demoteNameSpace TvName = Nothing+demoteNameSpace TcClsName = Just DataName++{-+************************************************************************+*                                                                      *+\subsection[Name-pieces-datatypes]{The @OccName@ datatypes}+*                                                                      *+************************************************************************+-}++-- | Occurrence Name+--+-- In this context that means:+-- "classified (i.e. as a type name, value name, etc) but not qualified+-- and not yet resolved"+data OccName = OccName+    { occNameSpace  :: !NameSpace+    , occNameFS     :: !FastString+    }++instance Eq OccName where+    (OccName sp1 s1) == (OccName sp2 s2) = s1 == s2 && sp1 == sp2++instance Ord OccName where+        -- Compares lexicographically, *not* by Unique of the string+    compare (OccName sp1 s1) (OccName sp2 s2)+        = (s1  `compare` s2) `thenCmp` (sp1 `compare` sp2)++instance Data OccName where+  -- don't traverse?+  toConstr _   = abstractConstr "OccName"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "OccName"++instance HasOccName OccName where+  occName = id++instance NFData OccName where+  rnf x = x `seq` ()++{-+************************************************************************+*                                                                      *+\subsection{Printing}+*                                                                      *+************************************************************************+-}++instance Outputable OccName where+    ppr = pprOccName++instance OutputableBndr OccName where+    pprBndr _ = ppr+    pprInfixOcc n = pprInfixVar (isSymOcc n) (ppr n)+    pprPrefixOcc n = pprPrefixVar (isSymOcc n) (ppr n)++pprOccName :: OccName -> SDoc+pprOccName (OccName sp occ)+  = getPprStyle $ \ sty ->+    if codeStyle sty+    then ztext (zEncodeFS occ)+    else pp_occ <> pp_debug sty+  where+    pp_debug sty | debugStyle sty = braces (pprNameSpaceBrief sp)+                 | otherwise      = empty++    pp_occ = sdocWithDynFlags $ \dflags ->+             if gopt Opt_SuppressUniques dflags+             then text (strip_th_unique (unpackFS occ))+             else ftext occ++        -- See Note [Suppressing uniques in OccNames]+    strip_th_unique ('[' : c : _) | isAlphaNum c = []+    strip_th_unique (c : cs) = c : strip_th_unique cs+    strip_th_unique []       = []++{-+Note [Suppressing uniques in OccNames]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This is a hack to de-wobblify the OccNames that contain uniques from+Template Haskell that have been turned into a string in the OccName.+See Note [Unique OccNames from Template Haskell] in Convert.hs++************************************************************************+*                                                                      *+\subsection{Construction}+*                                                                      *+************************************************************************+-}++mkOccName :: NameSpace -> String -> OccName+mkOccName occ_sp str = OccName occ_sp (mkFastString str)++mkOccNameFS :: NameSpace -> FastString -> OccName+mkOccNameFS occ_sp fs = OccName occ_sp fs++mkVarOcc :: String -> OccName+mkVarOcc s = mkOccName varName s++mkVarOccFS :: FastString -> OccName+mkVarOccFS fs = mkOccNameFS varName fs++mkDataOcc :: String -> OccName+mkDataOcc = mkOccName dataName++mkDataOccFS :: FastString -> OccName+mkDataOccFS = mkOccNameFS dataName++mkTyVarOcc :: String -> OccName+mkTyVarOcc = mkOccName tvName++mkTyVarOccFS :: FastString -> OccName+mkTyVarOccFS fs = mkOccNameFS tvName fs++mkTcOcc :: String -> OccName+mkTcOcc = mkOccName tcName++mkTcOccFS :: FastString -> OccName+mkTcOccFS = mkOccNameFS tcName++mkClsOcc :: String -> OccName+mkClsOcc = mkOccName clsName++mkClsOccFS :: FastString -> OccName+mkClsOccFS = mkOccNameFS clsName++-- demoteOccName lowers the Namespace of OccName.+-- see Note [Demotion]+demoteOccName :: OccName -> Maybe OccName+demoteOccName (OccName space name) = do+  space' <- demoteNameSpace space+  return $ OccName space' name++-- Name spaces are related if there is a chance to mean the one when one writes+-- the other, i.e. variables <-> data constructors and type variables <-> type constructors+nameSpacesRelated :: NameSpace -> NameSpace -> Bool+nameSpacesRelated ns1 ns2 = ns1 == ns2 || otherNameSpace ns1 == ns2++otherNameSpace :: NameSpace -> NameSpace+otherNameSpace VarName = DataName+otherNameSpace DataName = VarName+otherNameSpace TvName = TcClsName+otherNameSpace TcClsName = TvName++++{- | Other names in the compiler add additional information to an OccName.+This class provides a consistent way to access the underlying OccName. -}+class HasOccName name where+  occName :: name -> OccName++{-+************************************************************************+*                                                                      *+                Environments+*                                                                      *+************************************************************************++OccEnvs are used mainly for the envts in ModIfaces.++Note [The Unique of an OccName]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+They are efficient, because FastStrings have unique Int# keys.  We assume+this key is less than 2^24, and indeed FastStrings are allocated keys+sequentially starting at 0.++So we can make a Unique using+        mkUnique ns key  :: Unique+where 'ns' is a Char representing the name space.  This in turn makes it+easy to build an OccEnv.+-}++instance Uniquable OccName where+      -- See Note [The Unique of an OccName]+  getUnique (OccName VarName   fs) = mkVarOccUnique  fs+  getUnique (OccName DataName  fs) = mkDataOccUnique fs+  getUnique (OccName TvName    fs) = mkTvOccUnique   fs+  getUnique (OccName TcClsName fs) = mkTcOccUnique   fs++newtype OccEnv a = A (UniqFM a)+  deriving Data++emptyOccEnv :: OccEnv a+unitOccEnv  :: OccName -> a -> OccEnv a+extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a+extendOccEnvList :: OccEnv a -> [(OccName, a)] -> OccEnv a+lookupOccEnv :: OccEnv a -> OccName -> Maybe a+mkOccEnv     :: [(OccName,a)] -> OccEnv a+mkOccEnv_C   :: (a -> a -> a) -> [(OccName,a)] -> OccEnv a+elemOccEnv   :: OccName -> OccEnv a -> Bool+foldOccEnv   :: (a -> b -> b) -> b -> OccEnv a -> b+occEnvElts   :: OccEnv a -> [a]+extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a+extendOccEnv_Acc :: (a->b->b) -> (a->b) -> OccEnv b -> OccName -> a -> OccEnv b+plusOccEnv     :: OccEnv a -> OccEnv a -> OccEnv a+plusOccEnv_C   :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a+mapOccEnv      :: (a->b) -> OccEnv a -> OccEnv b+delFromOccEnv      :: OccEnv a -> OccName -> OccEnv a+delListFromOccEnv :: OccEnv a -> [OccName] -> OccEnv a+filterOccEnv       :: (elt -> Bool) -> OccEnv elt -> OccEnv elt+alterOccEnv        :: (Maybe elt -> Maybe elt) -> OccEnv elt -> OccName -> OccEnv elt++emptyOccEnv      = A emptyUFM+unitOccEnv x y = A $ unitUFM x y+extendOccEnv (A x) y z = A $ addToUFM x y z+extendOccEnvList (A x) l = A $ addListToUFM x l+lookupOccEnv (A x) y = lookupUFM x y+mkOccEnv     l    = A $ listToUFM l+elemOccEnv x (A y)       = elemUFM x y+foldOccEnv a b (A c)     = foldUFM a b c+occEnvElts (A x)         = eltsUFM x+plusOccEnv (A x) (A y)   = A $ plusUFM x y+plusOccEnv_C f (A x) (A y)       = A $ plusUFM_C f x y+extendOccEnv_C f (A x) y z   = A $ addToUFM_C f x y z+extendOccEnv_Acc f g (A x) y z   = A $ addToUFM_Acc f g x y z+mapOccEnv f (A x)        = A $ mapUFM f x+mkOccEnv_C comb l = A $ addListToUFM_C comb emptyUFM l+delFromOccEnv (A x) y    = A $ delFromUFM x y+delListFromOccEnv (A x) y  = A $ delListFromUFM x y+filterOccEnv x (A y)       = A $ filterUFM x y+alterOccEnv fn (A y) k     = A $ alterUFM fn y k++instance Outputable a => Outputable (OccEnv a) where+    ppr x = pprOccEnv ppr x++pprOccEnv :: (a -> SDoc) -> OccEnv a -> SDoc+pprOccEnv ppr_elt (A env) = pprUniqFM ppr_elt env++type OccSet = UniqSet OccName++emptyOccSet       :: OccSet+unitOccSet        :: OccName -> OccSet+mkOccSet          :: [OccName] -> OccSet+extendOccSet      :: OccSet -> OccName -> OccSet+extendOccSetList  :: OccSet -> [OccName] -> OccSet+unionOccSets      :: OccSet -> OccSet -> OccSet+unionManyOccSets  :: [OccSet] -> OccSet+minusOccSet       :: OccSet -> OccSet -> OccSet+elemOccSet        :: OccName -> OccSet -> Bool+isEmptyOccSet     :: OccSet -> Bool+intersectOccSet   :: OccSet -> OccSet -> OccSet+intersectsOccSet  :: OccSet -> OccSet -> Bool+filterOccSet      :: (OccName -> Bool) -> OccSet -> OccSet++emptyOccSet       = emptyUniqSet+unitOccSet        = unitUniqSet+mkOccSet          = mkUniqSet+extendOccSet      = addOneToUniqSet+extendOccSetList  = addListToUniqSet+unionOccSets      = unionUniqSets+unionManyOccSets  = unionManyUniqSets+minusOccSet       = minusUniqSet+elemOccSet        = elementOfUniqSet+isEmptyOccSet     = isEmptyUniqSet+intersectOccSet   = intersectUniqSets+intersectsOccSet s1 s2 = not (isEmptyOccSet (s1 `intersectOccSet` s2))+filterOccSet      = filterUniqSet++{-+************************************************************************+*                                                                      *+\subsection{Predicates and taking them apart}+*                                                                      *+************************************************************************+-}++occNameString :: OccName -> String+occNameString (OccName _ s) = unpackFS s++setOccNameSpace :: NameSpace -> OccName -> OccName+setOccNameSpace sp (OccName _ occ) = OccName sp occ++isVarOcc, isTvOcc, isTcOcc, isDataOcc :: OccName -> Bool++isVarOcc (OccName VarName _) = True+isVarOcc _                   = False++isTvOcc (OccName TvName _) = True+isTvOcc _                  = False++isTcOcc (OccName TcClsName _) = True+isTcOcc _                     = False++-- | /Value/ 'OccNames's are those that are either in+-- the variable or data constructor namespaces+isValOcc :: OccName -> Bool+isValOcc (OccName VarName  _) = True+isValOcc (OccName DataName _) = True+isValOcc _                    = False++isDataOcc (OccName DataName _) = True+isDataOcc _                    = False++-- | Test if the 'OccName' is a data constructor that starts with+-- a symbol (e.g. @:@, or @[]@)+isDataSymOcc :: OccName -> Bool+isDataSymOcc (OccName DataName s) = isLexConSym s+isDataSymOcc _                    = False+-- Pretty inefficient!++-- | Test if the 'OccName' is that for any operator (whether+-- it is a data constructor or variable or whatever)+isSymOcc :: OccName -> Bool+isSymOcc (OccName DataName s)  = isLexConSym s+isSymOcc (OccName TcClsName s) = isLexSym s+isSymOcc (OccName VarName s)   = isLexSym s+isSymOcc (OccName TvName s)    = isLexSym s+-- Pretty inefficient!++parenSymOcc :: OccName -> SDoc -> SDoc+-- ^ Wrap parens around an operator+parenSymOcc occ doc | isSymOcc occ = parens doc+                    | otherwise    = doc++startsWithUnderscore :: OccName -> Bool+-- ^ Haskell 98 encourages compilers to suppress warnings about unsed+-- names in a pattern if they start with @_@: this implements that test+startsWithUnderscore occ = headFS (occNameFS occ) == '_'++{-+************************************************************************+*                                                                      *+\subsection{Making system names}+*                                                                      *+************************************************************************++Here's our convention for splitting up the interface file name space:++   d...         dictionary identifiers+                (local variables, so no name-clash worries)++All of these other OccNames contain a mixture of alphabetic+and symbolic characters, and hence cannot possibly clash with+a user-written type or function name++   $f...        Dict-fun identifiers (from inst decls)+   $dmop        Default method for 'op'+   $pnC         n'th superclass selector for class C+   $wf          Worker for function 'f'+   $sf..        Specialised version of f+   D:C          Data constructor for dictionary for class C+   NTCo:T       Coercion connecting newtype T with its representation type+   TFCo:R       Coercion connecting a data family to its representation type R++In encoded form these appear as Zdfxxx etc++        :...            keywords (export:, letrec: etc.)+--- I THINK THIS IS WRONG!++This knowledge is encoded in the following functions.++@mk_deriv@ generates an @OccName@ from the prefix and a string.+NB: The string must already be encoded!+-}++-- | Build an 'OccName' derived from another 'OccName'.+--+-- Note that the pieces of the name are passed in as a @[FastString]@ so that+-- the whole name can be constructed with a single 'concatFS', minimizing+-- unnecessary intermediate allocations.+mk_deriv :: NameSpace+         -> FastString      -- ^ A prefix which distinguishes one sort of+                            -- derived name from another+         -> [FastString]    -- ^ The name we are deriving from in pieces which+                            -- will be concatenated.+         -> OccName+mk_deriv occ_sp sys_prefix str =+    mkOccNameFS occ_sp (concatFS $ sys_prefix : str)++isDerivedOccName :: OccName -> Bool+-- ^ Test for definitions internally generated by GHC.  This predicte+-- is used to suppress printing of internal definitions in some debug prints+isDerivedOccName occ =+   case occNameString occ of+     '$':c:_ | isAlphaNum c -> True   -- E.g.  $wfoo+     c:':':_ | isAlphaNum c -> True   -- E.g.  N:blah   newtype coercions+     _other                 -> False++isDefaultMethodOcc :: OccName -> Bool+isDefaultMethodOcc occ =+   case occNameString occ of+     '$':'d':'m':_ -> True+     _ -> False++-- | Is an 'OccName' one of a Typeable @TyCon@ or @Module@ binding?+-- This is needed as these bindings are renamed differently.+-- See Note [Grand plan for Typeable] in TcTypeable.+isTypeableBindOcc :: OccName -> Bool+isTypeableBindOcc occ =+   case occNameString occ of+     '$':'t':'c':_ -> True  -- mkTyConRepOcc+     '$':'t':'r':_ -> True  -- Module binding+     _ -> False++mkDataConWrapperOcc, mkWorkerOcc,+        mkMatcherOcc, mkBuilderOcc,+        mkDefaultMethodOcc,+        mkClassDataConOcc, mkDictOcc,+        mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkRepEqOcc,+        mkGenR, mkGen1R,+        mkDataConWorkerOcc, mkNewTyCoOcc,+        mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,+        mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,+        mkTyConRepOcc+   :: OccName -> OccName++-- These derived variables have a prefix that no Haskell value could have+mkDataConWrapperOcc = mk_simple_deriv varName  "$W"+mkWorkerOcc         = mk_simple_deriv varName  "$w"+mkMatcherOcc        = mk_simple_deriv varName  "$m"+mkBuilderOcc        = mk_simple_deriv varName  "$b"+mkDefaultMethodOcc  = mk_simple_deriv varName  "$dm"+mkClassOpAuxOcc     = mk_simple_deriv varName  "$c"+mkDictOcc           = mk_simple_deriv varName  "$d"+mkIPOcc             = mk_simple_deriv varName  "$i"+mkSpecOcc           = mk_simple_deriv varName  "$s"+mkForeignExportOcc  = mk_simple_deriv varName  "$f"+mkRepEqOcc          = mk_simple_deriv tvName   "$r"   -- In RULES involving Coercible+mkClassDataConOcc   = mk_simple_deriv dataName "C:"     -- Data con for a class+mkNewTyCoOcc        = mk_simple_deriv tcName   "N:"   -- Coercion for newtypes+mkInstTyCoOcc       = mk_simple_deriv tcName   "D:"   -- Coercion for type functions+mkEqPredCoOcc       = mk_simple_deriv tcName   "$co"++-- Used in derived instances+mkCon2TagOcc        = mk_simple_deriv varName  "$con2tag_"+mkTag2ConOcc        = mk_simple_deriv varName  "$tag2con_"+mkMaxTagOcc         = mk_simple_deriv varName  "$maxtag_"++-- TyConRepName stuff; see Note [Grand plan for Typeable] in TcTypeable+mkTyConRepOcc occ = mk_simple_deriv varName prefix occ+  where+    prefix | isDataOcc occ = "$tc'"+           | otherwise     = "$tc"++-- Generic deriving mechanism+mkGenR   = mk_simple_deriv tcName "Rep_"+mkGen1R  = mk_simple_deriv tcName "Rep1_"++-- Vectorisation+mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc,+ mkPADFunOcc,      mkPReprTyConOcc,+ mkPDataTyConOcc,  mkPDataDataConOcc,+ mkPDatasTyConOcc, mkPDatasDataConOcc+  :: Maybe String -> OccName -> OccName+mkVectOcc          = mk_simple_deriv_with varName  "$v"+mkVectTyConOcc     = mk_simple_deriv_with tcName   "V:"+mkVectDataConOcc   = mk_simple_deriv_with dataName "VD:"+mkVectIsoOcc       = mk_simple_deriv_with varName  "$vi"+mkPADFunOcc        = mk_simple_deriv_with varName  "$pa"+mkPReprTyConOcc    = mk_simple_deriv_with tcName   "VR:"+mkPDataTyConOcc    = mk_simple_deriv_with tcName   "VP:"+mkPDatasTyConOcc   = mk_simple_deriv_with tcName   "VPs:"+mkPDataDataConOcc  = mk_simple_deriv_with dataName "VPD:"+mkPDatasDataConOcc = mk_simple_deriv_with dataName "VPDs:"++-- Overloaded record field selectors+mkRecFldSelOcc :: String -> OccName+mkRecFldSelOcc s = mk_deriv varName "$sel" [fsLit s]++mk_simple_deriv :: NameSpace -> FastString -> OccName -> OccName+mk_simple_deriv sp px occ = mk_deriv sp px [occNameFS occ]++mk_simple_deriv_with :: NameSpace     -- ^ the namespace+                     -> FastString    -- ^ an identifying prefix+                     -> Maybe String  -- ^ another optional prefix+                     -> OccName       -- ^ the 'OccName' to derive from+                     -> OccName+mk_simple_deriv_with sp px Nothing     occ = mk_deriv sp px [occNameFS occ]+mk_simple_deriv_with sp px (Just with) occ =+    mk_deriv sp px [fsLit with, fsLit "_", occNameFS occ]++-- Data constructor workers are made by setting the name space+-- of the data constructor OccName (which should be a DataName)+-- to VarName+mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ++mkSuperDictAuxOcc :: Int -> OccName -> OccName+mkSuperDictAuxOcc index cls_tc_occ+  = mk_deriv varName "$cp" [fsLit $ show index, occNameFS cls_tc_occ]++mkSuperDictSelOcc :: Int        -- ^ Index of superclass, e.g. 3+                  -> OccName    -- ^ Class, e.g. @Ord@+                  -> OccName    -- ^ Derived 'Occname', e.g. @$p3Ord@+mkSuperDictSelOcc index cls_tc_occ+  = mk_deriv varName "$p" [fsLit $ show index, occNameFS cls_tc_occ]++mkLocalOcc :: Unique            -- ^ Unique to combine with the 'OccName'+           -> OccName           -- ^ Local name, e.g. @sat@+           -> OccName           -- ^ Nice unique version, e.g. @$L23sat@+mkLocalOcc uniq occ+   = mk_deriv varName "$L" [fsLit $ show uniq, occNameFS occ]+        -- The Unique might print with characters+        -- that need encoding (e.g. 'z'!)++-- | Derive a name for the representation type constructor of a+-- @data@\/@newtype@ instance.+mkInstTyTcOcc :: String                 -- ^ Family name, e.g. @Map@+              -> OccSet                 -- ^ avoid these Occs+              -> OccName                -- ^ @R:Map@+mkInstTyTcOcc str = chooseUniqueOcc tcName ('R' : ':' : str)++mkDFunOcc :: String             -- ^ Typically the class and type glommed together e.g. @OrdMaybe@.+                                -- Only used in debug mode, for extra clarity+          -> Bool               -- ^ Is this a hs-boot instance DFun?+          -> OccSet             -- ^ avoid these Occs+          -> OccName            -- ^ E.g. @$f3OrdMaybe@++-- In hs-boot files we make dict funs like $fx7ClsTy, which get bound to the real+-- thing when we compile the mother module. Reason: we don't know exactly+-- what the  mother module will call it.++mkDFunOcc info_str is_boot set+  = chooseUniqueOcc VarName (prefix ++ info_str) set+  where+    prefix | is_boot   = "$fx"+           | otherwise = "$f"++mkDataTOcc, mkDataCOcc+  :: OccName            -- ^ TyCon or data con string+  -> OccSet             -- ^ avoid these Occs+  -> OccName            -- ^ E.g. @$f3OrdMaybe@+-- data T = MkT ... deriving( Data ) needs definitions for+--      $tT   :: Data.Generics.Basics.DataType+--      $cMkT :: Data.Generics.Basics.Constr+mkDataTOcc occ = chooseUniqueOcc VarName ("$t" ++ occNameString occ)+mkDataCOcc occ = chooseUniqueOcc VarName ("$c" ++ occNameString occ)++{-+Sometimes we need to pick an OccName that has not already been used,+given a set of in-use OccNames.+-}++chooseUniqueOcc :: NameSpace -> String -> OccSet -> OccName+chooseUniqueOcc ns str set = loop (mkOccName ns str) (0::Int)+  where+  loop occ n+   | occ `elemOccSet` set = loop (mkOccName ns (str ++ show n)) (n+1)+   | otherwise            = occ++{-+We used to add a '$m' to indicate a method, but that gives rise to bad+error messages from the type checker when we print the function name or pattern+of an instance-decl binding.  Why? Because the binding is zapped+to use the method name in place of the selector name.+(See TcClassDcl.tcMethodBind)++The way it is now, -ddump-xx output may look confusing, but+you can always say -dppr-debug to get the uniques.++However, we *do* have to zap the first character to be lower case,+because overloaded constructors (blarg) generate methods too.+And convert to VarName space++e.g. a call to constructor MkFoo where+        data (Ord a) => Foo a = MkFoo a++If this is necessary, we do it by prefixing '$m'.  These+guys never show up in error messages.  What a hack.+-}++mkMethodOcc :: OccName -> OccName+mkMethodOcc occ@(OccName VarName _) = occ+mkMethodOcc occ                     = mk_simple_deriv varName "$m" occ++{-+************************************************************************+*                                                                      *+\subsection{Tidying them up}+*                                                                      *+************************************************************************++Before we print chunks of code we like to rename it so that+we don't have to print lots of silly uniques in it.  But we mustn't+accidentally introduce name clashes!  So the idea is that we leave the+OccName alone unless it accidentally clashes with one that is already+in scope; if so, we tack on '1' at the end and try again, then '2', and+so on till we find a unique one.++There's a wrinkle for operators.  Consider '>>='.  We can't use '>>=1'+because that isn't a single lexeme.  So we encode it to 'lle' and *then*+tack on the '1', if necessary.++Note [TidyOccEnv]+~~~~~~~~~~~~~~~~~+type TidyOccEnv = UniqFM Int++* Domain = The OccName's FastString. These FastStrings are "taken";+           make sure that we don't re-use++* Int, n = A plausible starting point for new guesses+           There is no guarantee that "FSn" is available;+           you must look that up in the TidyOccEnv.  But+           it's a good place to start looking.++* When looking for a renaming for "foo2" we strip off the "2" and start+  with "foo".  Otherwise if we tidy twice we get silly names like foo23.++  However, if it started with digits at the end, we always make a name+  with digits at the end, rather than shortening "foo2" to just "foo",+  even if "foo" is unused.  Reasons:+     - Plain "foo" might be used later+     - We use trailing digits to subtly indicate a unification variable+       in typechecker error message; see TypeRep.tidyTyVarBndr++We have to take care though! Consider a machine-generated module (Trac #10370)+  module Foo where+     a1 = e1+     a2 = e2+     ...+     a2000 = e2000+Then "a1", "a2" etc are all marked taken.  But now if we come across "a7" again,+we have to do a linear search to find a free one, "a2001".  That might just be+acceptable once.  But if we now come across "a8" again, we don't want to repeat+that search.++So we use the TidyOccEnv mapping for "a" (not "a7" or "a8") as our base for+starting the search; and we make sure to update the starting point for "a"+after we allocate a new one.+++Node [Tidying multiple names at once]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Consider++    > :t (id,id,id)++Every id contributes a type variable to the type signature, and all of them are+"a". If we tidy them one by one, we get++    (id,id,id) :: (a2 -> a2, a1 -> a1, a -> a)++which is a bit unfortunate, as it unfairly renames only one of them. What we+would like to see is++    (id,id,id) :: (a3 -> a3, a2 -> a2, a1 -> a1)++This is achieved in tidyOccNames. It still uses tidyOccName to rename each name+on its own, but it prepares the TidyEnv (using avoidClashesOccEnv), by “blocking” every+name that occurs twice in the map. This way, none of the "a"s will get the+priviledge of keeping this name, and all of them will get a suitable numbery by+tidyOccName.++It may be inappropriate to use tidyOccNames if the caller needs access to the+intermediate environments (e.g. to tidy the tyVarKind of a type variable). In that+case, avoidClashesOccEnv should be used directly, and tidyOccName afterwards.++This is #12382.++-}++type TidyOccEnv = UniqFM Int    -- The in-scope OccNames+  -- See Note [TidyOccEnv]++emptyTidyOccEnv :: TidyOccEnv+emptyTidyOccEnv = emptyUFM++initTidyOccEnv :: [OccName] -> TidyOccEnv       -- Initialise with names to avoid!+initTidyOccEnv = foldl add emptyUFM+  where+    add env (OccName _ fs) = addToUFM env fs 1++-- see Note [Tidying multiple names at once]+tidyOccNames :: TidyOccEnv -> [OccName] -> (TidyOccEnv, [OccName])+tidyOccNames env occs = mapAccumL tidyOccName env' occs+  where+    env' = avoidClashesOccEnv env occs++avoidClashesOccEnv :: TidyOccEnv -> [OccName] -> TidyOccEnv+avoidClashesOccEnv env occs = go env emptyUFM occs+  where+    go env _        [] = env+    go env seenOnce ((OccName _ fs):occs)+      | fs `elemUFM` env      = go env seenOnce                  occs+      | fs `elemUFM` seenOnce = go (addToUFM env fs 1) seenOnce  occs+      | otherwise             = go env (addToUFM seenOnce fs ()) occs++tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName)+tidyOccName env occ@(OccName occ_sp fs)+  | not (fs `elemUFM` env)+  = (addToUFM env fs 1, occ)   -- Desired OccName is free+  | otherwise+  = case lookupUFM env base1 of+       Nothing -> (addToUFM env base1 2, OccName occ_sp base1)+       Just n  -> find 1 n+  where+    base :: String  -- Drop trailing digits (see Note [TidyOccEnv])+    base  = dropWhileEndLE isDigit (unpackFS fs)+    base1 = mkFastString (base ++ "1")++    find !k !n+      = case lookupUFM env new_fs of+          Just {} -> find (k+1 :: Int) (n+k)+                       -- By using n+k, the n argument to find goes+                       --    1, add 1, add 2, add 3, etc which+                       -- moves at quadratic speed through a dense patch++          Nothing -> (new_env, OccName occ_sp new_fs)+       where+         new_fs = mkFastString (base ++ show n)+         new_env = addToUFM (addToUFM env new_fs 1) base1 (n+1)+                     -- Update:  base1,  so that next time we'll start where we left off+                     --          new_fs, so that we know it is taken+                     -- If they are the same (n==1), the former wins+                     -- See Note [TidyOccEnv]++{-+************************************************************************+*                                                                      *+                Binary instance+    Here rather than BinIface because OccName is abstract+*                                                                      *+************************************************************************+-}++instance Binary NameSpace where+    put_ bh VarName = do+            putByte bh 0+    put_ bh DataName = do+            putByte bh 1+    put_ bh TvName = do+            putByte bh 2+    put_ bh TcClsName = do+            putByte bh 3+    get bh = do+            h <- getByte bh+            case h of+              0 -> do return VarName+              1 -> do return DataName+              2 -> do return TvName+              _ -> do return TcClsName++instance Binary OccName where+    put_ bh (OccName aa ab) = do+            put_ bh aa+            put_ bh ab+    get bh = do+          aa <- get bh+          ab <- get bh+          return (OccName aa ab)
+ basicTypes/OccName.hs-boot view
@@ -0,0 +1,3 @@+module OccName where++data OccName
+ basicTypes/PatSyn.hs view
@@ -0,0 +1,429 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1998++\section[PatSyn]{@PatSyn@: Pattern synonyms}+-}++{-# LANGUAGE CPP #-}++module PatSyn (+        -- * Main data types+        PatSyn, mkPatSyn,++        -- ** Type deconstruction+        patSynName, patSynArity, patSynIsInfix,+        patSynArgs,+        patSynMatcher, patSynBuilder,+        patSynUnivTyVarBinders, patSynExTyVars, patSynExTyVarBinders, patSynSig,+        patSynInstArgTys, patSynInstResTy, patSynFieldLabels,+        patSynFieldType,++        tidyPatSynIds, pprPatSynType+    ) where++#include "HsVersions.h"++import Type+import Name+import Outputable+import Unique+import Util+import BasicTypes+import Var+import FieldLabel++import qualified Data.Data as Data+import Data.Function+import Data.List++{-+************************************************************************+*                                                                      *+\subsection{Pattern synonyms}+*                                                                      *+************************************************************************+-}++-- | Pattern Synonym+--+-- See Note [Pattern synonym representation]+-- See Note [Pattern synonym signature contexts]+data PatSyn+  = MkPatSyn {+        psName        :: Name,+        psUnique      :: Unique,       -- Cached from Name++        psArgs        :: [Type],+        psArity       :: Arity,        -- == length psArgs+        psInfix       :: Bool,         -- True <=> declared infix+        psFieldLabels :: [FieldLabel], -- List of fields for a+                                       -- record pattern synonym+                                       -- INVARIANT: either empty if no+                                       -- record pat syn or same length as+                                       -- psArgs++        -- Universially-quantified type variables+        psUnivTyVars  :: [TyVarBinder],++        -- Required dictionaries (may mention psUnivTyVars)+        psReqTheta    :: ThetaType,++        -- Existentially-quantified type vars+        psExTyVars    :: [TyVarBinder],++        -- Provided dictionaries (may mention psUnivTyVars or psExTyVars)+        psProvTheta   :: ThetaType,++        -- Result type+        psOrigResTy   :: Type,         -- Mentions only psUnivTyVars++        -- See Note [Matchers and builders for pattern synonyms]+        psMatcher     :: (Id, Bool),+             -- Matcher function.+             -- If Bool is True then prov_theta and arg_tys are empty+             -- and type is+             --   forall (p :: RuntimeRep) (r :: TYPE p) univ_tvs.+             --                          req_theta+             --                       => res_ty+             --                       -> (forall ex_tvs. Void# -> r)+             --                       -> (Void# -> r)+             --                       -> r+             --+             -- Otherwise type is+             --   forall (p :: RuntimeRep) (r :: TYPE r) univ_tvs.+             --                          req_theta+             --                       => res_ty+             --                       -> (forall ex_tvs. prov_theta => arg_tys -> r)+             --                       -> (Void# -> r)+             --                       -> r++        psBuilder     :: Maybe (Id, Bool)+             -- Nothing  => uni-directional pattern synonym+             -- Just (builder, is_unlifted) => bi-directional+             -- Builder function, of type+             --  forall univ_tvs, ex_tvs. (req_theta, prov_theta)+             --                       =>  arg_tys -> res_ty+             -- See Note [Builder for pattern synonyms with unboxed type]+  }++{- Note [Pattern synonym signature contexts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a pattern synonym signature we write+   pattern P :: req => prov => t1 -> ... tn -> res_ty++Note that the "required" context comes first, then the "provided"+context.  Moreover, the "required" context must not mention+existentially-bound type variables; that is, ones not mentioned in+res_ty.  See lots of discussion in Trac #10928.++If there is no "provided" context, you can omit it; but you+can't omit the "required" part (unless you omit both).++Example 1:+      pattern P1 :: (Num a, Eq a) => b -> Maybe (a,b)+      pattern P1 x = Just (3,x)++  We require (Num a, Eq a) to match the 3; there is no provided+  context.++Example 2:+      data T2 where+        MkT2 :: (Num a, Eq a) => a -> a -> T2++      pattern P2 :: () => (Num a, Eq a) => a -> T2+      pattern P2 x = MkT2 3 x++  When we match against P2 we get a Num dictionary provided.+  We can use that to check the match against 3.++Example 3:+      pattern P3 :: Eq a => a -> b -> T3 b++   This signature is illegal because the (Eq a) is a required+   constraint, but it mentions the existentially-bound variable 'a'.+   You can see it's existential because it doesn't appear in the+   result type (T3 b).++Note [Pattern synonym representation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following pattern synonym declaration++        pattern P x = MkT [x] (Just 42)++where+        data T a where+              MkT :: (Show a, Ord b) => [b] -> a -> T a++so pattern P has type++        b -> T (Maybe t)++with the following typeclass constraints:++        requires: (Eq t, Num t)+        provides: (Show (Maybe t), Ord b)++In this case, the fields of MkPatSyn will be set as follows:++  psArgs       = [b]+  psArity      = 1+  psInfix      = False++  psUnivTyVars = [t]+  psExTyVars   = [b]+  psProvTheta  = (Show (Maybe t), Ord b)+  psReqTheta   = (Eq t, Num t)+  psOrigResTy  = T (Maybe t)++Note [Matchers and builders for pattern synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For each pattern synonym P, we generate++  * a "matcher" function, used to desugar uses of P in patterns,+    which implements pattern matching++  * A "builder" function (for bidirectional pattern synonyms only),+    used to desugar uses of P in expressions, which constructs P-values.++For the above example, the matcher function has type:++        $mP :: forall (r :: ?) t. (Eq t, Num t)+            => T (Maybe t)+            -> (forall b. (Show (Maybe t), Ord b) => b -> r)+            -> (Void# -> r)+            -> r++with the following implementation:++        $mP @r @t $dEq $dNum scrut cont fail+          = case scrut of+              MkT @b $dShow $dOrd [x] (Just 42) -> cont @b $dShow $dOrd x+              _                                 -> fail Void#++Notice that the return type 'r' has an open kind, so that it can+be instantiated by an unboxed type; for example where we see+     f (P x) = 3#++The extra Void# argument for the failure continuation is needed so that+it is lazy even when the result type is unboxed.++For the same reason, if the pattern has no arguments, an extra Void#+argument is added to the success continuation as well.++For *bidirectional* pattern synonyms, we also generate a "builder"+function which implements the pattern synonym in an expression+context. For our running example, it will be:++        $bP :: forall t b. (Eq t, Num t, Show (Maybe t), Ord b)+            => b -> T (Maybe t)+        $bP x = MkT [x] (Just 42)++NB: the existential/universal and required/provided split does not+apply to the builder since you are only putting stuff in, not getting+stuff out.++Injectivity of bidirectional pattern synonyms is checked in+tcPatToExpr which walks the pattern and returns its corresponding+expression when available.++Note [Builder for pattern synonyms with unboxed type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For bidirectional pattern synonyms that have no arguments and have an+unboxed type, we add an extra Void# argument to the builder, else it+would be a top-level declaration with an unboxed type.++        pattern P = 0#++        $bP :: Void# -> Int#+        $bP _ = 0#++This means that when typechecking an occurrence of P in an expression,+we must remember that the builder has this void argument. This is+done by TcPatSyn.patSynBuilderOcc.++Note [Pattern synonyms and the data type Type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The type of a pattern synonym is of the form (See Note+[Pattern synonym signatures]):++    forall univ_tvs. req => forall ex_tvs. prov => ...++We cannot in general represent this by a value of type Type:++ - if ex_tvs is empty, then req and prov cannot be distinguished from+   each other+ - if req is empty, then univ_tvs and ex_tvs cannot be distinguished+   from each other, and moreover, prov is seen as the "required" context+   (as it is the only context)+++************************************************************************+*                                                                      *+\subsection{Instances}+*                                                                      *+************************************************************************+-}++instance Eq PatSyn where+    (==) = (==) `on` getUnique+    (/=) = (/=) `on` getUnique++instance Uniquable PatSyn where+    getUnique = psUnique++instance NamedThing PatSyn where+    getName = patSynName++instance Outputable PatSyn where+    ppr = ppr . getName++instance OutputableBndr PatSyn where+    pprInfixOcc = pprInfixName . getName+    pprPrefixOcc = pprPrefixName . getName++instance Data.Data PatSyn where+    -- don't traverse?+    toConstr _   = abstractConstr "PatSyn"+    gunfold _ _  = error "gunfold"+    dataTypeOf _ = mkNoRepType "PatSyn"++{-+************************************************************************+*                                                                      *+\subsection{Construction}+*                                                                      *+************************************************************************+-}++-- | Build a new pattern synonym+mkPatSyn :: Name+         -> Bool                 -- ^ Is the pattern synonym declared infix?+         -> ([TyVarBinder], ThetaType) -- ^ Universially-quantified type variables+                                 --   and required dicts+         -> ([TyVarBinder], ThetaType) -- ^ Existentially-quantified type variables+                                 --   and provided dicts+         -> [Type]               -- ^ Original arguments+         -> Type                 -- ^ Original result type+         -> (Id, Bool)           -- ^ Name of matcher+         -> Maybe (Id, Bool)     -- ^ Name of builder+         -> [FieldLabel]         -- ^ Names of fields for+                                 --   a record pattern synonym+         -> PatSyn+ -- NB: The univ and ex vars are both in TyBinder form and TyVar form for+ -- convenience. All the TyBinders should be Named!+mkPatSyn name declared_infix+         (univ_tvs, req_theta)+         (ex_tvs, prov_theta)+         orig_args+         orig_res_ty+         matcher builder field_labels+    = MkPatSyn {psName = name, psUnique = getUnique name,+                psUnivTyVars = univ_tvs,+                psExTyVars = ex_tvs,+                psProvTheta = prov_theta, psReqTheta = req_theta,+                psInfix = declared_infix,+                psArgs = orig_args,+                psArity = length orig_args,+                psOrigResTy = orig_res_ty,+                psMatcher = matcher,+                psBuilder = builder,+                psFieldLabels = field_labels+                }++-- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification+patSynName :: PatSyn -> Name+patSynName = psName++-- | Should the 'PatSyn' be presented infix?+patSynIsInfix :: PatSyn -> Bool+patSynIsInfix = psInfix++-- | Arity of the pattern synonym+patSynArity :: PatSyn -> Arity+patSynArity = psArity++patSynArgs :: PatSyn -> [Type]+patSynArgs = psArgs++patSynFieldLabels :: PatSyn -> [FieldLabel]+patSynFieldLabels = psFieldLabels++-- | Extract the type for any given labelled field of the 'DataCon'+patSynFieldType :: PatSyn -> FieldLabelString -> Type+patSynFieldType ps label+  = case find ((== label) . flLabel . fst) (psFieldLabels ps `zip` psArgs ps) of+      Just (_, ty) -> ty+      Nothing -> pprPanic "dataConFieldType" (ppr ps <+> ppr label)++patSynUnivTyVarBinders :: PatSyn -> [TyVarBinder]+patSynUnivTyVarBinders = psUnivTyVars++patSynExTyVars :: PatSyn -> [TyVar]+patSynExTyVars ps = binderVars (psExTyVars ps)++patSynExTyVarBinders :: PatSyn -> [TyVarBinder]+patSynExTyVarBinders = psExTyVars++patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type)+patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs+                    , psProvTheta = prov, psReqTheta = req+                    , psArgs = arg_tys, psOrigResTy = res_ty })+  = (binderVars univ_tvs, req, binderVars ex_tvs, prov, arg_tys, res_ty)++patSynMatcher :: PatSyn -> (Id,Bool)+patSynMatcher = psMatcher++patSynBuilder :: PatSyn -> Maybe (Id, Bool)+patSynBuilder = psBuilder++tidyPatSynIds :: (Id -> Id) -> PatSyn -> PatSyn+tidyPatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder })+  = ps { psMatcher = tidy_pr matcher, psBuilder = fmap tidy_pr builder }+  where+    tidy_pr (id, dummy) = (tidy_fn id, dummy)++patSynInstArgTys :: PatSyn -> [Type] -> [Type]+-- Return the types of the argument patterns+-- e.g.  data D a = forall b. MkD a b (b->a)+--       pattern P f x y = MkD (x,True) y f+--          D :: forall a. forall b. a -> b -> (b->a) -> D a+--          P :: forall c. forall b. (b->(c,Bool)) -> c -> b -> P c+--   patSynInstArgTys P [Int,bb] = [bb->(Int,Bool), Int, bb]+-- NB: the inst_tys should be both universal and existential+patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs+                           , psExTyVars = ex_tvs, psArgs = arg_tys })+                 inst_tys+  = ASSERT2( length tyvars == length inst_tys+          , text "patSynInstArgTys" <+> ppr name $$ ppr tyvars $$ ppr inst_tys )+    map (substTyWith tyvars inst_tys) arg_tys+  where+    tyvars = binderVars (univ_tvs ++ ex_tvs)++patSynInstResTy :: PatSyn -> [Type] -> Type+-- Return the type of whole pattern+-- E.g.  pattern P x y = Just (x,x,y)+--         P :: a -> b -> Just (a,a,b)+--         (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool)+-- NB: unlikepatSynInstArgTys, the inst_tys should be just the *universal* tyvars+patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs+                          , psOrigResTy = res_ty })+                inst_tys+  = ASSERT2( length univ_tvs == length inst_tys+           , text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys )+    substTyWith (binderVars univ_tvs) inst_tys res_ty++-- | Print the type of a pattern synonym. The foralls are printed explicitly+pprPatSynType :: PatSyn -> SDoc+pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs,  psReqTheta  = req_theta+                        , psExTyVars   = ex_tvs,    psProvTheta = prov_theta+                        , psArgs       = orig_args, psOrigResTy = orig_res_ty })+  = sep [ pprForAll univ_tvs+        , pprThetaArrowTy req_theta+        , ppWhen insert_empty_ctxt $ parens empty <+> darrow+        , pprType sigma_ty ]+  where+    sigma_ty = mkForAllTys ex_tvs  $+               mkFunTys prov_theta $+               mkFunTys orig_args orig_res_ty+    insert_empty_ctxt = null req_theta && not (null prov_theta && null ex_tvs)
+ basicTypes/PatSyn.hs-boot view
@@ -0,0 +1,13 @@+module PatSyn where++import BasicTypes (Arity)+import {-# SOURCE #-} TyCoRep (Type)+import Var (TyVar)+import Name (Name)++data PatSyn++patSynArity :: PatSyn -> Arity+patSynInstArgTys :: PatSyn -> [Type] -> [Type]+patSynExTyVars :: PatSyn -> [TyVar]+patSynName :: PatSyn -> Name
+ basicTypes/RdrName.hs view
@@ -0,0 +1,1243 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++{-# LANGUAGE CPP, DeriveDataTypeable #-}++-- |+-- #name_types#+-- GHC uses several kinds of name internally:+--+-- * 'OccName.OccName': see "OccName#name_types"+--+-- * 'RdrName.RdrName' is the type of names that come directly from the parser. They+--   have not yet had their scoping and binding resolved by the renamer and can be+--   thought of to a first approximation as an 'OccName.OccName' with an optional module+--   qualifier+--+-- * 'Name.Name': see "Name#name_types"+--+-- * 'Id.Id': see "Id#name_types"+--+-- * 'Var.Var': see "Var#name_types"++module RdrName (+        -- * The main type+        RdrName(..),    -- Constructors exported only to BinIface++        -- ** Construction+        mkRdrUnqual, mkRdrQual,+        mkUnqual, mkVarUnqual, mkQual, mkOrig,+        nameRdrName, getRdrName,++        -- ** Destruction+        rdrNameOcc, rdrNameSpace, demoteRdrName,+        isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual,+        isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName,++        -- * Local mapping of 'RdrName' to 'Name.Name'+        LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList,+        lookupLocalRdrEnv, lookupLocalRdrOcc,+        elemLocalRdrEnv, inLocalRdrEnvScope,+        localRdrEnvElts, delLocalRdrEnvList,++        -- * Global mapping of 'RdrName' to 'GlobalRdrElt's+        GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv,+        lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames,+        pprGlobalRdrEnv, globalRdrEnvElts,+        lookupGRE_RdrName, lookupGRE_Name, lookupGRE_FieldLabel,+        getGRE_NameQualifier_maybes,+        transformGREs, pickGREs, pickGREsModExp,++        -- * GlobalRdrElts+        gresFromAvails, gresFromAvail, localGREsFromAvail, availFromGRE,+        greUsedRdrName, greRdrNames, greSrcSpan, greQualModName,+        gresToAvailInfo,++        -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec'+        GlobalRdrElt(..), isLocalGRE, isRecFldGRE, greLabel,+        unQualOK, qualSpecOK, unQualSpecOK,+        pprNameProvenance,+        Parent(..),+        ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),+        importSpecLoc, importSpecModule, isExplicitItem, bestImport+  ) where++#include "HsVersions.h"++import Module+import Name+import Avail+import NameSet+import Maybes+import SrcLoc+import FastString+import FieldLabel+import Outputable+import Unique+import UniqFM+import UniqSet+import Util+import NameEnv++import Data.Data+import Data.List( sortBy, foldl', nub )++{-+************************************************************************+*                                                                      *+\subsection{The main data type}+*                                                                      *+************************************************************************+-}++-- | Reader Name+--+-- Do not use the data constructors of RdrName directly: prefer the family+-- of functions that creates them, such as 'mkRdrUnqual'+--+-- - Note: A Located RdrName will only have API Annotations if it is a+--         compound one,+--   e.g.+--+-- > `bar`+-- > ( ~ )+--+-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',+--           'ApiAnnotation.AnnOpen'  @'('@ or @'['@ or @'[:'@,+--           'ApiAnnotation.AnnClose' @')'@ or @']'@ or @':]'@,,+--           'ApiAnnotation.AnnBackquote' @'`'@,+--           'ApiAnnotation.AnnVal','ApiAnnotation.AnnTildehsh',+--           'ApiAnnotation.AnnTilde',++-- For details on above see note [Api annotations] in ApiAnnotation+data RdrName+  = Unqual OccName+        -- ^ Unqualified  name+        --+        -- Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@.+        -- Create such a 'RdrName' with 'mkRdrUnqual'++  | Qual ModuleName OccName+        -- ^ Qualified name+        --+        -- A qualified name written by the user in+        -- /source/ code.  The module isn't necessarily+        -- the module where the thing is defined;+        -- just the one from which it is imported.+        -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@.+        -- Create such a 'RdrName' with 'mkRdrQual'++  | Orig Module OccName+        -- ^ Original name+        --+        -- An original name; the module is the /defining/ module.+        -- This is used when GHC generates code that will be fed+        -- into the renamer (e.g. from deriving clauses), but where+        -- we want to say \"Use Prelude.map dammit\". One of these+        -- can be created with 'mkOrig'++  | Exact Name+        -- ^ Exact name+        --+        -- We know exactly the 'Name'. This is used:+        --+        --  (1) When the parser parses built-in syntax like @[]@+        --      and @(,)@, but wants a 'RdrName' from it+        --+        --  (2) By Template Haskell, when TH has generated a unique name+        --+        -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name'+  deriving Data++{-+************************************************************************+*                                                                      *+\subsection{Simple functions}+*                                                                      *+************************************************************************+-}++instance HasOccName RdrName where+  occName = rdrNameOcc++rdrNameOcc :: RdrName -> OccName+rdrNameOcc (Qual _ occ) = occ+rdrNameOcc (Unqual occ) = occ+rdrNameOcc (Orig _ occ) = occ+rdrNameOcc (Exact name) = nameOccName name++rdrNameSpace :: RdrName -> NameSpace+rdrNameSpace = occNameSpace . rdrNameOcc++-- demoteRdrName lowers the NameSpace of RdrName.+-- see Note [Demotion] in OccName+demoteRdrName :: RdrName -> Maybe RdrName+demoteRdrName (Unqual occ) = fmap Unqual (demoteOccName occ)+demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ)+demoteRdrName (Orig _ _) = panic "demoteRdrName"+demoteRdrName (Exact _) = panic "demoteRdrName"++        -- These two are the basic constructors+mkRdrUnqual :: OccName -> RdrName+mkRdrUnqual occ = Unqual occ++mkRdrQual :: ModuleName -> OccName -> RdrName+mkRdrQual mod occ = Qual mod occ++mkOrig :: Module -> OccName -> RdrName+mkOrig mod occ = Orig mod occ++---------------+        -- These two are used when parsing source files+        -- They do encode the module and occurrence names+mkUnqual :: NameSpace -> FastString -> RdrName+mkUnqual sp n = Unqual (mkOccNameFS sp n)++mkVarUnqual :: FastString -> RdrName+mkVarUnqual n = Unqual (mkVarOccFS n)++-- | Make a qualified 'RdrName' in the given namespace and where the 'ModuleName' and+-- the 'OccName' are taken from the first and second elements of the tuple respectively+mkQual :: NameSpace -> (FastString, FastString) -> RdrName+mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccNameFS sp n)++getRdrName :: NamedThing thing => thing -> RdrName+getRdrName name = nameRdrName (getName name)++nameRdrName :: Name -> RdrName+nameRdrName name = Exact name+-- Keep the Name even for Internal names, so that the+-- unique is still there for debug printing, particularly+-- of Types (which are converted to IfaceTypes before printing)++nukeExact :: Name -> RdrName+nukeExact n+  | isExternalName n = Orig (nameModule n) (nameOccName n)+  | otherwise        = Unqual (nameOccName n)++isRdrDataCon :: RdrName -> Bool+isRdrTyVar   :: RdrName -> Bool+isRdrTc      :: RdrName -> Bool++isRdrDataCon rn = isDataOcc (rdrNameOcc rn)+isRdrTyVar   rn = isTvOcc   (rdrNameOcc rn)+isRdrTc      rn = isTcOcc   (rdrNameOcc rn)++isSrcRdrName :: RdrName -> Bool+isSrcRdrName (Unqual _) = True+isSrcRdrName (Qual _ _) = True+isSrcRdrName _          = False++isUnqual :: RdrName -> Bool+isUnqual (Unqual _) = True+isUnqual _          = False++isQual :: RdrName -> Bool+isQual (Qual _ _) = True+isQual _          = False++isQual_maybe :: RdrName -> Maybe (ModuleName, OccName)+isQual_maybe (Qual m n) = Just (m,n)+isQual_maybe _          = Nothing++isOrig :: RdrName -> Bool+isOrig (Orig _ _) = True+isOrig _          = False++isOrig_maybe :: RdrName -> Maybe (Module, OccName)+isOrig_maybe (Orig m n) = Just (m,n)+isOrig_maybe _          = Nothing++isExact :: RdrName -> Bool+isExact (Exact _) = True+isExact _         = False++isExact_maybe :: RdrName -> Maybe Name+isExact_maybe (Exact n) = Just n+isExact_maybe _         = Nothing++{-+************************************************************************+*                                                                      *+\subsection{Instances}+*                                                                      *+************************************************************************+-}++instance Outputable RdrName where+    ppr (Exact name)   = ppr name+    ppr (Unqual occ)   = ppr occ+    ppr (Qual mod occ) = ppr mod <> dot <> ppr occ+    ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod occ <> ppr occ)++instance OutputableBndr RdrName where+    pprBndr _ n+        | isTvOcc (rdrNameOcc n) = char '@' <+> ppr n+        | otherwise              = ppr n++    pprInfixOcc  rdr = pprInfixVar  (isSymOcc (rdrNameOcc rdr)) (ppr rdr)+    pprPrefixOcc rdr+      | Just name <- isExact_maybe rdr = pprPrefixName name+             -- pprPrefixName has some special cases, so+             -- we delegate to them rather than reproduce them+      | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr)++instance Eq RdrName where+    (Exact n1)    == (Exact n2)    = n1==n2+        -- Convert exact to orig+    (Exact n1)    == r2@(Orig _ _) = nukeExact n1 == r2+    r1@(Orig _ _) == (Exact n2)    = r1 == nukeExact n2++    (Orig m1 o1)  == (Orig m2 o2)  = m1==m2 && o1==o2+    (Qual m1 o1)  == (Qual m2 o2)  = m1==m2 && o1==o2+    (Unqual o1)   == (Unqual o2)   = o1==o2+    _             == _             = False++instance Ord RdrName where+    a <= b = case (a `compare` b) of { LT -> True;  EQ -> True;  GT -> False }+    a <  b = case (a `compare` b) of { LT -> True;  EQ -> False; GT -> False }+    a >= b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }+    a >  b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }++        -- Exact < Unqual < Qual < Orig+        -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig+        --      before comparing so that Prelude.map == the exact Prelude.map, but+        --      that meant that we reported duplicates when renaming bindings+        --      generated by Template Haskell; e.g+        --      do { n1 <- newName "foo"; n2 <- newName "foo";+        --           <decl involving n1,n2> }+        --      I think we can do without this conversion+    compare (Exact n1) (Exact n2) = n1 `compare` n2+    compare (Exact _)  _          = LT++    compare (Unqual _)   (Exact _)    = GT+    compare (Unqual o1)  (Unqual  o2) = o1 `compare` o2+    compare (Unqual _)   _            = LT++    compare (Qual _ _)   (Exact _)    = GT+    compare (Qual _ _)   (Unqual _)   = GT+    compare (Qual m1 o1) (Qual m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2)+    compare (Qual _ _)   (Orig _ _)   = LT++    compare (Orig m1 o1) (Orig m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2)+    compare (Orig _ _)   _            = GT++{-+************************************************************************+*                                                                      *+                        LocalRdrEnv+*                                                                      *+************************************************************************+-}++-- | Local Reader Environment+--+-- This environment is used to store local bindings+-- (@let@, @where@, lambda, @case@).+-- It is keyed by OccName, because we never use it for qualified names+-- We keep the current mapping, *and* the set of all Names in scope+-- Reason: see Note [Splicing Exact names] in RnEnv+data LocalRdrEnv = LRE { lre_env      :: OccEnv Name+                       , lre_in_scope :: NameSet }++instance Outputable LocalRdrEnv where+  ppr (LRE {lre_env = env, lre_in_scope = ns})+    = hang (text "LocalRdrEnv {")+         2 (vcat [ text "env =" <+> pprOccEnv ppr_elt env+                 , text "in_scope ="+                    <+> pprUFM (getUniqSet ns) (braces . pprWithCommas ppr)+                 ] <+> char '}')+    where+      ppr_elt name = parens (ppr (getUnique (nameOccName name))) <+> ppr name+                     -- So we can see if the keys line up correctly++emptyLocalRdrEnv :: LocalRdrEnv+emptyLocalRdrEnv = LRE { lre_env = emptyOccEnv+                       , lre_in_scope = emptyNameSet }++extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv+-- The Name should be a non-top-level thing+extendLocalRdrEnv lre@(LRE { lre_env = env, lre_in_scope = ns }) name+  = WARN( isExternalName name, ppr name )+    lre { lre_env      = extendOccEnv env (nameOccName name) name+        , lre_in_scope = extendNameSet ns name }++extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv+extendLocalRdrEnvList lre@(LRE { lre_env = env, lre_in_scope = ns }) names+  = WARN( any isExternalName names, ppr names )+    lre { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names]+        , lre_in_scope = extendNameSetList ns names }++lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name+lookupLocalRdrEnv (LRE { lre_env = env, lre_in_scope = ns }) rdr+  | Unqual occ <- rdr+  = lookupOccEnv env occ++  -- See Note [Local bindings with Exact Names]+  | Exact name <- rdr+  , name `elemNameSet` ns+  = Just name++  | otherwise+  = Nothing++lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name+lookupLocalRdrOcc (LRE { lre_env = env }) occ = lookupOccEnv env occ++elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool+elemLocalRdrEnv rdr_name (LRE { lre_env = env, lre_in_scope = ns })+  = case rdr_name of+      Unqual occ -> occ  `elemOccEnv` env+      Exact name -> name `elemNameSet` ns  -- See Note [Local bindings with Exact Names]+      Qual {} -> False+      Orig {} -> False++localRdrEnvElts :: LocalRdrEnv -> [Name]+localRdrEnvElts (LRE { lre_env = env }) = occEnvElts env++inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool+-- This is the point of the NameSet+inLocalRdrEnvScope name (LRE { lre_in_scope = ns }) = name `elemNameSet` ns++delLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv+delLocalRdrEnvList lre@(LRE { lre_env = env }) occs+  = lre { lre_env = delListFromOccEnv env occs }++{-+Note [Local bindings with Exact Names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+With Template Haskell we can make local bindings that have Exact Names.+Computing shadowing etc may use elemLocalRdrEnv (at least it certainly+does so in RnTpes.bindHsQTyVars), so for an Exact Name we must consult+the in-scope-name-set.+++************************************************************************+*                                                                      *+                        GlobalRdrEnv+*                                                                      *+************************************************************************+-}++-- | Global Reader Environment+type GlobalRdrEnv = OccEnv [GlobalRdrElt]+-- ^ Keyed by 'OccName'; when looking up a qualified name+-- we look up the 'OccName' part, and then check the 'Provenance'+-- to see if the appropriate qualification is valid.  This+-- saves routinely doubling the size of the env by adding both+-- qualified and unqualified names to the domain.+--+-- The list in the codomain is required because there may be name clashes+-- These only get reported on lookup, not on construction+--+-- INVARIANT 1: All the members of the list have distinct+--              'gre_name' fields; that is, no duplicate Names+--+-- INVARIANT 2: Imported provenance => Name is an ExternalName+--              However LocalDefs can have an InternalName.  This+--              happens only when type-checking a [d| ... |] Template+--              Haskell quotation; see this note in RnNames+--              Note [Top-level Names in Template Haskell decl quotes]+--+-- INVARIANT 3: If the GlobalRdrEnv maps [occ -> gre], then+--                 greOccName gre = occ+--+--              NB: greOccName gre is usually the same as+--                  nameOccName (gre_name gre), but not always in the+--                  case of record seectors; see greOccName++-- | Global Reader Element+--+-- An element of the 'GlobalRdrEnv'+data GlobalRdrElt+  = GRE { gre_name :: Name+        , gre_par  :: Parent+        , gre_lcl :: Bool          -- ^ True <=> the thing was defined locally+        , gre_imp :: [ImportSpec]  -- ^ In scope through these imports+    } deriving (Data, Eq)+         -- INVARIANT: either gre_lcl = True or gre_imp is non-empty+         -- See Note [GlobalRdrElt provenance]++-- | The children of a Name are the things that are abbreviated by the ".."+--   notation in export lists.  See Note [Parents]+data Parent = NoParent+            | ParentIs  { par_is :: Name }+            | FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString }+              -- ^ See Note [Parents for record fields]+            deriving (Eq, Data, Typeable)++instance Outputable Parent where+   ppr NoParent        = empty+   ppr (ParentIs n)    = text "parent:" <> ppr n+   ppr (FldParent n f) = text "fldparent:"+                             <> ppr n <> colon <> ppr f++plusParent :: Parent -> Parent -> Parent+-- See Note [Combining parents]+plusParent p1@(ParentIs _)    p2 = hasParent p1 p2+plusParent p1@(FldParent _ _) p2 = hasParent p1 p2+plusParent p1 p2@(ParentIs _)    = hasParent p2 p1+plusParent p1 p2@(FldParent _ _) = hasParent p2 p1+plusParent _ _                   = NoParent++hasParent :: Parent -> Parent -> Parent+#ifdef DEBUG+hasParent p NoParent = p+hasParent p p'+  | p /= p' = pprPanic "hasParent" (ppr p <+> ppr p')  -- Parents should agree+#endif+hasParent p _  = p+++{- Note [GlobalRdrElt provenance]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The gre_lcl and gre_imp fields of a GlobalRdrElt describe its "provenance",+i.e. how the Name came to be in scope.  It can be in scope two ways:+  - gre_lcl = True: it is bound in this module+  - gre_imp: a list of all the imports that brought it into scope++It's an INVARIANT that you have one or the other; that is, either+gre_lcl is True, or gre_imp is non-empty.++It is just possible to have *both* if there is a module loop: a Name+is defined locally in A, and also brought into scope by importing a+module that SOURCE-imported A.  Exapmle (Trac #7672):++ A.hs-boot   module A where+               data T++ B.hs        module B(Decl.T) where+               import {-# SOURCE #-} qualified A as Decl++ A.hs        module A where+               import qualified B+               data T = Z | S B.T++In A.hs, 'T' is locally bound, *and* imported as B.T.++Note [Parents]+~~~~~~~~~~~~~~~~~+  Parent           Children+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  data T           Data constructors+                   Record-field ids++  data family T    Data constructors and record-field ids+                   of all visible data instances of T++  class C          Class operations+                   Associated type constructors++~~~~~~~~~~~~~~~~~~~~~~~~~+ Constructor      Meaning+ ~~~~~~~~~~~~~~~~~~~~~~~~+  NoParent        Can not be bundled with a type constructor.+  ParentIs n      Can be bundled with the type constructor corresponding to+                  n.+  FldParent       See Note [Parents for record fields]+++++Note [Parents for record fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For record fields, in addition to the Name of the type constructor+(stored in par_is), we use FldParent to store the field label.  This+extra information is used for identifying overloaded record fields+during renaming.++In a definition arising from a normal module (without+-XDuplicateRecordFields), par_lbl will be Nothing, meaning that the+field's label is the same as the OccName of the selector's Name.  The+GlobalRdrEnv will contain an entry like this:++    "x" |->  GRE x (FldParent T Nothing) LocalDef++When -XDuplicateRecordFields is enabled for the module that contains+T, the selector's Name will be mangled (see comments in FieldLabel).+Thus we store the actual field label in par_lbl, and the GlobalRdrEnv+entry looks like this:++    "x" |->  GRE $sel:x:MkT (FldParent T (Just "x")) LocalDef++Note that the OccName used when adding a GRE to the environment+(greOccName) now depends on the parent field: for FldParent it is the+field label, if present, rather than the selector name.++~~++Record pattern synonym selectors are treated differently. Their parent+information is `NoParent` in the module in which they are defined. This is because+a pattern synonym `P` has no parent constructor either.++However, if `f` is bundled with a type constructor `T` then whenever `f` is+imported the parent will use the `Parent` constructor so the parent of `f` is+now `T`.+++Note [Combining parents]+~~~~~~~~~~~~~~~~~~~~~~~~+With an associated type we might have+   module M where+     class C a where+       data T a+       op :: T a -> a+     instance C Int where+       data T Int = TInt+     instance C Bool where+       data T Bool = TBool++Then:   C is the parent of T+        T is the parent of TInt and TBool+So: in an export list+    C(..) is short for C( op, T )+    T(..) is short for T( TInt, TBool )++Module M exports everything, so its exports will be+   AvailTC C [C,T,op]+   AvailTC T [T,TInt,TBool]+On import we convert to GlobalRdrElt and then combine+those.  For T that will mean we have+  one GRE with Parent C+  one GRE with NoParent+That's why plusParent picks the "best" case.+-}++-- | make a 'GlobalRdrEnv' where all the elements point to the same+-- Provenance (useful for "hiding" imports, or imports with no details).+gresFromAvails :: Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt]+-- prov = Nothing   => locally bound+--        Just spec => imported as described by spec+gresFromAvails prov avails+  = concatMap (gresFromAvail (const prov)) avails++localGREsFromAvail :: AvailInfo -> [GlobalRdrElt]+-- Turn an Avail into a list of LocalDef GlobalRdrElts+localGREsFromAvail = gresFromAvail (const Nothing)++gresFromAvail :: (Name -> Maybe ImportSpec) -> AvailInfo -> [GlobalRdrElt]+gresFromAvail prov_fn avail+  = map mk_gre (availNonFldNames avail) ++ map mk_fld_gre (availFlds avail)+  where+    mk_gre n+      = case prov_fn n of  -- Nothing => bound locally+                           -- Just is => imported from 'is'+          Nothing -> GRE { gre_name = n, gre_par = mkParent n avail+                         , gre_lcl = True, gre_imp = [] }+          Just is -> GRE { gre_name = n, gre_par = mkParent n avail+                         , gre_lcl = False, gre_imp = [is] }++    mk_fld_gre (FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded+                           , flSelector = n })+      = case prov_fn n of  -- Nothing => bound locally+                           -- Just is => imported from 'is'+          Nothing -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl+                         , gre_lcl = True, gre_imp = [] }+          Just is -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl+                         , gre_lcl = False, gre_imp = [is] }+      where+        mb_lbl | is_overloaded = Just lbl+               | otherwise     = Nothing+++greQualModName :: GlobalRdrElt -> ModuleName+-- Get a suitable module qualifier for the GRE+-- (used in mkPrintUnqualified)+-- Prerecondition: the gre_name is always External+greQualModName gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss })+ | lcl, Just mod <- nameModule_maybe name = moduleName mod+ | (is:_) <- iss                          = is_as (is_decl is)+ | otherwise                              = pprPanic "greQualModName" (ppr gre)++greUsedRdrName :: GlobalRdrElt -> RdrName+-- For imported things, return a RdrName to add to the used-RdrName+-- set, which is used to generate unused-import-decl warnings.+-- Return a Qual RdrName if poss, so that identifies the most+-- specific ImportSpec.  See Trac #10890 for some good examples.+greUsedRdrName gre@GRE{ gre_name = name, gre_lcl = lcl, gre_imp = iss }+  | lcl, Just mod <- nameModule_maybe name = Qual (moduleName mod)     occ+  | not (null iss), is <- bestImport iss   = Qual (is_as (is_decl is)) occ+  | otherwise                              = pprTrace "greUsedRdrName" (ppr gre) (Unqual occ)+  where+    occ = greOccName gre++greRdrNames :: GlobalRdrElt -> [RdrName]+greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss }+  = (if lcl then [unqual] else []) ++ concatMap do_spec (map is_decl iss)+  where+    occ    = greOccName gre+    unqual = Unqual occ+    do_spec decl_spec+        | is_qual decl_spec = [qual]+        | otherwise         = [unqual,qual]+        where qual = Qual (is_as decl_spec) occ++-- the SrcSpan that pprNameProvenance prints out depends on whether+-- the Name is defined locally or not: for a local definition the+-- definition site is used, otherwise the location of the import+-- declaration.  We want to sort the export locations in+-- exportClashErr by this SrcSpan, we need to extract it:+greSrcSpan :: GlobalRdrElt -> SrcSpan+greSrcSpan gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss } )+  | lcl           = nameSrcSpan name+  | (is:_) <- iss = is_dloc (is_decl is)+  | otherwise     = pprPanic "greSrcSpan" (ppr gre)++mkParent :: Name -> AvailInfo -> Parent+mkParent _ (Avail _)           = NoParent+mkParent n (AvailTC m _ _) | n == m    = NoParent+                         | otherwise = ParentIs m++greParentName :: GlobalRdrElt -> Maybe Name+greParentName gre = case gre_par gre of+                      NoParent -> Nothing+                      ParentIs n -> Just n+                      FldParent n _ -> Just n++-- | Takes a list of distinct GREs and folds them+-- into AvailInfos. This is more efficient than mapping each individual+-- GRE to an AvailInfo and the folding using `plusAvail` but needs the+-- uniqueness assumption.+gresToAvailInfo :: [GlobalRdrElt] -> [AvailInfo]+gresToAvailInfo gres+  = ASSERT( nub gres == gres ) nameEnvElts avail_env+  where+    avail_env :: NameEnv AvailInfo -- keyed by the parent+    avail_env = foldl' add emptyNameEnv gres++    add :: NameEnv AvailInfo -> GlobalRdrElt -> NameEnv AvailInfo+    add env gre = extendNameEnv_Acc comb availFromGRE env+                    (fromMaybe (gre_name gre)+                               (greParentName gre)) gre++      where+        -- We want to insert the child `k` into a list of children but+        -- need to maintain the invariant that the parent is first.+        --+        -- We also use the invariant that `k` is not already in `ns`.+        insertChildIntoChildren :: Name -> [Name] -> Name -> [Name]+        insertChildIntoChildren _ [] k = [k]+        insertChildIntoChildren p (n:ns) k+          | p == k = k:n:ns+          | otherwise = n:k:ns++        comb :: GlobalRdrElt -> AvailInfo -> AvailInfo+        comb _ (Avail n) = Avail n -- Duplicated name+        comb gre (AvailTC m ns fls) =+          let n = gre_name gre+          in case gre_par gre of+              NoParent -> AvailTC m (n:ns) fls -- Not sure this ever happens+              ParentIs {} -> AvailTC m (insertChildIntoChildren m ns n) fls+              FldParent _ mb_lbl ->  AvailTC m ns (mkFieldLabel n mb_lbl : fls)++availFromGRE :: GlobalRdrElt -> AvailInfo+availFromGRE (GRE { gre_name = me, gre_par = parent })+  = case parent of+      ParentIs p                  -> AvailTC p [me] []+      NoParent   | isTyConName me -> AvailTC me [me] []+                 | otherwise      -> avail   me+      FldParent p mb_lbl -> AvailTC p [] [mkFieldLabel me mb_lbl]++mkFieldLabel :: Name -> Maybe FastString -> FieldLabel+mkFieldLabel me mb_lbl =+          case mb_lbl of+                 Nothing  -> FieldLabel { flLabel = occNameFS (nameOccName me)+                                        , flIsOverloaded = False+                                        , flSelector = me }+                 Just lbl -> FieldLabel { flLabel = lbl+                                        , flIsOverloaded = True+                                        , flSelector = me }++emptyGlobalRdrEnv :: GlobalRdrEnv+emptyGlobalRdrEnv = emptyOccEnv++globalRdrEnvElts :: GlobalRdrEnv -> [GlobalRdrElt]+globalRdrEnvElts env = foldOccEnv (++) [] env++instance Outputable GlobalRdrElt where+  ppr gre = hang (ppr (gre_name gre) <+> ppr (gre_par gre))+               2 (pprNameProvenance gre)++pprGlobalRdrEnv :: Bool -> GlobalRdrEnv -> SDoc+pprGlobalRdrEnv locals_only env+  = vcat [ text "GlobalRdrEnv" <+> ppWhen locals_only (ptext (sLit "(locals only)"))+             <+> lbrace+         , nest 2 (vcat [ pp (remove_locals gre_list) | gre_list <- occEnvElts env ]+             <+> rbrace) ]+  where+    remove_locals gres | locals_only = filter isLocalGRE gres+                       | otherwise   = gres+    pp []   = empty+    pp gres = hang (ppr occ+                     <+> parens (text "unique" <+> ppr (getUnique occ))+                     <> colon)+                 2 (vcat (map ppr gres))+      where+        occ = nameOccName (gre_name (head gres))++lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt]+lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of+                                  Nothing   -> []+                                  Just gres -> gres++greOccName :: GlobalRdrElt -> OccName+greOccName (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = mkVarOccFS lbl+greOccName gre                                            = nameOccName (gre_name gre)++lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt]+lookupGRE_RdrName rdr_name env+  = case lookupOccEnv env (rdrNameOcc rdr_name) of+    Nothing   -> []+    Just gres -> pickGREs rdr_name gres++lookupGRE_Name :: GlobalRdrEnv -> Name -> Maybe GlobalRdrElt+-- ^ Look for precisely this 'Name' in the environment.  This tests+-- whether it is in scope, ignoring anything else that might be in+-- scope with the same 'OccName'.+lookupGRE_Name env name+  = lookupGRE_Name_OccName env name (nameOccName name)++lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt+-- ^ Look for a particular record field selector in the environment, where the+-- selector name and field label may be different: the GlobalRdrEnv is keyed on+-- the label.  See Note [Parents for record fields] for why this happens.+lookupGRE_FieldLabel env fl+  = lookupGRE_Name_OccName env (flSelector fl) (mkVarOccFS (flLabel fl))++lookupGRE_Name_OccName :: GlobalRdrEnv -> Name -> OccName -> Maybe GlobalRdrElt+-- ^ Look for precisely this 'Name' in the environment, but with an 'OccName'+-- that might differ from that of the 'Name'.  See 'lookupGRE_FieldLabel' and+-- Note [Parents for record fields].+lookupGRE_Name_OccName env name occ+  = case [ gre | gre <- lookupGlobalRdrEnv env occ+               , gre_name gre == name ] of+      []    -> Nothing+      [gre] -> Just gre+      gres  -> pprPanic "lookupGRE_Name_OccName"+                        (ppr name $$ ppr occ $$ ppr gres)+               -- See INVARIANT 1 on GlobalRdrEnv+++getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]]+-- Returns all the qualifiers by which 'x' is in scope+-- Nothing means "the unqualified version is in scope"+-- [] means the thing is not in scope at all+getGRE_NameQualifier_maybes env name+  = case lookupGRE_Name env name of+      Just gre -> [qualifier_maybe gre]+      Nothing  -> []+  where+    qualifier_maybe (GRE { gre_lcl = lcl, gre_imp = iss })+      | lcl       = Nothing+      | otherwise = Just $ map (is_as . is_decl) iss++isLocalGRE :: GlobalRdrElt -> Bool+isLocalGRE (GRE {gre_lcl = lcl }) = lcl++isRecFldGRE :: GlobalRdrElt -> Bool+isRecFldGRE (GRE {gre_par = FldParent{}}) = True+isRecFldGRE _                             = False++-- Returns the field label of this GRE, if it has one+greLabel :: GlobalRdrElt -> Maybe FieldLabelString+greLabel (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = Just lbl+greLabel (GRE{gre_name = n, gre_par = FldParent{}})     = Just (occNameFS (nameOccName n))+greLabel _                                              = Nothing++unQualOK :: GlobalRdrElt -> Bool+-- ^ Test if an unqualified version of this thing would be in scope+unQualOK (GRE {gre_lcl = lcl, gre_imp = iss })+  | lcl = True+  | otherwise = any unQualSpecOK iss++{- Note [GRE filtering]+~~~~~~~~~~~~~~~~~~~~~~~+(pickGREs rdr gres) takes a list of GREs which have the same OccName+as 'rdr', say "x".  It does two things:++(a) filters the GREs to a subset that are in scope+    * Qualified,   as 'M.x'  if want_qual    is Qual M _+    * Unqualified, as 'x'    if want_unqual  is Unqual _++(b) for that subset, filter the provenance field (gre_lcl and gre_imp)+    to ones that brought it into scope qualified or unqualified resp.++Example:+      module A ( f ) where+      import qualified Foo( f )+      import Baz( f )+      f = undefined++Let's suppose that Foo.f and Baz.f are the same entity really, but the local+'f' is different, so there will be two GREs matching "f":+   gre1:  gre_lcl = True,  gre_imp = []+   gre2:  gre_lcl = False, gre_imp = [ imported from Foo, imported from Bar ]++The use of "f" in the export list is ambiguous because it's in scope+from the local def and the import Baz(f); but *not* the import qualified Foo.+pickGREs returns two GRE+   gre1:   gre_lcl = True,  gre_imp = []+   gre2:   gre_lcl = False, gre_imp = [ imported from Bar ]++Now the the "ambiguous occurrence" message can correctly report how the+ambiguity arises.+-}++pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt]+-- ^ Takes a list of GREs which have the right OccName 'x'+-- Pick those GREs that are are in scope+--    * Qualified,   as 'M.x'  if want_qual    is Qual M _+--    * Unqualified, as 'x'    if want_unqual  is Unqual _+--+-- Return each such GRE, with its ImportSpecs filtered, to reflect+-- how it is in scope qualified or unqualified respectively.+-- See Note [GRE filtering]+pickGREs (Unqual {})  gres = mapMaybe pickUnqualGRE     gres+pickGREs (Qual mod _) gres = mapMaybe (pickQualGRE mod) gres+pickGREs _            _    = []  -- I don't think this actually happens++pickUnqualGRE :: GlobalRdrElt -> Maybe GlobalRdrElt+pickUnqualGRE gre@(GRE { gre_lcl = lcl, gre_imp = iss })+  | not lcl, null iss' = Nothing+  | otherwise          = Just (gre { gre_imp = iss' })+  where+    iss' = filter unQualSpecOK iss++pickQualGRE :: ModuleName -> GlobalRdrElt -> Maybe GlobalRdrElt+pickQualGRE mod gre@(GRE { gre_name = n, gre_lcl = lcl, gre_imp = iss })+  | not lcl', null iss' = Nothing+  | otherwise           = Just (gre { gre_lcl = lcl', gre_imp = iss' })+  where+    iss' = filter (qualSpecOK mod) iss+    lcl' = lcl && name_is_from mod n++    name_is_from :: ModuleName -> Name -> Bool+    name_is_from mod name = case nameModule_maybe name of+                              Just n_mod -> moduleName n_mod == mod+                              Nothing    -> False++pickGREsModExp :: ModuleName -> [GlobalRdrElt] -> [(GlobalRdrElt,GlobalRdrElt)]+-- ^ Pick GREs that are in scope *both* qualified *and* unqualified+-- Return each GRE that is, as a pair+--    (qual_gre, unqual_gre)+-- These two GREs are the original GRE with imports filtered to express how+-- it is in scope qualified an unqualified respectively+--+-- Used only for the 'module M' item in export list;+--   see RnNames.exports_from_avail+pickGREsModExp mod gres = mapMaybe (pickBothGRE mod) gres++pickBothGRE :: ModuleName -> GlobalRdrElt -> Maybe (GlobalRdrElt, GlobalRdrElt)+pickBothGRE mod gre@(GRE { gre_name = n })+  | isBuiltInSyntax n                = Nothing+  | Just gre1 <- pickQualGRE mod gre+  , Just gre2 <- pickUnqualGRE   gre = Just (gre1, gre2)+  | otherwise                        = Nothing+  where+        -- isBuiltInSyntax filter out names for built-in syntax They+        -- just clutter up the environment (esp tuples), and the+        -- parser will generate Exact RdrNames for them, so the+        -- cluttered envt is no use.  Really, it's only useful for+        -- GHC.Base and GHC.Tuple.++-- Building GlobalRdrEnvs++plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv+plusGlobalRdrEnv env1 env2 = plusOccEnv_C (foldr insertGRE) env1 env2++mkGlobalRdrEnv :: [GlobalRdrElt] -> GlobalRdrEnv+mkGlobalRdrEnv gres+  = foldr add emptyGlobalRdrEnv gres+  where+    add gre env = extendOccEnv_Acc insertGRE singleton env+                                   (greOccName gre)+                                   gre++insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt]+insertGRE new_g [] = [new_g]+insertGRE new_g (old_g : old_gs)+        | gre_name new_g == gre_name old_g+        = new_g `plusGRE` old_g : old_gs+        | otherwise+        = old_g : insertGRE new_g old_gs++plusGRE :: GlobalRdrElt -> GlobalRdrElt -> GlobalRdrElt+-- Used when the gre_name fields match+plusGRE g1 g2+  = GRE { gre_name = gre_name g1+        , gre_lcl  = gre_lcl g1 || gre_lcl g2+        , gre_imp  = gre_imp g1 ++ gre_imp g2+        , gre_par  = gre_par  g1 `plusParent` gre_par  g2 }++transformGREs :: (GlobalRdrElt -> GlobalRdrElt)+              -> [OccName]+              -> GlobalRdrEnv -> GlobalRdrEnv+-- ^ Apply a transformation function to the GREs for these OccNames+transformGREs trans_gre occs rdr_env+  = foldr trans rdr_env occs+  where+    trans occ env+      = case lookupOccEnv env occ of+           Just gres -> extendOccEnv env occ (map trans_gre gres)+           Nothing   -> env++extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv+extendGlobalRdrEnv env gre+  = extendOccEnv_Acc insertGRE singleton env+                     (greOccName gre) gre++shadowNames :: GlobalRdrEnv -> [Name] -> GlobalRdrEnv+shadowNames = foldl shadowName++{- Note [GlobalRdrEnv shadowing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Before adding new names to the GlobalRdrEnv we nuke some existing entries;+this is "shadowing".  The actual work is done by RdrEnv.shadowNames.+There are two reasons for shadowing:++* The GHCi REPL++  - Ids bought into scope on the command line (eg let x = True) have+    External Names, like Ghci4.x.  We want a new binding for 'x' (say)+    to override the existing binding for 'x'.+    See Note [Interactively-bound Ids in GHCi] in HscTypes++  - Data types also have Extenal Names, like Ghci4.T; but we still want+    'T' to mean the newly-declared 'T', not an old one.++* Nested Template Haskell declaration brackets+  See Note [Top-level Names in Template Haskell decl quotes] in RnNames++  Consider a TH decl quote:+      module M where+        f x = h [d| f = 3 |]+  We must shadow the outer declaration of 'f', else we'll get a+  complaint when extending the GlobalRdrEnv, saying that there are two+  bindings for 'f'.  There are several tricky points:++    - This shadowing applies even if the binding for 'f' is in a+      where-clause, and hence is in the *local* RdrEnv not the *global*+      RdrEnv.  This is done in lcl_env_TH in extendGlobalRdrEnvRn.++    - The External Name M.f from the enclosing module must certainly+      still be available.  So we don't nuke it entirely; we just make+      it seem like qualified import.++    - We only shadow *External* names (which come from the main module),+      or from earlier GHCi commands. Do not shadow *Internal* names+      because in the bracket+          [d| class C a where f :: a+              f = 4 |]+      rnSrcDecls will first call extendGlobalRdrEnvRn with C[f] from the+      class decl, and *separately* extend the envt with the value binding.+      At that stage, the class op 'f' will have an Internal name.+-}++shadowName :: GlobalRdrEnv -> Name -> GlobalRdrEnv+-- Remove certain old GREs that share the same OccName as this new Name.+-- See Note [GlobalRdrEnv shadowing] for details+shadowName env name+  = alterOccEnv (fmap alter_fn) env (nameOccName name)+  where+    alter_fn :: [GlobalRdrElt] -> [GlobalRdrElt]+    alter_fn gres = mapMaybe (shadow_with name) gres++    shadow_with :: Name -> GlobalRdrElt -> Maybe GlobalRdrElt+    shadow_with new_name+       old_gre@(GRE { gre_name = old_name, gre_lcl = lcl, gre_imp = iss })+       = case nameModule_maybe old_name of+           Nothing -> Just old_gre   -- Old name is Internal; do not shadow+           Just old_mod+              | Just new_mod <- nameModule_maybe new_name+              , new_mod == old_mod   -- Old name same as new name; shadow completely+              -> Nothing++              | null iss'            -- Nothing remains+              -> Nothing++              | otherwise+              -> Just (old_gre { gre_lcl = False, gre_imp = iss' })++              where+                iss' = lcl_imp ++ mapMaybe (shadow_is new_name) iss+                lcl_imp | lcl       = [mk_fake_imp_spec old_name old_mod]+                        | otherwise = []++    mk_fake_imp_spec old_name old_mod    -- Urgh!+      = ImpSpec id_spec ImpAll+      where+        old_mod_name = moduleName old_mod+        id_spec      = ImpDeclSpec { is_mod = old_mod_name+                                   , is_as = old_mod_name+                                   , is_qual = True+                                   , is_dloc = nameSrcSpan old_name }++    shadow_is :: Name -> ImportSpec -> Maybe ImportSpec+    shadow_is new_name is@(ImpSpec { is_decl = id_spec })+       | Just new_mod <- nameModule_maybe new_name+       , is_as id_spec == moduleName new_mod+       = Nothing   -- Shadow both qualified and unqualified+       | otherwise -- Shadow unqualified only+       = Just (is { is_decl = id_spec { is_qual = True } })+++{-+************************************************************************+*                                                                      *+                        ImportSpec+*                                                                      *+************************************************************************+-}++-- | Import Specification+--+-- The 'ImportSpec' of something says how it came to be imported+-- It's quite elaborate so that we can give accurate unused-name warnings.+data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec,+                            is_item :: ImpItemSpec }+                deriving( Eq, Ord, Data )++-- | Import Declaration Specification+--+-- Describes a particular import declaration and is+-- shared among all the 'Provenance's for that decl+data ImpDeclSpec+  = ImpDeclSpec {+        is_mod      :: ModuleName, -- ^ Module imported, e.g. @import Muggle@+                                   -- Note the @Muggle@ may well not be+                                   -- the defining module for this thing!++                                   -- TODO: either should be Module, or there+                                   -- should be a Maybe UnitId here too.+        is_as       :: ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause)+        is_qual     :: Bool,       -- ^ Was this import qualified?+        is_dloc     :: SrcSpan     -- ^ The location of the entire import declaration+    } deriving Data++-- | Import Item Specification+--+-- Describes import info a particular Name+data ImpItemSpec+  = ImpAll              -- ^ The import had no import list,+                        -- or had a hiding list++  | ImpSome {+        is_explicit :: Bool,+        is_iloc     :: SrcSpan  -- Location of the import item+    }   -- ^ The import had an import list.+        -- The 'is_explicit' field is @True@ iff the thing was named+        -- /explicitly/ in the import specs rather+        -- than being imported as part of a "..." group. Consider:+        --+        -- > import C( T(..) )+        --+        -- Here the constructors of @T@ are not named explicitly;+        -- only @T@ is named explicitly.+  deriving Data++instance Eq ImpDeclSpec where+  p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False++instance Ord ImpDeclSpec where+   compare is1 is2 = (is_mod is1 `compare` is_mod is2) `thenCmp`+                     (is_dloc is1 `compare` is_dloc is2)++instance Eq ImpItemSpec where+  p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False++instance Ord ImpItemSpec where+   compare is1 is2 =+    case (is1, is2) of+      (ImpAll, ImpAll) -> EQ+      (ImpAll, _)      -> GT+      (_, ImpAll)      -> LT+      (ImpSome _ l1, ImpSome _ l2) -> l1 `compare` l2+++bestImport :: [ImportSpec] -> ImportSpec+-- Given a non-empty bunch of ImportSpecs, return the one that+-- imported the item most specifically (e.g. by name), using+-- textually-first as a tie breaker. This is used when reporting+-- redundant imports+bestImport iss+  = case sortBy best iss of+      (is:_) -> is+      []     -> pprPanic "bestImport" (ppr iss)+  where+    best :: ImportSpec -> ImportSpec -> Ordering+    -- Less means better+    best (ImpSpec { is_item = item1, is_decl = d1 })+         (ImpSpec { is_item = item2, is_decl = d2 })+      = best_item item1 item2 `thenCmp` (is_dloc d1 `compare` is_dloc d2)++    best_item :: ImpItemSpec -> ImpItemSpec -> Ordering+    best_item ImpAll ImpAll = EQ+    best_item ImpAll (ImpSome {}) = GT+    best_item (ImpSome {}) ImpAll = LT+    best_item (ImpSome { is_explicit = e1 })+              (ImpSome { is_explicit = e2 }) = e2 `compare` e1+     -- False < True, so if e1 is explicit and e2 is not, we get LT++unQualSpecOK :: ImportSpec -> Bool+-- ^ Is in scope unqualified?+unQualSpecOK is = not (is_qual (is_decl is))++qualSpecOK :: ModuleName -> ImportSpec -> Bool+-- ^ Is in scope qualified with the given module?+qualSpecOK mod is = mod == is_as (is_decl is)++importSpecLoc :: ImportSpec -> SrcSpan+importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl+importSpecLoc (ImpSpec _    item)   = is_iloc item++importSpecModule :: ImportSpec -> ModuleName+importSpecModule is = is_mod (is_decl is)++isExplicitItem :: ImpItemSpec -> Bool+isExplicitItem ImpAll                        = False+isExplicitItem (ImpSome {is_explicit = exp}) = exp++pprNameProvenance :: GlobalRdrElt -> SDoc+-- ^ Print out one place where the name was define/imported+-- (With -dppr-debug, print them all)+pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss })+  = sdocWithPprDebug $ \dbg -> if dbg+      then vcat pp_provs+      else head pp_provs+  where+    pp_provs = pp_lcl ++ map pp_is iss+    pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)]+                    else []+    pp_is is = sep [ppr is, ppr_defn_site is name]++-- If we know the exact definition point (which we may do with GHCi)+-- then show that too.  But not if it's just "imported from X".+ppr_defn_site :: ImportSpec -> Name -> SDoc+ppr_defn_site imp_spec name+  | same_module && not (isGoodSrcSpan loc)+  = empty              -- Nothing interesting to say+  | otherwise+  = parens $ hang (text "and originally defined" <+> pp_mod)+                2 (pprLoc loc)+  where+    loc = nameSrcSpan name+    defining_mod = ASSERT2( isExternalName name, ppr name ) nameModule name+    same_module = importSpecModule imp_spec == moduleName defining_mod+    pp_mod | same_module = empty+           | otherwise   = text "in" <+> quotes (ppr defining_mod)+++instance Outputable ImportSpec where+   ppr imp_spec+     = text "imported" <+> qual+        <+> text "from" <+> quotes (ppr (importSpecModule imp_spec))+        <+> pprLoc (importSpecLoc imp_spec)+     where+       qual | is_qual (is_decl imp_spec) = text "qualified"+            | otherwise                  = empty++pprLoc :: SrcSpan -> SDoc+pprLoc (RealSrcSpan s)    = text "at" <+> ppr s+pprLoc (UnhelpfulSpan {}) = empty
+ basicTypes/SrcLoc.hs view
@@ -0,0 +1,587 @@+-- (c) The University of Glasgow, 1992-2006++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveFunctor      #-}+{-# LANGUAGE DeriveFoldable     #-}+{-# LANGUAGE DeriveTraversable  #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE RecordWildCards    #-}+{-# OPTIONS_GHC -fno-omit-interface-pragmas #-}+   -- Workaround for Trac #5252 crashes the bootstrap compiler without -O+   -- When the earliest compiler we want to boostrap with is+   -- GHC 7.2, we can make RealSrcLoc properly abstract++-- | This module contains types that relate to the positions of things+-- in source files, and allow tagging of those things with locations+module SrcLoc (+        -- * SrcLoc+        RealSrcLoc,             -- Abstract+        SrcLoc(..),++        -- ** Constructing SrcLoc+        mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc,++        noSrcLoc,               -- "I'm sorry, I haven't a clue"+        generatedSrcLoc,        -- Code generated within the compiler+        interactiveSrcLoc,      -- Code from an interactive session++        advanceSrcLoc,++        -- ** Unsafely deconstructing SrcLoc+        -- These are dubious exports, because they crash on some inputs+        srcLocFile,             -- return the file name part+        srcLocLine,             -- return the line part+        srcLocCol,              -- return the column part++        -- * SrcSpan+        RealSrcSpan,            -- Abstract+        SrcSpan(..),++        -- ** Constructing SrcSpan+        mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan,+        noSrcSpan,+        wiredInSrcSpan,         -- Something wired into the compiler+        interactiveSrcSpan,+        srcLocSpan, realSrcLocSpan,+        combineSrcSpans,+        srcSpanFirstCharacter,++        -- ** Deconstructing SrcSpan+        srcSpanStart, srcSpanEnd,+        realSrcSpanStart, realSrcSpanEnd,+        srcSpanFileName_maybe,+        pprUserRealSpan,++        -- ** Unsafely deconstructing SrcSpan+        -- These are dubious exports, because they crash on some inputs+        srcSpanFile,+        srcSpanStartLine, srcSpanEndLine,+        srcSpanStartCol, srcSpanEndCol,++        -- ** Predicates on SrcSpan+        isGoodSrcSpan, isOneLineSpan,+        containsSpan,++        -- * Located+        Located,+        RealLocated,+        GenLocated(..),++        -- ** Constructing Located+        noLoc,+        mkGeneralLocated,++        -- ** Deconstructing Located+        getLoc, unLoc,++        -- ** Combining and comparing Located values+        eqLocated, cmpLocated, combineLocs, addCLoc,+        leftmost_smallest, leftmost_largest, rightmost,+        spans, isSubspanOf, sortLocated+    ) where++import Util+import Json+import Outputable+import FastString++import Control.DeepSeq+import Data.Bits+import Data.Data+import Data.List+import Data.Ord++{-+************************************************************************+*                                                                      *+\subsection[SrcLoc-SrcLocations]{Source-location information}+*                                                                      *+************************************************************************++We keep information about the {\em definition} point for each entity;+this is the obvious stuff:+-}++-- | Real Source Location+--+-- Represents a single point within a file+data RealSrcLoc+  = SrcLoc      FastString              -- A precise location (file name)+                {-# UNPACK #-} !Int     -- line number, begins at 1+                {-# UNPACK #-} !Int     -- column number, begins at 1+  deriving (Eq, Ord)++-- | Source Location+data SrcLoc+  = RealSrcLoc {-# UNPACK #-}!RealSrcLoc+  | UnhelpfulLoc FastString     -- Just a general indication+  deriving (Eq, Ord, Show)++{-+************************************************************************+*                                                                      *+\subsection[SrcLoc-access-fns]{Access functions}+*                                                                      *+************************************************************************+-}++mkSrcLoc :: FastString -> Int -> Int -> SrcLoc+mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col)++mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc+mkRealSrcLoc x line col = SrcLoc x line col++-- | Built-in "bad" 'SrcLoc' values for particular locations+noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc+noSrcLoc          = UnhelpfulLoc (fsLit "<no location info>")+generatedSrcLoc   = UnhelpfulLoc (fsLit "<compiler-generated code>")+interactiveSrcLoc = UnhelpfulLoc (fsLit "<interactive>")++-- | Creates a "bad" 'SrcLoc' that has no detailed information about its location+mkGeneralSrcLoc :: FastString -> SrcLoc+mkGeneralSrcLoc = UnhelpfulLoc++-- | Gives the filename of the 'RealSrcLoc'+srcLocFile :: RealSrcLoc -> FastString+srcLocFile (SrcLoc fname _ _) = fname++-- | Raises an error when used on a "bad" 'SrcLoc'+srcLocLine :: RealSrcLoc -> Int+srcLocLine (SrcLoc _ l _) = l++-- | Raises an error when used on a "bad" 'SrcLoc'+srcLocCol :: RealSrcLoc -> Int+srcLocCol (SrcLoc _ _ c) = c++-- | Move the 'SrcLoc' down by one line if the character is a newline,+-- to the next 8-char tabstop if it is a tab, and across by one+-- character in any other case+advanceSrcLoc :: RealSrcLoc -> Char -> RealSrcLoc+advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f  (l + 1) 1+advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f  l (((((c - 1) `shiftR` 3) + 1)+                                                  `shiftL` 3) + 1)+advanceSrcLoc (SrcLoc f l c) _    = SrcLoc f  l (c + 1)++{-+************************************************************************+*                                                                      *+\subsection[SrcLoc-instances]{Instance declarations for various names}+*                                                                      *+************************************************************************+-}++sortLocated :: [Located a] -> [Located a]+sortLocated things = sortBy (comparing getLoc) things++instance Outputable RealSrcLoc where+    ppr (SrcLoc src_path src_line src_col)+      = hcat [ pprFastFilePath src_path <> colon+             , int src_line <> colon+             , int src_col ]++-- I don't know why there is this style-based difference+--        if userStyle sty || debugStyle sty then+--            hcat [ pprFastFilePath src_path, char ':',+--                   int src_line,+--                   char ':', int src_col+--                 ]+--        else+--            hcat [text "{-# LINE ", int src_line, space,+--                  char '\"', pprFastFilePath src_path, text " #-}"]++instance Outputable SrcLoc where+    ppr (RealSrcLoc l) = ppr l+    ppr (UnhelpfulLoc s)  = ftext s++instance Data RealSrcSpan where+  -- don't traverse?+  toConstr _   = abstractConstr "RealSrcSpan"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "RealSrcSpan"++instance Data SrcSpan where+  -- don't traverse?+  toConstr _   = abstractConstr "SrcSpan"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "SrcSpan"++{-+************************************************************************+*                                                                      *+\subsection[SrcSpan]{Source Spans}+*                                                                      *+************************************************************************+-}++{- |+A 'RealSrcSpan' delimits a portion of a text file.  It could be represented+by a pair of (line,column) coordinates, but in fact we optimise+slightly by using more compact representations for single-line and+zero-length spans, both of which are quite common.++The end position is defined to be the column /after/ the end of the+span.  That is, a span of (1,1)-(1,2) is one character long, and a+span of (1,1)-(1,1) is zero characters long.+-}++-- | Real Source Span+data RealSrcSpan+  = RealSrcSpan'+        { srcSpanFile     :: !FastString,+          srcSpanSLine    :: {-# UNPACK #-} !Int,+          srcSpanSCol     :: {-# UNPACK #-} !Int,+          srcSpanELine    :: {-# UNPACK #-} !Int,+          srcSpanECol     :: {-# UNPACK #-} !Int+        }+  deriving Eq++-- | Source Span+--+-- A 'SrcSpan' identifies either a specific portion of a text file+-- or a human-readable description of a location.+data SrcSpan =+    RealSrcSpan !RealSrcSpan+  | UnhelpfulSpan !FastString   -- Just a general indication+                                -- also used to indicate an empty span++  deriving (Eq, Ord, Show) -- Show is used by Lexer.x, because we+                           -- derive Show for Token++instance ToJson SrcSpan where+  json (UnhelpfulSpan {} ) = JSNull --JSObject [( "type", "unhelpful")]+  json (RealSrcSpan rss)  = json rss++instance ToJson RealSrcSpan where+  json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile))+                                     , ("startLine", JSInt srcSpanSLine)+                                     , ("startCol", JSInt srcSpanSCol)+                                     , ("endLine", JSInt srcSpanELine)+                                     , ("endCol", JSInt srcSpanECol)+                                     ]++instance NFData SrcSpan where+  rnf x = x `seq` ()++-- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty+noSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan+noSrcSpan          = UnhelpfulSpan (fsLit "<no location info>")+wiredInSrcSpan     = UnhelpfulSpan (fsLit "<wired into compiler>")+interactiveSrcSpan = UnhelpfulSpan (fsLit "<interactive>")++-- | Create a "bad" 'SrcSpan' that has not location information+mkGeneralSrcSpan :: FastString -> SrcSpan+mkGeneralSrcSpan = UnhelpfulSpan++-- | Create a 'SrcSpan' corresponding to a single point+srcLocSpan :: SrcLoc -> SrcSpan+srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str+srcLocSpan (RealSrcLoc l) = RealSrcSpan (realSrcLocSpan l)++realSrcLocSpan :: RealSrcLoc -> RealSrcSpan+realSrcLocSpan (SrcLoc file line col) = RealSrcSpan' file line col line col++-- | Create a 'SrcSpan' between two points in a file+mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan+mkRealSrcSpan loc1 loc2 = RealSrcSpan' file line1 col1 line2 col2+  where+        line1 = srcLocLine loc1+        line2 = srcLocLine loc2+        col1 = srcLocCol loc1+        col2 = srcLocCol loc2+        file = srcLocFile loc1++-- | 'True' if the span is known to straddle only one line.+isOneLineRealSpan :: RealSrcSpan -> Bool+isOneLineRealSpan (RealSrcSpan' _ line1 _ line2 _)+  = line1 == line2++-- | 'True' if the span is a single point+isPointRealSpan :: RealSrcSpan -> Bool+isPointRealSpan (RealSrcSpan' _ line1 col1 line2 col2)+  = line1 == line2 && col1 == col2++-- | Create a 'SrcSpan' between two points in a file+mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan+mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str+mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str+mkSrcSpan (RealSrcLoc loc1) (RealSrcLoc loc2)+    = RealSrcSpan (mkRealSrcSpan loc1 loc2)++-- | Combines two 'SrcSpan' into one that spans at least all the characters+-- within both spans. Assumes the "file" part is the same in both inputs+combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan+combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful+combineSrcSpans l (UnhelpfulSpan _) = l+combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2)+    = RealSrcSpan (combineRealSrcSpans span1 span2)++-- | Combines two 'SrcSpan' into one that spans at least all the characters+-- within both spans. Assumes the "file" part is the same in both inputs+combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan+combineRealSrcSpans span1 span2+  = RealSrcSpan' file line_start col_start line_end col_end+  where+    (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1)+                                  (srcSpanStartLine span2, srcSpanStartCol span2)+    (line_end, col_end)     = max (srcSpanEndLine span1, srcSpanEndCol span1)+                                  (srcSpanEndLine span2, srcSpanEndCol span2)+    file = srcSpanFile span1++-- | Convert a SrcSpan into one that represents only its first character+srcSpanFirstCharacter :: SrcSpan -> SrcSpan+srcSpanFirstCharacter l@(UnhelpfulSpan {}) = l+srcSpanFirstCharacter (RealSrcSpan span) = RealSrcSpan $ mkRealSrcSpan loc1 loc2+  where+    loc1@(SrcLoc f l c) = realSrcSpanStart span+    loc2 = SrcLoc f l (c+1)+{-+************************************************************************+*                                                                      *+\subsection[SrcSpan-predicates]{Predicates}+*                                                                      *+************************************************************************+-}++-- | Test if a 'SrcSpan' is "good", i.e. has precise location information+isGoodSrcSpan :: SrcSpan -> Bool+isGoodSrcSpan (RealSrcSpan _) = True+isGoodSrcSpan (UnhelpfulSpan _) = False++isOneLineSpan :: SrcSpan -> Bool+-- ^ True if the span is known to straddle only one line.+-- For "bad" 'SrcSpan', it returns False+isOneLineSpan (RealSrcSpan s) = srcSpanStartLine s == srcSpanEndLine s+isOneLineSpan (UnhelpfulSpan _) = False++-- | Tests whether the first span "contains" the other span, meaning+-- that it covers at least as much source code. True where spans are equal.+containsSpan :: RealSrcSpan -> RealSrcSpan -> Bool+containsSpan s1 s2+  = (srcSpanStartLine s1, srcSpanStartCol s1)+       <= (srcSpanStartLine s2, srcSpanStartCol s2)+    && (srcSpanEndLine s1, srcSpanEndCol s1)+       >= (srcSpanEndLine s2, srcSpanEndCol s2)+    && (srcSpanFile s1 == srcSpanFile s2)+    -- We check file equality last because it is (presumably?) least+    -- likely to fail.+{-+%************************************************************************+%*                                                                      *+\subsection[SrcSpan-unsafe-access-fns]{Unsafe access functions}+*                                                                      *+************************************************************************+-}++srcSpanStartLine :: RealSrcSpan -> Int+srcSpanEndLine :: RealSrcSpan -> Int+srcSpanStartCol :: RealSrcSpan -> Int+srcSpanEndCol :: RealSrcSpan -> Int++srcSpanStartLine RealSrcSpan'{ srcSpanSLine=l } = l+srcSpanEndLine RealSrcSpan'{ srcSpanELine=l } = l+srcSpanStartCol RealSrcSpan'{ srcSpanSCol=l } = l+srcSpanEndCol RealSrcSpan'{ srcSpanECol=c } = c++{-+************************************************************************+*                                                                      *+\subsection[SrcSpan-access-fns]{Access functions}+*                                                                      *+************************************************************************+-}++-- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable+srcSpanStart :: SrcSpan -> SrcLoc+srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str+srcSpanStart (RealSrcSpan s) = RealSrcLoc (realSrcSpanStart s)++-- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable+srcSpanEnd :: SrcSpan -> SrcLoc+srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str+srcSpanEnd (RealSrcSpan s) = RealSrcLoc (realSrcSpanEnd s)++realSrcSpanStart :: RealSrcSpan -> RealSrcLoc+realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s)+                                  (srcSpanStartLine s)+                                  (srcSpanStartCol s)++realSrcSpanEnd :: RealSrcSpan -> RealSrcLoc+realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s)+                                (srcSpanEndLine s)+                                (srcSpanEndCol s)++-- | Obtains the filename for a 'SrcSpan' if it is "good"+srcSpanFileName_maybe :: SrcSpan -> Maybe FastString+srcSpanFileName_maybe (RealSrcSpan s)   = Just (srcSpanFile s)+srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing++{-+************************************************************************+*                                                                      *+\subsection[SrcSpan-instances]{Instances}+*                                                                      *+************************************************************************+-}++-- We want to order RealSrcSpans first by the start point, then by the+-- end point.+instance Ord RealSrcSpan where+  a `compare` b =+     (realSrcSpanStart a `compare` realSrcSpanStart b) `thenCmp`+     (realSrcSpanEnd   a `compare` realSrcSpanEnd   b)++instance Show RealSrcLoc where+  show (SrcLoc filename row col)+      = "SrcLoc " ++ show filename ++ " " ++ show row ++ " " ++ show col++-- Show is used by Lexer.x, because we derive Show for Token+instance Show RealSrcSpan where+  show span@(RealSrcSpan' file sl sc el ec)+    | isPointRealSpan span+    = "SrcSpanPoint " ++ show file ++ " " ++ intercalate " " (map show [sl,sc])++    | isOneLineRealSpan span+    = "SrcSpanOneLine " ++ show file ++ " "+                        ++ intercalate " " (map show [sl,sc,ec])++    | otherwise+    = "SrcSpanMultiLine " ++ show file ++ " "+                          ++ intercalate " " (map show [sl,sc,el,ec])+++instance Outputable RealSrcSpan where+    ppr span = pprUserRealSpan True span++-- I don't know why there is this style-based difference+--      = getPprStyle $ \ sty ->+--        if userStyle sty || debugStyle sty then+--           text (showUserRealSpan True span)+--        else+--           hcat [text "{-# LINE ", int (srcSpanStartLine span), space,+--                 char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"]++instance Outputable SrcSpan where+    ppr span = pprUserSpan True span++-- I don't know why there is this style-based difference+--      = getPprStyle $ \ sty ->+--        if userStyle sty || debugStyle sty then+--           pprUserSpan True span+--        else+--           case span of+--           UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan"+--           RealSrcSpan s -> ppr s++pprUserSpan :: Bool -> SrcSpan -> SDoc+pprUserSpan _         (UnhelpfulSpan s) = ftext s+pprUserSpan show_path (RealSrcSpan s)   = pprUserRealSpan show_path s++pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc+pprUserRealSpan show_path span@(RealSrcSpan' src_path line col _ _)+  | isPointRealSpan span+  = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)+         , int line <> colon+         , int col ]++pprUserRealSpan show_path span@(RealSrcSpan' src_path line scol _ ecol)+  | isOneLineRealSpan span+  = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)+         , int line <> colon+         , int scol+         , ppUnless (ecol - scol <= 1) (char '-' <> int (ecol - 1)) ]+            -- For single-character or point spans, we just+            -- output the starting column number++pprUserRealSpan show_path (RealSrcSpan' src_path sline scol eline ecol)+  = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)+         , parens (int sline <> comma <> int scol)+         , char '-'+         , parens (int eline <> comma <> int ecol') ]+ where+   ecol' = if ecol == 0 then ecol else ecol - 1++{-+************************************************************************+*                                                                      *+\subsection[Located]{Attaching SrcSpans to things}+*                                                                      *+************************************************************************+-}++-- | We attach SrcSpans to lots of things, so let's have a datatype for it.+data GenLocated l e = L l e+  deriving (Eq, Ord, Data, Functor, Foldable, Traversable)++type Located e = GenLocated SrcSpan e+type RealLocated e = GenLocated RealSrcSpan e++unLoc :: GenLocated l e -> e+unLoc (L _ e) = e++getLoc :: GenLocated l e -> l+getLoc (L l _) = l++noLoc :: e -> Located e+noLoc e = L noSrcSpan e++mkGeneralLocated :: String -> e -> Located e+mkGeneralLocated s e = L (mkGeneralSrcSpan (fsLit s)) e++combineLocs :: Located a -> Located b -> SrcSpan+combineLocs a b = combineSrcSpans (getLoc a) (getLoc b)++-- | Combine locations from two 'Located' things and add them to a third thing+addCLoc :: Located a -> Located b -> c -> Located c+addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c++-- not clear whether to add a general Eq instance, but this is useful sometimes:++-- | Tests whether the two located things are equal+eqLocated :: Eq a => Located a -> Located a -> Bool+eqLocated a b = unLoc a == unLoc b++-- not clear whether to add a general Ord instance, but this is useful sometimes:++-- | Tests the ordering of the two located things+cmpLocated :: Ord a => Located a -> Located a -> Ordering+cmpLocated a b = unLoc a `compare` unLoc b++instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where+  ppr (L l e) = -- TODO: We can't do this since Located was refactored into+                -- GenLocated:+                -- Print spans without the file name etc+                -- ifPprDebug (braces (pprUserSpan False l))+                ifPprDebug (braces (ppr l))+             $$ ppr e++{-+************************************************************************+*                                                                      *+\subsection{Ordering SrcSpans for InteractiveUI}+*                                                                      *+************************************************************************+-}++-- | Alternative strategies for ordering 'SrcSpan's+leftmost_smallest, leftmost_largest, rightmost :: SrcSpan -> SrcSpan -> Ordering+rightmost            = flip compare+leftmost_smallest    = compare+leftmost_largest a b = (srcSpanStart a `compare` srcSpanStart b)+                                `thenCmp`+                       (srcSpanEnd b `compare` srcSpanEnd a)++-- | Determines whether a span encloses a given line and column index+spans :: SrcSpan -> (Int, Int) -> Bool+spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan"+spans (RealSrcSpan span) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span+   where loc = mkRealSrcLoc (srcSpanFile span) l c++-- | Determines whether a span is enclosed by another one+isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other+            -> SrcSpan -- ^ The span it may be enclosed by+            -> Bool+isSubspanOf src parent+    | srcSpanFileName_maybe parent /= srcSpanFileName_maybe src = False+    | otherwise = srcSpanStart parent <= srcSpanStart src &&+                  srcSpanEnd parent   >= srcSpanEnd src
+ basicTypes/UniqSupply.hs view
@@ -0,0 +1,232 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++{-# LANGUAGE CPP, UnboxedTuples #-}++module UniqSupply (+        -- * Main data type+        UniqSupply, -- Abstractly++        -- ** Operations on supplies+        uniqFromSupply, uniqsFromSupply, -- basic ops+        takeUniqFromSupply,++        mkSplitUniqSupply,+        splitUniqSupply, listSplitUniqSupply,+        splitUniqSupply3, splitUniqSupply4,++        -- * Unique supply monad and its abstraction+        UniqSM, MonadUnique(..), liftUs,++        -- ** Operations on the monad+        initUs, initUs_,+        lazyThenUs, lazyMapUs,+        getUniqueSupplyM3,++        -- * Set supply strategy+        initUniqSupply+  ) where++import Unique++import GHC.IO++import MonadUtils+import Control.Monad+import Data.Bits+import Data.Char++#include "Unique.h"++{-+************************************************************************+*                                                                      *+\subsection{Splittable Unique supply: @UniqSupply@}+*                                                                      *+************************************************************************+-}++-- | Unique Supply+--+-- A value of type 'UniqSupply' is unique, and it can+-- supply /one/ distinct 'Unique'.  Also, from the supply, one can+-- also manufacture an arbitrary number of further 'UniqueSupply' values,+-- which will be distinct from the first and from all others.+data UniqSupply+  = MkSplitUniqSupply {-# UNPACK #-} !Int -- make the Unique with this+                   UniqSupply UniqSupply+                                -- when split => these two supplies++mkSplitUniqSupply :: Char -> IO UniqSupply+-- ^ Create a unique supply out of thin air. The character given must+-- be distinct from those of all calls to this function in the compiler+-- for the values generated to be truly unique.++splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)+-- ^ Build two 'UniqSupply' from a single one, each of which+-- can supply its own 'Unique'.+listSplitUniqSupply :: UniqSupply -> [UniqSupply]+-- ^ Create an infinite list of 'UniqSupply' from a single one+uniqFromSupply  :: UniqSupply -> Unique+-- ^ Obtain the 'Unique' from this particular 'UniqSupply'+uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite+-- ^ Obtain an infinite list of 'Unique' that can be generated by constant splitting of the supply+takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply)+-- ^ Obtain the 'Unique' from this particular 'UniqSupply', and a new supply++mkSplitUniqSupply c+  = case ord c `shiftL` uNIQUE_BITS of+     mask -> let+        -- here comes THE MAGIC:++        -- This is one of the most hammered bits in the whole compiler+        mk_supply+          -- NB: Use unsafeInterleaveIO for thread-safety.+          = unsafeInterleaveIO (+                genSym      >>= \ u ->+                mk_supply   >>= \ s1 ->+                mk_supply   >>= \ s2 ->+                return (MkSplitUniqSupply (mask .|. u) s1 s2)+            )+       in+       mk_supply++foreign import ccall unsafe "genSym" genSym :: IO Int+foreign import ccall unsafe "initGenSym" initUniqSupply :: Int -> Int -> IO ()++splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2)+listSplitUniqSupply  (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2++uniqFromSupply  (MkSplitUniqSupply n _ _)  = mkUniqueGrimily n+uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply s2+takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily n, s1)++-- | Build three 'UniqSupply' from a single one,+-- each of which can supply its own unique+splitUniqSupply3 :: UniqSupply -> (UniqSupply, UniqSupply, UniqSupply)+splitUniqSupply3 us = (us1, us2, us3)+  where+    (us1, us') = splitUniqSupply us+    (us2, us3) = splitUniqSupply us'++-- | Build four 'UniqSupply' from a single one,+-- each of which can supply its own unique+splitUniqSupply4 :: UniqSupply -> (UniqSupply, UniqSupply, UniqSupply, UniqSupply)+splitUniqSupply4 us = (us1, us2, us3, us4)+  where+    (us1, us2, us') = splitUniqSupply3 us+    (us3, us4)      = splitUniqSupply us'++{-+************************************************************************+*                                                                      *+\subsubsection[UniqSupply-monad]{@UniqSupply@ monad: @UniqSM@}+*                                                                      *+************************************************************************+-}++-- | A monad which just gives the ability to obtain 'Unique's+newtype UniqSM result = USM { unUSM :: UniqSupply -> (# result, UniqSupply #) }++instance Monad UniqSM where+  (>>=) = thenUs+  (>>)  = (*>)++instance Functor UniqSM where+    fmap f (USM x) = USM (\us -> case x us of+                                 (# r, us' #) -> (# f r, us' #))++instance Applicative UniqSM where+    pure = returnUs+    (USM f) <*> (USM x) = USM $ \us -> case f us of+                            (# ff, us' #)  -> case x us' of+                              (# xx, us'' #) -> (# ff xx, us'' #)+    (*>) = thenUs_++-- | Run the 'UniqSM' action, returning the final 'UniqSupply'+initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply)+initUs init_us m = case unUSM m init_us of { (# r, us #) -> (r,us) }++-- | Run the 'UniqSM' action, discarding the final 'UniqSupply'+initUs_ :: UniqSupply -> UniqSM a -> a+initUs_ init_us m = case unUSM m init_us of { (# r, _ #) -> r }++{-# INLINE thenUs #-}+{-# INLINE lazyThenUs #-}+{-# INLINE returnUs #-}+{-# INLINE splitUniqSupply #-}++-- @thenUs@ is where we split the @UniqSupply@.++liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply)+liftUSM (USM m) us = case m us of (# a, us' #) -> (a, us')++instance MonadFix UniqSM where+    mfix m = USM (\us -> let (r,us') = liftUSM (m r) us in (# r,us' #))++thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b+thenUs (USM expr) cont+  = USM (\us -> case (expr us) of+                   (# result, us' #) -> unUSM (cont result) us')++lazyThenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b+lazyThenUs expr cont+  = USM (\us -> let (result, us') = liftUSM expr us in unUSM (cont result) us')++thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b+thenUs_ (USM expr) (USM cont)+  = USM (\us -> case (expr us) of { (# _, us' #) -> cont us' })++returnUs :: a -> UniqSM a+returnUs result = USM (\us -> (# result, us #))++getUs :: UniqSM UniqSupply+getUs = USM (\us -> case splitUniqSupply us of (us1,us2) -> (# us1, us2 #))++-- | A monad for generating unique identifiers+class Monad m => MonadUnique m where+    -- | Get a new UniqueSupply+    getUniqueSupplyM :: m UniqSupply+    -- | Get a new unique identifier+    getUniqueM  :: m Unique+    -- | Get an infinite list of new unique identifiers+    getUniquesM :: m [Unique]++    -- This default definition of getUniqueM, while correct, is not as+    -- efficient as it could be since it needlessly generates and throws away+    -- an extra Unique. For your instances consider providing an explicit+    -- definition for 'getUniqueM' which uses 'takeUniqFromSupply' directly.+    getUniqueM  = liftM uniqFromSupply  getUniqueSupplyM+    getUniquesM = liftM uniqsFromSupply getUniqueSupplyM++instance MonadUnique UniqSM where+    getUniqueSupplyM = getUs+    getUniqueM  = getUniqueUs+    getUniquesM = getUniquesUs++getUniqueSupplyM3 :: MonadUnique m => m (UniqSupply, UniqSupply, UniqSupply)+getUniqueSupplyM3 = liftM3 (,,) getUniqueSupplyM getUniqueSupplyM getUniqueSupplyM++liftUs :: MonadUnique m => UniqSM a -> m a+liftUs m = getUniqueSupplyM >>= return . flip initUs_ m++getUniqueUs :: UniqSM Unique+getUniqueUs = USM (\us -> case takeUniqFromSupply us of+                          (u,us') -> (# u, us' #))++getUniquesUs :: UniqSM [Unique]+getUniquesUs = USM (\us -> case splitUniqSupply us of+                           (us1,us2) -> (# uniqsFromSupply us1, us2 #))++-- {-# SPECIALIZE mapM          :: (a -> UniqSM b) -> [a] -> UniqSM [b] #-}+-- {-# SPECIALIZE mapAndUnzipM  :: (a -> UniqSM (b,c))   -> [a] -> UniqSM ([b],[c]) #-}+-- {-# SPECIALIZE mapAndUnzip3M :: (a -> UniqSM (b,c,d)) -> [a] -> UniqSM ([b],[c],[d]) #-}++lazyMapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b]+lazyMapUs _ []     = returnUs []+lazyMapUs f (x:xs)+  = f x             `lazyThenUs` \ r  ->+    lazyMapUs f xs  `lazyThenUs` \ rs ->+    returnUs (r:rs)
+ basicTypes/Unique.hs view
@@ -0,0 +1,436 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++@Uniques@ are used to distinguish entities in the compiler (@Ids@,+@Classes@, etc.) from each other.  Thus, @Uniques@ are the basic+comparison key in the compiler.++If there is any single operation that needs to be fast, it is @Unique@++comparison.  Unsurprisingly, there is quite a bit of huff-and-puff+directed to that end.++Some of the other hair in this code is to be able to use a+``splittable @UniqueSupply@'' if requested/possible (not standard+Haskell).+-}++{-# LANGUAGE CPP, BangPatterns, MagicHash #-}++module Unique (+        -- * Main data types+        Unique, Uniquable(..),+        uNIQUE_BITS,++        -- ** Constructors, destructors and operations on 'Unique's+        hasKey,++        pprUniqueAlways,++        mkUniqueGrimily,                -- Used in UniqSupply only!+        getKey,                         -- Used in Var, UniqFM, Name only!+        mkUnique, unpkUnique,           -- Used in BinIface only++        deriveUnique,                   -- Ditto+        newTagUnique,                   -- Used in CgCase+        initTyVarUnique,+        nonDetCmpUnique,+        isValidKnownKeyUnique,          -- Used in PrelInfo.knownKeyNamesOkay++        -- ** Making built-in uniques++        -- now all the built-in Uniques (and functions to make them)+        -- [the Oh-So-Wonderful Haskell module system wins again...]+        mkAlphaTyVarUnique,+        mkPrimOpIdUnique,+        mkPreludeMiscIdUnique, mkPreludeDataConUnique,+        mkPreludeTyConUnique, mkPreludeClassUnique,+        mkPArrDataConUnique, mkCoVarUnique,++        mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,+        mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique,+        mkCostCentreUnique,++        mkBuiltinUnique,+        mkPseudoUniqueD,+        mkPseudoUniqueE,+        mkPseudoUniqueH,++        -- ** Deriving uniques+        -- *** From TyCon name uniques+        tyConRepNameUnique,+        -- *** From DataCon name uniques+        dataConWorkerUnique, dataConRepNameUnique+    ) where++#include "HsVersions.h"+#include "Unique.h"++import BasicTypes+import FastString+import Outputable+import Util++-- just for implementing a fast [0,61) -> Char function+import GHC.Exts (indexCharOffAddr#, Char(..), Int(..))++import Data.Char        ( chr, ord )+import Data.Bits++{-+************************************************************************+*                                                                      *+\subsection[Unique-type]{@Unique@ type and operations}+*                                                                      *+************************************************************************++The @Chars@ are ``tag letters'' that identify the @UniqueSupply@.+Fast comparison is everything on @Uniques@:+-}++-- | Unique identifier.+--+-- The type of unique identifiers that are used in many places in GHC+-- for fast ordering and equality tests. You should generate these with+-- the functions from the 'UniqSupply' module+--+-- These are sometimes also referred to as \"keys\" in comments in GHC.+newtype Unique = MkUnique Int++{-# INLINE uNIQUE_BITS #-}+uNIQUE_BITS :: Int+uNIQUE_BITS = finiteBitSize (0 :: Int) - UNIQUE_TAG_BITS++{-+Now come the functions which construct uniques from their pieces, and vice versa.+The stuff about unique *supplies* is handled further down this module.+-}++unpkUnique      :: Unique -> (Char, Int)        -- The reverse++mkUniqueGrimily :: Int -> Unique                -- A trap-door for UniqSupply+getKey          :: Unique -> Int                -- for Var++incrUnique   :: Unique -> Unique+stepUnique   :: Unique -> Int -> Unique+deriveUnique :: Unique -> Int -> Unique+newTagUnique :: Unique -> Char -> Unique++mkUniqueGrimily = MkUnique++{-# INLINE getKey #-}+getKey (MkUnique x) = x++incrUnique (MkUnique i) = MkUnique (i + 1)+stepUnique (MkUnique i) n = MkUnique (i + n)++-- deriveUnique uses an 'X' tag so that it won't clash with+-- any of the uniques produced any other way+-- SPJ says: this looks terribly smelly to me!+deriveUnique (MkUnique i) delta = mkUnique 'X' (i + delta)++-- newTagUnique changes the "domain" of a unique to a different char+newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u++-- | How many bits are devoted to the unique index (as opposed to the class+-- character).+uniqueMask :: Int+uniqueMask = (1 `shiftL` uNIQUE_BITS) - 1++-- pop the Char in the top 8 bits of the Unique(Supply)++-- No 64-bit bugs here, as long as we have at least 32 bits. --JSM++-- and as long as the Char fits in 8 bits, which we assume anyway!++mkUnique :: Char -> Int -> Unique       -- Builds a unique from pieces+-- NOT EXPORTED, so that we can see all the Chars that+--               are used in this one module+mkUnique c i+  = MkUnique (tag .|. bits)+  where+    tag  = ord c `shiftL` uNIQUE_BITS+    bits = i .&. uniqueMask++unpkUnique (MkUnique u)+  = let+        -- as long as the Char may have its eighth bit set, we+        -- really do need the logical right-shift here!+        tag = chr (u `shiftR` uNIQUE_BITS)+        i   = u .&. uniqueMask+    in+    (tag, i)++-- | The interface file symbol-table encoding assumes that known-key uniques fit+-- in 30-bits; verify this.+--+-- See Note [Symbol table representation of names] in BinIface for details.+isValidKnownKeyUnique :: Unique -> Bool+isValidKnownKeyUnique u =+    case unpkUnique u of+      (c, x) -> ord c < 0xff && x <= (1 `shiftL` 22)++{-+************************************************************************+*                                                                      *+\subsection[Uniquable-class]{The @Uniquable@ class}+*                                                                      *+************************************************************************+-}++-- | Class of things that we can obtain a 'Unique' from+class Uniquable a where+    getUnique :: a -> Unique++hasKey          :: Uniquable a => a -> Unique -> Bool+x `hasKey` k    = getUnique x == k++instance Uniquable FastString where+ getUnique fs = mkUniqueGrimily (uniqueOfFS fs)++instance Uniquable Int where+ getUnique i = mkUniqueGrimily i++{-+************************************************************************+*                                                                      *+\subsection[Unique-instances]{Instance declarations for @Unique@}+*                                                                      *+************************************************************************++And the whole point (besides uniqueness) is fast equality.  We don't+use `deriving' because we want {\em precise} control of ordering+(equality on @Uniques@ is v common).+-}++-- Note [Unique Determinism]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~+-- The order of allocated @Uniques@ is not stable across rebuilds.+-- The main reason for that is that typechecking interface files pulls+-- @Uniques@ from @UniqSupply@ and the interface file for the module being+-- currently compiled can, but doesn't have to exist.+--+-- It gets more complicated if you take into account that the interface+-- files are loaded lazily and that building multiple files at once has to+-- work for any subset of interface files present. When you add parallelism+-- this makes @Uniques@ hopelessly random.+--+-- As such, to get deterministic builds, the order of the allocated+-- @Uniques@ should not affect the final result.+-- see also wiki/DeterministicBuilds+--+-- Note [Unique Determinism and code generation]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The goal of the deterministic builds (wiki/DeterministicBuilds, #4012)+-- is to get ABI compatible binaries given the same inputs and environment.+-- The motivation behind that is that if the ABI doesn't change the+-- binaries can be safely reused.+-- Note that this is weaker than bit-for-bit identical binaries and getting+-- bit-for-bit identical binaries is not a goal for now.+-- This means that we don't care about nondeterminism that happens after+-- the interface files are created, in particular we don't care about+-- register allocation and code generation.+-- To track progress on bit-for-bit determinism see #12262.++eqUnique :: Unique -> Unique -> Bool+eqUnique (MkUnique u1) (MkUnique u2) = u1 == u2++-- Provided here to make it explicit at the call-site that it can+-- introduce non-determinism.+-- See Note [Unique Determinism]+-- See Note [No Ord for Unique]+nonDetCmpUnique :: Unique -> Unique -> Ordering+nonDetCmpUnique (MkUnique u1) (MkUnique u2)+  = if u1 == u2 then EQ else if u1 < u2 then LT else GT++{-+Note [No Ord for Unique]+~~~~~~~~~~~~~~~~~~~~~~~~~~+As explained in Note [Unique Determinism] the relative order of Uniques+is nondeterministic. To prevent from accidental use the Ord Unique+instance has been removed.+This makes it easier to maintain deterministic builds, but comes with some+drawbacks.+The biggest drawback is that Maps keyed by Uniques can't directly be used.+The alternatives are:++  1) Use UniqFM or UniqDFM, see Note [Deterministic UniqFM] to decide which+  2) Create a newtype wrapper based on Unique ordering where nondeterminism+     is controlled. See Module.ModuleEnv+  3) Change the algorithm to use nonDetCmpUnique and document why it's still+     deterministic+  4) Use TrieMap as done in CmmCommonBlockElim.groupByLabel+-}++instance Eq Unique where+    a == b = eqUnique a b+    a /= b = not (eqUnique a b)++instance Uniquable Unique where+    getUnique u = u++-- We do sometimes make strings with @Uniques@ in them:++showUnique :: Unique -> String+showUnique uniq+  = case unpkUnique uniq of+      (tag, u) -> finish_show tag u (iToBase62 u)++finish_show :: Char -> Int -> String -> String+finish_show 't' u _pp_u | u < 26+  = -- Special case to make v common tyvars, t1, t2, ...+    -- come out as a, b, ... (shorter, easier to read)+    [chr (ord 'a' + u)]+finish_show tag _ pp_u = tag : pp_u++pprUniqueAlways :: Unique -> SDoc+-- The "always" means regardless of -dsuppress-uniques+-- It replaces the old pprUnique to remind callers that+-- they should consider whether they want to consult+-- Opt_SuppressUniques+pprUniqueAlways u+  = text (showUnique u)++instance Outputable Unique where+    ppr = pprUniqueAlways++instance Show Unique where+    show uniq = showUnique uniq++{-+************************************************************************+*                                                                      *+\subsection[Utils-base62]{Base-62 numbers}+*                                                                      *+************************************************************************++A character-stingy way to read/write numbers (notably Uniques).+The ``62-its'' are \tr{[0-9a-zA-Z]}.  We don't handle negative Ints.+Code stolen from Lennart.+-}++iToBase62 :: Int -> String+iToBase62 n_+  = ASSERT(n_ >= 0) go n_ ""+  where+    go n cs | n < 62+            = let !c = chooseChar62 n in c : cs+            | otherwise+            = go q (c : cs) where (q, r) = quotRem n 62+                                  !c = chooseChar62 r++    chooseChar62 :: Int -> Char+    {-# INLINE chooseChar62 #-}+    chooseChar62 (I# n) = C# (indexCharOffAddr# chars62 n)+    chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"#++{-+************************************************************************+*                                                                      *+\subsection[Uniques-prelude]{@Uniques@ for wired-in Prelude things}+*                                                                      *+************************************************************************++Allocation of unique supply characters:+        v,t,u : for renumbering value-, type- and usage- vars.+        B:   builtin+        C-E: pseudo uniques     (used in native-code generator)+        X:   uniques derived by deriveUnique+        _:   unifiable tyvars   (above)+        0-9: prelude things below+             (no numbers left any more..)+        ::   (prelude) parallel array data constructors++        other a-z: lower case chars for unique supplies.  Used so far:++        d       desugarer+        f       AbsC flattener+        g       SimplStg+        k       constraint tuple tycons+        m       constraint tuple datacons+        n       Native codegen+        r       Hsc name cache+        s       simplifier+        z       anonymous sums+-}++mkAlphaTyVarUnique     :: Int -> Unique+mkPreludeClassUnique   :: Int -> Unique+mkPreludeTyConUnique   :: Int -> Unique+mkPreludeDataConUnique :: Arity -> Unique+mkPrimOpIdUnique       :: Int -> Unique+mkPreludeMiscIdUnique  :: Int -> Unique+mkPArrDataConUnique    :: Int -> Unique+mkCoVarUnique          :: Int -> Unique++mkAlphaTyVarUnique   i = mkUnique '1' i+mkCoVarUnique        i = mkUnique 'g' i+mkPreludeClassUnique i = mkUnique '2' i++--------------------------------------------------+-- Wired-in type constructor keys occupy *two* slots:+--    * u: the TyCon itself+--    * u+1: the TyConRepName of the TyCon+mkPreludeTyConUnique i                = mkUnique '3' (2*i)++tyConRepNameUnique :: Unique -> Unique+tyConRepNameUnique  u = incrUnique u++-- Data constructor keys occupy *two* slots.  The first is used for the+-- data constructor itself and its wrapper function (the function that+-- evaluates arguments as necessary and calls the worker). The second is+-- used for the worker function (the function that builds the constructor+-- representation).++--------------------------------------------------+-- Wired-in data constructor keys occupy *three* slots:+--    * u: the DataCon itself+--    * u+1: its worker Id+--    * u+2: the TyConRepName of the promoted TyCon+-- Prelude data constructors are too simple to need wrappers.++mkPreludeDataConUnique i              = mkUnique '6' (3*i)    -- Must be alphabetic++--------------------------------------------------+dataConRepNameUnique, dataConWorkerUnique :: Unique -> Unique+dataConWorkerUnique  u = incrUnique u+dataConRepNameUnique u = stepUnique u 2++--------------------------------------------------+mkPrimOpIdUnique op         = mkUnique '9' op+mkPreludeMiscIdUnique  i    = mkUnique '0' i++-- No numbers left anymore, so I pick something different for the character tag+mkPArrDataConUnique a           = mkUnique ':' (2*a)++-- The "tyvar uniques" print specially nicely: a, b, c, etc.+-- See pprUnique for details++initTyVarUnique :: Unique+initTyVarUnique = mkUnique 't' 0++mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH,+   mkBuiltinUnique :: Int -> Unique++mkBuiltinUnique i = mkUnique 'B' i+mkPseudoUniqueD i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs+mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs+mkPseudoUniqueH i = mkUnique 'H' i -- used in NCG spiller to create spill VirtualRegs++mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique+mkRegSingleUnique = mkUnique 'R'+mkRegSubUnique    = mkUnique 'S'+mkRegPairUnique   = mkUnique 'P'+mkRegClassUnique  = mkUnique 'L'++mkCostCentreUnique :: Int -> Unique+mkCostCentreUnique = mkUnique 'C'++mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique+-- See Note [The Unique of an OccName] in OccName+mkVarOccUnique  fs = mkUnique 'i' (uniqueOfFS fs)+mkDataOccUnique fs = mkUnique 'd' (uniqueOfFS fs)+mkTvOccUnique   fs = mkUnique 'v' (uniqueOfFS fs)+mkTcOccUnique   fs = mkUnique 'c' (uniqueOfFS fs)
+ basicTypes/Var.hs view
@@ -0,0 +1,643 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section{@Vars@: Variables}+-}++{-# LANGUAGE CPP, FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable #-}++-- |+-- #name_types#+-- GHC uses several kinds of name internally:+--+-- * 'OccName.OccName': see "OccName#name_types"+--+-- * 'RdrName.RdrName': see "RdrName#name_types"+--+-- * 'Name.Name': see "Name#name_types"+--+-- * 'Id.Id': see "Id#name_types"+--+-- * 'Var.Var' is a synonym for the 'Id.Id' type but it may additionally+--   potentially contain type variables, which have a 'TyCoRep.Kind'+--   rather than a 'TyCoRep.Type' and only contain some extra+--   details during typechecking.+--+--   These 'Var.Var' names may either be global or local, see "Var#globalvslocal"+--+-- #globalvslocal#+-- Global 'Id's and 'Var's are those that are imported or correspond+--    to a data constructor, primitive operation, or record selectors.+-- Local 'Id's and 'Var's are those bound within an expression+--    (e.g. by a lambda) or at the top level of the module being compiled.++module Var (+        -- * The main data type and synonyms+        Var, CoVar, Id, NcId, DictId, DFunId, EvVar, EqVar, EvId, IpId, JoinId,+        TyVar, TypeVar, KindVar, TKVar, TyCoVar,++        -- * In and Out variants+        InVar,  InCoVar,  InId,  InTyVar,+        OutVar, OutCoVar, OutId, OutTyVar,++        -- ** Taking 'Var's apart+        varName, varUnique, varType,++        -- ** Modifying 'Var's+        setVarName, setVarUnique, setVarType, updateVarType,+        updateVarTypeM,++        -- ** Constructing, taking apart, modifying 'Id's+        mkGlobalVar, mkLocalVar, mkExportedLocalVar, mkCoVar,+        idInfo, idDetails,+        lazySetIdInfo, setIdDetails, globaliseId,+        setIdExported, setIdNotExported,++        -- ** Predicates+        isId, isTyVar, isTcTyVar,+        isLocalVar, isLocalId, isCoVar, isNonCoVarId, isTyCoVar,+        isGlobalId, isExportedId,+        mustHaveLocalBinding,++        -- * TyVar's+        TyVarBndr(..), ArgFlag(..), TyVarBinder,+        binderVar, binderVars, binderArgFlag, binderKind,+        isVisibleArgFlag, isInvisibleArgFlag, sameVis,++        -- ** Constructing TyVar's+        mkTyVar, mkTcTyVar,++        -- ** Taking 'TyVar's apart+        tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails,++        -- ** Modifying 'TyVar's+        setTyVarName, setTyVarUnique, setTyVarKind, updateTyVarKind,+        updateTyVarKindM,++        nonDetCmpVar++    ) where++#include "HsVersions.h"++import {-# SOURCE #-}   TyCoRep( Type, Kind, pprKind )+import {-# SOURCE #-}   TcType( TcTyVarDetails, pprTcTyVarDetails, vanillaSkolemTv )+import {-# SOURCE #-}   IdInfo( IdDetails, IdInfo, coVarDetails, isCoVarDetails,+                                vanillaIdInfo, pprIdDetails )++import Name hiding (varName)+import Unique ( Uniquable, Unique, getKey, getUnique+              , mkUniqueGrimily, nonDetCmpUnique )+import Util+import Binary+import DynFlags+import Outputable++import Data.Data++{-+************************************************************************+*                                                                      *+                     Synonyms+*                                                                      *+************************************************************************+-- These synonyms are here and not in Id because otherwise we need a very+-- large number of SOURCE imports of Id.hs :-(+-}++-- | Identifier+type Id    = Var       -- A term-level identifier+                       --  predicate: isId++-- | Coercion Variable+type CoVar = Id        -- See Note [Evidence: EvIds and CoVars]+                       --   predicate: isCoVar++-- |+type NcId  = Id        -- A term-level (value) variable that is+                       -- /not/ an (unlifted) coercion+                       --    predicate: isNonCoVarId++-- | Type or kind Variable+type TyVar   = Var     -- Type *or* kind variable (historical)++-- | Type or Kind Variable+type TKVar   = Var     -- Type *or* kind variable (historical)++-- | Type Variable+type TypeVar = Var     -- Definitely a type variable++-- | Kind Variable+type KindVar = Var     -- Definitely a kind variable+                       -- See Note [Kind and type variables]++-- See Note [Evidence: EvIds and CoVars]+-- | Evidence Identifier+type EvId   = Id        -- Term-level evidence: DictId, IpId, or EqVar++-- | Evidence Variable+type EvVar  = EvId      -- ...historical name for EvId++-- | Dictionary Function Identifier+type DFunId = Id        -- A dictionary function++-- | Dictionary Identifier+type DictId = EvId      -- A dictionary variable++-- | Implicit parameter Identifier+type IpId   = EvId      -- A term-level implicit parameter++-- | Equality Variable+type EqVar  = EvId      -- Boxed equality evidence+type JoinId = Id        -- A join variable++-- | Type or Coercion Variable+type TyCoVar = Id       -- Type, *or* coercion variable+                        --   predicate: isTyCoVar+++{- Many passes apply a substitution, and it's very handy to have type+   synonyms to remind us whether or not the subsitution has been applied -}++type InVar      = Var+type InTyVar    = TyVar+type InCoVar    = CoVar+type InId       = Id+type OutVar     = Var+type OutTyVar   = TyVar+type OutCoVar   = CoVar+type OutId      = Id++++{- Note [Evidence: EvIds and CoVars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* An EvId (evidence Id) is a term-level evidence variable+  (dictionary, implicit parameter, or equality). Could be boxed or unboxed.++* DictId, IpId, and EqVar are synonyms when we know what kind of+  evidence we are talking about.  For example, an EqVar has type (t1 ~ t2).++* A CoVar is always an un-lifted coercion, of type (t1 ~# t2) or (t1 ~R# t2)++Note [Kind and type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Before kind polymorphism, TyVar were used to mean type variables. Now+they are use to mean kind *or* type variables. KindVar is used when we+know for sure that it is a kind variable. In future, we might want to+go over the whole compiler code to use:+   - TKVar   to mean kind or type variables+   - TypeVar to mean         type variables only+   - KindVar to mean kind         variables+++************************************************************************+*                                                                      *+\subsection{The main data type declarations}+*                                                                      *+************************************************************************+++Every @Var@ has a @Unique@, to uniquify it and for fast comparison, a+@Type@, and an @IdInfo@ (non-essential info about it, e.g.,+strictness).  The essential info about different kinds of @Vars@ is+in its @VarDetails@.+-}++-- | Variable+--+-- Essentially a typed 'Name', that may also contain some additional information+-- about the 'Var' and it's use sites.+data Var+  = TyVar {  -- Type and kind variables+             -- see Note [Kind and type variables]+        varName    :: !Name,+        realUnique :: {-# UNPACK #-} !Int,+                                     -- ^ Key for fast comparison+                                     -- Identical to the Unique in the name,+                                     -- cached here for speed+        varType    :: Kind           -- ^ The type or kind of the 'Var' in question+ }++  | TcTyVar {                           -- Used only during type inference+                                        -- Used for kind variables during+                                        -- inference, as well+        varName        :: !Name,+        realUnique     :: {-# UNPACK #-} !Int,+        varType        :: Kind,+        tc_tv_details  :: TcTyVarDetails+  }++  | Id {+        varName    :: !Name,+        realUnique :: {-# UNPACK #-} !Int,+        varType    :: Type,+        idScope    :: IdScope,+        id_details :: IdDetails,        -- Stable, doesn't change+        id_info    :: IdInfo }          -- Unstable, updated by simplifier++-- | Identifier Scope+data IdScope    -- See Note [GlobalId/LocalId]+  = GlobalId+  | LocalId ExportFlag++data ExportFlag   -- See Note [ExportFlag on binders]+  = NotExported   -- ^ Not exported: may be discarded as dead code.+  | Exported      -- ^ Exported: kept alive++{- Note [ExportFlag on binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+An ExportFlag of "Exported" on a top-level binder says "keep this+binding alive; do not drop it as dead code".  This transitively+keeps alive all the other top-level bindings that this binding refers+to.  This property is persisted all the way down the pipeline, so that+the binding will be compiled all the way to object code, and its+symbols will appear in the linker symbol table.++However, note that this use of "exported" is quite different to the+export list on a Haskell module.  Setting the ExportFlag on an Id does+/not/ mean that if you import the module (in Haskell source code) you+will see this Id.  Of course, things that appear in the export list+of the source Haskell module do indeed have their ExportFlag set.+But many other things, such as dictionary functions, are kept alive+by having their ExportFlag set, even though they are not exported+in the source-code sense.++We should probably use a different term for ExportFlag, like+KeepAlive.++Note [GlobalId/LocalId]+~~~~~~~~~~~~~~~~~~~~~~~+A GlobalId is+  * always a constant (top-level)+  * imported, or data constructor, or primop, or record selector+  * has a Unique that is globally unique across the whole+    GHC invocation (a single invocation may compile multiple modules)+  * never treated as a candidate by the free-variable finder;+        it's a constant!++A LocalId is+  * bound within an expression (lambda, case, local let(rec))+  * or defined at top level in the module being compiled+  * always treated as a candidate by the free-variable finder++After CoreTidy, top-level LocalIds are turned into GlobalIds+-}++instance Outputable Var where+  ppr var = sdocWithDynFlags $ \dflags ->+            getPprStyle $ \ppr_style ->+            if |  debugStyle ppr_style && (not (gopt Opt_SuppressVarKinds dflags))+                 -> parens (ppr (varName var) <+> ppr_debug var ppr_style <+>+                          dcolon <+> pprKind (tyVarKind var))+               |  otherwise+                 -> ppr (varName var) <> ppr_debug var ppr_style++ppr_debug :: Var -> PprStyle -> SDoc+ppr_debug (TyVar {}) sty+  | debugStyle sty = brackets (text "tv")+ppr_debug (TcTyVar {tc_tv_details = d}) sty+  | dumpStyle sty || debugStyle sty = brackets (pprTcTyVarDetails d)+ppr_debug (Id { idScope = s, id_details = d }) sty+  | debugStyle sty = brackets (ppr_id_scope s <> pprIdDetails d)+ppr_debug _ _ = empty++ppr_id_scope :: IdScope -> SDoc+ppr_id_scope GlobalId              = text "gid"+ppr_id_scope (LocalId Exported)    = text "lidx"+ppr_id_scope (LocalId NotExported) = text "lid"++instance NamedThing Var where+  getName = varName++instance Uniquable Var where+  getUnique = varUnique++instance Eq Var where+    a == b = realUnique a == realUnique b++instance Ord Var where+    a <= b = realUnique a <= realUnique b+    a <  b = realUnique a <  realUnique b+    a >= b = realUnique a >= realUnique b+    a >  b = realUnique a >  realUnique b+    a `compare` b = a `nonDetCmpVar` b++-- | Compare Vars by their Uniques.+-- This is what Ord Var does, provided here to make it explicit at the+-- call-site that it can introduce non-determinism.+-- See Note [Unique Determinism]+nonDetCmpVar :: Var -> Var -> Ordering+nonDetCmpVar a b = varUnique a `nonDetCmpUnique` varUnique b++instance Data Var where+  -- don't traverse?+  toConstr _   = abstractConstr "Var"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "Var"++instance HasOccName Var where+  occName = nameOccName . varName++varUnique :: Var -> Unique+varUnique var = mkUniqueGrimily (realUnique var)++setVarUnique :: Var -> Unique -> Var+setVarUnique var uniq+  = var { realUnique = getKey uniq,+          varName = setNameUnique (varName var) uniq }++setVarName :: Var -> Name -> Var+setVarName var new_name+  = var { realUnique = getKey (getUnique new_name),+          varName = new_name }++setVarType :: Id -> Type -> Id+setVarType id ty = id { varType = ty }++updateVarType :: (Type -> Type) -> Id -> Id+updateVarType f id = id { varType = f (varType id) }++updateVarTypeM :: Monad m => (Type -> m Type) -> Id -> m Id+updateVarTypeM f id = do { ty' <- f (varType id)+                         ; return (id { varType = ty' }) }++{- *********************************************************************+*                                                                      *+*                   ArgFlag+*                                                                      *+********************************************************************* -}++-- | Argument Flag+--+-- Is something required to appear in source Haskell ('Required'),+-- permitted by request ('Specified') (visible type application), or+-- prohibited entirely from appearing in source Haskell ('Inferred')?+-- See Note [TyBinders and ArgFlags] in TyCoRep+data ArgFlag = Required | Specified | Inferred+  deriving (Eq, Data)++-- | Does this 'ArgFlag' classify an argument that is written in Haskell?+isVisibleArgFlag :: ArgFlag -> Bool+isVisibleArgFlag Required = True+isVisibleArgFlag _        = False++-- | Does this 'ArgFlag' classify an argument that is not written in Haskell?+isInvisibleArgFlag :: ArgFlag -> Bool+isInvisibleArgFlag = not . isVisibleArgFlag++-- | Do these denote the same level of visibility? 'Required'+-- arguments are visible, others are not. So this function+-- equates 'Specified' and 'Inferred'. Used for printing.+sameVis :: ArgFlag -> ArgFlag -> Bool+sameVis Required Required = True+sameVis Required _        = False+sameVis _        Required = False+sameVis _        _        = True++{- *********************************************************************+*                                                                      *+*                   TyVarBndr, TyVarBinder+*                                                                      *+********************************************************************* -}++-- Type Variable Binder+--+-- TyVarBndr is polymorphic in both tyvar and visiblity fields:+--   * tyvar can be TyVar or IfaceTv+--   * argf  can be ArgFlag or TyConBndrVis+data TyVarBndr tyvar argf = TvBndr tyvar argf+  deriving( Data )++-- | Type Variable Binder+--+-- A 'TyVarBinder' is the binder of a ForAllTy+-- It's convenient to define this synonym here rather its natural+-- home in TyCoRep, because it's used in DataCon.hs-boot+type TyVarBinder = TyVarBndr TyVar ArgFlag++binderVar :: TyVarBndr tv argf -> tv+binderVar (TvBndr v _) = v++binderVars :: [TyVarBndr tv argf] -> [tv]+binderVars tvbs = map binderVar tvbs++binderArgFlag :: TyVarBndr tv argf -> argf+binderArgFlag (TvBndr _ argf) = argf++binderKind :: TyVarBndr TyVar argf -> Kind+binderKind (TvBndr tv _) = tyVarKind tv++{-+************************************************************************+*                                                                      *+*                 Type and kind variables                              *+*                                                                      *+************************************************************************+-}++tyVarName :: TyVar -> Name+tyVarName = varName++tyVarKind :: TyVar -> Kind+tyVarKind = varType++setTyVarUnique :: TyVar -> Unique -> TyVar+setTyVarUnique = setVarUnique++setTyVarName :: TyVar -> Name -> TyVar+setTyVarName   = setVarName++setTyVarKind :: TyVar -> Kind -> TyVar+setTyVarKind tv k = tv {varType = k}++updateTyVarKind :: (Kind -> Kind) -> TyVar -> TyVar+updateTyVarKind update tv = tv {varType = update (tyVarKind tv)}++updateTyVarKindM :: (Monad m) => (Kind -> m Kind) -> TyVar -> m TyVar+updateTyVarKindM update tv+  = do { k' <- update (tyVarKind tv)+       ; return $ tv {varType = k'} }++mkTyVar :: Name -> Kind -> TyVar+mkTyVar name kind = TyVar { varName    = name+                          , realUnique = getKey (nameUnique name)+                          , varType  = kind+                          }++mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar+mkTcTyVar name kind details+  = -- NB: 'kind' may be a coercion kind; cf, 'TcMType.newMetaCoVar'+    TcTyVar {   varName    = name,+                realUnique = getKey (nameUnique name),+                varType  = kind,+                tc_tv_details = details+        }++tcTyVarDetails :: TyVar -> TcTyVarDetails+-- See Note [TcTyVars in the typechecker] in TcType+tcTyVarDetails (TcTyVar { tc_tv_details = details }) = details+tcTyVarDetails (TyVar {})                            = vanillaSkolemTv+tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var <+> dcolon <+> pprKind (tyVarKind var))++setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar+setTcTyVarDetails tv details = tv { tc_tv_details = details }++-------------------------------------+instance Outputable tv => Outputable (TyVarBndr tv ArgFlag) where+  ppr (TvBndr v Required)  = ppr v+  ppr (TvBndr v Specified) = char '@' <> ppr v+  ppr (TvBndr v Inferred)  = braces (ppr v)++instance Outputable ArgFlag where+  ppr Required  = text "[req]"+  ppr Specified = text "[spec]"+  ppr Inferred  = text "[infrd]"++instance (Binary tv, Binary vis) => Binary (TyVarBndr tv vis) where+  put_ bh (TvBndr tv vis) = do { put_ bh tv; put_ bh vis }++  get bh = do { tv <- get bh; vis <- get bh; return (TvBndr tv vis) }+++instance Binary ArgFlag where+  put_ bh Required  = putByte bh 0+  put_ bh Specified = putByte bh 1+  put_ bh Inferred  = putByte bh 2++  get bh = do+    h <- getByte bh+    case h of+      0 -> return Required+      1 -> return Specified+      _ -> return Inferred++{-+%************************************************************************+%*                                                                      *+\subsection{Ids}+*                                                                      *+************************************************************************+-}++idInfo :: HasDebugCallStack => Id -> IdInfo+idInfo (Id { id_info = info }) = info+idInfo other                   = pprPanic "idInfo" (ppr other)++idDetails :: Id -> IdDetails+idDetails (Id { id_details = details }) = details+idDetails other                         = pprPanic "idDetails" (ppr other)++-- The next three have a 'Var' suffix even though they always build+-- Ids, because Id.hs uses 'mkGlobalId' etc with different types+mkGlobalVar :: IdDetails -> Name -> Type -> IdInfo -> Id+mkGlobalVar details name ty info+  = mk_id name ty GlobalId details info++mkLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id+mkLocalVar details name ty info+  = mk_id name ty (LocalId NotExported) details  info++mkCoVar :: Name -> Type -> CoVar+-- Coercion variables have no IdInfo+mkCoVar name ty = mk_id name ty (LocalId NotExported) coVarDetails vanillaIdInfo++-- | Exported 'Var's will not be removed as dead code+mkExportedLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id+mkExportedLocalVar details name ty info+  = mk_id name ty (LocalId Exported) details info++mk_id :: Name -> Type -> IdScope -> IdDetails -> IdInfo -> Id+mk_id name ty scope details info+  = Id { varName    = name,+         realUnique = getKey (nameUnique name),+         varType    = ty,+         idScope    = scope,+         id_details = details,+         id_info    = info }++-------------------+lazySetIdInfo :: Id -> IdInfo -> Var+lazySetIdInfo id info = id { id_info = info }++setIdDetails :: Id -> IdDetails -> Id+setIdDetails id details = id { id_details = details }++globaliseId :: Id -> Id+-- ^ If it's a local, make it global+globaliseId id = id { idScope = GlobalId }++setIdExported :: Id -> Id+-- ^ Exports the given local 'Id'. Can also be called on global 'Id's, such as data constructors+-- and class operations, which are born as global 'Id's and automatically exported+setIdExported id@(Id { idScope = LocalId {} }) = id { idScope = LocalId Exported }+setIdExported id@(Id { idScope = GlobalId })   = id+setIdExported tv                               = pprPanic "setIdExported" (ppr tv)++setIdNotExported :: Id -> Id+-- ^ We can only do this to LocalIds+setIdNotExported id = ASSERT( isLocalId id )+                      id { idScope = LocalId NotExported }++{-+************************************************************************+*                                                                      *+\subsection{Predicates over variables}+*                                                                      *+************************************************************************+-}++isTyVar :: Var -> Bool        -- True of both TyVar and TcTyVar+isTyVar (TyVar {})   = True+isTyVar (TcTyVar {}) = True+isTyVar _            = False++isTcTyVar :: Var -> Bool      -- True of TcTyVar only+isTcTyVar (TcTyVar {}) = True+isTcTyVar _            = False++isTyCoVar :: Var -> Bool+isTyCoVar v = isTyVar v || isCoVar v++isId :: Var -> Bool+isId (Id {}) = True+isId _       = False++isCoVar :: Var -> Bool+-- A coercion variable+isCoVar (Id { id_details = details }) = isCoVarDetails details+isCoVar _                             = False++isNonCoVarId :: Var -> Bool+-- A term variable (Id) that is /not/ a coercion variable+isNonCoVarId (Id { id_details = details }) = not (isCoVarDetails details)+isNonCoVarId _                             = False++isLocalId :: Var -> Bool+isLocalId (Id { idScope = LocalId _ }) = True+isLocalId _                            = False++-- | 'isLocalVar' returns @True@ for type variables as well as local 'Id's+-- These are the variables that we need to pay attention to when finding free+-- variables, or doing dependency analysis.+isLocalVar :: Var -> Bool+isLocalVar v = not (isGlobalId v)++isGlobalId :: Var -> Bool+isGlobalId (Id { idScope = GlobalId }) = True+isGlobalId _                           = False++-- | 'mustHaveLocalBinding' returns @True@ of 'Id's and 'TyVar's+-- that must have a binding in this module.  The converse+-- is not quite right: there are some global 'Id's that must have+-- bindings, such as record selectors.  But that doesn't matter,+-- because it's only used for assertions+mustHaveLocalBinding        :: Var -> Bool+mustHaveLocalBinding var = isLocalVar var++-- | 'isExportedIdVar' means \"don't throw this away\"+isExportedId :: Var -> Bool+isExportedId (Id { idScope = GlobalId })        = True+isExportedId (Id { idScope = LocalId Exported}) = True+isExportedId _ = False
+ basicTypes/VarEnv.hs view
@@ -0,0 +1,598 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++module VarEnv (+        -- * Var, Id and TyVar environments (maps)+        VarEnv, IdEnv, TyVarEnv, CoVarEnv, TyCoVarEnv,++        -- ** Manipulating these environments+        emptyVarEnv, unitVarEnv, mkVarEnv, mkVarEnv_Directly,+        elemVarEnv, disjointVarEnv,+        extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnv_Directly,+        extendVarEnvList,+        plusVarEnv, plusVarEnv_C, plusVarEnv_CD, plusMaybeVarEnv_C,+        plusVarEnvList, alterVarEnv,+        delVarEnvList, delVarEnv, delVarEnv_Directly,+        minusVarEnv, intersectsVarEnv,+        lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv,+        mapVarEnv, zipVarEnv,+        modifyVarEnv, modifyVarEnv_Directly,+        isEmptyVarEnv,+        elemVarEnvByKey, lookupVarEnv_Directly,+        filterVarEnv, filterVarEnv_Directly, restrictVarEnv,+        partitionVarEnv,++        -- * Deterministic Var environments (maps)+        DVarEnv, DIdEnv, DTyVarEnv,++        -- ** Manipulating these environments+        emptyDVarEnv, mkDVarEnv,+        dVarEnvElts,+        extendDVarEnv, extendDVarEnv_C,+        extendDVarEnvList,+        lookupDVarEnv, elemDVarEnv,+        isEmptyDVarEnv, foldDVarEnv,+        mapDVarEnv,+        modifyDVarEnv,+        alterDVarEnv,+        plusDVarEnv, plusDVarEnv_C,+        unitDVarEnv,+        delDVarEnv,+        delDVarEnvList,+        minusDVarEnv,+        partitionDVarEnv,+        anyDVarEnv,++        -- * The InScopeSet type+        InScopeSet,++        -- ** Operations on InScopeSets+        emptyInScopeSet, mkInScopeSet, delInScopeSet,+        extendInScopeSet, extendInScopeSetList, extendInScopeSetSet,+        getInScopeVars, lookupInScope, lookupInScope_Directly,+        unionInScope, elemInScopeSet, uniqAway,+        varSetInScope,++        -- * The RnEnv2 type+        RnEnv2,++        -- ** Operations on RnEnv2s+        mkRnEnv2, rnBndr2, rnBndrs2, rnBndr2_var,+        rnOccL, rnOccR, inRnEnvL, inRnEnvR, rnOccL_maybe, rnOccR_maybe,+        rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, rnSwap,+        delBndrL, delBndrR, delBndrsL, delBndrsR,+        addRnInScopeSet,+        rnEtaL, rnEtaR,+        rnInScope, rnInScopeSet, lookupRnInScope,+        rnEnvL, rnEnvR,++        -- * TidyEnv and its operation+        TidyEnv,+        emptyTidyEnv+    ) where++import OccName+import Var+import VarSet+import UniqSet+import UniqFM+import UniqDFM+import Unique+import Util+import Maybes+import Outputable++{-+************************************************************************+*                                                                      *+                In-scope sets+*                                                                      *+************************************************************************+-}++-- | A set of variables that are in scope at some point+-- "Secrets of the Glasgow Haskell Compiler inliner" Section 3.2 provides+-- the motivation for this abstraction.+data InScopeSet = InScope VarSet {-# UNPACK #-} !Int+        -- We store a VarSet here, but we use this for lookups rather than+        -- just membership tests. Typically the InScopeSet contains the+        -- canonical version of the variable (e.g. with an informative+        -- unfolding), so this lookup is useful.+        --+        -- The Int is a kind of hash-value used by uniqAway+        -- For example, it might be the size of the set+        -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway++instance Outputable InScopeSet where+  ppr (InScope s _) =+    text "InScope" <+>+    braces (fsep (map (ppr . Var.varName) (nonDetEltsUniqSet s)))+                      -- It's OK to use nonDetEltsUniqSet here because it's+                      -- only for pretty printing+                      -- In-scope sets get big, and with -dppr-debug+                      -- the output is overwhelming++emptyInScopeSet :: InScopeSet+emptyInScopeSet = InScope emptyVarSet 1++getInScopeVars ::  InScopeSet -> VarSet+getInScopeVars (InScope vs _) = vs++mkInScopeSet :: VarSet -> InScopeSet+mkInScopeSet in_scope = InScope in_scope 1++extendInScopeSet :: InScopeSet -> Var -> InScopeSet+extendInScopeSet (InScope in_scope n) v+   = InScope (extendVarSet in_scope v) (n + 1)++extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet+extendInScopeSetList (InScope in_scope n) vs+   = InScope (foldl (\s v -> extendVarSet s v) in_scope vs)+                    (n + length vs)++extendInScopeSetSet :: InScopeSet -> VarSet -> InScopeSet+extendInScopeSetSet (InScope in_scope n) vs+   = InScope (in_scope `unionVarSet` vs) (n + sizeUniqSet vs)++delInScopeSet :: InScopeSet -> Var -> InScopeSet+delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarSet` v) n++elemInScopeSet :: Var -> InScopeSet -> Bool+elemInScopeSet v (InScope in_scope _) = v `elemVarSet` in_scope++-- | Look up a variable the 'InScopeSet'.  This lets you map from+-- the variable's identity (unique) to its full value.+lookupInScope :: InScopeSet -> Var -> Maybe Var+lookupInScope (InScope in_scope _) v  = lookupVarSet in_scope v++lookupInScope_Directly :: InScopeSet -> Unique -> Maybe Var+lookupInScope_Directly (InScope in_scope _) uniq+  = lookupVarSet_Directly in_scope uniq++unionInScope :: InScopeSet -> InScopeSet -> InScopeSet+unionInScope (InScope s1 _) (InScope s2 n2)+  = InScope (s1 `unionVarSet` s2) n2++varSetInScope :: VarSet -> InScopeSet -> Bool+varSetInScope vars (InScope s1 _) = vars `subVarSet` s1++-- | @uniqAway in_scope v@ finds a unique that is not used in the+-- in-scope set, and gives that to v.+uniqAway :: InScopeSet -> Var -> Var+-- It starts with v's current unique, of course, in the hope that it won't+-- have to change, and thereafter uses a combination of that and the hash-code+-- found in the in-scope set+uniqAway in_scope var+  | var `elemInScopeSet` in_scope = uniqAway' in_scope var      -- Make a new one+  | otherwise                     = var                         -- Nothing to do++uniqAway' :: InScopeSet -> Var -> Var+-- This one *always* makes up a new variable+uniqAway' (InScope set n) var+  = try 1+  where+    orig_unique = getUnique var+    try k+          | debugIsOn && (k > 1000)+          = pprPanic "uniqAway loop:" msg+          | uniq `elemVarSetByKey` set = try (k + 1)+          | k > 3+          = pprTraceDebug "uniqAway:" msg+            setVarUnique var uniq+          | otherwise = setVarUnique var uniq+          where+            msg  = ppr k <+> text "tries" <+> ppr var <+> int n+            uniq = deriveUnique orig_unique (n * k)++{-+************************************************************************+*                                                                      *+                Dual renaming+*                                                                      *+************************************************************************+-}++-- | Rename Environment 2+--+-- When we are comparing (or matching) types or terms, we are faced with+-- \"going under\" corresponding binders.  E.g. when comparing:+--+-- > \x. e1     ~   \y. e2+--+-- Basically we want to rename [@x@ -> @y@] or [@y@ -> @x@], but there are lots of+-- things we must be careful of.  In particular, @x@ might be free in @e2@, or+-- y in @e1@.  So the idea is that we come up with a fresh binder that is free+-- in neither, and rename @x@ and @y@ respectively.  That means we must maintain:+--+-- 1. A renaming for the left-hand expression+--+-- 2. A renaming for the right-hand expressions+--+-- 3. An in-scope set+--+-- Furthermore, when matching, we want to be able to have an 'occurs check',+-- to prevent:+--+-- > \x. f   ~   \y. y+--+-- matching with [@f@ -> @y@].  So for each expression we want to know that set of+-- locally-bound variables. That is precisely the domain of the mappings 1.+-- and 2., but we must ensure that we always extend the mappings as we go in.+--+-- All of this information is bundled up in the 'RnEnv2'+data RnEnv2+  = RV2 { envL     :: VarEnv Var        -- Renaming for Left term+        , envR     :: VarEnv Var        -- Renaming for Right term+        , in_scope :: InScopeSet }      -- In scope in left or right terms++-- The renamings envL and envR are *guaranteed* to contain a binding+-- for every variable bound as we go into the term, even if it is not+-- renamed.  That way we can ask what variables are locally bound+-- (inRnEnvL, inRnEnvR)++mkRnEnv2 :: InScopeSet -> RnEnv2+mkRnEnv2 vars = RV2     { envL     = emptyVarEnv+                        , envR     = emptyVarEnv+                        , in_scope = vars }++addRnInScopeSet :: RnEnv2 -> VarSet -> RnEnv2+addRnInScopeSet env vs+  | isEmptyVarSet vs = env+  | otherwise        = env { in_scope = extendInScopeSetSet (in_scope env) vs }++rnInScope :: Var -> RnEnv2 -> Bool+rnInScope x env = x `elemInScopeSet` in_scope env++rnInScopeSet :: RnEnv2 -> InScopeSet+rnInScopeSet = in_scope++-- | Retrieve the left mapping+rnEnvL :: RnEnv2 -> VarEnv Var+rnEnvL = envL++-- | Retrieve the right mapping+rnEnvR :: RnEnv2 -> VarEnv Var+rnEnvR = envR++rnBndrs2 :: RnEnv2 -> [Var] -> [Var] -> RnEnv2+-- ^ Applies 'rnBndr2' to several variables: the two variable lists must be of equal length+rnBndrs2 env bsL bsR = foldl2 rnBndr2 env bsL bsR++rnBndr2 :: RnEnv2 -> Var -> Var -> RnEnv2+-- ^ @rnBndr2 env bL bR@ goes under a binder @bL@ in the Left term,+--                       and binder @bR@ in the Right term.+-- It finds a new binder, @new_b@,+-- and returns an environment mapping @bL -> new_b@ and @bR -> new_b@+rnBndr2 env bL bR = fst $ rnBndr2_var env bL bR++rnBndr2_var :: RnEnv2 -> Var -> Var -> (RnEnv2, Var)+-- ^ Similar to 'rnBndr2' but returns the new variable as well as the+-- new environment+rnBndr2_var (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR+  = (RV2 { envL            = extendVarEnv envL bL new_b   -- See Note+         , envR            = extendVarEnv envR bR new_b   -- [Rebinding]+         , in_scope = extendInScopeSet in_scope new_b }, new_b)+  where+        -- Find a new binder not in scope in either term+    new_b | not (bL `elemInScopeSet` in_scope) = bL+          | not (bR `elemInScopeSet` in_scope) = bR+          | otherwise                          = uniqAway' in_scope bL++        -- Note [Rebinding]+        -- If the new var is the same as the old one, note that+        -- the extendVarEnv *deletes* any current renaming+        -- E.g.   (\x. \x. ...)  ~  (\y. \z. ...)+        --+        --   Inside \x  \y      { [x->y], [y->y],       {y} }+        --       \x  \z         { [x->x], [y->y, z->x], {y,x} }++rnBndrL :: RnEnv2 -> Var -> (RnEnv2, Var)+-- ^ Similar to 'rnBndr2' but used when there's a binder on the left+-- side only.+rnBndrL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL+  = (RV2 { envL     = extendVarEnv envL bL new_b+         , envR     = envR+         , in_scope = extendInScopeSet in_scope new_b }, new_b)+  where+    new_b = uniqAway in_scope bL++rnBndrR :: RnEnv2 -> Var -> (RnEnv2, Var)+-- ^ Similar to 'rnBndr2' but used when there's a binder on the right+-- side only.+rnBndrR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR+  = (RV2 { envR     = extendVarEnv envR bR new_b+         , envL     = envL+         , in_scope = extendInScopeSet in_scope new_b }, new_b)+  where+    new_b = uniqAway in_scope bR++rnEtaL :: RnEnv2 -> Var -> (RnEnv2, Var)+-- ^ Similar to 'rnBndrL' but used for eta expansion+-- See Note [Eta expansion]+rnEtaL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL+  = (RV2 { envL     = extendVarEnv envL bL new_b+         , envR     = extendVarEnv envR new_b new_b     -- Note [Eta expansion]+         , in_scope = extendInScopeSet in_scope new_b }, new_b)+  where+    new_b = uniqAway in_scope bL++rnEtaR :: RnEnv2 -> Var -> (RnEnv2, Var)+-- ^ Similar to 'rnBndr2' but used for eta expansion+-- See Note [Eta expansion]+rnEtaR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR+  = (RV2 { envL     = extendVarEnv envL new_b new_b     -- Note [Eta expansion]+         , envR     = extendVarEnv envR bR new_b+         , in_scope = extendInScopeSet in_scope new_b }, new_b)+  where+    new_b = uniqAway in_scope bR++delBndrL, delBndrR :: RnEnv2 -> Var -> RnEnv2+delBndrL rn@(RV2 { envL = env, in_scope = in_scope }) v+  = rn { envL = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v }+delBndrR rn@(RV2 { envR = env, in_scope = in_scope }) v+  = rn { envR = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v }++delBndrsL, delBndrsR :: RnEnv2 -> [Var] -> RnEnv2+delBndrsL rn@(RV2 { envL = env, in_scope = in_scope }) v+  = rn { envL = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v }+delBndrsR rn@(RV2 { envR = env, in_scope = in_scope }) v+  = rn { envR = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v }++rnOccL, rnOccR :: RnEnv2 -> Var -> Var+-- ^ Look up the renaming of an occurrence in the left or right term+rnOccL (RV2 { envL = env }) v = lookupVarEnv env v `orElse` v+rnOccR (RV2 { envR = env }) v = lookupVarEnv env v `orElse` v++rnOccL_maybe, rnOccR_maybe :: RnEnv2 -> Var -> Maybe Var+-- ^ Look up the renaming of an occurrence in the left or right term+rnOccL_maybe (RV2 { envL = env }) v = lookupVarEnv env v+rnOccR_maybe (RV2 { envR = env }) v = lookupVarEnv env v++inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool+-- ^ Tells whether a variable is locally bound+inRnEnvL (RV2 { envL = env }) v = v `elemVarEnv` env+inRnEnvR (RV2 { envR = env }) v = v `elemVarEnv` env++lookupRnInScope :: RnEnv2 -> Var -> Var+lookupRnInScope env v = lookupInScope (in_scope env) v `orElse` v++nukeRnEnvL, nukeRnEnvR :: RnEnv2 -> RnEnv2+-- ^ Wipe the left or right side renaming+nukeRnEnvL env = env { envL = emptyVarEnv }+nukeRnEnvR env = env { envR = emptyVarEnv }++rnSwap :: RnEnv2 -> RnEnv2+-- ^ swap the meaning of left and right+rnSwap (RV2 { envL = envL, envR = envR, in_scope = in_scope })+  = RV2 { envL = envR, envR = envL, in_scope = in_scope }++{-+Note [Eta expansion]+~~~~~~~~~~~~~~~~~~~~+When matching+     (\x.M) ~ N+we rename x to x' with, where x' is not in scope in+either term.  Then we want to behave as if we'd seen+     (\x'.M) ~ (\x'.N x')+Since x' isn't in scope in N, the form (\x'. N x') doesn't+capture any variables in N.  But we must nevertheless extend+the envR with a binding [x' -> x'], to support the occurs check.+For example, if we don't do this, we can get silly matches like+        forall a.  (\y.a)  ~   v+succeeding with [a -> v y], which is bogus of course.+++************************************************************************+*                                                                      *+                Tidying+*                                                                      *+************************************************************************+-}++-- | Tidy Environment+--+-- When tidying up print names, we keep a mapping of in-scope occ-names+-- (the 'TidyOccEnv') and a Var-to-Var of the current renamings+type TidyEnv = (TidyOccEnv, VarEnv Var)++emptyTidyEnv :: TidyEnv+emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv)++{-+************************************************************************+*                                                                      *+\subsection{@VarEnv@s}+*                                                                      *+************************************************************************+-}++-- | Variable Environment+type VarEnv elt     = UniqFM elt++-- | Identifier Environment+type IdEnv elt      = VarEnv elt++-- | Type Variable Environment+type TyVarEnv elt   = VarEnv elt++-- | Type or Coercion Variable Environment+type TyCoVarEnv elt = VarEnv elt++-- | Coercion Variable Environment+type CoVarEnv elt   = VarEnv elt++emptyVarEnv       :: VarEnv a+mkVarEnv          :: [(Var, a)] -> VarEnv a+mkVarEnv_Directly :: [(Unique, a)] -> VarEnv a+zipVarEnv         :: [Var] -> [a] -> VarEnv a+unitVarEnv        :: Var -> a -> VarEnv a+alterVarEnv       :: (Maybe a -> Maybe a) -> VarEnv a -> Var -> VarEnv a+extendVarEnv      :: VarEnv a -> Var -> a -> VarEnv a+extendVarEnv_C    :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a+extendVarEnv_Acc  :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b+extendVarEnv_Directly :: VarEnv a -> Unique -> a -> VarEnv a+plusVarEnv        :: VarEnv a -> VarEnv a -> VarEnv a+plusVarEnvList    :: [VarEnv a] -> VarEnv a+extendVarEnvList  :: VarEnv a -> [(Var, a)] -> VarEnv a++lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a+filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a+delVarEnv_Directly    :: VarEnv a -> Unique -> VarEnv a+partitionVarEnv   :: (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a)+restrictVarEnv    :: VarEnv a -> VarSet -> VarEnv a+delVarEnvList     :: VarEnv a -> [Var] -> VarEnv a+delVarEnv         :: VarEnv a -> Var -> VarEnv a+minusVarEnv       :: VarEnv a -> VarEnv b -> VarEnv a+intersectsVarEnv  :: VarEnv a -> VarEnv a -> Bool+plusVarEnv_C      :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a+plusVarEnv_CD     :: (a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a+plusMaybeVarEnv_C :: (a -> a -> Maybe a) -> VarEnv a -> VarEnv a -> VarEnv a+mapVarEnv         :: (a -> b) -> VarEnv a -> VarEnv b+modifyVarEnv      :: (a -> a) -> VarEnv a -> Var -> VarEnv a++isEmptyVarEnv     :: VarEnv a -> Bool+lookupVarEnv      :: VarEnv a -> Var -> Maybe a+filterVarEnv      :: (a -> Bool) -> VarEnv a -> VarEnv a+lookupVarEnv_NF   :: VarEnv a -> Var -> a+lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a+elemVarEnv        :: Var -> VarEnv a -> Bool+elemVarEnvByKey   :: Unique -> VarEnv a -> Bool+disjointVarEnv    :: VarEnv a -> VarEnv a -> Bool++elemVarEnv       = elemUFM+elemVarEnvByKey  = elemUFM_Directly+disjointVarEnv   = disjointUFM+alterVarEnv      = alterUFM+extendVarEnv     = addToUFM+extendVarEnv_C   = addToUFM_C+extendVarEnv_Acc = addToUFM_Acc+extendVarEnv_Directly = addToUFM_Directly+extendVarEnvList = addListToUFM+plusVarEnv_C     = plusUFM_C+plusVarEnv_CD    = plusUFM_CD+plusMaybeVarEnv_C = plusMaybeUFM_C+delVarEnvList    = delListFromUFM+delVarEnv        = delFromUFM+minusVarEnv      = minusUFM+intersectsVarEnv e1 e2 = not (isEmptyVarEnv (e1 `intersectUFM` e2))+plusVarEnv       = plusUFM+plusVarEnvList   = plusUFMList+lookupVarEnv     = lookupUFM+filterVarEnv     = filterUFM+lookupWithDefaultVarEnv = lookupWithDefaultUFM+mapVarEnv        = mapUFM+mkVarEnv         = listToUFM+mkVarEnv_Directly= listToUFM_Directly+emptyVarEnv      = emptyUFM+unitVarEnv       = unitUFM+isEmptyVarEnv    = isNullUFM+lookupVarEnv_Directly = lookupUFM_Directly+filterVarEnv_Directly = filterUFM_Directly+delVarEnv_Directly    = delFromUFM_Directly+partitionVarEnv       = partitionUFM++restrictVarEnv env vs = filterVarEnv_Directly keep env+  where+    keep u _ = u `elemVarSetByKey` vs++zipVarEnv tyvars tys   = mkVarEnv (zipEqual "zipVarEnv" tyvars tys)+lookupVarEnv_NF env id = case lookupVarEnv env id of+                         Just xx -> xx+                         Nothing -> panic "lookupVarEnv_NF: Nothing"++{-+@modifyVarEnv@: Look up a thing in the VarEnv,+then mash it with the modify function, and put it back.+-}++modifyVarEnv mangle_fn env key+  = case (lookupVarEnv env key) of+      Nothing -> env+      Just xx -> extendVarEnv env key (mangle_fn xx)++modifyVarEnv_Directly :: (a -> a) -> UniqFM a -> Unique -> UniqFM a+modifyVarEnv_Directly mangle_fn env key+  = case (lookupUFM_Directly env key) of+      Nothing -> env+      Just xx -> addToUFM_Directly env key (mangle_fn xx)++-- Deterministic VarEnv+-- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need+-- DVarEnv.++-- | Deterministic Variable Environment+type DVarEnv elt = UniqDFM elt++-- | Deterministic Identifier Environment+type DIdEnv elt = DVarEnv elt++-- | Deterministic Type Variable Environment+type DTyVarEnv elt = DVarEnv elt++emptyDVarEnv :: DVarEnv a+emptyDVarEnv = emptyUDFM++dVarEnvElts :: DVarEnv a -> [a]+dVarEnvElts = eltsUDFM++mkDVarEnv :: [(Var, a)] -> DVarEnv a+mkDVarEnv = listToUDFM++extendDVarEnv :: DVarEnv a -> Var -> a -> DVarEnv a+extendDVarEnv = addToUDFM++minusDVarEnv :: DVarEnv a -> DVarEnv a' -> DVarEnv a+minusDVarEnv = minusUDFM++lookupDVarEnv :: DVarEnv a -> Var -> Maybe a+lookupDVarEnv = lookupUDFM++foldDVarEnv :: (a -> b -> b) -> b -> DVarEnv a -> b+foldDVarEnv = foldUDFM++mapDVarEnv :: (a -> b) -> DVarEnv a -> DVarEnv b+mapDVarEnv = mapUDFM++alterDVarEnv :: (Maybe a -> Maybe a) -> DVarEnv a -> Var -> DVarEnv a+alterDVarEnv = alterUDFM++plusDVarEnv :: DVarEnv a -> DVarEnv a -> DVarEnv a+plusDVarEnv = plusUDFM++plusDVarEnv_C :: (a -> a -> a) -> DVarEnv a -> DVarEnv a -> DVarEnv a+plusDVarEnv_C = plusUDFM_C++unitDVarEnv :: Var -> a -> DVarEnv a+unitDVarEnv = unitUDFM++delDVarEnv :: DVarEnv a -> Var -> DVarEnv a+delDVarEnv = delFromUDFM++delDVarEnvList :: DVarEnv a -> [Var] -> DVarEnv a+delDVarEnvList = delListFromUDFM++isEmptyDVarEnv :: DVarEnv a -> Bool+isEmptyDVarEnv = isNullUDFM++elemDVarEnv :: Var -> DVarEnv a -> Bool+elemDVarEnv = elemUDFM++extendDVarEnv_C :: (a -> a -> a) -> DVarEnv a -> Var -> a -> DVarEnv a+extendDVarEnv_C = addToUDFM_C++modifyDVarEnv :: (a -> a) -> DVarEnv a -> Var -> DVarEnv a+modifyDVarEnv mangle_fn env key+  = case (lookupDVarEnv env key) of+      Nothing -> env+      Just xx -> extendDVarEnv env key (mangle_fn xx)++partitionDVarEnv :: (a -> Bool) -> DVarEnv a -> (DVarEnv a, DVarEnv a)+partitionDVarEnv = partitionUDFM++extendDVarEnvList :: DVarEnv a -> [(Var, a)] -> DVarEnv a+extendDVarEnvList = addListToUDFM++anyDVarEnv :: (a -> Bool) -> DVarEnv a -> Bool+anyDVarEnv = anyUDFM
+ basicTypes/VarSet.hs view
@@ -0,0 +1,340 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++{-# LANGUAGE CPP #-}++module VarSet (+        -- * Var, Id and TyVar set types+        VarSet, IdSet, TyVarSet, CoVarSet, TyCoVarSet,++        -- ** Manipulating these sets+        emptyVarSet, unitVarSet, mkVarSet,+        extendVarSet, extendVarSetList,+        elemVarSet, subVarSet,+        unionVarSet, unionVarSets, mapUnionVarSet,+        intersectVarSet, intersectsVarSet, disjointVarSet,+        isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey,+        minusVarSet, filterVarSet,+        anyVarSet, allVarSet,+        transCloVarSet, fixVarSet,+        lookupVarSet_Directly, lookupVarSet, lookupVarSetByName,+        sizeVarSet, seqVarSet,+        elemVarSetByKey, partitionVarSet,+        pluralVarSet, pprVarSet,++        -- * Deterministic Var set types+        DVarSet, DIdSet, DTyVarSet, DTyCoVarSet,++        -- ** Manipulating these sets+        emptyDVarSet, unitDVarSet, mkDVarSet,+        extendDVarSet, extendDVarSetList,+        elemDVarSet, dVarSetElems, subDVarSet,+        unionDVarSet, unionDVarSets, mapUnionDVarSet,+        intersectDVarSet, intersectsDVarSet, disjointDVarSet,+        isEmptyDVarSet, delDVarSet, delDVarSetList,+        minusDVarSet, foldDVarSet, filterDVarSet,+        dVarSetMinusVarSet, anyDVarSet, allDVarSet,+        transCloDVarSet,+        sizeDVarSet, seqDVarSet,+        partitionDVarSet,+        dVarSetToVarSet,+    ) where++#include "HsVersions.h"++import Var      ( Var, TyVar, CoVar, TyCoVar, Id )+import Unique+import Name     ( Name )+import UniqSet+import UniqDSet+import UniqFM( disjointUFM, pluralUFM, pprUFM )+import UniqDFM( disjointUDFM, udfmToUfm, anyUDFM, allUDFM )+import Outputable (SDoc)++-- | A non-deterministic Variable Set+--+-- A non-deterministic set of variables.+-- See Note [Deterministic UniqFM] in UniqDFM for explanation why it's not+-- deterministic and why it matters. Use DVarSet if the set eventually+-- gets converted into a list or folded over in a way where the order+-- changes the generated code, for example when abstracting variables.+type VarSet       = UniqSet Var++-- | Identifier Set+type IdSet        = UniqSet Id++-- | Type Variable Set+type TyVarSet     = UniqSet TyVar++-- | Coercion Variable Set+type CoVarSet     = UniqSet CoVar++-- | Type or Coercion Variable Set+type TyCoVarSet   = UniqSet TyCoVar++emptyVarSet     :: VarSet+intersectVarSet :: VarSet -> VarSet -> VarSet+unionVarSet     :: VarSet -> VarSet -> VarSet+unionVarSets    :: [VarSet] -> VarSet++mapUnionVarSet  :: (a -> VarSet) -> [a] -> VarSet+-- ^ map the function over the list, and union the results++unitVarSet      :: Var -> VarSet+extendVarSet    :: VarSet -> Var -> VarSet+extendVarSetList:: VarSet -> [Var] -> VarSet+elemVarSet      :: Var -> VarSet -> Bool+delVarSet       :: VarSet -> Var -> VarSet+delVarSetList   :: VarSet -> [Var] -> VarSet+minusVarSet     :: VarSet -> VarSet -> VarSet+isEmptyVarSet   :: VarSet -> Bool+mkVarSet        :: [Var] -> VarSet+lookupVarSet_Directly :: VarSet -> Unique -> Maybe Var+lookupVarSet    :: VarSet -> Var -> Maybe Var+                        -- Returns the set element, which may be+                        -- (==) to the argument, but not the same as+lookupVarSetByName :: VarSet -> Name -> Maybe Var+sizeVarSet      :: VarSet -> Int+filterVarSet    :: (Var -> Bool) -> VarSet -> VarSet++delVarSetByKey  :: VarSet -> Unique -> VarSet+elemVarSetByKey :: Unique -> VarSet -> Bool+partitionVarSet :: (Var -> Bool) -> VarSet -> (VarSet, VarSet)++emptyVarSet     = emptyUniqSet+unitVarSet      = unitUniqSet+extendVarSet    = addOneToUniqSet+extendVarSetList= addListToUniqSet+intersectVarSet = intersectUniqSets++intersectsVarSet:: VarSet -> VarSet -> Bool     -- True if non-empty intersection+disjointVarSet  :: VarSet -> VarSet -> Bool     -- True if empty intersection+subVarSet       :: VarSet -> VarSet -> Bool     -- True if first arg is subset of second+        -- (s1 `intersectsVarSet` s2) doesn't compute s2 if s1 is empty;+        -- ditto disjointVarSet, subVarSet++unionVarSet     = unionUniqSets+unionVarSets    = unionManyUniqSets+elemVarSet      = elementOfUniqSet+minusVarSet     = minusUniqSet+delVarSet       = delOneFromUniqSet+delVarSetList   = delListFromUniqSet+isEmptyVarSet   = isEmptyUniqSet+mkVarSet        = mkUniqSet+lookupVarSet_Directly = lookupUniqSet_Directly+lookupVarSet    = lookupUniqSet+lookupVarSetByName = lookupUniqSet+sizeVarSet      = sizeUniqSet+filterVarSet    = filterUniqSet+delVarSetByKey  = delOneFromUniqSet_Directly+elemVarSetByKey = elemUniqSet_Directly+partitionVarSet = partitionUniqSet++mapUnionVarSet get_set xs = foldr (unionVarSet . get_set) emptyVarSet xs++-- See comments with type signatures+intersectsVarSet s1 s2 = not (s1 `disjointVarSet` s2)+disjointVarSet   s1 s2 = disjointUFM (getUniqSet s1) (getUniqSet s2)+subVarSet        s1 s2 = isEmptyVarSet (s1 `minusVarSet` s2)++anyVarSet :: (Var -> Bool) -> VarSet -> Bool+anyVarSet = uniqSetAny++allVarSet :: (Var -> Bool) -> VarSet -> Bool+allVarSet = uniqSetAll++-- There used to exist mapVarSet, see Note [Unsound mapUniqSet] in UniqSet for+-- why it got removed.++fixVarSet :: (VarSet -> VarSet)   -- Map the current set to a new set+          -> VarSet -> VarSet+-- (fixVarSet f s) repeatedly applies f to the set s,+-- until it reaches a fixed point.+fixVarSet fn vars+  | new_vars `subVarSet` vars = vars+  | otherwise                 = fixVarSet fn new_vars+  where+    new_vars = fn vars++transCloVarSet :: (VarSet -> VarSet)+                  -- Map some variables in the set to+                  -- extra variables that should be in it+               -> VarSet -> VarSet+-- (transCloVarSet f s) repeatedly applies f to new candidates, adding any+-- new variables to s that it finds thereby, until it reaches a fixed point.+--+-- The function fn could be (Var -> VarSet), but we use (VarSet -> VarSet)+-- for efficiency, so that the test can be batched up.+-- It's essential that fn will work fine if given new candidates+-- one at at time; ie  fn {v1,v2} = fn v1 `union` fn v2+-- Use fixVarSet if the function needs to see the whole set all at once+transCloVarSet fn seeds+  = go seeds seeds+  where+    go :: VarSet  -- Accumulating result+       -> VarSet  -- Work-list; un-processed subset of accumulating result+       -> VarSet+    -- Specification: go acc vs = acc `union` transClo fn vs++    go acc candidates+       | isEmptyVarSet new_vs = acc+       | otherwise            = go (acc `unionVarSet` new_vs) new_vs+       where+         new_vs = fn candidates `minusVarSet` acc++seqVarSet :: VarSet -> ()+seqVarSet s = sizeVarSet s `seq` ()++-- | Determines the pluralisation suffix appropriate for the length of a set+-- in the same way that plural from Outputable does for lists.+pluralVarSet :: VarSet -> SDoc+pluralVarSet = pluralUFM . getUniqSet++-- | Pretty-print a non-deterministic set.+-- The order of variables is non-deterministic and for pretty-printing that+-- shouldn't be a problem.+-- Having this function helps contain the non-determinism created with+-- nonDetEltsUFM.+-- Passing a list to the pretty-printing function allows the caller+-- to decide on the order of Vars (eg. toposort them) without them having+-- to use nonDetEltsUFM at the call site. This prevents from let-binding+-- non-deterministically ordered lists and reusing them where determinism+-- matters.+pprVarSet :: VarSet          -- ^ The things to be pretty printed+          -> ([Var] -> SDoc) -- ^ The pretty printing function to use on the+                             -- elements+          -> SDoc            -- ^ 'SDoc' where the things have been pretty+                             -- printed+pprVarSet = pprUFM . getUniqSet++-- Deterministic VarSet+-- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need+-- DVarSet.++-- | Deterministic Variable Set+type DVarSet     = UniqDSet Var++-- | Deterministic Identifier Set+type DIdSet      = UniqDSet Id++-- | Deterministic Type Variable Set+type DTyVarSet   = UniqDSet TyVar++-- | Deterministic Type or Coercion Variable Set+type DTyCoVarSet = UniqDSet TyCoVar++emptyDVarSet :: DVarSet+emptyDVarSet = emptyUniqDSet++unitDVarSet :: Var -> DVarSet+unitDVarSet = unitUniqDSet++mkDVarSet :: [Var] -> DVarSet+mkDVarSet = mkUniqDSet++extendDVarSet :: DVarSet -> Var -> DVarSet+extendDVarSet = addOneToUniqDSet++elemDVarSet :: Var -> DVarSet -> Bool+elemDVarSet = elementOfUniqDSet++dVarSetElems :: DVarSet -> [Var]+dVarSetElems = uniqDSetToList++subDVarSet :: DVarSet -> DVarSet -> Bool+subDVarSet s1 s2 = isEmptyDVarSet (s1 `minusDVarSet` s2)++unionDVarSet :: DVarSet -> DVarSet -> DVarSet+unionDVarSet = unionUniqDSets++unionDVarSets :: [DVarSet] -> DVarSet+unionDVarSets = unionManyUniqDSets++-- | Map the function over the list, and union the results+mapUnionDVarSet  :: (a -> DVarSet) -> [a] -> DVarSet+mapUnionDVarSet get_set xs = foldr (unionDVarSet . get_set) emptyDVarSet xs++intersectDVarSet :: DVarSet -> DVarSet -> DVarSet+intersectDVarSet = intersectUniqDSets++-- | True if empty intersection+disjointDVarSet :: DVarSet -> DVarSet -> Bool+disjointDVarSet s1 s2 = disjointUDFM s1 s2++-- | True if non-empty intersection+intersectsDVarSet :: DVarSet -> DVarSet -> Bool+intersectsDVarSet s1 s2 = not (s1 `disjointDVarSet` s2)++isEmptyDVarSet :: DVarSet -> Bool+isEmptyDVarSet = isEmptyUniqDSet++delDVarSet :: DVarSet -> Var -> DVarSet+delDVarSet = delOneFromUniqDSet++minusDVarSet :: DVarSet -> DVarSet -> DVarSet+minusDVarSet = minusUniqDSet++dVarSetMinusVarSet :: DVarSet -> VarSet -> DVarSet+dVarSetMinusVarSet = uniqDSetMinusUniqSet++foldDVarSet :: (Var -> a -> a) -> a -> DVarSet -> a+foldDVarSet = foldUniqDSet++anyDVarSet :: (Var -> Bool) -> DVarSet -> Bool+anyDVarSet = anyUDFM++allDVarSet :: (Var -> Bool) -> DVarSet -> Bool+allDVarSet = allUDFM++filterDVarSet :: (Var -> Bool) -> DVarSet -> DVarSet+filterDVarSet = filterUniqDSet++sizeDVarSet :: DVarSet -> Int+sizeDVarSet = sizeUniqDSet++-- | Partition DVarSet according to the predicate given+partitionDVarSet :: (Var -> Bool) -> DVarSet -> (DVarSet, DVarSet)+partitionDVarSet = partitionUniqDSet++-- | Delete a list of variables from DVarSet+delDVarSetList :: DVarSet -> [Var] -> DVarSet+delDVarSetList = delListFromUniqDSet++seqDVarSet :: DVarSet -> ()+seqDVarSet s = sizeDVarSet s `seq` ()++-- | Add a list of variables to DVarSet+extendDVarSetList :: DVarSet -> [Var] -> DVarSet+extendDVarSetList = addListToUniqDSet++-- | Convert a DVarSet to a VarSet by forgeting the order of insertion+dVarSetToVarSet :: DVarSet -> VarSet+dVarSetToVarSet = unsafeUFMToUniqSet . udfmToUfm++-- | transCloVarSet for DVarSet+transCloDVarSet :: (DVarSet -> DVarSet)+                  -- Map some variables in the set to+                  -- extra variables that should be in it+                -> DVarSet -> DVarSet+-- (transCloDVarSet f s) repeatedly applies f to new candidates, adding any+-- new variables to s that it finds thereby, until it reaches a fixed point.+--+-- The function fn could be (Var -> DVarSet), but we use (DVarSet -> DVarSet)+-- for efficiency, so that the test can be batched up.+-- It's essential that fn will work fine if given new candidates+-- one at at time; ie  fn {v1,v2} = fn v1 `union` fn v2+transCloDVarSet fn seeds+  = go seeds seeds+  where+    go :: DVarSet  -- Accumulating result+       -> DVarSet  -- Work-list; un-processed subset of accumulating result+       -> DVarSet+    -- Specification: go acc vs = acc `union` transClo fn vs++    go acc candidates+       | isEmptyDVarSet new_vs = acc+       | otherwise            = go (acc `unionDVarSet` new_vs) new_vs+       where+         new_vs = fn candidates `minusDVarSet` acc
+ cbits/genSym.c view
@@ -0,0 +1,40 @@+#include <assert.h>+#include "Rts.h"+#include "Unique.h"++static HsInt GenSymCounter = 0;+static HsInt GenSymInc = 1;++#define UNIQUE_BITS (sizeof (HsInt) * 8 - UNIQUE_TAG_BITS)+#define UNIQUE_MASK ((1ULL << UNIQUE_BITS) - 1)++STATIC_INLINE void checkUniqueRange(HsInt u STG_UNUSED) {+#if DEBUG+    // Uh oh! We will overflow next time a unique is requested.+    assert(u != UNIQUE_MASK);+#endif+}++HsInt genSym(void) {+#if defined(THREADED_RTS)+    if (n_capabilities == 1) {+        GenSymCounter = (GenSymCounter + GenSymInc) & UNIQUE_MASK;+        checkUniqueRange(GenSymCounter);+        return GenSymCounter;+    } else {+        HsInt n = atomic_inc((StgWord *)&GenSymCounter, GenSymInc)+          & UNIQUE_MASK;+        checkUniqueRange(n);+        return n;+    }+#else+    GenSymCounter = (GenSymCounter + GenSymInc) & UNIQUE_MASK;+    checkUniqueRange(GenSymCounter);+    return GenSymCounter;+#endif+}++void initGenSym(HsInt NewGenSymCounter, HsInt NewGenSymInc) {+  GenSymCounter = NewGenSymCounter;+  GenSymInc = NewGenSymInc;+}
+ cmm/Bitmap.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE CPP, BangPatterns #-}++--+-- (c) The University of Glasgow 2003-2006+--++-- Functions for constructing bitmaps, which are used in various+-- places in generated code (stack frame liveness masks, function+-- argument liveness masks, SRT bitmaps).++module Bitmap (+        Bitmap, mkBitmap,+        intsToBitmap, intsToReverseBitmap,+        mAX_SMALL_BITMAP_SIZE,+        seqBitmap,+  ) where++#include "HsVersions.h"+#include "MachDeps.h"++import SMRep+import DynFlags+import Util++import Data.Foldable (foldl')+import Data.Bits++{-|+A bitmap represented by a sequence of 'StgWord's on the /target/+architecture.  These are used for bitmaps in info tables and other+generated code which need to be emitted as sequences of StgWords.+-}+type Bitmap = [StgWord]++-- | Make a bitmap from a sequence of bits+mkBitmap :: DynFlags -> [Bool] -> Bitmap+mkBitmap _ [] = []+mkBitmap dflags stuff = chunkToBitmap dflags chunk : mkBitmap dflags rest+  where (chunk, rest) = splitAt (wORD_SIZE_IN_BITS dflags) stuff++chunkToBitmap :: DynFlags -> [Bool] -> StgWord+chunkToBitmap dflags chunk =+  foldl' (.|.) (toStgWord dflags 0) [ oneAt n | (True,n) <- zip chunk [0..] ]+  where+    oneAt :: Int -> StgWord+    oneAt i = toStgWord dflags 1 `shiftL` i++-- | Make a bitmap where the slots specified are the /ones/ in the bitmap.+-- eg. @[0,1,3], size 4 ==> 0xb@.+--+-- The list of @Int@s /must/ be already sorted.+intsToBitmap :: DynFlags+             -> Int        -- ^ size in bits+             -> [Int]      -- ^ sorted indices of ones+             -> Bitmap+intsToBitmap dflags size = go 0+  where+    word_sz = wORD_SIZE_IN_BITS dflags+    oneAt :: Int -> StgWord+    oneAt i = toStgWord dflags 1 `shiftL` i++    -- It is important that we maintain strictness here.+    -- See Note [Strictness when building Bitmaps].+    go :: Int -> [Int] -> Bitmap+    go !pos slots+      | size <= pos = []+      | otherwise =+        (foldl' (.|.) (toStgWord dflags 0) (map (\i->oneAt (i - pos)) these)) :+          go (pos + word_sz) rest+      where+        (these,rest) = span (< (pos + word_sz)) slots++-- | Make a bitmap where the slots specified are the /zeros/ in the bitmap.+-- eg. @[0,1,3], size 4 ==> 0x4@  (we leave any bits outside the size as zero,+-- just to make the bitmap easier to read).+--+-- The list of @Int@s /must/ be already sorted and duplicate-free.+intsToReverseBitmap :: DynFlags+                    -> Int      -- ^ size in bits+                    -> [Int]    -- ^ sorted indices of zeros free of duplicates+                    -> Bitmap+intsToReverseBitmap dflags size = go 0+  where+    word_sz = wORD_SIZE_IN_BITS dflags+    oneAt :: Int -> StgWord+    oneAt i = toStgWord dflags 1 `shiftL` i++    -- It is important that we maintain strictness here.+    -- See Note [Strictness when building Bitmaps].+    go :: Int -> [Int] -> Bitmap+    go !pos slots+      | size <= pos = []+      | otherwise =+        (foldl' xor (toStgWord dflags init) (map (\i->oneAt (i - pos)) these)) :+          go (pos + word_sz) rest+      where+        (these,rest) = span (< (pos + word_sz)) slots+        remain = size - pos+        init+          | remain >= word_sz = -1+          | otherwise         = (1 `shiftL` remain) - 1++{-++Note [Strictness when building Bitmaps]+========================================++One of the places where @Bitmap@ is used is in in building Static Reference+Tables (SRTs) (in @CmmBuildInfoTables.procpointSRT@). In #7450 it was noticed+that some test cases (particularly those whose C-- have large numbers of CAFs)+produced large quantities of allocations from this function.++The source traced back to 'intsToBitmap', which was lazily subtracting the word+size from the elements of the tail of the @slots@ list and recursively invoking+itself with the result. This resulted in large numbers of subtraction thunks+being built up. Here we take care to avoid passing new thunks to the recursive+call. Instead we pass the unmodified tail along with an explicit position+accumulator, which get subtracted in the fold when we compute the Word.++-}++{- |+Magic number, must agree with @BITMAP_BITS_SHIFT@ in InfoTables.h.+Some kinds of bitmap pack a size\/bitmap into a single word if+possible, or fall back to an external pointer when the bitmap is too+large.  This value represents the largest size of bitmap that can be+packed into a single word.+-}+mAX_SMALL_BITMAP_SIZE :: DynFlags -> Int+mAX_SMALL_BITMAP_SIZE dflags+ | wORD_SIZE dflags == 4 = 27+ | otherwise             = 58++seqBitmap :: Bitmap -> a -> a+seqBitmap = seqList+
+ cmm/BlockId.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++{- BlockId module should probably go away completely, being superseded by Label -}+module BlockId+  ( BlockId, mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet+  , newBlockId+  , blockLbl, infoTblLbl+  ) where++import CLabel+import IdInfo+import Name+import Outputable+import Unique+import UniqSupply++import Compiler.Hoopl as Hoopl hiding (Unique)+import Compiler.Hoopl.Internals (uniqueToLbl, lblToUnique)++----------------------------------------------------------------+--- Block Ids, their environments, and their sets++{- Note [Unique BlockId]+~~~~~~~~~~~~~~~~~~~~~~~~+Although a 'BlockId' is a local label, for reasons of implementation,+'BlockId's must be unique within an entire compilation unit.  The reason+is that each local label is mapped to an assembly-language label, and in+most assembly languages allow, a label is visible throughout the entire+compilation unit in which it appears.+-}++type BlockId = Hoopl.Label++instance Uniquable BlockId where+  getUnique label = getUnique (lblToUnique label)++instance Outputable BlockId where+  ppr label = ppr (getUnique label)++mkBlockId :: Unique -> BlockId+mkBlockId unique = uniqueToLbl $ intToUnique $ getKey unique++newBlockId :: MonadUnique m => m BlockId+newBlockId = mkBlockId <$> getUniqueM++blockLbl :: BlockId -> CLabel+blockLbl label = mkEntryLabel (mkFCallName (getUnique label) "block") NoCafRefs++infoTblLbl :: BlockId -> CLabel+infoTblLbl label = mkInfoTableLabel (mkFCallName (getUnique label) "block") NoCafRefs
+ cmm/CLabel.hs view
@@ -0,0 +1,1332 @@+-----------------------------------------------------------------------------+--+-- Object-file symbols (called CLabel for histerical raisins).+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}++module CLabel (+        CLabel, -- abstract type+        ForeignLabelSource(..),+        pprDebugCLabel,++        mkClosureLabel,+        mkSRTLabel,+        mkTopSRTLabel,+        mkInfoTableLabel,+        mkEntryLabel,+        mkSlowEntryLabel,+        mkConEntryLabel,+        mkRednCountsLabel,+        mkConInfoTableLabel,+        mkLargeSRTLabel,+        mkApEntryLabel,+        mkApInfoTableLabel,+        mkClosureTableLabel,+        mkBytesLabel,++        mkLocalClosureLabel,+        mkLocalInfoTableLabel,+        mkLocalEntryLabel,+        mkLocalConEntryLabel,+        mkLocalConInfoTableLabel,+        mkLocalClosureTableLabel,++        mkReturnPtLabel,+        mkReturnInfoLabel,+        mkAltLabel,+        mkDefaultLabel,+        mkBitmapLabel,+        mkStringLitLabel,++        mkAsmTempLabel,+        mkAsmTempDerivedLabel,+        mkAsmTempEndLabel,+        mkAsmTempDieLabel,++        mkPlainModuleInitLabel,++        mkSplitMarkerLabel,+        mkDirty_MUT_VAR_Label,+        mkUpdInfoLabel,+        mkBHUpdInfoLabel,+        mkIndStaticInfoLabel,+        mkMainCapabilityLabel,+        mkMAP_FROZEN_infoLabel,+        mkMAP_FROZEN0_infoLabel,+        mkMAP_DIRTY_infoLabel,+        mkSMAP_FROZEN_infoLabel,+        mkSMAP_FROZEN0_infoLabel,+        mkSMAP_DIRTY_infoLabel,+        mkEMPTY_MVAR_infoLabel,+        mkArrWords_infoLabel,++        mkTopTickyCtrLabel,+        mkCAFBlackHoleInfoTableLabel,+        mkCAFBlackHoleEntryLabel,+        mkRtsPrimOpLabel,+        mkRtsSlowFastTickyCtrLabel,++        mkSelectorInfoLabel,+        mkSelectorEntryLabel,++        mkCmmInfoLabel,+        mkCmmEntryLabel,+        mkCmmRetInfoLabel,+        mkCmmRetLabel,+        mkCmmCodeLabel,+        mkCmmDataLabel,+        mkCmmClosureLabel,++        mkRtsApFastLabel,++        mkPrimCallLabel,++        mkForeignLabel,+        addLabelSize,++        foreignLabelStdcallInfo,+        isBytesLabel,+        isForeignLabel,+        mkCCLabel, mkCCSLabel,++        DynamicLinkerLabelInfo(..),+        mkDynamicLinkerLabel,+        dynamicLinkerLabelInfo,++        mkPicBaseLabel,+        mkDeadStripPreventer,++        mkHpcTicksLabel,++        hasCAF,+        needsCDecl, maybeAsmTemp, externallyVisibleCLabel,+        isMathFun,+        isCFunctionLabel, isGcPtrLabel, labelDynamic,++        -- * Conversions+        toClosureLbl, toSlowEntryLbl, toEntryLbl, toInfoLbl, toRednCountsLbl, hasHaskellName,++        pprCLabel+    ) where++#include "HsVersions.h"++import IdInfo+import BasicTypes+import Packages+import Module+import Name+import Unique+import PrimOp+import Config+import CostCentre+import Outputable+import FastString+import DynFlags+import Platform+import UniqSet+import Util+import PprCore ( {- instances -} )++-- -----------------------------------------------------------------------------+-- The CLabel type++{-+  | CLabel is an abstract type that supports the following operations:++  - Pretty printing++  - In a C file, does it need to be declared before use?  (i.e. is it+    guaranteed to be already in scope in the places we need to refer to it?)++  - If it needs to be declared, what type (code or data) should it be+    declared to have?++  - Is it visible outside this object file or not?++  - Is it "dynamic" (see details below)++  - Eq and Ord, so that we can make sets of CLabels (currently only+    used in outputting C as far as I can tell, to avoid generating+    more than one declaration for any given label).++  - Converting an info table label into an entry label.+-}++data CLabel+  = -- | A label related to the definition of a particular Id or Con in a .hs file.+    IdLabel+        Name+        CafInfo+        IdLabelInfo             -- encodes the suffix of the label++  -- | A label from a .cmm file that is not associated with a .hs level Id.+  | CmmLabel+        UnitId               -- what package the label belongs to.+        FastString              -- identifier giving the prefix of the label+        CmmLabelInfo            -- encodes the suffix of the label++  -- | A label with a baked-in \/ algorithmically generated name that definitely+  --    comes from the RTS. The code for it must compile into libHSrts.a \/ libHSrts.so+  --    If it doesn't have an algorithmically generated name then use a CmmLabel+  --    instead and give it an appropriate UnitId argument.+  | RtsLabel+        RtsLabelInfo++  -- | A 'C' (or otherwise foreign) label.+  --+  | ForeignLabel+        FastString              -- name of the imported label.++        (Maybe Int)             -- possible '@n' suffix for stdcall functions+                                -- When generating C, the '@n' suffix is omitted, but when+                                -- generating assembler we must add it to the label.++        ForeignLabelSource      -- what package the foreign label is in.++        FunctionOrData++  -- | A family of labels related to a particular case expression.+  | CaseLabel+        {-# UNPACK #-} !Unique  -- Unique says which case expression+        CaseLabelInfo++  | AsmTempLabel+        {-# UNPACK #-} !Unique++  | AsmTempDerivedLabel+        CLabel+        FastString              -- suffix++  | StringLitLabel+        {-# UNPACK #-} !Unique++  | PlainModuleInitLabel        -- without the version & way info+        Module++  | CC_Label  CostCentre+  | CCS_Label CostCentreStack+++  -- | These labels are generated and used inside the NCG only.+  --    They are special variants of a label used for dynamic linking+  --    see module PositionIndependentCode for details.+  | DynamicLinkerLabel DynamicLinkerLabelInfo CLabel++  -- | This label is generated and used inside the NCG only.+  --    It is used as a base for PIC calculations on some platforms.+  --    It takes the form of a local numeric assembler label '1'; and+  --    is pretty-printed as 1b, referring to the previous definition+  --    of 1: in the assembler source file.+  | PicBaseLabel++  -- | A label before an info table to prevent excessive dead-stripping on darwin+  | DeadStripPreventer CLabel+++  -- | Per-module table of tick locations+  | HpcTicksLabel Module++  -- | Static reference table+  | SRTLabel !Unique++  -- | Label of an StgLargeSRT+  | LargeSRTLabel+        {-# UNPACK #-} !Unique++  -- | A bitmap (function or case return)+  | LargeBitmapLabel+        {-# UNPACK #-} !Unique++  deriving Eq++-- This is laborious, but necessary. We can't derive Ord because+-- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the+-- implementation. See Note [No Ord for Unique]+-- This is non-deterministic but we do not currently support deterministic+-- code-generation. See Note [Unique Determinism and code generation]+instance Ord CLabel where+  compare (IdLabel a1 b1 c1) (IdLabel a2 b2 c2) =+    compare a1 a2 `thenCmp`+    compare b1 b2 `thenCmp`+    compare c1 c2+  compare (CmmLabel a1 b1 c1) (CmmLabel a2 b2 c2) =+    compare a1 a2 `thenCmp`+    compare b1 b2 `thenCmp`+    compare c1 c2+  compare (RtsLabel a1) (RtsLabel a2) = compare a1 a2+  compare (ForeignLabel a1 b1 c1 d1) (ForeignLabel a2 b2 c2 d2) =+    compare a1 a2 `thenCmp`+    compare b1 b2 `thenCmp`+    compare c1 c2 `thenCmp`+    compare d1 d2+  compare (CaseLabel u1 a1) (CaseLabel u2 a2) =+    nonDetCmpUnique u1 u2 `thenCmp`+    compare a1 a2+  compare (AsmTempLabel u1) (AsmTempLabel u2) = nonDetCmpUnique u1 u2+  compare (AsmTempDerivedLabel a1 b1) (AsmTempDerivedLabel a2 b2) =+    compare a1 a2 `thenCmp`+    compare b1 b2+  compare (StringLitLabel u1) (StringLitLabel u2) =+    nonDetCmpUnique u1 u2+  compare (PlainModuleInitLabel a1) (PlainModuleInitLabel a2) =+    compare a1 a2+  compare (CC_Label a1) (CC_Label a2) =+    compare a1 a2+  compare (CCS_Label a1) (CCS_Label a2) =+    compare a1 a2+  compare (DynamicLinkerLabel a1 b1) (DynamicLinkerLabel a2 b2) =+    compare a1 a2 `thenCmp`+    compare b1 b2+  compare PicBaseLabel PicBaseLabel = EQ+  compare (DeadStripPreventer a1) (DeadStripPreventer a2) =+    compare a1 a2+  compare (HpcTicksLabel a1) (HpcTicksLabel a2) =+    compare a1 a2+  compare (SRTLabel u1) (SRTLabel u2) =+    nonDetCmpUnique u1 u2+  compare (LargeSRTLabel u1) (LargeSRTLabel u2) =+    nonDetCmpUnique u1 u2+  compare (LargeBitmapLabel u1) (LargeBitmapLabel u2) =+    nonDetCmpUnique u1 u2+  compare IdLabel{} _ = LT+  compare _ IdLabel{} = GT+  compare CmmLabel{} _ = LT+  compare _ CmmLabel{} = GT+  compare RtsLabel{} _ = LT+  compare _ RtsLabel{} = GT+  compare ForeignLabel{} _ = LT+  compare _ ForeignLabel{} = GT+  compare CaseLabel{} _ = LT+  compare _ CaseLabel{} = GT+  compare AsmTempLabel{} _ = LT+  compare _ AsmTempLabel{} = GT+  compare AsmTempDerivedLabel{} _ = LT+  compare _ AsmTempDerivedLabel{} = GT+  compare StringLitLabel{} _ = LT+  compare _ StringLitLabel{} = GT+  compare PlainModuleInitLabel{} _ = LT+  compare _ PlainModuleInitLabel{} = GT+  compare CC_Label{} _ = LT+  compare _ CC_Label{} = GT+  compare CCS_Label{} _ = LT+  compare _ CCS_Label{} = GT+  compare DynamicLinkerLabel{} _ = LT+  compare _ DynamicLinkerLabel{} = GT+  compare PicBaseLabel{} _ = LT+  compare _ PicBaseLabel{} = GT+  compare DeadStripPreventer{} _ = LT+  compare _ DeadStripPreventer{} = GT+  compare HpcTicksLabel{} _ = LT+  compare _ HpcTicksLabel{} = GT+  compare SRTLabel{} _ = LT+  compare _ SRTLabel{} = GT+  compare LargeSRTLabel{} _ = LT+  compare _ LargeSRTLabel{} = GT++-- | Record where a foreign label is stored.+data ForeignLabelSource++   -- | Label is in a named package+   = ForeignLabelInPackage      UnitId++   -- | Label is in some external, system package that doesn't also+   --   contain compiled Haskell code, and is not associated with any .hi files.+   --   We don't have to worry about Haskell code being inlined from+   --   external packages. It is safe to treat the RTS package as "external".+   | ForeignLabelInExternalPackage++   -- | Label is in the package currenly being compiled.+   --   This is only used for creating hacky tmp labels during code generation.+   --   Don't use it in any code that might be inlined across a package boundary+   --   (ie, core code) else the information will be wrong relative to the+   --   destination module.+   | ForeignLabelInThisPackage++   deriving (Eq, Ord)+++-- | For debugging problems with the CLabel representation.+--      We can't make a Show instance for CLabel because lots of its components don't have instances.+--      The regular Outputable instance only shows the label name, and not its other info.+--+pprDebugCLabel :: CLabel -> SDoc+pprDebugCLabel lbl+ = case lbl of+        IdLabel{}       -> ppr lbl <> (parens $ text "IdLabel")+        CmmLabel pkg _name _info+         -> ppr lbl <> (parens $ text "CmmLabel" <+> ppr pkg)++        RtsLabel{}      -> ppr lbl <> (parens $ text "RtsLabel")++        ForeignLabel _name mSuffix src funOrData+            -> ppr lbl <> (parens $ text "ForeignLabel"+                                <+> ppr mSuffix+                                <+> ppr src+                                <+> ppr funOrData)++        _               -> ppr lbl <> (parens $ text "other CLabel)")+++data IdLabelInfo+  = Closure             -- ^ Label for closure+  | SRT                 -- ^ Static reference table (TODO: could be removed+                        -- with the old code generator, but might be needed+                        -- when we implement the New SRT Plan)+  | InfoTable           -- ^ Info tables for closures; always read-only+  | Entry               -- ^ Entry point+  | Slow                -- ^ Slow entry point++  | LocalInfoTable      -- ^ Like InfoTable but not externally visible+  | LocalEntry          -- ^ Like Entry but not externally visible++  | RednCounts          -- ^ Label of place to keep Ticky-ticky  info for this Id++  | ConEntry            -- ^ Constructor entry point+  | ConInfoTable        -- ^ Corresponding info table++  | ClosureTable        -- ^ Table of closures for Enum tycons++  | Bytes               -- ^ Content of a string literal. See+                        -- Note [Bytes label].++  deriving (Eq, Ord)+++data CaseLabelInfo+  = CaseReturnPt+  | CaseReturnInfo+  | CaseAlt ConTag+  | CaseDefault+  deriving (Eq, Ord)+++data RtsLabelInfo+  = RtsSelectorInfoTable Bool{-updatable-} Int{-offset-}  -- ^ Selector thunks+  | RtsSelectorEntry     Bool{-updatable-} Int{-offset-}++  | RtsApInfoTable       Bool{-updatable-} Int{-arity-}    -- ^ AP thunks+  | RtsApEntry           Bool{-updatable-} Int{-arity-}++  | RtsPrimOp PrimOp+  | RtsApFast     FastString    -- ^ _fast versions of generic apply+  | RtsSlowFastTickyCtr String++  deriving (Eq, Ord)+  -- NOTE: Eq on LitString compares the pointer only, so this isn't+  -- a real equality.+++-- | What type of Cmm label we're dealing with.+--      Determines the suffix appended to the name when a CLabel.CmmLabel+--      is pretty printed.+data CmmLabelInfo+  = CmmInfo                     -- ^ misc rts info tabless,     suffix _info+  | CmmEntry                    -- ^ misc rts entry points,     suffix _entry+  | CmmRetInfo                  -- ^ misc rts ret info tables,  suffix _info+  | CmmRet                      -- ^ misc rts return points,    suffix _ret+  | CmmData                     -- ^ misc rts data bits, eg CHARLIKE_closure+  | CmmCode                     -- ^ misc rts code+  | CmmClosure                  -- ^ closures eg CHARLIKE_closure+  | CmmPrimCall                 -- ^ a prim call to some hand written Cmm code+  deriving (Eq, Ord)++data DynamicLinkerLabelInfo+  = CodeStub                    -- MachO: Lfoo$stub, ELF: foo@plt+  | SymbolPtr                   -- MachO: Lfoo$non_lazy_ptr, Windows: __imp_foo+  | GotSymbolPtr                -- ELF: foo@got+  | GotSymbolOffset             -- ELF: foo@gotoff++  deriving (Eq, Ord)+++-- -----------------------------------------------------------------------------+-- Constructing CLabels+-- -----------------------------------------------------------------------------++-- Constructing IdLabels+-- These are always local:+mkSlowEntryLabel :: Name -> CafInfo -> CLabel+mkSlowEntryLabel        name c         = IdLabel name  c Slow++mkTopSRTLabel     :: Unique -> CLabel+mkTopSRTLabel u = SRTLabel u++mkSRTLabel        :: Name -> CafInfo -> CLabel+mkRednCountsLabel :: Name -> CLabel+mkSRTLabel              name c  = IdLabel name  c SRT+mkRednCountsLabel       name    =+  IdLabel name NoCafRefs RednCounts  -- Note [ticky for LNE]++-- These have local & (possibly) external variants:+mkLocalClosureLabel      :: Name -> CafInfo -> CLabel+mkLocalInfoTableLabel    :: Name -> CafInfo -> CLabel+mkLocalEntryLabel        :: Name -> CafInfo -> CLabel+mkLocalClosureTableLabel :: Name -> CafInfo -> CLabel+mkLocalClosureLabel     name c  = IdLabel name  c Closure+mkLocalInfoTableLabel   name c  = IdLabel name  c LocalInfoTable+mkLocalEntryLabel       name c  = IdLabel name  c LocalEntry+mkLocalClosureTableLabel name c = IdLabel name  c ClosureTable++mkClosureLabel              :: Name -> CafInfo -> CLabel+mkInfoTableLabel            :: Name -> CafInfo -> CLabel+mkEntryLabel                :: Name -> CafInfo -> CLabel+mkClosureTableLabel         :: Name -> CafInfo -> CLabel+mkLocalConInfoTableLabel    :: CafInfo -> Name -> CLabel+mkLocalConEntryLabel        :: CafInfo -> Name -> CLabel+mkConInfoTableLabel         :: Name -> CafInfo -> CLabel+mkBytesLabel                :: Name -> CLabel+mkClosureLabel name         c     = IdLabel name c Closure+mkInfoTableLabel name       c     = IdLabel name c InfoTable+mkEntryLabel name           c     = IdLabel name c Entry+mkClosureTableLabel name    c     = IdLabel name c ClosureTable+mkLocalConInfoTableLabel    c con = IdLabel con c ConInfoTable+mkLocalConEntryLabel        c con = IdLabel con c ConEntry+mkConInfoTableLabel name    c     = IdLabel name c ConInfoTable+mkBytesLabel name                 = IdLabel name NoCafRefs Bytes++mkConEntryLabel       :: Name -> CafInfo -> CLabel+mkConEntryLabel name        c     = IdLabel name c ConEntry++-- Constructing Cmm Labels+mkDirty_MUT_VAR_Label, mkSplitMarkerLabel, mkUpdInfoLabel,+    mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel,+    mkMAP_FROZEN_infoLabel, mkMAP_FROZEN0_infoLabel, mkMAP_DIRTY_infoLabel,+    mkEMPTY_MVAR_infoLabel, mkTopTickyCtrLabel,+    mkCAFBlackHoleInfoTableLabel, mkCAFBlackHoleEntryLabel,+    mkArrWords_infoLabel, mkSMAP_FROZEN_infoLabel, mkSMAP_FROZEN0_infoLabel,+    mkSMAP_DIRTY_infoLabel :: CLabel+mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction+mkSplitMarkerLabel              = CmmLabel rtsUnitId (fsLit "__stg_split_marker")    CmmCode+mkUpdInfoLabel                  = CmmLabel rtsUnitId (fsLit "stg_upd_frame")         CmmInfo+mkBHUpdInfoLabel                = CmmLabel rtsUnitId (fsLit "stg_bh_upd_frame" )     CmmInfo+mkIndStaticInfoLabel            = CmmLabel rtsUnitId (fsLit "stg_IND_STATIC")        CmmInfo+mkMainCapabilityLabel           = CmmLabel rtsUnitId (fsLit "MainCapability")        CmmData+mkMAP_FROZEN_infoLabel          = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_FROZEN") CmmInfo+mkMAP_FROZEN0_infoLabel         = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_FROZEN0") CmmInfo+mkMAP_DIRTY_infoLabel           = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo+mkEMPTY_MVAR_infoLabel          = CmmLabel rtsUnitId (fsLit "stg_EMPTY_MVAR")        CmmInfo+mkTopTickyCtrLabel              = CmmLabel rtsUnitId (fsLit "top_ct")                CmmData+mkCAFBlackHoleInfoTableLabel    = CmmLabel rtsUnitId (fsLit "stg_CAF_BLACKHOLE")     CmmInfo+mkCAFBlackHoleEntryLabel        = CmmLabel rtsUnitId (fsLit "stg_CAF_BLACKHOLE")     CmmEntry+mkArrWords_infoLabel            = CmmLabel rtsUnitId (fsLit "stg_ARR_WORDS")         CmmInfo+mkSMAP_FROZEN_infoLabel         = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN") CmmInfo+mkSMAP_FROZEN0_infoLabel        = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN0") CmmInfo+mkSMAP_DIRTY_infoLabel          = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo++-----+mkCmmInfoLabel,   mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,+  mkCmmCodeLabel, mkCmmDataLabel,  mkCmmClosureLabel+        :: UnitId -> FastString -> CLabel++mkCmmInfoLabel      pkg str     = CmmLabel pkg str CmmInfo+mkCmmEntryLabel     pkg str     = CmmLabel pkg str CmmEntry+mkCmmRetInfoLabel   pkg str     = CmmLabel pkg str CmmRetInfo+mkCmmRetLabel       pkg str     = CmmLabel pkg str CmmRet+mkCmmCodeLabel      pkg str     = CmmLabel pkg str CmmCode+mkCmmDataLabel      pkg str     = CmmLabel pkg str CmmData+mkCmmClosureLabel   pkg str     = CmmLabel pkg str CmmClosure+++-- Constructing RtsLabels+mkRtsPrimOpLabel :: PrimOp -> CLabel+mkRtsPrimOpLabel primop         = RtsLabel (RtsPrimOp primop)++mkSelectorInfoLabel  :: Bool -> Int -> CLabel+mkSelectorEntryLabel :: Bool -> Int -> CLabel+mkSelectorInfoLabel  upd off    = RtsLabel (RtsSelectorInfoTable upd off)+mkSelectorEntryLabel upd off    = RtsLabel (RtsSelectorEntry     upd off)++mkApInfoTableLabel :: Bool -> Int -> CLabel+mkApEntryLabel     :: Bool -> Int -> CLabel+mkApInfoTableLabel   upd off    = RtsLabel (RtsApInfoTable       upd off)+mkApEntryLabel       upd off    = RtsLabel (RtsApEntry           upd off)+++-- A call to some primitive hand written Cmm code+mkPrimCallLabel :: PrimCall -> CLabel+mkPrimCallLabel (PrimCall str pkg)+        = CmmLabel pkg str CmmPrimCall+++-- Constructing ForeignLabels++-- | Make a foreign label+mkForeignLabel+        :: FastString           -- name+        -> Maybe Int            -- size prefix+        -> ForeignLabelSource   -- what package it's in+        -> FunctionOrData+        -> CLabel++mkForeignLabel str mb_sz src fod+    = ForeignLabel str mb_sz src  fod+++-- | Update the label size field in a ForeignLabel+addLabelSize :: CLabel -> Int -> CLabel+addLabelSize (ForeignLabel str _ src  fod) sz+    = ForeignLabel str (Just sz) src fod+addLabelSize label _+    = label++-- | Whether label is a top-level string literal+isBytesLabel :: CLabel -> Bool+isBytesLabel (IdLabel _ _ Bytes) = True+isBytesLabel _lbl = False++-- | Whether label is a non-haskell label (defined in C code)+isForeignLabel :: CLabel -> Bool+isForeignLabel (ForeignLabel _ _ _ _) = True+isForeignLabel _lbl = False++-- | Get the label size field from a ForeignLabel+foreignLabelStdcallInfo :: CLabel -> Maybe Int+foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info+foreignLabelStdcallInfo _lbl = Nothing+++-- Constructing Large*Labels+mkLargeSRTLabel :: Unique -> CLabel+mkBitmapLabel   :: Unique -> CLabel+mkLargeSRTLabel uniq            = LargeSRTLabel uniq+mkBitmapLabel   uniq            = LargeBitmapLabel uniq+++-- Constructin CaseLabels+mkReturnPtLabel   :: Unique -> CLabel+mkReturnInfoLabel :: Unique -> CLabel+mkAltLabel        :: Unique -> ConTag -> CLabel+mkDefaultLabel    :: Unique -> CLabel+mkReturnPtLabel uniq            = CaseLabel uniq CaseReturnPt+mkReturnInfoLabel uniq          = CaseLabel uniq CaseReturnInfo+mkAltLabel      uniq tag        = CaseLabel uniq (CaseAlt tag)+mkDefaultLabel  uniq            = CaseLabel uniq CaseDefault++-- Constructing Cost Center Labels+mkCCLabel  :: CostCentre      -> CLabel+mkCCSLabel :: CostCentreStack -> CLabel+mkCCLabel           cc          = CC_Label cc+mkCCSLabel          ccs         = CCS_Label ccs++mkRtsApFastLabel :: FastString -> CLabel+mkRtsApFastLabel str = RtsLabel (RtsApFast str)++mkRtsSlowFastTickyCtrLabel :: String -> CLabel+mkRtsSlowFastTickyCtrLabel pat = RtsLabel (RtsSlowFastTickyCtr pat)+++-- Constructing Code Coverage Labels+mkHpcTicksLabel :: Module -> CLabel+mkHpcTicksLabel                = HpcTicksLabel+++-- Constructing labels used for dynamic linking+mkDynamicLinkerLabel :: DynamicLinkerLabelInfo -> CLabel -> CLabel+mkDynamicLinkerLabel            = DynamicLinkerLabel++dynamicLinkerLabelInfo :: CLabel -> Maybe (DynamicLinkerLabelInfo, CLabel)+dynamicLinkerLabelInfo (DynamicLinkerLabel info lbl) = Just (info, lbl)+dynamicLinkerLabelInfo _        = Nothing++mkPicBaseLabel :: CLabel+mkPicBaseLabel                  = PicBaseLabel+++-- Constructing miscellaneous other labels+mkDeadStripPreventer :: CLabel -> CLabel+mkDeadStripPreventer lbl        = DeadStripPreventer lbl++mkStringLitLabel :: Unique -> CLabel+mkStringLitLabel                = StringLitLabel++mkAsmTempLabel :: Uniquable a => a -> CLabel+mkAsmTempLabel a                = AsmTempLabel (getUnique a)++mkAsmTempDerivedLabel :: CLabel -> FastString -> CLabel+mkAsmTempDerivedLabel = AsmTempDerivedLabel++mkAsmTempEndLabel :: CLabel -> CLabel+mkAsmTempEndLabel l = mkAsmTempDerivedLabel l (fsLit "_end")+mkPlainModuleInitLabel :: Module -> CLabel+mkPlainModuleInitLabel mod      = PlainModuleInitLabel mod++-- | Construct a label for a DWARF Debug Information Entity (DIE)+-- describing another symbol.+mkAsmTempDieLabel :: CLabel -> CLabel+mkAsmTempDieLabel l = mkAsmTempDerivedLabel l (fsLit "_die")++-- -----------------------------------------------------------------------------+-- Convert between different kinds of label++toClosureLbl :: CLabel -> CLabel+toClosureLbl (IdLabel n c _) = IdLabel n c Closure+toClosureLbl (CmmLabel m str _) = CmmLabel m str CmmClosure+toClosureLbl l = pprPanic "toClosureLbl" (ppr l)++toSlowEntryLbl :: CLabel -> CLabel+toSlowEntryLbl (IdLabel n c _) = IdLabel n c Slow+toSlowEntryLbl l = pprPanic "toSlowEntryLbl" (ppr l)++toEntryLbl :: CLabel -> CLabel+toEntryLbl (IdLabel n c LocalInfoTable)  = IdLabel n c LocalEntry+toEntryLbl (IdLabel n c ConInfoTable)    = IdLabel n c ConEntry+toEntryLbl (IdLabel n c _)               = IdLabel n c Entry+toEntryLbl (CaseLabel n CaseReturnInfo)  = CaseLabel n CaseReturnPt+toEntryLbl (CmmLabel m str CmmInfo)      = CmmLabel m str CmmEntry+toEntryLbl (CmmLabel m str CmmRetInfo)   = CmmLabel m str CmmRet+toEntryLbl l = pprPanic "toEntryLbl" (ppr l)++toInfoLbl :: CLabel -> CLabel+toInfoLbl (IdLabel n c Entry)          = IdLabel n c InfoTable+toInfoLbl (IdLabel n c LocalEntry)     = IdLabel n c LocalInfoTable+toInfoLbl (IdLabel n c ConEntry)       = IdLabel n c ConInfoTable+toInfoLbl (IdLabel n c _)              = IdLabel n c InfoTable+toInfoLbl (CaseLabel n CaseReturnPt)   = CaseLabel n CaseReturnInfo+toInfoLbl (CmmLabel m str CmmEntry)    = CmmLabel m str CmmInfo+toInfoLbl (CmmLabel m str CmmRet)      = CmmLabel m str CmmRetInfo+toInfoLbl l = pprPanic "CLabel.toInfoLbl" (ppr l)++toRednCountsLbl :: CLabel -> Maybe CLabel+toRednCountsLbl = fmap mkRednCountsLabel . hasHaskellName++hasHaskellName :: CLabel -> Maybe Name+hasHaskellName (IdLabel n _ _) = Just n+hasHaskellName _               = Nothing++-- -----------------------------------------------------------------------------+-- Does a CLabel's referent itself refer to a CAF?+hasCAF :: CLabel -> Bool+hasCAF (IdLabel _ _ RednCounts) = False -- Note [ticky for LNE]+hasCAF (IdLabel _ MayHaveCafRefs _) = True+hasCAF _                            = False++-- Note [ticky for LNE]+-- ~~~~~~~~~~~~~~~~~~~~~++-- Until 14 Feb 2013, every ticky counter was associated with a+-- closure. Thus, ticky labels used IdLabel. It is odd that+-- CmmBuildInfoTables.cafTransfers would consider such a ticky label+-- reason to add the name to the CAFEnv (and thus eventually the SRT),+-- but it was harmless because the ticky was only used if the closure+-- was also.+--+-- Since we now have ticky counters for LNEs, it is no longer the case+-- that every ticky counter has an actual closure. So I changed the+-- generation of ticky counters' CLabels to not result in their+-- associated id ending up in the SRT.+--+-- NB IdLabel is still appropriate for ticky ids (as opposed to+-- CmmLabel) because the LNE's counter is still related to an .hs Id,+-- that Id just isn't for a proper closure.++-- -----------------------------------------------------------------------------+-- Does a CLabel need declaring before use or not?+--+-- See wiki:Commentary/Compiler/Backends/PprC#Prototypes++needsCDecl :: CLabel -> Bool+  -- False <=> it's pre-declared; don't bother+  -- don't bother declaring Bitmap labels, we always make sure+  -- they are defined before use.+needsCDecl (SRTLabel _)                 = True+needsCDecl (LargeSRTLabel _)            = False+needsCDecl (LargeBitmapLabel _)         = False+needsCDecl (IdLabel _ _ _)              = True+needsCDecl (CaseLabel _ _)              = True+needsCDecl (PlainModuleInitLabel _)     = True++needsCDecl (StringLitLabel _)           = False+needsCDecl (AsmTempLabel _)             = False+needsCDecl (AsmTempDerivedLabel _ _)    = False+needsCDecl (RtsLabel _)                 = False++needsCDecl (CmmLabel pkgId _ _)+        -- Prototypes for labels defined in the runtime system are imported+        --      into HC files via includes/Stg.h.+        | pkgId == rtsUnitId         = False++        -- For other labels we inline one into the HC file directly.+        | otherwise                     = True++needsCDecl l@(ForeignLabel{})           = not (isMathFun l)+needsCDecl (CC_Label _)                 = True+needsCDecl (CCS_Label _)                = True+needsCDecl (HpcTicksLabel _)            = True+needsCDecl (DynamicLinkerLabel {})      = panic "needsCDecl DynamicLinkerLabel"+needsCDecl PicBaseLabel                 = panic "needsCDecl PicBaseLabel"+needsCDecl (DeadStripPreventer {})      = panic "needsCDecl DeadStripPreventer"++-- | If a label is a local temporary used for native code generation+--      then return just its unique, otherwise nothing.+maybeAsmTemp :: CLabel -> Maybe Unique+maybeAsmTemp (AsmTempLabel uq)          = Just uq+maybeAsmTemp _                          = Nothing+++-- | Check whether a label corresponds to a C function that has+--      a prototype in a system header somehere, or is built-in+--      to the C compiler. For these labels we avoid generating our+--      own C prototypes.+isMathFun :: CLabel -> Bool+isMathFun (ForeignLabel fs _ _ _)       = fs `elementOfUniqSet` math_funs+isMathFun _ = False++math_funs :: UniqSet FastString+math_funs = mkUniqSet [+        -- _ISOC99_SOURCE+        (fsLit "acos"),         (fsLit "acosf"),        (fsLit "acosh"),+        (fsLit "acoshf"),       (fsLit "acoshl"),       (fsLit "acosl"),+        (fsLit "asin"),         (fsLit "asinf"),        (fsLit "asinl"),+        (fsLit "asinh"),        (fsLit "asinhf"),       (fsLit "asinhl"),+        (fsLit "atan"),         (fsLit "atanf"),        (fsLit "atanl"),+        (fsLit "atan2"),        (fsLit "atan2f"),       (fsLit "atan2l"),+        (fsLit "atanh"),        (fsLit "atanhf"),       (fsLit "atanhl"),+        (fsLit "cbrt"),         (fsLit "cbrtf"),        (fsLit "cbrtl"),+        (fsLit "ceil"),         (fsLit "ceilf"),        (fsLit "ceill"),+        (fsLit "copysign"),     (fsLit "copysignf"),    (fsLit "copysignl"),+        (fsLit "cos"),          (fsLit "cosf"),         (fsLit "cosl"),+        (fsLit "cosh"),         (fsLit "coshf"),        (fsLit "coshl"),+        (fsLit "erf"),          (fsLit "erff"),         (fsLit "erfl"),+        (fsLit "erfc"),         (fsLit "erfcf"),        (fsLit "erfcl"),+        (fsLit "exp"),          (fsLit "expf"),         (fsLit "expl"),+        (fsLit "exp2"),         (fsLit "exp2f"),        (fsLit "exp2l"),+        (fsLit "expm1"),        (fsLit "expm1f"),       (fsLit "expm1l"),+        (fsLit "fabs"),         (fsLit "fabsf"),        (fsLit "fabsl"),+        (fsLit "fdim"),         (fsLit "fdimf"),        (fsLit "fdiml"),+        (fsLit "floor"),        (fsLit "floorf"),       (fsLit "floorl"),+        (fsLit "fma"),          (fsLit "fmaf"),         (fsLit "fmal"),+        (fsLit "fmax"),         (fsLit "fmaxf"),        (fsLit "fmaxl"),+        (fsLit "fmin"),         (fsLit "fminf"),        (fsLit "fminl"),+        (fsLit "fmod"),         (fsLit "fmodf"),        (fsLit "fmodl"),+        (fsLit "frexp"),        (fsLit "frexpf"),       (fsLit "frexpl"),+        (fsLit "hypot"),        (fsLit "hypotf"),       (fsLit "hypotl"),+        (fsLit "ilogb"),        (fsLit "ilogbf"),       (fsLit "ilogbl"),+        (fsLit "ldexp"),        (fsLit "ldexpf"),       (fsLit "ldexpl"),+        (fsLit "lgamma"),       (fsLit "lgammaf"),      (fsLit "lgammal"),+        (fsLit "llrint"),       (fsLit "llrintf"),      (fsLit "llrintl"),+        (fsLit "llround"),      (fsLit "llroundf"),     (fsLit "llroundl"),+        (fsLit "log"),          (fsLit "logf"),         (fsLit "logl"),+        (fsLit "log10l"),       (fsLit "log10"),        (fsLit "log10f"),+        (fsLit "log1pl"),       (fsLit "log1p"),        (fsLit "log1pf"),+        (fsLit "log2"),         (fsLit "log2f"),        (fsLit "log2l"),+        (fsLit "logb"),         (fsLit "logbf"),        (fsLit "logbl"),+        (fsLit "lrint"),        (fsLit "lrintf"),       (fsLit "lrintl"),+        (fsLit "lround"),       (fsLit "lroundf"),      (fsLit "lroundl"),+        (fsLit "modf"),         (fsLit "modff"),        (fsLit "modfl"),+        (fsLit "nan"),          (fsLit "nanf"),         (fsLit "nanl"),+        (fsLit "nearbyint"),    (fsLit "nearbyintf"),   (fsLit "nearbyintl"),+        (fsLit "nextafter"),    (fsLit "nextafterf"),   (fsLit "nextafterl"),+        (fsLit "nexttoward"),   (fsLit "nexttowardf"),  (fsLit "nexttowardl"),+        (fsLit "pow"),          (fsLit "powf"),         (fsLit "powl"),+        (fsLit "remainder"),    (fsLit "remainderf"),   (fsLit "remainderl"),+        (fsLit "remquo"),       (fsLit "remquof"),      (fsLit "remquol"),+        (fsLit "rint"),         (fsLit "rintf"),        (fsLit "rintl"),+        (fsLit "round"),        (fsLit "roundf"),       (fsLit "roundl"),+        (fsLit "scalbln"),      (fsLit "scalblnf"),     (fsLit "scalblnl"),+        (fsLit "scalbn"),       (fsLit "scalbnf"),      (fsLit "scalbnl"),+        (fsLit "sin"),          (fsLit "sinf"),         (fsLit "sinl"),+        (fsLit "sinh"),         (fsLit "sinhf"),        (fsLit "sinhl"),+        (fsLit "sqrt"),         (fsLit "sqrtf"),        (fsLit "sqrtl"),+        (fsLit "tan"),          (fsLit "tanf"),         (fsLit "tanl"),+        (fsLit "tanh"),         (fsLit "tanhf"),        (fsLit "tanhl"),+        (fsLit "tgamma"),       (fsLit "tgammaf"),      (fsLit "tgammal"),+        (fsLit "trunc"),        (fsLit "truncf"),       (fsLit "truncl"),+        -- ISO C 99 also defines these function-like macros in math.h:+        -- fpclassify, isfinite, isinf, isnormal, signbit, isgreater,+        -- isgreaterequal, isless, islessequal, islessgreater, isunordered++        -- additional symbols from _BSD_SOURCE+        (fsLit "drem"),         (fsLit "dremf"),        (fsLit "dreml"),+        (fsLit "finite"),       (fsLit "finitef"),      (fsLit "finitel"),+        (fsLit "gamma"),        (fsLit "gammaf"),       (fsLit "gammal"),+        (fsLit "isinf"),        (fsLit "isinff"),       (fsLit "isinfl"),+        (fsLit "isnan"),        (fsLit "isnanf"),       (fsLit "isnanl"),+        (fsLit "j0"),           (fsLit "j0f"),          (fsLit "j0l"),+        (fsLit "j1"),           (fsLit "j1f"),          (fsLit "j1l"),+        (fsLit "jn"),           (fsLit "jnf"),          (fsLit "jnl"),+        (fsLit "lgamma_r"),     (fsLit "lgammaf_r"),    (fsLit "lgammal_r"),+        (fsLit "scalb"),        (fsLit "scalbf"),       (fsLit "scalbl"),+        (fsLit "significand"),  (fsLit "significandf"), (fsLit "significandl"),+        (fsLit "y0"),           (fsLit "y0f"),          (fsLit "y0l"),+        (fsLit "y1"),           (fsLit "y1f"),          (fsLit "y1l"),+        (fsLit "yn"),           (fsLit "ynf"),          (fsLit "ynl"),++        -- These functions are described in IEEE Std 754-2008 -+        -- Standard for Floating-Point Arithmetic and ISO/IEC TS 18661+        (fsLit "nextup"),       (fsLit "nextupf"),      (fsLit "nextupl"),+        (fsLit "nextdown"),     (fsLit "nextdownf"),    (fsLit "nextdownl")+    ]++-- -----------------------------------------------------------------------------+-- | Is a CLabel visible outside this object file or not?+--      From the point of view of the code generator, a name is+--      externally visible if it has to be declared as exported+--      in the .o file's symbol table; that is, made non-static.+externallyVisibleCLabel :: CLabel -> Bool -- not C "static"+externallyVisibleCLabel (CaseLabel _ _)         = False+externallyVisibleCLabel (StringLitLabel _)      = False+externallyVisibleCLabel (AsmTempLabel _)        = False+externallyVisibleCLabel (AsmTempDerivedLabel _ _)= False+externallyVisibleCLabel (PlainModuleInitLabel _)= True+externallyVisibleCLabel (RtsLabel _)            = True+externallyVisibleCLabel (CmmLabel _ _ _)        = True+externallyVisibleCLabel (ForeignLabel{})        = True+externallyVisibleCLabel (IdLabel name _ info)   = isExternalName name && externallyVisibleIdLabel info+externallyVisibleCLabel (CC_Label _)            = True+externallyVisibleCLabel (CCS_Label _)           = True+externallyVisibleCLabel (DynamicLinkerLabel _ _)  = False+externallyVisibleCLabel (HpcTicksLabel _)       = True+externallyVisibleCLabel (LargeBitmapLabel _)    = False+externallyVisibleCLabel (SRTLabel _)            = False+externallyVisibleCLabel (LargeSRTLabel _)       = False+externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel"+externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer"++externallyVisibleIdLabel :: IdLabelInfo -> Bool+externallyVisibleIdLabel SRT             = False+externallyVisibleIdLabel LocalInfoTable  = False+externallyVisibleIdLabel LocalEntry      = False+externallyVisibleIdLabel _               = True++-- -----------------------------------------------------------------------------+-- Finding the "type" of a CLabel++-- For generating correct types in label declarations:++data CLabelType+  = CodeLabel   -- Address of some executable instructions+  | DataLabel   -- Address of data, not a GC ptr+  | GcPtrLabel  -- Address of a (presumably static) GC object++isCFunctionLabel :: CLabel -> Bool+isCFunctionLabel lbl = case labelType lbl of+                        CodeLabel -> True+                        _other    -> False++isGcPtrLabel :: CLabel -> Bool+isGcPtrLabel lbl = case labelType lbl of+                        GcPtrLabel -> True+                        _other     -> False+++-- | Work out the general type of data at the address of this label+--    whether it be code, data, or static GC object.+labelType :: CLabel -> CLabelType+labelType (CmmLabel _ _ CmmData)                = DataLabel+labelType (CmmLabel _ _ CmmClosure)             = GcPtrLabel+labelType (CmmLabel _ _ CmmCode)                = CodeLabel+labelType (CmmLabel _ _ CmmInfo)                = DataLabel+labelType (CmmLabel _ _ CmmEntry)               = CodeLabel+labelType (CmmLabel _ _ CmmPrimCall)            = CodeLabel+labelType (CmmLabel _ _ CmmRetInfo)             = DataLabel+labelType (CmmLabel _ _ CmmRet)                 = CodeLabel+labelType (RtsLabel (RtsSelectorInfoTable _ _)) = DataLabel+labelType (RtsLabel (RtsApInfoTable _ _))       = DataLabel+labelType (RtsLabel (RtsApFast _))              = CodeLabel+labelType (CaseLabel _ CaseReturnInfo)          = DataLabel+labelType (CaseLabel _ _)                       = CodeLabel+labelType (PlainModuleInitLabel _)              = CodeLabel+labelType (SRTLabel _)                          = DataLabel+labelType (LargeSRTLabel _)                     = DataLabel+labelType (LargeBitmapLabel _)                  = DataLabel+labelType (ForeignLabel _ _ _ IsFunction)       = CodeLabel+labelType (IdLabel _ _ info)                    = idInfoLabelType info+labelType _                                     = DataLabel++idInfoLabelType :: IdLabelInfo -> CLabelType+idInfoLabelType info =+  case info of+    InfoTable     -> DataLabel+    LocalInfoTable -> DataLabel+    Closure       -> GcPtrLabel+    ConInfoTable  -> DataLabel+    ClosureTable  -> DataLabel+    RednCounts    -> DataLabel+    Bytes         -> DataLabel+    _             -> CodeLabel+++-- -----------------------------------------------------------------------------+-- Does a CLabel need dynamic linkage?++-- When referring to data in code, we need to know whether+-- that data resides in a DLL or not. [Win32 only.]+-- @labelDynamic@ returns @True@ if the label is located+-- in a DLL, be it a data reference or not.++labelDynamic :: DynFlags -> Module -> CLabel -> Bool+labelDynamic dflags this_mod lbl =+  case lbl of+   -- is the RTS in a DLL or not?+   RtsLabel _           -> (WayDyn `elem` ways dflags) && (this_pkg /= rtsUnitId)++   IdLabel n _ _        -> isDllName dflags this_mod n++   -- When compiling in the "dyn" way, each package is to be linked into+   -- its own shared library.+   CmmLabel pkg _ _+    | os == OSMinGW32 ->+       (WayDyn `elem` ways dflags) && (this_pkg /= pkg)+    | otherwise ->+       True++   ForeignLabel _ _ source _  ->+       if os == OSMinGW32+       then case source of+            -- Foreign label is in some un-named foreign package (or DLL).+            ForeignLabelInExternalPackage -> True++            -- Foreign label is linked into the same package as the+            -- source file currently being compiled.+            ForeignLabelInThisPackage -> False++            -- Foreign label is in some named package.+            -- When compiling in the "dyn" way, each package is to be+            -- linked into its own DLL.+            ForeignLabelInPackage pkgId ->+                (WayDyn `elem` ways dflags) && (this_pkg /= pkgId)++       else -- On Mac OS X and on ELF platforms, false positives are OK,+            -- so we claim that all foreign imports come from dynamic+            -- libraries+            True++   PlainModuleInitLabel m -> (WayDyn `elem` ways dflags) && this_pkg /= (moduleUnitId m)++   HpcTicksLabel m        -> (WayDyn `elem` ways dflags) && this_mod /= m++   -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves.+   _                 -> False+  where+    os = platformOS (targetPlatform dflags)+    this_pkg = moduleUnitId this_mod+++-----------------------------------------------------------------------------+-- Printing out CLabels.++{-+Convention:++      <name>_<type>++where <name> is <Module>_<name> for external names and <unique> for+internal names. <type> is one of the following:++         info                   Info table+         srt                    Static reference table+         srtd                   Static reference table descriptor+         entry                  Entry code (function, closure)+         slow                   Slow entry code (if any)+         ret                    Direct return address+         vtbl                   Vector table+         <n>_alt                Case alternative (tag n)+         dflt                   Default case alternative+         btm                    Large bitmap vector+         closure                Static closure+         con_entry              Dynamic Constructor entry code+         con_info               Dynamic Constructor info table+         static_entry           Static Constructor entry code+         static_info            Static Constructor info table+         sel_info               Selector info table+         sel_entry              Selector entry code+         cc                     Cost centre+         ccs                    Cost centre stack++Many of these distinctions are only for documentation reasons.  For+example, _ret is only distinguished from _entry to make it easy to+tell whether a code fragment is a return point or a closure/function+entry.++Note [Closure and info labels]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For a function 'foo, we have:+   foo_info    : Points to the info table describing foo's closure+                 (and entry code for foo with tables next to code)+   foo_closure : Static (no-free-var) closure only:+                 points to the statically-allocated closure++For a data constructor (such as Just or Nothing), we have:+    Just_con_info: Info table for the data constructor itself+                   the first word of a heap-allocated Just+    Just_info:     Info table for the *worker function*, an+                   ordinary Haskell function of arity 1 that+                   allocates a (Just x) box:+                      Just = \x -> Just x+    Just_closure:  The closure for this worker++    Nothing_closure: a statically allocated closure for Nothing+    Nothing_static_info: info table for Nothing_closure++All these must be exported symbol, EXCEPT Just_info.  We don't need to+export this because in other modules we either have+       * A reference to 'Just'; use Just_closure+       * A saturated call 'Just x'; allocate using Just_con_info+Not exporting these Just_info labels reduces the number of symbols+somewhat.++Note [Bytes label]+~~~~~~~~~~~~~~~~~~+For a top-level string literal 'foo', we have just one symbol 'foo_bytes', which+points to a static data block containing the content of the literal.+-}++instance Outputable CLabel where+  ppr c = sdocWithPlatform $ \platform -> pprCLabel platform c++pprCLabel :: Platform -> CLabel -> SDoc++pprCLabel platform (AsmTempLabel u)+ | cGhcWithNativeCodeGen == "YES"+  =  getPprStyle $ \ sty ->+     if asmStyle sty then+        ptext (asmTempLabelPrefix platform) <> pprUniqueAlways u+     else+        char '_' <> pprUniqueAlways u++pprCLabel platform (AsmTempDerivedLabel l suf)+ | cGhcWithNativeCodeGen == "YES"+   = ptext (asmTempLabelPrefix platform)+     <> case l of AsmTempLabel u -> pprUniqueAlways u+                  _other         -> pprCLabel platform l+     <> ftext suf++pprCLabel platform (DynamicLinkerLabel info lbl)+ | cGhcWithNativeCodeGen == "YES"+   = pprDynamicLinkerAsmLabel platform info lbl++pprCLabel _ PicBaseLabel+ | cGhcWithNativeCodeGen == "YES"+   = text "1b"++pprCLabel platform (DeadStripPreventer lbl)+ | cGhcWithNativeCodeGen == "YES"+   = pprCLabel platform lbl <> text "_dsp"++pprCLabel _ (StringLitLabel u)+ | cGhcWithNativeCodeGen == "YES"+  = pprUniqueAlways u <> ptext (sLit "_str")++pprCLabel platform lbl+   = getPprStyle $ \ sty ->+     if cGhcWithNativeCodeGen == "YES" && asmStyle sty+     then maybe_underscore (pprAsmCLbl platform lbl)+     else pprCLbl lbl++maybe_underscore :: SDoc -> SDoc+maybe_underscore doc+  | underscorePrefix = pp_cSEP <> doc+  | otherwise        = doc++pprAsmCLbl :: Platform -> CLabel -> SDoc+pprAsmCLbl platform (ForeignLabel fs (Just sz) _ _)+ | platformOS platform == OSMinGW32+    -- In asm mode, we need to put the suffix on a stdcall ForeignLabel.+    -- (The C compiler does this itself).+    = ftext fs <> char '@' <> int sz+pprAsmCLbl _ lbl+   = pprCLbl lbl++pprCLbl :: CLabel -> SDoc+pprCLbl (StringLitLabel u)+  = pprUniqueAlways u <> text "_str"++pprCLbl (CaseLabel u CaseReturnPt)+  = hcat [pprUniqueAlways u, text "_ret"]+pprCLbl (CaseLabel u CaseReturnInfo)+  = hcat [pprUniqueAlways u, text "_info"]+pprCLbl (CaseLabel u (CaseAlt tag))+  = hcat [pprUniqueAlways u, pp_cSEP, int tag, text "_alt"]+pprCLbl (CaseLabel u CaseDefault)+  = hcat [pprUniqueAlways u, text "_dflt"]++pprCLbl (SRTLabel u)+  = pprUniqueAlways u <> pp_cSEP <> text "srt"++pprCLbl (LargeSRTLabel u)  = pprUniqueAlways u <> pp_cSEP <> text "srtd"+pprCLbl (LargeBitmapLabel u)  = text "b" <> pprUniqueAlways u <> pp_cSEP <> text "btm"+-- Some bitsmaps for tuple constructors have a numeric tag (e.g. '7')+-- until that gets resolved we'll just force them to start+-- with a letter so the label will be legal assmbly code.+++pprCLbl (CmmLabel _ str CmmCode)        = ftext str+pprCLbl (CmmLabel _ str CmmData)        = ftext str+pprCLbl (CmmLabel _ str CmmPrimCall)    = ftext str++pprCLbl (RtsLabel (RtsApFast str))   = ftext str <> text "_fast"++pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset))+  = sdocWithDynFlags $ \dflags ->+    ASSERT(offset >= 0 && offset <= mAX_SPEC_SELECTEE_SIZE dflags)+    hcat [text "stg_sel_", text (show offset),+          ptext (if upd_reqd+                 then (sLit "_upd_info")+                 else (sLit "_noupd_info"))+        ]++pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))+  = sdocWithDynFlags $ \dflags ->+    ASSERT(offset >= 0 && offset <= mAX_SPEC_SELECTEE_SIZE dflags)+    hcat [text "stg_sel_", text (show offset),+                ptext (if upd_reqd+                        then (sLit "_upd_entry")+                        else (sLit "_noupd_entry"))+        ]++pprCLbl (RtsLabel (RtsApInfoTable upd_reqd arity))+  = sdocWithDynFlags $ \dflags ->+    ASSERT(arity > 0 && arity <= mAX_SPEC_AP_SIZE dflags)+    hcat [text "stg_ap_", text (show arity),+                ptext (if upd_reqd+                        then (sLit "_upd_info")+                        else (sLit "_noupd_info"))+        ]++pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))+  = sdocWithDynFlags $ \dflags ->+    ASSERT(arity > 0 && arity <= mAX_SPEC_AP_SIZE dflags)+    hcat [text "stg_ap_", text (show arity),+                ptext (if upd_reqd+                        then (sLit "_upd_entry")+                        else (sLit "_noupd_entry"))+        ]++pprCLbl (CmmLabel _ fs CmmInfo)+  = ftext fs <> text "_info"++pprCLbl (CmmLabel _ fs CmmEntry)+  = ftext fs <> text "_entry"++pprCLbl (CmmLabel _ fs CmmRetInfo)+  = ftext fs <> text "_info"++pprCLbl (CmmLabel _ fs CmmRet)+  = ftext fs <> text "_ret"++pprCLbl (CmmLabel _ fs CmmClosure)+  = ftext fs <> text "_closure"++pprCLbl (RtsLabel (RtsPrimOp primop))+  = text "stg_" <> ppr primop++pprCLbl (RtsLabel (RtsSlowFastTickyCtr pat))+  = text "SLOW_CALL_fast_" <> text pat <> ptext (sLit "_ctr")++pprCLbl (ForeignLabel str _ _ _)+  = ftext str++pprCLbl (IdLabel name _cafs flavor) = ppr name <> ppIdFlavor flavor++pprCLbl (CC_Label cc)           = ppr cc+pprCLbl (CCS_Label ccs)         = ppr ccs++pprCLbl (PlainModuleInitLabel mod)+   = text "__stginit_" <> ppr mod++pprCLbl (HpcTicksLabel mod)+  = text "_hpc_tickboxes_"  <> ppr mod <> ptext (sLit "_hpc")++pprCLbl (AsmTempLabel {})       = panic "pprCLbl AsmTempLabel"+pprCLbl (AsmTempDerivedLabel {})= panic "pprCLbl AsmTempDerivedLabel"+pprCLbl (DynamicLinkerLabel {}) = panic "pprCLbl DynamicLinkerLabel"+pprCLbl (PicBaseLabel {})       = panic "pprCLbl PicBaseLabel"+pprCLbl (DeadStripPreventer {}) = panic "pprCLbl DeadStripPreventer"++ppIdFlavor :: IdLabelInfo -> SDoc+ppIdFlavor x = pp_cSEP <>+               (case x of+                       Closure          -> text "closure"+                       SRT              -> text "srt"+                       InfoTable        -> text "info"+                       LocalInfoTable   -> text "info"+                       Entry            -> text "entry"+                       LocalEntry       -> text "entry"+                       Slow             -> text "slow"+                       RednCounts       -> text "ct"+                       ConEntry         -> text "con_entry"+                       ConInfoTable     -> text "con_info"+                       ClosureTable     -> text "closure_tbl"+                       Bytes            -> text "bytes"+                      )+++pp_cSEP :: SDoc+pp_cSEP = char '_'+++instance Outputable ForeignLabelSource where+ ppr fs+  = case fs of+        ForeignLabelInPackage pkgId     -> parens $ text "package: " <> ppr pkgId+        ForeignLabelInThisPackage       -> parens $ text "this package"+        ForeignLabelInExternalPackage   -> parens $ text "external package"++-- -----------------------------------------------------------------------------+-- Machine-dependent knowledge about labels.++underscorePrefix :: Bool   -- leading underscore on assembler labels?+underscorePrefix = (cLeadingUnderscore == "YES")++asmTempLabelPrefix :: Platform -> LitString  -- for formatting labels+asmTempLabelPrefix platform = case platformOS platform of+    OSDarwin -> sLit "L"+    OSAIX    -> sLit "__L" -- follow IBM XL C's convention+    _        -> sLit ".L"++pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> CLabel -> SDoc+pprDynamicLinkerAsmLabel platform dllInfo lbl+ = if platformOS platform == OSDarwin+   then if platformArch platform == ArchX86_64+        then case dllInfo of+             CodeStub        -> char 'L' <> ppr lbl <> text "$stub"+             SymbolPtr       -> char 'L' <> ppr lbl <> text "$non_lazy_ptr"+             GotSymbolPtr    -> ppr lbl <> text "@GOTPCREL"+             GotSymbolOffset -> ppr lbl+        else case dllInfo of+             CodeStub  -> char 'L' <> ppr lbl <> text "$stub"+             SymbolPtr -> char 'L' <> ppr lbl <> text "$non_lazy_ptr"+             _         -> panic "pprDynamicLinkerAsmLabel"++   else if platformOS platform == OSAIX+        then case dllInfo of+             SymbolPtr -> text "LC.." <> ppr lbl -- GCC's naming convention+             _         -> panic "pprDynamicLinkerAsmLabel"++   else if osElfTarget (platformOS platform)+        then if platformArch platform == ArchPPC+             then case dllInfo of+                       CodeStub  -> -- See Note [.LCTOC1 in PPC PIC code]+                                    ppr lbl <> text "+32768@plt"+                       SymbolPtr -> text ".LC_" <> ppr lbl+                       _         -> panic "pprDynamicLinkerAsmLabel"+             else if platformArch platform == ArchX86_64+                  then case dllInfo of+                       CodeStub        -> ppr lbl <> text "@plt"+                       GotSymbolPtr    -> ppr lbl <> text "@gotpcrel"+                       GotSymbolOffset -> ppr lbl+                       SymbolPtr       -> text ".LC_" <> ppr lbl+             else if platformArch platform == ArchPPC_64 ELF_V1+                  || platformArch platform == ArchPPC_64 ELF_V2+                  then case dllInfo of+                       GotSymbolPtr    -> text ".LC_"  <> ppr lbl+                                               <> text "@toc"+                       GotSymbolOffset -> ppr lbl+                       SymbolPtr       -> text ".LC_" <> ppr lbl+                       _               -> panic "pprDynamicLinkerAsmLabel"+        else case dllInfo of+             CodeStub        -> ppr lbl <> text "@plt"+             SymbolPtr       -> text ".LC_" <> ppr lbl+             GotSymbolPtr    -> ppr lbl <> text "@got"+             GotSymbolOffset -> ppr lbl <> text "@gotoff"+   else if platformOS platform == OSMinGW32+        then case dllInfo of+             SymbolPtr -> text "__imp_" <> ppr lbl+             _         -> panic "pprDynamicLinkerAsmLabel"+   else panic "pprDynamicLinkerAsmLabel"+
+ cmm/Cmm.hs view
@@ -0,0 +1,218 @@+-- Cmm representations using Hoopl's Graph CmmNode e x.+{-# LANGUAGE CPP, GADTs #-}++module Cmm (+     -- * Cmm top-level datatypes+     CmmProgram, CmmGroup, GenCmmGroup,+     CmmDecl, GenCmmDecl(..),+     CmmGraph, GenCmmGraph(..),+     CmmBlock,+     RawCmmDecl, RawCmmGroup,+     Section(..), SectionType(..), CmmStatics(..), CmmStatic(..),++     -- ** Blocks containing lists+     GenBasicBlock(..), blockId,+     ListGraph(..), pprBBlock,++     -- * Cmm graphs+     CmmReplGraph, GenCmmReplGraph, CmmFwdRewrite, CmmBwdRewrite,++     -- * Info Tables+     CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..), topInfoTable,+     ClosureTypeInfo(..),+     C_SRT(..), needsSRT,+     ProfilingInfo(..), ConstrDescription,++     -- * Statements, expressions and types+     module CmmNode,+     module CmmExpr,+  ) where++import CLabel+import BlockId+import CmmNode+import SMRep+import CmmExpr+import UniqSupply+import Compiler.Hoopl+import Outputable++import Data.Word        ( Word8 )++#include "HsVersions.h"++-----------------------------------------------------------------------------+--  Cmm, GenCmm+-----------------------------------------------------------------------------++-- A CmmProgram is a list of CmmGroups+-- A CmmGroup is a list of top-level declarations++-- When object-splitting is on, each group is compiled into a separate+-- .o file. So typically we put closely related stuff in a CmmGroup.+-- Section-splitting follows suit and makes one .text subsection for each+-- CmmGroup.++type CmmProgram = [CmmGroup]++type GenCmmGroup d h g = [GenCmmDecl d h g]+type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph+type RawCmmGroup = GenCmmGroup CmmStatics (LabelMap CmmStatics) CmmGraph++-----------------------------------------------------------------------------+--  CmmDecl, GenCmmDecl+-----------------------------------------------------------------------------++-- GenCmmDecl is abstracted over+--   d, the type of static data elements in CmmData+--   h, the static info preceding the code of a CmmProc+--   g, the control-flow graph of a CmmProc+--+-- We expect there to be two main instances of this type:+--   (a) C--, i.e. populated with various C-- constructs+--   (b) Native code, populated with data/instructions++-- | A top-level chunk, abstracted over the type of the contents of+-- the basic blocks (Cmm or instructions are the likely instantiations).+data GenCmmDecl d h g+  = CmmProc     -- A procedure+     h                 -- Extra header such as the info table+     CLabel            -- Entry label+     [GlobalReg]       -- Registers live on entry. Note that the set of live+                       -- registers will be correct in generated C-- code, but+                       -- not in hand-written C-- code. However,+                       -- splitAtProcPoints calculates correct liveness+                       -- information for CmmProcs.+     g                 -- Control-flow graph for the procedure's code++  | CmmData     -- Static data+        Section+        d++type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph++type RawCmmDecl+   = GenCmmDecl+        CmmStatics+        (LabelMap CmmStatics)+        CmmGraph++-----------------------------------------------------------------------------+--     Graphs+-----------------------------------------------------------------------------++type CmmGraph = GenCmmGraph CmmNode+data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }+type CmmBlock = Block CmmNode C C++type CmmReplGraph e x = GenCmmReplGraph CmmNode e x+type GenCmmReplGraph n e x = UniqSM (Maybe (Graph n e x))+type CmmFwdRewrite f = FwdRewrite UniqSM CmmNode f+type CmmBwdRewrite f = BwdRewrite UniqSM CmmNode f++-----------------------------------------------------------------------------+--     Info Tables+-----------------------------------------------------------------------------++data CmmTopInfo   = TopInfo { info_tbls  :: LabelMap CmmInfoTable+                            , stack_info :: CmmStackInfo }++topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable+topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos)+topInfoTable _                     = Nothing++data CmmStackInfo+   = StackInfo {+       arg_space :: ByteOff,+               -- number of bytes of arguments on the stack on entry to the+               -- the proc.  This is filled in by StgCmm.codeGen, and used+               -- by the stack allocator later.+       updfr_space :: Maybe ByteOff,+               -- XXX: this never contains anything useful, but it should.+               -- See comment in CmmLayoutStack.+       do_layout :: Bool+               -- Do automatic stack layout for this proc.  This is+               -- True for all code generated by the code generator,+               -- but is occasionally False for hand-written Cmm where+               -- we want to do the stack manipulation manually.+  }++-- | Info table as a haskell data type+data CmmInfoTable+  = CmmInfoTable {+      cit_lbl  :: CLabel, -- Info table label+      cit_rep  :: SMRep,+      cit_prof :: ProfilingInfo,+      cit_srt  :: C_SRT+    }++data ProfilingInfo+  = NoProfilingInfo+  | ProfilingInfo [Word8] [Word8] -- closure_type, closure_desc++-- C_SRT is what StgSyn.SRT gets translated to...+-- we add a label for the table, and expect only the 'offset/length' form++data C_SRT = NoC_SRT+           | C_SRT !CLabel !WordOff !StgHalfWord {-bitmap or escape-}+           deriving (Eq)++needsSRT :: C_SRT -> Bool+needsSRT NoC_SRT       = False+needsSRT (C_SRT _ _ _) = True++-----------------------------------------------------------------------------+--              Static Data+-----------------------------------------------------------------------------++data SectionType+  = Text+  | Data+  | ReadOnlyData+  | RelocatableReadOnlyData+  | UninitialisedData+  | ReadOnlyData16      -- .rodata.cst16 on x86_64, 16-byte aligned+  | CString+  | OtherSection String+  deriving (Show)++data Section = Section SectionType CLabel++data CmmStatic+  = CmmStaticLit CmmLit+        -- a literal value, size given by cmmLitRep of the literal.+  | CmmUninitialised Int+        -- uninitialised data, N bytes long+  | CmmString [Word8]+        -- string of 8-bit values only, not zero terminated.++data CmmStatics+   = Statics+       CLabel      -- Label of statics+       [CmmStatic] -- The static data itself++-- -----------------------------------------------------------------------------+-- Basic blocks consisting of lists++-- These are used by the LLVM and NCG backends, when populating Cmm+-- with lists of instructions.++data GenBasicBlock i = BasicBlock BlockId [i]++-- | The branch block id is that of the first block in+-- the branch, which is that branch's entry point+blockId :: GenBasicBlock i -> BlockId+blockId (BasicBlock blk_id _ ) = blk_id++newtype ListGraph i = ListGraph [GenBasicBlock i]++instance Outputable instr => Outputable (ListGraph instr) where+    ppr (ListGraph blocks) = vcat (map ppr blocks)++instance Outputable instr => Outputable (GenBasicBlock instr) where+    ppr = pprBBlock++pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc+pprBBlock (BasicBlock ident stmts) =+    hang (ppr ident <> colon) 4 (vcat (map ppr stmts))+
+ cmm/CmmBuildInfoTables.hs view
@@ -0,0 +1,379 @@+{-# LANGUAGE BangPatterns, CPP, GADTs #-}++module CmmBuildInfoTables+    ( CAFSet, CAFEnv, cafAnal+    , doSRTs, TopSRT, emptySRT, isEmptySRT, srtToData )+where++#include "HsVersions.h"++import Hoopl+import Digraph+import Bitmap+import CLabel+import PprCmmDecl ()+import Cmm+import CmmUtils+import CmmInfo+import Data.List+import DynFlags+import Maybes+import Outputable+import SMRep+import UniqSupply+import Util++import PprCmm()+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Control.Monad++import qualified Prelude as P+import Prelude hiding (succ)++foldSet :: (a -> b -> b) -> b -> Set a -> b+foldSet = Set.foldr++-----------------------------------------------------------------------+-- SRTs++{- EXAMPLE++f = \x. ... g ...+  where+    g = \y. ... h ... c1 ...+    h = \z. ... c2 ...++c1 & c2 are CAFs++g and h are local functions, but they have no static closures.  When+we generate code for f, we start with a CmmGroup of four CmmDecls:++   [ f_closure, f_entry, g_entry, h_entry ]++we process each CmmDecl separately in cpsTop, giving us a list of+CmmDecls. e.g. for f_entry, we might end up with++   [ f_entry, f1_ret, f2_proc ]++where f1_ret is a return point, and f2_proc is a proc-point.  We have+a CAFSet for each of these CmmDecls, let's suppose they are++   [ f_entry{g_closure}, f1_ret{g_closure}, f2_proc{} ]+   [ g_entry{h_closure, c1_closure} ]+   [ h_entry{c2_closure} ]++Now, note that we cannot use g_closure and h_closure in an SRT,+because there are no static closures corresponding to these functions.+So we have to flatten out the structure, replacing g_closure and+h_closure with their contents:++   [ f_entry{c2_closure, c1_closure}, f1_ret{c2_closure,c1_closure}, f2_proc{} ]+   [ g_entry{c2_closure, c1_closure} ]+   [ h_entry{c2_closure} ]++This is what flattenCAFSets is doing.++-}++-----------------------------------------------------------------------+-- Finding the CAFs used by a procedure++type CAFSet = Set CLabel+type CAFEnv = LabelMap CAFSet++cafLattice :: DataflowLattice CAFSet+cafLattice = DataflowLattice Set.empty add+  where+    add (OldFact old) (NewFact new) =+        let !new' = old `Set.union` new+        in changedIf (Set.size new' > Set.size old) new'++cafTransfers :: TransferFun CAFSet+cafTransfers (BlockCC eNode middle xNode) fBase =+    let joined = cafsInNode xNode $! joinOutFacts cafLattice xNode fBase+        !result = foldNodesBwdOO cafsInNode middle joined+    in mapSingleton (entryLabel eNode) result++cafsInNode :: CmmNode e x -> CAFSet -> CAFSet+cafsInNode node set = foldExpDeep addCaf node set+  where+    addCaf expr !set =+        case expr of+            CmmLit (CmmLabel c) -> add c set+            CmmLit (CmmLabelOff c _) -> add c set+            CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $! add c2 set+            _ -> set+    add l s | hasCAF l  = Set.insert (toClosureLbl l) s+            | otherwise = s++-- | An analysis to find live CAFs.+cafAnal :: CmmGraph -> CAFEnv+cafAnal cmmGraph = analyzeCmmBwd cafLattice cafTransfers cmmGraph mapEmpty++-----------------------------------------------------------------------+-- Building the SRTs++-- Description of the SRT for a given module.+-- Note that this SRT may grow as we greedily add new CAFs to it.+data TopSRT = TopSRT { lbl      :: CLabel+                     , next_elt :: Int -- the next entry in the table+                     , rev_elts :: [CLabel]+                     , elt_map  :: Map CLabel Int }+                        -- map: CLabel -> its last entry in the table+instance Outputable TopSRT where+  ppr (TopSRT lbl next elts eltmap) =+    text "TopSRT:" <+> ppr lbl+                   <+> ppr next+                   <+> ppr elts+                   <+> ppr eltmap++emptySRT :: MonadUnique m => m TopSRT+emptySRT =+  do top_lbl <- getUniqueM >>= \ u -> return $ mkTopSRTLabel u+     return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = Map.empty }++isEmptySRT :: TopSRT -> Bool+isEmptySRT srt = null (rev_elts srt)++cafMember :: TopSRT -> CLabel -> Bool+cafMember srt lbl = Map.member lbl (elt_map srt)++cafOffset :: TopSRT -> CLabel -> Maybe Int+cafOffset srt lbl = Map.lookup lbl (elt_map srt)++addCAF :: CLabel -> TopSRT -> TopSRT+addCAF caf srt =+  srt { next_elt = last + 1+      , rev_elts = caf : rev_elts srt+      , elt_map  = Map.insert caf last (elt_map srt) }+    where last  = next_elt srt++srtToData :: TopSRT -> CmmGroup+srtToData srt = [CmmData sec (Statics (lbl srt) tbl)]+    where tbl = map (CmmStaticLit . CmmLabel) (reverse (rev_elts srt))+          sec = Section RelocatableReadOnlyData (lbl srt)++-- Once we have found the CAFs, we need to do two things:+-- 1. Build a table of all the CAFs used in the procedure.+-- 2. Compute the C_SRT describing the subset of CAFs live at each procpoint.+--+-- When building the local view of the SRT, we first make sure that all the CAFs are+-- in the SRT. Then, if the number of CAFs is small enough to fit in a bitmap,+-- we make sure they're all close enough to the bottom of the table that the+-- bitmap will be able to cover all of them.+buildSRT :: DynFlags -> TopSRT -> CAFSet -> UniqSM (TopSRT, Maybe CmmDecl, C_SRT)+buildSRT dflags topSRT cafs =+  do let+         -- For each label referring to a function f without a static closure,+         -- replace it with the CAFs that are reachable from f.+         sub_srt topSRT localCafs =+           let cafs = Set.elems localCafs+               mkSRT topSRT =+                 do localSRTs <- procpointSRT dflags (lbl topSRT) (elt_map topSRT) cafs+                    return (topSRT, localSRTs)+           in if length cafs > maxBmpSize dflags then+                mkSRT (foldl add_if_missing topSRT cafs)+              else -- make sure all the cafs are near the bottom of the srt+                mkSRT (add_if_too_far topSRT cafs)+         add_if_missing srt caf =+           if cafMember srt caf then srt else addCAF caf srt+         -- If a CAF is more than maxBmpSize entries from the young end of the+         -- SRT, then we add it to the SRT again.+         -- (Note: Not in the SRT => infinitely far.)+         add_if_too_far srt@(TopSRT {elt_map = m}) cafs =+           add srt (sortBy farthestFst cafs)+             where+               farthestFst x y = case (Map.lookup x m, Map.lookup y m) of+                                   (Nothing, Nothing) -> EQ+                                   (Nothing, Just _)  -> LT+                                   (Just _,  Nothing) -> GT+                                   (Just d, Just d')  -> compare d' d+               add srt [] = srt+               add srt@(TopSRT {next_elt = next}) (caf : rst) =+                 case cafOffset srt caf of+                   Just ix -> if next - ix > maxBmpSize dflags then+                                add (addCAF caf srt) rst+                              else srt+                   Nothing -> add (addCAF caf srt) rst+     (topSRT, subSRTs) <- sub_srt topSRT cafs+     let (sub_tbls, blockSRTs) = subSRTs+     return (topSRT, sub_tbls, blockSRTs)++-- Construct an SRT bitmap.+-- Adapted from simpleStg/SRT.hs, which expects Id's.+procpointSRT :: DynFlags -> CLabel -> Map CLabel Int -> [CLabel] ->+                UniqSM (Maybe CmmDecl, C_SRT)+procpointSRT _ _ _ [] =+ return (Nothing, NoC_SRT)+procpointSRT dflags top_srt top_table entries =+ do (top, srt) <- bitmap `seq` to_SRT dflags top_srt offset len bitmap+    return (top, srt)+  where+    ints = map (expectJust "constructSRT" . flip Map.lookup top_table) entries+    sorted_ints = sort ints+    offset = head sorted_ints+    bitmap_entries = map (subtract offset) sorted_ints+    len = P.last bitmap_entries + 1+    bitmap = intsToBitmap dflags len bitmap_entries++maxBmpSize :: DynFlags -> Int+maxBmpSize dflags = widthInBits (wordWidth dflags) `div` 2++-- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT.+to_SRT :: DynFlags -> CLabel -> Int -> Int -> Bitmap -> UniqSM (Maybe CmmDecl, C_SRT)+to_SRT dflags top_srt off len bmp+  | len > maxBmpSize dflags || bmp == [toStgWord dflags (fromStgHalfWord (srtEscape dflags))]+  = do id <- getUniqueM+       let srt_desc_lbl = mkLargeSRTLabel id+           section = Section RelocatableReadOnlyData srt_desc_lbl+           tbl = CmmData section $+                   Statics srt_desc_lbl $ map CmmStaticLit+                     ( cmmLabelOffW dflags top_srt off+                     : mkWordCLit dflags (fromIntegral len)+                     : map (mkStgWordCLit dflags) bmp)+       return (Just tbl, C_SRT srt_desc_lbl 0 (srtEscape dflags))+  | otherwise+  = return (Nothing, C_SRT top_srt off (toStgHalfWord dflags (fromStgWord (head bmp))))+        -- The fromIntegral converts to StgHalfWord++-- Gather CAF info for a procedure, but only if the procedure+-- doesn't have a static closure.+-- (If it has a static closure, it will already have an SRT to+--  keep its CAFs live.)+-- Any procedure referring to a non-static CAF c must keep live+-- any CAF that is reachable from c.+localCAFInfo :: CAFEnv -> CmmDecl -> (CAFSet, Maybe CLabel)+localCAFInfo _      (CmmData _ _) = (Set.empty, Nothing)+localCAFInfo cafEnv proc@(CmmProc _ top_l _ (CmmGraph {g_entry=entry})) =+  case topInfoTable proc of+    Just (CmmInfoTable { cit_rep = rep })+      | not (isStaticRep rep) && not (isStackRep rep)+      -> (cafs, Just (toClosureLbl top_l))+    _other -> (cafs, Nothing)+  where+    cafs = expectJust "maybeBindCAFs" $ mapLookup entry cafEnv++-- Once we have the local CAF sets for some (possibly) mutually+-- recursive functions, we can create an environment mapping+-- each function to its set of CAFs. Note that a CAF may+-- be a reference to a function. If that function f does not have+-- a static closure, then we need to refer specifically+-- to the set of CAFs used by f. Of course, the set of CAFs+-- used by f must be included in the local CAF sets that are input to+-- this function. To minimize lookup time later, we return+-- the environment with every reference to f replaced by its set of CAFs.+-- To do this replacement efficiently, we gather strongly connected+-- components, then we sort the components in topological order.+mkTopCAFInfo :: [(CAFSet, Maybe CLabel)] -> Map CLabel CAFSet+mkTopCAFInfo localCAFs = foldl addToTop Map.empty g+  where+        addToTop env (AcyclicSCC (l, cafset)) =+          Map.insert l (flatten env cafset) env+        addToTop env (CyclicSCC nodes) =+          let (lbls, cafsets) = unzip nodes+              cafset  = foldr Set.delete (foldl Set.union Set.empty cafsets) lbls+          in foldl (\env l -> Map.insert l (flatten env cafset) env) env lbls++        g = stronglyConnCompFromEdgedVerticesOrd+              [ ((l,cafs), l, Set.elems cafs) | (cafs, Just l) <- localCAFs ]++flatten :: Map CLabel CAFSet -> CAFSet -> CAFSet+flatten env cafset = foldSet (lookup env) Set.empty cafset+  where+      lookup env caf cafset' =+          case Map.lookup caf env of+             Just cafs -> foldSet Set.insert cafset' cafs+             Nothing   -> Set.insert caf cafset'++bundle :: Map CLabel CAFSet+       -> (CAFEnv, CmmDecl)+       -> (CAFSet, Maybe CLabel)+       -> (LabelMap CAFSet, CmmDecl)+bundle flatmap (env, decl@(CmmProc infos _lbl _ g)) (closure_cafs, mb_lbl)+  = ( mapMapWithKey get_cafs (info_tbls infos), decl )+ where+  entry = g_entry g++  entry_cafs+    | Just l <- mb_lbl = expectJust "bundle" $ Map.lookup l flatmap+    | otherwise        = flatten flatmap closure_cafs++  get_cafs l _+    | l == entry = entry_cafs+    | Just info <- mapLookup l env = flatten flatmap info+    | otherwise  = Set.empty+    -- the label might not be in the env if the code corresponding to+    -- this info table was optimised away (perhaps because it was+    -- unreachable).  In this case it doesn't matter what SRT we+    -- infer, since the info table will not appear in the generated+    -- code.  See #9329.++bundle _flatmap (_, decl) _+  = ( mapEmpty, decl )+++flattenCAFSets :: [(CAFEnv, [CmmDecl])] -> [(LabelMap CAFSet, CmmDecl)]+flattenCAFSets cpsdecls = zipWith (bundle flatmap) zipped localCAFs+   where+     zipped    = [ (env,decl) | (env,decls) <- cpsdecls, decl <- decls ]+     localCAFs = unzipWith localCAFInfo zipped+     flatmap   = mkTopCAFInfo localCAFs -- transitive closure of localCAFs++doSRTs :: DynFlags+       -> TopSRT+       -> [(CAFEnv, [CmmDecl])]+       -> IO (TopSRT, [CmmDecl])++doSRTs dflags topSRT tops+  = do+     let caf_decls = flattenCAFSets tops+     us <- mkSplitUniqSupply 'u'+     let (topSRT', gs') = initUs_ us $ foldM setSRT (topSRT, []) caf_decls+     return (topSRT', reverse gs' {- Note [reverse gs] -})+  where+    setSRT (topSRT, rst) (caf_map, decl@(CmmProc{})) = do+       (topSRT, srt_tables, srt_env) <- buildSRTs dflags topSRT caf_map+       let decl' = updInfoSRTs srt_env decl+       return (topSRT, decl': srt_tables ++ rst)+    setSRT (topSRT, rst) (_, decl) =+      return (topSRT, decl : rst)++buildSRTs :: DynFlags -> TopSRT -> LabelMap CAFSet+          -> UniqSM (TopSRT, [CmmDecl], LabelMap C_SRT)+buildSRTs dflags top_srt caf_map+  = foldM doOne (top_srt, [], mapEmpty) (mapToList caf_map)+  where+  doOne (top_srt, decls, srt_env) (l, cafs)+    = do (top_srt, mb_decl, srt) <- buildSRT dflags top_srt cafs+         return ( top_srt, maybeToList mb_decl ++ decls+                , mapInsert l srt srt_env )++{-+- In each CmmDecl there is a mapping from BlockId -> CmmInfoTable+- The one corresponding to g_entry is the closure info table, the+  rest are continuations.+- Each one needs an SRT.+- We get the CAFSet for each one from the CAFEnv+- flatten gives us+    [(LabelMap CAFSet, CmmDecl)]+-+-}+++{- Note [reverse gs]++   It is important to keep the code blocks in the same order,+   otherwise binary sizes get slightly bigger.  I'm not completely+   sure why this is, perhaps the assembler generates bigger jump+   instructions for forward refs.  --SDM+-}++updInfoSRTs :: LabelMap C_SRT -> CmmDecl -> CmmDecl+updInfoSRTs srt_env (CmmProc top_info top_l live g) =+  CmmProc (top_info {info_tbls = mapMapWithKey updInfoTbl (info_tbls top_info)}) top_l live g+  where updInfoTbl l info_tbl+             = info_tbl { cit_srt = expectJust "updInfo" $ mapLookup l srt_env }+updInfoSRTs _ t = t
+ cmm/CmmCallConv.hs view
@@ -0,0 +1,220 @@+{-# LANGUAGE CPP #-}++module CmmCallConv (+  ParamLocation(..),+  assignArgumentsPos,+  assignStack,+  realArgRegsCover+) where++#include "HsVersions.h"++import CmmExpr+import SMRep+import Cmm (Convention(..))+import PprCmm ()++import DynFlags+import Platform+import Outputable++-- Calculate the 'GlobalReg' or stack locations for function call+-- parameters as used by the Cmm calling convention.++data ParamLocation+  = RegisterParam GlobalReg+  | StackParam ByteOff++instance Outputable ParamLocation where+  ppr (RegisterParam g) = ppr g+  ppr (StackParam p)    = ppr p++-- |+-- Given a list of arguments, and a function that tells their types,+-- return a list showing where each argument is passed+--+assignArgumentsPos :: DynFlags+                   -> ByteOff           -- stack offset to start with+                   -> Convention+                   -> (a -> CmmType)    -- how to get a type from an arg+                   -> [a]               -- args+                   -> (+                        ByteOff              -- bytes of stack args+                      , [(a, ParamLocation)] -- args and locations+                      )++assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)+    where+      regs = case (reps, conv) of+               (_,   NativeNodeCall)   -> getRegsWithNode dflags+               (_,   NativeDirectCall) -> getRegsWithoutNode dflags+               ([_], NativeReturn)     -> allRegs dflags+               (_,   NativeReturn)     -> getRegsWithNode dflags+               -- GC calling convention *must* put values in registers+               (_,   GC)               -> allRegs dflags+               (_,   Slow)             -> nodeOnly+      -- The calling conventions first assign arguments to registers,+      -- then switch to the stack when we first run out of registers+      -- (even if there are still available registers for args of a+      -- different type).  When returning an unboxed tuple, we also+      -- separate the stack arguments by pointerhood.+      (reg_assts, stk_args)  = assign_regs [] reps regs+      (stk_off,   stk_assts) = assignStack dflags off arg_ty stk_args+      assignments = reg_assts ++ stk_assts++      assign_regs assts []     _    = (assts, [])+      assign_regs assts (r:rs) regs | isVecType ty   = vec+                                    | isFloatType ty = float+                                    | otherwise      = int+        where vec = case (w, regs) of+                      (W128, (vs, fs, ds, ls, s:ss))+                          | passVectorInReg W128 dflags -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss))+                      (W256, (vs, fs, ds, ls, s:ss))+                          | passVectorInReg W256 dflags -> k (RegisterParam (YmmReg s), (vs, fs, ds, ls, ss))+                      (W512, (vs, fs, ds, ls, s:ss))+                          | passVectorInReg W512 dflags -> k (RegisterParam (ZmmReg s), (vs, fs, ds, ls, ss))+                      _ -> (assts, (r:rs))+              float = case (w, regs) of+                        (W32, (vs, fs, ds, ls, s:ss))+                            | passFloatInXmm          -> k (RegisterParam (FloatReg s), (vs, fs, ds, ls, ss))+                        (W32, (vs, f:fs, ds, ls, ss))+                            | not passFloatInXmm      -> k (RegisterParam f, (vs, fs, ds, ls, ss))+                        (W64, (vs, fs, ds, ls, s:ss))+                            | passFloatInXmm          -> k (RegisterParam (DoubleReg s), (vs, fs, ds, ls, ss))+                        (W64, (vs, fs, d:ds, ls, ss))+                            | not passFloatInXmm      -> k (RegisterParam d, (vs, fs, ds, ls, ss))+                        (W80, _) -> panic "F80 unsupported register type"+                        _ -> (assts, (r:rs))+              int = case (w, regs) of+                      (W128, _) -> panic "W128 unsupported register type"+                      (_, (v:vs, fs, ds, ls, ss)) | widthInBits w <= widthInBits (wordWidth dflags)+                          -> k (RegisterParam (v gcp), (vs, fs, ds, ls, ss))+                      (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth dflags)+                          -> k (RegisterParam l, (vs, fs, ds, ls, ss))+                      _   -> (assts, (r:rs))+              k (asst, regs') = assign_regs ((r, asst) : assts) rs regs'+              ty = arg_ty r+              w  = typeWidth ty+              gcp | isGcPtrType ty = VGcPtr+                  | otherwise      = VNonGcPtr+              passFloatInXmm = passFloatArgsInXmm dflags++passFloatArgsInXmm :: DynFlags -> Bool+passFloatArgsInXmm dflags = case platformArch (targetPlatform dflags) of+                              ArchX86_64 -> True+                              _          -> False++-- On X86_64, we always pass 128-bit-wide vectors in registers. On 32-bit X86+-- and for all larger vector sizes on X86_64, LLVM's GHC calling convention+-- does not currently pass vectors in registers. The patch to update the GHC+-- calling convention to support passing SIMD vectors in registers is small and+-- well-contained, so it may make it into LLVM 3.4. The hidden+-- -fllvm-pass-vectors-in-regs flag will generate LLVM code that attempts to+-- pass vectors in registers, but it must only be used with a version of LLVM+-- that has an updated GHC calling convention.+passVectorInReg :: Width -> DynFlags -> Bool+passVectorInReg W128 dflags = case platformArch (targetPlatform dflags) of+                                ArchX86_64 -> True+                                _          -> gopt Opt_LlvmPassVectorsInRegisters dflags+passVectorInReg _    dflags = gopt Opt_LlvmPassVectorsInRegisters dflags++assignStack :: DynFlags -> ByteOff -> (a -> CmmType) -> [a]+            -> (+                 ByteOff              -- bytes of stack args+               , [(a, ParamLocation)] -- args and locations+               )+assignStack dflags offset arg_ty args = assign_stk offset [] (reverse args)+ where+      assign_stk offset assts [] = (offset, assts)+      assign_stk offset assts (r:rs)+        = assign_stk off' ((r, StackParam off') : assts) rs+        where w    = typeWidth (arg_ty r)+              size = (((widthInBytes w - 1) `div` word_size) + 1) * word_size+              off' = offset + size+              word_size = wORD_SIZE dflags++-----------------------------------------------------------------------------+-- Local information about the registers available++type AvailRegs = ( [VGcPtr -> GlobalReg]   -- available vanilla regs.+                 , [GlobalReg]   -- floats+                 , [GlobalReg]   -- doubles+                 , [GlobalReg]   -- longs (int64 and word64)+                 , [Int]         -- XMM (floats and doubles)+                 )++-- Vanilla registers can contain pointers, Ints, Chars.+-- Floats and doubles have separate register supplies.+--+-- We take these register supplies from the *real* registers, i.e. those+-- that are guaranteed to map to machine registers.++getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs+getRegsWithoutNode dflags =+  ( filter (\r -> r VGcPtr /= node) (realVanillaRegs dflags)+  , realFloatRegs dflags+  , realDoubleRegs dflags+  , realLongRegs dflags+  , realXmmRegNos dflags)++-- getRegsWithNode uses R1/node even if it isn't a register+getRegsWithNode dflags =+  ( if null (realVanillaRegs dflags)+    then [VanillaReg 1]+    else realVanillaRegs dflags+  , realFloatRegs dflags+  , realDoubleRegs dflags+  , realLongRegs dflags+  , realXmmRegNos dflags)++allFloatRegs, allDoubleRegs, allLongRegs :: DynFlags -> [GlobalReg]+allVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]+allXmmRegs :: DynFlags -> [Int]++allVanillaRegs dflags = map VanillaReg $ regList (mAX_Vanilla_REG dflags)+allFloatRegs   dflags = map FloatReg   $ regList (mAX_Float_REG   dflags)+allDoubleRegs  dflags = map DoubleReg  $ regList (mAX_Double_REG  dflags)+allLongRegs    dflags = map LongReg    $ regList (mAX_Long_REG    dflags)+allXmmRegs     dflags =                  regList (mAX_XMM_REG     dflags)++realFloatRegs, realDoubleRegs, realLongRegs :: DynFlags -> [GlobalReg]+realVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]+realXmmRegNos :: DynFlags -> [Int]++realVanillaRegs dflags = map VanillaReg $ regList (mAX_Real_Vanilla_REG dflags)+realFloatRegs   dflags = map FloatReg   $ regList (mAX_Real_Float_REG   dflags)+realDoubleRegs  dflags = map DoubleReg  $ regList (mAX_Real_Double_REG  dflags)+realLongRegs    dflags = map LongReg    $ regList (mAX_Real_Long_REG    dflags)++realXmmRegNos dflags+    | isSse2Enabled dflags = regList (mAX_Real_XMM_REG     dflags)+    | otherwise            = []++regList :: Int -> [Int]+regList n = [1 .. n]++allRegs :: DynFlags -> AvailRegs+allRegs dflags = (allVanillaRegs dflags,+                  allFloatRegs dflags,+                  allDoubleRegs dflags,+                  allLongRegs dflags,+                  allXmmRegs dflags)++nodeOnly :: AvailRegs+nodeOnly = ([VanillaReg 1], [], [], [], [])++-- This returns the set of global registers that *cover* the machine registers+-- used for argument passing. On platforms where registers can overlap---right+-- now just x86-64, where Float and Double registers overlap---passing this set+-- of registers is guaranteed to preserve the contents of all live registers. We+-- only use this functionality in hand-written C-- code in the RTS.+realArgRegsCover :: DynFlags -> [GlobalReg]+realArgRegsCover dflags+    | passFloatArgsInXmm dflags = map ($VGcPtr) (realVanillaRegs dflags) +++                                  realLongRegs dflags +++                                  map XmmReg (realXmmRegNos dflags)+    | otherwise                 = map ($VGcPtr) (realVanillaRegs dflags) +++                                  realFloatRegs dflags +++                                  realDoubleRegs dflags +++                                  realLongRegs dflags +++                                  map XmmReg (realXmmRegNos dflags)
+ cmm/CmmCommonBlockElim.hs view
@@ -0,0 +1,302 @@+{-# LANGUAGE GADTs, BangPatterns #-}+module CmmCommonBlockElim+  ( elimCommonBlocks+  )+where+++import BlockId+import Cmm+import CmmUtils+import CmmSwitch (eqSwitchTargetWith)+import CmmContFlowOpt+-- import PprCmm ()+import Prelude hiding (iterate, succ, unzip, zip)++import Hoopl hiding (ChangeFlag)+import Data.Bits+import Data.Maybe (mapMaybe)+import qualified Data.List as List+import Data.Word+import qualified Data.Map as M+import Outputable+import UniqFM+import UniqDFM+import qualified TrieMap as TM+import Unique+import Control.Arrow (first, second)++-- -----------------------------------------------------------------------------+-- Eliminate common blocks++-- If two blocks are identical except for the label on the first node,+-- then we can eliminate one of the blocks. To ensure that the semantics+-- of the program are preserved, we have to rewrite each predecessor of the+-- eliminated block to proceed with the block we keep.++-- The algorithm iterates over the blocks in the graph,+-- checking whether it has seen another block that is equal modulo labels.+-- If so, then it adds an entry in a map indicating that the new block+-- is made redundant by the old block.+-- Otherwise, it is added to the useful blocks.++-- To avoid comparing every block with every other block repeatedly, we group+-- them by+--   * a hash of the block, ignoring labels (explained below)+--   * the list of outgoing labels+-- The hash is invariant under relabeling, so we only ever compare within+-- the same group of blocks.+--+-- The list of outgoing labels is updated as we merge blocks (that is why they+-- are not included in the hash, which we want to calculate only once).+--+-- All in all, two blocks should never be compared if they have different+-- hashes, and at most once otherwise. Previously, we were slower, and people+-- rightfully complained: #10397++-- TODO: Use optimization fuel+elimCommonBlocks :: CmmGraph -> CmmGraph+elimCommonBlocks g = replaceLabels env $ copyTicks env g+  where+     env = iterate mapEmpty blocks_with_key+     groups = groupByInt hash_block (postorderDfs g)+     blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups]++-- Invariant: The blocks in the list are pairwise distinct+-- (so avoid comparing them again)+type DistinctBlocks = [CmmBlock]+type Key = [Label]+type Subst = LabelMap BlockId++-- The outer list groups by hash. We retain this grouping throughout.+iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst+iterate subst blocks+    | mapNull new_substs = subst+    | otherwise = iterate subst' updated_blocks+  where+    grouped_blocks :: [[(Key, [DistinctBlocks])]]+    grouped_blocks = map groupByLabel blocks++    merged_blocks :: [[(Key, DistinctBlocks)]]+    (new_substs, merged_blocks) = List.mapAccumL (List.mapAccumL go) mapEmpty grouped_blocks+      where+        go !new_subst1 (k,dbs) = (new_subst1 `mapUnion` new_subst2, (k,db))+          where+            (new_subst2, db) = mergeBlockList subst dbs++    subst' = subst `mapUnion` new_substs+    updated_blocks = map (map (first (map (lookupBid subst')))) merged_blocks++mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks)+mergeBlocks subst existing new = go new+  where+    go [] = (mapEmpty, existing)+    go (b:bs) = case List.find (eqBlockBodyWith (eqBid subst) b) existing of+        -- This block is a duplicate. Drop it, and add it to the substitution+        Just b' -> first (mapInsert (entryLabel b) (entryLabel b')) $ go bs+        -- This block is not a duplicate, keep it.+        Nothing -> second (b:) $ go bs++mergeBlockList :: Subst -> [DistinctBlocks] -> (Subst, DistinctBlocks)+mergeBlockList _ [] = pprPanic "mergeBlockList" empty+mergeBlockList subst (b:bs) = go mapEmpty b bs+  where+    go !new_subst1 b [] = (new_subst1, b)+    go !new_subst1 b1 (b2:bs) = go new_subst b bs+      where+        (new_subst2, b) =  mergeBlocks subst b1 b2+        new_subst = new_subst1 `mapUnion` new_subst2+++-- -----------------------------------------------------------------------------+-- Hashing and equality on blocks++-- Below here is mostly boilerplate: hashing blocks ignoring labels,+-- and comparing blocks modulo a label mapping.++-- To speed up comparisons, we hash each basic block modulo jump labels.+-- The hashing is a bit arbitrary (the numbers are completely arbitrary),+-- but it should be fast and good enough.++-- We want to get as many small buckets as possible, as comparing blocks is+-- expensive. So include as much as possible in the hash. Ideally everything+-- that is compared with (==) in eqBlockBodyWith.++type HashCode = Int++hash_block :: CmmBlock -> HashCode+hash_block block =+  fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))+  -- UniqFM doesn't like negative Ints+  where hash_fst _ h = h+        hash_mid m h = hash_node m + h `shiftL` 1+        hash_lst m h = hash_node m + h `shiftL` 1++        hash_node :: CmmNode O x -> Word32+        hash_node n | dont_care n = 0 -- don't care+        hash_node (CmmAssign r e) = hash_reg r + hash_e e+        hash_node (CmmStore e e') = hash_e e + hash_e e'+        hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as+        hash_node (CmmBranch _) = 23 -- NB. ignore the label+        hash_node (CmmCondBranch p _ _ _) = hash_e p+        hash_node (CmmCall e _ _ _ _ _) = hash_e e+        hash_node (CmmForeignCall t _ _ _ _ _ _) = hash_tgt t+        hash_node (CmmSwitch e _) = hash_e e+        hash_node _ = error "hash_node: unknown Cmm node!"++        hash_reg :: CmmReg -> Word32+        hash_reg   (CmmLocal localReg) = hash_unique localReg -- important for performance, see #10397+        hash_reg   (CmmGlobal _)    = 19++        hash_e :: CmmExpr -> Word32+        hash_e (CmmLit l) = hash_lit l+        hash_e (CmmLoad e _) = 67 + hash_e e+        hash_e (CmmReg r) = hash_reg r+        hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check+        hash_e (CmmRegOff r i) = hash_reg r + cvt i+        hash_e (CmmStackSlot _ _) = 13++        hash_lit :: CmmLit -> Word32+        hash_lit (CmmInt i _) = fromInteger i+        hash_lit (CmmFloat r _) = truncate r+        hash_lit (CmmVec ls) = hash_list hash_lit ls+        hash_lit (CmmLabel _) = 119 -- ugh+        hash_lit (CmmLabelOff _ i) = cvt $ 199 + i+        hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i+        hash_lit (CmmBlock _) = 191 -- ugh+        hash_lit (CmmHighStackMark) = cvt 313++        hash_tgt (ForeignTarget e _) = hash_e e+        hash_tgt (PrimTarget _) = 31 -- lots of these++        hash_list f = foldl (\z x -> f x + z) (0::Word32)++        cvt = fromInteger . toInteger++        hash_unique :: Uniquable a => a -> Word32+        hash_unique = cvt . getKey . getUnique++-- | Ignore these node types for equality+dont_care :: CmmNode O x -> Bool+dont_care CmmComment {}  = True+dont_care CmmTick {}     = True+dont_care CmmUnwind {}   = True+dont_care _other         = False++-- Utilities: equality and substitution on the graph.++-- Given a map ``subst'' from BlockID -> BlockID, we define equality.+eqBid :: LabelMap BlockId -> BlockId -> BlockId -> Bool+eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'+lookupBid :: LabelMap BlockId -> BlockId -> BlockId+lookupBid subst bid = case mapLookup bid subst of+                        Just bid  -> lookupBid subst bid+                        Nothing -> bid++-- Middle nodes and expressions can contain BlockIds, in particular in+-- CmmStackSlot and CmmBlock, so we have to use a special equality for+-- these.+--+eqMiddleWith :: (BlockId -> BlockId -> Bool)+             -> CmmNode O O -> CmmNode O O -> Bool+eqMiddleWith eqBid (CmmAssign r1 e1) (CmmAssign r2 e2)+  = r1 == r2 && eqExprWith eqBid e1 e2+eqMiddleWith eqBid (CmmStore l1 r1) (CmmStore l2 r2)+  = eqExprWith eqBid l1 l2 && eqExprWith eqBid r1 r2+eqMiddleWith eqBid (CmmUnsafeForeignCall t1 r1 a1)+                   (CmmUnsafeForeignCall t2 r2 a2)+  = t1 == t2 && r1 == r2 && and (zipWith (eqExprWith eqBid) a1 a2)+eqMiddleWith _ _ _ = False++eqExprWith :: (BlockId -> BlockId -> Bool)+           -> CmmExpr -> CmmExpr -> Bool+eqExprWith eqBid = eq+ where+  CmmLit l1          `eq` CmmLit l2          = eqLit l1 l2+  CmmLoad e1 _       `eq` CmmLoad e2 _       = e1 `eq` e2+  CmmReg r1          `eq` CmmReg r2          = r1==r2+  CmmRegOff r1 i1    `eq` CmmRegOff r2 i2    = r1==r2 && i1==i2+  CmmMachOp op1 es1  `eq` CmmMachOp op2 es2  = op1==op2 && es1 `eqs` es2+  CmmStackSlot a1 i1 `eq` CmmStackSlot a2 i2 = eqArea a1 a2 && i1==i2+  _e1                `eq` _e2                = False++  xs `eqs` ys = and (zipWith eq xs ys)++  eqLit (CmmBlock id1) (CmmBlock id2) = eqBid id1 id2+  eqLit l1 l2 = l1 == l2++  eqArea Old Old = True+  eqArea (Young id1) (Young id2) = eqBid id1 id2+  eqArea _ _ = False++-- Equality on the body of a block, modulo a function mapping block+-- IDs to block IDs.+eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool+eqBlockBodyWith eqBid block block'+  {-+  | equal     = pprTrace "equal" (vcat [ppr block, ppr block']) True+  | otherwise = pprTrace "not equal" (vcat [ppr block, ppr block']) False+  -}+  = equal+  where (_,m,l)   = blockSplit block+        nodes     = filter (not . dont_care) (blockToList m)+        (_,m',l') = blockSplit block'+        nodes'    = filter (not . dont_care) (blockToList m')++        equal = and (zipWith (eqMiddleWith eqBid) nodes nodes') &&+                eqLastWith eqBid l l'+++eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool+eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2+eqLastWith eqBid (CmmCondBranch c1 t1 f1 l1) (CmmCondBranch c2 t2 f2 l2) =+  c1 == c2 && l1 == l2 && eqBid t1 t2 && eqBid f1 f2+eqLastWith eqBid (CmmCall t1 c1 g1 a1 r1 u1) (CmmCall t2 c2 g2 a2 r2 u2) =+  t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2+eqLastWith eqBid (CmmSwitch e1 ids1) (CmmSwitch e2 ids2) =+  e1 == e2 && eqSwitchTargetWith eqBid ids1 ids2+eqLastWith _ _ _ = False++eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool+eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'+eqMaybeWith _ Nothing Nothing = True+eqMaybeWith _ _ _ = False++-- | Given a block map, ensure that all "target" blocks are covered by+-- the same ticks as the respective "source" blocks. This not only+-- means copying ticks, but also adjusting tick scopes where+-- necessary.+copyTicks :: LabelMap BlockId -> CmmGraph -> CmmGraph+copyTicks env g+  | mapNull env = g+  | otherwise   = ofBlockMap (g_entry g) $ mapMap copyTo blockMap+  where -- Reverse block merge map+        blockMap = toBlockMap g+        revEnv = mapFoldWithKey insertRev M.empty env+        insertRev k x = M.insertWith (const (k:)) x [k]+        -- Copy ticks and scopes into the given block+        copyTo block = case M.lookup (entryLabel block) revEnv of+          Nothing -> block+          Just ls -> foldr copy block $ mapMaybe (flip mapLookup blockMap) ls+        copy from to =+          let ticks = blockTicks from+              CmmEntry  _   scp0        = firstNode from+              (CmmEntry lbl scp1, code) = blockSplitHead to+          in CmmEntry lbl (combineTickScopes scp0 scp1) `blockJoinHead`+             foldr blockCons code (map CmmTick ticks)++-- Group by [Label]+groupByLabel :: [(Key, a)] -> [(Key, [a])]+groupByLabel = go (TM.emptyTM :: TM.ListMap UniqDFM a)+  where+    go !m [] = TM.foldTM (:) m []+    go !m ((k,v) : entries) = go (TM.alterTM k' adjust m) entries+      where k' = map getUnique k+            adjust Nothing       = Just (k,[v])+            adjust (Just (_,vs)) = Just (k,v:vs)+++groupByInt :: (a -> Int) -> [a] -> [[a]]+groupByInt f xs = nonDetEltsUFM $ List.foldl' go emptyUFM xs+  -- See Note [Unique Determinism and code generation]+  where go m x = alterUFM (Just . maybe [x] (x:)) m (f x)
+ cmm/CmmContFlowOpt.hs view
@@ -0,0 +1,415 @@+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+module CmmContFlowOpt+    ( cmmCfgOpts+    , cmmCfgOptsProc+    , removeUnreachableBlocksProc+    , replaceLabels+    )+where++import Hoopl+import BlockId+import Cmm+import CmmUtils+import CmmSwitch (mapSwitchTargets)+import Maybes+import Panic++import Control.Monad+import Prelude hiding (succ, unzip, zip)+++-- Note [What is shortcutting]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Consider this Cmm code:+--+-- L1: ...+--     goto L2;+-- L2: goto L3;+-- L3: ...+--+-- Here L2 is an empty block and contains only an unconditional branch+-- to L3. In this situation any block that jumps to L2 can jump+-- directly to L3:+--+-- L1: ...+--     goto L3;+-- L2: goto L3;+-- L3: ...+--+-- In this situation we say that we shortcut L2 to L3. One of+-- consequences of shortcutting is that some blocks of code may become+-- unreachable (in the example above this is true for L2).+++-- Note [Control-flow optimisations]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- This optimisation does three things:+--+--   - If a block finishes in an unconditonal branch to another block+--     and that is the only jump to that block we concatenate the+--     destination block at the end of the current one.+--+--   - If a block finishes in a call whose continuation block is a+--     goto, then we can shortcut the destination, making the+--     continuation block the destination of the goto - but see Note+--     [Shortcut call returns].+--+--   - For any block that is not a call we try to shortcut the+--     destination(s). Additionally, if a block ends with a+--     conditional branch we try to invert the condition.+--+-- Blocks are processed using postorder DFS traversal. A side effect+-- of determining traversal order with a graph search is elimination+-- of any blocks that are unreachable.+--+-- Transformations are improved by working from the end of the graph+-- towards the beginning, because we may be able to perform many+-- shortcuts in one go.+++-- Note [Shortcut call returns]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- We are going to maintain the "current" graph (LabelMap CmmBlock) as+-- we go, and also a mapping from BlockId to BlockId, representing+-- continuation labels that we have renamed.  This latter mapping is+-- important because we might shortcut a CmmCall continuation.  For+-- example:+--+--    Sp[0] = L+--    call g returns to L+--    L: goto M+--    M: ...+--+-- So when we shortcut the L block, we need to replace not only+-- the continuation of the call, but also references to L in the+-- code (e.g. the assignment Sp[0] = L):+--+--    Sp[0] = M+--    call g returns to M+--    M: ...+--+-- So we keep track of which labels we have renamed and apply the mapping+-- at the end with replaceLabels.+++-- Note [Shortcut call returns and proc-points]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Consider this code that you might get from a recursive+-- let-no-escape:+--+--       goto L1+--      L1:+--       if (Hp > HpLim) then L2 else L3+--      L2:+--       call stg_gc_noregs returns to L4+--      L4:+--       goto L1+--      L3:+--       ...+--       goto L1+--+-- Then the control-flow optimiser shortcuts L4.  But that turns L1+-- into the call-return proc point, and every iteration of the loop+-- has to shuffle variables to and from the stack.  So we must *not*+-- shortcut L4.+--+-- Moreover not shortcutting call returns is probably fine.  If L4 can+-- concat with its branch target then it will still do so.  And we+-- save some compile time because we don't have to traverse all the+-- code in replaceLabels.+--+-- However, we probably do want to do this if we are splitting proc+-- points, because L1 will be a proc-point anyway, so merging it with+-- L4 reduces the number of proc points.  Unfortunately recursive+-- let-no-escapes won't generate very good code with proc-point+-- splitting on - we should probably compile them to explicitly use+-- the native calling convention instead.++cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph+cmmCfgOpts split g = fst (blockConcat split g)++cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl+cmmCfgOptsProc split (CmmProc info lbl live g) = CmmProc info' lbl live g'+    where (g', env) = blockConcat split g+          info' = info{ info_tbls = new_info_tbls }+          new_info_tbls = mapFromList (map upd_info (mapToList (info_tbls info)))++          -- If we changed any labels, then we have to update the info tables+          -- too, except for the top-level info table because that might be+          -- referred to by other procs.+          upd_info (k,info)+             | Just k' <- mapLookup k env+             = (k', if k' == g_entry g'+                       then info+                       else info{ cit_lbl = infoTblLbl k' })+             | otherwise+             = (k,info)+cmmCfgOptsProc _ top = top+++blockConcat :: Bool -> CmmGraph -> (CmmGraph, LabelMap BlockId)+blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }+  = (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map')+  where+     -- We might be able to shortcut the entry BlockId itself.+     -- Remember to update the shortcut_map, since we also have to+     -- update the info_tbls mapping now.+     (new_entry, shortcut_map')+       | Just entry_blk <- mapLookup entry_id new_blocks+       , Just dest      <- canShortcut entry_blk+       = (dest, mapInsert entry_id dest shortcut_map)+       | otherwise+       = (entry_id, shortcut_map)++     -- blocks is a list of blocks in DFS postorder, while blockmap is+     -- a map of blocks. We process each element from blocks and update+     -- blockmap accordingly+     blocks = postorderDfs g+     blockmap = foldr addBlock emptyBody blocks++     -- Accumulator contains three components:+     --  * map of blocks in a graph+     --  * map of shortcut labels. See Note [Shortcut call returns]+     --  * map containing number of predecessors for each block. We discard+     --    it after we process all blocks.+     (new_blocks, shortcut_map, _) =+           foldr maybe_concat (blockmap, mapEmpty, initialBackEdges) blocks++     -- Map of predecessors for initial graph. We increase number of+     -- predecessors for entry block by one to denote that it is+     -- target of a jump, even if no block in the current graph jumps+     -- to it.+     initialBackEdges = incPreds entry_id (predMap blocks)++     maybe_concat :: CmmBlock+                  -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)+                  -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)+     maybe_concat block (blocks, shortcut_map, backEdges)+        -- If:+        --   (1) current block ends with unconditional branch to b' and+        --   (2) it has exactly one predecessor (namely, current block)+        --+        -- Then:+        --   (1) append b' block at the end of current block+        --   (2) remove b' from the map of blocks+        --   (3) remove information about b' from predecessors map+        --+        -- Since we know that the block has only one predecessor we call+        -- mapDelete directly instead of calling decPreds.+        --+        -- Note that we always maintain an up-to-date list of predecessors, so+        -- we can ignore the contents of shortcut_map+        | CmmBranch b' <- last+        , hasOnePredecessor b'+        , Just blk' <- mapLookup b' blocks+        = let bid' = entryLabel blk'+          in ( mapDelete bid' $ mapInsert bid (splice head blk') blocks+             , shortcut_map+             , mapDelete b' backEdges )++        -- If:+        --   (1) we are splitting proc points (see Note+        --       [Shortcut call returns and proc-points]) and+        --   (2) current block is a CmmCall or CmmForeignCall with+        --       continuation b' and+        --   (3) we can shortcut that continuation to dest+        -- Then:+        --   (1) we change continuation to point to b'+        --   (2) create mapping from b' to dest+        --   (3) increase number of predecessors of dest by 1+        --   (4) decrease number of predecessors of b' by 1+        --+        -- Later we will use replaceLabels to substitute all occurrences of b'+        -- with dest.+        | splitting_procs+        , Just b'   <- callContinuation_maybe last+        , Just blk' <- mapLookup b' blocks+        , Just dest <- canShortcut blk'+        = ( mapInsert bid (blockJoinTail head (update_cont dest)) blocks+          , mapInsert b' dest shortcut_map+          , decPreds b' $ incPreds dest backEdges )++        -- If:+        --   (1) a block does not end with a call+        -- Then:+        --   (1) if it ends with a conditional attempt to invert the+        --       conditional+        --   (2) attempt to shortcut all destination blocks+        --   (3) if new successors of a block are different from the old ones+        --       update the of predecessors accordingly+        --+        -- A special case of this is a situation when a block ends with an+        -- unconditional jump to a block that can be shortcut.+        | Nothing <- callContinuation_maybe last+        = let oldSuccs = successors last+              newSuccs = successors swapcond_last+          in ( mapInsert bid (blockJoinTail head swapcond_last) blocks+             , shortcut_map+             , if oldSuccs == newSuccs+               then backEdges+               else foldr incPreds (foldr decPreds backEdges oldSuccs) newSuccs )++        -- Otherwise don't do anything+        | otherwise+        = ( blocks, shortcut_map, backEdges )+        where+          (head, last) = blockSplitTail block+          bid = entryLabel block++          -- Changes continuation of a call to a specified label+          update_cont dest =+              case last of+                CmmCall{}        -> last { cml_cont = Just dest }+                CmmForeignCall{} -> last { succ = dest }+                _                -> panic "Can't shortcut continuation."++          -- Attempts to shortcut successors of last node+          shortcut_last = mapSuccessors shortcut last+            where+              shortcut l =+                 case mapLookup l blocks of+                   Just b | Just dest <- canShortcut b -> dest+                   _otherwise -> l++          -- For a conditional, we invert the conditional if that would make it+          -- more likely that the branch-not-taken case becomes a fallthrough.+          -- This helps the native codegen a little bit, and probably has no+          -- effect on LLVM.  It's convenient to do it here, where we have the+          -- information about predecessors.+          swapcond_last+            | CmmCondBranch cond t f l <- shortcut_last+            , likelyFalse l+            , numPreds f > 1+            , hasOnePredecessor t+            , Just cond' <- maybeInvertCmmExpr cond+            = CmmCondBranch cond' f t (invertLikeliness l)++            | otherwise+            = shortcut_last++          likelyFalse (Just False) = True+          likelyFalse Nothing      = True+          likelyFalse _            = False++          invertLikeliness (Just b)     = Just (not b)+          invertLikeliness Nothing      = Nothing++          -- Number of predecessors for a block+          numPreds bid = mapLookup bid backEdges `orElse` 0++          hasOnePredecessor b = numPreds b == 1++-- Functions for incrementing and decrementing number of predecessors. If+-- decrementing would set the predecessor count to 0, we remove entry from the+-- map.+-- Invariant: if a block has no predecessors it should be dropped from the+-- graph because it is unreachable. maybe_concat is constructed to maintain+-- that invariant, but calling replaceLabels may introduce unreachable blocks.+-- We rely on subsequent passes in the Cmm pipeline to remove unreachable+-- blocks.+incPreds, decPreds :: BlockId -> LabelMap Int -> LabelMap Int+incPreds bid edges = mapInsertWith (+) bid 1 edges+decPreds bid edges = case mapLookup bid edges of+                       Just preds | preds > 1 -> mapInsert bid (preds - 1) edges+                       Just _                 -> mapDelete bid edges+                       _                      -> edges+++-- Checks if a block consists only of "goto dest". If it does than we return+-- "Just dest" label. See Note [What is shortcutting]+canShortcut :: CmmBlock -> Maybe BlockId+canShortcut block+    | (_, middle, CmmBranch dest) <- blockSplit block+    , all dont_care $ blockToList middle+    = Just dest+    | otherwise+    = Nothing+    where dont_care CmmComment{} = True+          dont_care CmmTick{}    = True+          dont_care _other       = False++-- Concatenates two blocks. First one is assumed to be open on exit, the second+-- is assumed to be closed on entry (i.e. it has a label attached to it, which+-- the splice function removes by calling snd on result of blockSplitHead).+splice :: Block CmmNode C O -> CmmBlock -> CmmBlock+splice head rest = entry `blockJoinHead` code0 `blockAppend` code1+  where (CmmEntry lbl sc0, code0) = blockSplitHead head+        (CmmEntry _   sc1, code1) = blockSplitHead rest+        entry = CmmEntry lbl (combineTickScopes sc0 sc1)++-- If node is a call with continuation call return Just label of that+-- continuation. Otherwise return Nothing.+callContinuation_maybe :: CmmNode O C -> Maybe BlockId+callContinuation_maybe (CmmCall { cml_cont = Just b }) = Just b+callContinuation_maybe (CmmForeignCall { succ = b })   = Just b+callContinuation_maybe _ = Nothing+++-- Map over the CmmGraph, replacing each label with its mapping in the+-- supplied LabelMap.+replaceLabels :: LabelMap BlockId -> CmmGraph -> CmmGraph+replaceLabels env g+  | mapNull env = g+  | otherwise   = replace_eid $ mapGraphNodes1 txnode g+   where+     replace_eid g = g {g_entry = lookup (g_entry g)}+     lookup id = mapLookup id env `orElse` id++     txnode :: CmmNode e x -> CmmNode e x+     txnode (CmmBranch bid) = CmmBranch (lookup bid)+     txnode (CmmCondBranch p t f l) =+       mkCmmCondBranch (exp p) (lookup t) (lookup f) l+     txnode (CmmSwitch e ids) =+       CmmSwitch (exp e) (mapSwitchTargets lookup ids)+     txnode (CmmCall t k rg a res r) =+       CmmCall (exp t) (liftM lookup k) rg a res r+     txnode fc@CmmForeignCall{} =+       fc{ args = map exp (args fc), succ = lookup (succ fc) }+     txnode other = mapExpDeep exp other++     exp :: CmmExpr -> CmmExpr+     exp (CmmLit (CmmBlock bid))                = CmmLit (CmmBlock (lookup bid))+     exp (CmmStackSlot (Young id) i) = CmmStackSlot (Young (lookup id)) i+     exp e                                      = e++mkCmmCondBranch :: CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode O C+mkCmmCondBranch p t f l =+  if t == f then CmmBranch t else CmmCondBranch p t f l++-- Build a map from a block to its set of predecessors.+predMap :: [CmmBlock] -> LabelMap Int+predMap blocks = foldr add_preds mapEmpty blocks+  where+    add_preds block env = foldr add env (successors block)+      where add lbl env = mapInsertWith (+) lbl 1 env++-- Removing unreachable blocks+removeUnreachableBlocksProc :: CmmDecl -> CmmDecl+removeUnreachableBlocksProc proc@(CmmProc info lbl live g)+   | length used_blocks < mapSize (toBlockMap g)+   = CmmProc info' lbl live g'+   | otherwise+   = proc+   where+     g'    = ofBlockList (g_entry g) used_blocks+     info' = info { info_tbls = keep_used (info_tbls info) }+             -- Remove any info_tbls for unreachable++     keep_used :: LabelMap CmmInfoTable -> LabelMap CmmInfoTable+     keep_used bs = mapFoldWithKey keep mapEmpty bs++     keep :: Label -> CmmInfoTable -> LabelMap CmmInfoTable -> LabelMap CmmInfoTable+     keep l i env | l `setMember` used_lbls = mapInsert l i env+                  | otherwise               = env++     used_blocks :: [CmmBlock]+     used_blocks = postorderDfs g++     used_lbls :: LabelSet+     used_lbls = foldr (setInsert . entryLabel) setEmpty used_blocks
+ cmm/CmmExpr.hs view
@@ -0,0 +1,585 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}++module CmmExpr+    ( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr+    , CmmReg(..), cmmRegType+    , CmmLit(..), cmmLitType+    , LocalReg(..), localRegType+    , GlobalReg(..), isArgReg, globalRegType, spReg, hpReg, spLimReg, nodeReg, node, baseReg+    , VGcPtr(..)++    , DefinerOfRegs, UserOfRegs+    , foldRegsDefd, foldRegsUsed+    , foldLocalRegsDefd, foldLocalRegsUsed++    , RegSet, LocalRegSet, GlobalRegSet+    , emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet+    , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet+    , regSetToList++    , Area(..)+    , module CmmMachOp+    , module CmmType+    )+where++import BlockId+import CLabel+import CmmMachOp+import CmmType+import DynFlags+import Outputable (panic)+import Unique++import Data.Set (Set)+import Data.List+import qualified Data.Set as Set++-----------------------------------------------------------------------------+--              CmmExpr+-- An expression.  Expressions have no side effects.+-----------------------------------------------------------------------------++data CmmExpr+  = CmmLit CmmLit               -- Literal+  | CmmLoad !CmmExpr !CmmType   -- Read memory location+  | CmmReg !CmmReg              -- Contents of register+  | CmmMachOp MachOp [CmmExpr]  -- Machine operation (+, -, *, etc.)+  | CmmStackSlot Area {-# UNPACK #-} !Int+                                -- addressing expression of a stack slot+                                -- See Note [CmmStackSlot aliasing]+  | CmmRegOff !CmmReg Int+        -- CmmRegOff reg i+        --        ** is shorthand only, meaning **+        -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]+        --      where rep = typeWidth (cmmRegType reg)++instance Eq CmmExpr where       -- Equality ignores the types+  CmmLit l1          == CmmLit l2          = l1==l2+  CmmLoad e1 _       == CmmLoad e2 _       = e1==e2+  CmmReg r1          == CmmReg r2          = r1==r2+  CmmRegOff r1 i1    == CmmRegOff r2 i2    = r1==r2 && i1==i2+  CmmMachOp op1 es1  == CmmMachOp op2 es2  = op1==op2 && es1==es2+  CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2+  _e1                == _e2                = False++data CmmReg+  = CmmLocal  {-# UNPACK #-} !LocalReg+  | CmmGlobal GlobalReg+  deriving( Eq, Ord )++-- | A stack area is either the stack slot where a variable is spilled+-- or the stack space where function arguments and results are passed.+data Area+  = Old            -- See Note [Old Area]+  | Young {-# UNPACK #-} !BlockId  -- Invariant: must be a continuation BlockId+                   -- See Note [Continuation BlockId] in CmmNode.+  deriving (Eq, Ord)++{- Note [Old Area]+~~~~~~~~~~~~~~~~~~+There is a single call area 'Old', allocated at the extreme old+end of the stack frame (ie just younger than the return address)+which holds:+  * incoming (overflow) parameters,+  * outgoing (overflow) parameter to tail calls,+  * outgoing (overflow) result values+  * the update frame (if any)++Its size is the max of all these requirements.  On entry, the stack+pointer will point to the youngest incoming parameter, which is not+necessarily at the young end of the Old area.++End of note -}+++{- Note [CmmStackSlot aliasing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When do two CmmStackSlots alias?++ - T[old+N] aliases with U[young(L)+M] for all T, U, L, N and M+ - T[old+N] aliases with U[old+M] only if the areas actually overlap++Or more informally, different Areas may overlap with each other.++An alternative semantics, that we previously had, was that different+Areas do not overlap.  The problem that lead to redefining the+semantics of stack areas is described below.++e.g. if we had++    x = Sp[old + 8]+    y = Sp[old + 16]++    Sp[young(L) + 8]  = L+    Sp[young(L) + 16] = y+    Sp[young(L) + 24] = x+    call f() returns to L++if areas semantically do not overlap, then we might optimise this to++    Sp[young(L) + 8]  = L+    Sp[young(L) + 16] = Sp[old + 8]+    Sp[young(L) + 24] = Sp[old + 16]+    call f() returns to L++and now young(L) cannot be allocated at the same place as old, and we+are doomed to use more stack.++  - old+8  conflicts with young(L)+8+  - old+16 conflicts with young(L)+16 and young(L)+8++so young(L)+8 == old+24 and we get++    Sp[-8]  = L+    Sp[-16] = Sp[8]+    Sp[-24] = Sp[0]+    Sp -= 24+    call f() returns to L++However, if areas are defined to be "possibly overlapping" in the+semantics, then we cannot commute any loads/stores of old with+young(L), and we will be able to re-use both old+8 and old+16 for+young(L).++    x = Sp[8]+    y = Sp[0]++    Sp[8] = L+    Sp[0] = y+    Sp[-8] = x+    Sp = Sp - 8+    call f() returns to L++Now, the assignments of y go away,++    x = Sp[8]+    Sp[8] = L+    Sp[-8] = x+    Sp = Sp - 8+    call f() returns to L+-}++data CmmLit+  = CmmInt !Integer  Width+        -- Interpretation: the 2's complement representation of the value+        -- is truncated to the specified size.  This is easier than trying+        -- to keep the value within range, because we don't know whether+        -- it will be used as a signed or unsigned value (the CmmType doesn't+        -- distinguish between signed & unsigned).+  | CmmFloat  Rational Width+  | CmmVec [CmmLit]                     -- Vector literal+  | CmmLabel    CLabel                  -- Address of label+  | CmmLabelOff CLabel Int              -- Address of label + byte offset++        -- Due to limitations in the C backend, the following+        -- MUST ONLY be used inside the info table indicated by label2+        -- (label2 must be the info label), and label1 must be an+        -- SRT, a slow entrypoint or a large bitmap (see the Mangler)+        -- Don't use it at all unless tablesNextToCode.+        -- It is also used inside the NCG during when generating+        -- position-independent code.+  | CmmLabelDiffOff CLabel CLabel Int   -- label1 - label2 + offset++  | CmmBlock {-# UNPACK #-} !BlockId     -- Code label+        -- Invariant: must be a continuation BlockId+        -- See Note [Continuation BlockId] in CmmNode.++  | CmmHighStackMark -- A late-bound constant that stands for the max+                     -- #bytes of stack space used during a procedure.+                     -- During the stack-layout pass, CmmHighStackMark+                     -- is replaced by a CmmInt for the actual number+                     -- of bytes used+  deriving Eq++cmmExprType :: DynFlags -> CmmExpr -> CmmType+cmmExprType dflags (CmmLit lit)        = cmmLitType dflags lit+cmmExprType _      (CmmLoad _ rep)     = rep+cmmExprType dflags (CmmReg reg)        = cmmRegType dflags reg+cmmExprType dflags (CmmMachOp op args) = machOpResultType dflags op (map (cmmExprType dflags) args)+cmmExprType dflags (CmmRegOff reg _)   = cmmRegType dflags reg+cmmExprType dflags (CmmStackSlot _ _)  = bWord dflags -- an address+-- Careful though: what is stored at the stack slot may be bigger than+-- an address++cmmLitType :: DynFlags -> CmmLit -> CmmType+cmmLitType _      (CmmInt _ width)     = cmmBits  width+cmmLitType _      (CmmFloat _ width)   = cmmFloat width+cmmLitType _      (CmmVec [])          = panic "cmmLitType: CmmVec []"+cmmLitType cflags (CmmVec (l:ls))      = let ty = cmmLitType cflags l+                                         in if all (`cmmEqType` ty) (map (cmmLitType cflags) ls)+                                            then cmmVec (1+length ls) ty+                                            else panic "cmmLitType: CmmVec"+cmmLitType dflags (CmmLabel lbl)       = cmmLabelType dflags lbl+cmmLitType dflags (CmmLabelOff lbl _)  = cmmLabelType dflags lbl+cmmLitType dflags (CmmLabelDiffOff {}) = bWord dflags+cmmLitType dflags (CmmBlock _)         = bWord dflags+cmmLitType dflags (CmmHighStackMark)   = bWord dflags++cmmLabelType :: DynFlags -> CLabel -> CmmType+cmmLabelType dflags lbl+ | isGcPtrLabel lbl = gcWord dflags+ | otherwise        = bWord dflags++cmmExprWidth :: DynFlags -> CmmExpr -> Width+cmmExprWidth dflags e = typeWidth (cmmExprType dflags e)++--------+--- Negation for conditional branches++maybeInvertCmmExpr :: CmmExpr -> Maybe CmmExpr+maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op+                                            return (CmmMachOp op' args)+maybeInvertCmmExpr _ = Nothing++-----------------------------------------------------------------------------+--              Local registers+-----------------------------------------------------------------------------++data LocalReg+  = LocalReg {-# UNPACK #-} !Unique CmmType+    -- ^ Parameters:+    --   1. Identifier+    --   2. Type++instance Eq LocalReg where+  (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2++-- This is non-deterministic but we do not currently support deterministic+-- code-generation. See Note [Unique Determinism and code generation]+-- See Note [No Ord for Unique]+instance Ord LocalReg where+  compare (LocalReg u1 _) (LocalReg u2 _) = nonDetCmpUnique u1 u2++instance Uniquable LocalReg where+  getUnique (LocalReg uniq _) = uniq++cmmRegType :: DynFlags -> CmmReg -> CmmType+cmmRegType _      (CmmLocal  reg) = localRegType reg+cmmRegType dflags (CmmGlobal reg) = globalRegType dflags reg++localRegType :: LocalReg -> CmmType+localRegType (LocalReg _ rep) = rep++-----------------------------------------------------------------------------+--    Register-use information for expressions and other types+-----------------------------------------------------------------------------++-- | Sets of registers++-- These are used for dataflow facts, and a common operation is taking+-- the union of two RegSets and then asking whether the union is the+-- same as one of the inputs.  UniqSet isn't good here, because+-- sizeUniqSet is O(n) whereas Set.size is O(1), so we use ordinary+-- Sets.++type RegSet r     = Set r+type LocalRegSet  = RegSet LocalReg+type GlobalRegSet = RegSet GlobalReg++emptyRegSet             :: RegSet r+nullRegSet              :: RegSet r -> Bool+elemRegSet              :: Ord r => r -> RegSet r -> Bool+extendRegSet            :: Ord r => RegSet r -> r -> RegSet r+deleteFromRegSet        :: Ord r => RegSet r -> r -> RegSet r+mkRegSet                :: Ord r => [r] -> RegSet r+minusRegSet, plusRegSet, timesRegSet :: Ord r => RegSet r -> RegSet r -> RegSet r+sizeRegSet              :: RegSet r -> Int+regSetToList            :: RegSet r -> [r]++emptyRegSet      = Set.empty+nullRegSet       = Set.null+elemRegSet       = Set.member+extendRegSet     = flip Set.insert+deleteFromRegSet = flip Set.delete+mkRegSet         = Set.fromList+minusRegSet      = Set.difference+plusRegSet       = Set.union+timesRegSet      = Set.intersection+sizeRegSet       = Set.size+regSetToList     = Set.toList++class Ord r => UserOfRegs r a where+  foldRegsUsed :: DynFlags -> (b -> r -> b) -> b -> a -> b++foldLocalRegsUsed :: UserOfRegs LocalReg a+                  => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b+foldLocalRegsUsed = foldRegsUsed++class Ord r => DefinerOfRegs r a where+  foldRegsDefd :: DynFlags -> (b -> r -> b) -> b -> a -> b++foldLocalRegsDefd :: DefinerOfRegs LocalReg a+                  => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b+foldLocalRegsDefd = foldRegsDefd++instance UserOfRegs LocalReg CmmReg where+    foldRegsUsed _ f z (CmmLocal reg) = f z reg+    foldRegsUsed _ _ z (CmmGlobal _)  = z++instance DefinerOfRegs LocalReg CmmReg where+    foldRegsDefd _ f z (CmmLocal reg) = f z reg+    foldRegsDefd _ _ z (CmmGlobal _)  = z++instance UserOfRegs GlobalReg CmmReg where+    foldRegsUsed _ _ z (CmmLocal _)    = z+    foldRegsUsed _ f z (CmmGlobal reg) = f z reg++instance DefinerOfRegs GlobalReg CmmReg where+    foldRegsDefd _ _ z (CmmLocal _)    = z+    foldRegsDefd _ f z (CmmGlobal reg) = f z reg++instance Ord r => UserOfRegs r r where+    foldRegsUsed _ f z r = f z r++instance Ord r => DefinerOfRegs r r where+    foldRegsDefd _ f z r = f z r++instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where+  -- The (Ord r) in the context is necessary here+  -- See Note [Recursive superclasses] in TcInstDcls+  foldRegsUsed dflags f !z e = expr z e+    where expr z (CmmLit _)          = z+          expr z (CmmLoad addr _)    = foldRegsUsed dflags f z addr+          expr z (CmmReg r)          = foldRegsUsed dflags f z r+          expr z (CmmMachOp _ exprs) = foldRegsUsed dflags f z exprs+          expr z (CmmRegOff r _)     = foldRegsUsed dflags f z r+          expr z (CmmStackSlot _ _)  = z++instance UserOfRegs r a => UserOfRegs r [a] where+  foldRegsUsed dflags f set as = foldl' (foldRegsUsed dflags f) set as+  {-# INLINABLE foldRegsUsed #-}++instance DefinerOfRegs r a => DefinerOfRegs r [a] where+  foldRegsDefd dflags f set as = foldl' (foldRegsDefd dflags f) set as+  {-# INLINABLE foldRegsDefd #-}++-----------------------------------------------------------------------------+--              Global STG registers+-----------------------------------------------------------------------------++data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show )++-----------------------------------------------------------------------------+--              Global STG registers+-----------------------------------------------------------------------------+{-+Note [Overlapping global registers]++The backend might not faithfully implement the abstraction of the STG+machine with independent registers for different values of type+GlobalReg. Specifically, certain pairs of registers (r1, r2) may+overlap in the sense that a store to r1 invalidates the value in r2,+and vice versa.++Currently this occurs only on the x86_64 architecture where FloatReg n+and DoubleReg n are assigned the same microarchitectural register, in+order to allow functions to receive more Float# or Double# arguments+in registers (as opposed to on the stack).++There are no specific rules about which registers might overlap with+which other registers, but presumably it's safe to assume that nothing+will overlap with special registers like Sp or BaseReg.++Use CmmUtils.regsOverlap to determine whether two GlobalRegs overlap+on a particular platform. The instance Eq GlobalReg is syntactic+equality of STG registers and does not take overlap into+account. However it is still used in UserOfRegs/DefinerOfRegs and+there are likely still bugs there, beware!+-}++data GlobalReg+  -- Argument and return registers+  = VanillaReg                  -- pointers, unboxed ints and chars+        {-# UNPACK #-} !Int     -- its number+        VGcPtr++  | FloatReg            -- single-precision floating-point registers+        {-# UNPACK #-} !Int     -- its number++  | DoubleReg           -- double-precision floating-point registers+        {-# UNPACK #-} !Int     -- its number++  | LongReg             -- long int registers (64-bit, really)+        {-# UNPACK #-} !Int     -- its number++  | XmmReg                      -- 128-bit SIMD vector register+        {-# UNPACK #-} !Int     -- its number++  | YmmReg                      -- 256-bit SIMD vector register+        {-# UNPACK #-} !Int     -- its number++  | ZmmReg                      -- 512-bit SIMD vector register+        {-# UNPACK #-} !Int     -- its number++  -- STG registers+  | Sp                  -- Stack ptr; points to last occupied stack location.+  | SpLim               -- Stack limit+  | Hp                  -- Heap ptr; points to last occupied heap location.+  | HpLim               -- Heap limit register+  | CCCS                -- Current cost-centre stack+  | CurrentTSO          -- pointer to current thread's TSO+  | CurrentNursery      -- pointer to allocation area+  | HpAlloc             -- allocation count for heap check failure++                -- We keep the address of some commonly-called+                -- functions in the register table, to keep code+                -- size down:+  | EagerBlackholeInfo  -- stg_EAGER_BLACKHOLE_info+  | GCEnter1            -- stg_gc_enter_1+  | GCFun               -- stg_gc_fun++  -- Base offset for the register table, used for accessing registers+  -- which do not have real registers assigned to them.  This register+  -- will only appear after we have expanded GlobalReg into memory accesses+  -- (where necessary) in the native code generator.+  | BaseReg++  -- The register used by the platform for the C stack pointer. This is+  -- a break in the STG abstraction used exclusively to setup stack unwinding+  -- information.+  | MachSp++  -- The is a dummy register used to indicate to the stack unwinder where+  -- a routine would return to.+  | UnwindReturnReg++  -- Base Register for PIC (position-independent code) calculations+  -- Only used inside the native code generator. It's exact meaning differs+  -- from platform to platform (see module PositionIndependentCode).+  | PicBaseReg++  deriving( Show )++instance Eq GlobalReg where+   VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes+   FloatReg i == FloatReg j = i==j+   DoubleReg i == DoubleReg j = i==j+   LongReg i == LongReg j = i==j+   XmmReg i == XmmReg j = i==j+   YmmReg i == YmmReg j = i==j+   ZmmReg i == ZmmReg j = i==j+   Sp == Sp = True+   SpLim == SpLim = True+   Hp == Hp = True+   HpLim == HpLim = True+   CCCS == CCCS = True+   CurrentTSO == CurrentTSO = True+   CurrentNursery == CurrentNursery = True+   HpAlloc == HpAlloc = True+   EagerBlackholeInfo == EagerBlackholeInfo = True+   GCEnter1 == GCEnter1 = True+   GCFun == GCFun = True+   BaseReg == BaseReg = True+   MachSp == MachSp = True+   UnwindReturnReg == UnwindReturnReg = True+   PicBaseReg == PicBaseReg = True+   _r1 == _r2 = False++instance Ord GlobalReg where+   compare (VanillaReg i _) (VanillaReg j _) = compare i j+     -- Ignore type when seeking clashes+   compare (FloatReg i)  (FloatReg  j) = compare i j+   compare (DoubleReg i) (DoubleReg j) = compare i j+   compare (LongReg i)   (LongReg   j) = compare i j+   compare (XmmReg i)    (XmmReg    j) = compare i j+   compare (YmmReg i)    (YmmReg    j) = compare i j+   compare (ZmmReg i)    (ZmmReg    j) = compare i j+   compare Sp Sp = EQ+   compare SpLim SpLim = EQ+   compare Hp Hp = EQ+   compare HpLim HpLim = EQ+   compare CCCS CCCS = EQ+   compare CurrentTSO CurrentTSO = EQ+   compare CurrentNursery CurrentNursery = EQ+   compare HpAlloc HpAlloc = EQ+   compare EagerBlackholeInfo EagerBlackholeInfo = EQ+   compare GCEnter1 GCEnter1 = EQ+   compare GCFun GCFun = EQ+   compare BaseReg BaseReg = EQ+   compare MachSp MachSp = EQ+   compare UnwindReturnReg UnwindReturnReg = EQ+   compare PicBaseReg PicBaseReg = EQ+   compare (VanillaReg _ _) _ = LT+   compare _ (VanillaReg _ _) = GT+   compare (FloatReg _) _     = LT+   compare _ (FloatReg _)     = GT+   compare (DoubleReg _) _    = LT+   compare _ (DoubleReg _)    = GT+   compare (LongReg _) _      = LT+   compare _ (LongReg _)      = GT+   compare (XmmReg _) _       = LT+   compare _ (XmmReg _)       = GT+   compare (YmmReg _) _       = LT+   compare _ (YmmReg _)       = GT+   compare (ZmmReg _) _       = LT+   compare _ (ZmmReg _)       = GT+   compare Sp _ = LT+   compare _ Sp = GT+   compare SpLim _ = LT+   compare _ SpLim = GT+   compare Hp _ = LT+   compare _ Hp = GT+   compare HpLim _ = LT+   compare _ HpLim = GT+   compare CCCS _ = LT+   compare _ CCCS = GT+   compare CurrentTSO _ = LT+   compare _ CurrentTSO = GT+   compare CurrentNursery _ = LT+   compare _ CurrentNursery = GT+   compare HpAlloc _ = LT+   compare _ HpAlloc = GT+   compare GCEnter1 _ = LT+   compare _ GCEnter1 = GT+   compare GCFun _ = LT+   compare _ GCFun = GT+   compare BaseReg _ = LT+   compare _ BaseReg = GT+   compare MachSp _ = LT+   compare _ MachSp = GT+   compare UnwindReturnReg _ = LT+   compare _ UnwindReturnReg = GT+   compare EagerBlackholeInfo _ = LT+   compare _ EagerBlackholeInfo = GT++-- convenient aliases+baseReg, spReg, hpReg, spLimReg, nodeReg :: CmmReg+baseReg = CmmGlobal BaseReg+spReg = CmmGlobal Sp+hpReg = CmmGlobal Hp+spLimReg = CmmGlobal SpLim+nodeReg = CmmGlobal node++node :: GlobalReg+node = VanillaReg 1 VGcPtr++globalRegType :: DynFlags -> GlobalReg -> CmmType+globalRegType dflags (VanillaReg _ VGcPtr)    = gcWord dflags+globalRegType dflags (VanillaReg _ VNonGcPtr) = bWord dflags+globalRegType _      (FloatReg _)      = cmmFloat W32+globalRegType _      (DoubleReg _)     = cmmFloat W64+globalRegType _      (LongReg _)       = cmmBits W64+globalRegType _      (XmmReg _)        = cmmVec 4 (cmmBits W32)+globalRegType _      (YmmReg _)        = cmmVec 8 (cmmBits W32)+globalRegType _      (ZmmReg _)        = cmmVec 16 (cmmBits W32)++globalRegType dflags Hp                = gcWord dflags+                                            -- The initialiser for all+                                            -- dynamically allocated closures+globalRegType dflags _                 = bWord dflags++isArgReg :: GlobalReg -> Bool+isArgReg (VanillaReg {}) = True+isArgReg (FloatReg {})   = True+isArgReg (DoubleReg {})  = True+isArgReg (LongReg {})    = True+isArgReg (XmmReg {})     = True+isArgReg (YmmReg {})     = True+isArgReg (ZmmReg {})     = True+isArgReg _               = False
+ cmm/CmmImplementSwitchPlans.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE GADTs #-}+module CmmImplementSwitchPlans+  ( cmmImplementSwitchPlans+  )+where++import Hoopl+import BlockId+import Cmm+import CmmUtils+import CmmSwitch+import UniqSupply+import DynFlags++--+-- This module replaces Switch statements as generated by the Stg -> Cmm+-- transformation, which might be huge and sparse and hence unsuitable for+-- assembly code, by proper constructs (if-then-else trees, dense jump tables).+--+-- The actual, abstract strategy is determined by createSwitchPlan in+-- CmmSwitch and returned as a SwitchPlan; here is just the implementation in+-- terms of Cmm code. See Note [Cmm Switches, the general plan] in CmmSwitch.+--+-- This division into different modules is both to clearly separte concerns,+-- but also because createSwitchPlan needs access to the constructors of+-- SwitchTargets, a data type exported abstractly by CmmSwitch.+--++-- | Traverses the 'CmmGraph', making sure that 'CmmSwitch' are suitable for+-- code generation.+cmmImplementSwitchPlans :: DynFlags -> CmmGraph -> UniqSM CmmGraph+cmmImplementSwitchPlans dflags g+    | targetSupportsSwitch (hscTarget dflags) = return g+    | otherwise = do+    blocks' <- concat `fmap` mapM (visitSwitches dflags) (toBlockList g)+    return $ ofBlockList (g_entry g) blocks'++visitSwitches :: DynFlags -> CmmBlock -> UniqSM [CmmBlock]+visitSwitches dflags block+  | (entry@(CmmEntry _ scope), middle, CmmSwitch expr ids) <- blockSplit block+  = do+    let plan = createSwitchPlan ids++    (newTail, newBlocks) <- implementSwitchPlan dflags scope expr plan++    let block' = entry `blockJoinHead` middle `blockAppend` newTail++    return $ block' : newBlocks++  | otherwise+  = return [block]+++-- Implementing a switch plan (returning a tail block)+implementSwitchPlan :: DynFlags -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqSM (Block CmmNode O C, [CmmBlock])+implementSwitchPlan dflags scope expr = go+  where+    go (Unconditionally l)+      = return (emptyBlock `blockJoinTail` CmmBranch l, [])+    go (JumpTable ids)+      = return (emptyBlock `blockJoinTail` CmmSwitch expr ids, [])+    go (IfLT signed i ids1 ids2)+      = do+        (bid1, newBlocks1) <- go' ids1+        (bid2, newBlocks2) <- go' ids2++        let lt | signed    = cmmSLtWord+               | otherwise = cmmULtWord+            scrut = lt dflags expr $ CmmLit $ mkWordCLit dflags i+            lastNode = CmmCondBranch scrut bid1 bid2 Nothing+            lastBlock = emptyBlock `blockJoinTail` lastNode+        return (lastBlock, newBlocks1++newBlocks2)+    go (IfEqual i l ids2)+      = do+        (bid2, newBlocks2) <- go' ids2++        let scrut = cmmNeWord dflags expr $ CmmLit $ mkWordCLit dflags i+            lastNode = CmmCondBranch scrut bid2 l Nothing+            lastBlock = emptyBlock `blockJoinTail` lastNode+        return (lastBlock, newBlocks2)++    -- Same but returning a label to branch to+    go' (Unconditionally l)+      = return (l, [])+    go' p+      = do+        bid <- mkBlockId `fmap` getUniqueM+        (last, newBlocks) <- go p+        let block = CmmEntry bid scope `blockJoinHead` last+        return (bid, block: newBlocks)
+ cmm/CmmInfo.hs view
@@ -0,0 +1,557 @@+{-# LANGUAGE CPP #-}+module CmmInfo (+  mkEmptyContInfoTable,+  cmmToRawCmm,+  mkInfoTable,+  srtEscape,++  -- info table accessors+  closureInfoPtr,+  entryCode,+  getConstrTag,+  cmmGetClosureType,+  infoTable,+  infoTableConstrTag,+  infoTableSrtBitmap,+  infoTableClosureType,+  infoTablePtrs,+  infoTableNonPtrs,+  funInfoTable,+  funInfoArity,++  -- info table sizes and offsets+  stdInfoTableSizeW,+  fixedInfoTableSizeW,+  profInfoTableSizeW,+  maxStdInfoTableSizeW,+  maxRetInfoTableSizeW,+  stdInfoTableSizeB,+  conInfoTableSizeB,+  stdSrtBitmapOffset,+  stdClosureTypeOffset,+  stdPtrsOffset, stdNonPtrsOffset,+) where++#include "HsVersions.h"++import Cmm+import CmmUtils+import CLabel+import SMRep+import Bitmap+import Stream (Stream)+import qualified Stream+import Hoopl++import Maybes+import DynFlags+import Panic+import UniqSupply+import MonadUtils+import Util+import Outputable++import Data.Bits+import Data.Word++-- When we split at proc points, we need an empty info table.+mkEmptyContInfoTable :: CLabel -> CmmInfoTable+mkEmptyContInfoTable info_lbl+  = CmmInfoTable { cit_lbl  = info_lbl+                 , cit_rep  = mkStackRep []+                 , cit_prof = NoProfilingInfo+                 , cit_srt  = NoC_SRT }++cmmToRawCmm :: DynFlags -> Stream IO CmmGroup ()+            -> IO (Stream IO RawCmmGroup ())+cmmToRawCmm dflags cmms+  = do { uniqs <- mkSplitUniqSupply 'i'+       ; let do_one uniqs cmm = do+                case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of+                  (b,uniqs') -> return (uniqs',b)+                  -- NB. strictness fixes a space leak.  DO NOT REMOVE.+       ; return (Stream.mapAccumL do_one uniqs cmms >> return ())+       }++-- Make a concrete info table, represented as a list of CmmStatic+-- (it can't be simply a list of Word, because the SRT field is+-- represented by a label+offset expression).+--+-- With tablesNextToCode, the layout is+--      <reversed variable part>+--      <normal forward StgInfoTable, but without+--              an entry point at the front>+--      <code>+--+-- Without tablesNextToCode, the layout of an info table is+--      <entry label>+--      <normal forward rest of StgInfoTable>+--      <forward variable part>+--+--      See includes/rts/storage/InfoTables.h+--+-- For return-points these are as follows+--+-- Tables next to code:+--+--                      <srt slot>+--                      <standard info table>+--      ret-addr -->    <entry code (if any)>+--+-- Not tables-next-to-code:+--+--      ret-addr -->    <ptr to entry code>+--                      <standard info table>+--                      <srt slot>+--+--  * The SRT slot is only there if there is SRT info to record++mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl]+mkInfoTable _ (CmmData sec dat)+  = return [CmmData sec dat]++mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)+  --+  -- in the non-tables-next-to-code case, procs can have at most a+  -- single info table associated with the entry label of the proc.+  --+  | not (tablesNextToCode dflags)+  = case topInfoTable proc of   --  must be at most one+      -- no info table+      Nothing ->+         return [CmmProc mapEmpty entry_lbl live blocks]++      Just info@CmmInfoTable { cit_lbl = info_lbl } -> do+        (top_decls, (std_info, extra_bits)) <-+             mkInfoTableContents dflags info Nothing+        let+          rel_std_info   = map (makeRelativeRefTo dflags info_lbl) std_info+          rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits+        --+        -- Separately emit info table (with the function entry+        -- point as first entry) and the entry code+        --+        return (top_decls +++                [CmmProc mapEmpty entry_lbl live blocks,+                 mkDataLits (Section Data info_lbl) info_lbl+                    (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)])++  --+  -- With tables-next-to-code, we can have many info tables,+  -- associated with some of the BlockIds of the proc.  For each info+  -- table we need to turn it into CmmStatics, and collect any new+  -- CmmDecls that arise from doing so.+  --+  | otherwise+  = do+    (top_declss, raw_infos) <-+       unzip `fmap` mapM do_one_info (mapToList (info_tbls infos))+    return (concat top_declss +++            [CmmProc (mapFromList raw_infos) entry_lbl live blocks])++  where+   do_one_info (lbl,itbl) = do+     (top_decls, (std_info, extra_bits)) <-+         mkInfoTableContents dflags itbl Nothing+     let+        info_lbl = cit_lbl itbl+        rel_std_info   = map (makeRelativeRefTo dflags info_lbl) std_info+        rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits+     --+     return (top_decls, (lbl, Statics info_lbl $ map CmmStaticLit $+                              reverse rel_extra_bits ++ rel_std_info))++-----------------------------------------------------+type InfoTableContents = ( [CmmLit]          -- The standard part+                         , [CmmLit] )        -- The "extra bits"+-- These Lits have *not* had mkRelativeTo applied to them++mkInfoTableContents :: DynFlags+                    -> CmmInfoTable+                    -> Maybe Int               -- Override default RTS type tag?+                    -> UniqSM ([RawCmmDecl],             -- Auxiliary top decls+                               InfoTableContents)       -- Info tbl + extra bits++mkInfoTableContents dflags+                    info@(CmmInfoTable { cit_lbl  = info_lbl+                                       , cit_rep  = smrep+                                       , cit_prof = prof+                                       , cit_srt = srt })+                    mb_rts_tag+  | RTSRep rts_tag rep <- smrep+  = mkInfoTableContents dflags info{cit_rep = rep} (Just rts_tag)+    -- Completely override the rts_tag that mkInfoTableContents would+    -- otherwise compute, with the rts_tag stored in the RTSRep+    -- (which in turn came from a handwritten .cmm file)++  | StackRep frame <- smrep+  = do { (prof_lits, prof_data) <- mkProfLits dflags prof+       ; let (srt_label, srt_bitmap) = mkSRTLit dflags srt+       ; (liveness_lit, liveness_data) <- mkLivenessBits dflags frame+       ; let+             std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit+             rts_tag | Just tag <- mb_rts_tag = tag+                     | null liveness_data     = rET_SMALL -- Fits in extra_bits+                     | otherwise              = rET_BIG   -- Does not; extra_bits is+                                                          -- a label+       ; return (prof_data ++ liveness_data, (std_info, srt_label)) }++  | HeapRep _ ptrs nonptrs closure_type <- smrep+  = do { let layout  = packIntsCLit dflags ptrs nonptrs+       ; (prof_lits, prof_data) <- mkProfLits dflags prof+       ; let (srt_label, srt_bitmap) = mkSRTLit dflags srt+       ; (mb_srt_field, mb_layout, extra_bits, ct_data)+                                <- mk_pieces closure_type srt_label+       ; let std_info = mkStdInfoTable dflags prof_lits+                                       (mb_rts_tag   `orElse` rtsClosureType smrep)+                                       (mb_srt_field `orElse` srt_bitmap)+                                       (mb_layout    `orElse` layout)+       ; return (prof_data ++ ct_data, (std_info, extra_bits)) }+  where+    mk_pieces :: ClosureTypeInfo -> [CmmLit]+              -> UniqSM ( Maybe StgHalfWord  -- Override the SRT field with this+                        , Maybe CmmLit       -- Override the layout field with this+                        , [CmmLit]           -- "Extra bits" for info table+                        , [RawCmmDecl])      -- Auxiliary data decls+    mk_pieces (Constr con_tag con_descr) _no_srt    -- A data constructor+      = do { (descr_lit, decl) <- newStringLit con_descr+           ; return ( Just (toStgHalfWord dflags (fromIntegral con_tag))+                    , Nothing, [descr_lit], [decl]) }++    mk_pieces Thunk srt_label+      = return (Nothing, Nothing, srt_label, [])++    mk_pieces (ThunkSelector offset) _no_srt+      = return (Just (toStgHalfWord dflags 0), Just (mkWordCLit dflags (fromIntegral offset)), [], [])+         -- Layout known (one free var); we use the layout field for offset++    mk_pieces (Fun arity (ArgSpec fun_type)) srt_label+      = do { let extra_bits = packIntsCLit dflags fun_type arity : srt_label+           ; return (Nothing, Nothing,  extra_bits, []) }++    mk_pieces (Fun arity (ArgGen arg_bits)) srt_label+      = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits+           ; let fun_type | null liveness_data = aRG_GEN+                          | otherwise          = aRG_GEN_BIG+                 extra_bits = [ packIntsCLit dflags fun_type arity+                              , srt_lit, liveness_lit, slow_entry ]+           ; return (Nothing, Nothing, extra_bits, liveness_data) }+      where+        slow_entry = CmmLabel (toSlowEntryLbl info_lbl)+        srt_lit = case srt_label of+                    []          -> mkIntCLit dflags 0+                    (lit:_rest) -> ASSERT( null _rest ) lit++    mk_pieces other _ = pprPanic "mk_pieces" (ppr other)++mkInfoTableContents _ _ _ = panic "mkInfoTableContents"   -- NonInfoTable dealt with earlier++packIntsCLit :: DynFlags -> Int -> Int -> CmmLit+packIntsCLit dflags a b = packHalfWordsCLit dflags+                           (toStgHalfWord dflags (fromIntegral a))+                           (toStgHalfWord dflags (fromIntegral b))+++mkSRTLit :: DynFlags+         -> C_SRT+         -> ([CmmLit],    -- srt_label, if any+             StgHalfWord) -- srt_bitmap+mkSRTLit dflags NoC_SRT                = ([], toStgHalfWord dflags 0)+mkSRTLit dflags (C_SRT lbl off bitmap) = ([cmmLabelOffW dflags lbl off], bitmap)+++-------------------------------------------------------------------------+--+--      Lay out the info table and handle relative offsets+--+-------------------------------------------------------------------------++-- This function takes+--   * the standard info table portion (StgInfoTable)+--   * the "extra bits" (StgFunInfoExtraRev etc.)+--   * the entry label+--   * the code+-- and lays them out in memory, producing a list of RawCmmDecl++-------------------------------------------------------------------------+--+--      Position independent code+--+-------------------------------------------------------------------------+-- In order to support position independent code, we mustn't put absolute+-- references into read-only space. Info tables in the tablesNextToCode+-- case must be in .text, which is read-only, so we doctor the CmmLits+-- to use relative offsets instead.++-- Note that this is done even when the -fPIC flag is not specified,+-- as we want to keep binary compatibility between PIC and non-PIC.++makeRelativeRefTo :: DynFlags -> CLabel -> CmmLit -> CmmLit++makeRelativeRefTo dflags info_lbl (CmmLabel lbl)+  | tablesNextToCode dflags+  = CmmLabelDiffOff lbl info_lbl 0+makeRelativeRefTo dflags info_lbl (CmmLabelOff lbl off)+  | tablesNextToCode dflags+  = CmmLabelDiffOff lbl info_lbl off+makeRelativeRefTo _ _ lit = lit+++-------------------------------------------------------------------------+--+--              Build a liveness mask for the stack layout+--+-------------------------------------------------------------------------++-- There are four kinds of things on the stack:+--+--      - pointer variables (bound in the environment)+--      - non-pointer variables (bound in the environment)+--      - free slots (recorded in the stack free list)+--      - non-pointer data slots (recorded in the stack free list)+--+-- The first two are represented with a 'Just' of a 'LocalReg'.+-- The last two with one or more 'Nothing' constructors.+-- Each 'Nothing' represents one used word.+--+-- The head of the stack layout is the top of the stack and+-- the least-significant bit.++mkLivenessBits :: DynFlags -> Liveness -> UniqSM (CmmLit, [RawCmmDecl])+              -- ^ Returns:+              --   1. The bitmap (literal value or label)+              --   2. Large bitmap CmmData if needed++mkLivenessBits dflags liveness+  | n_bits > mAX_SMALL_BITMAP_SIZE dflags -- does not fit in one word+  = do { uniq <- getUniqueM+       ; let bitmap_lbl = mkBitmapLabel uniq+       ; return (CmmLabel bitmap_lbl,+                 [mkRODataLits bitmap_lbl lits]) }++  | otherwise -- Fits in one word+  = return (mkStgWordCLit dflags bitmap_word, [])+  where+    n_bits = length liveness++    bitmap :: Bitmap+    bitmap = mkBitmap dflags liveness++    small_bitmap = case bitmap of+                     []  -> toStgWord dflags 0+                     [b] -> b+                     _   -> panic "mkLiveness"+    bitmap_word = toStgWord dflags (fromIntegral n_bits)+              .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags)++    lits = mkWordCLit dflags (fromIntegral n_bits)+         : map (mkStgWordCLit dflags) bitmap+      -- The first word is the size.  The structure must match+      -- StgLargeBitmap in includes/rts/storage/InfoTable.h++-------------------------------------------------------------------------+--+--      Generating a standard info table+--+-------------------------------------------------------------------------++-- The standard bits of an info table.  This part of the info table+-- corresponds to the StgInfoTable type defined in+-- includes/rts/storage/InfoTables.h.+--+-- Its shape varies with ticky/profiling/tables next to code etc+-- so we can't use constant offsets from Constants++mkStdInfoTable+   :: DynFlags+   -> (CmmLit,CmmLit)   -- Closure type descr and closure descr  (profiling)+   -> Int               -- Closure RTS tag+   -> StgHalfWord       -- SRT length+   -> CmmLit            -- layout field+   -> [CmmLit]++mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit+ =      -- Parallel revertible-black hole field+    prof_info+        -- Ticky info (none at present)+        -- Debug info (none at present)+ ++ [layout_lit, type_lit]++ where+    prof_info+        | gopt Opt_SccProfilingOn dflags = [type_descr, closure_descr]+        | otherwise = []++    type_lit = packHalfWordsCLit dflags (toStgHalfWord dflags (fromIntegral cl_type)) srt_len++-------------------------------------------------------------------------+--+--      Making string literals+--+-------------------------------------------------------------------------++mkProfLits :: DynFlags -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])+mkProfLits dflags NoProfilingInfo       = return ((zeroCLit dflags, zeroCLit dflags), [])+mkProfLits _ (ProfilingInfo td cd)+  = do { (td_lit, td_decl) <- newStringLit td+       ; (cd_lit, cd_decl) <- newStringLit cd+       ; return ((td_lit,cd_lit), [td_decl,cd_decl]) }++newStringLit :: [Word8] -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)+newStringLit bytes+  = do { uniq <- getUniqueM+       ; return (mkByteStringCLit (mkStringLitLabel uniq) bytes) }+++-- Misc utils++-- | Value of the srt field of an info table when using an StgLargeSRT+srtEscape :: DynFlags -> StgHalfWord+srtEscape dflags = toStgHalfWord dflags (-1)++-------------------------------------------------------------------------+--+--      Accessing fields of an info table+--+-------------------------------------------------------------------------++closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr+-- Takes a closure pointer and returns the info table pointer+closureInfoPtr dflags e = CmmLoad e (bWord dflags)++entryCode :: DynFlags -> CmmExpr -> CmmExpr+-- Takes an info pointer (the first word of a closure)+-- and returns its entry code+entryCode dflags e+ | tablesNextToCode dflags = e+ | otherwise               = CmmLoad e (bWord dflags)++getConstrTag :: DynFlags -> CmmExpr -> CmmExpr+-- Takes a closure pointer, and return the *zero-indexed*+-- constructor tag obtained from the info table+-- This lives in the SRT field of the info table+-- (constructors don't need SRTs).+getConstrTag dflags closure_ptr+  = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table]+  where+    info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)++cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr+-- Takes a closure pointer, and return the closure type+-- obtained from the info table+cmmGetClosureType dflags closure_ptr+  = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table]+  where+    info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)++infoTable :: DynFlags -> CmmExpr -> CmmExpr+-- Takes an info pointer (the first word of a closure)+-- and returns a pointer to the first word of the standard-form+-- info table, excluding the entry-code word (if present)+infoTable dflags info_ptr+  | tablesNextToCode dflags = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags)+  | otherwise               = cmmOffsetW dflags info_ptr 1 -- Past the entry code pointer++infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr+-- Takes an info table pointer (from infoTable) and returns the constr tag+-- field of the info table (same as the srt_bitmap field)+infoTableConstrTag = infoTableSrtBitmap++infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr+-- Takes an info table pointer (from infoTable) and returns the srt_bitmap+-- field of the info table+infoTableSrtBitmap dflags info_tbl+  = CmmLoad (cmmOffsetB dflags info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord dflags)++infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr+-- Takes an info table pointer (from infoTable) and returns the closure type+-- field of the info table.+infoTableClosureType dflags info_tbl+  = CmmLoad (cmmOffsetB dflags info_tbl (stdClosureTypeOffset dflags)) (bHalfWord dflags)++infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr+infoTablePtrs dflags info_tbl+  = CmmLoad (cmmOffsetB dflags info_tbl (stdPtrsOffset dflags)) (bHalfWord dflags)++infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr+infoTableNonPtrs dflags info_tbl+  = CmmLoad (cmmOffsetB dflags info_tbl (stdNonPtrsOffset dflags)) (bHalfWord dflags)++funInfoTable :: DynFlags -> CmmExpr -> CmmExpr+-- Takes the info pointer of a function,+-- and returns a pointer to the first word of the StgFunInfoExtra struct+-- in the info table.+funInfoTable dflags info_ptr+  | tablesNextToCode dflags+  = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags)+  | otherwise+  = cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags)+                                -- Past the entry code pointer++-- Takes the info pointer of a function, returns the function's arity+funInfoArity :: DynFlags -> CmmExpr -> CmmExpr+funInfoArity dflags iptr+  = cmmToWord dflags (cmmLoadIndex dflags rep fun_info (offset `div` rep_bytes))+  where+   fun_info = funInfoTable dflags iptr+   rep = cmmBits (widthFromBytes rep_bytes)++   (rep_bytes, offset)+    | tablesNextToCode dflags = ( pc_REP_StgFunInfoExtraRev_arity pc+                                , oFFSET_StgFunInfoExtraRev_arity dflags )+    | otherwise               = ( pc_REP_StgFunInfoExtraFwd_arity pc+                                , oFFSET_StgFunInfoExtraFwd_arity dflags )++   pc = sPlatformConstants (settings dflags)++-----------------------------------------------------------------------------+--+--      Info table sizes & offsets+--+-----------------------------------------------------------------------------++stdInfoTableSizeW :: DynFlags -> WordOff+-- The size of a standard info table varies with profiling/ticky etc,+-- so we can't get it from Constants+-- It must vary in sync with mkStdInfoTable+stdInfoTableSizeW dflags+  = fixedInfoTableSizeW+  + if gopt Opt_SccProfilingOn dflags+       then profInfoTableSizeW+       else 0++fixedInfoTableSizeW :: WordOff+fixedInfoTableSizeW = 2 -- layout, type++profInfoTableSizeW :: WordOff+profInfoTableSizeW = 2++maxStdInfoTableSizeW :: WordOff+maxStdInfoTableSizeW =+  1 {- entry, when !tablesNextToCode -}+  + fixedInfoTableSizeW+  + profInfoTableSizeW++maxRetInfoTableSizeW :: WordOff+maxRetInfoTableSizeW =+  maxStdInfoTableSizeW+  + 1 {- srt label -}++stdInfoTableSizeB  :: DynFlags -> ByteOff+stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags++stdSrtBitmapOffset :: DynFlags -> ByteOff+-- Byte offset of the SRT bitmap half-word which is+-- in the *higher-addressed* part of the type_lit+stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE dflags++stdClosureTypeOffset :: DynFlags -> ByteOff+-- Byte offset of the closure type half-word+stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags++stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff+stdPtrsOffset    dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags+stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE dflags++conInfoTableSizeB :: DynFlags -> Int+conInfoTableSizeB dflags = stdInfoTableSizeB dflags + wORD_SIZE dflags
+ cmm/CmmLayoutStack.hs view
@@ -0,0 +1,1146 @@+{-# LANGUAGE CPP, RecordWildCards, GADTs #-}+module CmmLayoutStack (+       cmmLayoutStack, setInfoTableStackMap+  ) where++import StgCmmUtils      ( callerSaveVolatileRegs ) -- XXX layering violation+import StgCmmForeign    ( saveThreadState, loadThreadState ) -- XXX layering violation++import BasicTypes+import Cmm+import CmmInfo+import BlockId+import CLabel+import CmmUtils+import MkGraph+import ForeignCall+import CmmLive+import CmmProcPoint+import SMRep+import Hoopl+import UniqSupply+import StgCmmUtils      ( newTemp )+import Maybes+import UniqFM+import Util++import DynFlags+import FastString+import Outputable hiding ( isEmpty )+import qualified Data.Set as Set+import Control.Monad.Fix+import Data.Array as Array+import Data.Bits+import Data.List (nub)++import Prelude hiding ((<*>))++#include "HsVersions.h"++{- Note [Stack Layout]++The job of this pass is to++ - replace references to abstract stack Areas with fixed offsets from Sp.++ - replace the CmmHighStackMark constant used in the stack check with+   the maximum stack usage of the proc.++ - save any variables that are live across a call, and reload them as+   necessary.++Before stack allocation, local variables remain live across native+calls (CmmCall{ cmm_cont = Just _ }), and after stack allocation local+variables are clobbered by native calls.++We want to do stack allocation so that as far as possible+ - stack use is minimized, and+ - unnecessary stack saves and loads are avoided.++The algorithm we use is a variant of linear-scan register allocation,+where the stack is our register file.++ - First, we do a liveness analysis, which annotates every block with+   the variables live on entry to the block.++ - We traverse blocks in reverse postorder DFS; that is, we visit at+   least one predecessor of a block before the block itself.  The+   stack layout flowing from the predecessor of the block will+   determine the stack layout on entry to the block.++ - We maintain a data structure++     Map Label StackMap++   which describes the contents of the stack and the stack pointer on+   entry to each block that is a successor of a block that we have+   visited.++ - For each block we visit:++    - Look up the StackMap for this block.++    - If this block is a proc point (or a call continuation, if we+      aren't splitting proc points), emit instructions to reload all+      the live variables from the stack, according to the StackMap.++    - Walk forwards through the instructions:+      - At an assignment  x = Sp[loc]+        - Record the fact that Sp[loc] contains x, so that we won't+          need to save x if it ever needs to be spilled.+      - At an assignment  x = E+        - If x was previously on the stack, it isn't any more+      - At the last node, if it is a call or a jump to a proc point+        - Lay out the stack frame for the call (see setupStackFrame)+        - emit instructions to save all the live variables+        - Remember the StackMaps for all the successors+        - emit an instruction to adjust Sp+      - If the last node is a branch, then the current StackMap is the+        StackMap for the successors.++    - Manifest Sp: replace references to stack areas in this block+      with real Sp offsets. We cannot do this until we have laid out+      the stack area for the successors above.++      In this phase we also eliminate redundant stores to the stack;+      see elimStackStores.++  - There is one important gotcha: sometimes we'll encounter a control+    transfer to a block that we've already processed (a join point),+    and in that case we might need to rearrange the stack to match+    what the block is expecting. (exactly the same as in linear-scan+    register allocation, except here we have the luxury of an infinite+    supply of temporary variables).++  - Finally, we update the magic CmmHighStackMark constant with the+    stack usage of the function, and eliminate the whole stack check+    if there was no stack use. (in fact this is done as part of the+    main traversal, by feeding the high-water-mark output back in as+    an input. I hate cyclic programming, but it's just too convenient+    sometimes.)++There are plenty of tricky details: update frames, proc points, return+addresses, foreign calls, and some ad-hoc optimisations that are+convenient to do here and effective in common cases.  Comments in the+code below explain these.++-}+++-- All stack locations are expressed as positive byte offsets from the+-- "base", which is defined to be the address above the return address+-- on the stack on entry to this CmmProc.+--+-- Lower addresses have higher StackLocs.+--+type StackLoc = ByteOff++{-+ A StackMap describes the stack at any given point.  At a continuation+ it has a particular layout, like this:++         |             | <- base+         |-------------|+         |     ret0    | <- base + 8+         |-------------|+         .  upd frame  . <- base + sm_ret_off+         |-------------|+         |             |+         .    vars     .+         . (live/dead) .+         |             | <- base + sm_sp - sm_args+         |-------------|+         |    ret1     |+         .  ret vals   . <- base + sm_sp    (<--- Sp points here)+         |-------------|++Why do we include the final return address (ret0) in our stack map?  I+have absolutely no idea, but it seems to be done that way consistently+in the rest of the code generator, so I played along here. --SDM++Note that we will be constructing an info table for the continuation+(ret1), which needs to describe the stack down to, but not including,+the update frame (or ret0, if there is no update frame).+-}++data StackMap = StackMap+ {  sm_sp   :: StackLoc+       -- ^ the offset of Sp relative to the base on entry+       -- to this block.+ ,  sm_args :: ByteOff+       -- ^ the number of bytes of arguments in the area for this block+       -- Defn: the offset of young(L) relative to the base is given by+       -- (sm_sp - sm_args) of the StackMap for block L.+ ,  sm_ret_off :: ByteOff+       -- ^ Number of words of stack that we do not describe with an info+       -- table, because it contains an update frame.+ ,  sm_regs :: UniqFM (LocalReg,StackLoc)+       -- ^ regs on the stack+ }++instance Outputable StackMap where+  ppr StackMap{..} =+     text "Sp = " <> int sm_sp $$+     text "sm_args = " <> int sm_args $$+     text "sm_ret_off = " <> int sm_ret_off $$+     text "sm_regs = " <> pprUFM sm_regs ppr+++cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph+               -> UniqSM (CmmGraph, LabelMap StackMap)+cmmLayoutStack dflags procpoints entry_args+               graph@(CmmGraph { g_entry = entry })+  = do+    -- We need liveness info. Dead assignments are removed later+    -- by the sinking pass.+    let liveness = cmmLocalLiveness dflags graph+        blocks = postorderDfs graph++    (final_stackmaps, _final_high_sp, new_blocks) <-+          mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) ->+            layout dflags procpoints liveness entry entry_args+                   rec_stackmaps rec_high_sp blocks++    new_blocks' <- mapM (lowerSafeForeignCall dflags) new_blocks+    return (ofBlockList entry new_blocks', final_stackmaps)+++layout :: DynFlags+       -> LabelSet                      -- proc points+       -> LabelMap CmmLocalLive         -- liveness+       -> BlockId                       -- entry+       -> ByteOff                       -- stack args on entry++       -> LabelMap StackMap             -- [final] stack maps+       -> ByteOff                       -- [final] Sp high water mark++       -> [CmmBlock]                    -- [in] blocks++       -> UniqSM+          ( LabelMap StackMap           -- [out] stack maps+          , ByteOff                     -- [out] Sp high water mark+          , [CmmBlock]                  -- [out] new blocks+          )++layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high blocks+  = go blocks init_stackmap entry_args []+  where+    (updfr, cont_info)  = collectContInfo blocks++    init_stackmap = mapSingleton entry StackMap{ sm_sp   = entry_args+                                               , sm_args = entry_args+                                               , sm_ret_off = updfr+                                               , sm_regs = emptyUFM+                                               }++    go [] acc_stackmaps acc_hwm acc_blocks+      = return (acc_stackmaps, acc_hwm, acc_blocks)++    go (b0 : bs) acc_stackmaps acc_hwm acc_blocks+      = do+       let (entry0@(CmmEntry entry_lbl tscope), middle0, last0) = blockSplit b0++       let stack0@StackMap { sm_sp = sp0 }+               = mapFindWithDefault+                     (pprPanic "no stack map for" (ppr entry_lbl))+                     entry_lbl acc_stackmaps++       -- (a) Update the stack map to include the effects of+       --     assignments in this block+       let stack1 = foldBlockNodesF (procMiddle acc_stackmaps) middle0 stack0++       -- (b) Insert assignments to reload all the live variables if this+       --     block is a proc point+       let middle1 = if entry_lbl `setMember` procpoints+                        then foldr blockCons middle0 (insertReloads stack0)+                        else middle0++       -- (c) Look at the last node and if we are making a call or+       --     jumping to a proc point, we must save the live+       --     variables, adjust Sp, and construct the StackMaps for+       --     each of the successor blocks.  See handleLastNode for+       --     details.+       (middle2, sp_off, last1, fixup_blocks, out)+           <- handleLastNode dflags procpoints liveness cont_info+                             acc_stackmaps stack1 tscope middle0 last0++       -- (d) Manifest Sp: run over the nodes in the block and replace+       --     CmmStackSlot with CmmLoad from Sp with a concrete offset.+       --+       -- our block:+       --    middle1          -- the original middle nodes+       --    middle2          -- live variable saves from handleLastNode+       --    Sp = Sp + sp_off -- Sp adjustment goes here+       --    last1            -- the last node+       --+       let middle_pre = blockToList $ foldl blockSnoc middle1 middle2++       let final_blocks =+               manifestSp dflags final_stackmaps stack0 sp0 final_sp_high+                          entry0 middle_pre sp_off last1 fixup_blocks++       let acc_stackmaps' = mapUnion acc_stackmaps out++           -- If this block jumps to the GC, then we do not take its+           -- stack usage into account for the high-water mark.+           -- Otherwise, if the only stack usage is in the stack-check+           -- failure block itself, we will do a redundant stack+           -- check.  The stack has a buffer designed to accommodate+           -- the largest amount of stack needed for calling the GC.+           --+           this_sp_hwm | isGcJump last0 = 0+                       | otherwise      = sp0 - sp_off++           hwm' = maximum (acc_hwm : this_sp_hwm : map sm_sp (mapElems out))++       go bs acc_stackmaps' hwm' (final_blocks ++ acc_blocks)+++-- -----------------------------------------------------------------------------++-- Not foolproof, but GCFun is the culprit we most want to catch+isGcJump :: CmmNode O C -> Bool+isGcJump (CmmCall { cml_target = CmmReg (CmmGlobal l) })+  = l == GCFun || l == GCEnter1+isGcJump _something_else = False++-- -----------------------------------------------------------------------------++-- This doesn't seem right somehow.  We need to find out whether this+-- proc will push some update frame material at some point, so that we+-- can avoid using that area of the stack for spilling.  The+-- updfr_space field of the CmmProc *should* tell us, but it doesn't+-- (I think maybe it gets filled in later when we do proc-point+-- splitting).+--+-- So we'll just take the max of all the cml_ret_offs.  This could be+-- unnecessarily pessimistic, but probably not in the code we+-- generate.++collectContInfo :: [CmmBlock] -> (ByteOff, LabelMap ByteOff)+collectContInfo blocks+  = (maximum ret_offs, mapFromList (catMaybes mb_argss))+ where+  (mb_argss, ret_offs) = mapAndUnzip get_cont blocks++  get_cont :: Block CmmNode x C -> (Maybe (Label, ByteOff), ByteOff)+  get_cont b =+     case lastNode b of+        CmmCall { cml_cont = Just l, .. }+           -> (Just (l, cml_ret_args), cml_ret_off)+        CmmForeignCall { .. }+           -> (Just (succ, ret_args), ret_off)+        _other -> (Nothing, 0)+++-- -----------------------------------------------------------------------------+-- Updating the StackMap from middle nodes++-- Look for loads from stack slots, and update the StackMap.  This is+-- purely for optimisation reasons, so that we can avoid saving a+-- variable back to a different stack slot if it is already on the+-- stack.+--+-- This happens a lot: for example when function arguments are passed+-- on the stack and need to be immediately saved across a call, we+-- want to just leave them where they are on the stack.+--+procMiddle :: LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap+procMiddle stackmaps node sm+  = case node of+     CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot area off) _)+       -> sm { sm_regs = addToUFM (sm_regs sm) r (r,loc) }+        where loc = getStackLoc area off stackmaps+     CmmAssign (CmmLocal r) _other+       -> sm { sm_regs = delFromUFM (sm_regs sm) r }+     _other+       -> sm++getStackLoc :: Area -> ByteOff -> LabelMap StackMap -> StackLoc+getStackLoc Old       n _         = n+getStackLoc (Young l) n stackmaps =+  case mapLookup l stackmaps of+    Nothing -> pprPanic "getStackLoc" (ppr l)+    Just sm -> sm_sp sm - sm_args sm + n+++-- -----------------------------------------------------------------------------+-- Handling stack allocation for a last node++-- We take a single last node and turn it into:+--+--    C1 (some statements)+--    Sp = Sp + N+--    C2 (some more statements)+--    call f()          -- the actual last node+--+-- plus possibly some more blocks (we may have to add some fixup code+-- between the last node and the continuation).+--+-- C1: is the code for saving the variables across this last node onto+-- the stack, if the continuation is a call or jumps to a proc point.+--+-- C2: if the last node is a safe foreign call, we have to inject some+-- extra code that goes *after* the Sp adjustment.++handleLastNode+   :: DynFlags -> ProcPointSet -> LabelMap CmmLocalLive -> LabelMap ByteOff+   -> LabelMap StackMap -> StackMap -> CmmTickScope+   -> Block CmmNode O O+   -> CmmNode O C+   -> UniqSM+      ( [CmmNode O O]      -- nodes to go *before* the Sp adjustment+      , ByteOff            -- amount to adjust Sp+      , CmmNode O C        -- new last node+      , [CmmBlock]         -- new blocks+      , LabelMap StackMap  -- stackmaps for the continuations+      )++handleLastNode dflags procpoints liveness cont_info stackmaps+               stack0@StackMap { sm_sp = sp0 } tscp middle last+ = case last of+    --  At each return / tail call,+    --  adjust Sp to point to the last argument pushed, which+    --  is cml_args, after popping any other junk from the stack.+    CmmCall{ cml_cont = Nothing, .. } -> do+      let sp_off = sp0 - cml_args+      return ([], sp_off, last, [], mapEmpty)++    --  At each CmmCall with a continuation:+    CmmCall{ cml_cont = Just cont_lbl, .. } ->+       return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off++    CmmForeignCall{ succ = cont_lbl, .. } -> do+       return $ lastCall cont_lbl (wORD_SIZE dflags) ret_args ret_off+            -- one word of args: the return address++    CmmBranch {}     ->  handleBranches+    CmmCondBranch {} ->  handleBranches+    CmmSwitch {}     ->  handleBranches++  where+     -- Calls and ForeignCalls are handled the same way:+     lastCall :: BlockId -> ByteOff -> ByteOff -> ByteOff+              -> ( [CmmNode O O]+                 , ByteOff+                 , CmmNode O C+                 , [CmmBlock]+                 , LabelMap StackMap+                 )+     lastCall lbl cml_args cml_ret_args cml_ret_off+      =  ( assignments+         , spOffsetForCall sp0 cont_stack cml_args+         , last+         , [] -- no new blocks+         , mapSingleton lbl cont_stack )+      where+         (assignments, cont_stack) = prepareStack lbl cml_ret_args cml_ret_off+++     prepareStack lbl cml_ret_args cml_ret_off+       | Just cont_stack <- mapLookup lbl stackmaps+             -- If we have already seen this continuation before, then+             -- we just have to make the stack look the same:+       = (fixupStack stack0 cont_stack, cont_stack)+             -- Otherwise, we have to allocate the stack frame+       | otherwise+       = (save_assignments, new_cont_stack)+       where+        (new_cont_stack, save_assignments)+           = setupStackFrame dflags lbl liveness cml_ret_off cml_ret_args stack0+++     -- For other last nodes (branches), if any of the targets is a+     -- proc point, we have to set up the stack to match what the proc+     -- point is expecting.+     --+     handleBranches :: UniqSM ( [CmmNode O O]+                                , ByteOff+                                , CmmNode O C+                                , [CmmBlock]+                                , LabelMap StackMap )++     handleBranches+         -- Note [diamond proc point]+       | Just l <- futureContinuation middle+       , (nub $ filter (`setMember` procpoints) $ successors last) == [l]+       = do+         let cont_args = mapFindWithDefault 0 l cont_info+             (assigs, cont_stack) = prepareStack l cont_args (sm_ret_off stack0)+             out = mapFromList [ (l', cont_stack)+                               | l' <- successors last ]+         return ( assigs+                , spOffsetForCall sp0 cont_stack (wORD_SIZE dflags)+                , last+                , []+                , out)++        | otherwise = do+          pps <- mapM handleBranch (successors last)+          let lbl_map :: LabelMap Label+              lbl_map = mapFromList [ (l,tmp) | (l,tmp,_,_) <- pps ]+              fix_lbl l = mapFindWithDefault l l lbl_map+          return ( []+                 , 0+                 , mapSuccessors fix_lbl last+                 , concat [ blk | (_,_,_,blk) <- pps ]+                 , mapFromList [ (l, sm) | (l,_,sm,_) <- pps ] )++     -- For each successor of this block+     handleBranch :: BlockId -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])+     handleBranch l+        --   (a) if the successor already has a stackmap, we need to+        --       shuffle the current stack to make it look the same.+        --       We have to insert a new block to make this happen.+        | Just stack2 <- mapLookup l stackmaps+        = do+             let assigs = fixupStack stack0 stack2+             (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs+             return (l, tmp_lbl, stack2, block)++        --   (b) if the successor is a proc point, save everything+        --       on the stack.+        | l `setMember` procpoints+        = do+             let cont_args = mapFindWithDefault 0 l cont_info+                 (stack2, assigs) =+                      setupStackFrame dflags l liveness (sm_ret_off stack0)+                                                        cont_args stack0+             (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs+             return (l, tmp_lbl, stack2, block)++        --   (c) otherwise, the current StackMap is the StackMap for+        --       the continuation.  But we must remember to remove any+        --       variables from the StackMap that are *not* live at+        --       the destination, because this StackMap might be used+        --       by fixupStack if this is a join point.+        | otherwise = return (l, l, stack1, [])+        where live = mapFindWithDefault (panic "handleBranch") l liveness+              stack1 = stack0 { sm_regs = filterUFM is_live (sm_regs stack0) }+              is_live (r,_) = r `elemRegSet` live+++makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap+               -> CmmTickScope -> [CmmNode O O]+               -> UniqSM (Label, [CmmBlock])+makeFixupBlock dflags sp0 l stack tscope assigs+  | null assigs && sp0 == sm_sp stack = return (l, [])+  | otherwise = do+    tmp_lbl <- newBlockId+    let sp_off = sp0 - sm_sp stack+        maybeAddUnwind block+          | debugLevel dflags > 0+          = block `blockSnoc` CmmUnwind [(Sp, Just unwind_val)]+          | otherwise+          = block+          where unwind_val = cmmOffset dflags (CmmReg spReg) (sm_sp stack)+        block = blockJoin (CmmEntry tmp_lbl tscope)+                          (  maybeAddSpAdj dflags sp_off+                           $ maybeAddUnwind+                           $ blockFromList assigs )+                          (CmmBranch l)+    return (tmp_lbl, [block])+++-- Sp is currently pointing to current_sp,+-- we want it to point to+--    (sm_sp cont_stack - sm_args cont_stack + args)+-- so the difference is+--    sp0 - (sm_sp cont_stack - sm_args cont_stack + args)+spOffsetForCall :: ByteOff -> StackMap -> ByteOff -> ByteOff+spOffsetForCall current_sp cont_stack args+  = current_sp - (sm_sp cont_stack - sm_args cont_stack + args)+++-- | create a sequence of assignments to establish the new StackMap,+-- given the old StackMap.+fixupStack :: StackMap -> StackMap -> [CmmNode O O]+fixupStack old_stack new_stack = concatMap move new_locs+ where+     old_map  = sm_regs old_stack+     new_locs = stackSlotRegs new_stack++     move (r,n)+       | Just (_,m) <- lookupUFM old_map r, n == m = []+       | otherwise = [CmmStore (CmmStackSlot Old n)+                               (CmmReg (CmmLocal r))]++++setupStackFrame+             :: DynFlags+             -> BlockId                 -- label of continuation+             -> LabelMap CmmLocalLive   -- liveness+             -> ByteOff      -- updfr+             -> ByteOff      -- bytes of return values on stack+             -> StackMap     -- current StackMap+             -> (StackMap, [CmmNode O O])++setupStackFrame dflags lbl liveness updfr_off ret_args stack0+  = (cont_stack, assignments)+  where+      -- get the set of LocalRegs live in the continuation+      live = mapFindWithDefault Set.empty lbl liveness++      -- the stack from the base to updfr_off is off-limits.+      -- our new stack frame contains:+      --   * saved live variables+      --   * the return address [young(C) + 8]+      --   * the args for the call,+      --     which are replaced by the return values at the return+      --     point.++      -- everything up to updfr_off is off-limits+      -- stack1 contains updfr_off, plus everything we need to save+      (stack1, assignments) = allocate dflags updfr_off live stack0++      -- And the Sp at the continuation is:+      --   sm_sp stack1 + ret_args+      cont_stack = stack1{ sm_sp = sm_sp stack1 + ret_args+                         , sm_args = ret_args+                         , sm_ret_off = updfr_off+                         }+++-- -----------------------------------------------------------------------------+-- Note [diamond proc point]+--+-- This special case looks for the pattern we get from a typical+-- tagged case expression:+--+--    Sp[young(L1)] = L1+--    if (R1 & 7) != 0 goto L1 else goto L2+--  L2:+--    call [R1] returns to L1+--  L1: live: {y}+--    x = R1+--+-- If we let the generic case handle this, we get+--+--    Sp[-16] = L1+--    if (R1 & 7) != 0 goto L1a else goto L2+--  L2:+--    Sp[-8] = y+--    Sp = Sp - 16+--    call [R1] returns to L1+--  L1a:+--    Sp[-8] = y+--    Sp = Sp - 16+--    goto L1+--  L1:+--    x = R1+--+-- The code for saving the live vars is duplicated in each branch, and+-- furthermore there is an extra jump in the fast path (assuming L1 is+-- a proc point, which it probably is if there is a heap check).+--+-- So to fix this we want to set up the stack frame before the+-- conditional jump.  How do we know when to do this, and when it is+-- safe?  The basic idea is, when we see the assignment+--+--   Sp[young(L)] = L+--+-- we know that+--   * we are definitely heading for L+--   * there can be no more reads from another stack area, because young(L)+--     overlaps with it.+--+-- We don't necessarily know that everything live at L is live now+-- (some might be assigned between here and the jump to L).  So we+-- simplify and only do the optimisation when we see+--+--   (1) a block containing an assignment of a return address L+--   (2) ending in a branch where one (and only) continuation goes to L,+--       and no other continuations go to proc points.+--+-- then we allocate the stack frame for L at the end of the block,+-- before the branch.+--+-- We could generalise (2), but that would make it a bit more+-- complicated to handle, and this currently catches the common case.++futureContinuation :: Block CmmNode O O -> Maybe BlockId+futureContinuation middle = foldBlockNodesB f middle Nothing+   where f :: CmmNode a b -> Maybe BlockId -> Maybe BlockId+         f (CmmStore (CmmStackSlot (Young l) _) (CmmLit (CmmBlock _))) _+               = Just l+         f _ r = r++-- -----------------------------------------------------------------------------+-- Saving live registers++-- | Given a set of live registers and a StackMap, save all the registers+-- on the stack and return the new StackMap and the assignments to do+-- the saving.+--+allocate :: DynFlags -> ByteOff -> LocalRegSet -> StackMap+         -> (StackMap, [CmmNode O O])+allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0+                                              , sm_regs = regs0 }+ =+   -- we only have to save regs that are not already in a slot+   let to_save = filter (not . (`elemUFM` regs0)) (Set.elems live)+       regs1   = filterUFM (\(r,_) -> elemRegSet r live) regs0+   in++   -- make a map of the stack+   let stack = reverse $ Array.elems $+               accumArray (\_ x -> x) Empty (1, toWords dflags (max sp0 ret_off)) $+                 ret_words ++ live_words+            where ret_words =+                   [ (x, Occupied)+                   | x <- [ 1 .. toWords dflags ret_off] ]+                  live_words =+                   [ (toWords dflags x, Occupied)+                   | (r,off) <- nonDetEltsUFM regs1,+                   -- See Note [Unique Determinism and code generation]+                     let w = localRegBytes dflags r,+                     x <- [ off, off - wORD_SIZE dflags .. off - w + 1] ]+   in++   -- Pass over the stack: find slots to save all the new live variables,+   -- choosing the oldest slots first (hence a foldr).+   let+       save slot ([], stack, n, assigs, regs) -- no more regs to save+          = ([], slot:stack, plusW dflags n 1, assigs, regs)+       save slot (to_save, stack, n, assigs, regs)+          = case slot of+               Occupied ->  (to_save, Occupied:stack, plusW dflags n 1, assigs, regs)+               Empty+                 | Just (stack', r, to_save') <-+                       select_save to_save (slot:stack)+                 -> let assig = CmmStore (CmmStackSlot Old n')+                                         (CmmReg (CmmLocal r))+                        n' = plusW dflags n 1+                   in+                        (to_save', stack', n', assig : assigs, (r,(r,n')):regs)++                 | otherwise+                 -> (to_save, slot:stack, plusW dflags n 1, assigs, regs)++       -- we should do better here: right now we'll fit the smallest first,+       -- but it would make more sense to fit the biggest first.+       select_save :: [LocalReg] -> [StackSlot]+                   -> Maybe ([StackSlot], LocalReg, [LocalReg])+       select_save regs stack = go regs []+         where go []     _no_fit = Nothing+               go (r:rs) no_fit+                 | Just rest <- dropEmpty words stack+                 = Just (replicate words Occupied ++ rest, r, rs++no_fit)+                 | otherwise+                 = go rs (r:no_fit)+                 where words = localRegWords dflags r++       -- fill in empty slots as much as possible+       (still_to_save, save_stack, n, save_assigs, save_regs)+          = foldr save (to_save, [], 0, [], []) stack++       -- push any remaining live vars on the stack+       (push_sp, push_assigs, push_regs)+          = foldr push (n, [], []) still_to_save+          where+              push r (n, assigs, regs)+                = (n', assig : assigs, (r,(r,n')) : regs)+                where+                  n' = n + localRegBytes dflags r+                  assig = CmmStore (CmmStackSlot Old n')+                                   (CmmReg (CmmLocal r))++       trim_sp+          | not (null push_regs) = push_sp+          | otherwise+          = plusW dflags n (- length (takeWhile isEmpty save_stack))++       final_regs = regs1 `addListToUFM` push_regs+                          `addListToUFM` save_regs++   in+  -- XXX should be an assert+   if ( n /= max sp0 ret_off ) then pprPanic "allocate" (ppr n <+> ppr sp0 <+> ppr ret_off) else++   if (trim_sp .&. (wORD_SIZE dflags - 1)) /= 0  then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else++   ( stackmap { sm_regs = final_regs , sm_sp = trim_sp }+   , push_assigs ++ save_assigs )+++-- -----------------------------------------------------------------------------+-- Manifesting Sp++-- | Manifest Sp: turn all the CmmStackSlots into CmmLoads from Sp.  The+-- block looks like this:+--+--    middle_pre       -- the middle nodes+--    Sp = Sp + sp_off -- Sp adjustment goes here+--    last             -- the last node+--+-- And we have some extra blocks too (that don't contain Sp adjustments)+--+-- The adjustment for middle_pre will be different from that for+-- middle_post, because the Sp adjustment intervenes.+--+manifestSp+   :: DynFlags+   -> LabelMap StackMap  -- StackMaps for other blocks+   -> StackMap           -- StackMap for this block+   -> ByteOff            -- Sp on entry to the block+   -> ByteOff            -- SpHigh+   -> CmmNode C O        -- first node+   -> [CmmNode O O]      -- middle+   -> ByteOff            -- sp_off+   -> CmmNode O C        -- last node+   -> [CmmBlock]         -- new blocks+   -> [CmmBlock]         -- final blocks with Sp manifest++manifestSp dflags stackmaps stack0 sp0 sp_high+           first middle_pre sp_off last fixup_blocks+  = final_block : fixup_blocks'+  where+    area_off = getAreaOff stackmaps++    adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x+    adj_pre_sp  = mapExpDeep (areaToSp dflags sp0            sp_high area_off)+    adj_post_sp = mapExpDeep (areaToSp dflags (sp0 - sp_off) sp_high area_off)++    -- Add unwind pseudo-instruction at the beginning of each block to+    -- document Sp level for debugging+    add_initial_unwind block+      | debugLevel dflags > 0+      = CmmUnwind [(Sp, Just sp_unwind)] `blockCons` block+      | otherwise+      = block+      where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags)++    -- Add unwind pseudo-instruction right before the Sp adjustment+    -- if there is one.+    add_adj_unwind block+      | debugLevel dflags > 0+      , sp_off /= 0+      = block `blockSnoc` CmmUnwind [(Sp, Just sp_unwind)]+      | otherwise+      = block+      where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags - sp_off)++    final_middle = maybeAddSpAdj dflags sp_off+                 . add_adj_unwind+                 . add_initial_unwind+                 . blockFromList+                 . map adj_pre_sp+                 . elimStackStores stack0 stackmaps area_off+                 $ middle_pre+    final_last    = optStackCheck (adj_post_sp last)++    final_block   = blockJoin first final_middle final_last++    fixup_blocks' = map (mapBlock3' (id, adj_post_sp, id)) fixup_blocks+++getAreaOff :: LabelMap StackMap -> (Area -> StackLoc)+getAreaOff _ Old = 0+getAreaOff stackmaps (Young l) =+  case mapLookup l stackmaps of+    Just sm -> sm_sp sm - sm_args sm+    Nothing -> pprPanic "getAreaOff" (ppr l)+++maybeAddSpAdj :: DynFlags -> ByteOff -> Block CmmNode O O -> Block CmmNode O O+maybeAddSpAdj _      0      block = block+maybeAddSpAdj dflags sp_off block = block `blockSnoc` adj+  where+    adj = CmmAssign spReg (cmmOffset dflags (CmmReg spReg) sp_off)++{-+Sp(L) is the Sp offset on entry to block L relative to the base of the+OLD area.++SpArgs(L) is the size of the young area for L, i.e. the number of+arguments.++ - in block L, each reference to [old + N] turns into+   [Sp + Sp(L) - N]++ - in block L, each reference to [young(L') + N] turns into+   [Sp + Sp(L) - Sp(L') + SpArgs(L') - N]++ - be careful with the last node of each block: Sp has already been adjusted+   to be Sp + Sp(L) - Sp(L')+-}++areaToSp :: DynFlags -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr++areaToSp dflags sp_old _sp_hwm area_off (CmmStackSlot area n)+  = cmmOffset dflags (CmmReg spReg) (sp_old - area_off area - n)+    -- Replace (CmmStackSlot area n) with an offset from Sp++areaToSp dflags _ sp_hwm _ (CmmLit CmmHighStackMark)+  = mkIntExpr dflags sp_hwm+    -- Replace CmmHighStackMark with the number of bytes of stack used,+    -- the sp_hwm.   See Note [Stack usage] in StgCmmHeap++areaToSp dflags _ _ _ (CmmMachOp (MO_U_Lt _) args)+  | falseStackCheck args+  = zeroExpr dflags+areaToSp dflags _ _ _ (CmmMachOp (MO_U_Ge _) args)+  | falseStackCheck args+  = mkIntExpr dflags 1+    -- Replace a stack-overflow test that cannot fail with a no-op+    -- See Note [Always false stack check]++areaToSp _ _ _ _ other = other++-- | Determine whether a stack check cannot fail.+falseStackCheck :: [CmmExpr] -> Bool+falseStackCheck [ CmmMachOp (MO_Sub _)+                      [ CmmRegOff (CmmGlobal Sp) x_off+                      , CmmLit (CmmInt y_lit _)]+                , CmmReg (CmmGlobal SpLim)]+  = fromIntegral x_off >= y_lit+falseStackCheck _ = False++-- Note [Always false stack check]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- We can optimise stack checks of the form+--+--   if ((Sp + x) - y < SpLim) then .. else ..+--+-- where are non-negative integer byte offsets.  Since we know that+-- SpLim <= Sp (remember the stack grows downwards), this test must+-- yield False if (x >= y), so we can rewrite the comparison to False.+-- A subsequent sinking pass will later drop the dead code.+-- Optimising this away depends on knowing that SpLim <= Sp, so it is+-- really the job of the stack layout algorithm, hence we do it now.+--+-- The control flow optimiser may negate a conditional to increase+-- the likelihood of a fallthrough if the branch is not taken.  But+-- not every conditional is inverted as the control flow optimiser+-- places some requirements on the predecessors of both branch targets.+-- So we better look for the inverted comparison too.++optStackCheck :: CmmNode O C -> CmmNode O C+optStackCheck n = -- Note [Always false stack check]+ case n of+   CmmCondBranch (CmmLit (CmmInt 0 _)) _true false _ -> CmmBranch false+   CmmCondBranch (CmmLit (CmmInt _ _)) true _false _ -> CmmBranch true+   other -> other+++-- -----------------------------------------------------------------------------++-- | Eliminate stores of the form+--+--    Sp[area+n] = r+--+-- when we know that r is already in the same slot as Sp[area+n].  We+-- could do this in a later optimisation pass, but that would involve+-- a separate analysis and we already have the information to hand+-- here.  It helps clean up some extra stack stores in common cases.+--+-- Note that we may have to modify the StackMap as we walk through the+-- code using procMiddle, since an assignment to a variable in the+-- StackMap will invalidate its mapping there.+--+elimStackStores :: StackMap+                -> LabelMap StackMap+                -> (Area -> ByteOff)+                -> [CmmNode O O]+                -> [CmmNode O O]+elimStackStores stackmap stackmaps area_off nodes+  = go stackmap nodes+  where+    go _stackmap [] = []+    go stackmap (n:ns)+     = case n of+         CmmStore (CmmStackSlot area m) (CmmReg (CmmLocal r))+            | Just (_,off) <- lookupUFM (sm_regs stackmap) r+            , area_off area + m == off+            -> go stackmap ns+         _otherwise+            -> n : go (procMiddle stackmaps n stackmap) ns+++-- -----------------------------------------------------------------------------+-- Update info tables to include stack liveness+++setInfoTableStackMap :: DynFlags -> LabelMap StackMap -> CmmDecl -> CmmDecl+setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l v g)+  = CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g+  where+    fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } =+       info_tbl { cit_rep = StackRep (get_liveness lbl) }+    fix_info _ other = other++    get_liveness :: BlockId -> Liveness+    get_liveness lbl+      = case mapLookup lbl stackmaps of+          Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> ppr info_tbls)+          Just sm -> stackMapToLiveness dflags sm++setInfoTableStackMap _ _ d = d+++stackMapToLiveness :: DynFlags -> StackMap -> Liveness+stackMapToLiveness dflags StackMap{..} =+   reverse $ Array.elems $+        accumArray (\_ x -> x) True (toWords dflags sm_ret_off + 1,+                                     toWords dflags (sm_sp - sm_args)) live_words+   where+     live_words =  [ (toWords dflags off, False)+                   | (r,off) <- nonDetEltsUFM sm_regs+                   , isGcPtrType (localRegType r) ]+                   -- See Note [Unique Determinism and code generation]+++-- -----------------------------------------------------------------------------+-- Lowering safe foreign calls++{-+Note [Lower safe foreign calls]++We start with++   Sp[young(L1)] = L1+ ,-----------------------+ | r1 = foo(x,y,z) returns to L1+ '-----------------------+ L1:+   R1 = r1 -- copyIn, inserted by mkSafeCall+   ...++the stack layout algorithm will arrange to save and reload everything+live across the call.  Our job now is to expand the call so we get++   Sp[young(L1)] = L1+ ,-----------------------+ | SAVE_THREAD_STATE()+ | token = suspendThread(BaseReg, interruptible)+ | r = foo(x,y,z)+ | BaseReg = resumeThread(token)+ | LOAD_THREAD_STATE()+ | R1 = r  -- copyOut+ | jump Sp[0]+ '-----------------------+ L1:+   r = R1 -- copyIn, inserted by mkSafeCall+   ...++Note the copyOut, which saves the results in the places that L1 is+expecting them (see Note [safe foreign call convention]). Note also+that safe foreign call is replace by an unsafe one in the Cmm graph.+-}++lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock+lowerSafeForeignCall dflags block+  | (entry@(CmmEntry _ tscp), middle, CmmForeignCall { .. }) <- blockSplit block+  = do+    -- Both 'id' and 'new_base' are KindNonPtr because they're+    -- RTS-only objects and are not subject to garbage collection+    id <- newTemp (bWord dflags)+    new_base <- newTemp (cmmRegType dflags (CmmGlobal BaseReg))+    let (caller_save, caller_load) = callerSaveVolatileRegs dflags+    save_state_code <- saveThreadState dflags+    load_state_code <- loadThreadState dflags+    let suspend = save_state_code  <*>+                  caller_save <*>+                  mkMiddle (callSuspendThread dflags id intrbl)+        midCall = mkUnsafeCall tgt res args+        resume  = mkMiddle (callResumeThread new_base id) <*>+                  -- Assign the result to BaseReg: we+                  -- might now have a different Capability!+                  mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <*>+                  caller_load <*>+                  load_state_code++        (_, regs, copyout) =+             copyOutOflow dflags NativeReturn Jump (Young succ)+                            (map (CmmReg . CmmLocal) res)+                            ret_off []++        -- NB. after resumeThread returns, the top-of-stack probably contains+        -- the stack frame for succ, but it might not: if the current thread+        -- received an exception during the call, then the stack might be+        -- different.  Hence we continue by jumping to the top stack frame,+        -- not by jumping to succ.+        jump = CmmCall { cml_target    = entryCode dflags $+                                         CmmLoad (CmmReg spReg) (bWord dflags)+                       , cml_cont      = Just succ+                       , cml_args_regs = regs+                       , cml_args      = widthInBytes (wordWidth dflags)+                       , cml_ret_args  = ret_args+                       , cml_ret_off   = ret_off }++    graph' <- lgraphOfAGraph ( suspend <*>+                               midCall <*>+                               resume  <*>+                               copyout <*>+                               mkLast jump, tscp)++    case toBlockList graph' of+      [one] -> let (_, middle', last) = blockSplit one+               in return (blockJoin entry (middle `blockAppend` middle') last)+      _ -> panic "lowerSafeForeignCall0"++  -- Block doesn't end in a safe foreign call:+  | otherwise = return block+++foreignLbl :: FastString -> CmmExpr+foreignLbl name = CmmLit (CmmLabel (mkForeignLabel name Nothing ForeignLabelInExternalPackage IsFunction))++callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O+callSuspendThread dflags id intrbl =+  CmmUnsafeForeignCall+       (ForeignTarget (foreignLbl (fsLit "suspendThread"))+        (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn))+       [id] [CmmReg (CmmGlobal BaseReg), mkIntExpr dflags (fromEnum intrbl)]++callResumeThread :: LocalReg -> LocalReg -> CmmNode O O+callResumeThread new_base id =+  CmmUnsafeForeignCall+       (ForeignTarget (foreignLbl (fsLit "resumeThread"))+            (ForeignConvention CCallConv [AddrHint] [AddrHint] CmmMayReturn))+       [new_base] [CmmReg (CmmLocal id)]++-- -----------------------------------------------------------------------------++plusW :: DynFlags -> ByteOff -> WordOff -> ByteOff+plusW dflags b w = b + w * wORD_SIZE dflags++data StackSlot = Occupied | Empty+     -- Occupied: a return address or part of an update frame++instance Outputable StackSlot where+  ppr Occupied = text "XXX"+  ppr Empty    = text "---"++dropEmpty :: WordOff -> [StackSlot] -> Maybe [StackSlot]+dropEmpty 0 ss           = Just ss+dropEmpty n (Empty : ss) = dropEmpty (n-1) ss+dropEmpty _ _            = Nothing++isEmpty :: StackSlot -> Bool+isEmpty Empty = True+isEmpty _ = False++localRegBytes :: DynFlags -> LocalReg -> ByteOff+localRegBytes dflags r+    = roundUpToWords dflags (widthInBytes (typeWidth (localRegType r)))++localRegWords :: DynFlags -> LocalReg -> WordOff+localRegWords dflags = toWords dflags . localRegBytes dflags++toWords :: DynFlags -> ByteOff -> WordOff+toWords dflags x = x `quot` wORD_SIZE dflags+++insertReloads :: StackMap -> [CmmNode O O]+insertReloads stackmap =+   [ CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot Old sp)+                                     (localRegType r))+   | (r,sp) <- stackSlotRegs stackmap+   ]+++stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)]+stackSlotRegs sm = nonDetEltsUFM (sm_regs sm)+  -- See Note [Unique Determinism and code generation]
+ cmm/CmmLex.x view
@@ -0,0 +1,363 @@+-----------------------------------------------------------------------------+--+-- (c) The University of Glasgow, 2004-2006+--+-- Lexer for concrete Cmm.  We try to stay close to the C-- spec, but there+-- are a few minor differences:+--+--   * extra keywords for our macros, and float32/float64 types+--   * global registers (Sp,Hp, etc.)+--+-----------------------------------------------------------------------------++{+-- See Note [Warnings in code generated by Alex] in compiler/parser/Lexer.x+{-# OPTIONS_GHC -fno-warn-unused-matches #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module CmmLex (+   CmmToken(..), cmmlex,+  ) where++import CmmExpr++import Lexer+import CmmMonad+import SrcLoc+import UniqFM+import StringBuffer+import FastString+import Ctype+import Util+--import TRACE++import Data.Word+import Data.Char+}++$whitechar   = [\ \t\n\r\f\v\xa0] -- \xa0 is Unicode no-break space+$white_no_nl = $whitechar # \n++$ascdigit  = 0-9+$unidigit  = \x01 -- Trick Alex into handling Unicode. See alexGetChar.+$digit     = [$ascdigit $unidigit]+$octit     = 0-7+$hexit     = [$digit A-F a-f]++$unilarge  = \x03 -- Trick Alex into handling Unicode. See alexGetChar.+$asclarge  = [A-Z \xc0-\xd6 \xd8-\xde]+$large     = [$asclarge $unilarge]++$unismall  = \x04 -- Trick Alex into handling Unicode. See alexGetChar.+$ascsmall  = [a-z \xdf-\xf6 \xf8-\xff]+$small     = [$ascsmall $unismall \_]++$namebegin = [$large $small \. \$ \@]+$namechar  = [$namebegin $digit]++@decimal     = $digit++@octal       = $octit++@hexadecimal = $hexit++@exponent    = [eE] [\-\+]? @decimal++@floating_point = @decimal \. @decimal @exponent? | @decimal @exponent++@escape      = \\ ([abfnrt\\\'\"\?] | x $hexit{1,2} | $octit{1,3})+@strchar     = ($printable # [\"\\]) | @escape++cmm :-++$white_no_nl+           ;+^\# pragma .* \n        ; -- Apple GCC 3.3 CPP generates pragmas in its output++^\# (line)?             { begin line_prag }++-- single-line line pragmas, of the form+--    # <line> "<file>" <extra-stuff> \n+<line_prag> $digit+                     { setLine line_prag1 }+<line_prag1> \" [^\"]* \"       { setFile line_prag2 }+<line_prag2> .*                         { pop }++<0> {+  \n                    ;++  [\:\;\{\}\[\]\(\)\=\`\~\/\*\%\-\+\&\^\|\>\<\,\!]      { special_char }++  ".."                  { kw CmmT_DotDot }+  "::"                  { kw CmmT_DoubleColon }+  ">>"                  { kw CmmT_Shr }+  "<<"                  { kw CmmT_Shl }+  ">="                  { kw CmmT_Ge }+  "<="                  { kw CmmT_Le }+  "=="                  { kw CmmT_Eq }+  "!="                  { kw CmmT_Ne }+  "&&"                  { kw CmmT_BoolAnd }+  "||"                  { kw CmmT_BoolOr }++  P@decimal             { global_regN (\n -> VanillaReg n VGcPtr) }+  R@decimal             { global_regN (\n -> VanillaReg n VNonGcPtr) }+  F@decimal             { global_regN FloatReg }+  D@decimal             { global_regN DoubleReg }+  L@decimal             { global_regN LongReg }+  Sp                    { global_reg Sp }+  SpLim                 { global_reg SpLim }+  Hp                    { global_reg Hp }+  HpLim                 { global_reg HpLim }+  CCCS                  { global_reg CCCS }+  CurrentTSO            { global_reg CurrentTSO }+  CurrentNursery        { global_reg CurrentNursery }+  HpAlloc               { global_reg HpAlloc }+  BaseReg               { global_reg BaseReg }+  MachSp                { global_reg MachSp }+  UnwindReturnReg       { global_reg UnwindReturnReg }++  $namebegin $namechar* { name }++  0 @octal              { tok_octal }+  @decimal              { tok_decimal }+  0[xX] @hexadecimal    { tok_hexadecimal }+  @floating_point       { strtoken tok_float }++  \" @strchar* \"       { strtoken tok_string }+}++{+data CmmToken+  = CmmT_SpecChar  Char+  | CmmT_DotDot+  | CmmT_DoubleColon+  | CmmT_Shr+  | CmmT_Shl+  | CmmT_Ge+  | CmmT_Le+  | CmmT_Eq+  | CmmT_Ne+  | CmmT_BoolAnd+  | CmmT_BoolOr+  | CmmT_CLOSURE+  | CmmT_INFO_TABLE+  | CmmT_INFO_TABLE_RET+  | CmmT_INFO_TABLE_FUN+  | CmmT_INFO_TABLE_CONSTR+  | CmmT_INFO_TABLE_SELECTOR+  | CmmT_else+  | CmmT_export+  | CmmT_section+  | CmmT_goto+  | CmmT_if+  | CmmT_call+  | CmmT_jump+  | CmmT_foreign+  | CmmT_never+  | CmmT_prim+  | CmmT_reserve+  | CmmT_return+  | CmmT_returns+  | CmmT_import+  | CmmT_switch+  | CmmT_case+  | CmmT_default+  | CmmT_push+  | CmmT_unwind+  | CmmT_bits8+  | CmmT_bits16+  | CmmT_bits32+  | CmmT_bits64+  | CmmT_bits128+  | CmmT_bits256+  | CmmT_bits512+  | CmmT_float32+  | CmmT_float64+  | CmmT_gcptr+  | CmmT_GlobalReg GlobalReg+  | CmmT_Name      FastString+  | CmmT_String    String+  | CmmT_Int       Integer+  | CmmT_Float     Rational+  | CmmT_EOF+  deriving (Show)++-- -----------------------------------------------------------------------------+-- Lexer actions++type Action = RealSrcSpan -> StringBuffer -> Int -> PD (RealLocated CmmToken)++begin :: Int -> Action+begin code _span _str _len = do liftP (pushLexState code); lexToken++pop :: Action+pop _span _buf _len = liftP popLexState >> lexToken++special_char :: Action+special_char span buf _len = return (L span (CmmT_SpecChar (currentChar buf)))++kw :: CmmToken -> Action+kw tok span _buf _len = return (L span tok)++global_regN :: (Int -> GlobalReg) -> Action+global_regN con span buf len+  = return (L span (CmmT_GlobalReg (con (fromIntegral n))))+  where buf' = stepOn buf+        n = parseUnsignedInteger buf' (len-1) 10 octDecDigit++global_reg :: GlobalReg -> Action+global_reg r span _buf _len = return (L span (CmmT_GlobalReg r))++strtoken :: (String -> CmmToken) -> Action+strtoken f span buf len =+  return (L span $! (f $! lexemeToString buf len))++name :: Action+name span buf len =+  case lookupUFM reservedWordsFM fs of+        Just tok -> return (L span tok)+        Nothing  -> return (L span (CmmT_Name fs))+  where+        fs = lexemeToFastString buf len++reservedWordsFM = listToUFM $+        map (\(x, y) -> (mkFastString x, y)) [+        ( "CLOSURE",            CmmT_CLOSURE ),+        ( "INFO_TABLE",         CmmT_INFO_TABLE ),+        ( "INFO_TABLE_RET",     CmmT_INFO_TABLE_RET ),+        ( "INFO_TABLE_FUN",     CmmT_INFO_TABLE_FUN ),+        ( "INFO_TABLE_CONSTR",  CmmT_INFO_TABLE_CONSTR ),+        ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ),+        ( "else",               CmmT_else ),+        ( "export",             CmmT_export ),+        ( "section",            CmmT_section ),+        ( "goto",               CmmT_goto ),+        ( "if",                 CmmT_if ),+        ( "call",               CmmT_call ),+        ( "jump",               CmmT_jump ),+        ( "foreign",            CmmT_foreign ),+        ( "never",              CmmT_never ),+        ( "prim",               CmmT_prim ),+        ( "reserve",            CmmT_reserve ),+        ( "return",             CmmT_return ),+        ( "returns",            CmmT_returns ),+        ( "import",             CmmT_import ),+        ( "switch",             CmmT_switch ),+        ( "case",               CmmT_case ),+        ( "default",            CmmT_default ),+        ( "push",               CmmT_push ),+        ( "unwind",             CmmT_unwind ),+        ( "bits8",              CmmT_bits8 ),+        ( "bits16",             CmmT_bits16 ),+        ( "bits32",             CmmT_bits32 ),+        ( "bits64",             CmmT_bits64 ),+        ( "bits128",            CmmT_bits128 ),+        ( "bits256",            CmmT_bits256 ),+        ( "bits512",            CmmT_bits512 ),+        ( "float32",            CmmT_float32 ),+        ( "float64",            CmmT_float64 ),+-- New forms+        ( "b8",                 CmmT_bits8 ),+        ( "b16",                CmmT_bits16 ),+        ( "b32",                CmmT_bits32 ),+        ( "b64",                CmmT_bits64 ),+        ( "b128",               CmmT_bits128 ),+        ( "b256",               CmmT_bits256 ),+        ( "b512",               CmmT_bits512 ),+        ( "f32",                CmmT_float32 ),+        ( "f64",                CmmT_float64 ),+        ( "gcptr",              CmmT_gcptr )+        ]++tok_decimal span buf len+  = return (L span (CmmT_Int  $! parseUnsignedInteger buf len 10 octDecDigit))++tok_octal span buf len+  = return (L span (CmmT_Int  $! parseUnsignedInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit))++tok_hexadecimal span buf len+  = return (L span (CmmT_Int  $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 16 hexDigit))++tok_float str = CmmT_Float $! readRational str++tok_string str = CmmT_String (read str)+                 -- urk, not quite right, but it'll do for now++-- -----------------------------------------------------------------------------+-- Line pragmas++setLine :: Int -> Action+setLine code span buf len = do+  let line = parseUnsignedInteger buf len 10 octDecDigit+  liftP $ do+    setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)+          -- subtract one: the line number refers to the *following* line+    -- trace ("setLine "  ++ show line) $ do+    popLexState >> pushLexState code+  lexToken++setFile :: Int -> Action+setFile code span buf len = do+  let file = lexemeToFastString (stepOn buf) (len-2)+  liftP $ do+    setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))+    popLexState >> pushLexState code+  lexToken++-- -----------------------------------------------------------------------------+-- This is the top-level function: called from the parser each time a+-- new token is to be read from the input.++cmmlex :: (Located CmmToken -> PD a) -> PD a+cmmlex cont = do+  (L span tok) <- lexToken+  --trace ("token: " ++ show tok) $ do+  cont (L (RealSrcSpan span) tok)++lexToken :: PD (RealLocated CmmToken)+lexToken = do+  inp@(loc1,buf) <- getInput+  sc <- liftP getLexState+  case alexScan inp sc of+    AlexEOF -> do let span = mkRealSrcSpan loc1 loc1+                  liftP (setLastToken span 0)+                  return (L span CmmT_EOF)+    AlexError (loc2,_) -> liftP $ failLocMsgP loc1 loc2 "lexical error"+    AlexSkip inp2 _ -> do+        setInput inp2+        lexToken+    AlexToken inp2@(end,_buf2) len t -> do+        setInput inp2+        let span = mkRealSrcSpan loc1 end+        span `seq` liftP (setLastToken span len)+        t span buf len++-- -----------------------------------------------------------------------------+-- Monad stuff++-- Stuff that Alex needs to know about our input type:+type AlexInput = (RealSrcLoc,StringBuffer)++alexInputPrevChar :: AlexInput -> Char+alexInputPrevChar (_,s) = prevChar s '\n'++-- backwards compatibility for Alex 2.x+alexGetChar :: AlexInput -> Maybe (Char,AlexInput)+alexGetChar inp = case alexGetByte inp of+                    Nothing    -> Nothing+                    Just (b,i) -> c `seq` Just (c,i)+                       where c = chr $ fromIntegral b++alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)+alexGetByte (loc,s)+  | atEnd s   = Nothing+  | otherwise = b `seq` loc' `seq` s' `seq` Just (b, (loc', s'))+  where c    = currentChar s+        b    = fromIntegral $ ord $ c+        loc' = advanceSrcLoc loc c+        s'   = stepOn s++getInput :: PD AlexInput+getInput = PD $ \_ s@PState{ loc=l, buffer=b } -> POk s (l,b)++setInput :: AlexInput -> PD ()+setInput (l,b) = PD $ \_ s -> POk s{ loc=l, buffer=b } ()+}
+ cmm/CmmLint.hs view
@@ -0,0 +1,257 @@+-----------------------------------------------------------------------------+--+-- (c) The University of Glasgow 2011+--+-- CmmLint: checking the correctness of Cmm statements and expressions+--+-----------------------------------------------------------------------------+{-# LANGUAGE GADTs #-}+module CmmLint (+    cmmLint, cmmLintGraph+  ) where++import Hoopl+import Cmm+import CmmUtils+import CmmLive+import CmmSwitch (switchTargetsToList)+import PprCmm ()+import Outputable+import DynFlags++import Control.Monad (liftM, ap)++-- Things to check:+--     - invariant on CmmBlock in CmmExpr (see comment there)+--     - check for branches to blocks that don't exist+--     - check types++-- -----------------------------------------------------------------------------+-- Exported entry points:++cmmLint :: (Outputable d, Outputable h)+        => DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc+cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops++cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc+cmmLintGraph dflags g = runCmmLint dflags (lintCmmGraph dflags) g++runCmmLint :: Outputable a => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc+runCmmLint dflags l p =+   case unCL (l p) dflags of+     Left err -> Just (vcat [text "Cmm lint error:",+                             nest 2 err,+                             text "Program was:",+                             nest 2 (ppr p)])+     Right _  -> Nothing++lintCmmDecl :: DynFlags -> GenCmmDecl h i CmmGraph -> CmmLint ()+lintCmmDecl dflags (CmmProc _ lbl _ g)+  = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph dflags g+lintCmmDecl _ (CmmData {})+  = return ()+++lintCmmGraph :: DynFlags -> CmmGraph -> CmmLint ()+lintCmmGraph dflags g =+    cmmLocalLiveness dflags g `seq` mapM_ (lintCmmBlock labels) blocks+    -- cmmLiveness throws an error if there are registers+    -- live on entry to the graph (i.e. undefined+    -- variables)+  where+       blocks = toBlockList g+       labels = setFromList (map entryLabel blocks)+++lintCmmBlock :: LabelSet -> CmmBlock -> CmmLint ()+lintCmmBlock labels block+  = addLintInfo (text "in basic block " <> ppr (entryLabel block)) $ do+        let (_, middle, last) = blockSplit block+        mapM_ lintCmmMiddle (blockToList middle)+        lintCmmLast labels last++-- -----------------------------------------------------------------------------+-- lintCmmExpr++-- Checks whether a CmmExpr is "type-correct", and check for obvious-looking+-- byte/word mismatches.++lintCmmExpr :: CmmExpr -> CmmLint CmmType+lintCmmExpr (CmmLoad expr rep) = do+  _ <- lintCmmExpr expr+  -- Disabled, if we have the inlining phase before the lint phase,+  -- we can have funny offsets due to pointer tagging. -- EZY+  -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $+  --   cmmCheckWordAddress expr+  return rep+lintCmmExpr expr@(CmmMachOp op args) = do+  dflags <- getDynFlags+  tys <- mapM lintCmmExpr args+  if map (typeWidth . cmmExprType dflags) args == machOpArgReps dflags op+        then cmmCheckMachOp op args tys+        else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps dflags op)+lintCmmExpr (CmmRegOff reg offset)+  = do dflags <- getDynFlags+       let rep = typeWidth (cmmRegType dflags reg)+       lintCmmExpr (CmmMachOp (MO_Add rep)+                [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])+lintCmmExpr expr =+  do dflags <- getDynFlags+     return (cmmExprType dflags expr)++-- Check for some common byte/word mismatches (eg. Sp + 1)+cmmCheckMachOp   :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType+cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys+  = cmmCheckMachOp op [reg, lit] tys+cmmCheckMachOp op _ tys+  = do dflags <- getDynFlags+       return (machOpResultType dflags op tys)++{-+isOffsetOp :: MachOp -> Bool+isOffsetOp (MO_Add _) = True+isOffsetOp (MO_Sub _) = True+isOffsetOp _ = False++-- This expression should be an address from which a word can be loaded:+-- check for funny-looking sub-word offsets.+_cmmCheckWordAddress :: CmmExpr -> CmmLint ()+_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])+  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0+  = cmmLintDubiousWordOffset e+_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])+  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0+  = cmmLintDubiousWordOffset e+_cmmCheckWordAddress _+  = return ()++-- No warnings for unaligned arithmetic with the node register,+-- which is used to extract fields from tagged constructor closures.+notNodeReg :: CmmExpr -> Bool+notNodeReg (CmmReg reg) | reg == nodeReg = False+notNodeReg _                             = True+-}++lintCmmMiddle :: CmmNode O O -> CmmLint ()+lintCmmMiddle node = case node of+  CmmComment _ -> return ()+  CmmTick _    -> return ()+  CmmUnwind{}  -> return ()++  CmmAssign reg expr -> do+            dflags <- getDynFlags+            erep <- lintCmmExpr expr+            let reg_ty = cmmRegType dflags reg+            if (erep `cmmEqType_ignoring_ptrhood` reg_ty)+                then return ()+                else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty++  CmmStore l r -> do+            _ <- lintCmmExpr l+            _ <- lintCmmExpr r+            return ()++  CmmUnsafeForeignCall target _formals actuals -> do+            lintTarget target+            mapM_ lintCmmExpr actuals+++lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint ()+lintCmmLast labels node = case node of+  CmmBranch id -> checkTarget id++  CmmCondBranch e t f _ -> do+            dflags <- getDynFlags+            mapM_ checkTarget [t,f]+            _ <- lintCmmExpr e+            checkCond dflags e++  CmmSwitch e ids -> do+            dflags <- getDynFlags+            mapM_ checkTarget $ switchTargetsToList ids+            erep <- lintCmmExpr e+            if (erep `cmmEqType_ignoring_ptrhood` bWord dflags)+              then return ()+              else cmmLintErr (text "switch scrutinee is not a word: " <>+                               ppr e <> text " :: " <> ppr erep)++  CmmCall { cml_target = target, cml_cont = cont } -> do+          _ <- lintCmmExpr target+          maybe (return ()) checkTarget cont++  CmmForeignCall tgt _ args succ _ _ _ -> do+          lintTarget tgt+          mapM_ lintCmmExpr args+          checkTarget succ+ where+  checkTarget id+     | setMember id labels = return ()+     | otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id)+++lintTarget :: ForeignTarget -> CmmLint ()+lintTarget (ForeignTarget e _) = lintCmmExpr e >> return ()+lintTarget (PrimTarget {})     = return ()+++checkCond :: DynFlags -> CmmExpr -> CmmLint ()+checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()+checkCond dflags (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth dflags = return () -- constant values+checkCond _ expr+    = cmmLintErr (hang (text "expression is not a conditional:") 2+                         (ppr expr))++-- -----------------------------------------------------------------------------+-- CmmLint monad++-- just a basic error monad:++newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a }++instance Functor CmmLint where+      fmap = liftM++instance Applicative CmmLint where+      pure a = CmmLint (\_ -> Right a)+      (<*>) = ap++instance Monad CmmLint where+  CmmLint m >>= k = CmmLint $ \dflags ->+                                case m dflags of+                                Left e -> Left e+                                Right a -> unCL (k a) dflags++instance HasDynFlags CmmLint where+    getDynFlags = CmmLint (\dflags -> Right dflags)++cmmLintErr :: SDoc -> CmmLint a+cmmLintErr msg = CmmLint (\_ -> Left msg)++addLintInfo :: SDoc -> CmmLint a -> CmmLint a+addLintInfo info thing = CmmLint $ \dflags ->+   case unCL thing dflags of+        Left err -> Left (hang info 2 err)+        Right a  -> Right a++cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a+cmmLintMachOpErr expr argsRep opExpectsRep+     = cmmLintErr (text "in MachOp application: " $$+                   nest 2 (ppr  expr) $$+                      (text "op is expecting: " <+> ppr opExpectsRep) $$+                      (text "arguments provide: " <+> ppr argsRep))++cmmLintAssignErr :: CmmNode e x -> CmmType -> CmmType -> CmmLint a+cmmLintAssignErr stmt e_ty r_ty+  = cmmLintErr (text "in assignment: " $$+                nest 2 (vcat [ppr stmt,+                              text "Reg ty:" <+> ppr r_ty,+                              text "Rhs ty:" <+> ppr e_ty]))+++{-+cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a+cmmLintDubiousWordOffset expr+   = cmmLintErr (text "offset is not a multiple of words: " $$+                 nest 2 (ppr expr))+-}+
+ cmm/CmmLive.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}++module CmmLive+    ( CmmLocalLive+    , cmmLocalLiveness+    , cmmGlobalLiveness+    , liveLattice+    , gen_kill+    )+where++import DynFlags+import BlockId+import Cmm+import PprCmmExpr ()+import Hoopl++import Maybes+import Outputable++-----------------------------------------------------------------------------+-- Calculating what variables are live on entry to a basic block+-----------------------------------------------------------------------------++-- | The variables live on entry to a block+type CmmLive r = RegSet r+type CmmLocalLive = CmmLive LocalReg++-- | The dataflow lattice+liveLattice :: Ord r => DataflowLattice (CmmLive r)+{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive LocalReg) #-}+{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive GlobalReg) #-}+liveLattice = DataflowLattice emptyRegSet add+  where+    add (OldFact old) (NewFact new) =+        let !join = plusRegSet old new+        in changedIf (sizeRegSet join > sizeRegSet old) join++-- | A mapping from block labels to the variables live on entry+type BlockEntryLiveness r = LabelMap (CmmLive r)++-----------------------------------------------------------------------------+-- | Calculated liveness info for a CmmGraph+-----------------------------------------------------------------------------++cmmLocalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness LocalReg+cmmLocalLiveness dflags graph =+    check $ analyzeCmmBwd liveLattice (xferLive dflags) graph mapEmpty+  where+    entry = g_entry graph+    check facts =+        noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts++cmmGlobalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness GlobalReg+cmmGlobalLiveness dflags graph =+    analyzeCmmBwd liveLattice (xferLive dflags) graph mapEmpty++-- | On entry to the procedure, there had better not be any LocalReg's live-in.+noLiveOnEntry :: BlockId -> CmmLive LocalReg -> a -> a+noLiveOnEntry bid in_fact x =+  if nullRegSet in_fact then x+  else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact)++gen_kill+    :: (DefinerOfRegs r n, UserOfRegs r n)+    => DynFlags -> n -> CmmLive r -> CmmLive r+gen_kill dflags node set =+    let !afterKill = foldRegsDefd dflags deleteFromRegSet set node+    in foldRegsUsed dflags extendRegSet afterKill node+{-# INLINE gen_kill #-}++xferLive+    :: forall r.+       ( UserOfRegs r (CmmNode O O)+       , DefinerOfRegs r (CmmNode O O)+       , UserOfRegs r (CmmNode O C)+       , DefinerOfRegs r (CmmNode O C)+       )+    => DynFlags -> TransferFun (CmmLive r)+xferLive dflags (BlockCC eNode middle xNode) fBase =+    let joined = gen_kill dflags xNode $! joinOutFacts liveLattice xNode fBase+        !result = foldNodesBwdOO (gen_kill dflags) middle joined+    in mapSingleton (entryLabel eNode) result+{-# SPECIALIZE xferLive :: DynFlags -> TransferFun (CmmLive LocalReg) #-}+{-# SPECIALIZE xferLive :: DynFlags -> TransferFun (CmmLive GlobalReg) #-}
+ cmm/CmmMachOp.hs view
@@ -0,0 +1,619 @@+{-# LANGUAGE CPP #-}++module CmmMachOp+    ( MachOp(..)+    , pprMachOp, isCommutableMachOp, isAssociativeMachOp+    , isComparisonMachOp, maybeIntComparison, machOpResultType+    , machOpArgReps, maybeInvertComparison++    -- MachOp builders+    , mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot+    , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem+    , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe+    , mo_wordULe, mo_wordUGt, mo_wordULt+    , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot+    , mo_wordShl, mo_wordSShr, mo_wordUShr+    , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32+    , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord+    , mo_u_32ToWord, mo_s_32ToWord+    , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64++    -- CallishMachOp+    , CallishMachOp(..), callishMachOpHints+    , pprCallishMachOp+    , machOpMemcpyishAlign++    -- Atomic read-modify-write+    , AtomicMachOp(..)+   )+where++#include "HsVersions.h"++import CmmType+import Outputable+import DynFlags++-----------------------------------------------------------------------------+--              MachOp+-----------------------------------------------------------------------------++{- |+Machine-level primops; ones which we can reasonably delegate to the+native code generators to handle.++Most operations are parameterised by the 'Width' that they operate on.+Some operations have separate signed and unsigned versions, and float+and integer versions.+-}++data MachOp+  -- Integer operations (insensitive to signed/unsigned)+  = MO_Add Width+  | MO_Sub Width+  | MO_Eq  Width+  | MO_Ne  Width+  | MO_Mul Width                -- low word of multiply++  -- Signed multiply/divide+  | MO_S_MulMayOflo Width       -- nonzero if signed multiply overflows+  | MO_S_Quot Width             -- signed / (same semantics as IntQuotOp)+  | MO_S_Rem  Width             -- signed % (same semantics as IntRemOp)+  | MO_S_Neg  Width             -- unary -++  -- Unsigned multiply/divide+  | MO_U_MulMayOflo Width       -- nonzero if unsigned multiply overflows+  | MO_U_Quot Width             -- unsigned / (same semantics as WordQuotOp)+  | MO_U_Rem  Width             -- unsigned % (same semantics as WordRemOp)++  -- Signed comparisons+  | MO_S_Ge Width+  | MO_S_Le Width+  | MO_S_Gt Width+  | MO_S_Lt Width++  -- Unsigned comparisons+  | MO_U_Ge Width+  | MO_U_Le Width+  | MO_U_Gt Width+  | MO_U_Lt Width++  -- Floating point arithmetic+  | MO_F_Add  Width+  | MO_F_Sub  Width+  | MO_F_Neg  Width             -- unary -+  | MO_F_Mul  Width+  | MO_F_Quot Width++  -- Floating point comparison+  | MO_F_Eq Width+  | MO_F_Ne Width+  | MO_F_Ge Width+  | MO_F_Le Width+  | MO_F_Gt Width+  | MO_F_Lt Width++  -- Bitwise operations.  Not all of these may be supported+  -- at all sizes, and only integral Widths are valid.+  | MO_And   Width+  | MO_Or    Width+  | MO_Xor   Width+  | MO_Not   Width+  | MO_Shl   Width+  | MO_U_Shr Width      -- unsigned shift right+  | MO_S_Shr Width      -- signed shift right++  -- Conversions.  Some of these will be NOPs.+  -- Floating-point conversions use the signed variant.+  | MO_SF_Conv Width Width      -- Signed int -> Float+  | MO_FS_Conv Width Width      -- Float -> Signed int+  | MO_SS_Conv Width Width      -- Signed int -> Signed int+  | MO_UU_Conv Width Width      -- unsigned int -> unsigned int+  | MO_FF_Conv Width Width      -- Float -> Float++  -- Vector element insertion and extraction operations+  | MO_V_Insert  Length Width   -- Insert scalar into vector+  | MO_V_Extract Length Width   -- Extract scalar from vector++  -- Integer vector operations+  | MO_V_Add Length Width+  | MO_V_Sub Length Width+  | MO_V_Mul Length Width++  -- Signed vector multiply/divide+  | MO_VS_Quot Length Width+  | MO_VS_Rem  Length Width+  | MO_VS_Neg  Length Width++  -- Unsigned vector multiply/divide+  | MO_VU_Quot Length Width+  | MO_VU_Rem  Length Width++  -- Floting point vector element insertion and extraction operations+  | MO_VF_Insert  Length Width   -- Insert scalar into vector+  | MO_VF_Extract Length Width   -- Extract scalar from vector++  -- Floating point vector operations+  | MO_VF_Add  Length Width+  | MO_VF_Sub  Length Width+  | MO_VF_Neg  Length Width             -- unary -+  | MO_VF_Mul  Length Width+  | MO_VF_Quot Length Width+  deriving (Eq, Show)++pprMachOp :: MachOp -> SDoc+pprMachOp mo = text (show mo)++++-- -----------------------------------------------------------------------------+-- Some common MachReps++-- A 'wordRep' is a machine word on the target architecture+-- Specifically, it is the size of an Int#, Word#, Addr#+-- and the unit of allocation on the stack and the heap+-- Any pointer is also guaranteed to be a wordRep.++mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot+    , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem+    , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe+    , mo_wordULe, mo_wordUGt, mo_wordULt+    , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr+    , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord+    , mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64+    :: DynFlags -> MachOp++mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32+    , mo_32To8, mo_32To16+    :: MachOp++mo_wordAdd      dflags = MO_Add (wordWidth dflags)+mo_wordSub      dflags = MO_Sub (wordWidth dflags)+mo_wordEq       dflags = MO_Eq  (wordWidth dflags)+mo_wordNe       dflags = MO_Ne  (wordWidth dflags)+mo_wordMul      dflags = MO_Mul (wordWidth dflags)+mo_wordSQuot    dflags = MO_S_Quot (wordWidth dflags)+mo_wordSRem     dflags = MO_S_Rem (wordWidth dflags)+mo_wordSNeg     dflags = MO_S_Neg (wordWidth dflags)+mo_wordUQuot    dflags = MO_U_Quot (wordWidth dflags)+mo_wordURem     dflags = MO_U_Rem (wordWidth dflags)++mo_wordSGe      dflags = MO_S_Ge  (wordWidth dflags)+mo_wordSLe      dflags = MO_S_Le  (wordWidth dflags)+mo_wordSGt      dflags = MO_S_Gt  (wordWidth dflags)+mo_wordSLt      dflags = MO_S_Lt  (wordWidth dflags)++mo_wordUGe      dflags = MO_U_Ge  (wordWidth dflags)+mo_wordULe      dflags = MO_U_Le  (wordWidth dflags)+mo_wordUGt      dflags = MO_U_Gt  (wordWidth dflags)+mo_wordULt      dflags = MO_U_Lt  (wordWidth dflags)++mo_wordAnd      dflags = MO_And (wordWidth dflags)+mo_wordOr       dflags = MO_Or  (wordWidth dflags)+mo_wordXor      dflags = MO_Xor (wordWidth dflags)+mo_wordNot      dflags = MO_Not (wordWidth dflags)+mo_wordShl      dflags = MO_Shl (wordWidth dflags)+mo_wordSShr     dflags = MO_S_Shr (wordWidth dflags)+mo_wordUShr     dflags = MO_U_Shr (wordWidth dflags)++mo_u_8To32             = MO_UU_Conv W8 W32+mo_s_8To32             = MO_SS_Conv W8 W32+mo_u_16To32            = MO_UU_Conv W16 W32+mo_s_16To32            = MO_SS_Conv W16 W32++mo_u_8ToWord    dflags = MO_UU_Conv W8  (wordWidth dflags)+mo_s_8ToWord    dflags = MO_SS_Conv W8  (wordWidth dflags)+mo_u_16ToWord   dflags = MO_UU_Conv W16 (wordWidth dflags)+mo_s_16ToWord   dflags = MO_SS_Conv W16 (wordWidth dflags)+mo_s_32ToWord   dflags = MO_SS_Conv W32 (wordWidth dflags)+mo_u_32ToWord   dflags = MO_UU_Conv W32 (wordWidth dflags)++mo_WordTo8      dflags = MO_UU_Conv (wordWidth dflags) W8+mo_WordTo16     dflags = MO_UU_Conv (wordWidth dflags) W16+mo_WordTo32     dflags = MO_UU_Conv (wordWidth dflags) W32+mo_WordTo64     dflags = MO_UU_Conv (wordWidth dflags) W64++mo_32To8               = MO_UU_Conv W32 W8+mo_32To16              = MO_UU_Conv W32 W16+++-- ----------------------------------------------------------------------------+-- isCommutableMachOp++{- |+Returns 'True' if the MachOp has commutable arguments.  This is used+in the platform-independent Cmm optimisations.++If in doubt, return 'False'.  This generates worse code on the+native routes, but is otherwise harmless.+-}+isCommutableMachOp :: MachOp -> Bool+isCommutableMachOp mop =+  case mop of+        MO_Add _                -> True+        MO_Eq _                 -> True+        MO_Ne _                 -> True+        MO_Mul _                -> True+        MO_S_MulMayOflo _       -> True+        MO_U_MulMayOflo _       -> True+        MO_And _                -> True+        MO_Or _                 -> True+        MO_Xor _                -> True+        MO_F_Add _              -> True+        MO_F_Mul _              -> True+        _other                  -> False++-- ----------------------------------------------------------------------------+-- isAssociativeMachOp++{- |+Returns 'True' if the MachOp is associative (i.e. @(x+y)+z == x+(y+z)@)+This is used in the platform-independent Cmm optimisations.++If in doubt, return 'False'.  This generates worse code on the+native routes, but is otherwise harmless.+-}+isAssociativeMachOp :: MachOp -> Bool+isAssociativeMachOp mop =+  case mop of+        MO_Add {} -> True       -- NB: does not include+        MO_Mul {} -> True --     floatint point!+        MO_And {} -> True+        MO_Or  {} -> True+        MO_Xor {} -> True+        _other    -> False+++-- ----------------------------------------------------------------------------+-- isComparisonMachOp++{- |+Returns 'True' if the MachOp is a comparison.++If in doubt, return False.  This generates worse code on the+native routes, but is otherwise harmless.+-}+isComparisonMachOp :: MachOp -> Bool+isComparisonMachOp mop =+  case mop of+    MO_Eq   _  -> True+    MO_Ne   _  -> True+    MO_S_Ge _  -> True+    MO_S_Le _  -> True+    MO_S_Gt _  -> True+    MO_S_Lt _  -> True+    MO_U_Ge _  -> True+    MO_U_Le _  -> True+    MO_U_Gt _  -> True+    MO_U_Lt _  -> True+    MO_F_Eq {} -> True+    MO_F_Ne {} -> True+    MO_F_Ge {} -> True+    MO_F_Le {} -> True+    MO_F_Gt {} -> True+    MO_F_Lt {} -> True+    _other     -> False++{- |+Returns @Just w@ if the operation is an integer comparison with width+@w@, or @Nothing@ otherwise.+-}+maybeIntComparison :: MachOp -> Maybe Width+maybeIntComparison mop =+  case mop of+    MO_Eq   w  -> Just w+    MO_Ne   w  -> Just w+    MO_S_Ge w  -> Just w+    MO_S_Le w  -> Just w+    MO_S_Gt w  -> Just w+    MO_S_Lt w  -> Just w+    MO_U_Ge w  -> Just w+    MO_U_Le w  -> Just w+    MO_U_Gt w  -> Just w+    MO_U_Lt w  -> Just w+    _ -> Nothing++-- -----------------------------------------------------------------------------+-- Inverting conditions++-- Sometimes it's useful to be able to invert the sense of a+-- condition.  Not all conditional tests are invertible: in+-- particular, floating point conditionals cannot be inverted, because+-- there exist floating-point values which return False for both senses+-- of a condition (eg. !(NaN > NaN) && !(NaN /<= NaN)).++maybeInvertComparison :: MachOp -> Maybe MachOp+maybeInvertComparison op+  = case op of  -- None of these Just cases include floating point+        MO_Eq r   -> Just (MO_Ne r)+        MO_Ne r   -> Just (MO_Eq r)+        MO_U_Lt r -> Just (MO_U_Ge r)+        MO_U_Gt r -> Just (MO_U_Le r)+        MO_U_Le r -> Just (MO_U_Gt r)+        MO_U_Ge r -> Just (MO_U_Lt r)+        MO_S_Lt r -> Just (MO_S_Ge r)+        MO_S_Gt r -> Just (MO_S_Le r)+        MO_S_Le r -> Just (MO_S_Gt r)+        MO_S_Ge r -> Just (MO_S_Lt r)+        _other    -> Nothing++-- ----------------------------------------------------------------------------+-- machOpResultType++{- |+Returns the MachRep of the result of a MachOp.+-}+machOpResultType :: DynFlags -> MachOp -> [CmmType] -> CmmType+machOpResultType dflags mop tys =+  case mop of+    MO_Add {}           -> ty1  -- Preserve GC-ptr-hood+    MO_Sub {}           -> ty1  -- of first arg+    MO_Mul    r         -> cmmBits r+    MO_S_MulMayOflo r   -> cmmBits r+    MO_S_Quot r         -> cmmBits r+    MO_S_Rem  r         -> cmmBits r+    MO_S_Neg  r         -> cmmBits r+    MO_U_MulMayOflo r   -> cmmBits r+    MO_U_Quot r         -> cmmBits r+    MO_U_Rem  r         -> cmmBits r++    MO_Eq {}            -> comparisonResultRep dflags+    MO_Ne {}            -> comparisonResultRep dflags+    MO_S_Ge {}          -> comparisonResultRep dflags+    MO_S_Le {}          -> comparisonResultRep dflags+    MO_S_Gt {}          -> comparisonResultRep dflags+    MO_S_Lt {}          -> comparisonResultRep dflags++    MO_U_Ge {}          -> comparisonResultRep dflags+    MO_U_Le {}          -> comparisonResultRep dflags+    MO_U_Gt {}          -> comparisonResultRep dflags+    MO_U_Lt {}          -> comparisonResultRep dflags++    MO_F_Add r          -> cmmFloat r+    MO_F_Sub r          -> cmmFloat r+    MO_F_Mul r          -> cmmFloat r+    MO_F_Quot r         -> cmmFloat r+    MO_F_Neg r          -> cmmFloat r+    MO_F_Eq  {}         -> comparisonResultRep dflags+    MO_F_Ne  {}         -> comparisonResultRep dflags+    MO_F_Ge  {}         -> comparisonResultRep dflags+    MO_F_Le  {}         -> comparisonResultRep dflags+    MO_F_Gt  {}         -> comparisonResultRep dflags+    MO_F_Lt  {}         -> comparisonResultRep dflags++    MO_And {}           -> ty1  -- Used for pointer masking+    MO_Or {}            -> ty1+    MO_Xor {}           -> ty1+    MO_Not   r          -> cmmBits r+    MO_Shl   r          -> cmmBits r+    MO_U_Shr r          -> cmmBits r+    MO_S_Shr r          -> cmmBits r++    MO_SS_Conv _ to     -> cmmBits to+    MO_UU_Conv _ to     -> cmmBits to+    MO_FS_Conv _ to     -> cmmBits to+    MO_SF_Conv _ to     -> cmmFloat to+    MO_FF_Conv _ to     -> cmmFloat to++    MO_V_Insert  l w    -> cmmVec l (cmmBits w)+    MO_V_Extract _ w    -> cmmBits w++    MO_V_Add l w        -> cmmVec l (cmmBits w)+    MO_V_Sub l w        -> cmmVec l (cmmBits w)+    MO_V_Mul l w        -> cmmVec l (cmmBits w)++    MO_VS_Quot l w      -> cmmVec l (cmmBits w)+    MO_VS_Rem  l w      -> cmmVec l (cmmBits w)+    MO_VS_Neg  l w      -> cmmVec l (cmmBits w)++    MO_VU_Quot l w      -> cmmVec l (cmmBits w)+    MO_VU_Rem  l w      -> cmmVec l (cmmBits w)++    MO_VF_Insert  l w   -> cmmVec l (cmmFloat w)+    MO_VF_Extract _ w   -> cmmFloat w++    MO_VF_Add  l w      -> cmmVec l (cmmFloat w)+    MO_VF_Sub  l w      -> cmmVec l (cmmFloat w)+    MO_VF_Mul  l w      -> cmmVec l (cmmFloat w)+    MO_VF_Quot l w      -> cmmVec l (cmmFloat w)+    MO_VF_Neg  l w      -> cmmVec l (cmmFloat w)+  where+    (ty1:_) = tys++comparisonResultRep :: DynFlags -> CmmType+comparisonResultRep = bWord  -- is it?+++-- -----------------------------------------------------------------------------+-- machOpArgReps++-- | This function is used for debugging only: we can check whether an+-- application of a MachOp is "type-correct" by checking that the MachReps of+-- its arguments are the same as the MachOp expects.  This is used when+-- linting a CmmExpr.++machOpArgReps :: DynFlags -> MachOp -> [Width]+machOpArgReps dflags op =+  case op of+    MO_Add    r         -> [r,r]+    MO_Sub    r         -> [r,r]+    MO_Eq     r         -> [r,r]+    MO_Ne     r         -> [r,r]+    MO_Mul    r         -> [r,r]+    MO_S_MulMayOflo r   -> [r,r]+    MO_S_Quot r         -> [r,r]+    MO_S_Rem  r         -> [r,r]+    MO_S_Neg  r         -> [r]+    MO_U_MulMayOflo r   -> [r,r]+    MO_U_Quot r         -> [r,r]+    MO_U_Rem  r         -> [r,r]++    MO_S_Ge r           -> [r,r]+    MO_S_Le r           -> [r,r]+    MO_S_Gt r           -> [r,r]+    MO_S_Lt r           -> [r,r]++    MO_U_Ge r           -> [r,r]+    MO_U_Le r           -> [r,r]+    MO_U_Gt r           -> [r,r]+    MO_U_Lt r           -> [r,r]++    MO_F_Add r          -> [r,r]+    MO_F_Sub r          -> [r,r]+    MO_F_Mul r          -> [r,r]+    MO_F_Quot r         -> [r,r]+    MO_F_Neg r          -> [r]+    MO_F_Eq  r          -> [r,r]+    MO_F_Ne  r          -> [r,r]+    MO_F_Ge  r          -> [r,r]+    MO_F_Le  r          -> [r,r]+    MO_F_Gt  r          -> [r,r]+    MO_F_Lt  r          -> [r,r]++    MO_And   r          -> [r,r]+    MO_Or    r          -> [r,r]+    MO_Xor   r          -> [r,r]+    MO_Not   r          -> [r]+    MO_Shl   r          -> [r, wordWidth dflags]+    MO_U_Shr r          -> [r, wordWidth dflags]+    MO_S_Shr r          -> [r, wordWidth dflags]++    MO_SS_Conv from _   -> [from]+    MO_UU_Conv from _   -> [from]+    MO_SF_Conv from _   -> [from]+    MO_FS_Conv from _   -> [from]+    MO_FF_Conv from _   -> [from]++    MO_V_Insert  l r    -> [typeWidth (vec l (cmmBits r)),r,wordWidth dflags]+    MO_V_Extract l r    -> [typeWidth (vec l (cmmBits r)),wordWidth dflags]++    MO_V_Add _ r        -> [r,r]+    MO_V_Sub _ r        -> [r,r]+    MO_V_Mul _ r        -> [r,r]++    MO_VS_Quot _ r      -> [r,r]+    MO_VS_Rem  _ r      -> [r,r]+    MO_VS_Neg  _ r      -> [r]++    MO_VU_Quot _ r      -> [r,r]+    MO_VU_Rem  _ r      -> [r,r]++    MO_VF_Insert  l r   -> [typeWidth (vec l (cmmFloat r)),r,wordWidth dflags]+    MO_VF_Extract l r   -> [typeWidth (vec l (cmmFloat r)),wordWidth dflags]++    MO_VF_Add  _ r      -> [r,r]+    MO_VF_Sub  _ r      -> [r,r]+    MO_VF_Mul  _ r      -> [r,r]+    MO_VF_Quot _ r      -> [r,r]+    MO_VF_Neg  _ r      -> [r]++-----------------------------------------------------------------------------+-- CallishMachOp+-----------------------------------------------------------------------------++-- CallishMachOps tend to be implemented by foreign calls in some backends,+-- so we separate them out.  In Cmm, these can only occur in a+-- statement position, in contrast to an ordinary MachOp which can occur+-- anywhere in an expression.+data CallishMachOp+  = MO_F64_Pwr+  | MO_F64_Sin+  | MO_F64_Cos+  | MO_F64_Tan+  | MO_F64_Sinh+  | MO_F64_Cosh+  | MO_F64_Tanh+  | MO_F64_Asin+  | MO_F64_Acos+  | MO_F64_Atan+  | MO_F64_Log+  | MO_F64_Exp+  | MO_F64_Fabs+  | MO_F64_Sqrt+  | MO_F32_Pwr+  | MO_F32_Sin+  | MO_F32_Cos+  | MO_F32_Tan+  | MO_F32_Sinh+  | MO_F32_Cosh+  | MO_F32_Tanh+  | MO_F32_Asin+  | MO_F32_Acos+  | MO_F32_Atan+  | MO_F32_Log+  | MO_F32_Exp+  | MO_F32_Fabs+  | MO_F32_Sqrt++  | MO_UF_Conv Width++  | MO_S_QuotRem Width+  | MO_U_QuotRem Width+  | MO_U_QuotRem2 Width+  | MO_Add2      Width+  | MO_SubWordC  Width+  | MO_AddIntC   Width+  | MO_SubIntC   Width+  | MO_U_Mul2    Width++  | MO_WriteBarrier+  | MO_Touch         -- Keep variables live (when using interior pointers)++  -- Prefetch+  | MO_Prefetch_Data Int -- Prefetch hint. May change program performance but not+                     -- program behavior.+                     -- the Int can be 0-3. Needs to be known at compile time+                     -- to interact with code generation correctly.+                     --  TODO: add support for prefetch WRITES,+                     --  currently only exposes prefetch reads, which+                     -- would the majority of use cases in ghc anyways+++  -- These three MachOps are parameterised by the known alignment+  -- of the destination and source (for memcpy/memmove) pointers.+  -- This information may be used for optimisation in backends.+  | MO_Memcpy Int+  | MO_Memset Int+  | MO_Memmove Int++  | MO_PopCnt Width+  | MO_Clz Width+  | MO_Ctz Width++  | MO_BSwap Width++  -- Atomic read-modify-write.+  | MO_AtomicRMW Width AtomicMachOp+  | MO_AtomicRead Width+  | MO_AtomicWrite Width+  | MO_Cmpxchg Width+  deriving (Eq, Show)++-- | The operation to perform atomically.+data AtomicMachOp =+      AMO_Add+    | AMO_Sub+    | AMO_And+    | AMO_Nand+    | AMO_Or+    | AMO_Xor+      deriving (Eq, Show)++pprCallishMachOp :: CallishMachOp -> SDoc+pprCallishMachOp mo = text (show mo)++callishMachOpHints :: CallishMachOp -> ([ForeignHint], [ForeignHint])+callishMachOpHints op = case op of+  MO_Memcpy _  -> ([], [AddrHint,AddrHint,NoHint])+  MO_Memset _  -> ([], [AddrHint,NoHint,NoHint])+  MO_Memmove _ -> ([], [AddrHint,AddrHint,NoHint])+  _            -> ([],[])+  -- empty lists indicate NoHint++-- | The alignment of a 'memcpy'-ish operation.+machOpMemcpyishAlign :: CallishMachOp -> Maybe Int+machOpMemcpyishAlign op = case op of+  MO_Memcpy  align -> Just align+  MO_Memset  align -> Just align+  MO_Memmove align -> Just align+  _                -> Nothing
+ cmm/CmmMonad.hs view
@@ -0,0 +1,58 @@+-----------------------------------------------------------------------------+-- A Parser monad with access to the 'DynFlags'.+--+-- The 'P' monad  only has access to the subset of of 'DynFlags'+-- required for parsing Haskell.++-- The parser for C-- requires access to a lot more of the 'DynFlags',+-- so 'PD' provides access to 'DynFlags' via a 'HasDynFlags' instance.+-----------------------------------------------------------------------------+{-# LANGUAGE CPP #-}+module CmmMonad (+    PD(..)+  , liftP+  ) where++import Control.Monad+#if __GLASGOW_HASKELL__ > 710+import qualified Control.Monad.Fail as MonadFail+#endif++import DynFlags+import Lexer++newtype PD a = PD { unPD :: DynFlags -> PState -> ParseResult a }++instance Functor PD where+  fmap = liftM++instance Applicative PD where+  pure = returnPD+  (<*>) = ap++instance Monad PD where+  (>>=) = thenPD+  fail = failPD++#if __GLASGOW_HASKELL__ > 710+instance MonadFail.MonadFail PD where+  fail = failPD+#endif++liftP :: P a -> PD a+liftP (P f) = PD $ \_ s -> f s++returnPD :: a -> PD a+returnPD = liftP . return++thenPD :: PD a -> (a -> PD b) -> PD b+(PD m) `thenPD` k = PD $ \d s ->+        case m d s of+                POk s1 a         -> unPD (k a) d s1+                PFailed span err -> PFailed span err++failPD :: String -> PD a+failPD = liftP . fail++instance HasDynFlags PD where+   getDynFlags = PD $ \d s -> POk s d
+ cmm/CmmNode.hs view
@@ -0,0 +1,700 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}++-- CmmNode type for representation using Hoopl graphs.++module CmmNode (+     CmmNode(..), CmmFormal, CmmActual, CmmTickish,+     UpdFrameOffset, Convention(..),+     ForeignConvention(..), ForeignTarget(..), foreignTargetHints,+     CmmReturnInfo(..),+     mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf,+     mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors,++     -- * Tick scopes+     CmmTickScope(..), isTickSubScope, combineTickScopes,+  ) where++import CodeGen.Platform+import CmmExpr+import CmmSwitch+import DynFlags+import FastString+import ForeignCall+import Outputable+import SMRep+import CoreSyn (Tickish)+import qualified Unique as U++import Compiler.Hoopl+import Data.Maybe+import Data.List (tails,sortBy)+import Prelude hiding (succ)+import Unique (nonDetCmpUnique)+import Util+++------------------------+-- CmmNode++#define ULabel {-# UNPACK #-} !Label++data CmmNode e x where+  CmmEntry :: ULabel -> CmmTickScope -> CmmNode C O++  CmmComment :: FastString -> CmmNode O O++    -- Tick annotation, covering Cmm code in our tick scope. We only+    -- expect non-code @Tickish@ at this point (e.g. @SourceNote@).+    -- See Note [CmmTick scoping details]+  CmmTick :: !CmmTickish -> CmmNode O O++    -- Unwind pseudo-instruction, encoding stack unwinding+    -- instructions for a debugger. This describes how to reconstruct+    -- the "old" value of a register if we want to navigate the stack+    -- up one frame. Having unwind information for @Sp@ will allow the+    -- debugger to "walk" the stack.+    --+    -- See Note [What is this unwinding business?] in Debug+  CmmUnwind :: [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O++  CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O+    -- Assign to register++  CmmStore :: !CmmExpr -> !CmmExpr -> CmmNode O O+    -- Assign to memory location.  Size is+    -- given by cmmExprType of the rhs.++  CmmUnsafeForeignCall ::       -- An unsafe foreign call;+                                -- see Note [Foreign calls]+                                -- Like a "fat machine instruction"; can occur+                                -- in the middle of a block+      ForeignTarget ->          -- call target+      [CmmFormal] ->            -- zero or more results+      [CmmActual] ->            -- zero or more arguments+      CmmNode O O+      -- Semantics: clobbers any GlobalRegs for which callerSaves r == True+      -- See Note [Unsafe foreign calls clobber caller-save registers]+      --+      -- Invariant: the arguments and the ForeignTarget must not+      -- mention any registers for which CodeGen.Platform.callerSaves+      -- is True.  See Note [Register Parameter Passing].++  CmmBranch :: ULabel -> CmmNode O C+                                   -- Goto another block in the same procedure++  CmmCondBranch :: {                 -- conditional branch+      cml_pred :: CmmExpr,+      cml_true, cml_false :: ULabel,+      cml_likely :: Maybe Bool       -- likely result of the conditional,+                                     -- if known+  } -> CmmNode O C++  CmmSwitch+    :: CmmExpr       -- Scrutinee, of some integral type+    -> SwitchTargets -- Cases. See [Note SwitchTargets]+    -> CmmNode O C++  CmmCall :: {                -- A native call or tail call+      cml_target :: CmmExpr,  -- never a CmmPrim to a CallishMachOp!++      cml_cont :: Maybe Label,+          -- Label of continuation (Nothing for return or tail call)+          --+          -- Note [Continuation BlockId]: these BlockIds are called+          -- Continuation BlockIds, and are the only BlockIds that can+          -- occur in CmmExprs, namely as (CmmLit (CmmBlock b)) or+          -- (CmmStackSlot (Young b) _).++      cml_args_regs :: [GlobalReg],+          -- The argument GlobalRegs (Rx, Fx, Dx, Lx) that are passed+          -- to the call.  This is essential information for the+          -- native code generator's register allocator; without+          -- knowing which GlobalRegs are live it has to assume that+          -- they are all live.  This list should only include+          -- GlobalRegs that are mapped to real machine registers on+          -- the target platform.++      cml_args :: ByteOff,+          -- Byte offset, from the *old* end of the Area associated with+          -- the Label (if cml_cont = Nothing, then Old area), of+          -- youngest outgoing arg.  Set the stack pointer to this before+          -- transferring control.+          -- (NB: an update frame might also have been stored in the Old+          --      area, but it'll be in an older part than the args.)++      cml_ret_args :: ByteOff,+          -- For calls *only*, the byte offset for youngest returned value+          -- This is really needed at the *return* point rather than here+          -- at the call, but in practice it's convenient to record it here.++      cml_ret_off :: ByteOff+        -- For calls *only*, the byte offset of the base of the frame that+        -- must be described by the info table for the return point.+        -- The older words are an update frames, which have their own+        -- info-table and layout information++        -- From a liveness point of view, the stack words older than+        -- cml_ret_off are treated as live, even if the sequel of+        -- the call goes into a loop.+  } -> CmmNode O C++  CmmForeignCall :: {           -- A safe foreign call; see Note [Foreign calls]+                                -- Always the last node of a block+      tgt   :: ForeignTarget,   -- call target and convention+      res   :: [CmmFormal],     -- zero or more results+      args  :: [CmmActual],     -- zero or more arguments; see Note [Register parameter passing]+      succ  :: ULabel,          -- Label of continuation+      ret_args :: ByteOff,      -- same as cml_ret_args+      ret_off :: ByteOff,       -- same as cml_ret_off+      intrbl:: Bool             -- whether or not the call is interruptible+  } -> CmmNode O C++{- Note [Foreign calls]+~~~~~~~~~~~~~~~~~~~~~~~+A CmmUnsafeForeignCall is used for *unsafe* foreign calls;+a CmmForeignCall call is used for *safe* foreign calls.++Unsafe ones are mostly easy: think of them as a "fat machine+instruction".  In particular, they do *not* kill all live registers,+just the registers they return to (there was a bit of code in GHC that+conservatively assumed otherwise.)  However, see [Register parameter passing].++Safe ones are trickier.  A safe foreign call+     r = f(x)+ultimately expands to+     push "return address"      -- Never used to return to;+                                -- just points an info table+     save registers into TSO+     call suspendThread+     r = f(x)                   -- Make the call+     call resumeThread+     restore registers+     pop "return address"+We cannot "lower" a safe foreign call to this sequence of Cmms, because+after we've saved Sp all the Cmm optimiser's assumptions are broken.++Note that a safe foreign call needs an info table.++So Safe Foreign Calls must remain as last nodes until the stack is+made manifest in CmmLayoutStack, where they are lowered into the above+sequence.+-}++{- Note [Unsafe foreign calls clobber caller-save registers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++A foreign call is defined to clobber any GlobalRegs that are mapped to+caller-saves machine registers (according to the prevailing C ABI).+StgCmmUtils.callerSaves tells you which GlobalRegs are caller-saves.++This is a design choice that makes it easier to generate code later.+We could instead choose to say that foreign calls do *not* clobber+caller-saves regs, but then we would have to figure out which regs+were live across the call later and insert some saves/restores.++Furthermore when we generate code we never have any GlobalRegs live+across a call, because they are always copied-in to LocalRegs and+copied-out again before making a call/jump.  So all we have to do is+avoid any code motion that would make a caller-saves GlobalReg live+across a foreign call during subsequent optimisations.+-}++{- Note [Register parameter passing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+On certain architectures, some registers are utilized for parameter+passing in the C calling convention.  For example, in x86-64 Linux+convention, rdi, rsi, rdx and rcx (as well as r8 and r9) may be used for+argument passing.  These are registers R3-R6, which our generated+code may also be using; as a result, it's necessary to save these+values before doing a foreign call.  This is done during initial+code generation in callerSaveVolatileRegs in StgCmmUtils.hs.  However,+one result of doing this is that the contents of these registers+may mysteriously change if referenced inside the arguments.  This+is dangerous, so you'll need to disable inlining much in the same+way is done in cmm/CmmOpt.hs currently.  We should fix this!+-}++---------------------------------------------+-- Eq instance of CmmNode++deriving instance Eq (CmmNode e x)++----------------------------------------------+-- Hoopl instances of CmmNode++instance NonLocal CmmNode where+  entryLabel (CmmEntry l _) = l++  successors (CmmBranch l) = [l]+  successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint+  successors (CmmSwitch _ ids) = switchTargetsToList ids+  successors (CmmCall {cml_cont=l}) = maybeToList l+  successors (CmmForeignCall {succ=l}) = [l]+++--------------------------------------------------+-- Various helper types++type CmmActual = CmmExpr+type CmmFormal = LocalReg++type UpdFrameOffset = ByteOff++-- | A convention maps a list of values (function arguments or return+-- values) to registers or stack locations.+data Convention+  = NativeDirectCall+       -- ^ top-level Haskell functions use @NativeDirectCall@, which+       -- maps arguments to registers starting with R2, according to+       -- how many registers are available on the platform.  This+       -- convention ignores R1, because for a top-level function call+       -- the function closure is implicit, and doesn't need to be passed.+  | NativeNodeCall+       -- ^ non-top-level Haskell functions, which pass the address of+       -- the function closure in R1 (regardless of whether R1 is a+       -- real register or not), and the rest of the arguments in+       -- registers or on the stack.+  | NativeReturn+       -- ^ a native return.  The convention for returns depends on+       -- how many values are returned: for just one value returned,+       -- the appropriate register is used (R1, F1, etc.). regardless+       -- of whether it is a real register or not.  For multiple+       -- values returned, they are mapped to registers or the stack.+  | Slow+       -- ^ Slow entry points: all args pushed on the stack+  | GC+       -- ^ Entry to the garbage collector: uses the node reg!+       -- (TODO: I don't think we need this --SDM)+  deriving( Eq )++data ForeignConvention+  = ForeignConvention+        CCallConv               -- Which foreign-call convention+        [ForeignHint]           -- Extra info about the args+        [ForeignHint]           -- Extra info about the result+        CmmReturnInfo+  deriving Eq++data CmmReturnInfo+  = CmmMayReturn+  | CmmNeverReturns+  deriving ( Eq )++data ForeignTarget        -- The target of a foreign call+  = ForeignTarget                -- A foreign procedure+        CmmExpr                  -- Its address+        ForeignConvention        -- Its calling convention+  | PrimTarget            -- A possibly-side-effecting machine operation+        CallishMachOp            -- Which one+  deriving Eq++foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint])+foreignTargetHints target+  = ( res_hints ++ repeat NoHint+    , arg_hints ++ repeat NoHint )+  where+    (res_hints, arg_hints) =+       case target of+          PrimTarget op -> callishMachOpHints op+          ForeignTarget _ (ForeignConvention _ arg_hints res_hints _) ->+             (res_hints, arg_hints)++--------------------------------------------------+-- Instances of register and slot users / definers++instance UserOfRegs LocalReg (CmmNode e x) where+  foldRegsUsed dflags f !z n = case n of+    CmmAssign _ expr -> fold f z expr+    CmmStore addr rval -> fold f (fold f z addr) rval+    CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args+    CmmCondBranch expr _ _ _ -> fold f z expr+    CmmSwitch expr _ -> fold f z expr+    CmmCall {cml_target=tgt} -> fold f z tgt+    CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args+    _ -> z+    where fold :: forall a b. UserOfRegs LocalReg a+               => (b -> LocalReg -> b) -> b -> a -> b+          fold f z n = foldRegsUsed dflags f z n++instance UserOfRegs GlobalReg (CmmNode e x) where+  foldRegsUsed dflags f !z n = case n of+    CmmAssign _ expr -> fold f z expr+    CmmStore addr rval -> fold f (fold f z addr) rval+    CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args+    CmmCondBranch expr _ _ _ -> fold f z expr+    CmmSwitch expr _ -> fold f z expr+    CmmCall {cml_target=tgt, cml_args_regs=args} -> fold f (fold f z args) tgt+    CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args+    _ -> z+    where fold :: forall a b.  UserOfRegs GlobalReg a+               => (b -> GlobalReg -> b) -> b -> a -> b+          fold f z n = foldRegsUsed dflags f z n++instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r ForeignTarget where+  -- The (Ord r) in the context is necessary here+  -- See Note [Recursive superclasses] in TcInstDcls+  foldRegsUsed _      _ !z (PrimTarget _)      = z+  foldRegsUsed dflags f !z (ForeignTarget e _) = foldRegsUsed dflags f z e++instance DefinerOfRegs LocalReg (CmmNode e x) where+  foldRegsDefd dflags f !z n = case n of+    CmmAssign lhs _ -> fold f z lhs+    CmmUnsafeForeignCall _ fs _ -> fold f z fs+    CmmForeignCall {res=res} -> fold f z res+    _ -> z+    where fold :: forall a b. DefinerOfRegs LocalReg a+               => (b -> LocalReg -> b) -> b -> a -> b+          fold f z n = foldRegsDefd dflags f z n++instance DefinerOfRegs GlobalReg (CmmNode e x) where+  foldRegsDefd dflags f !z n = case n of+    CmmAssign lhs _ -> fold f z lhs+    CmmUnsafeForeignCall tgt _ _  -> fold f z (foreignTargetRegs tgt)+    CmmCall        {} -> fold f z activeRegs+    CmmForeignCall {} -> fold f z activeRegs+                      -- See Note [Safe foreign calls clobber STG registers]+    _ -> z+    where fold :: forall a b. DefinerOfRegs GlobalReg a+               => (b -> GlobalReg -> b) -> b -> a -> b+          fold f z n = foldRegsDefd dflags f z n++          platform = targetPlatform dflags+          activeRegs = activeStgRegs platform+          activeCallerSavesRegs = filter (callerSaves platform) activeRegs++          foreignTargetRegs (ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns)) = []+          foreignTargetRegs _ = activeCallerSavesRegs++-- Note [Safe foreign calls clobber STG registers]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- During stack layout phase every safe foreign call is expanded into a block+-- that contains unsafe foreign call (instead of safe foreign call) and ends+-- with a normal call (See Note [Foreign calls]). This means that we must+-- treat safe foreign call as if it was a normal call (because eventually it+-- will be). This is important if we try to run sinking pass before stack+-- layout phase. Consider this example of what might go wrong (this is cmm+-- code from stablename001 test). Here is code after common block elimination+-- (before stack layout):+--+--  c1q6:+--      _s1pf::P64 = R1;+--      _c1q8::I64 = performMajorGC;+--      I64[(young<c1q9> + 8)] = c1q9;+--      foreign call "ccall" arg hints:  []  result hints:  [] (_c1q8::I64)(...)+--                   returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;+--  c1q9:+--      I64[(young<c1qb> + 8)] = c1qb;+--      R1 = _s1pc::P64;+--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;+--+-- If we run sinking pass now (still before stack layout) we will get this:+--+--  c1q6:+--      I64[(young<c1q9> + 8)] = c1q9;+--      foreign call "ccall" arg hints:  []  result hints:  [] performMajorGC(...)+--                   returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;+--  c1q9:+--      I64[(young<c1qb> + 8)] = c1qb;+--      _s1pf::P64 = R1;         <------ _s1pf sunk past safe foreign call+--      R1 = _s1pc::P64;+--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;+--+-- Notice that _s1pf was sunk past a foreign call. When we run stack layout+-- safe call to performMajorGC will be turned into:+--+--  c1q6:+--      _s1pc::P64 = P64[Sp + 8];+--      I64[Sp - 8] = c1q9;+--      Sp = Sp - 8;+--      I64[I64[CurrentTSO + 24] + 16] = Sp;+--      P64[CurrentNursery + 8] = Hp + 8;+--      (_u1qI::I64) = call "ccall" arg hints:  [PtrHint,]+--                           result hints:  [PtrHint] suspendThread(BaseReg, 0);+--      call "ccall" arg hints:  []  result hints:  [] performMajorGC();+--      (_u1qJ::I64) = call "ccall" arg hints:  [PtrHint]+--                           result hints:  [PtrHint] resumeThread(_u1qI::I64);+--      BaseReg = _u1qJ::I64;+--      _u1qK::P64 = CurrentTSO;+--      _u1qL::P64 = I64[_u1qK::P64 + 24];+--      Sp = I64[_u1qL::P64 + 16];+--      SpLim = _u1qL::P64 + 192;+--      HpAlloc = 0;+--      Hp = I64[CurrentNursery + 8] - 8;+--      HpLim = I64[CurrentNursery] + (%MO_SS_Conv_W32_W64(I32[CurrentNursery + 48]) * 4096 - 1);+--      call (I64[Sp])() returns to c1q9, args: 8, res: 8, upd: 8;+--  c1q9:+--      I64[(young<c1qb> + 8)] = c1qb;+--      _s1pf::P64 = R1;         <------ INCORRECT!+--      R1 = _s1pc::P64;+--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;+--+-- Notice that c1q6 now ends with a call. Sinking _s1pf::P64 = R1 past that+-- call is clearly incorrect. This is what would happen if we assumed that+-- safe foreign call has the same semantics as unsafe foreign call. To prevent+-- this we need to treat safe foreign call as if was normal call.++-----------------------------------+-- mapping Expr in CmmNode++mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget+mapForeignTarget exp   (ForeignTarget e c) = ForeignTarget (exp e) c+mapForeignTarget _   m@(PrimTarget _)      = m++wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr+-- Take a transformer on expressions and apply it recursively.+-- (wrapRecExp f e) first recursively applies itself to sub-expressions of e+--                  then  uses f to rewrite the resulting expression+wrapRecExp f (CmmMachOp op es)    = f (CmmMachOp op $ map (wrapRecExp f) es)+wrapRecExp f (CmmLoad addr ty)    = f (CmmLoad (wrapRecExp f addr) ty)+wrapRecExp f e                    = f e++mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x+mapExp _ f@(CmmEntry{})                          = f+mapExp _ m@(CmmComment _)                        = m+mapExp _ m@(CmmTick _)                           = m+mapExp f   (CmmUnwind regs)                      = CmmUnwind (map (fmap (fmap f)) regs)+mapExp f   (CmmAssign r e)                       = CmmAssign r (f e)+mapExp f   (CmmStore addr e)                     = CmmStore (f addr) (f e)+mapExp f   (CmmUnsafeForeignCall tgt fs as)      = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)+mapExp _ l@(CmmBranch _)                         = l+mapExp f   (CmmCondBranch e ti fi l)             = CmmCondBranch (f e) ti fi l+mapExp f   (CmmSwitch e ids)                     = CmmSwitch (f e) ids+mapExp f   n@CmmCall {cml_target=tgt}            = n{cml_target = f tgt}+mapExp f   (CmmForeignCall tgt fs as succ ret_args updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ ret_args updfr intrbl++mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x+mapExpDeep f = mapExp $ wrapRecExp f++------------------------------------------------------------------------+-- mapping Expr in CmmNode, but not performing allocation if no changes++mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget+mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e+mapForeignTargetM _ (PrimTarget _)      = Nothing++wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr)+-- (wrapRecExpM f e) first recursively applies itself to sub-expressions of e+--                   then  gives f a chance to rewrite the resulting expression+wrapRecExpM f n@(CmmMachOp op es)  = maybe (f n) (f . CmmMachOp op)    (mapListM (wrapRecExpM f) es)+wrapRecExpM f n@(CmmLoad addr ty)  = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr)+wrapRecExpM f e                    = f e++mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)+mapExpM _ (CmmEntry{})              = Nothing+mapExpM _ (CmmComment _)            = Nothing+mapExpM _ (CmmTick _)               = Nothing+mapExpM f (CmmUnwind regs)          = CmmUnwind `fmap` mapM (\(r,e) -> mapM f e >>= \e' -> pure (r,e')) regs+mapExpM f (CmmAssign r e)           = CmmAssign r `fmap` f e+mapExpM f (CmmStore addr e)         = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e]+mapExpM _ (CmmBranch _)             = Nothing+mapExpM f (CmmCondBranch e ti fi l) = (\x -> CmmCondBranch x ti fi l) `fmap` f e+mapExpM f (CmmSwitch e tbl)         = (\x -> CmmSwitch x tbl)       `fmap` f e+mapExpM f (CmmCall tgt mb_id r o i s) = (\x -> CmmCall x mb_id r o i s) `fmap` f tgt+mapExpM f (CmmUnsafeForeignCall tgt fs as)+    = case mapForeignTargetM f tgt of+        Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as))+        Nothing   -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as+mapExpM f (CmmForeignCall tgt fs as succ ret_args updfr intrbl)+    = case mapForeignTargetM f tgt of+        Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ ret_args updfr intrbl)+        Nothing   -> (\xs -> CmmForeignCall tgt fs xs succ ret_args updfr intrbl) `fmap` mapListM f as++-- share as much as possible+mapListM :: (a -> Maybe a) -> [a] -> Maybe [a]+mapListM f xs = let (b, r) = mapListT f xs+                in if b then Just r else Nothing++mapListJ :: (a -> Maybe a) -> [a] -> [a]+mapListJ f xs = snd (mapListT f xs)++mapListT :: (a -> Maybe a) -> [a] -> (Bool, [a])+mapListT f xs = foldr g (False, []) (zip3 (tails xs) xs (map f xs))+    where g (_,   y, Nothing) (True, ys)  = (True,  y:ys)+          g (_,   _, Just y)  (True, ys)  = (True,  y:ys)+          g (ys', _, Nothing) (False, _)  = (False, ys')+          g (_,   _, Just y)  (False, ys) = (True,  y:ys)++mapExpDeepM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)+mapExpDeepM f = mapExpM $ wrapRecExpM f++-----------------------------------+-- folding Expr in CmmNode++foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z+foldExpForeignTarget exp (ForeignTarget e _) z = exp e z+foldExpForeignTarget _   (PrimTarget _)      z = z++-- Take a folder on expressions and apply it recursively.+-- Specifically (wrapRecExpf f e z) deals with CmmMachOp and CmmLoad+-- itself, delegating all the other CmmExpr forms to 'f'.+wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z+wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es+wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)+wrapRecExpf f e                  z = f e z++foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z+foldExp _ (CmmEntry {}) z                         = z+foldExp _ (CmmComment {}) z                       = z+foldExp _ (CmmTick {}) z                          = z+foldExp f (CmmUnwind xs) z                        = foldr (maybe id f) z (map snd xs)+foldExp f (CmmAssign _ e) z                       = f e z+foldExp f (CmmStore addr e) z                     = f addr $ f e z+foldExp f (CmmUnsafeForeignCall t _ as) z         = foldr f (foldExpForeignTarget f t z) as+foldExp _ (CmmBranch _) z                         = z+foldExp f (CmmCondBranch e _ _ _) z               = f e z+foldExp f (CmmSwitch e _) z                       = f e z+foldExp f (CmmCall {cml_target=tgt}) z            = f tgt z+foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args++foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z+foldExpDeep f = foldExp (wrapRecExpf f)++-- -----------------------------------------------------------------------------++mapSuccessors :: (Label -> Label) -> CmmNode O C -> CmmNode O C+mapSuccessors f (CmmBranch bid)         = CmmBranch (f bid)+mapSuccessors f (CmmCondBranch p y n l) = CmmCondBranch p (f y) (f n) l+mapSuccessors f (CmmSwitch e ids)       = CmmSwitch e (mapSwitchTargets f ids)+mapSuccessors _ n = n++-- -----------------------------------------------------------------------------++-- | Tickish in Cmm context (annotations only)+type CmmTickish = Tickish ()++-- | Tick scope identifier, allowing us to reason about what+-- annotations in a Cmm block should scope over. We especially take+-- care to allow optimisations to reorganise blocks without losing+-- tick association in the process.+data CmmTickScope+  = GlobalScope+    -- ^ The global scope is the "root" of the scope graph. Every+    -- scope is a sub-scope of the global scope. It doesn't make sense+    -- to add ticks to this scope. On the other hand, this means that+    -- setting this scope on a block means no ticks apply to it.++  | SubScope !U.Unique CmmTickScope+    -- ^ Constructs a new sub-scope to an existing scope. This allows+    -- us to translate Core-style scoping rules (see @tickishScoped@)+    -- into the Cmm world. Suppose the following code:+    --+    --   tick<1> case ... of+    --             A -> tick<2> ...+    --             B -> tick<3> ...+    --+    -- We want the top-level tick annotation to apply to blocks+    -- generated for the A and B alternatives. We can achieve that by+    -- generating tick<1> into a block with scope a, while the code+    -- for alternatives A and B gets generated into sub-scopes a/b and+    -- a/c respectively.++  | CombinedScope CmmTickScope CmmTickScope+    -- ^ A combined scope scopes over everything that the two given+    -- scopes cover. It is therefore a sub-scope of either scope. This+    -- is required for optimisations. Consider common block elimination:+    --+    --   A -> tick<2> case ... of+    --     C -> [common]+    --   B -> tick<3> case ... of+    --     D -> [common]+    --+    -- We will generate code for the C and D alternatives, and figure+    -- out afterwards that it's actually common code. Scoping rules+    -- dictate that the resulting common block needs to be covered by+    -- both tick<2> and tick<3>, therefore we need to construct a+    -- scope that is a child to *both* scope. Now we can do that - if+    -- we assign the scopes a/c and b/d to the common-ed up blocks,+    -- the new block could have a combined tick scope a/c+b/d, which+    -- both tick<2> and tick<3> apply to.++-- Note [CmmTick scoping details]:+--+-- The scope of a @CmmTick@ is given by the @CmmEntry@ node of the+-- same block. Note that as a result of this, optimisations making+-- tick scopes more specific can *reduce* the amount of code a tick+-- scopes over. Fixing this would require a separate @CmmTickScope@+-- field for @CmmTick@. Right now we do not do this simply because I+-- couldn't find an example where it actually mattered -- multiple+-- blocks within the same scope generally jump to each other, which+-- prevents common block elimination from happening in the first+-- place. But this is no strong reason, so if Cmm optimisations become+-- more involved in future this might have to be revisited.++-- | Output all scope paths.+scopeToPaths :: CmmTickScope -> [[U.Unique]]+scopeToPaths GlobalScope           = [[]]+scopeToPaths (SubScope u s)        = map (u:) (scopeToPaths s)+scopeToPaths (CombinedScope s1 s2) = scopeToPaths s1 ++ scopeToPaths s2++-- | Returns the head uniques of the scopes. This is based on the+-- assumption that the @Unique@ of @SubScope@ identifies the+-- underlying super-scope. Used for efficient equality and comparison,+-- see below.+scopeUniques :: CmmTickScope -> [U.Unique]+scopeUniques GlobalScope           = []+scopeUniques (SubScope u _)        = [u]+scopeUniques (CombinedScope s1 s2) = scopeUniques s1 ++ scopeUniques s2++-- Equality and order is based on the head uniques defined above. We+-- take care to short-cut the (extremly) common cases.+instance Eq CmmTickScope where+  GlobalScope    == GlobalScope     = True+  GlobalScope    == _               = False+  _              == GlobalScope     = False+  (SubScope u _) == (SubScope u' _) = u == u'+  (SubScope _ _) == _               = False+  _              == (SubScope _ _)  = False+  scope          == scope'          =+    sortBy nonDetCmpUnique (scopeUniques scope) ==+    sortBy nonDetCmpUnique (scopeUniques scope')+    -- This is still deterministic because+    -- the order is the same for equal lists++-- This is non-deterministic but we do not currently support deterministic+-- code-generation. See Note [Unique Determinism and code generation]+-- See Note [No Ord for Unique]+instance Ord CmmTickScope where+  compare GlobalScope    GlobalScope     = EQ+  compare GlobalScope    _               = LT+  compare _              GlobalScope     = GT+  compare (SubScope u _) (SubScope u' _) = nonDetCmpUnique u u'+  compare scope scope'                   = cmpList nonDetCmpUnique+     (sortBy nonDetCmpUnique $ scopeUniques scope)+     (sortBy nonDetCmpUnique $ scopeUniques scope')++instance Outputable CmmTickScope where+  ppr GlobalScope     = text "global"+  ppr (SubScope us GlobalScope)+                      = ppr us+  ppr (SubScope us s) = ppr s <> char '/' <> ppr us+  ppr combined        = parens $ hcat $ punctuate (char '+') $+                        map (hcat . punctuate (char '/') . map ppr . reverse) $+                        scopeToPaths combined++-- | Checks whether two tick scopes are sub-scopes of each other. True+-- if the two scopes are equal.+isTickSubScope :: CmmTickScope -> CmmTickScope -> Bool+isTickSubScope = cmp+  where cmp _              GlobalScope             = True+        cmp GlobalScope    _                       = False+        cmp (CombinedScope s1 s2) s'               = cmp s1 s' && cmp s2 s'+        cmp s              (CombinedScope s1' s2') = cmp s s1' || cmp s s2'+        cmp (SubScope u s) s'@(SubScope u' _)      = u == u' || cmp s s'++-- | Combine two tick scopes. The new scope should be sub-scope of+-- both parameters. We simplfy automatically if one tick scope is a+-- sub-scope of the other already.+combineTickScopes :: CmmTickScope -> CmmTickScope -> CmmTickScope+combineTickScopes s1 s2+  | s1 `isTickSubScope` s2 = s1+  | s2 `isTickSubScope` s1 = s2+  | otherwise              = CombinedScope s1 s2
+ cmm/CmmOpt.hs view
@@ -0,0 +1,392 @@+{-# LANGUAGE CPP #-}++-- The default iteration limit is a bit too low for the definitions+-- in this module.+#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}+#endif++-----------------------------------------------------------------------------+--+-- Cmm optimisation+--+-- (c) The University of Glasgow 2006+--+-----------------------------------------------------------------------------++module CmmOpt (+        constantFoldNode,+        constantFoldExpr,+        cmmMachOpFold,+        cmmMachOpFoldM+ ) where++#include "HsVersions.h"++import CmmUtils+import Cmm+import DynFlags+import Util++import Outputable+import Platform++import Data.Bits+import Data.Maybe+++constantFoldNode :: DynFlags -> CmmNode e x -> CmmNode e x+constantFoldNode dflags = mapExp (constantFoldExpr dflags)++constantFoldExpr :: DynFlags -> CmmExpr -> CmmExpr+constantFoldExpr dflags = wrapRecExp f+  where f (CmmMachOp op args) = cmmMachOpFold dflags op args+        f (CmmRegOff r 0) = CmmReg r+        f e = e++-- -----------------------------------------------------------------------------+-- MachOp constant folder++-- Now, try to constant-fold the MachOps.  The arguments have already+-- been optimized and folded.++cmmMachOpFold+    :: DynFlags+    -> MachOp       -- The operation from an CmmMachOp+    -> [CmmExpr]    -- The optimized arguments+    -> CmmExpr++cmmMachOpFold dflags op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM dflags op args)++-- Returns Nothing if no changes, useful for Hoopl, also reduces+-- allocation!+cmmMachOpFoldM+    :: DynFlags+    -> MachOp+    -> [CmmExpr]+    -> Maybe CmmExpr++cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)]+  = Just $ case op of+      MO_S_Neg _ -> CmmLit (CmmInt (-x) rep)+      MO_Not _   -> CmmLit (CmmInt (complement x) rep)++        -- these are interesting: we must first narrow to the+        -- "from" type, in order to truncate to the correct size.+        -- The final narrow/widen to the destination type+        -- is implicit in the CmmLit.+      MO_SF_Conv _from to -> CmmLit (CmmFloat (fromInteger x) to)+      MO_SS_Conv  from to -> CmmLit (CmmInt (narrowS from x) to)+      MO_UU_Conv  from to -> CmmLit (CmmInt (narrowU from x) to)++      _ -> panic $ "cmmMachOpFoldM: unknown unary op: " ++ show op+++-- Eliminate conversion NOPs+cmmMachOpFoldM _ (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = Just x+cmmMachOpFoldM _ (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = Just x++-- Eliminate nested conversions where possible+cmmMachOpFoldM dflags conv_outer [CmmMachOp conv_inner [x]]+  | Just (rep1,rep2,signed1) <- isIntConversion conv_inner,+    Just (_,   rep3,signed2) <- isIntConversion conv_outer+  = case () of+        -- widen then narrow to the same size is a nop+      _ | rep1 < rep2 && rep1 == rep3 -> Just x+        -- Widen then narrow to different size: collapse to single conversion+        -- but remember to use the signedness from the widening, just in case+        -- the final conversion is a widen.+        | rep1 < rep2 && rep2 > rep3 ->+            Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x]+        -- Nested widenings: collapse if the signedness is the same+        | rep1 < rep2 && rep2 < rep3 && signed1 == signed2 ->+            Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x]+        -- Nested narrowings: collapse+        | rep1 > rep2 && rep2 > rep3 ->+            Just $ cmmMachOpFold dflags (MO_UU_Conv rep1 rep3) [x]+        | otherwise ->+            Nothing+  where+        isIntConversion (MO_UU_Conv rep1 rep2)+          = Just (rep1,rep2,False)+        isIntConversion (MO_SS_Conv rep1 rep2)+          = Just (rep1,rep2,True)+        isIntConversion _ = Nothing++        intconv True  = MO_SS_Conv+        intconv False = MO_UU_Conv++-- ToDo: a narrow of a load can be collapsed into a narrow load, right?+-- but what if the architecture only supports word-sized loads, should+-- we do the transformation anyway?++cmmMachOpFoldM dflags mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]+  = case mop of+        -- for comparisons: don't forget to narrow the arguments before+        -- comparing, since they might be out of range.+        MO_Eq _   -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) (wordWidth dflags))+        MO_Ne _   -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) (wordWidth dflags))++        MO_U_Gt _ -> Just $ CmmLit (CmmInt (if x_u >  y_u then 1 else 0) (wordWidth dflags))+        MO_U_Ge _ -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) (wordWidth dflags))+        MO_U_Lt _ -> Just $ CmmLit (CmmInt (if x_u <  y_u then 1 else 0) (wordWidth dflags))+        MO_U_Le _ -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) (wordWidth dflags))++        MO_S_Gt _ -> Just $ CmmLit (CmmInt (if x_s >  y_s then 1 else 0) (wordWidth dflags))+        MO_S_Ge _ -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) (wordWidth dflags))+        MO_S_Lt _ -> Just $ CmmLit (CmmInt (if x_s <  y_s then 1 else 0) (wordWidth dflags))+        MO_S_Le _ -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth dflags))++        MO_Add r -> Just $ CmmLit (CmmInt (x + y) r)+        MO_Sub r -> Just $ CmmLit (CmmInt (x - y) r)+        MO_Mul r -> Just $ CmmLit (CmmInt (x * y) r)+        MO_U_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `quot` y_u) r)+        MO_U_Rem  r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `rem`  y_u) r)+        MO_S_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x `quot` y) r)+        MO_S_Rem  r | y /= 0 -> Just $ CmmLit (CmmInt (x `rem` y) r)++        MO_And   r -> Just $ CmmLit (CmmInt (x .&. y) r)+        MO_Or    r -> Just $ CmmLit (CmmInt (x .|. y) r)+        MO_Xor   r -> Just $ CmmLit (CmmInt (x `xor` y) r)++        MO_Shl   r -> Just $ CmmLit (CmmInt (x `shiftL` fromIntegral y) r)+        MO_U_Shr r -> Just $ CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r)+        MO_S_Shr r -> Just $ CmmLit (CmmInt (x `shiftR` fromIntegral y) r)++        _          -> Nothing++   where+        x_u = narrowU xrep x+        y_u = narrowU xrep y+        x_s = narrowS xrep x+        y_s = narrowS xrep y+++-- When possible, shift the constants to the right-hand side, so that we+-- can match for strength reductions.  Note that the code generator will+-- also assume that constants have been shifted to the right when+-- possible.++cmmMachOpFoldM dflags op [x@(CmmLit _), y]+   | not (isLit y) && isCommutableMachOp op+   = Just (cmmMachOpFold dflags op [y, x])++-- Turn (a+b)+c into a+(b+c) where possible.  Because literals are+-- moved to the right, it is more likely that we will find+-- opportunities for constant folding when the expression is+-- right-associated.+--+-- ToDo: this appears to introduce a quadratic behaviour due to the+-- nested cmmMachOpFold.  Can we fix this?+--+-- Why do we check isLit arg1?  If arg1 is a lit, it means that arg2+-- is also a lit (otherwise arg1 would be on the right).  If we+-- put arg1 on the left of the rearranged expression, we'll get into a+-- loop:  (x1+x2)+x3 => x1+(x2+x3)  => (x2+x3)+x1 => x2+(x3+x1) ...+--+-- Also don't do it if arg1 is PicBaseReg, so that we don't separate the+-- PicBaseReg from the corresponding label (or label difference).+--+cmmMachOpFoldM dflags mop1 [CmmMachOp mop2 [arg1,arg2], arg3]+   | mop2 `associates_with` mop1+     && not (isLit arg1) && not (isPicReg arg1)+   = Just (cmmMachOpFold dflags mop2 [arg1, cmmMachOpFold dflags mop1 [arg2,arg3]])+   where+     MO_Add{} `associates_with` MO_Sub{} = True+     mop1 `associates_with` mop2 =+        mop1 == mop2 && isAssociativeMachOp mop1++-- special case: (a - b) + c  ==>  a + (c - b)+cmmMachOpFoldM dflags mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3]+   | not (isLit arg1) && not (isPicReg arg1)+   = Just (cmmMachOpFold dflags mop1 [arg1, cmmMachOpFold dflags mop2 [arg3,arg2]])++-- special case: (PicBaseReg + lit) + N  ==>  PicBaseReg + (lit+N)+--+-- this is better because lit+N is a single link-time constant (e.g. a+-- CmmLabelOff), so the right-hand expression needs only one+-- instruction, whereas the left needs two.  This happens when pointer+-- tagging gives us label+offset, and PIC turns the label into+-- PicBaseReg + label.+--+cmmMachOpFoldM _ MO_Add{} [ CmmMachOp op@MO_Add{} [pic, CmmLit lit]+                          , CmmLit (CmmInt n rep) ]+  | isPicReg pic+  = Just $ CmmMachOp op [pic, CmmLit $ cmmOffsetLit lit off ]+  where off = fromIntegral (narrowS rep n)++-- Make a RegOff if we can+cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)]+  = Just $ cmmRegOff reg (fromIntegral (narrowS rep n))+cmmMachOpFoldM _ (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]+  = Just $ cmmRegOff reg (off + fromIntegral (narrowS rep n))+cmmMachOpFoldM _ (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)]+  = Just $ cmmRegOff reg (- fromIntegral (narrowS rep n))+cmmMachOpFoldM _ (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]+  = Just $ cmmRegOff reg (off - fromIntegral (narrowS rep n))++-- Fold label(+/-)offset into a CmmLit where possible++cmmMachOpFoldM _ (MO_Add _) [CmmLit lit, CmmLit (CmmInt i rep)]+  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i)))+cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmInt i rep), CmmLit lit]+  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i)))+cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)]+  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (negate (narrowU rep i))))+++-- Comparison of literal with widened operand: perform the comparison+-- at the smaller width, as long as the literal is within range.++-- We can't do the reverse trick, when the operand is narrowed:+-- narrowing throws away bits from the operand, there's no way to do+-- the same comparison at the larger size.++cmmMachOpFoldM dflags cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]+  |     -- powerPC NCG has a TODO for I8/I16 comparisons, so don't try+    platformArch (targetPlatform dflags) `elem` [ArchX86, ArchX86_64],+        -- if the operand is widened:+    Just (rep, signed, narrow_fn) <- maybe_conversion conv,+        -- and this is a comparison operation:+    Just narrow_cmp <- maybe_comparison cmp rep signed,+        -- and the literal fits in the smaller size:+    i == narrow_fn rep i+        -- then we can do the comparison at the smaller size+  = Just (cmmMachOpFold dflags narrow_cmp [x, CmmLit (CmmInt i rep)])+ where+    maybe_conversion (MO_UU_Conv from to)+        | to > from+        = Just (from, False, narrowU)+    maybe_conversion (MO_SS_Conv from to)+        | to > from+        = Just (from, True, narrowS)++        -- don't attempt to apply this optimisation when the source+        -- is a float; see #1916+    maybe_conversion _ = Nothing++        -- careful (#2080): if the original comparison was signed, but+        -- we were doing an unsigned widen, then we must do an+        -- unsigned comparison at the smaller size.+    maybe_comparison (MO_U_Gt _) rep _     = Just (MO_U_Gt rep)+    maybe_comparison (MO_U_Ge _) rep _     = Just (MO_U_Ge rep)+    maybe_comparison (MO_U_Lt _) rep _     = Just (MO_U_Lt rep)+    maybe_comparison (MO_U_Le _) rep _     = Just (MO_U_Le rep)+    maybe_comparison (MO_Eq   _) rep _     = Just (MO_Eq   rep)+    maybe_comparison (MO_S_Gt _) rep True  = Just (MO_S_Gt rep)+    maybe_comparison (MO_S_Ge _) rep True  = Just (MO_S_Ge rep)+    maybe_comparison (MO_S_Lt _) rep True  = Just (MO_S_Lt rep)+    maybe_comparison (MO_S_Le _) rep True  = Just (MO_S_Le rep)+    maybe_comparison (MO_S_Gt _) rep False = Just (MO_U_Gt rep)+    maybe_comparison (MO_S_Ge _) rep False = Just (MO_U_Ge rep)+    maybe_comparison (MO_S_Lt _) rep False = Just (MO_U_Lt rep)+    maybe_comparison (MO_S_Le _) rep False = Just (MO_U_Le rep)+    maybe_comparison _ _ _ = Nothing++-- We can often do something with constants of 0 and 1 ...++cmmMachOpFoldM dflags mop [x, y@(CmmLit (CmmInt 0 _))]+  = case mop of+        MO_Add   _ -> Just x+        MO_Sub   _ -> Just x+        MO_Mul   _ -> Just y+        MO_And   _ -> Just y+        MO_Or    _ -> Just x+        MO_Xor   _ -> Just x+        MO_Shl   _ -> Just x+        MO_S_Shr _ -> Just x+        MO_U_Shr _ -> Just x+        MO_Ne    _ | isComparisonExpr x -> Just x+        MO_Eq    _ | Just x' <- maybeInvertCmmExpr x -> Just x'+        MO_U_Gt  _ | isComparisonExpr x -> Just x+        MO_S_Gt  _ | isComparisonExpr x -> Just x+        MO_U_Lt  _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 (wordWidth dflags))+        MO_S_Lt  _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 (wordWidth dflags))+        MO_U_Ge  _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 (wordWidth dflags))+        MO_S_Ge  _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 (wordWidth dflags))+        MO_U_Le  _ | Just x' <- maybeInvertCmmExpr x -> Just x'+        MO_S_Le  _ | Just x' <- maybeInvertCmmExpr x -> Just x'+        _ -> Nothing++cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt 1 rep))]+  = case mop of+        MO_Mul    _ -> Just x+        MO_S_Quot _ -> Just x+        MO_U_Quot _ -> Just x+        MO_S_Rem  _ -> Just $ CmmLit (CmmInt 0 rep)+        MO_U_Rem  _ -> Just $ CmmLit (CmmInt 0 rep)+        MO_Ne    _ | Just x' <- maybeInvertCmmExpr x -> Just x'+        MO_Eq    _ | isComparisonExpr x -> Just x+        MO_U_Lt  _ | Just x' <- maybeInvertCmmExpr x -> Just x'+        MO_S_Lt  _ | Just x' <- maybeInvertCmmExpr x -> Just x'+        MO_U_Gt  _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 (wordWidth dflags))+        MO_S_Gt  _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 (wordWidth dflags))+        MO_U_Le  _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 (wordWidth dflags))+        MO_S_Le  _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 (wordWidth dflags))+        MO_U_Ge  _ | isComparisonExpr x -> Just x+        MO_S_Ge  _ | isComparisonExpr x -> Just x+        _ -> Nothing++-- Now look for multiplication/division by powers of 2 (integers).++cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt n _))]+  = case mop of+        MO_Mul rep+           | Just p <- exactLog2 n ->+                 Just (cmmMachOpFold dflags (MO_Shl rep) [x, CmmLit (CmmInt p rep)])+        MO_U_Quot rep+           | Just p <- exactLog2 n ->+                 Just (cmmMachOpFold dflags (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)])+        MO_S_Quot rep+           | Just p <- exactLog2 n,+             CmmReg _ <- x ->   -- We duplicate x below, hence require+                                -- it is a reg.  FIXME: remove this restriction.+                -- shift right is not the same as quot, because it rounds+                -- to minus infinity, whereasq quot rounds toward zero.+                -- To fix this up, we add one less than the divisor to the+                -- dividend if it is a negative number.+                --+                -- to avoid a test/jump, we use the following sequence:+                --      x1 = x >> word_size-1  (all 1s if -ve, all 0s if +ve)+                --      x2 = y & (divisor-1)+                --      result = (x+x2) >>= log2(divisor)+                -- this could be done a bit more simply using conditional moves,+                -- but we're processor independent here.+                --+                -- we optimise the divide by 2 case slightly, generating+                --      x1 = x >> word_size-1  (unsigned)+                --      return = (x + x1) >>= log2(divisor)+                let+                    bits = fromIntegral (widthInBits rep) - 1+                    shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep+                    x1 = CmmMachOp shr [x, CmmLit (CmmInt bits rep)]+                    x2 = if p == 1 then x1 else+                         CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)]+                    x3 = CmmMachOp (MO_Add rep) [x, x2]+                in+                Just (cmmMachOpFold dflags (MO_S_Shr rep) [x3, CmmLit (CmmInt p rep)])+        _ -> Nothing++-- ToDo (#7116): optimise floating-point multiplication, e.g. x*2.0 -> x+x+-- Unfortunately this needs a unique supply because x might not be a+-- register.  See #2253 (program 6) for an example.+++-- Anything else is just too hard.++cmmMachOpFoldM _ _ _ = Nothing++-- -----------------------------------------------------------------------------+-- Utils++isLit :: CmmExpr -> Bool+isLit (CmmLit _) = True+isLit _          = False++isComparisonExpr :: CmmExpr -> Bool+isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op+isComparisonExpr _                  = False++isPicReg :: CmmExpr -> Bool+isPicReg (CmmReg (CmmGlobal PicBaseReg)) = True+isPicReg _ = False
+ cmm/CmmParse.y view
@@ -0,0 +1,1419 @@+-----------------------------------------------------------------------------+--+-- (c) The University of Glasgow, 2004-2012+--+-- Parser for concrete Cmm.+--+-----------------------------------------------------------------------------++{- -----------------------------------------------------------------------------+Note [Syntax of .cmm files]++NOTE: You are very much on your own in .cmm.  There is very little+error checking at all:++  * Type errors are detected by the (optional) -dcmm-lint pass, if you+    don't turn this on then a type error will likely result in a panic+    from the native code generator.++  * Passing the wrong number of arguments or arguments of the wrong+    type is not detected.++There are two ways to write .cmm code:++ (1) High-level Cmm code delegates the stack handling to GHC, and+     never explicitly mentions Sp or registers.++ (2) Low-level Cmm manages the stack itself, and must know about+     calling conventions.++Whether you want high-level or low-level Cmm is indicated by the+presence of an argument list on a procedure.  For example:++foo ( gcptr a, bits32 b )+{+  // this is high-level cmm code++  if (b > 0) {+     // we can make tail calls passing arguments:+     jump stg_ap_0_fast(a);+  }++  push (stg_upd_frame_info, a) {+    // stack frames can be explicitly pushed++    (x,y) = call wibble(a,b,3,4);+      // calls pass arguments and return results using the native+      // Haskell calling convention.  The code generator will automatically+      // construct a stack frame and an info table for the continuation.++    return (x,y);+      // we can return multiple values from the current proc+  }+}++bar+{+  // this is low-level cmm code, indicated by the fact that we did not+  // put an argument list on bar.++  x = R1;  // the calling convention is explicit: better be careful+           // that this works on all platforms!++  jump %ENTRY_CODE(Sp(0))+}++Here is a list of rules for high-level and low-level code.  If you+break the rules, you get a panic (for using a high-level construct in+a low-level proc), or wrong code (when using low-level code in a+high-level proc).  This stuff isn't checked! (TODO!)++High-level only:++  - tail-calls with arguments, e.g.+    jump stg_fun (arg1, arg2);++  - function calls:+    (ret1,ret2) = call stg_fun (arg1, arg2);++    This makes a call with the NativeNodeCall convention, and the+    values are returned to the following code using the NativeReturn+    convention.++  - returning:+    return (ret1, ret2)++    These use the NativeReturn convention to return zero or more+    results to the caller.++  - pushing stack frames:+    push (info_ptr, field1, ..., fieldN) { ... statements ... }++  - reserving temporary stack space:++      reserve N = x { ... }++    this reserves an area of size N (words) on the top of the stack,+    and binds its address to x (a local register).  Typically this is+    used for allocating temporary storage for passing to foreign+    functions.++    Note that if you make any native calls or invoke the GC in the+    scope of the reserve block, you are responsible for ensuring that+    the stack you reserved is laid out correctly with an info table.++Low-level only:++  - References to Sp, R1-R8, F1-F4 etc.++    NB. foreign calls may clobber the argument registers R1-R8, F1-F4+    etc., so ensure they are saved into variables around foreign+    calls.++  - SAVE_THREAD_STATE() and LOAD_THREAD_STATE(), which modify Sp+    directly.++Both high-level and low-level code can use a raw tail-call:++    jump stg_fun [R1,R2]++NB. you *must* specify the list of GlobalRegs that are passed via a+jump, otherwise the register allocator will assume that all the+GlobalRegs are dead at the jump.+++Calling Conventions+-------------------++High-level procedures use the NativeNode calling convention, or the+NativeReturn convention if the 'return' keyword is used (see Stack+Frames below).++Low-level procedures implement their own calling convention, so it can+be anything at all.++If a low-level procedure implements the NativeNode calling convention,+then it can be called by high-level code using an ordinary function+call.  In general this is hard to arrange because the calling+convention depends on the number of physical registers available for+parameter passing, but there are two cases where the calling+convention is platform-independent:++ - Zero arguments.++ - One argument of pointer or non-pointer word type; this is always+   passed in R1 according to the NativeNode convention.++ - Returning a single value; these conventions are fixed and platform+   independent.+++Stack Frames+------------++A stack frame is written like this:++INFO_TABLE_RET ( label, FRAME_TYPE, info_ptr, field1, ..., fieldN )+               return ( arg1, ..., argM )+{+  ... code ...+}++where field1 ... fieldN are the fields of the stack frame (with types)+arg1...argN are the values returned to the stack frame (with types).+The return values are assumed to be passed according to the+NativeReturn convention.++On entry to the code, the stack frame looks like:++   |----------|+   | fieldN   |+   |   ...    |+   | field1   |+   |----------|+   | info_ptr |+   |----------|+   |  argN    |+   |   ...    | <- Sp++and some of the args may be in registers.++We prepend the code by a copyIn of the args, and assign all the stack+frame fields to their formals.  The initial "arg offset" for stack+layout purposes consists of the whole stack frame plus any args that+might be on the stack.++A tail-call may pass a stack frame to the callee using the following+syntax:++jump f (info_ptr, field1,..,fieldN) (arg1,..,argN)++where info_ptr and field1..fieldN describe the stack frame, and+arg1..argN are the arguments passed to f using the NativeNodeCall+convention. Note if a field is longer than a word (e.g. a D_ on+a 32-bit machine) then the call will push as many words as+necessary to the stack to accommodate it (e.g. 2).+++----------------------------------------------------------------------------- -}++{+module CmmParse ( parseCmmFile ) where++import StgCmmExtCode+import CmmCallConv+import StgCmmProf+import StgCmmHeap+import StgCmmMonad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit, emitStore+                          , emitAssign, emitOutOfLine, withUpdFrameOff+                          , getUpdFrameOff )+import qualified StgCmmMonad as F+import StgCmmUtils+import StgCmmForeign+import StgCmmExpr+import StgCmmClosure+import StgCmmLayout     hiding (ArgRep(..))+import StgCmmTicky+import StgCmmBind       ( emitBlackHoleCode, emitUpdateFrame )+import CoreSyn          ( Tickish(SourceNote) )++import CmmOpt+import MkGraph+import Cmm+import CmmUtils+import CmmSwitch        ( mkSwitchTargets )+import CmmInfo+import BlockId+import CmmLex+import CLabel+import SMRep+import Lexer+import CmmMonad++import CostCentre+import ForeignCall+import Module+import Platform+import Literal+import Unique+import UniqFM+import SrcLoc+import DynFlags+import ErrUtils+import StringBuffer+import FastString+import Panic+import Constants+import Outputable+import BasicTypes+import Bag              ( emptyBag, unitBag )+import Var++import Control.Monad+import Data.Array+import Data.Char        ( ord )+import System.Exit+import Data.Maybe+import qualified Data.Map as M++#include "HsVersions.h"+}++%expect 0++%token+        ':'     { L _ (CmmT_SpecChar ':') }+        ';'     { L _ (CmmT_SpecChar ';') }+        '{'     { L _ (CmmT_SpecChar '{') }+        '}'     { L _ (CmmT_SpecChar '}') }+        '['     { L _ (CmmT_SpecChar '[') }+        ']'     { L _ (CmmT_SpecChar ']') }+        '('     { L _ (CmmT_SpecChar '(') }+        ')'     { L _ (CmmT_SpecChar ')') }+        '='     { L _ (CmmT_SpecChar '=') }+        '`'     { L _ (CmmT_SpecChar '`') }+        '~'     { L _ (CmmT_SpecChar '~') }+        '/'     { L _ (CmmT_SpecChar '/') }+        '*'     { L _ (CmmT_SpecChar '*') }+        '%'     { L _ (CmmT_SpecChar '%') }+        '-'     { L _ (CmmT_SpecChar '-') }+        '+'     { L _ (CmmT_SpecChar '+') }+        '&'     { L _ (CmmT_SpecChar '&') }+        '^'     { L _ (CmmT_SpecChar '^') }+        '|'     { L _ (CmmT_SpecChar '|') }+        '>'     { L _ (CmmT_SpecChar '>') }+        '<'     { L _ (CmmT_SpecChar '<') }+        ','     { L _ (CmmT_SpecChar ',') }+        '!'     { L _ (CmmT_SpecChar '!') }++        '..'    { L _ (CmmT_DotDot) }+        '::'    { L _ (CmmT_DoubleColon) }+        '>>'    { L _ (CmmT_Shr) }+        '<<'    { L _ (CmmT_Shl) }+        '>='    { L _ (CmmT_Ge) }+        '<='    { L _ (CmmT_Le) }+        '=='    { L _ (CmmT_Eq) }+        '!='    { L _ (CmmT_Ne) }+        '&&'    { L _ (CmmT_BoolAnd) }+        '||'    { L _ (CmmT_BoolOr) }++        'CLOSURE'       { L _ (CmmT_CLOSURE) }+        'INFO_TABLE'    { L _ (CmmT_INFO_TABLE) }+        'INFO_TABLE_RET'{ L _ (CmmT_INFO_TABLE_RET) }+        'INFO_TABLE_FUN'{ L _ (CmmT_INFO_TABLE_FUN) }+        'INFO_TABLE_CONSTR'{ L _ (CmmT_INFO_TABLE_CONSTR) }+        'INFO_TABLE_SELECTOR'{ L _ (CmmT_INFO_TABLE_SELECTOR) }+        'else'          { L _ (CmmT_else) }+        'export'        { L _ (CmmT_export) }+        'section'       { L _ (CmmT_section) }+        'goto'          { L _ (CmmT_goto) }+        'if'            { L _ (CmmT_if) }+        'call'          { L _ (CmmT_call) }+        'jump'          { L _ (CmmT_jump) }+        'foreign'       { L _ (CmmT_foreign) }+        'never'         { L _ (CmmT_never) }+        'prim'          { L _ (CmmT_prim) }+        'reserve'       { L _ (CmmT_reserve) }+        'return'        { L _ (CmmT_return) }+        'returns'       { L _ (CmmT_returns) }+        'import'        { L _ (CmmT_import) }+        'switch'        { L _ (CmmT_switch) }+        'case'          { L _ (CmmT_case) }+        'default'       { L _ (CmmT_default) }+        'push'          { L _ (CmmT_push) }+        'unwind'        { L _ (CmmT_unwind) }+        'bits8'         { L _ (CmmT_bits8) }+        'bits16'        { L _ (CmmT_bits16) }+        'bits32'        { L _ (CmmT_bits32) }+        'bits64'        { L _ (CmmT_bits64) }+        'bits128'       { L _ (CmmT_bits128) }+        'bits256'       { L _ (CmmT_bits256) }+        'bits512'       { L _ (CmmT_bits512) }+        'float32'       { L _ (CmmT_float32) }+        'float64'       { L _ (CmmT_float64) }+        'gcptr'         { L _ (CmmT_gcptr) }++        GLOBALREG       { L _ (CmmT_GlobalReg   $$) }+        NAME            { L _ (CmmT_Name        $$) }+        STRING          { L _ (CmmT_String      $$) }+        INT             { L _ (CmmT_Int         $$) }+        FLOAT           { L _ (CmmT_Float       $$) }++%monad { PD } { >>= } { return }+%lexer { cmmlex } { L _ CmmT_EOF }+%name cmmParse cmm+%tokentype { Located CmmToken }++-- C-- operator precedences, taken from the C-- spec+%right '||'     -- non-std extension, called %disjoin in C--+%right '&&'     -- non-std extension, called %conjoin in C--+%right '!'+%nonassoc '>=' '>' '<=' '<' '!=' '=='+%left '|'+%left '^'+%left '&'+%left '>>' '<<'+%left '-' '+'+%left '/' '*' '%'+%right '~'++%%++cmm     :: { CmmParse () }+        : {- empty -}                   { return () }+        | cmmtop cmm                    { do $1; $2 }++cmmtop  :: { CmmParse () }+        : cmmproc                       { $1 }+        | cmmdata                       { $1 }+        | decl                          { $1 } +        | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'  +                {% liftP . withThisPackage $ \pkg ->+                   do lits <- sequence $6;+                      staticClosure pkg $3 $5 (map getLit lits) }++-- The only static closures in the RTS are dummy closures like+-- stg_END_TSO_QUEUE_closure and stg_dummy_ret.  We don't need+-- to provide the full generality of static closures here.+-- In particular:+--      * CCS can always be CCS_DONT_CARE+--      * closure is always extern+--      * payload is always empty+--      * we can derive closure and info table labels from a single NAME++cmmdata :: { CmmParse () }+        : 'section' STRING '{' data_label statics '}' +                { do lbl <- $4;+                     ss <- sequence $5;+                     code (emitDecl (CmmData (Section (section $2) lbl) (Statics lbl $ concat ss))) }++data_label :: { CmmParse CLabel }+    : NAME ':'  +                {% liftP . withThisPackage $ \pkg ->+                   return (mkCmmDataLabel pkg $1) }++statics :: { [CmmParse [CmmStatic]] }+        : {- empty -}                   { [] }+        | static statics                { $1 : $2 }+    +-- Strings aren't used much in the RTS HC code, so it doesn't seem+-- worth allowing inline strings.  C-- doesn't allow them anyway.+static  :: { CmmParse [CmmStatic] }+        : type expr ';' { do e <- $2;+                             return [CmmStaticLit (getLit e)] }+        | type ';'                      { return [CmmUninitialised+                                                        (widthInBytes (typeWidth $1))] }+        | 'bits8' '[' ']' STRING ';'    { return [mkString $4] }+        | 'bits8' '[' INT ']' ';'       { return [CmmUninitialised +                                                        (fromIntegral $3)] }+        | typenot8 '[' INT ']' ';'      { return [CmmUninitialised +                                                (widthInBytes (typeWidth $1) * +                                                        fromIntegral $3)] }+        | 'CLOSURE' '(' NAME lits ')'+                { do { lits <- sequence $4+                ; dflags <- getDynFlags+                     ; return $ map CmmStaticLit $+                        mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)+                         -- mkForeignLabel because these are only used+                         -- for CHARLIKE and INTLIKE closures in the RTS.+                        dontCareCCS (map getLit lits) [] [] [] } }+        -- arrays of closures required for the CHARLIKE & INTLIKE arrays++lits    :: { [CmmParse CmmExpr] }+        : {- empty -}           { [] }+        | ',' expr lits         { $2 : $3 }++cmmproc :: { CmmParse () }+        : info maybe_conv maybe_formals maybe_body+                { do ((entry_ret_label, info, stk_formals, formals), agraph) <-+                       getCodeScoped $ loopDecls $ do {+                         (entry_ret_label, info, stk_formals) <- $1;+                         dflags <- getDynFlags;+                         formals <- sequence (fromMaybe [] $3);+                         withName (showSDoc dflags (ppr entry_ret_label))+                           $4;+                         return (entry_ret_label, info, stk_formals, formals) }+                     let do_layout = isJust $3+                     code (emitProcWithStackFrame $2 info+                                entry_ret_label stk_formals formals agraph+                                do_layout ) }++maybe_conv :: { Convention }+           : {- empty -}        { NativeNodeCall }+           | 'return'           { NativeReturn }++maybe_body :: { CmmParse () }+           : ';'                { return () }+           | '{' body '}'       { withSourceNote $1 $3 $2 }++info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }+        : NAME+                {% liftP . withThisPackage $ \pkg ->+                   do   newFunctionName $1 pkg+                        return (mkCmmCodeLabel pkg $1, Nothing, []) }+++        | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'+                -- ptrs, nptrs, closure type, description, type+                {% liftP . withThisPackage $ \pkg ->+                   do dflags <- getDynFlags+                      let prof = profilingInfo dflags $11 $13+                          rep  = mkRTSRep (fromIntegral $9) $+                                   mkHeapRep dflags False (fromIntegral $5)+                                                   (fromIntegral $7) Thunk+                              -- not really Thunk, but that makes the info table+                              -- we want.+                      return (mkCmmEntryLabel pkg $3,+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3+                                           , cit_rep = rep+                                           , cit_prof = prof, cit_srt = NoC_SRT },+                              []) }+        +        | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'+                -- ptrs, nptrs, closure type, description, type, fun type+                {% liftP . withThisPackage $ \pkg ->+                   do dflags <- getDynFlags+                      let prof = profilingInfo dflags $11 $13+                          ty   = Fun 0 (ArgSpec (fromIntegral $15))+                                -- Arity zero, arg_type $15+                          rep = mkRTSRep (fromIntegral $9) $+                                    mkHeapRep dflags False (fromIntegral $5)+                                                    (fromIntegral $7) ty+                      return (mkCmmEntryLabel pkg $3,+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3+                                           , cit_rep = rep+                                           , cit_prof = prof, cit_srt = NoC_SRT },+                              []) }+                -- we leave most of the fields zero here.  This is only used+                -- to generate the BCO info table in the RTS at the moment.++        | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'+                -- ptrs, nptrs, tag, closure type, description, type+                {% liftP . withThisPackage $ \pkg ->+                   do dflags <- getDynFlags+                      let prof = profilingInfo dflags $13 $15+                          ty  = Constr (fromIntegral $9)  -- Tag+                                       (stringToWord8s $13)+                          rep = mkRTSRep (fromIntegral $11) $+                                  mkHeapRep dflags False (fromIntegral $5)+                                                  (fromIntegral $7) ty+                      return (mkCmmEntryLabel pkg $3,+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3+                                           , cit_rep = rep+                                           , cit_prof = prof, cit_srt = NoC_SRT },+                              []) }++                     -- If profiling is on, this string gets duplicated,+                     -- but that's the way the old code did it we can fix it some other time.+        +        | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'+                -- selector, closure type, description, type+                {% liftP . withThisPackage $ \pkg ->+                   do dflags <- getDynFlags+                      let prof = profilingInfo dflags $9 $11+                          ty  = ThunkSelector (fromIntegral $5)+                          rep = mkRTSRep (fromIntegral $7) $+                                   mkHeapRep dflags False 0 0 ty+                      return (mkCmmEntryLabel pkg $3,+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3+                                           , cit_rep = rep+                                           , cit_prof = prof, cit_srt = NoC_SRT },+                              []) }++        | 'INFO_TABLE_RET' '(' NAME ',' INT ')'+                -- closure type (no live regs)+                {% liftP . withThisPackage $ \pkg ->+                   do let prof = NoProfilingInfo+                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep []+                      return (mkCmmRetLabel pkg $3,+                              Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3+                                           , cit_rep = rep+                                           , cit_prof = prof, cit_srt = NoC_SRT },+                              []) }++        | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'+                -- closure type, live regs+                {% liftP . withThisPackage $ \pkg ->+                   do dflags <- getDynFlags+                      live <- sequence $7+                      let prof = NoProfilingInfo+                          -- drop one for the info pointer+                          bitmap = mkLiveness dflags (map Just (drop 1 live))+                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap+                      return (mkCmmRetLabel pkg $3,+                              Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3+                                           , cit_rep = rep+                                           , cit_prof = prof, cit_srt = NoC_SRT },+                              live) }++body    :: { CmmParse () }+        : {- empty -}                   { return () }+        | decl body                     { do $1; $2 }+        | stmt body                     { do $1; $2 }++decl    :: { CmmParse () }+        : type names ';'                { mapM_ (newLocal $1) $2 }+        | 'import' importNames ';'      { mapM_ newImport $2 }+        | 'export' names ';'            { return () }  -- ignore exports+++-- an imported function name, with optional packageId+importNames+        :: { [(FastString, CLabel)] }+        : importName                    { [$1] }+        | importName ',' importNames    { $1 : $3 }++importName+        :: { (FastString,  CLabel) }++        -- A label imported without an explicit packageId.+        --      These are taken to come frome some foreign, unnamed package.+        : NAME  +        { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }++        -- as previous 'NAME', but 'IsData'+        | 'CLOSURE' NAME+        { ($2, mkForeignLabel $2 Nothing ForeignLabelInExternalPackage IsData) }++        -- A label imported with an explicit packageId.+        | STRING NAME+        { ($2, mkCmmCodeLabel (fsToUnitId (mkFastString $1)) $2) }+        +        +names   :: { [FastString] }+        : NAME                          { [$1] }+        | NAME ',' names                { $1 : $3 }++stmt    :: { CmmParse () }+        : ';'                                   { return () }++        | NAME ':'+                { do l <- newLabel $1; emitLabel l }++++        | lreg '=' expr ';'+                { do reg <- $1; e <- $3; withSourceNote $2 $4 (emitAssign reg e) }+        | type '[' expr ']' '=' expr ';'+                { withSourceNote $2 $7 (doStore $1 $3 $6) }++        -- Gah! We really want to say "foreign_results" but that causes+        -- a shift/reduce conflict with assignment.  We either+        -- we expand out the no-result and single result cases or+        -- we tweak the syntax to avoid the conflict.  The later+        -- option is taken here because the other way would require+        -- multiple levels of expanding and get unwieldy.+        | foreign_results 'foreign' STRING foreignLabel '(' cmm_hint_exprs0 ')' safety opt_never_returns ';'+                {% foreignCall $3 $1 $4 $6 $8 $9 }+        | foreign_results 'prim' '%' NAME '(' exprs0 ')' ';'+                {% primCall $1 $4 $6 }+        -- stmt-level macros, stealing syntax from ordinary C-- function calls.+        -- Perhaps we ought to use the %%-form?+        | NAME '(' exprs0 ')' ';'+                {% stmtMacro $1 $3  }+        | 'switch' maybe_range expr '{' arms default '}'+                { do as <- sequence $5; doSwitch $2 $3 as $6 }+        | 'goto' NAME ';'+                { do l <- lookupLabel $2; emit (mkBranch l) }+        | 'return' '(' exprs0 ')' ';'+                { doReturn $3 }+        | 'jump' expr vols ';'+                { doRawJump $2 $3 }+        | 'jump' expr '(' exprs0 ')' ';'+                { doJumpWithStack $2 [] $4 }+        | 'jump' expr '(' exprs0 ')' '(' exprs0 ')' ';'+                { doJumpWithStack $2 $4 $7 }+        | 'call' expr '(' exprs0 ')' ';'+                { doCall $2 [] $4 }+        | '(' formals ')' '=' 'call' expr '(' exprs0 ')' ';'+                { doCall $6 $2 $8 }+        | 'if' bool_expr 'goto' NAME+                { do l <- lookupLabel $4; cmmRawIf $2 l }+        | 'if' bool_expr '{' body '}' else      +                { cmmIfThenElse $2 (withSourceNote $3 $5 $4) $6 }+        | 'push' '(' exprs0 ')' maybe_body+                { pushStackFrame $3 $5 }+        | 'reserve' expr '=' lreg maybe_body+                { reserveStackFrame $2 $4 $5 }+        | 'unwind' unwind_regs ';'+                { $2 >>= code . emitUnwind }++unwind_regs+        :: { CmmParse [(GlobalReg, Maybe CmmExpr)] }+        : GLOBALREG '=' expr_or_unknown ',' unwind_regs+                { do e <- $3; rest <- $5; return (($1, e) : rest) }+        | GLOBALREG '=' expr_or_unknown+                { do e <- $3; return [($1, e)] }++-- | Used by unwind to indicate unknown unwinding values.+expr_or_unknown+        :: { CmmParse (Maybe CmmExpr) }+        : 'return'+                { do return Nothing }+        | expr+                { do e <- $1; return (Just e) }++foreignLabel     :: { CmmParse CmmExpr }+        : NAME                          { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInThisPackage IsFunction))) }++opt_never_returns :: { CmmReturnInfo }+        :                               { CmmMayReturn }+        | 'never' 'returns'             { CmmNeverReturns }++bool_expr :: { CmmParse BoolExpr }+        : bool_op                       { $1 }+        | expr                          { do e <- $1; return (BoolTest e) }++bool_op :: { CmmParse BoolExpr }+        : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3; +                                          return (BoolAnd e1 e2) }+        | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3; +                                          return (BoolOr e1 e2)  }+        | '!' bool_expr                 { do e <- $2; return (BoolNot e) }+        | '(' bool_op ')'               { $2 }++safety  :: { Safety }+        : {- empty -}                   { PlayRisky }+        | STRING                        {% parseSafety $1 }++vols    :: { [GlobalReg] }+        : '[' ']'                       { [] }+        | '[' '*' ']'                   {% do df <- getDynFlags+                                         ; return (realArgRegsCover df) }+                                           -- All of them. See comment attached+                                           -- to realArgRegsCover+        | '[' globals ']'               { $2 }++globals :: { [GlobalReg] }+        : GLOBALREG                     { [$1] }+        | GLOBALREG ',' globals         { $1 : $3 }++maybe_range :: { Maybe (Integer,Integer) }+        : '[' INT '..' INT ']'  { Just ($2, $4) }+        | {- empty -}           { Nothing }++arms    :: { [CmmParse ([Integer],Either BlockId (CmmParse ()))] }+        : {- empty -}                   { [] }+        | arm arms                      { $1 : $2 }++arm     :: { CmmParse ([Integer],Either BlockId (CmmParse ())) }+        : 'case' ints ':' arm_body      { do b <- $4; return ($2, b) }++arm_body :: { CmmParse (Either BlockId (CmmParse ())) }+        : '{' body '}'                  { return (Right (withSourceNote $1 $3 $2)) }+        | 'goto' NAME ';'               { do l <- lookupLabel $2; return (Left l) }++ints    :: { [Integer] }+        : INT                           { [ $1 ] }+        | INT ',' ints                  { $1 : $3 }++default :: { Maybe (CmmParse ()) }+        : 'default' ':' '{' body '}'    { Just (withSourceNote $3 $5 $4) }+        -- taking a few liberties with the C-- syntax here; C-- doesn't have+        -- 'default' branches+        | {- empty -}                   { Nothing }++-- Note: OldCmm doesn't support a first class 'else' statement, though+-- CmmNode does.+else    :: { CmmParse () }+        : {- empty -}                   { return () }+        | 'else' '{' body '}'           { withSourceNote $2 $4 $3 }++-- we have to write this out longhand so that Happy's precedence rules+-- can kick in.+expr    :: { CmmParse CmmExpr }+        : expr '/' expr                 { mkMachOp MO_U_Quot [$1,$3] }+        | expr '*' expr                 { mkMachOp MO_Mul [$1,$3] }+        | expr '%' expr                 { mkMachOp MO_U_Rem [$1,$3] }+        | expr '-' expr                 { mkMachOp MO_Sub [$1,$3] }+        | expr '+' expr                 { mkMachOp MO_Add [$1,$3] }+        | expr '>>' expr                { mkMachOp MO_U_Shr [$1,$3] }+        | expr '<<' expr                { mkMachOp MO_Shl [$1,$3] }+        | expr '&' expr                 { mkMachOp MO_And [$1,$3] }+        | expr '^' expr                 { mkMachOp MO_Xor [$1,$3] }+        | expr '|' expr                 { mkMachOp MO_Or [$1,$3] }+        | expr '>=' expr                { mkMachOp MO_U_Ge [$1,$3] }+        | expr '>' expr                 { mkMachOp MO_U_Gt [$1,$3] }+        | expr '<=' expr                { mkMachOp MO_U_Le [$1,$3] }+        | expr '<' expr                 { mkMachOp MO_U_Lt [$1,$3] }+        | expr '!=' expr                { mkMachOp MO_Ne [$1,$3] }+        | expr '==' expr                { mkMachOp MO_Eq [$1,$3] }+        | '~' expr                      { mkMachOp MO_Not [$2] }+        | '-' expr                      { mkMachOp MO_S_Neg [$2] }+        | expr0 '`' NAME '`' expr0      {% do { mo <- nameToMachOp $3 ;+                                                return (mkMachOp mo [$1,$5]) } }+        | expr0                         { $1 }++expr0   :: { CmmParse CmmExpr }+        : INT   maybe_ty         { return (CmmLit (CmmInt $1 (typeWidth $2))) }+        | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 (typeWidth $2))) }+        | STRING                 { do s <- code (newStringCLit $1); +                                      return (CmmLit s) }+        | reg                    { $1 }+        | type '[' expr ']'      { do e <- $3; return (CmmLoad e $1) }+        | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }+        | '(' expr ')'           { $2 }+++-- leaving out the type of a literal gives you the native word size in C--+maybe_ty :: { CmmType }+        : {- empty -}                   {% do dflags <- getDynFlags; return $ bWord dflags }+        | '::' type                     { $2 }++cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] }+        : {- empty -}                   { [] }+        | cmm_hint_exprs                { $1 }++cmm_hint_exprs :: { [CmmParse (CmmExpr, ForeignHint)] }+        : cmm_hint_expr                 { [$1] }+        | cmm_hint_expr ',' cmm_hint_exprs      { $1 : $3 }++cmm_hint_expr :: { CmmParse (CmmExpr, ForeignHint) }+        : expr                          { do e <- $1;+                                             return (e, inferCmmHint e) }+        | expr STRING                   {% do h <- parseCmmHint $2;+                                              return $ do+                                                e <- $1; return (e, h) }++exprs0  :: { [CmmParse CmmExpr] }+        : {- empty -}                   { [] }+        | exprs                         { $1 }++exprs   :: { [CmmParse CmmExpr] }+        : expr                          { [ $1 ] }+        | expr ',' exprs                { $1 : $3 }++reg     :: { CmmParse CmmExpr }+        : NAME                  { lookupName $1 }+        | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }++foreign_results :: { [CmmParse (LocalReg, ForeignHint)] }+        : {- empty -}                   { [] }+        | '(' foreign_formals ')' '='   { $2 }++foreign_formals :: { [CmmParse (LocalReg, ForeignHint)] }+        : foreign_formal                        { [$1] }+        | foreign_formal ','                    { [$1] }+        | foreign_formal ',' foreign_formals    { $1 : $3 }++foreign_formal :: { CmmParse (LocalReg, ForeignHint) }+        : local_lreg            { do e <- $1; return (e, (inferCmmHint (CmmReg (CmmLocal e)))) }+        | STRING local_lreg     {% do h <- parseCmmHint $1;+                                      return $ do+                                         e <- $2; return (e,h) }++local_lreg :: { CmmParse LocalReg }+        : NAME                  { do e <- lookupName $1;+                                     return $+                                       case e of +                                        CmmReg (CmmLocal r) -> r+                                        other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }++lreg    :: { CmmParse CmmReg }+        : NAME                  { do e <- lookupName $1;+                                     return $+                                       case e of +                                        CmmReg r -> r+                                        other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }+        | GLOBALREG             { return (CmmGlobal $1) }++maybe_formals :: { Maybe [CmmParse LocalReg] }+        : {- empty -}           { Nothing }+        | '(' formals0 ')'      { Just $2 }++formals0 :: { [CmmParse LocalReg] }+        : {- empty -}           { [] }+        | formals               { $1 }++formals :: { [CmmParse LocalReg] }+        : formal ','            { [$1] }+        | formal                { [$1] }+        | formal ',' formals       { $1 : $3 }++formal :: { CmmParse LocalReg }+        : type NAME             { newLocal $1 $2 }++type    :: { CmmType }+        : 'bits8'               { b8 }+        | typenot8              { $1 }++typenot8 :: { CmmType }+        : 'bits16'              { b16 }+        | 'bits32'              { b32 }+        | 'bits64'              { b64 }+        | 'bits128'             { b128 }+        | 'bits256'             { b256 }+        | 'bits512'             { b512 }+        | 'float32'             { f32 }+        | 'float64'             { f64 }+        | 'gcptr'               {% do dflags <- getDynFlags; return $ gcWord dflags }++{+section :: String -> SectionType+section "text"      = Text+section "data"      = Data+section "rodata"    = ReadOnlyData+section "relrodata" = RelocatableReadOnlyData+section "bss"       = UninitialisedData+section s           = OtherSection s++mkString :: String -> CmmStatic+mkString s = CmmString (map (fromIntegral.ord) s)++-- |+-- Given an info table, decide what the entry convention for the proc+-- is.  That is, for an INFO_TABLE_RET we want the return convention,+-- otherwise it is a NativeNodeCall.+--+infoConv :: Maybe CmmInfoTable -> Convention+infoConv Nothing = NativeNodeCall+infoConv (Just info)+  | isStackRep (cit_rep info) = NativeReturn+  | otherwise                 = NativeNodeCall++-- mkMachOp infers the type of the MachOp from the type of its first+-- argument.  We assume that this is correct: for MachOps that don't have+-- symmetrical args (e.g. shift ops), the first arg determines the type of+-- the op.+mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr+mkMachOp fn args = do+  dflags <- getDynFlags+  arg_exprs <- sequence args+  return (CmmMachOp (fn (typeWidth (cmmExprType dflags (head arg_exprs)))) arg_exprs)++getLit :: CmmExpr -> CmmLit+getLit (CmmLit l) = l+getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)])  = CmmInt (negate i) r+getLit _ = panic "invalid literal" -- TODO messy failure++nameToMachOp :: FastString -> PD (Width -> MachOp)+nameToMachOp name =+  case lookupUFM machOps name of+        Nothing -> fail ("unknown primitive " ++ unpackFS name)+        Just m  -> return m++exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr)+exprOp name args_code = do+  dflags <- getDynFlags+  case lookupUFM (exprMacros dflags) name of+     Just f  -> return $ do+        args <- sequence args_code+        return (f args)+     Nothing -> do+        mo <- nameToMachOp name+        return $ mkMachOp mo args_code++exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr)+exprMacros dflags = listToUFM [+  ( fsLit "ENTRY_CODE",   \ [x] -> entryCode dflags x ),+  ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr dflags x ),+  ( fsLit "STD_INFO",     \ [x] -> infoTable dflags x ),+  ( fsLit "FUN_INFO",     \ [x] -> funInfoTable dflags x ),+  ( fsLit "GET_ENTRY",    \ [x] -> entryCode dflags (closureInfoPtr dflags x) ),+  ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr dflags x) ),+  ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr dflags x) ),+  ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType dflags x ),+  ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs dflags x ),+  ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs dflags x )+  ]++-- we understand a subset of C-- primitives:+machOps = listToUFM $+        map (\(x, y) -> (mkFastString x, y)) [+        ( "add",        MO_Add ),+        ( "sub",        MO_Sub ),+        ( "eq",         MO_Eq ),+        ( "ne",         MO_Ne ),+        ( "mul",        MO_Mul ),+        ( "neg",        MO_S_Neg ),+        ( "quot",       MO_S_Quot ),+        ( "rem",        MO_S_Rem ),+        ( "divu",       MO_U_Quot ),+        ( "modu",       MO_U_Rem ),++        ( "ge",         MO_S_Ge ),+        ( "le",         MO_S_Le ),+        ( "gt",         MO_S_Gt ),+        ( "lt",         MO_S_Lt ),++        ( "geu",        MO_U_Ge ),+        ( "leu",        MO_U_Le ),+        ( "gtu",        MO_U_Gt ),+        ( "ltu",        MO_U_Lt ),++        ( "and",        MO_And ),+        ( "or",         MO_Or ),+        ( "xor",        MO_Xor ),+        ( "com",        MO_Not ),+        ( "shl",        MO_Shl ),+        ( "shrl",       MO_U_Shr ),+        ( "shra",       MO_S_Shr ),++        ( "fadd",       MO_F_Add ),+        ( "fsub",       MO_F_Sub ),+        ( "fneg",       MO_F_Neg ),+        ( "fmul",       MO_F_Mul ),+        ( "fquot",      MO_F_Quot ),++        ( "feq",        MO_F_Eq ),+        ( "fne",        MO_F_Ne ),+        ( "fge",        MO_F_Ge ),+        ( "fle",        MO_F_Le ),+        ( "fgt",        MO_F_Gt ),+        ( "flt",        MO_F_Lt ),++        ( "lobits8",  flip MO_UU_Conv W8  ),+        ( "lobits16", flip MO_UU_Conv W16 ),+        ( "lobits32", flip MO_UU_Conv W32 ),+        ( "lobits64", flip MO_UU_Conv W64 ),++        ( "zx16",     flip MO_UU_Conv W16 ),+        ( "zx32",     flip MO_UU_Conv W32 ),+        ( "zx64",     flip MO_UU_Conv W64 ),++        ( "sx16",     flip MO_SS_Conv W16 ),+        ( "sx32",     flip MO_SS_Conv W32 ),+        ( "sx64",     flip MO_SS_Conv W64 ),++        ( "f2f32",    flip MO_FF_Conv W32 ),  -- TODO; rounding mode+        ( "f2f64",    flip MO_FF_Conv W64 ),  -- TODO; rounding mode+        ( "f2i8",     flip MO_FS_Conv W8 ),+        ( "f2i16",    flip MO_FS_Conv W16 ),+        ( "f2i32",    flip MO_FS_Conv W32 ),+        ( "f2i64",    flip MO_FS_Conv W64 ),+        ( "i2f32",    flip MO_SF_Conv W32 ),+        ( "i2f64",    flip MO_SF_Conv W64 )+        ]++callishMachOps :: UniqFM ([CmmExpr] -> (CallishMachOp, [CmmExpr]))+callishMachOps = listToUFM $+        map (\(x, y) -> (mkFastString x, y)) [+        ( "write_barrier", (,) MO_WriteBarrier ),+        ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ),+        ( "memset", memcpyLikeTweakArgs MO_Memset ),+        ( "memmove", memcpyLikeTweakArgs MO_Memmove ),++        ("prefetch0", (,) $ MO_Prefetch_Data 0),+        ("prefetch1", (,) $ MO_Prefetch_Data 1),+        ("prefetch2", (,) $ MO_Prefetch_Data 2),+        ("prefetch3", (,) $ MO_Prefetch_Data 3),++        ( "popcnt8",  (,) $ MO_PopCnt W8  ),+        ( "popcnt16", (,) $ MO_PopCnt W16 ),+        ( "popcnt32", (,) $ MO_PopCnt W32 ),+        ( "popcnt64", (,) $ MO_PopCnt W64 ),++        ( "cmpxchg8",  (,) $ MO_Cmpxchg W8  ),+        ( "cmpxchg16", (,) $ MO_Cmpxchg W16 ),+        ( "cmpxchg32", (,) $ MO_Cmpxchg W32 ),+        ( "cmpxchg64", (,) $ MO_Cmpxchg W64 )++        -- ToDo: the rest, maybe+        -- edit: which rest?+        -- also: how do we tell CMM Lint how to type check callish macops?+    ]+  where+    memcpyLikeTweakArgs :: (Int -> CallishMachOp) -> [CmmExpr] -> (CallishMachOp, [CmmExpr])+    memcpyLikeTweakArgs op [] = pgmError "memcpy-like function requires at least one argument"+    memcpyLikeTweakArgs op args@(_:_) =+        (op align, args')+      where+        args' = init args+        align = case last args of+          CmmLit (CmmInt alignInteger _) -> fromInteger alignInteger+          e -> pprPgmError "Non-constant alignment in memcpy-like function:" (ppr e)+        -- The alignment of memcpy-ish operations must be a+        -- compile-time constant. We verify this here, passing it around+        -- in the MO_* constructor. In order to do this, however, we+        -- must intercept the arguments in primCall.++parseSafety :: String -> PD Safety+parseSafety "safe"   = return PlaySafe+parseSafety "unsafe" = return PlayRisky+parseSafety "interruptible" = return PlayInterruptible+parseSafety str      = fail ("unrecognised safety: " ++ str)++parseCmmHint :: String -> PD ForeignHint+parseCmmHint "ptr"    = return AddrHint+parseCmmHint "signed" = return SignedHint+parseCmmHint str      = fail ("unrecognised hint: " ++ str)++-- labels are always pointers, so we might as well infer the hint+inferCmmHint :: CmmExpr -> ForeignHint+inferCmmHint (CmmLit (CmmLabel _)) = AddrHint+inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint+inferCmmHint _ = NoHint++isPtrGlobalReg Sp                    = True+isPtrGlobalReg SpLim                 = True+isPtrGlobalReg Hp                    = True+isPtrGlobalReg HpLim                 = True+isPtrGlobalReg CCCS                  = True+isPtrGlobalReg CurrentTSO            = True+isPtrGlobalReg CurrentNursery        = True+isPtrGlobalReg (VanillaReg _ VGcPtr) = True+isPtrGlobalReg _                     = False++happyError :: PD a+happyError = PD $ \_ s -> unP srcParseFail s++-- -----------------------------------------------------------------------------+-- Statement-level macros++stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ())+stmtMacro fun args_code = do+  case lookupUFM stmtMacros fun of+    Nothing -> fail ("unknown macro: " ++ unpackFS fun)+    Just fcode -> return $ do+        args <- sequence args_code+        code (fcode args)++stmtMacros :: UniqFM ([CmmExpr] -> FCode ())+stmtMacros = listToUFM [+  ( fsLit "CCS_ALLOC",             \[words,ccs]  -> profAlloc words ccs ),+  ( fsLit "ENTER_CCS_THUNK",       \[e] -> enterCostCentreThunk e ),++  ( fsLit "CLOSE_NURSERY",         \[]  -> emitCloseNursery ),+  ( fsLit "OPEN_NURSERY",          \[]  -> emitOpenNursery ),++  -- completely generic heap and stack checks, for use in high-level cmm.+  ( fsLit "HP_CHK_GEN",            \[bytes] ->+                                      heapStackCheckGen Nothing (Just bytes) ),+  ( fsLit "STK_CHK_GEN",           \[] ->+                                      heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ),++  -- A stack check for a fixed amount of stack.  Sounds a bit strange, but+  -- we use the stack for a bit of temporary storage in a couple of primops+  ( fsLit "STK_CHK_GEN_N",         \[bytes] ->+                                      heapStackCheckGen (Just bytes) Nothing ),++  -- A stack check on entry to a thunk, where the argument is the thunk pointer.+  ( fsLit "STK_CHK_NP"   ,         \[node] -> entryHeapCheck' False node 0 [] (return ())),++  ( fsLit "LOAD_THREAD_STATE",     \[] -> emitLoadThreadState ),+  ( fsLit "SAVE_THREAD_STATE",     \[] -> emitSaveThreadState ),++  ( fsLit "LDV_ENTER",             \[e] -> ldvEnter e ),+  ( fsLit "LDV_RECORD_CREATE",     \[e] -> ldvRecordCreate e ),++  ( fsLit "PUSH_UPD_FRAME",        \[sp,e] -> emitPushUpdateFrame sp e ),+  ( fsLit "SET_HDR",               \[ptr,info,ccs] ->+                                        emitSetDynHdr ptr info ccs ),+  ( fsLit "TICK_ALLOC_PRIM",       \[hdr,goods,slop] ->+                                        tickyAllocPrim hdr goods slop ),+  ( fsLit "TICK_ALLOC_PAP",        \[goods,slop] ->+                                        tickyAllocPAP goods slop ),+  ( fsLit "TICK_ALLOC_UP_THK",     \[goods,slop] ->+                                        tickyAllocThunk goods slop ),+  ( fsLit "UPD_BH_UPDATABLE",      \[reg] -> emitBlackHoleCode reg )+ ]++emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode ()+emitPushUpdateFrame sp e = do+  dflags <- getDynFlags+  emitUpdateFrame dflags sp mkUpdInfoLabel e++pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse ()+pushStackFrame fields body = do+  dflags <- getDynFlags+  exprs <- sequence fields+  updfr_off <- getUpdFrameOff+  let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old+                                           [] updfr_off exprs+  emit g+  withUpdFrameOff new_updfr_off body++reserveStackFrame+  :: CmmParse CmmExpr+  -> CmmParse CmmReg+  -> CmmParse ()+  -> CmmParse ()+reserveStackFrame psize preg body = do+  dflags <- getDynFlags+  old_updfr_off <- getUpdFrameOff+  reg <- preg+  esize <- psize+  let size = case constantFoldExpr dflags esize of+               CmmLit (CmmInt n _) -> n+               _other -> pprPanic "CmmParse: not a compile-time integer: "+                            (ppr esize)+  let frame = old_updfr_off + wORD_SIZE dflags * fromIntegral size+  emitAssign reg (CmmStackSlot Old frame)+  withUpdFrameOff frame body++profilingInfo dflags desc_str ty_str+  = if not (gopt Opt_SccProfilingOn dflags)+    then NoProfilingInfo+    else ProfilingInfo (stringToWord8s desc_str)+                       (stringToWord8s ty_str)++staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse ()+staticClosure pkg cl_label info payload+  = do dflags <- getDynFlags+       let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []+       code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits++foreignCall+        :: String+        -> [CmmParse (LocalReg, ForeignHint)]+        -> CmmParse CmmExpr+        -> [CmmParse (CmmExpr, ForeignHint)]+        -> Safety+        -> CmmReturnInfo+        -> PD (CmmParse ())+foreignCall conv_string results_code expr_code args_code safety ret+  = do  conv <- case conv_string of+          "C" -> return CCallConv+          "stdcall" -> return StdCallConv+          _ -> fail ("unknown calling convention: " ++ conv_string)+        return $ do+          dflags <- getDynFlags+          results <- sequence results_code+          expr <- expr_code+          args <- sequence args_code+          let+                  expr' = adjCallTarget dflags conv expr args+                  (arg_exprs, arg_hints) = unzip args+                  (res_regs,  res_hints) = unzip results+                  fc = ForeignConvention conv arg_hints res_hints ret+                  target = ForeignTarget expr' fc+          _ <- code $ emitForeignCall safety res_regs target arg_exprs+          return ()+++doReturn :: [CmmParse CmmExpr] -> CmmParse ()+doReturn exprs_code = do+  dflags <- getDynFlags+  exprs <- sequence exprs_code+  updfr_off <- getUpdFrameOff+  emit (mkReturnSimple dflags exprs updfr_off)++mkReturnSimple  :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph+mkReturnSimple dflags actuals updfr_off =+  mkReturn dflags e actuals updfr_off+  where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off)+                             (gcWord dflags))++doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()+doRawJump expr_code vols = do+  dflags <- getDynFlags+  expr <- expr_code+  updfr_off <- getUpdFrameOff+  emit (mkRawJump dflags expr updfr_off vols)++doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr]+                -> [CmmParse CmmExpr] -> CmmParse ()+doJumpWithStack expr_code stk_code args_code = do+  dflags <- getDynFlags+  expr <- expr_code+  stk_args <- sequence stk_code+  args <- sequence args_code+  updfr_off <- getUpdFrameOff+  emit (mkJumpExtra dflags NativeNodeCall expr args updfr_off stk_args)++doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]+       -> CmmParse ()+doCall expr_code res_code args_code = do+  dflags <- getDynFlags+  expr <- expr_code+  args <- sequence args_code+  ress <- sequence res_code+  updfr_off <- getUpdFrameOff+  c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off []+  emit c++adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]+              -> CmmExpr+-- On Windows, we have to add the '@N' suffix to the label when making+-- a call with the stdcall calling convention.+adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args+ | platformOS (targetPlatform dflags) == OSMinGW32+  = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))+  where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e)))+                 -- c.f. CgForeignCall.emitForeignCall+adjCallTarget _ _ expr _+  = expr++primCall+        :: [CmmParse (CmmFormal, ForeignHint)]+        -> FastString+        -> [CmmParse CmmExpr]+        -> PD (CmmParse ())+primCall results_code name args_code+  = case lookupUFM callishMachOps name of+        Nothing -> fail ("unknown primitive " ++ unpackFS name)+        Just f  -> return $ do+                results <- sequence results_code+                args <- sequence args_code+                let (p, args') = f args+                code (emitPrimCall (map fst results) p args')++doStore :: CmmType -> CmmParse CmmExpr  -> CmmParse CmmExpr -> CmmParse ()+doStore rep addr_code val_code+  = do dflags <- getDynFlags+       addr <- addr_code+       val <- val_code+        -- if the specified store type does not match the type of the expr+        -- on the rhs, then we insert a coercion that will cause the type+        -- mismatch to be flagged by cmm-lint.  If we don't do this, then+        -- the store will happen at the wrong type, and the error will not+        -- be noticed.+       let val_width = typeWidth (cmmExprType dflags val)+           rep_width = typeWidth rep+       let coerce_val+                | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]+                | otherwise              = val+       emitStore addr coerce_val++-- -----------------------------------------------------------------------------+-- If-then-else and boolean expressions++data BoolExpr+  = BoolExpr `BoolAnd` BoolExpr+  | BoolExpr `BoolOr`  BoolExpr+  | BoolNot BoolExpr+  | BoolTest CmmExpr++-- ToDo: smart constructors which simplify the boolean expression.++cmmIfThenElse cond then_part else_part = do+     then_id <- newBlockId+     join_id <- newBlockId+     c <- cond+     emitCond c then_id+     else_part+     emit (mkBranch join_id)+     emitLabel then_id+     then_part+     -- fall through to join+     emitLabel join_id++cmmRawIf cond then_id = do+    c <- cond+    emitCond c then_id++-- 'emitCond cond true_id'  emits code to test whether the cond is true,+-- branching to true_id if so, and falling through otherwise.+emitCond (BoolTest e) then_id = do+  else_id <- newBlockId+  emit (mkCbranch e then_id else_id Nothing)+  emitLabel else_id+emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id+  | Just op' <- maybeInvertComparison op+  = emitCond (BoolTest (CmmMachOp op' args)) then_id+emitCond (BoolNot e) then_id = do+  else_id <- newBlockId+  emitCond e else_id+  emit (mkBranch then_id)+  emitLabel else_id+emitCond (e1 `BoolOr` e2) then_id = do+  emitCond e1 then_id+  emitCond e2 then_id+emitCond (e1 `BoolAnd` e2) then_id = do+        -- we'd like to invert one of the conditionals here to avoid an+        -- extra branch instruction, but we can't use maybeInvertComparison+        -- here because we can't look too closely at the expression since+        -- we're in a loop.+  and_id <- newBlockId+  else_id <- newBlockId+  emitCond e1 and_id+  emit (mkBranch else_id)+  emitLabel and_id+  emitCond e2 then_id+  emitLabel else_id++-- -----------------------------------------------------------------------------+-- Source code notes++-- | Generate a source note spanning from "a" to "b" (inclusive), then+-- proceed with parsing. This allows debugging tools to reason about+-- locations in Cmm code.+withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c+withSourceNote a b parse = do+  name <- getName+  case combineSrcSpans (getLoc a) (getLoc b) of+    RealSrcSpan span -> code (emitTick (SourceNote span name)) >> parse+    _other           -> parse++-- -----------------------------------------------------------------------------+-- Table jumps++-- We use a simplified form of C-- switch statements for now.  A+-- switch statement always compiles to a table jump.  Each arm can+-- specify a list of values (not ranges), and there can be a single+-- default branch.  The range of the table is given either by the+-- optional range on the switch (eg. switch [0..7] {...}), or by+-- the minimum/maximum values from the branches.++doSwitch :: Maybe (Integer,Integer)+         -> CmmParse CmmExpr+         -> [([Integer],Either BlockId (CmmParse ()))]+         -> Maybe (CmmParse ()) -> CmmParse ()+doSwitch mb_range scrut arms deflt+   = do+        -- Compile code for the default branch+        dflt_entry <- +                case deflt of+                  Nothing -> return Nothing+                  Just e  -> do b <- forkLabelledCode e; return (Just b)++        -- Compile each case branch+        table_entries <- mapM emitArm arms+        let table = M.fromList (concat table_entries)++        dflags <- getDynFlags+        let range = fromMaybe (0, tARGET_MAX_WORD dflags) mb_range++        expr <- scrut+        -- ToDo: check for out of range and jump to default if necessary+        emit $ mkSwitch expr (mkSwitchTargets False range dflt_entry table)+   where+        emitArm :: ([Integer],Either BlockId (CmmParse ())) -> CmmParse [(Integer,BlockId)]+        emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]+        emitArm (ints,Right code) = do+           blockid <- forkLabelledCode code+           return [ (i,blockid) | i <- ints ]++forkLabelledCode :: CmmParse () -> CmmParse BlockId+forkLabelledCode p = do+  (_,ag) <- getCodeScoped p+  l <- newBlockId+  emitOutOfLine l ag+  return l++-- -----------------------------------------------------------------------------+-- Putting it all together++-- The initial environment: we define some constants that the compiler+-- knows about here.+initEnv :: DynFlags -> Env+initEnv dflags = listToUFM [+  ( fsLit "SIZEOF_StgHeader",+    VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth dflags)) )),+  ( fsLit "SIZEOF_StgInfoTable",+    VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) ))+  ]++parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)+parseCmmFile dflags filename = withTiming (pure dflags) (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do+  buf <- hGetStringBuffer filename+  let+        init_loc = mkRealSrcLoc (mkFastString filename) 1 1+        init_state = (mkPState dflags buf init_loc) { lex_state = [0] }+                -- reset the lex_state: the Lexer monad leaves some stuff+                -- in there we don't want.+  case unPD cmmParse dflags init_state of+    PFailed span err -> do+        let msg = mkPlainErrMsg dflags span err+        return ((emptyBag, unitBag msg), Nothing)+    POk pst code -> do+        st <- initC+        let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return ()+            (cmm,_) = runC dflags no_module st fcode+        let ms = getMessages pst dflags+        if (errorsFound dflags ms)+         then return (ms, Nothing)+         else return (ms, Just cmm)+  where+        no_module = panic "parseCmmFile: no module"+}
+ cmm/CmmPipeline.hs view
@@ -0,0 +1,365 @@+{-# LANGUAGE BangPatterns #-}++module CmmPipeline (+  -- | Converts C-- with an implicit stack and native C-- calls into+  -- optimized, CPS converted and native-call-less C--.  The latter+  -- C-- can be used to generate assembly.+  cmmPipeline+) where++import Cmm+import CmmLint+import CmmBuildInfoTables+import CmmCommonBlockElim+import CmmImplementSwitchPlans+import CmmProcPoint+import CmmContFlowOpt+import CmmLayoutStack+import CmmSink+import Hoopl++import UniqSupply+import DynFlags+import ErrUtils+import HscTypes+import Control.Monad+import Outputable+import Platform++-----------------------------------------------------------------------------+-- | Top level driver for C-- pipeline+-----------------------------------------------------------------------------++cmmPipeline  :: HscEnv -- Compilation env including+                       -- dynamic flags: -dcmm-lint -ddump-cmm-cps+             -> TopSRT     -- SRT table and accumulating list of compiled procs+             -> CmmGroup             -- Input C-- with Procedures+             -> IO (TopSRT, CmmGroup) -- Output CPS transformed C--++cmmPipeline hsc_env topSRT prog =+  do let dflags = hsc_dflags hsc_env++     tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog++     (topSRT, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags topSRT tops+     dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" (ppr cmms)++     return (topSRT, cmms)+++cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])+cpsTop _ p@(CmmData {}) = return (mapEmpty, [p])+cpsTop hsc_env proc =+    do+       ----------- Control-flow optimisations ----------------------------------++       -- The first round of control-flow optimisation speeds up the+       -- later passes by removing lots of empty blocks, so we do it+       -- even when optimisation isn't turned on.+       --+       CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-}+            return $ cmmCfgOptsProc splitting_proc_points proc+       dump Opt_D_dump_cmm_cfg "Post control-flow optimisations" g++       let !TopInfo {stack_info=StackInfo { arg_space = entry_off+                                          , do_layout = do_layout }} = h++       ----------- Eliminate common blocks -------------------------------------+       g <- {-# SCC "elimCommonBlocks" #-}+            condPass Opt_CmmElimCommonBlocks elimCommonBlocks g+                          Opt_D_dump_cmm_cbe "Post common block elimination"++       -- Any work storing block Labels must be performed _after_+       -- elimCommonBlocks++       g <- {-# SCC "createSwitchPlans" #-}+            runUniqSM $ cmmImplementSwitchPlans dflags g+       dump Opt_D_dump_cmm_switch "Post switch plan" g++       ----------- Proc points -------------------------------------------------+       let call_pps = {-# SCC "callProcPoints" #-} callProcPoints g+       proc_points <-+          if splitting_proc_points+             then do+               pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $+                  minimalProcPointSet (targetPlatform dflags) call_pps g+               dumpWith dflags Opt_D_dump_cmm_proc "Proc points"+                     (ppr l $$ ppr pp $$ ppr g)+               return pp+             else+               return call_pps++       ----------- Layout the stack and manifest Sp ----------------------------+       (g, stackmaps) <-+            {-# SCC "layoutStack" #-}+            if do_layout+               then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g+               else return (g, mapEmpty)+       dump Opt_D_dump_cmm_sp "Layout Stack" g++       ----------- Sink and inline assignments  --------------------------------+       g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]+            condPass Opt_CmmSink (cmmSink dflags) g+                     Opt_D_dump_cmm_sink "Sink assignments"++       ------------- CAF analysis ----------------------------------------------+       let cafEnv = {-# SCC "cafAnal" #-} cafAnal g+       dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" (ppr cafEnv)++       g <- if splitting_proc_points+            then do+               ------------- Split into separate procedures -----------------------+               let pp_map = {-# SCC "procPointAnalysis" #-}+                            procPointAnalysis proc_points g+               dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" $+                    ppr pp_map+               g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $+                    splitAtProcPoints dflags l call_pps proc_points pp_map+                                      (CmmProc h l v g)+               dumps Opt_D_dump_cmm_split "Post splitting" g+               return g+             else do+               -- attach info tables to return points+               return $ [attachContInfoTables call_pps (CmmProc h l v g)]++       ------------- Populate info tables with stack info -----------------+       g <- {-# SCC "setInfoTableStackMap" #-}+            return $ map (setInfoTableStackMap dflags stackmaps) g+       dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" g++       ----------- Control-flow optimisations -----------------------------+       g <- {-# SCC "cmmCfgOpts(2)" #-}+            return $ if optLevel dflags >= 1+                     then map (cmmCfgOptsProc splitting_proc_points) g+                     else g+       g <- return (map removeUnreachableBlocksProc g)+            -- See Note [unreachable blocks]+       dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g++       return (cafEnv, g)++  where dflags = hsc_dflags hsc_env+        platform = targetPlatform dflags+        dump = dumpGraph dflags++        dumps flag name+           = mapM_ (dumpWith dflags flag name . ppr)++        condPass flag pass g dumpflag dumpname =+            if gopt flag dflags+               then do+                    g <- return $ pass g+                    dump dumpflag dumpname g+                    return g+               else return g+++        -- we don't need to split proc points for the NCG, unless+        -- tablesNextToCode is off.  The latter is because we have no+        -- label to put on info tables for basic blocks that are not+        -- the entry point.+        splitting_proc_points = hscTarget dflags /= HscAsm+                             || not (tablesNextToCode dflags)+                             || -- Note [inconsistent-pic-reg]+                                usingInconsistentPicReg+        usingInconsistentPicReg+           = case (platformArch platform, platformOS platform, gopt Opt_PIC dflags)+             of   (ArchX86, OSDarwin, pic) -> pic+                  (ArchPPC, OSDarwin, pic) -> pic+                  _                        -> False++-- Note [Sinking after stack layout]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- In the past we considered running sinking pass also before stack+-- layout, but after making some measurements we realized that:+--+--   a) running sinking only before stack layout produces slower+--      code than running sinking only before stack layout+--+--   b) running sinking both before and after stack layout produces+--      code that has the same performance as when running sinking+--      only after stack layout.+--+-- In other words sinking before stack layout doesn't buy as anything.+--+-- An interesting question is "why is it better to run sinking after+-- stack layout"? It seems that the major reason are stores and loads+-- generated by stack layout. Consider this code before stack layout:+--+--  c1E:+--      _c1C::P64 = R3;+--      _c1B::P64 = R2;+--      _c1A::P64 = R1;+--      I64[(young<c1D> + 8)] = c1D;+--      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;+--  c1D:+--      R3 = _c1C::P64;+--      R2 = _c1B::P64;+--      R1 = _c1A::P64;+--      call (P64[(old + 8)])(R3, R2, R1) args: 8, res: 0, upd: 8;+--+-- Stack layout pass will save all local variables live across a call+-- (_c1C, _c1B and _c1A in this example) on the stack just before+-- making a call and reload them from the stack after returning from a+-- call:+--+--  c1E:+--      _c1C::P64 = R3;+--      _c1B::P64 = R2;+--      _c1A::P64 = R1;+--      I64[Sp - 32] = c1D;+--      P64[Sp - 24] = _c1A::P64;+--      P64[Sp - 16] = _c1B::P64;+--      P64[Sp - 8] = _c1C::P64;+--      Sp = Sp - 32;+--      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;+--  c1D:+--      _c1A::P64 = P64[Sp + 8];+--      _c1B::P64 = P64[Sp + 16];+--      _c1C::P64 = P64[Sp + 24];+--      R3 = _c1C::P64;+--      R2 = _c1B::P64;+--      R1 = _c1A::P64;+--      Sp = Sp + 32;+--      call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8;+--+-- If we don't run sinking pass after stack layout we are basically+-- left with such code. However, running sinking on this code can lead+-- to significant improvements:+--+--  c1E:+--      I64[Sp - 32] = c1D;+--      P64[Sp - 24] = R1;+--      P64[Sp - 16] = R2;+--      P64[Sp - 8] = R3;+--      Sp = Sp - 32;+--      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;+--  c1D:+--      R3 = P64[Sp + 24];+--      R2 = P64[Sp + 16];+--      R1 = P64[Sp + 8];+--      Sp = Sp + 32;+--      call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8;+--+-- Now we only have 9 assignments instead of 15.+--+-- There is one case when running sinking before stack layout could+-- be beneficial. Consider this:+--+--   L1:+--      x = y+--      call f() returns L2+--   L2: ...x...y...+--+-- Since both x and y are live across a call to f, they will be stored+-- on the stack during stack layout and restored after the call:+--+--   L1:+--      x = y+--      P64[Sp - 24] = L2+--      P64[Sp - 16] = x+--      P64[Sp - 8]  = y+--      Sp = Sp - 24+--      call f() returns L2+--   L2:+--      y = P64[Sp + 16]+--      x = P64[Sp + 8]+--      Sp = Sp + 24+--      ...x...y...+--+-- However, if we run sinking before stack layout we would propagate x+-- to its usage place (both x and y must be local register for this to+-- be possible - global registers cannot be floated past a call):+--+--   L1:+--      x = y+--      call f() returns L2+--   L2: ...y...y...+--+-- Thus making x dead at the call to f(). If we ran stack layout now+-- we would generate less stores and loads:+--+--   L1:+--      x = y+--      P64[Sp - 16] = L2+--      P64[Sp - 8]  = y+--      Sp = Sp - 16+--      call f() returns L2+--   L2:+--      y = P64[Sp + 8]+--      Sp = Sp + 16+--      ...y...y...+--+-- But since we don't see any benefits from running sinking befroe stack+-- layout, this situation probably doesn't arise too often in practice.+--++{- Note [inconsistent-pic-reg]++On x86/Darwin, PIC is implemented by inserting a sequence like++    call 1f+ 1: popl %reg++at the proc entry point, and then referring to labels as offsets from+%reg.  If we don't split proc points, then we could have many entry+points in a proc that would need this sequence, and each entry point+would then get a different value for %reg.  If there are any join+points, then at the join point we don't have a consistent value for+%reg, so we don't know how to refer to labels.++Hence, on x86/Darwin, we have to split proc points, and then each proc+point will get its own PIC initialisation sequence.++The situation is the same for ppc/Darwin. We use essentially the same+sequence to load the program counter onto reg:++    bcl  20,31,1f+ 1: mflr reg++This isn't an issue on x86/ELF, where the sequence is++    call 1f+ 1: popl %reg+    addl $_GLOBAL_OFFSET_TABLE_+(.-1b), %reg++so %reg always has a consistent value: the address of+_GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via.++-}++{- Note [unreachable blocks]++The control-flow optimiser sometimes leaves unreachable blocks behind+containing junk code.  These aren't necessarily a problem, but+removing them is good because it might save time in the native code+generator later.++-}++runUniqSM :: UniqSM a -> IO a+runUniqSM m = do+  us <- mkSplitUniqSupply 'u'+  return (initUs_ us m)+++dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()+dumpGraph dflags flag name g = do+  when (gopt Opt_DoCmmLinting dflags) $ do_lint g+  dumpWith dflags flag name (ppr g)+ where+  do_lint g = case cmmLintGraph dflags g of+                 Just err -> do { fatalErrorMsg dflags err+                                ; ghcExit dflags 1+                                }+                 Nothing  -> return ()++dumpWith :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()+dumpWith dflags flag txt sdoc = do+         -- ToDo: No easy way of say "dump all the cmm, *and* split+         -- them into files."  Also, -ddump-cmm-verbose doesn't play+         -- nicely with -ddump-to-file, since the headers get omitted.+   dumpIfSet_dyn dflags flag txt sdoc+   when (not (dopt flag dflags)) $+      dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose txt sdoc
+ cmm/CmmProcPoint.hs view
@@ -0,0 +1,490 @@+{-# LANGUAGE GADTs, DisambiguateRecordFields, BangPatterns #-}++module CmmProcPoint+    ( ProcPointSet, Status(..)+    , callProcPoints, minimalProcPointSet+    , splitAtProcPoints, procPointAnalysis+    , attachContInfoTables+    )+where++import Prelude hiding (last, unzip, succ, zip)++import DynFlags+import BlockId+import CLabel+import Cmm+import PprCmm ()+import CmmUtils+import CmmInfo+import CmmLive+import CmmSwitch+import Data.List (sortBy)+import Maybes+import Control.Monad+import Outputable+import Platform+import UniqSupply+import Hoopl++-- Compute a minimal set of proc points for a control-flow graph.++-- Determine a protocol for each proc point (which live variables will+-- be passed as arguments and which will be on the stack).++{-+A proc point is a basic block that, after CPS transformation, will+start a new function.  The entry block of the original function is a+proc point, as is the continuation of each function call.+A third kind of proc point arises if we want to avoid copying code.+Suppose we have code like the following:++  f() {+    if (...) { ..1..; call foo(); ..2..}+    else     { ..3..; call bar(); ..4..}+    x = y + z;+    return x;+  }++The statement 'x = y + z' can be reached from two different proc+points: the continuations of foo() and bar().  We would prefer not to+put a copy in each continuation; instead we would like 'x = y + z' to+be the start of a new procedure to which the continuations can jump:++  f_cps () {+    if (...) { ..1..; push k_foo; jump foo_cps(); }+    else     { ..3..; push k_bar; jump bar_cps(); }+  }+  k_foo() { ..2..; jump k_join(y, z); }+  k_bar() { ..4..; jump k_join(y, z); }+  k_join(y, z) { x = y + z; return x; }++You might think then that a criterion to make a node a proc point is+that it is directly reached by two distinct proc points.  (Note+[Direct reachability].)  But this criterion is a bit too simple; for+example, 'return x' is also reached by two proc points, yet there is+no point in pulling it out of k_join.  A good criterion would be to+say that a node should be made a proc point if it is reached by a set+of proc points that is different than its immediate dominator.  NR+believes this criterion can be shown to produce a minimum set of proc+points, and given a dominator tree, the proc points can be chosen in+time linear in the number of blocks.  Lacking a dominator analysis,+however, we turn instead to an iterative solution, starting with no+proc points and adding them according to these rules:++  1. The entry block is a proc point.+  2. The continuation of a call is a proc point.+  3. A node is a proc point if it is directly reached by more proc+     points than one of its predecessors.++Because we don't understand the problem very well, we apply rule 3 at+most once per iteration, then recompute the reachability information.+(See Note [No simple dataflow].)  The choice of the new proc point is+arbitrary, and I don't know if the choice affects the final solution,+so I don't know if the number of proc points chosen is the+minimum---but the set will be minimal.++++Note [Proc-point analysis]+~~~~~~~~~~~~~~~~~~~~~~~~~~++Given a specified set of proc-points (a set of block-ids), "proc-point+analysis" figures out, for every block, which proc-point it belongs to.+All the blocks belonging to proc-point P will constitute a single+top-level C procedure.++A non-proc-point block B "belongs to" a proc-point P iff B is+reachable from P without going through another proc-point.++Invariant: a block B should belong to at most one proc-point; if it+belongs to two, that's a bug.++Note [Non-existing proc-points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++On some architectures it might happen that the list of proc-points+computed before stack layout pass will be invalidated by the stack+layout. This will happen if stack layout removes from the graph+blocks that were determined to be proc-points. Later on in the pipeline+we use list of proc-points to perform [Proc-point analysis], but+if a proc-point does not exist anymore then we will get compiler panic.+See #8205.+-}++type ProcPointSet = LabelSet++data Status+  = ReachedBy ProcPointSet  -- set of proc points that directly reach the block+  | ProcPoint               -- this block is itself a proc point++instance Outputable Status where+  ppr (ReachedBy ps)+      | setNull ps = text "<not-reached>"+      | otherwise = text "reached by" <+>+                    (hsep $ punctuate comma $ map ppr $ setElems ps)+  ppr ProcPoint = text "<procpt>"++--------------------------------------------------+-- Proc point analysis++-- Once you know what the proc-points are, figure out+-- what proc-points each block is reachable from+-- See Note [Proc-point analysis]+procPointAnalysis :: ProcPointSet -> CmmGraph -> LabelMap Status+procPointAnalysis procPoints cmmGraph@(CmmGraph {g_graph = graph}) =+    analyzeCmmFwd procPointLattice procPointTransfer cmmGraph initProcPoints+  where+    initProcPoints =+        mkFactBase+            procPointLattice+            [ (id, ProcPoint)+            | id <- setElems procPoints+            -- See Note [Non-existing proc-points]+            , id `setMember` labelsInGraph+            ]+    labelsInGraph = labelsDefined graph++procPointTransfer :: TransferFun Status+procPointTransfer block facts =+    let label = entryLabel block+        !fact = case getFact procPointLattice label facts of+            ProcPoint -> ReachedBy $! setSingleton label+            f -> f+        result = map (\id -> (id, fact)) (successors block)+    in mkFactBase procPointLattice result++procPointLattice :: DataflowLattice Status+procPointLattice = DataflowLattice unreached add_to+  where+    unreached = ReachedBy setEmpty+    add_to (OldFact ProcPoint) _ = NotChanged ProcPoint+    add_to _ (NewFact ProcPoint) = Changed ProcPoint -- because of previous case+    add_to (OldFact (ReachedBy p)) (NewFact (ReachedBy p'))+        | setSize union > setSize p = Changed (ReachedBy union)+        | otherwise = NotChanged (ReachedBy p)+      where+        union = setUnion p' p++----------------------------------------------------------------------++-- It is worth distinguishing two sets of proc points: those that are+-- induced by calls in the original graph and those that are+-- introduced because they're reachable from multiple proc points.+--+-- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds].+callProcPoints      :: CmmGraph -> ProcPointSet+callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g+  where add :: CmmBlock -> LabelSet -> LabelSet+        add b set = case lastNode b of+                      CmmCall {cml_cont = Just k} -> setInsert k set+                      CmmForeignCall {succ=k}     -> setInsert k set+                      _ -> set++minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph+                    -> UniqSM ProcPointSet+-- Given the set of successors of calls (which must be proc-points)+-- figure out the minimal set of necessary proc-points+minimalProcPointSet platform callProcPoints g+  = extendPPSet platform g (postorderDfs g) callProcPoints++extendPPSet+    :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet+extendPPSet platform g blocks procPoints =+    let env = procPointAnalysis procPoints g+        add block pps = let id = entryLabel block+                        in  case mapLookup id env of+                              Just ProcPoint -> setInsert id pps+                              _ -> pps+        procPoints' = foldGraphBlocks add setEmpty g+        newPoints = mapMaybe ppSuccessor blocks+        newPoint  = listToMaybe newPoints+        ppSuccessor b =+            let nreached id = case mapLookup id env `orElse`+                                    pprPanic "no ppt" (ppr id <+> ppr b) of+                                ProcPoint -> 1+                                ReachedBy ps -> setSize ps+                block_procpoints = nreached (entryLabel b)+                -- | Looking for a successor of b that is reached by+                -- more proc points than b and is not already a proc+                -- point.  If found, it can become a proc point.+                newId succ_id = not (setMember succ_id procPoints') &&+                                nreached succ_id > block_procpoints+            in  listToMaybe $ filter newId $ successors b++    in case newPoint of+         Just id ->+             if setMember id procPoints'+                then panic "added old proc pt"+                else extendPPSet platform g blocks (setInsert id procPoints')+         Nothing -> return procPoints'+++-- At this point, we have found a set of procpoints, each of which should be+-- the entry point of a procedure.+-- Now, we create the procedure for each proc point,+-- which requires that we:+-- 1. build a map from proc points to the blocks reachable from the proc point+-- 2. turn each branch to a proc point into a jump+-- 3. turn calls and returns into jumps+-- 4. build info tables for the procedures -- and update the info table for+--    the SRTs in the entry procedure as well.+-- Input invariant: A block should only be reachable from a single ProcPoint.+-- ToDo: use the _ret naming convention that the old code generator+-- used. -- EZY+splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status ->+                     CmmDecl -> UniqSM [CmmDecl]+splitAtProcPoints dflags entry_label callPPs procPoints procMap+                  (CmmProc (TopInfo {info_tbls = info_tbls})+                           top_l _ g@(CmmGraph {g_entry=entry})) =+  do -- Build a map from procpoints to the blocks they reach+     let addBlock+             :: CmmBlock+             -> LabelMap (LabelMap CmmBlock)+             -> LabelMap (LabelMap CmmBlock)+         addBlock b graphEnv =+           case mapLookup bid procMap of+             Just ProcPoint -> add graphEnv bid bid b+             Just (ReachedBy set) ->+               case setElems set of+                 []   -> graphEnv+                 [id] -> add graphEnv id bid b+                 _    -> panic "Each block should be reachable from only one ProcPoint"+             Nothing -> graphEnv+           where bid = entryLabel b+         add graphEnv procId bid b = mapInsert procId graph' graphEnv+               where graph  = mapLookup procId graphEnv `orElse` mapEmpty+                     graph' = mapInsert bid b graph++     let liveness = cmmGlobalLiveness dflags g+     let ppLiveness pp = filter isArgReg $+                         regSetToList $+                         expectJust "ppLiveness" $ mapLookup pp liveness++     graphEnv <- return $ foldGraphBlocks addBlock mapEmpty g++     -- Build a map from proc point BlockId to pairs of:+     --  * Labels for their new procedures+     --  * Labels for the info tables of their new procedures (only if+     --    the proc point is a callPP)+     -- Due to common blockification, we may overestimate the set of procpoints.+     let add_label map pp = mapInsert pp lbls map+           where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls))+                      | otherwise   = (block_lbl, guard (setMember pp callPPs) >>+                                                    Just (toInfoLbl block_lbl))+                      where block_lbl = blockLbl pp++         procLabels :: LabelMap (CLabel, Maybe CLabel)+         procLabels = foldl add_label mapEmpty+                            (filter (flip mapMember (toBlockMap g)) (setElems procPoints))++     -- In each new graph, add blocks jumping off to the new procedures,+     -- and replace branches to procpoints with branches to the jump-off blocks+     let add_jump_block+             :: (LabelMap Label, [CmmBlock])+             -> (Label, CLabel)+             -> UniqSM (LabelMap Label, [CmmBlock])+         add_jump_block (env, bs) (pp, l) =+           do bid <- liftM mkBlockId getUniqueM+              let b = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump+                  live = ppLiveness pp+                  jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0+              return (mapInsert pp bid env, b : bs)++         add_jumps+             :: LabelMap CmmGraph+             -> (Label, LabelMap CmmBlock)+             -> UniqSM (LabelMap CmmGraph)+         add_jumps newGraphEnv (ppId, blockEnv) =+           do let needed_jumps = -- find which procpoints we currently branch to+                    mapFold add_if_branch_to_pp [] blockEnv+                  add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]+                  add_if_branch_to_pp block rst =+                    case lastNode block of+                      CmmBranch id          -> add_if_pp id rst+                      CmmCondBranch _ ti fi _ -> add_if_pp ti (add_if_pp fi rst)+                      CmmSwitch _ ids       -> foldr add_if_pp rst $ switchTargetsToList ids+                      _                     -> rst++                  -- when jumping to a PP that has an info table, if+                  -- tablesNextToCode is off we must jump to the entry+                  -- label instead.+                  jump_label (Just info_lbl) _+                             | tablesNextToCode dflags = info_lbl+                             | otherwise               = toEntryLbl info_lbl+                  jump_label Nothing         block_lbl = block_lbl++                  add_if_pp id rst = case mapLookup id procLabels of+                                       Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst+                                       Nothing                 -> rst+              (jumpEnv, jumpBlocks) <-+                 foldM add_jump_block (mapEmpty, []) needed_jumps+                  -- update the entry block+              let b = expectJust "block in env" $ mapLookup ppId blockEnv+                  blockEnv' = mapInsert ppId b blockEnv+                  -- replace branches to procpoints with branches to jumps+                  blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv'+                  -- add the jump blocks to the graph+                  blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks+              let g' = ofBlockMap ppId blockEnv'''+              -- pprTrace "g' pre jumps" (ppr g') $ do+              return (mapInsert ppId g' newGraphEnv)++     graphEnv <- foldM add_jumps mapEmpty $ mapToList graphEnv++     let to_proc (bid, g)+             | bid == entry+             =  CmmProc (TopInfo {info_tbls  = info_tbls,+                                  stack_info = stack_info})+                        top_l live g'+             | otherwise+             = case expectJust "pp label" $ mapLookup bid procLabels of+                 (lbl, Just info_lbl)+                    -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl)+                                        , stack_info=stack_info})+                               lbl live g'+                 (lbl, Nothing)+                    -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info})+                               lbl live g'+                where+                 g' = replacePPIds g+                 live = ppLiveness (g_entry g')+                 stack_info = StackInfo { arg_space = 0+                                        , updfr_space =  Nothing+                                        , do_layout = True }+                               -- cannot use panic, this is printed by -ddump-cmm++         -- References to procpoint IDs can now be replaced with the+         -- infotable's label+         replacePPIds g = {-# SCC "replacePPIds" #-}+                          mapGraphNodes (id, mapExp repl, mapExp repl) g+           where repl e@(CmmLit (CmmBlock bid)) =+                   case mapLookup bid procLabels of+                     Just (_, Just info_lbl)  -> CmmLit (CmmLabel info_lbl)+                     _ -> e+                 repl e = e++     -- The C back end expects to see return continuations before the+     -- call sites.  Here, we sort them in reverse order -- it gets+     -- reversed later.+     let (_, block_order) =+             foldl add_block_num (0::Int, mapEmpty :: LabelMap Int)+                   (postorderDfs g)+         add_block_num (i, map) block = (i+1, mapInsert (entryLabel block) i map)+         sort_fn (bid, _) (bid', _) =+           compare (expectJust "block_order" $ mapLookup bid  block_order)+                   (expectJust "block_order" $ mapLookup bid' block_order)+     procs <- return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv+     return -- pprTrace "procLabels" (ppr procLabels)+            -- pprTrace "splitting graphs" (ppr procs)+            procs+splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]++-- Only called from CmmProcPoint.splitAtProcPoints. NB. does a+-- recursive lookup, see comment below.+replaceBranches :: LabelMap BlockId -> CmmGraph -> CmmGraph+replaceBranches env cmmg+  = {-# SCC "replaceBranches" #-}+    ofBlockMap (g_entry cmmg) $ mapMap f $ toBlockMap cmmg+  where+    f block = replaceLastNode block $ last (lastNode block)++    last :: CmmNode O C -> CmmNode O C+    last (CmmBranch id)          = CmmBranch (lookup id)+    last (CmmCondBranch e ti fi l) = CmmCondBranch e (lookup ti) (lookup fi) l+    last (CmmSwitch e ids)       = CmmSwitch e (mapSwitchTargets lookup ids)+    last l@(CmmCall {})          = l { cml_cont = Nothing }+            -- NB. remove the continuation of a CmmCall, since this+            -- label will now be in a different CmmProc.  Not only+            -- is this tidier, it stops CmmLint from complaining.+    last l@(CmmForeignCall {})   = l+    lookup id = fmap lookup (mapLookup id env) `orElse` id+            -- XXX: this is a recursive lookup, it follows chains+            -- until the lookup returns Nothing, at which point we+            -- return the last BlockId++-- --------------------------------------------------------------+-- Not splitting proc points: add info tables for continuations++attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl+attachContInfoTables call_proc_points (CmmProc top_info top_l live g)+ = CmmProc top_info{info_tbls = info_tbls'} top_l live g+ where+   info_tbls' = mapUnion (info_tbls top_info) $+                mapFromList [ (l, mkEmptyContInfoTable (infoTblLbl l))+                            | l <- setElems call_proc_points+                            , l /= g_entry g ]+attachContInfoTables _ other_decl+ = other_decl++----------------------------------------------------------------++{-+Note [Direct reachability]++Block B is directly reachable from proc point P iff control can flow+from P to B without passing through an intervening proc point.+-}++----------------------------------------------------------------++{-+Note [No simple dataflow]++Sadly, it seems impossible to compute the proc points using a single+dataflow pass.  One might attempt to use this simple lattice:++  data Location = Unknown+                | InProc BlockId -- node is in procedure headed by the named proc point+                | ProcPoint      -- node is itself a proc point++At a join, a node in two different blocks becomes a proc point.+The difficulty is that the change of information during iterative+computation may promote a node prematurely.  Here's a program that+illustrates the difficulty:++  f () {+  entry:+    ....+  L1:+    if (...) { ... }+    else { ... }++  L2: if (...) { g(); goto L1; }+      return x + y;+  }++The only proc-point needed (besides the entry) is L1.  But in an+iterative analysis, consider what happens to L2.  On the first pass+through, it rises from Unknown to 'InProc entry', but when L1 is+promoted to a proc point (because it's the successor of g()), L1's+successors will be promoted to 'InProc L1'.  The problem hits when the+new fact 'InProc L1' flows into L2 which is already bound to 'InProc entry'.+The join operation makes it a proc point when in fact it needn't be,+because its immediate dominator L1 is already a proc point and there+are no other proc points that directly reach L2.+-}++++{- Note [Separate Adams optimization]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It may be worthwhile to attempt the Adams optimization by rewriting+the graph before the assignment of proc-point protocols.  Here are a+couple of rules:++  g() returns to k;                    g() returns to L;+  k: CopyIn c ress; goto L:+   ...                        ==>        ...+  L: // no CopyIn node here            L: CopyIn c ress;+++And when c == c' and ress == ress', this also:++  g() returns to k;                    g() returns to L;+  k: CopyIn c ress; goto L:+   ...                        ==>        ...+  L: CopyIn c' ress'                   L: CopyIn c' ress' ;++In both cases the goal is to eliminate k.+-}
+ cmm/CmmSink.hs view
@@ -0,0 +1,790 @@+{-# LANGUAGE GADTs #-}+module CmmSink (+     cmmSink+  ) where++import Cmm+import CmmOpt+import CmmLive+import CmmUtils+import Hoopl+import CodeGen.Platform+import Platform (isARM, platformArch)++import DynFlags+import UniqFM+import PprCmm ()++import Data.List (partition)+import qualified Data.Set as Set+import Data.Maybe++-- -----------------------------------------------------------------------------+-- Sinking and inlining++-- This is an optimisation pass that+--  (a) moves assignments closer to their uses, to reduce register pressure+--  (b) pushes assignments into a single branch of a conditional if possible+--  (c) inlines assignments to registers that are mentioned only once+--  (d) discards dead assignments+--+-- This tightens up lots of register-heavy code.  It is particularly+-- helpful in the Cmm generated by the Stg->Cmm code generator, in+-- which every function starts with a copyIn sequence like:+--+--    x1 = R1+--    x2 = Sp[8]+--    x3 = Sp[16]+--    if (Sp - 32 < SpLim) then L1 else L2+--+-- we really want to push the x1..x3 assignments into the L2 branch.+--+-- Algorithm:+--+--  * Start by doing liveness analysis.+--+--  * Keep a list of assignments A; earlier ones may refer to later ones.+--    Currently we only sink assignments to local registers, because we don't+--    have liveness information about global registers.+--+--  * Walk forwards through the graph, look at each node N:+--+--    * If it is a dead assignment, i.e. assignment to a register that is+--      not used after N, discard it.+--+--    * Try to inline based on current list of assignments+--      * If any assignments in A (1) occur only once in N, and (2) are+--        not live after N, inline the assignment and remove it+--        from A.+--+--      * If an assignment in A is cheap (RHS is local register), then+--        inline the assignment and keep it in A in case it is used afterwards.+--+--      * Otherwise don't inline.+--+--    * If N is assignment to a local register pick up the assignment+--      and add it to A.+--+--    * If N is not an assignment to a local register:+--      * remove any assignments from A that conflict with N, and+--        place them before N in the current block.  We call this+--        "dropping" the assignments.+--+--      * An assignment conflicts with N if it:+--        - assigns to a register mentioned in N+--        - mentions a register assigned by N+--        - reads from memory written by N+--      * do this recursively, dropping dependent assignments+--+--    * At an exit node:+--      * drop any assignments that are live on more than one successor+--        and are not trivial+--      * if any successor has more than one predecessor (a join-point),+--        drop everything live in that successor. Since we only propagate+--        assignments that are not dead at the successor, we will therefore+--        eliminate all assignments dead at this point. Thus analysis of a+--        join-point will always begin with an empty list of assignments.+--+--+-- As a result of above algorithm, sinking deletes some dead assignments+-- (transitively, even).  This isn't as good as removeDeadAssignments,+-- but it's much cheaper.++-- -----------------------------------------------------------------------------+-- things that we aren't optimising very well yet.+--+-- -----------+-- (1) From GHC's FastString.hashStr:+--+--  s2ay:+--      if ((_s2an::I64 == _s2ao::I64) >= 1) goto c2gn; else goto c2gp;+--  c2gn:+--      R1 = _s2au::I64;+--      call (I64[Sp])(R1) args: 8, res: 0, upd: 8;+--  c2gp:+--      _s2cO::I64 = %MO_S_Rem_W64(%MO_UU_Conv_W8_W64(I8[_s2aq::I64 + (_s2an::I64 << 0)]) + _s2au::I64 * 128,+--                                 4091);+--      _s2an::I64 = _s2an::I64 + 1;+--      _s2au::I64 = _s2cO::I64;+--      goto s2ay;+--+-- a nice loop, but we didn't eliminate the silly assignment at the end.+-- See Note [dependent assignments], which would probably fix this.+-- This is #8336 on Trac.+--+-- -----------+-- (2) From stg_atomically_frame in PrimOps.cmm+--+-- We have a diamond control flow:+--+--     x = ...+--       |+--      / \+--     A   B+--      \ /+--       |+--    use of x+--+-- Now x won't be sunk down to its use, because we won't push it into+-- both branches of the conditional.  We certainly do have to check+-- that we can sink it past all the code in both A and B, but having+-- discovered that, we could sink it to its use.+--++-- -----------------------------------------------------------------------------++type Assignment = (LocalReg, CmmExpr, AbsMem)+  -- Assignment caches AbsMem, an abstraction of the memory read by+  -- the RHS of the assignment.++type Assignments = [Assignment]+  -- A sequence of assignments; kept in *reverse* order+  -- So the list [ x=e1, y=e2 ] means the sequence of assignments+  --     y = e2+  --     x = e1++cmmSink :: DynFlags -> CmmGraph -> CmmGraph+cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks+  where+  liveness = cmmLocalLiveness dflags graph+  getLive l = mapFindWithDefault Set.empty l liveness++  blocks = postorderDfs graph++  join_pts = findJoinPoints blocks++  sink :: LabelMap Assignments -> [CmmBlock] -> [CmmBlock]+  sink _ [] = []+  sink sunk (b:bs) =+    -- pprTrace "sink" (ppr lbl) $+    blockJoin first final_middle final_last : sink sunk' bs+    where+      lbl = entryLabel b+      (first, middle, last) = blockSplit b++      succs = successors last++      -- Annotate the middle nodes with the registers live *after*+      -- the node.  This will help us decide whether we can inline+      -- an assignment in the current node or not.+      live = Set.unions (map getLive succs)+      live_middle = gen_kill dflags last live+      ann_middles = annotate dflags live_middle (blockToList middle)++      -- Now sink and inline in this block+      (middle', assigs) = walk dflags ann_middles (mapFindWithDefault [] lbl sunk)+      fold_last = constantFoldNode dflags last+      (final_last, assigs') = tryToInline dflags live fold_last assigs++      -- We cannot sink into join points (successors with more than+      -- one predecessor), so identify the join points and the set+      -- of registers live in them.+      (joins, nonjoins) = partition (`mapMember` join_pts) succs+      live_in_joins = Set.unions (map getLive joins)++      -- We do not want to sink an assignment into multiple branches,+      -- so identify the set of registers live in multiple successors.+      -- This is made more complicated because when we sink an assignment+      -- into one branch, this might change the set of registers that are+      -- now live in multiple branches.+      init_live_sets = map getLive nonjoins+      live_in_multi live_sets r =+         case filter (Set.member r) live_sets of+           (_one:_two:_) -> True+           _ -> False++      -- Now, drop any assignments that we will not sink any further.+      (dropped_last, assigs'') = dropAssignments dflags drop_if init_live_sets assigs'++      drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets')+          where+            should_drop =  conflicts dflags a final_last+                        || not (isTrivial dflags rhs) && live_in_multi live_sets r+                        || r `Set.member` live_in_joins++            live_sets' | should_drop = live_sets+                       | otherwise   = map upd live_sets++            upd set | r `Set.member` set = set `Set.union` live_rhs+                    | otherwise          = set++            live_rhs = foldRegsUsed dflags extendRegSet emptyRegSet rhs++      final_middle = foldl blockSnoc middle' dropped_last++      sunk' = mapUnion sunk $+                 mapFromList [ (l, filterAssignments dflags (getLive l) assigs'')+                             | l <- succs ]++{- TODO: enable this later, when we have some good tests in place to+   measure the effect and tune it.++-- small: an expression we don't mind duplicating+isSmall :: CmmExpr -> Bool+isSmall (CmmReg (CmmLocal _)) = True  --+isSmall (CmmLit _) = True+isSmall (CmmMachOp (MO_Add _) [x,y]) = isTrivial x && isTrivial y+isSmall (CmmRegOff (CmmLocal _) _) = True+isSmall _ = False+-}++--+-- We allow duplication of trivial expressions: registers (both local and+-- global) and literals.+--+isTrivial :: DynFlags -> CmmExpr -> Bool+isTrivial _ (CmmReg (CmmLocal _)) = True+isTrivial dflags (CmmReg (CmmGlobal r)) = -- see Note [Inline GlobalRegs?]+  if isARM (platformArch (targetPlatform dflags))+  then True -- CodeGen.Platform.ARM does not have globalRegMaybe+  else isJust (globalRegMaybe (targetPlatform dflags) r)+  -- GlobalRegs that are loads from BaseReg are not trivial+isTrivial _ (CmmLit _) = True+isTrivial _ _          = False++--+-- annotate each node with the set of registers live *after* the node+--+annotate :: DynFlags -> LocalRegSet -> [CmmNode O O] -> [(LocalRegSet, CmmNode O O)]+annotate dflags live nodes = snd $ foldr ann (live,[]) nodes+  where ann n (live,nodes) = (gen_kill dflags n live, (live,n) : nodes)++--+-- Find the blocks that have multiple successors (join points)+--+findJoinPoints :: [CmmBlock] -> LabelMap Int+findJoinPoints blocks = mapFilter (>1) succ_counts+ where+  all_succs = concatMap successors blocks++  succ_counts :: LabelMap Int+  succ_counts = foldr (\l -> mapInsertWith (+) l 1) mapEmpty all_succs++--+-- filter the list of assignments to remove any assignments that+-- are not live in a continuation.+--+filterAssignments :: DynFlags -> LocalRegSet -> Assignments -> Assignments+filterAssignments dflags live assigs = reverse (go assigs [])+  where go []             kept = kept+        go (a@(r,_,_):as) kept | needed    = go as (a:kept)+                               | otherwise = go as kept+           where+              needed = r `Set.member` live+                       || any (conflicts dflags a) (map toNode kept)+                       --  Note that we must keep assignments that are+                       -- referred to by other assignments we have+                       -- already kept.++-- -----------------------------------------------------------------------------+-- Walk through the nodes of a block, sinking and inlining assignments+-- as we go.+--+-- On input we pass in a:+--    * list of nodes in the block+--    * a list of assignments that appeared *before* this block and+--      that are being sunk.+--+-- On output we get:+--    * a new block+--    * a list of assignments that will be placed *after* that block.+--++walk :: DynFlags+     -> [(LocalRegSet, CmmNode O O)]    -- nodes of the block, annotated with+                                        -- the set of registers live *after*+                                        -- this node.++     -> Assignments                     -- The current list of+                                        -- assignments we are sinking.+                                        -- Earlier assignments may refer+                                        -- to later ones.++     -> ( Block CmmNode O O             -- The new block+        , Assignments                   -- Assignments to sink further+        )++walk dflags nodes assigs = go nodes emptyBlock assigs+ where+   go []               block as = (block, as)+   go ((live,node):ns) block as+    | shouldDiscard node live           = go ns block as+       -- discard dead assignment+    | Just a <- shouldSink dflags node2 = go ns block (a : as1)+    | otherwise                         = go ns block' as'+    where+      node1 = constantFoldNode dflags node++      (node2, as1) = tryToInline dflags live node1 as++      (dropped, as') = dropAssignmentsSimple dflags+                          (\a -> conflicts dflags a node2) as1++      block' = foldl blockSnoc block dropped `blockSnoc` node2+++--+-- Heuristic to decide whether to pick up and sink an assignment+-- Currently we pick up all assignments to local registers.  It might+-- be profitable to sink assignments to global regs too, but the+-- liveness analysis doesn't track those (yet) so we can't.+--+shouldSink :: DynFlags -> CmmNode e x -> Maybe Assignment+shouldSink dflags (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprMem dflags e)+  where no_local_regs = True -- foldRegsUsed (\_ _ -> False) True e+shouldSink _ _other = Nothing++--+-- discard dead assignments.  This doesn't do as good a job as+-- removeDeadAssignments, because it would need multiple passes+-- to get all the dead code, but it catches the common case of+-- superfluous reloads from the stack that the stack allocator+-- leaves behind.+--+-- Also we catch "r = r" here.  You might think it would fall+-- out of inlining, but the inliner will see that r is live+-- after the instruction and choose not to inline r in the rhs.+--+shouldDiscard :: CmmNode e x -> LocalRegSet -> Bool+shouldDiscard node live+   = case node of+       CmmAssign r (CmmReg r') | r == r' -> True+       CmmAssign (CmmLocal r) _ -> not (r `Set.member` live)+       _otherwise -> False+++toNode :: Assignment -> CmmNode O O+toNode (r,rhs,_) = CmmAssign (CmmLocal r) rhs++dropAssignmentsSimple :: DynFlags -> (Assignment -> Bool) -> Assignments+                      -> ([CmmNode O O], Assignments)+dropAssignmentsSimple dflags f = dropAssignments dflags (\a _ -> (f a, ())) ()++dropAssignments :: DynFlags -> (Assignment -> s -> (Bool, s)) -> s -> Assignments+                -> ([CmmNode O O], Assignments)+dropAssignments dflags should_drop state assigs+ = (dropped, reverse kept)+ where+   (dropped,kept) = go state assigs [] []++   go _ []             dropped kept = (dropped, kept)+   go state (assig : rest) dropped kept+      | conflict  = go state' rest (toNode assig : dropped) kept+      | otherwise = go state' rest dropped (assig:kept)+      where+        (dropit, state') = should_drop assig state+        conflict = dropit || any (conflicts dflags assig) dropped+++-- -----------------------------------------------------------------------------+-- Try to inline assignments into a node.++tryToInline+   :: DynFlags+   -> LocalRegSet               -- set of registers live after this+                                -- node.  We cannot inline anything+                                -- that is live after the node, unless+                                -- it is small enough to duplicate.+   -> CmmNode O x               -- The node to inline into+   -> Assignments               -- Assignments to inline+   -> (+        CmmNode O x             -- New node+      , Assignments             -- Remaining assignments+      )++tryToInline dflags live node assigs = go usages node [] assigs+ where+  usages :: UniqFM Int -- Maps each LocalReg to a count of how often it is used+  usages = foldLocalRegsUsed dflags addUsage emptyUFM node++  go _usages node _skipped [] = (node, [])++  go usages node skipped (a@(l,rhs,_) : rest)+   | cannot_inline           = dont_inline+   | occurs_none             = discard  -- Note [discard during inlining]+   | occurs_once             = inline_and_discard+   | isTrivial dflags rhs    = inline_and_keep+   | otherwise               = dont_inline+   where+        inline_and_discard = go usages' inl_node skipped rest+          where usages' = foldLocalRegsUsed dflags addUsage usages rhs++        discard = go usages node skipped rest++        dont_inline        = keep node  -- don't inline the assignment, keep it+        inline_and_keep    = keep inl_node -- inline the assignment, keep it++        keep node' = (final_node, a : rest')+          where (final_node, rest') = go usages' node' (l:skipped) rest+                usages' = foldLocalRegsUsed dflags (\m r -> addToUFM m r 2)+                                            usages rhs+                -- we must not inline anything that is mentioned in the RHS+                -- of a binding that we have already skipped, so we set the+                -- usages of the regs on the RHS to 2.++        cannot_inline = skipped `regsUsedIn` rhs -- Note [dependent assignments]+                        || l `elem` skipped+                        || not (okToInline dflags rhs node)++        l_usages = lookupUFM usages l+        l_live   = l `elemRegSet` live++        occurs_once = not l_live && l_usages == Just 1+        occurs_none = not l_live && l_usages == Nothing++        inl_node = mapExpDeep inline node+                   -- mapExpDeep is where the inlining actually takes place!+           where inline (CmmReg    (CmmLocal l'))     | l == l' = rhs+                 inline (CmmRegOff (CmmLocal l') off) | l == l'+                    = cmmOffset dflags rhs off+                    -- re-constant fold after inlining+                 inline (CmmMachOp op args) = cmmMachOpFold dflags op args+                 inline other = other++-- Note [dependent assignments]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- If our assignment list looks like+--+--    [ y = e,  x = ... y ... ]+--+-- We cannot inline x.  Remember this list is really in reverse order,+-- so it means  x = ... y ...; y = e+--+-- Hence if we inline x, the outer assignment to y will capture the+-- reference in x's right hand side.+--+-- In this case we should rename the y in x's right-hand side,+-- i.e. change the list to [ y = e, x = ... y1 ..., y1 = y ]+-- Now we can go ahead and inline x.+--+-- For now we do nothing, because this would require putting+-- everything inside UniqSM.+--+-- One more variant of this (#7366):+--+--   [ y = e, y = z ]+--+-- If we don't want to inline y = e, because y is used many times, we+-- might still be tempted to inline y = z (because we always inline+-- trivial rhs's).  But of course we can't, because y is equal to e,+-- not z.++-- Note [discard during inlining]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Opportunities to discard assignments sometimes appear after we've+-- done some inlining.  Here's an example:+--+--      x = R1;+--      y = P64[x + 7];+--      z = P64[x + 15];+--      /* z is dead */+--      R1 = y & (-8);+--+-- The x assignment is trivial, so we inline it in the RHS of y, and+-- keep both x and y.  z gets dropped because it is dead, then we+-- inline y, and we have a dead assignment to x.  If we don't notice+-- that x is dead in tryToInline, we end up retaining it.++addUsage :: UniqFM Int -> LocalReg -> UniqFM Int+addUsage m r = addToUFM_C (+) m r 1++regsUsedIn :: [LocalReg] -> CmmExpr -> Bool+regsUsedIn [] _ = False+regsUsedIn ls e = wrapRecExpf f e False+  where f (CmmReg (CmmLocal l))      _ | l `elem` ls = True+        f (CmmRegOff (CmmLocal l) _) _ | l `elem` ls = True+        f _ z = z++-- we don't inline into CmmUnsafeForeignCall if the expression refers+-- to global registers.  This is a HACK to avoid global registers+-- clashing with C argument-passing registers, really the back-end+-- ought to be able to handle it properly, but currently neither PprC+-- nor the NCG can do it.  See Note [Register parameter passing]+-- See also StgCmmForeign:load_args_into_temps.+okToInline :: DynFlags -> CmmExpr -> CmmNode e x -> Bool+okToInline dflags expr node@(CmmUnsafeForeignCall{}) =+    not (globalRegistersConflict dflags expr node)+okToInline _ _ _ = True++-- -----------------------------------------------------------------------------++-- | @conflicts (r,e) node@ is @False@ if and only if the assignment+-- @r = e@ can be safely commuted past statement @node@.+conflicts :: DynFlags -> Assignment -> CmmNode O x -> Bool+conflicts dflags (r, rhs, addr) node++  -- (1) node defines registers used by rhs of assignment. This catches+  -- assignments and all three kinds of calls. See Note [Sinking and calls]+  | globalRegistersConflict dflags rhs node                       = True+  | localRegistersConflict  dflags rhs node                       = True++  -- (2) node uses register defined by assignment+  | foldRegsUsed dflags (\b r' -> r == r' || b) False node        = True++  -- (3) a store to an address conflicts with a read of the same memory+  | CmmStore addr' e <- node+  , memConflicts addr (loadAddr dflags addr' (cmmExprWidth dflags e)) = True++  -- (4) an assignment to Hp/Sp conflicts with a heap/stack read respectively+  | HeapMem    <- addr, CmmAssign (CmmGlobal Hp) _ <- node        = True+  | StackMem   <- addr, CmmAssign (CmmGlobal Sp) _ <- node        = True+  | SpMem{}    <- addr, CmmAssign (CmmGlobal Sp) _ <- node        = True++  -- (5) foreign calls clobber heap: see Note [Foreign calls clobber heap]+  | CmmUnsafeForeignCall{} <- node, memConflicts addr AnyMem      = True++  -- (6) native calls clobber any memory+  | CmmCall{} <- node, memConflicts addr AnyMem                   = True++  -- (7) otherwise, no conflict+  | otherwise = False++-- Returns True if node defines any global registers that are used in the+-- Cmm expression+globalRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool+globalRegistersConflict dflags expr node =+    foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmGlobal r) expr)+                 False node++-- Returns True if node defines any local registers that are used in the+-- Cmm expression+localRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool+localRegistersConflict dflags expr node =+    foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmLocal  r) expr)+                 False node++-- Note [Sinking and calls]+-- ~~~~~~~~~~~~~~~~~~~~~~~~+--+-- We have three kinds of calls: normal (CmmCall), safe foreign (CmmForeignCall)+-- and unsafe foreign (CmmUnsafeForeignCall). We perform sinking pass after+-- stack layout (see Note [Sinking after stack layout]) which leads to two+-- invariants related to calls:+--+--   a) during stack layout phase all safe foreign calls are turned into+--      unsafe foreign calls (see Note [Lower safe foreign calls]). This+--      means that we will never encounter CmmForeignCall node when running+--      sinking after stack layout+--+--   b) stack layout saves all variables live across a call on the stack+--      just before making a call (remember we are not sinking assignments to+--      stack):+--+--       L1:+--          x = R1+--          P64[Sp - 16] = L2+--          P64[Sp - 8]  = x+--          Sp = Sp - 16+--          call f() returns L2+--       L2:+--+--      We will attempt to sink { x = R1 } but we will detect conflict with+--      { P64[Sp - 8]  = x } and hence we will drop { x = R1 } without even+--      checking whether it conflicts with { call f() }. In this way we will+--      never need to check any assignment conflicts with CmmCall. Remember+--      that we still need to check for potential memory conflicts.+--+-- So the result is that we only need to worry about CmmUnsafeForeignCall nodes+-- when checking conflicts (see Note [Unsafe foreign calls clobber caller-save registers]).+-- This assumption holds only when we do sinking after stack layout. If we run+-- it before stack layout we need to check for possible conflicts with all three+-- kinds of calls. Our `conflicts` function does that by using a generic+-- foldRegsDefd and foldRegsUsed functions defined in DefinerOfRegs and+-- UserOfRegs typeclasses.+--++-- An abstraction of memory read or written.+data AbsMem+  = NoMem            -- no memory accessed+  | AnyMem           -- arbitrary memory+  | HeapMem          -- definitely heap memory+  | StackMem         -- definitely stack memory+  | SpMem            -- <size>[Sp+n]+       {-# UNPACK #-} !Int+       {-# UNPACK #-} !Int++-- Having SpMem is important because it lets us float loads from Sp+-- past stores to Sp as long as they don't overlap, and this helps to+-- unravel some long sequences of+--    x1 = [Sp + 8]+--    x2 = [Sp + 16]+--    ...+--    [Sp + 8]  = xi+--    [Sp + 16] = xj+--+-- Note that SpMem is invalidated if Sp is changed, but the definition+-- of 'conflicts' above handles that.++-- ToDo: this won't currently fix the following commonly occurring code:+--    x1 = [R1 + 8]+--    x2 = [R1 + 16]+--    ..+--    [Hp - 8] = x1+--    [Hp - 16] = x2+--    ..++-- because [R1 + 8] and [Hp - 8] are both HeapMem.  We know that+-- assignments to [Hp + n] do not conflict with any other heap memory,+-- but this is tricky to nail down.  What if we had+--+--   x = Hp + n+--   [x] = ...+--+--  the store to [x] should be "new heap", not "old heap".+--  Furthermore, you could imagine that if we started inlining+--  functions in Cmm then there might well be reads of heap memory+--  that was written in the same basic block.  To take advantage of+--  non-aliasing of heap memory we will have to be more clever.++-- Note [Foreign calls clobber heap]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- It is tempting to say that foreign calls clobber only+-- non-heap/stack memory, but unfortunately we break this invariant in+-- the RTS.  For example, in stg_catch_retry_frame we call+-- stmCommitNestedTransaction() which modifies the contents of the+-- TRec it is passed (this actually caused incorrect code to be+-- generated).+--+-- Since the invariant is true for the majority of foreign calls,+-- perhaps we ought to have a special annotation for calls that can+-- modify heap/stack memory.  For now we just use the conservative+-- definition here.+--+-- Some CallishMachOp imply a memory barrier e.g. AtomicRMW and+-- therefore we should never float any memory operations across one of+-- these calls.+++bothMems :: AbsMem -> AbsMem -> AbsMem+bothMems NoMem    x         = x+bothMems x        NoMem     = x+bothMems HeapMem  HeapMem   = HeapMem+bothMems StackMem StackMem     = StackMem+bothMems (SpMem o1 w1) (SpMem o2 w2)+  | o1 == o2  = SpMem o1 (max w1 w2)+  | otherwise = StackMem+bothMems SpMem{}  StackMem  = StackMem+bothMems StackMem SpMem{}   = StackMem+bothMems _         _        = AnyMem++memConflicts :: AbsMem -> AbsMem -> Bool+memConflicts NoMem      _          = False+memConflicts _          NoMem      = False+memConflicts HeapMem    StackMem   = False+memConflicts StackMem   HeapMem    = False+memConflicts SpMem{}    HeapMem    = False+memConflicts HeapMem    SpMem{}    = False+memConflicts (SpMem o1 w1) (SpMem o2 w2)+  | o1 < o2   = o1 + w1 > o2+  | otherwise = o2 + w2 > o1+memConflicts _         _         = True++exprMem :: DynFlags -> CmmExpr -> AbsMem+exprMem dflags (CmmLoad addr w)  = bothMems (loadAddr dflags addr (typeWidth w)) (exprMem dflags addr)+exprMem dflags (CmmMachOp _ es)  = foldr bothMems NoMem (map (exprMem dflags) es)+exprMem _      _                 = NoMem++loadAddr :: DynFlags -> CmmExpr -> Width -> AbsMem+loadAddr dflags e w =+  case e of+   CmmReg r       -> regAddr dflags r 0 w+   CmmRegOff r i  -> regAddr dflags r i w+   _other | regUsedIn dflags (CmmGlobal Sp) e -> StackMem+          | otherwise -> AnyMem++regAddr :: DynFlags -> CmmReg -> Int -> Width -> AbsMem+regAddr _      (CmmGlobal Sp) i w = SpMem i (widthInBytes w)+regAddr _      (CmmGlobal Hp) _ _ = HeapMem+regAddr _      (CmmGlobal CurrentTSO) _ _ = HeapMem -- important for PrimOps+regAddr dflags r _ _ | isGcPtrType (cmmRegType dflags r) = HeapMem -- yay! GCPtr pays for itself+regAddr _      _ _ _ = AnyMem++{-+Note [Inline GlobalRegs?]++Should we freely inline GlobalRegs?++Actually it doesn't make a huge amount of difference either way, so we+*do* currently treat GlobalRegs as "trivial" and inline them+everywhere, but for what it's worth, here is what I discovered when I+(SimonM) looked into this:++Common sense says we should not inline GlobalRegs, because when we+have++  x = R1++the register allocator will coalesce this assignment, generating no+code, and simply record the fact that x is bound to $rbx (or+whatever).  Furthermore, if we were to sink this assignment, then the+range of code over which R1 is live increases, and the range of code+over which x is live decreases.  All things being equal, it is better+for x to be live than R1, because R1 is a fixed register whereas x can+live in any register.  So we should neither sink nor inline 'x = R1'.++However, not inlining GlobalRegs can have surprising+consequences. e.g. (cgrun020)++  c3EN:+      _s3DB::P64 = R1;+      _c3ES::P64 = _s3DB::P64 & 7;+      if (_c3ES::P64 >= 2) goto c3EU; else goto c3EV;+  c3EU:+      _s3DD::P64 = P64[_s3DB::P64 + 6];+      _s3DE::P64 = P64[_s3DB::P64 + 14];+      I64[Sp - 8] = c3F0;+      R1 = _s3DE::P64;+      P64[Sp] = _s3DD::P64;++inlining the GlobalReg gives:++  c3EN:+      if (R1 & 7 >= 2) goto c3EU; else goto c3EV;+  c3EU:+      I64[Sp - 8] = c3F0;+      _s3DD::P64 = P64[R1 + 6];+      R1 = P64[R1 + 14];+      P64[Sp] = _s3DD::P64;++but if we don't inline the GlobalReg, instead we get:++      _s3DB::P64 = R1;+      if (_s3DB::P64 & 7 >= 2) goto c3EU; else goto c3EV;+  c3EU:+      I64[Sp - 8] = c3F0;+      R1 = P64[_s3DB::P64 + 14];+      P64[Sp] = P64[_s3DB::P64 + 6];++This looks better - we managed to inline _s3DD - but in fact it+generates an extra reg-reg move:++.Lc3EU:+        movq $c3F0_info,-8(%rbp)+        movq %rbx,%rax+        movq 14(%rbx),%rbx+        movq 6(%rax),%rax+        movq %rax,(%rbp)++because _s3DB is now live across the R1 assignment, we lost the+benefit of coalescing.++Who is at fault here?  Perhaps if we knew that _s3DB was an alias for+R1, then we would not sink a reference to _s3DB past the R1+assignment.  Or perhaps we *should* do that - we might gain by sinking+it, despite losing the coalescing opportunity.++Sometimes not inlining global registers wins by virtue of the rule+about not inlining into arguments of a foreign call, e.g. (T7163) this+is what happens when we inlined F1:++      _s3L2::F32 = F1;+      _c3O3::F32 = %MO_F_Mul_W32(F1, 10.0 :: W32);+      (_s3L7::F32) = call "ccall" arg hints:  []  result hints:  [] rintFloat(_c3O3::F32);++but if we don't inline F1:++      (_s3L7::F32) = call "ccall" arg hints:  []  result hints:  [] rintFloat(%MO_F_Mul_W32(_s3L2::F32,+                                                                                            10.0 :: W32));+-}
+ cmm/CmmSwitch.hs view
@@ -0,0 +1,433 @@+{-# LANGUAGE GADTs #-}+module CmmSwitch (+     SwitchTargets,+     mkSwitchTargets,+     switchTargetsCases, switchTargetsDefault, switchTargetsRange, switchTargetsSigned,+     mapSwitchTargets, switchTargetsToTable, switchTargetsFallThrough,+     switchTargetsToList, eqSwitchTargetWith,++     SwitchPlan(..),+     targetSupportsSwitch,+     createSwitchPlan,+  ) where++import Outputable+import DynFlags+import Compiler.Hoopl (Label)++import Data.Maybe+import Data.List (groupBy)+import Data.Function (on)+import qualified Data.Map as M++-- Note [Cmm Switches, the general plan]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Compiling a high-level switch statement, as it comes out of a STG case+-- expression, for example, allows for a surprising amount of design decisions.+-- Therefore, we cleanly separated this from the Stg → Cmm transformation, as+-- well as from the actual code generation.+--+-- The overall plan is:+--  * The Stg → Cmm transformation creates a single `SwitchTargets` in+--    emitSwitch and emitCmmLitSwitch in StgCmmUtils.hs.+--    At this stage, they are unsuitable for code generation.+--  * A dedicated Cmm transformation (CmmImplementSwitchPlans) replaces these+--    switch statements with code that is suitable for code generation, i.e.+--    a nice balanced tree of decisions with dense jump tables in the leafs.+--    The actual planning of this tree is performed in pure code in createSwitchPlan+--    in this module. See Note [createSwitchPlan].+--  * The actual code generation will not do any further processing and+--    implement each CmmSwitch with a jump tables.+--+-- When compiling to LLVM or C, CmmImplementSwitchPlans leaves the switch+-- statements alone, as we can turn a SwitchTargets value into a nice+-- switch-statement in LLVM resp. C, and leave the rest to the compiler.+--+-- See Note [CmmSwitch vs. CmmImplementSwitchPlans] why the two module are+-- separated.++-----------------------------------------------------------------------------+-- Note [Magic Constants in CmmSwitch]+--+-- There are a lot of heuristics here that depend on magic values where it is+-- hard to determine the "best" value (for whatever that means). These are the+-- magic values:++-- | Number of consecutive default values allowed in a jump table. If there are+-- more of them, the jump tables are split.+--+-- Currently 7, as it costs 7 words of additional code when a jump table is+-- split (at least on x64, determined experimentally).+maxJumpTableHole :: Integer+maxJumpTableHole = 7++-- | Minimum size of a jump table. If the number is smaller, the switch is+-- implemented using conditionals.+-- Currently 5, because an if-then-else tree of 4 values is nice and compact.+minJumpTableSize :: Int+minJumpTableSize = 5++-- | Minimum non-zero offset for a jump table. See Note [Jump Table Offset].+minJumpTableOffset :: Integer+minJumpTableOffset = 2+++-----------------------------------------------------------------------------+-- Switch Targets++-- Note [SwitchTargets]:+-- ~~~~~~~~~~~~~~~~~~~~~+--+-- The branches of a switch are stored in a SwitchTargets, which consists of an+-- (optional) default jump target, and a map from values to jump targets.+--+-- If the default jump target is absent, the behaviour of the switch outside the+-- values of the map is undefined.+--+-- We use an Integer for the keys the map so that it can be used in switches on+-- unsigned as well as signed integers.+--+-- The map may be empty (we prune out-of-range branches here, so it could be us+-- emptying it).+--+-- Before code generation, the table needs to be brought into a form where all+-- entries are non-negative, so that it can be compiled into a jump table.+-- See switchTargetsToTable.+++-- | A value of type SwitchTargets contains the alternatives for a 'CmmSwitch'+-- value, and knows whether the value is signed, the possible range, an+-- optional default value and a map from values to jump labels.+data SwitchTargets =+    SwitchTargets+        Bool                       -- Signed values+        (Integer, Integer)         -- Range+        (Maybe Label)              -- Default value+        (M.Map Integer Label)      -- The branches+    deriving (Show, Eq)++-- | The smart constructr mkSwitchTargets normalises the map a bit:+--  * No entries outside the range+--  * No entries equal to the default+--  * No default if all elements have explicit values+mkSwitchTargets :: Bool -> (Integer, Integer) -> Maybe Label -> M.Map Integer Label -> SwitchTargets+mkSwitchTargets signed range@(lo,hi) mbdef ids+    = SwitchTargets signed range mbdef' ids'+  where+    ids' = dropDefault $ restrict ids+    mbdef' | defaultNeeded = mbdef+           | otherwise     = Nothing++    -- Drop entries outside the range, if there is a range+    restrict = restrictMap (lo,hi)++    -- Drop entries that equal the default, if there is a default+    dropDefault | Just l <- mbdef = M.filter (/= l)+                | otherwise       = id++    -- Check if the default is still needed+    defaultNeeded = fromIntegral (M.size ids') /= hi-lo+1+++-- | Changes all labels mentioned in the SwitchTargets value+mapSwitchTargets :: (Label -> Label) -> SwitchTargets -> SwitchTargets+mapSwitchTargets f (SwitchTargets signed range mbdef branches)+    = SwitchTargets signed range (fmap f mbdef) (fmap f branches)++-- | Returns the list of non-default branches of the SwitchTargets value+switchTargetsCases :: SwitchTargets -> [(Integer, Label)]+switchTargetsCases (SwitchTargets _ _ _ branches) = M.toList branches++-- | Return the default label of the SwitchTargets value+switchTargetsDefault :: SwitchTargets -> Maybe Label+switchTargetsDefault (SwitchTargets _ _ mbdef _) = mbdef++-- | Return the range of the SwitchTargets value+switchTargetsRange :: SwitchTargets -> (Integer, Integer)+switchTargetsRange (SwitchTargets _ range _ _) = range++-- | Return whether this is used for a signed value+switchTargetsSigned :: SwitchTargets -> Bool+switchTargetsSigned (SwitchTargets signed _ _ _) = signed++-- | switchTargetsToTable creates a dense jump table, usable for code generation.+--+-- Also returns an offset to add to the value; the list is 0-based on the+-- result of that addition.+--+-- The conversion from Integer to Int is a bit of a wart, as the actual+-- scrutinee might be an unsigned word, but it just works, due to wrap-around+-- arithmetic (as verified by the CmmSwitchTest test case).+switchTargetsToTable :: SwitchTargets -> (Int, [Maybe Label])+switchTargetsToTable (SwitchTargets _ (lo,hi) mbdef branches)+    = (fromIntegral (-start), [ labelFor i | i <- [start..hi] ])+  where+    labelFor i = case M.lookup i branches of Just l -> Just l+                                             Nothing -> mbdef+    start | lo >= 0 && lo < minJumpTableOffset  = 0  -- See Note [Jump Table Offset]+          | otherwise                           = lo++-- Note [Jump Table Offset]+-- ~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Usually, the code for a jump table starting at x will first subtract x from+-- the value, to avoid a large amount of empty entries. But if x is very small,+-- the extra entries are no worse than the subtraction in terms of code size, and+-- not having to do the subtraction is quicker.+--+-- I.e. instead of+--     _u20N:+--             leaq -1(%r14),%rax+--             jmp *_n20R(,%rax,8)+--     _n20R:+--             .quad   _c20p+--             .quad   _c20q+-- do+--     _u20N:+--             jmp *_n20Q(,%r14,8)+--+--     _n20Q:+--             .quad   0+--             .quad   _c20p+--             .quad   _c20q+--             .quad   _c20r++-- | The list of all labels occuring in the SwitchTargets value.+switchTargetsToList :: SwitchTargets -> [Label]+switchTargetsToList (SwitchTargets _ _ mbdef branches)+    = maybeToList mbdef ++ M.elems branches++-- | Groups cases with equal targets, suitable for pretty-printing to a+-- c-like switch statement with fall-through semantics.+switchTargetsFallThrough :: SwitchTargets -> ([([Integer], Label)], Maybe Label)+switchTargetsFallThrough (SwitchTargets _ _ mbdef branches) = (groups, mbdef)+  where+    groups = map (\xs -> (map fst xs, snd (head xs))) $+             groupBy ((==) `on` snd) $+             M.toList branches++-- | Custom equality helper, needed for "CmmCommonBlockElim"+eqSwitchTargetWith :: (Label -> Label -> Bool) -> SwitchTargets -> SwitchTargets -> Bool+eqSwitchTargetWith eq (SwitchTargets signed1 range1 mbdef1 ids1) (SwitchTargets signed2 range2 mbdef2 ids2) =+    signed1 == signed2 && range1 == range2 && goMB mbdef1 mbdef2 && goList (M.toList ids1) (M.toList ids2)+  where+    goMB Nothing Nothing = True+    goMB (Just l1) (Just l2) = l1 `eq` l2+    goMB _ _ = False+    goList [] [] = True+    goList ((i1,l1):ls1) ((i2,l2):ls2) = i1 == i2 && l1 `eq` l2 && goList ls1 ls2+    goList _ _ = False++-----------------------------------------------------------------------------+-- Code generation for Switches+++-- | A SwitchPlan abstractly describes how a Switch statement ought to be+-- implemented. See Note [createSwitchPlan]+data SwitchPlan+    = Unconditionally Label+    | IfEqual Integer Label SwitchPlan+    | IfLT Bool Integer SwitchPlan SwitchPlan+    | JumpTable SwitchTargets+  deriving Show+--+-- Note [createSwitchPlan]+-- ~~~~~~~~~~~~~~~~~~~~~~~+--+-- A SwitchPlan describes how a Switch statement is to be broken down into+-- smaller pieces suitable for code generation.+--+-- createSwitchPlan creates such a switch plan, in these steps:+--  1. It splits the switch statement at segments of non-default values that+--     are too large. See splitAtHoles and Note [Magic Constants in CmmSwitch]+--  2. Too small jump tables should be avoided, so we break up smaller pieces+--     in breakTooSmall.+--  3. We fill in the segments between those pieces with a jump to the default+--     label (if there is one), returning a SeparatedList in mkFlatSwitchPlan+--  4. We find and replace two less-than branches by a single equal-to-test in+--     findSingleValues+--  5. The thus collected pieces are assembled to a balanced binary tree.+++-- | Does the target support switch out of the box? Then leave this to the+-- target!+targetSupportsSwitch :: HscTarget -> Bool+targetSupportsSwitch HscC = True+targetSupportsSwitch HscLlvm = True+targetSupportsSwitch _ = False++-- | This function creates a SwitchPlan from a SwitchTargets value, breaking it+-- down into smaller pieces suitable for code generation.+createSwitchPlan :: SwitchTargets -> SwitchPlan+-- Lets do the common case of a singleton map quicky and efficiently (#10677)+createSwitchPlan (SwitchTargets _signed _range (Just defLabel) m)+    | [(x, l)] <- M.toList m+    = IfEqual x l (Unconditionally defLabel)+-- And another common case, matching booleans+createSwitchPlan (SwitchTargets _signed (lo,hi) Nothing m)+    | [(x1, l1), (x2,l2)] <- M.toAscList m+    , x1 == lo+    , x2 == hi+    , x1 + 1 == x2+    = IfEqual x1 l1 (Unconditionally l2)+createSwitchPlan (SwitchTargets signed range mbdef m) =+    -- pprTrace "createSwitchPlan" (text (show ids) $$ text (show (range,m)) $$ text (show pieces) $$ text (show flatPlan) $$ text (show plan)) $+    plan+  where+    pieces = concatMap breakTooSmall $ splitAtHoles maxJumpTableHole m+    flatPlan = findSingleValues $ mkFlatSwitchPlan signed mbdef range pieces+    plan = buildTree signed $ flatPlan+++---+--- Step 1: Splitting at large holes+---+splitAtHoles :: Integer -> M.Map Integer a -> [M.Map Integer a]+splitAtHoles _        m | M.null m = []+splitAtHoles holeSize m = map (\range -> restrictMap range m) nonHoles+  where+    holes = filter (\(l,h) -> h - l > holeSize) $ zip (M.keys m) (tail (M.keys m))+    nonHoles = reassocTuples lo holes hi++    (lo,_) = M.findMin m+    (hi,_) = M.findMax m++---+--- Step 2: Avoid small jump tables+---+-- We do not want jump tables below a certain size. This breaks them up+-- (into singleton maps, for now).+breakTooSmall :: M.Map Integer a -> [M.Map Integer a]+breakTooSmall m+  | M.size m > minJumpTableSize = [m]+  | otherwise                   = [M.singleton k v | (k,v) <- M.toList m]++---+---  Step 3: Fill in the blanks+---++-- | A FlatSwitchPlan is a list of SwitchPlans, with an integer inbetween every+-- two entries, dividing the range.+-- So if we have (abusing list syntax) [plan1,n,plan2], then we use plan1 if+-- the expression is < n, and plan2 otherwise.++type FlatSwitchPlan = SeparatedList Integer SwitchPlan++mkFlatSwitchPlan :: Bool -> Maybe Label -> (Integer, Integer) -> [M.Map Integer Label] -> FlatSwitchPlan++-- If we have no default (i.e. undefined where there is no entry), we can+-- branch at the minimum of each map+mkFlatSwitchPlan _ Nothing _ [] = pprPanic "mkFlatSwitchPlan with nothing left to do" empty+mkFlatSwitchPlan signed  Nothing _ (m:ms)+  = (mkLeafPlan signed Nothing m , [ (fst (M.findMin m'), mkLeafPlan signed Nothing m') | m' <- ms ])++-- If we have a default, we have to interleave segments that jump+-- to the default between the maps+mkFlatSwitchPlan signed (Just l) r ms = let ((_,p1):ps) = go r ms in (p1, ps)+  where+    go (lo,hi) []+        | lo > hi = []+        | otherwise = [(lo, Unconditionally l)]+    go (lo,hi) (m:ms)+        | lo < min+        = (lo, Unconditionally l) : go (min,hi) (m:ms)+        | lo == min+        = (lo, mkLeafPlan signed (Just l) m) : go (max+1,hi) ms+        | otherwise+        = pprPanic "mkFlatSwitchPlan" (integer lo <+> integer min)+      where+        min = fst (M.findMin m)+        max = fst (M.findMax m)+++mkLeafPlan :: Bool -> Maybe Label -> M.Map Integer Label -> SwitchPlan+mkLeafPlan signed mbdef m+    | [(_,l)] <- M.toList m -- singleton map+    = Unconditionally l+    | otherwise+    = JumpTable $ mkSwitchTargets signed (min,max) mbdef m+  where+    min = fst (M.findMin m)+    max = fst (M.findMax m)++---+---  Step 4: Reduce the number of branches using ==+---++-- A sequence of three unconditional jumps, with the outer two pointing to the+-- same value and the bounds off by exactly one can be improved+findSingleValues :: FlatSwitchPlan -> FlatSwitchPlan+findSingleValues (Unconditionally l, (i, Unconditionally l2) : (i', Unconditionally l3) : xs)+  | l == l3 && i + 1 == i'+  = findSingleValues (IfEqual i l2 (Unconditionally l), xs)+findSingleValues (p, (i,p'):xs)+  = (p,i) `consSL` findSingleValues (p', xs)+findSingleValues (p, [])+  = (p, [])++---+---  Step 5: Actually build the tree+---++-- Build a balanced tree from a separated list+buildTree :: Bool -> FlatSwitchPlan -> SwitchPlan+buildTree _ (p,[]) = p+buildTree signed sl = IfLT signed m (buildTree signed sl1) (buildTree signed sl2)+  where+    (sl1, m, sl2) = divideSL sl++++--+-- Utility data type: Non-empty lists with extra markers in between each+-- element:+--++type SeparatedList b a = (a, [(b,a)])++consSL :: (a, b) -> SeparatedList b a -> SeparatedList b a+consSL (a, b) (a', xs) = (a, (b,a'):xs)++divideSL :: SeparatedList b a -> (SeparatedList b a, b, SeparatedList b a)+divideSL (_,[]) = error "divideSL: Singleton SeparatedList"+divideSL (p,xs) = ((p, xs1), m, (p', xs2))+  where+    (xs1, (m,p'):xs2) = splitAt (length xs `div` 2) xs++--+-- Other Utilities+--++restrictMap :: (Integer,Integer) -> M.Map Integer b -> M.Map Integer b+restrictMap (lo,hi) m = mid+  where (_,   mid_hi) = M.split (lo-1) m+        (mid, _) =      M.split (hi+1) mid_hi++-- for example: reassocTuples a [(b,c),(d,e)] f == [(a,b),(c,d),(e,f)]+reassocTuples :: a -> [(a,a)] -> a -> [(a,a)]+reassocTuples initial [] last+    = [(initial,last)]+reassocTuples initial ((a,b):tuples) last+    = (initial,a) : reassocTuples b tuples last++-- Note [CmmSwitch vs. CmmImplementSwitchPlans]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- I (Joachim) separated the two somewhat closely related modules+--+--  - CmmSwitch, which provides the CmmSwitchTargets type and contains the strategy+--    for implementing a Cmm switch (createSwitchPlan), and+--  - CmmImplementSwitchPlans, which contains the actuall Cmm graph modification,+--+-- for these reasons:+--+--  * CmmSwitch is very low in the dependency tree, i.e. does not depend on any+--    GHC specific modules at all (with the exception of Output and Hoople+--    (Literal)). CmmImplementSwitchPlans is the Cmm transformation and hence very+--    high in the dependency tree.+--  * CmmSwitch provides the CmmSwitchTargets data type, which is abstract, but+--    used in CmmNodes.+--  * Because CmmSwitch is low in the dependency tree, the separation allows+--    for more parallelism when building GHC.+--  * The interaction between the modules is very explicit and easy to+--    understand, due to the small and simple interface.
+ cmm/CmmType.hs view
@@ -0,0 +1,439 @@+{-# LANGUAGE CPP #-}++module CmmType+    ( CmmType   -- Abstract+    , b8, b16, b32, b64, b128, b256, b512, f32, f64, bWord, bHalfWord, gcWord+    , cInt+    , cmmBits, cmmFloat+    , typeWidth, cmmEqType, cmmEqType_ignoring_ptrhood+    , isFloatType, isGcPtrType, isWord32, isWord64, isFloat64, isFloat32++    , Width(..)+    , widthInBits, widthInBytes, widthInLog, widthFromBytes+    , wordWidth, halfWordWidth, cIntWidth+    , halfWordMask+    , narrowU, narrowS+    , rEP_CostCentreStack_mem_alloc+    , rEP_CostCentreStack_scc_count+    , rEP_StgEntCounter_allocs+    , rEP_StgEntCounter_allocd++    , ForeignHint(..)++    , Length+    , vec, vec2, vec4, vec8, vec16+    , vec2f64, vec2b64, vec4f32, vec4b32, vec8b16, vec16b8+    , cmmVec+    , vecLength, vecElemType+    , isVecType+   )+where++#include "HsVersions.h"++import DynFlags+import FastString+import Outputable++import Data.Word+import Data.Int++-----------------------------------------------------------------------------+--              CmmType+-----------------------------------------------------------------------------++  -- NOTE: CmmType is an abstract type, not exported from this+  --       module so you can easily change its representation+  --+  -- However Width is exported in a concrete way,+  -- and is used extensively in pattern-matching++data CmmType    -- The important one!+  = CmmType CmmCat Width++data CmmCat                -- "Category" (not exported)+   = GcPtrCat              -- GC pointer+   | BitsCat               -- Non-pointer+   | FloatCat              -- Float+   | VecCat Length CmmCat  -- Vector+   deriving( Eq )+        -- See Note [Signed vs unsigned] at the end++instance Outputable CmmType where+  ppr (CmmType cat wid) = ppr cat <> ppr (widthInBits wid)++instance Outputable CmmCat where+  ppr FloatCat       = text "F"+  ppr GcPtrCat       = text "P"+  ppr BitsCat        = text "I"+  ppr (VecCat n cat) = ppr cat <> text "x" <> ppr n <> text "V"++-- Why is CmmType stratified?  For native code generation,+-- most of the time you just want to know what sort of register+-- to put the thing in, and for this you need to know how+-- many bits thing has and whether it goes in a floating-point+-- register.  By contrast, the distinction between GcPtr and+-- GcNonPtr is of interest to only a few parts of the code generator.++-------- Equality on CmmType --------------+-- CmmType is *not* an instance of Eq; sometimes we care about the+-- Gc/NonGc distinction, and sometimes we don't+-- So we use an explicit function to force you to think about it+cmmEqType :: CmmType -> CmmType -> Bool -- Exact equality+cmmEqType (CmmType c1 w1) (CmmType c2 w2) = c1==c2 && w1==w2++cmmEqType_ignoring_ptrhood :: CmmType -> CmmType -> Bool+  -- This equality is temporary; used in CmmLint+  -- but the RTS files are not yet well-typed wrt pointers+cmmEqType_ignoring_ptrhood (CmmType c1 w1) (CmmType c2 w2)+   = c1 `weak_eq` c2 && w1==w2+   where+     weak_eq :: CmmCat -> CmmCat -> Bool+     FloatCat         `weak_eq` FloatCat         = True+     FloatCat         `weak_eq` _other           = False+     _other           `weak_eq` FloatCat         = False+     (VecCat l1 cat1) `weak_eq` (VecCat l2 cat2) = l1 == l2+                                                   && cat1 `weak_eq` cat2+     (VecCat {})      `weak_eq` _other           = False+     _other           `weak_eq` (VecCat {})      = False+     _word1           `weak_eq` _word2           = True        -- Ignores GcPtr++--- Simple operations on CmmType -----+typeWidth :: CmmType -> Width+typeWidth (CmmType _ w) = w++cmmBits, cmmFloat :: Width -> CmmType+cmmBits  = CmmType BitsCat+cmmFloat = CmmType FloatCat++-------- Common CmmTypes ------------+-- Floats and words of specific widths+b8, b16, b32, b64, b128, b256, b512, f32, f64 :: CmmType+b8     = cmmBits W8+b16    = cmmBits W16+b32    = cmmBits W32+b64    = cmmBits W64+b128   = cmmBits W128+b256   = cmmBits W256+b512   = cmmBits W512+f32    = cmmFloat W32+f64    = cmmFloat W64++-- CmmTypes of native word widths+bWord :: DynFlags -> CmmType+bWord dflags = cmmBits (wordWidth dflags)++bHalfWord :: DynFlags -> CmmType+bHalfWord dflags = cmmBits (halfWordWidth dflags)++gcWord :: DynFlags -> CmmType+gcWord dflags = CmmType GcPtrCat (wordWidth dflags)++cInt :: DynFlags -> CmmType+cInt dflags = cmmBits (cIntWidth  dflags)++------------ Predicates ----------------+isFloatType, isGcPtrType :: CmmType -> Bool+isFloatType (CmmType FloatCat    _) = True+isFloatType _other                  = False++isGcPtrType (CmmType GcPtrCat _) = True+isGcPtrType _other               = False++isWord32, isWord64, isFloat32, isFloat64 :: CmmType -> Bool+-- isWord64 is true of 64-bit non-floats (both gc-ptrs and otherwise)+-- isFloat32 and 64 are obvious++isWord64 (CmmType BitsCat  W64) = True+isWord64 (CmmType GcPtrCat W64) = True+isWord64 _other                 = False++isWord32 (CmmType BitsCat  W32) = True+isWord32 (CmmType GcPtrCat W32) = True+isWord32 _other                 = False++isFloat32 (CmmType FloatCat W32) = True+isFloat32 _other                 = False++isFloat64 (CmmType FloatCat W64) = True+isFloat64 _other                 = False++-----------------------------------------------------------------------------+--              Width+-----------------------------------------------------------------------------++data Width   = W8 | W16 | W32 | W64+             | W80      -- Extended double-precision float,+                        -- used in x86 native codegen only.+                        -- (we use Ord, so it'd better be in this order)+             | W128+             | W256+             | W512+             deriving (Eq, Ord, Show)++instance Outputable Width where+   ppr rep = ptext (mrStr rep)++mrStr :: Width -> LitString+mrStr W8   = sLit("W8")+mrStr W16  = sLit("W16")+mrStr W32  = sLit("W32")+mrStr W64  = sLit("W64")+mrStr W128 = sLit("W128")+mrStr W256 = sLit("W256")+mrStr W512 = sLit("W512")+mrStr W80  = sLit("W80")+++-------- Common Widths  ------------+wordWidth :: DynFlags -> Width+wordWidth dflags+ | wORD_SIZE dflags == 4 = W32+ | wORD_SIZE dflags == 8 = W64+ | otherwise             = panic "MachOp.wordRep: Unknown word size"++halfWordWidth :: DynFlags -> Width+halfWordWidth dflags+ | wORD_SIZE dflags == 4 = W16+ | wORD_SIZE dflags == 8 = W32+ | otherwise             = panic "MachOp.halfWordRep: Unknown word size"++halfWordMask :: DynFlags -> Integer+halfWordMask dflags+ | wORD_SIZE dflags == 4 = 0xFFFF+ | wORD_SIZE dflags == 8 = 0xFFFFFFFF+ | otherwise             = panic "MachOp.halfWordMask: Unknown word size"++-- cIntRep is the Width for a C-language 'int'+cIntWidth :: DynFlags -> Width+cIntWidth dflags = case cINT_SIZE dflags of+                   4 -> W32+                   8 -> W64+                   s -> panic ("cIntWidth: Unknown cINT_SIZE: " ++ show s)++widthInBits :: Width -> Int+widthInBits W8   = 8+widthInBits W16  = 16+widthInBits W32  = 32+widthInBits W64  = 64+widthInBits W128 = 128+widthInBits W256 = 256+widthInBits W512 = 512+widthInBits W80  = 80++widthInBytes :: Width -> Int+widthInBytes W8   = 1+widthInBytes W16  = 2+widthInBytes W32  = 4+widthInBytes W64  = 8+widthInBytes W128 = 16+widthInBytes W256 = 32+widthInBytes W512 = 64+widthInBytes W80  = 10++widthFromBytes :: Int -> Width+widthFromBytes 1  = W8+widthFromBytes 2  = W16+widthFromBytes 4  = W32+widthFromBytes 8  = W64+widthFromBytes 16 = W128+widthFromBytes 32 = W256+widthFromBytes 64 = W512+widthFromBytes 10 = W80+widthFromBytes n  = pprPanic "no width for given number of bytes" (ppr n)++-- log_2 of the width in bytes, useful for generating shifts.+widthInLog :: Width -> Int+widthInLog W8   = 0+widthInLog W16  = 1+widthInLog W32  = 2+widthInLog W64  = 3+widthInLog W128 = 4+widthInLog W256 = 5+widthInLog W512 = 6+widthInLog W80  = panic "widthInLog: F80"++-- widening / narrowing++narrowU :: Width -> Integer -> Integer+narrowU W8  x = fromIntegral (fromIntegral x :: Word8)+narrowU W16 x = fromIntegral (fromIntegral x :: Word16)+narrowU W32 x = fromIntegral (fromIntegral x :: Word32)+narrowU W64 x = fromIntegral (fromIntegral x :: Word64)+narrowU _ _ = panic "narrowTo"++narrowS :: Width -> Integer -> Integer+narrowS W8  x = fromIntegral (fromIntegral x :: Int8)+narrowS W16 x = fromIntegral (fromIntegral x :: Int16)+narrowS W32 x = fromIntegral (fromIntegral x :: Int32)+narrowS W64 x = fromIntegral (fromIntegral x :: Int64)+narrowS _ _ = panic "narrowTo"++-----------------------------------------------------------------------------+--              SIMD+-----------------------------------------------------------------------------++type Length = Int++vec :: Length -> CmmType -> CmmType+vec l (CmmType cat w) = CmmType (VecCat l cat) vecw+  where+    vecw :: Width+    vecw = widthFromBytes (l*widthInBytes w)++vec2, vec4, vec8, vec16 :: CmmType -> CmmType+vec2  = vec 2+vec4  = vec 4+vec8  = vec 8+vec16 = vec 16++vec2f64, vec2b64, vec4f32, vec4b32, vec8b16, vec16b8 :: CmmType+vec2f64 = vec 2 f64+vec2b64 = vec 2 b64+vec4f32 = vec 4 f32+vec4b32 = vec 4 b32+vec8b16 = vec 8 b16+vec16b8 = vec 16 b8++cmmVec :: Int -> CmmType -> CmmType+cmmVec n (CmmType cat w) =+    CmmType (VecCat n cat) (widthFromBytes (n*widthInBytes w))++vecLength :: CmmType -> Length+vecLength (CmmType (VecCat l _) _) = l+vecLength _                        = panic "vecLength: not a vector"++vecElemType :: CmmType -> CmmType+vecElemType (CmmType (VecCat l cat) w) = CmmType cat scalw+  where+    scalw :: Width+    scalw = widthFromBytes (widthInBytes w `div` l)+vecElemType _ = panic "vecElemType: not a vector"++isVecType :: CmmType -> Bool+isVecType (CmmType (VecCat {}) _) = True+isVecType _                       = False++-------------------------------------------------------------------------+-- Hints++-- Hints are extra type information we attach to the arguments and+-- results of a foreign call, where more type information is sometimes+-- needed by the ABI to make the correct kind of call.++data ForeignHint+  = NoHint | AddrHint | SignedHint+  deriving( Eq )+        -- Used to give extra per-argument or per-result+        -- information needed by foreign calling conventions++-------------------------------------------------------------------------++-- These don't really belong here, but I don't know where is best to+-- put them.++rEP_CostCentreStack_mem_alloc :: DynFlags -> CmmType+rEP_CostCentreStack_mem_alloc dflags+    = cmmBits (widthFromBytes (pc_REP_CostCentreStack_mem_alloc pc))+    where pc = sPlatformConstants (settings dflags)++rEP_CostCentreStack_scc_count :: DynFlags -> CmmType+rEP_CostCentreStack_scc_count dflags+    = cmmBits (widthFromBytes (pc_REP_CostCentreStack_scc_count pc))+    where pc = sPlatformConstants (settings dflags)++rEP_StgEntCounter_allocs :: DynFlags -> CmmType+rEP_StgEntCounter_allocs dflags+    = cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocs pc))+    where pc = sPlatformConstants (settings dflags)++rEP_StgEntCounter_allocd :: DynFlags -> CmmType+rEP_StgEntCounter_allocd dflags+    = cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocd pc))+    where pc = sPlatformConstants (settings dflags)++-------------------------------------------------------------------------+{-      Note [Signed vs unsigned]+        ~~~~~~~~~~~~~~~~~~~~~~~~~+Should a CmmType include a signed vs. unsigned distinction?++This is very much like a "hint" in C-- terminology: it isn't necessary+in order to generate correct code, but it might be useful in that the+compiler can generate better code if it has access to higher-level+hints about data.  This is important at call boundaries, because the+definition of a function is not visible at all of its call sites, so+the compiler cannot infer the hints.++Here in Cmm, we're taking a slightly different approach.  We include+the int vs. float hint in the CmmType, because (a) the majority of+platforms have a strong distinction between float and int registers,+and (b) we don't want to do any heavyweight hint-inference in the+native code backend in order to get good code.  We're treating the+hint more like a type: our Cmm is always completely consistent with+respect to hints.  All coercions between float and int are explicit.++What about the signed vs. unsigned hint?  This information might be+useful if we want to keep sub-word-sized values in word-size+registers, which we must do if we only have word-sized registers.++On such a system, there are two straightforward conventions for+representing sub-word-sized values:++(a) Leave the upper bits undefined.  Comparison operations must+    sign- or zero-extend both operands before comparing them,+    depending on whether the comparison is signed or unsigned.++(b) Always keep the values sign- or zero-extended as appropriate.+    Arithmetic operations must narrow the result to the appropriate+    size.++A clever compiler might not use either (a) or (b) exclusively, instead+it would attempt to minimize the coercions by analysis: the same kind+of analysis that propagates hints around.  In Cmm we don't want to+have to do this, so we plump for having richer types and keeping the+type information consistent.++If signed/unsigned hints are missing from CmmType, then the only+choice we have is (a), because we don't know whether the result of an+operation should be sign- or zero-extended.++Many architectures have extending load operations, which work well+with (b).  To make use of them with (a), you need to know whether the+value is going to be sign- or zero-extended by an enclosing comparison+(for example), which involves knowing above the context.  This is+doable but more complex.++Further complicating the issue is foreign calls: a foreign calling+convention can specify that signed 8-bit quantities are passed as+sign-extended 32 bit quantities, for example (this is the case on the+PowerPC).  So we *do* need sign information on foreign call arguments.++Pros for adding signed vs. unsigned to CmmType:++  - It would let us use convention (b) above, and get easier+    code generation for extending loads.++  - Less information required on foreign calls.++  - MachOp type would be simpler++Cons:++  - More complexity++  - What is the CmmType for a VanillaReg?  Currently it is+    always wordRep, but now we have to decide whether it is+    signed or unsigned.  The same VanillaReg can thus have+    different CmmType in different parts of the program.++  - Extra coercions cluttering up expressions.++Currently for GHC, the foreign call point is moot, because we do our+own promotion of sub-word-sized values to word-sized values.  The Int8+type is represented by an Int# which is kept sign-extended at all times+(this is slightly naughty, because we're making assumptions about the+C calling convention rather early on in the compiler).  However, given+this, the cons outweigh the pros.++-}+
+ cmm/CmmUtils.hs view
@@ -0,0 +1,568 @@+{-# LANGUAGE CPP, GADTs, RankNTypes #-}++-----------------------------------------------------------------------------+--+-- Cmm utilities.+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module CmmUtils(+        -- CmmType+        primRepCmmType, slotCmmType, slotForeignHint,+        typeCmmType, typeForeignHint, primRepForeignHint,++        -- CmmLit+        zeroCLit, mkIntCLit,+        mkWordCLit, packHalfWordsCLit,+        mkByteStringCLit,+        mkDataLits, mkRODataLits,+        mkStgWordCLit,++        -- CmmExpr+        mkIntExpr, zeroExpr,+        mkLblExpr,+        cmmRegOff,  cmmOffset,  cmmLabelOff,  cmmOffsetLit,  cmmOffsetExpr,+        cmmRegOffB, cmmOffsetB, cmmLabelOffB, cmmOffsetLitB, cmmOffsetExprB,+        cmmRegOffW, cmmOffsetW, cmmLabelOffW, cmmOffsetLitW, cmmOffsetExprW,+        cmmIndex, cmmIndexExpr, cmmLoadIndex, cmmLoadIndexW,+        cmmNegate,+        cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,+        cmmSLtWord,+        cmmNeWord, cmmEqWord,+        cmmOrWord, cmmAndWord,+        cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord,+        cmmToWord,++        isTrivialCmmExpr, hasNoGlobalRegs,++        -- Statics+        blankWord,++        -- Tagging+        cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged,+        cmmConstrTag1,++        -- Overlap and usage+        regsOverlap, regUsedIn,++        -- Liveness and bitmaps+        mkLiveness,++        -- * Operations that probably don't belong here+        modifyGraph,++        ofBlockMap, toBlockMap, insertBlock,+        ofBlockList, toBlockList, bodyToBlockList,+        toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,+        foldGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1,++        -- * Ticks+        blockTicks+  ) where++#include "HsVersions.h"++import TyCon    ( PrimRep(..), PrimElemRep(..) )+import RepType  ( UnaryType, SlotTy (..), typePrimRep1 )++import SMRep+import Cmm+import BlockId+import CLabel+import Outputable+import DynFlags+import Util+import CodeGen.Platform++import Data.Word+import Data.Maybe+import Data.Bits+import Hoopl++---------------------------------------------------+--+--      CmmTypes+--+---------------------------------------------------++primRepCmmType :: DynFlags -> PrimRep -> CmmType+primRepCmmType _      VoidRep          = panic "primRepCmmType:VoidRep"+primRepCmmType dflags LiftedRep        = gcWord dflags+primRepCmmType dflags UnliftedRep      = gcWord dflags+primRepCmmType dflags IntRep           = bWord dflags+primRepCmmType dflags WordRep          = bWord dflags+primRepCmmType _      Int64Rep         = b64+primRepCmmType _      Word64Rep        = b64+primRepCmmType dflags AddrRep          = bWord dflags+primRepCmmType _      FloatRep         = f32+primRepCmmType _      DoubleRep        = f64+primRepCmmType _      (VecRep len rep) = vec len (primElemRepCmmType rep)++slotCmmType :: DynFlags -> SlotTy -> CmmType+slotCmmType dflags PtrSlot    = gcWord dflags+slotCmmType dflags WordSlot   = bWord dflags+slotCmmType _      Word64Slot = b64+slotCmmType _      FloatSlot  = f32+slotCmmType _      DoubleSlot = f64++primElemRepCmmType :: PrimElemRep -> CmmType+primElemRepCmmType Int8ElemRep   = b8+primElemRepCmmType Int16ElemRep  = b16+primElemRepCmmType Int32ElemRep  = b32+primElemRepCmmType Int64ElemRep  = b64+primElemRepCmmType Word8ElemRep  = b8+primElemRepCmmType Word16ElemRep = b16+primElemRepCmmType Word32ElemRep = b32+primElemRepCmmType Word64ElemRep = b64+primElemRepCmmType FloatElemRep  = f32+primElemRepCmmType DoubleElemRep = f64++typeCmmType :: DynFlags -> UnaryType -> CmmType+typeCmmType dflags ty = primRepCmmType dflags (typePrimRep1 ty)++primRepForeignHint :: PrimRep -> ForeignHint+primRepForeignHint VoidRep      = panic "primRepForeignHint:VoidRep"+primRepForeignHint LiftedRep    = AddrHint+primRepForeignHint UnliftedRep  = AddrHint+primRepForeignHint IntRep       = SignedHint+primRepForeignHint WordRep      = NoHint+primRepForeignHint Int64Rep     = SignedHint+primRepForeignHint Word64Rep    = NoHint+primRepForeignHint AddrRep      = AddrHint -- NB! AddrHint, but NonPtrArg+primRepForeignHint FloatRep     = NoHint+primRepForeignHint DoubleRep    = NoHint+primRepForeignHint (VecRep {})  = NoHint++slotForeignHint :: SlotTy -> ForeignHint+slotForeignHint PtrSlot       = AddrHint+slotForeignHint WordSlot      = NoHint+slotForeignHint Word64Slot    = NoHint+slotForeignHint FloatSlot     = NoHint+slotForeignHint DoubleSlot    = NoHint++typeForeignHint :: UnaryType -> ForeignHint+typeForeignHint = primRepForeignHint . typePrimRep1++---------------------------------------------------+--+--      CmmLit+--+---------------------------------------------------++-- XXX: should really be Integer, since Int doesn't necessarily cover+-- the full range of target Ints.+mkIntCLit :: DynFlags -> Int -> CmmLit+mkIntCLit dflags i = CmmInt (toInteger i) (wordWidth dflags)++mkIntExpr :: DynFlags -> Int -> CmmExpr+mkIntExpr dflags i = CmmLit $! mkIntCLit dflags i++zeroCLit :: DynFlags -> CmmLit+zeroCLit dflags = CmmInt 0 (wordWidth dflags)++zeroExpr :: DynFlags -> CmmExpr+zeroExpr dflags = CmmLit (zeroCLit dflags)++mkWordCLit :: DynFlags -> Integer -> CmmLit+mkWordCLit dflags wd = CmmInt wd (wordWidth dflags)++mkByteStringCLit+  :: CLabel -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stmt)+-- We have to make a top-level decl for the string,+-- and return a literal pointing to it+mkByteStringCLit lbl bytes+  = (CmmLabel lbl, CmmData (Section sec lbl) $ Statics lbl [CmmString bytes])+  where+    -- This can not happen for String literals (as there \NUL is replaced by+    -- C0 80). However, it can happen with Addr# literals.+    sec = if 0 `elem` bytes then ReadOnlyData else CString++mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt+-- Build a data-segment data block+mkDataLits section lbl lits+  = CmmData section (Statics lbl $ map CmmStaticLit lits)++mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt+-- Build a read-only data block+mkRODataLits lbl lits+  = mkDataLits section lbl lits+  where+    section | any needsRelocation lits = Section RelocatableReadOnlyData lbl+            | otherwise                = Section ReadOnlyData lbl+    needsRelocation (CmmLabel _)      = True+    needsRelocation (CmmLabelOff _ _) = True+    needsRelocation _                 = False++mkStgWordCLit :: DynFlags -> StgWord -> CmmLit+mkStgWordCLit dflags wd = CmmInt (fromStgWord wd) (wordWidth dflags)++packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit+-- Make a single word literal in which the lower_half_word is+-- at the lower address, and the upper_half_word is at the+-- higher address+-- ToDo: consider using half-word lits instead+--       but be careful: that's vulnerable when reversed+packHalfWordsCLit dflags lower_half_word upper_half_word+   = if wORDS_BIGENDIAN dflags+     then mkWordCLit dflags ((l `shiftL` hALF_WORD_SIZE_IN_BITS dflags) .|. u)+     else mkWordCLit dflags (l .|. (u `shiftL` hALF_WORD_SIZE_IN_BITS dflags))+    where l = fromStgHalfWord lower_half_word+          u = fromStgHalfWord upper_half_word++---------------------------------------------------+--+--      CmmExpr+--+---------------------------------------------------++mkLblExpr :: CLabel -> CmmExpr+mkLblExpr lbl = CmmLit (CmmLabel lbl)++cmmOffsetExpr :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr+-- assumes base and offset have the same CmmType+cmmOffsetExpr dflags e (CmmLit (CmmInt n _)) = cmmOffset dflags e (fromInteger n)+cmmOffsetExpr dflags e byte_off = CmmMachOp (MO_Add (cmmExprWidth dflags e)) [e, byte_off]++cmmOffset :: DynFlags -> CmmExpr -> Int -> CmmExpr+cmmOffset _ e                 0        = e+cmmOffset _ (CmmReg reg)      byte_off = cmmRegOff reg byte_off+cmmOffset _ (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off)+cmmOffset _ (CmmLit lit)      byte_off = CmmLit (cmmOffsetLit lit byte_off)+cmmOffset _ (CmmStackSlot area off) byte_off+  = CmmStackSlot area (off - byte_off)+  -- note stack area offsets increase towards lower addresses+cmmOffset _ (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2+  = CmmMachOp (MO_Add rep)+              [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)]+cmmOffset dflags expr byte_off+  = CmmMachOp (MO_Add width) [expr, CmmLit (CmmInt (toInteger byte_off) width)]+  where+    width = cmmExprWidth dflags expr++-- Smart constructor for CmmRegOff.  Same caveats as cmmOffset above.+cmmRegOff :: CmmReg -> Int -> CmmExpr+cmmRegOff reg 0        = CmmReg reg+cmmRegOff reg byte_off = CmmRegOff reg byte_off++cmmOffsetLit :: CmmLit -> Int -> CmmLit+cmmOffsetLit (CmmLabel l)      byte_off = cmmLabelOff l byte_off+cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off)+cmmOffsetLit (CmmLabelDiffOff l1 l2 m) byte_off+                                        = CmmLabelDiffOff l1 l2 (m+byte_off)+cmmOffsetLit (CmmInt m rep)    byte_off = CmmInt (m + fromIntegral byte_off) rep+cmmOffsetLit _                 byte_off = pprPanic "cmmOffsetLit" (ppr byte_off)++cmmLabelOff :: CLabel -> Int -> CmmLit+-- Smart constructor for CmmLabelOff+cmmLabelOff lbl 0        = CmmLabel lbl+cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off++-- | Useful for creating an index into an array, with a statically known offset.+-- The type is the element type; used for making the multiplier+cmmIndex :: DynFlags+         -> Width       -- Width w+         -> CmmExpr     -- Address of vector of items of width w+         -> Int         -- Which element of the vector (0 based)+         -> CmmExpr     -- Address of i'th element+cmmIndex dflags width base idx = cmmOffset dflags base (idx * widthInBytes width)++-- | Useful for creating an index into an array, with an unknown offset.+cmmIndexExpr :: DynFlags+             -> Width           -- Width w+             -> CmmExpr         -- Address of vector of items of width w+             -> CmmExpr         -- Which element of the vector (0 based)+             -> CmmExpr         -- Address of i'th element+cmmIndexExpr dflags width base (CmmLit (CmmInt n _)) = cmmIndex dflags width base (fromInteger n)+cmmIndexExpr dflags width base idx =+  cmmOffsetExpr dflags base byte_off+  where+    idx_w = cmmExprWidth dflags idx+    byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr dflags (widthInLog width)]++cmmLoadIndex :: DynFlags -> CmmType -> CmmExpr -> Int -> CmmExpr+cmmLoadIndex dflags ty expr ix = CmmLoad (cmmIndex dflags (typeWidth ty) expr ix) ty++-- The "B" variants take byte offsets+cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr+cmmRegOffB = cmmRegOff++cmmOffsetB :: DynFlags -> CmmExpr -> ByteOff -> CmmExpr+cmmOffsetB = cmmOffset++cmmOffsetExprB :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr+cmmOffsetExprB = cmmOffsetExpr++cmmLabelOffB :: CLabel -> ByteOff -> CmmLit+cmmLabelOffB = cmmLabelOff++cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit+cmmOffsetLitB = cmmOffsetLit++-----------------------+-- The "W" variants take word offsets++cmmOffsetExprW :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr+-- The second arg is a *word* offset; need to change it to bytes+cmmOffsetExprW dflags  e (CmmLit (CmmInt n _)) = cmmOffsetW dflags e (fromInteger n)+cmmOffsetExprW dflags e wd_off = cmmIndexExpr dflags (wordWidth dflags) e wd_off++cmmOffsetW :: DynFlags -> CmmExpr -> WordOff -> CmmExpr+cmmOffsetW dflags e n = cmmOffsetB dflags e (wordsToBytes dflags n)++cmmRegOffW :: DynFlags -> CmmReg -> WordOff -> CmmExpr+cmmRegOffW dflags reg wd_off = cmmRegOffB reg (wordsToBytes dflags wd_off)++cmmOffsetLitW :: DynFlags -> CmmLit -> WordOff -> CmmLit+cmmOffsetLitW dflags lit wd_off = cmmOffsetLitB lit (wordsToBytes dflags wd_off)++cmmLabelOffW :: DynFlags -> CLabel -> WordOff -> CmmLit+cmmLabelOffW dflags lbl wd_off = cmmLabelOffB lbl (wordsToBytes dflags wd_off)++cmmLoadIndexW :: DynFlags -> CmmExpr -> Int -> CmmType -> CmmExpr+cmmLoadIndexW dflags base off ty = CmmLoad (cmmOffsetW dflags base off) ty++-----------------------+cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,+  cmmSLtWord,+  cmmNeWord, cmmEqWord,+  cmmOrWord, cmmAndWord,+  cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord+  :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr+cmmOrWord dflags  e1 e2 = CmmMachOp (mo_wordOr dflags)  [e1, e2]+cmmAndWord dflags e1 e2 = CmmMachOp (mo_wordAnd dflags) [e1, e2]+cmmNeWord dflags  e1 e2 = CmmMachOp (mo_wordNe dflags)  [e1, e2]+cmmEqWord dflags  e1 e2 = CmmMachOp (mo_wordEq dflags)  [e1, e2]+cmmULtWord dflags e1 e2 = CmmMachOp (mo_wordULt dflags) [e1, e2]+cmmUGeWord dflags e1 e2 = CmmMachOp (mo_wordUGe dflags) [e1, e2]+cmmUGtWord dflags e1 e2 = CmmMachOp (mo_wordUGt dflags) [e1, e2]+--cmmShlWord dflags e1 e2 = CmmMachOp (mo_wordShl dflags) [e1, e2]+cmmSLtWord dflags e1 e2 = CmmMachOp (mo_wordSLt dflags) [e1, e2]+cmmUShrWord dflags e1 e2 = CmmMachOp (mo_wordUShr dflags) [e1, e2]+cmmAddWord dflags e1 e2 = CmmMachOp (mo_wordAdd dflags) [e1, e2]+cmmSubWord dflags e1 e2 = CmmMachOp (mo_wordSub dflags) [e1, e2]+cmmMulWord dflags e1 e2 = CmmMachOp (mo_wordMul dflags) [e1, e2]+cmmQuotWord dflags e1 e2 = CmmMachOp (mo_wordUQuot dflags) [e1, e2]++cmmNegate :: DynFlags -> CmmExpr -> CmmExpr+cmmNegate _      (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)+cmmNegate dflags e                       = CmmMachOp (MO_S_Neg (cmmExprWidth dflags e)) [e]++blankWord :: DynFlags -> CmmStatic+blankWord dflags = CmmUninitialised (wORD_SIZE dflags)++cmmToWord :: DynFlags -> CmmExpr -> CmmExpr+cmmToWord dflags e+  | w == word  = e+  | otherwise  = CmmMachOp (MO_UU_Conv w word) [e]+  where+    w = cmmExprWidth dflags e+    word = wordWidth dflags++---------------------------------------------------+--+--      CmmExpr predicates+--+---------------------------------------------------++isTrivialCmmExpr :: CmmExpr -> Bool+isTrivialCmmExpr (CmmLoad _ _)      = False+isTrivialCmmExpr (CmmMachOp _ _)    = False+isTrivialCmmExpr (CmmLit _)         = True+isTrivialCmmExpr (CmmReg _)         = True+isTrivialCmmExpr (CmmRegOff _ _)    = True+isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot"++hasNoGlobalRegs :: CmmExpr -> Bool+hasNoGlobalRegs (CmmLoad e _)              = hasNoGlobalRegs e+hasNoGlobalRegs (CmmMachOp _ es)           = all hasNoGlobalRegs es+hasNoGlobalRegs (CmmLit _)                 = True+hasNoGlobalRegs (CmmReg (CmmLocal _))      = True+hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True+hasNoGlobalRegs _ = False++---------------------------------------------------+--+--      Tagging+--+---------------------------------------------------++-- Tag bits mask+--cmmTagBits = CmmLit (mkIntCLit tAG_BITS)+cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr+cmmTagMask dflags = mkIntExpr dflags (tAG_MASK dflags)+cmmPointerMask dflags = mkIntExpr dflags (complement (tAG_MASK dflags))++-- Used to untag a possibly tagged pointer+-- A static label need not be untagged+cmmUntag :: DynFlags -> CmmExpr -> CmmExpr+cmmUntag _ e@(CmmLit (CmmLabel _)) = e+-- Default case+cmmUntag dflags e = cmmAndWord dflags e (cmmPointerMask dflags)++-- Test if a closure pointer is untagged+cmmIsTagged :: DynFlags -> CmmExpr -> CmmExpr+cmmIsTagged dflags e = cmmNeWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (zeroExpr dflags)++cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr+-- Get constructor tag, but one based.+cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags)+++-----------------------------------------------------------------------------+-- Overlap and usage++-- | Returns True if the two STG registers overlap on the specified+-- platform, in the sense that writing to one will clobber the+-- other. This includes the case that the two registers are the same+-- STG register. See Note [Overlapping global registers] for details.+regsOverlap :: DynFlags -> CmmReg -> CmmReg -> Bool+regsOverlap dflags (CmmGlobal g) (CmmGlobal g')+  | Just real  <- globalRegMaybe (targetPlatform dflags) g,+    Just real' <- globalRegMaybe (targetPlatform dflags) g',+    real == real'+    = True+regsOverlap _ reg reg' = reg == reg'++-- | Returns True if the STG register is used by the expression, in+-- the sense that a store to the register might affect the value of+-- the expression.+--+-- We must check for overlapping registers and not just equal+-- registers here, otherwise CmmSink may incorrectly reorder+-- assignments that conflict due to overlap. See Trac #10521 and Note+-- [Overlapping global registers].+regUsedIn :: DynFlags -> CmmReg -> CmmExpr -> Bool+regUsedIn dflags = regUsedIn_ where+  _   `regUsedIn_` CmmLit _         = False+  reg `regUsedIn_` CmmLoad e  _     = reg `regUsedIn_` e+  reg `regUsedIn_` CmmReg reg'      = regsOverlap dflags reg reg'+  reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap dflags reg reg'+  reg `regUsedIn_` CmmMachOp _ es   = any (reg `regUsedIn_`) es+  _   `regUsedIn_` CmmStackSlot _ _ = False++--------------------------------------------+--+--        mkLiveness+--+---------------------------------------------++mkLiveness :: DynFlags -> [Maybe LocalReg] -> Liveness+mkLiveness _      [] = []+mkLiveness dflags (reg:regs)+  = take sizeW bits ++ mkLiveness dflags regs+  where+    sizeW = case reg of+              Nothing -> 1+              Just r -> (widthInBytes (typeWidth (localRegType r)) + wORD_SIZE dflags - 1)+                        `quot` wORD_SIZE dflags+                        -- number of words, rounded up+    bits = repeat $ is_non_ptr reg -- True <=> Non Ptr++    is_non_ptr Nothing    = True+    is_non_ptr (Just reg) = not $ isGcPtrType (localRegType reg)+++-- ============================================== -+-- ============================================== -+-- ============================================== -++---------------------------------------------------+--+--      Manipulating CmmGraphs+--+---------------------------------------------------++modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n'+modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)}++toBlockMap :: CmmGraph -> LabelMap CmmBlock+toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body++ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph+ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}++insertBlock :: CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock+insertBlock block map =+  ASSERT(isNothing $ mapLookup id map)+  mapInsert id block map+  where id = entryLabel block++toBlockList :: CmmGraph -> [CmmBlock]+toBlockList g = mapElems $ toBlockMap g++-- | like 'toBlockList', but the entry block always comes first+toBlockListEntryFirst :: CmmGraph -> [CmmBlock]+toBlockListEntryFirst g+  | mapNull m  = []+  | otherwise  = entry_block : others+  where+    m = toBlockMap g+    entry_id = g_entry g+    Just entry_block = mapLookup entry_id m+    others = filter ((/= entry_id) . entryLabel) (mapElems m)++-- | Like 'toBlockListEntryFirst', but we strive to ensure that we order blocks+-- so that the false case of a conditional jumps to the next block in the output+-- list of blocks. This matches the way OldCmm blocks were output since in+-- OldCmm the false case was a fallthrough, whereas in Cmm conditional branches+-- have both true and false successors. Block ordering can make a big difference+-- in performance in the LLVM backend. Note that we rely crucially on the order+-- of successors returned for CmmCondBranch by the NonLocal instance for CmmNode+-- defind in cmm/CmmNode.hs. -GBM+toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock]+toBlockListEntryFirstFalseFallthrough g+  | mapNull m  = []+  | otherwise  = dfs setEmpty [entry_block]+  where+    m = toBlockMap g+    entry_id = g_entry g+    Just entry_block = mapLookup entry_id m++    dfs :: LabelSet -> [CmmBlock] -> [CmmBlock]+    dfs _ [] = []+    dfs visited (block:bs)+      | id `setMember` visited = dfs visited bs+      | otherwise              = block : dfs (setInsert id visited) bs'+      where id = entryLabel block+            bs' = foldr add_id bs (successors block)+            add_id id bs = case mapLookup id m of+                              Just b  -> b : bs+                              Nothing -> bs++ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph+ofBlockList entry blocks = CmmGraph { g_entry = entry+                                    , g_graph = GMany NothingO body NothingO }+  where body = foldr addBlock emptyBody blocks++bodyToBlockList :: Body CmmNode -> [CmmBlock]+bodyToBlockList body = mapElems body++mapGraphNodes :: ( CmmNode C O -> CmmNode C O+                 , CmmNode O O -> CmmNode O O+                 , CmmNode O C -> CmmNode O C)+              -> CmmGraph -> CmmGraph+mapGraphNodes funs@(mf,_,_) g =+  ofBlockMap (entryLabel $ mf $ CmmEntry (g_entry g) GlobalScope) $+  mapMap (mapBlock3' funs) $ toBlockMap g++mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph+mapGraphNodes1 f = modifyGraph (mapGraph f)+++foldGraphBlocks :: (CmmBlock -> a -> a) -> a -> CmmGraph -> a+foldGraphBlocks k z g = mapFold k z $ toBlockMap g++postorderDfs :: CmmGraph -> [CmmBlock]+postorderDfs g = {-# SCC "postorderDfs" #-} postorder_dfs_from (toBlockMap g) (g_entry g)++-------------------------------------------------+-- Tick utilities++-- | Extract all tick annotations from the given block+blockTicks :: Block CmmNode C C -> [CmmTickish]+blockTicks b = reverse $ foldBlockNodesF goStmt b []+  where goStmt :: CmmNode e x -> [CmmTickish] -> [CmmTickish]+        goStmt  (CmmTick t) ts = t:ts+        goStmt  _other      ts = ts
+ cmm/Debug.hs view
@@ -0,0 +1,459 @@+{-# LANGUAGE GADTs #-}++-----------------------------------------------------------------------------+--+-- Debugging data+--+-- Association of debug data on the Cmm level, with methods to encode it in+-- event log format for later inclusion in profiling event logs.+--+-----------------------------------------------------------------------------++module Debug (++  DebugBlock(..), dblIsEntry,+  cmmDebugGen,+  cmmDebugLabels,+  cmmDebugLink,+  debugToMap,++  -- * Unwinding information+  UnwindTable, UnwindPoint(..),+  UnwindExpr(..), toUnwindExpr+  ) where++import BlockId+import CLabel+import Cmm+import CmmUtils+import CoreSyn+import FastString      ( nilFS, mkFastString )+import Module+import Outputable+import PprCore         ()+import PprCmmExpr      ( pprExpr )+import SrcLoc+import Util++import Compiler.Hoopl++import Data.Maybe+import Data.List     ( minimumBy, nubBy )+import Data.Ord      ( comparing )+import qualified Data.Map as Map++-- | Debug information about a block of code. Ticks scope over nested+-- blocks.+data DebugBlock =+  DebugBlock+  { dblProcedure  :: !Label        -- ^ Entry label of containing proc+  , dblLabel      :: !Label        -- ^ Hoopl label+  , dblCLabel     :: !CLabel       -- ^ Output label+  , dblHasInfoTbl :: !Bool         -- ^ Has an info table?+  , dblParent     :: !(Maybe DebugBlock)+    -- ^ The parent of this proc. See Note [Splitting DebugBlocks]+  , dblTicks      :: ![CmmTickish] -- ^ Ticks defined in this block+  , dblSourceTick+            :: !(Maybe CmmTickish) -- ^ Best source tick covering block+  , dblPosition   :: !(Maybe Int)  -- ^ Output position relative to+                                   -- other blocks. @Nothing@ means+                                   -- the block was optimized out+  , dblUnwind     :: [UnwindPoint]+  , dblBlocks     :: ![DebugBlock] -- ^ Nested blocks+  }++-- | Is this the entry block?+dblIsEntry :: DebugBlock -> Bool+dblIsEntry blk = dblProcedure blk == dblLabel blk++instance Outputable DebugBlock where+  ppr blk = (if dblProcedure blk == dblLabel blk+             then text "proc "+             else if dblHasInfoTbl blk+                  then text "pp-blk "+                  else text "blk ") <>+            ppr (dblLabel blk) <+> parens (ppr (dblCLabel blk)) <+>+            (maybe empty ppr (dblSourceTick blk)) <+>+            (maybe (text "removed") ((text "pos " <>) . ppr)+                   (dblPosition blk)) <+>+            (ppr (dblUnwind blk)) <+>+            (if null (dblBlocks blk) then empty else ppr (dblBlocks blk))++-- | Intermediate data structure holding debug-relevant context information+-- about a block.+type BlockContext = (CmmBlock, RawCmmDecl)++-- | Extract debug data from a group of procedures. We will prefer+-- source notes that come from the given module (presumably the module+-- that we are currently compiling).+cmmDebugGen :: ModLocation -> RawCmmGroup -> [DebugBlock]+cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes+  where+      blockCtxs :: Map.Map CmmTickScope [BlockContext]+      blockCtxs = blockContexts decls++      -- Analyse tick scope structure: Each one is either a top-level+      -- tick scope, or the child of another.+      (topScopes, childScopes)+        = splitEithers $ map (\a -> findP a a) $ Map.keys blockCtxs+      findP tsc GlobalScope = Left tsc -- top scope+      findP tsc scp | scp' `Map.member` blockCtxs = Right (scp', tsc)+                    | otherwise                   = findP tsc scp'+        where -- Note that we only following the left parent of+              -- combined scopes. This loses us ticks, which we will+              -- recover by copying ticks below.+              scp' | SubScope _ scp' <- scp      = scp'+                   | CombinedScope scp' _ <- scp = scp'+                   | otherwise                   = panic "findP impossible"++      scopeMap = foldr (uncurry insertMulti) Map.empty childScopes++      -- This allows us to recover ticks that we lost by flattening+      -- the graph. Basically, if the parent is A but the child is+      -- CBA, we know that there is no BA, because it would have taken+      -- priority - but there might be a B scope, with ticks that+      -- would not be associated with our child anymore. Note however+      -- that there might be other childs (DB), which we have to+      -- filter out.+      --+      -- We expect this to be called rarely, which is why we are not+      -- trying too hard to be efficient here. In many cases we won't+      -- have to construct blockCtxsU in the first place.+      ticksToCopy :: CmmTickScope -> [CmmTickish]+      ticksToCopy (CombinedScope scp s) = go s+        where go s | scp `isTickSubScope` s   = [] -- done+                   | SubScope _ s' <- s       = ticks ++ go s'+                   | CombinedScope s1 s2 <- s = ticks ++ go s1 ++ go s2+                   | otherwise                = panic "ticksToCopy impossible"+                where ticks = bCtxsTicks $ fromMaybe [] $ Map.lookup s blockCtxs+      ticksToCopy _ = []+      bCtxsTicks = concatMap (blockTicks . fst)++      -- Finding the "best" source tick is somewhat arbitrary -- we+      -- select the first source span, while preferring source ticks+      -- from the same source file.  Furthermore, dumps take priority+      -- (if we generated one, we probably want debug information to+      -- refer to it).+      bestSrcTick = minimumBy (comparing rangeRating)+      rangeRating (SourceNote span _)+        | srcSpanFile span == thisFile = 1+        | otherwise                    = 2 :: Int+      rangeRating note                 = pprPanic "rangeRating" (ppr note)+      thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc++      -- Returns block tree for this scope as well as all nested+      -- scopes. Note that if there are multiple blocks in the (exact)+      -- same scope we elect one as the "branch" node and add the rest+      -- as children.+      blocksForScope :: Maybe CmmTickish -> CmmTickScope -> DebugBlock+      blocksForScope cstick scope = mkBlock True (head bctxs)+        where bctxs = fromJust $ Map.lookup scope blockCtxs+              nested = fromMaybe [] $ Map.lookup scope scopeMap+              childs = map (mkBlock False) (tail bctxs) +++                       map (blocksForScope stick) nested++              mkBlock :: Bool -> BlockContext -> DebugBlock+              mkBlock top (block, prc)+                = DebugBlock { dblProcedure    = g_entry graph+                             , dblLabel        = label+                             , dblCLabel       = case info of+                                 Just (Statics infoLbl _)   -> infoLbl+                                 Nothing+                                   | g_entry graph == label -> entryLbl+                                   | otherwise              -> blockLbl label+                             , dblHasInfoTbl   = isJust info+                             , dblParent       = Nothing+                             , dblTicks        = ticks+                             , dblPosition     = Nothing -- see cmmDebugLink+                             , dblSourceTick   = stick+                             , dblBlocks       = blocks+                             , dblUnwind       = []+                             }+                where (CmmProc infos entryLbl _ graph) = prc+                      label = entryLabel block+                      info = mapLookup label infos+                      blocks | top       = seqList childs childs+                             | otherwise = []++              -- A source tick scopes over all nested blocks. However+              -- their source ticks might take priority.+              isSourceTick SourceNote {} = True+              isSourceTick _             = False+              -- Collect ticks from all blocks inside the tick scope.+              -- We attempt to filter out duplicates while we're at it.+              ticks = nubBy (flip tickishContains) $+                      bCtxsTicks bctxs ++ ticksToCopy scope+              stick = case filter isSourceTick ticks of+                []     -> cstick+                sticks -> Just $! bestSrcTick (sticks ++ maybeToList cstick)++-- | Build a map of blocks sorted by their tick scopes+--+-- This involves a pre-order traversal, as we want blocks in rough+-- control flow order (so ticks have a chance to be sorted in the+-- right order).+blockContexts :: RawCmmGroup -> Map.Map CmmTickScope [BlockContext]+blockContexts decls = Map.map reverse $ foldr walkProc Map.empty decls+  where walkProc :: RawCmmDecl+                 -> Map.Map CmmTickScope [BlockContext]+                 -> Map.Map CmmTickScope [BlockContext]+        walkProc CmmData{}                 m = m+        walkProc prc@(CmmProc _ _ _ graph) m+          | mapNull blocks = m+          | otherwise      = snd $ walkBlock prc entry (emptyLbls, m)+          where blocks = toBlockMap graph+                entry  = [mapFind (g_entry graph) blocks]+                emptyLbls = setEmpty :: LabelSet++        walkBlock :: RawCmmDecl -> [Block CmmNode C C]+                  -> (LabelSet, Map.Map CmmTickScope [BlockContext])+                  -> (LabelSet, Map.Map CmmTickScope [BlockContext])+        walkBlock _   []             c            = c+        walkBlock prc (block:blocks) (visited, m)+          | lbl `setMember` visited+          = walkBlock prc blocks (visited, m)+          | otherwise+          = walkBlock prc blocks $+            walkBlock prc succs+              (lbl `setInsert` visited,+               insertMulti scope (block, prc) m)+          where CmmEntry lbl scope = firstNode block+                (CmmProc _ _ _ graph) = prc+                succs = map (flip mapFind (toBlockMap graph))+                            (successors (lastNode block))+        mapFind = mapFindWithDefault (error "contextTree: block not found!")++insertMulti :: Ord k => k -> a -> Map.Map k [a] -> Map.Map k [a]+insertMulti k v = Map.insertWith (const (v:)) k [v]++cmmDebugLabels :: (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label]+cmmDebugLabels isMeta nats = seqList lbls lbls+  where -- Find order in which procedures will be generated by the+        -- back-end (that actually matters for DWARF generation).+        --+        -- Note that we might encounter blocks that are missing or only+        -- consist of meta instructions -- we will declare them missing,+        -- which will skip debug data generation without messing up the+        -- block hierarchy.+        lbls = map blockId $ filter (not . allMeta) $ concatMap getBlocks nats+        getBlocks (CmmProc _ _ _ (ListGraph bs)) = bs+        getBlocks _other                         = []+        allMeta (BasicBlock _ instrs) = all isMeta instrs++-- | Sets position and unwind table fields in the debug block tree according to+-- native generated code.+cmmDebugLink :: [Label] -> LabelMap [UnwindPoint]+             -> [DebugBlock] -> [DebugBlock]+cmmDebugLink labels unwindPts blocks = map link blocks+  where blockPos :: LabelMap Int+        blockPos = mapFromList $ flip zip [0..] labels+        link block = block { dblPosition = mapLookup (dblLabel block) blockPos+                           , dblBlocks   = map link (dblBlocks block)+                           , dblUnwind   = fromMaybe mempty+                                         $ mapLookup (dblLabel block) unwindPts+                           }++-- | Converts debug blocks into a label map for easier lookups+debugToMap :: [DebugBlock] -> LabelMap DebugBlock+debugToMap = mapUnions . map go+   where go b = mapInsert (dblLabel b) b $ mapUnions $ map go (dblBlocks b)++{-+Note [What is this unwinding business?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Unwinding tables are a variety of debugging information used by debugging tools+to reconstruct the execution history of a program at runtime. These tables+consist of sets of "instructions", one set for every instruction in the program,+which describe how to reconstruct the state of the machine at the point where+the current procedure was called. For instance, consider the following annotated+pseudo-code,++  a_fun:+    add rsp, 8            -- unwind: rsp = rsp - 8+    mov rax, 1            -- unwind: rax = unknown+    call another_block+    sub rsp, 8            -- unwind: rsp = rsp++We see that attached to each instruction there is an "unwind" annotation, which+provides a relationship between each updated register and its value at the+time of entry to a_fun. This is the sort of information that allows gdb to give+you a stack backtrace given the execution state of your program. This+unwinding information is captured in various ways by various debug information+formats; in the case of DWARF (the only format supported by GHC) it is known as+Call Frame Information (CFI) and can be found in the .debug.frames section of+your object files.++Currently we only bother to produce unwinding information for registers which+are necessary to reconstruct flow-of-execution. On x86_64 this includes $rbp+(which is the STG stack pointer) and $rsp (the C stack pointer).++Let's consider how GHC would annotate a C-- program with unwinding information+with a typical C-- procedure as would come from the STG-to-Cmm code generator,++  entry()+     { c2fe:+           v :: P64 = R2;+           if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg;+       c2ff:+           R2 = v :: P64;+           R1 = test_closure;+           call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8;+       c2fg:+           I64[Sp - 8] = c2dD;+           R1 = v :: P64;+           Sp = Sp - 8;          // Sp updated here+           if (R1 & 7 != 0) goto c2dD; else goto c2dE;+       c2dE:+           call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8;+       c2dD:+           w :: P64 = R1;+           Hp = Hp + 48;+           if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi;+       ...+  },++Let's consider how this procedure will be decorated with unwind information+(largely by CmmLayoutStack). Naturally, when we enter the procedure `entry` the+value of Sp is no different from what it was at its call site. Therefore we will+add an `unwind` statement saying this at the beginning of its unwind-annotated+code,++  entry()+     { c2fe:+           unwind Sp = Just Sp + 0;+           v :: P64 = R2;+           if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg;++After c2fe we we may pass to either c2ff or c2fg; let's first consider the+former. In this case there is nothing in particular that we need to do other+than reiterate what we already know about Sp,++       c2ff:+           unwind Sp = Just Sp + 0;+           R2 = v :: P64;+           R1 = test_closure;+           call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8;++In contrast, c2fg updates Sp midway through its body. To ensure that unwinding+can happen correctly after this point we must include an unwind statement there,+in addition to the usual beginning-of-block statement,++       c2fg:+           unwind Sp = Just Sp + 0;+           I64[Sp - 8] = c2dD;+           R1 = v :: P64;+           unwind Sp = Just Sp + 8;+           Sp = Sp - 8;+           if (R1 & 7 != 0) goto c2dD; else goto c2dE;++The remaining blocks are simple,++       c2dE:+           unwind Sp = Just Sp + 8;+           call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8;+       c2dD:+           unwind Sp = Just Sp + 8;+           w :: P64 = R1;+           Hp = Hp + 48;+           if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi;+       ...+  },+++The flow of unwinding information through the compiler is a bit convoluted:++ * C-- begins life in StgCmm without any unwind information. This is because we+   haven't actually done any register assignment or stack layout yet, so there+   is no need for unwind information.++ * CmmLayoutStack figures out how to layout each procedure's stack, and produces+   appropriate unwinding nodes for each adjustment of the STG Sp register.++ * The unwind nodes are carried through the sinking pass. Currently this is+   guaranteed not to invalidate unwind information since it won't touch stores+   to Sp, but this will need revisiting if CmmSink gets smarter in the future.++ * Eventually we make it to the native code generator backend which can then+   preserve the unwind nodes in its machine-specific instructions. In so doing+   the backend can also modify or add unwinding information; this is necessary,+   for instance, in the case of x86-64, where adjustment of $rsp may be+   necessary during calls to native foreign code due to the native calling+   convention.++ * The NCG then retrieves the final unwinding table for each block from the+   backend with extractUnwindPoints.++ * This unwind information is converted to DebugBlocks by Debug.cmmDebugGen++ * These DebugBlcosk are then converted to, e.g., DWARF unwinding tables+   (by the Dwarf module) and emitted in the final object.++See also: Note [Unwinding information in the NCG] in AsmCodeGen.+-}++-- | A label associated with an 'UnwindTable'+data UnwindPoint = UnwindPoint !CLabel !UnwindTable++instance Outputable UnwindPoint where+  ppr (UnwindPoint lbl uws) =+      braces $ ppr lbl<>colon+      <+> hsep (punctuate comma $ map pprUw $ Map.toList uws)+    where+      pprUw (g, expr) = ppr g <> char '=' <> ppr expr++-- | Maps registers to expressions that yield their "old" values+-- further up the stack. Most interesting for the stack pointer @Sp@,+-- but might be useful to document saved registers, too. Note that a+-- register's value will be 'Nothing' when the register's previous+-- value cannot be reconstructed.+type UnwindTable = Map.Map GlobalReg (Maybe UnwindExpr)++-- | Expressions, used for unwind information+data UnwindExpr = UwConst !Int                  -- ^ literal value+                | UwReg !GlobalReg !Int         -- ^ register plus offset+                | UwDeref UnwindExpr            -- ^ pointer dereferencing+                | UwLabel CLabel+                | UwPlus UnwindExpr UnwindExpr+                | UwMinus UnwindExpr UnwindExpr+                | UwTimes UnwindExpr UnwindExpr+                deriving (Eq)++instance Outputable UnwindExpr where+  pprPrec _ (UwConst i)     = ppr i+  pprPrec _ (UwReg g 0)     = ppr g+  pprPrec p (UwReg g x)     = pprPrec p (UwPlus (UwReg g 0) (UwConst x))+  pprPrec _ (UwDeref e)     = char '*' <> pprPrec 3 e+  pprPrec _ (UwLabel l)     = pprPrec 3 l+  pprPrec p (UwPlus e0 e1)  | p <= 0+                            = pprPrec 0 e0 <> char '+' <> pprPrec 0 e1+  pprPrec p (UwMinus e0 e1) | p <= 0+                            = pprPrec 1 e0 <> char '-' <> pprPrec 1 e1+  pprPrec p (UwTimes e0 e1) | p <= 1+                            = pprPrec 2 e0 <> char '*' <> pprPrec 2 e1+  pprPrec _ other           = parens (pprPrec 0 other)++-- | Conversion of Cmm expressions to unwind expressions. We check for+-- unsupported operator usages and simplify the expression as far as+-- possible.+toUnwindExpr :: CmmExpr -> UnwindExpr+toUnwindExpr (CmmLit (CmmInt i _))       = UwConst (fromIntegral i)+toUnwindExpr (CmmLit (CmmLabel l))       = UwLabel l+toUnwindExpr (CmmRegOff (CmmGlobal g) i) = UwReg g i+toUnwindExpr (CmmReg (CmmGlobal g))      = UwReg g 0+toUnwindExpr (CmmLoad e _)               = UwDeref (toUnwindExpr e)+toUnwindExpr e@(CmmMachOp op [e1, e2])   =+  case (op, toUnwindExpr e1, toUnwindExpr e2) of+    (MO_Add{}, UwReg r x, UwConst y) -> UwReg r (x + y)+    (MO_Sub{}, UwReg r x, UwConst y) -> UwReg r (x - y)+    (MO_Add{}, UwConst x, UwReg r y) -> UwReg r (x + y)+    (MO_Add{}, UwConst x, UwConst y) -> UwConst (x + y)+    (MO_Sub{}, UwConst x, UwConst y) -> UwConst (x - y)+    (MO_Mul{}, UwConst x, UwConst y) -> UwConst (x * y)+    (MO_Add{}, u1,        u2       ) -> UwPlus u1 u2+    (MO_Sub{}, u1,        u2       ) -> UwMinus u1 u2+    (MO_Mul{}, u1,        u2       ) -> UwTimes u1 u2+    _otherwise -> pprPanic "Unsupported operator in unwind expression!"+                           (pprExpr e)+toUnwindExpr e+  = pprPanic "Unsupported unwind expression!" (ppr e)
+ cmm/Hoopl.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Hoopl (+    module Compiler.Hoopl,+    module Hoopl.Dataflow,+  ) where++import Compiler.Hoopl hiding+  ( (<*>), mkLabel, mkBranch, mkMiddle, mkLast, -- clashes with our MkGraph+    DataflowLattice, OldFact, NewFact, JoinFun,+    fact_bot, fact_join, joinOutFacts, mkFactBase,+    Unique,+    FwdTransfer(..), FwdRewrite(..), FwdPass(..),+    BwdTransfer(..), BwdRewrite(..), BwdPass(..),+    mkFactBase, Fact,+    mkBRewrite3, mkBTransfer3,+    mkFRewrite3, mkFTransfer3,++  )++import Hoopl.Dataflow+import Outputable++instance Outputable LabelSet where+  ppr = ppr . setElems++instance Outputable a => Outputable (LabelMap a) where+  ppr = ppr . mapToList
+ cmm/Hoopl/Dataflow.hs view
@@ -0,0 +1,323 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fprof-auto-top #-}++--+-- Copyright (c) 2010, João Dias, Simon Marlow, Simon Peyton Jones,+-- and Norman Ramsey+--+-- Modifications copyright (c) The University of Glasgow 2012+--+-- This module is a specialised and optimised version of+-- Compiler.Hoopl.Dataflow in the hoopl package.  In particular it is+-- specialised to the UniqSM monad.+--++module Hoopl.Dataflow+  ( C, O, Block+  , lastNode, entryLabel+  , foldNodesBwdOO+  , DataflowLattice(..), OldFact(..), NewFact(..), JoinedFact(..), TransferFun+  , Fact, FactBase+  , getFact, mkFactBase+  , analyzeCmmFwd, analyzeCmmBwd+  , changedIf+  , joinOutFacts+  )+where++import Cmm++import Data.Array+import Data.List+import Data.Maybe++-- Hide definitions from Hoopl's Dataflow module.+import Compiler.Hoopl hiding ( DataflowLattice, OldFact, NewFact, JoinFun+                             , fact_bot, fact_join, joinOutFacts, mkFactBase+                             )++newtype OldFact a = OldFact a++newtype NewFact a = NewFact a++-- | The result of joining OldFact and NewFact.+data JoinedFact a+    = Changed !a     -- ^ Result is different than OldFact.+    | NotChanged !a  -- ^ Result is the same as OldFact.++getJoined :: JoinedFact a -> a+getJoined (Changed a) = a+getJoined (NotChanged a) = a++changedIf :: Bool -> a -> JoinedFact a+changedIf True = Changed+changedIf False = NotChanged++type JoinFun a = OldFact a -> NewFact a -> JoinedFact a++data DataflowLattice a = DataflowLattice+    { fact_bot :: a+    , fact_join :: JoinFun a+    }++data Direction = Fwd | Bwd++type TransferFun f = CmmBlock -> FactBase f -> FactBase f++analyzeCmmBwd, analyzeCmmFwd+    :: DataflowLattice f+    -> TransferFun f+    -> CmmGraph+    -> FactBase f+    -> FactBase f+analyzeCmmBwd = analyzeCmm Bwd+analyzeCmmFwd = analyzeCmm Fwd++analyzeCmm+    :: Direction+    -> DataflowLattice f+    -> TransferFun f+    -> CmmGraph+    -> FactBase f+    -> FactBase f+analyzeCmm dir lattice transfer cmmGraph initFact =+    let entry = g_entry cmmGraph+        hooplGraph = g_graph cmmGraph+        blockMap =+            case hooplGraph of+                GMany NothingO bm NothingO -> bm+        entries = if mapNull initFact then [entry] else mapKeys initFact+    in fixpointAnalysis dir lattice transfer entries blockMap initFact++-- Fixpoint algorithm.+fixpointAnalysis+    :: forall f.+       Direction+    -> DataflowLattice f+    -> TransferFun f+    -> [Label]+    -> LabelMap CmmBlock+    -> FactBase f+    -> FactBase f+fixpointAnalysis direction lattice do_block entries blockmap = loop start+  where+    -- Sorting the blocks helps to minimize the number of times we need to+    -- process blocks. For instance, for forward analysis we want to look at+    -- blocks in reverse postorder. Also, see comments for sortBlocks.+    blocks     = sortBlocks direction entries blockmap+    num_blocks = length blocks+    block_arr  = {-# SCC "block_arr" #-} listArray (0, num_blocks - 1) blocks+    start      = {-# SCC "start" #-} [0 .. num_blocks - 1]+    dep_blocks = {-# SCC "dep_blocks" #-} mkDepBlocks direction blocks+    join       = fact_join lattice++    loop+        :: IntHeap     -- ^ Worklist, i.e., blocks to process+        -> FactBase f  -- ^ Current result (increases monotonically)+        -> FactBase f+    loop []              !fbase1 = fbase1+    loop (index : todo1) !fbase1 =+        let block = block_arr ! index+            out_facts = {-# SCC "do_block" #-} do_block block fbase1+            -- For each of the outgoing edges, we join it with the current+            -- information in fbase1 and (if something changed) we update it+            -- and add the affected blocks to the worklist.+            (todo2, fbase2) = {-# SCC "mapFoldWithKey" #-}+                mapFoldWithKey+                    (updateFact join dep_blocks) (todo1, fbase1) out_facts+        in loop todo2 fbase2++++{-+Note [Unreachable blocks]+~~~~~~~~~~~~~~~~~~~~~~~~~+A block that is not in the domain of tfb_fbase is "currently unreachable".+A currently-unreachable block is not even analyzed.  Reason: consider+constant prop and this graph, with entry point L1:+  L1: x:=3; goto L4+  L2: x:=4; goto L4+  L4: if x>3 goto L2 else goto L5+Here L2 is actually unreachable, but if we process it with bottom input fact,+we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4.++* If a currently-unreachable block is not analyzed, then its rewritten+  graph will not be accumulated in tfb_rg.  And that is good:+  unreachable blocks simply do not appear in the output.++* Note that clients must be careful to provide a fact (even if bottom)+  for each entry point. Otherwise useful blocks may be garbage collected.++* Note that updateFact must set the change-flag if a label goes from+  not-in-fbase to in-fbase, even if its fact is bottom.  In effect the+  real fact lattice is+       UNR+       bottom+       the points above bottom++* Even if the fact is going from UNR to bottom, we still call the+  client's fact_join function because it might give the client+  some useful debugging information.++* All of this only applies for *forward* ixpoints.  For the backward+  case we must treat every block as reachable; it might finish with a+  'return', and therefore have no successors, for example.+-}+++-----------------------------------------------------------------------------+--  Pieces that are shared by fixpoint and fixpoint_anal+-----------------------------------------------------------------------------++-- | Sort the blocks into the right order for analysis. This means reverse+-- postorder for a forward analysis. For the backward one, we simply reverse+-- that (see Note [Backward vs forward analysis]).+--+-- Note: We're using Hoopl's confusingly named `postorder_dfs_from` but AFAICS+-- it returns the *reverse* postorder of the blocks (it visits blocks in the+-- postorder and uses (:) to collect them, which gives the reverse of the+-- visitation order).+sortBlocks+    :: NonLocal n+    => Direction -> [Label] -> LabelMap (Block n C C) -> [Block n C C]+sortBlocks direction entries blockmap =+    case direction of+        Fwd -> fwd+        Bwd -> reverse fwd+  where+    fwd = postorder_dfs_from blockmap entries++-- Note [Backward vs forward analysis]+--+-- The forward and backward cases are not dual.  In the forward case, the entry+-- points are known, and one simply traverses the body blocks from those points.+-- In the backward case, something is known about the exit points, but a+-- backward analysis must also include reachable blocks that don't reach the+-- exit, as in a procedure that loops forever and has side effects.)+-- For instance, let E be the entry and X the exit blocks (arrows indicate+-- control flow)+--   E -> X+--   E -> B+--   B -> C+--   C -> B+-- We do need to include B and C even though they're unreachable in the+-- *reverse* graph (that we could use for backward analysis):+--   E <- X+--   E <- B+--   B <- C+--   C <- B+-- So when sorting the blocks for the backward analysis, we simply take the+-- reverse of what is used for the forward one.+++-- | construct a mapping from L -> block indices.  If the fact for L+-- changes, re-analyse the given blocks.+mkDepBlocks :: NonLocal n => Direction -> [Block n C C] -> LabelMap [Int]+mkDepBlocks Fwd blocks = go blocks 0 mapEmpty+  where go []     !_  m = m+        go (b:bs) !n m = go bs (n+1) $! mapInsert (entryLabel b) [n] m+mkDepBlocks Bwd blocks = go blocks 0 mapEmpty+  where go []     !_ m = m+        go (b:bs) !n m = go bs (n+1) $! go' (successors b) m+            where go' [] m = m+                  go' (l:ls) m = go' ls (mapInsertWith (++) l [n] m)+++-- | After some new facts have been generated by analysing a block, we+-- fold this function over them to generate (a) a list of block+-- indices to (re-)analyse, and (b) the new FactBase.+--+updateFact :: JoinFun f -> LabelMap [Int]+           -> Label -> f       -- out fact+           -> (IntHeap, FactBase f)+           -> (IntHeap, FactBase f)++updateFact fact_join dep_blocks lbl new_fact (todo, fbase)+  = case lookupFact lbl fbase of+      Nothing       -> let !z = mapInsert lbl new_fact fbase in (changed, z)+                           -- Note [no old fact]+      Just old_fact ->+        case fact_join (OldFact old_fact) (NewFact new_fact) of+          (NotChanged _) -> (todo, fbase)+          (Changed f) -> let !z = mapInsert lbl f fbase in (changed, z)+  where+     changed = foldr insertIntHeap todo $+                 mapFindWithDefault [] lbl dep_blocks++{-+Note [no old fact]++We know that the new_fact is >= _|_, so we don't need to join.  However,+if the new fact is also _|_, and we have already analysed its block,+we don't need to record a change.  So there's a tradeoff here.  It turns+out that always recording a change is faster.+-}++----------------------------------------------------------------+--       Utilities+----------------------------------------------------------------++-- Fact lookup: the fact `orelse` bottom+getFact  :: DataflowLattice f -> Label -> FactBase f -> f+getFact lat l fb = case lookupFact l fb of Just  f -> f+                                           Nothing -> fact_bot lat++-- | Returns the result of joining the facts from all the successors of the+-- provided node or block.+joinOutFacts :: (NonLocal n) => DataflowLattice f -> n e C -> FactBase f -> f+joinOutFacts lattice nonLocal fact_base = foldl' join (fact_bot lattice) facts+  where+    join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new)+    facts =+        [ fromJust fact+        | s <- successors nonLocal+        , let fact = lookupFact s fact_base+        , isJust fact+        ]++-- | Returns the joined facts for each label.+mkFactBase :: DataflowLattice f -> [(Label, f)] -> FactBase f+mkFactBase lattice = foldl' add mapEmpty+  where+    join = fact_join lattice++    add result (l, f1) =+        let !newFact =+                case mapLookup l result of+                    Nothing -> f1+                    Just f2 -> getJoined $ join (OldFact f1) (NewFact f2)+        in mapInsert l newFact result++-- | Folds backward over all nodes of an open-open block.+-- Strict in the accumulator.+foldNodesBwdOO :: (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f+foldNodesBwdOO funOO = go+  where+    go (BCat b1 b2) f = go b1 $! go b2 f+    go (BSnoc h n) f = go h $! funOO n f+    go (BCons n t) f = funOO n $! go t f+    go (BMiddle n) f = funOO n f+    go BNil f = f+{-# INLINABLE foldNodesBwdOO #-}++-- -----------------------------------------------------------------------------+-- a Heap of Int++-- We should really use a proper Heap here, but my attempts to make+-- one have not succeeded in beating the simple ordered list.  Another+-- alternative is IntSet (using deleteFindMin), but that was also+-- slower than the ordered list in my experiments --SDM 25/1/2012++type IntHeap = [Int] -- ordered++insertIntHeap :: Int -> [Int] -> [Int]+insertIntHeap x [] = [x]+insertIntHeap x (y:ys)+  | x < y     = x : y : ys+  | x == y    = x : ys+  | otherwise = y : insertIntHeap x ys
+ cmm/MkGraph.hs view
@@ -0,0 +1,415 @@+{-# LANGUAGE BangPatterns, CPP, GADTs #-}++module MkGraph+  ( CmmAGraph, CmmAGraphScoped, CgStmt(..)+  , (<*>), catAGraphs+  , mkLabel, mkMiddle, mkLast, outOfLine+  , lgraphOfAGraph, labelAGraph++  , stackStubExpr+  , mkNop, mkAssign, mkStore+  , mkUnsafeCall, mkFinalCall, mkCallReturnsTo+  , mkJumpReturnsTo+  , mkJump, mkJumpExtra+  , mkRawJump+  , mkCbranch, mkSwitch+  , mkReturn, mkComment, mkCallEntry, mkBranch+  , mkUnwind+  , copyInOflow, copyOutOflow+  , noExtraStack+  , toCall, Transfer(..)+  )+where++import BlockId+import Cmm+import CmmCallConv+import CmmSwitch (SwitchTargets)++import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..))+import DynFlags+import FastString+import ForeignCall+import OrdList+import SMRep (ByteOff)+import UniqSupply++import Control.Monad+import Data.List+import Data.Maybe+import Prelude (($),Int,Bool,Eq(..)) -- avoid importing (<*>)++#include "HsVersions.h"+++-----------------------------------------------------------------------------+-- Building Graphs+++-- | CmmAGraph is a chunk of code consisting of:+--+--   * ordinary statements (assignments, stores etc.)+--   * jumps+--   * labels+--   * out-of-line labelled blocks+--+-- The semantics is that control falls through labels and out-of-line+-- blocks.  Everything after a jump up to the next label is by+-- definition unreachable code, and will be discarded.+--+-- Two CmmAGraphs can be stuck together with <*>, with the meaning that+-- control flows from the first to the second.+--+-- A 'CmmAGraph' can be turned into a 'CmmGraph' (closed at both ends)+-- by providing a label for the entry point and a tick scope; see+-- 'labelAGraph'.+type CmmAGraph = OrdList CgStmt+-- | Unlabeled graph with tick scope+type CmmAGraphScoped = (CmmAGraph, CmmTickScope)++data CgStmt+  = CgLabel BlockId CmmTickScope+  | CgStmt  (CmmNode O O)+  | CgLast  (CmmNode O C)+  | CgFork  BlockId CmmAGraph CmmTickScope++flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph+flattenCmmAGraph id (stmts_t, tscope) =+    CmmGraph { g_entry = id,+               g_graph = GMany NothingO body NothingO }+  where+  body = foldr addBlock emptyBody $ flatten id stmts_t tscope []++  --+  -- flatten: given an entry label and a CmmAGraph, make a list of blocks.+  --+  -- NB. avoid the quadratic-append trap by passing in the tail of the+  -- list.  This is important for Very Long Functions (e.g. in T783).+  --+  flatten :: Label -> CmmAGraph -> CmmTickScope -> [Block CmmNode C C]+          -> [Block CmmNode C C]+  flatten id g tscope blocks+      = flatten1 (fromOL g) block' blocks+      where !block' = blockJoinHead (CmmEntry id tscope) emptyBlock+  --+  -- flatten0: we are outside a block at this point: any code before+  -- the first label is unreachable, so just drop it.+  --+  flatten0 :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]+  flatten0 [] blocks = blocks++  flatten0 (CgLabel id tscope : stmts) blocks+    = flatten1 stmts block blocks+    where !block = blockJoinHead (CmmEntry id tscope) emptyBlock++  flatten0 (CgFork fork_id stmts_t tscope : rest) blocks+    = flatten fork_id stmts_t tscope $ flatten0 rest blocks++  flatten0 (CgLast _ : stmts) blocks = flatten0 stmts blocks+  flatten0 (CgStmt _ : stmts) blocks = flatten0 stmts blocks++  --+  -- flatten1: we have a partial block, collect statements until the+  -- next last node to make a block, then call flatten0 to get the rest+  -- of the blocks+  --+  flatten1 :: [CgStmt] -> Block CmmNode C O+           -> [Block CmmNode C C] -> [Block CmmNode C C]++  -- The current block falls through to the end of a function or fork:+  -- this code should not be reachable, but it may be referenced by+  -- other code that is not reachable.  We'll remove it later with+  -- dead-code analysis, but for now we have to keep the graph+  -- well-formed, so we terminate the block with a branch to the+  -- beginning of the current block.+  flatten1 [] block blocks+    = blockJoinTail block (CmmBranch (entryLabel block)) : blocks++  flatten1 (CgLast stmt : stmts) block blocks+    = block' : flatten0 stmts blocks+    where !block' = blockJoinTail block stmt++  flatten1 (CgStmt stmt : stmts) block blocks+    = flatten1 stmts block' blocks+    where !block' = blockSnoc block stmt++  flatten1 (CgFork fork_id stmts_t tscope : rest) block blocks+    = flatten fork_id stmts_t tscope $ flatten1 rest block blocks++  -- a label here means that we should start a new block, and the+  -- current block should fall through to the new block.+  flatten1 (CgLabel id tscp : stmts) block blocks+    = blockJoinTail block (CmmBranch id) :+      flatten1 stmts (blockJoinHead (CmmEntry id tscp) emptyBlock) blocks++++---------- AGraph manipulation++(<*>)          :: CmmAGraph -> CmmAGraph -> CmmAGraph+(<*>)           = appOL++catAGraphs     :: [CmmAGraph] -> CmmAGraph+catAGraphs      = concatOL++-- | created a sequence "goto id; id:" as an AGraph+mkLabel        :: BlockId -> CmmTickScope -> CmmAGraph+mkLabel bid scp = unitOL (CgLabel bid scp)++-- | creates an open AGraph from a given node+mkMiddle        :: CmmNode O O -> CmmAGraph+mkMiddle middle = unitOL (CgStmt middle)++-- | created a closed AGraph from a given node+mkLast         :: CmmNode O C -> CmmAGraph+mkLast last     = unitOL (CgLast last)++-- | A labelled code block; should end in a last node+outOfLine      :: BlockId -> CmmAGraphScoped -> CmmAGraph+outOfLine l (c,s) = unitOL (CgFork l c s)++-- | allocate a fresh label for the entry point+lgraphOfAGraph :: CmmAGraphScoped -> UniqSM CmmGraph+lgraphOfAGraph g = do+  u <- getUniqueM+  return (labelAGraph (mkBlockId u) g)++-- | use the given BlockId as the label of the entry point+labelAGraph    :: BlockId -> CmmAGraphScoped -> CmmGraph+labelAGraph lbl ag = flattenCmmAGraph lbl ag++---------- No-ops+mkNop        :: CmmAGraph+mkNop         = nilOL++mkComment    :: FastString -> CmmAGraph+#ifdef DEBUG+-- SDM: generating all those comments takes time, this saved about 4% for me+mkComment fs  = mkMiddle $ CmmComment fs+#else+mkComment _   = nilOL+#endif++---------- Assignment and store+mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph+mkAssign l (CmmReg r) | l == r  = mkNop+mkAssign l r  = mkMiddle $ CmmAssign l r++mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph+mkStore  l r  = mkMiddle $ CmmStore  l r++---------- Control transfer+mkJump          :: DynFlags -> Convention -> CmmExpr+                -> [CmmExpr]+                -> UpdFrameOffset+                -> CmmAGraph+mkJump dflags conv e actuals updfr_off =+  lastWithArgs dflags Jump Old conv actuals updfr_off $+    toCall e Nothing updfr_off 0++-- | A jump where the caller says what the live GlobalRegs are.  Used+-- for low-level hand-written Cmm.+mkRawJump       :: DynFlags -> CmmExpr -> UpdFrameOffset -> [GlobalReg]+                -> CmmAGraph+mkRawJump dflags e updfr_off vols =+  lastWithArgs dflags Jump Old NativeNodeCall [] updfr_off $+    \arg_space _  -> toCall e Nothing updfr_off 0 arg_space vols+++mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmExpr]+                -> UpdFrameOffset -> [CmmExpr]+                -> CmmAGraph+mkJumpExtra dflags conv e actuals updfr_off extra_stack =+  lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $+    toCall e Nothing updfr_off 0++mkCbranch       :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph+mkCbranch pred ifso ifnot likely =+  mkLast (CmmCondBranch pred ifso ifnot likely)++mkSwitch        :: CmmExpr -> SwitchTargets -> CmmAGraph+mkSwitch e tbl   = mkLast $ CmmSwitch e tbl++mkReturn        :: DynFlags -> CmmExpr -> [CmmExpr] -> UpdFrameOffset+                -> CmmAGraph+mkReturn dflags e actuals updfr_off =+  lastWithArgs dflags Ret  Old NativeReturn actuals updfr_off $+    toCall e Nothing updfr_off 0++mkBranch        :: BlockId -> CmmAGraph+mkBranch bid     = mkLast (CmmBranch bid)++mkFinalCall   :: DynFlags+              -> CmmExpr -> CCallConv -> [CmmExpr] -> UpdFrameOffset+              -> CmmAGraph+mkFinalCall dflags f _ actuals updfr_off =+  lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $+    toCall f Nothing updfr_off 0++mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]+                -> BlockId+                -> ByteOff+                -> UpdFrameOffset+                -> [CmmExpr]+                -> CmmAGraph+mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do+  lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals+     updfr_off extra_stack $+       toCall f (Just ret_lbl) updfr_off ret_off++-- Like mkCallReturnsTo, but does not push the return address (it is assumed to be+-- already on the stack).+mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]+                -> BlockId+                -> ByteOff+                -> UpdFrameOffset+                -> CmmAGraph+mkJumpReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off  = do+  lastWithArgs dflags JumpRet (Young ret_lbl) callConv actuals updfr_off $+       toCall f (Just ret_lbl) updfr_off ret_off++mkUnsafeCall  :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph+mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as++-- | Construct a 'CmmUnwind' node for the given register and unwinding+-- expression.+mkUnwind     :: GlobalReg -> CmmExpr -> CmmAGraph+mkUnwind r e  = mkMiddle $ CmmUnwind [(r, Just e)]++--------------------------------------------------------------------------+++++-- Why are we inserting extra blocks that simply branch to the successors?+-- Because in addition to the branch instruction, @mkBranch@ will insert+-- a necessary adjustment to the stack pointer.+++-- For debugging purposes, we can stub out dead stack slots:+stackStubExpr :: Width -> CmmExpr+stackStubExpr w = CmmLit (CmmInt 0 w)++-- When we copy in parameters, we usually want to put overflow+-- parameters on the stack, but sometimes we want to pass the+-- variables in their spill slots.  Therefore, for copying arguments+-- and results, we provide different functions to pass the arguments+-- in an overflow area and to pass them in spill slots.+copyInOflow  :: DynFlags -> Convention -> Area+             -> [CmmFormal]+             -> [CmmFormal]+             -> (Int, [GlobalReg], CmmAGraph)++copyInOflow dflags conv area formals extra_stk+  = (offset, gregs, catAGraphs $ map mkMiddle nodes)+  where (offset, gregs, nodes) = copyIn dflags conv area formals extra_stk++-- Return the number of bytes used for copying arguments, as well as the+-- instructions to copy the arguments.+copyIn :: DynFlags -> Convention -> Area+       -> [CmmFormal]+       -> [CmmFormal]+       -> (ByteOff, [GlobalReg], [CmmNode O O])+copyIn dflags conv area formals extra_stk+  = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args))+  where+     ci (reg, RegisterParam r) =+          CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r))+     ci (reg, StackParam off) =+          CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty)+          where ty = localRegType reg++     init_offset = widthInBytes (wordWidth dflags) -- infotable++     (stk_off, stk_args) = assignStack dflags init_offset localRegType extra_stk++     (stk_size, args) = assignArgumentsPos dflags stk_off conv+                                           localRegType formals++-- Factoring out the common parts of the copyout functions yielded something+-- more complicated:++data Transfer = Call | JumpRet | Jump | Ret deriving Eq++copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmExpr]+             -> UpdFrameOffset+             -> [CmmExpr] -- extra stack args+             -> (Int, [GlobalReg], CmmAGraph)++-- Generate code to move the actual parameters into the locations+-- required by the calling convention.  This includes a store for the+-- return address.+--+-- The argument layout function ignores the pointer to the info table,+-- so we slot that in here. When copying-out to a young area, we set+-- the info table for return and adjust the offsets of the other+-- parameters.  If this is a call instruction, we adjust the offsets+-- of the other parameters.+copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff+  = (stk_size, regs, graph)+  where+    (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params)++    co (v, RegisterParam r) (rs, ms)+       = (r:rs, mkAssign (CmmGlobal r) v <*> ms)+    co (v, StackParam off)  (rs, ms)+       = (rs, mkStore (CmmStackSlot area off) v <*> ms)++    (setRA, init_offset) =+      case area of+            Young id ->  -- Generate a store instruction for+                         -- the return address if making a call+                  case transfer of+                     Call ->+                       ([(CmmLit (CmmBlock id), StackParam init_offset)],+                       widthInBytes (wordWidth dflags))+                     JumpRet ->+                       ([],+                       widthInBytes (wordWidth dflags))+                     _other ->+                       ([], 0)+            Old -> ([], updfr_off)++    (extra_stack_off, stack_params) =+       assignStack dflags init_offset (cmmExprType dflags) extra_stack_stuff++    args :: [(CmmExpr, ParamLocation)]   -- The argument and where to put it+    (stk_size, args) = assignArgumentsPos dflags extra_stack_off conv+                                          (cmmExprType dflags) actuals++++mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal]+            -> (Int, [GlobalReg], CmmAGraph)+mkCallEntry dflags conv formals extra_stk+  = copyInOflow dflags conv Old formals extra_stk++lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmExpr]+             -> UpdFrameOffset+             -> (ByteOff -> [GlobalReg] -> CmmAGraph)+             -> CmmAGraph+lastWithArgs dflags transfer area conv actuals updfr_off last =+  lastWithArgsAndExtraStack dflags transfer area conv actuals+                            updfr_off noExtraStack last++lastWithArgsAndExtraStack :: DynFlags+             -> Transfer -> Area -> Convention -> [CmmExpr]+             -> UpdFrameOffset -> [CmmExpr]+             -> (ByteOff -> [GlobalReg] -> CmmAGraph)+             -> CmmAGraph+lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off+                          extra_stack last =+  copies <*> last outArgs regs+ where+  (outArgs, regs, copies) = copyOutOflow dflags conv transfer area actuals+                               updfr_off extra_stack+++noExtraStack :: [CmmExpr]+noExtraStack = []++toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff+       -> ByteOff -> [GlobalReg]+       -> CmmAGraph+toCall e cont updfr_off res_space arg_space regs =+  mkLast $ CmmCall e cont regs arg_space res_space updfr_off
+ cmm/PprC.hs view
@@ -0,0 +1,1313 @@+{-# LANGUAGE CPP, GADTs #-}++-----------------------------------------------------------------------------+--+-- Pretty-printing of Cmm as C, suitable for feeding gcc+--+-- (c) The University of Glasgow 2004-2006+--+-- Print Cmm as real C, for -fvia-C+--+-- See wiki:Commentary/Compiler/Backends/PprC+--+-- This is simpler than the old PprAbsC, because Cmm is "macro-expanded"+-- relative to the old AbstractC, and many oddities/decorations have+-- disappeared from the data type.+--+-- This code generator is only supported in unregisterised mode.+--+-----------------------------------------------------------------------------++module PprC (+        writeCs,+        pprStringInCStyle+  ) where++#include "HsVersions.h"++-- Cmm stuff+import BlockId+import CLabel+import ForeignCall+import Cmm hiding (pprBBlock)+import PprCmm ()+import Hoopl+import CmmUtils+import CmmSwitch++-- Utils+import CPrim+import DynFlags+import FastString+import Outputable+import Platform+import UniqSet+import UniqFM+import Unique+import Util++-- The rest+import Control.Monad.ST+import Data.Bits+import Data.Char+import Data.List+import Data.Map (Map)+import Data.Word+import System.IO+import qualified Data.Map as Map+import Control.Monad (liftM, ap)+import qualified Data.Array.Unsafe as U ( castSTUArray )+import Data.Array.ST++-- --------------------------------------------------------------------------+-- Top level++pprCs :: DynFlags -> [RawCmmGroup] -> SDoc+pprCs dflags cmms+ = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms)+ where+   split_marker+     | gopt Opt_SplitObjs dflags = text "__STG_SPLIT_MARKER"+     | otherwise                 = empty++writeCs :: DynFlags -> Handle -> [RawCmmGroup] -> IO ()+writeCs dflags handle cmms+  = printForC dflags handle (pprCs dflags cmms)++-- --------------------------------------------------------------------------+-- Now do some real work+--+-- for fun, we could call cmmToCmm over the tops...+--++pprC :: RawCmmGroup -> SDoc+pprC tops = vcat $ intersperse blankLine $ map pprTop tops++--+-- top level procs+--+pprTop :: RawCmmDecl -> SDoc+pprTop (CmmProc infos clbl _ graph) =++    (case mapLookup (g_entry graph) infos of+       Nothing -> empty+       Just (Statics info_clbl info_dat) -> pprDataExterns info_dat $$+                                            pprWordArray info_clbl info_dat) $$+    (vcat [+           blankLine,+           extern_decls,+           (if (externallyVisibleCLabel clbl)+                    then mkFN_ else mkIF_) (ppr clbl) <+> lbrace,+           nest 8 temp_decls,+           vcat (map pprBBlock blocks),+           rbrace ]+    )+  where+        blocks = toBlockListEntryFirst graph+        (temp_decls, extern_decls) = pprTempAndExternDecls blocks+++-- Chunks of static data.++-- We only handle (a) arrays of word-sized things and (b) strings.++pprTop (CmmData _section (Statics lbl [CmmString str])) =+  hcat [+    pprLocalness lbl, text "char ", ppr lbl,+    text "[] = ", pprStringInCStyle str, semi+  ]++pprTop (CmmData _section (Statics lbl [CmmUninitialised size])) =+  hcat [+    pprLocalness lbl, text "char ", ppr lbl,+    brackets (int size), semi+  ]++pprTop (CmmData _section (Statics lbl lits)) =+  pprDataExterns lits $$+  pprWordArray lbl lits++-- --------------------------------------------------------------------------+-- BasicBlocks are self-contained entities: they always end in a jump.+--+-- Like nativeGen/AsmCodeGen, we could probably reorder blocks to turn+-- as many jumps as possible into fall throughs.+--++pprBBlock :: CmmBlock -> SDoc+pprBBlock block =+  nest 4 (pprBlockId (entryLabel block) <> colon) $$+  nest 8 (vcat (map pprStmt (blockToList nodes)) $$ pprStmt last)+ where+  (_, nodes, last)  = blockSplit block++-- --------------------------------------------------------------------------+-- Info tables. Just arrays of words.+-- See codeGen/ClosureInfo, and nativeGen/PprMach++pprWordArray :: CLabel -> [CmmStatic] -> SDoc+pprWordArray lbl ds+  = sdocWithDynFlags $ \dflags ->+    hcat [ pprLocalness lbl, text "StgWord"+         , space, ppr lbl, text "[]"+         -- See Note [StgWord alignment]+         , pprAlignment (wordWidth dflags)+         , text "= {" ]+    $$ nest 8 (commafy (pprStatics dflags ds))+    $$ text "};"++pprAlignment :: Width -> SDoc+pprAlignment words =+     text "__attribute__((aligned(" <> int (widthInBytes words) <> text ")))"++-- Note [StgWord alignment]+-- C codegen builds static closures as StgWord C arrays (pprWordArray).+-- Their real C type is 'StgClosure'. Macros like UNTAG_CLOSURE assume+-- pointers to 'StgClosure' are aligned at pointer size boundary:+--  4 byte boundary on 32 systems+--  and 8 bytes on 64-bit systems+-- see TAG_MASK and TAG_BITS definition and usage.+--+-- It's a reasonable assumption also known as natural alignment.+-- Although some architectures have different alignment rules.+-- One of known exceptions is m68k (Trac #11395, comment:16) where:+--   __alignof__(StgWord) == 2, sizeof(StgWord) == 4+--+-- Thus we explicitly increase alignment by using+--    __attribute__((aligned(4)))+-- declaration.++--+-- has to be static, if it isn't globally visible+--+pprLocalness :: CLabel -> SDoc+pprLocalness lbl | not $ externallyVisibleCLabel lbl = text "static "+                 | otherwise = empty++-- --------------------------------------------------------------------------+-- Statements.+--++pprStmt :: CmmNode e x -> SDoc++pprStmt stmt =+    sdocWithDynFlags $ \dflags ->+    case stmt of+    CmmEntry{}   -> empty+    CmmComment _ -> empty -- (hang (text "/*") 3 (ftext s)) $$ ptext (sLit "*/")+                          -- XXX if the string contains "*/", we need to fix it+                          -- XXX we probably want to emit these comments when+                          -- some debugging option is on.  They can get quite+                          -- large.++    CmmTick _ -> empty+    CmmUnwind{} -> empty++    CmmAssign dest src -> pprAssign dflags dest src++    CmmStore  dest src+        | typeWidth rep == W64 && wordWidth dflags /= W64+        -> (if isFloatType rep then text "ASSIGN_DBL"+                               else ptext (sLit ("ASSIGN_Word64"))) <>+           parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi++        | otherwise+        -> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ]+        where+          rep = cmmExprType dflags src++    CmmUnsafeForeignCall target@(ForeignTarget fn conv) results args ->+        fnCall+        where+        (res_hints, arg_hints) = foreignTargetHints target+        hresults = zip results res_hints+        hargs    = zip args arg_hints++        ForeignConvention cconv _ _ ret = conv++        cast_fn = parens (cCast (pprCFunType (char '*') cconv hresults hargs) fn)++        -- See wiki:Commentary/Compiler/Backends/PprC#Prototypes+        fnCall =+            case fn of+              CmmLit (CmmLabel lbl)+                | StdCallConv <- cconv ->+                    pprCall (ppr lbl) cconv hresults hargs+                        -- stdcall functions must be declared with+                        -- a function type, otherwise the C compiler+                        -- doesn't add the @n suffix to the label.  We+                        -- can't add the @n suffix ourselves, because+                        -- it isn't valid C.+                | CmmNeverReturns <- ret ->+                    pprCall cast_fn cconv hresults hargs <> semi+                | not (isMathFun lbl) ->+                    pprForeignCall (ppr lbl) cconv hresults hargs+              _ ->+                    pprCall cast_fn cconv hresults hargs <> semi+                        -- for a dynamic call, no declaration is necessary.++    CmmUnsafeForeignCall (PrimTarget MO_Touch) _results _args -> empty+    CmmUnsafeForeignCall (PrimTarget (MO_Prefetch_Data _)) _results _args -> empty++    CmmUnsafeForeignCall target@(PrimTarget op) results args ->+        fn_call+      where+        cconv = CCallConv+        fn = pprCallishMachOp_for_C op++        (res_hints, arg_hints) = foreignTargetHints target+        hresults = zip results res_hints+        hargs    = zip args arg_hints++        fn_call+          -- The mem primops carry an extra alignment arg.+          -- We could maybe emit an alignment directive using this info.+          -- We also need to cast mem primops to prevent conflicts with GCC+          -- builtins (see bug #5967).+          | Just _align <- machOpMemcpyishAlign op+          = (text ";EFF_(" <> fn <> char ')' <> semi) $$+            pprForeignCall fn cconv hresults hargs+          | otherwise+          = pprCall fn cconv hresults hargs++    CmmBranch ident          -> pprBranch ident+    CmmCondBranch expr yes no _ -> pprCondBranch expr yes no+    CmmCall { cml_target = expr } -> mkJMP_ (pprExpr expr) <> semi+    CmmSwitch arg ids        -> sdocWithDynFlags $ \dflags ->+                                pprSwitch dflags arg ids++    _other -> pprPanic "PprC.pprStmt" (ppr stmt)++type Hinted a = (a, ForeignHint)++pprForeignCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual]+               -> SDoc+pprForeignCall fn cconv results args = fn_call+  where+    fn_call = braces (+                 pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi+              $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi+              $$ pprCall (text "ghcFunPtr") cconv results args <> semi+             )+    cast_fn = parens (parens (pprCFunType (char '*') cconv results args) <> fn)++pprCFunType :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc+pprCFunType ppr_fn cconv ress args+  = sdocWithDynFlags $ \dflags ->+    let res_type [] = text "void"+        res_type [(one, hint)] = machRepHintCType (localRegType one) hint+        res_type _ = panic "pprCFunType: only void or 1 return value supported"++        arg_type (expr, hint) = machRepHintCType (cmmExprType dflags expr) hint+    in res_type ress <+>+       parens (ccallConvAttribute cconv <> ppr_fn) <>+       parens (commafy (map arg_type args))++-- ---------------------------------------------------------------------+-- unconditional branches+pprBranch :: BlockId -> SDoc+pprBranch ident = text "goto" <+> pprBlockId ident <> semi+++-- ---------------------------------------------------------------------+-- conditional branches to local labels+pprCondBranch :: CmmExpr -> BlockId -> BlockId -> SDoc+pprCondBranch expr yes no+        = hsep [ text "if" , parens(pprExpr expr) ,+                        text "goto", pprBlockId yes <> semi,+                        text "else goto", pprBlockId no <> semi ]++-- ---------------------------------------------------------------------+-- a local table branch+--+-- we find the fall-through cases+--+pprSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> SDoc+pprSwitch dflags e ids+  = (hang (text "switch" <+> parens ( pprExpr e ) <+> lbrace)+                4 (vcat ( map caseify pairs ) $$ def)) $$ rbrace+  where+    (pairs, mbdef) = switchTargetsFallThrough ids++    -- fall through case+    caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix+        where+        do_fallthrough ix =+                 hsep [ text "case" , pprHexVal ix (wordWidth dflags) <> colon ,+                        text "/* fall through */" ]++        final_branch ix =+                hsep [ text "case" , pprHexVal ix (wordWidth dflags) <> colon ,+                       text "goto" , (pprBlockId ident) <> semi ]++    caseify (_     , _    ) = panic "pprSwitch: switch with no cases!"++    def | Just l <- mbdef = text "default: goto" <+> pprBlockId l <> semi+        | otherwise       = empty++-- ---------------------------------------------------------------------+-- Expressions.+--++-- C Types: the invariant is that the C expression generated by+--+--      pprExpr e+--+-- has a type in C which is also given by+--+--      machRepCType (cmmExprType e)+--+-- (similar invariants apply to the rest of the pretty printer).++pprExpr :: CmmExpr -> SDoc+pprExpr e = case e of+    CmmLit lit -> pprLit lit+++    CmmLoad e ty -> sdocWithDynFlags $ \dflags -> pprLoad dflags e ty+    CmmReg reg      -> pprCastReg reg+    CmmRegOff reg 0 -> pprCastReg reg++    CmmRegOff reg i+        | i < 0 && negate_ok -> pprRegOff (char '-') (-i)+        | otherwise          -> pprRegOff (char '+') i+      where+        pprRegOff op i' = pprCastReg reg <> op <> int i'+        negate_ok = negate (fromIntegral i :: Integer) <+                    fromIntegral (maxBound::Int)+                     -- overflow is undefined; see #7620++    CmmMachOp mop args -> pprMachOpApp mop args++    CmmStackSlot _ _   -> panic "pprExpr: CmmStackSlot not supported!"+++pprLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc+pprLoad dflags e ty+  | width == W64, wordWidth dflags /= W64+  = (if isFloatType ty then text "PK_DBL"+                       else text "PK_Word64")+    <> parens (mkP_ <> pprExpr1 e)++  | otherwise+  = case e of+        CmmReg r | isPtrReg r && width == wordWidth dflags && not (isFloatType ty)+                 -> char '*' <> pprAsPtrReg r++        CmmRegOff r 0 | isPtrReg r && width == wordWidth dflags && not (isFloatType ty)+                      -> char '*' <> pprAsPtrReg r++        CmmRegOff r off | isPtrReg r && width == wordWidth dflags+                        , off `rem` wORD_SIZE dflags == 0 && not (isFloatType ty)+        -- ToDo: check that the offset is a word multiple?+        --       (For tagging to work, I had to avoid unaligned loads. --ARY)+                        -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift dflags))++        _other -> cLoad e ty+  where+    width = typeWidth ty++pprExpr1 :: CmmExpr -> SDoc+pprExpr1 (CmmLit lit)     = pprLit1 lit+pprExpr1 e@(CmmReg _reg)  = pprExpr e+pprExpr1 other            = parens (pprExpr other)++-- --------------------------------------------------------------------------+-- MachOp applications++pprMachOpApp :: MachOp -> [CmmExpr] -> SDoc++pprMachOpApp op args+  | isMulMayOfloOp op+  = text "mulIntMayOflo" <> parens (commafy (map pprExpr args))+  where isMulMayOfloOp (MO_U_MulMayOflo _) = True+        isMulMayOfloOp (MO_S_MulMayOflo _) = True+        isMulMayOfloOp _ = False++pprMachOpApp mop args+  | Just ty <- machOpNeedsCast mop+  = ty <> parens (pprMachOpApp' mop args)+  | otherwise+  = pprMachOpApp' mop args++-- Comparisons in C have type 'int', but we want type W_ (this is what+-- resultRepOfMachOp says).  The other C operations inherit their type+-- from their operands, so no casting is required.+machOpNeedsCast :: MachOp -> Maybe SDoc+machOpNeedsCast mop+  | isComparisonMachOp mop = Just mkW_+  | otherwise              = Nothing++pprMachOpApp' :: MachOp -> [CmmExpr] -> SDoc+pprMachOpApp' mop args+ = case args of+    -- dyadic+    [x,y] -> pprArg x <+> pprMachOp_for_C mop <+> pprArg y++    -- unary+    [x]   -> pprMachOp_for_C mop <> parens (pprArg x)++    _     -> panic "PprC.pprMachOp : machop with wrong number of args"++  where+        -- Cast needed for signed integer ops+    pprArg e | signedOp    mop = sdocWithDynFlags $ \dflags ->+                                 cCast (machRep_S_CType (typeWidth (cmmExprType dflags e))) e+             | needsFCasts mop = sdocWithDynFlags $ \dflags ->+                                 cCast (machRep_F_CType (typeWidth (cmmExprType dflags e))) e+             | otherwise    = pprExpr1 e+    needsFCasts (MO_F_Eq _)   = False+    needsFCasts (MO_F_Ne _)   = False+    needsFCasts (MO_F_Neg _)  = True+    needsFCasts (MO_F_Quot _) = True+    needsFCasts mop  = floatComparison mop++-- --------------------------------------------------------------------------+-- Literals++pprLit :: CmmLit -> SDoc+pprLit lit = case lit of+    CmmInt i rep      -> pprHexVal i rep++    CmmFloat f w       -> parens (machRep_F_CType w) <> str+        where d = fromRational f :: Double+              str | isInfinite d && d < 0 = text "-INFINITY"+                  | isInfinite d          = text "INFINITY"+                  | isNaN d               = text "NAN"+                  | otherwise             = text (show d)+                -- these constants come from <math.h>+                -- see #1861++    CmmVec {} -> panic "PprC printing vector literal"++    CmmBlock bid       -> mkW_ <> pprCLabelAddr (infoTblLbl bid)+    CmmHighStackMark   -> panic "PprC printing high stack mark"+    CmmLabel clbl      -> mkW_ <> pprCLabelAddr clbl+    CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i+    CmmLabelDiffOff clbl1 _ i+        -- WARNING:+        --  * the lit must occur in the info table clbl2+        --  * clbl1 must be an SRT, a slow entry point or a large bitmap+        -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i++    where+        pprCLabelAddr lbl = char '&' <> ppr lbl++pprLit1 :: CmmLit -> SDoc+pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit)+pprLit1 lit@(CmmLabelDiffOff _ _ _) = parens (pprLit lit)+pprLit1 lit@(CmmFloat _ _)    = parens (pprLit lit)+pprLit1 other = pprLit other++-- ---------------------------------------------------------------------------+-- Static data++pprStatics :: DynFlags -> [CmmStatic] -> [SDoc]+pprStatics _ [] = []+pprStatics dflags (CmmStaticLit (CmmFloat f W32) : rest)+  -- floats are padded to a word by padLitToWord, see #1852+  | wORD_SIZE dflags == 8, CmmStaticLit (CmmInt 0 W32) : rest' <- rest+  = pprLit1 (floatToWord dflags f) : pprStatics dflags rest'+  | wORD_SIZE dflags == 4+  = pprLit1 (floatToWord dflags f) : pprStatics dflags rest+  | otherwise+  = pprPanic "pprStatics: float" (vcat (map ppr' rest))+    where ppr' (CmmStaticLit l) = sdocWithDynFlags $ \dflags ->+                                  ppr (cmmLitType dflags l)+          ppr' _other           = text "bad static!"+pprStatics dflags (CmmStaticLit (CmmFloat f W64) : rest)+  = map pprLit1 (doubleToWords dflags f) ++ pprStatics dflags rest++pprStatics dflags (CmmStaticLit (CmmInt i W64) : rest)+  | wordWidth dflags == W32+  = if wORDS_BIGENDIAN dflags+    then pprStatics dflags (CmmStaticLit (CmmInt q W32) :+                            CmmStaticLit (CmmInt r W32) : rest)+    else pprStatics dflags (CmmStaticLit (CmmInt r W32) :+                            CmmStaticLit (CmmInt q W32) : rest)+  where r = i .&. 0xffffffff+        q = i `shiftR` 32+pprStatics dflags (CmmStaticLit (CmmInt _ w) : _)+  | w /= wordWidth dflags+  = panic "pprStatics: cannot emit a non-word-sized static literal"+pprStatics dflags (CmmStaticLit lit : rest)+  = pprLit1 lit : pprStatics dflags rest+pprStatics _ (other : _)+  = pprPanic "pprWord" (pprStatic other)++pprStatic :: CmmStatic -> SDoc+pprStatic s = case s of++    CmmStaticLit lit   -> nest 4 (pprLit lit)+    CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i))++    -- these should be inlined, like the old .hc+    CmmString s'       -> nest 4 (mkW_ <> parens(pprStringInCStyle s'))+++-- ---------------------------------------------------------------------------+-- Block Ids++pprBlockId :: BlockId -> SDoc+pprBlockId b = char '_' <> ppr (getUnique b)++-- --------------------------------------------------------------------------+-- Print a MachOp in a way suitable for emitting via C.+--++pprMachOp_for_C :: MachOp -> SDoc++pprMachOp_for_C mop = case mop of++        -- Integer operations+        MO_Add          _ -> char '+'+        MO_Sub          _ -> char '-'+        MO_Eq           _ -> text "=="+        MO_Ne           _ -> text "!="+        MO_Mul          _ -> char '*'++        MO_S_Quot       _ -> char '/'+        MO_S_Rem        _ -> char '%'+        MO_S_Neg        _ -> char '-'++        MO_U_Quot       _ -> char '/'+        MO_U_Rem        _ -> char '%'++        -- & Floating-point operations+        MO_F_Add        _ -> char '+'+        MO_F_Sub        _ -> char '-'+        MO_F_Neg        _ -> char '-'+        MO_F_Mul        _ -> char '*'+        MO_F_Quot       _ -> char '/'++        -- Signed comparisons+        MO_S_Ge         _ -> text ">="+        MO_S_Le         _ -> text "<="+        MO_S_Gt         _ -> char '>'+        MO_S_Lt         _ -> char '<'++        -- & Unsigned comparisons+        MO_U_Ge         _ -> text ">="+        MO_U_Le         _ -> text "<="+        MO_U_Gt         _ -> char '>'+        MO_U_Lt         _ -> char '<'++        -- & Floating-point comparisons+        MO_F_Eq         _ -> text "=="+        MO_F_Ne         _ -> text "!="+        MO_F_Ge         _ -> text ">="+        MO_F_Le         _ -> text "<="+        MO_F_Gt         _ -> char '>'+        MO_F_Lt         _ -> char '<'++        -- Bitwise operations.  Not all of these may be supported at all+        -- sizes, and only integral MachReps are valid.+        MO_And          _ -> char '&'+        MO_Or           _ -> char '|'+        MO_Xor          _ -> char '^'+        MO_Not          _ -> char '~'+        MO_Shl          _ -> text "<<"+        MO_U_Shr        _ -> text ">>" -- unsigned shift right+        MO_S_Shr        _ -> text ">>" -- signed shift right++-- Conversions.  Some of these will be NOPs, but never those that convert+-- between ints and floats.+-- Floating-point conversions use the signed variant.+-- We won't know to generate (void*) casts here, but maybe from+-- context elsewhere++-- noop casts+        MO_UU_Conv from to | from == to -> empty+        MO_UU_Conv _from to -> parens (machRep_U_CType to)++        MO_SS_Conv from to | from == to -> empty+        MO_SS_Conv _from to -> parens (machRep_S_CType to)++        MO_FF_Conv from to | from == to -> empty+        MO_FF_Conv _from to -> parens (machRep_F_CType to)++        MO_SF_Conv _from to -> parens (machRep_F_CType to)+        MO_FS_Conv _from to -> parens (machRep_S_CType to)++        MO_S_MulMayOflo _ -> pprTrace "offending mop:"+                                (text "MO_S_MulMayOflo")+                                (panic $ "PprC.pprMachOp_for_C: MO_S_MulMayOflo"+                                      ++ " should have been handled earlier!")+        MO_U_MulMayOflo _ -> pprTrace "offending mop:"+                                (text "MO_U_MulMayOflo")+                                (panic $ "PprC.pprMachOp_for_C: MO_U_MulMayOflo"+                                      ++ " should have been handled earlier!")++        MO_V_Insert {}    -> pprTrace "offending mop:"+                                (text "MO_V_Insert")+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Insert"+                                      ++ " should have been handled earlier!")+        MO_V_Extract {}   -> pprTrace "offending mop:"+                                (text "MO_V_Extract")+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Extract"+                                      ++ " should have been handled earlier!")++        MO_V_Add {}       -> pprTrace "offending mop:"+                                (text "MO_V_Add")+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Add"+                                      ++ " should have been handled earlier!")+        MO_V_Sub {}       -> pprTrace "offending mop:"+                                (text "MO_V_Sub")+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Sub"+                                      ++ " should have been handled earlier!")+        MO_V_Mul {}       -> pprTrace "offending mop:"+                                (text "MO_V_Mul")+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Mul"+                                      ++ " should have been handled earlier!")++        MO_VS_Quot {}     -> pprTrace "offending mop:"+                                (text "MO_VS_Quot")+                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Quot"+                                      ++ " should have been handled earlier!")+        MO_VS_Rem {}      -> pprTrace "offending mop:"+                                (text "MO_VS_Rem")+                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Rem"+                                      ++ " should have been handled earlier!")+        MO_VS_Neg {}      -> pprTrace "offending mop:"+                                (text "MO_VS_Neg")+                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Neg"+                                      ++ " should have been handled earlier!")++        MO_VU_Quot {}     -> pprTrace "offending mop:"+                                (text "MO_VU_Quot")+                                (panic $ "PprC.pprMachOp_for_C: MO_VU_Quot"+                                      ++ " should have been handled earlier!")+        MO_VU_Rem {}      -> pprTrace "offending mop:"+                                (text "MO_VU_Rem")+                                (panic $ "PprC.pprMachOp_for_C: MO_VU_Rem"+                                      ++ " should have been handled earlier!")++        MO_VF_Insert {}   -> pprTrace "offending mop:"+                                (text "MO_VF_Insert")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Insert"+                                      ++ " should have been handled earlier!")+        MO_VF_Extract {}  -> pprTrace "offending mop:"+                                (text "MO_VF_Extract")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Extract"+                                      ++ " should have been handled earlier!")++        MO_VF_Add {}      -> pprTrace "offending mop:"+                                (text "MO_VF_Add")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Add"+                                      ++ " should have been handled earlier!")+        MO_VF_Sub {}      -> pprTrace "offending mop:"+                                (text "MO_VF_Sub")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Sub"+                                      ++ " should have been handled earlier!")+        MO_VF_Neg {}      -> pprTrace "offending mop:"+                                (text "MO_VF_Neg")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Neg"+                                      ++ " should have been handled earlier!")+        MO_VF_Mul {}      -> pprTrace "offending mop:"+                                (text "MO_VF_Mul")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Mul"+                                      ++ " should have been handled earlier!")+        MO_VF_Quot {}     -> pprTrace "offending mop:"+                                (text "MO_VF_Quot")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Quot"+                                      ++ " should have been handled earlier!")++signedOp :: MachOp -> Bool      -- Argument type(s) are signed ints+signedOp (MO_S_Quot _)    = True+signedOp (MO_S_Rem  _)    = True+signedOp (MO_S_Neg  _)    = True+signedOp (MO_S_Ge   _)    = True+signedOp (MO_S_Le   _)    = True+signedOp (MO_S_Gt   _)    = True+signedOp (MO_S_Lt   _)    = True+signedOp (MO_S_Shr  _)    = True+signedOp (MO_SS_Conv _ _) = True+signedOp (MO_SF_Conv _ _) = True+signedOp _                = False++floatComparison :: MachOp -> Bool  -- comparison between float args+floatComparison (MO_F_Eq   _) = True+floatComparison (MO_F_Ne   _) = True+floatComparison (MO_F_Ge   _) = True+floatComparison (MO_F_Le   _) = True+floatComparison (MO_F_Gt   _) = True+floatComparison (MO_F_Lt   _) = True+floatComparison _             = False++-- ---------------------------------------------------------------------+-- tend to be implemented by foreign calls++pprCallishMachOp_for_C :: CallishMachOp -> SDoc++pprCallishMachOp_for_C mop+    = case mop of+        MO_F64_Pwr      -> text "pow"+        MO_F64_Sin      -> text "sin"+        MO_F64_Cos      -> text "cos"+        MO_F64_Tan      -> text "tan"+        MO_F64_Sinh     -> text "sinh"+        MO_F64_Cosh     -> text "cosh"+        MO_F64_Tanh     -> text "tanh"+        MO_F64_Asin     -> text "asin"+        MO_F64_Acos     -> text "acos"+        MO_F64_Atan     -> text "atan"+        MO_F64_Log      -> text "log"+        MO_F64_Exp      -> text "exp"+        MO_F64_Sqrt     -> text "sqrt"+        MO_F64_Fabs     -> text "fabs"+        MO_F32_Pwr      -> text "powf"+        MO_F32_Sin      -> text "sinf"+        MO_F32_Cos      -> text "cosf"+        MO_F32_Tan      -> text "tanf"+        MO_F32_Sinh     -> text "sinhf"+        MO_F32_Cosh     -> text "coshf"+        MO_F32_Tanh     -> text "tanhf"+        MO_F32_Asin     -> text "asinf"+        MO_F32_Acos     -> text "acosf"+        MO_F32_Atan     -> text "atanf"+        MO_F32_Log      -> text "logf"+        MO_F32_Exp      -> text "expf"+        MO_F32_Sqrt     -> text "sqrtf"+        MO_F32_Fabs     -> text "fabsf"+        MO_WriteBarrier -> text "write_barrier"+        MO_Memcpy _     -> text "memcpy"+        MO_Memset _     -> text "memset"+        MO_Memmove _    -> text "memmove"+        (MO_BSwap w)    -> ptext (sLit $ bSwapLabel w)+        (MO_PopCnt w)   -> ptext (sLit $ popCntLabel w)+        (MO_Clz w)      -> ptext (sLit $ clzLabel w)+        (MO_Ctz w)      -> ptext (sLit $ ctzLabel w)+        (MO_AtomicRMW w amop) -> ptext (sLit $ atomicRMWLabel w amop)+        (MO_Cmpxchg w)  -> ptext (sLit $ cmpxchgLabel w)+        (MO_AtomicRead w)  -> ptext (sLit $ atomicReadLabel w)+        (MO_AtomicWrite w) -> ptext (sLit $ atomicWriteLabel w)+        (MO_UF_Conv w)  -> ptext (sLit $ word2FloatLabel w)++        MO_S_QuotRem  {} -> unsupported+        MO_U_QuotRem  {} -> unsupported+        MO_U_QuotRem2 {} -> unsupported+        MO_Add2       {} -> unsupported+        MO_SubWordC   {} -> unsupported+        MO_AddIntC    {} -> unsupported+        MO_SubIntC    {} -> unsupported+        MO_U_Mul2     {} -> unsupported+        MO_Touch         -> unsupported+        (MO_Prefetch_Data _ ) -> unsupported+        --- we could support prefetch via "__builtin_prefetch"+        --- Not adding it for now+    where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop+                            ++ " not supported!")++-- ---------------------------------------------------------------------+-- Useful #defines+--++mkJMP_, mkFN_, mkIF_ :: SDoc -> SDoc++mkJMP_ i = text "JMP_" <> parens i+mkFN_  i = text "FN_"  <> parens i -- externally visible function+mkIF_  i = text "IF_"  <> parens i -- locally visible++-- from includes/Stg.h+--+mkC_,mkW_,mkP_ :: SDoc++mkC_  = text "(C_)"        -- StgChar+mkW_  = text "(W_)"        -- StgWord+mkP_  = text "(P_)"        -- StgWord*++-- ---------------------------------------------------------------------+--+-- Assignments+--+-- Generating assignments is what we're all about, here+--+pprAssign :: DynFlags -> CmmReg -> CmmExpr -> SDoc++-- dest is a reg, rhs is a reg+pprAssign _ r1 (CmmReg r2)+   | isPtrReg r1 && isPtrReg r2+   = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ]++-- dest is a reg, rhs is a CmmRegOff+pprAssign dflags r1 (CmmRegOff r2 off)+   | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE dflags == 0)+   = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ]+  where+        off1 = off `shiftR` wordShift dflags++        (op,off') | off >= 0  = (char '+', off1)+                  | otherwise = (char '-', -off1)++-- dest is a reg, rhs is anything.+-- We can't cast the lvalue, so we have to cast the rhs if necessary.  Casting+-- the lvalue elicits a warning from new GCC versions (3.4+).+pprAssign _ r1 r2+  | isFixedPtrReg r1             = mkAssign (mkP_ <> pprExpr1 r2)+  | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 r2)+  | otherwise                    = mkAssign (pprExpr r2)+    where mkAssign x = if r1 == CmmGlobal BaseReg+                       then text "ASSIGN_BaseReg" <> parens x <> semi+                       else pprReg r1 <> text " = " <> x <> semi++-- ---------------------------------------------------------------------+-- Registers++pprCastReg :: CmmReg -> SDoc+pprCastReg reg+   | isStrangeTypeReg reg = mkW_ <> pprReg reg+   | otherwise            = pprReg reg++-- True if (pprReg reg) will give an expression with type StgPtr.  We+-- need to take care with pointer arithmetic on registers with type+-- StgPtr.+isFixedPtrReg :: CmmReg -> Bool+isFixedPtrReg (CmmLocal _) = False+isFixedPtrReg (CmmGlobal r) = isFixedPtrGlobalReg r++-- True if (pprAsPtrReg reg) will give an expression with type StgPtr+-- JD: THIS IS HORRIBLE AND SHOULD BE RENAMED, AT THE VERY LEAST.+-- THE GARBAGE WITH THE VNonGcPtr HELPS MATCH THE OLD CODE GENERATOR'S OUTPUT;+-- I'M NOT SURE IF IT SHOULD REALLY STAY THAT WAY.+isPtrReg :: CmmReg -> Bool+isPtrReg (CmmLocal _)                         = False+isPtrReg (CmmGlobal (VanillaReg _ VGcPtr))    = True  -- if we print via pprAsPtrReg+isPtrReg (CmmGlobal (VanillaReg _ VNonGcPtr)) = False -- if we print via pprAsPtrReg+isPtrReg (CmmGlobal reg)                      = isFixedPtrGlobalReg reg++-- True if this global reg has type StgPtr+isFixedPtrGlobalReg :: GlobalReg -> Bool+isFixedPtrGlobalReg Sp    = True+isFixedPtrGlobalReg Hp    = True+isFixedPtrGlobalReg HpLim = True+isFixedPtrGlobalReg SpLim = True+isFixedPtrGlobalReg _     = False++-- True if in C this register doesn't have the type given by+-- (machRepCType (cmmRegType reg)), so it has to be cast.+isStrangeTypeReg :: CmmReg -> Bool+isStrangeTypeReg (CmmLocal _)   = False+isStrangeTypeReg (CmmGlobal g)  = isStrangeTypeGlobal g++isStrangeTypeGlobal :: GlobalReg -> Bool+isStrangeTypeGlobal CCCS                = True+isStrangeTypeGlobal CurrentTSO          = True+isStrangeTypeGlobal CurrentNursery      = True+isStrangeTypeGlobal BaseReg             = True+isStrangeTypeGlobal r                   = isFixedPtrGlobalReg r++strangeRegType :: CmmReg -> Maybe SDoc+strangeRegType (CmmGlobal CCCS) = Just (text "struct CostCentreStack_ *")+strangeRegType (CmmGlobal CurrentTSO) = Just (text "struct StgTSO_ *")+strangeRegType (CmmGlobal CurrentNursery) = Just (text "struct bdescr_ *")+strangeRegType (CmmGlobal BaseReg) = Just (text "struct StgRegTable_ *")+strangeRegType _ = Nothing++-- pprReg just prints the register name.+--+pprReg :: CmmReg -> SDoc+pprReg r = case r of+        CmmLocal  local  -> pprLocalReg local+        CmmGlobal global -> pprGlobalReg global++pprAsPtrReg :: CmmReg -> SDoc+pprAsPtrReg (CmmGlobal (VanillaReg n gcp))+  = WARN( gcp /= VGcPtr, ppr n ) char 'R' <> int n <> text ".p"+pprAsPtrReg other_reg = pprReg other_reg++pprGlobalReg :: GlobalReg -> SDoc+pprGlobalReg gr = case gr of+    VanillaReg n _ -> char 'R' <> int n  <> text ".w"+        -- pprGlobalReg prints a VanillaReg as a .w regardless+        -- Example:     R1.w = R1.w & (-0x8UL);+        --              JMP_(*R1.p);+    FloatReg   n   -> char 'F' <> int n+    DoubleReg  n   -> char 'D' <> int n+    LongReg    n   -> char 'L' <> int n+    Sp             -> text "Sp"+    SpLim          -> text "SpLim"+    Hp             -> text "Hp"+    HpLim          -> text "HpLim"+    CCCS           -> text "CCCS"+    CurrentTSO     -> text "CurrentTSO"+    CurrentNursery -> text "CurrentNursery"+    HpAlloc        -> text "HpAlloc"+    BaseReg        -> text "BaseReg"+    EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info"+    GCEnter1       -> text "stg_gc_enter_1"+    GCFun          -> text "stg_gc_fun"+    other          -> panic $ "pprGlobalReg: Unsupported register: " ++ show other++pprLocalReg :: LocalReg -> SDoc+pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq++-- -----------------------------------------------------------------------------+-- Foreign Calls++pprCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc+pprCall ppr_fn cconv results args+  | not (is_cishCC cconv)+  = panic $ "pprCall: unknown calling convention"++  | otherwise+  =+    ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi+  where+     ppr_assign []           rhs = rhs+     ppr_assign [(one,hint)] rhs+         = pprLocalReg one <> text " = "+                 <> pprUnHint hint (localRegType one) <> rhs+     ppr_assign _other _rhs = panic "pprCall: multiple results"++     pprArg (expr, AddrHint)+        = cCast (text "void *") expr+        -- see comment by machRepHintCType below+     pprArg (expr, SignedHint)+        = sdocWithDynFlags $ \dflags ->+          cCast (machRep_S_CType $ typeWidth $ cmmExprType dflags expr) expr+     pprArg (expr, _other)+        = pprExpr expr++     pprUnHint AddrHint   rep = parens (machRepCType rep)+     pprUnHint SignedHint rep = parens (machRepCType rep)+     pprUnHint _          _   = empty++-- Currently we only have these two calling conventions, but this might+-- change in the future...+is_cishCC :: CCallConv -> Bool+is_cishCC CCallConv    = True+is_cishCC CApiConv     = True+is_cishCC StdCallConv  = True+is_cishCC PrimCallConv = False+is_cishCC JavaScriptCallConv = False++-- ---------------------------------------------------------------------+-- Find and print local and external declarations for a list of+-- Cmm statements.+--+pprTempAndExternDecls :: [CmmBlock] -> (SDoc{-temps-}, SDoc{-externs-})+pprTempAndExternDecls stmts+  = (pprUFM (getUniqSet temps) (vcat . map pprTempDecl),+     vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls)))+  where (temps, lbls) = runTE (mapM_ te_BB stmts)++pprDataExterns :: [CmmStatic] -> SDoc+pprDataExterns statics+  = vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls))+  where (_, lbls) = runTE (mapM_ te_Static statics)++pprTempDecl :: LocalReg -> SDoc+pprTempDecl l@(LocalReg _ rep)+  = hcat [ machRepCType rep, space, pprLocalReg l, semi ]++pprExternDecl :: Bool -> CLabel -> SDoc+pprExternDecl _in_srt lbl+  -- do not print anything for "known external" things+  | not (needsCDecl lbl) = empty+  | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz+  | otherwise =+        hcat [ visibility, label_type lbl,+               lparen, ppr lbl, text ");" ]+ where+  label_type lbl | isBytesLabel lbl     = text "B_"+                 | isForeignLabel lbl && isCFunctionLabel lbl = text "FF_"+                 | isCFunctionLabel lbl = text "F_"+                 | otherwise            = text "I_"++  visibility+     | externallyVisibleCLabel lbl = char 'E'+     | otherwise                   = char 'I'++  -- If the label we want to refer to is a stdcall function (on Windows) then+  -- we must generate an appropriate prototype for it, so that the C compiler will+  -- add the @n suffix to the label (#2276)+  stdcall_decl sz = sdocWithDynFlags $ \dflags ->+        text "extern __attribute__((stdcall)) void " <> ppr lbl+        <> parens (commafy (replicate (sz `quot` wORD_SIZE dflags) (machRep_U_CType (wordWidth dflags))))+        <> semi++type TEState = (UniqSet LocalReg, Map CLabel ())+newtype TE a = TE { unTE :: TEState -> (a, TEState) }++instance Functor TE where+      fmap = liftM++instance Applicative TE where+      pure a = TE $ \s -> (a, s)+      (<*>) = ap++instance Monad TE where+   TE m >>= k  = TE $ \s -> case m s of (a, s') -> unTE (k a) s'++te_lbl :: CLabel -> TE ()+te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, Map.insert lbl () lbls))++te_temp :: LocalReg -> TE ()+te_temp r = TE $ \(temps,lbls) -> ((), (addOneToUniqSet temps r, lbls))++runTE :: TE () -> TEState+runTE (TE m) = snd (m (emptyUniqSet, Map.empty))++te_Static :: CmmStatic -> TE ()+te_Static (CmmStaticLit lit) = te_Lit lit+te_Static _ = return ()++te_BB :: CmmBlock -> TE ()+te_BB block = mapM_ te_Stmt (blockToList mid) >> te_Stmt last+  where (_, mid, last) = blockSplit block++te_Lit :: CmmLit -> TE ()+te_Lit (CmmLabel l) = te_lbl l+te_Lit (CmmLabelOff l _) = te_lbl l+te_Lit (CmmLabelDiffOff l1 _ _) = te_lbl l1+te_Lit _ = return ()++te_Stmt :: CmmNode e x -> TE ()+te_Stmt (CmmAssign r e)         = te_Reg r >> te_Expr e+te_Stmt (CmmStore l r)          = te_Expr l >> te_Expr r+te_Stmt (CmmUnsafeForeignCall target rs es)+  = do  te_Target target+        mapM_ te_temp rs+        mapM_ te_Expr es+te_Stmt (CmmCondBranch e _ _ _) = te_Expr e+te_Stmt (CmmSwitch e _)         = te_Expr e+te_Stmt (CmmCall { cml_target = e }) = te_Expr e+te_Stmt _                       = return ()++te_Target :: ForeignTarget -> TE ()+te_Target (ForeignTarget e _)      = te_Expr e+te_Target (PrimTarget{})           = return ()++te_Expr :: CmmExpr -> TE ()+te_Expr (CmmLit lit)            = te_Lit lit+te_Expr (CmmLoad e _)           = te_Expr e+te_Expr (CmmReg r)              = te_Reg r+te_Expr (CmmMachOp _ es)        = mapM_ te_Expr es+te_Expr (CmmRegOff r _)         = te_Reg r+te_Expr (CmmStackSlot _ _)      = panic "te_Expr: CmmStackSlot not supported!"++te_Reg :: CmmReg -> TE ()+te_Reg (CmmLocal l) = te_temp l+te_Reg _            = return ()+++-- ---------------------------------------------------------------------+-- C types for MachReps++cCast :: SDoc -> CmmExpr -> SDoc+cCast ty expr = parens ty <> pprExpr1 expr++cLoad :: CmmExpr -> CmmType -> SDoc+cLoad expr rep+    = sdocWithPlatform $ \platform ->+      if bewareLoadStoreAlignment (platformArch platform)+      then let decl = machRepCType rep <+> text "x" <> semi+               struct = text "struct" <+> braces (decl)+               packed_attr = text "__attribute__((packed))"+               cast = parens (struct <+> packed_attr <> char '*')+           in parens (cast <+> pprExpr1 expr) <> text "->x"+      else char '*' <> parens (cCast (machRepPtrCType rep) expr)+    where -- On these platforms, unaligned loads are known to cause problems+          bewareLoadStoreAlignment ArchAlpha    = True+          bewareLoadStoreAlignment ArchMipseb   = True+          bewareLoadStoreAlignment ArchMipsel   = True+          bewareLoadStoreAlignment (ArchARM {}) = True+          bewareLoadStoreAlignment ArchARM64    = True+          bewareLoadStoreAlignment ArchSPARC    = True+          bewareLoadStoreAlignment ArchSPARC64  = True+          -- Pessimistically assume that they will also cause problems+          -- on unknown arches+          bewareLoadStoreAlignment ArchUnknown  = True+          bewareLoadStoreAlignment _            = False++isCmmWordType :: DynFlags -> CmmType -> Bool+-- True of GcPtrReg/NonGcReg of native word size+isCmmWordType dflags ty = not (isFloatType ty)+                       && typeWidth ty == wordWidth dflags++-- This is for finding the types of foreign call arguments.  For a pointer+-- argument, we always cast the argument to (void *), to avoid warnings from+-- the C compiler.+machRepHintCType :: CmmType -> ForeignHint -> SDoc+machRepHintCType _   AddrHint   = text "void *"+machRepHintCType rep SignedHint = machRep_S_CType (typeWidth rep)+machRepHintCType rep _other     = machRepCType rep++machRepPtrCType :: CmmType -> SDoc+machRepPtrCType r+ = sdocWithDynFlags $ \dflags ->+   if isCmmWordType dflags r then text "P_"+                             else machRepCType r <> char '*'++machRepCType :: CmmType -> SDoc+machRepCType ty | isFloatType ty = machRep_F_CType w+                | otherwise      = machRep_U_CType w+                where+                  w = typeWidth ty++machRep_F_CType :: Width -> SDoc+machRep_F_CType W32 = text "StgFloat" -- ToDo: correct?+machRep_F_CType W64 = text "StgDouble"+machRep_F_CType _   = panic "machRep_F_CType"++machRep_U_CType :: Width -> SDoc+machRep_U_CType w+ = sdocWithDynFlags $ \dflags ->+   case w of+   _ | w == wordWidth dflags -> text "W_"+   W8  -> text "StgWord8"+   W16 -> text "StgWord16"+   W32 -> text "StgWord32"+   W64 -> text "StgWord64"+   _   -> panic "machRep_U_CType"++machRep_S_CType :: Width -> SDoc+machRep_S_CType w+ = sdocWithDynFlags $ \dflags ->+   case w of+   _ | w == wordWidth dflags -> text "I_"+   W8  -> text "StgInt8"+   W16 -> text "StgInt16"+   W32 -> text "StgInt32"+   W64 -> text "StgInt64"+   _   -> panic "machRep_S_CType"+++-- ---------------------------------------------------------------------+-- print strings as valid C strings++pprStringInCStyle :: [Word8] -> SDoc+pprStringInCStyle s = doubleQuotes (text (concatMap charToC s))++-- ---------------------------------------------------------------------------+-- Initialising static objects with floating-point numbers.  We can't+-- just emit the floating point number, because C will cast it to an int+-- by rounding it.  We want the actual bit-representation of the float.+--+-- Consider a concrete C example:+--    double d = 2.5e-10;+--    float f  = 2.5e-10f;+--+--    int * i2 = &d;      printf ("i2: %08X %08X\n", i2[0], i2[1]);+--    long long * l = &d; printf (" l: %016llX\n",   l[0]);+--    int * i = &f;       printf (" i: %08X\n",      i[0]);+-- Result on 64-bit LE (x86_64):+--     i2: E826D695 3DF12E0B+--      l: 3DF12E0BE826D695+--      i: 2F89705F+-- Result on 32-bit BE (m68k):+--     i2: 3DF12E0B E826D695+--      l: 3DF12E0BE826D695+--      i: 2F89705F+--+-- The trick here is to notice that binary representation does not+-- change much: only Word32 values get swapped on LE hosts / targets.++-- This is a hack to turn the floating point numbers into ints that we+-- can safely initialise to static locations.++castFloatToWord32Array :: STUArray s Int Float -> ST s (STUArray s Int Word32)+castFloatToWord32Array = U.castSTUArray++castDoubleToWord64Array :: STUArray s Int Double -> ST s (STUArray s Int Word64)+castDoubleToWord64Array = U.castSTUArray++floatToWord :: DynFlags -> Rational -> CmmLit+floatToWord dflags r+  = runST (do+        arr <- newArray_ ((0::Int),0)+        writeArray arr 0 (fromRational r)+        arr' <- castFloatToWord32Array arr+        w32 <- readArray arr' 0+        return (CmmInt (toInteger w32 `shiftL` wo) (wordWidth dflags))+    )+    where wo | wordWidth dflags == W64+             , wORDS_BIGENDIAN dflags    = 32+             | otherwise                 = 0++doubleToWords :: DynFlags -> Rational -> [CmmLit]+doubleToWords dflags r+  = runST (do+        arr <- newArray_ ((0::Int),1)+        writeArray arr 0 (fromRational r)+        arr' <- castDoubleToWord64Array arr+        w64 <- readArray arr' 0+        return (pprWord64 w64)+    )+    where targetWidth = wordWidth dflags+          targetBE    = wORDS_BIGENDIAN dflags+          pprWord64 w64+              | targetWidth == W64 =+                  [ CmmInt (toInteger w64) targetWidth ]+              | targetWidth == W32 =+                  [ CmmInt (toInteger targetW1) targetWidth+                  , CmmInt (toInteger targetW2) targetWidth+                  ]+              | otherwise = panic "doubleToWords.pprWord64"+              where (targetW1, targetW2)+                        | targetBE  = (wHi, wLo)+                        | otherwise = (wLo, wHi)+                    wHi = w64 `shiftR` 32+                    wLo = w64 .&. 0xFFFFffff++-- ---------------------------------------------------------------------------+-- Utils++wordShift :: DynFlags -> Int+wordShift dflags = widthInLog (wordWidth dflags)++commafy :: [SDoc] -> SDoc+commafy xs = hsep $ punctuate comma xs++-- Print in C hex format: 0x13fa+pprHexVal :: Integer -> Width -> SDoc+pprHexVal w rep+  | w < 0     = parens (char '-' <>+                    text "0x" <> intToDoc (-w) <> repsuffix rep)+  | otherwise =     text "0x" <> intToDoc   w  <> repsuffix rep+  where+        -- type suffix for literals:+        -- Integer literals are unsigned in Cmm/C.  We explicitly cast to+        -- signed values for doing signed operations, but at all other+        -- times values are unsigned.  This also helps eliminate occasional+        -- warnings about integer overflow from gcc.++      repsuffix W64 = sdocWithDynFlags $ \dflags ->+               if cINT_SIZE       dflags == 8 then char 'U'+          else if cLONG_SIZE      dflags == 8 then text "UL"+          else if cLONG_LONG_SIZE dflags == 8 then text "ULL"+          else panic "pprHexVal: Can't find a 64-bit type"+      repsuffix _ = char 'U'++      intToDoc :: Integer -> SDoc+      intToDoc i = case truncInt i of+                       0 -> char '0'+                       v -> go v++      -- We need to truncate value as Cmm backend does not drop+      -- redundant bits to ease handling of negative values.+      -- Thus the following Cmm code on 64-bit arch, like amd64:+      --     CInt v;+      --     v = {something};+      --     if (v == %lobits32(-1)) { ...+      -- leads to the following C code:+      --     StgWord64 v = (StgWord32)({something});+      --     if (v == 0xFFFFffffFFFFffffU) { ...+      -- Such code is incorrect as it promotes both operands to StgWord64+      -- and the whole condition is always false.+      truncInt :: Integer -> Integer+      truncInt i =+          case rep of+              W8  -> i `rem` (2^(8 :: Int))+              W16 -> i `rem` (2^(16 :: Int))+              W32 -> i `rem` (2^(32 :: Int))+              W64 -> i `rem` (2^(64 :: Int))+              _   -> panic ("pprHexVal/truncInt: C backend can't encode "+                            ++ show rep ++ " literals")++      go 0 = empty+      go w' = go q <> dig+           where+             (q,r) = w' `quotRem` 16+             dig | r < 10    = char (chr (fromInteger r + ord '0'))+                 | otherwise = char (chr (fromInteger r - 10 + ord 'a'))
+ cmm/PprCmm.hs view
@@ -0,0 +1,306 @@+{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++----------------------------------------------------------------------------+--+-- Pretty-printing of Cmm as (a superset of) C--+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------+--+-- This is where we walk over CmmNode emitting an external representation,+-- suitable for parsing, in a syntax strongly reminiscent of C--. This+-- is the "External Core" for the Cmm layer.+--+-- As such, this should be a well-defined syntax: we want it to look nice.+-- Thus, we try wherever possible to use syntax defined in [1],+-- "The C-- Reference Manual", http://www.cminusminus.org/. We differ+-- slightly, in some cases. For one, we use I8 .. I64 for types, rather+-- than C--'s bits8 .. bits64.+--+-- We try to ensure that all information available in the abstract+-- syntax is reproduced, or reproducible, in the concrete syntax.+-- Data that is not in printed out can be reconstructed according to+-- conventions used in the pretty printer. There are at least two such+-- cases:+--      1) if a value has wordRep type, the type is not appended in the+--      output.+--      2) MachOps that operate over wordRep type are printed in a+--      C-style, rather than as their internal MachRep name.+--+-- These conventions produce much more readable Cmm output.+--+-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs++module PprCmm+  ( module PprCmmDecl+  , module PprCmmExpr+  )+where++import BlockId ()+import CLabel+import Cmm+import CmmUtils+import CmmSwitch+import DynFlags+import FastString+import Outputable+import PprCmmDecl+import PprCmmExpr+import Util+import PprCore ()++import BasicTypes+import Compiler.Hoopl+import Data.List+import Prelude hiding (succ)++-------------------------------------------------+-- Outputable instances++instance Outputable CmmStackInfo where+    ppr = pprStackInfo++instance Outputable CmmTopInfo where+    ppr = pprTopInfo+++instance Outputable (CmmNode e x) where+    ppr = pprNode++instance Outputable Convention where+    ppr = pprConvention++instance Outputable ForeignConvention where+    ppr = pprForeignConvention++instance Outputable ForeignTarget where+    ppr = pprForeignTarget++instance Outputable CmmReturnInfo where+    ppr = pprReturnInfo++instance Outputable (Block CmmNode C C) where+    ppr = pprBlock+instance Outputable (Block CmmNode C O) where+    ppr = pprBlock+instance Outputable (Block CmmNode O C) where+    ppr = pprBlock+instance Outputable (Block CmmNode O O) where+    ppr = pprBlock++instance Outputable (Graph CmmNode e x) where+    ppr = pprGraph++instance Outputable CmmGraph where+    ppr = pprCmmGraph++----------------------------------------------------------+-- Outputting types Cmm contains++pprStackInfo :: CmmStackInfo -> SDoc+pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) =+  text "arg_space: " <> ppr arg_space <+>+  text "updfr_space: " <> ppr updfr_space++pprTopInfo :: CmmTopInfo -> SDoc+pprTopInfo (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =+  vcat [text "info_tbl: " <> ppr info_tbl,+        text "stack_info: " <> ppr stack_info]++----------------------------------------------------------+-- Outputting blocks and graphs++pprBlock :: IndexedCO x SDoc SDoc ~ SDoc+         => Block CmmNode e x -> IndexedCO e SDoc SDoc+pprBlock block+    = foldBlockNodesB3 ( ($$) . ppr+                       , ($$) . (nest 4) . ppr+                       , ($$) . (nest 4) . ppr+                       )+                       block+                       empty++pprGraph :: Graph CmmNode e x -> SDoc+pprGraph GNil = empty+pprGraph (GUnit block) = ppr block+pprGraph (GMany entry body exit)+   = text "{"+  $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit)+  $$ text "}"+  where pprMaybeO :: Outputable (Block CmmNode e x)+                  => MaybeO ex (Block CmmNode e x) -> SDoc+        pprMaybeO NothingO = empty+        pprMaybeO (JustO block) = ppr block++pprCmmGraph :: CmmGraph -> SDoc+pprCmmGraph g+   = text "{" <> text "offset"+  $$ nest 2 (vcat $ map ppr blocks)+  $$ text "}"+  where blocks = postorderDfs g+    -- postorderDfs has the side-effect of discarding unreachable code,+    -- so pretty-printed Cmm will omit any unreachable blocks.  This can+    -- sometimes be confusing.++---------------------------------------------+-- Outputting CmmNode and types which it contains++pprConvention :: Convention -> SDoc+pprConvention (NativeNodeCall   {}) = text "<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 :: ForeignTarget -> SDoc+pprForeignTarget (ForeignTarget fn c) = ppr c <+> ppr_target fn+  where+        ppr_target :: CmmExpr -> SDoc+        ppr_target t@(CmmLit _) = ppr t+        ppr_target fn'          = parens (ppr fn')++pprForeignTarget (PrimTarget op)+ -- HACK: We're just using a ForeignLabel to get this printed, the label+ --       might not really be foreign.+ = ppr+               (CmmLabel (mkForeignLabel+                         (mkFastString (show op))+                         Nothing ForeignLabelInThisPackage IsFunction))++pprNode :: CmmNode e x -> SDoc+pprNode node = pp_node <+> pp_debug+  where+    pp_node :: SDoc+    pp_node = sdocWithDynFlags $ \dflags -> case node of+      -- label:+      CmmEntry id tscope -> ppr id <> colon <+>+         (sdocWithDynFlags $ \dflags ->+           ppUnless (gopt Opt_SuppressTicks dflags) (text "//" <+> ppr tscope))++      -- // text+      CmmComment s -> text "//" <+> ftext s++      -- //tick bla<...>+      CmmTick t -> ppUnless (gopt Opt_SuppressTicks dflags) $+                   text "//tick" <+> ppr t++      -- unwind reg = expr;+      CmmUnwind regs ->+          text "unwind "+          <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> ppr e) regs) <> semi++      -- reg = expr;+      CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi++      -- rep[lv] = expr;+      CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi+          where+            rep = sdocWithDynFlags $ \dflags ->+                  ppr ( cmmExprType dflags expr )++      -- call "ccall" foo(x, y)[r1, r2];+      -- ToDo ppr volatile+      CmmUnsafeForeignCall target results args ->+          hsep [ ppUnless (null results) $+                    parens (commafy $ map ppr results) <+> equals,+                 text "call",+                 ppr target <> parens (commafy $ map ppr args) <> semi]++      -- goto label;+      CmmBranch ident -> text "goto" <+> ppr ident <> semi++      -- if (expr) goto t; else goto f;+      CmmCondBranch expr t f l ->+          hsep [ text "if"+               , parens(ppr expr)+               , case l of+                   Nothing -> empty+                   Just b -> parens (text "likely:" <+> ppr b)+               , text "goto"+               , ppr t <> semi+               , text "else goto"+               , ppr f <> semi+               ]++      CmmSwitch expr ids ->+          hang (hsep [ text "switch"+                     , range+                     , if isTrivialCmmExpr expr+                       then ppr expr+                       else parens (ppr expr)+                     , text "{"+                     ])+             4 (vcat (map ppCase cases) $$ def) $$ rbrace+          where+            (cases, mbdef) = switchTargetsFallThrough ids+            ppCase (is,l) = hsep+                            [ text "case"+                            , commafy $ map integer is+                            , text ": goto"+                            , ppr l <> semi+                            ]+            def | Just l <- mbdef = hsep+                            [ text "default: goto"+                            , ppr l <> semi+                            ]+                | otherwise = empty++            range = brackets $ hsep [integer lo, text "..", integer hi]+              where (lo,hi) = switchTargetsRange ids++      CmmCall tgt k regs out res updfr_off ->+          hcat [ text "call", space+               , pprFun tgt, parens (interpp'SP regs), space+               , returns <+>+                 text "args: " <> ppr out <> comma <+>+                 text "res: " <> ppr res <> comma <+>+                 text "upd: " <> ppr updfr_off+               , semi ]+          where pprFun f@(CmmLit _) = ppr f+                pprFun f = parens (ppr f)++                returns+                  | Just r <- k = text "returns to" <+> ppr r <> comma+                  | otherwise   = empty++      CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} ->+          hcat $ if i then [text "interruptible", space] else [] +++               [ text "foreign call", space+               , ppr t, text "(...)", space+               , text "returns to" <+> ppr s+                    <+> text "args:" <+> parens (ppr as)+                    <+> text "ress:" <+> parens (ppr rs)+               , text "ret_args:" <+> ppr a+               , text "ret_off:" <+> ppr u+               , semi ]++    pp_debug :: SDoc+    pp_debug =+      if not debugIsOn then empty+      else case node of+             CmmEntry {}             -> empty -- Looks terrible with text "  // CmmEntry"+             CmmComment {}           -> empty -- Looks also terrible with text "  // CmmComment"+             CmmTick {}              -> empty+             CmmUnwind {}            -> text "  // CmmUnwind"+             CmmAssign {}            -> text "  // CmmAssign"+             CmmStore {}             -> text "  // CmmStore"+             CmmUnsafeForeignCall {} -> text "  // CmmUnsafeForeignCall"+             CmmBranch {}            -> text "  // CmmBranch"+             CmmCondBranch {}        -> text "  // CmmCondBranch"+             CmmSwitch {}            -> text "  // CmmSwitch"+             CmmCall {}              -> text "  // CmmCall"+             CmmForeignCall {}       -> text "  // CmmForeignCall"++    commafy :: [SDoc] -> SDoc+    commafy xs = hsep $ punctuate comma xs
+ cmm/PprCmmDecl.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE CPP #-}++----------------------------------------------------------------------------+--+-- Pretty-printing of common Cmm types+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++--+-- This is where we walk over Cmm emitting an external representation,+-- suitable for parsing, in a syntax strongly reminiscent of C--. This+-- is the "External Core" for the Cmm layer.+--+-- As such, this should be a well-defined syntax: we want it to look nice.+-- Thus, we try wherever possible to use syntax defined in [1],+-- "The C-- Reference Manual", http://www.cminusminus.org/. We differ+-- slightly, in some cases. For one, we use I8 .. I64 for types, rather+-- than C--'s bits8 .. bits64.+--+-- We try to ensure that all information available in the abstract+-- syntax is reproduced, or reproducible, in the concrete syntax.+-- Data that is not in printed out can be reconstructed according to+-- conventions used in the pretty printer. There are at least two such+-- cases:+--      1) if a value has wordRep type, the type is not appended in the+--      output.+--      2) MachOps that operate over wordRep type are printed in a+--      C-style, rather than as their internal MachRep name.+--+-- These conventions produce much more readable Cmm output.+--+-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs+--++{-# OPTIONS_GHC -fno-warn-orphans #-}+module PprCmmDecl+    ( writeCmms, pprCmms, pprCmmGroup, pprSection, pprStatic+    )+where++import PprCmmExpr+import Cmm++import DynFlags+import Outputable+import FastString++import Data.List+import System.IO++-- Temp Jan08+import SMRep+#include "rts/storage/FunTypes.h"+++pprCmms :: (Outputable info, Outputable g)+        => [GenCmmGroup CmmStatics info g] -> SDoc+pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))+        where+          separator = space $$ text "-------------------" $$ space++writeCmms :: (Outputable info, Outputable g)+          => DynFlags -> Handle -> [GenCmmGroup CmmStatics info g] -> IO ()+writeCmms dflags handle cmms = printForC dflags handle (pprCmms cmms)++-----------------------------------------------------------------------------++instance (Outputable d, Outputable info, Outputable i)+      => Outputable (GenCmmDecl d info i) where+    ppr t = pprTop t++instance Outputable CmmStatics where+    ppr = pprStatics++instance Outputable CmmStatic where+    ppr = pprStatic++instance Outputable CmmInfoTable where+    ppr = pprInfoTable+++-----------------------------------------------------------------------------++pprCmmGroup :: (Outputable d, Outputable info, Outputable g)+            => GenCmmGroup d info g -> SDoc+pprCmmGroup tops+    = vcat $ intersperse blankLine $ map pprTop tops++-- --------------------------------------------------------------------------+-- Top level `procedure' blocks.+--+pprTop :: (Outputable d, Outputable info, Outputable i)+       => GenCmmDecl d info i -> SDoc++pprTop (CmmProc info lbl live graph)++  = vcat [ ppr lbl <> lparen <> rparen <+> text "// " <+> ppr live+         , nest 8 $ lbrace <+> ppr info $$ rbrace+         , nest 4 $ ppr graph+         , rbrace ]++-- --------------------------------------------------------------------------+-- We follow [1], 4.5+--+--      section "data" { ... }+--+pprTop (CmmData section ds) =+    (hang (pprSection section <+> lbrace) 4 (ppr ds))+    $$ rbrace++-- --------------------------------------------------------------------------+-- Info tables.++pprInfoTable :: CmmInfoTable -> SDoc+pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep+                           , cit_prof = prof_info+                           , cit_srt = _srt })+  = vcat [ text "label:" <+> ppr lbl+         , text "rep:" <> ppr rep+         , case prof_info of+             NoProfilingInfo -> empty+             ProfilingInfo ct cd -> vcat [ text "type:" <+> pprWord8String ct+                                         , text "desc: " <> pprWord8String cd ] ]++instance Outputable C_SRT where+  ppr NoC_SRT = text "_no_srt_"+  ppr (C_SRT label off bitmap)+      = parens (ppr label <> comma <> ppr off <> comma <> ppr bitmap)++instance Outputable ForeignHint where+  ppr NoHint     = empty+  ppr SignedHint = quotes(text "signed")+--  ppr AddrHint   = quotes(text "address")+-- Temp Jan08+  ppr AddrHint   = (text "PtrHint")++-- --------------------------------------------------------------------------+-- Static data.+--      Strings are printed as C strings, and we print them as I8[],+--      following C--+--+pprStatics :: CmmStatics -> SDoc+pprStatics (Statics lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds)++pprStatic :: CmmStatic -> SDoc+pprStatic s = case s of+    CmmStaticLit lit   -> nest 4 $ text "const" <+> pprLit lit <> semi+    CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)+    CmmString s'       -> nest 4 $ text "I8[]" <+> text (show s')++-- --------------------------------------------------------------------------+-- data sections+--+pprSection :: Section -> SDoc+pprSection (Section t suffix) =+  section <+> doubleQuotes (pprSectionType t <+> char '.' <+> ppr suffix)+  where+    section = text "section"++pprSectionType :: SectionType -> SDoc+pprSectionType s = doubleQuotes (ptext t)+ where+  t = case s of+    Text              -> sLit "text"+    Data              -> sLit "data"+    ReadOnlyData      -> sLit "readonly"+    ReadOnlyData16    -> sLit "readonly16"+    RelocatableReadOnlyData+                      -> sLit "relreadonly"+    UninitialisedData -> sLit "uninitialised"+    CString           -> sLit "cstring"+    OtherSection s'   -> sLit s' -- Not actually a literal though.
+ cmm/PprCmmExpr.hs view
@@ -0,0 +1,279 @@+----------------------------------------------------------------------------+--+-- Pretty-printing of common Cmm types+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++--+-- This is where we walk over Cmm emitting an external representation,+-- suitable for parsing, in a syntax strongly reminiscent of C--. This+-- is the "External Core" for the Cmm layer.+--+-- As such, this should be a well-defined syntax: we want it to look nice.+-- Thus, we try wherever possible to use syntax defined in [1],+-- "The C-- Reference Manual", http://www.cminusminus.org/. We differ+-- slightly, in some cases. For one, we use I8 .. I64 for types, rather+-- than C--'s bits8 .. bits64.+--+-- We try to ensure that all information available in the abstract+-- syntax is reproduced, or reproducible, in the concrete syntax.+-- Data that is not in printed out can be reconstructed according to+-- conventions used in the pretty printer. There are at least two such+-- cases:+--      1) if a value has wordRep type, the type is not appended in the+--      output.+--      2) MachOps that operate over wordRep type are printed in a+--      C-style, rather than as their internal MachRep name.+--+-- These conventions produce much more readable Cmm output.+--+-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs+--++{-# OPTIONS_GHC -fno-warn-orphans #-}+module PprCmmExpr+    ( pprExpr, pprLit+    )+where++import CmmExpr++import Outputable++import Data.Maybe+import Numeric ( fromRat )++-----------------------------------------------------------------------------++instance Outputable CmmExpr where+    ppr e = pprExpr e++instance Outputable CmmReg where+    ppr e = pprReg e++instance Outputable CmmLit where+    ppr l = pprLit l++instance Outputable LocalReg where+    ppr e = pprLocalReg e++instance Outputable Area where+    ppr e = pprArea e++instance Outputable GlobalReg where+    ppr e = pprGlobalReg e++-- --------------------------------------------------------------------------+-- Expressions+--++pprExpr :: CmmExpr -> SDoc+pprExpr e+    = sdocWithDynFlags $ \dflags ->+      case e of+        CmmRegOff reg i ->+                pprExpr (CmmMachOp (MO_Add rep)+                           [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])+                where rep = typeWidth (cmmRegType dflags reg)+        CmmLit lit -> pprLit lit+        _other     -> pprExpr1 e++-- Here's the precedence table from CmmParse.y:+-- %nonassoc '>=' '>' '<=' '<' '!=' '=='+-- %left '|'+-- %left '^'+-- %left '&'+-- %left '>>' '<<'+-- %left '-' '+'+-- %left '/' '*' '%'+-- %right '~'++-- We just cope with the common operators for now, the rest will get+-- a default conservative behaviour.++-- %nonassoc '>=' '>' '<=' '<' '!=' '=='+pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc+pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op+   = pprExpr7 x <+> doc <+> pprExpr7 y+pprExpr1 e = pprExpr7 e++infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc++infixMachOp1 (MO_Eq     _) = Just (text "==")+infixMachOp1 (MO_Ne     _) = Just (text "!=")+infixMachOp1 (MO_Shl    _) = Just (text "<<")+infixMachOp1 (MO_U_Shr  _) = Just (text ">>")+infixMachOp1 (MO_U_Ge   _) = Just (text ">=")+infixMachOp1 (MO_U_Le   _) = Just (text "<=")+infixMachOp1 (MO_U_Gt   _) = Just (char '>')+infixMachOp1 (MO_U_Lt   _) = Just (char '<')+infixMachOp1 _             = Nothing++-- %left '-' '+'+pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0+   = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])+pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op+   = pprExpr7 x <+> doc <+> pprExpr8 y+pprExpr7 e = pprExpr8 e++infixMachOp7 (MO_Add _)  = Just (char '+')+infixMachOp7 (MO_Sub _)  = Just (char '-')+infixMachOp7 _           = Nothing++-- %left '/' '*' '%'+pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op+   = pprExpr8 x <+> doc <+> pprExpr9 y+pprExpr8 e = pprExpr9 e++infixMachOp8 (MO_U_Quot _) = Just (char '/')+infixMachOp8 (MO_Mul _)    = Just (char '*')+infixMachOp8 (MO_U_Rem _)  = Just (char '%')+infixMachOp8 _             = Nothing++pprExpr9 :: CmmExpr -> SDoc+pprExpr9 e =+   case e of+        CmmLit    lit       -> pprLit1 lit+        CmmLoad   expr rep  -> ppr rep <> brackets (ppr expr)+        CmmReg    reg       -> ppr reg+        CmmRegOff  reg off  -> parens (ppr reg <+> char '+' <+> int off)+        CmmStackSlot a off  -> parens (ppr a   <+> char '+' <+> int off)+        CmmMachOp mop args  -> genMachOp mop args++genMachOp :: MachOp -> [CmmExpr] -> SDoc+genMachOp mop args+   | Just doc <- infixMachOp mop = case args of+        -- dyadic+        [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y++        -- unary+        [x]   -> doc <> pprExpr9 x++        _     -> pprTrace "PprCmm.genMachOp: machop with strange number of args"+                          (pprMachOp mop <+>+                            parens (hcat $ punctuate comma (map pprExpr args)))+                          empty++   | isJust (infixMachOp1 mop)+   || isJust (infixMachOp7 mop)+   || isJust (infixMachOp8 mop)  = parens (pprExpr (CmmMachOp mop args))++   | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))+        where ppr_op = text (map (\c -> if c == ' ' then '_' else c)+                                 (show mop))+                -- replace spaces in (show mop) with underscores,++--+-- Unsigned ops on the word size of the machine get nice symbols.+-- All else get dumped in their ugly format.+--+infixMachOp :: MachOp -> Maybe SDoc+infixMachOp mop+        = case mop of+            MO_And    _ -> Just $ char '&'+            MO_Or     _ -> Just $ char '|'+            MO_Xor    _ -> Just $ char '^'+            MO_Not    _ -> Just $ char '~'+            MO_S_Neg  _ -> Just $ char '-' -- there is no unsigned neg :)+            _ -> Nothing++-- --------------------------------------------------------------------------+-- Literals.+--  To minimise line noise we adopt the convention that if the literal+--  has the natural machine word size, we do not append the type+--+pprLit :: CmmLit -> SDoc+pprLit lit = sdocWithDynFlags $ \dflags ->+             case lit of+    CmmInt i rep ->+        hcat [ (if i < 0 then parens else id)(integer i)+             , ppUnless (rep == wordWidth dflags) $+               space <> dcolon <+> ppr rep ]++    CmmFloat f rep     -> hsep [ double (fromRat f), dcolon, ppr rep ]+    CmmVec lits        -> char '<' <> commafy (map pprLit lits) <> char '>'+    CmmLabel clbl      -> ppr clbl+    CmmLabelOff clbl i -> ppr clbl <> ppr_offset i+    CmmLabelDiffOff clbl1 clbl2 i -> ppr clbl1 <> char '-'+                                  <> ppr clbl2 <> ppr_offset i+    CmmBlock id        -> ppr id+    CmmHighStackMark -> text "<highSp>"++pprLit1 :: CmmLit -> SDoc+pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)+pprLit1 lit                  = pprLit lit++ppr_offset :: Int -> SDoc+ppr_offset i+    | i==0      = empty+    | i>=0      = char '+' <> int i+    | otherwise = char '-' <> int (-i)++-- --------------------------------------------------------------------------+-- Registers, whether local (temps) or global+--+pprReg :: CmmReg -> SDoc+pprReg r+    = case r of+        CmmLocal  local  -> pprLocalReg  local+        CmmGlobal global -> pprGlobalReg global++--+-- We only print the type of the local reg if it isn't wordRep+--+pprLocalReg :: LocalReg -> SDoc+pprLocalReg (LocalReg uniq rep)+--   = ppr rep <> char '_' <> ppr uniq+-- Temp Jan08+   = char '_' <> ppr uniq <>+       (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08               -- sigh+                    then dcolon <> ptr <> ppr rep+                    else dcolon <> ptr <> ppr rep)+   where+     ptr = empty+         --if isGcPtrType rep+         --      then doubleQuotes (text "ptr")+         --      else empty++-- Stack areas+pprArea :: Area -> SDoc+pprArea Old        = text "old"+pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ]++-- needs to be kept in syn with CmmExpr.hs.GlobalReg+--+pprGlobalReg :: GlobalReg -> SDoc+pprGlobalReg gr+    = case gr of+        VanillaReg n _ -> char 'R' <> int n+-- Temp Jan08+--        VanillaReg n VNonGcPtr -> char 'R' <> int n+--        VanillaReg n VGcPtr    -> char 'P' <> int n+        FloatReg   n   -> char 'F' <> int n+        DoubleReg  n   -> char 'D' <> int n+        LongReg    n   -> char 'L' <> int n+        XmmReg     n   -> text "XMM" <> int n+        YmmReg     n   -> text "YMM" <> int n+        ZmmReg     n   -> text "ZMM" <> int n+        Sp             -> text "Sp"+        SpLim          -> text "SpLim"+        Hp             -> text "Hp"+        HpLim          -> text "HpLim"+        MachSp         -> text "MachSp"+        UnwindReturnReg-> text "UnwindReturnReg"+        CCCS           -> text "CCCS"+        CurrentTSO     -> text "CurrentTSO"+        CurrentNursery -> text "CurrentNursery"+        HpAlloc        -> text "HpAlloc"+        EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info"+        GCEnter1       -> text "stg_gc_enter_1"+        GCFun          -> text "stg_gc_fun"+        BaseReg        -> text "BaseReg"+        PicBaseReg     -> text "PicBaseReg"++-----------------------------------------------------------------------------++commafy :: [SDoc] -> SDoc+commafy xs = fsep $ punctuate comma xs
+ cmm/SMRep.hs view
@@ -0,0 +1,574 @@+-- (c) The University of Glasgow 2006+-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998+--+-- Storage manager representation of closures++{-# LANGUAGE CPP,GeneralizedNewtypeDeriving #-}++module SMRep (+        -- * Words and bytes+        WordOff, ByteOff,+        wordsToBytes, bytesToWordsRoundUp,+        roundUpToWords,++        StgWord, fromStgWord, toStgWord,+        StgHalfWord, fromStgHalfWord, toStgHalfWord,+        hALF_WORD_SIZE, hALF_WORD_SIZE_IN_BITS,++        -- * Closure repesentation+        SMRep(..), -- CmmInfo sees the rep; no one else does+        IsStatic,+        ClosureTypeInfo(..), ArgDescr(..), Liveness,+        ConstrDescription,++        -- ** Construction+        mkHeapRep, blackHoleRep, indStaticRep, mkStackRep, mkRTSRep, arrPtrsRep,+        smallArrPtrsRep, arrWordsRep,++        -- ** Predicates+        isStaticRep, isConRep, isThunkRep, isFunRep, isStaticNoCafCon,+        isStackRep,++        -- ** Size-related things+        heapClosureSizeW,+        fixedHdrSizeW, arrWordsHdrSize, arrWordsHdrSizeW, arrPtrsHdrSize,+        arrPtrsHdrSizeW, profHdrSize, thunkHdrSize, nonHdrSize, nonHdrSizeW,+        smallArrPtrsHdrSize, smallArrPtrsHdrSizeW, hdrSize, hdrSizeW,+        fixedHdrSize,++        -- ** RTS closure types+        rtsClosureType, rET_SMALL, rET_BIG,+        aRG_GEN, aRG_GEN_BIG,++        -- ** Arrays+        card, cardRoundUp, cardTableSizeB, cardTableSizeW,++        -- * Operations over [Word8] strings that don't belong here+        pprWord8String, stringToWord8s+    ) where++#include "../HsVersions.h"+#include "MachDeps.h"++import DynFlags+import Outputable+import Platform+import FastString++import Data.Char( ord )+import Data.Word+import Data.Bits++{-+************************************************************************+*                                                                      *+                Words and bytes+*                                                                      *+************************************************************************+-}++-- | Word offset, or word count+type WordOff = Int++-- | Byte offset, or byte count+type ByteOff = Int++-- | Round up the given byte count to the next byte count that's a+-- multiple of the machine's word size.+roundUpToWords :: DynFlags -> ByteOff -> ByteOff+roundUpToWords dflags n =+  (n + (wORD_SIZE dflags - 1)) .&. (complement (wORD_SIZE dflags - 1))++-- | Convert the given number of words to a number of bytes.+--+-- This function morally has type @WordOff -> ByteOff@, but uses @Num+-- a@ to allow for overloading.+wordsToBytes :: Num a => DynFlags -> a -> a+wordsToBytes dflags n = fromIntegral (wORD_SIZE dflags) * n+{-# SPECIALIZE wordsToBytes :: DynFlags -> Int -> Int #-}+{-# SPECIALIZE wordsToBytes :: DynFlags -> Word -> Word #-}+{-# SPECIALIZE wordsToBytes :: DynFlags -> Integer -> Integer #-}++-- | First round the given byte count up to a multiple of the+-- machine's word size and then convert the result to words.+bytesToWordsRoundUp :: DynFlags -> ByteOff -> WordOff+bytesToWordsRoundUp dflags n = (n + word_size - 1) `quot` word_size+ where word_size = wORD_SIZE dflags+-- StgWord is a type representing an StgWord on the target platform.+-- A Word64 is large enough to hold a Word for either a 32bit or 64bit platform+newtype StgWord = StgWord Word64+    deriving (Eq, Bits)++fromStgWord :: StgWord -> Integer+fromStgWord (StgWord i) = toInteger i++toStgWord :: DynFlags -> Integer -> StgWord+toStgWord dflags i+    = case platformWordSize (targetPlatform dflags) of+      -- These conversions mean that things like toStgWord (-1)+      -- do the right thing+      4 -> StgWord (fromIntegral (fromInteger i :: Word32))+      8 -> StgWord (fromInteger i :: Word64)+      w -> panic ("toStgWord: Unknown platformWordSize: " ++ show w)++instance Outputable StgWord where+    ppr (StgWord i) = integer (toInteger i)++--++-- A Word32 is large enough to hold half a Word for either a 32bit or+-- 64bit platform+newtype StgHalfWord = StgHalfWord Word32+    deriving Eq++fromStgHalfWord :: StgHalfWord -> Integer+fromStgHalfWord (StgHalfWord w) = toInteger w++toStgHalfWord :: DynFlags -> Integer -> StgHalfWord+toStgHalfWord dflags i+    = case platformWordSize (targetPlatform dflags) of+      -- These conversions mean that things like toStgHalfWord (-1)+      -- do the right thing+      4 -> StgHalfWord (fromIntegral (fromInteger i :: Word16))+      8 -> StgHalfWord (fromInteger i :: Word32)+      w -> panic ("toStgHalfWord: Unknown platformWordSize: " ++ show w)++instance Outputable StgHalfWord where+    ppr (StgHalfWord w) = integer (toInteger w)++hALF_WORD_SIZE :: DynFlags -> ByteOff+hALF_WORD_SIZE dflags = platformWordSize (targetPlatform dflags) `shiftR` 1+hALF_WORD_SIZE_IN_BITS :: DynFlags -> Int+hALF_WORD_SIZE_IN_BITS dflags = platformWordSize (targetPlatform dflags) `shiftL` 2++{-+************************************************************************+*                                                                      *+\subsubsection[SMRep-datatype]{@SMRep@---storage manager representation}+*                                                                      *+************************************************************************+-}++-- | A description of the layout of a closure.  Corresponds directly+-- to the closure types in includes/rts/storage/ClosureTypes.h.+data SMRep+  = HeapRep              -- GC routines consult sizes in info tbl+        IsStatic+        !WordOff         --  # ptr words+        !WordOff         --  # non-ptr words INCLUDING SLOP (see mkHeapRep below)+        ClosureTypeInfo  -- type-specific info++  | ArrayPtrsRep+        !WordOff        -- # ptr words+        !WordOff        -- # card table words++  | SmallArrayPtrsRep+        !WordOff        -- # ptr words++  | ArrayWordsRep+        !WordOff        -- # bytes expressed in words, rounded up++  | StackRep            -- Stack frame (RET_SMALL or RET_BIG)+        Liveness++  | RTSRep              -- The RTS needs to declare info tables with specific+        Int             -- type tags, so this form lets us override the default+        SMRep           -- tag for an SMRep.++-- | True <=> This is a static closure.  Affects how we garbage-collect it.+-- Static closure have an extra static link field at the end.+-- Constructors do not have a static variant; see Note [static constructors]+type IsStatic = Bool++-- From an SMRep you can get to the closure type defined in+-- includes/rts/storage/ClosureTypes.h. Described by the function+-- rtsClosureType below.++data ClosureTypeInfo+  = Constr        ConstrTag ConstrDescription+  | Fun           FunArity ArgDescr+  | Thunk+  | ThunkSelector SelectorOffset+  | BlackHole+  | IndStatic++type ConstrTag         = Int+type ConstrDescription = [Word8] -- result of dataConIdentity+type FunArity          = Int+type SelectorOffset    = Int++-------------------------+-- We represent liveness bitmaps as a Bitmap (whose internal+-- representation really is a bitmap).  These are pinned onto case return+-- vectors to indicate the state of the stack for the garbage collector.+--+-- In the compiled program, liveness bitmaps that fit inside a single+-- word (StgWord) are stored as a single word, while larger bitmaps are+-- stored as a pointer to an array of words.++type Liveness = [Bool]   -- One Bool per word; True  <=> non-ptr or dead+                         --                    False <=> ptr++-------------------------+-- An ArgDescr describes the argument pattern of a function++data ArgDescr+  = ArgSpec             -- Fits one of the standard patterns+        !Int            -- RTS type identifier ARG_P, ARG_N, ...++  | ArgGen              -- General case+        Liveness        -- Details about the arguments+++-----------------------------------------------------------------------------+-- Construction++mkHeapRep :: DynFlags -> IsStatic -> WordOff -> WordOff -> ClosureTypeInfo+          -> SMRep+mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type_info+  = HeapRep is_static+            ptr_wds+            (nonptr_wds + slop_wds)+            cl_type_info+  where+     slop_wds+      | is_static = 0+      | otherwise = max 0 (minClosureSize dflags - (hdr_size + payload_size))++     hdr_size     = closureTypeHdrSize dflags cl_type_info+     payload_size = ptr_wds + nonptr_wds++mkRTSRep :: Int -> SMRep -> SMRep+mkRTSRep = RTSRep++mkStackRep :: [Bool] -> SMRep+mkStackRep liveness = StackRep liveness++blackHoleRep :: SMRep+blackHoleRep = HeapRep False 0 0 BlackHole++indStaticRep :: SMRep+indStaticRep = HeapRep True 1 0 IndStatic++arrPtrsRep :: DynFlags -> WordOff -> SMRep+arrPtrsRep dflags elems = ArrayPtrsRep elems (cardTableSizeW dflags elems)++smallArrPtrsRep :: WordOff -> SMRep+smallArrPtrsRep elems = SmallArrayPtrsRep elems++arrWordsRep :: DynFlags -> ByteOff -> SMRep+arrWordsRep dflags bytes = ArrayWordsRep (bytesToWordsRoundUp dflags bytes)++-----------------------------------------------------------------------------+-- Predicates++isStaticRep :: SMRep -> IsStatic+isStaticRep (HeapRep is_static _ _ _) = is_static+isStaticRep (RTSRep _ rep)            = isStaticRep rep+isStaticRep _                         = False++isStackRep :: SMRep -> Bool+isStackRep StackRep{}     = True+isStackRep (RTSRep _ rep) = isStackRep rep+isStackRep _              = False++isConRep :: SMRep -> Bool+isConRep (HeapRep _ _ _ Constr{}) = True+isConRep _                        = False++isThunkRep :: SMRep -> Bool+isThunkRep (HeapRep _ _ _ Thunk{})         = True+isThunkRep (HeapRep _ _ _ ThunkSelector{}) = True+isThunkRep (HeapRep _ _ _ BlackHole{})     = True+isThunkRep (HeapRep _ _ _ IndStatic{})     = True+isThunkRep _                               = False++isFunRep :: SMRep -> Bool+isFunRep (HeapRep _ _ _ Fun{}) = True+isFunRep _                     = False++isStaticNoCafCon :: SMRep -> Bool+-- This should line up exactly with CONSTR_NOCAF below+-- See Note [Static NoCaf constructors]+isStaticNoCafCon (HeapRep _ 0 _ Constr{}) = True+isStaticNoCafCon _                        = False+++-----------------------------------------------------------------------------+-- Size-related things++fixedHdrSize :: DynFlags -> ByteOff+fixedHdrSize dflags = wordsToBytes dflags (fixedHdrSizeW dflags)++-- | Size of a closure header (StgHeader in includes/rts/storage/Closures.h)+fixedHdrSizeW :: DynFlags -> WordOff+fixedHdrSizeW dflags = sTD_HDR_SIZE dflags + profHdrSize dflags++-- | Size of the profiling part of a closure header+-- (StgProfHeader in includes/rts/storage/Closures.h)+profHdrSize  :: DynFlags -> WordOff+profHdrSize dflags+ | gopt Opt_SccProfilingOn dflags = pROF_HDR_SIZE dflags+ | otherwise                      = 0++-- | The garbage collector requires that every closure is at least as+--   big as this.+minClosureSize :: DynFlags -> WordOff+minClosureSize dflags = fixedHdrSizeW dflags + mIN_PAYLOAD_SIZE dflags++arrWordsHdrSize :: DynFlags -> ByteOff+arrWordsHdrSize dflags+ = fixedHdrSize dflags + sIZEOF_StgArrBytes_NoHdr dflags++arrWordsHdrSizeW :: DynFlags -> WordOff+arrWordsHdrSizeW dflags =+    fixedHdrSizeW dflags ++    (sIZEOF_StgArrBytes_NoHdr dflags `quot` wORD_SIZE dflags)++arrPtrsHdrSize :: DynFlags -> ByteOff+arrPtrsHdrSize dflags+ = fixedHdrSize dflags + sIZEOF_StgMutArrPtrs_NoHdr dflags++arrPtrsHdrSizeW :: DynFlags -> WordOff+arrPtrsHdrSizeW dflags =+    fixedHdrSizeW dflags ++    (sIZEOF_StgMutArrPtrs_NoHdr dflags `quot` wORD_SIZE dflags)++smallArrPtrsHdrSize :: DynFlags -> ByteOff+smallArrPtrsHdrSize dflags+ = fixedHdrSize dflags + sIZEOF_StgSmallMutArrPtrs_NoHdr dflags++smallArrPtrsHdrSizeW :: DynFlags -> WordOff+smallArrPtrsHdrSizeW dflags =+    fixedHdrSizeW dflags ++    (sIZEOF_StgSmallMutArrPtrs_NoHdr dflags `quot` wORD_SIZE dflags)++-- Thunks have an extra header word on SMP, so the update doesn't+-- splat the payload.+thunkHdrSize :: DynFlags -> WordOff+thunkHdrSize dflags = fixedHdrSizeW dflags + smp_hdr+        where smp_hdr = sIZEOF_StgSMPThunkHeader dflags `quot` wORD_SIZE dflags++hdrSize :: DynFlags -> SMRep -> ByteOff+hdrSize dflags rep = wordsToBytes dflags (hdrSizeW dflags rep)++hdrSizeW :: DynFlags -> SMRep -> WordOff+hdrSizeW dflags (HeapRep _ _ _ ty)    = closureTypeHdrSize dflags ty+hdrSizeW dflags (ArrayPtrsRep _ _)    = arrPtrsHdrSizeW dflags+hdrSizeW dflags (SmallArrayPtrsRep _) = smallArrPtrsHdrSizeW dflags+hdrSizeW dflags (ArrayWordsRep _)     = arrWordsHdrSizeW dflags+hdrSizeW _ _                          = panic "SMRep.hdrSizeW"++nonHdrSize :: DynFlags -> SMRep -> ByteOff+nonHdrSize dflags rep = wordsToBytes dflags (nonHdrSizeW rep)++nonHdrSizeW :: SMRep -> WordOff+nonHdrSizeW (HeapRep _ p np _) = p + np+nonHdrSizeW (ArrayPtrsRep elems ct) = elems + ct+nonHdrSizeW (SmallArrayPtrsRep elems) = elems+nonHdrSizeW (ArrayWordsRep words) = words+nonHdrSizeW (StackRep bs)      = length bs+nonHdrSizeW (RTSRep _ rep)     = nonHdrSizeW rep++-- | The total size of the closure, in words.+heapClosureSizeW :: DynFlags -> SMRep -> WordOff+heapClosureSizeW dflags (HeapRep _ p np ty)+ = closureTypeHdrSize dflags ty + p + np+heapClosureSizeW dflags (ArrayPtrsRep elems ct)+ = arrPtrsHdrSizeW dflags + elems + ct+heapClosureSizeW dflags (SmallArrayPtrsRep elems)+ = smallArrPtrsHdrSizeW dflags + elems+heapClosureSizeW dflags (ArrayWordsRep words)+ = arrWordsHdrSizeW dflags + words+heapClosureSizeW _ _ = panic "SMRep.heapClosureSize"++closureTypeHdrSize :: DynFlags -> ClosureTypeInfo -> WordOff+closureTypeHdrSize dflags ty = case ty of+                  Thunk{}         -> thunkHdrSize dflags+                  ThunkSelector{} -> thunkHdrSize dflags+                  BlackHole{}     -> thunkHdrSize dflags+                  IndStatic{}     -> thunkHdrSize dflags+                  _               -> fixedHdrSizeW dflags+        -- All thunks use thunkHdrSize, even if they are non-updatable.+        -- this is because we don't have separate closure types for+        -- updatable vs. non-updatable thunks, so the GC can't tell the+        -- difference.  If we ever have significant numbers of non-+        -- updatable thunks, it might be worth fixing this.++-- ---------------------------------------------------------------------------+-- Arrays++-- | The byte offset into the card table of the card for a given element+card :: DynFlags -> Int -> Int+card dflags i = i `shiftR` mUT_ARR_PTRS_CARD_BITS dflags++-- | Convert a number of elements to a number of cards, rounding up+cardRoundUp :: DynFlags -> Int -> Int+cardRoundUp dflags i =+  card dflags (i + ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS dflags) - 1))++-- | The size of a card table, in bytes+cardTableSizeB :: DynFlags -> Int -> ByteOff+cardTableSizeB dflags elems = cardRoundUp dflags elems++-- | The size of a card table, in words+cardTableSizeW :: DynFlags -> Int -> WordOff+cardTableSizeW dflags elems =+  bytesToWordsRoundUp dflags (cardTableSizeB dflags elems)++-----------------------------------------------------------------------------+-- deriving the RTS closure type from an SMRep++#include "rts/storage/ClosureTypes.h"+#include "rts/storage/FunTypes.h"+-- Defines CONSTR, CONSTR_1_0 etc++-- | Derives the RTS closure type from an 'SMRep'+rtsClosureType :: SMRep -> Int+rtsClosureType rep+    = case rep of+      RTSRep ty _ -> ty++      -- See Note [static constructors]+      HeapRep _     1 0 Constr{} -> CONSTR_1_0+      HeapRep _     0 1 Constr{} -> CONSTR_0_1+      HeapRep _     2 0 Constr{} -> CONSTR_2_0+      HeapRep _     1 1 Constr{} -> CONSTR_1_1+      HeapRep _     0 2 Constr{} -> CONSTR_0_2+      HeapRep _     0 _ Constr{} -> CONSTR_NOCAF+           -- See Note [Static NoCaf constructors]+      HeapRep _     _ _ Constr{} -> CONSTR++      HeapRep False 1 0 Fun{} -> FUN_1_0+      HeapRep False 0 1 Fun{} -> FUN_0_1+      HeapRep False 2 0 Fun{} -> FUN_2_0+      HeapRep False 1 1 Fun{} -> FUN_1_1+      HeapRep False 0 2 Fun{} -> FUN_0_2+      HeapRep False _ _ Fun{} -> FUN++      HeapRep False 1 0 Thunk{} -> THUNK_1_0+      HeapRep False 0 1 Thunk{} -> THUNK_0_1+      HeapRep False 2 0 Thunk{} -> THUNK_2_0+      HeapRep False 1 1 Thunk{} -> THUNK_1_1+      HeapRep False 0 2 Thunk{} -> THUNK_0_2+      HeapRep False _ _ Thunk{} -> THUNK++      HeapRep False _ _ ThunkSelector{} ->  THUNK_SELECTOR++      HeapRep True _ _ Fun{}    -> FUN_STATIC+      HeapRep True _ _ Thunk{}  -> THUNK_STATIC++      HeapRep False _ _ BlackHole{} -> BLACKHOLE++      HeapRep False _ _ IndStatic{} -> IND_STATIC++      _ -> panic "rtsClosureType"++-- We export these ones+rET_SMALL, rET_BIG, aRG_GEN, aRG_GEN_BIG :: Int+rET_SMALL   = RET_SMALL+rET_BIG     = RET_BIG+aRG_GEN     = ARG_GEN+aRG_GEN_BIG = ARG_GEN_BIG++{-+Note [static constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~++We used to have a CONSTR_STATIC closure type, and each constructor had+two info tables: one with CONSTR (or CONSTR_1_0 etc.), and one with+CONSTR_STATIC.++This distinction was removed, because when copying a data structure+into a compact region, we must copy static constructors into the+compact region too.  If we didn't do this, we would need to track the+references from the compact region out to the static constructors,+because they might (indirectly) refer to CAFs.++Since static constructors will be copied to the heap, if we wanted to+use different info tables for static and dynamic constructors, we+would have to switch the info pointer when copying the constructor+into the compact region, which means we would need an extra field of+the static info table to point to the dynamic one.++However, since the distinction between static and dynamic closure+types is never actually needed (other than for assertions), we can+just drop the distinction and use the same info table for both.++The GC *does* need to distinguish between static and dynamic closures,+but it does this using the HEAP_ALLOCED() macro which checks whether+the address of the closure resides within the dynamic heap.+HEAP_ALLOCED() doesn't read the closure's info table.++Note [Static NoCaf constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we know that a top-level binding 'x' is not Caffy (ie no CAFs are+reachable from 'x'), then a statically allocated constructor (Just x)+is also not Caffy, and the garbage collector need not follow its+argument fields.  Exploiting this would require two static info tables+for Just, for the two cases where the argument was Caffy or non-Caffy.++Currently we don't do this; instead we treat nullary constructors+as non-Caffy, and the others as potentially Caffy.+++************************************************************************+*                                                                      *+             Pretty printing of SMRep and friends+*                                                                      *+************************************************************************+-}++instance Outputable ClosureTypeInfo where+   ppr = pprTypeInfo++instance Outputable SMRep where+   ppr (HeapRep static ps nps tyinfo)+     = hang (header <+> lbrace) 2 (ppr tyinfo <+> rbrace)+     where+       header = text "HeapRep"+                <+> if static then text "static" else empty+                <+> pp_n "ptrs" ps <+> pp_n "nonptrs" nps+       pp_n :: String -> Int -> SDoc+       pp_n _ 0 = empty+       pp_n s n = int n <+> text s++   ppr (ArrayPtrsRep size _) = text "ArrayPtrsRep" <+> ppr size++   ppr (SmallArrayPtrsRep size) = text "SmallArrayPtrsRep" <+> ppr size++   ppr (ArrayWordsRep words) = text "ArrayWordsRep" <+> ppr words++   ppr (StackRep bs) = text "StackRep" <+> ppr bs++   ppr (RTSRep ty rep) = text "tag:" <> ppr ty <+> ppr rep++instance Outputable ArgDescr where+  ppr (ArgSpec n) = text "ArgSpec" <+> ppr n+  ppr (ArgGen ls) = text "ArgGen" <+> ppr ls++pprTypeInfo :: ClosureTypeInfo -> SDoc+pprTypeInfo (Constr tag descr)+  = text "Con" <+>+    braces (sep [ text "tag:" <+> ppr tag+                , text "descr:" <> text (show descr) ])++pprTypeInfo (Fun arity args)+  = text "Fun" <+>+    braces (sep [ text "arity:" <+> ppr arity+                , ptext (sLit ("fun_type:")) <+> ppr args ])++pprTypeInfo (ThunkSelector offset)+  = text "ThunkSel" <+> ppr offset++pprTypeInfo Thunk     = text "Thunk"+pprTypeInfo BlackHole = text "BlackHole"+pprTypeInfo IndStatic = text "IndStatic"++-- XXX Does not belong here!!+stringToWord8s :: String -> [Word8]+stringToWord8s s = map (fromIntegral . ord) s++pprWord8String :: [Word8] -> SDoc+-- Debug printing.  Not very clever right now.+pprWord8String ws = text (show ws)
+ codeGen/CgUtils.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE CPP, GADTs #-}++-----------------------------------------------------------------------------+--+-- Code generator utilities; mostly monadic+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module CgUtils ( fixStgRegisters ) where++#include "HsVersions.h"++import CodeGen.Platform+import Cmm+import Hoopl+import CmmUtils+import CLabel+import DynFlags+import Outputable++-- -----------------------------------------------------------------------------+-- Information about global registers++baseRegOffset :: DynFlags -> GlobalReg -> Int++baseRegOffset dflags (VanillaReg 1 _)    = oFFSET_StgRegTable_rR1 dflags+baseRegOffset dflags (VanillaReg 2 _)    = oFFSET_StgRegTable_rR2 dflags+baseRegOffset dflags (VanillaReg 3 _)    = oFFSET_StgRegTable_rR3 dflags+baseRegOffset dflags (VanillaReg 4 _)    = oFFSET_StgRegTable_rR4 dflags+baseRegOffset dflags (VanillaReg 5 _)    = oFFSET_StgRegTable_rR5 dflags+baseRegOffset dflags (VanillaReg 6 _)    = oFFSET_StgRegTable_rR6 dflags+baseRegOffset dflags (VanillaReg 7 _)    = oFFSET_StgRegTable_rR7 dflags+baseRegOffset dflags (VanillaReg 8 _)    = oFFSET_StgRegTable_rR8 dflags+baseRegOffset dflags (VanillaReg 9 _)    = oFFSET_StgRegTable_rR9 dflags+baseRegOffset dflags (VanillaReg 10 _)   = oFFSET_StgRegTable_rR10 dflags+baseRegOffset _      (VanillaReg n _)    = panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")")+baseRegOffset dflags (FloatReg  1)       = oFFSET_StgRegTable_rF1 dflags+baseRegOffset dflags (FloatReg  2)       = oFFSET_StgRegTable_rF2 dflags+baseRegOffset dflags (FloatReg  3)       = oFFSET_StgRegTable_rF3 dflags+baseRegOffset dflags (FloatReg  4)       = oFFSET_StgRegTable_rF4 dflags+baseRegOffset dflags (FloatReg  5)       = oFFSET_StgRegTable_rF5 dflags+baseRegOffset dflags (FloatReg  6)       = oFFSET_StgRegTable_rF6 dflags+baseRegOffset _      (FloatReg  n)       = panic ("Registers above F6 are not supported (tried to use F" ++ show n ++ ")")+baseRegOffset dflags (DoubleReg 1)       = oFFSET_StgRegTable_rD1 dflags+baseRegOffset dflags (DoubleReg 2)       = oFFSET_StgRegTable_rD2 dflags+baseRegOffset dflags (DoubleReg 3)       = oFFSET_StgRegTable_rD3 dflags+baseRegOffset dflags (DoubleReg 4)       = oFFSET_StgRegTable_rD4 dflags+baseRegOffset dflags (DoubleReg 5)       = oFFSET_StgRegTable_rD5 dflags+baseRegOffset dflags (DoubleReg 6)       = oFFSET_StgRegTable_rD6 dflags+baseRegOffset _      (DoubleReg n)       = panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")")+baseRegOffset dflags (XmmReg 1)          = oFFSET_StgRegTable_rXMM1 dflags+baseRegOffset dflags (XmmReg 2)          = oFFSET_StgRegTable_rXMM2 dflags+baseRegOffset dflags (XmmReg 3)          = oFFSET_StgRegTable_rXMM3 dflags+baseRegOffset dflags (XmmReg 4)          = oFFSET_StgRegTable_rXMM4 dflags+baseRegOffset dflags (XmmReg 5)          = oFFSET_StgRegTable_rXMM5 dflags+baseRegOffset dflags (XmmReg 6)          = oFFSET_StgRegTable_rXMM6 dflags+baseRegOffset _      (XmmReg n)          = panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")")+baseRegOffset dflags (YmmReg 1)          = oFFSET_StgRegTable_rYMM1 dflags+baseRegOffset dflags (YmmReg 2)          = oFFSET_StgRegTable_rYMM2 dflags+baseRegOffset dflags (YmmReg 3)          = oFFSET_StgRegTable_rYMM3 dflags+baseRegOffset dflags (YmmReg 4)          = oFFSET_StgRegTable_rYMM4 dflags+baseRegOffset dflags (YmmReg 5)          = oFFSET_StgRegTable_rYMM5 dflags+baseRegOffset dflags (YmmReg 6)          = oFFSET_StgRegTable_rYMM6 dflags+baseRegOffset _      (YmmReg n)          = panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")")+baseRegOffset dflags (ZmmReg 1)          = oFFSET_StgRegTable_rZMM1 dflags+baseRegOffset dflags (ZmmReg 2)          = oFFSET_StgRegTable_rZMM2 dflags+baseRegOffset dflags (ZmmReg 3)          = oFFSET_StgRegTable_rZMM3 dflags+baseRegOffset dflags (ZmmReg 4)          = oFFSET_StgRegTable_rZMM4 dflags+baseRegOffset dflags (ZmmReg 5)          = oFFSET_StgRegTable_rZMM5 dflags+baseRegOffset dflags (ZmmReg 6)          = oFFSET_StgRegTable_rZMM6 dflags+baseRegOffset _      (ZmmReg n)          = panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")")+baseRegOffset dflags Sp                  = oFFSET_StgRegTable_rSp dflags+baseRegOffset dflags SpLim               = oFFSET_StgRegTable_rSpLim dflags+baseRegOffset dflags (LongReg 1)         = oFFSET_StgRegTable_rL1 dflags+baseRegOffset _      (LongReg n)         = panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")")+baseRegOffset dflags Hp                  = oFFSET_StgRegTable_rHp dflags+baseRegOffset dflags HpLim               = oFFSET_StgRegTable_rHpLim dflags+baseRegOffset dflags CCCS                = oFFSET_StgRegTable_rCCCS dflags+baseRegOffset dflags CurrentTSO          = oFFSET_StgRegTable_rCurrentTSO dflags+baseRegOffset dflags CurrentNursery      = oFFSET_StgRegTable_rCurrentNursery dflags+baseRegOffset dflags HpAlloc             = oFFSET_StgRegTable_rHpAlloc dflags+baseRegOffset dflags EagerBlackholeInfo  = oFFSET_stgEagerBlackholeInfo dflags+baseRegOffset dflags GCEnter1            = oFFSET_stgGCEnter1 dflags+baseRegOffset dflags GCFun               = oFFSET_stgGCFun dflags+baseRegOffset _      BaseReg             = panic "CgUtils.baseRegOffset:BaseReg"+baseRegOffset _      PicBaseReg          = panic "CgUtils.baseRegOffset:PicBaseReg"+baseRegOffset _      MachSp              = panic "CgUtils.baseRegOffset:MachSp"+baseRegOffset _      UnwindReturnReg     = panic "CgUtils.baseRegOffset:UnwindReturnReg"+++-- -----------------------------------------------------------------------------+--+-- STG/Cmm GlobalReg+--+-- -----------------------------------------------------------------------------++-- | We map STG registers onto appropriate CmmExprs.  Either they map+-- to real machine registers or stored as offsets from BaseReg.  Given+-- a GlobalReg, get_GlobalReg_addr always produces the+-- register table address for it.+get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr+get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0+get_GlobalReg_addr dflags mid+    = get_Regtable_addr_from_offset dflags+                                    (globalRegType dflags mid) (baseRegOffset dflags mid)++-- Calculate a literal representing an offset into the register table.+-- Used when we don't have an actual BaseReg to offset from.+regTableOffset :: DynFlags -> Int -> CmmExpr+regTableOffset dflags n =+  CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n))++get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr+get_Regtable_addr_from_offset dflags _ offset =+    if haveRegBase (targetPlatform dflags)+    then CmmRegOff (CmmGlobal BaseReg) offset+    else regTableOffset dflags offset++-- | Fixup global registers so that they assign to locations within the+-- RegTable if they aren't pinned for the current target.+fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl+fixStgRegisters _ top@(CmmData _ _) = top++fixStgRegisters dflags (CmmProc info lbl live graph) =+  let graph' = modifyGraph (mapGraphBlocks (fixStgRegBlock dflags)) graph+  in CmmProc info lbl live graph'++fixStgRegBlock :: DynFlags -> Block CmmNode e x -> Block CmmNode e x+fixStgRegBlock dflags block = mapBlock (fixStgRegStmt dflags) block++fixStgRegStmt :: DynFlags -> CmmNode e x -> CmmNode e x+fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt+  where+    platform = targetPlatform dflags++    fixAssign stmt =+      case stmt of+        CmmAssign (CmmGlobal reg) src+          -- MachSp isn't an STG register; it's merely here for tracking unwind+          -- information+          | reg == MachSp -> stmt+          | otherwise ->+            let baseAddr = get_GlobalReg_addr dflags reg+            in case reg `elem` activeStgRegs (targetPlatform dflags) of+                True  -> CmmAssign (CmmGlobal reg) src+                False -> CmmStore baseAddr src+        other_stmt -> other_stmt++    fixExpr expr = case expr of+        -- MachSp isn't an STG; it's merely here for tracking unwind information+        CmmReg (CmmGlobal MachSp) -> expr+        CmmReg (CmmGlobal reg) ->+            -- Replace register leaves with appropriate StixTrees for+            -- the given target.  MagicIds which map to a reg on this+            -- arch are left unchanged.  For the rest, BaseReg is taken+            -- to mean the address of the reg table in MainCapability,+            -- and for all others we generate an indirection to its+            -- location in the register table.+            case reg `elem` activeStgRegs platform of+                True  -> expr+                False ->+                    let baseAddr = get_GlobalReg_addr dflags reg+                    in case reg of+                        BaseReg -> baseAddr+                        _other  -> CmmLoad baseAddr (globalRegType dflags reg)++        CmmRegOff (CmmGlobal reg) offset ->+            -- RegOf leaves are just a shorthand form. If the reg maps+            -- to a real reg, we keep the shorthand, otherwise, we just+            -- expand it and defer to the above code.+            case reg `elem` activeStgRegs platform of+                True  -> expr+                False -> CmmMachOp (MO_Add (wordWidth dflags)) [+                                    fixExpr (CmmReg (CmmGlobal reg)),+                                    CmmLit (CmmInt (fromIntegral offset)+                                                   (wordWidth dflags))]++        other_expr -> other_expr+
+ codeGen/CodeGen/Platform.hs view
@@ -0,0 +1,116 @@++module CodeGen.Platform+       (callerSaves, activeStgRegs, haveRegBase, globalRegMaybe, freeReg)+       where++import CmmExpr+import Platform+import Reg++import qualified CodeGen.Platform.ARM        as ARM+import qualified CodeGen.Platform.ARM64      as ARM64+import qualified CodeGen.Platform.PPC        as PPC+import qualified CodeGen.Platform.PPC_Darwin as PPC_Darwin+import qualified CodeGen.Platform.SPARC      as SPARC+import qualified CodeGen.Platform.X86        as X86+import qualified CodeGen.Platform.X86_64     as X86_64+import qualified CodeGen.Platform.NoRegs     as NoRegs++-- | Returns 'True' if this global register is stored in a caller-saves+-- machine register.++callerSaves :: Platform -> GlobalReg -> Bool+callerSaves platform+ | platformUnregisterised platform = NoRegs.callerSaves+ | otherwise+ = case platformArch platform of+   ArchX86    -> X86.callerSaves+   ArchX86_64 -> X86_64.callerSaves+   ArchSPARC  -> SPARC.callerSaves+   ArchARM {} -> ARM.callerSaves+   ArchARM64  -> ARM64.callerSaves+   arch+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->+       case platformOS platform of+       OSDarwin -> PPC_Darwin.callerSaves+       _        -> PPC.callerSaves++    | otherwise -> NoRegs.callerSaves++-- | Here is where the STG register map is defined for each target arch.+-- The order matters (for the llvm backend anyway)! We must make sure to+-- maintain the order here with the order used in the LLVM calling conventions.+-- Note that also, this isn't all registers, just the ones that are currently+-- possbily mapped to real registers.+activeStgRegs :: Platform -> [GlobalReg]+activeStgRegs platform+ | platformUnregisterised platform = NoRegs.activeStgRegs+ | otherwise+ = case platformArch platform of+   ArchX86    -> X86.activeStgRegs+   ArchX86_64 -> X86_64.activeStgRegs+   ArchSPARC  -> SPARC.activeStgRegs+   ArchARM {} -> ARM.activeStgRegs+   ArchARM64  -> ARM64.activeStgRegs+   arch+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->+       case platformOS platform of+       OSDarwin -> PPC_Darwin.activeStgRegs+       _        -> PPC.activeStgRegs++    | otherwise -> NoRegs.activeStgRegs++haveRegBase :: Platform -> Bool+haveRegBase platform+ | platformUnregisterised platform = NoRegs.haveRegBase+ | otherwise+ = case platformArch platform of+   ArchX86    -> X86.haveRegBase+   ArchX86_64 -> X86_64.haveRegBase+   ArchSPARC  -> SPARC.haveRegBase+   ArchARM {} -> ARM.haveRegBase+   ArchARM64  -> ARM64.haveRegBase+   arch+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->+       case platformOS platform of+       OSDarwin -> PPC_Darwin.haveRegBase+       _        -> PPC.haveRegBase++    | otherwise -> NoRegs.haveRegBase++globalRegMaybe :: Platform -> GlobalReg -> Maybe RealReg+globalRegMaybe platform+ | platformUnregisterised platform = NoRegs.globalRegMaybe+ | otherwise+ = case platformArch platform of+   ArchX86    -> X86.globalRegMaybe+   ArchX86_64 -> X86_64.globalRegMaybe+   ArchSPARC  -> SPARC.globalRegMaybe+   ArchARM {} -> ARM.globalRegMaybe+   ArchARM64  -> ARM64.globalRegMaybe+   arch+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->+       case platformOS platform of+       OSDarwin -> PPC_Darwin.globalRegMaybe+       _        -> PPC.globalRegMaybe++    | otherwise -> NoRegs.globalRegMaybe++freeReg :: Platform -> RegNo -> Bool+freeReg platform+ | platformUnregisterised platform = NoRegs.freeReg+ | otherwise+ = case platformArch platform of+   ArchX86    -> X86.freeReg+   ArchX86_64 -> X86_64.freeReg+   ArchSPARC  -> SPARC.freeReg+   ArchARM {} -> ARM.freeReg+   ArchARM64  -> ARM64.freeReg+   arch+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->+       case platformOS platform of+       OSDarwin -> PPC_Darwin.freeReg+       _        -> PPC.freeReg++    | otherwise -> NoRegs.freeReg+
+ codeGen/CodeGen/Platform/ARM.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE CPP #-}++module CodeGen.Platform.ARM where++#define MACHREGS_NO_REGS 0+#define MACHREGS_arm 1+#include "CodeGen.Platform.hs"+
+ codeGen/CodeGen/Platform/ARM64.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE CPP #-}++module CodeGen.Platform.ARM64 where++#define MACHREGS_NO_REGS 0+#define MACHREGS_aarch64 1+#include "CodeGen.Platform.hs"+
+ codeGen/CodeGen/Platform/NoRegs.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE CPP #-}++module CodeGen.Platform.NoRegs where++#define MACHREGS_NO_REGS 1+#include "CodeGen.Platform.hs"+
+ codeGen/CodeGen/Platform/PPC.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE CPP #-}++module CodeGen.Platform.PPC where++#define MACHREGS_NO_REGS 0+#define MACHREGS_powerpc 1+#include "CodeGen.Platform.hs"+
+ codeGen/CodeGen/Platform/PPC_Darwin.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE CPP #-}++module CodeGen.Platform.PPC_Darwin where++#define MACHREGS_NO_REGS 0+#define MACHREGS_powerpc 1+#define MACHREGS_darwin 1+#include "CodeGen.Platform.hs"+
+ codeGen/CodeGen/Platform/SPARC.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE CPP #-}++module CodeGen.Platform.SPARC where++#define MACHREGS_NO_REGS 0+#define MACHREGS_sparc 1+#include "CodeGen.Platform.hs"+
+ codeGen/CodeGen/Platform/X86.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE CPP #-}++module CodeGen.Platform.X86 where++#define MACHREGS_NO_REGS 0+#define MACHREGS_i386 1+#include "CodeGen.Platform.hs"+
+ codeGen/CodeGen/Platform/X86_64.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE CPP #-}++module CodeGen.Platform.X86_64 where++#define MACHREGS_NO_REGS 0+#define MACHREGS_x86_64 1+#include "CodeGen.Platform.hs"+
+ codeGen/StgCmm.hs view
@@ -0,0 +1,284 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Stg to C-- code generation+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module StgCmm ( codeGen ) where++#include "HsVersions.h"++import StgCmmProf (initCostCentres, ldvEnter)+import StgCmmMonad+import StgCmmEnv+import StgCmmBind+import StgCmmCon+import StgCmmLayout+import StgCmmUtils+import StgCmmClosure+import StgCmmHpc+import StgCmmTicky++import Cmm+import CmmUtils+import CLabel++import StgSyn+import DynFlags++import HscTypes+import CostCentre+import Id+import IdInfo+import RepType+import DataCon+import Name+import TyCon+import Module+import Outputable+import Stream+import BasicTypes++import OrdList+import MkGraph++import qualified Data.ByteString as BS+import Data.IORef+import Control.Monad (when,void)+import Util++codeGen :: DynFlags+        -> Module+        -> [TyCon]+        -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.+        -> [StgTopBinding]             -- Bindings to convert+        -> HpcInfo+        -> Stream IO CmmGroup ()       -- Output as a stream, so codegen can+                                        -- be interleaved with output++codeGen dflags this_mod data_tycons+        cost_centre_info stg_binds hpc_info+  = do  {     -- cg: run the code generator, and yield the resulting CmmGroup+              -- Using an IORef to store the state is a bit crude, but otherwise+              -- we would need to add a state monad layer.+        ; cgref <- liftIO $ newIORef =<< initC+        ; let cg :: FCode () -> Stream IO CmmGroup ()+              cg fcode = do+                cmm <- liftIO $ do+                         st <- readIORef cgref+                         let (a,st') = runC dflags this_mod st (getCmm fcode)++                         -- NB. stub-out cgs_tops and cgs_stmts.  This fixes+                         -- a big space leak.  DO NOT REMOVE!+                         writeIORef cgref $! st'{ cgs_tops = nilOL,+                                                  cgs_stmts = mkNop }+                         return a+                yield cmm++               -- Note [codegen-split-init] the cmm_init block must come+               -- FIRST.  This is because when -split-objs is on we need to+               -- combine this block with its initialisation routines; see+               -- Note [pipeline-split-init].+        ; cg (mkModuleInit cost_centre_info this_mod hpc_info)++        ; mapM_ (cg . cgTopBinding dflags) stg_binds++                -- Put datatype_stuff after code_stuff, because the+                -- datatype closure table (for enumeration types) to+                -- (say) PrelBase_True_closure, which is defined in+                -- code_stuff+        ; let do_tycon tycon = do+                -- Generate a table of static closures for an+                -- enumeration type Note that the closure pointers are+                -- tagged.+                 when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon)+                 mapM_ (cg . cgDataCon) (tyConDataCons tycon)++        ; mapM_ do_tycon data_tycons+        }++---------------------------------------------------------------+--      Top-level bindings+---------------------------------------------------------------++{- 'cgTopBinding' is only used for top-level bindings, since they need+to be allocated statically (not in the heap) and need to be labelled.+No unboxed bindings can happen at top level.++In the code below, the static bindings are accumulated in the+@MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.+This is so that we can write the top level processing in a compositional+style, with the increasing static environment being plumbed as a state+variable. -}++cgTopBinding :: DynFlags -> StgTopBinding -> FCode ()+cgTopBinding dflags (StgTopLifted (StgNonRec id rhs))+  = do  { id' <- maybeExternaliseId dflags id+        ; let (info, fcode) = cgTopRhs dflags NonRecursive id' rhs+        ; fcode+        ; addBindC info -- Add the *un-externalised* Id to the envt,+                        -- so we find it when we look up occurrences+        }++cgTopBinding dflags (StgTopLifted (StgRec pairs))+  = do  { let (bndrs, rhss) = unzip pairs+        ; bndrs' <- Prelude.mapM (maybeExternaliseId dflags) bndrs+        ; let pairs' = zip bndrs' rhss+              r = unzipWith (cgTopRhs dflags Recursive) pairs'+              (infos, fcodes) = unzip r+        ; addBindsC infos+        ; sequence_ fcodes+        }++cgTopBinding dflags (StgTopStringLit id str)+  = do  { id' <- maybeExternaliseId dflags id+        ; let label = mkBytesLabel (idName id')+        ; let (lit, decl) = mkByteStringCLit label (BS.unpack str)+        ; emitDecl decl+        ; addBindC (litIdInfo dflags id' mkLFStringLit lit)+        }++cgTopRhs :: DynFlags -> RecFlag -> Id -> StgRhs -> (CgIdInfo, FCode ())+        -- The Id is passed along for setting up a binding...+        -- It's already been externalised if necessary++cgTopRhs dflags _rec bndr (StgRhsCon _cc con args)+  = cgTopRhsCon dflags bndr con (assertNonVoidStgArgs args)+      -- con args are always non-void,+      -- see Note [Post-unarisation invariants] in UnariseStg++cgTopRhs dflags rec bndr (StgRhsClosure cc bi fvs upd_flag args body)+  = ASSERT(null fvs)    -- There should be no free variables+    cgTopRhsClosure dflags rec bndr cc bi upd_flag args body+++---------------------------------------------------------------+--      Module initialisation code+---------------------------------------------------------------++{- The module initialisation code looks like this, roughly:++        FN(__stginit_Foo) {+          JMP_(__stginit_Foo_1_p)+        }++        FN(__stginit_Foo_1_p) {+        ...+        }++   We have one version of the init code with a module version and the+   'way' attached to it.  The version number helps to catch cases+   where modules are not compiled in dependency order before being+   linked: if a module has been compiled since any modules which depend on+   it, then the latter modules will refer to a different version in their+   init blocks and a link error will ensue.++   The 'way' suffix helps to catch cases where modules compiled in different+   ways are linked together (eg. profiled and non-profiled).++   We provide a plain, unadorned, version of the module init code+   which just jumps to the version with the label and way attached.  The+   reason for this is that when using foreign exports, the caller of+   startupHaskell() must supply the name of the init function for the "top"+   module in the program, and we don't want to require that this name+   has the version and way info appended to it.++We initialise the module tree by keeping a work-stack,+        * pointed to by Sp+        * that grows downward+        * Sp points to the last occupied slot+-}++mkModuleInit+        :: CollectedCCs         -- cost centre info+        -> Module+        -> HpcInfo+        -> FCode ()++mkModuleInit cost_centre_info this_mod hpc_info+  = do  { initHpc this_mod hpc_info+        ; initCostCentres cost_centre_info+            -- For backwards compatibility: user code may refer to this+            -- label for calling hs_add_root().+        ; let lbl = mkPlainModuleInitLabel this_mod+        ; emitDecl (CmmData (Section Data lbl) (Statics lbl []))+        }+++---------------------------------------------------------------+--      Generating static stuff for algebraic data types+---------------------------------------------------------------+++cgEnumerationTyCon :: TyCon -> FCode ()+cgEnumerationTyCon tycon+  = do dflags <- getDynFlags+       emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)+             [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)+                           (tagForCon dflags con)+             | con <- tyConDataCons tycon]+++cgDataCon :: DataCon -> FCode ()+-- Generate the entry code, info tables, and (for niladic constructor)+-- the static closure, for a constructor.+cgDataCon data_con+  = do  { dflags <- getDynFlags+        ; let+            (tot_wds, --  #ptr_wds + #nonptr_wds+             ptr_wds) --  #ptr_wds+              = mkVirtConstrSizes dflags arg_reps++            nonptr_wds   = tot_wds - ptr_wds++            dyn_info_tbl =+              mkDataConInfoTable dflags data_con False ptr_wds nonptr_wds++            -- We're generating info tables, so we don't know and care about+            -- what the actual arguments are. Using () here as the place holder.+            arg_reps :: [NonVoid PrimRep]+            arg_reps = [ NonVoid rep_ty+                       | ty <- dataConRepArgTys data_con+                       , rep_ty <- typePrimRep ty+                       , not (isVoidRep rep_ty) ]++        ; emitClosureAndInfoTable dyn_info_tbl NativeDirectCall [] $+            -- NB: the closure pointer is assumed *untagged* on+            -- entry to a constructor.  If the pointer is tagged,+            -- then we should not be entering it.  This assumption+            -- is used in ldvEnter and when tagging the pointer to+            -- return it.+            -- NB 2: We don't set CC when entering data (WDP 94/06)+            do { tickyEnterDynCon+               ; ldvEnter (CmmReg nodeReg)+               ; tickyReturnOldCon (length arg_reps)+               ; void $ emitReturn [cmmOffsetB dflags (CmmReg nodeReg) (tagForCon dflags data_con)]+               }+                    -- The case continuation code expects a tagged pointer+        }++---------------------------------------------------------------+--      Stuff to support splitting+---------------------------------------------------------------++maybeExternaliseId :: DynFlags -> Id -> FCode Id+maybeExternaliseId dflags id+  | gopt Opt_SplitObjs dflags,  -- See Note [Externalise when splitting]+                                -- in StgCmmMonad+    isInternalName name = do { mod <- getModuleName+                             ; returnFC (setIdName id (externalise mod)) }+  | otherwise           = returnFC id+  where+    externalise mod = mkExternalName uniq mod new_occ loc+    name    = idName id+    uniq    = nameUnique name+    new_occ = mkLocalOcc uniq (nameOccName name)+    loc     = nameSrcSpan name+        -- We want to conjure up a name that can't clash with any+        -- existing name.  So we generate+        --      Mod_$L243foo+        -- where 243 is the unique.
+ codeGen/StgCmmArgRep.hs view
@@ -0,0 +1,152 @@+-----------------------------------------------------------------------------+--+-- Argument representations used in StgCmmLayout.+--+-- (c) The University of Glasgow 2013+--+-----------------------------------------------------------------------------++module StgCmmArgRep (+        ArgRep(..), toArgRep, argRepSizeW,++        argRepString, isNonV, idArgRep,++        slowCallPattern,++        ) where++import StgCmmClosure    ( idPrimRep )++import SMRep            ( WordOff )+import Id               ( Id )+import TyCon            ( PrimRep(..), primElemRepSizeB )+import BasicTypes       ( RepArity )+import Constants        ( wORD64_SIZE )+import DynFlags++import Outputable+import FastString++-- I extricated this code as this new module in order to avoid a+-- cyclic dependency between StgCmmLayout and StgCmmTicky.+--+-- NSF 18 Feb 2013++-------------------------------------------------------------------------+--      Classifying arguments: ArgRep+-------------------------------------------------------------------------++-- ArgRep is re-exported by StgCmmLayout, but only for use in the+-- byte-code generator which also needs to know about the+-- classification of arguments.++data ArgRep = P   -- GC Ptr+            | N   -- Word-sized non-ptr+            | L   -- 64-bit non-ptr (long)+            | V   -- Void+            | F   -- Float+            | D   -- Double+            | V16 -- 16-byte (128-bit) vectors of Float/Double/Int8/Word32/etc.+            | V32 -- 32-byte (256-bit) vectors of Float/Double/Int8/Word32/etc.+            | V64 -- 64-byte (512-bit) vectors of Float/Double/Int8/Word32/etc.+instance Outputable ArgRep where ppr = text . argRepString++argRepString :: ArgRep -> String+argRepString P = "P"+argRepString N = "N"+argRepString L = "L"+argRepString V = "V"+argRepString F = "F"+argRepString D = "D"+argRepString V16 = "V16"+argRepString V32 = "V32"+argRepString V64 = "V64"++toArgRep :: PrimRep -> ArgRep+toArgRep VoidRep           = V+toArgRep LiftedRep         = P+toArgRep UnliftedRep       = P+toArgRep IntRep            = N+toArgRep WordRep           = N+toArgRep AddrRep           = N+toArgRep Int64Rep          = L+toArgRep Word64Rep         = L+toArgRep FloatRep          = F+toArgRep DoubleRep         = D+toArgRep (VecRep len elem) = case len*primElemRepSizeB elem of+                               16 -> V16+                               32 -> V32+                               64 -> V64+                               _  -> error "toArgRep: bad vector primrep"++isNonV :: ArgRep -> Bool+isNonV V = False+isNonV _ = True++argRepSizeW :: DynFlags -> ArgRep -> WordOff                -- Size in words+argRepSizeW _      N   = 1+argRepSizeW _      P   = 1+argRepSizeW _      F   = 1+argRepSizeW dflags L   = wORD64_SIZE        `quot` wORD_SIZE dflags+argRepSizeW dflags D   = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags+argRepSizeW _      V   = 0+argRepSizeW dflags V16 = 16                 `quot` wORD_SIZE dflags+argRepSizeW dflags V32 = 32                 `quot` wORD_SIZE dflags+argRepSizeW dflags V64 = 64                 `quot` wORD_SIZE dflags++idArgRep :: Id -> ArgRep+idArgRep = toArgRep . idPrimRep++-- This list of argument patterns should be kept in sync with at least+-- the following:+--+--  * StgCmmLayout.stdPattern maybe to some degree?+--+--  * the RTS_RET(stg_ap_*) and RTS_FUN_DECL(stg_ap_*_fast)+--  declarations in includes/stg/MiscClosures.h+--+--  * the SLOW_CALL_*_ctr declarations in includes/stg/Ticky.h,+--+--  * the TICK_SLOW_CALL_*() #defines in includes/Cmm.h,+--+--  * the PR_CTR(SLOW_CALL_*_ctr) calls in rts/Ticky.c,+--+--  * and the SymI_HasProto(stg_ap_*_{ret,info,fast}) calls and+--  SymI_HasProto(SLOW_CALL_*_ctr) calls in rts/Linker.c+--+-- There may be more places that I haven't found; I merely igrep'd for+-- pppppp and excluded things that seemed ghci-specific.+--+-- Also, it seems at the moment that ticky counters with void+-- arguments will never be bumped, but I'm still declaring those+-- counters, defensively.+--+-- NSF 6 Mar 2013++slowCallPattern :: [ArgRep] -> (FastString, RepArity)+-- Returns the generic apply function and arity+--+-- The first batch of cases match (some) specialised entries+-- The last group deals exhaustively with the cases for the first argument+--   (and the zero-argument case)+--+-- In 99% of cases this function will match *all* the arguments in one batch++slowCallPattern (P: P: P: P: P: P: _) = (fsLit "stg_ap_pppppp", 6)+slowCallPattern (P: P: P: P: P: _)    = (fsLit "stg_ap_ppppp", 5)+slowCallPattern (P: P: P: P: _)       = (fsLit "stg_ap_pppp", 4)+slowCallPattern (P: P: P: V: _)       = (fsLit "stg_ap_pppv", 4)+slowCallPattern (P: P: P: _)          = (fsLit "stg_ap_ppp", 3)+slowCallPattern (P: P: V: _)          = (fsLit "stg_ap_ppv", 3)+slowCallPattern (P: P: _)             = (fsLit "stg_ap_pp", 2)+slowCallPattern (P: V: _)             = (fsLit "stg_ap_pv", 2)+slowCallPattern (P: _)                = (fsLit "stg_ap_p", 1)+slowCallPattern (V: _)                = (fsLit "stg_ap_v", 1)+slowCallPattern (N: _)                = (fsLit "stg_ap_n", 1)+slowCallPattern (F: _)                = (fsLit "stg_ap_f", 1)+slowCallPattern (D: _)                = (fsLit "stg_ap_d", 1)+slowCallPattern (L: _)                = (fsLit "stg_ap_l", 1)+slowCallPattern (V16: _)              = (fsLit "stg_ap_v16", 1)+slowCallPattern (V32: _)              = (fsLit "stg_ap_v32", 1)+slowCallPattern (V64: _)              = (fsLit "stg_ap_v64", 1)+slowCallPattern []                    = (fsLit "stg_ap_0", 0)
+ codeGen/StgCmmBind.hs view
@@ -0,0 +1,755 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Stg to C-- code generation: bindings+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module StgCmmBind (+        cgTopRhsClosure,+        cgBind,+        emitBlackHoleCode,+        pushUpdateFrame, emitUpdateFrame+  ) where++#include "HsVersions.h"++import StgCmmExpr+import StgCmmMonad+import StgCmmEnv+import StgCmmCon+import StgCmmHeap+import StgCmmProf (curCCS, ldvEnterClosure, enterCostCentreFun, enterCostCentreThunk,+                   initUpdFrameProf)+import StgCmmTicky+import StgCmmLayout+import StgCmmUtils+import StgCmmClosure+import StgCmmForeign    (emitPrimCall)++import MkGraph+import CoreSyn          ( AltCon(..), tickishIsCode )+import BlockId+import SMRep+import Cmm+import CmmInfo+import CmmUtils+import CLabel+import StgSyn+import CostCentre+import Id+import IdInfo+import Name+import Module+import ListSetOps+import Util+import BasicTypes+import Outputable+import FastString+import DynFlags++import Control.Monad++import Prelude hiding ((<*>))++------------------------------------------------------------------------+--              Top-level bindings+------------------------------------------------------------------------++-- For closures bound at top level, allocate in static space.+-- They should have no free variables.++cgTopRhsClosure :: DynFlags+                -> RecFlag              -- member of a recursive group?+                -> Id+                -> CostCentreStack      -- Optional cost centre annotation+                -> StgBinderInfo+                -> UpdateFlag+                -> [Id]                 -- Args+                -> StgExpr+                -> (CgIdInfo, FCode ())++cgTopRhsClosure dflags rec id ccs _ upd_flag args body =+  let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id)+      cg_id_info    = litIdInfo dflags id lf_info (CmmLabel closure_label)+      lf_info       = mkClosureLFInfo dflags id TopLevel [] upd_flag args+  in (cg_id_info, gen_code dflags lf_info closure_label)+  where+  -- special case for a indirection (f = g).  We create an IND_STATIC+  -- closure pointing directly to the indirectee.  This is exactly+  -- what the CAF will eventually evaluate to anyway, we're just+  -- shortcutting the whole process, and generating a lot less code+  -- (#7308)+  --+  -- Note: we omit the optimisation when this binding is part of a+  -- recursive group, because the optimisation would inhibit the black+  -- hole detection from working in that case.  Test+  -- concurrent/should_run/4030 fails, for instance.+  --+  gen_code dflags _ closure_label+    | StgApp f [] <- body, null args, isNonRec rec+    = do+         cg_info <- getCgIdInfo f+         let closure_rep   = mkStaticClosureFields dflags+                                    indStaticInfoTable ccs MayHaveCafRefs+                                    [unLit (idInfoToAmode cg_info)]+         emitDataLits closure_label closure_rep+         return ()++  gen_code dflags lf_info closure_label+   = do {     -- LAY OUT THE OBJECT+          let name = idName id+        ; mod_name <- getModuleName+        ; let descr         = closureDescription dflags mod_name name+              closure_info  = mkClosureInfo dflags True id lf_info 0 0 descr++              caffy         = idCafInfo id+              info_tbl      = mkCmmInfo closure_info -- XXX short-cut+              closure_rep   = mkStaticClosureFields dflags info_tbl ccs caffy []++                 -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)+        ; emitDataLits closure_label closure_rep+        ; let fv_details :: [(NonVoid Id, VirtualHpOffset)]+              (_, _, fv_details) = mkVirtHeapOffsets dflags (isLFThunk lf_info) []+        -- Don't drop the non-void args until the closure info has been made+        ; forkClosureBody (closureCodeBody True id closure_info ccs+                                (nonVoidIds args) (length args) body fv_details)++        ; return () }++  unLit (CmmLit l) = l+  unLit _ = panic "unLit"++------------------------------------------------------------------------+--              Non-top-level bindings+------------------------------------------------------------------------++cgBind :: StgBinding -> FCode ()+cgBind (StgNonRec name rhs)+  = do  { (info, fcode) <- cgRhs name rhs+        ; addBindC info+        ; init <- fcode+        ; emit init }+        -- init cannot be used in body, so slightly better to sink it eagerly++cgBind (StgRec pairs)+  = do  {  r <- sequence $ unzipWith cgRhs pairs+        ;  let (id_infos, fcodes) = unzip r+        ;  addBindsC id_infos+        ;  (inits, body) <- getCodeR $ sequence fcodes+        ;  emit (catAGraphs inits <*> body) }++{- Note [cgBind rec]++   Recursive let-bindings are tricky.+   Consider the following pseudocode:++     let x = \_ ->  ... y ...+         y = \_ ->  ... z ...+         z = \_ ->  ... x ...+     in ...++   For each binding, we need to allocate a closure, and each closure must+   capture the address of the other closures.+   We want to generate the following C-- code:+     // Initialization Code+     x = hp - 24; // heap address of x's closure+     y = hp - 40; // heap address of x's closure+     z = hp - 64; // heap address of x's closure+     // allocate and initialize x+     m[hp-8]   = ...+     m[hp-16]  = y       // the closure for x captures y+     m[hp-24] = x_info;+     // allocate and initialize y+     m[hp-32] = z;       // the closure for y captures z+     m[hp-40] = y_info;+     // allocate and initialize z+     ...++   For each closure, we must generate not only the code to allocate and+   initialize the closure itself, but also some initialization Code that+   sets a variable holding the closure pointer.++   We could generate a pair of the (init code, body code), but since+   the bindings are recursive we also have to initialise the+   environment with the CgIdInfo for all the bindings before compiling+   anything.  So we do this in 3 stages:++     1. collect all the CgIdInfos and initialise the environment+     2. compile each binding into (init, body) code+     3. emit all the inits, and then all the bodies++   We'd rather not have separate functions to do steps 1 and 2 for+   each binding, since in pratice they share a lot of code.  So we+   have just one function, cgRhs, that returns a pair of the CgIdInfo+   for step 1, and a monadic computation to generate the code in step+   2.++   The alternative to separating things in this way is to use a+   fixpoint.  That's what we used to do, but it introduces a+   maintenance nightmare because there is a subtle dependency on not+   being too strict everywhere.  Doing things this way means that the+   FCode monad can be strict, for example.+ -}++cgRhs :: Id+      -> StgRhs+      -> FCode (+                 CgIdInfo         -- The info for this binding+               , FCode CmmAGraph  -- A computation which will generate the+                                  -- code for the binding, and return an+                                  -- assignent of the form "x = Hp - n"+                                  -- (see above)+               )++cgRhs id (StgRhsCon cc con args)+  = withNewTickyCounterCon (idName id) $+    buildDynCon id True cc con (assertNonVoidStgArgs args)+      -- con args are always non-void,+      -- see Note [Post-unarisation invariants] in UnariseStg++{- See Note [GC recovery] in compiler/codeGen/StgCmmClosure.hs -}+cgRhs id (StgRhsClosure cc bi fvs upd_flag args body)+  = do dflags <- getDynFlags+       mkRhsClosure dflags id cc bi (nonVoidIds fvs) upd_flag args body++------------------------------------------------------------------------+--              Non-constructor right hand sides+------------------------------------------------------------------------++mkRhsClosure :: DynFlags -> Id -> CostCentreStack -> StgBinderInfo+             -> [NonVoid Id]                    -- Free vars+             -> UpdateFlag+             -> [Id]                            -- Args+             -> StgExpr+             -> FCode (CgIdInfo, FCode CmmAGraph)++{- mkRhsClosure looks for two special forms of the right-hand side:+        a) selector thunks+        b) AP thunks++If neither happens, it just calls mkClosureLFInfo.  You might think+that mkClosureLFInfo should do all this, but it seems wrong for the+latter to look at the structure of an expression++Note [Selectors]+~~~~~~~~~~~~~~~~+We look at the body of the closure to see if it's a selector---turgid,+but nothing deep.  We are looking for a closure of {\em exactly} the+form:++...  = [the_fv] \ u [] ->+         case the_fv of+           con a_1 ... a_n -> a_i++Note [Ap thunks]+~~~~~~~~~~~~~~~~+A more generic AP thunk of the form++        x = [ x_1...x_n ] \.. [] -> x_1 ... x_n++A set of these is compiled statically into the RTS, so we just use+those.  We could extend the idea to thunks where some of the x_i are+global ids (and hence not free variables), but this would entail+generating a larger thunk.  It might be an option for non-optimising+compilation, though.++We only generate an Ap thunk if all the free variables are pointers,+for semi-obvious reasons.++-}++---------- Note [Selectors] ------------------+mkRhsClosure    dflags bndr _cc _bi+                [NonVoid the_fv]                -- Just one free var+                upd_flag                -- Updatable thunk+                []                      -- A thunk+                expr+  | let strip = snd . stripStgTicksTop (not . tickishIsCode)+  , StgCase (StgApp scrutinee [{-no args-}])+         _   -- ignore bndr+         (AlgAlt _)+         [(DataAlt _, params, sel_expr)] <- strip expr+  , StgApp selectee [{-no args-}] <- strip sel_expr+  , the_fv == scrutinee                -- Scrutinee is the only free variable++  , let (_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps (assertNonVoidIds params))+                                   -- pattern binders are always non-void,+                                   -- see Note [Post-unarisation invariants] in UnariseStg+  , Just the_offset <- assocMaybe params_w_offsets (NonVoid selectee)++  , let offset_into_int = bytesToWordsRoundUp dflags the_offset+                          - fixedHdrSizeW dflags+  , offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough+  = -- NOT TRUE: ASSERT(is_single_constructor)+    -- The simplifier may have statically determined that the single alternative+    -- is the only possible case and eliminated the others, even if there are+    -- other constructors in the datatype.  It's still ok to make a selector+    -- thunk in this case, because we *know* which constructor the scrutinee+    -- will evaluate to.+    --+    -- srt is discarded; it must be empty+    let lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag)+    in cgRhsStdThunk bndr lf_info [StgVarArg the_fv]++---------- Note [Ap thunks] ------------------+mkRhsClosure    dflags bndr _cc _bi+                fvs+                upd_flag+                []                      -- No args; a thunk+                (StgApp fun_id args)++  -- We are looking for an "ApThunk"; see data con ApThunk in StgCmmClosure+  -- of form (x1 x2 .... xn), where all the xi are locals (not top-level)+  -- So the xi will all be free variables+  | args `lengthIs` (n_fvs-1)  -- This happens only if the fun_id and+                               -- args are all distinct local variables+                               -- The "-1" is for fun_id+    -- Missed opportunity:   (f x x) is not detected+  , all (isGcPtrRep . idPrimRep . fromNonVoid) fvs+  , isUpdatable upd_flag+  , n_fvs <= mAX_SPEC_AP_SIZE dflags+  , not (gopt Opt_SccProfilingOn dflags)+                         -- not when profiling: we don't want to+                         -- lose information about this particular+                         -- thunk (e.g. its type) (#949)++          -- Ha! an Ap thunk+  = cgRhsStdThunk bndr lf_info payload++  where+    n_fvs   = length fvs+    lf_info = mkApLFInfo bndr upd_flag n_fvs+    -- the payload has to be in the correct order, hence we can't+    -- just use the fvs.+    payload = StgVarArg fun_id : args++---------- Default case ------------------+mkRhsClosure dflags bndr cc _ fvs upd_flag args body+  = do  { let lf_info = mkClosureLFInfo dflags bndr NotTopLevel fvs upd_flag args+        ; (id_info, reg) <- rhsIdInfo bndr lf_info+        ; return (id_info, gen_code lf_info reg) }+ where+ gen_code lf_info reg+  = do  {       -- LAY OUT THE OBJECT+        -- If the binder is itself a free variable, then don't store+        -- it in the closure.  Instead, just bind it to Node on entry.+        -- NB we can be sure that Node will point to it, because we+        -- haven't told mkClosureLFInfo about this; so if the binder+        -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*+        -- stored in the closure itself, so it will make sure that+        -- Node points to it...+        ; let   reduced_fvs = filter (NonVoid bndr /=) fvs++        -- MAKE CLOSURE INFO FOR THIS CLOSURE+        ; mod_name <- getModuleName+        ; dflags <- getDynFlags+        ; let   name  = idName bndr+                descr = closureDescription dflags mod_name name+                fv_details :: [(NonVoid Id, ByteOff)]+                (tot_wds, ptr_wds, fv_details)+                   = mkVirtHeapOffsets dflags (isLFThunk lf_info)+                                       (addIdReps reduced_fvs)+                closure_info = mkClosureInfo dflags False       -- Not static+                                             bndr lf_info tot_wds ptr_wds+                                             descr++        -- BUILD ITS INFO TABLE AND CODE+        ; forkClosureBody $+                -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere+                --                  (b) ignore Sequel from context; use empty Sequel+                -- And compile the body+                closureCodeBody False bndr closure_info cc (nonVoidIds args)+                                (length args) body fv_details++        -- BUILD THE OBJECT+--      ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body+        ; let use_cc = curCCS; blame_cc = curCCS+        ; emit (mkComment $ mkFastString "calling allocDynClosure")+        ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)+        ; let info_tbl = mkCmmInfo closure_info+        ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc+                                         (map toVarArg fv_details)++        -- RETURN+        ; return (mkRhsInit dflags reg lf_info hp_plus_n) }++-------------------------+cgRhsStdThunk+        :: Id+        -> LambdaFormInfo+        -> [StgArg]             -- payload+        -> FCode (CgIdInfo, FCode CmmAGraph)++cgRhsStdThunk bndr lf_info payload+ = do  { (id_info, reg) <- rhsIdInfo bndr lf_info+       ; return (id_info, gen_code reg)+       }+ where+ gen_code reg  -- AHA!  A STANDARD-FORM THUNK+  = withNewTickyCounterStdThunk (lfUpdatable lf_info) (idName bndr) $+    do+  {     -- LAY OUT THE OBJECT+    mod_name <- getModuleName+  ; dflags <- getDynFlags+  ; let (tot_wds, ptr_wds, payload_w_offsets)+            = mkVirtHeapOffsets dflags (isLFThunk lf_info)+                                (addArgReps (nonVoidStgArgs payload))++        descr = closureDescription dflags mod_name (idName bndr)+        closure_info = mkClosureInfo dflags False       -- Not static+                                     bndr lf_info tot_wds ptr_wds+                                     descr++--  ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body+  ; let use_cc = curCCS; blame_cc = curCCS+++        -- BUILD THE OBJECT+  ; let info_tbl = mkCmmInfo closure_info+  ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info+                                   use_cc blame_cc payload_w_offsets++        -- RETURN+  ; return (mkRhsInit dflags reg lf_info hp_plus_n) }+++mkClosureLFInfo :: DynFlags+                -> Id           -- The binder+                -> TopLevelFlag -- True of top level+                -> [NonVoid Id] -- Free vars+                -> UpdateFlag   -- Update flag+                -> [Id]         -- Args+                -> LambdaFormInfo+mkClosureLFInfo dflags bndr top fvs upd_flag args+  | null args =+        mkLFThunk (idType bndr) top (map fromNonVoid fvs) upd_flag+  | otherwise =+        mkLFReEntrant top (map fromNonVoid fvs) args (mkArgDescr dflags args)+++------------------------------------------------------------------------+--              The code for closures+------------------------------------------------------------------------++closureCodeBody :: Bool            -- whether this is a top-level binding+                -> Id              -- the closure's name+                -> ClosureInfo     -- Lots of information about this closure+                -> CostCentreStack -- Optional cost centre attached to closure+                -> [NonVoid Id]    -- incoming args to the closure+                -> Int             -- arity, including void args+                -> StgExpr+                -> [(NonVoid Id, ByteOff)] -- the closure's free vars+                -> FCode ()++{- There are two main cases for the code for closures.++* If there are *no arguments*, then the closure is a thunk, and not in+  normal form. So it should set up an update frame (if it is+  shared). NB: Thunks cannot have a primitive type!++* If there is *at least one* argument, then this closure is in+  normal form, so there is no need to set up an update frame.+-}++closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details+  | arity == 0 -- No args i.e. thunk+  = withNewTickyCounterThunk+        (isStaticClosure cl_info)+        (closureUpdReqd cl_info)+        (closureName cl_info) $+    emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $+      \(_, node, _) -> thunkCode cl_info fv_details cc node arity body+   where+     lf_info  = closureLFInfo cl_info+     info_tbl = mkCmmInfo cl_info++closureCodeBody top_lvl bndr cl_info cc args arity body fv_details+  = -- Note: args may be [], if all args are Void+    withNewTickyCounterFun+        (closureSingleEntry cl_info)+        (closureName cl_info)+        args $ do {++        ; let+             lf_info  = closureLFInfo cl_info+             info_tbl = mkCmmInfo cl_info++        -- Emit the main entry code+        ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args $+            \(_offset, node, arg_regs) -> do+                -- Emit slow-entry code (for entering a closure through a PAP)+                { mkSlowEntryCode bndr cl_info arg_regs+                ; dflags <- getDynFlags+                ; let node_points = nodeMustPointToIt dflags lf_info+                      node' = if node_points then Just node else Nothing+                ; loop_header_id <- newBlockId+                -- Extend reader monad with information that+                -- self-recursive tail calls can be optimized into local+                -- jumps. See Note [Self-recursive tail calls] in StgCmmExpr.+                ; withSelfLoop (bndr, loop_header_id, arg_regs) $ do+                {+                -- Main payload+                ; entryHeapCheck cl_info node' arity arg_regs $ do+                { -- emit LDV code when profiling+                  when node_points (ldvEnterClosure cl_info (CmmLocal node))+                -- ticky after heap check to avoid double counting+                ; tickyEnterFun cl_info+                ; enterCostCentreFun cc+                    (CmmMachOp (mo_wordSub dflags)+                         [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification]+                         , mkIntExpr dflags (funTag dflags cl_info) ])+                ; fv_bindings <- mapM bind_fv fv_details+                -- Load free vars out of closure *after*+                -- heap check, to reduce live vars over check+                ; when node_points $ load_fvs node lf_info fv_bindings+                ; void $ cgExpr body+                }}}++  }++-- Note [NodeReg clobbered with loopification]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Previously we used to pass nodeReg (aka R1) here. With profiling, upon+-- entering a closure, enterFunCCS was called with R1 passed to it. But since R1+-- may get clobbered inside the body of a closure, and since a self-recursive+-- tail call does not restore R1, a subsequent call to enterFunCCS received a+-- possibly bogus value from R1. The solution is to not pass nodeReg (aka R1) to+-- enterFunCCS. Instead, we pass node, the callee-saved temporary that stores+-- the original value of R1. This way R1 may get modified but loopification will+-- not care.++-- A function closure pointer may be tagged, so we+-- must take it into account when accessing the free variables.+bind_fv :: (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff)+bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }++load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode ()+load_fvs node lf_info = mapM_ (\ (reg, off) ->+   do dflags <- getDynFlags+      let tag = lfDynTag dflags lf_info+      emit $ mkTaggedObjectLoad dflags reg node off tag)++-----------------------------------------+-- The "slow entry" code for a function.  This entry point takes its+-- arguments on the stack.  It loads the arguments into registers+-- according to the calling convention, and jumps to the function's+-- normal entry point.  The function's closure is assumed to be in+-- R1/node.+--+-- The slow entry point is used for unknown calls: eg. stg_PAP_entry++mkSlowEntryCode :: Id -> ClosureInfo -> [LocalReg] -> FCode ()+-- If this function doesn't have a specialised ArgDescr, we need+-- to generate the function's arg bitmap and slow-entry code.+-- Here, we emit the slow-entry code.+mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'+  | Just (_, ArgGen _) <- closureFunInfo cl_info+  = do dflags <- getDynFlags+       let node = idToReg dflags (NonVoid bndr)+           slow_lbl = closureSlowEntryLabel  cl_info+           fast_lbl = closureLocalEntryLabel dflags cl_info+           -- mkDirectJump does not clobber `Node' containing function closure+           jump = mkJump dflags NativeNodeCall+                                (mkLblExpr fast_lbl)+                                (map (CmmReg . CmmLocal) (node : arg_regs))+                                (initUpdFrameOff dflags)+       tscope <- getTickScope+       emitProcWithConvention Slow Nothing slow_lbl+         (node : arg_regs) (jump, tscope)+  | otherwise = return ()++-----------------------------------------+thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack+          -> LocalReg -> Int -> StgExpr -> FCode ()+thunkCode cl_info fv_details _cc node arity body+  = do { dflags <- getDynFlags+       ; let node_points = nodeMustPointToIt dflags (closureLFInfo cl_info)+             node'       = if node_points then Just node else Nothing+        ; ldvEnterClosure cl_info (CmmLocal node) -- NB: Node always points when profiling++        -- Heap overflow check+        ; entryHeapCheck cl_info node' arity [] $ do+        { -- Overwrite with black hole if necessary+          -- but *after* the heap-overflow check+        ; tickyEnterThunk cl_info+        ; when (blackHoleOnEntry cl_info && node_points)+                (blackHoleIt node)++          -- Push update frame+        ; setupUpdate cl_info node $+            -- We only enter cc after setting up update so+            -- that cc of enclosing scope will be recorded+            -- in update frame CAF/DICT functions will be+            -- subsumed by this enclosing cc+            do { enterCostCentreThunk (CmmReg nodeReg)+               ; let lf_info = closureLFInfo cl_info+               ; fv_bindings <- mapM bind_fv fv_details+               ; load_fvs node lf_info fv_bindings+               ; void $ cgExpr body }}}+++------------------------------------------------------------------------+--              Update and black-hole wrappers+------------------------------------------------------------------------++blackHoleIt :: LocalReg -> FCode ()+-- Only called for closures with no args+-- Node points to the closure+blackHoleIt node_reg+  = emitBlackHoleCode (CmmReg (CmmLocal node_reg))++emitBlackHoleCode :: CmmExpr -> FCode ()+emitBlackHoleCode node = do+  dflags <- getDynFlags++  -- Eager blackholing is normally disabled, but can be turned on with+  -- -feager-blackholing.  When it is on, we replace the info pointer+  -- of the thunk with stg_EAGER_BLACKHOLE_info on entry.++  -- If we wanted to do eager blackholing with slop filling, we'd need+  -- to do it at the *end* of a basic block, otherwise we overwrite+  -- the free variables in the thunk that we still need.  We have a+  -- patch for this from Andy Cheadle, but not incorporated yet. --SDM+  -- [6/2004]+  --+  -- Previously, eager blackholing was enabled when ticky-ticky was+  -- on. But it didn't work, and it wasn't strictly necessary to bring+  -- back minimal ticky-ticky, so now EAGER_BLACKHOLING is+  -- unconditionally disabled. -- krc 1/2007++  -- Note the eager-blackholing check is here rather than in blackHoleOnEntry,+  -- because emitBlackHoleCode is called from CmmParse.++  let  eager_blackholing =  not (gopt Opt_SccProfilingOn dflags)+                         && gopt Opt_EagerBlackHoling dflags+             -- Profiling needs slop filling (to support LDV+             -- profiling), so currently eager blackholing doesn't+             -- work with profiling.++  when eager_blackholing $ do+    emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags))+                  (CmmReg (CmmGlobal CurrentTSO))+    emitPrimCall [] MO_WriteBarrier []+    emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo))++setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()+        -- Nota Bene: this function does not change Node (even if it's a CAF),+        -- so that the cost centre in the original closure can still be+        -- extracted by a subsequent enterCostCentre+setupUpdate closure_info node body+  | not (lfUpdatable (closureLFInfo closure_info))+  = body++  | not (isStaticClosure closure_info)+  = if not (closureUpdReqd closure_info)+      then do tickyUpdateFrameOmitted; body+      else do+          tickyPushUpdateFrame+          dflags <- getDynFlags+          let+              bh = blackHoleOnEntry closure_info &&+                   not (gopt Opt_SccProfilingOn dflags) &&+                   gopt Opt_EagerBlackHoling dflags++              lbl | bh        = mkBHUpdInfoLabel+                  | otherwise = mkUpdInfoLabel++          pushUpdateFrame lbl (CmmReg (CmmLocal node)) body++  | otherwise   -- A static closure+  = do  { tickyUpdateBhCaf closure_info++        ; if closureUpdReqd closure_info+          then do       -- Blackhole the (updatable) CAF:+                { upd_closure <- link_caf node True+                ; pushUpdateFrame mkBHUpdInfoLabel upd_closure body }+          else do {tickyUpdateFrameOmitted; body}+    }++-----------------------------------------------------------------------------+-- Setting up update frames++-- Push the update frame on the stack in the Entry area,+-- leaving room for the return address that is already+-- at the old end of the area.+--+pushUpdateFrame :: CLabel -> CmmExpr -> FCode () -> FCode ()+pushUpdateFrame lbl updatee body+  = do+       updfr  <- getUpdFrameOff+       dflags <- getDynFlags+       let+           hdr         = fixedHdrSize dflags+           frame       = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr dflags+       --+       emitUpdateFrame dflags (CmmStackSlot Old frame) lbl updatee+       withUpdFrameOff frame body++emitUpdateFrame :: DynFlags -> CmmExpr -> CLabel -> CmmExpr -> FCode ()+emitUpdateFrame dflags frame lbl updatee = do+  let+           hdr         = fixedHdrSize dflags+           off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags+  --+  emitStore frame (mkLblExpr lbl)+  emitStore (cmmOffset dflags frame off_updatee) updatee+  initUpdFrameProf frame++-----------------------------------------------------------------------------+-- Entering a CAF+--+-- See Note [CAF management] in rts/sm/Storage.c++link_caf :: LocalReg           -- pointer to the closure+         -> Bool               -- True <=> updatable, False <=> single-entry+         -> FCode CmmExpr      -- Returns amode for closure to be updated+-- This function returns the address of the black hole, so it can be+-- updated with the new value when available.+link_caf node _is_upd = do+  { dflags <- getDynFlags+        -- Call the RTS function newCAF, returning the newly-allocated+        -- blackhole indirection closure+  ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing+                                    ForeignLabelInExternalPackage IsFunction+  ; bh <- newTemp (bWord dflags)+  ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl+      [ (CmmReg (CmmGlobal BaseReg),  AddrHint),+        (CmmReg (CmmLocal node), AddrHint) ]+      False++  -- see Note [atomic CAF entry] in rts/sm/Storage.c+  ; updfr  <- getUpdFrameOff+  ; let target = entryCode dflags (closureInfoPtr dflags (CmmReg (CmmLocal node)))+  ; emit =<< mkCmmIfThen+      (cmmEqWord dflags (CmmReg (CmmLocal bh)) (zeroExpr dflags))+        -- re-enter the CAF+       (mkJump dflags NativeNodeCall target [] updfr)++  ; return (CmmReg (CmmLocal bh)) }++------------------------------------------------------------------------+--              Profiling+------------------------------------------------------------------------++-- For "global" data constructors the description is simply occurrence+-- name of the data constructor itself.  Otherwise it is determined by+-- @closureDescription@ from the let binding information.++closureDescription :: DynFlags+           -> Module            -- Module+                   -> Name              -- Id of closure binding+                   -> String+        -- Not called for StgRhsCon which have global info tables built in+        -- CgConTbls.hs with a description generated from the data constructor+closureDescription dflags mod_name name+  = showSDocDump dflags (char '<' <>+                    (if isExternalName name+                      then ppr name -- ppr will include the module name prefix+                      else pprModule mod_name <> char '.' <> ppr name) <>+                    char '>')+   -- showSDocDump, because we want to see the unique on the Name.
+ codeGen/StgCmmBind.hs-boot view
@@ -0,0 +1,6 @@+module StgCmmBind where++import StgCmmMonad( FCode )+import StgSyn( StgBinding )++cgBind :: StgBinding -> FCode ()
+ codeGen/StgCmmClosure.hs view
@@ -0,0 +1,1086 @@+{-# LANGUAGE CPP, RecordWildCards #-}++-----------------------------------------------------------------------------+--+-- Stg to C-- code generation:+--+-- The types   LambdaFormInfo+--             ClosureInfo+--+-- Nothing monadic in here!+--+-----------------------------------------------------------------------------++module StgCmmClosure (+        DynTag,  tagForCon, isSmallFamily,+        ConTagZ, dataConTagZ,++        idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps,+        argPrimRep,++        NonVoid(..), fromNonVoid, nonVoidIds, nonVoidStgArgs,+        assertNonVoidIds, assertNonVoidStgArgs,++        -- * LambdaFormInfo+        LambdaFormInfo,         -- Abstract+        StandardFormInfo,        -- ...ditto...+        mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,+        mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,+        mkLFStringLit,+        lfDynTag,+        maybeIsLFCon, isLFThunk, isLFReEntrant, lfUpdatable,++        -- * Used by other modules+        CgLoc(..), SelfLoopInfo, CallMethod(..),+        nodeMustPointToIt, isKnownFun, funTag, tagForArity, getCallMethod,++        -- * ClosureInfo+        ClosureInfo,+        mkClosureInfo,+        mkCmmInfo,++        -- ** Inspection+        closureLFInfo, closureName,++        -- ** Labels+        -- These just need the info table label+        closureInfoLabel, staticClosureLabel,+        closureSlowEntryLabel, closureLocalEntryLabel,++        -- ** Predicates+        -- These are really just functions on LambdaFormInfo+        closureUpdReqd, closureSingleEntry,+        closureReEntrant, closureFunInfo,+        isToplevClosure,++        blackHoleOnEntry,  -- Needs LambdaFormInfo and SMRep+        isStaticClosure,   -- Needs SMPre++        -- * InfoTables+        mkDataConInfoTable,+        cafBlackHoleInfoTable,+        indStaticInfoTable,+        staticClosureNeedsLink,+    ) where++#include "MachDeps.h"++#include "HsVersions.h"++import StgSyn+import SMRep+import Cmm+import PprCmmExpr()++import BlockId+import CLabel+import Id+import IdInfo+import DataCon+import Name+import Type+import TyCoRep+import TcType+import TyCon+import RepType+import BasicTypes+import Outputable+import DynFlags+import Util++import Data.Coerce (coerce)++-----------------------------------------------------------------------------+--                Data types and synonyms+-----------------------------------------------------------------------------++-- These data types are mostly used by other modules, especially StgCmmMonad,+-- but we define them here because some functions in this module need to+-- have access to them as well++data CgLoc+  = CmmLoc CmmExpr      -- A stable CmmExpr; that is, one not mentioning+                        -- Hp, so that it remains valid across calls++  | LneLoc BlockId [LocalReg]             -- A join point+        -- A join point (= let-no-escape) should only+        -- be tail-called, and in a saturated way.+        -- To tail-call it, assign to these locals,+        -- and branch to the block id++instance Outputable CgLoc where+  ppr (CmmLoc e)    = text "cmm" <+> ppr e+  ppr (LneLoc b rs) = text "lne" <+> ppr b <+> ppr rs++type SelfLoopInfo = (Id, BlockId, [LocalReg])++-- used by ticky profiling+isKnownFun :: LambdaFormInfo -> Bool+isKnownFun LFReEntrant{} = True+isKnownFun LFLetNoEscape = True+isKnownFun _             = False+++-------------------------------------+--        Non-void types+-------------------------------------+-- We frequently need the invariant that an Id or a an argument+-- is of a non-void type. This type is a witness to the invariant.++newtype NonVoid a = NonVoid a+  deriving (Eq, Show)++fromNonVoid :: NonVoid a -> a+fromNonVoid (NonVoid a) = a++instance (Outputable a) => Outputable (NonVoid a) where+  ppr (NonVoid a) = ppr a++nonVoidIds :: [Id] -> [NonVoid Id]+nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidTy (idType id))]++-- | Used in places where some invariant ensures that all these Ids are+-- non-void; e.g. constructor field binders in case expressions.+-- See Note [Post-unarisation invariants] in UnariseStg.+assertNonVoidIds :: [Id] -> [NonVoid Id]+assertNonVoidIds ids = ASSERT(not (any (isVoidTy . idType) ids))+                       coerce ids++nonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]+nonVoidStgArgs args = [NonVoid arg | arg <- args, not (isVoidTy (stgArgType arg))]++-- | Used in places where some invariant ensures that all these arguments are+-- non-void; e.g. constructor arguments.+-- See Note [Post-unarisation invariants] in UnariseStg.+assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]+assertNonVoidStgArgs args = ASSERT(not (any (isVoidTy . stgArgType) args))+                            coerce args+++-----------------------------------------------------------------------------+--                Representations+-----------------------------------------------------------------------------++-- Why are these here?++idPrimRep :: Id -> PrimRep+idPrimRep id = typePrimRep1 (idType id)+    -- NB: typePrimRep1 fails on unboxed tuples,+    --     but by StgCmm no Ids have unboxed tuple type++addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)]+addIdReps = map (\id -> let id' = fromNonVoid id+                         in NonVoid (idPrimRep id', id'))++addArgReps :: [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]+addArgReps = map (\arg -> let arg' = fromNonVoid arg+                           in NonVoid (argPrimRep arg', arg'))++argPrimRep :: StgArg -> PrimRep+argPrimRep arg = typePrimRep1 (stgArgType arg)+++-----------------------------------------------------------------------------+--                LambdaFormInfo+-----------------------------------------------------------------------------++-- Information about an identifier, from the code generator's point of+-- view.  Every identifier is bound to a LambdaFormInfo in the+-- environment, which gives the code generator enough info to be able to+-- tail call or return that identifier.++data LambdaFormInfo+  = LFReEntrant         -- Reentrant closure (a function)+        TopLevelFlag    -- True if top level+        OneShotInfo+        !RepArity       -- Arity. Invariant: always > 0+        !Bool           -- True <=> no fvs+        ArgDescr        -- Argument descriptor (should really be in ClosureInfo)++  | LFThunk             -- Thunk (zero arity)+        TopLevelFlag+        !Bool           -- True <=> no free vars+        !Bool           -- True <=> updatable (i.e., *not* single-entry)+        StandardFormInfo+        !Bool           -- True <=> *might* be a function type++  | LFCon               -- A saturated constructor application+        DataCon         -- The constructor++  | LFUnknown           -- Used for function arguments and imported things.+                        -- We know nothing about this closure.+                        -- Treat like updatable "LFThunk"...+                        -- Imported things which we *do* know something about use+                        -- one of the other LF constructors (eg LFReEntrant for+                        -- known functions)+        !Bool           -- True <=> *might* be a function type+                        --      The False case is good when we want to enter it,+                        --        because then we know the entry code will do+                        --        For a function, the entry code is the fast entry point++  | LFUnlifted          -- A value of unboxed type;+                        -- always a value, needs evaluation++  | LFLetNoEscape       -- See LetNoEscape module for precise description+++-------------------------+-- StandardFormInfo tells whether this thunk has one of+-- a small number of standard forms++data StandardFormInfo+  = NonStandardThunk+        -- The usual case: not of the standard forms++  | SelectorThunk+        -- A SelectorThunk is of form+        --      case x of+        --           con a1,..,an -> ak+        -- and the constructor is from a single-constr type.+       WordOff          -- 0-origin offset of ak within the "goods" of+                        -- constructor (Recall that the a1,...,an may be laid+                        -- out in the heap in a non-obvious order.)++  | ApThunk+        -- An ApThunk is of form+        --        x1 ... xn+        -- The code for the thunk just pushes x2..xn on the stack and enters x1.+        -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled+        -- in the RTS to save space.+        RepArity                -- Arity, n+++------------------------------------------------------+--                Building LambdaFormInfo+------------------------------------------------------++mkLFArgument :: Id -> LambdaFormInfo+mkLFArgument id+  | isUnliftedType ty      = LFUnlifted+  | might_be_a_function ty = LFUnknown True+  | otherwise              = LFUnknown False+  where+    ty = idType id++-------------+mkLFLetNoEscape :: LambdaFormInfo+mkLFLetNoEscape = LFLetNoEscape++-------------+mkLFReEntrant :: TopLevelFlag    -- True of top level+              -> [Id]            -- Free vars+              -> [Id]            -- Args+              -> ArgDescr        -- Argument descriptor+              -> LambdaFormInfo++mkLFReEntrant _ _ [] _+  = pprPanic "mkLFReEntrant" empty+mkLFReEntrant top fvs args arg_descr+  = LFReEntrant top os_info (length args) (null fvs) arg_descr+  where os_info = idOneShotInfo (head args)++-------------+mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo+mkLFThunk thunk_ty top fvs upd_flag+  = ASSERT( not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty) )+    LFThunk top (null fvs)+            (isUpdatable upd_flag)+            NonStandardThunk+            (might_be_a_function thunk_ty)++--------------+might_be_a_function :: Type -> Bool+-- Return False only if we are *sure* it's a data type+-- Look through newtypes etc as much as poss+might_be_a_function ty+  | [LiftedRep] <- typePrimRep ty+  , Just tc <- tyConAppTyCon_maybe (unwrapType ty)+  , isDataTyCon tc+  = False+  | otherwise+  = True++-------------+mkConLFInfo :: DataCon -> LambdaFormInfo+mkConLFInfo con = LFCon con++-------------+mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo+mkSelectorLFInfo id offset updatable+  = LFThunk NotTopLevel False updatable (SelectorThunk offset)+        (might_be_a_function (idType id))++-------------+mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo+mkApLFInfo id upd_flag arity+  = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)+        (might_be_a_function (idType id))++-------------+mkLFImported :: Id -> LambdaFormInfo+mkLFImported id+  | Just con <- isDataConWorkId_maybe id+  , isNullaryRepDataCon con+  = LFCon con   -- An imported nullary constructor+                -- We assume that the constructor is evaluated so that+                -- the id really does point directly to the constructor++  | arity > 0+  = LFReEntrant TopLevel noOneShotInfo arity True (panic "arg_descr")++  | otherwise+  = mkLFArgument id -- Not sure of exact arity+  where+    arity = idFunRepArity id++-------------+mkLFStringLit :: LambdaFormInfo+mkLFStringLit = LFUnlifted++-----------------------------------------------------+--                Dynamic pointer tagging+-----------------------------------------------------++type DynTag = Int       -- The tag on a *pointer*+                        -- (from the dynamic-tagging paper)++-- Note [Data constructor dynamic tags]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- The family size of a data type (the number of constructors+-- or the arity of a function) can be either:+--    * small, if the family size < 2**tag_bits+--    * big, otherwise.+--+-- Small families can have the constructor tag in the tag bits.+-- Big families only use the tag value 1 to represent evaluatedness.+-- We don't have very many tag bits: for example, we have 2 bits on+-- x86-32 and 3 bits on x86-64.++isSmallFamily :: DynFlags -> Int -> Bool+isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags++-- We keep the *zero-indexed* tag in the srt_len field of the info+-- table of a data constructor.+dataConTagZ :: DataCon -> ConTagZ+dataConTagZ con = dataConTag con - fIRST_TAG++tagForCon :: DynFlags -> DataCon -> DynTag+tagForCon dflags con+  | isSmallFamily dflags fam_size = con_tag + 1+  | otherwise                     = 1+  where+    con_tag  = dataConTagZ con+    fam_size = tyConFamilySize (dataConTyCon con)++tagForArity :: DynFlags -> RepArity -> DynTag+tagForArity dflags arity+ | isSmallFamily dflags arity = arity+ | otherwise                  = 0++lfDynTag :: DynFlags -> LambdaFormInfo -> DynTag+-- Return the tag in the low order bits of a variable bound+-- to this LambdaForm+lfDynTag dflags (LFCon con)                 = tagForCon dflags con+lfDynTag dflags (LFReEntrant _ _ arity _ _) = tagForArity dflags arity+lfDynTag _      _other                      = 0+++-----------------------------------------------------------------------------+--                Observing LambdaFormInfo+-----------------------------------------------------------------------------++-------------+maybeIsLFCon :: LambdaFormInfo -> Maybe DataCon+maybeIsLFCon (LFCon con) = Just con+maybeIsLFCon _ = Nothing++------------+isLFThunk :: LambdaFormInfo -> Bool+isLFThunk (LFThunk {})  = True+isLFThunk _ = False++isLFReEntrant :: LambdaFormInfo -> Bool+isLFReEntrant (LFReEntrant {}) = True+isLFReEntrant _                = False++-----------------------------------------------------------------------------+--                Choosing SM reps+-----------------------------------------------------------------------------++lfClosureType :: LambdaFormInfo -> ClosureTypeInfo+lfClosureType (LFReEntrant _ _ arity _ argd) = Fun arity argd+lfClosureType (LFCon con)                    = Constr (dataConTagZ con)+                                                    (dataConIdentity con)+lfClosureType (LFThunk _ _ _ is_sel _)       = thunkClosureType is_sel+lfClosureType _                              = panic "lfClosureType"++thunkClosureType :: StandardFormInfo -> ClosureTypeInfo+thunkClosureType (SelectorThunk off) = ThunkSelector off+thunkClosureType _                   = Thunk++-- We *do* get non-updatable top-level thunks sometimes.  eg. f = g+-- gets compiled to a jump to g (if g has non-zero arity), instead of+-- messing around with update frames and PAPs.  We set the closure type+-- to FUN_STATIC in this case.++-----------------------------------------------------------------------------+--                nodeMustPointToIt+-----------------------------------------------------------------------------++nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool+-- If nodeMustPointToIt is true, then the entry convention for+-- this closure has R1 (the "Node" register) pointing to the+-- closure itself --- the "self" argument++nodeMustPointToIt _ (LFReEntrant top _ _ no_fvs _)+  =  not no_fvs          -- Certainly if it has fvs we need to point to it+  || isNotTopLevel top   -- See Note [GC recovery]+        -- For lex_profiling we also access the cost centre for a+        -- non-inherited (i.e. non-top-level) function.+        -- The isNotTopLevel test above ensures this is ok.++nodeMustPointToIt dflags (LFThunk top no_fvs updatable NonStandardThunk _)+  =  not no_fvs            -- Self parameter+  || isNotTopLevel top     -- Note [GC recovery]+  || updatable             -- Need to push update frame+  || gopt Opt_SccProfilingOn dflags+          -- For the non-updatable (single-entry case):+          --+          -- True if has fvs (in which case we need access to them, and we+          --                    should black-hole it)+          -- or profiling (in which case we need to recover the cost centre+          --                 from inside it)  ToDo: do we need this even for+          --                                    top-level thunks? If not,+          --                                    isNotTopLevel subsumes this++nodeMustPointToIt _ (LFThunk {})        -- Node must point to a standard-form thunk+  = True++nodeMustPointToIt _ (LFCon _) = True++        -- Strictly speaking, the above two don't need Node to point+        -- to it if the arity = 0.  But this is a *really* unlikely+        -- situation.  If we know it's nil (say) and we are entering+        -- it. Eg: let x = [] in x then we will certainly have inlined+        -- x, since nil is a simple atom.  So we gain little by not+        -- having Node point to known zero-arity things.  On the other+        -- hand, we do lose something; Patrick's code for figuring out+        -- when something has been updated but not entered relies on+        -- having Node point to the result of an update.  SLPJ+        -- 27/11/92.++nodeMustPointToIt _ (LFUnknown _)   = True+nodeMustPointToIt _ LFUnlifted      = False+nodeMustPointToIt _ LFLetNoEscape   = False++{- Note [GC recovery]+~~~~~~~~~~~~~~~~~~~~~+If we a have a local let-binding (function or thunk)+   let f = <body> in ...+AND <body> allocates, then the heap-overflow check needs to know how+to re-start the evaluation.  It uses the "self" pointer to do this.+So even if there are no free variables in <body>, we still make+nodeMustPointToIt be True for non-top-level bindings.++Why do any such bindings exist?  After all, let-floating should have+floated them out.  Well, a clever optimiser might leave one there to+avoid a space leak, deliberately recomputing a thunk.  Also (and this+really does happen occasionally) let-floating may make a function f smaller+so it can be inlined, so now (f True) may generate a local no-fv closure.+This actually happened during bootstrapping GHC itself, with f=mkRdrFunBind+in TcGenDeriv.) -}++-----------------------------------------------------------------------------+--                getCallMethod+-----------------------------------------------------------------------------++{- The entry conventions depend on the type of closure being entered,+whether or not it has free variables, and whether we're running+sequentially or in parallel.++Closure                           Node   Argument   Enter+Characteristics              Par   Req'd  Passing    Via+---------------------------------------------------------------------------+Unknown                     & no  & yes & stack     & node+Known fun (>1 arg), no fvs  & no  & no  & registers & fast entry (enough args)+                                                    & slow entry (otherwise)+Known fun (>1 arg), fvs     & no  & yes & registers & fast entry (enough args)+0 arg, no fvs \r,\s         & no  & no  & n/a       & direct entry+0 arg, no fvs \u            & no  & yes & n/a       & node+0 arg, fvs \r,\s,selector   & no  & yes & n/a       & node+0 arg, fvs \r,\s            & no  & yes & n/a       & direct entry+0 arg, fvs \u               & no  & yes & n/a       & node+Unknown                     & yes & yes & stack     & node+Known fun (>1 arg), no fvs  & yes & no  & registers & fast entry (enough args)+                                                    & slow entry (otherwise)+Known fun (>1 arg), fvs     & yes & yes & registers & node+0 arg, fvs \r,\s,selector   & yes & yes & n/a       & node+0 arg, no fvs \r,\s         & yes & no  & n/a       & direct entry+0 arg, no fvs \u            & yes & yes & n/a       & node+0 arg, fvs \r,\s            & yes & yes & n/a       & node+0 arg, fvs \u               & yes & yes & n/a       & node++When black-holing, single-entry closures could also be entered via node+(rather than directly) to catch double-entry. -}++data CallMethod+  = EnterIt             -- No args, not a function++  | JumpToIt BlockId [LocalReg] -- A join point or a header of a local loop++  | ReturnIt            -- It's a value (function, unboxed value,+                        -- or constructor), so just return it.++  | SlowCall                -- Unknown fun, or known fun with+                        -- too few args.++  | DirectEntry         -- Jump directly, with args in regs+        CLabel          --   The code label+        RepArity        --   Its arity++getCallMethod :: DynFlags+              -> Name           -- Function being applied+              -> Id             -- Function Id used to chech if it can refer to+                                -- CAF's and whether the function is tail-calling+                                -- itself+              -> LambdaFormInfo -- Its info+              -> RepArity       -- Number of available arguments+              -> RepArity       -- Number of them being void arguments+              -> CgLoc          -- Passed in from cgIdApp so that we can+                                -- handle let-no-escape bindings and self-recursive+                                -- tail calls using the same data constructor,+                                -- JumpToIt. This saves us one case branch in+                                -- cgIdApp+              -> Maybe SelfLoopInfo -- can we perform a self-recursive tail call?+              -> CallMethod++getCallMethod dflags _ id _ n_args v_args _cg_loc+              (Just (self_loop_id, block_id, args))+  | gopt Opt_Loopification dflags+  , id == self_loop_id+  , n_args - v_args == length args+  -- If these patterns match then we know that:+  --   * loopification optimisation is turned on+  --   * function is performing a self-recursive call in a tail position+  --   * number of non-void parameters of the function matches functions arity.+  -- See Note [Self-recursive tail calls] and Note [Void arguments in+  -- self-recursive tail calls] in StgCmmExpr for more details+  = JumpToIt block_id args++getCallMethod dflags name id (LFReEntrant _ _ arity _ _) n_args _v_args _cg_loc+              _self_loop_info+  | n_args == 0 -- No args at all+  && not (gopt Opt_SccProfilingOn dflags)+     -- See Note [Evaluating functions with profiling] in rts/Apply.cmm+  = ASSERT( arity /= 0 ) ReturnIt+  | n_args < arity = SlowCall        -- Not enough args+  | otherwise      = DirectEntry (enterIdLabel dflags name (idCafInfo id)) arity++getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info+  = ASSERT( n_args == 0 ) ReturnIt++getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info+  = ASSERT( n_args == 0 ) ReturnIt+    -- n_args=0 because it'd be ill-typed to apply a saturated+    --          constructor application to anything++getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun)+              n_args _v_args _cg_loc _self_loop_info+  | is_fun      -- it *might* be a function, so we must "call" it (which is always safe)+  = SlowCall    -- We cannot just enter it [in eval/apply, the entry code+                -- is the fast-entry code]++  -- Since is_fun is False, we are *definitely* looking at a data value+  | updatable || gopt Opt_Ticky dflags -- to catch double entry+      {- OLD: || opt_SMP+         I decided to remove this, because in SMP mode it doesn't matter+         if we enter the same thunk multiple times, so the optimisation+         of jumping directly to the entry code is still valid.  --SDM+        -}+  = EnterIt++  -- even a non-updatable selector thunk can be updated by the garbage+  -- collector, so we must enter it. (#8817)+  | SelectorThunk{} <- std_form_info+  = EnterIt++    -- We used to have ASSERT( n_args == 0 ), but actually it is+    -- possible for the optimiser to generate+    --   let bot :: Int = error Int "urk"+    --   in (bot `cast` unsafeCoerce Int (Int -> Int)) 3+    -- This happens as a result of the case-of-error transformation+    -- So the right thing to do is just to enter the thing++  | otherwise        -- Jump direct to code for single-entry thunks+  = ASSERT( n_args == 0 )+    DirectEntry (thunkEntryLabel dflags name (idCafInfo id) std_form_info+                updatable) 0++getCallMethod _ _name _ (LFUnknown True) _n_arg _v_args _cg_locs _self_loop_info+  = SlowCall -- might be a function++getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info+  = ASSERT2( n_args == 0, ppr name <+> ppr n_args )+    EnterIt -- Not a function++getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs)+              _self_loop_info+  = JumpToIt blk_id lne_regs++getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method"++-----------------------------------------------------------------------------+--                staticClosureRequired+-----------------------------------------------------------------------------++{-  staticClosureRequired is never called (hence commented out)++    SimonMar writes (Sept 07) It's an optimisation we used to apply at+    one time, I believe, but it got lost probably in the rewrite of+    the RTS/code generator.  I left that code there to remind me to+    look into whether it was worth doing sometime++{- Avoiding generating entries and info tables+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+At present, for every function we generate all of the following,+just in case.  But they aren't always all needed, as noted below:++[NB1: all of this applies only to *functions*.  Thunks always+have closure, info table, and entry code.]++[NB2: All are needed if the function is *exported*, just to play safe.]++* Fast-entry code  ALWAYS NEEDED++* Slow-entry code+        Needed iff (a) we have any un-saturated calls to the function+        OR         (b) the function is passed as an arg+        OR         (c) we're in the parallel world and the function has free vars+                       [Reason: in parallel world, we always enter functions+                       with free vars via the closure.]++* The function closure+        Needed iff (a) we have any un-saturated calls to the function+        OR         (b) the function is passed as an arg+        OR         (c) if the function has free vars (ie not top level)++  Why case (a) here?  Because if the arg-satis check fails,+  UpdatePAP stuffs a pointer to the function closure in the PAP.+  [Could be changed; UpdatePAP could stuff in a code ptr instead,+   but doesn't seem worth it.]++  [NB: these conditions imply that we might need the closure+  without the slow-entry code.  Here's how.++        f x y = let g w = ...x..y..w...+                in+                ...(g t)...++  Here we need a closure for g which contains x and y,+  but since the calls are all saturated we just jump to the+  fast entry point for g, with R1 pointing to the closure for g.]+++* Standard info table+        Needed iff (a) we have any un-saturated calls to the function+        OR         (b) the function is passed as an arg+        OR         (c) the function has free vars (ie not top level)++        NB.  In the sequential world, (c) is only required so that the function closure has+        an info table to point to, to keep the storage manager happy.+        If (c) alone is true we could fake up an info table by choosing+        one of a standard family of info tables, whose entry code just+        bombs out.++        [NB In the parallel world (c) is needed regardless because+        we enter functions with free vars via the closure.]++        If (c) is retained, then we'll sometimes generate an info table+        (for storage mgr purposes) without slow-entry code.  Then we need+        to use an error label in the info table to substitute for the absent+        slow entry code.+-}++staticClosureRequired+        :: Name+        -> StgBinderInfo+        -> LambdaFormInfo+        -> Bool+staticClosureRequired binder bndr_info+                      (LFReEntrant top_level _ _ _ _)        -- It's a function+  = ASSERT( isTopLevel top_level )+        -- Assumption: it's a top-level, no-free-var binding+        not (satCallsOnly bndr_info)++staticClosureRequired binder other_binder_info other_lf_info = True+-}++-----------------------------------------------------------------------------+--              Data types for closure information+-----------------------------------------------------------------------------+++{- ClosureInfo: information about a binding++   We make a ClosureInfo for each let binding (both top level and not),+   but not bindings for data constructors: for those we build a CmmInfoTable+   directly (see mkDataConInfoTable).++   To a first approximation:+       ClosureInfo = (LambdaFormInfo, CmmInfoTable)++   A ClosureInfo has enough information+     a) to construct the info table itself, and build other things+        related to the binding (e.g. slow entry points for a function)+     b) to allocate a closure containing that info pointer (i.e.+           it knows the info table label)+-}++data ClosureInfo+  = ClosureInfo {+        closureName :: !Name,           -- The thing bound to this closure+           -- we don't really need this field: it's only used in generating+           -- code for ticky and profiling, and we could pass the information+           -- around separately, but it doesn't do much harm to keep it here.++        closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon+          -- this tells us about what the closure contains: it's right-hand-side.++          -- the rest is just an unpacked CmmInfoTable.+        closureInfoLabel :: !CLabel,+        closureSMRep     :: !SMRep,          -- representation used by storage mgr+        closureProf      :: !ProfilingInfo+    }++-- | Convert from 'ClosureInfo' to 'CmmInfoTable'.+mkCmmInfo :: ClosureInfo -> CmmInfoTable+mkCmmInfo ClosureInfo {..}+  = CmmInfoTable { cit_lbl  = closureInfoLabel+                 , cit_rep  = closureSMRep+                 , cit_prof = closureProf+                 , cit_srt  = NoC_SRT }++--------------------------------------+--        Building ClosureInfos+--------------------------------------++mkClosureInfo :: DynFlags+              -> Bool                -- Is static+              -> Id+              -> LambdaFormInfo+              -> Int -> Int        -- Total and pointer words+              -> String         -- String descriptor+              -> ClosureInfo+mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr+  = ClosureInfo { closureName      = name+                , closureLFInfo    = lf_info+                , closureInfoLabel = info_lbl   -- These three fields are+                , closureSMRep     = sm_rep     -- (almost) an info table+                , closureProf      = prof }     -- (we don't have an SRT yet)+  where+    name       = idName id+    sm_rep     = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info)+    prof       = mkProfilingInfo dflags id val_descr+    nonptr_wds = tot_wds - ptr_wds++    info_lbl = mkClosureInfoTableLabel id lf_info++--------------------------------------+--   Other functions over ClosureInfo+--------------------------------------++-- Eager blackholing is normally disabled, but can be turned on with+-- -feager-blackholing.  When it is on, we replace the info pointer of+-- the thunk with stg_EAGER_BLACKHOLE_info on entry.++-- If we wanted to do eager blackholing with slop filling,+-- we'd need to do it at the *end* of a basic block, otherwise+-- we overwrite the free variables in the thunk that we still+-- need.  We have a patch for this from Andy Cheadle, but not+-- incorporated yet. --SDM [6/2004]+--+-- Previously, eager blackholing was enabled when ticky-ticky+-- was on. But it didn't work, and it wasn't strictly necessary+-- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING+-- is unconditionally disabled. -- krc 1/2007+--+-- Static closures are never themselves black-holed.++blackHoleOnEntry :: ClosureInfo -> Bool+blackHoleOnEntry cl_info+  | isStaticRep (closureSMRep cl_info)+  = False        -- Never black-hole a static closure++  | otherwise+  = case closureLFInfo cl_info of+      LFReEntrant {}            -> False+      LFLetNoEscape             -> False+      LFThunk _ _no_fvs upd _ _ -> upd   -- See Note [Black-holing non-updatable thunks]+      _other -> panic "blackHoleOnEntry"++{- Note [Black-holing non-updatable thunks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must not black-hole non-updatable (single-entry) thunks otherwise+we run into issues like Trac #10414. Specifically:++  * There is no reason to black-hole a non-updatable thunk: it should+    not be competed for by multiple threads++  * It could, conceivably, cause a space leak if we don't black-hole+    it, if there was a live but never-followed pointer pointing to it.+    Let's hope that doesn't happen.++  * It is dangerous to black-hole a non-updatable thunk because+     - is not updated (of course)+     - hence, if it is black-holed and another thread tries to evaluate+       it, that thread will block forever+    This actually happened in Trac #10414.  So we do not black-hole+    non-updatable thunks.++  * How could two threads evaluate the same non-updatable (single-entry)+    thunk?  See Reid Barton's example below.++  * Only eager blackholing could possibly black-hole a non-updatable+    thunk, because lazy black-holing only affects thunks with an+    update frame on the stack.++Here is and example due to Reid Barton (Trac #10414):+    x = \u []  concat [[1], []]+with the following definitions,++    concat x = case x of+        []       -> []+        (:) x xs -> (++) x (concat xs)++    (++) xs ys = case xs of+        []         -> ys+        (:) x rest -> (:) x ((++) rest ys)++Where we use the syntax @\u []@ to denote an updatable thunk and @\s []@ to+denote a single-entry (i.e. non-updatable) thunk. After a thread evaluates @x@+to WHNF and calls @(++)@ the heap will contain the following thunks,++    x = 1 : y+    y = \u []  (++) [] z+    z = \s []  concat []++Now that the stage is set, consider the follow evaluations by two racing threads+A and B,++  1. Both threads enter @y@ before either is able to replace it with an+     indirection++  2. Thread A does the case analysis in @(++)@ and consequently enters @z@,+     replacing it with a black-hole++  3. At some later point thread B does the same case analysis and also attempts+     to enter @z@. However, it finds that it has been replaced with a black-hole+     so it blocks.++  4. Thread A eventually finishes evaluating @z@ (to @[]@) and updates @y@+     accordingly. It does *not* update @z@, however, as it is single-entry. This+     leaves Thread B blocked forever on a black-hole which will never be+     updated.++To avoid this sort of condition we never black-hole non-updatable thunks.+-}++isStaticClosure :: ClosureInfo -> Bool+isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)++closureUpdReqd :: ClosureInfo -> Bool+closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info++lfUpdatable :: LambdaFormInfo -> Bool+lfUpdatable (LFThunk _ _ upd _ _)  = upd+lfUpdatable _ = False++closureSingleEntry :: ClosureInfo -> Bool+closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd+closureSingleEntry (ClosureInfo { closureLFInfo = LFReEntrant _ OneShotLam _ _ _}) = True+closureSingleEntry _ = False++closureReEntrant :: ClosureInfo -> Bool+closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant {} }) = True+closureReEntrant _ = False++closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr)+closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info++lfFunInfo :: LambdaFormInfo ->  Maybe (RepArity, ArgDescr)+lfFunInfo (LFReEntrant _ _ arity _ arg_desc)  = Just (arity, arg_desc)+lfFunInfo _                                   = Nothing++funTag :: DynFlags -> ClosureInfo -> DynTag+funTag dflags (ClosureInfo { closureLFInfo = lf_info })+    = lfDynTag dflags lf_info++isToplevClosure :: ClosureInfo -> Bool+isToplevClosure (ClosureInfo { closureLFInfo = lf_info })+  = case lf_info of+      LFReEntrant TopLevel _ _ _ _ -> True+      LFThunk TopLevel _ _ _ _     -> True+      _other                       -> False++--------------------------------------+--   Label generation+--------------------------------------++staticClosureLabel :: ClosureInfo -> CLabel+staticClosureLabel = toClosureLbl .  closureInfoLabel++closureSlowEntryLabel :: ClosureInfo -> CLabel+closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel++closureLocalEntryLabel :: DynFlags -> ClosureInfo -> CLabel+closureLocalEntryLabel dflags+  | tablesNextToCode dflags = toInfoLbl  . closureInfoLabel+  | otherwise               = toEntryLbl . closureInfoLabel++mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel+mkClosureInfoTableLabel id lf_info+  = case lf_info of+        LFThunk _ _ upd_flag (SelectorThunk offset) _+                      -> mkSelectorInfoLabel upd_flag offset++        LFThunk _ _ upd_flag (ApThunk arity) _+                      -> mkApInfoTableLabel upd_flag arity++        LFThunk{}     -> std_mk_lbl name cafs+        LFReEntrant{} -> std_mk_lbl name cafs+        _other        -> panic "closureInfoTableLabel"++  where+    name = idName id++    std_mk_lbl | is_local  = mkLocalInfoTableLabel+               | otherwise = mkInfoTableLabel++    cafs     = idCafInfo id+    is_local = isDataConWorkId id+       -- Make the _info pointer for the implicit datacon worker+       -- binding local. The reason we can do this is that importing+       -- code always either uses the _closure or _con_info. By the+       -- invariants in CorePrep anything else gets eta expanded.+++thunkEntryLabel :: DynFlags -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel+-- thunkEntryLabel is a local help function, not exported.  It's used from+-- getCallMethod.+thunkEntryLabel dflags _thunk_id _ (ApThunk arity) upd_flag+  = enterApLabel dflags upd_flag arity+thunkEntryLabel dflags _thunk_id _ (SelectorThunk offset) upd_flag+  = enterSelectorLabel dflags upd_flag offset+thunkEntryLabel dflags thunk_id c _ _+  = enterIdLabel dflags thunk_id c++enterApLabel :: DynFlags -> Bool -> Arity -> CLabel+enterApLabel dflags is_updatable arity+  | tablesNextToCode dflags = mkApInfoTableLabel is_updatable arity+  | otherwise               = mkApEntryLabel is_updatable arity++enterSelectorLabel :: DynFlags -> Bool -> WordOff -> CLabel+enterSelectorLabel dflags upd_flag offset+  | tablesNextToCode dflags = mkSelectorInfoLabel upd_flag offset+  | otherwise               = mkSelectorEntryLabel upd_flag offset++enterIdLabel :: DynFlags -> Name -> CafInfo -> CLabel+enterIdLabel dflags id c+  | tablesNextToCode dflags = mkInfoTableLabel id c+  | otherwise               = mkEntryLabel id c+++--------------------------------------+--   Profiling+--------------------------------------++-- Profiling requires two pieces of information to be determined for+-- each closure's info table --- description and type.++-- The description is stored directly in the @CClosureInfoTable@ when the+-- info table is built.++-- The type is determined from the type information stored with the @Id@+-- in the closure info using @closureTypeDescr@.++mkProfilingInfo :: DynFlags -> Id -> String -> ProfilingInfo+mkProfilingInfo dflags id val_descr+  | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo+  | otherwise = ProfilingInfo ty_descr_w8 val_descr_w8+  where+    ty_descr_w8  = stringToWord8s (getTyDescription (idType id))+    val_descr_w8 = stringToWord8s val_descr++getTyDescription :: Type -> String+getTyDescription ty+  = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->+    case tau_ty of+      TyVarTy _              -> "*"+      AppTy fun _            -> getTyDescription fun+      TyConApp tycon _       -> getOccString tycon+      FunTy _ res            -> '-' : '>' : fun_result res+      ForAllTy _  ty         -> getTyDescription ty+      LitTy n                -> getTyLitDescription n+      CastTy ty _            -> getTyDescription ty+      CoercionTy co          -> pprPanic "getTyDescription" (ppr co)+    }+  where+    fun_result (FunTy _ res) = '>' : fun_result res+    fun_result other         = getTyDescription other++getTyLitDescription :: TyLit -> String+getTyLitDescription l =+  case l of+    NumTyLit n -> show n+    StrTyLit n -> show n++--------------------------------------+--   CmmInfoTable-related things+--------------------------------------++mkDataConInfoTable :: DynFlags -> DataCon -> Bool -> Int -> Int -> CmmInfoTable+mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds+ = CmmInfoTable { cit_lbl  = info_lbl+                , cit_rep  = sm_rep+                , cit_prof = prof+                , cit_srt  = NoC_SRT }+ where+   name = dataConName data_con+   info_lbl = mkConInfoTableLabel name NoCafRefs+   sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type+   cl_type = Constr (dataConTagZ data_con) (dataConIdentity data_con)++   prof | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo+        | otherwise                            = ProfilingInfo ty_descr val_descr++   ty_descr  = stringToWord8s $ occNameString $ getOccName $ dataConTyCon data_con+   val_descr = stringToWord8s $ occNameString $ getOccName data_con++-- We need a black-hole closure info to pass to @allocDynClosure@ when we+-- want to allocate the black hole on entry to a CAF.++cafBlackHoleInfoTable :: CmmInfoTable+cafBlackHoleInfoTable+  = CmmInfoTable { cit_lbl  = mkCAFBlackHoleInfoTableLabel+                 , cit_rep  = blackHoleRep+                 , cit_prof = NoProfilingInfo+                 , cit_srt  = NoC_SRT }++indStaticInfoTable :: CmmInfoTable+indStaticInfoTable+  = CmmInfoTable { cit_lbl  = mkIndStaticInfoLabel+                 , cit_rep  = indStaticRep+                 , cit_prof = NoProfilingInfo+                 , cit_srt  = NoC_SRT }++staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool+-- A static closure needs a link field to aid the GC when traversing+-- the static closure graph.  But it only needs such a field if either+--        a) it has an SRT+--        b) it's a constructor with one or more pointer fields+-- In case (b), the constructor's fields themselves play the role+-- of the SRT.+staticClosureNeedsLink has_srt CmmInfoTable{ cit_rep = smrep }+  | isConRep smrep         = not (isStaticNoCafCon smrep)+  | otherwise              = has_srt -- needsSRT (cit_srt info_tbl)
+ codeGen/StgCmmCon.hs view
@@ -0,0 +1,279 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Stg to C--: code generation for constructors+--+-- This module provides the support code for StgCmm to deal with with+-- constructors on the RHSs of let(rec)s.+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module StgCmmCon (+        cgTopRhsCon, buildDynCon, bindConArgs+    ) where++#include "HsVersions.h"++import StgSyn+import CoreSyn  ( AltCon(..) )++import StgCmmMonad+import StgCmmEnv+import StgCmmHeap+import StgCmmLayout+import StgCmmUtils+import StgCmmClosure+import StgCmmProf ( curCCS )++import CmmExpr+import CLabel+import MkGraph+import SMRep+import CostCentre+import Module+import DataCon+import DynFlags+import FastString+import Id+import RepType (countConRepArgs)+import Literal+import PrelInfo+import Outputable+import Platform+import Util+import MonadUtils (mapMaybeM)++import Control.Monad+import Data.Char++++---------------------------------------------------------------+--      Top-level constructors+---------------------------------------------------------------++cgTopRhsCon :: DynFlags+            -> Id               -- Name of thing bound to this RHS+            -> DataCon          -- Id+            -> [NonVoid StgArg] -- Args+            -> (CgIdInfo, FCode ())+cgTopRhsCon dflags id con args =+    let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label)+    in (id_info, gen_code)+  where+   name          = idName id+   caffy         = idCafInfo id -- any stgArgHasCafRefs args+   closure_label = mkClosureLabel name caffy++   gen_code =+     do { this_mod <- getModuleName+        ; when (platformOS (targetPlatform dflags) == OSMinGW32) $+              -- Windows DLLs have a problem with static cross-DLL refs.+              MASSERT( not (isDllConApp dflags this_mod con (map fromNonVoid args)) )+        ; ASSERT( args `lengthIs` countConRepArgs con ) return ()++        -- LAY IT OUT+        ; let+            (tot_wds, --  #ptr_wds + #nonptr_wds+             ptr_wds, --  #ptr_wds+             nv_args_w_offsets) = mkVirtConstrOffsets dflags (addArgReps args)++            nonptr_wds = tot_wds - ptr_wds++             -- we're not really going to emit an info table, so having+             -- to make a CmmInfoTable is a bit overkill, but mkStaticClosureFields+             -- needs to poke around inside it.+            info_tbl = mkDataConInfoTable dflags con True ptr_wds nonptr_wds++            get_lit (arg, _offset) = do { CmmLit lit <- getArgAmode arg+                                        ; return lit }++        ; payload <- mapM get_lit nv_args_w_offsets+                -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs+                -- NB2: all the amodes should be Lits!+                --      TODO (osa): Why?++        ; let closure_rep = mkStaticClosureFields+                             dflags+                             info_tbl+                             dontCareCCS                -- Because it's static data+                             caffy                      -- Has CAF refs+                             payload++                -- BUILD THE OBJECT+        ; emitDataLits closure_label closure_rep++        ; return () }+++---------------------------------------------------------------+--      Lay out and allocate non-top-level constructors+---------------------------------------------------------------++buildDynCon :: Id                 -- Name of the thing to which this constr will+                                  -- be bound+            -> Bool               -- is it genuinely bound to that name, or just+                                  -- for profiling?+            -> CostCentreStack    -- Where to grab cost centre from;+                                  -- current CCS if currentOrSubsumedCCS+            -> DataCon            -- The data constructor+            -> [NonVoid StgArg]   -- Its args+            -> FCode (CgIdInfo, FCode CmmAGraph)+               -- Return details about how to find it and initialization code+buildDynCon binder actually_bound cc con args+    = do dflags <- getDynFlags+         buildDynCon' dflags (targetPlatform dflags) binder actually_bound cc con args+++buildDynCon' :: DynFlags+             -> Platform+             -> Id -> Bool+             -> CostCentreStack+             -> DataCon+             -> [NonVoid StgArg]+             -> FCode (CgIdInfo, FCode CmmAGraph)++{- We used to pass a boolean indicating whether all the+args were of size zero, so we could use a static+constructor; but I concluded that it just isn't worth it.+Now I/O uses unboxed tuples there just aren't any constructors+with all size-zero args.++The reason for having a separate argument, rather than looking at+the addr modes of the args is that we may be in a "knot", and+premature looking at the args will cause the compiler to black-hole!+-}+++-------- buildDynCon': Nullary constructors --------------+-- First we deal with the case of zero-arity constructors.  They+-- will probably be unfolded, so we don't expect to see this case much,+-- if at all, but it does no harm, and sets the scene for characters.+--+-- In the case of zero-arity constructors, or, more accurately, those+-- which have exclusively size-zero (VoidRep) args, we generate no code+-- at all.++buildDynCon' dflags _ binder _ _cc con []+  | isNullaryRepDataCon con+  = return (litIdInfo dflags binder (mkConLFInfo con)+                (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))),+            return mkNop)++-------- buildDynCon': Charlike and Intlike constructors -----------+{- The following three paragraphs about @Char@-like and @Int@-like+closures are obsolete, but I don't understand the details well enough+to properly word them, sorry. I've changed the treatment of @Char@s to+be analogous to @Int@s: only a subset is preallocated, because @Char@+has now 31 bits. Only literals are handled here. -- Qrczak++Now for @Char@-like closures.  We generate an assignment of the+address of the closure to a temporary.  It would be possible simply to+generate no code, and record the addressing mode in the environment,+but we'd have to be careful if the argument wasn't a constant --- so+for simplicity we just always assign to a temporary.++Last special case: @Int@-like closures.  We only special-case the+situation in which the argument is a literal in the range+@mIN_INTLIKE@..@mAX_INTLILKE@.  NB: for @Char@-like closures we can+work with any old argument, but for @Int@-like ones the argument has+to be a literal.  Reason: @Char@ like closures have an argument type+which is guaranteed in range.++Because of this, we use can safely return an addressing mode.++We don't support this optimisation when compiling into Windows DLLs yet+because they don't support cross package data references well.+-}++buildDynCon' dflags platform binder _ _cc con [arg]+  | maybeIntLikeCon con+  , platformOS platform /= OSMinGW32 || not (gopt Opt_PIC dflags)+  , NonVoid (StgLitArg (MachInt val)) <- arg+  , val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer!+  , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto...+  = do  { let intlike_lbl   = mkCmmClosureLabel rtsUnitId (fsLit "stg_INTLIKE")+              val_int = fromIntegral val :: Int+              offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSizeW dflags + 1)+                -- INTLIKE closures consist of a header and one word payload+              intlike_amode = cmmLabelOffW dflags intlike_lbl offsetW+        ; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode+                 , return mkNop) }++buildDynCon' dflags platform binder _ _cc con [arg]+  | maybeCharLikeCon con+  , platformOS platform /= OSMinGW32 || not (gopt Opt_PIC dflags)+  , NonVoid (StgLitArg (MachChar val)) <- arg+  , let val_int = ord val :: Int+  , val_int <= mAX_CHARLIKE dflags+  , val_int >= mIN_CHARLIKE dflags+  = do  { let charlike_lbl   = mkCmmClosureLabel rtsUnitId (fsLit "stg_CHARLIKE")+              offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSizeW dflags + 1)+                -- CHARLIKE closures consist of a header and one word payload+              charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW+        ; return ( litIdInfo dflags binder (mkConLFInfo con) charlike_amode+                 , return mkNop) }++-------- buildDynCon': the general case -----------+buildDynCon' dflags _ binder actually_bound ccs con args+  = do  { (id_info, reg) <- rhsIdInfo binder lf_info+        ; return (id_info, gen_code reg)+        }+ where+  lf_info = mkConLFInfo con++  gen_code reg+    = do  { let (tot_wds, ptr_wds, args_w_offsets)+                  = mkVirtConstrOffsets dflags (addArgReps args)+                nonptr_wds = tot_wds - ptr_wds+                info_tbl = mkDataConInfoTable dflags con False+                                ptr_wds nonptr_wds+          ; let ticky_name | actually_bound = Just binder+                           | otherwise = Nothing++          ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info+                                          use_cc blame_cc args_w_offsets+          ; return (mkRhsInit dflags reg lf_info hp_plus_n) }+    where+      use_cc      -- cost-centre to stick in the object+        | isCurrentCCS ccs = curCCS+        | otherwise        = panic "buildDynCon: non-current CCS not implemented"++      blame_cc = use_cc -- cost-centre on which to blame the alloc (same)+++---------------------------------------------------------------+--      Binding constructor arguments+---------------------------------------------------------------++bindConArgs :: AltCon -> LocalReg -> [NonVoid Id] -> FCode [LocalReg]+-- bindConArgs is called from cgAlt of a case+-- (bindConArgs con args) augments the environment with bindings for the+-- binders args, assuming that we have just returned from a 'case' which+-- found a con+bindConArgs (DataAlt con) base args+  = ASSERT(not (isUnboxedTupleCon con))+    do dflags <- getDynFlags+       let (_, _, args_w_offsets) = mkVirtConstrOffsets dflags (addIdReps args)+           tag = tagForCon dflags con++           -- The binding below forces the masking out of the tag bits+           -- when accessing the constructor field.+           bind_arg :: (NonVoid Id, VirtualHpOffset) -> FCode (Maybe LocalReg)+           bind_arg (arg@(NonVoid b), offset)+             | isDeadBinder b =+                 -- Do not load unused fields from objects to local variables.+                 -- (CmmSink can optimize this, but it's cheap and common enough+                 -- to handle here)+                 return Nothing+             | otherwise      = do+                 emit $ mkTaggedObjectLoad dflags (idToReg dflags arg) base offset tag+                 Just <$> bindArgToReg arg++       mapMaybeM bind_arg args_w_offsets++bindConArgs _other_con _base args+  = ASSERT( null args ) return []
+ codeGen/StgCmmEnv.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Stg to C-- code generation: the binding environment+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------+module StgCmmEnv (+        CgIdInfo,++        litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit,+        idInfoToAmode,++        addBindC, addBindsC,++        bindArgsToRegs, bindToReg, rebindToReg,+        bindArgToReg, idToReg,+        getArgAmode, getNonVoidArgAmodes,+        getCgIdInfo,+        maybeLetNoEscape,+    ) where++#include "HsVersions.h"++import TyCon+import StgCmmMonad+import StgCmmUtils+import StgCmmClosure++import CLabel++import BlockId+import CmmExpr+import CmmUtils+import DynFlags+import Id+import MkGraph+import Name+import Outputable+import StgSyn+import Type+import TysPrim+import UniqFM+import Util+import VarEnv++-------------------------------------+--        Manipulating CgIdInfo+-------------------------------------++mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo+mkCgIdInfo id lf expr+  = CgIdInfo { cg_id = id, cg_lf = lf+             , cg_loc = CmmLoc expr }++litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo+litIdInfo dflags id lf lit+  = CgIdInfo { cg_id = id, cg_lf = lf+             , cg_loc = CmmLoc (addDynTag dflags (CmmLit lit) tag) }+  where+    tag = lfDynTag dflags lf++lneIdInfo :: DynFlags -> Id -> [NonVoid Id] -> CgIdInfo+lneIdInfo dflags id regs+  = CgIdInfo { cg_id = id, cg_lf = lf+             , cg_loc = LneLoc blk_id (map (idToReg dflags) regs) }+  where+    lf     = mkLFLetNoEscape+    blk_id = mkBlockId (idUnique id)+++rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)+rhsIdInfo id lf_info+  = do dflags <- getDynFlags+       reg <- newTemp (gcWord dflags)+       return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg)++mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph+mkRhsInit dflags reg lf_info expr+  = mkAssign (CmmLocal reg) (addDynTag dflags expr (lfDynTag dflags lf_info))++idInfoToAmode :: CgIdInfo -> CmmExpr+-- Returns a CmmExpr for the *tagged* pointer+idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e+idInfoToAmode cg_info+  = pprPanic "idInfoToAmode" (ppr (cg_id cg_info))        -- LneLoc++addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr+-- A tag adds a byte offset to the pointer+addDynTag dflags expr tag = cmmOffsetB dflags expr tag++maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])+maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args)+maybeLetNoEscape _other                                      = Nothing++++---------------------------------------------------------+--        The binding environment+--+-- There are three basic routines, for adding (addBindC),+-- modifying(modifyBindC) and looking up (getCgIdInfo) bindings.+---------------------------------------------------------++addBindC :: CgIdInfo -> FCode ()+addBindC stuff_to_bind = do+        binds <- getBinds+        setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind++addBindsC :: [CgIdInfo] -> FCode ()+addBindsC new_bindings = do+        binds <- getBinds+        let new_binds = foldl (\ binds info -> extendVarEnv binds (cg_id info) info)+                              binds+                              new_bindings+        setBinds new_binds++getCgIdInfo :: Id -> FCode CgIdInfo+getCgIdInfo id+  = do  { dflags <- getDynFlags+        ; local_binds <- getBinds -- Try local bindings first+        ; case lookupVarEnv local_binds id of {+            Just info -> return info ;+            Nothing   -> do {++                -- Should be imported; make up a CgIdInfo for it+          let name = idName id+        ; if isExternalName name then+              let ext_lbl+                      | isUnliftedType (idType id) =+                          -- An unlifted external Id must refer to a top-level+                          -- string literal. See Note [Bytes label] in CLabel.+                          ASSERT( idType id `eqType` addrPrimTy )+                          mkBytesLabel name+                      | otherwise = mkClosureLabel name $ idCafInfo id+              in return $+                  litIdInfo dflags id (mkLFImported id) (CmmLabel ext_lbl)+          else+              cgLookupPanic id -- Bug+        }}}++cgLookupPanic :: Id -> FCode a+cgLookupPanic id+  = do  local_binds <- getBinds+        pprPanic "StgCmmEnv: variable not found"+                (vcat [ppr id,+                text "local binds for:",+                pprUFM local_binds $ \infos ->+                  vcat [ ppr (cg_id info) | info <- infos ]+              ])+++--------------------+getArgAmode :: NonVoid StgArg -> FCode CmmExpr+getArgAmode (NonVoid (StgVarArg var)) = idInfoToAmode <$> getCgIdInfo var+getArgAmode (NonVoid (StgLitArg lit)) = CmmLit <$> cgLit lit++getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]+-- NB: Filters out void args,+--     so the result list may be shorter than the argument list+getNonVoidArgAmodes [] = return []+getNonVoidArgAmodes (arg:args)+  | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args+  | otherwise = do { amode  <- getArgAmode (NonVoid arg)+                   ; amodes <- getNonVoidArgAmodes args+                   ; return ( amode : amodes ) }+++------------------------------------------------------------------------+--        Interface functions for binding and re-binding names+------------------------------------------------------------------------++bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg+-- Bind an Id to a fresh LocalReg+bindToReg nvid@(NonVoid id) lf_info+  = do dflags <- getDynFlags+       let reg = idToReg dflags nvid+       addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))+       return reg++rebindToReg :: NonVoid Id -> FCode LocalReg+-- Like bindToReg, but the Id is already in scope, so+-- get its LF info from the envt+rebindToReg nvid@(NonVoid id)+  = do  { info <- getCgIdInfo id+        ; bindToReg nvid (cg_lf info) }++bindArgToReg :: NonVoid Id -> FCode LocalReg+bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)++bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]+bindArgsToRegs args = mapM bindArgToReg args++idToReg :: DynFlags -> NonVoid Id -> LocalReg+-- Make a register from an Id, typically a function argument,+-- free variable, or case binder+--+-- We re-use the Unique from the Id to make it easier to see what is going on+--+-- By now the Ids should be uniquely named; else one would worry+-- about accidental collision+idToReg dflags (NonVoid id)+             = LocalReg (idUnique id)+                        (primRepCmmType dflags (idPrimRep id))
+ codeGen/StgCmmExpr.hs view
@@ -0,0 +1,943 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}++-----------------------------------------------------------------------------+--+-- Stg to C-- code generation: expressions+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module StgCmmExpr ( cgExpr ) where++#include "HsVersions.h"++import {-# SOURCE #-} StgCmmBind ( cgBind )++import StgCmmMonad+import StgCmmHeap+import StgCmmEnv+import StgCmmCon+import StgCmmProf (saveCurrentCostCentre, restoreCurrentCostCentre, emitSetCCC)+import StgCmmLayout+import StgCmmPrim+import StgCmmHpc+import StgCmmTicky+import StgCmmUtils+import StgCmmClosure++import StgSyn++import MkGraph+import BlockId+import Cmm+import CmmInfo+import CoreSyn+import DataCon+import ForeignCall+import Id+import PrimOp+import TyCon+import Type             ( isUnliftedType )+import RepType          ( isVoidTy, countConRepArgs, primRepSlot )+import CostCentre       ( CostCentreStack, currentCCS )+import Maybes+import Util+import FastString+import Outputable++import Control.Monad (unless,void)+import Control.Arrow (first)+import Data.Function ( on )++import Prelude hiding ((<*>))++------------------------------------------------------------------------+--              cgExpr: the main function+------------------------------------------------------------------------++cgExpr  :: StgExpr -> FCode ReturnKind++cgExpr (StgApp fun args)     = cgIdApp fun args++{- seq# a s ==> a -}+cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) =+  cgIdApp a []++cgExpr (StgOpApp op args ty) = cgOpApp op args ty+cgExpr (StgConApp con args _)= cgConApp con args+cgExpr (StgTick t e)         = cgTick t >> cgExpr e+cgExpr (StgLit lit)       = do cmm_lit <- cgLit lit+                               emitReturn [CmmLit cmm_lit]++cgExpr (StgLet binds expr)             = do { cgBind binds;     cgExpr expr }+cgExpr (StgLetNoEscape binds expr) =+  do { u <- newUnique+     ; let join_id = mkBlockId u+     ; cgLneBinds join_id binds+     ; r <- cgExpr expr+     ; emitLabel join_id+     ; return r }++cgExpr (StgCase expr bndr alt_type alts) =+  cgCase expr bndr alt_type alts++cgExpr (StgLam {}) = panic "cgExpr: StgLam"++------------------------------------------------------------------------+--              Let no escape+------------------------------------------------------------------------++{- Generating code for a let-no-escape binding, aka join point is very+very similar to what we do for a case expression.  The duality is+between+        let-no-escape x = b+        in e+and+        case e of ... -> b++That is, the RHS of 'x' (ie 'b') will execute *later*, just like+the alternative of the case; it needs to be compiled in an environment+in which all volatile bindings are forgotten, and the free vars are+bound only to stable things like stack locations..  The 'e' part will+execute *next*, just like the scrutinee of a case. -}++-------------------------+cgLneBinds :: BlockId -> StgBinding -> FCode ()+cgLneBinds join_id (StgNonRec bndr rhs)+  = do  { local_cc <- saveCurrentCostCentre+                -- See Note [Saving the current cost centre]+        ; (info, fcode) <- cgLetNoEscapeRhs join_id local_cc bndr rhs+        ; fcode+        ; addBindC info }++cgLneBinds join_id (StgRec pairs)+  = do  { local_cc <- saveCurrentCostCentre+        ; r <- sequence $ unzipWith (cgLetNoEscapeRhs join_id local_cc) pairs+        ; let (infos, fcodes) = unzip r+        ; addBindsC infos+        ; sequence_ fcodes+        }++-------------------------+cgLetNoEscapeRhs+    :: BlockId          -- join point for successor of let-no-escape+    -> Maybe LocalReg   -- Saved cost centre+    -> Id+    -> StgRhs+    -> FCode (CgIdInfo, FCode ())++cgLetNoEscapeRhs join_id local_cc bndr rhs =+  do { (info, rhs_code) <- cgLetNoEscapeRhsBody local_cc bndr rhs+     ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info+     ; let code = do { (_, body) <- getCodeScoped rhs_code+                     ; emitOutOfLine bid (first (<*> mkBranch join_id) body) }+     ; return (info, code)+     }++cgLetNoEscapeRhsBody+    :: Maybe LocalReg   -- Saved cost centre+    -> Id+    -> StgRhs+    -> FCode (CgIdInfo, FCode ())+cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd args body)+  = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body+cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)+  = cgLetNoEscapeClosure bndr local_cc cc []+      (StgConApp con args (pprPanic "cgLetNoEscapeRhsBody" $+                           text "StgRhsCon doesn't have type args"))+        -- For a constructor RHS we want to generate a single chunk of+        -- code which can be jumped to from many places, which will+        -- return the constructor. It's easy; just behave as if it+        -- was an StgRhsClosure with a ConApp inside!++-------------------------+cgLetNoEscapeClosure+        :: Id                   -- binder+        -> Maybe LocalReg       -- Slot for saved current cost centre+        -> CostCentreStack      -- XXX: *** NOT USED *** why not?+        -> [NonVoid Id]         -- Args (as in \ args -> body)+        -> StgExpr              -- Body (as in above)+        -> FCode (CgIdInfo, FCode ())++cgLetNoEscapeClosure bndr cc_slot _unused_cc args body+  = do dflags <- getDynFlags+       return ( lneIdInfo dflags bndr args+              , code )+  where+   code = forkLneBody $ do {+            ; withNewTickyCounterLNE (idName bndr) args $ do+            ; restoreCurrentCostCentre cc_slot+            ; arg_regs <- bindArgsToRegs args+            ; void $ noEscapeHeapCheck arg_regs (tickyEnterLNE >> cgExpr body) }+++------------------------------------------------------------------------+--              Case expressions+------------------------------------------------------------------------++{- Note [Compiling case expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is quite interesting to decide whether to put a heap-check at the+start of each alternative.  Of course we certainly have to do so if+the case forces an evaluation, or if there is a primitive op which can+trigger GC.++A more interesting situation is this (a Plan-B situation)++        !P!;+        ...P...+        case x# of+          0#      -> !Q!; ...Q...+          default -> !R!; ...R...++where !x! indicates a possible heap-check point. The heap checks+in the alternatives *can* be omitted, in which case the topmost+heapcheck will take their worst case into account.++In favour of omitting !Q!, !R!:++ - *May* save a heap overflow test,+   if ...P... allocates anything.++ - We can use relative addressing from a single Hp to+   get at all the closures so allocated.++ - No need to save volatile vars etc across heap checks+   in !Q!, !R!++Against omitting !Q!, !R!++  - May put a heap-check into the inner loop.  Suppose+        the main loop is P -> R -> P -> R...+        Q is the loop exit, and only it does allocation.+    This only hurts us if P does no allocation.  If P allocates,+    then there is a heap check in the inner loop anyway.++  - May do more allocation than reqd.  This sometimes bites us+    badly.  For example, nfib (ha!) allocates about 30\% more space if the+    worst-casing is done, because many many calls to nfib are leaf calls+    which don't need to allocate anything.++    We can un-allocate, but that costs an instruction++Neither problem hurts us if there is only one alternative.++Suppose the inner loop is P->R->P->R etc.  Then here is+how many heap checks we get in the *inner loop* under various+conditions++  Alloc   Heap check in branches (!Q!, !R!)?+  P Q R      yes     no (absorb to !P!)+--------------------------------------+  n n n      0          0+  n y n      0          1+  n . y      1          1+  y . y      2          1+  y . n      1          1++Best choices: absorb heap checks from Q and R into !P! iff+  a) P itself does some allocation+or+  b) P does allocation, or there is exactly one alternative++We adopt (b) because that is more likely to put the heap check at the+entry to a function, when not many things are live.  After a bunch of+single-branch cases, we may have lots of things live++Hence: two basic plans for++        case e of r { alts }++------ Plan A: the general case ---------++        ...save current cost centre...++        ...code for e,+           with sequel (SetLocals r)++        ...restore current cost centre...+        ...code for alts...+        ...alts do their own heap checks++------ Plan B: special case when ---------+  (i)  e does not allocate or call GC+  (ii) either upstream code performs allocation+       or there is just one alternative++  Then heap allocation in the (single) case branch+  is absorbed by the upstream check.+  Very common example: primops on unboxed values++        ...code for e,+           with sequel (SetLocals r)...++        ...code for alts...+        ...no heap check...+-}++++-------------------------------------+data GcPlan+  = GcInAlts            -- Put a GC check at the start the case alternatives,+        [LocalReg]      -- which binds these registers+  | NoGcInAlts          -- The scrutinee is a primitive value, or a call to a+                        -- primitive op which does no GC.  Absorb the allocation+                        -- of the case alternative(s) into the upstream check++-------------------------------------+cgCase :: StgExpr -> Id -> AltType -> [StgAlt] -> FCode ReturnKind++cgCase (StgOpApp (StgPrimOp op) args _) bndr (AlgAlt tycon) alts+  | isEnumerationTyCon tycon -- Note [case on bool]+  = do { tag_expr <- do_enum_primop op args++       -- If the binder is not dead, convert the tag to a constructor+       -- and assign it.+       ; unless (isDeadBinder bndr) $ do+            { dflags <- getDynFlags+            ; tmp_reg <- bindArgToReg (NonVoid bndr)+            ; emitAssign (CmmLocal tmp_reg)+                         (tagToClosure dflags tycon tag_expr) }++       ; (mb_deflt, branches) <- cgAlgAltRhss (NoGcInAlts,AssignedDirectly)+                                              (NonVoid bndr) alts+       ; emitSwitch tag_expr branches mb_deflt 0 (tyConFamilySize tycon - 1)+       ; return AssignedDirectly+       }+  where+    do_enum_primop :: PrimOp -> [StgArg] -> FCode CmmExpr+    do_enum_primop TagToEnumOp [arg]  -- No code!+      = getArgAmode (NonVoid arg)+    do_enum_primop primop args+      = do dflags <- getDynFlags+           tmp <- newTemp (bWord dflags)+           cgPrimOp [tmp] primop args+           return (CmmReg (CmmLocal tmp))++{-+Note [case on bool]+~~~~~~~~~~~~~~~~~~~+This special case handles code like++  case a <# b of+    True ->+    False ->++-->  case tagToEnum# (a <$# b) of+        True -> .. ; False -> ...++--> case (a <$# b) of r ->+    case tagToEnum# r of+        True -> .. ; False -> ...++If we let the ordinary case code handle it, we'll get something like++ tmp1 = a < b+ tmp2 = Bool_closure_tbl[tmp1]+ if (tmp2 & 7 != 0) then ... // normal tagged case++but this junk won't optimise away.  What we really want is just an+inline comparison:++ if (a < b) then ...++So we add a special case to generate++ tmp1 = a < b+ if (tmp1 == 0) then ...++and later optimisations will further improve this.++Now that #6135 has been resolved it should be possible to remove that+special case. The idea behind this special case and pre-6135 implementation+of Bool-returning primops was that tagToEnum# was added implicitly in the+codegen and then optimized away. Now the call to tagToEnum# is explicit+in the source code, which allows to optimize it away at the earlier stages+of compilation (i.e. at the Core level).++Note [Scrutinising VoidRep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have this STG code:+   f = \[s : State# RealWorld] ->+       case s of _ -> blah+This is very odd.  Why are we scrutinising a state token?  But it+can arise with bizarre NOINLINE pragmas (Trac #9964)+    crash :: IO ()+    crash = IO (\s -> let {-# NOINLINE s' #-}+                          s' = s+                      in (# s', () #))++Now the trouble is that 's' has VoidRep, and we do not bind void+arguments in the environment; they don't live anywhere.  See the+calls to nonVoidIds in various places.  So we must not look up+'s' in the environment.  Instead, just evaluate the RHS!  Simple.+-}++cgCase (StgApp v []) _ (PrimAlt _) alts+  | isVoidRep (idPrimRep v)  -- See Note [Scrutinising VoidRep]+  , [(DEFAULT, _, rhs)] <- alts+  = cgExpr rhs++{- Note [Dodgy unsafeCoerce 1]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    case (x :: HValue) |> co of (y :: MutVar# Int)+        DEFAULT -> ...+We want to gnerate an assignment+     y := x+We want to allow this assignment to be generated in the case when the+types are compatible, because this allows some slightly-dodgy but+occasionally-useful casts to be used, such as in RtClosureInspect+where we cast an HValue to a MutVar# so we can print out the contents+of the MutVar#.  If instead we generate code that enters the HValue,+then we'll get a runtime panic, because the HValue really is a+MutVar#.  The types are compatible though, so we can just generate an+assignment.+-}+cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts+  | isUnliftedType (idType v)  -- Note [Dodgy unsafeCoerce 1]+  || reps_compatible+  = -- assignment suffices for unlifted types+    do { dflags <- getDynFlags+       ; unless reps_compatible $+           pprPanic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"+                    (pp_bndr v $$ pp_bndr bndr)+       ; v_info <- getCgIdInfo v+       ; emitAssign (CmmLocal (idToReg dflags (NonVoid bndr)))+                    (idInfoToAmode v_info)+       ; bindArgToReg (NonVoid bndr)+       ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts }+  where+    reps_compatible = ((==) `on` (primRepSlot . idPrimRep)) v bndr+      -- Must compare SlotTys, not proper PrimReps, because with unboxed sums,+      -- the types of the binders are generated from slotPrimRep and might not+      -- match. Test case:+      --   swap :: (# Int | Int #) -> (# Int | Int #)+      --   swap (# x | #) = (# | x #)+      --   swap (# | y #) = (# y | #)++    pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRep id))++{- Note [Dodgy unsafeCoerce 2, #3132]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In all other cases of a lifted Id being cast to an unlifted type, the+Id should be bound to bottom, otherwise this is an unsafe use of+unsafeCoerce.  We can generate code to enter the Id and assume that+it will never return.  Hence, we emit the usual enter/return code, and+because bottom must be untagged, it will be entered.  The Sequel is a+type-correct assignment, albeit bogus.  The (dead) continuation loops;+it would be better to invoke some kind of panic function here.+-}+cgCase scrut@(StgApp v []) _ (PrimAlt _) _+  = do { dflags <- getDynFlags+       ; mb_cc <- maybeSaveCostCentre True+       ; withSequel (AssignTo [idToReg dflags (NonVoid v)] False) (cgExpr scrut)+       ; restoreCurrentCostCentre mb_cc+       ; emitComment $ mkFastString "should be unreachable code"+       ; l <- newBlockId+       ; emitLabel l+       ; emit (mkBranch l)  -- an infinite loop+       ; return AssignedDirectly+       }++{- Note [Handle seq#]+~~~~~~~~~~~~~~~~~~~~~+case seq# a s of v+  (# s', a' #) -> e++==>++case a of v+  (# s', a' #) -> e++(taking advantage of the fact that the return convention for (# State#, a #)+is the same as the return convention for just 'a')+-}++cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts+  = -- Note [Handle seq#]+    -- Use the same return convention as vanilla 'a'.+    cgCase (StgApp a []) bndr alt_type alts++cgCase scrut bndr alt_type alts+  = -- the general case+    do { dflags <- getDynFlags+       ; up_hp_usg <- getVirtHp        -- Upstream heap usage+       ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts+             alt_regs  = map (idToReg dflags) ret_bndrs+       ; simple_scrut <- isSimpleScrut scrut alt_type+       ; let do_gc  | not simple_scrut = True+                    | isSingleton alts = False+                    | up_hp_usg > 0    = False+                    | otherwise        = True+               -- cf Note [Compiling case expressions]+             gc_plan = if do_gc then GcInAlts alt_regs else NoGcInAlts++       ; mb_cc <- maybeSaveCostCentre simple_scrut++       ; let sequel = AssignTo alt_regs do_gc{- Note [scrut sequel] -}+       ; ret_kind <- withSequel sequel (cgExpr scrut)+       ; restoreCurrentCostCentre mb_cc+       ; _ <- bindArgsToRegs ret_bndrs+       ; cgAlts (gc_plan,ret_kind) (NonVoid bndr) alt_type alts+       }+++{-+Note [scrut sequel]++The job of the scrutinee is to assign its value(s) to alt_regs.+Additionally, if we plan to do a heap-check in the alternatives (see+Note [Compiling case expressions]), then we *must* retreat Hp to+recover any unused heap before passing control to the sequel.  If we+don't do this, then any unused heap will become slop because the heap+check will reset the heap usage. Slop in the heap breaks LDV profiling+(+RTS -hb) which needs to do a linear sweep through the nursery.+++Note [Inlining out-of-line primops and heap checks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If shouldInlinePrimOp returns True when called from StgCmmExpr for the+purpose of heap check placement, we *must* inline the primop later in+StgCmmPrim. If we don't things will go wrong.+-}++-----------------+maybeSaveCostCentre :: Bool -> FCode (Maybe LocalReg)+maybeSaveCostCentre simple_scrut+  | simple_scrut = return Nothing+  | otherwise    = saveCurrentCostCentre+++-----------------+isSimpleScrut :: StgExpr -> AltType -> FCode Bool+-- Simple scrutinee, does not block or allocate; hence safe to amalgamate+-- heap usage from alternatives into the stuff before the case+-- NB: if you get this wrong, and claim that the expression doesn't allocate+--     when it does, you'll deeply mess up allocation+isSimpleScrut (StgOpApp op args _) _       = isSimpleOp op args+isSimpleScrut (StgLit _)       _           = return True       -- case 1# of { 0# -> ..; ... }+isSimpleScrut (StgApp _ [])    (PrimAlt _) = return True       -- case x# of { 0# -> ..; ... }+isSimpleScrut _                _           = return False++isSimpleOp :: StgOp -> [StgArg] -> FCode Bool+-- True iff the op cannot block or allocate+isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe)+isSimpleOp (StgPrimOp op) stg_args                  = do+    arg_exprs <- getNonVoidArgAmodes stg_args+    dflags <- getDynFlags+    -- See Note [Inlining out-of-line primops and heap checks]+    return $! isJust $ shouldInlinePrimOp dflags op arg_exprs+isSimpleOp (StgPrimCallOp _) _                           = return False++-----------------+chooseReturnBndrs :: Id -> AltType -> [StgAlt] -> [NonVoid Id]+-- These are the binders of a case that are assigned by the evaluation of the+-- scrutinee.+-- They're non-void, see Note [Post-unarisation invariants] in UnariseStg.+chooseReturnBndrs bndr (PrimAlt _) _alts+  = assertNonVoidIds [bndr]++chooseReturnBndrs _bndr (MultiValAlt n) [(_, ids, _)]+  = ASSERT2(n == length ids, ppr n $$ ppr ids $$ ppr _bndr)+    assertNonVoidIds ids     -- 'bndr' is not assigned!++chooseReturnBndrs bndr (AlgAlt _) _alts+  = assertNonVoidIds [bndr]  -- Only 'bndr' is assigned++chooseReturnBndrs bndr PolyAlt _alts+  = assertNonVoidIds [bndr]  -- Only 'bndr' is assigned++chooseReturnBndrs _ _ _ = panic "chooseReturnBndrs"+                             -- MultiValAlt has only one alternative++-------------------------------------+cgAlts :: (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [StgAlt]+       -> FCode ReturnKind+-- At this point the result of the case are in the binders+cgAlts gc_plan _bndr PolyAlt [(_, _, rhs)]+  = maybeAltHeapCheck gc_plan (cgExpr rhs)++cgAlts gc_plan _bndr (MultiValAlt _) [(_, _, rhs)]+  = maybeAltHeapCheck gc_plan (cgExpr rhs)+        -- Here bndrs are *already* in scope, so don't rebind them++cgAlts gc_plan bndr (PrimAlt _) alts+  = do  { dflags <- getDynFlags++        ; tagged_cmms <- cgAltRhss gc_plan bndr alts++        ; let bndr_reg = CmmLocal (idToReg dflags bndr)+              (DEFAULT,deflt) = head tagged_cmms+                -- PrimAlts always have a DEFAULT case+                -- and it always comes first++              tagged_cmms' = [(lit,code)+                             | (LitAlt lit, code) <- tagged_cmms]+        ; emitCmmLitSwitch (CmmReg bndr_reg) tagged_cmms' deflt+        ; return AssignedDirectly }++cgAlts gc_plan bndr (AlgAlt tycon) alts+  = do  { dflags <- getDynFlags++        ; (mb_deflt, branches) <- cgAlgAltRhss gc_plan bndr alts++        ; let fam_sz   = tyConFamilySize tycon+              bndr_reg = CmmLocal (idToReg dflags bndr)++                    -- Is the constructor tag in the node reg?+        ; if isSmallFamily dflags fam_sz+          then do+                let   -- Yes, bndr_reg has constr. tag in ls bits+                   tag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg)+                   branches' = [(tag+1,branch) | (tag,branch) <- branches]+                emitSwitch tag_expr branches' mb_deflt 1 fam_sz++           else         -- No, get tag from info table+                do dflags <- getDynFlags+                   let -- Note that ptr _always_ has tag 1+                       -- when the family size is big enough+                       untagged_ptr = cmmRegOffB bndr_reg (-1)+                       tag_expr = getConstrTag dflags (untagged_ptr)+                   emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1)++        ; return AssignedDirectly }++cgAlts _ _ _ _ = panic "cgAlts"+        -- UbxTupAlt and PolyAlt have only one alternative+++-- Note [alg-alt heap check]+--+-- In an algebraic case with more than one alternative, we will have+-- code like+--+-- L0:+--   x = R1+--   goto L1+-- L1:+--   if (x & 7 >= 2) then goto L2 else goto L3+-- L2:+--   Hp = Hp + 16+--   if (Hp > HpLim) then goto L4+--   ...+-- L4:+--   call gc() returns to L5+-- L5:+--   x = R1+--   goto L1++-------------------+cgAlgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [StgAlt]+             -> FCode ( Maybe CmmAGraphScoped+                      , [(ConTagZ, CmmAGraphScoped)] )+cgAlgAltRhss gc_plan bndr alts+  = do { tagged_cmms <- cgAltRhss gc_plan bndr alts++       ; let { mb_deflt = case tagged_cmms of+                           ((DEFAULT,rhs) : _) -> Just rhs+                           _other              -> Nothing+                            -- DEFAULT is always first, if present++              ; branches = [ (dataConTagZ con, cmm)+                           | (DataAlt con, cmm) <- tagged_cmms ]+              }++       ; return (mb_deflt, branches)+       }+++-------------------+cgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [StgAlt]+          -> FCode [(AltCon, CmmAGraphScoped)]+cgAltRhss gc_plan bndr alts = do+  dflags <- getDynFlags+  let+    base_reg = idToReg dflags bndr+    cg_alt :: StgAlt -> FCode (AltCon, CmmAGraphScoped)+    cg_alt (con, bndrs, rhs)+      = getCodeScoped             $+        maybeAltHeapCheck gc_plan $+        do { _ <- bindConArgs con base_reg (assertNonVoidIds bndrs)+                    -- alt binders are always non-void,+                    -- see Note [Post-unarisation invariants] in UnariseStg+           ; _ <- cgExpr rhs+           ; return con }+  forkAlts (map cg_alt alts)++maybeAltHeapCheck :: (GcPlan,ReturnKind) -> FCode a -> FCode a+maybeAltHeapCheck (NoGcInAlts,_)  code = code+maybeAltHeapCheck (GcInAlts regs, AssignedDirectly) code =+  altHeapCheck regs code+maybeAltHeapCheck (GcInAlts regs, ReturnedTo lret off) code =+  altHeapCheckReturnsTo regs lret off code++-----------------------------------------------------------------------------+--      Tail calls+-----------------------------------------------------------------------------++cgConApp :: DataCon -> [StgArg] -> FCode ReturnKind+cgConApp con stg_args+  | isUnboxedTupleCon con       -- Unboxed tuple: assign and return+  = do { arg_exprs <- getNonVoidArgAmodes stg_args+       ; tickyUnboxedTupleReturn (length arg_exprs)+       ; emitReturn arg_exprs }++  | otherwise   --  Boxed constructors; allocate and return+  = ASSERT2( stg_args `lengthIs` countConRepArgs con, ppr con <> parens (ppr (countConRepArgs con)) <+> ppr stg_args )+    do  { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) False+                                     currentCCS con (assertNonVoidStgArgs stg_args)+                                     -- con args are always non-void,+                                     -- see Note [Post-unarisation invariants] in UnariseStg+                -- The first "con" says that the name bound to this+                -- closure is "con", which is a bit of a fudge, but+                -- it only affects profiling (hence the False)++        ; emit =<< fcode_init+        ; tickyReturnNewCon (length stg_args)+        ; emitReturn [idInfoToAmode idinfo] }++cgIdApp :: Id -> [StgArg] -> FCode ReturnKind+cgIdApp fun_id [] | isVoidTy (idType fun_id) = emitReturn []+cgIdApp fun_id args = do+    dflags         <- getDynFlags+    fun_info       <- getCgIdInfo fun_id+    self_loop_info <- getSelfLoop+    let cg_fun_id   = cg_id fun_info+           -- NB: use (cg_id fun_info) instead of fun_id, because+           -- the former may be externalised for -split-objs.+           -- See Note [Externalise when splitting] in StgCmmMonad++        fun_arg     = StgVarArg cg_fun_id+        fun_name    = idName    cg_fun_id+        fun         = idInfoToAmode fun_info+        lf_info     = cg_lf         fun_info+        n_args      = length args+        v_args      = length $ filter (isVoidTy . stgArgType) args+        node_points dflags = nodeMustPointToIt dflags lf_info+    case getCallMethod dflags fun_name cg_fun_id lf_info n_args v_args (cg_loc fun_info) self_loop_info of++            -- A value in WHNF, so we can just return it.+        ReturnIt -> emitReturn [fun] -- ToDo: does ReturnIt guarantee tagged?++        EnterIt -> ASSERT( null args )  -- Discarding arguments+                   emitEnter fun++        SlowCall -> do      -- A slow function call via the RTS apply routines+                { tickySlowCall lf_info args+                ; emitComment $ mkFastString "slowCall"+                ; slowCall fun args }++        -- A direct function call (possibly with some left-over arguments)+        DirectEntry lbl arity -> do+                { tickyDirectCall arity args+                ; if node_points dflags+                     then directCall NativeNodeCall   lbl arity (fun_arg:args)+                     else directCall NativeDirectCall lbl arity args }++        -- Let-no-escape call or self-recursive tail-call+        JumpToIt blk_id lne_regs -> do+          { adjustHpBackwards -- always do this before a tail-call+          ; cmm_args <- getNonVoidArgAmodes args+          ; emitMultiAssign lne_regs cmm_args+          ; emit (mkBranch blk_id)+          ; return AssignedDirectly }++-- Note [Self-recursive tail calls]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Self-recursive tail calls can be optimized into a local jump in the same+-- way as let-no-escape bindings (see Note [What is a non-escaping let] in+-- stgSyn/CoreToStg.hs). Consider this:+--+-- foo.info:+--     a = R1  // calling convention+--     b = R2+--     goto L1+-- L1: ...+--     ...+-- ...+-- L2: R1 = x+--     R2 = y+--     call foo(R1,R2)+--+-- Instead of putting x and y into registers (or other locations required by the+-- calling convention) and performing a call we can put them into local+-- variables a and b and perform jump to L1:+--+-- foo.info:+--     a = R1+--     b = R2+--     goto L1+-- L1: ...+--     ...+-- ...+-- L2: a = x+--     b = y+--     goto L1+--+-- This can be done only when function is calling itself in a tail position+-- and only if the call passes number of parameters equal to function's arity.+-- Note that this cannot be performed if a function calls itself with a+-- continuation.+--+-- This in fact implements optimization known as "loopification". It was+-- described in "Low-level code optimizations in the Glasgow Haskell Compiler"+-- by Krzysztof Woś, though we use different approach. Krzysztof performed his+-- optimization at the Cmm level, whereas we perform ours during code generation+-- (Stg-to-Cmm pass) essentially making sure that optimized Cmm code is+-- generated in the first place.+--+-- Implementation is spread across a couple of places in the code:+--+--   * FCode monad stores additional information in its reader environment+--     (cgd_self_loop field). This information tells us which function can+--     tail call itself in an optimized way (it is the function currently+--     being compiled), what is the label of a loop header (L1 in example above)+--     and information about local registers in which we should arguments+--     before making a call (this would be a and b in example above).+--+--   * Whenever we are compiling a function, we set that information to reflect+--     the fact that function currently being compiled can be jumped to, instead+--     of called. This is done in closureCodyBody in StgCmmBind.+--+--   * We also have to emit a label to which we will be jumping. We make sure+--     that the label is placed after a stack check but before the heap+--     check. The reason is that making a recursive tail-call does not increase+--     the stack so we only need to check once. But it may grow the heap, so we+--     have to repeat the heap check in every self-call. This is done in+--     do_checks in StgCmmHeap.+--+--   * When we begin compilation of another closure we remove the additional+--     information from the environment. This is done by forkClosureBody+--     in StgCmmMonad. Other functions that duplicate the environment -+--     forkLneBody, forkAlts, codeOnly - duplicate that information. In other+--     words, we only need to clean the environment of the self-loop information+--     when compiling right hand side of a closure (binding).+--+--   * When compiling a call (cgIdApp) we use getCallMethod to decide what kind+--     of call will be generated. getCallMethod decides to generate a self+--     recursive tail call when (a) environment stores information about+--     possible self tail-call; (b) that tail call is to a function currently+--     being compiled; (c) number of passed non-void arguments is equal to+--     function's arity. (d) loopification is turned on via -floopification+--     command-line option.+--+--   * Command line option to turn loopification on and off is implemented in+--     DynFlags.+--+--+-- Note [Void arguments in self-recursive tail calls]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- State# tokens can get in the way of the loopification optimization as seen in+-- #11372. Consider this:+--+-- foo :: [a]+--     -> (a -> State# s -> (# State s, Bool #))+--     -> State# s+--     -> (# State# s, Maybe a #)+-- foo [] f s = (# s, Nothing #)+-- foo (x:xs) f s = case f x s of+--      (# s', b #) -> case b of+--          True -> (# s', Just x #)+--          False -> foo xs f s'+--+-- We would like to compile the call to foo as a local jump instead of a call+-- (see Note [Self-recursive tail calls]). However, the generated function has+-- an arity of 2 while we apply it to 3 arguments, one of them being of void+-- type. Thus, we mustn't count arguments of void type when checking whether+-- we can turn a call into a self-recursive jump.+--++emitEnter :: CmmExpr -> FCode ReturnKind+emitEnter fun = do+  { dflags <- getDynFlags+  ; adjustHpBackwards+  ; sequel <- getSequel+  ; updfr_off <- getUpdFrameOff+  ; case sequel of+      -- For a return, we have the option of generating a tag-test or+      -- not.  If the value is tagged, we can return directly, which+      -- is quicker than entering the value.  This is a code+      -- size/speed trade-off: when optimising for speed rather than+      -- size we could generate the tag test.+      --+      -- Right now, we do what the old codegen did, and omit the tag+      -- test, just generating an enter.+      Return -> do+        { let entry = entryCode dflags $ closureInfoPtr dflags $ CmmReg nodeReg+        ; emit $ mkJump dflags NativeNodeCall entry+                        [cmmUntag dflags fun] updfr_off+        ; return AssignedDirectly+        }++      -- The result will be scrutinised in the sequel.  This is where+      -- we generate a tag-test to avoid entering the closure if+      -- possible.+      --+      -- The generated code will be something like this:+      --+      --    R1 = fun  -- copyout+      --    if (fun & 7 != 0) goto Lret else goto Lcall+      --  Lcall:+      --    call [fun] returns to Lret+      --  Lret:+      --    fun' = R1  -- copyin+      --    ...+      --+      -- Note in particular that the label Lret is used as a+      -- destination by both the tag-test and the call.  This is+      -- because Lret will necessarily be a proc-point, and we want to+      -- ensure that we generate only one proc-point for this+      -- sequence.+      --+      -- Furthermore, we tell the caller that we generated a native+      -- return continuation by returning (ReturnedTo Lret off), so+      -- that the continuation can be reused by the heap-check failure+      -- code in the enclosing case expression.+      --+      AssignTo res_regs _ -> do+       { lret <- newBlockId+       ; let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs []+       ; lcall <- newBlockId+       ; updfr_off <- getUpdFrameOff+       ; let area = Young lret+       ; let (outArgs, regs, copyout) = copyOutOflow dflags NativeNodeCall Call area+                                          [fun] updfr_off []+         -- refer to fun via nodeReg after the copyout, to avoid having+         -- both live simultaneously; this sometimes enables fun to be+         -- inlined in the RHS of the R1 assignment.+       ; let entry = entryCode dflags (closureInfoPtr dflags (CmmReg nodeReg))+             the_call = toCall entry (Just lret) updfr_off off outArgs regs+       ; tscope <- getTickScope+       ; emit $+           copyout <*>+           mkCbranch (cmmIsTagged dflags (CmmReg nodeReg))+                     lret lcall Nothing <*>+           outOfLine lcall (the_call,tscope) <*>+           mkLabel lret tscope <*>+           copyin+       ; return (ReturnedTo lret off)+       }+  }++------------------------------------------------------------------------+--              Ticks+------------------------------------------------------------------------++-- | Generate Cmm code for a tick. Depending on the type of Tickish,+-- this will either generate actual Cmm instrumentation code, or+-- simply pass on the annotation as a @CmmTickish@.+cgTick :: Tickish Id -> FCode ()+cgTick tick+  = do { dflags <- getDynFlags+       ; case tick of+           ProfNote   cc t p -> emitSetCCC cc t p+           HpcTick    m n    -> emit (mkTickBox dflags m n)+           SourceNote s n    -> emitTick $ SourceNote s n+           _other            -> return () -- ignore+       }
+ codeGen/StgCmmExtCode.hs view
@@ -0,0 +1,251 @@+-- | Our extended FCode monad.++-- We add a mapping from names to CmmExpr, to support local variable names in+-- the concrete C-- code.  The unique supply of the underlying FCode monad+-- is used to grab a new unique for each local variable.++-- In C--, a local variable can be declared anywhere within a proc,+-- and it scopes from the beginning of the proc to the end.  Hence, we have+-- to collect declarations as we parse the proc, and feed the environment+-- back in circularly (to avoid a two-pass algorithm).++module StgCmmExtCode (+        CmmParse, unEC,+        Named(..), Env,++        loopDecls,+        getEnv,++        withName,+        getName,++        newLocal,+        newLabel,+        newBlockId,+        newFunctionName,+        newImport,+        lookupLabel,+        lookupName,++        code,+        emit, emitLabel, emitAssign, emitStore,+        getCode, getCodeR, getCodeScoped,+        emitOutOfLine,+        withUpdFrameOff, getUpdFrameOff+)++where++import qualified StgCmmMonad as F+import StgCmmMonad (FCode, newUnique)++import Cmm+import CLabel+import MkGraph++import BlockId+import DynFlags+import FastString+import Module+import UniqFM+import Unique+import UniqSupply++import Control.Monad (liftM, ap)++-- | The environment contains variable definitions or blockids.+data Named+        = VarN CmmExpr          -- ^ Holds CmmLit(CmmLabel ..) which gives the label type,+                                --      eg, RtsLabel, ForeignLabel, CmmLabel etc.++        | FunN   UnitId      -- ^ A function name from this package+        | LabelN BlockId                -- ^ A blockid of some code or data.++-- | An environment of named things.+type Env        = UniqFM Named++-- | Local declarations that are in scope during code generation.+type Decls      = [(FastString,Named)]++-- | Does a computation in the FCode monad, with a current environment+--      and a list of local declarations. Returns the resulting list of declarations.+newtype CmmParse a+        = EC { unEC :: String -> Env -> Decls -> FCode (Decls, a) }++type ExtCode = CmmParse ()++returnExtFC :: a -> CmmParse a+returnExtFC a   = EC $ \_ _ s -> return (s, a)++thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b+thenExtFC (EC m) k = EC $ \c e s -> do (s',r) <- m c e s; unEC (k r) c e s'++instance Functor CmmParse where+      fmap = liftM++instance Applicative CmmParse where+      pure = returnExtFC+      (<*>) = ap++instance Monad CmmParse where+  (>>=) = thenExtFC++instance MonadUnique CmmParse where+  getUniqueSupplyM = code getUniqueSupplyM+  getUniqueM = EC $ \_ _ decls -> do+    u <- getUniqueM+    return (decls, u)++instance HasDynFlags CmmParse where+    getDynFlags = EC (\_ _ d -> do dflags <- getDynFlags+                                   return (d, dflags))+++-- | Takes the variable decarations and imports from the monad+--      and makes an environment, which is looped back into the computation.+--      In this way, we can have embedded declarations that scope over the whole+--      procedure, and imports that scope over the entire module.+--      Discards the local declaration contained within decl'+--+loopDecls :: CmmParse a -> CmmParse a+loopDecls (EC fcode) =+      EC $ \c e globalDecls -> do+        (_, a) <- F.fixC $ \ ~(decls, _) ->+          fcode c (addListToUFM e decls) globalDecls+        return (globalDecls, a)+++-- | Get the current environment from the monad.+getEnv :: CmmParse Env+getEnv  = EC $ \_ e s -> return (s, e)++-- | Get the current context name from the monad+getName :: CmmParse String+getName  = EC $ \c _ s -> return (s, c)++-- | Set context name for a sub-parse+withName :: String -> CmmParse a -> CmmParse a+withName c' (EC fcode) = EC $ \_ e s -> fcode c' e s++addDecl :: FastString -> Named -> ExtCode+addDecl name named = EC $ \_ _ s -> return ((name, named) : s, ())+++-- | Add a new variable to the list of local declarations.+--      The CmmExpr says where the value is stored.+addVarDecl :: FastString -> CmmExpr -> ExtCode+addVarDecl var expr = addDecl var (VarN expr)++-- | Add a new label to the list of local declarations.+addLabel :: FastString -> BlockId -> ExtCode+addLabel name block_id = addDecl name (LabelN block_id)+++-- | Create a fresh local variable of a given type.+newLocal+        :: CmmType              -- ^ data type+        -> FastString           -- ^ name of variable+        -> CmmParse LocalReg    -- ^ register holding the value++newLocal ty name = do+   u <- code newUnique+   let reg = LocalReg u ty+   addVarDecl name (CmmReg (CmmLocal reg))+   return reg+++-- | Allocate a fresh label.+newLabel :: FastString -> CmmParse BlockId+newLabel name = do+   u <- code newUnique+   addLabel name (mkBlockId u)+   return (mkBlockId u)++-- | Add add a local function to the environment.+newFunctionName+        :: FastString   -- ^ name of the function+        -> UnitId    -- ^ package of the current module+        -> ExtCode++newFunctionName name pkg = addDecl name (FunN pkg)+++-- | Add an imported foreign label to the list of local declarations.+--      If this is done at the start of the module the declaration will scope+--      over the whole module.+newImport+        :: (FastString, CLabel)+        -> CmmParse ()++newImport (name, cmmLabel)+   = addVarDecl name (CmmLit (CmmLabel cmmLabel))+++-- | Lookup the BlockId bound to the label with this name.+--      If one hasn't been bound yet, create a fresh one based on the+--      Unique of the name.+lookupLabel :: FastString -> CmmParse BlockId+lookupLabel name = do+  env <- getEnv+  return $+     case lookupUFM env name of+        Just (LabelN l) -> l+        _other          -> mkBlockId (newTagUnique (getUnique name) 'L')+++-- | Lookup the location of a named variable.+--      Unknown names are treated as if they had been 'import'ed from the runtime system.+--      This saves us a lot of bother in the RTS sources, at the expense of+--      deferring some errors to link time.+lookupName :: FastString -> CmmParse CmmExpr+lookupName name = do+  env    <- getEnv+  return $+     case lookupUFM env name of+        Just (VarN e)   -> e+        Just (FunN pkg) -> CmmLit (CmmLabel (mkCmmCodeLabel pkg          name))+        _other          -> CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId name))+++-- | Lift an FCode computation into the CmmParse monad+code :: FCode a -> CmmParse a+code fc = EC $ \_ _ s -> do+                r <- fc+                return (s, r)++emit :: CmmAGraph -> CmmParse ()+emit = code . F.emit++emitLabel :: BlockId -> CmmParse ()+emitLabel = code . F.emitLabel++emitAssign :: CmmReg  -> CmmExpr -> CmmParse ()+emitAssign l r = code (F.emitAssign l r)++emitStore :: CmmExpr  -> CmmExpr -> CmmParse ()+emitStore l r = code (F.emitStore l r)++getCode :: CmmParse a -> CmmParse CmmAGraph+getCode (EC ec) = EC $ \c e s -> do+  ((s',_), gr) <- F.getCodeR (ec c e s)+  return (s', gr)++getCodeR :: CmmParse a -> CmmParse (a, CmmAGraph)+getCodeR (EC ec) = EC $ \c e s -> do+  ((s', r), gr) <- F.getCodeR (ec c e s)+  return (s', (r,gr))++getCodeScoped :: CmmParse a -> CmmParse (a, CmmAGraphScoped)+getCodeScoped (EC ec) = EC $ \c e s -> do+  ((s', r), gr) <- F.getCodeScoped (ec c e s)+  return (s', (r,gr))++emitOutOfLine :: BlockId -> CmmAGraphScoped -> CmmParse ()+emitOutOfLine l g = code (F.emitOutOfLine l g)++withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse ()+withUpdFrameOff size inner+  = EC $ \c e s -> F.withUpdFrameOff size $ (unEC inner) c e s++getUpdFrameOff :: CmmParse UpdFrameOffset+getUpdFrameOff = code $ F.getUpdFrameOff
+ codeGen/StgCmmForeign.hs view
@@ -0,0 +1,553 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Code generation for foreign calls.+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module StgCmmForeign (+  cgForeignCall,+  emitPrimCall, emitCCall,+  emitForeignCall,     -- For CmmParse+  emitSaveThreadState,+  saveThreadState,+  emitLoadThreadState,+  loadThreadState,+  emitOpenNursery,+  emitCloseNursery,+ ) where++#include "HsVersions.h"++import StgSyn+import StgCmmProf (storeCurCCS, ccsType, curCCS)+import StgCmmEnv+import StgCmmMonad+import StgCmmUtils+import StgCmmClosure+import StgCmmLayout++import BlockId (newBlockId)+import Cmm+import CmmUtils+import MkGraph+import Type+import RepType+import TysPrim+import CLabel+import SMRep+import ForeignCall+import DynFlags+import Maybes+import Outputable+import UniqSupply+import BasicTypes++import Control.Monad++import Prelude hiding( succ, (<*>) )++-----------------------------------------------------------------------------+-- Code generation for Foreign Calls+-----------------------------------------------------------------------------++-- | emit code for a foreign call, and return the results to the sequel.+--+cgForeignCall :: ForeignCall            -- the op+              -> [StgArg]               -- x,y    arguments+              -> Type                   -- result type+              -> FCode ReturnKind++cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty+  = do  { dflags <- getDynFlags+        ; let -- in the stdcall calling convention, the symbol needs @size appended+              -- to it, where size is the total number of bytes of arguments.  We+              -- attach this info to the CLabel here, and the CLabel pretty printer+              -- will generate the suffix when the label is printed.+            call_size args+              | StdCallConv <- cconv = Just (sum (map arg_size args))+              | otherwise            = Nothing++              -- ToDo: this might not be correct for 64-bit API+            arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType dflags arg)+                                     (wORD_SIZE dflags)+        ; cmm_args <- getFCallArgs stg_args+        ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty+        ; let ((call_args, arg_hints), cmm_target)+                = case target of+                   StaticTarget _ _   _      False ->+                       panic "cgForeignCall: unexpected FFI value import"+                   StaticTarget _ lbl mPkgId True+                     -> let labelSource+                                = case mPkgId of+                                        Nothing         -> ForeignLabelInThisPackage+                                        Just pkgId      -> ForeignLabelInPackage pkgId+                            size = call_size cmm_args+                        in  ( unzip cmm_args+                            , CmmLit (CmmLabel+                                        (mkForeignLabel lbl size labelSource IsFunction)))++                   DynamicTarget    ->  case cmm_args of+                                           (fn,_):rest -> (unzip rest, fn)+                                           [] -> panic "cgForeignCall []"+              fc = ForeignConvention cconv arg_hints res_hints CmmMayReturn+              call_target = ForeignTarget cmm_target fc++        -- we want to emit code for the call, and then emitReturn.+        -- However, if the sequel is AssignTo, we shortcut a little+        -- and generate a foreign call that assigns the results+        -- directly.  Otherwise we end up generating a bunch of+        -- useless "r = r" assignments, which are not merely annoying:+        -- they prevent the common block elimination from working correctly+        -- in the case of a safe foreign call.+        -- See Note [safe foreign call convention]+        --+        ; sequel <- getSequel+        ; case sequel of+            AssignTo assign_to_these _ ->+                emitForeignCall safety assign_to_these call_target call_args++            _something_else ->+                do { _ <- emitForeignCall safety res_regs call_target call_args+                   ; emitReturn (map (CmmReg . CmmLocal) res_regs)+                   }+         }++{- Note [safe foreign call convention]++The simple thing to do for a safe foreign call would be the same as an+unsafe one: just++    emitForeignCall ...+    emitReturn ...++but consider what happens in this case++   case foo x y z of+     (# s, r #) -> ...++The sequel is AssignTo [r].  The call to newUnboxedTupleRegs picks [r]+as the result reg, and we generate++  r = foo(x,y,z) returns to L1  -- emitForeignCall+ L1:+  r = r  -- emitReturn+  goto L2+L2:+  ...++Now L1 is a proc point (by definition, it is the continuation of the+safe foreign call).  If L2 does a heap check, then L2 will also be a+proc point.++Furthermore, the stack layout algorithm has to arrange to save r+somewhere between the call and the jump to L1, which is annoying: we+would have to treat r differently from the other live variables, which+have to be saved *before* the call.++So we adopt a special convention for safe foreign calls: the results+are copied out according to the NativeReturn convention by the call,+and the continuation of the call should copyIn the results.  (The+copyOut code is actually inserted when the safe foreign call is+lowered later).  The result regs attached to the safe foreign call are+only used temporarily to hold the results before they are copied out.++We will now generate this:++  r = foo(x,y,z) returns to L1+ L1:+  r = R1  -- copyIn, inserted by mkSafeCall+  goto L2+ L2:+  ... r ...++And when the safe foreign call is lowered later (see Note [lower safe+foreign calls]) we get this:++  suspendThread()+  r = foo(x,y,z)+  resumeThread()+  R1 = r  -- copyOut, inserted by lowerSafeForeignCall+  jump L1+ L1:+  r = R1  -- copyIn, inserted by mkSafeCall+  goto L2+ L2:+  ... r ...++Now consider what happens if L2 does a heap check: the Adams+optimisation kicks in and commons up L1 with the heap-check+continuation, resulting in just one proc point instead of two. Yay!+-}+++emitCCall :: [(CmmFormal,ForeignHint)]+          -> CmmExpr+          -> [(CmmActual,ForeignHint)]+          -> FCode ()+emitCCall hinted_results fn hinted_args+  = void $ emitForeignCall PlayRisky results target args+  where+    (args, arg_hints) = unzip hinted_args+    (results, result_hints) = unzip hinted_results+    target = ForeignTarget fn fc+    fc = ForeignConvention CCallConv arg_hints result_hints CmmMayReturn+++emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()+emitPrimCall res op args+  = void $ emitForeignCall PlayRisky res (PrimTarget op) args++-- alternative entry point, used by CmmParse+emitForeignCall+        :: Safety+        -> [CmmFormal]          -- where to put the results+        -> ForeignTarget        -- the op+        -> [CmmActual]          -- arguments+        -> FCode ReturnKind+emitForeignCall safety results target args+  | not (playSafe safety) = do+    dflags <- getDynFlags+    let (caller_save, caller_load) = callerSaveVolatileRegs dflags+    emit caller_save+    target' <- load_target_into_temp target+    args' <- mapM maybe_assign_temp args+    emit $ mkUnsafeCall target' results args'+    emit caller_load+    return AssignedDirectly++  | otherwise = do+    dflags <- getDynFlags+    updfr_off <- getUpdFrameOff+    target' <- load_target_into_temp target+    args' <- mapM maybe_assign_temp args+    k <- newBlockId+    let (off, _, copyout) = copyInOflow dflags NativeReturn (Young k) results []+       -- see Note [safe foreign call convention]+    tscope <- getTickScope+    emit $+           (    mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags)))+                        (CmmLit (CmmBlock k))+            <*> mkLast (CmmForeignCall { tgt  = target'+                                       , res  = results+                                       , args = args'+                                       , succ = k+                                       , ret_args = off+                                       , ret_off = updfr_off+                                       , intrbl = playInterruptible safety })+            <*> mkLabel k tscope+            <*> copyout+           )+    return (ReturnedTo k off)++load_target_into_temp :: ForeignTarget -> FCode ForeignTarget+load_target_into_temp (ForeignTarget expr conv) = do+  tmp <- maybe_assign_temp expr+  return (ForeignTarget tmp conv)+load_target_into_temp other_target@(PrimTarget _) =+  return other_target++-- What we want to do here is create a new temporary for the foreign+-- call argument if it is not safe to use the expression directly,+-- because the expression mentions caller-saves GlobalRegs (see+-- Note [Register Parameter Passing]).+--+-- However, we can't pattern-match on the expression here, because+-- this is used in a loop by CmmParse, and testing the expression+-- results in a black hole.  So we always create a temporary, and rely+-- on CmmSink to clean it up later.  (Yuck, ToDo).  The generated code+-- ends up being the same, at least for the RTS .cmm code.+--+maybe_assign_temp :: CmmExpr -> FCode CmmExpr+maybe_assign_temp e = do+  dflags <- getDynFlags+  reg <- newTemp (cmmExprType dflags e)+  emitAssign (CmmLocal reg) e+  return (CmmReg (CmmLocal reg))++-- -----------------------------------------------------------------------------+-- Save/restore the thread state in the TSO++-- This stuff can't be done in suspendThread/resumeThread, because it+-- refers to global registers which aren't available in the C world.++emitSaveThreadState :: FCode ()+emitSaveThreadState = do+  dflags <- getDynFlags+  code <- saveThreadState dflags+  emit code++-- | Produce code to save the current thread state to @CurrentTSO@+saveThreadState :: MonadUnique m => DynFlags -> m CmmAGraph+saveThreadState dflags = do+  tso <- newTemp (gcWord dflags)+  close_nursery <- closeNursery dflags tso+  pure $ catAGraphs [+    -- tso = CurrentTSO;+    mkAssign (CmmLocal tso) stgCurrentTSO,+    -- tso->stackobj->sp = Sp;+    mkStore (cmmOffset dflags+                       (CmmLoad (cmmOffset dflags+                                           (CmmReg (CmmLocal tso))+                                           (tso_stackobj dflags))+                                (bWord dflags))+                       (stack_SP dflags))+            stgSp,+    close_nursery,+    -- and save the current cost centre stack in the TSO when profiling:+    if gopt Opt_SccProfilingOn dflags then+        mkStore (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) curCCS+      else mkNop+    ]++emitCloseNursery :: FCode ()+emitCloseNursery = do+  dflags <- getDynFlags+  tso <- newTemp (bWord dflags)+  code <- closeNursery dflags tso+  emit $ mkAssign (CmmLocal tso) stgCurrentTSO <*> code++{- |+@closeNursery dflags tso@ produces code to close the nursery.+A local register holding the value of @CurrentTSO@ is expected for+efficiency.++Closing the nursery corresponds to the following code:++@+  tso = CurrentTSO;+  cn = CurrentNuresry;++  // Update the allocation limit for the current thread.  We don't+  // check to see whether it has overflowed at this point, that check is+  // made when we run out of space in the current heap block (stg_gc_noregs)+  // and in the scheduler when context switching (schedulePostRunThread).+  tso->alloc_limit -= Hp + WDS(1) - cn->start;++  // Set cn->free to the next unoccupied word in the block+  cn->free = Hp + WDS(1);+@+-}+closeNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph+closeNursery df tso = do+  let tsoreg  = CmmLocal tso+  cnreg      <- CmmLocal <$> newTemp (bWord df)+  pure $ catAGraphs [+    mkAssign cnreg stgCurrentNursery,++    -- CurrentNursery->free = Hp+1;+    mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW df stgHp 1),++    let alloc =+           CmmMachOp (mo_wordSub df)+              [ cmmOffsetW df stgHp 1+              , CmmLoad (nursery_bdescr_start df cnreg) (bWord df)+              ]++        alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df)+    in++    -- tso->alloc_limit += alloc+    mkStore alloc_limit (CmmMachOp (MO_Sub W64)+                               [ CmmLoad alloc_limit b64+                               , CmmMachOp (mo_WordTo64 df) [alloc] ])+   ]++emitLoadThreadState :: FCode ()+emitLoadThreadState = do+  dflags <- getDynFlags+  code <- loadThreadState dflags+  emit code++-- | Produce code to load the current thread state from @CurrentTSO@+loadThreadState :: MonadUnique m => DynFlags -> m CmmAGraph+loadThreadState dflags = do+  tso <- newTemp (gcWord dflags)+  stack <- newTemp (gcWord dflags)+  open_nursery <- openNursery dflags tso+  pure $ catAGraphs [+    -- tso = CurrentTSO;+    mkAssign (CmmLocal tso) stgCurrentTSO,+    -- stack = tso->stackobj;+    mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)),+    -- Sp = stack->sp;+    mkAssign sp (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)),+    -- SpLim = stack->stack + RESERVED_STACK_WORDS;+    mkAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags))+                                (rESERVED_STACK_WORDS dflags)),+    -- HpAlloc = 0;+    --   HpAlloc is assumed to be set to non-zero only by a failed+    --   a heap check, see HeapStackCheck.cmm:GC_GENERIC+    mkAssign hpAlloc (zeroExpr dflags),+    open_nursery,+    -- and load the current cost centre stack from the TSO when profiling:+    if gopt Opt_SccProfilingOn dflags+       then storeCurCCS+              (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso))+                 (tso_CCCS dflags)) (ccsType dflags))+       else mkNop+   ]+++emitOpenNursery :: FCode ()+emitOpenNursery = do+  dflags <- getDynFlags+  tso <- newTemp (bWord dflags)+  code <- openNursery dflags tso+  emit $ mkAssign (CmmLocal tso) stgCurrentTSO <*> code++{- |+@openNursery dflags tso@ produces code to open the nursery. A local register+holding the value of @CurrentTSO@ is expected for efficiency.++Opening the nursery corresponds to the following code:++@+   tso = CurrentTSO;+   cn = CurrentNursery;+   bdfree = CurrentNuresry->free;+   bdstart = CurrentNuresry->start;++   // We *add* the currently occupied portion of the nursery block to+   // the allocation limit, because we will subtract it again in+   // closeNursery.+   tso->alloc_limit += bdfree - bdstart;++   // Set Hp to the last occupied word of the heap block.  Why not the+   // next unocupied word?  Doing it this way means that we get to use+   // an offset of zero more often, which might lead to slightly smaller+   // code on some architectures.+   Hp = bdfree - WDS(1);++   // Set HpLim to the end of the current nursery block (note that this block+   // might be a block group, consisting of several adjacent blocks.+   HpLim = bdstart + CurrentNursery->blocks*BLOCK_SIZE_W - 1;+@+-}+openNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph+openNursery df tso = do+  let tsoreg =  CmmLocal tso+  cnreg      <- CmmLocal <$> newTemp (bWord df)+  bdfreereg  <- CmmLocal <$> newTemp (bWord df)+  bdstartreg <- CmmLocal <$> newTemp (bWord df)++  -- These assignments are carefully ordered to reduce register+  -- pressure and generate not completely awful code on x86.  To see+  -- what code we generate, look at the assembly for+  -- stg_returnToStackTop in rts/StgStartup.cmm.+  pure $ catAGraphs [+     mkAssign cnreg stgCurrentNursery,+     mkAssign bdfreereg  (CmmLoad (nursery_bdescr_free df cnreg)  (bWord df)),++     -- Hp = CurrentNursery->free - 1;+     mkAssign hp (cmmOffsetW df (CmmReg bdfreereg) (-1)),++     mkAssign bdstartreg (CmmLoad (nursery_bdescr_start df cnreg) (bWord df)),++     -- HpLim = CurrentNursery->start ++     --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;+     mkAssign hpLim+         (cmmOffsetExpr df+             (CmmReg bdstartreg)+             (cmmOffset df+               (CmmMachOp (mo_wordMul df) [+                 CmmMachOp (MO_SS_Conv W32 (wordWidth df))+                   [CmmLoad (nursery_bdescr_blocks df cnreg) b32],+                 mkIntExpr df (bLOCK_SIZE df)+                ])+               (-1)+             )+         ),++     -- alloc = bd->free - bd->start+     let alloc =+           CmmMachOp (mo_wordSub df) [CmmReg bdfreereg, CmmReg bdstartreg]++         alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df)+     in++     -- tso->alloc_limit += alloc+     mkStore alloc_limit (CmmMachOp (MO_Add W64)+                               [ CmmLoad alloc_limit b64+                               , CmmMachOp (mo_WordTo64 df) [alloc] ])++   ]++nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks+  :: DynFlags -> CmmReg -> CmmExpr+nursery_bdescr_free   dflags cn =+  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_free dflags)+nursery_bdescr_start  dflags cn =+  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_start dflags)+nursery_bdescr_blocks dflags cn =+  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_blocks dflags)++tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: DynFlags -> ByteOff+tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags)+tso_alloc_limit dflags = closureField dflags (oFFSET_StgTSO_alloc_limit dflags)+tso_CCCS     dflags = closureField dflags (oFFSET_StgTSO_cccs dflags)+stack_STACK  dflags = closureField dflags (oFFSET_StgStack_stack dflags)+stack_SP     dflags = closureField dflags (oFFSET_StgStack_sp dflags)+++closureField :: DynFlags -> ByteOff -> ByteOff+closureField dflags off = off + fixedHdrSize dflags++stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr+stgSp             = CmmReg sp+stgHp             = CmmReg hp+stgCurrentTSO     = CmmReg currentTSO+stgCurrentNursery = CmmReg currentNursery++sp, spLim, hp, hpLim, currentTSO, currentNursery, hpAlloc :: CmmReg+sp                = CmmGlobal Sp+spLim             = CmmGlobal SpLim+hp                = CmmGlobal Hp+hpLim             = CmmGlobal HpLim+currentTSO        = CmmGlobal CurrentTSO+currentNursery    = CmmGlobal CurrentNursery+hpAlloc           = CmmGlobal HpAlloc++-- -----------------------------------------------------------------------------+-- For certain types passed to foreign calls, we adjust the actual+-- value passed to the call.  For ByteArray#/Array# we pass the+-- address of the actual array, not the address of the heap object.++getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)]+-- (a) Drop void args+-- (b) Add foreign-call shim code+-- It's (b) that makes this differ from getNonVoidArgAmodes++getFCallArgs args+  = do  { mb_cmms <- mapM get args+        ; return (catMaybes mb_cmms) }+  where+    get arg | null arg_reps+            = return Nothing+            | otherwise+            = do { cmm <- getArgAmode (NonVoid arg)+                 ; dflags <- getDynFlags+                 ; return (Just (add_shim dflags arg_ty cmm, hint)) }+            where+              arg_ty   = stgArgType arg+              arg_reps = typePrimRep arg_ty+              hint     = typeForeignHint arg_ty++add_shim :: DynFlags -> Type -> CmmExpr -> CmmExpr+add_shim dflags arg_ty expr+  | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon+  = cmmOffsetB dflags expr (arrPtrsHdrSize dflags)++  | tycon == smallArrayPrimTyCon || tycon == smallMutableArrayPrimTyCon+  = cmmOffsetB dflags expr (smallArrPtrsHdrSize dflags)++  | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon+  = cmmOffsetB dflags expr (arrWordsHdrSize dflags)++  | otherwise = expr+  where+    tycon           = tyConAppTyCon (unwrapType arg_ty)+        -- should be a tycon app, since this is a foreign call
+ codeGen/StgCmmHeap.hs view
@@ -0,0 +1,698 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Stg to C--: heap management functions+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module StgCmmHeap (+        getVirtHp, setVirtHp, setRealHp,+        getHpRelOffset,++        entryHeapCheck, altHeapCheck, noEscapeHeapCheck, altHeapCheckReturnsTo,+        heapStackCheckGen,+        entryHeapCheck',++        mkStaticClosureFields, mkStaticClosure,++        allocDynClosure, allocDynClosureCmm, allocHeapClosure,+        emitSetDynHdr+    ) where++#include "HsVersions.h"++import StgSyn+import CLabel+import StgCmmLayout+import StgCmmUtils+import StgCmmMonad+import StgCmmProf (profDynAlloc, dynProfHdr, staticProfHdr)+import StgCmmTicky+import StgCmmClosure+import StgCmmEnv++import MkGraph++import Hoopl+import SMRep+import BlockId+import Cmm+import CmmUtils+import CostCentre+import IdInfo( CafInfo(..), mayHaveCafRefs )+import Id ( Id )+import Module+import DynFlags+import FastString( mkFastString, fsLit )+import Panic( sorry )++import Prelude hiding ((<*>))++import Control.Monad (when)+import Data.Maybe (isJust)++-----------------------------------------------------------+--              Initialise dynamic heap objects+-----------------------------------------------------------++allocDynClosure+        :: Maybe Id+        -> CmmInfoTable+        -> LambdaFormInfo+        -> CmmExpr              -- Cost Centre to stick in the object+        -> CmmExpr              -- Cost Centre to blame for this alloc+                                -- (usually the same; sometimes "OVERHEAD")++        -> [(NonVoid StgArg, VirtualHpOffset)]  -- Offsets from start of object+                                                -- ie Info ptr has offset zero.+                                                -- No void args in here+        -> FCode CmmExpr -- returns Hp+n++allocDynClosureCmm+        :: Maybe Id -> CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr+        -> [(CmmExpr, ByteOff)]+        -> FCode CmmExpr -- returns Hp+n++-- allocDynClosure allocates the thing in the heap,+-- and modifies the virtual Hp to account for this.+-- The second return value is the graph that sets the value of the+-- returned LocalReg, which should point to the closure after executing+-- the graph.++-- allocDynClosure returns an (Hp+8) CmmExpr, and hence the result is+-- only valid until Hp is changed.  The caller should assign the+-- result to a LocalReg if it is required to remain live.+--+-- The reason we don't assign it to a LocalReg here is that the caller+-- is often about to call regIdInfo, which immediately assigns the+-- result of allocDynClosure to a new temp in order to add the tag.+-- So by not generating a LocalReg here we avoid a common source of+-- new temporaries and save some compile time.  This can be quite+-- significant - see test T4801.+++allocDynClosure mb_id info_tbl lf_info use_cc _blame_cc args_w_offsets = do+  let (args, offsets) = unzip args_w_offsets+  cmm_args <- mapM getArgAmode args     -- No void args+  allocDynClosureCmm mb_id info_tbl lf_info+                     use_cc _blame_cc (zip cmm_args offsets)+++allocDynClosureCmm mb_id info_tbl lf_info use_cc _blame_cc amodes_w_offsets = do+  -- SAY WHAT WE ARE ABOUT TO DO+  let rep = cit_rep info_tbl+  tickyDynAlloc mb_id rep lf_info+  let info_ptr = CmmLit (CmmLabel (cit_lbl info_tbl))+  allocHeapClosure rep info_ptr use_cc amodes_w_offsets+++-- | Low-level heap object allocation.+allocHeapClosure+  :: SMRep                            -- ^ representation of the object+  -> CmmExpr                          -- ^ info pointer+  -> CmmExpr                          -- ^ cost centre+  -> [(CmmExpr,ByteOff)]              -- ^ payload+  -> FCode CmmExpr                    -- ^ returns the address of the object+allocHeapClosure rep info_ptr use_cc payload = do+  profDynAlloc rep use_cc++  virt_hp <- getVirtHp++  -- Find the offset of the info-ptr word+  let info_offset = virt_hp + 1+            -- info_offset is the VirtualHpOffset of the first+            -- word of the new object+            -- Remember, virtHp points to last allocated word,+            -- ie 1 *before* the info-ptr word of new object.++  base <- getHpRelOffset info_offset+  emitComment $ mkFastString "allocHeapClosure"+  emitSetDynHdr base info_ptr use_cc++  -- Fill in the fields+  hpStore base payload++  -- Bump the virtual heap pointer+  dflags <- getDynFlags+  setVirtHp (virt_hp + heapClosureSizeW dflags rep)++  return base+++emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()+emitSetDynHdr base info_ptr ccs+  = do dflags <- getDynFlags+       hpStore base (zip (header dflags) [0, wORD_SIZE dflags ..])+  where+    header :: DynFlags -> [CmmExpr]+    header dflags = [info_ptr] ++ dynProfHdr dflags ccs+        -- ToDof: Parallel stuff+        -- No ticky header++-- Store the item (expr,off) in base[off]+hpStore :: CmmExpr -> [(CmmExpr, ByteOff)] -> FCode ()+hpStore base vals = do+  dflags <- getDynFlags+  sequence_ $+    [ emitStore (cmmOffsetB dflags base off) val | (val,off) <- vals ]++-----------------------------------------------------------+--              Layout of static closures+-----------------------------------------------------------++-- Make a static closure, adding on any extra padding needed for CAFs,+-- and adding a static link field if necessary.++mkStaticClosureFields+        :: DynFlags+        -> CmmInfoTable+        -> CostCentreStack+        -> CafInfo+        -> [CmmLit]             -- Payload+        -> [CmmLit]             -- The full closure+mkStaticClosureFields dflags info_tbl ccs caf_refs payload+  = mkStaticClosure dflags info_lbl ccs payload padding+        static_link_field saved_info_field+  where+    info_lbl = cit_lbl info_tbl++    -- CAFs must have consistent layout, regardless of whether they+    -- are actually updatable or not.  The layout of a CAF is:+    --+    --        3 saved_info+    --        2 static_link+    --        1 indirectee+    --        0 info ptr+    --+    -- the static_link and saved_info fields must always be in the+    -- same place.  So we use isThunkRep rather than closureUpdReqd+    -- here:++    is_caf = isThunkRep (cit_rep info_tbl)++    padding+        | is_caf && null payload = [mkIntCLit dflags 0]+        | otherwise = []++    static_link_field+        | is_caf || staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl+        = [static_link_value]+        | otherwise+        = []++    saved_info_field+        | is_caf     = [mkIntCLit dflags 0]+        | otherwise  = []++        -- For a static constructor which has NoCafRefs, we set the+        -- static link field to a non-zero value so the garbage+        -- collector will ignore it.+    static_link_value+        | mayHaveCafRefs caf_refs  = mkIntCLit dflags 0+        | otherwise                = mkIntCLit dflags 3  -- No CAF refs+                                      -- See Note [STATIC_LINK fields]+                                      -- in rts/sm/Storage.h++mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit]+  -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]+mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info_field+  =  [CmmLabel info_lbl]+  ++ staticProfHdr dflags ccs+  ++ concatMap (padLitToWord dflags) payload+  ++ padding+  ++ static_link_field+  ++ saved_info_field++-- JD: Simon had ellided this padding, but without it the C back end asserts+-- failure. Maybe it's a bad assertion, and this padding is indeed unnecessary?+padLitToWord :: DynFlags -> CmmLit -> [CmmLit]+padLitToWord dflags lit = lit : padding pad_length+  where width = typeWidth (cmmLitType dflags lit)+        pad_length = wORD_SIZE dflags - widthInBytes width :: Int++        padding n | n <= 0 = []+                  | n `rem` 2 /= 0 = CmmInt 0 W8  : padding (n-1)+                  | n `rem` 4 /= 0 = CmmInt 0 W16 : padding (n-2)+                  | n `rem` 8 /= 0 = CmmInt 0 W32 : padding (n-4)+                  | otherwise      = CmmInt 0 W64 : padding (n-8)++-----------------------------------------------------------+--              Heap overflow checking+-----------------------------------------------------------++{- Note [Heap checks]+   ~~~~~~~~~~~~~~~~~~+Heap checks come in various forms.  We provide the following entry+points to the runtime system, all of which use the native C-- entry+convention.++  * gc() performs garbage collection and returns+    nothing to its caller++  * A series of canned entry points like+        r = gc_1p( r )+    where r is a pointer.  This performs gc, and+    then returns its argument r to its caller.++  * A series of canned entry points like+        gcfun_2p( f, x, y )+    where f is a function closure of arity 2+    This performs garbage collection, keeping alive the+    three argument ptrs, and then tail-calls f(x,y)++These are used in the following circumstances++* entryHeapCheck: Function entry+    (a) With a canned GC entry sequence+        f( f_clo, x:ptr, y:ptr ) {+             Hp = Hp+8+             if Hp > HpLim goto L+             ...+          L: HpAlloc = 8+             jump gcfun_2p( f_clo, x, y ) }+     Note the tail call to the garbage collector;+     it should do no register shuffling++    (b) No canned sequence+        f( f_clo, x:ptr, y:ptr, ...etc... ) {+          T: Hp = Hp+8+             if Hp > HpLim goto L+             ...+          L: HpAlloc = 8+             call gc()  -- Needs an info table+             goto T }++* altHeapCheck: Immediately following an eval+  Started as+        case f x y of r { (p,q) -> rhs }+  (a) With a canned sequence for the results of f+       (which is the very common case since+       all boxed cases return just one pointer+           ...+           r = f( x, y )+        K:      -- K needs an info table+           Hp = Hp+8+           if Hp > HpLim goto L+           ...code for rhs...++        L: r = gc_1p( r )+           goto K }++        Here, the info table needed by the call+        to gc_1p should be the *same* as the+        one for the call to f; the C-- optimiser+        spots this sharing opportunity)++   (b) No canned sequence for results of f+       Note second info table+           ...+           (r1,r2,r3) = call f( x, y )+        K:+           Hp = Hp+8+           if Hp > HpLim goto L+           ...code for rhs...++        L: call gc()    -- Extra info table here+           goto K++* generalHeapCheck: Anywhere else+  e.g. entry to thunk+       case branch *not* following eval,+       or let-no-escape+  Exactly the same as the previous case:++        K:      -- K needs an info table+           Hp = Hp+8+           if Hp > HpLim goto L+           ...++        L: call gc()+           goto K+-}++--------------------------------------------------------------+-- A heap/stack check at a function or thunk entry point.++entryHeapCheck :: ClosureInfo+               -> Maybe LocalReg -- Function (closure environment)+               -> Int            -- Arity -- not same as len args b/c of voids+               -> [LocalReg]     -- Non-void args (empty for thunk)+               -> FCode ()+               -> FCode ()++entryHeapCheck cl_info nodeSet arity args code+  = entryHeapCheck' is_fastf node arity args code+  where+    node = case nodeSet of+              Just r  -> CmmReg (CmmLocal r)+              Nothing -> CmmLit (CmmLabel $ staticClosureLabel cl_info)++    is_fastf = case closureFunInfo cl_info of+                 Just (_, ArgGen _) -> False+                 _otherwise         -> True++-- | lower-level version for CmmParse+entryHeapCheck' :: Bool           -- is a known function pattern+                -> CmmExpr        -- expression for the closure pointer+                -> Int            -- Arity -- not same as len args b/c of voids+                -> [LocalReg]     -- Non-void args (empty for thunk)+                -> FCode ()+                -> FCode ()+entryHeapCheck' is_fastf node arity args code+  = do dflags <- getDynFlags+       let is_thunk = arity == 0++           args' = map (CmmReg . CmmLocal) args+           stg_gc_fun    = CmmReg (CmmGlobal GCFun)+           stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1)++           {- Thunks:          jump stg_gc_enter_1++              Function (fast): call (NativeNode) stg_gc_fun(fun, args)++              Function (slow): call (slow) stg_gc_fun(fun, args)+           -}+           gc_call upd+               | is_thunk+                 = mkJump dflags NativeNodeCall stg_gc_enter1 [node] upd++               | is_fastf+                 = mkJump dflags NativeNodeCall stg_gc_fun (node : args') upd++               | otherwise+                 = mkJump dflags Slow stg_gc_fun (node : args') upd++       updfr_sz <- getUpdFrameOff++       loop_id <- newBlockId+       emitLabel loop_id+       heapCheck True True (gc_call updfr_sz <*> mkBranch loop_id) code++-- ------------------------------------------------------------+-- A heap/stack check in a case alternative+++-- If there are multiple alts and we need to GC, but don't have a+-- continuation already (the scrut was simple), then we should+-- pre-generate the continuation.  (if there are multiple alts it is+-- always a canned GC point).++-- altHeapCheck:+-- If we have a return continuation,+--   then if it is a canned GC pattern,+--           then we do mkJumpReturnsTo+--           else we do a normal call to stg_gc_noregs+--   else if it is a canned GC pattern,+--           then generate the continuation and do mkCallReturnsTo+--           else we do a normal call to stg_gc_noregs++altHeapCheck :: [LocalReg] -> FCode a -> FCode a+altHeapCheck regs code = altOrNoEscapeHeapCheck False regs code++altOrNoEscapeHeapCheck :: Bool -> [LocalReg] -> FCode a -> FCode a+altOrNoEscapeHeapCheck checkYield regs code = do+    dflags <- getDynFlags+    case cannedGCEntryPoint dflags regs of+      Nothing -> genericGC checkYield code+      Just gc -> do+        lret <- newBlockId+        let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) regs []+        lcont <- newBlockId+        tscope <- getTickScope+        emitOutOfLine lret (copyin <*> mkBranch lcont, tscope)+        emitLabel lcont+        cannedGCReturnsTo checkYield False gc regs lret off code++altHeapCheckReturnsTo :: [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a+altHeapCheckReturnsTo regs lret off code+  = do dflags <- getDynFlags+       case cannedGCEntryPoint dflags regs of+           Nothing -> genericGC False code+           Just gc -> cannedGCReturnsTo False True gc regs lret off code++-- noEscapeHeapCheck is implemented identically to altHeapCheck (which+-- is more efficient), but cannot be optimized away in the non-allocating+-- case because it may occur in a loop+noEscapeHeapCheck :: [LocalReg] -> FCode a -> FCode a+noEscapeHeapCheck regs code = altOrNoEscapeHeapCheck True regs code++cannedGCReturnsTo :: Bool -> Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff+                  -> FCode a+                  -> FCode a+cannedGCReturnsTo checkYield cont_on_stack gc regs lret off code+  = do dflags <- getDynFlags+       updfr_sz <- getUpdFrameOff+       heapCheck False checkYield (gc_call dflags gc updfr_sz) code+  where+    reg_exprs = map (CmmReg . CmmLocal) regs+      -- Note [stg_gc arguments]++      -- NB. we use the NativeReturn convention for passing arguments+      -- to the canned heap-check routines, because we are in a case+      -- alternative and hence the [LocalReg] was passed to us in the+      -- NativeReturn convention.+    gc_call dflags label sp+      | cont_on_stack+      = mkJumpReturnsTo dflags label NativeReturn reg_exprs lret off sp+      | otherwise+      = mkCallReturnsTo dflags label NativeReturn reg_exprs lret off sp []++genericGC :: Bool -> FCode a -> FCode a+genericGC checkYield code+  = do updfr_sz <- getUpdFrameOff+       lretry <- newBlockId+       emitLabel lretry+       call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []+       heapCheck False checkYield (call <*> mkBranch lretry) code++cannedGCEntryPoint :: DynFlags -> [LocalReg] -> Maybe CmmExpr+cannedGCEntryPoint dflags regs+  = case map localRegType regs of+      []  -> Just (mkGcLabel "stg_gc_noregs")+      [ty]+          | isGcPtrType ty -> Just (mkGcLabel "stg_gc_unpt_r1")+          | isFloatType ty -> case width of+                                  W32       -> Just (mkGcLabel "stg_gc_f1")+                                  W64       -> Just (mkGcLabel "stg_gc_d1")+                                  _         -> Nothing++          | width == wordWidth dflags -> Just (mkGcLabel "stg_gc_unbx_r1")+          | width == W64              -> Just (mkGcLabel "stg_gc_l1")+          | otherwise                 -> Nothing+          where+              width = typeWidth ty+      [ty1,ty2]+          |  isGcPtrType ty1+          && isGcPtrType ty2 -> Just (mkGcLabel "stg_gc_pp")+      [ty1,ty2,ty3]+          |  isGcPtrType ty1+          && isGcPtrType ty2+          && isGcPtrType ty3 -> Just (mkGcLabel "stg_gc_ppp")+      [ty1,ty2,ty3,ty4]+          |  isGcPtrType ty1+          && isGcPtrType ty2+          && isGcPtrType ty3+          && isGcPtrType ty4 -> Just (mkGcLabel "stg_gc_pppp")+      _otherwise -> Nothing++-- Note [stg_gc arguments]+-- It might seem that we could avoid passing the arguments to the+-- stg_gc function, because they are already in the right registers.+-- While this is usually the case, it isn't always.  Sometimes the+-- code generator has cleverly avoided the eval in a case, e.g. in+-- ffi/should_run/4221.hs we found+--+--   case a_r1mb of z+--     FunPtr x y -> ...+--+-- where a_r1mb is bound a top-level constructor, and is known to be+-- evaluated.  The codegen just assigns x, y and z, and continues;+-- R1 is never assigned.+--+-- So we'll have to rely on optimisations to eliminatethese+-- assignments where possible.+++-- | The generic GC procedure; no params, no results+generic_gc :: CmmExpr+generic_gc = mkGcLabel "stg_gc_noregs"++-- | Create a CLabel for calling a garbage collector entry point+mkGcLabel :: String -> CmmExpr+mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit s)))++-------------------------------+heapCheck :: Bool -> Bool -> CmmAGraph -> FCode a -> FCode a+heapCheck checkStack checkYield do_gc code+  = getHeapUsage $ \ hpHw ->+    -- Emit heap checks, but be sure to do it lazily so+    -- that the conditionals on hpHw don't cause a black hole+    do  { dflags <- getDynFlags+        ; let mb_alloc_bytes+                 | hpHw > mBLOCK_SIZE = sorry $ unlines+                    [" Trying to allocate more than "++show mBLOCK_SIZE++" bytes.",+                     "",+                     "This is currently not possible due to a limitation of GHC's code generator.",+                     "See http://hackage.haskell.org/trac/ghc/ticket/4505 for details.",+                     "Suggestion: read data from a file instead of having large static data",+                     "structures in code."]+                 | hpHw > 0  = Just (mkIntExpr dflags (hpHw * (wORD_SIZE dflags)))+                 | otherwise = Nothing+                 where mBLOCK_SIZE = bLOCKS_PER_MBLOCK dflags * bLOCK_SIZE_W dflags+              stk_hwm | checkStack = Just (CmmLit CmmHighStackMark)+                      | otherwise  = Nothing+        ; codeOnly $ do_checks stk_hwm checkYield mb_alloc_bytes do_gc+        ; tickyAllocHeap True hpHw+        ; setRealHp hpHw+        ; code }++heapStackCheckGen :: Maybe CmmExpr -> Maybe CmmExpr -> FCode ()+heapStackCheckGen stk_hwm mb_bytes+  = do updfr_sz <- getUpdFrameOff+       lretry <- newBlockId+       emitLabel lretry+       call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []+       do_checks stk_hwm False mb_bytes (call <*> mkBranch lretry)++-- Note [Single stack check]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~+-- When compiling a function we can determine how much stack space it+-- will use. We therefore need to perform only a single stack check at+-- the beginning of a function to see if we have enough stack space.+--+-- The check boils down to comparing Sp-N with SpLim, where N is the+-- amount of stack space needed (see Note [Stack usage] below).  *BUT*+-- at this stage of the pipeline we are not supposed to refer to Sp+-- itself, because the stack is not yet manifest, so we don't quite+-- know where Sp pointing.++-- So instead of referring directly to Sp - as we used to do in the+-- past - the code generator uses (old + 0) in the stack check. That+-- is the address of the first word of the old area, so if we add N+-- we'll get the address of highest used word.+--+-- This makes the check robust.  For example, while we need to perform+-- only one stack check for each function, we could in theory place+-- more stack checks later in the function. They would be redundant,+-- but not incorrect (in a sense that they should not change program+-- behaviour). We need to make sure however that a stack check+-- inserted after incrementing the stack pointer checks for a+-- respectively smaller stack space. This would not be the case if the+-- code generator produced direct references to Sp. By referencing+-- (old + 0) we make sure that we always check for a correct amount of+-- stack: when converting (old + 0) to Sp the stack layout phase takes+-- into account changes already made to stack pointer. The idea for+-- this change came from observations made while debugging #8275.++-- Note [Stack usage]+-- ~~~~~~~~~~~~~~~~~~+-- At the moment we convert from STG to Cmm we don't know N, the+-- number of bytes of stack that the function will use, so we use a+-- special late-bound CmmLit, namely+--       CmmHighStackMark+-- to stand for the number of bytes needed. When the stack is made+-- manifest, the number of bytes needed is calculated, and used to+-- replace occurrences of CmmHighStackMark+--+-- The (Maybe CmmExpr) passed to do_checks is usually+--     Just (CmmLit CmmHighStackMark)+-- but can also (in certain hand-written RTS functions)+--     Just (CmmLit 8)  or some other fixed valuet+-- If it is Nothing, we don't generate a stack check at all.++do_checks :: Maybe CmmExpr    -- Should we check the stack?+                              -- See Note [Stack usage]+          -> Bool             -- Should we check for preemption?+          -> Maybe CmmExpr    -- Heap headroom (bytes)+          -> CmmAGraph        -- What to do on failure+          -> FCode ()+do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do+  dflags <- getDynFlags+  gc_id <- newBlockId++  let+    Just alloc_lit = mb_alloc_lit++    bump_hp   = cmmOffsetExprB dflags (CmmReg hpReg) alloc_lit++    -- Sp overflow if ((old + 0) - CmmHighStack < SpLim)+    -- At the beginning of a function old + 0 = Sp+    -- See Note [Single stack check]+    sp_oflo sp_hwm =+         CmmMachOp (mo_wordULt dflags)+                  [CmmMachOp (MO_Sub (typeWidth (cmmRegType dflags spReg)))+                             [CmmStackSlot Old 0, sp_hwm],+                   CmmReg spLimReg]++    -- Hp overflow if (Hp > HpLim)+    -- (Hp has been incremented by now)+    -- HpLim points to the LAST WORD of valid allocation space.+    hp_oflo = CmmMachOp (mo_wordUGt dflags)+                  [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]++    alloc_n = mkAssign (CmmGlobal HpAlloc) alloc_lit++  case mb_stk_hwm of+    Nothing -> return ()+    Just stk_hwm -> tickyStackCheck+      >> (emit =<< mkCmmIfGoto' (sp_oflo stk_hwm) gc_id (Just False) )++  -- Emit new label that might potentially be a header+  -- of a self-recursive tail call.+  -- See Note [Self-recursive loop header].+  self_loop_info <- getSelfLoop+  case self_loop_info of+    Just (_, loop_header_id, _)+        | checkYield && isJust mb_stk_hwm -> emitLabel loop_header_id+    _otherwise -> return ()++  if (isJust mb_alloc_lit)+    then do+     tickyHeapCheck+     emitAssign hpReg bump_hp+     emit =<< mkCmmIfThen' hp_oflo (alloc_n <*> mkBranch gc_id) (Just False)+    else do+      when (checkYield && not (gopt Opt_OmitYields dflags)) $ do+         -- Yielding if HpLim == 0+         let yielding = CmmMachOp (mo_wordEq dflags)+                                  [CmmReg (CmmGlobal HpLim),+                                   CmmLit (zeroCLit dflags)]+         emit =<< mkCmmIfGoto' yielding gc_id (Just False)++  tscope <- getTickScope+  emitOutOfLine gc_id+   (do_gc, tscope) -- this is expected to jump back somewhere++                -- Test for stack pointer exhaustion, then+                -- bump heap pointer, and test for heap exhaustion+                -- Note that we don't move the heap pointer unless the+                -- stack check succeeds.  Otherwise we might end up+                -- with slop at the end of the current block, which can+                -- confuse the LDV profiler.++-- Note [Self-recursive loop header]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Self-recursive loop header is required by loopification optimization (See+-- Note [Self-recursive tail calls] in StgCmmExpr). We emit it if:+--+--  1. There is information about self-loop in the FCode environment. We don't+--     check the binder (first component of the self_loop_info) because we are+--     certain that if the self-loop info is present then we are compiling the+--     binder body. Reason: the only possible way to get here with the+--     self_loop_info present is from closureCodeBody.+--+--  2. checkYield && isJust mb_stk_hwm. checkYield tells us that it is possible+--     to preempt the heap check (see #367 for motivation behind this check). It+--     is True for heap checks placed at the entry to a function and+--     let-no-escape heap checks but false for other heap checks (eg. in case+--     alternatives or created from hand-written high-level Cmm). The second+--     check (isJust mb_stk_hwm) is true for heap checks at the entry to a+--     function and some heap checks created in hand-written Cmm. Otherwise it+--     is Nothing. In other words the only situation when both conditions are+--     true is when compiling stack and heap checks at the entry to a+--     function. This is the only situation when we want to emit a self-loop+--     label.
+ codeGen/StgCmmHpc.hs view
@@ -0,0 +1,46 @@+-----------------------------------------------------------------------------+--+-- Code generation for coverage+--+-- (c) Galois Connections, Inc. 2006+--+-----------------------------------------------------------------------------++module StgCmmHpc ( initHpc, mkTickBox ) where++import StgCmmMonad++import MkGraph+import CmmExpr+import CLabel+import Module+import CmmUtils+import StgCmmUtils+import HscTypes+import DynFlags++import Control.Monad++mkTickBox :: DynFlags -> Module -> Int -> CmmAGraph+mkTickBox dflags mod n+  = mkStore tick_box (CmmMachOp (MO_Add W64)+                                [ CmmLoad tick_box b64+                                , CmmLit (CmmInt 1 W64)+                                ])+  where+    tick_box = cmmIndex dflags W64+                        (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)+                        n++initHpc :: Module -> HpcInfo -> FCode ()+-- Emit top-level tables for HPC and return code to initialise+initHpc _ (NoHpcInfo {})+  = return ()+initHpc this_mod (HpcInfo tickCount _hashNo)+  = do dflags <- getDynFlags+       when (gopt Opt_Hpc dflags) $+           do emitDataLits (mkHpcTicksLabel this_mod)+                           [ (CmmInt 0 W64)+                           | _ <- take tickCount [0 :: Int ..]+                           ]+
+ codeGen/StgCmmLayout.hs view
@@ -0,0 +1,552 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Building info tables.+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module StgCmmLayout (+        mkArgDescr,+        emitCall, emitReturn, adjustHpBackwards,++        emitClosureProcAndInfoTable,+        emitClosureAndInfoTable,++        slowCall, directCall,++        mkVirtHeapOffsets, mkVirtConstrOffsets, mkVirtConstrSizes, getHpRelOffset,++        ArgRep(..), toArgRep, argRepSizeW -- re-exported from StgCmmArgRep+  ) where+++#include "HsVersions.h"++import Prelude hiding ((<*>))++import StgCmmClosure+import StgCmmEnv+import StgCmmArgRep -- notably: ( slowCallPattern )+import StgCmmTicky+import StgCmmMonad+import StgCmmUtils+import StgCmmProf (curCCS)++import MkGraph+import SMRep+import BlockId+import Cmm+import CmmUtils+import CmmInfo+import CLabel+import StgSyn+import Id+import TyCon             ( PrimRep(..) )+import BasicTypes        ( RepArity )+import DynFlags+import Module++import Util+import Data.List+import Outputable+import FastString+import Control.Monad++------------------------------------------------------------------------+--                Call and return sequences+------------------------------------------------------------------------++-- | Return multiple values to the sequel+--+-- If the sequel is @Return@+--+-- >     return (x,y)+--+-- If the sequel is @AssignTo [p,q]@+--+-- >    p=x; q=y;+--+emitReturn :: [CmmExpr] -> FCode ReturnKind+emitReturn results+  = do { dflags    <- getDynFlags+       ; sequel    <- getSequel+       ; updfr_off <- getUpdFrameOff+       ; case sequel of+           Return ->+             do { adjustHpBackwards+                ; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags)+                ; emit (mkReturn dflags (entryCode dflags e) results updfr_off)+                }+           AssignTo regs adjust ->+             do { when adjust adjustHpBackwards+                ; emitMultiAssign  regs results }+       ; return AssignedDirectly+       }+++-- | @emitCall conv fun args@ makes a call to the entry-code of @fun@,+-- using the call/return convention @conv@, passing @args@, and+-- returning the results to the current sequel.+--+emitCall :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> FCode ReturnKind+emitCall convs fun args+  = emitCallWithExtraStack convs fun args noExtraStack+++-- | @emitCallWithExtraStack conv fun args stack@ makes a call to the+-- entry-code of @fun@, using the call/return convention @conv@,+-- passing @args@, pushing some extra stack frames described by+-- @stack@, and returning the results to the current sequel.+--+emitCallWithExtraStack+   :: (Convention, Convention) -> CmmExpr -> [CmmExpr]+   -> [CmmExpr] -> FCode ReturnKind+emitCallWithExtraStack (callConv, retConv) fun args extra_stack+  = do  { dflags <- getDynFlags+        ; adjustHpBackwards+        ; sequel <- getSequel+        ; updfr_off <- getUpdFrameOff+        ; case sequel of+            Return -> do+              emit $ mkJumpExtra dflags callConv fun args updfr_off extra_stack+              return AssignedDirectly+            AssignTo res_regs _ -> do+              k <- newBlockId+              let area = Young k+                  (off, _, copyin) = copyInOflow dflags retConv area res_regs []+                  copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off+                                   extra_stack+              tscope <- getTickScope+              emit (copyout <*> mkLabel k tscope <*> copyin)+              return (ReturnedTo k off)+      }+++adjustHpBackwards :: FCode ()+-- This function adjusts the heap pointer just before a tail call or+-- return.  At a call or return, the virtual heap pointer may be less+-- than the real Hp, because the latter was advanced to deal with+-- the worst-case branch of the code, and we may be in a better-case+-- branch.  In that case, move the real Hp *back* and retract some+-- ticky allocation count.+--+-- It *does not* deal with high-water-mark adjustment.  That's done by+-- functions which allocate heap.+adjustHpBackwards+  = do  { hp_usg <- getHpUsage+        ; let rHp = realHp hp_usg+              vHp = virtHp hp_usg+              adjust_words = vHp -rHp+        ; new_hp <- getHpRelOffset vHp++        ; emit (if adjust_words == 0+                then mkNop+                else mkAssign hpReg new_hp) -- Generates nothing when vHp==rHp++        ; tickyAllocHeap False adjust_words -- ...ditto++        ; setRealHp vHp+        }+++-------------------------------------------------------------------------+--        Making calls: directCall and slowCall+-------------------------------------------------------------------------++-- General plan is:+--   - we'll make *one* fast call, either to the function itself+--     (directCall) or to stg_ap_<pat>_fast (slowCall)+--     Any left-over arguments will be pushed on the stack,+--+--     e.g. Sp[old+8]  = arg1+--          Sp[old+16] = arg2+--          Sp[old+32] = stg_ap_pp_info+--          R2 = arg3+--          R3 = arg4+--          call f() return to Nothing updfr_off: 32+++directCall :: Convention -> CLabel -> RepArity -> [StgArg] -> FCode ReturnKind+-- (directCall f n args)+-- calls f(arg1, ..., argn), and applies the result to the remaining args+-- The function f has arity n, and there are guaranteed at least n args+-- Both arity and args include void args+directCall conv lbl arity stg_args+  = do  { argreps <- getArgRepsAmodes stg_args+        ; direct_call "directCall" conv lbl arity argreps }+++slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind+-- (slowCall fun args) applies fun to args, returning the results to Sequel+slowCall fun stg_args+  = do  dflags <- getDynFlags+        argsreps <- getArgRepsAmodes stg_args+        let (rts_fun, arity) = slowCallPattern (map fst argsreps)++        (r, slow_code) <- getCodeR $ do+           r <- direct_call "slow_call" NativeNodeCall+                 (mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps)+           emitComment $ mkFastString ("slow_call for " +++                                      showSDoc dflags (ppr fun) +++                                      " with pat " ++ unpackFS rts_fun)+           return r++        -- Note [avoid intermediate PAPs]+        let n_args = length stg_args+        if n_args > arity && optLevel dflags >= 2+           then do+             funv <- (CmmReg . CmmLocal) `fmap` assignTemp fun+             fun_iptr <- (CmmReg . CmmLocal) `fmap`+                    assignTemp (closureInfoPtr dflags (cmmUntag dflags funv))++             -- ToDo: we could do slightly better here by reusing the+             -- continuation from the slow call, which we have in r.+             -- Also we'd like to push the continuation on the stack+             -- before the branch, so that we only get one copy of the+             -- code that saves all the live variables across the+             -- call, but that might need some improvements to the+             -- special case in the stack layout code to handle this+             -- (see Note [diamond proc point]).++             fast_code <- getCode $+                emitCall (NativeNodeCall, NativeReturn)+                  (entryCode dflags fun_iptr)+                  (nonVArgs ((P,Just funv):argsreps))++             slow_lbl <- newBlockId+             fast_lbl <- newBlockId+             is_tagged_lbl <- newBlockId+             end_lbl <- newBlockId++             let correct_arity = cmmEqWord dflags (funInfoArity dflags fun_iptr)+                                                  (mkIntExpr dflags n_args)++             tscope <- getTickScope+             emit (mkCbranch (cmmIsTagged dflags funv)+                             is_tagged_lbl slow_lbl (Just True)+                   <*> mkLabel is_tagged_lbl tscope+                   <*> mkCbranch correct_arity fast_lbl slow_lbl (Just True)+                   <*> mkLabel fast_lbl tscope+                   <*> fast_code+                   <*> mkBranch end_lbl+                   <*> mkLabel slow_lbl tscope+                   <*> slow_code+                   <*> mkLabel end_lbl tscope)+             return r++           else do+             emit slow_code+             return r+++-- Note [avoid intermediate PAPs]+--+-- A slow call which needs multiple generic apply patterns will be+-- almost guaranteed to create one or more intermediate PAPs when+-- applied to a function that takes the correct number of arguments.+-- We try to avoid this situation by generating code to test whether+-- we are calling a function with the correct number of arguments+-- first, i.e.:+--+--   if (TAG(f) != 0} {  // f is not a thunk+--      if (f->info.arity == n) {+--         ... make a fast call to f ...+--      }+--   }+--   ... otherwise make the slow call ...+--+-- We *only* do this when the call requires multiple generic apply+-- functions, which requires pushing extra stack frames and probably+-- results in intermediate PAPs.  (I say probably, because it might be+-- that we're over-applying a function, but that seems even less+-- likely).+--+-- This very rarely applies, but if it does happen in an inner loop it+-- can have a severe impact on performance (#6084).+++--------------+direct_call :: String+            -> Convention     -- e.g. NativeNodeCall or NativeDirectCall+            -> CLabel -> RepArity+            -> [(ArgRep,Maybe CmmExpr)] -> FCode ReturnKind+direct_call caller call_conv lbl arity args+  | debugIsOn && real_arity > length args  -- Too few args+  = do -- Caller should ensure that there enough args!+       pprPanic "direct_call" $+            text caller <+> ppr arity <+>+            ppr lbl <+> ppr (length args) <+>+            ppr (map snd args) <+> ppr (map fst args)++  | null rest_args  -- Precisely the right number of arguments+  = emitCall (call_conv, NativeReturn) target (nonVArgs args)++  | otherwise       -- Note [over-saturated calls]+  = do dflags <- getDynFlags+       emitCallWithExtraStack (call_conv, NativeReturn)+                              target+                              (nonVArgs fast_args)+                              (nonVArgs (stack_args dflags))+  where+    target = CmmLit (CmmLabel lbl)+    (fast_args, rest_args) = splitAt real_arity args+    stack_args dflags = slowArgs dflags rest_args+    real_arity = case call_conv of+                   NativeNodeCall -> arity+1+                   _              -> arity+++-- When constructing calls, it is easier to keep the ArgReps and the+-- CmmExprs zipped together.  However, a void argument has no+-- representation, so we need to use Maybe CmmExpr (the alternative of+-- using zeroCLit or even undefined would work, but would be ugly).+--+getArgRepsAmodes :: [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)]+getArgRepsAmodes = mapM getArgRepAmode+  where getArgRepAmode arg+           | V <- rep  = return (V, Nothing)+           | otherwise = do expr <- getArgAmode (NonVoid arg)+                            return (rep, Just expr)+           where rep = toArgRep (argPrimRep arg)++nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]+nonVArgs [] = []+nonVArgs ((_,Nothing)  : args) = nonVArgs args+nonVArgs ((_,Just arg) : args) = arg : nonVArgs args++{-+Note [over-saturated calls]++The natural thing to do for an over-saturated call would be to call+the function with the correct number of arguments, and then apply the+remaining arguments to the value returned, e.g.++  f a b c d   (where f has arity 2)+  -->+  r = call f(a,b)+  call r(c,d)++but this entails+  - saving c and d on the stack+  - making a continuation info table+  - at the continuation, loading c and d off the stack into regs+  - finally, call r++Note that since there are a fixed number of different r's+(e.g.  stg_ap_pp_fast), we can also pre-compile continuations+that correspond to each of them, rather than generating a fresh+one for each over-saturated call.++Not only does this generate much less code, it is faster too.  We will+generate something like:++Sp[old+16] = c+Sp[old+24] = d+Sp[old+32] = stg_ap_pp_info+call f(a,b) -- usual calling convention++For the purposes of the CmmCall node, we count this extra stack as+just more arguments that we are passing on the stack (cml_args).+-}++-- | 'slowArgs' takes a list of function arguments and prepares them for+-- pushing on the stack for "extra" arguments to a function which requires+-- fewer arguments than we currently have.+slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]+slowArgs _ [] = []+slowArgs dflags args -- careful: reps contains voids (V), but args does not+  | gopt Opt_SccProfilingOn dflags+              = save_cccs ++ this_pat ++ slowArgs dflags rest_args+  | otherwise =              this_pat ++ slowArgs dflags rest_args+  where+    (arg_pat, n)            = slowCallPattern (map fst args)+    (call_args, rest_args)  = splitAt n args++    stg_ap_pat = mkCmmRetInfoLabel rtsUnitId arg_pat+    this_pat   = (N, Just (mkLblExpr stg_ap_pat)) : call_args+    save_cccs  = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just curCCS)]+    save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (fsLit "stg_restore_cccs")++-------------------------------------------------------------------------+----        Laying out objects on the heap and stack+-------------------------------------------------------------------------++-- The heap always grows upwards, so hpRel is easy to compute+hpRel :: VirtualHpOffset         -- virtual offset of Hp+      -> VirtualHpOffset         -- virtual offset of The Thing+      -> WordOff                -- integer word offset+hpRel hp off = off - hp++getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr+-- See Note [Virtual and real heap pointers] in StgCmmMonad+getHpRelOffset virtual_offset+  = do dflags <- getDynFlags+       hp_usg <- getHpUsage+       return (cmmRegOffW dflags hpReg (hpRel (realHp hp_usg) virtual_offset))++mkVirtHeapOffsets+  :: DynFlags+  -> Bool                     -- True <=> is a thunk+  -> [NonVoid (PrimRep,a)]    -- Things to make offsets for+  -> (WordOff,                -- _Total_ number of words allocated+      WordOff,                -- Number of words allocated for *pointers*+      [(NonVoid a, ByteOff)])++-- Things with their offsets from start of object in order of+-- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER+-- First in list gets lowest offset, which is initial offset + 1.+--+-- mkVirtHeapOffsets always returns boxed things with smaller offsets+-- than the unboxed things++mkVirtHeapOffsets dflags is_thunk things+  = ASSERT(not (any (isVoidRep . fst . fromNonVoid) things))+    ( bytesToWordsRoundUp dflags tot_bytes+    , bytesToWordsRoundUp dflags bytes_of_ptrs+    , ptrs_w_offsets ++ non_ptrs_w_offsets+    )+  where+    hdr_words | is_thunk   = thunkHdrSize dflags+              | otherwise  = fixedHdrSizeW dflags+    hdr_bytes = wordsToBytes dflags hdr_words++    (ptrs, non_ptrs) = partition (isGcPtrRep . fst . fromNonVoid) things++    (bytes_of_ptrs, ptrs_w_offsets) =+       mapAccumL computeOffset 0 ptrs+    (tot_bytes, non_ptrs_w_offsets) =+       mapAccumL computeOffset bytes_of_ptrs non_ptrs++    computeOffset bytes_so_far nv_thing+      = (bytes_so_far + wordsToBytes dflags (argRepSizeW dflags (toArgRep rep)),+         (NonVoid thing, hdr_bytes + bytes_so_far))+           where (rep,thing) = fromNonVoid nv_thing++-- | Just like mkVirtHeapOffsets, but for constructors+mkVirtConstrOffsets+  :: DynFlags -> [NonVoid (PrimRep, a)]+  -> (WordOff, WordOff, [(NonVoid a, ByteOff)])+mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags False++-- | Just like mkVirtConstrOffsets, but used when we don't have the actual+-- arguments. Useful when e.g. generating info tables; we just need to know+-- sizes of pointer and non-pointer fields.+mkVirtConstrSizes :: DynFlags -> [NonVoid PrimRep] -> (WordOff, WordOff)+mkVirtConstrSizes dflags field_reps+  = (tot_wds, ptr_wds)+  where+    (tot_wds, ptr_wds, _) =+       mkVirtConstrOffsets dflags+         (map (\nv_rep -> NonVoid (fromNonVoid nv_rep, ())) field_reps)++-------------------------------------------------------------------------+--+--        Making argument descriptors+--+--  An argument descriptor describes the layout of args on the stack,+--  both for         * GC (stack-layout) purposes, and+--                * saving/restoring registers when a heap-check fails+--+-- Void arguments aren't important, therefore (contrast constructSlowCall)+--+-------------------------------------------------------------------------++-- bring in ARG_P, ARG_N, etc.+#include "rts/storage/FunTypes.h"++mkArgDescr :: DynFlags -> [Id] -> ArgDescr+mkArgDescr dflags args+  = let arg_bits = argBits dflags arg_reps+        arg_reps = filter isNonV (map idArgRep args)+           -- Getting rid of voids eases matching of standard patterns+    in case stdPattern arg_reps of+         Just spec_id -> ArgSpec spec_id+         Nothing      -> ArgGen  arg_bits++argBits :: DynFlags -> [ArgRep] -> [Bool]        -- True for non-ptr, False for ptr+argBits _      []           = []+argBits dflags (P   : args) = False : argBits dflags args+argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True)+                    ++ argBits dflags args++----------------------+stdPattern :: [ArgRep] -> Maybe Int+stdPattern reps+  = case reps of+        []    -> Just ARG_NONE        -- just void args, probably+        [N]   -> Just ARG_N+        [P]   -> Just ARG_P+        [F]   -> Just ARG_F+        [D]   -> Just ARG_D+        [L]   -> Just ARG_L+        [V16] -> Just ARG_V16+        [V32] -> Just ARG_V32+        [V64] -> Just ARG_V64++        [N,N] -> Just ARG_NN+        [N,P] -> Just ARG_NP+        [P,N] -> Just ARG_PN+        [P,P] -> Just ARG_PP++        [N,N,N] -> Just ARG_NNN+        [N,N,P] -> Just ARG_NNP+        [N,P,N] -> Just ARG_NPN+        [N,P,P] -> Just ARG_NPP+        [P,N,N] -> Just ARG_PNN+        [P,N,P] -> Just ARG_PNP+        [P,P,N] -> Just ARG_PPN+        [P,P,P] -> Just ARG_PPP++        [P,P,P,P]     -> Just ARG_PPPP+        [P,P,P,P,P]   -> Just ARG_PPPPP+        [P,P,P,P,P,P] -> Just ARG_PPPPPP++        _ -> Nothing++-------------------------------------------------------------------------+--+--        Generating the info table and code for a closure+--+-------------------------------------------------------------------------++-- Here we make an info table of type 'CmmInfo'.  The concrete+-- representation as a list of 'CmmAddr' is handled later+-- in the pipeline by 'cmmToRawCmm'.+-- When loading the free variables, a function closure pointer may be tagged,+-- so we must take it into account.++emitClosureProcAndInfoTable :: Bool                    -- top-level?+                            -> Id                      -- name of the closure+                            -> LambdaFormInfo+                            -> CmmInfoTable+                            -> [NonVoid Id]            -- incoming arguments+                            -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body+                            -> FCode ()+emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body+ = do   { dflags <- getDynFlags+        -- Bind the binder itself, but only if it's not a top-level+        -- binding. We need non-top let-bindings to refer to the+        -- top-level binding, which this binding would incorrectly shadow.+        ; node <- if top_lvl then return $ idToReg dflags (NonVoid bndr)+                  else bindToReg (NonVoid bndr) lf_info+        ; let node_points = nodeMustPointToIt dflags lf_info+        ; arg_regs <- bindArgsToRegs args+        ; let args' = if node_points then (node : arg_regs) else arg_regs+              conv  = if nodeMustPointToIt dflags lf_info then NativeNodeCall+                                                          else NativeDirectCall+              (offset, _, _) = mkCallEntry dflags conv args' []+        ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs)+        }++-- Data constructors need closures, but not with all the argument handling+-- needed for functions. The shared part goes here.+emitClosureAndInfoTable ::+  CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()+emitClosureAndInfoTable info_tbl conv args body+  = do { (_, blks) <- getCodeScoped body+       ; let entry_lbl = toEntryLbl (cit_lbl info_tbl)+       ; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks+       }
+ codeGen/StgCmmMonad.hs view
@@ -0,0 +1,900 @@+{-# LANGUAGE CPP, GADTs, UnboxedTuples #-}++-----------------------------------------------------------------------------+--+-- Monad for Stg to C-- code generation+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module StgCmmMonad (+        FCode,        -- type++        initC, runC, thenC, thenFC, listCs,+        returnFC, fixC,+        newUnique, newUniqSupply,++        emitLabel,++        emit, emitDecl, emitProc,+        emitProcWithConvention, emitProcWithStackFrame,+        emitOutOfLine, emitAssign, emitStore,+        emitComment, emitTick, emitUnwind,++        getCmm, aGraphToGraph,+        getCodeR, getCode, getCodeScoped, getHeapUsage,++        mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,+        mkCmmIfThenElse', mkCmmIfThen', mkCmmIfGoto',++        mkCall, mkCmmCall,++        forkClosureBody, forkLneBody, forkAlts, codeOnly,++        ConTagZ,++        Sequel(..), ReturnKind(..),+        withSequel, getSequel,++        setTickyCtrLabel, getTickyCtrLabel,+        tickScope, getTickScope,++        withUpdFrameOff, getUpdFrameOff, initUpdFrameOff,++        HeapUsage(..), VirtualHpOffset,        initHpUsage,+        getHpUsage,  setHpUsage, heapHWM,+        setVirtHp, getVirtHp, setRealHp,++        getModuleName,++        -- ideally we wouldn't export these, but some other modules access internal state+        getState, setState, getSelfLoop, withSelfLoop, getInfoDown, getDynFlags, getThisPackage,++        -- more localised access to monad state+        CgIdInfo(..),+        getBinds, setBinds,++        -- out of general friendliness, we also export ...+        CgInfoDownwards(..), CgState(..)        -- non-abstract+    ) where++#include "HsVersions.h"++import Cmm+import StgCmmClosure+import DynFlags+import Hoopl+import Maybes+import MkGraph+import BlockId+import CLabel+import SMRep+import Module+import Id+import VarEnv+import OrdList+import Unique+import UniqSupply+import FastString+import Outputable++import Control.Monad+import Data.List+import Prelude hiding( sequence, succ )++infixr 9 `thenC`        -- Right-associative!+infixr 9 `thenFC`+++--------------------------------------------------------+-- The FCode monad and its types+--+-- FCode is the monad plumbed through the Stg->Cmm code generator, and+-- the Cmm parser.  It contains the following things:+--+--  - A writer monad, collecting:+--    - code for the current function, in the form of a CmmAGraph.+--      The function "emit" appends more code to this.+--    - the top-level CmmDecls accumulated so far+--+--  - A state monad with:+--    - the local bindings in scope+--    - the current heap usage+--    - a UniqSupply+--+--  - A reader monad, for CgInfoDownwards, containing+--    - DynFlags,+--    - the current Module+--    - the update-frame offset+--    - the ticky counter label+--    - the Sequel (the continuation to return to)+--    - the self-recursive tail call information++--------------------------------------------------------++newtype FCode a = FCode (CgInfoDownwards -> CgState -> (# a, CgState #))++instance Functor FCode where+  fmap f (FCode g) = FCode $ \i s -> case g i s of (# a, s' #) -> (# f a, s' #)++instance Applicative FCode where+      pure = returnFC+      (<*>) = ap++instance Monad FCode where+        (>>=) = thenFC++{-# INLINE thenC #-}+{-# INLINE thenFC #-}+{-# INLINE returnFC #-}++instance MonadUnique FCode where+  getUniqueSupplyM = cgs_uniqs <$> getState+  getUniqueM = FCode $ \_ st ->+    let (u, us') = takeUniqFromSupply (cgs_uniqs st)+    in (# u, st { cgs_uniqs = us' } #)++initC :: IO CgState+initC  = do { uniqs <- mkSplitUniqSupply 'c'+            ; return (initCgState uniqs) }++runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState)+runC dflags mod st fcode = doFCode fcode (initCgInfoDown dflags mod) st++returnFC :: a -> FCode a+returnFC val = FCode (\_info_down state -> (# val, state #))++thenC :: FCode () -> FCode a -> FCode a+thenC (FCode m) (FCode k) =+        FCode $ \info_down state -> case m info_down state of+                                     (# _,new_state #) -> k info_down new_state++listCs :: [FCode ()] -> FCode ()+listCs [] = return ()+listCs (fc:fcs) = do+        fc+        listCs fcs++thenFC  :: FCode a -> (a -> FCode c) -> FCode c+thenFC (FCode m) k = FCode $+        \info_down state ->+            case m info_down state of+              (# m_result, new_state #) ->+                 case k m_result of+                   FCode kcode -> kcode info_down new_state++fixC :: (a -> FCode a) -> FCode a+fixC fcode = FCode (+        \info_down state ->+                let+                        (v,s) = doFCode (fcode v) info_down state+                in+                        (# v, s #)+        )++--------------------------------------------------------+--        The code generator environment+--------------------------------------------------------++-- This monadery has some information that it only passes+-- *downwards*, as well as some ``state'' which is modified+-- as we go along.++data CgInfoDownwards        -- information only passed *downwards* by the monad+  = MkCgInfoDown {+        cgd_dflags    :: DynFlags,+        cgd_mod       :: Module,            -- Module being compiled+        cgd_updfr_off :: UpdFrameOffset,    -- Size of current update frame+        cgd_ticky     :: CLabel,            -- Current destination for ticky counts+        cgd_sequel    :: Sequel,            -- What to do at end of basic block+        cgd_self_loop :: Maybe SelfLoopInfo,-- Which tail calls can be compiled+                                            -- as local jumps? See Note+                                            -- [Self-recursive tail calls] in+                                            -- StgCmmExpr+        cgd_tick_scope:: CmmTickScope       -- Tick scope for new blocks & ticks+  }++type CgBindings = IdEnv CgIdInfo++data CgIdInfo+  = CgIdInfo+        { cg_id :: Id   -- Id that this is the info for+                        -- Can differ from the Id at occurrence sites by+                        -- virtue of being externalised, for splittable C+                        -- See Note [Externalise when splitting]+        , cg_lf  :: LambdaFormInfo+        , cg_loc :: CgLoc                     -- CmmExpr for the *tagged* value+        }++-- Note [Externalise when splitting]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- If we're splitting the object with -fsplit-objs, we need to+-- externalise *all* the top-level names, and then make sure we only+-- use the externalised one in any C label we use which refers to this+-- name.++instance Outputable CgIdInfo where+  ppr (CgIdInfo { cg_id = id, cg_loc = loc })+    = ppr id <+> text "-->" <+> ppr loc++-- Sequel tells what to do with the result of this expression+data Sequel+  = Return              -- Return result(s) to continuation found on the stack.++  | AssignTo+        [LocalReg]      -- Put result(s) in these regs and fall through+                        -- NB: no void arguments here+                        --+        Bool            -- Should we adjust the heap pointer back to+                        -- recover space that's unused on this path?+                        -- We need to do this only if the expression+                        -- may allocate (e.g. it's a foreign call or+                        -- allocating primOp)++instance Outputable Sequel where+    ppr Return = text "Return"+    ppr (AssignTo regs b) = text "AssignTo" <+> ppr regs <+> ppr b++-- See Note [sharing continuations] below+data ReturnKind+  = AssignedDirectly+  | ReturnedTo BlockId ByteOff++-- Note [sharing continuations]+--+-- ReturnKind says how the expression being compiled returned its+-- results: either by assigning directly to the registers specified+-- by the Sequel, or by returning to a continuation that does the+-- assignments.  The point of this is we might be able to re-use the+-- continuation in a subsequent heap-check.  Consider:+--+--    case f x of z+--      True  -> <True code>+--      False -> <False code>+--+-- Naively we would generate+--+--    R2 = x   -- argument to f+--    Sp[young(L1)] = L1+--    call f returns to L1+--  L1:+--    z = R1+--    if (z & 1) then Ltrue else Lfalse+--  Ltrue:+--    Hp = Hp + 24+--    if (Hp > HpLim) then L4 else L7+--  L4:+--    HpAlloc = 24+--    goto L5+--  L5:+--    R1 = z+--    Sp[young(L6)] = L6+--    call stg_gc_unpt_r1 returns to L6+--  L6:+--    z = R1+--    goto L1+--  L7:+--    <True code>+--  Lfalse:+--    <False code>+--+-- We want the gc call in L4 to return to L1, and discard L6.  Note+-- that not only can we share L1 and L6, but the assignment of the+-- return address in L4 is unnecessary because the return address for+-- L1 is already on the stack.  We used to catch the sharing of L1 and+-- L6 in the common-block-eliminator, but not the unnecessary return+-- address assignment.+--+-- Since this case is so common I decided to make it more explicit and+-- robust by programming the sharing directly, rather than relying on+-- the common-block elimiantor to catch it.  This makes+-- common-block-elimianteion an optional optimisation, and furthermore+-- generates less code in the first place that we have to subsequently+-- clean up.+--+-- There are some rarer cases of common blocks that we don't catch+-- this way, but that's ok.  Common-block-elimination is still available+-- to catch them when optimisation is enabled.  Some examples are:+--+--   - when both the True and False branches do a heap check, we+--     can share the heap-check failure code L4a and maybe L4+--+--   - in a case-of-case, there might be multiple continuations that+--     we can common up.+--+-- It is always safe to use AssignedDirectly.  Expressions that jump+-- to the continuation from multiple places (e.g. case expressions)+-- fall back to AssignedDirectly.+--+++initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards+initCgInfoDown dflags mod+  = MkCgInfoDown { cgd_dflags    = dflags+                 , cgd_mod       = mod+                 , cgd_updfr_off = initUpdFrameOff dflags+                 , cgd_ticky     = mkTopTickyCtrLabel+                 , cgd_sequel    = initSequel+                 , cgd_self_loop = Nothing+                 , cgd_tick_scope= GlobalScope }++initSequel :: Sequel+initSequel = Return++initUpdFrameOff :: DynFlags -> UpdFrameOffset+initUpdFrameOff dflags = widthInBytes (wordWidth dflags) -- space for the RA+++--------------------------------------------------------+--        The code generator state+--------------------------------------------------------++data CgState+  = MkCgState {+     cgs_stmts :: CmmAGraph,          -- Current procedure++     cgs_tops  :: OrdList CmmDecl,+        -- Other procedures and data blocks in this compilation unit+        -- Both are ordered only so that we can+        -- reduce forward references, when it's easy to do so++     cgs_binds :: CgBindings,++     cgs_hp_usg  :: HeapUsage,++     cgs_uniqs :: UniqSupply }++data HeapUsage   -- See Note [Virtual and real heap pointers]+  = HeapUsage {+        virtHp :: VirtualHpOffset,       -- Virtual offset of highest-allocated word+                                         --   Incremented whenever we allocate+        realHp :: VirtualHpOffset        -- realHp: Virtual offset of real heap ptr+                                         --   Used in instruction addressing modes+    }++type VirtualHpOffset = WordOff+++{- Note [Virtual and real heap pointers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The code generator can allocate one or more objects contiguously, performing+one heap check to cover allocation of all the objects at once.  Let's call+this little chunk of heap space an "allocation chunk".  The code generator+will emit code to+  * Perform a heap-exhaustion check+  * Move the heap pointer to the end of the allocation chunk+  * Allocate multiple objects within the chunk++The code generator uses VirtualHpOffsets to address words within a+single allocation chunk; these start at one and increase positively.+The first word of the chunk has VirtualHpOffset=1, the second has+VirtualHpOffset=2, and so on.++ * The field realHp tracks (the VirtualHpOffset) where the real Hp+   register is pointing.  Typically it'll be pointing to the end of the+   allocation chunk.++ * The field virtHp gives the VirtualHpOffset of the highest-allocated+   word so far.  It starts at zero (meaning no word has been allocated),+   and increases whenever an object is allocated.++The difference between realHp and virtHp gives the offset from the+real Hp register of a particular word in the allocation chunk. This+is what getHpRelOffset does.  Since the returned offset is relative+to the real Hp register, it is valid only until you change the real+Hp register.  (Changing virtHp doesn't matter.)+-}+++initCgState :: UniqSupply -> CgState+initCgState uniqs+  = MkCgState { cgs_stmts  = mkNop+              , cgs_tops   = nilOL+              , cgs_binds  = emptyVarEnv+              , cgs_hp_usg = initHpUsage+              , cgs_uniqs  = uniqs }++stateIncUsage :: CgState -> CgState -> CgState+-- stateIncUsage@ e1 e2 incorporates in e1+-- the heap high water mark found in e2.+stateIncUsage s1 s2@(MkCgState { cgs_hp_usg = hp_usg })+     = s1 { cgs_hp_usg  = cgs_hp_usg  s1 `maxHpHw`  virtHp hp_usg }+       `addCodeBlocksFrom` s2++addCodeBlocksFrom :: CgState -> CgState -> CgState+-- Add code blocks from the latter to the former+-- (The cgs_stmts will often be empty, but not always; see codeOnly)+s1 `addCodeBlocksFrom` s2+  = s1 { cgs_stmts = cgs_stmts s1 MkGraph.<*> cgs_stmts s2,+         cgs_tops  = cgs_tops  s1 `appOL` cgs_tops  s2 }+++-- The heap high water mark is the larger of virtHp and hwHp.  The latter is+-- only records the high water marks of forked-off branches, so to find the+-- heap high water mark you have to take the max of virtHp and hwHp.  Remember,+-- virtHp never retreats!+--+-- Note Jan 04: ok, so why do we only look at the virtual Hp??++heapHWM :: HeapUsage -> VirtualHpOffset+heapHWM = virtHp++initHpUsage :: HeapUsage+initHpUsage = HeapUsage { virtHp = 0, realHp = 0 }++maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage+hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }++--------------------------------------------------------+-- Operators for getting and setting the state and "info_down".+--------------------------------------------------------++getState :: FCode CgState+getState = FCode $ \_info_down state -> (# state, state #)++setState :: CgState -> FCode ()+setState state = FCode $ \_info_down _ -> (# (), state #)++getHpUsage :: FCode HeapUsage+getHpUsage = do+        state <- getState+        return $ cgs_hp_usg state++setHpUsage :: HeapUsage -> FCode ()+setHpUsage new_hp_usg = do+        state <- getState+        setState $ state {cgs_hp_usg = new_hp_usg}++setVirtHp :: VirtualHpOffset -> FCode ()+setVirtHp new_virtHp+  = do  { hp_usage <- getHpUsage+        ; setHpUsage (hp_usage {virtHp = new_virtHp}) }++getVirtHp :: FCode VirtualHpOffset+getVirtHp+  = do  { hp_usage <- getHpUsage+        ; return (virtHp hp_usage) }++setRealHp ::  VirtualHpOffset -> FCode ()+setRealHp new_realHp+  = do  { hp_usage <- getHpUsage+        ; setHpUsage (hp_usage {realHp = new_realHp}) }++getBinds :: FCode CgBindings+getBinds = do+        state <- getState+        return $ cgs_binds state++setBinds :: CgBindings -> FCode ()+setBinds new_binds = do+        state <- getState+        setState $ state {cgs_binds = new_binds}++withState :: FCode a -> CgState -> FCode (a,CgState)+withState (FCode fcode) newstate = FCode $ \info_down state ->+  case fcode info_down newstate of+    (# retval, state2 #) -> (# (retval,state2), state #)++newUniqSupply :: FCode UniqSupply+newUniqSupply = do+        state <- getState+        let (us1, us2) = splitUniqSupply (cgs_uniqs state)+        setState $ state { cgs_uniqs = us1 }+        return us2++newUnique :: FCode Unique+newUnique = do+        state <- getState+        let (u,us') = takeUniqFromSupply (cgs_uniqs state)+        setState $ state { cgs_uniqs = us' }+        return u++------------------+getInfoDown :: FCode CgInfoDownwards+getInfoDown = FCode $ \info_down state -> (# info_down,state #)++getSelfLoop :: FCode (Maybe SelfLoopInfo)+getSelfLoop = do+        info_down <- getInfoDown+        return $ cgd_self_loop info_down++withSelfLoop :: SelfLoopInfo -> FCode a -> FCode a+withSelfLoop self_loop code = do+        info_down <- getInfoDown+        withInfoDown code (info_down {cgd_self_loop = Just self_loop})++instance HasDynFlags FCode where+    getDynFlags = liftM cgd_dflags getInfoDown++getThisPackage :: FCode UnitId+getThisPackage = liftM thisPackage getDynFlags++withInfoDown :: FCode a -> CgInfoDownwards -> FCode a+withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state++doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)+doFCode (FCode fcode) info_down state =+  case fcode info_down state of+    (# a, s #) -> ( a, s )++-- ----------------------------------------------------------------------------+-- Get the current module name++getModuleName :: FCode Module+getModuleName = do { info <- getInfoDown; return (cgd_mod info) }++-- ----------------------------------------------------------------------------+-- Get/set the end-of-block info++withSequel :: Sequel -> FCode a -> FCode a+withSequel sequel code+  = do  { info  <- getInfoDown+        ; withInfoDown code (info {cgd_sequel = sequel, cgd_self_loop = Nothing }) }++getSequel :: FCode Sequel+getSequel = do  { info <- getInfoDown+                ; return (cgd_sequel info) }++-- ----------------------------------------------------------------------------+-- Get/set the size of the update frame++-- We keep track of the size of the update frame so that we+-- can set the stack pointer to the proper address on return+-- (or tail call) from the closure.+-- There should be at most one update frame for each closure.+-- Note: I'm including the size of the original return address+-- in the size of the update frame -- hence the default case on `get'.++withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a+withUpdFrameOff size code+  = do  { info  <- getInfoDown+        ; withInfoDown code (info {cgd_updfr_off = size }) }++getUpdFrameOff :: FCode UpdFrameOffset+getUpdFrameOff+  = do  { info  <- getInfoDown+        ; return $ cgd_updfr_off info }++-- ----------------------------------------------------------------------------+-- Get/set the current ticky counter label++getTickyCtrLabel :: FCode CLabel+getTickyCtrLabel = do+        info <- getInfoDown+        return (cgd_ticky info)++setTickyCtrLabel :: CLabel -> FCode a -> FCode a+setTickyCtrLabel ticky code = do+        info <- getInfoDown+        withInfoDown code (info {cgd_ticky = ticky})++-- ----------------------------------------------------------------------------+-- Manage tick scopes++-- | The current tick scope. We will assign this to generated blocks.+getTickScope :: FCode CmmTickScope+getTickScope = do+        info <- getInfoDown+        return (cgd_tick_scope info)++-- | Places blocks generated by the given code into a fresh+-- (sub-)scope. This will make sure that Cmm annotations in our scope+-- will apply to the Cmm blocks generated therein - but not the other+-- way around.+tickScope :: FCode a -> FCode a+tickScope code = do+        info <- getInfoDown+        if debugLevel (cgd_dflags info) == 0 then code else do+          u <- newUnique+          let scope' = SubScope u (cgd_tick_scope info)+          withInfoDown code info{ cgd_tick_scope = scope' }+++--------------------------------------------------------+--                 Forking+--------------------------------------------------------++forkClosureBody :: FCode () -> FCode ()+-- forkClosureBody compiles body_code in environment where:+--   - sequel, update stack frame and self loop info are+--     set to fresh values+--   - state is set to a fresh value, except for local bindings+--     that are passed in unchanged. It's up to the enclosed code to+--     re-bind the free variables to a field of the closure.++forkClosureBody body_code+  = do  { dflags <- getDynFlags+        ; info   <- getInfoDown+        ; us     <- newUniqSupply+        ; state  <- getState+        ; let body_info_down = info { cgd_sequel    = initSequel+                                    , cgd_updfr_off = initUpdFrameOff dflags+                                    , cgd_self_loop = Nothing }+              fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }+              ((),fork_state_out) = doFCode body_code body_info_down fork_state_in+        ; setState $ state `addCodeBlocksFrom` fork_state_out }++forkLneBody :: FCode a -> FCode a+-- 'forkLneBody' takes a body of let-no-escape binding and compiles+-- it in the *current* environment, returning the graph thus constructed.+--+-- The current environment is passed on completely unchanged to+-- the successor.  In particular, any heap usage from the enclosed+-- code is discarded; it should deal with its own heap consumption.+forkLneBody body_code+  = do  { info_down <- getInfoDown+        ; us        <- newUniqSupply+        ; state     <- getState+        ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }+              (result, fork_state_out) = doFCode body_code info_down fork_state_in+        ; setState $ state `addCodeBlocksFrom` fork_state_out+        ; return result }++codeOnly :: FCode () -> FCode ()+-- Emit any code from the inner thing into the outer thing+-- Do not affect anything else in the outer state+-- Used in almost-circular code to prevent false loop dependencies+codeOnly body_code+  = do  { info_down <- getInfoDown+        ; us        <- newUniqSupply+        ; state     <- getState+        ; let   fork_state_in = (initCgState us) { cgs_binds   = cgs_binds state+                                                 , cgs_hp_usg  = cgs_hp_usg state }+                ((), fork_state_out) = doFCode body_code info_down fork_state_in+        ; setState $ state `addCodeBlocksFrom` fork_state_out }++forkAlts :: [FCode a] -> FCode [a]+-- (forkAlts' bs d) takes fcodes 'bs' for the branches of a 'case', and+-- an fcode for the default case 'd', and compiles each in the current+-- environment.  The current environment is passed on unmodified, except+-- that the virtual Hp is moved on to the worst virtual Hp for the branches++forkAlts branch_fcodes+  = do  { info_down <- getInfoDown+        ; us <- newUniqSupply+        ; state <- getState+        ; let compile us branch+                = (us2, doFCode branch info_down branch_state)+                where+                  (us1,us2) = splitUniqSupply us+                  branch_state = (initCgState us1) {+                                        cgs_binds  = cgs_binds state+                                      , cgs_hp_usg = cgs_hp_usg state }+              (_us, results) = mapAccumL compile us branch_fcodes+              (branch_results, branch_out_states) = unzip results+        ; setState $ foldl stateIncUsage state branch_out_states+                -- NB foldl.  state is the *left* argument to stateIncUsage+        ; return branch_results }++-- collect the code emitted by an FCode computation+getCodeR :: FCode a -> FCode (a, CmmAGraph)+getCodeR fcode+  = do  { state1 <- getState+        ; (a, state2) <- withState fcode (state1 { cgs_stmts = mkNop })+        ; setState $ state2 { cgs_stmts = cgs_stmts state1  }+        ; return (a, cgs_stmts state2) }++getCode :: FCode a -> FCode CmmAGraph+getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts }++-- | Generate code into a fresh tick (sub-)scope and gather generated code+getCodeScoped :: FCode a -> FCode (a, CmmAGraphScoped)+getCodeScoped fcode+  = do  { state1 <- getState+        ; ((a, tscope), state2) <-+            tickScope $+            flip withState state1 { cgs_stmts = mkNop } $+            do { a   <- fcode+               ; scp <- getTickScope+               ; return (a, scp) }+        ; setState $ state2 { cgs_stmts = cgs_stmts state1  }+        ; return (a, (cgs_stmts state2, tscope)) }+++-- 'getHeapUsage' applies a function to the amount of heap that it uses.+-- It initialises the heap usage to zeros, and passes on an unchanged+-- heap usage.+--+-- It is usually a prelude to performing a GC check, so everything must+-- be in a tidy and consistent state.+--+-- Note the slightly subtle fixed point behaviour needed here++getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a+getHeapUsage fcode+  = do  { info_down <- getInfoDown+        ; state <- getState+        ; let   fstate_in = state { cgs_hp_usg  = initHpUsage }+                (r, fstate_out) = doFCode (fcode hp_hw) info_down fstate_in+                hp_hw = heapHWM (cgs_hp_usg fstate_out)        -- Loop here!++        ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state }+        ; return r }++-- ----------------------------------------------------------------------------+-- Combinators for emitting code++emitCgStmt :: CgStmt -> FCode ()+emitCgStmt stmt+  = do  { state <- getState+        ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }+        }++emitLabel :: BlockId -> FCode ()+emitLabel id = do tscope <- getTickScope+                  emitCgStmt (CgLabel id tscope)++emitComment :: FastString -> FCode ()+#if 0 /* def DEBUG */+emitComment s = emitCgStmt (CgStmt (CmmComment s))+#else+emitComment _ = return ()+#endif++emitTick :: CmmTickish -> FCode ()+emitTick = emitCgStmt . CgStmt . CmmTick++emitUnwind :: [(GlobalReg, Maybe CmmExpr)] -> FCode ()+emitUnwind regs = do+  dflags <- getDynFlags+  when (debugLevel dflags > 0) $ do+     emitCgStmt $ CgStmt $ CmmUnwind regs++emitAssign :: CmmReg  -> CmmExpr -> FCode ()+emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r))++emitStore :: CmmExpr  -> CmmExpr -> FCode ()+emitStore l r = emitCgStmt (CgStmt (CmmStore l r))++emit :: CmmAGraph -> FCode ()+emit ag+  = do  { state <- getState+        ; setState $ state { cgs_stmts = cgs_stmts state MkGraph.<*> ag } }++emitDecl :: CmmDecl -> FCode ()+emitDecl decl+  = do  { state <- getState+        ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }++emitOutOfLine :: BlockId -> CmmAGraphScoped -> FCode ()+emitOutOfLine l (stmts, tscope) = emitCgStmt (CgFork l stmts tscope)++emitProcWithStackFrame+   :: Convention                        -- entry convention+   -> Maybe CmmInfoTable                -- info table?+   -> CLabel                            -- label for the proc+   -> [CmmFormal]                       -- stack frame+   -> [CmmFormal]                       -- arguments+   -> CmmAGraphScoped                   -- code+   -> Bool                              -- do stack layout?+   -> FCode ()++emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False+  = do  { dflags <- getDynFlags+        ; emitProc_ mb_info lbl [] blocks (widthInBytes (wordWidth dflags)) False+        }+emitProcWithStackFrame conv mb_info lbl stk_args args (graph, tscope) True+        -- do layout+  = do  { dflags <- getDynFlags+        ; let (offset, live, entry) = mkCallEntry dflags conv args stk_args+              graph' = entry MkGraph.<*> graph+        ; emitProc_ mb_info lbl live (graph', tscope) offset True+        }+emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame"++emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel+                       -> [CmmFormal]+                       -> CmmAGraphScoped+                       -> FCode ()+emitProcWithConvention conv mb_info lbl args blocks+  = emitProcWithStackFrame conv mb_info lbl [] args blocks True++emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped+         -> Int -> FCode ()+emitProc  mb_info lbl live blocks offset+ = emitProc_ mb_info lbl live blocks offset True++emitProc_ :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped+          -> Int -> Bool -> FCode ()+emitProc_ mb_info lbl live blocks offset do_layout+  = do  { dflags <- getDynFlags+        ; l <- newBlockId+        ; let+              blks = labelAGraph l blocks++              infos | Just info <- mb_info = mapSingleton (g_entry blks) info+                    | otherwise            = mapEmpty++              sinfo = StackInfo { arg_space = offset+                                , updfr_space = Just (initUpdFrameOff dflags)+                                , do_layout = do_layout }++              tinfo = TopInfo { info_tbls = infos+                              , stack_info=sinfo}++              proc_block = CmmProc tinfo lbl live blks++        ; state <- getState+        ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }++getCmm :: FCode () -> FCode CmmGroup+-- Get all the CmmTops (there should be no stmts)+-- Return a single Cmm which may be split from other Cmms by+-- object splitting (at a later stage)+getCmm code+  = do  { state1 <- getState+        ; ((), state2) <- withState code (state1 { cgs_tops  = nilOL })+        ; setState $ state2 { cgs_tops = cgs_tops state1 }+        ; return (fromOL (cgs_tops state2)) }+++mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph+mkCmmIfThenElse e tbranch fbranch = mkCmmIfThenElse' e tbranch fbranch Nothing++mkCmmIfThenElse' :: CmmExpr -> CmmAGraph -> CmmAGraph+                 -> Maybe Bool -> FCode CmmAGraph+mkCmmIfThenElse' e tbranch fbranch likely = do+  tscp  <- getTickScope+  endif <- newBlockId+  tid   <- newBlockId+  fid   <- newBlockId++  let+    (test, then_, else_, likely') = case likely of+      Just False | Just e' <- maybeInvertCmmExpr e+        -- currently NCG doesn't know about likely+        -- annotations. We manually switch then and+        -- else branch so the likely false branch+        -- becomes a fallthrough.+        -> (e', fbranch, tbranch, Just True)+      _ -> (e, tbranch, fbranch, likely)++  return $ catAGraphs [ mkCbranch test tid fid likely'+                      , mkLabel tid tscp, then_, mkBranch endif+                      , mkLabel fid tscp, else_, mkLabel endif tscp ]++mkCmmIfGoto :: CmmExpr -> BlockId -> FCode CmmAGraph+mkCmmIfGoto e tid = mkCmmIfGoto' e tid Nothing++mkCmmIfGoto' :: CmmExpr -> BlockId -> Maybe Bool -> FCode CmmAGraph+mkCmmIfGoto' e tid l = do+  endif <- newBlockId+  tscp  <- getTickScope+  return $ catAGraphs [ mkCbranch e tid endif l, mkLabel endif tscp ]++mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph+mkCmmIfThen e tbranch = mkCmmIfThen' e tbranch Nothing++mkCmmIfThen' :: CmmExpr -> CmmAGraph -> Maybe Bool -> FCode CmmAGraph+mkCmmIfThen' e tbranch l = do+  endif <- newBlockId+  tid   <- newBlockId+  tscp  <- getTickScope+  return $ catAGraphs [ mkCbranch e tid endif l+                      , mkLabel tid tscp, tbranch, mkLabel endif tscp ]++mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmExpr]+       -> UpdFrameOffset -> [CmmExpr] -> FCode CmmAGraph+mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do+  dflags <- getDynFlags+  k      <- newBlockId+  tscp   <- getTickScope+  let area = Young k+      (off, _, copyin) = copyInOflow dflags retConv area results []+      copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack+  return $ catAGraphs [copyout, mkLabel k tscp, copyin]++mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmExpr] -> UpdFrameOffset+          -> FCode CmmAGraph+mkCmmCall f results actuals updfr_off+   = mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off []+++-- ----------------------------------------------------------------------------+-- turn CmmAGraph into CmmGraph, for making a new proc.++aGraphToGraph :: CmmAGraphScoped -> FCode CmmGraph+aGraphToGraph stmts+  = do  { l <- newBlockId+        ; return (labelAGraph l stmts) }
+ codeGen/StgCmmPrim.hs view
@@ -0,0 +1,2242 @@+{-# LANGUAGE CPP #-}++----------------------------------------------------------------------------+--+-- Stg to C--: primitive operations+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module StgCmmPrim (+   cgOpApp,+   cgPrimOp, -- internal(ish), used by cgCase to get code for a+             -- comparison without also turning it into a Bool.+   shouldInlinePrimOp+ ) where++#include "HsVersions.h"++import StgCmmLayout+import StgCmmForeign+import StgCmmEnv+import StgCmmMonad+import StgCmmUtils+import StgCmmTicky+import StgCmmHeap+import StgCmmProf ( costCentreFrom, curCCS )++import DynFlags+import Platform+import BasicTypes+import BlockId+import MkGraph+import StgSyn+import Cmm+import CmmInfo+import Type     ( Type, tyConAppTyCon )+import TyCon+import CLabel+import CmmUtils+import PrimOp+import SMRep+import FastString+import Outputable+import Util++import Prelude hiding ((<*>))++import Data.Bits ((.&.), bit)+import Control.Monad (liftM, when)++------------------------------------------------------------------------+--      Primitive operations and foreign calls+------------------------------------------------------------------------++{- Note [Foreign call results]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~+A foreign call always returns an unboxed tuple of results, one+of which is the state token.  This seems to happen even for pure+calls.++Even if we returned a single result for pure calls, it'd still be+right to wrap it in a singleton unboxed tuple, because the result+might be a Haskell closure pointer, we don't want to evaluate it. -}++----------------------------------+cgOpApp :: StgOp        -- The op+        -> [StgArg]     -- Arguments+        -> Type         -- Result type (always an unboxed tuple)+        -> FCode ReturnKind++-- Foreign calls+cgOpApp (StgFCallOp fcall _) stg_args res_ty+  = cgForeignCall fcall stg_args res_ty+      -- Note [Foreign call results]++-- tagToEnum# is special: we need to pull the constructor+-- out of the table, and perform an appropriate return.++cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty+  = ASSERT(isEnumerationTyCon tycon)+    do  { dflags <- getDynFlags+        ; args' <- getNonVoidArgAmodes [arg]+        ; let amode = case args' of [amode] -> amode+                                    _ -> panic "TagToEnumOp had void arg"+        ; emitReturn [tagToClosure dflags tycon amode] }+   where+          -- If you're reading this code in the attempt to figure+          -- out why the compiler panic'ed here, it is probably because+          -- you used tagToEnum# in a non-monomorphic setting, e.g.,+          --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#+          -- That won't work.+        tycon = tyConAppTyCon res_ty++cgOpApp (StgPrimOp primop) args res_ty = do+    dflags <- getDynFlags+    cmm_args <- getNonVoidArgAmodes args+    case shouldInlinePrimOp dflags primop cmm_args of+        Nothing -> do  -- out-of-line+          let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))+          emitCall (NativeNodeCall, NativeReturn) fun cmm_args++        Just f  -- inline+          | ReturnsPrim VoidRep <- result_info+          -> do f []+                emitReturn []++          | ReturnsPrim rep <- result_info+          -> do dflags <- getDynFlags+                res <- newTemp (primRepCmmType dflags rep)+                f [res]+                emitReturn [CmmReg (CmmLocal res)]++          | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon+          -> do (regs, _hints) <- newUnboxedTupleRegs res_ty+                f regs+                emitReturn (map (CmmReg . CmmLocal) regs)++          | otherwise -> panic "cgPrimop"+          where+             result_info = getPrimOpResultInfo primop++cgOpApp (StgPrimCallOp primcall) args _res_ty+  = do  { cmm_args <- getNonVoidArgAmodes args+        ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall))+        ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args }++-- | Interpret the argument as an unsigned value, assuming the value+-- is given in two-complement form in the given width.+--+-- Example: @asUnsigned W64 (-1)@ is 18446744073709551615.+--+-- This function is used to work around the fact that many array+-- primops take Int# arguments, but we interpret them as unsigned+-- quantities in the code gen. This means that we have to be careful+-- every time we work on e.g. a CmmInt literal that corresponds to the+-- array size, as it might contain a negative Integer value if the+-- user passed a value larger than 2^(wORD_SIZE_IN_BITS-1) as the Int#+-- literal.+asUnsigned :: Width -> Integer -> Integer+asUnsigned w n = n .&. (bit (widthInBits w) - 1)++-- TODO: Several primop implementations (e.g. 'doNewByteArrayOp') use+--     ByteOff (or some other fixed width signed type) to represent+--     array sizes or indices. This means that these will overflow for+--     large enough sizes.++-- | Decide whether an out-of-line primop should be replaced by an+-- inline implementation. This might happen e.g. if there's enough+-- static information, such as statically know arguments, to emit a+-- more efficient implementation inline.+--+-- Returns 'Nothing' if this primop should use its out-of-line+-- implementation (defined elsewhere) and 'Just' together with a code+-- generating function that takes the output regs as arguments+-- otherwise.+shouldInlinePrimOp :: DynFlags+                   -> PrimOp     -- ^ The primop+                   -> [CmmExpr]  -- ^ The primop arguments+                   -> Maybe ([LocalReg] -> FCode ())++shouldInlinePrimOp dflags NewByteArrayOp_Char [(CmmLit (CmmInt n w))]+  | asUnsigned w n <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] -> doNewByteArrayOp res (fromInteger n)++shouldInlinePrimOp dflags NewArrayOp [(CmmLit (CmmInt n w)), init]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] ->+      doNewArrayOp res (arrPtrsRep dflags (fromInteger n)) mkMAP_DIRTY_infoLabel+      [ (mkIntExpr dflags (fromInteger n),+         fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags)+      , (mkIntExpr dflags (nonHdrSizeW (arrPtrsRep dflags (fromInteger n))),+         fixedHdrSize dflags + oFFSET_StgMutArrPtrs_size dflags)+      ]+      (fromInteger n) init++shouldInlinePrimOp _ CopyArrayOp+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =+        Just $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)++shouldInlinePrimOp _ CopyMutableArrayOp+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =+        Just $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)++shouldInlinePrimOp _ CopyArrayArrayOp+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =+        Just $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)++shouldInlinePrimOp _ CopyMutableArrayArrayOp+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =+        Just $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)++shouldInlinePrimOp dflags CloneArrayOp [src, src_off, (CmmLit (CmmInt n w))]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] -> emitCloneArray mkMAP_FROZEN_infoLabel res src src_off (fromInteger n)++shouldInlinePrimOp dflags CloneMutableArrayOp [src, src_off, (CmmLit (CmmInt n w))]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)++shouldInlinePrimOp dflags FreezeArrayOp [src, src_off, (CmmLit (CmmInt n w))]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] -> emitCloneArray mkMAP_FROZEN_infoLabel res src src_off (fromInteger n)++shouldInlinePrimOp dflags ThawArrayOp [src, src_off, (CmmLit (CmmInt n w))]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)++shouldInlinePrimOp dflags NewSmallArrayOp [(CmmLit (CmmInt n w)), init]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] ->+      doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel+      [ (mkIntExpr dflags (fromInteger n),+         fixedHdrSize dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags)+      ]+      (fromInteger n) init++shouldInlinePrimOp _ CopySmallArrayOp+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =+        Just $ \ [] -> doCopySmallArrayOp src src_off dst dst_off (fromInteger n)++shouldInlinePrimOp _ CopySmallMutableArrayOp+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =+        Just $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n)++shouldInlinePrimOp dflags CloneSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_infoLabel res src src_off (fromInteger n)++shouldInlinePrimOp dflags CloneSmallMutableArrayOp [src, src_off, (CmmLit (CmmInt n w))]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)++shouldInlinePrimOp dflags FreezeSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_infoLabel res src src_off (fromInteger n)++shouldInlinePrimOp dflags ThawSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)++shouldInlinePrimOp dflags primop args+  | primOpOutOfLine primop = Nothing+  | otherwise = Just $ \ regs -> emitPrimOp dflags regs primop args++-- TODO: Several primops, such as 'copyArray#', only have an inline+-- implementation (below) but could possibly have both an inline+-- implementation and an out-of-line implementation, just like+-- 'newArray#'. This would lower the amount of code generated,+-- hopefully without a performance impact (needs to be measured).++---------------------------------------------------+cgPrimOp   :: [LocalReg]        -- where to put the results+           -> PrimOp            -- the op+           -> [StgArg]          -- arguments+           -> FCode ()++cgPrimOp results op args+  = do dflags <- getDynFlags+       arg_exprs <- getNonVoidArgAmodes args+       emitPrimOp dflags results op arg_exprs+++------------------------------------------------------------------------+--      Emitting code for a primop+------------------------------------------------------------------------++emitPrimOp :: DynFlags+           -> [LocalReg]        -- where to put the results+           -> PrimOp            -- the op+           -> [CmmExpr]         -- arguments+           -> FCode ()++-- First we handle various awkward cases specially.  The remaining+-- easy cases are then handled by translateOp, defined below.++emitPrimOp _ [res] ParOp [arg]+  =+        -- for now, just implement this in a C function+        -- later, we might want to inline it.+    emitCCall+        [(res,NoHint)]+        (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))+        [(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)]++emitPrimOp dflags [res] SparkOp [arg]+  = do+        -- returns the value of arg in res.  We're going to therefore+        -- refer to arg twice (once to pass to newSpark(), and once to+        -- assign to res), so put it in a temporary.+        tmp <- assignTemp arg+        tmp2 <- newTemp (bWord dflags)+        emitCCall+            [(tmp2,NoHint)]+            (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))+            [(CmmReg (CmmGlobal BaseReg), AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]+        emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp))++emitPrimOp dflags [res] GetCCSOfOp [arg]+  = emitAssign (CmmLocal res) val+  where+    val+     | gopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg)+     | otherwise                      = CmmLit (zeroCLit dflags)++emitPrimOp _ [res] GetCurrentCCSOp [_dummy_arg]+   = emitAssign (CmmLocal res) curCCS++emitPrimOp dflags [res] ReadMutVarOp [mutv]+   = emitAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags))++emitPrimOp dflags res@[] WriteMutVarOp [mutv,var]+   = do -- Without this write barrier, other CPUs may see this pointer before+        -- the writes for the closure it points to have occurred.+        emitPrimCall res MO_WriteBarrier []+        emitStore (cmmOffsetW dflags mutv (fixedHdrSizeW dflags)) var+        emitCCall+                [{-no results-}]+                (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))+                [(CmmReg (CmmGlobal BaseReg), AddrHint), (mutv,AddrHint)]++--  #define sizzeofByteArrayzh(r,a) \+--     r = ((StgArrBytes *)(a))->bytes+emitPrimOp dflags [res] SizeofByteArrayOp [arg]+   = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))++--  #define sizzeofMutableByteArrayzh(r,a) \+--      r = ((StgArrBytes *)(a))->bytes+emitPrimOp dflags [res] SizeofMutableByteArrayOp [arg]+   = emitPrimOp dflags [res] SizeofByteArrayOp [arg]++--  #define getSizzeofMutableByteArrayzh(r,a) \+--      r = ((StgArrBytes *)(a))->bytes+emitPrimOp dflags [res] GetSizeofMutableByteArrayOp [arg]+   = emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))+++--  #define touchzh(o)                  /* nothing */+emitPrimOp _ res@[] TouchOp args@[_arg]+   = do emitPrimCall res MO_Touch args++--  #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)+emitPrimOp dflags [res] ByteArrayContents_Char [arg]+   = emitAssign (CmmLocal res) (cmmOffsetB dflags arg (arrWordsHdrSize dflags))++--  #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)+emitPrimOp dflags [res] StableNameToIntOp [arg]+   = emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))++--  #define eqStableNamezh(r,sn1,sn2)                                   \+--    (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))+emitPrimOp dflags [res] EqStableNameOp [arg1,arg2]+   = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [+                                   cmmLoadIndexW dflags arg1 (fixedHdrSizeW dflags) (bWord dflags),+                                   cmmLoadIndexW dflags arg2 (fixedHdrSizeW dflags) (bWord dflags)+                         ])++emitPrimOp dflags [res] ReallyUnsafePtrEqualityOp [arg1,arg2]+   = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2])++--  #define addrToHValuezh(r,a) r=(P_)a+emitPrimOp _      [res] AddrToAnyOp [arg]+   = emitAssign (CmmLocal res) arg++--  #define hvalueToAddrzh(r, a) r=(W_)a+emitPrimOp _      [res] AnyToAddrOp [arg]+   = emitAssign (CmmLocal res) arg++--  #define dataToTagzh(r,a)  r=(GET_TAG(((StgClosure *)a)->header.info))+--  Note: argument may be tagged!+emitPrimOp dflags [res] DataToTagOp [arg]+   = emitAssign (CmmLocal res) (getConstrTag dflags (cmmUntag dflags arg))++{- Freezing arrays-of-ptrs requires changing an info table, for the+   benefit of the generational collector.  It needs to scavenge mutable+   objects, even if they are in old space.  When they become immutable,+   they can be removed from this scavenge list.  -}++--  #define unsafeFreezzeArrayzh(r,a)+--      {+--        SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN0_info);+--        r = a;+--      }+emitPrimOp _      [res] UnsafeFreezeArrayOp [arg]+   = emit $ catAGraphs+   [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN0_infoLabel)),+     mkAssign (CmmLocal res) arg ]+emitPrimOp _      [res] UnsafeFreezeArrayArrayOp [arg]+   = emit $ catAGraphs+   [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN0_infoLabel)),+     mkAssign (CmmLocal res) arg ]+emitPrimOp _      [res] UnsafeFreezeSmallArrayOp [arg]+   = emit $ catAGraphs+   [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN0_infoLabel)),+     mkAssign (CmmLocal res) arg ]++--  #define unsafeFreezzeByteArrayzh(r,a)       r=(a)+emitPrimOp _      [res] UnsafeFreezeByteArrayOp [arg]+   = emitAssign (CmmLocal res) arg++-- Reading/writing pointer arrays++emitPrimOp _      [res] ReadArrayOp  [obj,ix]    = doReadPtrArrayOp res obj ix+emitPrimOp _      [res] IndexArrayOp [obj,ix]    = doReadPtrArrayOp res obj ix+emitPrimOp _      []  WriteArrayOp [obj,ix,v]  = doWritePtrArrayOp obj ix v++emitPrimOp _      [res] IndexArrayArrayOp_ByteArray         [obj,ix]   = doReadPtrArrayOp res obj ix+emitPrimOp _      [res] IndexArrayArrayOp_ArrayArray        [obj,ix]   = doReadPtrArrayOp res obj ix+emitPrimOp _      [res] ReadArrayArrayOp_ByteArray          [obj,ix]   = doReadPtrArrayOp res obj ix+emitPrimOp _      [res] ReadArrayArrayOp_MutableByteArray   [obj,ix]   = doReadPtrArrayOp res obj ix+emitPrimOp _      [res] ReadArrayArrayOp_ArrayArray         [obj,ix]   = doReadPtrArrayOp res obj ix+emitPrimOp _      [res] ReadArrayArrayOp_MutableArrayArray  [obj,ix]   = doReadPtrArrayOp res obj ix+emitPrimOp _      []  WriteArrayArrayOp_ByteArray         [obj,ix,v] = doWritePtrArrayOp obj ix v+emitPrimOp _      []  WriteArrayArrayOp_MutableByteArray  [obj,ix,v] = doWritePtrArrayOp obj ix v+emitPrimOp _      []  WriteArrayArrayOp_ArrayArray        [obj,ix,v] = doWritePtrArrayOp obj ix v+emitPrimOp _      []  WriteArrayArrayOp_MutableArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v++emitPrimOp _      [res] ReadSmallArrayOp  [obj,ix] = doReadSmallPtrArrayOp res obj ix+emitPrimOp _      [res] IndexSmallArrayOp [obj,ix] = doReadSmallPtrArrayOp res obj ix+emitPrimOp _      []  WriteSmallArrayOp [obj,ix,v] = doWriteSmallPtrArrayOp obj ix v++-- Getting the size of pointer arrays++emitPrimOp dflags [res] SizeofArrayOp [arg]+   = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg+    (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgMutArrPtrs_ptrs dflags))+        (bWord dflags))+emitPrimOp dflags [res] SizeofMutableArrayOp [arg]+   = emitPrimOp dflags [res] SizeofArrayOp [arg]+emitPrimOp dflags [res] SizeofArrayArrayOp [arg]+   = emitPrimOp dflags [res] SizeofArrayOp [arg]+emitPrimOp dflags [res] SizeofMutableArrayArrayOp [arg]+   = emitPrimOp dflags [res] SizeofArrayOp [arg]++emitPrimOp dflags [res] SizeofSmallArrayOp [arg] =+    emit $ mkAssign (CmmLocal res)+    (cmmLoadIndexW dflags arg+     (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgSmallMutArrPtrs_ptrs dflags))+        (bWord dflags))+emitPrimOp dflags [res] SizeofSmallMutableArrayOp [arg] =+    emitPrimOp dflags [res] SizeofSmallArrayOp [arg]++-- IndexXXXoffAddr++emitPrimOp dflags res IndexOffAddrOp_Char             args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args+emitPrimOp dflags res IndexOffAddrOp_WideChar         args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args+emitPrimOp dflags res IndexOffAddrOp_Int              args = doIndexOffAddrOp   Nothing (bWord dflags) res args+emitPrimOp dflags res IndexOffAddrOp_Word             args = doIndexOffAddrOp   Nothing (bWord dflags) res args+emitPrimOp dflags res IndexOffAddrOp_Addr             args = doIndexOffAddrOp   Nothing (bWord dflags) res args+emitPrimOp _      res IndexOffAddrOp_Float            args = doIndexOffAddrOp   Nothing f32 res args+emitPrimOp _      res IndexOffAddrOp_Double           args = doIndexOffAddrOp   Nothing f64 res args+emitPrimOp dflags res IndexOffAddrOp_StablePtr        args = doIndexOffAddrOp   Nothing (bWord dflags) res args+emitPrimOp dflags res IndexOffAddrOp_Int8             args = doIndexOffAddrOp   (Just (mo_s_8ToWord dflags)) b8  res args+emitPrimOp dflags res IndexOffAddrOp_Int16            args = doIndexOffAddrOp   (Just (mo_s_16ToWord dflags)) b16 res args+emitPrimOp dflags res IndexOffAddrOp_Int32            args = doIndexOffAddrOp   (Just (mo_s_32ToWord dflags)) b32 res args+emitPrimOp _      res IndexOffAddrOp_Int64            args = doIndexOffAddrOp   Nothing b64 res args+emitPrimOp dflags res IndexOffAddrOp_Word8            args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8  res args+emitPrimOp dflags res IndexOffAddrOp_Word16           args = doIndexOffAddrOp   (Just (mo_u_16ToWord dflags)) b16 res args+emitPrimOp dflags res IndexOffAddrOp_Word32           args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args+emitPrimOp _      res IndexOffAddrOp_Word64           args = doIndexOffAddrOp   Nothing b64 res args++-- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.++emitPrimOp dflags res ReadOffAddrOp_Char             args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args+emitPrimOp dflags res ReadOffAddrOp_WideChar         args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args+emitPrimOp dflags res ReadOffAddrOp_Int              args = doIndexOffAddrOp   Nothing (bWord dflags) res args+emitPrimOp dflags res ReadOffAddrOp_Word             args = doIndexOffAddrOp   Nothing (bWord dflags) res args+emitPrimOp dflags res ReadOffAddrOp_Addr             args = doIndexOffAddrOp   Nothing (bWord dflags) res args+emitPrimOp _      res ReadOffAddrOp_Float            args = doIndexOffAddrOp   Nothing f32 res args+emitPrimOp _      res ReadOffAddrOp_Double           args = doIndexOffAddrOp   Nothing f64 res args+emitPrimOp dflags res ReadOffAddrOp_StablePtr        args = doIndexOffAddrOp   Nothing (bWord dflags) res args+emitPrimOp dflags res ReadOffAddrOp_Int8             args = doIndexOffAddrOp   (Just (mo_s_8ToWord dflags)) b8  res args+emitPrimOp dflags res ReadOffAddrOp_Int16            args = doIndexOffAddrOp   (Just (mo_s_16ToWord dflags)) b16 res args+emitPrimOp dflags res ReadOffAddrOp_Int32            args = doIndexOffAddrOp   (Just (mo_s_32ToWord dflags)) b32 res args+emitPrimOp _      res ReadOffAddrOp_Int64            args = doIndexOffAddrOp   Nothing b64 res args+emitPrimOp dflags res ReadOffAddrOp_Word8            args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8  res args+emitPrimOp dflags res ReadOffAddrOp_Word16           args = doIndexOffAddrOp   (Just (mo_u_16ToWord dflags)) b16 res args+emitPrimOp dflags res ReadOffAddrOp_Word32           args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args+emitPrimOp _      res ReadOffAddrOp_Word64           args = doIndexOffAddrOp   Nothing b64 res args++-- IndexXXXArray++emitPrimOp dflags res IndexByteArrayOp_Char             args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8 res args+emitPrimOp dflags res IndexByteArrayOp_WideChar         args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32 res args+emitPrimOp dflags res IndexByteArrayOp_Int              args = doIndexByteArrayOp   Nothing (bWord dflags) res args+emitPrimOp dflags res IndexByteArrayOp_Word             args = doIndexByteArrayOp   Nothing (bWord dflags) res args+emitPrimOp dflags res IndexByteArrayOp_Addr             args = doIndexByteArrayOp   Nothing (bWord dflags) res args+emitPrimOp _      res IndexByteArrayOp_Float            args = doIndexByteArrayOp   Nothing f32 res args+emitPrimOp _      res IndexByteArrayOp_Double           args = doIndexByteArrayOp   Nothing f64 res args+emitPrimOp dflags res IndexByteArrayOp_StablePtr        args = doIndexByteArrayOp   Nothing (bWord dflags) res args+emitPrimOp dflags res IndexByteArrayOp_Int8             args = doIndexByteArrayOp   (Just (mo_s_8ToWord dflags)) b8  res args+emitPrimOp dflags res IndexByteArrayOp_Int16            args = doIndexByteArrayOp   (Just (mo_s_16ToWord dflags)) b16  res args+emitPrimOp dflags res IndexByteArrayOp_Int32            args = doIndexByteArrayOp   (Just (mo_s_32ToWord dflags)) b32  res args+emitPrimOp _      res IndexByteArrayOp_Int64            args = doIndexByteArrayOp   Nothing b64  res args+emitPrimOp dflags res IndexByteArrayOp_Word8            args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8  res args+emitPrimOp dflags res IndexByteArrayOp_Word16           args = doIndexByteArrayOp   (Just (mo_u_16ToWord dflags)) b16  res args+emitPrimOp dflags res IndexByteArrayOp_Word32           args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args+emitPrimOp _      res IndexByteArrayOp_Word64           args = doIndexByteArrayOp   Nothing b64  res args++-- ReadXXXArray, identical to IndexXXXArray.++emitPrimOp dflags res ReadByteArrayOp_Char             args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8 res args+emitPrimOp dflags res ReadByteArrayOp_WideChar         args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32 res args+emitPrimOp dflags res ReadByteArrayOp_Int              args = doIndexByteArrayOp   Nothing (bWord dflags) res args+emitPrimOp dflags res ReadByteArrayOp_Word             args = doIndexByteArrayOp   Nothing (bWord dflags) res args+emitPrimOp dflags res ReadByteArrayOp_Addr             args = doIndexByteArrayOp   Nothing (bWord dflags) res args+emitPrimOp _      res ReadByteArrayOp_Float            args = doIndexByteArrayOp   Nothing f32 res args+emitPrimOp _      res ReadByteArrayOp_Double           args = doIndexByteArrayOp   Nothing f64 res args+emitPrimOp dflags res ReadByteArrayOp_StablePtr        args = doIndexByteArrayOp   Nothing (bWord dflags) res args+emitPrimOp dflags res ReadByteArrayOp_Int8             args = doIndexByteArrayOp   (Just (mo_s_8ToWord dflags)) b8  res args+emitPrimOp dflags res ReadByteArrayOp_Int16            args = doIndexByteArrayOp   (Just (mo_s_16ToWord dflags)) b16  res args+emitPrimOp dflags res ReadByteArrayOp_Int32            args = doIndexByteArrayOp   (Just (mo_s_32ToWord dflags)) b32  res args+emitPrimOp _      res ReadByteArrayOp_Int64            args = doIndexByteArrayOp   Nothing b64  res args+emitPrimOp dflags res ReadByteArrayOp_Word8            args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8  res args+emitPrimOp dflags res ReadByteArrayOp_Word16           args = doIndexByteArrayOp   (Just (mo_u_16ToWord dflags)) b16  res args+emitPrimOp dflags res ReadByteArrayOp_Word32           args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args+emitPrimOp _      res ReadByteArrayOp_Word64           args = doIndexByteArrayOp   Nothing b64  res args++-- WriteXXXoffAddr++emitPrimOp dflags res WriteOffAddrOp_Char             args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args+emitPrimOp dflags res WriteOffAddrOp_WideChar         args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args+emitPrimOp dflags res WriteOffAddrOp_Int              args = doWriteOffAddrOp Nothing (bWord dflags) res args+emitPrimOp dflags res WriteOffAddrOp_Word             args = doWriteOffAddrOp Nothing (bWord dflags) res args+emitPrimOp dflags res WriteOffAddrOp_Addr             args = doWriteOffAddrOp Nothing (bWord dflags) res args+emitPrimOp _      res WriteOffAddrOp_Float            args = doWriteOffAddrOp Nothing f32 res args+emitPrimOp _      res WriteOffAddrOp_Double           args = doWriteOffAddrOp Nothing f64 res args+emitPrimOp dflags res WriteOffAddrOp_StablePtr        args = doWriteOffAddrOp Nothing (bWord dflags) res args+emitPrimOp dflags res WriteOffAddrOp_Int8             args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args+emitPrimOp dflags res WriteOffAddrOp_Int16            args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args+emitPrimOp dflags res WriteOffAddrOp_Int32            args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args+emitPrimOp _      res WriteOffAddrOp_Int64            args = doWriteOffAddrOp Nothing b64 res args+emitPrimOp dflags res WriteOffAddrOp_Word8            args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args+emitPrimOp dflags res WriteOffAddrOp_Word16           args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args+emitPrimOp dflags res WriteOffAddrOp_Word32           args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args+emitPrimOp _      res WriteOffAddrOp_Word64           args = doWriteOffAddrOp Nothing b64 res args++-- WriteXXXArray++emitPrimOp dflags res WriteByteArrayOp_Char             args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args+emitPrimOp dflags res WriteByteArrayOp_WideChar         args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args+emitPrimOp dflags res WriteByteArrayOp_Int              args = doWriteByteArrayOp Nothing (bWord dflags) res args+emitPrimOp dflags res WriteByteArrayOp_Word             args = doWriteByteArrayOp Nothing (bWord dflags) res args+emitPrimOp dflags res WriteByteArrayOp_Addr             args = doWriteByteArrayOp Nothing (bWord dflags) res args+emitPrimOp _      res WriteByteArrayOp_Float            args = doWriteByteArrayOp Nothing f32 res args+emitPrimOp _      res WriteByteArrayOp_Double           args = doWriteByteArrayOp Nothing f64 res args+emitPrimOp dflags res WriteByteArrayOp_StablePtr        args = doWriteByteArrayOp Nothing (bWord dflags) res args+emitPrimOp dflags res WriteByteArrayOp_Int8             args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args+emitPrimOp dflags res WriteByteArrayOp_Int16            args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args+emitPrimOp dflags res WriteByteArrayOp_Int32            args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args+emitPrimOp _      res WriteByteArrayOp_Int64            args = doWriteByteArrayOp Nothing b64 res args+emitPrimOp dflags res WriteByteArrayOp_Word8            args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8  res args+emitPrimOp dflags res WriteByteArrayOp_Word16           args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args+emitPrimOp dflags res WriteByteArrayOp_Word32           args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args+emitPrimOp _      res WriteByteArrayOp_Word64           args = doWriteByteArrayOp Nothing b64 res args++-- Copying and setting byte arrays+emitPrimOp _      [] CopyByteArrayOp [src,src_off,dst,dst_off,n] =+    doCopyByteArrayOp src src_off dst dst_off n+emitPrimOp _      [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] =+    doCopyMutableByteArrayOp src src_off dst dst_off n+emitPrimOp _      [] CopyByteArrayToAddrOp [src,src_off,dst,n] =+    doCopyByteArrayToAddrOp src src_off dst n+emitPrimOp _      [] CopyMutableByteArrayToAddrOp [src,src_off,dst,n] =+    doCopyMutableByteArrayToAddrOp src src_off dst n+emitPrimOp _      [] CopyAddrToByteArrayOp [src,dst,dst_off,n] =+    doCopyAddrToByteArrayOp src dst dst_off n+emitPrimOp _      [] SetByteArrayOp [ba,off,len,c] =+    doSetByteArrayOp ba off len c++emitPrimOp _      [res] BSwap16Op [w] = emitBSwapCall res w W16+emitPrimOp _      [res] BSwap32Op [w] = emitBSwapCall res w W32+emitPrimOp _      [res] BSwap64Op [w] = emitBSwapCall res w W64+emitPrimOp dflags [res] BSwapOp   [w] = emitBSwapCall res w (wordWidth dflags)++-- Population count+emitPrimOp _      [res] PopCnt8Op  [w] = emitPopCntCall res w W8+emitPrimOp _      [res] PopCnt16Op [w] = emitPopCntCall res w W16+emitPrimOp _      [res] PopCnt32Op [w] = emitPopCntCall res w W32+emitPrimOp _      [res] PopCnt64Op [w] = emitPopCntCall res w W64+emitPrimOp dflags [res] PopCntOp   [w] = emitPopCntCall res w (wordWidth dflags)++-- count leading zeros+emitPrimOp _      [res] Clz8Op  [w] = emitClzCall res w W8+emitPrimOp _      [res] Clz16Op [w] = emitClzCall res w W16+emitPrimOp _      [res] Clz32Op [w] = emitClzCall res w W32+emitPrimOp _      [res] Clz64Op [w] = emitClzCall res w W64+emitPrimOp dflags [res] ClzOp   [w] = emitClzCall res w (wordWidth dflags)++-- count trailing zeros+emitPrimOp _      [res] Ctz8Op [w]  = emitCtzCall res w W8+emitPrimOp _      [res] Ctz16Op [w] = emitCtzCall res w W16+emitPrimOp _      [res] Ctz32Op [w] = emitCtzCall res w W32+emitPrimOp _      [res] Ctz64Op [w] = emitCtzCall res w W64+emitPrimOp dflags [res] CtzOp   [w] = emitCtzCall res w (wordWidth dflags)++-- Unsigned int to floating point conversions+emitPrimOp _      [res] Word2FloatOp  [w] = emitPrimCall [res]+                                            (MO_UF_Conv W32) [w]+emitPrimOp _      [res] Word2DoubleOp [w] = emitPrimCall [res]+                                            (MO_UF_Conv W64) [w]++-- SIMD primops+emitPrimOp dflags [res] (VecBroadcastOp vcat n w) [e] = do+    checkVecCompatibility dflags vcat n w+    doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros (replicate n e) res+  where+    zeros :: CmmExpr+    zeros = CmmLit $ CmmVec (replicate n zero)++    zero :: CmmLit+    zero = case vcat of+             IntVec   -> CmmInt 0 w+             WordVec  -> CmmInt 0 w+             FloatVec -> CmmFloat 0 w++    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags [res] (VecPackOp vcat n w) es = do+    checkVecCompatibility dflags vcat n w+    when (length es /= n) $+        panic "emitPrimOp: VecPackOp has wrong number of arguments"+    doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros es res+  where+    zeros :: CmmExpr+    zeros = CmmLit $ CmmVec (replicate n zero)++    zero :: CmmLit+    zero = case vcat of+             IntVec   -> CmmInt 0 w+             WordVec  -> CmmInt 0 w+             FloatVec -> CmmFloat 0 w++    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags res (VecUnpackOp vcat n w) [arg] = do+    checkVecCompatibility dflags vcat n w+    when (length res /= n) $+        panic "emitPrimOp: VecUnpackOp has wrong number of results"+    doVecUnpackOp (vecElemProjectCast dflags vcat w) ty arg res+  where+    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags [res] (VecInsertOp vcat n w) [v,e,i] = do+    checkVecCompatibility dflags vcat n w+    doVecInsertOp (vecElemInjectCast dflags vcat w) ty v e i res+  where+    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags res (VecIndexByteArrayOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doIndexByteArrayOp Nothing ty res args+  where+    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags res (VecReadByteArrayOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doIndexByteArrayOp Nothing ty res args+  where+    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags res (VecWriteByteArrayOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doWriteByteArrayOp Nothing ty res args+  where+    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags res (VecIndexOffAddrOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doIndexOffAddrOp Nothing ty res args+  where+    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags res (VecReadOffAddrOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doIndexOffAddrOp Nothing ty res args+  where+    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags res (VecWriteOffAddrOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doWriteOffAddrOp Nothing ty res args+  where+    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags res (VecIndexScalarByteArrayOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doIndexByteArrayOpAs Nothing vecty ty res args+  where+    vecty :: CmmType+    vecty = vecVmmType vcat n w++    ty :: CmmType+    ty = vecCmmCat vcat w++emitPrimOp dflags res (VecReadScalarByteArrayOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doIndexByteArrayOpAs Nothing vecty ty res args+  where+    vecty :: CmmType+    vecty = vecVmmType vcat n w++    ty :: CmmType+    ty = vecCmmCat vcat w++emitPrimOp dflags res (VecWriteScalarByteArrayOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doWriteByteArrayOp Nothing ty res args+  where+    ty :: CmmType+    ty = vecCmmCat vcat w++emitPrimOp dflags res (VecIndexScalarOffAddrOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doIndexOffAddrOpAs Nothing vecty ty res args+  where+    vecty :: CmmType+    vecty = vecVmmType vcat n w++    ty :: CmmType+    ty = vecCmmCat vcat w++emitPrimOp dflags res (VecReadScalarOffAddrOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doIndexOffAddrOpAs Nothing vecty ty res args+  where+    vecty :: CmmType+    vecty = vecVmmType vcat n w++    ty :: CmmType+    ty = vecCmmCat vcat w++emitPrimOp dflags res (VecWriteScalarOffAddrOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doWriteOffAddrOp Nothing ty res args+  where+    ty :: CmmType+    ty = vecCmmCat vcat w++-- Prefetch+emitPrimOp _ [] PrefetchByteArrayOp3        args = doPrefetchByteArrayOp 3  args+emitPrimOp _ [] PrefetchMutableByteArrayOp3 args = doPrefetchMutableByteArrayOp 3  args+emitPrimOp _ [] PrefetchAddrOp3             args = doPrefetchAddrOp  3  args+emitPrimOp _ [] PrefetchValueOp3            args = doPrefetchValueOp 3 args++emitPrimOp _ [] PrefetchByteArrayOp2        args = doPrefetchByteArrayOp 2  args+emitPrimOp _ [] PrefetchMutableByteArrayOp2 args = doPrefetchMutableByteArrayOp 2  args+emitPrimOp _ [] PrefetchAddrOp2             args = doPrefetchAddrOp 2  args+emitPrimOp _ [] PrefetchValueOp2           args = doPrefetchValueOp 2 args++emitPrimOp _ [] PrefetchByteArrayOp1        args = doPrefetchByteArrayOp 1  args+emitPrimOp _ [] PrefetchMutableByteArrayOp1 args = doPrefetchMutableByteArrayOp 1  args+emitPrimOp _ [] PrefetchAddrOp1             args = doPrefetchAddrOp 1  args+emitPrimOp _ [] PrefetchValueOp1            args = doPrefetchValueOp 1 args++emitPrimOp _ [] PrefetchByteArrayOp0        args = doPrefetchByteArrayOp 0  args+emitPrimOp _ [] PrefetchMutableByteArrayOp0 args = doPrefetchMutableByteArrayOp 0  args+emitPrimOp _ [] PrefetchAddrOp0             args = doPrefetchAddrOp 0  args+emitPrimOp _ [] PrefetchValueOp0            args = doPrefetchValueOp 0 args++-- Atomic read-modify-write+emitPrimOp dflags [res] FetchAddByteArrayOp_Int [mba, ix, n] =+    doAtomicRMW res AMO_Add mba ix (bWord dflags) n+emitPrimOp dflags [res] FetchSubByteArrayOp_Int [mba, ix, n] =+    doAtomicRMW res AMO_Sub mba ix (bWord dflags) n+emitPrimOp dflags [res] FetchAndByteArrayOp_Int [mba, ix, n] =+    doAtomicRMW res AMO_And mba ix (bWord dflags) n+emitPrimOp dflags [res] FetchNandByteArrayOp_Int [mba, ix, n] =+    doAtomicRMW res AMO_Nand mba ix (bWord dflags) n+emitPrimOp dflags [res] FetchOrByteArrayOp_Int [mba, ix, n] =+    doAtomicRMW res AMO_Or mba ix (bWord dflags) n+emitPrimOp dflags [res] FetchXorByteArrayOp_Int [mba, ix, n] =+    doAtomicRMW res AMO_Xor mba ix (bWord dflags) n+emitPrimOp dflags [res] AtomicReadByteArrayOp_Int [mba, ix] =+    doAtomicReadByteArray res mba ix (bWord dflags)+emitPrimOp dflags [] AtomicWriteByteArrayOp_Int [mba, ix, val] =+    doAtomicWriteByteArray mba ix (bWord dflags) val+emitPrimOp dflags [res] CasByteArrayOp_Int [mba, ix, old, new] =+    doCasByteArray res mba ix (bWord dflags) old new++-- The rest just translate straightforwardly+emitPrimOp dflags [res] op [arg]+   | nopOp op+   = emitAssign (CmmLocal res) arg++   | Just (mop,rep) <- narrowOp op+   = emitAssign (CmmLocal res) $+           CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]]++emitPrimOp dflags r@[res] op args+   | Just prim <- callishOp op+   = do emitPrimCall r prim args++   | Just mop <- translateOp dflags op+   = let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) in+     emit stmt++emitPrimOp dflags results op args+   = case callishPrimOpSupported dflags op of+          Left op   -> emit $ mkUnsafeCall (PrimTarget op) results args+          Right gen -> gen results args++type GenericOp = [CmmFormal] -> [CmmActual] -> FCode ()++callishPrimOpSupported :: DynFlags -> PrimOp -> Either CallishMachOp GenericOp+callishPrimOpSupported dflags op+  = case op of+      IntQuotRemOp   | ncg && (x86ish+                              || ppc) -> Left (MO_S_QuotRem  (wordWidth dflags))+                     | otherwise      -> Right (genericIntQuotRemOp dflags)++      WordQuotRemOp  | ncg && (x86ish+                              || ppc) -> Left (MO_U_QuotRem  (wordWidth dflags))+                     | otherwise      -> Right (genericWordQuotRemOp dflags)++      WordQuotRem2Op | (ncg && (x86ish+                                || ppc))+                          || llvm     -> Left (MO_U_QuotRem2 (wordWidth dflags))+                     | otherwise      -> Right (genericWordQuotRem2Op dflags)++      WordAdd2Op     | (ncg && (x86ish+                                || ppc))+                         || llvm      -> Left (MO_Add2       (wordWidth dflags))+                     | otherwise      -> Right genericWordAdd2Op++      WordSubCOp     | (ncg && (x86ish+                                || ppc))+                         || llvm      -> Left (MO_SubWordC   (wordWidth dflags))+                     | otherwise      -> Right genericWordSubCOp++      IntAddCOp      | (ncg && (x86ish+                                || ppc))+                         || llvm      -> Left (MO_AddIntC    (wordWidth dflags))+                     | otherwise      -> Right genericIntAddCOp++      IntSubCOp      | (ncg && (x86ish+                                || ppc))+                         || llvm      -> Left (MO_SubIntC    (wordWidth dflags))+                     | otherwise      -> Right genericIntSubCOp++      WordMul2Op     | ncg && (x86ish+                               || ppc)+                         || llvm      -> Left (MO_U_Mul2     (wordWidth dflags))+                     | otherwise      -> Right genericWordMul2Op+      FloatFabsOp    | (ncg && x86ish+                               || ppc)+                         || llvm      -> Left MO_F32_Fabs+                     | otherwise      -> Right $ genericFabsOp W32+      DoubleFabsOp   | (ncg && x86ish+                               || ppc)+                         || llvm      -> Left MO_F64_Fabs+                     | otherwise      -> Right $ genericFabsOp W64++      _ -> pprPanic "emitPrimOp: can't translate PrimOp " (ppr op)+ where+  ncg = case hscTarget dflags of+           HscAsm -> True+           _      -> False+  llvm = case hscTarget dflags of+           HscLlvm -> True+           _       -> False+  x86ish = case platformArch (targetPlatform dflags) of+             ArchX86    -> True+             ArchX86_64 -> True+             _          -> False+  ppc = case platformArch (targetPlatform dflags) of+          ArchPPC      -> True+          ArchPPC_64 _ -> True+          _            -> False++genericIntQuotRemOp :: DynFlags -> GenericOp+genericIntQuotRemOp dflags [res_q, res_r] [arg_x, arg_y]+   = emit $ mkAssign (CmmLocal res_q)+              (CmmMachOp (MO_S_Quot (wordWidth dflags)) [arg_x, arg_y]) <*>+            mkAssign (CmmLocal res_r)+              (CmmMachOp (MO_S_Rem  (wordWidth dflags)) [arg_x, arg_y])+genericIntQuotRemOp _ _ _ = panic "genericIntQuotRemOp"++genericWordQuotRemOp :: DynFlags -> GenericOp+genericWordQuotRemOp dflags [res_q, res_r] [arg_x, arg_y]+    = emit $ mkAssign (CmmLocal res_q)+               (CmmMachOp (MO_U_Quot (wordWidth dflags)) [arg_x, arg_y]) <*>+             mkAssign (CmmLocal res_r)+               (CmmMachOp (MO_U_Rem  (wordWidth dflags)) [arg_x, arg_y])+genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp"++genericWordQuotRem2Op :: DynFlags -> GenericOp+genericWordQuotRem2Op dflags [res_q, res_r] [arg_x_high, arg_x_low, arg_y]+    = emit =<< f (widthInBits (wordWidth dflags)) zero arg_x_high arg_x_low+    where    ty = cmmExprType dflags arg_x_high+             shl   x i = CmmMachOp (MO_Shl   (wordWidth dflags)) [x, i]+             shr   x i = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, i]+             or    x y = CmmMachOp (MO_Or    (wordWidth dflags)) [x, y]+             ge    x y = CmmMachOp (MO_U_Ge  (wordWidth dflags)) [x, y]+             ne    x y = CmmMachOp (MO_Ne    (wordWidth dflags)) [x, y]+             minus x y = CmmMachOp (MO_Sub   (wordWidth dflags)) [x, y]+             times x y = CmmMachOp (MO_Mul   (wordWidth dflags)) [x, y]+             zero   = lit 0+             one    = lit 1+             negone = lit (fromIntegral (widthInBits (wordWidth dflags)) - 1)+             lit i = CmmLit (CmmInt i (wordWidth dflags))++             f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph+             f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*>+                                      mkAssign (CmmLocal res_r) high)+             f i acc high low =+                 do roverflowedBit <- newTemp ty+                    rhigh'         <- newTemp ty+                    rhigh''        <- newTemp ty+                    rlow'          <- newTemp ty+                    risge          <- newTemp ty+                    racc'          <- newTemp ty+                    let high'         = CmmReg (CmmLocal rhigh')+                        isge          = CmmReg (CmmLocal risge)+                        overflowedBit = CmmReg (CmmLocal roverflowedBit)+                    let this = catAGraphs+                               [mkAssign (CmmLocal roverflowedBit)+                                          (shr high negone),+                                mkAssign (CmmLocal rhigh')+                                          (or (shl high one) (shr low negone)),+                                mkAssign (CmmLocal rlow')+                                          (shl low one),+                                mkAssign (CmmLocal risge)+                                          (or (overflowedBit `ne` zero)+                                              (high' `ge` arg_y)),+                                mkAssign (CmmLocal rhigh'')+                                          (high' `minus` (arg_y `times` isge)),+                                mkAssign (CmmLocal racc')+                                          (or (shl acc one) isge)]+                    rest <- f (i - 1) (CmmReg (CmmLocal racc'))+                                      (CmmReg (CmmLocal rhigh''))+                                      (CmmReg (CmmLocal rlow'))+                    return (this <*> rest)+genericWordQuotRem2Op _ _ _ = panic "genericWordQuotRem2Op"++genericWordAdd2Op :: GenericOp+genericWordAdd2Op [res_h, res_l] [arg_x, arg_y]+  = do dflags <- getDynFlags+       r1 <- newTemp (cmmExprType dflags arg_x)+       r2 <- newTemp (cmmExprType dflags arg_x)+       let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]+           toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]+           bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]+           add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]+           or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]+           hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))+                                (wordWidth dflags))+           hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))+       emit $ catAGraphs+          [mkAssign (CmmLocal r1)+               (add (bottomHalf arg_x) (bottomHalf arg_y)),+           mkAssign (CmmLocal r2)+               (add (topHalf (CmmReg (CmmLocal r1)))+                    (add (topHalf arg_x) (topHalf arg_y))),+           mkAssign (CmmLocal res_h)+               (topHalf (CmmReg (CmmLocal r2))),+           mkAssign (CmmLocal res_l)+               (or (toTopHalf (CmmReg (CmmLocal r2)))+                   (bottomHalf (CmmReg (CmmLocal r1))))]+genericWordAdd2Op _ _ = panic "genericWordAdd2Op"++genericWordSubCOp :: GenericOp+genericWordSubCOp [res_r, res_c] [aa, bb] = do+  dflags <- getDynFlags+  emit $ catAGraphs+    [ -- Put the result into 'res_r'.+      mkAssign (CmmLocal res_r) $+        CmmMachOp (mo_wordSub dflags) [aa, bb]+      -- Set 'res_c' to 1 if 'bb > aa' and to 0 otherwise.+    , mkAssign (CmmLocal res_c) $+        CmmMachOp (mo_wordUGt dflags) [bb, aa]+    ]+genericWordSubCOp _ _ = panic "genericWordSubCOp"++genericIntAddCOp :: GenericOp+genericIntAddCOp [res_r, res_c] [aa, bb]+{-+   With some bit-twiddling, we can define int{Add,Sub}Czh portably in+   C, and without needing any comparisons.  This may not be the+   fastest way to do it - if you have better code, please send it! --SDM++   Return : r = a + b,  c = 0 if no overflow, 1 on overflow.++   We currently don't make use of the r value if c is != 0 (i.e.+   overflow), we just convert to big integers and try again.  This+   could be improved by making r and c the correct values for+   plugging into a new J#.++   { r = ((I_)(a)) + ((I_)(b));                                 \+     c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r)))    \+         >> (BITS_IN (I_) - 1);                                 \+   }+   Wading through the mass of bracketry, it seems to reduce to:+   c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)++-}+ = do dflags <- getDynFlags+      emit $ catAGraphs [+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),+        mkAssign (CmmLocal res_c) $+          CmmMachOp (mo_wordUShr dflags) [+                CmmMachOp (mo_wordAnd dflags) [+                    CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]],+                    CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]+                ],+                mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)+          ]+        ]+genericIntAddCOp _ _ = panic "genericIntAddCOp"++genericIntSubCOp :: GenericOp+genericIntSubCOp [res_r, res_c] [aa, bb]+{- Similarly:+   #define subIntCzh(r,c,a,b)                                   \+   { r = ((I_)(a)) - ((I_)(b));                                 \+     c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r)))     \+         >> (BITS_IN (I_) - 1);                                 \+   }++   c =  ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)+-}+ = do dflags <- getDynFlags+      emit $ catAGraphs [+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),+        mkAssign (CmmLocal res_c) $+          CmmMachOp (mo_wordUShr dflags) [+                CmmMachOp (mo_wordAnd dflags) [+                    CmmMachOp (mo_wordXor dflags) [aa,bb],+                    CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]+                ],+                mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)+          ]+        ]+genericIntSubCOp _ _ = panic "genericIntSubCOp"++genericWordMul2Op :: GenericOp+genericWordMul2Op [res_h, res_l] [arg_x, arg_y]+ = do dflags <- getDynFlags+      let t = cmmExprType dflags arg_x+      xlyl <- liftM CmmLocal $ newTemp t+      xlyh <- liftM CmmLocal $ newTemp t+      xhyl <- liftM CmmLocal $ newTemp t+      r    <- liftM CmmLocal $ newTemp t+      -- This generic implementation is very simple and slow. We might+      -- well be able to do better, but for now this at least works.+      let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]+          toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]+          bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]+          add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]+          sum = foldl1 add+          mul x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y]+          or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]+          hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))+                               (wordWidth dflags))+          hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))+      emit $ catAGraphs+             [mkAssign xlyl+                  (mul (bottomHalf arg_x) (bottomHalf arg_y)),+              mkAssign xlyh+                  (mul (bottomHalf arg_x) (topHalf arg_y)),+              mkAssign xhyl+                  (mul (topHalf arg_x) (bottomHalf arg_y)),+              mkAssign r+                  (sum [topHalf    (CmmReg xlyl),+                        bottomHalf (CmmReg xhyl),+                        bottomHalf (CmmReg xlyh)]),+              mkAssign (CmmLocal res_l)+                  (or (bottomHalf (CmmReg xlyl))+                      (toTopHalf (CmmReg r))),+              mkAssign (CmmLocal res_h)+                  (sum [mul (topHalf arg_x) (topHalf arg_y),+                        topHalf (CmmReg xhyl),+                        topHalf (CmmReg xlyh),+                        topHalf (CmmReg r)])]+genericWordMul2Op _ _ = panic "genericWordMul2Op"++-- This replicates what we had in libraries/base/GHC/Float.hs:+--+--    abs x    | x == 0    = 0 -- handles (-0.0)+--             | x >  0    = x+--             | otherwise = negateFloat x+genericFabsOp :: Width -> GenericOp+genericFabsOp w [res_r] [aa]+ = do dflags <- getDynFlags+      let zero   = CmmLit (CmmFloat 0 w)++          eq x y = CmmMachOp (MO_F_Eq w) [x, y]+          gt x y = CmmMachOp (MO_F_Gt w) [x, y]++          neg x  = CmmMachOp (MO_F_Neg w) [x]++          g1 = catAGraphs [mkAssign (CmmLocal res_r) zero]+          g2 = catAGraphs [mkAssign (CmmLocal res_r) aa]++      res_t <- CmmLocal <$> newTemp (cmmExprType dflags aa)+      let g3 = catAGraphs [mkAssign res_t aa,+                           mkAssign (CmmLocal res_r) (neg (CmmReg res_t))]++      g4 <- mkCmmIfThenElse (gt aa zero) g2 g3++      emit =<< mkCmmIfThenElse (eq aa zero) g1 g4++genericFabsOp _ _ _ = panic "genericFabsOp"++-- These PrimOps are NOPs in Cmm++nopOp :: PrimOp -> Bool+nopOp Int2WordOp     = True+nopOp Word2IntOp     = True+nopOp Int2AddrOp     = True+nopOp Addr2IntOp     = True+nopOp ChrOp          = True  -- Int# and Char# are rep'd the same+nopOp OrdOp          = True+nopOp _              = False++-- These PrimOps turn into double casts++narrowOp :: PrimOp -> Maybe (Width -> Width -> MachOp, Width)+narrowOp Narrow8IntOp   = Just (MO_SS_Conv, W8)+narrowOp Narrow16IntOp  = Just (MO_SS_Conv, W16)+narrowOp Narrow32IntOp  = Just (MO_SS_Conv, W32)+narrowOp Narrow8WordOp  = Just (MO_UU_Conv, W8)+narrowOp Narrow16WordOp = Just (MO_UU_Conv, W16)+narrowOp Narrow32WordOp = Just (MO_UU_Conv, W32)+narrowOp _              = Nothing++-- Native word signless ops++translateOp :: DynFlags -> PrimOp -> Maybe MachOp+translateOp dflags IntAddOp       = Just (mo_wordAdd dflags)+translateOp dflags IntSubOp       = Just (mo_wordSub dflags)+translateOp dflags WordAddOp      = Just (mo_wordAdd dflags)+translateOp dflags WordSubOp      = Just (mo_wordSub dflags)+translateOp dflags AddrAddOp      = Just (mo_wordAdd dflags)+translateOp dflags AddrSubOp      = Just (mo_wordSub dflags)++translateOp dflags IntEqOp        = Just (mo_wordEq dflags)+translateOp dflags IntNeOp        = Just (mo_wordNe dflags)+translateOp dflags WordEqOp       = Just (mo_wordEq dflags)+translateOp dflags WordNeOp       = Just (mo_wordNe dflags)+translateOp dflags AddrEqOp       = Just (mo_wordEq dflags)+translateOp dflags AddrNeOp       = Just (mo_wordNe dflags)++translateOp dflags AndOp          = Just (mo_wordAnd dflags)+translateOp dflags OrOp           = Just (mo_wordOr dflags)+translateOp dflags XorOp          = Just (mo_wordXor dflags)+translateOp dflags NotOp          = Just (mo_wordNot dflags)+translateOp dflags SllOp          = Just (mo_wordShl dflags)+translateOp dflags SrlOp          = Just (mo_wordUShr dflags)++translateOp dflags AddrRemOp      = Just (mo_wordURem dflags)++-- Native word signed ops++translateOp dflags IntMulOp        = Just (mo_wordMul dflags)+translateOp dflags IntMulMayOfloOp = Just (MO_S_MulMayOflo (wordWidth dflags))+translateOp dflags IntQuotOp       = Just (mo_wordSQuot dflags)+translateOp dflags IntRemOp        = Just (mo_wordSRem dflags)+translateOp dflags IntNegOp        = Just (mo_wordSNeg dflags)+++translateOp dflags IntGeOp        = Just (mo_wordSGe dflags)+translateOp dflags IntLeOp        = Just (mo_wordSLe dflags)+translateOp dflags IntGtOp        = Just (mo_wordSGt dflags)+translateOp dflags IntLtOp        = Just (mo_wordSLt dflags)++translateOp dflags AndIOp         = Just (mo_wordAnd dflags)+translateOp dflags OrIOp          = Just (mo_wordOr dflags)+translateOp dflags XorIOp         = Just (mo_wordXor dflags)+translateOp dflags NotIOp         = Just (mo_wordNot dflags)+translateOp dflags ISllOp         = Just (mo_wordShl dflags)+translateOp dflags ISraOp         = Just (mo_wordSShr dflags)+translateOp dflags ISrlOp         = Just (mo_wordUShr dflags)++-- Native word unsigned ops++translateOp dflags WordGeOp       = Just (mo_wordUGe dflags)+translateOp dflags WordLeOp       = Just (mo_wordULe dflags)+translateOp dflags WordGtOp       = Just (mo_wordUGt dflags)+translateOp dflags WordLtOp       = Just (mo_wordULt dflags)++translateOp dflags WordMulOp      = Just (mo_wordMul dflags)+translateOp dflags WordQuotOp     = Just (mo_wordUQuot dflags)+translateOp dflags WordRemOp      = Just (mo_wordURem dflags)++translateOp dflags AddrGeOp       = Just (mo_wordUGe dflags)+translateOp dflags AddrLeOp       = Just (mo_wordULe dflags)+translateOp dflags AddrGtOp       = Just (mo_wordUGt dflags)+translateOp dflags AddrLtOp       = Just (mo_wordULt dflags)++-- Char# ops++translateOp dflags CharEqOp       = Just (MO_Eq (wordWidth dflags))+translateOp dflags CharNeOp       = Just (MO_Ne (wordWidth dflags))+translateOp dflags CharGeOp       = Just (MO_U_Ge (wordWidth dflags))+translateOp dflags CharLeOp       = Just (MO_U_Le (wordWidth dflags))+translateOp dflags CharGtOp       = Just (MO_U_Gt (wordWidth dflags))+translateOp dflags CharLtOp       = Just (MO_U_Lt (wordWidth dflags))++-- Double ops++translateOp _      DoubleEqOp     = Just (MO_F_Eq W64)+translateOp _      DoubleNeOp     = Just (MO_F_Ne W64)+translateOp _      DoubleGeOp     = Just (MO_F_Ge W64)+translateOp _      DoubleLeOp     = Just (MO_F_Le W64)+translateOp _      DoubleGtOp     = Just (MO_F_Gt W64)+translateOp _      DoubleLtOp     = Just (MO_F_Lt W64)++translateOp _      DoubleAddOp    = Just (MO_F_Add W64)+translateOp _      DoubleSubOp    = Just (MO_F_Sub W64)+translateOp _      DoubleMulOp    = Just (MO_F_Mul W64)+translateOp _      DoubleDivOp    = Just (MO_F_Quot W64)+translateOp _      DoubleNegOp    = Just (MO_F_Neg W64)++-- Float ops++translateOp _      FloatEqOp     = Just (MO_F_Eq W32)+translateOp _      FloatNeOp     = Just (MO_F_Ne W32)+translateOp _      FloatGeOp     = Just (MO_F_Ge W32)+translateOp _      FloatLeOp     = Just (MO_F_Le W32)+translateOp _      FloatGtOp     = Just (MO_F_Gt W32)+translateOp _      FloatLtOp     = Just (MO_F_Lt W32)++translateOp _      FloatAddOp    = Just (MO_F_Add  W32)+translateOp _      FloatSubOp    = Just (MO_F_Sub  W32)+translateOp _      FloatMulOp    = Just (MO_F_Mul  W32)+translateOp _      FloatDivOp    = Just (MO_F_Quot W32)+translateOp _      FloatNegOp    = Just (MO_F_Neg  W32)++-- Vector ops++translateOp _ (VecAddOp FloatVec n w) = Just (MO_VF_Add  n w)+translateOp _ (VecSubOp FloatVec n w) = Just (MO_VF_Sub  n w)+translateOp _ (VecMulOp FloatVec n w) = Just (MO_VF_Mul  n w)+translateOp _ (VecDivOp FloatVec n w) = Just (MO_VF_Quot n w)+translateOp _ (VecNegOp FloatVec n w) = Just (MO_VF_Neg  n w)++translateOp _ (VecAddOp  IntVec n w) = Just (MO_V_Add   n w)+translateOp _ (VecSubOp  IntVec n w) = Just (MO_V_Sub   n w)+translateOp _ (VecMulOp  IntVec n w) = Just (MO_V_Mul   n w)+translateOp _ (VecQuotOp IntVec n w) = Just (MO_VS_Quot n w)+translateOp _ (VecRemOp  IntVec n w) = Just (MO_VS_Rem  n w)+translateOp _ (VecNegOp  IntVec n w) = Just (MO_VS_Neg  n w)++translateOp _ (VecAddOp  WordVec n w) = Just (MO_V_Add   n w)+translateOp _ (VecSubOp  WordVec n w) = Just (MO_V_Sub   n w)+translateOp _ (VecMulOp  WordVec n w) = Just (MO_V_Mul   n w)+translateOp _ (VecQuotOp WordVec n w) = Just (MO_VU_Quot n w)+translateOp _ (VecRemOp  WordVec n w) = Just (MO_VU_Rem  n w)++-- Conversions++translateOp dflags Int2DoubleOp   = Just (MO_SF_Conv (wordWidth dflags) W64)+translateOp dflags Double2IntOp   = Just (MO_FS_Conv W64 (wordWidth dflags))++translateOp dflags Int2FloatOp    = Just (MO_SF_Conv (wordWidth dflags) W32)+translateOp dflags Float2IntOp    = Just (MO_FS_Conv W32 (wordWidth dflags))++translateOp _      Float2DoubleOp = Just (MO_FF_Conv W32 W64)+translateOp _      Double2FloatOp = Just (MO_FF_Conv W64 W32)++-- Word comparisons masquerading as more exotic things.++translateOp dflags SameMutVarOp           = Just (mo_wordEq dflags)+translateOp dflags SameMVarOp             = Just (mo_wordEq dflags)+translateOp dflags SameMutableArrayOp     = Just (mo_wordEq dflags)+translateOp dflags SameMutableByteArrayOp = Just (mo_wordEq dflags)+translateOp dflags SameMutableArrayArrayOp= Just (mo_wordEq dflags)+translateOp dflags SameSmallMutableArrayOp= Just (mo_wordEq dflags)+translateOp dflags SameTVarOp             = Just (mo_wordEq dflags)+translateOp dflags EqStablePtrOp          = Just (mo_wordEq dflags)++translateOp _      _ = Nothing++-- These primops are implemented by CallishMachOps, because they sometimes+-- turn into foreign calls depending on the backend.++callishOp :: PrimOp -> Maybe CallishMachOp+callishOp DoublePowerOp  = Just MO_F64_Pwr+callishOp DoubleSinOp    = Just MO_F64_Sin+callishOp DoubleCosOp    = Just MO_F64_Cos+callishOp DoubleTanOp    = Just MO_F64_Tan+callishOp DoubleSinhOp   = Just MO_F64_Sinh+callishOp DoubleCoshOp   = Just MO_F64_Cosh+callishOp DoubleTanhOp   = Just MO_F64_Tanh+callishOp DoubleAsinOp   = Just MO_F64_Asin+callishOp DoubleAcosOp   = Just MO_F64_Acos+callishOp DoubleAtanOp   = Just MO_F64_Atan+callishOp DoubleLogOp    = Just MO_F64_Log+callishOp DoubleExpOp    = Just MO_F64_Exp+callishOp DoubleSqrtOp   = Just MO_F64_Sqrt++callishOp FloatPowerOp  = Just MO_F32_Pwr+callishOp FloatSinOp    = Just MO_F32_Sin+callishOp FloatCosOp    = Just MO_F32_Cos+callishOp FloatTanOp    = Just MO_F32_Tan+callishOp FloatSinhOp   = Just MO_F32_Sinh+callishOp FloatCoshOp   = Just MO_F32_Cosh+callishOp FloatTanhOp   = Just MO_F32_Tanh+callishOp FloatAsinOp   = Just MO_F32_Asin+callishOp FloatAcosOp   = Just MO_F32_Acos+callishOp FloatAtanOp   = Just MO_F32_Atan+callishOp FloatLogOp    = Just MO_F32_Log+callishOp FloatExpOp    = Just MO_F32_Exp+callishOp FloatSqrtOp   = Just MO_F32_Sqrt++callishOp _ = Nothing++------------------------------------------------------------------------------+-- Helpers for translating various minor variants of array indexing.++doIndexOffAddrOp :: Maybe MachOp+                 -> CmmType+                 -> [LocalReg]+                 -> [CmmExpr]+                 -> FCode ()+doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]+   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr rep idx+doIndexOffAddrOp _ _ _ _+   = panic "StgCmmPrim: doIndexOffAddrOp"++doIndexOffAddrOpAs :: Maybe MachOp+                   -> CmmType+                   -> CmmType+                   -> [LocalReg]+                   -> [CmmExpr]+                   -> FCode ()+doIndexOffAddrOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]+   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx_rep idx+doIndexOffAddrOpAs _ _ _ _ _+   = panic "StgCmmPrim: doIndexOffAddrOpAs"++doIndexByteArrayOp :: Maybe MachOp+                   -> CmmType+                   -> [LocalReg]+                   -> [CmmExpr]+                   -> FCode ()+doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]+   = do dflags <- getDynFlags+        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr rep idx+doIndexByteArrayOp _ _ _ _+   = panic "StgCmmPrim: doIndexByteArrayOp"++doIndexByteArrayOpAs :: Maybe MachOp+                    -> CmmType+                    -> CmmType+                    -> [LocalReg]+                    -> [CmmExpr]+                    -> FCode ()+doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]+   = do dflags <- getDynFlags+        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx_rep idx+doIndexByteArrayOpAs _ _ _ _ _+   = panic "StgCmmPrim: doIndexByteArrayOpAs"++doReadPtrArrayOp :: LocalReg+                 -> CmmExpr+                 -> CmmExpr+                 -> FCode ()+doReadPtrArrayOp res addr idx+   = do dflags <- getDynFlags+        mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr (gcWord dflags) idx++doWriteOffAddrOp :: Maybe MachOp+                 -> CmmType+                 -> [LocalReg]+                 -> [CmmExpr]+                 -> FCode ()+doWriteOffAddrOp maybe_pre_write_cast idx_ty [] [addr,idx,val]+   = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx_ty idx val+doWriteOffAddrOp _ _ _ _+   = panic "StgCmmPrim: doWriteOffAddrOp"++doWriteByteArrayOp :: Maybe MachOp+                   -> CmmType+                   -> [LocalReg]+                   -> [CmmExpr]+                   -> FCode ()+doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val]+   = do dflags <- getDynFlags+        mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast addr idx_ty idx val+doWriteByteArrayOp _ _ _ _+   = panic "StgCmmPrim: doWriteByteArrayOp"++doWritePtrArrayOp :: CmmExpr+                  -> CmmExpr+                  -> CmmExpr+                  -> FCode ()+doWritePtrArrayOp addr idx val+  = do dflags <- getDynFlags+       let ty = cmmExprType dflags val+       -- This write barrier is to ensure that the heap writes to the object+       -- referred to by val have happened before we write val into the array.+       -- See #12469 for details.+       emitPrimCall [] MO_WriteBarrier []+       mkBasicIndexedWrite (arrPtrsHdrSize dflags) Nothing addr ty idx val+       emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))+  -- the write barrier.  We must write a byte into the mark table:+  -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]+       emit $ mkStore (+         cmmOffsetExpr dflags+          (cmmOffsetExprW dflags (cmmOffsetB dflags addr (arrPtrsHdrSize dflags))+                         (loadArrPtrsSize dflags addr))+          (CmmMachOp (mo_wordUShr dflags) [idx,+                                           mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags)])+         ) (CmmLit (CmmInt 1 W8))++loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr+loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags)+ where off = fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags++mkBasicIndexedRead :: ByteOff      -- Initial offset in bytes+                   -> Maybe MachOp -- Optional result cast+                   -> CmmType      -- Type of element we are accessing+                   -> LocalReg     -- Destination+                   -> CmmExpr      -- Base address+                   -> CmmType      -- Type of element by which we are indexing+                   -> CmmExpr      -- Index+                   -> FCode ()+mkBasicIndexedRead off Nothing ty res base idx_ty idx+   = do dflags <- getDynFlags+        emitAssign (CmmLocal res) (cmmLoadIndexOffExpr dflags off ty base idx_ty idx)+mkBasicIndexedRead off (Just cast) ty res base idx_ty idx+   = do dflags <- getDynFlags+        emitAssign (CmmLocal res) (CmmMachOp cast [+                                   cmmLoadIndexOffExpr dflags off ty base idx_ty idx])++mkBasicIndexedWrite :: ByteOff      -- Initial offset in bytes+                    -> Maybe MachOp -- Optional value cast+                    -> CmmExpr      -- Base address+                    -> CmmType      -- Type of element by which we are indexing+                    -> CmmExpr      -- Index+                    -> CmmExpr      -- Value to write+                    -> FCode ()+mkBasicIndexedWrite off Nothing base idx_ty idx val+   = do dflags <- getDynFlags+        emitStore (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) val+mkBasicIndexedWrite off (Just cast) base idx_ty idx val+   = mkBasicIndexedWrite off Nothing base idx_ty idx (CmmMachOp cast [val])++-- ----------------------------------------------------------------------------+-- Misc utils++cmmIndexOffExpr :: DynFlags+                -> ByteOff  -- Initial offset in bytes+                -> Width    -- Width of element by which we are indexing+                -> CmmExpr  -- Base address+                -> CmmExpr  -- Index+                -> CmmExpr+cmmIndexOffExpr dflags off width base idx+   = cmmIndexExpr dflags width (cmmOffsetB dflags base off) idx++cmmLoadIndexOffExpr :: DynFlags+                    -> ByteOff  -- Initial offset in bytes+                    -> CmmType  -- Type of element we are accessing+                    -> CmmExpr  -- Base address+                    -> CmmType  -- Type of element by which we are indexing+                    -> CmmExpr  -- Index+                    -> CmmExpr+cmmLoadIndexOffExpr dflags off ty base idx_ty idx+   = CmmLoad (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) ty++setInfo :: CmmExpr -> CmmExpr -> CmmAGraph+setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr++------------------------------------------------------------------------------+-- Helpers for translating vector primops.++vecVmmType :: PrimOpVecCat -> Length -> Width -> CmmType+vecVmmType pocat n w = vec n (vecCmmCat pocat w)++vecCmmCat :: PrimOpVecCat -> Width -> CmmType+vecCmmCat IntVec   = cmmBits+vecCmmCat WordVec  = cmmBits+vecCmmCat FloatVec = cmmFloat++vecElemInjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp+vecElemInjectCast _      FloatVec _   =  Nothing+vecElemInjectCast dflags IntVec   W8  =  Just (mo_WordTo8  dflags)+vecElemInjectCast dflags IntVec   W16 =  Just (mo_WordTo16 dflags)+vecElemInjectCast dflags IntVec   W32 =  Just (mo_WordTo32 dflags)+vecElemInjectCast _      IntVec   W64 =  Nothing+vecElemInjectCast dflags WordVec  W8  =  Just (mo_WordTo8  dflags)+vecElemInjectCast dflags WordVec  W16 =  Just (mo_WordTo16 dflags)+vecElemInjectCast dflags WordVec  W32 =  Just (mo_WordTo32 dflags)+vecElemInjectCast _      WordVec  W64 =  Nothing+vecElemInjectCast _      _        _   =  Nothing++vecElemProjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp+vecElemProjectCast _      FloatVec _   =  Nothing+vecElemProjectCast dflags IntVec   W8  =  Just (mo_s_8ToWord  dflags)+vecElemProjectCast dflags IntVec   W16 =  Just (mo_s_16ToWord dflags)+vecElemProjectCast dflags IntVec   W32 =  Just (mo_s_32ToWord dflags)+vecElemProjectCast _      IntVec   W64 =  Nothing+vecElemProjectCast dflags WordVec  W8  =  Just (mo_u_8ToWord  dflags)+vecElemProjectCast dflags WordVec  W16 =  Just (mo_u_16ToWord dflags)+vecElemProjectCast dflags WordVec  W32 =  Just (mo_u_32ToWord dflags)+vecElemProjectCast _      WordVec  W64 =  Nothing+vecElemProjectCast _      _        _   =  Nothing++-- Check to make sure that we can generate code for the specified vector type+-- given the current set of dynamic flags.+checkVecCompatibility :: DynFlags -> PrimOpVecCat -> Length -> Width -> FCode ()+checkVecCompatibility dflags vcat l w = do+    when (hscTarget dflags /= HscLlvm) $ do+        sorry $ unlines ["SIMD vector instructions require the LLVM back-end."+                         ,"Please use -fllvm."]+    check vecWidth vcat l w+  where+    check :: Width -> PrimOpVecCat -> Length -> Width -> FCode ()+    check W128 FloatVec 4 W32 | not (isSseEnabled dflags) =+        sorry $ "128-bit wide single-precision floating point " +++                "SIMD vector instructions require at least -msse."+    check W128 _ _ _ | not (isSse2Enabled dflags) =+        sorry $ "128-bit wide integer and double precision " +++                "SIMD vector instructions require at least -msse2."+    check W256 FloatVec _ _ | not (isAvxEnabled dflags) =+        sorry $ "256-bit wide floating point " +++                "SIMD vector instructions require at least -mavx."+    check W256 _ _ _ | not (isAvx2Enabled dflags) =+        sorry $ "256-bit wide integer " +++                "SIMD vector instructions require at least -mavx2."+    check W512 _ _ _ | not (isAvx512fEnabled dflags) =+        sorry $ "512-bit wide " +++                "SIMD vector instructions require -mavx512f."+    check _ _ _ _ = return ()++    vecWidth = typeWidth (vecVmmType vcat l w)++------------------------------------------------------------------------------+-- Helpers for translating vector packing and unpacking.++doVecPackOp :: Maybe MachOp  -- Cast from element to vector component+            -> CmmType       -- Type of vector+            -> CmmExpr       -- Initial vector+            -> [CmmExpr]     -- Elements+            -> CmmFormal     -- Destination for result+            -> FCode ()+doVecPackOp maybe_pre_write_cast ty z es res = do+    dst <- newTemp ty+    emitAssign (CmmLocal dst) z+    vecPack dst es 0+  where+    vecPack :: CmmFormal -> [CmmExpr] -> Int -> FCode ()+    vecPack src [] _ =+        emitAssign (CmmLocal res) (CmmReg (CmmLocal src))++    vecPack src (e : es) i = do+        dst <- newTemp ty+        if isFloatType (vecElemType ty)+          then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Insert len wid)+                                                    [CmmReg (CmmLocal src), cast e, iLit])+          else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid)+                                                    [CmmReg (CmmLocal src), cast e, iLit])+        vecPack dst es (i + 1)+      where+        -- vector indices are always 32-bits+        iLit = CmmLit (CmmInt (toInteger i) W32)++    cast :: CmmExpr -> CmmExpr+    cast val = case maybe_pre_write_cast of+                 Nothing   -> val+                 Just cast -> CmmMachOp cast [val]++    len :: Length+    len = vecLength ty++    wid :: Width+    wid = typeWidth (vecElemType ty)++doVecUnpackOp :: Maybe MachOp  -- Cast from vector component to element result+              -> CmmType       -- Type of vector+              -> CmmExpr       -- Vector+              -> [CmmFormal]   -- Element results+              -> FCode ()+doVecUnpackOp maybe_post_read_cast ty e res =+    vecUnpack res 0+  where+    vecUnpack :: [CmmFormal] -> Int -> FCode ()+    vecUnpack [] _ =+        return ()++    vecUnpack (r : rs) i = do+        if isFloatType (vecElemType ty)+          then emitAssign (CmmLocal r) (cast (CmmMachOp (MO_VF_Extract len wid)+                                             [e, iLit]))+          else emitAssign (CmmLocal r) (cast (CmmMachOp (MO_V_Extract len wid)+                                             [e, iLit]))+        vecUnpack rs (i + 1)+      where+        -- vector indices are always 32-bits+        iLit = CmmLit (CmmInt (toInteger i) W32)++    cast :: CmmExpr -> CmmExpr+    cast val = case maybe_post_read_cast of+                 Nothing   -> val+                 Just cast -> CmmMachOp cast [val]++    len :: Length+    len = vecLength ty++    wid :: Width+    wid = typeWidth (vecElemType ty)++doVecInsertOp :: Maybe MachOp  -- Cast from element to vector component+              -> CmmType       -- Vector type+              -> CmmExpr       -- Source vector+              -> CmmExpr       -- Element+              -> CmmExpr       -- Index at which to insert element+              -> CmmFormal     -- Destination for result+              -> FCode ()+doVecInsertOp maybe_pre_write_cast ty src e idx res = do+    dflags <- getDynFlags+    -- vector indices are always 32-bits+    let idx' :: CmmExpr+        idx' = CmmMachOp (MO_SS_Conv (wordWidth dflags) W32) [idx]+    if isFloatType (vecElemType ty)+      then emitAssign (CmmLocal res) (CmmMachOp (MO_VF_Insert len wid) [src, cast e, idx'])+      else emitAssign (CmmLocal res) (CmmMachOp (MO_V_Insert len wid) [src, cast e, idx'])+  where+    cast :: CmmExpr -> CmmExpr+    cast val = case maybe_pre_write_cast of+                 Nothing   -> val+                 Just cast -> CmmMachOp cast [val]++    len :: Length+    len = vecLength ty++    wid :: Width+    wid = typeWidth (vecElemType ty)++------------------------------------------------------------------------------+-- Helpers for translating prefetching.+++-- | Translate byte array prefetch operations into proper primcalls.+doPrefetchByteArrayOp :: Int+                      -> [CmmExpr]+                      -> FCode ()+doPrefetchByteArrayOp locality  [addr,idx]+   = do dflags <- getDynFlags+        mkBasicPrefetch locality (arrWordsHdrSize dflags)  addr idx+doPrefetchByteArrayOp _ _+   = panic "StgCmmPrim: doPrefetchByteArrayOp"++-- | Translate mutable byte array prefetch operations into proper primcalls.+doPrefetchMutableByteArrayOp :: Int+                      -> [CmmExpr]+                      -> FCode ()+doPrefetchMutableByteArrayOp locality  [addr,idx]+   = do dflags <- getDynFlags+        mkBasicPrefetch locality (arrWordsHdrSize dflags)  addr idx+doPrefetchMutableByteArrayOp _ _+   = panic "StgCmmPrim: doPrefetchByteArrayOp"++-- | Translate address prefetch operations into proper primcalls.+doPrefetchAddrOp ::Int+                 -> [CmmExpr]+                 -> FCode ()+doPrefetchAddrOp locality   [addr,idx]+   = mkBasicPrefetch locality 0  addr idx+doPrefetchAddrOp _ _+   = panic "StgCmmPrim: doPrefetchAddrOp"++-- | Translate value prefetch operations into proper primcalls.+doPrefetchValueOp :: Int+                 -> [CmmExpr]+                 -> FCode ()+doPrefetchValueOp  locality   [addr]+  =  do dflags <- getDynFlags+        mkBasicPrefetch locality 0 addr  (CmmLit (CmmInt 0 (wordWidth dflags)))+doPrefetchValueOp _ _+  = panic "StgCmmPrim: doPrefetchValueOp"++-- | helper to generate prefetch primcalls+mkBasicPrefetch :: Int          -- Locality level 0-3+                -> ByteOff      -- Initial offset in bytes+                -> CmmExpr      -- Base address+                -> CmmExpr      -- Index+                -> FCode ()+mkBasicPrefetch locality off base idx+   = do dflags <- getDynFlags+        emitPrimCall [] (MO_Prefetch_Data locality) [cmmIndexExpr dflags W8 (cmmOffsetB dflags base off) idx]+        return ()++-- ----------------------------------------------------------------------------+-- Allocating byte arrays++-- | Takes a register to return the newly allocated array in and the+-- size of the new array in bytes. Allocates a new+-- 'MutableByteArray#'.+doNewByteArrayOp :: CmmFormal -> ByteOff -> FCode ()+doNewByteArrayOp res_r n = do+    dflags <- getDynFlags++    let info_ptr = mkLblExpr mkArrWords_infoLabel+        rep = arrWordsRep dflags n++    tickyAllocPrim (mkIntExpr dflags (arrWordsHdrSize dflags))+        (mkIntExpr dflags (nonHdrSize dflags rep))+        (zeroExpr dflags)++    let hdr_size = fixedHdrSize dflags++    base <- allocHeapClosure rep info_ptr curCCS+                     [ (mkIntExpr dflags n,+                        hdr_size + oFFSET_StgArrBytes_bytes dflags)+                     ]++    emit $ mkAssign (CmmLocal res_r) base++-- ----------------------------------------------------------------------------+-- Copying byte arrays++-- | Takes a source 'ByteArray#', an offset in the source array, a+-- destination 'MutableByteArray#', an offset into the destination+-- array, and the number of bytes to copy.  Copies the given number of+-- bytes from the source array to the destination array.+doCopyByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                  -> FCode ()+doCopyByteArrayOp = emitCopyByteArray copy+  where+    -- Copy data (we assume the arrays aren't overlapping since+    -- they're of different types)+    copy _src _dst dst_p src_p bytes =+        emitMemcpyCall dst_p src_p bytes 1++-- | Takes a source 'MutableByteArray#', an offset in the source+-- array, a destination 'MutableByteArray#', an offset into the+-- destination array, and the number of bytes to copy.  Copies the+-- given number of bytes from the source array to the destination+-- array.+doCopyMutableByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                         -> FCode ()+doCopyMutableByteArrayOp = emitCopyByteArray copy+  where+    -- The only time the memory might overlap is when the two arrays+    -- we were provided are the same array!+    -- TODO: Optimize branch for common case of no aliasing.+    copy src dst dst_p src_p bytes = do+        dflags <- getDynFlags+        [moveCall, cpyCall] <- forkAlts [+            getCode $ emitMemmoveCall dst_p src_p bytes 1,+            getCode $ emitMemcpyCall  dst_p src_p bytes 1+            ]+        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall++emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                      -> FCode ())+                  -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                  -> FCode ()+emitCopyByteArray copy src src_off dst dst_off n = do+    dflags <- getDynFlags+    dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off+    src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off+    copy src dst dst_p src_p n++-- | Takes a source 'ByteArray#', an offset in the source array, a+-- destination 'Addr#', and the number of bytes to copy.  Copies the given+-- number of bytes from the source array to the destination memory region.+doCopyByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()+doCopyByteArrayToAddrOp src src_off dst_p bytes = do+    -- Use memcpy (we are allowed to assume the arrays aren't overlapping)+    dflags <- getDynFlags+    src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off+    emitMemcpyCall dst_p src_p bytes 1++-- | Takes a source 'MutableByteArray#', an offset in the source array, a+-- destination 'Addr#', and the number of bytes to copy.  Copies the given+-- number of bytes from the source array to the destination memory region.+doCopyMutableByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                               -> FCode ()+doCopyMutableByteArrayToAddrOp = doCopyByteArrayToAddrOp++-- | Takes a source 'Addr#', a destination 'MutableByteArray#', an offset into+-- the destination array, and the number of bytes to copy.  Copies the given+-- number of bytes from the source memory region to the destination array.+doCopyAddrToByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()+doCopyAddrToByteArrayOp src_p dst dst_off bytes = do+    -- Use memcpy (we are allowed to assume the arrays aren't overlapping)+    dflags <- getDynFlags+    dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off+    emitMemcpyCall dst_p src_p bytes 1+++-- ----------------------------------------------------------------------------+-- Setting byte arrays++-- | Takes a 'MutableByteArray#', an offset into the array, a length,+-- and a byte, and sets each of the selected bytes in the array to the+-- character.+doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                 -> FCode ()+doSetByteArrayOp ba off len c+    = do dflags <- getDynFlags+         p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off+         emitMemsetCall p c len 1++-- ----------------------------------------------------------------------------+-- Allocating arrays++-- | Allocate a new array.+doNewArrayOp :: CmmFormal             -- ^ return register+             -> SMRep                 -- ^ representation of the array+             -> CLabel                -- ^ info pointer+             -> [(CmmExpr, ByteOff)]  -- ^ header payload+             -> WordOff               -- ^ array size+             -> CmmExpr               -- ^ initial element+             -> FCode ()+doNewArrayOp res_r rep info payload n init = do+    dflags <- getDynFlags++    let info_ptr = mkLblExpr info++    tickyAllocPrim (mkIntExpr dflags (hdrSize dflags rep))+        (mkIntExpr dflags (nonHdrSize dflags rep))+        (zeroExpr dflags)++    base <- allocHeapClosure rep info_ptr curCCS payload++    arr <- CmmLocal `fmap` newTemp (bWord dflags)+    emit $ mkAssign arr base++    -- Initialise all elements of the the array+    p <- assignTemp $ cmmOffsetB dflags (CmmReg arr) (hdrSize dflags rep)+    for <- newBlockId+    emitLabel for+    let loopBody =+            [ mkStore (CmmReg (CmmLocal p)) init+            , mkAssign (CmmLocal p) (cmmOffsetW dflags (CmmReg (CmmLocal p)) 1)+            , mkBranch for ]+    emit =<< mkCmmIfThen+        (cmmULtWord dflags (CmmReg (CmmLocal p))+         (cmmOffsetW dflags (CmmReg arr)+          (hdrSizeW dflags rep + n)))+        (catAGraphs loopBody)++    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)++-- ----------------------------------------------------------------------------+-- Copying pointer arrays++-- EZY: This code has an unusually high amount of assignTemp calls, seen+-- nowhere else in the code generator.  This is mostly because these+-- "primitive" ops result in a surprisingly large amount of code.  It+-- will likely be worthwhile to optimize what is emitted here, so that+-- our optimization passes don't waste time repeatedly optimizing the+-- same bits of code.++-- More closely imitates 'assignTemp' from the old code generator, which+-- returns a CmmExpr rather than a LocalReg.+assignTempE :: CmmExpr -> FCode CmmExpr+assignTempE e = do+    t <- assignTemp e+    return (CmmReg (CmmLocal t))++-- | Takes a source 'Array#', an offset in the source array, a+-- destination 'MutableArray#', an offset into the destination array,+-- and the number of elements to copy.  Copies the given number of+-- elements from the source array to the destination array.+doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff+              -> FCode ()+doCopyArrayOp = emitCopyArray copy+  where+    -- Copy data (we assume the arrays aren't overlapping since+    -- they're of different types)+    copy _src _dst dst_p src_p bytes =+        do dflags <- getDynFlags+           emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)+               (wORD_SIZE dflags)+++-- | Takes a source 'MutableArray#', an offset in the source array, a+-- destination 'MutableArray#', an offset into the destination array,+-- and the number of elements to copy.  Copies the given number of+-- elements from the source array to the destination array.+doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff+                     -> FCode ()+doCopyMutableArrayOp = emitCopyArray copy+  where+    -- The only time the memory might overlap is when the two arrays+    -- we were provided are the same array!+    -- TODO: Optimize branch for common case of no aliasing.+    copy src dst dst_p src_p bytes = do+        dflags <- getDynFlags+        [moveCall, cpyCall] <- forkAlts [+            getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)+            (wORD_SIZE dflags),+            getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr dflags bytes)+            (wORD_SIZE dflags)+            ]+        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall++emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff+                  -> FCode ())  -- ^ copy function+              -> CmmExpr        -- ^ source array+              -> CmmExpr        -- ^ offset in source array+              -> CmmExpr        -- ^ destination array+              -> CmmExpr        -- ^ offset in destination array+              -> WordOff        -- ^ number of elements to copy+              -> FCode ()+emitCopyArray copy src0 src_off dst0 dst_off0 n = do+    dflags <- getDynFlags+    when (n /= 0) $ do+        -- Passed as arguments (be careful)+        src     <- assignTempE src0+        dst     <- assignTempE dst0+        dst_off <- assignTempE dst_off0++        -- Set the dirty bit in the header.+        emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))++        dst_elems_p <- assignTempE $ cmmOffsetB dflags dst+                       (arrPtrsHdrSize dflags)+        dst_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p dst_off+        src_p <- assignTempE $ cmmOffsetExprW dflags+                 (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off+        let bytes = wordsToBytes dflags n++        copy src dst dst_p src_p bytes++        -- The base address of the destination card table+        dst_cards_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p+                       (loadArrPtrsSize dflags dst)++        emitSetCards dst_off dst_cards_p n++doCopySmallArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff+                   -> FCode ()+doCopySmallArrayOp = emitCopySmallArray copy+  where+    -- Copy data (we assume the arrays aren't overlapping since+    -- they're of different types)+    copy _src _dst dst_p src_p bytes =+        do dflags <- getDynFlags+           emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)+               (wORD_SIZE dflags)+++doCopySmallMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff+                          -> FCode ()+doCopySmallMutableArrayOp = emitCopySmallArray copy+  where+    -- The only time the memory might overlap is when the two arrays+    -- we were provided are the same array!+    -- TODO: Optimize branch for common case of no aliasing.+    copy src dst dst_p src_p bytes = do+        dflags <- getDynFlags+        [moveCall, cpyCall] <- forkAlts+            [ getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)+              (wORD_SIZE dflags)+            , getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr dflags bytes)+              (wORD_SIZE dflags)+            ]+        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall++emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff+                       -> FCode ())  -- ^ copy function+                   -> CmmExpr        -- ^ source array+                   -> CmmExpr        -- ^ offset in source array+                   -> CmmExpr        -- ^ destination array+                   -> CmmExpr        -- ^ offset in destination array+                   -> WordOff        -- ^ number of elements to copy+                   -> FCode ()+emitCopySmallArray copy src0 src_off dst0 dst_off n = do+    dflags <- getDynFlags++    -- Passed as arguments (be careful)+    src     <- assignTempE src0+    dst     <- assignTempE dst0++    -- Set the dirty bit in the header.+    emit (setInfo dst (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))++    dst_p <- assignTempE $ cmmOffsetExprW dflags+             (cmmOffsetB dflags dst (smallArrPtrsHdrSize dflags)) dst_off+    src_p <- assignTempE $ cmmOffsetExprW dflags+             (cmmOffsetB dflags src (smallArrPtrsHdrSize dflags)) src_off+    let bytes = wordsToBytes dflags n++    copy src dst dst_p src_p bytes++-- | Takes an info table label, a register to return the newly+-- allocated array in, a source array, an offset in the source array,+-- and the number of elements to copy. Allocates a new array and+-- initializes it from the source array.+emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff+               -> FCode ()+emitCloneArray info_p res_r src src_off n = do+    dflags <- getDynFlags++    let info_ptr = mkLblExpr info_p+        rep = arrPtrsRep dflags n++    tickyAllocPrim (mkIntExpr dflags (arrPtrsHdrSize dflags))+        (mkIntExpr dflags (nonHdrSize dflags rep))+        (zeroExpr dflags)++    let hdr_size = fixedHdrSize dflags++    base <- allocHeapClosure rep info_ptr curCCS+                     [ (mkIntExpr dflags n,+                        hdr_size + oFFSET_StgMutArrPtrs_ptrs dflags)+                     , (mkIntExpr dflags (nonHdrSizeW rep),+                        hdr_size + oFFSET_StgMutArrPtrs_size dflags)+                     ]++    arr <- CmmLocal `fmap` newTemp (bWord dflags)+    emit $ mkAssign arr base++    dst_p <- assignTempE $ cmmOffsetB dflags (CmmReg arr)+             (arrPtrsHdrSize dflags)+    src_p <- assignTempE $ cmmOffsetExprW dflags src+             (cmmAddWord dflags+              (mkIntExpr dflags (arrPtrsHdrSizeW dflags)) src_off)++    emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n))+        (wORD_SIZE dflags)++    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)++-- | Takes an info table label, a register to return the newly+-- allocated array in, a source array, an offset in the source array,+-- and the number of elements to copy. Allocates a new array and+-- initializes it from the source array.+emitCloneSmallArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff+                    -> FCode ()+emitCloneSmallArray info_p res_r src src_off n = do+    dflags <- getDynFlags++    let info_ptr = mkLblExpr info_p+        rep = smallArrPtrsRep n++    tickyAllocPrim (mkIntExpr dflags (smallArrPtrsHdrSize dflags))+        (mkIntExpr dflags (nonHdrSize dflags rep))+        (zeroExpr dflags)++    let hdr_size = fixedHdrSize dflags++    base <- allocHeapClosure rep info_ptr curCCS+                     [ (mkIntExpr dflags n,+                        hdr_size + oFFSET_StgSmallMutArrPtrs_ptrs dflags)+                     ]++    arr <- CmmLocal `fmap` newTemp (bWord dflags)+    emit $ mkAssign arr base++    dst_p <- assignTempE $ cmmOffsetB dflags (CmmReg arr)+             (smallArrPtrsHdrSize dflags)+    src_p <- assignTempE $ cmmOffsetExprW dflags src+             (cmmAddWord dflags+              (mkIntExpr dflags (smallArrPtrsHdrSizeW dflags)) src_off)++    emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n))+        (wORD_SIZE dflags)++    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)++-- | Takes and offset in the destination array, the base address of+-- the card table, and the number of elements affected (*not* the+-- number of cards). The number of elements may not be zero.+-- Marks the relevant cards as dirty.+emitSetCards :: CmmExpr -> CmmExpr -> WordOff -> FCode ()+emitSetCards dst_start dst_cards_start n = do+    dflags <- getDynFlags+    start_card <- assignTempE $ cardCmm dflags dst_start+    let end_card = cardCmm dflags+                   (cmmSubWord dflags+                    (cmmAddWord dflags dst_start (mkIntExpr dflags n))+                    (mkIntExpr dflags 1))+    emitMemsetCall (cmmAddWord dflags dst_cards_start start_card)+        (mkIntExpr dflags 1)+        (cmmAddWord dflags (cmmSubWord dflags end_card start_card) (mkIntExpr dflags 1))+        1 -- no alignment (1 byte)++-- Convert an element index to a card index+cardCmm :: DynFlags -> CmmExpr -> CmmExpr+cardCmm dflags i =+    cmmUShrWord dflags i (mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags))++------------------------------------------------------------------------------+-- SmallArray PrimOp implementations++doReadSmallPtrArrayOp :: LocalReg+                      -> CmmExpr+                      -> CmmExpr+                      -> FCode ()+doReadSmallPtrArrayOp res addr idx = do+    dflags <- getDynFlags+    mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr+        (gcWord dflags) idx++doWriteSmallPtrArrayOp :: CmmExpr+                       -> CmmExpr+                       -> CmmExpr+                       -> FCode ()+doWriteSmallPtrArrayOp addr idx val = do+    dflags <- getDynFlags+    let ty = cmmExprType dflags val+    mkBasicIndexedWrite (smallArrPtrsHdrSize dflags) Nothing addr ty idx val+    emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))++------------------------------------------------------------------------------+-- Atomic read-modify-write++-- | Emit an atomic modification to a byte array element. The result+-- reg contains that previous value of the element. Implies a full+-- memory barrier.+doAtomicRMW :: LocalReg      -- ^ Result reg+            -> AtomicMachOp  -- ^ Atomic op (e.g. add)+            -> CmmExpr       -- ^ MutableByteArray#+            -> CmmExpr       -- ^ Index+            -> CmmType       -- ^ Type of element by which we are indexing+            -> CmmExpr       -- ^ Op argument (e.g. amount to add)+            -> FCode ()+doAtomicRMW res amop mba idx idx_ty n = do+    dflags <- getDynFlags+    let width = typeWidth idx_ty+        addr  = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)+                width mba idx+    emitPrimCall+        [ res ]+        (MO_AtomicRMW width amop)+        [ addr, n ]++-- | Emit an atomic read to a byte array that acts as a memory barrier.+doAtomicReadByteArray+    :: LocalReg  -- ^ Result reg+    -> CmmExpr   -- ^ MutableByteArray#+    -> CmmExpr   -- ^ Index+    -> CmmType   -- ^ Type of element by which we are indexing+    -> FCode ()+doAtomicReadByteArray res mba idx idx_ty = do+    dflags <- getDynFlags+    let width = typeWidth idx_ty+        addr  = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)+                width mba idx+    emitPrimCall+        [ res ]+        (MO_AtomicRead width)+        [ addr ]++-- | Emit an atomic write to a byte array that acts as a memory barrier.+doAtomicWriteByteArray+    :: CmmExpr   -- ^ MutableByteArray#+    -> CmmExpr   -- ^ Index+    -> CmmType   -- ^ Type of element by which we are indexing+    -> CmmExpr   -- ^ Value to write+    -> FCode ()+doAtomicWriteByteArray mba idx idx_ty val = do+    dflags <- getDynFlags+    let width = typeWidth idx_ty+        addr  = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)+                width mba idx+    emitPrimCall+        [ {- no results -} ]+        (MO_AtomicWrite width)+        [ addr, val ]++doCasByteArray+    :: LocalReg  -- ^ Result reg+    -> CmmExpr   -- ^ MutableByteArray#+    -> CmmExpr   -- ^ Index+    -> CmmType   -- ^ Type of element by which we are indexing+    -> CmmExpr   -- ^ Old value+    -> CmmExpr   -- ^ New value+    -> FCode ()+doCasByteArray res mba idx idx_ty old new = do+    dflags <- getDynFlags+    let width = (typeWidth idx_ty)+        addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)+               width mba idx+    emitPrimCall+        [ res ]+        (MO_Cmpxchg width)+        [ addr, old, new ]++------------------------------------------------------------------------------+-- Helpers for emitting function calls++-- | Emit a call to @memcpy@.+emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()+emitMemcpyCall dst src n align = do+    emitPrimCall+        [ {-no results-} ]+        (MO_Memcpy align)+        [ dst, src, n ]++-- | Emit a call to @memmove@.+emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()+emitMemmoveCall dst src n align = do+    emitPrimCall+        [ {- no results -} ]+        (MO_Memmove align)+        [ dst, src, n ]++-- | Emit a call to @memset@.  The second argument must fit inside an+-- unsigned char.+emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()+emitMemsetCall dst c n align = do+    emitPrimCall+        [ {- no results -} ]+        (MO_Memset align)+        [ dst, c, n ]++emitBSwapCall :: LocalReg -> CmmExpr -> Width -> FCode ()+emitBSwapCall res x width = do+    emitPrimCall+        [ res ]+        (MO_BSwap width)+        [ x ]++emitPopCntCall :: LocalReg -> CmmExpr -> Width -> FCode ()+emitPopCntCall res x width = do+    emitPrimCall+        [ res ]+        (MO_PopCnt width)+        [ x ]++emitClzCall :: LocalReg -> CmmExpr -> Width -> FCode ()+emitClzCall res x width = do+    emitPrimCall+        [ res ]+        (MO_Clz width)+        [ x ]++emitCtzCall :: LocalReg -> CmmExpr -> Width -> FCode ()+emitCtzCall res x width = do+    emitPrimCall+        [ res ]+        (MO_Ctz width)+        [ x ]
+ codeGen/StgCmmProf.hs view
@@ -0,0 +1,366 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Code generation for profiling+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module StgCmmProf (+        initCostCentres, ccType, ccsType,+        mkCCostCentre, mkCCostCentreStack,++        -- Cost-centre Profiling+        dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,+        enterCostCentreThunk, enterCostCentreFun,+        costCentreFrom,+        curCCS, storeCurCCS,+        emitSetCCC,++        saveCurrentCostCentre, restoreCurrentCostCentre,++        -- Lag/drag/void stuff+        ldvEnter, ldvEnterClosure, ldvRecordCreate+  ) where++#include "HsVersions.h"++import StgCmmClosure+import StgCmmUtils+import StgCmmMonad+import SMRep++import MkGraph+import Cmm+import CmmUtils+import CLabel++import qualified Module+import CostCentre+import DynFlags+import FastString+import Module+import Outputable++import Control.Monad+import Data.Char (ord)++-----------------------------------------------------------------------------+--+-- Cost-centre-stack Profiling+--+-----------------------------------------------------------------------------++-- Expression representing the current cost centre stack+ccsType :: DynFlags -> CmmType -- Type of a cost-centre stack+ccsType = bWord++ccType :: DynFlags -> CmmType -- Type of a cost centre+ccType = bWord++curCCS :: CmmExpr+curCCS = CmmReg (CmmGlobal CCCS)++storeCurCCS :: CmmExpr -> CmmAGraph+storeCurCCS e = mkAssign (CmmGlobal CCCS) e++mkCCostCentre :: CostCentre -> CmmLit+mkCCostCentre cc = CmmLabel (mkCCLabel cc)++mkCCostCentreStack :: CostCentreStack -> CmmLit+mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)++costCentreFrom :: DynFlags+               -> CmmExpr         -- A closure pointer+               -> CmmExpr        -- The cost centre from that closure+costCentreFrom dflags cl = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (ccsType dflags)++-- | The profiling header words in a static closure+staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]+staticProfHdr dflags ccs+ = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit dflags]++-- | Profiling header words in a dynamic closure+dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]+dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags]++-- | Initialise the profiling field of an update frame+initUpdFrameProf :: CmmExpr -> FCode ()+initUpdFrameProf frame+  = ifProfiling $        -- frame->header.prof.ccs = CCCS+    do dflags <- getDynFlags+       emitStore (cmmOffset dflags frame (oFFSET_StgHeader_ccs dflags)) curCCS+        -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)+        -- is unnecessary because it is not used anyhow.++---------------------------------------------------------------------------+--         Saving and restoring the current cost centre+---------------------------------------------------------------------------++{-        Note [Saving the current cost centre]+        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The current cost centre is like a global register.  Like other+global registers, it's a caller-saves one.  But consider+        case (f x) of (p,q) -> rhs+Since 'f' may set the cost centre, we must restore it+before resuming rhs.  So we want code like this:+        local_cc = CCC  -- save+        r = f( x )+        CCC = local_cc  -- restore+That is, we explicitly "save" the current cost centre in+a LocalReg, local_cc; and restore it after the call. The+C-- infrastructure will arrange to save local_cc across the+call.++The same goes for join points;+        let j x = join-stuff+        in blah-blah+We want this kind of code:+        local_cc = CCC  -- save+        blah-blah+     J:+        CCC = local_cc  -- restore+-}++saveCurrentCostCentre :: FCode (Maybe LocalReg)+        -- Returns Nothing if profiling is off+saveCurrentCostCentre+  = do dflags <- getDynFlags+       if not (gopt Opt_SccProfilingOn dflags)+           then return Nothing+           else do local_cc <- newTemp (ccType dflags)+                   emitAssign (CmmLocal local_cc) curCCS+                   return (Just local_cc)++restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()+restoreCurrentCostCentre Nothing+  = return ()+restoreCurrentCostCentre (Just local_cc)+  = emit (storeCurCCS (CmmReg (CmmLocal local_cc)))+++-------------------------------------------------------------------------------+-- Recording allocation in a cost centre+-------------------------------------------------------------------------------++-- | Record the allocation of a closure.  The CmmExpr is the cost+-- centre stack to which to attribute the allocation.+profDynAlloc :: SMRep -> CmmExpr -> FCode ()+profDynAlloc rep ccs+  = ifProfiling $+    do dflags <- getDynFlags+       profAlloc (mkIntExpr dflags (heapClosureSizeW dflags rep)) ccs++-- | Record the allocation of a closure (size is given by a CmmExpr)+-- The size must be in words, because the allocation counter in a CCS counts+-- in words.+profAlloc :: CmmExpr -> CmmExpr -> FCode ()+profAlloc words ccs+  = ifProfiling $+        do dflags <- getDynFlags+           let alloc_rep = rEP_CostCentreStack_mem_alloc dflags+           emit (addToMemE alloc_rep+                       (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_mem_alloc dflags))+                       (CmmMachOp (MO_UU_Conv (wordWidth dflags) (typeWidth alloc_rep)) $+                         [CmmMachOp (mo_wordSub dflags) [words,+                                                         mkIntExpr dflags (profHdrSize dflags)]]))+                       -- subtract the "profiling overhead", which is the+                       -- profiling header in a closure.++-- -----------------------------------------------------------------------+-- Setting the current cost centre on entry to a closure++enterCostCentreThunk :: CmmExpr -> FCode ()+enterCostCentreThunk closure =+  ifProfiling $ do+      dflags <- getDynFlags+      emit $ storeCurCCS (costCentreFrom dflags closure)++enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode ()+enterCostCentreFun ccs closure =+  ifProfiling $ do+    if isCurrentCCS ccs+       then do dflags <- getDynFlags+               emitRtsCall rtsUnitId (fsLit "enterFunCCS")+                   [(CmmReg (CmmGlobal BaseReg), AddrHint),+                    (costCentreFrom dflags closure, AddrHint)] False+       else return () -- top-level function, nothing to do++ifProfiling :: FCode () -> FCode ()+ifProfiling code+  = do dflags <- getDynFlags+       if gopt Opt_SccProfilingOn dflags+           then code+           else return ()++ifProfilingL :: DynFlags -> [a] -> [a]+ifProfilingL dflags xs+  | gopt Opt_SccProfilingOn dflags = xs+  | otherwise                      = []+++---------------------------------------------------------------+--        Initialising Cost Centres & CCSs+---------------------------------------------------------------++initCostCentres :: CollectedCCs -> FCode ()+-- Emit the declarations+initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)+  = do dflags <- getDynFlags+       when (gopt Opt_SccProfilingOn dflags) $+           do mapM_ emitCostCentreDecl local_CCs+              mapM_ emitCostCentreStackDecl singleton_CCSs+++emitCostCentreDecl :: CostCentre -> FCode ()+emitCostCentreDecl cc = do+  { dflags <- getDynFlags+  ; let is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF+               | otherwise  = zero dflags+                        -- NB. bytesFS: we want the UTF-8 bytes here (#5559)+  ; label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc)+  ; modl  <- newByteStringCLit (bytesFS $ Module.moduleNameFS+                                        $ Module.moduleName+                                        $ cc_mod cc)+  ; loc <- newByteStringCLit $ bytesFS $ mkFastString $+                   showPpr dflags (costCentreSrcSpan cc)+           -- XXX going via FastString to get UTF-8 encoding is silly+  ; let+     lits = [ zero dflags,           -- StgInt ccID,+              label,        -- char *label,+              modl,        -- char *module,+              loc,      -- char *srcloc,+              zero64,   -- StgWord64 mem_alloc+              zero dflags,     -- StgWord time_ticks+              is_caf,   -- StgInt is_caf+              zero dflags      -- struct _CostCentre *link+            ]+  ; emitDataLits (mkCCLabel cc) lits+  }++emitCostCentreStackDecl :: CostCentreStack -> FCode ()+emitCostCentreStackDecl ccs+  = case maybeSingletonCCS ccs of+    Just cc ->+        do dflags <- getDynFlags+           let mk_lits cc = zero dflags :+                            mkCCostCentre cc :+                            replicate (sizeof_ccs_words dflags - 2) (zero dflags)+                -- Note: to avoid making any assumptions about how the+                -- C compiler (that compiles the RTS, in particular) does+                -- layouts of structs containing long-longs, simply+                -- pad out the struct with zero words until we hit the+                -- size of the overall struct (which we get via DerivedConstants.h)+           emitDataLits (mkCCSLabel ccs) (mk_lits cc)+    Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)++zero :: DynFlags -> CmmLit+zero dflags = mkIntCLit dflags 0+zero64 :: CmmLit+zero64 = CmmInt 0 W64++sizeof_ccs_words :: DynFlags -> Int+sizeof_ccs_words dflags+    -- round up to the next word.+  | ms == 0   = ws+  | otherwise = ws + 1+  where+   (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` wORD_SIZE dflags++-- ---------------------------------------------------------------------------+-- Set the current cost centre stack++emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()+emitSetCCC cc tick push+ = do dflags <- getDynFlags+      if not (gopt Opt_SccProfilingOn dflags)+          then return ()+          else do tmp <- newTemp (ccsType dflags)+                  pushCostCentre tmp curCCS cc+                  when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp)))+                  when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))++pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()+pushCostCentre result ccs cc+  = emitRtsCallWithResult result AddrHint+        rtsUnitId+        (fsLit "pushCostCentre") [(ccs,AddrHint),+                                (CmmLit (mkCCostCentre cc), AddrHint)]+        False++bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph+bumpSccCount dflags ccs+  = addToMem (rEP_CostCentreStack_scc_count dflags)+         (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1++-----------------------------------------------------------------------------+--+--                Lag/drag/void stuff+--+-----------------------------------------------------------------------------++--+-- Initial value for the LDV field in a static closure+--+staticLdvInit :: DynFlags -> CmmLit+staticLdvInit = zeroCLit++--+-- Initial value of the LDV field in a dynamic closure+--+dynLdvInit :: DynFlags -> CmmExpr+dynLdvInit dflags =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE+  CmmMachOp (mo_wordOr dflags) [+      CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)],+      CmmLit (mkWordCLit dflags (iLDV_STATE_CREATE dflags))+  ]++--+-- Initialise the LDV word of a new closure+--+ldvRecordCreate :: CmmExpr -> FCode ()+ldvRecordCreate closure = do+  dflags <- getDynFlags+  emit $ mkStore (ldvWord dflags closure) (dynLdvInit dflags)++--+-- | Called when a closure is entered, marks the closure as having+-- been "used".  The closure is not an "inherently used" one.  The+-- closure is not @IND@ because that is not considered for LDV profiling.+--+ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode ()+ldvEnterClosure closure_info node_reg = do+    dflags <- getDynFlags+    let tag = funTag dflags closure_info+    -- don't forget to substract node's tag+    ldvEnter (cmmOffsetB dflags (CmmReg node_reg) (-tag))++ldvEnter :: CmmExpr -> FCode ()+-- Argument is a closure pointer+ldvEnter cl_ptr = do+    dflags <- getDynFlags+    let -- don't forget to substract node's tag+        ldv_wd = ldvWord dflags cl_ptr+        new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags))+                                                         (CmmLit (mkWordCLit dflags (iLDV_CREATE_MASK dflags))))+                                      (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (iLDV_STATE_USE dflags))))+    ifProfiling $+         -- if (era > 0) {+         --    LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |+         --                era | LDV_STATE_USE }+        emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt dflags) [loadEra dflags, CmmLit (zeroCLit dflags)])+                     (mkStore ldv_wd new_ldv_wd)+                     mkNop++loadEra :: DynFlags -> CmmExpr+loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags))+    [CmmLoad (mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "era")))+             (cInt dflags)]++ldvWord :: DynFlags -> CmmExpr -> CmmExpr+-- Takes the address of a closure, and returns+-- the address of the LDV word in the closure+ldvWord dflags closure_ptr+    = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags)
+ codeGen/StgCmmTicky.hs view
@@ -0,0 +1,675 @@+{-# LANGUAGE BangPatterns, CPP #-}++-----------------------------------------------------------------------------+--+-- Code generation for ticky-ticky profiling+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++{- OVERVIEW: ticky ticky profiling++Please see+http://ghc.haskell.org/trac/ghc/wiki/Debugging/TickyTicky and also+edit it and the rest of this comment to keep them up-to-date if you+change ticky-ticky. Thanks!++ *** All allocation ticky numbers are in bytes. ***++Some of the relevant source files:++       ***not necessarily an exhaustive list***++  * some codeGen/ modules import this one++  * this module imports cmm/CLabel.hs to manage labels++  * cmm/CmmParse.y expands some macros using generators defined in+    this module++  * includes/stg/Ticky.h declares all of the global counters++  * includes/rts/Ticky.h declares the C data type for an+    STG-declaration's counters++  * some macros defined in includes/Cmm.h (and used within the RTS's+    CMM code) update the global ticky counters++  * at the end of execution rts/Ticky.c generates the final report+    +RTS -r<report-file> -RTS++The rts/Ticky.c function that generates the report includes an+STG-declaration's ticky counters if++  * that declaration was entered, or++  * it was allocated (if -ticky-allocd)++On either of those events, the counter is "registered" by adding it to+a linked list; cf the CMM generated by registerTickyCtr.++Ticky-ticky profiling has evolved over many years. Many of the+counters from its most sophisticated days are no longer+active/accurate. As the RTS has changed, sometimes the ticky code for+relevant counters was not accordingly updated. Unfortunately, neither+were the comments.++As of March 2013, there still exist deprecated code and comments in+the code generator as well as the RTS because:++  * I don't know what is out-of-date versus merely commented out for+    momentary convenience, and++  * someone else might know how to repair it!++-}++module StgCmmTicky (+  withNewTickyCounterFun,+  withNewTickyCounterLNE,+  withNewTickyCounterThunk,+  withNewTickyCounterStdThunk,+  withNewTickyCounterCon,++  tickyDynAlloc,+  tickyAllocHeap,++  tickyAllocPrim,+  tickyAllocThunk,+  tickyAllocPAP,+  tickyHeapCheck,+  tickyStackCheck,++  tickyUnknownCall, tickyDirectCall,++  tickyPushUpdateFrame,+  tickyUpdateFrameOmitted,++  tickyEnterDynCon,+  tickyEnterStaticCon,+  tickyEnterViaNode,++  tickyEnterFun,+  tickyEnterThunk, tickyEnterStdThunk,        -- dynamic non-value+                                              -- thunks only+  tickyEnterLNE,++  tickyUpdateBhCaf,+  tickyBlackHole,+  tickyUnboxedTupleReturn,+  tickyReturnOldCon, tickyReturnNewCon,++  tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,+  tickySlowCall, tickySlowCallPat,+  ) where++#include "HsVersions.h"++import StgCmmArgRep    ( slowCallPattern , toArgRep , argRepString )+import StgCmmClosure+import StgCmmUtils+import StgCmmMonad++import StgSyn+import CmmExpr+import MkGraph+import CmmUtils+import CLabel+import SMRep++import Module+import Name+import Id+import BasicTypes+import FastString+import Outputable++import DynFlags++-- Turgid imports for showTypeCategory+import PrelNames+import TcType+import Type+import TyCon++import Data.Maybe+import qualified Data.Char+import Control.Monad ( unless, when )++-----------------------------------------------------------------------------+--+-- Ticky-ticky profiling+--+-----------------------------------------------------------------------------++data TickyClosureType+    = TickyFun+        Bool -- True <-> single entry+    | TickyCon+    | TickyThunk+        Bool -- True <-> updateable+        Bool -- True <-> standard thunk (AP or selector), has no entry counter+    | TickyLNE++withNewTickyCounterFun :: Bool -> Name  -> [NonVoid Id] -> FCode a -> FCode a+withNewTickyCounterFun single_entry = withNewTickyCounter (TickyFun single_entry)++withNewTickyCounterLNE :: Name  -> [NonVoid Id] -> FCode a -> FCode a+withNewTickyCounterLNE nm args code = do+  b <- tickyLNEIsOn+  if not b then code else withNewTickyCounter TickyLNE nm args code++withNewTickyCounterThunk+  :: Bool -- ^ static+  -> Bool -- ^ updateable+  -> Name+  -> FCode a+  -> FCode a+withNewTickyCounterThunk isStatic isUpdatable name code = do+    b <- tickyDynThunkIsOn+    if isStatic || not b -- ignore static thunks+      then code+      else withNewTickyCounter (TickyThunk isUpdatable False) name [] code++withNewTickyCounterStdThunk+  :: Bool -- ^ updateable+  -> Name+  -> FCode a+  -> FCode a+withNewTickyCounterStdThunk isUpdatable name code = do+    b <- tickyDynThunkIsOn+    if not b+      then code+      else withNewTickyCounter (TickyThunk isUpdatable True) name [] code++withNewTickyCounterCon+  :: Name+  -> FCode a+  -> FCode a+withNewTickyCounterCon name code = do+    b <- tickyDynThunkIsOn+    if not b+      then code+      else withNewTickyCounter TickyCon name [] code++-- args does not include the void arguments+withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a+withNewTickyCounter cloType name args m = do+  lbl <- emitTickyCounter cloType name args+  setTickyCtrLabel lbl m++emitTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode CLabel+emitTickyCounter cloType name args+  = let ctr_lbl = mkRednCountsLabel name in+    (>> return ctr_lbl) $+    ifTicky $ do+        { dflags <- getDynFlags+        ; parent <- getTickyCtrLabel+        ; mod_name <- getModuleName++          -- When printing the name of a thing in a ticky file, we+          -- want to give the module name even for *local* things.  We+          -- print just "x (M)" rather that "M.x" to distinguish them+          -- from the global kind.+        ; let ppr_for_ticky_name :: SDoc+              ppr_for_ticky_name =+                let n = ppr name+                    ext = case cloType of+                              TickyFun single_entry -> parens $ hcat $ punctuate comma $+                                  [text "fun"] ++ [text "se"|single_entry]+                              TickyCon -> parens (text "con")+                              TickyThunk upd std -> parens $ hcat $ punctuate comma $+                                  [text "thk"] ++ [text "se"|not upd] ++ [text "std"|std]+                              TickyLNE | isInternalName name -> parens (text "LNE")+                                       | otherwise -> panic "emitTickyCounter: how is this an external LNE?"+                    p = case hasHaskellName parent of+                            -- NB the default "top" ticky ctr does not+                            -- have a Haskell name+                          Just pname -> text "in" <+> ppr (nameUnique pname)+                          _ -> empty+                in if isInternalName name+                   then n <+> parens (ppr mod_name) <+> ext <+> p+                   else n <+> ext <+> p++        ; fun_descr_lit <- newStringCLit $ showSDocDebug dflags ppr_for_ticky_name+        ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args+        ; emitDataLits ctr_lbl+        -- Must match layout of includes/rts/Ticky.h's StgEntCounter+        --+        -- krc: note that all the fields are I32 now; some were I16+        -- before, but the code generator wasn't handling that+        -- properly and it led to chaos, panic and disorder.+            [ mkIntCLit dflags 0,               -- registered?+              mkIntCLit dflags (length args),   -- Arity+              mkIntCLit dflags 0,               -- Heap allocated for this thing+              fun_descr_lit,+              arg_descr_lit,+              zeroCLit dflags,          -- Entries into this thing+              zeroCLit dflags,          -- Heap allocated by this thing+              zeroCLit dflags                   -- Link to next StgEntCounter+            ]+        }++-- -----------------------------------------------------------------------------+-- Ticky stack frames++tickyPushUpdateFrame, tickyUpdateFrameOmitted :: FCode ()+tickyPushUpdateFrame    = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr")+tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr")++-- -----------------------------------------------------------------------------+-- Ticky entries++-- NB the name-specific entries are only available for names that have+-- dedicated Cmm code. As far as I know, this just rules out+-- constructor thunks. For them, there is no CMM code block to put the+-- bump of name-specific ticky counter into. On the other hand, we can+-- still track allocation their allocation.++tickyEnterDynCon, tickyEnterStaticCon, tickyEnterViaNode :: FCode ()+tickyEnterDynCon      = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr")+tickyEnterStaticCon   = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr")+tickyEnterViaNode     = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr")++tickyEnterThunk :: ClosureInfo -> FCode ()+tickyEnterThunk cl_info+  = ifTicky $ do+    { bumpTickyCounter ctr+    ; unless static $ do+      ticky_ctr_lbl <- getTickyCtrLabel+      registerTickyCtrAtEntryDyn ticky_ctr_lbl+      bumpTickyEntryCount ticky_ctr_lbl }+  where+    updatable = closureSingleEntry cl_info+    static    = isStaticClosure cl_info++    ctr | static    = if updatable then fsLit "ENT_STATIC_THK_SINGLE_ctr"+                                   else fsLit "ENT_STATIC_THK_MANY_ctr"+        | otherwise = if updatable then fsLit "ENT_DYN_THK_SINGLE_ctr"+                                   else fsLit "ENT_DYN_THK_MANY_ctr"++tickyEnterStdThunk :: ClosureInfo -> FCode ()+tickyEnterStdThunk = tickyEnterThunk++tickyBlackHole :: Bool{-updatable-} -> FCode ()+tickyBlackHole updatable+  = ifTicky (bumpTickyCounter ctr)+  where+    ctr | updatable = (fsLit "UPD_BH_SINGLE_ENTRY_ctr")+        | otherwise = (fsLit "UPD_BH_UPDATABLE_ctr")++tickyUpdateBhCaf :: ClosureInfo -> FCode ()+tickyUpdateBhCaf cl_info+  = ifTicky (bumpTickyCounter ctr)+  where+    ctr | closureUpdReqd cl_info = (fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr")+        | otherwise              = (fsLit "UPD_CAF_BH_UPDATABLE_ctr")++tickyEnterFun :: ClosureInfo -> FCode ()+tickyEnterFun cl_info = ifTicky $ do+  ctr_lbl <- getTickyCtrLabel++  if isStaticClosure cl_info+    then do bumpTickyCounter (fsLit "ENT_STATIC_FUN_DIRECT_ctr")+            registerTickyCtr ctr_lbl+    else do bumpTickyCounter (fsLit "ENT_DYN_FUN_DIRECT_ctr")+            registerTickyCtrAtEntryDyn ctr_lbl++  bumpTickyEntryCount ctr_lbl++tickyEnterLNE :: FCode ()+tickyEnterLNE = ifTicky $ do+  bumpTickyCounter (fsLit "ENT_LNE_ctr")+  ifTickyLNE $ do+    ctr_lbl <- getTickyCtrLabel+    registerTickyCtr ctr_lbl+    bumpTickyEntryCount ctr_lbl++-- needn't register a counter upon entry if+--+-- 1) it's for a dynamic closure, and+--+-- 2) -ticky-allocd is on+--+-- since the counter was registered already upon being alloc'd+registerTickyCtrAtEntryDyn :: CLabel -> FCode ()+registerTickyCtrAtEntryDyn ctr_lbl = do+  already_registered <- tickyAllocdIsOn+  when (not already_registered) $ registerTickyCtr ctr_lbl++registerTickyCtr :: CLabel -> FCode ()+-- Register a ticky counter+--   if ( ! f_ct.registeredp ) {+--          f_ct.link = ticky_entry_ctrs;       /* hook this one onto the front of the list */+--          ticky_entry_ctrs = & (f_ct);        /* mark it as "registered" */+--          f_ct.registeredp = 1 }+registerTickyCtr ctr_lbl = do+  dflags <- getDynFlags+  let+    -- krc: code generator doesn't handle Not, so we test for Eq 0 instead+    test = CmmMachOp (MO_Eq (wordWidth dflags))+              [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl+                                (oFFSET_StgEntCounter_registeredp dflags))) (bWord dflags),+               zeroExpr dflags]+    register_stmts+      = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_link dflags)))+                   (CmmLoad ticky_entry_ctrs (bWord dflags))+        , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl)+        , mkStore (CmmLit (cmmLabelOffB ctr_lbl+                                (oFFSET_StgEntCounter_registeredp dflags)))+                   (mkIntExpr dflags 1) ]+    ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "ticky_entry_ctrs"))+  emit =<< mkCmmIfThen test (catAGraphs register_stmts)++tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode ()+tickyReturnOldCon arity+  = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr")+                 ; bumpHistogram    (fsLit "RET_OLD_hst") arity }+tickyReturnNewCon arity+  = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr")+                 ; bumpHistogram    (fsLit "RET_NEW_hst") arity }++tickyUnboxedTupleReturn :: RepArity -> FCode ()+tickyUnboxedTupleReturn arity+  = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr")+                 ; bumpHistogram    (fsLit "RET_UNBOXED_TUP_hst") arity }++-- -----------------------------------------------------------------------------+-- Ticky calls++-- Ticks at a *call site*:+tickyDirectCall :: RepArity -> [StgArg] -> FCode ()+tickyDirectCall arity args+  | arity == length args = tickyKnownCallExact+  | otherwise = do tickyKnownCallExtraArgs+                   tickySlowCallPat (map argPrimRep (drop arity args))++tickyKnownCallTooFewArgs :: FCode ()+tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")++tickyKnownCallExact :: FCode ()+tickyKnownCallExact      = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr")++tickyKnownCallExtraArgs :: FCode ()+tickyKnownCallExtraArgs  = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr")++tickyUnknownCall :: FCode ()+tickyUnknownCall         = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr")++-- Tick for the call pattern at slow call site (i.e. in addition to+-- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)+tickySlowCall :: LambdaFormInfo -> [StgArg] -> FCode ()+tickySlowCall _ [] = return ()+tickySlowCall lf_info args = do+ -- see Note [Ticky for slow calls]+ if isKnownFun lf_info+   then tickyKnownCallTooFewArgs+   else tickyUnknownCall+ tickySlowCallPat (map argPrimRep args)++tickySlowCallPat :: [PrimRep] -> FCode ()+tickySlowCallPat args = ifTicky $+  let argReps = map toArgRep args+      (_, n_matched) = slowCallPattern argReps+  in if n_matched > 0 && n_matched == length args+     then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps+     else bumpTickyCounter $ fsLit "VERY_SLOW_CALL_ctr"++{-++Note [Ticky for slow calls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Terminology is unfortunately a bit mixed up for these calls. codeGen+uses "slow call" to refer to unknown calls and under-saturated known+calls.++Nowadays, though (ie as of the eval/apply paper), the significantly+slower calls are actually just a subset of these: the ones with no+built-in argument pattern (cf StgCmmArgRep.slowCallPattern)++So for ticky profiling, we split slow calls into+"SLOW_CALL_fast_<pattern>_ctr" (those matching a built-in pattern) and+VERY_SLOW_CALL_ctr (those without a built-in pattern; these are very+bad for both space and time).++-}++-- -----------------------------------------------------------------------------+-- Ticky allocation++tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode ()+-- Called when doing a dynamic heap allocation; the LambdaFormInfo+-- used to distinguish between closure types+--+-- TODO what else to count while we're here?+tickyDynAlloc mb_id rep lf = ifTicky $ getDynFlags >>= \dflags ->+  let bytes = wORD_SIZE dflags * heapClosureSizeW dflags rep++      countGlobal tot ctr = do+        bumpTickyCounterBy tot bytes+        bumpTickyCounter   ctr+      countSpecific = ifTickyAllocd $ case mb_id of+        Nothing -> return ()+        Just id -> do+          let ctr_lbl = mkRednCountsLabel (idName id)+          registerTickyCtr ctr_lbl+          bumpTickyAllocd ctr_lbl bytes++  -- TODO are we still tracking "good stuff" (_gds) versus+  -- administrative (_adm) versus slop (_slp)? I'm going with all _gds+  -- for now, since I don't currently know neither if we do nor how to+  -- distinguish. NSF Mar 2013++  in case () of+    _ | isConRep rep   ->+          ifTickyDynThunk countSpecific >>+          countGlobal (fsLit "ALLOC_CON_gds") (fsLit "ALLOC_CON_ctr")+      | isThunkRep rep ->+          ifTickyDynThunk countSpecific >>+          if lfUpdatable lf+          then countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_UP_THK_ctr")+          else countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_SE_THK_ctr")+      | isFunRep   rep ->+          countSpecific >>+          countGlobal (fsLit "ALLOC_FUN_gds") (fsLit "ALLOC_FUN_ctr")+      | otherwise      -> panic "How is this heap object not a con, thunk, or fun?"++++tickyAllocHeap ::+  Bool -> -- is this a genuine allocation? As opposed to+          -- StgCmmLayout.adjustHpBackwards+  VirtualHpOffset -> FCode ()+-- Called when doing a heap check [TICK_ALLOC_HEAP]+-- Must be lazy in the amount of allocation!+tickyAllocHeap genuine hp+  = ifTicky $+    do  { dflags <- getDynFlags+        ; ticky_ctr <- getTickyCtrLabel+        ; emit $ catAGraphs $+            -- only test hp from within the emit so that the monadic+            -- computation itself is not strict in hp (cf knot in+            -- StgCmmMonad.getHeapUsage)+          if hp == 0 then []+          else let !bytes = wORD_SIZE dflags * hp in [+            -- Bump the allocation total in the closure's StgEntCounter+            addToMem (rEP_StgEntCounter_allocs dflags)+                     (CmmLit (cmmLabelOffB ticky_ctr (oFFSET_StgEntCounter_allocs dflags)))+                     bytes,+            -- Bump the global allocation total ALLOC_HEAP_tot+            addToMemLbl (bWord dflags)+                        (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_tot"))+                        bytes,+            -- Bump the global allocation counter ALLOC_HEAP_ctr+            if not genuine then mkNop+            else addToMemLbl (bWord dflags)+                             (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_ctr"))+                             1+            ]}+++--------------------------------------------------------------------------------+-- these three are only called from CmmParse.y (ie ultimately from the RTS)++-- the units are bytes++tickyAllocPrim :: CmmExpr  -- ^ size of the full header, in bytes+               -> CmmExpr  -- ^ size of the payload, in bytes+               -> CmmExpr -> FCode ()+tickyAllocPrim _hdr _goods _slop = ifTicky $ do+  bumpTickyCounter    (fsLit "ALLOC_PRIM_ctr")+  bumpTickyCounterByE (fsLit "ALLOC_PRIM_adm") _hdr+  bumpTickyCounterByE (fsLit "ALLOC_PRIM_gds") _goods+  bumpTickyCounterByE (fsLit "ALLOC_PRIM_slp") _slop++tickyAllocThunk :: CmmExpr -> CmmExpr -> FCode ()+tickyAllocThunk _goods _slop = ifTicky $ do+    -- TODO is it ever called with a Single-Entry thunk?+  bumpTickyCounter    (fsLit "ALLOC_UP_THK_ctr")+  bumpTickyCounterByE (fsLit "ALLOC_THK_gds") _goods+  bumpTickyCounterByE (fsLit "ALLOC_THK_slp") _slop++tickyAllocPAP :: CmmExpr -> CmmExpr -> FCode ()+tickyAllocPAP _goods _slop = ifTicky $ do+  bumpTickyCounter    (fsLit "ALLOC_PAP_ctr")+  bumpTickyCounterByE (fsLit "ALLOC_PAP_gds") _goods+  bumpTickyCounterByE (fsLit "ALLOC_PAP_slp") _slop++tickyHeapCheck :: FCode ()+tickyHeapCheck = ifTicky $ bumpTickyCounter (fsLit "HEAP_CHK_ctr")++tickyStackCheck :: FCode ()+tickyStackCheck = ifTicky $ bumpTickyCounter (fsLit "STK_CHK_ctr")++-- -----------------------------------------------------------------------------+-- Ticky utils++ifTicky :: FCode () -> FCode ()+ifTicky code =+  getDynFlags >>= \dflags -> when (gopt Opt_Ticky dflags) code++tickyAllocdIsOn :: FCode Bool+tickyAllocdIsOn = gopt Opt_Ticky_Allocd `fmap` getDynFlags++tickyLNEIsOn :: FCode Bool+tickyLNEIsOn = gopt Opt_Ticky_LNE `fmap` getDynFlags++tickyDynThunkIsOn :: FCode Bool+tickyDynThunkIsOn = gopt Opt_Ticky_Dyn_Thunk `fmap` getDynFlags++ifTickyAllocd :: FCode () -> FCode ()+ifTickyAllocd code = tickyAllocdIsOn >>= \b -> when b code++ifTickyLNE :: FCode () -> FCode ()+ifTickyLNE code = tickyLNEIsOn >>= \b -> when b code++ifTickyDynThunk :: FCode () -> FCode ()+ifTickyDynThunk code = tickyDynThunkIsOn >>= \b -> when b code++bumpTickyCounter :: FastString -> FCode ()+bumpTickyCounter lbl = bumpTickyLbl (mkCmmDataLabel rtsUnitId lbl)++bumpTickyCounterBy :: FastString -> Int -> FCode ()+bumpTickyCounterBy lbl = bumpTickyLblBy (mkCmmDataLabel rtsUnitId lbl)++bumpTickyCounterByE :: FastString -> CmmExpr -> FCode ()+bumpTickyCounterByE lbl = bumpTickyLblByE (mkCmmDataLabel rtsUnitId lbl)++bumpTickyEntryCount :: CLabel -> FCode ()+bumpTickyEntryCount lbl = do+  dflags <- getDynFlags+  bumpTickyLit (cmmLabelOffB lbl (oFFSET_StgEntCounter_entry_count dflags))++bumpTickyAllocd :: CLabel -> Int -> FCode ()+bumpTickyAllocd lbl bytes = do+  dflags <- getDynFlags+  bumpTickyLitBy (cmmLabelOffB lbl (oFFSET_StgEntCounter_allocd dflags)) bytes++bumpTickyLbl :: CLabel -> FCode ()+bumpTickyLbl lhs = bumpTickyLitBy (cmmLabelOffB lhs 0) 1++bumpTickyLblBy :: CLabel -> Int -> FCode ()+bumpTickyLblBy lhs = bumpTickyLitBy (cmmLabelOffB lhs 0)++bumpTickyLblByE :: CLabel -> CmmExpr -> FCode ()+bumpTickyLblByE lhs = bumpTickyLitByE (cmmLabelOffB lhs 0)++bumpTickyLit :: CmmLit -> FCode ()+bumpTickyLit lhs = bumpTickyLitBy lhs 1++bumpTickyLitBy :: CmmLit -> Int -> FCode ()+bumpTickyLitBy lhs n = do+  dflags <- getDynFlags+  emit (addToMem (bWord dflags) (CmmLit lhs) n)++bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode ()+bumpTickyLitByE lhs e = do+  dflags <- getDynFlags+  emit (addToMemE (bWord dflags) (CmmLit lhs) e)++bumpHistogram :: FastString -> Int -> FCode ()+bumpHistogram lbl n = do+    dflags <- getDynFlags+    let offset = n `min` (tICKY_BIN_COUNT dflags - 1)+    emit (addToMem (bWord dflags)+           (cmmIndexExpr dflags+                (wordWidth dflags)+                (CmmLit (CmmLabel (mkCmmDataLabel rtsUnitId lbl)))+                (CmmLit (CmmInt (fromIntegral offset) (wordWidth dflags))))+           1)++------------------------------------------------------------------+-- Showing the "type category" for ticky-ticky profiling++showTypeCategory :: Type -> Char+  {-+        +           dictionary++        >           function++        {C,I,F,D,W} char, int, float, double, word+        {c,i,f,d,w} unboxed ditto++        T           tuple++        P           other primitive type+        p           unboxed ditto++        L           list+        E           enumeration type+        S           other single-constructor type+        M           other multi-constructor data-con type++        .           other type++        -           reserved for others to mark as "uninteresting"++  Accurate as of Mar 2013, but I eliminated the Array category instead+  of updating it, for simplicity. It's in P/p, I think --NSF++    -}+showTypeCategory ty+  | isDictTy ty = '+'+  | otherwise = case tcSplitTyConApp_maybe ty of+  Nothing -> '.'+  Just (tycon, _) ->+    (if isUnliftedTyCon tycon then Data.Char.toLower else id) $+    let anyOf us = getUnique tycon `elem` us in+    case () of+      _ | anyOf [funTyConKey] -> '>'+        | anyOf [charPrimTyConKey, charTyConKey] -> 'C'+        | anyOf [doublePrimTyConKey, doubleTyConKey] -> 'D'+        | anyOf [floatPrimTyConKey, floatTyConKey] -> 'F'+        | anyOf [intPrimTyConKey, int32PrimTyConKey, int64PrimTyConKey,+                 intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey+                ] -> 'I'+        | anyOf [wordPrimTyConKey, word32PrimTyConKey, word64PrimTyConKey, wordTyConKey,+                 word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey+                ] -> 'W'+        | anyOf [listTyConKey] -> 'L'+        | isTupleTyCon tycon       -> 'T'+        | isPrimTyCon tycon        -> 'P'+        | isEnumerationTyCon tycon -> 'E'+        | isJust (tyConSingleDataCon_maybe tycon) -> 'S'+        | otherwise -> 'M' -- oh, well...
+ codeGen/StgCmmUtils.hs view
@@ -0,0 +1,620 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Code generator utilities; mostly monadic+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module StgCmmUtils (+        cgLit, mkSimpleLit,+        emitDataLits, mkDataLits,+        emitRODataLits, mkRODataLits,+        emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,+        assignTemp, newTemp,++        newUnboxedTupleRegs,++        emitMultiAssign, emitCmmLitSwitch, emitSwitch,++        tagToClosure, mkTaggedObjectLoad,++        callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,++        cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,+        cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,+        cmmOffsetExprW, cmmOffsetExprB,+        cmmRegOffW, cmmRegOffB,+        cmmLabelOffW, cmmLabelOffB,+        cmmOffsetW, cmmOffsetB,+        cmmOffsetLitW, cmmOffsetLitB,+        cmmLoadIndexW,+        cmmConstrTag1,++        cmmUntag, cmmIsTagged,++        addToMem, addToMemE, addToMemLblE, addToMemLbl,+        mkWordCLit,+        newStringCLit, newByteStringCLit,+        blankWord,+  ) where++#include "HsVersions.h"++import StgCmmMonad+import StgCmmClosure+import Cmm+import BlockId+import MkGraph+import CodeGen.Platform+import CLabel+import CmmUtils+import CmmSwitch++import ForeignCall+import IdInfo+import Type+import TyCon+import SMRep+import Module+import Literal+import Digraph+import Util+import Unique+import UniqSupply (MonadUnique(..))+import DynFlags+import FastString+import Outputable+import RepType++import qualified Data.ByteString as BS+import qualified Data.Map as M+import Data.Char+import Data.List+import Data.Ord+import Data.Word+++-------------------------------------------------------------------------+--+--      Literals+--+-------------------------------------------------------------------------++cgLit :: Literal -> FCode CmmLit+cgLit (MachStr s) = newByteStringCLit (BS.unpack s)+ -- not unpackFS; we want the UTF-8 byte stream.+cgLit other_lit   = do dflags <- getDynFlags+                       return (mkSimpleLit dflags other_lit)++mkSimpleLit :: DynFlags -> Literal -> CmmLit+mkSimpleLit dflags (MachChar   c)    = CmmInt (fromIntegral (ord c)) (wordWidth dflags)+mkSimpleLit dflags MachNullAddr      = zeroCLit dflags+mkSimpleLit dflags (MachInt i)       = CmmInt i (wordWidth dflags)+mkSimpleLit _      (MachInt64 i)     = CmmInt i W64+mkSimpleLit dflags (MachWord i)      = CmmInt i (wordWidth dflags)+mkSimpleLit _      (MachWord64 i)    = CmmInt i W64+mkSimpleLit _      (MachFloat r)     = CmmFloat r W32+mkSimpleLit _      (MachDouble r)    = CmmFloat r W64+mkSimpleLit _      (MachLabel fs ms fod)+        = CmmLabel (mkForeignLabel fs ms labelSrc fod)+        where+                -- TODO: Literal labels might not actually be in the current package...+                labelSrc = ForeignLabelInThisPackage+mkSimpleLit _ other             = pprPanic "mkSimpleLit" (ppr other)++--------------------------------------------------------------------------+--+-- Incrementing a memory location+--+--------------------------------------------------------------------------++addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph+addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n++addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph+addToMemLblE rep lbl = addToMemE rep (CmmLit (CmmLabel lbl))++addToMem :: CmmType     -- rep of the counter+         -> CmmExpr     -- Address+         -> Int         -- What to add (a word)+         -> CmmAGraph+addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) (typeWidth rep)))++addToMemE :: CmmType    -- rep of the counter+          -> CmmExpr    -- Address+          -> CmmExpr    -- What to add (a word-typed expression)+          -> CmmAGraph+addToMemE rep ptr n+  = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep, n])+++-------------------------------------------------------------------------+--+--      Loading a field from an object,+--      where the object pointer is itself tagged+--+-------------------------------------------------------------------------++mkTaggedObjectLoad+  :: DynFlags -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph+-- (loadTaggedObjectField reg base off tag) generates assignment+--      reg = bitsK[ base + off - tag ]+-- where K is fixed by 'reg'+mkTaggedObjectLoad dflags reg base offset tag+  = mkAssign (CmmLocal reg)+             (CmmLoad (cmmOffsetB dflags+                                  (CmmReg (CmmLocal base))+                                  (offset - tag))+                      (localRegType reg))++-------------------------------------------------------------------------+--+--      Converting a closure tag to a closure for enumeration types+--      (this is the implementation of tagToEnum#).+--+-------------------------------------------------------------------------++tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr+tagToClosure dflags tycon tag+  = CmmLoad (cmmOffsetExprW dflags closure_tbl tag) (bWord dflags)+  where closure_tbl = CmmLit (CmmLabel lbl)+        lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs++-------------------------------------------------------------------------+--+--      Conditionals and rts calls+--+-------------------------------------------------------------------------++emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()+emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe++emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString+        -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()+emitRtsCallWithResult res hint pkg fun args safe+   = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe++-- Make a call to an RTS C procedure+emitRtsCallGen+   :: [(LocalReg,ForeignHint)]+   -> CLabel+   -> [(CmmExpr,ForeignHint)]+   -> Bool -- True <=> CmmSafe call+   -> FCode ()+emitRtsCallGen res lbl args safe+  = do { dflags <- getDynFlags+       ; updfr_off <- getUpdFrameOff+       ; let (caller_save, caller_load) = callerSaveVolatileRegs dflags+       ; emit caller_save+       ; call updfr_off+       ; emit caller_load }+  where+    call updfr_off =+      if safe then+        emit =<< mkCmmCall fun_expr res' args' updfr_off+      else do+        let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn+        emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args'+    (args', arg_hints) = unzip args+    (res',  res_hints) = unzip res+    fun_expr = mkLblExpr lbl+++-----------------------------------------------------------------------------+--+--      Caller-Save Registers+--+-----------------------------------------------------------------------------++-- Here we generate the sequence of saves/restores required around a+-- foreign call instruction.++-- TODO: reconcile with includes/Regs.h+--  * Regs.h claims that BaseReg should be saved last and loaded first+--    * This might not have been tickled before since BaseReg is callee save+--  * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim+--+-- This code isn't actually used right now, because callerSaves+-- only ever returns true in the current universe for registers NOT in+-- system_regs (just do a grep for CALLER_SAVES in+-- includes/stg/MachRegs.h).  It's all one giant no-op, and for+-- good reason: having to save system registers on every foreign call+-- would be very expensive, so we avoid assigning them to those+-- registers when we add support for an architecture.+--+-- Note that the old code generator actually does more work here: it+-- also saves other global registers.  We can't (nor want) to do that+-- here, as we don't have liveness information.  And really, we+-- shouldn't be doing the workaround at this point in the pipeline, see+-- Note [Register parameter passing] and the ToDo on CmmCall in+-- cmm/CmmNode.hs.  Right now the workaround is to avoid inlining across+-- unsafe foreign calls in rewriteAssignments, but this is strictly+-- temporary.+callerSaveVolatileRegs :: DynFlags -> (CmmAGraph, CmmAGraph)+callerSaveVolatileRegs dflags = (caller_save, caller_load)+  where+    platform = targetPlatform dflags++    caller_save = catAGraphs (map callerSaveGlobalReg    regs_to_save)+    caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save)++    system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery+                    {- ,SparkHd,SparkTl,SparkBase,SparkLim -}+                  , BaseReg ]++    regs_to_save = filter (callerSaves platform) system_regs++    callerSaveGlobalReg reg+        = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg))++    callerRestoreGlobalReg reg+        = mkAssign (CmmGlobal reg)+                   (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType dflags reg))++-- -----------------------------------------------------------------------------+-- Global registers++-- We map STG registers onto appropriate CmmExprs.  Either they map+-- to real machine registers or stored as offsets from BaseReg.  Given+-- a GlobalReg, get_GlobalReg_addr always produces the+-- register table address for it.+-- (See also get_GlobalReg_reg_or_addr in MachRegs)++get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr+get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0+get_GlobalReg_addr dflags mid+    = get_Regtable_addr_from_offset dflags+                                    (globalRegType dflags mid) (baseRegOffset dflags mid)++-- Calculate a literal representing an offset into the register table.+-- Used when we don't have an actual BaseReg to offset from.+regTableOffset :: DynFlags -> Int -> CmmExpr+regTableOffset dflags n =+  CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n))++get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr+get_Regtable_addr_from_offset dflags _rep offset =+    if haveRegBase (targetPlatform dflags)+    then CmmRegOff (CmmGlobal BaseReg) offset+    else regTableOffset dflags offset+++-- -----------------------------------------------------------------------------+-- Information about global registers++baseRegOffset :: DynFlags -> GlobalReg -> Int++baseRegOffset dflags Sp             = oFFSET_StgRegTable_rSp dflags+baseRegOffset dflags SpLim          = oFFSET_StgRegTable_rSpLim dflags+baseRegOffset dflags (LongReg 1)    = oFFSET_StgRegTable_rL1 dflags+baseRegOffset dflags Hp             = oFFSET_StgRegTable_rHp dflags+baseRegOffset dflags HpLim          = oFFSET_StgRegTable_rHpLim dflags+baseRegOffset dflags CCCS           = oFFSET_StgRegTable_rCCCS dflags+baseRegOffset dflags CurrentTSO     = oFFSET_StgRegTable_rCurrentTSO dflags+baseRegOffset dflags CurrentNursery = oFFSET_StgRegTable_rCurrentNursery dflags+baseRegOffset dflags HpAlloc        = oFFSET_StgRegTable_rHpAlloc dflags+baseRegOffset dflags GCEnter1       = oFFSET_stgGCEnter1 dflags+baseRegOffset dflags GCFun          = oFFSET_stgGCFun dflags+baseRegOffset _      reg            = pprPanic "StgCmmUtils.baseRegOffset:" (ppr reg)++-------------------------------------------------------------------------+--+--      Strings generate a top-level data block+--+-------------------------------------------------------------------------++emitDataLits :: CLabel -> [CmmLit] -> FCode ()+-- Emit a data-segment data block+emitDataLits lbl lits = emitDecl (mkDataLits (Section Data lbl) lbl lits)++emitRODataLits :: CLabel -> [CmmLit] -> FCode ()+-- Emit a read-only data block+emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits)++newStringCLit :: String -> FCode CmmLit+-- Make a global definition for the string,+-- and return its label+newStringCLit str = newByteStringCLit (map (fromIntegral . ord) str)++newByteStringCLit :: [Word8] -> FCode CmmLit+newByteStringCLit bytes+  = do  { uniq <- newUnique+        ; let (lit, decl) = mkByteStringCLit (mkStringLitLabel uniq) bytes+        ; emitDecl decl+        ; return lit }++-------------------------------------------------------------------------+--+--      Assigning expressions to temporaries+--+-------------------------------------------------------------------------++assignTemp :: CmmExpr -> FCode LocalReg+-- Make sure the argument is in a local register.+-- We don't bother being particularly aggressive with avoiding+-- unnecessary local registers, since we can rely on a later+-- optimization pass to inline as necessary (and skipping out+-- on things like global registers can be a little dangerous+-- due to them being trashed on foreign calls--though it means+-- the optimization pass doesn't have to do as much work)+assignTemp (CmmReg (CmmLocal reg)) = return reg+assignTemp e = do { dflags <- getDynFlags+                  ; uniq <- newUnique+                  ; let reg = LocalReg uniq (cmmExprType dflags e)+                  ; emitAssign (CmmLocal reg) e+                  ; return reg }++newTemp :: MonadUnique m => CmmType -> m LocalReg+newTemp rep = do { uniq <- getUniqueM+                 ; return (LocalReg uniq rep) }++newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])+-- Choose suitable local regs to use for the components+-- of an unboxed tuple that we are about to return to+-- the Sequel.  If the Sequel is a join point, using the+-- regs it wants will save later assignments.+newUnboxedTupleRegs res_ty+  = ASSERT( isUnboxedTupleType res_ty )+    do  { dflags <- getDynFlags+        ; sequel <- getSequel+        ; regs <- choose_regs dflags sequel+        ; ASSERT( regs `equalLength` reps )+          return (regs, map primRepForeignHint reps) }+  where+    reps = typePrimRep res_ty+    choose_regs _ (AssignTo regs _) = return regs+    choose_regs dflags _            = mapM (newTemp . primRepCmmType dflags) reps++++-------------------------------------------------------------------------+--      emitMultiAssign+-------------------------------------------------------------------------++emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode ()+-- Emit code to perform the assignments in the+-- input simultaneously, using temporary variables when necessary.++type Key  = Int+type Vrtx = (Key, Stmt) -- Give each vertex a unique number,+                        -- for fast comparison+type Stmt = (LocalReg, CmmExpr) -- r := e++-- We use the strongly-connected component algorithm, in which+--      * the vertices are the statements+--      * an edge goes from s1 to s2 iff+--              s1 assigns to something s2 uses+--        that is, if s1 should *follow* s2 in the final order++emitMultiAssign []    []    = return ()+emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs+emitMultiAssign regs rhss   = do+  dflags <- getDynFlags+  ASSERT2( equalLength regs rhss, ppr regs $$ ppr rhss )+    unscramble dflags ([1..] `zip` (regs `zip` rhss))++unscramble :: DynFlags -> [Vrtx] -> FCode ()+unscramble dflags vertices = mapM_ do_component components+  where+        edges :: [ (Vrtx, Key, [Key]) ]+        edges = [ (vertex, key1, edges_from stmt1)+                | vertex@(key1, stmt1) <- vertices ]++        edges_from :: Stmt -> [Key]+        edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,+                                    stmt1 `mustFollow` stmt2 ]++        components :: [SCC Vrtx]+        components = stronglyConnCompFromEdgedVerticesUniq edges++        -- do_components deal with one strongly-connected component+        -- Not cyclic, or singleton?  Just do it+        do_component :: SCC Vrtx -> FCode ()+        do_component (AcyclicSCC (_,stmt))  = mk_graph stmt+        do_component (CyclicSCC [])         = panic "do_component"+        do_component (CyclicSCC [(_,stmt)]) = mk_graph stmt++                -- Cyclic?  Then go via temporaries.  Pick one to+                -- break the loop and try again with the rest.+        do_component (CyclicSCC ((_,first_stmt) : rest)) = do+            dflags <- getDynFlags+            u <- newUnique+            let (to_tmp, from_tmp) = split dflags u first_stmt+            mk_graph to_tmp+            unscramble dflags rest+            mk_graph from_tmp++        split :: DynFlags -> Unique -> Stmt -> (Stmt, Stmt)+        split dflags uniq (reg, rhs)+          = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp)))+          where+            rep = cmmExprType dflags rhs+            tmp = LocalReg uniq rep++        mk_graph :: Stmt -> FCode ()+        mk_graph (reg, rhs) = emitAssign (CmmLocal reg) rhs++        mustFollow :: Stmt -> Stmt -> Bool+        (reg, _) `mustFollow` (_, rhs) = regUsedIn dflags (CmmLocal reg) rhs++-------------------------------------------------------------------------+--      mkSwitch+-------------------------------------------------------------------------+++emitSwitch :: CmmExpr                      -- Tag to switch on+           -> [(ConTagZ, CmmAGraphScoped)] -- Tagged branches+           -> Maybe CmmAGraphScoped        -- Default branch (if any)+           -> ConTagZ -> ConTagZ           -- Min and Max possible values;+                                           -- behaviour outside this range is+                                           -- undefined+           -> FCode ()++-- First, two rather common cases in which there is no work to do+emitSwitch _ []         (Just code) _ _ = emit (fst code)+emitSwitch _ [(_,code)] Nothing     _ _ = emit (fst code)++-- Right, off we go+emitSwitch tag_expr branches mb_deflt lo_tag hi_tag = do+    join_lbl      <- newBlockId+    mb_deflt_lbl  <- label_default join_lbl mb_deflt+    branches_lbls <- label_branches join_lbl branches+    tag_expr'     <- assignTemp' tag_expr++    -- Sort the branches before calling mk_discrete_switch+    let branches_lbls' = [ (fromIntegral i, l) | (i,l) <- sortBy (comparing fst) branches_lbls ]+    let range = (fromIntegral lo_tag, fromIntegral hi_tag)++    emit $ mk_discrete_switch False tag_expr' branches_lbls' mb_deflt_lbl range++    emitLabel join_lbl++mk_discrete_switch :: Bool -- ^ Use signed comparisons+          -> CmmExpr+          -> [(Integer, BlockId)]+          -> Maybe BlockId+          -> (Integer, Integer)+          -> CmmAGraph++-- SINGLETON TAG RANGE: no case analysis to do+mk_discrete_switch _ _tag_expr [(tag, lbl)] _ (lo_tag, hi_tag)+  | lo_tag == hi_tag+  = ASSERT( tag == lo_tag )+    mkBranch lbl++-- SINGLETON BRANCH, NO DEFAULT: no case analysis to do+mk_discrete_switch _ _tag_expr [(_tag,lbl)] Nothing _+  = mkBranch lbl+        -- The simplifier might have eliminated a case+        --       so we may have e.g. case xs of+        --                               [] -> e+        -- In that situation we can be sure the (:) case+        -- can't happen, so no need to test++-- SOMETHING MORE COMPLICATED: defer to CmmImplementSwitchPlans+-- See Note [Cmm Switches, the general plan] in CmmSwitch+mk_discrete_switch signed tag_expr branches mb_deflt range+  = mkSwitch tag_expr $ mkSwitchTargets signed range mb_deflt (M.fromList branches)++divideBranches :: Ord a => [(a,b)] -> ([(a,b)], a, [(a,b)])+divideBranches branches = (lo_branches, mid, hi_branches)+  where+    -- 2 branches => n_branches `div` 2 = 1+    --            => branches !! 1 give the *second* tag+    -- There are always at least 2 branches here+    (mid,_) = branches !! (length branches `div` 2)+    (lo_branches, hi_branches) = span is_lo branches+    is_lo (t,_) = t < mid++--------------+emitCmmLitSwitch :: CmmExpr                    -- Tag to switch on+               -> [(Literal, CmmAGraphScoped)] -- Tagged branches+               -> CmmAGraphScoped              -- Default branch (always)+               -> FCode ()                     -- Emit the code+emitCmmLitSwitch _scrut []       deflt = emit $ fst deflt+emitCmmLitSwitch scrut  branches deflt = do+    scrut' <- assignTemp' scrut+    join_lbl <- newBlockId+    deflt_lbl <- label_code join_lbl deflt+    branches_lbls <- label_branches join_lbl branches++    dflags <- getDynFlags+    let cmm_ty = cmmExprType dflags scrut+        rep = typeWidth cmm_ty++    -- We find the necessary type information in the literals in the branches+    let signed = case head branches of+                    (MachInt _, _) ->   True+                    (MachInt64 _, _) -> True+                    _ -> False++    let range | signed    = (tARGET_MIN_INT dflags, tARGET_MAX_INT dflags)+              | otherwise = (0, tARGET_MAX_WORD dflags)++    if isFloatType cmm_ty+    then emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls+    else emit $ mk_discrete_switch+        signed+        scrut'+        [(litValue lit,l) | (lit,l) <- branches_lbls]+        (Just deflt_lbl)+        range+    emitLabel join_lbl++-- | lower bound (inclusive), upper bound (exclusive)+type LitBound = (Maybe Literal, Maybe Literal)++noBound :: LitBound+noBound = (Nothing, Nothing)++mk_float_switch :: Width -> CmmExpr -> BlockId+              -> LitBound+              -> [(Literal,BlockId)]+              -> FCode CmmAGraph+mk_float_switch rep scrut deflt _bounds [(lit,blk)]+  = do dflags <- getDynFlags+       return $ mkCbranch (cond dflags) deflt blk Nothing+  where+    cond dflags = CmmMachOp ne [scrut, CmmLit cmm_lit]+      where+        cmm_lit = mkSimpleLit dflags lit+        ne      = MO_F_Ne rep++mk_float_switch rep scrut deflt_blk_id (lo_bound, hi_bound) branches+  = do dflags <- getDynFlags+       lo_blk <- mk_float_switch rep scrut deflt_blk_id bounds_lo lo_branches+       hi_blk <- mk_float_switch rep scrut deflt_blk_id bounds_hi hi_branches+       mkCmmIfThenElse (cond dflags) lo_blk hi_blk+  where+    (lo_branches, mid_lit, hi_branches) = divideBranches branches++    bounds_lo = (lo_bound, Just mid_lit)+    bounds_hi = (Just mid_lit, hi_bound)++    cond dflags = CmmMachOp lt [scrut, CmmLit cmm_lit]+      where+        cmm_lit = mkSimpleLit dflags mid_lit+        lt      = MO_F_Lt rep+++--------------+label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId)+label_default _ Nothing+  = return  Nothing+label_default join_lbl (Just code)+  = do lbl <- label_code join_lbl code+       return (Just lbl)++--------------+label_branches :: BlockId -> [(a,CmmAGraphScoped)] -> FCode [(a,BlockId)]+label_branches _join_lbl []+  = return []+label_branches join_lbl ((tag,code):branches)+  = do lbl <- label_code join_lbl code+       branches' <- label_branches join_lbl branches+       return ((tag,lbl):branches')++--------------+label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId+--  label_code J code+--      generates+--  [L: code; goto J]+-- and returns L+label_code join_lbl (code,tsc) = do+    lbl <- newBlockId+    emitOutOfLine lbl (code MkGraph.<*> mkBranch join_lbl, tsc)+    return lbl++--------------+assignTemp' :: CmmExpr -> FCode CmmExpr+assignTemp' e+  | isTrivialCmmExpr e = return e+  | otherwise = do+       dflags <- getDynFlags+       lreg <- newTemp (cmmExprType dflags e)+       let reg = CmmLocal lreg+       emitAssign reg e+       return (CmmReg reg)
+ coreSyn/CoreArity.hs view
@@ -0,0 +1,1200 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++        Arity and eta expansion+-}++{-# LANGUAGE CPP #-}++-- | Arity and eta expansion+module CoreArity (+        manifestArity, joinRhsArity, exprArity, typeArity,+        exprEtaExpandArity, findRhsArity, CheapFun, etaExpand,+        etaExpandToJoinPoint, etaExpandToJoinPointRule,+        exprBotStrictness_maybe+    ) where++#include "HsVersions.h"++import CoreSyn+import CoreFVs+import CoreUtils+import CoreSubst+import Demand+import Var+import VarEnv+import Id+import Type+import TyCon    ( initRecTc, checkRecTc )+import Coercion+import BasicTypes+import Unique+import DynFlags ( DynFlags, GeneralFlag(..), gopt )+import Outputable+import FastString+import Pair+import Util     ( debugIsOn )++{-+************************************************************************+*                                                                      *+              manifestArity and exprArity+*                                                                      *+************************************************************************++exprArity is a cheap-and-cheerful version of exprEtaExpandArity.+It tells how many things the expression can be applied to before doing+any work.  It doesn't look inside cases, lets, etc.  The idea is that+exprEtaExpandArity will do the hard work, leaving something that's easy+for exprArity to grapple with.  In particular, Simplify uses exprArity to+compute the ArityInfo for the Id.++Originally I thought that it was enough just to look for top-level lambdas, but+it isn't.  I've seen this++        foo = PrelBase.timesInt++We want foo to get arity 2 even though the eta-expander will leave it+unchanged, in the expectation that it'll be inlined.  But occasionally it+isn't, because foo is blacklisted (used in a rule).++Similarly, see the ok_note check in exprEtaExpandArity.  So+        f = __inline_me (\x -> e)+won't be eta-expanded.++And in any case it seems more robust to have exprArity be a bit more intelligent.+But note that   (\x y z -> f x y z)+should have arity 3, regardless of f's arity.+-}++manifestArity :: CoreExpr -> Arity+-- ^ manifestArity sees how many leading value lambdas there are,+--   after looking through casts+manifestArity (Lam v e) | isId v        = 1 + manifestArity e+                        | otherwise     = manifestArity e+manifestArity (Tick t e) | not (tickishIsCode t) =  manifestArity e+manifestArity (Cast e _)                = manifestArity e+manifestArity _                         = 0++joinRhsArity :: CoreExpr -> JoinArity+-- Join points are supposed to have manifestly-visible+-- lambdas at the top: no ticks, no casts, nothing+-- Moreover, type lambdas count in JoinArity+joinRhsArity (Lam _ e) = 1 + joinRhsArity e+joinRhsArity _         = 0+++---------------+exprArity :: CoreExpr -> Arity+-- ^ An approximate, fast, version of 'exprEtaExpandArity'+exprArity e = go e+  where+    go (Var v)                     = idArity v+    go (Lam x e) | isId x          = go e + 1+                 | otherwise       = go e+    go (Tick t e) | not (tickishIsCode t) = go e+    go (Cast e co)                 = trim_arity (go e) (pSnd (coercionKind co))+                                        -- Note [exprArity invariant]+    go (App e (Type _))            = go e+    go (App f a) | exprIsTrivial a = (go f - 1) `max` 0+        -- See Note [exprArity for applications]+        -- NB: coercions count as a value argument++    go _                           = 0++    trim_arity :: Arity -> Type -> Arity+    trim_arity arity ty = arity `min` length (typeArity ty)++---------------+typeArity :: Type -> [OneShotInfo]+-- How many value arrows are visible in the type?+-- We look through foralls, and newtypes+-- See Note [exprArity invariant]+typeArity ty+  = go initRecTc ty+  where+    go rec_nts ty+      | Just (_, ty')  <- splitForAllTy_maybe ty+      = go rec_nts ty'++      | Just (arg,res) <- splitFunTy_maybe ty+      = typeOneShot arg : go rec_nts res++      | Just (tc,tys) <- splitTyConApp_maybe ty+      , Just (ty', _) <- instNewTyCon_maybe tc tys+      , Just rec_nts' <- checkRecTc rec_nts tc  -- See Note [Expanding newtypes]+                                                -- in TyCon+--   , not (isClassTyCon tc)    -- Do not eta-expand through newtype classes+--                              -- See Note [Newtype classes and eta expansion]+--                              (no longer required)+      = go rec_nts' ty'+        -- Important to look through non-recursive newtypes, so that, eg+        --      (f x)   where f has arity 2, f :: Int -> IO ()+        -- Here we want to get arity 1 for the result!+        --+        -- AND through a layer of recursive newtypes+        -- e.g. newtype Stream m a b = Stream (m (Either b (a, Stream m a b)))++      | otherwise+      = []++---------------+exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig)+-- A cheap and cheerful function that identifies bottoming functions+-- and gives them a suitable strictness signatures.  It's used during+-- float-out+exprBotStrictness_maybe e+  = case getBotArity (arityType env e) of+        Nothing -> Nothing+        Just ar -> Just (ar, sig ar)+  where+    env    = AE { ae_ped_bot = True, ae_cheap_fn = \ _ _ -> False }+    sig ar = mkClosedStrictSig (replicate ar topDmd) exnRes+                  -- For this purpose we can be very simple+                  -- exnRes is a bit less aggressive than botRes++{-+Note [exprArity invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~+exprArity has the following invariant:++  (1) If typeArity (exprType e) = n,+      then manifestArity (etaExpand e n) = n++      That is, etaExpand can always expand as much as typeArity says+      So the case analysis in etaExpand and in typeArity must match++  (2) exprArity e <= typeArity (exprType e)++  (3) Hence if (exprArity e) = n, then manifestArity (etaExpand e n) = n++      That is, if exprArity says "the arity is n" then etaExpand really+      can get "n" manifest lambdas to the top.++Why is this important?  Because+  - In TidyPgm we use exprArity to fix the *final arity* of+    each top-level Id, and in+  - In CorePrep we use etaExpand on each rhs, so that the visible lambdas+    actually match that arity, which in turn means+    that the StgRhs has the right number of lambdas++An alternative would be to do the eta-expansion in TidyPgm, at least+for top-level bindings, in which case we would not need the trim_arity+in exprArity.  That is a less local change, so I'm going to leave it for today!++Note [Newtype classes and eta expansion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    NB: this nasty special case is no longer required, because+    for newtype classes we don't use the class-op rule mechanism+    at all.  See Note [Single-method classes] in TcInstDcls. SLPJ May 2013++-------- Old out of date comments, just for interest -----------+We have to be careful when eta-expanding through newtypes.  In general+it's a good idea, but annoyingly it interacts badly with the class-op+rule mechanism.  Consider++   class C a where { op :: a -> a }+   instance C b => C [b] where+     op x = ...++These translate to++   co :: forall a. (a->a) ~ C a++   $copList :: C b -> [b] -> [b]+   $copList d x = ...++   $dfList :: C b -> C [b]+   {-# DFunUnfolding = [$copList] #-}+   $dfList d = $copList d |> co@[b]++Now suppose we have:++   dCInt :: C Int++   blah :: [Int] -> [Int]+   blah = op ($dfList dCInt)++Now we want the built-in op/$dfList rule will fire to give+   blah = $copList dCInt++But with eta-expansion 'blah' might (and in Trac #3772, which is+slightly more complicated, does) turn into++   blah = op (\eta. ($dfList dCInt |> sym co) eta)++and now it is *much* harder for the op/$dfList rule to fire, because+exprIsConApp_maybe won't hold of the argument to op.  I considered+trying to *make* it hold, but it's tricky and I gave up.++The test simplCore/should_compile/T3722 is an excellent example.+-------- End of old out of date comments, just for interest -----------+++Note [exprArity for applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we come to an application we check that the arg is trivial.+   eg  f (fac x) does not have arity 2,+                 even if f has arity 3!++* We require that is trivial rather merely cheap.  Suppose f has arity 2.+  Then    f (Just y)+  has arity 0, because if we gave it arity 1 and then inlined f we'd get+          let v = Just y in \w. <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 divegent case, no work is lost by duplicating because if the thing+is evaluated once, that's the end of the program.++Or, to put it another way, in any context C++   C[ (\x1 .. xn. e x1 .. xn) ]+         is as efficient as+   C[ e ]++It's all a bit more subtle than it looks:++Note [One-shot lambdas]+~~~~~~~~~~~~~~~~~~~~~~~+Consider one-shot lambdas+                let x = expensive in \y z -> E+We want this to have arity 1 if the \y-abstraction is a 1-shot lambda.++Note [Dealing with bottom]+~~~~~~~~~~~~~~~~~~~~~~~~~~+A Big Deal with computing arities is expressions like++   f = \x -> case x of+               True  -> \s -> e1+               False -> \s -> e2++This happens all the time when f :: Bool -> IO ()+In this case we do eta-expand, in order to get that \s to the+top, and give f arity 2.++This isn't really right in the presence of seq.  Consider+        (f bot) `seq` 1++This should diverge!  But if we eta-expand, it won't.  We ignore this+"problem" (unless -fpedantic-bottoms is on), because being scrupulous+would lose an important transformation for many programs. (See+Trac #5587 for an example.)++Consider also+        f = \x -> error "foo"+Here, arity 1 is fine.  But if it is+        f = \x -> case x of+                        True  -> error "foo"+                        False -> \y -> x+y+then we want to get arity 2.  Technically, this isn't quite right, because+        (f True) `seq` 1+should diverge, but it'll converge if we eta-expand f.  Nevertheless, we+do so; it improves some programs significantly, and increasing convergence+isn't a bad thing.  Hence the ABot/ATop in ArityType.++So these two transformations aren't always the Right Thing, and we+have several tickets reporting unexpected bahaviour resulting from+this transformation.  So we try to limit it as much as possible:++ (1) Do NOT move a lambda outside a known-bottom case expression+       case undefined of { (a,b) -> \y -> e }+     This showed up in Trac #5557++ (2) Do NOT move a lambda outside a case if all the branches of+     the case are known to return bottom.+        case x of { (a,b) -> \y -> error "urk" }+     This case is less important, but the idea is that if the fn is+     going to diverge eventually anyway then getting the best arity+     isn't an issue, so we might as well play safe++ (3) Do NOT move a lambda outside a case unless+     (a) The scrutinee is ok-for-speculation, or+     (b) more liberally: the scrutinee is cheap (e.g. a variable), and+         -fpedantic-bottoms is not enforced (see Trac #2915 for an example)++Of course both (1) and (2) are readily defeated by disguising the bottoms.++4. Note [Newtype arity]+~~~~~~~~~~~~~~~~~~~~~~~~+Non-recursive newtypes are transparent, and should not get in the way.+We do (currently) eta-expand recursive newtypes too.  So if we have, say++        newtype T = MkT ([T] -> Int)++Suppose we have+        e = coerce T f+where f has arity 1.  Then: etaExpandArity e = 1;+that is, etaExpandArity looks through the coerce.++When we eta-expand e to arity 1: eta_expand 1 e T+we want to get:                  coerce T (\x::[T] -> (coerce ([T]->Int) e) x)++  HOWEVER, note that if you use coerce bogusly you can ge+        coerce Int negate+  And since negate has arity 2, you might try to eta expand.  But you can't+  decopose Int to a function type.   Hence the final case in eta_expand.++Note [The state-transformer hack]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+        f = e+where e has arity n.  Then, if we know from the context that f has+a usage type like+        t1 -> ... -> tn -1-> t(n+1) -1-> ... -1-> tm -> ...+then we can expand the arity to m.  This usage type says that+any application (x e1 .. en) will be applied to uniquely to (m-n) more args+Consider f = \x. let y = <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 (Trac #2861):++  f :: String -> IO T+  f = \p. error "..."++Eta-expand, using the state hack:++  f = \p. (\s. ((error "...") |> g1) s) |> g2+  g1 :: IO T ~ (S -> (S,T))+  g2 :: (S -> (S,T)) ~ IO T++Extrude the g2++  f' = \p. \s. ((error "...") |> g1) s+  f = f' |> (String -> g2)++Discard args for bottomming function++  f' = \p. \s. ((error "...") |> g1 |> g3+  g3 :: (S -> (S,T)) ~ (S,T)++Extrude g1.g3++  f'' = \p. \s. (error "...")+  f' = f'' |> (String -> S -> g1.g3)++And now we can repeat the whole loop.  Aargh!  The bug is in applying the+state hack to a function which then swallows the argument.++This arose in another guise in Trac #3959.  Here we had++     catch# (throw exn >> return ())++Note that (throw :: forall a e. Exn e => e -> a) is called with [a = IO ()].+After inlining (>>) we get++     catch# (\_. throw {IO ()} exn)++We must *not* eta-expand to++     catch# (\_ _. throw {...} exn)++because 'catch#' expects to get a (# _,_ #) after applying its argument to+a State#, not another function!++In short, we use the state hack to allow us to push let inside a lambda,+but not to introduce a new lambda.+++Note [ArityType]+~~~~~~~~~~~~~~~~+ArityType is the result of a compositional analysis on expressions,+from which we can decide the real arity of the expression (extracted+with function exprEtaExpandArity).++Here is what the fields mean. If an arbitrary expression 'f' has+ArityType 'at', then++ * If at = ABot n, then (f x1..xn) definitely diverges. Partial+   applications to fewer than n args may *or may not* diverge.++   We allow ourselves to eta-expand bottoming functions, even+   if doing so may lose some `seq` sharing,+       let x = <expensive> in \y. error (g x y)+       ==> \y. let x = <expensive> in error (g x y)++ * If at = ATop as, and n=length as,+   then expanding 'f' to (\x1..xn. f x1 .. xn) loses no sharing,+   assuming the calls of f respect the one-shot-ness of+   its definition.++   NB 'f' is an arbitrary expression, eg (f = g e1 e2).  This 'f'+   can have ArityType as ATop, with length as > 0, only if e1 e2 are+   themselves.++ * In both cases, f, (f x1), ... (f x1 ... f(n-1)) are definitely+   really functions, or bottom, but *not* casts from a data type, in+   at least one case branch.  (If it's a function in one case branch but+   an unsafe cast from a data type in another, the program is bogus.)+   So eta expansion is dynamically ok; see Note [State hack and+   bottoming functions], the part about catch#++Example:+      f = \x\y. let v = <expensive> in+          \s(one-shot) \t(one-shot). blah+      'f' has ArityType [ManyShot,ManyShot,OneShot,OneShot]+      The one-shot-ness means we can, in effect, push that+      'let' inside the \st.+++Suppose f = \xy. x+y+Then  f             :: AT [False,False] ATop+      f v           :: AT [False]       ATop+      f <expensive> :: AT []            ATop++-------------------- Main arity code ----------------------------+-}++-- See Note [ArityType]+data ArityType = ATop [OneShotInfo] | ABot Arity+     -- There is always an explicit lambda+     -- to justify the [OneShot], or the Arity++vanillaArityType :: ArityType+vanillaArityType = ATop []      -- Totally uninformative++-- ^ The Arity returned is the number of value args the+-- expression can be applied to without doing much work+exprEtaExpandArity :: DynFlags -> CoreExpr -> Arity+-- exprEtaExpandArity is used when eta expanding+--      e  ==>  \xy -> e x y+exprEtaExpandArity dflags e+  = case (arityType env e) of+      ATop oss -> length oss+      ABot n   -> n+  where+    env = AE { ae_cheap_fn = mk_cheap_fn dflags isCheapApp+             , ae_ped_bot  = gopt Opt_PedanticBottoms dflags }++getBotArity :: ArityType -> Maybe Arity+-- Arity of a divergent function+getBotArity (ABot n) = Just n+getBotArity _        = Nothing++mk_cheap_fn :: DynFlags -> CheapAppFun -> CheapFun+mk_cheap_fn dflags cheap_app+  | not (gopt Opt_DictsCheap dflags)+  = \e _     -> exprIsOk cheap_app e+  | otherwise+  = \e mb_ty -> exprIsOk cheap_app e+             || case mb_ty of+                  Nothing -> False+                  Just ty -> isDictLikeTy ty+++----------------------+findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> Arity+-- This implements the fixpoint loop for arity analysis+-- See Note [Arity analysis]+findRhsArity dflags bndr rhs old_arity+  = go (rhsEtaExpandArity dflags init_cheap_app rhs)+       -- We always call exprEtaExpandArity once, but usually+       -- that produces a result equal to old_arity, and then+       -- we stop right away (since arities should not decrease)+       -- Result: the common case is that there is just one iteration+  where+    init_cheap_app :: CheapAppFun+    init_cheap_app fn n_val_args+      | fn == bndr = True   -- On the first pass, this binder gets infinite arity+      | otherwise  = isCheapApp fn n_val_args++    go :: Arity -> Arity+    go cur_arity+      | cur_arity <= old_arity = cur_arity+      | new_arity == cur_arity = cur_arity+      | otherwise = ASSERT( new_arity < cur_arity )+#ifdef DEBUG+                    pprTrace "Exciting arity"+                       (vcat [ ppr bndr <+> ppr cur_arity <+> ppr new_arity+                                                    , ppr rhs])+#endif+                    go new_arity+      where+        new_arity = rhsEtaExpandArity dflags cheap_app rhs++        cheap_app :: CheapAppFun+        cheap_app fn n_val_args+          | fn == bndr = n_val_args < cur_arity+          | otherwise  = isCheapApp fn n_val_args++-- ^ The Arity returned is the number of value args the+-- expression can be applied to without doing much work+rhsEtaExpandArity :: DynFlags -> CheapAppFun -> CoreExpr -> Arity+-- exprEtaExpandArity is used when eta expanding+--      e  ==>  \xy -> e x y+rhsEtaExpandArity dflags cheap_app e+  = case (arityType env e) of+      ATop (os:oss)+        | isOneShotInfo os || has_lam e -> 1 + length oss+                                   -- Don't expand PAPs/thunks+                                   -- Note [Eta expanding thunks]+        | otherwise       -> 0+      ATop []             -> 0+      ABot n              -> n+  where+    env = AE { ae_cheap_fn = mk_cheap_fn dflags cheap_app+             , ae_ped_bot  = gopt Opt_PedanticBottoms dflags }++    has_lam (Tick _ e) = has_lam e+    has_lam (Lam b e)  = isId b || has_lam e+    has_lam _          = False++{-+Note [Arity analysis]+~~~~~~~~~~~~~~~~~~~~~+The motivating example for arity analysis is this:++  f = \x. let g = f (x+1)+          in \y. ...g...++What arity does f have?  Really it should have arity 2, but a naive+look at the RHS won't see that.  You need a fixpoint analysis which+says it has arity "infinity" the first time round.++This example happens a lot; it first showed up in Andy Gill's thesis,+fifteen years ago!  It also shows up in the code for 'rnf' on lists+in Trac #4138.++The analysis is easy to achieve because exprEtaExpandArity takes an+argument+     type CheapFun = CoreExpr -> Maybe Type -> Bool+used to decide if an expression is cheap enough to push inside a+lambda.  And exprIsCheap' in turn takes an argument+     type CheapAppFun = Id -> Int -> Bool+which tells when an application is cheap. This makes it easy to+write the analysis loop.++The analysis is cheap-and-cheerful because it doesn't deal with+mutual recursion.  But the self-recursive case is the important one.+++Note [Eta expanding through dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the experimental -fdicts-cheap flag is on, we eta-expand through+dictionary bindings.  This improves arities. Thereby, it also+means that full laziness is less prone to floating out the+application of a function to its dictionary arguments, which+can thereby lose opportunities for fusion.  Example:+        foo :: Ord a => a -> ...+     foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). ....+        -- So foo has arity 1++     f = \x. foo dInt $ bar x++The (foo DInt) is floated out, and makes ineffective a RULE+     foo (bar x) = ...++One could go further and make exprIsCheap reply True to any+dictionary-typed expression, but that's more work.++See Note [Dictionary-like types] in TcType.hs for why we use+isDictLikeTy here rather than isDictTy++Note [Eta expanding thunks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don't eta-expand+   * Trivial RHSs     x = y+   * PAPs             x = map g+   * Thunks           f = case y of p -> \x -> blah++When we see+     f = case y of p -> \x -> blah+should we eta-expand it? Well, if 'x' is a one-shot state token+then 'yes' because 'f' will only be applied once.  But otherwise+we (conservatively) say no.  My main reason is to avoid expanding+PAPSs+        f = g d  ==>  f = \x. g d x+because that might in turn make g inline (if it has an inline pragma),+which we might not want.  After all, INLINE pragmas say "inline only+when saturated" so we don't want to be too gung-ho about saturating!+-}++arityLam :: Id -> ArityType -> ArityType+arityLam id (ATop as) = ATop (idStateHackOneShotInfo id : as)+arityLam _  (ABot n)  = ABot (n+1)++floatIn :: Bool -> ArityType -> ArityType+-- We have something like (let x = E in b),+-- where b has the given arity type.+floatIn _     (ABot n)  = ABot n+floatIn True  (ATop as) = ATop as+floatIn False (ATop as) = ATop (takeWhile isOneShotInfo as)+   -- If E is not cheap, keep arity only for one-shots++arityApp :: ArityType -> Bool -> ArityType+-- Processing (fun arg) where at is the ArityType of fun,+-- Knock off an argument and behave like 'let'+arityApp (ABot 0)      _     = ABot 0+arityApp (ABot n)      _     = ABot (n-1)+arityApp (ATop [])     _     = ATop []+arityApp (ATop (_:as)) cheap = floatIn cheap (ATop as)++andArityType :: ArityType -> ArityType -> ArityType   -- Used for branches of a 'case'+andArityType (ABot n1) (ABot n2)  = ABot (n1 `max` n2) -- Note [ABot branches: use max]+andArityType (ATop as)  (ABot _)  = ATop as+andArityType (ABot _)   (ATop bs) = ATop bs+andArityType (ATop as)  (ATop bs) = ATop (as `combine` bs)+  where      -- See Note [Combining case branches]+    combine (a:as) (b:bs) = (a `bestOneShot` b) : combine as bs+    combine []     bs     = takeWhile isOneShotInfo bs+    combine as     []     = takeWhile isOneShotInfo as++{- Note [ABot branches: use max]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider   case x of+             True  -> \x.  error "urk"+             False -> \xy. error "urk2"++Remember: ABot n means "if you apply to n args, it'll definitely diverge".+So we need (ABot 2) for the whole thing, the /max/ of the ABot arities.++Note [Combining case branches]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  go = \x. let z = go e0+               go2 = \x. case x of+                           True  -> z+                           False -> \s(one-shot). e1+           in go2 x+We *really* want to eta-expand go and go2.+When combining the barnches of the case we have+     ATop [] `andAT` ATop [OneShotLam]+and we want to get ATop [OneShotLam].  But if the inner+lambda wasn't one-shot we don't want to do this.+(We need a proper arity analysis to justify that.)++So we combine the best of the two branches, on the (slightly dodgy)+basis that if we know one branch is one-shot, then they all must be.+-}++---------------------------+type CheapFun = CoreExpr -> Maybe Type -> Bool+        -- How to decide if an expression is cheap+        -- If the Maybe is Just, the type is the type+        -- of the expression; Nothing means "don't know"++data ArityEnv+  = AE { ae_cheap_fn :: CheapFun+       , ae_ped_bot  :: Bool       -- True <=> be pedantic about bottoms+  }++arityType :: ArityEnv -> CoreExpr -> ArityType++arityType env (Cast e co)+  = case arityType env e of+      ATop os -> ATop (take co_arity os)+      ABot n  -> ABot (n `min` co_arity)+  where+    co_arity = length (typeArity (pSnd (coercionKind co)))+    -- See Note [exprArity invariant] (2); must be true of+    -- arityType too, since that is how we compute the arity+    -- of variables, and they in turn affect result of exprArity+    -- Trac #5441 is a nice demo+    -- However, do make sure that ATop -> ATop and ABot -> ABot!+    --   Casts don't affect that part. Getting this wrong provoked #5475++arityType _ (Var v)+  | strict_sig <- idStrictness v+  , not $ isTopSig strict_sig+  , (ds, res) <- splitStrictSig strict_sig+  , let arity = length ds+  = if isBotRes res then ABot arity+                    else ATop (take arity one_shots)+  | otherwise+  = ATop (take (idArity v) one_shots)+  where+    one_shots :: [OneShotInfo]  -- One-shot-ness derived from the type+    one_shots = typeArity (idType v)++        -- Lambdas; increase arity+arityType env (Lam x e)+  | isId x    = arityLam x (arityType env e)+  | otherwise = arityType env e++        -- Applications; decrease arity, except for types+arityType env (App fun (Type _))+   = arityType env fun+arityType env (App fun arg )+   = arityApp (arityType env fun) (ae_cheap_fn env arg Nothing)++        -- Case/Let; keep arity if either the expression is cheap+        -- or it's a 1-shot lambda+        -- The former is not really right for Haskell+        --      f x = case x of { (a,b) -> \y. e }+        --  ===>+        --      f x y = case x of { (a,b) -> e }+        -- The difference is observable using 'seq'+        --+arityType env (Case scrut _ _ alts)+  | exprIsBottom scrut || null alts+  = ABot 0     -- Do not eta expand+               -- See Note [Dealing with bottom (1)]+  | otherwise+  = case alts_type of+     ABot n  | n>0       -> ATop []    -- Don't eta expand+             | otherwise -> ABot 0     -- if RHS is bottomming+                                       -- See Note [Dealing with bottom (2)]++     ATop as | not (ae_ped_bot env)    -- See Note [Dealing with bottom (3)]+             , ae_cheap_fn env scrut Nothing -> ATop as+             | exprOkForSpeculation scrut    -> ATop as+             | otherwise                     -> ATop (takeWhile isOneShotInfo as)+  where+    alts_type = foldr1 andArityType [arityType env rhs | (_,_,rhs) <- alts]++arityType env (Let b e)+  = floatIn (cheap_bind b) (arityType env e)+  where+    cheap_bind (NonRec b e) = is_cheap (b,e)+    cheap_bind (Rec prs)    = all is_cheap prs+    is_cheap (b,e) = ae_cheap_fn env e (Just (idType b))++arityType env (Tick t e)+  | not (tickishIsCode t)     = arityType env e++arityType _ _ = vanillaArityType++{-+%************************************************************************+%*                                                                      *+              The main eta-expander+%*                                                                      *+%************************************************************************++We go for:+   f = \x1..xn -> N  ==>   f = \x1..xn y1..ym -> N y1..ym+                                 (n >= 0)++where (in both cases)++        * The xi can include type variables++        * The yi are all value variables++        * N is a NORMAL FORM (i.e. no redexes anywhere)+          wanting a suitable number of extra args.++The biggest reason for doing this is for cases like++        f = \x -> case x of+                    True  -> \y -> e1+                    False -> \y -> e2++Here we want to get the lambdas together.  A good example is the nofib+program fibheaps, which gets 25% more allocation if you don't do this+eta-expansion.++We may have to sandwich some coerces between the lambdas+to make the types work.   exprEtaExpandArity looks through coerces+when computing arity; and etaExpand adds the coerces as necessary when+actually computing the expansion.++Note [No crap in eta-expanded code]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The eta expander is careful not to introduce "crap".  In particular,+given a CoreExpr satisfying the 'CpeRhs' invariant (in CorePrep), it+returns a CoreExpr satisfying the same invariant. See Note [Eta+expansion and the CorePrep invariants] in CorePrep.++This means the eta-expander has to do a bit of on-the-fly+simplification but it's not too hard.  The alernative, of relying on+a subsequent clean-up phase of the Simplifier to de-crapify the result,+means you can't really use it in CorePrep, which is painful.++Note [Eta expansion and SCCs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note that SCCs are not treated specially by etaExpand.  If we have+        etaExpand 2 (\x -> scc "foo" e)+        = (\xy -> (scc "foo" e) y)+So the costs of evaluating 'e' (not 'e y') are attributed to "foo"++Note [Eta expansion and source notes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+CorePrep puts floatable ticks outside of value applications, but not+type applications. As a result we might be trying to eta-expand an+expression like++  (src<...> v) @a++which we want to lead to code like++  \x -> src<...> v @a x++This means that we need to look through type applications and be ready+to re-add floats on the top.++-}++-- | @etaExpand n e@ returns an expression with+-- the same meaning as @e@, but with arity @n@.+--+-- Given:+--+-- > e' = etaExpand n e+--+-- We should have that:+--+-- > ty = exprType e = exprType e'+etaExpand :: Arity              -- ^ Result should have this number of value args+          -> CoreExpr           -- ^ Expression to expand+          -> CoreExpr+-- etaExpand arity e = res+-- Then 'res' has at least 'arity' lambdas at the top+--+-- etaExpand deals with for-alls. For example:+--              etaExpand 1 E+-- where  E :: forall a. a -> a+-- would return+--      (/\b. \y::a -> E b y)+--+-- It deals with coerces too, though they are now rare+-- so perhaps the extra code isn't worth it++etaExpand n orig_expr+  = go n orig_expr+  where+      -- Strip off existing lambdas and casts+      -- Note [Eta expansion and SCCs]+    go 0 expr = expr+    go n (Lam v body) | isTyVar v = Lam v (go n     body)+                      | otherwise = Lam v (go (n-1) body)+    go n (Cast expr co)           = Cast (go n expr) co+    go n expr+      = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $+        retick $ etaInfoAbs etas (etaInfoApp subst' sexpr etas)+      where+          in_scope = mkInScopeSet (exprFreeVars expr)+          (in_scope', etas) = mkEtaWW n orig_expr in_scope (exprType expr)+          subst' = mkEmptySubst in_scope'++          -- Find ticks behind type apps.+          -- See Note [Eta expansion and source notes]+          (expr', args) = collectArgs expr+          (ticks, expr'') = stripTicksTop tickishFloatable expr'+          sexpr = foldl App expr'' args+          retick expr = foldr mkTick expr ticks++                                -- Wrapper    Unwrapper+--------------+data EtaInfo = EtaVar Var       -- /\a. [],   [] a+                                -- \x.  [],   [] x+             | EtaCo Coercion   -- [] |> co,  [] |> (sym co)++instance Outputable EtaInfo where+   ppr (EtaVar v) = text "EtaVar" <+> ppr v+   ppr (EtaCo co) = text "EtaCo"  <+> ppr co++pushCoercion :: Coercion -> [EtaInfo] -> [EtaInfo]+pushCoercion co1 (EtaCo co2 : eis)+  | isReflCo co = eis+  | otherwise   = EtaCo co : eis+  where+    co = co1 `mkTransCo` co2++pushCoercion co eis = EtaCo co : eis++--------------+etaInfoAbs :: [EtaInfo] -> CoreExpr -> CoreExpr+etaInfoAbs []               expr = expr+etaInfoAbs (EtaVar v : eis) expr = Lam v (etaInfoAbs eis expr)+etaInfoAbs (EtaCo co : eis) expr = Cast (etaInfoAbs eis expr) (mkSymCo co)++--------------+etaInfoApp :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr+-- (etaInfoApp s e eis) returns something equivalent to+--             ((substExpr s e) `appliedto` eis)++etaInfoApp subst (Lam v1 e) (EtaVar v2 : eis)+  = etaInfoApp (CoreSubst.extendSubstWithVar subst v1 v2) e eis++etaInfoApp subst (Cast e co1) eis+  = etaInfoApp subst e (pushCoercion co' eis)+  where+    co' = CoreSubst.substCo subst co1++etaInfoApp subst (Case e b ty alts) eis+  = Case (subst_expr subst e) b1 (mk_alts_ty (CoreSubst.substTy subst ty) eis) alts'+  where+    (subst1, b1) = substBndr subst b+    alts' = map subst_alt alts+    subst_alt (con, bs, rhs) = (con, bs', etaInfoApp subst2 rhs eis)+              where+                 (subst2,bs') = substBndrs subst1 bs++    mk_alts_ty ty []               = ty+    mk_alts_ty ty (EtaVar v : eis) = mk_alts_ty (applyTypeToArg ty (varToCoreExpr v)) eis+    mk_alts_ty _  (EtaCo co : eis) = mk_alts_ty (pSnd (coercionKind co)) eis++etaInfoApp subst (Let b e) eis+  = Let b' (etaInfoApp subst' e eis)+  where+    (subst', b') = etaInfoAppBind subst b eis++etaInfoApp subst (Tick t e) eis+  = Tick (substTickish subst t) (etaInfoApp subst e eis)++etaInfoApp subst expr _+  | (Var fun, _) <- collectArgs expr+  , Var fun' <- lookupIdSubst (text "etaInfoApp" <+> ppr fun) subst fun+  , isJoinId fun'+  = subst_expr subst expr++etaInfoApp subst e eis+  = go (subst_expr subst e) eis+  where+    go e []                  = e+    go e (EtaVar v    : eis) = go (App e (varToCoreExpr v)) eis+    go e (EtaCo co    : eis) = go (Cast e co) eis++--------------+-- | Apply the eta info to a local binding. Mostly delegates to+-- `etaInfoAppLocalBndr` and `etaInfoAppRhs`.+etaInfoAppBind :: Subst -> CoreBind -> [EtaInfo] -> (Subst, CoreBind)+etaInfoAppBind subst (NonRec bndr rhs) eis+  = (subst', NonRec bndr' rhs')+  where+    bndr_w_new_type = etaInfoAppLocalBndr bndr eis+    (subst', bndr1) = substBndr subst bndr_w_new_type+    rhs'            = etaInfoAppRhs subst bndr1 rhs eis+    bndr'           | isJoinId bndr = bndr1 `setIdArity` manifestArity rhs'+                                        -- Arity may have changed+                                        -- (see etaInfoAppRhs example)+                    | otherwise     = bndr1+etaInfoAppBind subst (Rec pairs) eis+  = (subst', Rec (bndrs' `zip` rhss'))+  where+    (bndrs, rhss)     = unzip pairs+    bndrs_w_new_types = map (\bndr -> etaInfoAppLocalBndr bndr eis) bndrs+    (subst', bndrs1)  = substRecBndrs subst bndrs_w_new_types+    rhss'             = zipWith process bndrs1 rhss+    process bndr' rhs = etaInfoAppRhs subst' bndr' rhs eis+    bndrs'            | isJoinId (head bndrs)+                      = [ bndr1 `setIdArity` manifestArity rhs'+                        | (bndr1, rhs') <- bndrs1 `zip` rhss' ]+                          -- Arities may have changed+                          -- (see etaInfoAppRhs example)+                      | otherwise+                      = bndrs1++--------------+-- | Apply the eta info to a binder's RHS. Only interesting for a join point,+-- where we might have this:+--   join j :: a -> [a] -> [a]+--        j x = \xs -> x : xs in jump j z+-- Eta-expanding produces this:+--   \ys -> (join j :: a -> [a] -> [a]+--                j x = \xs -> x : xs in jump j z) ys+-- Now when we push the application to ys inward (see Note [No crap in+-- eta-expanded code]), it goes to the body of the RHS of the join point (after+-- the lambda x!):+--   \ys -> join j :: a -> [a]+--               j x = x : ys in jump j z+-- Note that the type and arity of j have both changed.+etaInfoAppRhs :: Subst -> CoreBndr -> CoreExpr -> [EtaInfo] -> CoreExpr+etaInfoAppRhs subst bndr expr eis+  | Just arity <- isJoinId_maybe bndr+  = do_join_point arity+  | otherwise+  = subst_expr subst expr+  where+    do_join_point arity = mkLams join_bndrs' join_body'+      where+        (join_bndrs, join_body) = collectNBinders arity expr+        (subst', join_bndrs') = substBndrs subst join_bndrs+        join_body' = etaInfoApp subst' join_body eis+++--------------+-- | Apply the eta info to a local binder. A join point will have the EtaInfos+-- applied to its RHS, so its type may change. See comment on etaInfoAppRhs for+-- an example. See Note [No crap in eta-expanded code] for why all this is+-- necessary.+etaInfoAppLocalBndr :: CoreBndr -> [EtaInfo] -> CoreBndr+etaInfoAppLocalBndr bndr orig_eis+  = case isJoinId_maybe bndr of+      Just arity -> bndr `setIdType` modifyJoinResTy arity (app orig_eis) ty+      Nothing    -> bndr+  where+    ty = idType bndr++    -- | Apply the given EtaInfos to the result type of the join point.+    app :: [EtaInfo] -- To apply+        -> Type      -- Result type of join point+        -> Type      -- New result type+    app [] ty+      = ty+    app (EtaVar v : eis) ty+      | isId v    = app eis (funResultTy ty)+      | otherwise = app eis (piResultTy ty (mkTyVarTy v))+    app (EtaCo co : eis) ty+      = ASSERT2(from_ty `eqType` ty, fsep ([text "can't apply", ppr orig_eis,+                                            text "to", ppr bndr <+> dcolon <+>+                                                       ppr (idType bndr)]))+        app eis to_ty+      where+        Pair from_ty to_ty = coercionKind co++--------------+mkEtaWW :: Arity -> CoreExpr -> InScopeSet -> Type+        -> (InScopeSet, [EtaInfo])+        -- EtaInfo contains fresh variables,+        --   not free in the incoming CoreExpr+        -- Outgoing InScopeSet includes the EtaInfo vars+        --   and the original free vars++mkEtaWW orig_n orig_expr in_scope orig_ty+  = go orig_n empty_subst orig_ty []+  where+    empty_subst = mkEmptyTCvSubst in_scope++    go n subst ty eis       -- See Note [exprArity invariant]+       | n == 0+       = (getTCvInScope subst, reverse eis)++       | Just (tv,ty') <- splitForAllTy_maybe ty+       , let (subst', tv') = Type.substTyVarBndr subst tv+           -- Avoid free vars of the original expression+       = go n subst' ty' (EtaVar tv' : eis)++       | Just (arg_ty, res_ty) <- splitFunTy_maybe ty+       , not (isTypeLevPoly arg_ty)+          -- See Note [Levity polymorphism invariants] in CoreSyn+          -- See also test case typecheck/should_run/EtaExpandLevPoly++       , let (subst', eta_id') = freshEtaId n subst arg_ty+           -- Avoid free vars of the original expression+       = go (n-1) subst' res_ty (EtaVar eta_id' : eis)++       | Just (co, ty') <- topNormaliseNewType_maybe ty+       =        -- Given this:+                --      newtype T = MkT ([T] -> Int)+                -- Consider eta-expanding this+                --      eta_expand 1 e T+                -- We want to get+                --      coerce T (\x::[T] -> (coerce ([T]->Int) e) x)+         go n subst ty' (EtaCo co : eis)++       | otherwise       -- We have an expression of arity > 0,+                         -- but its type isn't a function, or a binder+                         -- is levity-polymorphic+       = WARN( True, (ppr orig_n <+> ppr orig_ty) $$ ppr orig_expr )+         (getTCvInScope subst, reverse eis)+        -- This *can* legitmately happen:+        -- e.g.  coerce Int (\x. x) Essentially the programmer is+        -- playing fast and loose with types (Happy does this a lot).+        -- So we simply decline to eta-expand.  Otherwise we'd end up+        -- with an explicit lambda having a non-function type++++--------------+-- Don't use short-cutting substitution - we may be changing the types of join+-- points, so applying the in-scope set is necessary+-- TODO Check if we actually *are* changing any join points' types++subst_expr :: Subst -> CoreExpr -> CoreExpr+subst_expr = substExpr (text "CoreArity:substExpr")+++--------------++-- | Split an expression into the given number of binders and a body,+-- eta-expanding if necessary. Counts value *and* type binders.+etaExpandToJoinPoint :: JoinArity -> CoreExpr -> ([CoreBndr], CoreExpr)+etaExpandToJoinPoint join_arity expr+  = go join_arity [] expr+  where+    go 0 rev_bs e         = (reverse rev_bs, e)+    go n rev_bs (Lam b e) = go (n-1) (b : rev_bs) e+    go n rev_bs e         = case etaBodyForJoinPoint n e of+                              (bs, e') -> (reverse rev_bs ++ bs, e')++etaExpandToJoinPointRule :: JoinArity -> CoreRule -> CoreRule+etaExpandToJoinPointRule _ rule@(BuiltinRule {})+  = WARN(True, (sep [text "Can't eta-expand built-in rule:", ppr rule]))+      -- How did a local binding get a built-in rule anyway? Probably a plugin.+    rule+etaExpandToJoinPointRule join_arity rule@(Rule { ru_bndrs = bndrs, ru_rhs = rhs+                                               , ru_args  = args })+  | need_args == 0+  = rule+  | need_args < 0+  = pprPanic "etaExpandToJoinPointRule" (ppr join_arity $$ ppr rule)+  | otherwise+  = rule { ru_bndrs = bndrs ++ new_bndrs, ru_args = args ++ new_args+         , ru_rhs = new_rhs }+  where+    need_args = join_arity - length args+    (new_bndrs, new_rhs) = etaBodyForJoinPoint need_args rhs+    new_args = varsToCoreExprs new_bndrs++-- Adds as many binders as asked for; assumes expr is not a lambda+etaBodyForJoinPoint :: Int -> CoreExpr -> ([CoreBndr], CoreExpr)+etaBodyForJoinPoint need_args body+  = go need_args (exprType body) (init_subst body) [] body+  where+    go 0 _  _     rev_bs e+      = (reverse rev_bs, e)+    go n ty subst rev_bs e+      | Just (tv, res_ty) <- splitForAllTy_maybe ty+      , let (subst', tv') = Type.substTyVarBndr subst tv+      = go (n-1) res_ty subst' (tv' : rev_bs) (e `App` Type (mkTyVarTy tv'))+      | Just (arg_ty, res_ty) <- splitFunTy_maybe ty+      , let (subst', b) = freshEtaId n subst arg_ty+      = go (n-1) res_ty subst' (b : rev_bs) (e `App` Var b)+      | otherwise+      = pprPanic "etaBodyForJoinPoint" $ int need_args $$+                                         ppr body $$ ppr (exprType body)++    init_subst e = mkEmptyTCvSubst (mkInScopeSet (exprFreeVars e))++--------------+freshEtaId :: Int -> TCvSubst -> Type -> (TCvSubst, Id)+-- Make a fresh Id, with specified type (after applying substitution)+-- It should be "fresh" in the sense that it's not in the in-scope set+-- of the TvSubstEnv; and it should itself then be added to the in-scope+-- set of the TvSubstEnv+--+-- The Int is just a reasonable starting point for generating a unique;+-- it does not necessarily have to be unique itself.+freshEtaId n subst ty+      = (subst', eta_id')+      where+        ty'     = Type.substTy subst ty+        eta_id' = uniqAway (getTCvInScope subst) $+                  mkSysLocalOrCoVar (fsLit "eta") (mkBuiltinUnique n) ty'+        subst'  = extendTCvInScope subst eta_id'
+ coreSyn/CoreFVs.hs view
@@ -0,0 +1,825 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++Taken quite directly from the Peyton Jones/Lester paper.+-}++{-# LANGUAGE CPP #-}++-- | A module concerned with finding the free variables of an expression.+module CoreFVs (+        -- * Free variables of expressions and binding groups+        exprFreeVars,+        exprFreeVarsDSet,+        exprFreeVarsList,+        exprFreeIds,+        exprFreeIdsDSet,+        exprFreeIdsList,+        exprsFreeIdsDSet,+        exprsFreeIdsList,+        exprsFreeVars,+        exprsFreeVarsList,+        bindFreeVars,++        -- * Selective free variables of expressions+        InterestingVarFun,+        exprSomeFreeVars, exprsSomeFreeVars,+        exprSomeFreeVarsList, exprsSomeFreeVarsList,++        -- * Free variables of Rules, Vars and Ids+        varTypeTyCoVars,+        varTypeTyCoFVs,+        idUnfoldingVars, idFreeVars, dIdFreeVars,+        bndrRuleAndUnfoldingVarsDSet,+        idFVs,+        idRuleVars, idRuleRhsVars, stableUnfoldingVars,+        ruleRhsFreeVars, ruleFreeVars, rulesFreeVars,+        rulesFreeVarsDSet,+        ruleLhsFreeIds, ruleLhsFreeIdsList,+        vectsFreeVars,++        expr_fvs,++        -- * Orphan names+        orphNamesOfType, orphNamesOfCo, orphNamesOfAxiom,+        orphNamesOfTypes, orphNamesOfCoCon,+        exprsOrphNames, orphNamesOfFamInst,++        -- * Core syntax tree annotation with free variables+        FVAnn,                  -- annotation, abstract+        CoreExprWithFVs,        -- = AnnExpr Id FVAnn+        CoreExprWithFVs',       -- = AnnExpr' Id FVAnn+        CoreBindWithFVs,        -- = AnnBind Id FVAnn+        CoreAltWithFVs,         -- = AnnAlt Id FVAnn+        freeVars,               -- CoreExpr -> CoreExprWithFVs+        freeVarsBind,           -- CoreBind -> DVarSet -> (DVarSet, CoreBindWithFVs)+        freeVarsOf,             -- CoreExprWithFVs -> DIdSet+        freeVarsOfType,         -- CoreExprWithFVs -> TyCoVarSet+        freeVarsOfAnn, freeVarsOfTypeAnn,+        exprTypeFV              -- CoreExprWithFVs -> Type+    ) where++#include "HsVersions.h"++import CoreSyn+import Id+import IdInfo+import NameSet+import UniqSet+import Unique (Uniquable (..))+import Literal ( literalType )+import Name+import VarSet+import Var+import Type+import TyCoRep+import TyCon+import CoAxiom+import FamInstEnv+import TysPrim( funTyConName )+import Coercion+import Maybes( orElse )+import Util+import BasicTypes( Activation )+import Outputable+import FV++{-+************************************************************************+*                                                                      *+\section{Finding the free variables of an expression}+*                                                                      *+************************************************************************++This function simply finds the free variables of an expression.+So far as type variables are concerned, it only finds tyvars that are++        * free in type arguments,+        * free in the type of a binder,++but not those that are free in the type of variable occurrence.+-}++-- | Find all locally-defined free Ids or type variables in an expression+-- returning a non-deterministic set.+exprFreeVars :: CoreExpr -> VarSet+exprFreeVars = fvVarSet . exprFVs++-- | Find all locally-defined free Ids or type variables in an expression+-- returning a composable FV computation. See Note [FV naming conventions] in FV+-- for why export it.+exprFVs :: CoreExpr -> FV+exprFVs = filterFV isLocalVar . expr_fvs++-- | Find all locally-defined free Ids or type variables in an expression+-- returning a deterministic set.+exprFreeVarsDSet :: CoreExpr -> DVarSet+exprFreeVarsDSet = fvDVarSet . exprFVs++-- | Find all locally-defined free Ids or type variables in an expression+-- returning a deterministically ordered list.+exprFreeVarsList :: CoreExpr -> [Var]+exprFreeVarsList = fvVarList . exprFVs++-- | Find all locally-defined free Ids in an expression+exprFreeIds :: CoreExpr -> IdSet        -- Find all locally-defined free Ids+exprFreeIds = exprSomeFreeVars isLocalId++-- | Find all locally-defined free Ids in an expression+-- returning a deterministic set.+exprFreeIdsDSet :: CoreExpr -> DIdSet -- Find all locally-defined free Ids+exprFreeIdsDSet = exprSomeFreeVarsDSet isLocalId++-- | Find all locally-defined free Ids in an expression+-- returning a deterministically ordered list.+exprFreeIdsList :: CoreExpr -> [Id] -- Find all locally-defined free Ids+exprFreeIdsList = exprSomeFreeVarsList isLocalId++-- | Find all locally-defined free Ids in several expressions+-- returning a deterministic set.+exprsFreeIdsDSet :: [CoreExpr] -> DIdSet -- Find all locally-defined free Ids+exprsFreeIdsDSet = exprsSomeFreeVarsDSet isLocalId++-- | Find all locally-defined free Ids in several expressions+-- returning a deterministically ordered list.+exprsFreeIdsList :: [CoreExpr] -> [Id]   -- Find all locally-defined free Ids+exprsFreeIdsList = exprsSomeFreeVarsList isLocalId++-- | Find all locally-defined free Ids or type variables in several expressions+-- returning a non-deterministic set.+exprsFreeVars :: [CoreExpr] -> VarSet+exprsFreeVars = fvVarSet . exprsFVs++-- | Find all locally-defined free Ids or type variables in several expressions+-- returning a composable FV computation. See Note [FV naming conventions] in FV+-- for why export it.+exprsFVs :: [CoreExpr] -> FV+exprsFVs exprs = mapUnionFV exprFVs exprs++-- | Find all locally-defined free Ids or type variables in several expressions+-- returning a deterministically ordered list.+exprsFreeVarsList :: [CoreExpr] -> [Var]+exprsFreeVarsList = fvVarList . exprsFVs++-- | Find all locally defined free Ids in a binding group+bindFreeVars :: CoreBind -> VarSet+bindFreeVars (NonRec b r) = fvVarSet $ filterFV isLocalVar $ rhs_fvs (b,r)+bindFreeVars (Rec prs)    = fvVarSet $ filterFV isLocalVar $+                                addBndrs (map fst prs)+                                     (mapUnionFV rhs_fvs prs)++-- | Finds free variables in an expression selected by a predicate+exprSomeFreeVars :: InterestingVarFun   -- ^ Says which 'Var's are interesting+                 -> CoreExpr+                 -> VarSet+exprSomeFreeVars fv_cand e = fvVarSet $ filterFV fv_cand $ expr_fvs e++-- | Finds free variables in an expression selected by a predicate+-- returning a deterministically ordered list.+exprSomeFreeVarsList :: InterestingVarFun -- ^ Says which 'Var's are interesting+                     -> CoreExpr+                     -> [Var]+exprSomeFreeVarsList fv_cand e = fvVarList $ filterFV fv_cand $ expr_fvs e++-- | Finds free variables in an expression selected by a predicate+-- returning a deterministic set.+exprSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting+                     -> CoreExpr+                     -> DVarSet+exprSomeFreeVarsDSet fv_cand e = fvDVarSet $ filterFV fv_cand $ expr_fvs e++-- | Finds free variables in several expressions selected by a predicate+exprsSomeFreeVars :: InterestingVarFun  -- Says which 'Var's are interesting+                  -> [CoreExpr]+                  -> VarSet+exprsSomeFreeVars fv_cand es =+  fvVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs es++-- | Finds free variables in several expressions selected by a predicate+-- returning a deterministically ordered list.+exprsSomeFreeVarsList :: InterestingVarFun  -- Says which 'Var's are interesting+                      -> [CoreExpr]+                      -> [Var]+exprsSomeFreeVarsList fv_cand es =+  fvVarList $ filterFV fv_cand $ mapUnionFV expr_fvs es++-- | Finds free variables in several expressions selected by a predicate+-- returning a deterministic set.+exprsSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting+                      -> [CoreExpr]+                      -> DVarSet+exprsSomeFreeVarsDSet fv_cand e =+  fvDVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs e++--      Comment about obselete code+-- We used to gather the free variables the RULES at a variable occurrence+-- with the following cryptic comment:+--     "At a variable occurrence, add in any free variables of its rule rhss+--     Curiously, we gather the Id's free *type* variables from its binding+--     site, but its free *rule-rhs* variables from its usage sites.  This+--     is a little weird.  The reason is that the former is more efficient,+--     but the latter is more fine grained, and a makes a difference when+--     a variable mentions itself one of its own rule RHSs"+-- Not only is this "weird", but it's also pretty bad because it can make+-- a function seem more recursive than it is.  Suppose+--      f  = ...g...+--      g  = ...+--         RULE g x = ...f...+-- Then f is not mentioned in its own RHS, and needn't be a loop breaker+-- (though g may be).  But if we collect the rule fvs from g's occurrence,+-- it looks as if f mentions itself.  (This bites in the eftInt/eftIntFB+-- code in GHC.Enum.)+--+-- Anyway, it seems plain wrong.  The RULE is like an extra RHS for the+-- function, so its free variables belong at the definition site.+--+-- Deleted code looked like+--     foldVarSet add_rule_var var_itself_set (idRuleVars var)+--     add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var+--                          | otherwise                    = set+--      SLPJ Feb06++addBndr :: CoreBndr -> FV -> FV+addBndr bndr fv fv_cand in_scope acc+  = (varTypeTyCoFVs bndr `unionFV`+        -- Include type variables in the binder's type+        --      (not just Ids; coercion variables too!)+     FV.delFV bndr fv) fv_cand in_scope acc++addBndrs :: [CoreBndr] -> FV -> FV+addBndrs bndrs fv = foldr addBndr fv bndrs++expr_fvs :: CoreExpr -> FV+expr_fvs (Type ty) fv_cand in_scope acc =+  tyCoFVsOfType ty fv_cand in_scope acc+expr_fvs (Coercion co) fv_cand in_scope acc =+  tyCoFVsOfCo co fv_cand in_scope acc+expr_fvs (Var var) fv_cand in_scope acc = FV.unitFV var fv_cand in_scope acc+expr_fvs (Lit _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc+expr_fvs (Tick t expr) fv_cand in_scope acc =+  (tickish_fvs t `unionFV` expr_fvs expr) fv_cand in_scope acc+expr_fvs (App fun arg) fv_cand in_scope acc =+  (expr_fvs fun `unionFV` expr_fvs arg) fv_cand in_scope acc+expr_fvs (Lam bndr body) fv_cand in_scope acc =+  addBndr bndr (expr_fvs body) fv_cand in_scope acc+expr_fvs (Cast expr co) fv_cand in_scope acc =+  (expr_fvs expr `unionFV` tyCoFVsOfCo co) fv_cand in_scope acc++expr_fvs (Case scrut bndr ty alts) fv_cand in_scope acc+  = (expr_fvs scrut `unionFV` tyCoFVsOfType ty `unionFV` addBndr bndr+      (mapUnionFV alt_fvs alts)) fv_cand in_scope acc+  where+    alt_fvs (_, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)++expr_fvs (Let (NonRec bndr rhs) body) fv_cand in_scope acc+  = (rhs_fvs (bndr, rhs) `unionFV` addBndr bndr (expr_fvs body))+      fv_cand in_scope acc++expr_fvs (Let (Rec pairs) body) fv_cand in_scope acc+  = addBndrs (map fst pairs)+             (mapUnionFV rhs_fvs pairs `unionFV` expr_fvs body)+               fv_cand in_scope acc++---------+rhs_fvs :: (Id, CoreExpr) -> FV+rhs_fvs (bndr, rhs) = expr_fvs rhs `unionFV`+                      bndrRuleAndUnfoldingFVs bndr+        -- Treat any RULES as extra RHSs of the binding++---------+exprs_fvs :: [CoreExpr] -> FV+exprs_fvs exprs = mapUnionFV expr_fvs exprs++tickish_fvs :: Tickish Id -> FV+tickish_fvs (Breakpoint _ ids) = FV.mkFVs ids+tickish_fvs _ = emptyFV++{-+************************************************************************+*                                                                      *+\section{Free names}+*                                                                      *+************************************************************************+-}++-- | Finds the free /external/ names of an expression, notably+-- including the names of type constructors (which of course do not show+-- up in 'exprFreeVars').+exprOrphNames :: CoreExpr -> NameSet+-- There's no need to delete local binders, because they will all+-- be /internal/ names.+exprOrphNames e+  = go e+  where+    go (Var v)+      | isExternalName n    = unitNameSet n+      | otherwise           = emptyNameSet+      where n = idName v+    go (Lit _)              = emptyNameSet+    go (Type ty)            = orphNamesOfType ty        -- Don't need free tyvars+    go (Coercion co)        = orphNamesOfCo co+    go (App e1 e2)          = go e1 `unionNameSet` go e2+    go (Lam v e)            = go e `delFromNameSet` idName v+    go (Tick _ e)           = go e+    go (Cast e co)          = go e `unionNameSet` orphNamesOfCo co+    go (Let (NonRec _ r) e) = go e `unionNameSet` go r+    go (Let (Rec prs) e)    = exprsOrphNames (map snd prs) `unionNameSet` go e+    go (Case e _ ty as)     = go e `unionNameSet` orphNamesOfType ty+                              `unionNameSet` unionNameSets (map go_alt as)++    go_alt (_,_,r) = go r++-- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details+exprsOrphNames :: [CoreExpr] -> NameSet+exprsOrphNames es = foldr (unionNameSet . exprOrphNames) emptyNameSet es+++{- **********************************************************************+%*                                                                      *+                    orphNamesXXX++%*                                                                      *+%********************************************************************* -}++orphNamesOfTyCon :: TyCon -> NameSet+orphNamesOfTyCon tycon = unitNameSet (getName tycon) `unionNameSet` case tyConClass_maybe tycon of+    Nothing  -> emptyNameSet+    Just cls -> unitNameSet (getName cls)++orphNamesOfType :: Type -> NameSet+orphNamesOfType ty | Just ty' <- coreView ty = orphNamesOfType ty'+                -- Look through type synonyms (Trac #4912)+orphNamesOfType (TyVarTy _)          = emptyNameSet+orphNamesOfType (LitTy {})           = emptyNameSet+orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon+                                       `unionNameSet` orphNamesOfTypes tys+orphNamesOfType (ForAllTy bndr res)  = orphNamesOfType (binderKind bndr)+                                       `unionNameSet` orphNamesOfType res+orphNamesOfType (FunTy arg res)      = unitNameSet funTyConName    -- NB!  See Trac #8535+                                       `unionNameSet` orphNamesOfType arg+                                       `unionNameSet` orphNamesOfType res+orphNamesOfType (AppTy fun arg)      = orphNamesOfType fun `unionNameSet` orphNamesOfType arg+orphNamesOfType (CastTy ty co)       = orphNamesOfType ty `unionNameSet` orphNamesOfCo co+orphNamesOfType (CoercionTy co)      = orphNamesOfCo co++orphNamesOfThings :: (a -> NameSet) -> [a] -> NameSet+orphNamesOfThings f = foldr (unionNameSet . f) emptyNameSet++orphNamesOfTypes :: [Type] -> NameSet+orphNamesOfTypes = orphNamesOfThings orphNamesOfType++orphNamesOfCo :: Coercion -> NameSet+orphNamesOfCo (Refl _ ty)           = orphNamesOfType ty+orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` orphNamesOfCos cos+orphNamesOfCo (AppCo co1 co2)       = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2+orphNamesOfCo (ForAllCo _ kind_co co)+  = orphNamesOfCo kind_co `unionNameSet` orphNamesOfCo co+orphNamesOfCo (FunCo _ co1 co2)     = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2+orphNamesOfCo (CoVarCo _)           = emptyNameSet+orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSet` orphNamesOfCos cos+orphNamesOfCo (UnivCo p _ t1 t2)    = orphNamesOfProv p `unionNameSet` orphNamesOfType t1 `unionNameSet` orphNamesOfType t2+orphNamesOfCo (SymCo co)            = orphNamesOfCo co+orphNamesOfCo (TransCo co1 co2)     = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2+orphNamesOfCo (NthCo _ co)          = orphNamesOfCo co+orphNamesOfCo (LRCo  _ co)          = orphNamesOfCo co+orphNamesOfCo (InstCo co arg)       = orphNamesOfCo co `unionNameSet` orphNamesOfCo arg+orphNamesOfCo (CoherenceCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2+orphNamesOfCo (KindCo co)           = orphNamesOfCo co+orphNamesOfCo (SubCo co)            = orphNamesOfCo co+orphNamesOfCo (AxiomRuleCo _ cs)    = orphNamesOfCos cs++orphNamesOfProv :: UnivCoProvenance -> NameSet+orphNamesOfProv UnsafeCoerceProv    = emptyNameSet+orphNamesOfProv (PhantomProv co)    = orphNamesOfCo co+orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co+orphNamesOfProv (PluginProv _)      = emptyNameSet+orphNamesOfProv (HoleProv _)        = emptyNameSet++orphNamesOfCos :: [Coercion] -> NameSet+orphNamesOfCos = orphNamesOfThings orphNamesOfCo++orphNamesOfCoCon :: CoAxiom br -> NameSet+orphNamesOfCoCon (CoAxiom { co_ax_tc = tc, co_ax_branches = branches })+  = orphNamesOfTyCon tc `unionNameSet` orphNamesOfCoAxBranches branches++orphNamesOfAxiom :: CoAxiom br -> NameSet+orphNamesOfAxiom axiom+  = orphNamesOfTypes (concatMap coAxBranchLHS $ fromBranches $ coAxiomBranches axiom)+    `extendNameSet` getName (coAxiomTyCon axiom)++orphNamesOfCoAxBranches :: Branches br -> NameSet+orphNamesOfCoAxBranches+  = foldr (unionNameSet . orphNamesOfCoAxBranch) emptyNameSet . fromBranches++orphNamesOfCoAxBranch :: CoAxBranch -> NameSet+orphNamesOfCoAxBranch (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs })+  = orphNamesOfTypes lhs `unionNameSet` orphNamesOfType rhs++-- | orphNamesOfAxiom collects the names of the concrete types and+-- type constructors that make up the LHS of a type family instance,+-- including the family name itself.+--+-- For instance, given `type family Foo a b`:+-- `type instance Foo (F (G (H a))) b = ...` would yield [Foo,F,G,H]+--+-- Used in the implementation of ":info" in GHCi.+orphNamesOfFamInst :: FamInst -> NameSet+orphNamesOfFamInst fam_inst = orphNamesOfAxiom (famInstAxiom fam_inst)++{-+************************************************************************+*                                                                      *+\section[freevars-everywhere]{Attaching free variables to every sub-expression}+*                                                                      *+************************************************************************+-}++-- | Those variables free in the right hand side of a rule returned as a+-- non-deterministic set+ruleRhsFreeVars :: CoreRule -> VarSet+ruleRhsFreeVars (BuiltinRule {}) = noFVs+ruleRhsFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs })+  = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs)+      -- See Note [Rule free var hack]++-- | Those variables free in the both the left right hand sides of a rule+-- returned as a non-deterministic set+ruleFreeVars :: CoreRule -> VarSet+ruleFreeVars = fvVarSet . ruleFVs++-- | Those variables free in the both the left right hand sides of a rule+-- returned as FV computation+ruleFVs :: CoreRule -> FV+ruleFVs (BuiltinRule {}) = emptyFV+ruleFVs (Rule { ru_fn = _do_not_include+                  -- See Note [Rule free var hack]+              , ru_bndrs = bndrs+              , ru_rhs = rhs, ru_args = args })+  = filterFV isLocalVar $ addBndrs bndrs (exprs_fvs (rhs:args))++-- | Those variables free in the both the left right hand sides of rules+-- returned as FV computation+rulesFVs :: [CoreRule] -> FV+rulesFVs = mapUnionFV ruleFVs++-- | Those variables free in the both the left right hand sides of rules+-- returned as a deterministic set+rulesFreeVarsDSet :: [CoreRule] -> DVarSet+rulesFreeVarsDSet rules = fvDVarSet $ rulesFVs rules++idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet+-- Just the variables free on the *rhs* of a rule+idRuleRhsVars is_active id+  = mapUnionVarSet get_fvs (idCoreRules id)+  where+    get_fvs (Rule { ru_fn = fn, ru_bndrs = bndrs+                  , ru_rhs = rhs, ru_act = act })+      | is_active act+            -- See Note [Finding rule RHS free vars] in OccAnal.hs+      = delOneFromUniqSet_Directly fvs (getUnique fn)+            -- Note [Rule free var hack]+      where+        fvs = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs)+    get_fvs _ = noFVs++-- | Those variables free in the right hand side of several rules+rulesFreeVars :: [CoreRule] -> VarSet+rulesFreeVars rules = mapUnionVarSet ruleFreeVars rules++ruleLhsFreeIds :: CoreRule -> VarSet+-- ^ This finds all locally-defined free Ids on the left hand side of a rule+-- and returns them as a non-deterministic set+ruleLhsFreeIds = fvVarSet . ruleLhsFVIds++ruleLhsFreeIdsList :: CoreRule -> [Var]+-- ^ This finds all locally-defined free Ids on the left hand side of a rule+-- and returns them as a determinisitcally ordered list+ruleLhsFreeIdsList = fvVarList . ruleLhsFVIds++ruleLhsFVIds :: CoreRule -> FV+-- ^ This finds all locally-defined free Ids on the left hand side of a rule+-- and returns an FV computation+ruleLhsFVIds (BuiltinRule {}) = emptyFV+ruleLhsFVIds (Rule { ru_bndrs = bndrs, ru_args = args })+  = filterFV isLocalId $ addBndrs bndrs (exprs_fvs args)++{-+Note [Rule free var hack]  (Not a hack any more)+~~~~~~~~~~~~~~~~~~~~~~~~~+We used not to include the Id in its own rhs free-var set.+Otherwise the occurrence analyser makes bindings recursive:+        f x y = x+y+        RULE:  f (f x y) z  ==>  f x (f y z)+However, the occurrence analyser distinguishes "non-rule loop breakers"+from "rule-only loop breakers" (see BasicTypes.OccInfo).  So it will+put this 'f' in a Rec block, but will mark the binding as a non-rule loop+breaker, which is perfectly inlinable.+-}++-- |Free variables of a vectorisation declaration+vectsFreeVars :: [CoreVect] -> VarSet+vectsFreeVars = mapUnionVarSet vectFreeVars+  where+    vectFreeVars (Vect   _ rhs)   = fvVarSet $ filterFV isLocalId $ expr_fvs rhs+    vectFreeVars (NoVect _)       = noFVs+    vectFreeVars (VectType _ _ _) = noFVs+    vectFreeVars (VectClass _)    = noFVs+    vectFreeVars (VectInst _)     = noFVs+      -- this function is only concerned with values, not types++{-+************************************************************************+*                                                                      *+\section[freevars-everywhere]{Attaching free variables to every sub-expression}+*                                                                      *+************************************************************************++The free variable pass annotates every node in the expression with its+NON-GLOBAL free variables and type variables.+-}++data FVAnn = FVAnn { fva_fvs    :: DVarSet   -- free in expression+                   , fva_ty_fvs :: DVarSet   -- free only in expression's type+                   , fva_ty     :: Type      -- expression's type+                   }++-- | Every node in a binding group annotated with its+-- (non-global) free variables, both Ids and TyVars, and type.+type CoreBindWithFVs = AnnBind Id FVAnn+-- | Every node in an expression annotated with its+-- (non-global) free variables, both Ids and TyVars, and type.+type CoreExprWithFVs  = AnnExpr Id FVAnn+type CoreExprWithFVs' = AnnExpr' Id FVAnn++-- | Every node in an expression annotated with its+-- (non-global) free variables, both Ids and TyVars, and type.+type CoreAltWithFVs = AnnAlt Id FVAnn++freeVarsOf :: CoreExprWithFVs -> DIdSet+-- ^ Inverse function to 'freeVars'+freeVarsOf (FVAnn { fva_fvs = fvs }, _) = fvs++-- | Extract the vars free in an annotated expression's type+freeVarsOfType :: CoreExprWithFVs -> DTyCoVarSet+freeVarsOfType (FVAnn { fva_ty_fvs = ty_fvs }, _) = ty_fvs++-- | Extract the type of an annotated expression. (This is cheap.)+exprTypeFV :: CoreExprWithFVs -> Type+exprTypeFV (FVAnn { fva_ty = ty }, _) = ty++-- | Extract the vars reported in a FVAnn+freeVarsOfAnn :: FVAnn -> DIdSet+freeVarsOfAnn = fva_fvs++-- | Extract the type-level vars reported in a FVAnn+freeVarsOfTypeAnn :: FVAnn -> DTyCoVarSet+freeVarsOfTypeAnn = fva_ty_fvs++noFVs :: VarSet+noFVs = emptyVarSet++aFreeVar :: Var -> DVarSet+aFreeVar = unitDVarSet++unionFVs :: DVarSet -> DVarSet -> DVarSet+unionFVs = unionDVarSet++unionFVss :: [DVarSet] -> DVarSet+unionFVss = unionDVarSets++delBindersFV :: [Var] -> DVarSet -> DVarSet+delBindersFV bs fvs = foldr delBinderFV fvs bs++delBinderFV :: Var -> DVarSet -> DVarSet+-- This way round, so we can do it multiple times using foldr++-- (b `delBinderFV` s) removes the binder b from the free variable set s,+-- but *adds* to s+--+--      the free variables of b's type+--+-- This is really important for some lambdas:+--      In (\x::a -> x) the only mention of "a" is in the binder.+--+-- Also in+--      let x::a = b in ...+-- we should really note that "a" is free in this expression.+-- It'll be pinned inside the /\a by the binding for b, but+-- it seems cleaner to make sure that a is in the free-var set+-- when it is mentioned.+--+-- This also shows up in recursive bindings.  Consider:+--      /\a -> letrec x::a = x in E+-- Now, there are no explicit free type variables in the RHS of x,+-- but nevertheless "a" is free in its definition.  So we add in+-- the free tyvars of the types of the binders, and include these in the+-- free vars of the group, attached to the top level of each RHS.+--+-- This actually happened in the defn of errorIO in IOBase.hs:+--      errorIO (ST io) = case (errorIO# io) of+--                          _ -> bottom+--                        where+--                          bottom = bottom -- Never evaluated++delBinderFV b s = (s `delDVarSet` b) `unionFVs` dVarTypeTyCoVars b+        -- Include coercion variables too!++varTypeTyCoVars :: Var -> TyCoVarSet+-- Find the type/kind variables free in the type of the id/tyvar+varTypeTyCoVars var = fvVarSet $ varTypeTyCoFVs var++dVarTypeTyCoVars :: Var -> DTyCoVarSet+-- Find the type/kind/coercion variables free in the type of the id/tyvar+dVarTypeTyCoVars var = fvDVarSet $ varTypeTyCoFVs var++varTypeTyCoFVs :: Var -> FV+varTypeTyCoFVs var = tyCoFVsOfType (varType var)++idFreeVars :: Id -> VarSet+idFreeVars id = ASSERT( isId id) fvVarSet $ idFVs id++dIdFreeVars :: Id -> DVarSet+dIdFreeVars id = fvDVarSet $ idFVs id++idFVs :: Id -> FV+-- Type variables, rule variables, and inline variables+idFVs id = ASSERT( isId id)+           varTypeTyCoFVs id `unionFV`+           bndrRuleAndUnfoldingFVs id++bndrRuleAndUnfoldingVarsDSet :: Id -> DVarSet+bndrRuleAndUnfoldingVarsDSet id = fvDVarSet $ bndrRuleAndUnfoldingFVs id++bndrRuleAndUnfoldingFVs :: Id -> FV+bndrRuleAndUnfoldingFVs id+  | isId id   = idRuleFVs id `unionFV` idUnfoldingFVs id+  | otherwise = emptyFV++idRuleVars ::Id -> VarSet  -- Does *not* include CoreUnfolding vars+idRuleVars id = fvVarSet $ idRuleFVs id++idRuleFVs :: Id -> FV+idRuleFVs id = ASSERT( isId id)+  FV.mkFVs (dVarSetElems $ ruleInfoFreeVars (idSpecialisation id))++idUnfoldingVars :: Id -> VarSet+-- Produce free vars for an unfolding, but NOT for an ordinary+-- (non-inline) unfolding, since it is a dup of the rhs+-- and we'll get exponential behaviour if we look at both unf and rhs!+-- But do look at the *real* unfolding, even for loop breakers, else+-- we might get out-of-scope variables+idUnfoldingVars id = fvVarSet $ idUnfoldingFVs id++idUnfoldingFVs :: Id -> FV+idUnfoldingFVs id = stableUnfoldingFVs (realIdUnfolding id) `orElse` emptyFV++stableUnfoldingVars :: Unfolding -> Maybe VarSet+stableUnfoldingVars unf = fvVarSet `fmap` stableUnfoldingFVs unf++stableUnfoldingFVs :: Unfolding -> Maybe FV+stableUnfoldingFVs unf+  = case unf of+      CoreUnfolding { uf_tmpl = rhs, uf_src = src }+         | isStableSource src+         -> Just (filterFV isLocalVar $ expr_fvs rhs)+      DFunUnfolding { df_bndrs = bndrs, df_args = args }+         -> Just (filterFV isLocalVar $ FV.delFVs (mkVarSet bndrs) $ exprs_fvs args)+            -- DFuns are top level, so no fvs from types of bndrs+      _other -> Nothing+++{-+************************************************************************+*                                                                      *+\subsection{Free variables (and types)}+*                                                                      *+************************************************************************+-}++freeVarsBind :: CoreBind+             -> DVarSet                     -- Free vars of scope of binding+             -> (CoreBindWithFVs, DVarSet)  -- Return free vars of binding + scope+freeVarsBind (NonRec binder rhs) body_fvs+  = ( AnnNonRec binder rhs2+    , freeVarsOf rhs2 `unionFVs` body_fvs2+                      `unionFVs` bndrRuleAndUnfoldingVarsDSet binder )+    where+      rhs2      = freeVars rhs+      body_fvs2 = binder `delBinderFV` body_fvs++freeVarsBind (Rec binds) body_fvs+  = ( AnnRec (binders `zip` rhss2)+    , delBindersFV binders all_fvs )+  where+    (binders, rhss) = unzip binds+    rhss2        = map freeVars rhss+    rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2+    binders_fvs  = fvDVarSet $ mapUnionFV bndrRuleAndUnfoldingFVs binders+    all_fvs      = rhs_body_fvs `unionFVs` binders_fvs+            -- The "delBinderFV" happens after adding the idSpecVars,+            -- since the latter may add some of the binders as fvs++freeVars :: CoreExpr -> CoreExprWithFVs+-- ^ Annotate a 'CoreExpr' with its (non-global) free type and value variables at every tree node+freeVars = go+  where+    go :: CoreExpr -> CoreExprWithFVs+    go (Var v)+      = (FVAnn fvs ty_fvs (idType v), AnnVar v)+      where+            -- ToDo: insert motivating example for why we *need*+            -- to include the idSpecVars in the FV list.+            --      Actually [June 98] I don't think it's necessary+            -- fvs = fvs_v `unionVarSet` idSpecVars v++        (fvs, ty_fvs)+            | isLocalVar v = (aFreeVar v `unionFVs` ty_fvs, dVarTypeTyCoVars v)+            | otherwise    = (emptyDVarSet, emptyDVarSet)++    go (Lit lit) = (FVAnn emptyDVarSet emptyDVarSet (literalType lit), AnnLit lit)+    go (Lam b body)+      = ( FVAnn { fva_fvs    = b_fvs `unionFVs` (b `delBinderFV` body_fvs)+                , fva_ty_fvs = b_fvs `unionFVs` (b `delBinderFV` body_ty_fvs)+                , fva_ty     = mkFunTy b_ty body_ty }+        , AnnLam b body' )+      where+        body'@(FVAnn { fva_fvs = body_fvs, fva_ty_fvs = body_ty_fvs+                     , fva_ty = body_ty }, _) = go body+        b_ty  = idType b+        b_fvs = tyCoVarsOfTypeDSet b_ty++    go (App fun arg)+      = ( FVAnn { fva_fvs    = freeVarsOf fun' `unionFVs` freeVarsOf arg'+                , fva_ty_fvs = tyCoVarsOfTypeDSet res_ty+                , fva_ty     = res_ty }+        , AnnApp fun' arg' )+      where+        fun'   = go fun+        fun_ty = exprTypeFV fun'+        arg'   = go arg+        res_ty = applyTypeToArg fun_ty arg++    go (Case scrut bndr ty alts)+      = ( FVAnn { fva_fvs = (bndr `delBinderFV` alts_fvs)+                            `unionFVs` freeVarsOf scrut2+                            `unionFVs` tyCoVarsOfTypeDSet ty+                           -- don't need to look at (idType bndr)+                           -- b/c that's redundant with scrut+                , fva_ty_fvs = tyCoVarsOfTypeDSet ty+                , fva_ty     = ty }+        , AnnCase scrut2 bndr ty alts2 )+      where+        scrut2 = go scrut++        (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts+        alts_fvs            = unionFVss alts_fvs_s++        fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2),+                                 (con, args, rhs2))+                              where+                                 rhs2 = go rhs++    go (Let bind body)+      = ( FVAnn { fva_fvs    = bind_fvs+                , fva_ty_fvs = freeVarsOfType body2+                , fva_ty     = exprTypeFV body2 }+        , AnnLet bind2 body2 )+      where+        (bind2, bind_fvs) = freeVarsBind bind (freeVarsOf body2)+        body2             = go body++    go (Cast expr co)+      = ( FVAnn (freeVarsOf expr2 `unionFVs` cfvs) (tyCoVarsOfTypeDSet to_ty) to_ty+        , AnnCast expr2 (c_ann, co) )+      where+        expr2 = go expr+        cfvs  = tyCoVarsOfCoDSet co+        c_ann = FVAnn cfvs (tyCoVarsOfTypeDSet co_ki) co_ki+        co_ki = coercionType co+        Just (_, to_ty) = splitCoercionType_maybe co_ki+++    go (Tick tickish expr)+      = ( FVAnn { fva_fvs    = tickishFVs tickish `unionFVs` freeVarsOf expr2+                , fva_ty_fvs = freeVarsOfType expr2+                , fva_ty     = exprTypeFV expr2 }+        , AnnTick tickish expr2 )+      where+        expr2 = go expr+        tickishFVs (Breakpoint _ ids) = mkDVarSet ids+        tickishFVs _                  = emptyDVarSet++    go (Type ty) = ( FVAnn (tyCoVarsOfTypeDSet ty)+                           (tyCoVarsOfTypeDSet ki)+                           ki+                   , AnnType ty)+      where+        ki = typeKind ty++    go (Coercion co) = ( FVAnn (tyCoVarsOfCoDSet co)+                               (tyCoVarsOfTypeDSet ki)+                               ki+                       , AnnCoercion co)+      where+        ki = coercionType co
+ coreSyn/CoreLint.hs view
@@ -0,0 +1,2478 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998+++A ``lint'' pass to check for Core correctness+-}++{-# LANGUAGE CPP #-}++module CoreLint (+    lintCoreBindings, lintUnfolding,+    lintPassResult, lintInteractiveExpr, lintExpr,+    lintAnnots,++    -- ** Debug output+    endPass, endPassIO,+    dumpPassResult,+    CoreLint.dumpIfSet,+ ) where++#include "HsVersions.h"++import CoreSyn+import CoreFVs+import CoreUtils+import CoreStats   ( coreBindsStats )+import CoreMonad+import Bag+import Literal+import DataCon+import TysWiredIn+import TysPrim+import TcType ( isFloatingTy )+import Var+import VarEnv+import VarSet+import Name+import Id+import IdInfo+import PprCore+import ErrUtils+import Coercion+import SrcLoc+import Kind+import Type+import RepType+import TyCoRep       -- checks validity of types/coercions+import TyCon+import CoAxiom+import BasicTypes+import ErrUtils as Err+import ListSetOps+import PrelNames+import Outputable+import FastString+import Util+import InstEnv     ( instanceDFunId )+import OptCoercion ( checkAxInstCo )+import UniqSupply+import CoreArity ( typeArity )+import Demand ( splitStrictSig, isBotRes )++import HscTypes+import DynFlags+import Control.Monad+#if __GLASGOW_HASKELL__ > 710+import qualified Control.Monad.Fail as MonadFail+#endif+import MonadUtils+import Data.Maybe+import Pair+import qualified GHC.LanguageExtensions as LangExt++{-+Note [GHC Formalism]+~~~~~~~~~~~~~~~~~~~~+This file implements the type-checking algorithm for System FC, the "official"+name of the Core language. Type safety of FC is heart of the claim that+executables produced by GHC do not have segmentation faults. Thus, it is+useful to be able to reason about System FC independently of reading the code.+To this purpose, there is a document core-spec.pdf built in docs/core-spec that+contains a formalism of the types and functions dealt with here. If you change+just about anything in this file or you change other types/functions throughout+the Core language (all signposted to this note), you should update that+formalism. See docs/core-spec/README for more info about how to do so.++Note [check vs lint]+~~~~~~~~~~~~~~~~~~~~+This file implements both a type checking algorithm and also general sanity+checking. For example, the "sanity checking" checks for TyConApp on the left+of an AppTy, which should never happen. These sanity checks don't really+affect any notion of type soundness. Yet, it is convenient to do the sanity+checks at the same time as the type checks. So, we use the following naming+convention:++- Functions that begin with 'lint'... are involved in type checking. These+  functions might also do some sanity checking.++- Functions that begin with 'check'... are *not* involved in type checking.+  They exist only for sanity checking.++Issues surrounding variable naming, shadowing, and such are considered *not*+to be part of type checking, as the formalism omits these details.++Summary of checks+~~~~~~~~~~~~~~~~~+Checks that a set of core bindings is well-formed.  The PprStyle and String+just control what we print in the event of an error.  The Bool value+indicates whether we have done any specialisation yet (in which case we do+some extra checks).++We check for+        (a) type errors+        (b) Out-of-scope type variables+        (c) Out-of-scope local variables+        (d) Ill-kinded types+        (e) Incorrect unsafe coercions++If we have done specialisation the we check that there are+        (a) No top-level bindings of primitive (unboxed type)++Outstanding issues:++    -- Things are *not* OK if:+    --+    --  * Unsaturated type app before specialisation has been done;+    --+    --  * Oversaturated type app after specialisation (eta reduction+    --   may well be happening...);+++Note [Linting function types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As described in Note [Representation of function types], all saturated+applications of funTyCon are represented with the FunTy constructor. We check+this invariant in lintType.++Note [Linting type lets]+~~~~~~~~~~~~~~~~~~~~~~~~+In the desugarer, it's very very convenient to be able to say (in effect)+        let a = Type Int in <body>+That is, use a type let.   See Note [Type let] in CoreSyn.++However, 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 -> Int]) and apply this substitution before comparing types.  The functin+        lintInTy :: Type -> LintM (Type, Kind)+returns a substituted type.++When we encounter a binder (like x::a) we must apply the substitution+to the type of the binding variable.  lintBinders does this.++For Ids, the type-substituted Id is added to the in_scope set (which+itself is part of the TCvSubst we are carrying down), and when we+find an occurrence of an Id, we fetch it from the in-scope set.++Note [Bad unsafe coercion]+~~~~~~~~~~~~~~~~~~~~~~~~~~+For discussion see https://ghc.haskell.org/trac/ghc/wiki/BadUnsafeCoercions+Linter introduces additional rules that checks improper coercion between+different types, called bad coercions. Following coercions are forbidden:++  (a) coercions between boxed and unboxed values;+  (b) coercions between unlifted values of the different sizes, here+      active size is checked, i.e. size of the actual value but not+      the space allocated for value;+  (c) coercions between floating and integral boxed values, this check+      is not yet supported for unboxed tuples, as no semantics were+      specified for that;+  (d) coercions from / to vector type+  (e) If types are unboxed tuples then tuple (# A_1,..,A_n #) can be+      coerced to (# B_1,..,B_m #) if n=m and for each pair A_i, B_i rules+      (a-e) holds.++Note [Join points]+~~~~~~~~~~~~~~~~~~+We check the rules listed in Note [Invariants on join points] in CoreSyn. The+only one that causes any difficulty is the first: All occurrences must be tail+calls. To this end, along with the in-scope set, we remember in le_joins the+subset of in-scope Ids that are valid join ids. For example:++  join j x = ... in+  case e of+    A -> jump j y -- good+    B -> case (jump j z) of -- BAD+           C -> join h = jump j w in ... -- good+           D -> let x = jump j v in ... -- BAD++A join point remains valid in case branches, so when checking the A+branch, j is still valid. When we check the scrutinee of the inner+case, however, we set le_joins to empty, and catch the+error. Similarly, join points can occur free in RHSes of other join+points but not the RHSes of value bindings (thunks and functions).++************************************************************************+*                                                                      *+                 Beginning and ending passes+*                                                                      *+************************************************************************++These functions are not CoreM monad stuff, but they probably ought to+be, and it makes a conveneint place.  place for them.  They print out+stuff before and after core passes, and do Core Lint when necessary.+-}++endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM ()+endPass pass binds rules+  = do { hsc_env <- getHscEnv+       ; print_unqual <- getPrintUnqualified+       ; liftIO $ endPassIO hsc_env print_unqual pass binds rules }++endPassIO :: HscEnv -> PrintUnqualified+          -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()+-- Used by the IO-is CorePrep too+endPassIO hsc_env print_unqual pass binds rules+  = do { dumpPassResult dflags print_unqual mb_flag+                        (ppr pass) (pprPassDetails pass) binds rules+       ; lintPassResult hsc_env pass binds }+  where+    dflags  = hsc_dflags hsc_env+    mb_flag = case coreDumpFlag pass of+                Just flag | dopt flag dflags                    -> Just flag+                          | dopt Opt_D_verbose_core2core dflags -> Just flag+                _ -> Nothing++dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO ()+dumpIfSet dflags dump_me pass extra_info doc+  = Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc++dumpPassResult :: DynFlags+               -> PrintUnqualified+               -> Maybe DumpFlag        -- Just df => show details in a file whose+                                        --            name is specified by df+               -> SDoc                  -- Header+               -> SDoc                  -- Extra info to appear after header+               -> CoreProgram -> [CoreRule]+               -> IO ()+dumpPassResult dflags unqual mb_flag hdr extra_info binds rules+  = do { forM_ mb_flag $ \flag ->+           Err.dumpSDoc dflags unqual flag (showSDoc dflags hdr) dump_doc++         -- Report result size+         -- This has the side effect of forcing the intermediate to be evaluated+         -- if it's not already forced by a -ddump flag.+       ; Err.debugTraceMsg dflags 2 size_doc+       }++  where+    size_doc = sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))]++    dump_doc  = vcat [ nest 2 extra_info+                     , size_doc+                     , blankLine+                     , pprCoreBindingsWithSize binds+                     , ppUnless (null rules) pp_rules ]+    pp_rules = vcat [ blankLine+                    , text "------ Local rules for imported ids --------"+                    , pprRules rules ]++coreDumpFlag :: CoreToDo -> Maybe DumpFlag+coreDumpFlag (CoreDoSimplify {})      = Just Opt_D_verbose_core2core+coreDumpFlag (CoreDoPluginPass {})    = Just Opt_D_verbose_core2core+coreDumpFlag CoreDoFloatInwards       = Just Opt_D_verbose_core2core+coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core+coreDumpFlag CoreLiberateCase         = Just Opt_D_verbose_core2core+coreDumpFlag CoreDoStaticArgs         = Just Opt_D_verbose_core2core+coreDumpFlag CoreDoCallArity          = Just Opt_D_dump_call_arity+coreDumpFlag CoreDoStrictness         = Just Opt_D_dump_stranal+coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper+coreDumpFlag CoreDoSpecialising       = Just Opt_D_dump_spec+coreDumpFlag CoreDoSpecConstr         = Just Opt_D_dump_spec+coreDumpFlag CoreCSE                  = Just Opt_D_dump_cse+coreDumpFlag CoreDoVectorisation      = Just Opt_D_dump_vect+coreDumpFlag CoreDesugar              = Just Opt_D_dump_ds+coreDumpFlag CoreDesugarOpt           = Just Opt_D_dump_ds+coreDumpFlag CoreTidy                 = Just Opt_D_dump_simpl+coreDumpFlag CorePrep                 = Just Opt_D_dump_prep+coreDumpFlag CoreOccurAnal            = Just Opt_D_dump_occur_anal++coreDumpFlag CoreDoPrintCore          = Nothing+coreDumpFlag (CoreDoRuleCheck {})     = Nothing+coreDumpFlag CoreDoNothing            = Nothing+coreDumpFlag (CoreDoPasses {})        = Nothing++{-+************************************************************************+*                                                                      *+                 Top-level interfaces+*                                                                      *+************************************************************************+-}++lintPassResult :: HscEnv -> CoreToDo -> CoreProgram -> IO ()+lintPassResult hsc_env pass binds+  | not (gopt Opt_DoCoreLinting dflags)+  = return ()+  | otherwise+  = do { let (warns, errs) = lintCoreBindings dflags pass (interactiveInScope hsc_env) binds+       ; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass)+       ; displayLintResults dflags pass warns errs binds  }+  where+    dflags = hsc_dflags hsc_env++displayLintResults :: DynFlags -> CoreToDo+                   -> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram+                   -> IO ()+displayLintResults dflags pass warns errs binds+  | not (isEmptyBag errs)+  = do { putLogMsg dflags NoReason Err.SevDump noSrcSpan+           (defaultDumpStyle dflags)+           (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs+                 , text "*** Offending Program ***"+                 , pprCoreBindings binds+                 , text "*** End of Offense ***" ])+       ; Err.ghcExit dflags 1 }++  | not (isEmptyBag warns)+  , not (hasNoDebugOutput dflags)+  , showLintWarnings pass+  = putLogMsg dflags NoReason Err.SevDump noSrcSpan+        (defaultDumpStyle dflags)+        (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag warns)++  | otherwise = return ()+  where++lint_banner :: String -> SDoc -> SDoc+lint_banner string pass = text "*** Core Lint"      <+> text string+                          <+> text ": in result of" <+> pass+                          <+> text "***"++showLintWarnings :: CoreToDo -> Bool+-- Disable Lint warnings on the first simplifier pass, because+-- there may be some INLINE knots still tied, which is tiresomely noisy+showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False+showLintWarnings _ = True++lintInteractiveExpr :: String -> HscEnv -> CoreExpr -> IO ()+lintInteractiveExpr what hsc_env expr+  | not (gopt Opt_DoCoreLinting dflags)+  = return ()+  | Just err <- lintExpr dflags (interactiveInScope hsc_env) expr+  = do { display_lint_err err+       ; Err.ghcExit dflags 1 }+  | otherwise+  = return ()+  where+    dflags = hsc_dflags hsc_env++    display_lint_err err+      = do { putLogMsg dflags NoReason Err.SevDump+               noSrcSpan (defaultDumpStyle dflags)+               (vcat [ lint_banner "errors" (text what)+                     , err+                     , text "*** Offending Program ***"+                     , pprCoreExpr expr+                     , text "*** End of Offense ***" ])+           ; Err.ghcExit dflags 1 }++interactiveInScope :: HscEnv -> [Var]+-- In GHCi we may lint expressions, or bindings arising from 'deriving'+-- clauses, that mention variables bound in the interactive context.+-- These are Local things (see Note [Interactively-bound Ids in GHCi] in HscTypes).+-- So we have to tell Lint about them, lest it reports them as out of scope.+--+-- We do this by find local-named things that may appear free in interactive+-- context.  This function is pretty revolting and quite possibly not quite right.+-- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty+-- so this is a (cheap) no-op.+--+-- See Trac #8215 for an example+interactiveInScope hsc_env+  = tyvars ++ ids+  where+    -- C.f. TcRnDriver.setInteractiveContext, Desugar.deSugarExpr+    ictxt                   = hsc_IC hsc_env+    (cls_insts, _fam_insts) = ic_instances ictxt+    te1    = mkTypeEnvWithImplicits (ic_tythings ictxt)+    te     = extendTypeEnvWithIds te1 (map instanceDFunId cls_insts)+    ids    = typeEnvIds te+    tyvars = tyCoVarsOfTypesList $ map idType ids+              -- Why the type variables?  How can the top level envt have free tyvars?+              -- I think it's because of the GHCi debugger, which can bind variables+              --   f :: [t] -> [t]+              -- where t is a RuntimeUnk (see TcType)++lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc)+--   Returns (warnings, errors)+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintCoreBindings dflags pass local_in_scope binds+  = initL dflags flags in_scope_set $+    addLoc TopLevelBindings         $+    lintLetBndrs TopLevel binders   $+        -- Put all the top-level binders in scope at the start+        -- This is because transformation rules can bring something+        -- into use 'unexpectedly'+    do { checkL (null dups) (dupVars dups)+       ; checkL (null ext_dups) (dupExtVars ext_dups)+       ; mapM lint_bind binds }+  where+    in_scope_set = mkInScopeSet (mkVarSet local_in_scope)++    flags = LF { lf_check_global_ids = check_globals+               , lf_check_inline_loop_breakers = check_lbs+               , lf_check_static_ptrs = check_static_ptrs }++    -- See Note [Checking for global Ids]+    check_globals = case pass of+                      CoreTidy -> False+                      CorePrep -> False+                      _        -> True++    -- See Note [Checking for INLINE loop breakers]+    check_lbs = case pass of+                      CoreDesugar    -> False+                      CoreDesugarOpt -> False+                      _              -> True++    -- See Note [Checking StaticPtrs]+    check_static_ptrs | not (xopt LangExt.StaticPointers dflags) = AllowAnywhere+                      | otherwise = case pass of+                          CoreDoFloatOutwards _ -> AllowAtTopLevel+                          CoreTidy              -> RejectEverywhere+                          CorePrep              -> AllowAtTopLevel+                          _                     -> AllowAnywhere++    binders = bindersOfBinds binds+    (_, dups) = removeDups compare binders++    -- dups_ext checks for names with different uniques+    -- but but the same External name M.n.  We don't+    -- allow this at top level:+    --    M.n{r3}  = ...+    --    M.n{r29} = ...+    -- because they both get the same linker symbol+    ext_dups = snd (removeDups ord_ext (map Var.varName binders))+    ord_ext n1 n2 | Just m1 <- nameModule_maybe n1+                  , Just m2 <- nameModule_maybe n2+                  = compare (m1, nameOccName n1) (m2, nameOccName n2)+                  | otherwise = LT++    -- If you edit this function, you may need to update the GHC formalism+    -- See Note [GHC Formalism]+    lint_bind (Rec prs)         = mapM_ (lintSingleBinding TopLevel Recursive) prs+    lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)++{-+************************************************************************+*                                                                      *+\subsection[lintUnfolding]{lintUnfolding}+*                                                                      *+************************************************************************++We use this to check all unfoldings that come in from interfaces+(it is very painful to catch errors otherwise):+-}++lintUnfolding :: DynFlags+              -> SrcLoc+              -> VarSet         -- Treat these as in scope+              -> CoreExpr+              -> Maybe MsgDoc   -- Nothing => OK++lintUnfolding dflags locn vars expr+  | isEmptyBag errs = Nothing+  | otherwise       = Just (pprMessageBag errs)+  where+    in_scope = mkInScopeSet vars+    (_warns, errs) = initL dflags defaultLintFlags in_scope linter+    linter = addLoc (ImportedUnfolding locn) $+             lintCoreExpr expr++lintExpr :: DynFlags+         -> [Var]               -- Treat these as in scope+         -> CoreExpr+         -> Maybe MsgDoc        -- Nothing => OK++lintExpr dflags vars expr+  | isEmptyBag errs = Nothing+  | otherwise       = Just (pprMessageBag errs)+  where+    in_scope = mkInScopeSet (mkVarSet vars)+    (_warns, errs) = initL dflags defaultLintFlags in_scope linter+    linter = addLoc TopLevelBindings $+             lintCoreExpr expr++{-+************************************************************************+*                                                                      *+\subsection[lintCoreBinding]{lintCoreBinding}+*                                                                      *+************************************************************************++Check a core binding, returning the list of variables bound.+-}++lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM ()+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintSingleBinding top_lvl_flag rec_flag (binder,rhs)+  = addLoc (RhsOf binder) $+         -- Check the rhs+    do { ty <- lintRhs binder rhs+       ; binder_ty <- applySubstTy (idType binder)+       ; ensureEqTys binder_ty ty (mkRhsMsg binder (text "RHS") ty)++       -- Check that it's not levity-polymorphic+       -- Do this first, because otherwise isUnliftedType panics+       -- Annoyingly, this duplicates the test in lintIdBdr,+       -- because for non-rec lets we call lintSingleBinding first+       ; checkL (isJoinId binder || not (isTypeLevPoly binder_ty))+                (badBndrTyMsg binder (text "levity-polymorphic"))++        -- Check the let/app invariant+        -- See Note [CoreSyn let/app invariant] in CoreSyn+       ; checkL ( isJoinId binder+               || not (isUnliftedType binder_ty)+               || (isNonRec rec_flag && exprOkForSpeculation rhs)+               || exprIsLiteralString rhs)+           (badBndrTyMsg binder (text "unlifted"))++        -- Check that if the binder is top-level or recursive, it's not+        -- demanded. Primitive string literals are exempt as there is no+        -- computation to perform, see Note [CoreSyn top-level string literals].+       ; checkL (not (isStrictId binder)+            || (isNonRec rec_flag && not (isTopLevel top_lvl_flag))+            || exprIsLiteralString rhs)+           (mkStrictMsg binder)++        -- Check that if the binder is at the top level and has type Addr#,+        -- that it is a string literal, see+        -- Note [CoreSyn top-level string literals].+       ; checkL (not (isTopLevel top_lvl_flag && binder_ty `eqType` addrPrimTy)+                 || exprIsLiteralString rhs)+           (mkTopNonLitStrMsg binder)++       ; flags <- getLintFlags++         -- Check that a join-point binder has a valid type+         -- NB: lintIdBinder has checked that it is not top-level bound+       ; case isJoinId_maybe binder of+            Nothing    -> return ()+            Just arity ->  checkL (isValidJoinPointType arity binder_ty)+                                  (mkInvalidJoinPointMsg binder binder_ty)++       ; when (lf_check_inline_loop_breakers flags+               && isStrongLoopBreaker (idOccInfo binder)+               && isInlinePragma (idInlinePragma binder))+              (addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder))+              -- Only non-rule loop breakers inhibit inlining++      -- Check whether arity and demand type are consistent (only if demand analysis+      -- already happened)+      --+      -- Note (Apr 2014): this is actually ok.  See Note [Demand analysis for trivial right-hand sides]+      --                  in DmdAnal.  After eta-expansion in CorePrep the rhs is no longer trivial.+      --       ; let dmdTy = idStrictness binder+      --       ; checkL (case dmdTy of+      --                  StrictSig dmd_ty -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs)+      --           (mkArityMsg binder)++       -- Check that the binder's arity is within the bounds imposed by+       -- the type and the strictness signature. See Note [exprArity invariant]+       -- and Note [Trimming arity]+       ; checkL (idArity binder <= length (typeArity (idType binder)))+           (text "idArity" <+> ppr (idArity binder) <+>+           text "exceeds typeArity" <+>+           ppr (length (typeArity (idType binder))) <> colon <+>+           ppr binder)++       ; case splitStrictSig (idStrictness binder) of+           (demands, result_info) | isBotRes result_info ->+             checkL (idArity binder <= length demands)+               (text "idArity" <+> ppr (idArity binder) <+>+               text "exceeds arity imposed by the strictness signature" <+>+               ppr (idStrictness binder) <> colon <+>+               ppr binder)+           _ -> return ()++       ; mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder)+       ; lintIdUnfolding binder binder_ty (idUnfolding binder) }++        -- We should check the unfolding, if any, but this is tricky because+        -- the unfolding is a SimplifiableCoreExpr. Give up for now.++-- | Checks the RHS of bindings. It only differs from 'lintCoreExpr'+-- in that it doesn't reject occurrences of the function 'makeStatic' when they+-- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@, and+-- for join points, it skips the outer lambdas that take arguments to the+-- join point.+--+-- See Note [Checking StaticPtrs].+lintRhs :: Id -> CoreExpr -> LintM OutType+lintRhs bndr rhs+    | Just arity <- isJoinId_maybe bndr+    = lint_join_lams arity arity True rhs+    | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr)+    = lint_join_lams arity arity False rhs+  where+    lint_join_lams 0 _ _ rhs+      = lintCoreExpr rhs++    lint_join_lams n tot enforce (Lam var expr)+      = addLoc (LambdaBodyOf var) $+        lintBinder LambdaBind var $ \ var' ->+        do { body_ty <- lint_join_lams (n-1) tot enforce expr+           ; return $ mkLamType var' body_ty }++    lint_join_lams n tot True _other+      = failWithL $ mkBadJoinArityMsg bndr tot (tot-n)+    lint_join_lams _ _ False rhs+      = markAllJoinsBad $ lintCoreExpr rhs+          -- Future join point, not yet eta-expanded+          -- Body is not a tail position++-- Allow applications of the data constructor @StaticPtr@ at the top+-- but produce errors otherwise.+lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go+  where+    -- Allow occurrences of 'makeStatic' at the top-level but produce errors+    -- otherwise.+    go AllowAtTopLevel+      | (binders0, rhs') <- collectTyBinders rhs+      , Just (fun, t, info, e) <- collectMakeStaticArgs rhs'+      = markAllJoinsBad $+        foldr+        -- imitate @lintCoreExpr (Lam ...)@+        (\var loopBinders ->+          addLoc (LambdaBodyOf var) $+            lintBinder LambdaBind var $ \var' ->+              do { body_ty <- loopBinders+                 ; return $ mkLamType var' body_ty }+        )+        -- imitate @lintCoreExpr (App ...)@+        (do fun_ty <- lintCoreExpr fun+            addLoc (AnExpr rhs') $ lintCoreArgs fun_ty [Type t, info, e]+        )+        binders0+    go _ = markAllJoinsBad $ lintCoreExpr rhs++lintIdUnfolding :: Id -> Type -> Unfolding -> LintM ()+lintIdUnfolding bndr bndr_ty (CoreUnfolding { uf_tmpl = rhs, uf_src = src })+  | isStableSource src+  = do { ty <- lintRhs bndr rhs+       ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) }++lintIdUnfolding bndr bndr_ty (DFunUnfolding { df_con = con, df_bndrs = bndrs+                                            , df_args = args })+  = do { ty <- lintBinders LambdaBind bndrs $ \ bndrs' ->+               do { res_ty <- lintCoreArgs (dataConRepType con) args+                  ; return (mkLamTypes bndrs' res_ty) }+       ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "dfun unfolding") ty) }++lintIdUnfolding  _ _ _+  = return ()       -- Do not Lint unstable unfoldings, because that leads+                    -- to exponential behaviour; c.f. CoreFVs.idUnfoldingVars++{-+Note [Checking for INLINE loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's very suspicious if a strong loop breaker is marked INLINE.++However, the desugarer generates instance methods with INLINE pragmas+that form a mutually recursive group.  Only after a round of+simplification are they unravelled.  So we suppress the test for+the desugarer.++************************************************************************+*                                                                      *+\subsection[lintCoreExpr]{lintCoreExpr}+*                                                                      *+************************************************************************+-}++-- For OutType, OutKind, the substitution has been applied,+--                       but has not been linted yet++type LintedType  = Type -- Substitution applied, and type is linted+type LintedKind  = Kind++lintCoreExpr :: CoreExpr -> LintM OutType+-- The returned type has the substitution from the monad+-- already applied to it:+--      lintCoreExpr e subst = exprType (subst e)+--+-- The returned "type" can be a kind, if the expression is (Type ty)++-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintCoreExpr (Var var)+  = lintVarOcc var 0++lintCoreExpr (Lit lit)+  = return (literalType lit)++lintCoreExpr (Cast expr co)+  = do { expr_ty <- markAllJoinsBad $ lintCoreExpr expr+       ; co' <- applySubstCo co+       ; (_, k2, from_ty, to_ty, r) <- lintCoercion co'+       ; lintL (classifiesTypeWithValues k2)+               (text "Target of cast not # or *:" <+> ppr co)+       ; lintRole co' Representational r+       ; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty)+       ; return to_ty }++lintCoreExpr (Tick tickish expr)+  = do case tickish of+         Breakpoint _ ids -> forM_ ids $ \id -> do+                               checkDeadIdOcc id+                               lookupIdInScope id+         _                -> return ()+       markAllJoinsBadIf block_joins $ lintCoreExpr expr+  where+    block_joins = not (tickish `tickishScopesLike` SoftScope)+      -- TODO Consider whether this is the correct rule. It is consistent with+      -- the simplifier's behaviour - cost-centre-scoped ticks become part of+      -- the continuation, and thus they behave like part of an evaluation+      -- context, but soft-scoped and non-scoped ticks simply wrap the result+      -- (see Simplify.simplTick).++lintCoreExpr (Let (NonRec tv (Type ty)) body)+  | isTyVar tv+  =     -- See Note [Linting type lets]+    do  { ty' <- applySubstTy ty+        ; lintTyBndr tv              $ \ tv' ->+    do  { addLoc (RhsOf tv) $ lintTyKind tv' ty'+                -- Now extend the substitution so we+                -- take advantage of it in the body+        ; extendSubstL tv ty'        $+          addLoc (BodyOfLetRec [tv]) $+          lintCoreExpr body } }++lintCoreExpr (Let (NonRec bndr rhs) body)+  | isId bndr+  = do  { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)+        ; addLoc (BodyOfLetRec [bndr])+                 (lintIdBndr NotTopLevel LetBind bndr $ \_ ->+                  addGoodJoins [bndr] $+                  lintCoreExpr body) }++  | otherwise+  = failWithL (mkLetErr bndr rhs)       -- Not quite accurate++lintCoreExpr e@(Let (Rec pairs) body)+  = lintLetBndrs NotTopLevel bndrs $+    addGoodJoins bndrs             $+    do  { -- Check that the list of pairs is non-empty+          checkL (not (null pairs)) (emptyRec e)++          -- Check that there are no duplicated binders+        ; checkL (null dups) (dupVars dups)++          -- Check that either all the binders are joins, or none+        ; checkL (all isJoinId bndrs || all (not . isJoinId) bndrs) $+            mkInconsistentRecMsg bndrs++        ; mapM_ (lintSingleBinding NotTopLevel Recursive) pairs+        ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }+  where+    bndrs = map fst pairs+    (_, dups) = removeDups compare bndrs++lintCoreExpr e@(App _ _)+  = addLoc (AnExpr e) $+    do { fun_ty <- lintCoreFun fun (length args)+       ; lintCoreArgs fun_ty args }+  where+    (fun, args) = collectArgs e++lintCoreExpr (Lam var expr)+  = addLoc (LambdaBodyOf var) $+    markAllJoinsBad $+    lintBinder LambdaBind var $ \ var' ->+    do { body_ty <- lintCoreExpr expr+       ; return $ mkLamType var' body_ty }++lintCoreExpr e@(Case scrut var alt_ty alts) =+       -- Check the scrutinee+  do { let scrut_diverges = exprIsBottom scrut+     ; scrut_ty <- markAllJoinsBad $ lintCoreExpr scrut+     ; (alt_ty, _) <- lintInTy alt_ty+     ; (var_ty, _) <- lintInTy (idType var)++     -- See Note [No alternatives lint check]+     ; when (null alts) $+     do { checkL (not (exprIsHNF scrut))+          (text "No alternatives for a case scrutinee in head-normal form:" <+> ppr scrut)+        ; checkWarnL scrut_diverges+          (text "No alternatives for a case scrutinee not known to diverge for sure:" <+> ppr scrut)+        }++     -- See Note [Rules for floating-point comparisons] in PrelRules+     ; let isLitPat (LitAlt _, _ , _) = True+           isLitPat _                 = False+     ; checkL (not $ isFloatingTy scrut_ty && any isLitPat alts)+         (ptext (sLit $ "Lint warning: Scrutinising floating-point " +++                        "expression with literal pattern in case " +++                        "analysis (see Trac #9238).")+          $$ text "scrut" <+> ppr scrut)++     ; case tyConAppTyCon_maybe (idType var) of+         Just tycon+              | debugIsOn+              , isAlgTyCon tycon+              , not (isAbstractTyCon tycon)+              , null (tyConDataCons tycon)+              , not scrut_diverges+              -> pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var))+                        -- This can legitimately happen for type families+                      $ return ()+         _otherwise -> return ()++        -- Don't use lintIdBndr on var, because unboxed tuple is legitimate++     ; subst <- getTCvSubst+     ; ensureEqTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)++     ; lintIdBndr NotTopLevel CaseBind var $ \_ ->+       do { -- Check the alternatives+            mapM_ (lintCoreAlt scrut_ty alt_ty) alts+          ; checkCaseAlts e scrut_ty alts+          ; return alt_ty } }++-- This case can't happen; linting types in expressions gets routed through+-- lintCoreArgs+lintCoreExpr (Type ty)+  = failWithL (text "Type found as expression" <+> ppr ty)++lintCoreExpr (Coercion co)+  = do { (k1, k2, ty1, ty2, role) <- lintInCo co+       ; return (mkHeteroCoercionType role k1 k2 ty1 ty2) }++----------------------+lintVarOcc :: Var -> Int -- Number of arguments (type or value) being passed+            -> LintM Type -- returns type of the *variable*+lintVarOcc var nargs+  = do  { checkL (isNonCoVarId var)+                 (text "Non term variable" <+> ppr var)++        -- Cneck that the type of the occurrence is the same+        -- as the type of the binding site+        ; ty   <- applySubstTy (idType var)+        ; var' <- lookupIdInScope var+        ; let ty' = idType var'+        ; ensureEqTys ty ty' $ mkBndrOccTypeMismatchMsg var' var ty' ty++          -- Check for a nested occurrence of the StaticPtr constructor.+          -- See Note [Checking StaticPtrs].+        ; lf <- getLintFlags+        ; when (nargs /= 0 && lf_check_static_ptrs lf /= AllowAnywhere) $+            checkL (idName var /= makeStaticName) $+              text "Found makeStatic nested in an expression"++        ; checkDeadIdOcc var+        ; checkJoinOcc var nargs++        ; return (idType var') }++lintCoreFun :: CoreExpr+            -> Int        -- Number of arguments (type or val) being passed+            -> LintM Type -- Returns type of the *function*+lintCoreFun (Var var) nargs+  = lintVarOcc var nargs++lintCoreFun (Lam var body) nargs+  -- Act like lintCoreExpr of Lam, but *don't* call markAllJoinsBad; see+  -- Note [Beta redexes]+  | nargs /= 0+  = addLoc (LambdaBodyOf var) $+    lintBinder LambdaBind var $ \ var' ->+    do { body_ty <- lintCoreFun body (nargs - 1)+       ; return $ mkLamType var' body_ty }++lintCoreFun expr nargs+  = markAllJoinsBadIf (nargs /= 0) $+    lintCoreExpr expr++------------------+checkDeadIdOcc :: Id -> LintM ()+-- Occurrences of an Id should never be dead....+-- except when we are checking a case pattern+checkDeadIdOcc id+  | isDeadOcc (idOccInfo id)+  = do { in_case <- inCasePat+       ; checkL in_case+                (text "Occurrence of a dead Id" <+> ppr id) }+  | otherwise+  = return ()++------------------+checkJoinOcc :: Id -> JoinArity -> LintM ()+-- Check that if the occurrence is a JoinId, then so is the+-- binding site, and it's a valid join Id+checkJoinOcc var n_args+  | Just join_arity_occ <- isJoinId_maybe var+  = do { mb_join_arity_bndr <- lookupJoinId var+       ; case mb_join_arity_bndr of {+           Nothing -> -- Binder is not a join point+                      addErrL (invalidJoinOcc var) ;++           Just join_arity_bndr ->++    do { checkL (join_arity_bndr == join_arity_occ) $+           -- Arity differs at binding site and occurrence+         mkJoinBndrOccMismatchMsg var join_arity_bndr join_arity_occ++       ; checkL (n_args == join_arity_occ) $+           -- Arity doesn't match #args+         mkBadJumpMsg var join_arity_occ n_args } } }++  | otherwise+  = return ()++{-+Note [No alternatives lint check]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Case expressions with no alternatives are odd beasts, and worth looking at+in the linter (cf Trac #10180).  We check two things:++* exprIsHNF is false: certainly, it would be terribly wrong if the+  scrutinee was already in head normal form.++* exprIsBottom is true: we should be able to see why GHC believes the+  scrutinee is diverging for sure.++In principle, the first check is redundant: exprIsBottom == True will+always imply exprIsHNF == False.  But the first check is reliable: If+exprIsHNF == True, then there definitely is a problem (exprIsHNF errs+on the right side).  If the second check triggers then it may be the+case that the compiler got smarter elsewhere, and the empty case is+correct, but that exprIsBottom is unable to see it. In particular, the+empty-type check in exprIsBottom is an approximation. Therefore, this+check is not fully reliable, and we keep both around.++Note [Beta redexes]+~~~~~~~~~~~~~~~~~~~+Consider:++  join j @x y z = ... in+  (\@x y z -> jump j @x y z) @t e1 e2++This is clearly ill-typed, since the jump is inside both an application and a+lambda, either of which is enough to disqualify it as a tail call (see Note+[Invariants on join points] in CoreSyn). However, strictly from a+lambda-calculus perspective, the term doesn't go wrong---after the two beta+reductions, the jump *is* a tail call and everything is fine.++Why would we want to allow this when we have let? One reason is that a compound+beta redex (that is, one with more than one argument) has different scoping+rules: naively reducing the above example using lets will capture any free+occurrence of y in e2. More fundamentally, type lets are tricky; many passes,+such as Float Out, tacitly assume that the incoming program's type lets have+all been dealt with by the simplifier. Thus we don't want to let-bind any types+in, say, CoreSubst.simpleOptPgm, which in some circumstances can run immediately+before Float Out.++All that said, currently CoreSubst.simpleOptPgm is the only thing using this+loophole, doing so to avoid re-traversing large functions (beta-reducing a type+lambda without introducing a type let requires a substitution). TODO: Improve+simpleOptPgm so that we can forget all this ever happened.++************************************************************************+*                                                                      *+\subsection[lintCoreArgs]{lintCoreArgs}+*                                                                      *+************************************************************************++The basic version of these functions checks that the argument is a+subtype of the required type, as one would expect.+-}+++lintCoreArgs  :: OutType -> [CoreArg] -> LintM OutType+lintCoreArgs fun_ty args = foldM lintCoreArg fun_ty args++lintCoreArg  :: OutType -> CoreArg -> LintM OutType+lintCoreArg fun_ty (Type arg_ty)+  = do { checkL (not (isCoercionTy arg_ty))+                (text "Unnecessary coercion-to-type injection:"+                  <+> ppr arg_ty)+       ; arg_ty' <- applySubstTy arg_ty+       ; lintTyApp fun_ty arg_ty' }++lintCoreArg fun_ty arg+  = do { arg_ty <- markAllJoinsBad $ lintCoreExpr arg+           -- See Note [Levity polymorphism invariants] in CoreSyn+       ; lintL (not (isTypeLevPoly arg_ty))+           (text "Levity-polymorphic argument:" <+>+             (ppr arg <+> dcolon <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))))+          -- check for levity polymorphism first, because otherwise isUnliftedType panics++       ; checkL (not (isUnliftedType arg_ty) || exprOkForSpeculation arg)+                (mkLetAppMsg arg)+       ; lintValApp arg fun_ty arg_ty }++-----------------+lintAltBinders :: OutType     -- Scrutinee type+               -> OutType     -- Constructor type+               -> [OutVar]    -- Binders+               -> LintM ()+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintAltBinders scrut_ty con_ty []+  = ensureEqTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty)+lintAltBinders scrut_ty con_ty (bndr:bndrs)+  | isTyVar bndr+  = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr)+       ; lintAltBinders scrut_ty con_ty' bndrs }+  | otherwise+  = do { con_ty' <- lintValApp (Var bndr) con_ty (idType bndr)+       ; lintAltBinders scrut_ty con_ty' bndrs }++-----------------+lintTyApp :: OutType -> OutType -> LintM OutType+lintTyApp fun_ty arg_ty+  | Just (tv,body_ty) <- splitForAllTy_maybe fun_ty+  = do  { lintTyKind tv arg_ty+        ; in_scope <- getInScope+        -- substTy needs the set of tyvars in scope to avoid generating+        -- uniques that are already in scope.+        -- See Note [The substitution invariant] in TyCoRep+        ; return (substTyWithInScope in_scope [tv] [arg_ty] body_ty) }++  | otherwise+  = failWithL (mkTyAppMsg fun_ty arg_ty)++-----------------+lintValApp :: CoreExpr -> OutType -> OutType -> LintM OutType+lintValApp arg fun_ty arg_ty+  | Just (arg,res) <- splitFunTy_maybe fun_ty+  = do { ensureEqTys arg arg_ty err1+       ; return res }+  | otherwise+  = failWithL err2+  where+    err1 = mkAppMsg       fun_ty arg_ty arg+    err2 = mkNonFunAppMsg fun_ty arg_ty arg++lintTyKind :: OutTyVar -> OutType -> LintM ()+-- Both args have had substitution applied++-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintTyKind tyvar arg_ty+        -- Arg type might be boxed for a function with an uncommitted+        -- tyvar; notably this is used so that we can give+        --      error :: forall a:*. String -> a+        -- and then apply it to both boxed and unboxed types.+  = do { arg_kind <- lintType arg_ty+       ; unless (arg_kind `eqType` tyvar_kind)+                (addErrL (mkKindErrMsg tyvar arg_ty $$ (text "Linted Arg kind:" <+> ppr arg_kind))) }+  where+    tyvar_kind = tyVarKind tyvar++{-+************************************************************************+*                                                                      *+\subsection[lintCoreAlts]{lintCoreAlts}+*                                                                      *+************************************************************************+-}++checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()+-- a) Check that the alts are non-empty+-- b1) Check that the DEFAULT comes first, if it exists+-- b2) Check that the others are in increasing order+-- c) Check that there's a default for infinite types+-- NB: Algebraic cases are not necessarily exhaustive, because+--     the simplifier correctly eliminates case that can't+--     possibly match.++checkCaseAlts e ty alts =+  do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)+     ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)++          -- For types Int#, Word# with an infinite (well, large!) number of+          -- possible values, there should usually be a DEFAULT case+          -- But (see Note [Empty case alternatives] in CoreSyn) it's ok to+          -- have *no* case alternatives.+          -- In effect, this is a kind of partial test. I suppose it's possible+          -- that we might *know* that 'x' was 1 or 2, in which case+          --   case x of { 1 -> e1; 2 -> e2 }+          -- would be fine.+     ; checkL (isJust maybe_deflt || not is_infinite_ty || null alts)+              (nonExhaustiveAltsMsg e) }+  where+    (con_alts, maybe_deflt) = findDefault alts++        -- Check that successive alternatives have increasing tags+    increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest+    increasing_tag _                         = True++    non_deflt (DEFAULT, _, _) = False+    non_deflt _               = True++    is_infinite_ty = case tyConAppTyCon_maybe ty of+                        Nothing    -> False+                        Just tycon -> isPrimTyCon tycon++lintAltExpr :: CoreExpr -> OutType -> LintM ()+lintAltExpr expr ann_ty+  = do { actual_ty <- lintCoreExpr expr+       ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }++lintCoreAlt :: OutType          -- Type of scrutinee+            -> OutType          -- Type of the alternative+            -> CoreAlt+            -> LintM ()+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintCoreAlt _ alt_ty (DEFAULT, args, rhs) =+  do { lintL (null args) (mkDefaultArgsMsg args)+     ; lintAltExpr rhs alt_ty }++lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs)+  | litIsLifted lit+  = failWithL integerScrutinisedMsg+  | otherwise+  = do { lintL (null args) (mkDefaultArgsMsg args)+       ; ensureEqTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)+       ; lintAltExpr rhs alt_ty }+  where+    lit_ty = literalType lit++lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)+  | isNewTyCon (dataConTyCon con)+  = addErrL (mkNewTyDataConAltMsg scrut_ty alt)+  | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty+  = addLoc (CaseAlt alt) $  do+    {   -- First instantiate the universally quantified+        -- type variables of the data constructor+        -- We've already check+      lintL (tycon == dataConTyCon con) (mkBadConMsg tycon con)+    ; let con_payload_ty = piResultTys (dataConRepType con) tycon_arg_tys++        -- And now bring the new binders into scope+    ; lintBinders CasePatBind args $ \ args' -> do+    { addLoc (CasePat alt) (lintAltBinders scrut_ty con_payload_ty args')+    ; lintAltExpr rhs alt_ty } }++  | otherwise   -- Scrut-ty is wrong shape+  = addErrL (mkBadAltMsg scrut_ty alt)++{-+************************************************************************+*                                                                      *+\subsection[lint-types]{Types}+*                                                                      *+************************************************************************+-}++-- When we lint binders, we (one at a time and in order):+--  1. Lint var types or kinds (possibly substituting)+--  2. Add the binder to the in scope set, and if its a coercion var,+--     we may extend the substitution to reflect its (possibly) new kind+lintBinders :: BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a+lintBinders _    []         linterF = linterF []+lintBinders site (var:vars) linterF = lintBinder site var $ \var' ->+                                      lintBinders site vars $ \ vars' ->+                                      linterF (var':vars')++-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintBinder :: BindingSite -> Var -> (Var -> LintM a) -> LintM a+lintBinder site var linterF+  | isTyVar var = lintTyBndr                  var linterF+  | isCoVar var = lintCoBndr                  var linterF+  | otherwise   = lintIdBndr NotTopLevel site var linterF++lintTyBndr :: InTyVar -> (OutTyVar -> LintM a) -> LintM a+lintTyBndr tv thing_inside+  = do { subst <- getTCvSubst+       ; let (subst', tv') = substTyVarBndr subst tv+       ; lintKind (varType tv')+       ; updateTCvSubst subst' (thing_inside tv') }++lintCoBndr :: InCoVar -> (OutCoVar -> LintM a) -> LintM a+lintCoBndr cv thing_inside+  = do { subst <- getTCvSubst+       ; let (subst', cv') = substCoVarBndr subst cv+       ; lintKind (varType cv')+       ; lintL (isCoercionType (varType cv'))+               (text "CoVar with non-coercion type:" <+> pprTyVar cv)+       ; updateTCvSubst subst' (thing_inside cv') }++lintLetBndrs :: TopLevelFlag -> [Var] -> LintM a -> LintM a+lintLetBndrs top_lvl ids linterF+  = go ids+  where+    go []       = linterF+    go (id:ids) = lintIdBndr top_lvl LetBind id  $ \_ ->+                  go ids++lintIdBndr :: TopLevelFlag -> BindingSite+           -> InVar -> (OutVar -> LintM a) -> LintM a+-- Do substitution on the type of a binder and add the var with this+-- new type to the in-scope set of the second argument+-- ToDo: lint its rules+lintIdBndr top_lvl bind_site id linterF+  = ASSERT2( isId id, ppr id )+    do { flags <- getLintFlags+       ; checkL (not (lf_check_global_ids flags) || isLocalId id)+                (text "Non-local Id binder" <+> ppr id)+                -- See Note [Checking for global Ids]++       -- Check that if the binder is nested, it is not marked as exported+       ; checkL (not (isExportedId id) || is_top_lvl)+           (mkNonTopExportedMsg id)++       -- Check that if the binder is nested, it does not have an external name+       ; checkL (not (isExternalName (Var.varName id)) || is_top_lvl)+           (mkNonTopExternalNameMsg id)++       ; (ty, k) <- lintInTy (idType id)+          -- See Note [Levity polymorphism invariants] in CoreSyn+       ; lintL (isJoinId id || not (isKindLevPoly k))+           (text "Levity-polymorphic binder:" <+>+                 (ppr id <+> dcolon <+> parens (ppr ty <+> dcolon <+> ppr k)))++       -- Check that a join-id is a not-top-level let-binding+       ; when (isJoinId id) $+         checkL (not is_top_lvl && is_let_bind) $+         mkBadJoinBindMsg id++       ; let id' = setIdType id ty+       ; addInScopeVar id' $ (linterF id') }+  where+    is_top_lvl = isTopLevel top_lvl+    is_let_bind = case bind_site of+                    LetBind -> True+                    _       -> False++{-+%************************************************************************+%*                                                                      *+             Types+%*                                                                      *+%************************************************************************+-}++lintInTy :: InType -> LintM (LintedType, LintedKind)+-- Types only, not kinds+-- Check the type, and apply the substitution to it+-- See Note [Linting type lets]+lintInTy ty+  = addLoc (InType ty) $+    do  { ty' <- applySubstTy ty+        ; k  <- lintType ty'+        ; lintKind k+        ; return (ty', k) }++checkTyCon :: TyCon -> LintM ()+checkTyCon tc+  = checkL (not (isTcTyCon tc)) (text "Found TcTyCon:" <+> ppr tc)++-------------------+lintType :: OutType -> LintM LintedKind+-- The returned Kind has itself been linted++-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintType (TyVarTy tv)+  = do { checkL (isTyVar tv) (mkBadTyVarMsg tv)+       ; lintTyCoVarInScope tv+       ; return (tyVarKind tv) }+         -- We checked its kind when we added it to the envt++lintType ty@(AppTy t1 t2)+  | TyConApp {} <- t1+  = failWithL $ text "TyConApp to the left of AppTy:" <+> ppr ty+  | otherwise+  = do { k1 <- lintType t1+       ; k2 <- lintType t2+       ; lint_ty_app ty k1 [(t2,k2)] }++lintType ty@(TyConApp tc tys)+  | Just ty' <- coreView ty+  = lintType ty'   -- Expand type synonyms, so that we do not bogusly complain+                   --  about un-saturated type synonyms++  -- We should never see a saturated application of funTyCon; such applications+  -- should be represented with the FunTy constructor. See Note [Linting+  -- function types] and Note [Representation of function types].+  | isFunTyCon tc+  , length tys == 4+  = failWithL (hang (text "Saturated application of (->)") 2 (ppr ty))++  | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc+       -- Also type synonyms and type families+  , length tys < tyConArity tc+  = failWithL (hang (text "Un-saturated type application") 2 (ppr ty))++  | otherwise+  = do { checkTyCon tc+       ; ks <- mapM lintType tys+       ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) }++-- arrows can related *unlifted* kinds, so this has to be separate from+-- a dependent forall.+lintType ty@(FunTy t1 t2)+  = do { k1 <- lintType t1+       ; k2 <- lintType t2+       ; lintArrow (text "type or kind" <+> quotes (ppr ty)) k1 k2 }++lintType t@(ForAllTy (TvBndr tv _vis) ty)+  = do { lintL (isTyVar tv) (text "Covar bound in type:" <+> ppr t)+       ; lintTyBndr tv $ \tv' ->+          do { k <- lintType ty+             ; lintL (not (tv' `elemVarSet` tyCoVarsOfType k))+                     (text "Variable escape in forall:" <+> ppr t)+             ; lintL (classifiesTypeWithValues k)+                     (text "Non-* and non-# kind in forall:" <+> ppr t)+             ; return k }}++lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty)++lintType (CastTy ty co)+  = do { k1 <- lintType ty+       ; (k1', k2) <- lintStarCoercion co+       ; ensureEqTys k1 k1' (mkCastErr ty co k1' k1)+       ; return k2 }++lintType (CoercionTy co)+  = do { (k1, k2, ty1, ty2, r) <- lintCoercion co+       ; return $ mkHeteroCoercionType r k1 k2 ty1 ty2 }++lintKind :: OutKind -> LintM ()+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintKind k = do { sk <- lintType k+                ; unless (classifiesTypeWithValues sk)+                         (addErrL (hang (text "Ill-kinded kind:" <+> ppr k)+                                      2 (text "has kind:" <+> ppr sk))) }++-- confirms that a type is really *+lintStar :: SDoc -> OutKind -> LintM ()+lintStar doc k+  = lintL (classifiesTypeWithValues k)+          (text "Non-*-like kind when *-like expected:" <+> ppr k $$+           text "when checking" <+> doc)++lintArrow :: SDoc -> LintedKind -> LintedKind -> LintM LintedKind+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintArrow what k1 k2   -- Eg lintArrow "type or kind `blah'" k1 k2+                       -- or lintarrow "coercion `blah'" k1 k2+  = do { unless (okArrowArgKind k1)    (addErrL (msg (text "argument") k1))+       ; unless (okArrowResultKind k2) (addErrL (msg (text "result")   k2))+       ; return liftedTypeKind }+  where+    msg ar k+      = vcat [ hang (text "Ill-kinded" <+> ar)+                  2 (text "in" <+> what)+             , what <+> text "kind:" <+> ppr k ]++lint_ty_app :: Type -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind+lint_ty_app ty k tys+  = lint_app (text "type" <+> quotes (ppr ty)) k tys++----------------+lint_co_app :: Coercion -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind+lint_co_app ty k tys+  = lint_app (text "coercion" <+> quotes (ppr ty)) k tys++----------------+lintTyLit :: TyLit -> LintM ()+lintTyLit (NumTyLit n)+  | n >= 0    = return ()+  | otherwise = failWithL msg+    where msg = text "Negative type literal:" <+> integer n+lintTyLit (StrTyLit _) = return ()++lint_app :: SDoc -> LintedKind -> [(LintedType,LintedKind)] -> LintM Kind+-- (lint_app d fun_kind arg_tys)+--    We have an application (f arg_ty1 .. arg_tyn),+--    where f :: fun_kind+-- Takes care of linting the OutTypes++-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lint_app doc kfn kas+    = do { in_scope <- getInScope+         -- We need the in_scope set to satisfy the invariant in+         -- Note [The substitution invariant] in TyCoRep+         ; foldlM (go_app in_scope) kfn kas }+  where+    fail_msg = vcat [ hang (text "Kind application error in") 2 doc+                    , nest 2 (text "Function kind =" <+> ppr kfn)+                    , nest 2 (text "Arg kinds =" <+> ppr kas) ]++    go_app in_scope kfn ka+      | Just kfn' <- coreView kfn+      = go_app in_scope kfn' ka++    go_app _ (FunTy kfa kfb) (_,ka)+      = do { unless (ka `eqType` kfa) (addErrL fail_msg)+           ; return kfb }++    go_app in_scope (ForAllTy (TvBndr kv _vis) kfn) (ta,ka)+      = do { unless (ka `eqType` tyVarKind kv) (addErrL fail_msg)+           ; return (substTyWithInScope in_scope [kv] [ta] kfn) }++    go_app _ _ _ = failWithL fail_msg++{- *********************************************************************+*                                                                      *+        Linting rules+*                                                                      *+********************************************************************* -}++lintCoreRule :: OutVar -> OutType -> CoreRule -> LintM ()+lintCoreRule _ _ (BuiltinRule {})+  = return ()  -- Don't bother++lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs+                                   , ru_args = args, ru_rhs = rhs })+  = lintBinders LambdaBind bndrs $ \ _ ->+    do { lhs_ty <- foldM lintCoreArg fun_ty args+       ; rhs_ty <- case isJoinId_maybe fun of+                     Just join_arity+                       -> do { checkL (args `lengthIs` join_arity) $+                                 mkBadJoinPointRuleMsg fun join_arity rule+                               -- See Note [Rules for join points]+                             ; lintCoreExpr rhs }+                     _ -> markAllJoinsBad $ lintCoreExpr rhs+       ; ensureEqTys lhs_ty rhs_ty $+         (rule_doc <+> vcat [ text "lhs type:" <+> ppr lhs_ty+                            , text "rhs type:" <+> ppr rhs_ty ])+       ; let bad_bndrs = filterOut (`elemVarSet` exprsFreeVars args) $+                         filter (`elemVarSet` exprFreeVars rhs) $+                         bndrs++       ; checkL (null bad_bndrs)+                (rule_doc <+> text "unbound" <+> ppr bad_bndrs)+            -- See Note [Linting rules]+    }+  where+    rule_doc = text "Rule" <+> doubleQuotes (ftext name) <> colon++{- Note [Linting rules]+~~~~~~~~~~~~~~~~~~~~~~~+It's very bad if simplifying a rule means that one of the template+variables (ru_bndrs) that /is/ mentioned on the RHS becomes+not-mentioned in the LHS (ru_args).  How can that happen?  Well, in+Trac #10602, SpecConstr stupidly constructed a rule like++  forall x,c1,c2.+     f (x |> c1 |> c2) = ....++But simplExpr collapses those coercions into one.  (Indeed in+Trac #10602, it collapsed to the identity and was removed altogether.)++We don't have a great story for what to do here, but at least+this check will nail it.++NB (Trac #11643): it's possible that a variable listed in the+binders becomes not-mentioned on both LHS and RHS.  Here's a silly+example:+   RULE forall x y. f (g x y) = g (x+1 (y-1)+And suppose worker/wrapper decides that 'x' is Absent.  Then+we'll end up with+   RULE forall x y. f ($gw y) = $gw (x+1)+This seems sufficiently obscure that there isn't enough payoff to+try to trim the forall'd binder list.++Note [Rules for join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~++A join point cannot be partially applied. However, the left-hand side of a rule+for a join point is effectively a *pattern*, not a piece of code, so there's an+argument to be made for allowing a situation like this:++  join $sj :: Int -> Int -> String+       $sj n m = ...+       j :: forall a. Eq a => a -> a -> String+       {-# RULES "SPEC j" jump j @ Int $dEq = jump $sj #-}+       j @a $dEq x y = ...++Applying this rule can't turn a well-typed program into an ill-typed one, so+conceivably we could allow it. But we can always eta-expand such an+"undersaturated" rule (see 'CoreArity.etaExpandToJoinPointRule'), and in fact+the simplifier would have to in order to deal with the RHS. So we take a+conservative view and don't allow undersaturated rules for join points. See+Note [Rules and join points] in OccurAnal for further discussion.+-}++{-+************************************************************************+*                                                                      *+         Linting coercions+*                                                                      *+************************************************************************+-}++lintInCo :: InCoercion -> LintM (LintedKind, LintedKind, LintedType, LintedType, Role)+-- Check the coercion, and apply the substitution to it+-- See Note [Linting type lets]+lintInCo co+  = addLoc (InCo co) $+    do  { co' <- applySubstCo co+        ; lintCoercion co' }++-- lints a coercion, confirming that its lh kind and its rh kind are both *+-- also ensures that the role is Nominal+lintStarCoercion :: OutCoercion -> LintM (LintedType, LintedType)+lintStarCoercion g+  = do { (k1, k2, t1, t2, r) <- lintCoercion g+       ; lintStar (text "the kind of the left type in" <+> ppr g) k1+       ; lintStar (text "the kind of the right type in" <+> ppr g) k2+       ; lintRole g Nominal r+       ; return (t1, t2) }++lintCoercion :: OutCoercion -> LintM (LintedKind, LintedKind, LintedType, LintedType, Role)+-- Check the kind of a coercion term, returning the kind+-- Post-condition: the returned OutTypes are lint-free+--+-- If   lintCoercion co = (k1, k2, s1, s2, r)+-- then co :: s1 ~r s2+--      s1 :: k2+--      s2 :: k2++-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintCoercion (Refl r ty)+  = do { k <- lintType ty+       ; return (k, k, ty, ty, r) }++lintCoercion co@(TyConAppCo r tc cos)+  | tc `hasKey` funTyConKey+  , [_rep1,_rep2,_co1,_co2] <- cos+  = do { failWithL (text "Saturated TyConAppCo (->):" <+> ppr co)+       } -- All saturated TyConAppCos should be FunCos++  | Just {} <- synTyConDefn_maybe tc+  = failWithL (text "Synonym in TyConAppCo:" <+> ppr co)++  | otherwise+  = do { checkTyCon tc+       ; (k's, ks, ss, ts, rs) <- mapAndUnzip5M lintCoercion cos+       ; k' <- lint_co_app co (tyConKind tc) (ss `zip` k's)+       ; k <- lint_co_app co (tyConKind tc) (ts `zip` ks)+       ; _ <- zipWith3M lintRole cos (tyConRolesX r tc) rs+       ; return (k', k, mkTyConApp tc ss, mkTyConApp tc ts, r) }++lintCoercion co@(AppCo co1 co2)+  | TyConAppCo {} <- co1+  = failWithL (text "TyConAppCo to the left of AppCo:" <+> ppr co)+  | Refl _ (TyConApp {}) <- co1+  = failWithL (text "Refl (TyConApp ...) to the left of AppCo:" <+> ppr co)+  | otherwise+  = do { (k1,  k2,  s1, s2, r1) <- lintCoercion co1+       ; (k'1, k'2, t1, t2, r2) <- lintCoercion co2+       ; k3 <- lint_co_app co k1 [(t1,k'1)]+       ; k4 <- lint_co_app co k2 [(t2,k'2)]+       ; if r1 == Phantom+         then lintL (r2 == Phantom || r2 == Nominal)+                     (text "Second argument in AppCo cannot be R:" $$+                      ppr co)+         else lintRole co Nominal r2+       ; return (k3, k4, mkAppTy s1 t1, mkAppTy s2 t2, r1) }++----------+lintCoercion (ForAllCo tv1 kind_co co)+  = do { (_, k2) <- lintStarCoercion kind_co+       ; let tv2 = setTyVarKind tv1 k2+       ; addInScopeVar tv1 $+    do {+       ; (k3, k4, t1, t2, r) <- lintCoercion co+       ; in_scope <- getInScope+       ; let tyl = mkInvForAllTy tv1 t1+             subst = mkTvSubst in_scope $+                     -- We need both the free vars of the `t2` and the+                     -- free vars of the range of the substitution in+                     -- scope. All the free vars of `t2` and `kind_co` should+                     -- already be in `in_scope`, because they've been+                     -- linted and `tv2` has the same unique as `tv1`.+                     -- See Note [The substitution invariant]+                     unitVarEnv tv1 (TyVarTy tv2 `mkCastTy` mkSymCo kind_co)+             tyr = mkInvForAllTy tv2 $+                   substTy subst t2+       ; return (k3, k4, tyl, tyr, r) } }++lintCoercion co@(FunCo r co1 co2)+  = do { (k1,k'1,s1,t1,r1) <- lintCoercion co1+       ; (k2,k'2,s2,t2,r2) <- lintCoercion co2+       ; k <- lintArrow (text "coercion" <+> quotes (ppr co)) k1 k2+       ; k' <- lintArrow (text "coercion" <+> quotes (ppr co)) k'1 k'2+       ; lintRole co1 r r1+       ; lintRole co2 r r2+       ; return (k, k', mkFunTy s1 s2, mkFunTy t1 t2, r) }++lintCoercion (CoVarCo cv)+  | not (isCoVar cv)+  = failWithL (hang (text "Bad CoVarCo:" <+> ppr cv)+                  2 (text "With offending type:" <+> ppr (varType cv)))+  | otherwise+  = do { lintTyCoVarInScope cv+       ; cv' <- lookupIdInScope cv+       ; lintUnliftedCoVar cv+       ; return $ coVarKindsTypesRole cv' }++-- See Note [Bad unsafe coercion]+lintCoercion co@(UnivCo prov r ty1 ty2)+  = do { k1 <- lintType ty1+       ; k2 <- lintType ty2+       ; case prov of+           UnsafeCoerceProv -> return ()  -- no extra checks++           PhantomProv kco    -> do { lintRole co Phantom r+                                    ; check_kinds kco k1 k2 }++           ProofIrrelProv kco -> do { lintL (isCoercionTy ty1) $+                                          mkBadProofIrrelMsg ty1 co+                                    ; lintL (isCoercionTy ty2) $+                                          mkBadProofIrrelMsg ty2 co+                                    ; check_kinds kco k1 k2 }++           PluginProv _     -> return ()  -- no extra checks+           HoleProv h       -> addErrL $+                               text "Unfilled coercion hole:" <+> ppr h++       ; when (r /= Phantom && classifiesTypeWithValues k1+                            && classifiesTypeWithValues k2)+              (checkTypes ty1 ty2)+       ; return (k1, k2, ty1, ty2, r) }+   where+     report s = hang (text $ "Unsafe coercion between " ++ s)+                     2 (vcat [ text "From:" <+> ppr ty1+                             , text "  To:" <+> ppr ty2])+     isUnBoxed :: PrimRep -> Bool+     isUnBoxed = not . isGcPtrRep++       -- see #9122 for discussion of these checks+     checkTypes t1 t2+       = do { checkWarnL (reps1 `equalLength` reps2)+                         (report "values with different # of reps")+            ; zipWithM_ validateCoercion reps1 reps2 }+       where+         reps1 = typePrimRep t1+         reps2 = typePrimRep t2++     validateCoercion :: PrimRep -> PrimRep -> LintM ()+     validateCoercion rep1 rep2+       = do { dflags <- getDynFlags+            ; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2)+                         (report "unboxed and boxed value")+            ; checkWarnL (TyCon.primRepSizeW dflags rep1+                           == TyCon.primRepSizeW dflags rep2)+                         (report "unboxed values of different size")+            ; let fl = liftM2 (==) (TyCon.primRepIsFloat rep1)+                                   (TyCon.primRepIsFloat rep2)+            ; case fl of+                Nothing    -> addWarnL (report "vector types")+                Just False -> addWarnL (report "float and integral values")+                _          -> return ()+            }++     check_kinds kco k1 k2 = do { (k1', k2') <- lintStarCoercion kco+                                ; ensureEqTys k1 k1' (mkBadUnivCoMsg CLeft  co)+                                ; ensureEqTys k2 k2' (mkBadUnivCoMsg CRight co) }+++lintCoercion (SymCo co)+  = do { (k1, k2, ty1, ty2, r) <- lintCoercion co+       ; return (k2, k1, ty2, ty1, r) }++lintCoercion co@(TransCo co1 co2)+  = do { (k1a, _k1b, ty1a, ty1b, r1) <- lintCoercion co1+       ; (_k2a, k2b, ty2a, ty2b, r2) <- lintCoercion co2+       ; ensureEqTys ty1b ty2a+               (hang (text "Trans coercion mis-match:" <+> ppr co)+                   2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b]))+       ; lintRole co r1 r2+       ; return (k1a, k2b, ty1a, ty2b, r1) }++lintCoercion the_co@(NthCo n co)+  = do { (_, _, s, t, r) <- lintCoercion co+       ; case (splitForAllTy_maybe s, splitForAllTy_maybe t) of+         { (Just (tv_s, _ty_s), Just (tv_t, _ty_t))+             |  n == 0+             -> return (ks, kt, ts, tt, Nominal)+             where+               ts = tyVarKind tv_s+               tt = tyVarKind tv_t+               ks = typeKind ts+               kt = typeKind tt++         ; _ -> case (splitTyConApp_maybe s, splitTyConApp_maybe t) of+         { (Just (tc_s, tys_s), Just (tc_t, tys_t))+             | tc_s == tc_t+             , isInjectiveTyCon tc_s r+                 -- see Note [NthCo and newtypes] in TyCoRep+             , tys_s `equalLength` tys_t+             , n < length tys_s+             -> return (ks, kt, ts, tt, tr)+             where+               ts = getNth tys_s n+               tt = getNth tys_t n+               tr = nthRole r tc_s n+               ks = typeKind ts+               kt = typeKind tt++         ; _ -> failWithL (hang (text "Bad getNth:")+                              2 (ppr the_co $$ ppr s $$ ppr t)) }}}++lintCoercion the_co@(LRCo lr co)+  = do { (_,_,s,t,r) <- lintCoercion co+       ; lintRole co Nominal r+       ; case (splitAppTy_maybe s, splitAppTy_maybe t) of+           (Just s_pr, Just t_pr)+             -> return (ks_pick, kt_pick, s_pick, t_pick, Nominal)+             where+               s_pick  = pickLR lr s_pr+               t_pick  = pickLR lr t_pr+               ks_pick = typeKind s_pick+               kt_pick = typeKind t_pick++           _ -> failWithL (hang (text "Bad LRCo:")+                              2 (ppr the_co $$ ppr s $$ ppr t)) }++lintCoercion (InstCo co arg)+  = do { (k3, k4, t1',t2', r) <- lintCoercion co+       ; (k1',k2',s1,s2, r') <- lintCoercion arg+       ; lintRole arg Nominal r'+       ; in_scope <- getInScope+       ; case (splitForAllTy_maybe t1', splitForAllTy_maybe t2') of+          (Just (tv1,t1), Just (tv2,t2))+            | k1' `eqType` tyVarKind tv1+            , k2' `eqType` tyVarKind tv2+            -> return (k3, k4,+                       substTyWithInScope in_scope [tv1] [s1] t1,+                       substTyWithInScope in_scope [tv2] [s2] t2, r)+            | otherwise+            -> failWithL (text "Kind mis-match in inst coercion")+          _ -> failWithL (text "Bad argument of inst") }++lintCoercion co@(AxiomInstCo con ind cos)+  = do { unless (0 <= ind && ind < numBranches (coAxiomBranches con))+                (bad_ax (text "index out of range"))+       ; let CoAxBranch { cab_tvs   = ktvs+                        , cab_cvs   = cvs+                        , cab_roles = roles+                        , cab_lhs   = lhs+                        , cab_rhs   = rhs } = coAxiomNthBranch con ind+       ; unless (length ktvs + length cvs == length cos) $+           bad_ax (text "lengths")+       ; subst <- getTCvSubst+       ; let empty_subst = zapTCvSubst subst+       ; (subst_l, subst_r) <- foldlM check_ki+                                      (empty_subst, empty_subst)+                                      (zip3 (ktvs ++ cvs) roles cos)+       ; let lhs' = substTys subst_l lhs+             rhs' = substTy  subst_r rhs+       ; case checkAxInstCo co of+           Just bad_branch -> bad_ax $ text "inconsistent with" <+>+                                       pprCoAxBranch con bad_branch+           Nothing -> return ()+       ; let s2 = mkTyConApp (coAxiomTyCon con) lhs'+       ; return (typeKind s2, typeKind rhs', s2, rhs', coAxiomRole con) }+  where+    bad_ax what = addErrL (hang (text  "Bad axiom application" <+> parens what)+                        2 (ppr co))++    check_ki (subst_l, subst_r) (ktv, role, arg)+      = do { (k', k'', s', t', r) <- lintCoercion arg+           ; lintRole arg role r+           ; let ktv_kind_l = substTy subst_l (tyVarKind ktv)+                 ktv_kind_r = substTy subst_r (tyVarKind ktv)+           ; unless (k' `eqType` ktv_kind_l)+                    (bad_ax (text "check_ki1" <+> vcat [ ppr co, ppr k', ppr ktv, ppr ktv_kind_l ] ))+           ; unless (k'' `eqType` ktv_kind_r)+                    (bad_ax (text "check_ki2" <+> vcat [ ppr co, ppr k'', ppr ktv, ppr ktv_kind_r ] ))+           ; return (extendTCvSubst subst_l ktv s',+                     extendTCvSubst subst_r ktv t') }++lintCoercion (CoherenceCo co1 co2)+  = do { (_, k2, t1, t2, r) <- lintCoercion co1+       ; let lhsty = mkCastTy t1 co2+       ; k1' <- lintType lhsty+       ; return (k1', k2, lhsty, t2, r) }++lintCoercion (KindCo co)+  = do { (k1, k2, _, _, _) <- lintCoercion co+       ; return (liftedTypeKind, liftedTypeKind, k1, k2, Nominal) }++lintCoercion (SubCo co')+  = do { (k1,k2,s,t,r) <- lintCoercion co'+       ; lintRole co' Nominal r+       ; return (k1,k2,s,t,Representational) }++lintCoercion this@(AxiomRuleCo co cs)+  = do { eqs <- mapM lintCoercion cs+       ; lintRoles 0 (coaxrAsmpRoles co) eqs+       ; case coaxrProves co [ Pair l r | (_,_,l,r,_) <- eqs ] of+           Nothing -> err "Malformed use of AxiomRuleCo" [ ppr this ]+           Just (Pair l r) ->+             return (typeKind l, typeKind r, l, r, coaxrRole co) }+  where+  err m xs  = failWithL $+                hang (text m) 2 $ vcat (text "Rule:" <+> ppr (coaxrName co) : xs)++  lintRoles n (e : es) ((_,_,_,_,r) : rs)+    | e == r    = lintRoles (n+1) es rs+    | otherwise = err "Argument roles mismatch"+                      [ text "In argument:" <+> int (n+1)+                      , text "Expected:" <+> ppr e+                      , text "Found:" <+> ppr r ]+  lintRoles _ [] []  = return ()+  lintRoles n [] rs  = err "Too many coercion arguments"+                          [ text "Expected:" <+> int n+                          , text "Provided:" <+> int (n + length rs) ]++  lintRoles n es []  = err "Not enough coercion arguments"+                          [ text "Expected:" <+> int (n + length es)+                          , text "Provided:" <+> int n ]++----------+lintUnliftedCoVar :: CoVar -> LintM ()+lintUnliftedCoVar cv+  = when (not (isUnliftedType (coVarKind cv))) $+    failWithL (text "Bad lifted equality:" <+> ppr cv+                 <+> dcolon <+> ppr (coVarKind cv))++{-+************************************************************************+*                                                                      *+\subsection[lint-monad]{The Lint monad}+*                                                                      *+************************************************************************+-}++-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism]+data LintEnv+  = LE { le_flags :: LintFlags       -- Linting the result of this pass+       , le_loc   :: [LintLocInfo]   -- Locations+       , le_subst :: TCvSubst        -- Current type substitution; we also use this+                                     -- to keep track of all the variables in scope,+                                     -- both Ids and TyVars+       , le_joins :: IdSet           -- Join points in scope that are valid+                                     -- A subset of teh InScopeSet in le_subst+                                     -- See Note [Join points]+       , le_dynflags :: DynFlags     -- DynamicFlags+       }++data LintFlags+  = LF { lf_check_global_ids           :: Bool -- See Note [Checking for global Ids]+       , lf_check_inline_loop_breakers :: Bool -- See Note [Checking for INLINE loop breakers]+       , lf_check_static_ptrs          :: StaticPtrCheck+                                             -- ^ See Note [Checking StaticPtrs]+    }++-- See Note [Checking StaticPtrs]+data StaticPtrCheck+    = AllowAnywhere+        -- ^ Allow 'makeStatic' to occur anywhere.+    | AllowAtTopLevel+        -- ^ Allow 'makeStatic' calls at the top-level only.+    | RejectEverywhere+        -- ^ Reject any 'makeStatic' occurrence.+  deriving Eq++defaultLintFlags :: LintFlags+defaultLintFlags = LF { lf_check_global_ids = False+                      , lf_check_inline_loop_breakers = True+                      , lf_check_static_ptrs = AllowAnywhere+                      }++newtype LintM a =+   LintM { unLintM ::+            LintEnv ->+            WarnsAndErrs ->           -- Error and warning messages so far+            (Maybe a, WarnsAndErrs) } -- Result and messages (if any)++type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc)++{- Note [Checking for global Ids]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Before CoreTidy, all locally-bound Ids must be LocalIds, even+top-level ones. See Note [Exported LocalIds] and Trac #9857.++Note [Checking StaticPtrs]+~~~~~~~~~~~~~~~~~~~~~~~~~~+See Note [Grand plan for static forms] in StaticPtrTable for an overview.++Every occurrence of the function 'makeStatic' should be moved to the+top level by the FloatOut pass.  It's vital that we don't have nested+'makeStatic' occurrences after CorePrep, because we populate the Static+Pointer Table from the top-level bindings. See SimplCore Note [Grand+plan for static forms].++The linter checks that no occurrence is left behind, nested within an+expression. The check is enabled only after the FloatOut, CorePrep,+and CoreTidy passes and only if the module uses the StaticPointers+language extension. Checking more often doesn't help since the condition+doesn't hold until after the first FloatOut pass.++Note [Type substitution]+~~~~~~~~~~~~~~~~~~~~~~~~+Why do we need a type substitution?  Consider+        /\(a:*). \(x:a). /\(a:*). id a x+This is ill typed, because (renaming variables) it is really+        /\(a:*). \(x:a). /\(b:*). id b x+Hence, when checking an application, we can't naively compare x's type+(at its binding site) with its expected type (at a use site).  So we+rename type binders as we go, maintaining a substitution.++The same substitution also supports let-type, current expressed as+        (/\(a:*). body) ty+Here we substitute 'ty' for 'a' in 'body', on the fly.+-}++instance Functor LintM where+      fmap = liftM++instance Applicative LintM where+      pure x = LintM $ \ _ errs -> (Just x, errs)+      (<*>) = ap++instance Monad LintM where+  fail err = failWithL (text err)+  m >>= k  = LintM (\ env errs ->+                       let (res, errs') = unLintM m env errs in+                         case res of+                           Just r -> unLintM (k r) env errs'+                           Nothing -> (Nothing, errs'))++#if __GLASGOW_HASKELL__ > 710+instance MonadFail.MonadFail LintM where+    fail err = failWithL (text err)+#endif++instance HasDynFlags LintM where+  getDynFlags = LintM (\ e errs -> (Just (le_dynflags e), errs))++data LintLocInfo+  = RhsOf Id            -- The variable bound+  | LambdaBodyOf Id     -- The lambda-binder+  | BodyOfLetRec [Id]   -- One of the binders+  | CaseAlt CoreAlt     -- Case alternative+  | CasePat CoreAlt     -- The *pattern* of the case alternative+  | AnExpr CoreExpr     -- Some expression+  | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)+  | TopLevelBindings+  | InType Type         -- Inside a type+  | InCo   Coercion     -- Inside a coercion++initL :: DynFlags -> LintFlags -> InScopeSet+       -> LintM a -> WarnsAndErrs    -- Errors and warnings+initL dflags flags in_scope m+  = case unLintM m env (emptyBag, emptyBag) of+      (_, errs) -> errs+  where+    env = LE { le_flags = flags+             , le_subst = mkEmptyTCvSubst in_scope+             , le_joins = emptyVarSet+             , le_loc = []+             , le_dynflags = dflags }++getLintFlags :: LintM LintFlags+getLintFlags = LintM $ \ env errs -> (Just (le_flags env), errs)++checkL :: Bool -> MsgDoc -> LintM ()+checkL True  _   = return ()+checkL False msg = failWithL msg++-- like checkL, but relevant to type checking+lintL :: Bool -> MsgDoc -> LintM ()+lintL = checkL++checkWarnL :: Bool -> MsgDoc -> LintM ()+checkWarnL True   _  = return ()+checkWarnL False msg = addWarnL msg++failWithL :: MsgDoc -> LintM a+failWithL msg = LintM $ \ env (warns,errs) ->+                (Nothing, (warns, addMsg env errs msg))++addErrL :: MsgDoc -> LintM ()+addErrL msg = LintM $ \ env (warns,errs) ->+              (Just (), (warns, addMsg env errs msg))++addWarnL :: MsgDoc -> LintM ()+addWarnL msg = LintM $ \ env (warns,errs) ->+              (Just (), (addMsg env warns msg, errs))++addMsg :: LintEnv ->  Bag MsgDoc -> MsgDoc -> Bag MsgDoc+addMsg env msgs msg+  = ASSERT( notNull locs )+    msgs `snocBag` mk_msg msg+  where+   locs = le_loc env+   (loc, cxt1) = dumpLoc (head locs)+   cxts        = [snd (dumpLoc loc) | loc <- locs]+   context     = sdocWithPprDebug $ \dbg -> if dbg+                  then vcat (reverse cxts) $$ cxt1 $$+                         text "Substitution:" <+> ppr (le_subst env)+                  else cxt1++   mk_msg msg = mkLocMessage SevWarning (mkSrcSpan loc loc) (context $$ msg)++addLoc :: LintLocInfo -> LintM a -> LintM a+addLoc extra_loc m+  = LintM $ \ env errs ->+    unLintM m (env { le_loc = extra_loc : le_loc env }) errs++inCasePat :: LintM Bool         -- A slight hack; see the unique call site+inCasePat = LintM $ \ env errs -> (Just (is_case_pat env), errs)+  where+    is_case_pat (LE { le_loc = CasePat {} : _ }) = True+    is_case_pat _other                           = False++addInScopeVar :: Var -> LintM a -> LintM a+addInScopeVar var m+  = LintM $ \ env errs ->+    unLintM m (env { le_subst = extendTCvInScope (le_subst env) var+                   , le_joins = delVarSet        (le_joins env) var+               }) errs++extendSubstL :: TyVar -> Type -> LintM a -> LintM a+extendSubstL tv ty m+  = LintM $ \ env errs ->+    unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs++updateTCvSubst :: TCvSubst -> LintM a -> LintM a+updateTCvSubst subst' m+  = LintM $ \ env errs -> unLintM m (env { le_subst = subst' }) errs++markAllJoinsBad :: LintM a -> LintM a+markAllJoinsBad m+  = LintM $ \ env errs -> unLintM m (env { le_joins = emptyVarSet }) errs++markAllJoinsBadIf :: Bool -> LintM a -> LintM a+markAllJoinsBadIf True  m = markAllJoinsBad m+markAllJoinsBadIf False m = m++addGoodJoins :: [Var] -> LintM a -> LintM a+addGoodJoins vars thing_inside+  | null join_ids+  = thing_inside+  | otherwise+  = LintM $ \ env errs -> unLintM thing_inside (add_joins env) errs+  where+    add_joins env = env { le_joins = le_joins env `extendVarSetList` join_ids }+    join_ids = filter isJoinId vars++getValidJoins :: LintM IdSet+getValidJoins = LintM (\ env errs -> (Just (le_joins env), errs))++getTCvSubst :: LintM TCvSubst+getTCvSubst = LintM (\ env errs -> (Just (le_subst env), errs))++getInScope :: LintM InScopeSet+getInScope = LintM (\ env errs -> (Just (getTCvInScope $ le_subst env), errs))++applySubstTy :: InType -> LintM OutType+applySubstTy ty = do { subst <- getTCvSubst; return (substTy subst ty) }++applySubstCo :: InCoercion -> LintM OutCoercion+applySubstCo co = do { subst <- getTCvSubst; return (substCo subst co) }++lookupIdInScope :: Id -> LintM Id+lookupIdInScope id+  | not (mustHaveLocalBinding id)+  = return id   -- An imported Id+  | otherwise+  = do  { subst <- getTCvSubst+        ; case lookupInScope (getTCvInScope subst) id of+                Just v  -> return v+                Nothing -> do { addErrL out_of_scope+                              ; return id } }+  where+    out_of_scope = pprBndr LetBind id <+> text "is out of scope"++lookupJoinId :: Id -> LintM (Maybe JoinArity)+-- Look up an Id which should be a join point, valid here+-- If so, return its arity, if not return Nothing+lookupJoinId id+  = do { join_set <- getValidJoins+       ; case lookupVarSet join_set id of+            Just id' -> return (isJoinId_maybe id')+            Nothing  -> return Nothing }++lintTyCoVarInScope :: Var -> LintM ()+lintTyCoVarInScope v = lintInScope (text "is out of scope") v++lintInScope :: SDoc -> Var -> LintM ()+lintInScope loc_msg var =+ do { subst <- getTCvSubst+    ; lintL (not (mustHaveLocalBinding var) || (var `isInScope` subst))+             (hsep [pprBndr LetBind var, loc_msg]) }++ensureEqTys :: OutType -> OutType -> MsgDoc -> LintM ()+-- check ty2 is subtype of ty1 (ie, has same structure but usage+-- annotations need only be consistent, not equal)+-- Assumes ty1,ty2 are have already had the substitution applied+ensureEqTys ty1 ty2 msg = lintL (ty1 `eqType` ty2) msg++lintRole :: Outputable thing+          => thing     -- where the role appeared+          -> Role      -- expected+          -> Role      -- actual+          -> LintM ()+lintRole co r1 r2+  = lintL (r1 == r2)+          (text "Role incompatibility: expected" <+> ppr r1 <> comma <+>+           text "got" <+> ppr r2 $$+           text "in" <+> ppr co)++{-+************************************************************************+*                                                                      *+\subsection{Error messages}+*                                                                      *+************************************************************************+-}++dumpLoc :: LintLocInfo -> (SrcLoc, SDoc)++dumpLoc (RhsOf v)+  = (getSrcLoc v, brackets (text "RHS of" <+> pp_binders [v]))++dumpLoc (LambdaBodyOf b)+  = (getSrcLoc b, brackets (text "in body of lambda with binder" <+> pp_binder b))++dumpLoc (BodyOfLetRec [])+  = (noSrcLoc, brackets (text "In body of a letrec with no binders"))++dumpLoc (BodyOfLetRec bs@(_:_))+  = ( getSrcLoc (head bs), brackets (text "in body of letrec with binders" <+> pp_binders bs))++dumpLoc (AnExpr e)+  = (noSrcLoc, text "In the expression:" <+> ppr e)++dumpLoc (CaseAlt (con, args, _))+  = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args))++dumpLoc (CasePat (con, args, _))+  = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args))++dumpLoc (ImportedUnfolding locn)+  = (locn, brackets (text "in an imported unfolding"))+dumpLoc TopLevelBindings+  = (noSrcLoc, Outputable.empty)+dumpLoc (InType ty)+  = (noSrcLoc, text "In the type" <+> quotes (ppr ty))+dumpLoc (InCo co)+  = (noSrcLoc, text "In the coercion" <+> quotes (ppr co))++pp_binders :: [Var] -> SDoc+pp_binders bs = sep (punctuate comma (map pp_binder bs))++pp_binder :: Var -> SDoc+pp_binder b | isId b    = hsep [ppr b, dcolon, ppr (idType b)]+            | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)]++------------------------------------------------------+--      Messages for case expressions++mkDefaultArgsMsg :: [Var] -> MsgDoc+mkDefaultArgsMsg args+  = hang (text "DEFAULT case with binders")+         4 (ppr args)++mkCaseAltMsg :: CoreExpr -> Type -> Type -> MsgDoc+mkCaseAltMsg e ty1 ty2+  = hang (text "Type of case alternatives not the same as the annotation on case:")+         4 (vcat [ text "Actual type:" <+> ppr ty1,+                   text "Annotation on case:" <+> ppr ty2,+                   text "Alt Rhs:" <+> ppr e ])++mkScrutMsg :: Id -> Type -> Type -> TCvSubst -> MsgDoc+mkScrutMsg var var_ty scrut_ty subst+  = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,+          text "Result binder type:" <+> ppr var_ty,--(idType var),+          text "Scrutinee type:" <+> ppr scrut_ty,+     hsep [text "Current TCv subst", ppr subst]]++mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> MsgDoc+mkNonDefltMsg e+  = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)+mkNonIncreasingAltsMsg e+  = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)++nonExhaustiveAltsMsg :: CoreExpr -> MsgDoc+nonExhaustiveAltsMsg e+  = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)++mkBadConMsg :: TyCon -> DataCon -> MsgDoc+mkBadConMsg tycon datacon+  = vcat [+        text "In a case alternative, data constructor isn't in scrutinee type:",+        text "Scrutinee type constructor:" <+> ppr tycon,+        text "Data con:" <+> ppr datacon+    ]++mkBadPatMsg :: Type -> Type -> MsgDoc+mkBadPatMsg con_result_ty scrut_ty+  = vcat [+        text "In a case alternative, pattern result type doesn't match scrutinee type:",+        text "Pattern result type:" <+> ppr con_result_ty,+        text "Scrutinee type:" <+> ppr scrut_ty+    ]++integerScrutinisedMsg :: MsgDoc+integerScrutinisedMsg+  = text "In a LitAlt, the literal is lifted (probably Integer)"++mkBadAltMsg :: Type -> CoreAlt -> MsgDoc+mkBadAltMsg scrut_ty alt+  = vcat [ text "Data alternative when scrutinee is not a tycon application",+           text "Scrutinee type:" <+> ppr scrut_ty,+           text "Alternative:" <+> pprCoreAlt alt ]++mkNewTyDataConAltMsg :: Type -> CoreAlt -> MsgDoc+mkNewTyDataConAltMsg scrut_ty alt+  = vcat [ text "Data alternative for newtype datacon",+           text "Scrutinee type:" <+> ppr scrut_ty,+           text "Alternative:" <+> pprCoreAlt alt ]+++------------------------------------------------------+--      Other error messages++mkAppMsg :: Type -> Type -> CoreExpr -> MsgDoc+mkAppMsg fun_ty arg_ty arg+  = vcat [text "Argument value doesn't match argument type:",+              hang (text "Fun type:") 4 (ppr fun_ty),+              hang (text "Arg type:") 4 (ppr arg_ty),+              hang (text "Arg:") 4 (ppr arg)]++mkNonFunAppMsg :: Type -> Type -> CoreExpr -> MsgDoc+mkNonFunAppMsg fun_ty arg_ty arg+  = vcat [text "Non-function type in function position",+              hang (text "Fun type:") 4 (ppr fun_ty),+              hang (text "Arg type:") 4 (ppr arg_ty),+              hang (text "Arg:") 4 (ppr arg)]++mkLetErr :: TyVar -> CoreExpr -> MsgDoc+mkLetErr bndr rhs+  = vcat [text "Bad `let' binding:",+          hang (text "Variable:")+                 4 (ppr bndr <+> dcolon <+> ppr (varType bndr)),+          hang (text "Rhs:")+                 4 (ppr rhs)]++mkTyAppMsg :: Type -> Type -> MsgDoc+mkTyAppMsg ty arg_ty+  = vcat [text "Illegal type application:",+              hang (text "Exp type:")+                 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),+              hang (text "Arg type:")+                 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]++emptyRec :: CoreExpr -> MsgDoc+emptyRec e = hang (text "Empty Rec binding:") 2 (ppr e)++mkRhsMsg :: Id -> SDoc -> Type -> MsgDoc+mkRhsMsg binder what ty+  = vcat+    [hsep [text "The type of this binder doesn't match the type of its" <+> what <> colon,+            ppr binder],+     hsep [text "Binder's type:", ppr (idType binder)],+     hsep [text "Rhs type:", ppr ty]]++mkLetAppMsg :: CoreExpr -> MsgDoc+mkLetAppMsg e+  = hang (text "This argument does not satisfy the let/app invariant:")+       2 (ppr e)++badBndrTyMsg :: Id -> SDoc -> MsgDoc+badBndrTyMsg binder what+  = vcat [ text "The type of this binder is" <+> what <> colon <+> ppr binder+         , text "Binder's type:" <+> ppr (idType binder) ]++mkStrictMsg :: Id -> MsgDoc+mkStrictMsg binder+  = vcat [hsep [text "Recursive or top-level binder has strict demand info:",+                     ppr binder],+              hsep [text "Binder's demand info:", ppr (idDemandInfo binder)]+             ]++mkNonTopExportedMsg :: Id -> MsgDoc+mkNonTopExportedMsg binder+  = hsep [text "Non-top-level binder is marked as exported:", ppr binder]++mkNonTopExternalNameMsg :: Id -> MsgDoc+mkNonTopExternalNameMsg binder+  = hsep [text "Non-top-level binder has an external name:", ppr binder]++mkTopNonLitStrMsg :: Id -> MsgDoc+mkTopNonLitStrMsg binder+  = hsep [text "Top-level Addr# binder has a non-literal rhs:", ppr binder]++mkKindErrMsg :: TyVar -> Type -> MsgDoc+mkKindErrMsg tyvar arg_ty+  = vcat [text "Kinds don't match in type application:",+          hang (text "Type variable:")+                 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),+          hang (text "Arg type:")+                 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]++{- Not needed now+mkArityMsg :: Id -> MsgDoc+mkArityMsg binder+  = vcat [hsep [text "Demand type has",+                ppr (dmdTypeDepth dmd_ty),+                text "arguments, rhs has",+                ppr (idArity binder),+                text "arguments,",+                ppr binder],+              hsep [text "Binder's strictness signature:", ppr dmd_ty]++         ]+           where (StrictSig dmd_ty) = idStrictness binder+-}+mkCastErr :: Outputable casted => casted -> Coercion -> Type -> Type -> MsgDoc+mkCastErr expr co from_ty expr_ty+  = vcat [text "From-type of Cast differs from type of enclosed expression",+          text "From-type:" <+> ppr from_ty,+          text "Type of enclosed expr:" <+> ppr expr_ty,+          text "Actual enclosed expr:" <+> ppr expr,+          text "Coercion used in cast:" <+> ppr co+         ]++mkBadUnivCoMsg :: LeftOrRight -> Coercion -> SDoc+mkBadUnivCoMsg lr co+  = text "Kind mismatch on the" <+> pprLeftOrRight lr <+>+    text "side of a UnivCo:" <+> ppr co++mkBadProofIrrelMsg :: Type -> Coercion -> SDoc+mkBadProofIrrelMsg ty co+  = hang (text "Found a non-coercion in a proof-irrelevance UnivCo:")+       2 (vcat [ text "type:" <+> ppr ty+               , text "co:" <+> ppr co ])++mkBadTyVarMsg :: Var -> SDoc+mkBadTyVarMsg tv+  = text "Non-tyvar used in TyVarTy:"+      <+> ppr tv <+> dcolon <+> ppr (varType tv)++mkBadJoinBindMsg :: Var -> SDoc+mkBadJoinBindMsg var+  = vcat [ text "Bad join point binding:" <+> ppr var+         , text "Join points can be bound only by a non-top-level let" ]++mkInvalidJoinPointMsg :: Var -> Type -> SDoc+mkInvalidJoinPointMsg var ty+  = hang (text "Join point has invalid type:")+        2 (ppr var <+> dcolon <+> ppr ty)++mkBadJoinArityMsg :: Var -> Int -> Int -> SDoc+mkBadJoinArityMsg var ar nlams+  = vcat [ text "Join point has too few lambdas",+           text "Join var:" <+> ppr var,+           text "Join arity:" <+> ppr ar,+           text "Number of lambdas:" <+> ppr nlams ]++invalidJoinOcc :: Var -> SDoc+invalidJoinOcc var+  = vcat [ text "Invalid occurrence of a join variable:" <+> ppr var+         , text "The binder is either not a join point, or not valid here" ]++mkBadJumpMsg :: Var -> Int -> Int -> SDoc+mkBadJumpMsg var ar nargs+  = vcat [ text "Join point invoked with wrong number of arguments",+           text "Join var:" <+> ppr var,+           text "Join arity:" <+> ppr ar,+           text "Number of arguments:" <+> int nargs ]++mkInconsistentRecMsg :: [Var] -> SDoc+mkInconsistentRecMsg bndrs+  = vcat [ text "Recursive let binders mix values and join points",+           text "Binders:" <+> hsep (map ppr_with_details bndrs) ]+  where+    ppr_with_details bndr = ppr bndr <> ppr (idDetails bndr)++mkJoinBndrOccMismatchMsg :: Var -> JoinArity -> JoinArity -> SDoc+mkJoinBndrOccMismatchMsg bndr join_arity_bndr join_arity_occ+  = vcat [ text "Mismatch in join point arity between binder and occurrence"+         , text "Var:" <+> ppr bndr+         , text "Arity at binding site:" <+> ppr join_arity_bndr+         , text "Arity at occurrence:  " <+> ppr join_arity_occ ]++mkBndrOccTypeMismatchMsg :: Var -> Var -> OutType -> OutType -> SDoc+mkBndrOccTypeMismatchMsg bndr var bndr_ty var_ty+  = vcat [ text "Mismatch in type between binder and occurrence"+         , text "Var:" <+> ppr bndr+         , text "Binder type:" <+> ppr bndr_ty+         , text "Occurrence type:" <+> ppr var_ty+         , text "  Before subst:" <+> ppr (idType var) ]++mkBadJoinPointRuleMsg :: JoinId -> JoinArity -> CoreRule -> SDoc+mkBadJoinPointRuleMsg bndr join_arity rule+  = vcat [ text "Join point has rule with wrong number of arguments"+         , text "Var:" <+> ppr bndr+         , text "Join arity:" <+> ppr join_arity+         , text "Rule:" <+> ppr rule ]++pprLeftOrRight :: LeftOrRight -> MsgDoc+pprLeftOrRight CLeft  = text "left"+pprLeftOrRight CRight = text "right"++dupVars :: [[Var]] -> MsgDoc+dupVars vars+  = hang (text "Duplicate variables brought into scope")+       2 (ppr vars)++dupExtVars :: [[Name]] -> MsgDoc+dupExtVars vars+  = hang (text "Duplicate top-level variables with the same qualified name")+       2 (ppr vars)++{-+************************************************************************+*                                                                      *+\subsection{Annotation Linting}+*                                                                      *+************************************************************************+-}++-- | This checks whether a pass correctly looks through debug+-- annotations (@SourceNote@). This works a bit different from other+-- consistency checks: We check this by running the given task twice,+-- noting all differences between the results.+lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts+lintAnnots pname pass guts = do+  -- Run the pass as we normally would+  dflags <- getDynFlags+  when (gopt Opt_DoAnnotationLinting dflags) $+    liftIO $ Err.showPass dflags "Annotation linting - first run"+  nguts <- pass guts+  -- If appropriate re-run it without debug annotations to make sure+  -- that they made no difference.+  when (gopt Opt_DoAnnotationLinting dflags) $ do+    liftIO $ Err.showPass dflags "Annotation linting - second run"+    nguts' <- withoutAnnots pass guts+    -- Finally compare the resulting bindings+    liftIO $ Err.showPass dflags "Annotation linting - comparison"+    let binds = flattenBinds $ mg_binds nguts+        binds' = flattenBinds $ mg_binds nguts'+        (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds'+    when (not (null diffs)) $ CoreMonad.putMsg $ vcat+      [ lint_banner "warning" pname+      , text "Core changes with annotations:"+      , withPprStyle (defaultDumpStyle dflags) $ nest 2 $ vcat diffs+      ]+  -- Return actual new guts+  return nguts++-- | Run the given pass without annotations. This means that we both+-- set the debugLevel setting to 0 in the environment as well as all+-- annotations from incoming modules.+withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts+withoutAnnots pass guts = do+  -- Remove debug flag from environment.+  dflags <- getDynFlags+  let removeFlag env = env{ hsc_dflags = dflags{ debugLevel = 0} }+      withoutFlag corem =+        liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*>+                                getUniqueSupplyM <*> getModule <*>+                                getVisibleOrphanMods <*>+                                getPrintUnqualified <*> getSrcSpanM <*>+                                pure corem+  -- Nuke existing ticks in module.+  -- TODO: Ticks in unfoldings. Maybe change unfolding so it removes+  -- them in absence of debugLevel > 0.+  let nukeTicks = stripTicksE (not . tickishIsCode)+      nukeAnnotsBind :: CoreBind -> CoreBind+      nukeAnnotsBind bind = case bind of+        Rec bs     -> Rec $ map (\(b,e) -> (b, nukeTicks e)) bs+        NonRec b e -> NonRec b $ nukeTicks e+      nukeAnnotsMod mg@ModGuts{mg_binds=binds}+        = mg{mg_binds = map nukeAnnotsBind binds}+  -- Perform pass with all changes applied+  fmap fst $ withoutFlag $ pass (nukeAnnotsMod guts)
+ coreSyn/CoreOpt.hs view
@@ -0,0 +1,1176 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++{-# LANGUAGE CPP #-}+module CoreOpt (+        -- ** Simple expression optimiser+        simpleOptPgm, simpleOptExpr, simpleOptExprWith,++        -- ** Join points+        joinPointBinding_maybe, joinPointBindings_maybe,++        -- ** Predicates on expressions+        exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe,++        -- ** Coercions and casts+        pushCoArg, pushCoValArg, pushCoTyArg, collectBindersPushingCo+    ) where++#include "HsVersions.h"++import CoreArity( joinRhsArity, etaExpandToJoinPoint )++import CoreSyn+import CoreSubst+import CoreUtils+import CoreFVs+import PprCore  ( pprCoreBindings, pprRules )+import OccurAnal( occurAnalyseExpr, occurAnalysePgm )+import Literal  ( Literal(MachStr) )+import Id+import Var      ( varType )+import VarSet+import VarEnv+import DataCon+import OptCoercion ( optCoercion )+import Type     hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList+                       , isInScope, substTyVarBndr, cloneTyVarBndr )+import Coercion hiding ( substCo, substCoVarBndr )+import TyCon        ( tyConArity )+import TysWiredIn+import PrelNames+import BasicTypes+import Module       ( Module )+import ErrUtils+import DynFlags+import Outputable+import Pair+import Util+import Maybes       ( orElse )+import FastString+import Data.List+import qualified Data.ByteString as BS++{-+************************************************************************+*                                                                      *+        The Simple Optimiser+*                                                                      *+************************************************************************++Note [The simple optimiser]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+The simple optimiser is a lightweight, pure (non-monadic) function+that rapidly does a lot of simple optimisations, including++  - inlining things that occur just once,+      or whose RHS turns out to be trivial+  - beta reduction+  - case of known constructor+  - dead code elimination++It does NOT do any call-site inlining; it only inlines a function if+it can do so unconditionally, dropping the binding.  It thereby+guarantees to leave no un-reduced beta-redexes.++It is careful to follow the guidance of "Secrets of the GHC inliner",+and in particular the pre-inline-unconditionally and+post-inline-unconditionally story, to do effective beta reduction on+functions called precisely once, without repeatedly optimising the same+expression.  In fact, the simple optimiser is a good example of this+little dance in action; the full Simplifier is a lot more complicated.++-}++simpleOptExpr :: CoreExpr -> CoreExpr+-- See Note [The simple optimiser]+-- Do simple optimisation on an expression+-- The optimisation is very straightforward: just+-- inline non-recursive bindings that are used only once,+-- or where the RHS is trivial+--+-- We also inline bindings that bind a Eq# box: see+-- See Note [Getting the map/coerce RULE to work].+--+-- Also we convert functions to join points where possible (as+-- the occurrence analyser does most of the work anyway).+--+-- The result is NOT guaranteed occurrence-analysed, because+-- in  (let x = y in ....) we substitute for x; so y's occ-info+-- may change radically++simpleOptExpr expr+  = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr)+    simpleOptExprWith init_subst expr+  where+    init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))+        -- It's potentially important to make a proper in-scope set+        -- Consider  let x = ..y.. in \y. ...x...+        -- Then we should remember to clone y before substituting+        -- for x.  It's very unlikely to occur, because we probably+        -- won't *be* substituting for x if it occurs inside a+        -- lambda.+        --+        -- It's a bit painful to call exprFreeVars, because it makes+        -- three passes instead of two (occ-anal, and go)++simpleOptExprWith :: Subst -> InExpr -> OutExpr+-- See Note [The simple optimiser]+simpleOptExprWith subst expr+  = simple_opt_expr init_env (occurAnalyseExpr expr)+  where+    init_env = SOE { soe_inl = emptyVarEnv, soe_subst = subst }++----------------------+simpleOptPgm :: DynFlags -> Module+             -> CoreProgram -> [CoreRule] -> [CoreVect]+             -> IO (CoreProgram, [CoreRule], [CoreVect])+-- See Note [The simple optimiser]+simpleOptPgm dflags this_mod binds rules vects+  = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"+                       (pprCoreBindings occ_anald_binds $$ pprRules rules );++       ; return (reverse binds', rules', vects') }+  where+    occ_anald_binds  = occurAnalysePgm this_mod (\_ -> False) {- No rules active -}+                                       rules vects emptyVarSet binds++    (final_env, binds') = foldl do_one (emptyEnv, []) occ_anald_binds+    final_subst = soe_subst final_env++    rules' = substRulesForImportedIds final_subst rules+    vects' = substVects final_subst vects+             -- We never unconditionally inline into rules,+             -- hence pasing just a substitution++    do_one (env, binds') bind+      = case simple_opt_bind env bind of+          (env', Nothing)    -> (env', binds')+          (env', Just bind') -> (env', bind':binds')++-- In these functions the substitution maps InVar -> OutExpr++----------------------+type SimpleClo = (SimpleOptEnv, InExpr)++data SimpleOptEnv+  = SOE { soe_inl   :: IdEnv SimpleClo+             -- Deals with preInlineUnconditionally; things+             -- that occur exactly once and are inlined+             -- without having first been simplified++        , soe_subst :: Subst+             -- Deals with cloning; includes the InScopeSet+        }++instance Outputable SimpleOptEnv where+  ppr (SOE { soe_inl = inl, soe_subst = subst })+    = text "SOE {" <+> vcat [ text "soe_inl   =" <+> ppr inl+                            , text "soe_subst =" <+> ppr subst ]+                   <+> text "}"++emptyEnv :: SimpleOptEnv+emptyEnv = SOE { soe_inl = emptyVarEnv+               , soe_subst = emptySubst }++soeZapSubst :: SimpleOptEnv -> SimpleOptEnv+soeZapSubst (SOE { soe_subst = subst })+  = SOE { soe_inl = emptyVarEnv, soe_subst = zapSubstEnv subst }++soeSetInScope :: SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv+-- Take in-scope set from env1, and the rest from env2+soeSetInScope (SOE { soe_subst = subst1 })+              env2@(SOE { soe_subst = subst2 })+  = env2 { soe_subst = setInScope subst2 (substInScope subst1) }++---------------+simple_opt_clo :: SimpleOptEnv -> SimpleClo -> OutExpr+simple_opt_clo env (e_env, e)+  = simple_opt_expr (soeSetInScope env e_env) e++simple_opt_expr :: SimpleOptEnv -> InExpr -> OutExpr+simple_opt_expr env expr+  = go expr+  where+    subst        = soe_subst env+    in_scope     = substInScope subst+    in_scope_env = (in_scope, simpleUnfoldingFun)++    go (Var v)+       | Just clo <- lookupVarEnv (soe_inl env) v+       = simple_opt_clo env clo+       | otherwise+       = lookupIdSubst (text "simpleOptExpr") (soe_subst env) v++    go (App e1 e2)      = simple_app env e1 [(env,e2)]+    go (Type ty)        = Type     (substTy subst ty)+    go (Coercion co)    = Coercion (optCoercion (getTCvSubst subst) co)+    go (Lit lit)        = Lit lit+    go (Tick tickish e) = mkTick (substTickish subst tickish) (go e)+    go (Cast e co)      | isReflCo co' = go e+                        | otherwise    = Cast (go e) co'+                        where+                          co' = optCoercion (getTCvSubst subst) co++    go (Let bind body) = case simple_opt_bind env bind of+                           (env', Nothing)   -> simple_opt_expr env' body+                           (env', Just bind) -> Let bind (simple_opt_expr env' body)++    go lam@(Lam {})     = go_lam env [] lam+    go (Case e b ty as)+       -- See Note [Getting the map/coerce RULE to work]+      | isDeadBinder b+      , Just (con, _tys, es) <- exprIsConApp_maybe in_scope_env e'+      , Just (altcon, bs, rhs) <- findAlt (DataAlt con) as+      = case altcon of+          DEFAULT -> go rhs+          _       -> foldr wrapLet (simple_opt_expr env' rhs) mb_prs+            where+              (env', mb_prs) = mapAccumL simple_out_bind env $+                               zipEqual "simpleOptExpr" bs es++         -- Note [Getting the map/coerce RULE to work]+      | isDeadBinder b+      , [(DEFAULT, _, rhs)] <- as+      , isCoercionType (varType b)+      , (Var fun, _args) <- collectArgs e+      , fun `hasKey` coercibleSCSelIdKey+         -- without this last check, we get #11230+      = go rhs++      | otherwise+      = Case e' b' (substTy subst ty)+                   (map (go_alt env') as)+      where+        e' = go e+        (env', b') = subst_opt_bndr env b++    ----------------------+    go_alt env (con, bndrs, rhs)+      = (con, bndrs', simple_opt_expr env' rhs)+      where+        (env', bndrs') = subst_opt_bndrs env bndrs++    ----------------------+    -- go_lam tries eta reduction+    go_lam env bs' (Lam b e)+       = go_lam env' (b':bs') e+       where+         (env', b') = subst_opt_bndr env b+    go_lam env bs' e+       | Just etad_e <- tryEtaReduce bs e' = etad_e+       | otherwise                         = mkLams bs e'+       where+         bs = reverse bs'+         e' = simple_opt_expr env e++----------------------+-- simple_app collects arguments for beta reduction+simple_app :: SimpleOptEnv -> InExpr -> [SimpleClo] -> CoreExpr++simple_app env (Var v) as+  | Just (env', e) <- lookupVarEnv (soe_inl env) v+  = simple_app (soeSetInScope env env') e as++  | let unf = idUnfolding v+  , isCompulsoryUnfolding (idUnfolding v)+  , isAlwaysActive (idInlineActivation v)+    -- See Note [Unfold compulsory unfoldings in LHSs]+  = simple_app (soeZapSubst env) (unfoldingTemplate unf) as++  | otherwise+  , let out_fn = lookupIdSubst (text "simple_app") (soe_subst env) v+  = finish_app env out_fn as++simple_app env (App e1 e2) as+  = simple_app env e1 ((env, e2) : as)++simple_app env (Lam b e) (a:as)+  = wrapLet mb_pr (simple_app env' e as)+  where+     (env', mb_pr) = simple_bind_pair env b Nothing a++simple_app env (Tick t e) as+  -- Okay to do "(Tick t e) x ==> Tick t (e x)"?+  | t `tickishScopesLike` SoftScope+  = mkTick t $ simple_app env e as++simple_app env e as+  = finish_app env (simple_opt_expr env e) as++finish_app :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr+finish_app _ fun []+  = fun+finish_app env fun (arg:args)+  = finish_app env (App fun (simple_opt_clo env arg)) args++----------------------+simple_opt_bind :: SimpleOptEnv -> InBind+                -> (SimpleOptEnv, Maybe OutBind)+simple_opt_bind env (NonRec b r)+  = (env', case mb_pr of+            Nothing    -> Nothing+            Just (b,r) -> Just (NonRec b r))+  where+    (b', r') = joinPointBinding_maybe b r `orElse` (b, r)+    (env', mb_pr) = simple_bind_pair env b' Nothing (env,r')++simple_opt_bind env (Rec prs)+  = (env'', res_bind)+  where+    res_bind          = Just (Rec (reverse rev_prs'))+    prs'              = joinPointBindings_maybe prs `orElse` prs+    (env', bndrs')    = subst_opt_bndrs env (map fst prs')+    (env'', rev_prs') = foldl do_pr (env', []) (prs' `zip` bndrs')+    do_pr (env, prs) ((b,r), b')+       = (env', case mb_pr of+                  Just pr -> pr : prs+                  Nothing -> prs)+       where+         (env', mb_pr) = simple_bind_pair env b (Just b') (env,r)++----------------------+simple_bind_pair :: SimpleOptEnv+                 -> InVar -> Maybe OutVar+                 -> SimpleClo+                 -> (SimpleOptEnv, Maybe (OutVar, OutExpr))+    -- (simple_bind_pair subst in_var out_rhs)+    --   either extends subst with (in_var -> out_rhs)+    --   or     returns Nothing+simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst })+                 in_bndr mb_out_bndr clo@(rhs_env, in_rhs)+  | Type ty <- in_rhs        -- let a::* = TYPE ty in <body>+  , let out_ty = substTy (soe_subst rhs_env) ty+  = ASSERT( isTyVar in_bndr )+    (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing)++  | Coercion co <- in_rhs+  , let out_co = optCoercion (getTCvSubst (soe_subst rhs_env)) co+  = ASSERT( isCoVar in_bndr )+    (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing)++  | pre_inline_unconditionally+  = (env { soe_inl = extendVarEnv inl_env in_bndr clo }, Nothing)++  | otherwise+  = simple_out_bind_pair env in_bndr mb_out_bndr+                         (simple_opt_clo env clo)+                         occ active stable_unf+  where+    stable_unf = isStableUnfolding (idUnfolding in_bndr)+    active     = isAlwaysActive (idInlineActivation in_bndr)+    occ        = idOccInfo in_bndr++    pre_inline_unconditionally :: Bool+    pre_inline_unconditionally+       | isCoVar in_bndr          = False    -- See Note [Do not inline CoVars unconditionally]+       | isExportedId in_bndr     = False    --     in SimplUtils+       | stable_unf               = False+       | not active               = False    -- Note [Inline prag in simplOpt]+       | not (safe_to_inline occ) = False+       | otherwise = True++        -- Unconditionally safe to inline+    safe_to_inline :: OccInfo -> Bool+    safe_to_inline (IAmALoopBreaker {}) = False+    safe_to_inline IAmDead              = True+    safe_to_inline occ@(OneOcc {})      =  not (occ_in_lam occ)+                                        && occ_one_br occ+    safe_to_inline (ManyOccs {})        = False++-------------------+simple_out_bind :: SimpleOptEnv -> (InVar, OutExpr)+                -> (SimpleOptEnv, Maybe (OutVar, OutExpr))+simple_out_bind env@(SOE { soe_subst = subst }) (in_bndr, out_rhs)+  | Type out_ty <- out_rhs+  = ASSERT( isTyVar in_bndr )+    (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing)++  | Coercion out_co <- out_rhs+  = ASSERT( isCoVar in_bndr )+    (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing)++  | otherwise+  = simple_out_bind_pair env in_bndr Nothing out_rhs+                         (idOccInfo in_bndr) True False++-------------------+simple_out_bind_pair :: SimpleOptEnv+                     -> InId -> Maybe OutId -> OutExpr+                     -> OccInfo -> Bool -> Bool+                     -> (SimpleOptEnv, Maybe (OutVar, OutExpr))+simple_out_bind_pair env in_bndr mb_out_bndr out_rhs+                     occ_info active stable_unf+  | post_inline_unconditionally+  = ( env' { soe_subst = extendIdSubst (soe_subst env) in_bndr out_rhs }+    , Nothing)++  | otherwise+  = ( env', Just (out_bndr, out_rhs) )+  where+    (env', bndr1) = case mb_out_bndr of+                      Just out_bndr -> (env, out_bndr)+                      Nothing       -> subst_opt_bndr env in_bndr+    out_bndr = add_info env' in_bndr bndr1++    post_inline_unconditionally :: Bool+    post_inline_unconditionally+       | not active                  = False+       | isWeakLoopBreaker occ_info  = False -- If it's a loop-breaker of any kind, don't inline+                                             -- because it might be referred to "earlier"+       | stable_unf                  = False -- Note [Stable unfoldings and postInlineUnconditionally]+       | isExportedId in_bndr        = False -- Note [Exported Ids and trivial RHSs]+       | exprIsTrivial out_rhs       = True+       | coercible_hack              = True+       | otherwise                   = False++    -- See Note [Getting the map/coerce RULE to work]+    coercible_hack | (Var fun, args) <- collectArgs out_rhs+                   , Just dc <- isDataConWorkId_maybe fun+                   , dc `hasKey` heqDataConKey || dc `hasKey` coercibleDataConKey+                   = all exprIsTrivial args+                   | otherwise+                   = False++{- Note [Exported Ids and trivial RHSs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We obviously do not want to unconditionally inline an Id that is exported.+In SimplUtils, Note [Top level and postInlineUnconditionally], we+explain why we don't inline /any/ top-level things unconditionally, even+trivial ones.  But we do here!  Why?  In the simple optimiser++  * We do no rule rewrites+  * We do no call-site inlining++Those differences obviate the reasons for not inlining a trivial rhs,+and increase the benefit for doing so.  So we unconditionally inline trivial+rhss here.+-}++----------------------+subst_opt_bndrs :: SimpleOptEnv -> [InVar] -> (SimpleOptEnv, [OutVar])+subst_opt_bndrs env bndrs = mapAccumL subst_opt_bndr env bndrs++subst_opt_bndr :: SimpleOptEnv -> InVar -> (SimpleOptEnv, OutVar)+subst_opt_bndr env bndr+  | isTyVar bndr  = (env { soe_subst = subst_tv }, tv')+  | isCoVar bndr  = (env { soe_subst = subst_cv }, cv')+  | otherwise     = subst_opt_id_bndr env bndr+  where+    subst           = soe_subst env+    (subst_tv, tv') = substTyVarBndr subst bndr+    (subst_cv, cv') = substCoVarBndr subst bndr++subst_opt_id_bndr :: SimpleOptEnv -> InId -> (SimpleOptEnv, OutId)+-- Nuke all fragile IdInfo, unfolding, and RULES;+--    it gets added back later by add_info+-- Rather like SimplEnv.substIdBndr+--+-- It's important to zap fragile OccInfo (which CoreSubst.substIdBndr+-- carefully does not do) because simplOptExpr invalidates it++subst_opt_id_bndr (SOE { soe_subst = subst, soe_inl = inl }) old_id+  = (SOE { soe_subst = new_subst, soe_inl = new_inl }, new_id)+  where+    Subst in_scope id_subst tv_subst cv_subst = subst++    id1    = uniqAway in_scope old_id+    id2    = setIdType id1 (substTy subst (idType old_id))+    new_id = zapFragileIdInfo id2+             -- Zaps rules, worker-info, unfolding, and fragile OccInfo+             -- The unfolding and rules will get added back later, by add_info++    new_in_scope = in_scope `extendInScopeSet` new_id++    no_change = new_id == old_id++        -- Extend the substitution if the unique has changed,+        -- See the notes with substTyVarBndr for the delSubstEnv+    new_id_subst+      | no_change = delVarEnv id_subst old_id+      | otherwise = extendVarEnv id_subst old_id (Var new_id)++    new_subst = Subst new_in_scope new_id_subst tv_subst cv_subst+    new_inl   = delVarEnv inl old_id++----------------------+add_info :: SimpleOptEnv -> InVar -> OutVar -> OutVar+add_info env old_bndr new_bndr+ | isTyVar old_bndr = new_bndr+ | otherwise        = maybeModifyIdInfo mb_new_info new_bndr+ where+   subst = soe_subst env+   mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr)++simpleUnfoldingFun :: IdUnfoldingFun+simpleUnfoldingFun id+  | isAlwaysActive (idInlineActivation id) = idUnfolding id+  | otherwise                              = noUnfolding++wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr+wrapLet Nothing      body = body+wrapLet (Just (b,r)) body = Let (NonRec b r) body++------------------+substVects :: Subst -> [CoreVect] -> [CoreVect]+substVects subst = map (substVect subst)++------------------+substVect :: Subst -> CoreVect -> CoreVect+substVect subst  (Vect v rhs)        = Vect v (simpleOptExprWith subst rhs)+substVect _subst vd@(NoVect _)       = vd+substVect _subst vd@(VectType _ _ _) = vd+substVect _subst vd@(VectClass _)    = vd+substVect _subst vd@(VectInst _)     = vd++{-+Note [Inline prag in simplOpt]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If there's an INLINE/NOINLINE pragma that restricts the phase in+which the binder can be inlined, we don't inline here; after all,+we don't know what phase we're in.  Here's an example++  foo :: Int -> Int -> Int+  {-# INLINE foo #-}+  foo m n = inner m+     where+       {-# INLINE [1] inner #-}+       inner m = m+n++  bar :: Int -> Int+  bar n = foo n 1++When inlining 'foo' in 'bar' we want the let-binding for 'inner'+to remain visible until Phase 1++Note [Unfold compulsory unfoldings in LHSs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When the user writes `RULES map coerce = coerce` as a rule, the rule+will only ever match if simpleOptExpr replaces coerce by its unfolding+on the LHS, because that is the core that the rule matching engine+will find. So do that for everything that has a compulsory+unfolding. Also see Note [Desugaring coerce as cast] in Desugar.++However, we don't want to inline 'seq', which happens to also have a+compulsory unfolding, so we only do this unfolding only for things+that are always-active.  See Note [User-defined RULES for seq] in MkId.++Note [Getting the map/coerce RULE to work]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We wish to allow the "map/coerce" RULE to fire:++  {-# RULES "map/coerce" map coerce = coerce #-}++The naive core produced for this is++  forall a b (dict :: Coercible * a b).+    map @a @b (coerce @a @b @dict) = coerce @[a] @[b] @dict'++  where dict' :: Coercible [a] [b]+        dict' = ...++This matches literal uses of `map coerce` in code, but that's not what we+want. We want it to match, say, `map MkAge` (where newtype Age = MkAge Int)+too. Some of this is addressed by compulsorily unfolding coerce on the LHS,+yielding++  forall a b (dict :: Coercible * a b).+    map @a @b (\(x :: a) -> case dict of+      MkCoercible (co :: a ~R# b) -> x |> co) = ...++Getting better. But this isn't exactly what gets produced. This is because+Coercible essentially has ~R# as a superclass, and superclasses get eagerly+extracted during solving. So we get this:++  forall a b (dict :: Coercible * a b).+    case Coercible_SCSel @* @a @b dict of+      _ [Dead] -> map @a @b (\(x :: a) -> case dict of+                               MkCoercible (co :: a ~R# b) -> x |> co) = ...++Unfortunately, this still abstracts over a Coercible dictionary. We really+want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce,+which transforms the above to (see also Note [Desugaring coerce as cast] in+Desugar)++  forall a b (co :: a ~R# b).+    let dict = MkCoercible @* @a @b co in+    case Coercible_SCSel @* @a @b dict of+      _ [Dead] -> map @a @b (\(x :: a) -> case dict of+         MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ...++Now, we need simpleOptExpr to fix this up. It does so by taking three+separate actions:+  1. Inline certain non-recursive bindings. The choice whether to inline+     is made in simple_bind_pair. Note the rather specific check for+     MkCoercible in there.++  2. Stripping case expressions like the Coercible_SCSel one.+     See the `Case` case of simple_opt_expr's `go` function.++  3. Look for case expressions that unpack something that was+     just packed and inline them. This is also done in simple_opt_expr's+     `go` function.++This is all a fair amount of special-purpose hackery, but it's for+a good cause. And it won't hurt other RULES and such that it comes across.+++************************************************************************+*                                                                      *+                Join points+*                                                                      *+************************************************************************+-}++-- | Returns Just (bndr,rhs) if the binding is a join point:+-- If it's a JoinId, just return it+-- If it's not yet a JoinId but is always tail-called,+--    make it into a JoinId and return it.+-- In the latter case, eta-expand the RHS if necessary, to make the+-- lambdas explicit, as is required for join points+--+-- Precondition: the InBndr has been occurrence-analysed,+--               so its OccInfo is valid+joinPointBinding_maybe :: InBndr -> InExpr -> Maybe (InBndr, InExpr)+joinPointBinding_maybe bndr rhs+  | not (isId bndr)+  = Nothing++  | isJoinId bndr+  = Just (bndr, rhs)++  | AlwaysTailCalled join_arity <- tailCallInfo (idOccInfo bndr)+  , not (bad_unfolding join_arity (idUnfolding bndr))+  , (bndrs, body) <- etaExpandToJoinPoint join_arity rhs+  = Just (bndr `asJoinId` join_arity, mkLams bndrs body)++  | otherwise+  = Nothing++  where+    -- bad_unfolding returns True if we should /not/ convert a non-join-id+    -- into a join-id, even though it is AlwaysTailCalled+    -- See Note [Join points and INLINE pragmas]+    bad_unfolding join_arity (CoreUnfolding { uf_src = src, uf_tmpl = rhs })+      = isStableSource src && join_arity > joinRhsArity rhs+    bad_unfolding _ (DFunUnfolding {})+      = True+    bad_unfolding _ _+      = False++joinPointBindings_maybe :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)]+joinPointBindings_maybe bndrs+  = mapM (uncurry joinPointBinding_maybe) bndrs+++{- Note [Join points and INLINE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f x = let g = \x. not  -- Arity 1+             {-# INLINE g #-}+         in case x of+              A -> g True True+              B -> g True False+              C -> blah2++Here 'g' is always tail-called applied to 2 args, but the stable+unfolding captured by the INLINE pragma has arity 1.  If we try to+convert g to be a join point, its unfolding will still have arity 1+(since it is stable, and we don't meddle with stable unfoldings), and+Lint will complain (see Note [Invariants on join points], (2a), in+CoreSyn.  Trac #13413.++Moreover, since g is going to be inlined anyway, there is no benefit+from making it a join point.++If it is recursive, and uselessly marked INLINE, this will stop us+making it a join point, which is a annoying.  But occasionally+(notably in class methods; see Note [Instances and loop breakers] in+TcInstDcls) we mark recurive things as INLINE but the recursion+unravels; so ignoring INLINE pragmas on recursive things isn't good+either.+++************************************************************************+*                                                                      *+         exprIsConApp_maybe+*                                                                      *+************************************************************************++Note [exprIsConApp_maybe]+~~~~~~~~~~~~~~~~~~~~~~~~~+exprIsConApp_maybe is a very important function.  There are two principal+uses:+  * case e of { .... }+  * cls_op e, where cls_op is a class operation++In both cases you want to know if e is of form (C e1..en) where C is+a data constructor.++However e might not *look* as if+++Note [exprIsConApp_maybe on literal strings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See #9400 and #13317.++Conceptually, a string literal "abc" is just ('a':'b':'c':[]), but in Core+they are represented as unpackCString# "abc"# by MkCore.mkStringExprFS, or+unpackCStringUtf8# when the literal contains multi-byte UTF8 characters.++For optimizations we want to be able to treat it as a list, so they can be+decomposed when used in a case-statement. exprIsConApp_maybe detects those+calls to unpackCString# and returns:++Just (':', [Char], ['a', unpackCString# "bc"]).++We need to be careful about UTF8 strings here. ""# contains a ByteString, so+we must parse it back into a FastString to split off the first character.+That way we can treat unpackCString# and unpackCStringUtf8# in the same way.++We must also be caeful about+   lvl = "foo"#+   ...(unpackCString# lvl)...+to ensure that we see through the let-binding for 'lvl'.  Hence the+(exprIsLiteral_maybe .. arg) in the guard before the call to+dealWithStringLiteral.++Note [Push coercions in exprIsConApp_maybe]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In Trac #13025 I found a case where we had+    op (df @t1 @t2)     -- op is a ClassOp+where+    df = (/\a b. K e1 e2) |> g++To get this to come out we need to simplify on the fly+   ((/\a b. K e1 e2) |> g) @t1 @t2++Hence the use of pushCoArgs.+-}++data ConCont = CC [CoreExpr] Coercion+                  -- Substitution already applied++-- | Returns @Just (dc, [t1..tk], [x1..xn])@ if the argument expression is+-- a *saturated* constructor application of the form @dc t1..tk x1 .. xn@,+-- where t1..tk are the *universally-qantified* type args of 'dc'+exprIsConApp_maybe :: InScopeEnv -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr])+exprIsConApp_maybe (in_scope, id_unf) expr+  = go (Left in_scope) expr (CC [] (mkRepReflCo (exprType expr)))+  where+    go :: Either InScopeSet Subst+             -- Left in-scope  means "empty substitution"+             -- Right subst    means "apply this substitution to the CoreExpr"+       -> CoreExpr -> ConCont+       -> Maybe (DataCon, [Type], [CoreExpr])+    go subst (Tick t expr) cont+       | not (tickishIsCode t) = go subst expr cont+    go subst (Cast expr co1) (CC args co2)+       | Just (args', co1') <- pushCoArgs (subst_co subst co1) args+            -- See Note [Push coercions in exprIsConApp_maybe]+       = go subst expr (CC args' (co1' `mkTransCo` co2))+    go subst (App fun arg) (CC args co)+       = go subst fun (CC (subst_arg subst arg : args) co)+    go subst (Lam var body) (CC (arg:args) co)+       | exprIsTrivial arg          -- Don't duplicate stuff!+       = go (extend subst var arg) body (CC args co)+    go (Right sub) (Var v) cont+       = go (Left (substInScope sub))+            (lookupIdSubst (text "exprIsConApp" <+> ppr expr) sub v)+            cont++    go (Left in_scope) (Var fun) cont@(CC args co)++        | Just con <- isDataConWorkId_maybe fun+        , count isValArg args == idArity fun+        = pushCoDataCon con args co++        -- Look through dictionary functions; see Note [Unfolding DFuns]+        | DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = dfun_args } <- unfolding+        , bndrs `equalLength` args    -- See Note [DFun arity check]+        , let subst = mkOpenSubst in_scope (bndrs `zip` args)+        = pushCoDataCon con (map (substExpr (text "exprIsConApp1") subst) dfun_args) co++        -- Look through unfoldings, but only arity-zero one;+        -- if arity > 0 we are effectively inlining a function call,+        -- and that is the business of callSiteInline.+        -- In practice, without this test, most of the "hits" were+        -- CPR'd workers getting inlined back into their wrappers,+        | idArity fun == 0+        , Just rhs <- expandUnfolding_maybe unfolding+        , let in_scope' = extendInScopeSetSet in_scope (exprFreeVars rhs)+        = go (Left in_scope') rhs cont++        -- See Note [exprIsConApp_maybe on literal strings]+        | (fun `hasKey` unpackCStringIdKey) ||+          (fun `hasKey` unpackCStringUtf8IdKey)+        , [arg]              <- args+        , Just (MachStr str) <- exprIsLiteral_maybe (in_scope, id_unf) arg+        = dealWithStringLiteral fun str co+        where+          unfolding = id_unf fun++    go _ _ _ = Nothing++    ----------------------------+    -- Operations on the (Either InScopeSet CoreSubst)+    -- The Left case is wildly dominant+    subst_co (Left {}) co = co+    subst_co (Right s) co = CoreSubst.substCo s co++    subst_arg (Left {}) e = e+    subst_arg (Right s) e = substExpr (text "exprIsConApp2") s e++    extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e)+    extend (Right s)       v e = Right (extendSubst s v e)+++-- See Note [exprIsConApp_maybe on literal strings]+dealWithStringLiteral :: Var -> BS.ByteString -> Coercion+                      -> Maybe (DataCon, [Type], [CoreExpr])++-- This is not possible with user-supplied empty literals, MkCore.mkStringExprFS+-- turns those into [] automatically, but just in case something else in GHC+-- generates a string literal directly.+dealWithStringLiteral _   str co+  | BS.null str+  = pushCoDataCon nilDataCon [Type charTy] co++dealWithStringLiteral fun str co+  = let strFS = mkFastStringByteString str++        char = mkConApp charDataCon [mkCharLit (headFS strFS)]+        charTail = fastStringToByteString (tailFS strFS)++        -- In singleton strings, just add [] instead of unpackCstring# ""#.+        rest = if BS.null charTail+                 then mkConApp nilDataCon [Type charTy]+                 else App (Var fun)+                          (Lit (MachStr charTail))++    in pushCoDataCon consDataCon [Type charTy, char, rest] co++{-+Note [Unfolding DFuns]+~~~~~~~~~~~~~~~~~~~~~~+DFuns look like++  df :: forall a b. (Eq a, Eq b) -> Eq (a,b)+  df a b d_a d_b = MkEqD (a,b) ($c1 a b d_a d_b)+                               ($c2 a b d_a d_b)++So to split it up we just need to apply the ops $c1, $c2 etc+to the very same args as the dfun.  It takes a little more work+to compute the type arguments to the dictionary constructor.++Note [DFun arity check]+~~~~~~~~~~~~~~~~~~~~~~~+Here we check that the total number of supplied arguments (inclding+type args) matches what the dfun is expecting.  This may be *less*+than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn+-}++exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal+-- Same deal as exprIsConApp_maybe, but much simpler+-- Nevertheless we do need to look through unfoldings for+-- Integer and string literals, which are vigorously hoisted to top level+-- and not subsequently inlined+exprIsLiteral_maybe env@(_, id_unf) e+  = case e of+      Lit l     -> Just l+      Tick _ e' -> exprIsLiteral_maybe env e' -- dubious?+      Var v     | Just rhs <- expandUnfolding_maybe (id_unf v)+                -> exprIsLiteral_maybe env rhs+      _         -> Nothing++{-+Note [exprIsLambda_maybe]+~~~~~~~~~~~~~~~~~~~~~~~~~~+exprIsLambda_maybe will, given an expression `e`, try to turn it into the form+`Lam v e'` (returned as `Just (v,e')`). Besides using lambdas, it looks through+casts (using the Push rule), and it unfolds function calls if the unfolding+has a greater arity than arguments are present.++Currently, it is used in Rules.match, and is required to make+"map coerce = coerce" match.+-}++exprIsLambda_maybe :: InScopeEnv -> CoreExpr+                      -> Maybe (Var, CoreExpr,[Tickish Id])+    -- See Note [exprIsLambda_maybe]++-- The simple case: It is a lambda already+exprIsLambda_maybe _ (Lam x e)+    = Just (x, e, [])++-- Still straightforward: Ticks that we can float out of the way+exprIsLambda_maybe (in_scope_set, id_unf) (Tick t e)+    | tickishFloatable t+    , Just (x, e, ts) <- exprIsLambda_maybe (in_scope_set, id_unf) e+    = Just (x, e, t:ts)++-- Also possible: A casted lambda. Push the coercion inside+exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co)+    | Just (x, e,ts) <- exprIsLambda_maybe (in_scope_set, id_unf) casted_e+    -- Only do value lambdas.+    -- this implies that x is not in scope in gamma (makes this code simpler)+    , not (isTyVar x) && not (isCoVar x)+    , ASSERT( not $ x `elemVarSet` tyCoVarsOfCo co) True+    , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e co+    , let res = Just (x',e',ts)+    = --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)])+      res++-- Another attempt: See if we find a partial unfolding+exprIsLambda_maybe (in_scope_set, id_unf) e+    | (Var f, as, ts) <- collectArgsTicks tickishFloatable e+    , idArity f > count isValArg as+    -- Make sure there is hope to get a lambda+    , Just rhs <- expandUnfolding_maybe (id_unf f)+    -- Optimize, for beta-reduction+    , let e' =  simpleOptExprWith (mkEmptySubst in_scope_set) (rhs `mkApps` as)+    -- Recurse, because of possible casts+    , Just (x', e'', ts') <- exprIsLambda_maybe (in_scope_set, id_unf) e'+    , let res = Just (x', e'', ts++ts')+    = -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr (x',e'')])+      res++exprIsLambda_maybe _ _e+    = -- pprTrace "exprIsLambda_maybe:Fail" (vcat [ppr _e])+      Nothing+++{- *********************************************************************+*                                                                      *+              The "push rules"+*                                                                      *+************************************************************************++Here we implement the "push rules" from FC papers:++* The push-argument rules, where we can move a coercion past an argument.+  We have+      (fun |> co) arg+  and we want to transform it to+    (fun arg') |> co'+  for some suitable co' and tranformed arg'.++* The PushK rule for data constructors.  We have+       (K e1 .. en) |> co+  and we want to tranform to+       (K e1' .. en')+  by pushing the coercion into the oarguments+-}++pushCoArgs :: Coercion -> [CoreArg] -> Maybe ([CoreArg], Coercion)+pushCoArgs co []         = return ([], co)+pushCoArgs co (arg:args) = do { (arg',  co1) <- pushCoArg  co  arg+                              ; (args', co2) <- pushCoArgs co1 args+                              ; return (arg':args', co2) }++pushCoArg :: Coercion -> CoreArg -> Maybe (CoreArg, Coercion)+-- We have (fun |> co) arg, and we want to transform it to+--         (fun arg) |> co+-- This may fail, e.g. if (fun :: N) where N is a newtype+-- C.f. simplCast in Simplify.hs+-- 'co' is always Representational++pushCoArg co (Type ty) = do { (ty', co') <- pushCoTyArg co ty+                            ; return (Type ty', co') }+pushCoArg co val_arg   = do { (arg_co, co') <- pushCoValArg co+                            ; return (mkCast val_arg arg_co, co') }++pushCoTyArg :: Coercion -> Type -> Maybe (Type, Coercion)+-- We have (fun |> co) @ty+-- Push the coercion through to return+--         (fun @ty') |> co'+-- 'co' is always Representational+pushCoTyArg co ty+  | tyL `eqType` tyR+  = Just (ty, mkRepReflCo (piResultTy tyR ty))++  | isForAllTy tyL+  = ASSERT2( isForAllTy tyR, ppr co $$ ppr ty )+    Just (ty `mkCastTy` mkSymCo co1, co2)++  | otherwise+  = Nothing+  where+    Pair tyL tyR = coercionKind co+       -- co :: tyL ~ tyR+       -- tyL = forall (a1 :: k1). ty1+       -- tyR = forall (a2 :: k2). ty2++    co1 = mkNthCo 0 co+       -- co1 :: k1 ~ k2+       -- Note that NthCo can extract an equality between the kinds+       -- of the types related by a coercion between forall-types.+       -- See the NthCo case in CoreLint.++    co2 = mkInstCo co (mkCoherenceLeftCo (mkNomReflCo ty) co1)+        -- co2 :: ty1[ (ty|>co1)/a1 ] ~ ty2[ ty/a2 ]+        -- Arg of mkInstCo is always nominal, hence mkNomReflCo++pushCoValArg :: Coercion -> Maybe (Coercion, Coercion)+-- We have (fun |> co) arg+-- Push the coercion through to return+--         (fun (arg |> co_arg)) |> co_res+-- 'co' is always Representational+pushCoValArg co+  | tyL `eqType` tyR+  = Just (mkRepReflCo arg, mkRepReflCo res)++  | isFunTy tyL+  , (co1, co2) <- decomposeFunCo co+              -- If   co  :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2)+              -- then co1 :: tyL1 ~ tyR1+              --      co2 :: tyL2 ~ tyR2+  = ASSERT2( isFunTy tyR, ppr co $$ ppr arg )+    Just (mkSymCo co1, co2)++  | otherwise+  = Nothing+  where+    (arg, res)   = splitFunTy tyR+    Pair tyL tyR = coercionKind co++pushCoercionIntoLambda+    :: InScopeSet -> Var -> CoreExpr -> Coercion -> Maybe (Var, CoreExpr)+-- This implements the Push rule from the paper on coercions+--    (\x. e) |> co+-- ===>+--    (\x'. e |> co')+pushCoercionIntoLambda in_scope x e co+    | ASSERT(not (isTyVar x) && not (isCoVar x)) True+    , Pair s1s2 t1t2 <- coercionKind co+    , Just (_s1,_s2) <- splitFunTy_maybe s1s2+    , Just (t1,_t2) <- splitFunTy_maybe t1t2+    = let (co1, co2) = decomposeFunCo co+          -- Should we optimize the coercions here?+          -- Otherwise they might not match too well+          x' = x `setIdType` t1+          in_scope' = in_scope `extendInScopeSet` x'+          subst = extendIdSubst (mkEmptySubst in_scope')+                                x+                                (mkCast (Var x') co1)+      in Just (x', substExpr (text "pushCoercionIntoLambda") subst e `mkCast` co2)+    | otherwise+    = pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e))+      Nothing++pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion+              -> Maybe (DataCon+                       , [Type]      -- Universal type args+                       , [CoreExpr]) -- All other args incl existentials+-- Implement the KPush reduction rule as described in "Down with kinds"+-- The transformation applies iff we have+--      (C e1 ... en) `cast` co+-- where co :: (T t1 .. tn) ~ to_ty+-- The left-hand one must be a T, because exprIsConApp returned True+-- but the right-hand one might not be.  (Though it usually will.)+pushCoDataCon dc dc_args co+  | isReflCo co || from_ty `eqType` to_ty  -- try cheap test first+  , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args+  = Just (dc, map exprToType univ_ty_args, rest_args)++  | Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty+  , to_tc == dataConTyCon dc+        -- These two tests can fail; we might see+        --      (C x y) `cast` (g :: T a ~ S [a]),+        -- where S is a type function.  In fact, exprIsConApp+        -- will probably not be called in such circumstances,+        -- but there't nothing wrong with it++  = let+        tc_arity       = tyConArity to_tc+        dc_univ_tyvars = dataConUnivTyVars dc+        dc_ex_tyvars   = dataConExTyVars dc+        arg_tys        = dataConRepArgTys dc++        non_univ_args  = dropList dc_univ_tyvars dc_args+        (ex_args, val_args) = splitAtList dc_ex_tyvars non_univ_args++        -- Make the "Psi" from the paper+        omegas = decomposeCo tc_arity co+        (psi_subst, to_ex_arg_tys)+          = liftCoSubstWithEx Representational+                              dc_univ_tyvars+                              omegas+                              dc_ex_tyvars+                              (map exprToType ex_args)++          -- Cast the value arguments (which include dictionaries)+        new_val_args = zipWith cast_arg arg_tys val_args+        cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty)++        to_ex_args = map Type to_ex_arg_tys++        dump_doc = vcat [ppr dc,      ppr dc_univ_tyvars, ppr dc_ex_tyvars,+                         ppr arg_tys, ppr dc_args,+                         ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc ]+    in+    ASSERT2( eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args)), dump_doc )+    ASSERT2( equalLength val_args arg_tys, dump_doc )+    Just (dc, to_tc_arg_tys, to_ex_args ++ new_val_args)++  | otherwise+  = Nothing++  where+    Pair from_ty to_ty = coercionKind co++collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr)+-- Collect lambda binders, pushing coercions inside if possible+-- E.g.   (\x.e) |> g         g :: <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 -> Coercion -> ([Var], CoreExpr)+    -- (go_c bs e c) is same as (go bs e (e |> c))+    go_c bs (Cast e co1) co2 = go_c bs e (co1 `mkTransCo` co2)+    go_c bs (Lam b e)    co  = go_lam bs b e co+    go_c bs e            co  = (reverse bs, mkCast e co)++    -- We are in a lambda under a cast; peel off lambdas and build a+    -- new coercion for the body.+    go_lam :: [Var] -> Var -> CoreExpr -> Coercion -> ([Var], CoreExpr)+    -- (go_lam bs b e c) is same as (go_c bs (\b.e) c)+    go_lam bs b e co+      | isTyVar b+      , let Pair tyL tyR = coercionKind co+      , ASSERT( isForAllTy tyL )+        isForAllTy tyR+      , isReflCo (mkNthCo 0 co)  -- See Note [collectBindersPushingCo]+      = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkTyVarTy b)))++      | isId b+      , let Pair tyL tyR = coercionKind co+      , ASSERT( isFunTy tyL) isFunTy tyR+      , (co_arg, co_res) <- decomposeFunCo co+      , isReflCo co_arg  -- See Note [collectBindersPushingCo]+      = go_c (b:bs) e co_res++      | otherwise = (reverse bs, mkCast (Lam b e) co)++{- Note [collectBindersPushingCo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We just look for coercions of form+   <type> -> blah+(and similarly for foralls) to keep this function simple.  We could do+more elaborate stuff, but it'd involve substitution etc.+-}
+ coreSyn/CorePrep.hs view
@@ -0,0 +1,1587 @@+{-+(c) The University of Glasgow, 1994-2006+++Core pass to saturate constructors and PrimOps+-}++{-# LANGUAGE BangPatterns, CPP, MultiWayIf #-}++module CorePrep (+      corePrepPgm, corePrepExpr, cvtLitInteger,+      lookupMkIntegerName, lookupIntegerSDataConName+  ) where++#include "HsVersions.h"++import OccurAnal++import HscTypes+import PrelNames+import MkId             ( realWorldPrimId )+import CoreUtils+import CoreArity+import CoreFVs+import CoreMonad        ( CoreToDo(..) )+import CoreLint         ( endPassIO )+import CoreSyn+import CoreSubst+import MkCore hiding( FloatBind(..) )   -- We use our own FloatBind here+import Type+import Literal+import Coercion+import TcEnv+import TyCon+import Demand+import Var+import VarSet+import VarEnv+import Id+import IdInfo+import TysWiredIn+import DataCon+import PrimOp+import BasicTypes+import Module+import UniqSupply+import Maybes+import OrdList+import ErrUtils+import DynFlags+import Util+import Pair+import Outputable+import Platform+import FastString+import Config+import Name             ( NamedThing(..), nameSrcSpan )+import SrcLoc           ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )+import Data.Bits+import MonadUtils       ( mapAccumLM )+import Data.List        ( mapAccumL )+import Control.Monad++{-+-- ---------------------------------------------------------------------------+-- Overview+-- ---------------------------------------------------------------------------++The goal of this pass is to prepare for code generation.++1.  Saturate constructor and primop applications.++2.  Convert to A-normal form; that is, function arguments+    are always variables.++    * Use case for strict arguments:+        f E ==> case E of x -> f x+        (where f is strict)++    * Use let for non-trivial lazy arguments+        f E ==> let x = E in f x+        (were f is lazy and x is non-trivial)++3.  Similarly, convert any unboxed lets into cases.+    [I'm experimenting with leaving 'ok-for-speculation'+     rhss in let-form right up to this point.]++4.  Ensure that *value* lambdas only occur as the RHS of a binding+    (The code generator can't deal with anything else.)+    Type lambdas are ok, however, because the code gen discards them.++5.  [Not any more; nuked Jun 2002] Do the seq/par munging.++6.  Clone all local Ids.+    This means that all such Ids are unique, rather than the+    weaker guarantee of no clashes which the simplifier provides.+    And that is what the code generator needs.++    We don't clone TyVars or CoVars. The code gen doesn't need that,+    and doing so would be tiresome because then we'd need+    to substitute in types and coercions.++7.  Give each dynamic CCall occurrence a fresh unique; this is+    rather like the cloning step above.++8.  Inject bindings for the "implicit" Ids:+        * Constructor wrappers+        * Constructor workers+    We want curried definitions for all of these in case they+    aren't inlined by some caller.++9.  Replace (lazy e) by e.  See Note [lazyId magic] in MkId.hs+    Also replace (noinline e) by e.++10. Convert (LitInteger i t) into the core representation+    for the Integer i. Normally this uses mkInteger, but if+    we are using the integer-gmp implementation then there is a+    special case where we use the S# constructor for Integers that+    are in the range of Int.++11. Uphold tick consistency while doing this: We move ticks out of+    (non-type) applications where we can, and make sure that we+    annotate according to scoping rules when floating.++This is all done modulo type applications and abstractions, so that+when type erasure is done for conversion to STG, we don't end up with+any trivial or useless bindings.+++Note [CorePrep invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is the syntax of the Core produced by CorePrep:++    Trivial expressions+       arg ::= lit |  var+              | arg ty  |  /\a. arg+              | truv co  |  /\c. arg  |  arg |> co++    Applications+       app ::= lit  |  var  |  app arg  |  app ty  | app co | app |> co++    Expressions+       body ::= app+              | let(rec) x = rhs in body     -- Boxed only+              | case body of pat -> body+              | /\a. body | /\c. body+              | body |> co++    Right hand sides (only place where value lambdas can occur)+       rhs ::= /\a.rhs  |  \x.rhs  |  body++We define a synonym for each of these non-terminals.  Functions+with the corresponding name produce a result in that syntax.+-}++type CpeArg  = CoreExpr    -- Non-terminal 'arg'+type CpeApp  = CoreExpr    -- Non-terminal 'app'+type CpeBody = CoreExpr    -- Non-terminal 'body'+type CpeRhs  = CoreExpr    -- Non-terminal 'rhs'++{-+************************************************************************+*                                                                      *+                Top level stuff+*                                                                      *+************************************************************************+-}++corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon]+            -> IO CoreProgram+corePrepPgm hsc_env this_mod mod_loc binds data_tycons =+    withTiming (pure dflags)+               (text "CorePrep"<+>brackets (ppr this_mod))+               (const ()) $ do+    us <- mkSplitUniqSupply 's'+    initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env++    let implicit_binds = mkDataConWorkers dflags mod_loc data_tycons+            -- NB: we must feed mkImplicitBinds through corePrep too+            -- so that they are suitably cloned and eta-expanded++        binds_out = initUs_ us $ do+                      floats1 <- corePrepTopBinds initialCorePrepEnv binds+                      floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds+                      return (deFloatTop (floats1 `appendFloats` floats2))++    endPassIO hsc_env alwaysQualify CorePrep binds_out []+    return binds_out+  where+    dflags = hsc_dflags hsc_env++corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr+corePrepExpr dflags hsc_env expr =+    withTiming (pure dflags) (text "CorePrep [expr]") (const ()) $ do+    us <- mkSplitUniqSupply 's'+    initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env+    let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr)+    dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr)+    return new_expr++corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats+-- Note [Floating out of top level bindings]+corePrepTopBinds initialCorePrepEnv binds+  = go initialCorePrepEnv binds+  where+    go _   []             = return emptyFloats+    go env (bind : binds) = do (env', floats, maybe_new_bind)+                                 <- cpeBind TopLevel env bind+                               MASSERT(isNothing maybe_new_bind)+                                 -- Only join points get returned this way by+                                 -- cpeBind, and no join point may float to top+                               floatss <- go env' binds+                               return (floats `appendFloats` floatss)++mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> [CoreBind]+-- See Note [Data constructor workers]+-- c.f. Note [Injecting implicit bindings] in TidyPgm+mkDataConWorkers dflags mod_loc data_tycons+  = [ NonRec id (tick_it (getName data_con) (Var id))+                                -- The ice is thin here, but it works+    | tycon <- data_tycons,     -- CorePrep will eta-expand it+      data_con <- tyConDataCons tycon,+      let id = dataConWorkId data_con+    ]+ where+   -- If we want to generate debug info, we put a source note on the+   -- worker. This is useful, especially for heap profiling.+   tick_it name+     | debugLevel dflags == 0                = id+     | RealSrcSpan span <- nameSrcSpan name  = tick span+     | Just file <- ml_hs_file mod_loc       = tick (span1 file)+     | otherwise                             = tick (span1 "???")+     where tick span  = Tick (SourceNote span $ showSDoc dflags (ppr name))+           span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1++{-+Note [Floating out of top level bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+NB: we do need to float out of top-level bindings+Consider        x = length [True,False]+We want to get+                s1 = False : []+                s2 = True  : s1+                x  = length s2++We return a *list* of bindings, because we may start with+        x* = f (g y)+where x is demanded, in which case we want to finish with+        a = g y+        x* = f a+And then x will actually end up case-bound++Note [CafInfo and floating]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+What happens when we try to float bindings to the top level?  At this+point all the CafInfo is supposed to be correct, and we must make certain+that is true of the new top-level bindings.  There are two cases+to consider++a) The top-level binding is marked asCafRefs.  In that case we are+   basically fine.  The floated bindings had better all be lazy lets,+   so they can float to top level, but they'll all have HasCafRefs+   (the default) which is safe.++b) The top-level binding is marked NoCafRefs.  This really happens+   Example.  CoreTidy produces+      $fApplicativeSTM [NoCafRefs] = D:Alternative retry# ...blah...+   Now CorePrep has to eta-expand to+      $fApplicativeSTM = let sat = \xy. retry x y+                         in D:Alternative sat ...blah...+   So what we *want* is+      sat [NoCafRefs] = \xy. retry x y+      $fApplicativeSTM [NoCafRefs] = D:Alternative sat ...blah...++   So, gruesomely, we must set the NoCafRefs flag on the sat bindings,+   *and* substitute the modified 'sat' into the old RHS.++   It should be the case that 'sat' is itself [NoCafRefs] (a value, no+   cafs) else the original top-level binding would not itself have been+   marked [NoCafRefs].  The DEBUG check in CoreToStg for+   consistentCafInfo will find this.++This is all very gruesome and horrible. It would be better to figure+out CafInfo later, after CorePrep.  We'll do that in due course.+Meanwhile this horrible hack works.++Note [Join points and floating]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Join points can float out of other join points but not out of value bindings:++  let z =+    let  w = ... in -- can float+    join k = ... in -- can't float+    ... jump k ...+  join j x1 ... xn =+    let  y = ... in -- can float (but don't want to)+    join h = ... in -- can float (but not much point)+    ... jump h ...+  in ...++Here, the jump to h remains valid if h is floated outward, but the jump to k+does not.++We don't float *out* of join points. It would only be safe to float out of+nullary join points (or ones where the arguments are all either type arguments+or dead binders). Nullary join points aren't ever recursive, so they're always+effectively one-shot functions, which we don't float out of. We *could* float+join points from nullary join points, but there's no clear benefit at this+stage.++Note [Data constructor workers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Create any necessary "implicit" bindings for data con workers.  We+create the rather strange (non-recursive!) binding++        $wC = \x y -> $wC x y++i.e. a curried constructor that allocates.  This means that we can+treat the worker for a constructor like any other function in the rest+of the compiler.  The point here is that CoreToStg will generate a+StgConApp for the RHS, rather than a call to the worker (which would+give a loop).  As Lennart says: the ice is thin here, but it works.++Hmm.  Should we create bindings for dictionary constructors?  They are+always fully applied, and the bindings are just there to support+partial applications. But it's easier to let them through.+++Note [Dead code in CorePrep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Imagine that we got an input program like this (see Trac #4962):++  f :: Show b => Int -> (Int, b -> Maybe Int -> Int)+  f x = (g True (Just x) + g () (Just x), g)+    where+      g :: Show a => a -> Maybe Int -> Int+      g _ Nothing = x+      g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown++After specialisation and SpecConstr, we would get something like this:++  f :: Show b => Int -> (Int, b -> Maybe Int -> Int)+  f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g)+    where+      {-# RULES g $dBool = g$Bool+                g $dUnit = g$Unit #-}+      g = ...+      {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-}+      g$Bool = ...+      {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-}+      g$Unit = ...+      g$Bool_True_Just = ...+      g$Unit_Unit_Just = ...++Note that the g$Bool and g$Unit functions are actually dead code: they+are only kept alive by the occurrence analyser because they are+referred to by the rules of g, which is being kept alive by the fact+that it is used (unspecialised) in the returned pair.++However, at the CorePrep stage there is no way that the rules for g+will ever fire, and it really seems like a shame to produce an output+program that goes to the trouble of allocating a closure for the+unreachable g$Bool and g$Unit functions.++The way we fix this is to:+ * In cloneBndr, drop all unfoldings/rules++ * In deFloatTop, run a simple dead code analyser on each top-level+   RHS to drop the dead local bindings. For that call to OccAnal, we+   disable the binder swap, else the occurrence analyser sometimes+   introduces new let bindings for cased binders, which lead to the bug+   in #5433.++The reason we don't just OccAnal the whole output of CorePrep is that+the tidier ensures that all top-level binders are GlobalIds, so they+don't show up in the free variables any longer. So if you run the+occurrence analyser on the output of CoreTidy (or later) you e.g. turn+this program:++  Rec {+  f = ... f ...+  }++Into this one:++  f = ... f ...++(Since f is not considered to be free in its own RHS.)+++************************************************************************+*                                                                      *+                The main code+*                                                                      *+************************************************************************+-}++cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind+        -> UniqSM (CorePrepEnv,+                   Floats,         -- Floating value bindings+                   Maybe CoreBind) -- Just bind' <=> returned new bind; no float+                                   -- Nothing <=> added bind' to floats instead+cpeBind top_lvl env (NonRec bndr rhs)+  | not (isJoinId bndr)+  = do { (_, bndr1) <- cpCloneBndr env bndr+       ; let dmd         = idDemandInfo bndr+             is_unlifted = isUnliftedType (idType bndr)+       ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive+                                          dmd+                                          is_unlifted+                                          env bndr1 rhs+       -- See Note [Inlining in CorePrep]+       ; if exprIsTrivial rhs2 && isNotTopLevel top_lvl+            then return (extendCorePrepEnvExpr env bndr rhs2, floats, Nothing)+            else do {++       ; let new_float = mkFloat dmd is_unlifted bndr2 rhs2++        -- We want bndr'' in the envt, because it records+        -- the evaluated-ness of the binder+       ; return (extendCorePrepEnv env bndr bndr2,+                 addFloat floats new_float,+                 Nothing) }}+  | otherwise -- See Note [Join points and floating]+  = ASSERT(not (isTopLevel top_lvl)) -- can't have top-level join point+    do { (_, bndr1) <- cpCloneBndr env bndr+       ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs+       ; return (extendCorePrepEnv env bndr bndr2,+                 emptyFloats,+                 Just (NonRec bndr2 rhs1)) }++cpeBind top_lvl env (Rec pairs)+  | not (isJoinId (head bndrs))+  = do { (env', bndrs1) <- cpCloneBndrs env bndrs+       ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env') bndrs1 rhss++       ; let (floats_s, bndrs2, rhss2) = unzip3 stuff+             all_pairs = foldrOL add_float (bndrs2 `zip` rhss2)+                                           (concatFloats floats_s)+       ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),+                 unitFloat (FloatLet (Rec all_pairs)),+                 Nothing) }+  | otherwise -- See Note [Join points and floating]+  = do { (env', bndrs1) <- cpCloneBndrs env bndrs+       ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss++       ; let bndrs2 = map fst pairs1+       ; return (extendCorePrepEnvList env' (bndrs `zip` bndrs2),+                 emptyFloats,+                 Just (Rec pairs1)) }+  where+    (bndrs, rhss) = unzip pairs++        -- Flatten all the floats, and the current+        -- group into a single giant Rec+    add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2+    add_float (FloatLet (Rec prs1))   prs2 = prs1 ++ prs2+    add_float b                       _    = pprPanic "cpeBind" (ppr b)++---------------+cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool+        -> CorePrepEnv -> Id -> CoreExpr+        -> UniqSM (Floats, Id, CpeRhs)+-- Used for all bindings+cpePair top_lvl is_rec dmd is_unlifted env bndr rhs+  = ASSERT(not (isJoinId bndr)) -- those should use cpeJoinPair+    do { (floats1, rhs1) <- cpeRhsE env rhs++       -- See if we are allowed to float this stuff out of the RHS+       ; (floats2, rhs2) <- float_from_rhs floats1 rhs1++       -- Make the arity match up+       ; (floats3, rhs3)+            <- if manifestArity rhs1 <= arity+               then return (floats2, cpeEtaExpand arity rhs2)+               else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)+                               -- Note [Silly extra arguments]+                    (do { v <- newVar (idType bndr)+                        ; let float = mkFloat topDmd False v rhs2+                        ; return ( addFloat floats2 float+                                 , cpeEtaExpand arity (Var v)) })++        -- Wrap floating ticks+       ; let (floats4, rhs4) = wrapTicks floats3 rhs3++        -- Record if the binder is evaluated+        -- and otherwise trim off the unfolding altogether+        -- It's not used by the code generator; getting rid of it reduces+        -- heap usage and, since we may be changing uniques, we'd have+        -- to substitute to keep it right+       ; let bndr' | exprIsHNF rhs3 = bndr `setIdUnfolding` evaldUnfolding+                   | otherwise      = bndr `setIdUnfolding` noUnfolding++       ; return (floats4, bndr', rhs4) }+  where+    platform = targetPlatform (cpe_dynFlags env)++    arity = idArity bndr        -- We must match this arity++    ---------------------+    float_from_rhs floats rhs+      | isEmptyFloats floats = return (emptyFloats, rhs)+      | isTopLevel top_lvl   = float_top    floats rhs+      | otherwise            = float_nested floats rhs++    ---------------------+    float_nested floats rhs+      | wantFloatNested is_rec dmd is_unlifted floats rhs+                  = return (floats, rhs)+      | otherwise = dontFloat floats rhs++    ---------------------+    float_top floats rhs        -- Urhgh!  See Note [CafInfo and floating]+      | mayHaveCafRefs (idCafInfo bndr)+      , allLazyTop floats+      = return (floats, rhs)++      -- So the top-level binding is marked NoCafRefs+      | Just (floats', rhs') <- canFloatFromNoCaf platform floats rhs+      = return (floats', rhs')++      | otherwise+      = dontFloat floats rhs++dontFloat :: Floats -> CpeRhs -> UniqSM (Floats, CpeBody)+-- Non-empty floats, but do not want to float from rhs+-- So wrap the rhs in the floats+-- But: rhs1 might have lambdas, and we can't+--      put them inside a wrapBinds+dontFloat floats1 rhs+  = do { (floats2, body) <- rhsToBody rhs+        ; return (emptyFloats, wrapBinds floats1 $+                               wrapBinds floats2 body) }++{- Note [Silly extra arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we had this+        f{arity=1} = \x\y. e+We *must* match the arity on the Id, so we have to generate+        f' = \x\y. e+        f  = \x. f' x++It's a bizarre case: why is the arity on the Id wrong?  Reason+(in the days of __inline_me__):+        f{arity=0} = __inline_me__ (let v = expensive in \xy. e)+When InlineMe notes go away this won't happen any more.  But+it seems good for CorePrep to be robust.+-}++---------------+cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr+            -> UniqSM (JoinId, CpeRhs)+-- Used for all join bindings+cpeJoinPair env bndr rhs+  = ASSERT(isJoinId bndr)+    do { let Just join_arity = isJoinId_maybe bndr+             (bndrs, body)   = collectNBinders join_arity rhs++       ; (env', bndrs') <- cpCloneBndrs env bndrs++       ; body' <- cpeBodyNF env' body -- Will let-bind the body if it starts+                                      -- with a lambda++       ; let rhs'  = mkCoreLams bndrs' body'+             bndr' = bndr `setIdUnfolding` evaldUnfolding+                          `setIdArity` count isId bndrs+                            -- See Note [Arity and join points]++       ; return (bndr', rhs') }++{-+Note [Arity and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Up to now, we've allowed a join point to have an arity greater than its join+arity (minus type arguments), since this is what's useful for eta expansion.+However, for code gen purposes, its arity must be exactly the number of value+arguments it will be called with, and it must have exactly that many value+lambdas. Hence if there are extra lambdas we must let-bind the body of the RHS:++  join j x y z = \w -> ... in ...+    =>+  join j x y z = (let f = \w -> ... in f) in ...++This is also what happens with Note [Silly extra arguments]. Note that it's okay+for us to mess with the arity because a join point is never exported.+-}++-- ---------------------------------------------------------------------------+--              CpeRhs: produces a result satisfying CpeRhs+-- ---------------------------------------------------------------------------++cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)+-- If+--      e  ===>  (bs, e')+-- then+--      e = let bs in e'        (semantically, that is!)+--+-- For example+--      f (g x)   ===>   ([v = g x], f v)++cpeRhsE _env expr@(Type {})      = return (emptyFloats, expr)+cpeRhsE _env expr@(Coercion {})  = return (emptyFloats, expr)+cpeRhsE env (Lit (LitInteger i _))+    = cpeRhsE env (cvtLitInteger (cpe_dynFlags env) (getMkIntegerId env)+                   (cpe_integerSDataCon env) i)+cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)+cpeRhsE env expr@(Var {})  = cpeApp env expr+cpeRhsE env expr@(App {}) = cpeApp env expr++cpeRhsE env (Let bind body)+  = do { (env', bind_floats, maybe_bind') <- cpeBind NotTopLevel env bind+       ; (body_floats, body') <- cpeRhsE env' body+       ; let expr' = case maybe_bind' of Just bind' -> Let bind' body'+                                         Nothing    -> body'+       ; return (bind_floats `appendFloats` body_floats, expr') }++cpeRhsE env (Tick tickish expr)+  | tickishPlace tickish == PlaceNonLam && tickish `tickishScopesLike` SoftScope+  = do { (floats, body) <- cpeRhsE env expr+         -- See [Floating Ticks in CorePrep]+       ; return (unitFloat (FloatTick tickish) `appendFloats` floats, body) }+  | otherwise+  = do { body <- cpeBodyNF env expr+       ; return (emptyFloats, mkTick tickish' body) }+  where+    tickish' | Breakpoint n fvs <- tickish+             -- See also 'substTickish'+             = Breakpoint n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs)+             | otherwise+             = tickish++cpeRhsE env (Cast expr co)+   = do { (floats, expr') <- cpeRhsE env expr+        ; return (floats, Cast expr' co) }++cpeRhsE env expr@(Lam {})+   = do { let (bndrs,body) = collectBinders expr+        ; (env', bndrs') <- cpCloneBndrs env bndrs+        ; body' <- cpeBodyNF env' body+        ; return (emptyFloats, mkLams bndrs' body') }++cpeRhsE env (Case scrut bndr ty alts)+  = do { (floats, scrut') <- cpeBody env scrut+       ; let bndr1 = bndr `setIdUnfolding` evaldUnfolding+            -- Record that the case binder is evaluated in the alternatives+       ; (env', bndr2) <- cpCloneBndr env bndr1+       ; alts' <- mapM (sat_alt env') alts+       ; return (floats, Case scrut' bndr2 ty alts') }+  where+    sat_alt env (con, bs, rhs)+       = do { (env2, bs') <- cpCloneBndrs env bs+            ; rhs' <- cpeBodyNF env2 rhs+            ; return (con, bs', rhs') }++cvtLitInteger :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr+-- Here we convert a literal Integer to the low-level+-- representation. Exactly how we do this depends on the+-- library that implements Integer.  If it's GMP we+-- use the S# data constructor for small literals.+-- See Note [Integer literals] in Literal+cvtLitInteger dflags _ (Just sdatacon) i+  | inIntRange dflags i -- Special case for small integers+    = mkConApp sdatacon [Lit (mkMachInt dflags i)]++cvtLitInteger dflags mk_integer _ i+    = mkApps (Var mk_integer) [isNonNegative, ints]+  where isNonNegative = if i < 0 then mkConApp falseDataCon []+                                 else mkConApp trueDataCon  []+        ints = mkListExpr intTy (f (abs i))+        f 0 = []+        f x = let low  = x .&. mask+                  high = x `shiftR` bits+              in mkConApp intDataCon [Lit (mkMachInt dflags low)] : f high+        bits = 31+        mask = 2 ^ bits - 1++-- ---------------------------------------------------------------------------+--              CpeBody: produces a result satisfying CpeBody+-- ---------------------------------------------------------------------------++-- | Convert a 'CoreExpr' so it satisfies 'CpeBody', without+-- producing any floats (any generated floats are immediately+-- let-bound using 'wrapBinds').  Generally you want this, esp.+-- when you've reached a binding form (e.g., a lambda) and+-- floating any further would be incorrect.+cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody+cpeBodyNF env expr+  = do { (floats, body) <- cpeBody env expr+       ; return (wrapBinds floats body) }++-- | Convert a 'CoreExpr' so it satisfies 'CpeBody'; also produce+-- a list of 'Floats' which are being propagated upwards.  In+-- fact, this function is used in only two cases: to+-- implement 'cpeBodyNF' (which is what you usually want),+-- and in the case when a let-binding is in a case scrutinee--here,+-- we can always float out:+--+--      case (let x = y in z) of ...+--      ==> let x = y in case z of ...+--+cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)+cpeBody env expr+  = do { (floats1, rhs) <- cpeRhsE env expr+       ; (floats2, body) <- rhsToBody rhs+       ; return (floats1 `appendFloats` floats2, body) }++--------+rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)+-- Remove top level lambdas by let-binding++rhsToBody (Tick t expr)+  | tickishScoped t == NoScope  -- only float out of non-scoped annotations+  = do { (floats, expr') <- rhsToBody expr+       ; return (floats, mkTick t expr') }++rhsToBody (Cast e co)+        -- You can get things like+        --      case e of { p -> coerce t (\s -> ...) }+  = do { (floats, e') <- rhsToBody e+       ; return (floats, Cast e' co) }++rhsToBody expr@(Lam {})+  | Just no_lam_result <- tryEtaReducePrep bndrs body+  = return (emptyFloats, no_lam_result)+  | all isTyVar bndrs           -- Type lambdas are ok+  = return (emptyFloats, expr)+  | otherwise                   -- Some value lambdas+  = do { fn <- newVar (exprType expr)+       ; let rhs   = cpeEtaExpand (exprArity expr) expr+             float = FloatLet (NonRec fn rhs)+       ; return (unitFloat float, Var fn) }+  where+    (bndrs,body) = collectBinders expr++rhsToBody expr = return (emptyFloats, expr)++++-- ---------------------------------------------------------------------------+--              CpeApp: produces a result satisfying CpeApp+-- ---------------------------------------------------------------------------++data ArgInfo = CpeApp  CoreArg+             | CpeCast Coercion+             | CpeTick (Tickish Id)++{- Note [runRW arg]+~~~~~~~~~~~~~~~~~~~+If we got, say+   runRW# (case bot of {})+which happened in Trac #11291, we do /not/ want to turn it into+   (case bot of {}) realWorldPrimId#+because that gives a panic in CoreToStg.myCollectArgs, which expects+only variables in function position.  But if we are sure to make+runRW# strict (which we do in MkId), this can't happen+-}++cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)+-- May return a CpeRhs because of saturating primops+cpeApp top_env expr+  = do { let (terminal, args, depth) = collect_args expr+       ; cpe_app top_env terminal args depth+       }++  where+    -- We have a nested data structure of the form+    -- e `App` a1 `App` a2 ... `App` an, convert it into+    -- (e, [CpeApp a1, CpeApp a2, ..., CpeApp an], depth)+    -- We use 'ArgInfo' because we may also need to+    -- record casts and ticks.  Depth counts the number+    -- of arguments that would consume strictness information+    -- (so, no type or coercion arguments.)+    collect_args :: CoreExpr -> (CoreExpr, [ArgInfo], Int)+    collect_args e = go e [] 0+      where+        go (App fun arg)      as !depth+            = go fun (CpeApp arg : as)+                (if isTyCoArg arg then depth else depth + 1)+        go (Cast fun co)      as depth+            = go fun (CpeCast co : as) depth+        go (Tick tickish fun) as depth+            | tickishPlace tickish == PlaceNonLam+            && tickish `tickishScopesLike` SoftScope+            = go fun (CpeTick tickish : as) depth+        go terminal as depth = (terminal, as, depth)++    cpe_app :: CorePrepEnv+            -> CoreExpr+            -> [ArgInfo]+            -> Int+            -> UniqSM (Floats, CpeRhs)+    cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) depth+        | f `hasKey` lazyIdKey          -- Replace (lazy a) with a, and+       || f `hasKey` noinlineIdKey      -- Replace (noinline a) with a+        -- Consider the code:+        --+        --      lazy (f x) y+        --+        -- We need to make sure that we need to recursively collect arguments on+        -- "f x", otherwise we'll float "f x" out (it's not a variable) and+        -- end up with this awful -ddump-prep:+        --+        --      case f x of f_x {+        --        __DEFAULT -> f_x y+        --      }+        --+        -- rather than the far superior "f x y".  Test case is par01.+        = let (terminal, args', depth') = collect_args arg+          in cpe_app env terminal (args' ++ args) (depth + depth' - 1)+    cpe_app env (Var f) [CpeApp _runtimeRep@Type{}, CpeApp _type@Type{}, CpeApp arg] 1+        | f `hasKey` runRWKey+        -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this+        -- is why we return a CorePrepEnv as well)+        = case arg of+            Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body [] 0+            _          -> cpe_app env arg [CpeApp (Var realWorldPrimId)] 1+    cpe_app env (Var v) args depth+      = do { v1 <- fiddleCCall v+           ; let e2 = lookupCorePrepEnv env v1+                 hd = getIdFromTrivialExpr_maybe e2+           -- NB: depth from collect_args is right, because e2 is a trivial expression+           -- and thus its embedded Id *must* be at the same depth as any+           -- Apps it is under are type applications only (c.f.+           -- exprIsTrivial).  But note that we need the type of the+           -- expression, not the id.+           ; (app, floats) <- rebuild_app args e2 (exprType e2) emptyFloats stricts+           ; mb_saturate hd app floats depth }+        where+          stricts = case idStrictness v of+                            StrictSig (DmdType _ demands _)+                              | listLengthCmp demands depth /= GT -> demands+                                    -- length demands <= depth+                              | otherwise                         -> []+                -- If depth < length demands, then we have too few args to+                -- satisfy strictness  info so we have to  ignore all the+                -- strictness info, e.g. + (error "urk")+                -- Here, we can't evaluate the arg strictly, because this+                -- partial application might be seq'd++        -- We inlined into something that's not a var and has no args.+        -- Bounce it back up to cpeRhsE.+    cpe_app env fun [] _ = cpeRhsE env fun++        -- N-variable fun, better let-bind it+    cpe_app env fun args depth+      = do { (fun_floats, fun') <- cpeArg env evalDmd fun ty+                          -- The evalDmd says that it's sure to be evaluated,+                          -- so we'll end up case-binding it+           ; (app, floats) <- rebuild_app args fun' ty fun_floats []+           ; mb_saturate Nothing app floats depth }+        where+          ty = exprType fun++    -- Saturate if necessary+    mb_saturate head app floats depth =+       case head of+         Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth+                          ; return (floats, sat_app) }+         _other              -> return (floats, app)++    -- Deconstruct and rebuild the application, floating any non-atomic+    -- arguments to the outside.  We collect the type of the expression,+    -- the head of the application, and the number of actual value arguments,+    -- all of which are used to possibly saturate this application if it+    -- has a constructor or primop at the head.+    rebuild_app+        :: [ArgInfo]                  -- The arguments (inner to outer)+        -> CpeApp+        -> Type+        -> Floats+        -> [Demand]+        -> UniqSM (CpeApp, Floats)+    rebuild_app [] app _ floats ss = do+      MASSERT(null ss) -- make sure we used all the strictness info+      return (app, floats)+    rebuild_app (a : as) fun' fun_ty floats ss = case a of+      CpeApp arg@(Type arg_ty) ->+        rebuild_app as (App fun' arg) (piResultTy fun_ty arg_ty) floats ss+      CpeApp arg@(Coercion {}) ->+        rebuild_app as (App fun' arg) (funResultTy fun_ty) floats ss+      CpeApp arg -> do+        let (ss1, ss_rest)  -- See Note [lazyId magic] in MkId+               = case (ss, isLazyExpr arg) of+                   (_   : ss_rest, True)  -> (topDmd, ss_rest)+                   (ss1 : ss_rest, False) -> (ss1,    ss_rest)+                   ([],            _)     -> (topDmd, [])+            (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $+                               splitFunTy_maybe fun_ty+        (fs, arg') <- cpeArg top_env ss1 arg arg_ty+        rebuild_app as (App fun' arg') res_ty (fs `appendFloats` floats) ss_rest+      CpeCast co ->+        let Pair _ty1 ty2 = coercionKind co+        in rebuild_app as (Cast fun' co) ty2 floats ss+      CpeTick tickish ->+        -- See [Floating Ticks in CorePrep]+        rebuild_app as fun' fun_ty (addFloat floats (FloatTick tickish)) ss++isLazyExpr :: CoreExpr -> Bool+-- See Note [lazyId magic] in MkId+isLazyExpr (Cast e _)              = isLazyExpr e+isLazyExpr (Tick _ e)              = isLazyExpr e+isLazyExpr (Var f `App` _ `App` _) = f `hasKey` lazyIdKey+isLazyExpr _                       = False++-- ---------------------------------------------------------------------------+--      CpeArg: produces a result satisfying CpeArg+-- ---------------------------------------------------------------------------++{-+Note [ANF-ising literal string arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Consider a program like,++    data Foo = Foo Addr#++    foo = Foo "turtle"#++When we go to ANFise this we might think that we want to float the string+literal like we do any other non-trivial argument. This would look like,++    foo = u\ [] case "turtle"# of s { __DEFAULT__ -> Foo s }++However, this 1) isn't necessary since strings are in a sense "trivial"; and 2)+wreaks havoc on the CAF annotations that we produce here since we the result+above is caffy since it is updateable. Ideally at some point in the future we+would like to just float the literal to the top level as suggested in #11312,++    s = "turtle"#+    foo = Foo s++However, until then we simply add a special case excluding literals from the+floating done by cpeArg.+-}++-- | Is an argument okay to CPE?+okCpeArg :: CoreExpr -> Bool+-- Don't float literals. See Note [ANF-ising literal string arguments].+okCpeArg (Lit _) = False+-- Do not eta expand a trivial argument+okCpeArg expr    = not (exprIsTrivial expr)++-- This is where we arrange that a non-trivial argument is let-bound+cpeArg :: CorePrepEnv -> Demand+       -> CoreArg -> Type -> UniqSM (Floats, CpeArg)+cpeArg env dmd arg arg_ty+  = do { (floats1, arg1) <- cpeRhsE env arg     -- arg1 can be a lambda+       ; (floats2, arg2) <- if want_float floats1 arg1+                            then return (floats1, arg1)+                            else dontFloat floats1 arg1+                -- Else case: arg1 might have lambdas, and we can't+                --            put them inside a wrapBinds++       ; if okCpeArg arg2+         then do { v <- newVar arg_ty+                 ; let arg3      = cpeEtaExpand (exprArity arg2) arg2+                       arg_float = mkFloat dmd is_unlifted v arg3+                 ; return (addFloat floats2 arg_float, varToCoreExpr v) }+         else return (floats2, arg2)+       }+  where+    is_unlifted = isUnliftedType arg_ty+    want_float  = wantFloatNested NonRecursive dmd is_unlifted++{-+Note [Floating unlifted arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider    C (let v* = expensive in v)++where the "*" indicates "will be demanded".  Usually v will have been+inlined by now, but let's suppose it hasn't (see Trac #2756).  Then we+do *not* want to get++     let v* = expensive in C v++because that has different strictness.  Hence the use of 'allLazy'.+(NB: the let v* turns into a FloatCase, in mkLocalNonRec.)+++------------------------------------------------------------------------------+-- Building the saturated syntax+-- ---------------------------------------------------------------------------++maybeSaturate deals with saturating primops and constructors+The type is the type of the entire application+-}++maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs+maybeSaturate fn expr n_args+  | Just DataToTagOp <- isPrimOpId_maybe fn     -- DataToTag must have an evaluated arg+                                                -- A gruesome special case+  = saturateDataToTag sat_expr++  | hasNoBinding fn        -- There's no binding+  = return sat_expr++  | otherwise+  = return expr+  where+    fn_arity     = idArity fn+    excess_arity = fn_arity - n_args+    sat_expr     = cpeEtaExpand excess_arity expr++-------------+saturateDataToTag :: CpeApp -> UniqSM CpeApp+-- See Note [dataToTag magic]+saturateDataToTag sat_expr+  = do { let (eta_bndrs, eta_body) = collectBinders sat_expr+       ; eta_body' <- eval_data2tag_arg eta_body+       ; return (mkLams eta_bndrs eta_body') }+  where+    eval_data2tag_arg :: CpeApp -> UniqSM CpeBody+    eval_data2tag_arg app@(fun `App` arg)+        | exprIsHNF arg         -- Includes nullary constructors+        = return app            -- The arg is evaluated+        | otherwise                     -- Arg not evaluated, so evaluate it+        = do { arg_id <- newVar (exprType arg)+             ; let arg_id1 = setIdUnfolding arg_id evaldUnfolding+             ; return (Case arg arg_id1 (exprType app)+                            [(DEFAULT, [], fun `App` Var arg_id1)]) }++    eval_data2tag_arg (Tick t app)    -- Scc notes can appear+        = do { app' <- eval_data2tag_arg app+             ; return (Tick t app') }++    eval_data2tag_arg other     -- Should not happen+        = pprPanic "eval_data2tag" (ppr other)++{-+Note [dataToTag magic]+~~~~~~~~~~~~~~~~~~~~~~+Horrid: we must ensure that the arg of data2TagOp is evaluated+  (data2tag x) -->  (case x of y -> data2tag y)+(yuk yuk) take into account the lambdas we've now introduced++How might it not be evaluated?  Well, we might have floated it out+of the scope of a `seq`, or dropped the `seq` altogether.+++************************************************************************+*                                                                      *+                Simple CoreSyn operations+*                                                                      *+************************************************************************+-}++{-+-- -----------------------------------------------------------------------------+--      Eta reduction+-- -----------------------------------------------------------------------------++Note [Eta expansion]+~~~~~~~~~~~~~~~~~~~~~+Eta expand to match the arity claimed by the binder Remember,+CorePrep must not change arity++Eta expansion might not have happened already, because it is done by+the simplifier only when there at least one lambda already.++NB1:we could refrain when the RHS is trivial (which can happen+    for exported things).  This would reduce the amount of code+    generated (a little) and make things a little words for+    code compiled without -O.  The case in point is data constructor+    wrappers.++NB2: we have to be careful that the result of etaExpand doesn't+   invalidate any of the assumptions that CorePrep is attempting+   to establish.  One possible cause is eta expanding inside of+   an SCC note - we're now careful in etaExpand to make sure the+   SCC is pushed inside any new lambdas that are generated.++Note [Eta expansion and the CorePrep invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It turns out to be much much easier to do eta expansion+*after* the main CorePrep stuff.  But that places constraints+on the eta expander: given a CpeRhs, it must return a CpeRhs.++For example here is what we do not want:+                f = /\a -> g (h 3)      -- h has arity 2+After ANFing we get+                f = /\a -> let s = h 3 in g s+and now we do NOT want eta expansion to give+                f = /\a -> \ y -> (let s = h 3 in g s) y++Instead CoreArity.etaExpand gives+                f = /\a -> \y -> let s = h 3 in g s y+-}++cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs+cpeEtaExpand arity expr+  | arity == 0 = expr+  | otherwise  = etaExpand arity expr++{-+-- -----------------------------------------------------------------------------+--      Eta reduction+-- -----------------------------------------------------------------------------++Why try eta reduction?  Hasn't the simplifier already done eta?+But the simplifier only eta reduces if that leaves something+trivial (like f, or f Int).  But for deLam it would be enough to+get to a partial application:+        case x of { p -> \xs. map f xs }+    ==> case x of { p -> map f }+-}++tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr+tryEtaReducePrep bndrs expr@(App _ _)+  | ok_to_eta_reduce f+  , n_remaining >= 0+  , and (zipWith ok bndrs last_args)+  , not (any (`elemVarSet` fvs_remaining) bndrs)+  , exprIsHNF remaining_expr   -- Don't turn value into a non-value+                               -- else the behaviour with 'seq' changes+  = Just remaining_expr+  where+    (f, args) = collectArgs expr+    remaining_expr = mkApps f remaining_args+    fvs_remaining = exprFreeVars remaining_expr+    (remaining_args, last_args) = splitAt n_remaining args+    n_remaining = length args - length bndrs++    ok bndr (Var arg) = bndr == arg+    ok _    _         = False++          -- We can't eta reduce something which must be saturated.+    ok_to_eta_reduce (Var f) = not (hasNoBinding f)+    ok_to_eta_reduce _       = False -- Safe. ToDo: generalise++tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body)+  | not (any (`elemVarSet` fvs) bndrs)+  = case tryEtaReducePrep bndrs body of+        Just e -> Just (Let bind e)+        Nothing -> Nothing+  where+    fvs = exprFreeVars r++-- NB: do not attempt to eta-reduce across ticks+-- Otherwise we risk reducing+--       \x. (Tick (Breakpoint {x}) f x)+--   ==> Tick (breakpoint {x}) f+-- which is bogus (Trac #17228)+-- tryEtaReducePrep bndrs (Tick tickish e)+--   = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e++tryEtaReducePrep _ _ = Nothing++{-+************************************************************************+*                                                                      *+                Floats+*                                                                      *+************************************************************************++Note [Pin demand info on floats]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We pin demand info on floated lets, so that we can see the one-shot thunks.+-}++data FloatingBind+  = FloatLet CoreBind    -- Rhs of bindings are CpeRhss+                         -- They are always of lifted type;+                         -- unlifted ones are done with FloatCase++ | FloatCase+      Id CpeBody+      Bool              -- The bool indicates "ok-for-speculation"++ -- | See Note [Floating Ticks in CorePrep]+ | FloatTick (Tickish Id)++data Floats = Floats OkToSpec (OrdList FloatingBind)++instance Outputable FloatingBind where+  ppr (FloatLet b) = ppr b+  ppr (FloatCase b r ok) = brackets (ppr ok) <+> ppr b <+> equals <+> ppr r+  ppr (FloatTick t) = ppr t++instance Outputable Floats where+  ppr (Floats flag fs) = text "Floats" <> brackets (ppr flag) <+>+                         braces (vcat (map ppr (fromOL fs)))++instance Outputable OkToSpec where+  ppr OkToSpec    = text "OkToSpec"+  ppr IfUnboxedOk = text "IfUnboxedOk"+  ppr NotOkToSpec = text "NotOkToSpec"++-- Can we float these binds out of the rhs of a let?  We cache this decision+-- to avoid having to recompute it in a non-linear way when there are+-- deeply nested lets.+data OkToSpec+   = OkToSpec           -- Lazy bindings of lifted type+   | IfUnboxedOk        -- A mixture of lazy lifted bindings and n+                        -- ok-to-speculate unlifted bindings+   | NotOkToSpec        -- Some not-ok-to-speculate unlifted bindings++mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind+mkFloat dmd is_unlifted bndr rhs+  | use_case  = FloatCase bndr rhs (exprOkForSpeculation rhs)+  | is_hnf    = FloatLet (NonRec bndr                       rhs)+  | otherwise = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs)+                   -- See Note [Pin demand info on floats]+  where+    is_hnf    = exprIsHNF rhs+    is_strict = isStrictDmd dmd+    use_case  = is_unlifted || is_strict && not is_hnf+                -- Don't make a case for a value binding,+                -- even if it's strict.  Otherwise we get+                --      case (\x -> e) of ...!++emptyFloats :: Floats+emptyFloats = Floats OkToSpec nilOL++isEmptyFloats :: Floats -> Bool+isEmptyFloats (Floats _ bs) = isNilOL bs++wrapBinds :: Floats -> CpeBody -> CpeBody+wrapBinds (Floats _ binds) body+  = foldrOL mk_bind body binds+  where+    mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]+    mk_bind (FloatLet bind)        body = Let bind body+    mk_bind (FloatTick tickish)    body = mkTick tickish body++addFloat :: Floats -> FloatingBind -> Floats+addFloat (Floats ok_to_spec floats) new_float+  = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)+  where+    check (FloatLet _) = OkToSpec+    check (FloatCase _ _ ok_for_spec)+        | ok_for_spec  =  IfUnboxedOk+        | otherwise    =  NotOkToSpec+    check FloatTick{}  = OkToSpec+        -- The ok-for-speculation flag says that it's safe to+        -- float this Case out of a let, and thereby do it more eagerly+        -- We need the top-level flag because it's never ok to float+        -- an unboxed binding to the top level++unitFloat :: FloatingBind -> Floats+unitFloat = addFloat emptyFloats++appendFloats :: Floats -> Floats -> Floats+appendFloats (Floats spec1 floats1) (Floats spec2 floats2)+  = Floats (combine spec1 spec2) (floats1 `appOL` floats2)++concatFloats :: [Floats] -> OrdList FloatingBind+concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL++combine :: OkToSpec -> OkToSpec -> OkToSpec+combine NotOkToSpec _ = NotOkToSpec+combine _ NotOkToSpec = NotOkToSpec+combine IfUnboxedOk _ = IfUnboxedOk+combine _ IfUnboxedOk = IfUnboxedOk+combine _ _           = OkToSpec++deFloatTop :: Floats -> [CoreBind]+-- For top level only; we don't expect any FloatCases+deFloatTop (Floats _ floats)+  = foldrOL get [] floats+  where+    get (FloatLet b) bs = occurAnalyseRHSs b : bs+    get (FloatCase var body _) bs  =+      occurAnalyseRHSs (NonRec var body) : bs+    get b _ = pprPanic "corePrepPgm" (ppr b)++    -- See Note [Dead code in CorePrep]+    occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr_NoBinderSwap e)+    occurAnalyseRHSs (Rec xes)    = Rec [(x, occurAnalyseExpr_NoBinderSwap e) | (x, e) <- xes]++---------------------------------------------------------------------------++canFloatFromNoCaf :: Platform -> Floats -> CpeRhs -> Maybe (Floats, CpeRhs)+       -- Note [CafInfo and floating]+canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs+  | OkToSpec <- ok_to_spec           -- Worth trying+  , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs)+  = Just (Floats OkToSpec fs', subst_expr subst rhs)+  | otherwise+  = Nothing+  where+    subst_expr = substExpr (text "CorePrep")++    go :: (Subst, OrdList FloatingBind) -> [FloatingBind]+       -> Maybe (Subst, OrdList FloatingBind)++    go (subst, fbs_out) [] = Just (subst, fbs_out)++    go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in)+      | rhs_ok r+      = go (subst', fbs_out `snocOL` new_fb) fbs_in+      where+        (subst', b') = set_nocaf_bndr subst b+        new_fb = FloatLet (NonRec b' (subst_expr subst r))++    go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in)+      | all rhs_ok rs+      = go (subst', fbs_out `snocOL` new_fb) fbs_in+      where+        (bs,rs) = unzip prs+        (subst', bs') = mapAccumL set_nocaf_bndr subst bs+        rs' = map (subst_expr subst') rs+        new_fb = FloatLet (Rec (bs' `zip` rs'))++    go (subst, fbs_out) (ft@FloatTick{} : fbs_in)+      = go (subst, fbs_out `snocOL` ft) fbs_in++    go _ _ = Nothing      -- Encountered a caffy binding++    ------------+    set_nocaf_bndr subst bndr+      = (extendIdSubst subst bndr (Var bndr'), bndr')+      where+        bndr' = bndr `setIdCafInfo` NoCafRefs++    ------------+    rhs_ok :: CoreExpr -> Bool+    -- We can only float to top level from a NoCaf thing if+    -- the new binding is static. However it can't mention+    -- any non-static things or it would *already* be Caffy+    rhs_ok = rhsIsStatic platform (\_ -> False)+                         (\i -> pprPanic "rhsIsStatic" (integer i))+                         -- Integer literals should not show up++wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool+wantFloatNested is_rec dmd is_unlifted floats rhs+  =  isEmptyFloats floats+  || isStrictDmd dmd+  || is_unlifted+  || (allLazyNested is_rec floats && exprIsHNF rhs)+        -- Why the test for allLazyNested?+        --      v = f (x `divInt#` y)+        -- we don't want to float the case, even if f has arity 2,+        -- because floating the case would make it evaluated too early++allLazyTop :: Floats -> Bool+allLazyTop (Floats OkToSpec _) = True+allLazyTop _                   = False++allLazyNested :: RecFlag -> Floats -> Bool+allLazyNested _      (Floats OkToSpec    _) = True+allLazyNested _      (Floats NotOkToSpec _) = False+allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec++{-+************************************************************************+*                                                                      *+                Cloning+*                                                                      *+************************************************************************+-}++-- ---------------------------------------------------------------------------+--                      The environment+-- ---------------------------------------------------------------------------++-- Note [Inlining in CorePrep]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- There is a subtle but important invariant that must be upheld in the output+-- of CorePrep: there are no "trivial" updatable thunks.  Thus, this Core+-- is impermissible:+--+--      let x :: ()+--          x = y+--+-- (where y is a reference to a GLOBAL variable).  Thunks like this are silly:+-- they can always be profitably replaced by inlining x with y. Consequently,+-- the code generator/runtime does not bother implementing this properly+-- (specifically, there is no implementation of stg_ap_0_upd_info, which is the+-- stack frame that would be used to update this thunk.  The "0" means it has+-- zero free variables.)+--+-- In general, the inliner is good at eliminating these let-bindings.  However,+-- there is one case where these trivial updatable thunks can arise: when+-- we are optimizing away 'lazy' (see Note [lazyId magic], and also+-- 'cpeRhsE'.)  Then, we could have started with:+--+--      let x :: ()+--          x = lazy @ () y+--+-- which is a perfectly fine, non-trivial thunk, but then CorePrep will+-- drop 'lazy', giving us 'x = y' which is trivial and impermissible.+-- The solution is CorePrep to have a miniature inlining pass which deals+-- with cases like this.  We can then drop the let-binding altogether.+--+-- Why does the removal of 'lazy' have to occur in CorePrep?+-- The gory details are in Note [lazyId magic] in MkId, but the+-- main reason is that lazy must appear in unfoldings (optimizer+-- output) and it must prevent call-by-value for catch# (which+-- is implemented by CorePrep.)+--+-- An alternate strategy for solving this problem is to have the+-- inliner treat 'lazy e' as a trivial expression if 'e' is trivial.+-- We decided not to adopt this solution to keep the definition+-- of 'exprIsTrivial' simple.+--+-- There is ONE caveat however: for top-level bindings we have+-- to preserve the binding so that we float the (hacky) non-recursive+-- binding for data constructors; see Note [Data constructor workers].+--+-- Note [CorePrep inlines trivial CoreExpr not Id]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Why does cpe_env need to be an IdEnv CoreExpr, as opposed to an+-- IdEnv Id?  Naively, we might conjecture that trivial updatable thunks+-- as per Note [Inlining in CorePrep] always have the form+-- 'lazy @ SomeType gbl_id'.  But this is not true: the following is+-- perfectly reasonable Core:+--+--      let x :: ()+--          x = lazy @ (forall a. a) y @ Bool+--+-- When we inline 'x' after eliminating 'lazy', we need to replace+-- occurrences of 'x' with 'y @ bool', not just 'y'.  Situations like+-- this can easily arise with higher-rank types; thus, cpe_env must+-- map to CoreExprs, not Ids.++data CorePrepEnv+  = CPE { cpe_dynFlags        :: DynFlags+        , cpe_env             :: IdEnv CoreExpr   -- Clone local Ids+        -- ^ This environment is used for three operations:+        --+        --      1. To support cloning of local Ids so that they are+        --      all unique (see item (6) of CorePrep overview).+        --+        --      2. To support beta-reduction of runRW, see+        --      Note [runRW magic] and Note [runRW arg].+        --+        --      3. To let us inline trivial RHSs of non top-level let-bindings,+        --      see Note [lazyId magic], Note [Inlining in CorePrep]+        --      and Note [CorePrep inlines trivial CoreExpr not Id] (#12076)+        , cpe_mkIntegerId     :: Id+        , cpe_integerSDataCon :: Maybe DataCon+    }++lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id+lookupMkIntegerName dflags hsc_env+    = guardIntegerUse dflags $ liftM tyThingId $+      lookupGlobal hsc_env mkIntegerName++lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)+lookupIntegerSDataConName dflags hsc_env = case cIntegerLibraryType of+    IntegerGMP -> guardIntegerUse dflags $ liftM (Just . tyThingDataCon) $+                  lookupGlobal hsc_env integerSDataConName+    IntegerSimple -> return Nothing++-- | Helper for 'lookupMkIntegerName' and 'lookupIntegerSDataConName'+guardIntegerUse :: DynFlags -> IO a -> IO a+guardIntegerUse dflags act+  | thisPackage dflags == primUnitId+  = return $ panic "Can't use Integer in ghc-prim"+  | thisPackage dflags == integerUnitId+  = return $ panic "Can't use Integer in integer-*"+  | otherwise = act++mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv+mkInitialCorePrepEnv dflags hsc_env+    = do mkIntegerId <- lookupMkIntegerName dflags hsc_env+         integerSDataCon <- lookupIntegerSDataConName dflags hsc_env+         return $ CPE {+                      cpe_dynFlags = dflags,+                      cpe_env = emptyVarEnv,+                      cpe_mkIntegerId = mkIntegerId,+                      cpe_integerSDataCon = integerSDataCon+                  }++extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv+extendCorePrepEnv cpe id id'+    = cpe { cpe_env = extendVarEnv (cpe_env cpe) id (Var id') }++extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv+extendCorePrepEnvExpr cpe id expr+    = cpe { cpe_env = extendVarEnv (cpe_env cpe) id expr }++extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv+extendCorePrepEnvList cpe prs+    = cpe { cpe_env = extendVarEnvList (cpe_env cpe)+                        (map (\(id, id') -> (id, Var id')) prs) }++lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr+lookupCorePrepEnv cpe id+  = case lookupVarEnv (cpe_env cpe) id of+        Nothing  -> Var id+        Just exp -> exp++getMkIntegerId :: CorePrepEnv -> Id+getMkIntegerId = cpe_mkIntegerId++------------------------------------------------------------------------------+-- Cloning binders+-- ---------------------------------------------------------------------------++cpCloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])+cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs++cpCloneBndr  :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)+cpCloneBndr env bndr+  | isLocalId bndr, not (isCoVar bndr)+  = do bndr' <- setVarUnique bndr <$> getUniqueM++       -- We are going to OccAnal soon, so drop (now-useless) rules/unfoldings+       -- so that we can drop more stuff as dead code.+       -- See also Note [Dead code in CorePrep]+       let bndr'' = bndr' `setIdUnfolding` noUnfolding+                          `setIdSpecialisation` emptyRuleInfo+       return (extendCorePrepEnv env bndr bndr'', bndr'')++  | otherwise   -- Top level things, which we don't want+                -- to clone, have become GlobalIds by now+                -- And we don't clone tyvars, or coercion variables+  = return (env, bndr)+++------------------------------------------------------------------------------+-- Cloning ccall Ids; each must have a unique name,+-- to give the code generator a handle to hang it on+-- ---------------------------------------------------------------------------++fiddleCCall :: Id -> UniqSM Id+fiddleCCall id+  | isFCallId id = (id `setVarUnique`) <$> getUniqueM+  | otherwise    = return id++------------------------------------------------------------------------------+-- Generating new binders+-- ---------------------------------------------------------------------------++newVar :: Type -> UniqSM Id+newVar ty+ = seqType ty `seq` do+     uniq <- getUniqueM+     return (mkSysLocalOrCoVar (fsLit "sat") uniq ty)+++------------------------------------------------------------------------------+-- Floating ticks+-- ---------------------------------------------------------------------------+--+-- Note [Floating Ticks in CorePrep]+--+-- It might seem counter-intuitive to float ticks by default, given+-- that we don't actually want to move them if we can help it. On the+-- other hand, nothing gets very far in CorePrep anyway, and we want+-- to preserve the order of let bindings and tick annotations in+-- relation to each other. For example, if we just wrapped let floats+-- when they pass through ticks, we might end up performing the+-- following transformation:+--+--   src<...> let foo = bar in baz+--   ==>  let foo = src<...> bar in src<...> baz+--+-- Because the let-binding would float through the tick, and then+-- immediately materialize, achieving nothing but decreasing tick+-- accuracy. The only special case is the following scenario:+--+--   let foo = src<...> (let a = b in bar) in baz+--   ==>  let foo = src<...> bar; a = src<...> b in baz+--+-- Here we would not want the source tick to end up covering "baz" and+-- therefore refrain from pushing ticks outside. Instead, we copy them+-- into the floating binds (here "a") in cpePair. Note that where "b"+-- or "bar" are (value) lambdas we have to push the annotations+-- further inside in order to uphold our rules.+--+-- All of this is implemented below in @wrapTicks@.++-- | Like wrapFloats, but only wraps tick floats+wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr)+wrapTicks (Floats flag floats0) expr =+    (Floats flag (toOL $ reverse floats1), foldr mkTick expr (reverse ticks1))+  where (floats1, ticks1) = foldlOL go ([], []) $ floats0+        -- Deeply nested constructors will produce long lists of+        -- redundant source note floats here. We need to eliminate+        -- those early, as relying on mkTick to spot it after the fact+        -- can yield O(n^3) complexity [#11095]+        go (floats, ticks) (FloatTick t)+          = ASSERT(tickishPlace t == PlaceNonLam)+            (floats, if any (flip tickishContains t) ticks+                     then ticks else t:ticks)+        go (floats, ticks) f+          = (foldr wrap f (reverse ticks):floats, ticks)++        wrap t (FloatLet bind)    = FloatLet (wrapBind t bind)+        wrap t (FloatCase b r ok) = FloatCase b (mkTick t r) ok+        wrap _ other              = pprPanic "wrapTicks: unexpected float!"+                                             (ppr other)+        wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs)+        wrapBind t (Rec pairs)         = Rec (mapSnd (mkTick t) pairs)
+ coreSyn/CoreSeq.hs view
@@ -0,0 +1,111 @@+-- |+-- Various utilities for forcing Core structures+--+-- It can often be useful to force various parts of the AST. This module+-- provides a number of @seq@-like functions to accomplish this.++module CoreSeq (+        -- * Utilities for forcing Core structures+        seqExpr, seqExprs, seqUnfolding, seqRules,+        megaSeqIdInfo, seqRuleInfo, seqBinds,+    ) where++import CoreSyn+import IdInfo+import Demand( seqDemand, seqStrictSig )+import BasicTypes( seqOccInfo )+import VarSet( seqDVarSet )+import Var( varType, tyVarKind )+import Type( seqType, isTyVar )+import Coercion( seqCo )+import Id( Id, idInfo )++-- | Evaluate all the fields of the 'IdInfo' that are generally demanded by the+-- compiler+megaSeqIdInfo :: IdInfo -> ()+megaSeqIdInfo info+  = seqRuleInfo (ruleInfo info)                 `seq`++-- Omitting this improves runtimes a little, presumably because+-- some unfoldings are not calculated at all+--    seqUnfolding (unfoldingInfo info)         `seq`++    seqDemand (demandInfo info)                 `seq`+    seqStrictSig (strictnessInfo info)          `seq`+    seqCaf (cafInfo info)                       `seq`+    seqOneShot (oneShotInfo info)               `seq`+    seqOccInfo (occInfo info)++seqOneShot :: OneShotInfo -> ()+seqOneShot l = l `seq` ()++seqRuleInfo :: RuleInfo -> ()+seqRuleInfo (RuleInfo rules fvs) = seqRules rules `seq` seqDVarSet fvs++seqCaf :: CafInfo -> ()+seqCaf c = c `seq` ()++seqRules :: [CoreRule] -> ()+seqRules [] = ()+seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)+  = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules+seqRules (BuiltinRule {} : rules) = seqRules rules++seqExpr :: CoreExpr -> ()+seqExpr (Var v)         = v `seq` ()+seqExpr (Lit lit)       = lit `seq` ()+seqExpr (App f a)       = seqExpr f `seq` seqExpr a+seqExpr (Lam b e)       = seqBndr b `seq` seqExpr e+seqExpr (Let b e)       = seqBind b `seq` seqExpr e+seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as+seqExpr (Cast e co)     = seqExpr e `seq` seqCo co+seqExpr (Tick n e)      = seqTickish n `seq` seqExpr e+seqExpr (Type t)        = seqType t+seqExpr (Coercion co)   = seqCo co++seqExprs :: [CoreExpr] -> ()+seqExprs [] = ()+seqExprs (e:es) = seqExpr e `seq` seqExprs es++seqTickish :: Tickish Id -> ()+seqTickish ProfNote{ profNoteCC = cc } = cc `seq` ()+seqTickish HpcTick{} = ()+seqTickish Breakpoint{ breakpointFVs = ids } = seqBndrs ids+seqTickish SourceNote{} = ()++seqBndr :: CoreBndr -> ()+seqBndr b | isTyVar b = seqType (tyVarKind b)+          | otherwise = seqType (varType b)             `seq`+                        megaSeqIdInfo (idInfo b)++seqBndrs :: [CoreBndr] -> ()+seqBndrs [] = ()+seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs++seqBinds :: [Bind CoreBndr] -> ()+seqBinds bs = foldr (seq . seqBind) () bs++seqBind :: Bind CoreBndr -> ()+seqBind (NonRec b e) = seqBndr b `seq` seqExpr e+seqBind (Rec prs)    = seqPairs prs++seqPairs :: [(CoreBndr, CoreExpr)] -> ()+seqPairs [] = ()+seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs++seqAlts :: [CoreAlt] -> ()+seqAlts [] = ()+seqAlts ((c,bs,e):alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts++seqUnfolding :: Unfolding -> ()+seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top,+                uf_is_value = b1, uf_is_work_free = b2,+                uf_expandable = b3, uf_is_conlike = b4,+                uf_guidance = g})+  = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` b4 `seq` seqGuidance g++seqUnfolding _ = ()++seqGuidance :: UnfoldingGuidance -> ()+seqGuidance (UnfIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` ()+seqGuidance _                      = ()
+ coreSyn/CoreStats.hs view
@@ -0,0 +1,141 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-2015+-}++-- | Functions to computing the statistics reflective of the "size"+-- of a Core expression+module CoreStats (+        -- * Expression and bindings size+        coreBindsSize, exprSize,+        CoreStats(..), coreBindsStats, exprStats,+    ) where++import BasicTypes+import CoreSyn+import Outputable+import Coercion+import Var+import Type (Type, typeSize, seqType)+import Id (idType, isJoinId)+import CoreSeq (megaSeqIdInfo)++data CoreStats = CS { cs_tm :: Int    -- Terms+                    , cs_ty :: Int    -- Types+                    , cs_co :: Int    -- Coercions+                    , cs_vb :: Int    -- Local value bindings+                    , cs_jb :: Int }  -- Local join bindings+++instance Outputable CoreStats where+ ppr (CS { cs_tm = i1, cs_ty = i2, cs_co = i3, cs_vb = i4, cs_jb = i5 })+   = braces (sep [text "terms:"     <+> intWithCommas i1 <> comma,+                  text "types:"     <+> intWithCommas i2 <> comma,+                  text "coercions:" <+> intWithCommas i3 <> comma,+                  text "joins:"     <+> intWithCommas i5 <> char '/' <>+                                        intWithCommas (i4 + i5) ])++plusCS :: CoreStats -> CoreStats -> CoreStats+plusCS (CS { cs_tm = p1, cs_ty = q1, cs_co = r1, cs_vb = v1, cs_jb = j1 })+       (CS { cs_tm = p2, cs_ty = q2, cs_co = r2, cs_vb = v2, cs_jb = j2 })+  = CS { cs_tm = p1+p2, cs_ty = q1+q2, cs_co = r1+r2, cs_vb = v1+v2+       , cs_jb = j1+j2 }++zeroCS, oneTM :: CoreStats+zeroCS = CS { cs_tm = 0, cs_ty = 0, cs_co = 0, cs_vb = 0, cs_jb = 0 }+oneTM  = zeroCS { cs_tm = 1 }++sumCS :: (a -> CoreStats) -> [a] -> CoreStats+sumCS f = foldr (plusCS . f) zeroCS++coreBindsStats :: [CoreBind] -> CoreStats+coreBindsStats = sumCS (bindStats TopLevel)++bindStats :: TopLevelFlag -> CoreBind -> CoreStats+bindStats top_lvl (NonRec v r) = bindingStats top_lvl v r+bindStats top_lvl (Rec prs)    = sumCS (\(v,r) -> bindingStats top_lvl v r) prs++bindingStats :: TopLevelFlag -> Var -> CoreExpr -> CoreStats+bindingStats top_lvl v r = letBndrStats top_lvl v `plusCS` exprStats r++bndrStats :: Var -> CoreStats+bndrStats v = oneTM `plusCS` tyStats (varType v)++letBndrStats :: TopLevelFlag -> Var -> CoreStats+letBndrStats top_lvl v+  | isTyVar v || isTopLevel top_lvl = bndrStats v+  | isJoinId v = oneTM { cs_jb = 1 } `plusCS` ty_stats+  | otherwise  = oneTM { cs_vb = 1 } `plusCS` ty_stats+  where+    ty_stats = tyStats (varType v)++exprStats :: CoreExpr -> CoreStats+exprStats (Var {})        = oneTM+exprStats (Lit {})        = oneTM+exprStats (Type t)        = tyStats t+exprStats (Coercion c)    = coStats c+exprStats (App f a)       = exprStats f `plusCS` exprStats a+exprStats (Lam b e)       = bndrStats b `plusCS` exprStats e+exprStats (Let b e)       = bindStats NotTopLevel b `plusCS` exprStats e+exprStats (Case e b _ as) = exprStats e `plusCS` bndrStats b+                                        `plusCS` sumCS altStats as+exprStats (Cast e co)     = coStats co `plusCS` exprStats e+exprStats (Tick _ e)      = exprStats e++altStats :: CoreAlt -> CoreStats+altStats (_, bs, r) = altBndrStats bs `plusCS` exprStats r++altBndrStats :: [Var] -> CoreStats+-- Charge one for the alternative, not for each binder+altBndrStats vs = oneTM `plusCS` sumCS (tyStats . varType) vs++tyStats :: Type -> CoreStats+tyStats ty = zeroCS { cs_ty = typeSize ty }++coStats :: Coercion -> CoreStats+coStats co = zeroCS { cs_co = coercionSize co }++coreBindsSize :: [CoreBind] -> Int+-- We use coreBindStats for user printout+-- but this one is a quick and dirty basis for+-- the simplifier's tick limit+coreBindsSize bs = foldr ((+) . bindSize) 0 bs++exprSize :: CoreExpr -> Int+-- ^ A measure of the size of the expressions, strictly greater than 0+-- It also forces the expression pretty drastically as a side effect+-- Counts *leaves*, not internal nodes. Types and coercions are not counted.+exprSize (Var v)         = v `seq` 1+exprSize (Lit lit)       = lit `seq` 1+exprSize (App f a)       = exprSize f + exprSize a+exprSize (Lam b e)       = bndrSize b + exprSize e+exprSize (Let b e)       = bindSize b + exprSize e+exprSize (Case e b t as) = seqType t `seq`+                           exprSize e + bndrSize b + 1 + foldr ((+) . altSize) 0 as+exprSize (Cast e co)     = (seqCo co `seq` 1) + exprSize e+exprSize (Tick n e)      = tickSize n + exprSize e+exprSize (Type t)        = seqType t `seq` 1+exprSize (Coercion co)   = seqCo co `seq` 1++tickSize :: Tickish Id -> Int+tickSize (ProfNote cc _ _) = cc `seq` 1+tickSize _ = 1 -- the rest are strict++bndrSize :: Var -> Int+bndrSize b | isTyVar b = seqType (tyVarKind b) `seq` 1+           | otherwise = seqType (idType b)             `seq`+                         megaSeqIdInfo (idInfo b)       `seq`+                         1++bndrsSize :: [Var] -> Int+bndrsSize = sum . map bndrSize++bindSize :: CoreBind -> Int+bindSize (NonRec b e) = bndrSize b + exprSize e+bindSize (Rec prs)    = foldr ((+) . pairSize) 0 prs++pairSize :: (Var, CoreExpr) -> Int+pairSize (b,e) = bndrSize b + exprSize e++altSize :: CoreAlt -> Int+altSize (c,bs,e) = c `seq` bndrsSize bs + exprSize e
+ coreSyn/CoreSubst.hs view
@@ -0,0 +1,762 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Utility functions on @Core@ syntax+-}++{-# LANGUAGE CPP #-}+module CoreSubst (+        -- * Main data types+        Subst(..), -- Implementation exported for supercompiler's Renaming.hs only+        TvSubstEnv, IdSubstEnv, InScopeSet,++        -- ** Substituting into expressions and related types+        deShadowBinds, substSpec, substRulesForImportedIds,+        substTy, substCo, substExpr, substExprSC, substBind, substBindSC,+        substUnfolding, substUnfoldingSC,+        lookupIdSubst, lookupTCvSubst, substIdOcc,+        substTickish, substDVarSet, substIdInfo,++        -- ** Operations on substitutions+        emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst,+        extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList,+        extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv,+        addInScopeSet, extendInScope, extendInScopeList, extendInScopeIds,+        isInScope, setInScope, getTCvSubst, extendTvSubst, extendCvSubst,+        delBndr, delBndrs,++        -- ** Substituting and cloning binders+        substBndr, substBndrs, substRecBndrs, substTyVarBndr, substCoVarBndr,+        cloneBndr, cloneBndrs, cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs,++    ) where++#include "HsVersions.h"+++import CoreSyn+import CoreFVs+import CoreSeq+import CoreUtils+import qualified Type+import qualified Coercion++        -- We are defining local versions+import Type     hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList+                       , isInScope, substTyVarBndr, cloneTyVarBndr )+import Coercion hiding ( substCo, substCoVarBndr )++import PrelNames+import VarSet+import VarEnv+import Id+import Name     ( Name )+import Var+import IdInfo+import UniqSupply+import Maybes+import Util+import Outputable+import PprCore          ()              -- Instances+import Data.List++++{-+************************************************************************+*                                                                      *+\subsection{Substitutions}+*                                                                      *+************************************************************************+-}++-- | A substitution environment, containing 'Id', 'TyVar', and 'CoVar'+-- substitutions.+--+-- Some invariants apply to how you use the substitution:+--+-- 1. #in_scope_invariant# The in-scope set contains at least those 'Id's and 'TyVar's that will be in scope /after/+-- applying the substitution to a term. Precisely, the in-scope set must be a superset of the free vars of the+-- substitution range that might possibly clash with locally-bound variables in the thing being substituted in.+--+-- 2. #apply_once# You may apply the substitution only /once/+--+-- There are various ways of setting up the in-scope set such that the first of these invariants hold:+--+-- * Arrange that the in-scope set really is all the things in scope+--+-- * Arrange that it's the free vars of the range of the substitution+--+-- * Make it empty, if you know that all the free vars of the substitution are fresh, and hence can't possibly clash+data Subst+  = Subst InScopeSet  -- Variables in in scope (both Ids and TyVars) /after/+                      -- applying the substitution+          IdSubstEnv  -- Substitution from NcIds to CoreExprs+          TvSubstEnv  -- Substitution from TyVars to Types+          CvSubstEnv  -- Substitution from CoVars to Coercions++        -- INVARIANT 1: See #in_scope_invariant#+        -- This is what lets us deal with name capture properly+        -- It's a hard invariant to check...+        --+        -- INVARIANT 2: The substitution is apply-once; see Note [Apply once] with+        --              Types.TvSubstEnv+        --+        -- INVARIANT 3: See Note [Extending the Subst]++{-+Note [Extending the Subst]+~~~~~~~~~~~~~~~~~~~~~~~~~~+For a core Subst, which binds Ids as well, we make a different choice for Ids+than we do for TyVars.++For TyVars, see Note [Extending the TCvSubst] with Type.TvSubstEnv++For Ids, we have a different invariant+        The IdSubstEnv is extended *only* when the Unique on an Id changes+        Otherwise, we just extend the InScopeSet++In consequence:++* If all subst envs are empty, substExpr would be a+  no-op, so substExprSC ("short cut") does nothing.++  However, substExpr still goes ahead and substitutes.  Reason: we may+  want to replace existing Ids with new ones from the in-scope set, to+  avoid space leaks.++* In substIdBndr, we extend the IdSubstEnv only when the unique changes++* If the CvSubstEnv, TvSubstEnv and IdSubstEnv are all empty,+  substExpr does nothing (Note that the above rule for substIdBndr+  maintains this property.  If the incoming envts are both empty, then+  substituting the type and IdInfo can't change anything.)++* In lookupIdSubst, we *must* look up the Id in the in-scope set, because+  it may contain non-trivial changes.  Example:+        (/\a. \x:a. ...x...) Int+  We extend the TvSubstEnv with [a |-> Int]; but x's unique does not change+  so we only extend the in-scope set.  Then we must look up in the in-scope+  set when we find the occurrence of x.++* The requirement to look up the Id in the in-scope set means that we+  must NOT take no-op short cut when the IdSubst is empty.+  We must still look up every Id in the in-scope set.++* (However, we don't need to do so for expressions found in the IdSubst+  itself, whose range is assumed to be correct wrt the in-scope set.)++Why do we make a different choice for the IdSubstEnv than the+TvSubstEnv and CvSubstEnv?++* For Ids, we change the IdInfo all the time (e.g. deleting the+  unfolding), and adding it back later, so using the TyVar convention+  would entail extending the substitution almost all the time++* The simplifier wants to look up in the in-scope set anyway, in case it+  can see a better unfolding from an enclosing case expression++* For TyVars, only coercion variables can possibly change, and they are+  easy to spot+-}++-- | An environment for substituting for 'Id's+type IdSubstEnv = IdEnv CoreExpr   -- Domain is NcIds, i.e. not coercions++----------------------------+isEmptySubst :: Subst -> Bool+isEmptySubst (Subst _ id_env tv_env cv_env)+  = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env++emptySubst :: Subst+emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv emptyVarEnv++mkEmptySubst :: InScopeSet -> Subst+mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv++mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst+mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs++-- | Find the in-scope set: see "CoreSubst#in_scope_invariant"+substInScope :: Subst -> InScopeSet+substInScope (Subst in_scope _ _ _) = in_scope++-- | Remove all substitutions for 'Id's and 'Var's that might have been built up+-- while preserving the in-scope set+zapSubstEnv :: Subst -> Subst+zapSubstEnv (Subst in_scope _ _ _) = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv++-- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the in-scope set is+-- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this+extendIdSubst :: Subst -> Id -> CoreExpr -> Subst+-- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set+extendIdSubst (Subst in_scope ids tvs cvs) v r+  = ASSERT2( isNonCoVarId v, ppr v $$ ppr r )+    Subst in_scope (extendVarEnv ids v r) tvs cvs++-- | Adds multiple 'Id' substitutions to the 'Subst': see also 'extendIdSubst'+extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst+extendIdSubstList (Subst in_scope ids tvs cvs) prs+  = ASSERT( all (isNonCoVarId . fst) prs )+    Subst in_scope (extendVarEnvList ids prs) tvs cvs++-- | Add a substitution for a 'TyVar' to the 'Subst'+-- The 'TyVar' *must* be a real TyVar, and not a CoVar+-- You must ensure that the in-scope set is such that+-- the "CoreSubst#in_scope_invariant" is true after extending+-- the substitution like this.+extendTvSubst :: Subst -> TyVar -> Type -> Subst+extendTvSubst (Subst in_scope ids tvs cvs) tv ty+  = ASSERT( isTyVar tv )+    Subst in_scope ids (extendVarEnv tvs tv ty) cvs++-- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst'+extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst+extendTvSubstList subst vrs+  = foldl' extend subst vrs+  where+    extend subst (v, r) = extendTvSubst subst v r++-- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst': you must ensure that the in-scope set is+-- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this+extendCvSubst :: Subst -> CoVar -> Coercion -> Subst+extendCvSubst (Subst in_scope ids tvs cvs) v r+  = ASSERT( isCoVar v )+    Subst in_scope ids tvs (extendVarEnv cvs v r)++-- | Add a substitution appropriate to the thing being substituted+--   (whether an expression, type, or coercion). See also+--   'extendIdSubst', 'extendTvSubst', 'extendCvSubst'+extendSubst :: Subst -> Var -> CoreArg -> Subst+extendSubst subst var arg+  = case arg of+      Type ty     -> ASSERT( isTyVar var ) extendTvSubst subst var ty+      Coercion co -> ASSERT( isCoVar var ) extendCvSubst subst var co+      _           -> ASSERT( isId    var ) extendIdSubst subst var arg++extendSubstWithVar :: Subst -> Var -> Var -> Subst+extendSubstWithVar subst v1 v2+  | isTyVar v1 = ASSERT( isTyVar v2 ) extendTvSubst subst v1 (mkTyVarTy v2)+  | isCoVar v1 = ASSERT( isCoVar v2 ) extendCvSubst subst v1 (mkCoVarCo v2)+  | otherwise  = ASSERT( isId    v2 ) extendIdSubst subst v1 (Var v2)++-- | Add a substitution as appropriate to each of the terms being+--   substituted (whether expressions, types, or coercions). See also+--   'extendSubst'.+extendSubstList :: Subst -> [(Var,CoreArg)] -> Subst+extendSubstList subst []              = subst+extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var rhs) prs++-- | Find the substitution for an 'Id' in the 'Subst'+lookupIdSubst :: SDoc -> Subst -> Id -> CoreExpr+lookupIdSubst doc (Subst in_scope ids _ _) v+  | not (isLocalId v) = Var v+  | Just e  <- lookupVarEnv ids       v = e+  | Just v' <- lookupInScope in_scope v = Var v'+        -- Vital! See Note [Extending the Subst]+  | otherwise = WARN( True, text "CoreSubst.lookupIdSubst" <+> doc <+> ppr v+                            $$ ppr in_scope)+                Var v++-- | Find the substitution for a 'TyVar' in the 'Subst'+lookupTCvSubst :: Subst -> TyVar -> Type+lookupTCvSubst (Subst _ _ tvs cvs) v+  | isTyVar v+  = lookupVarEnv tvs v `orElse` Type.mkTyVarTy v+  | otherwise+  = mkCoercionTy $ lookupVarEnv cvs v `orElse` mkCoVarCo v++delBndr :: Subst -> Var -> Subst+delBndr (Subst in_scope ids tvs cvs) v+  | isCoVar v = Subst in_scope ids tvs (delVarEnv cvs v)+  | isTyVar v = Subst in_scope ids (delVarEnv tvs v) cvs+  | otherwise = Subst in_scope (delVarEnv ids v) tvs cvs++delBndrs :: Subst -> [Var] -> Subst+delBndrs (Subst in_scope ids tvs cvs) vs+  = Subst in_scope (delVarEnvList ids vs) (delVarEnvList tvs vs) (delVarEnvList cvs vs)+      -- Easiest thing is just delete all from all!++-- | Simultaneously substitute for a bunch of variables+--   No left-right shadowing+--   ie the substitution for   (\x \y. e) a1 a2+--      so neither x nor y scope over a1 a2+mkOpenSubst :: InScopeSet -> [(Var,CoreArg)] -> Subst+mkOpenSubst in_scope pairs = Subst in_scope+                                   (mkVarEnv [(id,e)  | (id, e) <- pairs, isId id])+                                   (mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs])+                                   (mkVarEnv [(v,co)  | (v, Coercion co) <- pairs])++------------------------------+isInScope :: Var -> Subst -> Bool+isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope++-- | Add the 'Var' to the in-scope set, but do not remove+-- any existing substitutions for it+addInScopeSet :: Subst -> VarSet -> Subst+addInScopeSet (Subst in_scope ids tvs cvs) vs+  = Subst (in_scope `extendInScopeSetSet` vs) ids tvs cvs++-- | Add the 'Var' to the in-scope set: as a side effect,+-- and remove any existing substitutions for it+extendInScope :: Subst -> Var -> Subst+extendInScope (Subst in_scope ids tvs cvs) v+  = Subst (in_scope `extendInScopeSet` v)+          (ids `delVarEnv` v) (tvs `delVarEnv` v) (cvs `delVarEnv` v)++-- | Add the 'Var's to the in-scope set: see also 'extendInScope'+extendInScopeList :: Subst -> [Var] -> Subst+extendInScopeList (Subst in_scope ids tvs cvs) vs+  = Subst (in_scope `extendInScopeSetList` vs)+          (ids `delVarEnvList` vs) (tvs `delVarEnvList` vs) (cvs `delVarEnvList` vs)++-- | Optimized version of 'extendInScopeList' that can be used if you are certain+-- all the things being added are 'Id's and hence none are 'TyVar's or 'CoVar's+extendInScopeIds :: Subst -> [Id] -> Subst+extendInScopeIds (Subst in_scope ids tvs cvs) vs+  = Subst (in_scope `extendInScopeSetList` vs)+          (ids `delVarEnvList` vs) tvs cvs++setInScope :: Subst -> InScopeSet -> Subst+setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs++-- Pretty printing, for debugging only++instance Outputable Subst where+  ppr (Subst in_scope ids tvs cvs)+        =  text "<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)++{-+************************************************************************+*                                                                      *+        Substituting expressions+*                                                                      *+************************************************************************+-}++-- | Apply a substitution to an entire 'CoreExpr'. Remember, you may only+-- apply the substitution /once/: see "CoreSubst#apply_once"+--+-- Do *not* attempt to short-cut in the case of an empty substitution!+-- See Note [Extending the Subst]+substExprSC :: SDoc -> Subst -> CoreExpr -> CoreExpr+substExprSC doc subst orig_expr+  | isEmptySubst subst = orig_expr+  | otherwise          = -- pprTrace "enter subst-expr" (doc $$ ppr orig_expr) $+                         subst_expr doc subst orig_expr++substExpr :: SDoc -> Subst -> CoreExpr -> CoreExpr+substExpr doc subst orig_expr = subst_expr doc subst orig_expr++subst_expr :: SDoc -> Subst -> CoreExpr -> CoreExpr+subst_expr doc subst expr+  = go expr+  where+    go (Var v)         = lookupIdSubst (doc $$ text "subst_expr") subst v+    go (Type ty)       = Type (substTy subst ty)+    go (Coercion co)   = Coercion (substCo subst co)+    go (Lit lit)       = Lit lit+    go (App fun arg)   = App (go fun) (go arg)+    go (Tick tickish e) = mkTick (substTickish subst tickish) (go e)+    go (Cast e co)     = Cast (go e) (substCo subst co)+       -- Do not optimise even identity coercions+       -- Reason: substitution applies to the LHS of RULES, and+       --         if you "optimise" an identity coercion, you may+       --         lose a binder. We optimise the LHS of rules at+       --         construction time++    go (Lam bndr body) = Lam bndr' (subst_expr doc subst' body)+                       where+                         (subst', bndr') = substBndr subst bndr++    go (Let bind body) = Let bind' (subst_expr doc subst' body)+                       where+                         (subst', bind') = substBind subst bind++    go (Case scrut bndr ty alts) = Case (go scrut) bndr' (substTy subst ty) (map (go_alt subst') alts)+                                 where+                                 (subst', bndr') = substBndr subst bndr++    go_alt subst (con, bndrs, rhs) = (con, bndrs', subst_expr doc subst' rhs)+                                 where+                                   (subst', bndrs') = substBndrs subst bndrs++-- | Apply a substitution to an entire 'CoreBind', additionally returning an updated 'Subst'+-- that should be used by subsequent substitutions.+substBind, substBindSC :: Subst -> CoreBind -> (Subst, CoreBind)++substBindSC subst bind    -- Short-cut if the substitution is empty+  | not (isEmptySubst subst)+  = substBind subst bind+  | otherwise+  = case bind of+       NonRec bndr rhs -> (subst', NonRec bndr' rhs)+          where+            (subst', bndr') = substBndr subst bndr+       Rec pairs -> (subst', Rec (bndrs' `zip` rhss'))+          where+            (bndrs, rhss)    = unzip pairs+            (subst', bndrs') = substRecBndrs subst bndrs+            rhss' | isEmptySubst subst'+                  = rhss+                  | otherwise+                  = map (subst_expr (text "substBindSC") subst') rhss++substBind subst (NonRec bndr rhs)+  = (subst', NonRec bndr' (subst_expr (text "substBind") subst rhs))+  where+    (subst', bndr') = substBndr subst bndr++substBind subst (Rec pairs)+   = (subst', Rec (bndrs' `zip` rhss'))+   where+       (bndrs, rhss)    = unzip pairs+       (subst', bndrs') = substRecBndrs subst bndrs+       rhss' = map (subst_expr (text "substBind") subst') rhss++-- | De-shadowing the program is sometimes a useful pre-pass. It can be done simply+-- by running over the bindings with an empty substitution, because substitution+-- returns a result that has no-shadowing guaranteed.+--+-- (Actually, within a single /type/ there might still be shadowing, because+-- 'substTy' is a no-op for the empty substitution, but that's probably OK.)+--+-- [Aug 09] This function is not used in GHC at the moment, but seems so+--          short and simple that I'm going to leave it here+deShadowBinds :: CoreProgram -> CoreProgram+deShadowBinds binds = snd (mapAccumL substBind emptySubst binds)++{-+************************************************************************+*                                                                      *+        Substituting binders+*                                                                      *+************************************************************************++Remember that substBndr and friends are used when doing expression+substitution only.  Their only business is substitution, so they+preserve all IdInfo (suitably substituted).  For example, we *want* to+preserve occ info in rules.+-}++-- | Substitutes a 'Var' for another one according to the 'Subst' given, returning+-- the result and an updated 'Subst' that should be used by subsequent substitutions.+-- 'IdInfo' is preserved by this process, although it is substituted into appropriately.+substBndr :: Subst -> Var -> (Subst, Var)+substBndr subst bndr+  | isTyVar bndr  = substTyVarBndr subst bndr+  | isCoVar bndr  = substCoVarBndr subst bndr+  | otherwise     = substIdBndr (text "var-bndr") subst subst bndr++-- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right+substBndrs :: Subst -> [Var] -> (Subst, [Var])+substBndrs subst bndrs = mapAccumL substBndr subst bndrs++-- | Substitute in a mutually recursive group of 'Id's+substRecBndrs :: Subst -> [Id] -> (Subst, [Id])+substRecBndrs subst bndrs+  = (new_subst, new_bndrs)+  where         -- Here's the reason we need to pass rec_subst to subst_id+    (new_subst, new_bndrs) = mapAccumL (substIdBndr (text "rec-bndr") new_subst) subst bndrs++substIdBndr :: SDoc+            -> Subst            -- ^ Substitution to use for the IdInfo+            -> Subst -> Id      -- ^ Substitution and Id to transform+            -> (Subst, Id)      -- ^ Transformed pair+                                -- NB: unfolding may be zapped++substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id+  = -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $+    (Subst (in_scope `extendInScopeSet` new_id) new_env tvs cvs, new_id)+  where+    id1 = uniqAway in_scope old_id      -- id1 is cloned if necessary+    id2 | no_type_change = id1+        | otherwise      = setIdType id1 (substTy subst old_ty)++    old_ty = idType old_id+    no_type_change = (isEmptyVarEnv tvs && isEmptyVarEnv cvs) ||+                     noFreeVarsOfType old_ty++        -- new_id has the right IdInfo+        -- The lazy-set is because we're in a loop here, with+        -- rec_subst, when dealing with a mutually-recursive group+    new_id = maybeModifyIdInfo mb_new_info id2+    mb_new_info = substIdInfo rec_subst id2 (idInfo id2)+        -- NB: unfolding info may be zapped++        -- Extend the substitution if the unique has changed+        -- See the notes with substTyVarBndr for the delVarEnv+    new_env | no_change = delVarEnv env old_id+            | otherwise = extendVarEnv env old_id (Var new_id)++    no_change = id1 == old_id+        -- See Note [Extending the Subst]+        -- it's /not/ necessary to check mb_new_info and no_type_change++{-+Now a variant that unconditionally allocates a new unique.+It also unconditionally zaps the OccInfo.+-}++-- | Very similar to 'substBndr', but it always allocates a new 'Unique' for+-- each variable in its output.  It substitutes the IdInfo though.+cloneIdBndr :: Subst -> UniqSupply -> Id -> (Subst, Id)+cloneIdBndr subst us old_id+  = clone_id subst subst (old_id, uniqFromSupply us)++-- | Applies 'cloneIdBndr' to a number of 'Id's, accumulating a final+-- substitution from left to right+cloneIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])+cloneIdBndrs subst us ids+  = mapAccumL (clone_id subst) subst (ids `zip` uniqsFromSupply us)++cloneBndrs :: Subst -> UniqSupply -> [Var] -> (Subst, [Var])+-- Works for all kinds of variables (typically case binders)+-- not just Ids+cloneBndrs subst us vs+  = mapAccumL (\subst (v, u) -> cloneBndr subst u v) subst (vs `zip` uniqsFromSupply us)++cloneBndr :: Subst -> Unique -> Var -> (Subst, Var)+cloneBndr subst uniq v+  | isTyVar v = cloneTyVarBndr subst v uniq+  | otherwise = clone_id subst subst (v,uniq)  -- Works for coercion variables too++-- | Clone a mutually recursive group of 'Id's+cloneRecIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])+cloneRecIdBndrs subst us ids+  = (subst', ids')+  where+    (subst', ids') = mapAccumL (clone_id subst') subst+                               (ids `zip` uniqsFromSupply us)++-- Just like substIdBndr, except that it always makes a new unique+-- It is given the unique to use+clone_id    :: Subst                    -- Substitution for the IdInfo+            -> Subst -> (Id, Unique)    -- Substitution and Id to transform+            -> (Subst, Id)              -- Transformed pair++clone_id rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq)+  = (Subst (in_scope `extendInScopeSet` new_id) new_idvs tvs new_cvs, new_id)+  where+    id1     = setVarUnique old_id uniq+    id2     = substIdType subst id1+    new_id  = maybeModifyIdInfo (substIdInfo rec_subst id2 (idInfo old_id)) id2+    (new_idvs, new_cvs) | isCoVar old_id = (idvs, extendVarEnv cvs old_id (mkCoVarCo new_id))+                        | otherwise      = (extendVarEnv idvs old_id (Var new_id), cvs)++{-+************************************************************************+*                                                                      *+                Types and Coercions+*                                                                      *+************************************************************************++For types and coercions we just call the corresponding functions in+Type and Coercion, but we have to repackage the substitution, from a+Subst to a TCvSubst.+-}++substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar)+substTyVarBndr (Subst in_scope id_env tv_env cv_env) tv+  = case Type.substTyVarBndr (TCvSubst in_scope tv_env cv_env) tv of+        (TCvSubst in_scope' tv_env' cv_env', tv')+           -> (Subst in_scope' id_env tv_env' cv_env', tv')++cloneTyVarBndr :: Subst -> TyVar -> Unique -> (Subst, TyVar)+cloneTyVarBndr (Subst in_scope id_env tv_env cv_env) tv uniq+  = case Type.cloneTyVarBndr (TCvSubst in_scope tv_env cv_env) tv uniq of+        (TCvSubst in_scope' tv_env' cv_env', tv')+           -> (Subst in_scope' id_env tv_env' cv_env', tv')++substCoVarBndr :: Subst -> TyVar -> (Subst, TyVar)+substCoVarBndr (Subst in_scope id_env tv_env cv_env) cv+  = case Coercion.substCoVarBndr (TCvSubst in_scope tv_env cv_env) cv of+        (TCvSubst in_scope' tv_env' cv_env', cv')+           -> (Subst in_scope' id_env tv_env' cv_env', cv')++-- | See 'Type.substTy'+substTy :: Subst -> Type -> Type+substTy subst ty = Type.substTyUnchecked (getTCvSubst subst) ty++getTCvSubst :: Subst -> TCvSubst+getTCvSubst (Subst in_scope _ tenv cenv) = TCvSubst in_scope tenv cenv++-- | See 'Coercion.substCo'+substCo :: Subst -> Coercion -> Coercion+substCo subst co = Coercion.substCo (getTCvSubst subst) co++{-+************************************************************************+*                                                                      *+\section{IdInfo substitution}+*                                                                      *+************************************************************************+-}++substIdType :: Subst -> Id -> Id+substIdType subst@(Subst _ _ tv_env cv_env) id+  | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || noFreeVarsOfType old_ty = id+  | otherwise   = setIdType id (substTy subst old_ty)+                -- The tyCoVarsOfType is cheaper than it looks+                -- because we cache the free tyvars of the type+                -- in a Note in the id's type itself+  where+    old_ty = idType id++------------------+-- | Substitute into some 'IdInfo' with regard to the supplied new 'Id'.+substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo+substIdInfo subst new_id info+  | nothing_to_do = Nothing+  | otherwise     = Just (info `setRuleInfo`      substSpec subst new_id old_rules+                               `setUnfoldingInfo` substUnfolding subst old_unf)+  where+    old_rules     = ruleInfo info+    old_unf       = unfoldingInfo info+    nothing_to_do = isEmptyRuleInfo old_rules && not (isFragileUnfolding old_unf)++------------------+-- | Substitutes for the 'Id's within an unfolding+substUnfolding, substUnfoldingSC :: Subst -> Unfolding -> Unfolding+        -- Seq'ing on the returned Unfolding is enough to cause+        -- all the substitutions to happen completely++substUnfoldingSC subst unf       -- Short-cut version+  | isEmptySubst subst = unf+  | otherwise          = substUnfolding subst unf++substUnfolding subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })+  = df { df_bndrs = bndrs', df_args = args' }+  where+    (subst',bndrs') = substBndrs subst bndrs+    args'           = map (substExpr (text "subst-unf:dfun") subst') args++substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })+        -- Retain an InlineRule!+  | not (isStableSource src)  -- Zap an unstable unfolding, to save substitution work+  = NoUnfolding+  | otherwise                 -- But keep a stable one!+  = seqExpr new_tmpl `seq`+    unf { uf_tmpl = new_tmpl }+  where+    new_tmpl = substExpr (text "subst-unf") subst tmpl++substUnfolding _ unf = unf      -- NoUnfolding, OtherCon++------------------+substIdOcc :: Subst -> Id -> Id+-- These Ids should not be substituted to non-Ids+substIdOcc subst v = case lookupIdSubst (text "substIdOcc") subst v of+                        Var v' -> v'+                        other  -> pprPanic "substIdOcc" (vcat [ppr v <+> ppr other, ppr subst])++------------------+-- | Substitutes for the 'Id's within the 'WorkerInfo' given the new function 'Id'+substSpec :: Subst -> Id -> RuleInfo -> RuleInfo+substSpec subst new_id (RuleInfo rules rhs_fvs)+  = seqRuleInfo new_spec `seq` new_spec+  where+    subst_ru_fn = const (idName new_id)+    new_spec = RuleInfo (map (substRule subst subst_ru_fn) rules)+                        (substDVarSet subst rhs_fvs)++------------------+substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule]+substRulesForImportedIds subst rules+  = map (substRule subst not_needed) rules+  where+    not_needed name = pprPanic "substRulesForImportedIds" (ppr name)++------------------+substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule++-- The subst_ru_fn argument is applied to substitute the ru_fn field+-- of the rule:+--    - Rules for *imported* Ids never change ru_fn+--    - Rules for *local* Ids are in the IdInfo for that Id,+--      and the ru_fn field is simply replaced by the new name+--      of the Id+substRule _ _ rule@(BuiltinRule {}) = rule+substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args+                                       , ru_fn = fn_name, ru_rhs = rhs+                                       , ru_local = is_local })+  = rule { ru_bndrs = bndrs'+         , ru_fn    = if is_local+                        then subst_ru_fn fn_name+                        else fn_name+         , ru_args  = map (substExpr doc subst') args+         , ru_rhs   = substExpr (text "foo") subst' rhs }+           -- Do NOT optimise the RHS (previously we did simplOptExpr here)+           -- See Note [Substitute lazily]+  where+    doc = text "subst-rule" <+> ppr fn_name+    (subst', bndrs') = substBndrs subst bndrs++------------------+substDVarSet :: Subst -> DVarSet -> DVarSet+substDVarSet subst fvs+  = mkDVarSet $ fst $ foldr (subst_fv subst) ([], emptyVarSet) $ dVarSetElems fvs+  where+  subst_fv subst fv acc+     | isId fv = expr_fvs (lookupIdSubst (text "substDVarSet") subst fv) isLocalVar emptyVarSet $! acc+     | otherwise = tyCoFVsOfType (lookupTCvSubst subst fv) (const True) emptyVarSet $! acc++------------------+substTickish :: Subst -> Tickish Id -> Tickish Id+substTickish subst (Breakpoint n ids)+   = Breakpoint n (map do_one ids)+ where+    do_one = getIdFromTrivialExpr . lookupIdSubst (text "subst_tickish") subst+substTickish _subst other = other++{- Note [Substitute lazily]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+The functions that substitute over IdInfo must be pretty lazy, because+they are knot-tied by substRecBndrs.++One case in point was Trac #10627 in which a rule for a function 'f'+referred to 'f' (at a differnet type) on the RHS.  But instead of just+substituting in the rhs of the rule, we were calling simpleOptExpr, which+looked at the idInfo for 'f'; result <<loop>>.++In any case we don't need to optimise the RHS of rules, or unfoldings,+because the simplifier will do that.+++Note [substTickish]+~~~~~~~~~~~~~~~~~~~~~~+A Breakpoint contains a list of Ids.  What happens if we ever want to+substitute an expression for one of these Ids?++First, we ensure that we only ever substitute trivial expressions for+these Ids, by marking them as NoOccInfo in the occurrence analyser.+Then, when substituting for the Id, we unwrap any type applications+and abstractions to get back to an Id, with getIdFromTrivialExpr.++Second, we have to ensure that we never try to substitute a literal+for an Id in a breakpoint.  We ensure this by never storing an Id with+an unlifted type in a Breakpoint - see Coverage.mkTickish.+Breakpoints can't handle free variables with unlifted types anyway.+-}++{-+Note [Worker inlining]+~~~~~~~~~~~~~~~~~~~~~~+A worker can get sustituted away entirely.+        - it might be trivial+        - it might simply be very small+We do not treat an InlWrapper as an 'occurrence' in the occurrence+analyser, so it's possible that the worker is not even in scope any more.++In all all these cases we simply drop the special case, returning to+InlVanilla.  The WARN is just so I can see if it happens a lot.+-}+
+ coreSyn/CoreSyn.hs view
@@ -0,0 +1,2161 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}++-- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection+module CoreSyn (+        -- * Main data types+        Expr(..), Alt, Bind(..), AltCon(..), Arg,+        Tickish(..), TickishScoping(..), TickishPlacement(..),+        CoreProgram, CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,+        TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..), deTagExpr,++        -- * In/Out type synonyms+        InId, InBind, InExpr, InAlt, InArg, InType, InKind,+               InBndr, InVar, InCoercion, InTyVar, InCoVar,+        OutId, OutBind, OutExpr, OutAlt, OutArg, OutType, OutKind,+               OutBndr, OutVar, OutCoercion, OutTyVar, OutCoVar,++        -- ** 'Expr' construction+        mkLet, mkLets, mkLams,+        mkApps, mkTyApps, mkCoApps, mkVarApps, mkTyArg,++        mkIntLit, mkIntLitInt,+        mkWordLit, mkWordLitWord,+        mkWord64LitWord64, mkInt64LitInt64,+        mkCharLit, mkStringLit,+        mkFloatLit, mkFloatLitFloat,+        mkDoubleLit, mkDoubleLitDouble,++        mkConApp, mkConApp2, mkTyBind, mkCoBind,+        varToCoreExpr, varsToCoreExprs,++        isId, cmpAltCon, cmpAlt, ltAlt,++        -- ** Simple 'Expr' access functions and predicates+        bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,+        collectBinders, collectTyBinders, collectTyAndValBinders,+        collectNBinders,+        collectArgs, collectArgsTicks, flattenBinds,++        exprToType, exprToCoercion_maybe,+        applyTypeToArg,++        isValArg, isTypeArg, isTyCoArg, valArgCount, valBndrCount,+        isRuntimeArg, isRuntimeVar,++        -- * Tick-related functions+        tickishCounts, tickishScoped, tickishScopesLike, tickishFloatable,+        tickishCanSplit, mkNoCount, mkNoScope,+        tickishIsCode, tickishPlace,+        tickishContains,++        -- * Unfolding data types+        Unfolding(..),  UnfoldingGuidance(..), UnfoldingSource(..),++        -- ** Constructing 'Unfolding's+        noUnfolding, bootUnfolding, evaldUnfolding, mkOtherCon,+        unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk,++        -- ** Predicates and deconstruction on 'Unfolding'+        unfoldingTemplate, expandUnfolding_maybe,+        maybeUnfoldingTemplate, otherCons,+        isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,+        isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,+        isStableUnfolding, isFragileUnfolding, hasSomeUnfolding,+        isBootUnfolding,+        canUnfold, neverUnfoldGuidance, isStableSource,++        -- * Annotated expression data types+        AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt,++        -- ** Operations on annotated expressions+        collectAnnArgs, collectAnnArgsTicks,++        -- ** Operations on annotations+        deAnnotate, deAnnotate', deAnnAlt,+        collectAnnBndrs, collectNAnnBndrs,++        -- * Orphanhood+        IsOrphan(..), isOrphan, notOrphan, chooseOrphanAnchor,++        -- * Core rule data types+        CoreRule(..), RuleBase,+        RuleName, RuleFun, IdUnfoldingFun, InScopeEnv,+        RuleEnv(..), mkRuleEnv, emptyRuleEnv,++        -- ** Operations on 'CoreRule's+        ruleArity, ruleName, ruleIdName, ruleActivation,+        setRuleIdName, ruleModule,+        isBuiltinRule, isLocalRule, isAutoRule,++        -- * Core vectorisation declarations data type+        CoreVect(..)+    ) where++#include "HsVersions.h"++import CostCentre+import VarEnv( InScopeSet )+import Var+import Type+import Coercion+import Name+import NameSet+import NameEnv( NameEnv, emptyNameEnv )+import Literal+import DataCon+import Module+import TyCon+import BasicTypes+import DynFlags+import Outputable+import Util+import UniqSet+import SrcLoc     ( RealSrcSpan, containsSpan )+import Binary++import Data.Data hiding (TyCon)+import Data.Int+import Data.Word++infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps`+-- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)++{-+************************************************************************+*                                                                      *+\subsection{The main data types}+*                                                                      *+************************************************************************++These data types are the heart of the compiler+-}++-- | This is the data type that represents GHCs core intermediate language. Currently+-- GHC uses System FC <http://research.microsoft.com/~simonpj/papers/ext-f/> for this purpose,+-- which is closely related to the simpler and better known System F <http://en.wikipedia.org/wiki/System_F>.+--+-- We get from Haskell source to this Core language in a number of stages:+--+-- 1. The source code is parsed into an abstract syntax tree, which is represented+--    by the data type 'HsExpr.HsExpr' with the names being 'RdrName.RdrNames'+--+-- 2. This syntax tree is /renamed/, which attaches a 'Unique.Unique' to every 'RdrName.RdrName'+--    (yielding a 'Name.Name') to disambiguate identifiers which are lexically identical.+--    For example, this program:+--+-- @+--      f x = let f x = x + 1+--            in f (x - 2)+-- @+--+--    Would be renamed by having 'Unique's attached so it looked something like this:+--+-- @+--      f_1 x_2 = let f_3 x_4 = x_4 + 1+--                in f_3 (x_2 - 2)+-- @+--    But see Note [Shadowing] below.+--+-- 3. The resulting syntax tree undergoes type checking (which also deals with instantiating+--    type class arguments) to yield a 'HsExpr.HsExpr' type that has 'Id.Id' as it's names.+--+-- 4. Finally the syntax tree is /desugared/ from the expressive 'HsExpr.HsExpr' type into+--    this 'Expr' type, which has far fewer constructors and hence is easier to perform+--    optimization, analysis and code generation on.+--+-- The type parameter @b@ is for the type of binders in the expression tree.+--+-- The language consists of the following elements:+--+-- *  Variables+--+-- *  Primitive literals+--+-- *  Applications: note that the argument may be a 'Type'.+--    See Note [CoreSyn let/app invariant]+--    See Note [Levity polymorphism invariants]+--+-- *  Lambda abstraction+--    See Note [Levity polymorphism invariants]+--+-- *  Recursive and non recursive @let@s. Operationally+--    this corresponds to allocating a thunk for the things+--    bound and then executing the sub-expression.+--+--    #top_level_invariant#+--    #letrec_invariant#+--+--    The right hand sides of all top-level and recursive @let@s+--    /must/ be of lifted type (see "Type#type_classification" for+--    the meaning of /lifted/ vs. /unlifted/). There is one exception+--    to this rule, top-level @let@s are allowed to bind primitive+--    string literals, see Note [CoreSyn top-level string literals].+--+--    See Note [CoreSyn let/app invariant]+--    See Note [Levity polymorphism invariants]+--+--    #type_let#+--    We allow a /non-recursive/ let to bind a type variable, thus:+--+--    > Let (NonRec tv (Type ty)) body+--+--    This can be very convenient for postponing type substitutions until+--    the next run of the simplifier.+--+--    At the moment, the rest of the compiler only deals with type-let+--    in a Let expression, rather than at top level.  We may want to revist+--    this choice.+--+-- *  Case expression. Operationally this corresponds to evaluating+--    the scrutinee (expression examined) to weak head normal form+--    and then examining at most one level of resulting constructor (i.e. you+--    cannot do nested pattern matching directly with this).+--+--    The binder gets bound to the value of the scrutinee,+--    and the 'Type' must be that of all the case alternatives+--+--    #case_invariants#+--    This is one of the more complicated elements of the Core language,+--    and comes with a number of restrictions:+--+--    1. The list of alternatives may be empty;+--       See Note [Empty case alternatives]+--+--    2. The 'DEFAULT' case alternative must be first in the list,+--       if it occurs at all.+--+--    3. The remaining cases are in order of increasing+--         tag  (for 'DataAlts') or+--         lit  (for 'LitAlts').+--       This makes finding the relevant constructor easy,+--       and makes comparison easier too.+--+--    4. The list of alternatives must be exhaustive. An /exhaustive/ case+--       does not necessarily mention all constructors:+--+--       @+--            data Foo = Red | Green | Blue+--       ... case x of+--            Red   -> True+--            other -> f (case x of+--                            Green -> ...+--                            Blue  -> ... ) ...+--       @+--+--       The inner case does not need a @Red@ alternative, because @x@+--       can't be @Red@ at that program point.+--+--    5. Floating-point values must not be scrutinised against literals.+--       See Trac #9238 and Note [Rules for floating-point comparisons]+--       in PrelRules for rationale.+--+-- *  Cast an expression to a particular type.+--    This is used to implement @newtype@s (a @newtype@ constructor or+--    destructor just becomes a 'Cast' in Core) and GADTs.+--+-- *  Notes. These allow general information to be added to expressions+--    in the syntax tree+--+-- *  A type: this should only show up at the top level of an Arg+--+-- *  A coercion++-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism] in coreSyn/CoreLint.hs+data Expr b+  = Var   Id+  | Lit   Literal+  | App   (Expr b) (Arg b)+  | Lam   b (Expr b)+  | Let   (Bind b) (Expr b)+  | Case  (Expr b) b Type [Alt b]       -- See #case_invariants#+  | Cast  (Expr b) Coercion+  | Tick  (Tickish Id) (Expr b)+  | Type  Type+  | Coercion Coercion+  deriving Data++-- | Type synonym for expressions that occur in function argument positions.+-- Only 'Arg' should contain a 'Type' at top level, general 'Expr' should not+type Arg b = Expr b++-- | A case split alternative. Consists of the constructor leading to the alternative,+-- the variables bound from the constructor, and the expression to be executed given that binding.+-- The default alternative is @(DEFAULT, [], rhs)@++-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism] in coreSyn/CoreLint.hs+type Alt b = (AltCon, [b], Expr b)++-- | A case alternative constructor (i.e. pattern match)++-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism] in coreSyn/CoreLint.hs+data AltCon+  = DataAlt DataCon   --  ^ A plain data constructor: @case e of { Foo x -> ... }@.+                      -- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@++  | LitAlt  Literal   -- ^ A literal: @case e of { 1 -> ... }@+                      -- Invariant: always an *unlifted* literal+                      -- See Note [Literal alternatives]++  | DEFAULT           -- ^ Trivial alternative: @case e of { _ -> ... }@+   deriving (Eq, Data)++-- | Binding, used for top level bindings in a module and local bindings in a @let@.++-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism] in coreSyn/CoreLint.hs+data Bind b = NonRec b (Expr b)+            | Rec [(b, (Expr b))]+  deriving Data++{-+Note [Shadowing]+~~~~~~~~~~~~~~~~+While various passes attempt to rename on-the-fly in a manner that+avoids "shadowing" (thereby simplifying downstream optimizations),+neither the simplifier nor any other pass GUARANTEES that shadowing is+avoided. Thus, all passes SHOULD work fine even in the presence of+arbitrary shadowing in their inputs.++In particular, scrutinee variables `x` in expressions of the form+`Case e x t` are often renamed to variables with a prefix+"wild_". These "wild" variables may appear in the body of the+case-expression, and further, may be shadowed within the body.++So the Unique in an Var is not really unique at all.  Still, it's very+useful to give a constant-time equality/ordering for Vars, and to give+a key that can be used to make sets of Vars (VarSet), or mappings from+Vars to other things (VarEnv).   Moreover, if you do want to eliminate+shadowing, you can give a new Unique to an Id without changing its+printable name, which makes debugging easier.++Note [Literal alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Literal alternatives (LitAlt lit) are always for *un-lifted* literals.+We have one literal, a literal Integer, that is lifted, and we don't+allow in a LitAlt, because LitAlt cases don't do any evaluation. Also+(see Trac #5603) if you say+    case 3 of+      S# x -> ...+      J# _ _ -> ...+(where S#, J# are the constructors for Integer) we don't want the+simplifier calling findAlt with argument (LitAlt 3).  No no.  Integer+literals are an opaque encoding of an algebraic data type, not of+an unlifted literal, like all the others.++Also, we do not permit case analysis with literal patterns on floating-point+types. See Trac #9238 and Note [Rules for floating-point comparisons] in+PrelRules for the rationale for this restriction.++-------------------------- CoreSyn INVARIANTS ---------------------------++Note [CoreSyn top-level invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See #toplevel_invariant#++Note [CoreSyn letrec invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See #letrec_invariant#++Note [CoreSyn top-level string literals]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As an exception to the usual rule that top-level binders must be lifted,+we allow binding primitive string literals (of type Addr#) of type Addr# at the+top level. This allows us to share string literals earlier in the pipeline and+crucially allows other optimizations in the Core2Core pipeline to fire.+Consider,++  f n = let a::Addr# = "foo"#+        in \x -> blah++In order to be able to inline `f`, we would like to float `a` to the top.+Another option would be to inline `a`, but that would lead to duplicating string+literals, which we want to avoid. See Trac #8472.++The solution is simply to allow top-level unlifted binders. We can't allow+arbitrary unlifted expression at the top-level though, unlifted binders cannot+be thunks, so we just allow string literals.++It is important to note that top-level primitive string literals cannot be+wrapped in Ticks, as is otherwise done with lifted bindings. CoreToStg expects+to see just a plain (Lit (MachStr ...)) expression on the RHS of primitive+string bindings; anything else and things break. CoreLint checks this invariant.+To ensure that ticks don't sneak in CoreUtils.mkTick refuses to wrap any+primitve string expression with a tick.++Also see Note [Compilation plan for top-level string literals].++Note [Compilation plan for top-level string literals]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is a summary on how top-level string literals are handled by various+parts of the compilation pipeline.++* In the source language, there is no way to bind a primitive string literal+  at the top leve.++* In Core, we have a special rule that permits top-level Addr# bindings. See+  Note [CoreSyn top-level string literals]. Core-to-core passes may introduce+  new top-level string literals.++* In STG, top-level string literals are explicitly represented in the syntax+  tree.++* A top-level string literal may end up exported from a module. In this case,+  in the object file, the content of the exported literal is given a label with+  the _bytes suffix.++Note [CoreSyn let/app invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The let/app invariant+     the right hand side of a non-recursive 'Let', and+     the argument of an 'App',+    /may/ be of unlifted type, but only if+    the expression is ok-for-speculation+    or the 'Let' is for a join point.++This means that the let can be floated around+without difficulty. For example, this is OK:++   y::Int# = x +# 1#++But this is not, as it may affect termination if the+expression is floated out:++   y::Int# = fac 4#++In this situation you should use @case@ rather than a @let@. The function+'CoreUtils.needsCaseBinding' can help you determine which to generate, or+alternatively use 'MkCore.mkCoreLet' rather than this constructor directly,+which will generate a @case@ if necessary++The let/app invariant is initially enforced by mkCoreLet and mkCoreApp in+coreSyn/MkCore.++Note [CoreSyn case invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See #case_invariants#++Note [Levity polymorphism invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The levity-polymorphism invariants are these:++* The type of a term-binder must not be levity-polymorphic,+  unless it is a let(rec)-bound join point+     (see Note [Invariants on join points])++* The type of the argument of an App must not be levity-polymorphic.++A type (t::TYPE r) is "levity polymorphic" if 'r' has any free variables.++For example+  \(r::RuntimeRep). \(a::TYPE r). \(x::a). e+is illegal because x's type has kind (TYPE r), which has 'r' free.++See Note [Levity polymorphism checking] in DsMonad to see where these+invariants are established for user-written code.++Note [CoreSyn let goal]+~~~~~~~~~~~~~~~~~~~~~~~+* The simplifier tries to ensure that if the RHS of a let is a constructor+  application, its arguments are trivial, so that the constructor can be+  inlined vigorously.++Note [Type let]+~~~~~~~~~~~~~~~+See #type_let#++Note [Empty case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The alternatives of a case expression should be exhaustive.  But+this exhaustive list can be empty!++* A case expression can have empty alternatives if (and only if) the+  scrutinee is bound to raise an exception or diverge. When do we know+  this?  See Note [Bottoming expressions] in CoreUtils.++* The possiblity of empty alternatives is one reason we need a type on+  the case expression: if the alternatives are empty we can't get the+  type from the alternatives!++* In the case of empty types (see Note [Bottoming expressions]), say+    data T+  we do NOT want to replace+    case (x::T) of Bool {}   -->   error Bool "Inaccessible case"+  because x might raise an exception, and *that*'s what we want to see!+  (Trac #6067 is an example.) To preserve semantics we'd have to say+     x `seq` error Bool "Inaccessible case"+  but the 'seq' is just a case, so we are back to square 1.  Or I suppose+  we could say+     x |> UnsafeCoerce T Bool+  but that loses all trace of the fact that this originated with an empty+  set of alternatives.++* We can use the empty-alternative construct to coerce error values from+  one type to another.  For example++    f :: Int -> Int+    f n = error "urk"++    g :: Int -> (# Char, Bool #)+    g x = case f x of { 0 -> ..., n -> ... }++  Then if we inline f in g's RHS we get+    case (error Int "urk") of (# Char, Bool #) { ... }+  and we can discard the alternatives since the scrutinee is bottom to give+    case (error Int "urk") of (# Char, Bool #) {}++  This is nicer than using an unsafe coerce between Int ~ (# Char,Bool #),+  if for no other reason that we don't need to instantiate the (~) at an+  unboxed type.++* We treat a case expression with empty alternatives as trivial iff+  its scrutinee is (see CoreUtils.exprIsTrivial).  This is actually+  important; see Note [Empty case is trivial] in CoreUtils++* An empty case is replaced by its scrutinee during the CoreToStg+  conversion; remember STG is un-typed, so there is no need for+  the empty case to do the type conversion.++Note [Join points]+~~~~~~~~~~~~~~~~~~+In Core, a *join point* is a specially tagged function whose only occurrences+are saturated tail calls. A tail call can appear in these places:++  1. In the branches (not the scrutinee) of a case+  2. Underneath a let (value or join point)+  3. Inside another join point++We write a join-point declaration as+  join j @a @b x y = e1 in e2,+like a let binding but with "join" instead (or "join rec" for "let rec"). Note+that we put the parameters before the = rather than using lambdas; this is+because it's relevant how many parameters the join point takes *as a join+point.* This number is called the *join arity,* distinct from arity because it+counts types as well as values. Note that a join point may return a lambda! So+  join j x = x + 1+is different from+  join j = \x -> x + 1+The former has join arity 1, while the latter has join arity 0.++The identifier for a join point is called a join id or a *label.* An invocation+is called a *jump.* We write a jump using the jump keyword:++  jump j 3++The words *label* and *jump* are evocative of assembly code (or Cmm) for a+reason: join points are indeed compiled as labeled blocks, and jumps become+actual jumps (plus argument passing and stack adjustment). There is no closure+allocated and only a fraction of the function-call overhead. Hence we would+like as many functions as possible to become join points (see OccurAnal) and+the type rules for join points ensure we preserve the properties that make them+efficient.++In the actual AST, a join point is indicated by the IdDetails of the binder: a+local value binding gets 'VanillaId' but a join point gets a 'JoinId' with its+join arity.++For more details, see the paper:++  Luke Maurer, Paul Downen, Zena Ariola, and Simon Peyton Jones. "Compiling+  without continuations." Submitted to PLDI'17.++  https://www.microsoft.com/en-us/research/publication/compiling-without-continuations/++Note [Invariants on join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Join points must follow these invariants:++  1. All occurrences must be tail calls. Each of these tail calls must pass the+     same number of arguments, counting both types and values; we call this the+     "join arity" (to distinguish from regular arity, which only counts values).++  2. For join arity n, the right-hand side must begin with at least n lambdas.+     No ticks, no casts, just lambdas!  C.f. CoreUtils.joinRhsArity.++  2a. Moreover, this same constraint applies to any unfolding of the binder.+     Reason: if we want to push a continuation into the RHS we must push it+     into the unfolding as well.++  3. If the binding is recursive, then all other bindings in the recursive group+     must also be join points.++  4. The binding's type must not be polymorphic in its return type (as defined+     in Note [The polymorphism rule of join points]).++However, join points have simpler invariants in other ways++  5. A join point can have an unboxed type without the RHS being+     ok-for-speculation (i.e. drop the let/app invariant)+     e.g.  let j :: Int# = factorial x in ...++  6. A join point can have a levity-polymorphic RHS+     e.g.  let j :: r :: TYPE l = fail void# in ...+     This happened in an intermediate program Trac #13394++Examples:++  join j1  x = 1 + x in jump j (jump j x)  -- Fails 1: non-tail call+  join j1' x = 1 + x in if even a+                          then jump j1 a+                          else jump j1 a b -- Fails 1: inconsistent calls+  join j2  x = flip (+) x in j2 1 2        -- Fails 2: not enough lambdas+  join j2' x = \y -> x + y in j3 1         -- Passes: extra lams ok+  join j @a (x :: a) = x                   -- Fails 4: polymorphic in ret type++Invariant 1 applies to left-hand sides of rewrite rules, so a rule for a join+point must have an exact call as its LHS.++Strictly speaking, invariant 3 is redundant, since a call from inside a lazy+binding isn't a tail call. Since a let-bound value can't invoke a free join+point, then, they can't be mutually recursive. (A Core binding group *can*+include spurious extra bindings if the occurrence analyser hasn't run, so+invariant 3 does still need to be checked.) For the rigorous definition of+"tail call", see Section 3 of the paper (Note [Join points]).++Invariant 4 is subtle; see Note [The polymorphism rule of join points].++Core Lint will check these invariants, anticipating that any binder whose+OccInfo is marked AlwaysTailCalled will become a join point as soon as the+simplifier (or simpleOptPgm) runs.++Note [The type of a join point]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A join point has the same type it would have as a function. That is, if it takes+an Int and a Bool and its body produces a String, its type is `Int -> Bool ->+String`. Natural as this may seem, it can be awkward. A join point shouldn't be+thought to "return" in the same sense a function does---a jump is one-way. This+is crucial for understanding how case-of-case interacts with join points:++  case (join+          j :: Int -> Bool -> String+          j x y = ...+        in+          jump j z w) of+    "" -> True+    _  -> False++The simplifier will pull the case into the join point (see Note [Case-of-case+and join points] in Simplify):++  join+    j :: Int -> Bool -> Bool -- changed!+    j x y = case ... of "" -> True+                        _  -> False+  in+    jump j z w++The body of the join point now returns a Bool, so the label `j` has to have its+type updated accordingly. Inconvenient though this may be, it has the advantage+that 'CoreUtils.exprType' can still return a type for any expression, including+a jump.++This differs from the paper (see Note [Invariants on join points]). In the+paper, we instead give j the type `Int -> Bool -> forall a. a`. Then each jump+carries the "return type" as a parameter, exactly the way other non-returning+functions like `error` work:++  case (join+          j :: Int -> Bool -> forall a. a+          j x y = ...+        in+          jump j z w @String) of+    "" -> True+    _  -> False++Now we can move the case inward and we only have to change the jump:++  join+    j :: Int -> Bool -> forall a. a+    j x y = case ... of "" -> True+                        _  -> False+  in+    jump j z w @Bool++(Core Lint would still check that the body of the join point has the right type;+that type would simply not be reflected in the join id.)++Note [The polymorphism rule of join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Invariant 4 of Note [Invariants on join points] forbids a join point to be+polymorphic in its return type. That is, if its type is++  forall a1 ... ak. t1 -> ... -> tn -> r++where its join arity is k+n, none of the type parameters ai may occur free in r.+The most direct explanation is that given++  join j @a1 ... @ak x1 ... xn = e1 in e2++our typing rules require `e1` and `e2` to have the same type. Therefore the type+of `e1`---the return type of the join point---must be the same as the type of+e2. Since the type variables aren't bound in `e2`, its type can't include them,+and thus neither can the type of `e1`.++There's a deeper explanation in terms of the sequent calculus in Section 5.3 of+a previous paper:++  Paul Downen, Luke Maurer, Zena Ariola, and Simon Peyton Jones. "Sequent+  calculus as a compiler intermediate language." ICFP'16.++  https://www.microsoft.com/en-us/research/wp-content/uploads/2016/04/sequent-calculus-icfp16.pdf++The quick version: Consider the CPS term (the paper uses the sequent calculus,+but we can translate readily):++  \k -> join j @a1 ... @ak x1 ... xn = e1 k in e2 k++Since `j` is a join point, it doesn't bind a continuation variable but reuses+the variable `k` from the context. But the parameters `ai` are not in `k`'s+scope, and `k`'s type determines the return type of `j`; thus the `ai`s don't+appear in the return type of `j`. (Also, since `e1` and `e2` are passed the same+continuation, they must have the same type; hence the direct explanation above.)++************************************************************************+*                                                                      *+            In/Out type synonyms+*                                                                      *+********************************************************************* -}++{- Many passes apply a substitution, and it's very handy to have type+   synonyms to remind us whether or not the substitution has been applied -}++-- Pre-cloning or substitution+type InBndr     = CoreBndr+type InType     = Type+type InKind     = Kind+type InBind     = CoreBind+type InExpr     = CoreExpr+type InAlt      = CoreAlt+type InArg      = CoreArg+type InCoercion = Coercion++-- Post-cloning or substitution+type OutBndr     = CoreBndr+type OutType     = Type+type OutKind     = Kind+type OutCoercion = Coercion+type OutBind     = CoreBind+type OutExpr     = CoreExpr+type OutAlt      = CoreAlt+type OutArg      = CoreArg+++{- *********************************************************************+*                                                                      *+              Ticks+*                                                                      *+************************************************************************+-}++-- | Allows attaching extra information to points in expressions++-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism] in coreSyn/CoreLint.hs+data Tickish id =+    -- | An @{-# SCC #-}@ profiling annotation, either automatically+    -- added by the desugarer as a result of -auto-all, or added by+    -- the user.+    ProfNote {+      profNoteCC    :: CostCentre, -- ^ the cost centre+      profNoteCount :: !Bool,      -- ^ bump the entry count?+      profNoteScope :: !Bool       -- ^ scopes over the enclosed expression+                                   -- (i.e. not just a tick)+    }++  -- | A "tick" used by HPC to track the execution of each+  -- subexpression in the original source code.+  | HpcTick {+      tickModule :: Module,+      tickId     :: !Int+    }++  -- | A breakpoint for the GHCi debugger.  This behaves like an HPC+  -- tick, but has a list of free variables which will be available+  -- for inspection in GHCi when the program stops at the breakpoint.+  --+  -- NB. we must take account of these Ids when (a) counting free variables,+  -- and (b) substituting (don't substitute for them)+  | Breakpoint+    { breakpointId     :: !Int+    , breakpointFVs    :: [id]  -- ^ the order of this list is important:+                                -- it matches the order of the lists in the+                                -- appropriate entry in HscTypes.ModBreaks.+                                --+                                -- Careful about substitution!  See+                                -- Note [substTickish] in CoreSubst.+    }++  -- | A source note.+  --+  -- Source notes are pure annotations: Their presence should neither+  -- influence compilation nor execution. The semantics are given by+  -- causality: The presence of a source note means that a local+  -- change in the referenced source code span will possibly provoke+  -- the generated code to change. On the flip-side, the functionality+  -- of annotated code *must* be invariant against changes to all+  -- source code *except* the spans referenced in the source notes+  -- (see "Causality of optimized Haskell" paper for details).+  --+  -- Therefore extending the scope of any given source note is always+  -- valid. Note that it is still undesirable though, as this reduces+  -- their usefulness for debugging and profiling. Therefore we will+  -- generally try only to make use of this property where it is+  -- necessary to enable optimizations.+  | SourceNote+    { sourceSpan :: RealSrcSpan -- ^ Source covered+    , sourceName :: String      -- ^ Name for source location+                                --   (uses same names as CCs)+    }++  deriving (Eq, Ord, Data)++-- | A "counting tick" (where tickishCounts is True) is one that+-- counts evaluations in some way.  We cannot discard a counting tick,+-- and the compiler should preserve the number of counting ticks as+-- far as possible.+--+-- However, we still allow the simplifier to increase or decrease+-- sharing, so in practice the actual number of ticks may vary, except+-- that we never change the value from zero to non-zero or vice versa.+tickishCounts :: Tickish id -> Bool+tickishCounts n@ProfNote{} = profNoteCount n+tickishCounts HpcTick{}    = True+tickishCounts Breakpoint{} = True+tickishCounts _            = False+++-- | Specifies the scoping behaviour of ticks. This governs the+-- behaviour of ticks that care about the covered code and the cost+-- associated with it. Important for ticks relating to profiling.+data TickishScoping =+    -- | No scoping: The tick does not care about what code it+    -- covers. Transformations can freely move code inside as well as+    -- outside without any additional annotation obligations+    NoScope++    -- | Soft scoping: We want all code that is covered to stay+    -- covered.  Note that this scope type does not forbid+    -- transformations from happening, as as long as all results of+    -- the transformations are still covered by this tick or a copy of+    -- it. For example+    --+    --   let x = tick<...> (let y = foo in bar) in baz+    --     ===>+    --   let x = tick<...> bar; y = tick<...> foo in baz+    --+    -- Is a valid transformation as far as "bar" and "foo" is+    -- concerned, because both still are scoped over by the tick.+    --+    -- Note though that one might object to the "let" not being+    -- covered by the tick any more. However, we are generally lax+    -- with this - constant costs don't matter too much, and given+    -- that the "let" was effectively merged we can view it as having+    -- lost its identity anyway.+    --+    -- Also note that this scoping behaviour allows floating a tick+    -- "upwards" in pretty much any situation. For example:+    --+    --   case foo of x -> tick<...> bar+    --     ==>+    --   tick<...> case foo of x -> bar+    --+    -- While this is always leagl, we want to make a best effort to+    -- only make us of this where it exposes transformation+    -- opportunities.+  | SoftScope++    -- | Cost centre scoping: We don't want any costs to move to other+    -- cost-centre stacks. This means we not only want no code or cost+    -- to get moved out of their cost centres, but we also object to+    -- code getting associated with new cost-centre ticks - or+    -- changing the order in which they get applied.+    --+    -- A rule of thumb is that we don't want any code to gain new+    -- annotations. However, there are notable exceptions, for+    -- example:+    --+    --   let f = \y -> foo in tick<...> ... (f x) ...+    --     ==>+    --   tick<...> ... foo[x/y] ...+    --+    -- In-lining lambdas like this is always legal, because inlining a+    -- function does not change the cost-centre stack when the+    -- function is called.+  | CostCentreScope++  deriving (Eq)++-- | Returns the intended scoping rule for a Tickish+tickishScoped :: Tickish id -> TickishScoping+tickishScoped n@ProfNote{}+  | profNoteScope n        = CostCentreScope+  | otherwise              = NoScope+tickishScoped HpcTick{}    = NoScope+tickishScoped Breakpoint{} = CostCentreScope+   -- Breakpoints are scoped: eventually we're going to do call+   -- stacks, but also this helps prevent the simplifier from moving+   -- breakpoints around and changing their result type (see #1531).+tickishScoped SourceNote{} = SoftScope++-- | Returns whether the tick scoping rule is at least as permissive+-- as the given scoping rule.+tickishScopesLike :: Tickish id -> TickishScoping -> Bool+tickishScopesLike t scope = tickishScoped t `like` scope+  where NoScope         `like` _               = True+        _               `like` NoScope         = False+        SoftScope       `like` _               = True+        _               `like` SoftScope       = False+        CostCentreScope `like` _               = True++-- | Returns @True@ for ticks that can be floated upwards easily even+-- where it might change execution counts, such as:+--+--   Just (tick<...> foo)+--     ==>+--   tick<...> (Just foo)+--+-- This is a combination of @tickishSoftScope@ and+-- @tickishCounts@. Note that in principle splittable ticks can become+-- floatable using @mkNoTick@ -- even though there's currently no+-- tickish for which that is the case.+tickishFloatable :: Tickish id -> Bool+tickishFloatable t = t `tickishScopesLike` SoftScope && not (tickishCounts t)++-- | Returns @True@ for a tick that is both counting /and/ scoping and+-- can be split into its (tick, scope) parts using 'mkNoScope' and+-- 'mkNoTick' respectively.+tickishCanSplit :: Tickish id -> Bool+tickishCanSplit ProfNote{profNoteScope = True, profNoteCount = True}+                   = True+tickishCanSplit _  = False++mkNoCount :: Tickish id -> Tickish id+mkNoCount n | not (tickishCounts n)   = n+            | not (tickishCanSplit n) = panic "mkNoCount: Cannot split!"+mkNoCount n@ProfNote{}                = n {profNoteCount = False}+mkNoCount _                           = panic "mkNoCount: Undefined split!"++mkNoScope :: Tickish id -> Tickish id+mkNoScope n | tickishScoped n == NoScope  = n+            | not (tickishCanSplit n)     = panic "mkNoScope: Cannot split!"+mkNoScope n@ProfNote{}                    = n {profNoteScope = False}+mkNoScope _                               = panic "mkNoScope: Undefined split!"++-- | Return @True@ if this source annotation compiles to some backend+-- code. Without this flag, the tickish is seen as a simple annotation+-- that does not have any associated evaluation code.+--+-- What this means that we are allowed to disregard the tick if doing+-- so means that we can skip generating any code in the first place. A+-- typical example is top-level bindings:+--+--   foo = tick<...> \y -> ...+--     ==>+--   foo = \y -> tick<...> ...+--+-- Here there is just no operational difference between the first and+-- the second version. Therefore code generation should simply+-- translate the code as if it found the latter.+tickishIsCode :: Tickish id -> Bool+tickishIsCode SourceNote{} = False+tickishIsCode _tickish     = True  -- all the rest for now+++-- | Governs the kind of expression that the tick gets placed on when+-- annotating for example using @mkTick@. If we find that we want to+-- put a tickish on an expression ruled out here, we try to float it+-- inwards until we find a suitable expression.+data TickishPlacement =++    -- | Place ticks exactly on run-time expressions. We can still+    -- move the tick through pure compile-time constructs such as+    -- other ticks, casts or type lambdas. This is the most+    -- restrictive placement rule for ticks, as all tickishs have in+    -- common that they want to track runtime processes. The only+    -- legal placement rule for counting ticks.+    PlaceRuntime++    -- | As @PlaceRuntime@, but we float the tick through all+    -- lambdas. This makes sense where there is little difference+    -- between annotating the lambda and annotating the lambda's code.+  | PlaceNonLam++    -- | In addition to floating through lambdas, cost-centre style+    -- tickishs can also be moved from constructors, non-function+    -- variables and literals. For example:+    --+    --   let x = scc<...> C (scc<...> y) (scc<...> 3) in ...+    --+    -- Neither the constructor application, the variable or the+    -- literal are likely to have any cost worth mentioning. And even+    -- if y names a thunk, the call would not care about the+    -- evaluation context. Therefore removing all annotations in the+    -- above example is safe.+  | PlaceCostCentre++  deriving (Eq)++-- | Placement behaviour we want for the ticks+tickishPlace :: Tickish id -> TickishPlacement+tickishPlace n@ProfNote{}+  | profNoteCount n        = PlaceRuntime+  | otherwise              = PlaceCostCentre+tickishPlace HpcTick{}     = PlaceRuntime+tickishPlace Breakpoint{}  = PlaceRuntime+tickishPlace SourceNote{}  = PlaceNonLam++-- | Returns whether one tick "contains" the other one, therefore+-- making the second tick redundant.+tickishContains :: Eq b => Tickish b -> Tickish b -> Bool+tickishContains (SourceNote sp1 n1) (SourceNote sp2 n2)+  = containsSpan sp1 sp2 && n1 == n2+    -- compare the String last+tickishContains t1 t2+  = t1 == t2++{-+************************************************************************+*                                                                      *+                Orphans+*                                                                      *+************************************************************************+-}++-- | Is this instance an orphan?  If it is not an orphan, contains an 'OccName'+-- witnessing the instance's non-orphanhood.+-- See Note [Orphans]+data IsOrphan+  = IsOrphan+  | NotOrphan OccName -- The OccName 'n' witnesses the instance's non-orphanhood+                      -- In that case, the instance is fingerprinted as part+                      -- of the definition of 'n's definition+    deriving Data++-- | Returns true if 'IsOrphan' is orphan.+isOrphan :: IsOrphan -> Bool+isOrphan IsOrphan = True+isOrphan _ = False++-- | Returns true if 'IsOrphan' is not an orphan.+notOrphan :: IsOrphan -> Bool+notOrphan NotOrphan{} = True+notOrphan _ = False++chooseOrphanAnchor :: NameSet -> IsOrphan+-- Something (rule, instance) is relate to all the Names in this+-- list. Choose one of them to be an "anchor" for the orphan.  We make+-- the choice deterministic to avoid gratuitious changes in the ABI+-- hash (Trac #4012).  Specifically, use lexicographic comparison of+-- OccName rather than comparing Uniques+--+-- NB: 'minimum' use Ord, and (Ord OccName) works lexicographically+--+chooseOrphanAnchor local_names+  | isEmptyNameSet local_names = IsOrphan+  | otherwise                  = NotOrphan (minimum occs)+  where+    occs = map nameOccName $ nonDetEltsUniqSet local_names+    -- It's OK to use nonDetEltsUFM here, see comments above++instance Binary IsOrphan where+    put_ bh IsOrphan = putByte bh 0+    put_ bh (NotOrphan n) = do+        putByte bh 1+        put_ bh n+    get bh = do+        h <- getByte bh+        case h of+            0 -> return IsOrphan+            _ -> do+                n <- get bh+                return $ NotOrphan n++{-+Note [Orphans]+~~~~~~~~~~~~~~+Class instances, rules, and family instances are divided into orphans+and non-orphans.  Roughly speaking, an instance/rule is an orphan if+its left hand side mentions nothing defined in this module.  Orphan-hood+has two major consequences++ * A module that contains orphans is called an "orphan module".  If+   the module being compiled depends (transitively) on an oprhan+   module M, then M.hi is read in regardless of whether M is oherwise+   needed. This is to ensure that we don't miss any instance decls in+   M.  But it's painful, because it means we need to keep track of all+   the orphan modules below us.++ * A non-orphan is not finger-printed separately.  Instead, for+   fingerprinting purposes it is treated as part of the entity it+   mentions on the LHS.  For example+      data T = T1 | T2+      instance Eq T where ....+   The instance (Eq T) is incorprated as part of T's fingerprint.++   In contrast, orphans are all fingerprinted together in the+   mi_orph_hash field of the ModIface.++   See MkIface.addFingerprints.++Orphan-hood is computed+  * For class instances:+      when we make a ClsInst+    (because it is needed during instance lookup)++  * For rules and family instances:+       when we generate an IfaceRule (MkIface.coreRuleToIfaceRule)+                     or IfaceFamInst (MkIface.instanceToIfaceInst)+-}++{-+************************************************************************+*                                                                      *+\subsection{Transformation rules}+*                                                                      *+************************************************************************++The CoreRule type and its friends are dealt with mainly in CoreRules,+but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.+-}++-- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules+type RuleBase = NameEnv [CoreRule]+        -- The rules are unordered;+        -- we sort out any overlaps on lookup++-- | A full rule environment which we can apply rules from.  Like a 'RuleBase',+-- but it also includes the set of visible orphans we use to filter out orphan+-- rules which are not visible (even though we can see them...)+data RuleEnv+    = RuleEnv { re_base          :: RuleBase+              , re_visible_orphs :: ModuleSet+              }++mkRuleEnv :: RuleBase -> [Module] -> RuleEnv+mkRuleEnv rules vis_orphs = RuleEnv rules (mkModuleSet vis_orphs)++emptyRuleEnv :: RuleEnv+emptyRuleEnv = RuleEnv emptyNameEnv emptyModuleSet++-- | A 'CoreRule' is:+--+-- * \"Local\" if the function it is a rule for is defined in the+--   same module as the rule itself.+--+-- * \"Orphan\" if nothing on the LHS is defined in the same module+--   as the rule itself+data CoreRule+  = Rule {+        ru_name :: RuleName,            -- ^ Name of the rule, for communication with the user+        ru_act  :: Activation,          -- ^ When the rule is active++        -- Rough-matching stuff+        -- see comments with InstEnv.ClsInst( is_cls, is_rough )+        ru_fn    :: Name,               -- ^ Name of the 'Id.Id' at the head of this rule+        ru_rough :: [Maybe Name],       -- ^ Name at the head of each argument to the left hand side++        -- Proper-matching stuff+        -- see comments with InstEnv.ClsInst( is_tvs, is_tys )+        ru_bndrs :: [CoreBndr],         -- ^ Variables quantified over+        ru_args  :: [CoreExpr],         -- ^ Left hand side arguments++        -- And the right-hand side+        ru_rhs   :: CoreExpr,           -- ^ Right hand side of the rule+                                        -- Occurrence info is guaranteed correct+                                        -- See Note [OccInfo in unfoldings and rules]++        -- Locality+        ru_auto :: Bool,   -- ^ @True@  <=> this rule is auto-generated+                           --               (notably by Specialise or SpecConstr)+                           --   @False@ <=> generated at the user's behest+                           -- See Note [Trimming auto-rules] in TidyPgm+                           -- for the sole purpose of this field.++        ru_origin :: !Module,   -- ^ 'Module' the rule was defined in, used+                                -- to test if we should see an orphan rule.++        ru_orphan :: !IsOrphan, -- ^ Whether or not the rule is an orphan.++        ru_local :: Bool        -- ^ @True@ iff the fn at the head of the rule is+                                -- defined in the same module as the rule+                                -- and is not an implicit 'Id' (like a record selector,+                                -- class operation, or data constructor).  This+                                -- is different from 'ru_orphan', where a rule+                                -- can avoid being an orphan if *any* Name in+                                -- LHS of the rule was defined in the same+                                -- module as the rule.+    }++  -- | Built-in rules are used for constant folding+  -- and suchlike.  They have no free variables.+  -- A built-in rule is always visible (there is no such thing as+  -- an orphan built-in rule.)+  | BuiltinRule {+        ru_name  :: RuleName,   -- ^ As above+        ru_fn    :: Name,       -- ^ As above+        ru_nargs :: Int,        -- ^ Number of arguments that 'ru_try' consumes,+                                -- if it fires, including type arguments+        ru_try   :: RuleFun+                -- ^ This function does the rewrite.  It given too many+                -- arguments, it simply discards them; the returned 'CoreExpr'+                -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args+    }+                -- See Note [Extra args in rule matching] in Rules.hs++type RuleFun = DynFlags -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr+type InScopeEnv = (InScopeSet, IdUnfoldingFun)++type IdUnfoldingFun = Id -> Unfolding+-- A function that embodies how to unfold an Id if you need+-- to do that in the Rule.  The reason we need to pass this info in+-- is that whether an Id is unfoldable depends on the simplifier phase++isBuiltinRule :: CoreRule -> Bool+isBuiltinRule (BuiltinRule {}) = True+isBuiltinRule _                = False++isAutoRule :: CoreRule -> Bool+isAutoRule (BuiltinRule {}) = False+isAutoRule (Rule { ru_auto = is_auto }) = is_auto++-- | The number of arguments the 'ru_fn' must be applied+-- to before the rule can match on it+ruleArity :: CoreRule -> Int+ruleArity (BuiltinRule {ru_nargs = n}) = n+ruleArity (Rule {ru_args = args})      = length args++ruleName :: CoreRule -> RuleName+ruleName = ru_name++ruleModule :: CoreRule -> Maybe Module+ruleModule Rule { ru_origin } = Just ru_origin+ruleModule BuiltinRule {} = Nothing++ruleActivation :: CoreRule -> Activation+ruleActivation (BuiltinRule { })       = AlwaysActive+ruleActivation (Rule { ru_act = act }) = act++-- | The 'Name' of the 'Id.Id' at the head of the rule left hand side+ruleIdName :: CoreRule -> Name+ruleIdName = ru_fn++isLocalRule :: CoreRule -> Bool+isLocalRule = ru_local++-- | Set the 'Name' of the 'Id.Id' at the head of the rule left hand side+setRuleIdName :: Name -> CoreRule -> CoreRule+setRuleIdName nm ru = ru { ru_fn = nm }++{-+************************************************************************+*                                                                      *+\subsection{Vectorisation declarations}+*                                                                      *+************************************************************************++Representation of desugared vectorisation declarations that are fed to the vectoriser (via+'ModGuts').+-}++data CoreVect = Vect      Id   CoreExpr+              | NoVect    Id+              | VectType  Bool TyCon (Maybe TyCon)+              | VectClass TyCon                     -- class tycon+              | VectInst  Id                        -- instance dfun (always SCALAR)  !!!FIXME: should be superfluous now++{-+************************************************************************+*                                                                      *+                Unfoldings+*                                                                      *+************************************************************************++The @Unfolding@ type is declared here to avoid numerous loops+-}++-- | Records the /unfolding/ of an identifier, which is approximately the form the+-- identifier would have if we substituted its definition in for the identifier.+-- This type should be treated as abstract everywhere except in "CoreUnfold"+data Unfolding+  = NoUnfolding        -- ^ We have no information about the unfolding.++  | BootUnfolding      -- ^ We have no information about the unfolding, because+                       -- this 'Id' came from an @hi-boot@ file.+                       -- See Note [Inlining and hs-boot files] in ToIface+                       -- for what this is used for.++  | OtherCon [AltCon]  -- ^ It ain't one of these constructors.+                       -- @OtherCon xs@ also indicates that something has been evaluated+                       -- and hence there's no point in re-evaluating it.+                       -- @OtherCon []@ is used even for non-data-type values+                       -- to indicated evaluated-ness.  Notably:+                       --+                       -- > data C = C !(Int -> Int)+                       -- > case x of { C f -> ... }+                       --+                       -- Here, @f@ gets an @OtherCon []@ unfolding.++  | DFunUnfolding {     -- The Unfolding of a DFunId+                        -- See Note [DFun unfoldings]+                        --     df = /\a1..am. \d1..dn. MkD t1 .. tk+                        --                                 (op1 a1..am d1..dn)+                        --                                 (op2 a1..am d1..dn)+        df_bndrs :: [Var],      -- The bound variables [a1..m],[d1..dn]+        df_con   :: DataCon,    -- The dictionary data constructor (never a newtype datacon)+        df_args  :: [CoreExpr]  -- Args of the data con: types, superclasses and methods,+    }                           -- in positional order++  | CoreUnfolding {             -- An unfolding for an Id with no pragma,+                                -- or perhaps a NOINLINE pragma+                                -- (For NOINLINE, the phase, if any, is in the+                                -- InlinePragInfo for this Id.)+        uf_tmpl       :: CoreExpr,        -- Template; occurrence info is correct+        uf_src        :: UnfoldingSource, -- Where the unfolding came from+        uf_is_top     :: Bool,          -- True <=> top level binding+        uf_is_value   :: Bool,          -- exprIsHNF template (cached); it is ok to discard+                                        --      a `seq` on this variable+        uf_is_conlike :: Bool,          -- True <=> applicn of constructor or CONLIKE function+                                        --      Cached version of exprIsConLike+        uf_is_work_free :: Bool,                -- True <=> doesn't waste (much) work to expand+                                        --          inside an inlining+                                        --      Cached version of exprIsCheap+        uf_expandable :: Bool,          -- True <=> can expand in RULE matching+                                        --      Cached version of exprIsExpandable+        uf_guidance   :: UnfoldingGuidance      -- Tells about the *size* of the template.+    }+  -- ^ An unfolding with redundant cached information. Parameters:+  --+  --  uf_tmpl: Template used to perform unfolding;+  --           NB: Occurrence info is guaranteed correct:+  --               see Note [OccInfo in unfoldings and rules]+  --+  --  uf_is_top: Is this a top level binding?+  --+  --  uf_is_value: 'exprIsHNF' template (cached); it is ok to discard a 'seq' on+  --     this variable+  --+  --  uf_is_work_free:  Does this waste only a little work if we expand it inside an inlining?+  --     Basically this is a cached version of 'exprIsWorkFree'+  --+  --  uf_guidance:  Tells us about the /size/ of the unfolding template+++------------------------------------------------+data UnfoldingSource+  = -- See also Note [Historical note: unfoldings for wrappers]++    InlineRhs          -- The current rhs of the function+                       -- Replace uf_tmpl each time around++  | InlineStable       -- From an INLINE or INLINABLE pragma+                       --   INLINE     if guidance is UnfWhen+                       --   INLINABLE  if guidance is UnfIfGoodArgs/UnfoldNever+                       -- (well, technically an INLINABLE might be made+                       -- UnfWhen if it was small enough, and then+                       -- it will behave like INLINE outside the current+                       -- module, but that is the way automatic unfoldings+                       -- work so it is consistent with the intended+                       -- meaning of INLINABLE).+                       --+                       -- uf_tmpl may change, but only as a result of+                       -- gentle simplification, it doesn't get updated+                       -- to the current RHS during compilation as with+                       -- InlineRhs.+                       --+                       -- See Note [InlineStable]++  | InlineCompulsory   -- Something that *has* no binding, so you *must* inline it+                       -- Only a few primop-like things have this property+                       -- (see MkId.hs, calls to mkCompulsoryUnfolding).+                       -- Inline absolutely always, however boring the context.++++-- | 'UnfoldingGuidance' says when unfolding should take place+data UnfoldingGuidance+  = UnfWhen {   -- Inline without thinking about the *size* of the uf_tmpl+                -- Used (a) for small *and* cheap unfoldings+                --      (b) for INLINE functions+                -- See Note [INLINE for small functions] in CoreUnfold+      ug_arity    :: Arity,     -- Number of value arguments expected++      ug_unsat_ok  :: Bool,     -- True <=> ok to inline even if unsaturated+      ug_boring_ok :: Bool      -- True <=> ok to inline even if the context is boring+                -- So True,True means "always"+    }++  | UnfIfGoodArgs {     -- Arose from a normal Id; the info here is the+                        -- result of a simple analysis of the RHS++      ug_args ::  [Int],  -- Discount if the argument is evaluated.+                          -- (i.e., a simplification will definitely+                          -- be possible).  One elt of the list per *value* arg.++      ug_size :: Int,     -- The "size" of the unfolding.++      ug_res :: Int       -- Scrutinee discount: the discount to substract if the thing is in+    }                     -- a context (case (thing args) of ...),+                          -- (where there are the right number of arguments.)++  | UnfNever        -- The RHS is big, so don't inline it+  deriving (Eq)++{-+Note [Historical note: unfoldings for wrappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to have a nice clever scheme in interface files for+wrappers. A wrapper's unfolding can be reconstructed from its worker's+id and its strictness. This decreased .hi file size (sometimes+significantly, for modules like GHC.Classes with many high-arity w/w+splits) and had a slight corresponding effect on compile times.++However, when we added the second demand analysis, this scheme lead to+some Core lint errors. The second analysis could change the strictness+signatures, which sometimes resulted in a wrapper's regenerated+unfolding applying the wrapper to too many arguments.++Instead of repairing the clever .hi scheme, we abandoned it in favor+of simplicity. The .hi sizes are usually insignificant (excluding the++1M for base libraries), and compile time barely increases (~+1% for+nofib). The nicer upshot is that the UnfoldingSource no longer mentions+an Id, so, eg, substitutions need not traverse them.+++Note [DFun unfoldings]+~~~~~~~~~~~~~~~~~~~~~~+The Arity in a DFunUnfolding is total number of args (type and value)+that the DFun needs to produce a dictionary.  That's not necessarily+related to the ordinary arity of the dfun Id, esp if the class has+one method, so the dictionary is represented by a newtype.  Example++     class C a where { op :: a -> Int }+     instance C a -> C [a] where op xs = op (head xs)++The instance translates to++     $dfCList :: forall a. C a => C [a]  -- Arity 2!+     $dfCList = /\a.\d. $copList {a} d |> co++     $copList :: forall a. C a => [a] -> Int  -- Arity 2!+     $copList = /\a.\d.\xs. op {a} d (head xs)++Now we might encounter (op (dfCList {ty} d) a1 a2)+and we want the (op (dfList {ty} d)) rule to fire, because $dfCList+has all its arguments, even though its (value) arity is 2.  That's+why we record the number of expected arguments in the DFunUnfolding.++Note that although it's an Arity, it's most convenient for it to give+the *total* number of arguments, both type and value.  See the use+site in exprIsConApp_maybe.+-}++-- Constants for the UnfWhen constructor+needSaturated, unSaturatedOk :: Bool+needSaturated = False+unSaturatedOk = True++boringCxtNotOk, boringCxtOk :: Bool+boringCxtOk    = True+boringCxtNotOk = False++------------------------------------------------+noUnfolding :: Unfolding+-- ^ There is no known 'Unfolding'+evaldUnfolding :: Unfolding+-- ^ This unfolding marks the associated thing as being evaluated++noUnfolding    = NoUnfolding+evaldUnfolding = OtherCon []++-- | There is no known 'Unfolding', because this came from an+-- hi-boot file.+bootUnfolding :: Unfolding+bootUnfolding = BootUnfolding++mkOtherCon :: [AltCon] -> Unfolding+mkOtherCon = OtherCon++isStableSource :: UnfoldingSource -> Bool+-- Keep the unfolding template+isStableSource InlineCompulsory   = True+isStableSource InlineStable       = True+isStableSource InlineRhs          = False++-- | Retrieves the template of an unfolding: panics if none is known+unfoldingTemplate :: Unfolding -> CoreExpr+unfoldingTemplate = uf_tmpl++-- | Retrieves the template of an unfolding if possible+-- maybeUnfoldingTemplate is used mainly wnen specialising, and we do+-- want to specialise DFuns, so it's important to return a template+-- for DFunUnfoldings+maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr+maybeUnfoldingTemplate (CoreUnfolding { uf_tmpl = expr })+  = Just expr+maybeUnfoldingTemplate (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args })+  = Just (mkLams bndrs (mkApps (Var (dataConWorkId con)) args))+maybeUnfoldingTemplate _+  = Nothing++-- | The constructors that the unfolding could never be:+-- returns @[]@ if no information is available+otherCons :: Unfolding -> [AltCon]+otherCons (OtherCon cons) = cons+otherCons _               = []++-- | Determines if it is certainly the case that the unfolding will+-- yield a value (something in HNF): returns @False@ if unsure+isValueUnfolding :: Unfolding -> Bool+        -- Returns False for OtherCon+isValueUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald+isValueUnfolding _                                          = False++-- | Determines if it possibly the case that the unfolding will+-- yield a value. Unlike 'isValueUnfolding' it returns @True@+-- for 'OtherCon'+isEvaldUnfolding :: Unfolding -> Bool+        -- Returns True for OtherCon+isEvaldUnfolding (OtherCon _)                               = True+isEvaldUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald+isEvaldUnfolding _                                          = False++-- | @True@ if the unfolding is a constructor application, the application+-- of a CONLIKE function or 'OtherCon'+isConLikeUnfolding :: Unfolding -> Bool+isConLikeUnfolding (OtherCon _)                             = True+isConLikeUnfolding (CoreUnfolding { uf_is_conlike = con })  = con+isConLikeUnfolding _                                        = False++-- | Is the thing we will unfold into certainly cheap?+isCheapUnfolding :: Unfolding -> Bool+isCheapUnfolding (CoreUnfolding { uf_is_work_free = is_wf }) = is_wf+isCheapUnfolding _                                           = False++isExpandableUnfolding :: Unfolding -> Bool+isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expable+isExpandableUnfolding _                                              = False++expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr+-- Expand an expandable unfolding; this is used in rule matching+--   See Note [Expanding variables] in Rules.hs+-- The key point here is that CONLIKE things can be expanded+expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs+expandUnfolding_maybe _                                                       = Nothing++isCompulsoryUnfolding :: Unfolding -> Bool+isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True+isCompulsoryUnfolding _                                             = False++isStableUnfolding :: Unfolding -> Bool+-- True of unfoldings that should not be overwritten+-- by a CoreUnfolding for the RHS of a let-binding+isStableUnfolding (CoreUnfolding { uf_src = src }) = isStableSource src+isStableUnfolding (DFunUnfolding {})               = True+isStableUnfolding _                                = False++-- | Only returns False if there is no unfolding information available at all+hasSomeUnfolding :: Unfolding -> Bool+hasSomeUnfolding NoUnfolding   = False+hasSomeUnfolding BootUnfolding = False+hasSomeUnfolding _             = True++isBootUnfolding :: Unfolding -> Bool+isBootUnfolding BootUnfolding = True+isBootUnfolding _             = False++neverUnfoldGuidance :: UnfoldingGuidance -> Bool+neverUnfoldGuidance UnfNever = True+neverUnfoldGuidance _        = False++isFragileUnfolding :: Unfolding -> Bool+-- An unfolding is fragile if it mentions free variables or+-- is otherwise subject to change.  A robust one can be kept.+-- See Note [Fragile unfoldings]+isFragileUnfolding (CoreUnfolding {}) = True+isFragileUnfolding (DFunUnfolding {}) = True+isFragileUnfolding _                  = False+  -- NoUnfolding, BootUnfolding, OtherCon are all non-fragile++canUnfold :: Unfolding -> Bool+canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g)+canUnfold _                                   = False++{- Note [Fragile unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+An unfolding is "fragile" if it mentions free variables (and hence would+need substitution) or might be affected by optimisation.  The non-fragile+ones are++   NoUnfolding, BootUnfolding++   OtherCon {}    If we know this binder (say a lambda binder) will be+                  bound to an evaluated thing, we want to retain that+                  info in simpleOptExpr; see Trac #13077.++We consider even a StableUnfolding as fragile, because it needs substitution.++Note [InlineStable]+~~~~~~~~~~~~~~~~~+When you say+      {-# INLINE f #-}+      f x = <rhs>+you intend that calls (f e) are replaced by <rhs>[e/x] So we+should capture (\x.<rhs>) in the Unfolding of 'f', and never meddle+with it.  Meanwhile, we can optimise <rhs> to our heart's content,+leaving the original unfolding intact in Unfolding of 'f'. For example+        all xs = foldr (&&) True xs+        any p = all . map p  {-# INLINE any #-}+We optimise any's RHS fully, but leave the InlineRule saying "all . map p",+which deforests well at the call site.++So INLINE pragma gives rise to an InlineRule, which captures the original RHS.++Moreover, it's only used when 'f' is applied to the+specified number of arguments; that is, the number of argument on+the LHS of the '=' sign in the original source definition.+For example, (.) is now defined in the libraries like this+   {-# INLINE (.) #-}+   (.) f g = \x -> f (g x)+so that it'll inline when applied to two arguments. If 'x' appeared+on the left, thus+   (.) f g x = f (g x)+it'd only inline when applied to three arguments.  This slightly-experimental+change was requested by Roman, but it seems to make sense.++See also Note [Inlining an InlineRule] in CoreUnfold.+++Note [OccInfo in unfoldings and rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In unfoldings and rules, we guarantee that the template is occ-analysed,+so that the occurrence info on the binders is correct.  This is important,+because the Simplifier does not re-analyse the template when using it. If+the occurrence info is wrong+  - We may get more simpifier iterations than necessary, because+    once-occ info isn't there+  - More seriously, we may get an infinite loop if there's a Rec+    without a loop breaker marked+++************************************************************************+*                                                                      *+                  AltCon+*                                                                      *+************************************************************************+-}++-- The Ord is needed for the FiniteMap used in the lookForConstructor+-- in SimplEnv.  If you declared that lookForConstructor *ignores*+-- constructor-applications with LitArg args, then you could get+-- rid of this Ord.++instance Outputable AltCon where+  ppr (DataAlt dc) = ppr dc+  ppr (LitAlt lit) = ppr lit+  ppr DEFAULT      = text "__DEFAULT"++cmpAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Ordering+cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2++ltAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Bool+ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT++cmpAltCon :: AltCon -> AltCon -> Ordering+-- ^ Compares 'AltCon's within a single list of alternatives+cmpAltCon DEFAULT      DEFAULT     = EQ+cmpAltCon DEFAULT      _           = LT++cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2+cmpAltCon (DataAlt _)  DEFAULT      = GT+cmpAltCon (LitAlt  l1) (LitAlt  l2) = l1 `compare` l2+cmpAltCon (LitAlt _)   DEFAULT      = GT++cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>+                                  ppr con1 <+> ppr con2 )+                      LT++{-+************************************************************************+*                                                                      *+\subsection{Useful synonyms}+*                                                                      *+************************************************************************++Note [CoreProgram]+~~~~~~~~~~~~~~~~~~+The top level bindings of a program, a CoreProgram, are represented as+a list of CoreBind++ * Later bindings in the list can refer to earlier ones, but not vice+   versa.  So this is OK+      NonRec { x = 4 }+      Rec { p = ...q...x...+          ; q = ...p...x }+      Rec { f = ...p..x..f.. }+      NonRec { g = ..f..q...x.. }+   But it would NOT be ok for 'f' to refer to 'g'.++ * The occurrence analyser does strongly-connected component analysis+   on each Rec binding, and splits it into a sequence of smaller+   bindings where possible.  So the program typically starts life as a+   single giant Rec, which is then dependency-analysed into smaller+   chunks.+-}++-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism] in coreSyn/CoreLint.hs+type CoreProgram = [CoreBind]   -- See Note [CoreProgram]++-- | The common case for the type of binders and variables when+-- we are manipulating the Core language within GHC+type CoreBndr = Var+-- | Expressions where binders are 'CoreBndr's+type CoreExpr = Expr CoreBndr+-- | Argument expressions where binders are 'CoreBndr's+type CoreArg  = Arg  CoreBndr+-- | Binding groups where binders are 'CoreBndr's+type CoreBind = Bind CoreBndr+-- | Case alternatives where binders are 'CoreBndr's+type CoreAlt  = Alt  CoreBndr++{-+************************************************************************+*                                                                      *+\subsection{Tagging}+*                                                                      *+************************************************************************+-}++-- | Binders are /tagged/ with a t+data TaggedBndr t = TB CoreBndr t       -- TB for "tagged binder"++type TaggedBind t = Bind (TaggedBndr t)+type TaggedExpr t = Expr (TaggedBndr t)+type TaggedArg  t = Arg  (TaggedBndr t)+type TaggedAlt  t = Alt  (TaggedBndr t)++instance Outputable b => Outputable (TaggedBndr b) where+  ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'++deTagExpr :: TaggedExpr t -> CoreExpr+deTagExpr (Var v)                   = Var v+deTagExpr (Lit l)                   = Lit l+deTagExpr (Type ty)                 = Type ty+deTagExpr (Coercion co)             = Coercion co+deTagExpr (App e1 e2)               = App (deTagExpr e1) (deTagExpr e2)+deTagExpr (Lam (TB b _) e)          = Lam b (deTagExpr e)+deTagExpr (Let bind body)           = Let (deTagBind bind) (deTagExpr body)+deTagExpr (Case e (TB b _) ty alts) = Case (deTagExpr e) b ty (map deTagAlt alts)+deTagExpr (Tick t e)                = Tick t (deTagExpr e)+deTagExpr (Cast e co)               = Cast (deTagExpr e) co++deTagBind :: TaggedBind t -> CoreBind+deTagBind (NonRec (TB b _) rhs) = NonRec b (deTagExpr rhs)+deTagBind (Rec prs)             = Rec [(b, deTagExpr rhs) | (TB b _, rhs) <- prs]++deTagAlt :: TaggedAlt t -> CoreAlt+deTagAlt (con, bndrs, rhs) = (con, [b | TB b _ <- bndrs], deTagExpr rhs)++{-+************************************************************************+*                                                                      *+\subsection{Core-constructing functions with checking}+*                                                                      *+************************************************************************+-}++-- | Apply a list of argument expressions to a function expression in a nested fashion. Prefer to+-- use 'MkCore.mkCoreApps' if possible+mkApps    :: Expr b -> [Arg b]  -> Expr b+-- | Apply a list of type argument expressions to a function expression in a nested fashion+mkTyApps  :: Expr b -> [Type]   -> Expr b+-- | Apply a list of coercion argument expressions to a function expression in a nested fashion+mkCoApps  :: Expr b -> [Coercion] -> Expr b+-- | Apply a list of type or value variables to a function expression in a nested fashion+mkVarApps :: Expr b -> [Var] -> Expr b+-- | Apply a list of argument expressions to a data constructor in a nested fashion. Prefer to+-- use 'MkCore.mkCoreConApps' if possible+mkConApp      :: DataCon -> [Arg b] -> Expr b++mkApps    f args = foldl App                       f args+mkCoApps  f args = foldl (\ e a -> App e (Coercion a)) f args+mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars+mkConApp con args = mkApps (Var (dataConWorkId con)) args++mkTyApps  f args = foldl (\ e a -> App e (mkTyArg a)) f args++mkConApp2 :: DataCon -> [Type] -> [Var] -> Expr b+mkConApp2 con tys arg_ids = Var (dataConWorkId con)+                            `mkApps` map Type tys+                            `mkApps` map varToCoreExpr arg_ids++mkTyArg :: Type -> Expr b+mkTyArg ty+  | Just co <- isCoercionTy_maybe ty = Coercion co+  | otherwise                        = Type ty++-- | Create a machine integer literal expression of type @Int#@ from an @Integer@.+-- If you want an expression of type @Int@ use 'MkCore.mkIntExpr'+mkIntLit      :: DynFlags -> Integer -> Expr b+-- | Create a machine integer literal expression of type @Int#@ from an @Int@.+-- If you want an expression of type @Int@ use 'MkCore.mkIntExpr'+mkIntLitInt   :: DynFlags -> Int     -> Expr b++mkIntLit    dflags n = Lit (mkMachInt dflags n)+mkIntLitInt dflags n = Lit (mkMachInt dflags (toInteger n))++-- | Create a machine word literal expression of type  @Word#@ from an @Integer@.+-- If you want an expression of type @Word@ use 'MkCore.mkWordExpr'+mkWordLit     :: DynFlags -> Integer -> Expr b+-- | Create a machine word literal expression of type  @Word#@ from a @Word@.+-- If you want an expression of type @Word@ use 'MkCore.mkWordExpr'+mkWordLitWord :: DynFlags -> Word -> Expr b++mkWordLit     dflags w = Lit (mkMachWord dflags w)+mkWordLitWord dflags w = Lit (mkMachWord dflags (toInteger w))++mkWord64LitWord64 :: Word64 -> Expr b+mkWord64LitWord64 w = Lit (mkMachWord64 (toInteger w))++mkInt64LitInt64 :: Int64 -> Expr b+mkInt64LitInt64 w = Lit (mkMachInt64 (toInteger w))++-- | Create a machine character literal expression of type @Char#@.+-- If you want an expression of type @Char@ use 'MkCore.mkCharExpr'+mkCharLit :: Char -> Expr b+-- | Create a machine string literal expression of type @Addr#@.+-- If you want an expression of type @String@ use 'MkCore.mkStringExpr'+mkStringLit :: String -> Expr b++mkCharLit   c = Lit (mkMachChar c)+mkStringLit s = Lit (mkMachString s)++-- | Create a machine single precision literal expression of type @Float#@ from a @Rational@.+-- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr'+mkFloatLit :: Rational -> Expr b+-- | Create a machine single precision literal expression of type @Float#@ from a @Float@.+-- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr'+mkFloatLitFloat :: Float -> Expr b++mkFloatLit      f = Lit (mkMachFloat f)+mkFloatLitFloat f = Lit (mkMachFloat (toRational f))++-- | Create a machine double precision literal expression of type @Double#@ from a @Rational@.+-- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr'+mkDoubleLit :: Rational -> Expr b+-- | Create a machine double precision literal expression of type @Double#@ from a @Double@.+-- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr'+mkDoubleLitDouble :: Double -> Expr b++mkDoubleLit       d = Lit (mkMachDouble d)+mkDoubleLitDouble d = Lit (mkMachDouble (toRational d))++-- | Bind all supplied binding groups over an expression in a nested let expression. Assumes+-- that the rhs satisfies the let/app invariant.  Prefer to use 'MkCore.mkCoreLets' if+-- possible, which does guarantee the invariant+mkLets        :: [Bind b] -> Expr b -> Expr b+-- | Bind all supplied binders over an expression in a nested lambda expression. Prefer to+-- use 'MkCore.mkCoreLams' if possible+mkLams        :: [b] -> Expr b -> Expr b++mkLams binders body = foldr Lam body binders+mkLets binds body   = foldr mkLet body binds++mkLet :: Bind b -> Expr b -> Expr b+-- The desugarer sometimes generates an empty Rec group+-- which Lint rejects, so we kill it off right away+mkLet (Rec []) body = body+mkLet bind     body = Let bind body++-- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let",+-- this can only be used to bind something in a non-recursive @let@ expression+mkTyBind :: TyVar -> Type -> CoreBind+mkTyBind tv ty      = NonRec tv (Type ty)++-- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let",+-- this can only be used to bind something in a non-recursive @let@ expression+mkCoBind :: CoVar -> Coercion -> CoreBind+mkCoBind cv co      = NonRec cv (Coercion co)++-- | Convert a binder into either a 'Var' or 'Type' 'Expr' appropriately+varToCoreExpr :: CoreBndr -> Expr b+varToCoreExpr v | isTyVar v = Type (mkTyVarTy v)+                | isCoVar v = Coercion (mkCoVarCo v)+                | otherwise = ASSERT( isId v ) Var v++varsToCoreExprs :: [CoreBndr] -> [Expr b]+varsToCoreExprs vs = map varToCoreExpr vs++{-+************************************************************************+*                                                                      *+   Getting a result type+*                                                                      *+************************************************************************++These are defined here to avoid a module loop between CoreUtils and CoreFVs++-}++applyTypeToArg :: Type -> CoreExpr -> Type+-- ^ Determines the type resulting from applying an expression with given type+-- to a given argument expression+applyTypeToArg fun_ty arg = piResultTy fun_ty (exprToType arg)++-- | If the expression is a 'Type', converts. Otherwise,+-- panics. NB: This does /not/ convert 'Coercion' to 'CoercionTy'.+exprToType :: CoreExpr -> Type+exprToType (Type ty)     = ty+exprToType _bad          = pprPanic "exprToType" empty++-- | If the expression is a 'Coercion', converts.+exprToCoercion_maybe :: CoreExpr -> Maybe Coercion+exprToCoercion_maybe (Coercion co) = Just co+exprToCoercion_maybe _             = Nothing++{-+************************************************************************+*                                                                      *+\subsection{Simple access functions}+*                                                                      *+************************************************************************+-}++-- | Extract every variable by this group+bindersOf  :: Bind b -> [b]+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism] in coreSyn/CoreLint.hs+bindersOf (NonRec binder _) = [binder]+bindersOf (Rec pairs)       = [binder | (binder, _) <- pairs]++-- | 'bindersOf' applied to a list of binding groups+bindersOfBinds :: [Bind b] -> [b]+bindersOfBinds binds = foldr ((++) . bindersOf) [] binds++rhssOfBind :: Bind b -> [Expr b]+rhssOfBind (NonRec _ rhs) = [rhs]+rhssOfBind (Rec pairs)    = [rhs | (_,rhs) <- pairs]++rhssOfAlts :: [Alt b] -> [Expr b]+rhssOfAlts alts = [e | (_,_,e) <- alts]++-- | Collapse all the bindings in the supplied groups into a single+-- list of lhs\/rhs pairs suitable for binding in a 'Rec' binding group+flattenBinds :: [Bind b] -> [(b, Expr b)]+flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds+flattenBinds (Rec prs1   : binds) = prs1 ++ flattenBinds binds+flattenBinds []                   = []++-- | We often want to strip off leading lambdas before getting down to+-- business. Variants are 'collectTyBinders', 'collectValBinders',+-- and 'collectTyAndValBinders'+collectBinders         :: Expr b   -> ([b],     Expr b)+collectTyBinders       :: CoreExpr -> ([TyVar], CoreExpr)+collectValBinders      :: CoreExpr -> ([Id],    CoreExpr)+collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)+-- | Strip off exactly N leading lambdas (type or value). Good for use with+-- join points.+collectNBinders        :: Int -> Expr b -> ([b], Expr b)++collectBinders expr+  = go [] expr+  where+    go bs (Lam b e) = go (b:bs) e+    go bs e          = (reverse bs, e)++collectTyBinders expr+  = go [] expr+  where+    go tvs (Lam b e) | isTyVar b = go (b:tvs) e+    go tvs e                     = (reverse tvs, e)++collectValBinders expr+  = go [] expr+  where+    go ids (Lam b e) | isId b = go (b:ids) e+    go ids body               = (reverse ids, body)++collectTyAndValBinders expr+  = (tvs, ids, body)+  where+    (tvs, body1) = collectTyBinders expr+    (ids, body)  = collectValBinders body1++collectNBinders orig_n orig_expr+  = go orig_n [] orig_expr+  where+    go 0 bs expr      = (reverse bs, expr)+    go n bs (Lam b e) = go (n-1) (b:bs) e+    go _ _  _         = pprPanic "collectNBinders" $ int orig_n++-- | Takes a nested application expression and returns the the function+-- being applied and the arguments to which it is applied+collectArgs :: Expr b -> (Expr b, [Arg b])+collectArgs expr+  = go expr []+  where+    go (App f a) as = go f (a:as)+    go e         as = (e, as)++-- | Like @collectArgs@, but also collects looks through floatable+-- ticks if it means that we can find more arguments.+collectArgsTicks :: (Tickish Id -> Bool) -> Expr b+                 -> (Expr b, [Arg b], [Tickish Id])+collectArgsTicks skipTick expr+  = go expr [] []+  where+    go (App f a)  as ts = go f (a:as) ts+    go (Tick t e) as ts+      | skipTick t      = go e as (t:ts)+    go e          as ts = (e, as, reverse ts)+++{-+************************************************************************+*                                                                      *+\subsection{Predicates}+*                                                                      *+************************************************************************++At one time we optionally carried type arguments through to runtime.+@isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,+i.e. if type applications are actual lambdas because types are kept around+at runtime.  Similarly isRuntimeArg.+-}++-- | Will this variable exist at runtime?+isRuntimeVar :: Var -> Bool+isRuntimeVar = isId++-- | Will this argument expression exist at runtime?+isRuntimeArg :: CoreExpr -> Bool+isRuntimeArg = isValArg++-- | Returns @True@ for value arguments, false for type args+-- NB: coercions are value arguments (zero width, to be sure,+-- like State#, but still value args).+isValArg :: Expr b -> Bool+isValArg e = not (isTypeArg e)++-- | Returns @True@ iff the expression is a 'Type' or 'Coercion'+-- expression at its top level+isTyCoArg :: Expr b -> Bool+isTyCoArg (Type {})     = True+isTyCoArg (Coercion {}) = True+isTyCoArg _             = False++-- | Returns @True@ iff the expression is a 'Type' expression at its+-- top level.  Note this does NOT include 'Coercion's.+isTypeArg :: Expr b -> Bool+isTypeArg (Type {}) = True+isTypeArg _         = False++-- | The number of binders that bind values rather than types+valBndrCount :: [CoreBndr] -> Int+valBndrCount = count isId++-- | The number of argument expressions that are values rather than types at their top level+valArgCount :: [Arg b] -> Int+valArgCount = count isValArg++{-+************************************************************************+*                                                                      *+\subsection{Annotated core}+*                                                                      *+************************************************************************+-}++-- | Annotated core: allows annotation at every node in the tree+type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)++-- | A clone of the 'Expr' type but allowing annotation at every tree node+data AnnExpr' bndr annot+  = AnnVar      Id+  | AnnLit      Literal+  | AnnLam      bndr (AnnExpr bndr annot)+  | AnnApp      (AnnExpr bndr annot) (AnnExpr bndr annot)+  | AnnCase     (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]+  | AnnLet      (AnnBind bndr annot) (AnnExpr bndr annot)+  | AnnCast     (AnnExpr bndr annot) (annot, Coercion)+                   -- Put an annotation on the (root of) the coercion+  | AnnTick     (Tickish Id) (AnnExpr bndr annot)+  | AnnType     Type+  | AnnCoercion Coercion++-- | A clone of the 'Alt' type but allowing annotation at every tree node+type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)++-- | A clone of the 'Bind' type but allowing annotation at every tree node+data AnnBind bndr annot+  = AnnNonRec bndr (AnnExpr bndr annot)+  | AnnRec    [(bndr, AnnExpr bndr annot)]++-- | Takes a nested application expression and returns the the function+-- being applied and the arguments to which it is applied+collectAnnArgs :: AnnExpr b a -> (AnnExpr b a, [AnnExpr b a])+collectAnnArgs expr+  = go expr []+  where+    go (_, AnnApp f a) as = go f (a:as)+    go e               as = (e, as)++collectAnnArgsTicks :: (Tickish Var -> Bool) -> AnnExpr b a+                       -> (AnnExpr b a, [AnnExpr b a], [Tickish Var])+collectAnnArgsTicks tickishOk expr+  = go expr [] []+  where+    go (_, AnnApp f a)  as ts = go f (a:as) ts+    go (_, AnnTick t e) as ts | tickishOk t+                              = go e as (t:ts)+    go e                as ts = (e, as, reverse ts)++deAnnotate :: AnnExpr bndr annot -> Expr bndr+deAnnotate (_, e) = deAnnotate' e++deAnnotate' :: AnnExpr' bndr annot -> Expr bndr+deAnnotate' (AnnType t)           = Type t+deAnnotate' (AnnCoercion co)      = Coercion co+deAnnotate' (AnnVar  v)           = Var v+deAnnotate' (AnnLit  lit)         = Lit lit+deAnnotate' (AnnLam  binder body) = Lam binder (deAnnotate body)+deAnnotate' (AnnApp  fun arg)     = App (deAnnotate fun) (deAnnotate arg)+deAnnotate' (AnnCast e (_,co))    = Cast (deAnnotate e) co+deAnnotate' (AnnTick tick body)   = Tick tick (deAnnotate body)++deAnnotate' (AnnLet bind body)+  = Let (deAnnBind bind) (deAnnotate body)+  where+    deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)+    deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]++deAnnotate' (AnnCase scrut v t alts)+  = Case (deAnnotate scrut) v t (map deAnnAlt alts)++deAnnAlt :: AnnAlt bndr annot -> Alt bndr+deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)++-- | As 'collectBinders' but for 'AnnExpr' rather than 'Expr'+collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)+collectAnnBndrs e+  = collect [] e+  where+    collect bs (_, AnnLam b body) = collect (b:bs) body+    collect bs body               = (reverse bs, body)++-- | As 'collectNBinders' but for 'AnnExpr' rather than 'Expr'+collectNAnnBndrs :: Int -> AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)+collectNAnnBndrs orig_n e+  = collect orig_n [] e+  where+    collect 0 bs body               = (reverse bs, body)+    collect n bs (_, AnnLam b body) = collect (n-1) (b:bs) body+    collect _ _  _                  = pprPanic "collectNBinders" $ int orig_n
+ coreSyn/CoreTidy.hs view
@@ -0,0 +1,287 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1996-1998+++This module contains "tidying" code for *nested* expressions, bindings, rules.+The code for *top-level* bindings is in TidyPgm.+-}++{-# LANGUAGE CPP #-}+module CoreTidy (+        tidyExpr, tidyVarOcc, tidyRule, tidyRules, tidyUnfolding+    ) where++#include "HsVersions.h"++import CoreSyn+import CoreUnfold ( mkCoreUnfolding )+import CoreArity+import Id+import IdInfo+import Demand ( zapUsageEnvSig )+import Type( tidyType, tidyTyCoVarBndr )+import Coercion( tidyCo )+import Var+import VarEnv+import UniqFM+import Name hiding (tidyNameOcc)+import SrcLoc+import Maybes+import Data.List++{-+************************************************************************+*                                                                      *+\subsection{Tidying expressions, rules}+*                                                                      *+************************************************************************+-}++tidyBind :: TidyEnv+         -> CoreBind+         ->  (TidyEnv, CoreBind)++tidyBind env (NonRec bndr rhs)+  = tidyLetBndr env env (bndr,rhs) =: \ (env', bndr') ->+    (env', NonRec bndr' (tidyExpr env' rhs))++tidyBind env (Rec prs)+  = let+       (env', bndrs') = mapAccumL (tidyLetBndr env') env prs+    in+    map (tidyExpr env') (map snd prs)   =: \ rhss' ->+    (env', Rec (zip bndrs' rhss'))+++------------  Expressions  --------------+tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr+tidyExpr env (Var v)       = Var (tidyVarOcc env v)+tidyExpr env (Type ty)     = Type (tidyType env ty)+tidyExpr env (Coercion co) = Coercion (tidyCo env co)+tidyExpr _   (Lit lit)     = Lit lit+tidyExpr env (App f a)     = App (tidyExpr env f) (tidyExpr env a)+tidyExpr env (Tick t e)    = Tick (tidyTickish env t) (tidyExpr env e)+tidyExpr env (Cast e co)   = Cast (tidyExpr env e) (tidyCo env co)++tidyExpr env (Let b e)+  = tidyBind env b      =: \ (env', b') ->+    Let b' (tidyExpr env' e)++tidyExpr env (Case e b ty alts)+  = tidyBndr env b  =: \ (env', b) ->+    Case (tidyExpr env e) b (tidyType env ty)+         (map (tidyAlt env') alts)++tidyExpr env (Lam b e)+  = tidyBndr env b      =: \ (env', b) ->+    Lam b (tidyExpr env' e)++------------  Case alternatives  --------------+tidyAlt :: TidyEnv -> CoreAlt -> CoreAlt+tidyAlt env (con, vs, rhs)+  = tidyBndrs env vs    =: \ (env', vs) ->+    (con, vs, tidyExpr env' rhs)++------------  Tickish  --------------+tidyTickish :: TidyEnv -> Tickish Id -> Tickish Id+tidyTickish env (Breakpoint ix ids) = Breakpoint ix (map (tidyVarOcc env) ids)+tidyTickish _   other_tickish       = other_tickish++------------  Rules  --------------+tidyRules :: TidyEnv -> [CoreRule] -> [CoreRule]+tidyRules _   [] = []+tidyRules env (rule : rules)+  = tidyRule env rule           =: \ rule ->+    tidyRules env rules         =: \ rules ->+    (rule : rules)++tidyRule :: TidyEnv -> CoreRule -> CoreRule+tidyRule _   rule@(BuiltinRule {}) = rule+tidyRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs,+                          ru_fn = fn, ru_rough = mb_ns })+  = tidyBndrs env bndrs         =: \ (env', bndrs) ->+    map (tidyExpr env') args    =: \ args ->+    rule { ru_bndrs = bndrs, ru_args = args,+           ru_rhs   = tidyExpr env' rhs,+           ru_fn    = tidyNameOcc env fn,+           ru_rough = map (fmap (tidyNameOcc env')) mb_ns }++{-+************************************************************************+*                                                                      *+\subsection{Tidying non-top-level binders}+*                                                                      *+************************************************************************+-}++tidyNameOcc :: TidyEnv -> Name -> Name+-- In rules and instances, we have Names, and we must tidy them too+-- Fortunately, we can lookup in the VarEnv with a name+tidyNameOcc (_, var_env) n = case lookupUFM var_env n of+                                Nothing -> n+                                Just v  -> idName v++tidyVarOcc :: TidyEnv -> Var -> Var+tidyVarOcc (_, var_env) v = lookupVarEnv var_env v `orElse` v++-- tidyBndr is used for lambda and case binders+tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)+tidyBndr env var+  | isTyCoVar var = tidyTyCoVarBndr env var+  | otherwise     = tidyIdBndr env var++tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])+tidyBndrs env vars = mapAccumL tidyBndr env vars++-- Non-top-level variables, not covars+tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id)+tidyIdBndr env@(tidy_env, var_env) id+  = -- Do this pattern match strictly, otherwise we end up holding on to+    -- stuff in the OccName.+    case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') ->+    let+        -- Give the Id a fresh print-name, *and* rename its type+        -- The SrcLoc isn't important now,+        -- though we could extract it from the Id+        --+        ty'      = tidyType env (idType id)+        name'    = mkInternalName (idUnique id) occ' noSrcSpan+        id'      = mkLocalIdWithInfo name' ty' new_info+        var_env' = extendVarEnv var_env id id'++        -- Note [Tidy IdInfo]+        new_info = vanillaIdInfo `setOccInfo` occInfo old_info+                                 `setUnfoldingInfo` new_unf+                                  -- see Note [Preserve OneShotInfo]+                                 `setOneShotInfo` oneShotInfo old_info+        old_info = idInfo id+        old_unf  = unfoldingInfo old_info+        new_unf | isEvaldUnfolding old_unf = evaldUnfolding+                | otherwise                = noUnfolding+          -- See Note [Preserve evaluatedness]+    in+    ((tidy_env', var_env'), id')+   }++tidyLetBndr :: TidyEnv         -- Knot-tied version for unfoldings+            -> TidyEnv         -- The one to extend+            -> (Id, CoreExpr) -> (TidyEnv, Var)+-- Used for local (non-top-level) let(rec)s+-- Just like tidyIdBndr above, but with more IdInfo+tidyLetBndr rec_tidy_env env@(tidy_env, var_env) (id,rhs)+  = case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') ->+    let+        ty'      = tidyType env (idType id)+        name'    = mkInternalName (idUnique id) occ' noSrcSpan+        details  = idDetails id+        id'      = mkLocalVar details name' ty' new_info+        var_env' = extendVarEnv var_env id id'++        -- Note [Tidy IdInfo]+        -- We need to keep around any interesting strictness and+        -- demand info because later on we may need to use it when+        -- converting to A-normal form.+        -- eg.+        --      f (g x),  where f is strict in its argument, will be converted+        --      into  case (g x) of z -> f z  by CorePrep, but only if f still+        --      has its strictness info.+        --+        -- Similarly for the demand info - on a let binder, this tells+        -- CorePrep to turn the let into a case.+        -- But: Remove the usage demand here+        --      (See Note [Zapping DmdEnv after Demand Analyzer] in WorkWrap)+        --+        -- Similarly arity info for eta expansion in CorePrep+        --+        -- Set inline-prag info so that we preseve it across+        -- separate compilation boundaries+        old_info = idInfo id+        new_info = vanillaIdInfo+                    `setOccInfo`        occInfo old_info+                    `setArityInfo`      exprArity rhs+                    `setStrictnessInfo` zapUsageEnvSig (strictnessInfo old_info)+                    `setDemandInfo`     demandInfo old_info+                    `setInlinePragInfo` inlinePragInfo old_info+                    `setUnfoldingInfo`  new_unf++        new_unf | isStableUnfolding old_unf = tidyUnfolding rec_tidy_env old_unf old_unf+                | isEvaldUnfolding  old_unf = evaldUnfolding+                                              -- See Note [Preserve evaluatedness]+                | otherwise                 = noUnfolding+        old_unf = unfoldingInfo old_info+    in+    ((tidy_env', var_env'), id') }++------------ Unfolding  --------------+tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding+tidyUnfolding tidy_env df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) _+  = df { df_bndrs = bndrs', df_args = map (tidyExpr tidy_env') args }+  where+    (tidy_env', bndrs') = tidyBndrs tidy_env bndrs++tidyUnfolding tidy_env+              (CoreUnfolding { uf_tmpl = unf_rhs, uf_is_top = top_lvl+                             , uf_src = src, uf_guidance = guidance })+              unf_from_rhs+  | isStableSource src+  = mkCoreUnfolding src top_lvl (tidyExpr tidy_env unf_rhs) guidance+    -- Preserves OccInfo++    -- Note that uf_is_value and friends may be a thunk containing a reference+    -- to the old template. Consequently it is important that we rebuild them,+    -- despite the fact that they won't change, to avoid a space leak (since,+    -- e.g., ToIface doesn't look at them; see #13564). This is the same+    -- approach we use in Simplify.simplUnfolding and TcIface.tcUnfolding.++  | otherwise+  = unf_from_rhs+tidyUnfolding _ unf _ = unf     -- NoUnfolding or OtherCon++{-+Note [Tidy IdInfo]+~~~~~~~~~~~~~~~~~~+All nested Ids now have the same IdInfo, namely vanillaIdInfo, which+should save some space; except that we preserve occurrence info for+two reasons:++  (a) To make printing tidy core nicer++  (b) Because we tidy RULES and InlineRules, which may then propagate+      via --make into the compilation of the next module, and we want+      the benefit of that occurrence analysis when we use the rule or+      or inline the function.  In particular, it's vital not to lose+      loop-breaker info, else we get an infinite inlining loop++Note that tidyLetBndr puts more IdInfo back.++Note [Preserve evaluatedness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  data T = MkT !Bool+  ....(case v of MkT y ->+       let z# = case y of+                  True -> 1#+                  False -> 2#+       in ...)++The z# binding is ok because the RHS is ok-for-speculation,+but Lint will complain unless it can *see* that.  So we+preserve the evaluated-ness on 'y' in tidyBndr.++(Another alternative would be to tidy unboxed lets into cases,+but that seems more indirect and surprising.)++Note [Preserve OneShotInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We keep the OneShotInfo because we want it to propagate into the interface.+Not all OneShotInfo is determined by a compiler analysis; some is added by a+call of GHC.Exts.oneShot, which is then discarded before the end of the+optimisation pipeline, leaving only the OneShotInfo on the lambda. Hence we+must preserve this info in inlinings. See Note [The oneShot function] in MkId.++This applies to lambda binders only, hence it is stored in IfaceLamBndr.+-}++(=:) :: a -> (a -> b) -> b+m =: k = m `seq` k m
+ coreSyn/CoreUnfold.hs view
@@ -0,0 +1,1492 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1994-1998+++Core-syntax unfoldings++Unfoldings (which can travel across module boundaries) are in Core+syntax (namely @CoreExpr@s).++The type @Unfolding@ sits ``above'' simply-Core-expressions+unfoldings, capturing ``higher-level'' things we know about a binding,+usually things that the simplifier found out (e.g., ``it's a+literal'').  In the corner of a @CoreUnfolding@ unfolding, you will+find, unsurprisingly, a Core expression.+-}++{-# LANGUAGE CPP #-}++module CoreUnfold (+        Unfolding, UnfoldingGuidance,   -- Abstract types++        noUnfolding, mkImplicitUnfolding,+        mkUnfolding, mkCoreUnfolding,+        mkTopUnfolding, mkSimpleUnfolding, mkWorkerUnfolding,+        mkInlineUnfolding, mkInlineUnfoldingWithArity,+        mkInlinableUnfolding, mkWwInlineRule,+        mkCompulsoryUnfolding, mkDFunUnfolding,+        specUnfolding,++        ArgSummary(..),++        couldBeSmallEnoughToInline, inlineBoringOk,+        certainlyWillInline, smallEnoughToInline,++        callSiteInline, CallCtxt(..),++        -- Reexport from CoreSubst (it only live there so it can be used+        -- by the Very Simple Optimiser)+        exprIsConApp_maybe, exprIsLiteral_maybe+    ) where++#include "HsVersions.h"++import DynFlags+import CoreSyn+import PprCore          ()      -- Instances+import OccurAnal        ( occurAnalyseExpr )+import CoreOpt+import CoreArity       ( manifestArity )+import CoreUtils+import Id+import Demand          ( isBottomingSig )+import DataCon+import Literal+import PrimOp+import IdInfo+import BasicTypes       ( Arity, InlineSpec(..), inlinePragmaSpec )+import Type+import PrelNames+import TysPrim          ( realWorldStatePrimTy )+import Bag+import Util+import Outputable+import ForeignCall++import qualified Data.ByteString as BS++{-+************************************************************************+*                                                                      *+\subsection{Making unfoldings}+*                                                                      *+************************************************************************+-}++mkTopUnfolding :: DynFlags -> Bool -> CoreExpr -> Unfolding+mkTopUnfolding dflags is_bottoming rhs+  = mkUnfolding dflags InlineRhs True is_bottoming rhs++mkImplicitUnfolding :: DynFlags -> CoreExpr -> Unfolding+-- For implicit Ids, do a tiny bit of optimising first+mkImplicitUnfolding dflags expr+  = mkTopUnfolding dflags False (simpleOptExpr expr)++-- Note [Top-level flag on inline rules]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Slight hack: note that mk_inline_rules conservatively sets the+-- top-level flag to True.  It gets set more accurately by the simplifier+-- Simplify.simplUnfolding.++mkSimpleUnfolding :: DynFlags -> CoreExpr -> Unfolding+mkSimpleUnfolding dflags rhs+  = mkUnfolding dflags InlineRhs False False rhs++mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding+mkDFunUnfolding bndrs con ops+  = DFunUnfolding { df_bndrs = bndrs+                  , df_con = con+                  , df_args = map occurAnalyseExpr ops }+                  -- See Note [Occurrence analysis of unfoldings]++mkWwInlineRule :: CoreExpr -> Arity -> Unfolding+mkWwInlineRule expr arity+  = mkCoreUnfolding InlineStable True+                   (simpleOptExpr expr)+                   (UnfWhen { ug_arity = arity, ug_unsat_ok = unSaturatedOk+                            , ug_boring_ok = boringCxtNotOk })++mkCompulsoryUnfolding :: CoreExpr -> Unfolding+mkCompulsoryUnfolding expr         -- Used for things that absolutely must be unfolded+  = mkCoreUnfolding InlineCompulsory True+                    (simpleOptExpr expr)+                    (UnfWhen { ug_arity = 0    -- Arity of unfolding doesn't matter+                             , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk })++mkWorkerUnfolding :: DynFlags -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding+-- See Note [Worker-wrapper for INLINABLE functions] in WorkWrap+mkWorkerUnfolding dflags work_fn+                  (CoreUnfolding { uf_src = src, uf_tmpl = tmpl+                                 , uf_is_top = top_lvl })+  | isStableSource src+  = mkCoreUnfolding src top_lvl new_tmpl guidance+  where+    new_tmpl = simpleOptExpr (work_fn tmpl)+    guidance = calcUnfoldingGuidance dflags False new_tmpl++mkWorkerUnfolding _ _ _ = noUnfolding++-- | Make an unfolding that may be used unsaturated+-- (ug_unsat_ok = unSaturatedOk) and that is reported as having its+-- manifest arity (the number of outer lambdas applications will+-- resolve before doing any work).+mkInlineUnfolding :: CoreExpr -> Unfolding+mkInlineUnfolding expr+  = mkCoreUnfolding InlineStable+                    True         -- Note [Top-level flag on inline rules]+                    expr' guide+  where+    expr' = simpleOptExpr expr+    guide = UnfWhen { ug_arity = manifestArity expr'+                    , ug_unsat_ok = unSaturatedOk+                    , ug_boring_ok = boring_ok }+    boring_ok = inlineBoringOk expr'++-- | Make an unfolding that will be used once the RHS has been saturated+-- to the given arity.+mkInlineUnfoldingWithArity :: Arity -> CoreExpr -> Unfolding+mkInlineUnfoldingWithArity arity expr+  = mkCoreUnfolding InlineStable+                    True         -- Note [Top-level flag on inline rules]+                    expr' guide+  where+    expr' = simpleOptExpr expr+    guide = UnfWhen { ug_arity = arity+                    , ug_unsat_ok = needSaturated+                    , ug_boring_ok = boring_ok }+    boring_ok = inlineBoringOk expr'++mkInlinableUnfolding :: DynFlags -> CoreExpr -> Unfolding+mkInlinableUnfolding dflags expr+  = mkUnfolding dflags InlineStable False False expr'+  where+    expr' = simpleOptExpr expr++specUnfolding :: [Var] -> (CoreExpr -> CoreExpr) -> Arity -> Unfolding -> Unfolding+-- See Note [Specialising unfoldings]+-- specUnfolding spec_bndrs spec_app arity_decrease unf+--   = \spec_bndrs. spec_app( unf )+--+specUnfolding spec_bndrs spec_app arity_decrease+              df@(DFunUnfolding { df_bndrs = old_bndrs, df_con = con, df_args = args })+  = ASSERT2( arity_decrease == count isId old_bndrs - count isId spec_bndrs, ppr df )+    mkDFunUnfolding spec_bndrs con (map spec_arg args)+      -- There is a hard-to-check assumption here that the spec_app has+      -- enough applications to exactly saturate the old_bndrs+      -- For DFunUnfoldings we transform+      --       \old_bndrs. MkD <op1> ... <opn>+      -- to+      --       \new_bndrs. MkD (spec_app(\old_bndrs. <op1>)) ... ditto <opn>+      -- The ASSERT checks the value part of that+  where+    spec_arg arg = simpleOptExpr (spec_app (mkLams old_bndrs arg))+                   -- The beta-redexes created by spec_app will be+                   -- simplified away by simplOptExpr++specUnfolding spec_bndrs spec_app arity_decrease+              (CoreUnfolding { uf_src = src, uf_tmpl = tmpl+                             , uf_is_top = top_lvl+                             , uf_guidance = old_guidance })+ | isStableSource src  -- See Note [Specialising unfoldings]+ , UnfWhen { ug_arity     = old_arity+           , ug_unsat_ok  = unsat_ok+           , ug_boring_ok = boring_ok } <- old_guidance+ = let guidance = UnfWhen { ug_arity     = old_arity - arity_decrease+                          , ug_unsat_ok  = unsat_ok+                          , ug_boring_ok = boring_ok }+       new_tmpl = simpleOptExpr (mkLams spec_bndrs (spec_app tmpl))+                   -- The beta-redexes created by spec_app will be+                   -- simplified away by simplOptExpr++   in mkCoreUnfolding src top_lvl new_tmpl guidance++specUnfolding _ _ _ _ = noUnfolding++{- Note [Specialising unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we specialise a function for some given type-class arguments, we use+specUnfolding to specialise its unfolding.  Some important points:++* If the original function has a DFunUnfolding, the specialised one+  must do so too!  Otherwise we lose the magic rules that make it+  interact with ClassOps++* There is a bit of hack for INLINABLE functions:+     f :: Ord a => ....+     f = <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 probaby 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).++  Moreover, keeping the INLINABLE thing isn't much help, because+  the specialised function (probaby) isn't overloaded any more.++  Conclusion: drop the INLINEALE pragma.  In practice what this means is:+     if a stable unfolding has UnfoldingGuidance of UnfWhen,+        we keep it (so the specialised thing too will always inline)+     if a stable unfolding has UnfoldingGuidance of UnfIfGoodArgs+        (which arises from INLINABLE), we discard it+-}++mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr+                -> UnfoldingGuidance -> Unfolding+-- Occurrence-analyses the expression before capturing it+mkCoreUnfolding src top_lvl expr guidance+  = CoreUnfolding { uf_tmpl         = occurAnalyseExpr expr,+                      -- See Note [Occurrence analysis of unfoldings]+                    uf_src          = src,+                    uf_is_top       = top_lvl,+                    uf_is_value     = exprIsHNF        expr,+                    uf_is_conlike   = exprIsConLike    expr,+                    uf_is_work_free = exprIsWorkFree   expr,+                    uf_expandable   = exprIsExpandable expr,+                    uf_guidance     = guidance }++mkUnfolding :: DynFlags -> UnfoldingSource+            -> Bool       -- Is top-level+            -> Bool       -- Definitely a bottoming binding+                          -- (only relevant for top-level bindings)+            -> CoreExpr+            -> Unfolding+-- Calculates unfolding guidance+-- Occurrence-analyses the expression before capturing it+mkUnfolding dflags src is_top_lvl is_bottoming expr+  = CoreUnfolding { uf_tmpl         = occurAnalyseExpr expr,+                      -- See Note [Occurrence analysis of unfoldings]+                    uf_src          = src,+                    uf_is_top       = is_top_lvl,+                    uf_is_value     = exprIsHNF        expr,+                    uf_is_conlike   = exprIsConLike    expr,+                    uf_expandable   = exprIsExpandable expr,+                    uf_is_work_free = exprIsWorkFree   expr,+                    uf_guidance     = guidance }+  where+    is_top_bottoming = is_top_lvl && is_bottoming+    guidance         = calcUnfoldingGuidance dflags is_top_bottoming expr+        -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))!+        -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression]++{-+Note [Occurrence analysis of unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do occurrence-analysis of unfoldings once and for all, when the+unfolding is built, rather than each time we inline them.++But given this decision it's vital that we do+*always* do it.  Consider this unfolding+    \x -> letrec { f = ...g...; g* = f } in body+where g* is (for some strange reason) the loop breaker.  If we don't+occ-anal it when reading it in, we won't mark g as a loop breaker, and+we may inline g entirely in body, dropping its binding, and leaving+the occurrence in f out of scope. This happened in Trac #8892, where+the unfolding in question was a DFun unfolding.++But more generally, the simplifier is designed on the+basis that it is looking at occurrence-analysed expressions, so better+ensure that they acutally are.++Note [Calculate unfolding guidance on the non-occ-anal'd expression]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Notice that we give the non-occur-analysed expression to+calcUnfoldingGuidance.  In some ways it'd be better to occur-analyse+first; for example, sometimes during simplification, there's a large+let-bound thing which has been substituted, and so is now dead; so+'expr' contains two copies of the thing while the occurrence-analysed+expression doesn't.++Nevertheless, we *don't* and *must not* occ-analyse before computing+the size because++a) The size computation bales out after a while, whereas occurrence+   analysis does not.++b) Residency increases sharply if you occ-anal first.  I'm not+   100% sure why, but it's a large effect.  Compiling Cabal went+   from residency of 534M to over 800M with this one change.++This can occasionally mean that the guidance is very pessimistic;+it gets fixed up next round.  And it should be rare, because large+let-bound things that are dead are usually caught by preInlineUnconditionally+++************************************************************************+*                                                                      *+\subsection{The UnfoldingGuidance type}+*                                                                      *+************************************************************************+-}++inlineBoringOk :: CoreExpr -> Bool+-- See Note [INLINE for small functions]+-- True => the result of inlining the expression is+--         no bigger than the expression itself+--     eg      (\x y -> f y x)+-- This is a quick and dirty version. It doesn't attempt+-- to deal with  (\x y z -> x (y z))+-- The really important one is (x `cast` c)+inlineBoringOk e+  = go 0 e+  where+    go :: Int -> CoreExpr -> Bool+    go credit (Lam x e) | isId x           = go (credit+1) e+                        | otherwise        = go credit e+    go credit (App f (Type {}))            = go credit f+    go credit (App f a) | credit > 0+                        , exprIsTrivial a  = go (credit-1) f+    go credit (Tick _ e)                 = go credit e -- dubious+    go credit (Cast e _)                   = go credit e+    go _      (Var {})                     = boringCxtOk+    go _      _                            = boringCxtNotOk++calcUnfoldingGuidance+        :: DynFlags+        -> Bool          -- Definitely a top-level, bottoming binding+        -> CoreExpr      -- Expression to look at+        -> UnfoldingGuidance+calcUnfoldingGuidance dflags is_top_bottoming (Tick t expr)+  | not (tickishIsCode t)  -- non-code ticks don't matter for unfolding+  = calcUnfoldingGuidance dflags is_top_bottoming expr+calcUnfoldingGuidance dflags is_top_bottoming expr+  = case sizeExpr dflags bOMB_OUT_SIZE val_bndrs body of+      TooBig -> UnfNever+      SizeIs size cased_bndrs scrut_discount+        | uncondInline expr n_val_bndrs size+        -> UnfWhen { ug_unsat_ok = unSaturatedOk+                   , ug_boring_ok =  boringCxtOk+                   , ug_arity = n_val_bndrs }   -- Note [INLINE for small functions]++        | is_top_bottoming+        -> UnfNever   -- See Note [Do not inline top-level bottoming functions]++        | otherwise+        -> UnfIfGoodArgs { ug_args  = map (mk_discount cased_bndrs) val_bndrs+                         , ug_size  = size+                         , ug_res   = scrut_discount }++  where+    (bndrs, body) = collectBinders expr+    bOMB_OUT_SIZE = ufCreationThreshold dflags+           -- Bomb out if size gets bigger than this+    val_bndrs   = filter isId bndrs+    n_val_bndrs = length val_bndrs++    mk_discount :: Bag (Id,Int) -> Id -> Int+    mk_discount cbs bndr = foldlBag combine 0 cbs+           where+             combine acc (bndr', disc)+               | bndr == bndr' = acc `plus_disc` disc+               | otherwise     = acc++             plus_disc :: Int -> Int -> Int+             plus_disc | isFunTy (idType bndr) = max+                       | otherwise             = (+)+             -- See Note [Function and non-function discounts]++{-+Note [Computing the size of an expression]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The basic idea of sizeExpr is obvious enough: count nodes.  But getting the+heuristics right has taken a long time.  Here's the basic strategy:++    * Variables, literals: 0+      (Exception for string literals, see litSize.)++    * Function applications (f e1 .. en): 1 + #value args++    * Constructor applications: 1, regardless of #args++    * Let(rec): 1 + size of components++    * Note, cast: 0++Examples++  Size  Term+  --------------+    0     42#+    0     x+    0     True+    2     f x+    1     Just x+    4     f (g x)++Notice that 'x' counts 0, while (f x) counts 2.  That's deliberate: there's+a function call to account for.  Notice also that constructor applications+are very cheap, because exposing them to a caller is so valuable.++[25/5/11] All sizes are now multiplied by 10, except for primops+(which have sizes like 1 or 4.  This makes primops look fantastically+cheap, and seems to be almost unversally beneficial.  Done partly as a+result of #4978.++Note [Do not inline top-level bottoming functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The FloatOut pass has gone to some trouble to float out calls to 'error'+and similar friends.  See Note [Bottoming floats] in SetLevels.+Do not re-inline them!  But we *do* still inline if they are very small+(the uncondInline stuff).++Note [INLINE for small functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider        {-# INLINE f #-}+                f x = Just x+                g y = f y+Then f's RHS is no larger than its LHS, so we should inline it into+even the most boring context.  In general, f the function is+sufficiently small that its body is as small as the call itself, the+inline unconditionally, regardless of how boring the context is.++Things to note:++(1) We inline *unconditionally* if inlined thing is smaller (using sizeExpr)+    than the thing it's replacing.  Notice that+      (f x) --> (g 3)             -- YES, unconditionally+      (f x) --> x : []            -- YES, *even though* there are two+                                  --      arguments to the cons+      x     --> g 3               -- NO+      x     --> Just v            -- NO++    It's very important not to unconditionally replace a variable by+    a non-atomic term.++(2) We do this even if the thing isn't saturated, else we end up with the+    silly situation that+       f x y = x+       ...map (f 3)...+    doesn't inline.  Even in a boring context, inlining without being+    saturated will give a lambda instead of a PAP, and will be more+    efficient at runtime.++(3) However, when the function's arity > 0, we do insist that it+    has at least one value argument at the call site.  (This check is+    made in the UnfWhen case of callSiteInline.) Otherwise we find this:+         f = /\a \x:a. x+         d = /\b. MkD (f b)+    If we inline f here we get+         d = /\b. MkD (\x:b. x)+    and then prepareRhs floats out the argument, abstracting the type+    variables, so we end up with the original again!++(4) We must be much more cautious about arity-zero things. Consider+       let x = y +# z in ...+    In *size* terms primops look very small, because the generate a+    single instruction, but we do not want to unconditionally replace+    every occurrence of x with (y +# z).  So we only do the+    unconditional-inline thing for *trivial* expressions.++    NB: you might think that PostInlineUnconditionally would do this+    but it doesn't fire for top-level things; see SimplUtils+    Note [Top level and postInlineUnconditionally]+-}++uncondInline :: CoreExpr -> Arity -> Int -> Bool+-- Inline unconditionally if there no size increase+-- Size of call is arity (+1 for the function)+-- See Note [INLINE for small functions]+uncondInline rhs arity size+  | arity > 0 = size <= 10 * (arity + 1) -- See Note [INLINE for small functions] (1)+  | otherwise = exprIsTrivial rhs        -- See Note [INLINE for small functions] (4)++sizeExpr :: DynFlags+         -> Int             -- Bomb out if it gets bigger than this+         -> [Id]            -- Arguments; we're interested in which of these+                            -- get case'd+         -> CoreExpr+         -> ExprSize++-- Note [Computing the size of an expression]++sizeExpr dflags bOMB_OUT_SIZE top_args expr+  = size_up expr+  where+    size_up (Cast e _) = size_up e+    size_up (Tick _ e) = size_up e+    size_up (Type _)   = sizeZero           -- Types cost nothing+    size_up (Coercion _) = sizeZero+    size_up (Lit lit)  = sizeN (litSize lit)+    size_up (Var f) | isRealWorldId f = sizeZero+                      -- Make sure we get constructor discounts even+                      -- on nullary constructors+                    | otherwise       = size_up_call f [] 0++    size_up (App fun arg)+      | isTyCoArg arg = size_up fun+      | otherwise     = size_up arg  `addSizeNSD`+                        size_up_app fun [arg] (if isRealWorldExpr arg then 1 else 0)++    size_up (Lam b e)+      | isId b && not (isRealWorldId b) = lamScrutDiscount dflags (size_up e `addSizeN` 10)+      | otherwise = size_up e++    size_up (Let (NonRec binder rhs) body)+      = size_up_rhs (binder, rhs) `addSizeNSD`+        size_up body              `addSizeN`+        size_up_alloc binder++    size_up (Let (Rec pairs) body)+      = foldr (addSizeNSD . size_up_rhs)+              (size_up body `addSizeN` sum (map (size_up_alloc . fst) pairs))+              pairs++    size_up (Case e _ _ alts)+        | null alts+        = size_up e    -- case e of {} never returns, so take size of scrutinee++    size_up (Case e _ _ alts)+        -- Now alts is non-empty+        | Just v <- is_top_arg e -- We are scrutinising an argument variable+        = let+            alt_sizes = map size_up_alt alts++                  -- alts_size tries to compute a good discount for+                  -- the case when we are scrutinising an argument variable+            alts_size (SizeIs tot tot_disc tot_scrut)+                          -- Size of all alternatives+                      (SizeIs max _        _)+                          -- Size of biggest alternative+                  = SizeIs tot (unitBag (v, 20 + tot - max)+                      `unionBags` tot_disc) tot_scrut+                          -- If the variable is known, we produce a+                          -- discount that will take us back to 'max',+                          -- the size of the largest alternative The+                          -- 1+ is a little discount for reduced+                          -- allocation in the caller+                          --+                          -- Notice though, that we return tot_disc,+                          -- the total discount from all branches.  I+                          -- think that's right.++            alts_size tot_size _ = tot_size+          in+          alts_size (foldr1 addAltSize alt_sizes)  -- alts is non-empty+                    (foldr1 maxSize    alt_sizes)+                -- Good to inline if an arg is scrutinised, because+                -- that may eliminate allocation in the caller+                -- And it eliminates the case itself+        where+          is_top_arg (Var v) | v `elem` top_args = Just v+          is_top_arg (Cast e _) = is_top_arg e+          is_top_arg _ = Nothing+++    size_up (Case e _ _ alts) = size_up e  `addSizeNSD`+                                foldr (addAltSize . size_up_alt) case_size alts+      where+          case_size+           | is_inline_scrut e, not (lengthExceeds alts 1)  = sizeN (-10)+           | otherwise = sizeZero+                -- Normally we don't charge for the case itself, but+                -- we charge one per alternative (see size_up_alt,+                -- below) to account for the cost of the info table+                -- and comparisons.+                --+                -- However, in certain cases (see is_inline_scrut+                -- below), no code is generated for the case unless+                -- there are multiple alts.  In these cases we+                -- subtract one, making the first alt free.+                -- e.g. case x# +# y# of _ -> ...   should cost 1+                --      case touch# x# of _ -> ...  should cost 0+                -- (see #4978)+                --+                -- I would like to not have the "not (lengthExceeds alts 1)"+                -- condition above, but without that some programs got worse+                -- (spectral/hartel/event and spectral/para).  I don't fully+                -- understand why. (SDM 24/5/11)++                -- unboxed variables, inline primops and unsafe foreign calls+                -- are all "inline" things:+          is_inline_scrut (Var v) = isUnliftedType (idType v)+          is_inline_scrut scrut+              | (Var f, _) <- collectArgs scrut+                = case idDetails f of+                    FCallId fc  -> not (isSafeForeignCall fc)+                    PrimOpId op -> not (primOpOutOfLine op)+                    _other      -> False+              | otherwise+                = False++    size_up_rhs (bndr, rhs)+      | Just join_arity <- isJoinId_maybe bndr+        -- Skip arguments to join point+      , (_bndrs, body) <- collectNBinders join_arity rhs+      = size_up body+      | otherwise+      = size_up rhs++    ------------+    -- size_up_app is used when there's ONE OR MORE value args+    size_up_app (App fun arg) args voids+        | isTyCoArg arg                  = size_up_app fun args voids+        | isRealWorldExpr arg            = size_up_app fun (arg:args) (voids + 1)+        | otherwise                      = size_up arg  `addSizeNSD`+                                           size_up_app fun (arg:args) voids+    size_up_app (Var fun)     args voids = size_up_call fun args voids+    size_up_app (Tick _ expr) args voids = size_up_app expr args voids+    size_up_app (Cast expr _) args voids = size_up_app expr args voids+    size_up_app other         args voids = size_up other `addSizeN`+                                           callSize (length args) voids+       -- if the lhs is not an App or a Var, or an invisible thing like a+       -- Tick or Cast, then we should charge for a complete call plus the+       -- size of the lhs itself.++    ------------+    size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize+    size_up_call fun val_args voids+       = case idDetails fun of+           FCallId _        -> sizeN (callSize (length val_args) voids)+           DataConWorkId dc -> conSize    dc (length val_args)+           PrimOpId op      -> primOpSize op (length val_args)+           ClassOpId _      -> classOpSize dflags top_args val_args+           _                -> funSize dflags top_args fun (length val_args) voids++    ------------+    size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 10+        -- Don't charge for args, so that wrappers look cheap+        -- (See comments about wrappers with Case)+        --+        -- IMPORATANT: *do* charge 1 for the alternative, else we+        -- find that giant case nests are treated as practically free+        -- A good example is Foreign.C.Error.errnoToIOError++    ------------+    -- Cost to allocate binding with given binder+    size_up_alloc bndr+      |  isTyVar bndr                 -- Doesn't exist at runtime+      || isJoinId bndr                -- Not allocated at all+      || isUnliftedType (idType bndr) -- Doesn't live in heap+      = 0+      | otherwise+      = 10++    ------------+        -- These addSize things have to be here because+        -- I don't want to give them bOMB_OUT_SIZE as an argument+    addSizeN TooBig          _  = TooBig+    addSizeN (SizeIs n xs d) m  = mkSizeIs bOMB_OUT_SIZE (n + m) xs d++        -- addAltSize is used to add the sizes of case alternatives+    addAltSize TooBig            _      = TooBig+    addAltSize _                 TooBig = TooBig+    addAltSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)+        = mkSizeIs bOMB_OUT_SIZE (n1 + n2)+                                 (xs `unionBags` ys)+                                 (d1 + d2) -- Note [addAltSize result discounts]++        -- This variant ignores the result discount from its LEFT argument+        -- It's used when the second argument isn't part of the result+    addSizeNSD TooBig            _      = TooBig+    addSizeNSD _                 TooBig = TooBig+    addSizeNSD (SizeIs n1 xs _) (SizeIs n2 ys d2)+        = mkSizeIs bOMB_OUT_SIZE (n1 + n2)+                                 (xs `unionBags` ys)+                                 d2  -- Ignore d1++    isRealWorldId id = idType id `eqType` realWorldStatePrimTy++    -- an expression of type State# RealWorld must be a variable+    isRealWorldExpr (Var id)   = isRealWorldId id+    isRealWorldExpr (Tick _ e) = isRealWorldExpr e+    isRealWorldExpr _          = False++-- | Finds a nominal size of a string literal.+litSize :: Literal -> Int+-- Used by CoreUnfold.sizeExpr+litSize (LitInteger {}) = 100   -- Note [Size of literal integers]+litSize (MachStr str)   = 10 + 10 * ((BS.length str + 3) `div` 4)+        -- If size could be 0 then @f "x"@ might be too small+        -- [Sept03: make literal strings a bit bigger to avoid fruitless+        --  duplication of little strings]+litSize _other = 0    -- Must match size of nullary constructors+                      -- Key point: if  x |-> 4, then x must inline unconditionally+                      --            (eg via case binding)++classOpSize :: DynFlags -> [Id] -> [CoreExpr] -> ExprSize+-- See Note [Conlike is interesting]+classOpSize _ _ []+  = sizeZero+classOpSize dflags top_args (arg1 : other_args)+  = SizeIs size arg_discount 0+  where+    size = 20 + (10 * length other_args)+    -- If the class op is scrutinising a lambda bound dictionary then+    -- give it a discount, to encourage the inlining of this function+    -- The actual discount is rather arbitrarily chosen+    arg_discount = case arg1 of+                     Var dict | dict `elem` top_args+                              -> unitBag (dict, ufDictDiscount dflags)+                     _other   -> emptyBag++-- | The size of a function call+callSize+ :: Int  -- ^ number of value args+ -> Int  -- ^ number of value args that are void+ -> Int+callSize n_val_args voids = 10 * (1 + n_val_args - voids)+        -- The 1+ is for the function itself+        -- Add 1 for each non-trivial arg;+        -- the allocation cost, as in let(rec)++-- | The size of a jump to a join point+jumpSize+ :: Int  -- ^ number of value args+ -> Int  -- ^ number of value args that are void+ -> Int+jumpSize n_val_args voids = 2 * (1 + n_val_args - voids)+  -- A jump is 20% the size of a function call. Making jumps free reopens+  -- bug #6048, but making them any more expensive loses a 21% improvement in+  -- spectral/puzzle. TODO Perhaps adjusting the default threshold would be a+  -- better solution?++funSize :: DynFlags -> [Id] -> Id -> Int -> Int -> ExprSize+-- Size for functions that are not constructors or primops+-- Note [Function applications]+funSize dflags top_args fun n_val_args voids+  | fun `hasKey` buildIdKey   = buildSize+  | fun `hasKey` augmentIdKey = augmentSize+  | otherwise = SizeIs size arg_discount res_discount+  where+    some_val_args = n_val_args > 0+    is_join = isJoinId fun++    size | is_join              = jumpSize n_val_args voids+         | not some_val_args    = 0+         | otherwise            = callSize n_val_args voids++        --                  DISCOUNTS+        --  See Note [Function and non-function discounts]+    arg_discount | some_val_args && fun `elem` top_args+                 = unitBag (fun, ufFunAppDiscount dflags)+                 | otherwise = emptyBag+        -- If the function is an argument and is applied+        -- to some values, give it an arg-discount++    res_discount | idArity fun > n_val_args = ufFunAppDiscount dflags+                 | otherwise                = 0+        -- If the function is partially applied, show a result discount+-- XXX maybe behave like ConSize for eval'd variable++conSize :: DataCon -> Int -> ExprSize+conSize dc n_val_args+  | n_val_args == 0 = SizeIs 0 emptyBag 10    -- Like variables++-- See Note [Unboxed tuple size and result discount]+  | isUnboxedTupleCon dc = SizeIs 0 emptyBag (10 * (1 + n_val_args))++-- See Note [Constructor size and result discount]+  | otherwise = SizeIs 10 emptyBag (10 * (1 + n_val_args))++-- XXX still looks to large to me++{-+Note [Constructor size and result discount]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Treat a constructors application as size 10, regardless of how many+arguments it has; we are keen to expose them (and we charge separately+for their args).  We can't treat them as size zero, else we find that+(Just x) has size 0, which is the same as a lone variable; and hence+'v' will always be replaced by (Just x), where v is bound to Just x.++The "result discount" is applied if the result of the call is+scrutinised (say by a case).  For a constructor application that will+mean the constructor application will disappear, so we don't need to+charge it to the function.  So the discount should at least match the+cost of the constructor application, namely 10.  But to give a bit+of extra incentive we give a discount of 10*(1 + n_val_args).++Simon M tried a MUCH bigger discount: (10 * (10 + n_val_args)),+and said it was an "unambiguous win", but its terribly dangerous+because a function with many many case branches, each finishing with+a constructor, can have an arbitrarily large discount.  This led to+terrible code bloat: see Trac #6099.++Note [Unboxed tuple size and result discount]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+However, unboxed tuples count as size zero. I found occasions where we had+        f x y z = case op# x y z of { s -> (# s, () #) }+and f wasn't getting inlined.++I tried giving unboxed tuples a *result discount* of zero (see the+commented-out line).  Why?  When returned as a result they do not+allocate, so maybe we don't want to charge so much for them If you+have a non-zero discount here, we find that workers often get inlined+back into wrappers, because it look like+    f x = case $wf x of (# a,b #) -> (a,b)+and we are keener because of the case.  However while this change+shrank binary sizes by 0.5% it also made spectral/boyer allocate 5%+more. All other changes were very small. So it's not a big deal but I+didn't adopt the idea.++Note [Function and non-function discounts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want a discount if the function is applied. A good example is+monadic combinators with continuation arguments, where inlining is+quite important.++But we don't want a big discount when a function is called many times+(see the detailed comments with Trac #6048) because if the function is+big it won't be inlined at its many call sites and no benefit results.+Indeed, we can get exponentially big inlinings this way; that is what+Trac #6048 is about.++On the other hand, for data-valued arguments, if there are lots of+case expressions in the body, each one will get smaller if we apply+the function to a constructor application, so we *want* a big discount+if the argument is scrutinised by many case expressions.++Conclusion:+  - For functions, take the max of the discounts+  - For data values, take the sum of the discounts+++Note [Literal integer size]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Literal integers *can* be big (mkInteger [...coefficients...]), but+need not be (S# n).  We just use an arbitrary big-ish constant here+so that, in particular, we don't inline top-level defns like+   n = S# 5+There's no point in doing so -- any optimisations will see the S#+through n's unfolding.  Nor will a big size inhibit unfoldings functions+that mention a literal Integer, because the float-out pass will float+all those constants to top level.+-}++primOpSize :: PrimOp -> Int -> ExprSize+primOpSize op n_val_args+ = if primOpOutOfLine op+      then sizeN (op_size + n_val_args)+      else sizeN op_size+ where+   op_size = primOpCodeSize op+++buildSize :: ExprSize+buildSize = SizeIs 0 emptyBag 40+        -- We really want to inline applications of build+        -- build t (\cn -> e) should cost only the cost of e (because build will be inlined later)+        -- Indeed, we should add a result_discount because build is+        -- very like a constructor.  We don't bother to check that the+        -- build is saturated (it usually is).  The "-2" discounts for the \c n,+        -- The "4" is rather arbitrary.++augmentSize :: ExprSize+augmentSize = SizeIs 0 emptyBag 40+        -- Ditto (augment t (\cn -> e) ys) should cost only the cost of+        -- e plus ys. The -2 accounts for the \cn++-- When we return a lambda, give a discount if it's used (applied)+lamScrutDiscount :: DynFlags -> ExprSize -> ExprSize+lamScrutDiscount dflags (SizeIs n vs _) = SizeIs n vs (ufFunAppDiscount dflags)+lamScrutDiscount _      TooBig          = TooBig++{-+Note [addAltSize result discounts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When adding the size of alternatives, we *add* the result discounts+too, rather than take the *maximum*.  For a multi-branch case, this+gives a discount for each branch that returns a constructor, making us+keener to inline.  I did try using 'max' instead, but it makes nofib+'rewrite' and 'puzzle' allocate significantly more, and didn't make+binary sizes shrink significantly either.++Note [Discounts and thresholds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Constants for discounts and thesholds are defined in main/DynFlags,+all of form ufXxxx.   They are:++ufCreationThreshold+     At a definition site, if the unfolding is bigger than this, we+     may discard it altogether++ufUseThreshold+     At a call site, if the unfolding, less discounts, is smaller than+     this, then it's small enough inline++ufKeenessFactor+     Factor by which the discounts are multiplied before+     subtracting from size++ufDictDiscount+     The discount for each occurrence of a dictionary argument+     as an argument of a class method.  Should be pretty small+     else big functions may get inlined++ufFunAppDiscount+     Discount for a function argument that is applied.  Quite+     large, because if we inline we avoid the higher-order call.++ufDearOp+     The size of a foreign call or not-dupable PrimOp++ufVeryAggressive+     If True, the compiler ignores all the thresholds and inlines very+     aggressively. It still adheres to arity, simplifier phase control and+     loop breakers.+++Note [Function applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a function application (f a b)++  - If 'f' is an argument to the function being analysed,+    and there's at least one value arg, record a FunAppDiscount for f++  - If the application if a PAP (arity > 2 in this example)+    record a *result* discount (because inlining+    with "extra" args in the call may mean that we now+    get a saturated application)++Code for manipulating sizes+-}++-- | The size of an candidate expression for unfolding+data ExprSize+    = TooBig+    | SizeIs { _es_size_is  :: {-# UNPACK #-} !Int -- ^ Size found+             , _es_args     :: !(Bag (Id,Int))+               -- ^ Arguments cased herein, and discount for each such+             , _es_discount :: {-# UNPACK #-} !Int+               -- ^ Size to subtract if result is scrutinised by a case+               -- expression+             }++instance Outputable ExprSize where+  ppr TooBig         = text "TooBig"+  ppr (SizeIs a _ c) = brackets (int a <+> int c)++-- subtract the discount before deciding whether to bale out. eg. we+-- want to inline a large constructor application into a selector:+--      tup = (a_1, ..., a_99)+--      x = case tup of ...+--+mkSizeIs :: Int -> Int -> Bag (Id, Int) -> Int -> ExprSize+mkSizeIs max n xs d | (n - d) > max = TooBig+                    | otherwise     = SizeIs n xs d++maxSize :: ExprSize -> ExprSize -> ExprSize+maxSize TooBig         _                                  = TooBig+maxSize _              TooBig                             = TooBig+maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 > n2   = s1+                                              | otherwise = s2++sizeZero :: ExprSize+sizeN :: Int -> ExprSize++sizeZero = SizeIs 0 emptyBag 0+sizeN n  = SizeIs n emptyBag 0++{-+************************************************************************+*                                                                      *+\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}+*                                                                      *+************************************************************************++We use 'couldBeSmallEnoughToInline' to avoid exporting inlinings that+we ``couldn't possibly use'' on the other side.  Can be overridden w/+flaggery.  Just the same as smallEnoughToInline, except that it has no+actual arguments.+-}++couldBeSmallEnoughToInline :: DynFlags -> Int -> CoreExpr -> Bool+couldBeSmallEnoughToInline dflags threshold rhs+  = case sizeExpr dflags threshold [] body of+       TooBig -> False+       _      -> True+  where+    (_, body) = collectBinders rhs++----------------+smallEnoughToInline :: DynFlags -> Unfolding -> Bool+smallEnoughToInline dflags (CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_size = size}})+  = size <= ufUseThreshold dflags+smallEnoughToInline _ _+  = False++----------------++certainlyWillInline :: DynFlags -> IdInfo -> Maybe Unfolding+-- Sees if the unfolding is pretty certain to inline+-- If so, return a *stable* unfolding for it, that will always inline+certainlyWillInline dflags fn_info+  = case unfoldingInfo fn_info of+      CoreUnfolding { uf_tmpl = e, uf_guidance = g }+        | loop_breaker -> Nothing       -- Won't inline, so try w/w+        | otherwise    -> do_cunf e g   -- Depends on size, so look at that++      DFunUnfolding {} -> Just fn_unf  -- Don't w/w DFuns; it never makes sense+                                       -- to do so, and even if it is currently a+                                       -- loop breaker, it may not be later++      _other_unf       -> Nothing++  where+    loop_breaker = isStrongLoopBreaker (occInfo fn_info)+    fn_unf       = unfoldingInfo fn_info++    do_cunf :: CoreExpr -> UnfoldingGuidance -> Maybe Unfolding+    do_cunf _ UnfNever     = Nothing+    do_cunf _ (UnfWhen {}) = Just (fn_unf { uf_src = InlineStable })+                             -- INLINE functions have UnfWhen++        -- The UnfIfGoodArgs case seems important.  If we w/w small functions+        -- binary sizes go up by 10%!  (This is with SplitObjs.)+        -- I'm not totally sure why.+        -- INLINABLE functions come via this path+        --    See Note [certainlyWillInline: INLINABLE]+    do_cunf expr (UnfIfGoodArgs { ug_size = size, ug_args = args })+      | not (null args)  -- See Note [certainlyWillInline: be careful of thunks]+      , case inlinePragmaSpec (inlinePragInfo fn_info) of+          NoInline -> False -- NOINLINE; do not say certainlyWillInline!+          _        -> True  -- INLINE, INLINABLE, or nothing+      , not (isBottomingSig (strictnessInfo fn_info))+              -- Do not unconditionally inline a bottoming functions even if+              -- it seems smallish. We've carefully lifted it out to top level,+              -- so we don't want to re-inline it.+      , let arity = length args+      , size - (10 * (arity + 1)) <= ufUseThreshold dflags+      = Just (fn_unf { uf_src      = InlineStable+                     , uf_guidance = UnfWhen { ug_arity     = arity+                                             , ug_unsat_ok  = unSaturatedOk+                                             , ug_boring_ok = inlineBoringOk expr } })+             -- Note the "unsaturatedOk". A function like  f = \ab. a+             -- will certainly inline, even if partially applied (f e), so we'd+             -- better make sure that the transformed inlining has the same property+      | otherwise+      = Nothing++{- Note [certainlyWillInline: be careful of thunks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Don't claim that thunks will certainly inline, because that risks work+duplication.  Even if the work duplication is not great (eg is_cheap+holds), it can make a big difference in an inner loop In Trac #5623 we+found that the WorkWrap phase thought that+       y = case x of F# v -> F# (v +# v)+was certainlyWillInline, so the addition got duplicated.++Note [certainlyWillInline: INLINABLE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+certainlyWillInline /must/ return Nothing for a large INLINABLE thing,+even though we have a stable inlining, so that strictness w/w takes+place.  It makes a big difference to efficiency, and the w/w pass knows+how to transfer the INLINABLE info to the worker; see WorkWrap+Note [Worker-wrapper for INLINABLE functions]++************************************************************************+*                                                                      *+\subsection{callSiteInline}+*                                                                      *+************************************************************************++This is the key function.  It decides whether to inline a variable at a call site++callSiteInline is used at call sites, so it is a bit more generous.+It's a very important function that embodies lots of heuristics.+A non-WHNF can be inlined if it doesn't occur inside a lambda,+and occurs exactly once or+    occurs once in each branch of a case and is small++If the thing is in WHNF, there's no danger of duplicating work,+so we can inline if it occurs once, or is small++NOTE: we don't want to inline top-level functions that always diverge.+It just makes the code bigger.  Tt turns out that the convenient way to prevent+them inlining is to give them a NOINLINE pragma, which we do in+StrictAnal.addStrictnessInfoToTopId+-}++callSiteInline :: DynFlags+               -> Id                    -- The Id+               -> Bool                  -- True <=> unfolding is active+               -> Bool                  -- True if there are no arguments at all (incl type args)+               -> [ArgSummary]          -- One for each value arg; True if it is interesting+               -> CallCtxt              -- True <=> continuation is interesting+               -> Maybe CoreExpr        -- Unfolding, if any++data ArgSummary = TrivArg       -- Nothing interesting+                | NonTrivArg    -- Arg has structure+                | ValueArg      -- Arg is a con-app or PAP+                                -- ..or con-like. Note [Conlike is interesting]++instance Outputable ArgSummary where+  ppr TrivArg    = text "TrivArg"+  ppr NonTrivArg = text "NonTrivArg"+  ppr ValueArg   = text "ValueArg"++nonTriv ::  ArgSummary -> Bool+nonTriv TrivArg = False+nonTriv _       = True++data CallCtxt+  = BoringCtxt+  | RhsCtxt             -- Rhs of a let-binding; see Note [RHS of lets]+  | DiscArgCtxt         -- Argument of a function with non-zero arg discount+  | RuleArgCtxt         -- We are somewhere in the argument of a function with rules++  | ValAppCtxt          -- We're applied to at least one value arg+                        -- This arises when we have ((f x |> co) y)+                        -- Then the (f x) has argument 'x' but in a ValAppCtxt++  | CaseCtxt            -- We're the scrutinee of a case+                        -- that decomposes its scrutinee++instance Outputable CallCtxt where+  ppr CaseCtxt    = text "CaseCtxt"+  ppr ValAppCtxt  = text "ValAppCtxt"+  ppr BoringCtxt  = text "BoringCtxt"+  ppr RhsCtxt     = text "RhsCtxt"+  ppr DiscArgCtxt = text "DiscArgCtxt"+  ppr RuleArgCtxt = text "RuleArgCtxt"++callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info+  = case idUnfolding id of+      -- idUnfolding checks for loop-breakers, returning NoUnfolding+      -- Things with an INLINE pragma may have an unfolding *and*+      -- be a loop breaker  (maybe the knot is not yet untied)+        CoreUnfolding { uf_tmpl = unf_template, uf_is_top = is_top+                      , uf_is_work_free = is_wf+                      , uf_guidance = guidance, uf_expandable = is_exp }+          | active_unfolding -> tryUnfolding dflags id lone_variable+                                    arg_infos cont_info unf_template is_top+                                    is_wf is_exp guidance+          | otherwise -> traceInline dflags "Inactive unfolding:" (ppr id) Nothing+        NoUnfolding      -> Nothing+        BootUnfolding    -> Nothing+        OtherCon {}      -> Nothing+        DFunUnfolding {} -> Nothing     -- Never unfold a DFun++traceInline :: DynFlags -> String -> SDoc -> a -> a+traceInline dflags str doc result+ | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags+ = pprTrace str doc result+ | otherwise+ = result++tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt+             -> CoreExpr -> Bool -> Bool -> Bool -> UnfoldingGuidance+             -> Maybe CoreExpr+tryUnfolding dflags id lone_variable+             arg_infos cont_info unf_template is_top+             is_wf is_exp guidance+ = case guidance of+     UnfNever -> traceInline dflags str (text "UnfNever") Nothing++     UnfWhen { ug_arity = uf_arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }+        | enough_args && (boring_ok || some_benefit || ufVeryAggressive dflags)+                -- See Note [INLINE for small functions (3)]+        -> traceInline dflags str (mk_doc some_benefit empty True) (Just unf_template)+        | otherwise+        -> traceInline dflags str (mk_doc some_benefit empty False) Nothing+        where+          some_benefit = calc_some_benefit uf_arity+          enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0)++     UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }+        | ufVeryAggressive dflags+        -> traceInline dflags str (mk_doc some_benefit extra_doc True) (Just unf_template)+        | is_wf && some_benefit && small_enough+        -> traceInline dflags str (mk_doc some_benefit extra_doc True) (Just unf_template)+        | otherwise+        -> traceInline dflags str (mk_doc some_benefit extra_doc False) Nothing+        where+          some_benefit = calc_some_benefit (length arg_discounts)+          extra_doc = text "discounted size =" <+> int discounted_size+          discounted_size = size - discount+          small_enough = discounted_size <= ufUseThreshold dflags+          discount = computeDiscount dflags arg_discounts+                                     res_discount arg_infos cont_info++  where+    mk_doc some_benefit extra_doc yes_or_no+      = vcat [ text "arg infos" <+> ppr arg_infos+             , text "interesting continuation" <+> ppr cont_info+             , text "some_benefit" <+> ppr some_benefit+             , text "is exp:" <+> ppr is_exp+             , text "is work-free:" <+> ppr is_wf+             , text "guidance" <+> ppr guidance+             , extra_doc+             , text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"]++    str = "Considering inlining: " ++ showSDocDump dflags (ppr id)+    n_val_args = length arg_infos++           -- some_benefit is used when the RHS is small enough+           -- and the call has enough (or too many) value+           -- arguments (ie n_val_args >= arity). But there must+           -- be *something* interesting about some argument, or the+           -- result context, to make it worth inlining+    calc_some_benefit :: Arity -> Bool   -- The Arity is the number of args+                                         -- expected by the unfolding+    calc_some_benefit uf_arity+       | not saturated = interesting_args       -- Under-saturated+                                        -- Note [Unsaturated applications]+       | otherwise = interesting_args   -- Saturated or over-saturated+                  || interesting_call+      where+        saturated      = n_val_args >= uf_arity+        over_saturated = n_val_args > uf_arity+        interesting_args = any nonTriv arg_infos+                -- NB: (any nonTriv arg_infos) looks at the+                -- over-saturated args too which is "wrong";+                -- but if over-saturated we inline anyway.++        interesting_call+          | over_saturated+          = True+          | otherwise+          = case cont_info of+              CaseCtxt   -> not (lone_variable && is_wf)  -- Note [Lone variables]+              ValAppCtxt -> True                              -- Note [Cast then apply]+              RuleArgCtxt -> uf_arity > 0  -- See Note [Unfold info lazy contexts]+              DiscArgCtxt -> uf_arity > 0  --+              RhsCtxt     -> uf_arity > 0  --+              _           -> not is_top && uf_arity > 0   -- Note [Nested functions]+                                                      -- Note [Inlining in ArgCtxt]++{-+Note [Unfold into lazy contexts], Note [RHS of lets]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When the call is the argument of a function with a RULE, or the RHS of a let,+we are a little bit keener to inline.  For example+     f y = (y,y,y)+     g y = let x = f y in ...(case x of (a,b,c) -> ...) ...+We'd inline 'f' if the call was in a case context, and it kind-of-is,+only we can't see it.  Also+     x = f v+could be expensive whereas+     x = case v of (a,b) -> a+is patently cheap and may allow more eta expansion.+So we treat the RHS of a let as not-totally-boring.++Note [Unsaturated applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When a call is not saturated, we *still* inline if one of the+arguments has interesting structure.  That's sometimes very important.+A good example is the Ord instance for Bool in Base:++ Rec {+    $fOrdBool =GHC.Classes.D:Ord+                 @ Bool+                 ...+                 $cmin_ajX++    $cmin_ajX [Occ=LoopBreaker] :: Bool -> Bool -> Bool+    $cmin_ajX = GHC.Classes.$dmmin @ Bool $fOrdBool+  }++But the defn of GHC.Classes.$dmmin is:++  $dmmin :: forall a. GHC.Classes.Ord a => a -> a -> a+    {- Arity: 3, HasNoCafRefs, Strictness: SLL,+       Unfolding: (\ @ a $dOrd :: GHC.Classes.Ord a x :: a y :: a ->+                   case @ a GHC.Classes.<= @ a $dOrd x y of wild {+                     GHC.Types.False -> y GHC.Types.True -> x }) -}++We *really* want to inline $dmmin, even though it has arity 3, in+order to unravel the recursion.+++Note [Things to watch]+~~~~~~~~~~~~~~~~~~~~~~+*   { y = I# 3; x = y `cast` co; ...case (x `cast` co) of ... }+    Assume x is exported, so not inlined unconditionally.+    Then we want x to inline unconditionally; no reason for it+    not to, and doing so avoids an indirection.++*   { x = I# 3; ....f x.... }+    Make sure that x does not inline unconditionally!+    Lest we get extra allocation.++Note [Inlining an InlineRule]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+An InlineRules is used for+  (a) programmer INLINE pragmas+  (b) inlinings from worker/wrapper++For (a) the RHS may be large, and our contract is that we *only* inline+when the function is applied to all the arguments on the LHS of the+source-code defn.  (The uf_arity in the rule.)++However for worker/wrapper it may be worth inlining even if the+arity is not satisfied (as we do in the CoreUnfolding case) so we don't+require saturation.+++Note [Nested functions]+~~~~~~~~~~~~~~~~~~~~~~~+If a function has a nested defn we also record some-benefit, on the+grounds that we are often able to eliminate the binding, and hence the+allocation, for the function altogether; this is good for join points.+But this only makes sense for *functions*; inlining a constructor+doesn't help allocation unless the result is scrutinised.  UNLESS the+constructor occurs just once, albeit possibly in multiple case+branches.  Then inlining it doesn't increase allocation, but it does+increase the chance that the constructor won't be allocated at all in+the branches that don't use it.++Note [Cast then apply]+~~~~~~~~~~~~~~~~~~~~~~+Consider+   myIndex = __inline_me ( (/\a. <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 the+context can ``see'' the unfolding of the variable (e.g. case or a+RULE) so there's no gain.  If the thing is bound to a value.++However, watch out:++ * Consider this:+        foo = _inline_ (\n. [n])+        bar = _inline_ (foo 20)+        baz = \n. case bar of { (m:_) -> m + n }+   Here we really want to inline 'bar' so that we can inline 'foo'+   and the whole thing unravels as it should obviously do.  This is+   important: in the NDP project, 'bar' generates a closure data+   structure rather than a list.++   So the non-inlining of lone_variables should only apply if the+   unfolding is regarded as cheap; because that is when exprIsConApp_maybe+   looks through the unfolding.  Hence the "&& is_wf" in the+   InlineRule branch.++ * Even a type application or coercion isn't a lone variable.+   Consider+        case $fMonadST @ RealWorld of { :DMonad a b c -> c }+   We had better inline that sucker!  The case won't see through it.++   For now, I'm treating treating a variable applied to types+   in a *lazy* context "lone". The motivating example was+        f = /\a. \x. BIG+        g = /\a. \y.  h (f a)+   There's no advantage in inlining f here, and perhaps+   a significant disadvantage.  Hence some_val_args in the Stop case++Note [Interaction of exprIsWorkFree and lone variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The lone-variable test says "don't inline if a case expression+scrutinises a lone variable whose unfolding is cheap".  It's very+important that, under these circumstances, exprIsConApp_maybe+can spot a constructor application. So, for example, we don't+consider+        let x = e in (x,x)+to be cheap, and that's good because exprIsConApp_maybe doesn't+think that expression is a constructor application.++In the 'not (lone_variable && is_wf)' test, I used to test is_value+rather than is_wf, which was utterly wrong, because the above+expression responds True to exprIsHNF, which is what sets is_value.++This kind of thing can occur if you have++        {-# INLINE foo #-}+        foo = let x = e in (x,x)++which Roman did.+-}++computeDiscount :: DynFlags -> [Int] -> Int -> [ArgSummary] -> CallCtxt+                -> Int+computeDiscount dflags arg_discounts res_discount arg_infos cont_info+        -- We multiple the raw discounts (args_discount and result_discount)+        -- ty opt_UnfoldingKeenessFactor because the former have to do with+        --  *size* whereas the discounts imply that there's some extra+        --  *efficiency* to be gained (e.g. beta reductions, case reductions)+        -- by inlining.++  = 10          -- Discount of 10 because the result replaces the call+                -- so we count 10 for the function itself++    + 10 * length actual_arg_discounts+               -- Discount of 10 for each arg supplied,+               -- because the result replaces the call++    + round (ufKeenessFactor dflags *+             fromIntegral (total_arg_discount + res_discount'))+  where+    actual_arg_discounts = zipWith mk_arg_discount arg_discounts arg_infos+    total_arg_discount   = sum actual_arg_discounts++    mk_arg_discount _        TrivArg    = 0+    mk_arg_discount _        NonTrivArg = 10+    mk_arg_discount discount ValueArg   = discount++    res_discount'+      | LT <- arg_discounts `compareLength` arg_infos+      = res_discount   -- Over-saturated+      | otherwise+      = case cont_info of+                        BoringCtxt  -> 0+                        CaseCtxt    -> res_discount  -- Presumably a constructor+                        ValAppCtxt  -> res_discount  -- Presumably a function+                        _           -> 40 `min` res_discount+                -- ToDo: this 40 `min` res_discount doesn't seem right+                --   for DiscArgCtxt it shouldn't matter because the function will+                --    get the arg discount for any non-triv arg+                --   for RuleArgCtxt we do want to be keener to inline; but not only+                --    constructor results+                --   for RhsCtxt I suppose that exposing a data con is good in general+                --   And 40 seems very arbitrary+                --+                -- res_discount can be very large when a function returns+                -- constructors; but we only want to invoke that large discount+                -- when there's a case continuation.+                -- Otherwise we, rather arbitrarily, threshold it.  Yuk.+                -- But we want to aovid inlining large functions that return+                -- constructors into contexts that are simply "interesting"
+ coreSyn/CoreUtils.hs view
@@ -0,0 +1,2329 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Utility functions on @Core@ syntax+-}++{-# LANGUAGE CPP #-}++-- | Commonly useful utilites for manipulating the Core language+module CoreUtils (+        -- * Constructing expressions+        mkCast,+        mkTick, mkTicks, mkTickNoHNF, tickHNFArgs,+        bindNonRec, needsCaseBinding,+        mkAltExpr,++        -- * Taking expressions apart+        findDefault, addDefault, findAlt, isDefaultAlt,+        mergeAlts, trimConArgs,+        filterAlts, combineIdenticalAlts, refineDefaultAlt,++        -- * Properties of expressions+        exprType, coreAltType, coreAltsType, isExprLevPoly,+        exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom,+        getIdFromTrivialExpr_maybe,+        exprIsCheap, exprIsExpandable, exprIsOk, CheapAppFun,+        exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree,+        exprIsBig, exprIsConLike,+        rhsIsStatic, isCheapApp, isExpandableApp,+        exprIsLiteralString, exprIsTopLevelBindable,++        -- * Equality+        cheapEqExpr, cheapEqExpr', eqExpr,+        diffExpr, diffBinds,++        -- * Eta reduction+        tryEtaReduce,++        -- * Manipulating data constructors and types+        exprToType, exprToCoercion_maybe,+        applyTypeToArgs, applyTypeToArg,+        dataConRepInstPat, dataConRepFSInstPat,+        isEmptyTy,++        -- * Working with ticks+        stripTicksTop, stripTicksTopE, stripTicksTopT,+        stripTicksE, stripTicksT,++        -- * StaticPtr+        collectMakeStaticArgs,++        -- * Join points+        isJoinBind+    ) where++#include "HsVersions.h"++import CoreSyn+import PrelNames ( makeStaticName )+import PprCore+import CoreFVs( exprFreeVars )+import Var+import SrcLoc+import VarEnv+import VarSet+import Name+import Literal+import DataCon+import PrimOp+import Id+import IdInfo+import Type+import TyCoRep( TyBinder(..) )+import Coercion+import TyCon+import Unique+import Outputable+import TysPrim+import DynFlags+import FastString+import Maybes+import ListSetOps       ( minusList )+import BasicTypes       ( Arity )+import Platform+import Util+import Pair+import Data.Function       ( on )+import Data.List+import Data.Ord            ( comparing )+import OrdList++{-+************************************************************************+*                                                                      *+\subsection{Find the type of a Core atom/expression}+*                                                                      *+************************************************************************+-}++exprType :: CoreExpr -> Type+-- ^ Recover the type of a well-typed Core expression. Fails when+-- applied to the actual 'CoreSyn.Type' expression as it cannot+-- really be said to have a type+exprType (Var var)           = idType var+exprType (Lit lit)           = literalType lit+exprType (Coercion co)       = coercionType co+exprType (Let bind body)+  | NonRec tv rhs <- bind    -- See Note [Type bindings]+  , Type ty <- rhs           = substTyWithUnchecked [tv] [ty] (exprType body)+  | otherwise                = exprType body+exprType (Case _ _ ty _)     = ty+exprType (Cast _ co)         = pSnd (coercionKind co)+exprType (Tick _ e)          = exprType e+exprType (Lam binder expr)   = mkLamType binder (exprType expr)+exprType e@(App _ _)+  = case collectArgs e of+        (fun, args) -> applyTypeToArgs e (exprType fun) args++exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy++coreAltType :: CoreAlt -> Type+-- ^ Returns the type of the alternatives right hand side+coreAltType (_,bs,rhs)+  | any bad_binder bs = expandTypeSynonyms ty+  | otherwise         = ty    -- Note [Existential variables and silly type synonyms]+  where+    ty           = exprType rhs+    free_tvs     = tyCoVarsOfType ty+    bad_binder b = b `elemVarSet` free_tvs++coreAltsType :: [CoreAlt] -> Type+-- ^ Returns the type of the first alternative, which should be the same as for all alternatives+coreAltsType (alt:_) = coreAltType alt+coreAltsType []      = panic "corAltsType"++-- | Is this expression levity polymorphic? This should be the+-- same as saying (isKindLevPoly . typeKind . exprType) but+-- much faster.+isExprLevPoly :: CoreExpr -> Bool+isExprLevPoly = go+  where+   go (Var _)                      = False  -- no levity-polymorphic binders+   go (Lit _)                      = False  -- no levity-polymorphic literals+   go e@(App f _) | not (go_app f) = False+                  | otherwise      = check_type e+   go (Lam _ _)                    = False+   go (Let _ e)                    = go e+   go e@(Case {})                  = check_type e -- checking type is fast+   go e@(Cast {})                  = check_type e+   go (Tick _ e)                   = go e+   go e@(Type {})                  = pprPanic "isExprLevPoly ty" (ppr e)+   go (Coercion {})                = False  -- this case can happen in SetLevels++   check_type = isTypeLevPoly . exprType  -- slow approach++      -- if the function is a variable (common case), check its+      -- levityInfo. This might mean we don't need to look up and compute+      -- on the type. Spec of these functions: return False if there is+      -- no possibility, ever, of this expression becoming levity polymorphic,+      -- no matter what it's applied to; return True otherwise.+      -- returning True is always safe. See also Note [Levity info] in+      -- IdInfo+   go_app (Var id)        = not (isNeverLevPolyId id)+   go_app (Lit _)         = False+   go_app (App f _)       = go_app f+   go_app (Lam _ e)       = go_app e+   go_app (Let _ e)       = go_app e+   go_app (Case _ _ ty _) = resultIsLevPoly ty+   go_app (Cast _ co)     = resultIsLevPoly (pSnd $ coercionKind co)+   go_app (Tick _ e)      = go_app e+   go_app e@(Type {})     = pprPanic "isExprLevPoly app ty" (ppr e)+   go_app e@(Coercion {}) = pprPanic "isExprLevPoly app co" (ppr e)+++{-+Note [Type bindings]+~~~~~~~~~~~~~~~~~~~~+Core does allow type bindings, although such bindings are+not much used, except in the output of the desuguarer.+Example:+     let a = Int in (\x:a. x)+Given this, exprType must be careful to substitute 'a' in the+result type (Trac #8522).++Note [Existential variables and silly type synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+        data T = forall a. T (Funny a)+        type Funny a = Bool+        f :: T -> Bool+        f (T x) = x++Now, the type of 'x' is (Funny a), where 'a' is existentially quantified.+That means that 'exprType' and 'coreAltsType' may give a result that *appears*+to mention an out-of-scope type variable.  See Trac #3409 for a more real-world+example.++Various possibilities suggest themselves:++ - Ignore the problem, and make Lint not complain about such variables++ - Expand all type synonyms (or at least all those that discard arguments)+      This is tricky, because at least for top-level things we want to+      retain the type the user originally specified.++ - Expand synonyms on the fly, when the problem arises. That is what+   we are doing here.  It's not too expensive, I think.++Note that there might be existentially quantified coercion variables, too.+-}++-- Not defined with applyTypeToArg because you can't print from CoreSyn.+applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type+-- ^ A more efficient version of 'applyTypeToArg' when we have several arguments.+-- The first argument is just for debugging, and gives some context+applyTypeToArgs e op_ty args+  = go op_ty args+  where+    go op_ty []                   = op_ty+    go op_ty (Type ty : args)     = go_ty_args op_ty [ty] args+    go op_ty (Coercion co : args) = go_ty_args op_ty [mkCoercionTy co] args+    go op_ty (_ : args)           | Just (_, res_ty) <- splitFunTy_maybe op_ty+                                  = go res_ty args+    go _ _ = pprPanic "applyTypeToArgs" panic_msg++    -- go_ty_args: accumulate type arguments so we can+    -- instantiate all at once with piResultTys+    go_ty_args op_ty rev_tys (Type ty : args)+       = go_ty_args op_ty (ty:rev_tys) args+    go_ty_args op_ty rev_tys (Coercion co : args)+       = go_ty_args op_ty (mkCoercionTy co : rev_tys) args+    go_ty_args op_ty rev_tys args+       = go (piResultTys op_ty (reverse rev_tys)) args++    panic_msg = vcat [ text "Expression:" <+> pprCoreExpr e+                     , text "Type:" <+> ppr op_ty+                     , text "Args:" <+> ppr args ]+++{-+************************************************************************+*                                                                      *+\subsection{Attaching notes}+*                                                                      *+************************************************************************+-}++-- | Wrap the given expression in the coercion safely, dropping+-- identity coercions and coalescing nested coercions+mkCast :: CoreExpr -> Coercion -> CoreExpr+mkCast e co+  | ASSERT2( coercionRole co == Representational+           , text "coercion" <+> ppr co <+> ptext (sLit "passed to mkCast")+             <+> ppr e <+> text "has wrong role" <+> ppr (coercionRole co) )+    isReflCo co+  = e++mkCast (Coercion e_co) co+  | isCoercionType (pSnd (coercionKind co))+       -- The guard here checks that g has a (~#) on both sides,+       -- otherwise decomposeCo fails.  Can in principle happen+       -- with unsafeCoerce+  = Coercion (mkCoCast e_co co)++mkCast (Cast expr co2) co+  = WARN(let { Pair  from_ty  _to_ty  = coercionKind co;+               Pair _from_ty2  to_ty2 = coercionKind co2} in+            not (from_ty `eqType` to_ty2),+             vcat ([ text "expr:" <+> ppr expr+                   , text "co2:" <+> ppr co2+                   , text "co:" <+> ppr co ]) )+    mkCast expr (mkTransCo co2 co)++mkCast (Tick t expr) co+   = Tick t (mkCast expr co)++mkCast expr co+  = let Pair from_ty _to_ty = coercionKind co in+    WARN( not (from_ty `eqType` exprType expr),+          text "Trying to coerce" <+> text "(" <> ppr expr+          $$ text "::" <+> ppr (exprType expr) <> text ")"+          $$ ppr co $$ ppr (coercionType co) )+    (Cast expr co)++-- | Wraps the given expression in the source annotation, dropping the+-- annotation if possible.+mkTick :: Tickish Id -> CoreExpr -> CoreExpr+mkTick t orig_expr = mkTick' id id orig_expr+ where+  -- Some ticks (cost-centres) can be split in two, with the+  -- non-counting part having laxer placement properties.+  canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t++  mkTick' :: (CoreExpr -> CoreExpr) -- ^ apply after adding tick (float through)+          -> (CoreExpr -> CoreExpr) -- ^ apply before adding tick (float with)+          -> CoreExpr               -- ^ current expression+          -> CoreExpr+  mkTick' top rest expr = case expr of++    -- Never tick primitive string literals. These should ultimately float up to+    -- the top-level where they must be unadorned. See Note+    -- [CoreSyn top-level string literals] for details.+    _ | exprIsLiteralString expr          -> expr++    -- Cost centre ticks should never be reordered relative to each+    -- other. Therefore we can stop whenever two collide.+    Tick t2 e+      | ProfNote{} <- t2, ProfNote{} <- t -> top $ Tick t $ rest expr++    -- Otherwise we assume that ticks of different placements float+    -- through each other.+      | tickishPlace t2 /= tickishPlace t -> mkTick' (top . Tick t2) rest e++    -- For annotations this is where we make sure to not introduce+    -- redundant ticks.+      | tickishContains t t2              -> mkTick' top rest e+      | tickishContains t2 t              -> orig_expr+      | otherwise                         -> mkTick' top (rest . Tick t2) e++    -- Ticks don't care about types, so we just float all ticks+    -- through them. Note that it's not enough to check for these+    -- cases top-level. While mkTick will never produce Core with type+    -- expressions below ticks, such constructs can be the result of+    -- unfoldings. We therefore make an effort to put everything into+    -- the right place no matter what we start with.+    Cast e co   -> mkTick' (top . flip Cast co) rest e+    Coercion co -> Coercion co++    Lam x e+      -- Always float through type lambdas. Even for non-type lambdas,+      -- floating is allowed for all but the most strict placement rule.+      | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime+      -> mkTick' (top . Lam x) rest e++      -- If it is both counting and scoped, we split the tick into its+      -- two components, often allowing us to keep the counting tick on+      -- the outside of the lambda and push the scoped tick inside.+      -- The point of this is that the counting tick can probably be+      -- floated, and the lambda may then be in a position to be+      -- beta-reduced.+      | canSplit+      -> top $ Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e++    App f arg+      -- Always float through type applications.+      | not (isRuntimeArg arg)+      -> mkTick' (top . flip App arg) rest f++      -- We can also float through constructor applications, placement+      -- permitting. Again we can split.+      | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit)+      -> if tickishPlace t == PlaceCostCentre+         then top $ rest $ tickHNFArgs t expr+         else top $ Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr++    Var x+      | notFunction && tickishPlace t == PlaceCostCentre+      -> orig_expr+      | notFunction && canSplit+      -> top $ Tick (mkNoScope t) $ rest expr+      where+        -- SCCs can be eliminated on variables provided the variable+        -- is not a function.  In these cases the SCC makes no difference:+        -- the cost of evaluating the variable will be attributed to its+        -- definition site.  When the variable refers to a function, however,+        -- an SCC annotation on the variable affects the cost-centre stack+        -- when the function is called, so we must retain those.+        notFunction = not (isFunTy (idType x))++    Lit{}+      | tickishPlace t == PlaceCostCentre+      -> orig_expr++    -- Catch-all: Annotate where we stand+    _any -> top $ Tick t $ rest expr++mkTicks :: [Tickish Id] -> CoreExpr -> CoreExpr+mkTicks ticks expr = foldr mkTick expr ticks++isSaturatedConApp :: CoreExpr -> Bool+isSaturatedConApp e = go e []+  where go (App f a) as = go f (a:as)+        go (Var fun) args+           = isConLikeId fun && idArity fun == valArgCount args+        go (Cast f _) as = go f as+        go _ _ = False++mkTickNoHNF :: Tickish Id -> CoreExpr -> CoreExpr+mkTickNoHNF t e+  | exprIsHNF e = tickHNFArgs t e+  | otherwise   = mkTick t e++-- push a tick into the arguments of a HNF (call or constructor app)+tickHNFArgs :: Tickish Id -> CoreExpr -> CoreExpr+tickHNFArgs t e = push t e+ where+  push t (App f (Type u)) = App (push t f) (Type u)+  push t (App f arg) = App (push t f) (mkTick t arg)+  push _t e = e++-- | Strip ticks satisfying a predicate from top of an expression+stripTicksTop :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b)+stripTicksTop p = go []+  where go ts (Tick t e) | p t = go (t:ts) e+        go ts other            = (reverse ts, other)++-- | Strip ticks satisfying a predicate from top of an expression,+-- returning the remaining expression+stripTicksTopE :: (Tickish Id -> Bool) -> Expr b -> Expr b+stripTicksTopE p = go+  where go (Tick t e) | p t = go e+        go other            = other++-- | Strip ticks satisfying a predicate from top of an expression,+-- returning the ticks+stripTicksTopT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id]+stripTicksTopT p = go []+  where go ts (Tick t e) | p t = go (t:ts) e+        go ts _                = ts++-- | Completely strip ticks satisfying a predicate from an+-- expression. Note this is O(n) in the size of the expression!+stripTicksE :: (Tickish Id -> Bool) -> Expr b -> Expr b+stripTicksE p expr = go expr+  where go (App e a)        = App (go e) (go a)+        go (Lam b e)        = Lam b (go e)+        go (Let b e)        = Let (go_bs b) (go e)+        go (Case e b t as)  = Case (go e) b t (map go_a as)+        go (Cast e c)       = Cast (go e) c+        go (Tick t e)+          | p t             = go e+          | otherwise       = Tick t (go e)+        go other            = other+        go_bs (NonRec b e)  = NonRec b (go e)+        go_bs (Rec bs)      = Rec (map go_b bs)+        go_b (b, e)         = (b, go e)+        go_a (c,bs,e)       = (c,bs, go e)++stripTicksT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id]+stripTicksT p expr = fromOL $ go expr+  where go (App e a)        = go e `appOL` go a+        go (Lam _ e)        = go e+        go (Let b e)        = go_bs b `appOL` go e+        go (Case e _ _ as)  = go e `appOL` concatOL (map go_a as)+        go (Cast e _)       = go e+        go (Tick t e)+          | p t             = t `consOL` go e+          | otherwise       = go e+        go _                = nilOL+        go_bs (NonRec _ e)  = go e+        go_bs (Rec bs)      = concatOL (map go_b bs)+        go_b (_, e)         = go e+        go_a (_, _, e)      = go e++{-+************************************************************************+*                                                                      *+\subsection{Other expression construction}+*                                                                      *+************************************************************************+-}++bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr+-- ^ @bindNonRec x r b@ produces either:+--+-- > let x = r in b+--+-- or:+--+-- > case r of x { _DEFAULT_ -> b }+--+-- depending on whether we have to use a @case@ or @let@+-- binding for the expression (see 'needsCaseBinding').+-- It's used by the desugarer to avoid building bindings+-- that give Core Lint a heart attack, although actually+-- the simplifier deals with them perfectly well. See+-- also 'MkCore.mkCoreLet'+bindNonRec bndr rhs body+  | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT, [], body)]+  | otherwise                          = Let (NonRec bndr rhs) body++-- | Tests whether we have to use a @case@ rather than @let@ binding for this expression+-- as per the invariants of 'CoreExpr': see "CoreSyn#let_app_invariant"+needsCaseBinding :: Type -> CoreExpr -> Bool+needsCaseBinding ty rhs = isUnliftedType ty && not (exprOkForSpeculation rhs)+        -- Make a case expression instead of a let+        -- These can arise either from the desugarer,+        -- or from beta reductions: (\x.e) (x +# y)++mkAltExpr :: AltCon     -- ^ Case alternative constructor+          -> [CoreBndr] -- ^ Things bound by the pattern match+          -> [Type]     -- ^ The type arguments to the case alternative+          -> CoreExpr+-- ^ This guy constructs the value that the scrutinee must have+-- given that you are in one particular branch of a case+mkAltExpr (DataAlt con) args inst_tys+  = mkConApp con (map Type inst_tys ++ varsToCoreExprs args)+mkAltExpr (LitAlt lit) [] []+  = Lit lit+mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt"+mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"++{-+************************************************************************+*                                                                      *+               Operations oer case alternatives+*                                                                      *+************************************************************************++The default alternative must be first, if it exists at all.+This makes it easy to find, though it makes matching marginally harder.+-}++-- | Extract the default case alternative+findDefault :: [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b)+findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)+findDefault alts                        =                     (alts, Nothing)++addDefault :: [(AltCon, [a], b)] -> Maybe b -> [(AltCon, [a], b)]+addDefault alts Nothing    = alts+addDefault alts (Just rhs) = (DEFAULT, [], rhs) : alts++isDefaultAlt :: (AltCon, a, b) -> Bool+isDefaultAlt (DEFAULT, _, _) = True+isDefaultAlt _               = False++-- | Find the case alternative corresponding to a particular+-- constructor: panics if no such constructor exists+findAlt :: AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b)+    -- A "Nothing" result *is* legitmiate+    -- See Note [Unreachable code]+findAlt con alts+  = case alts of+        (deflt@(DEFAULT,_,_):alts) -> go alts (Just deflt)+        _                          -> go alts Nothing+  where+    go []                     deflt = deflt+    go (alt@(con1,_,_) : alts) deflt+      = case con `cmpAltCon` con1 of+          LT -> deflt   -- Missed it already; the alts are in increasing order+          EQ -> Just alt+          GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt++{- Note [Unreachable code]+~~~~~~~~~~~~~~~~~~~~~~~~~~+It is possible (although unusual) for GHC to find a case expression+that cannot match.  For example:++     data Col = Red | Green | Blue+     x = Red+     f v = case x of+              Red -> ...+              _ -> ...(case x of { Green -> e1; Blue -> e2 })...++Suppose that for some silly reason, x isn't substituted in the case+expression.  (Perhaps there's a NOINLINE on it, or profiling SCC stuff+gets in the way; cf Trac #3118.)  Then the full-lazines pass might produce+this++     x = Red+     lvl = case x of { Green -> e1; Blue -> e2 })+     f v = case x of+             Red -> ...+             _ -> ...lvl...++Now if x gets inlined, we won't be able to find a matching alternative+for 'Red'.  That's because 'lvl' is unreachable.  So rather than crashing+we generate (error "Inaccessible alternative").++Similar things can happen (augmented by GADTs) when the Simplifier+filters down the matching alternatives in Simplify.rebuildCase.+-}++---------------------------------+mergeAlts :: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]+-- ^ Merge alternatives preserving order; alternatives in+-- the first argument shadow ones in the second+mergeAlts [] as2 = as2+mergeAlts as1 [] = as1+mergeAlts (a1:as1) (a2:as2)+  = case a1 `cmpAlt` a2 of+        LT -> a1 : mergeAlts as1      (a2:as2)+        EQ -> a1 : mergeAlts as1      as2       -- Discard a2+        GT -> a2 : mergeAlts (a1:as1) as2+++---------------------------------+trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]+-- ^ Given:+--+-- > case (C a b x y) of+-- >        C b x y -> ...+--+-- We want to drop the leading type argument of the scrutinee+-- leaving the arguments to match against the pattern++trimConArgs DEFAULT      args = ASSERT( null args ) []+trimConArgs (LitAlt _)   args = ASSERT( null args ) []+trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args++filterAlts :: TyCon                -- ^ Type constructor of scrutinee's type (used to prune possibilities)+           -> [Type]               -- ^ And its type arguments+           -> [AltCon]             -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee+           -> [(AltCon, [Var], a)] -- ^ Alternatives+           -> ([AltCon], [(AltCon, [Var], a)])+             -- Returns:+             --  1. Constructors that will never be encountered by the+             --     *default* case (if any).  A superset of imposs_cons+             --  2. The new alternatives, trimmed by+             --        a) remove imposs_cons+             --        b) remove constructors which can't match because of GADTs+             --      and with the DEFAULT expanded to a DataAlt if there is exactly+             --      remaining constructor that can match+             --+             -- NB: the final list of alternatives may be empty:+             -- This is a tricky corner case.  If the data type has no constructors,+             -- which GHC allows, or if the imposs_cons covers all constructors (after taking+             -- account of GADTs), then no alternatives can match.+             --+             -- If callers need to preserve the invariant that there is always at least one branch+             -- in a "case" statement then they will need to manually add a dummy case branch that just+             -- calls "error" or similar.+filterAlts _tycon inst_tys imposs_cons alts+  = (imposs_deflt_cons, addDefault trimmed_alts maybe_deflt)+  where+    (alts_wo_default, maybe_deflt) = findDefault alts+    alt_cons = [con | (con,_,_) <- alts_wo_default]++    trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default++    imposs_deflt_cons = nub (imposs_cons ++ alt_cons)+         -- "imposs_deflt_cons" are handled+         --   EITHER by the context,+         --   OR by a non-DEFAULT branch in this case expression.++    impossible_alt :: [Type] -> (AltCon, a, b) -> Bool+    impossible_alt _ (con, _, _) | con `elem` imposs_cons = True+    impossible_alt inst_tys (DataAlt con, _, _) = dataConCannotMatch inst_tys con+    impossible_alt _  _                         = False++refineDefaultAlt :: [Unique] -> TyCon -> [Type]+                 -> [AltCon]  -- Constructors that cannot match the DEFAULT (if any)+                 -> [CoreAlt]+                 -> (Bool, [CoreAlt])+-- Refine the default alternative to a DataAlt,+-- if there is a unique way to do so+refineDefaultAlt us tycon tys imposs_deflt_cons all_alts+  | (DEFAULT,_,rhs) : rest_alts <- all_alts+  , isAlgTyCon tycon            -- It's a data type, tuple, or unboxed tuples.+  , not (isNewTyCon tycon)      -- We can have a newtype, if we are just doing an eval:+                                --      case x of { DEFAULT -> e }+                                -- and we don't want to fill in a default for them!+  , Just all_cons <- tyConDataCons_maybe tycon+  , let imposs_data_cons = [con | DataAlt con <- imposs_deflt_cons]   -- We now know it's a data type+        impossible con   = con `elem` imposs_data_cons || dataConCannotMatch tys con+  = case filterOut impossible all_cons of+       -- Eliminate the default alternative+       -- altogether if it can't match:+       []    -> (False, rest_alts)++       -- It matches exactly one constructor, so fill it in:+       [con] -> (True, mergeAlts rest_alts [(DataAlt con, ex_tvs ++ arg_ids, rhs)])+                       -- We need the mergeAlts to keep the alternatives in the right order+             where+                (ex_tvs, arg_ids) = dataConRepInstPat us con tys++       -- It matches more than one, so do nothing+       _  -> (False, all_alts)++  | debugIsOn, isAlgTyCon tycon, null (tyConDataCons tycon)+  , not (isFamilyTyCon tycon || isAbstractTyCon tycon)+        -- Check for no data constructors+        -- This can legitimately happen for abstract types and type families,+        -- so don't report that+  = (False, all_alts)++  | otherwise      -- The common case+  = (False, all_alts)++{- Note [Combine identical alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If several alternatives are identical, merge them into a single+DEFAULT alternative.  I've occasionally seen this making a big+difference:++     case e of               =====>     case e of+       C _ -> f x                         D v -> ....v....+       D v -> ....v....                   DEFAULT -> f x+       DEFAULT -> f x++The point is that we merge common RHSs, at least for the DEFAULT case.+[One could do something more elaborate but I've never seen it needed.]+To avoid an expensive test, we just merge branches equal to the *first*+alternative; this picks up the common cases+     a) all branches equal+     b) some branches equal to the DEFAULT (which occurs first)++The case where Combine Identical Alternatives transformation showed up+was like this (base/Foreign/C/Err/Error.hs):++        x | p `is` 1 -> e1+          | p `is` 2 -> e2+        ...etc...++where @is@ was something like++        p `is` n = p /= (-1) && p == n++This gave rise to a horrible sequence of cases++        case p of+          (-1) -> $j p+          1    -> e1+          DEFAULT -> $j p++and similarly in cascade for all the join points!++NB: it's important that all this is done in [InAlt], *before* we work+on the alternatives themselves, because Simpify.simplAlt may zap the+occurrence info on the binders in the alternatives, which in turn+defeats combineIdenticalAlts (see Trac #7360).++Note [Care with impossible-constructors when combining alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have (Trac #10538)+   data T = A | B | C | D++      case x::T of   (Imposs-default-cons {A,B})+         DEFAULT -> e1+         A -> e2+         B -> e1++When calling combineIdentialAlts, we'll have computed that the+"impossible constructors" for the DEFAULT alt is {A,B}, since if x is+A or B we'll take the other alternatives.  But suppose we combine B+into the DEFAULT, to get++      case x::T of   (Imposs-default-cons {A})+         DEFAULT -> e1+         A -> e2++Then we must be careful to trim the impossible constructors to just {A},+else we risk compiling 'e1' wrong!++Not only that, but we take care when there is no DEFAULT beforehand,+because we are introducing one.  Consider++   case x of   (Imposs-default-cons {A,B,C})+     A -> e1+     B -> e2+     C -> e1++Then when combining the A and C alternatives we get++   case x of   (Imposs-default-cons {B})+     DEFAULT -> e1+     B -> e2++Note that we have a new DEFAULT branch that we didn't have before.  So+we need delete from the "impossible-default-constructors" all the+known-con alternatives that we have eliminated. (In Trac #11172 we+missed the first one.)++-}++combineIdenticalAlts :: [AltCon]    -- Constructors that cannot match DEFAULT+                     -> [CoreAlt]+                     -> (Bool,      -- True <=> something happened+                         [AltCon],  -- New constructors that cannot match DEFAULT+                         [CoreAlt]) -- New alternatives+-- See Note [Combine identical alternatives]+-- True <=> we did some combining, result is a single DEFAULT alternative+combineIdenticalAlts imposs_deflt_cons ((con1,bndrs1,rhs1) : rest_alts)+  | all isDeadBinder bndrs1    -- Remember the default+  , not (null elim_rest) -- alternative comes first+  = (True, imposs_deflt_cons', deflt_alt : filtered_rest)+  where+    (elim_rest, filtered_rest) = partition identical_to_alt1 rest_alts+    deflt_alt = (DEFAULT, [], mkTicks (concat tickss) rhs1)++     -- See Note [Care with impossible-constructors when combining alternatives]+    imposs_deflt_cons' = imposs_deflt_cons `minusList` elim_cons+    elim_cons = elim_con1 ++ map fstOf3 elim_rest+    elim_con1 = case con1 of     -- Don't forget con1!+                  DEFAULT -> []  -- See Note [+                  _       -> [con1]++    cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2+    identical_to_alt1 (_con,bndrs,rhs)+      = all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1+    tickss = map (stripTicksT tickishFloatable . thdOf3) elim_rest++combineIdenticalAlts imposs_cons alts+  = (False, imposs_cons, alts)++{- *********************************************************************+*                                                                      *+             exprIsTrivial+*                                                                      *+************************************************************************++Note [exprIsTrivial]+~~~~~~~~~~~~~~~~~~~~+@exprIsTrivial@ is true of expressions we are unconditionally happy to+                duplicate; simple variables and constants, and type+                applications.  Note that primop Ids aren't considered+                trivial unless++Note [Variables are trivial]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There used to be a gruesome test for (hasNoBinding v) in the+Var case:+        exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0+The idea here is that a constructor worker, like \$wJust, is+really short for (\x -> \$wJust x), because \$wJust has no binding.+So it should be treated like a lambda.  Ditto unsaturated primops.+But now constructor workers are not "have-no-binding" Ids.  And+completely un-applied primops and foreign-call Ids are sufficiently+rare that I plan to allow them to be duplicated and put up with+saturating them.++Note [Tick trivial]+~~~~~~~~~~~~~~~~~~~+Ticks are only trivial if they are pure annotations. If we treat+"tick<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 CoreSyn.++If the scrutinee is trivial, then so is the whole expression; and the+CoreToSTG pass in fact drops the case expression leaving only the+scrutinee.++Having more trivial expressions is good.  Moreover, if we don't treat+it as trivial we may land up with let-bindings like+   let v = case x of {} in ...+and after CoreToSTG that gives+   let v = x in ...+and that confuses the code generator (Trac #11155). So best to kill+it off at source.+-}++exprIsTrivial :: CoreExpr -> Bool+exprIsTrivial (Var _)          = True        -- See Note [Variables are trivial]+exprIsTrivial (Type _)         = True+exprIsTrivial (Coercion _)     = True+exprIsTrivial (Lit lit)        = litIsTrivial lit+exprIsTrivial (App e arg)      = not (isRuntimeArg arg) && exprIsTrivial e+exprIsTrivial (Lam b e)        = not (isRuntimeVar b) && exprIsTrivial e+exprIsTrivial (Tick t e)       = not (tickishIsCode t) && exprIsTrivial e+                                 -- See Note [Tick trivial]+exprIsTrivial (Cast e _)       = exprIsTrivial e+exprIsTrivial (Case e _ _ [])  = exprIsTrivial e  -- See Note [Empty case is trivial]+exprIsTrivial _                = False++{-+Note [getIdFromTrivialExpr]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+When substituting in a breakpoint we need to strip away the type cruft+from a trivial expression and get back to the Id.  The invariant is+that the expression we're substituting was originally trivial+according to exprIsTrivial, AND the expression is not a literal.+See Note [substTickish] for how breakpoint substitution preserves+this extra invariant.++We also need this functionality in CorePrep to extract out Id of a+function which we are saturating.  However, in this case we don't know+if the variable actually refers to a literal; thus we use+'getIdFromTrivialExpr_maybe' to handle this case.  See test+T12076lit for an example where this matters.+-}++getIdFromTrivialExpr :: CoreExpr -> Id+getIdFromTrivialExpr e+    = fromMaybe (pprPanic "getIdFromTrivialExpr" (ppr e))+                (getIdFromTrivialExpr_maybe e)++getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id+-- See Note [getIdFromTrivialExpr]+getIdFromTrivialExpr_maybe e = go e+  where go (Var v) = Just v+        go (App f t) | not (isRuntimeArg t) = go f+        go (Tick t e) | not (tickishIsCode t) = go e+        go (Cast e _) = go e+        go (Lam b e) | not (isRuntimeVar b) = go e+        go _ = Nothing++{-+exprIsBottom is a very cheap and cheerful function; it may return+False for bottoming expressions, but it never costs much to ask.  See+also CoreArity.exprBotStrictness_maybe, but that's a bit more+expensive.+-}++exprIsBottom :: CoreExpr -> Bool+-- See Note [Bottoming expressions]+exprIsBottom e+  | isEmptyTy (exprType e)+  = True+  | otherwise+  = go 0 e+  where+    go n (Var v) = isBottomingId v &&  n >= idArity v+    go n (App e a) | isTypeArg a = go n e+                   | otherwise   = go (n+1) e+    go n (Tick _ e)              = go n e+    go n (Cast e _)              = go n e+    go n (Let _ e)               = go n e+    go n (Lam v e) | isTyVar v   = go n e+    go _ (Case _ _ _ alts)       = null alts+       -- See Note [Empty case alternatives] in CoreSyn+    go _ _                       = False++{- Note [Bottoming expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A bottoming expression is guaranteed to diverge, or raise an+exception.  We can test for it in two different ways, and exprIsBottom+checks for both of these situations:++* Visibly-bottom computations.  For example+      (error Int "Hello")+  is visibly bottom.  The strictness analyser also finds out if+  a function diverges or raises an exception, and puts that info+  in its strictness signature.++* Empty types.  If a type is empty, its only inhabitant is bottom.+  For example:+      data T+      f :: T -> Bool+      f = \(x:t). case x of Bool {}+  Since T has no data constructors, the case alternatives are of course+  empty.  However note that 'x' is not bound to a visibly-bottom value;+  it's the *type* that tells us it's going to diverge.++A GADT may also be empty even though it has constructors:+        data T a where+          T1 :: a -> T Bool+          T2 :: T Int+        ...(case (x::T Char) of {})...+Here (T Char) is uninhabited.  A more realistic case is (Int ~ Bool),+which is likewise uninhabited.+++************************************************************************+*                                                                      *+             exprIsDupable+*                                                                      *+************************************************************************++Note [exprIsDupable]+~~~~~~~~~~~~~~~~~~~~+@exprIsDupable@ is true of expressions that can be duplicated at a modest+                cost in code size.  This will only happen in different case+                branches, so there's no issue about duplicating work.++                That is, exprIsDupable returns True of (f x) even if+                f is very very expensive to call.++                Its only purpose is to avoid fruitless let-binding+                and then inlining of case join points+-}++exprIsDupable :: DynFlags -> CoreExpr -> Bool+exprIsDupable dflags e+  = isJust (go dupAppSize e)+  where+    go :: Int -> CoreExpr -> Maybe Int+    go n (Type {})     = Just n+    go n (Coercion {}) = Just n+    go n (Var {})      = decrement n+    go n (Tick _ e)    = go n e+    go n (Cast e _)    = go n e+    go n (App f a) | Just n' <- go n a = go n' f+    go n (Lit lit) | litIsDupable dflags lit = decrement n+    go _ _ = Nothing++    decrement :: Int -> Maybe Int+    decrement 0 = Nothing+    decrement n = Just (n-1)++dupAppSize :: Int+dupAppSize = 8   -- Size of term we are prepared to duplicate+                 -- This is *just* big enough to make test MethSharing+                 -- inline enough join points.  Really it should be+                 -- smaller, and could be if we fixed Trac #4960.++{-+************************************************************************+*                                                                      *+             exprIsCheap, exprIsExpandable+*                                                                      *+************************************************************************++Note [exprIsWorkFree]+~~~~~~~~~~~~~~~~~~~~~+exprIsWorkFree is used when deciding whether to inline something; we+don't inline it if doing so might duplicate work, by peeling off a+complete copy of the expression.  Here we do not want even to+duplicate a primop (Trac #5623):+   eg   let x = a #+ b in x +# x+   we do not want to inline/duplicate x++Previously we were a bit more liberal, which led to the primop-duplicating+problem.  However, being more conservative did lead to a big regression in+one nofib benchmark, wheel-sieve1.  The situation looks like this:++   let noFactor_sZ3 :: GHC.Types.Int -> GHC.Types.Bool+       noFactor_sZ3 = case s_adJ of _ { GHC.Types.I# x_aRs ->+         case GHC.Prim.<=# x_aRs 2 of _ {+           GHC.Types.False -> notDivBy ps_adM qs_adN;+           GHC.Types.True -> lvl_r2Eb }}+       go = \x. ...(noFactor (I# y))....(go x')...++The function 'noFactor' is heap-allocated and then called.  Turns out+that 'notDivBy' is strict in its THIRD arg, but that is invisible to+the caller of noFactor, which therefore cannot do w/w and+heap-allocates noFactor's argument.  At the moment (May 12) we are just+going to put up with this, because the previous more aggressive inlining+(which treated 'noFactor' as work-free) was duplicating primops, which+in turn was making inner loops of array calculations runs slow (#5623)++Note [Case expressions are work-free]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Are case-expressions work-free?  Consider+    let v = case x of (p,q) -> p+        go = \y -> ...case v of ...+Should we inline 'v' at its use site inside the loop?  At the moment+we do.  I experimented with saying that case are *not* work-free, but+that increased allocation slightly.  It's a fairly small effect, and at+the moment we go for the slightly more aggressive version which treats+(case x of ....) as work-free if the alternatives are.++Moreover it improves arities of overloaded functions where+there is only dictionary selection (no construction) involved++Note [exprIsCheap]   See also Note [Interaction of exprIsCheap and lone variables]+~~~~~~~~~~~~~~~~~~   in CoreUnfold.hs+@exprIsCheap@ looks at a Core expression and returns \tr{True} if+it is obviously in weak head normal form, or is cheap to get to WHNF.+[Note that that's not the same as exprIsDupable; an expression might be+big, and hence not dupable, but still cheap.]++By ``cheap'' we mean a computation we're willing to:+        push inside a lambda, or+        inline at more than one place+That might mean it gets evaluated more than once, instead of being+shared.  The main examples of things which aren't WHNF but are+``cheap'' are:++  *     case e of+          pi -> ei+        (where e, and all the ei are cheap)++  *     let x = e in b+        (where e and b are cheap)++  *     op x1 ... xn+        (where op is a cheap primitive operator)++  *     error "foo"+        (because we are happy to substitute it inside a lambda)++Notice that a variable is considered 'cheap': we can push it inside a lambda,+because sharing will make sure it is only evaluated once.++Note [exprIsCheap and exprIsHNF]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note that exprIsHNF does not imply exprIsCheap.  Eg+        let x = fac 20 in Just x+This responds True to exprIsHNF (you can discard a seq), but+False to exprIsCheap.++Note [exprIsExpandable]+~~~~~~~~~~~~~~~~~~~~~~~+An expression is "expandable" if we are willing to dupicate it, if doing+so might make a RULE or case-of-constructor fire.  Mainly this means+data-constructor applications, but it's a bit more generous than exprIsCheap+because it is true of "CONLIKE" Ids: see Note [CONLIKE pragma] in BasicTypes.++It is used to set the uf_expandable field of an Unfolding, and that+in turn is used+  * In RULE matching+  * In exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe++But take care: exprIsExpandable should /not/ be true of primops.  I+found this in test T5623a:+    let q = /\a. Ptr a (a +# b)+    in case q @ Float of Ptr v -> ...q...++q's inlining should not be expandable, else exprIsConApp_maybe will+say that (q @ Float) expands to (Ptr a (a +# b)), and that will+duplicate the (a +# b) primop, which we should not do lightly.+(It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.)+++Note [Arguments in exprIsOk]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What predicate should we apply to the argument of an application?  We+used to say "exprIsTrivial arg" due to concerns about duplicating+nested constructor applications, but see #4978.  The principle here is+that+   let x = a +# b in c *# x+should behave equivalently to+   c *# (a +# b)+Since lets with cheap RHSs are accepted, so should paps with cheap arguments+-}++--------------------+exprIsCheap :: CoreExpr -> Bool+exprIsCheap = exprIsOk isCheapApp++exprIsExpandable :: CoreExpr -> Bool -- See Note [exprIsExpandable]+exprIsExpandable = exprIsOk isExpandableApp++exprIsWorkFree :: CoreExpr -> Bool   -- See Note [exprIsWorkFree]+exprIsWorkFree = exprIsOk isWorkFreeApp++--------------------+exprIsOk :: CheapAppFun -> CoreExpr -> Bool+exprIsOk ok_app e+  = ok e+  where+    ok e = go 0 e++    -- n is the number of value arguments+    go n (Var v)                      = ok_app v n+    go _ (Lit {})                     = True+    go _ (Type {})                    = True+    go _ (Coercion {})                = True+    go n (Cast e _)                   = go n e+    go n (Case scrut _ _ alts)        = foldl (&&) (ok scrut)+                                        [ go n rhs | (_,_,rhs) <- alts ]+    go n (Tick t e) | tickishCounts t = False+                    | otherwise       = go n e+    go n (Lam x e)  | isRuntimeVar x  = n==0 || go (n-1) e+                    | otherwise       = go n e+    go n (App f e)  | isRuntimeArg e  = go (n+1) f && ok e+                    | otherwise       = go n f+    go _ (Let {})                     = False++      -- Case: see Note [Case expressions are work-free]+      -- App:  see Note [Arguments in exprIsOk]+      -- Let:  the old exprIsCheap worked through lets+++-------------------------------------+type CheapAppFun = Id -> Arity -> Bool+  -- Is an application of this function to n *value* args+  -- always cheap, assuming the arguments are cheap?+  -- True mainly of data constructors, partial applications;+  -- but with minor variations:+  --    isWorkFreeApp+  --    isCheapApp+  --    isExpandableApp++  -- NB: isCheapApp and isExpandableApp are called from outside+  --     this module, so don't be tempted to move the notRedex+  --     stuff into the call site in exprIsOk, and remove it+  --     from the CheapAppFun implementations+++notRedex :: CheapAppFun+notRedex fn n_val_args+  =  n_val_args == 0           -- No value args+  || n_val_args < idArity fn   -- Partial application+  || isBottomingId fn   -- OK to duplicate calls to bottom;+                        -- it certainly doesn't need to be shared!++isWorkFreeApp :: CheapAppFun+isWorkFreeApp fn n_val_args+  | notRedex fn n_val_args+  = True+  | otherwise+  = case idDetails fn of+      DataConWorkId {} -> True+      _                -> False++isCheapApp :: CheapAppFun+isCheapApp fn n_val_args+  | notRedex fn n_val_args+  = True+  | otherwise+  = case idDetails fn of+      DataConWorkId {} -> True+      RecSelId {}      -> n_val_args == 1  -- See Note [Record selection]+      ClassOpId {}     -> n_val_args == 1+      PrimOpId op      -> primOpIsCheap op+      _                -> False+        -- In principle we should worry about primops+        -- that return a type variable, since the result+        -- might be applied to something, but I'm not going+        -- to bother to check the number of args++isExpandableApp :: CheapAppFun+isExpandableApp fn n_val_args+  | notRedex fn n_val_args+  = True+  | isConLikeId fn+  = True+  | otherwise+  = case idDetails fn of+      DataConWorkId {} -> True+      RecSelId {}      -> n_val_args == 1  -- See Note [Record selection]+      ClassOpId {}     -> n_val_args == 1+      PrimOpId {}      -> False+      _                -> all_pred_args n_val_args (idType fn)++  where+  -- See if all the arguments are PredTys (implicit params or classes)+  -- If so we'll regard it as expandable; see Note [Expandable overloadings]+     all_pred_args n_val_args ty+       | n_val_args == 0+       = True++       | Just (bndr, ty) <- splitPiTy_maybe ty+       = caseBinder bndr+           (\_tv -> all_pred_args n_val_args ty)+           (\bndr_ty -> isPredTy bndr_ty && all_pred_args (n_val_args-1) ty)++       | otherwise+       = False++{- Note [Record selection]+~~~~~~~~~~~~~~~~~~~~~~~~~~+I'm experimenting with making record selection+look cheap, so we will substitute it inside a+lambda.  Particularly for dictionary field selection.++BUT: Take care with (sel d x)!  The (sel d) might be cheap, but+there's no guarantee that (sel d x) will be too.  Hence (n_val_args == 1)++Note [Expandable overloadings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose the user wrote this+   {-# RULE  forall x. foo (negate x) = h x #-}+   f x = ....(foo (negate x))....+He'd expect the rule to fire. But since negate is overloaded, we might+get this:+    f = \d -> let n = negate d in \x -> ...foo (n x)...+So we treat the application of a function (negate in this case) to a+*dictionary* as expandable.  In effect, every function is CONLIKE when+it's applied only to dictionaries.+++************************************************************************+*                                                                      *+             exprOkForSpeculation+*                                                                      *+************************************************************************+-}++-----------------------------+-- | 'exprOkForSpeculation' returns True of an expression that is:+--+--  * Safe to evaluate even if normal order eval might not+--    evaluate the expression at all, or+--+--  * Safe /not/ to evaluate even if normal order would do so+--+-- It is usually called on arguments of unlifted type, but not always+-- In particular, Simplify.rebuildCase calls it on lifted types+-- when a 'case' is a plain 'seq'. See the example in+-- Note [exprOkForSpeculation: case expressions] below+--+-- Precisely, it returns @True@ iff:+--  a) The expression guarantees to terminate,+--  b) soon,+--  c) without causing a write side effect (e.g. writing a mutable variable)+--  d) without throwing a Haskell exception+--  e) without risking an unchecked runtime exception (array out of bounds,+--     divide by zero)+--+-- For @exprOkForSideEffects@ the list is the same, but omitting (e).+--+-- Note that+--    exprIsHNF            implies exprOkForSpeculation+--    exprOkForSpeculation implies exprOkForSideEffects+--+-- See Note [PrimOp can_fail and has_side_effects] in PrimOp+-- and Note [Implementation: how can_fail/has_side_effects affect transformations]+--+-- As an example of the considerations in this test, consider:+--+-- > let x = case y# +# 1# of { r# -> I# r# }+-- > in E+--+-- being translated to:+--+-- > case y# +# 1# of { r# ->+-- >    let x = I# r#+-- >    in E+-- > }+--+-- We can only do this if the @y + 1@ is ok for speculation: it has no+-- side effects, and can't diverge or raise an exception.+exprOkForSpeculation, exprOkForSideEffects :: Expr b -> Bool+exprOkForSpeculation = expr_ok primOpOkForSpeculation+exprOkForSideEffects = expr_ok primOpOkForSideEffects+  -- Polymorphic in binder type+  -- There is one call at a non-Id binder type, in SetLevels++expr_ok :: (PrimOp -> Bool) -> Expr b -> 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++-- Tick annotations that *tick* cannot be speculated, because these+-- are meant to identify whether or not (and how often) the particular+-- source expression was evaluated at runtime.+expr_ok primop_ok (Tick tickish e)+   | tickishCounts tickish = False+   | otherwise             = expr_ok primop_ok e++expr_ok primop_ok (Case e _ _ alts)+  =  expr_ok primop_ok e  -- Note [exprOkForSpeculation: case expressions]+  && all (\(_,_,rhs) -> expr_ok primop_ok rhs) alts+  && altsAreExhaustive alts     -- Note [Exhaustive alts]++expr_ok primop_ok other_expr+  = case collectArgs other_expr of+        (expr, args) | Var f <- stripTicksTopE (not . tickishCounts) expr+                     -> app_ok primop_ok f args+        _            -> False++-----------------------------+app_ok :: (PrimOp -> Bool) -> Id -> [Expr b] -> Bool+app_ok primop_ok fun args+  = case idDetails fun of+      DFunId new_type ->  not new_type+         -- DFuns terminate, unless the dict is implemented+         -- with a newtype in which case they may not++      DataConWorkId {} -> True+                -- The strictness of the constructor has already+                -- been expressed by its "wrapper", so we don't need+                -- to take the arguments into account++      PrimOpId op+        | isDivOp op+        , [arg1, Lit lit] <- args+        -> not (isZeroLit lit) && expr_ok primop_ok arg1+              -- Special case for dividing operations that fail+              -- In general they are NOT ok-for-speculation+              -- (which primop_ok will catch), but they ARE OK+              -- if the divisor is definitely non-zero.+              -- Often there is a literal divisor, and this+              -- can get rid of a thunk in an inner loop++        | otherwise+        -> primop_ok op     -- Check the primop itself+        && and (zipWith arg_ok arg_tys args)  -- Check the arguments++      _other -> isUnliftedType (idType fun)          -- c.f. the Var case of exprIsHNF+             || idArity fun > n_val_args             -- Partial apps+             || (n_val_args == 0 &&+                 isEvaldUnfolding (idUnfolding fun)) -- Let-bound values+             where+               n_val_args = valArgCount args+  where+    (arg_tys, _) = splitPiTys (idType fun)++    arg_ok :: TyBinder -> Expr b -> Bool+    arg_ok (Named _) _ = True   -- A type argument+    arg_ok (Anon ty) arg        -- A term argument+       | isUnliftedType ty = expr_ok primop_ok arg+       | otherwise         = True  -- See Note [Primops with lifted arguments]++-----------------------------+altsAreExhaustive :: [Alt b] -> Bool+-- True  <=> the case alternatives are definiely exhaustive+-- False <=> they may or may not be+altsAreExhaustive []+  = False    -- Should not happen+altsAreExhaustive ((con1,_,_) : alts)+  = case con1 of+      DEFAULT   -> True+      LitAlt {} -> False+      DataAlt c -> 1 + length alts == tyConFamilySize (dataConTyCon c)+      -- It is possible to have an exhaustive case that does not+      -- enumerate all constructors, notably in a GADT match, but+      -- we behave conservatively here -- I don't think it's important+      -- enough to deserve special treatment++-- | True of dyadic operators that can fail only if the second arg is zero!+isDivOp :: PrimOp -> Bool+-- This function probably belongs in PrimOp, or even in+-- an automagically generated file.. but it's such a+-- special case I thought I'd leave it here for now.+isDivOp IntQuotOp        = True+isDivOp IntRemOp         = True+isDivOp WordQuotOp       = True+isDivOp WordRemOp        = True+isDivOp FloatDivOp       = True+isDivOp DoubleDivOp      = True+isDivOp _                = False++{-+Note [exprOkForSpeculation: case expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's always sound for exprOkForSpeculation to return False, and we+don't want it to take too long, so it bales out on complicated-looking+terms.  Notably lets, which can be stacked very deeply; and in any+case the argument of exprOkForSpeculation is usually in a strict context,+so any lets will have been floated away.++However, we keep going on case-expressions.  An example like this one+showed up in DPH code (Trac #3717):+    foo :: Int -> Int+    foo 0 = 0+    foo n = (if n < 5 then 1 else 2) `seq` foo (n-1)++If exprOkForSpeculation doesn't look through case expressions, you get this:+    T.$wfoo =+      \ (ww :: GHC.Prim.Int#) ->+        case ww of ds {+          __DEFAULT -> case (case <# ds 5 of _ {+                          GHC.Types.False -> lvl1;+                          GHC.Types.True -> lvl})+                       of _ { __DEFAULT ->+                       T.$wfoo (GHC.Prim.-# ds_XkE 1) };+          0 -> 0+        }++The inner case is redundant, and should be nuked.++Note [Exhaustive alts]+~~~~~~~~~~~~~~~~~~~~~~+We might have something like+  case x of {+    A -> ...+    _ -> ...(case x of { B -> ...; C -> ... })...+Here, the inner case is fine, because the A alternative+can't happen, but it's not ok to float the inner case outside+the outer one (even if we know x is evaluated outside), because+then it would be non-exhaustive. See Trac #5453.++Similarly, this is a valid program (albeit a slightly dodgy one)+   let v = case x of { B -> ...; C -> ... }+   in case x of+         A -> ...+         _ ->  ...v...v....+But we don't want to speculate the v binding.++One could try to be clever, but the easy fix is simpy to regard+a non-exhaustive case as *not* okForSpeculation.+++Note [Primops with lifted arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Is this ok-for-speculation (see Trac #13027)?+   reallyUnsafePtrEq# a b+Well, yes.  The primop accepts lifted arguments and does not+evaluate them.  Indeed, in general primops are, well, primitive+and do not perform evaluation.++There is one primop, dataToTag#, which does /require/ a lifted+argument to be evaluted.  To ensure this, CorePrep adds an+eval if it can't see the the argument is definitely evaluated+(see [dataToTag magic] in CorePrep).++We make no attempt to guarantee that dataToTag#'s argument is+evaluated here.  Main reason: it's very fragile to test for the+evaluatedness of a lifted argument.  Consider+    case x of y -> let v = dataToTag# y in ...++where x/y have type Int, say.  'y' looks evaluated (by the enclosing+case) so all is well.  Now the FloatOut pass does a binder-swap (for+very good reasons), changing to+   case x of y -> let v = dataToTag# x in ...++See also Note [dataToTag#] in primops.txt.pp.++Bottom line:+  * in exprOkForSpeculation we simply ignore all lifted arguments.+++************************************************************************+*                                                                      *+             exprIsHNF, exprIsConLike+*                                                                      *+************************************************************************+-}++-- Note [exprIsHNF]             See also Note [exprIsCheap and exprIsHNF]+-- ~~~~~~~~~~~~~~~~+-- | exprIsHNF returns true for expressions that are certainly /already/+-- evaluated to /head/ normal form.  This is used to decide whether it's ok+-- to change:+--+-- > case x of _ -> e+--+--    into:+--+-- > e+--+-- and to decide whether it's safe to discard a 'seq'.+--+-- So, it does /not/ treat variables as evaluated, unless they say they are.+-- However, it /does/ treat partial applications and constructor applications+-- as values, even if their arguments are non-trivial, provided the argument+-- type is lifted. For example, both of these are values:+--+-- > (:) (f x) (map f xs)+-- > map (...redex...)+--+-- because 'seq' on such things completes immediately.+--+-- For unlifted argument types, we have to be careful:+--+-- > C (f x :: Int#)+--+-- Suppose @f x@ diverges; then @C (f x)@ is not a value. However this can't+-- happen: see "CoreSyn#let_app_invariant". This invariant states that arguments of+-- unboxed type must be ok-for-speculation (or trivial).+exprIsHNF :: CoreExpr -> Bool           -- True => Value-lambda, constructor, PAP+exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding++-- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as+-- data constructors. Conlike arguments are considered interesting by the+-- inliner.+exprIsConLike :: CoreExpr -> Bool       -- True => lambda, conlike, PAP+exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding++-- | Returns true for values or value-like expressions. These are lambdas,+-- constructors / CONLIKE functions (as determined by the function argument)+-- or PAPs.+--+exprIsHNFlike :: (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool+exprIsHNFlike is_con is_con_unf = is_hnf_like+  where+    is_hnf_like (Var v) -- NB: There are no value args at this point+      =  is_con v       -- Catches nullary constructors,+                        --      so that [] and () are values, for example+      || idArity v > 0  -- Catches (e.g.) primops that don't have unfoldings+      || is_con_unf (idUnfolding v)+        -- Check the thing's unfolding; it might be bound to a value+        -- We don't look through loop breakers here, which is a bit conservative+        -- but otherwise I worry that if an Id's unfolding is just itself,+        -- we could get an infinite loop++    is_hnf_like (Lit _)          = True+    is_hnf_like (Type _)         = True       -- Types are honorary Values;+                                              -- we don't mind copying them+    is_hnf_like (Coercion _)     = True       -- Same for coercions+    is_hnf_like (Lam b e)        = isRuntimeVar b || is_hnf_like e+    is_hnf_like (Tick tickish e) = not (tickishCounts tickish)+                                      && is_hnf_like e+                                      -- See Note [exprIsHNF Tick]+    is_hnf_like (Cast e _)       = is_hnf_like e+    is_hnf_like (App e a)+      | isValArg a               = app_is_value e 1+      | otherwise                = is_hnf_like e+    is_hnf_like (Let _ e)        = is_hnf_like e  -- Lazy let(rec)s don't affect us+    is_hnf_like _                = False++    -- There is at least one value argument+    -- 'n' is number of value args to which the expression is applied+    app_is_value :: CoreExpr -> Int -> Bool+    app_is_value (Var fun) n_val_args+      = idArity fun > n_val_args    -- Under-applied function+        || is_con fun               --  or constructor-like+    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++{-+Note [exprIsHNF Tick]++We can discard source annotations on HNFs as long as they aren't+tick-like:++  scc c (\x . e)    =>  \x . e+  scc c (C x1..xn)  =>  C x1..xn++So we regard these as HNFs.  Tick annotations that tick are not+regarded as HNF if the expression they surround is HNF, because the+tick is there to tell us that the expression was evaluated, so we+don't want to discard a seq on it.+-}++-- | Can we bind this 'CoreExpr' at the top level?+exprIsTopLevelBindable :: CoreExpr -> Type -> Bool+-- See Note [CoreSyn top-level string literals]+-- Precondition: exprType expr = ty+exprIsTopLevelBindable expr ty+  = exprIsLiteralString expr+  || not (isUnliftedType ty)++exprIsLiteralString :: CoreExpr -> Bool+exprIsLiteralString (Lit (MachStr _)) = True+exprIsLiteralString _ = False++{-+************************************************************************+*                                                                      *+             Instantiating data constructors+*                                                                      *+************************************************************************++These InstPat functions go here to avoid circularity between DataCon and Id+-}++dataConRepInstPat   ::                 [Unique] -> DataCon -> [Type] -> ([TyVar], [Id])+dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [Id])++dataConRepInstPat   = dataConInstPat (repeat ((fsLit "ipv")))+dataConRepFSInstPat = dataConInstPat++dataConInstPat :: [FastString]          -- A long enough list of FSs to use for names+               -> [Unique]              -- An equally long list of uniques, at least one for each binder+               -> DataCon+               -> [Type]                -- Types to instantiate the universally quantified tyvars+               -> ([TyVar], [Id])       -- Return instantiated variables+-- dataConInstPat arg_fun fss us con inst_tys returns a tuple+-- (ex_tvs, arg_ids),+--+--   ex_tvs are intended to be used as binders for existential type args+--+--   arg_ids are indended to be used as binders for value arguments,+--     and their types have been instantiated with inst_tys and ex_tys+--     The arg_ids include both evidence and+--     programmer-specified arguments (both after rep-ing)+--+-- Example.+--  The following constructor T1+--+--  data T a where+--    T1 :: forall b. Int -> b -> T(a,b)+--    ...+--+--  has representation type+--   forall a. forall a1. forall b. (a ~ (a1,b)) =>+--     Int -> b -> T a+--+--  dataConInstPat fss us T1 (a1',b') will return+--+--  ([a1'', b''], [c :: (a1', b')~(a1'', b''), x :: Int, y :: b''])+--+--  where the double-primed variables are created with the FastStrings and+--  Uniques given as fss and us+dataConInstPat fss uniqs con inst_tys+  = ASSERT( univ_tvs `equalLength` inst_tys )+    (ex_bndrs, arg_ids)+  where+    univ_tvs = dataConUnivTyVars con+    ex_tvs   = dataConExTyVars con+    arg_tys  = dataConRepArgTys con+    arg_strs = dataConRepStrictness con  -- 1-1 with arg_tys+    n_ex = length ex_tvs++      -- split the Uniques and FastStrings+    (ex_uniqs, id_uniqs) = splitAt n_ex uniqs+    (ex_fss,   id_fss)   = splitAt n_ex fss++      -- Make the instantiating substitution for universals+    univ_subst = zipTvSubst univ_tvs inst_tys++      -- Make existential type variables, applying and extending the substitution+    (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst+                                       (zip3 ex_tvs ex_fss ex_uniqs)++    mk_ex_var :: TCvSubst -> (TyVar, FastString, Unique) -> (TCvSubst, TyVar)+    mk_ex_var subst (tv, fs, uniq) = (Type.extendTvSubstWithClone subst tv+                                       new_tv+                                     , new_tv)+      where+        new_tv = mkTyVar (mkSysTvName uniq fs) kind+        kind   = Type.substTyUnchecked subst (tyVarKind tv)++      -- Make value vars, instantiating types+    arg_ids = zipWith4 mk_id_var id_uniqs id_fss arg_tys arg_strs+    mk_id_var uniq fs ty str+      = setCaseBndrEvald str $  -- See Note [Mark evaluated arguments]+        mkLocalIdOrCoVar name (Type.substTy full_subst ty)+      where+        name = mkInternalName uniq (mkVarOccFS fs) noSrcSpan++{-+Note [Mark evaluated arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When pattern matching on a constructor with strict fields, the binder+can have an 'evaldUnfolding'.  Moreover, it *should* have one, so that+when loading an interface file unfolding like:+  data T = MkT !Int+  f x = case x of { MkT y -> let v::Int# = case y of I# n -> n+1+                             in ... }+we don't want Lint to complain.  The 'y' is evaluated, so the+case in the RHS of the binding for 'v' is fine.  But only if we+*know* that 'y' is evaluated.++c.f. add_evals in Simplify.simplAlt++************************************************************************+*                                                                      *+         Equality+*                                                                      *+************************************************************************+-}++-- | A cheap equality test which bales out fast!+--      If it returns @True@ the arguments are definitely equal,+--      otherwise, they may or may not be equal.+--+-- See also 'exprIsBig'+cheapEqExpr :: Expr b -> Expr b -> Bool+cheapEqExpr = cheapEqExpr' (const False)++-- | Cheap expression equality test, can ignore ticks by type.+cheapEqExpr' :: (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool+cheapEqExpr' ignoreTick = go_s+  where go_s = go `on` stripTicksTopE ignoreTick+        go (Var v1)   (Var v2)   = v1 == v2+        go (Lit lit1) (Lit lit2) = lit1 == lit2+        go (Type t1)  (Type t2)  = t1 `eqType` t2+        go (Coercion c1) (Coercion c2) = c1 `eqCoercion` c2++        go (App f1 a1) (App f2 a2)+          = f1 `go_s` f2 && a1 `go_s` a2++        go (Cast e1 t1) (Cast e2 t2)+          = e1 `go_s` e2 && t1 `eqCoercion` t2++        go (Tick t1 e1) (Tick t2 e2)+          = t1 == t2 && e1 `go_s` e2++        go _ _ = False+        {-# INLINE go #-}+{-# INLINE cheapEqExpr' #-}++exprIsBig :: Expr b -> Bool+-- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr'+exprIsBig (Lit _)      = False+exprIsBig (Var _)      = False+exprIsBig (Type _)     = False+exprIsBig (Coercion _) = False+exprIsBig (Lam _ e)    = exprIsBig e+exprIsBig (App f a)    = exprIsBig f || exprIsBig a+exprIsBig (Cast e _)   = exprIsBig e    -- Hopefully coercions are not too big!+exprIsBig (Tick _ e)   = exprIsBig e+exprIsBig _            = True++eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool+-- Compares for equality, modulo alpha+eqExpr in_scope e1 e2+  = go (mkRnEnv2 in_scope) e1 e2+  where+    go env (Var v1) (Var v2)+      | rnOccL env v1 == rnOccR env v2+      = True++    go _   (Lit lit1)    (Lit lit2)      = lit1 == lit2+    go env (Type t1)    (Type t2)        = eqTypeX env t1 t2+    go env (Coercion co1) (Coercion co2) = eqCoercionX env co1 co2+    go env (Cast e1 co1) (Cast e2 co2) = eqCoercionX env co1 co2 && go env e1 e2+    go env (App f1 a1)   (App f2 a2)   = go env f1 f2 && go env a1 a2+    go env (Tick n1 e1)  (Tick n2 e2)  = eqTickish env n1 n2 && go env e1 e2++    go env (Lam b1 e1)  (Lam b2 e2)+      =  eqTypeX env (varType b1) (varType b2)   -- False for Id/TyVar combination+      && go (rnBndr2 env b1 b2) e1 e2++    go env (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2)+      =  go env r1 r2  -- No need to check binder types, since RHSs match+      && go (rnBndr2 env v1 v2) e1 e2++    go env (Let (Rec ps1) e1) (Let (Rec ps2) e2)+      = length ps1 == length ps2+      && all2 (go env') rs1 rs2 && go env' e1 e2+      where+        (bs1,rs1) = unzip ps1+        (bs2,rs2) = unzip ps2+        env' = rnBndrs2 env bs1 bs2++    go env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2)+      | null a1   -- See Note [Empty case alternatives] in TrieMap+      = null a2 && go env e1 e2 && eqTypeX env t1 t2+      | otherwise+      =  go env e1 e2 && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2++    go _ _ _ = False++    -----------+    go_alt env (c1, bs1, e1) (c2, bs2, e2)+      = c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2++eqTickish :: RnEnv2 -> Tickish Id -> Tickish Id -> Bool+eqTickish env (Breakpoint lid lids) (Breakpoint rid rids)+      = lid == rid  &&  map (rnOccL env) lids == map (rnOccR env) rids+eqTickish _ l r = l == r++-- | Finds differences between core expressions, modulo alpha and+-- renaming. Setting @top@ means that the @IdInfo@ of bindings will be+-- checked for differences as well.+diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]+diffExpr _   env (Var v1)   (Var v2)   | rnOccL env v1 == rnOccR env v2 = []+diffExpr _   _   (Lit lit1) (Lit lit2) | lit1 == lit2                   = []+diffExpr _   env (Type t1)  (Type t2)  | eqTypeX env t1 t2              = []+diffExpr _   env (Coercion co1) (Coercion co2)+                                       | eqCoercionX env co1 co2        = []+diffExpr top env (Cast e1 co1)  (Cast e2 co2)+  | eqCoercionX env co1 co2                = diffExpr top env e1 e2+diffExpr top env (Tick n1 e1)   e2+  | not (tickishIsCode n1)                 = diffExpr top env e1 e2+diffExpr top env e1             (Tick n2 e2)+  | not (tickishIsCode n2)                 = diffExpr top env e1 e2+diffExpr top env (Tick n1 e1)   (Tick n2 e2)+  | eqTickish env n1 n2                    = diffExpr top env e1 e2+ -- The error message of failed pattern matches will contain+ -- generated names, which are allowed to differ.+diffExpr _   _   (App (App (Var absent) _) _)+                 (App (App (Var absent2) _) _)+  | isBottomingId absent && isBottomingId absent2 = []+diffExpr top env (App f1 a1)    (App f2 a2)+  = diffExpr top env f1 f2 ++ diffExpr top env a1 a2+diffExpr top env (Lam b1 e1)  (Lam b2 e2)+  | eqTypeX env (varType b1) (varType b2)   -- False for Id/TyVar combination+  = diffExpr top (rnBndr2 env b1 b2) e1 e2+diffExpr top env (Let bs1 e1) (Let bs2 e2)+  = let (ds, env') = diffBinds top env (flattenBinds [bs1]) (flattenBinds [bs2])+    in ds ++ diffExpr top env' e1 e2+diffExpr top env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2)+  | length a1 == length a2 && not (null a1) || eqTypeX env t1 t2+    -- See Note [Empty case alternatives] in TrieMap+  = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2)+  where env' = rnBndr2 env b1 b2+        diffAlt (c1, bs1, e1) (c2, bs2, e2)+          | c1 /= c2  = [text "alt-cons " <> ppr c1 <> text " /= " <> ppr c2]+          | otherwise = diffExpr top (rnBndrs2 env' bs1 bs2) e1 e2+diffExpr _  _ e1 e2+  = [fsep [ppr e1, text "/=", ppr e2]]++-- | Finds differences between core bindings, see @diffExpr@.+--+-- The main problem here is that while we expect the binds to have the+-- same order in both lists, this is not guaranteed. To do this+-- properly we'd either have to do some sort of unification or check+-- all possible mappings, which would be seriously expensive. So+-- instead we simply match single bindings as far as we can. This+-- leaves us just with mutually recursive and/or mismatching bindings,+-- which we then speculatively match by ordering them. It's by no means+-- perfect, but gets the job done well enough.+diffBinds :: Bool -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)]+          -> ([SDoc], RnEnv2)+diffBinds top env binds1 = go (length binds1) env binds1+ where go _    env []     []+          = ([], env)+       go fuel env binds1 binds2+          -- No binds left to compare? Bail out early.+          | null binds1 || null binds2+          = (warn env binds1 binds2, env)+          -- Iterated over all binds without finding a match? Then+          -- try speculatively matching binders by order.+          | fuel == 0+          = if not $ env `inRnEnvL` fst (head binds1)+            then let env' = uncurry (rnBndrs2 env) $ unzip $+                            zip (sort $ map fst binds1) (sort $ map fst binds2)+                 in go (length binds1) env' binds1 binds2+            -- If we have already tried that, give up+            else (warn env binds1 binds2, env)+       go fuel env ((bndr1,expr1):binds1) binds2+          | let matchExpr (bndr,expr) =+                  (not top || null (diffIdInfo env bndr bndr1)) &&+                  null (diffExpr top (rnBndr2 env bndr1 bndr) expr1 expr)+          , (binds2l, (bndr2,_):binds2r) <- break matchExpr binds2+          = go (length binds1) (rnBndr2 env bndr1 bndr2)+                binds1 (binds2l ++ binds2r)+          | otherwise -- No match, so push back (FIXME O(n^2))+          = go (fuel-1) env (binds1++[(bndr1,expr1)]) binds2+       go _ _ _ _ = panic "diffBinds: impossible" -- GHC isn't smart enough++       -- We have tried everything, but couldn't find a good match. So+       -- now we just return the comparison results when we pair up+       -- the binds in a pseudo-random order.+       warn env binds1 binds2 =+         concatMap (uncurry (diffBind env)) (zip binds1' binds2') +++         unmatched "unmatched left-hand:" (drop l binds1') +++         unmatched "unmatched right-hand:" (drop l binds2')+        where binds1' = sortBy (comparing fst) binds1+              binds2' = sortBy (comparing fst) binds2+              l = min (length binds1') (length binds2')+       unmatched _   [] = []+       unmatched txt bs = [text txt $$ ppr (Rec bs)]+       diffBind env (bndr1,expr1) (bndr2,expr2)+         | ds@(_:_) <- diffExpr top env expr1 expr2+         = locBind "in binding" bndr1 bndr2 ds+         | otherwise+         = diffIdInfo env bndr1 bndr2++-- | Find differences in @IdInfo@. We will especially check whether+-- the unfoldings match, if present (see @diffUnfold@).+diffIdInfo :: RnEnv2 -> Var -> Var -> [SDoc]+diffIdInfo env bndr1 bndr2+  | arityInfo info1 == arityInfo info2+    && cafInfo info1 == cafInfo info2+    && oneShotInfo info1 == oneShotInfo info2+    && inlinePragInfo info1 == inlinePragInfo info2+    && occInfo info1 == occInfo info2+    && demandInfo info1 == demandInfo info2+    && callArityInfo info1 == callArityInfo info2+    && levityInfo info1 == levityInfo info2+  = locBind "in unfolding of" bndr1 bndr2 $+    diffUnfold env (unfoldingInfo info1) (unfoldingInfo info2)+  | otherwise+  = locBind "in Id info of" bndr1 bndr2+    [fsep [pprBndr LetBind bndr1, text "/=", pprBndr LetBind bndr2]]+  where info1 = idInfo bndr1; info2 = idInfo bndr2++-- | Find differences in unfoldings. Note that we will not check for+-- differences of @IdInfo@ in unfoldings, as this is generally+-- redundant, and can lead to an exponential blow-up in complexity.+diffUnfold :: RnEnv2 -> Unfolding -> Unfolding -> [SDoc]+diffUnfold _   NoUnfolding    NoUnfolding                 = []+diffUnfold _   BootUnfolding  BootUnfolding               = []+diffUnfold _   (OtherCon cs1) (OtherCon cs2) | cs1 == cs2 = []+diffUnfold env (DFunUnfolding bs1 c1 a1)+               (DFunUnfolding bs2 c2 a2)+  | c1 == c2 && length bs1 == length bs2+  = concatMap (uncurry (diffExpr False env')) (zip a1 a2)+  where env' = rnBndrs2 env bs1 bs2+diffUnfold env (CoreUnfolding t1 _ _ v1 cl1 wf1 x1 g1)+               (CoreUnfolding t2 _ _ v2 cl2 wf2 x2 g2)+  | v1 == v2 && cl1 == cl2+    && wf1 == wf2 && x1 == x2 && g1 == g2+  = diffExpr False env t1 t2+diffUnfold _   uf1 uf2+  = [fsep [ppr uf1, text "/=", ppr uf2]]++-- | Add location information to diff messages+locBind :: String -> Var -> Var -> [SDoc] -> [SDoc]+locBind loc b1 b2 diffs = map addLoc diffs+  where addLoc d            = d $$ nest 2 (parens (text loc <+> bindLoc))+        bindLoc | b1 == b2  = ppr b1+                | otherwise = ppr b1 <> char '/' <> ppr b2++{-+************************************************************************+*                                                                      *+                Eta reduction+*                                                                      *+************************************************************************++Note [Eta reduction conditions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We try for eta reduction here, but *only* if we get all the way to an+trivial expression.  We don't want to remove extra lambdas unless we+are going to avoid allocating this thing altogether.++There are some particularly delicate points here:++* We want to eta-reduce if doing so leaves a trivial expression,+  *including* a cast.  For example+       \x. f |> co  -->  f |> co+  (provided co doesn't mention x)++* Eta reduction is not valid in general:+        \x. bot  /=  bot+  This matters, partly for old-fashioned correctness reasons but,+  worse, getting it wrong can yield a seg fault. Consider+        f = \x.f x+        h y = case (case y of { True -> f `seq` True; False -> False }) of+                True -> ...; False -> ...++  If we (unsoundly) eta-reduce f to get f=f, the strictness analyser+  says f=bottom, and replaces the (f `seq` True) with just+  (f `cast` unsafe-co).  BUT, as thing stand, 'f' got arity 1, and it+  *keeps* arity 1 (perhaps also wrongly).  So CorePrep eta-expands+  the definition again, so that it does not termninate after all.+  Result: seg-fault because the boolean case actually gets a function value.+  See Trac #1947.++  So it's important to do the right thing.++* Note [Arity care]: we need to be careful if we just look at f's+  arity. Currently (Dec07), f's arity is visible in its own RHS (see+  Note [Arity robustness] in SimplEnv) so we must *not* trust the+  arity when checking that 'f' is a value.  Otherwise we will+  eta-reduce+      f = \x. f x+  to+      f = f+  Which might change a terminating program (think (f `seq` e)) to a+  non-terminating one.  So we check for being a loop breaker first.++  However for GlobalIds we can look at the arity; and for primops we+  must, since they have no unfolding.++* Regardless of whether 'f' is a value, we always want to+  reduce (/\a -> f a) to f+  This came up in a RULE: foldr (build (/\a -> g a))+  did not match           foldr (build (/\b -> ...something complex...))+  The type checker can insert these eta-expanded versions,+  with both type and dictionary lambdas; hence the slightly+  ad-hoc isDictId++* Never *reduce* arity. For example+      f = \xy. g x y+  Then if h has arity 1 we don't want to eta-reduce because then+  f's arity would decrease, and that is bad++These delicacies are why we don't use exprIsTrivial and exprIsHNF here.+Alas.++Note [Eta reduction with casted arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    (\(x:t3). f (x |> g)) :: t3 -> t2+  where+    f :: t1 -> t2+    g :: t3 ~ t1+This should be eta-reduced to++    f |> (sym g -> t2)++So we need to accumulate a coercion, pushing it inward (past+variable arguments only) thus:+   f (x |> co_arg) |> co  -->  (f |> (sym co_arg -> co)) x+   f (x:t)         |> co  -->  (f |> (t -> co)) x+   f @ a           |> co  -->  (f |> (forall a.co)) @ a+   f @ (g:t1~t2)   |> co  -->  (f |> (t1~t2 => co)) @ (g:t1~t2)+These are the equations for ok_arg.++It's true that we could also hope to eta reduce these:+    (\xy. (f x |> g) y)+    (\xy. (f x y) |> g)+But the simplifier pushes those casts outwards, so we don't+need to address that here.+-}++tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr+tryEtaReduce bndrs body+  = go (reverse bndrs) body (mkRepReflCo (exprType body))+  where+    incoming_arity = count isId bndrs++    go :: [Var]            -- Binders, innermost first, types [a3,a2,a1]+       -> CoreExpr         -- Of type tr+       -> Coercion         -- Of type tr ~ ts+       -> Maybe CoreExpr   -- Of type a1 -> a2 -> a3 -> ts+    -- See Note [Eta reduction with casted arguments]+    -- for why we have an accumulating coercion+    go [] fun co+      | ok_fun fun+      , let used_vars = exprFreeVars fun `unionVarSet` tyCoVarsOfCo co+      , not (any (`elemVarSet` used_vars) bndrs)+      = Just (mkCast fun co)   -- Check for any of the binders free in the result+                               -- including the accumulated coercion++    go bs (Tick t e) co+      | tickishFloatable t+      = fmap (Tick t) $ go bs e co+      -- Float app ticks: \x -> Tick t (e x) ==> Tick t e++    go (b : bs) (App fun arg) co+      | Just (co', ticks) <- ok_arg b arg co+      = fmap (flip (foldr mkTick) ticks) $ go bs fun co'+            -- Float arg ticks: \x -> e (Tick t x) ==> Tick t e++    go _ _ _  = Nothing         -- Failure!++    ---------------+    -- Note [Eta reduction conditions]+    ok_fun (App fun (Type {})) = ok_fun fun+    ok_fun (Cast fun _)        = ok_fun fun+    ok_fun (Tick _ expr)       = ok_fun expr+    ok_fun (Var fun_id)        = ok_fun_id fun_id || all ok_lam bndrs+    ok_fun _fun                = False++    ---------------+    ok_fun_id fun = fun_arity fun >= incoming_arity++    ---------------+    fun_arity fun             -- See Note [Arity care]+       | isLocalId fun+       , isStrongLoopBreaker (idOccInfo fun) = 0+       | arity > 0                           = arity+       | isEvaldUnfolding (idUnfolding fun)  = 1+            -- See Note [Eta reduction of an eval'd function]+       | otherwise                           = 0+       where+         arity = idArity fun++    ---------------+    ok_lam v = isTyVar v || isEvVar v++    ---------------+    ok_arg :: Var              -- Of type bndr_t+           -> CoreExpr         -- Of type arg_t+           -> Coercion         -- Of kind (t1~t2)+           -> Maybe (Coercion  -- Of type (arg_t -> t1 ~  bndr_t -> t2)+                               --   (and similarly for tyvars, coercion args)+                    , [Tickish Var])+    -- See Note [Eta reduction with casted arguments]+    ok_arg bndr (Type ty) co+       | Just tv <- getTyVar_maybe ty+       , bndr == tv  = Just (mkHomoForAllCos [tv] co, [])+    ok_arg bndr (Var v) co+       | bndr == v   = let reflCo = mkRepReflCo (idType bndr)+                       in Just (mkFunCo Representational reflCo co, [])+    ok_arg bndr (Cast e co_arg) co+       | (ticks, Var v) <- stripTicksTop tickishFloatable e+       , bndr == v+       = Just (mkFunCo Representational (mkSymCo co_arg) co, ticks)+       -- The simplifier combines multiple casts into one,+       -- so we can have a simple-minded pattern match here+    ok_arg bndr (Tick t arg) co+       | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co+       = Just (co', t:ticks)++    ok_arg _ _ _ = Nothing++{-+Note [Eta reduction of an eval'd function]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In Haskell it is not true that    f = \x. f x+because f might be bottom, and 'seq' can distinguish them.++But it *is* true that   f = f `seq` \x. f x+and we'd like to simplify the latter to the former.  This amounts+to the rule that+  * when there is just *one* value argument,+  * f is not bottom+we can eta-reduce    \x. f x  ===>  f++This turned up in Trac #7542.+++************************************************************************+*                                                                      *+\subsection{Determining non-updatable right-hand-sides}+*                                                                      *+************************************************************************++Top-level constructor applications can usually be allocated+statically, but they can't if the constructor, or any of the+arguments, come from another DLL (because we can't refer to static+labels in other DLLs).++If this happens we simply make the RHS into an updatable thunk,+and 'execute' it rather than allocating it statically.+-}++-- | This function is called only on *top-level* right-hand sides.+-- Returns @True@ if the RHS can be allocated statically in the output,+-- with no thunks involved at all.+rhsIsStatic :: Platform+            -> (Name -> Bool)         -- Which names are dynamic+            -> (Integer -> CoreExpr)  -- Desugaring for integer literals (disgusting)+                                      -- C.f. Note [Disgusting computation of CafRefs]+                                      --      in TidyPgm+            -> CoreExpr -> Bool+-- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or+-- refers to, CAFs; (ii) in CoreToStg to decide whether to put an+-- update flag on it and (iii) in DsExpr to decide how to expand+-- list literals+--+-- The basic idea is that rhsIsStatic returns True only if the RHS is+--      (a) a value lambda+--      (b) a saturated constructor application with static args+--+-- BUT watch out for+--  (i) Any cross-DLL references kill static-ness completely+--      because they must be 'executed' not statically allocated+--      ("DLL" here really only refers to Windows DLLs, on other platforms,+--      this is not necessary)+--+-- (ii) We treat partial applications as redexes, because in fact we+--      make a thunk for them that runs and builds a PAP+--      at run-time.  The only applications that are treated as+--      static are *saturated* applications of constructors.++-- We used to try to be clever with nested structures like this:+--              ys = (:) w ((:) w [])+-- on the grounds that CorePrep will flatten ANF-ise it later.+-- But supporting this special case made the function much more+-- complicated, because the special case only applies if there are no+-- enclosing type lambdas:+--              ys = /\ a -> Foo (Baz ([] a))+-- Here the nested (Baz []) won't float out to top level in CorePrep.+--+-- But in fact, even without -O, nested structures at top level are+-- flattened by the simplifier, so we don't need to be super-clever here.+--+-- Examples+--+--      f = \x::Int. x+7        TRUE+--      p = (True,False)        TRUE+--+--      d = (fst p, False)      FALSE because there's a redex inside+--                              (this particular one doesn't happen but...)+--+--      h = D# (1.0## /## 2.0##)        FALSE (redex again)+--      n = /\a. Nil a                  TRUE+--+--      t = /\a. (:) (case w a of ...) (Nil a)  FALSE (redex)+--+--+-- This is a bit like CoreUtils.exprIsHNF, with the following differences:+--    a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)+--+--    b) (C x xs), where C is a constructor is updatable if the application is+--         dynamic+--+--    c) don't look through unfolding of f in (f x).++rhsIsStatic platform is_dynamic_name cvt_integer rhs = is_static False rhs+  where+  is_static :: Bool     -- True <=> in a constructor argument; must be atomic+            -> CoreExpr -> Bool++  is_static False  (Lam b e)              = isRuntimeVar b || is_static False e+  is_static in_arg (Tick n e)             = not (tickishIsCode n)+                                              && is_static in_arg e+  is_static in_arg (Cast e _)             = is_static in_arg e+  is_static _      (Coercion {})          = True   -- Behaves just like a literal+  is_static in_arg (Lit (LitInteger i _)) = is_static in_arg (cvt_integer i)+  is_static _      (Lit (MachLabel {}))   = False+  is_static _      (Lit _)                = True+        -- A MachLabel (foreign import "&foo") in an argument+        -- prevents a constructor application from being static.  The+        -- reason is that it might give rise to unresolvable symbols+        -- in the object file: under Linux, references to "weak"+        -- symbols from the data segment give rise to "unresolvable+        -- relocation" errors at link time This might be due to a bug+        -- in the linker, but we'll work around it here anyway.+        -- SDM 24/2/2004++  is_static in_arg other_expr = go other_expr 0+   where+    go (Var f) n_val_args+        | (platformOS platform /= OSMinGW32) ||+          not (is_dynamic_name (idName f))+        =  saturated_data_con f n_val_args+        || (in_arg && n_val_args == 0)+                -- A naked un-applied variable is *not* deemed a static RHS+                -- E.g.         f = g+                -- Reason: better to update so that the indirection gets shorted+                --         out, and the true value will be seen+                -- NB: if you change this, you'll break the invariant that THUNK_STATICs+                --     are always updatable.  If you do so, make sure that non-updatable+                --     ones have enough space for their static link field!++    go (App f a) n_val_args+        | isTypeArg a                    = go f n_val_args+        | not in_arg && is_static True a = go f (n_val_args + 1)+        -- The (not in_arg) checks that we aren't in a constructor argument;+        -- if we are, we don't allow (value) applications of any sort+        --+        -- NB. In case you wonder, args are sometimes not atomic.  eg.+        --   x = D# (1.0## /## 2.0##)+        -- can't float because /## can fail.++    go (Tick n f) n_val_args = not (tickishIsCode n) && go f n_val_args+    go (Cast e _) n_val_args = go e n_val_args+    go _          _          = False++    saturated_data_con f n_val_args+        = case isDataConWorkId_maybe f of+            Just dc -> n_val_args == dataConRepArity dc+            Nothing -> False++{-+************************************************************************+*                                                                      *+\subsection{Type utilities}+*                                                                      *+************************************************************************+-}++-- | True if the type has no non-bottom elements, e.g. when it is an empty+-- datatype, or a GADT with non-satisfiable type parameters, e.g. Int :~: Bool.+-- See Note [Bottoming expressions]+--+-- See Note [No alternatives lint check] for another use of this function.+isEmptyTy :: Type -> Bool+isEmptyTy ty+    -- Data types where, given the particular type parameters, no data+    -- constructor matches, are empty.+    -- This includes data types with no constructors, e.g. Data.Void.Void.+    | Just (tc, inst_tys) <- splitTyConApp_maybe ty+    , Just dcs <- tyConDataCons_maybe tc+    , all (dataConCannotMatch inst_tys) dcs+    = True+    | otherwise+    = False++{-+*****************************************************+*+* StaticPtr+*+*****************************************************+-}++-- | @collectMakeStaticArgs (makeStatic t srcLoc e)@ yields+-- @Just (makeStatic, t, srcLoc, e)@.+--+-- Returns @Nothing@ for every other expression.+collectMakeStaticArgs+  :: CoreExpr -> Maybe (CoreExpr, Type, CoreExpr, CoreExpr)+collectMakeStaticArgs e+    | (fun@(Var b), [Type t, loc, arg], _) <- collectArgsTicks (const True) e+    , idName b == makeStaticName = Just (fun, t, loc, arg)+collectMakeStaticArgs _          = Nothing++{-+************************************************************************+*                                                                      *+\subsection{Join points}+*                                                                      *+************************************************************************+-}++-- | Does this binding bind a join point (or a recursive group of join points)?+isJoinBind :: CoreBind -> Bool+isJoinBind (NonRec b _)       = isJoinId b+isJoinBind (Rec ((b, _) : _)) = isJoinId b+isJoinBind _                  = False
+ coreSyn/MkCore.hs view
@@ -0,0 +1,772 @@+{-# LANGUAGE CPP #-}++-- | Handy functions for creating much Core syntax+module MkCore (+        -- * Constructing normal syntax+        mkCoreLet, mkCoreLets,+        mkCoreApp, mkCoreApps, mkCoreConApps,+        mkCoreLams, mkWildCase, mkIfThenElse,+        mkWildValBinder, mkWildEvBinder,+        sortQuantVars, castBottomExpr,++        -- * Constructing boxed literals+        mkWordExpr, mkWordExprWord,+        mkIntExpr, mkIntExprInt,+        mkIntegerExpr, mkNaturalExpr,+        mkFloatExpr, mkDoubleExpr,+        mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith,++        -- * Floats+        FloatBind(..), wrapFloat,++        -- * Constructing small tuples+        mkCoreVarTup, mkCoreVarTupTy, mkCoreTup, mkCoreUbxTup,+        mkCoreTupBoxity, unitExpr,++        -- * Constructing big tuples+        mkBigCoreVarTup, mkBigCoreVarTup1,+        mkBigCoreVarTupTy, mkBigCoreTupTy,+        mkBigCoreTup,++        -- * Deconstructing small tuples+        mkSmallTupleSelector, mkSmallTupleCase,++        -- * Deconstructing big tuples+        mkTupleSelector, mkTupleSelector1, mkTupleCase,++        -- * Constructing list expressions+        mkNilExpr, mkConsExpr, mkListExpr,+        mkFoldrExpr, mkBuildExpr,++        -- * Constructing Maybe expressions+        mkNothingExpr, mkJustExpr,++        -- * Error Ids+        mkRuntimeErrorApp, mkImpossibleExpr, errorIds,+        rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,+        nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,+        pAT_ERROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID,+        tYPE_ERROR_ID,+    ) where++#include "HsVersions.h"++import Id+import Var      ( EvVar, setTyVarUnique )++import CoreSyn+import CoreUtils        ( exprType, needsCaseBinding, bindNonRec )+import Literal+import HscTypes++import TysWiredIn+import PrelNames++import HsUtils          ( mkChunkified, chunkify )+import TcType           ( mkSpecSigmaTy )+import Type+import Coercion         ( isCoVar )+import TysPrim+import DataCon          ( DataCon, dataConWorkId )+import IdInfo           ( vanillaIdInfo, setStrictnessInfo,+                          setArityInfo )+import Demand+import Name      hiding ( varName )+import Outputable+import FastString+import UniqSupply+import BasicTypes+import Util+import DynFlags+import Data.List++import Data.Char        ( ord )++infixl 4 `mkCoreApp`, `mkCoreApps`++{-+************************************************************************+*                                                                      *+\subsection{Basic CoreSyn construction}+*                                                                      *+************************************************************************+-}+sortQuantVars :: [Var] -> [Var]+-- Sort the variables, putting type and covars first, in scoped order,+-- and then other Ids+-- It is a deterministic sort, meaining it doesn't look at the values of+-- Uniques. For explanation why it's important See Note [Unique Determinism]+-- in Unique.+sortQuantVars vs = sorted_tcvs ++ ids+  where+    (tcvs, ids) = partition (isTyVar <||> isCoVar) vs+    sorted_tcvs = toposortTyVars tcvs++-- | Bind a binding group over an expression, using a @let@ or @case@ as+-- appropriate (see "CoreSyn#let_app_invariant")+mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr+mkCoreLet (NonRec bndr rhs) body        -- See Note [CoreSyn let/app invariant]+  | needsCaseBinding (idType bndr) rhs+  , not (isJoinId bndr)+  = Case rhs bndr (exprType body) [(DEFAULT,[],body)]+mkCoreLet bind body+  = Let bind body++-- | Bind a list of binding groups over an expression. The leftmost binding+-- group becomes the outermost group in the resulting expression+mkCoreLets :: [CoreBind] -> CoreExpr -> CoreExpr+mkCoreLets binds body = foldr mkCoreLet body binds++-- | Construct an expression which represents the application of one expression+-- to the other+mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr+-- Respects the let/app invariant by building a case expression where necessary+--   See CoreSyn Note [CoreSyn let/app invariant]+mkCoreApp _ fun (Type ty)     = App fun (Type ty)+mkCoreApp _ fun (Coercion co) = App fun (Coercion co)+mkCoreApp d fun arg           = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d )+                                mk_val_app fun arg arg_ty res_ty+                              where+                                fun_ty = exprType fun+                                (arg_ty, res_ty) = splitFunTy fun_ty++-- | Construct an expression which represents the application of a number of+-- expressions to another. The leftmost expression in the list is applied first+-- Respects the let/app invariant by building a case expression where necessary+--   See CoreSyn Note [CoreSyn let/app invariant]+mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr+-- Slightly more efficient version of (foldl mkCoreApp)+mkCoreApps orig_fun orig_args+  = go orig_fun (exprType orig_fun) orig_args+  where+    go fun _      []               = fun+    go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (piResultTy fun_ty ty) args+    go fun fun_ty (arg     : args) = ASSERT2( isFunTy fun_ty, ppr fun_ty $$ ppr orig_fun+                                                              $$ ppr orig_args )+                                     go (mk_val_app fun arg arg_ty res_ty) res_ty args+                                   where+                                     (arg_ty, res_ty) = splitFunTy fun_ty++-- | Construct an expression which represents the application of a number of+-- expressions to that of a data constructor expression. The leftmost expression+-- in the list is applied first+mkCoreConApps :: DataCon -> [CoreExpr] -> CoreExpr+mkCoreConApps con args = mkCoreApps (Var (dataConWorkId con)) args++mk_val_app :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr+-- Build an application (e1 e2),+-- or a strict binding  (case e2 of x -> e1 x)+-- using the latter when necessary to respect the let/app invariant+--   See Note [CoreSyn let/app invariant]+mk_val_app fun arg arg_ty res_ty+  | not (needsCaseBinding arg_ty arg)+  = App fun arg                -- The vastly common case++  | otherwise+  = Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))]+  where+    arg_id = mkWildValBinder arg_ty+        -- Lots of shadowing, but it doesn't matter,+        -- because 'fun ' should not have a free wild-id+        --+        -- This is Dangerous.  But this is the only place we play this+        -- game, mk_val_app returns an expression that does not have+        -- have a free wild-id.  So the only thing that can go wrong+        -- is if you take apart this case expression, and pass a+        -- fragment of it as the fun part of a 'mk_val_app'.++-----------+mkWildEvBinder :: PredType -> EvVar+mkWildEvBinder pred = mkWildValBinder pred++-- | Make a /wildcard binder/. This is typically used when you need a binder+-- that you expect to use only at a *binding* site.  Do not use it at+-- occurrence sites because it has a single, fixed unique, and it's very+-- easy to get into difficulties with shadowing.  That's why it is used so little.+-- See Note [WildCard binders] in SimplEnv+mkWildValBinder :: Type -> Id+mkWildValBinder ty = mkLocalIdOrCoVar wildCardName ty++mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr+-- Make a case expression whose case binder is unused+-- The alts should not have any occurrences of WildId+mkWildCase scrut scrut_ty res_ty alts+  = Case scrut (mkWildValBinder scrut_ty) res_ty alts++mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr+mkIfThenElse guard then_expr else_expr+-- Not going to be refining, so okay to take the type of the "then" clause+  = mkWildCase guard boolTy (exprType then_expr)+         [ (DataAlt falseDataCon, [], else_expr),       -- Increasing order of tag!+           (DataAlt trueDataCon,  [], then_expr) ]++castBottomExpr :: CoreExpr -> Type -> CoreExpr+-- (castBottomExpr e ty), assuming that 'e' diverges,+-- return an expression of type 'ty'+-- See Note [Empty case alternatives] in CoreSyn+castBottomExpr e res_ty+  | e_ty `eqType` res_ty = e+  | otherwise            = Case e (mkWildValBinder e_ty) res_ty []+  where+    e_ty = exprType e++{-+The functions from this point don't really do anything cleverer than+their counterparts in CoreSyn, but they are here for consistency+-}++-- | Create a lambda where the given expression has a number of variables+-- bound over it. The leftmost binder is that bound by the outermost+-- lambda in the result+mkCoreLams :: [CoreBndr] -> CoreExpr -> CoreExpr+mkCoreLams = mkLams++{-+************************************************************************+*                                                                      *+\subsection{Making literals}+*                                                                      *+************************************************************************+-}++-- | Create a 'CoreExpr' which will evaluate to the given @Int@+mkIntExpr :: DynFlags -> Integer -> CoreExpr        -- Result = I# i :: Int+mkIntExpr dflags i = mkCoreConApps intDataCon  [mkIntLit dflags i]++-- | Create a 'CoreExpr' which will evaluate to the given @Int@+mkIntExprInt :: DynFlags -> Int -> CoreExpr         -- Result = I# i :: Int+mkIntExprInt dflags i = mkCoreConApps intDataCon  [mkIntLitInt dflags i]++-- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value+mkWordExpr :: DynFlags -> Integer -> CoreExpr+mkWordExpr dflags w = mkCoreConApps wordDataCon [mkWordLit dflags w]++-- | Create a 'CoreExpr' which will evaluate to the given @Word@+mkWordExprWord :: DynFlags -> Word -> CoreExpr+mkWordExprWord dflags w = mkCoreConApps wordDataCon [mkWordLitWord dflags w]++-- | Create a 'CoreExpr' which will evaluate to the given @Integer@+mkIntegerExpr  :: MonadThings m => Integer -> m CoreExpr  -- Result :: Integer+mkIntegerExpr i = do t <- lookupTyCon integerTyConName+                     return (Lit (mkLitInteger i (mkTyConTy t)))++-- | Create a 'CoreExpr' which will evaluate to the given @Natural@+--+-- TODO: should we add LitNatural to Core?+mkNaturalExpr  :: MonadThings m => Integer -> m CoreExpr  -- Result :: Natural+mkNaturalExpr i = do iExpr <- mkIntegerExpr i+                     fiExpr <- lookupId naturalFromIntegerName+                     return (mkCoreApps (Var fiExpr) [iExpr])+++-- | Create a 'CoreExpr' which will evaluate to the given @Float@+mkFloatExpr :: Float -> CoreExpr+mkFloatExpr f = mkCoreConApps floatDataCon [mkFloatLitFloat f]++-- | Create a 'CoreExpr' which will evaluate to the given @Double@+mkDoubleExpr :: Double -> CoreExpr+mkDoubleExpr d = mkCoreConApps doubleDataCon [mkDoubleLitDouble d]+++-- | Create a 'CoreExpr' which will evaluate to the given @Char@+mkCharExpr     :: Char             -> CoreExpr      -- Result = C# c :: Int+mkCharExpr c = mkCoreConApps charDataCon [mkCharLit c]++-- | Create a 'CoreExpr' which will evaluate to the given @String@+mkStringExpr   :: MonadThings m => String     -> m CoreExpr  -- Result :: String++-- | Create a 'CoreExpr' which will evaluate to a string morally equivalent to the given @FastString@+mkStringExprFS :: MonadThings m => FastString -> m CoreExpr  -- Result :: String++mkStringExpr str = mkStringExprFS (mkFastString str)++mkStringExprFS = mkStringExprFSWith lookupId++mkStringExprFSWith :: Monad m => (Name -> m Id) -> FastString -> m CoreExpr+mkStringExprFSWith lookupM str+  | nullFS str+  = return (mkNilExpr charTy)++  | all safeChar chars+  = do unpack_id <- lookupM unpackCStringName+       return (App (Var unpack_id) lit)++  | otherwise+  = do unpack_utf8_id <- lookupM unpackCStringUtf8Name+       return (App (Var unpack_utf8_id) lit)++  where+    chars = unpackFS str+    safeChar c = ord c >= 1 && ord c <= 0x7F+    lit = Lit (MachStr (fastStringToByteString str))++{-+************************************************************************+*                                                                      *+\subsection{Tuple constructors}+*                                                                      *+************************************************************************+-}++{-+Creating tuples and their types for Core expressions++@mkBigCoreVarTup@ builds a tuple; the inverse to @mkTupleSelector@.++* If it has only one element, it is the identity function.++* If there are more elements than a big tuple can have, it nests+  the tuples.++Note [Flattening one-tuples]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This family of functions creates a tuple of variables/expressions/types.+  mkCoreTup [e1,e2,e3] = (e1,e2,e3)+What if there is just one variable/expression/type in the argument?+We could do one of two things:++* Flatten it out, so that+    mkCoreTup [e1] = e1++* Built a one-tuple (see Note [One-tuples] in TysWiredIn)+    mkCoreTup1 [e1] = Unit e1+  We use a suffix "1" to indicate this.++Usually we want the former, but occasionally the latter.+-}++-- | Build a small tuple holding the specified variables+-- One-tuples are flattened; see Note [Flattening one-tuples]+mkCoreVarTup :: [Id] -> CoreExpr+mkCoreVarTup ids = mkCoreTup (map Var ids)++-- | Build the type of a small tuple that holds the specified variables+-- One-tuples are flattened; see Note [Flattening one-tuples]+mkCoreVarTupTy :: [Id] -> Type+mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids)++-- | Build a small tuple holding the specified expressions+-- One-tuples are flattened; see Note [Flattening one-tuples]+mkCoreTup :: [CoreExpr] -> CoreExpr+mkCoreTup []  = Var unitDataConId+mkCoreTup [c] = c+mkCoreTup cs  = mkCoreConApps (tupleDataCon Boxed (length cs))+                              (map (Type . exprType) cs ++ cs)++-- | Build a small unboxed tuple holding the specified expressions,+-- with the given types. The types must be the types of the expressions.+-- Do not include the RuntimeRep specifiers; this function calculates them+-- for you.+-- Does /not/ flatten one-tuples; see Note [Flattening one-tuples]+mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr+mkCoreUbxTup tys exps+  = ASSERT( tys `equalLength` exps)+    mkCoreConApps (tupleDataCon Unboxed (length tys))+             (map (Type . getRuntimeRep "mkCoreUbxTup") tys ++ map Type tys ++ exps)++-- | Make a core tuple of the given boxity+mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr+mkCoreTupBoxity Boxed   exps = mkCoreTup exps+mkCoreTupBoxity Unboxed exps = mkCoreUbxTup (map exprType exps) exps++-- | Build a big tuple holding the specified variables+-- One-tuples are flattened; see Note [Flattening one-tuples]+mkBigCoreVarTup :: [Id] -> CoreExpr+mkBigCoreVarTup ids = mkBigCoreTup (map Var ids)++mkBigCoreVarTup1 :: [Id] -> CoreExpr+-- Same as mkBigCoreVarTup, but one-tuples are NOT flattened+--                          see Note [Flattening one-tuples]+mkBigCoreVarTup1 [id] = mkCoreConApps (tupleDataCon Boxed 1)+                                      [Type (idType id), Var id]+mkBigCoreVarTup1 ids  = mkBigCoreTup (map Var ids)++-- | Build the type of a big tuple that holds the specified variables+-- One-tuples are flattened; see Note [Flattening one-tuples]+mkBigCoreVarTupTy :: [Id] -> Type+mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids)++-- | Build a big tuple holding the specified expressions+-- One-tuples are flattened; see Note [Flattening one-tuples]+mkBigCoreTup :: [CoreExpr] -> CoreExpr+mkBigCoreTup = mkChunkified mkCoreTup++-- | Build the type of a big tuple that holds the specified type of thing+-- One-tuples are flattened; see Note [Flattening one-tuples]+mkBigCoreTupTy :: [Type] -> Type+mkBigCoreTupTy = mkChunkified mkBoxedTupleTy++-- | The unit expression+unitExpr :: CoreExpr+unitExpr = Var unitDataConId++{-+************************************************************************+*                                                                      *+\subsection{Tuple destructors}+*                                                                      *+************************************************************************+-}++-- | Builds a selector which scrutises the given+-- expression and extracts the one name from the list given.+-- If you want the no-shadowing rule to apply, the caller+-- is responsible for making sure that none of these names+-- are in scope.+--+-- If there is just one 'Id' in the tuple, then the selector is+-- just the identity.+--+-- If necessary, we pattern match on a \"big\" tuple.+mkTupleSelector, mkTupleSelector1+    :: [Id]         -- ^ The 'Id's to pattern match the tuple against+    -> Id           -- ^ The 'Id' to select+    -> Id           -- ^ A variable of the same type as the scrutinee+    -> CoreExpr     -- ^ Scrutinee+    -> CoreExpr     -- ^ Selector expression++-- mkTupleSelector [a,b,c,d] b v e+--          = case e of v {+--                (p,q) -> case p of p {+--                           (a,b) -> b }}+-- We use 'tpl' vars for the p,q, since shadowing does not matter.+--+-- In fact, it's more convenient to generate it innermost first, getting+--+--        case (case e of v+--                (p,q) -> p) of p+--          (a,b) -> b+mkTupleSelector vars the_var scrut_var scrut+  = mk_tup_sel (chunkify vars) the_var+  where+    mk_tup_sel [vars] the_var = mkSmallTupleSelector vars the_var scrut_var scrut+    mk_tup_sel vars_s the_var = mkSmallTupleSelector group the_var tpl_v $+                                mk_tup_sel (chunkify tpl_vs) tpl_v+        where+          tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s]+          tpl_vs  = mkTemplateLocals tpl_tys+          [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s,+                                         the_var `elem` gp ]+-- ^ 'mkTupleSelector1' is like 'mkTupleSelector'+-- but one-tuples are NOT flattened (see Note [Flattening one-tuples])+mkTupleSelector1 vars the_var scrut_var scrut+  | [_] <- vars+  = mkSmallTupleSelector1 vars the_var scrut_var scrut+  | otherwise+  = mkTupleSelector vars the_var scrut_var scrut++-- | Like 'mkTupleSelector' but for tuples that are guaranteed+-- never to be \"big\".+--+-- > mkSmallTupleSelector [x] x v e = [| e |]+-- > mkSmallTupleSelector [x,y,z] x v e = [| case e of v { (x,y,z) -> x } |]+mkSmallTupleSelector, mkSmallTupleSelector1+          :: [Id]        -- The tuple args+          -> Id          -- The selected one+          -> Id          -- A variable of the same type as the scrutinee+          -> CoreExpr    -- Scrutinee+          -> CoreExpr+mkSmallTupleSelector [var] should_be_the_same_var _ scrut+  = ASSERT(var == should_be_the_same_var)+    scrut  -- Special case for 1-tuples+mkSmallTupleSelector vars the_var scrut_var scrut+  = mkSmallTupleSelector1 vars the_var scrut_var scrut++-- ^ 'mkSmallTupleSelector1' is like 'mkSmallTupleSelector'+-- but one-tuples are NOT flattened (see Note [Flattening one-tuples])+mkSmallTupleSelector1 vars the_var scrut_var scrut+  = ASSERT( notNull vars )+    Case scrut scrut_var (idType the_var)+         [(DataAlt (tupleDataCon Boxed (length vars)), vars, Var the_var)]++-- | A generalization of 'mkTupleSelector', allowing the body+-- of the case to be an arbitrary expression.+--+-- To avoid shadowing, we use uniques to invent new variables.+--+-- If necessary we pattern match on a \"big\" tuple.+mkTupleCase :: UniqSupply       -- ^ For inventing names of intermediate variables+            -> [Id]             -- ^ The tuple identifiers to pattern match on+            -> CoreExpr         -- ^ Body of the case+            -> Id               -- ^ A variable of the same type as the scrutinee+            -> CoreExpr         -- ^ Scrutinee+            -> CoreExpr+-- ToDo: eliminate cases where none of the variables are needed.+--+--         mkTupleCase uniqs [a,b,c,d] body v e+--           = case e of v { (p,q) ->+--             case p of p { (a,b) ->+--             case q of q { (c,d) ->+--             body }}}+mkTupleCase uniqs vars body scrut_var scrut+  = mk_tuple_case uniqs (chunkify vars) body+  where+    -- This is the case where don't need any nesting+    mk_tuple_case _ [vars] body+      = mkSmallTupleCase vars body scrut_var scrut++    -- This is the case where we must make nest tuples at least once+    mk_tuple_case us vars_s body+      = let (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s+            in mk_tuple_case us' (chunkify vars') body'++    one_tuple_case chunk_vars (us, vs, body)+      = let (uniq, us') = takeUniqFromSupply us+            scrut_var = mkSysLocal (fsLit "ds") uniq+              (mkBoxedTupleTy (map idType chunk_vars))+            body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)+        in (us', scrut_var:vs, body')++-- | As 'mkTupleCase', but for a tuple that is small enough to be guaranteed+-- not to need nesting.+mkSmallTupleCase+        :: [Id]         -- ^ The tuple args+        -> CoreExpr     -- ^ Body of the case+        -> Id           -- ^ A variable of the same type as the scrutinee+        -> CoreExpr     -- ^ Scrutinee+        -> CoreExpr++mkSmallTupleCase [var] body _scrut_var scrut+  = bindNonRec var scrut body+mkSmallTupleCase vars body scrut_var scrut+-- One branch no refinement?+  = Case scrut scrut_var (exprType body)+         [(DataAlt (tupleDataCon Boxed (length vars)), vars, body)]++{-+************************************************************************+*                                                                      *+                Floats+*                                                                      *+************************************************************************+-}++data FloatBind+  = FloatLet  CoreBind+  | FloatCase CoreExpr Id AltCon [Var]+      -- case e of y { C ys -> ... }+      -- See Note [Floating cases] in SetLevels++instance Outputable FloatBind where+  ppr (FloatLet b) = text "LET" <+> ppr b+  ppr (FloatCase e b c bs) = hang (text "CASE" <+> ppr e <+> ptext (sLit "of") <+> ppr b)+                                2 (ppr c <+> ppr bs)++wrapFloat :: FloatBind -> CoreExpr -> CoreExpr+wrapFloat (FloatLet defns)       body = Let defns body+wrapFloat (FloatCase e b con bs) body = Case e b (exprType body) [(con, bs, body)]++{-+************************************************************************+*                                                                      *+\subsection{Common list manipulation expressions}+*                                                                      *+************************************************************************++Call the constructor Ids when building explicit lists, so that they+interact well with rules.+-}++-- | Makes a list @[]@ for lists of the specified type+mkNilExpr :: Type -> CoreExpr+mkNilExpr ty = mkCoreConApps nilDataCon [Type ty]++-- | Makes a list @(:)@ for lists of the specified type+mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr+mkConsExpr ty hd tl = mkCoreConApps consDataCon [Type ty, hd, tl]++-- | Make a list containing the given expressions, where the list has the given type+mkListExpr :: Type -> [CoreExpr] -> CoreExpr+mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs++-- | Make a fully applied 'foldr' expression+mkFoldrExpr :: MonadThings m+            => Type             -- ^ Element type of the list+            -> Type             -- ^ Fold result type+            -> CoreExpr         -- ^ "Cons" function expression for the fold+            -> CoreExpr         -- ^ "Nil" expression for the fold+            -> CoreExpr         -- ^ List expression being folded acress+            -> m CoreExpr+mkFoldrExpr elt_ty result_ty c n list = do+    foldr_id <- lookupId foldrName+    return (Var foldr_id `App` Type elt_ty+           `App` Type result_ty+           `App` c+           `App` n+           `App` list)++-- | Make a 'build' expression applied to a locally-bound worker function+mkBuildExpr :: (MonadThings m, MonadUnique m)+            => Type                                     -- ^ Type of list elements to be built+            -> ((Id, Type) -> (Id, Type) -> m CoreExpr) -- ^ Function that, given information about the 'Id's+                                                        -- of the binders for the build worker function, returns+                                                        -- the body of that worker+            -> m CoreExpr+mkBuildExpr elt_ty mk_build_inside = do+    [n_tyvar] <- newTyVars [alphaTyVar]+    let n_ty = mkTyVarTy n_tyvar+        c_ty = mkFunTys [elt_ty, n_ty] n_ty+    [c, n] <- sequence [mkSysLocalM (fsLit "c") c_ty, mkSysLocalM (fsLit "n") n_ty]++    build_inside <- mk_build_inside (c, c_ty) (n, n_ty)++    build_id <- lookupId buildName+    return $ Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] build_inside+  where+    newTyVars tyvar_tmpls = do+      uniqs <- getUniquesM+      return (zipWith setTyVarUnique tyvar_tmpls uniqs)++{-+************************************************************************+*                                                                      *+             Manipulating Maybe data type+*                                                                      *+************************************************************************+-}+++-- | Makes a Nothing for the specified type+mkNothingExpr :: Type -> CoreExpr+mkNothingExpr ty = mkConApp nothingDataCon [Type ty]++-- | Makes a Just from a value of the specified type+mkJustExpr :: Type -> CoreExpr -> CoreExpr+mkJustExpr ty val = mkConApp justDataCon [Type ty, val]+++{-+************************************************************************+*                                                                      *+                      Error expressions+*                                                                      *+************************************************************************+-}++mkRuntimeErrorApp+        :: Id           -- Should be of type (forall a. Addr# -> a)+                        --      where Addr# points to a UTF8 encoded string+        -> Type         -- The type to instantiate 'a'+        -> String       -- The string to print+        -> CoreExpr++mkRuntimeErrorApp err_id res_ty err_msg+  = mkApps (Var err_id) [ Type (getRuntimeRep "mkRuntimeErrorApp" res_ty)+                        , Type res_ty, err_string ]+  where+    err_string = Lit (mkMachString err_msg)++mkImpossibleExpr :: Type -> CoreExpr+mkImpossibleExpr res_ty+  = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative"++{-+************************************************************************+*                                                                      *+                     Error Ids+*                                                                      *+************************************************************************++GHC randomly injects these into the code.++@patError@ is just a version of @error@ for pattern-matching+failures.  It knows various ``codes'' which expand to longer+strings---this saves space!++@absentErr@ is a thing we put in for ``absent'' arguments.  They jolly+well shouldn't be yanked on, but if one is, then you will get a+friendly message from @absentErr@ (rather than a totally random+crash).++@parError@ is a special version of @error@ which the compiler does+not know to be a bottoming Id.  It is used in the @_par_@ and @_seq_@+templates, but we don't ever expect to generate code for it.+-}++errorIds :: [Id]+errorIds+  = [ rUNTIME_ERROR_ID,+      iRREFUT_PAT_ERROR_ID,+      nON_EXHAUSTIVE_GUARDS_ERROR_ID,+      nO_METHOD_BINDING_ERROR_ID,+      pAT_ERROR_ID,+      rEC_CON_ERROR_ID,+      rEC_SEL_ERROR_ID,+      aBSENT_ERROR_ID,+      tYPE_ERROR_ID   -- Used with Opt_DeferTypeErrors, see #10284+      ]++recSelErrorName, runtimeErrorName, absentErrorName :: Name+irrefutPatErrorName, recConErrorName, patErrorName :: Name+nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name+typeErrorName :: Name++recSelErrorName     = err_nm "recSelError"     recSelErrorIdKey     rEC_SEL_ERROR_ID+absentErrorName     = err_nm "absentError"     absentErrorIdKey     aBSENT_ERROR_ID+runtimeErrorName    = err_nm "runtimeError"    runtimeErrorIdKey    rUNTIME_ERROR_ID+irrefutPatErrorName = err_nm "irrefutPatError" irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID+recConErrorName     = err_nm "recConError"     recConErrorIdKey     rEC_CON_ERROR_ID+patErrorName        = err_nm "patError"        patErrorIdKey        pAT_ERROR_ID+typeErrorName       = err_nm "typeError"       typeErrorIdKey       tYPE_ERROR_ID++noMethodBindingErrorName     = err_nm "noMethodBindingError"+                                  noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID+nonExhaustiveGuardsErrorName = err_nm "nonExhaustiveGuardsError"+                                  nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID++err_nm :: String -> Unique -> Id -> Name+err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id++rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, iRREFUT_PAT_ERROR_ID, rEC_CON_ERROR_ID :: Id+pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id+tYPE_ERROR_ID, aBSENT_ERROR_ID :: Id+rEC_SEL_ERROR_ID                = mkRuntimeErrorId recSelErrorName+rUNTIME_ERROR_ID                = mkRuntimeErrorId runtimeErrorName+iRREFUT_PAT_ERROR_ID            = mkRuntimeErrorId irrefutPatErrorName+rEC_CON_ERROR_ID                = mkRuntimeErrorId recConErrorName+pAT_ERROR_ID                    = mkRuntimeErrorId patErrorName+nO_METHOD_BINDING_ERROR_ID      = mkRuntimeErrorId noMethodBindingErrorName+nON_EXHAUSTIVE_GUARDS_ERROR_ID  = mkRuntimeErrorId nonExhaustiveGuardsErrorName+aBSENT_ERROR_ID                 = mkRuntimeErrorId absentErrorName+tYPE_ERROR_ID                   = mkRuntimeErrorId typeErrorName++mkRuntimeErrorId :: Name -> Id+-- Error function+--   with type:  forall (r:RuntimeRep) (a:TYPE r). Addr# -> a+--   with arity: 1+-- which diverges after being given one argument+-- The Addr# is expected to be the address of+--   a UTF8-encoded error string+mkRuntimeErrorId name+ = mkVanillaGlobalWithInfo name runtime_err_ty bottoming_info+ where+    bottoming_info = vanillaIdInfo `setStrictnessInfo`    strict_sig+                                   `setArityInfo`         1+                        -- Make arity and strictness agree++        -- Do *not* mark them as NoCafRefs, because they can indeed have+        -- CAF refs.  For example, pAT_ERROR_ID calls GHC.Err.untangle,+        -- which has some CAFs+        -- In due course we may arrange that these error-y things are+        -- regarded by the GC as permanently live, in which case we+        -- can give them NoCaf info.  As it is, any function that calls+        -- any pc_bottoming_Id will itself have CafRefs, which bloats+        -- SRTs.++    strict_sig = mkClosedStrictSig [evalDmd] exnRes+              -- exnRes: these throw an exception, not just diverge++    -- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a+    --   See Note [Error and friends have an "open-tyvar" forall]+    runtime_err_ty = mkSpecSigmaTy [runtimeRep1TyVar, openAlphaTyVar] []+                                   (mkFunTy addrPrimTy openAlphaTy)++{- Note [Error and friends have an "open-tyvar" forall]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+'error' and 'undefined' have types+        error     :: forall (v :: RuntimeRep) (a :: TYPE v). String -> a+        undefined :: forall (v :: RuntimeRep) (a :: TYPE v). a+Notice the runtime-representation polymorphism. This ensures that+"error" can be instantiated at unboxed as well as boxed types.+This is OK because it never returns, so the return type is irrelevant.+-}
+ coreSyn/PprCore.hs view
@@ -0,0 +1,622 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1996-1998+++Printing of Core syntax+-}++{-# LANGUAGE MultiWayIf #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module PprCore (+        pprCoreExpr, pprParendExpr,+        pprCoreBinding, pprCoreBindings, pprCoreAlt,+        pprCoreBindingWithSize, pprCoreBindingsWithSize,+        pprRules, pprOptCo+    ) where++import CoreSyn+import CoreStats (exprStats)+import Literal( pprLiteral )+import Name( pprInfixName, pprPrefixName )+import Var+import Id+import IdInfo+import Demand+import DataCon+import TyCon+import Type+import Coercion+import DynFlags+import BasicTypes+import Maybes+import Util+import Outputable+import FastString+import SrcLoc      ( pprUserRealSpan )++{-+************************************************************************+*                                                                      *+\subsection{Public interfaces for Core printing (excluding instances)}+*                                                                      *+************************************************************************++@pprParendCoreExpr@ puts parens around non-atomic Core expressions.+-}++pprCoreBindings :: OutputableBndr b => [Bind b] -> SDoc+pprCoreBinding  :: OutputableBndr b => Bind b  -> SDoc+pprCoreExpr     :: OutputableBndr b => Expr b  -> SDoc+pprParendExpr   :: OutputableBndr b => Expr b  -> SDoc++pprCoreBindings = pprTopBinds noAnn+pprCoreBinding  = pprTopBind noAnn++pprCoreBindingsWithSize :: [CoreBind] -> SDoc+pprCoreBindingWithSize  :: CoreBind  -> SDoc++pprCoreBindingsWithSize = pprTopBinds sizeAnn+pprCoreBindingWithSize = pprTopBind sizeAnn++instance OutputableBndr b => Outputable (Bind b) where+    ppr bind = ppr_bind noAnn bind++instance OutputableBndr b => Outputable (Expr b) where+    ppr expr = pprCoreExpr expr++{-+************************************************************************+*                                                                      *+\subsection{The guts}+*                                                                      *+************************************************************************+-}++-- | A function to produce an annotation for a given right-hand-side+type Annotation b = Expr b -> SDoc++-- | Annotate with the size of the right-hand-side+sizeAnn :: CoreExpr -> SDoc+sizeAnn e = text "-- RHS size:" <+> ppr (exprStats e)++-- | No annotation+noAnn :: Expr b -> SDoc+noAnn _ = empty++pprTopBinds :: OutputableBndr a+            => Annotation a -- ^ generate an annotation to place before the+                            -- binding+            -> [Bind a]     -- ^ bindings to show+            -> SDoc         -- ^ the pretty result+pprTopBinds ann binds = vcat (map (pprTopBind ann) binds)++pprTopBind :: OutputableBndr a => Annotation a -> Bind a -> SDoc+pprTopBind ann (NonRec binder expr)+ = ppr_binding ann (binder,expr) $$ blankLine++pprTopBind _ (Rec [])+  = text "Rec { }"+pprTopBind ann (Rec (b:bs))+  = vcat [text "Rec {",+          ppr_binding ann b,+          vcat [blankLine $$ ppr_binding ann b | b <- bs],+          text "end Rec }",+          blankLine]++ppr_bind :: OutputableBndr b => Annotation b -> Bind b -> SDoc++ppr_bind ann (NonRec val_bdr expr) = ppr_binding ann (val_bdr, expr)+ppr_bind ann (Rec binds)           = vcat (map pp binds)+                                    where+                                      pp bind = ppr_binding ann bind <> semi++ppr_binding :: OutputableBndr b => Annotation b -> (b, Expr b) -> SDoc+ppr_binding ann (val_bdr, expr)+  = ann expr $$ pprBndr LetBind val_bdr $$ pp_bind+  where+    pp_bind = case bndrIsJoin_maybe val_bdr of+                Nothing -> pp_normal_bind+                Just ar -> pp_join_bind ar++    pp_normal_bind = hang (ppr val_bdr) 2 (equals <+> pprCoreExpr expr)++      -- For a join point of join arity n, we want to print j = \x1 ... xn -> e+      -- as "j x1 ... xn = e" to differentiate when a join point returns a+      -- lambda (the first rendering looks like a nullary join point returning+      -- an n-argument function).+    pp_join_bind join_arity+      = hang (ppr val_bdr <+> sep (map (pprBndr LambdaBind) lhs_bndrs))+           2 (equals <+> pprCoreExpr rhs)+      where+        (lhs_bndrs, rhs) = collectNBinders join_arity expr++pprParendExpr expr = ppr_expr parens expr+pprCoreExpr   expr = ppr_expr noParens expr++noParens :: SDoc -> SDoc+noParens pp = pp++pprOptCo :: Coercion -> SDoc+-- Print a coercion optionally; i.e. honouring -dsuppress-coercions+pprOptCo co = sdocWithDynFlags $ \dflags ->+              if gopt Opt_SuppressCoercions dflags+              then angleBrackets (text "Co:" <> int (coercionSize co))+              else parens (sep [ppr co, dcolon <+> ppr (coercionType co)])++ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc+        -- The function adds parens in context that need+        -- an atomic value (e.g. function args)++ppr_expr add_par (Var name)+ | isJoinId name               = add_par ((text "jump") <+> ppr name)+ | otherwise                   = ppr name+ppr_expr add_par (Type ty)     = add_par (text "TYPE:" <+> ppr ty)       -- Weird+ppr_expr add_par (Coercion co) = add_par (text "CO:" <+> ppr co)+ppr_expr add_par (Lit lit)     = pprLiteral add_par lit++ppr_expr add_par (Cast expr co)+  = add_par $ sep [pprParendExpr expr, text "`cast`" <+> pprOptCo co]++ppr_expr add_par expr@(Lam _ _)+  = let+        (bndrs, body) = collectBinders expr+    in+    add_par $+    hang (text "\\" <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)+         2 (pprCoreExpr body)++ppr_expr add_par expr@(App {})+  = sdocWithDynFlags $ \dflags ->+    case collectArgs expr of { (fun, args) ->+    let+        pp_args     = sep (map pprArg args)+        val_args    = dropWhile isTypeArg args   -- Drop the type arguments for tuples+        pp_tup_args = pprWithCommas pprCoreExpr val_args+        args'+          | gopt Opt_SuppressTypeApplications dflags = val_args+          | otherwise = args+        parens+          | null args' = id+          | otherwise  = add_par+    in+    case fun of+        Var f -> case isDataConWorkId_maybe f of+                        -- Notice that we print the *worker*+                        -- for tuples in paren'd format.+                   Just dc | saturated+                           , Just sort <- tyConTuple_maybe tc+                           -> tupleParens sort pp_tup_args+                           where+                             tc        = dataConTyCon dc+                             saturated = val_args `lengthIs` idArity f++                   _ -> parens (hang fun_doc 2 pp_args)+                   where+                     fun_doc | isJoinId f = text "jump" <+> ppr f+                             | otherwise  = ppr f++        _ -> parens (hang (pprParendExpr fun) 2 pp_args)+    }++ppr_expr add_par (Case expr var ty [(con,args,rhs)])+  = sdocWithDynFlags $ \dflags ->+    if gopt Opt_PprCaseAsLet dflags+    then add_par $  -- See Note [Print case as let]+         sep [ sep [ text "let! {"+                     <+> ppr_case_pat con args+                     <+> text "~"+                     <+> ppr_bndr var+                   , text "<-" <+> ppr_expr id expr+                     <+> text "} in" ]+             , pprCoreExpr rhs+             ]+    else add_par $+         sep [sep [sep [ text "case" <+> pprCoreExpr expr+                       , ifPprDebug (text "return" <+> ppr ty)+                       , text "of" <+> ppr_bndr var+                       ]+                  , char '{' <+> ppr_case_pat con args <+> arrow+                  ]+              , pprCoreExpr rhs+              , char '}'+              ]+  where+    ppr_bndr = pprBndr CaseBind++ppr_expr add_par (Case expr var ty alts)+  = add_par $+    sep [sep [text "case"+                <+> pprCoreExpr expr+                <+> ifPprDebug (text "return" <+> ppr ty),+              text "of" <+> ppr_bndr var <+> char '{'],+         nest 2 (vcat (punctuate semi (map pprCoreAlt alts))),+         char '}'+    ]+  where+    ppr_bndr = pprBndr CaseBind+++-- special cases: let ... in let ...+-- ("disgusting" SLPJ)++{-+ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)+  = add_par $+    vcat [+      hsep [text "let {", (pprBndr LetBind val_bdr $$ ppr val_bndr), equals],+      nest 2 (pprCoreExpr rhs),+      text "} in",+      pprCoreExpr body ]++ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))+  = add_par+    (hang (text "let {")+          2 (hsep [ppr_binding (val_bdr,rhs),+                   text "} in"])+     $$+     pprCoreExpr expr)+-}+++-- General case (recursive case, too)+ppr_expr add_par (Let bind expr)+  = add_par $+    sep [hang (keyword bind <+> char '{') 2 (ppr_bind noAnn bind <+> text "} in"),+         pprCoreExpr expr]+  where+    keyword (NonRec b _)+     | isJust (bndrIsJoin_maybe b) = text "join"+     | otherwise                   = text "let"+    keyword (Rec pairs)+     | ((b,_):_) <- pairs+     , isJust (bndrIsJoin_maybe b) = text "joinrec"+     | otherwise                   = text "letrec"++ppr_expr add_par (Tick tickish expr)+  = sdocWithDynFlags $ \dflags ->+  if gopt Opt_SuppressTicks dflags+  then ppr_expr add_par expr+  else add_par (sep [ppr tickish, pprCoreExpr expr])++pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc+pprCoreAlt (con, args, rhs)+  = hang (ppr_case_pat con args <+> arrow) 2 (pprCoreExpr rhs)++ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc+ppr_case_pat (DataAlt dc) args+  | Just sort <- tyConTuple_maybe tc+  = tupleParens sort (pprWithCommas ppr_bndr args)+  where+    ppr_bndr = pprBndr CasePatBind+    tc = dataConTyCon dc++ppr_case_pat con args+  = ppr con <+> (fsep (map ppr_bndr args))+  where+    ppr_bndr = pprBndr CasePatBind+++-- | Pretty print the argument in a function application.+pprArg :: OutputableBndr a => Expr a -> SDoc+pprArg (Type ty)+ = sdocWithDynFlags $ \dflags ->+   if gopt Opt_SuppressTypeApplications dflags+   then empty+   else text "@" <+> pprParendType ty+pprArg (Coercion co) = text "@~" <+> pprOptCo co+pprArg expr          = pprParendExpr expr++{-+Note [Print case as let]+~~~~~~~~~~~~~~~~~~~~~~~~+Single-branch case expressions are very common:+   case x of y { I# x' ->+   case p of q { I# p' -> ... } }+These are, in effect, just strict let's, with pattern matching.+With -dppr-case-as-let we print them as such:+   let! { I# x' ~ y <- x } in+   let! { I# p' ~ q <- p } in ...+++Other printing bits-and-bobs used with the general @pprCoreBinding@+and @pprCoreExpr@ functions.+++Note [Binding-site specific printing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++pprCoreBinder and pprTypedLamBinder receive a BindingSite argument to adjust+the information printed.++Let-bound binders are printed with their full type and idInfo.++Case-bound variables (both the case binder and pattern variables) are printed+without a type and without their unfolding.++Furthermore, a dead case-binder is completely ignored, while otherwise, dead+binders are printed as "_".+-}++-- These instances are sadly orphans++instance OutputableBndr Var where+  pprBndr = pprCoreBinder+  pprInfixOcc  = pprInfixName  . varName+  pprPrefixOcc = pprPrefixName . varName+  bndrIsJoin_maybe = isJoinId_maybe++instance Outputable b => OutputableBndr (TaggedBndr b) where+  pprBndr _    b = ppr b   -- Simple+  pprInfixOcc  b = ppr b+  pprPrefixOcc b = ppr b+  bndrIsJoin_maybe (TB b _) = isJoinId_maybe b++pprCoreBinder :: BindingSite -> Var -> SDoc+pprCoreBinder LetBind binder+  | isTyVar binder = pprKindedTyVarBndr binder+  | otherwise      = pprTypedLetBinder binder $$+                     ppIdInfo binder (idInfo binder)++-- Lambda bound type variables are preceded by "@"+pprCoreBinder bind_site bndr+  = getPprStyle $ \ sty ->+    pprTypedLamBinder bind_site (debugStyle sty) bndr++pprUntypedBinder :: Var -> SDoc+pprUntypedBinder binder+  | isTyVar binder = text "@" <+> ppr binder    -- NB: don't print kind+  | otherwise      = pprIdBndr binder++pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc+-- For lambda and case binders, show the unfolding info (usually none)+pprTypedLamBinder bind_site debug_on var+  = sdocWithDynFlags $ \dflags ->+    case () of+    _+      | not debug_on            -- Show case-bound wild bilders only if debug is on+      , CaseBind <- bind_site+      , isDeadBinder var        -> empty++      | not debug_on            -- Even dead binders can be one-shot+      , isDeadBinder var        -> char '_' <+> ppWhen (isId var)+                                                (pprIdBndrInfo (idInfo var))++      | not debug_on            -- No parens, no kind info+      , CaseBind <- bind_site   -> pprUntypedBinder var++      | not debug_on+      , CasePatBind <- bind_site    -> pprUntypedBinder var++      | suppress_sigs dflags    -> pprUntypedBinder var++      | isTyVar var  -> parens (pprKindedTyVarBndr var)++      | otherwise    -> parens (hang (pprIdBndr var)+                                   2 (vcat [ dcolon <+> pprType (idType var)+                                           , pp_unf]))+  where+    suppress_sigs = gopt Opt_SuppressTypeSignatures++    unf_info = unfoldingInfo (idInfo var)+    pp_unf | hasSomeUnfolding unf_info = text "Unf=" <> ppr unf_info+           | otherwise                 = empty++pprTypedLetBinder :: Var -> SDoc+-- Print binder with a type or kind signature (not paren'd)+pprTypedLetBinder binder+  = sdocWithDynFlags $ \dflags ->+    case () of+    _+      | isTyVar binder                         -> pprKindedTyVarBndr binder+      | gopt Opt_SuppressTypeSignatures dflags -> pprIdBndr binder+      | otherwise                              -> hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))++pprKindedTyVarBndr :: TyVar -> SDoc+-- Print a type variable binder with its kind (but not if *)+pprKindedTyVarBndr tyvar+  = text "@" <+> pprTyVar tyvar++-- pprIdBndr does *not* print the type+-- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness+pprIdBndr :: Id -> SDoc+pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)++pprIdBndrInfo :: IdInfo -> SDoc+pprIdBndrInfo info+  = sdocWithDynFlags $ \dflags ->+    ppUnless (gopt Opt_SuppressIdInfo dflags) $+    info `seq` doc -- The seq is useful for poking on black holes+  where+    prag_info = inlinePragInfo info+    occ_info  = occInfo info+    dmd_info  = demandInfo info+    lbv_info  = oneShotInfo info++    has_prag  = not (isDefaultInlinePragma prag_info)+    has_occ   = not (isManyOccs occ_info)+    has_dmd   = not $ isTopDmd dmd_info+    has_lbv   = not (hasNoOneShotInfo lbv_info)++    doc = showAttributes+          [ (has_prag, text "InlPrag=" <> pprInlineDebug prag_info)+          , (has_occ,  text "Occ=" <> ppr occ_info)+          , (has_dmd,  text "Dmd=" <> ppr dmd_info)+          , (has_lbv , text "OS=" <> ppr lbv_info)+          ]++{-+-----------------------------------------------------+--      IdDetails and IdInfo+-----------------------------------------------------+-}++ppIdInfo :: Id -> IdInfo -> SDoc+ppIdInfo id info+  = sdocWithDynFlags $ \dflags ->+    ppUnless (gopt Opt_SuppressIdInfo dflags) $+    showAttributes+    [ (True, pp_scope <> ppr (idDetails id))+    , (has_arity,        text "Arity=" <> int arity)+    , (has_called_arity, text "CallArity=" <> int called_arity)+    , (has_caf_info,     text "Caf=" <> ppr caf_info)+    , (has_str_info,     text "Str=" <> pprStrictness str_info)+    , (has_unf,          text "Unf=" <> ppr unf_info)+    , (not (null rules), text "RULES:" <+> vcat (map pprRule rules))+    ]   -- Inline pragma, occ, demand, one-shot info+        -- printed out with all binders (when debug is on);+        -- see PprCore.pprIdBndr+  where+    pp_scope | isGlobalId id   = text "GblId"+             | isExportedId id = text "LclIdX"+             | otherwise       = text "LclId"++    arity = arityInfo info+    has_arity = arity /= 0++    called_arity = callArityInfo info+    has_called_arity = called_arity /= 0++    caf_info = cafInfo info+    has_caf_info = not (mayHaveCafRefs caf_info)++    str_info = strictnessInfo info+    has_str_info = not (isTopSig str_info)++    unf_info = unfoldingInfo info+    has_unf = hasSomeUnfolding unf_info++    rules = ruleInfoRules (ruleInfo info)++showAttributes :: [(Bool,SDoc)] -> SDoc+showAttributes stuff+  | null docs = empty+  | otherwise = brackets (sep (punctuate comma docs))+  where+    docs = [d | (True,d) <- stuff]++{-+-----------------------------------------------------+--      Unfolding and UnfoldingGuidance+-----------------------------------------------------+-}++instance Outputable UnfoldingGuidance where+    ppr UnfNever  = text "NEVER"+    ppr (UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok })+      = text "ALWAYS_IF" <>+        parens (text "arity="     <> int arity    <> comma <>+                text "unsat_ok="  <> ppr unsat_ok <> comma <>+                text "boring_ok=" <> ppr boring_ok)+    ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount })+      = hsep [ text "IF_ARGS",+               brackets (hsep (map int cs)),+               int size,+               int discount ]++instance Outputable UnfoldingSource where+  ppr InlineCompulsory  = text "Compulsory"+  ppr InlineStable      = text "InlineStable"+  ppr InlineRhs         = text "<vanilla>"++instance Outputable Unfolding where+  ppr NoUnfolding                = text "No unfolding"+  ppr BootUnfolding              = text "No unfolding (from boot)"+  ppr (OtherCon cs)              = text "OtherCon" <+> ppr cs+  ppr (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args })+       = hang (text "DFun:" <+> ptext (sLit "\\")+                <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)+            2 (ppr con <+> sep (map ppr args))+  ppr (CoreUnfolding { uf_src = src+                     , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf+                     , uf_is_conlike=conlike, uf_is_work_free=wf+                     , uf_expandable=exp, uf_guidance=g })+        = text "Unf" <> braces (pp_info $$ pp_rhs)+    where+      pp_info = fsep $ punctuate comma+                [ text "Src="        <> ppr src+                , text "TopLvl="     <> ppr top+                , text "Value="      <> ppr hnf+                , text "ConLike="    <> ppr conlike+                , text "WorkFree="   <> ppr wf+                , text "Expandable=" <> ppr exp+                , text "Guidance="   <> ppr g ]+      pp_tmpl = sdocWithDynFlags $ \dflags ->+                ppUnless (gopt Opt_SuppressUnfoldings dflags) $+                text "Tmpl=" <+> ppr rhs+      pp_rhs | isStableSource src = pp_tmpl+             | otherwise          = empty+            -- Don't print the RHS or we get a quadratic+            -- blowup in the size of the printout!++{-+-----------------------------------------------------+--      Rules+-----------------------------------------------------+-}++instance Outputable CoreRule where+   ppr = pprRule++pprRules :: [CoreRule] -> SDoc+pprRules rules = vcat (map pprRule rules)++pprRule :: CoreRule -> SDoc+pprRule (BuiltinRule { ru_fn = fn, ru_name = name})+  = text "Built in rule for" <+> ppr fn <> colon <+> doubleQuotes (ftext name)++pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,+                ru_bndrs = tpl_vars, ru_args = tpl_args,+                ru_rhs = rhs })+  = hang (doubleQuotes (ftext name) <+> ppr act)+       4 (sep [text "forall" <+>+                  sep (map (pprCoreBinder LambdaBind) tpl_vars) <> dot,+               nest 2 (ppr fn <+> sep (map pprArg tpl_args)),+               nest 2 (text "=" <+> pprCoreExpr rhs)+            ])++{-+-----------------------------------------------------+--      Tickish+-----------------------------------------------------+-}++instance Outputable id => Outputable (Tickish id) where+  ppr (HpcTick modl ix) =+      hcat [text "hpc<",+            ppr modl, comma,+            ppr ix,+            text ">"]+  ppr (Breakpoint ix vars) =+      hcat [text "break<",+            ppr ix,+            text ">",+            parens (hcat (punctuate comma (map ppr vars)))]+  ppr (ProfNote { profNoteCC = cc,+                  profNoteCount = tick,+                  profNoteScope = scope }) =+      case (tick,scope) of+         (True,True)  -> hcat [text "scctick<", ppr cc, char '>']+         (True,False) -> hcat [text "tick<",    ppr cc, char '>']+         _            -> hcat [text "scc<",     ppr cc, char '>']+  ppr (SourceNote span _) =+      hcat [ text "src<", pprUserRealSpan True span, char '>']++{-+-----------------------------------------------------+--      Vectorisation declarations+-----------------------------------------------------+-}++instance Outputable CoreVect where+  ppr (Vect     var e)               = hang (text "VECTORISE" <+> ppr var <+> char '=')+                                         4 (pprCoreExpr e)+  ppr (NoVect   var)                 = text "NOVECTORISE" <+> ppr var+  ppr (VectType False var Nothing)   = text "VECTORISE type" <+> ppr var+  ppr (VectType True  var Nothing)   = text "VECTORISE SCALAR type" <+> ppr var+  ppr (VectType False var (Just tc)) = text "VECTORISE type" <+> ppr var <+> char '=' <+>+                                       ppr tc+  ppr (VectType True var (Just tc))  = text "VECTORISE SCALAR type" <+> ppr var <+>+                                       char '=' <+> ppr tc+  ppr (VectClass tc)                 = text "VECTORISE class" <+> ppr tc+  ppr (VectInst var)                 = text "VECTORISE SCALAR instance" <+> ppr var
+ coreSyn/TrieMap.hs view
@@ -0,0 +1,1129 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+module TrieMap(+   -- * Maps over Core expressions+   CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap,+   -- * Maps over 'Type's+   TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap, foldTypeMap,+   LooseTypeMap,+   -- ** With explicit scoping+   CmEnv, lookupCME, extendTypeMapWithScope, lookupTypeMapWithScope,+   mkDeBruijnContext,+   -- * Maps over 'Maybe' values+   MaybeMap,+   -- * Maps over 'List' values+   ListMap,+   -- * Maps over 'Literal's+   LiteralMap,+   -- * 'TrieMap' class+   TrieMap(..), insertTM, deleteTM,+   lkDFreeVar, xtDFreeVar,+   lkDNamed, xtDNamed,+   (>.>), (|>), (|>>),+ ) where++import CoreSyn+import Coercion+import Literal+import Name+import Type+import TyCoRep+import Var+import UniqDFM+import Unique( Unique )+import FastString(FastString)++import qualified Data.Map    as Map+import qualified Data.IntMap as IntMap+import VarEnv+import NameEnv+import Outputable+import Control.Monad( (>=>) )++{-+This module implements TrieMaps, which are finite mappings+whose key is a structured value like a CoreExpr or Type.++The code is very regular and boilerplate-like, but there is+some neat handling of *binders*.  In effect they are deBruijn+numbered on the fly.++The regular pattern for handling TrieMaps on data structures was first+described (to my knowledge) in Connelly and Morris's 1995 paper "A+generalization of the Trie Data Structure"; there is also an accessible+description of the idea in Okasaki's book "Purely Functional Data+Structures", Section 10.3.2++************************************************************************+*                                                                      *+                   The TrieMap class+*                                                                      *+************************************************************************+-}++type XT a = Maybe a -> Maybe a  -- How to alter a non-existent elt (Nothing)+                                --               or an existing elt (Just)++class TrieMap m where+   type Key m :: *+   emptyTM  :: m a+   lookupTM :: forall b. Key m -> m b -> Maybe b+   alterTM  :: forall b. Key m -> XT b -> m b -> m b+   mapTM    :: (a->b) -> m a -> m b++   foldTM   :: (a -> b -> b) -> m a -> b -> b+      -- The unusual argument order here makes+      -- it easy to compose calls to foldTM;+      -- see for example fdE below++insertTM :: TrieMap m => Key m -> a -> m a -> m a+insertTM k v m = alterTM k (\_ -> Just v) m++deleteTM :: TrieMap m => Key m -> m a -> m a+deleteTM k m = alterTM k (\_ -> Nothing) m++----------------------+-- Recall that+--   Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c++(>.>) :: (a -> b) -> (b -> c) -> a -> c+-- Reverse function composition (do f first, then g)+infixr 1 >.>+(f >.> g) x = g (f x)+infixr 1 |>, |>>++(|>) :: a -> (a->b) -> b     -- Reverse application+x |> f = f x++----------------------+(|>>) :: TrieMap m2+      => (XT (m2 a) -> m1 (m2 a) -> m1 (m2 a))+      -> (m2 a -> m2 a)+      -> m1 (m2 a) -> m1 (m2 a)+(|>>) f g = f (Just . g . deMaybe)++deMaybe :: TrieMap m => Maybe (m a) -> m a+deMaybe Nothing  = emptyTM+deMaybe (Just m) = m++{-+************************************************************************+*                                                                      *+                   IntMaps+*                                                                      *+************************************************************************+-}++instance TrieMap IntMap.IntMap where+  type Key IntMap.IntMap = Int+  emptyTM = IntMap.empty+  lookupTM k m = IntMap.lookup k m+  alterTM = xtInt+  foldTM k m z = IntMap.foldr k z m+  mapTM f m = IntMap.map f m++xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a+xtInt k f m = IntMap.alter f k m++instance Ord k => TrieMap (Map.Map k) where+  type Key (Map.Map k) = k+  emptyTM = Map.empty+  lookupTM = Map.lookup+  alterTM k f m = Map.alter f k m+  foldTM k m z = Map.foldr k z m+  mapTM f m = Map.map f m+++{-+Note [foldTM determinism]+~~~~~~~~~~~~~~~~~~~~~~~~~+We want foldTM to be deterministic, which is why we have an instance of+TrieMap for UniqDFM, but not for UniqFM. Here's an example of some things that+go wrong if foldTM is nondeterministic. Consider:++  f a b = return (a <> b)++Depending on the order that the typechecker generates constraints you+get either:++  f :: (Monad m, Monoid a) => a -> a -> m a++or:++  f :: (Monoid a, Monad m) => a -> a -> m a++The generated code will be different after desugaring as the dictionaries+will be bound in different orders, leading to potential ABI incompatibility.++One way to solve this would be to notice that the typeclasses could be+sorted alphabetically.++Unfortunately that doesn't quite work with this example:++  f a b = let x = a <> a; y = b <> b in x++where you infer:++  f :: (Monoid m, Monoid m1) => m1 -> m -> m1++or:++  f :: (Monoid m1, Monoid m) => m1 -> m -> m1++Here you could decide to take the order of the type variables in the type+according to depth first traversal and use it to order the constraints.++The real trouble starts when the user enables incoherent instances and+the compiler has to make an arbitrary choice. Consider:++  class T a b where+    go :: a -> b -> String++  instance (Show b) => T Int b where+    go a b = show a ++ show b++  instance (Show a) => T a Bool where+    go a b = show a ++ show b++  f = go 10 True++GHC is free to choose either dictionary to implement f, but for the sake of+determinism we'd like it to be consistent when compiling the same sources+with the same flags.++inert_dicts :: DictMap is implemented with a TrieMap. In getUnsolvedInerts it+gets converted to a bag of (Wanted) Cts using a fold. Then in+solve_simple_wanteds it's merged with other WantedConstraints. We want the+conversion to a bag to be deterministic. For that purpose we use UniqDFM+instead of UniqFM to implement the TrieMap.++See Note [Deterministic UniqFM] in UniqDFM for more details on how it's made+deterministic.+-}++instance TrieMap UniqDFM where+  type Key UniqDFM = Unique+  emptyTM = emptyUDFM+  lookupTM k m = lookupUDFM m k+  alterTM k f m = alterUDFM f m k+  foldTM k m z = foldUDFM k z m+  mapTM f m = mapUDFM f m++{-+************************************************************************+*                                                                      *+                   Maybes+*                                                                      *+************************************************************************++If              m is a map from k -> val+then (MaybeMap m) is a map from (Maybe k) -> val+-}++data MaybeMap m a = MM { mm_nothing  :: Maybe a, mm_just :: m a }++instance TrieMap m => TrieMap (MaybeMap m) where+   type Key (MaybeMap m) = Maybe (Key m)+   emptyTM  = MM { mm_nothing = Nothing, mm_just = emptyTM }+   lookupTM = lkMaybe lookupTM+   alterTM  = xtMaybe alterTM+   foldTM   = fdMaybe+   mapTM    = mapMb++mapMb :: TrieMap m => (a->b) -> MaybeMap m a -> MaybeMap m b+mapMb f (MM { mm_nothing = mn, mm_just = mj })+  = MM { mm_nothing = fmap f mn, mm_just = mapTM f mj }++lkMaybe :: (forall b. k -> m b -> Maybe b)+        -> Maybe k -> MaybeMap m a -> Maybe a+lkMaybe _  Nothing  = mm_nothing+lkMaybe lk (Just x) = mm_just >.> lk x++xtMaybe :: (forall b. k -> XT b -> m b -> m b)+        -> Maybe k -> XT a -> MaybeMap m a -> MaybeMap m a+xtMaybe _  Nothing  f m = m { mm_nothing  = f (mm_nothing m) }+xtMaybe tr (Just x) f m = m { mm_just = mm_just m |> tr x f }++fdMaybe :: TrieMap m => (a -> b -> b) -> MaybeMap m a -> b -> b+fdMaybe k m = foldMaybe k (mm_nothing m)+            . foldTM k (mm_just m)++{-+************************************************************************+*                                                                      *+                   Lists+*                                                                      *+************************************************************************+-}++data ListMap m a+  = LM { lm_nil  :: Maybe a+       , lm_cons :: m (ListMap m a) }++instance TrieMap m => TrieMap (ListMap m) where+   type Key (ListMap m) = [Key m]+   emptyTM  = LM { lm_nil = Nothing, lm_cons = emptyTM }+   lookupTM = lkList lookupTM+   alterTM  = xtList alterTM+   foldTM   = fdList+   mapTM    = mapList++mapList :: TrieMap m => (a->b) -> ListMap m a -> ListMap m b+mapList f (LM { lm_nil = mnil, lm_cons = mcons })+  = LM { lm_nil = fmap f mnil, lm_cons = mapTM (mapTM f) mcons }++lkList :: TrieMap m => (forall b. k -> m b -> Maybe b)+        -> [k] -> ListMap m a -> Maybe a+lkList _  []     = lm_nil+lkList lk (x:xs) = lm_cons >.> lk x >=> lkList lk xs++xtList :: TrieMap m => (forall b. k -> XT b -> m b -> m b)+        -> [k] -> XT a -> ListMap m a -> ListMap m a+xtList _  []     f m = m { lm_nil  = f (lm_nil m) }+xtList tr (x:xs) f m = m { lm_cons = lm_cons m |> tr x |>> xtList tr xs f }++fdList :: forall m a b. TrieMap m+       => (a -> b -> b) -> ListMap m a -> b -> b+fdList k m = foldMaybe k          (lm_nil m)+           . foldTM    (fdList k) (lm_cons m)++foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b+foldMaybe _ Nothing  b = b+foldMaybe k (Just a) b = k a b++{-+************************************************************************+*                                                                      *+                   Basic maps+*                                                                      *+************************************************************************+-}++lkDNamed :: NamedThing n => n -> DNameEnv a -> Maybe a+lkDNamed n env = lookupDNameEnv env (getName n)++xtDNamed :: NamedThing n => n -> XT a -> DNameEnv a -> DNameEnv a+xtDNamed tc f m = alterDNameEnv f m (getName tc)++------------------------+type LiteralMap  a = Map.Map Literal a++emptyLiteralMap :: LiteralMap a+emptyLiteralMap = emptyTM++lkLit :: Literal -> LiteralMap a -> Maybe a+lkLit = lookupTM++xtLit :: Literal -> XT a -> LiteralMap a -> LiteralMap a+xtLit = alterTM++{-+************************************************************************+*                                                                      *+                   GenMap+*                                                                      *+************************************************************************++Note [Compressed TrieMap]+~~~~~~~~~~~~~~~~~~~~~~~~~++The GenMap constructor augments TrieMaps with leaf compression.  This helps+solve the performance problem detailed in #9960: suppose we have a handful+H of entries in a TrieMap, each with a very large key, size K. If you fold over+such a TrieMap you'd expect time O(H). That would certainly be true of an+association list! But with TrieMap we actually have to navigate down a long+singleton structure to get to the elements, so it takes time O(K*H).  This+can really hurt on many type-level computation benchmarks:+see for example T9872d.++The point of a TrieMap is that you need to navigate to the point where only one+key remains, and then things should be fast.  So the point of a SingletonMap+is that, once we are down to a single (key,value) pair, we stop and+just use SingletonMap.++'EmptyMap' provides an even more basic (but essential) optimization: if there is+nothing in the map, don't bother building out the (possibly infinite) recursive+TrieMap structure!+-}++data GenMap m a+   = EmptyMap+   | SingletonMap (Key m) a+   | MultiMap (m a)++instance (Outputable a, Outputable (m a)) => Outputable (GenMap m a) where+  ppr EmptyMap = text "Empty map"+  ppr (SingletonMap _ v) = text "Singleton map" <+> ppr v+  ppr (MultiMap m) = ppr m++-- TODO undecidable instance+instance (Eq (Key m), TrieMap m) => TrieMap (GenMap m) where+   type Key (GenMap m) = Key m+   emptyTM  = EmptyMap+   lookupTM = lkG+   alterTM  = xtG+   foldTM   = fdG+   mapTM    = mapG++-- NB: Be careful about RULES and type families (#5821).  So we should make sure+-- to specify @Key TypeMapX@ (and not @DeBruijn Type@, the reduced form)++{-# SPECIALIZE lkG :: Key TypeMapX     -> TypeMapG a     -> Maybe a #-}+{-# SPECIALIZE lkG :: Key CoercionMapX -> CoercionMapG a -> Maybe a #-}+{-# SPECIALIZE lkG :: Key CoreMapX     -> CoreMapG a     -> Maybe a #-}+lkG :: (Eq (Key m), TrieMap m) => Key m -> GenMap m a -> Maybe a+lkG _ EmptyMap                         = Nothing+lkG k (SingletonMap k' v') | k == k'   = Just v'+                           | otherwise = Nothing+lkG k (MultiMap m)                     = lookupTM k m++{-# SPECIALIZE xtG :: Key TypeMapX     -> XT a -> TypeMapG a -> TypeMapG a #-}+{-# SPECIALIZE xtG :: Key CoercionMapX -> XT a -> CoercionMapG a -> CoercionMapG a #-}+{-# SPECIALIZE xtG :: Key CoreMapX     -> XT a -> CoreMapG a -> CoreMapG a #-}+xtG :: (Eq (Key m), TrieMap m) => Key m -> XT a -> GenMap m a -> GenMap m a+xtG k f EmptyMap+    = case f Nothing of+        Just v  -> SingletonMap k v+        Nothing -> EmptyMap+xtG k f m@(SingletonMap k' v')+    | k' == k+    -- The new key matches the (single) key already in the tree.  Hence,+    -- apply @f@ to @Just v'@ and build a singleton or empty map depending+    -- on the 'Just'/'Nothing' response respectively.+    = case f (Just v') of+        Just v'' -> SingletonMap k' v''+        Nothing  -> EmptyMap+    | otherwise+    -- We've hit a singleton tree for a different key than the one we are+    -- searching for. Hence apply @f@ to @Nothing@. If result is @Nothing@ then+    -- we can just return the old map. If not, we need a map with *two*+    -- entries. The easiest way to do that is to insert two items into an empty+    -- map of type @m a@.+    = case f Nothing of+        Nothing  -> m+        Just v   -> emptyTM |> alterTM k' (const (Just v'))+                           >.> alterTM k  (const (Just v))+                           >.> MultiMap+xtG k f (MultiMap m) = MultiMap (alterTM k f m)++{-# SPECIALIZE mapG :: (a -> b) -> TypeMapG a     -> TypeMapG b #-}+{-# SPECIALIZE mapG :: (a -> b) -> CoercionMapG a -> CoercionMapG b #-}+{-# SPECIALIZE mapG :: (a -> b) -> CoreMapG a     -> CoreMapG b #-}+mapG :: TrieMap m => (a -> b) -> GenMap m a -> GenMap m b+mapG _ EmptyMap = EmptyMap+mapG f (SingletonMap k v) = SingletonMap k (f v)+mapG f (MultiMap m) = MultiMap (mapTM f m)++{-# SPECIALIZE fdG :: (a -> b -> b) -> TypeMapG a     -> b -> b #-}+{-# SPECIALIZE fdG :: (a -> b -> b) -> CoercionMapG a -> b -> b #-}+{-# SPECIALIZE fdG :: (a -> b -> b) -> CoreMapG a     -> b -> b #-}+fdG :: TrieMap m => (a -> b -> b) -> GenMap m a -> b -> b+fdG _ EmptyMap = \z -> z+fdG k (SingletonMap _ v) = \z -> k v z+fdG k (MultiMap m) = foldTM k m++{-+************************************************************************+*                                                                      *+                   CoreMap+*                                                                      *+************************************************************************++Note [Binders]+~~~~~~~~~~~~~~+ * In general we check binders as late as possible because types are+   less likely to differ than expression structure.  That's why+      cm_lam :: CoreMapG (TypeMapG a)+   rather than+      cm_lam :: TypeMapG (CoreMapG a)++ * We don't need to look at the type of some binders, notalby+     - the case binder in (Case _ b _ _)+     - the binders in an alternative+   because they are totally fixed by the context++Note [Empty case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* For a key (Case e b ty (alt:alts))  we don't need to look the return type+  'ty', because every alternative has that type.++* For a key (Case e b ty []) we MUST look at the return type 'ty', because+  otherwise (Case (error () "urk") _ Int  []) would compare equal to+            (Case (error () "urk") _ Bool [])+  which is utterly wrong (Trac #6097)++We could compare the return type regardless, but the wildly common case+is that it's unnecessary, so we have two fields (cm_case and cm_ecase)+for the two possibilities.  Only cm_ecase looks at the type.++See also Note [Empty case alternatives] in CoreSyn.+-}++-- | @CoreMap a@ is a map from 'CoreExpr' to @a@.  If you are a client, this+-- is the type you want.+newtype CoreMap a = CoreMap (CoreMapG a)++instance TrieMap CoreMap where+    type Key CoreMap = CoreExpr+    emptyTM = CoreMap emptyTM+    lookupTM k (CoreMap m) = lookupTM (deBruijnize k) m+    alterTM k f (CoreMap m) = CoreMap (alterTM (deBruijnize k) f m)+    foldTM k (CoreMap m) = foldTM k m+    mapTM f (CoreMap m) = CoreMap (mapTM f m)++-- | @CoreMapG a@ is a map from @DeBruijn CoreExpr@ to @a@.  The extended+-- key makes it suitable for recursive traversal, since it can track binders,+-- but it is strictly internal to this module.  If you are including a 'CoreMap'+-- inside another 'TrieMap', this is the type you want.+type CoreMapG = GenMap CoreMapX++-- | @CoreMapX a@ is the base map from @DeBruijn CoreExpr@ to @a@, but without+-- the 'GenMap' optimization.+data CoreMapX a+  = CM { cm_var   :: VarMap a+       , cm_lit   :: LiteralMap a+       , cm_co    :: CoercionMapG a+       , cm_type  :: TypeMapG a+       , cm_cast  :: CoreMapG (CoercionMapG a)+       , cm_tick  :: CoreMapG (TickishMap a)+       , cm_app   :: CoreMapG (CoreMapG a)+       , cm_lam   :: CoreMapG (BndrMap a)    -- Note [Binders]+       , cm_letn  :: CoreMapG (CoreMapG (BndrMap a))+       , cm_letr  :: ListMap CoreMapG (CoreMapG (ListMap BndrMap a))+       , cm_case  :: CoreMapG (ListMap AltMap a)+       , cm_ecase :: CoreMapG (TypeMapG a)    -- Note [Empty case alternatives]+     }++instance Eq (DeBruijn CoreExpr) where+  D env1 e1 == D env2 e2 = go e1 e2 where+    go (Var v1) (Var v2) = case (lookupCME env1 v1, lookupCME env2 v2) of+                            (Just b1, Just b2) -> b1 == b2+                            (Nothing, Nothing) -> v1 == v2+                            _ -> False+    go (Lit lit1)    (Lit lit2)      = lit1 == lit2+    go (Type t1)    (Type t2)        = D env1 t1 == D env2 t2+    go (Coercion co1) (Coercion co2) = D env1 co1 == D env2 co2+    go (Cast e1 co1) (Cast e2 co2) = D env1 co1 == D env2 co2 && go e1 e2+    go (App f1 a1)   (App f2 a2)   = go f1 f2 && go a1 a2+    -- This seems a bit dodgy, see 'eqTickish'+    go (Tick n1 e1)  (Tick n2 e2)  = n1 == n2 && go e1 e2++    go (Lam b1 e1)  (Lam b2 e2)+      =  D env1 (varType b1) == D env2 (varType b2)+      && D (extendCME env1 b1) e1 == D (extendCME env2 b2) e2++    go (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2)+      =  go r1 r2+      && D (extendCME env1 v1) e1 == D (extendCME env2 v2) e2++    go (Let (Rec ps1) e1) (Let (Rec ps2) e2)+      = length ps1 == length ps2+      && D env1' rs1 == D env2' rs2+      && D env1' e1  == D env2' e2+      where+        (bs1,rs1) = unzip ps1+        (bs2,rs2) = unzip ps2+        env1' = extendCMEs env1 bs1+        env2' = extendCMEs env2 bs2++    go (Case e1 b1 t1 a1) (Case e2 b2 t2 a2)+      | null a1   -- See Note [Empty case alternatives]+      = null a2 && go e1 e2 && D env1 t1 == D env2 t2+      | otherwise+      =  go e1 e2 && D (extendCME env1 b1) a1 == D (extendCME env2 b2) a2++    go _ _ = False++emptyE :: CoreMapX a+emptyE = CM { cm_var = emptyTM, cm_lit = emptyLiteralMap+            , cm_co = emptyTM, cm_type = emptyTM+            , cm_cast = emptyTM, cm_app = emptyTM+            , cm_lam = emptyTM, cm_letn = emptyTM+            , cm_letr = emptyTM, cm_case = emptyTM+            , cm_ecase = emptyTM, cm_tick = emptyTM }++instance TrieMap CoreMapX where+   type Key CoreMapX = DeBruijn CoreExpr+   emptyTM  = emptyE+   lookupTM = lkE+   alterTM  = xtE+   foldTM   = fdE+   mapTM    = mapE++--------------------------+mapE :: (a->b) -> CoreMapX a -> CoreMapX b+mapE f (CM { cm_var = cvar, cm_lit = clit+           , cm_co = cco, cm_type = ctype+           , cm_cast = ccast , cm_app = capp+           , cm_lam = clam, cm_letn = cletn+           , cm_letr = cletr, cm_case = ccase+           , cm_ecase = cecase, cm_tick = ctick })+  = CM { cm_var = mapTM f cvar, cm_lit = mapTM f clit+       , cm_co = mapTM f cco, cm_type = mapTM f ctype+       , cm_cast = mapTM (mapTM f) ccast, cm_app = mapTM (mapTM f) capp+       , cm_lam = mapTM (mapTM f) clam, cm_letn = mapTM (mapTM (mapTM f)) cletn+       , cm_letr = mapTM (mapTM (mapTM f)) cletr, cm_case = mapTM (mapTM f) ccase+       , cm_ecase = mapTM (mapTM f) cecase, cm_tick = mapTM (mapTM f) ctick }++--------------------------+lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a+lookupCoreMap cm e = lookupTM e cm++extendCoreMap :: CoreMap a -> CoreExpr -> a -> CoreMap a+extendCoreMap m e v = alterTM e (\_ -> Just v) m++foldCoreMap :: (a -> b -> b) -> b -> CoreMap a -> b+foldCoreMap k z m = foldTM k m z++emptyCoreMap :: CoreMap a+emptyCoreMap = emptyTM++instance Outputable a => Outputable (CoreMap a) where+  ppr m = text "CoreMap elts" <+> ppr (foldTM (:) m [])++-------------------------+fdE :: (a -> b -> b) -> CoreMapX a -> b -> b+fdE k m+  = foldTM k (cm_var m)+  . foldTM k (cm_lit m)+  . foldTM k (cm_co m)+  . foldTM k (cm_type m)+  . foldTM (foldTM k) (cm_cast m)+  . foldTM (foldTM k) (cm_tick m)+  . foldTM (foldTM k) (cm_app m)+  . foldTM (foldTM k) (cm_lam m)+  . foldTM (foldTM (foldTM k)) (cm_letn m)+  . foldTM (foldTM (foldTM k)) (cm_letr m)+  . foldTM (foldTM k) (cm_case m)+  . foldTM (foldTM k) (cm_ecase m)++-- lkE: lookup in trie for expressions+lkE :: DeBruijn CoreExpr -> CoreMapX a -> Maybe a+lkE (D env expr) cm = go expr cm+  where+    go (Var v)              = cm_var  >.> lkVar env v+    go (Lit l)              = cm_lit  >.> lkLit l+    go (Type t)             = cm_type >.> lkG (D env t)+    go (Coercion c)         = cm_co   >.> lkG (D env c)+    go (Cast e c)           = cm_cast >.> lkG (D env e) >=> lkG (D env c)+    go (Tick tickish e)     = cm_tick >.> lkG (D env e) >=> lkTickish tickish+    go (App e1 e2)          = cm_app  >.> lkG (D env e2) >=> lkG (D env e1)+    go (Lam v e)            = cm_lam  >.> lkG (D (extendCME env v) e)+                              >=> lkBndr env v+    go (Let (NonRec b r) e) = cm_letn >.> lkG (D env r)+                              >=> lkG (D (extendCME env b) e) >=> lkBndr env b+    go (Let (Rec prs) e)    = let (bndrs,rhss) = unzip prs+                                  env1 = extendCMEs env bndrs+                              in cm_letr+                                 >.> lkList (lkG . D env1) rhss+                                 >=> lkG (D env1 e)+                                 >=> lkList (lkBndr env1) bndrs+    go (Case e b ty as)     -- See Note [Empty case alternatives]+               | null as    = cm_ecase >.> lkG (D env e) >=> lkG (D env ty)+               | otherwise  = cm_case >.> lkG (D env e)+                              >=> lkList (lkA (extendCME env b)) as++xtE :: DeBruijn CoreExpr -> XT a -> CoreMapX a -> CoreMapX a+xtE (D env (Var v))              f m = m { cm_var  = cm_var m+                                                 |> xtVar env v f }+xtE (D env (Type t))             f m = m { cm_type = cm_type m+                                                 |> xtG (D env t) f }+xtE (D env (Coercion c))         f m = m { cm_co   = cm_co m+                                                 |> xtG (D env c) f }+xtE (D _   (Lit l))              f m = m { cm_lit  = cm_lit m  |> xtLit l f }+xtE (D env (Cast e c))           f m = m { cm_cast = cm_cast m |> xtG (D env e)+                                                 |>> xtG (D env c) f }+xtE (D env (Tick t e))           f m = m { cm_tick = cm_tick m |> xtG (D env e)+                                                 |>> xtTickish t f }+xtE (D env (App e1 e2))          f m = m { cm_app = cm_app m |> xtG (D env e2)+                                                 |>> xtG (D env e1) f }+xtE (D env (Lam v e))            f m = m { cm_lam = cm_lam m+                                                 |> xtG (D (extendCME env v) e)+                                                 |>> xtBndr env v f }+xtE (D env (Let (NonRec b r) e)) f m = m { cm_letn = cm_letn m+                                                 |> xtG (D (extendCME env b) e)+                                                 |>> xtG (D env r)+                                                 |>> xtBndr env b f }+xtE (D env (Let (Rec prs) e))    f m = m { cm_letr =+                                              let (bndrs,rhss) = unzip prs+                                                  env1 = extendCMEs env bndrs+                                              in cm_letr m+                                                 |>  xtList (xtG . D env1) rhss+                                                 |>> xtG (D env1 e)+                                                 |>> xtList (xtBndr env1)+                                                            bndrs f }+xtE (D env (Case e b ty as))     f m+                     | null as   = m { cm_ecase = cm_ecase m |> xtG (D env e)+                                                 |>> xtG (D env ty) f }+                     | otherwise = m { cm_case = cm_case m |> xtG (D env e)+                                                 |>> let env1 = extendCME env b+                                                     in xtList (xtA env1) as f }++-- TODO: this seems a bit dodgy, see 'eqTickish'+type TickishMap a = Map.Map (Tickish Id) a+lkTickish :: Tickish Id -> TickishMap a -> Maybe a+lkTickish = lookupTM++xtTickish :: Tickish Id -> XT a -> TickishMap a -> TickishMap a+xtTickish = alterTM++------------------------+data AltMap a   -- A single alternative+  = AM { am_deflt :: CoreMapG a+       , am_data  :: DNameEnv (CoreMapG a)+       , am_lit   :: LiteralMap (CoreMapG a) }++instance TrieMap AltMap where+   type Key AltMap = CoreAlt+   emptyTM  = AM { am_deflt = emptyTM+                 , am_data = emptyDNameEnv+                 , am_lit  = emptyLiteralMap }+   lookupTM = lkA emptyCME+   alterTM  = xtA emptyCME+   foldTM   = fdA+   mapTM    = mapA++instance Eq (DeBruijn CoreAlt) where+  D env1 a1 == D env2 a2 = go a1 a2 where+    go (DEFAULT, _, rhs1) (DEFAULT, _, rhs2)+        = D env1 rhs1 == D env2 rhs2+    go (LitAlt lit1, _, rhs1) (LitAlt lit2, _, rhs2)+        = lit1 == lit2 && D env1 rhs1 == D env2 rhs2+    go (DataAlt dc1, bs1, rhs1) (DataAlt dc2, bs2, rhs2)+        = dc1 == dc2 &&+          D (extendCMEs env1 bs1) rhs1 == D (extendCMEs env2 bs2) rhs2+    go _ _ = False++mapA :: (a->b) -> AltMap a -> AltMap b+mapA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })+  = AM { am_deflt = mapTM f adeflt+       , am_data = mapTM (mapTM f) adata+       , am_lit = mapTM (mapTM f) alit }++lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a+lkA env (DEFAULT,    _, rhs)  = am_deflt >.> lkG (D env rhs)+lkA env (LitAlt lit, _, rhs)  = am_lit >.> lkLit lit >=> lkG (D env rhs)+lkA env (DataAlt dc, bs, rhs) = am_data >.> lkDNamed dc+                                        >=> lkG (D (extendCMEs env bs) rhs)++xtA :: CmEnv -> CoreAlt -> XT a -> AltMap a -> AltMap a+xtA env (DEFAULT, _, rhs)    f m =+    m { am_deflt = am_deflt m |> xtG (D env rhs) f }+xtA env (LitAlt l, _, rhs)   f m =+    m { am_lit   = am_lit m   |> xtLit l |>> xtG (D env rhs) f }+xtA env (DataAlt d, bs, rhs) f m =+    m { am_data  = am_data m  |> xtDNamed d+                             |>> xtG (D (extendCMEs env bs) rhs) f }++fdA :: (a -> b -> b) -> AltMap a -> b -> b+fdA k m = foldTM k (am_deflt m)+        . foldTM (foldTM k) (am_data m)+        . foldTM (foldTM k) (am_lit m)++{-+************************************************************************+*                                                                      *+                   Coercions+*                                                                      *+************************************************************************+-}++-- We should really never care about the contents of a coercion. Instead,+-- just look up the coercion's type.+newtype CoercionMap a = CoercionMap (CoercionMapG a)++instance TrieMap CoercionMap where+   type Key CoercionMap = Coercion+   emptyTM                     = CoercionMap emptyTM+   lookupTM k  (CoercionMap m) = lookupTM (deBruijnize k) m+   alterTM k f (CoercionMap m) = CoercionMap (alterTM (deBruijnize k) f m)+   foldTM k    (CoercionMap m) = foldTM k m+   mapTM f     (CoercionMap m) = CoercionMap (mapTM f m)++type CoercionMapG = GenMap CoercionMapX+newtype CoercionMapX a = CoercionMapX (TypeMapX a)++instance TrieMap CoercionMapX where+  type Key CoercionMapX = DeBruijn Coercion+  emptyTM = CoercionMapX emptyTM+  lookupTM = lkC+  alterTM  = xtC+  foldTM f (CoercionMapX core_tm) = foldTM f core_tm+  mapTM f (CoercionMapX core_tm)  = CoercionMapX (mapTM f core_tm)++instance Eq (DeBruijn Coercion) where+  D env1 co1 == D env2 co2+    = D env1 (coercionType co1) ==+      D env2 (coercionType co2)++lkC :: DeBruijn Coercion -> CoercionMapX a -> Maybe a+lkC (D env co) (CoercionMapX core_tm) = lkT (D env $ coercionType co)+                                        core_tm++xtC :: DeBruijn Coercion -> XT a -> CoercionMapX a -> CoercionMapX a+xtC (D env co) f (CoercionMapX m)+  = CoercionMapX (xtT (D env $ coercionType co) f m)++{-+************************************************************************+*                                                                      *+                   Types+*                                                                      *+************************************************************************+-}++-- | @TypeMapG a@ is a map from @DeBruijn Type@ to @a@.  The extended+-- key makes it suitable for recursive traversal, since it can track binders,+-- but it is strictly internal to this module.  If you are including a 'TypeMap'+-- inside another 'TrieMap', this is the type you want. Note that this+-- lookup does not do a kind-check. Thus, all keys in this map must have+-- the same kind. Also note that this map respects the distinction between+-- @Type@ and @Constraint@, despite the fact that they are equivalent type+-- synonyms in Core.+type TypeMapG = GenMap TypeMapX++-- | @TypeMapX a@ is the base map from @DeBruijn Type@ to @a@, but without the+-- 'GenMap' optimization.+data TypeMapX a+  = TM { tm_var    :: VarMap a+       , tm_app    :: TypeMapG (TypeMapG a)+       , tm_tycon  :: DNameEnv a+       , tm_forall :: TypeMapG (BndrMap a) -- See Note [Binders]+       , tm_tylit  :: TyLitMap a+       , tm_coerce :: Maybe a+       }+    -- Note that there is no tyconapp case; see Note [Equality on AppTys] in Type++-- | Squeeze out any synonyms, and change TyConApps to nested AppTys. Why the+-- last one? See Note [Equality on AppTys] in Type+--+-- Note, however, that we keep Constraint and Type apart here, despite the fact+-- that they are both synonyms of TYPE 'LiftedRep (see #11715).+trieMapView :: Type -> Maybe Type+trieMapView ty+  -- First check for TyConApps that need to be expanded to+  -- AppTy chains.+  | Just (tc, tys@(_:_)) <- tcSplitTyConApp_maybe ty+  = Just $ foldl AppTy (TyConApp tc []) tys++  -- Then resolve any remaining nullary synonyms.+  | Just ty' <- tcView ty = Just ty'+trieMapView _ = Nothing++instance TrieMap TypeMapX where+   type Key TypeMapX = DeBruijn Type+   emptyTM  = emptyT+   lookupTM = lkT+   alterTM  = xtT+   foldTM   = fdT+   mapTM    = mapT++instance Eq (DeBruijn Type) where+  env_t@(D env t) == env_t'@(D env' t')+    | Just new_t  <- tcView t  = D env new_t == env_t'+    | Just new_t' <- tcView t' = env_t       == D env' new_t'+    | otherwise+    = case (t, t') of+        (CastTy t1 _, _)  -> D env t1 == D env t'+        (_, CastTy t1' _) -> D env t  == D env t1'++        (TyVarTy v, TyVarTy v')+            -> case (lookupCME env v, lookupCME env' v') of+                (Just bv, Just bv') -> bv == bv'+                (Nothing, Nothing)  -> v == v'+                _ -> False+                -- See Note [Equality on AppTys] in Type+        (AppTy t1 t2, s) | Just (t1', t2') <- repSplitAppTy_maybe s+            -> D env t1 == D env' t1' && D env t2 == D env' t2'+        (s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_maybe s+            -> D env t1 == D env' t1' && D env t2 == D env' t2'+        (FunTy t1 t2, FunTy t1' t2')+            -> D env t1 == D env' t1' && D env t2 == D env' t2'+        (TyConApp tc tys, TyConApp tc' tys')+            -> tc == tc' && D env tys == D env' tys'+        (LitTy l, LitTy l')+            -> l == l'+        (ForAllTy (TvBndr tv _) ty, ForAllTy (TvBndr tv' _) ty')+            -> D env (tyVarKind tv)    == D env' (tyVarKind tv') &&+               D (extendCME env tv) ty == D (extendCME env' tv') ty'+        (CoercionTy {}, CoercionTy {})+            -> True+        _ -> False++instance {-# OVERLAPPING #-}+         Outputable a => Outputable (TypeMapG a) where+  ppr m = text "TypeMap elts" <+> ppr (foldTM (:) m [])++emptyT :: TypeMapX a+emptyT = TM { tm_var  = emptyTM+            , tm_app  = EmptyMap+            , tm_tycon  = emptyDNameEnv+            , tm_forall = EmptyMap+            , tm_tylit  = emptyTyLitMap+            , tm_coerce = Nothing }++mapT :: (a->b) -> TypeMapX a -> TypeMapX b+mapT f (TM { tm_var  = tvar, tm_app = tapp, tm_tycon = ttycon+           , tm_forall = tforall, tm_tylit = tlit+           , tm_coerce = tcoerce })+  = TM { tm_var    = mapTM f tvar+       , tm_app    = mapTM (mapTM f) tapp+       , tm_tycon  = mapTM f ttycon+       , tm_forall = mapTM (mapTM f) tforall+       , tm_tylit  = mapTM f tlit+       , tm_coerce = fmap f tcoerce }++-----------------+lkT :: DeBruijn Type -> TypeMapX a -> Maybe a+lkT (D env ty) m = go ty m+  where+    go ty | Just ty' <- trieMapView ty = go ty'+    go (TyVarTy v)                 = tm_var    >.> lkVar env v+    go (AppTy t1 t2)               = tm_app    >.> lkG (D env t1)+                                               >=> lkG (D env t2)+    go (TyConApp tc [])            = tm_tycon  >.> lkDNamed tc+    go ty@(TyConApp _ (_:_))       = pprPanic "lkT TyConApp" (ppr ty)+    go (LitTy l)                   = tm_tylit  >.> lkTyLit l+    go (ForAllTy (TvBndr tv _) ty) = tm_forall >.> lkG (D (extendCME env tv) ty)+                                               >=> lkBndr env tv+    go ty@(FunTy {})               = pprPanic "lkT FunTy" (ppr ty)+    go (CastTy t _)                = go t+    go (CoercionTy {})             = tm_coerce++-----------------+xtT :: DeBruijn Type -> XT a -> TypeMapX a -> TypeMapX a+xtT (D env ty) f m | Just ty' <- trieMapView ty = xtT (D env ty') f m++xtT (D env (TyVarTy v))       f m = m { tm_var    = tm_var m |> xtVar env v f }+xtT (D env (AppTy t1 t2))     f m = m { tm_app    = tm_app m |> xtG (D env t1)+                                                            |>> xtG (D env t2) f }+xtT (D _   (TyConApp tc []))  f m = m { tm_tycon  = tm_tycon m |> xtDNamed tc f }+xtT (D _   (LitTy l))         f m = m { tm_tylit  = tm_tylit m |> xtTyLit l f }+xtT (D env (CastTy t _))      f m = xtT (D env t) f m+xtT (D _   (CoercionTy {}))   f m = m { tm_coerce = tm_coerce m |> f }+xtT (D env (ForAllTy (TvBndr tv _) ty))  f m+  = m { tm_forall = tm_forall m |> xtG (D (extendCME env tv) ty)+                                |>> xtBndr env tv f }+xtT (D _   ty@(TyConApp _ (_:_))) _ _ = pprPanic "xtT TyConApp" (ppr ty)+xtT (D _   ty@(FunTy {}))         _ _ = pprPanic "xtT FunTy" (ppr ty)++fdT :: (a -> b -> b) -> TypeMapX a -> b -> b+fdT k m = foldTM k (tm_var m)+        . foldTM (foldTM k) (tm_app m)+        . foldTM k (tm_tycon m)+        . foldTM (foldTM k) (tm_forall m)+        . foldTyLit k (tm_tylit m)+        . foldMaybe k (tm_coerce m)++------------------------+data TyLitMap a = TLM { tlm_number :: Map.Map Integer a+                      , tlm_string :: Map.Map FastString a+                      }++instance TrieMap TyLitMap where+   type Key TyLitMap = TyLit+   emptyTM  = emptyTyLitMap+   lookupTM = lkTyLit+   alterTM  = xtTyLit+   foldTM   = foldTyLit+   mapTM    = mapTyLit++emptyTyLitMap :: TyLitMap a+emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = Map.empty }++mapTyLit :: (a->b) -> TyLitMap a -> TyLitMap b+mapTyLit f (TLM { tlm_number = tn, tlm_string = ts })+  = TLM { tlm_number = Map.map f tn, tlm_string = Map.map f ts }++lkTyLit :: TyLit -> TyLitMap a -> Maybe a+lkTyLit l =+  case l of+    NumTyLit n -> tlm_number >.> Map.lookup n+    StrTyLit n -> tlm_string >.> Map.lookup n++xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a+xtTyLit l f m =+  case l of+    NumTyLit n -> m { tlm_number = tlm_number m |> Map.alter f n }+    StrTyLit n -> m { tlm_string = tlm_string m |> Map.alter f n }++foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b+foldTyLit l m = flip (Map.foldr l) (tlm_string m)+              . flip (Map.foldr l) (tlm_number m)++-------------------------------------------------+-- | @TypeMap a@ is a map from 'Type' to @a@.  If you are a client, this+-- is the type you want. The keys in this map may have different kinds.+newtype TypeMap a = TypeMap (TypeMapG (TypeMapG a))++lkTT :: DeBruijn Type -> TypeMap a -> Maybe a+lkTT (D env ty) (TypeMap m) = lkG (D env $ typeKind ty) m+                          >>= lkG (D env ty)++xtTT :: DeBruijn Type -> XT a -> TypeMap a -> TypeMap a+xtTT (D env ty) f (TypeMap m)+  = TypeMap (m |> xtG (D env $ typeKind ty)+               |>> xtG (D env ty) f)++-- Below are some client-oriented functions which operate on 'TypeMap'.++instance TrieMap TypeMap where+    type Key TypeMap = Type+    emptyTM = TypeMap emptyTM+    lookupTM k m = lkTT (deBruijnize k) m+    alterTM k f m = xtTT (deBruijnize k) f m+    foldTM k (TypeMap m) = foldTM (foldTM k) m+    mapTM f (TypeMap m) = TypeMap (mapTM (mapTM f) m)++foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b+foldTypeMap k z m = foldTM k m z++emptyTypeMap :: TypeMap a+emptyTypeMap = emptyTM++lookupTypeMap :: TypeMap a -> Type -> Maybe a+lookupTypeMap cm t = lookupTM t cm++extendTypeMap :: TypeMap a -> Type -> a -> TypeMap a+extendTypeMap m t v = alterTM t (const (Just v)) m++lookupTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> Maybe a+lookupTypeMapWithScope m cm t = lkTT (D cm t) m++-- | Extend a 'TypeMap' with a type in the given context.+-- @extendTypeMapWithScope m (mkDeBruijnContext [a,b,c]) t v@ is equivalent to+-- @extendTypeMap m (forall a b c. t) v@, but allows reuse of the context over+-- multiple insertions.+extendTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> a -> TypeMap a+extendTypeMapWithScope m cm t v = xtTT (D cm t) (const (Just v)) m++-- | Construct a deBruijn environment with the given variables in scope.+-- e.g. @mkDeBruijnEnv [a,b,c]@ constructs a context @forall a b c.@+mkDeBruijnContext :: [Var] -> CmEnv+mkDeBruijnContext = extendCMEs emptyCME++-- | A 'LooseTypeMap' doesn't do a kind-check. Thus, when lookup up (t |> g),+-- you'll find entries inserted under (t), even if (g) is non-reflexive.+newtype LooseTypeMap a+  = LooseTypeMap (TypeMapG a)++instance TrieMap LooseTypeMap where+  type Key LooseTypeMap = Type+  emptyTM = LooseTypeMap emptyTM+  lookupTM k (LooseTypeMap m) = lookupTM (deBruijnize k) m+  alterTM k f (LooseTypeMap m) = LooseTypeMap (alterTM (deBruijnize k) f m)+  foldTM f (LooseTypeMap m) = foldTM f m+  mapTM f (LooseTypeMap m) = LooseTypeMap (mapTM f m)++{-+************************************************************************+*                                                                      *+                   Variables+*                                                                      *+************************************************************************+-}++type BoundVar = Int  -- Bound variables are deBruijn numbered+type BoundVarMap a = IntMap.IntMap a++data CmEnv = CME { cme_next :: !BoundVar+                 , cme_env  :: VarEnv BoundVar }++emptyCME :: CmEnv+emptyCME = CME { cme_next = 0, cme_env = emptyVarEnv }++extendCME :: CmEnv -> Var -> CmEnv+extendCME (CME { cme_next = bv, cme_env = env }) v+  = CME { cme_next = bv+1, cme_env = extendVarEnv env v bv }++extendCMEs :: CmEnv -> [Var] -> CmEnv+extendCMEs env vs = foldl extendCME env vs++lookupCME :: CmEnv -> Var -> Maybe BoundVar+lookupCME (CME { cme_env = env }) v = lookupVarEnv env v++-- | @DeBruijn a@ represents @a@ modulo alpha-renaming.  This is achieved+-- by equipping the value with a 'CmEnv', which tracks an on-the-fly deBruijn+-- numbering.  This allows us to define an 'Eq' instance for @DeBruijn a@, even+-- if this was not (easily) possible for @a@.  Note: we purposely don't+-- export the constructor.  Make a helper function if you find yourself+-- needing it.+data DeBruijn a = D CmEnv a++-- | Synthesizes a @DeBruijn a@ from an @a@, by assuming that there are no+-- bound binders (an empty 'CmEnv').  This is usually what you want if there+-- isn't already a 'CmEnv' in scope.+deBruijnize :: a -> DeBruijn a+deBruijnize = D emptyCME++instance Eq (DeBruijn a) => Eq (DeBruijn [a]) where+    D _   []     == D _    []       = True+    D env (x:xs) == D env' (x':xs') = D env x  == D env' x' &&+                                      D env xs == D env' xs'+    _            == _               = False++--------- Variable binders -------------++-- | A 'BndrMap' is a 'TypeMapG' which allows us to distinguish between+-- binding forms whose binders have different types.  For example,+-- if we are doing a 'TrieMap' lookup on @\(x :: Int) -> ()@, we should+-- not pick up an entry in the 'TrieMap' for @\(x :: Bool) -> ()@:+-- we can disambiguate this by matching on the type (or kind, if this+-- a binder in a type) of the binder.+type BndrMap = TypeMapG++-- Note [Binders]+-- ~~~~~~~~~~~~~~+-- We need to use 'BndrMap' for 'Coercion', 'CoreExpr' AND 'Type', since all+-- of these data types have binding forms.++lkBndr :: CmEnv -> Var -> BndrMap a -> Maybe a+lkBndr env v m = lkG (D env (varType v)) m++xtBndr :: CmEnv -> Var -> XT a -> BndrMap a -> BndrMap a+xtBndr env v f = xtG (D env (varType v)) f++--------- Variable occurrence -------------+data VarMap a = VM { vm_bvar   :: BoundVarMap a  -- Bound variable+                   , vm_fvar   :: DVarEnv a }      -- Free variable++instance TrieMap VarMap where+   type Key VarMap = Var+   emptyTM  = VM { vm_bvar = IntMap.empty, vm_fvar = emptyDVarEnv }+   lookupTM = lkVar emptyCME+   alterTM  = xtVar emptyCME+   foldTM   = fdVar+   mapTM    = mapVar++mapVar :: (a->b) -> VarMap a -> VarMap b+mapVar f (VM { vm_bvar = bv, vm_fvar = fv })+  = VM { vm_bvar = mapTM f bv, vm_fvar = mapTM f fv }++lkVar :: CmEnv -> Var -> VarMap a -> Maybe a+lkVar env v+  | Just bv <- lookupCME env v = vm_bvar >.> lookupTM bv+  | otherwise                  = vm_fvar >.> lkDFreeVar v++xtVar :: CmEnv -> Var -> XT a -> VarMap a -> VarMap a+xtVar env v f m+  | Just bv <- lookupCME env v = m { vm_bvar = vm_bvar m |> alterTM bv f }+  | otherwise                  = m { vm_fvar = vm_fvar m |> xtDFreeVar v f }++fdVar :: (a -> b -> b) -> VarMap a -> b -> b+fdVar k m = foldTM k (vm_bvar m)+          . foldTM k (vm_fvar m)++lkDFreeVar :: Var -> DVarEnv a -> Maybe a+lkDFreeVar var env = lookupDVarEnv env var++xtDFreeVar :: Var -> XT a -> DVarEnv a -> DVarEnv a+xtDFreeVar v f m = alterDVarEnv f m v
+ deSugar/Check.hs view
@@ -0,0 +1,1859 @@+{-+Author: George Karachalias <george.karachalias@cs.kuleuven.be>++Pattern Matching Coverage Checking.+-}++{-# LANGUAGE CPP, GADTs, DataKinds, KindSignatures #-}+{-# LANGUAGE TupleSections #-}++module Check (+        -- Checking and printing+        checkSingle, checkMatches, isAnyPmCheckEnabled,++        -- See Note [Type and Term Equality Propagation]+        genCaseTmCs1, genCaseTmCs2+    ) where++#include "HsVersions.h"++import TmOracle++import DynFlags+import HsSyn+import TcHsSyn+import Id+import ConLike+import Name+import FamInstEnv+import TysWiredIn+import TyCon+import SrcLoc+import Util+import Outputable+import FastString+import DataCon+import HscTypes (CompleteMatch(..))++import DsMonad+import TcSimplify    (tcCheckSatisfiability)+import TcType        (toTcType, isStringTy, isIntTy, isWordTy)+import Bag+import ErrUtils+import Var           (EvVar)+import Type+import UniqSupply+import DsGRHSs       (isTrueLHsExpr)++import Data.List     (find)+import Data.Maybe    (isJust, fromMaybe)+import Control.Monad (forM, when, forM_)+import Coercion+import TcEvidence+import IOEnv++import ListT (ListT(..), fold, select)++{-+This module checks pattern matches for:+\begin{enumerate}+  \item Equations that are redundant+  \item Equations with inaccessible right-hand-side+  \item Exhaustiveness+\end{enumerate}++The algorithm is based on the paper:++  "GADTs Meet Their Match:+     Pattern-matching Warnings That Account for GADTs, Guards, and Laziness"++    http://people.cs.kuleuven.be/~george.karachalias/papers/p424-karachalias.pdf++%************************************************************************+%*                                                                      *+                     Pattern Match Check Types+%*                                                                      *+%************************************************************************+-}++-- We use the non-determinism monad to apply the algorithm to several+-- possible sets of constructors. Users can specify complete sets of+-- constructors by using COMPLETE pragmas.+-- The algorithm only picks out constructor+-- sets deep in the bowels which makes a simpler `mapM` more difficult to+-- implement. The non-determinism is only used in one place, see the ConVar+-- case in `pmCheckHd`.++type PmM a = ListT DsM a++liftD :: DsM a -> PmM a+liftD m = ListT $ \sk fk -> m >>= \a -> sk a fk++-- Pick the first match complete covered match or otherwise the "best" match.+-- The best match is the one with the least uncovered clauses, ties broken+-- by the number of inaccessible clauses followed by number of redudant+-- clauses+getResult :: PmM PmResult -> DsM PmResult+getResult ls = do+  res <- fold ls goM (pure Nothing)+  case res of+    Nothing -> panic "getResult is empty"+    Just a -> return a+  where+    goM :: PmResult -> DsM (Maybe PmResult) -> DsM (Maybe PmResult)+    goM mpm dpm = do+      pmr <- dpm+      return $ go pmr mpm+    -- Careful not to force unecessary results+    go :: Maybe PmResult -> PmResult -> Maybe PmResult+    go Nothing rs = Just rs+    go old@(Just (PmResult prov rs (UncoveredPatterns us) is)) new+      | null us && null rs && null is = old+      | otherwise =+        let PmResult prov' rs' (UncoveredPatterns us') is' = new+            lr  = length rs+            lr' = length rs'+            li  = length is+            li' = length is'+        in case compare (length us) (length us')+                `mappend` (compare li li')+                `mappend` (compare lr lr')+                `mappend` (compare prov prov') of+              GT  -> Just new+              EQ  -> Just new+              LT  -> old+    go (Just (PmResult _ _ (TypeOfUncovered _) _)) _new+      = panic "getResult: No inhabitation candidates"++data PatTy = PAT | VA -- Used only as a kind, to index PmPat++-- The *arity* of a PatVec [p1,..,pn] is+-- the number of p1..pn that are not Guards++data PmPat :: PatTy -> * where+  PmCon  :: { pm_con_con     :: ConLike+            , pm_con_arg_tys :: [Type]+            , pm_con_tvs     :: [TyVar]+            , pm_con_dicts   :: [EvVar]+            , pm_con_args    :: [PmPat t] } -> PmPat t+            -- For PmCon arguments' meaning see @ConPatOut@ in hsSyn/HsPat.hs+  PmVar  :: { pm_var_id   :: Id    } -> PmPat t+  PmLit  :: { pm_lit_lit  :: PmLit } -> PmPat t -- See Note [Literals in PmPat]+  PmNLit :: { pm_lit_id   :: Id+            , pm_lit_not  :: [PmLit] } -> PmPat 'VA+  PmGrd  :: { pm_grd_pv   :: PatVec+            , pm_grd_expr :: PmExpr  } -> PmPat 'PAT++-- data T a where+--     MkT :: forall p q. (Eq p, Ord q) => p -> q -> T [p]+-- or  MkT :: forall p q r. (Eq p, Ord q, [p] ~ r) => p -> q -> T r++type Pattern = PmPat 'PAT -- ^ Patterns+type ValAbs  = PmPat 'VA  -- ^ Value Abstractions++type PatVec = [Pattern]             -- ^ Pattern Vectors+data ValVec = ValVec [ValAbs] Delta -- ^ Value Vector Abstractions++-- | Term and type constraints to accompany each value vector abstraction.+-- For efficiency, we store the term oracle state instead of the term+-- constraints. TODO: Do the same for the type constraints?+data Delta = MkDelta { delta_ty_cs :: Bag EvVar+                     , delta_tm_cs :: TmState }++type ValSetAbs = [ValVec]  -- ^ Value Set Abstractions+type Uncovered = ValSetAbs++-- Instead of keeping the whole sets in memory, we keep a boolean for both the+-- covered and the divergent set (we store the uncovered set though, since we+-- want to print it). For both the covered and the divergent we have:+--+--   True <=> The set is non-empty+--+-- hence:+--  C = True             ==> Useful clause (no warning)+--  C = False, D = True  ==> Clause with inaccessible RHS+--  C = False, D = False ==> Redundant clause++data Covered = Covered | NotCovered+  deriving Show++instance Outputable Covered where+  ppr (Covered) = text "Covered"+  ppr (NotCovered) = text "NotCovered"++-- Like the or monoid for booleans+-- Covered = True, Uncovered = False+instance Monoid Covered where+  mempty = NotCovered+  Covered `mappend` _ = Covered+  _ `mappend` Covered = Covered+  NotCovered `mappend` NotCovered = NotCovered++data Diverged = Diverged | NotDiverged+  deriving Show++instance Outputable Diverged where+  ppr Diverged = text "Diverged"+  ppr NotDiverged = text "NotDiverged"++instance Monoid Diverged where+  mempty = NotDiverged+  Diverged `mappend` _ = Diverged+  _ `mappend` Diverged = Diverged+  NotDiverged `mappend` NotDiverged = NotDiverged++-- | When we learned that a given match group is complete+data Provenance =+                  FromBuiltin -- ^  From the original definition of the type+                              --    constructor.+                | FromComplete -- ^ From a user-provided @COMPLETE@ pragma+  deriving (Show, Eq, Ord)++instance Outputable Provenance where+  ppr  = text . show++instance Monoid Provenance where+  mempty = FromBuiltin+  FromComplete `mappend` _ = FromComplete+  _ `mappend` FromComplete = FromComplete+  _ `mappend` _ = FromBuiltin++data PartialResult = PartialResult {+                        presultProvenence :: Provenance+                         -- keep track of provenance because we don't want+                         -- to warn about redundant matches if the result+                         -- is contaiminated with a COMPLETE pragma+                      , presultCovered :: Covered+                      , presultUncovered :: Uncovered+                      , presultDivergent :: Diverged }++instance Outputable PartialResult where+  ppr (PartialResult prov c vsa d)+           = text "PartialResult" <+> ppr prov <+> ppr c+                                  <+> ppr d <+> ppr vsa++instance Monoid PartialResult where+  mempty = PartialResult mempty mempty [] mempty+  (PartialResult prov1 cs1 vsa1 ds1)+    `mappend` (PartialResult prov2 cs2 vsa2 ds2)+      = PartialResult (prov1 `mappend` prov2)+                      (cs1 `mappend` cs2)+                      (vsa1 `mappend` vsa2)+                      (ds1 `mappend` ds2)++-- newtype ChoiceOf a = ChoiceOf [a]++-- | Pattern check result+--+-- * Redundant clauses+-- * Not-covered clauses (or their type, if no pattern is available)+-- * Clauses with inaccessible RHS+--+-- More details about the classification of clauses into useful, redundant+-- and with inaccessible right hand side can be found here:+--+--     https://ghc.haskell.org/trac/ghc/wiki/PatternMatchCheck+--+data PmResult =+  PmResult {+      pmresultProvenance :: Provenance+    , pmresultRedundant :: [Located [LPat Id]]+    , pmresultUncovered :: UncoveredCandidates+    , pmresultInaccessible :: [Located [LPat Id]] }++-- | Either a list of patterns that are not covered, or their type, in case we+-- have no patterns at hand. Not having patterns at hand can arise when+-- handling EmptyCase expressions, in two cases:+--+-- * The type of the scrutinee is a trivially inhabited type (like Int or Char)+-- * The type of the scrutinee cannot be reduced to WHNF.+--+-- In both these cases we have no inhabitation candidates for the type at hand,+-- but we don't want to issue just a wildcard as missing. Instead, we print a+-- type annotated wildcard, so that the user knows what kind of patterns is+-- expected (e.g. (_ :: Int), or (_ :: F Int), where F Int does not reduce).+data UncoveredCandidates = UncoveredPatterns Uncovered+                         | TypeOfUncovered Type++-- | The empty pattern check result+emptyPmResult :: PmResult+emptyPmResult = PmResult FromBuiltin [] (UncoveredPatterns []) []++-- | Non-exhaustive empty case with unknown/trivial inhabitants+uncoveredWithTy :: Type -> PmResult+uncoveredWithTy ty = PmResult FromBuiltin [] (TypeOfUncovered ty) []++{-+%************************************************************************+%*                                                                      *+       Entry points to the checker: checkSingle and checkMatches+%*                                                                      *+%************************************************************************+-}++-- | Check a single pattern binding (let)+checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat Id -> DsM ()+checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do+  tracePmD "checkSingle" (vcat [ppr ctxt, ppr var, ppr p])+  mb_pm_res <- tryM (getResult (checkSingle' locn var p))+  case mb_pm_res of+    Left  _   -> warnPmIters dflags ctxt+    Right res -> dsPmWarn dflags ctxt res++-- | Check a single pattern binding (let)+checkSingle' :: SrcSpan -> Id -> Pat Id -> PmM PmResult+checkSingle' locn var p = do+  liftD resetPmIterDs -- set the iter-no to zero+  fam_insts <- liftD dsGetFamInstEnvs+  clause    <- liftD $ translatePat fam_insts p+  missing   <- mkInitialUncovered [var]+  tracePm "checkSingle: missing" (vcat (map pprValVecDebug missing))+                                 -- no guards+  PartialResult prov cs us ds <- runMany (pmcheckI clause []) missing+  let us' = UncoveredPatterns us+  return $ case (cs,ds) of+    (Covered,  _    )         -> PmResult prov [] us' [] -- useful+    (NotCovered, NotDiverged) -> PmResult prov m  us' [] -- redundant+    (NotCovered, Diverged )   -> PmResult prov [] us' m  -- inaccessible rhs+  where m = [L locn [L locn p]]++-- | Check a matchgroup (case, functions, etc.)+checkMatches :: DynFlags -> DsMatchContext+             -> [Id] -> [LMatch Id (LHsExpr Id)] -> DsM ()+checkMatches dflags ctxt vars matches = do+  tracePmD "checkMatches" (hang (vcat [ppr ctxt+                               , ppr vars+                               , text "Matches:"])+                               2+                               (vcat (map ppr matches)))+  mb_pm_res <- tryM $ getResult $ case matches of+    -- Check EmptyCase separately+    -- See Note [Checking EmptyCase Expressions]+    [] | [var] <- vars -> checkEmptyCase' var+    _normal_match      -> checkMatches' vars matches+  case mb_pm_res of+    Left  _   -> warnPmIters dflags ctxt+    Right res -> dsPmWarn dflags ctxt res++-- | Check a matchgroup (case, functions, etc.). To be called on a non-empty+-- list of matches. For empty case expressions, use checkEmptyCase' instead.+checkMatches' :: [Id] -> [LMatch Id (LHsExpr Id)] -> PmM PmResult+checkMatches' vars matches+  | null matches = panic "checkMatches': EmptyCase"+  | otherwise = do+      liftD resetPmIterDs -- set the iter-no to zero+      missing    <- mkInitialUncovered vars+      tracePm "checkMatches: missing" (vcat (map pprValVecDebug missing))+      (prov, rs,us,ds) <- go matches missing+      return $ PmResult {+                   pmresultProvenance   = prov+                 , pmresultRedundant    = map hsLMatchToLPats rs+                 , pmresultUncovered    = UncoveredPatterns us+                 , pmresultInaccessible = map hsLMatchToLPats ds }+  where+    go :: [LMatch Id (LHsExpr Id)] -> Uncovered+       -> PmM (Provenance+              , [LMatch Id (LHsExpr Id)]+              , Uncovered+              , [LMatch Id (LHsExpr Id)])+    go []     missing = return (mempty, [], missing, [])+    go (m:ms) missing = do+      tracePm "checMatches': go" (ppr m $$ ppr missing)+      fam_insts          <- liftD dsGetFamInstEnvs+      (clause, guards)   <- liftD $ translateMatch fam_insts m+      r@(PartialResult prov cs missing' ds)+        <- runMany (pmcheckI clause guards) missing+      tracePm "checMatches': go: res" (ppr r)+      (ms_prov, rs, final_u, is)  <- go ms missing'+      let final_prov = prov `mappend` ms_prov+      return $ case (cs, ds) of+        -- useful+        (Covered,  _    )        -> (final_prov,  rs, final_u,   is)+        -- redundant+        (NotCovered, NotDiverged) -> (final_prov, m:rs, final_u,is)+        -- inaccessible+        (NotCovered, Diverged )   -> (final_prov,  rs, final_u, m:is)++    hsLMatchToLPats :: LMatch id body -> Located [LPat id]+    hsLMatchToLPats (L l (Match _ pats _ _)) = L l pats++-- | Check an empty case expression. Since there are no clauses to process, we+--   only compute the uncovered set. See Note [Checking EmptyCase Expressions]+--   for details.+checkEmptyCase' :: Id -> PmM PmResult+checkEmptyCase' var = do+  tm_css <- map toComplex . bagToList <$> liftD getTmCsDs+  case tmOracle initialTmState tm_css of+    Just tm_state -> do+      ty_css        <- liftD getDictsDs+      fam_insts     <- liftD dsGetFamInstEnvs+      mb_candidates <- inhabitationCandidates fam_insts (idType var)+      case mb_candidates of+        -- Inhabitation checking failed / the type is trivially inhabited+        Left ty -> return (uncoveredWithTy ty)++        -- A list of inhabitant candidates is available: Check for each+        -- one for the satisfiability of the constraints it gives rise to.+        Right candidates -> do+          missing_m <- flip concatMapM candidates $ \(va,tm_ct,ty_cs) -> do+            let all_ty_cs = unionBags ty_cs ty_css+            sat_ty <- tyOracle all_ty_cs+            return $ case (sat_ty, tmOracle tm_state (tm_ct:tm_css)) of+              (True, Just tm_state') -> [(va, all_ty_cs, tm_state')]+              _non_sat               -> []+          let mkValVec (va,all_ty_cs,tm_state')+                = ValVec [va] (MkDelta all_ty_cs tm_state')+              uncovered = UncoveredPatterns (map mkValVec missing_m)+          return $ if null missing_m+            then emptyPmResult+            else PmResult FromBuiltin [] uncovered []+    Nothing -> return emptyPmResult++-- | Generate all inhabitation candidates for a given type. The result is+-- either (Left ty), if the type cannot be reduced to a closed algebraic type+-- (or if it's one trivially inhabited, like Int), or (Right candidates), if it+-- can. In this case, the candidates are the singnature of the tycon, each one+-- accompanied by the term- and type- constraints it gives rise to.+-- See also Note [Checking EmptyCase Expressions]+inhabitationCandidates :: FamInstEnvs -> Type+                       -> PmM (Either Type [(ValAbs, ComplexEq, Bag EvVar)])+inhabitationCandidates fam_insts ty+  = case pmTopNormaliseType_maybe fam_insts ty of+      Just (src_ty, dcs, core_ty) -> alts_to_check src_ty core_ty dcs+      Nothing                     -> alts_to_check ty     ty      []+  where+    -- All these types are trivially inhabited+    trivially_inhabited = [ charTyCon, doubleTyCon, floatTyCon+                          , intTyCon, wordTyCon, word8TyCon ]++    -- Note: At the moment we leave all the typing and constraint fields of+    -- PmCon empty, since we know that they are not gonna be used. Is the+    -- right-thing-to-do to actually create them, even if they are never used?+    build_tm :: ValAbs -> [DataCon] -> ValAbs+    build_tm = foldr (\dc e -> PmCon (RealDataCon dc) [] [] [] [e])++    -- Inhabitation candidates, using the result of pmTopNormaliseType_maybe+    alts_to_check :: Type -> Type -> [DataCon]+                  -> PmM (Either Type [(ValAbs, ComplexEq, Bag EvVar)])+    alts_to_check src_ty core_ty dcs = case splitTyConApp_maybe core_ty of+      Just (tc, _)+        | tc `elem` trivially_inhabited -> case dcs of+            []    -> return (Left src_ty)+            (_:_) -> do var <- liftD $ mkPmId (toTcType core_ty)+                        let va = build_tm (PmVar var) dcs+                        return $ Right [(va, mkIdEq var, emptyBag)]+        | isClosedAlgType core_ty -> liftD $ do+            var  <- mkPmId (toTcType core_ty) -- it would be wrong to unify x+            alts <- mapM (mkOneConFull var . RealDataCon) (tyConDataCons tc)+            return $ Right [(build_tm va dcs, eq, cs) | (va, eq, cs) <- alts]+      -- For other types conservatively assume that they are inhabited.+      _other -> return (Left src_ty)++{- Note [Checking EmptyCase Expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Empty case expressions are strict on the scrutinee. That is, `case x of {}`+will force argument `x`. Hence, `checkMatches` is not sufficient for checking+empty cases, because it assumes that the match is not strict (which is true+for all other cases, apart from EmptyCase). This gave rise to #10746. Instead,+we do the following:++1. We normalise the outermost type family redex, data family redex or newtype,+   using pmTopNormaliseType_maybe (in types/FamInstEnv.hs). This computes 3+   things:+   (a) A normalised type src_ty, which is equal to the type of the scrutinee in+       source Haskell (does not normalise newtypes or data families)+   (b) The actual normalised type core_ty, which coincides with the result+       topNormaliseType_maybe. This type is not necessarily equal to the input+       type in source Haskell. And this is precicely the reason we compute (a)+       and (c): the reasoning happens with the underlying types, but both the+       patterns and types we print should respect newtypes and also show the+       family type constructors and not the representation constructors.++   (c) A list of all newtype data constructors dcs, each one corresponding to a+       newtype rewrite performed in (b).++   For an example see also Note [Type normalisation for EmptyCase]+   in types/FamInstEnv.hs.++2. Function checkEmptyCase' performs the check:+   - If core_ty is not an algebraic type, then we cannot check for+     inhabitation, so we emit (_ :: src_ty) as missing, conservatively assuming+     that the type is inhabited.+   - If core_ty is an algebraic type, then we unfold the scrutinee to all+     possible constructor patterns, using inhabitationCandidates, and then+     check each one for constraint satisfiability, same as we for normal+     pattern match checking.++%************************************************************************+%*                                                                      *+              Transform source syntax to *our* syntax+%*                                                                      *+%************************************************************************+-}++-- -----------------------------------------------------------------------+-- * Utilities++nullaryConPattern :: ConLike -> Pattern+-- Nullary data constructor and nullary type constructor+nullaryConPattern con =+  PmCon { pm_con_con = con, pm_con_arg_tys = []+        , pm_con_tvs = [], pm_con_dicts = [], pm_con_args = [] }+{-# INLINE nullaryConPattern #-}++truePattern :: Pattern+truePattern = nullaryConPattern (RealDataCon trueDataCon)+{-# INLINE truePattern #-}++-- | A fake guard pattern (True <- _) used to represent cases we cannot handle+fake_pat :: Pattern+fake_pat = PmGrd { pm_grd_pv   = [truePattern]+                 , pm_grd_expr = PmExprOther EWildPat }+{-# INLINE fake_pat #-}++-- | Check whether a guard pattern is generated by the checker (unhandled)+isFakeGuard :: [Pattern] -> PmExpr -> Bool+isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther EWildPat)+  | c == trueDataCon = True+  | otherwise        = False+isFakeGuard _pats _e = False++-- | Generate a `canFail` pattern vector of a specific type+mkCanFailPmPat :: Type -> DsM PatVec+mkCanFailPmPat ty = do+  var <- mkPmVar ty+  return [var, fake_pat]++vanillaConPattern :: ConLike -> [Type] -> PatVec -> Pattern+-- ADT constructor pattern => no existentials, no local constraints+vanillaConPattern con arg_tys args =+  PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys+        , pm_con_tvs = [], pm_con_dicts = [], pm_con_args = args }+{-# INLINE vanillaConPattern #-}++-- | Create an empty list pattern of a given type+nilPattern :: Type -> Pattern+nilPattern ty =+  PmCon { pm_con_con = RealDataCon nilDataCon, pm_con_arg_tys = [ty]+        , pm_con_tvs = [], pm_con_dicts = []+        , pm_con_args = [] }+{-# INLINE nilPattern #-}++mkListPatVec :: Type -> PatVec -> PatVec -> PatVec+mkListPatVec ty xs ys = [PmCon { pm_con_con = RealDataCon consDataCon+                               , pm_con_arg_tys = [ty]+                               , pm_con_tvs = [], pm_con_dicts = []+                               , pm_con_args = xs++ys }]+{-# INLINE mkListPatVec #-}++-- | Create a (non-overloaded) literal pattern+mkLitPattern :: HsLit -> Pattern+mkLitPattern lit = PmLit { pm_lit_lit = PmSLit lit }+{-# INLINE mkLitPattern #-}++-- -----------------------------------------------------------------------+-- * Transform (Pat Id) into of (PmPat Id)++translatePat :: FamInstEnvs -> Pat Id -> DsM PatVec+translatePat fam_insts pat = case pat of+  WildPat ty  -> mkPmVars [ty]+  VarPat  id  -> return [PmVar (unLoc id)]+  ParPat p    -> translatePat fam_insts (unLoc p)+  LazyPat _   -> mkPmVars [hsPatType pat] -- like a variable++  -- ignore strictness annotations for now+  BangPat p   -> translatePat fam_insts (unLoc p)++  AsPat lid p -> do+     -- Note [Translating As Patterns]+    ps <- translatePat fam_insts (unLoc p)+    let [e] = map vaToPmExpr (coercePatVec ps)+        g   = PmGrd [PmVar (unLoc lid)] e+    return (ps ++ [g])++  SigPatOut p _ty -> translatePat fam_insts (unLoc p)++  -- See Note [Translate CoPats]+  CoPat wrapper p ty+    | isIdHsWrapper wrapper                   -> translatePat fam_insts p+    | WpCast co <-  wrapper, isReflexiveCo co -> translatePat fam_insts p+    | otherwise -> do+        ps      <- translatePat fam_insts p+        (xp,xe) <- mkPmId2Forms ty+        let g = mkGuard ps (HsWrap wrapper (unLoc xe))+        return [xp,g]++  -- (n + k)  ===>   x (True <- x >= k) (n <- x-k)+  NPlusKPat (L _ _n) _k1 _k2 _ge _minus ty -> mkCanFailPmPat ty++  -- (fun -> pat)   ===>   x (pat <- fun x)+  ViewPat lexpr lpat arg_ty -> do+    ps <- translatePat fam_insts (unLoc lpat)+    -- See Note [Guards and Approximation]+    case all cantFailPattern ps of+      True  -> do+        (xp,xe) <- mkPmId2Forms arg_ty+        let g = mkGuard ps (HsApp lexpr xe)+        return [xp,g]+      False -> mkCanFailPmPat arg_ty++  -- list+  ListPat ps ty Nothing -> do+    foldr (mkListPatVec ty) [nilPattern ty]+      <$> translatePatVec fam_insts (map unLoc ps)++  -- overloaded list+  ListPat lpats elem_ty (Just (pat_ty, _to_list))+    | Just e_ty <- splitListTyConApp_maybe pat_ty+    , (_, norm_elem_ty) <- normaliseType fam_insts Nominal elem_ty+         -- elem_ty is frequently something like+         -- `Item [Int]`, but we prefer `Int`+    , norm_elem_ty `eqType` e_ty ->+        -- We have to ensure that the element types are exactly the same.+        -- Otherwise, one may give an instance IsList [Int] (more specific than+        -- the default IsList [a]) with a different implementation for `toList'+        translatePat fam_insts (ListPat lpats e_ty Nothing)+      -- See Note [Guards and Approximation]+    | otherwise -> mkCanFailPmPat pat_ty++  ConPatOut { pat_con     = L _ con+            , pat_arg_tys = arg_tys+            , pat_tvs     = ex_tvs+            , pat_dicts   = dicts+            , pat_args    = ps } -> do+    groups <- allCompleteMatches con arg_tys+    case groups of+      [] -> mkCanFailPmPat (conLikeResTy con arg_tys)+      _  -> do+        args <- translateConPatVec fam_insts arg_tys ex_tvs con ps+        return [PmCon { pm_con_con     = con+                      , pm_con_arg_tys = arg_tys+                      , pm_con_tvs     = ex_tvs+                      , pm_con_dicts   = dicts+                      , pm_con_args    = args }]++  NPat (L _ ol) mb_neg _eq ty -> translateNPat fam_insts ol mb_neg ty++  LitPat lit+      -- If it is a string then convert it to a list of characters+    | HsString src s <- lit ->+        foldr (mkListPatVec charTy) [nilPattern charTy] <$>+          translatePatVec fam_insts (map (LitPat . HsChar src) (unpackFS s))+    | otherwise -> return [mkLitPattern lit]++  PArrPat ps ty -> do+    tidy_ps <- translatePatVec fam_insts (map unLoc ps)+    let fake_con = RealDataCon (parrFakeCon (length ps))+    return [vanillaConPattern fake_con [ty] (concat tidy_ps)]++  TuplePat ps boxity tys -> do+    tidy_ps <- translatePatVec fam_insts (map unLoc ps)+    let tuple_con = RealDataCon (tupleDataCon boxity (length ps))+    return [vanillaConPattern tuple_con tys (concat tidy_ps)]++  SumPat p alt arity ty -> do+    tidy_p <- translatePat fam_insts (unLoc p)+    let sum_con = RealDataCon (sumDataCon alt arity)+    return [vanillaConPattern sum_con ty tidy_p]++  -- --------------------------------------------------------------------------+  -- Not supposed to happen+  ConPatIn  {} -> panic "Check.translatePat: ConPatIn"+  SplicePat {} -> panic "Check.translatePat: SplicePat"+  SigPatIn  {} -> panic "Check.translatePat: SigPatIn"++-- | Translate an overloaded literal (see `tidyNPat' in deSugar/MatchLit.hs)+translateNPat :: FamInstEnvs+              -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> Type -> DsM PatVec+translateNPat fam_insts (OverLit val False _ ty) mb_neg outer_ty+  | not type_change, isStringTy ty, HsIsString src s <- val, Nothing <- mb_neg+  = translatePat fam_insts (LitPat (HsString src s))+  | not type_change, isIntTy    ty, HsIntegral src i <- val+  = translatePat fam_insts (mk_num_lit HsInt src i)+  | not type_change, isWordTy   ty, HsIntegral src i <- val+  = translatePat fam_insts (mk_num_lit HsWordPrim src i)+  where+    type_change = not (outer_ty `eqType` ty)+    mk_num_lit c src i = LitPat $ case mb_neg of+      Nothing -> c src i+      Just _  -> c src (-i)+translateNPat _ ol mb_neg _+  = return [PmLit { pm_lit_lit = PmOLit (isJust mb_neg) ol }]++-- | Translate a list of patterns (Note: each pattern is translated+-- to a pattern vector but we do not concatenate the results).+translatePatVec :: FamInstEnvs -> [Pat Id] -> DsM [PatVec]+translatePatVec fam_insts pats = mapM (translatePat fam_insts) pats++-- | Translate a constructor pattern+translateConPatVec :: FamInstEnvs -> [Type] -> [TyVar]+                   -> ConLike -> HsConPatDetails Id -> DsM PatVec+translateConPatVec fam_insts _univ_tys _ex_tvs _ (PrefixCon ps)+  = concat <$> translatePatVec fam_insts (map unLoc ps)+translateConPatVec fam_insts _univ_tys _ex_tvs _ (InfixCon p1 p2)+  = concat <$> translatePatVec fam_insts (map unLoc [p1,p2])+translateConPatVec fam_insts  univ_tys  ex_tvs c (RecCon (HsRecFields fs _))+    -- Nothing matched. Make up some fresh term variables+  | null fs        = mkPmVars arg_tys+    -- The data constructor was not defined using record syntax. For the+    -- pattern to be in record syntax it should be empty (e.g. Just {}).+    -- So just like the previous case.+  | null orig_lbls = ASSERT(null matched_lbls) mkPmVars arg_tys+    -- Some of the fields appear, in the original order (there may be holes).+    -- Generate a simple constructor pattern and make up fresh variables for+    -- the rest of the fields+  | matched_lbls `subsetOf` orig_lbls+  = ASSERT(length orig_lbls == length arg_tys)+      let translateOne (lbl, ty) = case lookup lbl matched_pats of+            Just p  -> translatePat fam_insts p+            Nothing -> mkPmVars [ty]+      in  concatMapM translateOne (zip orig_lbls arg_tys)+    -- The fields that appear are not in the correct order. Make up fresh+    -- variables for all fields and add guards after matching, to force the+    -- evaluation in the correct order.+  | otherwise = do+      arg_var_pats    <- mkPmVars arg_tys+      translated_pats <- forM matched_pats $ \(x,pat) -> do+        pvec <- translatePat fam_insts pat+        return (x, pvec)++      let zipped = zip orig_lbls [ x | PmVar x <- arg_var_pats ]+          guards = map (\(name,pvec) -> case lookup name zipped of+                            Just x  -> PmGrd pvec (PmExprVar (idName x))+                            Nothing -> panic "translateConPatVec: lookup")+                       translated_pats++      return (arg_var_pats ++ guards)+  where+    -- The actual argument types (instantiated)+    arg_tys = conLikeInstOrigArgTys c (univ_tys ++ mkTyVarTys ex_tvs)++    -- Some label information+    orig_lbls    = map flSelector $ conLikeFieldLabels c+    matched_pats = [ (getName (unLoc (hsRecFieldId x)), unLoc (hsRecFieldArg x))+                   | L _ x <- fs]+    matched_lbls = [ name | (name, _pat) <- matched_pats ]++    subsetOf :: Eq a => [a] -> [a] -> Bool+    subsetOf []     _  = True+    subsetOf (_:_)  [] = False+    subsetOf (x:xs) (y:ys)+      | x == y    = subsetOf    xs  ys+      | otherwise = subsetOf (x:xs) ys++-- Translate a single match+translateMatch :: FamInstEnvs -> LMatch Id (LHsExpr Id) -> DsM (PatVec,[PatVec])+translateMatch fam_insts (L _ (Match _ lpats _ grhss)) = do+  pats'   <- concat <$> translatePatVec fam_insts pats+  guards' <- mapM (translateGuards fam_insts) guards+  return (pats', guards')+  where+    extractGuards :: LGRHS Id (LHsExpr Id) -> [GuardStmt Id]+    extractGuards (L _ (GRHS gs _)) = map unLoc gs++    pats   = map unLoc lpats+    guards = map extractGuards (grhssGRHSs grhss)++-- -----------------------------------------------------------------------+-- * Transform source guards (GuardStmt Id) to PmPats (Pattern)++-- | Translate a list of guard statements to a pattern vector+translateGuards :: FamInstEnvs -> [GuardStmt Id] -> DsM PatVec+translateGuards fam_insts guards = do+  all_guards <- concat <$> mapM (translateGuard fam_insts) guards+  return (replace_unhandled all_guards)+  -- It should have been (return all_guards) but it is too expressive.+  -- Since the term oracle does not handle all constraints we generate,+  -- we (hackily) replace all constraints the oracle cannot handle with a+  -- single one (we need to know if there is a possibility of falure).+  -- See Note [Guards and Approximation] for all guard-related approximations+  -- we implement.+  where+    replace_unhandled :: PatVec -> PatVec+    replace_unhandled gv+      | any_unhandled gv = fake_pat : [ p | p <- gv, shouldKeep p ]+      | otherwise        = gv++    any_unhandled :: PatVec -> Bool+    any_unhandled gv = any (not . shouldKeep) gv++    shouldKeep :: Pattern -> Bool+    shouldKeep p+      | PmVar {} <- p      = True+      | PmCon {} <- p      = singleConstructor (pm_con_con p)+                             && all shouldKeep (pm_con_args p)+    shouldKeep (PmGrd pv e)+      | all shouldKeep pv  = True+      | isNotPmExprOther e = True  -- expensive but we want it+    shouldKeep _other_pat  = False -- let the rest..++-- | Check whether a pattern can fail to match+cantFailPattern :: Pattern -> Bool+cantFailPattern p+  | PmVar {} <- p = True+  | PmCon {} <- p = singleConstructor (pm_con_con p)+                    && all cantFailPattern (pm_con_args p)+cantFailPattern (PmGrd pv _e)+                  = all cantFailPattern pv+cantFailPattern _ = False++-- | Translate a guard statement to Pattern+translateGuard :: FamInstEnvs -> GuardStmt Id -> DsM PatVec+translateGuard fam_insts guard = case guard of+  BodyStmt   e _ _ _ -> translateBoolGuard e+  LetStmt      binds -> translateLet (unLoc binds)+  BindStmt p e _ _ _ -> translateBind fam_insts p e+  LastStmt        {} -> panic "translateGuard LastStmt"+  ParStmt         {} -> panic "translateGuard ParStmt"+  TransStmt       {} -> panic "translateGuard TransStmt"+  RecStmt         {} -> panic "translateGuard RecStmt"+  ApplicativeStmt {} -> panic "translateGuard ApplicativeLastStmt"++-- | Translate let-bindings+translateLet :: HsLocalBinds Id -> DsM PatVec+translateLet _binds = return []++-- | Translate a pattern guard+translateBind :: FamInstEnvs -> LPat Id -> LHsExpr Id -> DsM PatVec+translateBind fam_insts (L _ p) e = do+  ps <- translatePat fam_insts p+  return [mkGuard ps (unLoc e)]++-- | Translate a boolean guard+translateBoolGuard :: LHsExpr Id -> DsM PatVec+translateBoolGuard e+  | isJust (isTrueLHsExpr e) = return []+    -- The formal thing to do would be to generate (True <- True)+    -- but it is trivial to solve so instead we give back an empty+    -- PatVec for efficiency+  | otherwise = return [mkGuard [truePattern] (unLoc e)]++{- Note [Guards and Approximation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Even if the algorithm is really expressive, the term oracle we use is not.+Hence, several features are not translated *properly* but we approximate.+The list includes:++1. View Patterns+----------------+A view pattern @(f -> p)@ should be translated to @x (p <- f x)@. The term+oracle does not handle function applications so we know that the generated+constraints will not be handled at the end. Hence, we distinguish between two+cases:+  a) Pattern @p@ cannot fail. Then this is just a binding and we do the *right+     thing*.+  b) Pattern @p@ can fail. This means that when checking the guard, we will+     generate several cases, with no useful information. E.g.:++       h (f -> [a,b]) = ...+       h x ([a,b] <- f x) = ...++       uncovered set = { [x |> { False ~ (f x ~ [])            }]+                       , [x |> { False ~ (f x ~ (t1:[]))       }]+                       , [x |> { False ~ (f x ~ (t1:t2:t3:t4)) }] }++     So we have two problems:+       1) Since we do not print the constraints in the general case (they may+          be too many), the warning will look like this:++            Pattern match(es) are non-exhaustive+            In an equation for `h':+                Patterns not matched:+                    _+                    _+                    _+          Which is not short and not more useful than a single underscore.+       2) The size of the uncovered set increases a lot, without gaining more+          expressivity in our warnings.++     Hence, in this case, we replace the guard @([a,b] <- f x)@ with a *dummy*+     @fake_pat@: @True <- _@. That is, we record that there is a possibility+     of failure but we minimize it to a True/False. This generates a single+     warning and much smaller uncovered sets.++2. Overloaded Lists+-------------------+An overloaded list @[...]@ should be translated to @x ([...] <- toList x)@. The+problem is exactly like above, as its solution. For future reference, the code+below is the *right thing to do*:++   ListPat lpats elem_ty (Just (pat_ty, to_list))+     otherwise -> do+       (xp, xe) <- mkPmId2Forms pat_ty+       ps       <- translatePatVec (map unLoc lpats)+       let pats = foldr (mkListPatVec elem_ty) [nilPattern elem_ty] ps+           g    = mkGuard pats (HsApp (noLoc to_list) xe)+       return [xp,g]++3. Overloaded Literals+----------------------+The case with literals is a bit different. a literal @l@ should be translated+to @x (True <- x == from l)@. Since we want to have better warnings for+overloaded literals as it is a very common feature, we treat them differently.+They are mainly covered in Note [Undecidable Equality on Overloaded Literals]+in PmExpr.++4. N+K Patterns & Pattern Synonyms+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+An n+k pattern (n+k) should be translated to @x (True <- x >= k) (n <- x-k)@.+Since the only pattern of the three that causes failure is guard @(n <- x-k)@,+and has two possible outcomes. Hence, there is no benefit in using a dummy and+we implement the proper thing. Pattern synonyms are simply not implemented yet.+Hence, to be conservative, we generate a dummy pattern, assuming that the+pattern can fail.++5. Actual Guards+----------------+During translation, boolean guards and pattern guards are translated properly.+Let bindings though are omitted by function @translateLet@. Since they are lazy+bindings, we do not actually want to generate a (strict) equality (like we do+in the pattern bind case). Hence, we safely drop them.++Additionally, top-level guard translation (performed by @translateGuards@)+replaces guards that cannot be reasoned about (like the ones we described in+1-4) with a single @fake_pat@ to record the possibility of failure to match.++Note [Translate CoPats]+~~~~~~~~~~~~~~~~~~~~~~~+The pattern match checker did not know how to handle coerced patterns `CoPat`+efficiently, which gave rise to #11276. The original approach translated+`CoPat`s:++    pat |> co    ===>    x (pat <- (e |> co))++Instead, we now check whether the coercion is a hole or if it is just refl, in+which case we can drop it. Unfortunately, data families generate useful+coercions so guards are still generated in these cases and checking data+families is not really efficient.++%************************************************************************+%*                                                                      *+                 Utilities for Pattern Match Checking+%*                                                                      *+%************************************************************************+-}++-- ----------------------------------------------------------------------------+-- * Basic utilities++-- | Get the type out of a PmPat. For guard patterns (ps <- e) we use the type+-- of the first (or the single -WHEREVER IT IS- valid to use?) pattern+pmPatType :: PmPat p -> Type+pmPatType (PmCon { pm_con_con = con, pm_con_arg_tys = tys })+  = conLikeResTy con tys+pmPatType (PmVar  { pm_var_id  = x }) = idType x+pmPatType (PmLit  { pm_lit_lit = l }) = pmLitType l+pmPatType (PmNLit { pm_lit_id  = x }) = idType x+pmPatType (PmGrd  { pm_grd_pv  = pv })+  = ASSERT(patVecArity pv == 1) (pmPatType p)+  where Just p = find ((==1) . patternArity) pv++-- | Generate a value abstraction for a given constructor (generate+-- fresh variables of the appropriate type for arguments)+mkOneConFull :: Id -> ConLike -> DsM (ValAbs, ComplexEq, Bag EvVar)+--  *  x :: T tys, where T is an algebraic data type+--     NB: in the case of a data family, T is the *representation* TyCon+--     e.g.   data instance T (a,b) = T1 a b+--       leads to+--            data TPair a b = T1 a b  -- The "representation" type+--       It is TPair, not T, that is given to mkOneConFull+--+--  * 'con' K is a constructor of data type T+--+-- After instantiating the universal tyvars of K we get+--          K tys :: forall bs. Q => s1 .. sn -> T tys+--+-- Results: ValAbs:          K (y1::s1) .. (yn::sn)+--          ComplexEq:       x ~ K y1..yn+--          [EvVar]:         Q+mkOneConFull x con = do+  let -- res_ty == TyConApp (ConLikeTyCon cabs_con) cabs_arg_tys+      res_ty  = idType x+      (univ_tvs, ex_tvs, eq_spec, thetas, _req_theta , arg_tys, _)+        = conLikeFullSig con+      tc_args = case splitTyConApp_maybe res_ty of+                  Just (_, tys) -> tys+                  Nothing -> pprPanic "mkOneConFull: Not TyConApp:" (ppr res_ty)+      subst1  = zipTvSubst univ_tvs tc_args++  (subst, ex_tvs') <- cloneTyVarBndrs subst1 ex_tvs <$> getUniqueSupplyM++  -- Fresh term variables (VAs) as arguments to the constructor+  arguments <-  mapM mkPmVar (substTys subst arg_tys)+  -- All constraints bound by the constructor (alpha-renamed)+  let theta_cs = substTheta subst (eqSpecPreds eq_spec ++ thetas)+  evvars <- mapM (nameType "pm") theta_cs+  let con_abs  = PmCon { pm_con_con     = con+                       , pm_con_arg_tys = tc_args+                       , pm_con_tvs     = ex_tvs'+                       , pm_con_dicts   = evvars+                       , pm_con_args    = arguments }+  return (con_abs, (PmExprVar (idName x), vaToPmExpr con_abs), listToBag evvars)++-- ----------------------------------------------------------------------------+-- * More smart constructors and fresh variable generation++-- | Create a guard pattern+mkGuard :: PatVec -> HsExpr Id -> Pattern+mkGuard pv e+  | all cantFailPattern pv = PmGrd pv expr+  | PmExprOther {} <- expr = fake_pat+  | otherwise              = PmGrd pv expr+  where+    expr = hsExprToPmExpr e++-- | Create a term equality of the form: `(False ~ (x ~ lit))`+mkNegEq :: Id -> PmLit -> ComplexEq+mkNegEq x l = (falsePmExpr, PmExprVar (idName x) `PmExprEq` PmExprLit l)+{-# INLINE mkNegEq #-}++-- | Create a term equality of the form: `(x ~ lit)`+mkPosEq :: Id -> PmLit -> ComplexEq+mkPosEq x l = (PmExprVar (idName x), PmExprLit l)+{-# INLINE mkPosEq #-}++-- | Create a term equality of the form: `(x ~ x)`+-- (always discharged by the term oracle)+mkIdEq :: Id -> ComplexEq+mkIdEq x = (PmExprVar name, PmExprVar name)+  where name = idName x+{-# INLINE mkIdEq #-}++-- | Generate a variable pattern of a given type+mkPmVar :: Type -> DsM (PmPat p)+mkPmVar ty = PmVar <$> mkPmId ty+{-# INLINE mkPmVar #-}++-- | Generate many variable patterns, given a list of types+mkPmVars :: [Type] -> DsM PatVec+mkPmVars tys = mapM mkPmVar tys+{-# INLINE mkPmVars #-}++-- | Generate a fresh `Id` of a given type+mkPmId :: Type -> DsM Id+mkPmId ty = getUniqueM >>= \unique ->+  let occname = mkVarOccFS (fsLit (show unique))+      name    = mkInternalName unique occname noSrcSpan+  in  return (mkLocalId name ty)++-- | Generate a fresh term variable of a given and return it in two forms:+-- * A variable pattern+-- * A variable expression+mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr Id)+mkPmId2Forms ty = do+  x <- mkPmId ty+  return (PmVar x, noLoc (HsVar (noLoc x)))++-- ----------------------------------------------------------------------------+-- * Converting between Value Abstractions, Patterns and PmExpr++-- | Convert a value abstraction an expression+vaToPmExpr :: ValAbs -> PmExpr+vaToPmExpr (PmCon  { pm_con_con = c, pm_con_args = ps })+  = PmExprCon c (map vaToPmExpr ps)+vaToPmExpr (PmVar  { pm_var_id  = x }) = PmExprVar (idName x)+vaToPmExpr (PmLit  { pm_lit_lit = l }) = PmExprLit l+vaToPmExpr (PmNLit { pm_lit_id  = x }) = PmExprVar (idName x)++-- | Convert a pattern vector to a list of value abstractions by dropping the+-- guards (See Note [Translating As Patterns])+coercePatVec :: PatVec -> [ValAbs]+coercePatVec pv = concatMap coercePmPat pv++-- | Convert a pattern to a list of value abstractions (will be either an empty+-- list if the pattern is a guard pattern, or a singleton list in all other+-- cases) by dropping the guards (See Note [Translating As Patterns])+coercePmPat :: Pattern -> [ValAbs]+coercePmPat (PmVar { pm_var_id  = x }) = [PmVar { pm_var_id  = x }]+coercePmPat (PmLit { pm_lit_lit = l }) = [PmLit { pm_lit_lit = l }]+coercePmPat (PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys+                   , pm_con_tvs = tvs, pm_con_dicts = dicts+                   , pm_con_args = args })+  = [PmCon { pm_con_con  = con, pm_con_arg_tys = arg_tys+           , pm_con_tvs  = tvs, pm_con_dicts = dicts+           , pm_con_args = coercePatVec args }]+coercePmPat (PmGrd {}) = [] -- drop the guards++-- | Check whether a data constructor is the only way to construct+-- a data type.+singleConstructor :: ConLike -> Bool+singleConstructor (RealDataCon dc) =+  case tyConDataCons (dataConTyCon dc) of+    [_] -> True+    _   -> False+singleConstructor _ = False++-- | For a given conlike, finds all the sets of patterns which could+-- be relevant to that conlike by consulting the result type.+--+-- These come from two places.+--  1. From data constructors defined with the result type constructor.+--  2. From `COMPLETE` pragmas which have the same type as the result+--     type constructor.+allCompleteMatches :: ConLike -> [Type] -> DsM [(Provenance, [ConLike])]+allCompleteMatches cl tys = do+  let fam = case cl of+           RealDataCon dc ->+            [(FromBuiltin, map RealDataCon (tyConDataCons (dataConTyCon dc)))]+           PatSynCon _    -> []++  pragmas <- case splitTyConApp_maybe (conLikeResTy cl tys) of+              Just (tc, _) -> dsGetCompleteMatches tc+              Nothing -> return []+  let fams cm = fmap (FromComplete,) $+                mapM dsLookupConLike (completeMatchConLikes cm)+  from_pragma <- mapM fams pragmas++  let final_groups = fam ++ from_pragma+  tracePmD "allCompleteMatches" (ppr final_groups)+  return final_groups++-- -----------------------------------------------------------------------+-- * Types and constraints++newEvVar :: Name -> Type -> EvVar+newEvVar name ty = mkLocalId name (toTcType ty)++nameType :: String -> Type -> DsM EvVar+nameType name ty = do+  unique <- getUniqueM+  let occname = mkVarOccFS (fsLit (name++"_"++show unique))+      idname  = mkInternalName unique occname noSrcSpan+  return (newEvVar idname ty)++{-+%************************************************************************+%*                                                                      *+                              The type oracle+%*                                                                      *+%************************************************************************+-}++-- | Check whether a set of type constraints is satisfiable.+tyOracle :: Bag EvVar -> PmM Bool+tyOracle evs+  = liftD $+    do { ((_warns, errs), res) <- initTcDsForSolver $ tcCheckSatisfiability evs+       ; case res of+            Just sat -> return sat+            Nothing  -> pprPanic "tyOracle" (vcat $ pprErrMsgBagWithLoc errs) }++{-+%************************************************************************+%*                                                                      *+                             Sanity Checks+%*                                                                      *+%************************************************************************+-}++-- | The arity of a pattern/pattern vector is the+-- number of top-level patterns that are not guards+type PmArity = Int++-- | Compute the arity of a pattern vector+patVecArity :: PatVec -> PmArity+patVecArity = sum . map patternArity++-- | Compute the arity of a pattern+patternArity :: Pattern -> PmArity+patternArity (PmGrd {}) = 0+patternArity _other_pat = 1++{-+%************************************************************************+%*                                                                      *+            Heart of the algorithm: Function pmcheck+%*                                                                      *+%************************************************************************++Main functions are:++* mkInitialUncovered :: [Id] -> PmM Uncovered++  Generates the initial uncovered set. Term and type constraints in scope+  are checked, if they are inconsistent, the set is empty, otherwise, the+  set contains only a vector of variables with the constraints in scope.++* pmcheck :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult++  Checks redundancy, coverage and inaccessibility, using auxilary functions+  `pmcheckGuards` and `pmcheckHd`. Mainly handles the guard case which is+  common in all three checks (see paper) and calls `pmcheckGuards` when the+  whole clause is checked, or `pmcheckHd` when the pattern vector does not+  start with a guard.++* pmcheckGuards :: [PatVec] -> ValVec -> PmM PartialResult++  Processes the guards.++* pmcheckHd :: Pattern -> PatVec -> [PatVec]+          -> ValAbs -> ValVec -> PmM PartialResult++  Worker: This function implements functions `covered`, `uncovered` and+  `divergent` from the paper at once. Slightly different from the paper because+  it does not even produce the covered and uncovered sets. Since we only care+  about whether a clause covers SOMETHING or if it may forces ANY argument, we+  only store a boolean in both cases, for efficiency.+-}++-- | Lift a pattern matching action from a single value vector abstration to a+-- value set abstraction, but calling it on every vector and the combining the+-- results.+runMany :: (ValVec -> PmM PartialResult) -> (Uncovered -> PmM PartialResult)+runMany _ [] = return mempty+runMany pm (m:ms) = mappend <$> pm m <*> runMany pm ms++-- | Generate the initial uncovered set. It initializes the+-- delta with all term and type constraints in scope.+mkInitialUncovered :: [Id] -> PmM Uncovered+mkInitialUncovered vars = do+  ty_cs  <- liftD getDictsDs+  tm_cs  <- map toComplex . bagToList <$> liftD getTmCsDs+  sat_ty <- tyOracle ty_cs+  let initTyCs = if sat_ty then ty_cs else emptyBag+      initTmState = fromMaybe initialTmState (tmOracle initialTmState tm_cs)+      patterns  = map PmVar vars+    -- If any of the term/type constraints are non+    -- satisfiable then return with the initialTmState. See #12957+  return [ValVec patterns (MkDelta initTyCs initTmState)]++-- | Increase the counter for elapsed algorithm iterations, check that the+-- limit is not exceeded and call `pmcheck`+pmcheckI :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult+pmcheckI ps guards vva = do+  n <- liftD incrCheckPmIterDs+  tracePm "pmCheck" (ppr n <> colon <+> pprPatVec ps+                        $$ hang (text "guards:") 2 (vcat (map pprPatVec guards))+                        $$ pprValVecDebug vva)+  res <- pmcheck ps guards vva+  tracePm "pmCheckResult:" (ppr res)+  return res+{-# INLINE pmcheckI #-}++-- | Increase the counter for elapsed algorithm iterations, check that the+-- limit is not exceeded and call `pmcheckGuards`+pmcheckGuardsI :: [PatVec] -> ValVec -> PmM PartialResult+pmcheckGuardsI gvs vva = liftD incrCheckPmIterDs >> pmcheckGuards gvs vva+{-# INLINE pmcheckGuardsI #-}++-- | Increase the counter for elapsed algorithm iterations, check that the+-- limit is not exceeded and call `pmcheckHd`+pmcheckHdI :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec+           -> PmM PartialResult+pmcheckHdI p ps guards va vva = do+  n <- liftD incrCheckPmIterDs+  tracePm "pmCheckHdI" (ppr n <> colon <+> pprPmPatDebug p+                        $$ pprPatVec ps+                        $$ hang (text "guards:") 2 (vcat (map pprPatVec guards))+                        $$ pprPmPatDebug va+                        $$ pprValVecDebug vva)++  res <- pmcheckHd p ps guards va vva+  tracePm "pmCheckHdI: res" (ppr res)+  return res+{-# INLINE pmcheckHdI #-}++-- | Matching function: Check simultaneously a clause (takes separately the+-- patterns and the list of guards) for exhaustiveness, redundancy and+-- inaccessibility.+pmcheck :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult+pmcheck [] guards vva@(ValVec [] _)+  | null guards = return $ mempty { presultCovered = Covered }+  | otherwise   = pmcheckGuardsI guards vva++-- Guard+pmcheck (p@(PmGrd pv e) : ps) guards vva@(ValVec vas delta)+    -- short-circuit if the guard pattern is useless.+    -- we just have two possible outcomes: fail here or match and recurse+    -- none of the two contains any useful information about the failure+    -- though. So just have these two cases but do not do all the boilerplate+  | isFakeGuard pv e = forces . mkCons vva <$> pmcheckI ps guards vva+  | otherwise = do+      y <- liftD $ mkPmId (pmPatType p)+      let tm_state = extendSubst y e (delta_tm_cs delta)+          delta'   = delta { delta_tm_cs = tm_state }+      utail <$> pmcheckI (pv ++ ps) guards (ValVec (PmVar y : vas) delta')++pmcheck [] _ (ValVec (_:_) _) = panic "pmcheck: nil-cons"+pmcheck (_:_) _ (ValVec [] _) = panic "pmcheck: cons-nil"++pmcheck (p:ps) guards (ValVec (va:vva) delta)+  = pmcheckHdI p ps guards va (ValVec vva delta)++-- | Check the list of guards+pmcheckGuards :: [PatVec] -> ValVec -> PmM PartialResult+pmcheckGuards []       vva = return (usimple [vva])+pmcheckGuards (gv:gvs) vva = do+  (PartialResult prov1 cs vsa ds) <- pmcheckI gv [] vva+  (PartialResult prov2 css vsas dss) <- runMany (pmcheckGuardsI gvs) vsa+  return $ PartialResult (prov1 `mappend` prov2)+                         (cs `mappend` css)+                         vsas+                         (ds `mappend` dss)++-- | Worker function: Implements all cases described in the paper for all three+-- functions (`covered`, `uncovered` and `divergent`) apart from the `Guard`+-- cases which are handled by `pmcheck`+pmcheckHd :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec+          -> PmM PartialResult++-- Var+pmcheckHd (PmVar x) ps guards va (ValVec vva delta)+  | Just tm_state <- solveOneEq (delta_tm_cs delta)+                                (PmExprVar (idName x), vaToPmExpr va)+  = ucon va <$> pmcheckI ps guards (ValVec vva (delta {delta_tm_cs = tm_state}))+  | otherwise = return mempty++-- ConCon+pmcheckHd ( p@(PmCon {pm_con_con = c1, pm_con_args = args1})) ps guards+          (va@(PmCon {pm_con_con = c2, pm_con_args = args2})) (ValVec vva delta)+  | c1 /= c2  =+    return (usimple [ValVec (va:vva) delta])+  | otherwise = kcon c1 (pm_con_arg_tys p) (pm_con_tvs p) (pm_con_dicts p)+                <$> pmcheckI (args1 ++ ps) guards (ValVec (args2 ++ vva) delta)++-- LitLit+pmcheckHd (PmLit l1) ps guards (va@(PmLit l2)) vva =+  case eqPmLit l1 l2 of+    True  -> ucon va <$> pmcheckI ps guards vva+    False -> return $ ucon va (usimple [vva])++-- ConVar+pmcheckHd (p@(PmCon { pm_con_con = con, pm_con_arg_tys = tys }))+          ps guards+          (PmVar x) (ValVec vva delta) = do+  (prov, complete_match) <- select =<< liftD (allCompleteMatches con tys)++  cons_cs <- mapM (liftD . mkOneConFull x) complete_match++  inst_vsa <- flip concatMapM cons_cs $ \(va, tm_ct, ty_cs) -> do+    let ty_state = ty_cs `unionBags` delta_ty_cs delta -- not actually a state+    sat_ty <- if isEmptyBag ty_cs then return True+                                  else tyOracle ty_state+    return $ case (sat_ty, solveOneEq (delta_tm_cs delta) tm_ct) of+      (True, Just tm_state) -> [ValVec (va:vva) (MkDelta ty_state tm_state)]+      _ty_or_tm_failed      -> []++  set_provenance prov .+    force_if (canDiverge (idName x) (delta_tm_cs delta)) <$>+      runMany (pmcheckI (p:ps) guards) inst_vsa++-- LitVar+pmcheckHd (p@(PmLit l)) ps guards (PmVar x) (ValVec vva delta)+  = force_if (canDiverge (idName x) (delta_tm_cs delta)) <$>+      mkUnion non_matched <$>+        case solveOneEq (delta_tm_cs delta) (mkPosEq x l) of+          Just tm_state -> pmcheckHdI p ps guards (PmLit l) $+                             ValVec vva (delta {delta_tm_cs = tm_state})+          Nothing       -> return mempty+  where+    us | Just tm_state <- solveOneEq (delta_tm_cs delta) (mkNegEq x l)+       = [ValVec (PmNLit x [l] : vva) (delta { delta_tm_cs = tm_state })]+       | otherwise = []++    non_matched = usimple us++-- LitNLit+pmcheckHd (p@(PmLit l)) ps guards+          (PmNLit { pm_lit_id = x, pm_lit_not = lits }) (ValVec vva delta)+  | all (not . eqPmLit l) lits+  , Just tm_state <- solveOneEq (delta_tm_cs delta) (mkPosEq x l)+    -- Both guards check the same so it would be sufficient to have only+    -- the second one. Nevertheless, it is much cheaper to check whether+    -- the literal is in the list so we check it first, to avoid calling+    -- the term oracle (`solveOneEq`) if possible+  = mkUnion non_matched <$>+      pmcheckHdI p ps guards (PmLit l)+                (ValVec vva (delta { delta_tm_cs = tm_state }))+  | otherwise = return non_matched+  where+    us | Just tm_state <- solveOneEq (delta_tm_cs delta) (mkNegEq x l)+       = [ValVec (PmNLit x (l:lits) : vva) (delta { delta_tm_cs = tm_state })]+       | otherwise = []++    non_matched = usimple us++-- ----------------------------------------------------------------------------+-- The following three can happen only in cases like #322 where constructors+-- and overloaded literals appear in the same match. The general strategy is+-- to replace the literal (positive/negative) by a variable and recurse. The+-- fact that the variable is equal to the literal is recorded in `delta` so+-- no information is lost++-- LitCon+pmcheckHd (PmLit l) ps guards (va@(PmCon {})) (ValVec vva delta)+  = do y <- liftD $ mkPmId (pmPatType va)+       let tm_state = extendSubst y (PmExprLit l) (delta_tm_cs delta)+           delta'   = delta { delta_tm_cs = tm_state }+       pmcheckHdI (PmVar y) ps guards va (ValVec vva delta')++-- ConLit+pmcheckHd (p@(PmCon {})) ps guards (PmLit l) (ValVec vva delta)+  = do y <- liftD $ mkPmId (pmPatType p)+       let tm_state = extendSubst y (PmExprLit l) (delta_tm_cs delta)+           delta'   = delta { delta_tm_cs = tm_state }+       pmcheckHdI p ps guards (PmVar y) (ValVec vva delta')++-- ConNLit+pmcheckHd (p@(PmCon {})) ps guards (PmNLit { pm_lit_id = x }) vva+  = pmcheckHdI p ps guards (PmVar x) vva++-- Impossible: handled by pmcheck+pmcheckHd (PmGrd {}) _ _ _ _ = panic "pmcheckHd: Guard"++-- ----------------------------------------------------------------------------+-- * Utilities for main checking++updateVsa :: (ValSetAbs -> ValSetAbs) -> (PartialResult -> PartialResult)+updateVsa f p@(PartialResult { presultUncovered = old })+  = p { presultUncovered = f old }+++-- | Initialise with default values for covering and divergent information.+usimple :: ValSetAbs -> PartialResult+usimple vsa = mempty { presultUncovered = vsa }++-- | Take the tail of all value vector abstractions in the uncovered set+utail :: PartialResult -> PartialResult+utail = updateVsa upd+  where upd vsa = [ ValVec vva delta | ValVec (_:vva) delta <- vsa ]++-- | Prepend a value abstraction to all value vector abstractions in the+-- uncovered set+ucon :: ValAbs -> PartialResult -> PartialResult+ucon va = updateVsa upd+  where+    upd vsa = [ ValVec (va:vva) delta | ValVec vva delta <- vsa ]++-- | Given a data constructor of arity `a` and an uncovered set containing+-- value vector abstractions of length `(a+n)`, pass the first `n` value+-- abstractions to the constructor (Hence, the resulting value vector+-- abstractions will have length `n+1`)+kcon :: ConLike -> [Type] -> [TyVar] -> [EvVar]+     -> PartialResult -> PartialResult+kcon con arg_tys ex_tvs dicts+  = let n = conLikeArity con+        upd vsa =+          [ ValVec (va:vva) delta+          | ValVec vva' delta <- vsa+          , let (args, vva) = splitAt n vva'+          , let va = PmCon { pm_con_con     = con+                            , pm_con_arg_tys = arg_tys+                            , pm_con_tvs     = ex_tvs+                            , pm_con_dicts   = dicts+                            , pm_con_args    = args } ]+    in updateVsa upd++-- | Get the union of two covered, uncovered and divergent value set+-- abstractions. Since the covered and divergent sets are represented by a+-- boolean, union means computing the logical or (at least one of the two is+-- non-empty).++mkUnion :: PartialResult -> PartialResult -> PartialResult+mkUnion = mappend++-- | Add a value vector abstraction to a value set abstraction (uncovered).+mkCons :: ValVec -> PartialResult -> PartialResult+mkCons vva = updateVsa (vva:)++-- | Set the divergent set to not empty+forces :: PartialResult -> PartialResult+forces pres = pres { presultDivergent = Diverged }++-- | Set the divergent set to non-empty if the flag is `True`+force_if :: Bool -> PartialResult -> PartialResult+force_if True  pres = forces pres+force_if False pres = pres++set_provenance :: Provenance -> PartialResult -> PartialResult+set_provenance prov pr = pr { presultProvenence = prov }++-- ----------------------------------------------------------------------------+-- * Propagation of term constraints inwards when checking nested matches++{- Note [Type and Term Equality Propagation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When checking a match it would be great to have all type and term information+available so we can get more precise results. For this reason we have functions+`addDictsDs' and `addTmCsDs' in PmMonad that store in the environment type and+term constraints (respectively) as we go deeper.++The type constraints we propagate inwards are collected by `collectEvVarsPats'+in HsPat.hs. This handles bug #4139 ( see example+  https://ghc.haskell.org/trac/ghc/attachment/ticket/4139/GADTbug.hs )+where this is needed.++For term equalities we do less, we just generate equalities for HsCase. For+example we accurately give 2 redundancy warnings for the marked cases:++f :: [a] -> Bool+f x = case x of++  []    -> case x of        -- brings (x ~ []) in scope+             []    -> True+             (_:_) -> False -- can't happen++  (_:_) -> case x of        -- brings (x ~ (_:_)) in scope+             (_:_) -> True+             []    -> False -- can't happen++Functions `genCaseTmCs1' and `genCaseTmCs2' are responsible for generating+these constraints.+-}++-- | Generate equalities when checking a case expression:+--     case x of { p1 -> e1; ... pn -> en }+-- When we go deeper to check e.g. e1 we record two equalities:+-- (x ~ y), where y is the initial uncovered when checking (p1; .. ; pn)+-- and (x ~ p1).+genCaseTmCs2 :: Maybe (LHsExpr Id) -- Scrutinee+             -> [Pat Id]           -- LHS       (should have length 1)+             -> [Id]               -- MatchVars (should have length 1)+             -> DsM (Bag SimpleEq)+genCaseTmCs2 Nothing _ _ = return emptyBag+genCaseTmCs2 (Just scr) [p] [var] = do+  fam_insts <- dsGetFamInstEnvs+  [e] <- map vaToPmExpr . coercePatVec <$> translatePat fam_insts p+  let scr_e = lhsExprToPmExpr scr+  return $ listToBag [(var, e), (var, scr_e)]+genCaseTmCs2 _ _ _ = panic "genCaseTmCs2: HsCase"++-- | Generate a simple equality when checking a case expression:+--     case x of { matches }+-- When checking matches we record that (x ~ y) where y is the initial+-- uncovered. All matches will have to satisfy this equality.+genCaseTmCs1 :: Maybe (LHsExpr Id) -> [Id] -> Bag SimpleEq+genCaseTmCs1 Nothing     _    = emptyBag+genCaseTmCs1 (Just scr) [var] = unitBag (var, lhsExprToPmExpr scr)+genCaseTmCs1 _ _              = panic "genCaseTmCs1: HsCase"++{- Note [Literals in PmPat]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Instead of translating a literal to a variable accompanied with a guard, we+treat them like constructor patterns. The following example from+"./libraries/base/GHC/IO/Encoding.hs" shows why:++mkTextEncoding' :: CodingFailureMode -> String -> IO TextEncoding+mkTextEncoding' cfm enc = case [toUpper c | c <- enc, c /= '-'] of+    "UTF8"    -> return $ UTF8.mkUTF8 cfm+    "UTF16"   -> return $ UTF16.mkUTF16 cfm+    "UTF16LE" -> return $ UTF16.mkUTF16le cfm+    ...++Each clause gets translated to a list of variables with an equal number of+guards. For every guard we generate two cases (equals True/equals False) which+means that we generate 2^n cases to feed the oracle with, where n is the sum of+the length of all strings that appear in the patterns. For this particular+example this means over 2^40 cases. Instead, by representing them like with+constructor we get the following:+  1. We exploit the common prefix with our representation of VSAs+  2. We prune immediately non-reachable cases+     (e.g. False == (x == "U"), True == (x == "U"))++Note [Translating As Patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Instead of translating x@p as:  x (p <- x)+we instead translate it as:     p (x <- coercePattern p)+for performance reasons. For example:++  f x@True  = 1+  f y@False = 2++Gives the following with the first translation:++  x |> {x == False, x == y, y == True}++If we use the second translation we get an empty set, independently of the+oracle. Since the pattern `p' may contain guard patterns though, it cannot be+used as an expression. That's why we call `coercePatVec' to drop the guard and+`vaToPmExpr' to transform the value abstraction to an expression in the+guard pattern (value abstractions are a subset of expressions). We keep the+guards in the first pattern `p' though.+++%************************************************************************+%*                                                                      *+      Pretty printing of exhaustiveness/redundancy check warnings+%*                                                                      *+%************************************************************************+-}++-- | Check whether any part of pattern match checking is enabled (does not+-- matter whether it is the redundancy check or the exhaustiveness check).+isAnyPmCheckEnabled :: DynFlags -> DsMatchContext -> Bool+isAnyPmCheckEnabled dflags (DsMatchContext kind _loc)+  = wopt Opt_WarnOverlappingPatterns dflags || exhaustive dflags kind++instance Outputable ValVec where+  ppr (ValVec vva delta)+    = let (residual_eqs, subst) = wrapUpTmState (delta_tm_cs delta)+          vector                = substInValAbs subst vva+      in  ppr_uncovered (vector, residual_eqs)++-- | Apply a term substitution to a value vector abstraction. All VAs are+-- transformed to PmExpr (used only before pretty printing).+substInValAbs :: PmVarEnv -> [ValAbs] -> [PmExpr]+substInValAbs subst = map (exprDeepLookup subst . vaToPmExpr)++-- | Wrap up the term oracle's state once solving is complete. Drop any+-- information about unhandled constraints (involving HsExprs) and flatten+-- (height 1) the substitution.+wrapUpTmState :: TmState -> ([ComplexEq], PmVarEnv)+wrapUpTmState (residual, (_, subst)) = (residual, flattenPmVarEnv subst)++-- | Issue all the warnings (coverage, exhaustiveness, inaccessibility)+dsPmWarn :: DynFlags -> DsMatchContext -> PmResult -> DsM ()+dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result+  = when (flag_i || flag_u) $ do+      let exists_r = flag_i && notNull redundant && onlyBuiltin+          exists_i = flag_i && notNull inaccessible && onlyBuiltin && not is_rec_upd+          exists_u = flag_u && (case uncovered of+                                  TypeOfUncovered   _ -> True+                                  UncoveredPatterns u -> notNull u)++      when exists_r $ forM_ redundant $ \(L l q) -> do+        putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)+                               (pprEqn q "is redundant"))+      when exists_i $ forM_ inaccessible $ \(L l q) -> do+        putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)+                               (pprEqn q "has inaccessible right hand side"))+      when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $+        case uncovered of+          TypeOfUncovered ty           -> warnEmptyCase ty+          UncoveredPatterns candidates -> pprEqns candidates+  where+    PmResult+      { pmresultProvenance = prov+      , pmresultRedundant = redundant+      , pmresultUncovered = uncovered+      , pmresultInaccessible = inaccessible } = pm_result++    flag_i = wopt Opt_WarnOverlappingPatterns dflags+    flag_u = exhaustive dflags kind+    flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag kind)++    is_rec_upd = case kind of { RecUpd -> True; _ -> False }+       -- See Note [Inaccessible warnings for record updates]++    onlyBuiltin = prov == FromBuiltin++    maxPatterns = maxUncoveredPatterns dflags++    -- Print a single clause (for redundant/with-inaccessible-rhs)+    pprEqn q txt = pp_context True ctx (text txt) $ \f -> ppr_eqn f kind q++    -- Print several clauses (for uncovered clauses)+    pprEqns qs = pp_context False ctx (text "are non-exhaustive") $ \_ ->+      case qs of -- See #11245+           [ValVec [] _]+                    -> text "Guards do not cover entire pattern space"+           _missing -> let us = map ppr qs+                       in  hang (text "Patterns not matched:") 4+                                (vcat (take maxPatterns us)+                                 $$ dots maxPatterns us)++    -- Print a type-annotated wildcard (for non-exhaustive `EmptyCase`s for+    -- which we only know the type and have no inhabitants at hand)+    warnEmptyCase ty = pp_context False ctx (text "are non-exhaustive") $ \_ ->+      hang (text "Patterns not matched:") 4 (underscore <+> dcolon <+> ppr ty)++{- Note [Inaccessible warnings for record updates]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (Trac #12957)+  data T a where+    T1 :: { x :: Int } -> T Bool+    T2 :: { x :: Int } -> T a+    T3 :: T a++  f :: T Char -> T a+  f r = r { x = 3 }++The desugarer will (conservatively generate a case for T1 even though+it's impossible:+  f r = case r of+          T1 x -> T1 3   -- Inaccessible branch+          T2 x -> T2 3+          _    -> error "Missing"++We don't want to warn about the inaccessible branch because the programmer+didn't put it there!  So we filter out the warning here.+-}++-- | Issue a warning when the predefined number of iterations is exceeded+-- for the pattern match checker+warnPmIters :: DynFlags -> DsMatchContext -> DsM ()+warnPmIters dflags (DsMatchContext kind loc)+  = when (flag_i || flag_u) $ do+      iters <- maxPmCheckIterations <$> getDynFlags+      putSrcSpanDs loc (warnDs NoReason (msg iters))+  where+    ctxt   = pprMatchContext kind+    msg is = fsep [ text "Pattern match checker exceeded"+                  , parens (ppr is), text "iterations in", ctxt <> dot+                  , text "(Use -fmax-pmcheck-iterations=n"+                  , text "to set the maximun number of iterations to n)" ]++    flag_i = wopt Opt_WarnOverlappingPatterns dflags+    flag_u = exhaustive dflags kind++dots :: Int -> [a] -> SDoc+dots maxPatterns qs+    | qs `lengthExceeds` maxPatterns = text "..."+    | otherwise                      = empty++-- | Check whether the exhaustiveness checker should run (exhaustiveness only)+exhaustive :: DynFlags -> HsMatchContext id -> Bool+exhaustive  dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag++-- | Denotes whether an exhaustiveness check is supported, and if so,+-- via which 'WarningFlag' it's controlled.+-- Returns 'Nothing' if check is not supported.+exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag+exhaustiveWarningFlag (FunRhs {})   = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag CaseAlt       = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag IfAlt         = Nothing+exhaustiveWarningFlag LambdaExpr    = Just Opt_WarnIncompleteUniPatterns+exhaustiveWarningFlag PatBindRhs    = Just Opt_WarnIncompleteUniPatterns+exhaustiveWarningFlag ProcExpr      = Just Opt_WarnIncompleteUniPatterns+exhaustiveWarningFlag RecUpd        = Just Opt_WarnIncompletePatternsRecUpd+exhaustiveWarningFlag ThPatSplice   = Nothing+exhaustiveWarningFlag PatSyn        = Nothing+exhaustiveWarningFlag ThPatQuote    = Nothing+exhaustiveWarningFlag (StmtCtxt {}) = Nothing -- Don't warn about incomplete patterns+                                       -- in list comprehensions, pattern guards+                                       -- etc. They are often *supposed* to be+                                       -- incomplete++-- True <==> singular+pp_context :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc+pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun+  = vcat [text txt <+> msg,+          sep [ text "In" <+> ppr_match <> char ':'+              , nest 4 (rest_of_msg_fun pref)]]+  where+    txt | singular  = "Pattern match"+        | otherwise = "Pattern match(es)"++    (ppr_match, pref)+        = case kind of+             FunRhs (L _ fun) _ _ -> (pprMatchContext kind,+                                      \ pp -> ppr fun <+> pp)+             _                    -> (pprMatchContext kind, \ pp -> pp)++ppr_pats :: HsMatchContext Name -> [Pat Id] -> SDoc+ppr_pats kind pats+  = sep [sep (map ppr pats), matchSeparator kind, text "..."]++ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> [LPat Id] -> SDoc+ppr_eqn prefixF kind eqn = prefixF (ppr_pats kind (map unLoc eqn))++ppr_constraint :: (SDoc,[PmLit]) -> SDoc+ppr_constraint (var, lits) = var <+> text "is not one of"+                                 <+> braces (pprWithCommas ppr lits)++ppr_uncovered :: ([PmExpr], [ComplexEq]) -> SDoc+ppr_uncovered (expr_vec, complex)+  | null cs   = fsep vec -- there are no literal constraints+  | otherwise = hang (fsep vec) 4 $+                  text "where" <+> vcat (map ppr_constraint cs)+  where+    sdoc_vec = mapM pprPmExprWithParens expr_vec+    (vec,cs) = runPmPprM sdoc_vec (filterComplex complex)++{- Note [Representation of Term Equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the paper, term constraints always take the form (x ~ e). Of course, a more+general constraint of the form (e1 ~ e1) can always be transformed to an+equivalent set of the former constraints, by introducing a fresh, intermediate+variable: { y ~ e1, y ~ e1 }. Yet, implementing this representation gave rise+to #11160 (incredibly bad performance for literal pattern matching). Two are+the main sources of this problem (the actual problem is how these two interact+with each other):++1. Pattern matching on literals generates twice as many constraints as needed.+   Consider the following (tests/ghci/should_run/ghcirun004):++    foo :: Int -> Int+    foo 1    = 0+    ...+    foo 5000 = 4999++   The covered and uncovered set *should* look like:+     U0 = { x |> {} }++     C1  = { 1  |> { x ~ 1 } }+     U1  = { x  |> { False ~ (x ~ 1) } }+     ...+     C10 = { 10 |> { False ~ (x ~ 1), .., False ~ (x ~ 9), x ~ 10 } }+     U10 = { x  |> { False ~ (x ~ 1), .., False ~ (x ~ 9), False ~ (x ~ 10) } }+     ...++     If we replace { False ~ (x ~ 1) } with { y ~ False, y ~ (x ~ 1) }+     we get twice as many constraints. Also note that half of them are just the+     substitution [x |-> False].++2. The term oracle (`tmOracle` in deSugar/TmOracle) uses equalities of the form+   (x ~ e) as substitutions [x |-> e]. More specifically, function+   `extendSubstAndSolve` applies such substitutions in the residual constraints+   and partitions them in the affected and non-affected ones, which are the new+   worklist. Essentially, this gives quadradic behaviour on the number of the+   residual constraints. (This would not be the case if the term oracle used+   mutable variables but, since we use it to handle disjunctions on value set+   abstractions (`Union` case), we chose a pure, incremental interface).++Now the problem becomes apparent (e.g. for clause 300):+  * Set U300 contains 300 substituting constraints [y_i |-> False] and 300+    constraints that we know that will not reduce (stay in the worklist).+  * To check for consistency, we apply the substituting constraints ONE BY ONE+    (since `tmOracle` is called incrementally, it does not have all of them+    available at once). Hence, we go through the (non-progressing) constraints+    over and over, achieving over-quadradic behaviour.++If instead we allow constraints of the form (e ~ e),+  * All uncovered sets Ui contain no substituting constraints and i+    non-progressing constraints of the form (False ~ (x ~ lit)) so the oracle+    behaves linearly.+  * All covered sets Ci contain exactly (i-1) non-progressing constraints and+    a single substituting constraint. So the term oracle goes through the+    constraints only once.++The performance improvement becomes even more important when more arguments are+involved.+-}++-- Debugging Infrastructre++tracePm :: String -> SDoc -> PmM ()+tracePm herald doc = liftD $ tracePmD herald doc+++tracePmD :: String -> SDoc -> DsM ()+tracePmD herald doc = do+  dflags <- getDynFlags+  printer <- mkPrintUnqualifiedDs+  liftIO $ dumpIfSet_dyn_printer printer dflags+            Opt_D_dump_ec_trace (text herald $$ (nest 2 doc))+++pprPmPatDebug :: PmPat a -> SDoc+pprPmPatDebug (PmCon cc _arg_tys _con_tvs _con_dicts con_args)+  = hsep [text "PmCon", ppr cc, hsep (map pprPmPatDebug con_args)]+pprPmPatDebug (PmVar vid) = text "PmVar" <+> ppr vid+pprPmPatDebug (PmLit li)  = text "PmLit" <+> ppr li+pprPmPatDebug (PmNLit i nl) = text "PmNLit" <+> ppr i <+> ppr nl+pprPmPatDebug (PmGrd pv ge) = text "PmGrd" <+> hsep (map pprPmPatDebug pv)+                                           <+> ppr ge++pprPatVec :: PatVec -> SDoc+pprPatVec ps = hang (text "Pattern:") 2+                (brackets $ sep+                  $ punctuate (comma <> char '\n') (map pprPmPatDebug ps))++pprValAbs :: [ValAbs] -> SDoc+pprValAbs ps = hang (text "ValAbs:") 2+                (brackets $ sep+                  $ punctuate (comma) (map pprPmPatDebug ps))++pprValVecDebug :: ValVec -> SDoc+pprValVecDebug (ValVec vas _d) = text "ValVec" <+>+                                  parens (pprValAbs vas)
+ deSugar/Coverage.hs view
@@ -0,0 +1,1354 @@+{-+(c) Galois, 2006+(c) University of Glasgow, 2007+-}++{-# LANGUAGE CPP, NondecreasingIndentation, RecordWildCards #-}++module Coverage (addTicksToBinds, hpcInitCode) where++import qualified GHCi+import GHCi.RemoteTypes+import Data.Array+import ByteCodeTypes+#if MIN_VERSION_base(4,9,0)+import GHC.Stack.CCS+#else+import GHC.Stack as GHC.Stack.CCS+#endif+import Type+import HsSyn+import Module+import Outputable+import DynFlags+import ConLike+import Control.Monad+import SrcLoc+import ErrUtils+import NameSet hiding (FreeVars)+import Name+import Bag+import CostCentre+import CoreSyn+import Id+import VarSet+import Data.List+import FastString+import HscTypes+import TyCon+import UniqSupply+import BasicTypes+import MonadUtils+import Maybes+import CLabel+import Util++import Data.Time+import System.Directory++import Trace.Hpc.Mix+import Trace.Hpc.Util++import Data.Map (Map)+import qualified Data.Map as Map++{-+************************************************************************+*                                                                      *+*              The main function: addTicksToBinds+*                                                                      *+************************************************************************+-}++addTicksToBinds+        :: HscEnv+        -> Module+        -> ModLocation          -- ... off the current module+        -> NameSet              -- Exported Ids.  When we call addTicksToBinds,+                                -- isExportedId doesn't work yet (the desugarer+                                -- hasn't set it), so we have to work from this set.+        -> [TyCon]              -- Type constructor in this module+        -> LHsBinds Id+        -> IO (LHsBinds Id, HpcInfo, Maybe ModBreaks)++addTicksToBinds hsc_env mod mod_loc exports tyCons binds+  | let dflags = hsc_dflags hsc_env+        passes = coveragePasses dflags, not (null passes),+    Just orig_file <- ml_hs_file mod_loc,+    not ("boot" `isSuffixOf` orig_file) = do++     us <- mkSplitUniqSupply 'C' -- for cost centres+     let  orig_file2 = guessSourceFile binds orig_file++          tickPass tickish (binds,st) =+            let env = TTE+                      { fileName     = mkFastString orig_file2+                      , declPath     = []+                      , tte_dflags   = dflags+                      , exports      = exports+                      , inlines      = emptyVarSet+                      , inScope      = emptyVarSet+                      , blackList    = Map.fromList+                                          [ (getSrcSpan (tyConName tyCon),())+                                          | tyCon <- tyCons ]+                      , density      = mkDensity tickish dflags+                      , this_mod     = mod+                      , tickishType  = tickish+}+                (binds',_,st') = unTM (addTickLHsBinds binds) env st+            in (binds', st')++          initState = TT { tickBoxCount = 0+                         , mixEntries   = []+                         , uniqSupply   = us+                         }++          (binds1,st) = foldr tickPass (binds, initState) passes++     let tickCount = tickBoxCount st+         entries = reverse $ mixEntries st+     hashNo <- writeMixEntries dflags mod tickCount entries orig_file2+     modBreaks <- mkModBreaks hsc_env mod tickCount entries++     when (dopt Opt_D_dump_ticked dflags) $+         putLogMsg dflags NoReason SevDump noSrcSpan+             (defaultDumpStyle dflags) (pprLHsBinds binds1)++     return (binds1, HpcInfo tickCount hashNo, Just modBreaks)++  | otherwise = return (binds, emptyHpcInfo False, Nothing)++guessSourceFile :: LHsBinds Id -> FilePath -> FilePath+guessSourceFile binds orig_file =+     -- Try look for a file generated from a .hsc file to a+     -- .hs file, by peeking ahead.+     let top_pos = catMaybes $ foldrBag (\ (L pos _) rest ->+                                 srcSpanFileName_maybe pos : rest) [] binds+     in+     case top_pos of+        (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name+                      -> unpackFS file_name+        _ -> orig_file+++mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO ModBreaks+mkModBreaks hsc_env mod count entries+  | HscInterpreted <- hscTarget (hsc_dflags hsc_env) = do+    breakArray <- GHCi.newBreakArray hsc_env (length entries)+    ccs <- mkCCSArray hsc_env mod count entries+    let+           locsTicks  = listArray (0,count-1) [ span  | (span,_,_,_)  <- entries ]+           varsTicks  = listArray (0,count-1) [ vars  | (_,_,vars,_)  <- entries ]+           declsTicks = listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ]+    return emptyModBreaks+                       { modBreaks_flags = breakArray+                       , modBreaks_locs  = locsTicks+                       , modBreaks_vars  = varsTicks+                       , modBreaks_decls = declsTicks+                       , modBreaks_ccs   = ccs+                       }+  | otherwise = return emptyModBreaks++mkCCSArray+  :: HscEnv -> Module -> Int -> [MixEntry_]+  -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre))+mkCCSArray hsc_env modul count entries = do+  if interpreterProfiled dflags+    then do+      let module_str = moduleNameString (moduleName modul)+      costcentres <- GHCi.mkCostCentres hsc_env module_str (map mk_one entries)+      return (listArray (0,count-1) costcentres)+    else do+      return (listArray (0,-1) [])+ where+    dflags = hsc_dflags hsc_env+    mk_one (srcspan, decl_path, _, _) = (name, src)+      where name = concat (intersperse "." decl_path)+            src = showSDoc dflags (ppr srcspan)+++writeMixEntries+  :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int+writeMixEntries dflags mod count entries filename+  | not (gopt Opt_Hpc dflags) = return 0+  | otherwise   = do+        let+            hpc_dir = hpcDir dflags+            mod_name = moduleNameString (moduleName mod)++            hpc_mod_dir+              | moduleUnitId mod == mainUnitId  = hpc_dir+              | otherwise = hpc_dir ++ "/" ++ unitIdString (moduleUnitId mod)++            tabStop = 8 -- <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 (length entries' /= count) $ do+          panic "the number of .mix entries are inconsistent"+        let hashNo = mixHash filename modTime tabStop entries'+        mixCreate hpc_mod_dir mod_name+                       $ Mix filename modTime (toHash hashNo) tabStop entries'+        return hashNo+++-- -----------------------------------------------------------------------------+-- TickDensity: where to insert ticks++data TickDensity+  = TickForCoverage       -- for Hpc+  | TickForBreakPoints    -- for GHCi+  | TickAllFunctions      -- for -prof-auto-all+  | TickTopFunctions      -- for -prof-auto-top+  | TickExportedFunctions -- for -prof-auto-exported+  | TickCallSites         -- for stack tracing+  deriving Eq++mkDensity :: TickishType -> DynFlags -> TickDensity+mkDensity tickish dflags = case tickish of+  HpcTicks             -> TickForCoverage+  SourceNotes          -> TickForCoverage+  Breakpoints          -> TickForBreakPoints+  ProfNotes ->+    case profAuto dflags of+      ProfAutoAll      -> TickAllFunctions+      ProfAutoTop      -> TickTopFunctions+      ProfAutoExports  -> TickExportedFunctions+      ProfAutoCalls    -> TickCallSites+      _other           -> panic "mkDensity"++-- | Decide whether to add a tick to a binding or not.+shouldTickBind  :: TickDensity+                -> Bool         -- top level?+                -> Bool         -- exported?+                -> Bool         -- simple pat bind?+                -> Bool         -- INLINE pragma?+                -> Bool++shouldTickBind density top_lev exported _simple_pat inline+ = case density of+      TickForBreakPoints    -> False+        -- we never add breakpoints to simple pattern bindings+        -- (there's always a tick on the rhs anyway).+      TickAllFunctions      -> not inline+      TickTopFunctions      -> top_lev && not inline+      TickExportedFunctions -> exported && not inline+      TickForCoverage       -> True+      TickCallSites         -> False++shouldTickPatBind :: TickDensity -> Bool -> Bool+shouldTickPatBind density top_lev+  = case density of+      TickForBreakPoints    -> False+      TickAllFunctions      -> True+      TickTopFunctions      -> top_lev+      TickExportedFunctions -> False+      TickForCoverage       -> False+      TickCallSites         -> False++-- -----------------------------------------------------------------------------+-- Adding ticks to bindings++addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)+addTickLHsBinds = mapBagM addTickLHsBind++addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)+addTickLHsBind (L pos bind@(AbsBinds { abs_binds   = binds,+                                       abs_exports = abs_exports })) = do+  withEnv add_exports $ do+  withEnv add_inlines $ do+  binds' <- addTickLHsBinds binds+  return $ L pos $ bind { abs_binds = binds' }+ where+   -- in AbsBinds, the Id on each binding is not the actual top-level+   -- Id that we are defining, they are related by the abs_exports+   -- field of AbsBinds.  So if we're doing TickExportedFunctions we need+   -- to add the local Ids to the set of exported Names so that we know to+   -- tick the right bindings.+   add_exports env =+     env{ exports = exports env `extendNameSetList`+                      [ idName mid+                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports+                      , idName pid `elemNameSet` (exports env) ] }++   add_inlines env =+     env{ inlines = inlines env `extendVarSetList`+                      [ mid+                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports+                      , isAnyInlinePragma (idInlinePragma pid) ] }++addTickLHsBind (L pos bind@(AbsBindsSig { abs_sig_bind   = val_bind+                                        , abs_sig_export = poly_id }))+  | L _ FunBind { fun_id = L _ mono_id } <- val_bind+  = do withEnv (add_export  mono_id) $ do+       withEnv (add_inlines mono_id) $ do+       val_bind' <- addTickLHsBind val_bind+       return $ L pos $ bind { abs_sig_bind = val_bind' }++  | otherwise+  = pprPanic "addTickLHsBind" (ppr bind)+ where+  -- see AbsBinds comments+  add_export mono_id env+    | idName poly_id `elemNameSet` exports env+    = env { exports = exports env `extendNameSet` idName mono_id }+    | otherwise+    = env++  add_inlines mono_id env+    | isAnyInlinePragma (idInlinePragma poly_id)+    = env { inlines = inlines env `extendVarSet` mono_id }+    | otherwise+    = env++addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do+  let name = getOccString id+  decl_path <- getPathEntry+  density <- getDensity++  inline_ids <- liftM inlines getEnv+  let inline   = isAnyInlinePragma (idInlinePragma id)+                 || id `elemVarSet` inline_ids++  -- See Note [inline sccs]+  tickish <- tickishType `liftM` getEnv+  if inline && tickish == ProfNotes then return (L pos funBind) else do++  (fvs, mg@(MG { mg_alts = matches' })) <-+        getFreeVars $+        addPathEntry name $+        addTickMatchGroup False (fun_matches funBind)++  blackListed <- isBlackListed pos+  exported_names <- liftM exports getEnv++  -- We don't want to generate code for blacklisted positions+  -- We don't want redundant ticks on simple pattern bindings+  -- We don't want to tick non-exported bindings in TickExportedFunctions+  let simple = isSimplePatBind funBind+      toplev = null decl_path+      exported = idName id `elemNameSet` exported_names++  tick <- if not blackListed &&+               shouldTickBind density toplev exported simple inline+             then+                bindTick density name pos fvs+             else+                return Nothing++  let mbCons = maybe Prelude.id (:)+  return $ L pos $ funBind { fun_matches = mg { mg_alts = matches' }+                           , fun_tick = tick `mbCons` fun_tick funBind }++   where+   -- a binding is a simple pattern binding if it is a funbind with+   -- zero patterns+   isSimplePatBind :: HsBind a -> Bool+   isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0++-- TODO: Revisit this+addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do+  let name = "(...)"+  (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs+  let pat' = pat { pat_rhs = rhs'}++  -- Should create ticks here?+  density <- getDensity+  decl_path <- getPathEntry+  let top_lev = null decl_path+  if not (shouldTickPatBind density top_lev) then return (L pos pat') else do++    -- Allocate the ticks+    rhs_tick <- bindTick density name pos fvs+    let patvars = map getOccString (collectPatBinders lhs)+    patvar_ticks <- mapM (\v -> bindTick density v pos fvs) patvars++    -- Add to pattern+    let mbCons = maybe id (:)+        rhs_ticks = rhs_tick `mbCons` fst (pat_ticks pat')+        patvar_tickss = zipWith mbCons patvar_ticks+                        (snd (pat_ticks pat') ++ repeat [])+    return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) }++-- Only internal stuff, not from source, uses VarBind, so we ignore it.+addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind+addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind+++bindTick+  :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))+bindTick density name pos fvs = do+  decl_path <- getPathEntry+  let+      toplev        = null decl_path+      count_entries = toplev || density == TickAllFunctions+      top_only      = density /= TickAllFunctions+      box_label     = if toplev then TopLevelBox [name]+                                else LocalBox (decl_path ++ [name])+  --+  allocATickBox box_label count_entries top_only pos fvs+++-- Note [inline sccs]+--+-- It should be reasonable to add ticks to INLINE functions; however+-- currently this tickles a bug later on because the SCCfinal pass+-- does not look inside unfoldings to find CostCentres.  It would be+-- difficult to fix that, because SCCfinal currently works on STG and+-- not Core (and since it also generates CostCentres for CAFs,+-- changing this would be difficult too).+--+-- Another reason not to add ticks to INLINE functions is that this+-- sometimes handy for avoiding adding a tick to a particular function+-- (see #6131)+--+-- So for now we do not add any ticks to INLINE functions at all.++-- -----------------------------------------------------------------------------+-- Decorate an LHsExpr with ticks++-- selectively add ticks to interesting expressions+addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)+addTickLHsExpr e@(L pos e0) = do+  d <- getDensity+  case d of+    TickForBreakPoints | isGoodBreakExpr e0 -> tick_it+    TickForCoverage    -> tick_it+    TickCallSites      | isCallSite e0      -> tick_it+    _other             -> dont_tick_it+ where+   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0+   dont_tick_it = addTickLHsExprNever e++-- Add a tick to an expression which is the RHS of an equation or a binding.+-- We always consider these to be breakpoints, unless the expression is a 'let'+-- (because the body will definitely have a tick somewhere).  ToDo: perhaps+-- we should treat 'case' and 'if' the same way?+addTickLHsExprRHS :: LHsExpr Id -> TM (LHsExpr Id)+addTickLHsExprRHS e@(L pos e0) = do+  d <- getDensity+  case d of+     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it+                        | otherwise     -> tick_it+     TickForCoverage -> tick_it+     TickCallSites   | isCallSite e0 -> tick_it+     _other          -> dont_tick_it+ where+   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0+   dont_tick_it = addTickLHsExprNever e++-- The inner expression of an evaluation context:+--    let binds in [], ( [] )+-- we never tick these if we're doing HPC, but otherwise+-- we treat it like an ordinary expression.+addTickLHsExprEvalInner :: LHsExpr Id -> TM (LHsExpr Id)+addTickLHsExprEvalInner e = do+   d <- getDensity+   case d of+     TickForCoverage -> addTickLHsExprNever e+     _otherwise      -> addTickLHsExpr e++-- | A let body is treated differently from addTickLHsExprEvalInner+-- above with TickForBreakPoints, because for breakpoints we always+-- want to tick the body, even if it is not a redex.  See test+-- break012.  This gives the user the opportunity to inspect the+-- values of the let-bound variables.+addTickLHsExprLetBody :: LHsExpr Id -> TM (LHsExpr Id)+addTickLHsExprLetBody e@(L pos e0) = do+  d <- getDensity+  case d of+     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it+                        | otherwise     -> tick_it+     _other -> addTickLHsExprEvalInner e+ where+   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0+   dont_tick_it = addTickLHsExprNever e++-- version of addTick that does not actually add a tick,+-- because the scope of this tick is completely subsumed by+-- another.+addTickLHsExprNever :: LHsExpr Id -> TM (LHsExpr Id)+addTickLHsExprNever (L pos e0) = do+    e1 <- addTickHsExpr e0+    return $ L pos e1++-- general heuristic: expressions which do not denote values are good+-- break points+isGoodBreakExpr :: HsExpr Id -> Bool+isGoodBreakExpr (HsApp {})        = True+isGoodBreakExpr (HsAppTypeOut {}) = True+isGoodBreakExpr (OpApp {})        = True+isGoodBreakExpr _other            = False++isCallSite :: HsExpr Id -> Bool+isCallSite HsApp{}        = True+isCallSite HsAppTypeOut{} = True+isCallSite OpApp{}        = True+isCallSite _ = False++addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id)+addTickLHsExprOptAlt oneOfMany (L pos e0)+  = ifDensity TickForCoverage+        (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0)+        (addTickLHsExpr (L pos e0))++addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)+addBinTickLHsExpr boxLabel (L pos e0)+  = ifDensity TickForCoverage+        (allocBinTickBox boxLabel pos $ addTickHsExpr e0)+        (addTickLHsExpr (L pos e0))+++-- -----------------------------------------------------------------------------+-- Decorate the body of an HsExpr with ticks.+-- (Whether to put a tick around the whole expression was already decided,+-- in the addTickLHsExpr family of functions.)++addTickHsExpr :: HsExpr Id -> TM (HsExpr Id)+addTickHsExpr e@(HsVar (L _ id)) = do freeVar id; return e+addTickHsExpr (HsUnboundVar {})  = panic "addTickHsExpr.HsUnboundVar"+addTickHsExpr e@(HsConLikeOut con)+  | Just id <- conLikeWrapId_maybe con = do freeVar id; return e+addTickHsExpr e@(HsIPVar _)      = return e+addTickHsExpr e@(HsOverLit _)    = return e+addTickHsExpr e@(HsOverLabel{})  = return e+addTickHsExpr e@(HsLit _)        = return e+addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup)+addTickHsExpr (HsLamCase mgs)    = liftM HsLamCase (addTickMatchGroup True mgs)+addTickHsExpr (HsApp e1 e2)      = liftM2 HsApp (addTickLHsExprNever e1)+                                                (addTickLHsExpr      e2)+addTickHsExpr (HsAppTypeOut e ty) = liftM2 HsAppTypeOut (addTickLHsExprNever e)+                                                        (return ty)++addTickHsExpr (OpApp e1 e2 fix e3) =+        liftM4 OpApp+                (addTickLHsExpr e1)+                (addTickLHsExprNever e2)+                (return fix)+                (addTickLHsExpr e3)+addTickHsExpr (NegApp e neg) =+        liftM2 NegApp+                (addTickLHsExpr e)+                (addTickSyntaxExpr hpcSrcSpan neg)+addTickHsExpr (HsPar e) =+        liftM HsPar (addTickLHsExprEvalInner e)+addTickHsExpr (SectionL e1 e2) =+        liftM2 SectionL+                (addTickLHsExpr e1)+                (addTickLHsExprNever e2)+addTickHsExpr (SectionR e1 e2) =+        liftM2 SectionR+                (addTickLHsExprNever e1)+                (addTickLHsExpr e2)+addTickHsExpr (ExplicitTuple es boxity) =+        liftM2 ExplicitTuple+                (mapM addTickTupArg es)+                (return boxity)+addTickHsExpr (ExplicitSum tag arity e ty) = do+        e' <- addTickLHsExpr e+        return (ExplicitSum tag arity e' ty)+addTickHsExpr (HsCase e mgs) =+        liftM2 HsCase+                (addTickLHsExpr e) -- not an EvalInner; e might not necessarily+                                   -- be evaluated.+                (addTickMatchGroup False mgs)+addTickHsExpr (HsIf cnd e1 e2 e3) =+        liftM3 (HsIf cnd)+                (addBinTickLHsExpr (BinBox CondBinBox) e1)+                (addTickLHsExprOptAlt True e2)+                (addTickLHsExprOptAlt True e3)+addTickHsExpr (HsMultiIf ty alts)+  = do { let isOneOfMany = case alts of [_] -> False; _ -> True+       ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts+       ; return $ HsMultiIf ty alts' }+addTickHsExpr (HsLet (L l binds) e) =+        bindLocals (collectLocalBinders binds) $+          liftM2 (HsLet . L l)+                  (addTickHsLocalBinds binds) -- to think about: !patterns.+                  (addTickLHsExprLetBody e)+addTickHsExpr (HsDo cxt (L l stmts) srcloc)+  = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())+       ; return (HsDo cxt (L l stmts') srcloc) }+  where+        forQual = case cxt of+                    ListComp -> Just $ BinBox QualBinBox+                    _        -> Nothing+addTickHsExpr (ExplicitList ty wit es) =+        liftM3 ExplicitList+                (return ty)+                (addTickWit wit)+                (mapM (addTickLHsExpr) es)+             where addTickWit Nothing = return Nothing+                   addTickWit (Just fln)+                     = do fln' <- addTickSyntaxExpr hpcSrcSpan fln+                          return (Just fln')+addTickHsExpr (ExplicitPArr ty es) =+        liftM2 ExplicitPArr+                (return ty)+                (mapM (addTickLHsExpr) es)++addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e++addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds })+  = do { rec_binds' <- addTickHsRecordBinds rec_binds+       ; return (expr { rcon_flds = rec_binds' }) }++addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds })+  = do { e' <- addTickLHsExpr e+       ; flds' <- mapM addTickHsRecField flds+       ; return (expr { rupd_expr = e', rupd_flds = flds' }) }++addTickHsExpr (ExprWithTySig e ty) =+        liftM2 ExprWithTySig+                (addTickLHsExprNever e) -- No need to tick the inner expression+                                    -- for expressions with signatures+                (return ty)+addTickHsExpr (ArithSeq  ty wit arith_seq) =+        liftM3 ArithSeq+                (return ty)+                (addTickWit wit)+                (addTickArithSeqInfo arith_seq)+             where addTickWit Nothing = return Nothing+                   addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl+                                             return (Just fl')++-- We might encounter existing ticks (multiple Coverage passes)+addTickHsExpr (HsTick t e) =+        liftM (HsTick t) (addTickLHsExprNever e)+addTickHsExpr (HsBinTick t0 t1 e) =+        liftM (HsBinTick t0 t1) (addTickLHsExprNever e)++addTickHsExpr (HsTickPragma _ _ _ (L pos e0)) = do+    e2 <- allocTickBox (ExpBox False) False False pos $+                addTickHsExpr e0+    return $ unLoc e2+addTickHsExpr (PArrSeq   ty arith_seq) =+        liftM2 PArrSeq+                (return ty)+                (addTickArithSeqInfo arith_seq)+addTickHsExpr (HsSCC src nm e) =+        liftM3 HsSCC+                (return src)+                (return nm)+                (addTickLHsExpr e)+addTickHsExpr (HsCoreAnn src nm e) =+        liftM3 HsCoreAnn+                (return src)+                (return nm)+                (addTickLHsExpr e)+addTickHsExpr e@(HsBracket     {})   = return e+addTickHsExpr e@(HsTcBracketOut  {}) = return e+addTickHsExpr e@(HsRnBracketOut  {}) = return e+addTickHsExpr e@(HsSpliceE  {})      = return e+addTickHsExpr (HsProc pat cmdtop) =+        liftM2 HsProc+                (addTickLPat pat)+                (liftL (addTickHsCmdTop) cmdtop)+addTickHsExpr (HsWrap w e) =+        liftM2 HsWrap+                (return w)+                (addTickHsExpr e)       -- Explicitly no tick on inside++addTickHsExpr (ExprWithTySigOut e ty) =+        liftM2 ExprWithTySigOut+               (addTickLHsExprNever e) -- No need to tick the inner expression+               (return ty)             -- for expressions with signatures++-- Others should never happen in expression content.+addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)++addTickTupArg :: LHsTupArg Id -> TM (LHsTupArg Id)+addTickTupArg (L l (Present e))  = do { e' <- addTickLHsExpr e+                                      ; return (L l (Present e')) }+addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))++addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id (LHsExpr Id) -> TM (MatchGroup Id (LHsExpr Id))+addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do+  let isOneOfMany = matchesOneOfMany matches+  matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches+  return $ mg { mg_alts = L l matches' }++addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id))+addTickMatch isOneOfMany isLambda (Match mf pats opSig gRHSs) =+  bindLocals (collectPatsBinders pats) $ do+    gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs+    return $ Match mf pats opSig gRHSs'++addTickGRHSs :: Bool -> Bool -> GRHSs Id (LHsExpr Id) -> TM (GRHSs Id (LHsExpr Id))+addTickGRHSs isOneOfMany isLambda (GRHSs guarded (L l local_binds)) = do+  bindLocals binders $ do+    local_binds' <- addTickHsLocalBinds local_binds+    guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded+    return $ GRHSs guarded' (L l local_binds')+  where+    binders = collectLocalBinders local_binds++addTickGRHS :: Bool -> Bool -> GRHS Id (LHsExpr Id) -> TM (GRHS Id (LHsExpr Id))+addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do+  (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts+                        (addTickGRHSBody isOneOfMany isLambda expr)+  return $ GRHS stmts' expr'++addTickGRHSBody :: Bool -> Bool -> LHsExpr Id -> TM (LHsExpr Id)+addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do+  d <- getDensity+  case d of+    TickForCoverage  -> addTickLHsExprOptAlt isOneOfMany expr+    TickAllFunctions | isLambda ->+       addPathEntry "\\" $+         allocTickBox (ExpBox False) True{-count-} False{-not top-} pos $+           addTickHsExpr e0+    _otherwise ->+       addTickLHsExprRHS expr++addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM [ExprLStmt Id]+addTickLStmts isGuard stmts = do+  (stmts, _) <- addTickLStmts' isGuard stmts (return ())+  return stmts++addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM a+               -> TM ([ExprLStmt Id], a)+addTickLStmts' isGuard lstmts res+  = bindLocals (collectLStmtsBinders lstmts) $+    do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts+       ; a <- res+       ; return (lstmts', a) }++addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id (LHsExpr Id) -> TM (Stmt Id (LHsExpr Id))+addTickStmt _isGuard (LastStmt e noret ret) = do+        liftM3 LastStmt+                (addTickLHsExpr e)+                (pure noret)+                (addTickSyntaxExpr hpcSrcSpan ret)+addTickStmt _isGuard (BindStmt pat e bind fail ty) = do+        liftM5 BindStmt+                (addTickLPat pat)+                (addTickLHsExprRHS e)+                (addTickSyntaxExpr hpcSrcSpan bind)+                (addTickSyntaxExpr hpcSrcSpan fail)+                (return ty)+addTickStmt isGuard (BodyStmt e bind' guard' ty) = do+        liftM4 BodyStmt+                (addTick isGuard e)+                (addTickSyntaxExpr hpcSrcSpan bind')+                (addTickSyntaxExpr hpcSrcSpan guard')+                (return ty)+addTickStmt _isGuard (LetStmt (L l binds)) = do+        liftM (LetStmt . L l)+                (addTickHsLocalBinds binds)+addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr ty) = do+    liftM4 ParStmt+        (mapM (addTickStmtAndBinders isGuard) pairs)+        (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr))+        (addTickSyntaxExpr hpcSrcSpan bindExpr)+        (return ty)+addTickStmt isGuard (ApplicativeStmt args mb_join body_ty) = do+    args' <- mapM (addTickApplicativeArg isGuard) args+    return (ApplicativeStmt args' mb_join body_ty)++addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts+                                    , trS_by = by, trS_using = using+                                    , trS_ret = returnExpr, trS_bind = bindExpr+                                    , trS_fmap = liftMExpr }) = do+    t_s <- addTickLStmts isGuard stmts+    t_y <- fmapMaybeM  addTickLHsExprRHS by+    t_u <- addTickLHsExprRHS using+    t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr+    t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr+    L _ t_m <- addTickLHsExpr (L hpcSrcSpan liftMExpr)+    return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u+                  , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }++addTickStmt isGuard stmt@(RecStmt {})+  = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)+       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)+       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)+       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)+       ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'+                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }++addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)+addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e+                  | otherwise          = addTickLHsExprRHS e++addTickApplicativeArg+  :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr Id, ApplicativeArg Id Id)+  -> TM (SyntaxExpr Id, ApplicativeArg Id Id)+addTickApplicativeArg isGuard (op, arg) =+  liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)+ where+  addTickArg (ApplicativeArgOne pat expr) =+    ApplicativeArgOne <$> addTickLPat pat <*> addTickLHsExpr expr+  addTickArg (ApplicativeArgMany stmts ret pat) =+    ApplicativeArgMany+      <$> addTickLStmts isGuard stmts+      <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret))+      <*> addTickLPat pat++addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock Id Id+                      -> TM (ParStmtBlock Id Id)+addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) =+    liftM3 ParStmtBlock+        (addTickLStmts isGuard stmts)+        (return ids)+        (addTickSyntaxExpr hpcSrcSpan returnExpr)++addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)+addTickHsLocalBinds (HsValBinds binds) =+        liftM HsValBinds+                (addTickHsValBinds binds)+addTickHsLocalBinds (HsIPBinds binds)  =+        liftM HsIPBinds+                (addTickHsIPBinds binds)+addTickHsLocalBinds (EmptyLocalBinds)  = return EmptyLocalBinds++addTickHsValBinds :: HsValBindsLR Id a -> TM (HsValBindsLR Id b)+addTickHsValBinds (ValBindsOut binds sigs) =+        liftM2 ValBindsOut+                (mapM (\ (rec,binds') ->+                                liftM2 (,)+                                        (return rec)+                                        (addTickLHsBinds binds'))+                        binds)+                (return sigs)+addTickHsValBinds _ = panic "addTickHsValBinds"++addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id)+addTickHsIPBinds (IPBinds ipbinds dictbinds) =+        liftM2 IPBinds+                (mapM (liftL (addTickIPBind)) ipbinds)+                (return dictbinds)++addTickIPBind :: IPBind Id -> TM (IPBind Id)+addTickIPBind (IPBind nm e) =+        liftM2 IPBind+                (return nm)+                (addTickLHsExpr e)++-- There is no location here, so we might need to use a context location??+addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id)+addTickSyntaxExpr pos syn@(SyntaxExpr { syn_expr = x }) = do+        L _ x' <- addTickLHsExpr (L pos x)+        return $ syn { syn_expr = x' }+-- we do not walk into patterns.+addTickLPat :: LPat Id -> TM (LPat Id)+addTickLPat pat = return pat++addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id)+addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =+        liftM4 HsCmdTop+                (addTickLHsCmd cmd)+                (return tys)+                (return ty)+                (return syntaxtable)++addTickLHsCmd ::  LHsCmd Id -> TM (LHsCmd Id)+addTickLHsCmd (L pos c0) = do+        c1 <- addTickHsCmd c0+        return $ L pos c1++addTickHsCmd :: HsCmd Id -> TM (HsCmd Id)+addTickHsCmd (HsCmdLam matchgroup) =+        liftM HsCmdLam (addTickCmdMatchGroup matchgroup)+addTickHsCmd (HsCmdApp c e) =+        liftM2 HsCmdApp (addTickLHsCmd c) (addTickLHsExpr e)+{-+addTickHsCmd (OpApp e1 c2 fix c3) =+        liftM4 OpApp+                (addTickLHsExpr e1)+                (addTickLHsCmd c2)+                (return fix)+                (addTickLHsCmd c3)+-}+addTickHsCmd (HsCmdPar e) = liftM HsCmdPar (addTickLHsCmd e)+addTickHsCmd (HsCmdCase e mgs) =+        liftM2 HsCmdCase+                (addTickLHsExpr e)+                (addTickCmdMatchGroup mgs)+addTickHsCmd (HsCmdIf cnd e1 c2 c3) =+        liftM3 (HsCmdIf cnd)+                (addBinTickLHsExpr (BinBox CondBinBox) e1)+                (addTickLHsCmd c2)+                (addTickLHsCmd c3)+addTickHsCmd (HsCmdLet (L l binds) c) =+        bindLocals (collectLocalBinders binds) $+          liftM2 (HsCmdLet . L l)+                   (addTickHsLocalBinds binds) -- to think about: !patterns.+                   (addTickLHsCmd c)+addTickHsCmd (HsCmdDo (L l stmts) srcloc)+  = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())+       ; return (HsCmdDo (L l stmts') srcloc) }++addTickHsCmd (HsCmdArrApp   e1 e2 ty1 arr_ty lr) =+        liftM5 HsCmdArrApp+               (addTickLHsExpr e1)+               (addTickLHsExpr e2)+               (return ty1)+               (return arr_ty)+               (return lr)+addTickHsCmd (HsCmdArrForm e f fix cmdtop) =+        liftM4 HsCmdArrForm+               (addTickLHsExpr e)+               (return f)+               (return fix)+               (mapM (liftL (addTickHsCmdTop)) cmdtop)++addTickHsCmd (HsCmdWrap w cmd)+  = liftM2 HsCmdWrap (return w) (addTickHsCmd cmd)++-- Others should never happen in a command context.+--addTickHsCmd e  = pprPanic "addTickHsCmd" (ppr e)++addTickCmdMatchGroup :: MatchGroup Id (LHsCmd Id) -> TM (MatchGroup Id (LHsCmd Id))+addTickCmdMatchGroup mg@(MG { mg_alts = L l matches }) = do+  matches' <- mapM (liftL addTickCmdMatch) matches+  return $ mg { mg_alts = L l matches' }++addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id))+addTickCmdMatch (Match mf pats opSig gRHSs) =+  bindLocals (collectPatsBinders pats) $ do+    gRHSs' <- addTickCmdGRHSs gRHSs+    return $ Match mf pats opSig gRHSs'++addTickCmdGRHSs :: GRHSs Id (LHsCmd Id) -> TM (GRHSs Id (LHsCmd Id))+addTickCmdGRHSs (GRHSs guarded (L l local_binds)) = do+  bindLocals binders $ do+    local_binds' <- addTickHsLocalBinds local_binds+    guarded' <- mapM (liftL addTickCmdGRHS) guarded+    return $ GRHSs guarded' (L l local_binds')+  where+    binders = collectLocalBinders local_binds++addTickCmdGRHS :: GRHS Id (LHsCmd Id) -> TM (GRHS Id (LHsCmd Id))+-- The *guards* are *not* Cmds, although the body is+-- C.f. addTickGRHS for the BinBox stuff+addTickCmdGRHS (GRHS stmts cmd)+  = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)+                                   stmts (addTickLHsCmd cmd)+       ; return $ GRHS stmts' expr' }++addTickLCmdStmts :: [LStmt Id (LHsCmd Id)] -> TM [LStmt Id (LHsCmd Id)]+addTickLCmdStmts stmts = do+  (stmts, _) <- addTickLCmdStmts' stmts (return ())+  return stmts++addTickLCmdStmts' :: [LStmt Id (LHsCmd Id)] -> TM a -> TM ([LStmt Id (LHsCmd Id)], a)+addTickLCmdStmts' lstmts res+  = bindLocals binders $ do+        lstmts' <- mapM (liftL addTickCmdStmt) lstmts+        a <- res+        return (lstmts', a)+  where+        binders = collectLStmtsBinders lstmts++addTickCmdStmt :: Stmt Id (LHsCmd Id) -> TM (Stmt Id (LHsCmd Id))+addTickCmdStmt (BindStmt pat c bind fail ty) = do+        liftM5 BindStmt+                (addTickLPat pat)+                (addTickLHsCmd c)+                (return bind)+                (return fail)+                (return ty)+addTickCmdStmt (LastStmt c noret ret) = do+        liftM3 LastStmt+                (addTickLHsCmd c)+                (pure noret)+                (addTickSyntaxExpr hpcSrcSpan ret)+addTickCmdStmt (BodyStmt c bind' guard' ty) = do+        liftM4 BodyStmt+                (addTickLHsCmd c)+                (addTickSyntaxExpr hpcSrcSpan bind')+                (addTickSyntaxExpr hpcSrcSpan guard')+                (return ty)+addTickCmdStmt (LetStmt (L l binds)) = do+        liftM (LetStmt . L l)+                (addTickHsLocalBinds binds)+addTickCmdStmt stmt@(RecStmt {})+  = do { stmts' <- addTickLCmdStmts (recS_stmts stmt)+       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)+       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)+       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)+       ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'+                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }+addTickCmdStmt ApplicativeStmt{} =+  panic "ToDo: addTickCmdStmt ApplicativeLastStmt"++-- Others should never happen in a command context.+addTickCmdStmt stmt  = pprPanic "addTickHsCmd" (ppr stmt)++addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)+addTickHsRecordBinds (HsRecFields fields dd)+  = do  { fields' <- mapM addTickHsRecField fields+        ; return (HsRecFields fields' dd) }++addTickHsRecField :: LHsRecField' id (LHsExpr Id) -> TM (LHsRecField' id (LHsExpr Id))+addTickHsRecField (L l (HsRecField id expr pun))+        = do { expr' <- addTickLHsExpr expr+             ; return (L l (HsRecField id expr' pun)) }+++addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)+addTickArithSeqInfo (From e1) =+        liftM From+                (addTickLHsExpr e1)+addTickArithSeqInfo (FromThen e1 e2) =+        liftM2 FromThen+                (addTickLHsExpr e1)+                (addTickLHsExpr e2)+addTickArithSeqInfo (FromTo e1 e2) =+        liftM2 FromTo+                (addTickLHsExpr e1)+                (addTickLHsExpr e2)+addTickArithSeqInfo (FromThenTo e1 e2 e3) =+        liftM3 FromThenTo+                (addTickLHsExpr e1)+                (addTickLHsExpr e2)+                (addTickLHsExpr e3)++liftL :: (Monad m) => (a -> m a) -> Located a -> m (Located a)+liftL f (L loc a) = do+  a' <- f a+  return $ L loc a'++data TickTransState = TT { tickBoxCount:: Int+                         , mixEntries  :: [MixEntry_]+                         , uniqSupply  :: UniqSupply+                         }++data TickTransEnv = TTE { fileName     :: FastString+                        , density      :: TickDensity+                        , tte_dflags   :: DynFlags+                        , exports      :: NameSet+                        , inlines      :: VarSet+                        , declPath     :: [String]+                        , inScope      :: VarSet+                        , blackList    :: Map SrcSpan ()+                        , this_mod     :: Module+                        , tickishType  :: TickishType+                        }++--      deriving Show++data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes+                 deriving (Eq)++coveragePasses :: DynFlags -> [TickishType]+coveragePasses dflags =+    ifa (hscTarget dflags == HscInterpreted) Breakpoints $+    ifa (gopt Opt_Hpc dflags)                HpcTicks $+    ifa (gopt Opt_SccProfilingOn dflags &&+         profAuto dflags /= NoProfAuto)      ProfNotes $+    ifa (debugLevel dflags > 0)              SourceNotes []+  where ifa f x xs | f         = x:xs+                   | otherwise = xs++-- | Tickishs that only make sense when their source code location+-- refers to the current file. This might not always be true due to+-- LINE pragmas in the code - which would confuse at least HPC.+tickSameFileOnly :: TickishType -> Bool+tickSameFileOnly HpcTicks = True+tickSameFileOnly _other   = False++type FreeVars = OccEnv Id+noFVs :: FreeVars+noFVs = emptyOccEnv++-- Note [freevars]+--   For breakpoints we want to collect the free variables of an+--   expression for pinning on the HsTick.  We don't want to collect+--   *all* free variables though: in particular there's no point pinning+--   on free variables that are will otherwise be in scope at the GHCi+--   prompt, which means all top-level bindings.  Unfortunately detecting+--   top-level bindings isn't easy (collectHsBindsBinders on the top-level+--   bindings doesn't do it), so we keep track of a set of "in-scope"+--   variables in addition to the free variables, and the former is used+--   to filter additions to the latter.  This gives us complete control+--   over what free variables we track.++data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }+        -- a combination of a state monad (TickTransState) and a writer+        -- monad (FreeVars).++instance Functor TM where+    fmap = liftM++instance Applicative TM where+    pure a = TM $ \ _env st -> (a,noFVs,st)+    (<*>) = ap++instance Monad TM where+  (TM m) >>= k = TM $ \ env st ->+                                case m env st of+                                  (r1,fv1,st1) ->+                                     case unTM (k r1) env st1 of+                                       (r2,fv2,st2) ->+                                          (r2, fv1 `plusOccEnv` fv2, st2)++instance HasDynFlags TM where+  getDynFlags = TM $ \ env st -> (tte_dflags env, noFVs, st)++instance MonadUnique TM where+  getUniqueSupplyM = TM $ \_ st -> (uniqSupply st, noFVs, st)+  getUniqueM = TM $ \_ st -> let (u, us') = takeUniqFromSupply (uniqSupply st)+                             in (u, noFVs, st { uniqSupply = us' })++getState :: TM TickTransState+getState = TM $ \ _ st -> (st, noFVs, st)++setState :: (TickTransState -> TickTransState) -> TM ()+setState f = TM $ \ _ st -> ((), noFVs, f st)++getEnv :: TM TickTransEnv+getEnv = TM $ \ env st -> (env, noFVs, st)++withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a+withEnv f (TM m) = TM $ \ env st ->+                                 case m (f env) st of+                                   (a, fvs, st') -> (a, fvs, st')++getDensity :: TM TickDensity+getDensity = TM $ \env st -> (density env, noFVs, st)++ifDensity :: TickDensity -> TM a -> TM a -> TM a+ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el++getFreeVars :: TM a -> TM (FreeVars, a)+getFreeVars (TM m)+  = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')++freeVar :: Id -> TM ()+freeVar id = TM $ \ env st ->+                if id `elemVarSet` inScope env+                   then ((), unitOccEnv (nameOccName (idName id)) id, st)+                   else ((), noFVs, st)++addPathEntry :: String -> TM a -> TM a+addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })++getPathEntry :: TM [String]+getPathEntry = declPath `liftM` getEnv++getFileName :: TM FastString+getFileName = fileName `liftM` getEnv++isGoodSrcSpan' :: SrcSpan -> Bool+isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos+isGoodSrcSpan' (UnhelpfulSpan _) = False++isGoodTickSrcSpan :: SrcSpan -> TM Bool+isGoodTickSrcSpan pos = do+  file_name <- getFileName+  tickish <- tickishType `liftM` getEnv+  let need_same_file = tickSameFileOnly tickish+      same_file      = Just file_name == srcSpanFileName_maybe pos+  return (isGoodSrcSpan' pos && (not need_same_file || same_file))++ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a+ifGoodTickSrcSpan pos then_code else_code = do+  good <- isGoodTickSrcSpan pos+  if good then then_code else else_code++bindLocals :: [Id] -> TM a -> TM a+bindLocals new_ids (TM m)+  = TM $ \ env st ->+                 case m env{ inScope = inScope env `extendVarSetList` new_ids } st of+                   (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')+  where occs = [ nameOccName (idName id) | id <- new_ids ]++isBlackListed :: SrcSpan -> TM Bool+isBlackListed pos = TM $ \ env st ->+              case Map.lookup pos (blackList env) of+                Nothing -> (False,noFVs,st)+                Just () -> (True,noFVs,st)++-- the tick application inherits the source position of its+-- expression argument to support nested box allocations+allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr Id)+             -> TM (LHsExpr Id)+allocTickBox boxLabel countEntries topOnly pos m =+  ifGoodTickSrcSpan pos (do+    (fvs, e) <- getFreeVars m+    env <- getEnv+    tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)+    return (L pos (HsTick tickish (L pos e)))+  ) (do+    e <- m+    return (L pos e)+  )++-- the tick application inherits the source position of its+-- expression argument to support nested box allocations+allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars+              -> TM (Maybe (Tickish Id))+allocATickBox boxLabel countEntries topOnly  pos fvs =+  ifGoodTickSrcSpan pos (do+    let+      mydecl_path = case boxLabel of+                      TopLevelBox x -> x+                      LocalBox xs  -> xs+                      _ -> panic "allocATickBox"+    tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path+    return (Just tickish)+  ) (return Nothing)+++mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String]+          -> TM (Tickish Id)+mkTickish boxLabel countEntries topOnly pos fvs decl_path = do++  let ids = filter (not . isUnliftedType . idType) $ occEnvElts fvs+          -- unlifted types cause two problems here:+          --   * we can't bind them  at the GHCi prompt+          --     (bindLocalsAtBreakpoint already fliters them out),+          --   * the simplifier might try to substitute a literal for+          --     the Id, and we can't handle that.++      me = (pos, decl_path, map (nameOccName.idName) ids, boxLabel)++      cc_name | topOnly   = head decl_path+              | otherwise = concat (intersperse "." decl_path)++  dflags <- getDynFlags+  env <- getEnv+  case tickishType env of+    HpcTicks -> do+      c <- liftM tickBoxCount getState+      setState $ \st -> st { tickBoxCount = c + 1+                           , mixEntries = me : mixEntries st }+      return $ HpcTick (this_mod env) c++    ProfNotes -> do+      ccUnique <- getUniqueM+      let cc = mkUserCC (mkFastString cc_name) (this_mod env) pos ccUnique+          count = countEntries && gopt Opt_ProfCountEntries dflags+      return $ ProfNote cc count True{-scopes-}++    Breakpoints -> do+      c <- liftM tickBoxCount getState+      setState $ \st -> st { tickBoxCount = c + 1+                           , mixEntries = me:mixEntries st }+      return $ Breakpoint c ids++    SourceNotes | RealSrcSpan pos' <- pos ->+      return $ SourceNote pos' cc_name++    _otherwise -> panic "mkTickish: bad source span!"+++allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr Id)+                -> TM (LHsExpr Id)+allocBinTickBox boxLabel pos m = do+  env <- getEnv+  case tickishType env of+    HpcTicks -> do e <- liftM (L pos) m+                   ifGoodTickSrcSpan pos+                     (mkBinTickBoxHpc boxLabel pos e)+                     (return e)+    _other   -> allocTickBox (ExpBox False) False False pos m++mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr Id+                -> TM (LHsExpr Id)+mkBinTickBoxHpc boxLabel pos e =+ TM $ \ env st ->+  let meT = (pos,declPath env, [],boxLabel True)+      meF = (pos,declPath env, [],boxLabel False)+      meE = (pos,declPath env, [],ExpBox False)+      c = tickBoxCount st+      mes = mixEntries st+  in+             ( L pos $ HsTick (HpcTick (this_mod env) c) $ L pos $ HsBinTick (c+1) (c+2) e+           -- notice that F and T are reversed,+           -- because we are building the list in+           -- reverse...+             , noFVs+             , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}+             )++mkHpcPos :: SrcSpan -> HpcPos+mkHpcPos pos@(RealSrcSpan s)+   | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s,+                                    srcSpanStartCol s,+                                    srcSpanEndLine s,+                                    srcSpanEndCol s - 1)+                              -- the end column of a SrcSpan is one+                              -- greater than the last column of the+                              -- span (see SrcLoc), whereas HPC+                              -- expects to the column range to be+                              -- inclusive, hence we subtract one above.+mkHpcPos _ = panic "bad source span; expected such spans to be filtered out"++hpcSrcSpan :: SrcSpan+hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")++matchesOneOfMany :: [LMatch Id body] -> Bool+matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1+  where+        matchCount (L _ (Match _ _pats _ty (GRHSs grhss _binds))) = length grhss++type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)++-- For the hash value, we hash everything: the file name,+--  the timestamp of the original source file, the tab stop,+--  and the mix entries. We cheat, and hash the show'd string.+-- This hash only has to be hashed at Mix creation time,+-- and is for sanity checking only.++mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int+mixHash file tm tabstop entries = fromIntegral $ hashString+        (show $ Mix file tm 0 tabstop entries)++{-+************************************************************************+*                                                                      *+*              initialisation+*                                                                      *+************************************************************************++Each module compiled with -fhpc declares an initialisation function of+the form `hpc_init_<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 :: Module -> HpcInfo -> SDoc+hpcInitCode _ (NoHpcInfo {}) = Outputable.empty+hpcInitCode this_mod (HpcInfo tickCount hashNo)+ = vcat+    [ text "static void hpc_init_" <> ppr this_mod+         <> text "(void) __attribute__((constructor));"+    , text "static void hpc_init_" <> ppr this_mod <> text "(void)"+    , braces (vcat [+        text "extern StgWord64 " <> tickboxes <>+               text "[]" <> semi,+        text "hs_hpc_module" <>+          parens (hcat (punctuate comma [+              doubleQuotes full_name_str,+              int tickCount, -- really StgWord32+              int hashNo,    -- really StgWord32+              tickboxes+            ])) <> semi+       ])+    ]+  where+    tickboxes = ppr (mkHpcTicksLabel $ this_mod)++    module_name  = hcat (map (text.charToC) $+                         bytesFS (moduleNameFS (Module.moduleName this_mod)))+    package_name = hcat (map (text.charToC) $+                         bytesFS (unitIdFS  (moduleUnitId this_mod)))+    full_name_str+       | moduleUnitId this_mod == mainUnitId+       = module_name+       | otherwise+       = package_name <> char '/' <> module_name
+ deSugar/Desugar.hs view
@@ -0,0 +1,567 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++The Desugarer: turning HsSyn into Core.+-}++{-# LANGUAGE CPP #-}++module Desugar (+    -- * Desugaring operations+    deSugar, deSugarExpr+    ) where++#include "HsVersions.h"++import DsUsage+import DynFlags+import HscTypes+import HsSyn+import TcRnTypes+import TcRnMonad  ( finalSafeMode, fixSafeInstances )+import TcRnDriver ( runTcInteractive )+import Id+import Name+import Type+import InstEnv+import Class+import Avail+import CoreSyn+import CoreFVs     ( exprsSomeFreeVarsList )+import CoreOpt     ( simpleOptPgm, simpleOptExpr )+import PprCore+import DsMonad+import DsExpr+import DsBinds+import DsForeign+import PrelNames   ( coercibleTyConKey )+import TysPrim     ( eqReprPrimTyCon )+import Unique      ( hasKey )+import Coercion    ( mkCoVarCo )+import TysWiredIn  ( coercibleDataCon )+import DataCon     ( dataConWrapId )+import MkCore      ( mkCoreLet )+import Module+import NameSet+import NameEnv+import Rules+import BasicTypes       ( Activation(.. ), competesWith, pprRuleName )+import CoreMonad        ( CoreToDo(..) )+import CoreLint         ( endPassIO )+import VarSet+import FastString+import ErrUtils+import Outputable+import SrcLoc+import Coverage+import Util+import MonadUtils+import OrdList++import Data.List+import Data.IORef+import Control.Monad( when )++{-+************************************************************************+*                                                                      *+*              The main function: deSugar+*                                                                      *+************************************************************************+-}++-- | Main entry point to the desugarer.+deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)+-- Can modify PCS by faulting in more declarations++deSugar hsc_env+        mod_loc+        tcg_env@(TcGblEnv { tcg_mod          = id_mod,+                            tcg_semantic_mod = mod,+                            tcg_src          = hsc_src,+                            tcg_type_env     = type_env,+                            tcg_imports      = imports,+                            tcg_exports      = exports,+                            tcg_keep         = keep_var,+                            tcg_th_splice_used = tc_splice_used,+                            tcg_rdr_env      = rdr_env,+                            tcg_fix_env      = fix_env,+                            tcg_inst_env     = inst_env,+                            tcg_fam_inst_env = fam_inst_env,+                            tcg_merged       = merged,+                            tcg_warns        = warns,+                            tcg_anns         = anns,+                            tcg_binds        = binds,+                            tcg_imp_specs    = imp_specs,+                            tcg_dependent_files = dependent_files,+                            tcg_ev_binds     = ev_binds,+                            tcg_th_foreign_files = th_foreign_files_var,+                            tcg_fords        = fords,+                            tcg_rules        = rules,+                            tcg_vects        = vects,+                            tcg_patsyns      = patsyns,+                            tcg_tcs          = tcs,+                            tcg_insts        = insts,+                            tcg_fam_insts    = fam_insts,+                            tcg_hpc          = other_hpc_info,+                            tcg_complete_matches = complete_matches+                            })++  = do { let dflags = hsc_dflags hsc_env+             print_unqual = mkPrintUnqualified dflags rdr_env+        ; withTiming (pure dflags)+                     (text "Desugar"<+>brackets (ppr mod))+                     (const ()) $+     do { -- Desugar the program+        ; let export_set = availsToNameSet exports+              target     = hscTarget dflags+              hpcInfo    = emptyHpcInfo other_hpc_info++        ; (binds_cvr, ds_hpc_info, modBreaks)+                         <- if not (isHsBootOrSig hsc_src)+                              then addTicksToBinds hsc_env mod mod_loc+                                       export_set (typeEnvTyCons type_env) binds+                              else return (binds, hpcInfo, Nothing)+        ; (msgs, mb_res) <- initDs hsc_env tcg_env $+                       do { ds_ev_binds <- dsEvBinds ev_binds+                          ; core_prs <- dsTopLHsBinds binds_cvr+                          ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs+                          ; (ds_fords, foreign_prs) <- dsForeigns fords+                          ; ds_rules <- mapMaybeM dsRule rules+                          ; ds_vects <- mapM dsVect vects+                          ; let hpc_init+                                  | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info+                                  | otherwise = empty+                          ; return ( ds_ev_binds+                                   , foreign_prs `appOL` core_prs `appOL` spec_prs+                                   , spec_rules ++ ds_rules, ds_vects+                                   , ds_fords `appendStubC` hpc_init) }++        ; case mb_res of {+           Nothing -> return (msgs, Nothing) ;+           Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) ->++     do {       -- Add export flags to bindings+          keep_alive <- readIORef keep_var+        ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules+              final_prs = addExportFlagsAndRules target export_set keep_alive+                                                 rules_for_locals (fromOL all_prs)++              final_pgm = combineEvBinds ds_ev_binds final_prs+        -- Notice that we put the whole lot in a big Rec, even the foreign binds+        -- When compiling PrelFloat, which defines data Float = F# Float#+        -- we want F# to be in scope in the foreign marshalling code!+        -- You might think it doesn't matter, but the simplifier brings all top-level+        -- things into the in-scope set before simplifying; so we get no unfolding for F#!++#ifdef DEBUG+          -- Debug only as pre-simple-optimisation program may be really big+        ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps+#endif+        ; (ds_binds, ds_rules_for_imps, ds_vects)+            <- simpleOptPgm dflags mod final_pgm rules_for_imps vects0+                         -- The simpleOptPgm gets rid of type+                         -- bindings plus any stupid dead code++        ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps++        ; let used_names = mkUsedNames tcg_env+        ; deps <- mkDependencies tcg_env++        ; used_th <- readIORef tc_splice_used+        ; dep_files <- readIORef dependent_files+        ; safe_mode <- finalSafeMode dflags tcg_env+        ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names dep_files merged+        -- id_mod /= mod when we are processing an hsig, but hsigs+        -- never desugared and compiled (there's no code!)+        -- Consequently, this should hold for any ModGuts that make+        -- past desugaring. See Note [Identity versus semantic module].+        ; MASSERT( id_mod == mod )++        ; foreign_files <- readIORef th_foreign_files_var++        ; let mod_guts = ModGuts {+                mg_module       = mod,+                mg_hsc_src      = hsc_src,+                mg_loc          = mkFileSrcSpan mod_loc,+                mg_exports      = exports,+                mg_usages       = usages,+                mg_deps         = deps,+                mg_used_th      = used_th,+                mg_rdr_env      = rdr_env,+                mg_fix_env      = fix_env,+                mg_warns        = warns,+                mg_anns         = anns,+                mg_tcs          = tcs,+                mg_insts        = fixSafeInstances safe_mode insts,+                mg_fam_insts    = fam_insts,+                mg_inst_env     = inst_env,+                mg_fam_inst_env = fam_inst_env,+                mg_patsyns      = patsyns,+                mg_rules        = ds_rules_for_imps,+                mg_binds        = ds_binds,+                mg_foreign      = ds_fords,+                mg_foreign_files = foreign_files,+                mg_hpc_info     = ds_hpc_info,+                mg_modBreaks    = modBreaks,+                mg_vect_decls   = ds_vects,+                mg_vect_info    = noVectInfo,+                mg_safe_haskell = safe_mode,+                mg_trust_pkg    = imp_trust_own_pkg imports,+                mg_complete_sigs = complete_matches+              }+        ; return (msgs, Just mod_guts)+        }}}}++mkFileSrcSpan :: ModLocation -> SrcSpan+mkFileSrcSpan mod_loc+  = case ml_hs_file mod_loc of+      Just file_path -> mkGeneralSrcSpan (mkFastString file_path)+      Nothing        -> interactiveSrcSpan   -- Presumably++dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])+dsImpSpecs imp_specs+ = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs+      ; let (spec_binds, spec_rules) = unzip spec_prs+      ; return (concatOL spec_binds, spec_rules) }++combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]+-- Top-level bindings can include coercion bindings, but not via superclasses+-- See Note [Top-level evidence]+combineEvBinds [] val_prs+  = [Rec val_prs]+combineEvBinds (NonRec b r : bs) val_prs+  | isId b    = combineEvBinds bs ((b,r):val_prs)+  | otherwise = NonRec b r : combineEvBinds bs val_prs+combineEvBinds (Rec prs : bs) val_prs+  = combineEvBinds bs (prs ++ val_prs)++{-+Note [Top-level evidence]+~~~~~~~~~~~~~~~~~~~~~~~~~+Top-level evidence bindings may be mutually recursive with the top-level value+bindings, so we must put those in a Rec.  But we can't put them *all* in a Rec+because the occurrence analyser doesn't teke account of type/coercion variables+when computing dependencies.++So we pull out the type/coercion variables (which are in dependency order),+and Rec the rest.+-}++deSugarExpr :: HscEnv -> LHsExpr Id -> IO (Messages, Maybe CoreExpr)++deSugarExpr hsc_env tc_expr = do {+         let dflags = hsc_dflags hsc_env++       ; showPass dflags "Desugar"++         -- Do desugaring+       ; (msgs, mb_core_expr) <- runTcInteractive hsc_env $ initDsTc $+                                 dsLExpr tc_expr++       ; case mb_core_expr of+            Nothing   -> return ()+            Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared"+                         (pprCoreExpr expr)++       ; return (msgs, mb_core_expr) }++{-+************************************************************************+*                                                                      *+*              Add rules and export flags to binders+*                                                                      *+************************************************************************+-}++addExportFlagsAndRules+    :: HscTarget -> NameSet -> NameSet -> [CoreRule]+    -> [(Id, t)] -> [(Id, t)]+addExportFlagsAndRules target exports keep_alive rules prs+  = mapFst add_one prs+  where+    add_one bndr = add_rules name (add_export name bndr)+       where+         name = idName bndr++    ---------- Rules --------+        -- See Note [Attach rules to local ids]+        -- NB: the binder might have some existing rules,+        -- arising from specialisation pragmas+    add_rules name bndr+        | Just rules <- lookupNameEnv rule_base name+        = bndr `addIdSpecialisations` rules+        | otherwise+        = bndr+    rule_base = extendRuleBaseList emptyRuleBase rules++    ---------- Export flag --------+    -- See Note [Adding export flags]+    add_export name bndr+        | dont_discard name = setIdExported bndr+        | otherwise         = bndr++    dont_discard :: Name -> Bool+    dont_discard name = is_exported name+                     || name `elemNameSet` keep_alive++        -- In interactive mode, we don't want to discard any top-level+        -- entities at all (eg. do not inline them away during+        -- simplification), and retain them all in the TypeEnv so they are+        -- available from the command line.+        --+        -- isExternalName separates the user-defined top-level names from those+        -- introduced by the type checker.+    is_exported :: Name -> Bool+    is_exported | targetRetainsAllBindings target = isExternalName+                | otherwise                       = (`elemNameSet` exports)++{-+Note [Adding export flags]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Set the no-discard flag if either+        a) the Id is exported+        b) it's mentioned in the RHS of an orphan rule+        c) it's in the keep-alive set++It means that the binding won't be discarded EVEN if the binding+ends up being trivial (v = w) -- the simplifier would usually just+substitute w for v throughout, but we don't apply the substitution to+the rules (maybe we should?), so this substitution would make the rule+bogus.++You might wonder why exported Ids aren't already marked as such;+it's just because the type checker is rather busy already and+I didn't want to pass in yet another mapping.++Note [Attach rules to local ids]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Find the rules for locally-defined Ids; then we can attach them+to the binders in the top-level bindings++Reason+  - It makes the rules easier to look up+  - It means that transformation rules and specialisations for+    locally defined Ids are handled uniformly+  - It keeps alive things that are referred to only from a rule+    (the occurrence analyser knows about rules attached to Ids)+  - It makes sure that, when we apply a rule, the free vars+    of the RHS are more likely to be in scope+  - The imported rules are carried in the in-scope set+    which is extended on each iteration by the new wave of+    local binders; any rules which aren't on the binding will+    thereby get dropped+++************************************************************************+*                                                                      *+*              Desugaring transformation rules+*                                                                      *+************************************************************************+-}++dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)+dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs))+  = putSrcSpanDs loc $+    do  { let bndrs' = [var | L _ (RuleBndr (L _ var)) <- vars]++        ; lhs' <- unsetGOptM Opt_EnableRewriteRules $+                  unsetWOptM Opt_WarnIdentities $+                  dsLExpr lhs   -- Note [Desugaring RULE left hand sides]++        ; rhs' <- dsLExpr rhs+        ; this_mod <- getModule++        ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs'++        -- Substitute the dict bindings eagerly,+        -- and take the body apart into a (f args) form+        ; case decomposeRuleLhs bndrs'' lhs'' of {+                Left msg -> do { warnDs NoReason msg; return Nothing } ;+                Right (final_bndrs, fn_id, args) -> do++        { let is_local = isLocalId fn_id+                -- NB: isLocalId is False of implicit Ids.  This is good because+                -- we don't want to attach rules to the bindings of implicit Ids,+                -- because they don't show up in the bindings until just before code gen+              fn_name   = idName fn_id+              final_rhs = simpleOptExpr rhs''    -- De-crap it+              rule_name = snd (unLoc name)+              final_bndrs_set = mkVarSet final_bndrs+              arg_ids = filterOut (`elemVarSet` final_bndrs_set) $+                        exprsSomeFreeVarsList isId args++        ; dflags <- getDynFlags+        ; rule <- dsMkUserRule this_mod is_local+                         rule_name rule_act fn_name final_bndrs args+                         final_rhs+        ; when (wopt Opt_WarnInlineRuleShadowing dflags) $+          warnRuleShadowing rule_name rule_act fn_id arg_ids++        ; return (Just rule)+        } } }+++warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()+-- See Note [Rules and inlining/other rules]+warnRuleShadowing rule_name rule_act fn_id arg_ids+  = do { check False fn_id    -- We often have multiple rules for the same Id in a+                              -- module. Maybe we should check that they don't overlap+                              -- but currently we don't+       ; mapM_ (check True) arg_ids }+  where+    check check_rules_too lhs_id+      | isLocalId lhs_id || canUnfold (idUnfolding lhs_id)+                       -- If imported with no unfolding, no worries+      , idInlineActivation lhs_id `competesWith` rule_act+      = warnDs (Reason Opt_WarnInlineRuleShadowing)+               (vcat [ hang (text "Rule" <+> pprRuleName rule_name+                               <+> text "may never fire")+                            2 (text "because" <+> quotes (ppr lhs_id)+                               <+> text "might inline first")+                     , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for"+                       <+> quotes (ppr lhs_id)+                     , ifPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ])++      | check_rules_too+      , bad_rule : _ <- get_bad_rules lhs_id+      = warnDs (Reason Opt_WarnInlineRuleShadowing)+               (vcat [ hang (text "Rule" <+> pprRuleName rule_name+                               <+> text "may never fire")+                            2 (text "because rule" <+> pprRuleName (ruleName bad_rule)+                               <+> text "for"<+> quotes (ppr lhs_id)+                               <+> text "might fire first")+                      , text "Probable fix: add phase [n] or [~n] to the competing rule"+                      , ifPprDebug (ppr bad_rule) ])++      | otherwise+      = return ()++    get_bad_rules lhs_id+      = [ rule | rule <- idCoreRules lhs_id+               , ruleActivation rule `competesWith` rule_act ]++-- See Note [Desugaring coerce as cast]+unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr)+unfold_coerce bndrs lhs rhs = do+    (bndrs', wrap) <- go bndrs+    return (bndrs', wrap lhs, wrap rhs)+  where+    go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr)+    go []     = return ([], id)+    go (v:vs)+        | Just (tc, [k, t1, t2]) <- splitTyConApp_maybe (idType v)+        , tc `hasKey` coercibleTyConKey = do+            u <- newUnique++            let ty' = mkTyConApp eqReprPrimTyCon [k, k, t1, t2]+                v'  = mkLocalCoVar+                        (mkDerivedInternalName mkRepEqOcc u (getName v)) ty'+                box = Var (dataConWrapId coercibleDataCon) `mkTyApps`+                      [k, t1, t2] `App`+                      Coercion (mkCoVarCo v')++            (bndrs, wrap) <- go vs+            return (v':bndrs, mkCoreLet (NonRec v box) . wrap)+        | otherwise = do+            (bndrs,wrap) <- go vs+            return (v:bndrs, wrap)++{- Note [Desugaring RULE left hand sides]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For the LHS of a RULE we do *not* want to desugar+    [x]   to    build (\cn. x `c` n)+We want to leave explicit lists simply as chains+of cons's. We can achieve that slightly indirectly by+switching off EnableRewriteRules.  See DsExpr.dsExplicitList.++That keeps the desugaring of list comprehensions simple too.++Nor do we want to warn of conversion identities on the LHS;+the rule is precisly to optimise them:+  {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}++Note [Desugaring coerce as cast]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want the user to express a rule saying roughly “mapping a coercion over a+list can be replaced by a coercion”. But the cast operator of Core (▷) cannot+be written in Haskell. So we use `coerce` for that (#2110). The user writes+    map coerce = coerce+as a RULE, and this optimizes any kind of mapped' casts away, including `map+MkNewtype`.++For that we replace any forall'ed `c :: Coercible a b` value in a RULE by+corresponding `co :: a ~#R b` and wrap the LHS and the RHS in+`let c = MkCoercible co in ...`. This is later simplified to the desired form+by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).+See also Note [Getting the map/coerce RULE to work] in CoreSubst.++Note [Rules and inlining/other rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If you have+  f x = ...+  g x = ...+  {-# RULES "rule-for-f" forall x. f (g x) = ... #-}+then there's a good chance that in a potential rule redex+    ...f (g e)...+then 'f' or 'g' will inline befor the rule can fire.  Solution: add an+INLINE [n] or NOINLINE [n] pragma to 'f' and 'g'.++Note that this applies to all the free variables on the LHS, both the+main function and things in its arguments.++We also check if there are Ids on the LHS that have competing RULES.+In the above example, suppose we had+  {-# RULES "rule-for-g" forally. g [y] = ... #-}+Then "rule-for-f" and "rule-for-g" would compete.  Better to add phase+control, so "rule-for-f" has a chance to fire before "rule-for-g" becomes+active; or perhpas after "rule-for-g" has become inactive. This is checked+by 'competesWith'++Class methods have a built-in RULE to select the method from the dictionary,+so you can't change the phase on this.  That makes id very dubious to+match on class methods in RULE lhs's.   See Trac #10595.   I'm not happy+about this. For example in Control.Arrow we have++{-# RULES "compose/arr"   forall f g .+                          (arr f) . (arr g) = arr (f . g) #-}++and similar, which will elicit exactly these warnings, and risk never+firing.  But it's not clear what to do instead.  We could make the+class methocd rules inactive in phase 2, but that would delay when+subsequent transformations could fire.+++************************************************************************+*                                                                      *+*              Desugaring vectorisation declarations+*                                                                      *+************************************************************************+-}++dsVect :: LVectDecl Id -> DsM CoreVect+dsVect (L loc (HsVect _ (L _ v) rhs))+  = putSrcSpanDs loc $+    do { rhs' <- dsLExpr rhs+       ; return $ Vect v rhs'+       }+dsVect (L _loc (HsNoVect _ (L _ v)))+  = return $ NoVect v+dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))+  = return $ VectType isScalar tycon' rhs_tycon+  where+    tycon' | Just ty <- coreView $ mkTyConTy tycon+           , (tycon', []) <- splitTyConApp ty      = tycon'+           | otherwise                             = tycon+dsVect vd@(L _ (HsVectTypeIn _ _ _ _))+  = pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd)+dsVect (L _loc (HsVectClassOut cls))+  = return $ VectClass (classTyCon cls)+dsVect vc@(L _ (HsVectClassIn _ _))+  = pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc)+dsVect (L _loc (HsVectInstOut inst))+  = return $ VectInst (instanceDFunId inst)+dsVect vi@(L _ (HsVectInstIn _))+  = pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi)
+ deSugar/DsArrows.hs view
@@ -0,0 +1,1230 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Desugaring arrow commands+-}++{-# LANGUAGE CPP #-}++module DsArrows ( dsProcExpr ) where++#include "HsVersions.h"++import Match+import DsUtils+import DsMonad++import HsSyn    hiding (collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectLStmtBinders, collectStmtBinders )+import TcHsSyn+import qualified HsUtils++-- NB: The desugarer, which straddles the source and Core worlds, sometimes+--     needs to see source types (newtypes etc), and sometimes not+--     So WATCH OUT; check each use of split*Ty functions.+-- Sigh.  This is a pain.++import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )++import TcType+import Type ( splitPiTy )+import TcEvidence+import CoreSyn+import CoreFVs+import CoreUtils+import MkCore+import DsBinds (dsHsWrapper)++import Name+import Var+import Id+import ConLike+import TysWiredIn+import BasicTypes+import PrelNames+import Outputable+import Bag+import VarSet+import SrcLoc+import ListSetOps( assocMaybe )+import Data.List+import Util+import UniqDFM+import UniqSet++data DsCmdEnv = DsCmdEnv {+        arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr+    }++mkCmdEnv :: CmdSyntaxTable Id -> DsM ([CoreBind], DsCmdEnv)+-- See Note [CmdSyntaxTable] in HsExpr+mkCmdEnv tc_meths+  = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths++       -- NB: Some of these lookups might fail, but that's OK if the+       -- symbol is never used. That's why we use Maybe first and then+       -- panic. An eager panic caused trouble in typecheck/should_compile/tc192+       ; let the_arr_id     = assocMaybe prs arrAName+             the_compose_id = assocMaybe prs composeAName+             the_first_id   = assocMaybe prs firstAName+             the_app_id     = assocMaybe prs appAName+             the_choice_id  = assocMaybe prs choiceAName+             the_loop_id    = assocMaybe prs loopAName++           -- used as an argument in, e.g., do_premap+       ; check_lev_poly 3 the_arr_id++           -- used as an argument in, e.g., dsCmdStmt/BodyStmt+       ; check_lev_poly 5 the_compose_id++           -- used as an argument in, e.g., dsCmdStmt/BodyStmt+       ; check_lev_poly 4 the_first_id++           -- the result of the_app_id is used as an argument in, e.g.,+           -- dsCmd/HsCmdArrApp/HsHigherOrderApp+       ; check_lev_poly 2 the_app_id++           -- used as an argument in, e.g., HsCmdIf+       ; check_lev_poly 5 the_choice_id++           -- used as an argument in, e.g., RecStmt+       ; check_lev_poly 4 the_loop_id++       ; return (meth_binds, DsCmdEnv {+               arr_id     = Var (unmaybe the_arr_id arrAName),+               compose_id = Var (unmaybe the_compose_id composeAName),+               first_id   = Var (unmaybe the_first_id firstAName),+               app_id     = Var (unmaybe the_app_id appAName),+               choice_id  = Var (unmaybe the_choice_id choiceAName),+               loop_id    = Var (unmaybe the_loop_id loopAName)+             }) }+  where+    mk_bind (std_name, expr)+      = do { rhs <- dsExpr expr+           ; id <- newSysLocalDs (exprType rhs)  -- no check needed; these are functions+           ; return (NonRec id rhs, (std_name, id)) }++    unmaybe Nothing name = pprPanic "mkCmdEnv" (text "Not found:" <+> ppr name)+    unmaybe (Just id) _  = id++      -- returns the result type of a pi-type (that is, a forall or a function)+      -- Note that this result type may be ill-scoped.+    res_type :: Type -> Type+    res_type ty = res_ty+      where+        (_, res_ty) = splitPiTy ty++    check_lev_poly :: Int -- arity+                   -> Maybe Id -> DsM ()+    check_lev_poly _     Nothing = return ()+    check_lev_poly arity (Just id)+      = dsNoLevPoly (nTimes arity res_type (idType id))+          (text "In the result of the function" <+> quotes (ppr id))+++-- arr :: forall b c. (b -> c) -> a b c+do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr+do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f]++-- (>>>) :: forall b c d. a b c -> a c d -> a b d+do_compose :: DsCmdEnv -> Type -> Type -> Type ->+                CoreExpr -> CoreExpr -> CoreExpr+do_compose ids b_ty c_ty d_ty f g+  = mkApps (compose_id ids) [Type b_ty, Type c_ty, Type d_ty, f, g]++-- first :: forall b c d. a b c -> a (b,d) (c,d)+do_first :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr+do_first ids b_ty c_ty d_ty f+  = mkApps (first_id ids) [Type b_ty, Type c_ty, Type d_ty, f]++-- app :: forall b c. a (a b c, b) c+do_app :: DsCmdEnv -> Type -> Type -> CoreExpr+do_app ids b_ty c_ty = mkApps (app_id ids) [Type b_ty, Type c_ty]++-- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d+-- note the swapping of d and c+do_choice :: DsCmdEnv -> Type -> Type -> Type ->+                CoreExpr -> CoreExpr -> CoreExpr+do_choice ids b_ty c_ty d_ty f g+  = mkApps (choice_id ids) [Type b_ty, Type d_ty, Type c_ty, f, g]++-- loop :: forall b d c. a (b,d) (c,d) -> a b c+-- note the swapping of d and c+do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr+do_loop ids b_ty c_ty d_ty f+  = mkApps (loop_id ids) [Type b_ty, Type d_ty, Type c_ty, f]++-- premap :: forall b c d. (b -> c) -> a c d -> a b d+-- premap f g = arr f >>> g+do_premap :: DsCmdEnv -> Type -> Type -> Type ->+                CoreExpr -> CoreExpr -> CoreExpr+do_premap ids b_ty c_ty d_ty f g+   = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) g++mkFailExpr :: HsMatchContext Id -> Type -> DsM CoreExpr+mkFailExpr ctxt ty+  = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt)++-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a+mkFstExpr :: Type -> Type -> DsM CoreExpr+mkFstExpr a_ty b_ty = do+    a_var <- newSysLocalDs a_ty+    b_var <- newSysLocalDs b_ty+    pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty)+    return (Lam pair_var+               (coreCasePair pair_var a_var b_var (Var a_var)))++-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b+mkSndExpr :: Type -> Type -> DsM CoreExpr+mkSndExpr a_ty b_ty = do+    a_var <- newSysLocalDs a_ty+    b_var <- newSysLocalDs b_ty+    pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty)+    return (Lam pair_var+               (coreCasePair pair_var a_var b_var (Var b_var)))++{-+Build case analysis of a tuple.  This cannot be done in the DsM monad,+because the list of variables is typically not yet defined.+-}++-- coreCaseTuple [u1..] v [x1..xn] body+--      = case v of v { (x1, .., xn) -> body }+-- But the matching may be nested if the tuple is very big++coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr+coreCaseTuple uniqs scrut_var vars body+  = mkTupleCase uniqs vars body scrut_var (Var scrut_var)++coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr+coreCasePair scrut_var var1 var2 body+  = Case (Var scrut_var) scrut_var (exprType body)+         [(DataAlt (tupleDataCon Boxed 2), [var1, var2], body)]++mkCorePairTy :: Type -> Type -> Type+mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2]++mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr+mkCorePairExpr e1 e2 = mkCoreTup [e1, e2]++mkCoreUnitExpr :: CoreExpr+mkCoreUnitExpr = mkCoreTup []++{-+The input is divided into a local environment, which is a flat tuple+(unless it's too big), and a stack, which is a right-nested pair.+In general, the input has the form++        ((x1,...,xn), (s1,...(sk,())...))++where xi are the environment values, and si the ones on the stack,+with s1 being the "top", the first one to be matched with a lambda.+-}++envStackType :: [Id] -> Type -> Type+envStackType ids stack_ty = mkCorePairTy (mkBigCoreVarTupTy ids) stack_ty++-- splitTypeAt n (t1,... (tn,t)...) = ([t1, ..., tn], t)+splitTypeAt :: Int -> Type -> ([Type], Type)+splitTypeAt n ty+  | n == 0 = ([], ty)+  | otherwise = case tcTyConAppArgs ty of+      [t, ty'] -> let (ts, ty_r) = splitTypeAt (n-1) ty' in (t:ts, ty_r)+      _ -> pprPanic "splitTypeAt" (ppr ty)++----------------------------------------------+--              buildEnvStack+--+--      ((x1,...,xn),stk)++buildEnvStack :: [Id] -> Id -> CoreExpr+buildEnvStack env_ids stack_id+  = mkCorePairExpr (mkBigCoreVarTup env_ids) (Var stack_id)++----------------------------------------------+--              matchEnvStack+--+--      \ ((x1,...,xn),stk) -> body+--      =>+--      \ pair ->+--      case pair of (tup,stk) ->+--      case tup of (x1,...,xn) ->+--      body++matchEnvStack   :: [Id]         -- x1..xn+                -> Id           -- stk+                -> CoreExpr     -- e+                -> DsM CoreExpr+matchEnvStack env_ids stack_id body = do+    uniqs <- newUniqueSupply+    tup_var <- newSysLocalDs (mkBigCoreVarTupTy env_ids)+    let match_env = coreCaseTuple uniqs tup_var env_ids body+    pair_id <- newSysLocalDs (mkCorePairTy (idType tup_var) (idType stack_id))+    return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env))++----------------------------------------------+--              matchEnv+--+--      \ (x1,...,xn) -> body+--      =>+--      \ tup ->+--      case tup of (x1,...,xn) ->+--      body++matchEnv :: [Id]        -- x1..xn+         -> CoreExpr    -- e+         -> DsM CoreExpr+matchEnv env_ids body = do+    uniqs <- newUniqueSupply+    tup_id <- newSysLocalDs (mkBigCoreVarTupTy env_ids)+    return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body))++----------------------------------------------+--              matchVarStack+--+--      case (x1, ...(xn, s)...) -> e+--      =>+--      case z0 of (x1,z1) ->+--      case zn-1 of (xn,s) ->+--      e+matchVarStack :: [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr)+matchVarStack [] stack_id body = return (stack_id, body)+matchVarStack (param_id:param_ids) stack_id body = do+    (tail_id, tail_code) <- matchVarStack param_ids stack_id body+    pair_id <- newSysLocalDs (mkCorePairTy (idType param_id) (idType tail_id))+    return (pair_id, coreCasePair pair_id param_id tail_id tail_code)++mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr Id+mkHsEnvStackExpr env_ids stack_id+  = mkLHsTupleExpr [mkLHsVarTuple env_ids, nlHsVar stack_id]++-- Translation of arrow abstraction++-- D; xs |-a c : () --> t'      ---> c'+-- --------------------------+-- D |- proc p -> c :: a t t'   ---> premap (\ p -> ((xs),())) c'+--+--              where (xs) is the tuple of variables bound by p++dsProcExpr+        :: LPat Id+        -> LHsCmdTop Id+        -> DsM CoreExpr+dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do+    (meth_binds, meth_ids) <- mkCmdEnv ids+    let locals = mkVarSet (collectPatBinders pat)+    (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals unitTy cmd_ty cmd+    let env_ty = mkBigCoreVarTupTy env_ids+    let env_stk_ty = mkCorePairTy env_ty unitTy+    let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr+    fail_expr <- mkFailExpr ProcExpr env_stk_ty+    var <- selectSimpleMatchVarL pat+    match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr+    let pat_ty = hsLPatType pat+    let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty+                    (Lam var match_code)+                    core_cmd+    return (mkLets meth_binds proc_code)++{-+Translation of a command judgement of the form++        D; xs |-a c : stk --> t++to an expression e such that++        D |- e :: a (xs, stk) t+-}++dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd Id -> [Id]+       -> DsM (CoreExpr, DIdSet)+dsLCmd ids local_vars stk_ty res_ty cmd env_ids+  = dsCmd ids local_vars stk_ty res_ty (unLoc cmd) env_ids++dsCmd   :: DsCmdEnv             -- arrow combinators+        -> IdSet                -- set of local vars available to this command+        -> Type                 -- type of the stack (right-nested tuple)+        -> Type                 -- return type of the command+        -> HsCmd Id             -- command to desugar+        -> [Id]                 -- list of vars in the input to this command+                                -- This is typically fed back,+                                -- so don't pull on it too early+        -> DsM (CoreExpr,       -- desugared expression+                DIdSet)         -- subset of local vars that occur free++-- D |- fun :: a t1 t2+-- D, xs |- arg :: t1+-- -----------------------------+-- D; xs |-a fun -< arg : stk --> t2+--+--              ---> premap (\ ((xs), _stk) -> arg) fun++dsCmd ids local_vars stack_ty res_ty+        (HsCmdArrApp arrow arg arrow_ty HsFirstOrderApp _)+        env_ids = do+    let+        (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty+        (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty+    core_arrow <- dsLExprNoLP arrow+    core_arg   <- dsLExpr arg+    stack_id   <- newSysLocalDs stack_ty+    core_make_arg <- matchEnvStack env_ids stack_id core_arg+    return (do_premap ids+              (envStackType env_ids stack_ty)+              arg_ty+              res_ty+              core_make_arg+              core_arrow,+            exprFreeIdsDSet core_arg `udfmIntersectUFM` (getUniqSet local_vars))++-- D, xs |- fun :: a t1 t2+-- D, xs |- arg :: t1+-- ------------------------------+-- D; xs |-a fun -<< arg : stk --> t2+--+--              ---> premap (\ ((xs), _stk) -> (fun, arg)) app++dsCmd ids local_vars stack_ty res_ty+        (HsCmdArrApp arrow arg arrow_ty HsHigherOrderApp _)+        env_ids = do+    let+        (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty+        (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty++    core_arrow <- dsLExpr arrow+    core_arg   <- dsLExpr arg+    stack_id   <- newSysLocalDs stack_ty+    core_make_pair <- matchEnvStack env_ids stack_id+          (mkCorePairExpr core_arrow core_arg)++    return (do_premap ids+              (envStackType env_ids stack_ty)+              (mkCorePairTy arrow_ty arg_ty)+              res_ty+              core_make_pair+              (do_app ids arg_ty res_ty),+            (exprsFreeIdsDSet [core_arrow, core_arg])+              `udfmIntersectUFM` getUniqSet local_vars)++-- D; ys |-a cmd : (t,stk) --> t'+-- D, xs |-  exp :: t+-- ------------------------+-- D; xs |-a cmd exp : stk --> t'+--+--              ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd++dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do+    core_arg <- dsLExpr arg+    let+        arg_ty = exprType core_arg+        stack_ty' = mkCorePairTy arg_ty stack_ty+    (core_cmd, free_vars, env_ids')+             <- dsfixCmd ids local_vars stack_ty' res_ty cmd+    stack_id <- newSysLocalDs stack_ty+    arg_id <- newSysLocalDsNoLP arg_ty+    -- push the argument expression onto the stack+    let+        stack' = mkCorePairExpr (Var arg_id) (Var stack_id)+        core_body = bindNonRec arg_id core_arg+                        (mkCorePairExpr (mkBigCoreVarTup env_ids') stack')++    -- match the environment and stack against the input+    core_map <- matchEnvStack env_ids stack_id core_body+    return (do_premap ids+                      (envStackType env_ids stack_ty)+                      (envStackType env_ids' stack_ty')+                      res_ty+                      core_map+                      core_cmd,+            free_vars `unionDVarSet`+              (exprFreeIdsDSet core_arg `udfmIntersectUFM` getUniqSet local_vars))++-- D; ys |-a cmd : stk t'+-- -----------------------------------------------+-- D; xs |-a \ p1 ... pk -> cmd : (t1,...(tk,stk)...) t'+--+--              ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd++dsCmd ids local_vars stack_ty res_ty+        (HsCmdLam (MG { mg_alts = L _ [L _ (Match _ pats _+                                           (GRHSs [L _ (GRHS [] body)] _ ))] }))+        env_ids = do+    let pat_vars = mkVarSet (collectPatsBinders pats)+    let+        local_vars' = pat_vars `unionVarSet` local_vars+        (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty+    (core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty' res_ty body+    param_ids <- mapM newSysLocalDsNoLP pat_tys+    stack_id' <- newSysLocalDs stack_ty'++    -- the expression is built from the inside out, so the actions+    -- are presented in reverse order++    let+        -- build a new environment, plus what's left of the stack+        core_expr = buildEnvStack env_ids' stack_id'+        in_ty = envStackType env_ids stack_ty+        in_ty' = envStackType env_ids' stack_ty'++    fail_expr <- mkFailExpr LambdaExpr in_ty'+    -- match the patterns against the parameters+    match_code <- matchSimplys (map Var param_ids) LambdaExpr pats core_expr fail_expr+    -- match the parameters against the top of the old stack+    (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code+    -- match the old environment and stack against the input+    select_code <- matchEnvStack env_ids stack_id param_code+    return (do_premap ids in_ty in_ty' res_ty select_code core_body,+            free_vars `udfmMinusUFM` getUniqSet pat_vars)++dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids+  = dsLCmd ids local_vars stack_ty res_ty cmd env_ids++-- D, xs |- e :: Bool+-- D; xs1 |-a c1 : stk --> t+-- D; xs2 |-a c2 : stk --> t+-- ----------------------------------------+-- D; xs |-a if e then c1 else c2 : stk --> t+--+--              ---> premap (\ ((xs),stk) ->+--                       if e then Left ((xs1),stk) else Right ((xs2),stk))+--                     (c1 ||| c2)++dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd)+        env_ids = do+    core_cond <- dsLExpr cond+    (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack_ty res_ty then_cmd+    (core_else, fvs_else, else_ids) <- dsfixCmd ids local_vars stack_ty res_ty else_cmd+    stack_id   <- newSysLocalDs stack_ty+    either_con <- dsLookupTyCon eitherTyConName+    left_con   <- dsLookupDataCon leftDataConName+    right_con  <- dsLookupDataCon rightDataConName++    let mk_left_expr ty1 ty2 e = mkCoreConApps left_con   [Type ty1, Type ty2, e]+        mk_right_expr ty1 ty2 e = mkCoreConApps right_con [Type ty1, Type ty2, e]++        in_ty = envStackType env_ids stack_ty+        then_ty = envStackType then_ids stack_ty+        else_ty = envStackType else_ids stack_ty+        sum_ty = mkTyConApp either_con [then_ty, else_ty]+        fvs_cond = exprFreeIdsDSet core_cond `udfmIntersectUFM` getUniqSet local_vars++        core_left  = mk_left_expr  then_ty else_ty (buildEnvStack then_ids stack_id)+        core_right = mk_right_expr then_ty else_ty (buildEnvStack else_ids stack_id)++    core_if <- case mb_fun of+       Just fun -> do { fun_apps <- dsSyntaxExpr fun [core_cond, core_left, core_right]+                      ; matchEnvStack env_ids stack_id fun_apps }+       Nothing  -> matchEnvStack env_ids stack_id $+                   mkIfThenElse core_cond core_left core_right++    return (do_premap ids in_ty sum_ty res_ty+                core_if+                (do_choice ids then_ty else_ty res_ty core_then core_else),+        fvs_cond `unionDVarSet` fvs_then `unionDVarSet` fvs_else)++{-+Case commands are treated in much the same way as if commands+(see above) except that there are more alternatives.  For example++        case e of { p1 -> c1; p2 -> c2; p3 -> c3 }++is translated to++        premap (\ ((xs)*ts) -> case e of+                p1 -> (Left (Left (xs1)*ts))+                p2 -> Left ((Right (xs2)*ts))+                p3 -> Right ((xs3)*ts))+        ((c1 ||| c2) ||| c3)++The idea is to extract the commands from the case, build a balanced tree+of choices, and replace the commands with expressions that build tagged+tuples, obtaining a case expression that can be desugared normally.+To build all this, we use triples describing segments of the list of+case bodies, containing the following fields:+ * a list of expressions of the form (Left|Right)* ((xs)*ts), to be put+   into the case replacing the commands+ * a sum type that is the common type of these expressions, and also the+   input type of the arrow+ * a CoreExpr for an arrow built by combining the translated command+   bodies with |||.+-}++dsCmd ids local_vars stack_ty res_ty+      (HsCmdCase exp (MG { mg_alts = L l matches, mg_arg_tys = arg_tys+                         , mg_origin = origin }))+      env_ids = do+    stack_id <- newSysLocalDs stack_ty++    -- Extract and desugar the leaf commands in the case, building tuple+    -- expressions that will (after tagging) replace these leaves++    let+        leaves = concatMap leavesMatch matches+        make_branch (leaf, bound_vars) = do+            (core_leaf, _fvs, leaf_ids) <-+                  dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty res_ty leaf+            return ([mkHsEnvStackExpr leaf_ids stack_id],+                    envStackType leaf_ids stack_ty,+                    core_leaf)++    branches <- mapM make_branch leaves+    either_con <- dsLookupTyCon eitherTyConName+    left_con <- dsLookupDataCon leftDataConName+    right_con <- dsLookupDataCon rightDataConName+    let+        left_id  = HsConLikeOut (RealDataCon left_con)+        right_id = HsConLikeOut (RealDataCon right_con)+        left_expr  ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) left_id ) e+        right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) right_id) e++        -- Prefix each tuple with a distinct series of Left's and Right's,+        -- in a balanced way, keeping track of the types.++        merge_branches (builds1, in_ty1, core_exp1)+                       (builds2, in_ty2, core_exp2)+          = (map (left_expr in_ty1 in_ty2) builds1 +++                map (right_expr in_ty1 in_ty2) builds2,+             mkTyConApp either_con [in_ty1, in_ty2],+             do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)+        (leaves', sum_ty, core_choices) = foldb merge_branches branches++        -- Replace the commands in the case with these tagged tuples,+        -- yielding a HsExpr Id we can feed to dsExpr.++        (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches+        in_ty = envStackType env_ids stack_ty++    core_body <- dsExpr (HsCase exp (MG { mg_alts = L l matches'+                                        , mg_arg_tys = arg_tys+                                        , mg_res_ty = sum_ty, mg_origin = origin }))+        -- Note that we replace the HsCase result type by sum_ty,+        -- which is the type of matches'++    core_matches <- matchEnvStack env_ids stack_id core_body+    return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,+            exprFreeIdsDSet core_body `udfmIntersectUFM` getUniqSet local_vars)++-- D; ys |-a cmd : stk --> t+-- ----------------------------------+-- D; xs |-a let binds in cmd : stk --> t+--+--              ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c++dsCmd ids local_vars stack_ty res_ty (HsCmdLet lbinds@(L _ binds) body) env_ids = do+    let+        defined_vars = mkVarSet (collectLocalBinders binds)+        local_vars' = defined_vars `unionVarSet` local_vars++    (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty res_ty body+    stack_id <- newSysLocalDs stack_ty+    -- build a new environment, plus the stack, using the let bindings+    core_binds <- dsLocalBinds lbinds (buildEnvStack env_ids' stack_id)+    -- match the old environment and stack against the input+    core_map <- matchEnvStack env_ids stack_id core_binds+    return (do_premap ids+                        (envStackType env_ids stack_ty)+                        (envStackType env_ids' stack_ty)+                        res_ty+                        core_map+                        core_body,+        exprFreeIdsDSet core_binds `udfmIntersectUFM` getUniqSet local_vars)++-- D; xs |-a ss : t+-- ----------------------------------+-- D; xs |-a do { ss } : () --> t+--+--              ---> premap (\ (env,stk) -> env) c++dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo (L loc stmts) stmts_ty) env_ids = do+    putSrcSpanDs loc $+      dsNoLevPoly stmts_ty+        (text "In the do-command:" <+> ppr do_block)+    (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids+    let env_ty = mkBigCoreVarTupTy env_ids+    core_fst <- mkFstExpr env_ty stack_ty+    return (do_premap ids+                (mkCorePairTy env_ty stack_ty)+                env_ty+                res_ty+                core_fst+                core_stmts,+        env_ids')++-- D |- e :: forall e. a1 (e,stk1) t1 -> ... an (e,stkn) tn -> a (e,stk) t+-- D; xs |-a ci :: stki --> ti+-- -----------------------------------+-- D; xs |-a (|e c1 ... cn|) :: stk --> t       ---> e [t_xs] c1 ... cn++dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ _ args) env_ids = do+    let env_ty = mkBigCoreVarTupTy env_ids+    core_op <- dsLExpr op+    (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args+    return (mkApps (App core_op (Type env_ty)) core_args,+            unionDVarSets fv_sets)++dsCmd ids local_vars stack_ty res_ty (HsCmdWrap wrap cmd) env_ids = do+    (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids+    core_wrap <- dsHsWrapper wrap+    return (core_wrap core_cmd, env_ids')++dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)++-- D; ys |-a c : stk --> t      (ys <= xs)+-- ---------------------+-- D; xs |-a c : stk --> t      ---> premap (\ ((xs),stk) -> ((ys),stk)) c++dsTrimCmdArg+        :: IdSet                -- set of local vars available to this command+        -> [Id]                 -- list of vars in the input to this command+        -> LHsCmdTop Id         -- command argument to desugar+        -> DsM (CoreExpr,       -- desugared expression+                DIdSet)         -- subset of local vars that occur free+dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do+    (meth_binds, meth_ids) <- mkCmdEnv ids+    (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd+    stack_id <- newSysLocalDs stack_ty+    trim_code <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id)+    let+        in_ty = envStackType env_ids stack_ty+        in_ty' = envStackType env_ids' stack_ty+        arg_code = if env_ids' == env_ids then core_cmd else+                do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd+    return (mkLets meth_binds arg_code, free_vars)++-- Given D; xs |-a c : stk --> t, builds c with xs fed back.+-- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk))++dsfixCmd+        :: DsCmdEnv             -- arrow combinators+        -> IdSet                -- set of local vars available to this command+        -> Type                 -- type of the stack (right-nested tuple)+        -> Type                 -- return type of the command+        -> LHsCmd Id            -- command to desugar+        -> DsM (CoreExpr,       -- desugared expression+                DIdSet,         -- subset of local vars that occur free+                [Id])           -- the same local vars as a list, fed back+dsfixCmd ids local_vars stk_ty cmd_ty cmd+  = do { putSrcSpanDs (getLoc cmd) $ dsNoLevPoly cmd_ty+           (text "When desugaring the command:" <+> ppr cmd)+       ; trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) }++-- Feed back the list of local variables actually used a command,+-- for use as the input tuple of the generated arrow.++trimInput+        :: ([Id] -> DsM (CoreExpr, DIdSet))+        -> DsM (CoreExpr,       -- desugared expression+                DIdSet,         -- subset of local vars that occur free+                [Id])           -- same local vars as a list, fed back to+                                -- the inner function to form the tuple of+                                -- inputs to the arrow.+trimInput build_arrow+  = fixDs (\ ~(_,_,env_ids) -> do+        (core_cmd, free_vars) <- build_arrow env_ids+        return (core_cmd, free_vars, dVarSetElems free_vars))++{-+Translation of command judgements of the form++        D |-a do { ss } : t+-}++dsCmdDo :: DsCmdEnv             -- arrow combinators+        -> IdSet                -- set of local vars available to this statement+        -> Type                 -- return type of the statement+        -> [CmdLStmt Id]        -- statements to desugar+        -> [Id]                 -- list of vars in the input to this statement+                                -- This is typically fed back,+                                -- so don't pull on it too early+        -> DsM (CoreExpr,       -- desugared expression+                DIdSet)         -- subset of local vars that occur free++dsCmdDo _ _ _ [] _ = panic "dsCmdDo"++-- D; xs |-a c : () --> t+-- --------------------------+-- D; xs |-a do { c } : t+--+--              ---> premap (\ (xs) -> ((xs), ())) c++dsCmdDo ids local_vars res_ty [L loc (LastStmt body _ _)] env_ids = do+    putSrcSpanDs loc $ dsNoLevPoly res_ty+                         (text "In the command:" <+> ppr body)+    (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids+    let env_ty = mkBigCoreVarTupTy env_ids+    env_var <- newSysLocalDs env_ty+    let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr)+    return (do_premap ids+                        env_ty+                        (mkCorePairTy env_ty unitTy)+                        res_ty+                        core_map+                        core_body,+        env_ids')++dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do+    let bound_vars  = mkVarSet (collectLStmtBinders stmt)+    let local_vars' = bound_vars `unionVarSet` local_vars+    (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts)+    (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids+    return (do_compose ids+                (mkBigCoreVarTupTy env_ids)+                (mkBigCoreVarTupTy env_ids')+                res_ty+                core_stmt+                core_stmts,+              fv_stmt)++{-+A statement maps one local environment to another, and is represented+as an arrow from one tuple type to another.  A statement sequence is+translated to a composition of such arrows.+-}++dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt Id -> [Id]+           -> DsM (CoreExpr, DIdSet)+dsCmdLStmt ids local_vars out_ids cmd env_ids+  = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids++dsCmdStmt+        :: DsCmdEnv             -- arrow combinators+        -> IdSet                -- set of local vars available to this statement+        -> [Id]                 -- list of vars in the output of this statement+        -> CmdStmt Id           -- statement to desugar+        -> [Id]                 -- list of vars in the input to this statement+                                -- This is typically fed back,+                                -- so don't pull on it too early+        -> DsM (CoreExpr,       -- desugared expression+                DIdSet)         -- subset of local vars that occur free++-- D; xs1 |-a c : () --> t+-- D; xs' |-a do { ss } : t'+-- ------------------------------+-- D; xs  |-a do { c; ss } : t'+--+--              ---> premap (\ ((xs)) -> (((xs1),()),(xs')))+--                      (first c >>> arr snd) >>> ss++dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do+    (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd+    core_mux <- matchEnv env_ids+        (mkCorePairExpr+            (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)+            (mkBigCoreVarTup out_ids))+    let+        in_ty = mkBigCoreVarTupTy env_ids+        in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy+        out_ty = mkBigCoreVarTupTy out_ids+        before_c_ty = mkCorePairTy in_ty1 out_ty+        after_c_ty = mkCorePairTy c_ty out_ty+    dsNoLevPoly c_ty empty -- I (Richard E, Dec '16) have no idea what to say here+    snd_fn <- mkSndExpr c_ty out_ty+    return (do_premap ids in_ty before_c_ty out_ty core_mux $+                do_compose ids before_c_ty after_c_ty out_ty+                        (do_first ids in_ty1 c_ty out_ty core_cmd) $+                do_arr ids after_c_ty out_ty snd_fn,+              extendDVarSetList fv_cmd out_ids)++-- D; xs1 |-a c : () --> t+-- D; xs' |-a do { ss } : t'            xs2 = xs' - defs(p)+-- -----------------------------------+-- D; xs  |-a do { p <- c; ss } : t'+--+--              ---> premap (\ (xs) -> (((xs1),()),(xs2)))+--                      (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss+--+-- It would be simpler and more consistent to do this using second,+-- but that's likely to be defined in terms of first.++dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _ _) env_ids = do+    let pat_ty = hsLPatType pat+    (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd+    let pat_vars = mkVarSet (collectPatBinders pat)+    let+        env_ids2 = filterOut (`elemVarSet` pat_vars) out_ids+        env_ty2 = mkBigCoreVarTupTy env_ids2++    -- multiplexing function+    --          \ (xs) -> (((xs1),()),(xs2))++    core_mux <- matchEnv env_ids+        (mkCorePairExpr+            (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)+            (mkBigCoreVarTup env_ids2))++    -- projection function+    --          \ (p, (xs2)) -> (zs)++    env_id <- newSysLocalDs env_ty2+    uniqs <- newUniqueSupply+    let+        after_c_ty = mkCorePairTy pat_ty env_ty2+        out_ty = mkBigCoreVarTupTy out_ids+        body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids)++    fail_expr <- mkFailExpr (StmtCtxt DoExpr) out_ty+    pat_id    <- selectSimpleMatchVarL pat+    match_code <- matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr+    pair_id   <- newSysLocalDs after_c_ty+    let+        proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)++    -- put it all together+    let+        in_ty = mkBigCoreVarTupTy env_ids+        in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy+        in_ty2 = mkBigCoreVarTupTy env_ids2+        before_c_ty = mkCorePairTy in_ty1 in_ty2+    return (do_premap ids in_ty before_c_ty out_ty core_mux $+                do_compose ids before_c_ty after_c_ty out_ty+                        (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $+                do_arr ids after_c_ty out_ty proj_expr,+              fv_cmd `unionDVarSet` (mkDVarSet out_ids `udfmMinusUFM` getUniqSet pat_vars))++-- D; xs' |-a do { ss } : t+-- --------------------------------------+-- D; xs  |-a do { let binds; ss } : t+--+--              ---> arr (\ (xs) -> let binds in (xs')) >>> ss++dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do+    -- build a new environment using the let bindings+    core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids)+    -- match the old environment against the input+    core_map <- matchEnv env_ids core_binds+    return (do_arr ids+                        (mkBigCoreVarTupTy env_ids)+                        (mkBigCoreVarTupTy out_ids)+                        core_map,+            exprFreeIdsDSet core_binds `udfmIntersectUFM` getUniqSet local_vars)++-- D; ys  |-a do { ss; returnA -< ((xs1), (ys2)) } : ...+-- D; xs' |-a do { ss' } : t+-- ------------------------------------+-- D; xs  |-a do { rec ss; ss' } : t+--+--                      xs1 = xs' /\ defs(ss)+--                      xs2 = xs' - defs(ss)+--                      ys1 = ys - defs(ss)+--                      ys2 = ys /\ defs(ss)+--+--              ---> arr (\(xs) -> ((ys1),(xs2))) >>>+--                      first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>+--                      arr (\((xs1),(xs2)) -> (xs')) >>> ss'++dsCmdStmt ids local_vars out_ids+        (RecStmt { recS_stmts = stmts+                 , recS_later_ids = later_ids, recS_rec_ids = rec_ids+                 , recS_later_rets = later_rets, recS_rec_rets = rec_rets })+        env_ids = do+    let+        later_ids_set = mkVarSet later_ids+        env2_ids = filterOut (`elemVarSet` later_ids_set) out_ids+        env2_id_set = mkDVarSet env2_ids+        env2_ty = mkBigCoreVarTupTy env2_ids++    -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)++    uniqs <- newUniqueSupply+    env2_id <- newSysLocalDs env2_ty+    let+        later_ty = mkBigCoreVarTupTy later_ids+        post_pair_ty = mkCorePairTy later_ty env2_ty+        post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids)++    post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body++    --- loop (...)++    (core_loop, env1_id_set, env1_ids)+               <- dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets++    -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))++    let+        env1_ty = mkBigCoreVarTupTy env1_ids+        pre_pair_ty = mkCorePairTy env1_ty env2_ty+        pre_loop_body = mkCorePairExpr (mkBigCoreVarTup env1_ids)+                                        (mkBigCoreVarTup env2_ids)++    pre_loop_fn <- matchEnv env_ids pre_loop_body++    -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn++    let+        env_ty = mkBigCoreVarTupTy env_ids+        out_ty = mkBigCoreVarTupTy out_ids+        core_body = do_premap ids env_ty pre_pair_ty out_ty+                pre_loop_fn+                (do_compose ids pre_pair_ty post_pair_ty out_ty+                        (do_first ids env1_ty later_ty env2_ty+                                core_loop)+                        (do_arr ids post_pair_ty out_ty+                                post_loop_fn))++    return (core_body, env1_id_set `unionDVarSet` env2_id_set)++dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s)++--      loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids))+--            (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>>++dsRecCmd+        :: DsCmdEnv             -- arrow combinators+        -> IdSet                -- set of local vars available to this statement+        -> [CmdLStmt Id]        -- list of statements inside the RecCmd+        -> [Id]                 -- list of vars defined here and used later+        -> [HsExpr Id]          -- expressions corresponding to later_ids+        -> [Id]                 -- list of vars fed back through the loop+        -> [HsExpr Id]          -- expressions corresponding to rec_ids+        -> DsM (CoreExpr,       -- desugared statement+                DIdSet,         -- subset of local vars that occur free+                [Id])           -- same local vars as a list++dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do+    let+        later_id_set = mkVarSet later_ids+        rec_id_set = mkVarSet rec_ids+        local_vars' = rec_id_set `unionVarSet` later_id_set `unionVarSet` local_vars++    -- mk_pair_fn = \ (out_ids) -> ((later_rets),(rec_rets))++    core_later_rets <- mapM dsExpr later_rets+    core_rec_rets <- mapM dsExpr rec_rets+    let+        -- possibly polymorphic version of vars of later_ids and rec_ids+        out_ids = exprsFreeIdsList (core_later_rets ++ core_rec_rets)+        out_ty = mkBigCoreVarTupTy out_ids++        later_tuple = mkBigCoreTup core_later_rets+        later_ty = mkBigCoreVarTupTy later_ids++        rec_tuple = mkBigCoreTup core_rec_rets+        rec_ty = mkBigCoreVarTupTy rec_ids++        out_pair = mkCorePairExpr later_tuple rec_tuple+        out_pair_ty = mkCorePairTy later_ty rec_ty++    mk_pair_fn <- matchEnv out_ids out_pair++    -- ss++    (core_stmts, fv_stmts, env_ids) <- dsfixCmdStmts ids local_vars' out_ids stmts++    -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids)++    rec_id <- newSysLocalDs rec_ty+    let+        env1_id_set = fv_stmts `udfmMinusUFM` getUniqSet rec_id_set+        env1_ids = dVarSetElems env1_id_set+        env1_ty = mkBigCoreVarTupTy env1_ids+        in_pair_ty = mkCorePairTy env1_ty rec_ty+        core_body = mkBigCoreTup (map selectVar env_ids)+          where+            selectVar v+                | v `elemVarSet` rec_id_set+                  = mkTupleSelector rec_ids v rec_id (Var rec_id)+                | otherwise = Var v++    squash_pair_fn <- matchEnvStack env1_ids rec_id core_body++    -- loop (premap squash_pair_fn (ss >>> arr mk_pair_fn))++    let+        env_ty = mkBigCoreVarTupTy env_ids+        core_loop = do_loop ids env1_ty later_ty rec_ty+                (do_premap ids in_pair_ty env_ty out_pair_ty+                        squash_pair_fn+                        (do_compose ids env_ty out_ty out_pair_ty+                                core_stmts+                                (do_arr ids out_ty out_pair_ty mk_pair_fn)))++    return (core_loop, env1_id_set, env1_ids)++{-+A sequence of statements (as in a rec) is desugared to an arrow between+two environments (no stack)+-}++dsfixCmdStmts+        :: DsCmdEnv             -- arrow combinators+        -> IdSet                -- set of local vars available to this statement+        -> [Id]                 -- output vars of these statements+        -> [CmdLStmt Id]        -- statements to desugar+        -> DsM (CoreExpr,       -- desugared expression+                DIdSet,         -- subset of local vars that occur free+                [Id])           -- same local vars as a list++dsfixCmdStmts ids local_vars out_ids stmts+  = trimInput (dsCmdStmts ids local_vars out_ids stmts)+   -- TODO: Add levity polymorphism check for the resulting expression.+   -- But I (Richard E.) don't know enough about arrows to do so.++dsCmdStmts+        :: DsCmdEnv             -- arrow combinators+        -> IdSet                -- set of local vars available to this statement+        -> [Id]                 -- output vars of these statements+        -> [CmdLStmt Id]        -- statements to desugar+        -> [Id]                 -- list of vars in the input to these statements+        -> DsM (CoreExpr,       -- desugared expression+                DIdSet)         -- subset of local vars that occur free++dsCmdStmts ids local_vars out_ids [stmt] env_ids+  = dsCmdLStmt ids local_vars out_ids stmt env_ids++dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do+    let bound_vars  = mkVarSet (collectLStmtBinders stmt)+    let local_vars' = bound_vars `unionVarSet` local_vars+    (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts+    (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids+    return (do_compose ids+                (mkBigCoreVarTupTy env_ids)+                (mkBigCoreVarTupTy env_ids')+                (mkBigCoreVarTupTy out_ids)+                core_stmt+                core_stmts,+              fv_stmt)++dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []"++-- Match a list of expressions against a list of patterns, left-to-right.++matchSimplys :: [CoreExpr]              -- Scrutinees+             -> HsMatchContext Name     -- Match kind+             -> [LPat Id]               -- Patterns they should match+             -> CoreExpr                -- Return this if they all match+             -> CoreExpr                -- Return this if they don't+             -> DsM CoreExpr+matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr+matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do+    match_code <- matchSimplys exps ctxt pats result_expr fail_expr+    matchSimply exp ctxt pat match_code fail_expr+matchSimplys _ _ _ _ _ = panic "matchSimplys"++-- List of leaf expressions, with set of variables bound in each++leavesMatch :: LMatch Id (Located (body Id)) -> [(Located (body Id), IdSet)]+leavesMatch (L _ (Match _ pats _ (GRHSs grhss (L _ binds))))+  = let+        defined_vars = mkVarSet (collectPatsBinders pats)+                        `unionVarSet`+                       mkVarSet (collectLocalBinders binds)+    in+    [(body,+      mkVarSet (collectLStmtsBinders stmts)+        `unionVarSet` defined_vars)+    | L _ (GRHS stmts body) <- grhss]++-- Replace the leaf commands in a match++replaceLeavesMatch+        :: Type                                 -- new result type+        -> [Located (body' Id)]                 -- replacement leaf expressions of that type+        -> LMatch Id (Located (body Id))        -- the matches of a case command+        -> ([Located (body' Id)],               -- remaining leaf expressions+            LMatch Id (Located (body' Id)))     -- updated match+replaceLeavesMatch _res_ty leaves (L loc (Match mf pat mt (GRHSs grhss binds)))+  = let+        (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss+    in+    (leaves', L loc (Match mf pat mt (GRHSs grhss' binds)))++replaceLeavesGRHS+        :: [Located (body' Id)]                 -- replacement leaf expressions of that type+        -> LGRHS Id (Located (body Id))         -- rhss of a case command+        -> ([Located (body' Id)],               -- remaining leaf expressions+            LGRHS Id (Located (body' Id)))      -- updated GRHS+replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts _))+  = (leaves, L loc (GRHS stmts leaf))+replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []"++-- Balanced fold of a non-empty list.++foldb :: (a -> a -> a) -> [a] -> a+foldb _ [] = error "foldb of empty list"+foldb _ [x] = x+foldb f xs = foldb f (fold_pairs xs)+  where+    fold_pairs [] = []+    fold_pairs [x] = [x]+    fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs++{-+Note [Dictionary binders in ConPatOut] See also same Note in HsUtils+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The following functions to collect value variables from patterns are+copied from HsUtils, with one change: we also collect the dictionary+bindings (pat_binds) from ConPatOut.  We need them for cases like++h :: Arrow a => Int -> a (Int,Int) Int+h x = proc (y,z) -> case compare x y of+                GT -> returnA -< z+x++The type checker turns the case into++                case compare x y of+                  GT { p77 = plusInt } -> returnA -< p77 z x++Here p77 is a local binding for the (+) operation.++See comments in HsUtils for why the other version does not include+these bindings.+-}++collectPatBinders :: LPat Id -> [Id]+collectPatBinders pat = collectl pat []++collectPatsBinders :: [LPat Id] -> [Id]+collectPatsBinders pats = foldr collectl [] pats++---------------------+collectl :: LPat Id -> [Id] -> [Id]+-- See Note [Dictionary binders in ConPatOut]+collectl (L _ pat) bndrs+  = go pat+  where+    go (VarPat (L _ var))         = var : bndrs+    go (WildPat _)                = bndrs+    go (LazyPat pat)              = collectl pat bndrs+    go (BangPat pat)              = collectl pat bndrs+    go (AsPat (L _ a) pat)        = a : collectl pat bndrs+    go (ParPat  pat)              = collectl pat bndrs++    go (ListPat pats _ _)         = foldr collectl bndrs pats+    go (PArrPat pats _)           = foldr collectl bndrs pats+    go (TuplePat pats _ _)        = foldr collectl bndrs pats+    go (SumPat pat _ _ _)         = collectl pat bndrs++    go (ConPatIn _ ps)            = foldr collectl bndrs (hsConPatArgs ps)+    go (ConPatOut {pat_args=ps, pat_binds=ds}) =+                                    collectEvBinders ds+                                    ++ foldr collectl bndrs (hsConPatArgs ps)+    go (LitPat _)                 = bndrs+    go (NPat {})                  = bndrs+    go (NPlusKPat (L _ n) _ _ _ _ _) = n : bndrs++    go (SigPatIn pat _)           = collectl pat bndrs+    go (SigPatOut pat _)          = collectl pat bndrs+    go (CoPat _ pat _)            = collectl (noLoc pat) bndrs+    go (ViewPat _ pat _)          = collectl pat bndrs+    go p@(SplicePat {})           = pprPanic "collectl/go" (ppr p)++collectEvBinders :: TcEvBinds -> [Id]+collectEvBinders (EvBinds bs)   = foldrBag add_ev_bndr [] bs+collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"++add_ev_bndr :: EvBind -> [Id] -> [Id]+add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b    = b:bs+                                       | otherwise = bs+  -- A worry: what about coercion variable binders??++collectLStmtsBinders :: [LStmt Id body] -> [Id]+collectLStmtsBinders = concatMap collectLStmtBinders++collectLStmtBinders :: LStmt Id body -> [Id]+collectLStmtBinders = collectStmtBinders . unLoc++collectStmtBinders :: Stmt Id body -> [Id]+collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids+collectStmtBinders stmt = HsUtils.collectStmtBinders stmt
+ deSugar/DsBinds.hs view
@@ -0,0 +1,1387 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Pattern-matching bindings (HsBinds and MonoBinds)++Handles @HsBinds@; those at the top level require different handling,+in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at+lower levels it is preserved with @let@/@letrec@s).+-}++{-# LANGUAGE CPP #-}++module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,+                 dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule+  ) where++#include "HsVersions.h"++import {-# SOURCE #-}   DsExpr( dsLExpr )+import {-# SOURCE #-}   Match( matchWrapper )++import DsMonad+import DsGRHSs+import DsUtils++import HsSyn            -- lots of things+import CoreSyn          -- lots of things+import Literal          ( Literal(MachStr) )+import CoreOpt          ( simpleOptExpr )+import OccurAnal        ( occurAnalyseExpr )+import MkCore+import CoreUtils+import CoreArity ( etaExpand )+import CoreUnfold+import CoreFVs+import Digraph++import PrelNames+import TyCon+import TcEvidence+import TcType+import Type+import Coercion+import TysWiredIn ( typeNatKind, typeSymbolKind )+import Id+import MkId(proxyHashId)+import Class+import Name+import VarSet+import Rules+import VarEnv+import Outputable+import Module+import SrcLoc+import Maybes+import OrdList+import Bag+import BasicTypes+import DynFlags+import FastString+import Util+import MonadUtils+import qualified GHC.LanguageExtensions as LangExt+import Control.Monad++{-**********************************************************************+*                                                                      *+           Desugaring a MonoBinds+*                                                                      *+**********************************************************************-}++-- | Desugar top level binds, strict binds are treated like normal+-- binds since there is no good time to force before first usage.+dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))+dsTopLHsBinds binds+     -- see Note [Strict binds checks]+  | not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds)+  = do { mapBagM_ (top_level_err "bindings for unlifted types") unlifted_binds+       ; mapBagM_ (top_level_err "strict pattern bindings")    bang_binds+       ; return nilOL }++  | otherwise+  = do { (force_vars, prs) <- dsLHsBinds binds+       ; when debugIsOn $+         do { xstrict <- xoptM LangExt.Strict+            ; MASSERT2( null force_vars || xstrict, ppr binds $$ ppr force_vars ) }+              -- with -XStrict, even top-level vars are listed as force vars.++       ; return (toOL prs) }++  where+    unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds+    bang_binds     = filterBag (isBangedPatBind  . unLoc) binds++    top_level_err desc (L loc bind)+      = putSrcSpanDs loc $+        errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:")+                  2 (ppr bind))+++-- | Desugar all other kind of bindings, Ids of strict binds are returned to+-- later be forced in the binding group body, see Note [Desugar Strict binds]+dsLHsBinds :: LHsBinds Id -> DsM ([Id], [(Id,CoreExpr)])+dsLHsBinds binds+  = do { MASSERT( allBag (not . isUnliftedHsBind . unLoc) binds )+       ; ds_bs <- mapBagM dsLHsBind binds+       ; return (foldBag (\(a, a') (b, b') -> (a ++ b, a' ++ b'))+                         id ([], []) ds_bs) }++------------------------+dsLHsBind :: LHsBind Id+          -> DsM ([Id], [(Id,CoreExpr)])+dsLHsBind (L loc bind) = do dflags <- getDynFlags+                            putSrcSpanDs loc $ dsHsBind dflags bind++-- | Desugar a single binding (or group of recursive binds).+dsHsBind :: DynFlags+         -> HsBind Id+         -> DsM ([Id], [(Id,CoreExpr)])+         -- ^ The Ids of strict binds, to be forced in the body of the+         -- binding group see Note [Desugar Strict binds] and all+         -- bindings and their desugared right hand sides.++dsHsBind dflags+         (VarBind { var_id = var+                  , var_rhs = expr+                  , var_inline = inline_regardless })+  = do  { core_expr <- dsLExpr expr+                -- Dictionary bindings are always VarBinds,+                -- so we only need do this here+        ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr+                   | otherwise         = var+        ; let core_bind@(id,_) = makeCorePair dflags var' False 0 core_expr+              force_var = if xopt LangExt.Strict dflags+                          then [id]+                          else []+        ; return (force_var, [core_bind]) }++dsHsBind dflags+         b@(FunBind { fun_id = L _ fun, fun_matches = matches+                    , fun_co_fn = co_fn, fun_tick = tick })+ = do   { (args, body) <- matchWrapper+                           (mkPrefixFunRhs (noLoc $ idName fun))+                           Nothing matches+        ; core_wrap <- dsHsWrapper co_fn+        ; let body' = mkOptTickBox tick body+              rhs   = core_wrap (mkLams args body')+              core_binds@(id,_) = makeCorePair dflags fun False 0 rhs+              force_var+                  -- Bindings are strict when -XStrict is enabled+                | xopt LangExt.Strict dflags+                , matchGroupArity matches == 0 -- no need to force lambdas+                = [id]+                | isBangedBind b+                = [id]+                | otherwise+                = []+        ; --pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun) $$ ppr (mg_alts matches) $$ ppr args $$ ppr core_binds) $+           return (force_var, [core_binds]) }++dsHsBind dflags+         (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty+                  , pat_ticks = (rhs_tick, var_ticks) })+  = do  { body_expr <- dsGuarded grhss ty+        ; let body' = mkOptTickBox rhs_tick body_expr+              pat'  = decideBangHood dflags pat+        ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat body'+          -- We silently ignore inline pragmas; no makeCorePair+          -- Not so cool, but really doesn't matter+        ; let force_var' = if isBangedLPat pat'+                           then [force_var]+                           else []+        ; return (force_var', sel_binds) }++        -- A common case: one exported variable, only non-strict binds+        -- Non-recursive bindings come through this way+        -- So do self-recursive bindings+        -- Bindings with complete signatures are AbsBindsSigs, below+dsHsBind dflags+         (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts+                   , abs_exports = [export]+                   , abs_ev_binds = ev_binds, abs_binds = binds })+  | ABE { abe_wrap = wrap, abe_poly = global+        , abe_mono = local, abe_prags = prags } <- export+  , not (xopt LangExt.Strict dflags)             -- Handle strict binds+  , not (anyBag (isBangedBind . unLoc) binds)    --        in the next case+  = -- See Note [AbsBinds wrappers] in HsBinds+    addDictsDs (toTcTypeBag (listToBag dicts)) $+         -- addDictsDs: push type constraints deeper for pattern match check+    do { (force_vars, bind_prs) <- dsLHsBinds binds+       ; let core_bind = Rec bind_prs+       ; ds_binds <- dsTcEvBinds_s ev_binds+       ; core_wrap <- dsHsWrapper wrap -- Usually the identity++       ; let rhs = core_wrap $+                   mkLams tyvars $ mkLams dicts $+                   mkCoreLets ds_binds $+                   mkLet core_bind $+                   Var local+       ; (spec_binds, rules) <- dsSpecs rhs prags++       ; let   global'  = addIdSpecialisations global rules+               main_bind = makeCorePair dflags global' (isDefaultMethod prags)+                                        (dictArity dicts) rhs++       ; ASSERT(null force_vars)+         return ([], main_bind : fromOL spec_binds) }++        -- Another common case: no tyvars, no dicts+        -- In this case we can have a much simpler desugaring+dsHsBind dflags+         (AbsBinds { abs_tvs = [], abs_ev_vars = []+                   , abs_exports = exports+                   , abs_ev_binds = ev_binds, abs_binds = binds })+  = do { (force_vars, bind_prs) <- dsLHsBinds binds+       ; let mk_bind (ABE { abe_wrap = wrap+                          , abe_poly = global+                          , abe_mono = local+                          , abe_prags = prags })+              = do { core_wrap <- dsHsWrapper wrap+                   ; return (makeCorePair dflags global+                                          (isDefaultMethod prags)+                                          0 (core_wrap (Var local))) }+       ; main_binds <- mapM mk_bind exports++       ; ds_binds <- dsTcEvBinds_s ev_binds+       ; return (force_vars, flattenBinds ds_binds ++ bind_prs ++ main_binds) }++dsHsBind dflags+         (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts+                   , abs_exports = exports, abs_ev_binds = ev_binds+                   , abs_binds = binds })+         -- See Note [Desugaring AbsBinds]+  = addDictsDs (toTcTypeBag (listToBag dicts)) $+         -- addDictsDs: push type constraints deeper for pattern match check+     do { (local_force_vars, bind_prs) <- dsLHsBinds binds+        ; let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs+                              | (lcl_id, rhs) <- bind_prs ]+                -- Monomorphic recursion possible, hence Rec+              new_force_vars = get_new_force_vars local_force_vars+              locals       = map abe_mono exports+              all_locals   = locals ++ new_force_vars+              tup_expr     = mkBigCoreVarTup all_locals+              tup_ty       = exprType tup_expr+        ; ds_binds <- dsTcEvBinds_s ev_binds+        ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $+                             mkCoreLets ds_binds $+                             mkLet core_bind $+                             tup_expr++        ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)++        -- Find corresponding global or make up a new one: sometimes+        -- we need to make new export to desugar strict binds, see+        -- Note [Desugar Strict binds]+        ; (exported_force_vars, extra_exports) <- get_exports local_force_vars++        ; let mk_bind (ABE { abe_wrap = wrap+                           , abe_poly = global+                           , abe_mono = local, abe_prags = spec_prags })+                         -- See Note [AbsBinds wrappers] in HsBinds+                = do { tup_id  <- newSysLocalDs tup_ty+                     ; core_wrap <- dsHsWrapper wrap+                     ; let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $+                                 mkTupleSelector all_locals local tup_id $+                                 mkVarApps (Var poly_tup_id) (tyvars ++ dicts)+                           rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs+                     ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags+                     ; let global' = (global `setInlinePragma` defaultInlinePragma)+                                             `addIdSpecialisations` rules+                           -- Kill the INLINE pragma because it applies to+                           -- the user written (local) function.  The global+                           -- Id is just the selector.  Hmm.+                     ; return ((global', rhs) : fromOL spec_binds) }++        ; export_binds_s <- mapM mk_bind (exports ++ extra_exports)++        ; return (exported_force_vars+                 ,(poly_tup_id, poly_tup_rhs) :+                   concat export_binds_s) }+  where+    inline_env :: IdEnv Id   -- Maps a monomorphic local Id to one with+                             -- the inline pragma from the source+                             -- The type checker put the inline pragma+                             -- on the *global* Id, so we need to transfer it+    inline_env+      = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag)+                 | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports+                 , let prag = idInlinePragma gbl_id ]++    add_inline :: Id -> Id    -- tran+    add_inline lcl_id = lookupVarEnv inline_env lcl_id+                        `orElse` lcl_id++    global_env :: IdEnv Id -- Maps local Id to its global exported Id+    global_env =+      mkVarEnv [ (local, global)+               | ABE { abe_mono = local, abe_poly = global } <- exports+               ]++    -- find variables that are not exported+    get_new_force_vars lcls =+      foldr (\lcl acc -> case lookupVarEnv global_env lcl of+                           Just _ -> acc+                           Nothing -> lcl:acc)+            [] lcls++    -- find exports or make up new exports for force variables+    get_exports :: [Id] -> DsM ([Id], [ABExport Id])+    get_exports lcls =+      foldM (\(glbls, exports) lcl ->+              case lookupVarEnv global_env lcl of+                Just glbl -> return (glbl:glbls, exports)+                Nothing   -> do export <- mk_export lcl+                                let glbl = abe_poly export+                                return (glbl:glbls, export:exports))+            ([],[]) lcls++    mk_export local =+      do global <- newSysLocalDs+                     (exprType (mkLams tyvars (mkLams dicts (Var local))))+         return (ABE {abe_poly = global+                     ,abe_mono = local+                     ,abe_wrap = WpHole+                     ,abe_prags = SpecPrags []})++-- AbsBindsSig is a combination of AbsBinds and FunBind+dsHsBind dflags (AbsBindsSig { abs_tvs = tyvars, abs_ev_vars = dicts+                             , abs_sig_export  = global+                             , abs_sig_prags   = prags+                             , abs_sig_ev_bind = ev_bind+                             , abs_sig_bind    = bind })+  | L bind_loc FunBind { fun_matches = matches+                       , fun_co_fn   = co_fn+                       , fun_tick    = tick } <- bind+  = putSrcSpanDs bind_loc $+    addDictsDs (toTcTypeBag (listToBag dicts)) $+             -- addDictsDs: push type constraints deeper for pattern match check+    do { (args, body) <- matchWrapper+                           (mkPrefixFunRhs (noLoc $ idName global))+                           Nothing matches+       ; core_wrap <- dsHsWrapper co_fn+       ; let body'   = mkOptTickBox tick body+             fun_rhs = core_wrap (mkLams args body')+             force_vars+               | xopt LangExt.Strict dflags+               , matchGroupArity matches == 0 -- no need to force lambdas+               = [global]+               | isBangedBind (unLoc bind)+               = [global]+               | otherwise+               = []++       ; ds_binds <- dsTcEvBinds ev_bind+       ; let rhs = mkLams tyvars $+                   mkLams dicts $+                   mkCoreLets ds_binds $+                   fun_rhs++       ; (spec_binds, rules) <- dsSpecs rhs prags+       ; let global' = addIdSpecialisations global rules+             main_bind = makeCorePair dflags global' (isDefaultMethod prags)+                                      (dictArity dicts) rhs++       ; return (force_vars, main_bind : fromOL spec_binds) }++  | otherwise+  = pprPanic "dsHsBind: AbsBindsSig" (ppr bind)++dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"++++-- | This is where we apply INLINE and INLINABLE pragmas. All we need to+-- do is to attach the unfolding information to the Id.+--+-- Other decisions about whether to inline are made in+-- `calcUnfoldingGuidance` but the decision about whether to then expose+-- the unfolding in the interface file is made in `TidyPgm.addExternal`+-- using this information.+------------------------+makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)+makeCorePair dflags gbl_id is_default_method dict_arity rhs+  | is_default_method                 -- Default methods are *always* inlined+  = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)++  | otherwise+  = case inlinePragmaSpec inline_prag of+          EmptyInlineSpec -> (gbl_id, rhs)+          NoInline        -> (gbl_id, rhs)+          Inlinable       -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)+          Inline          -> inline_pair++  where+    inline_prag   = idInlinePragma gbl_id+    inlinable_unf = mkInlinableUnfolding dflags rhs+    inline_pair+       | Just arity <- inlinePragmaSat inline_prag+        -- Add an Unfolding for an INLINE (but not for NOINLINE)+        -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]+       , let real_arity = dict_arity + arity+        -- NB: The arity in the InlineRule takes account of the dictionaries+       = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity real_arity rhs+         , etaExpand real_arity rhs)++       | otherwise+       = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $+         (gbl_id `setIdUnfolding` mkInlineUnfolding rhs, rhs)++dictArity :: [Var] -> Arity+-- Don't count coercion variables in arity+dictArity dicts = count isId dicts++{-+Note [Desugaring AbsBinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~+In the general AbsBinds case we desugar the binding to this:++       tup a (d:Num a) = let fm = ...gm...+                             gm = ...fm...+                         in (fm,gm)+       f a d = case tup a d of { (fm,gm) -> fm }+       g a d = case tup a d of { (fm,gm) -> fm }++Note [Rules and inlining]+~~~~~~~~~~~~~~~~~~~~~~~~~+Common special case: no type or dictionary abstraction+This is a bit less trivial than you might suppose+The naive way woudl be to desguar to something like+        f_lcl = ...f_lcl...     -- The "binds" from AbsBinds+        M.f = f_lcl             -- Generated from "exports"+But we don't want that, because if M.f isn't exported,+it'll be inlined unconditionally at every call site (its rhs is+trivial).  That would be ok unless it has RULES, which would+thereby be completely lost.  Bad, bad, bad.++Instead we want to generate+        M.f = ...f_lcl...+        f_lcl = M.f+Now all is cool. The RULES are attached to M.f (by SimplCore),+and f_lcl is rapidly inlined away.++This does not happen in the same way to polymorphic binds,+because they desugar to+        M.f = /\a. let f_lcl = ...f_lcl... in f_lcl+Although I'm a bit worried about whether full laziness might+float the f_lcl binding out and then inline M.f at its call site++Note [Specialising in no-dict case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Even if there are no tyvars or dicts, we may have specialisation pragmas.+Class methods can generate+      AbsBinds [] [] [( ... spec-prag]+         { AbsBinds [tvs] [dicts] ...blah }+So the overloading is in the nested AbsBinds. A good example is in GHC.Float:++  class  (Real a, Fractional a) => RealFrac a  where+    round :: (Integral b) => a -> b++  instance  RealFrac Float  where+    {-# SPECIALIZE round :: Float -> Int #-}++The top-level AbsBinds for $cround has no tyvars or dicts (because the+instance does not).  But the method is locally overloaded!++Note [Abstracting over tyvars only]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When abstracting over type variable only (not dictionaries), we don't really need to+built a tuple and select from it, as we do in the general case. Instead we can take++        AbsBinds [a,b] [ ([a,b], fg, fl, _),+                         ([b],   gg, gl, _) ]+                { fl = e1+                  gl = e2+                   h = e3 }++and desugar it to++        fg = /\ab. let B in e1+        gg = /\b. let a = () in let B in S(e2)+        h  = /\ab. let B in e3++where B is the *non-recursive* binding+        fl = fg a b+        gl = gg b+        h  = h a b    -- See (b); note shadowing!++Notice (a) g has a different number of type variables to f, so we must+             use the mkArbitraryType thing to fill in the gaps.+             We use a type-let to do that.++         (b) The local variable h isn't in the exports, and rather than+             clone a fresh copy we simply replace h by (h a b), where+             the two h's have different types!  Shadowing happens here,+             which looks confusing but works fine.++         (c) The result is *still* quadratic-sized if there are a lot of+             small bindings.  So if there are more than some small+             number (10), we filter the binding set B by the free+             variables of the particular RHS.  Tiresome.++Why got to this trouble?  It's a common case, and it removes the+quadratic-sized tuple desugaring.  Less clutter, hopefully faster+compilation, especially in a case where there are a *lot* of+bindings.+++Note [Eta-expanding INLINE things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   foo :: Eq a => a -> a+   {-# INLINE foo #-}+   foo x = ...++If (foo d) ever gets floated out as a common sub-expression (which can+happen as a result of method sharing), there's a danger that we never+get to do the inlining, which is a Terribly Bad thing given that the+user said "inline"!++To avoid this we pre-emptively eta-expand the definition, so that foo+has the arity with which it is declared in the source code.  In this+example it has arity 2 (one for the Eq and one for x). Doing this+should mean that (foo d) is a PAP and we don't share it.++Note [Nested arities]+~~~~~~~~~~~~~~~~~~~~~+For reasons that are not entirely clear, method bindings come out looking like+this:++  AbsBinds [] [] [$cfromT <= [] fromT]+    $cfromT [InlPrag=INLINE] :: T Bool -> Bool+    { AbsBinds [] [] [fromT <= [] fromT_1]+        fromT :: T Bool -> Bool+        { fromT_1 ((TBool b)) = not b } } }++Note the nested AbsBind.  The arity for the InlineRule on $cfromT should be+gotten from the binding for fromT_1.++It might be better to have just one level of AbsBinds, but that requires more+thought!+++Note [Desugar Strict binds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~++Desugaring strict variable bindings looks as follows (core below ==>)++  let !x = rhs+  in  body+==>+  let x = rhs+  in x `seq` body -- seq the variable++and if it is a pattern binding the desugaring looks like++  let !pat = rhs+  in body+==>+  let x = rhs -- bind the rhs to a new variable+      pat = x+  in x `seq` body -- seq the new variable++if there is no variable in the pattern desugaring looks like++  let False = rhs+  in body+==>+  let x = case rhs of {False -> (); _ -> error "Match failed"}+  in x `seq` body++In order to force the Ids in the binding group they are passed around+in the dsHsBind family of functions, and later seq'ed in DsExpr.ds_val_bind.++Consider a recursive group like this++  letrec+     f : g = rhs[f,g]+  in <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://ghc.haskell.org/trac/ghc/wiki/StrictPragma for a more+detailed explanation of the desugaring of strict bindings.++Note [Strict binds checks]+~~~~~~~~~~~~~~~~~~~~~~~~~~+There are several checks around properly formed strict bindings. They+all link to this Note. These checks must be here in the desugarer because+we cannot know whether or not a type is unlifted until after zonking, due+to levity polymorphism. These checks all used to be handled in the typechecker+in checkStrictBinds (before Jan '17).++We define an "unlifted bind" to be any bind that binds an unlifted id. Note that++  x :: Char+  (# True, x #) = blah++is *not* an unlifted bind. Unlifted binds are detected by HsUtils.isUnliftedHsBind.++Define a "banged bind" to have a top-level bang. Detected by HsPat.isBangedPatBind.+Define a "strict bind" to be either an unlifted bind or a banged bind.++The restrictions are:+  1. Strict binds may not be top-level. Checked in dsTopLHsBinds.++  2. Unlifted binds must also be banged. (There is no trouble to compile an unbanged+     unlifted bind, but an unbanged bind looks lazy, and we don't want users to be+     surprised by the strictness of an unlifted bind.) Checked in first clause+     of DsExpr.ds_val_bind.++  3. Unlifted binds may not have polymorphism (#6078). (That is, no quantified type+     variables or constraints.) Checked in first clause+     of DsExpr.ds_val_bind.++  4. Unlifted binds may not be recursive. Checked in second clause of ds_val_bind.++-}++------------------------+dsSpecs :: CoreExpr     -- Its rhs+        -> TcSpecPrags+        -> DsM ( OrdList (Id,CoreExpr)  -- Binding for specialised Ids+               , [CoreRule] )           -- Rules for the Global Ids+-- See Note [Handling SPECIALISE pragmas] in TcBinds+dsSpecs _ IsDefaultMethod = return (nilOL, [])+dsSpecs poly_rhs (SpecPrags sps)+  = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps+       ; let (spec_binds_s, rules) = unzip pairs+       ; return (concatOL spec_binds_s, rules) }++dsSpec :: Maybe CoreExpr        -- Just rhs => RULE is for a local binding+                                -- Nothing => RULE is for an imported Id+                                --            rhs is in the Id's unfolding+       -> Located TcSpecPrag+       -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))+dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))+  | isJust (isClassOpId_maybe poly_id)+  = putSrcSpanDs loc $+    do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for class method selector"+                          <+> quotes (ppr poly_id))+       ; return Nothing  }  -- There is no point in trying to specialise a class op+                            -- Moreover, classops don't (currently) have an inl_sat arity set+                            -- (it would be Just 0) and that in turn makes makeCorePair bleat++  | no_act_spec && isNeverActive rule_act+  = putSrcSpanDs loc $+    do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for NOINLINE function:"+                          <+> quotes (ppr poly_id))+       ; return Nothing  }  -- Function is NOINLINE, and the specialiation inherits that+                            -- See Note [Activation pragmas for SPECIALISE]++  | otherwise+  = putSrcSpanDs loc $+    do { uniq <- newUnique+       ; let poly_name = idName poly_id+             spec_occ  = mkSpecOcc (getOccName poly_name)+             spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name)+             (spec_bndrs, spec_app) = collectHsWrapBinders spec_co+               -- spec_co looks like+               --         \spec_bndrs. [] spec_args+               -- perhaps with the body of the lambda wrapped in some WpLets+               -- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2++       ; core_app <- dsHsWrapper spec_app++       ; let ds_lhs  = core_app (Var poly_id)+             spec_ty = mkLamTypes spec_bndrs (exprType ds_lhs)+       ; -- pprTrace "dsRule" (vcat [ text "Id:" <+> ppr poly_id+         --                         , text "spec_co:" <+> ppr spec_co+         --                         , text "ds_rhs:" <+> ppr ds_lhs ]) $+         case decomposeRuleLhs spec_bndrs ds_lhs of {+           Left msg -> do { warnDs NoReason msg; return Nothing } ;+           Right (rule_bndrs, _fn, args) -> do++       { dflags <- getDynFlags+       ; this_mod <- getModule+       ; let fn_unf    = realIdUnfolding poly_id+             spec_unf  = specUnfolding spec_bndrs core_app arity_decrease fn_unf+             spec_id   = mkLocalId spec_name spec_ty+                            `setInlinePragma` inl_prag+                            `setIdUnfolding`  spec_unf+             arity_decrease = count isValArg args - count isId spec_bndrs++       ; rule <- dsMkUserRule this_mod is_local_id+                        (mkFastString ("SPEC " ++ showPpr dflags poly_name))+                        rule_act poly_name+                        rule_bndrs args+                        (mkVarApps (Var spec_id) spec_bndrs)++       ; let spec_rhs = mkLams spec_bndrs (core_app poly_rhs)++-- Commented out: see Note [SPECIALISE on INLINE functions]+--       ; when (isInlinePragma id_inl)+--              (warnDs $ text "SPECIALISE pragma on INLINE function probably won't fire:"+--                        <+> quotes (ppr poly_name))++       ; return (Just (unitOL (spec_id, spec_rhs), rule))+            -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because+            --     makeCorePair overwrites the unfolding, which we have+            --     just created using specUnfolding+       } } }+  where+    is_local_id = isJust mb_poly_rhs+    poly_rhs | Just rhs <-  mb_poly_rhs+             = rhs          -- Local Id; this is its rhs+             | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)+             = unfolding    -- Imported Id; this is its unfolding+                            -- Use realIdUnfolding so we get the unfolding+                            -- even when it is a loop breaker.+                            -- We want to specialise recursive functions!+             | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)+                            -- The type checker has checked that it *has* an unfolding++    id_inl = idInlinePragma poly_id++    -- See Note [Activation pragmas for SPECIALISE]+    inl_prag | not (isDefaultInlinePragma spec_inl)    = spec_inl+             | not is_local_id  -- See Note [Specialising imported functions]+                                 -- in OccurAnal+             , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma+             | otherwise                               = id_inl+     -- Get the INLINE pragma from SPECIALISE declaration, or,+     -- failing that, from the original Id++    spec_prag_act = inlinePragmaActivation spec_inl++    -- See Note [Activation pragmas for SPECIALISE]+    -- no_act_spec is True if the user didn't write an explicit+    -- phase specification in the SPECIALISE pragma+    no_act_spec = case inlinePragmaSpec spec_inl of+                    NoInline -> isNeverActive  spec_prag_act+                    _        -> isAlwaysActive spec_prag_act+    rule_act | no_act_spec = inlinePragmaActivation id_inl   -- Inherit+             | otherwise   = spec_prag_act                   -- Specified by user+++dsMkUserRule :: Module -> Bool -> RuleName -> Activation+       -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> DsM CoreRule+dsMkUserRule this_mod is_local name act fn bndrs args rhs = do+    let rule = mkRule this_mod False is_local name act fn bndrs args rhs+    dflags <- getDynFlags+    when (isOrphan (ru_orphan rule) && wopt Opt_WarnOrphans dflags) $+        warnDs (Reason Opt_WarnOrphans) (ruleOrphWarn rule)+    return rule++ruleOrphWarn :: CoreRule -> SDoc+ruleOrphWarn rule = text "Orphan rule:" <+> ppr rule++{- Note [SPECIALISE on INLINE functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to warn that using SPECIALISE for a function marked INLINE+would be a no-op; but it isn't!  Especially with worker/wrapper split+we might have+   {-# INLINE f #-}+   f :: Ord a => Int -> a -> ...+   f d x y = case x of I# x' -> $wf d x' y++We might want to specialise 'f' so that we in turn specialise '$wf'.+We can't even /name/ '$wf' in the source code, so we can't specialise+it even if we wanted to.  Trac #10721 is a case in point.++Note [Activation pragmas for SPECIALISE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+From a user SPECIALISE pragma for f, we generate+  a) A top-level binding    spec_fn = rhs+  b) A RULE                 f dOrd = spec_fn++We need two pragma-like things:++* spec_fn's inline pragma: inherited from f's inline pragma (ignoring+                           activation on SPEC), unless overriden by SPEC INLINE++* Activation of RULE: from SPECIALISE pragma (if activation given)+                      otherwise from f's inline pragma++This is not obvious (see Trac #5237)!++Examples      Rule activation   Inline prag on spec'd fn+---------------------------------------------------------------------+SPEC [n] f :: ty            [n]   Always, or NOINLINE [n]+                                  copy f's prag++NOINLINE f+SPEC [n] f :: ty            [n]   NOINLINE+                                  copy f's prag++NOINLINE [k] f+SPEC [n] f :: ty            [n]   NOINLINE [k]+                                  copy f's prag++INLINE [k] f+SPEC [n] f :: ty            [n]   INLINE [k]+                                  copy f's prag++SPEC INLINE [n] f :: ty     [n]   INLINE [n]+                                  (ignore INLINE prag on f,+                                  same activation for rule and spec'd fn)++NOINLINE [k] f+SPEC f :: ty                [n]   INLINE [k]+++************************************************************************+*                                                                      *+\subsection{Adding inline pragmas}+*                                                                      *+************************************************************************+-}++decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr])+-- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE,+-- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs+-- may add some extra dictionary binders (see Note [Free dictionaries])+--+-- Returns an error message if the LHS isn't of the expected shape+-- Note [Decomposing the left-hand side of a RULE]+decomposeRuleLhs orig_bndrs orig_lhs+  | not (null unbound)    -- Check for things unbound on LHS+                          -- See Note [Unused spec binders]+  = Left (vcat (map dead_msg unbound))+  | Var funId <- fun2+  , Just con <- isDataConId_maybe funId+  = Left (constructor_msg con) -- See Note [No RULES on datacons]+  | Just (fn_id, args) <- decompose fun2 args2+  , let extra_bndrs = mk_extra_bndrs fn_id args+  = -- pprTrace "decmposeRuleLhs" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs+    --                                  , text "orig_lhs:" <+> ppr orig_lhs+    --                                  , text "lhs1:"     <+> ppr lhs1+    --                                  , text "extra_dict_bndrs:" <+> ppr extra_dict_bndrs+    --                                  , text "fn_id:" <+> ppr fn_id+    --                                  , text "args:"   <+> ppr args]) $+    Right (orig_bndrs ++ extra_bndrs, fn_id, args)++  | otherwise+  = Left bad_shape_msg+ where+   lhs1         = drop_dicts orig_lhs+   lhs2         = simpleOptExpr lhs1  -- See Note [Simplify rule LHS]+   (fun2,args2) = collectArgs lhs2++   lhs_fvs    = exprFreeVars lhs2+   unbound    = filterOut (`elemVarSet` lhs_fvs) orig_bndrs++   orig_bndr_set = mkVarSet orig_bndrs++        -- Add extra tyvar binders: Note [Free tyvars in rule LHS]+        -- and extra dict binders: Note [Free dictionaries in rule LHS]+   mk_extra_bndrs fn_id args+     = toposortTyVars unbound_tvs ++ unbound_dicts+     where+       unbound_tvs   = [ v | v <- unbound_vars, isTyVar v ]+       unbound_dicts = [ mkLocalId (localiseName (idName d)) (idType d)+                       | d <- unbound_vars, isDictId d ]+       unbound_vars  = [ v | v <- exprsFreeVarsList args+                           , not (v `elemVarSet` orig_bndr_set)+                           , not (v == fn_id) ]+         -- fn_id: do not quantify over the function itself, which may+         -- itself be a dictionary (in pathological cases, Trac #10251)++   decompose (Var fn_id) args+      | not (fn_id `elemVarSet` orig_bndr_set)+      = Just (fn_id, args)++   decompose _ _ = Nothing++   bad_shape_msg = hang (text "RULE left-hand side too complicated to desugar")+                      2 (vcat [ text "Optimised lhs:" <+> ppr lhs2+                              , text "Orig lhs:" <+> ppr orig_lhs])+   dead_msg bndr = hang (sep [ text "Forall'd" <+> pp_bndr bndr+                             , text "is not bound in RULE lhs"])+                      2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs+                              , text "Orig lhs:" <+> ppr orig_lhs+                              , text "optimised lhs:" <+> ppr lhs2 ])+   pp_bndr bndr+    | isTyVar bndr                      = text "type variable" <+> quotes (ppr bndr)+    | Just pred <- evVarPred_maybe bndr = text "constraint" <+> quotes (ppr pred)+    | otherwise                         = text "variable" <+> quotes (ppr bndr)++   constructor_msg con = vcat+     [ text "A constructor," <+> ppr con <>+         text ", appears as outermost match in RULE lhs."+     , text "This rule will be ignored." ]++   drop_dicts :: CoreExpr -> CoreExpr+   drop_dicts e+       = wrap_lets needed bnds body+     where+       needed = orig_bndr_set `minusVarSet` exprFreeVars body+       (bnds, body) = split_lets (occurAnalyseExpr e)+           -- The occurAnalyseExpr drops dead bindings which is+           -- crucial to ensure that every binding is used later;+           -- which in turn makes wrap_lets work right++   split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)+   split_lets (Let (NonRec d r) body)+     | isDictId d+     = ((d,r):bs, body')+     where (bs, body') = split_lets body++    -- handle "unlifted lets" too, needed for "map/coerce"+   split_lets (Case r d _ [(DEFAULT, _, body)])+     | isCoVar d+     = ((d,r):bs, body')+     where (bs, body') = split_lets body++   split_lets e = ([], e)++   wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr+   wrap_lets _ [] body = body+   wrap_lets needed ((d, r) : bs) body+     | rhs_fvs `intersectsVarSet` needed = mkCoreLet (NonRec d r) (wrap_lets needed' bs body)+     | otherwise                         = wrap_lets needed bs body+     where+       rhs_fvs = exprFreeVars r+       needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d++{-+Note [Decomposing the left-hand side of a RULE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are several things going on here.+* drop_dicts: see Note [Drop dictionary bindings on rule LHS]+* simpleOptExpr: see Note [Simplify rule LHS]+* extra_dict_bndrs: see Note [Free dictionaries]++Note [Free tyvars on rule LHS]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  data T a = C++  foo :: T a -> Int+  foo C = 1++  {-# RULES "myrule"  foo C = 1 #-}++After type checking the LHS becomes (foo alpha (C alpha)), where alpha+is an unbound meta-tyvar.  The zonker in TcHsSyn is careful not to+turn the free alpha into Any (as it usually does).  Instead it turns it+into a TyVar 'a'.  See TcHsSyn Note [Zonking the LHS of a RULE].++Now we must quantify over that 'a'.  It's /really/ inconvenient to do that+in the zonker, because the HsExpr data type is very large.  But it's /easy/+to do it here in the desugarer.++Moreover, we have to do something rather similar for dictionaries;+see Note [Free dictionaries on rule LHS].   So that's why we look for+type variables free on the LHS, and quantify over them.++Note [Free dictionaries on rule LHS]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,+which is presumably in scope at the function definition site, we can quantify+over it too.  *Any* dict with that type will do.++So for example when you have+        f :: Eq a => a -> a+        f = <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 (Trac #8331)+             {-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-}+             useAbstractMonad :: MonadAbstractIOST m => m Int+         Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code+         but the RHS uses no dictionaries, so we want to end up with+             RULE forall s (d :: MonadAbstractIOST (ReaderT s)).+                useAbstractMonad (ReaderT s) d = $suseAbstractMonad s++   Trac #8848 is a good example of where there are some intersting+   dictionary bindings to discard.++The drop_dicts algorithm is based on these observations:++  * Given (let d = rhs in e) where d is a DictId,+    matching 'e' will bind e's free variables.++  * So we want to keep the binding if one of the needed variables (for+    which we need a binding) is in fv(rhs) but not already in fv(e).++  * The "needed variables" are simply the orig_bndrs.  Consider+       f :: (Eq a, Show b) => a -> b -> String+       ... SPECIALISE f :: (Show b) => Int -> b -> String ...+    Then orig_bndrs includes the *quantified* dictionaries of the type+    namely (dsb::Show b), but not the one for Eq Int++So we work inside out, applying the above criterion at each step.+++Note [Simplify rule LHS]+~~~~~~~~~~~~~~~~~~~~~~~~+simplOptExpr occurrence-analyses and simplifies the LHS:++   (a) Inline any remaining dictionary bindings (which hopefully+       occur just once)++   (b) Substitute trivial lets, so that they don't get in the way.+       Note that we substitute the function too; we might+       have this as a LHS:  let f71 = M.f Int in f71++   (c) Do eta reduction.  To see why, consider the fold/build rule,+       which without simplification looked like:+          fold k z (build (/\a. g a))  ==>  ...+       This doesn't match unless you do eta reduction on the build argument.+       Similarly for a LHS like+         augment g (build h)+       we do not want to get+         augment (\a. g a) (build h)+       otherwise we don't match when given an argument like+          augment (\a. h a a) (build h)++Note [Matching seqId]+~~~~~~~~~~~~~~~~~~~+The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack+and this code turns it back into an application of seq!+See Note [Rules for seq] in MkId for the details.++Note [Unused spec binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+        f :: a -> a+        ... SPECIALISE f :: Eq a => a -> a ...+It's true that this *is* a more specialised type, but the rule+we get is something like this:+        f_spec d = f+        RULE: f = f_spec d+Note that the rule is bogus, because it mentions a 'd' that is+not bound on the LHS!  But it's a silly specialisation anyway, because+the constraint is unused.  We could bind 'd' to (error "unused")+but it seems better to reject the program because it's almost certainly+a mistake.  That's what the isDeadBinder call detects.++Note [No RULES on datacons]+~~~~~~~~~~~~~~~~~~~~~~~~~~~++Previously, `RULES` like++    "JustNothing" forall x . Just x = Nothing++were allowed. Simon Peyton Jones says this seems to have been a+mistake, that such rules have never been supported intentionally,+and that he doesn't know if they can break in horrible ways.+Furthermore, Ben Gamari and Reid Barton are considering trying to+detect the presence of "static data" that the simplifier doesn't+need to traverse at all. Such rules do not play well with that.+So for now, we ban them altogether as requested by #13290. See also #7398.+++************************************************************************+*                                                                      *+                Desugaring evidence+*                                                                      *+************************************************************************++-}++dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)+dsHsWrapper WpHole            = return $ \e -> e+dsHsWrapper (WpTyApp ty)      = return $ \e -> App e (Type ty)+dsHsWrapper (WpEvLam ev)      = return $ Lam ev+dsHsWrapper (WpTyLam tv)      = return $ Lam tv+dsHsWrapper (WpLet ev_binds)  = do { bs <- dsTcEvBinds ev_binds+                                   ; return (mkCoreLets bs) }+dsHsWrapper (WpCompose c1 c2) = do { w1 <- dsHsWrapper c1+                                   ; w2 <- dsHsWrapper c2+                                   ; return (w1 . w2) }+ -- See comments on WpFun in TcEvidence for an explanation of what+ -- the specification of this clause is+dsHsWrapper (WpFun c1 c2 t1 doc)+                              = do { x  <- newSysLocalDsNoLP t1+                                   ; w1 <- dsHsWrapper c1+                                   ; w2 <- dsHsWrapper c2+                                   ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a+                                         arg     = w1 (Var x)+                                   ; (_, ok) <- askNoErrsDs $ dsNoLevPolyExpr arg doc+                                   ; if ok+                                     then return (\e -> (Lam x (w2 (app e arg))))+                                     else return id }  -- this return is irrelevant+dsHsWrapper (WpCast co)       = ASSERT(coercionRole co == Representational)+                                return $ \e -> mkCastDs e co+dsHsWrapper (WpEvApp tm)      = do { core_tm <- dsEvTerm tm+                                   ; return (\e -> App e core_tm) }++--------------------------------------+dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind]+dsTcEvBinds_s []       = return []+dsTcEvBinds_s (b:rest) = ASSERT( null rest )  -- Zonker ensures null+                         dsTcEvBinds b++dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]+dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds"    -- Zonker has got rid of this+dsTcEvBinds (EvBinds bs)   = dsEvBinds bs++dsEvBinds :: Bag EvBind -> DsM [CoreBind]+dsEvBinds bs = mapM ds_scc (sccEvBinds bs)+  where+    ds_scc (AcyclicSCC (EvBind { eb_lhs = v, eb_rhs = r}))+                          = liftM (NonRec v) (dsEvTerm r)+    ds_scc (CyclicSCC bs) = liftM Rec (mapM dsEvBind bs)++dsEvBind :: EvBind -> DsM (Id, CoreExpr)+dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r)++{-**********************************************************************+*                                                                      *+           Desugaring EvTerms+*                                                                      *+**********************************************************************-}++dsEvTerm :: EvTerm -> DsM CoreExpr+dsEvTerm (EvId v)           = return (Var v)+dsEvTerm (EvCallStack cs)   = dsEvCallStack cs+dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev+dsEvTerm (EvLit (EvNum n))  = mkNaturalExpr n+dsEvTerm (EvLit (EvStr s))  = mkStringExprFS s++dsEvTerm (EvCast tm co)+  = do { tm' <- dsEvTerm tm+       ; return $ mkCastDs tm' co }++dsEvTerm (EvDFunApp df tys tms)+  = do { tms' <- mapM dsEvTerm tms+       ; return $ Var df `mkTyApps` tys `mkApps` tms' }+  -- The use of mkApps here is OK vis-a-vis levity polymorphism because+  -- the terms are always evidence variables with types of kind Constraint++dsEvTerm (EvCoercion co) = return (Coercion co)+dsEvTerm (EvSuperClass d n)+  = do { d' <- dsEvTerm d+       ; let (cls, tys) = getClassPredTys (exprType d')+             sc_sel_id  = classSCSelId cls n    -- Zero-indexed+       ; return $ Var sc_sel_id `mkTyApps` tys `App` d' }++dsEvTerm (EvSelector sel_id tys tms)+  = do { tms' <- mapM dsEvTerm tms+       ; return $ Var sel_id `mkTyApps` tys `mkApps` tms' }++dsEvTerm (EvDelayedError ty msg) = return $ dsEvDelayedError ty msg++dsEvDelayedError :: Type -> FastString -> CoreExpr+dsEvDelayedError ty msg+  = Var errorId `mkTyApps` [getRuntimeRep "dsEvTerm" ty, ty] `mkApps` [litMsg]+  where+    errorId = tYPE_ERROR_ID+    litMsg  = Lit (MachStr (fastStringToByteString msg))++{-**********************************************************************+*                                                                      *+           Desugaring Typeable dictionaries+*                                                                      *+**********************************************************************-}++dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr+-- Return a CoreExpr :: Typeable ty+-- This code is tightly coupled to the representation+-- of TypeRep, in base library Data.Typeable.Internals+dsEvTypeable ty ev+  = do { tyCl <- dsLookupTyCon typeableClassName    -- Typeable+       ; let kind = typeKind ty+             Just typeable_data_con+                 = tyConSingleDataCon_maybe tyCl    -- "Data constructor"+                                                    -- for Typeable++       ; rep_expr <- ds_ev_typeable ty ev           -- :: TypeRep a++       -- Package up the method as `Typeable` dictionary+       ; return $ mkConApp typeable_data_con [Type kind, Type ty, rep_expr] }++type TypeRepExpr = CoreExpr++-- | Returns a @CoreExpr :: TypeRep ty@+ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr+ds_ev_typeable ty (EvTypeableTyCon tc kind_ev)+  = do { mkTrCon <- dsLookupGlobalId mkTrConName+                    -- mkTrCon :: forall k (a :: k). TyCon -> TypeRep k -> TypeRep a+       ; someTypeRepTyCon <- dsLookupTyCon someTypeRepTyConName+       ; someTypeRepDataCon <- dsLookupDataCon someTypeRepDataConName+                    -- SomeTypeRep :: forall k (a :: k). TypeRep a -> SomeTypeRep++       ; tc_rep <- tyConRep tc                      -- :: TyCon+       ; let ks = tyConAppArgs ty+             -- Construct a SomeTypeRep+             toSomeTypeRep :: Type -> EvTerm -> DsM CoreExpr+             toSomeTypeRep t ev = do+                 rep <- getRep ev t+                 return $ mkCoreConApps someTypeRepDataCon [Type (typeKind t), Type t, rep]+       ; kind_arg_reps <- sequence $ zipWith toSomeTypeRep ks kind_ev   -- :: TypeRep t+       ; let -- :: [SomeTypeRep]+             kind_args = mkListExpr (mkTyConTy someTypeRepTyCon) kind_arg_reps++         -- Note that we use the kind of the type, not the TyCon from which it+         -- is constructed since the latter may be kind polymorphic whereas the+         -- former we know is not (we checked in the solver).+       ; return $ mkApps (Var mkTrCon) [ Type (typeKind ty)+                                       , Type ty+                                       , tc_rep+                                       , kind_args ]+       }++ds_ev_typeable ty (EvTypeableTyApp ev1 ev2)+  | Just (t1,t2) <- splitAppTy_maybe ty+  = do { e1  <- getRep ev1 t1+       ; e2  <- getRep ev2 t2+       ; mkTrApp <- dsLookupGlobalId mkTrAppName+                    -- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).+                    --            TypeRep a -> TypeRep b -> TypeRep (a b)+       ; let (k1, k2) = splitFunTy (typeKind t1)+       ; return $ mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ])+                         [ e1, e2 ] }++ds_ev_typeable ty (EvTypeableTrFun ev1 ev2)+  | Just (t1,t2) <- splitFunTy_maybe ty+  = do { e1 <- getRep ev1 t1+       ; e2 <- getRep ev2 t2+       ; mkTrFun <- dsLookupGlobalId mkTrFunName+                    -- mkTrFun :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2).+                    --            TypeRep a -> TypeRep b -> TypeRep (a -> b)+       ; let r1 = getRuntimeRep "ds_ev_typeable" t1+             r2 = getRuntimeRep "ds_ev_typeable" t2+       ; return $ mkApps (mkTyApps (Var mkTrFun) [r1, r2, t1, t2])+                         [ e1, e2 ]+       }++ds_ev_typeable ty (EvTypeableTyLit ev)+  = do { fun  <- dsLookupGlobalId tr_fun+       ; dict <- dsEvTerm ev       -- Of type KnownNat/KnownSym+       ; let proxy = mkTyApps (Var proxyHashId) [ty_kind, ty]+       ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict, proxy ]) }+  where+    ty_kind = typeKind ty++    -- tr_fun is the Name of+    --       typeNatTypeRep    :: KnownNat    a => Proxy# a -> TypeRep a+    -- of    typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep a+    tr_fun | ty_kind `eqType` typeNatKind    = typeNatTypeRepName+           | ty_kind `eqType` typeSymbolKind = typeSymbolTypeRepName+           | otherwise = panic "dsEvTypeable: unknown type lit kind"++ds_ev_typeable ty ev+  = pprPanic "dsEvTypeable" (ppr ty $$ ppr ev)++getRep :: EvTerm          -- ^ EvTerm for @Typeable ty@+       -> Type            -- ^ The type @ty@+       -> DsM TypeRepExpr -- ^ Return @CoreExpr :: TypeRep ty@+                          -- namely @typeRep# dict@+-- Remember that+--   typeRep# :: forall k (a::k). Typeable k a -> TypeRep a+getRep ev ty+  = do { typeable_expr <- dsEvTerm ev+       ; typeRepId     <- dsLookupGlobalId typeRepIdName+       ; let ty_args = [typeKind ty, ty]+       ; return (mkApps (mkTyApps (Var typeRepId) ty_args) [ typeable_expr ]) }++tyConRep :: TyCon -> DsM CoreExpr+-- Returns CoreExpr :: TyCon+tyConRep tc+  | Just tc_rep_nm <- tyConRepName_maybe tc+  = do { tc_rep_id <- dsLookupGlobalId tc_rep_nm+       ; return (Var tc_rep_id) }+  | otherwise+  = pprPanic "tyConRep" (ppr tc)++{- Note [Memoising typeOf]+~~~~~~~~~~~~~~~~~~~~~~~~~~+See #3245, #9203++IMPORTANT: we don't want to recalculate the TypeRep once per call with+the proxy argument.  This is what went wrong in #3245 and #9203. So we+help GHC by manually keeping the 'rep' *outside* the lambda.+-}+++{-**********************************************************************+*                                                                      *+           Desugaring EvCallStack evidence+*                                                                      *+**********************************************************************-}++dsEvCallStack :: EvCallStack -> DsM CoreExpr+-- See Note [Overview of implicit CallStacks] in TcEvidence.hs+dsEvCallStack cs = do+  df            <- getDynFlags+  m             <- getModule+  srcLocDataCon <- dsLookupDataCon srcLocDataConName+  let mkSrcLoc l =+        liftM (mkCoreConApps srcLocDataCon)+              (sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m)+                        , mkStringExprFS (moduleNameFS $ moduleName m)+                        , mkStringExprFS (srcSpanFile l)+                        , return $ mkIntExprInt df (srcSpanStartLine l)+                        , return $ mkIntExprInt df (srcSpanStartCol l)+                        , return $ mkIntExprInt df (srcSpanEndLine l)+                        , return $ mkIntExprInt df (srcSpanEndCol l)+                        ])++  emptyCS <- Var <$> dsLookupGlobalId emptyCallStackName++  pushCSVar <- dsLookupGlobalId pushCallStackName+  let pushCS name loc rest =+        mkCoreApps (Var pushCSVar) [mkCoreTup [name, loc], rest]++  let mkPush name loc tm = do+        nameExpr <- mkStringExprFS name+        locExpr <- mkSrcLoc loc+        case tm of+          EvCallStack EvCsEmpty -> return (pushCS nameExpr locExpr emptyCS)+          _ -> do tmExpr  <- dsEvTerm tm+                  -- at this point tmExpr :: IP sym CallStack+                  -- but we need the actual CallStack to pass to pushCS,+                  -- so we use unwrapIP to strip the dictionary wrapper+                  -- See Note [Overview of implicit CallStacks]+                  let ip_co = unwrapIP (exprType tmExpr)+                  return (pushCS nameExpr locExpr (mkCastDs tmExpr ip_co))+  case cs of+    EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm+    EvCsEmpty -> return emptyCS
+ deSugar/DsCCall.hs view
@@ -0,0 +1,377 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1994-1998+++Desugaring foreign calls+-}++{-# LANGUAGE CPP #-}+module DsCCall+        ( dsCCall+        , mkFCall+        , unboxArg+        , boxResult+        , resultWrapper+        ) where++#include "HsVersions.h"+++import CoreSyn++import DsMonad+import CoreUtils+import MkCore+import MkId+import ForeignCall+import DataCon+import DsUtils++import TcType+import Type+import Id   ( Id )+import Coercion+import PrimOp+import TysPrim+import TyCon+import TysWiredIn+import BasicTypes+import Literal+import PrelNames+import DynFlags+import Outputable+import Util++import Data.Maybe++{-+Desugaring of @ccall@s consists of adding some state manipulation,+unboxing any boxed primitive arguments and boxing the result if+desired.++The state stuff just consists of adding in+@PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place.++The unboxing is straightforward, as all information needed to unbox is+available from the type.  For each boxed-primitive argument, we+transform:+\begin{verbatim}+   _ccall_ foo [ r, t1, ... tm ] e1 ... em+   |+   |+   V+   case e1 of { T1# x1# ->+   ...+   case em of { Tm# xm# -> xm#+   ccall# foo [ r, t1#, ... tm# ] x1# ... xm#+   } ... }+\end{verbatim}++The reboxing of a @_ccall_@ result is a bit tricker: the types don't+contain information about the state-pairing functions so we have to+keep a list of \tr{(type, s-p-function)} pairs.  We transform as+follows:+\begin{verbatim}+   ccall# foo [ r, t1#, ... tm# ] e1# ... em#+   |+   |+   V+   \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of+          (StateAnd<r># result# state#) -> (R# result#, realWorld#)+\end{verbatim}+-}++dsCCall :: CLabelString -- C routine to invoke+        -> [CoreExpr]   -- Arguments (desugared)+                        -- Precondition: none have levity-polymorphic types+        -> Safety       -- Safety of the call+        -> Type         -- Type of the result: IO t+        -> DsM CoreExpr -- Result, of type ???++dsCCall lbl args may_gc result_ty+  = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args+       (ccall_result_ty, res_wrapper) <- boxResult result_ty+       uniq <- newUnique+       dflags <- getDynFlags+       let+           target = StaticTarget NoSourceText lbl Nothing True+           the_fcall    = CCall (CCallSpec target CCallConv may_gc)+           the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty+       return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)++mkFCall :: DynFlags -> Unique -> ForeignCall+        -> [CoreExpr]     -- Args+        -> Type           -- Result type+        -> CoreExpr+-- Construct the ccall.  The only tricky bit is that the ccall Id should have+-- no free vars, so if any of the arg tys do we must give it a polymorphic type.+--      [I forget *why* it should have no free vars!]+-- For example:+--      mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char]+--+-- Here we build a ccall thus+--      (ccallid::(forall a b.  StablePtr (a -> b) -> Addr -> Char -> IO Addr))+--                      a b s x c+mkFCall dflags uniq the_fcall val_args res_ty+  = ASSERT( all isTyVar tyvars )  -- this must be true because the type is top-level+    mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args+  where+    arg_tys = map exprType val_args+    body_ty = (mkFunTys arg_tys res_ty)+    tyvars  = tyCoVarsOfTypeWellScoped body_ty+    ty      = mkInvForAllTys tyvars body_ty+    the_fcall_id = mkFCallId dflags uniq the_fcall ty++unboxArg :: CoreExpr                    -- The supplied argument, not levity-polymorphic+         -> DsM (CoreExpr,              -- To pass as the actual argument+                 CoreExpr -> CoreExpr   -- Wrapper to unbox the arg+                )+-- Example: if the arg is e::Int, unboxArg will return+--      (x#::Int#, \W. case x of I# x# -> W)+-- where W is a CoreExpr that probably mentions x#++-- always returns a non-levity-polymorphic expression++unboxArg arg+  -- Primtive types: nothing to unbox+  | isPrimitiveType arg_ty+  = return (arg, \body -> body)++  -- Recursive newtypes+  | Just(co, _rep_ty) <- topNormaliseNewType_maybe arg_ty+  = unboxArg (mkCastDs arg co)++  -- Booleans+  | Just tc <- tyConAppTyCon_maybe arg_ty,+    tc `hasKey` boolTyConKey+  = do dflags <- getDynFlags+       prim_arg <- newSysLocalDs intPrimTy+       return (Var prim_arg,+              \ body -> Case (mkWildCase arg arg_ty intPrimTy+                                       [(DataAlt falseDataCon,[],mkIntLit dflags 0),+                                        (DataAlt trueDataCon, [],mkIntLit dflags 1)])+                                        -- In increasing tag order!+                             prim_arg+                             (exprType body)+                             [(DEFAULT,[],body)])++  -- Data types with a single constructor, which has a single, primitive-typed arg+  -- This deals with Int, Float etc; also Ptr, ForeignPtr+  | is_product_type && data_con_arity == 1+  = ASSERT2(isUnliftedType data_con_arg_ty1, pprType arg_ty)+                        -- Typechecker ensures this+    do case_bndr <- newSysLocalDs arg_ty+       prim_arg <- newSysLocalDs data_con_arg_ty1+       return (Var prim_arg,+               \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]+              )++  -- Byte-arrays, both mutable and otherwise; hack warning+  -- We're looking for values of type ByteArray, MutableByteArray+  --    data ByteArray          ix = ByteArray        ix ix ByteArray#+  --    data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)+  | is_product_type &&+    data_con_arity == 3 &&+    isJust maybe_arg3_tycon &&+    (arg3_tycon ==  byteArrayPrimTyCon ||+     arg3_tycon ==  mutableByteArrayPrimTyCon)+  = do case_bndr <- newSysLocalDs arg_ty+       vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys+       return (Var arr_cts_var,+               \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]+              )++  | otherwise+  = do l <- getSrcSpanDs+       pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)+  where+    arg_ty                                      = exprType arg+    maybe_product_type                          = splitDataProductType_maybe arg_ty+    is_product_type                             = isJust maybe_product_type+    Just (_, _, data_con, data_con_arg_tys)     = maybe_product_type+    data_con_arity                              = dataConSourceArity data_con+    (data_con_arg_ty1 : _)                      = data_con_arg_tys++    (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys+    maybe_arg3_tycon               = tyConAppTyCon_maybe data_con_arg_ty3+    Just arg3_tycon                = maybe_arg3_tycon++boxResult :: Type+          -> DsM (Type, CoreExpr -> CoreExpr)++-- Takes the result of the user-level ccall:+--      either (IO t),+--      or maybe just t for an side-effect-free call+-- Returns a wrapper for the primitive ccall itself, along with the+-- type of the result of the primitive ccall.  This result type+-- will be of the form+--      State# RealWorld -> (# State# RealWorld, t' #)+-- where t' is the unwrapped form of t.  If t is simply (), then+-- the result type will be+--      State# RealWorld -> (# State# RealWorld #)++boxResult result_ty+  | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty+        -- isIOType_maybe handles the case where the type is a+        -- simple wrapping of IO.  E.g.+        --      newtype Wrap a = W (IO a)+        -- No coercion necessary because its a non-recursive newtype+        -- (If we wanted to handle a *recursive* newtype too, we'd need+        -- another case, and a coercion.)+        -- The result is IO t, so wrap the result in an IO constructor+  = do  { res <- resultWrapper io_res_ty+        ; let extra_result_tys+                = case res of+                     (Just ty,_)+                       | isUnboxedTupleType ty+                       -> let Just ls = tyConAppArgs_maybe ty in tail ls+                     _ -> []++              return_result state anss+                = mkCoreUbxTup+                    (realWorldStatePrimTy : io_res_ty : extra_result_tys)+                    (state : anss)++        ; (ccall_res_ty, the_alt) <- mk_alt return_result res++        ; state_id <- newSysLocalDs realWorldStatePrimTy+        ; let io_data_con = head (tyConDataCons io_tycon)+              toIOCon     = dataConWrapId io_data_con++              wrap the_call =+                              mkApps (Var toIOCon)+                                     [ Type io_res_ty,+                                       Lam state_id $+                                       mkWildCase (App the_call (Var state_id))+                                             ccall_res_ty+                                             (coreAltType the_alt)+                                             [the_alt]+                                     ]++        ; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) }++boxResult result_ty+  = do -- It isn't IO, so do unsafePerformIO+       -- It's not conveniently available, so we inline it+       res <- resultWrapper result_ty+       (ccall_res_ty, the_alt) <- mk_alt return_result res+       let+           wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId))+                                           ccall_res_ty+                                           (coreAltType the_alt)+                                           [the_alt]+       return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)+  where+    return_result _ [ans] = ans+    return_result _ _     = panic "return_result: expected single result"+++mk_alt :: (Expr Var -> [Expr Var] -> Expr Var)+       -> (Maybe Type, Expr Var -> Expr Var)+       -> DsM (Type, (AltCon, [Id], Expr Var))+mk_alt return_result (Nothing, wrap_result)+  = do -- The ccall returns ()+       state_id <- newSysLocalDs realWorldStatePrimTy+       let+             the_rhs = return_result (Var state_id)+                                     [wrap_result (panic "boxResult")]++             ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy]+             the_alt      = (DataAlt (tupleDataCon Unboxed 1), [state_id], the_rhs)++       return (ccall_res_ty, the_alt)++mk_alt return_result (Just prim_res_ty, wrap_result)+  = -- The ccall returns a non-() value+    ASSERT2( isPrimitiveType prim_res_ty, ppr prim_res_ty )+             -- True because resultWrapper ensures it is so+    do { result_id <- newSysLocalDs prim_res_ty+       ; state_id <- newSysLocalDs realWorldStatePrimTy+       ; let the_rhs = return_result (Var state_id)+                                [wrap_result (Var result_id)]+             ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty]+             the_alt      = (DataAlt (tupleDataCon Unboxed 2), [state_id, result_id], the_rhs)+       ; return (ccall_res_ty, the_alt) }+++resultWrapper :: Type+              -> DsM (Maybe Type,               -- Type of the expected result, if any+                      CoreExpr -> CoreExpr)     -- Wrapper for the result+-- resultWrapper deals with the result *value*+-- E.g. foreign import foo :: Int -> IO T+-- Then resultWrapper deals with marshalling the 'T' part+-- So if    resultWrapper ty = (Just ty_rep, marshal)+--  then      marshal (e :: ty_rep) :: ty+-- That is, 'marshal' wrape the result returned by the foreign call,+-- of type ty_rep, into the value Haskell expected, of type 'ty'+--+-- Invariant: ty_rep is always a primitive type+--            i.e. (isPrimitiveType ty_rep) is True++resultWrapper result_ty+  -- Base case 1: primitive types+  | isPrimitiveType result_ty+  = return (Just result_ty, \e -> e)++  -- Base case 2: the unit type ()+  | Just (tc,_) <- maybe_tc_app+  , tc `hasKey` unitTyConKey+  = return (Nothing, \_ -> Var unitDataConId)++  -- Base case 3: the boolean type+  | Just (tc,_) <- maybe_tc_app+  , tc `hasKey` boolTyConKey+  = do { dflags <- getDynFlags+       ; let marshal_bool e+               = mkWildCase e intPrimTy boolTy+                   [ (DEFAULT                    ,[],Var trueDataConId )+                   , (LitAlt (mkMachInt dflags 0),[],Var falseDataConId)]+       ; return (Just intPrimTy, marshal_bool) }++  -- Newtypes+  | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty+  = do { (maybe_ty, wrapper) <- resultWrapper rep_ty+       ; return (maybe_ty, \e -> mkCastDs (wrapper e) (mkSymCo co)) }++  -- The type might contain foralls (eg. for dummy type arguments,+  -- referring to 'Ptr a' is legal).+  | Just (tyvar, rest) <- splitForAllTy_maybe result_ty+  = do { (maybe_ty, wrapper) <- resultWrapper rest+       ; return (maybe_ty, \e -> Lam tyvar (wrapper e)) }++  -- Data types with a single constructor, which has a single arg+  -- This includes types like Ptr and ForeignPtr+  | Just (tycon, tycon_arg_tys) <- maybe_tc_app+  , Just data_con <- isDataProductTyCon_maybe tycon  -- One construtor, no existentials+  , [unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys  -- One argument+  = do { dflags <- getDynFlags+       ; (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty+       ; let narrow_wrapper = maybeNarrow dflags tycon+             marshal_con e  = Var (dataConWrapId data_con)+                              `mkTyApps` tycon_arg_tys+                              `App` wrapper (narrow_wrapper e)+       ; return (maybe_ty, marshal_con) }++  | otherwise+  = pprPanic "resultWrapper" (ppr result_ty)+  where+    maybe_tc_app = splitTyConApp_maybe result_ty++-- When the result of a foreign call is smaller than the word size, we+-- need to sign- or zero-extend the result up to the word size.  The C+-- standard appears to say that this is the responsibility of the+-- caller, not the callee.++maybeNarrow :: DynFlags -> TyCon -> (CoreExpr -> CoreExpr)+maybeNarrow dflags tycon+  | tycon `hasKey` int8TyConKey   = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e+  | tycon `hasKey` int16TyConKey  = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e+  | tycon `hasKey` int32TyConKey+         && wORD_SIZE dflags > 4         = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e++  | tycon `hasKey` word8TyConKey  = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e+  | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e+  | tycon `hasKey` word32TyConKey+         && wORD_SIZE dflags > 4         = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e+  | otherwise                     = id
+ deSugar/DsExpr.hs view
@@ -0,0 +1,1066 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Desugaring exporessions.+-}++{-# LANGUAGE CPP, MultiWayIf #-}++module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds+              , dsValBinds, dsLit, dsSyntaxExpr ) where++#include "HsVersions.h"++import Match+import MatchLit+import DsBinds+import DsGRHSs+import DsListComp+import DsUtils+import DsArrows+import DsMonad+import Name+import NameEnv+import FamInstEnv( topNormaliseType )+import DsMeta+import HsSyn++-- NB: The desugarer, which straddles the source and Core worlds, sometimes+--     needs to see source types+import TcType+import TcEvidence+import TcRnMonad+import TcHsSyn+import Type+import CoreSyn+import CoreUtils+import MkCore++import DynFlags+import CostCentre+import Id+import MkId+import Module+import ConLike+import DataCon+import TysWiredIn+import PrelNames+import BasicTypes+import Maybes+import VarEnv+import SrcLoc+import Util+import Bag+import Outputable+import PatSyn++import Control.Monad++{-+************************************************************************+*                                                                      *+                dsLocalBinds, dsValBinds+*                                                                      *+************************************************************************+-}++dsLocalBinds :: LHsLocalBinds Id -> CoreExpr -> DsM CoreExpr+dsLocalBinds (L _   EmptyLocalBinds)    body = return body+dsLocalBinds (L loc (HsValBinds binds)) body = putSrcSpanDs loc $+                                               dsValBinds binds body+dsLocalBinds (L _ (HsIPBinds binds))    body = dsIPBinds  binds body++-------------------------+-- caller sets location+dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr+dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds+dsValBinds (ValBindsIn {})       _    = panic "dsValBinds ValBindsIn"++-------------------------+dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr+dsIPBinds (IPBinds ip_binds ev_binds) body+  = do  { ds_binds <- dsTcEvBinds ev_binds+        ; let inner = mkCoreLets ds_binds body+                -- The dict bindings may not be in+                -- dependency order; hence Rec+        ; foldrM ds_ip_bind inner ip_binds }+  where+    ds_ip_bind (L _ (IPBind ~(Right n) e)) body+      = do e' <- dsLExpr e+           return (Let (NonRec n e') body)++-------------------------+-- caller sets location+ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr+-- Special case for bindings which bind unlifted variables+-- We need to do a case right away, rather than building+-- a tuple and doing selections.+-- Silently ignore INLINE and SPECIALISE pragmas...+ds_val_bind (NonRecursive, hsbinds) body+  | [L loc bind] <- bagToList hsbinds+        -- Non-recursive, non-overloaded bindings only come in ones+        -- ToDo: in some bizarre case it's conceivable that there+        --       could be dict binds in the 'binds'.  (See the notes+        --       below.  Then pattern-match would fail.  Urk.)+  , isUnliftedHsBind bind+  = putSrcSpanDs loc $+     -- see Note [Strict binds checks] in DsBinds+    if is_polymorphic bind+    then errDsCoreExpr (poly_bind_err bind)+            -- data Ptr a = Ptr Addr#+            -- f x = let p@(Ptr y) = ... in ...+            -- Here the binding for 'p' is polymorphic, but does+            -- not mix with an unlifted binding for 'y'.  You should+            -- use a bang pattern.  Trac #6078.++    else do { when (looksLazyPatBind bind) $+              warnIfSetDs Opt_WarnUnbangedStrictPatterns (unlifted_must_be_bang bind)+        -- Complain about a binding that looks lazy+        --    e.g.    let I# y = x in ...+        -- Remember, in checkStrictBinds we are going to do strict+        -- matching, so (for software engineering reasons) we insist+        -- that the strictness is manifest on each binding+        -- However, lone (unboxed) variables are ok+++            ; dsUnliftedBind bind body }+  where+    is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs })+                     = not (null tvs && null evs)+    is_polymorphic (AbsBindsSig { abs_tvs = tvs, abs_ev_vars = evs })+                     = not (null tvs && null evs)+    is_polymorphic _ = False++    unlifted_must_be_bang bind+      = hang (text "Pattern bindings containing unlifted types should use" $$+              text "an outermost bang pattern:")+           2 (ppr bind)++    poly_bind_err bind+      = hang (text "You can't mix polymorphic and unlifted bindings:")+           2 (ppr bind) $$+        text "Probable fix: add a type signature"++ds_val_bind (is_rec, binds) _body+  | anyBag (isUnliftedHsBind . unLoc) binds  -- see Note [Strict binds checks] in DsBinds+  = ASSERT( isRec is_rec )+    errDsCoreExpr $+    hang (text "Recursive bindings for unlifted types aren't allowed:")+       2 (vcat (map ppr (bagToList binds)))++-- Ordinary case for bindings; none should be unlifted+ds_val_bind (is_rec, binds) body+  = do  { MASSERT( isRec is_rec || isSingletonBag binds )+               -- we should never produce a non-recursive list of multiple binds++        ; (force_vars,prs) <- dsLHsBinds binds+        ; let body' = foldr seqVar body force_vars+        ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr is_rec $$ ppr binds )+          case prs of+            [] -> return body+            _  -> return (Let (Rec prs) body') }+        -- Use a Rec regardless of is_rec.+        -- Why? Because it allows the binds to be all+        -- mixed up, which is what happens in one rare case+        -- Namely, for an AbsBind with no tyvars and no dicts,+        --         but which does have dictionary bindings.+        -- See notes with TcSimplify.inferLoop [NO TYVARS]+        -- It turned out that wrapping a Rec here was the easiest solution+        --+        -- NB The previous case dealt with unlifted bindings, so we+        --    only have to deal with lifted ones now; so Rec is ok++------------------+dsUnliftedBind :: HsBind Id -> CoreExpr -> DsM CoreExpr+dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []+               , abs_exports = exports+               , abs_ev_binds = ev_binds+               , abs_binds = lbinds }) body+  = do { let body1 = foldr bind_export body exports+             bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b+       ; body2 <- foldlBagM (\body lbind -> dsUnliftedBind (unLoc lbind) body)+                            body1 lbinds+       ; ds_binds <- dsTcEvBinds_s ev_binds+       ; return (mkCoreLets ds_binds body2) }++dsUnliftedBind (AbsBindsSig { abs_tvs         = []+                            , abs_ev_vars     = []+                            , abs_sig_export  = poly+                            , abs_sig_ev_bind = ev_bind+                            , abs_sig_bind    = L _ bind }) body+  = do { ds_binds <- dsTcEvBinds ev_bind+       ; body' <- dsUnliftedBind (bind { fun_id = noLoc poly }) body+       ; return (mkCoreLets ds_binds body') }++dsUnliftedBind (FunBind { fun_id = L l fun+                        , fun_matches = matches+                        , fun_co_fn = co_fn+                        , fun_tick = tick }) body+               -- Can't be a bang pattern (that looks like a PatBind)+               -- so must be simply unboxed+  = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun))+                                     Nothing matches+       ; MASSERT( null args ) -- Functions aren't lifted+       ; MASSERT( isIdHsWrapper co_fn )+       ; let rhs' = mkOptTickBox tick rhs+       ; return (bindNonRec fun rhs' body) }++dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body+  =     -- let C x# y# = rhs in body+        -- ==> case rhs of C x# y# -> body+    do { rhs <- dsGuarded grhss ty+       ; let upat = unLoc pat+             eqn = EqnInfo { eqn_pats = [upat],+                             eqn_rhs = cantFailMatchResult body }+       ; var    <- selectMatchVar upat+       ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)+       ; return (bindNonRec var rhs result) }++dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)++{-+************************************************************************+*                                                                      *+\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}+*                                                                      *+************************************************************************+-}++dsLExpr :: LHsExpr Id -> DsM CoreExpr++dsLExpr (L loc e)+  = putSrcSpanDs loc $+    do { core_expr <- dsExpr e+   -- uncomment this check to test the hsExprType function in TcHsSyn+   --    ; MASSERT2( exprType core_expr `eqType` hsExprType e+   --              , ppr e <+> dcolon <+> ppr (hsExprType e) $$+   --                ppr core_expr <+> dcolon <+> ppr (exprType core_expr) )+       ; return core_expr }++-- | Variant of 'dsLExpr' that ensures that the result is not levity+-- polymorphic. This should be used when the resulting expression will+-- be an argument to some other function.+-- See Note [Levity polymorphism checking] in DsMonad+-- See Note [Levity polymorphism invariants] in CoreSyn+dsLExprNoLP :: LHsExpr Id -> DsM CoreExpr+dsLExprNoLP (L loc e)+  = putSrcSpanDs loc $+    do { e' <- dsExpr e+       ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e)+       ; return e' }++dsExpr :: HsExpr Id -> DsM CoreExpr+dsExpr (HsPar e)              = dsLExpr e+dsExpr (ExprWithTySigOut e _) = dsLExpr e+dsExpr (HsVar (L _ var))      = return (varToCoreExpr var)+                                -- See Note [Desugaring vars]+dsExpr (HsUnboundVar {})      = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them+dsExpr (HsConLikeOut con)     = return (dsConLike con)+dsExpr (HsIPVar _)            = panic "dsExpr: HsIPVar"+dsExpr (HsOverLabel{})        = panic "dsExpr: HsOverLabel"+dsExpr (HsLit lit)            = dsLit lit+dsExpr (HsOverLit lit)        = dsOverLit lit++dsExpr (HsWrap co_fn e)+  = do { e' <- dsExpr e+       ; wrap' <- dsHsWrapper co_fn+       ; dflags <- getDynFlags+       ; let wrapped_e = wrap' e'+       ; warnAboutIdentities dflags e' (exprType wrapped_e)+       ; return wrapped_e }++dsExpr (NegApp (L loc (HsOverLit lit@(OverLit { ol_val = HsIntegral src i })))+                neg_expr)+  = do { expr' <- putSrcSpanDs loc $ do+          { dflags <- getDynFlags+          ; warnAboutOverflowedLiterals dflags+                                        (lit { ol_val = HsIntegral src (-i) })+          ; dsOverLit' dflags lit }+       ; dsSyntaxExpr neg_expr [expr'] }++dsExpr (NegApp expr neg_expr)+  = do { expr' <- dsLExpr expr+       ; dsSyntaxExpr neg_expr [expr'] }++dsExpr (HsLam a_Match)+  = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match++dsExpr (HsLamCase matches)+  = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches+       ; return $ Lam discrim_var matching_code }++dsExpr e@(HsApp fun arg)+  = do { fun' <- dsLExpr fun+       ; dsWhenNoErrs (dsLExprNoLP arg)+                      (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') }++dsExpr (HsAppTypeOut e _)+    -- ignore type arguments here; they're in the wrappers instead at this point+  = dsLExpr e+++{-+Note [Desugaring vars]+~~~~~~~~~~~~~~~~~~~~~~+In one situation we can get a *coercion* variable in a HsVar, namely+the support method for an equality superclass:+   class (a~b) => C a b where ...+   instance (blah) => C (T a) (T b) where ..+Then we get+   $dfCT :: forall ab. blah => C (T a) (T b)+   $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah)++   $c$p1C :: forall ab. blah => (T a ~ T b)+   $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g++That 'g' in the 'in' part is an evidence variable, and when+converting to core it must become a CO.++Operator sections.  At first it looks as if we can convert+\begin{verbatim}+        (expr op)+\end{verbatim}+to+\begin{verbatim}+        \x -> op expr x+\end{verbatim}++But no!  expr might be a redex, and we can lose laziness badly this+way.  Consider+\begin{verbatim}+        map (expr op) xs+\end{verbatim}+for example.  So we convert instead to+\begin{verbatim}+        let y = expr in \x -> op y x+\end{verbatim}+If \tr{expr} is actually just a variable, say, then the simplifier+will sort it out.+-}++dsExpr e@(OpApp e1 op _ e2)+  = -- for the type of y, we need the type of op's 2nd argument+    do { op' <- dsLExpr op+       ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2])+                      (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') }++dsExpr (SectionL expr op)       -- Desugar (e !) to ((!) e)+  = do { op' <- dsLExpr op+       ; dsWhenNoErrs (dsLExprNoLP expr)+                      (\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') }++-- dsLExpr (SectionR op expr)   -- \ x -> op x expr+dsExpr e@(SectionR op expr) = do+    core_op <- dsLExpr op+    -- for the type of x, we need the type of op's 2nd argument+    let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)+        -- See comment with SectionL+    y_core <- dsLExpr expr+    dsWhenNoErrs (mapM newSysLocalDsNoLP [x_ty, y_ty])+                 (\[x_id, y_id] -> bindNonRec y_id y_core $+                                   Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e)+                                                          core_op [Var x_id, Var y_id]))++dsExpr (ExplicitTuple tup_args boxity)+  = do { let go (lam_vars, args) (L _ (Missing ty))+                    -- For every missing expression, we need+                    -- another lambda in the desugaring.+               = do { lam_var <- newSysLocalDsNoLP ty+                    ; return (lam_var : lam_vars, Var lam_var : args) }+             go (lam_vars, args) (L _ (Present expr))+                    -- Expressions that are present don't generate+                    -- lambdas, just arguments.+               = do { core_expr <- 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 }++dsExpr (ExplicitSum alt arity expr types)+  = do { core_expr <- dsLExpr expr+       ; return $ mkCoreConApps (sumDataCon alt arity)+                                (map (Type . getRuntimeRep "dsExpr ExplicitSum") types +++                                 map Type types +++                                 [core_expr]) }++dsExpr (HsSCC _ cc expr@(L loc _)) = do+    dflags <- getDynFlags+    if gopt Opt_SccProfilingOn dflags+      then do+        mod_name <- getModule+        count <- goptM Opt_ProfCountEntries+        uniq <- newUnique+        Tick (ProfNote (mkUserCC (sl_fs cc) mod_name loc uniq) count True)+               <$> dsLExpr expr+      else dsLExpr expr++dsExpr (HsCoreAnn _ _ expr)+  = dsLExpr expr++dsExpr (HsCase discrim matches)+  = do { core_discrim <- dsLExpr discrim+       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches+       ; return (bindNonRec discrim_var core_discrim matching_code) }++-- Pepe: The binds are in scope in the body but NOT in the binding group+--       This is to avoid silliness in breakpoints+dsExpr (HsLet binds body) = do+    body' <- dsLExpr body+    dsLocalBinds binds body'++-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)+-- because the interpretation of `stmts' depends on what sort of thing it is.+--+dsExpr (HsDo ListComp     (L _ stmts) res_ty) = dsListComp stmts res_ty+dsExpr (HsDo PArrComp     (L _ stmts) _)      = dsPArrComp (map unLoc stmts)+dsExpr (HsDo DoExpr       (L _ stmts) _)      = dsDo stmts+dsExpr (HsDo GhciStmtCtxt (L _ stmts) _)      = dsDo stmts+dsExpr (HsDo MDoExpr      (L _ stmts) _)      = dsDo stmts+dsExpr (HsDo MonadComp    (L _ stmts) _)      = dsMonadComp stmts++dsExpr (HsIf mb_fun guard_expr then_expr else_expr)+  = do { pred <- dsLExpr guard_expr+       ; b1 <- dsLExpr then_expr+       ; b2 <- dsLExpr else_expr+       ; case mb_fun of+           Just fun -> dsSyntaxExpr fun [pred, b1, b2]+           Nothing  -> return $ mkIfThenElse pred b1 b2 }++dsExpr (HsMultiIf res_ty alts)+  | null alts+  = mkErrorExpr++  | otherwise+  = do { match_result <- liftM (foldr1 combineMatchResults)+                               (mapM (dsGRHS IfAlt res_ty) alts)+       ; error_expr   <- mkErrorExpr+       ; extractMatchResult match_result error_expr }+  where+    mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty+                               (text "multi-way if")++{-+\noindent+\underline{\bf Various data construction things}+             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-}++dsExpr (ExplicitList elt_ty wit xs)+  = dsExplicitList elt_ty wit xs++-- We desugar [:x1, ..., xn:] as+--   singletonP x1 +:+ ... +:+ singletonP xn+--+dsExpr (ExplicitPArr ty []) = do+    emptyP <- dsDPHBuiltin emptyPVar+    return (Var emptyP `App` Type ty)+dsExpr (ExplicitPArr ty xs) = do+    singletonP <- dsDPHBuiltin singletonPVar+    appP       <- dsDPHBuiltin appPVar+    xs'        <- mapM dsLExprNoLP xs+    let unary  fn x   = mkApps (Var fn) [Type ty, x]+        binary fn x y = mkApps (Var fn) [Type ty, x, y]++    return . foldr1 (binary appP) $ map (unary singletonP) xs'++dsExpr (ArithSeq expr witness seq)+  = case witness of+     Nothing -> dsArithSeq expr seq+     Just fl -> do { newArithSeq <- dsArithSeq expr seq+                   ; dsSyntaxExpr fl [newArithSeq] }++dsExpr (PArrSeq expr (FromTo from to))+  = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, to]++dsExpr (PArrSeq expr (FromThenTo from thn to))+  = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn, to]++dsExpr (PArrSeq _ _)+  = panic "DsExpr.dsExpr: Infinite parallel array!"+    -- the parser shouldn't have generated it and the renamer and typechecker+    -- shouldn't have let it through++{-+Static Pointers+~~~~~~~~~~~~~~~++See Note [Grand plan for static forms] in StaticPtrTable for an overview.++    g = ... static f ...+==>+    g = ... makeStatic loc f ...+-}++dsExpr (HsStatic _ expr@(L loc _)) = do+    expr_ds <- dsLExprNoLP expr+    let ty = exprType expr_ds+    makeStaticId <- dsLookupGlobalId makeStaticName++    dflags <- getDynFlags+    let (line, col) = case loc of+           RealSrcSpan r -> ( srcLocLine $ realSrcSpanStart r+                            , srcLocCol  $ realSrcSpanStart r+                            )+           _             -> (0, 0)+        srcLoc = mkCoreConApps (tupleDataCon Boxed 2)+                     [ Type intTy              , Type intTy+                     , mkIntExprInt dflags line, mkIntExprInt dflags col+                     ]++    putSrcSpanDs loc $ return $+      mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ]++{-+\noindent+\underline{\bf Record construction and update}+             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For record construction we do this (assuming T has three arguments)+\begin{verbatim}+        T { op2 = e }+==>+        let err = /\a -> recConErr a+        T (recConErr t1 "M.hs/230/op1")+          e+          (recConErr t1 "M.hs/230/op3")+\end{verbatim}+@recConErr@ then converts its argument string into a proper message+before printing it as+\begin{verbatim}+        M.hs, line 230: missing field op1 was evaluated+\end{verbatim}++We also handle @C{}@ as valid construction syntax for an unlabelled+constructor @C@, setting all of @C@'s fields to bottom.+-}++dsExpr (RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds+                  , rcon_con_like = con_like })+  = do { con_expr' <- dsExpr con_expr+       ; let+             (arg_tys, _) = tcSplitFunTys (exprType con_expr')+             -- A newtype in the corner should be opaque;+             -- hence TcType.tcSplitFunTys++             mk_arg (arg_ty, fl)+               = case findField (rec_flds rbinds) (flSelector fl) of+                   (rhs:rhss) -> ASSERT( null rhss )+                                 dsLExprNoLP rhs+                   []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl))+             unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty++             labels = conLikeFieldLabels con_like++       ; con_args <- if null labels+                     then mapM unlabelled_bottom arg_tys+                     else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)++       ; return (mkCoreApps con_expr' con_args) }++{-+Record update is a little harder. Suppose we have the decl:+\begin{verbatim}+        data T = T1 {op1, op2, op3 :: Int}+               | T2 {op4, op2 :: Int}+               | T3+\end{verbatim}+Then we translate as follows:+\begin{verbatim}+        r { op2 = e }+===>+        let op2 = e in+        case r of+          T1 op1 _ op3 -> T1 op1 op2 op3+          T2 op4 _     -> T2 op4 op2+          other        -> recUpdError "M.hs/230"+\end{verbatim}+It's important that we use the constructor Ids for @T1@, @T2@ etc on the+RHSs, and do not generate a Core constructor application directly, because the constructor+might do some argument-evaluation first; and may have to throw away some+dictionaries.++Note [Update for GADTs]+~~~~~~~~~~~~~~~~~~~~~~~+Consider+   data T a b where+     T1 :: { f1 :: a } -> T a Int++Then the wrapper function for T1 has type+   $WT1 :: a -> T a Int+But if x::T a b, then+   x { f1 = v } :: T a b   (not T a Int!)+So we need to cast (T a Int) to (T a b).  Sigh.++-}++dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields+                       , rupd_cons = cons_to_upd+                       , rupd_in_tys = in_inst_tys, rupd_out_tys = out_inst_tys+                       , rupd_wrap = dict_req_wrap } )+  | null fields+  = dsLExpr record_expr+  | otherwise+  = ASSERT2( notNull cons_to_upd, ppr expr )++    do  { record_expr' <- dsLExpr record_expr+        ; field_binds' <- mapM ds_field fields+        ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding+              upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']++        -- It's important to generate the match with matchWrapper,+        -- and the right hand sides with applications of the wrapper Id+        -- so that everything works when we are doing fancy unboxing on the+        -- constructor arguments.+        ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd+        ; ([discrim_var], matching_code)+                <- matchWrapper RecUpd Nothing (MG { mg_alts = noLoc alts+                                                   , mg_arg_tys = [in_ty]+                                                   , mg_res_ty = out_ty, mg_origin = FromSource })+                                                   -- FromSource is not strictly right, but we+                                                   -- want incomplete pattern-match warnings++        ; return (add_field_binds field_binds' $+                  bindNonRec discrim_var record_expr' matching_code) }+  where+    ds_field :: LHsRecUpdField Id -> DsM (Name, Id, CoreExpr)+      -- Clone the Id in the HsRecField, because its Name is that+      -- of the record selector, and we must not make that a local binder+      -- else we shadow other uses of the record selector+      -- Hence 'lcl_id'.  Cf Trac #2735+    ds_field (L _ rec_field) = do { rhs <- dsLExpr (hsRecFieldArg rec_field)+                                  ; let fld_id = unLoc (hsRecUpdFieldId rec_field)+                                  ; lcl_id <- newSysLocalDs (idType fld_id)+                                  ; return (idName fld_id, lcl_id, rhs) }++    add_field_binds [] expr = expr+    add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)++        -- Awkwardly, for families, the match goes+        -- from instance type to family type+    (in_ty, out_ty) =+      case (head cons_to_upd) of+        RealDataCon data_con ->+          let tycon = dataConTyCon data_con in+          (mkTyConApp tycon in_inst_tys, mkFamilyTyConApp tycon out_inst_tys)+        PatSynCon pat_syn ->+          ( patSynInstResTy pat_syn in_inst_tys+          , patSynInstResTy pat_syn out_inst_tys)+    mk_alt upd_fld_env con+      = do { let (univ_tvs, ex_tvs, eq_spec,+                  prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con+                 subst = zipTvSubst univ_tvs in_inst_tys++                -- I'm not bothering to clone the ex_tvs+           ; eqs_vars   <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))+           ; theta_vars <- mapM newPredVarDs (substTheta subst prov_theta)+           ; arg_ids    <- newSysLocalsDs (substTysUnchecked subst arg_tys)+           ; let field_labels = conLikeFieldLabels con+                 val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg+                                         field_labels arg_ids+                 mk_val_arg fl pat_arg_id+                     = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id)++                 inst_con = noLoc $ HsWrap wrap (HsConLikeOut con)+                        -- Reconstruct with the WrapId so that unpacking happens+                 -- The order here is because of the order in `TcPatSyn`.+                 wrap = mkWpEvVarApps theta_vars                                <.>+                        dict_req_wrap                                           <.>+                        mkWpTyApps    (mkTyVarTys ex_tvs)                       <.>+                        mkWpTyApps    [ ty+                                      | (tv, ty) <- univ_tvs `zip` out_inst_tys+                                      , not (tv `elemVarEnv` wrap_subst) ]+                 rhs = foldl (\a b -> nlHsApp a b) inst_con val_args++                        -- Tediously wrap the application in a cast+                        -- Note [Update for GADTs]+                 wrapped_rhs =+                  case con of+                    RealDataCon data_con ->+                      let+                        wrap_co =+                          mkTcTyConAppCo Nominal+                            (dataConTyCon data_con)+                            [ lookup tv ty+                              | (tv,ty) <- univ_tvs `zip` out_inst_tys ]+                        lookup univ_tv ty =+                          case lookupVarEnv wrap_subst univ_tv of+                            Just co' -> co'+                            Nothing  -> mkTcReflCo Nominal ty+                        in if null eq_spec+                             then rhs+                             else mkLHsWrap (mkWpCastN wrap_co) rhs+                    -- eq_spec is always null for a PatSynCon+                    PatSynCon _ -> rhs++                 wrap_subst =+                  mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var))+                           | (spec, eq_var) <- eq_spec `zip` eqs_vars+                           , let tv = eqSpecTyVar spec ]++                 req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys++                 pat = noLoc $ ConPatOut { pat_con = noLoc con+                                         , pat_tvs = ex_tvs+                                         , pat_dicts = eqs_vars ++ theta_vars+                                         , pat_binds = emptyTcEvBinds+                                         , pat_args = PrefixCon $ map nlVarPat arg_ids+                                         , pat_arg_tys = in_inst_tys+                                         , pat_wrap = req_wrap }+           ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) }++-- Here is where we desugar the Template Haskell brackets and escapes++-- Template Haskell stuff++dsExpr (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut"+dsExpr (HsTcBracketOut x ps) = dsBracket x ps+dsExpr (HsSpliceE s)  = pprPanic "dsExpr:splice" (ppr s)++-- Arrow notation extension+dsExpr (HsProc pat cmd) = dsProcExpr pat cmd++-- Hpc Support++dsExpr (HsTick tickish e) = do+  e' <- dsLExpr e+  return (Tick tickish e')++-- There is a problem here. The then and else branches+-- have no free variables, so they are open to lifting.+-- We need someway of stopping this.+-- This will make no difference to binary coverage+-- (did you go here: YES or NO), but will effect accurate+-- tick counting.++dsExpr (HsBinTick ixT ixF e) = do+  e2 <- dsLExpr e+  do { ASSERT(exprType e2 `eqType` boolTy)+       mkBinaryTickBox ixT ixF e2+     }++dsExpr (HsTickPragma _ _ _ expr) = do+  dflags <- getDynFlags+  if gopt Opt_Hpc dflags+    then panic "dsExpr:HsTickPragma"+    else dsLExpr expr++-- HsSyn constructs that just shouldn't be here:+dsExpr (ExprWithTySig {})  = panic "dsExpr:ExprWithTySig"+dsExpr (HsBracket     {})  = panic "dsExpr:HsBracket"+dsExpr (HsArrApp      {})  = panic "dsExpr:HsArrApp"+dsExpr (HsArrForm     {})  = panic "dsExpr:HsArrForm"+dsExpr (EWildPat      {})  = panic "dsExpr:EWildPat"+dsExpr (EAsPat        {})  = panic "dsExpr:EAsPat"+dsExpr (EViewPat      {})  = panic "dsExpr:EViewPat"+dsExpr (ELazyPat      {})  = panic "dsExpr:ELazyPat"+dsExpr (HsAppType     {})  = panic "dsExpr:HsAppType" -- removed by typechecker+dsExpr (HsDo          {})  = panic "dsExpr:HsDo"+dsExpr (HsRecFld      {})  = panic "dsExpr:HsRecFld"++------------------------------+dsSyntaxExpr :: SyntaxExpr Id -> [CoreExpr] -> DsM CoreExpr+dsSyntaxExpr (SyntaxExpr { syn_expr      = expr+                         , syn_arg_wraps = arg_wraps+                         , syn_res_wrap  = res_wrap })+             arg_exprs+  = do { fun            <- dsExpr expr+       ; core_arg_wraps <- mapM dsHsWrapper arg_wraps+       ; core_res_wrap  <- dsHsWrapper res_wrap+       ; let wrapped_args = zipWith ($) core_arg_wraps arg_exprs+       ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ])+                      (\_ -> core_res_wrap (mkApps fun wrapped_args)) }+  where+    mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr)++findField :: [LHsRecField Id arg] -> Name -> [arg]+findField rbinds sel+  = [hsRecFieldArg fld | L _ fld <- rbinds+                       , sel == idName (unLoc $ hsRecFieldId fld) ]++{-+%--------------------------------------------------------------------++Note [Desugaring explicit lists]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Explicit lists are desugared in a cleverer way to prevent some+fruitless allocations.  Essentially, whenever we see a list literal+[x_1, ..., x_n] we generate the corresponding expression in terms of+build:++Explicit lists (literals) are desugared to allow build/foldr fusion when+beneficial. This is a bit of a trade-off,++ * build/foldr fusion can generate far larger code than the corresponding+   cons-chain (e.g. see #11707)++ * even when it doesn't produce more code, build can still fail to fuse,+   requiring that the simplifier do more work to bring the expression+   back into cons-chain form; this costs compile time++ * when it works, fusion can be a significant win. Allocations are reduced+   by up to 25% in some nofib programs. Specifically,++        Program           Size    Allocs   Runtime  CompTime+        rewrite          +0.0%    -26.3%      0.02     -1.8%+           ansi          -0.3%    -13.8%      0.00     +0.0%+           lift          +0.0%     -8.7%      0.00     -2.3%++At the moment we use a simple heuristic to determine whether build will be+fruitful: for small lists we assume the benefits of fusion will be worthwhile;+for long lists we assume that the benefits will be outweighted by the cost of+code duplication. This magic length threshold is @maxBuildLength@. Also, fusion+won't work at all if rewrite rules are disabled, so we don't use the build-based+desugaring in this case.++We used to have a more complex heuristic which would try to break the list into+"static" and "dynamic" parts and only build-desugar the dynamic part.+Unfortunately, determining "static-ness" reliably is a bit tricky and the+heuristic at times produced surprising behavior (see #11710) so it was dropped.+-}++{- | The longest list length which we will desugar using @build@.++This is essentially a magic number and its setting is unfortunate rather+arbitrary. The idea here, as mentioned in Note [Desugaring explicit lists],+is to avoid deforesting large static data into large(r) code. Ideally we'd+want a smaller threshold with larger consumers and vice-versa, but we have no+way of knowing what will be consuming our list in the desugaring impossible to+set generally correctly.++The effect of reducing this number will be that 'build' fusion is applied+less often. From a runtime performance perspective, applying 'build' more+liberally on "moderately" sized lists should rarely hurt and will often it can+only expose further optimization opportunities; if no fusion is possible it will+eventually get rule-rewritten back to a list). We do, however, pay in compile+time.+-}+maxBuildLength :: Int+maxBuildLength = 32++dsExplicitList :: Type -> Maybe (SyntaxExpr Id) -> [LHsExpr Id]+               -> DsM CoreExpr+-- See Note [Desugaring explicit lists]+dsExplicitList elt_ty Nothing xs+  = do { dflags <- getDynFlags+       ; xs' <- mapM dsLExprNoLP xs+       ; if length xs' > maxBuildLength+                -- Don't generate builds if the list is very long.+         || length xs' == 0+                -- Don't generate builds when the [] constructor will do+         || not (gopt Opt_EnableRewriteRules dflags)  -- Rewrite rules off+                -- Don't generate a build if there are no rules to eliminate it!+                -- See Note [Desugaring RULE left hand sides] in Desugar+         then return $ mkListExpr elt_ty xs'+         else mkBuildExpr elt_ty (mk_build_list xs') }+  where+    mk_build_list xs' (cons, _) (nil, _)+      = return (foldr (App . App (Var cons)) (Var nil) xs')++dsExplicitList elt_ty (Just fln) xs+  = do { list <- dsExplicitList elt_ty Nothing xs+       ; dflags <- getDynFlags+       ; dsSyntaxExpr fln [mkIntExprInt dflags (length xs), list] }++dsArithSeq :: PostTcExpr -> (ArithSeqInfo Id) -> DsM CoreExpr+dsArithSeq expr (From from)+  = App <$> dsExpr expr <*> dsLExprNoLP from+dsArithSeq expr (FromTo from to)+  = do dflags <- getDynFlags+       warnAboutEmptyEnumerations dflags from Nothing to+       expr' <- dsExpr expr+       from' <- dsLExprNoLP from+       to'   <- dsLExprNoLP to+       return $ mkApps expr' [from', to']+dsArithSeq expr (FromThen from thn)+  = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn]+dsArithSeq expr (FromThenTo from thn to)+  = do dflags <- getDynFlags+       warnAboutEmptyEnumerations dflags from (Just thn) to+       expr' <- dsExpr expr+       from' <- dsLExprNoLP from+       thn'  <- dsLExprNoLP thn+       to'   <- dsLExprNoLP to+       return $ mkApps expr' [from', thn', to']++{-+Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're+handled in DsListComp).  Basically does the translation given in the+Haskell 98 report:+-}++dsDo :: [ExprLStmt Id] -> DsM CoreExpr+dsDo stmts+  = goL stmts+  where+    goL [] = panic "dsDo"+    goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts)++    go _ (LastStmt body _ _) stmts+      = ASSERT( null stmts ) dsLExpr body+        -- The 'return' op isn't used for 'do' expressions++    go _ (BodyStmt rhs then_expr _ _) stmts+      = do { rhs2 <- dsLExpr rhs+           ; warnDiscardedDoBindings rhs (exprType rhs2)+           ; rest <- goL stmts+           ; dsSyntaxExpr then_expr [rhs2, rest] }++    go _ (LetStmt binds) stmts+      = do { rest <- goL stmts+           ; dsLocalBinds binds rest }++    go _ (BindStmt pat rhs bind_op fail_op res1_ty) stmts+      = do  { body     <- goL stmts+            ; rhs'     <- dsLExpr rhs+            ; var   <- selectSimpleMatchVarL pat+            ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat+                                      res1_ty (cantFailMatchResult body)+            ; match_code <- handle_failure pat match fail_op+            ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }++    go _ (ApplicativeStmt args mb_join body_ty) stmts+      = do {+             let+               (pats, rhss) = unzip (map (do_arg . snd) args)++               do_arg (ApplicativeArgOne pat expr) =+                 (pat, dsLExpr expr)+               do_arg (ApplicativeArgMany stmts ret pat) =+                 (pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))++               arg_tys = map hsLPatType pats++           ; rhss' <- sequence rhss++           ; let body' = noLoc $ HsDo DoExpr (noLoc stmts) body_ty++           ; let fun = L noSrcSpan $ HsLam $+                   MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats+                                                       body']+                      , mg_arg_tys = arg_tys+                      , mg_res_ty = body_ty+                      , mg_origin = Generated }++           ; fun' <- dsLExpr fun+           ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r]+           ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss')+           ; case mb_join of+               Nothing -> return expr+               Just join_op -> dsSyntaxExpr join_op [expr] }++    go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids+                    , recS_rec_ids = rec_ids, recS_ret_fn = return_op+                    , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op+                    , recS_bind_ty = bind_ty+                    , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts+      = goL (new_bind_stmt : stmts)  -- rec_ids can be empty; eg  rec { print 'x' }+      where+        new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTupId later_pats)+                                         mfix_app bind_op+                                         noSyntaxExpr  -- Tuple cannot fail+                                         bind_ty++        tup_ids      = rec_ids ++ filterOut (`elem` rec_ids) later_ids+        tup_ty       = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case+        rec_tup_pats = map nlVarPat tup_ids+        later_pats   = rec_tup_pats+        rets         = map noLoc rec_rets+        mfix_app     = nlHsSyntaxApps mfix_op [mfix_arg]+        mfix_arg     = noLoc $ HsLam+                           (MG { mg_alts = noLoc [mkSimpleMatch+                                                    LambdaExpr+                                                    [mfix_pat] body]+                               , mg_arg_tys = [tup_ty], mg_res_ty = body_ty+                               , mg_origin = Generated })+        mfix_pat     = noLoc $ LazyPat $ mkBigLHsPatTupId rec_tup_pats+        body         = noLoc $ HsDo+                                DoExpr (noLoc (rec_stmts ++ [ret_stmt])) body_ty+        ret_app      = nlHsSyntaxApps return_op [mkBigLHsTupId rets]+        ret_stmt     = noLoc $ mkLastStmt ret_app+                     -- This LastStmt will be desugared with dsDo,+                     -- which ignores the return_op in the LastStmt,+                     -- so we must apply the return_op explicitly++    go _ (ParStmt   {}) _ = panic "dsDo ParStmt"+    go _ (TransStmt {}) _ = panic "dsDo TransStmt"++handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr+    -- In a do expression, pattern-match failure just calls+    -- the monadic 'fail' rather than throwing an exception+handle_failure pat match fail_op+  | matchCanFail match+  = do { dflags <- getDynFlags+       ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)+       ; fail_expr <- dsSyntaxExpr fail_op [fail_msg]+       ; extractMatchResult match fail_expr }+  | otherwise+  = extractMatchResult match (error "It can't fail")++mk_fail_msg :: DynFlags -> Located e -> String+mk_fail_msg dflags pat = "Pattern match failure in do expression at " +++                         showPpr dflags (getLoc pat)++{-+************************************************************************+*                                                                      *+   Desugaring ConLikes+*                                                                      *+************************************************************************+-}++dsConLike :: ConLike -> CoreExpr+dsConLike (RealDataCon dc) = Var (dataConWrapId dc)+dsConLike (PatSynCon ps) = case patSynBuilder ps of+  Just (id, add_void)+    | add_void  -> mkCoreApp (text "dsConLike" <+> ppr ps) (Var id) (Var voidPrimId)+    | otherwise -> Var id+  _ -> pprPanic "dsConLike" (ppr ps)++{-+************************************************************************+*                                                                      *+\subsection{Errors and contexts}+*                                                                      *+************************************************************************+-}++-- Warn about certain types of values discarded in monadic bindings (#3263)+warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM ()+warnDiscardedDoBindings rhs rhs_ty+  | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty+  = do { warn_unused <- woptM Opt_WarnUnusedDoBind+       ; warn_wrong <- woptM Opt_WarnWrongDoBind+       ; when (warn_unused || warn_wrong) $+    do { fam_inst_envs <- dsGetFamInstEnvs+       ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty++           -- Warn about discarding non-() things in 'monadic' binding+       ; if warn_unused && not (isUnitTy norm_elt_ty)+         then warnDs (Reason Opt_WarnUnusedDoBind)+                     (badMonadBind rhs elt_ty)+         else++           -- Warn about discarding m a things in 'monadic' binding of the same type,+           -- but only if we didn't already warn due to Opt_WarnUnusedDoBind+           when warn_wrong $+                do { case tcSplitAppTy_maybe norm_elt_ty of+                         Just (elt_m_ty, _)+                            | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty+                            -> warnDs (Reason Opt_WarnWrongDoBind)+                                      (badMonadBind rhs elt_ty)+                         _ -> return () } } }++  | otherwise   -- RHS does have type of form (m ty), which is weird+  = return ()   -- but at lesat this warning is irrelevant++badMonadBind :: LHsExpr Id -> Type -> SDoc+badMonadBind rhs elt_ty+  = vcat [ hang (text "A do-notation statement discarded a result of type")+              2 (quotes (ppr elt_ty))+         , hang (text "Suppress this warning by saying")+              2 (quotes $ text "_ <-" <+> ppr rhs)+         ]
+ deSugar/DsExpr.hs-boot view
@@ -0,0 +1,10 @@+module DsExpr where+import HsSyn    ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr )+import Var      ( Id )+import DsMonad  ( DsM )+import CoreSyn  ( CoreExpr )++dsExpr  :: HsExpr  Id -> DsM CoreExpr+dsLExpr, dsLExprNoLP :: LHsExpr Id -> DsM CoreExpr+dsSyntaxExpr :: SyntaxExpr Id -> [CoreExpr] -> DsM CoreExpr+dsLocalBinds :: LHsLocalBinds Id -> CoreExpr -> DsM CoreExpr
+ deSugar/DsForeign.hs view
@@ -0,0 +1,805 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1998+++Desugaring foreign declarations (see also DsCCall).+-}++{-# LANGUAGE CPP #-}++module DsForeign ( dsForeigns ) where++#include "HsVersions.h"+import TcRnMonad        -- temp++import CoreSyn++import DsCCall+import DsMonad++import HsSyn+import DataCon+import CoreUnfold+import Id+import Literal+import Module+import Name+import Type+import RepType+import TyCon+import Coercion+import TcEnv+import TcType++import CmmExpr+import CmmUtils+import HscTypes+import ForeignCall+import TysWiredIn+import TysPrim+import PrelNames+import BasicTypes+import SrcLoc+import Outputable+import FastString+import DynFlags+import Platform+import Config+import OrdList+import Pair+import Util+import Hooks+import Encoding++import Data.Maybe+import Data.List++{-+Desugaring of @foreign@ declarations is naturally split up into+parts, an @import@ and an @export@  part. A @foreign import@+declaration+\begin{verbatim}+  foreign import cc nm f :: prim_args -> IO prim_res+\end{verbatim}+is the same as+\begin{verbatim}+  f :: prim_args -> IO prim_res+  f a1 ... an = _ccall_ nm cc a1 ... an+\end{verbatim}+so we reuse the desugaring code in @DsCCall@ to deal with these.+-}++type Binding = (Id, CoreExpr)   -- No rec/nonrec structure;+                                -- the occurrence analyser will sort it all out++dsForeigns :: [LForeignDecl Id]+           -> DsM (ForeignStubs, OrdList Binding)+dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos)++dsForeigns' :: [LForeignDecl Id]+            -> DsM (ForeignStubs, OrdList Binding)+dsForeigns' []+  = return (NoStubs, nilOL)+dsForeigns' fos = do+    fives <- mapM do_ldecl fos+    let+        (hs, cs, idss, bindss) = unzip4 fives+        fe_ids = concat idss+        fe_init_code = map foreignExportInitialiser fe_ids+    --+    return (ForeignStubs+             (vcat hs)+             (vcat cs $$ vcat fe_init_code),+            foldr (appOL . toOL) nilOL bindss)+  where+   do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)++   do_decl (ForeignImport { fd_name = id, fd_co = co, fd_fi = spec }) = do+      traceIf (text "fi start" <+> ppr id)+      let id' = unLoc id+      (bs, h, c) <- dsFImport id' co spec+      traceIf (text "fi end" <+> ppr id)+      return (h, c, [], bs)++   do_decl (ForeignExport { fd_name = L _ id, fd_co = co+                          , fd_fe = CExport (L _ (CExportStatic _ ext_nm cconv)) _ }) = do+      (h, c, _, _) <- dsFExport id co ext_nm cconv False+      return (h, c, [id], [])++{-+************************************************************************+*                                                                      *+\subsection{Foreign import}+*                                                                      *+************************************************************************++Desugaring foreign imports is just the matter of creating a binding+that on its RHS unboxes its arguments, performs the external call+(using the @CCallOp@ primop), before boxing the result up and returning it.++However, we create a worker/wrapper pair, thus:++        foreign import f :: Int -> IO Int+==>+        f x = IO ( \s -> case x of { I# x# ->+                         case fw s x# of { (# s1, y# #) ->+                         (# s1, I# y# #)}})++        fw s x# = ccall f s x#++The strictness/CPR analyser won't do this automatically because it doesn't look+inside returned tuples; but inlining this wrapper is a Really Good Idea+because it exposes the boxing to the call site.+-}++dsFImport :: Id+          -> Coercion+          -> ForeignImport+          -> DsM ([Binding], SDoc, SDoc)+dsFImport id co (CImport cconv safety mHeader spec _) =+    dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader++dsCImport :: Id+          -> Coercion+          -> CImportSpec+          -> CCallConv+          -> Safety+          -> Maybe Header+          -> DsM ([Binding], SDoc, SDoc)+dsCImport id co (CLabel cid) cconv _ _ = do+   dflags <- getDynFlags+   let ty  = pFst $ coercionKind co+       fod = case tyConAppTyCon_maybe (dropForAlls ty) of+             Just tycon+              | tyConUnique tycon == funPtrTyConKey ->+                 IsFunction+             _ -> IsData+   (resTy, foRhs) <- resultWrapper ty+   ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this+    let+        rhs = foRhs (Lit (MachLabel cid stdcall_info fod))+        rhs' = Cast rhs co+        stdcall_info = fun_type_arg_stdcall_info dflags cconv ty+    in+    return ([(id, rhs')], empty, empty)++dsCImport id co (CFunction target) cconv@PrimCallConv safety _+  = dsPrimCall id co (CCall (CCallSpec target cconv safety))+dsCImport id co (CFunction target) cconv safety mHeader+  = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader+dsCImport id co CWrapper cconv _ _+  = dsFExportDynamic id co cconv++-- For stdcall labels, if the type was a FunPtr or newtype thereof,+-- then we need to calculate the size of the arguments in order to add+-- the @n suffix to the label.+fun_type_arg_stdcall_info :: DynFlags -> CCallConv -> Type -> Maybe Int+fun_type_arg_stdcall_info dflags StdCallConv ty+  | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty,+    tyConUnique tc == funPtrTyConKey+  = let+       (bndrs, _) = tcSplitPiTys arg_ty+       fe_arg_tys = mapMaybe binderRelevantType_maybe bndrs+    in Just $ sum (map (widthInBytes . typeWidth . typeCmmType dflags . getPrimTyOf) fe_arg_tys)+fun_type_arg_stdcall_info _ _other_conv _+  = Nothing++{-+************************************************************************+*                                                                      *+\subsection{Foreign calls}+*                                                                      *+************************************************************************+-}++dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header+        -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)+dsFCall fn_id co fcall mDeclHeader = do+    let+        ty                   = pFst $ coercionKind co+        (tv_bndrs, rho)      = tcSplitForAllTyVarBndrs ty+        (arg_tys, io_res_ty) = tcSplitFunTys rho++    args <- newSysLocalsDs arg_tys  -- no FFI levity-polymorphism+    (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)++    let+        work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars++    (ccall_result_ty, res_wrapper) <- boxResult io_res_ty++    ccall_uniq <- newUnique+    work_uniq  <- newUnique++    dflags <- getDynFlags+    (fcall', cDoc) <-+              case fcall of+              CCall (CCallSpec (StaticTarget _ cName mUnitId isFun)+                               CApiConv safety) ->+               do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName)+                  let fcall' = CCall (CCallSpec+                                      (StaticTarget NoSourceText+                                                    wrapperName mUnitId+                                                    True)+                                      CApiConv safety)+                      c = includes+                       $$ fun_proto <+> braces (cRet <> semi)+                      includes = vcat [ text "#include <" <> ftext h <> text ">"+                                      | Header _ h <- nub headers ]+                      fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes+                      cRet+                       | isVoidRes =                   cCall+                       | otherwise = text "return" <+> cCall+                      cCall = if isFun+                              then ppr cName <> parens argVals+                              else if null arg_tys+                                    then ppr cName+                                    else panic "dsFCall: Unexpected arguments to FFI value import"+                      raw_res_ty = case tcSplitIOType_maybe io_res_ty of+                                   Just (_ioTyCon, res_ty) -> res_ty+                                   Nothing                 -> io_res_ty+                      isVoidRes = raw_res_ty `eqType` unitTy+                      (mHeader, cResType)+                       | isVoidRes = (Nothing, text "void")+                       | otherwise = toCType raw_res_ty+                      pprCconv = ccallConvAttribute CApiConv+                      mHeadersArgTypeList+                          = [ (header, cType <+> char 'a' <> int n)+                            | (t, n) <- zip arg_tys [1..]+                            , let (header, cType) = toCType t ]+                      (mHeaders, argTypeList) = unzip mHeadersArgTypeList+                      argTypes = if null argTypeList+                                 then text "void"+                                 else hsep $ punctuate comma argTypeList+                      mHeaders' = mDeclHeader : mHeader : mHeaders+                      headers = catMaybes mHeaders'+                      argVals = hsep $ punctuate comma+                                    [ char 'a' <> int n+                                    | (_, n) <- zip arg_tys [1..] ]+                  return (fcall', c)+              _ ->+                  return (fcall, empty)+    let+        -- Build the worker+        worker_ty     = mkForAllTys tv_bndrs (mkFunTys (map idType work_arg_ids) ccall_result_ty)+        tvs           = map binderVar tv_bndrs+        the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty+        work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)+        work_id       = mkSysLocal (fsLit "$wccall") work_uniq worker_ty++        -- Build the wrapper+        work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args+        wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers+        wrap_rhs     = mkLams (tvs ++ args) wrapper_body+        wrap_rhs'    = Cast wrap_rhs co+        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity+                                                (length args) wrap_rhs'++    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc)++{-+************************************************************************+*                                                                      *+\subsection{Primitive calls}+*                                                                      *+************************************************************************++This is for `@foreign import prim@' declarations.++Currently, at the core level we pretend that these primitive calls are+foreign calls. It may make more sense in future to have them as a distinct+kind of Id, or perhaps to bundle them with PrimOps since semantically and+for calling convention they are really prim ops.+-}++dsPrimCall :: Id -> Coercion -> ForeignCall+           -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)+dsPrimCall fn_id co fcall = do+    let+        ty                   = pFst $ coercionKind co+        (tvs, fun_ty)        = tcSplitForAllTys ty+        (arg_tys, io_res_ty) = tcSplitFunTys fun_ty++    args <- newSysLocalsDs arg_tys  -- no FFI levity-polymorphism++    ccall_uniq <- newUnique+    dflags <- getDynFlags+    let+        call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty+        rhs      = mkLams tvs (mkLams args call_app)+        rhs'     = Cast rhs co+    return ([(fn_id, rhs')], empty, empty)++{-+************************************************************************+*                                                                      *+\subsection{Foreign export}+*                                                                      *+************************************************************************++The function that does most of the work for `@foreign export@' declarations.+(see below for the boilerplate code a `@foreign export@' declaration expands+ into.)++For each `@foreign export foo@' in a module M we generate:+\begin{itemize}+\item a C function `@foo@', which calls+\item a Haskell stub `@M.\$ffoo@', which calls+\end{itemize}+the user-written Haskell function `@M.foo@'.+-}++dsFExport :: Id                 -- Either the exported Id,+                                -- or the foreign-export-dynamic constructor+          -> Coercion           -- Coercion between the Haskell type callable+                                -- from C, and its representation type+          -> CLabelString       -- The name to export to C land+          -> CCallConv+          -> Bool               -- True => foreign export dynamic+                                --         so invoke IO action that's hanging off+                                --         the first argument's stable pointer+          -> DsM ( SDoc         -- contents of Module_stub.h+                 , SDoc         -- contents of Module_stub.c+                 , String       -- string describing type to pass to createAdj.+                 , Int          -- size of args to stub function+                 )++dsFExport fn_id co ext_name cconv isDyn = do+    let+       ty                     = pSnd $ coercionKind co+       (bndrs, orig_res_ty)   = tcSplitPiTys ty+       fe_arg_tys'            = mapMaybe binderRelevantType_maybe bndrs+       -- We must use tcSplits here, because we want to see+       -- the (IO t) in the corner of the type!+       fe_arg_tys | isDyn     = tail fe_arg_tys'+                  | otherwise = fe_arg_tys'++       -- Look at the result type of the exported function, orig_res_ty+       -- If it's IO t, return         (t, True)+       -- If it's plain t, return      (t, False)+       (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of+                                -- The function already returns IO t+                                Just (_ioTyCon, res_ty) -> (res_ty, True)+                                -- The function returns t+                                Nothing                 -> (orig_res_ty, False)++    dflags <- getDynFlags+    return $+      mkFExportCBits dflags ext_name+                     (if isDyn then Nothing else Just fn_id)+                     fe_arg_tys res_ty is_IO_res_ty cconv++{-+@foreign import "wrapper"@ (previously "foreign export dynamic") lets+you dress up Haskell IO actions of some fixed type behind an+externally callable interface (i.e., as a C function pointer). Useful+for callbacks and stuff.++\begin{verbatim}+type Fun = Bool -> Int -> IO Int+foreign import "wrapper" f :: Fun -> IO (FunPtr Fun)++-- Haskell-visible constructor, which is generated from the above:+-- SUP: No check for NULL from createAdjustor anymore???++f :: Fun -> IO (FunPtr Fun)+f cback =+   bindIO (newStablePtr cback)+          (\StablePtr sp# -> IO (\s1# ->+              case _ccall_ createAdjustor cconv sp# ``f_helper'' <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_evalIO(&cap,+                   rts_apply(rts_apply(deRefStablePtr(s),+                                       rts_mkBool(b)), rts_mkInt(i)));+        rts_unlock(cap);+}+\end{verbatim}+-}++dsFExportDynamic :: Id+                 -> Coercion+                 -> CCallConv+                 -> DsM ([Binding], SDoc, SDoc)+dsFExportDynamic id co0 cconv = do+    mod <- getModule+    dflags <- getDynFlags+    let fe_nm = mkFastString $ zEncodeString+            (moduleStableString mod ++ "$" ++ toCName dflags id)+        -- Construct the label based on the passed id, don't use names+        -- depending on Unique. See #13807 and Note [Unique Determinism].+    cback <- newSysLocalDs arg_ty+    newStablePtrId <- dsLookupGlobalId newStablePtrName+    stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName+    let+        stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]+        export_ty     = mkFunTy stable_ptr_ty arg_ty+    bindIOId <- dsLookupGlobalId bindIOName+    stbl_value <- newSysLocalDs stable_ptr_ty+    (h_code, c_code, typestring, args_size) <- dsFExport id (mkRepReflCo export_ty) fe_nm cconv True+    let+         {-+          The arguments to the external function which will+          create a little bit of (template) code on the fly+          for allowing the (stable pointed) Haskell closure+          to be entered using an external calling convention+          (stdcall, ccall).+         -}+        adj_args      = [ mkIntLitInt dflags (ccallConvToInt cconv)+                        , Var stbl_value+                        , Lit (MachLabel fe_nm mb_sz_args IsFunction)+                        , Lit (mkMachString typestring)+                        ]+          -- name of external entry point providing these services.+          -- (probably in the RTS.)+        adjustor   = fsLit "createAdjustor"++          -- Determine the number of bytes of arguments to the stub function,+          -- so that we can attach the '@N' suffix to its label if it is a+          -- stdcall on Windows.+        mb_sz_args = case cconv of+                        StdCallConv -> Just args_size+                        _           -> Nothing++    ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])+        -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback++    let io_app = mkLams tvs                  $+                 Lam cback                   $+                 mkApps (Var bindIOId)+                        [ Type stable_ptr_ty+                        , Type res_ty+                        , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]+                        , Lam stbl_value ccall_adj+                        ]++        fed = (id `setInlineActivation` NeverActive, Cast io_app co0)+               -- Never inline the f.e.d. function, because the litlit+               -- might not be in scope in other modules.++    return ([fed], h_code, c_code)++ where+  ty                       = pFst (coercionKind co0)+  (tvs,sans_foralls)       = tcSplitForAllTys ty+  ([arg_ty], fn_res_ty)    = tcSplitFunTys sans_foralls+  Just (io_tc, res_ty)     = tcSplitIOType_maybe fn_res_ty+        -- Must have an IO type; hence Just+++toCName :: DynFlags -> Id -> String+toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i)))++{-+*++\subsection{Generating @foreign export@ stubs}++*++For each @foreign export@ function, a C stub function is generated.+The C stub constructs the application of the exported Haskell function+using the hugs/ghc rts invocation API.+-}++mkFExportCBits :: DynFlags+               -> FastString+               -> Maybe Id      -- Just==static, Nothing==dynamic+               -> [Type]+               -> Type+               -> Bool          -- True <=> returns an IO type+               -> CCallConv+               -> (SDoc,+                   SDoc,+                   String,      -- the argument reps+                   Int          -- total size of arguments+                  )+mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc+ = (header_bits, c_bits, type_string,+    sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args+         -- NB. the calculation here isn't strictly speaking correct.+         -- We have a primitive Haskell type (eg. Int#, Double#), and+         -- we want to know the size, when passed on the C stack, of+         -- the associated C type (eg. HsInt, HsDouble).  We don't have+         -- this information to hand, but we know what GHC's conventions+         -- are for passing around the primitive Haskell types, so we+         -- use that instead.  I hope the two coincide --SDM+    )+ where+  -- list the arguments to the C function+  arg_info :: [(SDoc,           -- arg name+                SDoc,           -- C type+                Type,           -- Haskell type+                CmmType)]       -- the CmmType+  arg_info  = [ let stg_type = showStgType ty in+                (arg_cname n stg_type,+                 stg_type,+                 ty,+                 typeCmmType dflags (getPrimTyOf ty))+              | (ty,n) <- zip arg_htys [1::Int ..] ]++  arg_cname n stg_ty+        | libffi    = char '*' <> parens (stg_ty <> char '*') <>+                      text "args" <> brackets (int (n-1))+        | otherwise = text ('a':show n)++  -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled+  libffi = cLibFFI && isNothing maybe_target++  type_string+      -- libffi needs to know the result type too:+      | libffi    = primTyDescChar dflags res_hty : arg_type_string+      | otherwise = arg_type_string++  arg_type_string = [primTyDescChar dflags ty | (_,_,ty,_) <- arg_info]+                -- just the real args++  -- add some auxiliary args; the stable ptr in the wrapper case, and+  -- a slot for the dummy return address in the wrapper + ccall case+  aug_arg_info+    | isNothing maybe_target = stable_ptr_arg : insertRetAddr dflags cc arg_info+    | otherwise              = arg_info++  stable_ptr_arg =+        (text "the_stableptr", text "StgStablePtr", undefined,+         typeCmmType dflags (mkStablePtrPrimTy alphaTy))++  -- stuff to do with the return type of the C function+  res_hty_is_unit = res_hty `eqType` unitTy     -- Look through any newtypes++  cResType | res_hty_is_unit = text "void"+           | otherwise       = showStgType res_hty++  -- when the return type is integral and word-sized or smaller, it+  -- must be assigned as type ffi_arg (#3516).  To see what type+  -- libffi is expecting here, take a look in its own testsuite, e.g.+  -- libffi/testsuite/libffi.call/cls_align_ulonglong.c+  ffi_cResType+     | is_ffi_arg_type = text "ffi_arg"+     | otherwise       = cResType+     where+       res_ty_key = getUnique (getName (typeTyCon res_hty))+       is_ffi_arg_type = res_ty_key `notElem`+              [floatTyConKey, doubleTyConKey,+               int64TyConKey, word64TyConKey]++  -- Now we can cook up the prototype for the exported function.+  pprCconv = ccallConvAttribute cc++  header_bits = text "extern" <+> fun_proto <> semi++  fun_args+    | null aug_arg_info = text "void"+    | otherwise         = hsep $ punctuate comma+                               $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info++  fun_proto+    | libffi+      = text "void" <+> ftext c_nm <>+          parens (text "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr")+    | otherwise+      = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args++  -- the target which will form the root of what we ask rts_evalIO to run+  the_cfun+     = case maybe_target of+          Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"+          Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"++  cap = text "cap" <> comma++  -- the expression we give to rts_evalIO+  expr_to_run+     = foldl appArg the_cfun arg_info -- NOT aug_arg_info+       where+          appArg acc (arg_cname, _, arg_hty, _)+             = text "rts_apply"+               <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))++  -- various other bits for inside the fn+  declareResult = text "HaskellObj ret;"+  declareCResult | res_hty_is_unit = empty+                 | otherwise       = cResType <+> text "cret;"++  assignCResult | res_hty_is_unit = empty+                | otherwise       =+                        text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi++  -- an extern decl for the fn being called+  extern_decl+     = case maybe_target of+          Nothing -> empty+          Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi+++  -- finally, the whole darn thing+  c_bits =+    space $$+    extern_decl $$+    fun_proto  $$+    vcat+     [ lbrace+     ,   text "Capability *cap;"+     ,   declareResult+     ,   declareCResult+     ,   text "cap = rts_lock();"+          -- create the application + perform it.+     ,   text "rts_evalIO" <> parens (+                char '&' <> cap <>+                text "rts_apply" <> parens (+                    cap <>+                    text "(HaskellObj)"+                 <> ptext (if is_IO_res_ty+                                then (sLit "runIO_closure")+                                else (sLit "runNonIO_closure"))+                 <> comma+                 <> expr_to_run+                ) <+> comma+               <> text "&ret"+             ) <> semi+     ,   text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm)+                                                <> comma <> text "cap") <> semi+     ,   assignCResult+     ,   text "rts_unlock(cap);"+     ,   ppUnless res_hty_is_unit $+         if libffi+                  then char '*' <> parens (ffi_cResType <> char '*') <>+                       text "resp = cret;"+                  else text "return cret;"+     , rbrace+     ]+++foreignExportInitialiser :: Id -> SDoc+foreignExportInitialiser hs_fn =+   -- Initialise foreign exports by registering a stable pointer from an+   -- __attribute__((constructor)) function.+   -- The alternative is to do this from stginit functions generated in+   -- codeGen/CodeGen.hs; however, stginit functions have a negative impact+   -- on binary sizes and link times because the static linker will think that+   -- all modules that are imported directly or indirectly are actually used by+   -- the program.+   -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)+   vcat+    [ text "static void stginit_export_" <> ppr hs_fn+         <> text "() __attribute__((constructor));"+    , text "static void stginit_export_" <> ppr hs_fn <> text "()"+    , braces (text "foreignExportStablePtr"+       <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")+       <> semi)+    ]+++mkHObj :: Type -> SDoc+mkHObj t = text "rts_mk" <> text (showFFIType t)++unpackHObj :: Type -> SDoc+unpackHObj t = text "rts_get" <> text (showFFIType t)++showStgType :: Type -> SDoc+showStgType t = text "Hs" <> text (showFFIType t)++showFFIType :: Type -> String+showFFIType t = getOccString (getName (typeTyCon t))++toCType :: Type -> (Maybe Header, SDoc)+toCType = f False+    where f voidOK t+           -- First, if we have (Ptr t) of (FunPtr t), then we need to+           -- convert t to a C type and put a * after it. If we don't+           -- know a type for t, then "void" is fine, though.+           | Just (ptr, [t']) <- splitTyConApp_maybe t+           , tyConName ptr `elem` [ptrTyConName, funPtrTyConName]+              = case f True t' of+                (mh, cType') ->+                    (mh, cType' <> char '*')+           -- Otherwise, if we have a type constructor application, then+           -- see if there is a C type associated with that constructor.+           -- Note that we aren't looking through type synonyms or+           -- anything, as it may be the synonym that is annotated.+           | Just tycon <- tyConAppTyConPicky_maybe t+           , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon+              = (mHeader, ftext cType)+           -- If we don't know a C type for this type, then try looking+           -- through one layer of type synonym etc.+           | Just t' <- coreView t+              = f voidOK t'+           -- Otherwise we don't know the C type. If we are allowing+           -- void then return that; otherwise something has gone wrong.+           | voidOK = (Nothing, text "void")+           | otherwise+              = pprPanic "toCType" (ppr t)++typeTyCon :: Type -> TyCon+typeTyCon ty+  | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty)+  = tc+  | otherwise+  = pprPanic "DsForeign.typeTyCon" (ppr ty)++insertRetAddr :: DynFlags -> CCallConv+              -> [(SDoc, SDoc, Type, CmmType)]+              -> [(SDoc, SDoc, Type, CmmType)]+insertRetAddr dflags CCallConv args+    = case platformArch platform of+      ArchX86_64+       | platformOS platform == OSMinGW32 ->+          -- On other Windows x86_64 we insert the return address+          -- after the 4th argument, because this is the point+          -- at which we need to flush a register argument to the stack+          -- (See rts/Adjustor.c for details).+          let go :: Int -> [(SDoc, SDoc, Type, CmmType)]+                        -> [(SDoc, SDoc, Type, CmmType)]+              go 4 args = ret_addr_arg dflags : args+              go n (arg:args) = arg : go (n+1) args+              go _ [] = []+          in go 0 args+       | otherwise ->+          -- On other x86_64 platforms we insert the return address+          -- after the 6th integer argument, because this is the point+          -- at which we need to flush a register argument to the stack+          -- (See rts/Adjustor.c for details).+          let go :: Int -> [(SDoc, SDoc, Type, CmmType)]+                        -> [(SDoc, SDoc, Type, CmmType)]+              go 6 args = ret_addr_arg dflags : args+              go n (arg@(_,_,_,rep):args)+               | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args+               | otherwise  = arg : go n     args+              go _ [] = []+          in go 0 args+      _ ->+          ret_addr_arg dflags : args+    where platform = targetPlatform dflags+insertRetAddr _ _ args = args++ret_addr_arg :: DynFlags -> (SDoc, SDoc, Type, CmmType)+ret_addr_arg dflags = (text "original_return_addr", text "void*", undefined,+                       typeCmmType dflags addrPrimTy)++-- This function returns the primitive type associated with the boxed+-- type argument to a foreign export (eg. Int ==> Int#).+getPrimTyOf :: Type -> UnaryType+getPrimTyOf ty+  | isBoolTy rep_ty = intPrimTy+  -- Except for Bool, the types we are interested in have a single constructor+  -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).+  | otherwise =+  case splitDataProductType_maybe rep_ty of+     Just (_, _, data_con, [prim_ty]) ->+        ASSERT(dataConSourceArity data_con == 1)+        ASSERT2(isUnliftedType prim_ty, ppr prim_ty)+        prim_ty+     _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)+  where+        rep_ty = unwrapType ty++-- represent a primitive type as a Char, for building a string that+-- described the foreign function type.  The types are size-dependent,+-- e.g. 'W' is a signed 32-bit integer.+primTyDescChar :: DynFlags -> Type -> Char+primTyDescChar dflags ty+ | ty `eqType` unitTy = 'v'+ | otherwise+ = case typePrimRep1 (getPrimTyOf ty) of+     IntRep      -> signed_word+     WordRep     -> unsigned_word+     Int64Rep    -> 'L'+     Word64Rep   -> 'l'+     AddrRep     -> 'p'+     FloatRep    -> 'f'+     DoubleRep   -> 'd'+     _           -> pprPanic "primTyDescChar" (ppr ty)+  where+    (signed_word, unsigned_word)+       | wORD_SIZE dflags == 4  = ('W','w')+       | wORD_SIZE dflags == 8  = ('L','l')+       | otherwise              = panic "primTyDescChar"
+ deSugar/DsGRHSs.hs view
@@ -0,0 +1,163 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Matching guarded right-hand-sides (GRHSs)+-}++{-# LANGUAGE CPP #-}++module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS, isTrueLHsExpr ) where++#include "HsVersions.h"++import {-# SOURCE #-} DsExpr  ( dsLExpr, dsLocalBinds )+import {-# SOURCE #-} Match   ( matchSinglePat )++import HsSyn+import MkCore+import CoreSyn+import Var++import DsMonad+import DsUtils+import TysWiredIn+import PrelNames+import Type   ( Type )+import Module+import Name+import Util+import SrcLoc+import Outputable++{-+@dsGuarded@ is used for both @case@ expressions and pattern bindings.+It desugars:+\begin{verbatim}+        | g1 -> e1+        ...+        | gn -> en+        where binds+\end{verbatim}+producing an expression with a runtime error in the corner if+necessary.  The type argument gives the type of the @ei@.+-}++dsGuarded :: GRHSs Id (LHsExpr Id) -> Type -> DsM CoreExpr++dsGuarded grhss rhs_ty = do+    match_result <- dsGRHSs PatBindRhs [] grhss rhs_ty+    error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty+    extractMatchResult match_result error_expr++-- In contrast, @dsGRHSs@ produces a @MatchResult@.++dsGRHSs :: HsMatchContext Name -> [Pat Id]      -- These are to build a MatchContext from+        -> GRHSs Id (LHsExpr Id)                -- Guarded RHSs+        -> Type                                 -- Type of RHS+        -> DsM MatchResult+dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty+  = ASSERT( notNull grhss )+    do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss+       ; let match_result1 = foldr1 combineMatchResults match_results+             match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1+                             -- NB: nested dsLet inside matchResult+       ; return match_result2 }++dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id (LHsExpr Id) -> DsM MatchResult+dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs))+  = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty++{-+************************************************************************+*                                                                      *+*  matchGuard : make a MatchResult from a guarded RHS                  *+*                                                                      *+************************************************************************+-}++matchGuards :: [GuardStmt Id]       -- Guard+            -> HsStmtContext Name   -- Context+            -> LHsExpr Id           -- RHS+            -> Type                 -- Type of RHS of guard+            -> DsM MatchResult++-- See comments with HsExpr.Stmt re what a BodyStmt means+-- Here we must be in a guard context (not do-expression, nor list-comp)++matchGuards [] _ rhs _+  = do  { core_rhs <- dsLExpr rhs+        ; return (cantFailMatchResult core_rhs) }++        -- BodyStmts must be guards+        -- Turn an "otherwise" guard is a no-op.  This ensures that+        -- you don't get a "non-exhaustive eqns" message when the guards+        -- finish in "otherwise".+        -- NB:  The success of this clause depends on the typechecker not+        --      wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors+        --      If it does, you'll get bogus overlap warnings+matchGuards (BodyStmt e _ _ _ : stmts) ctx rhs rhs_ty+  | Just addTicks <- isTrueLHsExpr e = do+    match_result <- matchGuards stmts ctx rhs rhs_ty+    return (adjustMatchResultDs addTicks match_result)+matchGuards (BodyStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do+    match_result <- matchGuards stmts ctx rhs rhs_ty+    pred_expr <- dsLExpr expr+    return (mkGuardedMatchResult pred_expr match_result)++matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty = do+    match_result <- matchGuards stmts ctx rhs rhs_ty+    return (adjustMatchResultDs (dsLocalBinds binds) match_result)+        -- NB the dsLet occurs inside the match_result+        -- Reason: dsLet takes the body expression as its argument+        --         so we can't desugar the bindings without the+        --         body expression in hand++matchGuards (BindStmt pat bind_rhs _ _ _ : stmts) ctx rhs rhs_ty = do+    match_result <- matchGuards stmts ctx rhs rhs_ty+    core_rhs <- dsLExpr bind_rhs+    matchSinglePat core_rhs (StmtCtxt ctx) pat rhs_ty match_result++matchGuards (LastStmt  {} : _) _ _ _ = panic "matchGuards LastStmt"+matchGuards (ParStmt   {} : _) _ _ _ = panic "matchGuards ParStmt"+matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt"+matchGuards (RecStmt   {} : _) _ _ _ = panic "matchGuards RecStmt"+matchGuards (ApplicativeStmt {} : _) _ _ _ =+  panic "matchGuards ApplicativeLastStmt"++isTrueLHsExpr :: LHsExpr Id -> Maybe (CoreExpr -> DsM CoreExpr)++-- Returns Just {..} if we're sure that the expression is True+-- I.e.   * 'True' datacon+--        * 'otherwise' Id+--        * Trivial wappings of these+-- The arguments to Just are any HsTicks that we have found,+-- because we still want to tick then, even it they are always evaluated.+isTrueLHsExpr (L _ (HsVar (L _ v))) |  v `hasKey` otherwiseIdKey+                                    || v `hasKey` getUnique trueDataConId+                                            = Just return+        -- trueDataConId doesn't have the same unique as trueDataCon+isTrueLHsExpr (L _ (HsConLikeOut con)) | con `hasKey` getUnique trueDataCon = Just return+isTrueLHsExpr (L _ (HsTick tickish e))+    | Just ticks <- isTrueLHsExpr e+    = Just (\x -> do wrapped <- ticks x+                     return (Tick tickish wrapped))+   -- This encodes that the result is constant True for Hpc tick purposes;+   -- which is specifically what isTrueLHsExpr is trying to find out.+isTrueLHsExpr (L _ (HsBinTick ixT _ e))+    | Just ticks <- isTrueLHsExpr e+    = Just (\x -> do e <- ticks x+                     this_mod <- getModule+                     return (Tick (HpcTick this_mod ixT) e))++isTrueLHsExpr (L _ (HsPar e))         = isTrueLHsExpr e+isTrueLHsExpr _                       = Nothing++{-+Should {\em fail} if @e@ returns @D@+\begin{verbatim}+f x | p <- e', let C y# = e, f y# = r1+    | otherwise          = r2+\end{verbatim}+-}
+ deSugar/DsListComp.hs view
@@ -0,0 +1,883 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Desugaring list comprehensions, monad comprehensions and array comprehensions+-}++{-# LANGUAGE CPP, NamedFieldPuns #-}++module DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where++#include "HsVersions.h"++import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )++import HsSyn+import TcHsSyn+import CoreSyn+import MkCore++import DsMonad          -- the monadery used in the desugarer+import DsUtils++import DynFlags+import CoreUtils+import Id+import Type+import TysWiredIn+import Match+import PrelNames+import SrcLoc+import Outputable+import TcType+import ListSetOps( getNth )+import Util++{-+List comprehensions may be desugared in one of two ways: ``ordinary''+(as you would expect if you read SLPJ's book) and ``with foldr/build+turned on'' (if you read Gill {\em et al.}'s paper on the subject).++There will be at least one ``qualifier'' in the input.+-}++dsListComp :: [ExprLStmt Id]+           -> Type              -- Type of entire list+           -> DsM CoreExpr+dsListComp lquals res_ty = do+    dflags <- getDynFlags+    let quals = map unLoc lquals+        elt_ty = case tcTyConAppArgs res_ty of+                   [elt_ty] -> elt_ty+                   _ -> pprPanic "dsListComp" (ppr res_ty $$ ppr lquals)++    if not (gopt Opt_EnableRewriteRules dflags) || gopt Opt_IgnoreInterfacePragmas dflags+       -- Either rules are switched off, or we are ignoring what there are;+       -- Either way foldr/build won't happen, so use the more efficient+       -- Wadler-style desugaring+       || isParallelComp quals+       -- Foldr-style desugaring can't handle parallel list comprehensions+        then deListComp quals (mkNilExpr elt_ty)+        else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals)+             -- Foldr/build should be enabled, so desugar+             -- into foldrs and builds++  where+    -- We must test for ParStmt anywhere, not just at the head, because an extension+    -- to list comprehensions would be to add brackets to specify the associativity+    -- of qualifier lists. This is really easy to do by adding extra ParStmts into the+    -- mix of possibly a single element in length, so we do this to leave the possibility open+    isParallelComp = any isParallelStmt++    isParallelStmt (ParStmt {}) = True+    isParallelStmt _            = False+++-- This function lets you desugar a inner list comprehension and a list of the binders+-- of that comprehension that we need in the outer comprehension into such an expression+-- and the type of the elements that it outputs (tuples of binders)+dsInnerListComp :: (ParStmtBlock Id Id) -> DsM (CoreExpr, Type)+dsInnerListComp (ParStmtBlock stmts bndrs _)+  = do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs+             list_ty          = mkListTy bndrs_tuple_type++             -- really use original bndrs below!+       ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty++       ; return (expr, bndrs_tuple_type) }++-- This function factors out commonality between the desugaring strategies for GroupStmt.+-- Given such a statement it gives you back an expression representing how to compute the transformed+-- list and the tuple that you need to bind from that list in order to proceed with your desugaring+dsTransStmt :: ExprStmt Id -> DsM (CoreExpr, LPat Id)+dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap+                       , trS_by = by, trS_using = using }) = do+    let (from_bndrs, to_bndrs) = unzip binderMap++    let from_bndrs_tys  = map idType from_bndrs+        to_bndrs_tys    = map idType to_bndrs++        to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys++    -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders+    (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock stmts from_bndrs noSyntaxExpr)++    -- Work out what arguments should be supplied to that expression: i.e. is an extraction+    -- function required? If so, create that desugared function and add to arguments+    usingExpr' <- dsLExpr using+    usingArgs' <- case by of+                    Nothing   -> return [expr']+                    Just by_e -> do { by_e' <- dsLExpr by_e+                                    ; lam' <- matchTuple from_bndrs by_e'+                                    ; return [lam', expr'] }++    -- Create an unzip function for the appropriate arity and element types and find "map"+    unzip_stuff' <- mkUnzipBind form from_bndrs_tys+    map_id <- dsLookupGlobalId mapName++    -- Generate the expressions to build the grouped list+    let -- First we apply the grouping function to the inner list+        inner_list_expr' = mkApps usingExpr' usingArgs'+        -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists+        -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and+        -- the "b" to be a tuple of "to" lists!+        -- Then finally we bind the unzip function around that expression+        bound_unzipped_inner_list_expr'+          = case unzip_stuff' of+              Nothing -> inner_list_expr'+              Just (unzip_fn', unzip_rhs') ->+                Let (Rec [(unzip_fn', unzip_rhs')]) $+                mkApps (Var map_id) $+                [ Type (mkListTy from_tup_ty)+                , Type to_bndrs_tup_ty+                , Var unzip_fn'+                , inner_list_expr' ]++    dsNoLevPoly (tcFunResultTyN (length usingArgs') (exprType usingExpr'))+      (text "In the result of a" <+> quotes (text "using") <+> text "function:" <+> ppr using)++    -- Build a pattern that ensures the consumer binds into the NEW binders,+    -- which hold lists rather than single values+    let pat = mkBigLHsVarPatTupId to_bndrs  -- NB: no '!+    return (bound_unzipped_inner_list_expr', pat)++dsTransStmt _ = panic "dsTransStmt: Not given a TransStmt"++{-+************************************************************************+*                                                                      *+\subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions}+*                                                                      *+************************************************************************++Just as in Phil's chapter~7 in SLPJ, using the rules for+optimally-compiled list comprehensions.  This is what Kevin followed+as well, and I quite happily do the same.  The TQ translation scheme+transforms a list of qualifiers (either boolean expressions or+generators) into a single expression which implements the list+comprehension.  Because we are generating 2nd-order polymorphic+lambda-calculus, calls to NIL and CONS must be applied to a type+argument, as well as their usual value arguments.+\begin{verbatim}+TE << [ e | qs ] >>  =  TQ << [ e | qs ] ++ Nil (typeOf e) >>++(Rule C)+TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <<e>> TE <<L>>++(Rule B)+TQ << [ e | b , qs ] ++ L >> =+    if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >>++(Rule A')+TQ << [ e | p <- L1, qs ]  ++  L2 >> =+  letrec+    h = \ u1 ->+          case u1 of+            []        ->  TE << L2 >>+            (u2 : u3) ->+                  (( \ TE << p >> -> ( TQ << [e | qs]  ++  (h u3) >> )) u2)+                    [] (h u3)+  in+    h ( TE << L1 >> )++"h", "u1", "u2", and "u3" are new variables.+\end{verbatim}++@deListComp@ is the TQ translation scheme.  Roughly speaking, @dsExpr@+is the TE translation scheme.  Note that we carry around the @L@ list+already desugared.  @dsListComp@ does the top TE rule mentioned above.++To the above, we add an additional rule to deal with parallel list+comprehensions.  The translation goes roughly as follows:+     [ e | p1 <- e11, let v1 = e12, p2 <- e13+         | q1 <- e21, let v2 = e22, q2 <- e23]+     =>+     [ e | ((x1, .., xn), (y1, ..., ym)) <-+               zip [(x1,..,xn) | p1 <- e11, let v1 = e12, p2 <- e13]+                   [(y1,..,ym) | q1 <- e21, let v2 = e22, q2 <- e23]]+where (x1, .., xn) are the variables bound in p1, v1, p2+      (y1, .., ym) are the variables bound in q1, v2, q2++In the translation below, the ParStmt branch translates each parallel branch+into a sub-comprehension, and desugars each independently.  The resulting lists+are fed to a zip function, we create a binding for all the variables bound in all+the comprehensions, and then we hand things off the the desugarer for bindings.+The zip function is generated here a) because it's small, and b) because then we+don't have to deal with arbitrary limits on the number of zip functions in the+prelude, nor which library the zip function came from.+The introduced tuples are Boxed, but only because I couldn't get it to work+with the Unboxed variety.+-}++deListComp :: [ExprStmt Id] -> CoreExpr -> DsM CoreExpr++deListComp [] _ = panic "deListComp"++deListComp (LastStmt body _ _ : quals) list+  =     -- Figure 7.4, SLPJ, p 135, rule C above+    ASSERT( null quals )+    do { core_body <- dsLExpr body+       ; return (mkConsExpr (exprType core_body) core_body list) }++        -- Non-last: must be a guard+deListComp (BodyStmt guard _ _ _ : quals) list = do  -- rule B above+    core_guard <- dsLExpr guard+    core_rest <- deListComp quals list+    return (mkIfThenElse core_guard core_rest list)++-- [e | let B, qs] = let B in [e | qs]+deListComp (LetStmt binds : quals) list = do+    core_rest <- deListComp quals list+    dsLocalBinds binds core_rest++deListComp (stmt@(TransStmt {}) : quals) list = do+    (inner_list_expr, pat) <- dsTransStmt stmt+    deBindComp pat inner_list_expr quals list++deListComp (BindStmt pat list1 _ _ _ : quals) core_list2 = do -- rule A' above+    core_list1 <- dsLExprNoLP list1+    deBindComp pat core_list1 quals core_list2++deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list+  = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs+       ; let (exps, qual_tys) = unzip exps_and_qual_tys++       ; (zip_fn, zip_rhs) <- mkZipBind qual_tys++        -- Deal with [e | pat <- zip l1 .. ln] in example above+       ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))+                    quals list }+  where+        bndrs_s = [bs | ParStmtBlock _ bs _ <- stmtss_w_bndrs]++        -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above+        pat  = mkBigLHsPatTupId pats+        pats = map mkBigLHsVarPatTupId bndrs_s++deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt"++deListComp (ApplicativeStmt {} : _) _ =+  panic "deListComp ApplicativeStmt"++deBindComp :: OutPat Id+           -> CoreExpr+           -> [ExprStmt Id]+           -> CoreExpr+           -> DsM (Expr Id)+deBindComp pat core_list1 quals core_list2 = do+    let u3_ty@u1_ty = exprType core_list1       -- two names, same thing++        -- u1_ty is a [alpha] type, and u2_ty = alpha+    let u2_ty = hsLPatType pat++    let res_ty = exprType core_list2+        h_ty   = u1_ty `mkFunTy` res_ty++       -- no levity polymorphism here, as list comprehensions don't work+       -- with RebindableSyntax. NB: These are *not* monad comps.+    [h, u1, u2, u3] <- newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]++    -- the "fail" value ...+    let+        core_fail   = App (Var h) (Var u3)+        letrec_body = App (Var h) core_list1++    rest_expr <- deListComp quals core_fail+    core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail++    let+        rhs = Lam u1 $+              Case (Var u1) u1 res_ty+                   [(DataAlt nilDataCon,  [],       core_list2),+                    (DataAlt consDataCon, [u2, u3], core_match)]+                        -- Increasing order of tag++    return (Let (Rec [(h, rhs)]) letrec_body)++{-+************************************************************************+*                                                                      *+\subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}+*                                                                      *+************************************************************************++@dfListComp@ are the rules used with foldr/build turned on:++\begin{verbatim}+TE[ e | ]            c n = c e n+TE[ e | b , q ]      c n = if b then TE[ e | q ] c n else n+TE[ e | p <- l , q ] c n = let+                                f = \ x b -> case x of+                                                  p -> TE[ e | q ] c b+                                                  _ -> b+                           in+                           foldr f n l+\end{verbatim}+-}++dfListComp :: Id -> Id         -- 'c' and 'n'+           -> [ExprStmt Id]    -- the rest of the qual's+           -> DsM CoreExpr++dfListComp _ _ [] = panic "dfListComp"++dfListComp c_id n_id (LastStmt body _ _ : quals)+  = ASSERT( null quals )+    do { core_body <- dsLExprNoLP body+       ; return (mkApps (Var c_id) [core_body, Var n_id]) }++        -- Non-last: must be a guard+dfListComp c_id n_id (BodyStmt guard _ _ _  : quals) = do+    core_guard <- dsLExpr guard+    core_rest <- dfListComp c_id n_id quals+    return (mkIfThenElse core_guard core_rest (Var n_id))++dfListComp c_id n_id (LetStmt binds : quals) = do+    -- new in 1.3, local bindings+    core_rest <- dfListComp c_id n_id quals+    dsLocalBinds binds core_rest++dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do+    (inner_list_expr, pat) <- dsTransStmt stmt+    -- Anyway, we bind the newly grouped list via the generic binding function+    dfBindComp c_id n_id (pat, inner_list_expr) quals++dfListComp c_id n_id (BindStmt pat list1 _ _ _ : quals) = do+    -- evaluate the two lists+    core_list1 <- dsLExpr list1++    -- Do the rest of the work in the generic binding builder+    dfBindComp c_id n_id (pat, core_list1) quals++dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt"+dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt"+dfListComp _ _ (ApplicativeStmt {} : _) =+  panic "dfListComp ApplicativeStmt"++dfBindComp :: Id -> Id          -- 'c' and 'n'+           -> (LPat Id, CoreExpr)+           -> [ExprStmt Id]     -- the rest of the qual's+           -> DsM CoreExpr+dfBindComp c_id n_id (pat, core_list1) quals = do+    -- find the required type+    let x_ty   = hsLPatType pat+    let b_ty   = idType n_id++    -- create some new local id's+    b <- newSysLocalDs b_ty+    x <- newSysLocalDs x_ty++    -- build rest of the comprehesion+    core_rest <- dfListComp c_id b quals++    -- build the pattern match+    core_expr <- matchSimply (Var x) (StmtCtxt ListComp)+                pat core_rest (Var b)++    -- now build the outermost foldr, and return+    mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1++{-+************************************************************************+*                                                                      *+\subsection[DsFunGeneration]{Generation of zip/unzip functions for use in desugaring}+*                                                                      *+************************************************************************+-}++mkZipBind :: [Type] -> DsM (Id, CoreExpr)+-- mkZipBind [t1, t2]+-- = (zip, \as1:[t1] as2:[t2]+--         -> case as1 of+--              [] -> []+--              (a1:as'1) -> case as2 of+--                              [] -> []+--                              (a2:as'2) -> (a1, a2) : zip as'1 as'2)]++mkZipBind elt_tys = do+    ass  <- mapM newSysLocalDs  elt_list_tys+    as'  <- mapM newSysLocalDs  elt_tys+    as's <- mapM newSysLocalDs  elt_list_tys++    zip_fn <- newSysLocalDs zip_fn_ty++    let inner_rhs = mkConsExpr elt_tuple_ty+                        (mkBigCoreVarTup as')+                        (mkVarApps (Var zip_fn) as's)+        zip_body  = foldr mk_case inner_rhs (zip3 ass as' as's)++    return (zip_fn, mkLams ass zip_body)+  where+    elt_list_tys      = map mkListTy elt_tys+    elt_tuple_ty      = mkBigCoreTupTy elt_tys+    elt_tuple_list_ty = mkListTy elt_tuple_ty++    zip_fn_ty         = mkFunTys elt_list_tys elt_tuple_list_ty++    mk_case (as, a', as') rest+          = Case (Var as) as elt_tuple_list_ty+                  [(DataAlt nilDataCon,  [],        mkNilExpr elt_tuple_ty),+                   (DataAlt consDataCon, [a', as'], rest)]+                        -- Increasing order of tag+++mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr))+-- mkUnzipBind [t1, t2]+-- = (unzip, \ys :: [(t1, t2)] -> foldr (\ax :: (t1, t2) axs :: ([t1], [t2])+--     -> case ax of+--      (x1, x2) -> case axs of+--                (xs1, xs2) -> (x1 : xs1, x2 : xs2))+--      ([], [])+--      ys)+--+-- We use foldr here in all cases, even if rules are turned off, because we may as well!+mkUnzipBind ThenForm _+ = return Nothing    -- No unzipping for ThenForm+mkUnzipBind _ elt_tys+  = do { ax  <- newSysLocalDs elt_tuple_ty+       ; axs <- newSysLocalDs elt_list_tuple_ty+       ; ys  <- newSysLocalDs elt_tuple_list_ty+       ; xs  <- mapM newSysLocalDs elt_tys+       ; xss <- mapM newSysLocalDs elt_list_tys++       ; unzip_fn <- newSysLocalDs unzip_fn_ty++       ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply]++       ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)+             concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss))+             tupled_concat_expression = mkBigCoreTup concat_expressions++             folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs)+             folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax)+             folder_body = mkLams [ax, axs] folder_body_outer_case++       ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys)+       ; return (Just (unzip_fn, mkLams [ys] unzip_body)) }+  where+    elt_tuple_ty       = mkBigCoreTupTy elt_tys+    elt_tuple_list_ty  = mkListTy elt_tuple_ty+    elt_list_tys       = map mkListTy elt_tys+    elt_list_tuple_ty  = mkBigCoreTupTy elt_list_tys++    unzip_fn_ty        = elt_tuple_list_ty `mkFunTy` elt_list_tuple_ty++    mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail++{-+************************************************************************+*                                                                      *+\subsection[DsPArrComp]{Desugaring of array comprehensions}+*                                                                      *+************************************************************************+-}++-- entry point for desugaring a parallel array comprehension+--+--   [:e | qss:] = <<[:e | qss:]>> () [:():]+--+dsPArrComp :: [ExprStmt Id]+            -> DsM CoreExpr++-- Special case for parallel comprehension+dsPArrComp (ParStmt qss _ _ _ : quals) = dePArrParComp qss quals++-- Special case for simple generators:+--+--  <<[:e' | p <- e, qs:]>> = <<[: e' | qs :]>> p e+--+-- if matching again p cannot fail, or else+--+--  <<[:e' | p <- e, qs:]>> =+--    <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e)+--+dsPArrComp (BindStmt p e _ _ _ : qs) = do+    filterP <- dsDPHBuiltin filterPVar+    ce <- dsLExprNoLP e+    let ety'ce  = parrElemType ce+        false   = Var falseDataConId+        true    = Var trueDataConId+    v <- newSysLocalDs ety'ce+    pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false+    let gen | isIrrefutableHsPat p = ce+            | otherwise            = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]+    dePArrComp qs p gen++dsPArrComp qs = do -- no ParStmt in `qs'+    sglP <- dsDPHBuiltin singletonPVar+    let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []]+    dePArrComp qs (noLoc $ WildPat unitTy) unitArray++++-- the work horse+--+dePArrComp :: [ExprStmt Id]+           -> LPat Id           -- the current generator pattern+           -> CoreExpr          -- the current generator expression+           -> DsM CoreExpr++dePArrComp [] _ _ = panic "dePArrComp"++--+--  <<[:e' | :]>> pa ea = mapP (\pa -> e') ea+--+dePArrComp (LastStmt e' _ _ : quals) pa cea+  = ASSERT( null quals )+    do { mapP <- dsDPHBuiltin mapPVar+       ; let ty = parrElemType cea+       ; (clam, ty'e') <- deLambda ty pa e'+       ; return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea] }+--+--  <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)+--+dePArrComp (BodyStmt b _ _ _ : qs) pa cea = do+    filterP <- dsDPHBuiltin filterPVar+    let ty = parrElemType cea+    (clam,_) <- deLambda ty pa b+    dePArrComp qs pa (mkApps (Var filterP) [Type ty, clam, cea])++--+--  <<[:e' | p <- e, qs:]>> pa ea =+--    let ef = \pa -> e+--    in+--    <<[:e' | qs:]>> (pa, p) (crossMap ea ef)+--+-- if matching again p cannot fail, or else+--+--  <<[:e' | p <- e, qs:]>> pa ea =+--    let ef = \pa -> filterP (\x -> case x of {p -> True; _ -> False}) e+--    in+--    <<[:e' | qs:]>> (pa, p) (crossMapP ea ef)+--+dePArrComp (BindStmt p e _ _ _ : qs) pa cea = do+    filterP <- dsDPHBuiltin filterPVar+    crossMapP <- dsDPHBuiltin crossMapPVar+    ce <- dsLExpr e+    let ety'cea = parrElemType cea+        ety'ce  = parrElemType ce+        false   = Var falseDataConId+        true    = Var trueDataConId+    v <- newSysLocalDs ety'ce+    pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false+    let cef | isIrrefutableHsPat p = ce+            | otherwise            = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]+    (clam, _) <- mkLambda ety'cea pa cef+    let ety'cef = ety'ce                    -- filter doesn't change the element type+        pa'     = mkLHsPatTup [pa, p]++    dePArrComp qs pa' (mkApps (Var crossMapP)+                                 [Type ety'cea, Type ety'cef, cea, clam])+--+--  <<[:e' | let ds, qs:]>> pa ea =+--    <<[:e' | qs:]>> (pa, (x_1, ..., x_n))+--                    (mapP (\v@pa -> let ds in (v, (x_1, ..., x_n))) ea)+--  where+--    {x_1, ..., x_n} = DV (ds)         -- Defined Variables+--+dePArrComp (LetStmt lds@(L _ ds) : qs) pa cea = do+    mapP <- dsDPHBuiltin mapPVar+    let xs = collectLocalBinders ds+        ty'cea = parrElemType cea+    v <- newSysLocalDs ty'cea+    clet <- dsLocalBinds lds (mkCoreTup (map Var xs))+    let'v <- newSysLocalDs (exprType clet)+    let projBody = mkCoreLet (NonRec let'v clet) $+                   mkCoreTup [Var v, Var let'v]+        errTy    = exprType projBody+        errMsg   = text "DsListComp.dePArrComp: internal error!"+    cerr <- mkErrorAppDs pAT_ERROR_ID errTy errMsg+    ccase <- matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr+    let pa'    = mkLHsPatTup [pa, mkLHsPatTup (map nlVarPat xs)]+        proj   = mkLams [v] ccase+    dePArrComp qs pa' (mkApps (Var mapP)+                                   [Type ty'cea, Type errTy, proj, cea])+--+-- The parser guarantees that parallel comprehensions can only appear as+-- singleton qualifier lists, which we already special case in the caller.+-- So, encountering one here is a bug.+--+dePArrComp (ParStmt {} : _) _ _ =+  panic "DsListComp.dePArrComp: malformed comprehension AST: ParStmt"+dePArrComp (TransStmt {} : _) _ _ = panic "DsListComp.dePArrComp: TransStmt"+dePArrComp (RecStmt   {} : _) _ _ = panic "DsListComp.dePArrComp: RecStmt"+dePArrComp (ApplicativeStmt   {} : _) _ _ =+  panic "DsListComp.dePArrComp: ApplicativeStmt"++--  <<[:e' | qs | qss:]>> pa ea =+--    <<[:e' | qss:]>> (pa, (x_1, ..., x_n))+--                     (zipP ea <<[:(x_1, ..., x_n) | qs:]>>)+--    where+--      {x_1, ..., x_n} = DV (qs)+--+dePArrParComp :: [ParStmtBlock Id Id] -> [ExprStmt Id] -> DsM CoreExpr+dePArrParComp qss quals = do+    (pQss, ceQss) <- deParStmt qss+    dePArrComp quals pQss ceQss+  where+    deParStmt []             =+      -- empty parallel statement lists have no source representation+      panic "DsListComp.dePArrComp: Empty parallel list comprehension"+    deParStmt (ParStmtBlock qs xs _:qss) = do        -- first statement+      let res_expr = mkLHsVarTuple xs+      cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])+      parStmts qss (mkLHsVarPatTup xs) cqs+    ---+    parStmts []             pa cea = return (pa, cea)+    parStmts (ParStmtBlock qs xs _:qss) pa cea = do  -- subsequent statements (zip'ed)+      zipP <- dsDPHBuiltin zipPVar+      let pa'      = mkLHsPatTup [pa, mkLHsVarPatTup xs]+          ty'cea   = parrElemType cea+          res_expr = mkLHsVarTuple xs+      cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])+      let ty'cqs = parrElemType cqs+          cea'   = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]+      parStmts qss pa' cea'++-- generate Core corresponding to `\p -> e'+--+deLambda :: Type                       -- type of the argument (not levity-polymorphic)+         -> LPat Id                    -- argument pattern+         -> LHsExpr Id                 -- body+         -> DsM (CoreExpr, Type)+deLambda ty p e =+    mkLambda ty p =<< dsLExpr e++-- generate Core for a lambda pattern match, where the body is already in Core+--+mkLambda :: Type                        -- type of the argument (not levity-polymorphic)+         -> LPat Id                     -- argument pattern+         -> CoreExpr                    -- desugared body+         -> DsM (CoreExpr, Type)+mkLambda ty p ce = do+    v <- newSysLocalDs ty+    let errMsg = text "DsListComp.deLambda: internal error!"+        ce'ty  = exprType ce+    cerr <- mkErrorAppDs pAT_ERROR_ID ce'ty errMsg+    res <- matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr+    return (mkLams [v] res, ce'ty)++-- obtain the element type of the parallel array produced by the given Core+-- expression+--+parrElemType   :: CoreExpr -> Type+parrElemType e  =+  case splitTyConApp_maybe (exprType e) of+    Just (tycon, [ty]) | tycon == parrTyCon -> ty+    _                                                     -> panic+      "DsListComp.parrElemType: not a parallel array type"++-- Translation for monad comprehensions++-- Entry point for monad comprehension desugaring+dsMonadComp :: [ExprLStmt Id] -> DsM CoreExpr+dsMonadComp stmts = dsMcStmts stmts++dsMcStmts :: [ExprLStmt Id] -> DsM CoreExpr+dsMcStmts []                    = panic "dsMcStmts"+dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)++---------------+dsMcStmt :: ExprStmt Id -> [ExprLStmt Id] -> DsM CoreExpr++dsMcStmt (LastStmt body _ ret_op) stmts+  = ASSERT( null stmts )+    do { body' <- dsLExpr body+       ; dsSyntaxExpr ret_op [body'] }++--   [ .. | let binds, stmts ]+dsMcStmt (LetStmt binds) stmts+  = do { rest <- dsMcStmts stmts+       ; dsLocalBinds binds rest }++--   [ .. | a <- m, stmts ]+dsMcStmt (BindStmt pat rhs bind_op fail_op bind_ty) stmts+  = do { rhs' <- dsLExpr rhs+       ; dsMcBindStmt pat rhs' bind_op fail_op bind_ty stmts }++-- Apply `guard` to the `exp` expression+--+--   [ .. | exp, stmts ]+--+dsMcStmt (BodyStmt exp then_exp guard_exp _) stmts+  = do { exp'       <- dsLExpr exp+       ; rest       <- dsMcStmts stmts+       ; guard_exp' <- dsSyntaxExpr guard_exp [exp']+       ; dsSyntaxExpr then_exp [guard_exp', rest] }++-- Group statements desugar like this:+--+--   [| (q, then group by e using f); rest |]+--   --->  f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup ->+--         case unzip n_tup of qv' -> [| rest |]+--+-- where   variables (v1:t1, ..., vk:tk) are bound by q+--         qv = (v1, ..., vk)+--         qt = (t1, ..., tk)+--         (>>=) :: m2 a -> (a -> m3 b) -> m3 b+--         f :: forall a. (a -> t) -> m1 a -> m2 (n a)+--         n_tup :: n qt+--         unzip :: n qt -> (n t1, ..., n tk)    (needs Functor n)++dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs+                    , trS_by = by, trS_using = using+                    , trS_ret = return_op, trS_bind = bind_op+                    , trS_bind_arg_ty = n_tup_ty'  -- n (a,b,c)+                    , trS_fmap = fmap_op, trS_form = form }) stmts_rest+  = do { let (from_bndrs, to_bndrs) = unzip bndrs++       ; let from_bndr_tys = map idType from_bndrs     -- Types ty+++       -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders+       ; expr' <- dsInnerMonadComp stmts from_bndrs return_op++       -- Work out what arguments should be supplied to that expression: i.e. is an extraction+       -- function required? If so, create that desugared function and add to arguments+       ; usingExpr' <- dsLExpr using+       ; usingArgs' <- case by of+                         Nothing   -> return [expr']+                         Just by_e -> do { by_e' <- dsLExpr by_e+                                         ; lam' <- matchTuple from_bndrs by_e'+                                         ; return [lam', expr'] }++       -- Generate the expressions to build the grouped list+       -- Build a pattern that ensures the consumer binds into the NEW binders,+       -- which hold monads rather than single values+       ; let tup_n_ty' = mkBigCoreVarTupTy to_bndrs++       ; body        <- dsMcStmts stmts_rest+       ; n_tup_var'  <- newSysLocalDsNoLP n_tup_ty'+       ; tup_n_var'  <- newSysLocalDs tup_n_ty'+       ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys+       ; us          <- newUniqueSupply+       ; let rhs'  = mkApps usingExpr' usingArgs'+             body' = mkTupleCase us to_bndrs body tup_n_var' tup_n_expr'++       ; dsSyntaxExpr bind_op [rhs', Lam n_tup_var' body'] }++-- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel+-- statements, for example:+--+--   [ body | qs1 | qs2 | qs3 ]+--     ->  [ body | (bndrs1, (bndrs2, bndrs3))+--                     <- [bndrs1 | qs1] `mzip` ([bndrs2 | qs2] `mzip` [bndrs3 | qs3]) ]+--+-- where `mzip` has type+--   mzip :: forall a b. m a -> m b -> m (a,b)+-- NB: we need a polymorphic mzip because we call it several times++dsMcStmt (ParStmt blocks mzip_op bind_op bind_ty) stmts_rest+ = do  { exps_w_tys  <- mapM ds_inner blocks   -- Pairs (exp :: m ty, ty)+       ; mzip_op'    <- dsExpr mzip_op++       ; let -- The pattern variables+             pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ bs _ <- blocks]+             -- Pattern with tuples of variables+             -- [v1,v2,v3]  =>  (v1, (v2, v3))+             pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats+             (rhs, _) = foldr1 (\(e1,t1) (e2,t2) ->+                                 (mkApps mzip_op' [Type t1, Type t2, e1, e2],+                                  mkBoxedTupleTy [t1,t2]))+                               exps_w_tys++       ; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest }+  where+    ds_inner (ParStmtBlock stmts bndrs return_op)+       = do { exp <- dsInnerMonadComp stmts bndrs return_op+            ; return (exp, mkBigCoreVarTupTy bndrs) }++dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)+++matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr+-- (matchTuple [a,b,c] body)+--       returns the Core term+--  \x. case x of (a,b,c) -> body+matchTuple ids body+  = do { us <- newUniqueSupply+       ; tup_id <- newSysLocalDs (mkBigCoreVarTupTy ids)+       ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) }++-- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a+-- desugared `CoreExpr`+dsMcBindStmt :: LPat Id+             -> CoreExpr        -- ^ the desugared rhs of the bind statement+             -> SyntaxExpr Id+             -> SyntaxExpr Id+             -> Type            -- ^ S in (>>=) :: Q -> (R -> S) -> T+             -> [ExprLStmt Id]+             -> DsM CoreExpr+dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts+  = do  { body     <- dsMcStmts stmts+        ; var      <- selectSimpleMatchVarL pat+        ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat+                                  res1_ty (cantFailMatchResult body)+        ; match_code <- handle_failure pat match fail_op+        ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }++  where+    -- In a monad comprehension expression, pattern-match failure just calls+    -- the monadic `fail` rather than throwing an exception+    handle_failure pat match fail_op+      | matchCanFail match+        = do { dflags <- getDynFlags+             ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)+             ; fail_expr <- dsSyntaxExpr fail_op [fail_msg]+             ; extractMatchResult match fail_expr }+      | otherwise+        = extractMatchResult match (error "It can't fail")++    mk_fail_msg :: DynFlags -> Located e -> String+    mk_fail_msg dflags pat+        = "Pattern match failure in monad comprehension at " +++          showPpr dflags (getLoc pat)++-- Desugar nested monad comprehensions, for example in `then..` constructs+--    dsInnerMonadComp quals [a,b,c] ret_op+-- returns the desugaring of+--       [ (a,b,c) | quals ]++dsInnerMonadComp :: [ExprLStmt Id]+                 -> [Id]            -- Return a tuple of these variables+                 -> SyntaxExpr Id   -- The monomorphic "return" operator+                 -> DsM CoreExpr+dsInnerMonadComp stmts bndrs ret_op+  = dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTupId bndrs) False ret_op)])+++-- The `unzip` function for `GroupStmt` in a monad comprehensions+--+--   unzip :: m (a,b,..) -> (m a,m b,..)+--   unzip m_tuple = ( liftM selN1 m_tuple+--                   , liftM selN2 m_tuple+--                   , .. )+--+--   mkMcUnzipM fmap ys [t1, t2]+--     = ( fmap (selN1 :: (t1, t2) -> t1) ys+--       , fmap (selN2 :: (t1, t2) -> t2) ys )++mkMcUnzipM :: TransForm+           -> HsExpr TcId       -- fmap+           -> Id                -- Of type n (a,b,c)+           -> [Type]            -- [a,b,c]   (not levity-polymorphic)+           -> DsM CoreExpr      -- Of type (n a, n b, n c)+mkMcUnzipM ThenForm _ ys _+  = return (Var ys) -- No unzipping to do++mkMcUnzipM _ fmap_op ys elt_tys+  = do { fmap_op' <- dsExpr fmap_op+       ; xs       <- mapM newSysLocalDs elt_tys+       ; let tup_ty = mkBigCoreTupTy elt_tys+       ; tup_xs   <- newSysLocalDs tup_ty++       ; let mk_elt i = mkApps fmap_op'  -- fmap :: forall a b. (a -> b) -> n a -> n b+                           [ Type tup_ty, Type (getNth elt_tys i)+                           , mk_sel i, Var ys]++             mk_sel n = Lam tup_xs $+                        mkTupleSelector xs (getNth xs n) tup_xs (Var tup_xs)++       ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) }
+ deSugar/DsMeta.hs view
@@ -0,0 +1,2513 @@+{-# LANGUAGE CPP, TypeFamilies #-}++-----------------------------------------------------------------------------+--+-- (c) The University of Glasgow 2006+--+-- The purpose of this module is to transform an HsExpr into a CoreExpr which+-- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the+-- input HsExpr. We do this in the DsM monad, which supplies access to+-- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.+--+-- It also defines a bunch of knownKeyNames, in the same way as is done+-- in prelude/PrelNames.  It's much more convenient to do it here, because+-- otherwise we have to recompile PrelNames whenever we add a Name, which is+-- a Royal Pain (triggers other recompilation).+-----------------------------------------------------------------------------++module DsMeta( dsBracket ) where++#include "HsVersions.h"++import {-# SOURCE #-}   DsExpr ( dsExpr )++import MatchLit+import DsMonad++import qualified Language.Haskell.TH as TH++import HsSyn+import Class+import PrelNames+-- To avoid clashes with DsMeta.varName we must make a local alias for+-- OccName.varName we do this by removing varName from the import of+-- OccName above, making a qualified instance of OccName and using+-- OccNameAlias.varName where varName ws previously used in this file.+import qualified OccName( isDataOcc, isVarOcc, isTcOcc )++import Module+import Id+import Name hiding( isVarOcc, isTcOcc, varName, tcName )+import THNames+import NameEnv+import NameSet+import TcType+import TyCon+import TysWiredIn+import CoreSyn+import MkCore+import CoreUtils+import SrcLoc+import Unique+import BasicTypes+import Outputable+import Bag+import DynFlags+import FastString+import ForeignCall+import Util+import Maybes+import MonadUtils++import Data.ByteString ( unpack )+import Control.Monad+import Data.List++-----------------------------------------------------------------------------+dsBracket :: HsBracket Name -> [PendingTcSplice] -> DsM CoreExpr+-- Returns a CoreExpr of type TH.ExpQ+-- The quoted thing is parameterised over Name, even though it has+-- been type checked.  We don't want all those type decorations!++dsBracket brack splices+  = dsExtendMetaEnv new_bit (do_brack brack)+  where+    new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendingTcSplice n e <- splices]++    do_brack (VarBr _ n) = do { MkC e1  <- lookupOcc n ; return e1 }+    do_brack (ExpBr e)   = do { MkC e1  <- repLE e     ; return e1 }+    do_brack (PatBr p)   = do { MkC p1  <- repTopP p   ; return p1 }+    do_brack (TypBr t)   = do { MkC t1  <- repLTy t    ; return t1 }+    do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }+    do_brack (DecBrL _)  = panic "dsBracket: unexpected DecBrL"+    do_brack (TExpBr e)  = do { MkC e1  <- repLE e     ; return e1 }++{- -------------- Examples --------------------++  [| \x -> x |]+====>+  gensym (unpackString "x"#) `bindQ` \ x1::String ->+  lam (pvar x1) (var x1)+++  [| \x -> $(f [| x |]) |]+====>+  gensym (unpackString "x"#) `bindQ` \ x1::String ->+  lam (pvar x1) (f (var x1))+-}+++-------------------------------------------------------+--                      Declarations+-------------------------------------------------------++repTopP :: LPat Name -> DsM (Core TH.PatQ)+repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)+                 ; pat' <- addBinds ss (repLP pat)+                 ; wrapGenSyms ss pat' }++repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))+repTopDs group@(HsGroup { hs_valds   = valds+                        , hs_splcds  = splcds+                        , hs_tyclds  = tyclds+                        , hs_derivds = derivds+                        , hs_fixds   = fixds+                        , hs_defds   = defds+                        , hs_fords   = fords+                        , hs_warnds  = warnds+                        , hs_annds   = annds+                        , hs_ruleds  = ruleds+                        , hs_vects   = vects+                        , hs_docs    = docs })+ = do { let { bndrs  = hsSigTvBinders valds+                       ++ hsGroupBinders group+                       ++ hsPatSynSelectors valds+            ; instds = tyclds >>= group_instds } ;+        ss <- mkGenSyms bndrs ;++        -- Bind all the names mainly to avoid repeated use of explicit strings.+        -- Thus we get+        --      do { t :: String <- genSym "T" ;+        --           return (Data t [] ...more t's... }+        -- The other important reason is that the output must mention+        -- only "T", not "Foo:T" where Foo is the current module++        decls <- addBinds ss (+                  do { val_ds   <- rep_val_binds valds+                     ; _        <- mapM no_splice splcds+                     ; tycl_ds  <- mapM repTyClD (tyClGroupTyClDecls tyclds)+                     ; role_ds  <- mapM repRoleD (concatMap group_roles tyclds)+                     ; inst_ds  <- mapM repInstD instds+                     ; deriv_ds <- mapM repStandaloneDerivD derivds+                     ; fix_ds   <- mapM repFixD fixds+                     ; _        <- mapM no_default_decl defds+                     ; for_ds   <- mapM repForD fords+                     ; _        <- mapM no_warn (concatMap (wd_warnings . unLoc)+                                                           warnds)+                     ; ann_ds   <- mapM repAnnD annds+                     ; rule_ds  <- mapM repRuleD (concatMap (rds_rules . unLoc)+                                                            ruleds)+                     ; _        <- mapM no_vect vects+                     ; _        <- mapM no_doc docs++                        -- more needed+                     ;  return (de_loc $ sort_by_loc $+                                val_ds ++ catMaybes tycl_ds ++ role_ds+                                       ++ (concat fix_ds)+                                       ++ inst_ds ++ rule_ds ++ for_ds+                                       ++ ann_ds ++ deriv_ds) }) ;++        decl_ty <- lookupType decQTyConName ;+        let { core_list = coreList' decl_ty decls } ;++        dec_ty <- lookupType decTyConName ;+        q_decs  <- repSequenceQ dec_ty core_list ;++        wrapGenSyms ss q_decs+      }+  where+    no_splice (L loc _)+      = notHandledL loc "Splices within declaration brackets" empty+    no_default_decl (L loc decl)+      = notHandledL loc "Default declarations" (ppr decl)+    no_warn (L loc (Warning thing _))+      = notHandledL loc "WARNING and DEPRECATION pragmas" $+                    text "Pragma for declaration of" <+> ppr thing+    no_vect (L loc decl)+      = notHandledL loc "Vectorisation pragmas" (ppr decl)+    no_doc (L loc _)+      = notHandledL loc "Haddock documentation" empty++hsSigTvBinders :: HsValBinds Name -> [Name]+-- See Note [Scoped type variables in bindings]+hsSigTvBinders binds+  = concatMap get_scoped_tvs sigs+  where+    get_scoped_tvs :: LSig Name -> [Name]+    -- Both implicit and explicit quantified variables+    -- We need the implicit ones for   f :: forall (a::k). blah+    --    here 'k' scopes too+    get_scoped_tvs (L _ (TypeSig _ sig))+       | HsIB { hsib_vars = implicit_vars+              , hsib_body = hs_ty } <- hswc_body sig+       , (explicit_vars, _) <- splitLHsForAllTy hs_ty+       = implicit_vars ++ map hsLTyVarName explicit_vars+    get_scoped_tvs _ = []++    sigs = case binds of+             ValBindsIn  _ sigs -> sigs+             ValBindsOut _ sigs -> sigs++{- Notes++Note [Scoped type variables in bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f :: forall a. a -> a+   f x = x::a+Here the 'forall a' brings 'a' into scope over the binding group.+To achieve this we++  a) Gensym a binding for 'a' at the same time as we do one for 'f'+     collecting the relevant binders with hsSigTvBinders++  b) When processing the 'forall', don't gensym++The relevant places are signposted with references to this Note++Note [Binders and occurrences]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we desugar [d| data T = MkT |]+we want to get+        Data "T" [] [Con "MkT" []] []+and *not*+        Data "Foo:T" [] [Con "Foo:MkT" []] []+That is, the new data decl should fit into whatever new module it is+asked to fit in.   We do *not* clone, though; no need for this:+        Data "T79" ....++But if we see this:+        data T = MkT+        foo = reifyDecl T++then we must desugar to+        foo = Data "Foo:T" [] [Con "Foo:MkT" []] []++So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.+And we use lookupOcc, rather than lookupBinder+in repTyClD and repC.++Note [Don't quantify implicit type variables in quotes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If you're not careful, it's suprisingly easy to take this quoted declaration:++  [d| idProxy :: forall proxy (b :: k). proxy b -> proxy b+      idProxy x = x+    |]++and have Template Haskell turn it into this:++  idProxy :: forall k proxy (b :: k). proxy b -> proxy b+  idProxy x = x++Notice that we explicitly quantified the variable `k`! This is quite bad, as the+latter declaration requires -XTypeInType, while the former does not. Not to+mention that the latter declaration isn't even what the user wrote in the+first place.++Usually, the culprit behind these bugs is taking implicitly quantified type+variables (often from the hsib_vars field of HsImplicitBinders) and putting+them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123.+-}++-- represent associated family instances+--+repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))++repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $ repFamilyDecl (L loc fam)++repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))+  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]+       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->+                repSynDecl tc1 bndrs rhs+       ; return (Just (loc, dec)) }++repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn }))+  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]+       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->+                repDataDefn tc1 bndrs Nothing defn+       ; return (Just (loc, dec)) }++repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,+                             tcdTyVars = tvs, tcdFDs = fds,+                             tcdSigs = sigs, tcdMeths = meth_binds,+                             tcdATs = ats, tcdATDefs = atds }))+  = do { cls1 <- lookupLOcc cls         -- See note [Binders and occurrences]+       ; dec  <- addTyVarBinds tvs $ \bndrs ->+           do { cxt1   <- repLContext cxt+              ; sigs1  <- rep_sigs sigs+              ; binds1 <- rep_binds meth_binds+              ; fds1   <- repLFunDeps fds+              ; ats1   <- repFamilyDecls ats+              ; atds1  <- repAssocTyFamDefaults atds+              ; decls1 <- coreList decQTyConName (ats1 ++ atds1 ++ sigs1 ++ binds1)+              ; repClass cxt1 cls1 bndrs fds1 decls1+              }+       ; return $ Just (loc, dec)+       }++-------------------------+repRoleD :: LRoleAnnotDecl Name -> DsM (SrcSpan, Core TH.DecQ)+repRoleD (L loc (RoleAnnotDecl tycon roles))+  = do { tycon1 <- lookupLOcc tycon+       ; roles1 <- mapM repRole roles+       ; roles2 <- coreList roleTyConName roles1+       ; dec <- repRoleAnnotD tycon1 roles2+       ; return (loc, dec) }++-------------------------+repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr]+            -> Maybe (Core [TH.TypeQ])+            -> HsDataDefn Name+            -> DsM (Core TH.DecQ)+repDataDefn tc bndrs opt_tys+          (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig+                      , dd_cons = cons, dd_derivs = mb_derivs })+  = do { cxt1     <- repLContext cxt+       ; derivs1  <- repDerivs mb_derivs+       ; case (new_or_data, cons) of+           (NewType, [con])  -> do { con'  <- repC con+                                   ; ksig' <- repMaybeLKind ksig+                                   ; repNewtype cxt1 tc bndrs opt_tys ksig' con'+                                                derivs1 }+           (NewType, _) -> failWithDs (text "Multiple constructors for newtype:"+                                       <+> pprQuotedList+                                       (getConNames $ unLoc $ head cons))+           (DataType, _) -> do { ksig' <- repMaybeLKind ksig+                               ; consL <- mapM repC cons+                               ; cons1 <- coreList conQTyConName consL+                               ; repData cxt1 tc bndrs opt_tys ksig' cons1+                                         derivs1 }+       }++repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr]+           -> LHsType Name+           -> DsM (Core TH.DecQ)+repSynDecl tc bndrs ty+  = do { ty1 <- repLTy ty+       ; repTySyn tc bndrs ty1 }++repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ)+repFamilyDecl decl@(L loc (FamilyDecl { fdInfo      = info,+                                        fdLName     = tc,+                                        fdTyVars    = tvs,+                                        fdResultSig = L _ resultSig,+                                        fdInjectivityAnn = injectivity }))+  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]+       ; let mkHsQTvs :: [LHsTyVarBndr Name] -> LHsQTyVars Name+             mkHsQTvs tvs = HsQTvs { hsq_implicit = [], hsq_explicit = tvs+                                   , hsq_dependent = emptyNameSet }+             resTyVar = case resultSig of+                     TyVarSig bndr -> mkHsQTvs [bndr]+                     _             -> mkHsQTvs []+       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->+                addTyClTyVarBinds resTyVar $ \_ ->+           case info of+             ClosedTypeFamily Nothing ->+                 notHandled "abstract closed type family" (ppr decl)+             ClosedTypeFamily (Just eqns) ->+               do { eqns1  <- mapM repTyFamEqn eqns+                  ; eqns2  <- coreList tySynEqnQTyConName eqns1+                  ; result <- repFamilyResultSig resultSig+                  ; inj    <- repInjectivityAnn injectivity+                  ; repClosedFamilyD tc1 bndrs result inj eqns2 }+             OpenTypeFamily ->+               do { result <- repFamilyResultSig resultSig+                  ; inj    <- repInjectivityAnn injectivity+                  ; repOpenFamilyD tc1 bndrs result inj }+             DataFamily ->+               do { kind <- repFamilyResultSigToMaybeKind resultSig+                  ; repDataFamilyD tc1 bndrs kind }+       ; return (loc, dec)+       }++-- | Represent result signature of a type family+repFamilyResultSig :: FamilyResultSig Name -> DsM (Core TH.FamilyResultSig)+repFamilyResultSig  NoSig          = repNoSig+repFamilyResultSig (KindSig ki)    = do { ki' <- repLKind ki+                                        ; repKindSig ki' }+repFamilyResultSig (TyVarSig bndr) = do { bndr' <- repTyVarBndr bndr+                                        ; repTyVarSig bndr' }++-- | Represent result signature using a Maybe Kind. Used with data families,+-- where the result signature can be either missing or a kind but never a named+-- result variable.+repFamilyResultSigToMaybeKind :: FamilyResultSig Name+                              -> DsM (Core (Maybe TH.Kind))+repFamilyResultSigToMaybeKind NoSig =+    do { coreNothing kindTyConName }+repFamilyResultSigToMaybeKind (KindSig ki) =+    do { ki' <- repLKind ki+       ; coreJust kindTyConName ki' }+repFamilyResultSigToMaybeKind _ = panic "repFamilyResultSigToMaybeKind"++-- | Represent injectivity annotation of a type family+repInjectivityAnn :: Maybe (LInjectivityAnn Name)+                  -> DsM (Core (Maybe TH.InjectivityAnn))+repInjectivityAnn Nothing =+    do { coreNothing injAnnTyConName }+repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) =+    do { lhs'   <- lookupBinder (unLoc lhs)+       ; rhs1   <- mapM (lookupBinder . unLoc) rhs+       ; rhs2   <- coreList nameTyConName rhs1+       ; injAnn <- rep2 injectivityAnnName [unC lhs', unC rhs2]+       ; coreJust injAnnTyConName injAnn }++repFamilyDecls :: [LFamilyDecl Name] -> DsM [Core TH.DecQ]+repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)++repAssocTyFamDefaults :: [LTyFamDefltEqn Name] -> DsM [Core TH.DecQ]+repAssocTyFamDefaults = mapM rep_deflt+  where+     -- very like repTyFamEqn, but different in the details+    rep_deflt :: LTyFamDefltEqn Name -> DsM (Core TH.DecQ)+    rep_deflt (L _ (TyFamEqn { tfe_tycon = tc+                             , tfe_pats  = bndrs+                             , tfe_rhs   = rhs }))+      = addTyClTyVarBinds bndrs $ \ _ ->+        do { tc1  <- lookupLOcc tc+           ; tys1 <- repLTys (hsLTyVarBndrsToTypes bndrs)+           ; tys2 <- coreList typeQTyConName tys1+           ; rhs1 <- repLTy rhs+           ; eqn1 <- repTySynEqn tys2 rhs1+           ; repTySynInst tc1 eqn1 }++-------------------------+-- represent fundeps+--+repLFunDeps :: [Located (FunDep (Located Name))] -> DsM (Core [TH.FunDep])+repLFunDeps fds = repList funDepTyConName repLFunDep fds++repLFunDep :: Located (FunDep (Located Name)) -> DsM (Core TH.FunDep)+repLFunDep (L _ (xs, ys))+   = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs+        ys' <- repList nameTyConName (lookupBinder . unLoc) ys+        repFunDep xs' ys'++-- Represent instance declarations+--+repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)+repInstD (L loc (TyFamInstD { tfid_inst = fi_decl }))+  = do { dec <- repTyFamInstD fi_decl+       ; return (loc, dec) }+repInstD (L loc (DataFamInstD { dfid_inst = fi_decl }))+  = do { dec <- repDataFamInstD fi_decl+       ; return (loc, dec) }+repInstD (L loc (ClsInstD { cid_inst = cls_decl }))+  = do { dec <- repClsInstD cls_decl+       ; return (loc, dec) }++repClsInstD :: ClsInstDecl Name -> DsM (Core TH.DecQ)+repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds+                         , cid_sigs = prags, cid_tyfam_insts = ats+                         , cid_datafam_insts = adts+                         , cid_overlap_mode = overlap+                         })+  = addSimpleTyVarBinds tvs $+            -- We must bring the type variables into scope, so their+            -- occurrences don't fail, even though the binders don't+            -- appear in the resulting data structure+            --+            -- But we do NOT bring the binders of 'binds' into scope+            -- because they are properly regarded as occurrences+            -- For example, the method names should be bound to+            -- the selector Ids, not to fresh names (Trac #5410)+            --+            do { cxt1 <- repLContext cxt+               ; inst_ty1 <- repLTy inst_ty+               ; binds1 <- rep_binds binds+               ; prags1 <- rep_sigs prags+               ; ats1 <- mapM (repTyFamInstD . unLoc) ats+               ; adts1 <- mapM (repDataFamInstD . unLoc) adts+               ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)+               ; rOver <- repOverlap (fmap unLoc overlap)+               ; repInst rOver cxt1 inst_ty1 decls }+ where+   (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty++repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ)+repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat+                                      , deriv_type     = ty }))+  = do { dec <- addSimpleTyVarBinds tvs $+                do { cxt'     <- repLContext cxt+                   ; strat'   <- repDerivStrategy strat+                   ; inst_ty' <- repLTy inst_ty+                   ; repDeriv strat' cxt' inst_ty' }+       ; return (loc, dec) }+  where+    (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty++repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)+repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })+  = do { let tc_name = tyFamInstDeclLName decl+       ; tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]+       ; eqn1 <- repTyFamEqn eqn+       ; repTySynInst tc eqn1 }++repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)+repTyFamEqn (L _ (TyFamEqn { tfe_pats = HsIB { hsib_body = tys+                                             , hsib_vars = var_names }+                           , tfe_rhs = rhs }))+  = do { let hs_tvs = HsQTvs { hsq_implicit = var_names+                             , hsq_explicit = []+                             , hsq_dependent = emptyNameSet }   -- Yuk+       ; addTyClTyVarBinds hs_tvs $ \ _ ->+         do { tys1 <- repLTys tys+            ; tys2 <- coreList typeQTyConName tys1+            ; rhs1 <- repLTy rhs+            ; repTySynEqn tys2 rhs1 } }++repDataFamInstD :: DataFamInstDecl Name -> DsM (Core TH.DecQ)+repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name+                                 , dfid_pats = HsIB { hsib_body = tys, hsib_vars = var_names }+                                 , dfid_defn = defn })+  = do { tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]+       ; let hs_tvs = HsQTvs { hsq_implicit = var_names+                             , hsq_explicit = []+                             , hsq_dependent = emptyNameSet }   -- Yuk+       ; addTyClTyVarBinds hs_tvs $ \ bndrs ->+         do { tys1 <- repList typeQTyConName repLTy tys+            ; repDataDefn tc bndrs (Just tys1) defn } }++repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)+repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ+                              , fd_fi = CImport (L _ cc) (L _ s) mch cis _ }))+ = do MkC name' <- lookupLOcc name+      MkC typ' <- repHsSigType typ+      MkC cc' <- repCCallConv cc+      MkC s' <- repSafety s+      cis' <- conv_cimportspec cis+      MkC str <- coreStringLit (static ++ chStr ++ cis')+      dec <- rep2 forImpDName [cc', s', str, name', typ']+      return (loc, dec)+ where+    conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))+    conv_cimportspec (CFunction DynamicTarget) = return "dynamic"+    conv_cimportspec (CFunction (StaticTarget _ fs _ True))+                            = return (unpackFS fs)+    conv_cimportspec (CFunction (StaticTarget _ _  _ False))+                            = panic "conv_cimportspec: values not supported yet"+    conv_cimportspec CWrapper = return "wrapper"+    -- these calling conventions do not support headers and the static keyword+    raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv+    static = case cis of+                 CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static "+                 _ -> ""+    chStr = case mch of+            Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "+            _ -> ""+repForD decl = notHandled "Foreign declaration" (ppr decl)++repCCallConv :: CCallConv -> DsM (Core TH.Callconv)+repCCallConv CCallConv          = rep2 cCallName []+repCCallConv StdCallConv        = rep2 stdCallName []+repCCallConv CApiConv           = rep2 cApiCallName []+repCCallConv PrimCallConv       = rep2 primCallName []+repCCallConv JavaScriptCallConv = rep2 javaScriptCallName []++repSafety :: Safety -> DsM (Core TH.Safety)+repSafety PlayRisky = rep2 unsafeName []+repSafety PlayInterruptible = rep2 interruptibleName []+repSafety PlaySafe = rep2 safeName []++repFixD :: LFixitySig Name -> DsM [(SrcSpan, Core TH.DecQ)]+repFixD (L loc (FixitySig names (Fixity _ prec dir)))+  = do { MkC prec' <- coreIntLit prec+       ; let rep_fn = case dir of+                        InfixL -> infixLDName+                        InfixR -> infixRDName+                        InfixN -> infixNDName+       ; let do_one name+              = do { MkC name' <- lookupLOcc name+                   ; dec <- rep2 rep_fn [prec', name']+                   ; return (loc,dec) }+       ; mapM do_one names }++repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ)+repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))+  = do { let bndr_names = concatMap ruleBndrNames bndrs+       ; ss <- mkGenSyms bndr_names+       ; rule1 <- addBinds ss $+                  do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs+                     ; n'   <- coreStringLit $ unpackFS $ snd $ unLoc n+                     ; act' <- repPhases act+                     ; lhs' <- repLE lhs+                     ; rhs' <- repLE rhs+                     ; repPragRule n' bndrs' lhs' rhs' act' }+       ; rule2 <- wrapGenSyms ss rule1+       ; return (loc, rule2) }++ruleBndrNames :: LRuleBndr Name -> [Name]+ruleBndrNames (L _ (RuleBndr n))      = [unLoc n]+ruleBndrNames (L _ (RuleBndrSig n sig))+  | HsWC { hswc_body = HsIB { hsib_vars = vars }} <- sig+  = unLoc n : vars++repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ)+repRuleBndr (L _ (RuleBndr n))+  = do { MkC n' <- lookupLBinder n+       ; rep2 ruleVarName [n'] }+repRuleBndr (L _ (RuleBndrSig n sig))+  = do { MkC n'  <- lookupLBinder n+       ; MkC ty' <- repLTy (hsSigWcType sig)+       ; rep2 typedRuleVarName [n', ty'] }++repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ)+repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp)))+  = do { target <- repAnnProv ann_prov+       ; exp'   <- repE exp+       ; dec    <- repPragAnn target exp'+       ; return (loc, dec) }++repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget)+repAnnProv (ValueAnnProvenance (L _ n))+  = do { MkC n' <- globalVar n  -- ANNs are allowed only at top-level+       ; rep2 valueAnnotationName [ n' ] }+repAnnProv (TypeAnnProvenance (L _ n))+  = do { MkC n' <- globalVar n+       ; rep2 typeAnnotationName [ n' ] }+repAnnProv ModuleAnnProvenance+  = rep2 moduleAnnotationName []++-------------------------------------------------------+--                      Constructors+-------------------------------------------------------++repC :: LConDecl Name -> DsM (Core TH.ConQ)+repC (L _ (ConDeclH98 { con_name = con+                      , con_qvars = Nothing, con_cxt = Nothing+                      , con_details = details }))+  = repDataCon con details++repC (L _ (ConDeclH98 { con_name = con+                      , con_qvars = mcon_tvs, con_cxt = mcxt+                      , con_details = details }))+  = do { let con_tvs = fromMaybe emptyLHsQTvs mcon_tvs+             ctxt    = unLoc $ fromMaybe (noLoc []) mcxt+       ; addTyVarBinds con_tvs $ \ ex_bndrs ->+         do { c'    <- repDataCon con details+            ; ctxt' <- repContext ctxt+            ; if isEmptyLHsQTvs con_tvs && null ctxt+              then return c'+              else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])+            }+       }++repC (L _ (ConDeclGADT { con_names = cons+                       , con_type = res_ty@(HsIB { hsib_vars = imp_tvs })}))+  | (details, res_ty', L _ [] , []) <- gadtDetails+  , [] <- imp_tvs+    -- no implicit or explicit variables, no context = no need for a forall+  = do { let doc = text "In the constructor for " <+> ppr (head cons)+       ; (hs_details, gadt_res_ty) <-+           updateGadtResult failWithDs doc details res_ty'+       ; repGadtDataCons cons hs_details gadt_res_ty }++  | (details,res_ty',ctxt, exp_tvs) <- gadtDetails+  = do { let doc = text "In the constructor for " <+> ppr (head cons)+             con_tvs = HsQTvs { hsq_implicit  = imp_tvs+                              , hsq_explicit  = exp_tvs+                              , hsq_dependent = emptyNameSet }+             -- NB: Don't put imp_tvs into the hsq_explicit field above+             -- See Note [Don't quantify implicit type variables in quotes]+       ; addTyVarBinds con_tvs $ \ ex_bndrs -> do+       { (hs_details, gadt_res_ty) <-+           updateGadtResult failWithDs doc details res_ty'+       ; c'    <- repGadtDataCons cons hs_details gadt_res_ty+       ; ctxt' <- repContext (unLoc ctxt)+       ; if null exp_tvs && null (unLoc ctxt)+         then return c'+         else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } }+  where+     gadtDetails = gadtDeclDetails res_ty++repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ)+repSrcUnpackedness SrcUnpack   = rep2 sourceUnpackName         []+repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackName       []+repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessName []++repSrcStrictness :: SrcStrictness -> DsM (Core TH.SourceStrictnessQ)+repSrcStrictness SrcLazy     = rep2 sourceLazyName         []+repSrcStrictness SrcStrict   = rep2 sourceStrictName       []+repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName []++repBangTy :: LBangType Name -> DsM (Core (TH.BangTypeQ))+repBangTy ty = do+  MkC u <- repSrcUnpackedness su'+  MkC s <- repSrcStrictness ss'+  MkC b <- rep2 bangName [u, s]+  MkC t <- repLTy ty'+  rep2 bangTypeName [b, t]+  where+    (su', ss', ty') = case ty of+            L _ (HsBangTy (HsSrcBang _ su ss) ty) -> (su, ss, ty)+            _ -> (NoSrcUnpack, NoSrcStrict, ty)++-------------------------------------------------------+--                      Deriving clauses+-------------------------------------------------------++repDerivs :: HsDeriving Name -> DsM (Core [TH.DerivClauseQ])+repDerivs (L _ clauses) = repList derivClauseQTyConName repDerivClause clauses++repDerivClause :: LHsDerivingClause Name+               -> DsM (Core TH.DerivClauseQ)+repDerivClause (L _ (HsDerivingClause { deriv_clause_strategy = dcs+                                      , deriv_clause_tys      = L _ dct }))+  = do MkC dcs' <- repDerivStrategy dcs+       MkC dct' <- repList typeQTyConName (rep_deriv_ty . hsSigType) dct+       rep2 derivClauseName [dcs',dct']+  where+    rep_deriv_ty :: LHsType Name -> DsM (Core TH.TypeQ)+    rep_deriv_ty (L _ ty) = repTy ty++-------------------------------------------------------+--   Signatures in a class decl, or a group of bindings+-------------------------------------------------------++rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]+rep_sigs sigs = do locs_cores <- rep_sigs' sigs+                   return $ de_loc $ sort_by_loc locs_cores++rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]+        -- We silently ignore ones we don't recognise+rep_sigs' = concatMapM rep_sig++rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]+rep_sig (L loc (TypeSig nms ty))      = mapM (rep_wc_ty_sig sigDName loc ty) nms+rep_sig (L loc (PatSynSig nms ty))    = mapM (rep_patsyn_ty_sig loc ty) nms+rep_sig (L loc (ClassOpSig is_deflt nms ty))+  | is_deflt                          = mapM (rep_ty_sig defaultSigDName loc ty) nms+  | otherwise                         = mapM (rep_ty_sig sigDName loc ty) nms+rep_sig d@(L _ (IdSig {}))            = pprPanic "rep_sig IdSig" (ppr d)+rep_sig (L _   (FixSig {}))           = return [] -- fixity sigs at top level+rep_sig (L loc (InlineSig nm ispec))  = rep_inline nm ispec loc+rep_sig (L loc (SpecSig nm tys ispec))+  = concatMapM (\t -> rep_specialise nm t ispec loc) tys+rep_sig (L loc (SpecInstSig _ ty))    = rep_specialiseInst ty loc+rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty+rep_sig (L _   (SCCFunSig {}))        = notHandled "SCC pragmas" empty+rep_sig (L loc (CompleteMatchSig _st cls mty)) = rep_complete_sig cls mty loc+++rep_ty_sig :: Name -> SrcSpan -> LHsSigType Name -> Located Name+           -> DsM (SrcSpan, Core TH.DecQ)+rep_ty_sig mk_sig loc sig_ty nm+  = do { nm1 <- lookupLOcc nm+       ; ty1 <- repHsSigType sig_ty+       ; sig <- repProto mk_sig nm1 ty1+       ; return (loc, sig) }++rep_patsyn_ty_sig :: SrcSpan -> LHsSigType Name -> Located Name+                  -> DsM (SrcSpan, Core TH.DecQ)+-- represents a pattern synonym type signature;+-- see Note [Pattern synonym type signatures and Template Haskell] in Convert+rep_patsyn_ty_sig loc sig_ty nm+  = do { nm1 <- lookupLOcc nm+       ; ty1 <- repHsPatSynSigType sig_ty+       ; sig <- repProto patSynSigDName nm1 ty1+       ; return (loc, sig) }++rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType Name -> Located Name+              -> DsM (SrcSpan, Core TH.DecQ)+    -- We must special-case the top-level explicit for-all of a TypeSig+    -- See Note [Scoped type variables in bindings]+rep_wc_ty_sig mk_sig loc sig_ty nm+  | HsIB { hsib_body = hs_ty } <- hswc_body sig_ty+  , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy hs_ty+  = do { nm1 <- lookupLOcc nm+       ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)+                                     ; repTyVarBndrWithKind tv name }+       ; th_explicit_tvs <- repList tyVarBndrTyConName rep_in_scope_tv+                                    explicit_tvs+         -- NB: Don't pass any implicit type variables to repList above+         -- See Note [Don't quantify implicit type variables in quotes]++       ; th_ctxt <- repLContext ctxt+       ; th_ty   <- repLTy ty+       ; ty1 <- if null explicit_tvs && null (unLoc ctxt)+                then return th_ty+                else repTForall th_explicit_tvs th_ctxt th_ty+       ; sig <- repProto mk_sig nm1 ty1+       ; return (loc, sig) }++rep_inline :: Located Name+           -> InlinePragma      -- Never defaultInlinePragma+           -> SrcSpan+           -> DsM [(SrcSpan, Core TH.DecQ)]+rep_inline nm ispec loc+  = do { nm1    <- lookupLOcc nm+       ; inline <- repInline $ inl_inline ispec+       ; rm     <- repRuleMatch $ inl_rule ispec+       ; phases <- repPhases $ inl_act ispec+       ; pragma <- repPragInl nm1 inline rm phases+       ; return [(loc, pragma)]+       }++rep_specialise :: Located Name -> LHsSigType Name -> InlinePragma -> SrcSpan+               -> DsM [(SrcSpan, Core TH.DecQ)]+rep_specialise nm ty ispec loc+  = do { nm1 <- lookupLOcc nm+       ; ty1 <- repHsSigType ty+       ; phases <- repPhases $ inl_act ispec+       ; let inline = inl_inline ispec+       ; pragma <- if isEmptyInlineSpec inline+                   then -- SPECIALISE+                     repPragSpec nm1 ty1 phases+                   else -- SPECIALISE INLINE+                     do { inline1 <- repInline inline+                        ; repPragSpecInl nm1 ty1 inline1 phases }+       ; return [(loc, pragma)]+       }++rep_specialiseInst :: LHsSigType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]+rep_specialiseInst ty loc+  = do { ty1    <- repHsSigType ty+       ; pragma <- repPragSpecInst ty1+       ; return [(loc, pragma)] }++repInline :: InlineSpec -> DsM (Core TH.Inline)+repInline NoInline  = dataCon noInlineDataConName+repInline Inline    = dataCon inlineDataConName+repInline Inlinable = dataCon inlinableDataConName+repInline spec      = notHandled "repInline" (ppr spec)++repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)+repRuleMatch ConLike = dataCon conLikeDataConName+repRuleMatch FunLike = dataCon funLikeDataConName++repPhases :: Activation -> DsM (Core TH.Phases)+repPhases (ActiveBefore _ i) = do { MkC arg <- coreIntLit i+                                  ; dataCon' beforePhaseDataConName [arg] }+repPhases (ActiveAfter _ i)  = do { MkC arg <- coreIntLit i+                                  ; dataCon' fromPhaseDataConName [arg] }+repPhases _                  = dataCon allPhasesDataConName++rep_complete_sig :: Located [Located Name]+                 -> Maybe (Located Name)+                 -> SrcSpan+                 -> DsM [(SrcSpan, Core TH.DecQ)]+rep_complete_sig (L _ cls) mty loc+  = do { mty' <- rep_maybe_name mty+       ; cls' <- repList nameTyConName lookupLOcc cls+       ; sig <- repPragComplete cls' mty'+       ; return [(loc, sig)] }+  where+    rep_maybe_name Nothing = coreNothing nameTyConName+    rep_maybe_name (Just n) = do+      cn <- lookupLOcc n+      coreJust nameTyConName cn++-------------------------------------------------------+--                      Types+-------------------------------------------------------++addSimpleTyVarBinds :: [Name]                -- the binders to be added+                    -> DsM (Core (TH.Q a))   -- action in the ext env+                    -> DsM (Core (TH.Q a))+addSimpleTyVarBinds names thing_inside+  = do { fresh_names <- mkGenSyms names+       ; term <- addBinds fresh_names thing_inside+       ; wrapGenSyms fresh_names term }++addTyVarBinds :: LHsQTyVars Name                            -- the binders to be added+              -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))  -- action in the ext env+              -> DsM (Core (TH.Q a))+-- gensym a list of type variables and enter them into the meta environment;+-- the computations passed as the second argument is executed in that extended+-- meta environment and gets the *new* names on Core-level as an argument++addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs }) m+  = do { fresh_imp_names <- mkGenSyms imp_tvs+       ; fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs)+       ; let fresh_names = fresh_imp_names ++ fresh_exp_names+       ; term <- addBinds fresh_names $+                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr+                                     (exp_tvs `zip` fresh_exp_names)+                    ; m kbs }+       ; wrapGenSyms fresh_names term }+  where+    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)++addTyClTyVarBinds :: LHsQTyVars Name+                  -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))+                  -> DsM (Core (TH.Q a))++-- Used for data/newtype declarations, and family instances,+-- so that the nested type variables work right+--    instance C (T a) where+--      type W (T a) = blah+-- The 'a' in the type instance is the one bound by the instance decl+addTyClTyVarBinds tvs m+  = do { let tv_names = hsAllLTyVarNames tvs+       ; env <- dsGetMetaEnv+       ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)+            -- Make fresh names for the ones that are not already in scope+            -- This makes things work for family declarations++       ; term <- addBinds freshNames $+                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvExplicit tvs)+                    ; m kbs }++       ; wrapGenSyms freshNames term }+  where+    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)+                       ; repTyVarBndrWithKind tv v }++-- Produce kinded binder constructors from the Haskell tyvar binders+--+repTyVarBndrWithKind :: LHsTyVarBndr Name+                     -> Core TH.Name -> DsM (Core TH.TyVarBndr)+repTyVarBndrWithKind (L _ (UserTyVar _)) nm+  = repPlainTV nm+repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm+  = repLKind ki >>= repKindedTV nm++-- | Represent a type variable binder+repTyVarBndr :: LHsTyVarBndr Name -> DsM (Core TH.TyVarBndr)+repTyVarBndr (L _ (UserTyVar (L _ nm)) )= do { nm' <- lookupBinder nm+                                             ; repPlainTV nm' }+repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm+                                                  ; ki' <- repLKind ki+                                                  ; repKindedTV nm' ki' }++-- represent a type context+--+repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)+repLContext (L _ ctxt) = repContext ctxt++repContext :: HsContext Name -> DsM (Core TH.CxtQ)+repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt+                     repCtxt preds++repHsSigType :: LHsSigType Name -> DsM (Core TH.TypeQ)+repHsSigType (HsIB { hsib_vars = implicit_tvs+                   , hsib_body = body })+  | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body+  = addTyVarBinds (HsQTvs { hsq_implicit = implicit_tvs+                          , hsq_explicit = explicit_tvs+                          , hsq_dependent = emptyNameSet })+    -- NB: Don't pass implicit_tvs to the hsq_explicit field above+    -- See Note [Don't quantify implicit type variables in quotes]+                  $ \ th_explicit_tvs ->+    do { th_ctxt <- repLContext ctxt+       ; th_ty   <- repLTy ty+       ; if null explicit_tvs && null (unLoc ctxt)+         then return th_ty+         else repTForall th_explicit_tvs th_ctxt th_ty }++repHsPatSynSigType :: LHsSigType Name -> DsM (Core TH.TypeQ)+repHsPatSynSigType (HsIB { hsib_vars = implicit_tvs+                         , hsib_body = body })+  = addTyVarBinds (newTvs implicit_tvs univs) $ \th_univs ->+      addTyVarBinds (newTvs [] exis) $ \th_exis ->+    do { th_reqs  <- repLContext reqs+       ; th_provs <- repLContext provs+       ; th_ty    <- repLTy ty+       ; repTForall th_univs th_reqs =<< (repTForall th_exis th_provs th_ty) }+  where+    newTvs impl_tvs expl_tvs = HsQTvs+      { hsq_implicit  = impl_tvs+      , hsq_explicit  = expl_tvs+      , hsq_dependent = emptyNameSet }+    -- NB: Don't pass impl_tvs to the hsq_explicit field above+    -- See Note [Don't quantify implicit type variables in quotes]++    (univs, reqs, exis, provs, ty) = splitLHsPatSynTy body++repHsSigWcType :: LHsSigWcType Name -> DsM (Core TH.TypeQ)+repHsSigWcType (HsWC { hswc_body = sig1 })+  = repHsSigType sig1++-- yield the representation of a list of types+repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]+repLTys tys = mapM repLTy tys++-- represent a type+repLTy :: LHsType Name -> DsM (Core TH.TypeQ)+repLTy (L _ ty) = repTy ty++repForall :: HsType Name -> DsM (Core TH.TypeQ)+-- Arg of repForall is always HsForAllTy or HsQualTy+repForall ty+ | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty)+ = addTyVarBinds (HsQTvs { hsq_implicit = [], hsq_explicit = tvs+                         , hsq_dependent = emptyNameSet }) $ \bndrs ->+   do { ctxt1  <- repLContext ctxt+      ; ty1    <- repLTy tau+      ; repTForall bndrs ctxt1 ty1 }++repTy :: HsType Name -> DsM (Core TH.TypeQ)+repTy ty@(HsForAllTy {}) = repForall ty+repTy ty@(HsQualTy {})   = repForall ty++repTy (HsTyVar _ (L _ n))+  | isTvOcc occ   = do tv1 <- lookupOcc n+                       repTvar tv1+  | isDataOcc occ = do tc1 <- lookupOcc n+                       repPromotedDataCon tc1+  | n == eqTyConName = repTequality+  | otherwise     = do tc1 <- lookupOcc n+                       repNamedTyCon tc1+  where+    occ = nameOccName n++repTy (HsAppTy f a)         = do+                                f1 <- repLTy f+                                a1 <- repLTy a+                                repTapp f1 a1+repTy (HsFunTy f a)         = do+                                f1   <- repLTy f+                                a1   <- repLTy a+                                tcon <- repArrowTyCon+                                repTapps tcon [f1, a1]+repTy (HsListTy t)          = do+                                t1   <- repLTy t+                                tcon <- repListTyCon+                                repTapp tcon t1+repTy (HsPArrTy t)     = do+                           t1   <- repLTy t+                           tcon <- repTy (HsTyVar NotPromoted+                                                  (noLoc (tyConName parrTyCon)))+                           repTapp tcon t1+repTy (HsTupleTy HsUnboxedTuple tys) = do+                                tys1 <- repLTys tys+                                tcon <- repUnboxedTupleTyCon (length tys)+                                repTapps tcon tys1+repTy (HsTupleTy _ tys)     = do tys1 <- repLTys tys+                                 tcon <- repTupleTyCon (length tys)+                                 repTapps tcon tys1+repTy (HsSumTy tys)         = do tys1 <- repLTys tys+                                 tcon <- repUnboxedSumTyCon (length tys)+                                 repTapps tcon tys1+repTy (HsOpTy ty1 n ty2)    = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)+                                   `nlHsAppTy` ty2)+repTy (HsParTy t)           = repLTy t+repTy (HsEqTy t1 t2) = do+                         t1' <- repLTy t1+                         t2' <- repLTy t2+                         eq  <- repTequality+                         repTapps eq [t1', t2']+repTy (HsKindSig t k)       = do+                                t1 <- repLTy t+                                k1 <- repLKind k+                                repTSig t1 k1+repTy (HsSpliceTy splice _)     = repSplice splice+repTy (HsExplicitListTy _ _ tys) = do+                                    tys1 <- repLTys tys+                                    repTPromotedList tys1+repTy (HsExplicitTupleTy _ tys) = do+                                    tys1 <- repLTys tys+                                    tcon <- repPromotedTupleTyCon (length tys)+                                    repTapps tcon tys1+repTy (HsTyLit lit) = do+                        lit' <- repTyLit lit+                        repTLit lit'+repTy (HsWildCardTy (AnonWildCard _)) = repTWildCard++repTy ty                      = notHandled "Exotic form of type" (ppr ty)++repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)+repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i+                            rep2 numTyLitName [iExpr]+repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s+                            ; rep2 strTyLitName [s']+                            }++-- represent a kind+--+repLKind :: LHsKind Name -> DsM (Core TH.Kind)+repLKind ki+  = do { let (kis, ki') = splitHsFunType ki+       ; kis_rep <- mapM repLKind kis+       ; ki'_rep <- repNonArrowLKind ki'+       ; kcon <- repKArrow+       ; let f k1 k2 = repKApp kcon k1 >>= flip repKApp k2+       ; foldrM f ki'_rep kis_rep+       }++-- | Represent a kind wrapped in a Maybe+repMaybeLKind :: Maybe (LHsKind Name)+              -> DsM (Core (Maybe TH.Kind))+repMaybeLKind Nothing =+    do { coreNothing kindTyConName }+repMaybeLKind (Just ki) =+    do { ki' <- repLKind ki+       ; coreJust kindTyConName ki' }++repNonArrowLKind :: LHsKind Name -> DsM (Core TH.Kind)+repNonArrowLKind (L _ ki) = repNonArrowKind ki++repNonArrowKind :: HsKind Name -> DsM (Core TH.Kind)+repNonArrowKind (HsTyVar _ (L _ name))+  | isLiftedTypeKindTyConName name       = repKStar+  | name `hasKey` constraintKindTyConKey = repKConstraint+  | isTvOcc (nameOccName name)      = lookupOcc name >>= repKVar+  | otherwise                       = lookupOcc name >>= repKCon+repNonArrowKind (HsAppTy f a)       = do  { f' <- repLKind f+                                          ; a' <- repLKind a+                                          ; repKApp f' a'+                                          }+repNonArrowKind (HsListTy k)        = do  { k' <- repLKind k+                                          ; kcon <- repKList+                                          ; repKApp kcon k'+                                          }+repNonArrowKind (HsTupleTy _ ks)    = do  { ks' <- mapM repLKind ks+                                          ; kcon <- repKTuple (length ks)+                                          ; repKApps kcon ks'+                                          }+repNonArrowKind k                   = notHandled "Exotic form of kind" (ppr k)++repRole :: Located (Maybe Role) -> DsM (Core TH.Role)+repRole (L _ (Just Nominal))          = rep2 nominalRName []+repRole (L _ (Just Representational)) = rep2 representationalRName []+repRole (L _ (Just Phantom))          = rep2 phantomRName []+repRole (L _ Nothing)                 = rep2 inferRName []++-----------------------------------------------------------------------------+--              Splices+-----------------------------------------------------------------------------++repSplice :: HsSplice Name -> DsM (Core a)+-- See Note [How brackets and nested splices are handled] in TcSplice+-- We return a CoreExpr of any old type; the context should know+repSplice (HsTypedSplice   _ n _) = rep_splice n+repSplice (HsUntypedSplice _ n _) = rep_splice n+repSplice (HsQuasiQuote n _ _ _)  = rep_splice n+repSplice e@(HsSpliced _ _)       = pprPanic "repSplice" (ppr e)++rep_splice :: Name -> DsM (Core a)+rep_splice splice_name+ = do { mb_val <- dsLookupMetaEnv splice_name+       ; case mb_val of+           Just (DsSplice e) -> do { e' <- dsExpr e+                                   ; return (MkC e') }+           _ -> pprPanic "HsSplice" (ppr splice_name) }+                        -- Should not happen; statically checked++-----------------------------------------------------------------------------+--              Expressions+-----------------------------------------------------------------------------++repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])+repLEs es = repList expQTyConName repLE es++-- FIXME: some of these panics should be converted into proper error messages+--        unless we can make sure that constructs, which are plainly not+--        supported in TH already lead to error messages at an earlier stage+repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)+repLE (L loc e) = putSrcSpanDs loc (repE e)++repE :: HsExpr Name -> DsM (Core TH.ExpQ)+repE (HsVar (L _ x))            =+  do { mb_val <- dsLookupMetaEnv x+     ; case mb_val of+        Nothing            -> do { str <- globalVar x+                                 ; repVarOrCon x str }+        Just (DsBound y)   -> repVarOrCon x (coreVar y)+        Just (DsSplice e)  -> do { e' <- dsExpr e+                                 ; return (MkC e') } }+repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)+repE e@(HsOverLabel{}) = notHandled "Overloaded labels" (ppr e)++repE e@(HsRecFld f) = case f of+  Unambiguous _ x -> repE (HsVar (noLoc x))+  Ambiguous{}     -> notHandled "Ambiguous record selectors" (ppr e)++        -- Remember, we're desugaring renamer output here, so+        -- HsOverlit can definitely occur+repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }+repE (HsLit l)     = do { a <- repLiteral l;           repLit a }+repE (HsLam (MG { mg_alts = L _ [m] })) = repLambda m+repE (HsLamCase (MG { mg_alts = L _ ms }))+                   = do { ms' <- mapM repMatchTup ms+                        ; core_ms <- coreList matchQTyConName ms'+                        ; repLamCase core_ms }+repE (HsApp x y)   = do {a <- repLE x; b <- repLE y; repApp a b}+repE (HsAppType e t) = do { a <- repLE e+                          ; s <- repLTy (hswc_body t)+                          ; repAppType a s }++repE (OpApp e1 op _ e2) =+  do { arg1 <- repLE e1;+       arg2 <- repLE e2;+       the_op <- repLE op ;+       repInfixApp arg1 the_op arg2 }+repE (NegApp x _)        = do+                              a         <- repLE x+                              negateVar <- lookupOcc negateName >>= repVar+                              negateVar `repApp` a+repE (HsPar x)            = repLE x+repE (SectionL x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b }+repE (SectionR x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b }+repE (HsCase e (MG { mg_alts = L _ ms }))+                          = do { arg <- repLE e+                               ; ms2 <- mapM repMatchTup ms+                               ; core_ms2 <- coreList matchQTyConName ms2+                               ; repCaseE arg core_ms2 }+repE (HsIf _ x y z)         = do+                              a <- repLE x+                              b <- repLE y+                              c <- repLE z+                              repCond a b c+repE (HsMultiIf _ alts)+  = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts+       ; expr' <- repMultiIf (nonEmptyCoreList alts')+       ; wrapGenSyms (concat binds) expr' }+repE (HsLet (L _ bs) e)         = do { (ss,ds) <- repBinds bs+                                     ; e2 <- addBinds ss (repLE e)+                                     ; z <- repLetE ds e2+                                     ; wrapGenSyms ss z }++-- FIXME: I haven't got the types here right yet+repE e@(HsDo ctxt (L _ sts) _)+ | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }+ = do { (ss,zs) <- repLSts sts;+        e'      <- repDoE (nonEmptyCoreList zs);+        wrapGenSyms ss e' }++ | ListComp <- ctxt+ = do { (ss,zs) <- repLSts sts;+        e'      <- repComp (nonEmptyCoreList zs);+        wrapGenSyms ss e' }++  | otherwise+  = notHandled "mdo, monad comprehension and [: :]" (ppr e)++repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }+repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)+repE e@(ExplicitTuple es boxed)+  | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)+  | isBoxed boxed  = do { xs <- repLEs [e | L _ (Present e) <- es]; repTup xs }+  | otherwise      = do { xs <- repLEs [e | L _ (Present e) <- es]+                        ; repUnboxedTup xs }++repE (ExplicitSum alt arity e _)+ = do { e1 <- repLE e+      ; repUnboxedSum e1 alt arity }++repE (RecordCon { rcon_con_name = c, rcon_flds = flds })+ = do { x <- lookupLOcc c;+        fs <- repFields flds;+        repRecCon x fs }+repE (RecordUpd { rupd_expr = e, rupd_flds = flds })+ = do { x <- repLE e;+        fs <- repUpdFields flds;+        repRecUpd x fs }++repE (ExprWithTySig e ty)+  = do { e1 <- repLE e+       ; t1 <- repHsSigWcType ty+       ; repSigExp e1 t1 }++repE (ArithSeq _ _ aseq) =+  case aseq of+    From e              -> do { ds1 <- repLE e; repFrom ds1 }+    FromThen e1 e2      -> do+                             ds1 <- repLE e1+                             ds2 <- repLE e2+                             repFromThen ds1 ds2+    FromTo   e1 e2      -> do+                             ds1 <- repLE e1+                             ds2 <- repLE e2+                             repFromTo ds1 ds2+    FromThenTo e1 e2 e3 -> do+                             ds1 <- repLE e1+                             ds2 <- repLE e2+                             ds3 <- repLE e3+                             repFromThenTo ds1 ds2 ds3++repE (HsSpliceE splice)    = repSplice splice+repE (HsStatic _ e)        = repLE e >>= rep2 staticEName . (:[]) . unC+repE (HsUnboundVar uv)     = do+                               occ   <- occNameLit (unboundVarOcc uv)+                               sname <- repNameS occ+                               repUnboundVar sname++repE e@(PArrSeq {})        = notHandled "Parallel arrays" (ppr e)+repE e@(HsCoreAnn {})      = notHandled "Core annotations" (ppr e)+repE e@(HsSCC {})          = notHandled "Cost centres" (ppr e)+repE e@(HsTickPragma {})   = notHandled "Tick Pragma" (ppr e)+repE e@(HsTcBracketOut {}) = notHandled "TH brackets" (ppr e)+repE e                     = notHandled "Expression form" (ppr e)++-----------------------------------------------------------------------------+-- Building representations of auxillary structures like Match, Clause, Stmt,++repMatchTup ::  LMatch Name (LHsExpr Name) -> DsM (Core TH.MatchQ)+repMatchTup (L _ (Match _ [p] _ (GRHSs guards (L _ wheres)))) =+  do { ss1 <- mkGenSyms (collectPatBinders p)+     ; addBinds ss1 $ do {+     ; p1 <- repLP p+     ; (ss2,ds) <- repBinds wheres+     ; addBinds ss2 $ do {+     ; gs    <- repGuards guards+     ; match <- repMatch p1 gs ds+     ; wrapGenSyms (ss1++ss2) match }}}+repMatchTup _ = panic "repMatchTup: case alt with more than one arg"++repClauseTup ::  LMatch Name (LHsExpr Name) -> DsM (Core TH.ClauseQ)+repClauseTup (L _ (Match _ ps _ (GRHSs guards (L _ wheres)))) =+  do { ss1 <- mkGenSyms (collectPatsBinders ps)+     ; addBinds ss1 $ do {+       ps1 <- repLPs ps+     ; (ss2,ds) <- repBinds wheres+     ; addBinds ss2 $ do {+       gs <- repGuards guards+     ; clause <- repClause ps1 gs ds+     ; wrapGenSyms (ss1++ss2) clause }}}++repGuards ::  [LGRHS Name (LHsExpr Name)] ->  DsM (Core TH.BodyQ)+repGuards [L _ (GRHS [] e)]+  = do {a <- repLE e; repNormal a }+repGuards other+  = do { zs <- mapM repLGRHS other+       ; let (xs, ys) = unzip zs+       ; gd <- repGuarded (nonEmptyCoreList ys)+       ; wrapGenSyms (concat xs) gd }++repLGRHS :: LGRHS Name (LHsExpr Name) -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))+repLGRHS (L _ (GRHS [L _ (BodyStmt e1 _ _ _)] e2))+  = do { guarded <- repLNormalGE e1 e2+       ; return ([], guarded) }+repLGRHS (L _ (GRHS ss rhs))+  = do { (gs, ss') <- repLSts ss+       ; rhs' <- addBinds gs $ repLE rhs+       ; guarded <- repPatGE (nonEmptyCoreList ss') rhs'+       ; return (gs, guarded) }++repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])+repFields (HsRecFields { rec_flds = flds })+  = repList fieldExpQTyConName rep_fld flds+  where+    rep_fld :: LHsRecField Name (LHsExpr Name) -> DsM (Core (TH.Q TH.FieldExp))+    rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld)+                           ; e  <- repLE (hsRecFieldArg fld)+                           ; repFieldExp fn e }++repUpdFields :: [LHsRecUpdField Name] -> DsM (Core [TH.Q TH.FieldExp])+repUpdFields = repList fieldExpQTyConName rep_fld+  where+    rep_fld :: LHsRecUpdField Name -> DsM (Core (TH.Q TH.FieldExp))+    rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of+      Unambiguous _ sel_name -> do { fn <- lookupLOcc (L l sel_name)+                                   ; e  <- repLE (hsRecFieldArg fld)+                                   ; repFieldExp fn e }+      _                      -> notHandled "Ambiguous record updates" (ppr fld)++++-----------------------------------------------------------------------------+-- Representing Stmt's is tricky, especially if bound variables+-- shadow each other. Consider:  [| do { x <- f 1; x <- f x; g x } |]+-- First gensym new names for every variable in any of the patterns.+-- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))+-- if variables didn't shaddow, the static gensym wouldn't be necessary+-- and we could reuse the original names (x and x).+--+-- do { x'1 <- gensym "x"+--    ; x'2 <- gensym "x"+--    ; doE [ BindSt (pvar x'1) [| f 1 |]+--          , BindSt (pvar x'2) [| f x |]+--          , NoBindSt [| g x |]+--          ]+--    }++-- The strategy is to translate a whole list of do-bindings by building a+-- bigger environment, and a bigger set of meta bindings+-- (like:  x'1 <- gensym "x" ) and then combining these with the translations+-- of the expressions within the Do++-----------------------------------------------------------------------------+-- The helper function repSts computes the translation of each sub expression+-- and a bunch of prefix bindings denoting the dynamic renaming.++repLSts :: [LStmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ])+repLSts stmts = repSts (map unLoc stmts)++repSts :: [Stmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ])+repSts (BindStmt p e _ _ _ : ss) =+   do { e2 <- repLE e+      ; ss1 <- mkGenSyms (collectPatBinders p)+      ; addBinds ss1 $ do {+      ; p1 <- repLP p;+      ; (ss2,zs) <- repSts ss+      ; z <- repBindSt p1 e2+      ; return (ss1++ss2, z : zs) }}+repSts (LetStmt (L _ bs) : ss) =+   do { (ss1,ds) <- repBinds bs+      ; z <- repLetSt ds+      ; (ss2,zs) <- addBinds ss1 (repSts ss)+      ; return (ss1++ss2, z : zs) }+repSts (BodyStmt e _ _ _ : ss) =+   do { e2 <- repLE e+      ; z <- repNoBindSt e2+      ; (ss2,zs) <- repSts ss+      ; return (ss2, z : zs) }+repSts (ParStmt stmt_blocks _ _ _ : ss) =+   do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks+      ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1+            ss1 = concat ss_s+      ; z <- repParSt stmt_blocks2+      ; (ss2, zs) <- addBinds ss1 (repSts ss)+      ; return (ss1++ss2, z : zs) }+   where+     rep_stmt_block :: ParStmtBlock Name Name -> DsM ([GenSymBind], Core [TH.StmtQ])+     rep_stmt_block (ParStmtBlock stmts _ _) =+       do { (ss1, zs) <- repSts (map unLoc stmts)+          ; zs1 <- coreList stmtQTyConName zs+          ; return (ss1, zs1) }+repSts [LastStmt e _ _]+  = do { e2 <- repLE e+       ; z <- repNoBindSt e2+       ; return ([], [z]) }+repSts []    = return ([],[])+repSts other = notHandled "Exotic statement" (ppr other)+++-----------------------------------------------------------+--                      Bindings+-----------------------------------------------------------++repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])+repBinds EmptyLocalBinds+  = do  { core_list <- coreList decQTyConName []+        ; return ([], core_list) }++repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)++repBinds (HsValBinds decs)+ = do   { let { bndrs = hsSigTvBinders decs ++ collectHsValBinders decs }+                -- No need to worry about detailed scopes within+                -- the binding group, because we are talking Names+                -- here, so we can safely treat it as a mutually+                -- recursive group+                -- For hsSigTvBinders see Note [Scoped type variables in bindings]+        ; ss        <- mkGenSyms bndrs+        ; prs       <- addBinds ss (rep_val_binds decs)+        ; core_list <- coreList decQTyConName+                                (de_loc (sort_by_loc prs))+        ; return (ss, core_list) }++rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]+-- Assumes: all the binders of the binding are already in the meta-env+rep_val_binds (ValBindsOut binds sigs)+ = do { core1 <- rep_binds' (unionManyBags (map snd binds))+      ; core2 <- rep_sigs' sigs+      ; return (core1 ++ core2) }+rep_val_binds (ValBindsIn _ _)+ = panic "rep_val_binds: ValBindsIn"++rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]+rep_binds binds = do { binds_w_locs <- rep_binds' binds+                     ; return (de_loc (sort_by_loc binds_w_locs)) }++rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]+rep_binds' = mapM rep_bind . bagToList++rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)+-- Assumes: all the binders of the binding are already in the meta-env++-- Note GHC treats declarations of a variable (not a pattern)+-- e.g.  x = g 5 as a Fun MonoBinds. This is indicated by a single match+-- with an empty list of patterns+rep_bind (L loc (FunBind+                 { fun_id = fn,+                   fun_matches = MG { mg_alts+                           = L _ [L _ (Match _ [] _+                                             (GRHSs guards (L _ wheres)))] } }))+ = do { (ss,wherecore) <- repBinds wheres+        ; guardcore <- addBinds ss (repGuards guards)+        ; fn'  <- lookupLBinder fn+        ; p    <- repPvar fn'+        ; ans  <- repVal p guardcore wherecore+        ; ans' <- wrapGenSyms ss ans+        ; return (loc, ans') }++rep_bind (L loc (FunBind { fun_id = fn+                         , fun_matches = MG { mg_alts = L _ ms } }))+ =   do { ms1 <- mapM repClauseTup ms+        ; fn' <- lookupLBinder fn+        ; ans <- repFun fn' (nonEmptyCoreList ms1)+        ; return (loc, ans) }++rep_bind (L loc (PatBind { pat_lhs = pat+                         , pat_rhs = GRHSs guards (L _ wheres) }))+ =   do { patcore <- repLP pat+        ; (ss,wherecore) <- repBinds wheres+        ; guardcore <- addBinds ss (repGuards guards)+        ; ans  <- repVal patcore guardcore wherecore+        ; ans' <- wrapGenSyms ss ans+        ; return (loc, ans') }++rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))+ =   do { v' <- lookupBinder v+        ; e2 <- repLE e+        ; x <- repNormal e2+        ; patcore <- repPvar v'+        ; empty_decls <- coreList decQTyConName []+        ; ans <- repVal patcore x empty_decls+        ; return (srcLocSpan (getSrcLoc v), ans) }++rep_bind (L _ (AbsBinds {}))  = panic "rep_bind: AbsBinds"+rep_bind (L _ (AbsBindsSig {})) = panic "rep_bind: AbsBindsSig"+rep_bind (L loc (PatSynBind (PSB { psb_id   = syn+                                 , psb_fvs  = _fvs+                                 , psb_args = args+                                 , psb_def  = pat+                                 , psb_dir  = dir })))+  = do { syn'      <- lookupLBinder syn+       ; dir'      <- repPatSynDir dir+       ; ss        <- mkGenArgSyms args+       ; patSynD'  <- addBinds ss (+         do { args'  <- repPatSynArgs args+            ; pat'   <- repLP pat+            ; repPatSynD syn' args' dir' pat' })+       ; patSynD'' <- wrapGenArgSyms args ss patSynD'+       ; return (loc, patSynD'') }+  where+    mkGenArgSyms :: HsPatSynDetails (Located Name) -> DsM [GenSymBind]+    -- for Record Pattern Synonyms we want to conflate the selector+    -- and the pattern-only names in order to provide a nicer TH+    -- API. Whereas inside GHC, record pattern synonym selectors and+    -- their pattern-only bound right hand sides have different names,+    -- we want to treat them the same in TH. This is the reason why we+    -- need an adjusted mkGenArgSyms in the `RecordPatSyn` case below.+    mkGenArgSyms (PrefixPatSyn args)     = mkGenSyms (map unLoc args)+    mkGenArgSyms (InfixPatSyn arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]+    mkGenArgSyms (RecordPatSyn fields)+      = do { let pats = map (unLoc . recordPatSynPatVar) fields+                 sels = map (unLoc . recordPatSynSelectorId) fields+           ; ss <- mkGenSyms sels+           ; return $ replaceNames (zip sels pats) ss }++    replaceNames selsPats genSyms+      = [ (pat, id) | (sel, id) <- genSyms, (sel', pat) <- selsPats+                    , sel == sel' ]++    wrapGenArgSyms :: HsPatSynDetails (Located Name)+                   -> [GenSymBind] -> Core TH.DecQ -> DsM (Core TH.DecQ)+    wrapGenArgSyms (RecordPatSyn _) _  dec = return dec+    wrapGenArgSyms _                ss dec = wrapGenSyms ss dec++repPatSynD :: Core TH.Name+           -> Core TH.PatSynArgsQ+           -> Core TH.PatSynDirQ+           -> Core TH.PatQ+           -> DsM (Core TH.DecQ)+repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat)+  = rep2 patSynDName [syn, args, dir, pat]++repPatSynArgs :: HsPatSynDetails (Located Name) -> DsM (Core TH.PatSynArgsQ)+repPatSynArgs (PrefixPatSyn args)+  = do { args' <- repList nameTyConName lookupLOcc args+       ; repPrefixPatSynArgs args' }+repPatSynArgs (InfixPatSyn arg1 arg2)+  = do { arg1' <- lookupLOcc arg1+       ; arg2' <- lookupLOcc arg2+       ; repInfixPatSynArgs arg1' arg2' }+repPatSynArgs (RecordPatSyn fields)+  = do { sels' <- repList nameTyConName lookupLOcc sels+       ; repRecordPatSynArgs sels' }+  where sels = map recordPatSynSelectorId fields++repPrefixPatSynArgs :: Core [TH.Name] -> DsM (Core TH.PatSynArgsQ)+repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms]++repInfixPatSynArgs :: Core TH.Name -> Core TH.Name -> DsM (Core TH.PatSynArgsQ)+repInfixPatSynArgs (MkC nm1) (MkC nm2) = rep2 infixPatSynName [nm1, nm2]++repRecordPatSynArgs :: Core [TH.Name]+                    -> DsM (Core TH.PatSynArgsQ)+repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels]++repPatSynDir :: HsPatSynDir Name -> DsM (Core TH.PatSynDirQ)+repPatSynDir Unidirectional        = rep2 unidirPatSynName []+repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName []+repPatSynDir (ExplicitBidirectional (MG { mg_alts = L _ clauses }))+  = do { clauses' <- mapM repClauseTup clauses+       ; repExplBidirPatSynDir (nonEmptyCoreList clauses') }++repExplBidirPatSynDir :: Core [TH.ClauseQ] -> DsM (Core TH.PatSynDirQ)+repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]+++-----------------------------------------------------------------------------+-- Since everything in a Bind is mutually recursive we need rename all+-- all the variables simultaneously. For example:+-- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to+-- do { f'1 <- gensym "f"+--    ; g'2 <- gensym "g"+--    ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},+--        do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}+--      ]}+-- This requires collecting the bindings (f'1 <- gensym "f"), and the+-- environment ( f |-> f'1 ) from each binding, and then unioning them+-- together. As we do this we collect GenSymBinds's which represent the renamed+-- variables bound by the Bindings. In order not to lose track of these+-- representations we build a shadow datatype MB with the same structure as+-- MonoBinds, but which has slots for the representations+++-----------------------------------------------------------------------------+-- GHC allows a more general form of lambda abstraction than specified+-- by Haskell 98. In particular it allows guarded lambda's like :+-- (\  x | even x -> 0 | odd x -> 1) at the moment we can't represent this in+-- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like+-- (\ p1 .. pn -> exp) by causing an error.++repLambda :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ExpQ)+repLambda (L _ (Match _ ps _ (GRHSs [L _ (GRHS [] e)] (L _ EmptyLocalBinds))))+ = do { let bndrs = collectPatsBinders ps ;+      ; ss  <- mkGenSyms bndrs+      ; lam <- addBinds ss (+                do { xs <- repLPs ps; body <- repLE e; repLam xs body })+      ; wrapGenSyms ss lam }++repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch m)+++-----------------------------------------------------------------------------+--                      Patterns+-- repP deals with patterns.  It assumes that we have already+-- walked over the pattern(s) once to collect the binders, and+-- have extended the environment.  So every pattern-bound+-- variable should already appear in the environment.++-- Process a list of patterns+repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])+repLPs ps = repList patQTyConName repLP ps++repLP :: LPat Name -> DsM (Core TH.PatQ)+repLP (L _ p) = repP p++repP :: Pat Name -> DsM (Core TH.PatQ)+repP (WildPat _)       = repPwild+repP (LitPat l)        = do { l2 <- repLiteral l; repPlit l2 }+repP (VarPat (L _ x))  = do { x' <- lookupBinder x; repPvar x' }+repP (LazyPat p)       = do { p1 <- repLP p; repPtilde p1 }+repP (BangPat p)       = do { p1 <- repLP p; repPbang p1 }+repP (AsPat x p)       = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }+repP (ParPat p)        = repLP p+repP (ListPat ps _ Nothing)    = do { qs <- repLPs ps; repPlist qs }+repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' <- repE (syn_expr e); repPview e' p}+repP (TuplePat ps boxed _)+  | isBoxed boxed       = do { qs <- repLPs ps; repPtup qs }+  | otherwise           = do { qs <- repLPs ps; repPunboxedTup qs }+repP (SumPat p alt arity _) = do { p1 <- repLP p; repPunboxedSum p1 alt arity }+repP (ConPatIn dc details)+ = do { con_str <- lookupLOcc dc+      ; case details of+         PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }+         RecCon rec   -> do { fps <- repList fieldPatQTyConName rep_fld (rec_flds rec)+                            ; repPrec con_str fps }+         InfixCon p1 p2 -> do { p1' <- repLP p1;+                                p2' <- repLP p2;+                                repPinfix p1' con_str p2' }+   }+ where+   rep_fld :: LHsRecField Name (LPat Name) -> DsM (Core (TH.Name,TH.PatQ))+   rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)+                          ; MkC p <- repLP (hsRecFieldArg fld)+                          ; rep2 fieldPatName [v,p] }++repP (NPat (L _ l) Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a }+repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }+repP p@(NPat _ (Just _) _ _) = notHandled "Negative overloaded patterns" (ppr p)+repP (SigPatIn p t) = do { p' <- repLP p+                         ; t' <- repLTy (hsSigWcType t)+                         ; repPsig p' t' }+repP (SplicePat splice) = repSplice splice++repP other = notHandled "Exotic pattern" (ppr other)++----------------------------------------------------------+-- Declaration ordering helpers++sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]+sort_by_loc xs = sortBy comp xs+    where comp x y = compare (fst x) (fst y)++de_loc :: [(a, b)] -> [b]+de_loc = map snd++----------------------------------------------------------+--      The meta-environment++-- A name/identifier association for fresh names of locally bound entities+type GenSymBind = (Name, Id)    -- Gensym the string and bind it to the Id+                                -- I.e.         (x, x_id) means+                                --      let x_id = gensym "x" in ...++-- Generate a fresh name for a locally bound entity++mkGenSyms :: [Name] -> DsM [GenSymBind]+-- We can use the existing name.  For example:+--      [| \x_77 -> x_77 + x_77 |]+-- desugars to+--      do { x_77 <- genSym "x"; .... }+-- We use the same x_77 in the desugared program, but with the type Bndr+-- instead of Int+--+-- We do make it an Internal name, though (hence localiseName)+--+-- Nevertheless, it's monadic because we have to generate nameTy+mkGenSyms ns = do { var_ty <- lookupType nameTyConName+                  ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }+++addBinds :: [GenSymBind] -> DsM a -> DsM a+-- Add a list of fresh names for locally bound entities to the+-- meta environment (which is part of the state carried around+-- by the desugarer monad)+addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs]) m++-- Look up a locally bound name+--+lookupLBinder :: Located Name -> DsM (Core TH.Name)+lookupLBinder (L _ n) = lookupBinder n++lookupBinder :: Name -> DsM (Core TH.Name)+lookupBinder = lookupOcc+  -- Binders are brought into scope before the pattern or what-not is+  -- desugared.  Moreover, in instance declaration the binder of a method+  -- will be the selector Id and hence a global; so we need the+  -- globalVar case of lookupOcc++-- Look up a name that is either locally bound or a global name+--+--  * If it is a global name, generate the "original name" representation (ie,+--   the <module>:<name> form) for the associated entity+--+lookupLOcc :: Located Name -> DsM (Core TH.Name)+-- Lookup an occurrence; it can't be a splice.+-- Use the in-scope bindings if they exist+lookupLOcc (L _ n) = lookupOcc n++lookupOcc :: Name -> DsM (Core TH.Name)+lookupOcc n+  = do {  mb_val <- dsLookupMetaEnv n ;+          case mb_val of+                Nothing           -> globalVar n+                Just (DsBound x)  -> return (coreVar x)+                Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n)+    }++globalVar :: Name -> DsM (Core TH.Name)+-- Not bound by the meta-env+-- Could be top-level; or could be local+--      f x = $(g [| x |])+-- Here the x will be local+globalVar name+  | isExternalName name+  = do  { MkC mod <- coreStringLit name_mod+        ; MkC pkg <- coreStringLit name_pkg+        ; MkC occ <- nameLit name+        ; rep2 mk_varg [pkg,mod,occ] }+  | otherwise+  = do  { MkC occ <- nameLit name+        ; MkC uni <- coreIntLit (getKey (getUnique name))+        ; rep2 mkNameLName [occ,uni] }+  where+      mod = ASSERT( isExternalName name) nameModule name+      name_mod = moduleNameString (moduleName mod)+      name_pkg = unitIdString (moduleUnitId mod)+      name_occ = nameOccName name+      mk_varg | OccName.isDataOcc name_occ = mkNameG_dName+              | OccName.isVarOcc  name_occ = mkNameG_vName+              | OccName.isTcOcc   name_occ = mkNameG_tcName+              | otherwise                  = pprPanic "DsMeta.globalVar" (ppr name)++lookupType :: Name      -- Name of type constructor (e.g. TH.ExpQ)+           -> DsM Type  -- The type+lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;+                          return (mkTyConApp tc []) }++wrapGenSyms :: [GenSymBind]+            -> Core (TH.Q a) -> DsM (Core (TH.Q a))+-- wrapGenSyms [(nm1,id1), (nm2,id2)] y+--      --> bindQ (gensym nm1) (\ id1 ->+--          bindQ (gensym nm2 (\ id2 ->+--          y))++wrapGenSyms binds body@(MkC b)+  = do  { var_ty <- lookupType nameTyConName+        ; go var_ty binds }+  where+    [elt_ty] = tcTyConAppArgs (exprType b)+        -- b :: Q a, so we can get the type 'a' by looking at the+        -- argument type. NB: this relies on Q being a data/newtype,+        -- not a type synonym++    go _ [] = return body+    go var_ty ((name,id) : binds)+      = do { MkC body'  <- go var_ty binds+           ; lit_str    <- nameLit name+           ; gensym_app <- repGensym lit_str+           ; repBindQ var_ty elt_ty+                      gensym_app (MkC (Lam id body')) }++nameLit :: Name -> DsM (Core String)+nameLit n = coreStringLit (occNameString (nameOccName n))++occNameLit :: OccName -> DsM (Core String)+occNameLit name = coreStringLit (occNameString name)+++-- %*********************************************************************+-- %*                                                                   *+--              Constructing code+-- %*                                                                   *+-- %*********************************************************************++-----------------------------------------------------------------------------+-- PHANTOM TYPES for consistency. In order to make sure we do this correct+-- we invent a new datatype which uses phantom types.++newtype Core a = MkC CoreExpr+unC :: Core a -> CoreExpr+unC (MkC x) = x++rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)+rep2 n xs = do { id <- dsLookupGlobalId n+               ; return (MkC (foldl App (Var id) xs)) }++dataCon' :: Name -> [CoreExpr] -> DsM (Core a)+dataCon' n args = do { id <- dsLookupDataCon n+                     ; return $ MkC $ mkCoreConApps id args }++dataCon :: Name -> DsM (Core a)+dataCon n = dataCon' n []+++-- %*********************************************************************+-- %*                                                                   *+--              The 'smart constructors'+-- %*                                                                   *+-- %*********************************************************************++--------------- Patterns -----------------+repPlit   :: Core TH.Lit -> DsM (Core TH.PatQ)+repPlit (MkC l) = rep2 litPName [l]++repPvar :: Core TH.Name -> DsM (Core TH.PatQ)+repPvar (MkC s) = rep2 varPName [s]++repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)+repPtup (MkC ps) = rep2 tupPName [ps]++repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)+repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]++repPunboxedSum :: Core TH.PatQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.PatQ)+-- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here+repPunboxedSum (MkC p) alt arity+ = do { dflags <- getDynFlags+      ; rep2 unboxedSumPName [ p+                             , mkIntExprInt dflags alt+                             , mkIntExprInt dflags arity ] }++repPcon   :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)+repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]++repPrec   :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)+repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]++repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)+repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]++repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)+repPtilde (MkC p) = rep2 tildePName [p]++repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)+repPbang (MkC p) = rep2 bangPName [p]++repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)+repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]++repPwild  :: DsM (Core TH.PatQ)+repPwild = rep2 wildPName []++repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)+repPlist (MkC ps) = rep2 listPName [ps]++repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ)+repPview (MkC e) (MkC p) = rep2 viewPName [e,p]++repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)+repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]++--------------- Expressions -----------------+repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)+repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str+                   | otherwise                  = repVar str++repVar :: Core TH.Name -> DsM (Core TH.ExpQ)+repVar (MkC s) = rep2 varEName [s]++repCon :: Core TH.Name -> DsM (Core TH.ExpQ)+repCon (MkC s) = rep2 conEName [s]++repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)+repLit (MkC c) = rep2 litEName [c]++repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repApp (MkC x) (MkC y) = rep2 appEName [x,y]++repAppType :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)+repAppType (MkC x) (MkC y) = rep2 appTypeEName [x,y]++repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]++repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ)+repLamCase (MkC ms) = rep2 lamCaseEName [ms]++repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)+repTup (MkC es) = rep2 tupEName [es]++repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)+repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]++repUnboxedSum :: Core TH.ExpQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.ExpQ)+-- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here+repUnboxedSum (MkC e) alt arity+ = do { dflags <- getDynFlags+      ; rep2 unboxedSumEName [ e+                             , mkIntExprInt dflags alt+                             , mkIntExprInt dflags arity ] }++repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]++repMultiIf :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.ExpQ)+repMultiIf (MkC alts) = rep2 multiIfEName [alts]++repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]++repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)+repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]++repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)+repDoE (MkC ss) = rep2 doEName [ss]++repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)+repComp (MkC ss) = rep2 compEName [ss]++repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)+repListExp (MkC es) = rep2 listEName [es]++repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)+repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]++repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)+repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]++repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)+repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]++repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))+repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]++repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]++repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]++repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]++------------ Right hand sides (guarded expressions) ----+repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)+repGuarded (MkC pairs) = rep2 guardedBName [pairs]++repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)+repNormal (MkC e) = rep2 normalBName [e]++------------ Guards ----+repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))+repLNormalGE g e = do g' <- repLE g+                      e' <- repLE e+                      repNormalGE g' e'++repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))+repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]++repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))+repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]++------------- Stmts -------------------+repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)+repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]++repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)+repLetSt (MkC ds) = rep2 letSName [ds]++repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)+repNoBindSt (MkC e) = rep2 noBindSName [e]++repParSt :: Core [[TH.StmtQ]] -> DsM (Core TH.StmtQ)+repParSt (MkC sss) = rep2 parSName [sss]++-------------- Range (Arithmetic sequences) -----------+repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)+repFrom (MkC x) = rep2 fromEName [x]++repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]++repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]++repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]++------------ Match and Clause Tuples -----------+repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)+repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]++repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)+repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]++-------------- Dec -----------------------------+repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)+repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]++repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)+repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]++repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]+        -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.Kind)+        -> Core [TH.ConQ] -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ)+repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC cons) (MkC derivs)+  = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]+repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC cons)+        (MkC derivs)+  = rep2 dataInstDName [cxt, nm, tys, ksig, cons, derivs]++repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]+           -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.Kind)+           -> Core TH.ConQ -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ)+repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC con)+           (MkC derivs)+  = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs]+repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC con)+           (MkC derivs)+  = rep2 newtypeInstDName [cxt, nm, tys, ksig, con, derivs]++repTySyn :: Core TH.Name -> Core [TH.TyVarBndr]+         -> Core TH.TypeQ -> DsM (Core TH.DecQ)+repTySyn (MkC nm) (MkC tvs) (MkC rhs)+  = rep2 tySynDName [nm, tvs, rhs]++repInst :: Core (Maybe TH.Overlap) ->+           Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)+repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName+                                                              [o, cxt, ty, ds]++repDerivStrategy :: Maybe (Located DerivStrategy)+                 -> DsM (Core (Maybe TH.DerivStrategy))+repDerivStrategy mds =+  case mds of+    Nothing -> nothing+    Just (L _ ds) ->+      case ds of+        StockStrategy    -> just =<< dataCon stockStrategyDataConName+        AnyclassStrategy -> just =<< dataCon anyclassStrategyDataConName+        NewtypeStrategy  -> just =<< dataCon newtypeStrategyDataConName+  where+  nothing = coreNothing derivStrategyTyConName+  just    = coreJust    derivStrategyTyConName++repOverlap :: Maybe OverlapMode -> DsM (Core (Maybe TH.Overlap))+repOverlap mb =+  case mb of+    Nothing -> nothing+    Just o ->+      case o of+        NoOverlap _    -> nothing+        Overlappable _ -> just =<< dataCon overlappableDataConName+        Overlapping _  -> just =<< dataCon overlappingDataConName+        Overlaps _     -> just =<< dataCon overlapsDataConName+        Incoherent _   -> just =<< dataCon incoherentDataConName+  where+  nothing = coreNothing overlapTyConName+  just    = coreJust overlapTyConName+++repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]+         -> Core [TH.FunDep] -> Core [TH.DecQ]+         -> DsM (Core TH.DecQ)+repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)+  = rep2 classDName [cxt, cls, tvs, fds, ds]++repDeriv :: Core (Maybe TH.DerivStrategy)+         -> Core TH.CxtQ -> Core TH.TypeQ+         -> DsM (Core TH.DecQ)+repDeriv (MkC ds) (MkC cxt) (MkC ty)+  = rep2 standaloneDerivWithStrategyDName [ds, cxt, ty]++repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch+           -> Core TH.Phases -> DsM (Core TH.DecQ)+repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)+  = rep2 pragInlDName [nm, inline, rm, phases]++repPragSpec :: Core TH.Name -> Core TH.TypeQ -> Core TH.Phases+            -> DsM (Core TH.DecQ)+repPragSpec (MkC nm) (MkC ty) (MkC phases)+  = rep2 pragSpecDName [nm, ty, phases]++repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.Inline+               -> Core TH.Phases -> DsM (Core TH.DecQ)+repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)+  = rep2 pragSpecInlDName [nm, ty, inline, phases]++repPragSpecInst :: Core TH.TypeQ -> DsM (Core TH.DecQ)+repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]++repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> DsM (Core TH.DecQ)+repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty]++repPragRule :: Core String -> Core [TH.RuleBndrQ] -> Core TH.ExpQ+            -> Core TH.ExpQ -> Core TH.Phases -> DsM (Core TH.DecQ)+repPragRule (MkC nm) (MkC bndrs) (MkC lhs) (MkC rhs) (MkC phases)+  = rep2 pragRuleDName [nm, bndrs, lhs, rhs, phases]++repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ)+repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]++repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ)+repTySynInst (MkC nm) (MkC eqn)+    = rep2 tySynInstDName [nm, eqn]++repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndr]+               -> Core (Maybe TH.Kind) -> DsM (Core TH.DecQ)+repDataFamilyD (MkC nm) (MkC tvs) (MkC kind)+    = rep2 dataFamilyDName [nm, tvs, kind]++repOpenFamilyD :: Core TH.Name+               -> Core [TH.TyVarBndr]+               -> Core TH.FamilyResultSig+               -> Core (Maybe TH.InjectivityAnn)+               -> DsM (Core TH.DecQ)+repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj)+    = rep2 openTypeFamilyDName [nm, tvs, result, inj]++repClosedFamilyD :: Core TH.Name+                 -> Core [TH.TyVarBndr]+                 -> Core TH.FamilyResultSig+                 -> Core (Maybe TH.InjectivityAnn)+                 -> Core [TH.TySynEqnQ]+                 -> DsM (Core TH.DecQ)+repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns)+    = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns]++repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)+repTySynEqn (MkC lhs) (MkC rhs)+  = rep2 tySynEqnName [lhs, rhs]++repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> DsM (Core TH.DecQ)+repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]++repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)+repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]++repProto :: Name -> Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)+repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty]++repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)+repCtxt (MkC tys) = rep2 cxtName [tys]++repDataCon :: Located Name+           -> HsConDeclDetails Name+           -> DsM (Core TH.ConQ)+repDataCon con details+    = do con' <- lookupLOcc con -- See Note [Binders and occurrences]+         repConstr details Nothing [con']++repGadtDataCons :: [Located Name]+                -> HsConDeclDetails Name+                -> LHsType Name+                -> DsM (Core TH.ConQ)+repGadtDataCons cons details res_ty+    = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]+         repConstr details (Just res_ty) cons'++-- Invariant:+--   * for plain H98 data constructors second argument is Nothing and third+--     argument is a singleton list+--   * for GADTs data constructors second argument is (Just return_type) and+--     third argument is a non-empty list+repConstr :: HsConDeclDetails Name+          -> Maybe (LHsType Name)+          -> [Core TH.Name]+          -> DsM (Core TH.ConQ)+repConstr (PrefixCon ps) Nothing [con]+    = do arg_tys  <- repList bangTypeQTyConName repBangTy ps+         rep2 normalCName [unC con, unC arg_tys]++repConstr (PrefixCon ps) (Just (L _ res_ty)) cons+    = do arg_tys     <- repList bangTypeQTyConName repBangTy ps+         res_ty' <- repTy res_ty+         rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty']++repConstr (RecCon (L _ ips)) resTy cons+    = do args     <- concatMapM rep_ip ips+         arg_vtys <- coreList varBangTypeQTyConName args+         case resTy of+           Nothing -> rep2 recCName [unC (head cons), unC arg_vtys]+           Just (L _ res_ty) -> do+             res_ty' <- repTy res_ty+             rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys,+                                unC res_ty']++    where+      rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)++      rep_one_ip :: LBangType Name -> LFieldOcc Name -> DsM (Core a)+      rep_one_ip t n = do { MkC v  <- lookupOcc (selectorFieldOcc $ unLoc n)+                          ; MkC ty <- repBangTy  t+                          ; rep2 varBangTypeName [v,ty] }++repConstr (InfixCon st1 st2) Nothing [con]+    = do arg1 <- repBangTy st1+         arg2 <- repBangTy st2+         rep2 infixCName [unC arg1, unC con, unC arg2]++repConstr (InfixCon {}) (Just _) _ =+    panic "repConstr: infix GADT constructor should be in a PrefixCon"+repConstr _ _ _ =+    panic "repConstr: invariant violated"++------------ Types -------------------++repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ+           -> DsM (Core TH.TypeQ)+repTForall (MkC tvars) (MkC ctxt) (MkC ty)+    = rep2 forallTName [tvars, ctxt, ty]++repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)+repTvar (MkC s) = rep2 varTName [s]++repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)+repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]++repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)+repTapps f []     = return f+repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }++repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ)+repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]++repTequality :: DsM (Core TH.TypeQ)+repTequality = rep2 equalityTName []++repTPromotedList :: [Core TH.TypeQ] -> DsM (Core TH.TypeQ)+repTPromotedList []     = repPromotedNilTyCon+repTPromotedList (t:ts) = do  { tcon <- repPromotedConsTyCon+                              ; f <- repTapp tcon t+                              ; t' <- repTPromotedList ts+                              ; repTapp f t'+                              }++repTLit :: Core TH.TyLitQ -> DsM (Core TH.TypeQ)+repTLit (MkC lit) = rep2 litTName [lit]++repTWildCard :: DsM (Core TH.TypeQ)+repTWildCard = rep2 wildCardTName []++--------- Type constructors --------------++repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)+repNamedTyCon (MkC s) = rep2 conTName [s]++repTupleTyCon :: Int -> DsM (Core TH.TypeQ)+-- Note: not Core Int; it's easier to be direct here+repTupleTyCon i = do dflags <- getDynFlags+                     rep2 tupleTName [mkIntExprInt dflags i]++repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ)+-- Note: not Core Int; it's easier to be direct here+repUnboxedTupleTyCon i = do dflags <- getDynFlags+                            rep2 unboxedTupleTName [mkIntExprInt dflags i]++repUnboxedSumTyCon :: TH.SumArity -> DsM (Core TH.TypeQ)+-- Note: not Core TH.SumArity; it's easier to be direct here+repUnboxedSumTyCon arity = do dflags <- getDynFlags+                              rep2 unboxedSumTName [mkIntExprInt dflags arity]++repArrowTyCon :: DsM (Core TH.TypeQ)+repArrowTyCon = rep2 arrowTName []++repListTyCon :: DsM (Core TH.TypeQ)+repListTyCon = rep2 listTName []++repPromotedDataCon :: Core TH.Name -> DsM (Core TH.TypeQ)+repPromotedDataCon (MkC s) = rep2 promotedTName [s]++repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ)+repPromotedTupleTyCon i = do dflags <- getDynFlags+                             rep2 promotedTupleTName [mkIntExprInt dflags i]++repPromotedNilTyCon :: DsM (Core TH.TypeQ)+repPromotedNilTyCon = rep2 promotedNilTName []++repPromotedConsTyCon :: DsM (Core TH.TypeQ)+repPromotedConsTyCon = rep2 promotedConsTName []++------------ Kinds -------------------++repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr)+repPlainTV (MkC nm) = rep2 plainTVName [nm]++repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr)+repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]++repKVar :: Core TH.Name -> DsM (Core TH.Kind)+repKVar (MkC s) = rep2 varKName [s]++repKCon :: Core TH.Name -> DsM (Core TH.Kind)+repKCon (MkC s) = rep2 conKName [s]++repKTuple :: Int -> DsM (Core TH.Kind)+repKTuple i = do dflags <- getDynFlags+                 rep2 tupleKName [mkIntExprInt dflags i]++repKArrow :: DsM (Core TH.Kind)+repKArrow = rep2 arrowKName []++repKList :: DsM (Core TH.Kind)+repKList = rep2 listKName []++repKApp :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind)+repKApp (MkC k1) (MkC k2) = rep2 appKName [k1, k2]++repKApps :: Core TH.Kind -> [Core TH.Kind] -> DsM (Core TH.Kind)+repKApps f []     = return f+repKApps f (k:ks) = do { f' <- repKApp f k; repKApps f' ks }++repKStar :: DsM (Core TH.Kind)+repKStar = rep2 starKName []++repKConstraint :: DsM (Core TH.Kind)+repKConstraint = rep2 constraintKName []++----------------------------------------------------------+--       Type family result signature++repNoSig :: DsM (Core TH.FamilyResultSig)+repNoSig = rep2 noSigName []++repKindSig :: Core TH.Kind -> DsM (Core TH.FamilyResultSig)+repKindSig (MkC ki) = rep2 kindSigName [ki]++repTyVarSig :: Core TH.TyVarBndr -> DsM (Core TH.FamilyResultSig)+repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr]++----------------------------------------------------------+--              Literals++repLiteral :: HsLit -> DsM (Core TH.Lit)+repLiteral (HsStringPrim _ bs)+  = do dflags   <- getDynFlags+       word8_ty <- lookupType word8TyConName+       let w8s = unpack bs+           w8s_expr = map (\w8 -> mkCoreConApps word8DataCon+                                  [mkWordLit dflags (toInteger w8)]) w8s+       rep2 stringPrimLName [mkListExpr word8_ty w8s_expr]+repLiteral lit+  = do lit' <- case lit of+                   HsIntPrim _ i    -> mk_integer i+                   HsWordPrim _ w   -> mk_integer w+                   HsInt _ i        -> mk_integer i+                   HsFloatPrim r    -> mk_rational r+                   HsDoublePrim r   -> mk_rational r+                   HsCharPrim _ c   -> mk_char c+                   _ -> return lit+       lit_expr <- dsLit lit'+       case mb_lit_name of+          Just lit_name -> rep2 lit_name [lit_expr]+          Nothing -> notHandled "Exotic literal" (ppr lit)+  where+    mb_lit_name = case lit of+                 HsInteger _ _ _  -> Just integerLName+                 HsInt     _ _    -> Just integerLName+                 HsIntPrim _ _    -> Just intPrimLName+                 HsWordPrim _ _   -> Just wordPrimLName+                 HsFloatPrim _    -> Just floatPrimLName+                 HsDoublePrim _   -> Just doublePrimLName+                 HsChar _ _       -> Just charLName+                 HsCharPrim _ _   -> Just charPrimLName+                 HsString _ _     -> Just stringLName+                 HsRat _ _        -> Just rationalLName+                 _                -> Nothing++mk_integer :: Integer -> DsM HsLit+mk_integer  i = do integer_ty <- lookupType integerTyConName+                   return $ HsInteger NoSourceText i integer_ty+mk_rational :: FractionalLit -> DsM HsLit+mk_rational r = do rat_ty <- lookupType rationalTyConName+                   return $ HsRat r rat_ty+mk_string :: FastString -> DsM HsLit+mk_string s = return $ HsString NoSourceText s++mk_char :: Char -> DsM HsLit+mk_char c = return $ HsChar NoSourceText c++repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)+repOverloadedLiteral (OverLit { ol_val = val})+  = do { lit <- mk_lit val; repLiteral lit }+        -- The type Rational will be in the environment, because+        -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,+        -- and rationalL is sucked in when any TH stuff is used++mk_lit :: OverLitVal -> DsM HsLit+mk_lit (HsIntegral _ i)   = mk_integer  i+mk_lit (HsFractional f)   = mk_rational f+mk_lit (HsIsString _ s)   = mk_string   s++repNameS :: Core String -> DsM (Core TH.Name)+repNameS (MkC name) = rep2 mkNameSName [name]++--------------- Miscellaneous -------------------++repGensym :: Core String -> DsM (Core (TH.Q TH.Name))+repGensym (MkC lit_str) = rep2 newNameName [lit_str]++repBindQ :: Type -> Type        -- a and b+         -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))+repBindQ ty_a ty_b (MkC x) (MkC y)+  = rep2 bindQName [Type ty_a, Type ty_b, x, y]++repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))+repSequenceQ ty_a (MkC list)+  = rep2 sequenceQName [Type ty_a, list]++repUnboundVar :: Core TH.Name -> DsM (Core TH.ExpQ)+repUnboundVar (MkC name) = rep2 unboundVarEName [name]++------------ Lists -------------------+-- turn a list of patterns into a single pattern matching a list++repList :: Name -> (a  -> DsM (Core b))+                -> [a] -> DsM (Core [b])+repList tc_name f args+  = do { args1 <- mapM f args+       ; coreList tc_name args1 }++coreList :: Name        -- Of the TyCon of the element type+         -> [Core a] -> DsM (Core [a])+coreList tc_name es+  = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }++coreList' :: Type       -- The element type+          -> [Core a] -> Core [a]+coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))++nonEmptyCoreList :: [Core a] -> Core [a]+  -- The list must be non-empty so we can get the element type+  -- Otherwise use coreList+nonEmptyCoreList []           = panic "coreList: empty argument"+nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))++coreStringLit :: String -> DsM (Core String)+coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }++------------------- Maybe ------------------++-- | Construct Core expression for Nothing of a given type name+coreNothing :: Name        -- ^ Name of the TyCon of the element type+            -> DsM (Core (Maybe a))+coreNothing tc_name =+    do { elt_ty <- lookupType tc_name; return (coreNothing' elt_ty) }++-- | Construct Core expression for Nothing of a given type+coreNothing' :: Type       -- ^ The element type+             -> Core (Maybe a)+coreNothing' elt_ty = MkC (mkNothingExpr elt_ty)++-- | Store given Core expression in a Just of a given type name+coreJust :: Name        -- ^ Name of the TyCon of the element type+         -> Core a -> DsM (Core (Maybe a))+coreJust tc_name es+  = do { elt_ty <- lookupType tc_name; return (coreJust' elt_ty es) }++-- | Store given Core expression in a Just of a given type+coreJust' :: Type       -- ^ The element type+          -> Core a -> Core (Maybe a)+coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es))++------------ Literals & Variables -------------------++coreIntLit :: Int -> DsM (Core Int)+coreIntLit i = do dflags <- getDynFlags+                  return (MkC (mkIntExprInt dflags i))++coreVar :: Id -> Core TH.Name   -- The Id has type Name+coreVar id = MkC (Var id)++----------------- Failure -----------------------+notHandledL :: SrcSpan -> String -> SDoc -> DsM a+notHandledL loc what doc+  | isGoodSrcSpan loc+  = putSrcSpanDs loc $ notHandled what doc+  | otherwise+  = notHandled what doc++notHandled :: String -> SDoc -> DsM a+notHandled what doc = failWithDs msg+  where+    msg = hang (text what <+> text "not (yet) handled by Template Haskell")+             2 doc
+ deSugar/DsMonad.hs view
@@ -0,0 +1,733 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++@DsMonad@: monadery used in desugaring+-}++{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an orphan++module DsMonad (+        DsM, mapM, mapAndUnzipM,+        initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs,+        foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM,+        Applicative(..),(<$>),++        duplicateLocalDs, newSysLocalDsNoLP, newSysLocalDs,+        newSysLocalsDsNoLP, newSysLocalsDs, newUniqueId,+        newFailLocalDs, newPredVarDs,+        getSrcSpanDs, putSrcSpanDs,+        mkPrintUnqualifiedDs,+        newUnique,+        UniqSupply, newUniqueSupply,+        getGhcModeDs, dsGetFamInstEnvs,+        dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon,+        dsLookupDataCon, dsLookupConLike,++        PArrBuiltin(..),+        dsLookupDPHRdrEnv, dsLookupDPHRdrEnv_maybe,+        dsInitPArrBuiltin,++        DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,++        -- Getting and setting EvVars and term constraints in local environment+        getDictsDs, addDictsDs, getTmCsDs, addTmCsDs,++        -- Iterations for pm checking+        incrCheckPmIterDs, resetPmIterDs, dsGetCompleteMatches,++        -- Warnings and errors+        DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr,+        failWithDs, failDs, discardWarningsDs,+        askNoErrsDs,++        -- Data types+        DsMatchContext(..),+        EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,+        CanItFail(..), orFail,++        -- Levity polymorphism+        dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs+    ) where++import TcRnMonad+import FamInstEnv+import CoreSyn+import MkCore    ( unitExpr )+import CoreUtils ( exprType, isExprLevPoly )+import HsSyn+import TcIface+import TcMType ( checkForLevPolyX, formatLevPolyErr )+import LoadIface+import Finder+import PrelNames+import RdrName+import HscTypes+import Bag+import DataCon+import ConLike+import TyCon+import PmExpr+import Id+import Module+import Outputable+import SrcLoc+import Type+import UniqSupply+import Name+import NameEnv+import DynFlags+import ErrUtils+import FastString+import Maybes+import Var (EvVar)+import qualified GHC.LanguageExtensions as LangExt+import UniqFM ( lookupWithDefaultUFM )++import Data.IORef+import Control.Monad++{-+************************************************************************+*                                                                      *+                Data types for the desugarer+*                                                                      *+************************************************************************+-}++data DsMatchContext+  = DsMatchContext (HsMatchContext Name) SrcSpan+  deriving ()++instance Outputable DsMatchContext where+  ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match++data EquationInfo+  = EqnInfo { eqn_pats :: [Pat Id],     -- The patterns for an eqn+              eqn_rhs  :: MatchResult } -- What to do after match++instance Outputable EquationInfo where+    ppr (EqnInfo pats _) = ppr pats++type DsWrapper = CoreExpr -> CoreExpr+idDsWrapper :: DsWrapper+idDsWrapper e = e++-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult+--      \fail. wrap (case vs of { pats -> rhs fail })+-- where vs are not bound by wrap+++-- A MatchResult is an expression with a hole in it+data MatchResult+  = MatchResult+        CanItFail       -- Tells whether the failure expression is used+        (CoreExpr -> DsM CoreExpr)+                        -- Takes a expression to plug in at the+                        -- failure point(s). The expression should+                        -- be duplicatable!++data CanItFail = CanFail | CantFail++orFail :: CanItFail -> CanItFail -> CanItFail+orFail CantFail CantFail = CantFail+orFail _        _        = CanFail++{-+************************************************************************+*                                                                      *+                Monad functions+*                                                                      *+************************************************************************+-}++-- Compatibility functions+fixDs :: (a -> DsM a) -> DsM a+fixDs    = fixM++type DsWarning = (SrcSpan, SDoc)+        -- Not quite the same as a WarnMsg, we have an SDoc here+        -- and we'll do the print_unqual stuff later on to turn it+        -- into a Doc.++-- | Run a 'DsM' action inside the 'TcM' monad.+initDsTc :: DsM a -> TcM a+initDsTc thing_inside+  = do { tcg_env  <- getGblEnv+       ; msg_var  <- getErrsVar+       ; hsc_env  <- getTopEnv+       ; envs     <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env+       ; setEnvs envs $ initDPH thing_inside+       }++-- | Run a 'DsM' action inside the 'IO' monad.+initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages, Maybe a)+initDs hsc_env tcg_env thing_inside+  = do { msg_var <- newIORef emptyMessages+       ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env+       ; runDs hsc_env envs thing_inside+       }++-- | Build a set of desugarer environments derived from a 'TcGblEnv'.+mkDsEnvsFromTcGbl :: MonadIO m+                  => HscEnv -> IORef Messages -> TcGblEnv+                  -> m (DsGblEnv, DsLclEnv)+mkDsEnvsFromTcGbl hsc_env msg_var tcg_env+  = do { pm_iter_var <- liftIO $ newIORef 0+       ; let dflags   = hsc_dflags hsc_env+             this_mod = tcg_mod tcg_env+             type_env = tcg_type_env tcg_env+             rdr_env  = tcg_rdr_env tcg_env+             fam_inst_env = tcg_fam_inst_env tcg_env+             complete_matches = hptCompleteSigs hsc_env+                                ++ tcg_complete_matches tcg_env+       ; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env+                           msg_var pm_iter_var complete_matches+       }++runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)+runDs hsc_env (ds_gbl, ds_lcl) thing_inside+  = do { res    <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl+                              (initDPH $ tryM thing_inside)+       ; msgs   <- readIORef (ds_msgs ds_gbl)+       ; let final_res+               | errorsFound dflags msgs = Nothing+               | Right r <- res          = Just r+               | otherwise               = panic "initDs"+       ; return (msgs, final_res)+       }+  where dflags = hsc_dflags hsc_env++-- | Run a 'DsM' action in the context of an existing 'ModGuts'+initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a)+initDsWithModGuts hsc_env guts thing_inside+  = do { pm_iter_var <- newIORef 0+       ; msg_var <- newIORef emptyMessages+       ; let dflags   = hsc_dflags hsc_env+             type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts)+             rdr_env  = mg_rdr_env guts+             fam_inst_env = mg_fam_inst_env guts+             this_mod = mg_module guts+             complete_matches = hptCompleteSigs hsc_env+                                ++ mg_complete_sigs guts++             bindsToIds (NonRec v _)   = [v]+             bindsToIds (Rec    binds) = map fst binds+             ids = concatMap bindsToIds (mg_binds guts)++             envs  = mkDsEnvs dflags this_mod rdr_env type_env+                              fam_inst_env msg_var pm_iter_var+                              complete_matches+       ; runDs hsc_env envs thing_inside+       }++initTcDsForSolver :: TcM a -> DsM (Messages, Maybe a)+-- Spin up a TcM context so that we can run the constraint solver+-- Returns any error messages generated by the constraint solver+-- and (Just res) if no error happened; Nothing if an error happened+--+-- Simon says: I'm not very happy about this.  We spin up a complete TcM monad+--             only to immediately refine it to a TcS monad.+-- Better perhaps to make TcS into its own monad, rather than building on TcS+-- But that may in turn interact with plugins++initTcDsForSolver thing_inside+  = do { (gbl, lcl) <- getEnvs+       ; hsc_env    <- getTopEnv++       ; let DsGblEnv { ds_mod = mod+                      , ds_fam_inst_env = fam_inst_env } = gbl++             DsLclEnv { dsl_loc = loc }                  = lcl++       ; liftIO $ initTc hsc_env HsSrcFile False mod loc $+         updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env }) $+         thing_inside }++mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv+         -> IORef Messages -> IORef Int -> [CompleteMatch]+         -> (DsGblEnv, DsLclEnv)+mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar+         complete_matches+  = let if_genv = IfGblEnv { if_doc       = text "mkDsEnvs",+                             if_rec_types = Just (mod, return type_env) }+        if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)+                             False -- not boot!+        real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)+        completeMatchMap = mkCompleteMatchMap complete_matches+        gbl_env = DsGblEnv { ds_mod     = mod+                           , ds_fam_inst_env = fam_inst_env+                           , ds_if_env  = (if_genv, if_lenv)+                           , ds_unqual  = mkPrintUnqualified dflags rdr_env+                           , ds_msgs    = msg_var+                           , ds_dph_env = emptyGlobalRdrEnv+                           , ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi"+                           , ds_complete_matches = completeMatchMap+                           }+        lcl_env = DsLclEnv { dsl_meta    = emptyNameEnv+                           , dsl_loc     = real_span+                           , dsl_dicts   = emptyBag+                           , dsl_tm_cs   = emptyBag+                           , dsl_pm_iter = pmvar+                           }+    in (gbl_env, lcl_env)+++{-+************************************************************************+*                                                                      *+                Operations in the monad+*                                                                      *+************************************************************************++And all this mysterious stuff is so we can occasionally reach out and+grab one or more names.  @newLocalDs@ isn't exported---exported+functions are defined with it.  The difference in name-strings makes+it easier to read debugging output.++Note [Levity polymorphism checking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+According to the Levity Polymorphism paper+<http://cs.brynmawr.edu/~rae/papers/2017/levity/levity.pdf>, levity+polymorphism is forbidden in precisely two places: in the type of a bound+term-level argument and in the type of an argument to a function. The paper+explains it more fully, but briefly: expressions in these contexts need to be+stored in registers, and it's hard (read, impossible) to store something+that's levity polymorphic.++We cannot check for bad levity polymorphism conveniently in the type checker,+because we can't tell, a priori, which levity metavariables will be solved.+At one point, I (Richard) thought we could check in the zonker, but it's hard+to know where precisely are the abstracted variables and the arguments. So+we check in the desugarer, the only place where we can see the Core code and+still report respectable syntax to the user. This covers the vast majority+of cases; see calls to DsMonad.dsNoLevPoly and friends.++Levity polymorphism is also prohibited in the types of binders, and the+desugarer checks for this in GHC-generated Ids. (The zonker handles+the user-writted ids in zonkIdBndr.) This is done in newSysLocalDsNoLP.+The newSysLocalDs variant is used in the vast majority of cases where+the binder is obviously not levity polymorphic, omitting the check.+It would be nice to ASSERT that there is no levity polymorphism here,+but we can't, because of the fixM in DsArrows. It's all OK, though:+Core Lint will catch an error here.++However, the desugarer is the wrong place for certain checks. In particular,+the desugarer can't report a sensible error message if an HsWrapper is malformed.+After all, GHC itself produced the HsWrapper. So we store some message text+in the appropriate HsWrappers (e.g. WpFun) that we can print out in the+desugarer.++There are a few more checks in places where Core is generated outside the+desugarer. For example, in datatype and class declarations, where levity+polymorphism is checked for during validity checking. It would be nice to+have one central place for all this, but that doesn't seem possible while+still reporting nice error messages.++-}++-- Make a new Id with the same print name, but different type, and new unique+newUniqueId :: Id -> Type -> DsM Id+newUniqueId id = mk_local (occNameFS (nameOccName (idName id)))++duplicateLocalDs :: Id -> DsM Id+duplicateLocalDs old_local+  = do  { uniq <- newUnique+        ; return (setIdUnique old_local uniq) }++newPredVarDs :: PredType -> DsM Var+newPredVarDs pred+ = newSysLocalDs pred++newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Type -> DsM Id+newSysLocalDsNoLP  = mk_local (fsLit "ds")++-- this variant should be used when the caller can be sure that the variable type+-- is not levity-polymorphic. It is necessary when the type is knot-tied because+-- of the fixM used in DsArrows. See Note [Levity polymorphism checking]+newSysLocalDs = mkSysLocalOrCoVarM (fsLit "ds")+newFailLocalDs = mkSysLocalOrCoVarM (fsLit "fail")+  -- the fail variable is used only in a situation where we can tell that+  -- levity-polymorphism is impossible.++newSysLocalsDsNoLP, newSysLocalsDs :: [Type] -> DsM [Id]+newSysLocalsDsNoLP = mapM newSysLocalDsNoLP+newSysLocalsDs = mapM newSysLocalDs++mk_local :: FastString -> Type -> DsM Id+mk_local fs ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+>+                                      ppr ty)  -- could improve the msg with another+                                               -- parameter indicating context+                    ; mkSysLocalOrCoVarM fs ty }++{-+We can also reach out and either set/grab location information from+the @SrcSpan@ being carried around.+-}++getGhcModeDs :: DsM GhcMode+getGhcModeDs =  getDynFlags >>= return . ghcMode++-- | Get in-scope type constraints (pm check)+getDictsDs :: DsM (Bag EvVar)+getDictsDs = do { env <- getLclEnv; return (dsl_dicts env) }++-- | Add in-scope type constraints (pm check)+addDictsDs :: Bag EvVar -> DsM a -> DsM a+addDictsDs ev_vars+  = updLclEnv (\env -> env { dsl_dicts = unionBags ev_vars (dsl_dicts env) })++-- | Get in-scope term constraints (pm check)+getTmCsDs :: DsM (Bag SimpleEq)+getTmCsDs = do { env <- getLclEnv; return (dsl_tm_cs env) }++-- | Add in-scope term constraints (pm check)+addTmCsDs :: Bag SimpleEq -> DsM a -> DsM a+addTmCsDs tm_cs+  = updLclEnv (\env -> env { dsl_tm_cs = unionBags tm_cs (dsl_tm_cs env) })++-- | Increase the counter for elapsed pattern match check iterations.+-- If the current counter is already over the limit, fail+incrCheckPmIterDs :: DsM Int+incrCheckPmIterDs = do+  env <- getLclEnv+  cnt <- readTcRef (dsl_pm_iter env)+  max_iters <- maxPmCheckIterations <$> getDynFlags+  if cnt >= max_iters+    then failM+    else updTcRef (dsl_pm_iter env) (+1)+  return cnt++-- | Reset the counter for pattern match check iterations to zero+resetPmIterDs :: DsM ()+resetPmIterDs = do { env <- getLclEnv; writeTcRef (dsl_pm_iter env) 0 }++getSrcSpanDs :: DsM SrcSpan+getSrcSpanDs = do { env <- getLclEnv+                  ; return (RealSrcSpan (dsl_loc env)) }++putSrcSpanDs :: SrcSpan -> DsM a -> DsM a+putSrcSpanDs (UnhelpfulSpan {}) thing_inside+  = thing_inside+putSrcSpanDs (RealSrcSpan real_span) thing_inside+  = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside++-- | Emit a warning for the current source location+-- NB: Warns whether or not -Wxyz is set+warnDs :: WarnReason -> SDoc -> DsM ()+warnDs reason warn+  = do { env <- getGblEnv+       ; loc <- getSrcSpanDs+       ; dflags <- getDynFlags+       ; let msg = makeIntoWarning reason $+                   mkWarnMsg dflags loc (ds_unqual env) warn+       ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }++-- | Emit a warning only if the correct WarnReason is set in the DynFlags+warnIfSetDs :: WarningFlag -> SDoc -> DsM ()+warnIfSetDs flag warn+  = whenWOptM flag $+    warnDs (Reason flag) warn++errDs :: SDoc -> DsM ()+errDs err+  = do  { env <- getGblEnv+        ; loc <- getSrcSpanDs+        ; dflags <- getDynFlags+        ; let msg = mkErrMsg dflags loc (ds_unqual env) err+        ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) }++-- | Issue an error, but return the expression for (), so that we can continue+-- reporting errors.+errDsCoreExpr :: SDoc -> DsM CoreExpr+errDsCoreExpr err+  = do { errDs err+       ; return unitExpr }++failWithDs :: SDoc -> DsM a+failWithDs err+  = do  { errDs err+        ; failM }++failDs :: DsM a+failDs = failM++-- (askNoErrsDs m) runs m+-- If m fails,+--    then (askNoErrsDs m) fails+-- If m succeeds with result r,+--    then (askNoErrsDs m) succeeds with result (r, b),+--         where b is True iff m generated no errors+-- Regardless of success or failure,+--   propagate any errors/warnings generated by m+--+-- c.f. TcRnMonad.askNoErrs+askNoErrsDs :: DsM a -> DsM (a, Bool)+askNoErrsDs thing_inside+ = do { errs_var <- newMutVar emptyMessages+      ; env <- getGblEnv+      ; mb_res <- tryM $  -- Be careful to catch exceptions+                          -- so that we propagate errors correctly+                          -- (Trac #13642)+                  setGblEnv (env { ds_msgs = errs_var }) $+                  thing_inside++      -- Propagate errors+      ; msgs@(warns, errs) <- readMutVar errs_var+      ; updMutVar (ds_msgs env) (\ (w,e) -> (w `unionBags` warns, e `unionBags` errs))++      -- And return+      ; case mb_res of+           Left _    -> failM+           Right res -> do { dflags <- getDynFlags+                           ; let errs_found = errorsFound dflags msgs+                           ; return (res, not errs_found) } }++mkPrintUnqualifiedDs :: DsM PrintUnqualified+mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv++instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where+    lookupThing = dsLookupGlobal++-- | Attempt to load the given module and return its exported entities if+-- successful.+dsLoadModule :: SDoc -> Module -> DsM GlobalRdrEnv+dsLoadModule doc mod+  = do { env    <- getGblEnv+       ; setEnvs (ds_if_env env) $ do+       { iface <- loadInterface doc mod ImportBySystem+       ; case iface of+           Failed err      -> pprPanic "DsMonad.dsLoadModule: failed to load" (err $$ doc)+           Succeeded iface -> return $ mkGlobalRdrEnv . gresFromAvails prov . mi_exports $ iface+       } }+  where+    prov     = Just (ImpSpec { is_decl = imp_spec, is_item = ImpAll })+    imp_spec = ImpDeclSpec { is_mod = name, is_qual = True,+                             is_dloc = wiredInSrcSpan, is_as = name }+    name = moduleName mod++dsLookupGlobal :: Name -> DsM TyThing+-- Very like TcEnv.tcLookupGlobal+dsLookupGlobal name+  = do  { env <- getGblEnv+        ; setEnvs (ds_if_env env)+                  (tcIfaceGlobal name) }++dsLookupGlobalId :: Name -> DsM Id+dsLookupGlobalId name+  = tyThingId <$> dsLookupGlobal name++dsLookupTyCon :: Name -> DsM TyCon+dsLookupTyCon name+  = tyThingTyCon <$> dsLookupGlobal name++dsLookupDataCon :: Name -> DsM DataCon+dsLookupDataCon name+  = tyThingDataCon <$> dsLookupGlobal name++dsLookupConLike :: Name -> DsM ConLike+dsLookupConLike name+  = tyThingConLike <$> dsLookupGlobal name+++dsGetFamInstEnvs :: DsM FamInstEnvs+-- Gets both the external-package inst-env+-- and the home-pkg inst env (includes module being compiled)+dsGetFamInstEnvs+  = do { eps <- getEps; env <- getGblEnv+       ; return (eps_fam_inst_env eps, ds_fam_inst_env env) }++dsGetMetaEnv :: DsM (NameEnv DsMetaVal)+dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }++-- | The @COMPLETE@ pragams provided by the user for a given `TyCon`.+dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch]+dsGetCompleteMatches tc = do+  eps <- getEps+  env <- getGblEnv+  let lookup_completes ufm = lookupWithDefaultUFM ufm [] tc+      eps_matches_list = lookup_completes $ eps_complete_matches eps+      env_matches_list = lookup_completes $ ds_complete_matches env+  return $ eps_matches_list ++ env_matches_list++dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)+dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }++dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a+dsExtendMetaEnv menv thing_inside+  = updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside++discardWarningsDs :: DsM a -> DsM a+-- Ignore warnings inside the thing inside;+-- used to ignore inaccessable cases etc. inside generated code+discardWarningsDs thing_inside+  = do  { env <- getGblEnv+        ; old_msgs <- readTcRef (ds_msgs env)++        ; result <- thing_inside++        -- Revert messages to old_msgs+        ; writeTcRef (ds_msgs env) old_msgs++        ; return result }++-- | Fail with an error message if the type is levity polymorphic.+dsNoLevPoly :: Type -> SDoc -> DsM ()+-- See Note [Levity polymorphism checking]+dsNoLevPoly ty doc = checkForLevPolyX errDs doc ty++-- | Check an expression for levity polymorphism, failing if it is+-- levity polymorphic.+dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM ()+-- See Note [Levity polymorphism checking]+dsNoLevPolyExpr e doc+  | isExprLevPoly e = errDs (formatLevPolyErr (exprType e) $$ doc)+  | otherwise       = return ()++-- | Runs the thing_inside. If there are no errors, then returns the expr+-- given. Otherwise, returns unitExpr. This is useful for doing a bunch+-- of levity polymorphism checks and then avoiding making a core App.+-- (If we make a core App on a levity polymorphic argument, detecting how+-- to handle the let/app invariant might call isUnliftedType, which panics+-- on a levity polymorphic type.)+-- See #12709 for an example of why this machinery is necessary.+dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr+dsWhenNoErrs thing_inside mk_expr+  = do { (result, no_errs) <- askNoErrsDs thing_inside+       ; return $ if no_errs+                  then mk_expr result+                  else unitExpr }++--------------------------------------------------------------------------+--                  Data Parallel Haskell+--------------------------------------------------------------------------++-- | Run a 'DsM' with DPH things in scope if necessary.+initDPH :: DsM a -> DsM a+initDPH = loadDAP . initDPHBuiltins++-- | Extend the global environment with a 'GlobalRdrEnv' containing the exported+-- entities of,+--+--   * 'Data.Array.Parallel'      iff '-XParallelArrays' specified (see also 'checkLoadDAP').+--   * 'Data.Array.Parallel.Prim' iff '-fvectorise' specified.+loadDAP :: DsM a -> DsM a+loadDAP thing_inside+  = do { dapEnv  <- loadOneModule dATA_ARRAY_PARALLEL_NAME      checkLoadDAP          paErr+       ; dappEnv <- loadOneModule dATA_ARRAY_PARALLEL_PRIM_NAME (goptM Opt_Vectorise) veErr+       ; updGblEnv (\env -> env {ds_dph_env = dapEnv `plusOccEnv` dappEnv }) thing_inside+       }+  where+    loadOneModule :: ModuleName           -- the module to load+                  -> DsM Bool             -- under which condition+                  -> MsgDoc               -- error message if module not found+                  -> DsM GlobalRdrEnv     -- empty if condition 'False'+    loadOneModule modname check err+      = do { doLoad <- check+           ; if not doLoad+             then return emptyGlobalRdrEnv+             else do {+           ; hsc_env <- getTopEnv+           ; result <- liftIO $ findImportedModule hsc_env modname Nothing+           ; case result of+               Found _ mod -> dsLoadModule err mod+               _           -> pprPgmError "Unable to use Data Parallel Haskell (DPH):" err+           } }++    paErr       = text "To use ParallelArrays," <+> specBackend $$ hint1 $$ hint2+    veErr       = text "To use -fvectorise," <+> specBackend $$ hint1 $$ hint2+    specBackend = text "you must specify a DPH backend package"+    hint1       = text "Look for packages named 'dph-lifted-*' with 'ghc-pkg'"+    hint2       = text "You may need to install them with 'cabal install dph-examples'"++-- | If '-XParallelArrays' given, we populate the builtin table for desugaring+-- those.+initDPHBuiltins :: DsM a -> DsM a+initDPHBuiltins thing_inside+  = do { doInitBuiltins <- checkLoadDAP+       ; if doInitBuiltins+         then dsInitPArrBuiltin thing_inside+         else thing_inside+       }++checkLoadDAP :: DsM Bool+checkLoadDAP+  = do { paEnabled <- xoptM LangExt.ParallelArrays+       ; mod <- getModule+         -- do not load 'Data.Array.Parallel' iff compiling 'base:GHC.PArr' or a+         -- module called 'dATA_ARRAY_PARALLEL_NAME'; see also the comments at the top+         -- of 'base:GHC.PArr' and 'Data.Array.Parallel' in the DPH libraries+       ; return $ paEnabled &&+                  mod /= gHC_PARR' &&+                  moduleName mod /= dATA_ARRAY_PARALLEL_NAME+       }++-- | Populate 'ds_parr_bi' from 'ds_dph_env'.+--+dsInitPArrBuiltin :: DsM a -> DsM a+dsInitPArrBuiltin thing_inside+  = do { lengthPVar         <- externalVar (fsLit "lengthP")+       ; replicatePVar      <- externalVar (fsLit "replicateP")+       ; singletonPVar      <- externalVar (fsLit "singletonP")+       ; mapPVar            <- externalVar (fsLit "mapP")+       ; filterPVar         <- externalVar (fsLit "filterP")+       ; zipPVar            <- externalVar (fsLit "zipP")+       ; crossMapPVar       <- externalVar (fsLit "crossMapP")+       ; indexPVar          <- externalVar (fsLit "!:")+       ; emptyPVar          <- externalVar (fsLit "emptyP")+       ; appPVar            <- externalVar (fsLit "+:+")+       -- ; enumFromToPVar     <- externalVar (fsLit "enumFromToP")+       -- ; enumFromThenToPVar <- externalVar (fsLit "enumFromThenToP")+       ; enumFromToPVar     <- return arithErr+       ; enumFromThenToPVar <- return arithErr++       ; updGblEnv (\env -> env {ds_parr_bi = PArrBuiltin+                                              { lengthPVar         = lengthPVar+                                              , replicatePVar      = replicatePVar+                                              , singletonPVar      = singletonPVar+                                              , mapPVar            = mapPVar+                                              , filterPVar         = filterPVar+                                              , zipPVar            = zipPVar+                                              , crossMapPVar       = crossMapPVar+                                              , indexPVar          = indexPVar+                                              , emptyPVar          = emptyPVar+                                              , appPVar            = appPVar+                                              , enumFromToPVar     = enumFromToPVar+                                              , enumFromThenToPVar = enumFromThenToPVar+                                              } })+                   thing_inside+       }+  where+    externalVar :: FastString -> DsM Var+    externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId++    arithErr = panic "Arithmetic sequences have to wait until we support type classes"++-- |Get a name from "Data.Array.Parallel" for the desugarer, from the+-- 'ds_parr_bi' component of the global desugerar environment.+--+dsDPHBuiltin :: (PArrBuiltin -> a) -> DsM a+dsDPHBuiltin sel = (sel . ds_parr_bi) <$> getGblEnv++-- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim'.+--  Panic if there isn't one, or if it is defined multiple times.+dsLookupDPHRdrEnv :: OccName -> DsM Name+dsLookupDPHRdrEnv occ+  = liftM (fromMaybe (pprPanic nameNotFound (ppr occ)))+  $ dsLookupDPHRdrEnv_maybe occ+  where nameNotFound  = "Name not found in 'Data.Array.Parallel' or 'Data.Array.Parallel.Prim':"++-- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim',+--  returning `Nothing` if it's not defined. Panic if it's defined multiple times.+dsLookupDPHRdrEnv_maybe :: OccName -> DsM (Maybe Name)+dsLookupDPHRdrEnv_maybe occ+  = do { env <- ds_dph_env <$> getGblEnv+       ; let gres = lookupGlobalRdrEnv env occ+       ; case gres of+           []    -> return $ Nothing+           [gre] -> return $ Just $ gre_name gre+           _     -> pprPanic multipleNames (ppr occ)+       }+  where multipleNames = "Multiple definitions in 'Data.Array.Parallel' and 'Data.Array.Parallel.Prim':"
+ deSugar/DsUsage.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE CPP #-}++module DsUsage (+    -- * Dependency/fingerprinting code (used by MkIface)+    mkUsageInfo, mkUsedNames, mkDependencies+    ) where++#include "HsVersions.h"++import DynFlags+import HscTypes+import TcRnTypes+import Name+import NameSet+import Module+import Outputable+import Util+import UniqSet+import UniqFM+import Fingerprint+import Maybes++import Data.List+import Data.IORef+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Set as Set++-- | Extract information from the rename and typecheck phases to produce+-- a dependencies information for the module being compiled.+mkDependencies :: TcGblEnv -> IO Dependencies+mkDependencies+          TcGblEnv{ tcg_mod = mod,+                    tcg_imports = imports,+                    tcg_th_used = th_var+                  }+ = do+      -- Template Haskell used?+      th_used <- readIORef th_var+      let dep_mods = modDepsElts (delFromUFM (imp_dep_mods imports)+                                           (moduleName mod))+                -- M.hi-boot can be in the imp_dep_mods, but we must remove+                -- it before recording the modules on which this one depends!+                -- (We want to retain M.hi-boot in imp_dep_mods so that+                --  loadHiBootInterface can see if M's direct imports depend+                --  on M.hi-boot, and hence that we should do the hi-boot consistency+                --  check.)++          pkgs | th_used   = Set.insert (toInstalledUnitId thUnitId) (imp_dep_pkgs imports)+               | otherwise = imp_dep_pkgs imports++          -- Set the packages required to be Safe according to Safe Haskell.+          -- See Note [RnNames . Tracking Trust Transitively]+          sorted_pkgs = sort (Set.toList pkgs)+          trust_pkgs  = imp_trust_pkgs imports+          dep_pkgs'   = map (\x -> (x, x `Set.member` trust_pkgs)) sorted_pkgs++      return Deps { dep_mods   = dep_mods,+                    dep_pkgs   = dep_pkgs',+                    dep_orphs  = sortBy stableModuleCmp (imp_orphs  imports),+                    dep_finsts = sortBy stableModuleCmp (imp_finsts imports) }+                    -- sort to get into canonical order+                    -- NB. remember to use lexicographic ordering++mkUsedNames :: TcGblEnv -> NameSet+mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus++mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] -> [(Module, Fingerprint)] -> IO [Usage]+mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged+  = do+    eps <- hscEPS hsc_env+    hashes <- mapM getFileHash dependent_files+    let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod+                                       dir_imp_mods used_names+        usages = mod_usages ++ [ UsageFile { usg_file_path = f+                                           , usg_file_hash = hash }+                               | (f, hash) <- zip dependent_files hashes ]+                            ++ [ UsageMergedRequirement+                                    { usg_mod = mod,+                                      usg_mod_hash = hash+                                    }+                               | (mod, hash) <- merged ]+    usages `seqList` return usages+    -- seq the list of Usages returned: occasionally these+    -- don't get evaluated for a while and we can end up hanging on to+    -- the entire collection of Ifaces.++mk_mod_usage_info :: PackageIfaceTable+              -> HscEnv+              -> Module+              -> ImportedMods+              -> NameSet+              -> [Usage]+mk_mod_usage_info pit hsc_env this_mod direct_imports used_names+  = mapMaybe mkUsage usage_mods+  where+    hpt = hsc_HPT hsc_env+    dflags = hsc_dflags hsc_env+    this_pkg = thisPackage dflags++    used_mods    = moduleEnvKeys ent_map+    dir_imp_mods = moduleEnvKeys direct_imports+    all_mods     = used_mods ++ filter (`notElem` used_mods) dir_imp_mods+    usage_mods   = sortBy stableModuleCmp all_mods+                        -- canonical order is imported, to avoid interface-file+                        -- wobblage.++    -- ent_map groups together all the things imported and used+    -- from a particular module+    ent_map :: ModuleEnv [OccName]+    ent_map  = nonDetFoldUniqSet add_mv emptyModuleEnv used_names+     -- nonDetFoldUFM is OK here. If you follow the logic, we sort by OccName+     -- in ent_hashs+     where+      add_mv name mv_map+        | isWiredInName name = mv_map  -- ignore wired-in names+        | otherwise+        = case nameModule_maybe name of+             Nothing  -> ASSERT2( isSystemName name, ppr name ) mv_map+                -- See Note [Internal used_names]++             Just mod ->+                -- See Note [Identity versus semantic module]+                let mod' = if isHoleModule mod+                            then mkModule this_pkg (moduleName mod)+                            else mod+                -- This lambda function is really just a+                -- specialised (++); originally came about to+                -- avoid quadratic behaviour (trac #2680)+                in extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod' [occ]+            where occ = nameOccName name++    -- We want to create a Usage for a home module if+    --  a) we used something from it; has something in used_names+    --  b) we imported it, even if we used nothing from it+    --     (need to recompile if its export list changes: export_fprint)+    mkUsage :: Module -> Maybe Usage+    mkUsage mod+      | isNothing maybe_iface           -- We can't depend on it if we didn't+                                        -- load its interface.+      || mod == this_mod                -- We don't care about usages of+                                        -- things in *this* module+      = Nothing++      | moduleUnitId mod /= this_pkg+      = Just UsagePackageModule{ usg_mod      = mod,+                                 usg_mod_hash = mod_hash,+                                 usg_safe     = imp_safe }+        -- for package modules, we record the module hash only++      | (null used_occs+          && isNothing export_hash+          && not is_direct_import+          && not finsts_mod)+      = Nothing                 -- Record no usage info+        -- for directly-imported modules, we always want to record a usage+        -- on the orphan hash.  This is what triggers a recompilation if+        -- an orphan is added or removed somewhere below us in the future.++      | otherwise+      = Just UsageHomeModule {+                      usg_mod_name = moduleName mod,+                      usg_mod_hash = mod_hash,+                      usg_exports  = export_hash,+                      usg_entities = Map.toList ent_hashs,+                      usg_safe     = imp_safe }+      where+        maybe_iface  = lookupIfaceByModule dflags hpt pit mod+                -- In one-shot mode, the interfaces for home-package+                -- modules accumulate in the PIT not HPT.  Sigh.++        Just iface   = maybe_iface+        finsts_mod   = mi_finsts    iface+        hash_env     = mi_hash_fn   iface+        mod_hash     = mi_mod_hash  iface+        export_hash | depend_on_exports = Just (mi_exp_hash iface)+                    | otherwise         = Nothing++        by_is_safe (ImportedByUser imv) = imv_is_safe imv+        by_is_safe _ = False+        (is_direct_import, imp_safe)+            = case lookupModuleEnv direct_imports mod of+                -- ezyang: I'm not sure if any is the correct+                -- metric here. If safety was guaranteed to be uniform+                -- across all imports, why did the old code only look+                -- at the first import?+                Just bys -> (True, any by_is_safe bys)+                Nothing  -> (False, safeImplicitImpsReq dflags)+                -- Nothing case is for references to entities which were+                -- not directly imported (NB: the "implicit" Prelude import+                -- counts as directly imported!  An entity is not directly+                -- imported if, e.g., we got a reference to it from a+                -- reexport of another module.)++        used_occs = lookupModuleEnv ent_map mod `orElse` []++        -- Making a Map here ensures that (a) we remove duplicates+        -- when we have usages on several subordinates of a single parent,+        -- and (b) that the usages emerge in a canonical order, which+        -- is why we use Map rather than OccEnv: Map works+        -- using Ord on the OccNames, which is a lexicographic ordering.+        ent_hashs :: Map OccName Fingerprint+        ent_hashs = Map.fromList (map lookup_occ used_occs)++        lookup_occ occ =+            case hash_env occ of+                Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names)+                Just r  -> r++        depend_on_exports = is_direct_import+        {- True+              Even if we used 'import M ()', we have to register a+              usage on the export list because we are sensitive to+              changes in orphan instances/rules.+           False+              In GHC 6.8.x we always returned true, and in+              fact it recorded a dependency on *all* the+              modules underneath in the dependency tree.  This+              happens to make orphans work right, but is too+              expensive: it'll read too many interface files.+              The 'isNothing maybe_iface' check above saved us+              from generating many of these usages (at least in+              one-shot mode), but that's even more bogus!+        -}
+ deSugar/DsUtils.hs view
@@ -0,0 +1,1008 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Utilities for desugaring++This module exports some utility functions of no great interest.+-}++{-# LANGUAGE CPP #-}++-- | Utility functions for constructing Core syntax, principally for desugaring+module DsUtils (+        EquationInfo(..),+        firstPat, shiftEqns,++        MatchResult(..), CanItFail(..), CaseAlt(..),+        cantFailMatchResult, alwaysFailMatchResult,+        extractMatchResult, combineMatchResults,+        adjustMatchResult,  adjustMatchResultDs,+        mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,+        matchCanFail, mkEvalMatchResult,+        mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult,+        wrapBind, wrapBinds,++        mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs,++        seqVar,++        -- LHs tuples+        mkLHsVarPatTup, mkLHsPatTup, mkVanillaTuplePat,+        mkBigLHsVarTupId, mkBigLHsTupId, mkBigLHsVarPatTupId, mkBigLHsPatTupId,++        mkSelectorBinds,++        selectSimpleMatchVarL, selectMatchVars, selectMatchVar,+        mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang+    ) where++#include "HsVersions.h"++import {-# SOURCE #-} Match  ( matchSimply )+import {-# SOURCE #-} DsExpr ( dsLExpr )++import HsSyn+import TcHsSyn+import TcType( tcSplitTyConApp )+import CoreSyn+import DsMonad++import CoreUtils+import MkCore+import MkId+import Id+import Literal+import TyCon+import DataCon+import PatSyn+import Type+import Coercion+import TysPrim+import TysWiredIn+import BasicTypes+import ConLike+import UniqSet+import UniqSupply+import Module+import PrelNames+import Name( isInternalName )+import Outputable+import SrcLoc+import Util+import DynFlags+import FastString+import qualified GHC.LanguageExtensions as LangExt++import TcEvidence++import Control.Monad    ( zipWithM )++{-+************************************************************************+*                                                                      *+\subsection{ Selecting match variables}+*                                                                      *+************************************************************************++We're about to match against some patterns.  We want to make some+@Ids@ to use as match variables.  If a pattern has an @Id@ readily at+hand, which should indeed be bound to the pattern as a whole, then use it;+otherwise, make one up.+-}++selectSimpleMatchVarL :: LPat Id -> DsM Id+selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)++-- (selectMatchVars ps tys) chooses variables of type tys+-- to use for matching ps against.  If the pattern is a variable,+-- we try to use that, to save inventing lots of fresh variables.+--+-- OLD, but interesting note:+--    But even if it is a variable, its type might not match.  Consider+--      data T a where+--        T1 :: Int -> T Int+--        T2 :: a   -> T a+--+--      f :: T a -> a -> Int+--      f (T1 i) (x::Int) = x+--      f (T2 i) (y::a)   = 0+--    Then we must not choose (x::Int) as the matching variable!+-- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat++selectMatchVars :: [Pat Id] -> DsM [Id]+selectMatchVars ps = mapM selectMatchVar ps++selectMatchVar :: Pat Id -> DsM Id+selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)+selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)+selectMatchVar (ParPat pat)  = selectMatchVar (unLoc pat)+selectMatchVar (VarPat var)  = return (localiseId (unLoc var))+                                  -- Note [Localise pattern binders]+selectMatchVar (AsPat var _) = return (unLoc var)+selectMatchVar other_pat     = newSysLocalDsNoLP (hsPatType other_pat)+                                  -- OK, better make up one...++{-+Note [Localise pattern binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider     module M where+               [Just a] = e+After renaming it looks like+             module M where+               [Just M.a] = e++We don't generalise, since it's a pattern binding, monomorphic, etc,+so after desugaring we may get something like+             M.a = case e of (v:_) ->+                   case v of Just M.a -> M.a+Notice the "M.a" in the pattern; after all, it was in the original+pattern.  However, after optimisation those pattern binders can become+let-binders, and then end up floated to top level.  They have a+different *unique* by then (the simplifier is good about maintaining+proper scoping), but it's BAD to have two top-level bindings with the+External Name M.a, because that turns into two linker symbols for M.a.+It's quite rare for this to actually *happen* -- the only case I know+of is tc003 compiled with the 'hpc' way -- but that only makes it+all the more annoying.++To avoid this, we craftily call 'localiseId' in the desugarer, which+simply turns the External Name for the Id into an Internal one, but+doesn't change the unique.  So the desugarer produces this:+             M.a{r8} = case e of (v:_) ->+                       case v of Just a{r8} -> M.a{r8}+The unique is still 'r8', but the binding site in the pattern+is now an Internal Name.  Now the simplifier's usual mechanisms+will propagate that Name to all the occurrence sites, as well as+un-shadowing it, so we'll get+             M.a{r8} = case e of (v:_) ->+                       case v of Just a{s77} -> a{s77}+In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr+runs on the output of the desugarer, so all is well by the end of+the desugaring pass.+++************************************************************************+*                                                                      *+* type synonym EquationInfo and access functions for its pieces        *+*                                                                      *+************************************************************************+\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}++The ``equation info'' used by @match@ is relatively complicated and+worthy of a type synonym and a few handy functions.+-}++firstPat :: EquationInfo -> Pat Id+firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)++shiftEqns :: [EquationInfo] -> [EquationInfo]+-- Drop the first pattern in each equation+shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]++-- Functions on MatchResults++matchCanFail :: MatchResult -> Bool+matchCanFail (MatchResult CanFail _)  = True+matchCanFail (MatchResult CantFail _) = False++alwaysFailMatchResult :: MatchResult+alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail)++cantFailMatchResult :: CoreExpr -> MatchResult+cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr)++extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr+extractMatchResult (MatchResult CantFail match_fn) _+  = match_fn (error "It can't fail!")++extractMatchResult (MatchResult CanFail match_fn) fail_expr = do+    (fail_bind, if_it_fails) <- mkFailurePair fail_expr+    body <- match_fn if_it_fails+    return (mkCoreLet fail_bind body)+++combineMatchResults :: MatchResult -> MatchResult -> MatchResult+combineMatchResults (MatchResult CanFail      body_fn1)+                    (MatchResult can_it_fail2 body_fn2)+  = MatchResult can_it_fail2 body_fn+  where+    body_fn fail = do body2 <- body_fn2 fail+                      (fail_bind, duplicatable_expr) <- mkFailurePair body2+                      body1 <- body_fn1 duplicatable_expr+                      return (Let fail_bind body1)++combineMatchResults match_result1@(MatchResult CantFail _) _+  = match_result1++adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult+adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)+  = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail)++adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult+adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)+  = MatchResult can_it_fail (\fail -> encl_fn =<< body_fn fail)++wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr+wrapBinds [] e = e+wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)++wrapBind :: Var -> Var -> CoreExpr -> CoreExpr+wrapBind new old body   -- NB: this function must deal with term+  | new==old    = body  -- variables, type variables or coercion variables+  | otherwise   = Let (NonRec new (varToCoreExpr old)) body++seqVar :: Var -> CoreExpr -> CoreExpr+seqVar var body = Case (Var var) var (exprType body)+                        [(DEFAULT, [], body)]++mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult+mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)++-- (mkViewMatchResult var' viewExpr mr) makes the expression+-- let var' = viewExpr in mr+mkViewMatchResult :: Id -> CoreExpr -> MatchResult -> MatchResult+mkViewMatchResult var' viewExpr =+    adjustMatchResult (mkCoreLet (NonRec var' viewExpr))++mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult+mkEvalMatchResult var ty+  = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])++mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult+mkGuardedMatchResult pred_expr (MatchResult _ body_fn)+  = MatchResult CanFail (\fail -> do body <- body_fn fail+                                     return (mkIfThenElse pred_expr body fail))++mkCoPrimCaseMatchResult :: Id                        -- Scrutinee+                        -> Type                      -- Type of the case+                        -> [(Literal, MatchResult)]  -- Alternatives+                        -> MatchResult               -- Literals are all unlifted+mkCoPrimCaseMatchResult var ty match_alts+  = MatchResult CanFail mk_case+  where+    mk_case fail = do+        alts <- mapM (mk_alt fail) sorted_alts+        return (Case (Var var) var ty ((DEFAULT, [], fail) : alts))++    sorted_alts = sortWith fst match_alts       -- Right order for a Case+    mk_alt fail (lit, MatchResult _ body_fn)+       = ASSERT( not (litIsLifted lit) )+         do body <- body_fn fail+            return (LitAlt lit, [], body)++data CaseAlt a = MkCaseAlt{ alt_pat :: a,+                            alt_bndrs :: [Var],+                            alt_wrapper :: HsWrapper,+                            alt_result :: MatchResult }++mkCoAlgCaseMatchResult+  :: DynFlags+  -> Id                 -- Scrutinee+  -> Type               -- Type of exp+  -> [CaseAlt DataCon]  -- Alternatives (bndrs *include* tyvars, dicts)+  -> MatchResult+mkCoAlgCaseMatchResult dflags var ty match_alts+  | isNewtype  -- Newtype case; use a let+  = ASSERT( null (tail match_alts) && null (tail arg_ids1) )+    mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1++  | isPArrFakeAlts match_alts+  = MatchResult CanFail $ mkPArrCase dflags var ty (sort_alts match_alts)+  | otherwise+  = mkDataConCase var ty match_alts+  where+    isNewtype = isNewTyCon (dataConTyCon (alt_pat alt1))++        -- [Interesting: because of GADTs, we can't rely on the type of+        --  the scrutinised Id to be sufficiently refined to have a TyCon in it]++    alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 }+      = ASSERT( notNull match_alts ) head match_alts+    -- Stuff for newtype+    arg_id1       = ASSERT( notNull arg_ids1 ) head arg_ids1+    var_ty        = idType var+    (tc, ty_args) = tcSplitTyConApp var_ty      -- Don't look through newtypes+                                                -- (not that splitTyConApp does, these days)+    newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)++        --- Stuff for parallel arrays+        --+        -- Concerning `isPArrFakeAlts':+        --+        --  * it is *not* sufficient to just check the type of the type+        --   constructor, as we have to be careful not to confuse the real+        --   representation of parallel arrays with the fake constructors;+        --   moreover, a list of alternatives must not mix fake and real+        --   constructors (this is checked earlier on)+        --+        -- FIXME: We actually go through the whole list and make sure that+        --        either all or none of the constructors are fake parallel+        --        array constructors.  This is to spot equations that mix fake+        --        constructors with the real representation defined in+        --        `PrelPArr'.  It would be nicer to spot this situation+        --        earlier and raise a proper error message, but it can really+        --        only happen in `PrelPArr' anyway.+        --++    isPArrFakeAlts :: [CaseAlt DataCon] -> Bool+    isPArrFakeAlts [alt] = isPArrFakeCon (alt_pat alt)+    isPArrFakeAlts (alt:alts) =+      case (isPArrFakeCon (alt_pat alt), isPArrFakeAlts alts) of+        (True , True ) -> True+        (False, False) -> False+        _              -> panic "DsUtils: you may not mix `[:...:]' with `PArr' patterns"+    isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives"++mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult+mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt++sort_alts :: [CaseAlt DataCon] -> [CaseAlt DataCon]+sort_alts = sortWith (dataConTag . alt_pat)++mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr+mkPatSynCase var ty alt fail = do+    matcher <- dsLExpr $ mkLHsWrap wrapper $+                         nlHsTyApp matcher [getRuntimeRep "mkPatSynCase" ty, ty]+    let MatchResult _ mkCont = match_result+    cont <- mkCoreLams bndrs <$> mkCont fail+    return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]+  where+    MkCaseAlt{ alt_pat = psyn,+               alt_bndrs = bndrs,+               alt_wrapper = wrapper,+               alt_result = match_result} = alt+    (matcher, needs_void_lam) = patSynMatcher psyn++    -- See Note [Matchers and builders for pattern synonyms] in PatSyns+    -- on these extra Void# arguments+    ensure_unstrict cont | needs_void_lam = Lam voidArgId cont+                         | otherwise      = cont++mkDataConCase :: Id -> Type -> [CaseAlt DataCon] -> MatchResult+mkDataConCase _   _  []            = panic "mkDataConCase: no alternatives"+mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case+  where+    con1          = alt_pat alt1+    tycon         = dataConTyCon con1+    data_cons     = tyConDataCons tycon+    match_results = map alt_result alts++    sorted_alts :: [CaseAlt DataCon]+    sorted_alts  = sort_alts alts++    var_ty       = idType var+    (_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes+                                          -- (not that splitTyConApp does, these days)++    mk_case :: CoreExpr -> DsM CoreExpr+    mk_case fail = do+        alts <- mapM (mk_alt fail) sorted_alts+        return $ mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts)++    mk_alt :: CoreExpr -> CaseAlt DataCon -> DsM CoreAlt+    mk_alt fail MkCaseAlt{ alt_pat = con,+                           alt_bndrs = args,+                           alt_result = MatchResult _ body_fn }+      = do { body <- body_fn fail+           ; case dataConBoxer con of {+                Nothing -> return (DataAlt con, args, body) ;+                Just (DCB boxer) ->+        do { us <- newUniqueSupply+           ; let (rep_ids, binds) = initUs_ us (boxer ty_args args)+           ; return (DataAlt con, rep_ids, mkLets binds body) } } }++    mk_default :: CoreExpr -> [CoreAlt]+    mk_default fail | exhaustive_case = []+                    | otherwise       = [(DEFAULT, [], fail)]++    fail_flag :: CanItFail+    fail_flag | exhaustive_case+              = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- match_results]+              | otherwise+              = CanFail++    mentioned_constructors = mkUniqSet $ map alt_pat alts+    un_mentioned_constructors+        = mkUniqSet data_cons `minusUniqSet` mentioned_constructors+    exhaustive_case = isEmptyUniqSet un_mentioned_constructors++--- Stuff for parallel arrays+--+--  * the following is to desugar cases over fake constructors for+--   parallel arrays, which are introduced by `tidy1' in the `PArrPat'+--   case+--+mkPArrCase :: DynFlags -> Id -> Type -> [CaseAlt DataCon] -> CoreExpr -> DsM CoreExpr+mkPArrCase dflags var ty sorted_alts fail = do+    lengthP <- dsDPHBuiltin lengthPVar+    alt <- unboxAlt+    return (mkWildCase (len lengthP) intTy ty [alt])+  where+    elemTy      = case splitTyConApp (idType var) of+        (_, [elemTy]) -> elemTy+        _             -> panic panicMsg+    panicMsg    = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"+    len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]+    --+    unboxAlt = do+        l      <- newSysLocalDs intPrimTy+        indexP <- dsDPHBuiltin indexPVar+        alts   <- mapM (mkAlt indexP) sorted_alts+        return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts))+      where+        dft  = (DEFAULT, [], fail)++    --+    -- each alternative matches one array length (corresponding to one+    -- fake array constructor), so the match is on a literal; each+    -- alternative's body is extended by a local binding for each+    -- constructor argument, which are bound to array elements starting+    -- with the first+    --+    mkAlt indexP alt@MkCaseAlt{alt_result = MatchResult _ bodyFun} = do+        body <- bodyFun fail+        return (LitAlt lit, [], mkCoreLets binds body)+      where+        lit   = MachInt $ toInteger (dataConSourceArity (alt_pat alt))+        binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] (alt_bndrs alt)]+        --+        indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr dflags i]++{-+************************************************************************+*                                                                      *+\subsection{Desugarer's versions of some Core functions}+*                                                                      *+************************************************************************+-}++mkErrorAppDs :: Id              -- The error function+             -> Type            -- Type to which it should be applied+             -> SDoc            -- The error message string to pass+             -> DsM CoreExpr++mkErrorAppDs err_id ty msg = do+    src_loc <- getSrcSpanDs+    dflags <- getDynFlags+    let+        full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])+        core_msg = Lit (mkMachString full_msg)+        -- mkMachString returns a result of type String#+    return (mkApps (Var err_id) [Type (getRuntimeRep "mkErrorAppDs" ty), Type ty, core_msg])++{-+'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'.++Note [Desugaring seq (1)]  cf Trac #1031+~~~~~~~~~~~~~~~~~~~~~~~~~+   f x y = x `seq` (y `seq` (# x,y #))++The [CoreSyn let/app invariant] means that, other things being equal, because+the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:++   f x y = case (y `seq` (# x,y #)) of v -> x `seq` v++But that is bad for two reasons:+  (a) we now evaluate y before x, and+  (b) we can't bind v to an unboxed pair++Seq is very, very special!  So we recognise it right here, and desugar to+        case x of _ -> case y of _ -> (# x,y #)++Note [Desugaring seq (2)]  cf Trac #2273+~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   let chp = case b of { True -> fst x; False -> 0 }+   in chp `seq` ...chp...+Here the seq is designed to plug the space leak of retaining (snd x)+for too long.++If we rely on the ordinary inlining of seq, we'll get+   let chp = case b of { True -> fst x; False -> 0 }+   case chp of _ { I# -> ...chp... }++But since chp is cheap, and the case is an alluring contet, we'll+inline chp into the case scrutinee.  Now there is only one use of chp,+so we'll inline a second copy.  Alas, we've now ruined the purpose of+the seq, by re-introducing the space leak:+    case (case b of {True -> fst x; False -> 0}) of+      I# _ -> ...case b of {True -> fst x; False -> 0}...++We can try to avoid doing this by ensuring that the binder-swap in the+case happens, so we get his at an early stage:+   case chp of chp2 { I# -> ...chp2... }+But this is fragile.  The real culprit is the source program.  Perhaps we+should have said explicitly+   let !chp2 = chp in ...chp2...++But that's painful.  So the code here does a little hack to make seq+more robust: a saturated application of 'seq' is turned *directly* into+the case expression, thus:+   x  `seq` e2 ==> case x of x -> e2    -- Note shadowing!+   e1 `seq` e2 ==> case x of _ -> e2++So we desugar our example to:+   let chp = case b of { True -> fst x; False -> 0 }+   case chp of chp { I# -> ...chp... }+And now all is well.++The reason it's a hack is because if you define mySeq=seq, the hack+won't work on mySeq.++Note [Desugaring seq (3)] cf Trac #2409+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The isLocalId ensures that we don't turn+        True `seq` e+into+        case True of True { ... }+which stupidly tries to bind the datacon 'True'.+-}++-- NB: Make sure the argument is not levity polymorphic+mkCoreAppDs  :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr+mkCoreAppDs _ (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2+  | f `hasKey` seqIdKey            -- Note [Desugaring seq (1), (2)]+  = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]+  where+    case_bndr = case arg1 of+                   Var v1 | isInternalName (idName v1)+                          -> v1        -- Note [Desugaring seq (2) and (3)]+                   _      -> mkWildValBinder ty1++mkCoreAppDs s fun arg = mkCoreApp s fun arg  -- The rest is done in MkCore++-- NB: No argument can be levity polymorphic+mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr+mkCoreAppsDs s fun args = foldl (mkCoreAppDs s) fun args++mkCastDs :: CoreExpr -> Coercion -> CoreExpr+-- We define a desugarer-specific version of CoreUtils.mkCast,+-- because in the immediate output of the desugarer, we can have+-- apparently-mis-matched coercions:  E.g.+--     let a = b+--     in (x :: a) |> (co :: b ~ Int)+-- Lint know about type-bindings for let and does not complain+-- So here we do not make the assertion checks that we make in+-- CoreUtils.mkCast; and we do less peephole optimisation too+mkCastDs e co | isReflCo co = e+              | otherwise   = Cast e co++{-+************************************************************************+*                                                                      *+               Tuples and selector bindings+*                                                                      *+************************************************************************++This is used in various places to do with lazy patterns.+For each binder $b$ in the pattern, we create a binding:+\begin{verbatim}+    b = case v of pat' -> b'+\end{verbatim}+where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.++ToDo: making these bindings should really depend on whether there's+much work to be done per binding.  If the pattern is complex, it+should be de-mangled once, into a tuple (and then selected from).+Otherwise the demangling can be in-line in the bindings (as here).++Boring!  Boring!  One error message per binder.  The above ToDo is+even more helpful.  Something very similar happens for pattern-bound+expressions.++Note [mkSelectorBinds]+~~~~~~~~~~~~~~~~~~~~~~+mkSelectorBinds is used to desugar a pattern binding {p = e},+in a binding group:+  let { ...; p = e; ... } in body+where p binds x,y (this list of binders can be empty).+There are two cases.++------ Special case (A) -------+  For a pattern that is just a variable,+     let !x = e in body+  ==>+     let x = e in x `seq` body+  So we return the binding, with 'x' as the variable to seq.++------ Special case (B) -------+  For a pattern that is essentially just a tuple:+      * A product type, so cannot fail+      * Only one level, so that+          - generating multiple matches is fine+          - seq'ing it evaluates the same as matching it+  Then instead we generate+       { v = e+       ; x = case v of p -> x+       ; y = case v of p -> y }+  with 'v' as the variable to force++------ General case (C) -------+  In the general case we generate these bindings:+       let { ...; p = e; ... } in body+  ==>+       let { t = case e of p -> (x,y)+           ; x = case t of (x,y) -> x+           ; y = case t of (x,y) -> y }+       in t `seq` body++  Note that we return 't' as the variable to force if the pattern+  is strict (i.e. with -XStrict or an outermost-bang-pattern)++  Note that (A) /includes/ the situation where++   * The pattern binds exactly one variable+        let !(Just (Just x) = e in body+     ==>+       let { t = case e of Just (Just v) -> Unit v+           ; v = case t of Unit v -> v }+       in t `seq` body+    The 'Unit' is a one-tuple; see Note [One-tuples] in TysWiredIn+    Note that forcing 't' makes the pattern match happen,+    but does not force 'v'.++  * The pattern binds no variables+        let !(True,False) = e in body+    ==>+        let t = case e of (True,False) -> ()+        in t `seq` body+++------ Examples ----------+  *   !(_, (_, a)) = e+    ==>+      t = case e of (_, (_, a)) -> Unit a+      a = case t of Unit a -> a++    Note that+     - Forcing 't' will force the pattern to match fully;+       e.g. will diverge if (snd e) is bottom+     - But 'a' itself is not forced; it is wrapped in a one-tuple+       (see Note [One-tuples] in TysWiredIn)++  *   !(Just x) = e+    ==>+      t = case e of Just x -> Unit x+      x = case t of Unit x -> x++    Again, forcing 't' will fail if 'e' yields Nothing.++Note that even though this is rather general, the special cases+work out well:++* One binder, not -XStrict:++    let Just (Just v) = e in body+  ==>+    let t = case e of Just (Just v) -> Unit v+        v = case t of Unit v -> v+    in body+  ==>+    let v = case (case e of Just (Just v) -> Unit v) of+              Unit v -> v+    in body+  ==>+    let v = case e of Just (Just v) -> v+    in body++* Non-recursive, -XStrict+     let p = e in body+  ==>+     let { t = case e of p -> (x,y)+         ; x = case t of (x,y) -> x+         ; y = case t of (x,y) -> x }+     in t `seq` body+  ==> {inline seq, float x,y bindings inwards}+     let t = case e of p -> (x,y) in+     case t of t' ->+     let { x = case t' of (x,y) -> x+         ; y = case t' of (x,y) -> x } in+     body+  ==> {inline t, do case of case}+     case e of p ->+     let t = (x,y) in+     let { x = case t' of (x,y) -> x+         ; y = case t' of (x,y) -> x } in+     body+  ==> {case-cancellation, drop dead code}+     case e of p -> body++* Special case (B) is there to avoid fruitlessly taking the tuple+  apart and rebuilding it. For example, consider+     { K x y = e }+  where K is a product constructor.  Then general case (A) does:+     { t = case e of K x y -> (x,y)+     ; x = case t of (x,y) -> x+     ; y = case t of (x,y) -> y }+  In the lazy case we can't optimise out this fruitless taking apart+  and rebuilding.  Instead (B) builds+     { v = e+     ; x = case v of K x y -> x+     ; y = case v of K x y -> y }+  which is better.+-}++mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly+                -> LPat Id        -- ^ The pattern+                -> CoreExpr       -- ^ Expression to which the pattern is bound+                -> DsM (Id,[(Id,CoreExpr)])+                -- ^ Id the rhs is bound to, for desugaring strict+                -- binds (see Note [Desugar Strict binds] in DsBinds)+                -- and all the desugared binds++mkSelectorBinds ticks pat val_expr+  | L _ (VarPat (L _ v)) <- pat'     -- Special case (A)+  = return (v, [(v, val_expr)])++  | is_flat_prod_lpat pat'           -- Special case (B)+  = do { let pat_ty = hsLPatType pat'+       ; val_var <- newSysLocalDsNoLP pat_ty++       ; let mk_bind tick bndr_var+               -- (mk_bind sv bv)  generates  bv = case sv of { pat -> bv }+               -- Remember, 'pat' binds 'bv'+               = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat'+                                       (Var bndr_var)+                                       (Var bndr_var)  -- Neat hack+                      -- Neat hack: since 'pat' can't fail, the+                      -- "fail-expr" passed to matchSimply is not+                      -- used. But it /is/ used for its type, and for+                      -- that bndr_var is just the ticket.+                    ; return (bndr_var, mkOptTickBox tick rhs_expr) }++       ; binds <- zipWithM mk_bind ticks' binders+       ; return ( val_var, (val_var, val_expr) : binds) }++  | otherwise                          -- General case (C)+  = do { tuple_var  <- newSysLocalDs tuple_ty+       ; error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (ppr pat')+       ; tuple_expr <- matchSimply val_expr PatBindRhs pat+                                   local_tuple error_expr+       ; let mk_tup_bind tick binder+               = (binder, mkOptTickBox tick $+                          mkTupleSelector1 local_binders binder+                                           tuple_var (Var tuple_var))+             tup_binds = zipWith mk_tup_bind ticks' binders+       ; return (tuple_var, (tuple_var, tuple_expr) : tup_binds) }+  where+    pat' = strip_bangs pat+           -- Strip the bangs before looking for case (A) or (B)+           -- The incoming pattern may well have a bang on it++    binders = collectPatBinders pat'+    ticks'  = ticks ++ repeat []++    local_binders = map localiseId binders      -- See Note [Localise pattern binders]+    local_tuple   = mkBigCoreVarTup1 binders+    tuple_ty      = exprType local_tuple++strip_bangs :: LPat a -> LPat a+-- Remove outermost bangs and parens+strip_bangs (L _ (ParPat p))  = strip_bangs p+strip_bangs (L _ (BangPat p)) = strip_bangs p+strip_bangs lp                = lp++is_flat_prod_lpat :: LPat a -> Bool+is_flat_prod_lpat p = is_flat_prod_pat (unLoc p)++is_flat_prod_pat :: Pat a -> Bool+is_flat_prod_pat (ParPat p)            = is_flat_prod_lpat p+is_flat_prod_pat (TuplePat ps Boxed _) = all is_triv_lpat ps+is_flat_prod_pat (ConPatOut { pat_con = L _ pcon, pat_args = ps})+  | RealDataCon con <- pcon+  , isProductTyCon (dataConTyCon con)+  = all is_triv_lpat (hsConPatArgs ps)+is_flat_prod_pat _ = False++is_triv_lpat :: LPat a -> Bool+is_triv_lpat p = is_triv_pat (unLoc p)++is_triv_pat :: Pat a -> Bool+is_triv_pat (VarPat _)  = True+is_triv_pat (WildPat _) = True+is_triv_pat (ParPat p)  = is_triv_lpat p+is_triv_pat _           = False+++{- *********************************************************************+*                                                                      *+  Creating big tuples and their types for full Haskell expressions.+  They work over *Ids*, and create tuples replete with their types,+  which is whey they are not in HsUtils.+*                                                                      *+********************************************************************* -}++mkLHsPatTup :: [LPat Id] -> LPat Id+mkLHsPatTup []     = noLoc $ mkVanillaTuplePat [] Boxed+mkLHsPatTup [lpat] = lpat+mkLHsPatTup lpats  = L (getLoc (head lpats)) $+                     mkVanillaTuplePat lpats Boxed++mkLHsVarPatTup :: [Id] -> LPat Id+mkLHsVarPatTup bs  = mkLHsPatTup (map nlVarPat bs)++mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id+-- A vanilla tuple pattern simply gets its type from its sub-patterns+mkVanillaTuplePat pats box = TuplePat pats box (map hsLPatType pats)++-- The Big equivalents for the source tuple expressions+mkBigLHsVarTupId :: [Id] -> LHsExpr Id+mkBigLHsVarTupId ids = mkBigLHsTupId (map nlHsVar ids)++mkBigLHsTupId :: [LHsExpr Id] -> LHsExpr Id+mkBigLHsTupId = mkChunkified mkLHsTupleExpr++-- The Big equivalents for the source tuple patterns+mkBigLHsVarPatTupId :: [Id] -> LPat Id+mkBigLHsVarPatTupId bs = mkBigLHsPatTupId (map nlVarPat bs)++mkBigLHsPatTupId :: [LPat Id] -> LPat Id+mkBigLHsPatTupId = mkChunkified mkLHsPatTup++{-+************************************************************************+*                                                                      *+        Code for pattern-matching and other failures+*                                                                      *+************************************************************************++Generally, we handle pattern matching failure like this: let-bind a+fail-variable, and use that variable if the thing fails:+\begin{verbatim}+        let fail.33 = error "Help"+        in+        case x of+                p1 -> ...+                p2 -> fail.33+                p3 -> fail.33+                p4 -> ...+\end{verbatim}+Then+\begin{itemize}+\item+If the case can't fail, then there'll be no mention of @fail.33@, and the+simplifier will later discard it.++\item+If it can fail in only one way, then the simplifier will inline it.++\item+Only if it is used more than once will the let-binding remain.+\end{itemize}++There's a problem when the result of the case expression is of+unboxed type.  Then the type of @fail.33@ is unboxed too, and+there is every chance that someone will change the let into a case:+\begin{verbatim}+        case error "Help" of+          fail.33 -> case ....+\end{verbatim}++which is of course utterly wrong.  Rather than drop the condition that+only boxed types can be let-bound, we just turn the fail into a function+for the primitive case:+\begin{verbatim}+        let fail.33 :: Void -> Int#+            fail.33 = \_ -> error "Help"+        in+        case x of+                p1 -> ...+                p2 -> fail.33 void+                p3 -> fail.33 void+                p4 -> ...+\end{verbatim}++Now @fail.33@ is a function, so it can be let-bound.++We would *like* to use join points here; in fact, these "fail variables" are+paradigmatic join points! Sadly, this breaks pattern synonyms, which desugar as+CPS functions - i.e. they take "join points" as parameters. It's not impossible+to imagine extending our type system to allow passing join points around (very+carefully), but we certainly don't support it now.++99.99% of the time, the fail variables wind up as join points in short order+anyway, and the Void# doesn't do much harm.+-}++mkFailurePair :: CoreExpr       -- Result type of the whole case expression+              -> DsM (CoreBind, -- Binds the newly-created fail variable+                                -- to \ _ -> expression+                      CoreExpr) -- Fail variable applied to realWorld#+-- See Note [Failure thunks and CPR]+mkFailurePair expr+  = do { fail_fun_var <- newFailLocalDs (voidPrimTy `mkFunTy` ty)+       ; fail_fun_arg <- newSysLocalDs voidPrimTy+       ; let real_arg = setOneShotLambda fail_fun_arg+       ; return (NonRec fail_fun_var (Lam real_arg expr),+                 App (Var fail_fun_var) (Var voidPrimId)) }+  where+    ty = exprType expr++{-+Note [Failure thunks and CPR]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(This note predates join points as formal entities (hence the quotation marks).+We can't use actual join points here (see above); if we did, this would also+solve the CPR problem, since join points don't get CPR'd. See Note [Don't CPR+join points] in WorkWrap.)++When we make a failure point we ensure that it+does not look like a thunk. Example:++   let fail = \rw -> error "urk"+   in case x of+        [] -> fail realWorld#+        (y:ys) -> case ys of+                    [] -> fail realWorld#+                    (z:zs) -> (y,z)++Reason: we know that a failure point is always a "join point" and is+entered at most once.  Adding a dummy 'realWorld' token argument makes+it clear that sharing is not an issue.  And that in turn makes it more+CPR-friendly.  This matters a lot: if you don't get it right, you lose+the tail call property.  For example, see Trac #3403.+++************************************************************************+*                                                                      *+              Ticks+*                                                                      *+********************************************************************* -}++mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr+mkOptTickBox = flip (foldr Tick)++mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr+mkBinaryTickBox ixT ixF e = do+       uq <- newUnique+       this_mod <- getModule+       let bndr1 = mkSysLocal (fsLit "t1") uq boolTy+       let+           falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId)+           trueBox  = Tick (HpcTick this_mod ixT) (Var trueDataConId)+       --+       return $ Case e bndr1 boolTy+                       [ (DataAlt falseDataCon, [], falseBox)+                       , (DataAlt trueDataCon,  [], trueBox)+                       ]++++-- *******************************************************************++-- | Use -XStrict to add a ! or remove a ~+--+-- Examples:+-- ~pat    => pat    -- when -XStrict (even if pat = ~pat')+-- !pat    => !pat   -- always+-- pat     => !pat   -- when -XStrict+-- pat     => pat    -- otherwise+decideBangHood :: DynFlags+               -> LPat id  -- ^ Original pattern+               -> LPat id  -- Pattern with bang if necessary+decideBangHood dflags lpat+  | not (xopt LangExt.Strict dflags)+  = lpat+  | otherwise   --  -XStrict+  = go lpat+  where+    go lp@(L l p)+      = case p of+           ParPat p    -> L l (ParPat (go p))+           LazyPat lp' -> lp'+           BangPat _   -> lp+           _           -> L l (BangPat lp)++-- | Unconditionally make a 'Pat' strict.+addBang :: LPat id -- ^ Original pattern+        -> LPat id -- ^ Banged pattern+addBang = go+  where+    go lp@(L l p)+      = case p of+           ParPat p    -> L l (ParPat (go p))+           LazyPat lp' -> L l (BangPat lp')+           BangPat _   -> lp+           _           -> L l (BangPat lp)
+ deSugar/Match.hs view
@@ -0,0 +1,1135 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++The @match@ function+-}++{-# LANGUAGE CPP #-}++module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where++#include "HsVersions.h"++import {-#SOURCE#-} DsExpr (dsLExpr, dsSyntaxExpr)++import DynFlags+import HsSyn+import TcHsSyn+import TcEvidence+import TcRnMonad+import Check+import CoreSyn+import Literal+import CoreUtils+import MkCore+import DsMonad+import DsBinds+import DsGRHSs+import DsUtils+import Id+import ConLike+import DataCon+import PatSyn+import MatchCon+import MatchLit+import Type+import Coercion ( eqCoercion )+import TcType ( toTcTypeBag )+import TyCon( isNewTyCon )+import TysWiredIn+import ListSetOps+import SrcLoc+import Maybes+import Util+import Name+import Outputable+import BasicTypes ( isGenerated, fl_value )+import FastString+import Unique+import UniqDFM++import Control.Monad( when, unless )+import qualified Data.Map as Map++{-+************************************************************************+*                                                                      *+                The main matching function+*                                                                      *+************************************************************************++The function @match@ is basically the same as in the Wadler chapter,+except it is monadised, to carry around the name supply, info about+annotations, etc.++Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns:+\begin{enumerate}+\item+A list of $n$ variable names, those variables presumably bound to the+$n$ expressions being matched against the $n$ patterns.  Using the+list of $n$ expressions as the first argument showed no benefit and+some inelegance.++\item+The second argument, a list giving the ``equation info'' for each of+the $m$ equations:+\begin{itemize}+\item+the $n$ patterns for that equation, and+\item+a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on+the front'' of the matching code, as in:+\begin{verbatim}+let <binds>+in  <matching-code>+\end{verbatim}+\item+and finally: (ToDo: fill in)++The right way to think about the ``after-match function'' is that it+is an embryonic @CoreExpr@ with a ``hole'' at the end for the+final ``else expression''.+\end{itemize}++There is a data type, @EquationInfo@, defined in module @DsMonad@.++An experiment with re-ordering this information about equations (in+particular, having the patterns available in column-major order)+showed no benefit.++\item+A default expression---what to evaluate if the overall pattern-match+fails.  This expression will (almost?) always be+a measly expression @Var@, unless we know it will only be used once+(as we do in @glue_success_exprs@).++Leaving out this third argument to @match@ (and slamming in lots of+@Var "fail"@s) is a positively {\em bad} idea, because it makes it+impossible to share the default expressions.  (Also, it stands no+chance of working in our post-upheaval world of @Locals@.)+\end{enumerate}++Note: @match@ is often called via @matchWrapper@ (end of this module),+a function that does much of the house-keeping that goes with a call+to @match@.++It is also worth mentioning the {\em typical} way a block of equations+is desugared with @match@.  At each stage, it is the first column of+patterns that is examined.  The steps carried out are roughly:+\begin{enumerate}+\item+Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add+bindings to the second component of the equation-info):+\begin{itemize}+\item+Remove the `as' patterns from column~1.+\item+Make all constructor patterns in column~1 into @ConPats@, notably+@ListPats@ and @TuplePats@.+\item+Handle any irrefutable (or ``twiddle'') @LazyPats@.+\end{itemize}+\item+Now {\em unmix} the equations into {\em blocks} [w\/ local function+@unmix_eqns@], in which the equations in a block all have variable+patterns in column~1, or they all have constructor patterns in ...+(see ``the mixture rule'' in SLPJ).+\item+Call @matchEqnBlock@ on each block of equations; it will do the+appropriate thing for each kind of column-1 pattern, usually ending up+in a recursive call to @match@.+\end{enumerate}++We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)+than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).+And gluing the ``success expressions'' together isn't quite so pretty.++This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@+(a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and+(b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em+un}mixes the equations], producing a list of equation-info+blocks, each block having as its first column of patterns either all+constructors, or all variables (or similar beasts), etc.++@match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the+Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@+corresponds roughly to @matchVarCon@.++Note [Match Ids]+~~~~~~~~~~~~~~~~+Most of the matching fuctions take an Id or [Id] as argument.  This Id+is the scrutinee(s) of the match. The desugared expression may+sometimes use that Id in a local binding or as a case binder.  So it+should not have an External name; Lint rejects non-top-level binders+with External names (Trac #13043).+-}++type MatchId = Id   -- See Note [Match Ids]++match :: [MatchId]        -- Variables rep\'ing the exprs we\'re matching with+                          -- See Note [Match Ids]+      -> Type             -- Type of the case expression+      -> [EquationInfo]   -- Info about patterns, etc. (type synonym below)+      -> DsM MatchResult  -- Desugared result!++match [] ty eqns+  = ASSERT2( not (null eqns), ppr ty )+    return (foldr1 combineMatchResults match_results)+  where+    match_results = [ ASSERT( null (eqn_pats eqn) )+                      eqn_rhs eqn+                    | eqn <- eqns ]++match vars@(v:_) ty eqns    -- Eqns *can* be empty+  = ASSERT2( all (isInternalName . idName) vars, ppr vars )+    do  { dflags <- getDynFlags+                -- Tidy the first pattern, generating+                -- auxiliary bindings if necessary+        ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns++                -- Group the equations and match each group in turn+        ; let grouped = groupEquations dflags tidy_eqns++         -- print the view patterns that are commoned up to help debug+        ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped)++        ; match_results <- match_groups grouped+        ; return (adjustMatchResult (foldr (.) id aux_binds) $+                  foldr1 combineMatchResults match_results) }+  where+    dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo]+    dropGroup = map snd++    match_groups :: [[(PatGroup,EquationInfo)]] -> DsM [MatchResult]+    -- Result list of [MatchResult] is always non-empty+    match_groups [] = matchEmpty v ty+    match_groups gs = mapM match_group gs++    match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult+    match_group [] = panic "match_group"+    match_group eqns@((group,_) : _)+        = case group of+            PgCon {}  -> matchConFamily  vars ty (subGroupUniq [(c,e) | (PgCon c, e) <- eqns])+            PgSyn {}  -> matchPatSyn     vars ty (dropGroup eqns)+            PgLit {}  -> matchLiterals   vars ty (subGroupOrd [(l,e) | (PgLit l, e) <- eqns])+            PgAny     -> matchVariables  vars ty (dropGroup eqns)+            PgN {}    -> matchNPats      vars ty (dropGroup eqns)+            PgOverS {}-> matchNPats      vars ty (dropGroup eqns)+            PgNpK {}  -> matchNPlusKPats vars ty (dropGroup eqns)+            PgBang    -> matchBangs      vars ty (dropGroup eqns)+            PgCo {}   -> matchCoercion   vars ty (dropGroup eqns)+            PgView {} -> matchView       vars ty (dropGroup eqns)+            PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns)++    -- FIXME: we should also warn about view patterns that should be+    -- commoned up but are not++    -- print some stuff to see what's getting grouped+    -- use -dppr-debug to see the resolution of overloaded literals+    debug eqns =+        let gs = map (\group -> foldr (\ (p,_) -> \acc ->+                                           case p of PgView e _ -> e:acc+                                                     _ -> acc) [] group) eqns+            maybeWarn [] = return ()+            maybeWarn l = warnDs NoReason (vcat l)+        in+          maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))+                       (filter (not . null) gs))++matchEmpty :: MatchId -> Type -> DsM [MatchResult]+-- See Note [Empty case expressions]+matchEmpty var res_ty+  = return [MatchResult CanFail mk_seq]+  where+    mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty+                                      [(DEFAULT, [], fail)]++matchVariables :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult+-- Real true variables, just like in matchVar, SLPJ p 94+-- No binding to do: they'll all be wildcards by now (done in tidy)+matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns)+matchVariables [] _ _ = panic "matchVariables"++matchBangs :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult+matchBangs (var:vars) ty eqns+  = do  { match_result <- match (var:vars) ty $+                          map (decomposeFirstPat getBangPat) eqns+        ; return (mkEvalMatchResult var ty match_result) }+matchBangs [] _ _ = panic "matchBangs"++matchCoercion :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult+-- Apply the coercion to the match variable and then match that+matchCoercion (var:vars) ty (eqns@(eqn1:_))+  = do  { let CoPat co pat _ = firstPat eqn1+        ; let pat_ty' = hsPatType pat+        ; var' <- newUniqueId var pat_ty'+        ; match_result <- match (var':vars) ty $+                          map (decomposeFirstPat getCoPat) eqns+        ; core_wrap <- dsHsWrapper co+        ; let bind = NonRec var' (core_wrap (Var var))+        ; return (mkCoLetMatchResult bind match_result) }+matchCoercion _ _ _ = panic "matchCoercion"++matchView :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult+-- Apply the view function to the match variable and then match that+matchView (var:vars) ty (eqns@(eqn1:_))+  = do  { -- we could pass in the expr from the PgView,+         -- but this needs to extract the pat anyway+         -- to figure out the type of the fresh variable+         let ViewPat viewExpr (L _ pat) _ = firstPat eqn1+         -- do the rest of the compilation+        ; let pat_ty' = hsPatType pat+        ; var' <- newUniqueId var pat_ty'+        ; match_result <- match (var':vars) ty $+                          map (decomposeFirstPat getViewPat) eqns+         -- compile the view expressions+        ; viewExpr' <- dsLExpr viewExpr+        ; return (mkViewMatchResult var'+                    (mkCoreAppDs (text "matchView") viewExpr' (Var var))+                    match_result) }+matchView _ _ _ = panic "matchView"++matchOverloadedList :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult+matchOverloadedList (var:vars) ty (eqns@(eqn1:_))+-- Since overloaded list patterns are treated as view patterns,+-- the code is roughly the same as for matchView+  = do { let ListPat _ elt_ty (Just (_,e)) = firstPat eqn1+       ; var' <- newUniqueId var (mkListTy elt_ty)  -- we construct the overall type by hand+       ; match_result <- match (var':vars) ty $+                            map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern+       ; e' <- dsSyntaxExpr e [Var var]+       ; return (mkViewMatchResult var' e' match_result) }+matchOverloadedList _ _ _ = panic "matchOverloadedList"++-- decompose the first pattern and leave the rest alone+decomposeFirstPat :: (Pat Id -> Pat Id) -> EquationInfo -> EquationInfo+decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))+        = eqn { eqn_pats = extractpat pat : pats}+decomposeFirstPat _ _ = panic "decomposeFirstPat"++getCoPat, getBangPat, getViewPat, getOLPat :: Pat Id -> Pat Id+getCoPat (CoPat _ pat _)     = pat+getCoPat _                   = panic "getCoPat"+getBangPat (BangPat pat  )   = unLoc pat+getBangPat _                 = panic "getBangPat"+getViewPat (ViewPat _ pat _) = unLoc pat+getViewPat _                 = panic "getViewPat"+getOLPat (ListPat pats ty (Just _)) = ListPat pats ty Nothing+getOLPat _                   = panic "getOLPat"++{-+Note [Empty case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The list of EquationInfo can be empty, arising from+    case x of {}   or    \case {}+In that situation we desugar to+    case x of { _ -> error "pattern match failure" }+The *desugarer* isn't certain whether there really should be no+alternatives, so it adds a default case, as it always does.  A later+pass may remove it if it's inaccessible.  (See also Note [Empty case+alternatives] in CoreSyn.)++We do *not* desugar simply to+   error "empty case"+or some such, because 'x' might be bound to (error "hello"), in which+case we want to see that "hello" exception, not (error "empty case").+See also Note [Case elimination: lifted case] in Simplify.+++************************************************************************+*                                                                      *+                Tidying patterns+*                                                                      *+************************************************************************++Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@+which will be scrutinised.  This means:+\begin{itemize}+\item+Replace variable patterns @x@ (@x /= v@) with the pattern @_@,+together with the binding @x = v@.+\item+Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@.+\item+Removing lazy (irrefutable) patterns (you don't want to know...).+\item+Converting explicit tuple-, list-, and parallel-array-pats into ordinary+@ConPats@.+\item+Convert the literal pat "" to [].+\end{itemize}++The result of this tidying is that the column of patterns will include+{\em only}:+\begin{description}+\item[@WildPats@:]+The @VarPat@ information isn't needed any more after this.++\item[@ConPats@:]+@ListPats@, @TuplePats@, etc., are all converted into @ConPats@.++\item[@LitPats@ and @NPats@:]+@LitPats@/@NPats@ of ``known friendly types'' (Int, Char,+Float,  Double, at least) are converted to unboxed form; e.g.,+\tr{(NPat (HsInt i) _ _)} is converted to:+\begin{verbatim}+(ConPat I# _ _ [LitPat (HsIntPrim i)])+\end{verbatim}+\end{description}+-}++tidyEqnInfo :: Id -> EquationInfo+            -> DsM (DsWrapper, EquationInfo)+        -- DsM'd because of internal call to dsLHsBinds+        --      and mkSelectorBinds.+        -- "tidy1" does the interesting stuff, looking at+        -- one pattern and fiddling the list of bindings.+        --+        -- POST CONDITION: head pattern in the EqnInfo is+        --      WildPat+        --      ConPat+        --      NPat+        --      LitPat+        --      NPlusKPat+        -- but no other++tidyEqnInfo _ (EqnInfo { eqn_pats = [] })+  = panic "tidyEqnInfo"++tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats })+  = do { (wrap, pat') <- tidy1 v pat+       ; return (wrap, eqn { eqn_pats = do pat' : pats }) }++tidy1 :: Id               -- The Id being scrutinised+      -> Pat Id           -- The pattern against which it is to be matched+      -> DsM (DsWrapper,  -- Extra bindings to do before the match+              Pat Id)     -- Equivalent pattern++-------------------------------------------------------+--      (pat', mr') = tidy1 v pat mr+-- tidies the *outer level only* of pat, giving pat'+-- It eliminates many pattern forms (as-patterns, variable patterns,+-- list patterns, etc) yielding one of:+--      WildPat+--      ConPatOut+--      LitPat+--      NPat+--      NPlusKPat++tidy1 v (ParPat pat)      = tidy1 v (unLoc pat)+tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat)+tidy1 _ (WildPat ty)      = return (idDsWrapper, WildPat ty)+tidy1 v (BangPat (L l p)) = tidy_bang_pat v l p++        -- case v of { x -> mr[] }+        -- = case v of { _ -> let x=v in mr[] }+tidy1 v (VarPat (L _ var))+  = return (wrapBind var v, WildPat (idType var))++        -- case v of { x@p -> mr[] }+        -- = case v of { p -> let x=v in mr[] }+tidy1 v (AsPat (L _ var) pat)+  = do  { (wrap, pat') <- tidy1 v (unLoc pat)+        ; return (wrapBind var v . wrap, pat') }++{- now, here we handle lazy patterns:+    tidy1 v ~p bs = (v, v1 = case v of p -> v1 :+                        v2 = case v of p -> v2 : ... : bs )++    where the v_i's are the binders in the pattern.++    ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?++    The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr+-}++tidy1 v (LazyPat pat)+    -- This is a convenient place to check for unlifted types under a lazy pattern.+    -- Doing this check during type-checking is unsatisfactory because we may+    -- not fully know the zonked types yet. We sure do here.+  = do  { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders pat)+        ; unless (null unlifted_bndrs) $+          putSrcSpanDs (getLoc pat) $+          errDs (hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$+                       text "Unlifted variables:")+                    2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id))+                                 unlifted_bndrs)))++        ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v)+        ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]+        ; return (mkCoreLets sel_binds, WildPat (idType v)) }++tidy1 _ (ListPat pats ty Nothing)+  = return (idDsWrapper, unLoc list_ConPat)+  where+    list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])+                        (mkNilPat ty)+                        pats++-- Introduce fake parallel array constructors to be able to handle parallel+-- arrays with the existing machinery for constructor pattern+tidy1 _ (PArrPat pats ty)+  = return (idDsWrapper, unLoc parrConPat)+  where+    arity      = length pats+    parrConPat = mkPrefixConPat (parrFakeCon arity) pats [ty]++tidy1 _ (TuplePat pats boxity tys)+  = return (idDsWrapper, unLoc tuple_ConPat)+  where+    arity = length pats+    tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys++tidy1 _ (SumPat pat alt arity tys)+  = return (idDsWrapper, unLoc sum_ConPat)+  where+    sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] tys++-- LitPats: we *might* be able to replace these w/ a simpler form+tidy1 _ (LitPat lit)+  = return (idDsWrapper, tidyLitPat lit)++-- NPats: we *might* be able to replace these w/ a simpler form+tidy1 _ (NPat (L _ lit) mb_neg eq ty)+  = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq ty)++-- Everything else goes through unchanged...++tidy1 _ non_interesting_pat+  = return (idDsWrapper, non_interesting_pat)++--------------------+tidy_bang_pat :: Id -> SrcSpan -> Pat Id -> DsM (DsWrapper, Pat Id)++-- Discard par/sig under a bang+tidy_bang_pat v _ (ParPat (L l p))      = tidy_bang_pat v l p+tidy_bang_pat v _ (SigPatOut (L l p) _) = tidy_bang_pat v l p++-- Push the bang-pattern inwards, in the hope that+-- it may disappear next time+tidy_bang_pat v l (AsPat v' p)  = tidy1 v (AsPat v' (L l (BangPat p)))+tidy_bang_pat v l (CoPat w p t) = tidy1 v (CoPat w (BangPat (L l p)) t)++-- Discard bang around strict pattern+tidy_bang_pat v _ p@(LitPat {})    = tidy1 v p+tidy_bang_pat v _ p@(ListPat {})   = tidy1 v p+tidy_bang_pat v _ p@(TuplePat {})  = tidy1 v p+tidy_bang_pat v _ p@(SumPat {})    = tidy1 v p+tidy_bang_pat v _ p@(PArrPat {})   = tidy1 v p++-- Data/newtype constructors+tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc)+                               , pat_args = args+                               , pat_arg_tys = arg_tys })+  -- Newtypes: push bang inwards (Trac #9844)+  =+    if isNewTyCon (dataConTyCon dc)+      then tidy1 v (p { pat_args = push_bang_into_newtype_arg l ty args })+      else tidy1 v p  -- Data types: discard the bang+    where+      (ty:_) = dataConInstArgTys dc arg_tys++-------------------+-- Default case, leave the bang there:+--    VarPat,+--    LazyPat,+--    WildPat,+--    ViewPat,+--    pattern synonyms (ConPatOut with PatSynCon)+--    NPat,+--    NPlusKPat+--+-- For LazyPat, remember that it's semantically like a VarPat+--  i.e.  !(~p) is not like ~p, or p!  (Trac #8952)+--+-- NB: SigPatIn, ConPatIn should not happen++tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p))++-------------------+push_bang_into_newtype_arg :: SrcSpan+                           -> Type -- The type of the argument we are pushing+                                   -- onto+                           -> HsConPatDetails Id -> HsConPatDetails Id+-- See Note [Bang patterns and newtypes]+-- We are transforming   !(N p)   into   (N !p)+push_bang_into_newtype_arg l _ty (PrefixCon (arg:args))+  = ASSERT( null args)+    PrefixCon [L l (BangPat arg)]+push_bang_into_newtype_arg l _ty (RecCon rf)+  | HsRecFields { rec_flds = L lf fld : flds } <- rf+  , HsRecField { hsRecFieldArg = arg } <- fld+  = ASSERT( null flds)+    RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg = L l (BangPat arg) })] })+push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})+  | HsRecFields { rec_flds = [] } <- rf+  = PrefixCon [L l (BangPat (noLoc (WildPat ty)))]+push_bang_into_newtype_arg _ _ cd+  = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)++{-+Note [Bang patterns and newtypes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For the pattern  !(Just pat)  we can discard the bang, because+the pattern is strict anyway. But for !(N pat), where+  newtype NT = N Int+we definitely can't discard the bang.  Trac #9844.++So what we do is to push the bang inwards, in the hope that it will+get discarded there.  So we transform+   !(N pat)   into    (N !pat)++But what if there is nothing to push the bang onto? In at least one instance+a user has written !(N {}) which we translate into (N !_). See #13215+++\noindent+{\bf Previous @matchTwiddled@ stuff:}++Now we get to the only interesting part; note: there are choices for+translation [from Simon's notes]; translation~1:+\begin{verbatim}+deTwiddle [s,t] e+\end{verbatim}+returns+\begin{verbatim}+[ w = e,+  s = case w of [s,t] -> s+  t = case w of [s,t] -> t+]+\end{verbatim}++Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple+evaluation of \tr{e}.  An alternative translation (No.~2):+\begin{verbatim}+[ w = case e of [s,t] -> (s,t)+  s = case w of (s,t) -> s+  t = case w of (s,t) -> t+]+\end{verbatim}++************************************************************************+*                                                                      *+\subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}+*                                                                      *+************************************************************************++We might be able to optimise unmixing when confronted by+only-one-constructor-possible, of which tuples are the most notable+examples.  Consider:+\begin{verbatim}+f (a,b,c) ... = ...+f d ... (e:f) = ...+f (g,h,i) ... = ...+f j ...       = ...+\end{verbatim}+This definition would normally be unmixed into four equation blocks,+one per equation.  But it could be unmixed into just one equation+block, because if the one equation matches (on the first column),+the others certainly will.++You have to be careful, though; the example+\begin{verbatim}+f j ...       = ...+-------------------+f (a,b,c) ... = ...+f d ... (e:f) = ...+f (g,h,i) ... = ...+\end{verbatim}+{\em must} be broken into two blocks at the line shown; otherwise, you+are forcing unnecessary evaluation.  In any case, the top-left pattern+always gives the cue.  You could then unmix blocks into groups of...+\begin{description}+\item[all variables:]+As it is now.+\item[constructors or variables (mixed):]+Need to make sure the right names get bound for the variable patterns.+\item[literals or variables (mixed):]+Presumably just a variant on the constructor case (as it is now).+\end{description}++************************************************************************+*                                                                      *+*  matchWrapper: a convenient way to call @match@                      *+*                                                                      *+************************************************************************+\subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@}++Calls to @match@ often involve similar (non-trivial) work; that work+is collected here, in @matchWrapper@.  This function takes as+arguments:+\begin{itemize}+\item+Typchecked @Matches@ (of a function definition, or a case or lambda+expression)---the main input;+\item+An error message to be inserted into any (runtime) pattern-matching+failure messages.+\end{itemize}++As results, @matchWrapper@ produces:+\begin{itemize}+\item+A list of variables (@Locals@) that the caller must ``promise'' to+bind to appropriate values; and+\item+a @CoreExpr@, the desugared output (main result).+\end{itemize}++The main actions of @matchWrapper@ include:+\begin{enumerate}+\item+Flatten the @[TypecheckedMatch]@ into a suitable list of+@EquationInfo@s.+\item+Create as many new variables as there are patterns in a pattern-list+(in any one of the @EquationInfo@s).+\item+Create a suitable ``if it fails'' expression---a call to @error@ using+the error-string input; the {\em type} of this fail value can be found+by examining one of the RHS expressions in one of the @EquationInfo@s.+\item+Call @match@ with all of this information!+\end{enumerate}+-}++matchWrapper :: HsMatchContext Name         -- For shadowing warning messages+             -> Maybe (LHsExpr Id)          -- The scrutinee, if we check a case expr+             -> MatchGroup Id (LHsExpr Id)  -- Matches being desugared+             -> DsM ([Id], CoreExpr)        -- Results++{-+ There is one small problem with the Lambda Patterns, when somebody+ writes something similar to:+\begin{verbatim}+    (\ (x:xs) -> ...)+\end{verbatim}+ he/she don't want a warning about incomplete patterns, that is done with+ the flag @opt_WarnSimplePatterns@.+ This problem also appears in the:+\begin{itemize}+\item @do@ patterns, but if the @do@ can fail+      it creates another equation if the match can fail+      (see @DsExpr.doDo@ function)+\item @let@ patterns, are treated by @matchSimply@+   List Comprension Patterns, are treated by @matchSimply@ also+\end{itemize}++We can't call @matchSimply@ with Lambda patterns,+due to the fact that lambda patterns can have more than+one pattern, and match simply only accepts one pattern.++JJQC 30-Nov-1997+-}++matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches+                             , mg_arg_tys = arg_tys+                             , mg_res_ty = rhs_ty+                             , mg_origin = origin })+  = do  { dflags <- getDynFlags+        ; locn   <- getSrcSpanDs++        ; new_vars    <- case matches of+                           []    -> mapM newSysLocalDsNoLP arg_tys+                           (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m))++        ; eqns_info   <- mapM (mk_eqn_info new_vars) matches++        -- pattern match check warnings+        ; unless (isGenerated origin) $+          when (isAnyPmCheckEnabled dflags (DsMatchContext ctxt locn)) $+          addTmCsDs (genCaseTmCs1 mb_scr new_vars) $+              -- See Note [Type and Term Equality Propagation]+          checkMatches dflags (DsMatchContext ctxt locn) new_vars matches++        ; result_expr <- handleWarnings $+                         matchEquations ctxt new_vars eqns_info rhs_ty+        ; return (new_vars, result_expr) }+  where+    mk_eqn_info vars (L _ (Match ctx pats _ grhss))+      = do { dflags <- getDynFlags+           ; let add_bang+                   | FunRhs {mc_strictness=SrcStrict} <- ctx+                   = pprTrace "addBang" empty addBang+                   | otherwise+                   = decideBangHood dflags+                 upats = map (unLoc . add_bang) pats+                 dicts = toTcTypeBag (collectEvVarsPats upats) -- Only TcTyVars+           ; tm_cs <- genCaseTmCs2 mb_scr upats vars+           ; match_result <- addDictsDs dicts $ -- See Note [Type and Term Equality Propagation]+                             addTmCsDs tm_cs  $ -- See Note [Type and Term Equality Propagation]+                             dsGRHSs ctxt upats grhss rhs_ty+           ; return (EqnInfo { eqn_pats = upats, eqn_rhs  = match_result}) }++    handleWarnings = if isGenerated origin+                     then discardWarningsDs+                     else id+++matchEquations  :: HsMatchContext Name+                -> [MatchId] -> [EquationInfo] -> Type+                -> DsM CoreExpr+matchEquations ctxt vars eqns_info rhs_ty+  = do  { let error_doc = matchContextErrString ctxt++        ; match_result <- match vars rhs_ty eqns_info++        ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc+        ; extractMatchResult match_result fail_expr }++{-+************************************************************************+*                                                                      *+\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}+*                                                                      *+************************************************************************++@mkSimpleMatch@ is a wrapper for @match@ which deals with the+situation where we want to match a single expression against a single+pattern. It returns an expression.+-}++matchSimply :: CoreExpr                 -- Scrutinee+            -> HsMatchContext Name      -- Match kind+            -> LPat Id                  -- Pattern it should match+            -> CoreExpr                 -- Return this if it matches+            -> CoreExpr                 -- Return this if it doesn't+            -> DsM CoreExpr+-- Do not warn about incomplete patterns; see matchSinglePat comments+matchSimply scrut hs_ctx pat result_expr fail_expr = do+    let+      match_result = cantFailMatchResult result_expr+      rhs_ty       = exprType fail_expr+        -- Use exprType of fail_expr, because won't refine in the case of failure!+    match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result+    extractMatchResult match_result' fail_expr++matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id+               -> Type -> MatchResult -> DsM MatchResult+-- matchSinglePat ensures that the scrutinee is a variable+-- and then calls match_single_pat_var+--+-- matchSinglePat does not warn about incomplete patterns+-- Used for things like [ e | pat <- stuff ], where+-- incomplete patterns are just fine++matchSinglePat (Var var) ctx pat ty match_result+  | not (isExternalName (idName var))+  = match_single_pat_var var ctx pat ty match_result++matchSinglePat scrut hs_ctx pat ty match_result+  = do { var           <- selectSimpleMatchVarL pat+       ; match_result' <- match_single_pat_var var hs_ctx pat ty match_result+       ; return (adjustMatchResult (bindNonRec var scrut) match_result') }++match_single_pat_var :: Id   -- See Note [Match Ids]+                     -> HsMatchContext Name -> LPat Id+                     -> Type -> MatchResult -> DsM MatchResult+match_single_pat_var var ctx pat ty match_result+  = ASSERT2( isInternalName (idName var), ppr var )+    do { dflags <- getDynFlags+       ; locn   <- getSrcSpanDs++                    -- Pattern match check warnings+       ; checkSingle dflags (DsMatchContext ctx locn) var (unLoc pat)++       ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]+                                , eqn_rhs  = match_result }+       ; match [var] ty [eqn_info] }+++{-+************************************************************************+*                                                                      *+                Pattern classification+*                                                                      *+************************************************************************+-}++data PatGroup+  = PgAny               -- Immediate match: variables, wildcards,+                        --                  lazy patterns+  | PgCon DataCon       -- Constructor patterns (incl list, tuple)+  | PgSyn PatSyn [Type] -- See Note [Pattern synonym groups]+  | PgLit Literal       -- Literal patterns+  | PgN   Rational      -- Overloaded numeric literals;+                        -- see Note [Don't use Literal for PgN]+  | PgOverS FastString  -- Overloaded string literals+  | PgNpK Integer       -- n+k patterns+  | PgBang              -- Bang patterns+  | PgCo Type           -- Coercion patterns; the type is the type+                        --      of the pattern *inside*+  | PgView (LHsExpr Id) -- view pattern (e -> p):+                        -- the LHsExpr is the expression e+           Type         -- the Type is the type of p (equivalently, the result type of e)+  | PgOverloadedList++{- Note [Don't use Literal for PgN]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Previously we had, as PatGroup constructors++  | ...+  | PgN   Literal       -- Overloaded literals+  | PgNpK Literal       -- n+k patterns+  | ...++But Literal is really supposed to represent an *unboxed* literal, like Int#.+We were sticking the literal from, say, an overloaded numeric literal pattern+into a MachInt constructor. This didn't really make sense; and we now have+the invariant that value in a MachInt must be in the range of the target+machine's Int# type, and an overloaded literal could meaningfully be larger.++Solution: For pattern grouping purposes, just store the literal directly in+the PgN constructor as a Rational if numeric, and add a PgOverStr constructor+for overloaded strings.+-}++groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]]+-- If the result is of form [g1, g2, g3],+-- (a) all the (pg,eq) pairs in g1 have the same pg+-- (b) none of the gi are empty+-- The ordering of equations is unchanged+groupEquations dflags eqns+  = runs same_gp [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns]+  where+    same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool+    (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2++subGroup :: (m -> [[EquationInfo]]) -- Map.elems+         -> m -- Map.empty+         -> (a -> m -> Maybe [EquationInfo]) -- Map.lookup+         -> (a -> [EquationInfo] -> m -> m) -- Map.insert+         -> [(a, EquationInfo)] -> [[EquationInfo]]+-- Input is a particular group.  The result sub-groups the+-- equations by with particular constructor, literal etc they match.+-- Each sub-list in the result has the same PatGroup+-- See Note [Take care with pattern order]+-- Parameterized by map operations to allow different implementations+-- and constraints, eg. types without Ord instance.+subGroup elems empty lookup insert group+    = map reverse $ elems $ foldl accumulate empty group+  where+    accumulate pg_map (pg, eqn)+      = case lookup pg pg_map of+          Just eqns -> insert pg (eqn:eqns) pg_map+          Nothing   -> insert pg [eqn]      pg_map+    -- pg_map :: Map a [EquationInfo]+    -- Equations seen so far in reverse order of appearance++subGroupOrd :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]+subGroupOrd = subGroup Map.elems Map.empty Map.lookup Map.insert++subGroupUniq :: Uniquable a => [(a, EquationInfo)] -> [[EquationInfo]]+subGroupUniq =+  subGroup eltsUDFM emptyUDFM (flip lookupUDFM) (\k v m -> addToUDFM m k v)++{- Note [Pattern synonym groups]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we see+  f (P a) = e1+  f (P b) = e2+    ...+where P is a pattern synonym, can we put (P a -> e1) and (P b -> e2) in the+same group?  We can if P is a constructor, but /not/ if P is a pattern synonym.+Consider (Trac #11224)+   -- readMaybe :: Read a => String -> Maybe a+   pattern PRead :: Read a => () => a -> String+   pattern PRead a <- (readMaybe -> Just a)++   f (PRead (x::Int))  = e1+   f (PRead (y::Bool)) = e2+This is all fine: we match the string by trying to read an Int; if that+fails we try to read a Bool. But clearly we can't combine the two into a single+match.++Conclusion: we can combine when we invoke PRead /at the same type/.  Hence+in PgSyn we record the instantiaing types, and use them in sameGroup.++Note [Take care with pattern order]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the subGroup function we must be very careful about pattern re-ordering,+Consider the patterns [ (True, Nothing), (False, x), (True, y) ]+Then in bringing together the patterns for True, we must not+swap the Nothing and y!+-}++sameGroup :: PatGroup -> PatGroup -> Bool+-- Same group means that a single case expression+-- or test will suffice to match both, *and* the order+-- of testing within the group is insignificant.+sameGroup PgAny         PgAny         = True+sameGroup PgBang        PgBang        = True+sameGroup (PgCon _)     (PgCon _)     = True    -- One case expression+sameGroup (PgSyn p1 t1) (PgSyn p2 t2) = p1==p2 && eqTypes t1 t2+                                                -- eqTypes: See Note [Pattern synonym groups]+sameGroup (PgLit _)     (PgLit _)     = True    -- One case expression+sameGroup (PgN l1)      (PgN l2)      = l1==l2  -- Order is significant+sameGroup (PgOverS s1)  (PgOverS s2)  = s1==s2+sameGroup (PgNpK l1)    (PgNpK l2)    = l1==l2  -- See Note [Grouping overloaded literal patterns]+sameGroup (PgCo t1)     (PgCo t2)     = t1 `eqType` t2+        -- CoPats are in the same goup only if the type of the+        -- enclosed pattern is the same. The patterns outside the CoPat+        -- always have the same type, so this boils down to saying that+        -- the two coercions are identical.+sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2)+       -- ViewPats are in the same group iff the expressions+       -- are "equal"---conservatively, we use syntactic equality+sameGroup _          _          = False++-- An approximation of syntactic equality used for determining when view+-- exprs are in the same group.+-- This function can always safely return false;+-- but doing so will result in the application of the view function being repeated.+--+-- Currently: compare applications of literals and variables+--            and anything else that we can do without involving other+--            HsSyn types in the recursion+--+-- NB we can't assume that the two view expressions have the same type.  Consider+--   f (e1 -> True) = ...+--   f (e2 -> "hi") = ...+viewLExprEq :: (LHsExpr Id,Type) -> (LHsExpr Id,Type) -> Bool+viewLExprEq (e1,_) (e2,_) = lexp e1 e2+  where+    lexp :: LHsExpr Id -> LHsExpr Id -> Bool+    lexp e e' = exp (unLoc e) (unLoc e')++    ---------+    exp :: HsExpr Id -> HsExpr Id -> Bool+    -- real comparison is on HsExpr's+    -- strip parens+    exp (HsPar (L _ e)) e'   = exp e e'+    exp e (HsPar (L _ e'))   = exp e e'+    -- because the expressions do not necessarily have the same type,+    -- we have to compare the wrappers+    exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e'+    exp (HsVar i) (HsVar i') =  i == i'+    exp (HsConLikeOut c) (HsConLikeOut c') = c == c'+    -- the instance for IPName derives using the id, so this works if the+    -- above does+    exp (HsIPVar i) (HsIPVar i') = i == i'+    exp (HsOverLabel l x) (HsOverLabel l' x') = l == l' && x == x'+    exp (HsOverLit l) (HsOverLit l') =+        -- Overloaded lits are equal if they have the same type+        -- and the data is the same.+        -- this is coarser than comparing the SyntaxExpr's in l and l',+        -- which resolve the overloading (e.g., fromInteger 1),+        -- because these expressions get written as a bunch of different variables+        -- (presumably to improve sharing)+        eqType (overLitType l) (overLitType l') && l == l'+    exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2'+    -- the fixities have been straightened out by now, so it's safe+    -- to ignore them?+    exp (OpApp l o _ ri) (OpApp l' o' _ ri') =+        lexp l l' && lexp o o' && lexp ri ri'+    exp (NegApp e n) (NegApp e' n') = lexp e e' && syn_exp n n'+    exp (SectionL e1 e2) (SectionL e1' e2') =+        lexp e1 e1' && lexp e2 e2'+    exp (SectionR e1 e2) (SectionR e1' e2') =+        lexp e1 e1' && lexp e2 e2'+    exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) =+        eq_list tup_arg es1 es2+    exp (ExplicitSum _ _ e _) (ExplicitSum _ _ e' _) = lexp e e'+    exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') =+        lexp e e' && lexp e1 e1' && lexp e2 e2'++    -- Enhancement: could implement equality for more expressions+    --   if it seems useful+    -- But no need for HsLit, ExplicitList, ExplicitTuple,+    -- because they cannot be functions+    exp _ _  = False++    ---------+    syn_exp :: SyntaxExpr Id -> SyntaxExpr Id -> Bool+    syn_exp (SyntaxExpr { syn_expr      = expr1+                        , syn_arg_wraps = arg_wraps1+                        , syn_res_wrap  = res_wrap1 })+            (SyntaxExpr { syn_expr      = expr2+                        , syn_arg_wraps = arg_wraps2+                        , syn_res_wrap  = res_wrap2 })+      = exp expr1 expr2 &&+        and (zipWithEqual "viewLExprEq" wrap arg_wraps1 arg_wraps2) &&+        wrap res_wrap1 res_wrap2++    ---------+    tup_arg (L _ (Present e1)) (L _ (Present e2)) = lexp e1 e2+    tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2+    tup_arg _ _ = False++    ---------+    wrap :: HsWrapper -> HsWrapper -> Bool+    -- Conservative, in that it demands that wrappers be+    -- syntactically identical and doesn't look under binders+    --+    -- Coarser notions of equality are possible+    -- (e.g., reassociating compositions,+    --        equating different ways of writing a coercion)+    wrap WpHole WpHole = True+    wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'+    wrap (WpFun w1 w2 _ _) (WpFun w1' w2' _ _) = wrap w1 w1' && wrap w2 w2'+    wrap (WpCast co)       (WpCast co')        = co `eqCoercion` co'+    wrap (WpEvApp et1)     (WpEvApp et2)       = et1 `ev_term` et2+    wrap (WpTyApp t)       (WpTyApp t')        = eqType t t'+    -- Enhancement: could implement equality for more wrappers+    --   if it seems useful (lams and lets)+    wrap _ _ = False++    ---------+    ev_term :: EvTerm -> EvTerm -> Bool+    ev_term (EvId a)       (EvId b)       = a==b+    ev_term (EvCoercion a) (EvCoercion b) = a `eqCoercion` b+    ev_term _ _ = False++    ---------+    eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool+    eq_list _  []     []     = True+    eq_list _  []     (_:_)  = False+    eq_list _  (_:_)  []     = False+    eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys++patGroup :: DynFlags -> Pat Id -> PatGroup+patGroup _ (ConPatOut { pat_con = L _ con+                      , pat_arg_tys = tys })+ | RealDataCon dcon <- con              = PgCon dcon+ | PatSynCon psyn <- con                = PgSyn psyn tys+patGroup _ (WildPat {})                 = PgAny+patGroup _ (BangPat {})                 = PgBang+patGroup _ (NPat (L _ OverLit {ol_val=oval}) mb_neg _ _) =+  case (oval, isJust mb_neg) of+   (HsIntegral _ i, False) -> PgN (fromInteger i)+   (HsIntegral _ i, True ) -> PgN (-fromInteger i)+   (HsFractional r, False) -> PgN (fl_value r)+   (HsFractional r, True ) -> PgN (-fl_value r)+   (HsIsString _ s, _) -> ASSERT(isNothing mb_neg)+                          PgOverS s+patGroup _ (NPlusKPat _ (L _ OverLit {ol_val=oval}) _ _ _ _) =+  case oval of+   HsIntegral _ i -> PgNpK i+   _ -> pprPanic "patGroup NPlusKPat" (ppr oval)+patGroup _ (CoPat _ p _)                = PgCo  (hsPatType p) -- Type of innelexp pattern+patGroup _ (ViewPat expr p _)           = PgView expr (hsPatType (unLoc p))+patGroup _ (ListPat _ _ (Just _))       = PgOverloadedList+patGroup dflags (LitPat lit)            = PgLit (hsLitKey dflags lit)+patGroup _ pat                          = pprPanic "patGroup" (ppr pat)++{-+Note [Grouping overloaded literal patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+WATCH OUT!  Consider++        f (n+1) = ...+        f (n+2) = ...+        f (n+1) = ...++We can't group the first and third together, because the second may match+the same thing as the first.  Same goes for *overloaded* literal patterns+        f 1 True = ...+        f 2 False = ...+        f 1 False = ...+If the first arg matches '1' but the second does not match 'True', we+cannot jump to the third equation!  Because the same argument might+match '2'!+Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group.+-}
+ deSugar/Match.hs-boot view
@@ -0,0 +1,34 @@+module Match where+import Var      ( Id )+import TcType   ( Type )+import DsMonad  ( DsM, EquationInfo, MatchResult )+import CoreSyn  ( CoreExpr )+import HsSyn    ( LPat, HsMatchContext, MatchGroup, LHsExpr )+import Name     ( Name )++match   :: [Id]+        -> Type+        -> [EquationInfo]+        -> DsM MatchResult++matchWrapper+        :: HsMatchContext Name+        -> Maybe (LHsExpr Id)+        -> MatchGroup Id (LHsExpr Id)+        -> DsM ([Id], CoreExpr)++matchSimply+        :: CoreExpr+        -> HsMatchContext Name+        -> LPat Id+        -> CoreExpr+        -> CoreExpr+        -> DsM CoreExpr++matchSinglePat+        :: CoreExpr+        -> HsMatchContext Name+        -> LPat Id+        -> Type+        -> MatchResult+        -> DsM MatchResult
+ deSugar/MatchCon.hs view
@@ -0,0 +1,287 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Pattern-matching constructors+-}++{-# LANGUAGE CPP #-}++module MatchCon ( matchConFamily, matchPatSyn ) where++#include "HsVersions.h"++import {-# SOURCE #-} Match     ( match )++import HsSyn+import DsBinds+import ConLike+import TcType+import DsMonad+import DsUtils+import MkCore   ( mkCoreLets )+import Util+import ListSetOps ( runs )+import Id+import NameEnv+import FieldLabel ( flSelector )+import SrcLoc+import DynFlags+import Outputable+import Control.Monad(liftM)++{-+We are confronted with the first column of patterns in a set of+equations, all beginning with constructors from one ``family'' (e.g.,+@[]@ and @:@ make up the @List@ ``family'').  We want to generate the+alternatives for a @Case@ expression.  There are several choices:+\begin{enumerate}+\item+Generate an alternative for every constructor in the family, whether+they are used in this set of equations or not; this is what the Wadler+chapter does.+\begin{description}+\item[Advantages:]+(a)~Simple.  (b)~It may also be that large sparsely-used constructor+families are mainly handled by the code for literals.+\item[Disadvantages:]+(a)~Not practical for large sparsely-used constructor families, e.g.,+the ASCII character set.  (b)~Have to look up a list of what+constructors make up the whole family.+\end{description}++\item+Generate an alternative for each constructor used, then add a default+alternative in case some constructors in the family weren't used.+\begin{description}+\item[Advantages:]+(a)~Alternatives aren't generated for unused constructors.  (b)~The+STG is quite happy with defaults.  (c)~No lookup in an environment needed.+\item[Disadvantages:]+(a)~A spurious default alternative may be generated.+\end{description}++\item+``Do it right:'' generate an alternative for each constructor used,+and add a default alternative if all constructors in the family+weren't used.+\begin{description}+\item[Advantages:]+(a)~You will get cases with only one alternative (and no default),+which should be amenable to optimisation.  Tuples are a common example.+\item[Disadvantages:]+(b)~Have to look up constructor families in TDE (as above).+\end{description}+\end{enumerate}++We are implementing the ``do-it-right'' option for now.  The arguments+to @matchConFamily@ are the same as to @match@; the extra @Int@+returned is the number of constructors in the family.++The function @matchConFamily@ is concerned with this+have-we-used-all-the-constructors? question; the local function+@match_cons_used@ does all the real work.+-}++matchConFamily :: [Id]+               -> Type+               -> [[EquationInfo]]+               -> DsM MatchResult+-- Each group of eqns is for a single constructor+matchConFamily (var:vars) ty groups+  = do dflags <- getDynFlags+       alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups+       return (mkCoAlgCaseMatchResult dflags var ty alts)+  where+    toRealAlt alt = case alt_pat alt of+        RealDataCon dcon -> alt{ alt_pat = dcon }+        _ -> panic "matchConFamily: not RealDataCon"+matchConFamily [] _ _ = panic "matchConFamily []"++matchPatSyn :: [Id]+            -> Type+            -> [EquationInfo]+            -> DsM MatchResult+matchPatSyn (var:vars) ty eqns+  = do alt <- fmap toSynAlt $ matchOneConLike vars ty eqns+       return (mkCoSynCaseMatchResult var ty alt)+  where+    toSynAlt alt = case alt_pat alt of+        PatSynCon psyn -> alt{ alt_pat = psyn }+        _ -> panic "matchPatSyn: not PatSynCon"+matchPatSyn _ _ _ = panic "matchPatSyn []"++type ConArgPats = HsConDetails (LPat Id) (HsRecFields Id (LPat Id))++matchOneConLike :: [Id]+                -> Type+                -> [EquationInfo]+                -> DsM (CaseAlt ConLike)+matchOneConLike vars ty (eqn1 : eqns)   -- All eqns for a single constructor+  = do  { let inst_tys = ASSERT( tvs1 `equalLength` ex_tvs )+                         arg_tys ++ mkTyVarTys tvs1++              val_arg_tys = conLikeInstOrigArgTys con1 inst_tys+        -- dataConInstOrigArgTys takes the univ and existential tyvars+        -- and returns the types of the *value* args, which is what we want++              match_group :: [Id]+                          -> [(ConArgPats, EquationInfo)] -> DsM MatchResult+              -- All members of the group have compatible ConArgPats+              match_group arg_vars arg_eqn_prs+                = ASSERT( notNull arg_eqn_prs )+                  do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs)+                     ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs+                     ; match_result <- match (group_arg_vars ++ vars) ty eqns'+                     ; return (adjustMatchResult (foldr1 (.) wraps) match_result) }++              shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds,+                                                             pat_binds = bind, pat_args = args+                                                  } : pats }))+                = do ds_bind <- dsTcEvBinds bind+                     return ( wrapBinds (tvs `zip` tvs1)+                            . wrapBinds (ds  `zip` dicts1)+                            . mkCoreLets ds_bind+                            , eqn { eqn_pats = conArgPats val_arg_tys args ++ pats }+                            )+              shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps)++        ; arg_vars <- selectConMatchVars val_arg_tys args1+                -- Use the first equation as a source of+                -- suggestions for the new variables++        -- Divide into sub-groups; see Note [Record patterns]+        ; let groups :: [[(ConArgPats, EquationInfo)]]+              groups = runs compatible_pats [ (pat_args (firstPat eqn), eqn)+                                            | eqn <- eqn1:eqns ]++        ; match_results <- mapM (match_group arg_vars) groups++        ; return $ MkCaseAlt{ alt_pat = con1,+                              alt_bndrs = tvs1 ++ dicts1 ++ arg_vars,+                              alt_wrapper = wrapper1,+                              alt_result = foldr1 combineMatchResults match_results } }+  where+    ConPatOut { pat_con = L _ con1, pat_arg_tys = arg_tys, pat_wrap = wrapper1,+                pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 }+              = firstPat eqn1+    fields1 = map flSelector (conLikeFieldLabels con1)++    ex_tvs = conLikeExTyVars con1++    -- Choose the right arg_vars in the right order for this group+    -- Note [Record patterns]+    select_arg_vars :: [Id] -> [(ConArgPats, EquationInfo)] -> [Id]+    select_arg_vars arg_vars ((arg_pats, _) : _)+      | RecCon flds <- arg_pats+      , let rpats = rec_flds flds+      , not (null rpats)     -- Treated specially; cf conArgPats+      = ASSERT2( length fields1 == length arg_vars,+                 ppr con1 $$ ppr fields1 $$ ppr arg_vars )+        map lookup_fld rpats+      | otherwise+      = arg_vars+      where+        fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars+        lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env+                                            (idName (unLoc (hsRecFieldId rpat)))+    select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []"+matchOneConLike _ _ [] = panic "matchOneCon []"++-----------------+compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool+-- Two constructors have compatible argument patterns if the number+-- and order of sub-matches is the same in both cases+compatible_pats (RecCon flds1, _) (RecCon flds2, _) = same_fields flds1 flds2+compatible_pats (RecCon flds1, _) _                 = null (rec_flds flds1)+compatible_pats _                 (RecCon flds2, _) = null (rec_flds flds2)+compatible_pats _                 _                 = True -- Prefix or infix con++same_fields :: HsRecFields Id (LPat Id) -> HsRecFields Id (LPat Id) -> Bool+same_fields flds1 flds2+  = all2 (\(L _ f1) (L _ f2)+                          -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))+         (rec_flds flds1) (rec_flds flds2)+++-----------------+selectConMatchVars :: [Type] -> ConArgPats -> DsM [Id]+selectConMatchVars arg_tys (RecCon {})      = newSysLocalsDsNoLP arg_tys+selectConMatchVars _       (PrefixCon ps)   = selectMatchVars (map unLoc ps)+selectConMatchVars _       (InfixCon p1 p2) = selectMatchVars [unLoc p1, unLoc p2]++conArgPats :: [Type]      -- Instantiated argument types+                          -- Used only to fill in the types of WildPats, which+                          -- are probably never looked at anyway+           -> ConArgPats+           -> [Pat Id]+conArgPats _arg_tys (PrefixCon ps)   = map unLoc ps+conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2]+conArgPats  arg_tys (RecCon (HsRecFields { rec_flds = rpats }))+  | null rpats = map WildPat arg_tys+        -- Important special case for C {}, which can be used for a+        -- datacon that isn't declared to have fields at all+  | otherwise  = map (unLoc . hsRecFieldArg . unLoc) rpats++{-+Note [Record patterns]+~~~~~~~~~~~~~~~~~~~~~~+Consider+         data T = T { x,y,z :: Bool }++         f (T { y=True, x=False }) = ...++We must match the patterns IN THE ORDER GIVEN, thus for the first+one we match y=True before x=False.  See Trac #246; or imagine+matching against (T { y=False, x=undefined }): should fail without+touching the undefined.++Now consider:++         f (T { y=True, x=False }) = ...+         f (T { x=True, y= False}) = ...++In the first we must test y first; in the second we must test x+first.  So we must divide even the equations for a single constructor+T into sub-goups, based on whether they match the same field in the+same order.  That's what the (runs compatible_pats) grouping.++All non-record patterns are "compatible" in this sense, because the+positional patterns (T a b) and (a `T` b) all match the arguments+in order.  Also T {} is special because it's equivalent to (T _ _).+Hence the (null rpats) checks here and there.+++Note [Existentials in shift_con_pat]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+        data T = forall a. Ord a => T a (a->Int)++        f (T x f) True  = ...expr1...+        f (T y g) False = ...expr2..++When we put in the tyvars etc we get++        f (T a (d::Ord a) (x::a) (f::a->Int)) True =  ...expr1...+        f (T b (e::Ord b) (y::a) (g::a->Int)) True =  ...expr2...++After desugaring etc we'll get a single case:++        f = \t::T b::Bool ->+            case t of+               T a (d::Ord a) (x::a) (f::a->Int)) ->+            case b of+                True  -> ...expr1...+                False -> ...expr2...++*** We have to substitute [a/b, d/e] in expr2! **+Hence+                False -> ....((/\b\(e:Ord b).expr2) a d)....++Originally I tried to use+        (\b -> let e = d in expr2) a+to do this substitution.  While this is "correct" in a way, it fails+Lint, because e::Ord b but d::Ord a.++-}
+ deSugar/MatchLit.hs view
@@ -0,0 +1,456 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Pattern-matching literal patterns+-}++{-# LANGUAGE CPP, ScopedTypeVariables #-}++module MatchLit ( dsLit, dsOverLit, dsOverLit', hsLitKey+                , tidyLitPat, tidyNPat+                , matchLiterals, matchNPlusKPats, matchNPats+                , warnAboutIdentities, warnAboutOverflowedLiterals+                , warnAboutEmptyEnumerations+                ) where++#include "HsVersions.h"++import {-# SOURCE #-} Match  ( match )+import {-# SOURCE #-} DsExpr ( dsExpr, dsSyntaxExpr )++import DsMonad+import DsUtils++import HsSyn++import Id+import CoreSyn+import MkCore+import TyCon+import DataCon+import TcHsSyn ( shortCutLit )+import TcType+import Name+import Type+import PrelNames+import TysWiredIn+import Literal+import SrcLoc+import Data.Ratio+import Outputable+import BasicTypes+import DynFlags+import Util+import FastString+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Data.Int+import Data.Word++{-+************************************************************************+*                                                                      *+                Desugaring literals+        [used to be in DsExpr, but DsMeta needs it,+         and it's nice to avoid a loop]+*                                                                      *+************************************************************************++We give int/float literals type @Integer@ and @Rational@, respectively.+The typechecker will (presumably) have put \tr{from{Integer,Rational}s}+around them.++ToDo: put in range checks for when converting ``@i@''+(or should that be in the typechecker?)++For numeric literals, we try to detect there use at a standard type+(@Int@, @Float@, etc.) are directly put in the right constructor.+[NB: down with the @App@ conversion.]++See also below where we look for @DictApps@ for \tr{plusInt}, etc.+-}++dsLit :: HsLit -> DsM CoreExpr+dsLit (HsStringPrim _ s) = return (Lit (MachStr s))+dsLit (HsCharPrim   _ c) = return (Lit (MachChar c))+dsLit (HsIntPrim    _ i) = return (Lit (MachInt i))+dsLit (HsWordPrim   _ w) = return (Lit (MachWord w))+dsLit (HsInt64Prim  _ i) = return (Lit (MachInt64 i))+dsLit (HsWord64Prim _ w) = return (Lit (MachWord64 w))+dsLit (HsFloatPrim    f) = return (Lit (MachFloat (fl_value f)))+dsLit (HsDoublePrim   d) = return (Lit (MachDouble (fl_value d)))++dsLit (HsChar _ c)       = return (mkCharExpr c)+dsLit (HsString _ str)   = mkStringExprFS str+dsLit (HsInteger _ i _)  = mkIntegerExpr i+dsLit (HsInt _ i)        = do dflags <- getDynFlags+                              return (mkIntExpr dflags i)++dsLit (HsRat r ty) = do+   num   <- mkIntegerExpr (numerator (fl_value r))+   denom <- mkIntegerExpr (denominator (fl_value r))+   return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])+  where+    (ratio_data_con, integer_ty)+        = case tcSplitTyConApp ty of+                (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)+                                   (head (tyConDataCons tycon), i_ty)+                x -> pprPanic "dsLit" (ppr x)++dsOverLit :: HsOverLit Id -> DsM CoreExpr+dsOverLit lit = do { dflags <- getDynFlags+                   ; warnAboutOverflowedLiterals dflags lit+                   ; dsOverLit' dflags lit }++dsOverLit' :: DynFlags -> HsOverLit Id -> DsM CoreExpr+-- Post-typechecker, the HsExpr field of an OverLit contains+-- (an expression for) the literal value itself+dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable+                           , ol_witness = witness, ol_type = ty })+  | not rebindable+  , Just expr <- shortCutLit dflags val ty = dsExpr expr        -- Note [Literal short cut]+  | otherwise                              = dsExpr witness++{-+Note [Literal short cut]+~~~~~~~~~~~~~~~~~~~~~~~~+The type checker tries to do this short-cutting as early as possible, but+because of unification etc, more information is available to the desugarer.+And where it's possible to generate the correct literal right away, it's+much better to do so.+++************************************************************************+*                                                                      *+                 Warnings about overflowed literals+*                                                                      *+************************************************************************++Warn about functions like toInteger, fromIntegral, that convert+between one type and another when the to- and from- types are the+same.  Then it's probably (albeit not definitely) the identity+-}++warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM ()+warnAboutIdentities dflags (Var conv_fn) type_of_conv+  | wopt Opt_WarnIdentities dflags+  , idName conv_fn `elem` conversionNames+  , Just (arg_ty, res_ty) <- splitFunTy_maybe type_of_conv+  , arg_ty `eqType` res_ty  -- So we are converting  ty -> ty+  = warnDs (Reason Opt_WarnIdentities)+           (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv+                 , nest 2 $ text "can probably be omitted"+           ])+warnAboutIdentities _ _ _ = return ()++conversionNames :: [Name]+conversionNames+  = [ toIntegerName, toRationalName+    , fromIntegralName, realToFracName ]+ -- We can't easily add fromIntegerName, fromRationalName,+ -- because they are generated by literals++warnAboutOverflowedLiterals :: DynFlags -> HsOverLit Id -> DsM ()+warnAboutOverflowedLiterals dflags lit+ | wopt Opt_WarnOverflowedLiterals dflags+ , Just (i, tc) <- getIntegralLit lit+  = if      tc == intTyConName    then check i tc (undefined :: Int)+    else if tc == int8TyConName   then check i tc (undefined :: Int8)+    else if tc == int16TyConName  then check i tc (undefined :: Int16)+    else if tc == int32TyConName  then check i tc (undefined :: Int32)+    else if tc == int64TyConName  then check i tc (undefined :: Int64)+    else if tc == wordTyConName   then check i tc (undefined :: Word)+    else if tc == word8TyConName  then check i tc (undefined :: Word8)+    else if tc == word16TyConName then check i tc (undefined :: Word16)+    else if tc == word32TyConName then check i tc (undefined :: Word32)+    else if tc == word64TyConName then check i tc (undefined :: Word64)+    else return ()++  | otherwise = return ()+  where+    check :: forall a. (Bounded a, Integral a) => Integer -> Name -> a -> DsM ()+    check i tc _proxy+      = when (i < minB || i > maxB) $ do+        warnDs (Reason Opt_WarnOverflowedLiterals)+               (vcat [ text "Literal" <+> integer i+                       <+> text "is out of the" <+> ppr tc <+> ptext (sLit "range")+                       <+> integer minB <> text ".." <> integer maxB+                     , sug ])+      where+        minB = toInteger (minBound :: a)+        maxB = toInteger (maxBound :: a)+        sug | minB == -i   -- Note [Suggest NegativeLiterals]+            , i > 0+            , not (xopt LangExt.NegativeLiterals dflags)+            = text "If you are trying to write a large negative literal, use NegativeLiterals"+            | otherwise = Outputable.empty++{-+Note [Suggest NegativeLiterals]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If you write+  x :: Int8+  x = -128+it'll parse as (negate 128), and overflow.  In this case, suggest NegativeLiterals.+We get an erroneous suggestion for+  x = 128+but perhaps that does not matter too much.+-}++warnAboutEmptyEnumerations :: DynFlags -> LHsExpr Id -> Maybe (LHsExpr Id) -> LHsExpr Id -> DsM ()+-- Warns about [2,3 .. 1] which returns the empty list+-- Only works for integral types, not floating point+warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr+  | wopt Opt_WarnEmptyEnumerations dflags+  , Just (from,tc) <- getLHsIntegralLit fromExpr+  , Just mThn      <- traverse getLHsIntegralLit mThnExpr+  , Just (to,_)    <- getLHsIntegralLit toExpr+  , let check :: forall a. (Enum a, Num a) => a -> DsM ()+        check _proxy+          = when (null enumeration) $+            warnDs (Reason Opt_WarnEmptyEnumerations) (text "Enumeration is empty")+          where+            enumeration :: [a]+            enumeration = case mThn of+                            Nothing      -> [fromInteger from                    .. fromInteger to]+                            Just (thn,_) -> [fromInteger from, fromInteger thn   .. fromInteger to]++  = if      tc == intTyConName    then check (undefined :: Int)+    else if tc == int8TyConName   then check (undefined :: Int8)+    else if tc == int16TyConName  then check (undefined :: Int16)+    else if tc == int32TyConName  then check (undefined :: Int32)+    else if tc == int64TyConName  then check (undefined :: Int64)+    else if tc == wordTyConName   then check (undefined :: Word)+    else if tc == word8TyConName  then check (undefined :: Word8)+    else if tc == word16TyConName then check (undefined :: Word16)+    else if tc == word32TyConName then check (undefined :: Word32)+    else if tc == word64TyConName then check (undefined :: Word64)+    else if tc == integerTyConName then check (undefined :: Integer)+    else return ()++  | otherwise = return ()++getLHsIntegralLit :: LHsExpr Id -> Maybe (Integer, Name)+-- See if the expression is an Integral literal+-- Remember to look through automatically-added tick-boxes! (Trac #8384)+getLHsIntegralLit (L _ (HsPar e))            = getLHsIntegralLit e+getLHsIntegralLit (L _ (HsTick _ e))         = getLHsIntegralLit e+getLHsIntegralLit (L _ (HsBinTick _ _ e))    = getLHsIntegralLit e+getLHsIntegralLit (L _ (HsOverLit over_lit)) = getIntegralLit over_lit+getLHsIntegralLit _ = Nothing++getIntegralLit :: HsOverLit Id -> Maybe (Integer, Name)+getIntegralLit (OverLit { ol_val = HsIntegral _ i, ol_type = ty })+  | Just tc <- tyConAppTyCon_maybe ty+  = Just (i, tyConName tc)+getIntegralLit _ = Nothing++{-+************************************************************************+*                                                                      *+        Tidying lit pats+*                                                                      *+************************************************************************+-}++tidyLitPat :: HsLit -> Pat Id+-- Result has only the following HsLits:+--      HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim+--      HsDoublePrim, HsStringPrim, HsString+--  * HsInteger, HsRat, HsInt can't show up in LitPats+--  * We get rid of HsChar right here+tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c)+tidyLitPat (HsString src s)+  | lengthFS s <= 1     -- Short string literals only+  = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon+                                             [mkCharLitPat src c, pat] [charTy])+                  (mkNilPat charTy) (unpackFS s)+        -- The stringTy is the type of the whole pattern, not+        -- the type to instantiate (:) or [] with!+tidyLitPat lit = LitPat lit++----------------+tidyNPat :: (HsLit -> Pat Id)   -- How to tidy a LitPat+                 -- We need this argument because tidyNPat is called+                 -- both by Match and by Check, but they tidy LitPats+                 -- slightly differently; and we must desugar+                 -- literals consistently (see Trac #5117)+         -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Type+         -> Pat Id+tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty+        -- False: Take short cuts only if the literal is not using rebindable syntax+        --+        -- Once that is settled, look for cases where the type of the+        -- entire overloaded literal matches the type of the underlying literal,+        -- and in that case take the short cut+        -- NB: Watch out for weird cases like Trac #3382+        --        f :: Int -> Int+        --        f "blah" = 4+        --     which might be ok if we have 'instance IsString Int'+        --+  | not type_change, isIntTy ty,    Just int_lit <- mb_int_lit+                 = mk_con_pat intDataCon    (HsIntPrim    NoSourceText int_lit)+  | not type_change, isWordTy ty,   Just int_lit <- mb_int_lit+                 = mk_con_pat wordDataCon   (HsWordPrim   NoSourceText int_lit)+  | not type_change, isStringTy ty, Just str_lit <- mb_str_lit+                 = tidy_lit_pat (HsString NoSourceText str_lit)+     -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3+     -- If we do convert to the constructor form, we'll generate a case+     -- expression on a Float# or Double# and that's not allowed in Core; see+     -- Trac #9238 and Note [Rules for floating-point comparisons] in PrelRules+  where+    -- Sometimes (like in test case+    -- overloadedlists/should_run/overloadedlistsrun04), the SyntaxExprs include+    -- type-changing wrappers (for example, from Id Int to Int, for the identity+    -- type family Id). In these cases, we can't do the short-cut.+    type_change = not (outer_ty `eqType` ty)++    mk_con_pat :: DataCon -> HsLit -> Pat Id+    mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] [])++    mb_int_lit :: Maybe Integer+    mb_int_lit = case (mb_neg, val) of+                   (Nothing, HsIntegral _ i) -> Just i+                   (Just _,  HsIntegral _ i) -> Just (-i)+                   _ -> Nothing++    mb_str_lit :: Maybe FastString+    mb_str_lit = case (mb_neg, val) of+                   (Nothing, HsIsString _ s) -> Just s+                   _ -> Nothing++tidyNPat _ over_lit mb_neg eq outer_ty+  = NPat (noLoc over_lit) mb_neg eq outer_ty++{-+************************************************************************+*                                                                      *+                Pattern matching on LitPat+*                                                                      *+************************************************************************+-}++matchLiterals :: [Id]+              -> Type                   -- Type of the whole case expression+              -> [[EquationInfo]]       -- All PgLits+              -> DsM MatchResult++matchLiterals (var:vars) ty sub_groups+  = ASSERT( notNull sub_groups && all notNull sub_groups )+    do  {       -- Deal with each group+        ; alts <- mapM match_group sub_groups++                -- Combine results.  For everything except String+                -- we can use a case expression; for String we need+                -- a chain of if-then-else+        ; if isStringTy (idType var) then+            do  { eq_str <- dsLookupGlobalId eqStringName+                ; mrs <- mapM (wrap_str_guard eq_str) alts+                ; return (foldr1 combineMatchResults mrs) }+          else+            return (mkCoPrimCaseMatchResult var ty alts)+        }+  where+    match_group :: [EquationInfo] -> DsM (Literal, MatchResult)+    match_group eqns+        = do dflags <- getDynFlags+             let LitPat hs_lit = firstPat (head eqns)+             match_result <- match vars ty (shiftEqns eqns)+             return (hsLitKey dflags hs_lit, match_result)++    wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult+        -- Equality check for string literals+    wrap_str_guard eq_str (MachStr s, mr)+        = do { -- We now have to convert back to FastString. Perhaps there+               -- should be separate MachBytes and MachStr constructors?+               let s'  = mkFastStringByteString s+             ; lit    <- mkStringExprFS s'+             ; let pred = mkApps (Var eq_str) [Var var, lit]+             ; return (mkGuardedMatchResult pred mr) }+    wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l)++matchLiterals [] _ _ = panic "matchLiterals []"++---------------------------+hsLitKey :: DynFlags -> HsLit -> Literal+-- Get the Core literal corresponding to a HsLit.+-- It only works for primitive types and strings;+-- others have been removed by tidy+-- For HsString, it produces a MachStr, which really represents an _unboxed_+-- string literal; and we deal with it in matchLiterals above. Otherwise, it+-- produces a primitive Literal of type matching the original HsLit.+-- In the case of the fixed-width numeric types, we need to wrap here+-- because Literal has an invariant that the literal is in range, while+-- HsLit does not.+hsLitKey dflags (HsIntPrim    _ i) = mkMachIntWrap  dflags i+hsLitKey dflags (HsWordPrim   _ w) = mkMachWordWrap dflags w+hsLitKey _      (HsInt64Prim  _ i) = mkMachInt64Wrap       i+hsLitKey _      (HsWord64Prim _ w) = mkMachWord64Wrap      w+hsLitKey _      (HsCharPrim   _ c) = mkMachChar            c+hsLitKey _      (HsFloatPrim    f) = mkMachFloat           (fl_value f)+hsLitKey _      (HsDoublePrim   d) = mkMachDouble          (fl_value d)+hsLitKey _      (HsString _ s)     = MachStr (fastStringToByteString s)+hsLitKey _      l                  = pprPanic "hsLitKey" (ppr l)++{-+************************************************************************+*                                                                      *+                Pattern matching on NPat+*                                                                      *+************************************************************************+-}++matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult+matchNPats (var:vars) ty (eqn1:eqns)    -- All for the same literal+  = do  { let NPat (L _ lit) mb_neg eq_chk _ = firstPat eqn1+        ; lit_expr <- dsOverLit lit+        ; neg_lit <- case mb_neg of+                            Nothing  -> return lit_expr+                            Just neg -> dsSyntaxExpr neg [lit_expr]+        ; pred_expr <- dsSyntaxExpr eq_chk [Var var, neg_lit]+        ; match_result <- match vars ty (shiftEqns (eqn1:eqns))+        ; return (mkGuardedMatchResult pred_expr match_result) }+matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns))++{-+************************************************************************+*                                                                      *+                Pattern matching on n+k patterns+*                                                                      *+************************************************************************++For an n+k pattern, we use the various magic expressions we've been given.+We generate:+\begin{verbatim}+    if ge var lit then+        let n = sub var lit+        in  <expr-for-a-successful-match>+    else+        <try-next-pattern-or-whatever>+\end{verbatim}+-}++matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult+-- All NPlusKPats, for the *same* literal k+matchNPlusKPats (var:vars) ty (eqn1:eqns)+  = do  { let NPlusKPat (L _ n1) (L _ lit1) lit2 ge minus _ = firstPat eqn1+        ; lit1_expr   <- dsOverLit lit1+        ; lit2_expr   <- dsOverLit lit2+        ; pred_expr   <- dsSyntaxExpr ge    [Var var, lit1_expr]+        ; minusk_expr <- dsSyntaxExpr minus [Var var, lit2_expr]+        ; let (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)+        ; match_result <- match vars ty eqns'+        ; return  (mkGuardedMatchResult pred_expr               $+                   mkCoLetMatchResult (NonRec n1 minusk_expr)   $+                   adjustMatchResult (foldr1 (.) wraps)         $+                   match_result) }+  where+    shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ _ _ : pats })+        = (wrapBind n n1, eqn { eqn_pats = pats })+        -- The wrapBind is a no-op for the first equation+    shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)++matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns))
+ deSugar/PmExpr.hs view
@@ -0,0 +1,449 @@+{-+Author: George Karachalias <george.karachalias@cs.kuleuven.be>++Haskell expressions (as used by the pattern matching checker) and utilities.+-}++{-# LANGUAGE CPP #-}++module PmExpr (+        PmExpr(..), PmLit(..), SimpleEq, ComplexEq, toComplex, eqPmLit,+        truePmExpr, falsePmExpr, isTruePmExpr, isFalsePmExpr, isNotPmExprOther,+        lhsExprToPmExpr, hsExprToPmExpr, substComplexEq, filterComplex,+        pprPmExprWithParens, runPmPprM+    ) where++#include "HsVersions.h"++import HsSyn+import Id+import Name+import NameSet+import DataCon+import ConLike+import TysWiredIn+import Outputable+import Util+import SrcLoc++import Data.Maybe (mapMaybe)+import Data.List (groupBy, sortBy, nubBy)+import Control.Monad.Trans.State.Lazy++{-+%************************************************************************+%*                                                                      *+                         Lifted Expressions+%*                                                                      *+%************************************************************************+-}++{- Note [PmExprOther in PmExpr]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Since there is no plan to extend the (currently pretty naive) term oracle in+the near future, instead of playing with the verbose (HsExpr Id), we lift it to+PmExpr. All expressions the term oracle does not handle are wrapped by the+constructor PmExprOther. Note that we do not perform substitution in+PmExprOther. Because of this, we do not even print PmExprOther, since they may+refer to variables that are otherwise substituted away.+-}++-- ----------------------------------------------------------------------------+-- ** Types++-- | Lifted expressions for pattern match checking.+data PmExpr = PmExprVar   Name+            | PmExprCon   ConLike [PmExpr]+            | PmExprLit   PmLit+            | PmExprEq    PmExpr PmExpr  -- Syntactic equality+            | PmExprOther (HsExpr Id)    -- Note [PmExprOther in PmExpr]+++mkPmExprData :: DataCon -> [PmExpr] -> PmExpr+mkPmExprData dc args = PmExprCon (RealDataCon dc) args++-- | Literals (simple and overloaded ones) for pattern match checking.+data PmLit = PmSLit HsLit                                    -- simple+           | PmOLit Bool {- is it negated? -} (HsOverLit Id) -- overloaded++-- | Equality between literals for pattern match checking.+eqPmLit :: PmLit -> PmLit -> Bool+eqPmLit (PmSLit    l1) (PmSLit    l2) = l1 == l2+eqPmLit (PmOLit b1 l1) (PmOLit b2 l2) = b1 == b2 && l1 == l2+  -- See Note [Undecidable Equality for Overloaded Literals]+eqPmLit _              _              = False++{- Note [Undecidable Equality for Overloaded Literals]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Equality on overloaded literals is undecidable in the general case. Consider+the following example:++  instance Num Bool where+    ...+    fromInteger 0 = False -- C-like representation of booleans+    fromInteger _ = True++    f :: Bool -> ()+    f 1 = ()        -- Clause A+    f 2 = ()        -- Clause B++Clause B is redundant but to detect this, we should be able to solve the+constraint: False ~ (fromInteger 2 ~ fromInteger 1) which means that we+have to look through function `fromInteger`, whose implementation could+be anything. This poses difficulties for:++1. The expressive power of the check.+   We cannot expect a reasonable implementation of pattern matching to detect+   that fromInteger 2 ~ fromInteger 1 is True, unless we unfold function+   fromInteger. This puts termination at risk and is undecidable in the+   general case.++2. Performance.+   Having an unresolved constraint False ~ (fromInteger 2 ~ fromInteger 1)+   lying around could become expensive really fast. Ticket #11161 illustrates+   how heavy use of overloaded literals can generate plenty of those+   constraints, effectively undermining the term oracle's performance.++3. Error nessages/Warnings.+   What should our message for `f` above be? A reasonable approach would be+   to issue:++     Pattern matches are (potentially) redundant:+       f 2 = ...    under the assumption that 1 == 2++   but seems to complex and confusing for the user.++We choose to treat overloaded literals that look different as different. The+impact of this is the following:++  * Redundancy checking is rather conservative, since it cannot see that clause+    B above is redundant.++  * We have instant equality check for overloaded literals (we do not rely on+    the term oracle which is rather expensive, both in terms of performance and+    memory). This significantly improves the performance of functions `covered`+    `uncovered` and `divergent` in deSugar/Check.hs and effectively addresses+    #11161.++  * The warnings issued are simpler.++  * We do not play on the safe side, strictly speaking. The assumption that+    1 /= 2 makes the redundancy check more conservative but at the same time+    makes its dual (exhaustiveness check) unsafe. This we can live with, mainly+    for two reasons:+    1. At the moment we do not use the results of the check during compilation+       where this would be a disaster (could result in runtime errors even if+       our function was deemed exhaustive).+    2. Pattern matcing on literals can never be considered exhaustive unless we+       have a catch-all clause. Hence, this assumption affects mainly the+       appearance of the warnings and is, in practice safe.+-}++nubPmLit :: [PmLit] -> [PmLit]+nubPmLit = nubBy eqPmLit++-- | Term equalities+type SimpleEq  = (Id, PmExpr) -- We always use this orientation+type ComplexEq = (PmExpr, PmExpr)++-- | Lift a `SimpleEq` to a `ComplexEq`+toComplex :: SimpleEq -> ComplexEq+toComplex (x,e) = (PmExprVar (idName x), e)++-- | Expression `True'+truePmExpr :: PmExpr+truePmExpr = mkPmExprData trueDataCon []++-- | Expression `False'+falsePmExpr :: PmExpr+falsePmExpr = mkPmExprData falseDataCon []++-- ----------------------------------------------------------------------------+-- ** Predicates on PmExpr++-- | Check if an expression is lifted or not+isNotPmExprOther :: PmExpr -> Bool+isNotPmExprOther (PmExprOther _) = False+isNotPmExprOther _expr           = True++-- | Check whether a literal is negated+isNegatedPmLit :: PmLit -> Bool+isNegatedPmLit (PmOLit b _) = b+isNegatedPmLit _other_lit   = False++-- | Check whether a PmExpr is syntactically equal to term `True'.+isTruePmExpr :: PmExpr -> Bool+isTruePmExpr (PmExprCon c []) = c == RealDataCon trueDataCon+isTruePmExpr _other_expr      = False++-- | Check whether a PmExpr is syntactically equal to term `False'.+isFalsePmExpr :: PmExpr -> Bool+isFalsePmExpr (PmExprCon c []) = c == RealDataCon falseDataCon+isFalsePmExpr _other_expr      = False++-- | Check whether a PmExpr is syntactically e+isNilPmExpr :: PmExpr -> Bool+isNilPmExpr (PmExprCon c _) = c == RealDataCon nilDataCon+isNilPmExpr _other_expr     = False++-- | Check whether a PmExpr is syntactically equal to (x == y).+-- Since (==) is overloaded and can have an arbitrary implementation, we use+-- the PmExprEq constructor to represent only equalities with non-overloaded+-- literals where it coincides with a syntactic equality check.+isPmExprEq :: PmExpr -> Maybe (PmExpr, PmExpr)+isPmExprEq (PmExprEq e1 e2) = Just (e1,e2)+isPmExprEq _other_expr      = Nothing++-- | Check if a DataCon is (:).+isConsDataCon :: DataCon -> Bool+isConsDataCon con = consDataCon == con++-- ----------------------------------------------------------------------------+-- ** Substitution in PmExpr++-- | We return a boolean along with the expression. Hence, if substitution was+-- a no-op, we know that the expression still cannot progress.+substPmExpr :: Name -> PmExpr -> PmExpr -> (PmExpr, Bool)+substPmExpr x e1 e =+  case e of+    PmExprVar z | x == z    -> (e1, True)+                | otherwise -> (e, False)+    PmExprCon c ps -> let (ps', bs) = mapAndUnzip (substPmExpr x e1) ps+                      in  (PmExprCon c ps', or bs)+    PmExprEq ex ey -> let (ex', bx) = substPmExpr x e1 ex+                          (ey', by) = substPmExpr x e1 ey+                      in  (PmExprEq ex' ey', bx || by)+    _other_expr    -> (e, False) -- The rest are terminals (We silently ignore+                                 -- Other). See Note [PmExprOther in PmExpr]++-- | Substitute in a complex equality. We return (Left eq) if the substitution+-- affected the equality or (Right eq) if nothing happened.+substComplexEq :: Name -> PmExpr -> ComplexEq -> Either ComplexEq ComplexEq+substComplexEq x e (ex, ey)+  | bx || by  = Left  (ex', ey')+  | otherwise = Right (ex', ey')+  where+    (ex', bx) = substPmExpr x e ex+    (ey', by) = substPmExpr x e ey++-- -----------------------------------------------------------------------+-- ** Lift source expressions (HsExpr Id) to PmExpr++lhsExprToPmExpr :: LHsExpr Id -> PmExpr+lhsExprToPmExpr (L _ e) = hsExprToPmExpr e++hsExprToPmExpr :: HsExpr Id -> PmExpr++hsExprToPmExpr (HsVar         x) = PmExprVar (idName (unLoc x))+hsExprToPmExpr (HsConLikeOut  c) = PmExprVar (conLikeName c)+hsExprToPmExpr (HsOverLit  olit) = PmExprLit (PmOLit False olit)+hsExprToPmExpr (HsLit       lit) = PmExprLit (PmSLit lit)++hsExprToPmExpr e@(NegApp _ neg_e)+  | PmExprLit (PmOLit False ol) <- synExprToPmExpr neg_e+  = PmExprLit (PmOLit True ol)+  | otherwise = PmExprOther e+hsExprToPmExpr (HsPar (L _ e)) = hsExprToPmExpr e++hsExprToPmExpr e@(ExplicitTuple ps boxity)+  | all tupArgPresent ps = mkPmExprData tuple_con tuple_args+  | otherwise            = PmExprOther e+  where+    tuple_con  = tupleDataCon boxity (length ps)+    tuple_args = [ lhsExprToPmExpr e | L _ (Present e) <- ps ]++hsExprToPmExpr e@(ExplicitList _elem_ty mb_ol elems)+  | Nothing <- mb_ol = foldr cons nil (map lhsExprToPmExpr elems)+  | otherwise        = PmExprOther e {- overloaded list: No PmExprApp -}+  where+    cons x xs = mkPmExprData consDataCon [x,xs]+    nil       = mkPmExprData nilDataCon  []++hsExprToPmExpr (ExplicitPArr _elem_ty elems)+  = mkPmExprData (parrFakeCon (length elems)) (map lhsExprToPmExpr elems)+++-- we want this but we would have to make everything monadic :/+-- ./compiler/deSugar/DsMonad.hs:397:dsLookupDataCon :: Name -> DsM DataCon+--+-- hsExprToPmExpr (RecordCon   c _ binds) = do+--   con  <- dsLookupDataCon (unLoc c)+--   args <- mapM lhsExprToPmExpr (hsRecFieldsArgs binds)+--   return (PmExprCon con args)+hsExprToPmExpr e@(RecordCon   _ _ _ _) = PmExprOther e++hsExprToPmExpr (HsTick            _ e) = lhsExprToPmExpr e+hsExprToPmExpr (HsBinTick       _ _ e) = lhsExprToPmExpr e+hsExprToPmExpr (HsTickPragma  _ _ _ e) = lhsExprToPmExpr e+hsExprToPmExpr (HsSCC           _ _ e) = lhsExprToPmExpr e+hsExprToPmExpr (HsCoreAnn       _ _ e) = lhsExprToPmExpr e+hsExprToPmExpr (ExprWithTySig     e _) = lhsExprToPmExpr e+hsExprToPmExpr (ExprWithTySigOut  e _) = lhsExprToPmExpr e+hsExprToPmExpr (HsWrap            _ e) =  hsExprToPmExpr e+hsExprToPmExpr e = PmExprOther e -- the rest are not handled by the oracle++synExprToPmExpr :: SyntaxExpr Id -> PmExpr+synExprToPmExpr = hsExprToPmExpr . syn_expr  -- ignore the wrappers++{-+%************************************************************************+%*                                                                      *+                            Pretty printing+%*                                                                      *+%************************************************************************+-}++{- 1. Literals+~~~~~~~~~~~~~~+Starting with a function definition like:++    f :: Int -> Bool+    f 5 = True+    f 6 = True++The uncovered set looks like:+    { var |> False == (var == 5), False == (var == 6) }++Yet, we would like to print this nicely as follows:+   x , where x not one of {5,6}++Function `filterComplex' takes the set of residual constraints and packs+together the negative constraints that refer to the same variable so we can do+just this. Since these variables will be shown to the programmer, we also give+them better names (t1, t2, ..), hence the SDoc in PmNegLitCt.++2. Residual Constraints+~~~~~~~~~~~~~~~~~~~~~~~+Unhandled constraints that refer to HsExpr are typically ignored by the solver+(it does not even substitute in HsExpr so they are even printed as wildcards).+Additionally, the oracle returns a substitution if it succeeds so we apply this+substitution to the vectors before printing them out (see function `pprOne' in+Check.hs) to be more precice.+-}++-- -----------------------------------------------------------------------------+-- ** Transform residual constraints in appropriate form for pretty printing++type PmNegLitCt = (Name, (SDoc, [PmLit]))++filterComplex :: [ComplexEq] -> [PmNegLitCt]+filterComplex = zipWith rename nameList . map mkGroup+              . groupBy name . sortBy order . mapMaybe isNegLitCs+  where+    order x y = compare (fst x) (fst y)+    name  x y = fst x == fst y+    mkGroup l = (fst (head l), nubPmLit $ map snd l)+    rename new (old, lits) = (old, (new, lits))++    isNegLitCs (e1,e2)+      | isFalsePmExpr e1, Just (x,y) <- isPmExprEq e2 = isNegLitCs' x y+      | isFalsePmExpr e2, Just (x,y) <- isPmExprEq e1 = isNegLitCs' x y+      | otherwise = Nothing++    isNegLitCs' (PmExprVar x) (PmExprLit l) = Just (x, l)+    isNegLitCs' (PmExprLit l) (PmExprVar x) = Just (x, l)+    isNegLitCs' _ _             = Nothing++    -- Try nice names p,q,r,s,t before using the (ugly) t_i+    nameList :: [SDoc]+    nameList = map text ["p","q","r","s","t"] +++                 [ text ('t':show u) | u <- [(0 :: Int)..] ]++-- ----------------------------------------------------------------------------++runPmPprM :: PmPprM a -> [PmNegLitCt] -> (a, [(SDoc,[PmLit])])+runPmPprM m lit_env = (result, mapMaybe is_used lit_env)+  where+    (result, (_lit_env, used)) = runState m (lit_env, emptyNameSet)++    is_used (x,(name, lits))+      | elemNameSet x used = Just (name, lits)+      | otherwise         = Nothing++type PmPprM a = State ([PmNegLitCt], NameSet) a+-- (the first part of the state is read only. make it a reader?)++addUsed :: Name -> PmPprM ()+addUsed x = modify (\(negated, used) -> (negated, extendNameSet used x))++checkNegation :: Name -> PmPprM (Maybe SDoc) -- the clean name if it is negated+checkNegation x = do+  negated <- gets fst+  return $ case lookup x negated of+    Just (new, _) -> Just new+    Nothing       -> Nothing++-- | Pretty print a pmexpr, but remember to prettify the names of the variables+-- that refer to neg-literals. The ones that cannot be shown are printed as+-- underscores.+pprPmExpr :: PmExpr -> PmPprM SDoc+pprPmExpr (PmExprVar x) = do+  mb_name <- checkNegation x+  case mb_name of+    Just name -> addUsed x >> return name+    Nothing   -> return underscore++pprPmExpr (PmExprCon con args) = pprPmExprCon con args+pprPmExpr (PmExprLit l)        = return (ppr l)+pprPmExpr (PmExprEq _ _)       = return underscore -- don't show+pprPmExpr (PmExprOther _)      = return underscore -- don't show++needsParens :: PmExpr -> Bool+needsParens (PmExprVar   {}) = False+needsParens (PmExprLit    l) = isNegatedPmLit l+needsParens (PmExprEq    {}) = False -- will become a wildcard+needsParens (PmExprOther {}) = False -- will become a wildcard+needsParens (PmExprCon (RealDataCon c) es)+  | isTupleDataCon c || isPArrFakeCon c+  || isConsDataCon c || null es = False+  | otherwise                   = True+needsParens (PmExprCon (PatSynCon _) es) = not (null es)++pprPmExprWithParens :: PmExpr -> PmPprM SDoc+pprPmExprWithParens expr+  | needsParens expr = parens <$> pprPmExpr expr+  | otherwise        =            pprPmExpr expr++pprPmExprCon :: ConLike -> [PmExpr] -> PmPprM SDoc+pprPmExprCon (RealDataCon con) args+  | isTupleDataCon con = mkTuple <$> mapM pprPmExpr args+  |  isPArrFakeCon con = mkPArr  <$> mapM pprPmExpr args+  |  isConsDataCon con = pretty_list+  where+    mkTuple, mkPArr :: [SDoc] -> SDoc+    mkTuple = parens     . fsep . punctuate comma+    mkPArr  = paBrackets . fsep . punctuate comma++    -- lazily, to be used in the list case only+    pretty_list :: PmPprM SDoc+    pretty_list = case isNilPmExpr (last list) of+      True  -> brackets . fsep . punctuate comma <$> mapM pprPmExpr (init list)+      False -> parens   . hcat . punctuate colon <$> mapM pprPmExpr list++    list = list_elements args++    list_elements [x,y]+      | PmExprCon c es <- y,  RealDataCon nilDataCon == c+          = ASSERT(null es) [x,y]+      | PmExprCon c es <- y, RealDataCon consDataCon == c+          = x : list_elements es+      | otherwise = [x,y]+    list_elements list  = pprPanic "list_elements:" (ppr list)+pprPmExprCon cl args+  | conLikeIsInfix cl = case args of+      [x, y] -> do x' <- pprPmExprWithParens x+                   y' <- pprPmExprWithParens y+                   return (x' <+> ppr cl <+> y')+      -- can it be infix but have more than two arguments?+      list   -> pprPanic "pprPmExprCon:" (ppr list)+  | null args = return (ppr cl)+  | otherwise = do args' <- mapM pprPmExprWithParens args+                   return (fsep (ppr cl : args'))++instance Outputable PmLit where+  ppr (PmSLit     l) = pmPprHsLit l+  ppr (PmOLit neg l) = (if neg then char '-' else empty) <> ppr l++-- not really useful for pmexprs per se+instance Outputable PmExpr where+  ppr e = fst $ runPmPprM (pprPmExpr e) []
+ deSugar/TmOracle.hs view
@@ -0,0 +1,257 @@+{-+Author: George Karachalias <george.karachalias@cs.kuleuven.be>++The term equality oracle. The main export of the module is function `tmOracle'.+-}++{-# LANGUAGE CPP, MultiWayIf #-}++module TmOracle (++        -- re-exported from PmExpr+        PmExpr(..), PmLit(..), SimpleEq, ComplexEq, PmVarEnv, falsePmExpr,+        eqPmLit, filterComplex, isNotPmExprOther, runPmPprM, lhsExprToPmExpr,+        hsExprToPmExpr, pprPmExprWithParens,++        -- the term oracle+        tmOracle, TmState, initialTmState, solveOneEq, extendSubst, canDiverge,++        -- misc.+        toComplex, exprDeepLookup, pmLitType, flattenPmVarEnv+    ) where++#include "HsVersions.h"++import PmExpr++import Id+import Name+import Type+import HsLit+import TcHsSyn+import MonadUtils+import Util++import NameEnv++{-+%************************************************************************+%*                                                                      *+                      The term equality oracle+%*                                                                      *+%************************************************************************+-}++-- | The type of substitutions.+type PmVarEnv = NameEnv PmExpr++-- | The environment of the oracle contains+--     1. A Bool (are there any constraints we cannot handle? (PmExprOther)).+--     2. A substitution we extend with every step and return as a result.+type TmOracleEnv = (Bool, PmVarEnv)++-- | Check whether a constraint (x ~ BOT) can succeed,+-- given the resulting state of the term oracle.+canDiverge :: Name -> TmState -> Bool+canDiverge x (standby, (_unhandled, env))+  -- If the variable seems not evaluated, there is a possibility for+  -- constraint x ~ BOT to be satisfiable.+  | PmExprVar y <- varDeepLookup env x -- seems not forced+  -- If it is involved (directly or indirectly) in any equality in the+  -- worklist, we can assume that it is already indirectly evaluated,+  -- as a side-effect of equality checking. If not, then we can assume+  -- that the constraint is satisfiable.+  = not $ any (isForcedByEq x) standby || any (isForcedByEq y) standby+  -- Variable x is already in WHNF so the constraint is non-satisfiable+  | otherwise = False++  where+    isForcedByEq :: Name -> ComplexEq -> Bool+    isForcedByEq y (e1, e2) = varIn y e1 || varIn y e2++-- | Check whether a variable is in the free variables of an expression+varIn :: Name -> PmExpr -> Bool+varIn x e = case e of+  PmExprVar y    -> x == y+  PmExprCon _ es -> any (x `varIn`) es+  PmExprLit _    -> False+  PmExprEq e1 e2 -> (x `varIn` e1) || (x `varIn` e2)+  PmExprOther _  -> False++-- | Flatten the DAG (Could be improved in terms of performance.).+flattenPmVarEnv :: PmVarEnv -> PmVarEnv+flattenPmVarEnv env = mapNameEnv (exprDeepLookup env) env++-- | The state of the term oracle (includes complex constraints that cannot+-- progress unless we get more information).+type TmState = ([ComplexEq], TmOracleEnv)++-- | Initial state of the oracle.+initialTmState :: TmState+initialTmState = ([], (False, emptyNameEnv))++-- | Solve a complex equality (top-level).+solveOneEq :: TmState -> ComplexEq -> Maybe TmState+solveOneEq solver_env@(_,(_,env)) complex+  = solveComplexEq solver_env -- do the actual *merging* with existing state+  $ simplifyComplexEq               -- simplify as much as you can+  $ applySubstComplexEq env complex -- replace everything we already know++-- | Solve a complex equality.+solveComplexEq :: TmState -> ComplexEq -> Maybe TmState+solveComplexEq solver_state@(standby, (unhandled, env)) eq@(e1, e2) = case eq of+  -- We cannot do a thing about these cases+  (PmExprOther _,_)            -> Just (standby, (True, env))+  (_,PmExprOther _)            -> Just (standby, (True, env))++  (PmExprLit l1, PmExprLit l2) -> case eqPmLit l1 l2 of+    -- See Note [Undecidable Equality for Overloaded Literals]+    True  -> Just solver_state+    False -> Nothing++  (PmExprCon c1 ts1, PmExprCon c2 ts2)+    | c1 == c2  -> foldlM solveComplexEq solver_state (zip ts1 ts2)+    | otherwise -> Nothing+  (PmExprCon _ [], PmExprEq t1 t2)+    | isTruePmExpr e1  -> solveComplexEq solver_state (t1, t2)+    | isFalsePmExpr e1 -> Just (eq:standby, (unhandled, env))+  (PmExprEq t1 t2, PmExprCon _ [])+    | isTruePmExpr e2   -> solveComplexEq solver_state (t1, t2)+    | isFalsePmExpr e2  -> Just (eq:standby, (unhandled, env))++  (PmExprVar x, PmExprVar y)+    | x == y    -> Just solver_state+    | otherwise -> extendSubstAndSolve x e2 solver_state++  (PmExprVar x, _) -> extendSubstAndSolve x e2 solver_state+  (_, PmExprVar x) -> extendSubstAndSolve x e1 solver_state++  (PmExprEq _ _, PmExprEq _ _) -> Just (eq:standby, (unhandled, env))++  _ -> Just (standby, (True, env)) -- I HATE CATCH-ALLS++-- | Extend the substitution and solve the (possibly updated) constraints.+extendSubstAndSolve :: Name -> PmExpr -> TmState -> Maybe TmState+extendSubstAndSolve x e (standby, (unhandled, env))+  = foldlM solveComplexEq new_incr_state (map simplifyComplexEq changed)+  where+    -- Apply the substitution to the worklist and partition them to the ones+    -- that had some progress and the rest. Then, recurse over the ones that+    -- had some progress. Careful about performance:+    -- See Note [Representation of Term Equalities] in deSugar/Check.hs+    (changed, unchanged) = partitionWith (substComplexEq x e) standby+    new_incr_state       = (unchanged, (unhandled, extendNameEnv env x e))++-- | When we know that a variable is fresh, we do not actually have to+-- check whether anything changes, we know that nothing does. Hence,+-- `extendSubst` simply extends the substitution, unlike what+-- `extendSubstAndSolve` does.+extendSubst :: Id -> PmExpr -> TmState -> TmState+extendSubst y e (standby, (unhandled, env))+  | isNotPmExprOther simpl_e+  = (standby, (unhandled, extendNameEnv env x simpl_e))+  | otherwise = (standby, (True, env))+  where+    x = idName y+    simpl_e = fst $ simplifyPmExpr $ exprDeepLookup env e++-- | Simplify a complex equality.+simplifyComplexEq :: ComplexEq -> ComplexEq+simplifyComplexEq (e1, e2) = (fst $ simplifyPmExpr e1, fst $ simplifyPmExpr e2)++-- | Simplify an expression. The boolean indicates if there has been any+-- simplification or if the operation was a no-op.+simplifyPmExpr :: PmExpr -> (PmExpr, Bool)+-- See Note [Deep equalities]+simplifyPmExpr e = case e of+  PmExprCon c ts -> case mapAndUnzip simplifyPmExpr ts of+                      (ts', bs) -> (PmExprCon c ts', or bs)+  PmExprEq t1 t2 -> simplifyEqExpr t1 t2+  _other_expr    -> (e, False) -- the others are terminals++-- | Simplify an equality expression. The equality is given in parts.+simplifyEqExpr :: PmExpr -> PmExpr -> (PmExpr, Bool)+-- See Note [Deep equalities]+simplifyEqExpr e1 e2 = case (e1, e2) of+  -- Varables+  (PmExprVar x, PmExprVar y)+    | x == y -> (truePmExpr, True)++  -- Literals+  (PmExprLit l1, PmExprLit l2) -> case eqPmLit l1 l2 of+    -- See Note [Undecidable Equality for Overloaded Literals]+    True  -> (truePmExpr,  True)+    False -> (falsePmExpr, True)++  -- Can potentially be simplified+  (PmExprEq {}, _) -> case (simplifyPmExpr e1, simplifyPmExpr e2) of+    ((e1', True ), (e2', _    )) -> simplifyEqExpr e1' e2'+    ((e1', _    ), (e2', True )) -> simplifyEqExpr e1' e2'+    ((e1', False), (e2', False)) -> (PmExprEq e1' e2', False) -- cannot progress+  (_, PmExprEq {}) -> case (simplifyPmExpr e1, simplifyPmExpr e2) of+    ((e1', True ), (e2', _    )) -> simplifyEqExpr e1' e2'+    ((e1', _    ), (e2', True )) -> simplifyEqExpr e1' e2'+    ((e1', False), (e2', False)) -> (PmExprEq e1' e2', False) -- cannot progress++  -- Constructors+  (PmExprCon c1 ts1, PmExprCon c2 ts2)+    | c1 == c2 ->+        let (ts1', bs1) = mapAndUnzip simplifyPmExpr ts1+            (ts2', bs2) = mapAndUnzip simplifyPmExpr ts2+            (tss, _bss) = zipWithAndUnzip simplifyEqExpr ts1' ts2'+            worst_case  = PmExprEq (PmExprCon c1 ts1') (PmExprCon c2 ts2')+        in  if | not (or bs1 || or bs2) -> (worst_case, False) -- no progress+               | all isTruePmExpr  tss  -> (truePmExpr, True)+               | any isFalsePmExpr tss  -> (falsePmExpr, True)+               | otherwise              -> (worst_case, False)+    | otherwise -> (falsePmExpr, True)++  -- We cannot do anything about the rest..+  _other_equality -> (original, False)++  where+    original = PmExprEq e1 e2 -- reconstruct equality++-- | Apply an (un-flattened) substitution to a simple equality.+applySubstComplexEq :: PmVarEnv -> ComplexEq -> ComplexEq+applySubstComplexEq env (e1,e2) = (exprDeepLookup env e1, exprDeepLookup env e2)++-- | Apply an (un-flattened) substitution to a variable.+varDeepLookup :: PmVarEnv -> Name -> PmExpr+varDeepLookup env x+  | Just e <- lookupNameEnv env x = exprDeepLookup env e -- go deeper+  | otherwise                  = PmExprVar x          -- terminal+{-# INLINE varDeepLookup #-}++-- | Apply an (un-flattened) substitution to an expression.+exprDeepLookup :: PmVarEnv -> PmExpr -> PmExpr+exprDeepLookup env (PmExprVar x)    = varDeepLookup env x+exprDeepLookup env (PmExprCon c es) = PmExprCon c (map (exprDeepLookup env) es)+exprDeepLookup env (PmExprEq e1 e2) = PmExprEq (exprDeepLookup env e1)+                                               (exprDeepLookup env e2)+exprDeepLookup _   other_expr       = other_expr -- PmExprLit, PmExprOther++-- | External interface to the term oracle.+tmOracle :: TmState -> [ComplexEq] -> Maybe TmState+tmOracle tm_state eqs = foldlM solveOneEq tm_state eqs++-- | Type of a PmLit+pmLitType :: PmLit -> Type -- should be in PmExpr but gives cyclic imports :(+pmLitType (PmSLit   lit) = hsLitType   lit+pmLitType (PmOLit _ lit) = overLitType lit++{- Note [Deep equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~+Solving nested equalities is the most difficult part. The general strategy+is the following:++  * Equalities of the form (True ~ (e1 ~ e2)) are transformed to just+    (e1 ~ e2) and then treated recursively.++  * Equalities of the form (False ~ (e1 ~ e2)) cannot be analyzed unless+    we know more about the inner equality (e1 ~ e2). That's exactly what+    `simplifyEqExpr' tries to do: It takes e1 and e2 and either returns+    truePmExpr, falsePmExpr or (e1' ~ e2') in case it is uncertain. Note+    that it is not e but rather e', since it may perform some+    simplifications deeper.+-}
+ ghc.cabal view
@@ -0,0 +1,640 @@+Name: ghc+Version: 8.2.1+License: BSD3+License-File: LICENSE+Author: The GHC Team+Maintainer: glasgow-haskell-users@haskell.org+Homepage: http://www.haskell.org/ghc/+Synopsis: The GHC API+Description:+    GHC's functionality can be useful for more things than just+    compiling Haskell programs. Important use cases are programs+    that analyse (and perhaps transform) Haskell code. Others+    include loading Haskell code dynamically in a GHCi-like manner.+    For this reason, a lot of GHC's functionality is made available+    through this package.+Category: Development+Build-Type: Simple+Cabal-Version: >=2.0++extra-source-files:+    utils/md5.h+    Unique.h+    HsVersions.h+    nativeGen/NCG.h+    parser/cutils.h+    autogen/ghc_boot_platform.h+    autogen/CodeGen.Platform.hs+    autogen/Config.hs+    autogen/GHCConstantsHaskellExports.hs+    autogen/GHCConstantsHaskellType.hs+    autogen/GHCConstantsHaskellWrappers.hs+    autogen/*.hs-incl+++Flag terminfo+    Description: Build GHC with terminfo support on non-Windows platforms.+    Default: True+    Manual: True++Flag buildable+    Description: Make this package buildable (highly experimental)+    Default: False+    Manual: True++Library+    -- The generated code in autogen/ has been generated for a linux/x86_64 target+    -- So everything else is definitely not working...+    if !(os(linux) && arch(x86_64) && impl(ghc == 8.2.1))+      build-depends: base<0++    -- ...while this package may in theory allow to reinstall lib:ghc+    -- under very limited constraints, this most likely could fail in+    -- weird ways (e.g. mismatched tag numbers, GHC panics, etc), and+    -- since cabal doesn't mark this package as non-upgradable, we+    -- declare this package out of reach to the cabal solver by default+    -- here+    if !flag(buildable)+      build-depends: base<0++    Default-Language: Haskell2010+    Exposed: False++    Build-Depends: base       == 4.10.*,+                   deepseq    >= 1.4 && < 1.5,+                   directory  >= 1   && < 1.4,+                   process    >= 1   && < 1.7,+                   bytestring >= 0.9 && < 0.11,+                   binary     == 0.8.*,+                   time       >= 1.4 && < 1.9,+                   containers >= 0.5 && < 0.6,+                   array      >= 0.1 && < 0.6,+                   filepath   >= 1   && < 1.5,+                   template-haskell == 2.12.*,+                   hpc        == 0.6.*,+                   transformers == 0.5.*,+                   ghc-boot   == 8.2.1,+                   ghc-boot-th == 8.2.1,+                   ghci == 8.2.1,+                   hoopl      >= 3.10.2 && < 3.11++    if os(windows)+        Build-Depends: Win32  >= 2.3 && < 2.6+    else+        if flag(terminfo)+            Build-Depends: terminfo == 0.4.*+        Build-Depends: unix   == 2.7.*++    build-tools: alex ^>= 3.2.1, happy ^>= 1.19.5++    GHC-Options: -Wall -fno-warn-name-shadowing++    -- if flag(ghci)+    --     CPP-Options: -DGHCI+    --     Include-Dirs: ../rts/dist/build++    Other-Extensions:+        BangPatterns+        CPP+        DataKinds+        DeriveDataTypeable+        DeriveFoldable+        DeriveFunctor+        DeriveTraversable+        DisambiguateRecordFields+        ExplicitForAll+        FlexibleContexts+        FlexibleInstances+        GADTs+        GeneralizedNewtypeDeriving+        MagicHash+        MultiParamTypeClasses+        NamedFieldPuns+        NondecreasingIndentation+        RankNTypes+        RecordWildCards+        ScopedTypeVariables+        StandaloneDeriving+        Trustworthy+        TupleSections+        TypeFamilies+        TypeSynonymInstances+        UnboxedTuples+        UndecidableInstances++    Include-Dirs: . parser utils++    -- We need to set the unit id to ghc (without a version number)+    -- as it's magic.  But we can't set it for old versions of GHC (e.g.+    -- when bootstrapping) because those versions of GHC don't understand+    -- that GHC is wired-in.+    if impl ( ghc >= 7.11 )+        GHC-Options: -this-unit-id ghc+    else+        if impl( ghc >= 7.9 )+            GHC-Options: -this-package-key ghc++    cpp-options: -DSTAGE=2++    Install-Includes: HsVersions.h, ghc_boot_platform.h++    c-sources:+        parser/cutils.c+        ghci/keepCAFsForGHCi.c+        cbits/genSym.c++    hs-source-dirs:+        autogen++    include-dirs:+        autogen++    hs-source-dirs:+        backpack+        basicTypes+        cmm+        codeGen+        coreSyn+        deSugar+        ghci+        hsSyn+        iface+        llvmGen+        main+        nativeGen+        parser+        prelude+        profiling+        rename+        simplCore+        simplStg+        specialise+        stgSyn+        stranal+        typecheck+        types+        utils+        vectorise++    Exposed-Modules:+        DriverBkp+        BkpSyn+        NameShape+        RnModIface+        Avail+        BasicTypes+        ConLike+        DataCon+        PatSyn+        Demand+        Debug+        Exception+        FieldLabel+        GhcMonad+        Hooks+        Id+        IdInfo+        Lexeme+        Literal+        Llvm+        Llvm.AbsSyn+        Llvm.MetaData+        Llvm.PpLlvm+        Llvm.Types+        LlvmCodeGen+        LlvmCodeGen.Base+        LlvmCodeGen.CodeGen+        LlvmCodeGen.Data+        LlvmCodeGen.Ppr+        LlvmCodeGen.Regs+        LlvmMangler+        MkId+        Module+        Name+        NameEnv+        NameSet+        OccName+        RdrName+        NameCache+        SrcLoc+        UniqSupply+        Unique+        Var+        VarEnv+        VarSet+        UnVarGraph+        BlockId+        CLabel+        Cmm+        CmmBuildInfoTables+        CmmPipeline+        CmmCallConv+        CmmCommonBlockElim+        CmmImplementSwitchPlans+        CmmContFlowOpt+        CmmExpr+        CmmInfo+        CmmLex+        CmmLint+        CmmLive+        CmmMachOp+        CmmMonad+        CmmSwitch+        CmmNode+        CmmOpt+        CmmParse+        CmmProcPoint+        CmmSink+        CmmType+        CmmUtils+        CmmLayoutStack+        MkGraph+        PprBase+        PprC+        PprCmm+        PprCmmDecl+        PprCmmExpr+        Bitmap+        CodeGen.Platform+        CodeGen.Platform.ARM+        CodeGen.Platform.ARM64+        CodeGen.Platform.NoRegs+        CodeGen.Platform.PPC+        CodeGen.Platform.PPC_Darwin+        CodeGen.Platform.SPARC+        CodeGen.Platform.X86+        CodeGen.Platform.X86_64+        CgUtils+        StgCmm+        StgCmmBind+        StgCmmClosure+        StgCmmCon+        StgCmmEnv+        StgCmmExpr+        StgCmmForeign+        StgCmmHeap+        StgCmmHpc+        StgCmmArgRep+        StgCmmLayout+        StgCmmMonad+        StgCmmPrim+        StgCmmProf+        StgCmmTicky+        StgCmmUtils+        StgCmmExtCode+        SMRep+        CoreArity+        CoreFVs+        CoreLint+        CorePrep+        CoreSubst+        CoreOpt+        CoreSyn+        TrieMap+        CoreTidy+        CoreUnfold+        CoreUtils+        CoreSeq+        CoreStats+        MkCore+        PprCore+        PmExpr+        TmOracle+        Check+        Coverage+        Desugar+        DsArrows+        DsBinds+        DsCCall+        DsExpr+        DsForeign+        DsGRHSs+        DsListComp+        DsMonad+        DsUsage+        DsUtils+        Match+        MatchCon+        MatchLit+        HsBinds+        HsDecls+        HsDoc+        HsExpr+        HsImpExp+        HsLit+        PlaceHolder+        HsPat+        HsSyn+        HsTypes+        HsUtils+        HsDumpAst+        BinIface+        BinFingerprint+        BuildTyCl+        IfaceEnv+        IfaceSyn+        IfaceType+        ToIface+        LoadIface+        MkIface+        TcIface+        FlagChecker+        Annotations+        CmdLineParser+        CodeOutput+        Config+        Constants+        DriverMkDepend+        DriverPhases+        PipelineMonad+        DriverPipeline+        DynFlags+        ErrUtils+        Finder+        GHC+        GhcMake+        GhcPlugins+        DynamicLoading+        HeaderInfo+        HscMain+        HscStats+        HscTypes+        InteractiveEval+        InteractiveEvalTypes+        PackageConfig+        Packages+        PlatformConstants+        Plugins+        TcPluginM+        PprTyThing+        StaticPtrTable+        SysTools+        SysTools.Terminal+        Elf+        TidyPgm+        Ctype+        HaddockUtils+        Lexer+        OptCoercion+        Parser+        RdrHsSyn+        ApiAnnotation+        ForeignCall+        KnownUniques+        PrelInfo+        PrelNames+        PrelRules+        PrimOp+        TysPrim+        TysWiredIn+        CostCentre+        ProfInit+        SCCfinal+        RnBinds+        RnEnv+        RnExpr+        RnHsDoc+        RnNames+        RnPat+        RnSource+        RnSplice+        RnTypes+        CoreMonad+        CSE+        FloatIn+        FloatOut+        LiberateCase+        OccurAnal+        SAT+        SetLevels+        SimplCore+        SimplEnv+        SimplMonad+        SimplUtils+        Simplify+        SimplStg+        StgStats+        StgCse+        UnariseStg+        RepType+        Rules+        SpecConstr+        Specialise+        CoreToStg+        StgLint+        StgSyn+        CallArity+        DmdAnal+        WorkWrap+        WwLib+        FamInst+        Inst+        TcAnnotations+        TcArrows+        TcBinds+        TcSigs+        TcClassDcl+        TcDefaults+        TcDeriv+        TcDerivInfer+        TcDerivUtils+        TcEnv+        TcExpr+        TcForeign+        TcGenDeriv+        TcGenFunctor+        TcGenGenerics+        TcHsSyn+        TcHsType+        TcInstDcls+        TcMType+        TcValidity+        TcMatches+        TcPat+        TcPatSyn+        TcRnDriver+        TcBackpack+        TcRnExports+        TcRnMonad+        TcRnTypes+        TcRules+        TcSimplify+        TcErrors+        TcTyClsDecls+        TcTyDecls+        TcTypeable+        TcType+        TcEvidence+        TcUnify+        TcInteract+        TcCanonical+        TcFlatten+        TcSMonad+        TcTypeNats+        TcSplice+        Class+        Coercion+        DsMeta+        THNames+        FamInstEnv+        FunDeps+        InstEnv+        TyCon+        CoAxiom+        Kind+        Type+        TyCoRep+        Unify+        Bag+        Binary+        BooleanFormula+        BufWrite+        Digraph+        Encoding+        FastFunctions+        FastMutInt+        FastString+        FastStringEnv+        Fingerprint+        FiniteMap+        FV+        GraphBase+        GraphColor+        GraphOps+        GraphPpr+        IOEnv+        Json+        ListSetOps+        ListT+        Maybes+        MonadUtils+        OrdList+        Outputable+        Pair+        Panic+        PprColour+        Pretty+        State+        Stream+        StringBuffer+        UniqDFM+        UniqDSet+        UniqFM+        UniqSet+        Util+        Vectorise.Builtins.Base+        Vectorise.Builtins.Initialise+        Vectorise.Builtins+        Vectorise.Monad.Base+        Vectorise.Monad.Naming+        Vectorise.Monad.Local+        Vectorise.Monad.Global+        Vectorise.Monad.InstEnv+        Vectorise.Monad+        Vectorise.Utils.Base+        Vectorise.Utils.Closure+        Vectorise.Utils.Hoisting+        Vectorise.Utils.PADict+        Vectorise.Utils.Poly+        Vectorise.Utils+        Vectorise.Generic.Description+        Vectorise.Generic.PAMethods+        Vectorise.Generic.PADict+        Vectorise.Generic.PData+        Vectorise.Type.Env+        Vectorise.Type.Type+        Vectorise.Type.TyConDecl+        Vectorise.Type.Classify+        Vectorise.Convert+        Vectorise.Vect+        Vectorise.Var+        Vectorise.Env+        Vectorise.Exp+        Vectorise+        Hoopl.Dataflow+        Hoopl+--        CgInfoTbls used in ghci/DebuggerUtils+--        CgHeapery  mkVirtHeapOffsets used in ghci++    Exposed-Modules:+            AsmCodeGen+            TargetReg+            NCGMonad+            Instruction+            Format+            Reg+            RegClass+            PIC+            Platform+            CPrim+            X86.Regs+            X86.RegInfo+            X86.Instr+            X86.Cond+            X86.Ppr+            X86.CodeGen+            PPC.Regs+            PPC.RegInfo+            PPC.Instr+            PPC.Cond+            PPC.Ppr+            PPC.CodeGen+            SPARC.Base+            SPARC.Regs+            SPARC.Imm+            SPARC.AddrMode+            SPARC.Cond+            SPARC.Instr+            SPARC.Stack+            SPARC.ShortcutJump+            SPARC.Ppr+            SPARC.CodeGen+            SPARC.CodeGen.Amode+            SPARC.CodeGen.Base+            SPARC.CodeGen.CondCode+            SPARC.CodeGen.Gen32+            SPARC.CodeGen.Gen64+            SPARC.CodeGen.Sanity+            SPARC.CodeGen.Expand+            RegAlloc.Liveness+            RegAlloc.Graph.Main+            RegAlloc.Graph.Stats+            RegAlloc.Graph.ArchBase+            RegAlloc.Graph.ArchX86+            RegAlloc.Graph.Coalesce+            RegAlloc.Graph.Spill+            RegAlloc.Graph.SpillClean+            RegAlloc.Graph.SpillCost+            RegAlloc.Graph.TrivColorable+            RegAlloc.Linear.Main+            RegAlloc.Linear.JoinToTargets+            RegAlloc.Linear.State+            RegAlloc.Linear.Stats+            RegAlloc.Linear.FreeRegs+            RegAlloc.Linear.StackMap+            RegAlloc.Linear.Base+            RegAlloc.Linear.X86.FreeRegs+            RegAlloc.Linear.X86_64.FreeRegs+            RegAlloc.Linear.PPC.FreeRegs+            RegAlloc.Linear.SPARC.FreeRegs+            Dwarf+            Dwarf.Types+            Dwarf.Constants+            Convert+            ByteCodeTypes+            ByteCodeAsm+            ByteCodeGen+            ByteCodeInstr+            ByteCodeItbls+            ByteCodeLink+            Debugger+            Linker+            RtClosureInspect+            DebuggerUtils+            GHCi++    -- ghc:Serialized moved to ghc-boot:GHC.Serialized.  So for+    -- compatibility with GHC 7.10 and earlier, we reexport it+    -- under the old name.+    reexported-modules:+        ghc-boot:GHC.Serialized as Serialized
+ ghci/ByteCodeAsm.hs view
@@ -0,0 +1,538 @@+{-# LANGUAGE BangPatterns, CPP, MagicHash, RecordWildCards #-}+{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}+--+--  (c) The University of Glasgow 2002-2006+--++-- | ByteCodeLink: Bytecode assembler and linker+module ByteCodeAsm (+        assembleBCOs, assembleOneBCO,++        bcoFreeNames,+        SizedSeq, sizeSS, ssElts,+        iNTERP_STACK_CHECK_THRESH+  ) where++#include "HsVersions.h"++import ByteCodeInstr+import ByteCodeItbls+import ByteCodeTypes+import GHCi.RemoteTypes+import GHCi++import HscTypes+import Name+import NameSet+import Literal+import TyCon+import FastString+import StgCmmLayout     ( ArgRep(..) )+import SMRep+import DynFlags+import Outputable+import Platform+import Util+import Unique+import UniqDSet++-- From iserv+import SizedSeq++import Control.Monad+import Control.Monad.ST ( runST )+import Control.Monad.Trans.Class+import Control.Monad.Trans.State.Strict++import Data.Array.MArray++import qualified Data.Array.Unboxed as Array+import Data.Array.Base  ( UArray(..) )++import Data.Array.Unsafe( castSTUArray )++import Foreign+import Data.Char        ( ord )+import Data.List+import Data.Map (Map)+import Data.Maybe (fromMaybe)+import qualified Data.Map as Map++-- -----------------------------------------------------------------------------+-- Unlinked BCOs++-- CompiledByteCode represents the result of byte-code+-- compiling a bunch of functions and data types++-- | Finds external references.  Remember to remove the names+-- defined by this group of BCOs themselves+bcoFreeNames :: UnlinkedBCO -> UniqDSet Name+bcoFreeNames bco+  = bco_refs bco `uniqDSetMinusUniqSet` mkNameSet [unlinkedBCOName bco]+  where+    bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs)+        = unionManyUniqDSets (+             mkUniqDSet [ n | BCOPtrName n <- ssElts ptrs ] :+             mkUniqDSet [ n | BCONPtrItbl n <- ssElts nonptrs ] :+             map bco_refs [ bco | BCOPtrBCO bco <- ssElts ptrs ]+          )++-- -----------------------------------------------------------------------------+-- The bytecode assembler++-- The object format for bytecodes is: 16 bits for the opcode, and 16+-- for each field -- so the code can be considered a sequence of+-- 16-bit ints.  Each field denotes either a stack offset or number of+-- items on the stack (eg SLIDE), and index into the pointer table (eg+-- PUSH_G), an index into the literal table (eg PUSH_I/D/L), or a+-- bytecode address in this BCO.++-- Top level assembler fn.+assembleBCOs+  :: HscEnv -> [ProtoBCO Name] -> [TyCon] -> [RemotePtr ()]+  -> Maybe ModBreaks+  -> IO CompiledByteCode+assembleBCOs hsc_env proto_bcos tycons top_strs modbreaks = do+  itblenv <- mkITbls hsc_env tycons+  bcos    <- mapM (assembleBCO (hsc_dflags hsc_env)) proto_bcos+  (bcos',ptrs) <- mallocStrings hsc_env bcos+  return CompiledByteCode+    { bc_bcos = bcos'+    , bc_itbls =  itblenv+    , bc_ffis = concat (map protoBCOFFIs proto_bcos)+    , bc_strs = top_strs ++ ptrs+    , bc_breaks = modbreaks+    }++-- Find all the literal strings and malloc them together.  We want to+-- do this because:+--+--  a) It should be done when we compile the module, not each time we relink it+--  b) For -fexternal-interpreter It's more efficient to malloc the strings+--     as a single batch message, especially when compiling in parallel.+--+mallocStrings :: HscEnv -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()])+mallocStrings hsc_env ulbcos = do+  let bytestrings = reverse (execState (mapM_ collect ulbcos) [])+  ptrs <- iservCmd hsc_env (MallocStrings bytestrings)+  return (evalState (mapM splice ulbcos) ptrs, ptrs)+ where+  splice bco@UnlinkedBCO{..} = do+    lits <- mapM spliceLit unlinkedBCOLits+    ptrs <- mapM splicePtr unlinkedBCOPtrs+    return bco { unlinkedBCOLits = lits, unlinkedBCOPtrs = ptrs }++  spliceLit (BCONPtrStr _) = do+    (RemotePtr p : rest) <- get+    put rest+    return (BCONPtrWord (fromIntegral p))+  spliceLit other = return other++  splicePtr (BCOPtrBCO bco) = BCOPtrBCO <$> splice bco+  splicePtr other = return other++  collect UnlinkedBCO{..} = do+    mapM_ collectLit unlinkedBCOLits+    mapM_ collectPtr unlinkedBCOPtrs++  collectLit (BCONPtrStr bs) = do+    strs <- get+    put (bs:strs)+  collectLit _ = return ()++  collectPtr (BCOPtrBCO bco) = collect bco+  collectPtr _ = return ()+++assembleOneBCO :: HscEnv -> ProtoBCO Name -> IO UnlinkedBCO+assembleOneBCO hsc_env pbco = do+  ubco <- assembleBCO (hsc_dflags hsc_env) pbco+  ([ubco'], _ptrs) <- mallocStrings hsc_env [ubco]+  return ubco'++assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO+assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = do+  -- pass 1: collect up the offsets of the local labels.+  let asm = mapM_ (assembleI dflags) instrs++      initial_offset = 0++      -- Jump instructions are variable-sized, there are long and short variants+      -- depending on the magnitude of the offset.  However, we can't tell what+      -- size instructions we will need until we have calculated the offsets of+      -- the labels, which depends on the size of the instructions...  So we+      -- first create the label environment assuming that all jumps are short,+      -- and if the final size is indeed small enough for short jumps, we are+      -- done.  Otherwise, we repeat the calculation, and we force all jumps in+      -- this BCO to be long.+      (n_insns0, lbl_map0) = inspectAsm dflags False initial_offset asm+      ((n_insns, lbl_map), long_jumps)+        | isLarge n_insns0 = (inspectAsm dflags True initial_offset asm, True)+        | otherwise = ((n_insns0, lbl_map0), False)++      env :: Word16 -> Word+      env lbl = fromMaybe+        (pprPanic "assembleBCO.findLabel" (ppr lbl))+        (Map.lookup lbl lbl_map)++  -- pass 2: run assembler and generate instructions, literals and pointers+  let initial_state = (emptySS, emptySS, emptySS)+  (final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm dflags long_jumps env asm++  -- precomputed size should be equal to final size+  ASSERT(n_insns == sizeSS final_insns) return ()++  let asm_insns = ssElts final_insns+      insns_arr = Array.listArray (0, fromIntegral n_insns - 1) asm_insns+      bitmap_arr = mkBitmapArray bsize bitmap+      ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr final_lits final_ptrs++  -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive+  -- objects, since they might get run too early.  Disable this until+  -- we figure out what to do.+  -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced))++  return ul_bco++mkBitmapArray :: Word16 -> [StgWord] -> UArray Int Word+-- Here the return type must be an array of Words, not StgWords,+-- because the underlying ByteArray# will end up as a component+-- of a BCO object.+mkBitmapArray bsize bitmap+  = Array.listArray (0, length bitmap) $+      fromIntegral bsize : map (fromInteger . fromStgWord) bitmap++-- instrs nonptrs ptrs+type AsmState = (SizedSeq Word16,+                 SizedSeq BCONPtr,+                 SizedSeq BCOPtr)++data Operand+  = Op Word+  | SmallOp Word16+  | LabelOp Word16+-- (unused)  | LargeOp Word++data Assembler a+  = AllocPtr (IO BCOPtr) (Word -> Assembler a)+  | AllocLit [BCONPtr] (Word -> Assembler a)+  | AllocLabel Word16 (Assembler a)+  | Emit Word16 [Operand] (Assembler a)+  | NullAsm a++instance Functor Assembler where+    fmap = liftM++instance Applicative Assembler where+    pure = NullAsm+    (<*>) = ap++instance Monad Assembler where+  NullAsm x >>= f = f x+  AllocPtr p k >>= f = AllocPtr p (k >=> f)+  AllocLit l k >>= f = AllocLit l (k >=> f)+  AllocLabel lbl k >>= f = AllocLabel lbl (k >>= f)+  Emit w ops k >>= f = Emit w ops (k >>= f)++ioptr :: IO BCOPtr -> Assembler Word+ioptr p = AllocPtr p return++ptr :: BCOPtr -> Assembler Word+ptr = ioptr . return++lit :: [BCONPtr] -> Assembler Word+lit l = AllocLit l return++label :: Word16 -> Assembler ()+label w = AllocLabel w (return ())++emit :: Word16 -> [Operand] -> Assembler ()+emit w ops = Emit w ops (return ())++type LabelEnv = Word16 -> Word++largeOp :: Bool -> Operand -> Bool+largeOp long_jumps op = case op of+   SmallOp _ -> False+   Op w      -> isLarge w+   LabelOp _ -> long_jumps+-- LargeOp _ -> True++runAsm :: DynFlags -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a+runAsm dflags long_jumps e = go+  where+    go (NullAsm x) = return x+    go (AllocPtr p_io k) = do+      p <- lift p_io+      w <- state $ \(st_i0,st_l0,st_p0) ->+        let st_p1 = addToSS st_p0 p+        in (sizeSS st_p0, (st_i0,st_l0,st_p1))+      go $ k w+    go (AllocLit lits k) = do+      w <- state $ \(st_i0,st_l0,st_p0) ->+        let st_l1 = addListToSS st_l0 lits+        in (sizeSS st_l0, (st_i0,st_l1,st_p0))+      go $ k w+    go (AllocLabel _ k) = go k+    go (Emit w ops k) = do+      let largeOps = any (largeOp long_jumps) ops+          opcode+            | largeOps = largeArgInstr w+            | otherwise = w+          words = concatMap expand ops+          expand (SmallOp w) = [w]+          expand (LabelOp w) = expand (Op (e w))+          expand (Op w) = if largeOps then largeArg dflags w else [fromIntegral w]+--        expand (LargeOp w) = largeArg dflags w+      state $ \(st_i0,st_l0,st_p0) ->+        let st_i1 = addListToSS st_i0 (opcode : words)+        in ((), (st_i1,st_l0,st_p0))+      go k++type LabelEnvMap = Map Word16 Word++data InspectState = InspectState+  { instrCount :: !Word+  , ptrCount :: !Word+  , litCount :: !Word+  , lblEnv :: LabelEnvMap+  }++inspectAsm :: DynFlags -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)+inspectAsm dflags long_jumps initial_offset+  = go (InspectState initial_offset 0 0 Map.empty)+  where+    go s (NullAsm _) = (instrCount s, lblEnv s)+    go s (AllocPtr _ k) = go (s { ptrCount = n + 1 }) (k n)+      where n = ptrCount s+    go s (AllocLit ls k) = go (s { litCount = n + genericLength ls }) (k n)+      where n = litCount s+    go s (AllocLabel lbl k) = go s' k+      where s' = s { lblEnv = Map.insert lbl (instrCount s) (lblEnv s) }+    go s (Emit _ ops k) = go s' k+      where+        s' = s { instrCount = instrCount s + size }+        size = sum (map count ops) + 1+        largeOps = any (largeOp long_jumps) ops+        count (SmallOp _) = 1+        count (LabelOp _) = count (Op 0)+        count (Op _) = if largeOps then largeArg16s dflags else 1+--      count (LargeOp _) = largeArg16s dflags++-- Bring in all the bci_ bytecode constants.+#include "rts/Bytecodes.h"++largeArgInstr :: Word16 -> Word16+largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci++largeArg :: DynFlags -> Word -> [Word16]+largeArg dflags w+ | wORD_SIZE_IN_BITS dflags == 64+           = [fromIntegral (w `shiftR` 48),+              fromIntegral (w `shiftR` 32),+              fromIntegral (w `shiftR` 16),+              fromIntegral w]+ | wORD_SIZE_IN_BITS dflags == 32+           = [fromIntegral (w `shiftR` 16),+              fromIntegral w]+ | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?"++largeArg16s :: DynFlags -> Word+largeArg16s dflags | wORD_SIZE_IN_BITS dflags == 64 = 4+                   | otherwise                      = 2++assembleI :: DynFlags+          -> BCInstr+          -> Assembler ()+assembleI dflags i = case i of+  STKCHECK n               -> emit bci_STKCHECK [Op n]+  PUSH_L o1                -> emit bci_PUSH_L [SmallOp o1]+  PUSH_LL o1 o2            -> emit bci_PUSH_LL [SmallOp o1, SmallOp o2]+  PUSH_LLL o1 o2 o3        -> emit bci_PUSH_LLL [SmallOp o1, SmallOp o2, SmallOp o3]+  PUSH_G nm                -> do p <- ptr (BCOPtrName nm)+                                 emit bci_PUSH_G [Op p]+  PUSH_PRIMOP op           -> do p <- ptr (BCOPtrPrimOp op)+                                 emit bci_PUSH_G [Op p]+  PUSH_BCO proto           -> do let ul_bco = assembleBCO dflags proto+                                 p <- ioptr (liftM BCOPtrBCO ul_bco)+                                 emit bci_PUSH_G [Op p]+  PUSH_ALTS proto          -> do let ul_bco = assembleBCO dflags proto+                                 p <- ioptr (liftM BCOPtrBCO ul_bco)+                                 emit bci_PUSH_ALTS [Op p]+  PUSH_ALTS_UNLIFTED proto pk+                           -> do let ul_bco = assembleBCO dflags proto+                                 p <- ioptr (liftM BCOPtrBCO ul_bco)+                                 emit (push_alts pk) [Op p]+  PUSH_UBX lit nws         -> do np <- literal lit+                                 emit bci_PUSH_UBX [Op np, SmallOp nws]++  PUSH_APPLY_N             -> emit bci_PUSH_APPLY_N []+  PUSH_APPLY_V             -> emit bci_PUSH_APPLY_V []+  PUSH_APPLY_F             -> emit bci_PUSH_APPLY_F []+  PUSH_APPLY_D             -> emit bci_PUSH_APPLY_D []+  PUSH_APPLY_L             -> emit bci_PUSH_APPLY_L []+  PUSH_APPLY_P             -> emit bci_PUSH_APPLY_P []+  PUSH_APPLY_PP            -> emit bci_PUSH_APPLY_PP []+  PUSH_APPLY_PPP           -> emit bci_PUSH_APPLY_PPP []+  PUSH_APPLY_PPPP          -> emit bci_PUSH_APPLY_PPPP []+  PUSH_APPLY_PPPPP         -> emit bci_PUSH_APPLY_PPPPP []+  PUSH_APPLY_PPPPPP        -> emit bci_PUSH_APPLY_PPPPPP []++  SLIDE     n by           -> emit bci_SLIDE [SmallOp n, SmallOp by]+  ALLOC_AP  n              -> emit bci_ALLOC_AP [SmallOp n]+  ALLOC_AP_NOUPD n         -> emit bci_ALLOC_AP_NOUPD [SmallOp n]+  ALLOC_PAP arity n        -> emit bci_ALLOC_PAP [SmallOp arity, SmallOp n]+  MKAP      off sz         -> emit bci_MKAP [SmallOp off, SmallOp sz]+  MKPAP     off sz         -> emit bci_MKPAP [SmallOp off, SmallOp sz]+  UNPACK    n              -> emit bci_UNPACK [SmallOp n]+  PACK      dcon sz        -> do itbl_no <- lit [BCONPtrItbl (getName dcon)]+                                 emit bci_PACK [Op itbl_no, SmallOp sz]+  LABEL     lbl            -> label lbl+  TESTLT_I  i l            -> do np <- int i+                                 emit bci_TESTLT_I [Op np, LabelOp l]+  TESTEQ_I  i l            -> do np <- int i+                                 emit bci_TESTEQ_I [Op np, LabelOp l]+  TESTLT_W  w l            -> do np <- word w+                                 emit bci_TESTLT_W [Op np, LabelOp l]+  TESTEQ_W  w l            -> do np <- word w+                                 emit bci_TESTEQ_W [Op np, LabelOp l]+  TESTLT_F  f l            -> do np <- float f+                                 emit bci_TESTLT_F [Op np, LabelOp l]+  TESTEQ_F  f l            -> do np <- float f+                                 emit bci_TESTEQ_F [Op np, LabelOp l]+  TESTLT_D  d l            -> do np <- double d+                                 emit bci_TESTLT_D [Op np, LabelOp l]+  TESTEQ_D  d l            -> do np <- double d+                                 emit bci_TESTEQ_D [Op np, LabelOp l]+  TESTLT_P  i l            -> emit bci_TESTLT_P [SmallOp i, LabelOp l]+  TESTEQ_P  i l            -> emit bci_TESTEQ_P [SmallOp i, LabelOp l]+  CASEFAIL                 -> emit bci_CASEFAIL []+  SWIZZLE   stkoff n       -> emit bci_SWIZZLE [SmallOp stkoff, SmallOp n]+  JMP       l              -> emit bci_JMP [LabelOp l]+  ENTER                    -> emit bci_ENTER []+  RETURN                   -> emit bci_RETURN []+  RETURN_UBX rep           -> emit (return_ubx rep) []+  CCALL off m_addr i       -> do np <- addr m_addr+                                 emit bci_CCALL [SmallOp off, Op np, SmallOp i]+  BRK_FUN index uniq cc    -> do p1 <- ptr BCOPtrBreakArray+                                 q <- int (getKey uniq)+                                 np <- addr cc+                                 emit bci_BRK_FUN [Op p1, SmallOp index,+                                                   Op q, Op np]++  where+    literal (MachLabel fs (Just sz) _)+     | platformOS (targetPlatform dflags) == OSMinGW32+         = litlabel (appendFS fs (mkFastString ('@':show sz)))+     -- On Windows, stdcall labels have a suffix indicating the no. of+     -- arg words, e.g. foo@8.  testcase: ffi012(ghci)+    literal (MachLabel fs _ _) = litlabel fs+    literal (MachWord w)       = int (fromIntegral w)+    literal (MachInt j)        = int (fromIntegral j)+    literal MachNullAddr       = int 0+    literal (MachFloat r)      = float (fromRational r)+    literal (MachDouble r)     = double (fromRational r)+    literal (MachChar c)       = int (ord c)+    literal (MachInt64 ii)     = int64 (fromIntegral ii)+    literal (MachWord64 ii)    = int64 (fromIntegral ii)+    literal (MachStr bs)       = lit [BCONPtrStr bs]+       -- MachStr requires a zero-terminator when emitted+    literal LitInteger{}       = panic "ByteCodeAsm.literal: LitInteger"++    litlabel fs = lit [BCONPtrLbl fs]+    addr (RemotePtr a) = words [fromIntegral a]+    float = words . mkLitF+    double = words . mkLitD dflags+    int = words . mkLitI+    int64 = words . mkLitI64 dflags+    words ws = lit (map BCONPtrWord ws)+    word w = words [w]++isLarge :: Word -> Bool+isLarge n = n > 65535++push_alts :: ArgRep -> Word16+push_alts V   = bci_PUSH_ALTS_V+push_alts P   = bci_PUSH_ALTS_P+push_alts N   = bci_PUSH_ALTS_N+push_alts L   = bci_PUSH_ALTS_L+push_alts F   = bci_PUSH_ALTS_F+push_alts D   = bci_PUSH_ALTS_D+push_alts V16 = error "push_alts: vector"+push_alts V32 = error "push_alts: vector"+push_alts V64 = error "push_alts: vector"++return_ubx :: ArgRep -> Word16+return_ubx V   = bci_RETURN_V+return_ubx P   = bci_RETURN_P+return_ubx N   = bci_RETURN_N+return_ubx L   = bci_RETURN_L+return_ubx F   = bci_RETURN_F+return_ubx D   = bci_RETURN_D+return_ubx V16 = error "return_ubx: vector"+return_ubx V32 = error "return_ubx: vector"+return_ubx V64 = error "return_ubx: vector"++-- Make lists of host-sized words for literals, so that when the+-- words are placed in memory at increasing addresses, the+-- bit pattern is correct for the host's word size and endianness.+mkLitI   ::             Int    -> [Word]+mkLitF   ::             Float  -> [Word]+mkLitD   :: DynFlags -> Double -> [Word]+mkLitI64 :: DynFlags -> Int64  -> [Word]++mkLitF f+   = runST (do+        arr <- newArray_ ((0::Int),0)+        writeArray arr 0 f+        f_arr <- castSTUArray arr+        w0 <- readArray f_arr 0+        return [w0 :: Word]+     )++mkLitD dflags d+   | wORD_SIZE dflags == 4+   = runST (do+        arr <- newArray_ ((0::Int),1)+        writeArray arr 0 d+        d_arr <- castSTUArray arr+        w0 <- readArray d_arr 0+        w1 <- readArray d_arr 1+        return [w0 :: Word, w1]+     )+   | wORD_SIZE dflags == 8+   = runST (do+        arr <- newArray_ ((0::Int),0)+        writeArray arr 0 d+        d_arr <- castSTUArray arr+        w0 <- readArray d_arr 0+        return [w0 :: Word]+     )+   | otherwise+   = panic "mkLitD: Bad wORD_SIZE"++mkLitI64 dflags ii+   | wORD_SIZE dflags == 4+   = runST (do+        arr <- newArray_ ((0::Int),1)+        writeArray arr 0 ii+        d_arr <- castSTUArray arr+        w0 <- readArray d_arr 0+        w1 <- readArray d_arr 1+        return [w0 :: Word,w1]+     )+   | wORD_SIZE dflags == 8+   = runST (do+        arr <- newArray_ ((0::Int),0)+        writeArray arr 0 ii+        d_arr <- castSTUArray arr+        w0 <- readArray d_arr 0+        return [w0 :: Word]+     )+   | otherwise+   = panic "mkLitI64: Bad wORD_SIZE"++mkLitI i = [fromIntegral i :: Word]++iNTERP_STACK_CHECK_THRESH :: Int+iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH
+ ghci/ByteCodeGen.hs view
@@ -0,0 +1,1798 @@+{-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-}+{-# OPTIONS_GHC -fprof-auto-top #-}+--+--  (c) The University of Glasgow 2002-2006+--++-- | ByteCodeGen: Generate bytecode from Core+module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where++#include "HsVersions.h"++import ByteCodeInstr+import ByteCodeAsm+import ByteCodeTypes++import GHCi+import GHCi.FFI+import GHCi.RemoteTypes+import BasicTypes+import DynFlags+import Outputable+import Platform+import Name+import MkId+import Id+import ForeignCall+import HscTypes+import CoreUtils+import CoreSyn+import PprCore+import Literal+import PrimOp+import CoreFVs+import Type+import RepType+import Kind            ( isLiftedTypeKind )+import DataCon+import TyCon+import Util+import VarSet+import TysPrim+import ErrUtils+import Unique+import FastString+import Panic+import StgCmmLayout     ( ArgRep(..), toArgRep, argRepSizeW )+import SMRep+import Bitmap+import OrdList+import Maybes+import VarEnv++import Data.List+import Foreign+import Control.Monad+import Data.Char++import UniqSupply+import Module+import Control.Arrow ( second )++import Control.Exception+import Data.Array+import Data.ByteString (ByteString)+import Data.Map (Map)+import Data.IntMap (IntMap)+import qualified Data.Map as Map+import qualified Data.IntMap as IntMap+import qualified FiniteMap as Map+import Data.Ord+#if MIN_VERSION_base(4,9,0)+import GHC.Stack.CCS+#else+import GHC.Stack as GHC.Stack.CCS+#endif++-- -----------------------------------------------------------------------------+-- Generating byte code for a complete module++byteCodeGen :: HscEnv+            -> Module+            -> CoreProgram+            -> [TyCon]+            -> Maybe ModBreaks+            -> IO CompiledByteCode+byteCodeGen hsc_env this_mod binds tycs mb_modBreaks+   = withTiming (pure dflags)+                (text "ByteCodeGen"<+>brackets (ppr this_mod))+                (const ()) $ do+        -- Split top-level binds into strings and others.+        -- See Note [generating code for top-level string literal bindings].+        let (strings, flatBinds) = splitEithers $ do+                (bndr, rhs) <- flattenBinds binds+                return $ case rhs of+                    Lit (MachStr str) -> Left (bndr, str)+                    _ -> Right (bndr, simpleFreeVars rhs)+        stringPtrs <- allocateTopStrings hsc_env strings++        us <- mkSplitUniqSupply 'y'+        (BcM_State{..}, proto_bcos) <-+           runBc hsc_env us this_mod mb_modBreaks (mkVarEnv stringPtrs) $+             mapM schemeTopBind flatBinds++        when (notNull ffis)+             (panic "ByteCodeGen.byteCodeGen: missing final emitBc?")++        dumpIfSet_dyn dflags Opt_D_dump_BCOs+           "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))++        cbc <- assembleBCOs hsc_env proto_bcos tycs (map snd stringPtrs)+          (case modBreaks of+             Nothing -> Nothing+             Just mb -> Just mb{ modBreaks_breakInfo = breakInfo })++        -- Squash space leaks in the CompiledByteCode.  This is really+        -- important, because when loading a set of modules into GHCi+        -- we don't touch the CompiledByteCode until the end when we+        -- do linking.  Forcing out the thunks here reduces space+        -- usage by more than 50% when loading a large number of+        -- modules.+        evaluate (seqCompiledByteCode cbc)++        return cbc++  where dflags = hsc_dflags hsc_env++allocateTopStrings+  :: HscEnv+  -> [(Id, ByteString)]+  -> IO [(Var, RemotePtr ())]+allocateTopStrings hsc_env topStrings = do+  let !(bndrs, strings) = unzip topStrings+  ptrs <- iservCmd hsc_env $ MallocStrings strings+  return $ zip bndrs ptrs++{-+Note [generating code for top-level string literal bindings]++Here is a summary on how the byte code generator deals with top-level string+literals:++1. Top-level string literal bindings are spearted from the rest of the module.++2. The strings are allocated via iservCmd, in allocateTopStrings++3. The mapping from binders to allocated strings (topStrings) are maintained in+   BcM and used when generating code for variable references.+-}++-- -----------------------------------------------------------------------------+-- Generating byte code for an expression++-- Returns: the root BCO for this expression+coreExprToBCOs :: HscEnv+               -> Module+               -> CoreExpr+               -> IO UnlinkedBCO+coreExprToBCOs hsc_env this_mod expr+ = withTiming (pure dflags)+              (text "ByteCodeGen"<+>brackets (ppr this_mod))+              (const ()) $ do+      -- create a totally bogus name for the top-level BCO; this+      -- should be harmless, since it's never used for anything+      let invented_name  = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel")+          invented_id    = Id.mkLocalId invented_name (panic "invented_id's type")++      -- the uniques are needed to generate fresh variables when we introduce new+      -- let bindings for ticked expressions+      us <- mkSplitUniqSupply 'y'+      (BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ _, proto_bco)+         <- runBc hsc_env us this_mod Nothing emptyVarEnv $+              schemeTopBind (invented_id, simpleFreeVars expr)++      when (notNull mallocd)+           (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")++      dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco)++      assembleOneBCO hsc_env proto_bco+  where dflags = hsc_dflags hsc_env++-- The regular freeVars function gives more information than is useful to+-- us here. simpleFreeVars does the impedance matching.+simpleFreeVars :: CoreExpr -> AnnExpr Id DVarSet+simpleFreeVars = go . freeVars+  where+    go :: AnnExpr Id FVAnn -> AnnExpr Id DVarSet+    go (ann, e) = (freeVarsOfAnn ann, go' e)++    go' :: AnnExpr' Id FVAnn -> AnnExpr' Id DVarSet+    go' (AnnVar id)                  = AnnVar id+    go' (AnnLit lit)                 = AnnLit lit+    go' (AnnLam bndr body)           = AnnLam bndr (go body)+    go' (AnnApp fun arg)             = AnnApp (go fun) (go arg)+    go' (AnnCase scrut bndr ty alts) = AnnCase (go scrut) bndr ty (map go_alt alts)+    go' (AnnLet bind body)           = AnnLet (go_bind bind) (go body)+    go' (AnnCast expr (ann, co))     = AnnCast (go expr) (freeVarsOfAnn ann, co)+    go' (AnnTick tick body)          = AnnTick tick (go body)+    go' (AnnType ty)                 = AnnType ty+    go' (AnnCoercion co)             = AnnCoercion co++    go_alt (con, args, expr) = (con, args, go expr)++    go_bind (AnnNonRec bndr rhs) = AnnNonRec bndr (go rhs)+    go_bind (AnnRec pairs)       = AnnRec (map (second go) pairs)++-- -----------------------------------------------------------------------------+-- Compilation schema for the bytecode generator++type BCInstrList = OrdList BCInstr++type Sequel = Word -- back off to this depth before ENTER++-- Maps Ids to the offset from the stack _base_ so we don't have+-- to mess with it after each push/pop.+type BCEnv = Map Id Word -- To find vars on the stack++{-+ppBCEnv :: BCEnv -> SDoc+ppBCEnv p+   = text "begin-env"+     $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p))))+     $$ text "end-env"+     where+        pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgRep var)+        cmp_snd x y = compare (snd x) (snd y)+-}++-- Create a BCO and do a spot of peephole optimisation on the insns+-- at the same time.+mkProtoBCO+   :: DynFlags+   -> name+   -> BCInstrList+   -> Either  [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)+   -> Int+   -> Word16+   -> [StgWord]+   -> Bool      -- True <=> is a return point, rather than a function+   -> [FFIInfo]+   -> ProtoBCO name+mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis+   = ProtoBCO {+        protoBCOName = nm,+        protoBCOInstrs = maybe_with_stack_check,+        protoBCOBitmap = bitmap,+        protoBCOBitmapSize = bitmap_size,+        protoBCOArity = arity,+        protoBCOExpr = origin,+        protoBCOFFIs = ffis+      }+     where+        -- Overestimate the stack usage (in words) of this BCO,+        -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit+        -- stack check.  (The interpreter always does a stack check+        -- for iNTERP_STACK_CHECK_THRESH words at the start of each+        -- BCO anyway, so we only need to add an explicit one in the+        -- (hopefully rare) cases when the (overestimated) stack use+        -- exceeds iNTERP_STACK_CHECK_THRESH.+        maybe_with_stack_check+           | is_ret && stack_usage < fromIntegral (aP_STACK_SPLIM dflags) = peep_d+                -- don't do stack checks at return points,+                -- everything is aggregated up to the top BCO+                -- (which must be a function).+                -- That is, unless the stack usage is >= AP_STACK_SPLIM,+                -- see bug #1466.+           | stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH+           = STKCHECK stack_usage : peep_d+           | otherwise+           = peep_d     -- the supposedly common case++        -- We assume that this sum doesn't wrap+        stack_usage = sum (map bciStackUse peep_d)++        -- Merge local pushes+        peep_d = peep (fromOL instrs_ordlist)++        peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest)+           = PUSH_LLL off1 (off2-1) (off3-2) : peep rest+        peep (PUSH_L off1 : PUSH_L off2 : rest)+           = PUSH_LL off1 (off2-1) : peep rest+        peep (i:rest)+           = i : peep rest+        peep []+           = []++argBits :: DynFlags -> [ArgRep] -> [Bool]+argBits _      [] = []+argBits dflags (rep : args)+  | isFollowableArg rep  = False : argBits dflags args+  | otherwise = take (argRepSizeW dflags rep) (repeat True) ++ argBits dflags args++-- -----------------------------------------------------------------------------+-- schemeTopBind++-- Compile code for the right-hand side of a top-level binding++schemeTopBind :: (Id, AnnExpr Id DVarSet) -> BcM (ProtoBCO Name)+++schemeTopBind (id, rhs)+  | Just data_con <- isDataConWorkId_maybe id,+    isNullaryRepDataCon data_con = do+    dflags <- getDynFlags+        -- Special case for the worker of a nullary data con.+        -- It'll look like this:        Nil = /\a -> Nil a+        -- If we feed it into schemeR, we'll get+        --      Nil = Nil+        -- because mkConAppCode treats nullary constructor applications+        -- by just re-using the single top-level definition.  So+        -- for the worker itself, we must allocate it directly.+    -- ioToBc (putStrLn $ "top level BCO")+    emitBc (mkProtoBCO dflags (getName id) (toOL [PACK data_con 0, ENTER])+                       (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})++  | otherwise+  = schemeR [{- No free variables -}] (id, rhs)+++-- -----------------------------------------------------------------------------+-- schemeR++-- Compile code for a right-hand side, to give a BCO that,+-- when executed with the free variables and arguments on top of the stack,+-- will return with a pointer to the result on top of the stack, after+-- removing the free variables and arguments.+--+-- Park the resulting BCO in the monad.  Also requires the+-- variable to which this value was bound, so as to give the+-- resulting BCO a name.++schemeR :: [Id]                 -- Free vars of the RHS, ordered as they+                                -- will appear in the thunk.  Empty for+                                -- top-level things, which have no free vars.+        -> (Id, AnnExpr Id DVarSet)+        -> BcM (ProtoBCO Name)+schemeR fvs (nm, rhs)+{-+   | trace (showSDoc (+              (char ' '+               $$ (ppr.filter (not.isTyVar).dVarSetElems.fst) rhs+               $$ pprCoreExpr (deAnnotate rhs)+               $$ char ' '+              ))) False+   = undefined+   | otherwise+-}+   = schemeR_wrk fvs nm rhs (collect rhs)++collect :: AnnExpr Id DVarSet -> ([Var], AnnExpr' Id DVarSet)+collect (_, e) = go [] e+  where+    go xs e | Just e' <- bcView e = go xs e'+    go xs (AnnLam x (_,e))+      | typePrimRep (idType x) `lengthExceeds` 1+      = multiValException+      | otherwise+      = go (x:xs) e+    go xs not_lambda = (reverse xs, not_lambda)++schemeR_wrk :: [Id] -> Id -> AnnExpr Id DVarSet -> ([Var], AnnExpr' Var DVarSet) -> BcM (ProtoBCO Name)+schemeR_wrk fvs nm original_body (args, body)+   = do+     dflags <- getDynFlags+     let+         all_args  = reverse args ++ fvs+         arity     = length all_args+         -- all_args are the args in reverse order.  We're compiling a function+         -- \fv1..fvn x1..xn -> e+         -- i.e. the fvs come first++         szsw_args = map (fromIntegral . idSizeW dflags) all_args+         szw_args  = sum szsw_args+         p_init    = Map.fromList (zip all_args (mkStackOffsets 0 szsw_args))++         -- make the arg bitmap+         bits = argBits dflags (reverse (map bcIdArgRep all_args))+         bitmap_size = genericLength bits+         bitmap = mkBitmap dflags bits+     body_code <- schemeER_wrk szw_args p_init body++     emitBc (mkProtoBCO dflags (getName nm) body_code (Right original_body)+                 arity bitmap_size bitmap False{-not alts-})++-- introduce break instructions for ticked expressions+schemeER_wrk :: Word -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList+schemeER_wrk d p rhs+  | AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs+  = do  code <- schemeE (fromIntegral d) 0 p newRhs+        cc_arr <- getCCArray+        this_mod <- moduleName <$> getCurrentModule+        let idOffSets = getVarOffSets d p fvs+        let breakInfo = CgBreakInfo+                        { cgb_vars = idOffSets+                        , cgb_resty = exprType (deAnnotate' newRhs)+                        }+        newBreakInfo tick_no breakInfo+        dflags <- getDynFlags+        let cc | interpreterProfiled dflags = cc_arr ! tick_no+               | otherwise = toRemotePtr nullPtr+        let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc+        return $ breakInstr `consOL` code+   | otherwise = schemeE (fromIntegral d) 0 p rhs++getVarOffSets :: Word -> BCEnv -> [Id] -> [(Id, Word16)]+getVarOffSets d p = catMaybes . map (getOffSet d p)++getOffSet :: Word -> BCEnv -> Id -> Maybe (Id, Word16)+getOffSet d env id+   = case lookupBCEnv_maybe id env of+        Nothing     -> Nothing+        Just offset -> Just (id, trunc16 $ d - offset)++trunc16 :: Word -> Word16+trunc16 w+    | w > fromIntegral (maxBound :: Word16)+    = panic "stack depth overflow"+    | otherwise+    = fromIntegral w++fvsToEnv :: BCEnv -> DVarSet -> [Id]+-- Takes the free variables of a right-hand side, and+-- delivers an ordered list of the local variables that will+-- be captured in the thunk for the RHS+-- The BCEnv argument tells which variables are in the local+-- environment: these are the ones that should be captured+--+-- The code that constructs the thunk, and the code that executes+-- it, have to agree about this layout+fvsToEnv p fvs = [v | v <- dVarSetElems fvs,+                      isId v,           -- Could be a type variable+                      v `Map.member` p]++-- -----------------------------------------------------------------------------+-- schemeE++returnUnboxedAtom :: Word -> Sequel -> BCEnv+                 -> AnnExpr' Id DVarSet -> ArgRep+                 -> BcM BCInstrList+-- Returning an unlifted value.+-- Heave it on the stack, SLIDE, and RETURN.+returnUnboxedAtom d s p e e_rep+   = do (push, szw) <- pushAtom d p e+        return (push                       -- value onto stack+                `appOL`  mkSLIDE szw (d-s) -- clear to sequel+                `snocOL` RETURN_UBX e_rep) -- go++-- Compile code to apply the given expression to the remaining args+-- on the stack, returning a HNF.+schemeE :: Word -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList++schemeE d s p e+   | Just e' <- bcView e+   = schemeE d s p e'++-- Delegate tail-calls to schemeT.+schemeE d s p e@(AnnApp _ _) = schemeT d s p e++schemeE d s p e@(AnnLit lit)     = returnUnboxedAtom d s p e (typeArgRep (literalType lit))+schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V++schemeE d s p e@(AnnVar v)+    | isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v)+    | otherwise                 = schemeT d s p e++schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))+   | (AnnVar v, args_r_to_l) <- splitApp rhs,+     Just data_con <- isDataConWorkId_maybe v,+     dataConRepArity data_con == length args_r_to_l+   = do -- Special case for a non-recursive let whose RHS is a+        -- saturated constructor application.+        -- Just allocate the constructor and carry on+        alloc_code <- mkConAppCode d s p data_con args_r_to_l+        body_code <- schemeE (d+1) s (Map.insert x d p) body+        return (alloc_code `appOL` body_code)++-- General case for let.  Generates correct, if inefficient, code in+-- all situations.+schemeE d s p (AnnLet binds (_,body)) = do+     dflags <- getDynFlags+     let (xs,rhss) = case binds of AnnNonRec x rhs  -> ([x],[rhs])+                                   AnnRec xs_n_rhss -> unzip xs_n_rhss+         n_binds = genericLength xs++         fvss  = map (fvsToEnv p' . fst) rhss++         -- Sizes of free vars+         sizes = map (\rhs_fvs -> sum (map (fromIntegral . idSizeW dflags) rhs_fvs)) fvss++         -- the arity of each rhs+         arities = map (genericLength . fst . collect) rhss++         -- This p', d' defn is safe because all the items being pushed+         -- are ptrs, so all have size 1.  d' and p' reflect the stack+         -- after the closures have been allocated in the heap (but not+         -- filled in), and pointers to them parked on the stack.+         p'    = Map.insertList (zipE xs (mkStackOffsets d (genericReplicate n_binds 1))) p+         d'    = d + fromIntegral n_binds+         zipE  = zipEqual "schemeE"++         -- ToDo: don't build thunks for things with no free variables+         build_thunk _ [] size bco off arity+            = return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size))+           where+                mkap | arity == 0 = MKAP+                     | otherwise  = MKPAP+         build_thunk dd (fv:fvs) size bco off arity = do+              (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv)+              more_push_code <- build_thunk (dd + fromIntegral pushed_szw) fvs size bco off arity+              return (push_code `appOL` more_push_code)++         alloc_code = toOL (zipWith mkAlloc sizes arities)+           where mkAlloc sz 0+                    | is_tick     = ALLOC_AP_NOUPD sz+                    | otherwise   = ALLOC_AP sz+                 mkAlloc sz arity = ALLOC_PAP arity sz++         is_tick = case binds of+                     AnnNonRec id _ -> occNameFS (getOccName id) == tickFS+                     _other -> False++         compile_bind d' fvs x rhs size arity off = do+                bco <- schemeR fvs (x,rhs)+                build_thunk d' fvs size bco off arity++         compile_binds =+            [ compile_bind d' fvs x rhs size arity n+            | (fvs, x, rhs, size, arity, n) <-+                zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]+            ]+     body_code <- schemeE d' s p' body+     thunk_codes <- sequence compile_binds+     return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)++-- Introduce a let binding for a ticked case expression. This rule+-- *should* only fire when the expression was not already let-bound+-- (the code gen for let bindings should take care of that).  Todo: we+-- call exprFreeVars on a deAnnotated expression, this may not be the+-- best way to calculate the free vars but it seemed like the least+-- intrusive thing to do+schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs)+   | isLiftedTypeKind (typeKind ty)+   = do   id <- newId ty+          -- Todo: is emptyVarSet correct on the next line?+          let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyDVarSet, AnnVar id)+          schemeE d s p letExp++   | otherwise+   = do   -- If the result type is not definitely lifted, then we must generate+          --   let f = \s . tick<n> e+          --   in  f realWorld#+          -- When we stop at the breakpoint, _result will have an unlifted+          -- type and hence won't be bound in the environment, but the+          -- breakpoint will otherwise work fine.+          --+          -- NB (Trac #12007) this /also/ applies for if (ty :: TYPE r), where+          --    r :: RuntimeRep is a variable. This can happen in the+          --    continuations for a pattern-synonym matcher+          --    match = /\(r::RuntimeRep) /\(a::TYPE r).+          --            \(k :: Int -> a) \(v::T).+          --            case v of MkV n -> k n+          -- Here (k n) :: a :: Type r, so we don't know if it's lifted+          -- or not; but that should be fine provided we add that void arg.++          id <- newId (mkFunTy realWorldStatePrimTy ty)+          st <- newId realWorldStatePrimTy+          let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyDVarSet, exp)))+                              (emptyDVarSet, (AnnApp (emptyDVarSet, AnnVar id)+                                                    (emptyDVarSet, AnnVar realWorldPrimId)))+          schemeE d s p letExp++   where+     exp' = deAnnotate' exp+     fvs  = exprFreeVarsDSet exp'+     ty   = exprType exp'++-- ignore other kinds of tick+schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs++schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut+        -- no alts: scrut is guaranteed to diverge++schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])+   | isUnboxedTupleCon dc -- handles pairs with one void argument (e.g. state token)+        -- Convert+        --      case .... of x { (# V'd-thing, a #) -> ... }+        -- to+        --      case .... of a { DEFAULT -> ... }+        -- because the return convention for both are identical.+        --+        -- Note that it does not matter losing the void-rep thing from the+        -- envt (it won't be bound now) because we never look such things up.+   , Just res <- case (typePrimRep (idType bind1), typePrimRep (idType bind2)) of+                   ([], [_])+                     -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr)+                   ([_], [])+                     -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)+                   _ -> Nothing+   = res++schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])+   | isUnboxedTupleCon dc+   , length (typePrimRep (idType bndr)) <= 1 -- handles unit tuples+   = doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)++schemeE d s p (AnnCase scrut bndr _ alt@[(DEFAULT, [], _)])+   | isUnboxedTupleType (idType bndr)+   , Just ty <- case typePrimRep (idType bndr) of+       [_]  -> Just (unwrapType (idType bndr))+       []   -> Just voidPrimTy+       _    -> Nothing+       -- handles any pattern with a single non-void binder; in particular I/O+       -- monad returns (# RealWorld#, a #)+   = doCase d s p scrut (bndr `setIdType` ty) alt (Just bndr)++schemeE d s p (AnnCase scrut bndr _ alts)+   = doCase d s p scrut bndr alts Nothing{-not an unboxed tuple-}++schemeE _ _ _ expr+   = pprPanic "ByteCodeGen.schemeE: unhandled case"+               (pprCoreExpr (deAnnotate' expr))++{-+   Ticked Expressions+   ------------------++  The idea is that the "breakpoint<n,fvs> E" is really just an annotation on+  the code. When we find such a thing, we pull out the useful information,+  and then compile the code as if it was just the expression E.++-}++-- Compile code to do a tail call.  Specifically, push the fn,+-- slide the on-stack app back down to the sequel depth,+-- and enter.  Four cases:+--+-- 0.  (Nasty hack).+--     An application "GHC.Prim.tagToEnum# <type> unboxed-int".+--     The int will be on the stack.  Generate a code sequence+--     to convert it to the relevant constructor, SLIDE and ENTER.+--+-- 1.  The fn denotes a ccall.  Defer to generateCCall.+--+-- 2.  (Another nasty hack).  Spot (# a::V, b #) and treat+--     it simply as  b  -- since the representations are identical+--     (the V takes up zero stack space).  Also, spot+--     (# b #) and treat it as  b.+--+-- 3.  Application of a constructor, by defn saturated.+--     Split the args into ptrs and non-ptrs, and push the nonptrs,+--     then the ptrs, and then do PACK and RETURN.+--+-- 4.  Otherwise, it must be a function call.  Push the args+--     right to left, SLIDE and ENTER.++schemeT :: Word         -- Stack depth+        -> Sequel       -- Sequel depth+        -> BCEnv        -- stack env+        -> AnnExpr' Id DVarSet+        -> BcM BCInstrList++schemeT d s p app++--   | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False+--   = panic "schemeT ?!?!"++--   | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate' app)) ++ "\n") False+--   = error "?!?!"++   -- Case 0+   | Just (arg, constr_names) <- maybe_is_tagToEnum_call app+   = implement_tagToId d s p arg constr_names++   -- Case 1+   | Just (CCall ccall_spec) <- isFCallId_maybe fn+   = if isSupportedCConv ccall_spec+      then generateCCall d s p ccall_spec fn args_r_to_l+      else unsupportedCConvException+++   -- Case 2: Constructor application+   | Just con <- maybe_saturated_dcon+   , isUnboxedTupleCon con+   = case args_r_to_l of+        [arg1,arg2] | isVAtom arg1 ->+                  unboxedTupleReturn d s p arg2+        [arg1,arg2] | isVAtom arg2 ->+                  unboxedTupleReturn d s p arg1+        _other -> multiValException++   -- Case 3: Ordinary data constructor+   | Just con <- maybe_saturated_dcon+   = do alloc_con <- mkConAppCode d s p con args_r_to_l+        return (alloc_con         `appOL`+                mkSLIDE 1 (d - s) `snocOL`+                ENTER)++   -- Case 4: Tail call of function+   | otherwise+   = doTailCall d s p fn args_r_to_l++   where+        -- Extract the args (R->L) and fn+        -- The function will necessarily be a variable,+        -- because we are compiling a tail call+      (AnnVar fn, args_r_to_l) = splitApp app++      -- Only consider this to be a constructor application iff it is+      -- saturated.  Otherwise, we'll call the constructor wrapper.+      n_args = length args_r_to_l+      maybe_saturated_dcon+        = case isDataConWorkId_maybe fn of+                Just con | dataConRepArity con == n_args -> Just con+                _ -> Nothing++-- -----------------------------------------------------------------------------+-- Generate code to build a constructor application,+-- leaving it on top of the stack++mkConAppCode :: Word -> Sequel -> BCEnv+             -> DataCon                 -- The data constructor+             -> [AnnExpr' Id DVarSet]    -- Args, in *reverse* order+             -> BcM BCInstrList++mkConAppCode _ _ _ con []       -- Nullary constructor+  = ASSERT( isNullaryRepDataCon con )+    return (unitOL (PUSH_G (getName (dataConWorkId con))))+        -- Instead of doing a PACK, which would allocate a fresh+        -- copy of this constructor, use the single shared version.++mkConAppCode orig_d _ p con args_r_to_l+  = ASSERT( dataConRepArity con == length args_r_to_l )+    do_pushery orig_d (non_ptr_args ++ ptr_args)+ where+        -- The args are already in reverse order, which is the way PACK+        -- expects them to be.  We must push the non-ptrs after the ptrs.+      (ptr_args, non_ptr_args) = partition isPtrAtom args_r_to_l++      do_pushery d (arg:args)+         = do (push, arg_words) <- pushAtom d p arg+              more_push_code <- do_pushery (d + fromIntegral arg_words) args+              return (push `appOL` more_push_code)+      do_pushery d []+         = return (unitOL (PACK con n_arg_words))+         where+           n_arg_words = trunc16 $ d - orig_d+++-- -----------------------------------------------------------------------------+-- Returning an unboxed tuple with one non-void component (the only+-- case we can handle).+--+-- Remember, we don't want to *evaluate* the component that is being+-- returned, even if it is a pointed type.  We always just return.++unboxedTupleReturn+        :: Word -> Sequel -> BCEnv+        -> AnnExpr' Id DVarSet -> BcM BCInstrList+unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg)++-- -----------------------------------------------------------------------------+-- Generate code for a tail-call++doTailCall+        :: Word -> Sequel -> BCEnv+        -> Id -> [AnnExpr' Id DVarSet]+        -> BcM BCInstrList+doTailCall init_d s p fn args+  = do_pushes init_d args (map atomRep args)+  where+  do_pushes d [] reps = do+        ASSERT( null reps ) return ()+        (push_fn, sz) <- pushAtom d p (AnnVar fn)+        ASSERT( sz == 1 ) return ()+        return (push_fn `appOL` (+                  mkSLIDE (trunc16 $ d - init_d + 1) (init_d - s) `appOL`+                  unitOL ENTER))+  do_pushes d args reps = do+      let (push_apply, n, rest_of_reps) = findPushSeq reps+          (these_args, rest_of_args) = splitAt n args+      (next_d, push_code) <- push_seq d these_args+      instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps+      --                          ^^^ for the PUSH_APPLY_ instruction+      return (push_code `appOL` (push_apply `consOL` instrs))++  push_seq d [] = return (d, nilOL)+  push_seq d (arg:args) = do+    (push_code, sz) <- pushAtom d p arg+    (final_d, more_push_code) <- push_seq (d + fromIntegral sz) args+    return (final_d, push_code `appOL` more_push_code)++-- v. similar to CgStackery.findMatch, ToDo: merge+findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep])+findPushSeq (P: P: P: P: P: P: rest)+  = (PUSH_APPLY_PPPPPP, 6, rest)+findPushSeq (P: P: P: P: P: rest)+  = (PUSH_APPLY_PPPPP, 5, rest)+findPushSeq (P: P: P: P: rest)+  = (PUSH_APPLY_PPPP, 4, rest)+findPushSeq (P: P: P: rest)+  = (PUSH_APPLY_PPP, 3, rest)+findPushSeq (P: P: rest)+  = (PUSH_APPLY_PP, 2, rest)+findPushSeq (P: rest)+  = (PUSH_APPLY_P, 1, rest)+findPushSeq (V: rest)+  = (PUSH_APPLY_V, 1, rest)+findPushSeq (N: rest)+  = (PUSH_APPLY_N, 1, rest)+findPushSeq (F: rest)+  = (PUSH_APPLY_F, 1, rest)+findPushSeq (D: rest)+  = (PUSH_APPLY_D, 1, rest)+findPushSeq (L: rest)+  = (PUSH_APPLY_L, 1, rest)+findPushSeq _+  = panic "ByteCodeGen.findPushSeq"++-- -----------------------------------------------------------------------------+-- Case expressions++doCase  :: Word -> Sequel -> BCEnv+        -> AnnExpr Id DVarSet -> Id -> [AnnAlt Id DVarSet]+        -> Maybe Id  -- Just x <=> is an unboxed tuple case with scrut binder, don't enter the result+        -> BcM BCInstrList+doCase d s p (_,scrut) bndr alts is_unboxed_tuple+  | typePrimRep (idType bndr) `lengthExceeds` 1+  = multiValException+  | otherwise+  = do+     dflags <- getDynFlags+     let+        profiling+          | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags+          | otherwise = rtsIsProfiled++        -- Top of stack is the return itbl, as usual.+        -- underneath it is the pointer to the alt_code BCO.+        -- When an alt is entered, it assumes the returned value is+        -- on top of the itbl.+        ret_frame_sizeW :: Word+        ret_frame_sizeW = 2++        -- The extra frame we push to save/restor the CCCS when profiling+        save_ccs_sizeW | profiling = 2+                       | otherwise = 0++        -- An unlifted value gets an extra info table pushed on top+        -- when it is returned.+        unlifted_itbl_sizeW :: Word+        unlifted_itbl_sizeW | isAlgCase = 0+                            | otherwise = 1++        -- depth of stack after the return value has been pushed+        d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW dflags bndr)++        -- depth of stack after the extra info table for an unboxed return+        -- has been pushed, if any.  This is the stack depth at the+        -- continuation.+        d_alts = d_bndr + unlifted_itbl_sizeW++        -- Env in which to compile the alts, not including+        -- any vars bound by the alts themselves+        d_bndr' = fromIntegral d_bndr - 1+        p_alts0 = Map.insert bndr d_bndr' p+        p_alts = case is_unboxed_tuple of+                   Just ubx_bndr -> Map.insert ubx_bndr d_bndr' p_alts0+                   Nothing       -> p_alts0++        bndr_ty = idType bndr+        isAlgCase = not (isUnliftedType bndr_ty) && isNothing is_unboxed_tuple++        -- given an alt, return a discr and code for it.+        codeAlt (DEFAULT, _, (_,rhs))+           = do rhs_code <- schemeE d_alts s p_alts rhs+                return (NoDiscr, rhs_code)++        codeAlt alt@(_, bndrs, (_,rhs))+           -- primitive or nullary constructor alt: no need to UNPACK+           | null real_bndrs = do+                rhs_code <- schemeE d_alts s p_alts rhs+                return (my_discr alt, rhs_code)+           -- algebraic alt with some binders+           | otherwise =+             let+                 (ptrs,nptrs) = partition (isFollowableArg.bcIdArgRep) real_bndrs+                 ptr_sizes    = map (fromIntegral . idSizeW dflags) ptrs+                 nptrs_sizes  = map (fromIntegral . idSizeW dflags) nptrs+                 bind_sizes   = ptr_sizes ++ nptrs_sizes+                 size         = sum ptr_sizes + sum nptrs_sizes+                 -- the UNPACK instruction unpacks in reverse order...+                 p' = Map.insertList+                        (zip (reverse (ptrs ++ nptrs))+                          (mkStackOffsets d_alts (reverse bind_sizes)))+                        p_alts+             in do+             MASSERT(isAlgCase)+             rhs_code <- schemeE (d_alts + size) s p' rhs+             return (my_discr alt, unitOL (UNPACK (trunc16 size)) `appOL` rhs_code)+           where+             real_bndrs = filterOut isTyVar bndrs++        my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}+        my_discr (DataAlt dc, _, _)+           | isUnboxedTupleCon dc || isUnboxedSumCon dc+           = multiValException+           | otherwise+           = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))+        my_discr (LitAlt l, _, _)+           = case l of MachInt i     -> DiscrI (fromInteger i)+                       MachWord w    -> DiscrW (fromInteger w)+                       MachFloat r   -> DiscrF (fromRational r)+                       MachDouble r  -> DiscrD (fromRational r)+                       MachChar i    -> DiscrI (ord i)+                       _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)++        maybe_ncons+           | not isAlgCase = Nothing+           | otherwise+           = case [dc | (DataAlt dc, _, _) <- alts] of+                []     -> Nothing+                (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))++        -- the bitmap is relative to stack depth d, i.e. before the+        -- BCO, info table and return value are pushed on.+        -- This bit of code is v. similar to buildLivenessMask in CgBindery,+        -- except that here we build the bitmap from the known bindings of+        -- things that are pointers, whereas in CgBindery the code builds the+        -- bitmap from the free slots and unboxed bindings.+        -- (ToDo: merge?)+        --+        -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002.+        -- The bitmap must cover the portion of the stack up to the sequel only.+        -- Previously we were building a bitmap for the whole depth (d), but we+        -- really want a bitmap up to depth (d-s).  This affects compilation of+        -- case-of-case expressions, which is the only time we can be compiling a+        -- case expression with s /= 0.+        bitmap_size = trunc16 $ d-s+        bitmap_size' :: Int+        bitmap_size' = fromIntegral bitmap_size+        bitmap = intsToReverseBitmap dflags bitmap_size'{-size-}+                        (sort (filter (< bitmap_size') rel_slots))+          where+          binds = Map.toList p+          -- NB: unboxed tuple cases bind the scrut binder to the same offset+          -- as one of the alt binders, so we have to remove any duplicates here:+          rel_slots = nub $ map fromIntegral $ concat (map spread binds)+          spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ]+                              | otherwise                      = []+                where rel_offset = trunc16 $ d - fromIntegral offset - 1++     alt_stuff <- mapM codeAlt alts+     alt_final <- mkMultiBranch maybe_ncons alt_stuff++     let+         alt_bco_name = getName bndr+         alt_bco = mkProtoBCO dflags alt_bco_name alt_final (Left alts)+                       0{-no arity-} bitmap_size bitmap True{-is alts-}+--     trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) +++--            "\n      bitmap = " ++ show bitmap) $ do++     scrut_code <- schemeE (d + ret_frame_sizeW + save_ccs_sizeW)+                           (d + ret_frame_sizeW + save_ccs_sizeW)+                           p scrut+     alt_bco' <- emitBc alt_bco+     let push_alts+            | isAlgCase = PUSH_ALTS alt_bco'+            | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep bndr_ty)+     return (push_alts `consOL` scrut_code)+++-- -----------------------------------------------------------------------------+-- Deal with a CCall.++-- Taggedly push the args onto the stack R->L,+-- deferencing ForeignObj#s and adjusting addrs to point to+-- payloads in Ptr/Byte arrays.  Then, generate the marshalling+-- (machine) code for the ccall, and create bytecodes to call that and+-- then return in the right way.++generateCCall :: Word -> Sequel         -- stack and sequel depths+              -> BCEnv+              -> CCallSpec              -- where to call+              -> Id                     -- of target, for type info+              -> [AnnExpr' Id DVarSet]   -- args (atoms)+              -> BcM BCInstrList++generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l+ = do+     dflags <- getDynFlags++     let+         -- useful constants+         addr_sizeW :: Word16+         addr_sizeW = fromIntegral (argRepSizeW dflags N)++         -- Get the args on the stack, with tags and suitably+         -- dereferenced for the CCall.  For each arg, return the+         -- depth to the first word of the bits for that arg, and the+         -- ArgRep of what was actually pushed.++         pargs _ [] = return []+         pargs d (a:az)+            = let arg_ty = unwrapType (exprType (deAnnotate' a))++              in case tyConAppTyCon_maybe arg_ty of+                    -- Don't push the FO; instead push the Addr# it+                    -- contains.+                    Just t+                     | t == arrayPrimTyCon || t == mutableArrayPrimTyCon+                       -> do rest <- pargs (d + fromIntegral addr_sizeW) az+                             code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize dflags)) d p a+                             return ((code,AddrRep):rest)++                     | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon+                       -> do rest <- pargs (d + fromIntegral addr_sizeW) az+                             code <- parg_ArrayishRep (fromIntegral (smallArrPtrsHdrSize dflags)) d p a+                             return ((code,AddrRep):rest)++                     | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon+                       -> do rest <- pargs (d + fromIntegral addr_sizeW) az+                             code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize dflags)) d p a+                             return ((code,AddrRep):rest)++                    -- Default case: push taggedly, but otherwise intact.+                    _+                       -> do (code_a, sz_a) <- pushAtom d p a+                             rest <- pargs (d + fromIntegral sz_a) az+                             return ((code_a, atomPrimRep a) : rest)++         -- Do magic for Ptr/Byte arrays.  Push a ptr to the array on+         -- the stack but then advance it over the headers, so as to+         -- point to the payload.+         parg_ArrayishRep :: Word16 -> Word -> BCEnv -> AnnExpr' Id DVarSet+                          -> BcM BCInstrList+         parg_ArrayishRep hdrSize d p a+            = do (push_fo, _) <- pushAtom d p a+                 -- The ptr points at the header.  Advance it over the+                 -- header and then pretend this is an Addr#.+                 return (push_fo `snocOL` SWIZZLE 0 hdrSize)++     code_n_reps <- pargs d0 args_r_to_l+     let+         (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps+         a_reps_sizeW = fromIntegral (sum (map (primRepSizeW dflags) a_reps_pushed_r_to_l))++         push_args    = concatOL pushs_arg+         d_after_args = d0 + a_reps_sizeW+         a_reps_pushed_RAW+            | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep+            = panic "ByteCodeGen.generateCCall: missing or invalid World token?"+            | otherwise+            = reverse (tail a_reps_pushed_r_to_l)++         -- Now: a_reps_pushed_RAW are the reps which are actually on the stack.+         -- push_args is the code to do that.+         -- d_after_args is the stack depth once the args are on.++         -- Get the result rep.+         (returns_void, r_rep)+            = case maybe_getCCallReturnRep (idType fn) of+                 Nothing -> (True,  VoidRep)+                 Just rr -> (False, rr)+         {-+         Because the Haskell stack grows down, the a_reps refer to+         lowest to highest addresses in that order.  The args for the call+         are on the stack.  Now push an unboxed Addr# indicating+         the C function to call.  Then push a dummy placeholder for the+         result.  Finally, emit a CCALL insn with an offset pointing to the+         Addr# just pushed, and a literal field holding the mallocville+         address of the piece of marshalling code we generate.+         So, just prior to the CCALL insn, the stack looks like this+         (growing down, as usual):++            <arg_n>+            ...+            <arg_1>+            Addr# address_of_C_fn+            <placeholder-for-result#> (must be an unboxed type)++         The interpreter then calls the marshall code mentioned+         in the CCALL insn, passing it (& <placeholder-for-result#>),+         that is, the addr of the topmost word in the stack.+         When this returns, the placeholder will have been+         filled in.  The placeholder is slid down to the sequel+         depth, and we RETURN.++         This arrangement makes it simple to do f-i-dynamic since the Addr#+         value is the first arg anyway.++         The marshalling code is generated specifically for this+         call site, and so knows exactly the (Haskell) stack+         offsets of the args, fn address and placeholder.  It+         copies the args to the C stack, calls the stacked addr,+         and parks the result back in the placeholder.  The interpreter+         calls it as a normal C call, assuming it has a signature+            void marshall_code ( StgWord* ptr_to_top_of_stack )+         -}+         -- resolve static address+         maybe_static_target =+             case target of+                 DynamicTarget -> Nothing+                 StaticTarget _ _ _ False ->+                   panic "generateCCall: unexpected FFI value import"+                 StaticTarget _ target _ True ->+                   Just (MachLabel target mb_size IsFunction)+                   where+                      mb_size+                          | OSMinGW32 <- platformOS (targetPlatform dflags)+                          , StdCallConv <- cconv+                          = Just (fromIntegral a_reps_sizeW * wORD_SIZE dflags)+                          | otherwise+                          = Nothing++     let+         is_static = isJust maybe_static_target++         -- Get the arg reps, zapping the leading Addr# in the dynamic case+         a_reps --  | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"+                | is_static = a_reps_pushed_RAW+                | otherwise = if null a_reps_pushed_RAW+                              then panic "ByteCodeGen.generateCCall: dyn with no args"+                              else tail a_reps_pushed_RAW++         -- push the Addr#+         (push_Addr, d_after_Addr)+            | Just machlabel <- maybe_static_target+            = (toOL [PUSH_UBX machlabel addr_sizeW],+               d_after_args + fromIntegral addr_sizeW)+            | otherwise -- is already on the stack+            = (nilOL, d_after_args)++         -- Push the return placeholder.  For a call returning nothing,+         -- this is a V (tag).+         r_sizeW   = fromIntegral (primRepSizeW dflags r_rep)+         d_after_r = d_after_Addr + fromIntegral r_sizeW+         push_r    = (if   returns_void+                      then nilOL+                      else unitOL (PUSH_UBX (mkDummyLiteral r_rep) r_sizeW))++         -- generate the marshalling code we're going to call++         -- Offset of the next stack frame down the stack.  The CCALL+         -- instruction needs to describe the chunk of stack containing+         -- the ccall args to the GC, so it needs to know how large it+         -- is.  See comment in Interpreter.c with the CCALL instruction.+         stk_offset   = trunc16 $ d_after_r - s++         conv = case cconv of+           CCallConv -> FFICCall+           StdCallConv -> FFIStdCall+           _ -> panic "ByteCodeGen: unexpected calling convention"++     -- the only difference in libffi mode is that we prepare a cif+     -- describing the call type by calling libffi, and we attach the+     -- address of this to the CCALL instruction.+++     let ffires = primRepToFFIType dflags r_rep+         ffiargs = map (primRepToFFIType dflags) a_reps+     hsc_env <- getHscEnv+     token <- ioToBc $ iservCmd hsc_env (PrepFFI conv ffiargs ffires)+     recordFFIBc token++     let+         -- do the call+         do_call      = unitOL (CCALL stk_offset token+                                 (fromIntegral (fromEnum (playInterruptible safety))))+         -- slide and return+         wrapup       = mkSLIDE r_sizeW (d_after_r - fromIntegral r_sizeW - s)+                        `snocOL` RETURN_UBX (toArgRep r_rep)+         --trace (show (arg1_offW, args_offW  ,  (map argRepSizeW a_reps) )) $+     return (+         push_args `appOL`+         push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup+         )++primRepToFFIType :: DynFlags -> PrimRep -> FFIType+primRepToFFIType dflags r+  = case r of+     VoidRep     -> FFIVoid+     IntRep      -> signed_word+     WordRep     -> unsigned_word+     Int64Rep    -> FFISInt64+     Word64Rep   -> FFIUInt64+     AddrRep     -> FFIPointer+     FloatRep    -> FFIFloat+     DoubleRep   -> FFIDouble+     _           -> panic "primRepToFFIType"+  where+    (signed_word, unsigned_word)+       | wORD_SIZE dflags == 4  = (FFISInt32, FFIUInt32)+       | wORD_SIZE dflags == 8  = (FFISInt64, FFIUInt64)+       | otherwise              = panic "primTyDescChar"++-- Make a dummy literal, to be used as a placeholder for FFI return+-- values on the stack.+mkDummyLiteral :: PrimRep -> Literal+mkDummyLiteral pr+   = case pr of+        IntRep    -> MachInt 0+        WordRep   -> MachWord 0+        AddrRep   -> MachNullAddr+        DoubleRep -> MachDouble 0+        FloatRep  -> MachFloat 0+        Int64Rep  -> MachInt64 0+        Word64Rep -> MachWord64 0+        _         -> pprPanic "mkDummyLiteral" (ppr pr)+++-- Convert (eg)+--     GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld+--                   -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)+--+-- to  Just IntRep+-- and check that an unboxed pair is returned wherein the first arg is V'd.+--+-- Alternatively, for call-targets returning nothing, convert+--+--     GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld+--                   -> (# GHC.Prim.State# GHC.Prim.RealWorld #)+--+-- to  Nothing++maybe_getCCallReturnRep :: Type -> Maybe PrimRep+maybe_getCCallReturnRep fn_ty+   = let+       (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)+       r_reps = typePrimRepArgs r_ty++       blargh :: a -- Used at more than one type+       blargh = pprPanic "maybe_getCCallReturn: can't handle:"+                         (pprType fn_ty)+     in+       case r_reps of+         []            -> panic "empty typePrimRepArgs"+         [VoidRep]     -> Nothing+         [rep]+           | isGcPtrRep rep -> blargh+           | otherwise      -> Just rep++                 -- if it was, it would be impossible to create a+                 -- valid return value placeholder on the stack+         _             -> blargh++maybe_is_tagToEnum_call :: AnnExpr' Id DVarSet -> Maybe (AnnExpr' Id DVarSet, [Name])+-- Detect and extract relevant info for the tagToEnum kludge.+maybe_is_tagToEnum_call app+  | AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg <- app+  , Just TagToEnumOp <- isPrimOpId_maybe v+  = Just (snd arg, extract_constr_Names t)+  | otherwise+  = Nothing+  where+    extract_constr_Names ty+           | rep_ty <- unwrapType ty+           , Just tyc <- tyConAppTyCon_maybe rep_ty+           , isDataTyCon tyc+           = map (getName . dataConWorkId) (tyConDataCons tyc)+           -- NOTE: use the worker name, not the source name of+           -- the DataCon.  See DataCon.hs for details.+           | otherwise+           = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty)++{- -----------------------------------------------------------------------------+Note [Implementing tagToEnum#]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(implement_tagToId arg names) compiles code which takes an argument+'arg', (call it i), and enters the i'th closure in the supplied list+as a consequence.  The [Name] is a list of the constructors of this+(enumeration) type.++The code we generate is this:+                push arg+                push bogus-word++                TESTEQ_I 0 L1+                  PUSH_G <lbl for first data con>+                  JMP L_Exit++        L1:     TESTEQ_I 1 L2+                  PUSH_G <lbl for second data con>+                  JMP L_Exit+        ...etc...+        Ln:     TESTEQ_I n L_fail+                  PUSH_G <lbl for last data con>+                  JMP L_Exit++        L_fail: CASEFAIL++        L_exit: SLIDE 1 n+                ENTER++The 'bogus-word' push is because TESTEQ_I expects the top of the stack+to have an info-table, and the next word to have the value to be+tested.  This is very weird, but it's the way it is right now.  See+Interpreter.c.  We don't acutally need an info-table here; we just+need to have the argument to be one-from-top on the stack, hence pushing+a 1-word null. See Trac #8383.+-}+++implement_tagToId :: Word -> Sequel -> BCEnv+                  -> AnnExpr' Id DVarSet -> [Name] -> BcM BCInstrList+-- See Note [Implementing tagToEnum#]+implement_tagToId d s p arg names+  = ASSERT( notNull names )+    do (push_arg, arg_words) <- pushAtom d p arg+       labels <- getLabelsBc (genericLength names)+       label_fail <- getLabelBc+       label_exit <- getLabelBc+       let infos = zip4 labels (tail labels ++ [label_fail])+                               [0 ..] names+           steps = map (mkStep label_exit) infos++       return (push_arg+               `appOL` unitOL (PUSH_UBX MachNullAddr 1)+                   -- Push bogus word (see Note [Implementing tagToEnum#])+               `appOL` concatOL steps+               `appOL` toOL [ LABEL label_fail, CASEFAIL,+                              LABEL label_exit ]+                `appOL` mkSLIDE 1 (d - s + fromIntegral arg_words + 1)+                   -- "+1" to account for bogus word+                   --      (see Note [Implementing tagToEnum#])+                `appOL` unitOL ENTER)+  where+        mkStep l_exit (my_label, next_label, n, name_for_n)+           = toOL [LABEL my_label,+                   TESTEQ_I n next_label,+                   PUSH_G name_for_n,+                   JMP l_exit]+++-- -----------------------------------------------------------------------------+-- pushAtom++-- Push an atom onto the stack, returning suitable code & number of+-- stack words used.+--+-- The env p must map each variable to the highest- numbered stack+-- slot for it.  For example, if the stack has depth 4 and we+-- tagged-ly push (v :: Int#) on it, the value will be in stack[4],+-- the tag in stack[5], the stack will have depth 6, and p must map v+-- to 5 and not to 4.  Stack locations are numbered from zero, so a+-- depth 6 stack has valid words 0 .. 5.++pushAtom :: Word -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, Word16)++pushAtom d p e+   | Just e' <- bcView e+   = pushAtom d p e'++pushAtom _ _ (AnnCoercion {})   -- Coercions are zero-width things,+   = return (nilOL, 0)          -- treated just like a variable V++-- See Note [Empty case alternatives] in coreSyn/CoreSyn.hs+-- and Note [Bottoming expressions] in coreSyn/CoreUtils.hs:+-- The scrutinee of an empty case evaluates to bottom+pushAtom d p (AnnCase (_, a) _ _ []) -- trac #12128+   = pushAtom d p a++pushAtom d p (AnnVar v)+   | [] <- typePrimRep (idType v)+   = return (nilOL, 0)++   | isFCallId v+   = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr v)++   | Just primop <- isPrimOpId_maybe v+   = return (unitOL (PUSH_PRIMOP primop), 1)++   | Just d_v <- lookupBCEnv_maybe v p  -- v is a local variable+   = do dflags <- getDynFlags+        let sz :: Word16+            sz = fromIntegral (idSizeW dflags v)+            l = trunc16 $ d - d_v + fromIntegral sz - 2+        return (toOL (genericReplicate sz (PUSH_L l)), sz)+         -- d - d_v                 the number of words between the TOS+         --                         and the 1st slot of the object+         --+         -- d - d_v - 1             the offset from the TOS of the 1st slot+         --+         -- d - d_v - 1 + sz - 1    the offset from the TOS of the last slot+         --                         of the object.+         --+         -- Having found the last slot, we proceed to copy the right number of+         -- slots on to the top of the stack.++   | otherwise  -- v must be a global variable+   = do topStrings <- getTopStrings+        case lookupVarEnv topStrings v of+            Just ptr -> pushAtom d p $ AnnLit $ MachWord $ fromIntegral $+              ptrToWordPtr $ fromRemotePtr ptr+            Nothing -> do+                dflags <- getDynFlags+                let sz :: Word16+                    sz = fromIntegral (idSizeW dflags v)+                MASSERT(sz == 1)+                return (unitOL (PUSH_G (getName v)), sz)+++pushAtom _ _ (AnnLit lit) = do+     dflags <- getDynFlags+     let code rep+             = let size_host_words = fromIntegral (argRepSizeW dflags rep)+               in  return (unitOL (PUSH_UBX lit size_host_words),+                           size_host_words)++     case lit of+        MachLabel _ _ _ -> code N+        MachWord _    -> code N+        MachInt _     -> code N+        MachWord64 _  -> code L+        MachInt64 _   -> code L+        MachFloat _   -> code F+        MachDouble _  -> code D+        MachChar _    -> code N+        MachNullAddr  -> code N+        MachStr _     -> code N+        -- No LitInteger's should be left by the time this is called.+        -- CorePrep should have converted them all to a real core+        -- representation.+        LitInteger {} -> panic "pushAtom: LitInteger"++pushAtom _ _ expr+   = pprPanic "ByteCodeGen.pushAtom"+              (pprCoreExpr (deAnnotate' expr))+++-- -----------------------------------------------------------------------------+-- Given a bunch of alts code and their discrs, do the donkey work+-- of making a multiway branch using a switch tree.+-- What a load of hassle!++mkMultiBranch :: Maybe Int      -- # datacons in tycon, if alg alt+                                -- a hint; generates better code+                                -- Nothing is always safe+              -> [(Discr, BCInstrList)]+              -> BcM BCInstrList+mkMultiBranch maybe_ncons raw_ways = do+     lbl_default <- getLabelBc++     let+         mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList+         mkTree [] _range_lo _range_hi = return (unitOL (JMP lbl_default))+             -- shouldn't happen?++         mkTree [val] range_lo range_hi+            | range_lo == range_hi+            = return (snd val)+            | null defaults -- Note [CASEFAIL]+            = do lbl <- getLabelBc+                 return (testEQ (fst val) lbl+                            `consOL` (snd val+                            `appOL`  (LABEL lbl `consOL` unitOL CASEFAIL)))+            | otherwise+            = return (testEQ (fst val) lbl_default `consOL` snd val)++            -- Note [CASEFAIL] It may be that this case has no default+            -- branch, but the alternatives are not exhaustive - this+            -- happens for GADT cases for example, where the types+            -- prove that certain branches are impossible.  We could+            -- just assume that the other cases won't occur, but if+            -- this assumption was wrong (because of a bug in GHC)+            -- then the result would be a segfault.  So instead we+            -- emit an explicit test and a CASEFAIL instruction that+            -- causes the interpreter to barf() if it is ever+            -- executed.++         mkTree vals range_lo range_hi+            = let n = length vals `div` 2+                  vals_lo = take n vals+                  vals_hi = drop n vals+                  v_mid = fst (head vals_hi)+              in do+              label_geq <- getLabelBc+              code_lo <- mkTree vals_lo range_lo (dec v_mid)+              code_hi <- mkTree vals_hi v_mid range_hi+              return (testLT v_mid label_geq+                      `consOL` (code_lo+                      `appOL`   unitOL (LABEL label_geq)+                      `appOL`   code_hi))++         the_default+            = case defaults of+                []         -> nilOL+                [(_, def)] -> LABEL lbl_default `consOL` def+                _          -> panic "mkMultiBranch/the_default"+     instrs <- mkTree notd_ways init_lo init_hi+     return (instrs `appOL` the_default)+  where+         (defaults, not_defaults) = partition (isNoDiscr.fst) raw_ways+         notd_ways = sortBy (comparing fst) not_defaults++         testLT (DiscrI i) fail_label = TESTLT_I i fail_label+         testLT (DiscrW i) fail_label = TESTLT_W i fail_label+         testLT (DiscrF i) fail_label = TESTLT_F i fail_label+         testLT (DiscrD i) fail_label = TESTLT_D i fail_label+         testLT (DiscrP i) fail_label = TESTLT_P i fail_label+         testLT NoDiscr    _          = panic "mkMultiBranch NoDiscr"++         testEQ (DiscrI i) fail_label = TESTEQ_I i fail_label+         testEQ (DiscrW i) fail_label = TESTEQ_W i fail_label+         testEQ (DiscrF i) fail_label = TESTEQ_F i fail_label+         testEQ (DiscrD i) fail_label = TESTEQ_D i fail_label+         testEQ (DiscrP i) fail_label = TESTEQ_P i fail_label+         testEQ NoDiscr    _          = panic "mkMultiBranch NoDiscr"++         -- None of these will be needed if there are no non-default alts+         (init_lo, init_hi)+            | null notd_ways+            = panic "mkMultiBranch: awesome foursome"+            | otherwise+            = case fst (head notd_ways) of+                DiscrI _ -> ( DiscrI minBound,  DiscrI maxBound )+                DiscrW _ -> ( DiscrW minBound,  DiscrW maxBound )+                DiscrF _ -> ( DiscrF minF,      DiscrF maxF )+                DiscrD _ -> ( DiscrD minD,      DiscrD maxD )+                DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound )+                NoDiscr -> panic "mkMultiBranch NoDiscr"++         (algMinBound, algMaxBound)+            = case maybe_ncons of+                 -- XXX What happens when n == 0?+                 Just n  -> (0, fromIntegral n - 1)+                 Nothing -> (minBound, maxBound)++         isNoDiscr NoDiscr = True+         isNoDiscr _       = False++         dec (DiscrI i) = DiscrI (i-1)+         dec (DiscrW w) = DiscrW (w-1)+         dec (DiscrP i) = DiscrP (i-1)+         dec other      = other         -- not really right, but if you+                -- do cases on floating values, you'll get what you deserve++         -- same snotty comment applies to the following+         minF, maxF :: Float+         minD, maxD :: Double+         minF = -1.0e37+         maxF =  1.0e37+         minD = -1.0e308+         maxD =  1.0e308+++-- -----------------------------------------------------------------------------+-- Supporting junk for the compilation schemes++-- Describes case alts+data Discr+   = DiscrI Int+   | DiscrW Word+   | DiscrF Float+   | DiscrD Double+   | DiscrP Word16+   | NoDiscr+    deriving (Eq, Ord)++instance Outputable Discr where+   ppr (DiscrI i) = int i+   ppr (DiscrW w) = text (show w)+   ppr (DiscrF f) = text (show f)+   ppr (DiscrD d) = text (show d)+   ppr (DiscrP i) = ppr i+   ppr NoDiscr    = text "DEF"+++lookupBCEnv_maybe :: Id -> BCEnv -> Maybe Word+lookupBCEnv_maybe = Map.lookup++idSizeW :: DynFlags -> Id -> Int+idSizeW dflags = argRepSizeW dflags . bcIdArgRep++bcIdArgRep :: Id -> ArgRep+bcIdArgRep = toArgRep . bcIdPrimRep++bcIdPrimRep :: Id -> PrimRep+bcIdPrimRep id+  | [rep] <- typePrimRepArgs (idType id)+  = rep+  | otherwise+  = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id))++isFollowableArg :: ArgRep -> Bool+isFollowableArg P = True+isFollowableArg _ = False++isVoidArg :: ArgRep -> Bool+isVoidArg V = True+isVoidArg _ = False++-- See bug #1257+multiValException :: a+multiValException = throwGhcException (ProgramError+  ("Error: bytecode compiler can't handle unboxed tuples and sums.\n"+++   "  Possibly due to foreign import/export decls in source.\n"+++   "  Workaround: use -fobject-code, or compile this module to .o separately."))++-- | Indicate if the calling convention is supported+isSupportedCConv :: CCallSpec -> Bool+isSupportedCConv (CCallSpec _ cconv _) = case cconv of+   CCallConv            -> True     -- we explicitly pattern match on every+   StdCallConv          -> True     -- convention to ensure that a warning+   PrimCallConv         -> False    -- is triggered when a new one is added+   JavaScriptCallConv   -> False+   CApiConv             -> False++-- See bug #10462+unsupportedCConvException :: a+unsupportedCConvException = throwGhcException (ProgramError+  ("Error: bytecode compiler can't handle some foreign calling conventions\n"+++   "  Workaround: use -fobject-code, or compile this module to .o separately."))++mkSLIDE :: Word16 -> Word -> OrdList BCInstr+mkSLIDE n d+    -- if the amount to slide doesn't fit in a word,+    -- generate multiple slide instructions+    | d > fromIntegral limit+    = SLIDE n limit `consOL` mkSLIDE n (d - fromIntegral limit)+    | d == 0+    = nilOL+    | otherwise+    = if d == 0 then nilOL else unitOL (SLIDE n $ fromIntegral d)+    where+        limit :: Word16+        limit = maxBound++splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann])+        -- The arguments are returned in *right-to-left* order+splitApp e | Just e' <- bcView e = splitApp e'+splitApp (AnnApp (_,f) (_,a))    = case splitApp f of+                                      (f', as) -> (f', a:as)+splitApp e                       = (e, [])+++bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)+-- The "bytecode view" of a term discards+--  a) type abstractions+--  b) type applications+--  c) casts+--  d) ticks (but not breakpoints)+-- Type lambdas *can* occur in random expressions,+-- whereas value lambdas cannot; that is why they are nuked here+bcView (AnnCast (_,e) _)             = Just e+bcView (AnnLam v (_,e)) | isTyVar v  = Just e+bcView (AnnApp (_,e) (_, AnnType _)) = Just e+bcView (AnnTick Breakpoint{} _)      = Nothing+bcView (AnnTick _other_tick (_,e))   = Just e+bcView _                             = Nothing++isVAtom :: AnnExpr' Var ann -> Bool+isVAtom e | Just e' <- bcView e = isVAtom e'+isVAtom (AnnVar v)              = isVoidArg (bcIdArgRep v)+isVAtom (AnnCoercion {})        = True+isVAtom _                     = False++atomPrimRep :: AnnExpr' Id ann -> PrimRep+atomPrimRep e | Just e' <- bcView e = atomPrimRep e'+atomPrimRep (AnnVar v)              = bcIdPrimRep v+atomPrimRep (AnnLit l)              = typePrimRep1 (literalType l)++-- Trac #12128:+-- A case expression can be an atom because empty cases evaluate to bottom.+-- See Note [Empty case alternatives] in coreSyn/CoreSyn.hs+atomPrimRep (AnnCase _ _ ty _)      = ASSERT(typePrimRep ty == [LiftedRep]) LiftedRep+atomPrimRep (AnnCoercion {})        = VoidRep+atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate' other))++atomRep :: AnnExpr' Id ann -> ArgRep+atomRep e = toArgRep (atomPrimRep e)++isPtrAtom :: AnnExpr' Id ann -> Bool+isPtrAtom e = isFollowableArg (atomRep e)++-- Let szsw be the sizes in words of some items pushed onto the stack,+-- which has initial depth d'.  Return the values which the stack environment+-- should map these items to.+mkStackOffsets :: Word -> [Word] -> [Word]+mkStackOffsets original_depth szsw+   = map (subtract 1) (tail (scanl (+) original_depth szsw))++typeArgRep :: Type -> ArgRep+typeArgRep = toArgRep . typePrimRep1++-- -----------------------------------------------------------------------------+-- The bytecode generator's monad++data BcM_State+   = BcM_State+        { bcm_hsc_env :: HscEnv+        , uniqSupply  :: UniqSupply      -- for generating fresh variable names+        , thisModule  :: Module          -- current module (for breakpoints)+        , nextlabel   :: Word16          -- for generating local labels+        , ffis        :: [FFIInfo]       -- ffi info blocks, to free later+                                         -- Should be free()d when it is GCd+        , modBreaks   :: Maybe ModBreaks -- info about breakpoints+        , breakInfo   :: IntMap CgBreakInfo+        , topStrings  :: IdEnv (RemotePtr ()) -- top-level string literals+          -- See Note [generating code for top-level string literal bindings].+        }++newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))++ioToBc :: IO a -> BcM a+ioToBc io = BcM $ \st -> do+  x <- io+  return (st, x)++runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks+      -> IdEnv (RemotePtr ())+      -> BcM r+      -> IO (BcM_State, r)+runBc hsc_env us this_mod modBreaks topStrings (BcM m)+   = m (BcM_State hsc_env us this_mod 0 [] modBreaks IntMap.empty topStrings)++thenBc :: BcM a -> (a -> BcM b) -> BcM b+thenBc (BcM expr) cont = BcM $ \st0 -> do+  (st1, q) <- expr st0+  let BcM k = cont q+  (st2, r) <- k st1+  return (st2, r)++thenBc_ :: BcM a -> BcM b -> BcM b+thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do+  (st1, _) <- expr st0+  (st2, r) <- cont st1+  return (st2, r)++returnBc :: a -> BcM a+returnBc result = BcM $ \st -> (return (st, result))++instance Functor BcM where+    fmap = liftM++instance Applicative BcM where+    pure = returnBc+    (<*>) = ap+    (*>) = thenBc_++instance Monad BcM where+  (>>=) = thenBc+  (>>)  = (*>)++instance HasDynFlags BcM where+    getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st))++getHscEnv :: BcM HscEnv+getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st)++emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)+emitBc bco+  = BcM $ \st -> return (st{ffis=[]}, bco (ffis st))++recordFFIBc :: RemotePtr C_ffi_cif -> BcM ()+recordFFIBc a+  = BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ())++getLabelBc :: BcM Word16+getLabelBc+  = BcM $ \st -> do let nl = nextlabel st+                    when (nl == maxBound) $+                        panic "getLabelBc: Ran out of labels"+                    return (st{nextlabel = nl + 1}, nl)++getLabelsBc :: Word16 -> BcM [Word16]+getLabelsBc n+  = BcM $ \st -> let ctr = nextlabel st+                 in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])++getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre))+getCCArray = BcM $ \st ->+  let breaks = expectJust "ByteCodeGen.getCCArray" $ modBreaks st in+  return (st, modBreaks_ccs breaks)+++newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM ()+newBreakInfo ix info = BcM $ \st ->+  return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ())++newUnique :: BcM Unique+newUnique = BcM $+   \st -> case takeUniqFromSupply (uniqSupply st) of+             (uniq, us) -> let newState = st { uniqSupply = us }+                           in  return (newState, uniq)++getCurrentModule :: BcM Module+getCurrentModule = BcM $ \st -> return (st, thisModule st)++getTopStrings :: BcM (IdEnv (RemotePtr ()))+getTopStrings = BcM $ \st -> return (st, topStrings st)++newId :: Type -> BcM Id+newId ty = do+    uniq <- newUnique+    return $ mkSysLocal tickFS uniq ty++tickFS :: FastString+tickFS = fsLit "ticked"
+ ghci/ByteCodeInstr.hs view
@@ -0,0 +1,315 @@+{-# LANGUAGE CPP, MagicHash #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}+--+--  (c) The University of Glasgow 2002-2006+--++-- | ByteCodeInstrs: Bytecode instruction definitions+module ByteCodeInstr (+        BCInstr(..), ProtoBCO(..), bciStackUse,+  ) where++#include "HsVersions.h"+#include "MachDeps.h"++import ByteCodeTypes+import GHCi.RemoteTypes+import GHCi.FFI (C_ffi_cif)+import StgCmmLayout     ( ArgRep(..) )+import PprCore+import Outputable+import FastString+import Name+import Unique+import Id+import CoreSyn+import Literal+import DataCon+import VarSet+import PrimOp+import SMRep++import Data.Word+#if MIN_VERSION_base(4,9,0)+import GHC.Stack.CCS (CostCentre)+#else+import GHC.Stack (CostCentre)+#endif++-- ----------------------------------------------------------------------------+-- Bytecode instructions++data ProtoBCO a+   = ProtoBCO {+        protoBCOName       :: a,          -- name, in some sense+        protoBCOInstrs     :: [BCInstr],  -- instrs+        -- arity and GC info+        protoBCOBitmap     :: [StgWord],+        protoBCOBitmapSize :: Word16,+        protoBCOArity      :: Int,+        -- what the BCO came from+        protoBCOExpr       :: Either  [AnnAlt Id DVarSet] (AnnExpr Id DVarSet),+        -- malloc'd pointers+        protoBCOFFIs       :: [FFIInfo]+   }++type LocalLabel = Word16++data BCInstr+   -- Messing with the stack+   = STKCHECK  Word++   -- Push locals (existing bits of the stack)+   | PUSH_L    !Word16{-offset-}+   | PUSH_LL   !Word16 !Word16{-2 offsets-}+   | PUSH_LLL  !Word16 !Word16 !Word16{-3 offsets-}++   -- Push a ptr  (these all map to PUSH_G really)+   | PUSH_G       Name+   | PUSH_PRIMOP  PrimOp+   | PUSH_BCO     (ProtoBCO Name)++   -- Push an alt continuation+   | PUSH_ALTS          (ProtoBCO Name)+   | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep++   -- Pushing literals+   | PUSH_UBX  Literal Word16+        -- push this int/float/double/addr, on the stack. Word16+        -- is # of words to copy from literal pool.  Eitherness reflects+        -- the difficulty of dealing with MachAddr here, mostly due to+        -- the excessive (and unnecessary) restrictions imposed by the+        -- designers of the new Foreign library.  In particular it is+        -- quite impossible to convert an Addr to any other integral+        -- type, and it appears impossible to get hold of the bits of+        -- an addr, even though we need to assemble BCOs.++   -- various kinds of application+   | PUSH_APPLY_N+   | PUSH_APPLY_V+   | PUSH_APPLY_F+   | PUSH_APPLY_D+   | PUSH_APPLY_L+   | PUSH_APPLY_P+   | PUSH_APPLY_PP+   | PUSH_APPLY_PPP+   | PUSH_APPLY_PPPP+   | PUSH_APPLY_PPPPP+   | PUSH_APPLY_PPPPPP++   | SLIDE     Word16{-this many-} Word16{-down by this much-}++   -- To do with the heap+   | ALLOC_AP  !Word16 -- make an AP with this many payload words+   | ALLOC_AP_NOUPD !Word16 -- make an AP_NOUPD with this many payload words+   | ALLOC_PAP !Word16 !Word16 -- make a PAP with this arity / payload words+   | MKAP      !Word16{-ptr to AP is this far down stack-} !Word16{-number of words-}+   | MKPAP     !Word16{-ptr to PAP is this far down stack-} !Word16{-number of words-}+   | UNPACK    !Word16 -- unpack N words from t.o.s Constr+   | PACK      DataCon !Word16+                        -- after assembly, the DataCon is an index into the+                        -- itbl array+   -- For doing case trees+   | LABEL     LocalLabel+   | TESTLT_I  Int    LocalLabel+   | TESTEQ_I  Int    LocalLabel+   | TESTLT_W  Word   LocalLabel+   | TESTEQ_W  Word   LocalLabel+   | TESTLT_F  Float  LocalLabel+   | TESTEQ_F  Float  LocalLabel+   | TESTLT_D  Double LocalLabel+   | TESTEQ_D  Double LocalLabel++   -- The Word16 value is a constructor number and therefore+   -- stored in the insn stream rather than as an offset into+   -- the literal pool.+   | TESTLT_P  Word16 LocalLabel+   | TESTEQ_P  Word16 LocalLabel++   | CASEFAIL+   | JMP              LocalLabel++   -- For doing calls to C (via glue code generated by libffi)+   | CCALL            Word16    -- stack frame size+                      (RemotePtr C_ffi_cif) -- addr of the glue code+                      Word16    -- whether or not the call is interruptible+                                -- (XXX: inefficient, but I don't know+                                -- what the alignment constraints are.)++   -- For doing magic ByteArray passing to foreign calls+   | SWIZZLE          Word16 -- to the ptr N words down the stack,+                      Word16 -- add M (interpreted as a signed 16-bit entity)++   -- To Infinity And Beyond+   | ENTER+   | RETURN             -- return a lifted value+   | RETURN_UBX ArgRep -- return an unlifted value, here's its rep++   -- Breakpoints+   | BRK_FUN          Word16 Unique (RemotePtr CostCentre)++-- -----------------------------------------------------------------------------+-- Printing bytecode instructions++instance Outputable a => Outputable (ProtoBCO a) where+   ppr (ProtoBCO name instrs bitmap bsize arity origin ffis)+      = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity+                <+> text (show ffis) <> colon)+        $$ nest 3 (case origin of+                      Left alts -> vcat (zipWith (<+>) (char '{' : repeat (char ';'))+                                                       (map (pprCoreAltShort.deAnnAlt) alts)) <+> char '}'+                      Right rhs -> pprCoreExprShort (deAnnotate rhs))+        $$ nest 3 (text "bitmap: " <+> text (show bsize) <+> ppr bitmap)+        $$ nest 3 (vcat (map ppr instrs))++-- Print enough of the Core expression to enable the reader to find+-- the expression in the -ddump-prep output.  That is, we need to+-- include at least a binder.++pprCoreExprShort :: CoreExpr -> SDoc+pprCoreExprShort expr@(Lam _ _)+  = let+        (bndrs, _) = collectBinders expr+    in+    char '\\' <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow <+> text "..."++pprCoreExprShort (Case _expr var _ty _alts)+ = text "case of" <+> ppr var++pprCoreExprShort (Let (NonRec x _) _) = text "let" <+> ppr x <+> ptext (sLit ("= ... in ..."))+pprCoreExprShort (Let (Rec bs) _) = text "let {" <+> ppr (fst (head bs)) <+> ptext (sLit ("= ...; ... } in ..."))++pprCoreExprShort (Tick t e) = ppr t <+> pprCoreExprShort e+pprCoreExprShort (Cast e _) = pprCoreExprShort e <+> text "`cast` T"++pprCoreExprShort e = pprCoreExpr e++pprCoreAltShort :: CoreAlt -> SDoc+pprCoreAltShort (con, args, expr) = ppr con <+> sep (map ppr args) <+> text "->" <+> pprCoreExprShort expr++instance Outputable BCInstr where+   ppr (STKCHECK n)          = text "STKCHECK" <+> ppr n+   ppr (PUSH_L offset)       = text "PUSH_L  " <+> ppr offset+   ppr (PUSH_LL o1 o2)       = text "PUSH_LL " <+> ppr o1 <+> ppr o2+   ppr (PUSH_LLL o1 o2 o3)   = text "PUSH_LLL" <+> ppr o1 <+> ppr o2 <+> ppr o3+   ppr (PUSH_G nm)           = text "PUSH_G  " <+> ppr nm+   ppr (PUSH_PRIMOP op)      = text "PUSH_G  " <+> text "GHC.PrimopWrappers."+                                               <> ppr op+   ppr (PUSH_BCO bco)        = hang (text "PUSH_BCO") 2 (ppr bco)+   ppr (PUSH_ALTS bco)       = hang (text "PUSH_ALTS") 2 (ppr bco)+   ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco)++   ppr (PUSH_UBX lit nw)     = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit+   ppr PUSH_APPLY_N          = text "PUSH_APPLY_N"+   ppr PUSH_APPLY_V          = text "PUSH_APPLY_V"+   ppr PUSH_APPLY_F          = text "PUSH_APPLY_F"+   ppr PUSH_APPLY_D          = text "PUSH_APPLY_D"+   ppr PUSH_APPLY_L          = text "PUSH_APPLY_L"+   ppr PUSH_APPLY_P          = text "PUSH_APPLY_P"+   ppr PUSH_APPLY_PP         = text "PUSH_APPLY_PP"+   ppr PUSH_APPLY_PPP        = text "PUSH_APPLY_PPP"+   ppr PUSH_APPLY_PPPP       = text "PUSH_APPLY_PPPP"+   ppr PUSH_APPLY_PPPPP      = text "PUSH_APPLY_PPPPP"+   ppr PUSH_APPLY_PPPPPP     = text "PUSH_APPLY_PPPPPP"++   ppr (SLIDE n d)           = text "SLIDE   " <+> ppr n <+> ppr d+   ppr (ALLOC_AP sz)         = text "ALLOC_AP   " <+> ppr sz+   ppr (ALLOC_AP_NOUPD sz)   = text "ALLOC_AP_NOUPD   " <+> ppr sz+   ppr (ALLOC_PAP arity sz)  = text "ALLOC_PAP   " <+> ppr arity <+> ppr sz+   ppr (MKAP offset sz)      = text "MKAP    " <+> ppr sz <+> text "words,"+                                               <+> ppr offset <+> text "stkoff"+   ppr (MKPAP offset sz)     = text "MKPAP   " <+> ppr sz <+> text "words,"+                                               <+> ppr offset <+> text "stkoff"+   ppr (UNPACK sz)           = text "UNPACK  " <+> ppr sz+   ppr (PACK dcon sz)        = text "PACK    " <+> ppr dcon <+> ppr sz+   ppr (LABEL     lab)       = text "__"       <> ppr lab <> colon+   ppr (TESTLT_I  i lab)     = text "TESTLT_I" <+> int i <+> text "__" <> ppr lab+   ppr (TESTEQ_I  i lab)     = text "TESTEQ_I" <+> int i <+> text "__" <> ppr lab+   ppr (TESTLT_W  i lab)     = text "TESTLT_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab+   ppr (TESTEQ_W  i lab)     = text "TESTEQ_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab+   ppr (TESTLT_F  f lab)     = text "TESTLT_F" <+> float f <+> text "__" <> ppr lab+   ppr (TESTEQ_F  f lab)     = text "TESTEQ_F" <+> float f <+> text "__" <> ppr lab+   ppr (TESTLT_D  d lab)     = text "TESTLT_D" <+> double d <+> text "__" <> ppr lab+   ppr (TESTEQ_D  d lab)     = text "TESTEQ_D" <+> double d <+> text "__" <> ppr lab+   ppr (TESTLT_P  i lab)     = text "TESTLT_P" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTEQ_P  i lab)     = text "TESTEQ_P" <+> ppr i <+> text "__" <> ppr lab+   ppr CASEFAIL              = text "CASEFAIL"+   ppr (JMP lab)             = text "JMP"      <+> ppr lab+   ppr (CCALL off marshall_addr int) = text "CCALL   " <+> ppr off+                                                <+> text "marshall code at"+                                               <+> text (show marshall_addr)+                                               <+> (if int == 1+                                                    then text "(interruptible)"+                                                    else empty)+   ppr (SWIZZLE stkoff n)    = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff+                                               <+> text "by" <+> ppr n+   ppr ENTER                 = text "ENTER"+   ppr RETURN                = text "RETURN"+   ppr (RETURN_UBX pk)       = text "RETURN_UBX  " <+> ppr pk+   ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> ppr uniq <+> text "<cc>"++-- -----------------------------------------------------------------------------+-- The stack use, in words, of each bytecode insn.  These _must_ be+-- correct, or overestimates of reality, to be safe.++-- NOTE: we aggregate the stack use from case alternatives too, so that+-- we can do a single stack check at the beginning of a function only.++-- This could all be made more accurate by keeping track of a proper+-- stack high water mark, but it doesn't seem worth the hassle.++protoBCOStackUse :: ProtoBCO a -> Word+protoBCOStackUse bco = sum (map bciStackUse (protoBCOInstrs bco))++bciStackUse :: BCInstr -> Word+bciStackUse STKCHECK{}            = 0+bciStackUse PUSH_L{}              = 1+bciStackUse PUSH_LL{}             = 2+bciStackUse PUSH_LLL{}            = 3+bciStackUse PUSH_G{}              = 1+bciStackUse PUSH_PRIMOP{}         = 1+bciStackUse PUSH_BCO{}            = 1+bciStackUse (PUSH_ALTS bco)       = 2 + protoBCOStackUse bco+bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 + protoBCOStackUse bco+bciStackUse (PUSH_UBX _ nw)       = fromIntegral nw+bciStackUse PUSH_APPLY_N{}        = 1+bciStackUse PUSH_APPLY_V{}        = 1+bciStackUse PUSH_APPLY_F{}        = 1+bciStackUse PUSH_APPLY_D{}        = 1+bciStackUse PUSH_APPLY_L{}        = 1+bciStackUse PUSH_APPLY_P{}        = 1+bciStackUse PUSH_APPLY_PP{}       = 1+bciStackUse PUSH_APPLY_PPP{}      = 1+bciStackUse PUSH_APPLY_PPPP{}     = 1+bciStackUse PUSH_APPLY_PPPPP{}    = 1+bciStackUse PUSH_APPLY_PPPPPP{}   = 1+bciStackUse ALLOC_AP{}            = 1+bciStackUse ALLOC_AP_NOUPD{}      = 1+bciStackUse ALLOC_PAP{}           = 1+bciStackUse (UNPACK sz)           = fromIntegral sz+bciStackUse LABEL{}               = 0+bciStackUse TESTLT_I{}            = 0+bciStackUse TESTEQ_I{}            = 0+bciStackUse TESTLT_W{}            = 0+bciStackUse TESTEQ_W{}            = 0+bciStackUse TESTLT_F{}            = 0+bciStackUse TESTEQ_F{}            = 0+bciStackUse TESTLT_D{}            = 0+bciStackUse TESTEQ_D{}            = 0+bciStackUse TESTLT_P{}            = 0+bciStackUse TESTEQ_P{}            = 0+bciStackUse CASEFAIL{}            = 0+bciStackUse JMP{}                 = 0+bciStackUse ENTER{}               = 0+bciStackUse RETURN{}              = 0+bciStackUse RETURN_UBX{}          = 1+bciStackUse CCALL{}               = 0+bciStackUse SWIZZLE{}             = 0+bciStackUse BRK_FUN{}             = 0++-- These insns actually reduce stack use, but we need the high-tide level,+-- so can't use this info.  Not that it matters much.+bciStackUse SLIDE{}               = 0+bciStackUse MKAP{}                = 0+bciStackUse MKPAP{}               = 0+bciStackUse PACK{}                = 1 -- worst case is PACK 0 words
+ ghci/ByteCodeItbls.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-}+{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}+--+--  (c) The University of Glasgow 2002-2006+--++-- | ByteCodeItbls: Generate infotables for interpreter-made bytecodes+module ByteCodeItbls ( mkITbls ) where++#include "HsVersions.h"++import ByteCodeTypes+import GHCi+import DynFlags+import HscTypes+import Name             ( Name, getName )+import NameEnv+import DataCon          ( DataCon, dataConRepArgTys, dataConIdentity )+import TyCon            ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )+import RepType+import StgCmmLayout     ( mkVirtConstrSizes )+import StgCmmClosure    ( tagForCon, NonVoid (..) )+import Util+import Panic++{-+  Manufacturing of info tables for DataCons+-}++-- Make info tables for the data decls in this module+mkITbls :: HscEnv -> [TyCon] -> IO ItblEnv+mkITbls hsc_env tcs =+  foldr plusNameEnv emptyNameEnv <$>+    mapM (mkITbl hsc_env) (filter isDataTyCon tcs)+ where+  mkITbl :: HscEnv -> TyCon -> IO ItblEnv+  mkITbl hsc_env tc+    | dcs `lengthIs` n -- paranoia; this is an assertion.+    = make_constr_itbls hsc_env dcs+       where+          dcs = tyConDataCons tc+          n   = tyConFamilySize tc+  mkITbl _ _ = panic "mkITbl"++mkItblEnv :: [(Name,ItblPtr)] -> ItblEnv+mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs]++-- Assumes constructors are numbered from zero, not one+make_constr_itbls :: HscEnv -> [DataCon] -> IO ItblEnv+make_constr_itbls hsc_env cons =+  mkItblEnv <$> mapM (uncurry mk_itbl) (zip cons [0..])+ where+  dflags = hsc_dflags hsc_env++  mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr)+  mk_itbl dcon conNo = do+     let rep_args = [ NonVoid prim_rep+                    | arg <- dataConRepArgTys dcon+                    , prim_rep <- typePrimRep arg ]++         (tot_wds, ptr_wds) =+             mkVirtConstrSizes dflags rep_args++         ptrs'  = ptr_wds+         nptrs' = tot_wds - ptr_wds+         nptrs_really+            | ptrs' + nptrs' >= mIN_PAYLOAD_SIZE dflags = nptrs'+            | otherwise = mIN_PAYLOAD_SIZE dflags - ptrs'++         descr = dataConIdentity dcon++     r <- iservCmd hsc_env (MkConInfoTable ptrs' nptrs_really+                              conNo (tagForCon dflags dcon) descr)+     return (getName dcon, ItblPtr r)
+ ghci/ByteCodeLink.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UnboxedTuples #-}+{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}+--+--  (c) The University of Glasgow 2002-2006+--++-- | ByteCodeLink: Bytecode assembler and linker+module ByteCodeLink (+        ClosureEnv, emptyClosureEnv, extendClosureEnv,+        linkBCO, lookupStaticPtr,+        lookupIE,+        nameToCLabel, linkFail+  ) where++#include "HsVersions.h"++import GHCi.RemoteTypes+import GHCi.ResolvedBCO+import GHCi.InfoTable+import GHCi.BreakArray+import SizedSeq++import GHCi+import ByteCodeTypes+import HscTypes+import DynFlags+import Name+import NameEnv+import PrimOp+import Module+import FastString+import Panic+import Outputable+import Util++-- Standard libraries+import Data.Array.Unboxed+import Data.Array.Base+import Data.Word+import Foreign.Ptr+import GHC.IO           ( IO(..) )+import GHC.Exts++{-+  Linking interpretables into something we can run+-}++type ClosureEnv = NameEnv (Name, ForeignHValue)++emptyClosureEnv :: ClosureEnv+emptyClosureEnv = emptyNameEnv++extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv+extendClosureEnv cl_env pairs+  = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]++{-+  Linking interpretables into something we can run+-}++linkBCO+  :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray+  -> UnlinkedBCO+  -> IO ResolvedBCO+linkBCO hsc_env ie ce bco_ix breakarray+           (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do+  lits <- mapM (lookupLiteral hsc_env ie) (ssElts lits0)+  ptrs <- mapM (resolvePtr hsc_env ie ce bco_ix breakarray) (ssElts ptrs0)+  let dflags = hsc_dflags hsc_env+  return (ResolvedBCO arity (toWordArray dflags insns) bitmap+              (listArray (0, fromIntegral (sizeSS lits0)-1) lits)+              (addListToSS emptySS ptrs))++-- Turn the insns array from a Word16 array into a Word array.  The+-- latter is much faster to serialize/deserialize. Assumes the input+-- array is zero-indexed.+toWordArray :: DynFlags -> UArray Int Word16 -> UArray Int Word+toWordArray dflags (UArray _ _ n arr) = UArray 0 (n'-1) n' arr+  where n' = (n + w16s_per_word - 1) `quot` w16s_per_word+        w16s_per_word = wORD_SIZE dflags `quot` 2++lookupLiteral :: HscEnv -> ItblEnv -> BCONPtr -> IO Word+lookupLiteral _ _ (BCONPtrWord lit) = return lit+lookupLiteral hsc_env _ (BCONPtrLbl  sym) = do+  Ptr a# <- lookupStaticPtr hsc_env sym+  return (W# (int2Word# (addr2Int# a#)))+lookupLiteral hsc_env ie (BCONPtrItbl nm)  = do+  Ptr a# <- lookupIE hsc_env ie nm+  return (W# (int2Word# (addr2Int# a#)))+lookupLiteral _ _ (BCONPtrStr _) =+  -- should be eliminated during assembleBCOs+  panic "lookupLiteral: BCONPtrStr"++lookupStaticPtr :: HscEnv -> FastString -> IO (Ptr ())+lookupStaticPtr hsc_env addr_of_label_string = do+  m <- lookupSymbol hsc_env addr_of_label_string+  case m of+    Just ptr -> return ptr+    Nothing  -> linkFail "ByteCodeLink: can't find label"+                  (unpackFS addr_of_label_string)++lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr ())+lookupIE hsc_env ie con_nm =+  case lookupNameEnv ie con_nm of+    Just (_, ItblPtr a) -> return (conInfoPtr (fromRemotePtr (castRemotePtr a)))+    Nothing -> do -- try looking up in the object files.+       let sym_to_find1 = nameToCLabel con_nm "con_info"+       m <- lookupSymbol hsc_env sym_to_find1+       case m of+          Just addr -> return addr+          Nothing+             -> do -- perhaps a nullary constructor?+                   let sym_to_find2 = nameToCLabel con_nm "static_info"+                   n <- lookupSymbol hsc_env sym_to_find2+                   case n of+                      Just addr -> return addr+                      Nothing   -> linkFail "ByteCodeLink.lookupIE"+                                      (unpackFS sym_to_find1 ++ " or " +++                                       unpackFS sym_to_find2)++lookupPrimOp :: HscEnv -> PrimOp -> IO (RemotePtr ())+lookupPrimOp hsc_env primop = do+  let sym_to_find = primopToCLabel primop "closure"+  m <- lookupSymbol hsc_env (mkFastString sym_to_find)+  case m of+    Just p -> return (toRemotePtr p)+    Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find++resolvePtr+  :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray+  -> BCOPtr+  -> IO ResolvedBCOPtr+resolvePtr hsc_env _ie ce bco_ix _ (BCOPtrName nm)+  | Just ix <- lookupNameEnv bco_ix nm =+    return (ResolvedBCORef ix) -- ref to another BCO in this group+  | Just (_, rhv) <- lookupNameEnv ce nm =+    return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))+  | otherwise =+    ASSERT2(isExternalName nm, ppr nm)+    do let sym_to_find = nameToCLabel nm "closure"+       m <- lookupSymbol hsc_env sym_to_find+       case m of+         Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))+         Nothing -> linkFail "ByteCodeLink.lookupCE" (unpackFS sym_to_find)+resolvePtr hsc_env _ _ _ _ (BCOPtrPrimOp op) =+  ResolvedBCOStaticPtr <$> lookupPrimOp hsc_env op+resolvePtr hsc_env ie ce bco_ix breakarray (BCOPtrBCO bco) =+  ResolvedBCOPtrBCO <$> linkBCO hsc_env ie ce bco_ix breakarray bco+resolvePtr _ _ _ _ breakarray BCOPtrBreakArray =+  return (ResolvedBCOPtrBreakArray breakarray)++linkFail :: String -> String -> IO a+linkFail who what+   = throwGhcExceptionIO (ProgramError $+        unlines [ "",who+                , "During interactive linking, GHCi couldn't find the following symbol:"+                , ' ' : ' ' : what+                , "This may be due to you not asking GHCi to load extra object files,"+                , "archives or DLLs needed by your current session.  Restart GHCi, specifying"+                , "the missing library using the -L/path/to/object/dir and -lmissinglibname"+                , "flags, or simply by naming the relevant files on the GHCi command line."+                , "Alternatively, this link failure might indicate a bug in GHCi."+                , "If you suspect the latter, please send a bug report to:"+                , "  glasgow-haskell-bugs@haskell.org"+                ])+++nameToCLabel :: Name -> String -> FastString+nameToCLabel n suffix = mkFastString label+  where+    encodeZ = zString . zEncodeFS+    (Module pkgKey modName) = ASSERT( isExternalName n ) nameModule n+    packagePart = encodeZ (unitIdFS pkgKey)+    modulePart  = encodeZ (moduleNameFS modName)+    occPart     = encodeZ (occNameFS (nameOccName n))++    label = concat+        [ if pkgKey == mainUnitId then "" else packagePart ++ "_"+        , modulePart+        , '_':occPart+        , '_':suffix+        ]+++primopToCLabel :: PrimOp -> String -> String+primopToCLabel primop suffix = concat+    [ "ghczmprim_GHCziPrimopWrappers_"+    , zString (zEncodeFS (occNameFS (primOpOcc primop)))+    , '_':suffix+    ]
+ ghci/ByteCodeTypes.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE CPP, MagicHash, RecordWildCards, GeneralizedNewtypeDeriving #-}+--+--  (c) The University of Glasgow 2002-2006+--++-- | Bytecode assembler types+module ByteCodeTypes+  ( CompiledByteCode(..), seqCompiledByteCode, FFIInfo(..)+  , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..)+  , ItblEnv, ItblPtr(..)+  , CgBreakInfo(..)+  , ModBreaks (..), BreakIndex, emptyModBreaks+  , CCostCentre+  ) where++import FastString+import Id+import Name+import NameEnv+import Outputable+import PrimOp+import SizedSeq+import Type+import SrcLoc+import GHCi.BreakArray+import GHCi.RemoteTypes+import GHCi.FFI+import GHCi.InfoTable+import Control.DeepSeq++import Foreign+import Data.Array+import Data.Array.Base  ( UArray(..) )+import Data.ByteString (ByteString)+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+#if MIN_VERSION_base(4,9,0)+import GHC.Stack.CCS+#else+import GHC.Stack as GHC.Stack.CCS+#endif++-- -----------------------------------------------------------------------------+-- Compiled Byte Code++data CompiledByteCode = CompiledByteCode+  { bc_bcos   :: [UnlinkedBCO]  -- Bunch of interpretable bindings+  , bc_itbls  :: ItblEnv        -- A mapping from DataCons to their itbls+  , bc_ffis   :: [FFIInfo]      -- ffi blocks we allocated+  , bc_strs   :: [RemotePtr ()] -- malloc'd strings+  , bc_breaks :: Maybe ModBreaks -- breakpoint info (Nothing if we're not+                                 -- creating breakpoints, for some reason)+  }+                -- ToDo: we're not tracking strings that we malloc'd+newtype FFIInfo = FFIInfo (RemotePtr C_ffi_cif)+  deriving (Show, NFData)++instance Outputable CompiledByteCode where+  ppr CompiledByteCode{..} = ppr bc_bcos++-- Not a real NFData instance, because ModBreaks contains some things+-- we can't rnf+seqCompiledByteCode :: CompiledByteCode -> ()+seqCompiledByteCode CompiledByteCode{..} =+  rnf bc_bcos `seq`+  rnf (nameEnvElts bc_itbls) `seq`+  rnf bc_ffis `seq`+  rnf bc_strs `seq`+  rnf (fmap seqModBreaks bc_breaks)++type ItblEnv = NameEnv (Name, ItblPtr)+        -- We need the Name in the range so we know which+        -- elements to filter out when unloading a module++newtype ItblPtr = ItblPtr (RemotePtr StgInfoTable)+  deriving (Show, NFData)++data UnlinkedBCO+   = UnlinkedBCO {+        unlinkedBCOName   :: !Name,+        unlinkedBCOArity  :: {-# UNPACK #-} !Int,+        unlinkedBCOInstrs :: !(UArray Int Word16),      -- insns+        unlinkedBCOBitmap :: !(UArray Int Word),        -- bitmap+        unlinkedBCOLits   :: !(SizedSeq BCONPtr),       -- non-ptrs+        unlinkedBCOPtrs   :: !(SizedSeq BCOPtr)         -- ptrs+   }++instance NFData UnlinkedBCO where+  rnf UnlinkedBCO{..} =+    rnf unlinkedBCOLits `seq`+    rnf unlinkedBCOPtrs++data BCOPtr+  = BCOPtrName   !Name+  | BCOPtrPrimOp !PrimOp+  | BCOPtrBCO    !UnlinkedBCO+  | BCOPtrBreakArray  -- a pointer to this module's BreakArray++instance NFData BCOPtr where+  rnf (BCOPtrBCO bco) = rnf bco+  rnf x = x `seq` ()++data BCONPtr+  = BCONPtrWord  {-# UNPACK #-} !Word+  | BCONPtrLbl   !FastString+  | BCONPtrItbl  !Name+  | BCONPtrStr   !ByteString++instance NFData BCONPtr where+  rnf x = x `seq` ()++-- | Information about a breakpoint that we know at code-generation time+data CgBreakInfo+   = CgBreakInfo+   { cgb_vars   :: [(Id,Word16)]+   , cgb_resty  :: Type+   }++-- Not a real NFData instance because we can't rnf Id or Type+seqCgBreakInfo :: CgBreakInfo -> ()+seqCgBreakInfo CgBreakInfo{..} =+  rnf (map snd cgb_vars) `seq`+  seqType cgb_resty++instance Outputable UnlinkedBCO where+   ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs)+      = sep [text "BCO", ppr nm, text "with",+             ppr (sizeSS lits), text "lits",+             ppr (sizeSS ptrs), text "ptrs" ]++instance Outputable CgBreakInfo where+   ppr info = text "CgBreakInfo" <+>+              parens (ppr (cgb_vars info) <+>+                      ppr (cgb_resty info))++-- -----------------------------------------------------------------------------+-- Breakpoints++-- | Breakpoint index+type BreakIndex = Int++-- | C CostCentre type+data CCostCentre++-- | All the information about the breakpoints for a module+data ModBreaks+   = ModBreaks+   { modBreaks_flags :: ForeignRef BreakArray+        -- ^ The array of flags, one per breakpoint,+        -- indicating which breakpoints are enabled.+   , modBreaks_locs :: !(Array BreakIndex SrcSpan)+        -- ^ An array giving the source span of each breakpoint.+   , modBreaks_vars :: !(Array BreakIndex [OccName])+        -- ^ An array giving the names of the free variables at each breakpoint.+   , modBreaks_decls :: !(Array BreakIndex [String])+        -- ^ An array giving the names of the declarations enclosing each breakpoint.+   , modBreaks_ccs :: !(Array BreakIndex (RemotePtr CostCentre))+        -- ^ Array pointing to cost centre for each breakpoint+   , modBreaks_breakInfo :: IntMap CgBreakInfo+        -- ^ info about each breakpoint from the bytecode generator+   }++seqModBreaks :: ModBreaks -> ()+seqModBreaks ModBreaks{..} =+  rnf modBreaks_flags `seq`+  rnf modBreaks_locs `seq`+  rnf modBreaks_vars `seq`+  rnf modBreaks_decls `seq`+  rnf modBreaks_ccs `seq`+  rnf (fmap seqCgBreakInfo modBreaks_breakInfo)++-- | Construct an empty ModBreaks+emptyModBreaks :: ModBreaks+emptyModBreaks = ModBreaks+   { modBreaks_flags = error "ModBreaks.modBreaks_array not initialised"+         -- ToDo: can we avoid this?+   , modBreaks_locs  = array (0,-1) []+   , modBreaks_vars  = array (0,-1) []+   , modBreaks_decls = array (0,-1) []+   , modBreaks_ccs = array (0,-1) []+   , modBreaks_breakInfo = IntMap.empty+   }
+ ghci/Debugger.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE MagicHash #-}++-----------------------------------------------------------------------------+--+-- GHCi Interactive debugging commands+--+-- Pepe Iborra (supported by Google SoC) 2006+--+-- ToDo: lots of violation of layering here.  This module should+-- decide whether it is above the GHC API (import GHC and nothing+-- else) or below it.+--+-----------------------------------------------------------------------------++module Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where++import Linker+import RtClosureInspect++import GHCi+import GHCi.RemoteTypes+import GhcMonad+import HscTypes+import Id+import IfaceSyn ( showToHeader )+import IfaceEnv( newInteractiveBinder )+import Name+import Var hiding ( varName )+import VarSet+import UniqSet+import Type+import GHC+import Outputable+import PprTyThing+import ErrUtils+import MonadUtils+import DynFlags+import Exception++import Control.Monad+import Data.List+import Data.Maybe+import Data.IORef++import GHC.Exts++-------------------------------------+-- | The :print & friends commands+-------------------------------------+pprintClosureCommand :: GhcMonad m => Bool -> Bool -> String -> m ()+pprintClosureCommand bindThings force str = do+  tythings <- (catMaybes . concat) `liftM`+                 mapM (\w -> GHC.parseName w >>=+                                mapM GHC.lookupName)+                      (words str)+  let ids = [id | AnId id <- tythings]++  -- Obtain the terms and the recovered type information+  (subst, terms) <- mapAccumLM go emptyTCvSubst ids++  -- Apply the substitutions obtained after recovering the types+  modifySession $ \hsc_env ->+    hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst}++  -- Finally, print the Terms+  unqual  <- GHC.getPrintUnqual+  docterms <- mapM showTerm terms+  dflags <- getDynFlags+  liftIO $ (printOutputForUser dflags unqual . vcat)+           (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)+                    ids+                    docterms)+ where+   -- Do the obtainTerm--bindSuspensions-computeSubstitution dance+   go :: GhcMonad m => TCvSubst -> Id -> m (TCvSubst, Term)+   go subst id = do+       let id' = id `setIdType` substTy subst (idType id)+       term_    <- GHC.obtainTermFromId maxBound force id'+       term     <- tidyTermTyVars term_+       term'    <- if bindThings &&+                      (not (isUnliftedType (termType term)))+                     then bindSuspensions term+                     else return term+     -- Before leaving, we compare the type obtained to see if it's more specific+     --  Then, we extract a substitution,+     --  mapping the old tyvars to the reconstructed types.+       let reconstructed_type = termType term+       hsc_env <- getSession+       case (improveRTTIType hsc_env (idType id) (reconstructed_type)) of+         Nothing     -> return (subst, term')+         Just subst' -> do { traceOptIf Opt_D_dump_rtti+                               (fsep $ [text "RTTI Improvement for", ppr id,+                                text "is the substitution:" , ppr subst'])+                           ; return (subst `unionTCvSubst` subst', term')}++   tidyTermTyVars :: GhcMonad m => Term -> m Term+   tidyTermTyVars t =+     withSession $ \hsc_env -> do+     let env_tvs      = tyThingsTyCoVars $ ic_tythings $ hsc_IC hsc_env+         my_tvs       = termTyCoVars t+         tvs          = env_tvs `minusVarSet` my_tvs+         tyvarOccName = nameOccName . tyVarName+         tidyEnv      = (initTidyOccEnv (map tyvarOccName (nonDetEltsUniqSet tvs))+           -- It's OK to use nonDetEltsUniqSet here because initTidyOccEnv+           -- forgets the ordering immediately by creating an env+                        , getUniqSet $ env_tvs `intersectVarSet` my_tvs)+     return $ mapTermType (snd . tidyOpenType tidyEnv) t++-- | Give names, and bind in the interactive environment, to all the suspensions+--   included (inductively) in a term+bindSuspensions :: GhcMonad m => Term -> m Term+bindSuspensions t = do+      hsc_env <- getSession+      inScope <- GHC.getBindings+      let ictxt        = hsc_IC hsc_env+          prefix       = "_t"+          alreadyUsedNames = map (occNameString . nameOccName . getName) inScope+          availNames   = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames+      availNames_var  <- liftIO $ newIORef availNames+      (t', stuff)     <- liftIO $ foldTerm (nameSuspensionsAndGetInfos hsc_env availNames_var) t+      let (names, tys, hvals) = unzip3 stuff+      let ids = [ mkVanillaGlobal name ty+                | (name,ty) <- zip names tys]+          new_ic = extendInteractiveContextWithIds ictxt ids+      fhvs <- liftIO $ mapM (mkFinalizedHValue hsc_env <=< mkRemoteRef) hvals+      liftIO $ extendLinkEnv (zip names fhvs)+      setSession hsc_env {hsc_IC = new_ic }+      return t'+     where++--    Processing suspensions. Give names and recopilate info+        nameSuspensionsAndGetInfos :: HscEnv -> IORef [String]+                                   -> TermFold (IO (Term, [(Name,Type,HValue)]))+        nameSuspensionsAndGetInfos hsc_env freeNames = TermFold+                      {+                        fSuspension = doSuspension hsc_env freeNames+                      , fTerm = \ty dc v tt -> do+                                    tt' <- sequence tt+                                    let (terms,names) = unzip tt'+                                    return (Term ty dc v terms, concat names)+                      , fPrim    = \ty n ->return (Prim ty n,[])+                      , fNewtypeWrap  =+                                \ty dc t -> do+                                    (term, names) <- t+                                    return (NewtypeWrap ty dc term, names)+                      , fRefWrap = \ty t -> do+                                    (term, names) <- t+                                    return (RefWrap ty term, names)+                      }+        doSuspension hsc_env freeNames ct ty hval _name = do+          name <- atomicModifyIORef' freeNames (\x->(tail x, head x))+          n <- newGrimName hsc_env name+          return (Suspension ct ty hval (Just n), [(n,ty,hval)])+++--  A custom Term printer to enable the use of Show instances+showTerm :: GhcMonad m => Term -> m SDoc+showTerm term = do+    dflags       <- GHC.getSessionDynFlags+    if gopt Opt_PrintEvldWithShow dflags+       then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term+       else cPprTerm cPprTermBase term+ where+  cPprShowable prec t@Term{ty=ty, val=val} =+    if not (isFullyEvaluatedTerm t)+     then return Nothing+     else do+        hsc_env <- getSession+        dflags  <- GHC.getSessionDynFlags+        do+           (new_env, bname) <- bindToFreshName hsc_env ty "showme"+           setSession new_env+                      -- XXX: this tries to disable logging of errors+                      -- does this still do what it is intended to do+                      -- with the changed error handling and logging?+           let noop_log _ _ _ _ _ _ = return ()+               expr = "show " ++ showPpr dflags bname+           _ <- GHC.setSessionDynFlags dflags{log_action=noop_log}+           fhv <- liftIO $ mkFinalizedHValue hsc_env =<< mkRemoteRef val+           txt_ <- withExtendedLinkEnv [(bname, fhv)]+                                       (GHC.compileExpr expr)+           let myprec = 10 -- application precedence. TODO Infix constructors+           let txt = unsafeCoerce# txt_ :: [a]+           if not (null txt) then+             return $ Just $ cparen (prec >= myprec && needsParens txt)+                                    (text txt)+            else return Nothing+         `gfinally` do+           setSession hsc_env+           GHC.setSessionDynFlags dflags+  cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} =+      cPprShowable prec t{ty=new_ty}+  cPprShowable _ _ = return Nothing++  needsParens ('"':_) = False   -- some simple heuristics to see whether parens+                                -- are redundant in an arbitrary Show output+  needsParens ('(':_) = False+  needsParens txt = ' ' `elem` txt+++  bindToFreshName hsc_env ty userName = do+    name <- newGrimName hsc_env userName+    let id       = mkVanillaGlobal name ty+        new_ic   = extendInteractiveContextWithIds (hsc_IC hsc_env) [id]+    return (hsc_env {hsc_IC = new_ic }, name)++--    Create new uniques and give them sequentially numbered names+newGrimName :: MonadIO m => HscEnv -> String -> m Name+newGrimName hsc_env userName+  = liftIO (newInteractiveBinder hsc_env occ noSrcSpan)+  where+    occ = mkOccName varName userName++pprTypeAndContents :: GhcMonad m => Id -> m SDoc+pprTypeAndContents id = do+  dflags  <- GHC.getSessionDynFlags+  let pcontents = gopt Opt_PrintBindContents dflags+      pprdId    = (pprTyThing showToHeader . AnId) id+  if pcontents+    then do+      let depthBound = 100+      -- If the value is an exception, make sure we catch it and+      -- show the exception, rather than propagating the exception out.+      e_term <- gtry $ GHC.obtainTermFromId depthBound False id+      docs_term <- case e_term of+                      Right term -> showTerm term+                      Left  exn  -> return (text "*** Exception:" <+>+                                            text (show (exn :: SomeException)))+      return $ pprdId <+> equals <+> docs_term+    else return pprdId++--------------------------------------------------------------+-- Utils++traceOptIf :: GhcMonad m => DumpFlag -> SDoc -> m ()+traceOptIf flag doc = do+  dflags <- GHC.getSessionDynFlags+  when (dopt flag dflags) $ liftIO $ printInfoForUser dflags alwaysQualify doc
+ ghci/DebuggerUtils.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE CPP #-}++module DebuggerUtils (+       dataConInfoPtrToName,+  ) where++import GHCi.InfoTable+import CmmInfo ( stdInfoTableSizeB )+import DynFlags+import FastString+import TcRnTypes+import TcRnMonad+import IfaceEnv+import Module+import OccName+import Name+import Outputable+import Util++import Data.Char+import Foreign+import Data.List++#include "HsVersions.h"++-- | Given a data constructor in the heap, find its Name.+--   The info tables for data constructors have a field which records+--   the source name of the constructor as a Ptr Word8 (UTF-8 encoded+--   string). The format is:+--+--   > Package:Module.Name+--+--   We use this string to lookup the interpreter's internal representation of the name+--   using the lookupOrig.+--+dataConInfoPtrToName :: Ptr () -> TcM (Either String Name)+dataConInfoPtrToName x = do+   dflags <- getDynFlags+   theString <- liftIO $ do+      let ptr = castPtr x :: Ptr StgInfoTable+      conDescAddress <- getConDescAddress dflags ptr+      peekArray0 0 conDescAddress+   let (pkg, mod, occ) = parse theString+       pkgFS = mkFastStringByteList pkg+       modFS = mkFastStringByteList mod+       occFS = mkFastStringByteList occ+       occName = mkOccNameFS OccName.dataName occFS+       modName = mkModule (fsToUnitId pkgFS) (mkModuleNameFS modFS)+   return (Left $ showSDoc dflags $ ppr modName <> dot <> ppr occName)+    `recoverM` (Right `fmap` lookupOrig modName occName)++   where++   {- To find the string in the constructor's info table we need to consider+      the layout of info tables relative to the entry code for a closure.++      An info table can be next to the entry code for the closure, or it can+      be separate. The former (faster) is used in registerised versions of ghc,+      and the latter (portable) is for non-registerised versions.++      The diagrams below show where the string is to be found relative to+      the normal info table of the closure.++      1) Code next to table:++         --------------+         |            |   <- pointer to the start of the string+         --------------+         |            |   <- the (start of the) info table structure+         |            |+         |            |+         --------------+         | entry code |+         |    ....    |++         In this case the pointer to the start of the string can be found in+         the memory location _one word before_ the first entry in the normal info+         table.++      2) Code NOT next to table:++                                 --------------+         info table structure -> |     *------------------> --------------+                                 |            |             | entry code |+                                 |            |             |    ....    |+                                 --------------+         ptr to start of str ->  |            |+                                 --------------++         In this case the pointer to the start of the string can be found+         in the memory location: info_table_ptr + info_table_size+   -}++   getConDescAddress :: DynFlags -> Ptr StgInfoTable -> IO (Ptr Word8)+   getConDescAddress dflags ptr+    | ghciTablesNextToCode = do+       let ptr' = ptr `plusPtr` (- wORD_SIZE dflags)+       -- NB. the offset must be read as an Int32 not a Word32, so+       -- that the sign is preserved when converting to an Int.+       offsetToString <- fromIntegral <$> (peek ptr' :: IO Int32)+       return $ (ptr `plusPtr` stdInfoTableSizeB dflags) `plusPtr` offsetToString+    | otherwise =+       peek $ intPtrToPtr $ ptrToIntPtr ptr + fromIntegral (stdInfoTableSizeB dflags)+   -- parsing names is a little bit fiddly because we have a string in the form:+   -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo").+   -- Thus we split at the leftmost colon and the rightmost occurrence of the dot.+   -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas+   -- this is not the conventional way of writing Haskell names. We stick with+   -- convention, even though it makes the parsing code more troublesome.+   -- Warning: this code assumes that the string is well formed.+   parse :: [Word8] -> ([Word8], [Word8], [Word8])+   parse input+      = ASSERT(all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ)+      where+      dot = fromIntegral (ord '.')+      (pkg, rest1) = break (== fromIntegral (ord ':')) input+      (mod, occ)+         = (concat $ intersperse [dot] $ reverse modWords, occWord)+         where+         (modWords, occWord) = ASSERT(length rest1 > 0) (parseModOcc [] (tail rest1))+      parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])+      -- We only look for dots if str could start with a module name,+      -- i.e. if it starts with an upper case character.+      -- Otherwise we might think that "X.:->" is the module name in+      -- "X.:->.+", whereas actually "X" is the module name and+      -- ":->.+" is a constructor name.+      parseModOcc acc str@(c : _)+       | isUpper $ chr $ fromIntegral c+         = case break (== dot) str of+              (top, []) -> (acc, top)+              (top, _ : bot) -> parseModOcc (top : acc) bot+      parseModOcc acc str = (acc, str)
+ ghci/GHCi.hsc view
@@ -0,0 +1,677 @@+{-# LANGUAGE RecordWildCards, ScopedTypeVariables, BangPatterns, CPP #-}++--+-- | Interacting with the interpreter, whether it is running on an+-- external process or in the current process.+--+module GHCi+  ( -- * High-level interface to the interpreter+    evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..)+  , resumeStmt+  , abandonStmt+  , evalIO+  , evalString+  , evalStringToIOString+  , mallocData+  , createBCOs+  , addSptEntry+  , mkCostCentres+  , costCentreStackInfo+  , newBreakArray+  , enableBreakpoint+  , breakpointStatus+  , getBreakpointVar++  -- * The object-code linker+  , initObjLinker+  , lookupSymbol+  , lookupClosure+  , loadDLL+  , loadArchive+  , loadObj+  , unloadObj+  , addLibrarySearchPath+  , removeLibrarySearchPath+  , resolveObjs+  , findSystemLibrary++  -- * Lower-level API using messages+  , iservCmd, Message(..), withIServ, stopIServ+  , iservCall, readIServ, writeIServ+  , purgeLookupSymbolCache+  , freeHValueRefs+  , mkFinalizedHValue+  , wormhole, wormholeRef+  , mkEvalOpts+  , fromEvalResult+  ) where++import GHCi.Message+#ifdef GHCI+import GHCi.Run+#endif+import GHCi.RemoteTypes+import GHCi.ResolvedBCO+import GHCi.BreakArray (BreakArray)+import Fingerprint+import HscTypes+import UniqFM+import Panic+import DynFlags+import ErrUtils+import Outputable+import Exception+import BasicTypes+import FastString+import Util+import Hooks++import Control.Concurrent+import Control.Monad+import Control.Monad.IO.Class+import Data.Binary+import Data.Binary.Put+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LB+import Data.IORef+import Foreign hiding (void)+#if MIN_VERSION_base(4,9,0)+import GHC.Stack.CCS (CostCentre,CostCentreStack)+#else+import GHC.Stack (CostCentre,CostCentreStack)+#endif+import System.Exit+import Data.Maybe+import GHC.IO.Handle.Types (Handle)+#ifdef mingw32_HOST_OS+import Foreign.C+import GHC.IO.Handle.FD (fdToHandle)+#if !MIN_VERSION_process(1,4,2)+import System.Posix.Internals+import Foreign.Marshal.Array+import Foreign.C.Error+import Foreign.Storable+#endif+#else+import System.Posix as Posix+#endif+import System.Directory+import System.Process+import GHC.Conc (getNumProcessors, pseq, par)++{- Note [Remote GHCi]++When the flag -fexternal-interpreter is given to GHC, interpreted code+is run in a separate process called iserv, and we communicate with the+external process over a pipe using Binary-encoded messages.++Motivation+~~~~~~~~~~++When the interpreted code is running in a separate process, it can+use a different "way", e.g. profiled or dynamic.  This means++- compiling Template Haskell code with -prof does not require+  building the code without -prof first++- when GHC itself is profiled, it can interpret unprofiled code,+  and the same applies to dynamic linking.++- An unprofiled GHCi can load and run profiled code, which means it+  can use the stack-trace functionality provided by profiling without+  taking the performance hit on the compiler that profiling would+  entail.++For other reasons see RemoteGHCi on the wiki.++Implementation Overview+~~~~~~~~~~~~~~~~~~~~~~~++The main pieces are:++- libraries/ghci, containing:+  - types for talking about remote values (GHCi.RemoteTypes)+  - the message protocol (GHCi.Message),+  - implementation of the messages (GHCi.Run)+  - implementation of Template Haskell (GHCi.TH)+  - a few other things needed to run interpreted code++- top-level iserv directory, containing the codefor the external+  server.  This is a fairly simple wrapper, most of the functionality+  is provided by modules in libraries/ghci.++- This module (GHCi) which provides the interface to the server used+  by the rest of GHC.++GHC works with and without -fexternal-interpreter.  With the flag, all+interpreted code is run by the iserv binary.  Without the flag,+interpreted code is run in the same process as GHC.++Things that do not work with -fexternal-interpreter+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++dynCompileExpr cannot work, because we have no way to run code of an+unknown type in the remote process.  This API fails with an error+message if it is used with -fexternal-interpreter.++Other Notes on Remote GHCi+~~~~~~~~~~~~~~~~~~~~~~~~~~+  * This wiki page has an implementation overview:+    https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/ExternalInterpreter+  * Note [External GHCi pointers] in compiler/ghci/GHCi.hs+  * Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs+-}++#ifndef GHCI+needExtInt :: IO a+needExtInt = throwIO+  (InstallationError "this operation requires -fexternal-interpreter")+#endif++-- | Run a command in the interpreter's context.  With+-- @-fexternal-interpreter@, the command is serialized and sent to an+-- external iserv process, and the response is deserialized (hence the+-- @Binary@ constraint).  With @-fno-external-interpreter@ we execute+-- the command directly here.+iservCmd :: Binary a => HscEnv -> Message a -> IO a+iservCmd hsc_env@HscEnv{..} msg+ | gopt Opt_ExternalInterpreter hsc_dflags =+     withIServ hsc_env $ \iserv ->+       uninterruptibleMask_ $ do -- Note [uninterruptibleMask_]+         iservCall iserv msg+ | otherwise = -- Just run it directly+#ifdef GHCI+   run msg+#else+   needExtInt+#endif++-- Note [uninterruptibleMask_ and iservCmd]+--+-- If we receive an async exception, such as ^C, while communicating+-- with the iserv process then we will be out-of-sync and not be able+-- to recoever.  Thus we use uninterruptibleMask_ during+-- communication.  A ^C will be delivered to the iserv process (because+-- signals get sent to the whole process group) which will interrupt+-- the running computation and return an EvalException result.++-- | Grab a lock on the 'IServ' and do something with it.+-- Overloaded because this is used from TcM as well as IO.+withIServ+  :: (MonadIO m, ExceptionMonad m)+  => HscEnv -> (IServ -> m a) -> m a+withIServ HscEnv{..} action =+  gmask $ \restore -> do+    m <- liftIO $ takeMVar hsc_iserv+      -- start the iserv process if we haven't done so yet+    iserv <- maybe (liftIO $ startIServ hsc_dflags) return m+               `gonException` (liftIO $ putMVar hsc_iserv Nothing)+      -- free any ForeignHValues that have been garbage collected.+    let iserv' = iserv{ iservPendingFrees = [] }+    a <- (do+      liftIO $ when (not (null (iservPendingFrees iserv))) $+        iservCall iserv (FreeHValueRefs (iservPendingFrees iserv))+        -- run the inner action+      restore $ action iserv)+          `gonException` (liftIO $ putMVar hsc_iserv (Just iserv'))+    liftIO $ putMVar hsc_iserv (Just iserv')+    return a+++-- -----------------------------------------------------------------------------+-- Wrappers around messages++-- | Execute an action of type @IO [a]@, returning 'ForeignHValue's for+-- each of the results.+evalStmt+  :: HscEnv -> Bool -> EvalExpr ForeignHValue+  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])+evalStmt hsc_env step foreign_expr = do+  let dflags = hsc_dflags hsc_env+  status <- withExpr foreign_expr $ \expr ->+    iservCmd hsc_env (EvalStmt (mkEvalOpts dflags step) expr)+  handleEvalStatus hsc_env status+ where+  withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a+  withExpr (EvalThis fhv) cont =+    withForeignRef fhv $ \hvref -> cont (EvalThis hvref)+  withExpr (EvalApp fl fr) cont =+    withExpr fl $ \fl' ->+    withExpr fr $ \fr' ->+    cont (EvalApp fl' fr')++resumeStmt+  :: HscEnv -> Bool -> ForeignRef (ResumeContext [HValueRef])+  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])+resumeStmt hsc_env step resume_ctxt = do+  let dflags = hsc_dflags hsc_env+  status <- withForeignRef resume_ctxt $ \rhv ->+    iservCmd hsc_env (ResumeStmt (mkEvalOpts dflags step) rhv)+  handleEvalStatus hsc_env status++abandonStmt :: HscEnv -> ForeignRef (ResumeContext [HValueRef]) -> IO ()+abandonStmt hsc_env resume_ctxt = do+  withForeignRef resume_ctxt $ \rhv ->+    iservCmd hsc_env (AbandonStmt rhv)++handleEvalStatus+  :: HscEnv -> EvalStatus [HValueRef]+  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])+handleEvalStatus hsc_env status =+  case status of+    EvalBreak a b c d e f -> return (EvalBreak a b c d e f)+    EvalComplete alloc res ->+      EvalComplete alloc <$> addFinalizer res+ where+  addFinalizer (EvalException e) = return (EvalException e)+  addFinalizer (EvalSuccess rs) = do+    EvalSuccess <$> mapM (mkFinalizedHValue hsc_env) rs++-- | Execute an action of type @IO ()@+evalIO :: HscEnv -> ForeignHValue -> IO ()+evalIO hsc_env fhv = do+  liftIO $ withForeignRef fhv $ \fhv ->+    iservCmd hsc_env (EvalIO fhv) >>= fromEvalResult++-- | Execute an action of type @IO String@+evalString :: HscEnv -> ForeignHValue -> IO String+evalString hsc_env fhv = do+  liftIO $ withForeignRef fhv $ \fhv ->+    iservCmd hsc_env (EvalString fhv) >>= fromEvalResult++-- | Execute an action of type @String -> IO String@+evalStringToIOString :: HscEnv -> ForeignHValue -> String -> IO String+evalStringToIOString hsc_env fhv str = do+  liftIO $ withForeignRef fhv $ \fhv ->+    iservCmd hsc_env (EvalStringToString fhv str) >>= fromEvalResult+++-- | Allocate and store the given bytes in memory, returning a pointer+-- to the memory in the remote process.+mallocData :: HscEnv -> ByteString -> IO (RemotePtr ())+mallocData hsc_env bs = iservCmd hsc_env (MallocData bs)++mkCostCentres+  :: HscEnv -> String -> [(String,String)] -> IO [RemotePtr CostCentre]+mkCostCentres hsc_env mod ccs =+  iservCmd hsc_env (MkCostCentres mod ccs)++-- | Create a set of BCOs that may be mutually recursive.+createBCOs :: HscEnv -> [ResolvedBCO] -> IO [HValueRef]+createBCOs hsc_env rbcos = do+  n_jobs <- case parMakeCount (hsc_dflags hsc_env) of+              Nothing -> liftIO getNumProcessors+              Just n  -> return n+  -- Serializing ResolvedBCO is expensive, so if we're in parallel mode+  -- (-j<n>) parallelise the serialization.+  if (n_jobs == 1)+    then+      iservCmd hsc_env (CreateBCOs [runPut (put rbcos)])++    else do+      old_caps <- getNumCapabilities+      if old_caps == n_jobs+         then void $ evaluate puts+         else bracket_ (setNumCapabilities n_jobs)+                       (setNumCapabilities old_caps)+                       (void $ evaluate puts)+      iservCmd hsc_env (CreateBCOs puts)+ where+  puts = parMap doChunk (chunkList 100 rbcos)++  -- make sure we force the whole lazy ByteString+  doChunk c = pseq (LB.length bs) bs+    where bs = runPut (put c)++  -- We don't have the parallel package, so roll our own simple parMap+  parMap _ [] = []+  parMap f (x:xs) = fx `par` (fxs `pseq` (fx : fxs))+    where fx = f x; fxs = parMap f xs++addSptEntry :: HscEnv -> Fingerprint -> ForeignHValue -> IO ()+addSptEntry hsc_env fpr ref =+  withForeignRef ref $ \val ->+    iservCmd hsc_env (AddSptEntry fpr val)++costCentreStackInfo :: HscEnv -> RemotePtr CostCentreStack -> IO [String]+costCentreStackInfo hsc_env ccs =+  iservCmd hsc_env (CostCentreStackInfo ccs)++newBreakArray :: HscEnv -> Int -> IO (ForeignRef BreakArray)+newBreakArray hsc_env size = do+  breakArray <- iservCmd hsc_env (NewBreakArray size)+  mkFinalizedHValue hsc_env breakArray++enableBreakpoint :: HscEnv -> ForeignRef BreakArray -> Int -> Bool -> IO ()+enableBreakpoint hsc_env ref ix b = do+  withForeignRef ref $ \breakarray ->+    iservCmd hsc_env (EnableBreakpoint breakarray ix b)++breakpointStatus :: HscEnv -> ForeignRef BreakArray -> Int -> IO Bool+breakpointStatus hsc_env ref ix = do+  withForeignRef ref $ \breakarray ->+    iservCmd hsc_env (BreakpointStatus breakarray ix)++getBreakpointVar :: HscEnv -> ForeignHValue -> Int -> IO (Maybe ForeignHValue)+getBreakpointVar hsc_env ref ix =+  withForeignRef ref $ \apStack -> do+    mb <- iservCmd hsc_env (GetBreakpointVar apStack ix)+    mapM (mkFinalizedHValue hsc_env) mb++-- -----------------------------------------------------------------------------+-- Interface to the object-code linker++initObjLinker :: HscEnv -> IO ()+initObjLinker hsc_env = iservCmd hsc_env InitLinker++lookupSymbol :: HscEnv -> FastString -> IO (Maybe (Ptr ()))+lookupSymbol hsc_env@HscEnv{..} str+ | gopt Opt_ExternalInterpreter hsc_dflags =+     -- Profiling of GHCi showed a lot of time and allocation spent+     -- making cross-process LookupSymbol calls, so I added a GHC-side+     -- cache which sped things up quite a lot.  We have to be careful+     -- to purge this cache when unloading code though.+     withIServ hsc_env $ \iserv@IServ{..} -> do+       cache <- readIORef iservLookupSymbolCache+       case lookupUFM cache str of+         Just p -> return (Just p)+         Nothing -> do+           m <- uninterruptibleMask_ $+                    iservCall iserv (LookupSymbol (unpackFS str))+           case m of+             Nothing -> return Nothing+             Just r -> do+               let p = fromRemotePtr r+               writeIORef iservLookupSymbolCache $! addToUFM cache str p+               return (Just p)+ | otherwise =+#ifdef GHCI+   fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str))+#else+   needExtInt+#endif++lookupClosure :: HscEnv -> String -> IO (Maybe HValueRef)+lookupClosure hsc_env str =+  iservCmd hsc_env (LookupClosure str)++purgeLookupSymbolCache :: HscEnv -> IO ()+purgeLookupSymbolCache hsc_env@HscEnv{..} =+ when (gopt Opt_ExternalInterpreter hsc_dflags) $+   withIServ hsc_env $ \IServ{..} ->+     writeIORef iservLookupSymbolCache emptyUFM+++-- | loadDLL loads a dynamic library using the OS's native linker+-- (i.e. dlopen() on Unix, LoadLibrary() on Windows).  It takes either+-- an absolute pathname to the file, or a relative filename+-- (e.g. "libfoo.so" or "foo.dll").  In the latter case, loadDLL+-- searches the standard locations for the appropriate library.+--+-- Returns:+--+-- Nothing      => success+-- Just err_msg => failure+loadDLL :: HscEnv -> String -> IO (Maybe String)+loadDLL hsc_env str = iservCmd hsc_env (LoadDLL str)++loadArchive :: HscEnv -> String -> IO ()+loadArchive hsc_env path = do+  path' <- canonicalizePath path -- Note [loadObj and relative paths]+  iservCmd hsc_env (LoadArchive path')++loadObj :: HscEnv -> String -> IO ()+loadObj hsc_env path = do+  path' <- canonicalizePath path -- Note [loadObj and relative paths]+  iservCmd hsc_env (LoadObj path')++unloadObj :: HscEnv -> String -> IO ()+unloadObj hsc_env path = do+  path' <- canonicalizePath path -- Note [loadObj and relative paths]+  iservCmd hsc_env (UnloadObj path')++-- Note [loadObj and relative paths]+-- the iserv process might have a different current directory from the+-- GHC process, so we must make paths absolute before sending them+-- over.++addLibrarySearchPath :: HscEnv -> String -> IO (Ptr ())+addLibrarySearchPath hsc_env str =+  fromRemotePtr <$> iservCmd hsc_env (AddLibrarySearchPath str)++removeLibrarySearchPath :: HscEnv -> Ptr () -> IO Bool+removeLibrarySearchPath hsc_env p =+  iservCmd hsc_env (RemoveLibrarySearchPath (toRemotePtr p))++resolveObjs :: HscEnv -> IO SuccessFlag+resolveObjs hsc_env = successIf <$> iservCmd hsc_env ResolveObjs++findSystemLibrary :: HscEnv -> String -> IO (Maybe String)+findSystemLibrary hsc_env str = iservCmd hsc_env (FindSystemLibrary str)+++-- -----------------------------------------------------------------------------+-- Raw calls and messages++-- | Send a 'Message' and receive the response from the iserv process+iservCall :: Binary a => IServ -> Message a -> IO a+iservCall iserv@IServ{..} msg =+  remoteCall iservPipe msg+    `catch` \(e :: SomeException) -> handleIServFailure iserv e++-- | Read a value from the iserv process+readIServ :: IServ -> Get a -> IO a+readIServ iserv@IServ{..} get =+  readPipe iservPipe get+    `catch` \(e :: SomeException) -> handleIServFailure iserv e++-- | Send a value to the iserv process+writeIServ :: IServ -> Put -> IO ()+writeIServ iserv@IServ{..} put =+  writePipe iservPipe put+    `catch` \(e :: SomeException) -> handleIServFailure iserv e++handleIServFailure :: IServ -> SomeException -> IO a+handleIServFailure IServ{..} e = do+  ex <- getProcessExitCode iservProcess+  case ex of+    Just (ExitFailure n) ->+      throw (InstallationError ("ghc-iserv terminated (" ++ show n ++ ")"))+    _ -> do+      terminateProcess iservProcess+      _ <- waitForProcess iservProcess+      throw e++-- -----------------------------------------------------------------------------+-- Starting and stopping the iserv process++startIServ :: DynFlags -> IO IServ+startIServ dflags = do+  let flavour+        | WayProf `elem` ways dflags = "-prof"+        | WayDyn `elem` ways dflags = "-dyn"+        | otherwise = ""+      prog = pgm_i dflags ++ flavour+      opts = getOpts dflags opt_i+  debugTraceMsg dflags 3 $ text "Starting " <> text prog+  let createProc = lookupHook createIservProcessHook+                              (\cp -> do { (_,_,_,ph) <- createProcess cp+                                         ; return ph })+                              dflags+  (ph, rh, wh) <- runWithPipes createProc prog opts+  lo_ref <- newIORef Nothing+  cache_ref <- newIORef emptyUFM+  return $ IServ+    { iservPipe = Pipe { pipeRead = rh+                       , pipeWrite = wh+                       , pipeLeftovers = lo_ref }+    , iservProcess = ph+    , iservLookupSymbolCache = cache_ref+    , iservPendingFrees = []+    }++stopIServ :: HscEnv -> IO ()+stopIServ HscEnv{..} =+  gmask $ \_restore -> do+    m <- takeMVar hsc_iserv+    maybe (return ()) stop m+    putMVar hsc_iserv Nothing+ where+  stop iserv = do+    ex <- getProcessExitCode (iservProcess iserv)+    if isJust ex+       then return ()+       else iservCall iserv Shutdown++runWithPipes :: (CreateProcess -> IO ProcessHandle)+             -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle)+#ifdef mingw32_HOST_OS+foreign import ccall "io.h _close"+   c__close :: CInt -> IO CInt++foreign import ccall unsafe "io.h _get_osfhandle"+   _get_osfhandle :: CInt -> IO CInt++runWithPipes createProc prog opts = do+    (rfd1, wfd1) <- createPipeFd -- we read on rfd1+    (rfd2, wfd2) <- createPipeFd -- we write on wfd2+    wh_client    <- _get_osfhandle wfd1+    rh_client    <- _get_osfhandle rfd2+    let args = show wh_client : show rh_client : opts+    ph <- createProc (proc prog args)+    rh <- mkHandle rfd1+    wh <- mkHandle wfd2+    return (ph, rh, wh)+      where mkHandle :: CInt -> IO Handle+            mkHandle fd = (fdToHandle fd) `onException` (c__close fd)++#if !MIN_VERSION_process(1,4,2)+-- This #include and the _O_BINARY below are the only reason this is hsc,+-- so we can remove that once we can depend on process 1.4.2+#include <fcntl.h>++createPipeFd :: IO (FD, FD)+createPipeFd = do+    allocaArray 2 $ \ pfds -> do+        throwErrnoIfMinus1_ "_pipe" $ c__pipe pfds 2 (#const _O_BINARY)+        readfd <- peek pfds+        writefd <- peekElemOff pfds 1+        return (readfd, writefd)++foreign import ccall "io.h _pipe" c__pipe ::+    Ptr CInt -> CUInt -> CInt -> IO CInt+#endif+#else+runWithPipes createProc prog opts = do+    (rfd1, wfd1) <- Posix.createPipe -- we read on rfd1+    (rfd2, wfd2) <- Posix.createPipe -- we write on wfd2+    setFdOption rfd1 CloseOnExec True+    setFdOption wfd2 CloseOnExec True+    let args = show wfd1 : show rfd2 : opts+    ph <- createProc (proc prog args)+    closeFd wfd1+    closeFd rfd2+    rh <- fdToHandle rfd1+    wh <- fdToHandle wfd2+    return (ph, rh, wh)+#endif++-- -----------------------------------------------------------------------------+{- Note [External GHCi pointers]++We have the following ways to reference things in GHCi:++HValue+------++HValue is a direct reference to an value in the local heap.  Obviously+we cannot use this to refer to things in the external process.+++RemoteRef+---------++RemoteRef is a StablePtr to a heap-resident value.  When+-fexternal-interpreter is used, this value resides in the external+process's heap.  RemoteRefs are mostly used to send pointers in+messages between GHC and iserv.++A RemoteRef must be explicitly freed when no longer required, using+freeHValueRefs, or by attaching a finalizer with mkForeignHValue.++To get from a RemoteRef to an HValue you can use 'wormholeRef', which+fails with an error message if -fexternal-interpreter is in use.++ForeignRef+----------++A ForeignRef is a RemoteRef with a finalizer that will free the+'RemoteRef' when it is garbage collected.  We mostly use ForeignHValue+on the GHC side.++The finalizer adds the RemoteRef to the iservPendingFrees list in the+IServ record.  The next call to iservCmd will free any RemoteRefs in+the list.  It was done this way rather than calling iservCmd directly,+because I didn't want to have arbitrary threads calling iservCmd.  In+principle it would probably be ok, but it seems less hairy this way.+-}++-- | Creates a 'ForeignRef' that will automatically release the+-- 'RemoteRef' when it is no longer referenced.+mkFinalizedHValue :: HscEnv -> RemoteRef a -> IO (ForeignRef a)+mkFinalizedHValue HscEnv{..} rref = mkForeignRef rref free+ where+  !external = gopt Opt_ExternalInterpreter hsc_dflags+  hvref = toHValueRef rref++  free :: IO ()+  free+    | not external = freeRemoteRef hvref+    | otherwise =+      modifyMVar_ hsc_iserv $ \mb_iserv ->+        case mb_iserv of+          Nothing -> return Nothing -- already shut down+          Just iserv@IServ{..} ->+            return (Just iserv{iservPendingFrees = hvref : iservPendingFrees})++freeHValueRefs :: HscEnv -> [HValueRef] -> IO ()+freeHValueRefs _ [] = return ()+freeHValueRefs hsc_env refs = iservCmd hsc_env (FreeHValueRefs refs)++-- | Convert a 'ForeignRef' to the value it references directly.  This+-- only works when the interpreter is running in the same process as+-- the compiler, so it fails when @-fexternal-interpreter@ is on.+wormhole :: DynFlags -> ForeignRef a -> IO a+wormhole dflags r = wormholeRef dflags (unsafeForeignRefToRemoteRef r)++-- | Convert an 'RemoteRef' to the value it references directly.  This+-- only works when the interpreter is running in the same process as+-- the compiler, so it fails when @-fexternal-interpreter@ is on.+wormholeRef :: DynFlags -> RemoteRef a -> IO a+wormholeRef dflags _r+  | gopt Opt_ExternalInterpreter dflags+  = throwIO (InstallationError+      "this operation requires -fno-external-interpreter")+#ifdef GHCI+  | otherwise+  = localRef _r+#else+  | otherwise+  = throwIO (InstallationError+      "can't wormhole a value in a stage1 compiler")+#endif++-- -----------------------------------------------------------------------------+-- Misc utils++mkEvalOpts :: DynFlags -> Bool -> EvalOpts+mkEvalOpts dflags step =+  EvalOpts+    { useSandboxThread = gopt Opt_GhciSandbox dflags+    , singleStep = step+    , breakOnException = gopt Opt_BreakOnException dflags+    , breakOnError = gopt Opt_BreakOnError dflags }++fromEvalResult :: EvalResult a -> IO a+fromEvalResult (EvalException e) = throwIO (fromSerializableException e)+fromEvalResult (EvalSuccess a) = return a
+ ghci/Linker.hs view
@@ -0,0 +1,1475 @@+{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections, RecordWildCards #-}+{-# OPTIONS_GHC -fno-cse #-}+-- -fno-cse is needed for GLOBAL_VAR's to behave properly++--+--  (c) The University of Glasgow 2002-2006+--+-- | The dynamic linker for GHCi.+--+-- This module deals with the top-level issues of dynamic linking,+-- calling the object-code linker and the byte-code linker where+-- necessary.+module Linker ( getHValue, showLinkerState,+                linkExpr, linkDecls, unload, withExtendedLinkEnv,+                extendLinkEnv, deleteFromLinkEnv,+                extendLoadedPkgs,+                linkPackages,initDynLinker,linkModule,+                linkCmdLineLibs+        ) where++#include "HsVersions.h"++import GHCi+import GHCi.RemoteTypes+import LoadIface+import ByteCodeLink+import ByteCodeAsm+import ByteCodeTypes+import TcRnMonad+import Packages+import DriverPhases+import Finder+import HscTypes+import Name+import NameEnv+import Module+import ListSetOps+import DynFlags+import BasicTypes+import Outputable+import Panic+import Util+import ErrUtils+import SrcLoc+import qualified Maybes+import UniqDSet+import FastString+import Platform+import SysTools++-- Standard libraries+import Control.Monad+import Control.Applicative((<|>))++import Data.IORef+import Data.List+import Data.Maybe+import Control.Concurrent.MVar++import System.FilePath+import System.Directory++import Exception++import Foreign (Ptr) -- needed for 2nd stage++{- **********************************************************************++                        The Linker's state++  ********************************************************************* -}++{-+The persistent linker state *must* match the actual state of the+C dynamic linker at all times, so we keep it in a private global variable.++The global IORef used for PersistentLinkerState actually contains another MVar.+The reason for this is that we want to allow another loaded copy of the GHC+library to side-effect the PLS and for those changes to be reflected here.++The PersistentLinkerState maps Names to actual closures (for+interpreted code only), for use during linking.+-}+#if STAGE < 2+GLOBAL_VAR_M(v_PersistentLinkerState, newMVar (panic "Dynamic linker not initialised"), MVar PersistentLinkerState)+GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised+#else+SHARED_GLOBAL_VAR_M( v_PersistentLinkerState+                   , getOrSetLibHSghcPersistentLinkerState+                   , "getOrSetLibHSghcPersistentLinkerState"+                   , newMVar (panic "Dynamic linker not initialised")+                   , MVar PersistentLinkerState)+-- Set True when dynamic linker is initialised+SHARED_GLOBAL_VAR( v_InitLinkerDone+                 , getOrSetLibHSghcInitLinkerDone+                 , "getOrSetLibHSghcInitLinkerDone"+                 , False+                 , Bool)+#endif++modifyPLS_ :: (PersistentLinkerState -> IO PersistentLinkerState) -> IO ()+modifyPLS_ f = readIORef v_PersistentLinkerState >>= flip modifyMVar_ f++modifyPLS :: (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a+modifyPLS f = readIORef v_PersistentLinkerState >>= flip modifyMVar f++data PersistentLinkerState+   = PersistentLinkerState {++        -- Current global mapping from Names to their true values+        closure_env :: ClosureEnv,++        -- The current global mapping from RdrNames of DataCons to+        -- info table addresses.+        -- When a new Unlinked is linked into the running image, or an existing+        -- module in the image is replaced, the itbl_env must be updated+        -- appropriately.+        itbl_env    :: !ItblEnv,++        -- The currently loaded interpreted modules (home package)+        bcos_loaded :: ![Linkable],++        -- And the currently-loaded compiled modules (home package)+        objs_loaded :: ![Linkable],++        -- The currently-loaded packages; always object code+        -- Held, as usual, in dependency order; though I am not sure if+        -- that is really important+        pkgs_loaded :: ![LinkerUnitId],++        -- we need to remember the name of previous temporary DLL/.so+        -- libraries so we can link them (see #10322)+        temp_sos :: ![(FilePath, String)] }+++emptyPLS :: DynFlags -> PersistentLinkerState+emptyPLS _ = PersistentLinkerState {+                        closure_env = emptyNameEnv,+                        itbl_env    = emptyNameEnv,+                        pkgs_loaded = init_pkgs,+                        bcos_loaded = [],+                        objs_loaded = [],+                        temp_sos = [] }++  -- Packages that don't need loading, because the compiler+  -- shares them with the interpreted program.+  --+  -- The linker's symbol table is populated with RTS symbols using an+  -- explicit list.  See rts/Linker.c for details.+  where init_pkgs = map toInstalledUnitId [rtsUnitId]+++extendLoadedPkgs :: [InstalledUnitId] -> IO ()+extendLoadedPkgs pkgs =+  modifyPLS_ $ \s ->+      return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }++extendLinkEnv :: [(Name,ForeignHValue)] -> IO ()+extendLinkEnv new_bindings =+  modifyPLS_ $ \pls -> do+    let ce = closure_env pls+    let new_ce = extendClosureEnv ce new_bindings+    return pls{ closure_env = new_ce }++deleteFromLinkEnv :: [Name] -> IO ()+deleteFromLinkEnv to_remove =+  modifyPLS_ $ \pls -> do+    let ce = closure_env pls+    let new_ce = delListFromNameEnv ce to_remove+    return pls{ closure_env = new_ce }++-- | Get the 'HValue' associated with the given name.+--+-- May cause loading the module that contains the name.+--+-- Throws a 'ProgramError' if loading fails or the name cannot be found.+getHValue :: HscEnv -> Name -> IO ForeignHValue+getHValue hsc_env name = do+  initDynLinker hsc_env+  pls <- modifyPLS $ \pls -> do+           if (isExternalName name) then do+             (pls', ok) <- linkDependencies hsc_env pls noSrcSpan+                              [nameModule name]+             if (failed ok) then throwGhcExceptionIO (ProgramError "")+                            else return (pls', pls')+            else+             return (pls, pls)+  case lookupNameEnv (closure_env pls) name of+    Just (_,aa) -> return aa+    Nothing+        -> ASSERT2(isExternalName name, ppr name)+           do let sym_to_find = nameToCLabel name "closure"+              m <- lookupClosure hsc_env (unpackFS sym_to_find)+              case m of+                Just hvref -> mkFinalizedHValue hsc_env hvref+                Nothing -> linkFail "ByteCodeLink.lookupCE"+                             (unpackFS sym_to_find)++linkDependencies :: HscEnv -> PersistentLinkerState+                 -> SrcSpan -> [Module]+                 -> IO (PersistentLinkerState, SuccessFlag)+linkDependencies hsc_env pls span needed_mods = do+--   initDynLinker (hsc_dflags hsc_env)+   let hpt = hsc_HPT hsc_env+       dflags = hsc_dflags hsc_env+   -- The interpreter and dynamic linker can only handle object code built+   -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.+   -- So here we check the build tag: if we're building a non-standard way+   -- then we need to find & link object files built the "normal" way.+   maybe_normal_osuf <- checkNonStdWay dflags span++   -- Find what packages and linkables are required+   (lnks, pkgs) <- getLinkDeps hsc_env hpt pls+                               maybe_normal_osuf span needed_mods++   -- Link the packages and modules required+   pls1 <- linkPackages' hsc_env pkgs pls+   linkModules hsc_env pls1 lnks+++-- | Temporarily extend the linker state.++withExtendedLinkEnv :: (ExceptionMonad m) =>+                       [(Name,ForeignHValue)] -> m a -> m a+withExtendedLinkEnv new_env action+    = gbracket (liftIO $ extendLinkEnv new_env)+               (\_ -> reset_old_env)+               (\_ -> action)+    where+        -- Remember that the linker state might be side-effected+        -- during the execution of the IO action, and we don't want to+        -- lose those changes (we might have linked a new module or+        -- package), so the reset action only removes the names we+        -- added earlier.+          reset_old_env = liftIO $ do+            modifyPLS_ $ \pls ->+                let cur = closure_env pls+                    new = delListFromNameEnv cur (map fst new_env)+                in return pls{ closure_env = new }+++-- | Display the persistent linker state.+showLinkerState :: DynFlags -> IO ()+showLinkerState dflags+  = do pls <- readIORef v_PersistentLinkerState >>= readMVar+       putLogMsg dflags NoReason SevDump noSrcSpan+          (defaultDumpStyle dflags)+                 (vcat [text "----- Linker state -----",+                        text "Pkgs:" <+> ppr (pkgs_loaded pls),+                        text "Objs:" <+> ppr (objs_loaded pls),+                        text "BCOs:" <+> ppr (bcos_loaded pls)])+++{- **********************************************************************++                        Initialisation++  ********************************************************************* -}++-- | Initialise the dynamic linker.  This entails+--+--  a) Calling the C initialisation procedure,+--+--  b) Loading any packages specified on the command line,+--+--  c) Loading any packages specified on the command line, now held in the+--     @-l@ options in @v_Opt_l@,+--+--  d) Loading any @.o\/.dll@ files specified on the command line, now held+--     in @ldInputs@,+--+--  e) Loading any MacOS frameworks.+--+-- NOTE: This function is idempotent; if called more than once, it does+-- nothing.  This is useful in Template Haskell, where we call it before+-- trying to link.+--+initDynLinker :: HscEnv -> IO ()+initDynLinker hsc_env =+  modifyPLS_ $ \pls0 -> do+    done <- readIORef v_InitLinkerDone+    if done then return pls0+            else do writeIORef v_InitLinkerDone True+                    reallyInitDynLinker hsc_env++reallyInitDynLinker :: HscEnv -> IO PersistentLinkerState+reallyInitDynLinker hsc_env = do+  -- Initialise the linker state+  let dflags = hsc_dflags hsc_env+      pls0 = emptyPLS dflags++  -- (a) initialise the C dynamic linker+  initObjLinker hsc_env++  -- (b) Load packages from the command-line (Note [preload packages])+  pls <- linkPackages' hsc_env (preloadPackages (pkgState dflags)) pls0++  -- steps (c), (d) and (e)+  linkCmdLineLibs' hsc_env pls+++linkCmdLineLibs :: HscEnv -> IO ()+linkCmdLineLibs hsc_env = do+  initDynLinker hsc_env+  modifyPLS_ $ \pls -> do+    linkCmdLineLibs' hsc_env pls++linkCmdLineLibs' :: HscEnv -> PersistentLinkerState -> IO PersistentLinkerState+linkCmdLineLibs' hsc_env pls =+  do+      let dflags@(DynFlags { ldInputs = cmdline_ld_inputs+                           , libraryPaths = lib_paths}) = hsc_dflags hsc_env++      -- (c) Link libraries from the command-line+      let minus_ls_1 = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ]++      -- On Windows we want to add libpthread by default just as GCC would.+      -- However because we don't know the actual name of pthread's dll we+      -- need to defer this to the locateLib call so we can't initialize it+      -- inside of the rts. Instead we do it here to be able to find the+      -- import library for pthreads. See Trac #13210.+      let platform = targetPlatform dflags+          os       = platformOS platform+          minus_ls = case os of+                       OSMinGW32 -> "pthread" : minus_ls_1+                       _         -> minus_ls_1++      libspecs <- mapM (locateLib hsc_env False lib_paths) minus_ls++      -- (d) Link .o files from the command-line+      classified_ld_inputs <- mapM (classifyLdInput dflags)+                                [ f | FileOption _ f <- cmdline_ld_inputs ]++      -- (e) Link any MacOS frameworks+      let platform = targetPlatform dflags+      let (framework_paths, frameworks) =+            if platformUsesFrameworks platform+             then (frameworkPaths dflags, cmdlineFrameworks dflags)+              else ([],[])++      -- Finally do (c),(d),(e)+      let cmdline_lib_specs = catMaybes classified_ld_inputs+                           ++ libspecs+                           ++ map Framework frameworks+      if null cmdline_lib_specs then return pls+                                else do++      -- Add directories to library search paths, this only has an effect+      -- on Windows. On Unix OSes this function is a NOP.+      let all_paths = let paths = takeDirectory (fst $ sPgm_c $ settings dflags)+                                : framework_paths+                               ++ lib_paths+                               ++ [ takeDirectory dll | DLLPath dll <- libspecs ]+                      in nub $ map normalise paths+      pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths++      pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls+                    cmdline_lib_specs+      maybePutStr dflags "final link ... "+      ok <- resolveObjs hsc_env++      -- DLLs are loaded, reset the search paths+      mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache++      if succeeded ok then maybePutStrLn dflags "done"+      else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed")++      return pls1++{- Note [preload packages]++Why do we need to preload packages from the command line?  This is an+explanation copied from #2437:++I tried to implement the suggestion from #3560, thinking it would be+easy, but there are two reasons we link in packages eagerly when they+are mentioned on the command line:++  * So that you can link in extra object files or libraries that+    depend on the packages. e.g. ghc -package foo -lbar where bar is a+    C library that depends on something in foo. So we could link in+    foo eagerly if and only if there are extra C libs or objects to+    link in, but....++  * Haskell code can depend on a C function exported by a package, and+    the normal dependency tracking that TH uses can't know about these+    dependencies. The test ghcilink004 relies on this, for example.++I conclude that we need two -package flags: one that says "this is a+package I want to make available", and one that says "this is a+package I want to link in eagerly". Would that be too complicated for+users?+-}++classifyLdInput :: DynFlags -> FilePath -> IO (Maybe LibrarySpec)+classifyLdInput dflags f+  | isObjectFilename platform f = return (Just (Object f))+  | isDynLibFilename platform f = return (Just (DLLPath f))+  | otherwise          = do+        putLogMsg dflags NoReason SevInfo noSrcSpan+            (defaultUserStyle dflags)+            (text ("Warning: ignoring unrecognised input `" ++ f ++ "'"))+        return Nothing+    where platform = targetPlatform dflags++preloadLib+  :: HscEnv -> [String] -> [String] -> PersistentLinkerState+  -> LibrarySpec -> IO PersistentLinkerState+preloadLib hsc_env lib_paths framework_paths pls lib_spec = do+  maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")+  case lib_spec of+    Object static_ish -> do+      (b, pls1) <- preload_static lib_paths static_ish+      maybePutStrLn dflags (if b  then "done" else "not found")+      return pls1++    Archive static_ish -> do+      b <- preload_static_archive lib_paths static_ish+      maybePutStrLn dflags (if b  then "done" else "not found")+      return pls++    DLL dll_unadorned -> do+      maybe_errstr <- loadDLL hsc_env (mkSOName platform dll_unadorned)+      case maybe_errstr of+         Nothing -> maybePutStrLn dflags "done"+         Just mm | platformOS platform /= OSDarwin ->+           preloadFailed mm lib_paths lib_spec+         Just mm | otherwise -> do+           -- As a backup, on Darwin, try to also load a .so file+           -- since (apparently) some things install that way - see+           -- ticket #8770.+           let libfile = ("lib" ++ dll_unadorned) <.> "so"+           err2 <- loadDLL hsc_env libfile+           case err2 of+             Nothing -> maybePutStrLn dflags "done"+             Just _  -> preloadFailed mm lib_paths lib_spec+      return pls++    DLLPath dll_path -> do+      do maybe_errstr <- loadDLL hsc_env dll_path+         case maybe_errstr of+            Nothing -> maybePutStrLn dflags "done"+            Just mm -> preloadFailed mm lib_paths lib_spec+         return pls++    Framework framework ->+      if platformUsesFrameworks (targetPlatform dflags)+      then do maybe_errstr <- loadFramework hsc_env framework_paths framework+              case maybe_errstr of+                 Nothing -> maybePutStrLn dflags "done"+                 Just mm -> preloadFailed mm framework_paths lib_spec+              return pls+      else panic "preloadLib Framework"++  where+    dflags = hsc_dflags hsc_env++    platform = targetPlatform dflags++    preloadFailed :: String -> [String] -> LibrarySpec -> IO ()+    preloadFailed sys_errmsg paths spec+       = do maybePutStr dflags "failed.\n"+            throwGhcExceptionIO $+              CmdLineError (+                    "user specified .o/.so/.DLL could not be loaded ("+                    ++ sys_errmsg ++ ")\nWhilst trying to load:  "+                    ++ showLS spec ++ "\nAdditional directories searched:"+                    ++ (if null paths then " (none)" else+                        intercalate "\n" (map ("   "++) paths)))++    -- Not interested in the paths in the static case.+    preload_static _paths name+       = do b <- doesFileExist name+            if not b then return (False, pls)+                     else if dynamicGhc+                             then  do pls1 <- dynLoadObjs hsc_env pls [name]+                                      return (True, pls1)+                             else  do loadObj hsc_env name+                                      return (True, pls)++    preload_static_archive _paths name+       = do b <- doesFileExist name+            if not b then return False+                     else do if dynamicGhc+                                 then panic "Loading archives not supported"+                                 else loadArchive hsc_env name+                             return True+++{- **********************************************************************++                        Link a byte-code expression++  ********************************************************************* -}++-- | Link a single expression, /including/ first linking packages and+-- modules that this expression depends on.+--+-- Raises an IO exception ('ProgramError') if it can't find a compiled+-- version of the dependents to link.+--+linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue+linkExpr hsc_env span root_ul_bco+  = do {+     -- Initialise the linker (if it's not been done already)+   ; initDynLinker hsc_env++     -- Take lock for the actual work.+   ; modifyPLS $ \pls0 -> do {++     -- Link the packages and modules required+   ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods+   ; if failed ok then+        throwGhcExceptionIO (ProgramError "")+     else do {++     -- Link the expression itself+     let ie = itbl_env pls+         ce = closure_env pls++     -- Link the necessary packages and linkables++   ; let nobreakarray = error "no break array"+         bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)]+   ; resolved <- linkBCO hsc_env ie ce bco_ix nobreakarray root_ul_bco+   ; [root_hvref] <- createBCOs hsc_env [resolved]+   ; fhv <- mkFinalizedHValue hsc_env root_hvref+   ; return (pls, fhv)+   }}}+   where+     free_names = uniqDSetToList (bcoFreeNames root_ul_bco)++     needed_mods :: [Module]+     needed_mods = [ nameModule n | n <- free_names,+                     isExternalName n,      -- Names from other modules+                     not (isWiredInName n)  -- Exclude wired-in names+                   ]                        -- (see note below)+        -- Exclude wired-in names because we may not have read+        -- their interface files, so getLinkDeps will fail+        -- All wired-in names are in the base package, which we link+        -- by default, so we can safely ignore them here.++dieWith :: DynFlags -> SrcSpan -> MsgDoc -> IO a+dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg)))+++checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe FilePath)+checkNonStdWay dflags srcspan+  | gopt Opt_ExternalInterpreter dflags = return Nothing+    -- with -fexternal-interpreter we load the .o files, whatever way+    -- they were built.  If they were built for a non-std way, then+    -- we will use the appropriate variant of the iserv binary to load them.++  | interpWays == haskellWays = return Nothing+    -- Only if we are compiling with the same ways as GHC is built+    -- with, can we dynamically load those object files. (see #3604)++  | objectSuf dflags == normalObjectSuffix && not (null haskellWays)+  = failNonStd dflags srcspan++  | otherwise = return (Just (interpTag ++ "o"))+  where+    haskellWays = filter (not . wayRTSOnly) (ways dflags)+    interpTag = case mkBuildTag interpWays of+                  "" -> ""+                  tag -> tag ++ "_"++normalObjectSuffix :: String+normalObjectSuffix = phaseInputExt StopLn++failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath)+failNonStd dflags srcspan = dieWith dflags srcspan $+  text "Cannot load" <+> compWay <+>+     text "objects when GHC is built" <+> ghciWay $$+  text "To fix this, either:" $$+  text "  (1) Use -fexternal-interprter, or" $$+  text "  (2) Build the program twice: once" <+>+                       ghciWay <> text ", and then" $$+  text "      with" <+> compWay <+>+     text "using -osuf to set a different object file suffix."+    where compWay+            | WayDyn `elem` ways dflags = text "-dynamic"+            | WayProf `elem` ways dflags = text "-prof"+            | otherwise = text "normal"+          ghciWay+            | dynamicGhc = text "with -dynamic"+            | rtsIsProfiled = text "with -prof"+            | otherwise = text "the normal way"++getLinkDeps :: HscEnv -> HomePackageTable+            -> PersistentLinkerState+            -> Maybe FilePath                   -- replace object suffices?+            -> SrcSpan                          -- for error messages+            -> [Module]                         -- If you need these+            -> IO ([Linkable], [InstalledUnitId])     -- ... then link these first+-- Fails with an IO exception if it can't find enough files++getLinkDeps hsc_env hpt pls replace_osuf span mods+-- Find all the packages and linkables that a set of modules depends on+ = do {+        -- 1.  Find the dependent home-pkg-modules/packages from each iface+        -- (omitting modules from the interactive package, which is already linked)+      ; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods)+                                        emptyUniqDSet emptyUniqDSet;++      ; let {+        -- 2.  Exclude ones already linked+        --      Main reason: avoid findModule calls in get_linkable+            mods_needed = mods_s `minusList` linked_mods     ;+            pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ;++            linked_mods = map (moduleName.linkableModule)+                                (objs_loaded pls ++ bcos_loaded pls)  }++        -- 3.  For each dependent module, find its linkable+        --     This will either be in the HPT or (in the case of one-shot+        --     compilation) we may need to use maybe_getFileLinkable+      ; let { osuf = objectSuf dflags }+      ; lnks_needed <- mapM (get_linkable osuf) mods_needed++      ; return (lnks_needed, pkgs_needed) }+  where+    dflags = hsc_dflags hsc_env+    this_pkg = thisPackage dflags++        -- The ModIface contains the transitive closure of the module dependencies+        -- within the current package, *except* for boot modules: if we encounter+        -- a boot module, we have to find its real interface and discover the+        -- dependencies of that.  Hence we need to traverse the dependency+        -- tree recursively.  See bug #936, testcase ghci/prog007.+    follow_deps :: [Module]             -- modules to follow+                -> UniqDSet ModuleName         -- accum. module dependencies+                -> UniqDSet InstalledUnitId          -- accum. package dependencies+                -> IO ([ModuleName], [InstalledUnitId]) -- result+    follow_deps []     acc_mods acc_pkgs+        = return (uniqDSetToList acc_mods, uniqDSetToList acc_pkgs)+    follow_deps (mod:mods) acc_mods acc_pkgs+        = do+          mb_iface <- initIfaceCheck (text "getLinkDeps") hsc_env $+                        loadInterface msg mod (ImportByUser False)+          iface <- case mb_iface of+                    Maybes.Failed err      -> throwGhcExceptionIO (ProgramError (showSDoc dflags err))+                    Maybes.Succeeded iface -> return iface++          when (mi_boot iface) $ link_boot_mod_error mod++          let+            pkg = moduleUnitId mod+            deps  = mi_deps iface++            pkg_deps = dep_pkgs deps+            (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps)+                    where is_boot (m,True)  = Left m+                          is_boot (m,False) = Right m++            boot_deps' = filter (not . (`elementOfUniqDSet` acc_mods)) boot_deps+            acc_mods'  = addListToUniqDSet acc_mods (moduleName mod : mod_deps)+            acc_pkgs'  = addListToUniqDSet acc_pkgs $ map fst pkg_deps+          --+          if pkg /= this_pkg+             then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toInstalledUnitId pkg))+             else follow_deps (map (mkModule this_pkg) boot_deps' ++ mods)+                              acc_mods' acc_pkgs'+        where+            msg = text "need to link module" <+> ppr mod <+>+                  text "due to use of Template Haskell"+++    link_boot_mod_error mod =+        throwGhcExceptionIO (ProgramError (showSDoc dflags (+            text "module" <+> ppr mod <+>+            text "cannot be linked; it is only available as a boot module")))++    no_obj :: Outputable a => a -> IO b+    no_obj mod = dieWith dflags span $+                     text "cannot find object file for module " <>+                        quotes (ppr mod) $$+                     while_linking_expr++    while_linking_expr = text "while linking an interpreted expression"++        -- This one is a build-system bug++    get_linkable osuf mod_name      -- A home-package module+        | Just mod_info <- lookupHpt hpt mod_name+        = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))+        | otherwise+        = do    -- It's not in the HPT because we are in one shot mode,+                -- so use the Finder to get a ModLocation...+             mb_stuff <- findHomeModule hsc_env mod_name+             case mb_stuff of+                  Found loc mod -> found loc mod+                  _ -> no_obj mod_name+        where+            found loc mod = do {+                -- ...and then find the linkable for it+               mb_lnk <- findObjectLinkableMaybe mod loc ;+               case mb_lnk of {+                  Nothing  -> no_obj mod ;+                  Just lnk -> adjust_linkable lnk+              }}++            adjust_linkable lnk+                | Just new_osuf <- replace_osuf = do+                        new_uls <- mapM (adjust_ul new_osuf)+                                        (linkableUnlinked lnk)+                        return lnk{ linkableUnlinked=new_uls }+                | otherwise =+                        return lnk++            adjust_ul new_osuf (DotO file) = do+                MASSERT(osuf `isSuffixOf` file)+                let file_base = fromJust (stripExtension osuf file)+                    new_file = file_base <.> new_osuf+                ok <- doesFileExist new_file+                if (not ok)+                   then dieWith dflags span $+                          text "cannot find object file "+                                <> quotes (text new_file) $$ while_linking_expr+                   else return (DotO new_file)+            adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp)+            adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp)+            adjust_ul _ l@(BCOs {}) = return l+#if !MIN_VERSION_filepath(1,4,1)+    stripExtension :: String -> FilePath -> Maybe FilePath+    stripExtension []        path = Just path+    stripExtension ext@(x:_) path = stripSuffix dotExt path+        where dotExt = if isExtSeparator x then ext else '.':ext++    stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]+    stripSuffix xs ys = fmap reverse $ stripPrefix (reverse xs) (reverse ys)+#endif++++{- **********************************************************************++              Loading a Decls statement++  ********************************************************************* -}++linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO ()+linkDecls hsc_env span cbc@CompiledByteCode{..} = do+    -- Initialise the linker (if it's not been done already)+    initDynLinker hsc_env++    -- Take lock for the actual work.+    modifyPLS $ \pls0 -> do++    -- Link the packages and modules required+    (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods+    if failed ok+      then throwGhcExceptionIO (ProgramError "")+      else do++    -- Link the expression itself+    let ie = plusNameEnv (itbl_env pls) bc_itbls+        ce = closure_env pls++    -- Link the necessary packages and linkables+    new_bindings <- linkSomeBCOs hsc_env ie ce [cbc]+    nms_fhvs <- makeForeignNamedHValueRefs hsc_env new_bindings+    let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs+                   , itbl_env    = ie }+    return (pls2, ())+  where+    free_names = uniqDSetToList $+      foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet bc_bcos++    needed_mods :: [Module]+    needed_mods = [ nameModule n | n <- free_names,+                    isExternalName n,       -- Names from other modules+                    not (isWiredInName n)   -- Exclude wired-in names+                  ]                         -- (see note below)+    -- Exclude wired-in names because we may not have read+    -- their interface files, so getLinkDeps will fail+    -- All wired-in names are in the base package, which we link+    -- by default, so we can safely ignore them here.++{- **********************************************************************++              Loading a single module++  ********************************************************************* -}++linkModule :: HscEnv -> Module -> IO ()+linkModule hsc_env mod = do+  initDynLinker hsc_env+  modifyPLS_ $ \pls -> do+    (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod]+    if (failed ok) then throwGhcExceptionIO (ProgramError "could not link module")+      else return pls'++{- **********************************************************************++                Link some linkables+        The linkables may consist of a mixture of+        byte-code modules and object modules++  ********************************************************************* -}++linkModules :: HscEnv -> PersistentLinkerState -> [Linkable]+            -> IO (PersistentLinkerState, SuccessFlag)+linkModules hsc_env pls linkables+  = mask_ $ do  -- don't want to be interrupted by ^C in here++        let (objs, bcos) = partition isObjectLinkable+                              (concatMap partitionLinkable linkables)++                -- Load objects first; they can't depend on BCOs+        (pls1, ok_flag) <- dynLinkObjs hsc_env pls objs++        if failed ok_flag then+                return (pls1, Failed)+          else do+                pls2 <- dynLinkBCOs hsc_env pls1 bcos+                return (pls2, Succeeded)+++-- HACK to support f-x-dynamic in the interpreter; no other purpose+partitionLinkable :: Linkable -> [Linkable]+partitionLinkable li+   = let li_uls = linkableUnlinked li+         li_uls_obj = filter isObject li_uls+         li_uls_bco = filter isInterpretable li_uls+     in+         case (li_uls_obj, li_uls_bco) of+            (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj},+                           li {linkableUnlinked=li_uls_bco}]+            _ -> [li]++findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable+findModuleLinkable_maybe lis mod+   = case [LM time nm us | LM time nm us <- lis, nm == mod] of+        []   -> Nothing+        [li] -> Just li+        _    -> pprPanic "findModuleLinkable" (ppr mod)++linkableInSet :: Linkable -> [Linkable] -> Bool+linkableInSet l objs_loaded =+  case findModuleLinkable_maybe objs_loaded (linkableModule l) of+        Nothing -> False+        Just m  -> linkableTime l == linkableTime m+++{- **********************************************************************++                The object-code linker++  ********************************************************************* -}++dynLinkObjs :: HscEnv -> PersistentLinkerState -> [Linkable]+            -> IO (PersistentLinkerState, SuccessFlag)+dynLinkObjs hsc_env pls objs = do+        -- Load the object files and link them+        let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs+            pls1                     = pls { objs_loaded = objs_loaded' }+            unlinkeds                = concatMap linkableUnlinked new_objs+            wanted_objs              = map nameOfObject unlinkeds++        if interpreterDynamic (hsc_dflags hsc_env)+            then do pls2 <- dynLoadObjs hsc_env pls1 wanted_objs+                    return (pls2, Succeeded)+            else do mapM_ (loadObj hsc_env) wanted_objs++                    -- Link them all together+                    ok <- resolveObjs hsc_env++                    -- If resolving failed, unload all our+                    -- object modules and carry on+                    if succeeded ok then do+                            return (pls1, Succeeded)+                      else do+                            pls2 <- unload_wkr hsc_env [] pls1+                            return (pls2, Failed)+++dynLoadObjs :: HscEnv -> PersistentLinkerState -> [FilePath]+            -> IO PersistentLinkerState+dynLoadObjs _       pls []   = return pls+dynLoadObjs hsc_env pls objs = do+    let dflags = hsc_dflags hsc_env+    let platform = targetPlatform dflags+    let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ]+    let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ]+    (soFile, libPath , libName) <- newTempLibName dflags (soExt platform)+    let+        dflags2 = dflags {+                      -- We don't want the original ldInputs in+                      -- (they're already linked in), but we do want+                      -- to link against previous dynLoadObjs+                      -- libraries if there were any, so that the linker+                      -- can resolve dependencies when it loads this+                      -- library.+                      ldInputs =+                        concatMap+                            (\(lp, l) ->+                                 [ Option ("-L" ++ lp)+                                 , Option "-Xlinker"+                                 , Option "-rpath"+                                 , Option "-Xlinker"+                                 , Option lp+                                 , Option ("-l" ++  l)+                                 ])+                            (temp_sos pls)+                        ++ concatMap+                             (\lp ->+                                 [ Option ("-L" ++ lp)+                                 , Option "-Xlinker"+                                 , Option "-rpath"+                                 , Option "-Xlinker"+                                 , Option lp+                                 ])+                             minus_big_ls+                        -- See Note [-Xlinker -rpath vs -Wl,-rpath]+                        ++ map (\l -> Option ("-l" ++ l)) minus_ls,+                      -- Add -l options and -L options from dflags.+                      --+                      -- When running TH for a non-dynamic way, we still+                      -- need to make -l flags to link against the dynamic+                      -- libraries, so we need to add WayDyn to ways.+                      --+                      -- Even if we're e.g. profiling, we still want+                      -- the vanilla dynamic libraries, so we set the+                      -- ways / build tag to be just WayDyn.+                      ways = [WayDyn],+                      buildTag = mkBuildTag [WayDyn],+                      outputFile = Just soFile+                  }+    -- link all "loaded packages" so symbols in those can be resolved+    -- Note: We are loading packages with local scope, so to see the+    -- symbols in this link we must link all loaded packages again.+    linkDynLib dflags2 objs (pkgs_loaded pls)+    consIORef (filesToNotIntermediateClean dflags) soFile+    m <- loadDLL hsc_env soFile+    case m of+        Nothing -> return pls { temp_sos = (libPath, libName) : temp_sos pls }+        Just err -> panic ("Loading temp shared object failed: " ++ err)++rmDupLinkables :: [Linkable]    -- Already loaded+               -> [Linkable]    -- New linkables+               -> ([Linkable],  -- New loaded set (including new ones)+                   [Linkable])  -- New linkables (excluding dups)+rmDupLinkables already ls+  = go already [] ls+  where+    go already extras [] = (already, extras)+    go already extras (l:ls)+        | linkableInSet l already = go already     extras     ls+        | otherwise               = go (l:already) (l:extras) ls++{- **********************************************************************++                The byte-code linker++  ********************************************************************* -}+++dynLinkBCOs :: HscEnv -> PersistentLinkerState -> [Linkable]+            -> IO PersistentLinkerState+dynLinkBCOs hsc_env pls bcos = do++        let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos+            pls1                     = pls { bcos_loaded = bcos_loaded' }+            unlinkeds :: [Unlinked]+            unlinkeds                = concatMap linkableUnlinked new_bcos++            cbcs :: [CompiledByteCode]+            cbcs      = map byteCodeOfObject unlinkeds+++            ies        = map bc_itbls cbcs+            gce       = closure_env pls+            final_ie  = foldr plusNameEnv (itbl_env pls) ies++        names_and_refs <- linkSomeBCOs hsc_env final_ie gce cbcs++        -- We only want to add the external ones to the ClosureEnv+        let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs++        -- Immediately release any HValueRefs we're not going to add+        freeHValueRefs hsc_env (map snd to_drop)+        -- Wrap finalizers on the ones we want to keep+        new_binds <- makeForeignNamedHValueRefs hsc_env to_add++        return pls1 { closure_env = extendClosureEnv gce new_binds,+                      itbl_env    = final_ie }++-- Link a bunch of BCOs and return references to their values+linkSomeBCOs :: HscEnv+             -> ItblEnv+             -> ClosureEnv+             -> [CompiledByteCode]+             -> IO [(Name,HValueRef)]+                        -- The returned HValueRefs are associated 1-1 with+                        -- the incoming unlinked BCOs.  Each gives the+                        -- value of the corresponding unlinked BCO++linkSomeBCOs hsc_env ie ce mods = foldr fun do_link mods []+ where+  fun CompiledByteCode{..} inner accum =+    case bc_breaks of+      Nothing -> inner ((panic "linkSomeBCOs: no break array", bc_bcos) : accum)+      Just mb -> withForeignRef (modBreaks_flags mb) $ \breakarray ->+                   inner ((breakarray, bc_bcos) : accum)++  do_link [] = return []+  do_link mods = do+    let flat = [ (breakarray, bco) | (breakarray, bcos) <- mods, bco <- bcos ]+        names = map (unlinkedBCOName . snd) flat+        bco_ix = mkNameEnv (zip names [0..])+    resolved <- sequence [ linkBCO hsc_env ie ce bco_ix breakarray bco+                         | (breakarray, bco) <- flat ]+    hvrefs <- createBCOs hsc_env resolved+    return (zip names hvrefs)++-- | Useful to apply to the result of 'linkSomeBCOs'+makeForeignNamedHValueRefs+  :: HscEnv -> [(Name,HValueRef)] -> IO [(Name,ForeignHValue)]+makeForeignNamedHValueRefs hsc_env bindings =+  mapM (\(n, hvref) -> (n,) <$> mkFinalizedHValue hsc_env hvref) bindings++{- **********************************************************************++                Unload some object modules++  ********************************************************************* -}++-- ---------------------------------------------------------------------------+-- | Unloading old objects ready for a new compilation sweep.+--+-- The compilation manager provides us with a list of linkables that it+-- considers \"stable\", i.e. won't be recompiled this time around.  For+-- each of the modules current linked in memory,+--+--   * if the linkable is stable (and it's the same one -- the user may have+--     recompiled the module on the side), we keep it,+--+--   * otherwise, we unload it.+--+--   * we also implicitly unload all temporary bindings at this point.+--+unload :: HscEnv+       -> [Linkable] -- ^ The linkables to *keep*.+       -> IO ()+unload hsc_env linkables+  = mask_ $ do -- mask, so we're safe from Ctrl-C in here++        -- Initialise the linker (if it's not been done already)+        initDynLinker hsc_env++        new_pls+            <- modifyPLS $ \pls -> do+                 pls1 <- unload_wkr hsc_env linkables pls+                 return (pls1, pls1)++        let dflags = hsc_dflags hsc_env+        debugTraceMsg dflags 3 $+          text "unload: retaining objs" <+> ppr (objs_loaded new_pls)+        debugTraceMsg dflags 3 $+          text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls)+        return ()++unload_wkr :: HscEnv+           -> [Linkable]                -- stable linkables+           -> PersistentLinkerState+           -> IO PersistentLinkerState+-- Does the core unload business+-- (the wrapper blocks exceptions and deals with the PLS get and put)++unload_wkr hsc_env keep_linkables pls = do+  let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable keep_linkables++      discard keep l = not (linkableInSet l keep)++      (objs_to_unload, remaining_objs_loaded) =+         partition (discard objs_to_keep) (objs_loaded pls)+      (bcos_to_unload, remaining_bcos_loaded) =+         partition (discard bcos_to_keep) (bcos_loaded pls)++  mapM_ unloadObjs objs_to_unload+  mapM_ unloadObjs bcos_to_unload++  -- If we unloaded any object files at all, we need to purge the cache+  -- of lookupSymbol results.+  when (not (null (objs_to_unload +++                   filter (not . null . linkableObjs) bcos_to_unload))) $+    purgeLookupSymbolCache hsc_env++  let bcos_retained = map linkableModule remaining_bcos_loaded++      -- Note that we want to remove all *local*+      -- (i.e. non-isExternal) names too (these are the+      -- temporary bindings from the command line).+      keep_name (n,_) = isExternalName n &&+                        nameModule n `elem` bcos_retained++      itbl_env'     = filterNameEnv keep_name (itbl_env pls)+      closure_env'  = filterNameEnv keep_name (closure_env pls)++      new_pls = pls { itbl_env = itbl_env',+                      closure_env = closure_env',+                      bcos_loaded = remaining_bcos_loaded,+                      objs_loaded = remaining_objs_loaded }++  return new_pls+  where+    unloadObjs :: Linkable -> IO ()+    unloadObjs lnk+      | dynamicGhc = return ()+        -- We don't do any cleanup when linking objects with the+        -- dynamic linker.  Doing so introduces extra complexity for+        -- not much benefit.+      | otherwise+      = mapM_ (unloadObj hsc_env) [f | DotO f <- linkableUnlinked lnk]+                -- The components of a BCO linkable may contain+                -- dot-o files.  Which is very confusing.+                --+                -- But the BCO parts can be unlinked just by+                -- letting go of them (plus of course depopulating+                -- the symbol table which is done in the main body)++{- **********************************************************************++                Loading packages++  ********************************************************************* -}++data LibrarySpec+   = Object FilePath    -- Full path name of a .o file, including trailing .o+                        -- For dynamic objects only, try to find the object+                        -- file in all the directories specified in+                        -- v_Library_paths before giving up.++   | Archive FilePath   -- Full path name of a .a file, including trailing .a++   | DLL String         -- "Unadorned" name of a .DLL/.so+                        --  e.g.    On unix     "qt"  denotes "libqt.so"+                        --          On Windows  "burble"  denotes "burble.DLL" or "libburble.dll"+                        --  loadDLL is platform-specific and adds the lib/.so/.DLL+                        --  suffixes platform-dependently++   | DLLPath FilePath   -- Absolute or relative pathname to a dynamic library+                        -- (ends with .dll or .so).++   | Framework String   -- Only used for darwin, but does no harm++-- If this package is already part of the GHCi binary, we'll already+-- have the right DLLs for this package loaded, so don't try to+-- load them again.+--+-- But on Win32 we must load them 'again'; doing so is a harmless no-op+-- as far as the loader is concerned, but it does initialise the list+-- of DLL handles that rts/Linker.c maintains, and that in turn is+-- used by lookupSymbol.  So we must call addDLL for each library+-- just to get the DLL handle into the list.+partOfGHCi :: [PackageName]+partOfGHCi+ | isWindowsHost || isDarwinHost = []+ | otherwise = map (PackageName . mkFastString)+                   ["base", "template-haskell", "editline"]++showLS :: LibrarySpec -> String+showLS (Object nm)    = "(static) " ++ nm+showLS (Archive nm)   = "(static archive) " ++ nm+showLS (DLL nm)       = "(dynamic) " ++ nm+showLS (DLLPath nm)   = "(dynamic) " ++ nm+showLS (Framework nm) = "(framework) " ++ nm++-- TODO: Make this type more precise+type LinkerUnitId = InstalledUnitId++-- | Link exactly the specified packages, and their dependents (unless of+-- course they are already linked).  The dependents are linked+-- automatically, and it doesn't matter what order you specify the input+-- packages.+--+linkPackages :: HscEnv -> [LinkerUnitId] -> IO ()+-- NOTE: in fact, since each module tracks all the packages it depends on,+--       we don't really need to use the package-config dependencies.+--+-- However we do need the package-config stuff (to find aux libs etc),+-- and following them lets us load libraries in the right order, which+-- perhaps makes the error message a bit more localised if we get a link+-- failure.  So the dependency walking code is still here.++linkPackages hsc_env new_pkgs = do+  -- It's probably not safe to try to load packages concurrently, so we take+  -- a lock.+  initDynLinker hsc_env+  modifyPLS_ $ \pls -> do+    linkPackages' hsc_env new_pkgs pls++linkPackages' :: HscEnv -> [LinkerUnitId] -> PersistentLinkerState+             -> IO PersistentLinkerState+linkPackages' hsc_env new_pks pls = do+    pkgs' <- link (pkgs_loaded pls) new_pks+    return $! pls { pkgs_loaded = pkgs' }+  where+     dflags = hsc_dflags hsc_env++     link :: [LinkerUnitId] -> [LinkerUnitId] -> IO [LinkerUnitId]+     link pkgs new_pkgs =+         foldM link_one pkgs new_pkgs++     link_one pkgs new_pkg+        | new_pkg `elem` pkgs   -- Already linked+        = return pkgs++        | Just pkg_cfg <- lookupInstalledPackage dflags new_pkg+        = do {  -- Link dependents first+               pkgs' <- link pkgs (depends pkg_cfg)+                -- Now link the package itself+             ; linkPackage hsc_env pkg_cfg+             ; return (new_pkg : pkgs') }++        | otherwise+        = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (installedUnitIdFS new_pkg)))+++linkPackage :: HscEnv -> PackageConfig -> IO ()+linkPackage hsc_env pkg+   = do+        let dflags    = hsc_dflags hsc_env+            platform  = targetPlatform dflags+            dirs | interpreterDynamic dflags = Packages.libraryDynDirs pkg+                 | otherwise                 = Packages.libraryDirs pkg++        let hs_libs   =  Packages.hsLibraries pkg+            -- The FFI GHCi import lib isn't needed as+            -- compiler/ghci/Linker.hs + rts/Linker.c link the+            -- interpreted references to FFI to the compiled FFI.+            -- We therefore filter it out so that we don't get+            -- duplicate symbol errors.+            hs_libs'  =  filter ("HSffi" /=) hs_libs++        -- Because of slight differences between the GHC dynamic linker and+        -- the native system linker some packages have to link with a+        -- different list of libraries when using GHCi. Examples include: libs+        -- that are actually gnu ld scripts, and the possibility that the .a+        -- libs do not exactly match the .so/.dll equivalents. So if the+        -- package file provides an "extra-ghci-libraries" field then we use+        -- that instead of the "extra-libraries" field.+            extra_libs =+                      (if null (Packages.extraGHCiLibraries pkg)+                            then Packages.extraLibraries pkg+                            else Packages.extraGHCiLibraries pkg)+                      ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ]++        hs_classifieds    <- mapM (locateLib hsc_env True  dirs) hs_libs'+        extra_classifieds <- mapM (locateLib hsc_env False dirs) extra_libs+        let classifieds = hs_classifieds ++ extra_classifieds++        -- Complication: all the .so's must be loaded before any of the .o's.+        let known_dlls = [ dll  | DLLPath dll    <- classifieds ]+            dlls       = [ dll  | DLL dll        <- classifieds ]+            objs       = [ obj  | Object obj     <- classifieds ]+            archs      = [ arch | Archive arch   <- classifieds ]++        -- Add directories to library search paths+        let dll_paths  = map takeDirectory known_dlls+            all_paths  = nub $ map normalise $ dll_paths ++ dirs+        pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths++        maybePutStr dflags+            ("Loading package " ++ sourcePackageIdString pkg ++ " ... ")++        -- See comments with partOfGHCi+        when (packageName pkg `notElem` partOfGHCi) $ do+            loadFrameworks hsc_env platform pkg+            mapM_ (load_dyn hsc_env)+              (known_dlls ++ map (mkSOName platform) dlls)++        -- After loading all the DLLs, we can load the static objects.+        -- Ordering isn't important here, because we do one final link+        -- step to resolve everything.+        mapM_ (loadObj hsc_env) objs+        mapM_ (loadArchive hsc_env) archs++        maybePutStr dflags "linking ... "+        ok <- resolveObjs hsc_env++        -- DLLs are loaded, reset the search paths+        -- Import libraries will be loaded via loadArchive so only+        -- reset the DLL search path after all archives are loaded+        -- as well.+        mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache++        if succeeded ok+           then maybePutStrLn dflags "done."+           else let errmsg = "unable to load package `"+                             ++ sourcePackageIdString pkg ++ "'"+                 in throwGhcExceptionIO (InstallationError errmsg)++-- we have already searched the filesystem; the strings passed to load_dyn+-- can be passed directly to loadDLL.  They are either fully-qualified+-- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so").  In the latter case,+-- loadDLL is going to search the system paths to find the library.+--+load_dyn :: HscEnv -> FilePath -> IO ()+load_dyn hsc_env dll = do+  r <- loadDLL hsc_env dll+  case r of+    Nothing  -> return ()+    Just err -> throwGhcExceptionIO (CmdLineError ("can't load .so/.DLL for: "+                                                ++ dll ++ " (" ++ err ++ ")" ))++loadFrameworks :: HscEnv -> Platform -> PackageConfig -> IO ()+loadFrameworks hsc_env platform pkg+    = when (platformUsesFrameworks platform) $ mapM_ load frameworks+  where+    fw_dirs    = Packages.frameworkDirs pkg+    frameworks = Packages.frameworks pkg++    load fw = do  r <- loadFramework hsc_env fw_dirs fw+                  case r of+                    Nothing  -> return ()+                    Just err -> throwGhcExceptionIO (CmdLineError ("can't load framework: "+                                                        ++ fw ++ " (" ++ err ++ ")" ))++-- Try to find an object file for a given library in the given paths.+-- If it isn't present, we assume that addDLL in the RTS can find it,+-- which generally means that it should be a dynamic library in the+-- standard system search path.+-- For GHCi we tend to prefer dynamic libraries over static ones as+-- they are easier to load and manage, have less overhead.+locateLib :: HscEnv -> Bool -> [FilePath] -> String -> IO LibrarySpec+locateLib hsc_env is_hs dirs lib+  | not is_hs+    -- For non-Haskell libraries (e.g. gmp, iconv):+    --   first look in library-dirs for a dynamic library (libfoo.so)+    --   then  look in library-dirs for a static library (libfoo.a)+    --   then look in library-dirs and inplace GCC for a dynamic library (libfoo.so)+    --   then  check for system dynamic libraries (e.g. kernel32.dll on windows)+    --   then  try looking for import libraries on Windows (.dll.a, .lib)+    --   then  try "gcc --print-file-name" to search gcc's search path+    --   then  look in library-dirs and inplace GCC for a static library (libfoo.a)+    --       for a dynamic library (#5289)+    --   otherwise, assume loadDLL can find it+    --+  = findDll     `orElse`+    findSysDll  `orElse`+    tryImpLib   `orElse`+    tryGcc      `orElse`+    findArchive `orElse`+    assumeDll++  | loading_dynamic_hs_libs -- search for .so libraries first.+  = findHSDll     `orElse`+    findDynObject `orElse`+    assumeDll++  | loading_profiled_hs_libs -- only a libHSfoo_p.a archive will do.+  = findArchive `orElse`+    assumeDll++  | otherwise+    -- HSfoo.o is the best, but only works for the normal way+    -- libHSfoo.a is the backup option.+  = findObject  `orElse`+    findArchive `orElse`+    assumeDll++   where+     dflags = hsc_dflags hsc_env++     obj_file     = lib <.> "o"+     dyn_obj_file = lib <.> "dyn_o"+     arch_files = [ "lib" ++ lib ++ lib_tag <.> "a"+                  , lib <.> "a" -- native code has no lib_tag+                  ]+     lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else ""++     loading_profiled_hs_libs = interpreterProfiled dflags+     loading_dynamic_hs_libs  = interpreterDynamic dflags++     import_libs  = [ lib <.> "lib"           , "lib" ++ lib <.> "lib"+                    , "lib" ++ lib <.> "dll.a", lib <.> "dll.a"+                    ]++     hs_dyn_lib_name = lib ++ '-':programName dflags ++ projectVersion dflags+     hs_dyn_lib_file = mkHsSOName platform hs_dyn_lib_name++     so_name     = mkSOName platform lib+     lib_so_name = "lib" ++ so_name+     dyn_lib_file = case (arch, os) of+                             (ArchX86_64, OSSolaris2) -> "64" </> so_name+                             _ -> so_name++     findObject    = liftM (fmap Object)  $ findFile dirs obj_file+     findDynObject = liftM (fmap Object)  $ findFile dirs dyn_obj_file+     findArchive   = let local  name = liftM (fmap Archive) $ findFile dirs name+                         linked name = liftM (fmap Archive) $ searchForLibUsingGcc dflags name dirs+                         check name = apply [local name, linked name]+                     in  apply (map check arch_files)+     findHSDll     = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file+     findDll       = liftM (fmap DLLPath) $ findFile dirs dyn_lib_file+     findSysDll    = fmap (fmap $ DLL . dropExtension . takeFileName) $ findSystemLibrary hsc_env so_name+     tryGcc        = let short = liftM (fmap DLLPath) $ searchForLibUsingGcc dflags so_name     dirs+                         full  = liftM (fmap DLLPath) $ searchForLibUsingGcc dflags lib_so_name dirs+                     in liftM2 (<|>) short full+     tryImpLib     = case os of+                       OSMinGW32 -> let check name = liftM (fmap Archive) $ searchForLibUsingGcc dflags name dirs+                                    in apply (map check import_libs)+                       _         -> return Nothing++     assumeDll   = return (DLL lib)+     infixr `orElse`+     f `orElse` g = f >>= maybe g return++     apply []     = return Nothing+     apply (x:xs) = do x' <- x+                       if isJust x'+                          then return x'+                          else apply xs++     platform = targetPlatform dflags+     arch = platformArch platform+     os = platformOS platform++searchForLibUsingGcc :: DynFlags -> String -> [FilePath] -> IO (Maybe FilePath)+searchForLibUsingGcc dflags so dirs = do+   -- GCC does not seem to extend the library search path (using -L) when using+   -- --print-file-name. So instead pass it a new base location.+   str <- askLd dflags (map (FileOption "-B") dirs+                          ++ [Option "--print-file-name", Option so])+   let file = case lines str of+                []  -> ""+                l:_ -> l+   if (file == so)+      then return Nothing+      else return (Just file)++-- ----------------------------------------------------------------------------+-- Loading a dynamic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)++-- Darwin / MacOS X only: load a framework+-- a framework is a dynamic library packaged inside a directory of the same+-- name. They are searched for in different paths than normal libraries.+loadFramework :: HscEnv -> [FilePath] -> FilePath -> IO (Maybe String)+loadFramework hsc_env extraPaths rootname+   = do { either_dir <- tryIO getHomeDirectory+        ; let homeFrameworkPath = case either_dir of+                                  Left _ -> []+                                  Right dir -> [dir </> "Library/Frameworks"]+              ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths+        ; mb_fwk <- findFile ps fwk_file+        ; case mb_fwk of+            Just fwk_path -> loadDLL hsc_env fwk_path+            Nothing       -> return (Just "not found") }+                -- Tried all our known library paths, but dlopen()+                -- has no built-in paths for frameworks: give up+   where+     fwk_file = rootname <.> "framework" </> rootname+        -- sorry for the hardcoded paths, I hope they won't change anytime soon:+     defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]++{- **********************************************************************++                Helper functions++  ********************************************************************* -}++maybePutStr :: DynFlags -> String -> IO ()+maybePutStr dflags s+    = when (verbosity dflags > 1) $+          putLogMsg dflags+              NoReason+              SevInteractive+              noSrcSpan+              (defaultUserStyle dflags)+              (text s)++maybePutStrLn :: DynFlags -> String -> IO ()+maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n")
+ ghci/RtClosureInspect.hs view
@@ -0,0 +1,1281 @@+{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables, MagicHash, UnboxedTuples #-}++-----------------------------------------------------------------------------+--+-- GHC Interactive support for inspecting arbitrary closures at runtime+--+-- Pepe Iborra (supported by Google SoC) 2006+--+-----------------------------------------------------------------------------+module RtClosureInspect(+     cvObtainTerm,      -- :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term+     cvReconstructType,+     improveRTTIType,++     Term(..),+     isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap,+     isFullyEvaluated, isFullyEvaluatedTerm,+     termType, mapTermType, termTyCoVars,+     foldTerm, TermFold(..), foldTermM, TermFoldM(..), idTermFold,+     pprTerm, cPprTerm, cPprTermBase, CustomTermPrinter,++--     unsafeDeepSeq,++     Closure(..), getClosureData, ClosureType(..), isConstr, isIndirection+ ) where++#include "HsVersions.h"++import DebuggerUtils+import GHCi.RemoteTypes ( HValue )+import qualified GHCi.InfoTable as InfoTable+import GHCi.InfoTable (StgInfoTable, peekItbl)+import HscTypes++import DataCon+import Type+import RepType+import qualified Unify as U+import Var+import TcRnMonad+import TcType+import TcMType+import TcHsSyn ( zonkTcTypeToType, mkEmptyZonkEnv )+import TcUnify+import TcEnv++import TyCon+import Name+import Util+import VarSet+import BasicTypes       ( Boxity(..) )+import TysPrim+import PrelNames+import TysWiredIn+import DynFlags+import Outputable as Ppr+import GHC.Arr          ( Array(..) )+import GHC.Exts+import GHC.IO ( IO(..) )++import Control.Monad+import Data.Maybe+import Data.Array.Base+import Data.Ix+import Data.List+import qualified Data.Sequence as Seq+import Data.Sequence (viewl, ViewL(..))+import Foreign+import System.IO.Unsafe++---------------------------------------------+-- * A representation of semi evaluated Terms+---------------------------------------------++data Term = Term { ty        :: RttiType+                 , dc        :: Either String DataCon+                               -- Carries a text representation if the datacon is+                               -- not exported by the .hi file, which is the case+                               -- for private constructors in -O0 compiled libraries+                 , val       :: HValue+                 , subTerms  :: [Term] }++          | Prim { ty        :: RttiType+                 , value     :: [Word] }++          | Suspension { ctype    :: ClosureType+                       , ty       :: RttiType+                       , val      :: HValue+                       , bound_to :: Maybe Name   -- Useful for printing+                       }+          | NewtypeWrap{       -- At runtime there are no newtypes, and hence no+                               -- newtype constructors. A NewtypeWrap is just a+                               -- made-up tag saying "heads up, there used to be+                               -- a newtype constructor here".+                         ty           :: RttiType+                       , dc           :: Either String DataCon+                       , wrapped_term :: Term }+          | RefWrap    {       -- The contents of a reference+                         ty           :: RttiType+                       , wrapped_term :: Term }++isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap :: Term -> Bool+isTerm Term{} = True+isTerm   _    = False+isSuspension Suspension{} = True+isSuspension      _       = False+isPrim Prim{} = True+isPrim   _    = False+isNewtypeWrap NewtypeWrap{} = True+isNewtypeWrap _             = False++isFun Suspension{ctype=Fun} = True+isFun _ = False++isFunLike s@Suspension{ty=ty} = isFun s || isFunTy ty+isFunLike _ = False++termType :: Term -> RttiType+termType t = ty t++isFullyEvaluatedTerm :: Term -> Bool+isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt+isFullyEvaluatedTerm Prim {}            = True+isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t+isFullyEvaluatedTerm RefWrap{wrapped_term=t}     = isFullyEvaluatedTerm t+isFullyEvaluatedTerm _                  = False++instance Outputable (Term) where+ ppr t | Just doc <- cPprTerm cPprTermBase t = doc+       | otherwise = panic "Outputable Term instance"++-------------------------------------------------------------------------+-- Runtime Closure Datatype and functions for retrieving closure related stuff+-------------------------------------------------------------------------+data ClosureType = Constr+                 | Fun+                 | Thunk Int+                 | ThunkSelector+                 | Blackhole+                 | AP+                 | PAP+                 | Indirection Int+                 | MutVar Int+                 | MVar   Int+                 | Other  Int+ deriving (Show, Eq)++data Closure = Closure { tipe         :: ClosureType+                       , infoPtr      :: Ptr ()+                       , infoTable    :: StgInfoTable+                       , ptrs         :: Array Int HValue+                       , nonPtrs      :: [Word]+                       }++instance Outputable ClosureType where+  ppr = text . show++#include "rts/storage/ClosureTypes.h"++aP_CODE, pAP_CODE :: Int+aP_CODE = AP+pAP_CODE = PAP+#undef AP+#undef PAP++getClosureData :: DynFlags -> a -> IO Closure+getClosureData dflags a =+   case unpackClosure# a of+     (# iptr, ptrs, nptrs #) -> do+           let iptr0 = Ptr iptr+           let iptr1+                | ghciTablesNextToCode = iptr0+                | otherwise =+                   -- the info pointer we get back from unpackClosure#+                   -- is to the beginning of the standard info table,+                   -- but the Storable instance for info tables takes+                   -- into account the extra entry pointer when+                   -- !ghciTablesNextToCode, so we must adjust here:+                   iptr0 `plusPtr` negate (wORD_SIZE dflags)+           itbl <- peekItbl iptr1+           let tipe = readCType (InfoTable.tipe itbl)+               elems = fromIntegral (InfoTable.ptrs itbl)+               ptrsList = Array 0 (elems - 1) elems ptrs+               nptrs_data = [W# (indexWordArray# nptrs i)+                            | I# i <- [0.. fromIntegral (InfoTable.nptrs itbl)-1] ]+           ASSERT(elems >= 0) return ()+           ptrsList `seq`+            return (Closure tipe iptr0 itbl ptrsList nptrs_data)++readCType :: Integral a => a -> ClosureType+readCType i+ | i >= CONSTR && i <= CONSTR_NOCAF        = Constr+ | i >= FUN    && i <= FUN_STATIC          = Fun+ | i >= THUNK  && i < THUNK_SELECTOR       = Thunk i'+ | i == THUNK_SELECTOR                     = ThunkSelector+ | i == BLACKHOLE                          = Blackhole+ | i >= IND    && i <= IND_STATIC          = Indirection i'+ | i' == aP_CODE                           = AP+ | i == AP_STACK                           = AP+ | i' == pAP_CODE                          = PAP+ | i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY= MutVar i'+ | i == MVAR_CLEAN    || i == MVAR_DIRTY   = MVar i'+ | otherwise                               = Other  i'+  where i' = fromIntegral i++isConstr, isIndirection, isThunk :: ClosureType -> Bool+isConstr Constr = True+isConstr    _   = False++isIndirection (Indirection _) = True+isIndirection _ = False++isThunk (Thunk _)     = True+isThunk ThunkSelector = True+isThunk AP            = True+isThunk _             = False++isFullyEvaluated :: DynFlags -> a -> IO Bool+isFullyEvaluated dflags a = do+  closure <- getClosureData dflags a+  case tipe closure of+    Constr -> do are_subs_evaluated <- amapM (isFullyEvaluated dflags) (ptrs closure)+                 return$ and are_subs_evaluated+    _      -> return False+  where amapM f = sequence . amap' f++-- TODO: Fix it. Probably the otherwise case is failing, trace/debug it+{-+unsafeDeepSeq :: a -> b -> b+unsafeDeepSeq = unsafeDeepSeq1 2+ where unsafeDeepSeq1 0 a b = seq a $! b+       unsafeDeepSeq1 i a b   -- 1st case avoids infinite loops for non reducible thunks+        | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b+     -- | unsafePerformIO (isFullyEvaluated a) = b+        | otherwise = case unsafePerformIO (getClosureData a) of+                        closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)+        where tipe = unsafePerformIO (getClosureType a)+-}++-----------------------------------+-- * Traversals for Terms+-----------------------------------+type TermProcessor a b = RttiType -> Either String DataCon -> HValue -> [a] -> b++data TermFold a = TermFold { fTerm        :: TermProcessor a a+                           , fPrim        :: RttiType -> [Word] -> a+                           , fSuspension  :: ClosureType -> RttiType -> HValue+                                            -> Maybe Name -> a+                           , fNewtypeWrap :: RttiType -> Either String DataCon+                                            -> a -> a+                           , fRefWrap     :: RttiType -> a -> a+                           }+++data TermFoldM m a =+                   TermFoldM {fTermM        :: TermProcessor a (m a)+                            , fPrimM        :: RttiType -> [Word] -> m a+                            , fSuspensionM  :: ClosureType -> RttiType -> HValue+                                             -> Maybe Name -> m a+                            , fNewtypeWrapM :: RttiType -> Either String DataCon+                                            -> a -> m a+                            , fRefWrapM     :: RttiType -> a -> m a+                           }++foldTerm :: TermFold a -> Term -> a+foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)+foldTerm tf (Prim ty    v   ) = fPrim tf ty v+foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b+foldTerm tf (NewtypeWrap ty dc t)  = fNewtypeWrap tf ty dc (foldTerm tf t)+foldTerm tf (RefWrap ty t)         = fRefWrap tf ty (foldTerm tf t)+++foldTermM :: Monad m => TermFoldM m a -> Term -> m a+foldTermM tf (Term ty dc v tt) = mapM (foldTermM tf) tt >>= fTermM tf ty dc v+foldTermM tf (Prim ty    v   ) = fPrimM tf ty v+foldTermM tf (Suspension ct ty v b) = fSuspensionM tf ct ty v b+foldTermM tf (NewtypeWrap ty dc t)  = foldTermM tf t >>=  fNewtypeWrapM tf ty dc+foldTermM tf (RefWrap ty t)         = foldTermM tf t >>= fRefWrapM tf ty++idTermFold :: TermFold Term+idTermFold = TermFold {+              fTerm = Term,+              fPrim = Prim,+              fSuspension  = Suspension,+              fNewtypeWrap = NewtypeWrap,+              fRefWrap = RefWrap+                      }++mapTermType :: (RttiType -> Type) -> Term -> Term+mapTermType f = foldTerm idTermFold {+          fTerm       = \ty dc hval tt -> Term (f ty) dc hval tt,+          fSuspension = \ct ty hval n ->+                          Suspension ct (f ty) hval n,+          fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,+          fRefWrap    = \ty t -> RefWrap (f ty) t}++mapTermTypeM :: Monad m =>  (RttiType -> m Type) -> Term -> m Term+mapTermTypeM f = foldTermM TermFoldM {+          fTermM       = \ty dc hval tt -> f ty >>= \ty' -> return $ Term ty'  dc hval tt,+          fPrimM       = (return.) . Prim,+          fSuspensionM = \ct ty hval n ->+                          f ty >>= \ty' -> return $ Suspension ct ty' hval n,+          fNewtypeWrapM= \ty dc t -> f ty >>= \ty' -> return $ NewtypeWrap ty' dc t,+          fRefWrapM    = \ty t -> f ty >>= \ty' -> return $ RefWrap ty' t}++termTyCoVars :: Term -> TyCoVarSet+termTyCoVars = foldTerm TermFold {+            fTerm       = \ty _ _ tt   ->+                          tyCoVarsOfType ty `unionVarSet` concatVarEnv tt,+            fSuspension = \_ ty _ _ -> tyCoVarsOfType ty,+            fPrim       = \ _ _ -> emptyVarSet,+            fNewtypeWrap= \ty _ t -> tyCoVarsOfType ty `unionVarSet` t,+            fRefWrap    = \ty t -> tyCoVarsOfType ty `unionVarSet` t}+    where concatVarEnv = foldr unionVarSet emptyVarSet++----------------------------------+-- Pretty printing of terms+----------------------------------++type Precedence        = Int+type TermPrinter       = Precedence -> Term ->   SDoc+type TermPrinterM m    = Precedence -> Term -> m SDoc++app_prec,cons_prec, max_prec ::Int+max_prec  = 10+app_prec  = max_prec+cons_prec = 5 -- TODO Extract this info from GHC itself++pprTerm :: TermPrinter -> TermPrinter+pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc+pprTerm _ _ _ = panic "pprTerm"++pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m+pprTermM y p t = pprDeeper `liftM` ppr_termM y p t++ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do+  tt_docs <- mapM (y app_prec) tt+  return $ cparen (not (null tt) && p >= app_prec)+                  (text dc_tag <+> pprDeeperList fsep tt_docs)++ppr_termM y p Term{dc=Right dc, subTerms=tt} = do+{-  | dataConIsInfix dc, (t1:t2:tt') <- tt  --TODO fixity+  = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)+    <+> hsep (map (ppr_term1 True) tt)+-} -- TODO Printing infix constructors properly+  tt_docs' <- mapM (y app_prec) tt+  return $ sdocWithPprDebug $ \dbg ->+    -- Don't show the dictionary arguments to+    -- constructors unless -dppr-debug is on+    let tt_docs = if dbg+           then tt_docs'+           else dropList (dataConTheta dc) tt_docs'+    in if null tt_docs+      then ppr dc+      else cparen (p >= app_prec) $+             sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)]++ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t+ppr_termM y p RefWrap{wrapped_term=t}  = do+  contents <- y app_prec t+  return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents)+  -- The constructor name is wired in here ^^^ for the sake of simplicity.+  -- I don't think mutvars are going to change in a near future.+  -- In any case this is solely a presentation matter: MutVar# is+  -- a datatype with no constructors, implemented by the RTS+  -- (hence there is no way to obtain a datacon and print it).+ppr_termM _ _ t = ppr_termM1 t+++ppr_termM1 :: Monad m => Term -> m SDoc+ppr_termM1 Prim{value=words, ty=ty} =+    return $ repPrim (tyConAppTyCon ty) words+ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =+    return (char '_' <+> ifPprDebug (text "::" <> ppr ty))+ppr_termM1 Suspension{ty=ty, bound_to=Just n}+--  | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>")+  | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty+ppr_termM1 Term{}        = panic "ppr_termM1 - Term"+ppr_termM1 RefWrap{}     = panic "ppr_termM1 - RefWrap"+ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"++pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}+  | Just (tc,_) <- tcSplitTyConApp_maybe ty+  , ASSERT(isNewTyCon tc) True+  , Just new_dc <- tyConSingleDataCon_maybe tc = do+             real_term <- y max_prec t+             return $ cparen (p >= app_prec) (ppr new_dc <+> real_term)+pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"++-------------------------------------------------------+-- Custom Term Pretty Printers+-------------------------------------------------------++-- We can want to customize the representation of a+--  term depending on its type.+-- However, note that custom printers have to work with+--  type representations, instead of directly with types.+-- We cannot use type classes here, unless we employ some+--  typerep trickery (e.g. Weirich's RepLib tricks),+--  which I didn't. Therefore, this code replicates a lot+--  of what type classes provide for free.++type CustomTermPrinter m = TermPrinterM m+                         -> [Precedence -> Term -> (m (Maybe SDoc))]++-- | Takes a list of custom printers with a explicit recursion knot and a term,+-- and returns the output of the first successful printer, or the default printer+cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc+cPprTerm printers_ = go 0 where+  printers = printers_ go+  go prec t = do+    let default_ = Just `liftM` pprTermM go prec t+        mb_customDocs = [pp prec t | pp <- printers] ++ [default_]+    Just doc <- firstJustM mb_customDocs+    return$ cparen (prec>app_prec+1) doc++  firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)+  firstJustM [] = return Nothing++-- Default set of custom printers. Note that the recursion knot is explicit+cPprTermBase :: forall m. Monad m => CustomTermPrinter m+cPprTermBase y =+  [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)+                                      . mapM (y (-1))+                                      . subTerms)+  , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)+           ppr_list+  , ifTerm (isTyCon intTyCon    . ty) ppr_int+  , ifTerm (isTyCon charTyCon   . ty) ppr_char+  , ifTerm (isTyCon floatTyCon  . ty) ppr_float+  , ifTerm (isTyCon doubleTyCon . ty) ppr_double+  , ifTerm (isIntegerTy         . ty) ppr_integer+  ]+ where+   ifTerm :: (Term -> Bool)+          -> (Precedence -> Term -> m SDoc)+          -> Precedence -> Term -> m (Maybe SDoc)+   ifTerm pred f prec t@Term{}+       | pred t    = Just `liftM` f prec t+   ifTerm _ _ _ _  = return Nothing++   isTupleTy ty    = fromMaybe False $ do+     (tc,_) <- tcSplitTyConApp_maybe ty+     return (isBoxedTupleTyCon tc)++   isTyCon a_tc ty = fromMaybe False $ do+     (tc,_) <- tcSplitTyConApp_maybe ty+     return (a_tc == tc)++   isIntegerTy ty = fromMaybe False $ do+     (tc,_) <- tcSplitTyConApp_maybe ty+     return (tyConName tc == integerTyConName)++   ppr_int, ppr_char, ppr_float, ppr_double, ppr_integer+      :: Precedence -> Term -> m SDoc+   ppr_int     _ v = return (Ppr.int     (unsafeCoerce# (val v)))+   ppr_char    _ v = return (Ppr.char '\'' <> Ppr.char (unsafeCoerce# (val v)) <> Ppr.char '\'')+   ppr_float   _ v = return (Ppr.float   (unsafeCoerce# (val v)))+   ppr_double  _ v = return (Ppr.double  (unsafeCoerce# (val v)))+   ppr_integer _ v = return (Ppr.integer (unsafeCoerce# (val v)))++   --Note pprinting of list terms is not lazy+   ppr_list :: Precedence -> Term -> m SDoc+   ppr_list p (Term{subTerms=[h,t]}) = do+       let elems      = h : getListTerms t+           isConsLast = not (termType (last elems) `eqType` termType h)+           is_string  = all (isCharTy . ty) elems++       print_elems <- mapM (y cons_prec) elems+       if is_string+        then return (Ppr.doubleQuotes (Ppr.text (unsafeCoerce# (map val elems))))+        else if isConsLast+        then return $ cparen (p >= cons_prec)+                    $ pprDeeperList fsep+                    $ punctuate (space<>colon) print_elems+        else return $ brackets+                    $ pprDeeperList fcat+                    $ punctuate comma print_elems++        where getListTerms Term{subTerms=[h,t]} = h : getListTerms t+              getListTerms Term{subTerms=[]}    = []+              getListTerms t@Suspension{}       = [t]+              getListTerms t = pprPanic "getListTerms" (ppr t)+   ppr_list _ _ = panic "doList"+++repPrim :: TyCon -> [Word] -> SDoc+repPrim t = rep where+   rep x+    | t == charPrimTyCon             = text $ show (build x :: Char)+    | t == intPrimTyCon              = text $ show (build x :: Int)+    | t == wordPrimTyCon             = text $ show (build x :: Word)+    | t == floatPrimTyCon            = text $ show (build x :: Float)+    | t == doublePrimTyCon           = text $ show (build x :: Double)+    | t == int32PrimTyCon            = text $ show (build x :: Int32)+    | t == word32PrimTyCon           = text $ show (build x :: Word32)+    | t == int64PrimTyCon            = text $ show (build x :: Int64)+    | t == word64PrimTyCon           = text $ show (build x :: Word64)+    | t == addrPrimTyCon             = text $ show (nullPtr `plusPtr` build x)+    | t == stablePtrPrimTyCon        = text "<stablePtr>"+    | t == stableNamePrimTyCon       = text "<stableName>"+    | t == statePrimTyCon            = text "<statethread>"+    | t == proxyPrimTyCon            = text "<proxy>"+    | t == realWorldTyCon            = text "<realworld>"+    | t == threadIdPrimTyCon         = text "<ThreadId>"+    | t == weakPrimTyCon             = text "<Weak>"+    | t == arrayPrimTyCon            = text "<array>"+    | t == smallArrayPrimTyCon       = text "<smallArray>"+    | t == byteArrayPrimTyCon        = text "<bytearray>"+    | t == mutableArrayPrimTyCon     = text "<mutableArray>"+    | t == smallMutableArrayPrimTyCon = text "<smallMutableArray>"+    | t == mutableByteArrayPrimTyCon = text "<mutableByteArray>"+    | t == mutVarPrimTyCon           = text "<mutVar>"+    | t == mVarPrimTyCon             = text "<mVar>"+    | t == tVarPrimTyCon             = text "<tVar>"+    | otherwise                      = char '<' <> ppr t <> char '>'+    where build ww = unsafePerformIO $ withArray ww (peek . castPtr)+--   This ^^^ relies on the representation of Haskell heap values being+--   the same as in a C array.++-----------------------------------+-- Type Reconstruction+-----------------------------------+{-+Type Reconstruction is type inference done on heap closures.+The algorithm walks the heap generating a set of equations, which+are solved with syntactic unification.+A type reconstruction equation looks like:++  <datacon reptype>  =  <actual heap contents>++The full equation set is generated by traversing all the subterms, starting+from a given term.++The only difficult part is that newtypes are only found in the lhs of equations.+Right hand sides are missing them. We can either (a) drop them from the lhs, or+(b) reconstruct them in the rhs when possible.++The function congruenceNewtypes takes a shot at (b)+-}+++-- A (non-mutable) tau type containing+-- existentially quantified tyvars.+--    (since GHC type language currently does not support+--     existentials, we leave these variables unquantified)+type RttiType = Type++-- An incomplete type as stored in GHCi:+--  no polymorphism: no quantifiers & all tyvars are skolem.+type GhciType = Type+++-- The Type Reconstruction monad+--------------------------------+type TR a = TcM a++runTR :: HscEnv -> TR a -> IO a+runTR hsc_env thing = do+  mb_val <- runTR_maybe hsc_env thing+  case mb_val of+    Nothing -> error "unable to :print the term"+    Just x  -> return x++runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)+runTR_maybe hsc_env thing_inside+  = do { (_errs, res) <- initTcInteractive hsc_env thing_inside+       ; return res }++-- | Term Reconstruction trace+traceTR :: SDoc -> TR ()+traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti+++-- Semantically different to recoverM in TcRnMonad+-- recoverM retains the errors in the first action,+--  whereas recoverTc here does not+recoverTR :: TR a -> TR a -> TR a+recoverTR = tryTcDiscardingErrs++trIO :: IO a -> TR a+trIO = liftTcM . liftIO++liftTcM :: TcM a -> TR a+liftTcM = id++newVar :: Kind -> TR TcType+newVar = liftTcM . newFlexiTyVarTy++newOpenVar :: TR TcType+newOpenVar = liftTcM newOpenFlexiTyVarTy++instTyVars :: [TyVar] -> TR (TCvSubst, [TcTyVar])+-- Instantiate fresh mutable type variables from some TyVars+-- This function preserves the print-name, which helps error messages+instTyVars tvs+  = liftTcM $ fst <$> captureConstraints (newMetaTyVars tvs)++type RttiInstantiation = [(TcTyVar, TyVar)]+   -- Associates the typechecker-world meta type variables+   -- (which are mutable and may be refined), to their+   -- debugger-world RuntimeUnk counterparts.+   -- If the TcTyVar has not been refined by the runtime type+   -- elaboration, then we want to turn it back into the+   -- original RuntimeUnk++-- | Returns the instantiated type scheme ty', and the+--   mapping from new (instantiated) -to- old (skolem) type variables+instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation)+instScheme (tvs, ty)+  = do { (subst, tvs') <- instTyVars tvs+       ; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs]+       ; return (substTy subst ty, rtti_inst) }++applyRevSubst :: RttiInstantiation -> TR ()+-- Apply the *reverse* substitution in-place to any un-filled-in+-- meta tyvars.  This recovers the original debugger-world variable+-- unless it has been refined by new information from the heap+applyRevSubst pairs = liftTcM (mapM_ do_pair pairs)+  where+    do_pair (tc_tv, rtti_tv)+      = do { tc_ty <- zonkTcTyVar tc_tv+           ; case tcGetTyVar_maybe tc_ty of+               Just tv | isMetaTyVar tv -> writeMetaTyVar tv (mkTyVarTy rtti_tv)+               _                        -> return () }++-- Adds a constraint of the form t1 == t2+-- t1 is expected to come from walking the heap+-- t2 is expected to come from a datacon signature+-- Before unification, congruenceNewtypes needs to+-- do its magic.+addConstraint :: TcType -> TcType -> TR ()+addConstraint actual expected = do+    traceTR (text "add constraint:" <+> fsep [ppr actual, equals, ppr expected])+    recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual,+                                    text "with", ppr expected]) $+      discardResult $+      captureConstraints $+      do { (ty1, ty2) <- congruenceNewtypes actual expected+         ; unifyType noThing ty1 ty2 }+     -- TOMDO: what about the coercion?+     -- we should consider family instances++-- Type & Term reconstruction+------------------------------+cvObtainTerm :: HscEnv -> Int -> Bool -> RttiType -> HValue -> IO Term+cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do+  -- we quantify existential tyvars as universal,+  -- as this is needed to be able to manipulate+  -- them properly+   let quant_old_ty@(old_tvs, old_tau) = quantifyType old_ty+       sigma_old_ty = mkInvForAllTys old_tvs old_tau+   traceTR (text "Term reconstruction started with initial type " <> ppr old_ty)+   term <-+     if null old_tvs+      then do+        term  <- go max_depth sigma_old_ty sigma_old_ty hval+        term' <- zonkTerm term+        return $ fixFunDictionaries $ expandNewtypes term'+      else do+              (old_ty', rev_subst) <- instScheme quant_old_ty+              my_ty <- newOpenVar+              when (check1 quant_old_ty) (traceTR (text "check1 passed") >>+                                          addConstraint my_ty old_ty')+              term  <- go max_depth my_ty sigma_old_ty hval+              new_ty <- zonkTcType (termType term)+              if isMonomorphic new_ty || check2 (quantifyType new_ty) quant_old_ty+                 then do+                      traceTR (text "check2 passed")+                      addConstraint new_ty old_ty'+                      applyRevSubst rev_subst+                      zterm' <- zonkTerm term+                      return ((fixFunDictionaries . expandNewtypes) zterm')+                 else do+                      traceTR (text "check2 failed" <+> parens+                                       (ppr term <+> text "::" <+> ppr new_ty))+                      -- we have unsound types. Replace constructor types in+                      -- subterms with tyvars+                      zterm' <- mapTermTypeM+                                 (\ty -> case tcSplitTyConApp_maybe ty of+                                           Just (tc, _:_) | tc /= funTyCon+                                               -> newOpenVar+                                           _   -> return ty)+                                 term+                      zonkTerm zterm'+   traceTR (text "Term reconstruction completed." $$+            text "Term obtained: " <> ppr term $$+            text "Type obtained: " <> ppr (termType term))+   return term+    where+  dflags = hsc_dflags hsc_env++  go :: Int -> Type -> Type -> HValue -> TcM Term+   -- I believe that my_ty should not have any enclosing+   -- foralls, nor any free RuntimeUnk skolems;+   -- that is partly what the quantifyType stuff achieved+   --+   -- [SPJ May 11] I don't understand the difference between my_ty and old_ty++  go 0 my_ty _old_ty a = do+    traceTR (text "Gave up reconstructing a term after" <>+                  int max_depth <> text " steps")+    clos <- trIO $ getClosureData dflags a+    return (Suspension (tipe clos) my_ty a Nothing)+  go !max_depth my_ty old_ty a = do+    let monomorphic = not(isTyVarTy my_ty)+    -- This ^^^ is a convention. The ancestor tests for+    -- monomorphism and passes a type instead of a tv+    clos <- trIO $ getClosureData dflags a+    case tipe clos of+-- Thunks we may want to force+      t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >>+                                seq a (go (pred max_depth) my_ty old_ty a)+-- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE.  So we+-- treat them like indirections; if the payload is TSO or BLOCKING_QUEUE, we'll end up+-- showing '_' which is what we want.+      Blackhole -> do traceTR (text "Following a BLACKHOLE")+                      appArr (go max_depth my_ty old_ty) (ptrs clos) 0+-- We always follow indirections+      Indirection i -> do traceTR (text "Following an indirection" <> parens (int i) )+                          go max_depth my_ty old_ty $! (ptrs clos ! 0)+-- We also follow references+      MutVar _ | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty+             -> do+                  -- Deal with the MutVar# primitive+                  -- It does not have a constructor at all,+                  -- so we simulate the following one+                  -- MutVar# :: contents_ty -> MutVar# s contents_ty+         traceTR (text "Following a MutVar")+         contents_tv <- newVar liftedTypeKind+         contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w+         ASSERT(isUnliftedType my_ty) return ()+         (mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy+                            contents_ty (mkTyConApp tycon [world,contents_ty])+         addConstraint (mkFunTy contents_tv my_ty) mutvar_ty+         x <- go (pred max_depth) contents_tv contents_ty contents+         return (RefWrap my_ty x)++ -- The interesting case+      Constr -> do+        traceTR (text "entering a constructor " <>+                      if monomorphic+                        then parens (text "already monomorphic: " <> ppr my_ty)+                        else Ppr.empty)+        Right dcname <- dataConInfoPtrToName (infoPtr clos)+        (_,mb_dc)    <- tryTc (tcLookupDataCon dcname)+        case mb_dc of+          Nothing -> do -- This can happen for private constructors compiled -O0+                        -- where the .hi descriptor does not export them+                        -- In such case, we return a best approximation:+                        --  ignore the unpointed args, and recover the pointeds+                        -- This preserves laziness, and should be safe.+                       traceTR (text "Not constructor" <+> ppr dcname)+                       let dflags = hsc_dflags hsc_env+                           tag = showPpr dflags dcname+                       vars     <- replicateM (length$ elems$ ptrs clos)+                                              (newVar liftedTypeKind)+                       subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i+                                              | (i, tv) <- zip [0..] vars]+                       return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)+          Just dc -> do+            traceTR (text "Is constructor" <+> (ppr dc $$ ppr my_ty))+            subTtypes <- getDataConArgTys dc my_ty+            subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) clos subTtypes+            return (Term my_ty (Right dc) a subTerms)++-- The otherwise case: can be a Thunk,AP,PAP,etc.+      tipe_clos -> do+         traceTR (text "Unknown closure:" <+> ppr tipe_clos)+         return (Suspension tipe_clos my_ty a Nothing)++  -- insert NewtypeWraps around newtypes+  expandNewtypes = foldTerm idTermFold { fTerm = worker } where+   worker ty dc hval tt+     | Just (tc, args) <- tcSplitTyConApp_maybe ty+     , isNewTyCon tc+     , wrapped_type    <- newTyConInstRhs tc args+     , Just dc'        <- tyConSingleDataCon_maybe tc+     , t'              <- worker wrapped_type dc hval tt+     = NewtypeWrap ty (Right dc') t'+     | otherwise = Term ty dc hval tt+++   -- Avoid returning types where predicates have been expanded to dictionaries.+  fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where+      worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n+                          | otherwise  = Suspension ct ty hval n++extractSubTerms :: (Type -> HValue -> TcM Term)+                -> Closure -> [Type] -> TcM [Term]+extractSubTerms recurse clos = liftM thdOf3 . go 0 (nonPtrs clos)+  where+    go ptr_i ws [] = return (ptr_i, ws, [])+    go ptr_i ws (ty:tys)+      | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty+      , isUnboxedTupleTyCon tc+                -- See Note [Unboxed tuple RuntimeRep vars] in TyCon+      = do (ptr_i, ws, terms0) <- go ptr_i ws (dropRuntimeRepArgs elem_tys)+           (ptr_i, ws, terms1) <- go ptr_i ws tys+           return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1)+      | otherwise+      = case typePrimRepArgs ty of+          [rep_ty] ->  do+            (ptr_i, ws, term0)  <- go_rep ptr_i ws ty rep_ty+            (ptr_i, ws, terms1) <- go ptr_i ws tys+            return (ptr_i, ws, term0 : terms1)+          rep_tys -> do+           (ptr_i, ws, terms0) <- go_unary_types ptr_i ws rep_tys+           (ptr_i, ws, terms1) <- go ptr_i ws tys+           return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1)++    go_unary_types ptr_i ws [] = return (ptr_i, ws, [])+    go_unary_types ptr_i ws (rep_ty:rep_tys) = do+      tv <- newVar liftedTypeKind+      (ptr_i, ws, term0)  <- go_rep ptr_i ws tv rep_ty+      (ptr_i, ws, terms1) <- go_unary_types ptr_i ws rep_tys+      return (ptr_i, ws, term0 : terms1)++    go_rep ptr_i ws ty rep+      | isGcPtrRep rep+      = do t <- appArr (recurse ty) (ptrs clos) ptr_i+           return (ptr_i + 1, ws, t)+      | otherwise+      = do dflags <- getDynFlags+           let (ws0, ws1) = splitAt (primRepSizeW dflags rep) ws+           return (ptr_i, ws1, Prim ty ws0)++    unboxedTupleTerm ty terms+      = Term ty (Right (tupleDataCon Unboxed (length terms)))+                (error "unboxedTupleTerm: no HValue for unboxed tuple") terms+++-- Fast, breadth-first Type reconstruction+------------------------------------------+cvReconstructType :: HscEnv -> Int -> GhciType -> HValue -> IO (Maybe Type)+cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do+   traceTR (text "RTTI started with initial type " <> ppr old_ty)+   let sigma_old_ty@(old_tvs, _) = quantifyType old_ty+   new_ty <-+       if null old_tvs+        then return old_ty+        else do+          (old_ty', rev_subst) <- instScheme sigma_old_ty+          my_ty <- newOpenVar+          when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>+                                      addConstraint my_ty old_ty')+          search (isMonomorphic `fmap` zonkTcType my_ty)+                 (\(ty,a) -> go ty a)+                 (Seq.singleton (my_ty, hval))+                 max_depth+          new_ty <- zonkTcType my_ty+          if isMonomorphic new_ty || check2 (quantifyType new_ty) sigma_old_ty+            then do+                 traceTR (text "check2 passed" <+> ppr old_ty $$ ppr new_ty)+                 addConstraint my_ty old_ty'+                 applyRevSubst rev_subst+                 zonkRttiType new_ty+            else traceTR (text "check2 failed" <+> parens (ppr new_ty)) >>+                 return old_ty+   traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty)+   return new_ty+    where+  dflags = hsc_dflags hsc_env++--  search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()+  search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>+                                int max_depth <> text " steps")+  search stop expand l d =+    case viewl l of+      EmptyL  -> return ()+      x :< xx -> unlessM stop $ do+                  new <- expand x+                  search stop expand (xx `mappend` Seq.fromList new) $! (pred d)++   -- returns unification tasks,since we are going to want a breadth-first search+  go :: Type -> HValue -> TR [(Type, HValue)]+  go my_ty a = do+    traceTR (text "go" <+> ppr my_ty)+    clos <- trIO $ getClosureData dflags a+    case tipe clos of+      Blackhole -> appArr (go my_ty) (ptrs clos) 0 -- carefully, don't eval the TSO+      Indirection _ -> go my_ty $! (ptrs clos ! 0)+      MutVar _ -> do+         contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w+         tv'   <- newVar liftedTypeKind+         world <- newVar liftedTypeKind+         addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv'])+         return [(tv', contents)]+      Constr -> do+        Right dcname <- dataConInfoPtrToName (infoPtr clos)+        traceTR (text "Constr1" <+> ppr dcname)+        (_,mb_dc)    <- tryTc (tcLookupDataCon dcname)+        case mb_dc of+          Nothing-> do+            forM (elems $ ptrs clos) $ \a -> do+              tv <- newVar liftedTypeKind+              return (tv, a)++          Just dc -> do+            arg_tys <- getDataConArgTys dc my_ty+            (_, itys) <- findPtrTyss 0 arg_tys+            traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys)+            return $ [ appArr (\e-> (ty,e)) (ptrs clos) i+                     | (i,ty) <- itys]+      _ -> return []++findPtrTys :: Int  -- Current pointer index+           -> Type -- Type+           -> TR (Int, [(Int, Type)])+findPtrTys i ty+  | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty+  , isUnboxedTupleTyCon tc+  = findPtrTyss i elem_tys++  | otherwise+  = case typePrimRep ty of+      [rep] | isGcPtrRep rep -> return (i + 1, [(i, ty)])+            | otherwise      -> return (i,     [])+      prim_reps              ->+        foldM (\(i, extras) prim_rep ->+                if isGcPtrRep prim_rep+                  then newVar liftedTypeKind >>= \tv -> return (i + 1, extras ++ [(i, tv)])+                  else return (i, extras))+              (i, []) prim_reps++findPtrTyss :: Int+            -> [Type]+            -> TR (Int, [(Int, Type)])+findPtrTyss i tys = foldM step (i, []) tys+  where step (i, discovered) elem_ty = do+          (i, extras) <- findPtrTys i elem_ty+          return (i, discovered ++ extras)+++-- Compute the difference between a base type and the type found by RTTI+-- improveType <base_type> <rtti_type>+-- The types can contain skolem type variables, which need to be treated as normal vars.+-- In particular, we want them to unify with things.+improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TCvSubst+improveRTTIType _ base_ty new_ty = U.tcUnifyTyKi base_ty new_ty++getDataConArgTys :: DataCon -> Type -> TR [Type]+-- Given the result type ty of a constructor application (D a b c :: ty)+-- return the types of the arguments.  This is RTTI-land, so 'ty' might+-- not be fully known.  Moreover, the arg types might involve existentials;+-- if so, make up fresh RTTI type variables for them+--+-- I believe that con_app_ty should not have any enclosing foralls+getDataConArgTys dc con_app_ty+  = do { let rep_con_app_ty = unwrapType con_app_ty+       ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty+                   $$ ppr (tcSplitTyConApp_maybe rep_con_app_ty)))+       ; (subst, _) <- instTyVars (univ_tvs ++ ex_tvs)+       ; addConstraint rep_con_app_ty (substTy subst (dataConOrigResTy dc))+              -- See Note [Constructor arg types]+       ; let con_arg_tys = substTys subst (dataConRepArgTys dc)+       ; traceTR (text "getDataConArgTys 2" <+> (ppr rep_con_app_ty $$ ppr con_arg_tys $$ ppr subst))+       ; return con_arg_tys }+  where+    univ_tvs = dataConUnivTyVars dc+    ex_tvs   = dataConExTyVars dc++{- Note [Constructor arg types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a GADT (cf Trac #7386)+   data family D a b+   data instance D [a] a where+     MkT :: a -> D [a] (Maybe a)+     ...++In getDataConArgTys+* con_app_ty is the known type (from outside) of the constructor application,+  say D [Int] Int++* The data constructor MkT has a (representation) dataConTyCon = DList,+  say where+    data DList a where+      MkT :: a -> DList a (Maybe a)+      ...++So the dataConTyCon of the data constructor, DList, differs from+the "outside" type, D. So we can't straightforwardly decompose the+"outside" type, and we end up in the "_" branch of the case.++Then we match the dataConOrigResTy of the data constructor against the+outside type, hoping to get a substitution that tells how to instantiate+the *representation* type constructor.   This looks a bit delicate to+me, but it seems to work.+-}++-- Soundness checks+--------------------+{-+This is not formalized anywhere, so hold to your seats!+RTTI in the presence of newtypes can be a tricky and unsound business.++Example:+~~~~~~~~~+Suppose we are doing RTTI for a partially evaluated+closure t, the real type of which is t :: MkT Int, for++   newtype MkT a = MkT [Maybe a]++The table below shows the results of RTTI and the improvement+calculated for different combinations of evaluatedness and :type t.+Regard the two first columns as input and the next two as output.++  # |     t     |  :type t  | rtti(t)  | improv.    | result+    ------------------------------------------------------------+  1 |     _     |    t b    |    a     | none       | OK+  2 |     _     |   MkT b   |    a     | none       | OK+  3 |     _     |   t Int   |    a     | none       | OK++  If t is not evaluated at *all*, we are safe.++  4 |  (_ : _)  |    t b    |   [a]    | t = []     | UNSOUND+  5 |  (_ : _)  |   MkT b   |  MkT a   | none       | OK (compensating for the missing newtype)+  6 |  (_ : _)  |   t Int   |  [Int]   | t = []     | UNSOUND++  If a is a minimal whnf, we run into trouble. Note that+  row 5 above does newtype enrichment on the ty_rtty parameter.++  7 | (Just _:_)|    t b    |[Maybe a] | t = [],    | UNSOUND+    |                       |          | b = Maybe a|++  8 | (Just _:_)|   MkT b   |  MkT a   |  none      | OK+  9 | (Just _:_)|   t Int   |   FAIL   |  none      | OK++  And if t is any more evaluated than whnf, we are still in trouble.+  Because constraints are solved in top-down order, when we reach the+  Maybe subterm what we got is already unsound. This explains why the+  row 9 fails to complete.++  10 | (Just _:_)|  t Int  | [Maybe a]   |  FAIL    | OK+  11 | (Just 1:_)|  t Int  | [Maybe Int] |  FAIL    | OK++  We can undo the failure in row 9 by leaving out the constraint+  coming from the type signature of t (i.e., the 2nd column).+  Note that this type information is still used+  to calculate the improvement. But we fail+  when trying to calculate the improvement, as there is no unifier for+  t Int = [Maybe a] or t Int = [Maybe Int].+++  Another set of examples with t :: [MkT (Maybe Int)]  \equiv  [[Maybe (Maybe Int)]]++  # |     t     |    :type t    |  rtti(t)    | improvement | result+    ---------------------------------------------------------------------+  1 |(Just _:_) | [t (Maybe a)] | [[Maybe b]] | t = []      |+    |           |               |             | b = Maybe a |++The checks:+~~~~~~~~~~~+Consider a function obtainType that takes a value and a type and produces+the Term representation and a substitution (the improvement).+Assume an auxiliar rtti' function which does the actual job if recovering+the type, but which may produce a false type.++In pseudocode:++  rtti' :: a -> IO Type  -- Does not use the static type information++  obtainType :: a -> Type -> IO (Maybe (Term, Improvement))+  obtainType v old_ty = do+       rtti_ty <- rtti' v+       if monomorphic rtti_ty || (check rtti_ty old_ty)+        then ...+         else return Nothing+  where check rtti_ty old_ty = check1 rtti_ty &&+                              check2 rtti_ty old_ty++  check1 :: Type -> Bool+  check2 :: Type -> Type -> Bool++Now, if rtti' returns a monomorphic type, we are safe.+If that is not the case, then we consider two conditions.+++1. To prevent the class of unsoundness displayed by+   rows 4 and 7 in the example: no higher kind tyvars+   accepted.++  check1 (t a)   = NO+  check1 (t Int) = NO+  check1 ([] a)  = YES++2. To prevent the class of unsoundness shown by row 6,+   the rtti type should be structurally more+   defined than the old type we are comparing it to.+  check2 :: NewType -> OldType -> Bool+  check2 a  _        = True+  check2 [a] a       = True+  check2 [a] (t Int) = False+  check2 [a] (t a)   = False  -- By check1 we never reach this equation+  check2 [Int] a     = True+  check2 [Int] (t Int) = True+  check2 [Maybe a]   (t Int) = False+  check2 [Maybe Int] (t Int) = True+  check2 (Maybe [a])   (m [Int]) = False+  check2 (Maybe [Int]) (m [Int]) = True++-}++check1 :: QuantifiedType -> Bool+check1 (tvs, _) = not $ any isHigherKind (map tyVarKind tvs)+ where+   isHigherKind = not . null . fst . splitPiTys++check2 :: QuantifiedType -> QuantifiedType -> Bool+check2 (_, rtti_ty) (_, old_ty)+  | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty+  = case () of+      _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty+        -> and$ zipWith check2 (map quantifyType rttis) (map quantifyType olds)+      _ | Just _ <- splitAppTy_maybe old_ty+        -> isMonomorphicOnNonPhantomArgs rtti_ty+      _ -> True+  | otherwise = True++-- Dealing with newtypes+--------------------------+{-+ congruenceNewtypes does a parallel fold over two Type values,+ compensating for missing newtypes on both sides.+ This is necessary because newtypes are not present+ in runtime, but sometimes there is evidence available.+   Evidence can come from DataCon signatures or+ from compile-time type inference.+ What we are doing here is an approximation+ of unification modulo a set of equations derived+ from newtype definitions. These equations should be the+ same as the equality coercions generated for newtypes+ in System Fc. The idea is to perform a sort of rewriting,+ taking those equations as rules, before launching unification.++ The caller must ensure the following.+ The 1st type (lhs) comes from the heap structure of ptrs,nptrs.+ The 2nd type (rhs) comes from a DataCon type signature.+ Rewriting (i.e. adding/removing a newtype wrapper) can happen+ in both types, but in the rhs it is restricted to the result type.++   Note that it is very tricky to make this 'rewriting'+ work with the unification implemented by TcM, where+ substitutions are operationally inlined. The order in which+ constraints are unified is vital as we cannot modify+ anything that has been touched by a previous unification step.+Therefore, congruenceNewtypes is sound only if the types+recovered by the RTTI mechanism are unified Top-Down.+-}+congruenceNewtypes ::  TcType -> TcType -> TR (TcType,TcType)+congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')+ where+   go l r+ -- TyVar lhs inductive case+    | Just tv <- getTyVar_maybe l+    , isTcTyVar tv+    , isMetaTyVar tv+    = recoverTR (return r) $ do+         Indirect ty_v <- readMetaTyVar tv+         traceTR $ fsep [text "(congruence) Following indirect tyvar:",+                          ppr tv, equals, ppr ty_v]+         go ty_v r+-- FunTy inductive case+    | Just (l1,l2) <- splitFunTy_maybe l+    , Just (r1,r2) <- splitFunTy_maybe r+    = do r2' <- go l2 r2+         r1' <- go l1 r1+         return (mkFunTy r1' r2')+-- TyconApp Inductive case; this is the interesting bit.+    | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs+    , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs+    , tycon_l /= tycon_r+    = upgrade tycon_l r++    | otherwise = return r++    where upgrade :: TyCon -> Type -> TR Type+          upgrade new_tycon ty+            | not (isNewTyCon new_tycon) = do+              traceTR (text "(Upgrade) Not matching newtype evidence: " <>+                       ppr new_tycon <> text " for " <> ppr ty)+              return ty+            | otherwise = do+               traceTR (text "(Upgrade) upgraded " <> ppr ty <>+                        text " in presence of newtype evidence " <> ppr new_tycon)+               (_, vars) <- instTyVars (tyConTyVars new_tycon)+               let ty' = mkTyConApp new_tycon (mkTyVarTys vars)+                   rep_ty = unwrapType ty'+               _ <- liftTcM (unifyType noThing ty rep_ty)+        -- assumes that reptype doesn't ^^^^ touch tyconApp args+               return ty'+++zonkTerm :: Term -> TcM Term+zonkTerm = foldTermM (TermFoldM+             { fTermM = \ty dc v tt -> zonkRttiType ty    >>= \ty' ->+                                       return (Term ty' dc v tt)+             , fSuspensionM  = \ct ty v b -> zonkRttiType ty >>= \ty ->+                                             return (Suspension ct ty v b)+             , fNewtypeWrapM = \ty dc t -> zonkRttiType ty >>= \ty' ->+                                           return$ NewtypeWrap ty' dc t+             , fRefWrapM     = \ty t -> return RefWrap  `ap`+                                        zonkRttiType ty `ap` return t+             , fPrimM        = (return.) . Prim })++zonkRttiType :: TcType -> TcM Type+-- Zonk the type, replacing any unbound Meta tyvars+-- by skolems, safely out of Meta-tyvar-land+zonkRttiType = zonkTcTypeToType (mkEmptyZonkEnv zonk_unbound_meta)+  where+    zonk_unbound_meta tv+      = ASSERT( isTcTyVar tv )+        do { tv' <- skolemiseRuntimeUnk tv+             -- This is where RuntimeUnks are born:+             -- otherwise-unconstrained unification variables are+             -- turned into RuntimeUnks as they leave the+             -- typechecker's monad+           ; return (mkTyVarTy tv') }++--------------------------------------------------------------------------------+-- Restore Class predicates out of a representation type+dictsView :: Type -> Type+dictsView ty = ty+++-- Use only for RTTI types+isMonomorphic :: RttiType -> Bool+isMonomorphic ty = noExistentials && noUniversals+ where (tvs, _, ty')  = tcSplitSigmaTy ty+       noExistentials = noFreeVarsOfType ty'+       noUniversals   = null tvs++-- Use only for RTTI types+isMonomorphicOnNonPhantomArgs :: RttiType -> Bool+isMonomorphicOnNonPhantomArgs ty+  | Just (tc, all_args) <- tcSplitTyConApp_maybe (unwrapType ty)+  , phantom_vars  <- tyConPhantomTyVars tc+  , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args+                           , tyv `notElem` phantom_vars]+  = all isMonomorphicOnNonPhantomArgs concrete_args+  | Just (ty1, ty2) <- splitFunTy_maybe ty+  = all isMonomorphicOnNonPhantomArgs [ty1,ty2]+  | otherwise = isMonomorphic ty++tyConPhantomTyVars :: TyCon -> [TyVar]+tyConPhantomTyVars tc+  | isAlgTyCon tc+  , Just dcs <- tyConDataCons_maybe tc+  , dc_vars  <- concatMap dataConUnivTyVars dcs+  = tyConTyVars tc \\ dc_vars+tyConPhantomTyVars _ = []++type QuantifiedType = ([TyVar], Type)+   -- Make the free type variables explicit+   -- The returned Type should have no top-level foralls (I believe)++quantifyType :: Type -> QuantifiedType+-- Generalize the type: find all free and forall'd tyvars+-- and return them, together with the type inside, which+-- should not be a forall type.+--+-- Thus (quantifyType (forall a. a->[b]))+-- returns ([a,b], a -> [b])++quantifyType ty = ( filter isTyVar $+                    tyCoVarsOfTypeWellScoped rho+                  , rho)+  where+    (_tvs, rho) = tcSplitForAllTys ty++-- Strict application of f at index i+appArr :: Ix i => (e -> a) -> Array i e -> Int -> a+appArr f a@(Array _ _ _ ptrs#) i@(I# i#)+ = ASSERT2(i < length(elems a), ppr(length$ elems a, i))+   case indexArray# ptrs# i# of+       (# e #) -> f e++amap' :: (t -> b) -> Array Int t -> [b]+amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]+    where g (I# i#) = case indexArray# arr# i# of+                          (# e #) -> f e
+ ghci/keepCAFsForGHCi.c view
@@ -0,0 +1,15 @@+#include "Rts.h"++// This file is only included in the dynamic library.+// It contains an __attribute__((constructor)) function (run prior to main())+// which sets the keepCAFs flag in the RTS, before any Haskell code is run.+// This is required so that GHCi can use dynamic libraries instead of HSxyz.o+// files.++static void keepCAFsForGHCi(void) __attribute__((constructor));++static void keepCAFsForGHCi(void)+{+    keepCAFs = 1;+}+
+ hsSyn/Convert.hs view
@@ -0,0 +1,1721 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++This module converts Template Haskell syntax into HsSyn+-}++{-# LANGUAGE ScopedTypeVariables #-}++module Convert( convertToHsExpr, convertToPat, convertToHsDecls,+                convertToHsType,+                thRdrNameGuesses ) where++import HsSyn as Hs+import qualified Class+import RdrName+import qualified Name+import Module+import RdrHsSyn+import qualified OccName+import OccName+import SrcLoc+import Type+import qualified Coercion ( Role(..) )+import TysWiredIn+import TysPrim (eqPrimTyCon)+import BasicTypes as Hs+import ForeignCall+import Unique+import ErrUtils+import Bag+import Lexeme+import Util+import FastString+import Outputable+import MonadUtils ( foldrM )++import qualified Data.ByteString as BS+import Control.Monad( unless, liftM, ap, (<=<) )++import Data.Maybe( catMaybes, fromMaybe, isNothing )+import Language.Haskell.TH as TH hiding (sigP)+import Language.Haskell.TH.Syntax as TH++-------------------------------------------------------------------+--              The external interface++convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl RdrName]+convertToHsDecls loc ds = initCvt loc (fmap catMaybes (mapM cvt_dec ds))+  where+    cvt_dec d = wrapMsg "declaration" d (cvtDec d)++convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr RdrName)+convertToHsExpr loc e+  = initCvt loc $ wrapMsg "expression" e $ cvtl e++convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat RdrName)+convertToPat loc p+  = initCvt loc $ wrapMsg "pattern" p $ cvtPat p++convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType RdrName)+convertToHsType loc t+  = initCvt loc $ wrapMsg "type" t $ cvtType t++-------------------------------------------------------------------+newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) }+        -- Push down the source location;+        -- Can fail, with a single error message++-- NB: If the conversion succeeds with (Right x), there should+--     be no exception values hiding in x+-- Reason: so a (head []) in TH code doesn't subsequently+--         make GHC crash when it tries to walk the generated tree++-- Use the loc everywhere, for lack of anything better+-- In particular, we want it on binding locations, so that variables bound in+-- the spliced-in declarations get a location that at least relates to the splice point++instance Functor CvtM where+    fmap = liftM++instance Applicative CvtM where+    pure x = CvtM $ \loc -> Right (loc,x)+    (<*>) = ap++instance Monad CvtM where+  (CvtM m) >>= k = CvtM $ \loc -> case m loc of+                                  Left err -> Left err+                                  Right (loc',v) -> unCvtM (k v) loc'++initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a+initCvt loc (CvtM m) = fmap snd (m loc)++force :: a -> CvtM ()+force a = a `seq` return ()++failWith :: MsgDoc -> CvtM a+failWith m = CvtM (\_ -> Left m)++getL :: CvtM SrcSpan+getL = CvtM (\loc -> Right (loc,loc))++setL :: SrcSpan -> CvtM ()+setL loc = CvtM (\_ -> Right (loc, ()))++returnL :: a -> CvtM (Located a)+returnL x = CvtM (\loc -> Right (loc, L loc x))++returnJustL :: a -> CvtM (Maybe (Located a))+returnJustL = fmap Just . returnL++wrapParL :: (Located a -> a) -> a -> CvtM a+wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (L loc x)))++wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b+-- E.g  wrapMsg "declaration" dec thing+wrapMsg what item (CvtM m)+  = CvtM (\loc -> case m loc of+                     Left err -> Left (err $$ getPprStyle msg)+                     Right v  -> Right v)+  where+        -- Show the item in pretty syntax normally,+        -- but with all its constructors if you say -dppr-debug+    msg sty = hang (text "When splicing a TH" <+> text what <> colon)+                 2 (if debugStyle sty+                    then text (show item)+                    else text (pprint item))++wrapL :: CvtM a -> CvtM (Located a)+wrapL (CvtM m) = CvtM (\loc -> case m loc of+                               Left err -> Left err+                               Right (loc',v) -> Right (loc',L loc v))++-------------------------------------------------------------------+cvtDecs :: [TH.Dec] -> CvtM [LHsDecl RdrName]+cvtDecs = fmap catMaybes . mapM cvtDec++cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl RdrName))+cvtDec (TH.ValD pat body ds)+  | TH.VarP s <- pat+  = do  { s' <- vNameL s+        ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds)+        ; returnJustL $ Hs.ValD $ mkFunBind s' [cl'] }++  | otherwise+  = do  { pat' <- cvtPat pat+        ; body' <- cvtGuard body+        ; ds' <- cvtLocalDecs (text "a where clause") ds+        ; returnJustL $ Hs.ValD $+          PatBind { pat_lhs = pat', pat_rhs = GRHSs body' (noLoc ds')+                  , pat_rhs_ty = placeHolderType, bind_fvs = placeHolderNames+                  , pat_ticks = ([],[]) } }++cvtDec (TH.FunD nm cls)+  | null cls+  = failWith (text "Function binding for"+                 <+> quotes (text (TH.pprint nm))+                 <+> text "has no equations")+  | otherwise+  = do  { nm' <- vNameL nm+        ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls+        ; returnJustL $ Hs.ValD $ mkFunBind nm' cls' }++cvtDec (TH.SigD nm typ)+  = do  { nm' <- vNameL nm+        ; ty' <- cvtType typ+        ; returnJustL $ Hs.SigD (TypeSig [nm'] (mkLHsSigWcType ty')) }++cvtDec (TH.InfixD fx nm)+  -- Fixity signatures are allowed for variables, constructors, and types+  -- the renamer automatically looks for types during renaming, even when+  -- the RdrName says it's a variable or a constructor. So, just assume+  -- it's a variable or constructor and proceed.+  = do { nm' <- vcNameL nm+       ; returnJustL (Hs.SigD (FixSig (FixitySig [nm'] (cvtFixity fx)))) }++cvtDec (PragmaD prag)+  = cvtPragmaD prag++cvtDec (TySynD tc tvs rhs)+  = do  { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs+        ; rhs' <- cvtType rhs+        ; returnJustL $ TyClD $+          SynDecl { tcdLName = tc', tcdTyVars = tvs'+                  , tcdFixity = Prefix+                  , tcdFVs = placeHolderNames+                  , tcdRhs = rhs' } }++cvtDec (DataD ctxt tc tvs ksig constrs derivs)+  = do  { let isGadtCon (GadtC    _ _ _) = True+              isGadtCon (RecGadtC _ _ _) = True+              isGadtCon (ForallC  _ _ c) = isGadtCon c+              isGadtCon _                = False+              isGadtDecl  = all isGadtCon constrs+              isH98Decl   = all (not . isGadtCon) constrs+        ; unless (isGadtDecl || isH98Decl)+                 (failWith (text "Cannot mix GADT constructors with Haskell 98"+                        <+> text "constructors"))+        ; unless (isNothing ksig || isGadtDecl)+                 (failWith (text "Kind signatures are only allowed on GADTs"))+        ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs+        ; ksig' <- cvtKind `traverse` ksig+        ; cons' <- mapM cvtConstr constrs+        ; derivs' <- cvtDerivs derivs+        ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing+                                , dd_ctxt = ctxt'+                                , dd_kindSig = ksig'+                                , dd_cons = cons', dd_derivs = derivs' }+        ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'+                                        , tcdFixity = Prefix+                                        , tcdDataDefn = defn+                                        , tcdDataCusk = PlaceHolder+                                        , tcdFVs = placeHolderNames }) }++cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)+  = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs+        ; ksig' <- cvtKind `traverse` ksig+        ; con' <- cvtConstr constr+        ; derivs' <- cvtDerivs derivs+        ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing+                                , dd_ctxt = ctxt'+                                , dd_kindSig = ksig'+                                , dd_cons = [con']+                                , dd_derivs = derivs' }+        ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'+                                    , tcdFixity = Prefix+                                    , tcdDataDefn = defn+                                    , tcdDataCusk = PlaceHolder+                                    , tcdFVs = placeHolderNames }) }++cvtDec (ClassD ctxt cl tvs fds decs)+  = do  { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs+        ; fds'  <- mapM cvt_fundep fds+        ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs (text "a class declaration") decs+        ; unless (null adts')+            (failWith $ (text "Default data instance declarations"+                     <+> text "are not allowed:")+                   $$ (Outputable.ppr adts'))+        ; at_defs <- mapM cvt_at_def ats'+        ; returnJustL $ TyClD $+          ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'+                    , tcdFixity = Prefix+                    , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'+                    , tcdMeths = binds'+                    , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = []+                    , tcdFVs = placeHolderNames }+                              -- no docs in TH ^^+        }+  where+    cvt_at_def :: LTyFamInstDecl RdrName -> CvtM (LTyFamDefltEqn RdrName)+    -- Very similar to what happens in RdrHsSyn.mkClassDecl+    cvt_at_def decl = case RdrHsSyn.mkATDefault decl of+                        Right def     -> return def+                        Left (_, msg) -> failWith msg++cvtDec (InstanceD o ctxt ty decs)+  = do  { let doc = text "an instance declaration"+        ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs+        ; unless (null fams') (failWith (mkBadDecMsg doc fams'))+        ; ctxt' <- cvtContext ctxt+        ; L loc ty' <- cvtType ty+        ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ L loc ty'+        ; returnJustL $ InstD $ ClsInstD $+          ClsInstDecl { cid_poly_ty = mkLHsSigType inst_ty'+                      , cid_binds = binds'+                      , cid_sigs = Hs.mkClassOpSigs sigs'+                      , cid_tyfam_insts = ats', cid_datafam_insts = adts'+                      , cid_overlap_mode = fmap (L loc . overlap) o } }+  where+  overlap pragma =+    case pragma of+      TH.Overlaps      -> Hs.Overlaps     (SourceText "OVERLAPS")+      TH.Overlappable  -> Hs.Overlappable (SourceText "OVERLAPPABLE")+      TH.Overlapping   -> Hs.Overlapping  (SourceText "OVERLAPPING")+      TH.Incoherent    -> Hs.Incoherent   (SourceText "INCOHERENT")+++++cvtDec (ForeignD ford)+  = do { ford' <- cvtForD ford+       ; returnJustL $ ForD ford' }++cvtDec (DataFamilyD tc tvs kind)+  = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs+       ; result <- cvtMaybeKindToFamilyResultSig kind+       ; returnJustL $ TyClD $ FamDecl $+         FamilyDecl DataFamily tc' tvs' Prefix result Nothing }++cvtDec (DataInstD ctxt tc tys ksig constrs derivs)+  = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys+       ; ksig' <- cvtKind `traverse` ksig+       ; cons' <- mapM cvtConstr constrs+       ; derivs' <- cvtDerivs derivs+       ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing+                               , dd_ctxt = ctxt'+                               , dd_kindSig = ksig'+                               , dd_cons = cons', dd_derivs = derivs' }++       ; returnJustL $ InstD $ DataFamInstD+           { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'+                                         , dfid_defn = defn+                                         , dfid_fixity = Prefix+                                         , dfid_fvs = placeHolderNames } }}++cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs)+  = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys+       ; ksig' <- cvtKind `traverse` ksig+       ; con' <- cvtConstr constr+       ; derivs' <- cvtDerivs derivs+       ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing+                               , dd_ctxt = ctxt'+                               , dd_kindSig = ksig'+                               , dd_cons = [con'], dd_derivs = derivs' }+       ; returnJustL $ InstD $ DataFamInstD+           { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'+                                         , dfid_defn = defn+                                         , dfid_fixity = Prefix+                                         , dfid_fvs = placeHolderNames } }}++cvtDec (TySynInstD tc eqn)+  = do  { tc' <- tconNameL tc+        ; eqn' <- cvtTySynEqn tc' eqn+        ; returnJustL $ InstD $ TyFamInstD+            { tfid_inst = TyFamInstDecl { tfid_eqn = eqn'+                                        , tfid_fvs = placeHolderNames } } }++cvtDec (OpenTypeFamilyD head)+  = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head+       ; returnJustL $ TyClD $ FamDecl $+         FamilyDecl OpenTypeFamily tc' tyvars' Prefix result' injectivity' }++cvtDec (ClosedTypeFamilyD head eqns)+  = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head+       ; eqns' <- mapM (cvtTySynEqn tc') eqns+       ; returnJustL $ TyClD $ FamDecl $+         FamilyDecl (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix result'+                                      injectivity' }++cvtDec (TH.RoleAnnotD tc roles)+  = do { tc' <- tconNameL tc+       ; let roles' = map (noLoc . cvtRole) roles+       ; returnJustL $ Hs.RoleAnnotD (RoleAnnotDecl tc' roles') }++cvtDec (TH.StandaloneDerivD ds cxt ty)+  = do { cxt' <- cvtContext cxt+       ; L loc ty'  <- cvtType ty+       ; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty'+       ; returnJustL $ DerivD $+         DerivDecl { deriv_strategy = fmap (L loc . cvtDerivStrategy) ds+                   , deriv_type = mkLHsSigType inst_ty'+                   , deriv_overlap_mode = Nothing } }++cvtDec (TH.DefaultSigD nm typ)+  = do { nm' <- vNameL nm+       ; ty' <- cvtType typ+       ; returnJustL $ Hs.SigD $ ClassOpSig True [nm'] (mkLHsSigType ty') }++cvtDec (TH.PatSynD nm args dir pat)+  = do { nm'   <- cNameL nm+       ; args' <- cvtArgs args+       ; dir'  <- cvtDir nm' dir+       ; pat'  <- cvtPat pat+       ; returnJustL $ Hs.ValD $ PatSynBind $+           PSB nm' placeHolderType args' pat' dir' }+  where+    cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixPatSyn <$> mapM vNameL args+    cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixPatSyn <$> vNameL a1 <*> vNameL a2+    cvtArgs (TH.RecordPatSyn sels)+      = do { sels' <- mapM vNameL sels+           ; vars' <- mapM (vNameL . mkNameS . nameBase) sels+           ; return $ Hs.RecordPatSyn $ zipWith RecordPatSynField sels' vars' }++    cvtDir _ Unidir          = return Unidirectional+    cvtDir _ ImplBidir       = return ImplicitBidirectional+    cvtDir n (ExplBidir cls) =+      do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls+         ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms }++cvtDec (TH.PatSynSigD nm ty)+  = do { nm' <- cNameL nm+       ; ty' <- cvtPatSynSigTy ty+       ; returnJustL $ Hs.SigD $ PatSynSig [nm'] (mkLHsSigType ty') }++----------------+cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)+cvtTySynEqn tc (TySynEqn lhs rhs)+  = do  { lhs' <- mapM (wrap_apps <=< cvtType) lhs+        ; rhs' <- cvtType rhs+        ; returnL $ TyFamEqn { tfe_tycon = tc+                             , tfe_pats = mkHsImplicitBndrs lhs'+                             , tfe_fixity = Prefix+                             , tfe_rhs = rhs' } }++----------------+cvt_ci_decs :: MsgDoc -> [TH.Dec]+            -> CvtM (LHsBinds RdrName,+                     [LSig RdrName],+                     [LFamilyDecl RdrName],+                     [LTyFamInstDecl RdrName],+                     [LDataFamInstDecl RdrName])+-- Convert the declarations inside a class or instance decl+-- ie signatures, bindings, and associated types+cvt_ci_decs doc decs+  = do  { decs' <- cvtDecs decs+        ; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs'+        ; let (adts', no_ats')       = partitionWith is_datafam_inst bind_sig_decs'+        ; let (sigs', prob_binds')   = partitionWith is_sig no_ats'+        ; let (binds', prob_fams')   = partitionWith is_bind prob_binds'+        ; let (fams', bads)          = partitionWith is_fam_decl prob_fams'+        ; unless (null bads) (failWith (mkBadDecMsg doc bads))+          --We use FromSource as the origin of the bind+          -- because the TH declaration is user-written+        ; return (listToBag binds', sigs', fams', ats', adts') }++----------------+cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]+             -> CvtM ( LHsContext RdrName+                     , Located RdrName+                     , LHsQTyVars RdrName)+cvt_tycl_hdr cxt tc tvs+  = do { cxt' <- cvtContext cxt+       ; tc'  <- tconNameL tc+       ; tvs' <- cvtTvs tvs+       ; return (cxt', tc', tvs')+       }++cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]+               -> CvtM ( LHsContext RdrName+                       , Located RdrName+                       , HsImplicitBndrs RdrName [LHsType RdrName])+cvt_tyinst_hdr cxt tc tys+  = do { cxt' <- cvtContext cxt+       ; tc'  <- tconNameL tc+       ; tys' <- mapM (wrap_apps <=< cvtType) tys+       ; return (cxt', tc', mkHsImplicitBndrs tys') }++----------------+cvt_tyfam_head :: TypeFamilyHead+               -> CvtM ( Located RdrName+                       , LHsQTyVars RdrName+                       , Hs.LFamilyResultSig RdrName+                       , Maybe (Hs.LInjectivityAnn RdrName))++cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity)+  = do {(_, tc', tyvars') <- cvt_tycl_hdr [] tc tyvars+       ; result' <- cvtFamilyResultSig result+       ; injectivity' <- traverse cvtInjectivityAnnotation injectivity+       ; return (tc', tyvars', result', injectivity') }++-------------------------------------------------------------------+--              Partitioning declarations+-------------------------------------------------------------------++is_fam_decl :: LHsDecl RdrName -> Either (LFamilyDecl RdrName) (LHsDecl RdrName)+is_fam_decl (L loc (TyClD (FamDecl { tcdFam = d }))) = Left (L loc d)+is_fam_decl decl = Right decl++is_tyfam_inst :: LHsDecl RdrName -> Either (LTyFamInstDecl RdrName) (LHsDecl RdrName)+is_tyfam_inst (L loc (Hs.InstD (TyFamInstD { tfid_inst = d }))) = Left (L loc d)+is_tyfam_inst decl                                              = Right decl++is_datafam_inst :: LHsDecl RdrName -> Either (LDataFamInstDecl RdrName) (LHsDecl RdrName)+is_datafam_inst (L loc (Hs.InstD (DataFamInstD { dfid_inst = d }))) = Left (L loc d)+is_datafam_inst decl                                                = Right decl++is_sig :: LHsDecl RdrName -> Either (LSig RdrName) (LHsDecl RdrName)+is_sig (L loc (Hs.SigD sig)) = Left (L loc sig)+is_sig decl                  = Right decl++is_bind :: LHsDecl RdrName -> Either (LHsBind RdrName) (LHsDecl RdrName)+is_bind (L loc (Hs.ValD bind)) = Left (L loc bind)+is_bind decl                   = Right decl++mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc+mkBadDecMsg doc bads+  = sep [ text "Illegal declaration(s) in" <+> doc <> colon+        , nest 2 (vcat (map Outputable.ppr bads)) ]++---------------------------------------------------+--      Data types+---------------------------------------------------++cvtConstr :: TH.Con -> CvtM (LConDecl RdrName)++cvtConstr (NormalC c strtys)+  = do  { c'   <- cNameL c+        ; cxt' <- returnL []+        ; tys' <- mapM cvt_arg strtys+        ; returnL $ mkConDeclH98 c' Nothing cxt' (PrefixCon tys') }++cvtConstr (RecC c varstrtys)+  = do  { c'    <- cNameL c+        ; cxt'  <- returnL []+        ; args' <- mapM cvt_id_arg varstrtys+        ; returnL $ mkConDeclH98 c' Nothing cxt'+                                   (RecCon (noLoc args')) }++cvtConstr (InfixC st1 c st2)+  = do  { c'   <- cNameL c+        ; cxt' <- returnL []+        ; st1' <- cvt_arg st1+        ; st2' <- cvt_arg st2+        ; returnL $ mkConDeclH98 c' Nothing cxt' (InfixCon st1' st2') }++cvtConstr (ForallC tvs ctxt con)+  = do  { tvs'        <- cvtTvs tvs+        ; L loc ctxt' <- cvtContext ctxt+        ; L _ con'    <- cvtConstr con+        ; returnL $ case con' of+                ConDeclGADT { con_type = conT } ->+                  let hs_ty  = mkHsForAllTy tvs noSrcSpan tvs' rho_ty+                      rho_ty = mkHsQualTy ctxt noSrcSpan (L loc ctxt')+                                                         (hsib_body conT)+                  in con' { con_type = mkHsImplicitBndrs hs_ty }+                ConDeclH98  {} ->+                  let qvars = case (tvs, con_qvars con') of+                        ([], Nothing) -> Nothing+                        (_ , m_qvs  ) -> Just $+                          mkHsQTvs (hsQTvExplicit tvs' +++                                    maybe [] hsQTvExplicit m_qvs)+                  in con' { con_qvars = qvars+                          , con_cxt = Just $+                            L loc (ctxt' +++                                   unLoc (fromMaybe (noLoc [])+                                          (con_cxt con'))) } }++cvtConstr (GadtC c strtys ty)+  = do  { c'      <- mapM cNameL c+        ; args    <- mapM cvt_arg strtys+        ; L _ ty' <- cvtType ty+        ; c_ty    <- mk_arr_apps args ty'+        ; returnL $ mkGadtDecl c' (mkLHsSigType c_ty)}++cvtConstr (RecGadtC c varstrtys ty)+  = do  { c'       <- mapM cNameL c+        ; ty'      <- cvtType ty+        ; rec_flds <- mapM cvt_id_arg varstrtys+        ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ty')+        ; returnL $ mkGadtDecl c' (mkLHsSigType rec_ty) }++cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness+cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack+cvtSrcUnpackedness SourceNoUnpack       = SrcNoUnpack+cvtSrcUnpackedness SourceUnpack         = SrcUnpack++cvtSrcStrictness :: TH.SourceStrictness -> SrcStrictness+cvtSrcStrictness NoSourceStrictness = NoSrcStrict+cvtSrcStrictness SourceLazy         = SrcLazy+cvtSrcStrictness SourceStrict       = SrcStrict++cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType RdrName)+cvt_arg (Bang su ss, ty)+  = do { ty'' <- cvtType ty+       ; ty' <- wrap_apps ty''+       ; let su' = cvtSrcUnpackedness su+       ; let ss' = cvtSrcStrictness ss+       ; returnL $ HsBangTy (HsSrcBang NoSourceText su' ss') ty' }++cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField RdrName)+cvt_id_arg (i, str, ty)+  = do  { L li i' <- vNameL i+        ; ty' <- cvt_arg (str,ty)+        ; return $ noLoc (ConDeclField+                          { cd_fld_names+                              = [L li $ FieldOcc (L li i') PlaceHolder]+                          , cd_fld_type =  ty'+                          , cd_fld_doc = Nothing}) }++cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving RdrName)+cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs+                  ; returnL cs' }++cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName)))+cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs+                               ; ys' <- mapM tNameL ys+                               ; returnL (xs', ys') }+++------------------------------------------+--      Foreign declarations+------------------------------------------++cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)+cvtForD (ImportF callconv safety from nm ty)+  -- the prim and javascript calling conventions do not support headers+  -- and are inserted verbatim, analogous to mkImport in RdrHsSyn+  | callconv == TH.Prim || callconv == TH.JavaScript+  = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing+                    (CFunction (StaticTarget (SourceText from)+                                             (mkFastString from) Nothing+                                             True))+                    (noLoc $ quotedSourceText from))+  | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')+                                 (mkFastString (TH.nameBase nm))+                                 from (noLoc $ quotedSourceText from)+  = mk_imp impspec+  | otherwise+  = failWith $ text (show from) <+> text "is not a valid ccall impent"+  where+    mk_imp impspec+      = do { nm' <- vNameL nm+           ; ty' <- cvtType ty+           ; return (ForeignImport { fd_name = nm'+                                   , fd_sig_ty = mkLHsSigType ty'+                                   , fd_co = noForeignImportCoercionYet+                                   , fd_fi = impspec })+           }+    safety' = case safety of+                     Unsafe     -> PlayRisky+                     Safe       -> PlaySafe+                     Interruptible -> PlayInterruptible++cvtForD (ExportF callconv as nm ty)+  = do  { nm' <- vNameL nm+        ; ty' <- cvtType ty+        ; let e = CExport (noLoc (CExportStatic (SourceText as)+                                                (mkFastString as)+                                                (cvt_conv callconv)))+                                                (noLoc (SourceText as))+        ; return $ ForeignExport { fd_name = nm'+                                 , fd_sig_ty = mkLHsSigType ty'+                                 , fd_co = noForeignExportCoercionYet+                                 , fd_fe = e } }++cvt_conv :: TH.Callconv -> CCallConv+cvt_conv TH.CCall      = CCallConv+cvt_conv TH.StdCall    = StdCallConv+cvt_conv TH.CApi       = CApiConv+cvt_conv TH.Prim       = PrimCallConv+cvt_conv TH.JavaScript = JavaScriptCallConv++------------------------------------------+--              Pragmas+------------------------------------------++cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl RdrName))+cvtPragmaD (InlineP nm inline rm phases)+  = do { nm' <- vNameL nm+       ; let dflt = dfltActivation inline+       ; let src TH.NoInline  = "{-# NOINLINE"+             src TH.Inline    = "{-# INLINE"+             src TH.Inlinable = "{-# INLINABLE"+       ; let ip   = InlinePragma { inl_src    = SourceText $ src inline+                                 , inl_inline = cvtInline inline+                                 , inl_rule   = cvtRuleMatch rm+                                 , inl_act    = cvtPhases phases dflt+                                 , inl_sat    = Nothing }+       ; returnJustL $ Hs.SigD $ InlineSig nm' ip }++cvtPragmaD (SpecialiseP nm ty inline phases)+  = do { nm' <- vNameL nm+       ; ty' <- cvtType ty+       ; let src TH.NoInline  = "{-# SPECIALISE NOINLINE"+             src TH.Inline    = "{-# SPECIALISE INLINE"+             src TH.Inlinable = "{-# SPECIALISE INLINE"+       ; let (inline', dflt,srcText) = case inline of+               Just inline1 -> (cvtInline inline1, dfltActivation inline1,+                                src inline1)+               Nothing      -> (EmptyInlineSpec,   AlwaysActive,+                                "{-# SPECIALISE")+       ; let ip = InlinePragma { inl_src    = SourceText srcText+                               , inl_inline = inline'+                               , inl_rule   = Hs.FunLike+                               , inl_act    = cvtPhases phases dflt+                               , inl_sat    = Nothing }+       ; returnJustL $ Hs.SigD $ SpecSig nm' [mkLHsSigType ty'] ip }++cvtPragmaD (SpecialiseInstP ty)+  = do { ty' <- cvtType ty+       ; returnJustL $ Hs.SigD $+         SpecInstSig (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }++cvtPragmaD (RuleP nm bndrs lhs rhs phases)+  = do { let nm' = mkFastString nm+       ; let act = cvtPhases phases AlwaysActive+       ; bndrs' <- mapM cvtRuleBndr bndrs+       ; lhs'   <- cvtl lhs+       ; rhs'   <- cvtl rhs+       ; returnJustL $ Hs.RuleD+            $ HsRules (SourceText "{-# RULES")+                      [noLoc $ HsRule (noLoc (SourceText nm,nm')) act bndrs'+                                                  lhs' placeHolderNames+                                                  rhs' placeHolderNames]+       }++cvtPragmaD (AnnP target exp)+  = do { exp' <- cvtl exp+       ; target' <- case target of+         ModuleAnnotation  -> return ModuleAnnProvenance+         TypeAnnotation n  -> do+           n' <- tconName n+           return (TypeAnnProvenance  (noLoc n'))+         ValueAnnotation n -> do+           n' <- vcName n+           return (ValueAnnProvenance (noLoc n'))+       ; returnJustL $ Hs.AnnD $ HsAnnotation (SourceText "{-# ANN") target'+                                               exp'+       }++cvtPragmaD (LineP line file)+  = do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1))+       ; return Nothing+       }+cvtPragmaD (CompleteP cls mty)+  = do { cls' <- noLoc <$> mapM cNameL cls+       ; mty'  <- traverse tconNameL mty+       ; returnJustL $ Hs.SigD+                   $ CompleteMatchSig NoSourceText cls' mty' }++dfltActivation :: TH.Inline -> Activation+dfltActivation TH.NoInline = NeverActive+dfltActivation _           = AlwaysActive++cvtInline :: TH.Inline -> Hs.InlineSpec+cvtInline TH.NoInline  = Hs.NoInline+cvtInline TH.Inline    = Hs.Inline+cvtInline TH.Inlinable = Hs.Inlinable++cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo+cvtRuleMatch TH.ConLike = Hs.ConLike+cvtRuleMatch TH.FunLike = Hs.FunLike++cvtPhases :: TH.Phases -> Activation -> Activation+cvtPhases AllPhases       dflt = dflt+cvtPhases (FromPhase i)   _    = ActiveAfter NoSourceText i+cvtPhases (BeforePhase i) _    = ActiveBefore NoSourceText i++cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr RdrName)+cvtRuleBndr (RuleVar n)+  = do { n' <- vNameL n+       ; return $ noLoc $ Hs.RuleBndr n' }+cvtRuleBndr (TypedRuleVar n ty)+  = do { n'  <- vNameL n+       ; ty' <- cvtType ty+       ; return $ noLoc $ Hs.RuleBndrSig n' $ mkLHsSigWcType ty' }++---------------------------------------------------+--              Declarations+---------------------------------------------------++cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds RdrName)+cvtLocalDecs doc ds+  | null ds+  = return EmptyLocalBinds+  | otherwise+  = do { ds' <- cvtDecs ds+       ; let (binds, prob_sigs) = partitionWith is_bind ds'+       ; let (sigs, bads) = partitionWith is_sig prob_sigs+       ; unless (null bads) (failWith (mkBadDecMsg doc bads))+       ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) }++cvtClause :: HsMatchContext RdrName+          -> TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))+cvtClause ctxt (Clause ps body wheres)+  = do  { ps' <- cvtPats ps+        ; pps <- mapM wrap_conpat ps'+        ; g'  <- cvtGuard body+        ; ds' <- cvtLocalDecs (text "a where clause") wheres+        ; returnL $ Hs.Match ctxt pps Nothing+                             (GRHSs g' (noLoc ds')) }+++-------------------------------------------------------------------+--              Expressions+-------------------------------------------------------------------++cvtl :: TH.Exp -> CvtM (LHsExpr RdrName)+cvtl e = wrapL (cvt e)+  where+    cvt (VarE s)        = do { s' <- vName s; return $ HsVar (noLoc s') }+    cvt (ConE s)        = do { s' <- cName s; return $ HsVar (noLoc s') }+    cvt (LitE l)+      | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }+      | otherwise       = do { l' <- cvtLit l;     return $ HsLit l' }+    cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y+                                   ; return $ HsApp (mkLHsPar x') (mkLHsPar y')}+    cvt (AppE x y)            = do { x' <- cvtl x; y' <- cvtl y+                                   ; return $ HsApp (mkLHsPar x') (mkLHsPar y')}+    cvt (AppTypeE e t) = do { e' <- cvtl e+                            ; t' <- cvtType t+                            ; tp <- wrap_apps t'+                            ; return $ HsAppType e' $ mkHsWildCardBndrs tp }+    cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e+                            ; return $ HsLam (mkMatchGroup FromSource+                                             [mkSimpleMatch LambdaExpr ps' e'])}+    cvt (LamCaseE ms)  = do { ms' <- mapM (cvtMatch LambdaExpr) ms+                            ; return $ HsLamCase (mkMatchGroup FromSource ms')+                            }+    cvt (TupE [e])     = do { e' <- cvtl e; return $ HsPar e' }+                                 -- Note [Dropping constructors]+                                 -- Singleton tuples treated like nothing (just parens)+    cvt (TupE es)      = do { es' <- mapM cvtl es+                            ; return $ ExplicitTuple (map (noLoc . Present) es')+                                                      Boxed }+    cvt (UnboxedTupE es)      = do { es' <- mapM cvtl es+                                   ; return $ ExplicitTuple+                                           (map (noLoc . Present) es') Unboxed }+    cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e+                                       ; unboxedSumChecks alt arity+                                       ; return $ ExplicitSum+                                             alt arity e' placeHolderType }+    cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;+                            ; return $ HsIf (Just noSyntaxExpr) x' y' z' }+    cvt (MultiIfE alts)+      | null alts      = failWith (text "Multi-way if-expression with no alternatives")+      | otherwise      = do { alts' <- mapM cvtpair alts+                            ; return $ HsMultiIf placeHolderType alts' }+    cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (text "a let expression") ds+                            ; e' <- cvtl e; return $ HsLet (noLoc ds') e' }+    cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms+                            ; return $ HsCase e' (mkMatchGroup FromSource ms') }+    cvt (DoE ss)       = cvtHsDo DoExpr ss+    cvt (CompE ss)     = cvtHsDo ListComp ss+    cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr Nothing dd' }+    cvt (ListE xs)+      | Just s <- allCharLs xs       = do { l' <- cvtLit (StringL s); return (HsLit l') }+             -- Note [Converting strings]+      | otherwise       = do { xs' <- mapM cvtl xs+                             ; return $ ExplicitList placeHolderType Nothing xs'+                             }++    -- Infix expressions+    cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y+                                          ; wrapParL HsPar $+                                            OpApp (mkLHsPar x') s' undefined (mkLHsPar y') }+                                            -- Parenthesise both arguments and result,+                                            -- to ensure this operator application does+                                            -- does not get re-associated+                            -- See Note [Operator association]+    cvt (InfixE Nothing  s (Just y)) = do { s' <- cvtl s; y' <- cvtl y+                                          ; wrapParL HsPar $ SectionR s' y' }+                                            -- See Note [Sections in HsSyn] in HsExpr+    cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s+                                          ; wrapParL HsPar $ SectionL x' s' }++    cvt (InfixE Nothing  s Nothing ) = do { s' <- cvtl s; return $ HsPar s' }+                                       -- Can I indicate this is an infix thing?+                                       -- Note [Dropping constructors]++    cvt (UInfixE x s y)  = do { x' <- cvtl x+                              ; let x'' = case x' of+                                            L _ (OpApp {}) -> x'+                                            _ -> mkLHsPar x'+                              ; cvtOpApp x'' s y } --  Note [Converting UInfix]++    cvt (ParensE e)      = do { e' <- cvtl e; return $ HsPar e' }+    cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t+                              ; return $ ExprWithTySig e' (mkLHsSigWcType t') }+    cvt (RecConE c flds) = do { c' <- cNameL c+                              ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds+                              ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }+    cvt (RecUpdE e flds) = do { e' <- cvtl e+                              ; flds'+                                  <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc))+                                           flds+                              ; return $ mkRdrRecordUpd e' flds' }+    cvt (StaticE e)      = fmap (HsStatic placeHolderNames) $ cvtl e+    cvt (UnboundVarE s)  = do { s' <- vName s; return $ HsVar (noLoc s') }++{- Note [Dropping constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we drop constructors from the input (for instance, when we encounter @TupE [e]@)+we must insert parentheses around the argument. Otherwise, @UInfix@ constructors in @e@+could meet @UInfix@ constructors containing the @TupE [e]@. For example:++  UInfixE x * (TupE [UInfixE y + z])++If we drop the singleton tuple but don't insert parentheses, the @UInfixE@s would meet+and the above expression would be reassociated to++  OpApp (OpApp x * y) + z++which we don't want.+-}++cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp) -> CvtM (LHsRecField' t (LHsExpr RdrName))+cvtFld f (v,e)+  = do  { v' <- vNameL v; e' <- cvtl e+        ; return (noLoc $ HsRecField { hsRecFieldLbl = fmap f v'+                                     , hsRecFieldArg = e'+                                     , hsRecPun      = False}) }++cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)+cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }+cvtDD (FromThenR x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }+cvtDD (FromToR x y)       = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }+cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }++{- Note [Operator assocation]+We must be quite careful about adding parens:+  * Infix (UInfix ...) op arg      Needs parens round the first arg+  * Infix (Infix ...) op arg       Needs parens round the first arg+  * UInfix (UInfix ...) op arg     No parens for first arg+  * UInfix (Infix ...) op arg      Needs parens round first arg+++Note [Converting UInfix]+~~~~~~~~~~~~~~~~~~~~~~~~+When converting @UInfixE@, @UInfixP@, and @UInfixT@ values, we want to readjust+the trees to reflect the fixities of the underlying operators:++  UInfixE x * (UInfixE y + z) ---> (x * y) + z++This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and+@mkHsOpTyRn@ in RnTypes), which expects that the input will be completely+right-biased for types and left-biased for everything else. So we left-bias the+trees of @UInfixP@ and @UInfixE@ and use HsAppsTy for UInfixT.++Sample input:++  UInfixE+   (UInfixE x op1 y)+   op2+   (UInfixE z op3 w)++Sample output:++  OpApp+    (OpApp+      (OpApp x op1 y)+      op2+      z)+    op3+    w++The functions @cvtOpApp@, @cvtOpAppP@, and @cvtOpAppT@ are responsible for this+biasing.+-}++{- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.+The produced tree of infix expressions will be left-biased, provided @x@ is.++We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis+is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that+this holds for both branches (of @cvtOpApp@), provided we assume it holds for+the recursive calls to @cvtOpApp@.++When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased+since we have already run @cvtl@ on it.+-}+cvtOpApp :: LHsExpr RdrName -> TH.Exp -> TH.Exp -> CvtM (HsExpr RdrName)+cvtOpApp x op1 (UInfixE y op2 z)+  = do { l <- wrapL $ cvtOpApp x op1 y+       ; cvtOpApp l op2 z }+cvtOpApp x op y+  = do { op' <- cvtl op+       ; y' <- cvtl y+       ; return (OpApp x op' undefined y') }++-------------------------------------+--      Do notation and statements+-------------------------------------++cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName)+cvtHsDo do_or_lc stmts+  | null stmts = failWith (text "Empty stmt list in do-block")+  | otherwise+  = do  { stmts' <- cvtStmts stmts+        ; let Just (stmts'', last') = snocView stmts'++        ; last'' <- case last' of+                    L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body))+                    _ -> failWith (bad_last last')++        ; return $ HsDo do_or_lc (noLoc (stmts'' ++ [last''])) placeHolderType }+  where+    bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon+                         , nest 2 $ Outputable.ppr stmt+                         , text "(It should be an expression.)" ]++cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName (LHsExpr RdrName)]+cvtStmts = mapM cvtStmt++cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName (LHsExpr RdrName))+cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkBodyStmt e' }+cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }+cvtStmt (TH.LetS ds)   = do { ds' <- cvtLocalDecs (text "a let binding") ds+                            ; returnL $ LetStmt (noLoc ds') }+cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noExpr noSyntaxExpr placeHolderType }+                       where+                         cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) }++cvtMatch :: HsMatchContext RdrName+         -> TH.Match -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))+cvtMatch ctxt (TH.Match p body decs)+  = do  { p' <- cvtPat p+        ; lp <- case ctxt of+            CaseAlt -> return p'+            _       -> wrap_conpat p'+        ; g' <- cvtGuard body+        ; decs' <- cvtLocalDecs (text "a where clause") decs+        ; returnL $ Hs.Match ctxt [lp] Nothing+                             (GRHSs g' (noLoc decs')) }++cvtGuard :: TH.Body -> CvtM [LGRHS RdrName (LHsExpr RdrName)]+cvtGuard (GuardedB pairs) = mapM cvtpair pairs+cvtGuard (NormalB e)      = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }++cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName (LHsExpr RdrName))+cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs+                              ; g' <- returnL $ mkBodyStmt ge'+                              ; returnL $ GRHS [g'] rhs' }+cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs+                              ; returnL $ GRHS gs' rhs' }++cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)+cvtOverLit (IntegerL i)+  = do { force i; return $ mkHsIntegral NoSourceText i placeHolderType}+cvtOverLit (RationalL r)+  = do { force r; return $ mkHsFractional (cvtFractionalLit r) placeHolderType}+cvtOverLit (StringL s)+  = do { let { s' = mkFastString s }+       ; force s'+       ; return $ mkHsIsString (quotedSourceText s) s' placeHolderType+       }+cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"+-- An Integer is like an (overloaded) '3' in a Haskell source program+-- Similarly 3.5 for fractionals++{- Note [Converting strings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to+a string literal for "xy".  Of course, we might hope to get+(LitE (StringL "xy")), but not always, and allCharLs fails quickly+if it isn't a literal string+-}++allCharLs :: [TH.Exp] -> Maybe String+-- Note [Converting strings]+-- NB: only fire up this setup for a non-empty list, else+--     there's a danger of returning "" for [] :: [Int]!+allCharLs xs+  = case xs of+      LitE (CharL c) : ys -> go [c] ys+      _                   -> Nothing+  where+    go cs []                    = Just (reverse cs)+    go cs (LitE (CharL c) : ys) = go (c:cs) ys+    go _  _                     = Nothing++cvtLit :: Lit -> CvtM HsLit+cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim NoSourceText i }+cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim NoSourceText w }+cvtLit (FloatPrimL f)  = do { force f; return $ HsFloatPrim (cvtFractionalLit f) }+cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (cvtFractionalLit f) }+cvtLit (CharL c)       = do { force c; return $ HsChar NoSourceText c }+cvtLit (CharPrimL c)   = do { force c; return $ HsCharPrim NoSourceText c }+cvtLit (StringL s)     = do { let { s' = mkFastString s }+                            ; force s'+                            ; return $ HsString (quotedSourceText s) s' }+cvtLit (StringPrimL s) = do { let { s' = BS.pack s }+                            ; force s'+                            ; return $ HsStringPrim NoSourceText s' }+cvtLit _ = panic "Convert.cvtLit: Unexpected literal"+        -- cvtLit should not be called on IntegerL, RationalL+        -- That precondition is established right here in+        -- Convert.hs, hence panic++quotedSourceText :: String -> SourceText+quotedSourceText s = SourceText $ "\"" ++ s ++ "\""++cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]+cvtPats pats = mapM cvtPat pats++cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)+cvtPat pat = wrapL (cvtp pat)++cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)+cvtp (TH.LitP l)+  | overloadedLit l    = do { l' <- cvtOverLit l+                            ; return (mkNPat (noLoc l') Nothing) }+                                  -- Not right for negative patterns;+                                  -- need to think about that!+  | otherwise          = do { l' <- cvtLit l; return $ Hs.LitPat l' }+cvtp (TH.VarP s)       = do { s' <- vName s; return $ Hs.VarPat (noLoc s') }+cvtp (TupP [p])        = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors]+cvtp (TupP ps)         = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed   [] }+cvtp (UnboxedTupP ps)  = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed [] }+cvtp (UnboxedSumP p alt arity)+                       = do { p' <- cvtPat p+                            ; unboxedSumChecks alt arity+                            ; return $ SumPat p' alt arity placeHolderType }+cvtp (ConP s ps)       = do { s' <- cNameL s; ps' <- cvtPats ps+                            ; pps <- mapM wrap_conpat ps'+                            ; return $ ConPatIn s' (PrefixCon pps) }+cvtp (InfixP p1 s p2)  = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2+                            ; wrapParL ParPat $+                              ConPatIn s' (InfixCon (mkParPat p1') (mkParPat p2')) }+                            -- See Note [Operator association]+cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]+cvtp (ParensP p)       = do { p' <- cvtPat p;+                            ; case p' of  -- may be wrapped ConPatIn+                                (L _ (ParPat {})) -> return $ unLoc p'+                                _                 -> return $ ParPat p' }+cvtp (TildeP p)        = do { p' <- cvtPat p; return $ LazyPat p' }+cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat p' }+cvtp (TH.AsP s p)      = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }+cvtp TH.WildP          = return $ WildPat placeHolderType+cvtp (RecP c fs)       = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs+                            ; return $ ConPatIn c'+                                     $ Hs.RecCon (HsRecFields fs' Nothing) }+cvtp (ListP ps)        = do { ps' <- cvtPats ps+                            ; return $ ListPat ps' placeHolderType Nothing }+cvtp (SigP p t)        = do { p' <- cvtPat p; t' <- cvtType t+                            ; return $ SigPatIn p' (mkLHsSigWcType t') }+cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p+                            ; return $ ViewPat e' p' placeHolderType }++cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField RdrName (LPat RdrName))+cvtPatFld (s,p)+  = do  { L ls s' <- vNameL s; p' <- cvtPat p+        ; return (noLoc $ HsRecField { hsRecFieldLbl+                                         = L ls $ mkFieldOcc (L ls s')+                                     , hsRecFieldArg = p'+                                     , hsRecPun      = False}) }++wrap_conpat :: Hs.LPat RdrName -> CvtM (Hs.LPat RdrName)+wrap_conpat p@(L _ (ConPatIn _ (InfixCon{})))   = returnL $ ParPat p+wrap_conpat p@(L _ (ConPatIn _ (PrefixCon []))) = return p+wrap_conpat p@(L _ (ConPatIn _ (PrefixCon _)))  = returnL $ ParPat p+wrap_conpat p                                   = return p++{- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.+The produced tree of infix patterns will be left-biased, provided @x@ is.++See the @cvtOpApp@ documentation for how this function works.+-}+cvtOpAppP :: Hs.LPat RdrName -> TH.Name -> TH.Pat -> CvtM (Hs.Pat RdrName)+cvtOpAppP x op1 (UInfixP y op2 z)+  = do { l <- wrapL $ cvtOpAppP x op1 y+       ; cvtOpAppP l op2 z }+cvtOpAppP x op y+  = do { op' <- cNameL op+       ; y' <- cvtPat y+       ; return (ConPatIn op' (InfixCon x y')) }++-----------------------------------------------------------+--      Types and type variables++cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars RdrName)+cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }++cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)+cvt_tv (TH.PlainTV nm)+  = do { nm' <- tNameL nm+       ; returnL $ UserTyVar nm' }+cvt_tv (TH.KindedTV nm ki)+  = do { nm' <- tNameL nm+       ; ki' <- cvtKind ki+       ; returnL $ KindedTyVar nm' ki' }++cvtRole :: TH.Role -> Maybe Coercion.Role+cvtRole TH.NominalR          = Just Coercion.Nominal+cvtRole TH.RepresentationalR = Just Coercion.Representational+cvtRole TH.PhantomR          = Just Coercion.Phantom+cvtRole TH.InferR            = Nothing++cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)+cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }++cvtPred :: TH.Pred -> CvtM (LHsType RdrName)+cvtPred = cvtType++cvtDerivClause :: TH.DerivClause+               -> CvtM (LHsDerivingClause RdrName)+cvtDerivClause (TH.DerivClause ds ctxt)+  = do { ctxt'@(L loc _) <- fmap (map mkLHsSigType) <$> cvtContext ctxt+       ; let ds' = fmap (L loc . cvtDerivStrategy) ds+       ; returnL $ HsDerivingClause ds' ctxt' }++cvtDerivStrategy :: TH.DerivStrategy -> Hs.DerivStrategy+cvtDerivStrategy TH.StockStrategy    = Hs.StockStrategy+cvtDerivStrategy TH.AnyclassStrategy = Hs.AnyclassStrategy+cvtDerivStrategy TH.NewtypeStrategy  = Hs.NewtypeStrategy++cvtType :: TH.Type -> CvtM (LHsType RdrName)+cvtType = cvtTypeKind "type"++cvtTypeKind :: String -> TH.Type -> CvtM (LHsType RdrName)+cvtTypeKind ty_str ty+  = do { (head_ty, tys') <- split_ty_app ty+       ; case head_ty of+           TupleT n+             | length tys' == n         -- Saturated+             -> if n==1 then return (head tys') -- Singleton tuples treated+                                                -- like nothing (ie just parens)+                        else returnL (HsTupleTy HsBoxedOrConstraintTuple tys')+             | n == 1+             -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))+             | otherwise+             -> mk_apps (HsTyVar NotPromoted+                               (noLoc (getRdrName (tupleTyCon Boxed n)))) tys'+           UnboxedTupleT n+             | length tys' == n         -- Saturated+             -> returnL (HsTupleTy HsUnboxedTuple tys')+             | otherwise+             -> mk_apps (HsTyVar NotPromoted+                             (noLoc (getRdrName (tupleTyCon Unboxed n)))) tys'+           UnboxedSumT n+             | n < 2+            -> failWith $+                   vcat [ text "Illegal sum arity:" <+> text (show n)+                        , nest 2 $+                            text "Sums must have an arity of at least 2" ]+             | length tys' == n -- Saturated+             -> returnL (HsSumTy tys')+             | otherwise+             -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName (sumTyCon n))))+                        tys'+           ArrowT+             | [x',y'] <- tys' -> returnL (HsFunTy x' y')+             | otherwise ->+                  mk_apps (HsTyVar NotPromoted (noLoc (getRdrName funTyCon)))+                          tys'+           ListT+             | [x']    <- tys' -> returnL (HsListTy x')+             | otherwise ->+                  mk_apps (HsTyVar NotPromoted (noLoc (getRdrName listTyCon)))+                           tys'+           VarT nm -> do { nm' <- tNameL nm+                         ; mk_apps (HsTyVar NotPromoted nm') tys' }+           ConT nm -> do { nm' <- tconName nm+                         ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' }++           ForallT tvs cxt ty+             | null tys'+             -> do { tvs' <- cvtTvs tvs+                   ; cxt' <- cvtContext cxt+                   ; ty'  <- cvtType ty+                   ; loc <- getL+                   ; let hs_ty  = mkHsForAllTy tvs loc tvs' rho_ty+                         rho_ty = mkHsQualTy cxt loc cxt' ty'++                   ; return hs_ty }++           SigT ty ki+             -> do { ty' <- cvtType ty+                   ; ki' <- cvtKind ki+                   ; mk_apps (HsKindSig ty' ki') tys'+                   }++           LitT lit+             -> returnL (HsTyLit (cvtTyLit lit))++           WildCardT+             -> mk_apps mkAnonWildCardTy tys'++           InfixT t1 s t2+             -> do { s'  <- tconName s+                   ; t1' <- cvtType t1+                   ; t2' <- cvtType t2+                   ; mk_apps (HsTyVar NotPromoted (noLoc s')) [t1', t2']+                   }++           UInfixT t1 s t2+             -> do { t1' <- cvtType t1+                   ; t2' <- cvtType t2+                   ; s'  <- tconName s+                   ; return $ cvtOpAppT t1' s' t2'+                   } -- Note [Converting UInfix]++           ParensT t+             -> do { t' <- cvtType t+                   ; returnL $ HsParTy t'+                   }++           PromotedT nm -> do { nm' <- cName nm+                              ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' }+                 -- Promoted data constructor; hence cName++           PromotedTupleT n+             | n == 1+             -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))+             | m == n   -- Saturated+             -> do  { let kis = replicate m placeHolderKind+                    ; returnL (HsExplicitTupleTy kis tys')+                    }+             where+               m = length tys'++           PromotedNilT+             -> returnL (HsExplicitListTy Promoted placeHolderKind [])++           PromotedConsT  -- See Note [Representing concrete syntax in types]+                          -- in Language.Haskell.TH.Syntax+             | [ty1, L _ (HsExplicitListTy ip _ tys2)] <- tys'+             -> returnL (HsExplicitListTy ip placeHolderKind (ty1:tys2))+             | otherwise+             -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName consDataCon)))+                        tys'++           StarT+             -> returnL (HsTyVar NotPromoted (noLoc+                                              (getRdrName liftedTypeKindTyCon)))++           ConstraintT+             -> returnL (HsTyVar NotPromoted+                              (noLoc (getRdrName constraintKindTyCon)))++           EqualityT+             | [x',y'] <- tys' -> returnL (HsEqTy x' y')+             | otherwise ->+                   mk_apps (HsTyVar NotPromoted+                            (noLoc (getRdrName eqPrimTyCon))) tys'++           _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))+    }++-- | Constructs an application of a type to arguments passed in a list.+mk_apps :: HsType RdrName -> [LHsType RdrName] -> CvtM (LHsType RdrName)+mk_apps head_ty []       = returnL head_ty+mk_apps head_ty (ty:tys) =+  do { head_ty' <- returnL head_ty+     ; p_ty      <- add_parens ty+     ; mk_apps (HsAppTy head_ty' p_ty) tys }+  where+    add_parens t@(L _ HsAppTy{}) = returnL (HsParTy t)+    add_parens t                 = return t++wrap_apps  :: LHsType RdrName -> CvtM (LHsType RdrName)+wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy t)+wrap_apps t                  = return t++-- | Constructs an arrow type with a specified return type+mk_arr_apps :: [LHsType RdrName] -> HsType RdrName -> CvtM (LHsType RdrName)+mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL+    where go :: LHsType RdrName -> HsType RdrName -> CvtM (HsType RdrName)+          go arg ret_ty = do { ret_ty_l <- returnL ret_ty+                             ; return (HsFunTy arg ret_ty_l) }++split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])+split_ty_app ty = go ty []+  where+    go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }+    go f as           = return (f,as)++cvtTyLit :: TH.TyLit -> HsTyLit+cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i+cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s)++{- | @cvtOpAppT x op y@ takes converted arguments and flattens any HsAppsTy+   structure in them.+-}+cvtOpAppT :: LHsType RdrName -> RdrName -> LHsType RdrName -> LHsType RdrName+cvtOpAppT t1@(L loc1 _) op t2@(L loc2 _)+  = L (combineSrcSpans loc1 loc2) $+    HsAppsTy (t1' ++ [noLoc $ HsAppInfix (noLoc op)] ++ t2')+  where+    t1' | L _ (HsAppsTy t1s) <- t1+        = t1s+        | otherwise+        = [noLoc $ HsAppPrefix t1]++    t2' | L _ (HsAppsTy t2s) <- t2+        = t2s+        | otherwise+        = [noLoc $ HsAppPrefix t2]++cvtKind :: TH.Kind -> CvtM (LHsKind RdrName)+cvtKind = cvtTypeKind "kind"++-- | Convert Maybe Kind to a type family result signature. Used with data+-- families where naming of the result is not possible (thus only kind or no+-- signature is possible).+cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind+                              -> CvtM (LFamilyResultSig RdrName)+cvtMaybeKindToFamilyResultSig Nothing   = returnL Hs.NoSig+cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki+                                             ; returnL (Hs.KindSig ki') }++-- | Convert type family result signature. Used with both open and closed type+-- families.+cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig RdrName)+cvtFamilyResultSig TH.NoSig           = returnL Hs.NoSig+cvtFamilyResultSig (TH.KindSig ki)    = do { ki' <- cvtKind ki+                                           ; returnL (Hs.KindSig ki') }+cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr+                                           ; returnL (Hs.TyVarSig tv) }++-- | Convert injectivity annotation of a type family.+cvtInjectivityAnnotation :: TH.InjectivityAnn+                         -> CvtM (Hs.LInjectivityAnn RdrName)+cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS)+  = do { annLHS' <- tNameL annLHS+       ; annRHS' <- mapM tNameL annRHS+       ; returnL (Hs.InjectivityAnn annLHS' annRHS') }++cvtPatSynSigTy :: TH.Type -> CvtM (LHsType RdrName)+-- pattern synonym types are of peculiar shapes, which is why we treat+-- them separately from regular types;+-- see Note [Pattern synonym type signatures and Template Haskell]+cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))+  | null exis, null provs = cvtType (ForallT univs reqs ty)+  | null univs, null reqs = do { l   <- getL+                               ; ty' <- cvtType (ForallT exis provs ty)+                               ; return $ L l (HsQualTy { hst_ctxt = L l []+                                                        , hst_body = ty' }) }+  | null reqs             = do { l      <- getL+                               ; univs' <- hsQTvExplicit <$> cvtTvs univs+                               ; ty'    <- cvtType (ForallT exis provs ty)+                               ; let forTy = HsForAllTy { hst_bndrs = univs'+                                                        , hst_body = L l cxtTy }+                                     cxtTy = HsQualTy { hst_ctxt = L l []+                                                      , hst_body = ty' }+                               ; return $ L l forTy }+  | otherwise             = cvtType (ForallT univs reqs (ForallT exis provs ty))+cvtPatSynSigTy ty         = cvtType ty++-----------------------------------------------------------+cvtFixity :: TH.Fixity -> Hs.Fixity+cvtFixity (TH.Fixity prec dir) = Hs.Fixity NoSourceText prec (cvt_dir dir)+   where+     cvt_dir TH.InfixL = Hs.InfixL+     cvt_dir TH.InfixR = Hs.InfixR+     cvt_dir TH.InfixN = Hs.InfixN++-----------------------------------------------------------+++-----------------------------------------------------------+-- some useful things++overloadedLit :: Lit -> Bool+-- True for literals that Haskell treats as overloaded+overloadedLit (IntegerL  _) = True+overloadedLit (RationalL _) = True+overloadedLit _             = False++cvtFractionalLit :: Rational -> FractionalLit+cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = r }++-- Checks that are performed when converting unboxed sum expressions and+-- patterns alike.+unboxedSumChecks :: TH.SumAlt -> TH.SumArity -> CvtM ()+unboxedSumChecks alt arity+    | alt > arity+    = failWith $ text "Sum alternative"    <+> text (show alt)+             <+> text "exceeds its arity," <+> text (show arity)+    | alt <= 0+    = failWith $ vcat [ text "Illegal sum alternative:" <+> text (show alt)+                      , nest 2 $ text "Sum alternatives must start from 1" ]+    | arity < 2+    = failWith $ vcat [ text "Illegal sum arity:" <+> text (show arity)+                      , nest 2 $ text "Sums must have an arity of at least 2" ]+    | otherwise+    = return ()++-- | If passed an empty list of 'TH.TyVarBndr's, this simply returns the+-- third argument (an 'LHsType'). Otherwise, return an 'HsForAllTy'+-- using the provided 'LHsQTyVars' and 'LHsType'.+mkHsForAllTy :: [TH.TyVarBndr]+             -- ^ The original Template Haskell type variable binders+             -> SrcSpan+             -- ^ The location of the returned 'LHsType' if it needs an+             --   explicit forall+             -> LHsQTyVars name+             -- ^ The converted type variable binders+             -> LHsType name+             -- ^ The converted rho type+             -> LHsType name+             -- ^ The complete type, quantified with a forall if necessary+mkHsForAllTy tvs loc tvs' rho_ty+  | null tvs  = rho_ty+  | otherwise = L loc $ HsForAllTy { hst_bndrs = hsQTvExplicit tvs'+                                   , hst_body = rho_ty }++-- | If passed an empty 'TH.Cxt', this simply returns the third argument+-- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided+-- 'LHsContext' and 'LHsType'.++-- It's important that we don't build an HsQualTy if the context is empty,+-- as the pretty-printer for HsType _always_ prints contexts, even if+-- they're empty. See Trac #13183.+mkHsQualTy :: TH.Cxt+           -- ^ The original Template Haskell context+           -> SrcSpan+           -- ^ The location of the returned 'LHsType' if it needs an+           --   explicit context+           -> LHsContext name+           -- ^ The converted context+           -> LHsType name+           -- ^ The converted tau type+           -> LHsType name+           -- ^ The complete type, qualified with a context if necessary+mkHsQualTy ctxt loc ctxt' ty+  | null ctxt = ty+  | otherwise = L loc $ HsQualTy { hst_ctxt = ctxt', hst_body = ty }++--------------------------------------------------------------------+--      Turning Name back into RdrName+--------------------------------------------------------------------++-- variable names+vNameL, cNameL, vcNameL, tNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)+vName,  cName,  vcName,  tName,  tconName  :: TH.Name -> CvtM RdrName++-- Variable names+vNameL n = wrapL (vName n)+vName n = cvtName OccName.varName n++-- Constructor function names; this is Haskell source, hence srcDataName+cNameL n = wrapL (cName n)+cName n = cvtName OccName.dataName n++-- Variable *or* constructor names; check by looking at the first char+vcNameL n = wrapL (vcName n)+vcName n = if isVarName n then vName n else cName n++-- Type variable names+tNameL n = wrapL (tName n)+tName n = cvtName OccName.tvName n++-- Type Constructor names+tconNameL n = wrapL (tconName n)+tconName n = cvtName OccName.tcClsName n++cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName+cvtName ctxt_ns (TH.Name occ flavour)+  | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)+  | otherwise+  = do { loc <- getL+       ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour+       ; force rdr_name+       ; return rdr_name }+  where+    occ_str = TH.occString occ++okOcc :: OccName.NameSpace -> String -> Bool+okOcc ns str+  | OccName.isVarNameSpace ns     = okVarOcc str+  | OccName.isDataConNameSpace ns = okConOcc str+  | otherwise                     = okTcOcc  str++-- Determine the name space of a name in a type+--+isVarName :: TH.Name -> Bool+isVarName (TH.Name occ _)+  = case TH.occString occ of+      ""    -> False+      (c:_) -> startsVarId c || startsVarSym c++badOcc :: OccName.NameSpace -> String -> SDoc+badOcc ctxt_ns occ+  = text "Illegal" <+> pprNameSpace ctxt_ns+        <+> text "name:" <+> quotes (text occ)++thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName+-- This turns a TH Name into a RdrName; used for both binders and occurrences+-- See Note [Binders in Template Haskell]+-- The passed-in name space tells what the context is expecting;+--      use it unless the TH name knows what name-space it comes+--      from, in which case use the latter+--+-- We pass in a SrcSpan (gotten from the monad) because this function+-- is used for *binders* and if we make an Exact Name we want it+-- to have a binding site inside it.  (cf Trac #5434)+--+-- ToDo: we may generate silly RdrNames, by passing a name space+--       that doesn't match the string, like VarName ":+",+--       which will give confusing error messages later+--+-- The strict applications ensure that any buried exceptions get forced+thRdrName loc ctxt_ns th_occ th_name+  = case th_name of+     TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod+     TH.NameQ mod  -> (mkRdrQual  $! mk_mod mod) $! occ+     TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq uniq) $! occ) loc)+     TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq uniq) $! occ) loc)+     TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name+              | otherwise                           -> mkRdrUnqual $! occ+              -- We check for built-in syntax here, because the TH+              -- user might have written a (NameS "(,,)"), for example+  where+    occ :: OccName.OccName+    occ = mk_occ ctxt_ns th_occ++thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName+thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)++thRdrNameGuesses :: TH.Name -> [RdrName]+thRdrNameGuesses (TH.Name occ flavour)+  -- This special case for NameG ensures that we don't generate duplicates in the output list+  | TH.NameG th_ns pkg mod <- flavour = [ thOrigRdrName occ_str th_ns pkg mod]+  | otherwise                         = [ thRdrName noSrcSpan gns occ_str flavour+                                        | gns <- guessed_nss]+  where+    -- guessed_ns are the name spaces guessed from looking at the TH name+    guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName,  OccName.dataName]+                | otherwise                       = [OccName.varName, OccName.tvName]+    occ_str = TH.occString occ++-- The packing and unpacking is rather turgid :-(+mk_occ :: OccName.NameSpace -> String -> OccName.OccName+mk_occ ns occ = OccName.mkOccName ns occ++mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace+mk_ghc_ns TH.DataName  = OccName.dataName+mk_ghc_ns TH.TcClsName = OccName.tcClsName+mk_ghc_ns TH.VarName   = OccName.varName++mk_mod :: TH.ModName -> ModuleName+mk_mod mod = mkModuleName (TH.modString mod)++mk_pkg :: TH.PkgName -> UnitId+mk_pkg pkg = stringToUnitId (TH.pkgString pkg)++mk_uniq :: Int -> Unique+mk_uniq u = mkUniqueGrimily u++{-+Note [Binders in Template Haskell]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this TH term construction:+  do { x1 <- TH.newName "x"   -- newName :: String -> Q TH.Name+     ; x2 <- TH.newName "x"   -- Builds a NameU+     ; x3 <- TH.newName "x"++     ; let x = mkName "x"     -- mkName :: String -> TH.Name+                              -- Builds a NameS++     ; return (LamE (..pattern [x1,x2]..) $+               LamE (VarPat x3) $+               ..tuple (x1,x2,x3,x)) }++It represents the term   \[x1,x2]. \x3. (x1,x2,x3,x)++a) We don't want to complain about "x" being bound twice in+   the pattern [x1,x2]+b) We don't want x3 to shadow the x1,x2+c) We *do* want 'x' (dynamically bound with mkName) to bind+   to the innermost binding of "x", namely x3.+d) When pretty printing, we want to print a unique with x1,x2+   etc, else they'll all print as "x" which isn't very helpful++When we convert all this to HsSyn, the TH.Names are converted with+thRdrName.  To achieve (b) we want the binders to be Exact RdrNames.+Achieving (a) is a bit awkward, because+   - We must check for duplicate and shadowed names on Names,+     not RdrNames, *after* renaming.+     See Note [Collect binders only after renaming] in HsUtils++   - But to achieve (a) we must distinguish between the Exact+     RdrNames arising from TH and the Unqual RdrNames that would+     come from a user writing \[x,x] -> blah++So in Convert.thRdrName we translate+   TH Name                          RdrName+   --------------------------------------------------------+   NameU (arising from newName) --> Exact (Name{ System })+   NameS (arising from mkName)  --> Unqual++Notice that the NameUs generate *System* Names.  Then, when+figuring out shadowing and duplicates, we can filter out+System Names.++This use of System Names fits with other uses of System Names, eg for+temporary variables "a". Since there are lots of things called "a" we+usually want to print the name with the unique, and that is indeed+the way System Names are printed.++There's a small complication of course; see Note [Looking up Exact+RdrNames] in RnEnv.+-}++{-+Note [Pattern synonym type signatures and Template Haskell]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++In general, the type signature of a pattern synonym++  pattern P x1 x2 .. xn = <some-pattern>++is of the form++   forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t++with the following parts:++   1) the (possibly empty lists of) universally quantified type+      variables `univs` and required constraints `reqs` on them.+   2) the (possibly empty lists of) existentially quantified type+      variables `exis` and the provided constraints `provs` on them.+   3) the types `t1`, `t2`, .., `tn` of the pattern synonym's arguments x1,+      x2, .., xn, respectively+   4) the type `t` of <some-pattern>, mentioning only universals from `univs`.++Due to the two forall quantifiers and constraint contexts (either of+which might be empty), pattern synonym type signatures are treated+specially in `deSugar/DsMeta.hs`, `hsSyn/Convert.hs`, and+`typecheck/TcSplice.hs`:++   (a) When desugaring a pattern synonym from HsSyn to TH.Dec in+       `deSugar/DsMeta.hs`, we represent its *full* type signature in TH, i.e.:++           ForallT univs reqs (ForallT exis provs ty)+              (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)++   (b) When converting pattern synonyms from TH.Dec to HsSyn in+       `hsSyn/Convert.hs`, we convert their TH type signatures back to an+       appropriate Haskell pattern synonym type of the form++         forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t++       where initial empty `univs` type variables or an empty `reqs`+       constraint context are represented *explicitly* as `() =>`.++   (c) When reifying a pattern synonym in `typecheck/TcSplice.hs`, we always+       return its *full* type, i.e.:++           ForallT univs reqs (ForallT exis provs ty)+              (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)++The key point is to always represent a pattern synonym's *full* type+in cases (a) and (c) to make it clear which of the two forall+quantifiers and/or constraint contexts are specified, and which are+not. See GHC's user's guide on pattern synonyms for more information+about pattern synonym type signatures.++-}
+ hsSyn/HsBinds.hs view
@@ -0,0 +1,1193 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[HsBinds]{Abstract syntax: top-level bindings and signatures}++Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.+-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]+                                      -- in module PlaceHolder+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE BangPatterns #-}++module HsBinds where++import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,+                               MatchGroup, pprFunBind,+                               GRHSs, pprPatBind )+import {-# SOURCE #-} HsPat  ( LPat )++import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId )+import HsTypes+import PprCore ()+import CoreSyn+import TcEvidence+import Type+import Name+import NameSet+import BasicTypes+import Outputable+import SrcLoc+import Var+import Bag+import FastString+import BooleanFormula (LBooleanFormula)+import DynFlags++import Data.Data hiding ( Fixity )+import Data.List hiding ( foldr )+import Data.Ord+import Data.Foldable ( Foldable(..) )++{-+************************************************************************+*                                                                      *+\subsection{Bindings: @BindGroup@}+*                                                                      *+************************************************************************++Global bindings (where clauses)+-}++-- During renaming, we need bindings where the left-hand sides+-- have been renamed but the the right-hand sides have not.+-- the ...LR datatypes are parametrized by two id types,+-- one for the left and one for the right.+-- Other than during renaming, these will be the same.++-- | Haskell Local Bindings+type HsLocalBinds id = HsLocalBindsLR id id++-- | Located Haskell local bindings+type LHsLocalBinds id = Located (HsLocalBinds id)++-- | Haskell Local Bindings with separate Left and Right identifier types+--+-- Bindings in a 'let' expression+-- or a 'where' clause+data HsLocalBindsLR idL idR+  = HsValBinds (HsValBindsLR idL idR)+      -- ^ Haskell Value Bindings++         -- There should be no pattern synonyms in the HsValBindsLR+         -- These are *local* (not top level) bindings+         -- The parser accepts them, however, leaving the the+         -- renamer to report them++  | HsIPBinds  (HsIPBinds idR)+      -- ^ Haskell Implicit Parameter Bindings++  | EmptyLocalBinds+      -- ^ Empty Local Bindings++type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR)++deriving instance (DataId idL, DataId idR)+  => Data (HsLocalBindsLR idL idR)++-- | Haskell Value Bindings+type HsValBinds id = HsValBindsLR id id++-- | Haskell Value bindings with separate Left and Right identifier types+-- (not implicit parameters)+-- Used for both top level and nested bindings+-- May contain pattern synonym bindings+data HsValBindsLR idL idR+  = -- | Value Bindings In+    --+    -- Before renaming RHS; idR is always RdrName+    -- Not dependency analysed+    -- Recursive by default+    ValBindsIn+        (LHsBindsLR idL idR) [LSig idR]++    -- | Value Bindings Out+    --+    -- After renaming RHS; idR can be Name or Id Dependency analysed,+    -- later bindings in the list may depend on earlier ones.+  | ValBindsOut+        [(RecFlag, LHsBinds idL)]+        [LSig Name]++deriving instance (DataId idL, DataId idR)+  => Data (HsValBindsLR idL idR)++-- | Located Haskell Binding+type LHsBind  id = LHsBindLR  id id++-- | Located Haskell Bindings+type LHsBinds id = LHsBindsLR id id++-- | Haskell Binding+type HsBind   id = HsBindLR   id id++-- | Located Haskell Bindings with separate Left and Right identifier types+type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)++-- | Located Haskell Binding with separate Left and Right identifier types+type LHsBindLR  idL idR = Located (HsBindLR idL idR)++{- Note [Varieties of binding pattern matches]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The distinction between FunBind and PatBind is a bit subtle. FunBind covers+patterns which resemble function bindings and simple variable bindings.++    f x = e+    f !x = e+    f = e+    !x = e          -- FunRhs has SrcStrict+    x `f` y = e     -- FunRhs has Infix++The actual patterns and RHSs of a FunBind are encoding in fun_matches.+The m_ctxt field of Match will be FunRhs and carries two bits of information+about the match,++  * the mc_strictness field describes whether the match is decorated with a bang+    (e.g. `!x = e`)+  * the mc_fixity field describes the fixity of the function binder++By contrast, PatBind represents data constructor patterns, as well as a few+other interesting cases. Namely,++    Just x = e+    (x) = e+    x :: Ty = e+-}++-- | Haskell Binding with separate Left and Right id's+data HsBindLR idL idR+  = -- | Function-like Binding+    --+    -- FunBind is used for both functions     @f x = e@+    -- and variables                          @f = \x -> e@+    -- and strict variables                   @!x = x + 1@+    --+    -- Reason 1: Special case for type inference: see 'TcBinds.tcMonoBinds'.+    --+    -- Reason 2: Instance decls can only have FunBinds, which is convenient.+    --           If you change this, you'll need to change e.g. rnMethodBinds+    --+    -- But note that the form                 @f :: a->a = ...@+    -- parses as a pattern binding, just like+    --                                        @(f :: a -> a) = ... @+    --+    -- Strict bindings have their strictness recorded in the 'SrcStrictness' of their+    -- 'MatchContext'. See Note [Varieties of binding pattern matches] for+    -- details about the relationship between FunBind and PatBind.+    --+    --  'ApiAnnotation.AnnKeywordId's+    --+    --  - 'ApiAnnotation.AnnFunId', attached to each element of fun_matches+    --+    --  - 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere',+    --    'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',++    -- For details on above see note [Api annotations] in ApiAnnotation+    FunBind {++        fun_id :: Located idL, -- Note [fun_id in Match] in HsExpr++        fun_matches :: MatchGroup idR (LHsExpr idR),  -- ^ The payload++        fun_co_fn :: HsWrapper, -- ^ Coercion from the type of the MatchGroup to the type of+                                -- the Id.  Example:+                                --+                                -- @+                                --      f :: Int -> forall a. a -> a+                                --      f x y = y+                                -- @+                                --+                                -- Then the MatchGroup will have type (Int -> a' -> a')+                                -- (with a free type variable a').  The coercion will take+                                -- a CoreExpr of this type and convert it to a CoreExpr of+                                -- type         Int -> forall a'. a' -> a'+                                -- Notice that the coercion captures the free a'.++        bind_fvs :: PostRn idL NameSet, -- ^ After the renamer, this contains+                                --  the locally-bound+                                -- free variables of this defn.+                                -- See Note [Bind free vars]+++        fun_tick :: [Tickish Id]  -- ^ Ticks to put on the rhs, if any+    }++  -- | Pattern Binding+  --+  -- The pattern is never a simple variable;+  -- That case is done by FunBind.+  -- See Note [Varieties of binding pattern matches] for details about the+  -- relationship between FunBind and PatBind.++  --+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang',+  --       'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere',+  --       'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',++  -- For details on above see note [Api annotations] in ApiAnnotation+  | PatBind {+        pat_lhs    :: LPat idL,+        pat_rhs    :: GRHSs idR (LHsExpr idR),+        pat_rhs_ty :: PostTc idR Type,      -- ^ Type of the GRHSs+        bind_fvs   :: PostRn idL NameSet, -- ^ See Note [Bind free vars]+        pat_ticks  :: ([Tickish Id], [[Tickish Id]])+               -- ^ Ticks to put on the rhs, if any, and ticks to put on+               -- the bound variables.+    }++  -- | Variable Binding+  --+  -- Dictionary binding and suchlike.+  -- All VarBinds are introduced by the type checker+  | VarBind {+        var_id     :: idL,+        var_rhs    :: LHsExpr idR,   -- ^ Located only for consistency+        var_inline :: Bool           -- ^ True <=> inline this binding regardless+                                     -- (used for implication constraints only)+    }++  -- | Abstraction Bindings+  | AbsBinds {                      -- Binds abstraction; TRANSLATION+        abs_tvs     :: [TyVar],+        abs_ev_vars :: [EvVar],  -- ^ Includes equality constraints++       -- | AbsBinds only gets used when idL = idR after renaming,+       -- but these need to be idL's for the collect... code in HsUtil+       -- to have the right type+        abs_exports :: [ABExport idL],++        -- | Evidence bindings+        -- Why a list? See TcInstDcls+        -- Note [Typechecking plan for instance declarations]+        abs_ev_binds :: [TcEvBinds],++        -- | Typechecked user bindings+        abs_binds    :: LHsBinds idL+    }++  -- | Abstraction Bindings Signature+  | AbsBindsSig {  -- Simpler form of AbsBinds, used with a type sig+                   -- in tcPolyCheck. Produces simpler desugaring and+                   -- is necessary to avoid #11405, comment:3.+        abs_tvs     :: [TyVar],+        abs_ev_vars :: [EvVar],++        abs_sig_export :: idL,  -- like abe_poly+        abs_sig_prags  :: TcSpecPrags,++        abs_sig_ev_bind :: TcEvBinds,  -- no list needed here+        abs_sig_bind    :: LHsBind idL -- always only one, and it's always a+                                       -- FunBind+    }++  -- | Patterns Synonym Binding+  | PatSynBind (PatSynBind idL idR)+        -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',+        --          'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnEqual',+        --          'ApiAnnotation.AnnWhere'+        --          'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@++        -- For details on above see note [Api annotations] in ApiAnnotation++deriving instance (DataId idL, DataId idR)+  => Data (HsBindLR idL idR)++        -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]+        --+        -- Creates bindings for (polymorphic, overloaded) poly_f+        -- in terms of monomorphic, non-overloaded mono_f+        --+        -- Invariants:+        --      1. 'binds' binds mono_f+        --      2. ftvs is a subset of tvs+        --      3. ftvs includes all tyvars free in ds+        --+        -- See Note [AbsBinds]++-- | Abtraction Bindings Export+data ABExport id+  = ABE { abe_poly      :: id    -- ^ Any INLINE pragmas is attached to this Id+        , abe_mono      :: id+        , abe_wrap      :: HsWrapper    -- ^ See Note [ABExport wrapper]+             -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly+        , abe_prags     :: TcSpecPrags  -- ^ SPECIALISE pragmas+  } deriving Data++-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',+--             'ApiAnnotation.AnnEqual','ApiAnnotation.AnnLarrow'+--             'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen' @'{'@,+--             'ApiAnnotation.AnnClose' @'}'@,++-- For details on above see note [Api annotations] in ApiAnnotation++-- | Pattern Synonym binding+data PatSynBind idL idR+  = PSB { psb_id   :: Located idL,             -- ^ Name of the pattern synonym+          psb_fvs  :: PostRn idR NameSet,      -- ^ See Note [Bind free vars]+          psb_args :: HsPatSynDetails (Located idR), -- ^ Formal parameter names+          psb_def  :: LPat idR,                      -- ^ Right-hand side+          psb_dir  :: HsPatSynDir idR                -- ^ Directionality+  }+deriving instance (DataId idL, DataId idR)+  => Data (PatSynBind idL idR)++{-+Note [AbsBinds]+~~~~~~~~~~~~~~~+The AbsBinds constructor is used in the output of the type checker, to record+*typechecked* and *generalised* bindings.  Consider a module M, with this+top-level binding, where there is no type signature for M.reverse,+    M.reverse []     = []+    M.reverse (x:xs) = M.reverse xs ++ [x]++In Hindley-Milner, a recursive binding is typechecked with the *recursive* uses+being *monomorphic*.  So after typechecking *and* desugaring we will get something+like this++    M.reverse :: forall a. [a] -> [a]+      = /\a. letrec+                reverse :: [a] -> [a] = \xs -> case xs of+                                                []     -> []+                                                (x:xs) -> reverse xs ++ [x]+             in reverse++Notice that 'M.reverse' is polymorphic as expected, but there is a local+definition for plain 'reverse' which is *monomorphic*.  The type variable+'a' scopes over the entire letrec.++That's after desugaring.  What about after type checking but before+desugaring?  That's where AbsBinds comes in.  It looks like this:++   AbsBinds { abs_tvs     = [a]+            , abs_exports = [ABE { abe_poly = M.reverse :: forall a. [a] -> [a],+                                 , abe_mono = reverse :: [a] -> [a]}]+            , abs_binds = { reverse :: [a] -> [a]+                               = \xs -> case xs of+                                            []     -> []+                                            (x:xs) -> reverse xs ++ [x] } }++Here,+  * abs_tvs says what type variables are abstracted over the binding group,+    just 'a' in this case.+  * abs_binds is the *monomorphic* bindings of the group+  * abs_exports describes how to get the polymorphic Id 'M.reverse' from the+    monomorphic one 'reverse'++Notice that the *original* function (the polymorphic one you thought+you were defining) appears in the abe_poly field of the+abs_exports. The bindings in abs_binds are for fresh, local, Ids with+a *monomorphic* Id.++If there is a group of mutually recursive (see Note [Polymorphic+recursion]) functions without type signatures, we get one AbsBinds+with the monomorphic versions of the bindings in abs_binds, and one+element of abe_exports for each variable bound in the mutually+recursive group.  This is true even for pattern bindings.  Example:+        (f,g) = (\x -> x, f)+After type checking we get+   AbsBinds { abs_tvs     = [a]+            , abs_exports = [ ABE { abe_poly = M.f :: forall a. a -> a+                                  , abe_mono = f :: a -> a }+                            , ABE { abe_poly = M.g :: forall a. a -> a+                                  , abe_mono = g :: a -> a }]+            , abs_binds = { (f,g) = (\x -> x, f) }++Note [Polymorphic recursion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   Rec { f x = ...(g ef)...++       ; g :: forall a. [a] -> [a]+       ; g y = ...(f eg)...  }++These bindings /are/ mutually recursive (f calls g, and g calls f).+But we can use the type signature for g to break the recursion,+like this:++  1. Add g :: forall a. [a] -> [a] to the type environment++  2. Typecheck the definition of f, all by itself,+     including generalising it to find its most general+     type, say f :: forall b. b -> b -> [b]++  3. Extend the type environment with that type for f++  4. Typecheck the definition of g, all by itself,+     checking that it has the type claimed by its signature++Steps 2 and 4 each generate a separate AbsBinds, so we end+up with+   Rec { AbsBinds { ...for f ... }+       ; AbsBinds { ...for g ... } }++This approach allows both f and to call each other+polymorphically, even though only g has a signature.++We get an AbsBinds that encompasses multiple source-program+bindings only when+ * Each binding in the group has at least one binder that+   lacks a user type signature+ * The group forms a strongly connected component++Note [ABExport wrapper]+~~~~~~~~~~~~~~~~~~~~~~~+Consider+   (f,g) = (\x.x, \y.y)+This ultimately desugars to something like this:+   tup :: forall a b. (a->a, b->b)+   tup = /\a b. (\x:a.x, \y:b.y)+   f :: forall a. a -> a+   f = /\a. case tup a Any of+               (fm::a->a,gm:Any->Any) -> fm+   ...similarly for g...++The abe_wrap field deals with impedance-matching between+    (/\a b. case tup a b of { (f,g) -> f })+and the thing we really want, which may have fewer type+variables.  The action happens in TcBinds.mkExport.++Note [Bind free vars]+~~~~~~~~~~~~~~~~~~~~~+The bind_fvs field of FunBind and PatBind records the free variables+of the definition.  It is used for the following purposes++a) Dependency analysis prior to type checking+    (see TcBinds.tc_group)++b) Deciding whether we can do generalisation of the binding+    (see TcBinds.decideGeneralisationPlan)++c) Deciding whether the binding can be used in static forms+    (see TcExpr.checkClosedInStaticForm for the HsStatic case and+     TcBinds.isClosedBndrGroup).++Specifically,++  * bind_fvs includes all free vars that are defined in this module+    (including top-level things and lexically scoped type variables)++  * bind_fvs excludes imported vars; this is just to keep the set smaller++  * Before renaming, and after typechecking, the field is unused;+    it's just an error thunk+-}++instance (OutputableBndrId idL, OutputableBndrId idR)+        => Outputable (HsLocalBindsLR idL idR) where+  ppr (HsValBinds bs) = ppr bs+  ppr (HsIPBinds bs)  = ppr bs+  ppr EmptyLocalBinds = empty++instance (OutputableBndrId idL, OutputableBndrId idR)+        => Outputable (HsValBindsLR idL idR) where+  ppr (ValBindsIn binds sigs)+   = pprDeclList (pprLHsBindsForUser binds sigs)++  ppr (ValBindsOut sccs sigs)+    = getPprStyle $ \ sty ->+      if debugStyle sty then    -- Print with sccs showing+        vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)+     else+        pprDeclList (pprLHsBindsForUser (unionManyBags (map snd sccs)) sigs)+   where+     ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds+     pp_rec Recursive    = text "rec"+     pp_rec NonRecursive = text "nonrec"++pprLHsBinds :: (OutputableBndrId idL, OutputableBndrId idR)+            => LHsBindsLR idL idR -> SDoc+pprLHsBinds binds+  | isEmptyLHsBinds binds = empty+  | otherwise = pprDeclList (map ppr (bagToList binds))++pprLHsBindsForUser :: (OutputableBndrId idL, OutputableBndrId idR,+                       OutputableBndrId id2)+                   => LHsBindsLR idL idR -> [LSig id2] -> [SDoc]+--  pprLHsBindsForUser is different to pprLHsBinds because+--  a) No braces: 'let' and 'where' include a list of HsBindGroups+--     and we don't want several groups of bindings each+--     with braces around+--  b) Sort by location before printing+--  c) Include signatures+pprLHsBindsForUser binds sigs+  = map snd (sort_by_loc decls)+  where++    decls :: [(SrcSpan, SDoc)]+    decls = [(loc, ppr sig)  | L loc sig <- sigs] +++            [(loc, ppr bind) | L loc bind <- bagToList binds]++    sort_by_loc decls = sortBy (comparing fst) decls++pprDeclList :: [SDoc] -> SDoc   -- Braces with a space+-- Print a bunch of declarations+-- One could choose  { d1; d2; ... }, using 'sep'+-- or      d1+--         d2+--         ..+--    using vcat+-- At the moment we chose the latter+-- Also we do the 'pprDeeperList' thing.+pprDeclList ds = pprDeeperList vcat ds++------------+emptyLocalBinds :: HsLocalBindsLR a b+emptyLocalBinds = EmptyLocalBinds++isEmptyLocalBinds :: HsLocalBindsLR a b -> Bool+isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds+isEmptyLocalBinds (HsIPBinds ds)  = isEmptyIPBinds ds+isEmptyLocalBinds EmptyLocalBinds = True++eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool+eqEmptyLocalBinds EmptyLocalBinds = True+eqEmptyLocalBinds _               = False++isEmptyValBinds :: HsValBindsLR a b -> Bool+isEmptyValBinds (ValBindsIn ds sigs)  = isEmptyLHsBinds ds && null sigs+isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs++emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b+emptyValBindsIn  = ValBindsIn emptyBag []+emptyValBindsOut = ValBindsOut []      []++emptyLHsBinds :: LHsBindsLR idL idR+emptyLHsBinds = emptyBag++isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool+isEmptyLHsBinds = isEmptyBag++------------+plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a+plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)+  = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)+plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)+  = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)+plusHsValBinds _ _+  = panic "HsBinds.plusHsValBinds"++{-+What AbsBinds means+~~~~~~~~~~~~~~~~~~~+         AbsBinds tvs+                  [d1,d2]+                  [(tvs1, f1p, f1m),+                   (tvs2, f2p, f2m)]+                  BIND+means++        f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND+                                     in fm++        gp = ...same again, with gm instead of fm++This is a pretty bad translation, because it duplicates all the bindings.+So the desugarer tries to do a better job:++        fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of+                                        (fm,gm) -> fm+        ..ditto for gp..++        tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND+                                      in (fm,gm)+-}++instance (OutputableBndrId idL, OutputableBndrId idR)+         => Outputable (HsBindLR idL idR) where+    ppr mbind = ppr_monobind mbind++ppr_monobind :: (OutputableBndrId idL, OutputableBndrId idR)+             => HsBindLR idL idR -> SDoc++ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })+  = pprPatBind pat grhss+ppr_monobind (VarBind { var_id = var, var_rhs = rhs })+  = sep [pprBndr CasePatBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)]+ppr_monobind (FunBind { fun_id = fun,+                        fun_co_fn = wrap,+                        fun_matches = matches,+                        fun_tick = ticks })+  = pprTicks empty (if null ticks then empty+                    else text "-- ticks = " <> ppr ticks)+    $$  ifPprDebug (pprBndr LetBind (unLoc fun))+    $$  pprFunBind  matches+    $$  ifPprDebug (ppr wrap)+ppr_monobind (PatSynBind psb) = ppr psb+ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars+                       , abs_exports = exports, abs_binds = val_binds+                       , abs_ev_binds = ev_binds })+  = sdocWithDynFlags $ \ dflags ->+    if gopt Opt_PrintTypecheckerElaboration dflags then+      -- Show extra information (bug number: #10662)+      hang (text "AbsBinds" <+> brackets (interpp'SP tyvars)+                                    <+> brackets (interpp'SP dictvars))+         2 $ braces $ vcat+      [ text "Exports:" <+>+          brackets (sep (punctuate comma (map ppr exports)))+      , text "Exported types:" <+>+          vcat [pprBndr LetBind (abe_poly ex) | ex <- exports]+      , text "Binds:" <+> pprLHsBinds val_binds+      , text "Evidence:" <+> ppr ev_binds ]+    else+      pprLHsBinds val_binds+ppr_monobind (AbsBindsSig { abs_tvs         = tyvars+                          , abs_ev_vars     = dictvars+                          , abs_sig_export  = poly_id+                          , abs_sig_ev_bind = ev_bind+                          , abs_sig_bind    = bind })+  = sdocWithDynFlags $ \ dflags ->+    if gopt Opt_PrintTypecheckerElaboration dflags then+      hang (text "AbsBindsSig" <+> brackets (interpp'SP tyvars)+                               <+> brackets (interpp'SP dictvars))+         2 $ braces $ vcat+      [ text "Exported type:" <+> pprBndr LetBind poly_id+      , text "Bind:"     <+> ppr bind+      , text "Evidence:" <+> ppr ev_bind ]+    else+      ppr bind++instance (OutputableBndr id) => Outputable (ABExport id) where+  ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })+    = vcat [ ppr gbl <+> text "<=" <+> ppr lcl+           , nest 2 (pprTcSpecPrags prags)+           , nest 2 (text "wrap:" <+> ppr wrap)]++instance (OutputableBndr idL, OutputableBndrId idR)+          => Outputable (PatSynBind idL idR) where+  ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat,+            psb_dir = dir })+      = ppr_lhs <+> ppr_rhs+    where+      ppr_lhs = text "pattern" <+> ppr_details+      ppr_simple syntax = syntax <+> ppr pat++      ppr_details = case details of+          InfixPatSyn v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2]+          PrefixPatSyn vs   -> hsep (pprPrefixOcc psyn : map ppr vs)+          RecordPatSyn vs   ->+            pprPrefixOcc psyn+                      <> braces (sep (punctuate comma (map ppr vs)))++      ppr_rhs = case dir of+          Unidirectional           -> ppr_simple (text "<-")+          ImplicitBidirectional    -> ppr_simple equals+          ExplicitBidirectional mg -> ppr_simple (text "<-") <+> ptext (sLit "where") $$+                                      (nest 2 $ pprFunBind mg)++pprTicks :: SDoc -> SDoc -> SDoc+-- Print stuff about ticks only when -dppr-debug is on, to avoid+-- them appearing in error messages (from the desugarer); see Trac # 3263+-- Also print ticks in dumpStyle, so that -ddump-hpc actually does+-- something useful.+pprTicks pp_no_debug pp_when_debug+  = getPprStyle (\ sty -> if debugStyle sty || dumpStyle sty+                             then pp_when_debug+                             else pp_no_debug)++{-+************************************************************************+*                                                                      *+                Implicit parameter bindings+*                                                                      *+************************************************************************+-}++-- | Haskell Implicit Parameter Bindings+data HsIPBinds id+  = IPBinds+        [LIPBind id]+        TcEvBinds       -- Only in typechecker output; binds+                        -- uses of the implicit parameters+deriving instance (DataId id) => Data (HsIPBinds id)++isEmptyIPBinds :: HsIPBinds id -> Bool+isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds++-- | Located Implicit Parameter Binding+type LIPBind id = Located (IPBind id)+-- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a+--   list++-- For details on above see note [Api annotations] in ApiAnnotation++-- | Implicit parameter bindings.+--+-- These bindings start off as (Left "x") in the parser and stay+-- that way until after type-checking when they are replaced with+-- (Right d), where "d" is the name of the dictionary holding the+-- evidence for the implicit parameter.+--+-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual'++-- For details on above see note [Api annotations] in ApiAnnotation+data IPBind id+  = IPBind (Either (Located HsIPName) id) (LHsExpr id)+deriving instance (DataId name) => Data (IPBind name)++instance (OutputableBndrId id ) => Outputable (HsIPBinds id) where+  ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)+                        $$ ifPprDebug (ppr ds)++instance (OutputableBndrId id ) => Outputable (IPBind id) where+  ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)+    where name = case lr of+                   Left (L _ ip) -> pprBndr LetBind ip+                   Right     id  -> pprBndr LetBind id++{-+************************************************************************+*                                                                      *+\subsection{@Sig@: type signatures and value-modifying user pragmas}+*                                                                      *+************************************************************************++It is convenient to lump ``value-modifying'' user-pragmas (e.g.,+``specialise this function to these four types...'') in with type+signatures.  Then all the machinery to move them into place, etc.,+serves for both.+-}++-- | Located Signature+type LSig name = Located (Sig name)++-- | Signatures and pragmas+data Sig name+  =   -- | An ordinary type signature+      --+      -- > f :: Num a => a -> a+      --+      -- After renaming, this list of Names contains the named and unnamed+      -- wildcards brought into scope by this signature. For a signature+      -- @_ -> _a -> Bool@, the renamer will give the unnamed wildcard @_@+      -- a freshly generated name, e.g. @_w@. @_w@ and the named wildcard @_a@+      -- are then both replaced with fresh meta vars in the type. Their names+      -- are stored in the type signature that brought them into scope, in+      -- this third field to be more specific.+      --+      --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon',+      --          'ApiAnnotation.AnnComma'++      -- For details on above see note [Api annotations] in ApiAnnotation+    TypeSig+       [Located name]        -- LHS of the signature; e.g.  f,g,h :: blah+       (LHsSigWcType name)   -- RHS of the signature; can have wildcards++      -- | A pattern synonym type signature+      --+      -- > pattern Single :: () => (Show a) => a -> [a]+      --+      --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',+      --           'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnForall'+      --           'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'++      -- For details on above see note [Api annotations] in ApiAnnotation+  | PatSynSig [Located name] (LHsSigType name)+      -- P :: forall a b. Req => Prov => ty++      -- | A signature for a class method+      --   False: ordinary class-method signature+      --   True:  generic-default class method signature+      -- e.g.   class C a where+      --          op :: a -> a                   -- Ordinary+      --          default op :: Eq a => a -> a   -- Generic default+      -- No wildcards allowed here+      --+      --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault',+      --           'ApiAnnotation.AnnDcolon'+  | ClassOpSig Bool [Located name] (LHsSigType name)++        -- | A type signature in generated code, notably the code+        -- generated for record selectors.  We simply record+        -- the desired Id itself, replete with its name, type+        -- and IdDetails.  Otherwise it's just like a type+        -- signature: there should be an accompanying binding+  | IdSig Id++        -- | An ordinary fixity declaration+        --+        -- >     infixl 8 ***+        --+        --+        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInfix',+        --           'ApiAnnotation.AnnVal'++        -- For details on above see note [Api annotations] in ApiAnnotation+  | FixSig (FixitySig name)++        -- | An inline pragma+        --+        -- > {#- INLINE f #-}+        --+        --  - 'ApiAnnotation.AnnKeywordId' :+        --       'ApiAnnotation.AnnOpen' @'{-\# INLINE'@ and @'['@,+        --       'ApiAnnotation.AnnClose','ApiAnnotation.AnnOpen',+        --       'ApiAnnotation.AnnVal','ApiAnnotation.AnnTilde',+        --       'ApiAnnotation.AnnClose'++        -- For details on above see note [Api annotations] in ApiAnnotation+  | InlineSig   (Located name)  -- Function name+                InlinePragma    -- Never defaultInlinePragma++        -- | A specialisation pragma+        --+        -- > {-# SPECIALISE f :: Int -> Int #-}+        --+        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',+        --      'ApiAnnotation.AnnOpen' @'{-\# SPECIALISE'@ and @'['@,+        --      'ApiAnnotation.AnnTilde',+        --      'ApiAnnotation.AnnVal',+        --      'ApiAnnotation.AnnClose' @']'@ and @'\#-}'@,+        --      'ApiAnnotation.AnnDcolon'++        -- For details on above see note [Api annotations] in ApiAnnotation+  | SpecSig     (Located name)     -- Specialise a function or datatype  ...+                [LHsSigType name]  -- ... to these types+                InlinePragma       -- The pragma on SPECIALISE_INLINE form.+                                   -- If it's just defaultInlinePragma, then we said+                                   --    SPECIALISE, not SPECIALISE_INLINE++        -- | A specialisation pragma for instance declarations only+        --+        -- > {-# SPECIALISE instance Eq [Int] #-}+        --+        -- (Class tys); should be a specialisation of the+        -- current instance declaration+        --+        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',+        --      'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose'++        -- For details on above see note [Api annotations] in ApiAnnotation+  | SpecInstSig SourceText (LHsSigType name)+                  -- Note [Pragma source text] in BasicTypes++        -- | A minimal complete definition pragma+        --+        -- > {-# MINIMAL a | (b, c | (d | e)) #-}+        --+        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',+        --      'ApiAnnotation.AnnVbar','ApiAnnotation.AnnComma',+        --      'ApiAnnotation.AnnClose'++        -- For details on above see note [Api annotations] in ApiAnnotation+  | MinimalSig SourceText (LBooleanFormula (Located name))+               -- Note [Pragma source text] in BasicTypes++        -- | A "set cost centre" pragma for declarations+        --+        -- > {-# SCC funName #-}+        --+        -- or+        --+        -- > {-# SCC funName "cost_centre_name" #-}++  | SCCFunSig  SourceText      -- Note [Pragma source text] in BasicTypes+               (Located name)  -- Function name+               (Maybe (Located StringLiteral))+       -- | A complete match pragma+       --+       -- > {-# COMPLETE C, D [:: T] #-}+       --+       -- Used to inform the pattern match checker about additional+       -- complete matchings which, for example, arise from pattern+       -- synonym definitions.+  | CompleteMatchSig SourceText (Located [Located name]) (Maybe (Located name))++deriving instance (DataId name) => Data (Sig name)++-- | Located Fixity Signature+type LFixitySig name = Located (FixitySig name)++-- | Fixity Signature+data FixitySig name = FixitySig [Located name] Fixity+  deriving Data++-- | Type checker Specialisation Pragmas+--+-- 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker to the desugarer+data TcSpecPrags+  = IsDefaultMethod     -- ^ Super-specialised: a default method should+                        -- be macro-expanded at every call site+  | SpecPrags [LTcSpecPrag]+  deriving Data++-- | Located Type checker Specification Pragmas+type LTcSpecPrag = Located TcSpecPrag++-- | Type checker Specification Pragma+data TcSpecPrag+  = SpecPrag+        Id+        HsWrapper+        InlinePragma+  -- ^ The Id to be specialised, an wrapper that specialises the+  -- polymorphic function, and inlining spec for the specialised function+  deriving Data++noSpecPrags :: TcSpecPrags+noSpecPrags = SpecPrags []++hasSpecPrags :: TcSpecPrags -> Bool+hasSpecPrags (SpecPrags ps) = not (null ps)+hasSpecPrags IsDefaultMethod = False++isDefaultMethod :: TcSpecPrags -> Bool+isDefaultMethod IsDefaultMethod = True+isDefaultMethod (SpecPrags {})  = False+++isFixityLSig :: LSig name -> Bool+isFixityLSig (L _ (FixSig {})) = True+isFixityLSig _                 = False++isTypeLSig :: LSig name -> Bool  -- Type signatures+isTypeLSig (L _(TypeSig {}))    = True+isTypeLSig (L _(ClassOpSig {})) = True+isTypeLSig (L _(IdSig {}))      = True+isTypeLSig _                    = False++isSpecLSig :: LSig name -> Bool+isSpecLSig (L _(SpecSig {})) = True+isSpecLSig _                 = False++isSpecInstLSig :: LSig name -> Bool+isSpecInstLSig (L _ (SpecInstSig {})) = True+isSpecInstLSig _                      = False++isPragLSig :: LSig name -> Bool+-- Identifies pragmas+isPragLSig (L _ (SpecSig {}))   = True+isPragLSig (L _ (InlineSig {})) = True+isPragLSig (L _ (SCCFunSig {})) = True+isPragLSig (L _ (CompleteMatchSig {})) = True+isPragLSig _                    = False++isInlineLSig :: LSig name -> Bool+-- Identifies inline pragmas+isInlineLSig (L _ (InlineSig {})) = True+isInlineLSig _                    = False++isMinimalLSig :: LSig name -> Bool+isMinimalLSig (L _ (MinimalSig {})) = True+isMinimalLSig _                     = False++isSCCFunSig :: LSig name -> Bool+isSCCFunSig (L _ (SCCFunSig {})) = True+isSCCFunSig _                    = False++isCompleteMatchSig :: LSig name -> Bool+isCompleteMatchSig (L _ (CompleteMatchSig {} )) = True+isCompleteMatchSig _                            = False++hsSigDoc :: Sig name -> SDoc+hsSigDoc (TypeSig {})           = text "type signature"+hsSigDoc (PatSynSig {})         = text "pattern synonym signature"+hsSigDoc (ClassOpSig is_deflt _ _)+ | is_deflt                     = text "default type signature"+ | otherwise                    = text "class method signature"+hsSigDoc (IdSig {})             = text "id signature"+hsSigDoc (SpecSig {})           = text "SPECIALISE pragma"+hsSigDoc (InlineSig _ prag)     = ppr (inlinePragmaSpec prag) <+> text "pragma"+hsSigDoc (SpecInstSig {})       = text "SPECIALISE instance pragma"+hsSigDoc (FixSig {})            = text "fixity declaration"+hsSigDoc (MinimalSig {})        = text "MINIMAL pragma"+hsSigDoc (SCCFunSig {})         = text "SCC pragma"+hsSigDoc (CompleteMatchSig {})  = text "COMPLETE pragma"++{-+Check if signatures overlap; this is used when checking for duplicate+signatures. Since some of the signatures contain a list of names, testing for+equality is not enough -- we have to check if they overlap.+-}++instance (OutputableBndrId name ) => Outputable (Sig name) where+    ppr sig = ppr_sig sig++ppr_sig :: (OutputableBndrId name ) => Sig name -> SDoc+ppr_sig (TypeSig vars ty)    = pprVarSig (map unLoc vars) (ppr ty)+ppr_sig (ClassOpSig is_deflt vars ty)+  | is_deflt                 = text "default" <+> pprVarSig (map unLoc vars) (ppr ty)+  | otherwise                = pprVarSig (map unLoc vars) (ppr ty)+ppr_sig (IdSig id)           = pprVarSig [id] (ppr (varType id))+ppr_sig (FixSig fix_sig)     = ppr fix_sig+ppr_sig (SpecSig var ty inl@(InlinePragma { inl_inline = spec }))+  = pragSrcBrackets (inl_src inl) pragmaSrc (pprSpec (unLoc var)+                                             (interpp'SP ty) inl)+    where+      pragmaSrc = case spec of+        EmptyInlineSpec -> "{-# SPECIALISE"+        _               -> "{-# SPECIALISE_INLINE"+ppr_sig (InlineSig var inl)+  = pragSrcBrackets (inl_src inl) "{-# INLINE"  (pprInline inl+                                   <+> pprPrefixOcc (unLoc var))+ppr_sig (SpecInstSig src ty)+  = pragSrcBrackets src "{-# SPECIALISE" (text "instance" <+> ppr ty)+ppr_sig (MinimalSig src bf)+  = pragSrcBrackets src "{-# MINIMAL" (pprMinimalSig bf)+ppr_sig (PatSynSig names sig_ty)+  = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty)+ppr_sig (SCCFunSig src fn mlabel)+  = pragSrcBrackets src "{-# SCC" (ppr fn <+> maybe empty ppr mlabel )+ppr_sig (CompleteMatchSig src cs mty)+  = pragSrcBrackets src "{-# COMPLETE"+      ((hsep (punctuate comma (map ppr (unLoc cs))))+        <+> opt_sig)+  where+    opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty++instance OutputableBndr name => Outputable (FixitySig name) where+  ppr (FixitySig names fixity) = sep [ppr fixity, pprops]+    where+      pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names)++pragBrackets :: SDoc -> SDoc+pragBrackets doc = text "{-#" <+> doc <+> text "#-}"++-- | Using SourceText in case the pragma was spelled differently or used mixed+-- case+pragSrcBrackets :: SourceText -> String -> SDoc -> SDoc+pragSrcBrackets (SourceText src) _   doc = text src <+> doc <+> text "#-}"+pragSrcBrackets NoSourceText     alt doc = text alt <+> doc <+> text "#-}"++pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc+pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty]+  where+    pprvars = hsep $ punctuate comma (map pprPrefixOcc vars)++pprSpec :: (OutputableBndr id) => id -> SDoc -> InlinePragma -> SDoc+pprSpec var pp_ty inl = pp_inl <+> pprVarSig [var] pp_ty+  where+    pp_inl | isDefaultInlinePragma inl = empty+           | otherwise = pprInline inl++pprTcSpecPrags :: TcSpecPrags -> SDoc+pprTcSpecPrags IsDefaultMethod = text "<default method>"+pprTcSpecPrags (SpecPrags ps)  = vcat (map (ppr . unLoc) ps)++instance Outputable TcSpecPrag where+  ppr (SpecPrag var _ inl)+    = text "SPECIALIZE" <+> pprSpec var (text "<type>") inl++pprMinimalSig :: (OutputableBndr name)+              => LBooleanFormula (Located name) -> SDoc+pprMinimalSig (L _ bf) = ppr (fmap unLoc bf)++{-+************************************************************************+*                                                                      *+\subsection[PatSynBind]{A pattern synonym definition}+*                                                                      *+************************************************************************+-}++-- | Haskell Pattern Synonym Details+data HsPatSynDetails a+  = InfixPatSyn a a                    -- ^ Infix Pattern Synonym+  | PrefixPatSyn [a]                   -- ^ Prefix Pattern Synonym+  | RecordPatSyn [RecordPatSynField a] -- ^ Record Pattern Synonym+  deriving Data+++-- See Note [Record PatSyn Fields]+-- | Record Pattern Synonym Field+data RecordPatSynField a+  = RecordPatSynField {+      recordPatSynSelectorId :: a  -- Selector name visible in rest of the file+      , recordPatSynPatVar :: a+      -- Filled in by renamer, the name used internally+      -- by the pattern+      } deriving Data++++{-+Note [Record PatSyn Fields]++Consider the following two pattern synonyms.++pattern P x y = ([x,True], [y,'v'])+pattern Q{ x, y } =([x,True], [y,'v'])++In P, we just have two local binders, x and y.++In Q, we have local binders but also top-level record selectors+x :: ([Bool], [Char]) -> Bool and similarly for y.++It would make sense to support record-like syntax++pattern Q{ x=x1, y=y1 } = ([x1,True], [y1,'v'])++when we have a different name for the local and top-level binder+the distinction between the two names clear++-}+instance Functor RecordPatSynField where+    fmap f (RecordPatSynField { recordPatSynSelectorId = visible+                              , recordPatSynPatVar = hidden })+      = RecordPatSynField { recordPatSynSelectorId = f visible+                          , recordPatSynPatVar = f hidden }++instance Outputable a => Outputable (RecordPatSynField a) where+    ppr (RecordPatSynField { recordPatSynSelectorId = v }) = ppr v++instance Foldable RecordPatSynField  where+    foldMap f (RecordPatSynField { recordPatSynSelectorId = visible+                                 , recordPatSynPatVar = hidden })+      = f visible `mappend` f hidden++instance Traversable RecordPatSynField where+    traverse f (RecordPatSynField { recordPatSynSelectorId =visible+                                  , recordPatSynPatVar = hidden })+      = (\ sel_id pat_var -> RecordPatSynField { recordPatSynSelectorId = sel_id+                                               , recordPatSynPatVar = pat_var })+          <$> f visible <*> f hidden+++instance Functor HsPatSynDetails where+    fmap f (InfixPatSyn left right) = InfixPatSyn (f left) (f right)+    fmap f (PrefixPatSyn args) = PrefixPatSyn (fmap f args)+    fmap f (RecordPatSyn args) = RecordPatSyn (map (fmap f) args)++instance Foldable HsPatSynDetails where+    foldMap f (InfixPatSyn left right) = f left `mappend` f right+    foldMap f (PrefixPatSyn args) = foldMap f args+    foldMap f (RecordPatSyn args) = foldMap (foldMap f) args++    foldl1 f (InfixPatSyn left right) = left `f` right+    foldl1 f (PrefixPatSyn args) = Data.List.foldl1 f args+    foldl1 f (RecordPatSyn args) =+      Data.List.foldl1 f (map (Data.Foldable.foldl1 f) args)++    foldr1 f (InfixPatSyn left right) = left `f` right+    foldr1 f (PrefixPatSyn args) = Data.List.foldr1 f args+    foldr1 f (RecordPatSyn args) =+      Data.List.foldr1 f (map (Data.Foldable.foldr1 f) args)++    length (InfixPatSyn _ _) = 2+    length (PrefixPatSyn args) = Data.List.length args+    length (RecordPatSyn args) = Data.List.length args++    null (InfixPatSyn _ _) = False+    null (PrefixPatSyn args) = Data.List.null args+    null (RecordPatSyn args) = Data.List.null args++    toList (InfixPatSyn left right) = [left, right]+    toList (PrefixPatSyn args) = args+    toList (RecordPatSyn args) = foldMap toList args++instance Traversable HsPatSynDetails where+    traverse f (InfixPatSyn left right) = InfixPatSyn <$> f left <*> f right+    traverse f (PrefixPatSyn args) = PrefixPatSyn <$> traverse f args+    traverse f (RecordPatSyn args) = RecordPatSyn <$> traverse (traverse f) args++-- | Haskell Pattern Synonym Direction+data HsPatSynDir id+  = Unidirectional+  | ImplicitBidirectional+  | ExplicitBidirectional (MatchGroup id (LHsExpr id))+deriving instance (DataId id) => Data (HsPatSynDir id)
+ hsSyn/HsDecls.hs view
@@ -0,0 +1,2104 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable,+             DeriveTraversable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]+                                      -- in module PlaceHolder+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}++-- | Abstract syntax of global declarations.+--+-- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@,+-- @InstDecl@, @DefaultDecl@ and @ForeignDecl@.+module HsDecls (+  -- * Toplevel declarations+  HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving,+  HsDerivingClause(..), LHsDerivingClause,++  -- ** Class or type declarations+  TyClDecl(..), LTyClDecl,+  TyClGroup(..), mkTyClGroup, emptyTyClGroup,+  tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls,+  isClassDecl, isDataDecl, isSynDecl, tcdName,+  isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl,+  isOpenTypeFamilyInfo, isClosedTypeFamilyInfo,+  tyFamInstDeclName, tyFamInstDeclLName,+  countTyClDecls, pprTyClDeclFlavour,+  tyClDeclLName, tyClDeclTyVars,+  hsDeclHasCusk, famDeclHasCusk,+  FamilyDecl(..), LFamilyDecl,++  -- ** Instance declarations+  InstDecl(..), LInstDecl, NewOrData(..), FamilyInfo(..),+  TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,+  DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour,+  TyFamEqn(..), TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn,+  HsTyPats,+  LClsInstDecl, ClsInstDecl(..),++  -- ** Standalone deriving declarations+  DerivDecl(..), LDerivDecl,+  -- ** @RULE@ declarations+  LRuleDecls,RuleDecls(..),RuleDecl(..), LRuleDecl, RuleBndr(..),LRuleBndr,+  collectRuleBndrSigTys,+  flattenRuleDecls, pprFullRuleName,+  -- ** @VECTORISE@ declarations+  VectDecl(..), LVectDecl,+  lvectDeclName, lvectInstDecl,+  -- ** @default@ declarations+  DefaultDecl(..), LDefaultDecl,+  -- ** Template haskell declaration splice+  SpliceExplicitFlag(..),+  SpliceDecl(..), LSpliceDecl,+  -- ** Foreign function interface declarations+  ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),+  noForeignImportCoercionYet, noForeignExportCoercionYet,+  CImportSpec(..),+  -- ** Data-constructor declarations+  ConDecl(..), LConDecl,+  HsConDeclDetails, hsConDeclArgTys,+  getConNames,+  getConDetails,+  gadtDeclDetails,+  -- ** Document comments+  DocDecl(..), LDocDecl, docDeclDoc,+  -- ** Deprecations+  WarnDecl(..),  LWarnDecl,+  WarnDecls(..), LWarnDecls,+  -- ** Annotations+  AnnDecl(..), LAnnDecl,+  AnnProvenance(..), annProvenanceName_maybe,+  -- ** Role annotations+  RoleAnnotDecl(..), LRoleAnnotDecl, roleAnnotDeclName,+  -- ** Injective type families+  FamilyResultSig(..), LFamilyResultSig, InjectivityAnn(..), LInjectivityAnn,+  resultVariableName,++  -- * Grouping+  HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups, hsGroupInstDecls++    ) where++-- friends:+import {-# SOURCE #-}   HsExpr( LHsExpr, HsExpr, HsSplice, pprExpr,+                                pprSpliceDecl )+        -- Because Expr imports Decls via HsBracket++import HsBinds+import HsTypes+import HsDoc+import TyCon+import Name+import BasicTypes+import Coercion+import ForeignCall+import PlaceHolder ( PostTc,PostRn,PlaceHolder(..),DataId, OutputableBndrId )+import NameSet++-- others:+import InstEnv+import Class+import Outputable+import Util+import SrcLoc++import Bag+import Maybes+import Data.Data        hiding (TyCon,Fixity, Infix)++{-+************************************************************************+*                                                                      *+\subsection[HsDecl]{Declarations}+*                                                                      *+************************************************************************+-}++type LHsDecl id = Located (HsDecl id)+        -- ^ When in a list this may have+        --+        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi'+        --++-- For details on above see note [Api annotations] in ApiAnnotation++-- | A Haskell Declaration+data HsDecl id+  = TyClD       (TyClDecl id)      -- ^ Type or Class Declaration+  | InstD       (InstDecl  id)     -- ^ Instance declaration+  | DerivD      (DerivDecl id)     -- ^ Deriving declaration+  | ValD        (HsBind id)        -- ^ Value declaration+  | SigD        (Sig id)           -- ^ Signature declaration+  | DefD        (DefaultDecl id)   -- ^ 'default' declaration+  | ForD        (ForeignDecl id)   -- ^ Foreign declaration+  | WarningD    (WarnDecls id)     -- ^ Warning declaration+  | AnnD        (AnnDecl id)       -- ^ Annotation declaration+  | RuleD       (RuleDecls id)     -- ^ Rule declaration+  | VectD       (VectDecl id)      -- ^ Vectorise declaration+  | SpliceD     (SpliceDecl id)    -- ^ Splice declaration+                                   -- (Includes quasi-quotes)+  | DocD        (DocDecl)          -- ^ Documentation comment declaration+  | RoleAnnotD  (RoleAnnotDecl id) -- ^ Role annotation declaration+deriving instance (DataId id) => Data (HsDecl id)+++-- NB: all top-level fixity decls are contained EITHER+-- EITHER SigDs+-- OR     in the ClassDecls in TyClDs+--+-- The former covers+--      a) data constructors+--      b) class methods (but they can be also done in the+--              signatures of class decls)+--      c) imported functions (that have an IfacSig)+--      d) top level decls+--+-- The latter is for class methods only++-- | Haskell Group+--+-- A 'HsDecl' is categorised into a 'HsGroup' before being+-- fed to the renamer.+data HsGroup id+  = HsGroup {+        hs_valds  :: HsValBinds id,+        hs_splcds :: [LSpliceDecl id],++        hs_tyclds :: [TyClGroup id],+                -- A list of mutually-recursive groups;+                -- This includes `InstDecl`s as well;+                -- Parser generates a singleton list;+                -- renamer does dependency analysis++        hs_derivds :: [LDerivDecl id],++        hs_fixds  :: [LFixitySig id],+                -- Snaffled out of both top-level fixity signatures,+                -- and those in class declarations++        hs_defds  :: [LDefaultDecl id],+        hs_fords  :: [LForeignDecl id],+        hs_warnds :: [LWarnDecls id],+        hs_annds  :: [LAnnDecl id],+        hs_ruleds :: [LRuleDecls id],+        hs_vects  :: [LVectDecl id],++        hs_docs   :: [LDocDecl]+  }+deriving instance (DataId id) => Data (HsGroup id)++emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a+emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }+emptyRnGroup  = emptyGroup { hs_valds = emptyValBindsOut }++hsGroupInstDecls :: HsGroup id -> [LInstDecl id]+hsGroupInstDecls = (=<<) group_instds . hs_tyclds++emptyGroup = HsGroup { hs_tyclds = [],+                       hs_derivds = [],+                       hs_fixds = [], hs_defds = [], hs_annds = [],+                       hs_fords = [], hs_warnds = [], hs_ruleds = [], hs_vects = [],+                       hs_valds = error "emptyGroup hs_valds: Can't happen",+                       hs_splcds = [],+                       hs_docs = [] }++appendGroups :: HsGroup a -> HsGroup a -> HsGroup a+appendGroups+    HsGroup {+        hs_valds  = val_groups1,+        hs_splcds = spliceds1,+        hs_tyclds = tyclds1,+        hs_derivds = derivds1,+        hs_fixds  = fixds1,+        hs_defds  = defds1,+        hs_annds  = annds1,+        hs_fords  = fords1,+        hs_warnds = warnds1,+        hs_ruleds = rulds1,+        hs_vects = vects1,+  hs_docs   = docs1 }+    HsGroup {+        hs_valds  = val_groups2,+        hs_splcds = spliceds2,+        hs_tyclds = tyclds2,+        hs_derivds = derivds2,+        hs_fixds  = fixds2,+        hs_defds  = defds2,+        hs_annds  = annds2,+        hs_fords  = fords2,+        hs_warnds = warnds2,+        hs_ruleds = rulds2,+        hs_vects  = vects2,+        hs_docs   = docs2 }+  =+    HsGroup {+        hs_valds  = val_groups1 `plusHsValBinds` val_groups2,+        hs_splcds = spliceds1 ++ spliceds2,+        hs_tyclds = tyclds1 ++ tyclds2,+        hs_derivds = derivds1 ++ derivds2,+        hs_fixds  = fixds1 ++ fixds2,+        hs_annds  = annds1 ++ annds2,+        hs_defds  = defds1 ++ defds2,+        hs_fords  = fords1 ++ fords2,+        hs_warnds = warnds1 ++ warnds2,+        hs_ruleds = rulds1 ++ rulds2,+        hs_vects  = vects1 ++ vects2,+        hs_docs   = docs1  ++ docs2 }++instance (OutputableBndrId name) => Outputable (HsDecl name) where+    ppr (TyClD dcl)             = ppr dcl+    ppr (ValD binds)            = ppr binds+    ppr (DefD def)              = ppr def+    ppr (InstD inst)            = ppr inst+    ppr (DerivD deriv)          = ppr deriv+    ppr (ForD fd)               = ppr fd+    ppr (SigD sd)               = ppr sd+    ppr (RuleD rd)              = ppr rd+    ppr (VectD vect)            = ppr vect+    ppr (WarningD wd)           = ppr wd+    ppr (AnnD ad)               = ppr ad+    ppr (SpliceD dd)            = ppr dd+    ppr (DocD doc)              = ppr doc+    ppr (RoleAnnotD ra)         = ppr ra++instance (OutputableBndrId name) => Outputable (HsGroup name) where+    ppr (HsGroup { hs_valds  = val_decls,+                   hs_tyclds = tycl_decls,+                   hs_derivds = deriv_decls,+                   hs_fixds  = fix_decls,+                   hs_warnds = deprec_decls,+                   hs_annds  = ann_decls,+                   hs_fords  = foreign_decls,+                   hs_defds  = default_decls,+                   hs_ruleds = rule_decls,+                   hs_vects  = vect_decls })+        = vcat_mb empty+            [ppr_ds fix_decls, ppr_ds default_decls,+             ppr_ds deprec_decls, ppr_ds ann_decls,+             ppr_ds rule_decls,+             ppr_ds vect_decls,+             if isEmptyValBinds val_decls+                then Nothing+                else Just (ppr val_decls),+             ppr_ds (tyClGroupTyClDecls tycl_decls),+             ppr_ds (tyClGroupInstDecls tycl_decls),+             ppr_ds deriv_decls,+             ppr_ds foreign_decls]+        where+          ppr_ds :: Outputable a => [a] -> Maybe SDoc+          ppr_ds [] = Nothing+          ppr_ds ds = Just (vcat (map ppr ds))++          vcat_mb :: SDoc -> [Maybe SDoc] -> SDoc+          -- Concatenate vertically with white-space between non-blanks+          vcat_mb _    []             = empty+          vcat_mb gap (Nothing : ds) = vcat_mb gap ds+          vcat_mb gap (Just d  : ds) = gap $$ d $$ vcat_mb blankLine ds++-- | Located Splice Declaration+type LSpliceDecl name = Located (SpliceDecl name)++-- | Splice Declaration+data SpliceDecl id+  = SpliceDecl                  -- Top level splice+        (Located (HsSplice id))+        SpliceExplicitFlag+deriving instance (DataId id) => Data (SpliceDecl id)++instance (OutputableBndrId name) => Outputable (SpliceDecl name) where+   ppr (SpliceDecl (L _ e) f) = pprSpliceDecl e f++{-+************************************************************************+*                                                                      *+            Type and class declarations+*                                                                      *+************************************************************************++Note [The Naming story]+~~~~~~~~~~~~~~~~~~~~~~~+Here is the story about the implicit names that go with type, class,+and instance decls.  It's a bit tricky, so pay attention!++"Implicit" (or "system") binders+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  Each data type decl defines+        a worker name for each constructor+        to-T and from-T convertors+  Each class decl defines+        a tycon for the class+        a data constructor for that tycon+        the worker for that constructor+        a selector for each superclass++All have occurrence names that are derived uniquely from their parent+declaration.++None of these get separate definitions in an interface file; they are+fully defined by the data or class decl.  But they may *occur* in+interface files, of course.  Any such occurrence must haul in the+relevant type or class decl.++Plan of attack:+ - Ensure they "point to" the parent data/class decl+   when loading that decl from an interface file+   (See RnHiFiles.getSysBinders)++ - When typechecking the decl, we build the implicit TyCons and Ids.+   When doing so we look them up in the name cache (RnEnv.lookupSysName),+   to ensure correct module and provenance is set++These are the two places that we have to conjure up the magic derived+names.  (The actual magic is in OccName.mkWorkerOcc, etc.)++Default methods+~~~~~~~~~~~~~~~+ - Occurrence name is derived uniquely from the method name+   E.g. $dmmax++ - If there is a default method name at all, it's recorded in+   the ClassOpSig (in HsBinds), in the DefMethInfo field.+   (DefMethInfo is defined in Class.hs)++Source-code class decls and interface-code class decls are treated subtly+differently, which has given me a great deal of confusion over the years.+Here's the deal.  (We distinguish the two cases because source-code decls+have (Just binds) in the tcdMeths field, whereas interface decls have Nothing.++In *source-code* class declarations:++ - When parsing, every ClassOpSig gets a DefMeth with a suitable RdrName+   This is done by RdrHsSyn.mkClassOpSigDM++ - The renamer renames it to a Name++ - During typechecking, we generate a binding for each $dm for+   which there's a programmer-supplied default method:+        class Foo a where+          op1 :: <type>+          op2 :: <type>+          op1 = ...+   We generate a binding for $dmop1 but not for $dmop2.+   The Class for Foo has a Nothing for op2 and+                         a Just ($dm_op1, VanillaDM) for op1.+   The Name for $dmop2 is simply discarded.++In *interface-file* class declarations:+  - When parsing, we see if there's an explicit programmer-supplied default method+    because there's an '=' sign to indicate it:+        class Foo a where+          op1 = :: <type>       -- NB the '='+          op2   :: <type>+    We use this info to generate a DefMeth with a suitable RdrName for op1,+    and a NoDefMeth for op2+  - The interface file has a separate definition for $dmop1, with unfolding etc.+  - The renamer renames it to a Name.+  - The renamer treats $dmop1 as a free variable of the declaration, so that+    the binding for $dmop1 will be sucked in.  (See RnHsSyn.tyClDeclFVs)+    This doesn't happen for source code class decls, because they *bind* the default method.++Dictionary functions+~~~~~~~~~~~~~~~~~~~~+Each instance declaration gives rise to one dictionary function binding.++The type checker makes up new source-code instance declarations+(e.g. from 'deriving' or generic default methods --- see+TcInstDcls.tcInstDecls1).  So we can't generate the names for+dictionary functions in advance (we don't know how many we need).++On the other hand for interface-file instance declarations, the decl+specifies the name of the dictionary function, and it has a binding elsewhere+in the interface file:+        instance {Eq Int} = dEqInt+        dEqInt :: {Eq Int} <pragma info>++So again we treat source code and interface file code slightly differently.++Source code:+  - Source code instance decls have a Nothing in the (Maybe name) field+    (see data InstDecl below)++  - The typechecker makes up a Local name for the dict fun for any source-code+    instance decl, whether it comes from a source-code instance decl, or whether+    the instance decl is derived from some other construct (e.g. 'deriving').++  - The occurrence name it chooses is derived from the instance decl (just for+    documentation really) --- e.g. dNumInt.  Two dict funs may share a common+    occurrence name, but will have different uniques.  E.g.+        instance Foo [Int]  where ...+        instance Foo [Bool] where ...+    These might both be dFooList++  - The CoreTidy phase externalises the name, and ensures the occurrence name is+    unique (this isn't special to dict funs).  So we'd get dFooList and dFooList1.++  - We can take this relaxed approach (changing the occurrence name later)+    because dict fun Ids are not captured in a TyCon or Class (unlike default+    methods, say).  Instead, they are kept separately in the InstEnv.  This+    makes it easy to adjust them after compiling a module.  (Once we've finished+    compiling that module, they don't change any more.)+++Interface file code:+  - The instance decl gives the dict fun name, so the InstDecl has a (Just name)+    in the (Maybe name) field.++  - RnHsSyn.instDeclFVs treats the dict fun name as free in the decl, so that we+    suck in the dfun binding+-}++-- | Located Declaration of a Type or Class+type LTyClDecl name = Located (TyClDecl name)++-- | A type or class declaration.+data TyClDecl name+  = -- | @type/data family T :: *->*@+    --+    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',+    --             'ApiAnnotation.AnnData',+    --             'ApiAnnotation.AnnFamily','ApiAnnotation.AnnDcolon',+    --             'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpenP',+    --             'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnCloseP',+    --             'ApiAnnotation.AnnEqual','ApiAnnotation.AnnRarrow',+    --             'ApiAnnotation.AnnVbar'++    -- For details on above see note [Api annotations] in ApiAnnotation+    FamDecl { tcdFam :: FamilyDecl name }++  | -- | @type@ declaration+    --+    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',+    --             'ApiAnnotation.AnnEqual',++    -- For details on above see note [Api annotations] in ApiAnnotation+    SynDecl { tcdLName  :: Located name           -- ^ Type constructor+            , tcdTyVars :: LHsQTyVars name        -- ^ Type variables; for an associated type+                                                  --   these include outer binders+            , tcdFixity :: LexicalFixity    -- ^ Fixity used in the declaration+            , tcdRhs    :: LHsType name           -- ^ RHS of type declaration+            , tcdFVs    :: PostRn name NameSet }++  | -- | @data@ declaration+    --+    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData',+    --              'ApiAnnotation.AnnFamily',+    --              'ApiAnnotation.AnnNewType',+    --              'ApiAnnotation.AnnNewType','ApiAnnotation.AnnDcolon'+    --              'ApiAnnotation.AnnWhere',++    -- For details on above see note [Api annotations] in ApiAnnotation+    DataDecl { tcdLName    :: Located name        -- ^ Type constructor+             , tcdTyVars   :: LHsQTyVars name  -- ^ Type variables; for an associated type+                                                  --   these include outer binders+                                                  -- Eg  class T a where+                                                  --       type F a :: *+                                                  --       type F a = a -> a+                                                  -- Here the type decl for 'f' includes 'a'+                                                  -- in its tcdTyVars+             , tcdFixity  :: LexicalFixity -- ^ Fixity used in the declaration+             , tcdDataDefn :: HsDataDefn name+             , tcdDataCusk :: PostRn name Bool    -- ^ does this have a CUSK?+             , tcdFVs      :: PostRn name NameSet }++  | ClassDecl { tcdCtxt    :: LHsContext name,          -- ^ Context...+                tcdLName   :: Located name,             -- ^ Name of the class+                tcdTyVars  :: LHsQTyVars name,          -- ^ Class type variables+                tcdFixity  :: LexicalFixity, -- ^ Fixity used in the declaration+                tcdFDs     :: [Located (FunDep (Located name))],+                                                        -- ^ Functional deps+                tcdSigs    :: [LSig name],              -- ^ Methods' signatures+                tcdMeths   :: LHsBinds name,            -- ^ Default methods+                tcdATs     :: [LFamilyDecl name],       -- ^ Associated types;+                tcdATDefs  :: [LTyFamDefltEqn name],    -- ^ Associated type defaults+                tcdDocs    :: [LDocDecl],               -- ^ Haddock docs+                tcdFVs     :: PostRn name NameSet+    }+        -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnClass',+        --           'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen',+        --           'ApiAnnotation.AnnClose'+        --   - The tcdFDs will have 'ApiAnnotation.AnnVbar',+        --                          'ApiAnnotation.AnnComma'+        --                          'ApiAnnotation.AnnRarrow'++        -- For details on above see note [Api annotations] in ApiAnnotation++deriving instance (DataId id) => Data (TyClDecl id)+++-- Simple classifiers for TyClDecl+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++-- | @True@ <=> argument is a @data@\/@newtype@+-- declaration.+isDataDecl :: TyClDecl name -> Bool+isDataDecl (DataDecl {}) = True+isDataDecl _other        = False++-- | type or type instance declaration+isSynDecl :: TyClDecl name -> Bool+isSynDecl (SynDecl {})   = True+isSynDecl _other        = False++-- | type class+isClassDecl :: TyClDecl name -> Bool+isClassDecl (ClassDecl {}) = True+isClassDecl _              = False++-- | type/data family declaration+isFamilyDecl :: TyClDecl name -> Bool+isFamilyDecl (FamDecl {})  = True+isFamilyDecl _other        = False++-- | type family declaration+isTypeFamilyDecl :: TyClDecl name -> Bool+isTypeFamilyDecl (FamDecl (FamilyDecl { fdInfo = info })) = case info of+  OpenTypeFamily      -> True+  ClosedTypeFamily {} -> True+  _                   -> False+isTypeFamilyDecl _ = False++-- | open type family info+isOpenTypeFamilyInfo :: FamilyInfo name -> Bool+isOpenTypeFamilyInfo OpenTypeFamily = True+isOpenTypeFamilyInfo _              = False++-- | closed type family info+isClosedTypeFamilyInfo :: FamilyInfo name -> Bool+isClosedTypeFamilyInfo (ClosedTypeFamily {}) = True+isClosedTypeFamilyInfo _                     = False++-- | data family declaration+isDataFamilyDecl :: TyClDecl name -> Bool+isDataFamilyDecl (FamDecl (FamilyDecl { fdInfo = DataFamily })) = True+isDataFamilyDecl _other      = False++-- Dealing with names++tyFamInstDeclName :: TyFamInstDecl name -> name+tyFamInstDeclName = unLoc . tyFamInstDeclLName++tyFamInstDeclLName :: TyFamInstDecl name -> Located name+tyFamInstDeclLName (TyFamInstDecl { tfid_eqn =+                     (L _ (TyFamEqn { tfe_tycon = ln })) })+  = ln++tyClDeclLName :: TyClDecl name -> Located name+tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln+tyClDeclLName decl = tcdLName decl++tcdName :: TyClDecl name -> name+tcdName = unLoc . tyClDeclLName++tyClDeclTyVars :: TyClDecl name -> LHsQTyVars name+tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs+tyClDeclTyVars d = tcdTyVars d++countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int)+        -- class, synonym decls, data, newtype, family decls+countTyClDecls decls+ = (count isClassDecl    decls,+    count isSynDecl      decls,  -- excluding...+    count isDataTy       decls,  -- ...family...+    count isNewTy        decls,  -- ...instances+    count isFamilyDecl   decls)+ where+   isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = DataType } } = True+   isDataTy _                                                       = False++   isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True+   isNewTy _                                                      = False++-- | Does this declaration have a complete, user-supplied kind signature?+-- See Note [Complete user-supplied kind signatures]+hsDeclHasCusk :: TyClDecl Name -> Bool+hsDeclHasCusk (FamDecl { tcdFam = fam_decl }) = famDeclHasCusk Nothing fam_decl+hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })+  -- NB: Keep this synchronized with 'getInitialKind'+  = hsTvbAllKinded tyvars && rhs_annotated rhs+  where+    rhs_annotated (L _ ty) = case ty of+      HsParTy lty  -> rhs_annotated lty+      HsKindSig {} -> True+      _            -> False+hsDeclHasCusk (DataDecl { tcdDataCusk = cusk }) = cusk+hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars++-- Pretty-printing TyClDecl+-- ~~~~~~~~~~~~~~~~~~~~~~~~++instance (OutputableBndrId name) => Outputable (TyClDecl name) where++    ppr (FamDecl { tcdFam = decl }) = ppr decl+    ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity+                 , tcdRhs = rhs })+      = hang (text "type" <+>+              pp_vanilla_decl_head ltycon tyvars fixity [] <+> equals)+          4 (ppr rhs)++    ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity+                  , tcdDataDefn = defn })+      = pp_data_defn (pp_vanilla_decl_head ltycon tyvars fixity) defn++    ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,+                    tcdFixity = fixity,+                    tcdFDs  = fds,+                    tcdSigs = sigs, tcdMeths = methods,+                    tcdATs = ats, tcdATDefs = at_defs})+      | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part+      = top_matter++      | otherwise       -- Laid out+      = vcat [ top_matter <+> text "where"+             , nest 2 $ pprDeclList (map (pprFamilyDecl NotTopLevel . unLoc) ats +++                                     map ppr_fam_deflt_eqn at_defs +++                                     pprLHsBindsForUser methods sigs) ]+      where+        top_matter = text "class"+                    <+> pp_vanilla_decl_head lclas tyvars fixity (unLoc context)+                    <+> pprFundeps (map unLoc fds)++instance (OutputableBndrId name) => Outputable (TyClGroup name) where+  ppr (TyClGroup { group_tyclds = tyclds+                 , group_roles = roles+                 , group_instds = instds+                 }+      )+    = ppr tyclds $$+      ppr roles $$+      ppr instds++pp_vanilla_decl_head :: (OutputableBndrId name) => Located name+   -> LHsQTyVars name+   -> LexicalFixity+   -> HsContext name+   -> SDoc+pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context+ = hsep [pprHsContext context, pp_tyvars tyvars]+  where+    pp_tyvars (varl:varsr)+      | fixity == Infix+         = hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing)+         , hsep (map (ppr.unLoc) varsr)]+      | otherwise = hsep [ pprPrefixOcc (unLoc thing)+                  , hsep (map (ppr.unLoc) (varl:varsr))]+    pp_tyvars [] = ppr thing++pprTyClDeclFlavour :: TyClDecl a -> SDoc+pprTyClDeclFlavour (ClassDecl {})   = text "class"+pprTyClDeclFlavour (SynDecl {})     = text "type"+pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }})+  = pprFlavour info <+> text "family"+pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } })+  = ppr nd+++{- Note [Complete user-supplied kind signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We kind-check declarations differently if they have a complete, user-supplied+kind signature (CUSK). This is because we can safely generalise a CUSKed+declaration before checking all of the others, supporting polymorphic recursion.+See ghc.haskell.org/trac/ghc/wiki/GhcKinds/KindInference#Proposednewstrategy+and #9200 for lots of discussion of how we got here.++A declaration has a CUSK if we can know its complete kind without doing any+inference, at all. Here are the rules:++ - A class or datatype is said to have a CUSK if and only if all of its type+variables are annotated. Its result kind is, by construction, Constraint or *+respectively.++ - A type synonym has a CUSK if and only if all of its type variables and its+RHS are annotated with kinds.++ - A closed type family is said to have a CUSK if and only if all of its type+variables and its return type are annotated.++ - An open type family always has a CUSK -- unannotated type variables (and+return type) default to *.++ - Additionally, if -XTypeInType is on, then a data definition with a top-level+   :: must explicitly bind all kind variables to the right of the ::.+   See test dependent/should_compile/KindLevels, which requires this case.+   (Naturally, any kind variable mentioned before the :: should not be bound+   after it.)+-}+++{- *********************************************************************+*                                                                      *+                         TyClGroup+        Strongly connected components of+      type, class, instance, and role declarations+*                                                                      *+********************************************************************* -}++{- Note [TyClGroups and dependency analysis]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A TyClGroup represents a strongly connected components of type/class/instance+decls, together with the role annotations for the type/class declarations.++The hs_tyclds :: [TyClGroup] field of a HsGroup is a dependency-order+sequence of strongly-connected components.++Invariants+ * The type and class declarations, group_tyclds, may depend on each+   other, or earlier TyClGroups, but not on later ones++ * The role annotations, group_roles, are role-annotations for some or+   all of the types and classes in group_tyclds (only).++ * The instance declarations, group_instds, may (and usually will)+   depend on group_tyclds, or on earlier TyClGroups, but not on later+   ones.++See Note [Dependency analsis of type, class, and instance decls]+in RnSource for more info.+-}++-- | Type or Class Group+data TyClGroup name  -- See Note [TyClGroups and dependency analysis]+  = TyClGroup { group_tyclds :: [LTyClDecl name]+              , group_roles  :: [LRoleAnnotDecl name]+              , group_instds :: [LInstDecl name] }+deriving instance (DataId id) => Data (TyClGroup id)++emptyTyClGroup :: TyClGroup name+emptyTyClGroup = TyClGroup [] [] []++tyClGroupTyClDecls :: [TyClGroup name] -> [LTyClDecl name]+tyClGroupTyClDecls = concatMap group_tyclds++tyClGroupInstDecls :: [TyClGroup name] -> [LInstDecl name]+tyClGroupInstDecls = concatMap group_instds++tyClGroupRoleDecls :: [TyClGroup name] -> [LRoleAnnotDecl name]+tyClGroupRoleDecls = concatMap group_roles++mkTyClGroup :: [LTyClDecl name] -> [LInstDecl name] -> TyClGroup name+mkTyClGroup decls instds = TyClGroup+  { group_tyclds = decls+  , group_roles = []+  , group_instds = instds+  }++++{- *********************************************************************+*                                                                      *+               Data and type family declarations+*                                                                      *+********************************************************************* -}++{- Note [FamilyResultSig]+~~~~~~~~~~~~~~~~~~~~~~~~~++This data type represents the return signature of a type family.  Possible+values are:++ * NoSig - the user supplied no return signature:+      type family Id a where ...++ * KindSig - the user supplied the return kind:+      type family Id a :: * where ...++ * TyVarSig - user named the result with a type variable and possibly+   provided a kind signature for that variable:+      type family Id a = r where ...+      type family Id a = (r :: *) where ...++   Naming result of a type family is required if we want to provide+   injectivity annotation for a type family:+      type family Id a = r | r -> a where ...++See also: Note [Injectivity annotation]++Note [Injectivity annotation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++A user can declare a type family to be injective:++   type family Id a = r | r -> a where ...++ * The part after the "|" is called "injectivity annotation".+ * "r -> a" part is called "injectivity condition"; at the moment terms+   "injectivity annotation" and "injectivity condition" are synonymous+   because we only allow a single injectivity condition.+ * "r" is the "LHS of injectivity condition". LHS can only contain the+   variable naming the result of a type family.++ * "a" is the "RHS of injectivity condition". RHS contains space-separated+   type and kind variables representing the arguments of a type+   family. Variables can be omitted if a type family is not injective in+   these arguments. Example:+         type family Foo a b c = d | d -> a c where ...++Note that:+ (a) naming of type family result is required to provide injectivity+     annotation+ (b) for associated types if the result was named then injectivity annotation+     is mandatory. Otherwise result type variable is indistinguishable from+     associated type default.++It is possible that in the future this syntax will be extended to support+more complicated injectivity annotations. For example we could declare that+if we know the result of Plus and one of its arguments we can determine the+other argument:++   type family Plus a b = (r :: Nat) | r a -> b, r b -> a where ...++Here injectivity annotation would consist of two comma-separated injectivity+conditions.++See also Note [Injective type families] in TyCon+-}++-- | Located type Family Result Signature+type LFamilyResultSig name = Located (FamilyResultSig name)++-- | type Family Result Signature+data FamilyResultSig name = -- see Note [FamilyResultSig]+    NoSig+  -- ^ - 'ApiAnnotation.AnnKeywordId' :++  -- For details on above see note [Api annotations] in ApiAnnotation++  | KindSig  (LHsKind name)+  -- ^ - 'ApiAnnotation.AnnKeywordId' :+  --             'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon',+  --             'ApiAnnotation.AnnCloseP'++  -- For details on above see note [Api annotations] in ApiAnnotation++  | TyVarSig (LHsTyVarBndr name)+  -- ^ - 'ApiAnnotation.AnnKeywordId' :+  --             'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon',+  --             'ApiAnnotation.AnnCloseP', 'ApiAnnotation.AnnEqual'++  -- For details on above see note [Api annotations] in ApiAnnotation++deriving instance (DataId name) => Data (FamilyResultSig name)++-- | Located type Family Declaration+type LFamilyDecl name = Located (FamilyDecl name)++-- | type Family Declaration+data FamilyDecl name = FamilyDecl+  { fdInfo           :: FamilyInfo name              -- type/data, closed/open+  , fdLName          :: Located name                 -- type constructor+  , fdTyVars         :: LHsQTyVars name              -- type variables+  , fdFixity         :: LexicalFixity         -- Fixity used in the declaration+  , fdResultSig      :: LFamilyResultSig name        -- result signature+  , fdInjectivityAnn :: Maybe (LInjectivityAnn name) -- optional injectivity ann+  }+  -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',+  --             'ApiAnnotation.AnnData', 'ApiAnnotation.AnnFamily',+  --             'ApiAnnotation.AnnWhere', 'ApiAnnotation.AnnOpenP',+  --             'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnCloseP',+  --             'ApiAnnotation.AnnEqual', 'ApiAnnotation.AnnRarrow',+  --             'ApiAnnotation.AnnVbar'++  -- For details on above see note [Api annotations] in ApiAnnotation++deriving instance (DataId id) => Data (FamilyDecl id)++-- | Located Injectivity Annotation+type LInjectivityAnn name = Located (InjectivityAnn name)++-- | If the user supplied an injectivity annotation it is represented using+-- InjectivityAnn. At the moment this is a single injectivity condition - see+-- Note [Injectivity annotation]. `Located name` stores the LHS of injectivity+-- condition. `[Located name]` stores the RHS of injectivity condition. Example:+--+--   type family Foo a b c = r | r -> a c where ...+--+-- This will be represented as "InjectivityAnn `r` [`a`, `c`]"+data InjectivityAnn name+  = InjectivityAnn (Located name) [Located name]+  -- ^ - 'ApiAnnotation.AnnKeywordId' :+  --             'ApiAnnotation.AnnRarrow', 'ApiAnnotation.AnnVbar'++  -- For details on above see note [Api annotations] in ApiAnnotation+  deriving Data++data FamilyInfo name+  = DataFamily+  | OpenTypeFamily+     -- | 'Nothing' if we're in an hs-boot file and the user+     -- said "type family Foo x where .."+  | ClosedTypeFamily (Maybe [LTyFamInstEqn name])+deriving instance (DataId name) => Data (FamilyInfo name)++-- | Does this family declaration have a complete, user-supplied kind signature?+famDeclHasCusk :: Maybe Bool+                   -- ^ if associated, does the enclosing class have a CUSK?+               -> FamilyDecl name -> Bool+famDeclHasCusk _ (FamilyDecl { fdInfo      = ClosedTypeFamily _+                             , fdTyVars    = tyvars+                             , fdResultSig = L _ resultSig })+  = hsTvbAllKinded tyvars && hasReturnKindSignature resultSig+famDeclHasCusk mb_class_cusk _ = mb_class_cusk `orElse` True+        -- all un-associated open families have CUSKs!++-- | Does this family declaration have user-supplied return kind signature?+hasReturnKindSignature :: FamilyResultSig a -> Bool+hasReturnKindSignature NoSig                          = False+hasReturnKindSignature (TyVarSig (L _ (UserTyVar _))) = False+hasReturnKindSignature _                              = True++-- | Maybe return name of the result type variable+resultVariableName :: FamilyResultSig a -> Maybe a+resultVariableName (TyVarSig sig) = Just $ hsLTyVarName sig+resultVariableName _              = Nothing++instance (OutputableBndrId name) => Outputable (FamilyDecl name) where+  ppr = pprFamilyDecl TopLevel++pprFamilyDecl :: (OutputableBndrId name)+              => TopLevelFlag -> FamilyDecl name -> SDoc+pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon+                                    , fdTyVars = tyvars+                                    , fdFixity = fixity+                                    , fdResultSig = L _ result+                                    , fdInjectivityAnn = mb_inj })+  = vcat [ pprFlavour info <+> pp_top_level <+>+           pp_vanilla_decl_head ltycon tyvars fixity [] <+>+           pp_kind <+> pp_inj <+> pp_where+         , nest 2 $ pp_eqns ]+  where+    pp_top_level = case top_level of+                     TopLevel    -> text "family"+                     NotTopLevel -> empty++    pp_kind = case result of+                NoSig            -> empty+                KindSig  kind    -> dcolon <+> ppr kind+                TyVarSig tv_bndr -> text "=" <+> ppr tv_bndr+    pp_inj = case mb_inj of+               Just (L _ (InjectivityAnn lhs rhs)) ->+                 hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ]+               Nothing -> empty+    (pp_where, pp_eqns) = case info of+      ClosedTypeFamily mb_eqns ->+        ( text "where"+        , case mb_eqns of+            Nothing   -> text ".."+            Just eqns -> vcat $ map ppr_fam_inst_eqn eqns )+      _ -> (empty, empty)++pprFlavour :: FamilyInfo name -> SDoc+pprFlavour DataFamily            = text "data"+pprFlavour OpenTypeFamily        = text "type"+pprFlavour (ClosedTypeFamily {}) = text "type"++instance Outputable (FamilyInfo name) where+  ppr info = pprFlavour info <+> text "family"++++{- *********************************************************************+*                                                                      *+               Data types and data constructors+*                                                                      *+********************************************************************* -}++-- | Haskell Data type Definition+data HsDataDefn name   -- The payload of a data type defn+                       -- Used *both* for vanilla data declarations,+                       --       *and* for data family instances+  = -- | Declares a data type or newtype, giving its constructors+    -- @+    --  data/newtype T a = <constrs>+    --  data/newtype instance T [a] = <constrs>+    -- @+    HsDataDefn { dd_ND     :: NewOrData,+                 dd_ctxt   :: LHsContext name,           -- ^ Context+                 dd_cType  :: Maybe (Located CType),+                 dd_kindSig:: Maybe (LHsKind name),+                     -- ^ Optional kind signature.+                     --+                     -- @(Just k)@ for a GADT-style @data@,+                     -- or @data instance@ decl, with explicit kind sig+                     --+                     -- Always @Nothing@ for H98-syntax decls++                 dd_cons   :: [LConDecl name],+                     -- ^ Data constructors+                     --+                     -- For @data T a = T1 | T2 a@+                     --   the 'LConDecl's all have 'ConDeclH98'.+                     -- For @data T a where { T1 :: T a }@+                     --   the 'LConDecls' all have 'ConDeclGADT'.++                 dd_derivs :: HsDeriving name  -- ^ Optional 'deriving' claues++             -- For details on above see note [Api annotations] in ApiAnnotation+   }+deriving instance (DataId id) => Data (HsDataDefn id)++-- | Haskell Deriving clause+type HsDeriving name = Located [LHsDerivingClause name]+  -- ^ The optional @deriving@ clauses of a data declaration. "Clauses" is+  -- plural because one can specify multiple deriving clauses using the+  -- @-XDerivingStrategies@ language extension.+  --+  -- The list of 'LHsDerivingClause's corresponds to exactly what the user+  -- requested to derive, in order. If no deriving clauses were specified,+  -- the list is empty.++type LHsDerivingClause name = Located (HsDerivingClause name)++-- | A single @deriving@ clause of a data declaration.+--+--  - 'ApiAnnotation.AnnKeywordId' :+--       'ApiAnnotation.AnnDeriving', 'ApiAnnotation.AnnStock',+--       'ApiAnnotation.AnnAnyClass', 'Api.AnnNewtype',+--       'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'+data HsDerivingClause name+  -- See Note [Deriving strategies] in TcDeriv+  = HsDerivingClause+    { deriv_clause_strategy :: Maybe (Located DerivStrategy)+      -- ^ The user-specified strategy (if any) to use when deriving+      -- 'deriv_clause_tys'.+    , deriv_clause_tys :: Located [LHsSigType name]+      -- ^ The types to derive.+      --+      -- It uses 'LHsSigType's because, with @-XGeneralizedNewtypeDeriving@,+      -- we can mention type variables that aren't bound by the datatype, e.g.+      --+      -- > data T b = ... deriving (C [a])+      --+      -- should produce a derived instance for @C [a] (T b)@.+    }+deriving instance (DataId id) => Data (HsDerivingClause id)++instance (OutputableBndrId name)+       => Outputable (HsDerivingClause name) where+  ppr (HsDerivingClause { deriv_clause_strategy = dcs+                        , deriv_clause_tys      = L _ dct })+    = hsep [ text "deriving"+           , ppDerivStrategy dcs+           , pp_dct dct ]+      where+        -- This complexity is to distinguish between+        --    deriving Show+        --    deriving (Show)+        pp_dct [a@(HsIB { hsib_body = L _ HsAppsTy{} })] = parens (ppr a)+        pp_dct [a] = ppr a+        pp_dct _   = parens (interpp'SP dct)++data NewOrData+  = NewType                     -- ^ @newtype Blah ...@+  | DataType                    -- ^ @data Blah ...@+  deriving( Eq, Data )                -- Needed because Demand derives Eq++-- | Located data Constructor Declaration+type LConDecl name = Located (ConDecl name)+      -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when+      --   in a GADT constructor list++  -- For details on above see note [Api annotations] in ApiAnnotation++-- |+--+-- @+-- data T b = forall a. Eq a => MkT a b+--   MkT :: forall b a. Eq a => MkT a b+--+-- data T b where+--      MkT1 :: Int -> T Int+--+-- data T = Int `MkT` Int+--        | MkT2+--+-- data T a where+--      Int `MkT` Int :: T Int+-- @+--+-- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen',+--            'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnCLose',+--            'ApiAnnotation.AnnEqual','ApiAnnotation.AnnVbar',+--            'ApiAnnotation.AnnDarrow','ApiAnnotation.AnnDarrow',+--            'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot'++-- For details on above see note [Api annotations] in ApiAnnotation++-- | data Constructor Declaration+data ConDecl name+  = ConDeclGADT+      { con_names   :: [Located name]+      , con_type    :: LHsSigType name+        -- ^ The type after the ‘::’+      , con_doc     :: Maybe LHsDocString+          -- ^ A possible Haddock comment.+      }++  | ConDeclH98+      { con_name    :: Located name++      , con_qvars     :: Maybe (LHsQTyVars name)+        -- User-written forall (if any), and its implicit+        -- kind variables+        -- Non-Nothing needs -XExistentialQuantification+        --               e.g. data T a = forall b. MkT b (b->a)+        --               con_qvars = {b}++      , con_cxt       :: Maybe (LHsContext name)+        -- ^ User-written context (if any)++      , con_details   :: HsConDeclDetails name+          -- ^ Arguments++      , con_doc       :: Maybe LHsDocString+          -- ^ A possible Haddock comment.+      }+deriving instance (DataId name) => Data (ConDecl name)++-- | Haskell data Constructor Declaration Details+type HsConDeclDetails name+   = HsConDetails (LBangType name) (Located [LConDeclField name])++getConNames :: ConDecl name -> [Located name]+getConNames ConDeclH98  {con_name  = name}  = [name]+getConNames ConDeclGADT {con_names = names} = names++-- don't call with RdrNames, because it can't deal with HsAppsTy+getConDetails :: ConDecl name -> HsConDeclDetails name+getConDetails ConDeclH98  {con_details  = details} = details+getConDetails ConDeclGADT {con_type     = ty     } = details+  where+    (details,_,_,_) = gadtDeclDetails ty++-- don't call with RdrNames, because it can't deal with HsAppsTy+gadtDeclDetails :: LHsSigType name+                -> ( HsConDeclDetails name+                   , LHsType name+                   , LHsContext name+                   , [LHsTyVarBndr name] )+gadtDeclDetails HsIB {hsib_body = lbody_ty} = (details,res_ty,cxt,tvs)+  where+    (tvs, cxt, tau) = splitLHsSigmaTy lbody_ty+    (details, res_ty)           -- See Note [Sorting out the result type]+      = case tau of+          L _ (HsFunTy (L l (HsRecTy flds)) res_ty')+                  -> (RecCon (L l flds), res_ty')+          _other  -> (PrefixCon [], tau)++hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name]+hsConDeclArgTys (PrefixCon tys)    = tys+hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]+hsConDeclArgTys (RecCon flds)      = map (cd_fld_type . unLoc) (unLoc flds)++pp_data_defn :: (OutputableBndrId name)+                  => (HsContext name -> SDoc)   -- Printing the header+                  -> HsDataDefn name+                  -> SDoc+pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context+                                , dd_cType = mb_ct+                                , dd_kindSig = mb_sig+                                , dd_cons = condecls, dd_derivs = derivings })+  | null condecls+  = ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig+    <+> pp_derivings derivings++  | otherwise+  = hang (ppr new_or_data <+> pp_ct  <+> pp_hdr context <+> pp_sig)+       2 (pp_condecls condecls $$ pp_derivings derivings)+  where+    pp_ct = case mb_ct of+               Nothing   -> empty+               Just ct -> ppr ct+    pp_sig = case mb_sig of+               Nothing   -> empty+               Just kind -> dcolon <+> ppr kind+    pp_derivings (L _ ds) = vcat (map ppr ds)++instance (OutputableBndrId name) => Outputable (HsDataDefn name) where+   ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d++instance Outputable NewOrData where+  ppr NewType  = text "newtype"+  ppr DataType = text "data"++pp_condecls :: (OutputableBndrId name) => [LConDecl name] -> SDoc+pp_condecls cs@(L _ ConDeclGADT{} : _) -- In GADT syntax+  = hang (text "where") 2 (vcat (map ppr cs))+pp_condecls cs                    -- In H98 syntax+  = equals <+> sep (punctuate (text " |") (map ppr cs))++instance (OutputableBndrId name) => Outputable (ConDecl name) where+    ppr = pprConDecl++pprConDecl :: (OutputableBndrId name) => ConDecl name -> SDoc+pprConDecl (ConDeclH98 { con_name = L _ con+                       , con_qvars = mtvs+                       , con_cxt = mcxt+                       , con_details = details+                       , con_doc = doc })+  = sep [ppr_mbDoc doc, pprHsForAll tvs cxt,         ppr_details details]+  where+    ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2]+    ppr_details (PrefixCon tys)  = hsep (pprPrefixOcc con+                                   : map (pprParendHsType . unLoc) tys)+    ppr_details (RecCon fields)  = pprPrefixOcc con+                                 <+> pprConDeclFields (unLoc fields)+    tvs = case mtvs of+      Nothing -> []+      Just (HsQTvs { hsq_explicit = tvs }) -> tvs++    cxt = fromMaybe (noLoc []) mcxt++pprConDecl (ConDeclGADT { con_names = cons, con_type = res_ty, con_doc = doc })+  = sep [ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon+         <+> ppr res_ty]++ppr_con_names :: (OutputableBndr name) => [Located name] -> SDoc+ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)++{-+************************************************************************+*                                                                      *+                Instance declarations+*                                                                      *+************************************************************************++Note [Type family instance declarations in HsSyn]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The data type TyFamEqn represents one equation of a type family instance.+It is parameterised over its tfe_pats field:++ * An ordinary type family instance declaration looks like this in source Haskell+      type instance T [a] Int = a -> a+   (or something similar for a closed family)+   It is represented by a TyFamInstEqn, with *type* in the tfe_pats field.++ * On the other hand, the *default instance* of an associated type looks like+   this in source Haskell+      class C a where+        type T a b+        type T a b = a -> b   -- The default instance+   It is represented by a TyFamDefltEqn, with *type variables* in the tfe_pats+   field.+-}++----------------- Type synonym family instances -------------++-- | Located Type Family Instance Equation+type LTyFamInstEqn  name = Located (TyFamInstEqn  name)+  -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi'+  --   when in a list++-- For details on above see note [Api annotations] in ApiAnnotation++-- | Located Type Family Default Equation+type LTyFamDefltEqn name = Located (TyFamDefltEqn name)++-- | Haskell Type Patterns+type HsTyPats name = HsImplicitBndrs name [LHsType name]+            -- ^ Type patterns (with kind and type bndrs)+            -- See Note [Family instance declaration binders]++{- Note [Family instance declaration binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The HsTyPats field is LHS patterns or a type/data family instance.++The hsib_vars of the HsImplicitBndrs are the template variables of the+type patterns, i.e. fv(pat_tys).  Note in particular++* The hsib_vars *includes* any anonymous wildcards.  For example+     type instance F a _ = a+  The hsib_vars will be {a, _}.  Remember that each separate wildcard+  '_' gets its own unique.  In this context wildcards behave just like+  an ordinary type variable, only anonymous.++* The hsib_vars *including* type variables that are already in scope++   Eg   class C s t where+          type F t p :: *+        instance C w (a,b) where+          type F (a,b) x = x->a+   The hsib_vars of the F decl are {a,b,x}, even though the F decl+   is nested inside the 'instance' decl.++   However after the renamer, the uniques will match up:+        instance C w7 (a8,b9) where+          type F (a8,b9) x10 = x10->a8+   so that we can compare the type pattern in the 'instance' decl and+   in the associated 'type' decl+-}++-- | Type Family Instance Equation+type TyFamInstEqn  name = TyFamEqn name (HsTyPats name)++-- | Type Family Default Equation+type TyFamDefltEqn name = TyFamEqn name (LHsQTyVars name)+  -- See Note [Type family instance declarations in HsSyn]++-- | Type Family Equation+--+-- One equation in a type family instance declaration+-- See Note [Type family instance declarations in HsSyn]+data TyFamEqn name pats+  = TyFamEqn+       { tfe_tycon  :: Located name+       , tfe_pats   :: pats+       , tfe_fixity :: LexicalFixity    -- ^ Fixity used in the declaration+       , tfe_rhs    :: LHsType name }+    -- ^+    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual'++    -- For details on above see note [Api annotations] in ApiAnnotation+deriving instance (DataId name, Data pats) => Data (TyFamEqn name pats)++-- | Located Type Family Instance Declaration+type LTyFamInstDecl name = Located (TyFamInstDecl name)++-- | Type Family Instance Declaration+data TyFamInstDecl name+  = TyFamInstDecl+       { tfid_eqn  :: LTyFamInstEqn name+       , tfid_fvs  :: PostRn name NameSet }+    -- ^+    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',+    --           'ApiAnnotation.AnnInstance',++    -- For details on above see note [Api annotations] in ApiAnnotation+deriving instance (DataId name) => Data (TyFamInstDecl name)++----------------- Data family instances -------------++-- | Located Data Family Instance Declaration+type LDataFamInstDecl name = Located (DataFamInstDecl name)++-- | Data Family Instance Declaration+data DataFamInstDecl name+  = DataFamInstDecl+       { dfid_tycon     :: Located name+       , dfid_pats      :: HsTyPats   name       -- LHS+       , dfid_fixity    :: LexicalFixity    -- ^ Fixity used in the declaration+       , dfid_defn      :: HsDataDefn name       -- RHS+       , dfid_fvs       :: PostRn name NameSet } -- Free vars for dependency analysis+    -- ^+    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData',+    --           'ApiAnnotation.AnnNewType','ApiAnnotation.AnnInstance',+    --           'ApiAnnotation.AnnDcolon'+    --           'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen',+    --           'ApiAnnotation.AnnClose'++    -- For details on above see note [Api annotations] in ApiAnnotation+deriving instance (DataId name) => Data (DataFamInstDecl name)+++----------------- Class instances -------------++-- | Located Class Instance Declaration+type LClsInstDecl name = Located (ClsInstDecl name)++-- | Class Instance Declaration+data ClsInstDecl name+  = ClsInstDecl+      { cid_poly_ty :: LHsSigType name    -- Context => Class Instance-type+                                          -- Using a polytype means that the renamer conveniently+                                          -- figures out the quantified type variables for us.+      , cid_binds         :: LHsBinds name           -- Class methods+      , cid_sigs          :: [LSig name]             -- User-supplied pragmatic info+      , cid_tyfam_insts   :: [LTyFamInstDecl name]   -- Type family instances+      , cid_datafam_insts :: [LDataFamInstDecl name] -- Data family instances+      , cid_overlap_mode  :: Maybe (Located OverlapMode)+         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',+         --                                    'ApiAnnotation.AnnClose',++        -- For details on above see note [Api annotations] in ApiAnnotation+      }+    -- ^+    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInstance',+    --           'ApiAnnotation.AnnWhere',+    --           'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',++    -- For details on above see note [Api annotations] in ApiAnnotation+deriving instance (DataId id) => Data (ClsInstDecl id)+++----------------- Instances of all kinds -------------++-- | Located Instance Declaration+type LInstDecl name = Located (InstDecl name)++-- | Instance Declaration+data InstDecl name  -- Both class and family instances+  = ClsInstD+      { cid_inst  :: ClsInstDecl name }+  | DataFamInstD              -- data family instance+      { dfid_inst :: DataFamInstDecl name }+  | TyFamInstD              -- type family instance+      { tfid_inst :: TyFamInstDecl name }+deriving instance (DataId id) => Data (InstDecl id)++instance (OutputableBndrId name) => Outputable (TyFamInstDecl name) where+  ppr = pprTyFamInstDecl TopLevel++pprTyFamInstDecl :: (OutputableBndrId name)+                 => TopLevelFlag -> TyFamInstDecl name -> SDoc+pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn })+   = text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn++ppr_instance_keyword :: TopLevelFlag -> SDoc+ppr_instance_keyword TopLevel    = text "instance"+ppr_instance_keyword NotTopLevel = empty++ppr_fam_inst_eqn :: (OutputableBndrId name) => LTyFamInstEqn name -> SDoc+ppr_fam_inst_eqn (L _ (TyFamEqn { tfe_tycon = tycon+                                , tfe_pats  = pats+                                , tfe_fixity = fixity+                                , tfe_rhs   = rhs }))+    = pp_fam_inst_lhs tycon pats fixity [] <+> equals <+> ppr rhs++ppr_fam_deflt_eqn :: (OutputableBndrId name) => LTyFamDefltEqn name -> SDoc+ppr_fam_deflt_eqn (L _ (TyFamEqn { tfe_tycon = tycon+                                 , tfe_pats  = tvs+                                 , tfe_fixity = fixity+                                 , tfe_rhs   = rhs }))+    = text "type" <+> pp_vanilla_decl_head tycon tvs fixity []+                  <+> equals <+> ppr rhs++instance (OutputableBndrId name) => Outputable (DataFamInstDecl name) where+  ppr = pprDataFamInstDecl TopLevel++pprDataFamInstDecl :: (OutputableBndrId name)+                   => TopLevelFlag -> DataFamInstDecl name -> SDoc+pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_tycon = tycon+                                            , dfid_pats  = pats+                                            , dfid_fixity = fixity+                                            , dfid_defn  = defn })+  = pp_data_defn pp_hdr defn+  where+    pp_hdr ctxt = ppr_instance_keyword top_lvl+              <+> pp_fam_inst_lhs tycon pats fixity ctxt++pprDataFamInstFlavour :: DataFamInstDecl name -> SDoc+pprDataFamInstFlavour (DataFamInstDecl { dfid_defn = (HsDataDefn { dd_ND = nd }) })+  = ppr nd++pp_fam_inst_lhs :: (OutputableBndrId name) => Located name+   -> HsTyPats name+   -> LexicalFixity+   -> HsContext name+   -> SDoc+pp_fam_inst_lhs thing (HsIB { hsib_body = typats }) fixity context+                                              -- explicit type patterns+   = hsep [ pprHsContext context, pp_pats typats]+   where+     pp_pats (patl:patsr)+       | fixity == Infix+          = hsep [pprParendHsType (unLoc patl), pprInfixOcc (unLoc thing)+          , hsep (map (pprParendHsType.unLoc) patsr)]+       | otherwise = hsep [ pprPrefixOcc (unLoc thing)+                   , hsep (map (pprParendHsType.unLoc) (patl:patsr))]+     pp_pats [] = empty++instance (OutputableBndrId name) => Outputable (ClsInstDecl name) where+    ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds+                     , cid_sigs = sigs, cid_tyfam_insts = ats+                     , cid_overlap_mode = mbOverlap+                     , cid_datafam_insts = adts })+      | null sigs, null ats, null adts, isEmptyBag binds  -- No "where" part+      = top_matter++      | otherwise       -- Laid out+      = vcat [ top_matter <+> text "where"+             , nest 2 $ pprDeclList $+               map (pprTyFamInstDecl NotTopLevel . unLoc)   ats +++               map (pprDataFamInstDecl NotTopLevel . unLoc) adts +++               pprLHsBindsForUser binds sigs ]+      where+        top_matter = text "instance" <+> ppOverlapPragma mbOverlap+                                             <+> ppr inst_ty++ppDerivStrategy :: Maybe (Located DerivStrategy) -> SDoc+ppDerivStrategy mb =+  case mb of+    Nothing       -> empty+    Just (L _ ds) -> ppr ds++ppOverlapPragma :: Maybe (Located OverlapMode) -> SDoc+ppOverlapPragma mb =+  case mb of+    Nothing           -> empty+    Just (L _ (NoOverlap s))    -> maybe_stext s "{-# NO_OVERLAP #-}"+    Just (L _ (Overlappable s)) -> maybe_stext s "{-# OVERLAPPABLE #-}"+    Just (L _ (Overlapping s))  -> maybe_stext s "{-# OVERLAPPING #-}"+    Just (L _ (Overlaps s))     -> maybe_stext s "{-# OVERLAPS #-}"+    Just (L _ (Incoherent s))   -> maybe_stext s "{-# INCOHERENT #-}"+  where+    maybe_stext NoSourceText     alt = text alt+    maybe_stext (SourceText src) _   = text src <+> text "#-}"+++instance (OutputableBndrId name) => Outputable (InstDecl name) where+    ppr (ClsInstD     { cid_inst  = decl }) = ppr decl+    ppr (TyFamInstD   { tfid_inst = decl }) = ppr decl+    ppr (DataFamInstD { dfid_inst = decl }) = ppr decl++-- Extract the declarations of associated data types from an instance++instDeclDataFamInsts :: [LInstDecl name] -> [DataFamInstDecl name]+instDeclDataFamInsts inst_decls+  = concatMap do_one inst_decls+  where+    do_one (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam_insts } }))+      = map unLoc fam_insts+    do_one (L _ (DataFamInstD { dfid_inst = fam_inst }))      = [fam_inst]+    do_one (L _ (TyFamInstD {}))                              = []++{-+************************************************************************+*                                                                      *+\subsection[DerivDecl]{A stand-alone instance deriving declaration}+*                                                                      *+************************************************************************+-}++-- | Located Deriving Declaration+type LDerivDecl name = Located (DerivDecl name)++-- | Deriving Declaration+data DerivDecl name = DerivDecl+        { deriv_type         :: LHsSigType name+        , deriv_strategy     :: Maybe (Located DerivStrategy)+        , deriv_overlap_mode :: Maybe (Located OverlapMode)+         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDeriving',+         --        'ApiAnnotation.AnnInstance', 'ApiAnnotation.AnnStock',+         --        'ApiAnnotation.AnnAnyClass', 'Api.AnnNewtype',+         --        'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'++  -- For details on above see note [Api annotations] in ApiAnnotation+        }+deriving instance (DataId name) => Data (DerivDecl name)++instance (OutputableBndrId name) => Outputable (DerivDecl name) where+    ppr (DerivDecl { deriv_type = ty+                   , deriv_strategy = ds+                   , deriv_overlap_mode = o })+        = hsep [ text "deriving"+               , ppDerivStrategy ds+               , text "instance"+               , ppOverlapPragma o+               , ppr ty ]++{-+************************************************************************+*                                                                      *+\subsection[DefaultDecl]{A @default@ declaration}+*                                                                      *+************************************************************************++There can only be one default declaration per module, but it is hard+for the parser to check that; we pass them all through in the abstract+syntax, and that restriction must be checked in the front end.+-}++-- | Located Default Declaration+type LDefaultDecl name = Located (DefaultDecl name)++-- | Default Declaration+data DefaultDecl name+  = DefaultDecl [LHsType name]+        -- ^ - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnDefault',+        --          'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'++        -- For details on above see note [Api annotations] in ApiAnnotation+deriving instance (DataId name) => Data (DefaultDecl name)++instance (OutputableBndrId name) => Outputable (DefaultDecl name) where++    ppr (DefaultDecl tys)+      = text "default" <+> parens (interpp'SP tys)++{-+************************************************************************+*                                                                      *+\subsection{Foreign function interface declaration}+*                                                                      *+************************************************************************+-}++-- foreign declarations are distinguished as to whether they define or use a+-- Haskell name+--+--  * the Boolean value indicates whether the pre-standard deprecated syntax+--   has been used++-- | Located Foreign Declaration+type LForeignDecl name = Located (ForeignDecl name)++-- | Foreign Declaration+data ForeignDecl name+  = ForeignImport+      { fd_name   :: Located name          -- defines this name+      , fd_sig_ty :: LHsSigType name       -- sig_ty+      , fd_co     :: PostTc name Coercion  -- rep_ty ~ sig_ty+      , fd_fi     :: ForeignImport }++  | ForeignExport+      { fd_name   :: Located name          -- uses this name+      , fd_sig_ty :: LHsSigType name       -- sig_ty+      , fd_co     :: PostTc name Coercion  -- rep_ty ~ sig_ty+      , fd_fe     :: ForeignExport }+        -- ^+        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForeign',+        --           'ApiAnnotation.AnnImport','ApiAnnotation.AnnExport',+        --           'ApiAnnotation.AnnDcolon'++        -- For details on above see note [Api annotations] in ApiAnnotation++deriving instance (DataId name) => Data (ForeignDecl name)+{-+    In both ForeignImport and ForeignExport:+        sig_ty is the type given in the Haskell code+        rep_ty is the representation for this type, i.e. with newtypes+               coerced away and type functions evaluated.+    Thus if the declaration is valid, then rep_ty will only use types+    such as Int and IO that we know how to make foreign calls with.+-}++noForeignImportCoercionYet :: PlaceHolder+noForeignImportCoercionYet = PlaceHolder++noForeignExportCoercionYet :: PlaceHolder+noForeignExportCoercionYet = PlaceHolder++-- Specification Of an imported external entity in dependence on the calling+-- convention+--+data ForeignImport = -- import of a C entity+                     --+                     --  * the two strings specifying a header file or library+                     --   may be empty, which indicates the absence of a+                     --   header or object specification (both are not used+                     --   in the case of `CWrapper' and when `CFunction'+                     --   has a dynamic target)+                     --+                     --  * the calling convention is irrelevant for code+                     --   generation in the case of `CLabel', but is needed+                     --   for pretty printing+                     --+                     --  * `Safety' is irrelevant for `CLabel' and `CWrapper'+                     --+                     CImport  (Located CCallConv) -- ccall or stdcall+                              (Located Safety)  -- interruptible, safe or unsafe+                              (Maybe Header)       -- name of C header+                              CImportSpec          -- details of the C entity+                              (Located SourceText) -- original source text for+                                                   -- the C entity+  deriving Data++-- details of an external C entity+--+data CImportSpec = CLabel    CLabelString     -- import address of a C label+                 | CFunction CCallTarget      -- static or dynamic function+                 | CWrapper                   -- wrapper to expose closures+                                              -- (former f.e.d.)+  deriving Data++-- specification of an externally exported entity in dependence on the calling+-- convention+--+data ForeignExport = CExport  (Located CExportSpec) -- contains the calling+                                                    -- convention+                              (Located SourceText)  -- original source text for+                                                    -- the C entity+  deriving Data++-- pretty printing of foreign declarations+--++instance (OutputableBndrId name) => Outputable (ForeignDecl name) where+  ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport })+    = hang (text "foreign import" <+> ppr fimport <+> ppr n)+         2 (dcolon <+> ppr ty)+  ppr (ForeignExport { fd_name = n, fd_sig_ty = ty, fd_fe = fexport }) =+    hang (text "foreign export" <+> ppr fexport <+> ppr n)+       2 (dcolon <+> ppr ty)++instance Outputable ForeignImport where+  ppr (CImport  cconv safety mHeader spec (L _ srcText)) =+    ppr cconv <+> ppr safety+      <+> pprWithSourceText srcText (pprCEntity spec "")+    where+      pp_hdr = case mHeader of+               Nothing -> empty+               Just (Header _ header) -> ftext header++      pprCEntity (CLabel lbl) _ =+        doubleQuotes $ text "static" <+> pp_hdr <+> char '&' <> ppr lbl+      pprCEntity (CFunction (StaticTarget st _lbl _ isFun)) src =+        if dqNeeded then doubleQuotes ce else empty+          where+            dqNeeded = (take 6 src == "static")+                    || isJust mHeader+                    || not isFun+                    || st /= NoSourceText+            ce =+                  -- We may need to drop leading spaces first+                  (if take 6 src == "static" then text "static" else empty)+              <+> pp_hdr+              <+> (if isFun then empty else text "value")+              <+> (pprWithSourceText st empty)+      pprCEntity (CFunction DynamicTarget) _ =+        doubleQuotes $ text "dynamic"+      pprCEntity CWrapper _ = doubleQuotes $ text "wrapper"++instance Outputable ForeignExport where+  ppr (CExport  (L _ (CExportStatic _ lbl cconv)) _) =+    ppr cconv <+> char '"' <> ppr lbl <> char '"'++{-+************************************************************************+*                                                                      *+\subsection{Transformation rules}+*                                                                      *+************************************************************************+-}++-- | Located Rule Declarations+type LRuleDecls name = Located (RuleDecls name)++  -- Note [Pragma source text] in BasicTypes+-- | Rule Declarations+data RuleDecls name = HsRules { rds_src   :: SourceText+                              , rds_rules :: [LRuleDecl name] }+deriving instance (DataId name) => Data (RuleDecls name)++-- | Located Rule Declaration+type LRuleDecl name = Located (RuleDecl name)++-- | Rule Declaration+data RuleDecl name+  = HsRule                             -- Source rule+        (Located (SourceText,RuleName)) -- Rule name+               -- Note [Pragma source text] in BasicTypes+        Activation+        [LRuleBndr name]        -- Forall'd vars; after typechecking this+                                --   includes tyvars+        (Located (HsExpr name)) -- LHS+        (PostRn name NameSet)   -- Free-vars from the LHS+        (Located (HsExpr name)) -- RHS+        (PostRn name NameSet)   -- Free-vars from the RHS+        -- ^+        --  - 'ApiAnnotation.AnnKeywordId' :+        --           'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde',+        --           'ApiAnnotation.AnnVal',+        --           'ApiAnnotation.AnnClose',+        --           'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot',+        --           'ApiAnnotation.AnnEqual',++        -- For details on above see note [Api annotations] in ApiAnnotation+deriving instance (DataId name) => Data (RuleDecl name)++flattenRuleDecls :: [LRuleDecls name] -> [LRuleDecl name]+flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls++-- | Located Rule Binder+type LRuleBndr name = Located (RuleBndr name)++-- | Rule Binder+data RuleBndr name+  = RuleBndr (Located name)+  | RuleBndrSig (Located name) (LHsSigWcType name)+        -- ^+        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',+        --     'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose'++        -- For details on above see note [Api annotations] in ApiAnnotation+deriving instance (DataId name) => Data (RuleBndr name)++collectRuleBndrSigTys :: [RuleBndr name] -> [LHsSigWcType name]+collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]++pprFullRuleName :: Located (SourceText, RuleName) -> SDoc+pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n)++instance (OutputableBndrId name) => Outputable (RuleDecls name) where+  ppr (HsRules st rules)+    = pprWithSourceText st (text "{-# RULES")+          <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}"++instance (OutputableBndrId name) => Outputable (RuleDecl name) where+  ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs)+        = sep [pprFullRuleName name <+> ppr act,+               nest 4 (pp_forall <+> pprExpr (unLoc lhs)),+               nest 6 (equals <+> pprExpr (unLoc rhs)) ]+        where+          pp_forall | null ns   = empty+                    | otherwise = forAllLit <+> fsep (map ppr ns) <> dot++instance (OutputableBndrId name) => Outputable (RuleBndr name) where+   ppr (RuleBndr name) = ppr name+   ppr (RuleBndrSig name ty) = parens (ppr name <> dcolon <> ppr ty)++{-+************************************************************************+*                                                                      *+\subsection{Vectorisation declarations}+*                                                                      *+************************************************************************++A vectorisation pragma, one of++  {-# VECTORISE f = closure1 g (scalar_map g) #-}+  {-# VECTORISE SCALAR f #-}+  {-# NOVECTORISE f #-}++  {-# VECTORISE type T = ty #-}+  {-# VECTORISE SCALAR type T #-}+-}++-- | Located Vectorise Declaration+type LVectDecl name = Located (VectDecl name)++-- | Vectorise Declaration+data VectDecl name+  = HsVect+      SourceText   -- Note [Pragma source text] in BasicTypes+      (Located name)+      (LHsExpr name)+        -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',+        --           'ApiAnnotation.AnnEqual','ApiAnnotation.AnnClose'++        -- For details on above see note [Api annotations] in ApiAnnotation+  | HsNoVect+      SourceText   -- Note [Pragma source text] in BasicTypes+      (Located name)+        -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',+        --                                    'ApiAnnotation.AnnClose'++        -- For details on above see note [Api annotations] in ApiAnnotation+  | HsVectTypeIn                -- pre type-checking+      SourceText                -- Note [Pragma source text] in BasicTypes+      Bool                      -- 'TRUE' => SCALAR declaration+      (Located name)+      (Maybe (Located name))    -- 'Nothing' => no right-hand side+        -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',+        --           'ApiAnnotation.AnnType','ApiAnnotation.AnnClose',+        --           'ApiAnnotation.AnnEqual'++        -- For details on above see note [Api annotations] in ApiAnnotation+  | HsVectTypeOut               -- post type-checking+      Bool                      -- 'TRUE' => SCALAR declaration+      TyCon+      (Maybe TyCon)             -- 'Nothing' => no right-hand side+  | HsVectClassIn               -- pre type-checking+      SourceText                -- Note [Pragma source text] in BasicTypes+      (Located name)+        -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',+        --           'ApiAnnotation.AnnClass','ApiAnnotation.AnnClose',++       -- For details on above see note [Api annotations] in ApiAnnotation+  | HsVectClassOut              -- post type-checking+      Class+  | HsVectInstIn                -- pre type-checking (always SCALAR)  !!!FIXME: should be superfluous now+      (LHsSigType name)+  | HsVectInstOut               -- post type-checking (always SCALAR) !!!FIXME: should be superfluous now+      ClsInst+deriving instance (DataId name) => Data (VectDecl name)++lvectDeclName :: NamedThing name => LVectDecl name -> Name+lvectDeclName (L _ (HsVect _       (L _ name) _))    = getName name+lvectDeclName (L _ (HsNoVect _     (L _ name)))      = getName name+lvectDeclName (L _ (HsVectTypeIn _  _ (L _ name) _)) = getName name+lvectDeclName (L _ (HsVectTypeOut  _ tycon _))       = getName tycon+lvectDeclName (L _ (HsVectClassIn _ (L _ name)))     = getName name+lvectDeclName (L _ (HsVectClassOut cls))             = getName cls+lvectDeclName (L _ (HsVectInstIn _))+  = panic "HsDecls.lvectDeclName: HsVectInstIn"+lvectDeclName (L _ (HsVectInstOut  _))+  = panic "HsDecls.lvectDeclName: HsVectInstOut"++lvectInstDecl :: LVectDecl name -> Bool+lvectInstDecl (L _ (HsVectInstIn _))  = True+lvectInstDecl (L _ (HsVectInstOut _)) = True+lvectInstDecl _                       = False++instance (OutputableBndrId name) => Outputable (VectDecl name) where+  ppr (HsVect _ v rhs)+    = sep [text "{-# VECTORISE" <+> ppr v,+           nest 4 $+             pprExpr (unLoc rhs) <+> text "#-}" ]+  ppr (HsNoVect _ v)+    = sep [text "{-# NOVECTORISE" <+> ppr v <+> text "#-}" ]+  ppr (HsVectTypeIn _ False t Nothing)+    = sep [text "{-# VECTORISE type" <+> ppr t <+> text "#-}" ]+  ppr (HsVectTypeIn _ False t (Just t'))+    = sep [text "{-# VECTORISE type" <+> ppr t, text "=", ppr t', text "#-}" ]+  ppr (HsVectTypeIn _ True t Nothing)+    = sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ]+  ppr (HsVectTypeIn _ True t (Just t'))+    = sep [text "{-# VECTORISE SCALAR type" <+> ppr t, text "=", ppr t', text "#-}" ]+  ppr (HsVectTypeOut False t Nothing)+    = sep [text "{-# VECTORISE type" <+> ppr t <+> text "#-}" ]+  ppr (HsVectTypeOut False t (Just t'))+    = sep [text "{-# VECTORISE type" <+> ppr t, text "=", ppr t', text "#-}" ]+  ppr (HsVectTypeOut True t Nothing)+    = sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ]+  ppr (HsVectTypeOut True t (Just t'))+    = sep [text "{-# VECTORISE SCALAR type" <+> ppr t, text "=", ppr t', text "#-}" ]+  ppr (HsVectClassIn _ c)+    = sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ]+  ppr (HsVectClassOut c)+    = sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ]+  ppr (HsVectInstIn ty)+    = sep [text "{-# VECTORISE SCALAR instance" <+> ppr ty <+> text "#-}" ]+  ppr (HsVectInstOut i)+    = sep [text "{-# VECTORISE SCALAR instance" <+> ppr i <+> text "#-}" ]++{-+************************************************************************+*                                                                      *+\subsection[DocDecl]{Document comments}+*                                                                      *+************************************************************************+-}++-- | Located Documentation comment Declaration+type LDocDecl = Located (DocDecl)++-- | Documentation comment Declaration+data DocDecl+  = DocCommentNext HsDocString+  | DocCommentPrev HsDocString+  | DocCommentNamed String HsDocString+  | DocGroup Int HsDocString+  deriving Data++-- Okay, I need to reconstruct the document comments, but for now:+instance Outputable DocDecl where+  ppr _ = text "<document comment>"++docDeclDoc :: DocDecl -> HsDocString+docDeclDoc (DocCommentNext d) = d+docDeclDoc (DocCommentPrev d) = d+docDeclDoc (DocCommentNamed _ d) = d+docDeclDoc (DocGroup _ d) = d++{-+************************************************************************+*                                                                      *+\subsection[DeprecDecl]{Deprecations}+*                                                                      *+************************************************************************++We use exported entities for things to deprecate.+-}++-- | Located Warning Declarations+type LWarnDecls name = Located (WarnDecls name)++ -- Note [Pragma source text] in BasicTypes+-- | Warning pragma Declarations+data WarnDecls name = Warnings { wd_src :: SourceText+                               , wd_warnings :: [LWarnDecl name]+                               }+  deriving Data++-- | Located Warning pragma Declaration+type LWarnDecl name = Located (WarnDecl name)++-- | Warning pragma Declaration+data WarnDecl name = Warning [Located name] WarningTxt+  deriving Data++instance OutputableBndr name => Outputable (WarnDecls name) where+    ppr (Warnings (SourceText src) decls)+      = text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}"+    ppr (Warnings NoSourceText _decls) = panic "WarnDecls"++instance OutputableBndr name => Outputable (WarnDecl name) where+    ppr (Warning thing txt)+      = hsep ( punctuate comma (map ppr thing))+              <+> ppr txt++{-+************************************************************************+*                                                                      *+\subsection[AnnDecl]{Annotations}+*                                                                      *+************************************************************************+-}++-- | Located Annotation Declaration+type LAnnDecl name = Located (AnnDecl name)++-- | Annotation Declaration+data AnnDecl name = HsAnnotation+                      SourceText -- Note [Pragma source text] in BasicTypes+                      (AnnProvenance name) (Located (HsExpr name))+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',+      --           'ApiAnnotation.AnnType'+      --           'ApiAnnotation.AnnModule'+      --           'ApiAnnotation.AnnClose'++      -- For details on above see note [Api annotations] in ApiAnnotation+deriving instance (DataId name) => Data (AnnDecl name)++instance (OutputableBndrId name) => Outputable (AnnDecl name) where+    ppr (HsAnnotation _ provenance expr)+      = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]++-- | Annotation Provenance+data AnnProvenance name = ValueAnnProvenance (Located name)+                        | TypeAnnProvenance (Located name)+                        | ModuleAnnProvenance+  deriving (Data, Functor)+deriving instance Foldable    AnnProvenance+deriving instance Traversable AnnProvenance++annProvenanceName_maybe :: AnnProvenance name -> Maybe name+annProvenanceName_maybe (ValueAnnProvenance (L _ name)) = Just name+annProvenanceName_maybe (TypeAnnProvenance (L _ name))  = Just name+annProvenanceName_maybe ModuleAnnProvenance       = Nothing++pprAnnProvenance :: OutputableBndr name => AnnProvenance name -> SDoc+pprAnnProvenance ModuleAnnProvenance       = text "ANN module"+pprAnnProvenance (ValueAnnProvenance (L _ name))+  = text "ANN" <+> ppr name+pprAnnProvenance (TypeAnnProvenance (L _ name))+  = text "ANN type" <+> ppr name++{-+************************************************************************+*                                                                      *+\subsection[RoleAnnot]{Role annotations}+*                                                                      *+************************************************************************+-}++-- | Located Role Annotation Declaration+type LRoleAnnotDecl name = Located (RoleAnnotDecl name)++-- See #8185 for more info about why role annotations are+-- top-level declarations+-- | Role Annotation Declaration+data RoleAnnotDecl name+  = RoleAnnotDecl (Located name)         -- type constructor+                  [Located (Maybe Role)] -- optional annotations+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',+      --           'ApiAnnotation.AnnRole'++      -- For details on above see note [Api annotations] in ApiAnnotation+  deriving Data++instance OutputableBndr name => Outputable (RoleAnnotDecl name) where+  ppr (RoleAnnotDecl ltycon roles)+    = text "type role" <+> ppr ltycon <+>+      hsep (map (pp_role . unLoc) roles)+    where+      pp_role Nothing  = underscore+      pp_role (Just r) = ppr r++roleAnnotDeclName :: RoleAnnotDecl name -> name+roleAnnotDeclName (RoleAnnotDecl (L _ name) _) = name
+ hsSyn/HsDoc.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE CPP, DeriveDataTypeable #-}++module HsDoc (+  HsDocString(..),+  LHsDocString,+  ppr_mbDoc+  ) where++#include "HsVersions.h"++import Outputable+import SrcLoc+import FastString++import Data.Data++-- | Haskell Documentation String+newtype HsDocString = HsDocString FastString+  deriving (Eq, Show, Data)++-- | Located Haskell Documentation String+type LHsDocString = Located HsDocString++instance Outputable HsDocString where+  ppr (HsDocString fs) = ftext fs++ppr_mbDoc :: Maybe LHsDocString -> SDoc+ppr_mbDoc (Just doc) = ppr doc+ppr_mbDoc Nothing    = empty+
+ hsSyn/HsDumpAst.hs view
@@ -0,0 +1,206 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Contains a debug function to dump parts of the hsSyn AST. It uses a syb+-- traversal which falls back to displaying based on the constructor name, so+-- can be used to dump anything having a @Data.Data@ instance.++module HsDumpAst (+        -- * Dumping ASTs+        showAstData,+        BlankSrcSpan(..),+    ) where++import Data.Data hiding (Fixity)+import Data.List+import Bag+import BasicTypes+import FastString+import NameSet+import Name+import RdrName+import DataCon+import SrcLoc+import HsSyn+import OccName hiding (occName)+import Var+import Module+import DynFlags+import Outputable hiding (space)++import qualified Data.ByteString as B++data BlankSrcSpan = BlankSrcSpan | NoBlankSrcSpan+                  deriving (Eq,Show)++-- | Show a GHC syntax tree. This parameterised because it is also used for+-- comparing ASTs in ppr roundtripping tests, where the SrcSpan's are blanked+-- out, to avoid comparing locations, only structure+showAstData :: Data a => BlankSrcSpan -> a -> String+showAstData b = showAstData' 0+  where+    showAstData' :: Data a => Int -> a -> String+    showAstData' n =+      generic+              `ext1Q` list+              `extQ` string `extQ` fastString `extQ` srcSpan `extQ` lit+              `extQ` bytestring+              `extQ` name `extQ` occName `extQ` moduleName `extQ` var+              `extQ` dataCon+              `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet+              `extQ` fixity+              `ext2Q` located+      where generic :: Data a => a -> String+            generic t = indent n ++ "(" ++ showConstr (toConstr t)+                     ++ space (unwords (gmapQ (showAstData' (n+1)) t)) ++ ")"++            space "" = ""+            space s  = ' ':s++            indent i = "\n" ++ replicate i ' '++            string :: String -> String+            string     = normalize_newlines . show++            fastString :: FastString -> String+            fastString = ("{FastString: "++) . (++"}") . normalize_newlines+                       . show++            bytestring :: B.ByteString -> String+            bytestring = normalize_newlines . show++            list l     = indent n ++ "["+                                ++ intercalate "," (map (showAstData' (n+1)) l)+                                ++ "]"++            -- Eliminate word-size dependence+            lit :: HsLit -> String+            lit (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s+            lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s+            lit (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s+            lit (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s+            lit l                  = generic l++            numericLit :: String -> Integer -> SourceText -> String+            numericLit tag x s = indent n ++ unwords [ "{" ++ tag+                                                     , generic x+                                                     , generic s ++ "}" ]++            name :: Name -> String+            name       = ("{Name: "++) . (++"}") . showSDocDebug_ . ppr++            occName    = ("{OccName: "++) . (++"}") .  OccName.occNameString++            moduleName :: ModuleName -> String+            moduleName = ("{ModuleName: "++) . (++"}") . showSDoc_ . ppr++            srcSpan :: SrcSpan -> String+            srcSpan ss = case b of+             BlankSrcSpan -> "{ "++ "ss" ++"}"+             NoBlankSrcSpan ->+                             "{ "++ showSDoc_ (hang (ppr ss) (n+2)+                                              -- TODO: show annotations here+                                                    (text "")+                                              )+                          ++"}"++            var  :: Var -> String+            var        = ("{Var: "++) . (++"}") . showSDocDebug_ . ppr++            dataCon :: DataCon -> String+            dataCon    = ("{DataCon: "++) . (++"}") . showSDoc_ . ppr++            bagRdrName:: Bag (Located (HsBind RdrName)) -> String+            bagRdrName = ("{Bag(Located (HsBind RdrName)): "++) . (++"}")+                          . list . bagToList++            bagName   :: Bag (Located (HsBind Name)) -> String+            bagName    = ("{Bag(Located (HsBind Name)): "++) . (++"}")+                           . list . bagToList++            bagVar    :: Bag (Located (HsBind Var)) -> String+            bagVar     = ("{Bag(Located (HsBind Var)): "++) . (++"}")+                           . list . bagToList++            nameSet = ("{NameSet: "++) . (++"}") . list . nameSetElemsStable++            fixity :: Fixity -> String+            fixity = ("{Fixity: "++) . (++"}") . showSDoc_ . ppr++            located :: (Data b,Data loc) => GenLocated loc b -> String+            located (L ss a) =+              indent n ++ "("+                ++ case cast ss of+                        Just (s :: SrcSpan) ->+                          srcSpan s+                        Nothing -> "nnnnnnnn"+                      ++ showAstData' (n+1) a+                      ++ ")"++normalize_newlines :: String -> String+normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs+normalize_newlines (x:xs)                 = x:normalize_newlines xs+normalize_newlines []                     = []++showSDoc_ :: SDoc -> String+showSDoc_ = normalize_newlines . showSDoc unsafeGlobalDynFlags++showSDocDebug_ :: SDoc -> String+showSDocDebug_ = normalize_newlines . showSDocDebug unsafeGlobalDynFlags++{-+************************************************************************+*                                                                      *+* Copied from syb+*                                                                      *+************************************************************************+-}+++-- | The type constructor for queries+newtype Q q x = Q { unQ :: x -> q }++-- | Extend a generic query by a type-specific case+extQ :: ( Typeable a+        , Typeable b+        )+     => (a -> q)+     -> (b -> q)+     -> a+     -> q+extQ f g a = maybe (f a) g (cast a)++-- | Type extension of queries for type constructors+ext1Q :: (Data d, Typeable t)+      => (d -> q)+      -> (forall e. Data e => t e -> q)+      -> d -> q+ext1Q def ext = unQ ((Q def) `ext1` (Q ext))+++-- | Type extension of queries for type constructors+ext2Q :: (Data d, Typeable t)+      => (d -> q)+      -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)+      -> d -> q+ext2Q def ext = unQ ((Q def) `ext2` (Q ext))++-- | Flexible type extension+ext1 :: (Data a, Typeable t)+     => c a+     -> (forall d. Data d => c (t d))+     -> c a+ext1 def ext = maybe def id (dataCast1 ext)++++-- | Flexible type extension+ext2 :: (Data a, Typeable t)+     => c a+     -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))+     -> c a+ext2 def ext = maybe def id (dataCast2 ext)
+ hsSyn/HsExpr.hs view
@@ -0,0 +1,2556 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]+                                      -- in module PlaceHolder+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE DeriveFunctor #-}++-- | Abstract Haskell syntax for expressions.+module HsExpr where++#include "HsVersions.h"++-- friends:+import HsDecls+import HsPat+import HsLit+import PlaceHolder ( PostTc,PostRn,DataId,DataIdPost,+                     NameOrRdrName,OutputableBndrId )+import HsTypes+import HsBinds++-- others:+import TcEvidence+import CoreSyn+import Var+import DynFlags ( gopt, GeneralFlag(Opt_PrintExplicitCoercions) )+import Name+import NameSet+import RdrName  ( GlobalRdrEnv )+import BasicTypes+import ConLike+import SrcLoc+import Util+import Outputable+import FastString+import Type++-- libraries:+import Data.Data hiding (Fixity(..))+import qualified Data.Data as Data (Fixity(..))+import Data.Maybe (isNothing)++import GHCi.RemoteTypes ( ForeignRef )+import qualified Language.Haskell.TH as TH (Q)++{-+************************************************************************+*                                                                      *+\subsection{Expressions proper}+*                                                                      *+************************************************************************+-}++-- * Expressions proper++-- | Located Haskell Expression+type LHsExpr id = Located (HsExpr id)+  -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when+  --   in a list++  -- For details on above see note [Api annotations] in ApiAnnotation++-------------------------+-- | Post-Type checking Expression+--+-- PostTcExpr is an evidence expression attached to the syntax tree by the+-- type checker (c.f. postTcType).+type PostTcExpr  = HsExpr Id++-- | Post-Type checking Table+--+-- We use a PostTcTable where there are a bunch of pieces of evidence, more+-- than is convenient to keep individually.+type PostTcTable = [(Name, PostTcExpr)]++noPostTcExpr :: PostTcExpr+noPostTcExpr = HsLit (HsString NoSourceText (fsLit "noPostTcExpr"))++noPostTcTable :: PostTcTable+noPostTcTable = []++-------------------------+-- | Syntax Expression+--+-- SyntaxExpr is like 'PostTcExpr', but it's filled in a little earlier,+-- by the renamer.  It's used for rebindable syntax.+--+-- E.g. @(>>=)@ is filled in before the renamer by the appropriate 'Name' for+--      @(>>=)@, and then instantiated by the type checker with its type args+--      etc+--+-- This should desugar to+--+-- > syn_res_wrap $ syn_expr (syn_arg_wraps[0] arg0)+-- >                         (syn_arg_wraps[1] arg1) ...+--+-- where the actual arguments come from elsewhere in the AST.+-- This could be defined using @PostRn@ and @PostTc@ and such, but it's+-- harder to get it all to work out that way. ('noSyntaxExpr' is hard to+-- write, for example.)+data SyntaxExpr id = SyntaxExpr { syn_expr      :: HsExpr id+                                , syn_arg_wraps :: [HsWrapper]+                                , syn_res_wrap  :: HsWrapper }+deriving instance (DataId id) => Data (SyntaxExpr id)++-- | This is used for rebindable-syntax pieces that are too polymorphic+-- for tcSyntaxOp (trS_fmap and the mzip in ParStmt)+noExpr :: HsExpr id+noExpr = HsLit (HsString (SourceText  "noExpr") (fsLit "noExpr"))++noSyntaxExpr :: SyntaxExpr id -- Before renaming, and sometimes after,+                              -- (if the syntax slot makes no sense)+noSyntaxExpr = SyntaxExpr { syn_expr      = HsLit (HsString NoSourceText+                                                        (fsLit "noSyntaxExpr"))+                          , syn_arg_wraps = []+                          , syn_res_wrap  = WpHole }++-- | Make a 'SyntaxExpr Name' (the "rn" is because this is used in the+-- renamer), missing its HsWrappers.+mkRnSyntaxExpr :: Name -> SyntaxExpr Name+mkRnSyntaxExpr name = SyntaxExpr { syn_expr      = HsVar $ noLoc name+                                 , syn_arg_wraps = []+                                 , syn_res_wrap  = WpHole }+  -- don't care about filling in syn_arg_wraps because we're clearly+  -- not past the typechecker++instance (OutputableBndrId id) => Outputable (SyntaxExpr id) where+  ppr (SyntaxExpr { syn_expr      = expr+                  , syn_arg_wraps = arg_wraps+                  , syn_res_wrap  = res_wrap })+    = sdocWithDynFlags $ \ dflags ->+      getPprStyle $ \s ->+      if debugStyle s || gopt Opt_PrintExplicitCoercions dflags+      then ppr expr <> braces (pprWithCommas ppr arg_wraps)+                    <> braces (ppr res_wrap)+      else ppr expr++-- | Command Syntax Table (for Arrow syntax)+type CmdSyntaxTable id = [(Name, HsExpr id)]+-- See Note [CmdSyntaxTable]++{-+Note [CmdSyntaxtable]+~~~~~~~~~~~~~~~~~~~~~+Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps+track of the methods needed for a Cmd.++* Before the renamer, this list is an empty list++* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@+  For example, for the 'arr' method+   * normal case:            (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr)+   * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22)+             where @arr_22@ is whatever 'arr' is in scope++* After the type checker, it takes the form [(std_name, <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 RnExpr.methodNamesCmd.++  * The desugarer has to know the polymorphic type of the instantiated+    method. This is checked by Inst.tcSyntaxName, but is less flexible+    than the rest of rebindable syntax, where the type is less+    pre-ordained.  (And this flexibility is useful; for example we can+    typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.)+-}++-- | An unbound variable; used for treating out-of-scope variables as+-- expression holes+data UnboundVar+  = OutOfScope OccName GlobalRdrEnv  -- ^ An (unqualified) out-of-scope+                                     -- variable, together with the GlobalRdrEnv+                                     -- with respect to which it is unbound++                                     -- See Note [OutOfScope and GlobalRdrEnv]++  | TrueExprHole OccName             -- ^ A "true" expression hole (_ or _x)++  deriving Data++instance Outputable UnboundVar where+    ppr = ppr . unboundVarOcc++unboundVarOcc :: UnboundVar -> OccName+unboundVarOcc (OutOfScope occ _) = occ+unboundVarOcc (TrueExprHole occ) = occ++{-+Note [OutOfScope and GlobalRdrEnv]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To understand why we bundle a GlobalRdrEnv with an out-of-scope variable,+consider the following module:++    module A where++    foo :: ()+    foo = bar++    bat :: [Double]+    bat = [1.2, 3.4]++    $(return [])++    bar = ()+    bad = False++When A is compiled, the renamer determines that `bar` is not in scope in the+declaration of `foo` (since `bar` is declared in the following inter-splice+group).  Once it has finished typechecking the entire module, the typechecker+then generates the associated error message, which specifies both the type of+`bar` and a list of possible in-scope alternatives:++    A.hs:6:7: error:+        • Variable not in scope: bar :: ()+        • ‘bar’ (line 13) is not in scope before the splice on line 11+          Perhaps you meant ‘bat’ (line 9)++When it calls RnEnv.unknownNameSuggestions to identify these alternatives, the+typechecker must provide a GlobalRdrEnv.  If it provided the current one, which+contains top-level declarations for the entire module, the error message would+incorrectly suggest the out-of-scope `bar` and `bad` as possible alternatives+for `bar` (see Trac #11680).  Instead, the typechecker must use the same+GlobalRdrEnv the renamer used when it determined that `bar` is out-of-scope.++To obtain this GlobalRdrEnv, can the typechecker simply use the out-of-scope+`bar`'s location to either reconstruct it (from the current GlobalRdrEnv) or to+look it up in some global store?  Unfortunately, no.  The problem is that+location information is not always sufficient for this task.  This is most+apparent when dealing with the TH function addTopDecls, which adds its+declarations to the FOLLOWING inter-splice group.  Consider these declarations:++    ex9 = cat               -- cat is NOT in scope here++    $(do -------------------------------------------------------------+        ds <- [d| f = cab   -- cat and cap are both in scope here+                  cat = ()+                |]+        addTopDecls ds+        [d| g = cab         -- only cap is in scope here+            cap = True+          |])++    ex10 = cat              -- cat is NOT in scope here++    $(return []) -----------------------------------------------------++    ex11 = cat              -- cat is in scope++Here, both occurrences of `cab` are out-of-scope, and so the typechecker needs+the GlobalRdrEnvs which were used when they were renamed.  These GlobalRdrEnvs+are different (`cat` is present only in the GlobalRdrEnv for f's `cab'), but the+locations of the two `cab`s are the same (they are both created in the same+splice).  Thus, we must include some additional information with each `cab` to+allow the typechecker to obtain the correct GlobalRdrEnv.  Clearly, the simplest+information to use is the GlobalRdrEnv itself.+-}++-- | A Haskell expression.+data HsExpr id+  = HsVar     (Located id)   -- ^ Variable++                             -- See Note [Located RdrNames]++  | HsUnboundVar UnboundVar  -- ^ Unbound variable; also used for "holes"+                             --   (_ or _x).+                             -- Turned from HsVar to HsUnboundVar by the+                             --   renamer, when it finds an out-of-scope+                             --   variable or hole.+                             -- Turned into HsVar by type checker, to support+                             --   deferred type errors.++  | HsConLikeOut ConLike     -- ^ After typechecker only; must be different+                             -- HsVar for pretty printing++  | HsRecFld (AmbiguousFieldOcc id) -- ^ Variable pointing to record selector+                                    -- Not in use after typechecking++  | HsOverLabel (Maybe id) FastString+     -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels)+     --   @Just id@ means @RebindableSyntax@ is in use, and gives the id of the+     --   in-scope 'fromLabel'.+     --   NB: Not in use after typechecking++  | HsIPVar   HsIPName       -- ^ Implicit parameter (not in use after typechecking)+  | HsOverLit (HsOverLit id) -- ^ Overloaded literals++  | HsLit     HsLit          -- ^ Simple (non-overloaded) literals++  | HsLam     (MatchGroup id (LHsExpr id)) -- ^ Lambda abstraction. Currently always a single match+       --+       -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',+       --       'ApiAnnotation.AnnRarrow',++       -- For details on above see note [Api annotations] in ApiAnnotation++  | HsLamCase (MatchGroup id (LHsExpr id)) -- ^ Lambda-case+       --+       -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',+       --           'ApiAnnotation.AnnCase','ApiAnnotation.AnnOpen',+       --           'ApiAnnotation.AnnClose'++       -- For details on above see note [Api annotations] in ApiAnnotation++  | HsApp     (LHsExpr id) (LHsExpr id) -- ^ Application++  | HsAppType (LHsExpr id) (LHsWcType id) -- ^ Visible type application+       --+       -- Explicit type argument; e.g  f @Int x y+       -- NB: Has wildcards, but no implicit quantification+       --+       -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt',++  | HsAppTypeOut (LHsExpr id) (LHsWcType Name) -- just for pretty-printing+++  -- | Operator applications:+  -- NB Bracketed ops such as (+) come out as Vars.++  -- NB We need an expr for the operator in an OpApp/Section since+  -- the typechecker may need to apply the operator to a few types.++  | OpApp       (LHsExpr id)    -- left operand+                (LHsExpr id)    -- operator+                (PostRn id Fixity) -- Renamer adds fixity; bottom until then+                (LHsExpr id)    -- right operand++  -- | Negation operator. Contains the negated expression and the name+  -- of 'negate'+  --+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnMinus'++  -- For details on above see note [Api annotations] in ApiAnnotation+  | NegApp      (LHsExpr id)+                (SyntaxExpr id)++  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,+  --             'ApiAnnotation.AnnClose' @')'@++  -- For details on above see note [Api annotations] in ApiAnnotation+  | HsPar       (LHsExpr id)    -- ^ Parenthesised expr; see Note [Parens in HsSyn]++  | SectionL    (LHsExpr id)    -- operand; see Note [Sections in HsSyn]+                (LHsExpr id)    -- operator+  | SectionR    (LHsExpr id)    -- operator; see Note [Sections in HsSyn]+                (LHsExpr id)    -- operand++  -- | Used for explicit tuples and sections thereof+  --+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',+  --         'ApiAnnotation.AnnClose'++  -- For details on above see note [Api annotations] in ApiAnnotation+  | ExplicitTuple+        [LHsTupArg id]+        Boxity++  -- | Used for unboxed sum types+  --+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(#'@,+  --          'ApiAnnotation.AnnVbar', 'ApiAnnotation.AnnClose' @'#)'@,+  --+  --  There will be multiple 'ApiAnnotation.AnnVbar', (1 - alternative) before+  --  the expression, (arity - alternative) after it+  | ExplicitSum+          ConTag --  Alternative (one-based)+          Arity  --  Sum arity+          (LHsExpr id)+          (PostTc id [Type])   -- the type arguments++  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase',+  --       'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@,+  --       'ApiAnnotation.AnnClose' @'}'@++  -- For details on above see note [Api annotations] in ApiAnnotation+  | HsCase      (LHsExpr id)+                (MatchGroup id (LHsExpr id))++  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf',+  --       'ApiAnnotation.AnnSemi',+  --       'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi',+  --       'ApiAnnotation.AnnElse',++  -- For details on above see note [Api annotations] in ApiAnnotation+  | HsIf        (Maybe (SyntaxExpr id)) -- cond function+                                        -- Nothing => use the built-in 'if'+                                        -- See Note [Rebindable if]+                (LHsExpr id)    --  predicate+                (LHsExpr id)    --  then part+                (LHsExpr id)    --  else part++  -- | Multi-way if+  --+  -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf'+  --       'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',++  -- For details on above see note [Api annotations] in ApiAnnotation+  | HsMultiIf   (PostTc id Type) [LGRHS id (LHsExpr id)]++  -- | let(rec)+  --+  -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet',+  --       'ApiAnnotation.AnnOpen' @'{'@,+  --       'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn'++  -- For details on above see note [Api annotations] in ApiAnnotation+  | HsLet       (LHsLocalBinds id)+                (LHsExpr  id)++  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo',+  --             'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi',+  --             'ApiAnnotation.AnnVbar',+  --             'ApiAnnotation.AnnClose'++  -- For details on above see note [Api annotations] in ApiAnnotation+  | HsDo        (HsStmtContext Name)     -- The parameterisation is unimportant+                                         -- because in this context we never use+                                         -- the PatGuard or ParStmt variant+                (Located [ExprLStmt id]) -- "do":one or more stmts+                (PostTc id Type)         -- Type of the whole expression++  -- | Syntactic list: [a,b,c,...]+  --+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,+  --              'ApiAnnotation.AnnClose' @']'@++  -- For details on above see note [Api annotations] in ApiAnnotation+  | ExplicitList+                (PostTc id Type)        -- Gives type of components of list+                (Maybe (SyntaxExpr id)) -- For OverloadedLists, the fromListN witness+                [LHsExpr id]++  -- | Syntactic parallel array: [:e1, ..., en:]+  --+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,+  --              'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnComma',+  --              'ApiAnnotation.AnnVbar'+  --              'ApiAnnotation.AnnClose' @':]'@++  -- For details on above see note [Api annotations] in ApiAnnotation+  | ExplicitPArr+                (PostTc id Type)   -- type of elements of the parallel array+                [LHsExpr id]++  -- | Record construction+  --+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@,+  --         'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@++  -- For details on above see note [Api annotations] in ApiAnnotation+  | RecordCon+      { rcon_con_name :: Located id         -- The constructor name;+                                            --  not used after type checking+      , rcon_con_like :: PostTc id ConLike  -- The data constructor or pattern synonym+      , rcon_con_expr :: PostTcExpr         -- Instantiated constructor function+      , rcon_flds     :: HsRecordBinds id } -- The fields++  -- | Record update+  --+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@,+  --         'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@++  -- For details on above see note [Api annotations] in ApiAnnotation+  | RecordUpd+      { rupd_expr :: LHsExpr id+      , rupd_flds :: [LHsRecUpdField id]+      , rupd_cons :: PostTc id [ConLike]+                -- Filled in by the type checker to the+                -- _non-empty_ list of DataCons that have+                -- all the upd'd fields++      , rupd_in_tys  :: PostTc id [Type]  -- Argument types of *input* record type+      , rupd_out_tys :: PostTc id [Type]  --              and  *output* record type+                                          -- The original type can be reconstructed+                                          -- with conLikeResTy+      , rupd_wrap :: PostTc id HsWrapper  -- See note [Record Update HsWrapper]+      }+  -- For a type family, the arg types are of the *instance* tycon,+  -- not the family tycon++  -- | Expression with an explicit type signature. @e :: type@+  --+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'++  -- For details on above see note [Api annotations] in ApiAnnotation+  | ExprWithTySig+                (LHsExpr id)+                (LHsSigWcType id)++  | ExprWithTySigOut              -- Post typechecking+                (LHsExpr id)+                (LHsSigWcType Name)  -- Retain the signature,+                                     -- as HsSigType Name, for+                                     -- round-tripping purposes++  -- | Arithmetic sequence+  --+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,+  --              'ApiAnnotation.AnnComma','ApiAnnotation.AnnDotdot',+  --              'ApiAnnotation.AnnClose' @']'@++  -- For details on above see note [Api annotations] in ApiAnnotation+  | ArithSeq+                PostTcExpr+                (Maybe (SyntaxExpr id))   -- For OverloadedLists, the fromList witness+                (ArithSeqInfo id)++  -- | Arithmetic sequence for parallel array+  --+  -- > [:e1..e2:] or [:e1, e2..e3:]+  --+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,+  --              'ApiAnnotation.AnnComma','ApiAnnotation.AnnDotdot',+  --              'ApiAnnotation.AnnVbar',+  --              'ApiAnnotation.AnnClose' @':]'@++  -- For details on above see note [Api annotations] in ApiAnnotation+  | PArrSeq+                PostTcExpr+                (ArithSeqInfo id)++  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# SCC'@,+  --             'ApiAnnotation.AnnVal' or 'ApiAnnotation.AnnValStr',+  --              'ApiAnnotation.AnnClose' @'\#-}'@++  -- For details on above see note [Api annotations] in ApiAnnotation+  | HsSCC       SourceText            -- Note [Pragma source text] in BasicTypes+                StringLiteral         -- "set cost centre" SCC pragma+                (LHsExpr id)          -- expr whose cost is to be measured++  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CORE'@,+  --             'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@++  -- For details on above see note [Api annotations] in ApiAnnotation+  | HsCoreAnn   SourceText            -- Note [Pragma source text] in BasicTypes+                StringLiteral         -- hdaume: core annotation+                (LHsExpr id)++  -----------------------------------------------------------+  -- MetaHaskell Extensions++  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',+  --         'ApiAnnotation.AnnOpenE','ApiAnnotation.AnnOpenEQ',+  --         'ApiAnnotation.AnnClose','ApiAnnotation.AnnCloseQ'++  -- For details on above see note [Api annotations] in ApiAnnotation+  | HsBracket    (HsBracket id)++    -- See Note [Pending Splices]+  | HsRnBracketOut+      (HsBracket Name)     -- Output of the renamer is the *original* renamed+                           -- expression, plus+      [PendingRnSplice]    -- _renamed_ splices to be type checked++  | HsTcBracketOut+      (HsBracket Name)     -- Output of the type checker is the *original*+                           -- renamed expression, plus+      [PendingTcSplice]    -- _typechecked_ splices to be+                           -- pasted back in by the desugarer++  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',+  --         'ApiAnnotation.AnnClose'++  -- For details on above see note [Api annotations] in ApiAnnotation+  | HsSpliceE  (HsSplice id)++  -----------------------------------------------------------+  -- Arrow notation extension++  -- | @proc@ notation for Arrows+  --+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnProc',+  --          'ApiAnnotation.AnnRarrow'++  -- For details on above see note [Api annotations] in ApiAnnotation+  | HsProc      (LPat id)               -- arrow abstraction, proc+                (LHsCmdTop id)          -- body of the abstraction+                                        -- always has an empty stack++  ---------------------------------------+  -- static pointers extension+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnStatic',++  -- For details on above see note [Api annotations] in ApiAnnotation+  | HsStatic (PostRn id NameSet) -- Free variables of the body+             (LHsExpr id)        -- Body++  ---------------------------------------+  -- The following are commands, not expressions proper+  -- They are only used in the parsing stage and are removed+  --    immediately in parser.RdrHsSyn.checkCommand++  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.Annlarrowtail',+  --          'ApiAnnotation.Annrarrowtail','ApiAnnotation.AnnLarrowtail',+  --          'ApiAnnotation.AnnRarrowtail'++  -- For details on above see note [Api annotations] in ApiAnnotation+  | HsArrApp             -- Arrow tail, or arrow application (f -< arg)+        (LHsExpr id)     -- arrow expression, f+        (LHsExpr id)     -- input expression, arg+        (PostTc id Type) -- type of the arrow expressions f,+                         -- of the form a t t', where arg :: t+        HsArrAppType     -- higher-order (-<<) or first-order (-<)+        Bool             -- True => right-to-left (f -< arg)+                         -- False => left-to-right (arg >- f)++  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpenB' @'(|'@,+  --         'ApiAnnotation.AnnCloseB' @'|)'@++  -- For details on above see note [Api annotations] in ApiAnnotation+  | HsArrForm            -- Command formation,  (| e cmd1 .. cmdn |)+        (LHsExpr id)     -- the operator+                         -- after type-checking, a type abstraction to be+                         -- applied to the type of the local environment tuple+        (Maybe Fixity)   -- fixity (filled in by the renamer), for forms that+                         -- were converted from OpApp's by the renamer+        [LHsCmdTop id]   -- argument commands++  ---------------------------------------+  -- Haskell program coverage (Hpc) Support++  | HsTick+     (Tickish id)+     (LHsExpr id)                       -- sub-expression++  | HsBinTick+     Int                                -- module-local tick number for True+     Int                                -- module-local tick number for False+     (LHsExpr id)                       -- sub-expression++  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',+  --       'ApiAnnotation.AnnOpen' @'{-\# GENERATED'@,+  --       'ApiAnnotation.AnnVal','ApiAnnotation.AnnVal',+  --       'ApiAnnotation.AnnColon','ApiAnnotation.AnnVal',+  --       'ApiAnnotation.AnnMinus',+  --       'ApiAnnotation.AnnVal','ApiAnnotation.AnnColon',+  --       'ApiAnnotation.AnnVal',+  --       'ApiAnnotation.AnnClose' @'\#-}'@++  -- For details on above see note [Api annotations] in ApiAnnotation+  | HsTickPragma                      -- A pragma introduced tick+     SourceText                       -- Note [Pragma source text] in BasicTypes+     (StringLiteral,(Int,Int),(Int,Int))+                                      -- external span for this tick+     ((SourceText,SourceText),(SourceText,SourceText))+        -- Source text for the four integers used in the span.+        -- See note [Pragma source text] in BasicTypes+     (LHsExpr id)++  ---------------------------------------+  -- These constructors only appear temporarily in the parser.+  -- The renamer translates them into the Right Thing.++  | EWildPat                 -- wildcard++  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'++  -- For details on above see note [Api annotations] in ApiAnnotation+  | EAsPat      (Located id) -- as pattern+                (LHsExpr id)++  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'++  -- For details on above see note [Api annotations] in ApiAnnotation+  | EViewPat    (LHsExpr id) -- view pattern+                (LHsExpr id)++  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'++  -- For details on above see note [Api annotations] in ApiAnnotation+  | ELazyPat    (LHsExpr id) -- ~ pattern+++  ---------------------------------------+  -- Finally, HsWrap appears only in typechecker output++  |  HsWrap     HsWrapper    -- TRANSLATION+                (HsExpr id)++deriving instance (DataId id) => Data (HsExpr id)++-- | Located Haskell Tuple Argument+--+-- 'HsTupArg' is used for tuple sections+-- @(,a,)@ is represented by+-- @ExplicitTuple [Missing ty1, Present a, Missing ty3]@+-- Which in turn stands for @(\x:ty1 \y:ty2. (x,a,y))@+type LHsTupArg id = Located (HsTupArg id)+-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma'++-- For details on above see note [Api annotations] in ApiAnnotation++-- | Haskell Tuple Argument+data HsTupArg id+  = Present (LHsExpr id)     -- ^ The argument+  | Missing (PostTc id Type) -- ^ The argument is missing, but this is its type+deriving instance (DataId id) => Data (HsTupArg id)++tupArgPresent :: LHsTupArg id -> Bool+tupArgPresent (L _ (Present {})) = True+tupArgPresent (L _ (Missing {})) = False++{-+Note [Parens in HsSyn]+~~~~~~~~~~~~~~~~~~~~~~+HsPar (and ParPat in patterns, HsParTy in types) is used as follows++  * HsPar is required; the pretty printer does not add parens.++  * HsPars are respected when rearranging operator fixities.+    So   a * (b + c)  means what it says (where the parens are an HsPar)++  * For ParPat and HsParTy the pretty printer does add parens but this should be+    a no-op for ParsedSource, based on the pretty printer round trip feature+    introduced in+    https://phabricator.haskell.org/rGHC499e43824bda967546ebf95ee33ec1f84a114a7c++  * ParPat and HsParTy are pretty printed as '( .. )' regardless of whether or+    not they are strictly necssary. This should be addressed when #13238 is+    completed, to be treated the same as HsPar.+++Note [Sections in HsSyn]+~~~~~~~~~~~~~~~~~~~~~~~~+Sections should always appear wrapped in an HsPar, thus+         HsPar (SectionR ...)+The parser parses sections in a wider variety of situations+(See Note [Parsing sections]), but the renamer checks for those+parens.  This invariant makes pretty-printing easier; we don't need+a special case for adding the parens round sections.++Note [Rebindable if]+~~~~~~~~~~~~~~~~~~~~+The rebindable syntax for 'if' is a bit special, because when+rebindable syntax is *off* we do not want to treat+   (if c then t else e)+as if it was an application (ifThenElse c t e).  Why not?+Because we allow an 'if' to return *unboxed* results, thus+  if blah then 3# else 4#+whereas that would not be possible using a all to a polymorphic function+(because you can't call a polymorphic function at an unboxed type).++So we use Nothing to mean "use the old built-in typing rule".++Note [Record Update HsWrapper]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There is a wrapper in RecordUpd which is used for the *required*+constraints for pattern synonyms. This wrapper is created in the+typechecking and is then directly used in the desugaring without+modification.++For example, if we have the record pattern synonym P,+  pattern P :: (Show a) => a -> Maybe a+  pattern P{x} = Just x++  foo = (Just True) { x = False }+then `foo` desugars to something like+  foo = case Just True of+          P x -> P False+hence we need to provide the correct dictionaries to P's matcher on+the RHS so that we can build the expression.++Note [Located RdrNames]+~~~~~~~~~~~~~~~~~~~~~~~+A number of syntax elements have seemingly redundant locations attached to them.+This is deliberate, to allow transformations making use of the API Annotations+to easily correlate a Located Name in the RenamedSource with a Located RdrName+in the ParsedSource.++There are unfortunately enough differences between the ParsedSource and the+RenamedSource that the API Annotations cannot be used directly with+RenamedSource, so this allows a simple mapping to be used based on the location.+-}++instance (OutputableBndrId id) => Outputable (HsExpr id) where+    ppr expr = pprExpr expr++-----------------------+-- pprExpr, pprLExpr, pprBinds call pprDeeper;+-- the underscore versions do not+pprLExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc+pprLExpr (L _ e) = pprExpr e++pprExpr :: (OutputableBndrId id) => HsExpr id -> SDoc+pprExpr e | isAtomicHsExpr e || isQuietHsExpr e =            ppr_expr e+          | otherwise                           = pprDeeper (ppr_expr e)++isQuietHsExpr :: HsExpr id -> Bool+-- Parentheses do display something, but it gives little info and+-- if we go deeper when we go inside them then we get ugly things+-- like (...)+isQuietHsExpr (HsPar _)          = True+-- applications don't display anything themselves+isQuietHsExpr (HsApp _ _)        = True+isQuietHsExpr (HsAppType _ _)    = True+isQuietHsExpr (HsAppTypeOut _ _) = True+isQuietHsExpr (OpApp _ _ _ _)    = True+isQuietHsExpr _ = False++pprBinds :: (OutputableBndrId idL, OutputableBndrId idR)+         => HsLocalBindsLR idL idR -> SDoc+pprBinds b = pprDeeper (ppr b)++-----------------------+ppr_lexpr :: (OutputableBndrId id) => LHsExpr id -> SDoc+ppr_lexpr e = ppr_expr (unLoc e)++ppr_expr :: forall id. (OutputableBndrId id) => HsExpr id -> SDoc+ppr_expr (HsVar (L _ v))  = pprPrefixOcc v+ppr_expr (HsUnboundVar uv)= pprPrefixOcc (unboundVarOcc uv)+ppr_expr (HsConLikeOut c) = pprPrefixOcc c+ppr_expr (HsIPVar v)      = ppr v+ppr_expr (HsOverLabel _ l)= char '#' <> ppr l+ppr_expr (HsLit lit)      = ppr lit+ppr_expr (HsOverLit lit)  = ppr lit+ppr_expr (HsPar e)        = parens (ppr_lexpr e)++ppr_expr (HsCoreAnn stc (StringLiteral sta s) e)+  = vcat [pprWithSourceText stc (text "{-# CORE")+          <+> pprWithSourceText sta (doubleQuotes $ ftext s) <+> text "#-}"+         , ppr_lexpr e]++ppr_expr e@(HsApp {})        = ppr_apps e []+ppr_expr e@(HsAppType {})    = ppr_apps e []+ppr_expr e@(HsAppTypeOut {}) = ppr_apps e []++ppr_expr (OpApp e1 op _ e2)+  | Just pp_op <- should_print_infix (unLoc op)+  = pp_infixly pp_op+  | otherwise+  = pp_prefixly++  where+    should_print_infix (HsVar (L _ v)) = Just (pprInfixOcc v)+    should_print_infix (HsConLikeOut c)= Just (pprInfixOcc (conLikeName c))+    should_print_infix (HsRecFld f)    = Just (pprInfixOcc f)+    should_print_infix (HsUnboundVar h@TrueExprHole{})+                                       = Just (pprInfixOcc (unboundVarOcc h))+    should_print_infix EWildPat        = Just (text "`_`")+    should_print_infix (HsWrap _ e)    = should_print_infix e+    should_print_infix _               = Nothing++    pp_e1 = pprDebugParendExpr e1   -- In debug mode, add parens+    pp_e2 = pprDebugParendExpr e2   -- to make precedence clear++    pp_prefixly+      = hang (ppr op) 2 (sep [pp_e1, pp_e2])++    pp_infixly pp_op+      = hang pp_e1 2 (sep [pp_op, nest 2 pp_e2])++ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e++ppr_expr (SectionL expr op)+  = case unLoc op of+      HsVar (L _ v)  -> pp_infixly v+      HsConLikeOut c -> pp_infixly (conLikeName c)+      _              -> pp_prefixly+  where+    pp_expr = pprDebugParendExpr expr++    pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])+                       4 (hsep [pp_expr, text "x_ )"])+    pp_infixly v = (sep [pp_expr, pprInfixOcc v])++ppr_expr (SectionR op expr)+  = case unLoc op of+      HsVar (L _ v)  -> pp_infixly v+      HsConLikeOut c -> pp_infixly (conLikeName c)+      _              -> pp_prefixly+  where+    pp_expr = pprDebugParendExpr expr++    pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"])+                       4 (pp_expr <> rparen)+    pp_infixly v = sep [pprInfixOcc v, pp_expr]++ppr_expr (ExplicitTuple exprs boxity)+  = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs))+  where+    ppr_tup_args []               = []+    ppr_tup_args (Present e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es+    ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es++    punc (Present {} : _) = comma <> space+    punc (Missing {} : _) = comma+    punc []               = empty++ppr_expr (ExplicitSum alt arity expr _)+  = text "(#" <+> ppr_bars (alt - 1) <+> ppr expr <+> ppr_bars (arity - alt) <+> text "#)"+  where+    ppr_bars n = hsep (replicate n (char '|'))++ppr_expr (HsLam matches)+  = pprMatches matches++ppr_expr (HsLamCase matches)+  = sep [ sep [text "\\case"],+          nest 2 (pprMatches matches) ]++ppr_expr (HsCase expr matches@(MG { mg_alts = L _ [_] }))+  = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of {")],+          nest 2 (pprMatches matches) <+> char '}']+ppr_expr (HsCase expr matches)+  = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")],+          nest 2 (pprMatches matches) ]++ppr_expr (HsIf _ e1 e2 e3)+  = sep [hsep [text "if", nest 2 (ppr e1), ptext (sLit "then")],+         nest 4 (ppr e2),+         text "else",+         nest 4 (ppr e3)]++ppr_expr (HsMultiIf _ alts)+  = hang (text "if") 3  (vcat (map ppr_alt alts))+  where ppr_alt (L _ (GRHS guards expr)) =+          hang vbar 2 (ppr_one one_alt)+          where+            ppr_one [] = panic "ppr_exp HsMultiIf"+            ppr_one (h:t) = hang h 2 (sep t)+            one_alt = [ interpp'SP guards+                      , text "->" <+> pprDeeper (ppr expr) ]++-- special case: let ... in let ...+ppr_expr (HsLet (L _ binds) expr@(L _ (HsLet _ _)))+  = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]),+         ppr_lexpr expr]++ppr_expr (HsLet (L _ binds) expr)+  = sep [hang (text "let") 2 (pprBinds binds),+         hang (text "in")  2 (ppr expr)]++ppr_expr (HsDo do_or_list_comp (L _ stmts) _) = pprDo do_or_list_comp stmts++ppr_expr (ExplicitList _ _ exprs)+  = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))++ppr_expr (ExplicitPArr _ exprs)+  = paBrackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))++ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds })+  = hang (ppr con_id) 2 (ppr rbinds)++ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = rbinds })+  = hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))++ppr_expr (ExprWithTySig expr sig)+  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)+         4 (ppr sig)+ppr_expr (ExprWithTySigOut expr sig)+  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)+         4 (ppr sig)++ppr_expr (ArithSeq _ _ info) = brackets (ppr info)+ppr_expr (PArrSeq  _ info) = paBrackets (ppr info)++ppr_expr EWildPat       = char '_'+ppr_expr (ELazyPat e)   = char '~' <> ppr e+ppr_expr (EAsPat v e)   = ppr v <> char '@' <> ppr e+ppr_expr (EViewPat p e) = ppr p <+> text "->" <+> ppr e++ppr_expr (HsSCC st (StringLiteral stl lbl) expr)+  = sep [ pprWithSourceText st (text "{-# SCC")+         -- no doublequotes if stl empty, for the case where the SCC was written+         -- without quotes.+          <+> pprWithSourceText stl (ftext lbl) <+> text "#-}",+          ppr expr ]++ppr_expr (HsWrap co_fn e)+  = pprHsWrapper co_fn (\parens -> if parens then pprExpr e+                                             else pprExpr e)++ppr_expr (HsSpliceE s)         = pprSplice s+ppr_expr (HsBracket b)         = pprHsBracket b+ppr_expr (HsRnBracketOut e []) = ppr e+ppr_expr (HsRnBracketOut e ps) = ppr e $$ text "pending(rn)" <+> ppr ps+ppr_expr (HsTcBracketOut e []) = ppr e+ppr_expr (HsTcBracketOut e ps) = ppr e $$ text "pending(tc)" <+> ppr ps++ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))+  = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd]++ppr_expr (HsStatic _ e)+  = hsep [text "static", ppr e]++ppr_expr (HsTick tickish exp)+  = pprTicks (ppr exp) $+    ppr tickish <+> ppr_lexpr exp+ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)+  = pprTicks (ppr exp) $+    hcat [text "bintick<",+          ppr tickIdTrue,+          text ",",+          ppr tickIdFalse,+          text ">(",+          ppr exp, text ")"]+ppr_expr (HsTickPragma _ externalSrcLoc _ exp)+  = pprTicks (ppr exp) $+    hcat [text "tickpragma<",+          pprExternalSrcLoc externalSrcLoc,+          text ">(",+          ppr exp,+          text ")"]++ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True)+  = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]+ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False)+  = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]+ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True)+  = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]+ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False)+  = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]++ppr_expr (HsArrForm (L _ (HsVar (L _ v))) (Just _) [arg1, arg2])+  = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]]+ppr_expr (HsArrForm (L _ (HsConLikeOut c)) (Just _) [arg1, arg2])+  = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc (conLikeName c), pprCmdArg (unLoc arg2)]]+ppr_expr (HsArrForm op _ args)+  = hang (text "(|" <+> ppr_lexpr op)+         4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)")+ppr_expr (HsRecFld f) = ppr f++-- We must tiresomely make the "id" parameter to the LHsWcType existential+-- because it's different in the HsAppType case and the HsAppTypeOut case+-- | Located Haskell Wildcard Type Expression+data LHsWcTypeX = forall id. (OutputableBndrId id) => LHsWcTypeX (LHsWcType id)++ppr_apps :: (OutputableBndrId id) => HsExpr id+         -> [Either (LHsExpr id) LHsWcTypeX]+         -> SDoc+ppr_apps (HsApp (L _ fun) arg)        args+  = ppr_apps fun (Left arg : args)+ppr_apps (HsAppType (L _ fun) arg)    args+  = ppr_apps fun (Right (LHsWcTypeX arg) : args)+ppr_apps (HsAppTypeOut (L _ fun) arg) args+  = ppr_apps fun (Right (LHsWcTypeX arg) : args)+ppr_apps fun args = hang (ppr_expr fun) 2 (sep (map pp args))+  where+    pp (Left arg)                             = ppr arg+    pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg })))+      = char '@' <> pprParendHsType arg++pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc+pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4))+  = ppr (src,(n1,n2),(n3,n4))++{-+HsSyn records exactly where the user put parens, with HsPar.+So generally speaking we print without adding any parens.+However, some code is internally generated, and in some places+parens are absolutely required; so for these places we use+pprParendLExpr (but don't print double parens of course).++For operator applications we don't add parens, because the operator+fixities should do the job, except in debug mode (-dppr-debug) so we+can see the structure of the parse tree.+-}++pprDebugParendExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc+pprDebugParendExpr expr+  = getPprStyle (\sty ->+    if debugStyle sty then pprParendLExpr expr+                      else pprLExpr      expr)++pprParendLExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc+pprParendLExpr (L _ e) = pprParendExpr e++pprParendExpr :: (OutputableBndrId id) => HsExpr id -> SDoc+pprParendExpr expr+  | hsExprNeedsParens expr = parens (pprExpr expr)+  | otherwise              = pprExpr expr+        -- Using pprLExpr makes sure that we go 'deeper'+        -- I think that is usually (always?) right++hsExprNeedsParens :: HsExpr id -> Bool+-- True of expressions for which '(e)' and 'e'+-- mean the same thing+hsExprNeedsParens (ArithSeq {})       = False+hsExprNeedsParens (PArrSeq {})        = False+hsExprNeedsParens (HsLit {})          = False+hsExprNeedsParens (HsOverLit {})      = False+hsExprNeedsParens (HsVar {})          = False+hsExprNeedsParens (HsUnboundVar {})   = False+hsExprNeedsParens (HsConLikeOut {})   = False+hsExprNeedsParens (HsIPVar {})        = False+hsExprNeedsParens (HsOverLabel {})    = False+hsExprNeedsParens (ExplicitTuple {})  = False+hsExprNeedsParens (ExplicitList {})   = False+hsExprNeedsParens (ExplicitPArr {})   = False+hsExprNeedsParens (HsPar {})          = False+hsExprNeedsParens (HsBracket {})      = False+hsExprNeedsParens (HsRnBracketOut {}) = False+hsExprNeedsParens (HsTcBracketOut {}) = False+hsExprNeedsParens (HsDo sc _ _)+       | isListCompExpr sc            = False+hsExprNeedsParens (HsRecFld{})        = False+hsExprNeedsParens (RecordCon{})       = False+hsExprNeedsParens (HsSpliceE{})       = False+hsExprNeedsParens (RecordUpd{})       = False+hsExprNeedsParens (HsWrap _ e)        = hsExprNeedsParens e+hsExprNeedsParens _ = True+++isAtomicHsExpr :: HsExpr id -> Bool+-- True of a single token+isAtomicHsExpr (HsVar {})        = True+isAtomicHsExpr (HsConLikeOut {}) = True+isAtomicHsExpr (HsLit {})        = True+isAtomicHsExpr (HsOverLit {})    = True+isAtomicHsExpr (HsIPVar {})      = True+isAtomicHsExpr (HsOverLabel {})  = True+isAtomicHsExpr (HsUnboundVar {}) = True+isAtomicHsExpr (HsWrap _ e)      = isAtomicHsExpr e+isAtomicHsExpr (HsPar e)         = isAtomicHsExpr (unLoc e)+isAtomicHsExpr (HsRecFld{})      = True+isAtomicHsExpr _                 = False++{-+************************************************************************+*                                                                      *+\subsection{Commands (in arrow abstractions)}+*                                                                      *+************************************************************************++We re-use HsExpr to represent these.+-}++-- | Located Haskell Command (for arrow syntax)+type LHsCmd id = Located (HsCmd id)++-- | Haskell Command (e.g. a "statement" in an Arrow proc block)+data HsCmd id+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.Annlarrowtail',+  --          'ApiAnnotation.Annrarrowtail','ApiAnnotation.AnnLarrowtail',+  --          'ApiAnnotation.AnnRarrowtail'++  -- For details on above see note [Api annotations] in ApiAnnotation+  = HsCmdArrApp          -- Arrow tail, or arrow application (f -< arg)+        (LHsExpr id)     -- arrow expression, f+        (LHsExpr id)     -- input expression, arg+        (PostTc id Type) -- type of the arrow expressions f,+                         -- of the form a t t', where arg :: t+        HsArrAppType     -- higher-order (-<<) or first-order (-<)+        Bool             -- True => right-to-left (f -< arg)+                         -- False => left-to-right (arg >- f)++  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpenB' @'(|'@,+  --         'ApiAnnotation.AnnCloseB' @'|)'@++  -- For details on above see note [Api annotations] in ApiAnnotation+  | HsCmdArrForm         -- Command formation,  (| e cmd1 .. cmdn |)+        (LHsExpr id)     -- The operator.+                         -- After type-checking, a type abstraction to be+                         -- applied to the type of the local environment tuple+        LexicalFixity    -- Whether the operator appeared prefix or infix when+                         -- parsed.+        (Maybe Fixity)   -- fixity (filled in by the renamer), for forms that+                         -- were converted from OpApp's by the renamer+        [LHsCmdTop id]   -- argument commands++  | HsCmdApp    (LHsCmd id)+                (LHsExpr id)++  | HsCmdLam    (MatchGroup id (LHsCmd id))     -- kappa+       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',+       --       'ApiAnnotation.AnnRarrow',++       -- For details on above see note [Api annotations] in ApiAnnotation++  | HsCmdPar    (LHsCmd id)                     -- parenthesised command+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,+    --             'ApiAnnotation.AnnClose' @')'@++    -- For details on above see note [Api annotations] in ApiAnnotation++  | HsCmdCase   (LHsExpr id)+                (MatchGroup id (LHsCmd id))     -- bodies are HsCmd's+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase',+    --       'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@,+    --       'ApiAnnotation.AnnClose' @'}'@++    -- For details on above see note [Api annotations] in ApiAnnotation++  | HsCmdIf     (Maybe (SyntaxExpr id))         -- cond function+                (LHsExpr id)                    -- predicate+                (LHsCmd id)                     -- then part+                (LHsCmd id)                     -- else part+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf',+    --       'ApiAnnotation.AnnSemi',+    --       'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi',+    --       'ApiAnnotation.AnnElse',++    -- For details on above see note [Api annotations] in ApiAnnotation++  | HsCmdLet    (LHsLocalBinds id)      -- let(rec)+                (LHsCmd  id)+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet',+    --       'ApiAnnotation.AnnOpen' @'{'@,+    --       'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn'++    -- For details on above see note [Api annotations] in ApiAnnotation++  | HsCmdDo     (Located [CmdLStmt id])+                (PostTc id Type)                -- Type of the whole expression+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo',+    --             'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi',+    --             'ApiAnnotation.AnnVbar',+    --             'ApiAnnotation.AnnClose'++    -- For details on above see note [Api annotations] in ApiAnnotation++  | HsCmdWrap   HsWrapper+                (HsCmd id)     -- If   cmd :: arg1 --> res+                               --      wrap :: arg1 "->" arg2+                               -- Then (HsCmdWrap wrap cmd) :: arg2 --> res+deriving instance (DataId id) => Data (HsCmd id)++-- | Haskell Array Application Type+data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp+  deriving Data+++{- | Top-level command, introducing a new arrow.+This may occur inside a proc (where the stack is empty) or as an+argument of a command-forming operator.+-}++-- | Located Haskell Top-level Command+type LHsCmdTop id = Located (HsCmdTop id)++-- | Haskell Top-level Command+data HsCmdTop id+  = HsCmdTop (LHsCmd id)+             (PostTc id Type)   -- Nested tuple of inputs on the command's stack+             (PostTc id Type)   -- return type of the command+             (CmdSyntaxTable id) -- See Note [CmdSyntaxTable]+deriving instance (DataId id) => Data (HsCmdTop id)++instance (OutputableBndrId id) => Outputable (HsCmd id) where+    ppr cmd = pprCmd cmd++-----------------------+-- pprCmd and pprLCmd call pprDeeper;+-- the underscore versions do not+pprLCmd :: (OutputableBndrId id) => LHsCmd id -> SDoc+pprLCmd (L _ c) = pprCmd c++pprCmd :: (OutputableBndrId id) => HsCmd id -> SDoc+pprCmd c | isQuietHsCmd c =            ppr_cmd c+         | otherwise      = pprDeeper (ppr_cmd c)++isQuietHsCmd :: HsCmd id -> Bool+-- Parentheses do display something, but it gives little info and+-- if we go deeper when we go inside them then we get ugly things+-- like (...)+isQuietHsCmd (HsCmdPar _) = True+-- applications don't display anything themselves+isQuietHsCmd (HsCmdApp _ _) = True+isQuietHsCmd _ = False++-----------------------+ppr_lcmd :: (OutputableBndrId id) => LHsCmd id -> SDoc+ppr_lcmd c = ppr_cmd (unLoc c)++ppr_cmd :: forall id. (OutputableBndrId id) => HsCmd id -> SDoc+ppr_cmd (HsCmdPar c) = parens (ppr_lcmd c)++ppr_cmd (HsCmdApp c e)+  = let (fun, args) = collect_args c [e] in+    hang (ppr_lcmd fun) 2 (sep (map ppr args))+  where+    collect_args (L _ (HsCmdApp fun arg)) args = collect_args fun (arg:args)+    collect_args fun args = (fun, args)++ppr_cmd (HsCmdLam matches)+  = pprMatches matches++ppr_cmd (HsCmdCase expr matches)+  = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")],+          nest 2 (pprMatches matches) ]++ppr_cmd (HsCmdIf _ e ct ce)+  = sep [hsep [text "if", nest 2 (ppr e), ptext (sLit "then")],+         nest 4 (ppr ct),+         text "else",+         nest 4 (ppr ce)]++-- special case: let ... in let ...+ppr_cmd (HsCmdLet (L _ binds) cmd@(L _ (HsCmdLet _ _)))+  = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]),+         ppr_lcmd cmd]++ppr_cmd (HsCmdLet (L _ binds) cmd)+  = sep [hang (text "let") 2 (pprBinds binds),+         hang (text "in")  2 (ppr cmd)]++ppr_cmd (HsCmdDo (L _ stmts) _)  = pprDo ArrowExpr stmts++ppr_cmd (HsCmdWrap w cmd)+  = pprHsWrapper w (\_ -> parens (ppr_cmd cmd))+ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp True)+  = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]+ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp False)+  = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]+ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp True)+  = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]+ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp False)+  = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]++ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) _ (Just _) [arg1, arg2])+  = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v+                                         , pprCmdArg (unLoc arg2)])+ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) Infix _    [arg1, arg2])+  = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v+                                         , pprCmdArg (unLoc arg2)])+ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut c)) _ (Just _) [arg1, arg2])+  = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c)+                                         , pprCmdArg (unLoc arg2)])+ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut c)) Infix _    [arg1, arg2])+  = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c)+                                         , pprCmdArg (unLoc arg2)])+ppr_cmd (HsCmdArrForm op _ _ args)+  = hang (text "(|" <> ppr_lexpr op)+         4 (sep (map (pprCmdArg.unLoc) args) <> text "|)")++pprCmdArg :: (OutputableBndrId id) => HsCmdTop id -> SDoc+pprCmdArg (HsCmdTop cmd _ _ _)+  = ppr_lcmd cmd++instance (OutputableBndrId id) => Outputable (HsCmdTop id) where+    ppr = pprCmdArg++{-+************************************************************************+*                                                                      *+\subsection{Record binds}+*                                                                      *+************************************************************************+-}++-- | Haskell Record Bindings+type HsRecordBinds id = HsRecFields id (LHsExpr id)++{-+************************************************************************+*                                                                      *+\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}+*                                                                      *+************************************************************************++@Match@es are sets of pattern bindings and right hand sides for+functions, patterns or case branches. For example, if a function @g@+is defined as:+\begin{verbatim}+g (x,y) = y+g ((x:ys),y) = y+1,+\end{verbatim}+then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@.++It is always the case that each element of an @[Match]@ list has the+same number of @pats@s inside it.  This corresponds to saying that+a function defined by pattern matching must have the same number of+patterns in each equation.+-}++data MatchGroup id body+  = MG { mg_alts    :: Located [LMatch id body]  -- The alternatives+       , mg_arg_tys :: [PostTc id Type]  -- Types of the arguments, t1..tn+       , mg_res_ty  :: PostTc id Type    -- Type of the result, tr+       , mg_origin  :: Origin }+     -- The type is the type of the entire group+     --      t1 -> ... -> tn -> tr+     -- where there are n patterns+deriving instance (Data body,DataId id) => Data (MatchGroup id body)++-- | Located Match+type LMatch id body = Located (Match id body)+-- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a+--   list++-- For details on above see note [Api annotations] in ApiAnnotation+data Match id body+  = Match {+        m_ctxt :: HsMatchContext (NameOrRdrName id),+          -- See note [m_ctxt in Match]+        m_pats :: [LPat id], -- The patterns+        m_type :: (Maybe (LHsType id)),+                                 -- A type signature for the result of the match+                                 -- Nothing after typechecking+                                 -- NB: No longer supported+        m_grhss :: (GRHSs id body)+  }+deriving instance (Data body,DataId id) => Data (Match id body)++instance (OutputableBndrId idR, Outputable body)+            => Outputable (Match idR body) where+  ppr = pprMatch++{-+Note [m_ctxt in Match]+~~~~~~~~~~~~~~~~~~~~~~++A Match can occur in a number of contexts, such as a FunBind, HsCase, HsLam and+so on.++In order to simplify tooling processing and pretty print output, the provenance+is captured in an HsMatchContext.++This is particularly important for the API Annotations for a multi-equation+FunBind.++The parser initially creates a FunBind with a single Match in it for+every function definition it sees.++These are then grouped together by getMonoBind into a single FunBind,+where all the Matches are combined.++In the process, all the original FunBind fun_id's bar one are+discarded, including the locations.++This causes a problem for source to source conversions via API+Annotations, so the original fun_ids and infix flags are preserved in+the Match, when it originates from a FunBind.++Example infix function definition requiring individual API Annotations++    (&&&  ) [] [] =  []+    xs    &&&   [] =  xs+    (  &&&  ) [] ys =  ys++++-}+++isInfixMatch :: Match id body -> Bool+isInfixMatch match = case m_ctxt match of+  FunRhs {mc_fixity = Infix} -> True+  _                          -> False++isEmptyMatchGroup :: MatchGroup id body -> Bool+isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms++-- | Is there only one RHS in this list of matches?+isSingletonMatchGroup :: [LMatch id body] -> Bool+isSingletonMatchGroup matches+  | [L _ match] <- matches+  , Match { m_grhss = GRHSs { grhssGRHSs = [_] } } <- match+  = True+  | otherwise+  = False++matchGroupArity :: MatchGroup id body -> Arity+-- Precondition: MatchGroup is non-empty+-- This is called before type checking, when mg_arg_tys is not set+matchGroupArity (MG { mg_alts = alts })+  | L _ (alt1:_) <- alts = length (hsLMatchPats alt1)+  | otherwise        = panic "matchGroupArity"++hsLMatchPats :: LMatch id body -> [LPat id]+hsLMatchPats (L _ (Match _ pats _ _)) = pats++-- | Guarded Right-Hand Sides+--+-- GRHSs are used both for pattern bindings and for Matches+--+--  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVbar',+--        'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere',+--        'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'+--        'ApiAnnotation.AnnRarrow','ApiAnnotation.AnnSemi'++-- For details on above see note [Api annotations] in ApiAnnotation+data GRHSs id body+  = GRHSs {+      grhssGRHSs :: [LGRHS id body],      -- ^ Guarded RHSs+      grhssLocalBinds :: LHsLocalBinds id -- ^ The where clause+    }+deriving instance (Data body,DataId id) => Data (GRHSs id body)++-- | Located Guarded Right-Hand Side+type LGRHS id body = Located (GRHS id body)++-- | Guarded Right Hand Side.+data GRHS id body = GRHS [GuardLStmt id] -- Guards+                         body            -- Right hand side+deriving instance (Data body,DataId id) => Data (GRHS id body)++-- We know the list must have at least one @Match@ in it.++pprMatches :: (OutputableBndrId idR, Outputable body)+           => MatchGroup idR body -> SDoc+pprMatches MG { mg_alts = matches }+    = vcat (map pprMatch (map unLoc (unLoc matches)))+      -- Don't print the type; it's only a place-holder before typechecking++-- Exported to HsBinds, which can't see the defn of HsMatchContext+pprFunBind :: (OutputableBndrId idR, Outputable body)+           => MatchGroup idR body -> SDoc+pprFunBind matches = pprMatches matches++-- Exported to HsBinds, which can't see the defn of HsMatchContext+pprPatBind :: forall bndr id body. (OutputableBndrId bndr,+                                    OutputableBndrId id,+                                    Outputable body)+           => LPat bndr -> GRHSs id body -> SDoc+pprPatBind pat (grhss)+ = sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext id) grhss)]++pprMatch :: (OutputableBndrId idR, Outputable body) => Match idR body -> SDoc+pprMatch match+  = sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats)+        , nest 2 ppr_maybe_ty+        , nest 2 (pprGRHSs ctxt (m_grhss match)) ]+  where+    ctxt = m_ctxt match+    (herald, other_pats)+        = case ctxt of+            FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness}+                | strictness == SrcStrict -> ASSERT(null $ m_pats match)+                                             (char '!'<>pprPrefixOcc fun, m_pats match)+                        -- a strict variable binding+                | fixity == Prefix -> (pprPrefixOcc fun, m_pats match)+                        -- f x y z = e+                        -- Not pprBndr; the AbsBinds will+                        -- have printed the signature++                | null pats2 -> (pp_infix, [])+                        -- x &&& y = e++                | otherwise -> (parens pp_infix, pats2)+                        -- (x &&& y) z = e+                where+                  pp_infix = pprParendLPat pat1 <+> pprInfixOcc fun <+> pprParendLPat pat2++            LambdaExpr -> (char '\\', m_pats match)++            _  -> ASSERT2( null pats1, ppr ctxt $$ ppr pat1 $$ ppr pats1 )+                  (ppr pat1, [])        -- No parens around the single pat++    (pat1:pats1) = m_pats match+    (pat2:pats2) = pats1+    ppr_maybe_ty = case m_type match of+                        Just ty -> dcolon <+> ppr ty+                        Nothing -> empty+++pprGRHSs :: (OutputableBndrId idR, Outputable body)+         => HsMatchContext idL -> GRHSs idR body -> SDoc+pprGRHSs ctxt (GRHSs grhss (L _ binds))+  = vcat (map (pprGRHS ctxt . unLoc) grhss)+  -- Print the "where" even if the contents of the binds is empty. Only+  -- EmptyLocalBinds means no "where" keyword+ $$ ppUnless (eqEmptyLocalBinds binds)+      (text "where" $$ nest 4 (pprBinds binds))++pprGRHS :: (OutputableBndrId idR, Outputable body)+        => HsMatchContext idL -> GRHS idR body -> SDoc+pprGRHS ctxt (GRHS [] body)+ =  pp_rhs ctxt body++pprGRHS ctxt (GRHS guards body)+ = sep [vbar <+> interpp'SP guards, pp_rhs ctxt body]++pp_rhs :: Outputable body => HsMatchContext idL -> body -> SDoc+pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)++{-+************************************************************************+*                                                                      *+\subsection{Do stmts and list comprehensions}+*                                                                      *+************************************************************************+-}++-- | Located @do@ block Statement+type LStmt id body = Located (StmtLR id id body)++-- | Located Statement with separate Left and Right id's+type LStmtLR idL idR body = Located (StmtLR idL idR body)++-- | @do@ block Statement+type Stmt id body = StmtLR id id body++-- | Command Located Statement+type CmdLStmt   id = LStmt id (LHsCmd  id)++-- | Command Statement+type CmdStmt    id = Stmt  id (LHsCmd  id)++-- | Expression Located Statement+type ExprLStmt  id = LStmt id (LHsExpr id)++-- | Expression Statement+type ExprStmt   id = Stmt  id (LHsExpr id)++-- | Guard Located Statement+type GuardLStmt id = LStmt id (LHsExpr id)++-- | Guard Statement+type GuardStmt  id = Stmt  id (LHsExpr id)++-- | Ghci Located Statemnt+type GhciLStmt  id = LStmt id (LHsExpr id)++-- | Ghci Statement+type GhciStmt   id = Stmt  id (LHsExpr id)++-- The SyntaxExprs in here are used *only* for do-notation and monad+-- comprehensions, which have rebindable syntax. Otherwise they are unused.+-- | API Annotations when in qualifier lists or guards+--  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVbar',+--         'ApiAnnotation.AnnComma','ApiAnnotation.AnnThen',+--         'ApiAnnotation.AnnBy','ApiAnnotation.AnnBy',+--         'ApiAnnotation.AnnGroup','ApiAnnotation.AnnUsing'++-- For details on above see note [Api annotations] in ApiAnnotation+data StmtLR idL idR body -- body should always be (LHs**** idR)+  = LastStmt  -- Always the last Stmt in ListComp, MonadComp, PArrComp,+              -- and (after the renamer) DoExpr, MDoExpr+              -- Not used for GhciStmtCtxt, PatGuard, which scope over other stuff+          body+          Bool               -- True <=> return was stripped by ApplicativeDo+          (SyntaxExpr idR)   -- The return operator, used only for+                             -- MonadComp For ListComp, PArrComp, we+                             -- use the baked-in 'return' For DoExpr,+                             -- MDoExpr, we don't apply a 'return' at+                             -- all See Note [Monad Comprehensions] |+                             -- - 'ApiAnnotation.AnnKeywordId' :+                             -- 'ApiAnnotation.AnnLarrow'++  -- For details on above see note [Api annotations] in ApiAnnotation+  | BindStmt (LPat idL)+             body+             (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind in Stmts]+             (SyntaxExpr idR) -- The fail operator+             -- The fail operator is noSyntaxExpr+             -- if the pattern match can't fail++             (PostTc idR Type)  -- result type of the function passed to bind;+                                -- that is, S in (>>=) :: Q -> (R -> S) -> T++  -- | 'ApplicativeStmt' represents an applicative expression built with+  -- <$> and <*>.  It is generated by the renamer, and is desugared into the+  -- appropriate applicative expression by the desugarer, but it is intended+  -- to be invisible in error messages.+  --+  -- For full details, see Note [ApplicativeDo] in RnExpr+  --+  | ApplicativeStmt+             [ ( SyntaxExpr idR+               , ApplicativeArg idL idR) ]+                      -- [(<$>, e1), (<*>, e2), ..., (<*>, en)]+             (Maybe (SyntaxExpr idR))  -- 'join', if necessary+             (PostTc idR Type)     -- Type of the body++  | BodyStmt body              -- See Note [BodyStmt]+             (SyntaxExpr idR)  -- The (>>) operator+             (SyntaxExpr idR)  -- The `guard` operator; used only in MonadComp+                               -- See notes [Monad Comprehensions]+             (PostTc idR Type) -- Element type of the RHS (used for arrows)++  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet'+  --          'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@,++  -- For details on above see note [Api annotations] in ApiAnnotation+  | LetStmt  (LHsLocalBindsLR idL idR)++  -- ParStmts only occur in a list/monad comprehension+  | ParStmt  [ParStmtBlock idL idR]+             (HsExpr idR)               -- Polymorphic `mzip` for monad comprehensions+             (SyntaxExpr idR)           -- The `>>=` operator+                                        -- See notes [Monad Comprehensions]+             (PostTc idR Type)          -- S in (>>=) :: Q -> (R -> S) -> T+            -- After renaming, the ids are the binders+            -- bound by the stmts and used after themp++  | TransStmt {+      trS_form  :: TransForm,+      trS_stmts :: [ExprLStmt idL],   -- Stmts to the *left* of the 'group'+                                      -- which generates the tuples to be grouped++      trS_bndrs :: [(idR, idR)],      -- See Note [TransStmt binder map]++      trS_using :: LHsExpr idR,+      trS_by :: Maybe (LHsExpr idR),  -- "by e" (optional)+        -- Invariant: if trS_form = GroupBy, then grp_by = Just e++      trS_ret :: SyntaxExpr idR,      -- The monomorphic 'return' function for+                                      -- the inner monad comprehensions+      trS_bind :: SyntaxExpr idR,     -- The '(>>=)' operator+      trS_bind_arg_ty :: PostTc idR Type,  -- R in (>>=) :: Q -> (R -> S) -> T+      trS_fmap :: HsExpr idR          -- The polymorphic 'fmap' function for desugaring+                                      -- Only for 'group' forms+                                      -- Just a simple HsExpr, because it's+                                      -- too polymorphic for tcSyntaxOp+    }                                 -- See Note [Monad Comprehensions]++  -- Recursive statement (see Note [How RecStmt works] below)+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRec'++  -- For details on above see note [Api annotations] in ApiAnnotation+  | RecStmt+     { recS_stmts :: [LStmtLR idL idR body]++        -- The next two fields are only valid after renaming+     , recS_later_ids :: [idR] -- The ids are a subset of the variables bound by the+                               -- stmts that are used in stmts that follow the RecStmt++     , recS_rec_ids :: [idR]   -- Ditto, but these variables are the "recursive" ones,+                               -- that are used before they are bound in the stmts of+                               -- the RecStmt.+        -- An Id can be in both groups+        -- Both sets of Ids are (now) treated monomorphically+        -- See Note [How RecStmt works] for why they are separate++        -- Rebindable syntax+     , recS_bind_fn :: SyntaxExpr idR -- The bind function+     , recS_ret_fn  :: SyntaxExpr idR -- The return function+     , recS_mfix_fn :: SyntaxExpr idR -- The mfix function+     , recS_bind_ty :: PostTc idR Type  -- S in (>>=) :: Q -> (R -> S) -> T++        -- These fields are only valid after typechecking+     , recS_later_rets :: [PostTcExpr] -- (only used in the arrow version)+     , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1+                                     -- with recS_later_ids and recS_rec_ids,+                                     -- and are the expressions that should be+                                     -- returned by the recursion.+                                     -- They may not quite be the Ids themselves,+                                     -- because the Id may be *polymorphic*, but+                                     -- the returned thing has to be *monomorphic*,+                                     -- so they may be type applications++      , recS_ret_ty :: PostTc idR Type -- The type of+                                       -- do { stmts; return (a,b,c) }+                                   -- With rebindable syntax the type might not+                                   -- be quite as simple as (m (tya, tyb, tyc)).+      }+deriving instance (Data body, DataId idL, DataId idR)+  => Data (StmtLR idL idR body)++data TransForm   -- The 'f' below is the 'using' function, 'e' is the by function+  = ThenForm     -- then f               or    then f by e             (depending on trS_by)+  | GroupForm    -- then group using f   or    then group by e using f (depending on trS_by)+  deriving Data++-- | Parenthesised Statement Block+data ParStmtBlock idL idR+  = ParStmtBlock+        [ExprLStmt idL]+        [idR]              -- The variables to be returned+        (SyntaxExpr idR)   -- The return operator+deriving instance (DataId idL, DataId idR) => Data (ParStmtBlock idL idR)++-- | Applicative Argument+data ApplicativeArg idL idR+  = ApplicativeArgOne            -- pat <- expr (pat must be irrefutable)+      (LPat idL)+      (LHsExpr idL)+  | ApplicativeArgMany           -- do { stmts; return vars }+      [ExprLStmt idL]            -- stmts+      (HsExpr idL)               -- return (v1,..,vn), or just (v1,..,vn)+      (LPat idL)                 -- (v1,...,vn)+deriving instance (DataId idL, DataId idR) => Data (ApplicativeArg idL idR)++{-+Note [The type of bind in Stmts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Some Stmts, notably BindStmt, keep the (>>=) bind operator.+We do NOT assume that it has type+    (>>=) :: m a -> (a -> m b) -> m b+In some cases (see Trac #303, #1537) it might have a more+exotic type, such as+    (>>=) :: m i j a -> (a -> m j k b) -> m i k b+So we must be careful not to make assumptions about the type.+In particular, the monad may not be uniform throughout.++Note [TransStmt binder map]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+The [(idR,idR)] in a TransStmt behaves as follows:++  * Before renaming: []++  * After renaming:+          [ (x27,x27), ..., (z35,z35) ]+    These are the variables+       bound by the stmts to the left of the 'group'+       and used either in the 'by' clause,+                or     in the stmts following the 'group'+    Each item is a pair of identical variables.++  * After typechecking:+          [ (x27:Int, x27:[Int]), ..., (z35:Bool, z35:[Bool]) ]+    Each pair has the same unique, but different *types*.++Note [BodyStmt]+~~~~~~~~~~~~~~~+BodyStmts are a bit tricky, because what they mean+depends on the context.  Consider the following contexts:++        A do expression of type (m res_ty)+        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+        * BodyStmt E any_ty:   do { ....; E; ... }+                E :: m any_ty+          Translation: E >> ...++        A list comprehensions of type [elt_ty]+        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+        * BodyStmt E Bool:   [ .. | .... E ]+                        [ .. | ..., E, ... ]+                        [ .. | .... | ..., E | ... ]+                E :: Bool+          Translation: if E then fail else ...++        A guard list, guarding a RHS of type rhs_ty+        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+        * BodyStmt E BooParStmtBlockl:   f x | ..., E, ... = ...rhs...+                E :: Bool+          Translation: if E then fail else ...++        A monad comprehension of type (m res_ty)+        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+        * BodyStmt E Bool:   [ .. | .... E ]+                E :: Bool+          Translation: guard E >> ...++Array comprehensions are handled like list comprehensions.++Note [How RecStmt works]+~~~~~~~~~~~~~~~~~~~~~~~~+Example:+   HsDo [ BindStmt x ex++        , RecStmt { recS_rec_ids   = [a, c]+                  , recS_stmts     = [ BindStmt b (return (a,c))+                                     , LetStmt a = ...b...+                                     , BindStmt c ec ]+                  , recS_later_ids = [a, b]++        , return (a b) ]++Here, the RecStmt binds a,b,c; but+  - Only a,b are used in the stmts *following* the RecStmt,+  - Only a,c are used in the stmts *inside* the RecStmt+        *before* their bindings++Why do we need *both* rec_ids and later_ids?  For monads they could be+combined into a single set of variables, but not for arrows.  That+follows from the types of the respective feedback operators:++        mfix :: MonadFix m => (a -> m a) -> m a+        loop :: ArrowLoop a => a (b,d) (c,d) -> a b c++* For mfix, the 'a' covers the union of the later_ids and the rec_ids+* For 'loop', 'c' is the later_ids and 'd' is the rec_ids++Note [Typing a RecStmt]+~~~~~~~~~~~~~~~~~~~~~~~+A (RecStmt stmts) types as if you had written++  (v1,..,vn, _, ..., _) <- mfix (\~(_, ..., _, r1, ..., rm) ->+                                 do { stmts+                                    ; return (v1,..vn, r1, ..., rm) })++where v1..vn are the later_ids+      r1..rm are the rec_ids++Note [Monad Comprehensions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Monad comprehensions require separate functions like 'return' and+'>>=' for desugaring. These functions are stored in the statements+used in monad comprehensions. For example, the 'return' of the 'LastStmt'+expression is used to lift the body of the monad comprehension:++  [ body | stmts ]+   =>+  stmts >>= \bndrs -> return body++In transform and grouping statements ('then ..' and 'then group ..') the+'return' function is required for nested monad comprehensions, for example:++  [ body | stmts, then f, rest ]+   =>+  f [ env | stmts ] >>= \bndrs -> [ body | rest ]++BodyStmts require the 'Control.Monad.guard' function for boolean+expressions:++  [ body | exp, stmts ]+   =>+  guard exp >> [ body | stmts ]++Parallel statements require the 'Control.Monad.Zip.mzip' function:++  [ body | stmts1 | stmts2 | .. ]+   =>+  mzip stmts1 (mzip stmts2 (..)) >>= \(bndrs1, (bndrs2, ..)) -> return body++In any other context than 'MonadComp', the fields for most of these+'SyntaxExpr's stay bottom.+-}++instance (OutputableBndrId idL) => Outputable (ParStmtBlock idL idR) where+  ppr (ParStmtBlock stmts _ _) = interpp'SP stmts++instance (OutputableBndrId idL, OutputableBndrId idR, Outputable body)+         => Outputable (StmtLR idL idR body) where+    ppr stmt = pprStmt stmt++pprStmt :: forall idL idR body . (OutputableBndrId idL, OutputableBndrId idR,+                                  Outputable body)+        => (StmtLR idL idR body) -> SDoc+pprStmt (LastStmt expr ret_stripped _)+  = ifPprDebug (text "[last]") <+>+       (if ret_stripped then text "return" else empty) <+>+       ppr expr+pprStmt (BindStmt pat expr _ _ _) = hsep [ppr pat, larrow, ppr expr]+pprStmt (LetStmt (L _ binds))     = hsep [text "let", pprBinds binds]+pprStmt (BodyStmt expr _ _ _)     = ppr expr+pprStmt (ParStmt stmtss _ _ _)    = sep (punctuate (text " | ") (map ppr stmtss))++pprStmt (TransStmt { trS_stmts = stmts, trS_by = by, trS_using = using, trS_form = form })+  = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form])++pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids+                 , recS_later_ids = later_ids })+  = text "rec" <+>+    vcat [ ppr_do_stmts segment+         , ifPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids+                            , text "later_ids=" <> ppr later_ids])]++pprStmt (ApplicativeStmt args mb_join _)+  = getPprStyle $ \style ->+      if userStyle style+         then pp_for_user+         else pp_debug+  where+  -- make all the Applicative stuff invisible in error messages by+  -- flattening the whole ApplicativeStmt nest back to a sequence+  -- of statements.+   pp_for_user = vcat $ concatMap flattenArg args++   -- ppr directly rather than transforming here, because we need to+   -- inject a "return" which is hard when we're polymorphic in the id+   -- type.+   flattenStmt :: ExprLStmt idL -> [SDoc]+   flattenStmt (L _ (ApplicativeStmt args _ _)) = concatMap flattenArg args+   flattenStmt stmt = [ppr stmt]++   flattenArg (_, ApplicativeArgOne pat expr) =+     [ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr (panic "pprStmt")+             :: ExprStmt idL)]+   flattenArg (_, ApplicativeArgMany stmts _ _) =+     concatMap flattenStmt stmts++   pp_debug =+     let+         ap_expr = sep (punctuate (text " |") (map pp_arg args))+     in+       if isNothing mb_join+          then ap_expr+          else text "join" <+> parens ap_expr++   pp_arg (_, ApplicativeArgOne pat expr) =+     ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr (panic "pprStmt")+            :: ExprStmt idL)+   pp_arg (_, ApplicativeArgMany stmts return pat) =+     ppr pat <+>+     text "<-" <+>+     ppr (HsDo DoExpr (noLoc+                (stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)]))+           (error "pprStmt"))++pprTransformStmt :: (OutputableBndrId id)+                 => [id] -> LHsExpr id -> Maybe (LHsExpr id) -> SDoc+pprTransformStmt bndrs using by+  = sep [ text "then" <+> ifPprDebug (braces (ppr bndrs))+        , nest 2 (ppr using)+        , nest 2 (pprBy by)]++pprTransStmt :: Outputable body => Maybe body -> body -> TransForm -> SDoc+pprTransStmt by using ThenForm+  = sep [ text "then", nest 2 (ppr using), nest 2 (pprBy by)]+pprTransStmt by using GroupForm+  = sep [ text "then group", nest 2 (pprBy by), nest 2 (ptext (sLit "using") <+> ppr using)]++pprBy :: Outputable body => Maybe body -> SDoc+pprBy Nothing  = empty+pprBy (Just e) = text "by" <+> ppr e++pprDo :: (OutputableBndrId id, Outputable body)+      => HsStmtContext any -> [LStmt id body] -> SDoc+pprDo DoExpr        stmts = text "do"  <+> ppr_do_stmts stmts+pprDo GhciStmtCtxt  stmts = text "do"  <+> ppr_do_stmts stmts+pprDo ArrowExpr     stmts = text "do"  <+> ppr_do_stmts stmts+pprDo MDoExpr       stmts = text "mdo" <+> ppr_do_stmts stmts+pprDo ListComp      stmts = brackets    $ pprComp stmts+pprDo PArrComp      stmts = paBrackets  $ pprComp stmts+pprDo MonadComp     stmts = brackets    $ pprComp stmts+pprDo _             _     = panic "pprDo" -- PatGuard, ParStmtCxt++ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR, Outputable body)+             => [LStmtLR idL idR body] -> SDoc+-- Print a bunch of do stmts+ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts)++pprComp :: (OutputableBndrId id, Outputable body) => [LStmt id body] -> SDoc+pprComp quals     -- Prints:  body | qual1, ..., qualn+  | Just (initStmts, L _ (LastStmt body _ _)) <- snocView quals+  = if null initStmts+       -- If there are no statements in a list comprehension besides the last+       -- one, we simply treat it like a normal list. This does arise+       -- occasionally in code that GHC generates, e.g., in implementations of+       -- 'range' for derived 'Ix' instances for product datatypes with exactly+       -- one constructor (e.g., see Trac #12583).+       then ppr body+       else hang (ppr body <+> vbar) 2 (pprQuals initStmts)+  | otherwise+  = pprPanic "pprComp" (pprQuals quals)++pprQuals :: (OutputableBndrId id, Outputable body) => [LStmt id body] -> SDoc+-- Show list comprehension qualifiers separated by commas+pprQuals quals = interpp'SP quals++{-+************************************************************************+*                                                                      *+                Template Haskell quotation brackets+*                                                                      *+************************************************************************+-}++-- | Haskell Splice+data HsSplice id+   = HsTypedSplice       --  $$z  or $$(f 4)+        SpliceDecoration -- Whether $$( ) variant found, for pretty printing+        id               -- A unique name to identify this splice point+        (LHsExpr id)     -- See Note [Pending Splices]++   | HsUntypedSplice     --  $z  or $(f 4)+        SpliceDecoration -- Whether $( ) variant found, for pretty printing+        id               -- A unique name to identify this splice point+        (LHsExpr id)     -- See Note [Pending Splices]++   | HsQuasiQuote        -- See Note [Quasi-quote overview] in TcSplice+        id               -- Splice point+        id               -- Quoter+        SrcSpan          -- The span of the enclosed string+        FastString       -- The enclosed string++   | HsSpliced  -- See Note [Delaying modFinalizers in untyped splices] in+                -- RnSplice.+                -- This is the result of splicing a splice. It is produced by+                -- the renamer and consumed by the typechecker. It lives only+                -- between the two.+        ThModFinalizers     -- TH finalizers produced by the splice.+        (HsSplicedThing id) -- The result of splicing+  deriving Typeable+deriving instance (DataId id) => Data (HsSplice id)++-- | A splice can appear with various decorations wrapped around it. This data+-- type captures explicitly how it was originally written, for use in the pretty+-- printer.+data SpliceDecoration+  = HasParens -- ^ $( splice ) or $$( splice )+  | HasDollar -- ^ $splice or $$splice+  | NoParens  -- ^ bare splice+  deriving (Data, Eq, Show)++instance Outputable SpliceDecoration where+  ppr x = text $ show x+++isTypedSplice :: HsSplice id -> Bool+isTypedSplice (HsTypedSplice {}) = True+isTypedSplice _                  = False   -- Quasi-quotes are untyped splices++-- | Finalizers produced by a splice with+-- 'Language.Haskell.TH.Syntax.addModFinalizer'+--+-- See Note [Delaying modFinalizers in untyped splices] in RnSplice. For how+-- this is used.+--+newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())]++-- A Data instance which ignores the argument of 'ThModFinalizers'.+instance Data ThModFinalizers where+  gunfold _ z _ = z $ ThModFinalizers []+  toConstr  a   = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix+  dataTypeOf a  = mkDataType "HsExpr.ThModFinalizers" [toConstr a]++-- | Haskell Spliced Thing+--+-- Values that can result from running a splice.+data HsSplicedThing id+    = HsSplicedExpr (HsExpr id) -- ^ Haskell Spliced Expression+    | HsSplicedTy   (HsType id) -- ^ Haskell Spliced Type+    | HsSplicedPat  (Pat id)    -- ^ Haskell Spliced Pattern+  deriving Typeable++deriving instance (DataId id) => Data (HsSplicedThing id)++-- See Note [Pending Splices]+type SplicePointName = Name++-- | Pending Renamer Splice+data PendingRnSplice+  = PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr Name)+  deriving Data++data UntypedSpliceFlavour+  = UntypedExpSplice+  | UntypedPatSplice+  | UntypedTypeSplice+  | UntypedDeclSplice+  deriving Data++-- | Pending Type-checker Splice+data PendingTcSplice+  = PendingTcSplice SplicePointName (LHsExpr Id)+  deriving Data+++{-+Note [Pending Splices]+~~~~~~~~~~~~~~~~~~~~~~+When we rename an untyped bracket, we name and lift out all the nested+splices, so that when the typechecker hits the bracket, it can+typecheck those nested splices without having to walk over the untyped+bracket code.  So for example+    [| f $(g x) |]+looks like++    HsBracket (HsApp (HsVar "f") (HsSpliceE _ (g x)))++which the renamer rewrites to++    HsRnBracketOut (HsApp (HsVar f) (HsSpliceE sn (g x)))+                   [PendingRnSplice UntypedExpSplice sn (g x)]++* The 'sn' is the Name of the splice point, the SplicePointName++* The PendingRnExpSplice gives the splice that splice-point name maps to;+  and the typechecker can now conveniently find these sub-expressions++* The other copy of the splice, in the second argument of HsSpliceE+                                in the renamed first arg of HsRnBracketOut+  is used only for pretty printing++There are four varieties of pending splices generated by the renamer,+distinguished by their UntypedSpliceFlavour++ * Pending expression splices (UntypedExpSplice), e.g.,+       [|$(f x) + 2|]++   UntypedExpSplice is also used for+     * quasi-quotes, where the pending expression expands to+          $(quoter "...blah...")+       (see RnSplice.makePending, HsQuasiQuote case)++     * cross-stage lifting, where the pending expression expands to+          $(lift x)+       (see RnSplice.checkCrossStageLifting)++ * Pending pattern splices (UntypedPatSplice), e.g.,+       [| \$(f x) -> x |]++ * Pending type splices (UntypedTypeSplice), e.g.,+       [| f :: $(g x) |]++ * Pending declaration (UntypedDeclSplice), e.g.,+       [| let $(f x) in ... |]++There is a fifth variety of pending splice, which is generated by the type+checker:++  * Pending *typed* expression splices, (PendingTcSplice), e.g.,+        [||1 + $$(f 2)||]++It would be possible to eliminate HsRnBracketOut and use HsBracketOut for the+output of the renamer. However, when pretty printing the output of the renamer,+e.g., in a type error message, we *do not* want to print out the pending+splices. In contrast, when pretty printing the output of the type checker, we+*do* want to print the pending splices. So splitting them up seems to make+sense, although I hate to add another constructor to HsExpr.+-}++instance (OutputableBndrId id) => Outputable (HsSplicedThing id) where+  ppr (HsSplicedExpr e) = ppr_expr e+  ppr (HsSplicedTy   t) = ppr t+  ppr (HsSplicedPat  p) = ppr p++instance (OutputableBndrId id) => Outputable (HsSplice id) where+  ppr s = pprSplice s++pprPendingSplice :: (OutputableBndrId id)+                 => SplicePointName -> LHsExpr id -> SDoc+pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e)++pprSpliceDecl ::  (OutputableBndrId id)+          => HsSplice id -> SpliceExplicitFlag -> SDoc+pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e+pprSpliceDecl e ExplicitSplice   = text "$(" <> ppr_splice_decl e <> text ")"+pprSpliceDecl e ImplicitSplice   = ppr_splice_decl e++ppr_splice_decl :: (OutputableBndrId id) => HsSplice id -> SDoc+ppr_splice_decl (HsUntypedSplice _ n e) = ppr_splice empty n e empty+ppr_splice_decl e = pprSplice e++pprSplice :: (OutputableBndrId id) => HsSplice id -> SDoc+pprSplice (HsTypedSplice HasParens  n e)+  = ppr_splice (text "$$(") n e (text ")")+pprSplice (HsTypedSplice HasDollar n e)+  = ppr_splice (text "$$") n e empty+pprSplice (HsTypedSplice NoParens n e)+  = ppr_splice empty n e empty+pprSplice (HsUntypedSplice HasParens  n e)+  = ppr_splice (text "$(") n e (text ")")+pprSplice (HsUntypedSplice HasDollar n e)+  = ppr_splice (text "$")  n e empty+pprSplice (HsUntypedSplice NoParens n e)+  = ppr_splice empty  n e empty+pprSplice (HsQuasiQuote n q _ s)      = ppr_quasi n q s+pprSplice (HsSpliced _ thing)         = ppr thing++ppr_quasi :: OutputableBndr id => id -> id -> FastString -> SDoc+ppr_quasi n quoter quote = ifPprDebug (brackets (ppr n)) <>+                           char '[' <> ppr quoter <> vbar <>+                           ppr quote <> text "|]"++ppr_splice :: (OutputableBndrId id)+           => SDoc -> id -> LHsExpr id -> SDoc -> SDoc+ppr_splice herald n e trail+    = herald <> ifPprDebug (brackets (ppr n)) <> ppr e <> trail++-- | Haskell Bracket+data HsBracket id = ExpBr (LHsExpr id)   -- [|  expr  |]+                  | PatBr (LPat id)      -- [p| pat   |]+                  | DecBrL [LHsDecl id]  -- [d| decls |]; result of parser+                  | DecBrG (HsGroup id)  -- [d| decls |]; result of renamer+                  | TypBr (LHsType id)   -- [t| type  |]+                  | VarBr Bool id        -- True: 'x, False: ''T+                                         -- (The Bool flag is used only in pprHsBracket)+                  | TExpBr (LHsExpr id)  -- [||  expr  ||]+deriving instance (DataId id) => Data (HsBracket id)++isTypedBracket :: HsBracket id -> Bool+isTypedBracket (TExpBr {}) = True+isTypedBracket _           = False++instance (OutputableBndrId id) => Outputable (HsBracket id) where+  ppr = pprHsBracket+++pprHsBracket :: (OutputableBndrId id) => HsBracket id -> SDoc+pprHsBracket (ExpBr e)   = thBrackets empty (ppr e)+pprHsBracket (PatBr p)   = thBrackets (char 'p') (ppr p)+pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp)+pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds))+pprHsBracket (TypBr t)   = thBrackets (char 't') (ppr t)+pprHsBracket (VarBr True n)+  = char '\'' <> pprPrefixOcc n+pprHsBracket (VarBr False n)+  = text "''" <> pprPrefixOcc n+pprHsBracket (TExpBr e)  = thTyBrackets (ppr e)++thBrackets :: SDoc -> SDoc -> SDoc+thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+>+                             pp_body <+> text "|]"++thTyBrackets :: SDoc -> SDoc+thTyBrackets pp_body = text "[||" <+> pp_body <+> ptext (sLit "||]")++instance Outputable PendingRnSplice where+  ppr (PendingRnSplice _ n e) = pprPendingSplice n e++instance Outputable PendingTcSplice where+  ppr (PendingTcSplice n e) = pprPendingSplice n e++{-+************************************************************************+*                                                                      *+\subsection{Enumerations and list comprehensions}+*                                                                      *+************************************************************************+-}++-- | Arithmetic Sequence Information+data ArithSeqInfo id+  = From            (LHsExpr id)+  | FromThen        (LHsExpr id)+                    (LHsExpr id)+  | FromTo          (LHsExpr id)+                    (LHsExpr id)+  | FromThenTo      (LHsExpr id)+                    (LHsExpr id)+                    (LHsExpr id)+deriving instance (DataId id) => Data (ArithSeqInfo id)++instance (OutputableBndrId id)+         => Outputable (ArithSeqInfo id) where+    ppr (From e1)             = hcat [ppr e1, pp_dotdot]+    ppr (FromThen e1 e2)      = hcat [ppr e1, comma, space, ppr e2, pp_dotdot]+    ppr (FromTo e1 e3)        = hcat [ppr e1, pp_dotdot, ppr e3]+    ppr (FromThenTo e1 e2 e3)+      = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3]++pp_dotdot :: SDoc+pp_dotdot = text " .. "++{-+************************************************************************+*                                                                      *+\subsection{HsMatchCtxt}+*                                                                      *+************************************************************************+-}++-- | Haskell Match Context+--+-- Context of a pattern match. This is more subtle than it would seem. See Note+-- [Varieties of pattern matches].+data HsMatchContext id -- Not an extensible tag+  = FunRhs { mc_fun :: Located id -- ^ function binder of @f@+           , mc_fixity :: LexicalFixity -- ^ fixing of @f@+           , mc_strictness :: SrcStrictness+             -- ^ was the pattern banged? See+             -- Note [Varieties of binding pattern matches]+           }+                                -- ^A pattern matching on an argument of a+                                -- function binding+  | LambdaExpr                  -- ^Patterns of a lambda+  | CaseAlt                     -- ^Patterns and guards on a case alternative+  | IfAlt                       -- ^Guards of a multi-way if alternative+  | ProcExpr                    -- ^Patterns of a proc+  | PatBindRhs                  -- ^A pattern binding  eg [y] <- e = e++  | RecUpd                      -- ^Record update [used only in DsExpr to+                                --    tell matchWrapper what sort of+                                --    runtime error message to generate]++  | StmtCtxt (HsStmtContext id) -- ^Pattern of a do-stmt, list comprehension,+                                -- pattern guard, etc++  | ThPatSplice            -- ^A Template Haskell pattern splice+  | ThPatQuote             -- ^A Template Haskell pattern quotation [p| (a,b) |]+  | PatSyn                 -- ^A pattern synonym declaration+  deriving Functor+deriving instance (DataIdPost id) => Data (HsMatchContext id)++instance OutputableBndr id => Outputable (HsMatchContext id) where+  ppr m@(FunRhs{})          = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m)+  ppr LambdaExpr            = text "LambdaExpr"+  ppr CaseAlt               = text "CaseAlt"+  ppr IfAlt                 = text "IfAlt"+  ppr ProcExpr              = text "ProcExpr"+  ppr PatBindRhs            = text "PatBindRhs"+  ppr RecUpd                = text "RecUpd"+  ppr (StmtCtxt _)          = text "StmtCtxt _"+  ppr ThPatSplice           = text "ThPatSplice"+  ppr ThPatQuote            = text "ThPatQuote"+  ppr PatSyn                = text "PatSyn"++isPatSynCtxt :: HsMatchContext id -> Bool+isPatSynCtxt ctxt =+  case ctxt of+    PatSyn -> True+    _      -> False++-- | Haskell Statement Context+data HsStmtContext id+  = ListComp+  | MonadComp+  | PArrComp                         -- ^Parallel array comprehension++  | DoExpr                           -- ^do { ... }+  | MDoExpr                          -- ^mdo { ... }  ie recursive do-expression+  | ArrowExpr                        -- ^do-notation in an arrow-command context++  | GhciStmtCtxt                     -- ^A command-line Stmt in GHCi pat <- rhs+  | PatGuard (HsMatchContext id)     -- ^Pattern guard for specified thing+  | ParStmtCtxt (HsStmtContext id)   -- ^A branch of a parallel stmt+  | TransStmtCtxt (HsStmtContext id) -- ^A branch of a transform stmt+  deriving Functor+deriving instance (DataIdPost id) => Data (HsStmtContext id)++isListCompExpr :: HsStmtContext id -> Bool+-- Uses syntax [ e | quals ]+isListCompExpr ListComp          = True+isListCompExpr PArrComp          = True+isListCompExpr MonadComp         = True+isListCompExpr (ParStmtCtxt c)   = isListCompExpr c+isListCompExpr (TransStmtCtxt c) = isListCompExpr c+isListCompExpr _                 = False++isMonadCompExpr :: HsStmtContext id -> Bool+isMonadCompExpr MonadComp            = True+isMonadCompExpr (ParStmtCtxt ctxt)   = isMonadCompExpr ctxt+isMonadCompExpr (TransStmtCtxt ctxt) = isMonadCompExpr ctxt+isMonadCompExpr _                    = False++-- | Should pattern match failure in a 'HsStmtContext' be desugared using+-- 'MonadFail'?+isMonadFailStmtContext :: HsStmtContext id -> Bool+isMonadFailStmtContext MonadComp    = True+isMonadFailStmtContext DoExpr       = True+isMonadFailStmtContext MDoExpr      = True+isMonadFailStmtContext GhciStmtCtxt = True+isMonadFailStmtContext _            = False++matchSeparator :: HsMatchContext id -> SDoc+matchSeparator (FunRhs {})  = text "="+matchSeparator CaseAlt      = text "->"+matchSeparator IfAlt        = text "->"+matchSeparator LambdaExpr   = text "->"+matchSeparator ProcExpr     = text "->"+matchSeparator PatBindRhs   = text "="+matchSeparator (StmtCtxt _) = text "<-"+matchSeparator RecUpd       = text "=" -- This can be printed by the pattern+                                       -- match checker trace+matchSeparator ThPatSplice  = panic "unused"+matchSeparator ThPatQuote   = panic "unused"+matchSeparator PatSyn       = panic "unused"++pprMatchContext :: (Outputable (NameOrRdrName id),Outputable id)+                => HsMatchContext id -> SDoc+pprMatchContext ctxt+  | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt+  | otherwise    = text "a"  <+> pprMatchContextNoun ctxt+  where+    want_an (FunRhs {}) = True  -- Use "an" in front+    want_an ProcExpr    = True+    want_an _           = False++pprMatchContextNoun :: (Outputable (NameOrRdrName id),Outputable id)+                    => HsMatchContext id -> SDoc+pprMatchContextNoun (FunRhs {mc_fun=L _ fun})+                                    = text "equation for"+                                      <+> quotes (ppr fun)+pprMatchContextNoun CaseAlt         = text "case alternative"+pprMatchContextNoun IfAlt           = text "multi-way if alternative"+pprMatchContextNoun RecUpd          = text "record-update construct"+pprMatchContextNoun ThPatSplice     = text "Template Haskell pattern splice"+pprMatchContextNoun ThPatQuote      = text "Template Haskell pattern quotation"+pprMatchContextNoun PatBindRhs      = text "pattern binding"+pprMatchContextNoun LambdaExpr      = text "lambda abstraction"+pprMatchContextNoun ProcExpr        = text "arrow abstraction"+pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in"+                                      $$ pprStmtContext ctxt+pprMatchContextNoun PatSyn          = text "pattern synonym declaration"++-----------------+pprAStmtContext, pprStmtContext :: (Outputable id,+                                    Outputable (NameOrRdrName id))+                                => HsStmtContext id -> SDoc+pprAStmtContext ctxt = article <+> pprStmtContext ctxt+  where+    pp_an = text "an"+    pp_a  = text "a"+    article = case ctxt of+                  MDoExpr       -> pp_an+                  PArrComp      -> pp_an+                  GhciStmtCtxt  -> pp_an+                  _             -> pp_a+++-----------------+pprStmtContext GhciStmtCtxt    = text "interactive GHCi command"+pprStmtContext DoExpr          = text "'do' block"+pprStmtContext MDoExpr         = text "'mdo' block"+pprStmtContext ArrowExpr       = text "'do' block in an arrow command"+pprStmtContext ListComp        = text "list comprehension"+pprStmtContext MonadComp       = text "monad comprehension"+pprStmtContext PArrComp        = text "array comprehension"+pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt++-- Drop the inner contexts when reporting errors, else we get+--     Unexpected transform statement+--     in a transformed branch of+--          transformed branch of+--          transformed branch of monad comprehension+pprStmtContext (ParStmtCtxt c) =+  sdocWithPprDebug $ \dbg -> if dbg+    then sep [text "parallel branch of", pprAStmtContext c]+    else pprStmtContext c+pprStmtContext (TransStmtCtxt c) =+  sdocWithPprDebug $ \dbg -> if dbg+    then sep [text "transformed branch of", pprAStmtContext c]+    else pprStmtContext c++instance (Outputable id, Outputable (NameOrRdrName id))+      => Outputable (HsStmtContext id) where+    ppr = pprStmtContext++-- Used to generate the string for a *runtime* error message+matchContextErrString :: Outputable id+                      => HsMatchContext id -> SDoc+matchContextErrString (FunRhs{mc_fun=L _ fun})   = text "function" <+> ppr fun+matchContextErrString CaseAlt                    = text "case"+matchContextErrString IfAlt                      = text "multi-way if"+matchContextErrString PatBindRhs                 = text "pattern binding"+matchContextErrString RecUpd                     = text "record update"+matchContextErrString LambdaExpr                 = text "lambda"+matchContextErrString ProcExpr                   = text "proc"+matchContextErrString ThPatSplice                = panic "matchContextErrString"  -- Not used at runtime+matchContextErrString ThPatQuote                 = panic "matchContextErrString"  -- Not used at runtime+matchContextErrString PatSyn                     = panic "matchContextErrString"  -- Not used at runtime+matchContextErrString (StmtCtxt (ParStmtCtxt c))   = matchContextErrString (StmtCtxt c)+matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c)+matchContextErrString (StmtCtxt (PatGuard _))      = text "pattern guard"+matchContextErrString (StmtCtxt GhciStmtCtxt)      = text "interactive GHCi command"+matchContextErrString (StmtCtxt DoExpr)            = text "'do' block"+matchContextErrString (StmtCtxt ArrowExpr)         = text "'do' block"+matchContextErrString (StmtCtxt MDoExpr)           = text "'mdo' block"+matchContextErrString (StmtCtxt ListComp)          = text "list comprehension"+matchContextErrString (StmtCtxt MonadComp)         = text "monad comprehension"+matchContextErrString (StmtCtxt PArrComp)          = text "array comprehension"++pprMatchInCtxt :: (OutputableBndrId idR,+                   Outputable (NameOrRdrName (NameOrRdrName idR)),+                   Outputable body)+               => Match idR body -> SDoc+pprMatchInCtxt match  = hang (text "In" <+> pprMatchContext (m_ctxt match)+                                        <> colon)+                             4 (pprMatch match)++pprStmtInCtxt :: (OutputableBndrId idL, OutputableBndrId idR,+                  Outputable body)+               => HsStmtContext idL -> StmtLR idL idR body -> SDoc+pprStmtInCtxt ctxt (LastStmt e _ _)+  | isListCompExpr ctxt      -- For [ e | .. ], do not mutter about "stmts"+  = hang (text "In the expression:") 2 (ppr e)++pprStmtInCtxt ctxt stmt+  = hang (text "In a stmt of" <+> pprAStmtContext ctxt <> colon)+       2 (ppr_stmt stmt)+  where+    -- For Group and Transform Stmts, don't print the nested stmts!+    ppr_stmt (TransStmt { trS_by = by, trS_using = using+                        , trS_form = form }) = pprTransStmt by using form+    ppr_stmt stmt = pprStmt stmt
+ hsSyn/HsExpr.hs-boot view
@@ -0,0 +1,57 @@+{-# LANGUAGE CPP, KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]+                                      -- in module PlaceHolder+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE RoleAnnotations #-}++module HsExpr where++import SrcLoc     ( Located )+import Outputable ( SDoc, Outputable )+import {-# SOURCE #-} HsPat  ( LPat )+import BasicTypes ( SpliceExplicitFlag(..))+import PlaceHolder ( DataId, OutputableBndrId )+import Data.Data hiding ( Fixity )++type role HsExpr nominal+type role HsCmd nominal+type role MatchGroup nominal representational+type role GRHSs nominal representational+type role HsSplice nominal+type role SyntaxExpr nominal+data HsExpr (i :: *)+data HsCmd  (i :: *)+data HsSplice (i :: *)+data MatchGroup (a :: *) (body :: *)+data GRHSs (a :: *) (body :: *)+data SyntaxExpr (i :: *)++instance (DataId id) => Data (HsSplice id)+instance (DataId id) => Data (HsExpr id)+instance (DataId id) => Data (HsCmd id)+instance (Data body,DataId id) => Data (MatchGroup id body)+instance (Data body,DataId id) => Data (GRHSs id body)+instance (DataId id) => Data (SyntaxExpr id)++instance (OutputableBndrId id) => Outputable (HsExpr id)+instance (OutputableBndrId id) => Outputable (HsCmd id)++type LHsExpr a = Located (HsExpr a)++pprLExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc++pprExpr :: (OutputableBndrId id) => HsExpr id -> SDoc++pprSplice :: (OutputableBndrId id) => HsSplice id -> SDoc++pprSpliceDecl ::  (OutputableBndrId id)+          => HsSplice id -> SpliceExplicitFlag -> SDoc++pprPatBind :: (OutputableBndrId bndr,+               OutputableBndrId id,+               Outputable body)+           => LPat bndr -> GRHSs id body -> SDoc++pprFunBind :: (OutputableBndrId idR, Outputable body)+           => MatchGroup idR body -> SDoc
+ hsSyn/HsImpExp.hs view
@@ -0,0 +1,310 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++HsImpExp: Abstract syntax: imports, exports, interfaces+-}++{-# LANGUAGE DeriveDataTypeable #-}++module HsImpExp where++import Module           ( ModuleName )+import HsDoc            ( HsDocString )+import OccName          ( HasOccName(..), isTcOcc, isSymOcc )+import BasicTypes       ( SourceText(..), StringLiteral(..), pprWithSourceText )+import FieldLabel       ( FieldLbl(..) )++import Outputable+import FastString+import SrcLoc++import Data.Data++{-+************************************************************************+*                                                                      *+\subsection{Import and export declaration lists}+*                                                                      *+************************************************************************++One per \tr{import} declaration in a module.+-}++-- | Located Import Declaration+type LImportDecl name = Located (ImportDecl name)+        -- ^ When in a list this may have+        --+        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi'++        -- For details on above see note [Api annotations] in ApiAnnotation++-- | Import Declaration+--+-- A single Haskell @import@ declaration.+data ImportDecl name+  = ImportDecl {+      ideclSourceSrc :: SourceText,+                                 -- Note [Pragma source text] in BasicTypes+      ideclName      :: Located ModuleName, -- ^ Module name.+      ideclPkgQual   :: Maybe StringLiteral,  -- ^ Package qualifier.+      ideclSource    :: Bool,          -- ^ True <=> {-\# SOURCE \#-} import+      ideclSafe      :: Bool,          -- ^ True => safe import+      ideclQualified :: Bool,          -- ^ True => qualified+      ideclImplicit  :: Bool,          -- ^ True => implicit import (of Prelude)+      ideclAs        :: Maybe (Located ModuleName),  -- ^ as Module+      ideclHiding    :: Maybe (Bool, Located [LIE name])+                                       -- ^ (True => hiding, names)+    }+     -- ^+     --  'ApiAnnotation.AnnKeywordId's+     --+     --  - 'ApiAnnotation.AnnImport'+     --+     --  - 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnClose' for ideclSource+     --+     --  - 'ApiAnnotation.AnnSafe','ApiAnnotation.AnnQualified',+     --    'ApiAnnotation.AnnPackageName','ApiAnnotation.AnnAs',+     --    'ApiAnnotation.AnnVal'+     --+     --  - 'ApiAnnotation.AnnHiding','ApiAnnotation.AnnOpen',+     --    'ApiAnnotation.AnnClose' attached+     --     to location in ideclHiding++     -- For details on above see note [Api annotations] in ApiAnnotation+       deriving Data++simpleImportDecl :: ModuleName -> ImportDecl name+simpleImportDecl mn = ImportDecl {+      ideclSourceSrc = NoSourceText,+      ideclName      = noLoc mn,+      ideclPkgQual   = Nothing,+      ideclSource    = False,+      ideclSafe      = False,+      ideclImplicit  = False,+      ideclQualified = False,+      ideclAs        = Nothing,+      ideclHiding    = Nothing+    }++instance (OutputableBndr name, HasOccName name) => Outputable (ImportDecl name) where+    ppr (ImportDecl { ideclSourceSrc = mSrcText, ideclName = mod'+                    , ideclPkgQual = pkg+                    , ideclSource = from, ideclSafe = safe+                    , ideclQualified = qual, ideclImplicit = implicit+                    , ideclAs = as, ideclHiding = spec })+      = hang (hsep [text "import", ppr_imp from, pp_implicit implicit, pp_safe safe,+                    pp_qual qual, pp_pkg pkg, ppr mod', pp_as as])+             4 (pp_spec spec)+      where+        pp_implicit False = empty+        pp_implicit True = ptext (sLit ("(implicit)"))++        pp_pkg Nothing                    = empty+        pp_pkg (Just (StringLiteral st p))+          = pprWithSourceText st (doubleQuotes (ftext p))++        pp_qual False   = empty+        pp_qual True    = text "qualified"++        pp_safe False   = empty+        pp_safe True    = text "safe"++        pp_as Nothing   = empty+        pp_as (Just a)  = text "as" <+> ppr a++        ppr_imp True  = case mSrcText of+                          NoSourceText   -> text "{-# SOURCE #-}"+                          SourceText src -> text src <+> text "#-}"+        ppr_imp False = empty++        pp_spec Nothing             = empty+        pp_spec (Just (False, (L _ ies))) = ppr_ies ies+        pp_spec (Just (True, (L _ ies))) = text "hiding" <+> ppr_ies ies++        ppr_ies []  = text "()"+        ppr_ies ies = char '(' <+> interpp'SP ies <+> char ')'++{-+************************************************************************+*                                                                      *+\subsection{Imported and exported entities}+*                                                                      *+************************************************************************+-}++-- | A name in an import or export specfication which may have adornments. Used+-- primarily for accurate pretty printing of ParsedSource, and API Annotation+-- placement.+data IEWrappedName name+  = IEName    (Located name)  -- ^ no extra+  | IEPattern (Located name)  -- ^ pattern X+  | IEType    (Located name)  -- ^ type (:+:)+  deriving (Eq,Data)++-- | Located name with possible adornment+-- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnType',+--         'ApiAnnotation.AnnPattern'+type LIEWrappedName name = Located (IEWrappedName name)+-- For details on above see note [Api annotations] in ApiAnnotation+++-- | Located Import or Export+type LIE name = Located (IE name)+        -- ^ When in a list this may have+        --+        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma'++        -- For details on above see note [Api annotations] in ApiAnnotation++-- | Imported or exported entity.+data IE name+  = IEVar       (LIEWrappedName name)+        -- ^ Imported or Exported Variable++  | IEThingAbs  (LIEWrappedName name)+        -- ^ Imported or exported Thing with Absent list+        --+        -- The thing is a Class/Type (can't tell)+        --  - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnPattern',+        --             'ApiAnnotation.AnnType','ApiAnnotation.AnnVal'++        -- For details on above see note [Api annotations] in ApiAnnotation+        -- See Note [Located RdrNames] in HsExpr+  | IEThingAll  (LIEWrappedName name)+        -- ^ Imported or exported Thing with All imported or exported+        --+        -- The thing is a Class/Type and the All refers to methods/constructors+        --+        -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen',+        --       'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose',+        --                                 'ApiAnnotation.AnnType'++        -- For details on above see note [Api annotations] in ApiAnnotation+        -- See Note [Located RdrNames] in HsExpr++  | IEThingWith (LIEWrappedName name)+                IEWildcard+                [LIEWrappedName name]+                [Located (FieldLbl name)]+        -- ^ Imported or exported Thing With given imported or exported+        --+        -- The thing is a Class/Type and the imported or exported things are+        -- methods/constructors and record fields; see Note [IEThingWith]+        -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen',+        --                                   'ApiAnnotation.AnnClose',+        --                                   'ApiAnnotation.AnnComma',+        --                                   'ApiAnnotation.AnnType'++        -- For details on above see note [Api annotations] in ApiAnnotation+  | IEModuleContents  (Located ModuleName)+        -- ^ Imported or exported module contents+        --+        -- (Export Only)+        --+        -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnModule'++        -- For details on above see note [Api annotations] in ApiAnnotation+  | IEGroup             Int HsDocString  -- ^ Doc section heading+  | IEDoc               HsDocString      -- ^ Some documentation+  | IEDocNamed          String           -- ^ Reference to named doc+  deriving (Eq, Data)++-- | Imported or Exported Wildcard+data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data)++{-+Note [IEThingWith]+~~~~~~~~~~~~~~~~~~++A definition like++    module M ( T(MkT, x) ) where+      data T = MkT { x :: Int }++gives rise to++    IEThingWith T [MkT] [FieldLabel "x" False x)]           (without DuplicateRecordFields)+    IEThingWith T [MkT] [FieldLabel "x" True $sel:x:MkT)]   (with    DuplicateRecordFields)++See Note [Representing fields in AvailInfo] in Avail for more details.+-}++ieName :: IE name -> name+ieName (IEVar (L _ n))              = ieWrappedName n+ieName (IEThingAbs  (L _ n))        = ieWrappedName n+ieName (IEThingWith (L _ n) _ _ _)  = ieWrappedName n+ieName (IEThingAll  (L _ n))        = ieWrappedName n+ieName _ = panic "ieName failed pattern match!"++ieNames :: IE a -> [a]+ieNames (IEVar       (L _ n)   )     = [ieWrappedName n]+ieNames (IEThingAbs  (L _ n)   )     = [ieWrappedName n]+ieNames (IEThingAll  (L _ n)   )     = [ieWrappedName n]+ieNames (IEThingWith (L _ n) _ ns _) = ieWrappedName n+                                       : map (ieWrappedName . unLoc) ns+ieNames (IEModuleContents _    )     = []+ieNames (IEGroup          _ _  )     = []+ieNames (IEDoc            _    )     = []+ieNames (IEDocNamed       _    )     = []++ieWrappedName :: IEWrappedName name -> name+ieWrappedName (IEName    (L _ n)) = n+ieWrappedName (IEPattern (L _ n)) = n+ieWrappedName (IEType    (L _ n)) = n++ieLWrappedName :: LIEWrappedName name -> Located name+ieLWrappedName (L l n) = L l (ieWrappedName n)++replaceWrappedName :: IEWrappedName name1 -> name2 -> IEWrappedName name2+replaceWrappedName (IEName    (L l _)) n = IEName    (L l n)+replaceWrappedName (IEPattern (L l _)) n = IEPattern (L l n)+replaceWrappedName (IEType    (L l _)) n = IEType    (L l n)++replaceLWrappedName :: LIEWrappedName name1 -> name2 -> LIEWrappedName name2+replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n')++instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where+    ppr (IEVar          var) = ppr (unLoc var)+    ppr (IEThingAbs     thing) = ppr (unLoc thing)+    ppr (IEThingAll     thing) = hcat [ppr (unLoc thing), text "(..)"]+    ppr (IEThingWith thing wc withs flds)+        = ppr (unLoc thing) <> parens (fsep (punctuate comma+                                              (ppWiths +++                                              map (ppr . flLabel . unLoc) flds)))+      where+        ppWiths =+          case wc of+              NoIEWildcard ->+                map (ppr . unLoc) withs+              IEWildcard pos ->+                let (bs, as) = splitAt pos (map (ppr . unLoc) withs)+                in bs ++ [text ".."] ++ as+    ppr (IEModuleContents mod')+        = text "module" <+> ppr mod'+    ppr (IEGroup n _)           = text ("<IEGroup: " ++ show n ++ ">")+    ppr (IEDoc doc)             = ppr doc+    ppr (IEDocNamed string)     = text ("<IEDocNamed: " ++ string ++ ">")++instance (HasOccName name) => HasOccName (IEWrappedName name) where+  occName w = occName (ieWrappedName w)++instance (OutputableBndr name, HasOccName name)+           => OutputableBndr (IEWrappedName name) where+  pprBndr bs   w = pprBndr bs   (ieWrappedName w)+  pprPrefixOcc w = pprPrefixOcc (ieWrappedName w)+  pprInfixOcc  w = pprInfixOcc  (ieWrappedName w)++instance (HasOccName name, OutputableBndr name)+            => Outputable (IEWrappedName name) where+  ppr (IEName    n) = pprPrefixOcc (unLoc n)+  ppr (IEPattern n) = text "pattern" <+> pprPrefixOcc (unLoc n)+  ppr (IEType    n) = text "type"    <+> pprPrefixOcc (unLoc n)++pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc+pprImpExp name = type_pref <+> pprPrefixOcc name+    where+    occ = occName name+    type_pref | isTcOcc occ && isSymOcc occ = text "type"+              | otherwise                   = empty
+ hsSyn/HsLit.hs view
@@ -0,0 +1,216 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[HsLit]{Abstract syntax: source-language literals}+-}++{-# LANGUAGE CPP, DeriveDataTypeable #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]+                                      -- in module PlaceHolder+{-# LANGUAGE ConstraintKinds #-}++module HsLit where++#include "HsVersions.h"++import {-# SOURCE #-} HsExpr( HsExpr, pprExpr )+import BasicTypes ( FractionalLit(..),SourceText(..),pprWithSourceText )+import Type       ( Type )+import Outputable+import FastString+import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId )++import Data.ByteString (ByteString)+import Data.Data hiding ( Fixity )++{-+************************************************************************+*                                                                      *+\subsection[HsLit]{Literals}+*                                                                      *+************************************************************************+-}++-- Note [Literal source text] in BasicTypes for SourceText fields in+-- the following+-- | Haskell Literal+data HsLit+  = HsChar          SourceText Char+      -- ^ Character+  | HsCharPrim      SourceText Char+      -- ^ Unboxed character+  | HsString        SourceText FastString+      -- ^ String+  | HsStringPrim    SourceText ByteString+      -- ^ Packed bytes+  | HsInt           SourceText Integer+      -- ^ Genuinely an Int; arises from+      -- @TcGenDeriv@, and from TRANSLATION+  | HsIntPrim       SourceText Integer+      -- ^ literal @Int#@+  | HsWordPrim      SourceText Integer+      -- ^ literal @Word#@+  | HsInt64Prim     SourceText Integer+      -- ^ literal @Int64#@+  | HsWord64Prim    SourceText Integer+      -- ^ literal @Word64#@+  | HsInteger       SourceText Integer Type+      -- ^ Genuinely an integer; arises only+      -- from TRANSLATION (overloaded+      -- literals are done with HsOverLit)+  | HsRat           FractionalLit Type+      -- ^ Genuinely a rational; arises only from+      -- TRANSLATION (overloaded literals are+      -- done with HsOverLit)+  | HsFloatPrim     FractionalLit+      -- ^ Unboxed Float+  | HsDoublePrim    FractionalLit+      -- ^ Unboxed Double+  deriving Data++instance Eq HsLit where+  (HsChar _ x1)       == (HsChar _ x2)       = x1==x2+  (HsCharPrim _ x1)   == (HsCharPrim _ x2)   = x1==x2+  (HsString _ x1)     == (HsString _ x2)     = x1==x2+  (HsStringPrim _ x1) == (HsStringPrim _ x2) = x1==x2+  (HsInt _ x1)        == (HsInt _ x2)        = x1==x2+  (HsIntPrim _ x1)    == (HsIntPrim _ x2)    = x1==x2+  (HsWordPrim _ x1)   == (HsWordPrim _ x2)   = x1==x2+  (HsInt64Prim _ x1)  == (HsInt64Prim _ x2)  = x1==x2+  (HsWord64Prim _ x1) == (HsWord64Prim _ x2) = x1==x2+  (HsInteger _ x1 _)  == (HsInteger _ x2 _)  = x1==x2+  (HsRat x1 _)        == (HsRat x2 _)        = x1==x2+  (HsFloatPrim x1)    == (HsFloatPrim x2)    = x1==x2+  (HsDoublePrim x1)   == (HsDoublePrim x2)   = x1==x2+  _                   == _                   = False++-- | Haskell Overloaded Literal+data HsOverLit id+  = OverLit {+        ol_val :: OverLitVal,+        ol_rebindable :: PostRn id Bool, -- Note [ol_rebindable]+        ol_witness :: HsExpr id,     -- Note [Overloaded literal witnesses]+        ol_type :: PostTc id Type }+deriving instance (DataId id) => Data (HsOverLit id)++-- Note [Literal source text] in BasicTypes for SourceText fields in+-- the following+-- | Overloaded Literal Value+data OverLitVal+  = HsIntegral   !SourceText !Integer    -- ^ Integer-looking literals;+  | HsFractional !FractionalLit          -- ^ Frac-looking literals+  | HsIsString   !SourceText !FastString -- ^ String-looking literals+  deriving Data++overLitType :: HsOverLit a -> PostTc a Type+overLitType = ol_type++{-+Note [ol_rebindable]+~~~~~~~~~~~~~~~~~~~~+The ol_rebindable field is True if this literal is actually+using rebindable syntax.  Specifically:++  False iff ol_witness is the standard one+  True  iff ol_witness is non-standard++Equivalently it's True if+  a) RebindableSyntax is on+  b) the witness for fromInteger/fromRational/fromString+     that happens to be in scope isn't the standard one++Note [Overloaded literal witnesses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+*Before* type checking, the HsExpr in an HsOverLit is the+name of the coercion function, 'fromInteger' or 'fromRational'.+*After* type checking, it is a witness for the literal, such as+        (fromInteger 3) or lit_78+This witness should replace the literal.++This dual role is unusual, because we're replacing 'fromInteger' with+a call to fromInteger.  Reason: it allows commoning up of the fromInteger+calls, which wouldn't be possible if the desguarar made the application.++The PostTcType in each branch records the type the overload literal is+found to have.+-}++-- Comparison operations are needed when grouping literals+-- for compiling pattern-matching (module MatchLit)+instance Eq (HsOverLit id) where+  (OverLit {ol_val = val1}) == (OverLit {ol_val=val2}) = val1 == val2++instance Eq OverLitVal where+  (HsIntegral _ i1)   == (HsIntegral _ i2)   = i1 == i2+  (HsFractional f1)   == (HsFractional f2)   = f1 == f2+  (HsIsString _ s1)   == (HsIsString _ s2)   = s1 == s2+  _                   == _                   = False++instance Ord (HsOverLit id) where+  compare (OverLit {ol_val=val1}) (OverLit {ol_val=val2}) = val1 `compare` val2++instance Ord OverLitVal where+  compare (HsIntegral _ i1)   (HsIntegral _ i2)   = i1 `compare` i2+  compare (HsIntegral _ _)    (HsFractional _)    = LT+  compare (HsIntegral _ _)    (HsIsString _ _)    = LT+  compare (HsFractional f1)   (HsFractional f2)   = f1 `compare` f2+  compare (HsFractional _)    (HsIntegral _ _)    = GT+  compare (HsFractional _)    (HsIsString _ _)    = LT+  compare (HsIsString _ s1)   (HsIsString _ s2)   = s1 `compare` s2+  compare (HsIsString _ _)    (HsIntegral _ _)    = GT+  compare (HsIsString _ _)    (HsFractional _)    = GT++instance Outputable HsLit where+    ppr (HsChar st c)       = pprWithSourceText st (pprHsChar c)+    ppr (HsCharPrim st c)   = pp_st_suffix st primCharSuffix (pprPrimChar c)+    ppr (HsString st s)     = pprWithSourceText st (pprHsString s)+    ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s)+    ppr (HsInt st i)        = pprWithSourceText st (integer i)+    ppr (HsInteger st i _)  = pprWithSourceText st (integer i)+    ppr (HsRat f _)         = ppr f+    ppr (HsFloatPrim f)     = ppr f <> primFloatSuffix+    ppr (HsDoublePrim d)    = ppr d <> primDoubleSuffix+    ppr (HsIntPrim st i)    = pprWithSourceText st (pprPrimInt i)+    ppr (HsWordPrim st w)   = pprWithSourceText st (pprPrimWord w)+    ppr (HsInt64Prim st i)  = pp_st_suffix st primInt64Suffix  (pprPrimInt64 i)+    ppr (HsWord64Prim st w) = pp_st_suffix st primWord64Suffix (pprPrimWord64 w)++pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc+pp_st_suffix NoSourceText         _ doc = doc+pp_st_suffix (SourceText st) suffix _   = text st <> suffix++-- in debug mode, print the expression that it's resolved to, too+instance (OutputableBndrId id) => Outputable (HsOverLit id) where+  ppr (OverLit {ol_val=val, ol_witness=witness})+        = ppr val <+> (ifPprDebug (parens (pprExpr witness)))++instance Outputable OverLitVal where+  ppr (HsIntegral st i)  = pprWithSourceText st (integer i)+  ppr (HsFractional f)   = ppr f+  ppr (HsIsString st s)  = pprWithSourceText st (pprHsString s)++-- | pmPprHsLit pretty prints literals and is used when pretty printing pattern+-- match warnings. All are printed the same (i.e., without hashes if they are+-- primitive and not wrapped in constructors if they are boxed). This happens+-- mainly for too reasons:+--  * We do not want to expose their internal representation+--  * The warnings become too messy+pmPprHsLit :: HsLit -> SDoc+pmPprHsLit (HsChar _ c)       = pprHsChar c+pmPprHsLit (HsCharPrim _ c)   = pprHsChar c+pmPprHsLit (HsString st s)    = pprWithSourceText st (pprHsString s)+pmPprHsLit (HsStringPrim _ s) = pprHsBytes s+pmPprHsLit (HsInt _ i)        = integer i+pmPprHsLit (HsIntPrim _ i)    = integer i+pmPprHsLit (HsWordPrim _ w)   = integer w+pmPprHsLit (HsInt64Prim _ i)  = integer i+pmPprHsLit (HsWord64Prim _ w) = integer w+pmPprHsLit (HsInteger _ i _)  = integer i+pmPprHsLit (HsRat f _)        = ppr f+pmPprHsLit (HsFloatPrim f)    = ppr f+pmPprHsLit (HsDoublePrim d)   = ppr d
+ hsSyn/HsPat.hs view
@@ -0,0 +1,698 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[PatSyntax]{Abstract Haskell syntax---patterns}+-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]+                                      -- in module PlaceHolder+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}++module HsPat (+        Pat(..), InPat, OutPat, LPat,++        HsConPatDetails, hsConPatArgs,+        HsRecFields(..), HsRecField'(..), LHsRecField',+        HsRecField, LHsRecField,+        HsRecUpdField, LHsRecUpdField,+        hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs,+        hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr,++        mkPrefixConPat, mkCharLitPat, mkNilPat,++        looksLazyPatBind,+        isBangedLPat, isBangedPatBind,+        hsPatNeedsParens,+        isIrrefutableHsPat,++        collectEvVarsPats,++        pprParendLPat, pprConArgs+    ) where++import {-# SOURCE #-} HsExpr            (SyntaxExpr, LHsExpr, HsSplice, pprLExpr, pprSplice)++-- friends:+import HsBinds+import HsLit+import PlaceHolder+import HsTypes+import TcEvidence+import BasicTypes+-- others:+import PprCore          ( {- instance OutputableBndr TyVar -} )+import TysWiredIn+import Var+import RdrName ( RdrName )+import ConLike+import DataCon+import TyCon+import Outputable+import Type+import SrcLoc+import Bag -- collect ev vars from pats+import DynFlags( gopt, GeneralFlag(..) )+import Maybes+-- libraries:+import Data.Data hiding (TyCon,Fixity)++type InPat id  = LPat id        -- No 'Out' constructors+type OutPat id = LPat id        -- No 'In' constructors++type LPat id = Located (Pat id)++-- | Pattern+--+-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang'++-- For details on above see note [Api annotations] in ApiAnnotation+data Pat id+  =     ------------ Simple patterns ---------------+    WildPat     (PostTc id Type)        -- ^ Wildcard Pattern+        -- The sole reason for a type on a WildPat is to+        -- support hsPatType :: Pat Id -> Type++  | VarPat      (Located id) -- ^ Variable Pattern++                             -- See Note [Located RdrNames] in HsExpr+  | LazyPat     (LPat id)               -- ^ Lazy Pattern+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'++    -- For details on above see note [Api annotations] in ApiAnnotation++  | AsPat       (Located id) (LPat id)  -- ^ As pattern+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'++    -- For details on above see note [Api annotations] in ApiAnnotation++  | ParPat      (LPat id)               -- ^ Parenthesised pattern+                                        -- See Note [Parens in HsSyn] in HsExpr+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,+    --                                    'ApiAnnotation.AnnClose' @')'@++    -- For details on above see note [Api annotations] in ApiAnnotation+  | BangPat     (LPat id)               -- ^ Bang pattern+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang'++    -- For details on above see note [Api annotations] in ApiAnnotation++        ------------ Lists, tuples, arrays ---------------+  | ListPat     [LPat id]+                (PostTc id Type)                        -- The type of the elements+                (Maybe (PostTc id Type, SyntaxExpr id)) -- For rebindable syntax+                   -- For OverloadedLists a Just (ty,fn) gives+                   -- overall type of the pattern, and the toList+                   -- function to convert the scrutinee to a list value+    -- ^ Syntactic List+    --+    -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,+    --                                    'ApiAnnotation.AnnClose' @']'@++    -- For details on above see note [Api annotations] in ApiAnnotation++  | TuplePat    [LPat id]        -- Tuple sub-patterns+                Boxity           -- UnitPat is TuplePat []+                [PostTc id Type] -- [] before typechecker, filled in afterwards+                                 -- with the types of the tuple components+        -- You might think that the PostTc id Type was redundant, because we can+        -- get the pattern type by getting the types of the sub-patterns.+        -- But it's essential+        --      data T a where+        --        T1 :: Int -> T Int+        --      f :: (T a, a) -> Int+        --      f (T1 x, z) = z+        -- When desugaring, we must generate+        --      f = /\a. \v::a.  case v of (t::T a, w::a) ->+        --                       case t of (T1 (x::Int)) ->+        -- Note the (w::a), NOT (w::Int), because we have not yet+        -- refined 'a' to Int.  So we must know that the second component+        -- of the tuple is of type 'a' not Int.  See selectMatchVar+        -- (June 14: I'm not sure this comment is right; the sub-patterns+        --           will be wrapped in CoPats, no?)+    -- ^ Tuple sub-patterns+    --+    -- - 'ApiAnnotation.AnnKeywordId' :+    --            'ApiAnnotation.AnnOpen' @'('@ or @'(#'@,+    --            'ApiAnnotation.AnnClose' @')'@ or  @'#)'@++  | SumPat      (LPat id)          -- Sum sub-pattern+                ConTag             -- Alternative (one-based)+                Arity              -- Arity+                (PostTc id [Type]) -- PlaceHolder before typechecker, filled in+                                   -- afterwards with the types of the+                                   -- alternative+    -- ^ Anonymous sum pattern+    --+    -- - 'ApiAnnotation.AnnKeywordId' :+    --            'ApiAnnotation.AnnOpen' @'(#'@,+    --            'ApiAnnotation.AnnClose' @'#)'@++    -- For details on above see note [Api annotations] in ApiAnnotation+  | PArrPat     [LPat id]               -- Syntactic parallel array+                (PostTc id Type)        -- The type of the elements+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,+    --                                    'ApiAnnotation.AnnClose' @':]'@++    -- For details on above see note [Api annotations] in ApiAnnotation+        ------------ Constructor patterns ---------------+  | ConPatIn    (Located id)+                (HsConPatDetails id)+    -- ^ Constructor Pattern In++  | ConPatOut {+        pat_con     :: Located ConLike,+        pat_arg_tys :: [Type],          -- The universal arg types, 1-1 with the universal+                                        -- tyvars of the constructor/pattern synonym+                                        --   Use (conLikeResTy pat_con pat_arg_tys) to get+                                        --   the type of the pattern++        pat_tvs   :: [TyVar],           -- Existentially bound type variables+                                        -- in correctly-scoped order e.g. [k:*, x:k]+        pat_dicts :: [EvVar],           -- Ditto *coercion variables* and *dictionaries*+                                        -- One reason for putting coercion variable here, I think,+                                        --      is to ensure their kinds are zonked++        pat_binds :: TcEvBinds,         -- Bindings involving those dictionaries+        pat_args  :: HsConPatDetails id,+        pat_wrap  :: HsWrapper          -- Extra wrapper to pass to the matcher+                                        -- Only relevant for pattern-synonyms;+                                        --   ignored for data cons+    }+    -- ^ Constructor Pattern Out++        ------------ View patterns ---------------+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'++  -- For details on above see note [Api annotations] in ApiAnnotation+  | ViewPat       (LHsExpr id)+                  (LPat id)+                  (PostTc id Type)  -- The overall type of the pattern+                                    -- (= the argument type of the view function)+                                    -- for hsPatType.+    -- ^ View Pattern++        ------------ Pattern splices ---------------+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@+  --        'ApiAnnotation.AnnClose' @')'@++  -- For details on above see note [Api annotations] in ApiAnnotation+  | SplicePat       (HsSplice id)   -- ^ Splice Pattern (Includes quasi-quotes)++        ------------ Literal and n+k patterns ---------------+  | LitPat          HsLit               -- ^ Literal Pattern+                                        -- Used for *non-overloaded* literal patterns:+                                        -- Int#, Char#, Int, Char, String, etc.++  | NPat                -- Natural Pattern+                        -- Used for all overloaded literals,+                        -- including overloaded strings with -XOverloadedStrings+                    (Located (HsOverLit id))    -- ALWAYS positive+                    (Maybe (SyntaxExpr id))     -- Just (Name of 'negate') for negative+                                                -- patterns, Nothing otherwise+                    (SyntaxExpr id)             -- Equality checker, of type t->t->Bool+                    (PostTc id Type)            -- Overall type of pattern. Might be+                                                -- different than the literal's type+                                                -- if (==) or negate changes the type++  -- ^ Natural Pattern+  --+  -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@++  -- For details on above see note [Api annotations] in ApiAnnotation+  | NPlusKPat       (Located id)        -- n+k pattern+                    (Located (HsOverLit id)) -- It'll always be an HsIntegral+                    (HsOverLit id)      -- See Note [NPlusK patterns] in TcPat+                     -- NB: This could be (PostTc ...), but that induced a+                     -- a new hs-boot file. Not worth it.++                    (SyntaxExpr id)     -- (>=) function, of type t1->t2->Bool+                    (SyntaxExpr id)     -- Name of '-' (see RnEnv.lookupSyntaxName)+                    (PostTc id Type)    -- Type of overall pattern+  -- ^ n+k pattern++        ------------ Pattern type signatures ---------------+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'++  -- For details on above see note [Api annotations] in ApiAnnotation+  | SigPatIn        (LPat id)                 -- Pattern with a type signature+                    (LHsSigWcType id)         -- Signature can bind both+                                              -- kind and type vars+    -- ^ Pattern with a type signature++  | SigPatOut       (LPat id)+                    Type+    -- ^ Pattern with a type signature++        ------------ Pattern coercions (translation only) ---------------+  | CoPat       HsWrapper               -- Coercion Pattern+                                        -- If co :: t1 ~ t2, p :: t2,+                                        -- then (CoPat co p) :: t1+                (Pat id)                -- Why not LPat?  Ans: existing locn will do+                Type                    -- Type of whole pattern, t1+        -- During desugaring a (CoPat co pat) turns into a cast with 'co' on+        -- the scrutinee, followed by a match on 'pat'+    -- ^ Coercion Pattern+deriving instance (DataId id) => Data (Pat id)++-- | Haskell Constructor Pattern Details+type HsConPatDetails id = HsConDetails (LPat id) (HsRecFields id (LPat id))++hsConPatArgs :: HsConPatDetails id -> [LPat id]+hsConPatArgs (PrefixCon ps)   = ps+hsConPatArgs (RecCon fs)      = map (hsRecFieldArg . unLoc) (rec_flds fs)+hsConPatArgs (InfixCon p1 p2) = [p1,p2]++-- | Haskell Record Fields+--+-- HsRecFields is used only for patterns and expressions (not data type+-- declarations)+data HsRecFields id arg         -- A bunch of record fields+                                --      { x = 3, y = True }+        -- Used for both expressions and patterns+  = HsRecFields { rec_flds   :: [LHsRecField id arg],+                  rec_dotdot :: Maybe Int }  -- Note [DotDot fields]+  deriving (Functor, Foldable, Traversable)+deriving instance (DataId id, Data arg) => Data (HsRecFields id arg)+++-- Note [DotDot fields]+-- ~~~~~~~~~~~~~~~~~~~~+-- The rec_dotdot field means this:+--   Nothing => the normal case+--   Just n  => the group uses ".." notation,+--+-- In the latter case:+--+--   *before* renamer: rec_flds are exactly the n user-written fields+--+--   *after* renamer:  rec_flds includes *all* fields, with+--                     the first 'n' being the user-written ones+--                     and the remainder being 'filled in' implicitly++-- | Located Haskell Record Field+type LHsRecField' id arg = Located (HsRecField' id arg)++-- | Located Haskell Record Field+type LHsRecField  id arg = Located (HsRecField  id arg)++-- | Located Haskell Record Update Field+type LHsRecUpdField id   = Located (HsRecUpdField id)++-- | Haskell Record Field+type HsRecField    id arg = HsRecField' (FieldOcc id) arg++-- | Haskell Record Update Field+type HsRecUpdField id     = HsRecField' (AmbiguousFieldOcc id) (LHsExpr id)++-- | Haskell Record Field+--+-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual',+--+-- For details on above see note [Api annotations] in ApiAnnotation+data HsRecField' id arg = HsRecField {+        hsRecFieldLbl :: Located id,+        hsRecFieldArg :: arg,           -- ^ Filled in by renamer when punning+        hsRecPun      :: Bool           -- ^ Note [Punning]+  } deriving (Data, Functor, Foldable, Traversable)+++-- Note [Punning]+-- ~~~~~~~~~~~~~~+-- If you write T { x, y = v+1 }, the HsRecFields will be+--      HsRecField x x True ...+--      HsRecField y (v+1) False ...+-- That is, for "punned" field x is expanded (in the renamer)+-- to x=x; but with a punning flag so we can detect it later+-- (e.g. when pretty printing)+--+-- If the original field was qualified, we un-qualify it, thus+--    T { A.x } means T { A.x = x }+++-- Note [HsRecField and HsRecUpdField]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++-- A HsRecField (used for record construction and pattern matching)+-- contains an unambiguous occurrence of a field (i.e. a FieldOcc).+-- We can't just store the Name, because thanks to+-- DuplicateRecordFields this may not correspond to the label the user+-- wrote.+--+-- A HsRecUpdField (used for record update) contains a potentially+-- ambiguous occurrence of a field (an AmbiguousFieldOcc).  The+-- renamer will fill in the selector function if it can, but if the+-- selector is ambiguous the renamer will defer to the typechecker.+-- After the typechecker, a unique selector will have been determined.+--+-- The renamer produces an Unambiguous result if it can, rather than+-- just doing the lookup in the typechecker, so that completely+-- unambiguous updates can be represented by 'DsMeta.repUpdFields'.+--+-- For example, suppose we have:+--+--     data S = MkS { x :: Int }+--     data T = MkT { x :: Int }+--+--     f z = (z { x = 3 }) :: S+--+-- The parsed HsRecUpdField corresponding to the record update will have:+--+--     hsRecFieldLbl = Unambiguous "x" PlaceHolder :: AmbiguousFieldOcc RdrName+--+-- After the renamer, this will become:+--+--     hsRecFieldLbl = Ambiguous   "x" PlaceHolder :: AmbiguousFieldOcc Name+--+-- (note that the Unambiguous constructor is not type-correct here).+-- The typechecker will determine the particular selector:+--+--     hsRecFieldLbl = Unambiguous "x" $sel:x:MkS  :: AmbiguousFieldOcc Id+--+-- See also Note [Disambiguating record fields] in TcExpr.++hsRecFields :: HsRecFields id arg -> [PostRn id id]+hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds)++-- Probably won't typecheck at once, things have changed :/+hsRecFieldsArgs :: HsRecFields id arg -> [arg]+hsRecFieldsArgs rbinds = map (hsRecFieldArg . unLoc) (rec_flds rbinds)++hsRecFieldSel :: HsRecField name arg -> Located (PostRn name name)+hsRecFieldSel = fmap selectorFieldOcc . hsRecFieldLbl++hsRecFieldId :: HsRecField Id arg -> Located Id+hsRecFieldId = hsRecFieldSel++hsRecUpdFieldRdr :: HsRecUpdField id -> Located RdrName+hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl++hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc Id) arg -> Located Id+hsRecUpdFieldId = fmap selectorFieldOcc . hsRecUpdFieldOcc++hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc Id) arg -> LFieldOcc Id+hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl+++{-+************************************************************************+*                                                                      *+*              Printing patterns+*                                                                      *+************************************************************************+-}++instance (OutputableBndrId name) => Outputable (Pat name) where+    ppr = pprPat++pprPatBndr :: OutputableBndr name => name -> SDoc+pprPatBndr var                  -- Print with type info if -dppr-debug is on+  = getPprStyle $ \ sty ->+    if debugStyle sty then+        parens (pprBndr LambdaBind var)         -- Could pass the site to pprPat+                                                -- but is it worth it?+    else+        pprPrefixOcc var++pprParendLPat :: (OutputableBndrId name) => LPat name -> SDoc+pprParendLPat (L _ p) = pprParendPat p++pprParendPat :: (OutputableBndrId name) => Pat name -> SDoc+pprParendPat p = sdocWithDynFlags $ \ dflags ->+                 if need_parens dflags p+                 then parens (pprPat p)+                 else  pprPat p+  where+    need_parens dflags p+      | CoPat {} <- p = gopt Opt_PrintTypecheckerElaboration dflags+      | otherwise     = hsPatNeedsParens p+      -- For a CoPat we need parens if we are going to show it, which+      -- we do if -fprint-typechecker-elaboration is on (c.f. pprHsWrapper)+      -- But otherwise the CoPat is discarded, so it+      -- is the pattern inside that matters.  Sigh.++pprPat :: (OutputableBndrId name) => Pat name -> SDoc+pprPat (VarPat (L _ var))     = pprPatBndr var+pprPat (WildPat _)            = char '_'+pprPat (LazyPat pat)          = char '~' <> pprParendLPat pat+pprPat (BangPat pat)          = char '!' <> pprParendLPat pat+pprPat (AsPat name pat)       = hcat [pprPrefixOcc (unLoc name), char '@', pprParendLPat pat]+pprPat (ViewPat expr pat _)   = hcat [pprLExpr expr, text " -> ", ppr pat]+pprPat (ParPat pat)           = parens (ppr pat)+pprPat (LitPat s)             = ppr s+pprPat (NPat l Nothing  _ _)  = ppr l+pprPat (NPat l (Just _) _ _)  = char '-' <> ppr l+pprPat (NPlusKPat n k _ _ _ _)= hcat [ppr n, char '+', ppr k]+pprPat (SplicePat splice)     = pprSplice splice+pprPat (CoPat co pat _)       = pprHsWrapper co (\parens -> if parens+                                                            then pprParendPat pat+                                                            else pprPat pat)+pprPat (SigPatIn pat ty)      = ppr pat <+> dcolon <+> ppr ty+pprPat (SigPatOut pat ty)     = ppr pat <+> dcolon <+> ppr ty+pprPat (ListPat pats _ _)     = brackets (interpp'SP pats)+pprPat (PArrPat pats _)       = paBrackets (interpp'SP pats)+pprPat (TuplePat pats bx _)   = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats)+pprPat (SumPat pat alt arity _) = sumParens (pprAlternative ppr pat alt arity)+pprPat (ConPatIn con details) = pprUserCon (unLoc con) details+pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,+                    pat_binds = binds, pat_args = details })+  = sdocWithDynFlags $ \dflags ->+       -- Tiresome; in TcBinds.tcRhs we print out a+       -- typechecked Pat in an error message,+       -- and we want to make sure it prints nicely+    if gopt Opt_PrintTypecheckerElaboration dflags then+        ppr con+          <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))+                         , ppr binds])+          <+> pprConArgs details+    else pprUserCon (unLoc con) details+++pprUserCon :: (OutputableBndr con, OutputableBndrId id)+           => con -> HsConPatDetails id -> SDoc+pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2+pprUserCon c details          = pprPrefixOcc c <+> pprConArgs details++pprConArgs :: (OutputableBndrId id) => HsConPatDetails id -> SDoc+pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats)+pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2]+pprConArgs (RecCon rpats)   = ppr rpats++instance (Outputable arg)+      => Outputable (HsRecFields id arg) where+  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing })+        = braces (fsep (punctuate comma (map ppr flds)))+  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just n })+        = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot])))+        where+          dotdot = text ".." <+> ifPprDebug (ppr (drop n flds))++instance (Outputable id, Outputable arg)+      => Outputable (HsRecField' id arg) where+  ppr (HsRecField { hsRecFieldLbl = f, hsRecFieldArg = arg,+                    hsRecPun = pun })+    = ppr f <+> (ppUnless pun $ equals <+> ppr arg)+++{-+************************************************************************+*                                                                      *+*              Building patterns+*                                                                      *+************************************************************************+-}++mkPrefixConPat :: DataCon -> [OutPat id] -> [Type] -> OutPat id+-- Make a vanilla Prefix constructor pattern+mkPrefixConPat dc pats tys+  = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc), pat_tvs = [], pat_dicts = [],+                        pat_binds = emptyTcEvBinds, pat_args = PrefixCon pats,+                        pat_arg_tys = tys, pat_wrap = idHsWrapper }++mkNilPat :: Type -> OutPat id+mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]++mkCharLitPat :: SourceText -> Char -> OutPat id+mkCharLitPat src c = mkPrefixConPat charDataCon+                                    [noLoc $ LitPat (HsCharPrim src c)] []++{-+************************************************************************+*                                                                      *+* Predicates for checking things about pattern-lists in EquationInfo   *+*                                                                      *+************************************************************************++\subsection[Pat-list-predicates]{Look for interesting things in patterns}++Unlike in the Wadler chapter, where patterns are either ``variables''+or ``constructors,'' here we distinguish between:+\begin{description}+\item[unfailable:]+Patterns that cannot fail to match: variables, wildcards, and lazy+patterns.++These are the irrefutable patterns; the two other categories+are refutable patterns.++\item[constructor:]+A non-literal constructor pattern (see next category).++\item[literal patterns:]+At least the numeric ones may be overloaded.+\end{description}++A pattern is in {\em exactly one} of the above three categories; `as'+patterns are treated specially, of course.++The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.+-}++isBangedPatBind :: HsBind id -> Bool+isBangedPatBind (PatBind {pat_lhs = pat}) = isBangedLPat pat+isBangedPatBind _ = False++isBangedLPat :: LPat id -> Bool+isBangedLPat (L _ (ParPat p))   = isBangedLPat p+isBangedLPat (L _ (BangPat {})) = True+isBangedLPat _                  = False++looksLazyPatBind :: HsBind id -> Bool+-- Returns True of anything *except*+--     a StrictHsBind (as above) or+--     a VarPat+-- In particular, returns True of a pattern binding with a compound pattern, like (I# x)+-- Looks through AbsBinds+looksLazyPatBind (PatBind { pat_lhs = p })+  = looksLazyLPat p+looksLazyPatBind (AbsBinds { abs_binds = binds })+  = anyBag (looksLazyPatBind . unLoc) binds+looksLazyPatBind (AbsBindsSig { abs_sig_bind = L _ bind })+  = looksLazyPatBind bind+looksLazyPatBind _+  = False++looksLazyLPat :: LPat id -> Bool+looksLazyLPat (L _ (ParPat p))             = looksLazyLPat p+looksLazyLPat (L _ (AsPat _ p))            = looksLazyLPat p+looksLazyLPat (L _ (BangPat {}))           = False+looksLazyLPat (L _ (VarPat {}))            = False+looksLazyLPat (L _ (WildPat {}))           = False+looksLazyLPat _                            = True++isIrrefutableHsPat :: (OutputableBndrId id) => LPat id -> Bool+-- (isIrrefutableHsPat p) is true if matching against p cannot fail,+-- in the sense of falling through to the next pattern.+--      (NB: this is not quite the same as the (silly) defn+--      in 3.17.2 of the Haskell 98 report.)+--+-- WARNING: isIrrefutableHsPat returns False if it's in doubt.+-- Specifically on a ConPatIn, which is what it sees for a+-- (LPat Name) in the renamer, it doesn't know the size of the+-- constructor family, so it returns False.  Result: only+-- tuple patterns are considered irrefuable at the renamer stage.+--+-- But if it returns True, the pattern is definitely irrefutable+isIrrefutableHsPat pat+  = go pat+  where+    go (L _ pat) = go1 pat++    go1 (WildPat {})        = True+    go1 (VarPat {})         = True+    go1 (LazyPat {})        = True+    go1 (BangPat pat)       = go pat+    go1 (CoPat _ pat _)     = go1 pat+    go1 (ParPat pat)        = go pat+    go1 (AsPat _ pat)       = go pat+    go1 (ViewPat _ pat _)   = go pat+    go1 (SigPatIn pat _)    = go pat+    go1 (SigPatOut pat _)   = go pat+    go1 (TuplePat pats _ _) = all go pats+    go1 (SumPat pat _ _  _) = go pat+    go1 (ListPat {})        = False+    go1 (PArrPat {})        = False     -- ?++    go1 (ConPatIn {})       = False     -- Conservative+    go1 (ConPatOut{ pat_con = L _ (RealDataCon con), pat_args = details })+        =  isJust (tyConSingleDataCon_maybe (dataConTyCon con))+           -- NB: tyConSingleDataCon_maybe, *not* isProductTyCon, because+           -- the latter is false of existentials. See Trac #4439+        && all go (hsConPatArgs details)+    go1 (ConPatOut{ pat_con = L _ (PatSynCon _pat) })+        = False -- Conservative++    go1 (LitPat {})         = False+    go1 (NPat {})           = False+    go1 (NPlusKPat {})      = False++    -- We conservatively assume that no TH splices are irrefutable+    -- since we cannot know until the splice is evaluated.+    go1 (SplicePat {})      = False++hsPatNeedsParens :: Pat a -> Bool+hsPatNeedsParens (NPlusKPat {})      = True+hsPatNeedsParens (SplicePat {})      = False+hsPatNeedsParens (ConPatIn _ ds)     = conPatNeedsParens ds+hsPatNeedsParens p@(ConPatOut {})    = conPatNeedsParens (pat_args p)+hsPatNeedsParens (SigPatIn {})       = True+hsPatNeedsParens (SigPatOut {})      = True+hsPatNeedsParens (ViewPat {})        = True+hsPatNeedsParens (CoPat _ p _)       = hsPatNeedsParens p+hsPatNeedsParens (WildPat {})        = False+hsPatNeedsParens (VarPat {})         = False+hsPatNeedsParens (LazyPat {})        = False+hsPatNeedsParens (BangPat {})        = False+hsPatNeedsParens (ParPat {})         = False+hsPatNeedsParens (AsPat {})          = False+hsPatNeedsParens (TuplePat {})       = False+hsPatNeedsParens (SumPat {})         = False+hsPatNeedsParens (ListPat {})        = False+hsPatNeedsParens (PArrPat {})        = False+hsPatNeedsParens (LitPat {})         = False+hsPatNeedsParens (NPat {})           = False++conPatNeedsParens :: HsConDetails a b -> Bool+conPatNeedsParens (PrefixCon {}) = False+conPatNeedsParens (InfixCon {})  = True+conPatNeedsParens (RecCon {})    = False++{-+% Collect all EvVars from all constructor patterns+-}++-- May need to add more cases+collectEvVarsPats :: [Pat id] -> Bag EvVar+collectEvVarsPats = unionManyBags . map collectEvVarsPat++collectEvVarsLPat :: LPat id -> Bag EvVar+collectEvVarsLPat (L _ pat) = collectEvVarsPat pat++collectEvVarsPat :: Pat id -> Bag EvVar+collectEvVarsPat pat =+  case pat of+    LazyPat  p        -> collectEvVarsLPat p+    AsPat _  p        -> collectEvVarsLPat p+    ParPat   p        -> collectEvVarsLPat p+    BangPat  p        -> collectEvVarsLPat p+    ListPat  ps _ _   -> unionManyBags $ map collectEvVarsLPat ps+    TuplePat ps _ _   -> unionManyBags $ map collectEvVarsLPat ps+    SumPat p _ _ _    -> collectEvVarsLPat p+    PArrPat  ps _     -> unionManyBags $ map collectEvVarsLPat ps+    ConPatOut {pat_dicts = dicts, pat_args  = args}+                      -> unionBags (listToBag dicts)+                                   $ unionManyBags+                                   $ map collectEvVarsLPat+                                   $ hsConPatArgs args+    SigPatOut p _     -> collectEvVarsLPat p+    CoPat _ p _       -> collectEvVarsPat  p+    ConPatIn _  _     -> panic "foldMapPatBag: ConPatIn"+    SigPatIn _ _      -> panic "foldMapPatBag: SigPatIn"+    _other_pat        -> emptyBag
+ hsSyn/HsPat.hs-boot view
@@ -0,0 +1,20 @@+{-# LANGUAGE CPP, KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]+                                      -- in module PlaceHolder+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE RoleAnnotations #-}++module HsPat where+import SrcLoc( Located )++import Data.Data hiding (Fixity)+import Outputable+import PlaceHolder      ( DataId, OutputableBndrId )++type role Pat nominal+data Pat (i :: *)+type LPat i = Located (Pat i)++instance (DataId id) => Data (Pat id)+instance (OutputableBndrId name) => Outputable (Pat name)
+ hsSyn/HsSyn.hs view
@@ -0,0 +1,145 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section{Haskell abstract syntax definition}++This module glues together the pieces of the Haskell abstract syntax,+which is declared in the various \tr{Hs*} modules.  This module,+therefore, is almost nothing but re-exporting.+-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]+                                      -- in module PlaceHolder+{-# LANGUAGE ConstraintKinds #-}++module HsSyn (+        module HsBinds,+        module HsDecls,+        module HsExpr,+        module HsImpExp,+        module HsLit,+        module HsPat,+        module HsTypes,+        module HsUtils,+        module HsDoc,+        module PlaceHolder,+        Fixity,++        HsModule(..)+) where++-- friends:+import HsDecls+import HsBinds+import HsExpr+import HsImpExp+import HsLit+import PlaceHolder+import HsPat+import HsTypes+import BasicTypes       ( Fixity, WarningTxt )+import HsUtils+import HsDoc+import OccName          ( HasOccName(..) )++-- others:+import Outputable+import SrcLoc+import Module           ( ModuleName )++-- libraries:+import Data.Data hiding ( Fixity )++-- | Haskell Module+--+-- All we actually declare here is the top-level structure for a module.+data HsModule name+  = HsModule {+      hsmodName :: Maybe (Located ModuleName),+        -- ^ @Nothing@: \"module X where\" is omitted (in which case the next+        --     field is Nothing too)+      hsmodExports :: Maybe (Located [LIE name]),+        -- ^ Export list+        --+        --  - @Nothing@: export list omitted, so export everything+        --+        --  - @Just []@: export /nothing/+        --+        --  - @Just [...]@: as you would expect...+        --+        --+        --  - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen'+        --                                   ,'ApiAnnotation.AnnClose'++        -- For details on above see note [Api annotations] in ApiAnnotation+      hsmodImports :: [LImportDecl name],+        -- ^ We snaffle interesting stuff out of the imported interfaces early+        -- on, adding that info to TyDecls/etc; so this list is often empty,+        -- downstream.+      hsmodDecls :: [LHsDecl name],+        -- ^ Type, class, value, and interface signature decls+      hsmodDeprecMessage :: Maybe (Located WarningTxt),+        -- ^ reason\/explanation for warning/deprecation of this module+        --+        --  - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen'+        --                                   ,'ApiAnnotation.AnnClose'+        --++        -- For details on above see note [Api annotations] in ApiAnnotation+      hsmodHaddockModHeader :: Maybe LHsDocString+        -- ^ Haddock module info and description, unparsed+        --+        --  - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen'+        --                                   ,'ApiAnnotation.AnnClose'++        -- For details on above see note [Api annotations] in ApiAnnotation+   }+     -- ^ 'ApiAnnotation.AnnKeywordId's+     --+     --  - 'ApiAnnotation.AnnModule','ApiAnnotation.AnnWhere'+     --+     --  - 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnSemi',+     --    'ApiAnnotation.AnnClose' for explicit braces and semi around+     --    hsmodImports,hsmodDecls if this style is used.++     -- For details on above see note [Api annotations] in ApiAnnotation+deriving instance (DataId name) => Data (HsModule name)++instance (OutputableBndrId name, HasOccName name)+  => Outputable (HsModule name) where++    ppr (HsModule Nothing _ imports decls _ mbDoc)+      = pp_mb mbDoc $$ pp_nonnull imports+                    $$ pp_nonnull decls++    ppr (HsModule (Just name) exports imports decls deprec mbDoc)+      = vcat [+            pp_mb mbDoc,+            case exports of+              Nothing -> pp_header (text "where")+              Just es -> vcat [+                           pp_header lparen,+                           nest 8 (fsep (punctuate comma (map ppr (unLoc es)))),+                           nest 4 (text ") where")+                          ],+            pp_nonnull imports,+            pp_nonnull decls+          ]+      where+        pp_header rest = case deprec of+           Nothing -> pp_modname <+> rest+           Just d -> vcat [ pp_modname, ppr d, rest ]++        pp_modname = text "module" <+> ppr name++pp_mb :: Outputable t => Maybe t -> SDoc+pp_mb (Just x) = ppr x+pp_mb Nothing  = empty++pp_nonnull :: Outputable t => [t] -> SDoc+pp_nonnull [] = empty+pp_nonnull xs = vcat (map ppr xs)
+ hsSyn/HsTypes.hs view
@@ -0,0 +1,1349 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++HsTypes: Abstract syntax: user-defined types+-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]+                                      -- in module PlaceHolder+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}++module HsTypes (+        HsType(..), LHsType, HsKind, LHsKind,+        HsTyVarBndr(..), LHsTyVarBndr,+        LHsQTyVars(..),+        HsImplicitBndrs(..),+        HsWildCardBndrs(..),+        LHsSigType, LHsSigWcType, LHsWcType,+        HsTupleSort(..),+        Promoted(..),+        HsContext, LHsContext,+        HsTyLit(..),+        HsIPName(..), hsIPNameFS,+        HsAppType(..),LHsAppType,++        LBangType, BangType,+        HsSrcBang(..), HsImplBang(..),+        SrcStrictness(..), SrcUnpackedness(..),+        getBangType, getBangStrictness,++        ConDeclField(..), LConDeclField, pprConDeclFields, updateGadtResult,++        HsConDetails(..),++        FieldOcc(..), LFieldOcc, mkFieldOcc,+        AmbiguousFieldOcc(..), mkAmbiguousFieldOcc,+        rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc,+        unambiguousFieldOcc, ambiguousFieldOcc,++        HsWildCardInfo(..), mkAnonWildCardTy,+        wildCardName, sameWildCard,++        mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody,+        mkEmptyImplicitBndrs, mkEmptyWildCardBndrs,+        mkHsQTvs, hsQTvExplicit, emptyLHsQTvs, isEmptyLHsQTvs,+        isHsKindedTyVar, hsTvbAllKinded,+        hsScopedTvs, hsWcScopedTvs, dropWildCards,+        hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames,+        hsLTyVarName, hsLTyVarLocName, hsExplicitLTyVarNames,+        splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe,+        splitLHsPatSynTy,+        splitLHsForAllTy, splitLHsQualTy, splitLHsSigmaTy,+        splitHsFunType, splitHsAppsTy,+        splitHsAppTys, getAppsTyHead_maybe, hsTyGetAppHead_maybe,+        mkHsOpTy, mkHsAppTy, mkHsAppTys,+        ignoreParens, hsSigType, hsSigWcType,+        hsLTyVarBndrToType, hsLTyVarBndrsToTypes,++        -- Printing+        pprParendHsType, pprHsForAll, pprHsForAllTvs, pprHsForAllExtra,+        pprHsContext, pprHsContextNoArrow, pprHsContextMaybe+    ) where++import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice )++import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..),+                     OutputableBndrId )++import Id ( Id )+import Name( Name )+import RdrName ( RdrName )+import NameSet ( NameSet, emptyNameSet )+import DataCon( HsSrcBang(..), HsImplBang(..),+                SrcStrictness(..), SrcUnpackedness(..) )+import TysPrim( funTyConName )+import Type+import HsDoc+import BasicTypes+import SrcLoc+import Outputable+import FastString+import Maybes( isJust )++import Data.Data hiding ( Fixity, Prefix, Infix )+import Data.Maybe ( fromMaybe )+import Control.Monad ( unless )++{-+************************************************************************+*                                                                      *+\subsection{Bang annotations}+*                                                                      *+************************************************************************+-}++-- | Located Bang Type+type LBangType name = Located (BangType name)++-- | Bang Type+type BangType name  = HsType name       -- Bangs are in the HsType data type++getBangType :: LHsType a -> LHsType a+getBangType (L _ (HsBangTy _ ty)) = ty+getBangType ty                    = ty++getBangStrictness :: LHsType a -> HsSrcBang+getBangStrictness (L _ (HsBangTy s _)) = s+getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict)++{-+************************************************************************+*                                                                      *+\subsection{Data types}+*                                                                      *+************************************************************************++This is the syntax for types as seen in type signatures.++Note [HsBSig binder lists]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a binder (or pattern) decorated with a type or kind,+   \ (x :: a -> a). blah+   forall (a :: k -> *) (b :: k). blah+Then we use a LHsBndrSig on the binder, so that the+renamer can decorate it with the variables bound+by the pattern ('a' in the first example, 'k' in the second),+assuming that neither of them is in scope already+See also Note [Kind and type-variable binders] in RnTypes++Note [HsType binders]+~~~~~~~~~~~~~~~~~~~~~+The system for recording type and kind-variable binders in HsTypes+is a bit complicated.  Here's how it works.++* In a HsType,+     HsForAllTy   represents an /explicit, user-written/ 'forall'+                   e.g.   forall a b. ...+     HsQualTy     represents an /explicit, user-written/ context+                   e.g.   (Eq a, Show a) => ...+                  The context can be empty if that's what the user wrote+  These constructors represent what the user wrote, no more+  and no less.++* HsTyVarBndr describes a quantified type variable written by the+  user.  For example+     f :: forall a (b :: *).  blah+  here 'a' and '(b::*)' are each a HsTyVarBndr.  A HsForAllTy has+  a list of LHsTyVarBndrs.++* HsImplicitBndrs is a wrapper that gives the implicitly-quantified+  kind and type variables of the wrapped thing.  It is filled in by+  the renamer. For example, if the user writes+     f :: a -> a+  the HsImplicitBinders binds the 'a' (not a HsForAllTy!).+  NB: this implicit quantification is purely lexical: we bind any+      type or kind variables that are not in scope. The type checker+      may subsequently quantify over further kind variables.++* HsWildCardBndrs is a wrapper that binds the wildcard variables+  of the wrapped thing.  It is filled in by the renamer+     f :: _a -> _+  The enclosing HsWildCardBndrs binds the wildcards _a and _.++* The explicit presence of these wrappers specifies, in the HsSyn,+  exactly where implicit quantification is allowed, and where+  wildcards are allowed.++* LHsQTyVars is used in data/class declarations, where the user gives+  explicit *type* variable bindings, but we need to implicitly bind+  *kind* variables.  For example+      class C (a :: k -> *) where ...+  The 'k' is implicitly bound in the hsq_tvs field of LHsQTyVars++Note [The wildcard story for types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Types can have wildcards in them, to support partial type signatures,+like       f :: Int -> (_ , _a) -> _a++A wildcard in a type can be++  * An anonymous wildcard,+        written '_'+    In HsType this is represented by HsWildCardTy.+    After the renamer, this contains a Name which uniquely+    identifies this particular occurrence.++  * A named wildcard,+        written '_a', '_foo', etc+    In HsType this is represented by (HsTyVar "_a")+    i.e. a perfectly ordinary type variable that happens+         to start with an underscore++Note carefully:++* When NamedWildCards is off, type variables that start with an+  underscore really /are/ ordinary type variables.  And indeed, even+  when NamedWildCards is on you can bind _a explicitly as an ordinary+  type variable:+        data T _a _b = MkT _b _a+  Or even:+        f :: forall _a. _a -> _b+  Here _a is an ordinary forall'd binder, but (With NamedWildCards)+  _b is a named wildcard.  (See the comments in Trac #10982)++* All wildcards, whether named or anonymous, are bound by the+  HsWildCardBndrs construct, which wraps types that are allowed+  to have wildcards.++* After type checking is done, we report what types the wildcards+  got unified with.++-}++-- | Located Haskell Context+type LHsContext name = Located (HsContext name)+      -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnUnit'++      -- For details on above see note [Api annotations] in ApiAnnotation++-- | Haskell Context+type HsContext name = [LHsType name]++-- | Located Haskell Type+type LHsType name = Located (HsType name)+      -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when+      --   in a list++      -- For details on above see note [Api annotations] in ApiAnnotation++-- | Haskell Kind+type HsKind name = HsType name++-- | Located Haskell Kind+type LHsKind name = Located (HsKind name)+      -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'++      -- For details on above see note [Api annotations] in ApiAnnotation++--------------------------------------------------+--             LHsQTyVars+--  The explicitly-quantified binders in a data/type declaration++-- | Located Haskell Type Variable Binder+type LHsTyVarBndr name = Located (HsTyVarBndr name)+                         -- See Note [HsType binders]++-- | Located Haskell Quantified Type Variables+data LHsQTyVars name   -- See Note [HsType binders]+  = HsQTvs { hsq_implicit :: PostRn name [Name]      -- implicit (dependent) variables+           , hsq_explicit :: [LHsTyVarBndr name]     -- explicit variables+             -- See Note [HsForAllTy tyvar binders]+           , hsq_dependent :: PostRn name NameSet+               -- which explicit vars are dependent+               -- See Note [Dependent LHsQTyVars] in TcHsType+    }++deriving instance (DataId name) => Data (LHsQTyVars name)++mkHsQTvs :: [LHsTyVarBndr RdrName] -> LHsQTyVars RdrName+mkHsQTvs tvs = HsQTvs { hsq_implicit = PlaceHolder, hsq_explicit = tvs+                      , hsq_dependent = PlaceHolder }++hsQTvExplicit :: LHsQTyVars name -> [LHsTyVarBndr name]+hsQTvExplicit = hsq_explicit++emptyLHsQTvs :: LHsQTyVars Name+emptyLHsQTvs = HsQTvs [] [] emptyNameSet++isEmptyLHsQTvs :: LHsQTyVars Name -> Bool+isEmptyLHsQTvs (HsQTvs [] [] _) = True+isEmptyLHsQTvs _                = False++------------------------------------------------+--            HsImplicitBndrs+-- Used to quantify the binders of a type in cases+-- when a HsForAll isn't appropriate:+--    * Patterns in a type/data family instance (HsTyPats)+--    * Type of a rule binder (RuleBndr)+--    * Pattern type signatures (SigPatIn)+-- In the last of these, wildcards can happen, so we must accommodate them++-- | Haskell Implicit Binders+data HsImplicitBndrs name thing   -- See Note [HsType binders]+  = HsIB { hsib_vars :: PostRn name [Name] -- Implicitly-bound kind & type vars+         , hsib_body :: thing              -- Main payload (type or list of types)+         , hsib_closed :: PostRn name Bool -- Taking the hsib_vars into account,+                                           -- is the payload closed? Used in+                                           -- TcHsType.decideKindGeneralisationPlan+    }++-- | Haskell Wildcard Binders+data HsWildCardBndrs name thing+    -- See Note [HsType binders]+    -- See Note [The wildcard story for types]+  = HsWC { hswc_wcs :: PostRn name [Name]+                -- Wild cards, both named and anonymous+                -- after the renamer++         , hswc_body :: thing+                -- Main payload (type or list of types)+                -- If there is an extra-constraints wildcard,+                -- it's still there in the hsc_body.+    }++deriving instance (Data name, Data thing, Data (PostRn name [Name]), Data (PostRn name Bool))+  => Data (HsImplicitBndrs name thing)++deriving instance (Data name, Data thing, Data (PostRn name [Name]))+  => Data (HsWildCardBndrs name thing)++-- | Located Haskell Signature Type+type LHsSigType   name = HsImplicitBndrs name (LHsType name)    -- Implicit only++-- | Located Haskell Wildcard Type+type LHsWcType    name = HsWildCardBndrs name (LHsType name)    -- Wildcard only++-- | Located Haskell Signature Wildcard Type+type LHsSigWcType name = HsWildCardBndrs name (LHsSigType name) -- Both++-- See Note [Representing type signatures]++hsImplicitBody :: HsImplicitBndrs name thing -> thing+hsImplicitBody (HsIB { hsib_body = body }) = body++hsSigType :: LHsSigType name -> LHsType name+hsSigType = hsImplicitBody++hsSigWcType :: LHsSigWcType name -> LHsType name+hsSigWcType sig_ty = hsib_body (hswc_body sig_ty)++dropWildCards :: LHsSigWcType name -> LHsSigType name+-- Drop the wildcard part of a LHsSigWcType+dropWildCards sig_ty = hswc_body sig_ty++{- Note [Representing type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+HsSigType is used to represent an explicit user type signature+such as   f :: a -> a+     or   g (x :: a -> a) = x++A HsSigType is just a HsImplicitBndrs wrapping a LHsType.+ * The HsImplicitBndrs binds the /implicitly/ quantified tyvars+ * The LHsType binds the /explicitly/ quantified tyvars++E.g. For a signature like+   f :: forall (a::k). blah+we get+   HsIB { hsib_vars = [k]+        , hsib_body = HsForAllTy { hst_bndrs = [(a::*)]+                                 , hst_body = blah }+The implicit kind variable 'k' is bound by the HsIB;+the explicitly forall'd tyvar 'a' is bound by the HsForAllTy+-}++mkHsImplicitBndrs :: thing -> HsImplicitBndrs RdrName thing+mkHsImplicitBndrs x = HsIB { hsib_body   = x+                           , hsib_vars   = PlaceHolder+                           , hsib_closed = PlaceHolder }++mkHsWildCardBndrs :: thing -> HsWildCardBndrs RdrName thing+mkHsWildCardBndrs x = HsWC { hswc_body = x+                           , hswc_wcs  = PlaceHolder }++-- Add empty binders.  This is a bit suspicious; what if+-- the wrapped thing had free type variables?+mkEmptyImplicitBndrs :: thing -> HsImplicitBndrs Name thing+mkEmptyImplicitBndrs x = HsIB { hsib_body   = x+                              , hsib_vars   = []+                              , hsib_closed = False }++mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs Name thing+mkEmptyWildCardBndrs x = HsWC { hswc_body = x+                              , hswc_wcs  = [] }+++--------------------------------------------------+-- | These names are used early on to store the names of implicit+-- parameters.  They completely disappear after type-checking.+newtype HsIPName = HsIPName FastString+  deriving( Eq, Data )++hsIPNameFS :: HsIPName -> FastString+hsIPNameFS (HsIPName n) = n++instance Outputable HsIPName where+    ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters++instance OutputableBndr HsIPName where+    pprBndr _ n   = ppr n         -- Simple for now+    pprInfixOcc  n = ppr n+    pprPrefixOcc n = ppr n++--------------------------------------------------++-- | Haskell Type Variable Binder+data HsTyVarBndr name+  = UserTyVar        -- no explicit kinding+         (Located name)+        -- See Note [Located RdrNames] in HsExpr+  | KindedTyVar+         (Located name)+         (LHsKind name)  -- The user-supplied kind signature+        -- ^+        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',+        --          'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnClose'++        -- For details on above see note [Api annotations] in ApiAnnotation+deriving instance (DataId name) => Data (HsTyVarBndr name)++-- | Does this 'HsTyVarBndr' come with an explicit kind annotation?+isHsKindedTyVar :: HsTyVarBndr name -> Bool+isHsKindedTyVar (UserTyVar {})   = False+isHsKindedTyVar (KindedTyVar {}) = True++-- | Do all type variables in this 'LHsQTyVars' come with kind annotations?+hsTvbAllKinded :: LHsQTyVars name -> Bool+hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit++-- | Haskell Type+data HsType name+  = HsForAllTy   -- See Note [HsType binders]+      { hst_bndrs :: [LHsTyVarBndr name]   -- Explicit, user-supplied 'forall a b c'+      , hst_body  :: LHsType name          -- body type+      }+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall',+      --         'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'+      -- For details on above see note [Api annotations] in ApiAnnotation++  | HsQualTy   -- See Note [HsType binders]+      { hst_ctxt :: LHsContext name       -- Context C => blah+      , hst_body :: LHsType name }++  | HsTyVar             Promoted -- whether explicitly promoted, for the pretty+                                 -- printer+                        (Located name)+                  -- Type variable, type constructor, or data constructor+                  -- see Note [Promotions (HsTyVar)]+                  -- See Note [Located RdrNames] in HsExpr+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None++      -- For details on above see note [Api annotations] in ApiAnnotation++  | HsAppsTy            [LHsAppType name] -- Used only before renaming,+                                          -- Note [HsAppsTy]+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None++  | HsAppTy             (LHsType name)+                        (LHsType name)+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None++      -- For details on above see note [Api annotations] in ApiAnnotation++  | HsFunTy             (LHsType name)   -- function type+                        (LHsType name)+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow',++      -- For details on above see note [Api annotations] in ApiAnnotation++  | HsListTy            (LHsType name)  -- Element type+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,+      --         'ApiAnnotation.AnnClose' @']'@++      -- For details on above see note [Api annotations] in ApiAnnotation++  | HsPArrTy            (LHsType name)  -- Elem. type of parallel array: [:t:]+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,+      --         'ApiAnnotation.AnnClose' @':]'@++      -- For details on above see note [Api annotations] in ApiAnnotation++  | HsTupleTy           HsTupleSort+                        [LHsType name]  -- Element types (length gives arity)+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(' or '(#'@,+    --         'ApiAnnotation.AnnClose' @')' or '#)'@++    -- For details on above see note [Api annotations] in ApiAnnotation++  | HsSumTy             [LHsType name]  -- Element types (length gives arity)+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(#'@,+    --         'ApiAnnotation.AnnClose' '#)'@++    -- For details on above see note [Api annotations] in ApiAnnotation++  | HsOpTy              (LHsType name) (Located name) (LHsType name)+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None++      -- For details on above see note [Api annotations] in ApiAnnotation++  | HsParTy             (LHsType name)   -- See Note [Parens in HsSyn] in HsExpr+        -- Parenthesis preserved for the precedence re-arrangement in RnTypes+        -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c!+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,+      --         'ApiAnnotation.AnnClose' @')'@++      -- For details on above see note [Api annotations] in ApiAnnotation++  | HsIParamTy          (Located HsIPName) -- (?x :: ty)+                        (LHsType name)   -- Implicit parameters as they occur in contexts+      -- ^+      -- > (?x :: ty)+      --+      -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'++      -- For details on above see note [Api annotations] in ApiAnnotation++  | HsEqTy              (LHsType name)   -- ty1 ~ ty2+                        (LHsType name)   -- Always allowed even without TypeOperators, and has special kinding rule+      -- ^+      -- > ty1 ~ ty2+      --+      -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'++      -- For details on above see note [Api annotations] in ApiAnnotation++  | HsKindSig           (LHsType name)  -- (ty :: kind)+                        (LHsKind name)  -- A type with a kind signature+      -- ^+      -- > (ty :: kind)+      --+      -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,+      --         'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose' @')'@++      -- For details on above see note [Api annotations] in ApiAnnotation++  | HsSpliceTy          (HsSplice name)   -- Includes quasi-quotes+                        (PostTc name Kind)+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@,+      --         'ApiAnnotation.AnnClose' @')'@++      -- For details on above see note [Api annotations] in ApiAnnotation++  | HsDocTy             (LHsType name) LHsDocString -- A documented type+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None++      -- For details on above see note [Api annotations] in ApiAnnotation++  | HsBangTy    HsSrcBang (LHsType name)   -- Bang-style type annotations+      -- ^ - 'ApiAnnotation.AnnKeywordId' :+      --         'ApiAnnotation.AnnOpen' @'{-\# UNPACK' or '{-\# NOUNPACK'@,+      --         'ApiAnnotation.AnnClose' @'#-}'@+      --         'ApiAnnotation.AnnBang' @\'!\'@++      -- For details on above see note [Api annotations] in ApiAnnotation++  | HsRecTy     [LConDeclField name]    -- Only in data type declarations+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@,+      --         'ApiAnnotation.AnnClose' @'}'@++      -- For details on above see note [Api annotations] in ApiAnnotation++  | HsCoreTy Type       -- An escape hatch for tunnelling a *closed*+                        -- Core Type through HsSyn.+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None++      -- For details on above see note [Api annotations] in ApiAnnotation++  | HsExplicitListTy       -- A promoted explicit list+        Promoted           -- whether explcitly promoted, for pretty printer+        (PostTc name Kind) -- See Note [Promoted lists and tuples]+        [LHsType name]+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'["@,+      --         'ApiAnnotation.AnnClose' @']'@++      -- For details on above see note [Api annotations] in ApiAnnotation++  | HsExplicitTupleTy      -- A promoted explicit tuple+        [PostTc name Kind] -- See Note [Promoted lists and tuples]+        [LHsType name]+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'("@,+      --         'ApiAnnotation.AnnClose' @')'@++      -- For details on above see note [Api annotations] in ApiAnnotation++  | HsTyLit HsTyLit      -- A promoted numeric literal.+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None++      -- For details on above see note [Api annotations] in ApiAnnotation++  | HsWildCardTy (HsWildCardInfo name)  -- A type wildcard+      -- See Note [The wildcard story for types]+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None++      -- For details on above see note [Api annotations] in ApiAnnotation+deriving instance (DataId name) => Data (HsType name)++-- Note [Literal source text] in BasicTypes for SourceText fields in+-- the following+-- | Haskell Type Literal+data HsTyLit+  = HsNumTy SourceText Integer+  | HsStrTy SourceText FastString+    deriving Data++newtype HsWildCardInfo name      -- See Note [The wildcard story for types]+    = AnonWildCard (PostRn name (Located Name))+      -- A anonymous wild card ('_'). A fresh Name is generated for+      -- each individual anonymous wildcard during renaming+deriving instance (DataId name) => Data (HsWildCardInfo name)++-- | Located Haskell Application Type+type LHsAppType name = Located (HsAppType name)+      -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSimpleQuote'++-- | Haskell Application Type+data HsAppType name+  = HsAppInfix (Located name)       -- either a symbol or an id in backticks+  | HsAppPrefix (LHsType name)      -- anything else, including things like (+)+deriving instance (DataId name) => Data (HsAppType name)++instance (OutputableBndrId name) => Outputable (HsAppType name) where+  ppr = ppr_app_ty TopPrec++{-+Note [HsForAllTy tyvar binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+After parsing:+  * Implicit => empty+    Explicit => the variables the user wrote++After renaming+  * Implicit => the *type* variables free in the type+    Explicit => the variables the user wrote (renamed)++Qualified currently behaves exactly as Implicit,+but it is deprecated to use it for implicit quantification.+In this case, GHC 7.10 gives a warning; see+Note [Context quantification] in RnTypes, and Trac #4426.+In GHC 8.0, Qualified will no longer bind variables+and this will become an error.++The kind variables bound in the hsq_implicit field come both+  a) from the kind signatures on the kind vars (eg k1)+  b) from the scope of the forall (eg k2)+Example:   f :: forall (a::k1) b. T a (b::k2)+++Note [Unit tuples]+~~~~~~~~~~~~~~~~~~+Consider the type+    type instance F Int = ()+We want to parse that "()"+    as HsTupleTy HsBoxedOrConstraintTuple [],+NOT as HsTyVar unitTyCon++Why? Because F might have kind (* -> Constraint), so we when parsing we+don't know if that tuple is going to be a constraint tuple or an ordinary+unit tuple.  The HsTupleSort flag is specifically designed to deal with+that, but it has to work for unit tuples too.++Note [Promotions (HsTyVar)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+HsTyVar: A name in a type or kind.+  Here are the allowed namespaces for the name.+    In a type:+      Var: not allowed+      Data: promoted data constructor+      Tv: type variable+      TcCls before renamer: type constructor, class constructor, or promoted data constructor+      TcCls after renamer: type constructor or class constructor+    In a kind:+      Var, Data: not allowed+      Tv: kind variable+      TcCls: kind constructor or promoted type constructor++  The 'Promoted' field in an HsTyVar captures whether the type was promoted in+  the source code by prefixing an apostrophe.++Note [HsAppsTy]+~~~~~~~~~~~~~~~+How to parse++  Foo * Int++? Is it `(*) Foo Int` or `Foo GHC.Types.* Int`? There's no way to know until renaming.+So we just take type expressions like this and put each component in a list, so be+sorted out in the renamer. The sorting out is done by RnTypes.mkHsOpTyRn. This means+that the parser should never produce HsAppTy or HsOpTy.++Note [Promoted lists and tuples]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Notice the difference between+   HsListTy    HsExplicitListTy+   HsTupleTy   HsExplicitListTupleTy++E.g.    f :: [Int]                      HsListTy++        g3  :: T '[]                   All these use+        g2  :: T '[True]                  HsExplicitListTy+        g1  :: T '[True,False]+        g1a :: T [True,False]             (can omit ' where unambiguous)++  kind of T :: [Bool] -> *        This kind uses HsListTy!++E.g.    h :: (Int,Bool)                 HsTupleTy; f is a pair+        k :: S '(True,False)            HsExplicitTypleTy; S is indexed by+                                           a type-level pair of booleans+        kind of S :: (Bool,Bool) -> *   This kind uses HsExplicitTupleTy++Note [Distinguishing tuple kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Apart from promotion, tuples can have one of three different kinds:++        x :: (Int, Bool)                -- Regular boxed tuples+        f :: Int# -> (# Int#, Int# #)   -- Unboxed tuples+        g :: (Eq a, Ord a) => a         -- Constraint tuples++For convenience, internally we use a single constructor for all of these,+namely HsTupleTy, but keep track of the tuple kind (in the first argument to+HsTupleTy, a HsTupleSort). We can tell if a tuple is unboxed while parsing,+because of the #. However, with -XConstraintKinds we can only distinguish+between constraint and boxed tuples during type checking, in general. Hence the+four constructors of HsTupleSort:++        HsUnboxedTuple                  -> Produced by the parser+        HsBoxedTuple                    -> Certainly a boxed tuple+        HsConstraintTuple               -> Certainly a constraint tuple+        HsBoxedOrConstraintTuple        -> Could be a boxed or a constraint+                                        tuple. Produced by the parser only,+                                        disappears after type checking+-}++-- | Haskell Tuple Sort+data HsTupleSort = HsUnboxedTuple+                 | HsBoxedTuple+                 | HsConstraintTuple+                 | HsBoxedOrConstraintTuple+                 deriving Data+++-- | Promoted data types.+data Promoted = Promoted+              | NotPromoted+              deriving (Data, Eq, Show)++-- | Located Constructor Declaration Field+type LConDeclField name = Located (ConDeclField name)+      -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when+      --   in a list++      -- For details on above see note [Api annotations] in ApiAnnotation++-- | Constructor Declaration Field+data ConDeclField name  -- Record fields have Haddoc docs on them+  = ConDeclField { cd_fld_names :: [LFieldOcc name],+                                   -- ^ See Note [ConDeclField names]+                   cd_fld_type :: LBangType name,+                   cd_fld_doc  :: Maybe LHsDocString }+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'++      -- For details on above see note [Api annotations] in ApiAnnotation+deriving instance (DataId name) => Data (ConDeclField name)++instance (OutputableBndrId name) => Outputable (ConDeclField name) where+  ppr (ConDeclField fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty++-- HsConDetails is used for patterns/expressions *and* for data type+-- declarations+-- | Haskell Constructor Details+data HsConDetails arg rec+  = PrefixCon [arg]             -- C p1 p2 p3+  | RecCon    rec               -- C { x = p1, y = p2 }+  | InfixCon  arg arg           -- p1 `C` p2+  deriving Data++instance (Outputable arg, Outputable rec)+         => Outputable (HsConDetails arg rec) where+  ppr (PrefixCon args) = text "PrefixCon" <+> ppr args+  ppr (RecCon rec)     = text "RecCon:" <+> ppr rec+  ppr (InfixCon l r)   = text "InfixCon:" <+> ppr [l, r]++-- Takes details and result type of a GADT data constructor as created by the+-- parser and rejigs them using information about fixities from the renamer.+-- See Note [Sorting out the result type] in RdrHsSyn+updateGadtResult+  :: (Monad m)+     => (SDoc -> m ())+     -> SDoc+     -> HsConDetails (LHsType Name) (Located [LConDeclField Name])+                     -- ^ Original details+     -> LHsType Name -- ^ Original result type+     -> m (HsConDetails (LHsType Name) (Located [LConDeclField Name]),+           LHsType Name)+updateGadtResult failWith doc details ty+  = do { let (arg_tys, res_ty) = splitHsFunType ty+             badConSig         = text "Malformed constructor signature"+       ; case details of+           InfixCon {}  -> pprPanic "updateGadtResult" (ppr ty)++           RecCon {}    -> do { unless (null arg_tys)+                                       (failWith (doc <+> badConSig))+                              ; return (details, res_ty) }++           PrefixCon {} -> return (PrefixCon arg_tys, res_ty)}++{-+Note [ConDeclField names]+~~~~~~~~~~~~~~~~~~~~~~~~~++A ConDeclField contains a list of field occurrences: these always+include the field label as the user wrote it.  After the renamer, it+will additionally contain the identity of the selector function in the+second component.++Due to DuplicateRecordFields, the OccName of the selector function+may have been mangled, which is why we keep the original field label+separately.  For example, when DuplicateRecordFields is enabled++    data T = MkT { x :: Int }++gives++    ConDeclField { cd_fld_names = [L _ (FieldOcc "x" $sel:x:MkT)], ... }.+-}++-----------------------+-- A valid type must have a for-all at the top of the type, or of the fn arg+-- types++---------------------+hsWcScopedTvs :: LHsSigWcType Name -> [Name]+-- Get the lexically-scoped type variables of a HsSigType+--  - the explicitly-given forall'd type variables+--  - the implicitly-bound kind variables+--  - the named wildcars; see Note [Scoping of named wildcards]+-- because they scope in the same way+hsWcScopedTvs sig_ty+  | HsWC { hswc_wcs = nwcs, hswc_body = sig_ty1 }  <- sig_ty+  , HsIB { hsib_vars = vars, hsib_body = sig_ty2 } <- sig_ty1+  = case sig_ty2 of+      L _ (HsForAllTy { hst_bndrs = tvs }) -> vars ++ nwcs +++                                              map hsLTyVarName tvs+               -- include kind variables only if the type is headed by forall+               -- (this is consistent with GHC 7 behaviour)+      _                                    -> nwcs++hsScopedTvs :: LHsSigType Name -> [Name]+-- Same as hsWcScopedTvs, but for a LHsSigType+hsScopedTvs sig_ty+  | HsIB { hsib_vars = vars,  hsib_body = sig_ty2 } <- sig_ty+  , L _ (HsForAllTy { hst_bndrs = tvs }) <- sig_ty2+  = vars ++ map hsLTyVarName tvs+  | otherwise+  = []++{- Note [Scoping of named wildcards]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  f :: _a -> _a+  f x = let g :: _a -> _a+            g = ...+        in ...++Currently, for better or worse, the "_a" variables are all the same. So+although there is no explicit forall, the "_a" scopes over the definition.+I don't know if this is a good idea, but there it is.+-}++---------------------+hsTyVarName :: HsTyVarBndr name -> name+hsTyVarName (UserTyVar (L _ n))     = n+hsTyVarName (KindedTyVar (L _ n) _) = n++hsLTyVarName :: LHsTyVarBndr name -> name+hsLTyVarName = hsTyVarName . unLoc++hsExplicitLTyVarNames :: LHsQTyVars name -> [name]+-- Explicit variables only+hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs)++hsAllLTyVarNames :: LHsQTyVars Name -> [Name]+-- All variables+hsAllLTyVarNames (HsQTvs { hsq_implicit = kvs, hsq_explicit = tvs })+  = kvs ++ map hsLTyVarName tvs++hsLTyVarLocName :: LHsTyVarBndr name -> Located name+hsLTyVarLocName = fmap hsTyVarName++hsLTyVarLocNames :: LHsQTyVars name -> [Located name]+hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs)++-- | Convert a LHsTyVarBndr to an equivalent LHsType.+hsLTyVarBndrToType :: LHsTyVarBndr name -> LHsType name+hsLTyVarBndrToType = fmap cvt+  where cvt (UserTyVar n) = HsTyVar NotPromoted n+        cvt (KindedTyVar (L name_loc n) kind)+          = HsKindSig (L name_loc (HsTyVar NotPromoted (L name_loc n))) kind++-- | Convert a LHsTyVarBndrs to a list of types.+-- Works on *type* variable only, no kind vars.+hsLTyVarBndrsToTypes :: LHsQTyVars name -> [LHsType name]+hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs++---------------------+wildCardName :: HsWildCardInfo Name -> Name+wildCardName (AnonWildCard  (L _ n)) = n++-- Two wild cards are the same when they have the same location+sameWildCard :: Located (HsWildCardInfo name)+             -> Located (HsWildCardInfo name) -> Bool+sameWildCard (L l1 (AnonWildCard _))   (L l2 (AnonWildCard _))   = l1 == l2++ignoreParens :: LHsType name -> LHsType name+ignoreParens (L _ (HsParTy ty))                      = ignoreParens ty+ignoreParens (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = ignoreParens ty+ignoreParens ty                                      = ty++{-+************************************************************************+*                                                                      *+                Building types+*                                                                      *+************************************************************************+-}++mkAnonWildCardTy :: HsType RdrName+mkAnonWildCardTy = HsWildCardTy (AnonWildCard PlaceHolder)++mkHsOpTy :: LHsType name -> Located name -> LHsType name -> HsType name+mkHsOpTy ty1 op ty2 = HsOpTy ty1 op ty2++mkHsAppTy :: LHsType name -> LHsType name -> LHsType name+mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)++mkHsAppTys :: LHsType name -> [LHsType name] -> LHsType name+mkHsAppTys = foldl mkHsAppTy+++{-+************************************************************************+*                                                                      *+                Decomposing HsTypes+*                                                                      *+************************************************************************+-}++---------------------------------+-- splitHsFunType decomposes a type (t1 -> t2 ... -> tn)+-- Breaks up any parens in the result type:+--      splitHsFunType (a -> (b -> c)) = ([a,b], c)+-- Also deals with (->) t1 t2; that is why it only works on LHsType Name+--   (see Trac #9096)+splitHsFunType :: LHsType Name -> ([LHsType Name], LHsType Name)+splitHsFunType (L _ (HsParTy ty))+  = splitHsFunType ty++splitHsFunType (L _ (HsFunTy x y))+  | (args, res) <- splitHsFunType y+  = (x:args, res)++splitHsFunType orig_ty@(L _ (HsAppTy t1 t2))+  = go t1 [t2]+  where  -- Look for (->) t1 t2, possibly with parenthesisation+    go (L _ (HsTyVar _ (L _ fn))) tys | fn == funTyConName+                                 , [t1,t2] <- tys+                                 , (args, res) <- splitHsFunType t2+                                 = (t1:args, res)+    go (L _ (HsAppTy t1 t2)) tys = go t1 (t2:tys)+    go (L _ (HsParTy ty))    tys = go ty tys+    go _                     _   = ([], orig_ty)  -- Failure to match++splitHsFunType other = ([], other)++--------------------------------+-- | Retrieves the head of an HsAppsTy, if this can be done unambiguously,+-- without consulting fixities.+getAppsTyHead_maybe :: [LHsAppType name]+                    -> Maybe (LHsType name, [LHsType name], LexicalFixity)+getAppsTyHead_maybe tys = case splitHsAppsTy tys of+  ([app1:apps], []) ->  -- no symbols, some normal types+    Just (mkHsAppTys app1 apps, [], Prefix)+  ([app1l:appsl, app1r:appsr], [L loc op]) ->  -- one operator+    Just ( L loc (HsTyVar NotPromoted (L loc op))+         , [mkHsAppTys app1l appsl, mkHsAppTys app1r appsr], Infix)+  _ -> -- can't figure it out+    Nothing++-- | Splits a [HsAppType name] (the payload of an HsAppsTy) into regions of prefix+-- types (normal types) and infix operators.+-- If @splitHsAppsTy tys = (non_syms, syms)@, then @tys@ starts with the first+-- element of @non_syms@ followed by the first element of @syms@ followed by+-- the next element of @non_syms@, etc. It is guaranteed that the non_syms list+-- has one more element than the syms list.+splitHsAppsTy :: [LHsAppType name] -> ([[LHsType name]], [Located name])+splitHsAppsTy = go [] [] []+  where+    go acc acc_non acc_sym [] = (reverse (reverse acc : acc_non), reverse acc_sym)+    go acc acc_non acc_sym (L _ (HsAppPrefix ty) : rest)+      = go (ty : acc) acc_non acc_sym rest+    go acc acc_non acc_sym (L _ (HsAppInfix op) : rest)+      = go [] (reverse acc : acc_non) (op : acc_sym) rest++-- Retrieve the name of the "head" of a nested type application+-- somewhat like splitHsAppTys, but a little more thorough+-- used to examine the result of a GADT-like datacon, so it doesn't handle+-- *all* cases (like lists, tuples, (~), etc.)+hsTyGetAppHead_maybe :: LHsType name -> Maybe (Located name, [LHsType name])+hsTyGetAppHead_maybe = go []+  where+    go tys (L _ (HsTyVar _ ln))          = Just (ln, tys)+    go tys (L _ (HsAppsTy apps))+      | Just (head, args, _) <- getAppsTyHead_maybe apps+                                         = go (args ++ tys) head+    go tys (L _ (HsAppTy l r))           = go (r : tys) l+    go tys (L _ (HsOpTy l (L loc n) r))  = Just (L loc n, l : r : tys)+    go tys (L _ (HsParTy t))             = go tys t+    go tys (L _ (HsKindSig t _))         = go tys t+    go _   _                             = Nothing++splitHsAppTys :: LHsType Name -> [LHsType Name] -> (LHsType Name, [LHsType Name])+  -- no need to worry about HsAppsTy here+splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as)+splitHsAppTys (L _ (HsParTy f))   as = splitHsAppTys f as+splitHsAppTys f                   as = (f,as)++--------------------------------+splitLHsPatSynTy :: LHsType name+                 -> ( [LHsTyVarBndr name]    -- universals+                    , LHsContext name        -- required constraints+                    , [LHsTyVarBndr name]    -- existentials+                    , LHsContext name        -- provided constraints+                    , LHsType name)          -- body type+splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4)+  where+    (univs, ty1) = splitLHsForAllTy ty+    (reqs,  ty2) = splitLHsQualTy ty1+    (exis,  ty3) = splitLHsForAllTy ty2+    (provs, ty4) = splitLHsQualTy ty3++splitLHsSigmaTy :: LHsType name -> ([LHsTyVarBndr name], LHsContext name, LHsType name)+splitLHsSigmaTy ty+  | (tvs, ty1)  <- splitLHsForAllTy ty+  , (ctxt, ty2) <- splitLHsQualTy ty1+  = (tvs, ctxt, ty2)++splitLHsForAllTy :: LHsType name -> ([LHsTyVarBndr name], LHsType name)+splitLHsForAllTy (L _ (HsForAllTy { hst_bndrs = tvs, hst_body = body })) = (tvs, body)+splitLHsForAllTy body                                                    = ([], body)++splitLHsQualTy :: LHsType name -> (LHsContext name, LHsType name)+splitLHsQualTy (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) = (ctxt,     body)+splitLHsQualTy body                                                  = (noLoc [], body)++splitLHsInstDeclTy :: LHsSigType Name+                   -> ([Name], LHsContext Name, LHsType Name)+-- Split up an instance decl type, returning the pieces+splitLHsInstDeclTy (HsIB { hsib_vars = itkvs+                         , hsib_body = inst_ty })+  | (tvs, cxt, body_ty) <- splitLHsSigmaTy inst_ty+  = (itkvs ++ map hsLTyVarName tvs, cxt, body_ty)+         -- Return implicitly bound type and kind vars+         -- For an instance decl, all of them are in scope++getLHsInstDeclHead :: LHsSigType name -> LHsType name+getLHsInstDeclHead inst_ty+  | (_tvs, _cxt, body_ty) <- splitLHsSigmaTy (hsSigType inst_ty)+  = body_ty++getLHsInstDeclClass_maybe :: LHsSigType name -> Maybe (Located name)+-- Works on (HsSigType RdrName)+getLHsInstDeclClass_maybe inst_ty+  = do { let head_ty = getLHsInstDeclHead inst_ty+       ; (cls, _) <- hsTyGetAppHead_maybe head_ty+       ; return cls }++{-+************************************************************************+*                                                                      *+                FieldOcc+*                                                                      *+************************************************************************+-}++-- | Located Field Occurrence+type LFieldOcc name = Located (FieldOcc name)++-- | Field Occurrence+--+-- Represents an *occurrence* of an unambiguous field.  We store+-- both the 'RdrName' the user originally wrote, and after the+-- renamer, the selector function.+data FieldOcc name = FieldOcc { rdrNameFieldOcc  :: Located RdrName+                                 -- ^ See Note [Located RdrNames] in HsExpr+                              , selectorFieldOcc :: PostRn name name+                              }+deriving instance Eq (PostRn name name) => Eq (FieldOcc name)+deriving instance Ord (PostRn name name) => Ord (FieldOcc name)+deriving instance (Data name, Data (PostRn name name)) => Data (FieldOcc name)++instance Outputable (FieldOcc name) where+  ppr = ppr . rdrNameFieldOcc++mkFieldOcc :: Located RdrName -> FieldOcc RdrName+mkFieldOcc rdr = FieldOcc rdr PlaceHolder+++-- | Ambiguous Field Occurrence+--+-- Represents an *occurrence* of a field that is potentially+-- ambiguous after the renamer, with the ambiguity resolved by the+-- typechecker.  We always store the 'RdrName' that the user+-- originally wrote, and store the selector function after the renamer+-- (for unambiguous occurrences) or the typechecker (for ambiguous+-- occurrences).+--+-- See Note [HsRecField and HsRecUpdField] in HsPat and+-- Note [Disambiguating record fields] in TcExpr.+-- See Note [Located RdrNames] in HsExpr+data AmbiguousFieldOcc name+  = Unambiguous (Located RdrName) (PostRn name name)+  | Ambiguous   (Located RdrName) (PostTc name name)+deriving instance ( Data name+                  , Data (PostRn name name)+                  , Data (PostTc name name))+                  => Data (AmbiguousFieldOcc name)++instance Outputable (AmbiguousFieldOcc name) where+  ppr = ppr . rdrNameAmbiguousFieldOcc++instance OutputableBndr (AmbiguousFieldOcc name) where+  pprInfixOcc  = pprInfixOcc . rdrNameAmbiguousFieldOcc+  pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc++mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc RdrName+mkAmbiguousFieldOcc rdr = Unambiguous rdr PlaceHolder++rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc name -> RdrName+rdrNameAmbiguousFieldOcc (Unambiguous (L _ rdr) _) = rdr+rdrNameAmbiguousFieldOcc (Ambiguous   (L _ rdr) _) = rdr++selectorAmbiguousFieldOcc :: AmbiguousFieldOcc Id -> Id+selectorAmbiguousFieldOcc (Unambiguous _ sel) = sel+selectorAmbiguousFieldOcc (Ambiguous   _ sel) = sel++unambiguousFieldOcc :: AmbiguousFieldOcc Id -> FieldOcc Id+unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel+unambiguousFieldOcc (Ambiguous   rdr sel) = FieldOcc rdr sel++ambiguousFieldOcc :: FieldOcc name -> AmbiguousFieldOcc name+ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel++{-+************************************************************************+*                                                                      *+\subsection{Pretty printing}+*                                                                      *+************************************************************************+-}++instance (OutputableBndrId name) => Outputable (HsType name) where+    ppr ty = pprHsType ty++instance Outputable HsTyLit where+    ppr = ppr_tylit++instance (OutputableBndrId name) => Outputable (LHsQTyVars name) where+    ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs++instance (OutputableBndrId name) => Outputable (HsTyVarBndr name) where+    ppr (UserTyVar n)     = ppr n+    ppr (KindedTyVar n k) = parens $ hsep [ppr n, dcolon, ppr k]++instance (Outputable thing) => Outputable (HsImplicitBndrs name thing) where+    ppr (HsIB { hsib_body = ty }) = ppr ty++instance (Outputable thing) => Outputable (HsWildCardBndrs name thing) where+    ppr (HsWC { hswc_body = ty }) = ppr ty++instance Outputable (HsWildCardInfo name) where+    ppr (AnonWildCard _)  = char '_'++pprHsForAll :: (OutputableBndrId name)+            => [LHsTyVarBndr name] -> LHsContext name -> SDoc+pprHsForAll = pprHsForAllExtra Nothing++-- | Version of 'pprHsForAll' that can also print an extra-constraints+-- wildcard, e.g. @_ => a -> Bool@ or @(Show a, _) => a -> String@. This+-- underscore will be printed when the 'Maybe SrcSpan' argument is a 'Just'+-- containing the location of the extra-constraints wildcard. A special+-- function for this is needed, as the extra-constraints wildcard is removed+-- from the actual context and type, and stored in a separate field, thus just+-- printing the type will not print the extra-constraints wildcard.+pprHsForAllExtra :: (OutputableBndrId name)+                 => Maybe SrcSpan -> [LHsTyVarBndr name] -> LHsContext name+                 -> SDoc+pprHsForAllExtra extra qtvs cxt+  = pprHsForAllTvs qtvs <+> pprHsContextExtra show_extra (unLoc cxt)+  where+    show_extra = isJust extra++pprHsForAllTvs :: (OutputableBndrId name) => [LHsTyVarBndr name] -> SDoc+pprHsForAllTvs qtvs = sdocWithPprDebug $ \debug ->+  ppWhen (debug || not (null qtvs)) $ forAllLit <+> interppSP qtvs <> dot++pprHsContext :: (OutputableBndrId name) => HsContext name -> SDoc+pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe++pprHsContextNoArrow :: (OutputableBndrId name) => HsContext name -> SDoc+pprHsContextNoArrow = fromMaybe empty . pprHsContextMaybe++pprHsContextMaybe :: (OutputableBndrId name) => HsContext name -> Maybe SDoc+pprHsContextMaybe []         = Nothing+pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty FunPrec pred+pprHsContextMaybe cxt        = Just $ parens (interpp'SP cxt)++-- For use in a HsQualTy, which always gets printed if it exists.+pprHsContextAlways :: (OutputableBndrId name) => HsContext name -> SDoc+pprHsContextAlways []  = parens empty <+> darrow+pprHsContextAlways [L _ ty] = ppr_mono_ty FunPrec ty <+> darrow+pprHsContextAlways cxt = parens (interpp'SP cxt) <+> darrow++-- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@+pprHsContextExtra :: (OutputableBndrId name) => Bool -> HsContext name -> SDoc+pprHsContextExtra show_extra ctxt+  | not show_extra+  = pprHsContext ctxt+  | null ctxt+  = char '_' <+> darrow+  | otherwise+  = parens (sep (punctuate comma ctxt')) <+> darrow+  where+    ctxt' = map ppr ctxt ++ [char '_']++pprConDeclFields :: (OutputableBndrId name) => [LConDeclField name] -> SDoc+pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))+  where+    ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty,+                                 cd_fld_doc = doc }))+        = ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc+    ppr_names [n] = ppr n+    ppr_names ns = sep (punctuate comma (map ppr ns))++{-+Note [Printing KindedTyVars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Trac #3830 reminded me that we should really only print the kind+signature on a KindedTyVar if the kind signature was put there by the+programmer.  During kind inference GHC now adds a PostTcKind to UserTyVars,+rather than converting to KindedTyVars as before.++(As it happens, the message in #3830 comes out a different way now,+and the problem doesn't show up; but having the flag on a KindedTyVar+seems like the Right Thing anyway.)+-}++-- Printing works more-or-less as for Types++pprHsType, pprParendHsType :: (OutputableBndrId name) => HsType name -> SDoc++pprHsType ty       = ppr_mono_ty TopPrec ty+pprParendHsType ty = ppr_mono_ty TyConPrec ty++ppr_mono_lty :: (OutputableBndrId name) => TyPrec -> LHsType name -> SDoc+ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)++ppr_mono_ty :: (OutputableBndrId name) => TyPrec -> HsType name -> SDoc+ppr_mono_ty ctxt_prec (HsForAllTy { hst_bndrs = tvs, hst_body = ty })+  = maybeParen ctxt_prec FunPrec $+    sep [pprHsForAllTvs tvs, ppr_mono_lty TopPrec ty]++ppr_mono_ty _ctxt_prec (HsQualTy { hst_ctxt = L _ ctxt, hst_body = ty })+  = sep [pprHsContextAlways ctxt, ppr_mono_lty TopPrec ty]++ppr_mono_ty _    (HsBangTy b ty)     = ppr b <> ppr_mono_lty TyConPrec ty+ppr_mono_ty _    (HsRecTy flds)      = pprConDeclFields flds+ppr_mono_ty _    (HsTyVar NotPromoted (L _ name))= pprPrefixOcc name+ppr_mono_ty _    (HsTyVar Promoted (L _ name))+  = space <> quote (pprPrefixOcc name)+                         -- We need a space before the ' above, so the parser+                         -- does not attach it to the previous symbol+ppr_mono_ty prec (HsFunTy ty1 ty2)   = ppr_fun_ty prec ty1 ty2+ppr_mono_ty _    (HsTupleTy con tys) = tupleParens std_con (pprWithCommas ppr tys)+  where std_con = case con of+                    HsUnboxedTuple -> UnboxedTuple+                    _              -> BoxedTuple+ppr_mono_ty _    (HsSumTy tys)       = tupleParens UnboxedTuple (pprWithBars ppr tys)+ppr_mono_ty _    (HsKindSig ty kind) = parens (ppr_mono_lty TopPrec ty <+> dcolon <+> ppr kind)+ppr_mono_ty _    (HsListTy ty)       = brackets (ppr_mono_lty TopPrec ty)+ppr_mono_ty _    (HsPArrTy ty)       = paBrackets (ppr_mono_lty TopPrec ty)+ppr_mono_ty prec (HsIParamTy n ty)   = maybeParen prec FunPrec (ppr n <+> dcolon <+> ppr_mono_lty TopPrec ty)+ppr_mono_ty _    (HsSpliceTy s _)    = pprSplice s+ppr_mono_ty _    (HsCoreTy ty)       = ppr ty+ppr_mono_ty _    (HsExplicitListTy Promoted _ tys)+  = quote $ brackets (interpp'SP tys)+ppr_mono_ty _    (HsExplicitListTy NotPromoted _ tys)+  = brackets (interpp'SP tys)+ppr_mono_ty _    (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys)+ppr_mono_ty _    (HsTyLit t)         = ppr_tylit t+ppr_mono_ty _    (HsWildCardTy {})   = char '_'++ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2)+  = maybeParen ctxt_prec TyOpPrec $+    ppr_mono_lty TyOpPrec ty1 <+> char '~' <+> ppr_mono_lty TyOpPrec ty2++ppr_mono_ty _ctxt_prec (HsAppsTy tys)+  = hsep (map (ppr_app_ty TopPrec . unLoc) tys)++ppr_mono_ty _ctxt_prec (HsAppTy fun_ty arg_ty)+  = hsep [ppr_mono_lty FunPrec fun_ty, ppr_mono_lty TyConPrec arg_ty]++ppr_mono_ty ctxt_prec (HsOpTy ty1 (L _ op) ty2)+  = maybeParen ctxt_prec TyOpPrec $+    sep [ ppr_mono_lty TyOpPrec ty1+        , sep [pprInfixOcc op, ppr_mono_lty TyOpPrec ty2 ] ]++ppr_mono_ty _         (HsParTy ty)+  = parens (ppr_mono_lty TopPrec ty)+  -- Put the parens in where the user did+  -- But we still use the precedence stuff to add parens because+  --    toHsType doesn't put in any HsParTys, so we may still need them++ppr_mono_ty ctxt_prec (HsDocTy ty doc)+  = maybeParen ctxt_prec TyOpPrec $+    ppr_mono_lty TyOpPrec ty <+> ppr (unLoc doc)+  -- we pretty print Haddock comments on types as if they were+  -- postfix operators++--------------------------+ppr_fun_ty :: (OutputableBndrId name)+           => TyPrec -> LHsType name -> LHsType name -> SDoc+ppr_fun_ty ctxt_prec ty1 ty2+  = let p1 = ppr_mono_lty FunPrec ty1+        p2 = ppr_mono_lty TopPrec ty2+    in+    maybeParen ctxt_prec FunPrec $+    sep [p1, text "->" <+> p2]++--------------------------+ppr_app_ty :: (OutputableBndrId name) => TyPrec -> HsAppType name -> SDoc+ppr_app_ty _    (HsAppInfix (L _ n))                  = pprInfixOcc n+ppr_app_ty _    (HsAppPrefix (L _ (HsTyVar NotPromoted (L _ n))))+  = pprPrefixOcc n+ppr_app_ty _    (HsAppPrefix (L _ (HsTyVar Promoted  (L _ n))))+  = space <> quote (pprPrefixOcc n) -- We need a space before the ' above, so+                                    -- the parser does not attach it to the+                                    -- previous symbol+ppr_app_ty ctxt (HsAppPrefix ty)                      = ppr_mono_lty ctxt ty++--------------------------+ppr_tylit :: HsTyLit -> SDoc+ppr_tylit (HsNumTy _ i) = integer i+ppr_tylit (HsStrTy _ s) = text (show s)
+ hsSyn/HsUtils.hs view
@@ -0,0 +1,1251 @@+{-+(c) The University of Glasgow, 1992-2006+++Here we collect a variety of helper functions that construct or+analyse HsSyn.  All these functions deal with generic HsSyn; functions+which deal with the instantiated versions are located elsewhere:++   Parameterised by     Module+   ----------------     -------------+   RdrName              parser/RdrHsSyn+   Name                 rename/RnHsSyn+   Id                   typecheck/TcHsSyn+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++module HsUtils(+  -- Terms+  mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypeOut, mkHsCaseAlt,+  mkSimpleMatch, unguardedGRHSs, unguardedRHS,+  mkMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,+  mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,+  mkHsDictLet, mkHsLams,+  mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,+  mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,++  nlHsTyApp, nlHsTyApps, nlHsVar, nlHsDataCon,+  nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps,+  nlHsIntLit, nlHsVarApps,+  nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,+  mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,+  typeToLHsType,++  -- * Constructing general big tuples+  -- $big_tuples+  mkChunkified, chunkify,++  -- Bindings+  mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind,+  mkPatSynBind,+  isInfixFunBind,++  -- Literals+  mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit,++  -- Patterns+  mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,+  nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat,+  nlWildPatName, nlWildPatId, nlTuplePat, mkParPat, nlParPat,+  mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,++  -- Types+  mkHsAppTy, mkHsAppTys, userHsTyVarBndrs, userHsLTyVarBndrs,+  mkLHsSigType, mkLHsSigWcType, mkClassOpSigs, mkHsSigEnv,+  nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp,++  -- Stmts+  mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkTcBindStmt,+  mkLastStmt,+  emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt,+  emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt,++  -- Template Haskell+  mkHsSpliceTy, mkHsSpliceE, mkHsSpliceTE, mkUntypedSplice,+  mkHsQuasiQuote, unqualQuasiQuote,++  -- Flags+  noRebindableInfo,++  -- Collecting binders+  isUnliftedHsBind, isBangedBind,++  collectLocalBinders, collectHsValBinders, collectHsBindListBinders,+  collectHsIdBinders,+  collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,+  collectPatBinders, collectPatsBinders,+  collectLStmtsBinders, collectStmtsBinders,+  collectLStmtBinders, collectStmtBinders,++  hsLTyClDeclBinders, hsTyClForeignBinders,+  hsPatSynSelectors, getPatSynBinds,+  hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,+  hsDataDefnBinders,++  -- Collecting implicit binders+  lStmtsImplicits, hsValBindsImplicits, lPatImplicits+  ) where++#include "HsVersions.h"++import HsDecls+import HsBinds+import HsExpr+import HsPat+import HsTypes+import HsLit+import PlaceHolder++import TcEvidence+import RdrName+import Var+import TyCoRep+import Type   ( filterOutInvisibleTypes )+import TysWiredIn ( unitTy )+import TcType+import DataCon+import ConLike+import Id+import Name+import NameSet+import NameEnv+import BasicTypes+import SrcLoc+import FastString+import Util+import Bag+import Outputable+import Constants++import Data.Either+import Data.Function+import Data.List++{-+************************************************************************+*                                                                      *+        Some useful helpers for constructing syntax+*                                                                      *+************************************************************************++These functions attempt to construct a not-completely-useless SrcSpan+from their components, compared with the nl* functions below which+just attach noSrcSpan to everything.+-}++mkHsPar :: LHsExpr id -> LHsExpr id+mkHsPar e = L (getLoc e) (HsPar e)++mkSimpleMatch :: HsMatchContext (NameOrRdrName id)+              -> [LPat id] -> Located (body id)+              -> LMatch id (Located (body id))+mkSimpleMatch ctxt pats rhs+  = L loc $+    Match ctxt pats Nothing (unguardedGRHSs rhs)+  where+    loc = case pats of+                []      -> getLoc rhs+                (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)++unguardedGRHSs :: Located (body id) -> GRHSs id (Located (body id))+unguardedGRHSs rhs@(L loc _)+  = GRHSs (unguardedRHS loc rhs) (noLoc emptyLocalBinds)++unguardedRHS :: SrcSpan -> Located (body id) -> [LGRHS id (Located (body id))]+unguardedRHS loc rhs = [L loc (GRHS [] rhs)]++mkMatchGroup :: (PostTc name Type ~ PlaceHolder)+             => Origin -> [LMatch name (Located (body name))]+             -> MatchGroup name (Located (body name))+mkMatchGroup origin matches = MG { mg_alts = mkLocatedList matches+                                 , mg_arg_tys = []+                                 , mg_res_ty = placeHolderType+                                 , mg_origin = origin }++mkLocatedList ::  [Located a] -> Located [Located a]+mkLocatedList [] = noLoc []+mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms++mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name+mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)++mkHsAppType :: LHsExpr name -> LHsWcType name -> LHsExpr name+mkHsAppType e t = addCLoc e (hswc_body t) (HsAppType e t)++mkHsAppTypeOut :: LHsExpr Id -> LHsWcType Name -> LHsExpr Id+mkHsAppTypeOut e t = addCLoc e (hswc_body t) (HsAppTypeOut e t)++mkHsLam :: [LPat RdrName] -> LHsExpr RdrName -> LHsExpr RdrName+mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))+  where+    matches = mkMatchGroup Generated+                           [mkSimpleMatch LambdaExpr pats body]++mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id+mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars+                                       <.> mkWpLams dicts) expr++-- |A simple case alternative with a single pattern, no binds, no guards;+-- pre-typechecking+mkHsCaseAlt :: LPat id -> (Located (body id)) -> LMatch id (Located (body id))+mkHsCaseAlt pat expr+  = mkSimpleMatch CaseAlt [pat] expr++nlHsTyApp :: name -> [Type] -> LHsExpr name+nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar (noLoc fun_id)))++nlHsTyApps :: name -> [Type] -> [LHsExpr name] -> LHsExpr name+nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs++--------- Adding parens ---------+mkLHsPar :: LHsExpr name -> LHsExpr name+-- Wrap in parens if hsExprNeedsParens says it needs them+-- So   'f x'  becomes '(f x)', but '3' stays as '3'+mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar le)+                      | otherwise           = le++mkParPat :: LPat name -> LPat name+mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp)+                      | otherwise          = lp++nlParPat :: LPat name -> LPat name+nlParPat p = noLoc (ParPat p)++-------------------------------+-- These are the bits of syntax that contain rebindable names+-- See RnEnv.lookupSyntaxName++mkHsIntegral   :: SourceText -> Integer -> PostTc RdrName Type+               -> HsOverLit RdrName+mkHsFractional :: FractionalLit -> PostTc RdrName Type -> HsOverLit RdrName+mkHsIsString :: SourceText -> FastString -> PostTc RdrName Type+             -> HsOverLit RdrName+mkHsDo         :: HsStmtContext Name -> [ExprLStmt RdrName] -> HsExpr RdrName+mkHsComp       :: HsStmtContext Name -> [ExprLStmt RdrName] -> LHsExpr RdrName+               -> HsExpr RdrName++mkNPat      :: Located (HsOverLit RdrName) -> Maybe (SyntaxExpr RdrName) -> Pat RdrName+mkNPlusKPat :: Located RdrName -> Located (HsOverLit RdrName) -> Pat RdrName++mkLastStmt :: Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))+mkBodyStmt :: Located (bodyR RdrName)+           -> StmtLR idL RdrName (Located (bodyR RdrName))+mkBindStmt :: (PostTc idR Type ~ PlaceHolder)+           => LPat idL -> Located (bodyR idR)+           -> StmtLR idL idR (Located (bodyR idR))+mkTcBindStmt :: LPat Id -> Located (bodyR Id) -> StmtLR Id Id (Located (bodyR Id))++emptyRecStmt     :: StmtLR idL  RdrName bodyR+emptyRecStmtName :: StmtLR Name Name    bodyR+emptyRecStmtId   :: StmtLR Id   Id      bodyR+mkRecStmt    :: [LStmtLR idL RdrName bodyR] -> StmtLR idL RdrName bodyR+++mkHsIntegral src i  = OverLit (HsIntegral   src i) noRebindableInfo noExpr+mkHsFractional   f  = OverLit (HsFractional     f) noRebindableInfo noExpr+mkHsIsString src s  = OverLit (HsIsString   src s) noRebindableInfo noExpr++noRebindableInfo :: PlaceHolder+noRebindableInfo = PlaceHolder -- Just another placeholder;++mkHsDo ctxt stmts = HsDo ctxt (mkLocatedList stmts) placeHolderType+mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])+  where+    last_stmt = L (getLoc expr) $ mkLastStmt expr++mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id+mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b++mkNPat lit neg     = NPat lit neg noSyntaxExpr placeHolderType+mkNPlusKPat id lit = NPlusKPat id lit (unLoc lit) noSyntaxExpr noSyntaxExpr placeHolderType++mkTransformStmt    :: (PostTc idR Type ~ PlaceHolder)+                   => [ExprLStmt idL] -> LHsExpr idR+                   -> StmtLR idL idR (LHsExpr idL)+mkTransformByStmt  :: (PostTc idR Type ~ PlaceHolder)+                   => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR+                   -> StmtLR idL idR (LHsExpr idL)+mkGroupUsingStmt   :: (PostTc idR Type ~ PlaceHolder)+                   => [ExprLStmt idL]                -> LHsExpr idR+                   -> StmtLR idL idR (LHsExpr idL)+mkGroupByUsingStmt :: (PostTc idR Type ~ PlaceHolder)+                   => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR+                   -> StmtLR idL idR (LHsExpr idL)++emptyTransStmt :: (PostTc idR Type ~ PlaceHolder) => StmtLR idL idR (LHsExpr idR)+emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form"+                           , trS_stmts = [], trS_bndrs = []+                           , trS_by = Nothing, trS_using = noLoc noExpr+                           , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr+                           , trS_bind_arg_ty = PlaceHolder+                           , trS_fmap = noExpr }+mkTransformStmt    ss u   = emptyTransStmt { trS_form = ThenForm,  trS_stmts = ss, trS_using = u }+mkTransformByStmt  ss u b = emptyTransStmt { trS_form = ThenForm,  trS_stmts = ss, trS_using = u, trS_by = Just b }+mkGroupUsingStmt   ss u   = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u }+mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b }++mkLastStmt body     = LastStmt body False noSyntaxExpr+mkBodyStmt body     = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType+mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr PlaceHolder+mkTcBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr unitTy+  -- don't use placeHolderTypeTc above, because that panics during zonking++emptyRecStmt' :: forall idL idR body.+                       PostTc idR Type -> StmtLR idL idR body+emptyRecStmt' tyVal =+   RecStmt+     { recS_stmts = [], recS_later_ids = []+     , recS_rec_ids = []+     , recS_ret_fn = noSyntaxExpr+     , recS_mfix_fn = noSyntaxExpr+     , recS_bind_fn = noSyntaxExpr, recS_bind_ty = tyVal+     , recS_later_rets = []+     , recS_rec_rets = [], recS_ret_ty = tyVal }++emptyRecStmt     = emptyRecStmt' placeHolderType+emptyRecStmtName = emptyRecStmt' placeHolderType+emptyRecStmtId   = emptyRecStmt' unitTy -- a panic might trigger during zonking+mkRecStmt stmts  = emptyRecStmt { recS_stmts = stmts }++-------------------------------+--- A useful function for building @OpApps@.  The operator is always a+-- variable, and we don't know the fixity yet.+mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id+mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noLoc op)))+                           (error "mkOpApp:fixity") e2++unqualSplice :: RdrName+unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))++mkUntypedSplice :: SpliceDecoration -> LHsExpr RdrName -> HsSplice RdrName+mkUntypedSplice hasParen e = HsUntypedSplice hasParen unqualSplice e++mkHsSpliceE :: SpliceDecoration -> LHsExpr RdrName -> HsExpr RdrName+mkHsSpliceE hasParen e = HsSpliceE (mkUntypedSplice hasParen e)++mkHsSpliceTE :: SpliceDecoration -> LHsExpr RdrName -> HsExpr RdrName+mkHsSpliceTE hasParen e = HsSpliceE (HsTypedSplice hasParen unqualSplice e)++mkHsSpliceTy :: SpliceDecoration -> LHsExpr RdrName -> HsType RdrName+mkHsSpliceTy hasParen e+  = HsSpliceTy (HsUntypedSplice hasParen unqualSplice e) placeHolderKind++mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice RdrName+mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualSplice quoter span quote++unqualQuasiQuote :: RdrName+unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))+                -- A name (uniquified later) to+                -- identify the quasi-quote++mkHsString :: String -> HsLit+mkHsString s = HsString NoSourceText (mkFastString s)++mkHsStringPrimLit :: FastString -> HsLit+mkHsStringPrimLit fs+  = HsStringPrim NoSourceText (fastStringToByteString fs)++-------------+userHsLTyVarBndrs :: SrcSpan -> [Located name] -> [LHsTyVarBndr name]+-- Caller sets location+userHsLTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ]++userHsTyVarBndrs :: SrcSpan -> [name] -> [LHsTyVarBndr name]+-- Caller sets location+userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ]+++{-+************************************************************************+*                                                                      *+        Constructing syntax with no location info+*                                                                      *+************************************************************************+-}++nlHsVar :: id -> LHsExpr id+nlHsVar n = noLoc (HsVar (noLoc n))++-- NB: Only for LHsExpr **Id**+nlHsDataCon :: DataCon -> LHsExpr Id+nlHsDataCon con = noLoc (HsConLikeOut (RealDataCon con))++nlHsLit :: HsLit -> LHsExpr id+nlHsLit n = noLoc (HsLit n)++nlVarPat :: id -> LPat id+nlVarPat n = noLoc (VarPat (noLoc n))++nlLitPat :: HsLit -> LPat id+nlLitPat l = noLoc (LitPat l)++nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id+nlHsApp f x = noLoc (HsApp f (mkLHsPar x))++nlHsSyntaxApps :: SyntaxExpr id -> [LHsExpr id] -> LHsExpr id+nlHsSyntaxApps (SyntaxExpr { syn_expr      = fun+                           , syn_arg_wraps = arg_wraps+                           , syn_res_wrap  = res_wrap }) args+  | [] <- arg_wraps   -- in the noSyntaxExpr case+  = ASSERT( isIdHsWrapper res_wrap )+    foldl nlHsApp (noLoc fun) args++  | otherwise+  = mkLHsWrap res_wrap (foldl nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps"+                                                     mkLHsWrap arg_wraps args))++nlHsIntLit :: Integer -> LHsExpr id+nlHsIntLit n = noLoc (HsLit (HsInt NoSourceText n))++nlHsApps :: id -> [LHsExpr id] -> LHsExpr id+nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs++nlHsVarApps :: id -> [id] -> LHsExpr id+nlHsVarApps f xs = noLoc (foldl mk (HsVar (noLoc f)) (map (HsVar . noLoc) xs))+                 where+                   mk f a = HsApp (noLoc f) (noLoc a)++nlConVarPat :: RdrName -> [RdrName] -> LPat RdrName+nlConVarPat con vars = nlConPat con (map nlVarPat vars)++nlConVarPatName :: Name -> [Name] -> LPat Name+nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)++nlInfixConPat :: id -> LPat id -> LPat id -> LPat id+nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))++nlConPat :: RdrName -> [LPat RdrName] -> LPat RdrName+nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))++nlConPatName :: Name -> [LPat Name] -> LPat Name+nlConPatName con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))++nlNullaryConPat :: id -> LPat id+nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))++nlWildConPat :: DataCon -> LPat RdrName+nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))+                         (PrefixCon (nOfThem (dataConSourceArity con)+                                             nlWildPat)))++nlWildPat :: LPat RdrName+nlWildPat  = noLoc (WildPat placeHolderType )  -- Pre-typechecking++nlWildPatName :: LPat Name+nlWildPatName  = noLoc (WildPat placeHolderType )  -- Pre-typechecking++nlWildPatId :: LPat Id+nlWildPatId  = noLoc (WildPat placeHolderTypeTc )  -- Post-typechecking++nlHsDo :: HsStmtContext Name -> [LStmt RdrName (LHsExpr RdrName)]+       -> LHsExpr RdrName+nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)++nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id+nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)++nlHsLam  :: LMatch RdrName (LHsExpr RdrName) -> LHsExpr RdrName+nlHsPar  :: LHsExpr id -> LHsExpr id+nlHsIf   :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id+nlHsCase :: LHsExpr RdrName -> [LMatch RdrName (LHsExpr RdrName)]+         -> LHsExpr RdrName+nlList   :: [LHsExpr RdrName] -> LHsExpr RdrName++nlHsLam match          = noLoc (HsLam (mkMatchGroup Generated [match]))+nlHsPar e              = noLoc (HsPar e)++-- Note [Rebindable nlHsIf]+-- nlHsIf should generate if-expressions which are NOT subject to+-- RebindableSyntax, so the first field of HsIf is Nothing. (#12080)+nlHsIf cond true false = noLoc (HsIf Nothing cond true false)++nlHsCase expr matches  = noLoc (HsCase expr (mkMatchGroup Generated matches))+nlList exprs           = noLoc (ExplicitList placeHolderType Nothing exprs)++nlHsAppTy :: LHsType name -> LHsType name -> LHsType name+nlHsTyVar :: name                         -> LHsType name+nlHsFunTy :: LHsType name -> LHsType name -> LHsType name+nlHsParTy :: LHsType name                 -> LHsType name++nlHsAppTy f t           = noLoc (HsAppTy f t)+nlHsTyVar x             = noLoc (HsTyVar NotPromoted (noLoc x))+nlHsFunTy a b           = noLoc (HsFunTy a b)+nlHsParTy t             = noLoc (HsParTy t)++nlHsTyConApp :: name -> [LHsType name] -> LHsType name+nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys++{-+Tuples.  All these functions are *pre-typechecker* because they lack+types on the tuple.+-}++mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a+-- Makes a pre-typechecker boxed tuple, deals with 1 case+mkLHsTupleExpr [e] = e+mkLHsTupleExpr es  = noLoc $ ExplicitTuple (map (noLoc . Present) es) Boxed++mkLHsVarTuple :: [a] -> LHsExpr a+mkLHsVarTuple ids  = mkLHsTupleExpr (map nlHsVar ids)++nlTuplePat :: [LPat id] -> Boxity -> LPat id+nlTuplePat pats box = noLoc (TuplePat pats box [])++missingTupArg :: HsTupArg RdrName+missingTupArg = Missing placeHolderType++mkLHsPatTup :: [LPat id] -> LPat id+mkLHsPatTup []     = noLoc $ TuplePat [] Boxed []+mkLHsPatTup [lpat] = lpat+mkLHsPatTup lpats  = L (getLoc (head lpats)) $ TuplePat lpats Boxed []++-- The Big equivalents for the source tuple expressions+mkBigLHsVarTup :: [id] -> LHsExpr id+mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)++mkBigLHsTup :: [LHsExpr id] -> LHsExpr id+mkBigLHsTup = mkChunkified mkLHsTupleExpr++-- The Big equivalents for the source tuple patterns+mkBigLHsVarPatTup :: [id] -> LPat id+mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)++mkBigLHsPatTup :: [LPat id] -> LPat id+mkBigLHsPatTup = mkChunkified mkLHsPatTup++-- $big_tuples+-- #big_tuples#+--+-- GHCs built in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but+-- we might concievably want to build such a massive tuple as part of the+-- output of a desugaring stage (notably that for list comprehensions).+--+-- We call tuples above this size \"big tuples\", and emulate them by+-- creating and pattern matching on >nested< tuples that are expressible+-- by GHC.+--+-- Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects)+-- than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any+-- construction to be big.+--+-- If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkTupleSelector'+-- and 'mkTupleCase' functions to do all your work with tuples you should be+-- fine, and not have to worry about the arity limitation at all.++-- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decompositon+mkChunkified :: ([a] -> a)      -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE'+             -> [a]             -- ^ Possible \"big\" list of things to construct from+             -> a               -- ^ Constructed thing made possible by recursive decomposition+mkChunkified small_tuple as = mk_big_tuple (chunkify as)+  where+        -- Each sub-list is short enough to fit in a tuple+    mk_big_tuple [as] = small_tuple as+    mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))++chunkify :: [a] -> [[a]]+-- ^ Split a list into lists that are small enough to have a corresponding+-- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE'+-- But there may be more than 'mAX_TUPLE_SIZE' sub-lists+chunkify xs+  | n_xs <= mAX_TUPLE_SIZE = [xs]+  | otherwise              = split xs+  where+    n_xs     = length xs+    split [] = []+    split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)++{-+************************************************************************+*                                                                      *+        LHsSigType and LHsSigWcType+*                                                                      *+********************************************************************* -}++mkLHsSigType :: LHsType RdrName -> LHsSigType RdrName+mkLHsSigType ty = mkHsImplicitBndrs ty++mkLHsSigWcType :: LHsType RdrName -> LHsSigWcType RdrName+mkLHsSigWcType ty = mkHsWildCardBndrs (mkHsImplicitBndrs ty)++mkHsSigEnv :: forall a. (LSig Name -> Maybe ([Located Name], a))+                     -> [LSig Name]+                     -> NameEnv a+mkHsSigEnv get_info sigs+  = mkNameEnv          (mk_pairs ordinary_sigs)+   `extendNameEnvList` (mk_pairs gen_dm_sigs)+   -- The subtlety is this: in a class decl with a+   -- default-method signature as well as a method signature+   -- we want the latter to win (Trac #12533)+   --    class C x where+   --       op :: forall a . x a -> x a+   --       default op :: forall b . x b -> x b+   --       op x = ...(e :: b -> b)...+   -- The scoped type variables of the 'default op', namely 'b',+   -- scope over the code for op.   The 'forall a' does not!+   -- This applies both in the renamer and typechecker, both+   -- of which use this function+  where+    (gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs+    is_gen_dm_sig (L _ (ClassOpSig True _ _)) = True+    is_gen_dm_sig _                           = False++    mk_pairs :: [LSig Name] -> [(Name, a)]+    mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs+                            , L _ n <- ns ]++mkClassOpSigs :: [LSig RdrName] -> [LSig RdrName]+-- Convert TypeSig to ClassOpSig+-- The former is what is parsed, but the latter is+-- what we need in class/instance declarations+mkClassOpSigs sigs+  = map fiddle sigs+  where+    fiddle (L loc (TypeSig nms ty)) = L loc (ClassOpSig False nms (dropWildCards ty))+    fiddle sig                      = sig++typeToLHsType :: Type -> LHsType RdrName+-- ^ Converting a Type to an HsType RdrName+-- This is needed to implement GeneralizedNewtypeDeriving.+--+-- Note that we use 'getRdrName' extensively, which+-- generates Exact RdrNames rather than strings.+typeToLHsType ty+  = go ty+  where+    go :: Type -> LHsType RdrName+    go ty@(FunTy arg _)+      | isPredTy arg+      , (theta, tau) <- tcSplitPhiTy ty+      = noLoc (HsQualTy { hst_ctxt = noLoc (map go theta)+                        , hst_body = go tau })+    go (FunTy arg res) = nlHsFunTy (go arg) (go res)+    go ty@(ForAllTy {})+      | (tvs, tau) <- tcSplitForAllTys ty+      = noLoc (HsForAllTy { hst_bndrs = map go_tv tvs+                          , hst_body = go tau })+    go (TyVarTy tv)         = nlHsTyVar (getRdrName tv)+    go (AppTy t1 t2)        = nlHsAppTy (go t1) (go t2)+    go (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy NoSourceText n)+    go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy NoSourceText s)+    go (TyConApp tc args)   = nlHsTyConApp (getRdrName tc) (map go args')+       where+         args' = filterOutInvisibleTypes tc args+    go (CastTy ty _)        = go ty+    go (CoercionTy co)      = pprPanic "toLHsSigWcType" (ppr co)++         -- Source-language types have _invisible_ kind arguments,+         -- so we must remove them here (Trac #8563)++    go_tv :: TyVar -> LHsTyVarBndr RdrName+    go_tv tv = noLoc $ KindedTyVar (noLoc (getRdrName tv))+                                   (go (tyVarKind tv))+++{- *********************************************************************+*                                                                      *+    --------- HsWrappers: type args, dict args, casts ---------+*                                                                      *+********************************************************************* -}++mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id+mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)++mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id+mkHsWrap co_fn e | isIdHsWrapper co_fn = e+                 | otherwise           = HsWrap co_fn e++mkHsWrapCo :: TcCoercionN   -- A Nominal coercion  a ~N b+           -> HsExpr id -> HsExpr id+mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e++mkHsWrapCoR :: TcCoercionR   -- A Representational coercion  a ~R b+            -> HsExpr id -> HsExpr id+mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e++mkLHsWrapCo :: TcCoercionN -> LHsExpr id -> LHsExpr id+mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)++mkHsCmdWrap :: HsWrapper -> HsCmd id -> HsCmd id+mkHsCmdWrap w cmd | isIdHsWrapper w = cmd+                  | otherwise       = HsCmdWrap w cmd++mkLHsCmdWrap :: HsWrapper -> LHsCmd id -> LHsCmd id+mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c)++mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id+mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p+                       | otherwise           = CoPat co_fn p ty++mkHsWrapPatCo :: TcCoercionN -> Pat id -> Type -> Pat id+mkHsWrapPatCo co pat ty | isTcReflCo co = pat+                        | otherwise     = CoPat (mkWpCastN co) pat ty++mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id+mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr++{-+l+************************************************************************+*                                                                      *+                Bindings; with a location at the top+*                                                                      *+************************************************************************+-}++mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)]+          -> HsBind RdrName+-- Not infix, with place holders for coercion and free vars+mkFunBind fn ms = FunBind { fun_id = fn+                          , fun_matches = mkMatchGroup Generated ms+                          , fun_co_fn = idHsWrapper+                          , bind_fvs = placeHolderNames+                          , fun_tick = [] }++mkTopFunBind :: Origin -> Located Name -> [LMatch Name (LHsExpr Name)]+             -> HsBind Name+-- In Name-land, with empty bind_fvs+mkTopFunBind origin fn ms = FunBind { fun_id = fn+                                    , fun_matches = mkMatchGroup origin ms+                                    , fun_co_fn = idHsWrapper+                                    , bind_fvs = emptyNameSet -- NB: closed+                                                              --     binding+                                    , fun_tick = [] }++mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName+mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs++mkVarBind :: id -> LHsExpr id -> LHsBind id+mkVarBind var rhs = L (getLoc rhs) $+                    VarBind { var_id = var, var_rhs = rhs, var_inline = False }++mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName)+             -> LPat RdrName -> HsPatSynDir RdrName -> HsBind RdrName+mkPatSynBind name details lpat dir = PatSynBind psb+  where+    psb = PSB{ psb_id = name+             , psb_args = details+             , psb_def = lpat+             , psb_dir = dir+             , psb_fvs = placeHolderNames }++-- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is+-- considered infix.+isInfixFunBind :: HsBindLR id1 id2 -> Bool+isInfixFunBind (FunBind _ (MG matches _ _ _) _ _ _)+  = any (isInfixMatch . unLoc) (unLoc matches)+isInfixFunBind _ = False+++------------+mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]+                -> LHsExpr RdrName -> LHsBind RdrName+mk_easy_FunBind loc fun pats expr+  = L loc $ mkFunBind (L loc fun)+              [mkMatch (mkPrefixFunRhs (L loc fun)) pats expr+                       (noLoc emptyLocalBinds)]++-- | Make a prefix, non-strict function 'HsMatchContext'+mkPrefixFunRhs :: Located id -> HsMatchContext id+mkPrefixFunRhs n = FunRhs n Prefix NoSrcStrict++------------+mkMatch :: HsMatchContext (NameOrRdrName id) -> [LPat id] -> LHsExpr id+        -> Located (HsLocalBinds id) -> LMatch id (LHsExpr id)+mkMatch ctxt pats expr lbinds+  = noLoc (Match ctxt (map paren pats) Nothing+                 (GRHSs (unguardedRHS noSrcSpan expr) lbinds))+  where+    paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)+                     | otherwise          = lp++{-+************************************************************************+*                                                                      *+        Collecting binders+*                                                                      *+************************************************************************++Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.++...+where+  (x, y) = ...+  f i j  = ...+  [a, b] = ...++it should return [x, y, f, a, b] (remember, order important).++Note [Collect binders only after renaming]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+These functions should only be used on HsSyn *after* the renamer,+to return a [Name] or [Id].  Before renaming the record punning+and wild-card mechanism makes it hard to know what is bound.+So these functions should not be applied to (HsSyn RdrName)++Note [Unlifted id check in isHsUnliftedBind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose there is a binding with the type (Num a => (# a, a #)). Is this a+strict binding that should be disallowed at the top level? At first glance,+no, because it's a function. But consider how this is desugared via+AbsBinds:++  -- x :: Num a => (# a, a #)+  x = (# 3, 4 #)++becomes++  x = \ $dictNum ->+      let x_mono = (# fromInteger $dictNum 3, fromInteger $dictNum 4 #) in+      x_mono++Note that the inner let is strict. And thus if we have a bunch of mutually+recursive bindings of this form, we could end up in trouble. This was shown+up in #9140.++But if there is a type signature on x, everything changes because of the+desugaring used by AbsBindsSig:++  x :: Num a => (# a, a #)+  x = (# 3, 4 #)++becomes++  x = \ $dictNum -> (# fromInteger $dictNum 3, fromInteger $dictNum 4 #)++No strictness anymore! The bottom line here is that, for inferred types, we+care about the strictness of the type after the =>. For checked types+(AbsBindsSig), we care about the overall strictness.++This matters. If we don't separate out the AbsBindsSig case, then GHC runs into+a problem when compiling++  undefined :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a++Looking only after the =>, we cannot tell if this is strict or not. (GHC panics+if you try.) Looking at the whole type, on the other hand, tells you that this+is a lifted function type, with no trouble at all.++-}++----------------- Bindings --------------------------++-- | Should we treat this as an unlifted bind? This will be true for any+-- bind that binds an unlifted variable, but we must be careful around+-- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage+-- information, see Note [Strict binds check] is DsBinds.+isUnliftedHsBind :: HsBind Id -> Bool  -- works only over typechecked binds+isUnliftedHsBind (AbsBindsSig { abs_sig_export = id })+  = isUnliftedType (idType id)+isUnliftedHsBind bind+  = any is_unlifted_id (collectHsBindBinders bind)+  where+    is_unlifted_id id+      = case tcSplitSigmaTy (idType id) of+          (_, _, tau) -> isUnliftedType tau+          -- For the is_unlifted check, we need to look inside polymorphism+          -- and overloading.  E.g.  x = (# 1, True #)+          -- would get type forall a. Num a => (# a, Bool #)+          -- and we want to reject that.  See Trac #9140++-- | Is a binding a strict variable bind (e.g. @!x = ...@)?+isBangedBind :: HsBind Id -> Bool+isBangedBind b | isBangedPatBind b = True+isBangedBind (FunBind {fun_matches = matches})+  | [L _ match] <- unLoc $ mg_alts matches+  , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match+  = True+isBangedBind _ = False++collectLocalBinders :: HsLocalBindsLR idL idR -> [idL]+collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds+                                         -- No pattern synonyms here+collectLocalBinders (HsIPBinds _)      = []+collectLocalBinders EmptyLocalBinds    = []++collectHsIdBinders, collectHsValBinders :: HsValBindsLR idL idR -> [idL]+-- Collect Id binders only, or Ids + pattern synonyms, respectively+collectHsIdBinders  = collect_hs_val_binders True+collectHsValBinders = collect_hs_val_binders False++collectHsBindBinders :: HsBindLR idL idR -> [idL]+-- Collect both Ids and pattern-synonym binders+collectHsBindBinders b = collect_bind False b []++collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]+collectHsBindsBinders binds = collect_binds False binds []++collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL]+-- Same as collectHsBindsBinders, but works over a list of bindings+collectHsBindListBinders = foldr (collect_bind False . unLoc) []++collect_hs_val_binders :: Bool -> HsValBindsLR idL idR -> [idL]+collect_hs_val_binders ps (ValBindsIn  binds _) = collect_binds     ps binds []+collect_hs_val_binders ps (ValBindsOut binds _) = collect_out_binds ps binds++collect_out_binds :: Bool -> [(RecFlag, LHsBinds id)] -> [id]+collect_out_binds ps = foldr (collect_binds ps . snd) []++collect_binds :: Bool -> LHsBindsLR idL idR -> [idL] -> [idL]+-- Collect Ids, or Ids + pattern synonyms, depending on boolean flag+collect_binds ps binds acc = foldrBag (collect_bind ps . unLoc) acc binds++collect_bind :: Bool -> HsBindLR idL idR -> [idL] -> [idL]+collect_bind _ (PatBind { pat_lhs = p })           acc = collect_lpat p acc+collect_bind _ (FunBind { fun_id = L _ f })        acc = f : acc+collect_bind _ (VarBind { var_id = f })            acc = f : acc+collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc+        -- I don't think we want the binders from the abe_binds+        -- The only time we collect binders from a typechecked+        -- binding (hence see AbsBinds) is in zonking in TcHsSyn+collect_bind _ (AbsBindsSig { abs_sig_export = poly }) acc = poly : acc+collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc+  | omitPatSyn                  = acc+  | otherwise                   = ps : acc++collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]+-- Used exclusively for the bindings of an instance decl which are all FunBinds+collectMethodBinders binds = foldrBag (get . unLoc) [] binds+  where+    get (FunBind { fun_id = f }) fs = f : fs+    get _                        fs = fs+       -- Someone else complains about non-FunBinds++----------------- Statements --------------------------+collectLStmtsBinders :: [LStmtLR idL idR body] -> [idL]+collectLStmtsBinders = concatMap collectLStmtBinders++collectStmtsBinders :: [StmtLR idL idR body] -> [idL]+collectStmtsBinders = concatMap collectStmtBinders++collectLStmtBinders :: LStmtLR idL idR body -> [idL]+collectLStmtBinders = collectStmtBinders . unLoc++collectStmtBinders :: StmtLR idL idR body -> [idL]+  -- Id Binders for a Stmt... [but what about pattern-sig type vars]?+collectStmtBinders (BindStmt pat _ _ _ _)= collectPatBinders pat+collectStmtBinders (LetStmt (L _ binds)) = collectLocalBinders binds+collectStmtBinders (BodyStmt {})         = []+collectStmtBinders (LastStmt {})         = []+collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders+                                      $ [s | ParStmtBlock ss _ _ <- xs, s <- ss]+collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts+collectStmtBinders (RecStmt { recS_stmts = ss })     = collectLStmtsBinders ss+collectStmtBinders ApplicativeStmt{} = []+++----------------- Patterns --------------------------+collectPatBinders :: LPat a -> [a]+collectPatBinders pat = collect_lpat pat []++collectPatsBinders :: [LPat a] -> [a]+collectPatsBinders pats = foldr collect_lpat [] pats++-------------+collect_lpat :: LPat name -> [name] -> [name]+collect_lpat (L _ pat) bndrs+  = go pat+  where+    go (VarPat (L _ var))         = var : bndrs+    go (WildPat _)                = bndrs+    go (LazyPat pat)              = collect_lpat pat bndrs+    go (BangPat pat)              = collect_lpat pat bndrs+    go (AsPat (L _ a) pat)        = a : collect_lpat pat bndrs+    go (ViewPat _ pat _)          = collect_lpat pat bndrs+    go (ParPat  pat)              = collect_lpat pat bndrs++    go (ListPat pats _ _)         = foldr collect_lpat bndrs pats+    go (PArrPat pats _)           = foldr collect_lpat bndrs pats+    go (TuplePat pats _ _)        = foldr collect_lpat bndrs pats+    go (SumPat pat _ _ _)         = collect_lpat pat bndrs++    go (ConPatIn _ ps)            = foldr collect_lpat bndrs (hsConPatArgs ps)+    go (ConPatOut {pat_args=ps})  = foldr collect_lpat bndrs (hsConPatArgs ps)+        -- See Note [Dictionary binders in ConPatOut]+    go (LitPat _)                 = bndrs+    go (NPat {})                  = bndrs+    go (NPlusKPat (L _ n) _ _ _ _ _)= n : bndrs++    go (SigPatIn pat _)           = collect_lpat pat bndrs+    go (SigPatOut pat _)          = collect_lpat pat bndrs++    go (SplicePat (HsSpliced _ (HsSplicedPat pat)))+                                  = go pat+    go (SplicePat _)              = bndrs+    go (CoPat _ pat _)            = go pat++{-+Note [Dictionary binders in ConPatOut] See also same Note in DsArrows+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Do *not* gather (a) dictionary and (b) dictionary bindings as binders+of a ConPatOut pattern.  For most calls it doesn't matter, because+it's pre-typechecker and there are no ConPatOuts.  But it does matter+more in the desugarer; for example, DsUtils.mkSelectorBinds uses+collectPatBinders.  In a lazy pattern, for example f ~(C x y) = ...,+we want to generate bindings for x,y but not for dictionaries bound by+C.  (The type checker ensures they would not be used.)++Desugaring of arrow case expressions needs these bindings (see DsArrows+and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its+own pat-binder-collector:++Here's the problem.  Consider++data T a where+   C :: Num a => a -> Int -> T a++f ~(C (n+1) m) = (n,m)++Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),+and *also* uses that dictionary to match the (n+1) pattern.  Yet, the+variables bound by the lazy pattern are n,m, *not* the dictionary d.+So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.+-}++hsGroupBinders :: HsGroup Name -> [Name]+hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,+                          hs_fords = foreign_decls })+  =  collectHsValBinders val_decls+  ++ hsTyClForeignBinders tycl_decls foreign_decls++hsTyClForeignBinders :: [TyClGroup Name]+                     -> [LForeignDecl Name]+                     -> [Name]+-- We need to look at instance declarations too,+-- because their associated types may bind data constructors+hsTyClForeignBinders tycl_decls foreign_decls+  =    map unLoc (hsForeignDeclsBinders foreign_decls)+    ++ getSelectorNames+         (foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls+         `mappend`+         foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls)+  where+    getSelectorNames :: ([Located Name], [LFieldOcc Name]) -> [Name]+    getSelectorNames (ns, fs) = map unLoc ns ++ map (selectorFieldOcc.unLoc) fs++-------------------+hsLTyClDeclBinders :: Located (TyClDecl name) -> ([Located name], [LFieldOcc name])+-- ^ Returns all the /binding/ names of the decl.  The first one is++-- guaranteed to be the name of the decl. The first component+-- represents all binding names except record fields; the second+-- represents field occurrences. For record fields mentioned in+-- multiple constructors, the SrcLoc will be from the first occurrence.+--+-- Each returned (Located name) has a SrcSpan for the /whole/ declaration.+-- See Note [SrcSpan for binders]++hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } }))+  = ([L loc name], [])+hsLTyClDeclBinders (L loc (SynDecl     { tcdLName = L _ name })) = ([L loc name], [])+hsLTyClDeclBinders (L loc (ClassDecl   { tcdLName = L _ cls_name+                                       , tcdSigs = sigs, tcdATs = ats }))+  = (L loc cls_name :+     [ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] +++     [ L mem_loc mem_name | L mem_loc (ClassOpSig False ns _) <- sigs, L _ mem_name <- ns ]+    , [])+hsLTyClDeclBinders (L loc (DataDecl    { tcdLName = L _ name, tcdDataDefn = defn }))+  = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn++-------------------+hsForeignDeclsBinders :: [LForeignDecl name] -> [Located name]+-- See Note [SrcSpan for binders]+hsForeignDeclsBinders foreign_decls+  = [ L decl_loc n+    | L decl_loc (ForeignImport { fd_name = L _ n }) <- foreign_decls]+++-------------------+hsPatSynSelectors :: HsValBinds id -> [id]+-- Collects record pattern-synonym selectors only; the pattern synonym+-- names are collected by collectHsValBinders.+hsPatSynSelectors (ValBindsIn _ _) = panic "hsPatSynSelectors"+hsPatSynSelectors (ValBindsOut binds _)+  = foldrBag addPatSynSelector [] . unionManyBags $ map snd binds++addPatSynSelector:: LHsBind id -> [id] -> [id]+addPatSynSelector bind sels+  | L _ (PatSynBind (PSB { psb_args = RecordPatSyn as })) <- bind+  = map (unLoc . recordPatSynSelectorId) as ++ sels+  | otherwise = sels++getPatSynBinds :: [(RecFlag, LHsBinds id)] -> [PatSynBind id id]+getPatSynBinds binds+  = [ psb | (_, lbinds) <- binds+          , L _ (PatSynBind psb) <- bagToList lbinds ]++-------------------+hsLInstDeclBinders :: LInstDecl name -> ([Located name], [LFieldOcc name])+hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } }))+  = foldMap (hsDataFamInstBinders . unLoc) dfis+hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi }))+  = hsDataFamInstBinders fi+hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty++-------------------+-- the SrcLoc returned are for the whole declarations, not just the names+hsDataFamInstBinders :: DataFamInstDecl name -> ([Located name], [LFieldOcc name])+hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn })+  = hsDataDefnBinders defn+  -- There can't be repeated symbols because only data instances have binders++-------------------+-- the SrcLoc returned are for the whole declarations, not just the names+hsDataDefnBinders :: HsDataDefn name -> ([Located name], [LFieldOcc name])+hsDataDefnBinders (HsDataDefn { dd_cons = cons })+  = hsConDeclsBinders cons+  -- See Note [Binders in family instances]++-------------------+hsConDeclsBinders :: [LConDecl name] -> ([Located name], [LFieldOcc name])+  -- See hsLTyClDeclBinders for what this does+  -- The function is boringly complicated because of the records+  -- And since we only have equality, we have to be a little careful+hsConDeclsBinders cons = go id cons+  where go :: ([LFieldOcc name] -> [LFieldOcc name])+           -> [LConDecl name] -> ([Located name], [LFieldOcc name])+        go _ [] = ([], [])+        go remSeen (r:rs) =+          -- don't re-mangle the location of field names, because we don't+          -- have a record of the full location of the field declaration anyway+          case r of+             -- remove only the first occurrence of any seen field in order to+             -- avoid circumventing detection of duplicate fields (#9156)+             L loc (ConDeclGADT { con_names = names+                                , con_type = HsIB { hsib_body = res_ty}}) ->+               case tau of+                 L _ (HsFunTy+                      (L _ (HsAppsTy+                            [L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _res_ty)+                         -> record_gadt flds+                 L _ (HsFunTy (L _ (HsRecTy flds)) _res_ty)+                         -> record_gadt flds++                 _other  -> (map (L loc . unLoc) names ++ ns, fs)+                            where (ns, fs) = go remSeen rs+               where+                 (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty+                 record_gadt flds = (map (L loc . unLoc) names ++ ns, r' ++ fs)+                   where r' = remSeen (concatMap (cd_fld_names . unLoc) flds)+                         remSeen' = foldr (.) remSeen+                                        [deleteBy ((==) `on`+                                              unLoc . rdrNameFieldOcc . unLoc) v+                                        | v <- r']+                         (ns, fs) = go remSeen' rs++             L loc (ConDeclH98 { con_name = name+                               , con_details = RecCon flds }) ->+               ([L loc (unLoc name)] ++ ns, r' ++ fs)+                  where r' = remSeen (concatMap (cd_fld_names . unLoc)+                                                (unLoc flds))+                        remSeen'+                          = foldr (.) remSeen+                               [deleteBy ((==) `on`+                                   unLoc . rdrNameFieldOcc . unLoc) v | v <- r']+                        (ns, fs) = go remSeen' rs+             L loc (ConDeclH98 { con_name = name }) ->+                ([L loc (unLoc name)] ++ ns, fs)+                  where (ns, fs) = go remSeen rs++{-++Note [SrcSpan for binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~+When extracting the (Located RdrNme) for a binder, at least for the+main name (the TyCon of a type declaration etc), we want to give it+the @SrcSpan@ of the whole /declaration/, not just the name itself+(which is how it appears in the syntax tree).  This SrcSpan (for the+entire declaration) is used as the SrcSpan for the Name that is+finally produced, and hence for error messages.  (See Trac #8607.)++Note [Binders in family instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a type or data family instance declaration, the type+constructor is an *occurrence* not a binding site+    type instance T Int = Int -> Int   -- No binders+    data instance S Bool = S1 | S2     -- Binders are S1,S2+++************************************************************************+*                                                                      *+        Collecting binders the user did not write+*                                                                      *+************************************************************************++The job of this family of functions is to run through binding sites and find the set of all Names+that were defined "implicitly", without being explicitly written by the user.++The main purpose is to find names introduced by record wildcards so that we can avoid+warning the user when they don't use those names (#4404)+-}++lStmtsImplicits :: [LStmtLR Name idR (Located (body idR))] -> NameSet+lStmtsImplicits = hs_lstmts+  where+    hs_lstmts :: [LStmtLR Name idR (Located (body idR))] -> NameSet+    hs_lstmts = foldr (\stmt rest -> unionNameSet (hs_stmt (unLoc stmt)) rest) emptyNameSet++    hs_stmt :: StmtLR Name idR (Located (body idR)) -> NameSet+    hs_stmt (BindStmt pat _ _ _ _) = lPatImplicits pat+    hs_stmt (ApplicativeStmt args _ _) = unionNameSets (map do_arg args)+      where do_arg (_, ApplicativeArgOne pat _) = lPatImplicits pat+            do_arg (_, ApplicativeArgMany stmts _ _) = hs_lstmts stmts+    hs_stmt (LetStmt binds)      = hs_local_binds (unLoc binds)+    hs_stmt (BodyStmt {})        = emptyNameSet+    hs_stmt (LastStmt {})        = emptyNameSet+    hs_stmt (ParStmt xs _ _ _)   = hs_lstmts [s | ParStmtBlock ss _ _ <- xs, s <- ss]+    hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts+    hs_stmt (RecStmt { recS_stmts = ss })     = hs_lstmts ss++    hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds+    hs_local_binds (HsIPBinds _)         = emptyNameSet+    hs_local_binds EmptyLocalBinds       = emptyNameSet++hsValBindsImplicits :: HsValBindsLR Name idR -> NameSet+hsValBindsImplicits (ValBindsOut binds _)+  = foldr (unionNameSet . lhsBindsImplicits . snd) emptyNameSet binds+hsValBindsImplicits (ValBindsIn binds _)+  = lhsBindsImplicits binds++lhsBindsImplicits :: LHsBindsLR Name idR -> NameSet+lhsBindsImplicits = foldBag unionNameSet (lhs_bind . unLoc) emptyNameSet+  where+    lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat+    lhs_bind _ = emptyNameSet++lPatImplicits :: LPat Name -> NameSet+lPatImplicits = hs_lpat+  where+    hs_lpat (L _ pat) = hs_pat pat++    hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSet` rest) emptyNameSet++    hs_pat (LazyPat pat)       = hs_lpat pat+    hs_pat (BangPat pat)       = hs_lpat pat+    hs_pat (AsPat _ pat)       = hs_lpat pat+    hs_pat (ViewPat _ pat _)   = hs_lpat pat+    hs_pat (ParPat  pat)       = hs_lpat pat+    hs_pat (ListPat pats _ _)  = hs_lpats pats+    hs_pat (PArrPat pats _)    = hs_lpats pats+    hs_pat (TuplePat pats _ _) = hs_lpats pats++    hs_pat (SigPatIn pat _)  = hs_lpat pat+    hs_pat (SigPatOut pat _) = hs_lpat pat+    hs_pat (CoPat _ pat _)   = hs_pat pat++    hs_pat (ConPatIn _ ps)           = details ps+    hs_pat (ConPatOut {pat_args=ps}) = details ps++    hs_pat _ = emptyNameSet++    details (PrefixCon ps)   = hs_lpats ps+    details (RecCon fs)      = hs_lpats explicit `unionNameSet` mkNameSet (collectPatsBinders implicit)+      where (explicit, implicit) = partitionEithers [if pat_explicit then Left pat else Right pat+                                                    | (i, fld) <- [0..] `zip` rec_flds fs+                                                    , let pat = hsRecFieldArg+                                                                     (unLoc fld)+                                                          pat_explicit = maybe True (i<) (rec_dotdot fs)]+    details (InfixCon p1 p2) = hs_lpat p1 `unionNameSet` hs_lpat p2
+ hsSyn/PlaceHolder.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StandaloneDeriving #-}++module PlaceHolder where++import Type       ( Type )+import Outputable+import Name+import NameSet+import RdrName+import Var+import Coercion+import ConLike (ConLike)+import FieldLabel+import SrcLoc (Located)+import TcEvidence ( HsWrapper )++import Data.Data hiding ( Fixity )+import BasicTypes       (Fixity)+++{-+%************************************************************************+%*                                                                      *+\subsection{Annotating the syntax}+%*                                                                      *+%************************************************************************+-}++-- NB: These are intentionally open, allowing API consumers (like Haddock)+-- to declare new instances++-- | used as place holder in PostTc and PostRn values+data PlaceHolder = PlaceHolder+  deriving (Data)++-- | Types that are not defined until after type checking+type family PostTc id ty  -- Note [Pass sensitive types]+type instance PostTc Id      ty = ty+type instance PostTc Name    ty = PlaceHolder+type instance PostTc RdrName ty = PlaceHolder++-- | Types that are not defined until after renaming+type family PostRn id ty  -- Note [Pass sensitive types]+type instance PostRn Id      ty = ty+type instance PostRn Name    ty = ty+type instance PostRn RdrName ty = PlaceHolder++placeHolderKind :: PlaceHolder+placeHolderKind = PlaceHolder++placeHolderFixity :: PlaceHolder+placeHolderFixity = PlaceHolder++placeHolderType :: PlaceHolder+placeHolderType = PlaceHolder++placeHolderTypeTc :: Type+placeHolderTypeTc = panic "Evaluated the place holder for a PostTcType"++placeHolderNames :: PlaceHolder+placeHolderNames = PlaceHolder++placeHolderNamesTc :: NameSet+placeHolderNamesTc = emptyNameSet++placeHolderHsWrapper :: PlaceHolder+placeHolderHsWrapper = PlaceHolder++{-++Note [Pass sensitive types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Since the same AST types are re-used through parsing,renaming and type+checking there are naturally some places in the AST that do not have+any meaningful value prior to the pass they are assigned a value.++Historically these have been filled in with place holder values of the form++  panic "error message"++This has meant the AST is difficult to traverse using standard generic+programming techniques. The problem is addressed by introducing+pass-specific data types, implemented as a pair of open type families,+one for PostTc and one for PostRn. These are then explicitly populated+with a PlaceHolder value when they do not yet have meaning.++In terms of actual usage, we have the following++  PostTc id Kind+  PostTc id Type++  PostRn id Fixity+  PostRn id NameSet++TcId and Var are synonyms for Id++Unfortunately the type checker termination checking conditions fail for the+DataId constraint type based on this, so even though it is safe the+UndecidableInstances pragma is required where this is used.+-}++type DataId id =+  ( DataIdPost id+  , DataIdPost (NameOrRdrName id)+  )++type DataIdPost id =+  ( Data id+  , Data (PostRn id NameSet)+  , Data (PostRn id Fixity)+  , Data (PostRn id Bool)+  , Data (PostRn id Name)+  , Data (PostRn id (Located Name))+  , Data (PostRn id [Name])++  , Data (PostRn id id)+  , Data (PostTc id Type)+  , Data (PostTc id Coercion)+  , Data (PostTc id id)+  , Data (PostTc id [Type])+  , Data (PostTc id ConLike)+  , Data (PostTc id [ConLike])+  , Data (PostTc id HsWrapper)+  , Data (PostTc id [FieldLabel])+  )+++-- |Follow the @id@, but never beyond Name. This is used in a 'HsMatchContext',+-- for printing messages related to a 'Match'+type family NameOrRdrName id where+  NameOrRdrName Id      = Name+  NameOrRdrName Name    = Name+  NameOrRdrName RdrName = RdrName++-- |Constraint type to bundle up the requirement for 'OutputableBndr' on both+-- the @id@ and the 'NameOrRdrName' type for it+type OutputableBndrId id =+  ( OutputableBndr id+  , OutputableBndr (NameOrRdrName id)+  )
+ iface/BinFingerprint.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE CPP #-}++-- | Computing fingerprints of values serializeable with GHC's "Binary" module.+module BinFingerprint+  ( -- * Computing fingerprints+    fingerprintBinMem+  , computeFingerprint+  , putNameLiterally+  ) where++#include "HsVersions.h"++import Fingerprint+import Binary+import Name+import Panic+import Util++fingerprintBinMem :: BinHandle -> IO Fingerprint+fingerprintBinMem bh = withBinBuffer bh f+  where+    f bs =+        -- we need to take care that we force the result here+        -- lest a reference to the ByteString may leak out of+        -- withBinBuffer.+        let fp = fingerprintByteString bs+        in fp `seq` return fp++computeFingerprint :: (Binary a)+                   => (BinHandle -> Name -> IO ())+                   -> a+                   -> IO Fingerprint+computeFingerprint put_nonbinding_name a = do+    bh <- fmap set_user_data $ openBinMem (3*1024) -- just less than a block+    put_ bh a+    fp <- fingerprintBinMem bh+    return fp+  where+    set_user_data bh =+      setUserData bh $ newWriteState put_nonbinding_name putNameLiterally putFS++-- | Used when we want to fingerprint a structure without depending on the+-- fingerprints of external Names that it refers to.+putNameLiterally :: BinHandle -> Name -> IO ()+putNameLiterally bh name = ASSERT( isExternalName name ) do+    put_ bh $! nameModule name+    put_ bh $! nameOccName name
+ iface/BinIface.hs view
@@ -0,0 +1,390 @@+{-# LANGUAGE BinaryLiterals, CPP, ScopedTypeVariables #-}++--+--  (c) The University of Glasgow 2002-2006+--++{-# OPTIONS_GHC -O #-}+-- We always optimise this, otherwise performance of a non-optimised+-- compiler is severely affected++-- | Binary interface file support.+module BinIface (+        writeBinIface,+        readBinIface,+        getSymtabName,+        getDictFastString,+        CheckHiWay(..),+        TraceBinIFaceReading(..)+    ) where++#include "HsVersions.h"++import TcRnMonad+import PrelInfo   ( isKnownKeyName, lookupKnownKeyName )+import IfaceEnv+import HscTypes+import Module+import Name+import DynFlags+import UniqFM+import UniqSupply+import Panic+import Binary+import SrcLoc+import ErrUtils+import FastMutInt+import Unique+import Outputable+import NameCache+import Platform+import FastString+import Constants+import Util++import Data.Bits+import Data.Char+import Data.List+import Data.Word+import Data.Array+import Data.IORef+import Control.Monad+++-- ---------------------------------------------------------------------------+-- Reading and writing binary interface files+--++data CheckHiWay = CheckHiWay | IgnoreHiWay+    deriving Eq++data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading+    deriving Eq++-- | Read an interface file+readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath+             -> TcRnIf a b ModIface+readBinIface checkHiWay traceBinIFaceReading hi_path = do+    ncu <- mkNameCacheUpdater+    dflags <- getDynFlags+    liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu++readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath+              -> NameCacheUpdater+              -> IO ModIface+readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do+    let printer :: SDoc -> IO ()+        printer = case traceBinIFaceReading of+                      TraceBinIFaceReading -> \sd ->+                          putLogMsg dflags+                                    NoReason+                                    SevOutput+                                    noSrcSpan+                                    (defaultDumpStyle dflags)+                                    sd+                      QuietBinIFaceReading -> \_ -> return ()+        wantedGot :: Outputable a => String -> a -> a -> IO ()+        wantedGot what wanted got =+            printer (text what <> text ": " <>+                     vcat [text "Wanted " <> ppr wanted <> text ",",+                           text "got    " <> ppr got])++        errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()+        errorOnMismatch what wanted got =+            -- This will be caught by readIface which will emit an error+            -- msg containing the iface module name.+            when (wanted /= got) $ throwGhcExceptionIO $ ProgramError+                         (what ++ " (wanted " ++ show wanted+                               ++ ", got "    ++ show got ++ ")")+    bh <- Binary.readBinMem hi_path++    -- Read the magic number to check that this really is a GHC .hi file+    -- (This magic number does not change when we change+    --  GHC interface file format)+    magic <- get bh+    wantedGot "Magic" (binaryInterfaceMagic dflags) magic+    errorOnMismatch "magic number mismatch: old/corrupt interface file?"+        (binaryInterfaceMagic dflags) magic++    -- Note [dummy iface field]+    -- read a dummy 32/64 bit value.  This field used to hold the+    -- dictionary pointer in old interface file formats, but now+    -- the dictionary pointer is after the version (where it+    -- should be).  Also, the serialisation of value of type "Bin+    -- a" used to depend on the word size of the machine, now they+    -- are always 32 bits.+    if wORD_SIZE dflags == 4+        then do _ <- Binary.get bh :: IO Word32; return ()+        else do _ <- Binary.get bh :: IO Word64; return ()++    -- Check the interface file version and ways.+    check_ver  <- get bh+    let our_ver = show hiVersion+    wantedGot "Version" our_ver check_ver+    errorOnMismatch "mismatched interface file versions" our_ver check_ver++    check_way <- get bh+    let way_descr = getWayDescr dflags+    wantedGot "Way" way_descr check_way+    when (checkHiWay == CheckHiWay) $+        errorOnMismatch "mismatched interface file ways" way_descr check_way++    -- Read the dictionary+    -- The next word in the file is a pointer to where the dictionary is+    -- (probably at the end of the file)+    dict_p <- Binary.get bh+    data_p <- tellBin bh          -- Remember where we are now+    seekBin bh dict_p+    dict   <- getDictionary bh+    seekBin bh data_p             -- Back to where we were before++    -- Initialise the user-data field of bh+    bh <- do+        bh <- return $ setUserData bh $ newReadState (error "getSymtabName")+                                                     (getDictFastString dict)+        symtab_p <- Binary.get bh     -- Get the symtab ptr+        data_p <- tellBin bh          -- Remember where we are now+        seekBin bh symtab_p+        symtab <- getSymbolTable bh ncu+        seekBin bh data_p             -- Back to where we were before++        -- It is only now that we know how to get a Name+        return $ setUserData bh $ newReadState (getSymtabName ncu dict symtab)+                                               (getDictFastString dict)++    -- Read the interface file+    get bh++-- | Write an interface file+writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()+writeBinIface dflags hi_path mod_iface = do+    bh <- openBinMem initBinMemSize+    put_ bh (binaryInterfaceMagic dflags)++   -- dummy 32/64-bit field before the version/way for+   -- compatibility with older interface file formats.+   -- See Note [dummy iface field] above.+    if wORD_SIZE dflags == 4+        then Binary.put_ bh (0 :: Word32)+        else Binary.put_ bh (0 :: Word64)++    -- The version and way descriptor go next+    put_ bh (show hiVersion)+    let way_descr = getWayDescr dflags+    put_  bh way_descr++    -- Remember where the dictionary pointer will go+    dict_p_p <- tellBin bh+    -- Placeholder for ptr to dictionary+    put_ bh dict_p_p++    -- Remember where the symbol table pointer will go+    symtab_p_p <- tellBin bh+    put_ bh symtab_p_p++    -- Make some intial state+    symtab_next <- newFastMutInt+    writeFastMutInt symtab_next 0+    symtab_map <- newIORef emptyUFM+    let bin_symtab = BinSymbolTable {+                         bin_symtab_next = symtab_next,+                         bin_symtab_map  = symtab_map }+    dict_next_ref <- newFastMutInt+    writeFastMutInt dict_next_ref 0+    dict_map_ref <- newIORef emptyUFM+    let bin_dict = BinDictionary {+                       bin_dict_next = dict_next_ref,+                       bin_dict_map  = dict_map_ref }++    -- Put the main thing,+    bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab)+                                                  (putName bin_dict bin_symtab)+                                                  (putFastString bin_dict)+    put_ bh mod_iface++    -- Write the symtab pointer at the front of the file+    symtab_p <- tellBin bh        -- This is where the symtab will start+    putAt bh symtab_p_p symtab_p  -- Fill in the placeholder+    seekBin bh symtab_p           -- Seek back to the end of the file++    -- Write the symbol table itself+    symtab_next <- readFastMutInt symtab_next+    symtab_map  <- readIORef symtab_map+    putSymbolTable bh symtab_next symtab_map+    debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next+                                <+> text "Names")++    -- NB. write the dictionary after the symbol table, because+    -- writing the symbol table may create more dictionary entries.++    -- Write the dictionary pointer at the fornt of the file+    dict_p <- tellBin bh          -- This is where the dictionary will start+    putAt bh dict_p_p dict_p      -- Fill in the placeholder+    seekBin bh dict_p             -- Seek back to the end of the file++    -- Write the dictionary itself+    dict_next <- readFastMutInt dict_next_ref+    dict_map  <- readIORef dict_map_ref+    putDictionary bh dict_next dict_map+    debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next+                                <+> text "dict entries")++    -- And send the result to the file+    writeBinMem bh hi_path++-- | Initial ram buffer to allocate for writing interface files+initBinMemSize :: Int+initBinMemSize = 1024 * 1024++binaryInterfaceMagic :: DynFlags -> Word32+binaryInterfaceMagic dflags+ | target32Bit (targetPlatform dflags) = 0x1face+ | otherwise                           = 0x1face64+++-- -----------------------------------------------------------------------------+-- The symbol table+--++putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()+putSymbolTable bh next_off symtab = do+    put_ bh next_off+    let names = elems (array (0,next_off-1) (nonDetEltsUFM symtab))+      -- It's OK to use nonDetEltsUFM here because the elements have+      -- indices that array uses to create order+    mapM_ (\n -> serialiseName bh n symtab) names++getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable+getSymbolTable bh ncu = do+    sz <- get bh+    od_names <- sequence (replicate sz (get bh))+    updateNameCache ncu $ \namecache ->+        let arr = listArray (0,sz-1) names+            (namecache', names) =+                mapAccumR (fromOnDiskName arr) namecache od_names+        in (namecache', arr)++type OnDiskName = (UnitId, ModuleName, OccName)++fromOnDiskName :: Array Int Name -> NameCache -> OnDiskName -> (NameCache, Name)+fromOnDiskName _ nc (pid, mod_name, occ) =+    let mod   = mkModule pid mod_name+        cache = nsNames nc+    in case lookupOrigNameCache cache  mod occ of+           Just name -> (nc, name)+           Nothing   ->+               let (uniq, us) = takeUniqFromSupply (nsUniqs nc)+                   name       = mkExternalName uniq mod occ noSrcSpan+                   new_cache  = extendNameCache cache mod occ name+               in ( nc{ nsUniqs = us, nsNames = new_cache }, name )++serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()+serialiseName bh name _ = do+    let mod = ASSERT2( isExternalName name, ppr name ) nameModule name+    put_ bh (moduleUnitId mod, moduleName mod, nameOccName name)+++-- Note [Symbol table representation of names]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- An occurrence of a name in an interface file is serialized as a single 32-bit+-- word. The format of this word is:+--  00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx+--   A normal name. x is an index into the symbol table+--  10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy+--   A known-key name. x is the Unique's Char, y is the int part. We assume that+--   all known-key uniques fit in this space. This is asserted by+--   PrelInfo.knownKeyNamesOkay.+--+-- During serialization we check for known-key things using isKnownKeyName.+-- During deserialization we use lookupKnownKeyName to get from the unique back+-- to its corresponding Name.+++-- See Note [Symbol table representation of names]+putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO ()+putName _dict BinSymbolTable{+               bin_symtab_map = symtab_map_ref,+               bin_symtab_next = symtab_next }+        bh name+  | isKnownKeyName name+  , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits+  = -- ASSERT(u < 2^(22 :: Int))+    put_ bh (0x80000000+             .|. (fromIntegral (ord c) `shiftL` 22)+             .|. (fromIntegral u :: Word32))++  | otherwise+  = do symtab_map <- readIORef symtab_map_ref+       case lookupUFM symtab_map name of+         Just (off,_) -> put_ bh (fromIntegral off :: Word32)+         Nothing -> do+            off <- readFastMutInt symtab_next+            -- MASSERT(off < 2^(30 :: Int))+            writeFastMutInt symtab_next (off+1)+            writeIORef symtab_map_ref+                $! addToUFM symtab_map name (off,name)+            put_ bh (fromIntegral off :: Word32)++-- See Note [Symbol table representation of names]+getSymtabName :: NameCacheUpdater+              -> Dictionary -> SymbolTable+              -> BinHandle -> IO Name+getSymtabName _ncu _dict symtab bh = do+    i :: Word32 <- get bh+    case i .&. 0xC0000000 of+      0x00000000 -> return $! symtab ! fromIntegral i++      0x80000000 ->+        let+          tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22))+          ix  = fromIntegral i .&. 0x003FFFFF+          u   = mkUnique tag ix+        in+          return $! case lookupKnownKeyName u of+                      Nothing -> pprPanic "getSymtabName:unknown known-key unique"+                                          (ppr i $$ ppr (unpkUnique u))+                      Just n  -> n++      _ -> pprPanic "getSymtabName:unknown name tag" (ppr i)++data BinSymbolTable = BinSymbolTable {+        bin_symtab_next :: !FastMutInt, -- The next index to use+        bin_symtab_map  :: !(IORef (UniqFM (Int,Name)))+                                -- indexed by Name+  }++putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()+putFastString dict bh fs = allocateFastString dict fs >>= put_ bh++allocateFastString :: BinDictionary -> FastString -> IO Word32+allocateFastString BinDictionary { bin_dict_next = j_r,+                                   bin_dict_map  = out_r} f = do+    out <- readIORef out_r+    let uniq = getUnique f+    case lookupUFM out uniq of+        Just (j, _)  -> return (fromIntegral j :: Word32)+        Nothing -> do+           j <- readFastMutInt j_r+           writeFastMutInt j_r (j + 1)+           writeIORef out_r $! addToUFM out uniq (j, f)+           return (fromIntegral j :: Word32)++getDictFastString :: Dictionary -> BinHandle -> IO FastString+getDictFastString dict bh = do+    j <- get bh+    return $! (dict ! fromIntegral (j :: Word32))++data BinDictionary = BinDictionary {+        bin_dict_next :: !FastMutInt, -- The next index to use+        bin_dict_map  :: !(IORef (UniqFM (Int,FastString)))+                                -- indexed by FastString+  }++getWayDescr :: DynFlags -> String+getWayDescr dflags+  | platformUnregisterised (targetPlatform dflags) = 'u':tag+  | otherwise                                      =     tag+  where tag = buildTag dflags+        -- if this is an unregisterised build, make sure our interfaces+        -- can't be used by a registerised build.
+ iface/BuildTyCl.hs view
@@ -0,0 +1,476 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++{-# LANGUAGE CPP #-}++module BuildTyCl (+        buildDataCon, mkDataConUnivTyVarBinders,+        buildPatSyn,+        TcMethInfo, buildClass,+        mkNewTyConRhs, mkDataTyConRhs,+        newImplicitBinder, newTyConRepName+    ) where++#include "HsVersions.h"++import IfaceEnv+import FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom )+import TysWiredIn( isCTupleTyConName )+import TysPrim ( voidPrimTy )+import DataCon+import PatSyn+import Var+import VarSet+import BasicTypes+import Name+import MkId+import Class+import TyCon+import Type+import Id+import TcType++import SrcLoc( SrcSpan, noSrcSpan )+import DynFlags+import TcRnMonad+import UniqSupply+import Util+import Outputable++mkDataTyConRhs :: [DataCon] -> AlgTyConRhs+mkDataTyConRhs cons+  = DataTyCon {+        data_cons = cons,+        is_enum = not (null cons) && all is_enum_con cons+                  -- See Note [Enumeration types] in TyCon+    }+  where+    is_enum_con con+       | (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res)+           <- dataConFullSig con+       = null ex_tvs && null eq_spec && null theta && null arg_tys+++mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs+-- ^ Monadic because it makes a Name for the coercion TyCon+--   We pass the Name of the parent TyCon, as well as the TyCon itself,+--   because the latter is part of a knot, whereas the former is not.+mkNewTyConRhs tycon_name tycon con+  = do  { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc+        ; let nt_ax = mkNewTypeCoAxiom co_tycon_name tycon etad_tvs etad_roles etad_rhs+        ; traceIf (text "mkNewTyConRhs" <+> ppr nt_ax)+        ; return (NewTyCon { data_con    = con,+                             nt_rhs      = rhs_ty,+                             nt_etad_rhs = (etad_tvs, etad_rhs),+                             nt_co       = nt_ax } ) }+                             -- Coreview looks through newtypes with a Nothing+                             -- for nt_co, or uses explicit coercions otherwise+  where+    tvs    = tyConTyVars tycon+    roles  = tyConRoles tycon+    inst_con_ty = piResultTys (dataConUserType con) (mkTyVarTys tvs)+    rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty+        -- Instantiate the data con with the+        -- type variables from the tycon+        -- NB: a newtype DataCon has a type that must look like+        --        forall tvs.  <arg-ty> -> T tvs+        -- Note that we *can't* use dataConInstOrigArgTys here because+        -- the newtype arising from   class Foo a => Bar a where {}+        -- has a single argument (Foo a) that is a *type class*, so+        -- dataConInstOrigArgTys returns [].++    etad_tvs   :: [TyVar]  -- Matched lazily, so that mkNewTypeCo can+    etad_roles :: [Role]   -- return a TyCon without pulling on rhs_ty+    etad_rhs   :: Type     -- See Note [Tricky iface loop] in LoadIface+    (etad_tvs, etad_roles, etad_rhs) = eta_reduce (reverse tvs) (reverse roles) rhs_ty++    eta_reduce :: [TyVar]       -- Reversed+               -> [Role]        -- also reversed+               -> Type          -- Rhs type+               -> ([TyVar], [Role], Type)  -- Eta-reduced version+                                           -- (tyvars in normal order)+    eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty,+                                  Just tv <- getTyVar_maybe arg,+                                  tv == a,+                                  not (a `elemVarSet` tyCoVarsOfType fun)+                                = eta_reduce as rs fun+    eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty)++------------------------------------------------------+buildDataCon :: FamInstEnvs+            -> Name+            -> Bool                     -- Declared infix+            -> TyConRepName+            -> [HsSrcBang]+            -> Maybe [HsImplBang]+                -- See Note [Bangs on imported data constructors] in MkId+           -> [FieldLabel]             -- Field labels+           -> [TyVarBinder]            -- Universals+           -> [TyVarBinder]            -- Existentials+           -> [EqSpec]                 -- Equality spec+           -> ThetaType                -- Does not include the "stupid theta"+                                       -- or the GADT equalities+           -> [Type] -> Type           -- Argument and result types+           -> TyCon                    -- Rep tycon+           -> TcRnIf m n DataCon+-- A wrapper for DataCon.mkDataCon that+--   a) makes the worker Id+--   b) makes the wrapper Id if necessary, including+--      allocating its unique (hence monadic)+--   c) Sorts out the TyVarBinders. See mkDataConUnivTyBinders+buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs field_lbls+             univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon+  = do  { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc+        ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc+        -- This last one takes the name of the data constructor in the source+        -- code, which (for Haskell source anyway) will be in the DataName name+        -- space, and puts it into the VarName name space++        ; traceIf (text "buildDataCon 1" <+> ppr src_name)+        ; us <- newUniqueSupply+        ; dflags <- getDynFlags+        ; let stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs+              data_con = mkDataCon src_name declared_infix prom_info+                                   src_bangs field_lbls+                                   univ_tvs ex_tvs eq_spec ctxt+                                   arg_tys res_ty NoRRI rep_tycon+                                   stupid_ctxt dc_wrk dc_rep+              dc_wrk = mkDataConWorkId work_name data_con+              dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name+                                                impl_bangs data_con)++        ; traceIf (text "buildDataCon 2" <+> ppr src_name)+        ; return data_con }+++-- The stupid context for a data constructor should be limited to+-- the type variables mentioned in the arg_tys+-- ToDo: Or functionally dependent on?+--       This whole stupid theta thing is, well, stupid.+mkDataConStupidTheta :: TyCon -> [Type] -> [TyVarBinder] -> [PredType]+mkDataConStupidTheta tycon arg_tys univ_tvs+  | null stupid_theta = []      -- The common case+  | otherwise         = filter in_arg_tys stupid_theta+  where+    tc_subst     = zipTvSubst (tyConTyVars tycon)+                              (mkTyVarTys (binderVars univ_tvs))+    stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)+        -- Start by instantiating the master copy of the+        -- stupid theta, taken from the TyCon++    arg_tyvars      = tyCoVarsOfTypes arg_tys+    in_arg_tys pred = not $ isEmptyVarSet $+                      tyCoVarsOfType pred `intersectVarSet` arg_tyvars+++mkDataConUnivTyVarBinders :: [TyConBinder]   -- From the TyCon+                          -> [TyVarBinder]   -- For the DataCon+-- See Note [Building the TyBinders for a DataCon]+mkDataConUnivTyVarBinders tc_bndrs+ = map mk_binder tc_bndrs+ where+   mk_binder (TvBndr tv tc_vis) = mkTyVarBinder vis tv+      where+        vis = case tc_vis of+                AnonTCB           -> Specified+                NamedTCB Required -> Specified+                NamedTCB vis      -> vis++{- Note [Building the TyBinders for a DataCon]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A DataCon needs to keep track of the visibility of its universals and+existentials, so that visible type application can work properly. This+is done by storing the universal and existential TyVarBinders.+See Note [TyVarBinders in DataCons] in DataCon.++During construction of a DataCon, we often start from the TyBinders of+the parent TyCon.  For example+   data Maybe a = Nothing | Just a+The DataCons start from the TyBinders of the parent TyCon.++But the ultimate TyBinders for the DataCon are *different* than those+of the DataCon. Here is an example:++  data App a b = MkApp (a b) -- App :: forall {k}. (k->*) -> k -> *++The TyCon has++  tyConTyVars    = [ k:*,                              a:k->*,      b:k]+  tyConTyBinders = [ Named (TvBndr (k :: *) Inferred), Anon (k->*), Anon k ]++The TyBinders for App line up with App's kind, given above.++But the DataCon MkApp has the type+  MkApp :: forall {k} (a:k->*) (b:k). a b -> App k a b++That is, its TyBinders should be++  dataConUnivTyVarBinders = [ TvBndr (k:*)    Inferred+                            , TvBndr (a:k->*) Specified+                            , TvBndr (b:k)    Specified ]++So we want to take the TyCon's TyBinders and the TyCon's TyVars and+merge them, pulling+  - variable names from the TyVars+  - visibilities from the TyBinders+  - but changing Anon/Required to Specified++The last part about Required->Specified comes from this:+  data T k (a:k) b = MkT (a b)+Here k is Required in T's kind, but we don't have Required binders in+the TyBinders for a term (see Note [No Required TyBinder in terms]+in TyCoRep), so we change it to Specified when making MkT's TyBinders++This merging operation is done by mkDataConUnivTyBinders. In contrast,+the TyBinders passed to mkDataCon are the final TyBinders stored in the+DataCon (mkDataCon does no further work).+-}++------------------------------------------------------+buildPatSyn :: Name -> Bool+            -> (Id,Bool) -> Maybe (Id, Bool)+            -> ([TyVarBinder], ThetaType) -- ^ Univ and req+            -> ([TyVarBinder], ThetaType) -- ^ Ex and prov+            -> [Type]               -- ^ Argument types+            -> Type                 -- ^ Result type+            -> [FieldLabel]         -- ^ Field labels for+                                    --   a record pattern synonym+            -> PatSyn+buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder+            (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys+            pat_ty field_labels+  = -- The assertion checks that the matcher is+    -- compatible with the pattern synonym+    ASSERT2((and [ univ_tvs `equalLength` univ_tvs1+                 , ex_tvs `equalLength` ex_tvs1+                 , pat_ty `eqType` substTy subst pat_ty1+                 , prov_theta `eqTypes` substTys subst prov_theta1+                 , req_theta `eqTypes` substTys subst req_theta1+                 , compareArgTys arg_tys (substTys subst arg_tys1)+                 ])+            , (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1+                    , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1+                    , ppr pat_ty <+> twiddle <+> ppr pat_ty1+                    , ppr prov_theta <+> twiddle <+> ppr prov_theta1+                    , ppr req_theta <+> twiddle <+> ppr req_theta1+                    , ppr arg_tys <+> twiddle <+> ppr arg_tys1]))+    mkPatSyn src_name declared_infix+             (univ_tvs, req_theta) (ex_tvs, prov_theta)+             arg_tys pat_ty+             matcher builder field_labels+  where+    ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id+    ([pat_ty1, cont_sigma, _], _)      = tcSplitFunTys tau+    (ex_tvs1, prov_theta1, cont_tau)   = tcSplitSigmaTy cont_sigma+    (arg_tys1, _) = (tcSplitFunTys cont_tau)+    twiddle = char '~'+    subst = zipTvSubst (univ_tvs1 ++ ex_tvs1)+                       (mkTyVarTys (binderVars (univ_tvs ++ ex_tvs)))++    -- For a nullary pattern synonym we add a single void argument to the+    -- matcher to preserve laziness in the case of unlifted types.+    -- See #12746+    compareArgTys :: [Type] -> [Type] -> Bool+    compareArgTys [] [x] = x `eqType` voidPrimTy+    compareArgTys arg_tys matcher_arg_tys = arg_tys `eqTypes` matcher_arg_tys+++------------------------------------------------------+type TcMethInfo     -- A temporary intermediate, to communicate+                    -- between tcClassSigs and buildClass.+  = ( Name   -- Name of the class op+    , Type   -- Type of the class op+    , Maybe (DefMethSpec (SrcSpan, Type)))+         -- Nothing                    => no default method+         --+         -- Just VanillaDM             => There is an ordinary+         --                               polymorphic default method+         --+         -- Just (GenericDM (loc, ty)) => There is a generic default metho+         --                               Here is its type, and the location+         --                               of the type signature+         --    We need that location /only/ to attach it to the+         --    generic default method's Name; and we need /that/+         --    only to give the right location of an ambiguity error+         --    for the generic default method, spat out by checkValidClass++buildClass :: Name  -- Name of the class/tycon (they have the same Name)+           -> [TyConBinder]                -- Of the tycon+           -> [Role]+           -> [FunDep TyVar]               -- Functional dependencies+           -- Super classes, associated types, method info, minimal complete def.+           -- This is Nothing if the class is abstract.+           -> Maybe (ThetaType, [ClassATItem], [TcMethInfo], ClassMinimalDef)+           -> TcRnIf m n Class++buildClass tycon_name binders roles fds Nothing+  = fixM  $ \ rec_clas ->       -- Only name generation inside loop+    do  { traceIf (text "buildClass")++        ; tc_rep_name  <- newTyConRepName tycon_name+        ; let univ_bndrs = mkDataConUnivTyVarBinders binders+              univ_tvs   = binderVars univ_bndrs+              tycon = mkClassTyCon tycon_name binders roles+                                   AbstractTyCon rec_clas tc_rep_name+              result = mkAbstractClass tycon_name univ_tvs fds tycon+        ; traceIf (text "buildClass" <+> ppr tycon)+        ; return result }++buildClass tycon_name binders roles fds+           (Just (sc_theta, at_items, sig_stuff, mindef))+  = fixM  $ \ rec_clas ->       -- Only name generation inside loop+    do  { traceIf (text "buildClass")++        ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc+        ; tc_rep_name  <- newTyConRepName tycon_name++        ; op_items <- mapM (mk_op_item rec_clas) sig_stuff+                        -- Build the selector id and default method id++              -- Make selectors for the superclasses+        ; sc_sel_names <- mapM  (newImplicitBinder tycon_name . mkSuperDictSelOcc)+                                (takeList sc_theta [fIRST_TAG..])+        ; let sc_sel_ids = [ mkDictSelId sc_name rec_clas+                           | sc_name <- sc_sel_names]+              -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we+              -- can construct names for the selectors. Thus+              --      class (C a, C b) => D a b where ...+              -- gives superclass selectors+              --      D_sc1, D_sc2+              -- (We used to call them D_C, but now we can have two different+              --  superclasses both called C!)++        ; let use_newtype = isSingleton arg_tys+                -- Use a newtype if the data constructor+                --   (a) has exactly one value field+                --       i.e. exactly one operation or superclass taken together+                --   (b) that value is of lifted type (which they always are, because+                --       we box equality superclasses)+                -- See note [Class newtypes and equality predicates]++                -- We treat the dictionary superclasses as ordinary arguments.+                -- That means that in the case of+                --     class C a => D a+                -- we don't get a newtype with no arguments!+              args       = sc_sel_names ++ op_names+              op_tys     = [ty | (_,ty,_) <- sig_stuff]+              op_names   = [op | (op,_,_) <- sig_stuff]+              arg_tys    = sc_theta ++ op_tys+              rec_tycon  = classTyCon rec_clas+              univ_bndrs = mkDataConUnivTyVarBinders binders+              univ_tvs   = binderVars univ_bndrs++        ; rep_nm   <- newTyConRepName datacon_name+        ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")+                                   datacon_name+                                   False        -- Not declared infix+                                   rep_nm+                                   (map (const no_bang) args)+                                   (Just (map (const HsLazy) args))+                                   [{- No fields -}]+                                   univ_bndrs+                                   [{- no existentials -}]+                                   [{- No GADT equalities -}]+                                   [{- No theta -}]+                                   arg_tys+                                   (mkTyConApp rec_tycon (mkTyVarTys univ_tvs))+                                   rec_tycon++        ; rhs <- case () of+                  _ | use_newtype+                    -> mkNewTyConRhs tycon_name rec_tycon dict_con+                    | isCTupleTyConName tycon_name+                    -> return (TupleTyCon { data_con = dict_con+                                          , tup_sort = ConstraintTuple })+                    | otherwise+                    -> return (mkDataTyConRhs [dict_con])++        ; let { tycon = mkClassTyCon tycon_name binders roles+                                     rhs rec_clas tc_rep_name+                -- A class can be recursive, and in the case of newtypes+                -- this matters.  For example+                --      class C a where { op :: C b => a -> b -> Int }+                -- Because C has only one operation, it is represented by+                -- a newtype, and it should be a *recursive* newtype.+                -- [If we don't make it a recursive newtype, we'll expand the+                -- newtype like a synonym, but that will lead to an infinite+                -- type]++              ; result = mkClass tycon_name univ_tvs fds+                                 sc_theta sc_sel_ids at_items+                                 op_items mindef tycon+              }+        ; traceIf (text "buildClass" <+> ppr tycon)+        ; return result }+  where+    no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict++    mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem+    mk_op_item rec_clas (op_name, _, dm_spec)+      = do { dm_info <- mk_dm_info op_name dm_spec+           ; return (mkDictSelId op_name rec_clas, dm_info) }++    mk_dm_info :: Name -> Maybe (DefMethSpec (SrcSpan, Type))+               -> TcRnIf n m (Maybe (Name, DefMethSpec Type))+    mk_dm_info _ Nothing+      = return Nothing+    mk_dm_info op_name (Just VanillaDM)+      = do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc+           ; return (Just (dm_name, VanillaDM)) }+    mk_dm_info op_name (Just (GenericDM (loc, dm_ty)))+      = do { dm_name <- newImplicitBinderLoc op_name mkDefaultMethodOcc loc+           ; return (Just (dm_name, GenericDM dm_ty)) }++{-+Note [Class newtypes and equality predicates]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+        class (a ~ F b) => C a b where+          op :: a -> b++We cannot represent this by a newtype, even though it's not+existential, because there are two value fields (the equality+predicate and op. See Trac #2238++Moreover,+          class (a ~ F b) => C a b where {}+Here we can't use a newtype either, even though there is only+one field, because equality predicates are unboxed, and classes+are boxed.+-}++newImplicitBinder :: Name                       -- Base name+                  -> (OccName -> OccName)       -- Occurrence name modifier+                  -> TcRnIf m n Name            -- Implicit name+-- Called in BuildTyCl to allocate the implicit binders of type/class decls+-- For source type/class decls, this is the first occurrence+-- For iface ones, the LoadIface has already allocated a suitable name in the cache+newImplicitBinder base_name mk_sys_occ+  = newImplicitBinderLoc base_name mk_sys_occ (nameSrcSpan base_name)++newImplicitBinderLoc :: Name                       -- Base name+                     -> (OccName -> OccName)       -- Occurrence name modifier+                     -> SrcSpan+                     -> TcRnIf m n Name            -- Implicit name+-- Just the same, but lets you specify the SrcSpan+newImplicitBinderLoc base_name mk_sys_occ loc+  | Just mod <- nameModule_maybe base_name+  = newGlobalBinder mod occ loc+  | otherwise           -- When typechecking a [d| decl bracket |],+                        -- TH generates types, classes etc with Internal names,+                        -- so we follow suit for the implicit binders+  = do  { uniq <- newUnique+        ; return (mkInternalName uniq occ loc) }+  where+    occ = mk_sys_occ (nameOccName base_name)++-- | Make the 'TyConRepName' for this 'TyCon'+newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName+newTyConRepName tc_name+  | Just mod <- nameModule_maybe tc_name+  , (mod, occ) <- tyConRepModOcc mod (nameOccName tc_name)+  = newGlobalBinder mod occ noSrcSpan+  | otherwise+  = newImplicitBinder tc_name mkTyConRepOcc
+ iface/FlagChecker.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE RecordWildCards #-}++-- | This module manages storing the various GHC option flags in a modules+-- interface file as part of the recompilation checking infrastructure.+module FlagChecker (+        fingerprintDynFlags+    ) where++import Binary+import BinIface ()+import DynFlags+import HscTypes+import Module+import Name+import Fingerprint+import BinFingerprint+-- import Outputable++import qualified Data.IntSet as IntSet+import System.FilePath (normalise)++-- | Produce a fingerprint of a @DynFlags@ value. We only base+-- the finger print on important fields in @DynFlags@ so that+-- the recompilation checker can use this fingerprint.+--+-- NB: The 'Module' parameter is the 'Module' recorded by the+-- *interface* file, not the actual 'Module' according to our+-- 'DynFlags'.+fingerprintDynFlags :: DynFlags -> Module+                    -> (BinHandle -> Name -> IO ())+                    -> IO Fingerprint++fingerprintDynFlags dflags@DynFlags{..} this_mod nameio =+    let mainis   = if mainModIs == this_mod then Just mainFunIs else Nothing+                      -- see #5878+        -- pkgopts  = (thisPackage dflags, sort $ packageFlags dflags)+        safeHs   = setSafeMode safeHaskell+        -- oflags   = sort $ filter filterOFlags $ flags dflags++        -- *all* the extension flags and the language+        lang = (fmap fromEnum language,+                IntSet.toList $ extensionFlags)++        -- -I, -D and -U flags affect CPP+        cpp = (map normalise includePaths, opt_P dflags ++ picPOpts dflags)+            -- normalise: eliminate spurious differences due to "./foo" vs "foo"++        -- Note [path flags and recompilation]+        paths = [ hcSuf ]++        -- -fprof-auto etc.+        prof = if gopt Opt_SccProfilingOn dflags then fromEnum profAuto else 0++        -- -O, see https://ghc.haskell.org/trac/ghc/ticket/10923+        opt = if hscTarget == HscInterpreted ||+                 hscTarget == HscNothing+                 then 0+                 else optLevel++        -- -fhpc, see https://ghc.haskell.org/trac/ghc/ticket/11798+        -- hpcDir is output-only, so we should recompile if it changes+        hpc = if gopt Opt_Hpc dflags then Just hpcDir else Nothing++        -- Nesting just to avoid ever more Binary tuple instances+        flags = (mainis, safeHs, lang, cpp, paths, (prof, opt, hpc))++    in -- pprTrace "flags" (ppr flags) $+       computeFingerprint nameio flags++{- Note [path flags and recompilation]++There are several flags that we deliberately omit from the+recompilation check; here we explain why.++-osuf, -odir, -hisuf, -hidir+  If GHC decides that it does not need to recompile, then+  it must have found an up-to-date .hi file and .o file.+  There is no point recording these flags - the user must+  have passed the correct ones.  Indeed, the user may+  have compiled the source file in one-shot mode using+  -o to specify the .o file, and then loaded it in GHCi+  using -odir.++-stubdir+  We omit this one because it is automatically set by -outputdir, and+  we don't want changes in -outputdir to automatically trigger+  recompilation.  This could be wrong, but only in very rare cases.++-i (importPaths)+  For the same reason as -osuf etc. above: if GHC decides not to+  recompile, then it must have already checked all the .hi files on+  which the current module depends, so it must have found them+  successfully.  It is occasionally useful to be able to cd to a+  different directory and use -i flags to enable GHC to find the .hi+  files; we don't want this to force recompilation.++The only path-related flag left is -hcsuf.+-}
+ iface/IfaceEnv.hs view
@@ -0,0 +1,272 @@+-- (c) The University of Glasgow 2002-2006++{-# LANGUAGE CPP, RankNTypes #-}++module IfaceEnv (+        newGlobalBinder, newInteractiveBinder,+        externaliseName,+        lookupIfaceTop,+        lookupOrig, lookupOrigNameCache, extendNameCache,+        newIfaceName, newIfaceNames,+        extendIfaceIdEnv, extendIfaceTyVarEnv,+        tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar,+        lookupIfaceTyVar, extendIfaceEnvs,+        setNameModule,++        ifaceExportNames,++        -- Name-cache stuff+        allocateGlobalBinder, updNameCache,+        mkNameCacheUpdater, NameCacheUpdater(..),+   ) where++#include "HsVersions.h"++import TcRnMonad+import HscTypes+import Type+import Var+import Name+import Avail+import Module+import FastString+import FastStringEnv+import IfaceType+import NameCache+import UniqSupply+import SrcLoc++import Outputable+import Data.List     ( partition )++{-+*********************************************************+*                                                      *+        Allocating new Names in the Name Cache+*                                                      *+*********************************************************++See Also: Note [The Name Cache] in NameCache+-}++newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name+-- Used for source code and interface files, to make the+-- Name for a thing, given its Module and OccName+-- See Note [The Name Cache]+--+-- The cache may already already have a binding for this thing,+-- because we may have seen an occurrence before, but now is the+-- moment when we know its Module and SrcLoc in their full glory++newGlobalBinder mod occ loc+  = do { mod `seq` occ `seq` return ()    -- See notes with lookupOrig+       ; name <- updNameCache $ \name_cache ->+                 allocateGlobalBinder name_cache mod occ loc+       ; traceIf (text "newGlobalBinder" <+>+                  (vcat [ ppr mod <+> ppr occ <+> ppr loc, ppr name]))+       ; return name }++newInteractiveBinder :: HscEnv -> OccName -> SrcSpan -> IO Name+-- Works in the IO monad, and gets the Module+-- from the interactive context+newInteractiveBinder hsc_env occ loc+ = do { let mod = icInteractiveModule (hsc_IC hsc_env)+       ; updNameCacheIO hsc_env $ \name_cache ->+         allocateGlobalBinder name_cache mod occ loc }++allocateGlobalBinder+  :: NameCache+  -> Module -> OccName -> SrcSpan+  -> (NameCache, Name)+-- See Note [The Name Cache]+allocateGlobalBinder name_supply mod occ loc+  = case lookupOrigNameCache (nsNames name_supply) mod occ of+        -- A hit in the cache!  We are at the binding site of the name.+        -- This is the moment when we know the SrcLoc+        -- of the Name, so we set this field in the Name we return.+        --+        -- Then (bogus) multiple bindings of the same Name+        -- get different SrcLocs can can be reported as such.+        --+        -- Possible other reason: it might be in the cache because we+        --      encountered an occurrence before the binding site for an+        --      implicitly-imported Name.  Perhaps the current SrcLoc is+        --      better... but not really: it'll still just say 'imported'+        --+        -- IMPORTANT: Don't mess with wired-in names.+        --            Their wired-in-ness is in their NameSort+        --            and their Module is correct.++        Just name | isWiredInName name+                  -> (name_supply, name)+                  | otherwise+                  -> (new_name_supply, name')+                  where+                    uniq            = nameUnique name+                    name'           = mkExternalName uniq mod occ loc+                                      -- name' is like name, but with the right SrcSpan+                    new_cache       = extendNameCache (nsNames name_supply) mod occ name'+                    new_name_supply = name_supply {nsNames = new_cache}++        -- Miss in the cache!+        -- Build a completely new Name, and put it in the cache+        _ -> (new_name_supply, name)+                  where+                    (uniq, us')     = takeUniqFromSupply (nsUniqs name_supply)+                    name            = mkExternalName uniq mod occ loc+                    new_cache       = extendNameCache (nsNames name_supply) mod occ name+                    new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}++ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]+ifaceExportNames exports = return exports++-- | A function that atomically updates the name cache given a modifier+-- function.  The second result of the modifier function will be the result+-- of the IO action.+newtype NameCacheUpdater+      = NCU { updateNameCache :: forall c. (NameCache -> (NameCache, c)) -> IO c }++mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater+mkNameCacheUpdater = do { hsc_env <- getTopEnv+                        ; return (NCU (updNameCacheIO hsc_env)) }++updNameCache :: (NameCache -> (NameCache, c)) -> TcRnIf a b c+updNameCache upd_fn = do { hsc_env <- getTopEnv+                         ; liftIO $ updNameCacheIO hsc_env upd_fn }++{-+************************************************************************+*                                                                      *+                Name cache access+*                                                                      *+************************************************************************+-}++-- | Look up the 'Name' for a given 'Module' and 'OccName'.+-- Consider alternately using 'lookupIfaceTop' if you're in the 'IfL' monad+-- and 'Module' is simply that of the 'ModIface' you are typechecking.+lookupOrig :: Module -> OccName -> TcRnIf a b Name+lookupOrig mod occ+  = do  {       -- First ensure that mod and occ are evaluated+                -- If not, chaos can ensue:+                --      we read the name-cache+                --      then pull on mod (say)+                --      which does some stuff that modifies the name cache+                -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)+          mod `seq` occ `seq` return ()+        ; traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)++        ; updNameCache $ \name_cache ->+          case lookupOrigNameCache (nsNames name_cache) mod occ of {+              Just name -> (name_cache, name);+              Nothing   ->+              case takeUniqFromSupply (nsUniqs name_cache) of {+              (uniq, us) ->+                  let+                    name      = mkExternalName uniq mod occ noSrcSpan+                    new_cache = extendNameCache (nsNames name_cache) mod occ name+                  in (name_cache{ nsUniqs = us, nsNames = new_cache }, name)+    }}}++externaliseName :: Module -> Name -> TcRnIf m n Name+-- Take an Internal Name and make it an External one,+-- with the same unique+externaliseName mod name+  = do { let occ = nameOccName name+             loc = nameSrcSpan name+             uniq = nameUnique name+       ; occ `seq` return ()  -- c.f. seq in newGlobalBinder+       ; updNameCache $ \ ns ->+         let name' = mkExternalName uniq mod occ loc+             ns'   = ns { nsNames = extendNameCache (nsNames ns) mod occ name' }+         in (ns', name') }++-- | Set the 'Module' of a 'Name'.+setNameModule :: Maybe Module -> Name -> TcRnIf m n Name+setNameModule Nothing n = return n+setNameModule (Just m) n =+    newGlobalBinder m (nameOccName n) (nameSrcSpan n)++{-+************************************************************************+*                                                                      *+                Type variables and local Ids+*                                                                      *+************************************************************************+-}++tcIfaceLclId :: FastString -> IfL Id+tcIfaceLclId occ+  = do  { lcl <- getLclEnv+        ; case (lookupFsEnv (if_id_env lcl) occ) of+            Just ty_var -> return ty_var+            Nothing     -> failIfM (text "Iface id out of scope: " <+> ppr occ)+        }++extendIfaceIdEnv :: [Id] -> IfL a -> IfL a+extendIfaceIdEnv ids thing_inside+  = do  { env <- getLclEnv+        ; let { id_env' = extendFsEnvList (if_id_env env) pairs+              ; pairs   = [(occNameFS (getOccName id), id) | id <- ids] }+        ; setLclEnv (env { if_id_env = id_env' }) thing_inside }+++tcIfaceTyVar :: FastString -> IfL TyVar+tcIfaceTyVar occ+  = do  { lcl <- getLclEnv+        ; case (lookupFsEnv (if_tv_env lcl) occ) of+            Just ty_var -> return ty_var+            Nothing     -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)+        }++lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe TyVar)+lookupIfaceTyVar (occ, _)+  = do  { lcl <- getLclEnv+        ; return (lookupFsEnv (if_tv_env lcl) occ) }++lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar)+lookupIfaceVar (IfaceIdBndr (occ, _))+  = do  { lcl <- getLclEnv+        ; return (lookupFsEnv (if_id_env lcl) occ) }+lookupIfaceVar (IfaceTvBndr (occ, _))+  = do  { lcl <- getLclEnv+        ; return (lookupFsEnv (if_tv_env lcl) occ) }++extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a+extendIfaceTyVarEnv tyvars thing_inside+  = do  { env <- getLclEnv+        ; let { tv_env' = extendFsEnvList (if_tv_env env) pairs+              ; pairs   = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }+        ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }++extendIfaceEnvs :: [TyCoVar] -> IfL a -> IfL a+extendIfaceEnvs tcvs thing_inside+  = extendIfaceTyVarEnv tvs $+    extendIfaceIdEnv    cvs $+    thing_inside+  where+    (tvs, cvs) = partition isTyVar tcvs++{-+************************************************************************+*                                                                      *+                Getting from RdrNames to Names+*                                                                      *+************************************************************************+-}++-- | Look up a top-level name from the current Iface module+lookupIfaceTop :: OccName -> IfL Name+lookupIfaceTop occ+  = do  { env <- getLclEnv; lookupOrig (if_mod env) occ }++newIfaceName :: OccName -> IfL Name+newIfaceName occ+  = do  { uniq <- newUnique+        ; return $! mkInternalName uniq occ noSrcSpan }++newIfaceNames :: [OccName] -> IfL [Name]+newIfaceNames occs+  = do  { uniqs <- newUniqueSupply+        ; return [ mkInternalName uniq occ noSrcSpan+                 | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
+ iface/IfaceEnv.hs-boot view
@@ -0,0 +1,9 @@+module IfaceEnv where++import Module+import OccName+import TcRnMonad+import Name+import SrcLoc++newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
+ iface/IfaceSyn.hs view
@@ -0,0 +1,2220 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998+-}++{-# LANGUAGE CPP #-}++module IfaceSyn (+        module IfaceType,++        IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..),+        IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec,+        IfaceExpr(..), IfaceAlt, IfaceLetBndr(..), IfaceJoinInfo(..),+        IfaceBinding(..), IfaceConAlt(..),+        IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..),+        IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,+        IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..),+        IfaceClassBody(..),+        IfaceBang(..),+        IfaceSrcBang(..), SrcUnpackedness(..), SrcStrictness(..),+        IfaceAxBranch(..),+        IfaceTyConParent(..),+        IfaceCompleteMatch(..),++        -- * Binding names+        IfaceTopBndr,+        putIfaceTopBndr, getIfaceTopBndr,++        -- Misc+        ifaceDeclImplicitBndrs, visibleIfConDecls,+        ifaceDeclFingerprints,++        -- Free Names+        freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst,++        -- Pretty printing+        pprIfaceExpr,+        pprIfaceDecl,+        AltPpr(..), ShowSub(..), ShowHowMuch(..), showToIface, showToHeader+    ) where++#include "HsVersions.h"++import IfaceType+import BinFingerprint+import CoreSyn( IsOrphan, isOrphan )+import PprCore()            -- Printing DFunArgs+import Demand+import Class+import FieldLabel+import NameSet+import CoAxiom ( BranchIndex )+import Name+import CostCentre+import Literal+import ForeignCall+import Annotations( AnnPayload, AnnTarget )+import BasicTypes+import Outputable+import Module+import SrcLoc+import Fingerprint+import Binary+import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue )+import Var( TyVarBndr(..) )+import TyCon ( Role (..), Injectivity(..) )+import Util( filterOut, filterByList )+import DataCon (SrcStrictness(..), SrcUnpackedness(..))+import Lexeme (isLexSym)++import Control.Monad+import System.IO.Unsafe+import Data.Maybe (isJust)++infixl 3 &&&++{-+************************************************************************+*                                                                      *+                    Declarations+*                                                                      *+************************************************************************+-}++-- | A binding top-level 'Name' in an interface file (e.g. the name of an+-- 'IfaceDecl').+type IfaceTopBndr = Name+  -- It's convenient to have an Name in the IfaceSyn, although in each+  -- case the namespace is implied by the context. However, having an+  -- Name makes things like ifaceDeclImplicitBndrs and ifaceDeclFingerprints+  -- very convenient. Moreover, having the key of the binder means that+  -- we can encode known-key things cleverly in the symbol table. See Note+  -- [Symbol table representation of Names]+  --+  -- We don't serialise the namespace onto the disk though; rather we+  -- drop it when serialising and add it back in when deserialising.++getIfaceTopBndr :: BinHandle -> IO IfaceTopBndr+getIfaceTopBndr bh = get bh++putIfaceTopBndr :: BinHandle -> IfaceTopBndr -> IO ()+putIfaceTopBndr bh name =+    case getUserData bh of+      UserData{ ud_put_binding_name = put_binding_name } ->+          --pprTrace "putIfaceTopBndr" (ppr name) $+          put_binding_name bh name++data IfaceDecl+  = IfaceId { ifName      :: IfaceTopBndr,+              ifType      :: IfaceType,+              ifIdDetails :: IfaceIdDetails,+              ifIdInfo    :: IfaceIdInfo }++  | IfaceData { ifName       :: IfaceTopBndr,   -- Type constructor+                ifBinders    :: [IfaceTyConBinder],+                ifResKind    :: IfaceType,      -- Result kind of type constructor+                ifCType      :: Maybe CType,    -- C type for CAPI FFI+                ifRoles      :: [Role],         -- Roles+                ifCtxt       :: IfaceContext,   -- The "stupid theta"+                ifCons       :: IfaceConDecls,  -- Includes new/data/data family info+                ifGadtSyntax :: Bool,           -- True <=> declared using+                                                -- GADT syntax+                ifParent     :: IfaceTyConParent -- The axiom, for a newtype,+                                                 -- or data/newtype family instance+    }++  | IfaceSynonym { ifName    :: IfaceTopBndr,      -- Type constructor+                   ifRoles   :: [Role],            -- Roles+                   ifBinders :: [IfaceTyConBinder],+                   ifResKind :: IfaceKind,         -- Kind of the *result*+                   ifSynRhs  :: IfaceType }++  | IfaceFamily  { ifName    :: IfaceTopBndr,      -- Type constructor+                   ifResVar  :: Maybe IfLclName,   -- Result variable name, used+                                                   -- only for pretty-printing+                                                   -- with --show-iface+                   ifBinders :: [IfaceTyConBinder],+                   ifResKind :: IfaceKind,         -- Kind of the *tycon*+                   ifFamFlav :: IfaceFamTyConFlav,+                   ifFamInj  :: Injectivity }      -- injectivity information++  | IfaceClass { ifName    :: IfaceTopBndr,             -- Name of the class TyCon+                 ifRoles   :: [Role],                   -- Roles+                 ifBinders :: [IfaceTyConBinder],+                 ifFDs     :: [FunDep IfLclName],       -- Functional dependencies+                 ifBody    :: IfaceClassBody            -- Methods, superclasses, ATs+    }++  | IfaceAxiom { ifName       :: IfaceTopBndr,        -- Axiom name+                 ifTyCon      :: IfaceTyCon,     -- LHS TyCon+                 ifRole       :: Role,           -- Role of axiom+                 ifAxBranches :: [IfaceAxBranch] -- Branches+    }++  | IfacePatSyn { ifName          :: IfaceTopBndr,           -- Name of the pattern synonym+                  ifPatIsInfix    :: Bool,+                  ifPatMatcher    :: (IfExtName, Bool),+                  ifPatBuilder    :: Maybe (IfExtName, Bool),+                  -- Everything below is redundant,+                  -- but needed to implement pprIfaceDecl+                  ifPatUnivBndrs  :: [IfaceForAllBndr],+                  ifPatExBndrs    :: [IfaceForAllBndr],+                  ifPatProvCtxt   :: IfaceContext,+                  ifPatReqCtxt    :: IfaceContext,+                  ifPatArgs       :: [IfaceType],+                  ifPatTy         :: IfaceType,+                  ifFieldLabels   :: [FieldLabel] }++-- See also 'ClassBody'+data IfaceClassBody+  -- Abstract classes don't specify their body; they only occur in @hs-boot@ and+  -- @hsig@ files.+  = IfAbstractClass+  | IfConcreteClass {+     ifClassCtxt :: IfaceContext,             -- Super classes+     ifATs       :: [IfaceAT],                -- Associated type families+     ifSigs      :: [IfaceClassOp],           -- Method signatures+     ifMinDef    :: BooleanFormula IfLclName  -- Minimal complete definition+    }++data IfaceTyConParent+  = IfNoParent+  | IfDataInstance IfExtName+                   IfaceTyCon+                   IfaceTcArgs++data IfaceFamTyConFlav+  = IfaceDataFamilyTyCon                      -- Data family+  | IfaceOpenSynFamilyTyCon+  | IfaceClosedSynFamilyTyCon (Maybe (IfExtName, [IfaceAxBranch]))+    -- ^ Name of associated axiom and branches for pretty printing purposes,+    -- or 'Nothing' for an empty closed family without an axiom+  | IfaceAbstractClosedSynFamilyTyCon+  | IfaceBuiltInSynFamTyCon -- for pretty printing purposes only++data IfaceClassOp+  = IfaceClassOp IfaceTopBndr+                 IfaceType                         -- Class op type+                 (Maybe (DefMethSpec IfaceType))   -- Default method+                 -- The types of both the class op itself,+                 -- and the default method, are *not* quantified+                 -- over the class variables++data IfaceAT = IfaceAT  -- See Class.ClassATItem+                  IfaceDecl          -- The associated type declaration+                  (Maybe IfaceType)  -- Default associated type instance, if any+++-- This is just like CoAxBranch+data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars   :: [IfaceTvBndr]+                                   , ifaxbCoVars   :: [IfaceIdBndr]+                                   , ifaxbLHS      :: IfaceTcArgs+                                   , ifaxbRoles    :: [Role]+                                   , ifaxbRHS      :: IfaceType+                                   , ifaxbIncomps  :: [BranchIndex] }+                                     -- See Note [Storing compatibility] in CoAxiom++data IfaceConDecls+  = IfAbstractTyCon     -- c.f TyCon.AbstractTyCon+  | IfDataTyCon [IfaceConDecl] -- Data type decls+  | IfNewTyCon  IfaceConDecl   -- Newtype decls++-- For IfDataTyCon and IfNewTyCon we store:+--  * the data constructor(s);+-- The field labels are stored individually in the IfaceConDecl+-- (there is some redundancy here, because a field label may occur+-- in multiple IfaceConDecls and represent the same field label)++data IfaceConDecl+  = IfCon {+        ifConName    :: IfaceTopBndr,                -- Constructor name+        ifConWrapper :: Bool,                   -- True <=> has a wrapper+        ifConInfix   :: Bool,                   -- True <=> declared infix++        -- The universal type variables are precisely those+        -- of the type constructor of this data constructor+        -- This is *easy* to guarantee when creating the IfCon+        -- but it's not so easy for the original TyCon/DataCon+        -- So this guarantee holds for IfaceConDecl, but *not* for DataCon++        ifConExTvs   :: [IfaceForAllBndr],  -- Existential tyvars (w/ visibility)+        ifConEqSpec  :: IfaceEqSpec,        -- Equality constraints+        ifConCtxt    :: IfaceContext,       -- Non-stupid context+        ifConArgTys  :: [IfaceType],        -- Arg types+        ifConFields  :: [FieldLabel],  -- ...ditto... (field labels)+        ifConStricts :: [IfaceBang],+          -- Empty (meaning all lazy),+          -- or 1-1 corresp with arg tys+          -- See Note [Bangs on imported data constructors] in MkId+        ifConSrcStricts :: [IfaceSrcBang] } -- empty meaning no src stricts++type IfaceEqSpec = [(IfLclName,IfaceType)]++-- | This corresponds to an HsImplBang; that is, the final+-- implementation decision about the data constructor arg+data IfaceBang+  = IfNoBang | IfStrict | IfUnpack | IfUnpackCo IfaceCoercion++-- | This corresponds to HsSrcBang+data IfaceSrcBang+  = IfSrcBang SrcUnpackedness SrcStrictness++data IfaceClsInst+  = IfaceClsInst { ifInstCls  :: IfExtName,                -- See comments with+                   ifInstTys  :: [Maybe IfaceTyCon],       -- the defn of ClsInst+                   ifDFun     :: IfExtName,                -- The dfun+                   ifOFlag    :: OverlapFlag,              -- Overlap flag+                   ifInstOrph :: IsOrphan }                -- See Note [Orphans] in InstEnv+        -- There's always a separate IfaceDecl for the DFun, which gives+        -- its IdInfo with its full type and version number.+        -- The instance declarations taken together have a version number,+        -- and we don't want that to wobble gratuitously+        -- If this instance decl is *used*, we'll record a usage on the dfun;+        -- and if the head does not change it won't be used if it wasn't before++-- The ifFamInstTys field of IfaceFamInst contains a list of the rough+-- match types+data IfaceFamInst+  = IfaceFamInst { ifFamInstFam      :: IfExtName            -- Family name+                 , ifFamInstTys      :: [Maybe IfaceTyCon]   -- See above+                 , ifFamInstAxiom    :: IfExtName            -- The axiom+                 , ifFamInstOrph     :: IsOrphan             -- Just like IfaceClsInst+                 }++data IfaceRule+  = IfaceRule {+        ifRuleName   :: RuleName,+        ifActivation :: Activation,+        ifRuleBndrs  :: [IfaceBndr],    -- Tyvars and term vars+        ifRuleHead   :: IfExtName,      -- Head of lhs+        ifRuleArgs   :: [IfaceExpr],    -- Args of LHS+        ifRuleRhs    :: IfaceExpr,+        ifRuleAuto   :: Bool,+        ifRuleOrph   :: IsOrphan   -- Just like IfaceClsInst+    }++data IfaceAnnotation+  = IfaceAnnotation {+        ifAnnotatedTarget :: IfaceAnnTarget,+        ifAnnotatedValue  :: AnnPayload+  }++type IfaceAnnTarget = AnnTarget OccName++data IfaceCompleteMatch = IfaceCompleteMatch [IfExtName] IfExtName++instance Outputable IfaceCompleteMatch where+  ppr (IfaceCompleteMatch cls ty) = text "COMPLETE" <> colon <+> ppr cls+                                                    <+> dcolon <+> ppr ty+++++-- Here's a tricky case:+--   * Compile with -O module A, and B which imports A.f+--   * Change function f in A, and recompile without -O+--   * When we read in old A.hi we read in its IdInfo (as a thunk)+--      (In earlier GHCs we used to drop IdInfo immediately on reading,+--       but we do not do that now.  Instead it's discarded when the+--       ModIface is read into the various decl pools.)+--   * The version comparison sees that new (=NoInfo) differs from old (=HasInfo *)+--      and so gives a new version.++data IfaceIdInfo+  = NoInfo                      -- When writing interface file without -O+  | HasInfo [IfaceInfoItem]     -- Has info, and here it is++data IfaceInfoItem+  = HsArity         Arity+  | HsStrictness    StrictSig+  | HsInline        InlinePragma+  | HsUnfold        Bool             -- True <=> isStrongLoopBreaker is true+                    IfaceUnfolding   -- See Note [Expose recursive functions]+  | HsNoCafRefs+  | HsLevity                         -- Present <=> never levity polymorphic++-- NB: Specialisations and rules come in separately and are+-- only later attached to the Id.  Partial reason: some are orphans.++data IfaceUnfolding+  = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding+                                -- Possibly could eliminate the Bool here, the information+                                -- is also in the InlinePragma.++  | IfCompulsory IfaceExpr      -- Only used for default methods, in fact++  | IfInlineRule Arity          -- INLINE pragmas+                 Bool           -- OK to inline even if *un*-saturated+                 Bool           -- OK to inline even if context is boring+                 IfaceExpr++  | IfDFunUnfold [IfaceBndr] [IfaceExpr]+++-- We only serialise the IdDetails of top-level Ids, and even then+-- we only need a very limited selection.  Notably, none of the+-- implicit ones are needed here, because they are not put it+-- interface files++data IfaceIdDetails+  = IfVanillaId+  | IfRecSelId (Either IfaceTyCon IfaceDecl) Bool+  | IfDFunId++{-+Note [Versioning of instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See [http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance#Instances]+++************************************************************************+*                                                                      *+                Functions over declarations+*                                                                      *+************************************************************************+-}++visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]+visibleIfConDecls IfAbstractTyCon  = []+visibleIfConDecls (IfDataTyCon cs) = cs+visibleIfConDecls (IfNewTyCon c)   = [c]++ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName]+--  *Excludes* the 'main' name, but *includes* the implicitly-bound names+-- Deeply revolting, because it has to predict what gets bound,+-- especially the question of whether there's a wrapper for a datacon+-- See Note [Implicit TyThings] in HscTypes++-- N.B. the set of names returned here *must* match the set of+-- TyThings returned by HscTypes.implicitTyThings, in the sense that+-- TyThing.getOccName should define a bijection between the two lists.+-- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop])+-- The order of the list does not matter.++ifaceDeclImplicitBndrs (IfaceData {ifName = tc_name, ifCons = cons })+  = case cons of+      IfAbstractTyCon -> []+      IfNewTyCon  cd  -> mkNewTyCoOcc (occName tc_name) : ifaceConDeclImplicitBndrs cd+      IfDataTyCon cds -> concatMap ifaceConDeclImplicitBndrs cds++ifaceDeclImplicitBndrs (IfaceClass { ifBody = IfAbstractClass })+  = []++ifaceDeclImplicitBndrs (IfaceClass { ifName = cls_tc_name+                                   , ifBody = IfConcreteClass {+                                        ifClassCtxt = sc_ctxt,+                                        ifSigs      = sigs,+                                        ifATs       = ats+                                     }})+  = --   (possibly) newtype coercion+    co_occs +++    --    data constructor (DataCon namespace)+    --    data worker (Id namespace)+    --    no wrapper (class dictionaries never have a wrapper)+    [dc_occ, dcww_occ] +++    -- associated types+    [occName (ifName at) | IfaceAT at _ <- ats ] +++    -- superclass selectors+    [mkSuperDictSelOcc n cls_tc_occ | n <- [1..n_ctxt]] +++    -- operation selectors+    [occName op | IfaceClassOp op  _ _ <- sigs]+  where+    cls_tc_occ = occName cls_tc_name+    n_ctxt = length sc_ctxt+    n_sigs = length sigs+    co_occs | is_newtype = [mkNewTyCoOcc cls_tc_occ]+            | otherwise  = []+    dcww_occ = mkDataConWorkerOcc dc_occ+    dc_occ = mkClassDataConOcc cls_tc_occ+    is_newtype = n_sigs + n_ctxt == 1 -- Sigh (keep this synced with buildClass)++ifaceDeclImplicitBndrs _ = []++ifaceConDeclImplicitBndrs :: IfaceConDecl -> [OccName]+ifaceConDeclImplicitBndrs (IfCon {+        ifConWrapper = has_wrapper, ifConName = con_name })+  = [occName con_name, work_occ] ++ wrap_occs+  where+    con_occ = occName con_name+    work_occ  = mkDataConWorkerOcc con_occ                   -- Id namespace+    wrap_occs | has_wrapper = [mkDataConWrapperOcc con_occ]  -- Id namespace+              | otherwise   = []++-- -----------------------------------------------------------------------------+-- The fingerprints of an IfaceDecl++       -- We better give each name bound by the declaration a+       -- different fingerprint!  So we calculate the fingerprint of+       -- each binder by combining the fingerprint of the whole+       -- declaration with the name of the binder. (#5614, #7215)+ifaceDeclFingerprints :: Fingerprint -> IfaceDecl -> [(OccName,Fingerprint)]+ifaceDeclFingerprints hash decl+  = (getOccName decl, hash) :+    [ (occ, computeFingerprint' (hash,occ))+    | occ <- ifaceDeclImplicitBndrs decl ]+  where+     computeFingerprint' =+       unsafeDupablePerformIO+        . computeFingerprint (panic "ifaceDeclFingerprints")++{-+************************************************************************+*                                                                      *+                Expressions+*                                                                      *+************************************************************************+-}++data IfaceExpr+  = IfaceLcl    IfLclName+  | IfaceExt    IfExtName+  | IfaceType   IfaceType+  | IfaceCo     IfaceCoercion+  | IfaceTuple  TupleSort [IfaceExpr]   -- Saturated; type arguments omitted+  | IfaceLam    IfaceLamBndr IfaceExpr+  | IfaceApp    IfaceExpr IfaceExpr+  | IfaceCase   IfaceExpr IfLclName [IfaceAlt]+  | IfaceECase  IfaceExpr IfaceType     -- See Note [Empty case alternatives]+  | IfaceLet    IfaceBinding  IfaceExpr+  | IfaceCast   IfaceExpr IfaceCoercion+  | IfaceLit    Literal+  | IfaceFCall  ForeignCall IfaceType+  | IfaceTick   IfaceTickish IfaceExpr    -- from Tick tickish E++data IfaceTickish+  = IfaceHpcTick Module Int                -- from HpcTick x+  | IfaceSCC     CostCentre Bool Bool      -- from ProfNote+  | IfaceSource  RealSrcSpan String        -- from SourceNote+  -- no breakpoints: we never export these into interface files++type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr)+        -- Note: IfLclName, not IfaceBndr (and same with the case binder)+        -- We reconstruct the kind/type of the thing from the context+        -- thus saving bulk in interface files++data IfaceConAlt = IfaceDefault+                 | IfaceDataAlt IfExtName+                 | IfaceLitAlt Literal++data IfaceBinding+  = IfaceNonRec IfaceLetBndr IfaceExpr+  | IfaceRec    [(IfaceLetBndr, IfaceExpr)]++-- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too+-- It's used for *non-top-level* let/rec binders+-- See Note [IdInfo on nested let-bindings]+data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo IfaceJoinInfo++data IfaceJoinInfo = IfaceNotJoinPoint+                   | IfaceJoinPoint JoinArity++{-+Note [Empty case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In IfaceSyn an IfaceCase does not record the types of the alternatives,+unlike CorSyn Case.  But we need this type if the alternatives are empty.+Hence IfaceECase.  See Note [Empty case alternatives] in CoreSyn.++Note [Expose recursive functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For supercompilation we want to put *all* unfoldings in the interface+file, even for functions that are recursive (or big).  So we need to+know when an unfolding belongs to a loop-breaker so that we can refrain+from inlining it (except during supercompilation).++Note [IdInfo on nested let-bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Occasionally we want to preserve IdInfo on nested let bindings. The one+that came up was a NOINLINE pragma on a let-binding inside an INLINE+function.  The user (Duncan Coutts) really wanted the NOINLINE control+to cross the separate compilation boundary.++In general we retain all info that is left by CoreTidy.tidyLetBndr, since+that is what is seen by importing module with --make+++************************************************************************+*                                                                      *+              Printing IfaceDecl+*                                                                      *+************************************************************************+-}++pprAxBranch :: SDoc -> IfaceAxBranch -> SDoc+-- The TyCon might be local (just an OccName), or this might+-- be a branch for an imported TyCon, so it would be an ExtName+-- So it's easier to take an SDoc here+pprAxBranch pp_tc (IfaceAxBranch { ifaxbTyVars = tvs+                                 , ifaxbCoVars = cvs+                                 , ifaxbLHS = pat_tys+                                 , ifaxbRHS = rhs+                                 , ifaxbIncomps = incomps })+  = hang ppr_binders 2 (hang pp_lhs 2 (equals <+> ppr rhs))+    $+$+    nest 2 maybe_incomps+  where+    ppr_binders+      | null tvs && null cvs = empty+      | null cvs+      = brackets (pprWithCommas (pprIfaceTvBndr True) tvs)+      | otherwise+      = brackets (pprWithCommas (pprIfaceTvBndr True) tvs <> semi <+>+                  pprWithCommas pprIfaceIdBndr cvs)+    pp_lhs = hang pp_tc 2 (pprParendIfaceTcArgs pat_tys)+    maybe_incomps = ppUnless (null incomps) $ parens $+                    text "incompatible indices:" <+> ppr incomps++instance Outputable IfaceAnnotation where+  ppr (IfaceAnnotation target value) = ppr target <+> colon <+> ppr value++instance NamedThing IfaceClassOp where+  getName (IfaceClassOp n _ _) = n++instance HasOccName IfaceClassOp where+  occName = getOccName++instance NamedThing IfaceConDecl where+  getName = ifConName++instance HasOccName IfaceConDecl where+  occName = getOccName++instance NamedThing IfaceDecl where+  getName = ifName++instance HasOccName IfaceDecl where+  occName = getOccName++instance Outputable IfaceDecl where+  ppr = pprIfaceDecl showToIface++{-+Note [Minimal complete definition] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The minimal complete definition should only be included if a complete+class definition is shown. Since the minimal complete definition is+anonymous we can't reuse the same mechanism that is used for the+filtering of method signatures. Instead we just check if anything at all is+filtered and hide it in that case.+-}++data ShowSub+  = ShowSub+      { ss_how_much :: ShowHowMuch+      , ss_forall :: ShowForAllFlag }++-- See Note [Printing IfaceDecl binders]+-- The alternative pretty printer referred to in the note.+newtype AltPpr = AltPpr (Maybe (OccName -> SDoc))++data ShowHowMuch+  = ShowHeader AltPpr -- ^Header information only, not rhs+  | ShowSome [OccName] AltPpr+  -- ^ Show only some sub-components. Specifically,+  --+  -- [@[]@] Print all sub-components.+  -- [@(n:ns)@] Print sub-component @n@ with @ShowSub = ns@;+  -- elide other sub-components to @...@+  -- May 14: the list is max 1 element long at the moment+  | ShowIface+  -- ^Everything including GHC-internal information (used in --show-iface)++{-+Note [Printing IfaceDecl binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The binders in an IfaceDecl are just OccNames, so we don't know what module they+come from.  But when we pretty-print a TyThing by converting to an IfaceDecl+(see PprTyThing), the TyThing may come from some other module so we really need+the module qualifier.  We solve this by passing in a pretty-printer for the+binders.++When printing an interface file (--show-iface), we want to print+everything unqualified, so we can just print the OccName directly.+-}++instance Outputable ShowHowMuch where+  ppr (ShowHeader _)    = text "ShowHeader"+  ppr ShowIface         = text "ShowIface"+  ppr (ShowSome occs _) = text "ShowSome" <+> ppr occs++showToHeader :: ShowSub+showToHeader = ShowSub { ss_how_much = ShowHeader $ AltPpr Nothing+                       , ss_forall = ShowForAllWhen }++showToIface :: ShowSub+showToIface = ShowSub { ss_how_much = ShowIface+                      , ss_forall = ShowForAllWhen }++ppShowIface :: ShowSub -> SDoc -> SDoc+ppShowIface (ShowSub { ss_how_much = ShowIface }) doc = doc+ppShowIface _                                     _   = Outputable.empty++-- show if all sub-components or the complete interface is shown+ppShowAllSubs :: ShowSub -> SDoc -> SDoc -- Note [Minimal complete definition]+ppShowAllSubs (ShowSub { ss_how_much = ShowSome [] _ }) doc = doc+ppShowAllSubs (ShowSub { ss_how_much = ShowIface })     doc = doc+ppShowAllSubs _                                         _   = Outputable.empty++ppShowRhs :: ShowSub -> SDoc -> SDoc+ppShowRhs (ShowSub { ss_how_much = ShowHeader _ }) _   = Outputable.empty+ppShowRhs _                                        doc = doc++showSub :: HasOccName n => ShowSub -> n -> Bool+showSub (ShowSub { ss_how_much = ShowHeader _ })     _     = False+showSub (ShowSub { ss_how_much = ShowSome (n:_) _ }) thing = n == occName thing+showSub (ShowSub { ss_how_much = _ })              _     = True++ppr_trim :: [Maybe SDoc] -> [SDoc]+-- Collapse a group of Nothings to a single "..."+ppr_trim xs+  = snd (foldr go (False, []) xs)+  where+    go (Just doc) (_,     so_far) = (False, doc : so_far)+    go Nothing    (True,  so_far) = (True, so_far)+    go Nothing    (False, so_far) = (True, text "..." : so_far)++isIfaceDataInstance :: IfaceTyConParent -> Bool+isIfaceDataInstance IfNoParent = False+isIfaceDataInstance _          = True++pprClassRoles :: ShowSub -> IfaceTopBndr -> [IfaceTyConBinder] -> [Role] -> SDoc+pprClassRoles ss clas binders roles =+    pprRoles (== Nominal)+             (pprPrefixIfDeclBndr (ss_how_much ss) (occName clas))+             binders+             roles++pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc+-- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi+--     See Note [Pretty-printing TyThings] in PprTyThing+pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,+                             ifCtxt = context,+                             ifRoles = roles, ifCons = condecls,+                             ifParent = parent,+                             ifGadtSyntax = gadt,+                             ifBinders = binders })++  | gadt_style = vcat [ pp_roles+                      , pp_nd <+> pp_lhs <+> pp_where+                      , nest 2 (vcat pp_cons)+                      , nest 2 $ ppShowIface ss pp_extra ]+  | otherwise  = vcat [ pp_roles+                      , hang (pp_nd <+> pp_lhs) 2 (add_bars pp_cons)+                      , nest 2 $ ppShowIface ss pp_extra ]+  where+    is_data_instance = isIfaceDataInstance parent++    gadt_style = gadt || any (not . isVanillaIfaceConDecl) cons+    cons       = visibleIfConDecls condecls+    pp_where   = ppWhen (gadt_style && not (null cons)) $ text "where"+    pp_cons    = ppr_trim (map show_con cons) :: [SDoc]++    pp_lhs = case parent of+               IfNoParent -> pprIfaceDeclHead context ss tycon binders Nothing+               _          -> text "instance" <+> pprIfaceTyConParent parent++    pp_roles+      | is_data_instance = empty+      | otherwise        = pprRoles (== Representational)+                                    (pprPrefixIfDeclBndr+                                        (ss_how_much ss)+                                        (occName tycon))+                                    binders roles+            -- Don't display roles for data family instances (yet)+            -- See discussion on Trac #8672.++    add_bars []     = Outputable.empty+    add_bars (c:cs) = sep ((equals <+> c) : map (vbar <+>) cs)++    ok_con dc = showSub ss dc || any (showSub ss . flSelector) (ifConFields dc)++    show_con dc+      | ok_con dc = Just $ pprIfaceConDecl ss gadt_style tycon binders parent dc+      | otherwise = Nothing++    pp_nd = case condecls of+              IfAbstractTyCon{} -> text "data"+              IfDataTyCon{}     -> text "data"+              IfNewTyCon{}      -> text "newtype"++    pp_extra = vcat [pprCType ctype]++pprIfaceDecl ss (IfaceClass { ifName  = clas+                            , ifRoles = roles+                            , ifFDs    = fds+                            , ifBinders = binders+                            , ifBody = IfAbstractClass })+  = vcat [ pprClassRoles ss clas binders roles+         , text "class" <+> pprIfaceDeclHead [] ss clas binders Nothing+                                <+> pprFundeps fds ]++pprIfaceDecl ss (IfaceClass { ifName  = clas+                            , ifRoles = roles+                            , ifFDs    = fds+                            , ifBinders = binders+                            , ifBody = IfConcreteClass {+                                ifATs = ats,+                                ifSigs = sigs,+                                ifClassCtxt = context,+                                ifMinDef = minDef+                              }})+  = vcat [ pprClassRoles ss clas binders roles+         , text "class" <+> pprIfaceDeclHead context ss clas binders Nothing+                                <+> pprFundeps fds <+> pp_where+         , nest 2 (vcat [ vcat asocs, vcat dsigs+                        , ppShowAllSubs ss (pprMinDef minDef)])]+    where+      pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (text "where")++      asocs = ppr_trim $ map maybeShowAssoc ats+      dsigs = ppr_trim $ map maybeShowSig sigs++      maybeShowAssoc :: IfaceAT -> Maybe SDoc+      maybeShowAssoc asc@(IfaceAT d _)+        | showSub ss d = Just $ pprIfaceAT ss asc+        | otherwise    = Nothing++      maybeShowSig :: IfaceClassOp -> Maybe SDoc+      maybeShowSig sg+        | showSub ss sg = Just $  pprIfaceClassOp ss sg+        | otherwise     = Nothing++      pprMinDef :: BooleanFormula IfLclName -> SDoc+      pprMinDef minDef = ppUnless (isTrue minDef) $ -- hide empty definitions+        text "{-# MINIMAL" <+>+        pprBooleanFormula+          (\_ def -> cparen (isLexSym def) (ppr def)) 0 minDef <+>+        text "#-}"++pprIfaceDecl ss (IfaceSynonym { ifName    = tc+                              , ifBinders = binders+                              , ifSynRhs  = mono_ty+                              , ifResKind = res_kind})+  = hang (text "type" <+> pprIfaceDeclHead [] ss tc binders Nothing <+> equals)+       2 (sep [ pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau+              , ppUnless (isIfaceLiftedTypeKind res_kind) (dcolon <+> ppr res_kind) ])+  where+    (tvs, theta, tau) = splitIfaceSigmaTy mono_ty++pprIfaceDecl ss (IfaceFamily { ifName = tycon+                             , ifFamFlav = rhs, ifBinders = binders+                             , ifResKind = res_kind+                             , ifResVar = res_var, ifFamInj = inj })+  | IfaceDataFamilyTyCon <- rhs+  = text "data family" <+> pprIfaceDeclHead [] ss tycon binders Nothing++  | otherwise+  = hang (text "type family" <+> pprIfaceDeclHead [] ss tycon binders (Just res_kind))+       2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs))+    $$+    nest 2 (ppShowRhs ss (pp_branches rhs))+  where+    pp_inj Nothing    _   = empty+    pp_inj (Just res) inj+       | Injective injectivity <- inj = hsep [ equals, ppr res+                                             , pp_inj_cond res injectivity]+       | otherwise = hsep [ equals, ppr res ]++    pp_inj_cond res inj = case filterByList inj binders of+       []  -> empty+       tvs -> hsep [vbar, ppr res, text "->", interppSP (map ifTyConBinderName tvs)]++    pp_rhs IfaceDataFamilyTyCon+      = ppShowIface ss (text "data")+    pp_rhs IfaceOpenSynFamilyTyCon+      = ppShowIface ss (text "open")+    pp_rhs IfaceAbstractClosedSynFamilyTyCon+      = ppShowIface ss (text "closed, abstract")+    pp_rhs (IfaceClosedSynFamilyTyCon {})+      = empty  -- see pp_branches+    pp_rhs IfaceBuiltInSynFamTyCon+      = ppShowIface ss (text "built-in")++    pp_branches (IfaceClosedSynFamilyTyCon (Just (ax, brs)))+      = hang (text "where")+           2 (vcat (map (pprAxBranch+                           (pprPrefixIfDeclBndr+                             (ss_how_much ss)+                             (occName tycon))+                        ) brs)+              $$ ppShowIface ss (text "axiom" <+> ppr ax))+    pp_branches _ = Outputable.empty++pprIfaceDecl _ (IfacePatSyn { ifName = name,+                              ifPatUnivBndrs = univ_bndrs, ifPatExBndrs = ex_bndrs,+                              ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,+                              ifPatArgs = arg_tys,+                              ifPatTy = pat_ty} )+  = sdocWithDynFlags mk_msg+  where+    mk_msg dflags+      = hsep [ text "pattern", pprPrefixOcc name, dcolon+             , univ_msg, pprIfaceContextArr req_ctxt+             , ppWhen insert_empty_ctxt $ parens empty <+> darrow+             , ex_msg, pprIfaceContextArr prov_ctxt+             , pprIfaceType $ foldr IfaceFunTy pat_ty arg_tys]+      where+        univ_msg = pprUserIfaceForAll univ_bndrs+        ex_msg   = pprUserIfaceForAll ex_bndrs++        insert_empty_ctxt = null req_ctxt+            && not (null prov_ctxt && isEmpty dflags ex_msg)++pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty,+                              ifIdDetails = details, ifIdInfo = info })+  = vcat [ hang (pprPrefixIfDeclBndr (ss_how_much ss) (occName var) <+> dcolon)+              2 (pprIfaceSigmaType (ss_forall ss) ty)+         , ppShowIface ss (ppr details)+         , ppShowIface ss (ppr info) ]++pprIfaceDecl _ (IfaceAxiom { ifName = name, ifTyCon = tycon+                           , ifAxBranches = branches })+  = hang (text "axiom" <+> ppr name <> dcolon)+       2 (vcat $ map (pprAxBranch (ppr tycon)) branches)+++pprCType :: Maybe CType -> SDoc+pprCType Nothing      = Outputable.empty+pprCType (Just cType) = text "C type:" <+> ppr cType++-- if, for each role, suppress_if role is True, then suppress the role+-- output+pprRoles :: (Role -> Bool) -> SDoc -> [IfaceTyConBinder]+         -> [Role] -> SDoc+pprRoles suppress_if tyCon bndrs roles+  = sdocWithDynFlags $ \dflags ->+      let froles = suppressIfaceInvisibles dflags bndrs roles+      in ppUnless (all suppress_if roles || null froles) $+         text "type role" <+> tyCon <+> hsep (map ppr froles)++pprInfixIfDeclBndr :: ShowHowMuch -> OccName -> SDoc+pprInfixIfDeclBndr (ShowSome _ (AltPpr (Just ppr_bndr))) name+  = pprInfixVar (isSymOcc name) (ppr_bndr name)+pprInfixIfDeclBndr _ name+  = pprInfixVar (isSymOcc name) (ppr name)++pprPrefixIfDeclBndr :: ShowHowMuch -> OccName -> SDoc+pprPrefixIfDeclBndr (ShowHeader (AltPpr (Just ppr_bndr))) name+  = parenSymOcc name (ppr_bndr name)+pprPrefixIfDeclBndr (ShowSome _ (AltPpr (Just ppr_bndr))) name+  = parenSymOcc name (ppr_bndr name)+pprPrefixIfDeclBndr _ name+  = parenSymOcc name (ppr name)++instance Outputable IfaceClassOp where+   ppr = pprIfaceClassOp showToIface++pprIfaceClassOp :: ShowSub -> IfaceClassOp -> SDoc+pprIfaceClassOp ss (IfaceClassOp n ty dm)+  = pp_sig n ty $$ generic_dm+  where+   generic_dm | Just (GenericDM dm_ty) <- dm+              =  text "default" <+> pp_sig n dm_ty+              | otherwise+              = empty+   pp_sig n ty+     = pprPrefixIfDeclBndr (ss_how_much ss) (occName n)+     <+> dcolon+     <+> pprIfaceSigmaType ShowForAllWhen ty++instance Outputable IfaceAT where+   ppr = pprIfaceAT showToIface++pprIfaceAT :: ShowSub -> IfaceAT -> SDoc+pprIfaceAT ss (IfaceAT d mb_def)+  = vcat [ pprIfaceDecl ss d+         , case mb_def of+              Nothing  -> Outputable.empty+              Just rhs -> nest 2 $+                          text "Default:" <+> ppr rhs ]++instance Outputable IfaceTyConParent where+  ppr p = pprIfaceTyConParent p++pprIfaceTyConParent :: IfaceTyConParent -> SDoc+pprIfaceTyConParent IfNoParent+  = Outputable.empty+pprIfaceTyConParent (IfDataInstance _ tc tys)+  = sdocWithDynFlags $ \dflags ->+    let ftys = stripInvisArgs dflags tys+    in pprIfaceTypeApp TopPrec tc ftys++pprIfaceDeclHead :: IfaceContext -> ShowSub -> Name+                 -> [IfaceTyConBinder]   -- of the tycon, for invisible-suppression+                 -> Maybe IfaceKind+                 -> SDoc+pprIfaceDeclHead context ss tc_occ bndrs m_res_kind+  = sdocWithDynFlags $ \ dflags ->+    sep [ pprIfaceContextArr context+        , pprPrefixIfDeclBndr (ss_how_much ss) (occName tc_occ)+          <+> pprIfaceTyConBinders (suppressIfaceInvisibles dflags bndrs bndrs)+        , maybe empty (\res_kind -> dcolon <+> pprIfaceType res_kind) m_res_kind ]++isVanillaIfaceConDecl :: IfaceConDecl -> Bool+isVanillaIfaceConDecl (IfCon { ifConExTvs  = ex_tvs+                             , ifConEqSpec = eq_spec+                             , ifConCtxt   = ctxt })+  = (null ex_tvs) && (null eq_spec) && (null ctxt)++pprIfaceConDecl :: ShowSub -> Bool+                -> IfaceTopBndr+                -> [IfaceTyConBinder]+                -> IfaceTyConParent+                -> IfaceConDecl -> SDoc+pprIfaceConDecl ss gadt_style tycon tc_binders parent+        (IfCon { ifConName = name, ifConInfix = is_infix,+                 ifConExTvs = ex_tvs,+                 ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,+                 ifConStricts = stricts, ifConFields = fields })+  | gadt_style            = pp_prefix_con <+> dcolon <+> ppr_ty+  | not (null fields)     = pp_prefix_con <+> pp_field_args+  | is_infix+  , [ty1, ty2] <- pp_args = sep [ ty1+                                , pprInfixIfDeclBndr how_much (occName name)+                                , ty2]++  | otherwise             = pp_prefix_con <+> sep pp_args+  where+    how_much = ss_how_much ss+    tys_w_strs :: [(IfaceBang, IfaceType)]+    tys_w_strs = zip stricts arg_tys+    pp_prefix_con = pprPrefixIfDeclBndr how_much (occName name)++    (univ_tvs, pp_res_ty) = mk_user_con_res_ty eq_spec+    ppr_ty = pprIfaceForAllPart (map tv_to_forall_bndr univ_tvs ++ ex_tvs)+                                ctxt pp_tau++        -- A bit gruesome this, but we can't form the full con_tau, and ppr it,+        -- because we don't have a Name for the tycon, only an OccName+    pp_tau | null fields+           = case pp_args ++ [pp_res_ty] of+                (t:ts) -> fsep (t : map (arrow <+>) ts)+                []     -> panic "pp_con_taus"+           | otherwise+           = sep [pp_field_args, arrow <+> pp_res_ty]++    ppr_bang IfNoBang = sdocWithPprDebug $ \dbg -> ppWhen dbg $ char '_'+    ppr_bang IfStrict = char '!'+    ppr_bang IfUnpack = text "{-# UNPACK #-}"+    ppr_bang (IfUnpackCo co) = text "! {-# UNPACK #-}" <>+                               pprParendIfaceCoercion co++    pprParendBangTy (bang, ty) = ppr_bang bang <> pprParendIfaceType ty+    pprBangTy       (bang, ty) = ppr_bang bang <> ppr ty++    pp_args :: [SDoc]  -- With parens, e.g  (Maybe a)  or  !(Maybe a)+    pp_args = map pprParendBangTy tys_w_strs++    pp_field_args :: SDoc  -- Braces form:  { x :: !Maybe a, y :: Int }+    pp_field_args = braces $ sep $ punctuate comma $ ppr_trim $+                    zipWith maybe_show_label fields tys_w_strs++    maybe_show_label :: FieldLabel -> (IfaceBang, IfaceType) -> Maybe SDoc+    maybe_show_label lbl bty+      | showSub ss sel =+          Just (pprPrefixIfDeclBndr how_much occ <+> dcolon <+> pprBangTy bty)+      | otherwise      =+          Nothing+      where+        sel = flSelector lbl+        occ = mkVarOccFS (flLabel lbl)++    mk_user_con_res_ty :: IfaceEqSpec -> ([IfaceTvBndr], SDoc)+    -- See Note [Result type of a data family GADT]+    mk_user_con_res_ty eq_spec+      | IfDataInstance _ tc tys <- parent+      = (con_univ_tvs, pprIfaceType (IfaceTyConApp tc (substIfaceTcArgs gadt_subst tys)))+      | otherwise+      = (con_univ_tvs, sdocWithDynFlags (ppr_tc_app gadt_subst))+      where+        gadt_subst = mkFsEnv eq_spec+        done_univ_tv (tv,_) = isJust (lookupFsEnv gadt_subst tv)+        con_univ_tvs = filterOut done_univ_tv (map ifTyConBinderTyVar tc_binders)++    ppr_tc_app gadt_subst dflags+       = pprPrefixIfDeclBndr how_much (occName tycon)+         <+> sep [ pprParendIfaceType (substIfaceTyVar gadt_subst tv)+                 | (tv,_kind)+                     <- map ifTyConBinderTyVar $+                        suppressIfaceInvisibles dflags tc_binders tc_binders ]++instance Outputable IfaceRule where+  ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,+                   ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,+                   ifRuleOrph = orph })+    = sep [hsep [pprRuleName name,+                 if isOrphan orph then text "[orphan]" else Outputable.empty,+                 ppr act,+                 text "forall" <+> pprIfaceBndrs bndrs],+           nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args),+                        text "=" <+> ppr rhs])+      ]++instance Outputable IfaceClsInst where+  ppr (IfaceClsInst { ifDFun = dfun_id, ifOFlag = flag+                    , ifInstCls = cls, ifInstTys = mb_tcs+                    , ifInstOrph = orph })+    = hang (text "instance" <+> ppr flag+              <+> (if isOrphan orph then text "[orphan]" else Outputable.empty)+              <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))+         2 (equals <+> ppr dfun_id)++instance Outputable IfaceFamInst where+  ppr (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs+                    , ifFamInstAxiom = tycon_ax, ifFamInstOrph = orph })+    = hang (text "family instance"+              <+> (if isOrphan orph then text "[orphan]" else Outputable.empty)+              <+> ppr fam <+> pprWithCommas (brackets . ppr_rough) mb_tcs)+         2 (equals <+> ppr tycon_ax)++ppr_rough :: Maybe IfaceTyCon -> SDoc+ppr_rough Nothing   = dot+ppr_rough (Just tc) = ppr tc++tv_to_forall_bndr :: IfaceTvBndr -> IfaceForAllBndr+tv_to_forall_bndr tv = TvBndr tv Specified++{-+Note [Result type of a data family GADT]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   data family T a+   data instance T (p,q) where+      T1 :: T (Int, Maybe c)+      T2 :: T (Bool, q)++The IfaceDecl actually looks like++   data TPr p q where+      T1 :: forall p q. forall c. (p~Int,q~Maybe c) => TPr p q+      T2 :: forall p q. (p~Bool) => TPr p q++To reconstruct the result types for T1 and T2 that we+want to pretty print, we substitute the eq-spec+[p->Int, q->Maybe c] in the arg pattern (p,q) to give+   T (Int, Maybe c)+Remember that in IfaceSyn, the TyCon and DataCon share the same+universal type variables.++----------------------------- Printing IfaceExpr ------------------------------------+-}++instance Outputable IfaceExpr where+    ppr e = pprIfaceExpr noParens e++noParens :: SDoc -> SDoc+noParens pp = pp++pprParendIfaceExpr :: IfaceExpr -> SDoc+pprParendIfaceExpr = pprIfaceExpr parens++-- | Pretty Print an IfaceExpre+--+-- The first argument should be a function that adds parens in context that need+-- an atomic value (e.g. function args)+pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc++pprIfaceExpr _       (IfaceLcl v)       = ppr v+pprIfaceExpr _       (IfaceExt v)       = ppr v+pprIfaceExpr _       (IfaceLit l)       = ppr l+pprIfaceExpr _       (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)+pprIfaceExpr _       (IfaceType ty)     = char '@' <+> pprParendIfaceType ty+pprIfaceExpr _       (IfaceCo co)       = text "@~" <+> pprParendIfaceCoercion co++pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])+pprIfaceExpr _       (IfaceTuple c as)  = tupleParens c (pprWithCommas ppr as)++pprIfaceExpr add_par i@(IfaceLam _ _)+  = add_par (sep [char '\\' <+> sep (map pprIfaceLamBndr bndrs) <+> arrow,+                  pprIfaceExpr noParens body])+  where+    (bndrs,body) = collect [] i+    collect bs (IfaceLam b e) = collect (b:bs) e+    collect bs e              = (reverse bs, e)++pprIfaceExpr add_par (IfaceECase scrut ty)+  = add_par (sep [ text "case" <+> pprIfaceExpr noParens scrut+                 , text "ret_ty" <+> pprParendIfaceType ty+                 , text "of {}" ])++pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)])+  = add_par (sep [text "case"+                        <+> pprIfaceExpr noParens scrut <+> text "of"+                        <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,+                  pprIfaceExpr noParens rhs <+> char '}'])++pprIfaceExpr add_par (IfaceCase scrut bndr alts)+  = add_par (sep [text "case"+                        <+> pprIfaceExpr noParens scrut <+> text "of"+                        <+> ppr bndr <+> char '{',+                  nest 2 (sep (map ppr_alt alts)) <+> char '}'])++pprIfaceExpr _       (IfaceCast expr co)+  = sep [pprParendIfaceExpr expr,+         nest 2 (text "`cast`"),+         pprParendIfaceCoercion co]++pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body)+  = add_par (sep [text "let {",+                  nest 2 (ppr_bind (b, rhs)),+                  text "} in",+                  pprIfaceExpr noParens body])++pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body)+  = add_par (sep [text "letrec {",+                  nest 2 (sep (map ppr_bind pairs)),+                  text "} in",+                  pprIfaceExpr noParens body])++pprIfaceExpr add_par (IfaceTick tickish e)+  = add_par (pprIfaceTickish tickish <+> pprIfaceExpr noParens e)++ppr_alt :: (IfaceConAlt, [IfLclName], IfaceExpr) -> SDoc+ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs,+                         arrow <+> pprIfaceExpr noParens rhs]++ppr_con_bs :: IfaceConAlt -> [IfLclName] -> SDoc+ppr_con_bs con bs = ppr con <+> hsep (map ppr bs)++ppr_bind :: (IfaceLetBndr, IfaceExpr) -> SDoc+ppr_bind (IfLetBndr b ty info ji, rhs)+  = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr ji <+> ppr info),+         equals <+> pprIfaceExpr noParens rhs]++------------------+pprIfaceTickish :: IfaceTickish -> SDoc+pprIfaceTickish (IfaceHpcTick m ix)+  = braces (text "tick" <+> ppr m <+> ppr ix)+pprIfaceTickish (IfaceSCC cc tick scope)+  = braces (pprCostCentreCore cc <+> ppr tick <+> ppr scope)+pprIfaceTickish (IfaceSource src _names)+  = braces (pprUserRealSpan True src)++------------------+pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc+pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $+                                          nest 2 (pprParendIfaceExpr arg) : args+pprIfaceApp fun                args = sep (pprParendIfaceExpr fun : args)++------------------+instance Outputable IfaceConAlt where+    ppr IfaceDefault      = text "DEFAULT"+    ppr (IfaceLitAlt l)   = ppr l+    ppr (IfaceDataAlt d)  = ppr d++------------------+instance Outputable IfaceIdDetails where+  ppr IfVanillaId       = Outputable.empty+  ppr (IfRecSelId tc b) = text "RecSel" <+> ppr tc+                          <+> if b+                                then text "<naughty>"+                                else Outputable.empty+  ppr IfDFunId          = text "DFunId"++instance Outputable IfaceIdInfo where+  ppr NoInfo       = Outputable.empty+  ppr (HasInfo is) = text "{-" <+> pprWithCommas ppr is+                     <+> text "-}"++instance Outputable IfaceInfoItem where+  ppr (HsUnfold lb unf)     = text "Unfolding"+                              <> ppWhen lb (text "(loop-breaker)")+                              <> colon <+> ppr unf+  ppr (HsInline prag)       = text "Inline:" <+> ppr prag+  ppr (HsArity arity)       = text "Arity:" <+> int arity+  ppr (HsStrictness str) = text "Strictness:" <+> pprIfaceStrictSig str+  ppr HsNoCafRefs           = text "HasNoCafRefs"+  ppr HsLevity              = text "Never levity-polymorphic"++instance Outputable IfaceJoinInfo where+  ppr IfaceNotJoinPoint   = empty+  ppr (IfaceJoinPoint ar) = angleBrackets (text "join" <+> ppr ar)++instance Outputable IfaceUnfolding where+  ppr (IfCompulsory e)     = text "<compulsory>" <+> parens (ppr e)+  ppr (IfCoreUnfold s e)   = (if s+                                then text "<stable>"+                                else Outputable.empty)+                              <+> parens (ppr e)+  ppr (IfInlineRule a uok bok e) = sep [text "InlineRule"+                                            <+> ppr (a,uok,bok),+                                        pprParendIfaceExpr e]+  ppr (IfDFunUnfold bs es) = hang (text "DFun:" <+> sep (map ppr bs) <> dot)+                                2 (sep (map pprParendIfaceExpr es))++{-+************************************************************************+*                                                                      *+              Finding the Names in IfaceSyn+*                                                                      *+************************************************************************++This is used for dependency analysis in MkIface, so that we+fingerprint a declaration before the things that depend on it.  It+is specific to interface-file fingerprinting in the sense that we+don't collect *all* Names: for example, the DFun of an instance is+recorded textually rather than by its fingerprint when+fingerprinting the instance, so DFuns are not dependencies.+-}++freeNamesIfDecl :: IfaceDecl -> NameSet+freeNamesIfDecl (IfaceId _s t d i) =+  freeNamesIfType t &&&+  freeNamesIfIdInfo i &&&+  freeNamesIfIdDetails d+freeNamesIfDecl d@IfaceData{} =+  freeNamesIfTyVarBndrs (ifBinders d) &&&+  freeNamesIfType (ifResKind d) &&&+  freeNamesIfaceTyConParent (ifParent d) &&&+  freeNamesIfContext (ifCtxt d) &&&+  freeNamesIfConDecls (ifCons d)+freeNamesIfDecl d@IfaceSynonym{} =+  freeNamesIfType (ifSynRhs d) &&&+  freeNamesIfTyVarBndrs (ifBinders d) &&&+  freeNamesIfKind (ifResKind d)+freeNamesIfDecl d@IfaceFamily{} =+  freeNamesIfFamFlav (ifFamFlav d) &&&+  freeNamesIfTyVarBndrs (ifBinders d) &&&+  freeNamesIfKind (ifResKind d)+freeNamesIfDecl d@IfaceClass{ ifBody = IfAbstractClass } =+  freeNamesIfTyVarBndrs (ifBinders d)+freeNamesIfDecl d@IfaceClass{ ifBody = d'@IfConcreteClass{} } =+  freeNamesIfTyVarBndrs (ifBinders d) &&&+  freeNamesIfContext (ifClassCtxt d') &&&+  fnList freeNamesIfAT     (ifATs d') &&&+  fnList freeNamesIfClsSig (ifSigs d')+freeNamesIfDecl d@IfaceAxiom{} =+  freeNamesIfTc (ifTyCon d) &&&+  fnList freeNamesIfAxBranch (ifAxBranches d)+freeNamesIfDecl d@IfacePatSyn{} =+  unitNameSet (fst (ifPatMatcher d)) &&&+  maybe emptyNameSet (unitNameSet . fst) (ifPatBuilder d) &&&+  freeNamesIfTyVarBndrs (ifPatUnivBndrs d) &&&+  freeNamesIfTyVarBndrs (ifPatExBndrs d) &&&+  freeNamesIfContext (ifPatProvCtxt d) &&&+  freeNamesIfContext (ifPatReqCtxt d) &&&+  fnList freeNamesIfType (ifPatArgs d) &&&+  freeNamesIfType (ifPatTy d) &&&+  mkNameSet (map flSelector (ifFieldLabels d))++freeNamesIfAxBranch :: IfaceAxBranch -> NameSet+freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars   = tyvars+                                   , ifaxbCoVars   = covars+                                   , ifaxbLHS      = lhs+                                   , ifaxbRHS      = rhs })+  = fnList freeNamesIfTvBndr tyvars &&&+    fnList freeNamesIfIdBndr covars &&&+    freeNamesIfTcArgs lhs &&&+    freeNamesIfType rhs++freeNamesIfIdDetails :: IfaceIdDetails -> NameSet+freeNamesIfIdDetails (IfRecSelId tc _) =+  either freeNamesIfTc freeNamesIfDecl tc+freeNamesIfIdDetails _                 = emptyNameSet++-- All other changes are handled via the version info on the tycon+freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet+freeNamesIfFamFlav IfaceOpenSynFamilyTyCon             = emptyNameSet+freeNamesIfFamFlav IfaceDataFamilyTyCon                = emptyNameSet+freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon (Just (ax, br)))+  = unitNameSet ax &&& fnList freeNamesIfAxBranch br+freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon Nothing) = emptyNameSet+freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon   = emptyNameSet+freeNamesIfFamFlav IfaceBuiltInSynFamTyCon             = emptyNameSet++freeNamesIfContext :: IfaceContext -> NameSet+freeNamesIfContext = fnList freeNamesIfType++freeNamesIfAT :: IfaceAT -> NameSet+freeNamesIfAT (IfaceAT decl mb_def)+  = freeNamesIfDecl decl &&&+    case mb_def of+      Nothing  -> emptyNameSet+      Just rhs -> freeNamesIfType rhs++freeNamesIfClsSig :: IfaceClassOp -> NameSet+freeNamesIfClsSig (IfaceClassOp _n ty dm) = freeNamesIfType ty &&& freeNamesDM dm++freeNamesDM :: Maybe (DefMethSpec IfaceType) -> NameSet+freeNamesDM (Just (GenericDM ty)) = freeNamesIfType ty+freeNamesDM _                     = emptyNameSet++freeNamesIfConDecls :: IfaceConDecls -> NameSet+freeNamesIfConDecls (IfDataTyCon c) = fnList freeNamesIfConDecl c+freeNamesIfConDecls (IfNewTyCon  c) = freeNamesIfConDecl c+freeNamesIfConDecls _                   = emptyNameSet++freeNamesIfConDecl :: IfaceConDecl -> NameSet+freeNamesIfConDecl (IfCon { ifConExTvs   = ex_tvs, ifConCtxt = ctxt+                          , ifConArgTys  = arg_tys+                          , ifConFields  = flds+                          , ifConEqSpec  = eq_spec+                          , ifConStricts = bangs })+  = freeNamesIfTyVarBndrs ex_tvs &&&+    freeNamesIfContext ctxt &&&+    fnList freeNamesIfType arg_tys &&&+    mkNameSet (map flSelector flds) &&&+    fnList freeNamesIfType (map snd eq_spec) &&& -- equality constraints+    fnList freeNamesIfBang bangs++freeNamesIfBang :: IfaceBang -> NameSet+freeNamesIfBang (IfUnpackCo co) = freeNamesIfCoercion co+freeNamesIfBang _               = emptyNameSet++freeNamesIfKind :: IfaceType -> NameSet+freeNamesIfKind = freeNamesIfType++freeNamesIfTcArgs :: IfaceTcArgs -> NameSet+freeNamesIfTcArgs (ITC_Vis   t ts) = freeNamesIfType t &&& freeNamesIfTcArgs ts+freeNamesIfTcArgs (ITC_Invis k ks) = freeNamesIfKind k &&& freeNamesIfTcArgs ks+freeNamesIfTcArgs ITC_Nil          = emptyNameSet++freeNamesIfType :: IfaceType -> NameSet+freeNamesIfType (IfaceFreeTyVar _)    = emptyNameSet+freeNamesIfType (IfaceTyVar _)        = emptyNameSet+freeNamesIfType (IfaceAppTy s t)      = freeNamesIfType s &&& freeNamesIfType t+freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfTcArgs ts+freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfTcArgs ts+freeNamesIfType (IfaceLitTy _)        = emptyNameSet+freeNamesIfType (IfaceForAllTy tv t)  = freeNamesIfTyVarBndr tv &&& freeNamesIfType t+freeNamesIfType (IfaceFunTy s t)      = freeNamesIfType s &&& freeNamesIfType t+freeNamesIfType (IfaceDFunTy s t)     = freeNamesIfType s &&& freeNamesIfType t+freeNamesIfType (IfaceCastTy t c)     = freeNamesIfType t &&& freeNamesIfCoercion c+freeNamesIfType (IfaceCoercionTy c)   = freeNamesIfCoercion c++freeNamesIfCoercion :: IfaceCoercion -> NameSet+freeNamesIfCoercion (IfaceReflCo _ t) = freeNamesIfType t+freeNamesIfCoercion (IfaceFunCo _ c1 c2)+  = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2+freeNamesIfCoercion (IfaceTyConAppCo _ tc cos)+  = freeNamesIfTc tc &&& fnList freeNamesIfCoercion cos+freeNamesIfCoercion (IfaceAppCo c1 c2)+  = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2+freeNamesIfCoercion (IfaceForAllCo _ kind_co co)+  = freeNamesIfCoercion kind_co &&& freeNamesIfCoercion co+freeNamesIfCoercion (IfaceCoVarCo _)+  = emptyNameSet+freeNamesIfCoercion (IfaceAxiomInstCo ax _ cos)+  = unitNameSet ax &&& fnList freeNamesIfCoercion cos+freeNamesIfCoercion (IfaceUnivCo p _ t1 t2)+  = freeNamesIfProv p &&& freeNamesIfType t1 &&& freeNamesIfType t2+freeNamesIfCoercion (IfaceSymCo c)+  = freeNamesIfCoercion c+freeNamesIfCoercion (IfaceTransCo c1 c2)+  = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2+freeNamesIfCoercion (IfaceNthCo _ co)+  = freeNamesIfCoercion co+freeNamesIfCoercion (IfaceLRCo _ co)+  = freeNamesIfCoercion co+freeNamesIfCoercion (IfaceInstCo co co2)+  = freeNamesIfCoercion co &&& freeNamesIfCoercion co2+freeNamesIfCoercion (IfaceCoherenceCo c1 c2)+  = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2+freeNamesIfCoercion (IfaceKindCo c)+  = freeNamesIfCoercion c+freeNamesIfCoercion (IfaceSubCo co)+  = freeNamesIfCoercion co+freeNamesIfCoercion (IfaceAxiomRuleCo _ax cos)+  -- the axiom is just a string, so we don't count it as a name.+  = fnList freeNamesIfCoercion cos++freeNamesIfProv :: IfaceUnivCoProv -> NameSet+freeNamesIfProv IfaceUnsafeCoerceProv    = emptyNameSet+freeNamesIfProv (IfacePhantomProv co)    = freeNamesIfCoercion co+freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co+freeNamesIfProv (IfacePluginProv _)      = emptyNameSet+freeNamesIfProv (IfaceHoleProv _)        = emptyNameSet++freeNamesIfTyVarBndr :: TyVarBndr IfaceTvBndr vis -> NameSet+freeNamesIfTyVarBndr (TvBndr tv _) = freeNamesIfTvBndr tv++freeNamesIfTyVarBndrs :: [TyVarBndr IfaceTvBndr vis] -> NameSet+freeNamesIfTyVarBndrs = fnList freeNamesIfTyVarBndr++freeNamesIfBndr :: IfaceBndr -> NameSet+freeNamesIfBndr (IfaceIdBndr b) = freeNamesIfIdBndr b+freeNamesIfBndr (IfaceTvBndr b) = freeNamesIfTvBndr b++freeNamesIfBndrs :: [IfaceBndr] -> NameSet+freeNamesIfBndrs = fnList freeNamesIfBndr++freeNamesIfLetBndr :: IfaceLetBndr -> NameSet+-- Remember IfaceLetBndr is used only for *nested* bindings+-- The IdInfo can contain an unfolding (in the case of+-- local INLINE pragmas), so look there too+freeNamesIfLetBndr (IfLetBndr _name ty info _ji) = freeNamesIfType ty+                                                 &&& freeNamesIfIdInfo info++freeNamesIfTvBndr :: IfaceTvBndr -> NameSet+freeNamesIfTvBndr (_fs,k) = freeNamesIfKind k+    -- kinds can have Names inside, because of promotion++freeNamesIfIdBndr :: IfaceIdBndr -> NameSet+freeNamesIfIdBndr (_fs,k) = freeNamesIfKind k++freeNamesIfIdInfo :: IfaceIdInfo -> NameSet+freeNamesIfIdInfo NoInfo      = emptyNameSet+freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i++freeNamesItem :: IfaceInfoItem -> NameSet+freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u+freeNamesItem _              = emptyNameSet++freeNamesIfUnfold :: IfaceUnfolding -> NameSet+freeNamesIfUnfold (IfCoreUnfold _ e)     = freeNamesIfExpr e+freeNamesIfUnfold (IfCompulsory e)       = freeNamesIfExpr e+freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e+freeNamesIfUnfold (IfDFunUnfold bs es)   = freeNamesIfBndrs bs &&& fnList freeNamesIfExpr es++freeNamesIfExpr :: IfaceExpr -> NameSet+freeNamesIfExpr (IfaceExt v)          = unitNameSet v+freeNamesIfExpr (IfaceFCall _ ty)     = freeNamesIfType ty+freeNamesIfExpr (IfaceType ty)        = freeNamesIfType ty+freeNamesIfExpr (IfaceCo co)          = freeNamesIfCoercion co+freeNamesIfExpr (IfaceTuple _ as)     = fnList freeNamesIfExpr as+freeNamesIfExpr (IfaceLam (b,_) body) = freeNamesIfBndr b &&& freeNamesIfExpr body+freeNamesIfExpr (IfaceApp f a)        = freeNamesIfExpr f &&& freeNamesIfExpr a+freeNamesIfExpr (IfaceCast e co)      = freeNamesIfExpr e &&& freeNamesIfCoercion co+freeNamesIfExpr (IfaceTick _ e)       = freeNamesIfExpr e+freeNamesIfExpr (IfaceECase e ty)     = freeNamesIfExpr e &&& freeNamesIfType ty+freeNamesIfExpr (IfaceCase s _ alts)+  = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts+  where+    fn_alt (_con,_bs,r) = freeNamesIfExpr r++    -- Depend on the data constructors.  Just one will do!+    -- Note [Tracking data constructors]+    fn_cons []                            = emptyNameSet+    fn_cons ((IfaceDefault    ,_,_) : xs) = fn_cons xs+    fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con+    fn_cons (_                      : _ ) = emptyNameSet++freeNamesIfExpr (IfaceLet (IfaceNonRec bndr rhs) body)+  = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs &&& freeNamesIfExpr body++freeNamesIfExpr (IfaceLet (IfaceRec as) x)+  = fnList fn_pair as &&& freeNamesIfExpr x+  where+    fn_pair (bndr, rhs) = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs++freeNamesIfExpr _ = emptyNameSet++freeNamesIfTc :: IfaceTyCon -> NameSet+freeNamesIfTc tc = unitNameSet (ifaceTyConName tc)+-- ToDo: shouldn't we include IfaceIntTc & co.?++freeNamesIfRule :: IfaceRule -> NameSet+freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f+                           , ifRuleArgs = es, ifRuleRhs = rhs })+  = unitNameSet f &&&+    fnList freeNamesIfBndr bs &&&+    fnList freeNamesIfExpr es &&&+    freeNamesIfExpr rhs++freeNamesIfFamInst :: IfaceFamInst -> NameSet+freeNamesIfFamInst (IfaceFamInst { ifFamInstFam = famName+                                 , ifFamInstAxiom = axName })+  = unitNameSet famName &&&+    unitNameSet axName++freeNamesIfaceTyConParent :: IfaceTyConParent -> NameSet+freeNamesIfaceTyConParent IfNoParent = emptyNameSet+freeNamesIfaceTyConParent (IfDataInstance ax tc tys)+  = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfTcArgs tys++-- helpers+(&&&) :: NameSet -> NameSet -> NameSet+(&&&) = unionNameSet++fnList :: (a -> NameSet) -> [a] -> NameSet+fnList f = foldr (&&&) emptyNameSet . map f++{-+Note [Tracking data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a case expression+   case e of { C a -> ...; ... }+You might think that we don't need to include the datacon C+in the free names, because its type will probably show up in+the free names of 'e'.  But in rare circumstances this may+not happen.   Here's the one that bit me:++   module DynFlags where+     import {-# SOURCE #-} Packages( PackageState )+     data DynFlags = DF ... PackageState ...++   module Packages where+     import DynFlags+     data PackageState = PS ...+     lookupModule (df :: DynFlags)+        = case df of+              DF ...p... -> case p of+                               PS ... -> ...++Now, lookupModule depends on DynFlags, but the transitive dependency+on the *locally-defined* type PackageState is not visible. We need+to take account of the use of the data constructor PS in the pattern match.+++************************************************************************+*                                                                      *+                Binary instances+*                                                                      *+************************************************************************++Note that there is a bit of subtlety here when we encode names. While+IfaceTopBndrs is really just a synonym for Name, we need to take care to+encode them with {get,put}IfaceTopBndr. The difference becomes important when+we go to fingerprint an IfaceDecl. See Note [Fingerprinting IfaceDecls] for+details.++-}++instance Binary IfaceDecl where+    put_ bh (IfaceId name ty details idinfo) = do+        putByte bh 0+        putIfaceTopBndr bh name+        lazyPut bh (ty, details, idinfo)+        -- See Note [Lazy deserialization of IfaceId]++    put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) = do+        putByte bh 2+        putIfaceTopBndr bh a1+        put_ bh a2+        put_ bh a3+        put_ bh a4+        put_ bh a5+        put_ bh a6+        put_ bh a7+        put_ bh a8+        put_ bh a9++    put_ bh (IfaceSynonym a1 a2 a3 a4 a5) = do+        putByte bh 3+        putIfaceTopBndr bh a1+        put_ bh a2+        put_ bh a3+        put_ bh a4+        put_ bh a5++    put_ bh (IfaceFamily a1 a2 a3 a4 a5 a6) = do+        putByte bh 4+        putIfaceTopBndr bh a1+        put_ bh a2+        put_ bh a3+        put_ bh a4+        put_ bh a5+        put_ bh a6++    -- NB: Written in a funny way to avoid an interface change+    put_ bh (IfaceClass {+                ifName    = a2,+                ifRoles   = a3,+                ifBinders = a4,+                ifFDs     = a5,+                ifBody = IfConcreteClass {+                    ifClassCtxt = a1,+                    ifATs  = a6,+                    ifSigs = a7,+                    ifMinDef  = a8+                }}) = do+        putByte bh 5+        put_ bh a1+        putIfaceTopBndr bh a2+        put_ bh a3+        put_ bh a4+        put_ bh a5+        put_ bh a6+        put_ bh a7+        put_ bh a8++    put_ bh (IfaceAxiom a1 a2 a3 a4) = do+        putByte bh 6+        putIfaceTopBndr bh a1+        put_ bh a2+        put_ bh a3+        put_ bh a4++    put_ bh (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do+        putByte bh 7+        putIfaceTopBndr bh a1+        put_ bh a2+        put_ bh a3+        put_ bh a4+        put_ bh a5+        put_ bh a6+        put_ bh a7+        put_ bh a8+        put_ bh a9+        put_ bh a10+        put_ bh a11++    put_ bh (IfaceClass {+                ifName    = a1,+                ifRoles   = a2,+                ifBinders = a3,+                ifFDs     = a4,+                ifBody = IfAbstractClass }) = do+        putByte bh 8+        putIfaceTopBndr bh a1+        put_ bh a2+        put_ bh a3+        put_ bh a4++    get bh = do+        h <- getByte bh+        case h of+            0 -> do name    <- get bh+                    ~(ty, details, idinfo) <- lazyGet bh+                    -- See Note [Lazy deserialization of IfaceId]+                    return (IfaceId name ty details idinfo)+            1 -> error "Binary.get(TyClDecl): ForeignType"+            2 -> do a1  <- getIfaceTopBndr bh+                    a2  <- get bh+                    a3  <- get bh+                    a4  <- get bh+                    a5  <- get bh+                    a6  <- get bh+                    a7  <- get bh+                    a8  <- get bh+                    a9  <- get bh+                    return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9)+            3 -> do a1 <- getIfaceTopBndr bh+                    a2 <- get bh+                    a3 <- get bh+                    a4 <- get bh+                    a5 <- get bh+                    return (IfaceSynonym a1 a2 a3 a4 a5)+            4 -> do a1 <- getIfaceTopBndr bh+                    a2 <- get bh+                    a3 <- get bh+                    a4 <- get bh+                    a5 <- get bh+                    a6 <- get bh+                    return (IfaceFamily a1 a2 a3 a4 a5 a6)+            5 -> do a1 <- get bh+                    a2 <- getIfaceTopBndr bh+                    a3 <- get bh+                    a4 <- get bh+                    a5 <- get bh+                    a6 <- get bh+                    a7 <- get bh+                    a8 <- get bh+                    return (IfaceClass {+                        ifName    = a2,+                        ifRoles   = a3,+                        ifBinders = a4,+                        ifFDs     = a5,+                        ifBody = IfConcreteClass {+                            ifClassCtxt = a1,+                            ifATs  = a6,+                            ifSigs = a7,+                            ifMinDef  = a8+                        }})+            6 -> do a1 <- getIfaceTopBndr bh+                    a2 <- get bh+                    a3 <- get bh+                    a4 <- get bh+                    return (IfaceAxiom a1 a2 a3 a4)+            7 -> do a1 <- getIfaceTopBndr bh+                    a2 <- get bh+                    a3 <- get bh+                    a4 <- get bh+                    a5 <- get bh+                    a6 <- get bh+                    a7 <- get bh+                    a8 <- get bh+                    a9 <- get bh+                    a10 <- get bh+                    a11 <- get bh+                    return (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11)+            8 -> do a1 <- getIfaceTopBndr bh+                    a2 <- get bh+                    a3 <- get bh+                    a4 <- get bh+                    return (IfaceClass {+                        ifName    = a1,+                        ifRoles   = a2,+                        ifBinders = a3,+                        ifFDs     = a4,+                        ifBody = IfAbstractClass })+            _ -> panic (unwords ["Unknown IfaceDecl tag:", show h])++{- Note [Lazy deserialization of IfaceId]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The use of lazyPut and lazyGet in the IfaceId Binary instance is+purely for performance reasons, to avoid deserializing details about+identifiers that will never be used. It's not involved in tying the+knot in the type checker. It saved ~1% of the total build time of GHC.++When we read an interface file, we extend the PTE, a mapping of Names+to TyThings, with the declarations we have read. The extension of the+PTE is strict in the Names, but not in the TyThings themselves.+LoadIface.loadDecl calculates the list of (Name, TyThing) bindings to+add to the PTE. For an IfaceId, there's just one binding to add; and+the ty, details, and idinfo fields of an IfaceId are used only in the+TyThing. So by reading those fields lazily we may be able to save the+work of ever having to deserialize them (into IfaceType, etc.).++For IfaceData and IfaceClass, loadDecl creates extra implicit bindings+(the constructors and field selectors of the data declaration, or the+methods of the class), whose Names depend on more than just the Name+of the type constructor or class itself. So deserializing them lazily+would be more involved. Similar comments apply to the other+constructors of IfaceDecl with the additional point that they probably+represent a small proportion of all declarations.+-}++instance Binary IfaceFamTyConFlav where+    put_ bh IfaceDataFamilyTyCon              = putByte bh 0+    put_ bh IfaceOpenSynFamilyTyCon           = putByte bh 1+    put_ bh (IfaceClosedSynFamilyTyCon mb)    = putByte bh 2 >> put_ bh mb+    put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 3+    put_ _ IfaceBuiltInSynFamTyCon+        = pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" Outputable.empty++    get bh = do { h <- getByte bh+                ; case h of+                    0 -> return IfaceDataFamilyTyCon+                    1 -> return IfaceOpenSynFamilyTyCon+                    2 -> do { mb <- get bh+                            ; return (IfaceClosedSynFamilyTyCon mb) }+                    3 -> return IfaceAbstractClosedSynFamilyTyCon+                    _ -> pprPanic "Binary.get(IfaceFamTyConFlav): Invalid tag"+                                  (ppr (fromIntegral h :: Int)) }++instance Binary IfaceClassOp where+    put_ bh (IfaceClassOp n ty def) = do+        putIfaceTopBndr bh n+        put_ bh ty+        put_ bh def+    get bh = do+        n   <- getIfaceTopBndr bh+        ty  <- get bh+        def <- get bh+        return (IfaceClassOp n ty def)++instance Binary IfaceAT where+    put_ bh (IfaceAT dec defs) = do+        put_ bh dec+        put_ bh defs+    get bh = do+        dec  <- get bh+        defs <- get bh+        return (IfaceAT dec defs)++instance Binary IfaceAxBranch where+    put_ bh (IfaceAxBranch a1 a2 a3 a4 a5 a6) = do+        put_ bh a1+        put_ bh a2+        put_ bh a3+        put_ bh a4+        put_ bh a5+        put_ bh a6+    get bh = do+        a1 <- get bh+        a2 <- get bh+        a3 <- get bh+        a4 <- get bh+        a5 <- get bh+        a6 <- get bh+        return (IfaceAxBranch a1 a2 a3 a4 a5 a6)++instance Binary IfaceConDecls where+    put_ bh IfAbstractTyCon  = putByte bh 0+    put_ bh (IfDataTyCon cs) = putByte bh 1 >> put_ bh cs+    put_ bh (IfNewTyCon c)   = putByte bh 2 >> put_ bh c+    get bh = do+        h <- getByte bh+        case h of+            0 -> return IfAbstractTyCon+            1 -> liftM IfDataTyCon (get bh)+            2 -> liftM IfNewTyCon (get bh)+            _ -> error "Binary(IfaceConDecls).get: Invalid IfaceConDecls"++instance Binary IfaceConDecl where+    put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do+        putIfaceTopBndr bh a1+        put_ bh a2+        put_ bh a3+        put_ bh a4+        put_ bh a5+        put_ bh a6+        put_ bh a7+        put_ bh (length a8)+        mapM_ (put_ bh) a8+        put_ bh a9+        put_ bh a10+    get bh = do+        a1 <- getIfaceTopBndr bh+        a2 <- get bh+        a3 <- get bh+        a4 <- get bh+        a5 <- get bh+        a6 <- get bh+        a7 <- get bh+        n_fields <- get bh+        a8 <- replicateM n_fields (get bh)+        a9 <- get bh+        a10 <- get bh+        return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)++instance Binary IfaceBang where+    put_ bh IfNoBang        = putByte bh 0+    put_ bh IfStrict        = putByte bh 1+    put_ bh IfUnpack        = putByte bh 2+    put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co++    get bh = do+            h <- getByte bh+            case h of+              0 -> do return IfNoBang+              1 -> do return IfStrict+              2 -> do return IfUnpack+              _ -> do { a <- get bh; return (IfUnpackCo a) }++instance Binary IfaceSrcBang where+    put_ bh (IfSrcBang a1 a2) =+      do put_ bh a1+         put_ bh a2++    get bh =+      do a1 <- get bh+         a2 <- get bh+         return (IfSrcBang a1 a2)++instance Binary IfaceClsInst where+    put_ bh (IfaceClsInst cls tys dfun flag orph) = do+        put_ bh cls+        put_ bh tys+        put_ bh dfun+        put_ bh flag+        put_ bh orph+    get bh = do+        cls  <- get bh+        tys  <- get bh+        dfun <- get bh+        flag <- get bh+        orph <- get bh+        return (IfaceClsInst cls tys dfun flag orph)++instance Binary IfaceFamInst where+    put_ bh (IfaceFamInst fam tys name orph) = do+        put_ bh fam+        put_ bh tys+        put_ bh name+        put_ bh orph+    get bh = do+        fam      <- get bh+        tys      <- get bh+        name     <- get bh+        orph     <- get bh+        return (IfaceFamInst fam tys name orph)++instance Binary IfaceRule where+    put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do+        put_ bh a1+        put_ bh a2+        put_ bh a3+        put_ bh a4+        put_ bh a5+        put_ bh a6+        put_ bh a7+        put_ bh a8+    get bh = do+        a1 <- get bh+        a2 <- get bh+        a3 <- get bh+        a4 <- get bh+        a5 <- get bh+        a6 <- get bh+        a7 <- get bh+        a8 <- get bh+        return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8)++instance Binary IfaceAnnotation where+    put_ bh (IfaceAnnotation a1 a2) = do+        put_ bh a1+        put_ bh a2+    get bh = do+        a1 <- get bh+        a2 <- get bh+        return (IfaceAnnotation a1 a2)++instance Binary IfaceIdDetails where+    put_ bh IfVanillaId      = putByte bh 0+    put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b+    put_ bh IfDFunId         = putByte bh 2+    get bh = do+        h <- getByte bh+        case h of+            0 -> return IfVanillaId+            1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) }+            _ -> return IfDFunId++instance Binary IfaceIdInfo where+    put_ bh NoInfo      = putByte bh 0+    put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut++    get bh = do+        h <- getByte bh+        case h of+            0 -> return NoInfo+            _ -> liftM HasInfo $ lazyGet bh    -- NB lazyGet++instance Binary IfaceInfoItem where+    put_ bh (HsArity aa)          = putByte bh 0 >> put_ bh aa+    put_ bh (HsStrictness ab)     = putByte bh 1 >> put_ bh ab+    put_ bh (HsUnfold lb ad)      = putByte bh 2 >> put_ bh lb >> put_ bh ad+    put_ bh (HsInline ad)         = putByte bh 3 >> put_ bh ad+    put_ bh HsNoCafRefs           = putByte bh 4+    put_ bh HsLevity              = putByte bh 5+    get bh = do+        h <- getByte bh+        case h of+            0 -> liftM HsArity $ get bh+            1 -> liftM HsStrictness $ get bh+            2 -> do lb <- get bh+                    ad <- get bh+                    return (HsUnfold lb ad)+            3 -> liftM HsInline $ get bh+            4 -> return HsNoCafRefs+            _ -> return HsLevity++instance Binary IfaceUnfolding where+    put_ bh (IfCoreUnfold s e) = do+        putByte bh 0+        put_ bh s+        put_ bh e+    put_ bh (IfInlineRule a b c d) = do+        putByte bh 1+        put_ bh a+        put_ bh b+        put_ bh c+        put_ bh d+    put_ bh (IfDFunUnfold as bs) = do+        putByte bh 2+        put_ bh as+        put_ bh bs+    put_ bh (IfCompulsory e) = do+        putByte bh 3+        put_ bh e+    get bh = do+        h <- getByte bh+        case h of+            0 -> do s <- get bh+                    e <- get bh+                    return (IfCoreUnfold s e)+            1 -> do a <- get bh+                    b <- get bh+                    c <- get bh+                    d <- get bh+                    return (IfInlineRule a b c d)+            2 -> do as <- get bh+                    bs <- get bh+                    return (IfDFunUnfold as bs)+            _ -> do e <- get bh+                    return (IfCompulsory e)+++instance Binary IfaceExpr where+    put_ bh (IfaceLcl aa) = do+        putByte bh 0+        put_ bh aa+    put_ bh (IfaceType ab) = do+        putByte bh 1+        put_ bh ab+    put_ bh (IfaceCo ab) = do+        putByte bh 2+        put_ bh ab+    put_ bh (IfaceTuple ac ad) = do+        putByte bh 3+        put_ bh ac+        put_ bh ad+    put_ bh (IfaceLam (ae, os) af) = do+        putByte bh 4+        put_ bh ae+        put_ bh os+        put_ bh af+    put_ bh (IfaceApp ag ah) = do+        putByte bh 5+        put_ bh ag+        put_ bh ah+    put_ bh (IfaceCase ai aj ak) = do+        putByte bh 6+        put_ bh ai+        put_ bh aj+        put_ bh ak+    put_ bh (IfaceLet al am) = do+        putByte bh 7+        put_ bh al+        put_ bh am+    put_ bh (IfaceTick an ao) = do+        putByte bh 8+        put_ bh an+        put_ bh ao+    put_ bh (IfaceLit ap) = do+        putByte bh 9+        put_ bh ap+    put_ bh (IfaceFCall as at) = do+        putByte bh 10+        put_ bh as+        put_ bh at+    put_ bh (IfaceExt aa) = do+        putByte bh 11+        put_ bh aa+    put_ bh (IfaceCast ie ico) = do+        putByte bh 12+        put_ bh ie+        put_ bh ico+    put_ bh (IfaceECase a b) = do+        putByte bh 13+        put_ bh a+        put_ bh b+    get bh = do+        h <- getByte bh+        case h of+            0 -> do aa <- get bh+                    return (IfaceLcl aa)+            1 -> do ab <- get bh+                    return (IfaceType ab)+            2 -> do ab <- get bh+                    return (IfaceCo ab)+            3 -> do ac <- get bh+                    ad <- get bh+                    return (IfaceTuple ac ad)+            4 -> do ae <- get bh+                    os <- get bh+                    af <- get bh+                    return (IfaceLam (ae, os) af)+            5 -> do ag <- get bh+                    ah <- get bh+                    return (IfaceApp ag ah)+            6 -> do ai <- get bh+                    aj <- get bh+                    ak <- get bh+                    return (IfaceCase ai aj ak)+            7 -> do al <- get bh+                    am <- get bh+                    return (IfaceLet al am)+            8 -> do an <- get bh+                    ao <- get bh+                    return (IfaceTick an ao)+            9 -> do ap <- get bh+                    return (IfaceLit ap)+            10 -> do as <- get bh+                     at <- get bh+                     return (IfaceFCall as at)+            11 -> do aa <- get bh+                     return (IfaceExt aa)+            12 -> do ie <- get bh+                     ico <- get bh+                     return (IfaceCast ie ico)+            13 -> do a <- get bh+                     b <- get bh+                     return (IfaceECase a b)+            _ -> panic ("get IfaceExpr " ++ show h)++instance Binary IfaceTickish where+    put_ bh (IfaceHpcTick m ix) = do+        putByte bh 0+        put_ bh m+        put_ bh ix+    put_ bh (IfaceSCC cc tick push) = do+        putByte bh 1+        put_ bh cc+        put_ bh tick+        put_ bh push+    put_ bh (IfaceSource src name) = do+        putByte bh 2+        put_ bh (srcSpanFile src)+        put_ bh (srcSpanStartLine src)+        put_ bh (srcSpanStartCol src)+        put_ bh (srcSpanEndLine src)+        put_ bh (srcSpanEndCol src)+        put_ bh name++    get bh = do+        h <- getByte bh+        case h of+            0 -> do m <- get bh+                    ix <- get bh+                    return (IfaceHpcTick m ix)+            1 -> do cc <- get bh+                    tick <- get bh+                    push <- get bh+                    return (IfaceSCC cc tick push)+            2 -> do file <- get bh+                    sl <- get bh+                    sc <- get bh+                    el <- get bh+                    ec <- get bh+                    let start = mkRealSrcLoc file sl sc+                        end = mkRealSrcLoc file el ec+                    name <- get bh+                    return (IfaceSource (mkRealSrcSpan start end) name)+            _ -> panic ("get IfaceTickish " ++ show h)++instance Binary IfaceConAlt where+    put_ bh IfaceDefault      = putByte bh 0+    put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa+    put_ bh (IfaceLitAlt ac)  = putByte bh 2 >> put_ bh ac+    get bh = do+        h <- getByte bh+        case h of+            0 -> return IfaceDefault+            1 -> liftM IfaceDataAlt $ get bh+            _ -> liftM IfaceLitAlt  $ get bh++instance Binary IfaceBinding where+    put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab+    put_ bh (IfaceRec ac)       = putByte bh 1 >> put_ bh ac+    get bh = do+        h <- getByte bh+        case h of+            0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) }+            _ -> do { ac <- get bh; return (IfaceRec ac) }++instance Binary IfaceLetBndr where+    put_ bh (IfLetBndr a b c d) = do+            put_ bh a+            put_ bh b+            put_ bh c+            put_ bh d+    get bh = do a <- get bh+                b <- get bh+                c <- get bh+                d <- get bh+                return (IfLetBndr a b c d)++instance Binary IfaceJoinInfo where+    put_ bh IfaceNotJoinPoint = putByte bh 0+    put_ bh (IfaceJoinPoint ar) = do+        putByte bh 1+        put_ bh ar+    get bh = do+        h <- getByte bh+        case h of+            0 -> return IfaceNotJoinPoint+            _ -> liftM IfaceJoinPoint $ get bh++instance Binary IfaceTyConParent where+    put_ bh IfNoParent = putByte bh 0+    put_ bh (IfDataInstance ax pr ty) = do+        putByte bh 1+        put_ bh ax+        put_ bh pr+        put_ bh ty+    get bh = do+        h <- getByte bh+        case h of+            0 -> return IfNoParent+            _ -> do+                ax <- get bh+                pr <- get bh+                ty <- get bh+                return $ IfDataInstance ax pr ty++instance Binary IfaceCompleteMatch where+  put_ bh (IfaceCompleteMatch cs ts) = put_ bh cs >> put_ bh ts+  get bh = IfaceCompleteMatch <$> get bh <*> get bh
+ iface/IfaceType.hs view
@@ -0,0 +1,1552 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998+++This module defines interface types and binders+-}++{-# LANGUAGE CPP, FlexibleInstances, BangPatterns #-}+{-# LANGUAGE MultiWayIf #-}+    -- FlexibleInstances for Binary (DefMethSpec IfaceType)++module IfaceType (+        IfExtName, IfLclName,++        IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..),+        IfaceUnivCoProv(..),+        IfaceTyCon(..), IfaceTyConInfo(..), IfaceTyConSort(..), IsPromoted(..),+        IfaceTyLit(..), IfaceTcArgs(..),+        IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr,+        IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder,+        IfaceForAllBndr, ArgFlag(..), ShowForAllFlag(..),++        ifTyConBinderTyVar, ifTyConBinderName,++        -- Equality testing+        IfRnEnv2, emptyIfRnEnv2, eqIfaceType, eqIfaceTypes,+        eqIfaceTcArgs, eqIfaceTvBndrs, isIfaceLiftedTypeKind,++        -- Conversion from IfaceTcArgs -> [IfaceType]+        tcArgsIfaceTypes,++        -- Printing+        pprIfaceType, pprParendIfaceType,+        pprIfaceContext, pprIfaceContextArr,+        pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders,+        pprIfaceBndrs, pprIfaceTcArgs, pprParendIfaceTcArgs,+        pprIfaceForAllPart, pprIfaceForAll, pprIfaceSigmaType,+        pprIfaceTyLit,+        pprIfaceCoercion, pprParendIfaceCoercion,+        splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll,+        pprIfaceCoTcApp, pprTyTcApp, pprIfacePrefixApp,++        suppressIfaceInvisibles,+        stripIfaceInvisVars,+        stripInvisArgs,+        substIfaceType, substIfaceTyVar, substIfaceTcArgs, mkIfaceTySubst,+        eqIfaceTvBndr+    ) where++#include "HsVersions.h"++import {-# SOURCE #-} TysWiredIn ( liftedRepDataConTyCon )++import DynFlags+import TyCon hiding ( pprPromotionQuote )+import CoAxiom+import Var+import PrelNames+import Name+import BasicTypes+import Binary+import Outputable+import FastString+import FastStringEnv+import UniqFM+import Util++import Data.List (foldl')++{-+************************************************************************+*                                                                      *+                Local (nested) binders+*                                                                      *+************************************************************************+-}++type IfLclName = FastString     -- A local name in iface syntax++type IfExtName = Name   -- An External or WiredIn Name can appear in IfaceSyn+                        -- (However Internal or System Names never should)++data IfaceBndr          -- Local (non-top-level) binders+  = IfaceIdBndr {-# UNPACK #-} !IfaceIdBndr+  | IfaceTvBndr {-# UNPACK #-} !IfaceTvBndr++type IfaceIdBndr  = (IfLclName, IfaceType)+type IfaceTvBndr  = (IfLclName, IfaceKind)++ifaceTvBndrName :: IfaceTvBndr -> IfLclName+ifaceTvBndrName (n,_) = n++type IfaceLamBndr = (IfaceBndr, IfaceOneShot)++data IfaceOneShot    -- See Note [Preserve OneShotInfo] in CoreTicy+  = IfaceNoOneShot   -- and Note [The oneShot function] in MkId+  | IfaceOneShot+++{-+%************************************************************************+%*                                                                      *+                IfaceType+%*                                                                      *+%************************************************************************+-}++-------------------------------+type IfaceKind     = IfaceType++data IfaceType     -- A kind of universal type, used for types and kinds+  = IfaceFreeTyVar TyVar                 -- See Note [Free tyvars in IfaceType]+  | IfaceTyVar     IfLclName            -- Type/coercion variable only, not tycon+  | IfaceLitTy     IfaceTyLit+  | IfaceAppTy     IfaceType IfaceType+  | IfaceFunTy     IfaceType IfaceType+  | IfaceDFunTy    IfaceType IfaceType+  | IfaceForAllTy  IfaceForAllBndr IfaceType+  | IfaceTyConApp  IfaceTyCon IfaceTcArgs  -- Not necessarily saturated+                                           -- Includes newtypes, synonyms, tuples+  | IfaceCastTy     IfaceType IfaceCoercion+  | IfaceCoercionTy IfaceCoercion++  | IfaceTupleTy                  -- Saturated tuples (unsaturated ones use IfaceTyConApp)+       TupleSort                  -- What sort of tuple?+       IsPromoted                 -- A bit like IfaceTyCon+       IfaceTcArgs                -- arity = length args+          -- For promoted data cons, the kind args are omitted++type IfacePredType = IfaceType+type IfaceContext = [IfacePredType]++data IfaceTyLit+  = IfaceNumTyLit Integer+  | IfaceStrTyLit FastString+  deriving (Eq)++type IfaceTyConBinder = TyVarBndr IfaceTvBndr TyConBndrVis+type IfaceForAllBndr  = TyVarBndr IfaceTvBndr ArgFlag++-- See Note [Suppressing invisible arguments]+-- We use a new list type (rather than [(IfaceType,Bool)], because+-- it'll be more compact and faster to parse in interface+-- files. Rather than two bytes and two decisions (nil/cons, and+-- type/kind) there'll just be one.+data IfaceTcArgs+  = ITC_Nil+  | ITC_Vis   IfaceType IfaceTcArgs   -- "Vis" means show when pretty-printing+  | ITC_Invis IfaceKind IfaceTcArgs   -- "Invis" means don't show when pretty-printing+                                      --         except with -fprint-explicit-kinds++instance Monoid IfaceTcArgs where+  mempty = ITC_Nil+  ITC_Nil `mappend` xs           = xs+  ITC_Vis ty rest `mappend` xs   = ITC_Vis ty (rest `mappend` xs)+  ITC_Invis ki rest `mappend` xs = ITC_Invis ki (rest `mappend` xs)++-- Encodes type constructors, kind constructors,+-- coercion constructors, the lot.+-- We have to tag them in order to pretty print them+-- properly.+data IfaceTyCon = IfaceTyCon { ifaceTyConName :: IfExtName+                             , ifaceTyConInfo :: IfaceTyConInfo }+    deriving (Eq)++-- | Is a TyCon a promoted data constructor or just a normal type constructor?+data IsPromoted = IsNotPromoted | IsPromoted+    deriving (Eq)++-- | The various types of TyCons which have special, built-in syntax.+data IfaceTyConSort = IfaceNormalTyCon          -- ^ a regular tycon++                    | IfaceTupleTyCon !Arity !TupleSort+                      -- ^ e.g. @(a, b, c)@ or @(#a, b, c#)@.+                      -- The arity is the tuple width, not the tycon arity+                      -- (which is twice the width in the case of unboxed+                      -- tuples).++                    | IfaceSumTyCon !Arity+                      -- ^ e.g. @(a | b | c)@++                    | IfaceEqualityTyCon !Bool+                      -- ^ a type equality. 'True' indicates kind-homogeneous.+                      -- See Note [Equality predicates in IfaceType] for+                      -- details.+                    deriving (Eq)++{- Note [Free tyvars in IfaceType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Nowadays (since Nov 16, 2016) we pretty-print a Type by converting to an+IfaceType and pretty printing that.  This eliminates a lot of+pretty-print duplication, and it matches what we do with+pretty-printing TyThings.++It works fine for closed types, but when printing debug traces (e.g.+when using -ddump-tc-trace) we print a lot of /open/ types.  These+types are full of TcTyVars, and it's absolutely crucial to print them+in their full glory, with their unique, TcTyVarDetails etc.++So we simply embed a TyVar in IfaceType with the IfaceFreeTyVar constructor.+Note that:++* We never expect to serialise an IfaceFreeTyVar into an interface file, nor+  to deserialise one.  IfaceFreeTyVar is used only in the "convert to IfaceType+  and then pretty-print" pipeline.+++Note [Equality predicates in IfaceType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC has several varieties of type equality (see Note [The equality types story]+in TysPrim for details) which all must be rendered with different surface syntax+during pretty-printing. Which syntax we use depends upon,++ 1. Which predicate tycon was used+ 2. Whether the types being compared are of the same kind.++Unfortunately, determining (2) from an IfaceType isn't possible since we can't+see through type synonyms. Consequently, we need to record whether the equality+is homogeneous or not in IfaceTyConSort for the purposes of pretty-printing.++Namely we handle these cases,++    Predicate               Homogeneous        Heterogeneous+    ----------------        -----------        -------------+    eqTyCon                 ~                  N/A+    heqTyCon                ~                  ~~+    eqPrimTyCon             ~#                 ~~+    eqReprPrimTyCon         Coercible          Coercible++-}++data IfaceTyConInfo   -- Used to guide pretty-printing+                      -- and to disambiguate D from 'D (they share a name)+  = IfaceTyConInfo { ifaceTyConIsPromoted :: IsPromoted+                   , ifaceTyConSort       :: IfaceTyConSort }+    deriving (Eq)++data IfaceCoercion+  = IfaceReflCo       Role IfaceType+  | IfaceFunCo        Role IfaceCoercion IfaceCoercion+  | IfaceTyConAppCo   Role IfaceTyCon [IfaceCoercion]+  | IfaceAppCo        IfaceCoercion IfaceCoercion+  | IfaceForAllCo     IfaceTvBndr IfaceCoercion IfaceCoercion+  | IfaceCoVarCo      IfLclName+  | IfaceAxiomInstCo  IfExtName BranchIndex [IfaceCoercion]+  | IfaceUnivCo       IfaceUnivCoProv Role IfaceType IfaceType+  | IfaceSymCo        IfaceCoercion+  | IfaceTransCo      IfaceCoercion IfaceCoercion+  | IfaceNthCo        Int IfaceCoercion+  | IfaceLRCo         LeftOrRight IfaceCoercion+  | IfaceInstCo       IfaceCoercion IfaceCoercion+  | IfaceCoherenceCo  IfaceCoercion IfaceCoercion+  | IfaceKindCo       IfaceCoercion+  | IfaceSubCo        IfaceCoercion+  | IfaceAxiomRuleCo  IfLclName [IfaceCoercion]++data IfaceUnivCoProv+  = IfaceUnsafeCoerceProv+  | IfacePhantomProv IfaceCoercion+  | IfaceProofIrrelProv IfaceCoercion+  | IfacePluginProv String+  | IfaceHoleProv Unique+    -- ^ See Note [Holes in IfaceUnivCoProv]++{-+Note [Holes in IfaceUnivCoProv]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When typechecking fails the typechecker will produce a HoleProv UnivCoProv to+stand in place of the unproven assertion. While we generally don't want to let+these unproven assertions leak into interface files, we still need to be able to+pretty-print them as we use IfaceType's pretty-printer to render Types. For this+reason IfaceUnivCoProv has a IfaceHoleProv constructor; however, we fails when+asked to serialize to a IfaceHoleProv to ensure that they don't end up in an+interface file. To avoid an import loop between IfaceType and TyCoRep we only+keep the hole's Unique, since that is all we need to print.+-}++{-+%************************************************************************+%*                                                                      *+                Functions over IFaceTypes+*                                                                      *+************************************************************************+-}++ifaceTyConHasKey :: IfaceTyCon -> Unique -> Bool+ifaceTyConHasKey tc key = ifaceTyConName tc `hasKey` key++eqIfaceTvBndr :: IfaceTvBndr -> IfaceTvBndr -> Bool+eqIfaceTvBndr (occ1, _) (occ2, _) = occ1 == occ2++isIfaceLiftedTypeKind :: IfaceKind -> Bool+isIfaceLiftedTypeKind (IfaceTyConApp tc ITC_Nil)+  = isLiftedTypeKindTyConName (ifaceTyConName tc)+isIfaceLiftedTypeKind (IfaceTyConApp tc+                       (ITC_Vis (IfaceTyConApp ptr_rep_lifted ITC_Nil) ITC_Nil))+  =  tc `ifaceTyConHasKey` tYPETyConKey+  && ptr_rep_lifted `ifaceTyConHasKey` liftedRepDataConKey+isIfaceLiftedTypeKind _ = False++splitIfaceSigmaTy :: IfaceType -> ([IfaceForAllBndr], [IfacePredType], IfaceType)+-- Mainly for printing purposes+splitIfaceSigmaTy ty+  = (bndrs, theta, tau)+  where+    (bndrs, rho)   = split_foralls ty+    (theta, tau)   = split_rho rho++    split_foralls (IfaceForAllTy bndr ty)+        = case split_foralls ty of { (bndrs, rho) -> (bndr:bndrs, rho) }+    split_foralls rho = ([], rho)++    split_rho (IfaceDFunTy ty1 ty2)+        = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) }+    split_rho tau = ([], tau)++suppressIfaceInvisibles :: DynFlags -> [IfaceTyConBinder] -> [a] -> [a]+suppressIfaceInvisibles dflags tys xs+  | gopt Opt_PrintExplicitKinds dflags = xs+  | otherwise = suppress tys xs+    where+      suppress _       []      = []+      suppress []      a       = a+      suppress (k:ks) a@(_:xs)+        | isInvisibleTyConBinder k = suppress ks xs+        | otherwise                = a++stripIfaceInvisVars :: DynFlags -> [IfaceTyConBinder] -> [IfaceTyConBinder]+stripIfaceInvisVars dflags tyvars+  | gopt Opt_PrintExplicitKinds dflags = tyvars+  | otherwise = filterOut isInvisibleTyConBinder tyvars++-- | Extract a IfaceTvBndr from a IfaceTyConBinder+ifTyConBinderTyVar :: IfaceTyConBinder -> IfaceTvBndr+ifTyConBinderTyVar = binderVar++-- | Extract the variable name from a IfaceTyConBinder+ifTyConBinderName :: IfaceTyConBinder -> IfLclName+ifTyConBinderName tcb = ifaceTvBndrName (ifTyConBinderTyVar tcb)++ifTypeIsVarFree :: IfaceType -> Bool+-- Returns True if the type definitely has no variables at all+-- Just used to control pretty printing+ifTypeIsVarFree ty = go ty+  where+    go (IfaceTyVar {})         = False+    go (IfaceFreeTyVar {})     = False+    go (IfaceAppTy fun arg)    = go fun && go arg+    go (IfaceFunTy arg res)    = go arg && go res+    go (IfaceDFunTy arg res)   = go arg && go res+    go (IfaceForAllTy {})      = False+    go (IfaceTyConApp _ args)  = go_args args+    go (IfaceTupleTy _ _ args) = go_args args+    go (IfaceLitTy _)          = True+    go (IfaceCastTy {})        = False -- Safe+    go (IfaceCoercionTy {})    = False -- Safe++    go_args ITC_Nil = True+    go_args (ITC_Vis   arg args) = go arg && go_args args+    go_args (ITC_Invis arg args) = go arg && go_args args++{-+Substitutions on IfaceType. This is only used during pretty-printing to construct+the result type of a GADT, and does not deal with binders (eg IfaceForAll), so+it doesn't need fancy capture stuff.+-}++type IfaceTySubst = FastStringEnv IfaceType++mkIfaceTySubst :: [IfaceTvBndr] -> [IfaceType] -> IfaceTySubst+mkIfaceTySubst tvs tys = mkFsEnv $ zipWithEqual "mkIfaceTySubst" (\(fs,_) ty -> (fs,ty)) tvs tys++substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType+substIfaceType env ty+  = go ty+  where+    go (IfaceFreeTyVar tv)    = IfaceFreeTyVar tv+    go (IfaceTyVar tv)        = substIfaceTyVar env tv+    go (IfaceAppTy  t1 t2)    = IfaceAppTy  (go t1) (go t2)+    go (IfaceFunTy  t1 t2)    = IfaceFunTy  (go t1) (go t2)+    go (IfaceDFunTy t1 t2)    = IfaceDFunTy (go t1) (go t2)+    go ty@(IfaceLitTy {})     = ty+    go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceTcArgs env tys)+    go (IfaceTupleTy s i tys) = IfaceTupleTy s i (substIfaceTcArgs env tys)+    go (IfaceForAllTy {})     = pprPanic "substIfaceType" (ppr ty)+    go (IfaceCastTy ty co)    = IfaceCastTy (go ty) (go_co co)+    go (IfaceCoercionTy co)   = IfaceCoercionTy (go_co co)++    go_co (IfaceReflCo r ty)     = IfaceReflCo r (go ty)+    go_co (IfaceFunCo r c1 c2)   = IfaceFunCo r (go_co c1) (go_co c2)+    go_co (IfaceTyConAppCo r tc cos) = IfaceTyConAppCo r tc (go_cos cos)+    go_co (IfaceAppCo c1 c2)         = IfaceAppCo (go_co c1) (go_co c2)+    go_co (IfaceForAllCo {})         = pprPanic "substIfaceCoercion" (ppr ty)+    go_co (IfaceCoVarCo cv)          = IfaceCoVarCo cv+    go_co (IfaceAxiomInstCo a i cos) = IfaceAxiomInstCo a i (go_cos cos)+    go_co (IfaceUnivCo prov r t1 t2) = IfaceUnivCo (go_prov prov) r (go t1) (go t2)+    go_co (IfaceSymCo co)            = IfaceSymCo (go_co co)+    go_co (IfaceTransCo co1 co2)     = IfaceTransCo (go_co co1) (go_co co2)+    go_co (IfaceNthCo n co)          = IfaceNthCo n (go_co co)+    go_co (IfaceLRCo lr co)          = IfaceLRCo lr (go_co co)+    go_co (IfaceInstCo c1 c2)        = IfaceInstCo (go_co c1) (go_co c2)+    go_co (IfaceCoherenceCo c1 c2)   = IfaceCoherenceCo (go_co c1) (go_co c2)+    go_co (IfaceKindCo co)           = IfaceKindCo (go_co co)+    go_co (IfaceSubCo co)            = IfaceSubCo (go_co co)+    go_co (IfaceAxiomRuleCo n cos)   = IfaceAxiomRuleCo n (go_cos cos)++    go_cos = map go_co++    go_prov IfaceUnsafeCoerceProv    = IfaceUnsafeCoerceProv+    go_prov (IfacePhantomProv co)    = IfacePhantomProv (go_co co)+    go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co)+    go_prov (IfacePluginProv str)    = IfacePluginProv str+    go_prov (IfaceHoleProv h)        = IfaceHoleProv h++substIfaceTcArgs :: IfaceTySubst -> IfaceTcArgs -> IfaceTcArgs+substIfaceTcArgs env args+  = go args+  where+    go ITC_Nil            = ITC_Nil+    go (ITC_Vis ty tys)   = ITC_Vis   (substIfaceType env ty) (go tys)+    go (ITC_Invis ty tys) = ITC_Invis (substIfaceType env ty) (go tys)++substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType+substIfaceTyVar env tv+  | Just ty <- lookupFsEnv env tv = ty+  | otherwise                     = IfaceTyVar tv++{-+************************************************************************+*                                                                      *+                Equality over IfaceTypes+*                                                                      *+************************************************************************++Note [No kind check in ifaces]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We check iface types for equality only when checking the consistency+between two user-written signatures. In these cases, there is no possibility+for a kind mismatch. So we omit the kind check (which would be impossible to+write, anyway.)++-}++-- Like an RnEnv2, but mapping from FastString to deBruijn index+-- DeBruijn; see eqTypeX+type BoundVar = Int+data IfRnEnv2+  = IRV2 { ifenvL :: UniqFM BoundVar -- from FastString+         , ifenvR :: UniqFM BoundVar+         , ifenv_next :: BoundVar+         }++emptyIfRnEnv2 :: IfRnEnv2+emptyIfRnEnv2 = IRV2 { ifenvL = emptyUFM+                     , ifenvR = emptyUFM+                     , ifenv_next = 0 }++rnIfOccL :: IfRnEnv2 -> IfLclName -> Maybe BoundVar+rnIfOccL env = lookupUFM (ifenvL env)++rnIfOccR :: IfRnEnv2 -> IfLclName -> Maybe BoundVar+rnIfOccR env = lookupUFM (ifenvR env)++extendIfRnEnv2 :: IfRnEnv2 -> IfLclName -> IfLclName -> IfRnEnv2+extendIfRnEnv2 IRV2 { ifenvL = lenv+                    , ifenvR = renv+                    , ifenv_next = n } tv1 tv2+             = IRV2 { ifenvL = addToUFM lenv tv1 n+                    , ifenvR = addToUFM renv tv2 n+                    , ifenv_next = n + 1+                    }++-- See Note [No kind check in ifaces]+eqIfaceType :: IfRnEnv2 -> IfaceType -> IfaceType -> Bool+eqIfaceType _ (IfaceFreeTyVar tv1) (IfaceFreeTyVar tv2)+    = tv1 == tv2   -- Should not happen+eqIfaceType env (IfaceTyVar tv1) (IfaceTyVar tv2) =+    case (rnIfOccL env tv1, rnIfOccR env tv2) of+        (Just v1, Just v2) -> v1 == v2+        (Nothing, Nothing) -> tv1 == tv2+        _ -> False+eqIfaceType _   (IfaceLitTy l1) (IfaceLitTy l2) = l1 == l2+eqIfaceType env (IfaceAppTy t11 t12) (IfaceAppTy t21 t22)+    = eqIfaceType env t11 t21 && eqIfaceType env t12 t22+eqIfaceType env (IfaceFunTy t11 t12) (IfaceFunTy t21 t22)+    = eqIfaceType env t11 t21 && eqIfaceType env t12 t22+eqIfaceType env (IfaceDFunTy t11 t12) (IfaceDFunTy t21 t22)+    = eqIfaceType env t11 t21 && eqIfaceType env t12 t22+eqIfaceType env (IfaceForAllTy bndr1 t1) (IfaceForAllTy bndr2 t2)+    = eqIfaceForAllBndr env bndr1 bndr2 (\env' -> eqIfaceType env' t1 t2)+eqIfaceType env (IfaceTyConApp tc1 tys1) (IfaceTyConApp tc2 tys2)+    = tc1 == tc2 && eqIfaceTcArgs env tys1 tys2+eqIfaceType env (IfaceTupleTy s1 tc1 tys1) (IfaceTupleTy s2 tc2 tys2)+    = s1 == s2 && tc1 == tc2 && eqIfaceTcArgs env tys1 tys2+eqIfaceType env (IfaceCastTy t1 _) (IfaceCastTy t2 _)+    = eqIfaceType env t1 t2+eqIfaceType _   (IfaceCoercionTy {}) (IfaceCoercionTy {})+    = True+eqIfaceType _ _ _ = False++eqIfaceTypes :: IfRnEnv2 -> [IfaceType] -> [IfaceType] -> Bool+eqIfaceTypes env tys1 tys2 = and (zipWith (eqIfaceType env) tys1 tys2)++eqIfaceForAllBndr :: IfRnEnv2 -> IfaceForAllBndr -> IfaceForAllBndr+                  -> (IfRnEnv2 -> Bool)  -- continuation+                  -> Bool+eqIfaceForAllBndr env (TvBndr (tv1, k1) vis1) (TvBndr (tv2, k2) vis2) k+  = eqIfaceType env k1 k2 && vis1 == vis2 &&+    k (extendIfRnEnv2 env tv1 tv2)++eqIfaceTcArgs :: IfRnEnv2 -> IfaceTcArgs -> IfaceTcArgs -> Bool+eqIfaceTcArgs _ ITC_Nil ITC_Nil = True+eqIfaceTcArgs env (ITC_Vis ty1 tys1) (ITC_Vis ty2 tys2)+    = eqIfaceType env ty1 ty2 && eqIfaceTcArgs env tys1 tys2+eqIfaceTcArgs env (ITC_Invis ty1 tys1) (ITC_Invis ty2 tys2)+    = eqIfaceType env ty1 ty2 && eqIfaceTcArgs env tys1 tys2+eqIfaceTcArgs _ _ _ = False++-- | Similar to 'eqTyVarBndrs', checks that tyvar lists+-- are the same length and have matching kinds; if so, extend the+-- 'IfRnEnv2'.  Returns 'Nothing' if they don't match.+eqIfaceTvBndrs :: IfRnEnv2 -> [IfaceTvBndr] -> [IfaceTvBndr] -> Maybe IfRnEnv2+eqIfaceTvBndrs env [] [] = Just env+eqIfaceTvBndrs env ((tv1, k1):tvs1) ((tv2, k2):tvs2)+  | eqIfaceType env k1 k2+  = eqIfaceTvBndrs (extendIfRnEnv2 env tv1 tv2) tvs1 tvs2+eqIfaceTvBndrs _ _ _ = Nothing++{-+************************************************************************+*                                                                      *+                Functions over IFaceTcArgs+*                                                                      *+************************************************************************+-}++stripInvisArgs :: DynFlags -> IfaceTcArgs -> IfaceTcArgs+stripInvisArgs dflags tys+  | gopt Opt_PrintExplicitKinds dflags = tys+  | otherwise = suppress_invis tys+    where+      suppress_invis c+        = case c of+            ITC_Invis _ ts -> suppress_invis ts+            _ -> c++tcArgsIfaceTypes :: IfaceTcArgs -> [IfaceType]+tcArgsIfaceTypes ITC_Nil = []+tcArgsIfaceTypes (ITC_Invis t ts) = t : tcArgsIfaceTypes ts+tcArgsIfaceTypes (ITC_Vis   t ts) = t : tcArgsIfaceTypes ts++ifaceVisTcArgsLength :: IfaceTcArgs -> Int+ifaceVisTcArgsLength = go 0+  where+    go !n ITC_Nil            = n+    go n  (ITC_Vis _ rest)   = go (n+1) rest+    go n  (ITC_Invis _ rest) = go n rest++{-+Note [Suppressing invisible arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We use the IfaceTcArgs to specify which of the arguments to a type+constructor should be displayed when pretty-printing, under+the control of -fprint-explicit-kinds.+See also Type.filterOutInvisibleTypes.+For example, given+    T :: forall k. (k->*) -> k -> *    -- Ordinary kind polymorphism+    'Just :: forall k. k -> 'Maybe k   -- Promoted+we want+  T * Tree Int    prints as    T Tree Int+  'Just *         prints as    Just *+++************************************************************************+*                                                                      *+                Pretty-printing+*                                                                      *+************************************************************************+-}++if_print_coercions :: SDoc  -- ^ if printing coercions+                   -> SDoc  -- ^ otherwise+                   -> SDoc+if_print_coercions yes no+  = sdocWithDynFlags $ \dflags ->+    getPprStyle $ \style ->+    if gopt Opt_PrintExplicitCoercions dflags+         || dumpStyle style || debugStyle style+    then yes+    else no++pprIfaceInfixApp :: (TyPrec -> a -> SDoc) -> TyPrec -> SDoc -> a -> a -> SDoc+pprIfaceInfixApp pp p pp_tc ty1 ty2+  = maybeParen p FunPrec $+    sep [pp FunPrec ty1, pprInfixVar True pp_tc <+> pp FunPrec ty2]++pprIfacePrefixApp :: TyPrec -> SDoc -> [SDoc] -> SDoc+pprIfacePrefixApp p pp_fun pp_tys+  | null pp_tys = pp_fun+  | otherwise   = maybeParen p TyConPrec $+                  hang pp_fun 2 (sep pp_tys)++-- ----------------------------- Printing binders ------------------------------------++instance Outputable IfaceBndr where+    ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr+    ppr (IfaceTvBndr bndr) = char '@' <+> pprIfaceTvBndr False bndr++pprIfaceBndrs :: [IfaceBndr] -> SDoc+pprIfaceBndrs bs = sep (map ppr bs)++pprIfaceLamBndr :: IfaceLamBndr -> SDoc+pprIfaceLamBndr (b, IfaceNoOneShot) = ppr b+pprIfaceLamBndr (b, IfaceOneShot)   = ppr b <> text "[OneShot]"++pprIfaceIdBndr :: IfaceIdBndr -> SDoc+pprIfaceIdBndr (name, ty) = parens (ppr name <+> dcolon <+> ppr ty)++pprIfaceTvBndr :: Bool -> IfaceTvBndr -> SDoc+pprIfaceTvBndr use_parens (tv, ki)+  | isIfaceLiftedTypeKind ki = ppr tv+  | otherwise                = maybe_parens (ppr tv <+> dcolon <+> ppr ki)+  where+    maybe_parens | use_parens = parens+                 | otherwise  = id++pprIfaceTyConBinders :: [IfaceTyConBinder] -> SDoc+pprIfaceTyConBinders = sep . map go+  where+    go tcb = pprIfaceTvBndr True (ifTyConBinderTyVar tcb)++instance Binary IfaceBndr where+    put_ bh (IfaceIdBndr aa) = do+            putByte bh 0+            put_ bh aa+    put_ bh (IfaceTvBndr ab) = do+            putByte bh 1+            put_ bh ab+    get bh = do+            h <- getByte bh+            case h of+              0 -> do aa <- get bh+                      return (IfaceIdBndr aa)+              _ -> do ab <- get bh+                      return (IfaceTvBndr ab)++instance Binary IfaceOneShot where+    put_ bh IfaceNoOneShot = do+            putByte bh 0+    put_ bh IfaceOneShot = do+            putByte bh 1+    get bh = do+            h <- getByte bh+            case h of+              0 -> do return IfaceNoOneShot+              _ -> do return IfaceOneShot++-- ----------------------------- Printing IfaceType ------------------------------------++---------------------------------+instance Outputable IfaceType where+  ppr ty = pprIfaceType ty++pprIfaceType, pprParendIfaceType :: IfaceType -> SDoc+pprIfaceType       = eliminateRuntimeRep (ppr_ty TopPrec)+pprParendIfaceType = eliminateRuntimeRep (ppr_ty TyConPrec)++ppr_ty :: TyPrec -> IfaceType -> SDoc+ppr_ty _         (IfaceFreeTyVar tyvar) = ppr tyvar  -- This is the main reson for IfaceFreeTyVar!+ppr_ty _         (IfaceTyVar tyvar)     = ppr tyvar  -- See Note [TcTyVars in IfaceType]+ppr_ty ctxt_prec (IfaceTyConApp tc tys) = pprTyTcApp ctxt_prec tc tys+ppr_ty _         (IfaceTupleTy i p tys) = pprTuple i p tys+ppr_ty _         (IfaceLitTy n)         = pprIfaceTyLit n+        -- Function types+ppr_ty ctxt_prec (IfaceFunTy ty1 ty2)+  = -- We don't want to lose synonyms, so we mustn't use splitFunTys here.+    maybeParen ctxt_prec FunPrec $+    sep [ppr_ty FunPrec ty1, sep (ppr_fun_tail ty2)]+  where+    ppr_fun_tail (IfaceFunTy ty1 ty2)+      = (arrow <+> ppr_ty FunPrec ty1) : ppr_fun_tail ty2+    ppr_fun_tail other_ty+      = [arrow <+> pprIfaceType other_ty]++ppr_ty ctxt_prec (IfaceAppTy ty1 ty2)+  = if_print_coercions+      ppr_app_ty+      ppr_app_ty_no_casts+  where+    ppr_app_ty =+        maybeParen ctxt_prec TyConPrec+        $ ppr_ty FunPrec ty1 <+> ppr_ty TyConPrec ty2++    -- Strip any casts from the head of the application+    ppr_app_ty_no_casts =+        case split_app_tys ty1 (ITC_Vis ty2 ITC_Nil) of+          (IfaceCastTy head _, args) -> ppr_ty ctxt_prec (mk_app_tys head args)+          _                          -> ppr_app_ty++    split_app_tys :: IfaceType -> IfaceTcArgs -> (IfaceType, IfaceTcArgs)+    split_app_tys (IfaceAppTy t1 t2) args = split_app_tys t1 (t2 `ITC_Vis` args)+    split_app_tys head               args = (head, args)++    mk_app_tys :: IfaceType -> IfaceTcArgs -> IfaceType+    mk_app_tys (IfaceTyConApp tc tys1) tys2 =+        IfaceTyConApp tc (tys1 `mappend` tys2)+    mk_app_tys t1                      tys2 =+        foldl' IfaceAppTy t1 (tcArgsIfaceTypes tys2)++ppr_ty ctxt_prec (IfaceCastTy ty co)+  = if_print_coercions+      (parens (ppr_ty TopPrec ty <+> text "|>" <+> ppr co))+      (ppr_ty ctxt_prec ty)++ppr_ty ctxt_prec (IfaceCoercionTy co)+  = if_print_coercions+      (ppr_co ctxt_prec co)+      (text "<>")++ppr_ty ctxt_prec ty+  = maybeParen ctxt_prec FunPrec (pprIfaceSigmaType ShowForAllMust ty)++{-+Note [Defaulting RuntimeRep variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++RuntimeRep variables are considered by many (most?) users to be little more than+syntactic noise. When the notion was introduced there was a signficant and+understandable push-back from those with pedagogy in mind, which argued that+RuntimeRep variables would throw a wrench into nearly any teach approach since+they appear in even the lowly ($) function's type,++    ($) :: forall (w :: RuntimeRep) a (b :: TYPE w). (a -> b) -> a -> b++which is significantly less readable than its non RuntimeRep-polymorphic type of++    ($) :: (a -> b) -> a -> b++Moreover, unboxed types don't appear all that often in run-of-the-mill Haskell+programs, so it makes little sense to make all users pay this syntactic+overhead.++For this reason it was decided that we would hide RuntimeRep variables for now+(see #11549). We do this by defaulting all type variables of kind RuntimeRep to+PtrLiftedRep. This is done in a pass right before pretty-printing+(defaultRuntimeRepVars, controlled by -fprint-explicit-runtime-reps)+-}++-- | Default 'RuntimeRep' variables to 'LiftedPtr'. e.g.+--+-- @+-- ($) :: forall (r :: GHC.Types.RuntimeRep) a (b :: TYPE r).+--        (a -> b) -> a -> b+-- @+--+-- turns in to,+--+-- @ ($) :: forall a (b :: *). (a -> b) -> a -> b @+--+-- We do this to prevent RuntimeRep variables from incurring a significant+-- syntactic overhead in otherwise simple type signatures (e.g. ($)). See+-- Note [Defaulting RuntimeRep variables] and #11549 for further discussion.+--+defaultRuntimeRepVars :: IfaceType -> IfaceType+defaultRuntimeRepVars = go emptyFsEnv+  where+    go :: FastStringEnv () -> IfaceType -> IfaceType+    go subs (IfaceForAllTy bndr ty)+      | isRuntimeRep var_kind+      = let subs' = extendFsEnv subs var ()+        in go subs' ty+      | otherwise+      = IfaceForAllTy (TvBndr (var, go subs var_kind) (binderArgFlag bndr))+        (go subs ty)+      where+        var :: IfLclName+        (var, var_kind) = binderVar bndr++    go subs (IfaceTyVar tv)+      | tv `elemFsEnv` subs+      = IfaceTyConApp liftedRep ITC_Nil++    go subs (IfaceFunTy kind ty)+      = IfaceFunTy (go subs kind) (go subs ty)++    go subs (IfaceAppTy x y)+      = IfaceAppTy (go subs x) (go subs y)++    go subs (IfaceDFunTy x y)+      = IfaceDFunTy (go subs x) (go subs y)++    go subs (IfaceCastTy x co)+      = IfaceCastTy (go subs x) co++    go _ other = other++    liftedRep :: IfaceTyCon+    liftedRep =+        IfaceTyCon dc_name (IfaceTyConInfo IsPromoted IfaceNormalTyCon)+      where dc_name = getName liftedRepDataConTyCon++    isRuntimeRep :: IfaceType -> Bool+    isRuntimeRep (IfaceTyConApp tc _) =+        tc `ifaceTyConHasKey` runtimeRepTyConKey+    isRuntimeRep _ = False++eliminateRuntimeRep :: (IfaceType -> SDoc) -> IfaceType -> SDoc+eliminateRuntimeRep f ty = sdocWithDynFlags $ \dflags ->+    if gopt Opt_PrintExplicitRuntimeReps dflags+      then f ty+      else f (defaultRuntimeRepVars ty)++instance Outputable IfaceTcArgs where+  ppr tca = pprIfaceTcArgs tca++pprIfaceTcArgs, pprParendIfaceTcArgs :: IfaceTcArgs -> SDoc+pprIfaceTcArgs  = ppr_tc_args TopPrec+pprParendIfaceTcArgs = ppr_tc_args TyConPrec++ppr_tc_args :: TyPrec -> IfaceTcArgs -> SDoc+ppr_tc_args ctx_prec args+ = let pprTys t ts = ppr_ty ctx_prec t <+> ppr_tc_args ctx_prec ts+   in case args of+        ITC_Nil        -> empty+        ITC_Vis   t ts -> pprTys t ts+        ITC_Invis t ts -> pprTys t ts++-------------------+pprIfaceForAllPart :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc+pprIfaceForAllPart tvs ctxt sdoc+  = ppr_iface_forall_part ShowForAllWhen tvs ctxt sdoc++pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion)] -> SDoc -> SDoc+pprIfaceForAllCoPart tvs sdoc+  = sep [ pprIfaceForAllCo tvs, sdoc ]++ppr_iface_forall_part :: ShowForAllFlag+                      -> [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc+ppr_iface_forall_part show_forall tvs ctxt sdoc+  = sep [ case show_forall of+            ShowForAllMust -> pprIfaceForAll tvs+            ShowForAllWhen -> pprUserIfaceForAll tvs+        , pprIfaceContextArr ctxt+        , sdoc]++-- | Render the "forall ... ." or "forall ... ->" bit of a type.+pprIfaceForAll :: [IfaceForAllBndr] -> SDoc+pprIfaceForAll [] = empty+pprIfaceForAll bndrs@(TvBndr _ vis : _)+  = add_separator (forAllLit <+> doc) <+> pprIfaceForAll bndrs'+  where+    (bndrs', doc) = ppr_itv_bndrs bndrs vis++    add_separator stuff = case vis of+                            Required -> stuff <+> arrow+                            _inv     -> stuff <>  dot+++-- | Render the ... in @(forall ... .)@ or @(forall ... ->)@.+-- Returns both the list of not-yet-rendered binders and the doc.+-- No anonymous binders here!+ppr_itv_bndrs :: [IfaceForAllBndr]+             -> ArgFlag  -- ^ visibility of the first binder in the list+             -> ([IfaceForAllBndr], SDoc)+ppr_itv_bndrs all_bndrs@(bndr@(TvBndr _ vis) : bndrs) vis1+  | vis `sameVis` vis1 = let (bndrs', doc) = ppr_itv_bndrs bndrs vis1 in+                         (bndrs', pprIfaceForAllBndr bndr <+> doc)+  | otherwise   = (all_bndrs, empty)+ppr_itv_bndrs [] _ = ([], empty)++pprIfaceForAllCo :: [(IfLclName, IfaceCoercion)] -> SDoc+pprIfaceForAllCo []  = empty+pprIfaceForAllCo tvs = text "forall" <+> pprIfaceForAllCoBndrs tvs <> dot++pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion)] -> SDoc+pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs++pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc+pprIfaceForAllBndr (TvBndr tv Inferred) = sdocWithDynFlags $ \dflags ->+                                           if gopt Opt_PrintExplicitForalls dflags+                                           then braces $ pprIfaceTvBndr False tv+                                           else pprIfaceTvBndr True tv+pprIfaceForAllBndr (TvBndr tv _)        = pprIfaceTvBndr True tv++pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion) -> SDoc+pprIfaceForAllCoBndr (tv, kind_co)+  = parens (ppr tv <+> dcolon <+> pprIfaceCoercion kind_co)++-- | Show forall flag+--+-- Unconditionally show the forall quantifier with ('ShowForAllMust')+-- or when ('ShowForAllWhen') the names used are free in the binder+-- or when compiling with -fprint-explicit-foralls.+data ShowForAllFlag = ShowForAllMust | ShowForAllWhen++pprIfaceSigmaType :: ShowForAllFlag -> IfaceType -> SDoc+pprIfaceSigmaType show_forall ty+  = ppr_iface_forall_part show_forall tvs theta (ppr tau)+  where+    (tvs, theta, tau) = splitIfaceSigmaTy ty++pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc+pprUserIfaceForAll tvs+   = sdocWithDynFlags $ \dflags ->+     ppWhen (any tv_has_kind_var tvs || gopt Opt_PrintExplicitForalls dflags) $+     pprIfaceForAll tvs+   where+     tv_has_kind_var (TvBndr (_,kind) _) = not (ifTypeIsVarFree kind)+++-------------------++-- See equivalent function in TyCoRep.hs+pprIfaceTyList :: TyPrec -> IfaceType -> IfaceType -> SDoc+-- Given a type-level list (t1 ': t2), see if we can print+-- it in list notation [t1, ...].+-- Precondition: Opt_PrintExplicitKinds is off+pprIfaceTyList ctxt_prec ty1 ty2+  = case gather ty2 of+      (arg_tys, Nothing)+        -> char '\'' <> brackets (fsep (punctuate comma+                        (map (ppr_ty TopPrec) (ty1:arg_tys))))+      (arg_tys, Just tl)+        -> maybeParen ctxt_prec FunPrec $ hang (ppr_ty FunPrec ty1)+           2 (fsep [ colon <+> ppr_ty FunPrec ty | ty <- arg_tys ++ [tl]])+  where+    gather :: IfaceType -> ([IfaceType], Maybe IfaceType)+     -- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn]+     --             = (tys, Just tl) means ty is of form t1:t2:...tn:tl+    gather (IfaceTyConApp tc tys)+      | tc `ifaceTyConHasKey` consDataConKey+      , (ITC_Invis _ (ITC_Vis ty1 (ITC_Vis ty2 ITC_Nil))) <- tys+      , (args, tl) <- gather ty2+      = (ty1:args, tl)+      | tc `ifaceTyConHasKey` nilDataConKey+      = ([], Nothing)+    gather ty = ([], Just ty)++pprIfaceTypeApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> SDoc+pprIfaceTypeApp prec tc args = pprTyTcApp prec tc args++pprTyTcApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> SDoc+pprTyTcApp ctxt_prec tc tys =+    sdocWithDynFlags $ \dflags ->+    getPprStyle $ \style ->+    pprTyTcApp' ctxt_prec tc tys dflags style++pprTyTcApp' :: TyPrec -> IfaceTyCon -> IfaceTcArgs+            -> DynFlags -> PprStyle -> SDoc+pprTyTcApp' ctxt_prec tc tys dflags style+  | ifaceTyConName tc `hasKey` ipClassKey+  , ITC_Vis (IfaceLitTy (IfaceStrTyLit n)) (ITC_Vis ty ITC_Nil) <- tys+  = maybeParen ctxt_prec FunPrec+    $ char '?' <> ftext n <> text "::" <> ppr_ty TopPrec ty++  | IfaceTupleTyCon arity sort <- ifaceTyConSort info+  , not (debugStyle style)+  , arity == ifaceVisTcArgsLength tys+  = pprTuple sort (ifaceTyConIsPromoted info) tys++  | IfaceSumTyCon arity <- ifaceTyConSort info+  = pprSum arity (ifaceTyConIsPromoted info) tys++  | tc `ifaceTyConHasKey` consDataConKey+  , not (gopt Opt_PrintExplicitKinds dflags)+  , ITC_Invis _ (ITC_Vis ty1 (ITC_Vis ty2 ITC_Nil)) <- tys+  = pprIfaceTyList ctxt_prec ty1 ty2++  | tc `ifaceTyConHasKey` tYPETyConKey+  , ITC_Vis (IfaceTyConApp rep ITC_Nil) ITC_Nil <- tys+  , rep `ifaceTyConHasKey` liftedRepDataConKey+  = kindStar++  | otherwise+  = sdocWithPprDebug $ \dbg ->+    if | not dbg && tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey+         -- Suppress detail unles you _really_ want to see+         -> text "(TypeError ...)"++       | Just doc <- ppr_equality tc (tcArgsIfaceTypes tys)+         -> maybeParen ctxt_prec TyConPrec doc++       | otherwise+         -> ppr_iface_tc_app ppr_ty ctxt_prec tc tys_wo_kinds+  where+    info = ifaceTyConInfo tc+    tys_wo_kinds = tcArgsIfaceTypes $ stripInvisArgs dflags tys++-- | Pretty-print a type-level equality.+--+-- See Note [Equality predicates in IfaceType].+ppr_equality :: IfaceTyCon -> [IfaceType] -> Maybe SDoc+ppr_equality tc args+  | hetero_eq_tc+  , [k1, k2, t1, t2] <- args+  = Just $ print_equality (k1, k2, t1, t2)++  | hom_eq_tc+  , [k, t1, t2] <- args+  = Just $ print_equality (k, k, t1, t2)++  | otherwise+  = Nothing+  where+    homogeneous = case ifaceTyConSort $ ifaceTyConInfo tc of+                    IfaceEqualityTyCon hom -> hom+                    _other -> pprPanic "ppr_equality: homogeneity" (ppr tc)+    tc_name = ifaceTyConName tc+    pp = ppr_ty+    hom_eq_tc = tc_name `hasKey` eqTyConKey            -- (~)+    hetero_eq_tc = tc_name `hasKey` eqPrimTyConKey     -- (~#)+                || tc_name `hasKey` eqReprPrimTyConKey -- (~R#)+                || tc_name `hasKey` heqTyConKey        -- (~~)++    print_equality args =+        sdocWithDynFlags+        $ \dflags -> getPprStyle+        $ \style -> print_equality' args style dflags++    print_equality' (ki1, ki2, ty1, ty2) style dflags+      | print_eqs+      = ppr_infix_eq (ppr tc)++      | hetero_eq_tc+      , print_kinds || not homogeneous+      = ppr_infix_eq (text "~~")++      | otherwise+      = if tc_name `hasKey` eqReprPrimTyConKey+        then text "Coercible"+             <+> sep [ pp TyConPrec ty1, pp TyConPrec ty2 ]+        else sep [pp TyOpPrec ty1, char '~', pp TyOpPrec ty2]+      where+        ppr_infix_eq eq_op+           = sep [ parens (pp TyOpPrec ty1 <+> dcolon <+> pp TyOpPrec ki1)+                 , eq_op+                 , parens (pp TyOpPrec ty2 <+> dcolon <+> pp TyOpPrec ki2) ]++        print_kinds = gopt Opt_PrintExplicitKinds dflags+        print_eqs   = gopt Opt_PrintEqualityRelations dflags ||+                      dumpStyle style || debugStyle style+++pprIfaceCoTcApp :: TyPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc+pprIfaceCoTcApp ctxt_prec tc tys = ppr_iface_tc_app ppr_co ctxt_prec tc tys++ppr_iface_tc_app :: (TyPrec -> a -> SDoc) -> TyPrec -> IfaceTyCon -> [a] -> SDoc+ppr_iface_tc_app pp _ tc [ty]+  | tc `ifaceTyConHasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp TopPrec ty)+  | tc `ifaceTyConHasKey` parrTyConKey = pprPromotionQuote tc <> paBrackets (pp TopPrec ty)++ppr_iface_tc_app pp ctxt_prec tc tys+  |  tc `ifaceTyConHasKey` starKindTyConKey+  || tc `ifaceTyConHasKey` liftedTypeKindTyConKey+  || tc `ifaceTyConHasKey` unicodeStarKindTyConKey+  = kindStar   -- Handle unicode; do not wrap * in parens++  | not (isSymOcc (nameOccName (ifaceTyConName tc)))+  = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp TyConPrec) tys)++  | [ty1,ty2] <- tys  -- Infix, two arguments;+                      -- we know nothing of precedence though+  = pprIfaceInfixApp pp ctxt_prec (ppr tc) ty1 ty2++  | otherwise+  = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp TyConPrec) tys)++pprSum :: Arity -> IsPromoted -> IfaceTcArgs -> SDoc+pprSum _arity is_promoted args+  =   -- drop the RuntimeRep vars.+      -- See Note [Unboxed tuple RuntimeRep vars] in TyCon+    let tys   = tcArgsIfaceTypes args+        args' = drop (length tys `div` 2) tys+    in pprPromotionQuoteI is_promoted+       <> sumParens (pprWithBars (ppr_ty TopPrec) args')++pprTuple :: TupleSort -> IsPromoted -> IfaceTcArgs -> SDoc+pprTuple ConstraintTuple IsNotPromoted ITC_Nil+  = text "() :: Constraint"++-- All promoted constructors have kind arguments+pprTuple sort IsPromoted args+  = let tys = tcArgsIfaceTypes args+        args' = drop (length tys `div` 2) tys+    in pprPromotionQuoteI IsPromoted <>+       tupleParens sort (pprWithCommas pprIfaceType args')++pprTuple sort promoted args+  =   -- drop the RuntimeRep vars.+      -- See Note [Unboxed tuple RuntimeRep vars] in TyCon+    let tys   = tcArgsIfaceTypes args+        args' = case sort of+                  UnboxedTuple -> drop (length tys `div` 2) tys+                  _            -> tys+    in+    pprPromotionQuoteI promoted <>+    tupleParens sort (pprWithCommas pprIfaceType args')++pprIfaceTyLit :: IfaceTyLit -> SDoc+pprIfaceTyLit (IfaceNumTyLit n) = integer n+pprIfaceTyLit (IfaceStrTyLit n) = text (show n)++pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc+pprIfaceCoercion = ppr_co TopPrec+pprParendIfaceCoercion = ppr_co TyConPrec++ppr_co :: TyPrec -> IfaceCoercion -> SDoc+ppr_co _         (IfaceReflCo r ty) = angleBrackets (ppr ty) <> ppr_role r+ppr_co ctxt_prec (IfaceFunCo r co1 co2)+  = maybeParen ctxt_prec FunPrec $+    sep (ppr_co FunPrec co1 : ppr_fun_tail co2)+  where+    ppr_fun_tail (IfaceFunCo r co1 co2)+      = (arrow <> ppr_role r <+> ppr_co FunPrec co1) : ppr_fun_tail co2+    ppr_fun_tail other_co+      = [arrow <> ppr_role r <+> pprIfaceCoercion other_co]++ppr_co _         (IfaceTyConAppCo r tc cos)+  = parens (pprIfaceCoTcApp TopPrec tc cos) <> ppr_role r+ppr_co ctxt_prec (IfaceAppCo co1 co2)+  = maybeParen ctxt_prec TyConPrec $+    ppr_co FunPrec co1 <+> pprParendIfaceCoercion co2+ppr_co ctxt_prec co@(IfaceForAllCo {})+  = maybeParen ctxt_prec FunPrec (pprIfaceForAllCoPart tvs (pprIfaceCoercion inner_co))+  where+    (tvs, inner_co) = split_co co++    split_co (IfaceForAllCo (name, _) kind_co co')+      = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'')+    split_co co' = ([], co')++ppr_co _         (IfaceCoVarCo covar)       = ppr covar++ppr_co ctxt_prec (IfaceUnivCo IfaceUnsafeCoerceProv r ty1 ty2)+  = maybeParen ctxt_prec TyConPrec $+    text "UnsafeCo" <+> ppr r <+>+    pprParendIfaceType ty1 <+> pprParendIfaceType ty2++ppr_co _ctxt_prec (IfaceUnivCo (IfaceHoleProv u) _ _ _)+ = braces $ ppr u++ppr_co _         (IfaceUnivCo _ _ ty1 ty2)+  = angleBrackets ( ppr ty1 <> comma <+> ppr ty2 )++ppr_co ctxt_prec (IfaceInstCo co ty)+  = maybeParen ctxt_prec TyConPrec $+    text "Inst" <+> pprParendIfaceCoercion co+                        <+> pprParendIfaceCoercion ty++ppr_co ctxt_prec (IfaceAxiomRuleCo tc cos)+  = maybeParen ctxt_prec TyConPrec $ ppr tc <+> parens (interpp'SP cos)++ppr_co ctxt_prec (IfaceAxiomInstCo n i cos)+  = ppr_special_co ctxt_prec (ppr n <> brackets (ppr i)) cos+ppr_co ctxt_prec (IfaceSymCo co)+  = ppr_special_co ctxt_prec (text "Sym") [co]+ppr_co ctxt_prec (IfaceTransCo co1 co2)+  = ppr_special_co ctxt_prec  (text "Trans") [co1,co2]+ppr_co ctxt_prec (IfaceNthCo d co)+  = ppr_special_co ctxt_prec (text "Nth:" <> int d) [co]+ppr_co ctxt_prec (IfaceLRCo lr co)+  = ppr_special_co ctxt_prec (ppr lr) [co]+ppr_co ctxt_prec (IfaceSubCo co)+  = ppr_special_co ctxt_prec (text "Sub") [co]+ppr_co ctxt_prec (IfaceCoherenceCo co1 co2)+  = ppr_special_co ctxt_prec (text "Coh") [co1,co2]+ppr_co ctxt_prec (IfaceKindCo co)+  = ppr_special_co ctxt_prec (text "Kind") [co]++ppr_special_co :: TyPrec -> SDoc -> [IfaceCoercion] -> SDoc+ppr_special_co ctxt_prec doc cos+  = maybeParen ctxt_prec TyConPrec+               (sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))])++ppr_role :: Role -> SDoc+ppr_role r = underscore <> pp_role+  where pp_role = case r of+                    Nominal          -> char 'N'+                    Representational -> char 'R'+                    Phantom          -> char 'P'++-------------------+instance Outputable IfaceTyCon where+  ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc)++pprPromotionQuote :: IfaceTyCon -> SDoc+pprPromotionQuote tc =+    pprPromotionQuoteI $ ifaceTyConIsPromoted $ ifaceTyConInfo tc++pprPromotionQuoteI  :: IsPromoted -> SDoc+pprPromotionQuoteI IsNotPromoted = empty+pprPromotionQuoteI IsPromoted    = char '\''++instance Outputable IfaceCoercion where+  ppr = pprIfaceCoercion++instance Binary IfaceTyCon where+   put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i++   get bh = do n <- get bh+               i <- get bh+               return (IfaceTyCon n i)++instance Binary IsPromoted where+   put_ bh IsNotPromoted = putByte bh 0+   put_ bh IsPromoted    = putByte bh 1++   get bh = do+       n <- getByte bh+       case n of+         0 -> return IsNotPromoted+         1 -> return IsPromoted+         _ -> fail "Binary(IsPromoted): fail)"++instance Binary IfaceTyConSort where+   put_ bh IfaceNormalTyCon             = putByte bh 0+   put_ bh (IfaceTupleTyCon arity sort) = putByte bh 1 >> put_ bh arity >> put_ bh sort+   put_ bh (IfaceSumTyCon arity)        = putByte bh 2 >> put_ bh arity+   put_ bh (IfaceEqualityTyCon hom)+     | hom                              = putByte bh 3+     | otherwise                        = putByte bh 4++   get bh = do+       n <- getByte bh+       case n of+         0 -> return IfaceNormalTyCon+         1 -> IfaceTupleTyCon <$> get bh <*> get bh+         2 -> IfaceSumTyCon <$> get bh+         3 -> return $ IfaceEqualityTyCon True+         4 -> return $ IfaceEqualityTyCon False+         _ -> fail "Binary(IfaceTyConSort): fail"++instance Binary IfaceTyConInfo where+   put_ bh (IfaceTyConInfo i s) = put_ bh i >> put_ bh s++   get bh = IfaceTyConInfo <$> get bh <*> get bh++instance Outputable IfaceTyLit where+  ppr = pprIfaceTyLit++instance Binary IfaceTyLit where+  put_ bh (IfaceNumTyLit n)  = putByte bh 1 >> put_ bh n+  put_ bh (IfaceStrTyLit n)  = putByte bh 2 >> put_ bh n++  get bh =+    do tag <- getByte bh+       case tag of+         1 -> do { n <- get bh+                 ; return (IfaceNumTyLit n) }+         2 -> do { n <- get bh+                 ; return (IfaceStrTyLit n) }+         _ -> panic ("get IfaceTyLit " ++ show tag)++instance Binary IfaceTcArgs where+  put_ bh tk =+    case tk of+      ITC_Vis   t ts -> putByte bh 0 >> put_ bh t >> put_ bh ts+      ITC_Invis t ts -> putByte bh 1 >> put_ bh t >> put_ bh ts+      ITC_Nil        -> putByte bh 2++  get bh =+    do c <- getByte bh+       case c of+         0 -> do+           t  <- get bh+           ts <- get bh+           return $! ITC_Vis t ts+         1 -> do+           t  <- get bh+           ts <- get bh+           return $! ITC_Invis t ts+         2 -> return ITC_Nil+         _ -> panic ("get IfaceTcArgs " ++ show c)++-------------------++-- Some notes about printing contexts+--+-- In the event that we are printing a singleton context (e.g. @Eq a@) we can+-- omit parentheses. However, we must take care to set the precedence correctly+-- to TyOpPrec, since something like @a :~: b@ must be parenthesized (see+-- #9658).+--+-- When printing a larger context we use 'fsep' instead of 'sep' so that+-- the context doesn't get displayed as a giant column. Rather than,+--  instance (Eq a,+--            Eq b,+--            Eq c,+--            Eq d,+--            Eq e,+--            Eq f,+--            Eq g,+--            Eq h,+--            Eq i,+--            Eq j,+--            Eq k,+--            Eq l) =>+--           Eq (a, b, c, d, e, f, g, h, i, j, k, l)+--+-- we want+--+--  instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i,+--            Eq j, Eq k, Eq l) =>+--           Eq (a, b, c, d, e, f, g, h, i, j, k, l)++++-- | Prints "(C a, D b) =>", including the arrow. This is used when we want to+-- print a context in a type.+pprIfaceContextArr :: [IfacePredType] -> SDoc+pprIfaceContextArr []     = empty+pprIfaceContextArr [pred] = ppr_ty TyOpPrec pred <+> darrow+pprIfaceContextArr preds  =+    parens (fsep (punctuate comma (map ppr preds))) <+> darrow++-- | Prints a context or @()@ if empty. This is used when, e.g., we want to+-- display a context in an error message.+pprIfaceContext :: [IfacePredType] -> SDoc+pprIfaceContext []     = parens empty+pprIfaceContext [pred] = ppr_ty TyOpPrec pred+pprIfaceContext preds  = parens (fsep (punctuate comma (map ppr preds)))++instance Binary IfaceType where+    put_ _ (IfaceFreeTyVar tv)+       = pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv)++    put_ bh (IfaceForAllTy aa ab) = do+            putByte bh 0+            put_ bh aa+            put_ bh ab+    put_ bh (IfaceTyVar ad) = do+            putByte bh 1+            put_ bh ad+    put_ bh (IfaceAppTy ae af) = do+            putByte bh 2+            put_ bh ae+            put_ bh af+    put_ bh (IfaceFunTy ag ah) = do+            putByte bh 3+            put_ bh ag+            put_ bh ah+    put_ bh (IfaceDFunTy ag ah) = do+            putByte bh 4+            put_ bh ag+            put_ bh ah+    put_ bh (IfaceTyConApp tc tys)+      = do { putByte bh 5; put_ bh tc; put_ bh tys }+    put_ bh (IfaceCastTy a b)+      = do { putByte bh 6; put_ bh a; put_ bh b }+    put_ bh (IfaceCoercionTy a)+      = do { putByte bh 7; put_ bh a }+    put_ bh (IfaceTupleTy s i tys)+      = do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys }+    put_ bh (IfaceLitTy n)+      = do { putByte bh 9; put_ bh n }++    get bh = do+            h <- getByte bh+            case h of+              0 -> do aa <- get bh+                      ab <- get bh+                      return (IfaceForAllTy aa ab)+              1 -> do ad <- get bh+                      return (IfaceTyVar ad)+              2 -> do ae <- get bh+                      af <- get bh+                      return (IfaceAppTy ae af)+              3 -> do ag <- get bh+                      ah <- get bh+                      return (IfaceFunTy ag ah)+              4 -> do ag <- get bh+                      ah <- get bh+                      return (IfaceDFunTy ag ah)+              5 -> do { tc <- get bh; tys <- get bh+                      ; return (IfaceTyConApp tc tys) }+              6 -> do { a <- get bh; b <- get bh+                      ; return (IfaceCastTy a b) }+              7 -> do { a <- get bh+                      ; return (IfaceCoercionTy a) }++              8 -> do { s <- get bh; i <- get bh; tys <- get bh+                      ; return (IfaceTupleTy s i tys) }+              _  -> do n <- get bh+                       return (IfaceLitTy n)++instance Binary IfaceCoercion where+  put_ bh (IfaceReflCo a b) = do+          putByte bh 1+          put_ bh a+          put_ bh b+  put_ bh (IfaceFunCo a b c) = do+          putByte bh 2+          put_ bh a+          put_ bh b+          put_ bh c+  put_ bh (IfaceTyConAppCo a b c) = do+          putByte bh 3+          put_ bh a+          put_ bh b+          put_ bh c+  put_ bh (IfaceAppCo a b) = do+          putByte bh 4+          put_ bh a+          put_ bh b+  put_ bh (IfaceForAllCo a b c) = do+          putByte bh 5+          put_ bh a+          put_ bh b+          put_ bh c+  put_ bh (IfaceCoVarCo a) = do+          putByte bh 6+          put_ bh a+  put_ bh (IfaceAxiomInstCo a b c) = do+          putByte bh 7+          put_ bh a+          put_ bh b+          put_ bh c+  put_ bh (IfaceUnivCo a b c d) = do+          putByte bh 8+          put_ bh a+          put_ bh b+          put_ bh c+          put_ bh d+  put_ bh (IfaceSymCo a) = do+          putByte bh 9+          put_ bh a+  put_ bh (IfaceTransCo a b) = do+          putByte bh 10+          put_ bh a+          put_ bh b+  put_ bh (IfaceNthCo a b) = do+          putByte bh 11+          put_ bh a+          put_ bh b+  put_ bh (IfaceLRCo a b) = do+          putByte bh 12+          put_ bh a+          put_ bh b+  put_ bh (IfaceInstCo a b) = do+          putByte bh 13+          put_ bh a+          put_ bh b+  put_ bh (IfaceCoherenceCo a b) = do+          putByte bh 14+          put_ bh a+          put_ bh b+  put_ bh (IfaceKindCo a) = do+          putByte bh 15+          put_ bh a+  put_ bh (IfaceSubCo a) = do+          putByte bh 16+          put_ bh a+  put_ bh (IfaceAxiomRuleCo a b) = do+          putByte bh 17+          put_ bh a+          put_ bh b++  get bh = do+      tag <- getByte bh+      case tag of+           1 -> do a <- get bh+                   b <- get bh+                   return $ IfaceReflCo a b+           2 -> do a <- get bh+                   b <- get bh+                   c <- get bh+                   return $ IfaceFunCo a b c+           3 -> do a <- get bh+                   b <- get bh+                   c <- get bh+                   return $ IfaceTyConAppCo a b c+           4 -> do a <- get bh+                   b <- get bh+                   return $ IfaceAppCo a b+           5 -> do a <- get bh+                   b <- get bh+                   c <- get bh+                   return $ IfaceForAllCo a b c+           6 -> do a <- get bh+                   return $ IfaceCoVarCo a+           7 -> do a <- get bh+                   b <- get bh+                   c <- get bh+                   return $ IfaceAxiomInstCo a b c+           8 -> do a <- get bh+                   b <- get bh+                   c <- get bh+                   d <- get bh+                   return $ IfaceUnivCo a b c d+           9 -> do a <- get bh+                   return $ IfaceSymCo a+           10-> do a <- get bh+                   b <- get bh+                   return $ IfaceTransCo a b+           11-> do a <- get bh+                   b <- get bh+                   return $ IfaceNthCo a b+           12-> do a <- get bh+                   b <- get bh+                   return $ IfaceLRCo a b+           13-> do a <- get bh+                   b <- get bh+                   return $ IfaceInstCo a b+           14-> do a <- get bh+                   b <- get bh+                   return $ IfaceCoherenceCo a b+           15-> do a <- get bh+                   return $ IfaceKindCo a+           16-> do a <- get bh+                   return $ IfaceSubCo a+           17-> do a <- get bh+                   b <- get bh+                   return $ IfaceAxiomRuleCo a b+           _ -> panic ("get IfaceCoercion " ++ show tag)++instance Binary IfaceUnivCoProv where+  put_ bh IfaceUnsafeCoerceProv = putByte bh 1+  put_ bh (IfacePhantomProv a) = do+          putByte bh 2+          put_ bh a+  put_ bh (IfaceProofIrrelProv a) = do+          putByte bh 3+          put_ bh a+  put_ bh (IfacePluginProv a) = do+          putByte bh 4+          put_ bh a+  put_ _  (IfaceHoleProv _) =+          pprPanic "Binary(IfaceUnivCoProv) hit a hole" empty+  -- See Note [Holes in IfaceUnivCoProv]++  get bh = do+      tag <- getByte bh+      case tag of+           1 -> return $ IfaceUnsafeCoerceProv+           2 -> do a <- get bh+                   return $ IfacePhantomProv a+           3 -> do a <- get bh+                   return $ IfaceProofIrrelProv a+           4 -> do a <- get bh+                   return $ IfacePluginProv a+           _ -> panic ("get IfaceUnivCoProv " ++ show tag)+++instance Binary (DefMethSpec IfaceType) where+    put_ bh VanillaDM     = putByte bh 0+    put_ bh (GenericDM t) = putByte bh 1 >> put_ bh t+    get bh = do+            h <- getByte bh+            case h of+              0 -> return VanillaDM+              _ -> do { t <- get bh; return (GenericDM t) }
+ iface/IfaceType.hs-boot view
@@ -0,0 +1,37 @@+-- Exists to allow TyCoRep to import pretty-printers+module IfaceType where++import Var (TyVarBndr, ArgFlag)+import TyCon (TyConBndrVis)+import BasicTypes (TyPrec)+import Outputable (Outputable, SDoc)+import FastString (FastString)++type IfLclName = FastString+type IfaceKind = IfaceType+type IfacePredType = IfaceType++data ShowForAllFlag+data IfaceType+data IfaceTyCon+data IfaceTyLit+data IfaceCoercion+data IfaceTcArgs+type IfaceTvBndr = (IfLclName, IfaceKind)+type IfaceTyConBinder = TyVarBndr IfaceTvBndr TyConBndrVis+type IfaceForAllBndr  = TyVarBndr IfaceTvBndr ArgFlag++instance Outputable IfaceType++pprIfaceType, pprParendIfaceType :: IfaceType -> SDoc+pprIfaceSigmaType :: ShowForAllFlag -> IfaceType -> SDoc+pprIfaceTyLit :: IfaceTyLit -> SDoc+pprIfaceForAll :: [IfaceForAllBndr] -> SDoc+pprIfaceTvBndr :: Bool -> IfaceTvBndr -> SDoc+pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc+pprIfaceContext :: [IfacePredType] -> SDoc+pprIfaceContextArr :: [IfacePredType] -> SDoc+pprIfaceTypeApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> SDoc+pprIfaceCoTcApp :: TyPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc+pprTyTcApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> SDoc+pprIfacePrefixApp :: TyPrec -> SDoc -> [SDoc] -> SDoc
+ iface/LoadIface.hs view
@@ -0,0 +1,1184 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Loading interface files+-}++{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module LoadIface (+        -- Importing one thing+        tcLookupImported_maybe, importDecl,+        checkWiredInTyCon, ifCheckWiredInThing,++        -- RnM/TcM functions+        loadModuleInterface, loadModuleInterfaces,+        loadSrcInterface, loadSrcInterface_maybe,+        loadInterfaceForName, loadInterfaceForModule,++        -- IfM functions+        loadInterface,+        loadSysInterface, loadUserInterface, loadPluginInterface,+        findAndReadIface, readIface,    -- Used when reading the module's old interface+        loadDecls,      -- Should move to TcIface and be renamed+        initExternalPackageState,+        moduleFreeHolesPrecise,++        pprModIfaceSimple,+        ifaceStats, pprModIface, showIface+   ) where++#include "HsVersions.h"++import {-# SOURCE #-}   TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst,+                                 tcIfaceFamInst, tcIfaceVectInfo,+                                 tcIfaceAnnotations, tcIfaceCompleteSigs )++import DynFlags+import IfaceSyn+import IfaceEnv+import HscTypes++import BasicTypes hiding (SuccessFlag(..))+import TcRnMonad++import Constants+import PrelNames+import PrelInfo+import PrimOp   ( allThePrimOps, primOpFixity, primOpOcc )+import MkId     ( seqId )+import TysPrim  ( funTyConName )+import Rules+import TyCon+import Annotations+import InstEnv+import FamInstEnv+import Name+import NameEnv+import Avail+import Module+import Maybes+import ErrUtils+import Finder+import UniqFM+import SrcLoc+import Outputable+import BinIface+import Panic+import Util+import FastString+import Fingerprint+import Hooks+import FieldLabel+import RnModIface+import UniqDSet++import Control.Monad+import Control.Exception+import Data.IORef+import System.FilePath++{-+************************************************************************+*                                                                      *+*      tcImportDecl is the key function for "faulting in"              *+*      imported things+*                                                                      *+************************************************************************++The main idea is this.  We are chugging along type-checking source code, and+find a reference to GHC.Base.map.  We call tcLookupGlobal, which doesn't find+it in the EPS type envt.  So it+        1 loads GHC.Base.hi+        2 gets the decl for GHC.Base.map+        3 typechecks it via tcIfaceDecl+        4 and adds it to the type env in the EPS++Note that DURING STEP 4, we may find that map's type mentions a type+constructor that also++Notice that for imported things we read the current version from the EPS+mutable variable.  This is important in situations like+        ...$(e1)...$(e2)...+where the code that e1 expands to might import some defns that+also turn out to be needed by the code that e2 expands to.+-}++tcLookupImported_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing)+-- Returns (Failed err) if we can't find the interface file for the thing+tcLookupImported_maybe name+  = do  { hsc_env <- getTopEnv+        ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)+        ; case mb_thing of+            Just thing -> return (Succeeded thing)+            Nothing    -> tcImportDecl_maybe name }++tcImportDecl_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing)+-- Entry point for *source-code* uses of importDecl+tcImportDecl_maybe name+  | Just thing <- wiredInNameTyThing_maybe name+  = do  { when (needWiredInHomeIface thing)+               (initIfaceTcRn (loadWiredInHomeIface name))+                -- See Note [Loading instances for wired-in things]+        ; return (Succeeded thing) }+  | otherwise+  = initIfaceTcRn (importDecl name)++importDecl :: Name -> IfM lcl (MaybeErr MsgDoc TyThing)+-- Get the TyThing for this Name from an interface file+-- It's not a wired-in thing -- the caller caught that+importDecl name+  = ASSERT( not (isWiredInName name) )+    do  { traceIf nd_doc++        -- Load the interface, which should populate the PTE+        ; mb_iface <- ASSERT2( isExternalName name, ppr name )+                      loadInterface nd_doc (nameModule name) ImportBySystem+        ; case mb_iface of {+                Failed err_msg  -> return (Failed err_msg) ;+                Succeeded _ -> do++        -- Now look it up again; this time we should find it+        { eps <- getEps+        ; case lookupTypeEnv (eps_PTE eps) name of+            Just thing -> return $ Succeeded thing+            Nothing    -> let doc = ifPprDebug (found_things_msg eps $$ empty)+                                    $$ not_found_msg+                          in return $ Failed doc+    }}}+  where+    nd_doc = text "Need decl for" <+> ppr name+    not_found_msg = hang (text "Can't find interface-file declaration for" <+>+                                pprNameSpace (occNameSpace (nameOccName name)) <+> ppr name)+                       2 (vcat [text "Probable cause: bug in .hi-boot file, or inconsistent .hi file",+                                text "Use -ddump-if-trace to get an idea of which file caused the error"])+    found_things_msg eps =+        hang (text "Found the following declarations in" <+> ppr (nameModule name) <> colon)+           2 (vcat (map ppr $ filter is_interesting $ nameEnvElts $ eps_PTE eps))+      where+        is_interesting thing = nameModule name == nameModule (getName thing)+++{-+************************************************************************+*                                                                      *+           Checks for wired-in things+*                                                                      *+************************************************************************++Note [Loading instances for wired-in things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to make sure that we have at least *read* the interface files+for any module with an instance decl or RULE that we might want.++* If the instance decl is an orphan, we have a whole separate mechanism+  (loadOrphanModules)++* If the instance decl is not an orphan, then the act of looking at the+  TyCon or Class will force in the defining module for the+  TyCon/Class, and hence the instance decl++* BUT, if the TyCon is a wired-in TyCon, we don't really need its interface;+  but we must make sure we read its interface in case it has instances or+  rules.  That is what LoadIface.loadWiredInHomeIface does.  It's called+  from TcIface.{tcImportDecl, checkWiredInTyCon, ifCheckWiredInThing}++* HOWEVER, only do this for TyCons.  There are no wired-in Classes.  There+  are some wired-in Ids, but we don't want to load their interfaces. For+  example, Control.Exception.Base.recSelError is wired in, but that module+  is compiled late in the base library, and we don't want to force it to+  load before it's been compiled!++All of this is done by the type checker. The renamer plays no role.+(It used to, but no longer.)+-}++checkWiredInTyCon :: TyCon -> TcM ()+-- Ensure that the home module of the TyCon (and hence its instances)+-- are loaded. See Note [Loading instances for wired-in things]+-- It might not be a wired-in tycon (see the calls in TcUnify),+-- in which case this is a no-op.+checkWiredInTyCon tc+  | not (isWiredInName tc_name)+  = return ()+  | otherwise+  = do  { mod <- getModule+        ; traceIf (text "checkWiredInTyCon" <+> ppr tc_name $$ ppr mod)+        ; ASSERT( isExternalName tc_name )+          when (mod /= nameModule tc_name)+               (initIfaceTcRn (loadWiredInHomeIface tc_name))+                -- Don't look for (non-existent) Float.hi when+                -- compiling Float.hs, which mentions Float of course+                -- A bit yukky to call initIfaceTcRn here+        }+  where+    tc_name = tyConName tc++ifCheckWiredInThing :: TyThing -> IfL ()+-- Even though we are in an interface file, we want to make+-- sure the instances of a wired-in thing are loaded (imagine f :: Double -> Double)+-- Ditto want to ensure that RULES are loaded too+-- See Note [Loading instances for wired-in things]+ifCheckWiredInThing thing+  = do  { mod <- getIfModule+                -- Check whether we are typechecking the interface for this+                -- very module.  E.g when compiling the base library in --make mode+                -- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in+                -- the HPT, so without the test we'll demand-load it into the PIT!+                -- C.f. the same test in checkWiredInTyCon above+        ; let name = getName thing+        ; ASSERT2( isExternalName name, ppr name )+          when (needWiredInHomeIface thing && mod /= nameModule name)+               (loadWiredInHomeIface name) }++needWiredInHomeIface :: TyThing -> Bool+-- Only for TyCons; see Note [Loading instances for wired-in things]+needWiredInHomeIface (ATyCon {}) = True+needWiredInHomeIface _           = False+++{-+************************************************************************+*                                                                      *+        loadSrcInterface, loadOrphanModules, loadInterfaceForName++                These three are called from TcM-land+*                                                                      *+************************************************************************+-}++-- | Load the interface corresponding to an @import@ directive in+-- source code.  On a failure, fail in the monad with an error message.+loadSrcInterface :: SDoc+                 -> ModuleName+                 -> IsBootInterface     -- {-# SOURCE #-} ?+                 -> Maybe FastString    -- "package", if any+                 -> RnM ModIface++loadSrcInterface doc mod want_boot maybe_pkg+  = do { res <- loadSrcInterface_maybe doc mod want_boot maybe_pkg+       ; case res of+           Failed err      -> failWithTc err+           Succeeded iface -> return iface }++-- | Like 'loadSrcInterface', but returns a 'MaybeErr'.+loadSrcInterface_maybe :: SDoc+                       -> ModuleName+                       -> IsBootInterface     -- {-# SOURCE #-} ?+                       -> Maybe FastString    -- "package", if any+                       -> RnM (MaybeErr MsgDoc ModIface)++loadSrcInterface_maybe doc mod want_boot maybe_pkg+  -- We must first find which Module this import refers to.  This involves+  -- calling the Finder, which as a side effect will search the filesystem+  -- and create a ModLocation.  If successful, loadIface will read the+  -- interface; it will call the Finder again, but the ModLocation will be+  -- cached from the first search.+  = do { hsc_env <- getTopEnv+       ; res <- liftIO $ findImportedModule hsc_env mod maybe_pkg+       ; case res of+           Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot)+           -- TODO: Make sure this error message is good+           err         -> return (Failed (cannotFindModule (hsc_dflags hsc_env) mod err)) }++-- | Load interface directly for a fully qualified 'Module'.  (This is a fairly+-- rare operation, but in particular it is used to load orphan modules+-- in order to pull their instances into the global package table and to+-- handle some operations in GHCi).+loadModuleInterface :: SDoc -> Module -> TcM ModIface+loadModuleInterface doc mod = initIfaceTcRn (loadSysInterface doc mod)++-- | Load interfaces for a collection of modules.+loadModuleInterfaces :: SDoc -> [Module] -> TcM ()+loadModuleInterfaces doc mods+  | null mods = return ()+  | otherwise = initIfaceTcRn (mapM_ load mods)+  where+    load mod = loadSysInterface (doc <+> parens (ppr mod)) mod++-- | Loads the interface for a given Name.+-- Should only be called for an imported name;+-- otherwise loadSysInterface may not find the interface+loadInterfaceForName :: SDoc -> Name -> TcRn ModIface+loadInterfaceForName doc name+  = do { when debugIsOn $  -- Check pre-condition+         do { this_mod <- getModule+            ; MASSERT2( not (nameIsLocalOrFrom this_mod name), ppr name <+> parens doc ) }+      ; ASSERT2( isExternalName name, ppr name )+        initIfaceTcRn $ loadSysInterface doc (nameModule name) }++-- | Loads the interface for a given Module.+loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface+loadInterfaceForModule doc m+  = do+    -- Should not be called with this module+    when debugIsOn $ do+      this_mod <- getModule+      MASSERT2( this_mod /= m, ppr m <+> parens doc )+    initIfaceTcRn $ loadSysInterface doc m++{-+*********************************************************+*                                                      *+                loadInterface++        The main function to load an interface+        for an imported module, and put it in+        the External Package State+*                                                      *+*********************************************************+-}++-- | An 'IfM' function to load the home interface for a wired-in thing,+-- so that we're sure that we see its instance declarations and rules+-- See Note [Loading instances for wired-in things]+loadWiredInHomeIface :: Name -> IfM lcl ()+loadWiredInHomeIface name+  = ASSERT( isWiredInName name )+    do _ <- loadSysInterface doc (nameModule name); return ()+  where+    doc = text "Need home interface for wired-in thing" <+> ppr name++------------------+-- | Loads a system interface and throws an exception if it fails+loadSysInterface :: SDoc -> Module -> IfM lcl ModIface+loadSysInterface doc mod_name = loadInterfaceWithException doc mod_name ImportBySystem++------------------+-- | Loads a user interface and throws an exception if it fails. The first parameter indicates+-- whether we should import the boot variant of the module+loadUserInterface :: Bool -> SDoc -> Module -> IfM lcl ModIface+loadUserInterface is_boot doc mod_name+  = loadInterfaceWithException doc mod_name (ImportByUser is_boot)++loadPluginInterface :: SDoc -> Module -> IfM lcl ModIface+loadPluginInterface doc mod_name+  = loadInterfaceWithException doc mod_name ImportByPlugin++------------------+-- | A wrapper for 'loadInterface' that throws an exception if it fails+loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface+loadInterfaceWithException doc mod_name where_from+  = withException (loadInterface doc mod_name where_from)++------------------+loadInterface :: SDoc -> Module -> WhereFrom+              -> IfM lcl (MaybeErr MsgDoc ModIface)++-- loadInterface looks in both the HPT and PIT for the required interface+-- If not found, it loads it, and puts it in the PIT (always).++-- If it can't find a suitable interface file, we+--      a) modify the PackageIfaceTable to have an empty entry+--              (to avoid repeated complaints)+--      b) return (Left message)+--+-- It's not necessarily an error for there not to be an interface+-- file -- perhaps the module has changed, and that interface+-- is no longer used++loadInterface doc_str mod from+  | isHoleModule mod+  -- Hole modules get special treatment+  = do dflags <- getDynFlags+       -- Redo search for our local hole module+       loadInterface doc_str (mkModule (thisPackage dflags) (moduleName mod)) from+  | otherwise+  = do  {       -- Read the state+          (eps,hpt) <- getEpsAndHpt+        ; gbl_env <- getGblEnv++        ; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from)++                -- Check whether we have the interface already+        ; dflags <- getDynFlags+        ; case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of {+            Just iface+                -> return (Succeeded iface) ;   -- Already loaded+                        -- The (src_imp == mi_boot iface) test checks that the already-loaded+                        -- interface isn't a boot iface.  This can conceivably happen,+                        -- if an earlier import had a before we got to real imports.   I think.+            _ -> do {++        -- READ THE MODULE IN+        ; read_result <- case (wantHiBootFile dflags eps mod from) of+                           Failed err             -> return (Failed err)+                           Succeeded hi_boot_file ->+                            -- Stoutly warn against an EPS-updating import+                            -- of one's own boot file! (one-shot only)+                            --See Note [Do not update EPS with your own hi-boot]+                            -- in MkIface.+                            WARN( hi_boot_file &&+                                  fmap fst (if_rec_types gbl_env) == Just mod,+                                  ppr mod )+                            computeInterface doc_str hi_boot_file mod+        ; case read_result of {+            Failed err -> do+                { let fake_iface = emptyModIface mod++                ; updateEps_ $ \eps ->+                        eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface }+                        -- Not found, so add an empty iface to+                        -- the EPS map so that we don't look again++                ; return (Failed err) } ;++        -- Found and parsed!+        -- We used to have a sanity check here that looked for:+        --  * System importing ..+        --  * a home package module ..+        --  * that we know nothing about (mb_dep == Nothing)!+        --+        -- But this is no longer valid because thNameToGhcName allows users to+        -- cause the system to load arbitrary interfaces (by supplying an appropriate+        -- Template Haskell original-name).+            Succeeded (iface, loc) ->+        let+            loc_doc = text loc+        in+        initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ do++        --      Load the new ModIface into the External Package State+        -- Even home-package interfaces loaded by loadInterface+        --      (which only happens in OneShot mode; in Batch/Interactive+        --      mode, home-package modules are loaded one by one into the HPT)+        -- are put in the EPS.+        --+        -- The main thing is to add the ModIface to the PIT, but+        -- we also take the+        --      IfaceDecls, IfaceClsInst, IfaceFamInst, IfaceRules, IfaceVectInfo+        -- out of the ModIface and put them into the big EPS pools++        -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined+        ---    names is done correctly (notably, whether this is an .hi file or .hi-boot file).+        --     If we do loadExport first the wrong info gets into the cache (unless we+        --      explicitly tag each export which seems a bit of a bore)++        ; ignore_prags      <- goptM Opt_IgnoreInterfacePragmas+        ; new_eps_decls     <- loadDecls ignore_prags (mi_decls iface)+        ; new_eps_insts     <- mapM tcIfaceInst (mi_insts iface)+        ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)+        ; new_eps_rules     <- tcIfaceRules ignore_prags (mi_rules iface)+        ; new_eps_anns      <- tcIfaceAnnotations (mi_anns iface)+        ; new_eps_vect_info <- tcIfaceVectInfo mod (mkNameEnv new_eps_decls) (mi_vect_info iface)+        ; new_eps_complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)++        ; let { final_iface = iface {+                                mi_decls     = panic "No mi_decls in PIT",+                                mi_insts     = panic "No mi_insts in PIT",+                                mi_fam_insts = panic "No mi_fam_insts in PIT",+                                mi_rules     = panic "No mi_rules in PIT",+                                mi_anns      = panic "No mi_anns in PIT"+                              }+               }++        ; updateEps_  $ \ eps ->+           if elemModuleEnv mod (eps_PIT eps) || is_external_sig dflags iface+           then eps else+                eps {+                  eps_PIT          = extendModuleEnv (eps_PIT eps) mod final_iface,+                  eps_PTE          = addDeclsToPTE   (eps_PTE eps) new_eps_decls,+                  eps_rule_base    = extendRuleBaseList (eps_rule_base eps)+                                                        new_eps_rules,+                  eps_complete_matches+                                   = extendCompleteMatchMap+                                         (eps_complete_matches eps)+                                         new_eps_complete_sigs,+                  eps_inst_env     = extendInstEnvList (eps_inst_env eps)+                                                       new_eps_insts,+                  eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps)+                                                          new_eps_fam_insts,+                  eps_vect_info    = plusVectInfo (eps_vect_info eps)+                                                  new_eps_vect_info,+                  eps_ann_env      = extendAnnEnvList (eps_ann_env eps)+                                                      new_eps_anns,+                  eps_mod_fam_inst_env+                                   = let+                                       fam_inst_env =+                                         extendFamInstEnvList emptyFamInstEnv+                                                              new_eps_fam_insts+                                     in+                                     extendModuleEnv (eps_mod_fam_inst_env eps)+                                                     mod+                                                     fam_inst_env,+                  eps_stats        = addEpsInStats (eps_stats eps)+                                                   (length new_eps_decls)+                                                   (length new_eps_insts)+                                                   (length new_eps_rules) }++        ; return (Succeeded final_iface)+    }}}}++-- | Returns @True@ if a 'ModIface' comes from an external package.+-- In this case, we should NOT load it into the EPS; the entities+-- should instead come from the local merged signature interface.+is_external_sig :: DynFlags -> ModIface -> Bool+is_external_sig dflags iface =+    -- It's a signature iface...+    mi_semantic_module iface /= mi_module iface &&+    -- and it's not from the local package+    moduleUnitId (mi_module iface) /= thisPackage dflags++-- | This is an improved version of 'findAndReadIface' which can also+-- handle the case when a user requests @p[A=<B>]:M@ but we only+-- have an interface for @p[A=<A>]:M@ (the indefinite interface.+-- If we are not trying to build code, we load the interface we have,+-- *instantiating it* according to how the holes are specified.+-- (Of course, if we're actually building code, this is a hard error.)+--+-- In the presence of holes, 'computeInterface' has an important invariant:+-- to load module M, its set of transitively reachable requirements must+-- have an up-to-date local hi file for that requirement.  Note that if+-- we are loading the interface of a requirement, this does not+-- apply to the requirement itself; e.g., @p[A=<A>]:A@ does not require+-- A.hi to be up-to-date (and indeed, we MUST NOT attempt to read A.hi, unless+-- we are actually typechecking p.)+computeInterface ::+       SDoc -> IsBootInterface -> Module+    -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))+computeInterface doc_str hi_boot_file mod0 = do+    MASSERT( not (isHoleModule mod0) )+    dflags <- getDynFlags+    case splitModuleInsts mod0 of+        (imod, Just indef) | not (unitIdIsDefinite (thisPackage dflags)) -> do+            r <- findAndReadIface doc_str imod mod0 hi_boot_file+            case r of+                Succeeded (iface0, path) -> do+                    hsc_env <- getTopEnv+                    r <- liftIO $+                        rnModIface hsc_env (indefUnitIdInsts (indefModuleUnitId indef))+                                   Nothing iface0+                    case r of+                        Right x -> return (Succeeded (x, path))+                        Left errs -> liftIO . throwIO . mkSrcErr $ errs+                Failed err -> return (Failed err)+        (mod, _) ->+            findAndReadIface doc_str mod mod0 hi_boot_file++-- | Compute the signatures which must be compiled in order to+-- load the interface for a 'Module'.  The output of this function+-- is always a subset of 'moduleFreeHoles'; it is more precise+-- because in signature @p[A=<A>,B=<B>]:B@, although the free holes+-- are A and B, B might not depend on A at all!+--+-- If this is invoked on a signature, this does NOT include the+-- signature itself; e.g. precise free module holes of+-- @p[A=<A>,B=<B>]:B@ never includes B.+moduleFreeHolesPrecise+    :: SDoc -> Module+    -> TcRnIf gbl lcl (MaybeErr MsgDoc (UniqDSet ModuleName))+moduleFreeHolesPrecise doc_str mod+ | moduleIsDefinite mod = return (Succeeded emptyUniqDSet)+ | otherwise =+   case splitModuleInsts mod of+    (imod, Just indef) -> do+        let insts = indefUnitIdInsts (indefModuleUnitId indef)+        traceIf (text "Considering whether to load" <+> ppr mod <+>+                 text "to compute precise free module holes")+        (eps, hpt) <- getEpsAndHpt+        dflags <- getDynFlags+        case tryEpsAndHpt dflags eps hpt `firstJust` tryDepsCache eps imod insts of+            Just r -> return (Succeeded r)+            Nothing -> readAndCache imod insts+    (_, Nothing) -> return (Succeeded emptyUniqDSet)+  where+    tryEpsAndHpt dflags eps hpt =+        fmap mi_free_holes (lookupIfaceByModule dflags hpt (eps_PIT eps) mod)+    tryDepsCache eps imod insts =+        case lookupInstalledModuleEnv (eps_free_holes eps) imod of+            Just ifhs  -> Just (renameFreeHoles ifhs insts)+            _otherwise -> Nothing+    readAndCache imod insts = do+        mb_iface <- findAndReadIface (text "moduleFreeHolesPrecise" <+> doc_str) imod mod False+        case mb_iface of+            Succeeded (iface, _) -> do+                let ifhs = mi_free_holes iface+                -- Cache it+                updateEps_ (\eps ->+                    eps { eps_free_holes = extendInstalledModuleEnv (eps_free_holes eps) imod ifhs })+                return (Succeeded (renameFreeHoles ifhs insts))+            Failed err -> return (Failed err)++wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom+               -> MaybeErr MsgDoc IsBootInterface+-- Figure out whether we want Foo.hi or Foo.hi-boot+wantHiBootFile dflags eps mod from+  = case from of+       ImportByUser usr_boot+          | usr_boot && not this_package+          -> Failed (badSourceImport mod)+          | otherwise -> Succeeded usr_boot++       ImportByPlugin+          -> Succeeded False++       ImportBySystem+          | not this_package   -- If the module to be imported is not from this package+          -> Succeeded False   -- don't look it up in eps_is_boot, because that is keyed+                               -- on the ModuleName of *home-package* modules only.+                               -- We never import boot modules from other packages!++          | otherwise+          -> case lookupUFM (eps_is_boot eps) (moduleName mod) of+                Just (_, is_boot) -> Succeeded is_boot+                Nothing           -> Succeeded False+                     -- The boot-ness of the requested interface,+                     -- based on the dependencies in directly-imported modules+  where+    this_package = thisPackage dflags == moduleUnitId mod++badSourceImport :: Module -> SDoc+badSourceImport mod+  = hang (text "You cannot {-# SOURCE #-} import a module from another package")+       2 (text "but" <+> quotes (ppr mod) <+> ptext (sLit "is from package")+          <+> quotes (ppr (moduleUnitId mod)))++-----------------------------------------------------+--      Loading type/class/value decls+-- We pass the full Module name here, replete with+-- its package info, so that we can build a Name for+-- each binder with the right package info in it+-- All subsequent lookups, including crucially lookups during typechecking+-- the declaration itself, will find the fully-glorious Name+--+-- We handle ATs specially.  They are not main declarations, but also not+-- implicit things (in particular, adding them to `implicitTyThings' would mess+-- things up in the renaming/type checking of source programs).+-----------------------------------------------------++addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv+addDeclsToPTE pte things = extendNameEnvList pte things++loadDecls :: Bool+          -> [(Fingerprint, IfaceDecl)]+          -> IfL [(Name,TyThing)]+loadDecls ignore_prags ver_decls+   = do { thingss <- mapM (loadDecl ignore_prags) ver_decls+        ; return (concat thingss)+        }++loadDecl :: Bool                    -- Don't load pragmas into the decl pool+          -> (Fingerprint, IfaceDecl)+          -> IfL [(Name,TyThing)]   -- The list can be poked eagerly, but the+                                    -- TyThings are forkM'd thunks+loadDecl ignore_prags (_version, decl)+  = do  {       -- Populate the name cache with final versions of all+                -- the names associated with the decl+          let main_name = ifName decl++        -- Typecheck the thing, lazily+        -- NB. Firstly, the laziness is there in case we never need the+        -- declaration (in one-shot mode), and secondly it is there so that+        -- we don't look up the occurrence of a name before calling mk_new_bndr+        -- on the binder.  This is important because we must get the right name+        -- which includes its nameParent.++        ; thing <- forkM doc $ do { bumpDeclStats main_name+                                  ; tcIfaceDecl ignore_prags decl }++        -- Populate the type environment with the implicitTyThings too.+        --+        -- Note [Tricky iface loop]+        -- ~~~~~~~~~~~~~~~~~~~~~~~~+        -- Summary: The delicate point here is that 'mini-env' must be+        -- buildable from 'thing' without demanding any of the things+        -- 'forkM'd by tcIfaceDecl.+        --+        -- In more detail: Consider the example+        --      data T a = MkT { x :: T a }+        -- The implicitTyThings of T are:  [ <datacon MkT>, <selector x>]+        -- (plus their workers, wrappers, coercions etc etc)+        --+        -- We want to return an environment+        --      [ "MkT" -> <datacon MkT>, "x" -> <selector x>, ... ]+        -- (where the "MkT" is the *Name* associated with MkT, etc.)+        --+        -- We do this by mapping the implicit_names to the associated+        -- TyThings.  By the invariant on ifaceDeclImplicitBndrs and+        -- implicitTyThings, we can use getOccName on the implicit+        -- TyThings to make this association: each Name's OccName should+        -- be the OccName of exactly one implicitTyThing.  So the key is+        -- to define a "mini-env"+        --+        -- [ 'MkT' -> <datacon MkT>, 'x' -> <selector x>, ... ]+        -- where the 'MkT' here is the *OccName* associated with MkT.+        --+        -- However, there is a subtlety: due to how type checking needs+        -- to be staged, we can't poke on the forkM'd thunks inside the+        -- implicitTyThings while building this mini-env.+        -- If we poke these thunks too early, two problems could happen:+        --    (1) When processing mutually recursive modules across+        --        hs-boot boundaries, poking too early will do the+        --        type-checking before the recursive knot has been tied,+        --        so things will be type-checked in the wrong+        --        environment, and necessary variables won't be in+        --        scope.+        --+        --    (2) Looking up one OccName in the mini_env will cause+        --        others to be looked up, which might cause that+        --        original one to be looked up again, and hence loop.+        --+        -- The code below works because of the following invariant:+        -- getOccName on a TyThing does not force the suspended type+        -- checks in order to extract the name. For example, we don't+        -- poke on the "T a" type of <selector x> on the way to+        -- extracting <selector x>'s OccName. Of course, there is no+        -- reason in principle why getting the OccName should force the+        -- thunks, but this means we need to be careful in+        -- implicitTyThings and its helper functions.+        --+        -- All a bit too finely-balanced for my liking.++        -- This mini-env and lookup function mediates between the+        --'Name's n and the map from 'OccName's to the implicit TyThings+        ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing]+              lookup n = case lookupOccEnv mini_env (getOccName n) of+                           Just thing -> thing+                           Nothing    ->+                             pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl))++        ; implicit_names <- mapM lookupIfaceTop (ifaceDeclImplicitBndrs decl)++--         ; traceIf (text "Loading decl for " <> ppr main_name $$ ppr implicit_names)+        ; return $ (main_name, thing) :+                      -- uses the invariant that implicit_names and+                      -- implicitTyThings are bijective+                      [(n, lookup n) | n <- implicit_names]+        }+  where+    doc = text "Declaration for" <+> ppr (ifName decl)++bumpDeclStats :: Name -> IfL ()         -- Record that one more declaration has actually been used+bumpDeclStats name+  = do  { traceIf (text "Loading decl for" <+> ppr name)+        ; updateEps_ (\eps -> let stats = eps_stats eps+                              in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } })+        }++{-+*********************************************************+*                                                      *+\subsection{Reading an interface file}+*                                                      *+*********************************************************++Note [Home module load error]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the sought-for interface is in the current package (as determined+by -package-name flag) then it jolly well should already be in the HPT+because we process home-package modules in dependency order.  (Except+in one-shot mode; see notes with hsc_HPT decl in HscTypes).++It is possible (though hard) to get this error through user behaviour.+  * Suppose package P (modules P1, P2) depends on package Q (modules Q1,+    Q2, with Q2 importing Q1)+  * We compile both packages.+  * Now we edit package Q so that it somehow depends on P+  * Now recompile Q with --make (without recompiling P).+  * Then Q1 imports, say, P1, which in turn depends on Q2. So Q2+    is a home-package module which is not yet in the HPT!  Disaster.++This actually happened with P=base, Q=ghc-prim, via the AMP warnings.+See Trac #8320.+-}++findAndReadIface :: SDoc+                 -- The unique identifier of the on-disk module we're+                 -- looking for+                 -> InstalledModule+                 -- The *actual* module we're looking for.  We use+                 -- this to check the consistency of the requirements+                 -- of the module we read out.+                 -> Module+                 -> IsBootInterface     -- True  <=> Look for a .hi-boot file+                                        -- False <=> Look for .hi file+                 -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))+        -- Nothing <=> file not found, or unreadable, or illegible+        -- Just x  <=> successfully found and parsed++        -- It *doesn't* add an error to the monad, because+        -- sometimes it's ok to fail... see notes with loadInterface+findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file+  = do traceIf (sep [hsep [text "Reading",+                           if hi_boot_file+                             then text "[boot]"+                             else Outputable.empty,+                           text "interface for",+                           ppr mod <> semi],+                     nest 4 (text "reason:" <+> doc_str)])++       -- Check for GHC.Prim, and return its static interface+       -- TODO: make this check a function+       if mod `installedModuleEq` gHC_PRIM+           then do+               iface <- getHooked ghcPrimIfaceHook ghcPrimIface+               return (Succeeded (iface,+                                   "<built in interface for GHC.Prim>"))+           else do+               dflags <- getDynFlags+               -- Look for the file+               hsc_env <- getTopEnv+               mb_found <- liftIO (findExactModule hsc_env mod)+               case mb_found of+                   InstalledFound loc mod -> do+                       -- Found file, so read it+                       let file_path = addBootSuffix_maybe hi_boot_file+                                                           (ml_hi_file loc)++                       -- See Note [Home module load error]+                       if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags &&+                          not (isOneShot (ghcMode dflags))+                           then return (Failed (homeModError mod loc))+                           else do r <- read_file file_path+                                   checkBuildDynamicToo r+                                   return r+                   err -> do+                       traceIf (text "...not found")+                       dflags <- getDynFlags+                       return (Failed (cannotFindInterface dflags+                                           (installedModuleName mod) err))+    where read_file file_path = do+              traceIf (text "readIFace" <+> text file_path)+              -- Figure out what is recorded in mi_module.  If this is+              -- a fully definite interface, it'll match exactly, but+              -- if it's indefinite, the inside will be uninstantiated!+              dflags <- getDynFlags+              let wanted_mod =+                    case splitModuleInsts wanted_mod_with_insts of+                        (_, Nothing) -> wanted_mod_with_insts+                        (_, Just indef_mod) ->+                          indefModuleToModule dflags+                            (generalizeIndefModule indef_mod)+              read_result <- readIface wanted_mod file_path+              case read_result of+                Failed err -> return (Failed (badIfaceFile file_path err))+                Succeeded iface -> return (Succeeded (iface, file_path))+                            -- Don't forget to fill in the package name...+          checkBuildDynamicToo (Succeeded (iface, filePath)) = do+              dflags <- getDynFlags+              -- Indefinite interfaces are ALWAYS non-dynamic, and+              -- that's OK.+              let is_definite_iface = moduleIsDefinite (mi_module iface)+              when is_definite_iface $+                whenGeneratingDynamicToo dflags $ withDoDynamicToo $ do+                  let ref = canGenerateDynamicToo dflags+                      dynFilePath = addBootSuffix_maybe hi_boot_file+                                  $ replaceExtension filePath (dynHiSuf dflags)+                  r <- read_file dynFilePath+                  case r of+                      Succeeded (dynIface, _)+                       | mi_mod_hash iface == mi_mod_hash dynIface ->+                          return ()+                       | otherwise ->+                          do traceIf (text "Dynamic hash doesn't match")+                             liftIO $ writeIORef ref False+                      Failed err ->+                          do traceIf (text "Failed to load dynamic interface file:" $$ err)+                             liftIO $ writeIORef ref False+          checkBuildDynamicToo _ = return ()++-- @readIface@ tries just the one file.++readIface :: Module -> FilePath+          -> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface)+        -- Failed err    <=> file not found, or unreadable, or illegible+        -- Succeeded iface <=> successfully found and parsed++readIface wanted_mod file_path+  = do  { res <- tryMostM $+                 readBinIface CheckHiWay QuietBinIFaceReading file_path+        ; dflags <- getDynFlags+        ; case res of+            Right iface+                -- NB: This check is NOT just a sanity check, it is+                -- critical for correctness of recompilation checking+                -- (it lets us tell when -this-unit-id has changed.)+                | wanted_mod == actual_mod+                                -> return (Succeeded iface)+                | otherwise     -> return (Failed err)+                where+                  actual_mod = mi_module iface+                  err = hiModuleNameMismatchWarn dflags wanted_mod actual_mod++            Left exn    -> return (Failed (text (showException exn)))+    }++{-+*********************************************************+*                                                       *+        Wired-in interface for GHC.Prim+*                                                       *+*********************************************************+-}++initExternalPackageState :: ExternalPackageState+initExternalPackageState+  = EPS {+      eps_is_boot          = emptyUFM,+      eps_PIT              = emptyPackageIfaceTable,+      eps_free_holes       = emptyInstalledModuleEnv,+      eps_PTE              = emptyTypeEnv,+      eps_inst_env         = emptyInstEnv,+      eps_fam_inst_env     = emptyFamInstEnv,+      eps_rule_base        = mkRuleBase builtinRules,+        -- Initialise the EPS rule pool with the built-in rules+      eps_mod_fam_inst_env+                           = emptyModuleEnv,+      eps_vect_info        = noVectInfo,+      eps_complete_matches = emptyUFM,+      eps_ann_env          = emptyAnnEnv,+      eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0+                           , n_insts_in = 0, n_insts_out = 0+                           , n_rules_in = length builtinRules, n_rules_out = 0 }+    }++{-+*********************************************************+*                                                       *+        Wired-in interface for GHC.Prim+*                                                       *+*********************************************************+-}++ghcPrimIface :: ModIface+ghcPrimIface+  = (emptyModIface gHC_PRIM) {+        mi_exports  = ghcPrimExports,+        mi_decls    = [],+        mi_fixities = fixities,+        mi_fix_fn  = mkIfaceFixCache fixities+    }+  where+    fixities = (getOccName seqId, Fixity NoSourceText 0 InfixR)+                                      -- seq is infixr 0+             : (occName funTyConName, funTyFixity)  -- trac #10145+             : mapMaybe mkFixity allThePrimOps+    mkFixity op = (,) (primOpOcc op) <$> primOpFixity op++{-+*********************************************************+*                                                      *+\subsection{Statistics}+*                                                      *+*********************************************************+-}++ifaceStats :: ExternalPackageState -> SDoc+ifaceStats eps+  = hcat [text "Renamer stats: ", msg]+  where+    stats = eps_stats eps+    msg = vcat+        [int (n_ifaces_in stats) <+> text "interfaces read",+         hsep [ int (n_decls_out stats), text "type/class/variable imported, out of",+                int (n_decls_in stats), text "read"],+         hsep [ int (n_insts_out stats), text "instance decls imported, out of",+                int (n_insts_in stats), text "read"],+         hsep [ int (n_rules_out stats), text "rule decls imported, out of",+                int (n_rules_in stats), text "read"]+        ]++{-+************************************************************************+*                                                                      *+                Printing interfaces+*                                                                      *+************************************************************************+-}++-- | Read binary interface, and print it out+showIface :: HscEnv -> FilePath -> IO ()+showIface hsc_env filename = do+   -- skip the hi way check; we don't want to worry about profiled vs.+   -- non-profiled interfaces, for example.+   iface <- initTcRnIf 's' hsc_env () () $+       readBinIface IgnoreHiWay TraceBinIFaceReading filename+   let dflags = hsc_dflags hsc_env+   putLogMsg dflags NoReason SevDump noSrcSpan+      (defaultDumpStyle dflags) (pprModIface iface)++-- Show a ModIface but don't display details; suitable for ModIfaces stored in+-- the EPT.+pprModIfaceSimple :: ModIface -> SDoc+pprModIfaceSimple iface = ppr (mi_module iface) $$ pprDeps (mi_deps iface) $$ nest 2 (vcat (map pprExport (mi_exports iface)))++pprModIface :: ModIface -> SDoc+-- Show a ModIface+pprModIface iface+ = vcat [ text "interface"+                <+> ppr (mi_module iface) <+> pp_hsc_src (mi_hsc_src iface)+                <+> (if mi_orphan iface then text "[orphan module]" else Outputable.empty)+                <+> (if mi_finsts iface then text "[family instance module]" else Outputable.empty)+                <+> (if mi_hpc    iface then text "[hpc]" else Outputable.empty)+                <+> integer hiVersion+        , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash iface))+        , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash iface))+        , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash iface))+        , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface))+        , nest 2 (text "flag hash:" <+> ppr (mi_flag_hash iface))+        , nest 2 (text "sig of:" <+> ppr (mi_sig_of iface))+        , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface))+        , nest 2 (text "where")+        , text "exports:"+        , nest 2 (vcat (map pprExport (mi_exports iface)))+        , pprDeps (mi_deps iface)+        , vcat (map pprUsage (mi_usages iface))+        , vcat (map pprIfaceAnnotation (mi_anns iface))+        , pprFixities (mi_fixities iface)+        , vcat [ppr ver $$ nest 2 (ppr decl) | (ver,decl) <- mi_decls iface]+        , vcat (map ppr (mi_insts iface))+        , vcat (map ppr (mi_fam_insts iface))+        , vcat (map ppr (mi_rules iface))+        , pprVectInfo (mi_vect_info iface)+        , ppr (mi_warns iface)+        , pprTrustInfo (mi_trust iface)+        , pprTrustPkg (mi_trust_pkg iface)+        , vcat (map ppr (mi_complete_sigs iface))+        ]+  where+    pp_hsc_src HsBootFile = text "[boot]"+    pp_hsc_src HsigFile = text "[hsig]"+    pp_hsc_src HsSrcFile = Outputable.empty++{-+When printing export lists, we print like this:+        Avail   f               f+        AvailTC C [C, x, y]     C(x,y)+        AvailTC C [x, y]        C!(x,y)         -- Exporting x, y but not C+-}++pprExport :: IfaceExport -> SDoc+pprExport (Avail n)         = ppr n+pprExport (AvailTC _ [] []) = Outputable.empty+pprExport (AvailTC n ns0 fs)+  = case ns0 of+      (n':ns) | n==n' -> ppr n <> pp_export ns fs+      _               -> ppr n <> vbar <> pp_export ns0 fs+  where+    pp_export []    [] = Outputable.empty+    pp_export names fs = braces (hsep (map ppr names ++ map (ppr . flLabel) fs))++pprUsage :: Usage -> SDoc+pprUsage usage@UsagePackageModule{}+  = pprUsageImport usage usg_mod+pprUsage usage@UsageHomeModule{}+  = pprUsageImport usage usg_mod_name $$+    nest 2 (+        maybe Outputable.empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$+        vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ]+        )+pprUsage usage@UsageFile{}+  = hsep [text "addDependentFile",+          doubleQuotes (text (usg_file_path usage))]+pprUsage usage@UsageMergedRequirement{}+  = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)]++pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc+pprUsageImport usage usg_mod'+  = hsep [text "import", safe, ppr (usg_mod' usage),+                       ppr (usg_mod_hash usage)]+    where+        safe | usg_safe usage = text "safe"+             | otherwise      = text " -/ "++pprDeps :: Dependencies -> SDoc+pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,+                dep_finsts = finsts })+  = vcat [text "module dependencies:" <+> fsep (map ppr_mod mods),+          text "package dependencies:" <+> fsep (map ppr_pkg pkgs),+          text "orphans:" <+> fsep (map ppr orphs),+          text "family instance modules:" <+> fsep (map ppr finsts)+        ]+  where+    ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot+    ppr_pkg (pkg,trust_req)  = ppr pkg <>+                               (if trust_req then text "*" else Outputable.empty)+    ppr_boot True  = text "[boot]"+    ppr_boot False = Outputable.empty++pprFixities :: [(OccName, Fixity)] -> SDoc+pprFixities []    = Outputable.empty+pprFixities fixes = text "fixities" <+> pprWithCommas pprFix fixes+                  where+                    pprFix (occ,fix) = ppr fix <+> ppr occ++pprVectInfo :: IfaceVectInfo -> SDoc+pprVectInfo (IfaceVectInfo { ifaceVectInfoVar            = vars+                           , ifaceVectInfoTyCon          = tycons+                           , ifaceVectInfoTyConReuse     = tyconsReuse+                           , ifaceVectInfoParallelVars   = parallelVars+                           , ifaceVectInfoParallelTyCons = parallelTyCons+                           }) =+  vcat+  [ text "vectorised variables:" <+> hsep (map ppr vars)+  , text "vectorised tycons:" <+> hsep (map ppr tycons)+  , text "vectorised reused tycons:" <+> hsep (map ppr tyconsReuse)+  , text "parallel variables:" <+> hsep (map ppr parallelVars)+  , text "parallel tycons:" <+> hsep (map ppr parallelTyCons)+  ]++pprTrustInfo :: IfaceTrustInfo -> SDoc+pprTrustInfo trust = text "trusted:" <+> ppr trust++pprTrustPkg :: Bool -> SDoc+pprTrustPkg tpkg = text "require own pkg trusted:" <+> ppr tpkg++instance Outputable Warnings where+    ppr = pprWarns++pprWarns :: Warnings -> SDoc+pprWarns NoWarnings         = Outputable.empty+pprWarns (WarnAll txt)  = text "Warn all" <+> ppr txt+pprWarns (WarnSome prs) = text "Warnings"+                        <+> vcat (map pprWarning prs)+    where pprWarning (name, txt) = ppr name <+> ppr txt++pprIfaceAnnotation :: IfaceAnnotation -> SDoc+pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized })+  = ppr target <+> text "annotated by" <+> ppr serialized++{-+*********************************************************+*                                                       *+\subsection{Errors}+*                                                       *+*********************************************************+-}++badIfaceFile :: String -> SDoc -> SDoc+badIfaceFile file err+  = vcat [text "Bad interface file:" <+> text file,+          nest 4 err]++hiModuleNameMismatchWarn :: DynFlags -> Module -> Module -> MsgDoc+hiModuleNameMismatchWarn dflags requested_mod read_mod+ | moduleUnitId requested_mod == moduleUnitId read_mod =+    sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma,+         text "but we were expecting module" <+> quotes (ppr requested_mod),+         sep [text "Probable cause: the source code which generated interface file",+             text "has an incompatible module name"+            ]+        ]+ | otherwise =+  -- ToDo: This will fail to have enough qualification when the package IDs+  -- are the same+  withPprStyle (mkUserStyle dflags alwaysQualify AllTheWay) $+    -- we want the Modules below to be qualified with package names,+    -- so reset the PrintUnqualified setting.+    hsep [ text "Something is amiss; requested module "+         , ppr requested_mod+         , text "differs from name found in the interface file"+         , ppr read_mod+         , parens (text "if these names look the same, try again with -dppr-debug")+         ]++homeModError :: InstalledModule -> ModLocation -> SDoc+-- See Note [Home module load error]+homeModError mod location+  = text "attempting to use module " <> quotes (ppr mod)+    <> (case ml_hs_file location of+           Just file -> space <> parens (text file)+           Nothing   -> Outputable.empty)+    <+> text "which is not loaded"
+ iface/LoadIface.hs-boot view
@@ -0,0 +1,7 @@+module LoadIface where+import Module (Module)+import TcRnMonad (IfM)+import HscTypes (ModIface)+import Outputable (SDoc)++loadSysInterface :: SDoc -> Module -> IfM lcl ModIface
+ iface/MkIface.hs view
@@ -0,0 +1,1815 @@+{-+(c) The University of Glasgow 2006-2008+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998+-}++{-# LANGUAGE CPP, NondecreasingIndentation #-}++-- | Module for constructing @ModIface@ values (interface files),+-- writing them to disk and comparing two versions to see if+-- recompilation is required.+module MkIface (+        mkIface,        -- Build a ModIface from a ModGuts,+                        -- including computing version information++        mkIfaceTc,++        writeIfaceFile, -- Write the interface file++        checkOldIface,  -- See if recompilation is required, by+                        -- comparing version information+        RecompileRequired(..), recompileRequired,+        mkIfaceExports,++        tyThingToIfaceDecl -- Converting things to their Iface equivalents+ ) where++{-+  -----------------------------------------------+          Recompilation checking+  -----------------------------------------------++A complete description of how recompilation checking works can be+found in the wiki commentary:++ http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance++Please read the above page for a top-down description of how this all+works.  Notes below cover specific issues related to the implementation.++Basic idea:++  * In the mi_usages information in an interface, we record the+    fingerprint of each free variable of the module++  * In mkIface, we compute the fingerprint of each exported thing A.f.+    For each external thing that A.f refers to, we include the fingerprint+    of the external reference when computing the fingerprint of A.f.  So+    if anything that A.f depends on changes, then A.f's fingerprint will+    change.+    Also record any dependent files added with+      * addDependentFile+      * #include+      * -optP-include++  * In checkOldIface we compare the mi_usages for the module with+    the actual fingerprint for all each thing recorded in mi_usages+-}++#include "HsVersions.h"++import IfaceSyn+import BinFingerprint+import LoadIface+import ToIface+import FlagChecker++import DsUsage ( mkUsageInfo, mkUsedNames, mkDependencies )+import Id+import Annotations+import CoreSyn+import Class+import TyCon+import CoAxiom+import ConLike+import DataCon+import Type+import TcType+import InstEnv+import FamInstEnv+import TcRnMonad+import HsSyn+import HscTypes+import Finder+import DynFlags+import VarEnv+import VarSet+import Var+import Name+import Avail+import RdrName+import NameEnv+import NameSet+import Module+import BinIface+import ErrUtils+import Digraph+import SrcLoc+import Outputable+import BasicTypes       hiding ( SuccessFlag(..) )+import Unique+import Util             hiding ( eqListBy )+import FastString+import Maybes+import Binary+import Fingerprint+import Exception+import UniqSet+import Packages++import Control.Monad+import Data.Function+import Data.List+import qualified Data.Map as Map+import Data.Ord+import Data.IORef+import System.Directory+import System.FilePath++{-+************************************************************************+*                                                                      *+\subsection{Completing an interface}+*                                                                      *+************************************************************************+-}++mkIface :: HscEnv+        -> Maybe Fingerprint    -- The old fingerprint, if we have it+        -> ModDetails           -- The trimmed, tidied interface+        -> ModGuts              -- Usages, deprecations, etc+        -> IO (ModIface, -- The new one+               Bool)     -- True <=> there was an old Iface, and the+                         --          new one is identical, so no need+                         --          to write it++mkIface hsc_env maybe_old_fingerprint mod_details+         ModGuts{     mg_module       = this_mod,+                      mg_hsc_src      = hsc_src,+                      mg_usages       = usages,+                      mg_used_th      = used_th,+                      mg_deps         = deps,+                      mg_rdr_env      = rdr_env,+                      mg_fix_env      = fix_env,+                      mg_warns        = warns,+                      mg_hpc_info     = hpc_info,+                      mg_safe_haskell = safe_mode,+                      mg_trust_pkg    = self_trust+                    }+        = mkIface_ hsc_env maybe_old_fingerprint+                   this_mod hsc_src used_th deps rdr_env fix_env+                   warns hpc_info self_trust+                   safe_mode usages mod_details++-- | make an interface from the results of typechecking only.  Useful+-- for non-optimising compilation, or where we aren't generating any+-- object code at all ('HscNothing').+mkIfaceTc :: HscEnv+          -> Maybe Fingerprint  -- The old fingerprint, if we have it+          -> SafeHaskellMode    -- The safe haskell mode+          -> ModDetails         -- gotten from mkBootModDetails, probably+          -> TcGblEnv           -- Usages, deprecations, etc+          -> IO (ModIface, Bool)+mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details+  tc_result@TcGblEnv{ tcg_mod = this_mod,+                      tcg_src = hsc_src,+                      tcg_imports = imports,+                      tcg_rdr_env = rdr_env,+                      tcg_fix_env = fix_env,+                      tcg_merged = merged,+                      tcg_warns = warns,+                      tcg_hpc = other_hpc_info,+                      tcg_th_splice_used = tc_splice_used,+                      tcg_dependent_files = dependent_files+                    }+  = do+          let used_names = mkUsedNames tc_result+          deps <- mkDependencies tc_result+          let hpc_info = emptyHpcInfo other_hpc_info+          used_th <- readIORef tc_splice_used+          dep_files <- (readIORef dependent_files)+          -- Do NOT use semantic module here; this_mod in mkUsageInfo+          -- is used solely to decide if we should record a dependency+          -- or not.  When we instantiate a signature, the semantic+          -- module is something we want to record dependencies for,+          -- but if you pass that in here, we'll decide it's the local+          -- module and does not need to be recorded as a dependency.+          -- See Note [Identity versus semantic module]+          usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names dep_files merged+          mkIface_ hsc_env maybe_old_fingerprint+                   this_mod hsc_src+                   used_th deps rdr_env+                   fix_env warns hpc_info+                   (imp_trust_own_pkg imports) safe_mode usages mod_details+++mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> HscSource+         -> Bool -> Dependencies -> GlobalRdrEnv+         -> NameEnv FixItem -> Warnings -> HpcInfo+         -> Bool+         -> SafeHaskellMode+         -> [Usage]+         -> ModDetails+         -> IO (ModIface, Bool)+mkIface_ hsc_env maybe_old_fingerprint+         this_mod hsc_src used_th deps rdr_env fix_env src_warns+         hpc_info pkg_trust_req safe_mode usages+         ModDetails{  md_insts     = insts,+                      md_fam_insts = fam_insts,+                      md_rules     = rules,+                      md_anns      = anns,+                      md_vect_info = vect_info,+                      md_types     = type_env,+                      md_exports   = exports,+                      md_complete_sigs = complete_sigs }+-- NB:  notice that mkIface does not look at the bindings+--      only at the TypeEnv.  The previous Tidy phase has+--      put exactly the info into the TypeEnv that we want+--      to expose in the interface++  = do+    let semantic_mod = canonicalizeHomeModule (hsc_dflags hsc_env) (moduleName this_mod)+        entities = typeEnvElts type_env+        decls  = [ tyThingToIfaceDecl entity+                 | entity <- entities,+                   let name = getName entity,+                   not (isImplicitTyThing entity),+                      -- No implicit Ids and class tycons in the interface file+                   not (isWiredInName name),+                      -- Nor wired-in things; the compiler knows about them anyhow+                   nameIsLocalOrFrom semantic_mod name  ]+                      -- Sigh: see Note [Root-main Id] in TcRnDriver+                      -- NB: ABSOLUTELY need to check against semantic_mod,+                      -- because all of the names in an hsig p[H=<H>]:H+                      -- are going to be for <H>, not the former id!+                      -- See Note [Identity versus semantic module]++        fixities    = sortBy (comparing fst)+          [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]+          -- The order of fixities returned from nameEnvElts is not+          -- deterministic, so we sort by OccName to canonicalize it.+          -- See Note [Deterministic UniqFM] in UniqDFM for more details.+        warns       = src_warns+        iface_rules = map coreRuleToIfaceRule rules+        iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode insts+        iface_fam_insts = map famInstToIfaceFamInst fam_insts+        iface_vect_info = flattenVectInfo vect_info+        trust_info  = setSafeMode safe_mode+        annotations = map mkIfaceAnnotation anns+        icomplete_sigs = map mkIfaceCompleteSig complete_sigs++        intermediate_iface = ModIface {+              mi_module      = this_mod,+              -- Need to record this because it depends on the -instantiated-with flag+              -- which could change+              mi_sig_of      = if semantic_mod == this_mod+                                then Nothing+                                else Just semantic_mod,+              mi_hsc_src     = hsc_src,+              mi_deps        = deps,+              mi_usages      = usages,+              mi_exports     = mkIfaceExports exports,++              -- Sort these lexicographically, so that+              -- the result is stable across compilations+              mi_insts       = sortBy cmp_inst     iface_insts,+              mi_fam_insts   = sortBy cmp_fam_inst iface_fam_insts,+              mi_rules       = sortBy cmp_rule     iface_rules,++              mi_vect_info   = iface_vect_info,++              mi_fixities    = fixities,+              mi_warns       = warns,+              mi_anns        = annotations,+              mi_globals     = maybeGlobalRdrEnv rdr_env,++              -- Left out deliberately: filled in by addFingerprints+              mi_iface_hash  = fingerprint0,+              mi_mod_hash    = fingerprint0,+              mi_flag_hash   = fingerprint0,+              mi_exp_hash    = fingerprint0,+              mi_used_th     = used_th,+              mi_orphan_hash = fingerprint0,+              mi_orphan      = False, -- Always set by addFingerprints, but+                                      -- it's a strict field, so we can't omit it.+              mi_finsts      = False, -- Ditto+              mi_decls       = deliberatelyOmitted "decls",+              mi_hash_fn     = deliberatelyOmitted "hash_fn",+              mi_hpc         = isHpcUsed hpc_info,+              mi_trust       = trust_info,+              mi_trust_pkg   = pkg_trust_req,++              -- And build the cached values+              mi_warn_fn     = mkIfaceWarnCache warns,+              mi_fix_fn      = mkIfaceFixCache fixities,+              mi_complete_sigs = icomplete_sigs }++    (new_iface, no_change_at_all)+          <- {-# SCC "versioninfo" #-}+                   addFingerprints hsc_env maybe_old_fingerprint+                                   intermediate_iface decls++    -- Debug printing+    dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"+                  (pprModIface new_iface)++    -- bug #1617: on reload we weren't updating the PrintUnqualified+    -- correctly.  This stems from the fact that the interface had+    -- not changed, so addFingerprints returns the old ModIface+    -- with the old GlobalRdrEnv (mi_globals).+    let final_iface = new_iface{ mi_globals = maybeGlobalRdrEnv rdr_env }++    return (final_iface, no_change_at_all)+  where+     cmp_rule     = comparing ifRuleName+     -- Compare these lexicographically by OccName, *not* by unique,+     -- because the latter is not stable across compilations:+     cmp_inst     = comparing (nameOccName . ifDFun)+     cmp_fam_inst = comparing (nameOccName . ifFamInstTcName)++     dflags = hsc_dflags hsc_env++     -- We only fill in mi_globals if the module was compiled to byte+     -- code.  Otherwise, the compiler may not have retained all the+     -- top-level bindings and they won't be in the TypeEnv (see+     -- Desugar.addExportFlagsAndRules).  The mi_globals field is used+     -- by GHCi to decide whether the module has its full top-level+     -- scope available. (#5534)+     maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv+     maybeGlobalRdrEnv rdr_env+         | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env+         | otherwise                                   = Nothing++     deliberatelyOmitted :: String -> a+     deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)++     ifFamInstTcName = ifFamInstFam++     flattenVectInfo (VectInfo { vectInfoVar            = vVar+                               , vectInfoTyCon          = vTyCon+                               , vectInfoParallelVars     = vParallelVars+                               , vectInfoParallelTyCons = vParallelTyCons+                               }) =+       IfaceVectInfo+       { ifaceVectInfoVar            = [Var.varName v | (v, _  ) <- dVarEnvElts vVar]+       , ifaceVectInfoTyCon          = [tyConName t   | (t, t_v) <- nameEnvElts vTyCon, t /= t_v]+       , ifaceVectInfoTyConReuse     = [tyConName t   | (t, t_v) <- nameEnvElts vTyCon, t == t_v]+       , ifaceVectInfoParallelVars   = [Var.varName v | v <- dVarSetElems vParallelVars]+       , ifaceVectInfoParallelTyCons = nameSetElemsStable vParallelTyCons+       }++-----------------------------+writeIfaceFile :: DynFlags -> FilePath -> ModIface -> IO ()+writeIfaceFile dflags hi_file_path new_iface+    = do createDirectoryIfMissing True (takeDirectory hi_file_path)+         writeBinIface dflags hi_file_path new_iface+++-- -----------------------------------------------------------------------------+-- Look up parents and versions of Names++-- This is like a global version of the mi_hash_fn field in each ModIface.+-- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get+-- the parent and version info.++mkHashFun+        :: HscEnv                       -- needed to look up versions+        -> ExternalPackageState         -- ditto+        -> (Name -> IO Fingerprint)+mkHashFun hsc_env eps name+  | isHoleModule orig_mod+  = lookup (mkModule (thisPackage dflags) (moduleName orig_mod))+  | otherwise+  = lookup orig_mod+  where+      dflags = hsc_dflags hsc_env+      hpt = hsc_HPT hsc_env+      pit = eps_PIT eps+      occ = nameOccName name+      orig_mod = nameModule name+      lookup mod = do+        MASSERT2( isExternalName name, ppr name )+        iface <- case lookupIfaceByModule dflags hpt pit mod of+                  Just iface -> return iface+                  Nothing -> do+                      -- This can occur when we're writing out ifaces for+                      -- requirements; we didn't do any /real/ typechecking+                      -- so there's no guarantee everything is loaded.+                      -- Kind of a heinous hack.+                      iface <- initIfaceLoad hsc_env . withException+                            $ loadInterface (text "lookupVers2") mod ImportBySystem+                      return iface+        return $ snd (mi_hash_fn iface occ `orElse`+                  pprPanic "lookupVers1" (ppr mod <+> ppr occ))++-- ---------------------------------------------------------------------------+-- Compute fingerprints for the interface++{-+Note [Fingerprinting IfaceDecls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The general idea here is that we first examine the 'IfaceDecl's and determine+the recursive groups of them. We then walk these groups in dependency order,+serializing each contained 'IfaceDecl' to a "Binary" buffer which we then+hash using MD5 to produce a fingerprint for the group.++However, the serialization that we use is a bit funny: we override the @putName@+operation with our own which serializes the hash of a 'Name' instead of the+'Name' itself. This ensures that the fingerprint of a decl changes if anything+in its transitive closure changes. This trick is why we must be careful about+traversing in dependency order: we need to ensure that we have hashes for+everything referenced by the decl which we are fingerprinting.++Moreover, we need to be careful to distinguish between serialization of binding+Names (e.g. the ifName field of a IfaceDecl) and non-binding (e.g. the ifInstCls+field of a IfaceClsInst): only in the non-binding case should we include the+fingerprint; in the binding case we shouldn't since it is merely the name of the+thing that we are currently fingerprinting.+-}++-- | Add fingerprints for top-level declarations to a 'ModIface'.+--+-- See Note [Fingerprinting IfaceDecls]+addFingerprints+        :: HscEnv+        -> Maybe Fingerprint -- the old fingerprint, if any+        -> ModIface          -- The new interface (lacking decls)+        -> [IfaceDecl]       -- The new decls+        -> IO (ModIface,     -- Updated interface+               Bool)         -- True <=> no changes at all;+                             -- no need to write Iface++addFingerprints hsc_env mb_old_fingerprint iface0 new_decls+ = do+   eps <- hscEPS hsc_env+   let+        -- The ABI of a declaration represents everything that is made+        -- visible about the declaration that a client can depend on.+        -- see IfaceDeclABI below.+       declABI :: IfaceDecl -> IfaceDeclABI+       -- TODO: I'm not sure if this should be semantic_mod or this_mod.+       -- See also Note [Identity versus semantic module]+       declABI decl = (this_mod, decl, extras)+        where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts+                                  non_orph_fis decl++       edges :: [(IfaceDeclABI, Unique, [Unique])]+       edges = [ (abi, getUnique (getOccName decl), out)+               | decl <- new_decls+               , let abi = declABI decl+               , let out = localOccs $ freeNamesDeclABI abi+               ]++       name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n+       localOccs =+         map (getUnique . getParent . getOccName)+                        -- NB: names always use semantic module, so+                        -- filtering must be on the semantic module!+                        -- See Note [Identity versus semantic module]+                        . filter ((== semantic_mod) . name_module)+                        . nonDetEltsUniqSet+                   -- It's OK to use nonDetEltsUFM as localOccs is only+                   -- used to construct the edges and+                   -- stronglyConnCompFromEdgedVertices is deterministic+                   -- even with non-deterministic order of edges as+                   -- explained in Note [Deterministic SCC] in Digraph.+          where getParent :: OccName -> OccName+                getParent occ = lookupOccEnv parent_map occ `orElse` occ++        -- maps OccNames to their parents in the current module.+        -- e.g. a reference to a constructor must be turned into a reference+        -- to the TyCon for the purposes of calculating dependencies.+       parent_map :: OccEnv OccName+       parent_map = foldl' extend emptyOccEnv new_decls+          where extend env d =+                  extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ]+                  where n = getOccName d++        -- strongly-connected groups of declarations, in dependency order+       groups :: [SCC IfaceDeclABI]+       groups =+           stronglyConnCompFromEdgedVerticesUniq edges++       global_hash_fn = mkHashFun hsc_env eps++        -- How to output Names when generating the data to fingerprint.+        -- Here we want to output the fingerprint for each top-level+        -- Name, whether it comes from the current module or another+        -- module.  In this way, the fingerprint for a declaration will+        -- change if the fingerprint for anything it refers to (transitively)+        -- changes.+       mk_put_name :: OccEnv (OccName,Fingerprint)+                   -> BinHandle -> Name -> IO  ()+       mk_put_name local_env bh name+          | isWiredInName name  =  putNameLiterally bh name+           -- wired-in names don't have fingerprints+          | otherwise+          = ASSERT2( isExternalName name, ppr name )+            let hash | nameModule name /= semantic_mod =  global_hash_fn name+                     -- Get it from the REAL interface!!+                     -- This will trigger when we compile an hsig file+                     -- and we know a backing impl for it.+                     -- See Note [Identity versus semantic module]+                     | semantic_mod /= this_mod+                     , not (isHoleModule semantic_mod) = global_hash_fn name+                     | otherwise = return (snd (lookupOccEnv local_env (getOccName name)+                           `orElse` pprPanic "urk! lookup local fingerprint"+                                       (ppr name $$ ppr local_env)))+                -- This panic indicates that we got the dependency+                -- analysis wrong, because we needed a fingerprint for+                -- an entity that wasn't in the environment.  To debug+                -- it, turn the panic into a trace, uncomment the+                -- pprTraces below, run the compile again, and inspect+                -- the output and the generated .hi file with+                -- --show-iface.+            in hash >>= put_ bh++        -- take a strongly-connected group of declarations and compute+        -- its fingerprint.++       fingerprint_group :: (OccEnv (OccName,Fingerprint),+                             [(Fingerprint,IfaceDecl)])+                         -> SCC IfaceDeclABI+                         -> IO (OccEnv (OccName,Fingerprint),+                                [(Fingerprint,IfaceDecl)])++       fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi)+          = do let hash_fn = mk_put_name local_env+                   decl = abiDecl abi+               --pprTrace "fingerprinting" (ppr (ifName decl) ) $ do+               hash <- computeFingerprint hash_fn abi+               env' <- extend_hash_env local_env (hash,decl)+               return (env', (hash,decl) : decls_w_hashes)++       fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)+          = do let decls = map abiDecl abis+               local_env1 <- foldM extend_hash_env local_env+                                   (zip (repeat fingerprint0) decls)+               let hash_fn = mk_put_name local_env1+               -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do+               let stable_abis = sortBy cmp_abiNames abis+                -- put the cycle in a canonical order+               hash <- computeFingerprint hash_fn stable_abis+               let pairs = zip (repeat hash) decls+               local_env2 <- foldM extend_hash_env local_env pairs+               return (local_env2, pairs ++ decls_w_hashes)++       -- we have fingerprinted the whole declaration, but we now need+       -- to assign fingerprints to all the OccNames that it binds, to+       -- use when referencing those OccNames in later declarations.+       --+       extend_hash_env :: OccEnv (OccName,Fingerprint)+                       -> (Fingerprint,IfaceDecl)+                       -> IO (OccEnv (OccName,Fingerprint))+       extend_hash_env env0 (hash,d) = do+          return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0+                 (ifaceDeclFingerprints hash d))++   --+   (local_env, decls_w_hashes) <-+       foldM fingerprint_group (emptyOccEnv, []) groups++   -- when calculating fingerprints, we always need to use canonical+   -- ordering for lists of things.  In particular, the mi_deps has various+   -- lists of modules and suchlike, so put these all in canonical order:+   let sorted_deps = sortDependencies (mi_deps iface0)++   -- The export hash of a module depends on the orphan hashes of the+   -- orphan modules below us in the dependency tree.  This is the way+   -- that changes in orphans get propagated all the way up the+   -- dependency tree.+   --+   -- Note [A bad dep_orphs optimization]+   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+   -- In a previous version of this code, we filtered out orphan modules which+   -- were not from the home package, justifying it by saying that "we'd+   -- pick up the ABI hashes of the external module instead".  This is wrong.+   -- Suppose that we have:+   --+   --       module External where+   --           instance Show (a -> b)+   --+   --       module Home1 where+   --           import External+   --+   --       module Home2 where+   --           import Home1+   --+   -- The export hash of Home1 needs to reflect the orphan instances of+   -- External. It's true that Home1 will get rebuilt if the orphans+   -- of External, but we also need to make sure Home2 gets rebuilt+   -- as well.  See #12733 for more details.+   let orph_mods+        = filter (/= this_mod) -- Note [Do not update EPS with your own hi-boot]+        $ dep_orphs sorted_deps+   dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods++   -- Note [Do not update EPS with your own hi-boot]+   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+   -- (See also Trac #10182).  When your hs-boot file includes an orphan+   -- instance declaration, you may find that the dep_orphs of a module you+   -- import contains reference to yourself.  DO NOT actually load this module+   -- or add it to the orphan hashes: you're going to provide the orphan+   -- instances yourself, no need to consult hs-boot; if you do load the+   -- interface into EPS, you will see a duplicate orphan instance.++   orphan_hash <- computeFingerprint (mk_put_name local_env)+                                     (map ifDFun orph_insts, orph_rules, orph_fis)++   -- the export list hash doesn't depend on the fingerprints of+   -- the Names it mentions, only the Names themselves, hence putNameLiterally.+   export_hash <- computeFingerprint putNameLiterally+                      (mi_exports iface0,+                       orphan_hash,+                       dep_orphan_hashes,+                       dep_pkgs (mi_deps iface0),+                       -- See Note [Export hash depends on non-orphan family instances]+                       dep_finsts (mi_deps iface0),+                        -- dep_pkgs: see "Package Version Changes" on+                        -- wiki/Commentary/Compiler/RecompilationAvoidance+                       mi_trust iface0)+                        -- Make sure change of Safe Haskell mode causes recomp.++   -- Note [Export hash depends on non-orphan family instances]+   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+   --+   -- Suppose we have:+   --+   --   module A where+   --       type instance F Int = Bool+   --+   --   module B where+   --       import A+   --+   --   module C where+   --       import B+   --+   -- The family instance consistency check for C depends on the dep_finsts of+   -- B.  If we rename module A to A2, when the dep_finsts of B changes, we need+   -- to make sure that C gets rebuilt. Effectively, the dep_finsts are part of+   -- the exports of B, because C always considers them when checking+   -- consistency.+   --+   -- A full discussion is in #12723.+   --+   -- We do NOT need to hash dep_orphs, because this is implied by+   -- dep_orphan_hashes, and we do not need to hash ordinary class instances,+   -- because there is no eager consistency check as there is with type families+   -- (also we didn't store it anywhere!)+   --++   -- put the declarations in a canonical order, sorted by OccName+   let sorted_decls = Map.elems $ Map.fromList $+                          [(getOccName d, e) | e@(_, d) <- decls_w_hashes]++   -- the flag hash depends on:+   --   - (some of) dflags+   -- it returns two hashes, one that shouldn't change+   -- the abi hash and one that should+   flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally++   -- the ABI hash depends on:+   --   - decls+   --   - export list+   --   - orphans+   --   - deprecations+   --   - vect info+   --   - flag abi hash+   mod_hash <- computeFingerprint putNameLiterally+                      (map fst sorted_decls,+                       export_hash,  -- includes orphan_hash+                       mi_warns iface0,+                       mi_vect_info iface0)++   -- The interface hash depends on:+   --   - the ABI hash, plus+   --   - the module level annotations,+   --   - usages+   --   - deps (home and external packages, dependent files)+   --   - hpc+   iface_hash <- computeFingerprint putNameLiterally+                      (mod_hash,+                       ann_fn (mkVarOcc "module"),  -- See mkIfaceAnnCache+                       mi_usages iface0,+                       sorted_deps,+                       mi_hpc iface0)++   let+    no_change_at_all = Just iface_hash == mb_old_fingerprint++    final_iface = iface0 {+                mi_mod_hash    = mod_hash,+                mi_iface_hash  = iface_hash,+                mi_exp_hash    = export_hash,+                mi_orphan_hash = orphan_hash,+                mi_flag_hash   = flag_hash,+                mi_orphan      = not (   all ifRuleAuto orph_rules+                                           -- See Note [Orphans and auto-generated rules]+                                      && null orph_insts+                                      && null orph_fis+                                      && isNoIfaceVectInfo (mi_vect_info iface0)),+                mi_finsts      = not . null $ mi_fam_insts iface0,+                mi_decls       = sorted_decls,+                mi_hash_fn     = lookupOccEnv local_env }+   --+   return (final_iface, no_change_at_all)++  where+    this_mod = mi_module iface0+    semantic_mod = mi_semantic_module iface0+    dflags = hsc_dflags hsc_env+    (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph    (mi_insts iface0)+    (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph    (mi_rules iface0)+    (non_orph_fis,   orph_fis)   = mkOrphMap ifFamInstOrph (mi_fam_insts iface0)+    fix_fn = mi_fix_fn iface0+    ann_fn = mkIfaceAnnCache (mi_anns iface0)++-- | Retrieve the orphan hashes 'mi_orphan_hash' for a list of modules+-- (in particular, the orphan modules which are transitively imported by the+-- current module).+--+-- Q: Why do we need the hash at all, doesn't the list of transitively+-- imported orphan modules suffice?+--+-- A: If one of our transitive imports adds a new orphan instance, our+-- export hash must change so that modules which import us rebuild.  If we just+-- hashed the [Module], the hash would not change even when a new instance was+-- added to a module that already had an orphan instance.+--+-- Q: Why don't we just hash the orphan hashes of our direct dependencies?+-- Why the full transitive closure?+--+-- A: Suppose we have these modules:+--+--      module A where+--          instance Show (a -> b) where+--      module B where+--          import A -- **+--      module C where+--          import A+--          import B+--+-- Whether or not we add or remove the import to A in B affects the+-- orphan hash of B.  But it shouldn't really affect the orphan hash+-- of C.  If we hashed only direct dependencies, there would be no+-- way to tell that the net effect was a wash, and we'd be forced+-- to recompile C and everything else.+getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]+getOrphanHashes hsc_env mods = do+  eps <- hscEPS hsc_env+  let+    hpt        = hsc_HPT hsc_env+    pit        = eps_PIT eps+    dflags     = hsc_dflags hsc_env+    get_orph_hash mod =+          case lookupIfaceByModule dflags hpt pit mod of+            Just iface -> return (mi_orphan_hash iface)+            Nothing    -> do -- similar to 'mkHashFun'+                iface <- initIfaceLoad hsc_env . withException+                            $ loadInterface (text "getOrphanHashes") mod ImportBySystem+                return (mi_orphan_hash iface)++  --+  mapM get_orph_hash mods+++sortDependencies :: Dependencies -> Dependencies+sortDependencies d+ = Deps { dep_mods   = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d),+          dep_pkgs   = sortBy (compare `on` fst) (dep_pkgs d),+          dep_orphs  = sortBy stableModuleCmp (dep_orphs d),+          dep_finsts = sortBy stableModuleCmp (dep_finsts d) }++-- | Creates cached lookup for the 'mi_anns' field of ModIface+-- Hackily, we use "module" as the OccName for any module-level annotations+mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload]+mkIfaceAnnCache anns+  = \n -> lookupOccEnv env n `orElse` []+  where+    pair (IfaceAnnotation target value) =+      (case target of+          NamedTarget occn -> occn+          ModuleTarget _   -> mkVarOcc "module"+      , [value])+    -- flipping (++), so the first argument is always short+    env = mkOccEnv_C (flip (++)) (map pair anns)++{-+************************************************************************+*                                                                      *+          The ABI of an IfaceDecl+*                                                                      *+************************************************************************++Note [The ABI of an IfaceDecl]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The ABI of a declaration consists of:++   (a) the full name of the identifier (inc. module and package,+       because these are used to construct the symbol name by which+       the identifier is known externally).++   (b) the declaration itself, as exposed to clients.  That is, the+       definition of an Id is included in the fingerprint only if+       it is made available as an unfolding in the interface.++   (c) the fixity of the identifier (if it exists)+   (d) for Ids: rules+   (e) for classes: instances, fixity & rules for methods+   (f) for datatypes: instances, fixity & rules for constrs++Items (c)-(f) are not stored in the IfaceDecl, but instead appear+elsewhere in the interface file.  But they are *fingerprinted* with+the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras,+and fingerprinting that as part of the declaration.+-}++type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)++data IfaceDeclExtras+  = IfaceIdExtras IfaceIdExtras++  | IfaceDataExtras+       (Maybe Fixity)           -- Fixity of the tycon itself (if it exists)+       [IfaceInstABI]           -- Local class and family instances of this tycon+                                -- See Note [Orphans] in InstEnv+       [AnnPayload]             -- Annotations of the type itself+       [IfaceIdExtras]          -- For each constructor: fixity, RULES and annotations++  | IfaceClassExtras+       (Maybe Fixity)           -- Fixity of the class itself (if it exists)+       [IfaceInstABI]           -- Local instances of this class *or*+                                --   of its associated data types+                                -- See Note [Orphans] in InstEnv+       [AnnPayload]             -- Annotations of the type itself+       [IfaceIdExtras]          -- For each class method: fixity, RULES and annotations++  | IfaceSynonymExtras (Maybe Fixity) [AnnPayload]++  | IfaceFamilyExtras   (Maybe Fixity) [IfaceInstABI] [AnnPayload]++  | IfaceOtherDeclExtras++data IfaceIdExtras+  = IdExtras+       (Maybe Fixity)           -- Fixity of the Id (if it exists)+       [IfaceRule]              -- Rules for the Id+       [AnnPayload]             -- Annotations for the Id++-- When hashing a class or family instance, we hash only the+-- DFunId or CoAxiom, because that depends on all the+-- information about the instance.+--+type IfaceInstABI = IfExtName   -- Name of DFunId or CoAxiom that is evidence for the instance++abiDecl :: IfaceDeclABI -> IfaceDecl+abiDecl (_, decl, _) = decl++cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering+cmp_abiNames abi1 abi2 = getOccName (abiDecl abi1) `compare`+                         getOccName (abiDecl abi2)++freeNamesDeclABI :: IfaceDeclABI -> NameSet+freeNamesDeclABI (_mod, decl, extras) =+  freeNamesIfDecl decl `unionNameSet` freeNamesDeclExtras extras++freeNamesDeclExtras :: IfaceDeclExtras -> NameSet+freeNamesDeclExtras (IfaceIdExtras id_extras)+  = freeNamesIdExtras id_extras+freeNamesDeclExtras (IfaceDataExtras  _ insts _ subs)+  = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs)+freeNamesDeclExtras (IfaceClassExtras _ insts _ subs)+  = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs)+freeNamesDeclExtras (IfaceSynonymExtras _ _)+  = emptyNameSet+freeNamesDeclExtras (IfaceFamilyExtras _ insts _)+  = mkNameSet insts+freeNamesDeclExtras IfaceOtherDeclExtras+  = emptyNameSet++freeNamesIdExtras :: IfaceIdExtras -> NameSet+freeNamesIdExtras (IdExtras _ rules _) = unionNameSets (map freeNamesIfRule rules)++instance Outputable IfaceDeclExtras where+  ppr IfaceOtherDeclExtras       = Outputable.empty+  ppr (IfaceIdExtras  extras)    = ppr_id_extras extras+  ppr (IfaceSynonymExtras fix anns) = vcat [ppr fix, ppr anns]+  ppr (IfaceFamilyExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns]+  ppr (IfaceDataExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns,+                                                ppr_id_extras_s stuff]+  ppr (IfaceClassExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns,+                                                 ppr_id_extras_s stuff]++ppr_insts :: [IfaceInstABI] -> SDoc+ppr_insts _ = text "<insts>"++ppr_id_extras_s :: [IfaceIdExtras] -> SDoc+ppr_id_extras_s stuff = vcat (map ppr_id_extras stuff)++ppr_id_extras :: IfaceIdExtras -> SDoc+ppr_id_extras (IdExtras fix rules anns) = ppr fix $$ vcat (map ppr rules) $$ vcat (map ppr anns)++-- This instance is used only to compute fingerprints+instance Binary IfaceDeclExtras where+  get _bh = panic "no get for IfaceDeclExtras"+  put_ bh (IfaceIdExtras extras) = do+   putByte bh 1; put_ bh extras+  put_ bh (IfaceDataExtras fix insts anns cons) = do+   putByte bh 2; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh cons+  put_ bh (IfaceClassExtras fix insts anns methods) = do+   putByte bh 3; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh methods+  put_ bh (IfaceSynonymExtras fix anns) = do+   putByte bh 4; put_ bh fix; put_ bh anns+  put_ bh (IfaceFamilyExtras fix finsts anns) = do+   putByte bh 5; put_ bh fix; put_ bh finsts; put_ bh anns+  put_ bh IfaceOtherDeclExtras = putByte bh 6++instance Binary IfaceIdExtras where+  get _bh = panic "no get for IfaceIdExtras"+  put_ bh (IdExtras fix rules anns)= do { put_ bh fix; put_ bh rules; put_ bh anns }++declExtras :: (OccName -> Maybe Fixity)+           -> (OccName -> [AnnPayload])+           -> OccEnv [IfaceRule]+           -> OccEnv [IfaceClsInst]+           -> OccEnv [IfaceFamInst]+           -> IfaceDecl+           -> IfaceDeclExtras++declExtras fix_fn ann_fn rule_env inst_env fi_env decl+  = case decl of+      IfaceId{} -> IfaceIdExtras (id_extras n)+      IfaceData{ifCons=cons} ->+                     IfaceDataExtras (fix_fn n)+                        (map ifFamInstAxiom (lookupOccEnvL fi_env n) +++                         map ifDFun         (lookupOccEnvL inst_env n))+                        (ann_fn n)+                        (map (id_extras . occName . ifConName) (visibleIfConDecls cons))+      IfaceClass{ifBody = IfConcreteClass { ifSigs=sigs, ifATs=ats }} ->+                     IfaceClassExtras (fix_fn n)+                        (map ifDFun $ (concatMap at_extras ats)+                                    ++ lookupOccEnvL inst_env n)+                           -- Include instances of the associated types+                           -- as well as instances of the class (Trac #5147)+                        (ann_fn n)+                        [id_extras (getOccName op) | IfaceClassOp op _ _ <- sigs]+      IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n)+                                           (ann_fn n)+      IfaceFamily{} -> IfaceFamilyExtras (fix_fn n)+                        (map ifFamInstAxiom (lookupOccEnvL fi_env n))+                        (ann_fn n)+      _other -> IfaceOtherDeclExtras+  where+        n = getOccName decl+        id_extras occ = IdExtras (fix_fn occ) (lookupOccEnvL rule_env occ) (ann_fn occ)+        at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (getOccName decl)+++lookupOccEnvL :: OccEnv [v] -> OccName -> [v]+lookupOccEnvL env k = lookupOccEnv env k `orElse` []++{-+-- for testing: use the md5sum command to generate fingerprints and+-- compare the results against our built-in version.+  fp' <- oldMD5 dflags bh+  if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp')+               else return fp++oldMD5 dflags bh = do+  tmp <- newTempName dflags "bin"+  writeBinMem bh tmp+  tmp2 <- newTempName dflags "md5"+  let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2+  r <- system cmd+  case r of+    ExitFailure _ -> throwGhcExceptionIO (PhaseFailed cmd r)+    ExitSuccess -> do+        hash_str <- readFile tmp2+        return $! readHexFingerprint hash_str+-}++----------------------+-- mkOrphMap partitions instance decls or rules into+--      (a) an OccEnv for ones that are not orphans,+--          mapping the local OccName to a list of its decls+--      (b) a list of orphan decls+mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl+          -> [decl]             -- Sorted into canonical order+          -> (OccEnv [decl],    -- Non-orphan decls associated with their key;+                                --      each sublist in canonical order+              [decl])           -- Orphan decls; in canonical order+mkOrphMap get_key decls+  = foldl go (emptyOccEnv, []) decls+  where+    go (non_orphs, orphs) d+        | NotOrphan occ <- get_key d+        = (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs)+        | otherwise = (non_orphs, d:orphs)++{-+************************************************************************+*                                                                      *+       COMPLETE Pragmas+*                                                                      *+************************************************************************+-}++mkIfaceCompleteSig :: CompleteMatch -> IfaceCompleteMatch+mkIfaceCompleteSig (CompleteMatch cls tc) = IfaceCompleteMatch cls tc+++{-+************************************************************************+*                                                                      *+       Keeping track of what we've slurped, and fingerprints+*                                                                      *+************************************************************************+-}+++mkIfaceAnnotation :: Annotation -> IfaceAnnotation+mkIfaceAnnotation (Annotation { ann_target = target, ann_value = payload })+  = IfaceAnnotation {+        ifAnnotatedTarget = fmap nameOccName target,+        ifAnnotatedValue = payload+    }++mkIfaceExports :: [AvailInfo] -> [IfaceExport]  -- Sort to make canonical+mkIfaceExports exports+  = sortBy stableAvailCmp (map sort_subs exports)+  where+    sort_subs :: AvailInfo -> AvailInfo+    sort_subs (Avail n) = Avail n+    sort_subs (AvailTC n [] fs) = AvailTC n [] (sort_flds fs)+    sort_subs (AvailTC n (m:ms) fs)+       | n==m      = AvailTC n (m:sortBy stableNameCmp ms) (sort_flds fs)+       | otherwise = AvailTC n (sortBy stableNameCmp (m:ms)) (sort_flds fs)+       -- Maintain the AvailTC Invariant++    sort_flds = sortBy (stableNameCmp `on` flSelector)++{-+Note [Original module]+~~~~~~~~~~~~~~~~~~~~~+Consider this:+        module X where { data family T }+        module Y( T(..) ) where { import X; data instance T Int = MkT Int }+The exported Avail from Y will look like+        X.T{X.T, Y.MkT}+That is, in Y,+  - only MkT is brought into scope by the data instance;+  - but the parent (used for grouping and naming in T(..) exports) is X.T+  - and in this case we export X.T too++In the result of MkIfaceExports, the names are grouped by defining module,+so we may need to split up a single Avail into multiple ones.++Note [Internal used_names]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Most of the used_names are External Names, but we can have Internal+Names too: see Note [Binders in Template Haskell] in Convert, and+Trac #5362 for an example.  Such Names are always+  - Such Names are always for locally-defined things, for which we+    don't gather usage info, so we can just ignore them in ent_map+  - They are always System Names, hence the assert, just as a double check.+++************************************************************************+*                                                                      *+        Load the old interface file for this module (unless+        we have it already), and check whether it is up to date+*                                                                      *+************************************************************************+-}++data RecompileRequired+  = UpToDate+       -- ^ everything is up to date, recompilation is not required+  | MustCompile+       -- ^ The .hs file has been touched, or the .o/.hi file does not exist+  | RecompBecause String+       -- ^ The .o/.hi files are up to date, but something else has changed+       -- to force recompilation; the String says what (one-line summary)+   deriving Eq++recompileRequired :: RecompileRequired -> Bool+recompileRequired UpToDate = False+recompileRequired _ = True++++-- | Top level function to check if the version of an old interface file+-- is equivalent to the current source file the user asked us to compile.+-- If the same, we can avoid recompilation. We return a tuple where the+-- first element is a bool saying if we should recompile the object file+-- and the second is maybe the interface file, where Nothng means to+-- rebuild the interface file not use the exisitng one.+checkOldIface+  :: HscEnv+  -> ModSummary+  -> SourceModified+  -> Maybe ModIface         -- Old interface from compilation manager, if any+  -> IO (RecompileRequired, Maybe ModIface)++checkOldIface hsc_env mod_summary source_modified maybe_iface+  = do  let dflags = hsc_dflags hsc_env+        showPass dflags $+            "Checking old interface for " +++              (showPpr dflags $ ms_mod mod_summary) +++              " (use -ddump-hi-diffs for more details)"+        initIfaceCheck (text "checkOldIface") hsc_env $+            check_old_iface hsc_env mod_summary source_modified maybe_iface++check_old_iface+  :: HscEnv+  -> ModSummary+  -> SourceModified+  -> Maybe ModIface+  -> IfG (RecompileRequired, Maybe ModIface)++check_old_iface hsc_env mod_summary src_modified maybe_iface+  = let dflags = hsc_dflags hsc_env+        getIface =+            case maybe_iface of+                Just _  -> do+                    traceIf (text "We already have the old interface for" <+>+                      ppr (ms_mod mod_summary))+                    return maybe_iface+                Nothing -> loadIface++        loadIface = do+             let iface_path = msHiFilePath mod_summary+             read_result <- readIface (ms_mod mod_summary) iface_path+             case read_result of+                 Failed err -> do+                     traceIf (text "FYI: cannot read old interface file:" $$ nest 4 err)+                     traceHiDiffs (text "Old interface file was invalid:" $$ nest 4 err)+                     return Nothing+                 Succeeded iface -> do+                     traceIf (text "Read the interface file" <+> text iface_path)+                     return $ Just iface++        src_changed+            | gopt Opt_ForceRecomp (hsc_dflags hsc_env) = True+            | SourceModified <- src_modified = True+            | otherwise = False+    in do+        when src_changed $+            traceHiDiffs (nest 4 $ text "Source file changed or recompilation check turned off")++        case src_changed of+            -- If the source has changed and we're in interactive mode,+            -- avoid reading an interface; just return the one we might+            -- have been supplied with.+            True | not (isObjectTarget $ hscTarget dflags) ->+                return (MustCompile, maybe_iface)++            -- Try and read the old interface for the current module+            -- from the .hi file left from the last time we compiled it+            True -> do+                maybe_iface' <- getIface+                return (MustCompile, maybe_iface')++            False -> do+                maybe_iface' <- getIface+                case maybe_iface' of+                    -- We can't retrieve the iface+                    Nothing    -> return (MustCompile, Nothing)++                    -- We have got the old iface; check its versions+                    -- even in the SourceUnmodifiedAndStable case we+                    -- should check versions because some packages+                    -- might have changed or gone away.+                    Just iface -> checkVersions hsc_env mod_summary iface++-- | Check if a module is still the same 'version'.+--+-- This function is called in the recompilation checker after we have+-- determined that the module M being checked hasn't had any changes+-- to its source file since we last compiled M. So at this point in general+-- two things may have changed that mean we should recompile M:+--   * The interface export by a dependency of M has changed.+--   * The compiler flags specified this time for M have changed+--     in a manner that is significant for recompilation.+-- We return not just if we should recompile the object file but also+-- if we should rebuild the interface file.+checkVersions :: HscEnv+              -> ModSummary+              -> ModIface       -- Old interface+              -> IfG (RecompileRequired, Maybe ModIface)+checkVersions hsc_env mod_summary iface+  = do { traceHiDiffs (text "Considering whether compilation is required for" <+>+                        ppr (mi_module iface) <> colon)++       -- readIface will have verified that the InstalledUnitId matches,+       -- but we ALSO must make sure the instantiation matches up.  See+       -- test case bkpcabal04!+       ; if moduleUnitId (mi_module iface) /= thisPackage (hsc_dflags hsc_env)+            then return (RecompBecause "-this-unit-id changed", Nothing) else do {+       ; recomp <- checkFlagHash hsc_env iface+       ; if recompileRequired recomp then return (recomp, Nothing) else do {+       ; recomp <- checkMergedSignatures mod_summary iface+       ; if recompileRequired recomp then return (recomp, Nothing) else do {+       ; recomp <- checkHsig mod_summary iface+       ; if recompileRequired recomp then return (recomp, Nothing) else do {+       ; recomp <- checkDependencies hsc_env mod_summary iface+       ; if recompileRequired recomp then return (recomp, Just iface) else do {++       -- Source code unchanged and no errors yet... carry on+       --+       -- First put the dependent-module info, read from the old+       -- interface, into the envt, so that when we look for+       -- interfaces we look for the right one (.hi or .hi-boot)+       --+       -- It's just temporary because either the usage check will succeed+       -- (in which case we are done with this module) or it'll fail (in which+       -- case we'll compile the module from scratch anyhow).+       --+       -- We do this regardless of compilation mode, although in --make mode+       -- all the dependent modules should be in the HPT already, so it's+       -- quite redundant+       ; updateEps_ $ \eps  -> eps { eps_is_boot = mod_deps }+       ; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface]+       ; return (recomp, Just iface)+    }}}}}}+  where+    this_pkg = thisPackage (hsc_dflags hsc_env)+    -- This is a bit of a hack really+    mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)+    mod_deps = mkModDeps (dep_mods (mi_deps iface))++-- | Check if an hsig file needs recompilation because its+-- implementing module has changed.+checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired+checkHsig mod_summary iface = do+    dflags <- getDynFlags+    let outer_mod = ms_mod mod_summary+        inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod)+    MASSERT( moduleUnitId outer_mod == thisPackage dflags )+    case inner_mod == mi_semantic_module iface of+        True -> up_to_date (text "implementing module unchanged")+        False -> return (RecompBecause "implementing module changed")++-- | Check the flags haven't changed+checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired+checkFlagHash hsc_env iface = do+    let old_hash = mi_flag_hash iface+    new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env)+                                             (mi_module iface)+                                             putNameLiterally+    case old_hash == new_hash of+        True  -> up_to_date (text "Module flags unchanged")+        False -> out_of_date_hash "flags changed"+                     (text "  Module flags have changed")+                     old_hash new_hash++-- Check that the set of signatures we are merging in match.+-- If the -unit-id flags change, this can change too.+checkMergedSignatures :: ModSummary -> ModIface -> IfG RecompileRequired+checkMergedSignatures mod_summary iface = do+    dflags <- getDynFlags+    let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ]+        new_merged = case Map.lookup (ms_mod_name mod_summary)+                                     (requirementContext (pkgState dflags)) of+                        Nothing -> []+                        Just r -> sort $ map (indefModuleToModule dflags) r+    if old_merged == new_merged+        then up_to_date (text "signatures to merge in unchanged" $$ ppr new_merged)+        else return (RecompBecause "signatures to merge in changed")++-- If the direct imports of this module are resolved to targets that+-- are not among the dependencies of the previous interface file,+-- then we definitely need to recompile.  This catches cases like+--   - an exposed package has been upgraded+--   - we are compiling with different package flags+--   - a home module that was shadowing a package module has been removed+--   - a new home module has been added that shadows a package module+-- See bug #1372.+--+-- Returns (RecompBecause <textual reason>) if recompilation is required.+checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired+checkDependencies hsc_env summary iface+ = checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))+  where+   prev_dep_mods = dep_mods (mi_deps iface)+   prev_dep_pkgs = dep_pkgs (mi_deps iface)++   this_pkg = thisPackage (hsc_dflags hsc_env)++   dep_missing (mb_pkg, L _ mod) = do+     find_res <- liftIO $ findImportedModule hsc_env mod (mb_pkg)+     let reason = moduleNameString mod ++ " changed"+     case find_res of+        Found _ mod+          | pkg == this_pkg+           -> if moduleName mod `notElem` map fst prev_dep_mods+                 then do traceHiDiffs $+                           text "imported module " <> quotes (ppr mod) <>+                           text " not among previous dependencies"+                         return (RecompBecause reason)+                 else+                         return UpToDate+          | otherwise+           -> if toInstalledUnitId pkg `notElem` (map fst prev_dep_pkgs)+                 then do traceHiDiffs $+                           text "imported module " <> quotes (ppr mod) <>+                           text " is from package " <> quotes (ppr pkg) <>+                           text ", which is not among previous dependencies"+                         return (RecompBecause reason)+                 else+                         return UpToDate+           where pkg = moduleUnitId mod+        _otherwise  -> return (RecompBecause reason)++needInterface :: Module -> (ModIface -> IfG RecompileRequired)+              -> IfG RecompileRequired+needInterface mod continue+  = do  -- Load the imported interface if possible+    let doc_str = sep [text "need version info for", ppr mod]+    traceHiDiffs (text "Checking usages for module" <+> ppr mod)++    mb_iface <- loadInterface doc_str mod ImportBySystem+        -- Load the interface, but don't complain on failure;+        -- Instead, get an Either back which we can test++    case mb_iface of+      Failed _ -> do+        traceHiDiffs (sep [text "Couldn't load interface for module",+                           ppr mod])+        return MustCompile+                  -- Couldn't find or parse a module mentioned in the+                  -- old interface file.  Don't complain: it might+                  -- just be that the current module doesn't need that+                  -- import and it's been deleted+      Succeeded iface -> continue iface++-- | Given the usage information extracted from the old+-- M.hi file for the module being compiled, figure out+-- whether M needs to be recompiled.+checkModUsage :: UnitId -> Usage -> IfG RecompileRequired+checkModUsage _this_pkg UsagePackageModule{+                                usg_mod = mod,+                                usg_mod_hash = old_mod_hash }+  = needInterface mod $ \iface -> do+    let reason = moduleNameString (moduleName mod) ++ " changed"+    checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface)+        -- We only track the ABI hash of package modules, rather than+        -- individual entity usages, so if the ABI hash changes we must+        -- recompile.  This is safe but may entail more recompilation when+        -- a dependent package has changed.++checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash }+  = needInterface mod $ \iface -> do+    let reason = moduleNameString (moduleName mod) ++ " changed (raw)"+    checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface)++checkModUsage this_pkg UsageHomeModule{+                                usg_mod_name = mod_name,+                                usg_mod_hash = old_mod_hash,+                                usg_exports = maybe_old_export_hash,+                                usg_entities = old_decl_hash }+  = do+    let mod = mkModule this_pkg mod_name+    needInterface mod $ \iface -> do++    let+        new_mod_hash    = mi_mod_hash    iface+        new_decl_hash   = mi_hash_fn     iface+        new_export_hash = mi_exp_hash    iface++        reason = moduleNameString mod_name ++ " changed"++        -- CHECK MODULE+    recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash+    if not (recompileRequired recompile)+      then return UpToDate+      else do++        -- CHECK EXPORT LIST+        checkMaybeHash reason maybe_old_export_hash new_export_hash+            (text "  Export list changed") $ do++        -- CHECK ITEMS ONE BY ONE+        recompile <- checkList [ checkEntityUsage reason new_decl_hash u+                               | u <- old_decl_hash]+        if recompileRequired recompile+          then return recompile     -- This one failed, so just bail out now+          else up_to_date (text "  Great!  The bits I use are up to date")+++checkModUsage _this_pkg UsageFile{ usg_file_path = file,+                                   usg_file_hash = old_hash } =+  liftIO $+    handleIO handle $ do+      new_hash <- getFileHash file+      if (old_hash /= new_hash)+         then return recomp+         else return UpToDate+ where+   recomp = RecompBecause (file ++ " changed")+   handle =+#ifdef DEBUG+       \e -> pprTrace "UsageFile" (text (show e)) $ return recomp+#else+       \_ -> return recomp -- if we can't find the file, just recompile, don't fail+#endif++------------------------+checkModuleFingerprint :: String -> Fingerprint -> Fingerprint+                       -> IfG RecompileRequired+checkModuleFingerprint reason old_mod_hash new_mod_hash+  | new_mod_hash == old_mod_hash+  = up_to_date (text "Module fingerprint unchanged")++  | otherwise+  = out_of_date_hash reason (text "  Module fingerprint has changed")+                     old_mod_hash new_mod_hash++------------------------+checkMaybeHash :: String -> Maybe Fingerprint -> Fingerprint -> SDoc+               -> IfG RecompileRequired -> IfG RecompileRequired+checkMaybeHash reason maybe_old_hash new_hash doc continue+  | Just hash <- maybe_old_hash, hash /= new_hash+  = out_of_date_hash reason doc hash new_hash+  | otherwise+  = continue++------------------------+checkEntityUsage :: String+                 -> (OccName -> Maybe (OccName, Fingerprint))+                 -> (OccName, Fingerprint)+                 -> IfG RecompileRequired+checkEntityUsage reason new_hash (name,old_hash)+  = case new_hash name of++        Nothing       ->        -- We used it before, but it ain't there now+                          out_of_date reason (sep [text "No longer exported:", ppr name])++        Just (_, new_hash)      -- It's there, but is it up to date?+          | new_hash == old_hash -> do traceHiDiffs (text "  Up to date" <+> ppr name <+> parens (ppr new_hash))+                                       return UpToDate+          | otherwise            -> out_of_date_hash reason (text "  Out of date:" <+> ppr name)+                                                     old_hash new_hash++up_to_date :: SDoc -> IfG RecompileRequired+up_to_date  msg = traceHiDiffs msg >> return UpToDate++out_of_date :: String -> SDoc -> IfG RecompileRequired+out_of_date reason msg = traceHiDiffs msg >> return (RecompBecause reason)++out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired+out_of_date_hash reason msg old_hash new_hash+  = out_of_date reason (hsep [msg, ppr old_hash, text "->", ppr new_hash])++----------------------+checkList :: [IfG RecompileRequired] -> IfG RecompileRequired+-- This helper is used in two places+checkList []             = return UpToDate+checkList (check:checks) = do recompile <- check+                              if recompileRequired recompile+                                then return recompile+                                else checkList checks++{-+************************************************************************+*                                                                      *+                Converting things to their Iface equivalents+*                                                                      *+************************************************************************+-}++tyThingToIfaceDecl :: TyThing -> IfaceDecl+tyThingToIfaceDecl (AnId id)      = idToIfaceDecl id+tyThingToIfaceDecl (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon)+tyThingToIfaceDecl (ACoAxiom ax)  = coAxiomToIfaceDecl ax+tyThingToIfaceDecl (AConLike cl)  = case cl of+    RealDataCon dc -> dataConToIfaceDecl dc -- for ppr purposes only+    PatSynCon ps   -> patSynToIfaceDecl ps++--------------------------+idToIfaceDecl :: Id -> IfaceDecl+-- The Id is already tidied, so that locally-bound names+-- (lambdas, for-alls) already have non-clashing OccNames+-- We can't tidy it here, locally, because it may have+-- free variables in its type or IdInfo+idToIfaceDecl id+  = IfaceId { ifName      = getName id,+              ifType      = toIfaceType (idType id),+              ifIdDetails = toIfaceIdDetails (idDetails id),+              ifIdInfo    = toIfaceIdInfo (idInfo id) }++--------------------------+dataConToIfaceDecl :: DataCon -> IfaceDecl+dataConToIfaceDecl dataCon+  = IfaceId { ifName      = getName dataCon,+              ifType      = toIfaceType (dataConUserType dataCon),+              ifIdDetails = IfVanillaId,+              ifIdInfo    = NoInfo }++--------------------------+coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl+-- We *do* tidy Axioms, because they are not (and cannot+-- conveniently be) built in tidy form+coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches+                               , co_ax_role = role })+ = IfaceAxiom { ifName       = getName ax+              , ifTyCon      = toIfaceTyCon tycon+              , ifRole       = role+              , ifAxBranches = map (coAxBranchToIfaceBranch tycon+                                     (map coAxBranchLHS branch_list))+                                   branch_list }+ where+   branch_list = fromBranches branches++-- 2nd parameter is the list of branch LHSs, for conversion from incompatible branches+-- to incompatible indices+-- See Note [Storing compatibility] in CoAxiom+coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch+coAxBranchToIfaceBranch tc lhs_s+                        branch@(CoAxBranch { cab_incomps = incomps })+  = (coAxBranchToIfaceBranch' tc branch) { ifaxbIncomps = iface_incomps }+  where+    iface_incomps = map (expectJust "iface_incomps"+                        . (flip findIndex lhs_s+                          . eqTypes)+                        . coAxBranchLHS) incomps++-- use this one for standalone branches without incompatibles+coAxBranchToIfaceBranch' :: TyCon -> CoAxBranch -> IfaceAxBranch+coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs+                                        , cab_lhs = lhs+                                        , cab_roles = roles, cab_rhs = rhs })+  = IfaceAxBranch { ifaxbTyVars  = toIfaceTvBndrs tidy_tvs+                  , ifaxbCoVars  = map toIfaceIdBndr cvs+                  , ifaxbLHS     = tidyToIfaceTcArgs env1 tc lhs+                  , ifaxbRoles   = roles+                  , ifaxbRHS     = tidyToIfaceType env1 rhs+                  , ifaxbIncomps = [] }+  where+    (env1, tidy_tvs) = tidyTyCoVarBndrs emptyTidyEnv tvs+    -- Don't re-bind in-scope tyvars+    -- See Note [CoAxBranch type variables] in CoAxiom++-----------------+tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl)+-- We *do* tidy TyCons, because they are not (and cannot+-- conveniently be) built in tidy form+-- The returned TidyEnv is the one after tidying the tyConTyVars+tyConToIfaceDecl env tycon+  | Just clas <- tyConClass_maybe tycon+  = classToIfaceDecl env clas++  | Just syn_rhs <- synTyConRhs_maybe tycon+  = ( tc_env1+    , IfaceSynonym { ifName    = getName tycon,+                     ifRoles   = tyConRoles tycon,+                     ifSynRhs  = if_syn_type syn_rhs,+                     ifBinders = if_binders,+                     ifResKind = if_res_kind+                   })++  | Just fam_flav <- famTyConFlav_maybe tycon+  = ( tc_env1+    , IfaceFamily { ifName    = getName tycon,+                    ifResVar  = if_res_var,+                    ifFamFlav = to_if_fam_flav fam_flav,+                    ifBinders = if_binders,+                    ifResKind = if_res_kind,+                    ifFamInj  = familyTyConInjectivityInfo tycon+                  })++  | isAlgTyCon tycon+  = ( tc_env1+    , IfaceData { ifName    = getName tycon,+                  ifBinders = if_binders,+                  ifResKind = if_res_kind,+                  ifCType   = tyConCType tycon,+                  ifRoles   = tyConRoles tycon,+                  ifCtxt    = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon),+                  ifCons    = ifaceConDecls (algTyConRhs tycon),+                  ifGadtSyntax = isGadtSyntaxTyCon tycon,+                  ifParent  = parent })++  | otherwise  -- FunTyCon, PrimTyCon, promoted TyCon/DataCon+  -- We only convert these TyCons to IfaceTyCons when we are+  -- just about to pretty-print them, not because we are going+  -- to put them into interface files+  = ( env+    , IfaceData { ifName       = getName tycon,+                  ifBinders    = if_binders,+                  ifResKind    = if_res_kind,+                  ifCType      = Nothing,+                  ifRoles      = tyConRoles tycon,+                  ifCtxt       = [],+                  ifCons       = IfDataTyCon [],+                  ifGadtSyntax = False,+                  ifParent     = IfNoParent })+  where+    -- NOTE: Not all TyCons have `tyConTyVars` field. Forcing this when `tycon`+    -- is one of these TyCons (FunTyCon, PrimTyCon, PromotedDataCon) will cause+    -- an error.+    (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)+    tc_tyvars      = binderVars tc_binders+    if_binders     = toIfaceTyVarBinders tc_binders+    if_res_kind    = tidyToIfaceType tc_env1 (tyConResKind tycon)+    if_syn_type ty = tidyToIfaceType tc_env1 ty+    if_res_var     = getOccFS `fmap` tyConFamilyResVar_maybe tycon++    parent = case tyConFamInstSig_maybe tycon of+               Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax)+                                                   (toIfaceTyCon tc)+                                                   (tidyToIfaceTcArgs tc_env1 tc ty)+               Nothing           -> IfNoParent++    to_if_fam_flav OpenSynFamilyTyCon        = IfaceOpenSynFamilyTyCon+    to_if_fam_flav (ClosedSynFamilyTyCon (Just ax))+      = IfaceClosedSynFamilyTyCon (Just (axn, ibr))+      where defs = fromBranches $ coAxiomBranches ax+            ibr  = map (coAxBranchToIfaceBranch' tycon) defs+            axn  = coAxiomName ax+    to_if_fam_flav (ClosedSynFamilyTyCon Nothing)+      = IfaceClosedSynFamilyTyCon Nothing+    to_if_fam_flav AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon+    to_if_fam_flav (DataFamilyTyCon {})         = IfaceDataFamilyTyCon+    to_if_fam_flav (BuiltInSynFamTyCon {})      = IfaceBuiltInSynFamTyCon++++    ifaceConDecls (NewTyCon { data_con = con })    = IfNewTyCon  (ifaceConDecl con)+    ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)+    ifaceConDecls (TupleTyCon { data_con = con })  = IfDataTyCon [ifaceConDecl con]+    ifaceConDecls (SumTyCon { data_cons = cons })  = IfDataTyCon (map ifaceConDecl cons)+    ifaceConDecls AbstractTyCon                    = IfAbstractTyCon+        -- The AbstractTyCon case happens when a TyCon has been trimmed+        -- during tidying.+        -- Furthermore, tyThingToIfaceDecl is also used in TcRnDriver+        -- for GHCi, when browsing a module, in which case the+        -- AbstractTyCon and TupleTyCon cases are perfectly sensible.+        -- (Tuple declarations are not serialised into interface files.)++    ifaceConDecl data_con+        = IfCon   { ifConName    = dataConName data_con,+                    ifConInfix   = dataConIsInfix data_con,+                    ifConWrapper = isJust (dataConWrapId_maybe data_con),+                    ifConExTvs   = map toIfaceForAllBndr ex_bndrs',+                    ifConEqSpec  = map (to_eq_spec . eqSpecPair) eq_spec,+                    ifConCtxt    = tidyToIfaceContext con_env2 theta,+                    ifConArgTys  = map (tidyToIfaceType con_env2) arg_tys,+                    ifConFields  = dataConFieldLabels data_con,+                    ifConStricts = map (toIfaceBang con_env2)+                                       (dataConImplBangs data_con),+                    ifConSrcStricts = map toIfaceSrcBang+                                          (dataConSrcBangs data_con)}+        where+          (univ_tvs, _ex_tvs, eq_spec, theta, arg_tys, _)+            = dataConFullSig data_con+          ex_bndrs = dataConExTyVarBinders data_con++          -- Tidy the univ_tvs of the data constructor to be identical+          -- to the tyConTyVars of the type constructor.  This means+          -- (a) we don't need to redundantly put them into the interface file+          -- (b) when pretty-printing an Iface data declaration in H98-style syntax,+          --     we know that the type variables will line up+          -- The latter (b) is important because we pretty-print type constructors+          -- by converting to IfaceSyn and pretty-printing that+          con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars))+                     -- A bit grimy, perhaps, but it's simple!++          (con_env2, ex_bndrs') = tidyTyVarBinders con_env1 ex_bndrs+          to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty)++classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)+classToIfaceDecl env clas+  = ( env1+    , IfaceClass { ifName   = getName tycon,+                   ifRoles  = tyConRoles (classTyCon clas),+                   ifBinders = toIfaceTyVarBinders tc_binders,+                   ifBody   = body,+                   ifFDs    = map toIfaceFD clas_fds })+  where+    (_, clas_fds, sc_theta, _, clas_ats, op_stuff)+      = classExtraBigSig clas+    tycon = classTyCon clas++    body | isAbstractTyCon tycon = IfAbstractClass+         | otherwise+         = IfConcreteClass {+                ifClassCtxt   = tidyToIfaceContext env1 sc_theta,+                ifATs    = map toIfaceAT clas_ats,+                ifSigs   = map toIfaceClassOp op_stuff,+                ifMinDef = fmap getOccFS (classMinimalDef clas)+            }++    (env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)++    toIfaceAT :: ClassATItem -> IfaceAT+    toIfaceAT (ATI tc def)+      = IfaceAT if_decl (fmap (tidyToIfaceType env2 . fst) def)+      where+        (env2, if_decl) = tyConToIfaceDecl env1 tc++    toIfaceClassOp (sel_id, def_meth)+        = ASSERT( sel_tyvars == binderVars tc_binders )+          IfaceClassOp (getName sel_id)+                       (tidyToIfaceType env1 op_ty)+                       (fmap toDmSpec def_meth)+        where+                -- Be careful when splitting the type, because of things+                -- like         class Foo a where+                --                op :: (?x :: String) => a -> a+                -- and          class Baz a where+                --                op :: (Ord a) => a -> a+          (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)+          op_ty                = funResultTy rho_ty++    toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType+    toDmSpec (_, VanillaDM)       = VanillaDM+    toDmSpec (_, GenericDM dm_ty) = GenericDM (tidyToIfaceType env1 dm_ty)++    toIfaceFD (tvs1, tvs2) = (map (tidyTyVar env1) tvs1+                             ,map (tidyTyVar env1) tvs2)++--------------------------++tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder)+-- If the type variable "binder" is in scope, don't re-bind it+-- In a class decl, for example, the ATD binders mention+-- (amd must mention) the class tyvars+tidyTyConBinder env@(_, subst) tvb@(TvBndr tv vis)+ = case lookupVarEnv subst tv of+     Just tv' -> (env,  TvBndr tv' vis)+     Nothing  -> tidyTyVarBinder env tvb++tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder])+tidyTyConBinders = mapAccumL tidyTyConBinder++tidyTyVar :: TidyEnv -> TyVar -> FastString+tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv)++--------------------------+instanceToIfaceInst :: ClsInst -> IfaceClsInst+instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag+                             , is_cls_nm = cls_name, is_cls = cls+                             , is_tcs = mb_tcs+                             , is_orphan = orph })+  = ASSERT( cls_name == className cls )+    IfaceClsInst { ifDFun    = dfun_name,+                ifOFlag   = oflag,+                ifInstCls = cls_name,+                ifInstTys = map do_rough mb_tcs,+                ifInstOrph = orph }+  where+    do_rough Nothing  = Nothing+    do_rough (Just n) = Just (toIfaceTyCon_name n)++    dfun_name = idName dfun_id+++--------------------------+famInstToIfaceFamInst :: FamInst -> IfaceFamInst+famInstToIfaceFamInst (FamInst { fi_axiom    = axiom,+                                 fi_fam      = fam,+                                 fi_tcs      = roughs })+  = IfaceFamInst { ifFamInstAxiom    = coAxiomName axiom+                 , ifFamInstFam      = fam+                 , ifFamInstTys      = map do_rough roughs+                 , ifFamInstOrph     = orph }+  where+    do_rough Nothing  = Nothing+    do_rough (Just n) = Just (toIfaceTyCon_name n)++    fam_decl = tyConName $ coAxiomTyCon axiom+    mod = ASSERT( isExternalName (coAxiomName axiom) )+          nameModule (coAxiomName axiom)+    is_local name = nameIsLocalOrFrom mod name++    lhs_names = filterNameSet is_local (orphNamesOfCoCon axiom)++    orph | is_local fam_decl+         = NotOrphan (nameOccName fam_decl)+         | otherwise+         = chooseOrphanAnchor lhs_names++--------------------------+coreRuleToIfaceRule :: CoreRule -> IfaceRule+coreRuleToIfaceRule (BuiltinRule { ru_fn = fn})+  = pprTrace "toHsRule: builtin" (ppr fn) $+    bogusIfaceRule fn++coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn,+                            ru_act = act, ru_bndrs = bndrs,+                            ru_args = args, ru_rhs = rhs,+                            ru_orphan = orph, ru_auto = auto })+  = IfaceRule { ifRuleName  = name, ifActivation = act,+                ifRuleBndrs = map toIfaceBndr bndrs,+                ifRuleHead  = fn,+                ifRuleArgs  = map do_arg args,+                ifRuleRhs   = toIfaceExpr rhs,+                ifRuleAuto  = auto,+                ifRuleOrph  = orph }+  where+        -- For type args we must remove synonyms from the outermost+        -- level.  Reason: so that when we read it back in we'll+        -- construct the same ru_rough field as we have right now;+        -- see tcIfaceRule+    do_arg (Type ty)     = IfaceType (toIfaceType (deNoteType ty))+    do_arg (Coercion co) = IfaceCo   (toIfaceCoercion co)+    do_arg arg           = toIfaceExpr arg++bogusIfaceRule :: Name -> IfaceRule+bogusIfaceRule id_name+  = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,+        ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],+        ifRuleRhs = IfaceExt id_name, ifRuleOrph = IsOrphan,+        ifRuleAuto = True }
+ iface/TcIface.hs view
@@ -0,0 +1,1875 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Type checking of type signatures in interface files+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE NondecreasingIndentation #-}++module TcIface (+        tcLookupImported_maybe,+        importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,+        typecheckIfacesForMerging,+        typecheckIfaceForInstantiate,+        tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,+        tcIfaceVectInfo, tcIfaceAnnotations, tcIfaceCompleteSigs,+        tcIfaceExpr,    -- Desired by HERMIT (Trac #7683)+        tcIfaceGlobal+ ) where++#include "HsVersions.h"++import TcTypeNats(typeNatCoAxiomRules)+import IfaceSyn+import LoadIface+import IfaceEnv+import BuildTyCl+import TcRnMonad+import TcType+import Type+import Coercion+import CoAxiom+import TyCoRep    -- needs to build types & coercions in a knot+import HscTypes+import Annotations+import InstEnv+import FamInstEnv+import CoreSyn+import CoreUtils+import CoreUnfold+import CoreLint+import MkCore+import Id+import MkId+import IdInfo+import Class+import TyCon+import ConLike+import DataCon+import PrelNames+import TysWiredIn+import Literal+import Var+import VarEnv+import VarSet+import Name+import NameEnv+import NameSet+import OccurAnal        ( occurAnalyseExpr )+import Demand+import Module+import UniqFM+import UniqSupply+import Outputable+import Maybes+import SrcLoc+import DynFlags+import Util+import FastString+import BasicTypes hiding ( SuccessFlag(..) )+import ListSetOps+import GHC.Fingerprint+import qualified BooleanFormula as BF++import Data.List+import Control.Monad+import qualified Data.Map as Map++{-+This module takes++        IfaceDecl -> TyThing+        IfaceType -> Type+        etc++An IfaceDecl is populated with RdrNames, and these are not renamed to+Names before typechecking, because there should be no scope errors etc.++        -- For (b) consider: f = \$(...h....)+        -- where h is imported, and calls f via an hi-boot file.+        -- This is bad!  But it is not seen as a staging error, because h+        -- is indeed imported.  We don't want the type-checker to black-hole+        -- when simplifying and compiling the splice!+        --+        -- Simple solution: discard any unfolding that mentions a variable+        -- bound in this module (and hence not yet processed).+        -- The discarding happens when forkM finds a type error.+++************************************************************************+*                                                                      *+                Type-checking a complete interface+*                                                                      *+************************************************************************++Suppose we discover we don't need to recompile.  Then we must type+check the old interface file.  This is a bit different to the+incremental type checking we do as we suck in interface files.  Instead+we do things similarly as when we are typechecking source decls: we+bring into scope the type envt for the interface all at once, using a+knot.  Remember, the decls aren't necessarily in dependency order --+and even if they were, the type decls might be mutually recursive.++Note [Knot-tying typecheckIface]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we are typechecking an interface A.hi, and we come across+a Name for another entity defined in A.hi.  How do we get the+'TyCon', in this case?  There are three cases:++    1) tcHiBootIface in TcIface: We're typechecking an hi-boot file in+    preparation of checking if the hs file we're building+    is compatible.  In this case, we want all of the internal+    TyCons to MATCH the ones that we just constructed during+    typechecking: the knot is thus tied through if_rec_types.++    2) retypecheckLoop in GhcMake: We are retypechecking a+    mutually recursive cluster of hi files, in order to ensure+    that all of the references refer to each other correctly.+    In this case, the knot is tied through the HPT passed in,+    which contains all of the interfaces we are in the process+    of typechecking.++    3) genModDetails in HscMain: We are typechecking an+    old interface to generate the ModDetails.  In this case,+    we do the same thing as (2) and pass in an HPT with+    the HomeModInfo being generated to tie knots.++The upshot is that the CLIENT of this function is responsible+for making sure that the knot is tied correctly.  If you don't,+then you'll get a message saying that we couldn't load the+declaration you wanted.++BTW, in one-shot mode we never call typecheckIface; instead,+loadInterface handles type-checking interface.  In that case,+knots are tied through the EPS.  No problem!+-}++-- Clients of this function be careful, see Note [Knot-tying typecheckIface]+typecheckIface :: ModIface      -- Get the decls from here+               -> IfG ModDetails+typecheckIface iface+  = initIfaceLcl (mi_semantic_module iface) (text "typecheckIface") (mi_boot iface) $ do+        {       -- Get the right set of decls and rules.  If we are compiling without -O+                -- we discard pragmas before typechecking, so that we don't "see"+                -- information that we shouldn't.  From a versioning point of view+                -- It's not actually *wrong* to do so, but in fact GHCi is unable+                -- to handle unboxed tuples, so it must not see unfoldings.+          ignore_prags <- goptM Opt_IgnoreInterfacePragmas++                -- Typecheck the decls.  This is done lazily, so that the knot-tying+                -- within this single module works out right.  It's the callers+                -- job to make sure the knot is tied.+        ; names_w_things <- loadDecls ignore_prags (mi_decls iface)+        ; let type_env = mkNameEnv names_w_things++                -- Now do those rules, instances and annotations+        ; insts     <- mapM tcIfaceInst (mi_insts iface)+        ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)+        ; rules     <- tcIfaceRules ignore_prags (mi_rules iface)+        ; anns      <- tcIfaceAnnotations (mi_anns iface)++                -- Vectorisation information+        ; vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface)++                -- Exports+        ; exports <- ifaceExportNames (mi_exports iface)++                -- Complete Sigs+        ; complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)++                -- Finished+        ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface),+                         -- Careful! If we tug on the TyThing thunks too early+                         -- we'll infinite loop with hs-boot.  See #10083 for+                         -- an example where this would cause non-termination.+                         text "Type envt:" <+> ppr (map fst names_w_things)])+        ; return $ ModDetails { md_types     = type_env+                              , md_insts     = insts+                              , md_fam_insts = fam_insts+                              , md_rules     = rules+                              , md_anns      = anns+                              , md_vect_info = vect_info+                              , md_exports   = exports+                              , md_complete_sigs = complete_sigs+                              }+    }++{-+************************************************************************+*                                                                      *+                Typechecking for merging+*                                                                      *+************************************************************************+-}++-- | Returns true if an 'IfaceDecl' is for @data T@ (an abstract data type)+isAbstractIfaceDecl :: IfaceDecl -> Bool+isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon } = True+isAbstractIfaceDecl IfaceClass{ ifBody = IfAbstractClass } = True+isAbstractIfaceDecl IfaceFamily{ ifFamFlav = IfaceAbstractClosedSynFamilyTyCon } = True+isAbstractIfaceDecl _ = False++ifMaybeRoles :: IfaceDecl -> Maybe [Role]+ifMaybeRoles IfaceData    { ifRoles = rs } = Just rs+ifMaybeRoles IfaceSynonym { ifRoles = rs } = Just rs+ifMaybeRoles IfaceClass   { ifRoles = rs } = Just rs+ifMaybeRoles _ = Nothing++-- | Merge two 'IfaceDecl's together, preferring a non-abstract one.  If+-- both are non-abstract we pick one arbitrarily (and check for consistency+-- later.)+mergeIfaceDecl :: IfaceDecl -> IfaceDecl -> IfaceDecl+mergeIfaceDecl d1 d2+    | isAbstractIfaceDecl d1 = d2 `withRolesFrom` d1+    | isAbstractIfaceDecl d2 = d1 `withRolesFrom` d2+    | IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops1, ifMinDef = bf1 } } <- d1+    , IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops2, ifMinDef = bf2 } } <- d2+    = let ops = nameEnvElts $+                  plusNameEnv_C mergeIfaceClassOp+                    (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops1 ])+                    (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ])+      in d1 { ifBody = (ifBody d1) {+                ifSigs  = ops,+                ifMinDef = BF.mkOr [noLoc bf1, noLoc bf2]+                }+            } `withRolesFrom` d2+    -- It doesn't matter; we'll check for consistency later when+    -- we merge, see 'mergeSignatures'+    | otherwise              = d1 `withRolesFrom` d2++-- Note [Role merging]+-- ~~~~~~~~~~~~~~~~~~~+-- First, why might it be necessary to do a non-trivial role+-- merge?  It may rescue a merge that might otherwise fail:+--+--      signature A where+--          type role T nominal representational+--          data T a b+--+--      signature A where+--          type role T representational nominal+--          data T a b+--+-- A module that defines T as representational in both arguments+-- would successfully fill both signatures, so it would be better+-- if we merged the roles of these types in some nontrivial+-- way.+--+-- However, we have to be very careful about how we go about+-- doing this, because role subtyping is *conditional* on+-- the supertype being NOT representationally injective, e.g.,+-- if we have instead:+--+--      signature A where+--          type role T nominal representational+--          data T a b = T a b+--+--      signature A where+--          type role T representational nominal+--          data T a b = T a b+--+-- Should we merge the definitions of T so that the roles are R/R (or N/N)?+-- Absolutely not: neither resulting type is a subtype of the original+-- types (see Note [Role subtyping]), because data is not representationally+-- injective.+--+-- Thus, merging only occurs when BOTH TyCons in question are+-- representationally injective.  If they're not, no merge.++withRolesFrom :: IfaceDecl -> IfaceDecl -> IfaceDecl+d1 `withRolesFrom` d2+    | Just roles1 <- ifMaybeRoles d1+    , Just roles2 <- ifMaybeRoles d2+    , not (isRepInjectiveIfaceDecl d1 || isRepInjectiveIfaceDecl d2)+    = d1 { ifRoles = mergeRoles roles1 roles2 }+    | otherwise = d1+  where+    mergeRoles roles1 roles2 = zipWith max roles1 roles2++isRepInjectiveIfaceDecl :: IfaceDecl -> Bool+isRepInjectiveIfaceDecl IfaceData{ ifCons = IfDataTyCon _ } = True+isRepInjectiveIfaceDecl IfaceFamily{ ifFamFlav = IfaceDataFamilyTyCon } = True+isRepInjectiveIfaceDecl _ = False++mergeIfaceClassOp :: IfaceClassOp -> IfaceClassOp -> IfaceClassOp+mergeIfaceClassOp op1@(IfaceClassOp _ _ (Just _)) _ = op1+mergeIfaceClassOp _ op2 = op2++-- | Merge two 'OccEnv's of 'IfaceDecl's by 'OccName'.+mergeIfaceDecls :: OccEnv IfaceDecl -> OccEnv IfaceDecl -> OccEnv IfaceDecl+mergeIfaceDecls = plusOccEnv_C mergeIfaceDecl++-- | This is a very interesting function.  Like typecheckIface, we want+-- to type check an interface file into a ModDetails.  However, the use-case+-- for these ModDetails is different: we want to compare all of the+-- ModDetails to ensure they define compatible declarations, and then+-- merge them together.  So in particular, we have to take a different+-- strategy for knot-tying: we first speculatively merge the declarations+-- to get the "base" truth for what we believe the types will be+-- (this is "type computation.")  Then we read everything in relative+-- to this truth and check for compatibility.+--+-- During the merge process, we may need to nondeterministically+-- pick a particular declaration to use, if multiple signatures define+-- the declaration ('mergeIfaceDecl').  If, for all choices, there+-- are no type synonym cycles in the resulting merged graph, then+-- we can show that our choice cannot matter. Consider the+-- set of entities which the declarations depend on: by assumption+-- of acyclicity, we can assume that these have already been shown to be equal+-- to each other (otherwise merging will fail).  Then it must+-- be the case that all candidate declarations here are type-equal+-- (the choice doesn't matter) or there is an inequality (in which+-- case merging will fail.)+--+-- Unfortunately, the choice can matter if there is a cycle.  Consider the+-- following merge:+--+--      signature H where { type A = C;  type B = A; data C      }+--      signature H where { type A = (); data B;     type C = B  }+--+-- If we pick @type A = C@ as our representative, there will be+-- a cycle and merging will fail. But if we pick @type A = ()@ as+-- our representative, no cycle occurs, and we instead conclude+-- that all of the types are unit.  So it seems that we either+-- (a) need a stronger acyclicity check which considers *all*+-- possible choices from a merge, or (b) we must find a selection+-- of declarations which is acyclic, and show that this is always+-- the "best" choice we could have made (ezyang conjectures this+-- is the case but does not have a proof).  For now this is+-- not implemented.+--+-- It's worth noting that at the moment, a data constructor and a+-- type synonym are never compatible.  Consider:+--+--      signature H where { type Int=C;         type B = Int; data C = Int}+--      signature H where { export Prelude.Int; data B;       type C = B; }+--+-- This will be rejected, because the reexported Int in the second+-- signature (a proper data type) is never considered equal to a+-- type synonym.  Perhaps this should be relaxed, where a type synonym+-- in a signature is considered implemented by a data type declaration+-- which matches the reference of the type synonym.+typecheckIfacesForMerging :: Module -> [ModIface] -> IORef TypeEnv -> IfM lcl (TypeEnv, [ModDetails])+typecheckIfacesForMerging mod ifaces tc_env_var =+  -- cannot be boot (False)+  initIfaceLcl mod (text "typecheckIfacesForMerging") False $ do+    ignore_prags <- goptM Opt_IgnoreInterfacePragmas+    -- Build the initial environment+    -- NB: Don't include dfuns here, because we don't want to+    -- serialize them out.  See Note [rnIfaceNeverExported] in RnModIface+    -- NB: But coercions are OK, because they will have the right OccName.+    let mk_decl_env decls+            = mkOccEnv [ (getOccName decl, decl)+                       | decl <- decls+                       , case decl of+                            IfaceId { ifIdDetails = IfDFunId } -> False -- exclude DFuns+                            _ -> True ]+        decl_envs = map (mk_decl_env . map snd . mi_decls) ifaces+                        :: [OccEnv IfaceDecl]+        decl_env = foldl' mergeIfaceDecls emptyOccEnv decl_envs+                        ::  OccEnv IfaceDecl+    -- TODO: change loadDecls to accept w/o Fingerprint+    names_w_things <- loadDecls ignore_prags (map (\x -> (fingerprint0, x))+                                                  (occEnvElts decl_env))+    let global_type_env = mkNameEnv names_w_things+    writeMutVar tc_env_var global_type_env++    -- OK, now typecheck each ModIface using this environment+    details <- forM ifaces $ \iface -> do+        -- See Note [Resolving never-exported Names in TcIface]+        type_env <- fixM $ \type_env -> do+            setImplicitEnvM type_env $ do+                decls <- loadDecls ignore_prags (mi_decls iface)+                return (mkNameEnv decls)+        -- But note that we use this type_env to typecheck references to DFun+        -- in 'IfaceInst'+        setImplicitEnvM type_env $ do+        insts     <- mapM tcIfaceInst (mi_insts iface)+        fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)+        rules     <- tcIfaceRules ignore_prags (mi_rules iface)+        anns      <- tcIfaceAnnotations (mi_anns iface)+        vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface)+        exports   <- ifaceExportNames (mi_exports iface)+        complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)+        return $ ModDetails { md_types     = type_env+                            , md_insts     = insts+                            , md_fam_insts = fam_insts+                            , md_rules     = rules+                            , md_anns      = anns+                            , md_vect_info = vect_info+                            , md_exports   = exports+                            , md_complete_sigs = complete_sigs+                            }+    return (global_type_env, details)++-- | Typecheck a signature 'ModIface' under the assumption that we have+-- instantiated it under some implementation (recorded in 'mi_semantic_module')+-- and want to check if the implementation fills the signature.+--+-- This needs to operate slightly differently than 'typecheckIface'+-- because (1) we have a 'NameShape', from the exports of the+-- implementing module, which we will use to give our top-level+-- declarations the correct 'Name's even when the implementor+-- provided them with a reexport, and (2) we have to deal with+-- DFun silliness (see Note [rnIfaceNeverExported])+typecheckIfaceForInstantiate :: NameShape -> ModIface -> IfM lcl ModDetails+typecheckIfaceForInstantiate nsubst iface =+  initIfaceLclWithSubst (mi_semantic_module iface)+                        (text "typecheckIfaceForInstantiate")+                        (mi_boot iface) nsubst $ do+    ignore_prags <- goptM Opt_IgnoreInterfacePragmas+    -- See Note [Resolving never-exported Names in TcIface]+    type_env <- fixM $ \type_env -> do+        setImplicitEnvM type_env $ do+            decls     <- loadDecls ignore_prags (mi_decls iface)+            return (mkNameEnv decls)+    -- See Note [rnIfaceNeverExported]+    setImplicitEnvM type_env $ do+    insts     <- mapM tcIfaceInst (mi_insts iface)+    fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)+    rules     <- tcIfaceRules ignore_prags (mi_rules iface)+    anns      <- tcIfaceAnnotations (mi_anns iface)+    vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface)+    exports   <- ifaceExportNames (mi_exports iface)+    complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)+    return $ ModDetails { md_types     = type_env+                        , md_insts     = insts+                        , md_fam_insts = fam_insts+                        , md_rules     = rules+                        , md_anns      = anns+                        , md_vect_info = vect_info+                        , md_exports   = exports+                        , md_complete_sigs = complete_sigs+                        }++-- Note [Resolving never-exported Names in TcIface]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- For the high-level overview, see+-- Note [Handling never-exported TyThings under Backpack]+--+-- As described in 'typecheckIfacesForMerging', the splendid innovation+-- of signature merging is to rewrite all Names in each of the signatures+-- we are merging together to a pre-merged structure; this is the key+-- ingredient that lets us solve some problems when merging type+-- synonyms.+--+-- However, when a 'Name' refers to a NON-exported entity, as is the+-- case with the DFun of a ClsInst, or a CoAxiom of a type family,+-- this strategy causes problems: if we pick one and rewrite all+-- references to a shared 'Name', we will accidentally fail to check+-- if the DFun or CoAxioms are compatible, as they will never be+-- checked--only exported entities are checked for compatibility,+-- and a non-exported TyThing is checked WHEN we are checking the+-- ClsInst or type family for compatibility in checkBootDeclM.+-- By virtue of the fact that everything's been pointed to the merged+-- declaration, you'll never notice there's a difference even if there+-- is one.+--+-- Fortunately, there are only a few places in the interface declarations+-- where this can occur, so we replace those calls with 'tcIfaceImplicit',+-- which will consult a local TypeEnv that records any never-exported+-- TyThings which we should wire up with.+--+-- Note that we actually knot-tie this local TypeEnv (the 'fixM'), because a+-- type family can refer to a coercion axiom, all of which are done in one go+-- when we typecheck 'mi_decls'.  An alternate strategy would be to typecheck+-- coercions first before type families, but that seemed more fragile.+--++{-+************************************************************************+*                                                                      *+                Type and class declarations+*                                                                      *+************************************************************************+-}++tcHiBootIface :: HscSource -> Module -> TcRn SelfBootInfo+-- Load the hi-boot iface for the module being compiled,+-- if it indeed exists in the transitive closure of imports+-- Return the ModDetails; Nothing if no hi-boot iface+tcHiBootIface hsc_src mod+  | HsBootFile <- hsc_src            -- Already compiling a hs-boot file+  = return NoSelfBoot+  | otherwise+  = do  { traceIf (text "loadHiBootInterface" <+> ppr mod)++        ; mode <- getGhcMode+        ; if not (isOneShot mode)+                -- In --make and interactive mode, if this module has an hs-boot file+                -- we'll have compiled it already, and it'll be in the HPT+                --+                -- We check wheher the interface is a *boot* interface.+                -- It can happen (when using GHC from Visual Studio) that we+                -- compile a module in TypecheckOnly mode, with a stable,+                -- fully-populated HPT.  In that case the boot interface isn't there+                -- (it's been replaced by the mother module) so we can't check it.+                -- And that's fine, because if M's ModInfo is in the HPT, then+                -- it's been compiled once, and we don't need to check the boot iface+          then do { hpt <- getHpt+                 ; case lookupHpt hpt (moduleName mod) of+                      Just info | mi_boot (hm_iface info)+                                -> mkSelfBootInfo (hm_iface info) (hm_details info)+                      _ -> return NoSelfBoot }+          else do++        -- OK, so we're in one-shot mode.+        -- Re #9245, we always check if there is an hi-boot interface+        -- to check consistency against, rather than just when we notice+        -- that an hi-boot is necessary due to a circular import.+        { read_result <- findAndReadIface+                                need (fst (splitModuleInsts mod)) mod+                                True    -- Hi-boot file++        ; case read_result of {+            Succeeded (iface, _path) -> do { tc_iface <- initIfaceTcRn $ typecheckIface iface+                                           ; mkSelfBootInfo iface tc_iface } ;+            Failed err               ->++        -- There was no hi-boot file. But if there is circularity in+        -- the module graph, there really should have been one.+        -- Since we've read all the direct imports by now,+        -- eps_is_boot will record if any of our imports mention the+        -- current module, which either means a module loop (not+        -- a SOURCE import) or that our hi-boot file has mysteriously+        -- disappeared.+    do  { eps <- getEps+        ; case lookupUFM (eps_is_boot eps) (moduleName mod) of+            Nothing -> return NoSelfBoot -- The typical case++            Just (_, False) -> failWithTc moduleLoop+                -- Someone below us imported us!+                -- This is a loop with no hi-boot in the way++            Just (_mod, True) -> failWithTc (elaborate err)+                -- The hi-boot file has mysteriously disappeared.+    }}}}+  where+    need = text "Need the hi-boot interface for" <+> ppr mod+                 <+> text "to compare against the Real Thing"++    moduleLoop = text "Circular imports: module" <+> quotes (ppr mod)+                     <+> text "depends on itself"++    elaborate err = hang (text "Could not find hi-boot interface for" <+>+                          quotes (ppr mod) <> colon) 4 err+++mkSelfBootInfo :: ModIface -> ModDetails -> TcRn SelfBootInfo+mkSelfBootInfo iface mds+  = do -- NB: This is computed DIRECTLY from the ModIface rather+       -- than from the ModDetails, so that we can query 'sb_tcs'+       -- WITHOUT forcing the contents of the interface.+       let tcs = map ifName+                 . filter isIfaceTyCon+                 . map snd+                 $ mi_decls iface+       return $ SelfBoot { sb_mds = mds+                         , sb_tcs = mkNameSet tcs }+  where+    -- | Retuerns @True@ if, when you call 'tcIfaceDecl' on+    -- this 'IfaceDecl', an ATyCon would be returned.+    -- NB: This code assumes that a TyCon cannot be implicit.+    isIfaceTyCon IfaceId{}      = False+    isIfaceTyCon IfaceData{}    = True+    isIfaceTyCon IfaceSynonym{} = True+    isIfaceTyCon IfaceFamily{}  = True+    isIfaceTyCon IfaceClass{}   = True+    isIfaceTyCon IfaceAxiom{}   = False+    isIfaceTyCon IfacePatSyn{}  = False++{-+************************************************************************+*                                                                      *+                Type and class declarations+*                                                                      *+************************************************************************++When typechecking a data type decl, we *lazily* (via forkM) typecheck+the constructor argument types.  This is in the hope that we may never+poke on those argument types, and hence may never need to load the+interface files for types mentioned in the arg types.++E.g.+        data Foo.S = MkS Baz.T+Maybe we can get away without even loading the interface for Baz!++This is not just a performance thing.  Suppose we have+        data Foo.S = MkS Baz.T+        data Baz.T = MkT Foo.S+(in different interface files, of course).+Now, first we load and typecheck Foo.S, and add it to the type envt.+If we do explore MkS's argument, we'll load and typecheck Baz.T.+If we explore MkT's argument we'll find Foo.S already in the envt.++If we typechecked constructor args eagerly, when loading Foo.S we'd try to+typecheck the type Baz.T.  So we'd fault in Baz.T... and then need Foo.S...+which isn't done yet.++All very cunning. However, there is a rather subtle gotcha which bit+me when developing this stuff.  When we typecheck the decl for S, we+extend the type envt with S, MkS, and all its implicit Ids.  Suppose+(a bug, but it happened) that the list of implicit Ids depended in+turn on the constructor arg types.  Then the following sequence of+events takes place:+        * we build a thunk <t> for the constructor arg tys+        * we build a thunk for the extended type environment (depends on <t>)+        * we write the extended type envt into the global EPS mutvar++Now we look something up in the type envt+        * that pulls on <t>+        * which reads the global type envt out of the global EPS mutvar+        * but that depends in turn on <t>++It's subtle, because, it'd work fine if we typechecked the constructor args+eagerly -- they don't need the extended type envt.  They just get the extended+type envt by accident, because they look at it later.++What this means is that the implicitTyThings MUST NOT DEPEND on any of+the forkM stuff.+-}++tcIfaceDecl :: Bool     -- ^ True <=> discard IdInfo on IfaceId bindings+            -> IfaceDecl+            -> IfL TyThing+tcIfaceDecl = tc_iface_decl Nothing++tc_iface_decl :: Maybe Class  -- ^ For associated type/data family declarations+              -> Bool         -- ^ True <=> discard IdInfo on IfaceId bindings+              -> IfaceDecl+              -> IfL TyThing+tc_iface_decl _ ignore_prags (IfaceId {ifName = name, ifType = iface_type,+                                       ifIdDetails = details, ifIdInfo = info})+  = do  { ty <- tcIfaceType iface_type+        ; details <- tcIdDetails ty details+        ; info <- tcIdInfo ignore_prags name ty info+        ; return (AnId (mkGlobalId details name ty info)) }++tc_iface_decl _ _ (IfaceData {ifName = tc_name,+                          ifCType = cType,+                          ifBinders = binders,+                          ifResKind = res_kind,+                          ifRoles = roles,+                          ifCtxt = ctxt, ifGadtSyntax = gadt_syn,+                          ifCons = rdr_cons,+                          ifParent = mb_parent })+  = bindIfaceTyConBinders_AT binders $ \ binders' -> do+    { res_kind' <- tcIfaceType res_kind++    ; tycon <- fixM $ \ tycon -> do+            { stupid_theta <- tcIfaceCtxt ctxt+            ; parent' <- tc_parent tc_name mb_parent+            ; cons <- tcIfaceDataCons tc_name tycon binders' rdr_cons+            ; return (mkAlgTyCon tc_name binders' res_kind'+                                 roles cType stupid_theta+                                 cons parent' gadt_syn) }+    ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)+    ; return (ATyCon tycon) }+  where+    tc_parent :: Name -> IfaceTyConParent -> IfL AlgTyConFlav+    tc_parent tc_name IfNoParent+      = do { tc_rep_name <- newTyConRepName tc_name+           ; return (VanillaAlgTyCon tc_rep_name) }+    tc_parent _ (IfDataInstance ax_name _ arg_tys)+      = do { ax <- tcIfaceCoAxiom ax_name+           ; let fam_tc  = coAxiomTyCon ax+                 ax_unbr = toUnbranchedAxiom ax+           ; lhs_tys <- tcIfaceTcArgs arg_tys+           ; return (DataFamInstTyCon ax_unbr fam_tc lhs_tys) }++tc_iface_decl _ _ (IfaceSynonym {ifName = tc_name,+                                      ifRoles = roles,+                                      ifSynRhs = rhs_ty,+                                      ifBinders = binders,+                                      ifResKind = res_kind })+   = bindIfaceTyConBinders_AT binders $ \ binders' -> do+     { res_kind' <- tcIfaceType res_kind     -- Note [Synonym kind loop]+     ; rhs      <- forkM (mk_doc tc_name) $+                   tcIfaceType rhs_ty+     ; let tycon = buildSynTyCon tc_name binders' res_kind' roles rhs+     ; return (ATyCon tycon) }+   where+     mk_doc n = text "Type synonym" <+> ppr n++tc_iface_decl parent _ (IfaceFamily {ifName = tc_name,+                                     ifFamFlav = fam_flav,+                                     ifBinders = binders,+                                     ifResKind = res_kind,+                                     ifResVar = res, ifFamInj = inj })+   = bindIfaceTyConBinders_AT binders $ \ binders' -> do+     { res_kind' <- tcIfaceType res_kind    -- Note [Synonym kind loop]+     ; rhs      <- forkM (mk_doc tc_name) $+                   tc_fam_flav tc_name fam_flav+     ; res_name <- traverse (newIfaceName . mkTyVarOccFS) res+     ; let tycon = mkFamilyTyCon tc_name binders' res_kind' res_name rhs parent inj+     ; return (ATyCon tycon) }+   where+     mk_doc n = text "Type synonym" <+> ppr n++     tc_fam_flav :: Name -> IfaceFamTyConFlav -> IfL FamTyConFlav+     tc_fam_flav tc_name IfaceDataFamilyTyCon+       = do { tc_rep_name <- newTyConRepName tc_name+            ; return (DataFamilyTyCon tc_rep_name) }+     tc_fam_flav _ IfaceOpenSynFamilyTyCon= return OpenSynFamilyTyCon+     tc_fam_flav _ (IfaceClosedSynFamilyTyCon mb_ax_name_branches)+       = do { ax <- traverse (tcIfaceCoAxiom . fst) mb_ax_name_branches+            ; return (ClosedSynFamilyTyCon ax) }+     tc_fam_flav _ IfaceAbstractClosedSynFamilyTyCon+         = return AbstractClosedSynFamilyTyCon+     tc_fam_flav _ IfaceBuiltInSynFamTyCon+         = pprPanic "tc_iface_decl"+                    (text "IfaceBuiltInSynFamTyCon in interface file")++tc_iface_decl _parent _ignore_prags+            (IfaceClass {ifName = tc_name,+                         ifRoles = roles,+                         ifBinders = binders,+                         ifFDs = rdr_fds,+                         ifBody = IfAbstractClass})+  = bindIfaceTyConBinders binders $ \ binders' -> do+    { fds  <- mapM tc_fd rdr_fds+    ; cls  <- buildClass tc_name binders' roles fds Nothing+    ; return (ATyCon (classTyCon cls)) }++tc_iface_decl _parent ignore_prags+            (IfaceClass {ifName = tc_name,+                         ifRoles = roles,+                         ifBinders = binders,+                         ifFDs = rdr_fds,+                         ifBody = IfConcreteClass {+                             ifClassCtxt = rdr_ctxt,+                             ifATs = rdr_ats, ifSigs = rdr_sigs,+                             ifMinDef = mindef_occ+                         }})+  = bindIfaceTyConBinders binders $ \ binders' -> do+    { traceIf (text "tc-iface-class1" <+> ppr tc_name)+    ; ctxt <- mapM tc_sc rdr_ctxt+    ; traceIf (text "tc-iface-class2" <+> ppr tc_name)+    ; sigs <- mapM tc_sig rdr_sigs+    ; fds  <- mapM tc_fd rdr_fds+    ; traceIf (text "tc-iface-class3" <+> ppr tc_name)+    ; mindef <- traverse (lookupIfaceTop . mkVarOccFS) mindef_occ+    ; cls  <- fixM $ \ cls -> do+              { ats  <- mapM (tc_at cls) rdr_ats+              ; traceIf (text "tc-iface-class4" <+> ppr tc_name)+              ; buildClass tc_name binders' roles fds (Just (ctxt, ats, sigs, mindef)) }+    ; return (ATyCon (classTyCon cls)) }+  where+   tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred)+        -- The *length* of the superclasses is used by buildClass, and hence must+        -- not be inside the thunk.  But the *content* maybe recursive and hence+        -- must be lazy (via forkM).  Example:+        --     class C (T a) => D a where+        --       data T a+        -- Here the associated type T is knot-tied with the class, and+        -- so we must not pull on T too eagerly.  See Trac #5970++   tc_sig :: IfaceClassOp -> IfL TcMethInfo+   tc_sig (IfaceClassOp op_name rdr_ty dm)+     = do { let doc = mk_op_doc op_name rdr_ty+          ; op_ty <- forkM (doc <+> text "ty") $ tcIfaceType rdr_ty+                -- Must be done lazily for just the same reason as the+                -- type of a data con; to avoid sucking in types that+                -- it mentions unless it's necessary to do so+          ; dm'   <- tc_dm doc dm+          ; return (op_name, op_ty, dm') }++   tc_dm :: SDoc+         -> Maybe (DefMethSpec IfaceType)+         -> IfL (Maybe (DefMethSpec (SrcSpan, Type)))+   tc_dm _   Nothing               = return Nothing+   tc_dm _   (Just VanillaDM)      = return (Just VanillaDM)+   tc_dm doc (Just (GenericDM ty))+        = do { -- Must be done lazily to avoid sucking in types+             ; ty' <- forkM (doc <+> text "dm") $ tcIfaceType ty+             ; return (Just (GenericDM (noSrcSpan, ty'))) }++   tc_at cls (IfaceAT tc_decl if_def)+     = do ATyCon tc <- tc_iface_decl (Just cls) ignore_prags tc_decl+          mb_def <- case if_def of+                      Nothing  -> return Nothing+                      Just def -> forkM (mk_at_doc tc)                 $+                                  extendIfaceTyVarEnv (tyConTyVars tc) $+                                  do { tc_def <- tcIfaceType def+                                     ; return (Just (tc_def, noSrcSpan)) }+                  -- Must be done lazily in case the RHS of the defaults mention+                  -- the type constructor being defined here+                  -- e.g.   type AT a; type AT b = AT [b]   Trac #8002+          return (ATI tc mb_def)++   mk_sc_doc pred = text "Superclass" <+> ppr pred+   mk_at_doc tc = text "Associated type" <+> ppr tc+   mk_op_doc op_name op_ty = text "Class op" <+> sep [ppr op_name, ppr op_ty]++tc_iface_decl _ _ (IfaceAxiom { ifName = tc_name, ifTyCon = tc+                              , ifAxBranches = branches, ifRole = role })+  = do { tc_tycon    <- tcIfaceTyCon tc+       -- Must be done lazily, because axioms are forced when checking+       -- for family instance consistency, and the RHS may mention+       -- a hs-boot declared type constructor that is going to be+       -- defined by this module.+       -- e.g. type instance F Int = ToBeDefined+       -- See Trac #13803+       ; tc_branches <- forkM (text "Axiom branches" <+> ppr tc_name)+                      $ tc_ax_branches branches+       ; let axiom = CoAxiom { co_ax_unique   = nameUnique tc_name+                             , co_ax_name     = tc_name+                             , co_ax_tc       = tc_tycon+                             , co_ax_role     = role+                             , co_ax_branches = manyBranches tc_branches+                             , co_ax_implicit = False }+       ; return (ACoAxiom axiom) }++tc_iface_decl _ _ (IfacePatSyn{ ifName = name+                              , ifPatMatcher = if_matcher+                              , ifPatBuilder = if_builder+                              , ifPatIsInfix = is_infix+                              , ifPatUnivBndrs = univ_bndrs+                              , ifPatExBndrs = ex_bndrs+                              , ifPatProvCtxt = prov_ctxt+                              , ifPatReqCtxt = req_ctxt+                              , ifPatArgs = args+                              , ifPatTy = pat_ty+                              , ifFieldLabels = field_labels })+  = do { traceIf (text "tc_iface_decl" <+> ppr name)+       ; matcher <- tc_pr if_matcher+       ; builder <- fmapMaybeM tc_pr if_builder+       ; bindIfaceForAllBndrs univ_bndrs $ \univ_tvs -> do+       { bindIfaceForAllBndrs ex_bndrs $ \ex_tvs -> do+       { patsyn <- forkM (mk_doc name) $+             do { prov_theta <- tcIfaceCtxt prov_ctxt+                ; req_theta  <- tcIfaceCtxt req_ctxt+                ; pat_ty     <- tcIfaceType pat_ty+                ; arg_tys    <- mapM tcIfaceType args+                ; return $ buildPatSyn name is_infix matcher builder+                                       (univ_tvs, req_theta)+                                       (ex_tvs, prov_theta)+                                       arg_tys pat_ty field_labels }+       ; return $ AConLike . PatSynCon $ patsyn }}}+  where+     mk_doc n = text "Pattern synonym" <+> ppr n+     tc_pr :: (IfExtName, Bool) -> IfL (Id, Bool)+     tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm)+                        ; return (id, b) }++tc_fd :: FunDep IfLclName -> IfL (FunDep TyVar)+tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1+                        ; tvs2' <- mapM tcIfaceTyVar tvs2+                        ; return (tvs1', tvs2') }++tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch]+tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches++tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch]+tc_ax_branch prev_branches+             (IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbCoVars = cv_bndrs+                            , ifaxbLHS = lhs, ifaxbRHS = rhs+                            , ifaxbRoles = roles, ifaxbIncomps = incomps })+  = bindIfaceTyConBinders_AT+      (map (\b -> TvBndr b (NamedTCB Inferred)) tv_bndrs) $ \ tvs ->+         -- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom+    bindIfaceIds cv_bndrs $ \ cvs -> do+    { tc_lhs <- tcIfaceTcArgs lhs+    ; tc_rhs <- tcIfaceType rhs+    ; let br = CoAxBranch { cab_loc     = noSrcSpan+                          , cab_tvs     = binderVars tvs+                          , cab_cvs     = cvs+                          , cab_lhs     = tc_lhs+                          , cab_roles   = roles+                          , cab_rhs     = tc_rhs+                          , cab_incomps = map (prev_branches `getNth`) incomps }+    ; return (prev_branches ++ [br]) }++tcIfaceDataCons :: Name -> TyCon -> [TyConBinder] -> IfaceConDecls -> IfL AlgTyConRhs+tcIfaceDataCons tycon_name tycon tc_tybinders if_cons+  = case if_cons of+        IfAbstractTyCon  -> return AbstractTyCon+        IfDataTyCon cons -> do  { data_cons  <- mapM tc_con_decl cons+                                ; return (mkDataTyConRhs data_cons) }+        IfNewTyCon  con  -> do  { data_con  <- tc_con_decl con+                                ; mkNewTyConRhs tycon_name tycon data_con }+  where+    univ_tv_bndrs :: [TyVarBinder]+    univ_tv_bndrs = mkDataConUnivTyVarBinders tc_tybinders++    tc_con_decl (IfCon { ifConInfix = is_infix,+                         ifConExTvs = ex_bndrs,+                         ifConName = dc_name,+                         ifConCtxt = ctxt, ifConEqSpec = spec,+                         ifConArgTys = args, ifConFields = lbl_names,+                         ifConStricts = if_stricts,+                         ifConSrcStricts = if_src_stricts})+     = -- Universally-quantified tyvars are shared with+       -- parent TyCon, and are already in scope+       bindIfaceForAllBndrs ex_bndrs    $ \ ex_tv_bndrs -> do+        { traceIf (text "Start interface-file tc_con_decl" <+> ppr dc_name)++        -- Read the context and argument types, but lazily for two reasons+        -- (a) to avoid looking tugging on a recursive use of+        --     the type itself, which is knot-tied+        -- (b) to avoid faulting in the component types unless+        --     they are really needed+        ; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc dc_name) $+             do { eq_spec <- tcIfaceEqSpec spec+                ; theta   <- tcIfaceCtxt ctxt+                ; arg_tys <- mapM tcIfaceType args+                ; stricts <- mapM tc_strict if_stricts+                        -- The IfBang field can mention+                        -- the type itself; hence inside forkM+                ; return (eq_spec, theta, arg_tys, stricts) }++        -- Remember, tycon is the representation tycon+        ; let orig_res_ty = mkFamilyTyConApp tycon+                                (substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec))+                                             (binderVars tc_tybinders))++        ; prom_rep_name <- newTyConRepName dc_name++        ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name))+                       dc_name is_infix prom_rep_name+                       (map src_strict if_src_stricts)+                       (Just stricts)+                       -- Pass the HsImplBangs (i.e. final+                       -- decisions) to buildDataCon; it'll use+                       -- these to guide the construction of a+                       -- worker.+                       -- See Note [Bangs on imported data constructors] in MkId+                       lbl_names+                       univ_tv_bndrs ex_tv_bndrs+                       eq_spec theta+                       arg_tys orig_res_ty tycon+        ; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name)+        ; return con }+    mk_doc con_name = text "Constructor" <+> ppr con_name++    tc_strict :: IfaceBang -> IfL HsImplBang+    tc_strict IfNoBang = return (HsLazy)+    tc_strict IfStrict = return (HsStrict)+    tc_strict IfUnpack = return (HsUnpack Nothing)+    tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co+                                      ; return (HsUnpack (Just co)) }++    src_strict :: IfaceSrcBang -> HsSrcBang+    src_strict (IfSrcBang unpk bang) = HsSrcBang NoSourceText unpk bang++tcIfaceEqSpec :: IfaceEqSpec -> IfL [EqSpec]+tcIfaceEqSpec spec+  = mapM do_item spec+  where+    do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ+                              ; ty <- tcIfaceType if_ty+                              ; return (mkEqSpec tv ty) }++{-+Note [Synonym kind loop]+~~~~~~~~~~~~~~~~~~~~~~~~+Notice that we eagerly grab the *kind* from the interface file, but+build a forkM thunk for the *rhs* (and family stuff).  To see why,+consider this (Trac #2412)++M.hs:       module M where { import X; data T = MkT S }+X.hs:       module X where { import {-# SOURCE #-} M; type S = T }+M.hs-boot:  module M where { data T }++When kind-checking M.hs we need S's kind.  But we do not want to+find S's kind from (typeKind S-rhs), because we don't want to look at+S-rhs yet!  Since S is imported from X.hi, S gets just one chance to+be defined, and we must not do that until we've finished with M.T.++Solution: record S's kind in the interface file; now we can safely+look at it.++************************************************************************+*                                                                      *+                Instances+*                                                                      *+************************************************************************+-}++tcIfaceInst :: IfaceClsInst -> IfL ClsInst+tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag+                          , ifInstCls = cls, ifInstTys = mb_tcs+                          , ifInstOrph = orph })+  = do { dfun <- forkM (text "Dict fun" <+> ppr dfun_name) $+                    fmap tyThingId (tcIfaceImplicit dfun_name)+       ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs+       ; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) }++tcIfaceFamInst :: IfaceFamInst -> IfL FamInst+tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs+                             , ifFamInstAxiom = axiom_name } )+    = do { axiom' <- forkM (text "Axiom" <+> ppr axiom_name) $+                     tcIfaceCoAxiom axiom_name+             -- will panic if branched, but that's OK+         ; let axiom'' = toUnbranchedAxiom axiom'+               mb_tcs' = map (fmap ifaceTyConName) mb_tcs+         ; return (mkImportedFamInst fam mb_tcs' axiom'') }++{-+************************************************************************+*                                                                      *+                Rules+*                                                                      *+************************************************************************++We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars+are in the type environment.  However, remember that typechecking a Rule may+(as a side effect) augment the type envt, and so we may need to iterate the process.+-}++tcIfaceRules :: Bool            -- True <=> ignore rules+             -> [IfaceRule]+             -> IfL [CoreRule]+tcIfaceRules ignore_prags if_rules+  | ignore_prags = return []+  | otherwise    = mapM tcIfaceRule if_rules++tcIfaceRule :: IfaceRule -> IfL CoreRule+tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,+                        ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,+                        ifRuleAuto = auto, ifRuleOrph = orph })+  = do  { ~(bndrs', args', rhs') <-+                -- Typecheck the payload lazily, in the hope it'll never be looked at+                forkM (text "Rule" <+> pprRuleName name) $+                bindIfaceBndrs bndrs                      $ \ bndrs' ->+                do { args' <- mapM tcIfaceExpr args+                   ; rhs'  <- tcIfaceExpr rhs+                   ; return (bndrs', args', rhs') }+        ; let mb_tcs = map ifTopFreeName args+        ; this_mod <- getIfModule+        ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act,+                          ru_bndrs = bndrs', ru_args = args',+                          ru_rhs = occurAnalyseExpr rhs',+                          ru_rough = mb_tcs,+                          ru_origin = this_mod,+                          ru_orphan = orph,+                          ru_auto = auto,+                          ru_local = False }) } -- An imported RULE is never for a local Id+                                                -- or, even if it is (module loop, perhaps)+                                                -- we'll just leave it in the non-local set+  where+        -- This function *must* mirror exactly what Rules.roughTopNames does+        -- We could have stored the ru_rough field in the iface file+        -- but that would be redundant, I think.+        -- The only wrinkle is that we must not be deceived by+        -- type synonyms at the top of a type arg.  Since+        -- we can't tell at this point, we are careful not+        -- to write them out in coreRuleToIfaceRule+    ifTopFreeName :: IfaceExpr -> Maybe Name+    ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)+    ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (tcArgsIfaceTypes ts)))+    ifTopFreeName (IfaceApp f _)                    = ifTopFreeName f+    ifTopFreeName (IfaceExt n)                      = Just n+    ifTopFreeName _                                 = Nothing++{-+************************************************************************+*                                                                      *+                Annotations+*                                                                      *+************************************************************************+-}++tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]+tcIfaceAnnotations = mapM tcIfaceAnnotation++tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation+tcIfaceAnnotation (IfaceAnnotation target serialized) = do+    target' <- tcIfaceAnnTarget target+    return $ Annotation {+        ann_target = target',+        ann_value = serialized+    }++tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name)+tcIfaceAnnTarget (NamedTarget occ) = do+    name <- lookupIfaceTop occ+    return $ NamedTarget name+tcIfaceAnnTarget (ModuleTarget mod) = do+    return $ ModuleTarget mod++{-+************************************************************************+*                                                                      *+                Complete Match Pragmas+*                                                                      *+************************************************************************+-}++tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch]+tcIfaceCompleteSigs = mapM tcIfaceCompleteSig++tcIfaceCompleteSig :: IfaceCompleteMatch -> IfL CompleteMatch+tcIfaceCompleteSig (IfaceCompleteMatch ms t) = return (CompleteMatch ms t)++{-+************************************************************************+*                                                                      *+                Vectorisation information+*                                                                      *+************************************************************************+-}++-- We need access to the type environment as we need to look up information about type constructors+-- (i.e., their data constructors and whether they are class type constructors).  If a vectorised+-- type constructor or class is defined in the same module as where it is vectorised, we cannot+-- look that information up from the type constructor that we obtained via a 'forkM'ed+-- 'tcIfaceTyCon' without recursively loading the interface that we are already type checking again+-- and again and again...+--+tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo+tcIfaceVectInfo mod typeEnv (IfaceVectInfo+                             { ifaceVectInfoVar            = vars+                             , ifaceVectInfoTyCon          = tycons+                             , ifaceVectInfoTyConReuse     = tyconsReuse+                             , ifaceVectInfoParallelVars   = parallelVars+                             , ifaceVectInfoParallelTyCons = parallelTyCons+                             })+  = do { let parallelTyConsSet = mkNameSet parallelTyCons+       ; vVars         <- mapM vectVarMapping                  vars+       ; let varsSet = mkVarSet (map fst vVars)+       ; tyConRes1     <- mapM (vectTyConVectMapping varsSet)  tycons+       ; tyConRes2     <- mapM (vectTyConReuseMapping varsSet) tyconsReuse+       ; vParallelVars <- mapM vectVar                         parallelVars+       ; let (vTyCons, vDataCons, vScSels) = unzip3 (tyConRes1 ++ tyConRes2)+       ; return $ VectInfo+                  { vectInfoVar            = mkDVarEnv vVars `extendDVarEnvList` concat vScSels+                  , vectInfoTyCon          = mkNameEnv vTyCons+                  , vectInfoDataCon        = mkNameEnv (concat vDataCons)+                  , vectInfoParallelVars   = mkDVarSet vParallelVars+                  , vectInfoParallelTyCons = parallelTyConsSet+                  }+       }+  where+    vectVarMapping name+      = do { vName <- lookupIfaceTop (mkLocalisedOccName mod mkVectOcc name)+           ; var   <- forkM (text "vect var"  <+> ppr name)  $+                        tcIfaceExtId name+           ; vVar  <- forkM (text "vect vVar [mod =" <+>+                             ppr mod <> text "; nameModule =" <+>+                             ppr (nameModule name) <> text "]" <+> ppr vName) $+                       tcIfaceExtId vName+           ; return (var, (var, vVar))+           }+      -- where+      --   lookupLocalOrExternalId name+      --     = do { let mb_id = lookupTypeEnv typeEnv name+      --          ; case mb_id of+      --                -- id is local+      --              Just (AnId id) -> return id+      --                -- name is not an Id => internal inconsistency+      --              Just _         -> notAnIdErr+      --                -- Id is external+      --              Nothing        -> tcIfaceExtId name+      --          }+      --+      --   notAnIdErr = pprPanic "TcIface.tcIfaceVectInfo: not an id" (ppr name)++    vectVar name+      = forkM (text "vect scalar var"  <+> ppr name)  $+          tcIfaceExtId name++    vectTyConVectMapping vars name+      = do { vName  <- lookupIfaceTop (mkLocalisedOccName mod mkVectTyConOcc name)+           ; vectTyConMapping vars name vName+           }++    vectTyConReuseMapping vars name+      = vectTyConMapping vars name name++    vectTyConMapping vars name vName+      = do { tycon  <- lookupLocalOrExternalTyCon name+           ; vTycon <- forkM (text "vTycon of" <+> ppr vName) $+                         lookupLocalOrExternalTyCon vName++               -- Map the data constructors of the original type constructor to those of the+               -- vectorised type constructor /unless/ the type constructor was vectorised+               -- abstractly; if it was vectorised abstractly, the workers of its data constructors+               -- do not appear in the set of vectorised variables.+               --+               -- NB: This is lazy!  We don't pull at the type constructors before we actually use+               --     the data constructor mapping.+           ; let isAbstract | isClassTyCon tycon = False+                            | datacon:_ <- tyConDataCons tycon+                                                 = not $ dataConWrapId datacon `elemVarSet` vars+                            | otherwise          = True+                 vDataCons  | isAbstract = []+                            | otherwise  = [ (dataConName datacon, (datacon, vDatacon))+                                           | (datacon, vDatacon) <- zip (tyConDataCons tycon)+                                                                        (tyConDataCons vTycon)+                                           ]++                   -- Map the (implicit) superclass and methods selectors as they don't occur in+                   -- the var map.+                 vScSels    | Just cls  <- tyConClass_maybe tycon+                            , Just vCls <- tyConClass_maybe vTycon+                            = [ (sel, (sel, vSel))+                              | (sel, vSel) <- zip (classAllSelIds cls) (classAllSelIds vCls)+                              ]+                            | otherwise+                            = []++           ; return ( (name, (tycon, vTycon))          -- (T, T_v)+                    , vDataCons                        -- list of (Ci, Ci_v)+                    , vScSels                          -- list of (seli, seli_v)+                    )+           }+      where+          -- we need a fully defined version of the type constructor to be able to extract+          -- its data constructors etc.+        lookupLocalOrExternalTyCon name+          = do { let mb_tycon = lookupTypeEnv typeEnv name+               ; case mb_tycon of+                     -- tycon is local+                   Just (ATyCon tycon) -> return tycon+                     -- name is not a tycon => internal inconsistency+                   Just _              -> notATyConErr+                     -- tycon is external+                   Nothing             -> tcIfaceTyConByName name+               }++        notATyConErr = pprPanic "TcIface.tcIfaceVectInfo: not a tycon" (ppr name)++{-+************************************************************************+*                                                                      *+                        Types+*                                                                      *+************************************************************************+-}++tcIfaceType :: IfaceType -> IfL Type+tcIfaceType = go+  where+    go (IfaceTyVar n)         = TyVarTy <$> tcIfaceTyVar n+    go (IfaceFreeTyVar n)     = pprPanic "tcIfaceType:IfaceFreeTyVar" (ppr n)+    go (IfaceAppTy t1 t2)     = AppTy <$> go t1 <*> go t2+    go (IfaceLitTy l)         = LitTy <$> tcIfaceTyLit l+    go (IfaceFunTy t1 t2)     = FunTy <$> go t1 <*> go t2+    go (IfaceDFunTy t1 t2)    = FunTy <$> go t1 <*> go t2+    go (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks+    go (IfaceTyConApp tc tks)+      = do { tc' <- tcIfaceTyCon tc+           ; tks' <- mapM go (tcArgsIfaceTypes tks)+           ; return (mkTyConApp tc' tks') }+    go (IfaceForAllTy bndr t)+      = bindIfaceForAllBndr bndr $ \ tv' vis ->+        ForAllTy (TvBndr tv' vis) <$> go t+    go (IfaceCastTy ty co)   = CastTy <$> go ty <*> tcIfaceCo co+    go (IfaceCoercionTy co)  = CoercionTy <$> tcIfaceCo co++tcIfaceTupleTy :: TupleSort -> IsPromoted -> IfaceTcArgs -> IfL Type+tcIfaceTupleTy sort is_promoted args+ = do { args' <- tcIfaceTcArgs args+      ; let arity = length args'+      ; base_tc <- tcTupleTyCon True sort arity+      ; case is_promoted of+          IsNotPromoted+            -> return (mkTyConApp base_tc args')++          IsPromoted+            -> do { let tc        = promoteDataCon (tyConSingleDataCon base_tc)+                        kind_args = map typeKind args'+                  ; return (mkTyConApp tc (kind_args ++ args')) } }++-- See Note [Unboxed tuple RuntimeRep vars] in TyCon+tcTupleTyCon :: Bool    -- True <=> typechecking a *type* (vs. an expr)+             -> TupleSort+             -> Arity   -- the number of args. *not* the tuple arity.+             -> IfL TyCon+tcTupleTyCon in_type sort arity+  = case sort of+      ConstraintTuple -> do { thing <- tcIfaceGlobal (cTupleTyConName arity)+                            ; return (tyThingTyCon thing) }+      BoxedTuple   -> return (tupleTyCon Boxed   arity)+      UnboxedTuple -> return (tupleTyCon Unboxed arity')+        where arity' | in_type   = arity `div` 2+                     | otherwise = arity+                      -- in expressions, we only have term args++tcIfaceTcArgs :: IfaceTcArgs -> IfL [Type]+tcIfaceTcArgs = mapM tcIfaceType . tcArgsIfaceTypes++-----------------------------------------+tcIfaceCtxt :: IfaceContext -> IfL ThetaType+tcIfaceCtxt sts = mapM tcIfaceType sts++-----------------------------------------+tcIfaceTyLit :: IfaceTyLit -> IfL TyLit+tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n)+tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)++{-+%************************************************************************+%*                                                                      *+                        Coercions+*                                                                      *+************************************************************************+-}++tcIfaceCo :: IfaceCoercion -> IfL Coercion+tcIfaceCo = go+  where+    go (IfaceReflCo r t)         = Refl r <$> tcIfaceType t+    go (IfaceFunCo r c1 c2)      = mkFunCo r <$> go c1 <*> go c2+    go (IfaceTyConAppCo r tc cs)+      = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs+    go (IfaceAppCo c1 c2)        = AppCo <$> go c1 <*> go c2+    go (IfaceForAllCo tv k c)  = do { k' <- go k+                                      ; bindIfaceTyVar tv $ \ tv' ->+                                        ForAllCo tv' k' <$> go c }+    go (IfaceCoVarCo n)          = CoVarCo <$> go_var n+    go (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n <*> pure i <*> mapM go cs+    go (IfaceUnivCo p r t1 t2)   = UnivCo <$> tcIfaceUnivCoProv p <*> pure r+                                          <*> tcIfaceType t1 <*> tcIfaceType t2+    go (IfaceSymCo c)            = SymCo    <$> go c+    go (IfaceTransCo c1 c2)      = TransCo  <$> go c1+                                            <*> go c2+    go (IfaceInstCo c1 t2)       = InstCo   <$> go c1+                                            <*> go t2+    go (IfaceNthCo d c)          = NthCo d  <$> go c+    go (IfaceLRCo lr c)          = LRCo lr  <$> go c+    go (IfaceCoherenceCo c1 c2)  = CoherenceCo <$> go c1+                                               <*> go c2+    go (IfaceKindCo c)           = KindCo   <$> go c+    go (IfaceSubCo c)            = SubCo    <$> go c+    go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> go_axiom_rule ax+                                               <*> mapM go cos++    go_var :: FastString -> IfL CoVar+    go_var = tcIfaceLclId++    go_axiom_rule :: FastString -> IfL CoAxiomRule+    go_axiom_rule n =+      case Map.lookup n typeNatCoAxiomRules of+        Just ax -> return ax+        _  -> pprPanic "go_axiom_rule" (ppr n)++tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance+tcIfaceUnivCoProv IfaceUnsafeCoerceProv     = return UnsafeCoerceProv+tcIfaceUnivCoProv (IfacePhantomProv kco)    = PhantomProv <$> tcIfaceCo kco+tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco+tcIfaceUnivCoProv (IfacePluginProv str)     = return $ PluginProv str+tcIfaceUnivCoProv (IfaceHoleProv _)         =+    pprPanic "tcIfaceUnivCoProv" (text "holes can't occur in interface files")++{-+************************************************************************+*                                                                      *+                        Core+*                                                                      *+************************************************************************+-}++tcIfaceExpr :: IfaceExpr -> IfL CoreExpr+tcIfaceExpr (IfaceType ty)+  = Type <$> tcIfaceType ty++tcIfaceExpr (IfaceCo co)+  = Coercion <$> tcIfaceCo co++tcIfaceExpr (IfaceCast expr co)+  = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co++tcIfaceExpr (IfaceLcl name)+  = Var <$> tcIfaceLclId name++tcIfaceExpr (IfaceExt gbl)+  = Var <$> tcIfaceExtId gbl++tcIfaceExpr (IfaceLit lit)+  = do lit' <- tcIfaceLit lit+       return (Lit lit')++tcIfaceExpr (IfaceFCall cc ty) = do+    ty' <- tcIfaceType ty+    u <- newUnique+    dflags <- getDynFlags+    return (Var (mkFCallId dflags u cc ty'))++tcIfaceExpr (IfaceTuple sort args)+  = do { args' <- mapM tcIfaceExpr args+       ; tc <- tcTupleTyCon False sort arity+       ; let con_tys = map exprType args'+             some_con_args = map Type con_tys ++ args'+             con_args = case sort of+               UnboxedTuple -> map (Type . getRuntimeRep "tcIfaceExpr") con_tys ++ some_con_args+               _            -> some_con_args+                        -- Put the missing type arguments back in+             con_id   = dataConWorkId (tyConSingleDataCon tc)+       ; return (mkApps (Var con_id) con_args) }+  where+    arity = length args++tcIfaceExpr (IfaceLam (bndr, os) body)+  = bindIfaceBndr bndr $ \bndr' ->+    Lam (tcIfaceOneShot os bndr') <$> tcIfaceExpr body+  where+    tcIfaceOneShot IfaceOneShot b = setOneShotLambda b+    tcIfaceOneShot _            b = b++tcIfaceExpr (IfaceApp fun arg)+  = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg++tcIfaceExpr (IfaceECase scrut ty)+  = do { scrut' <- tcIfaceExpr scrut+       ; ty' <- tcIfaceType ty+       ; return (castBottomExpr scrut' ty') }++tcIfaceExpr (IfaceCase scrut case_bndr alts)  = do+    scrut' <- tcIfaceExpr scrut+    case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)+    let+        scrut_ty   = exprType scrut'+        case_bndr' = mkLocalIdOrCoVar case_bndr_name scrut_ty+        tc_app     = splitTyConApp scrut_ty+                -- NB: Won't always succeed (polymorphic case)+                --     but won't be demanded in those cases+                -- NB: not tcSplitTyConApp; we are looking at Core here+                --     look through non-rec newtypes to find the tycon that+                --     corresponds to the datacon in this case alternative++    extendIfaceIdEnv [case_bndr'] $ do+     alts' <- mapM (tcIfaceAlt scrut' tc_app) alts+     return (Case scrut' case_bndr' (coreAltsType alts') alts')++tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body)+  = do  { name    <- newIfaceName (mkVarOccFS fs)+        ; ty'     <- tcIfaceType ty+        ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}+                              name ty' info+        ; let id = mkLocalIdOrCoVarWithInfo name ty' id_info+                     `asJoinId_maybe` tcJoinInfo ji+        ; rhs' <- tcIfaceExpr rhs+        ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)+        ; return (Let (NonRec id rhs') body') }++tcIfaceExpr (IfaceLet (IfaceRec pairs) body)+  = do { ids <- mapM tc_rec_bndr (map fst pairs)+       ; extendIfaceIdEnv ids $ do+       { pairs' <- zipWithM tc_pair pairs ids+       ; body' <- tcIfaceExpr body+       ; return (Let (Rec pairs') body') } }+ where+   tc_rec_bndr (IfLetBndr fs ty _ ji)+     = do { name <- newIfaceName (mkVarOccFS fs)+          ; ty'  <- tcIfaceType ty+          ; return (mkLocalIdOrCoVar name ty' `asJoinId_maybe` tcJoinInfo ji) }+   tc_pair (IfLetBndr _ _ info _, rhs) id+     = do { rhs' <- tcIfaceExpr rhs+          ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}+                                (idName id) (idType id) info+          ; return (setIdInfo id id_info, rhs') }++tcIfaceExpr (IfaceTick tickish expr) = do+    expr' <- tcIfaceExpr expr+    -- If debug flag is not set: Ignore source notes+    dbgLvl <- fmap debugLevel getDynFlags+    case tickish of+      IfaceSource{} | dbgLvl > 0+                    -> return expr'+      _otherwise    -> do+        tickish' <- tcIfaceTickish tickish+        return (Tick tickish' expr')++-------------------------+tcIfaceTickish :: IfaceTickish -> IfM lcl (Tickish Id)+tcIfaceTickish (IfaceHpcTick modl ix)   = return (HpcTick modl ix)+tcIfaceTickish (IfaceSCC  cc tick push) = return (ProfNote cc tick push)+tcIfaceTickish (IfaceSource src name)   = return (SourceNote src name)++-------------------------+tcIfaceLit :: Literal -> IfL Literal+-- Integer literals deserialise to (LitInteger i <error thunk>)+-- so tcIfaceLit just fills in the type.+-- See Note [Integer literals] in Literal+tcIfaceLit (LitInteger i _)+  = do t <- tcIfaceTyConByName integerTyConName+       return (mkLitInteger i (mkTyConTy t))+tcIfaceLit lit = return lit++-------------------------+tcIfaceAlt :: CoreExpr -> (TyCon, [Type])+           -> (IfaceConAlt, [FastString], IfaceExpr)+           -> IfL (AltCon, [TyVar], CoreExpr)+tcIfaceAlt _ _ (IfaceDefault, names, rhs)+  = ASSERT( null names ) do+    rhs' <- tcIfaceExpr rhs+    return (DEFAULT, [], rhs')++tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs)+  = ASSERT( null names ) do+    lit' <- tcIfaceLit lit+    rhs' <- tcIfaceExpr rhs+    return (LitAlt lit', [], rhs')++-- A case alternative is made quite a bit more complicated+-- by the fact that we omit type annotations because we can+-- work them out.  True enough, but its not that easy!+tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs)+  = do  { con <- tcIfaceDataCon data_occ+        ; when (debugIsOn && not (con `elem` tyConDataCons tycon))+               (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))+        ; tcIfaceDataAlt con inst_tys arg_strs rhs }++tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr+               -> IfL (AltCon, [TyVar], CoreExpr)+tcIfaceDataAlt con inst_tys arg_strs rhs+  = do  { us <- newUniqueSupply+        ; let uniqs = uniqsFromSupply us+        ; let (ex_tvs, arg_ids)+                      = dataConRepFSInstPat arg_strs uniqs con inst_tys++        ; rhs' <- extendIfaceEnvs  ex_tvs       $+                  extendIfaceIdEnv arg_ids      $+                  tcIfaceExpr rhs+        ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }++{-+************************************************************************+*                                                                      *+                IdInfo+*                                                                      *+************************************************************************+-}++tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails+tcIdDetails _  IfVanillaId = return VanillaId+tcIdDetails ty IfDFunId+  = return (DFunId (isNewTyCon (classTyCon cls)))+  where+    (_, _, cls, _) = tcSplitDFunTy ty++tcIdDetails _ (IfRecSelId tc naughty)+  = do { tc' <- either (fmap RecSelData . tcIfaceTyCon)+                       (fmap (RecSelPatSyn . tyThingPatSyn) . tcIfaceDecl False)+                       tc+       ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) }+  where+    tyThingPatSyn (AConLike (PatSynCon ps)) = ps+    tyThingPatSyn _ = panic "tcIdDetails: expecting patsyn"++tcIdInfo :: Bool -> Name -> Type -> IfaceIdInfo -> IfL IdInfo+tcIdInfo ignore_prags name ty info = do+    lcl_env <- getLclEnv+    -- Set the CgInfo to something sensible but uninformative before+    -- we start; default assumption is that it has CAFs+    let init_info | if_boot lcl_env = vanillaIdInfo `setUnfoldingInfo` BootUnfolding+                  | otherwise       = vanillaIdInfo+    if ignore_prags+        then return init_info+        else case info of+                NoInfo -> return init_info+                HasInfo info -> foldlM tcPrag init_info info+  where+    tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo+    tcPrag info HsNoCafRefs        = return (info `setCafInfo`   NoCafRefs)+    tcPrag info (HsArity arity)    = return (info `setArityInfo` arity)+    tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str)+    tcPrag info (HsInline prag)    = return (info `setInlinePragInfo` prag)+    tcPrag info HsLevity           = return (info `setNeverLevPoly` ty)++        -- The next two are lazy, so they don't transitively suck stuff in+    tcPrag info (HsUnfold lb if_unf)+      = do { unf <- tcUnfolding name ty info if_unf+           ; let info1 | lb        = info `setOccInfo` strongLoopBreaker+                       | otherwise = info+           ; return (info1 `setUnfoldingInfo` unf) }++tcJoinInfo :: IfaceJoinInfo -> Maybe JoinArity+tcJoinInfo (IfaceJoinPoint ar) = Just ar+tcJoinInfo IfaceNotJoinPoint   = Nothing++tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding+tcUnfolding name _ info (IfCoreUnfold stable if_expr)+  = do  { dflags <- getDynFlags+        ; mb_expr <- tcPragExpr name if_expr+        ; let unf_src | stable    = InlineStable+                      | otherwise = InlineRhs+        ; return $ case mb_expr of+            Nothing -> NoUnfolding+            Just expr -> mkUnfolding dflags unf_src+                           True {- Top level -}+                           (isBottomingSig strict_sig)+                           expr+        }+  where+     -- Strictness should occur before unfolding!+    strict_sig = strictnessInfo info+tcUnfolding name _ _ (IfCompulsory if_expr)+  = do  { mb_expr <- tcPragExpr name if_expr+        ; return (case mb_expr of+                    Nothing   -> NoUnfolding+                    Just expr -> mkCompulsoryUnfolding expr) }++tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)+  = do  { mb_expr <- tcPragExpr name if_expr+        ; return (case mb_expr of+                    Nothing   -> NoUnfolding+                    Just expr -> mkCoreUnfolding InlineStable True expr guidance )}+  where+    guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }++tcUnfolding name dfun_ty _ (IfDFunUnfold bs ops)+  = bindIfaceBndrs bs $ \ bs' ->+    do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops+       ; return (case mb_ops1 of+                    Nothing   -> noUnfolding+                    Just ops1 -> mkDFunUnfolding bs' (classDataCon cls) ops1) }+  where+    doc = text "Class ops for dfun" <+> ppr name+    (_, _, cls, _) = tcSplitDFunTy dfun_ty++{-+For unfoldings we try to do the job lazily, so that we never type check+an unfolding that isn't going to be looked at.+-}++tcPragExpr :: Name -> IfaceExpr -> IfL (Maybe CoreExpr)+tcPragExpr name expr+  = forkM_maybe doc $ do+    core_expr' <- tcIfaceExpr expr++                -- Check for type consistency in the unfolding+    whenGOptM Opt_DoCoreLinting $ do+        in_scope <- get_in_scope+        dflags   <- getDynFlags+        case lintUnfolding dflags noSrcLoc in_scope core_expr' of+          Nothing       -> return ()+          Just fail_msg -> do { mod <- getIfModule+                              ; pprPanic "Iface Lint failure"+                                  (vcat [ text "In interface for" <+> ppr mod+                                        , hang doc 2 fail_msg+                                        , ppr name <+> equals <+> ppr core_expr'+                                        , text "Iface expr =" <+> ppr expr ]) }+    return core_expr'+  where+    doc = text "Unfolding of" <+> ppr name++    get_in_scope :: IfL VarSet -- Totally disgusting; but just for linting+    get_in_scope+        = do { (gbl_env, lcl_env) <- getEnvs+             ; rec_ids <- case if_rec_types gbl_env of+                            Nothing -> return []+                            Just (_, get_env) -> do+                               { type_env <- setLclEnv () get_env+                               ; return (typeEnvIds type_env) }+             ; return (bindingsVars (if_tv_env lcl_env) `unionVarSet`+                       bindingsVars (if_id_env lcl_env) `unionVarSet`+                       mkVarSet rec_ids) }++    bindingsVars :: FastStringEnv Var -> VarSet+    bindingsVars ufm = mkVarSet $ nonDetEltsUFM ufm+      -- It's OK to use nonDetEltsUFM here because we immediately forget+      -- the ordering by creating a set++{-+************************************************************************+*                                                                      *+                Getting from Names to TyThings+*                                                                      *+************************************************************************+-}++tcIfaceGlobal :: Name -> IfL TyThing+tcIfaceGlobal name+  | Just thing <- wiredInNameTyThing_maybe name+        -- Wired-in things include TyCons, DataCons, and Ids+        -- Even though we are in an interface file, we want to make+        -- sure the instances and RULES of this thing (particularly TyCon) are loaded+        -- Imagine: f :: Double -> Double+  = do { ifCheckWiredInThing thing; return thing }++  | otherwise+  = do  { env <- getGblEnv+        ; case if_rec_types env of {    -- Note [Tying the knot]+            Just (mod, get_type_env)+                | nameIsLocalOrFrom mod name+                -> do           -- It's defined in the module being compiled+                { type_env <- setLclEnv () get_type_env         -- yuk+                ; case lookupNameEnv type_env name of+                    Just thing -> return thing+                    Nothing   ->+                      pprPanic "tcIfaceGlobal (local): not found"+                               (ifKnotErr name (if_doc env) type_env)+                }++          ; _ -> do++        { hsc_env <- getTopEnv+        ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)+        ; case mb_thing of {+            Just thing -> return thing ;+            Nothing    -> do++        { mb_thing <- importDecl name   -- It's imported; go get it+        ; case mb_thing of+            Failed err      -> failIfM err+            Succeeded thing -> return thing+    }}}}}++ifKnotErr :: Name -> SDoc -> TypeEnv -> SDoc+ifKnotErr name env_doc type_env = vcat+  [ text "You are in a maze of twisty little passages, all alike."+  , text "While forcing the thunk for TyThing" <+> ppr name+  , text "which was lazily initialized by" <+> env_doc <> text ","+  , text "I tried to tie the knot, but I couldn't find" <+> ppr name+  , text "in the current type environment."+  , text "If you are developing GHC, please read Note [Tying the knot]"+  , text "and Note [Type-checking inside the knot]."+  , text "Consider rebuilding GHC with profiling for a better stack trace."+  , hang (text "Contents of current type environment:")+       2 (ppr type_env)+  ]++-- Note [Tying the knot]+-- ~~~~~~~~~~~~~~~~~~~~~+-- The if_rec_types field is used when we are compiling M.hs, which indirectly+-- imports Foo.hi, which mentions M.T Then we look up M.T in M's type+-- environment, which is splatted into if_rec_types after we've built M's type+-- envt.+--+-- This is a dark and complicated part of GHC type checking, with a lot+-- of moving parts.  Interested readers should also look at:+--+--      * Note [Knot-tying typecheckIface]+--      * Note [DFun knot-tying]+--      * Note [hsc_type_env_var hack]+--+-- There is also a wiki page on the subject, see:+--+--      https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TyingTheKnot++tcIfaceTyConByName :: IfExtName -> IfL TyCon+tcIfaceTyConByName name+  = do { thing <- tcIfaceGlobal name+       ; return (tyThingTyCon thing) }++tcIfaceTyCon :: IfaceTyCon -> IfL TyCon+tcIfaceTyCon (IfaceTyCon name info)+  = do { thing <- tcIfaceGlobal name+       ; return $ case ifaceTyConIsPromoted info of+           IsNotPromoted -> tyThingTyCon thing+           IsPromoted    -> promoteDataCon $ tyThingDataCon thing }++tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched)+tcIfaceCoAxiom name = do { thing <- tcIfaceImplicit name+                         ; return (tyThingCoAxiom thing) }++tcIfaceDataCon :: Name -> IfL DataCon+tcIfaceDataCon name = do { thing <- tcIfaceGlobal name+                         ; case thing of+                                AConLike (RealDataCon dc) -> return dc+                                _       -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }++tcIfaceExtId :: Name -> IfL Id+tcIfaceExtId name = do { thing <- tcIfaceGlobal name+                       ; case thing of+                          AnId id -> return id+                          _       -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) }++-- See Note [Resolving never-exported Names in TcIface]+tcIfaceImplicit :: Name -> IfL TyThing+tcIfaceImplicit n = do+    lcl_env <- getLclEnv+    case if_implicits_env lcl_env of+        Nothing -> tcIfaceGlobal n+        Just tenv ->+            case lookupTypeEnv tenv n of+                Nothing -> pprPanic "tcIfaceInst" (ppr n $$ ppr tenv)+                Just tything -> return tything++{-+************************************************************************+*                                                                      *+                Bindings+*                                                                      *+************************************************************************+-}++bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a+bindIfaceId (fs, ty) thing_inside+  = do  { name <- newIfaceName (mkVarOccFS fs)+        ; ty' <- tcIfaceType ty+        ; let id = mkLocalIdOrCoVar name ty'+        ; extendIfaceIdEnv [id] (thing_inside id) }++bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a+bindIfaceIds [] thing_inside = thing_inside []+bindIfaceIds (b:bs) thing_inside+  = bindIfaceId b   $ \b'  ->+    bindIfaceIds bs $ \bs' ->+    thing_inside (b':bs')++bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a+bindIfaceBndr (IfaceIdBndr bndr) thing_inside+  = bindIfaceId bndr thing_inside+bindIfaceBndr (IfaceTvBndr bndr) thing_inside+  = bindIfaceTyVar bndr thing_inside++bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a+bindIfaceBndrs []     thing_inside = thing_inside []+bindIfaceBndrs (b:bs) thing_inside+  = bindIfaceBndr b     $ \ b' ->+    bindIfaceBndrs bs   $ \ bs' ->+    thing_inside (b':bs')++-----------------------+bindIfaceForAllBndrs :: [IfaceForAllBndr] -> ([TyVarBinder] -> IfL a) -> IfL a+bindIfaceForAllBndrs [] thing_inside = thing_inside []+bindIfaceForAllBndrs (bndr:bndrs) thing_inside+  = bindIfaceForAllBndr bndr $ \tv vis ->+    bindIfaceForAllBndrs bndrs $ \bndrs' ->+    thing_inside (mkTyVarBinder vis tv : bndrs')++bindIfaceForAllBndr :: IfaceForAllBndr -> (TyVar -> ArgFlag -> IfL a) -> IfL a+bindIfaceForAllBndr (TvBndr tv vis) thing_inside+  = bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis++bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a+bindIfaceTyVar (occ,kind) thing_inside+  = do  { name <- newIfaceName (mkTyVarOccFS occ)+        ; tyvar <- mk_iface_tyvar name kind+        ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }++mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar+mk_iface_tyvar name ifKind+   = do { kind <- tcIfaceType ifKind+        ; return (Var.mkTyVar name kind) }++bindIfaceTyConBinders :: [IfaceTyConBinder]+                      -> ([TyConBinder] -> IfL a) -> IfL a+bindIfaceTyConBinders [] thing_inside = thing_inside []+bindIfaceTyConBinders (b:bs) thing_inside+  = bindIfaceTyConBinderX bindIfaceTyVar b $ \ b'  ->+    bindIfaceTyConBinders bs               $ \ bs' ->+    thing_inside (b':bs')++bindIfaceTyConBinders_AT :: [IfaceTyConBinder]+                         -> ([TyConBinder] -> IfL a) -> IfL a+-- Used for type variable in nested associated data/type declarations+-- where some of the type variables are already in scope+--    class C a where { data T a b }+-- Here 'a' is in scope when we look at the 'data T'+bindIfaceTyConBinders_AT [] thing_inside+  = thing_inside []+bindIfaceTyConBinders_AT (b : bs) thing_inside+  = bindIfaceTyConBinderX bind_tv b  $ \b'  ->+    bindIfaceTyConBinders_AT      bs $ \bs' ->+    thing_inside (b':bs')+  where+    bind_tv tv thing+      = do { mb_tv <- lookupIfaceTyVar tv+           ; case mb_tv of+               Just b' -> thing b'+               Nothing -> bindIfaceTyVar tv thing }++bindIfaceTyConBinderX :: (IfaceTvBndr -> (TyVar -> IfL a) -> IfL a)+                      -> IfaceTyConBinder+                      -> (TyConBinder -> IfL a) -> IfL a+bindIfaceTyConBinderX bind_tv (TvBndr tv vis) thing_inside+  = bind_tv tv $ \tv' ->+    thing_inside (TvBndr tv' vis)
+ iface/TcIface.hs-boot view
@@ -0,0 +1,20 @@+module TcIface where++import IfaceSyn    ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule,+                     IfaceAnnotation, IfaceCompleteMatch )+import TyCoRep     ( TyThing )+import TcRnTypes   ( IfL )+import InstEnv     ( ClsInst )+import FamInstEnv  ( FamInst )+import CoreSyn     ( CoreRule )+import HscTypes    ( TypeEnv, VectInfo, IfaceVectInfo, CompleteMatch )+import Module      ( Module )+import Annotations ( Annotation )++tcIfaceDecl         :: Bool -> IfaceDecl -> IfL TyThing+tcIfaceRules        :: Bool -> [IfaceRule] -> IfL [CoreRule]+tcIfaceVectInfo     :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo+tcIfaceInst         :: IfaceClsInst -> IfL ClsInst+tcIfaceFamInst      :: IfaceFamInst -> IfL FamInst+tcIfaceAnnotations  :: [IfaceAnnotation] -> IfL [Annotation]+tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
+ iface/ToIface.hs view
@@ -0,0 +1,602 @@+{-# LANGUAGE CPP #-}++-- | Functions for converting Core things to interface file things.+module ToIface+    ( -- * Binders+      toIfaceTvBndr+    , toIfaceTvBndrs+    , toIfaceIdBndr+    , toIfaceBndr+    , toIfaceForAllBndr+    , toIfaceTyVarBinders+    , toIfaceTyVar+      -- * Types+    , toIfaceType, toIfaceTypeX+    , toIfaceKind+    , toIfaceTcArgs+    , toIfaceTyCon+    , toIfaceTyCon_name+    , toIfaceTyLit+      -- * Tidying types+    , tidyToIfaceType+    , tidyToIfaceContext+    , tidyToIfaceTcArgs+      -- * Coercions+    , toIfaceCoercion+      -- * Pattern synonyms+    , patSynToIfaceDecl+      -- * Expressions+    , toIfaceExpr+    , toIfaceBang+    , toIfaceSrcBang+    , toIfaceLetBndr+    , toIfaceIdDetails+    , toIfaceIdInfo+    , toIfUnfolding+    , toIfaceOneShot+    , toIfaceTickish+    , toIfaceBind+    , toIfaceAlt+    , toIfaceCon+    , toIfaceApp+    , toIfaceVar+    ) where++#include "HsVersions.h"++import IfaceSyn+import DataCon+import Id+import IdInfo+import CoreSyn+import TyCon hiding ( pprPromotionQuote )+import CoAxiom+import TysPrim ( eqPrimTyCon, eqReprPrimTyCon )+import TysWiredIn ( heqTyCon )+import MkId ( noinlineIdName )+import PrelNames+import Name+import BasicTypes+import Type+import PatSyn+import Outputable+import FastString+import Util+import Var+import VarEnv+import VarSet+import TyCoRep+import Demand ( isTopSig )++import Data.Maybe ( catMaybes )++----------------+toIfaceTvBndr :: TyVar -> IfaceTvBndr+toIfaceTvBndr tyvar   = ( occNameFS (getOccName tyvar)+                        , toIfaceKind (tyVarKind tyvar)+                        )++toIfaceIdBndr :: Id -> (IfLclName, IfaceType)+toIfaceIdBndr id      = (occNameFS (getOccName id),    toIfaceType (idType id))++toIfaceTvBndrs :: [TyVar] -> [IfaceTvBndr]+toIfaceTvBndrs = map toIfaceTvBndr++toIfaceBndr :: Var -> IfaceBndr+toIfaceBndr var+  | isId var  = IfaceIdBndr (toIfaceIdBndr var)+  | otherwise = IfaceTvBndr (toIfaceTvBndr var)++toIfaceTyVarBinder :: TyVarBndr TyVar vis -> TyVarBndr IfaceTvBndr vis+toIfaceTyVarBinder (TvBndr tv vis) = TvBndr (toIfaceTvBndr tv) vis++toIfaceTyVarBinders :: [TyVarBndr TyVar vis] -> [TyVarBndr IfaceTvBndr vis]+toIfaceTyVarBinders = map toIfaceTyVarBinder++{-+************************************************************************+*                                                                      *+        Conversion from Type to IfaceType+*                                                                      *+************************************************************************+-}++toIfaceKind :: Type -> IfaceType+toIfaceKind = toIfaceType++---------------------+toIfaceType :: Type -> IfaceType+toIfaceType = toIfaceTypeX emptyVarSet++toIfaceTypeX :: VarSet -> Type -> IfaceType+-- (toIfaceTypeX free ty)+--    translates the tyvars in 'free' as IfaceFreeTyVars+--+-- Synonyms are retained in the interface type+toIfaceTypeX fr (TyVarTy tv)   -- See Note [TcTyVars in IfaceType] in IfaceType+  | tv `elemVarSet` fr         = IfaceFreeTyVar tv+  | otherwise                  = IfaceTyVar (toIfaceTyVar tv)+toIfaceTypeX fr (AppTy t1 t2)  = IfaceAppTy (toIfaceTypeX fr t1) (toIfaceTypeX fr t2)+toIfaceTypeX _  (LitTy n)      = IfaceLitTy (toIfaceTyLit n)+toIfaceTypeX fr (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndr b)+                                               (toIfaceTypeX (fr `delVarSet` binderVar b) t)+toIfaceTypeX fr (FunTy t1 t2)+  | isPredTy t1                 = IfaceDFunTy (toIfaceTypeX fr t1) (toIfaceTypeX fr t2)+  | otherwise                   = IfaceFunTy  (toIfaceTypeX fr t1) (toIfaceTypeX fr t2)+toIfaceTypeX fr (CastTy ty co)  = IfaceCastTy (toIfaceTypeX fr ty) (toIfaceCoercionX fr co)+toIfaceTypeX fr (CoercionTy co) = IfaceCoercionTy (toIfaceCoercionX fr co)++toIfaceTypeX fr (TyConApp tc tys)+    -- tuples+  | Just sort <- tyConTuple_maybe tc+  , n_tys == arity+  = IfaceTupleTy sort IsNotPromoted (toIfaceTcArgsX fr tc tys)++  | Just dc <- isPromotedDataCon_maybe tc+  , isTupleDataCon dc+  , n_tys == 2*arity+  = IfaceTupleTy BoxedTuple IsPromoted (toIfaceTcArgsX fr tc (drop arity tys))++    -- type equalities: see Note [Equality predicates in IfaceType]+  | tyConName tc == eqTyConName+  = let info = IfaceTyConInfo IsNotPromoted (IfaceEqualityTyCon True)+    in IfaceTyConApp (IfaceTyCon (tyConName tc) info) (toIfaceTcArgsX fr tc tys)++  | tc `elem` [ eqPrimTyCon, eqReprPrimTyCon, heqTyCon ]+  , [k1, k2, _t1, _t2] <- tys+  = let homogeneous = k1 `eqType` k2+        info = IfaceTyConInfo IsNotPromoted (IfaceEqualityTyCon homogeneous)+    in IfaceTyConApp (IfaceTyCon (tyConName tc) info) (toIfaceTcArgsX fr tc tys)++    -- other applications+  | otherwise+  = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTcArgsX fr tc tys)+  where+    arity = tyConArity tc+    n_tys = length tys++toIfaceTyVar :: TyVar -> FastString+toIfaceTyVar = occNameFS . getOccName++toIfaceCoVar :: CoVar -> FastString+toIfaceCoVar = occNameFS . getOccName++toIfaceForAllBndr :: TyVarBinder -> IfaceForAllBndr+toIfaceForAllBndr (TvBndr v vis) = TvBndr (toIfaceTvBndr v) vis++----------------+toIfaceTyCon :: TyCon -> IfaceTyCon+toIfaceTyCon tc+  = IfaceTyCon tc_name info+  where+    tc_name = tyConName tc+    info    = IfaceTyConInfo promoted sort+    promoted | isPromotedDataCon tc = IsPromoted+             | otherwise            = IsNotPromoted++    tupleSort :: TyCon -> Maybe IfaceTyConSort+    tupleSort tc' =+        case tyConTuple_maybe tc' of+          Just UnboxedTuple -> let arity = tyConArity tc' `div` 2+                               in Just $ IfaceTupleTyCon arity UnboxedTuple+          Just sort         -> let arity = tyConArity tc'+                               in Just $ IfaceTupleTyCon arity sort+          Nothing           -> Nothing++    sort+      | Just tsort <- tupleSort tc           = tsort++      | Just dcon <- isPromotedDataCon_maybe tc+      , let tc' = dataConTyCon dcon+      , Just tsort <- tupleSort tc'          = tsort++      | isUnboxedSumTyCon tc+      , Just cons <- isDataSumTyCon_maybe tc = IfaceSumTyCon (length cons)++      | otherwise                            = IfaceNormalTyCon+++toIfaceTyCon_name :: Name -> IfaceTyCon+toIfaceTyCon_name n = IfaceTyCon n info+  where info = IfaceTyConInfo IsNotPromoted IfaceNormalTyCon+  -- Used for the "rough-match" tycon stuff,+  -- where pretty-printing is not an issue++toIfaceTyLit :: TyLit -> IfaceTyLit+toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x+toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x++----------------+toIfaceCoercion :: Coercion -> IfaceCoercion+toIfaceCoercion = toIfaceCoercionX emptyVarSet++toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion+-- (toIfaceCoercionX free ty)+--    translates the tyvars in 'free' as IfaceFreeTyVars+toIfaceCoercionX fr co+  = go co+  where+    go (Refl r ty)          = IfaceReflCo r (toIfaceType ty)+    go (CoVarCo cv)         = IfaceCoVarCo  (toIfaceCoVar cv)+    go (AppCo co1 co2)      = IfaceAppCo  (go co1) (go co2)+    go (SymCo co)           = IfaceSymCo (go co)+    go (TransCo co1 co2)    = IfaceTransCo (go co1) (go co2)+    go (NthCo d co)         = IfaceNthCo d (go co)+    go (LRCo lr co)         = IfaceLRCo lr (go co)+    go (InstCo co arg)      = IfaceInstCo (go co) (go arg)+    go (CoherenceCo c1 c2)  = IfaceCoherenceCo (go c1) (go c2)+    go (KindCo c)           = IfaceKindCo (go c)+    go (SubCo co)           = IfaceSubCo (go co)+    go (AxiomRuleCo co cs)  = IfaceAxiomRuleCo (coaxrName co) (map go cs)+    go (AxiomInstCo c i cs) = IfaceAxiomInstCo (coAxiomName c) i (map go cs)+    go (UnivCo p r t1 t2)   = IfaceUnivCo (go_prov p) r+                                          (toIfaceTypeX fr t1)+                                          (toIfaceTypeX fr t2)+    go (TyConAppCo r tc cos)+      | tc `hasKey` funTyConKey+      , [_,_,_,_] <- cos         = pprPanic "toIfaceCoercion" (ppr co)+      | otherwise                = IfaceTyConAppCo r (toIfaceTyCon tc) (map go cos)+    go (FunCo r co1 co2)   = IfaceFunCo r (toIfaceCoercion co1)+                                          (toIfaceCoercion co2)++    go (ForAllCo tv k co) = IfaceForAllCo (toIfaceTvBndr tv)+                                          (toIfaceCoercionX fr' k)+                                          (toIfaceCoercionX fr' co)+                          where+                            fr' = fr `delVarSet` tv++    go_prov :: UnivCoProvenance -> IfaceUnivCoProv+    go_prov UnsafeCoerceProv    = IfaceUnsafeCoerceProv+    go_prov (PhantomProv co)    = IfacePhantomProv (go co)+    go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co)+    go_prov (PluginProv str)    = IfacePluginProv str+    go_prov (HoleProv h)        = IfaceHoleProv (chUnique h)++toIfaceTcArgs :: TyCon -> [Type] -> IfaceTcArgs+toIfaceTcArgs = toIfaceTcArgsX emptyVarSet++toIfaceTcArgsX :: VarSet -> TyCon -> [Type] -> IfaceTcArgs+-- See Note [Suppressing invisible arguments]+-- We produce a result list of args describing visiblity+-- The awkward case is+--    T :: forall k. * -> k+-- And consider+--    T (forall j. blah) * blib+-- Is 'blib' visible?  It depends on the visibility flag on j,+-- so we have to substitute for k.  Annoying!+toIfaceTcArgsX fr tc ty_args+  = go (mkEmptyTCvSubst in_scope) (tyConKind tc) ty_args+  where+    in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args)++    go _   _                   []     = ITC_Nil+    go env ty                  ts+      | Just ty' <- coreView ty+      = go env ty' ts+    go env (ForAllTy (TvBndr tv vis) res) (t:ts)+      | isVisibleArgFlag vis = ITC_Vis   t' ts'+      | otherwise            = ITC_Invis t' ts'+      where+        t'  = toIfaceTypeX fr t+        ts' = go (extendTvSubst env tv t) res ts++    go env (FunTy _ res) (t:ts) -- No type-class args in tycon apps+      = ITC_Vis (toIfaceTypeX fr t) (go env res ts)++    go env (TyVarTy tv) ts+      | Just ki <- lookupTyVar env tv = go env ki ts+    go env kind (t:ts) = WARN( True, ppr tc $$ ppr (tyConKind tc) $$ ppr ty_args )+                         ITC_Vis (toIfaceTypeX fr t) (go env kind ts) -- Ill-kinded++tidyToIfaceType :: TidyEnv -> Type -> IfaceType+tidyToIfaceType env ty = toIfaceType (tidyType env ty)++tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceTcArgs+tidyToIfaceTcArgs env tc tys = toIfaceTcArgs tc (tidyTypes env tys)++tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext+tidyToIfaceContext env theta = map (tidyToIfaceType env) theta++{-+************************************************************************+*                                                                      *+        Conversion of pattern synonyms+*                                                                      *+************************************************************************+-}++patSynToIfaceDecl :: PatSyn -> IfaceDecl+patSynToIfaceDecl ps+  = IfacePatSyn { ifName          = getName $ ps+                , ifPatMatcher    = to_if_pr (patSynMatcher ps)+                , ifPatBuilder    = fmap to_if_pr (patSynBuilder ps)+                , ifPatIsInfix    = patSynIsInfix ps+                , ifPatUnivBndrs  = map toIfaceForAllBndr univ_bndrs'+                , ifPatExBndrs    = map toIfaceForAllBndr ex_bndrs'+                , ifPatProvCtxt   = tidyToIfaceContext env2 prov_theta+                , ifPatReqCtxt    = tidyToIfaceContext env2 req_theta+                , ifPatArgs       = map (tidyToIfaceType env2) args+                , ifPatTy         = tidyToIfaceType env2 rhs_ty+                , ifFieldLabels   = (patSynFieldLabels ps)+                }+  where+    (_univ_tvs, req_theta, _ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps+    univ_bndrs = patSynUnivTyVarBinders ps+    ex_bndrs   = patSynExTyVarBinders ps+    (env1, univ_bndrs') = tidyTyVarBinders emptyTidyEnv univ_bndrs+    (env2, ex_bndrs')   = tidyTyVarBinders env1 ex_bndrs+    to_if_pr (id, needs_dummy) = (idName id, needs_dummy)++{-+************************************************************************+*                                                                      *+        Conversion of other things+*                                                                      *+************************************************************************+-}++toIfaceBang :: TidyEnv -> HsImplBang -> IfaceBang+toIfaceBang _    HsLazy              = IfNoBang+toIfaceBang _   (HsUnpack Nothing)   = IfUnpack+toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co))+toIfaceBang _   HsStrict             = IfStrict++toIfaceSrcBang :: HsSrcBang -> IfaceSrcBang+toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang++toIfaceLetBndr :: Id -> IfaceLetBndr+toIfaceLetBndr id  = IfLetBndr (occNameFS (getOccName id))+                               (toIfaceType (idType id))+                               (toIfaceIdInfo (idInfo id))+                               (toIfaceJoinInfo (isJoinId_maybe id))+  -- Put into the interface file any IdInfo that CoreTidy.tidyLetBndr+  -- has left on the Id.  See Note [IdInfo on nested let-bindings] in IfaceSyn++toIfaceIdDetails :: IdDetails -> IfaceIdDetails+toIfaceIdDetails VanillaId                      = IfVanillaId+toIfaceIdDetails (DFunId {})                    = IfDFunId+toIfaceIdDetails (RecSelId { sel_naughty = n+                           , sel_tycon = tc })  =+  let iface = case tc of+                RecSelData ty_con -> Left (toIfaceTyCon ty_con)+                RecSelPatSyn pat_syn -> Right (patSynToIfaceDecl pat_syn)+  in IfRecSelId iface n++  -- The remaining cases are all "implicit Ids" which don't+  -- appear in interface files at all+toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other)+                         IfVanillaId   -- Unexpected; the other++toIfaceIdInfo :: IdInfo -> IfaceIdInfo+toIfaceIdInfo id_info+  = case catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,+                    inline_hsinfo,  unfold_hsinfo, levity_hsinfo] of+       []    -> NoInfo+       infos -> HasInfo infos+               -- NB: strictness and arity must appear in the list before unfolding+               -- See TcIface.tcUnfolding+  where+    ------------  Arity  --------------+    arity_info = arityInfo id_info+    arity_hsinfo | arity_info == 0 = Nothing+                 | otherwise       = Just (HsArity arity_info)++    ------------ Caf Info --------------+    caf_info   = cafInfo id_info+    caf_hsinfo = case caf_info of+                   NoCafRefs -> Just HsNoCafRefs+                   _other    -> Nothing++    ------------  Strictness  --------------+        -- No point in explicitly exporting TopSig+    sig_info = strictnessInfo id_info+    strict_hsinfo | not (isTopSig sig_info) = Just (HsStrictness sig_info)+                  | otherwise               = Nothing++    ------------  Unfolding  --------------+    unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info)+    loop_breaker  = isStrongLoopBreaker (occInfo id_info)++    ------------  Inline prag  --------------+    inline_prag = inlinePragInfo id_info+    inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing+                  | otherwise = Just (HsInline inline_prag)++    ------------  Levity polymorphism  ----------+    levity_hsinfo | isNeverLevPolyIdInfo id_info = Just HsLevity+                  | otherwise                    = Nothing++toIfaceJoinInfo :: Maybe JoinArity -> IfaceJoinInfo+toIfaceJoinInfo (Just ar) = IfaceJoinPoint ar+toIfaceJoinInfo Nothing   = IfaceNotJoinPoint++--------------------------+toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem+toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs+                                , uf_src = src+                                , uf_guidance = guidance })+  = Just $ HsUnfold lb $+    case src of+        InlineStable+          -> case guidance of+               UnfWhen {ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok =  boring_ok }+                      -> IfInlineRule arity unsat_ok boring_ok if_rhs+               _other -> IfCoreUnfold True if_rhs+        InlineCompulsory -> IfCompulsory if_rhs+        InlineRhs        -> IfCoreUnfold False if_rhs+        -- Yes, even if guidance is UnfNever, expose the unfolding+        -- If we didn't want to expose the unfolding, TidyPgm would+        -- have stuck in NoUnfolding.  For supercompilation we want+        -- to see that unfolding!+  where+    if_rhs = toIfaceExpr rhs++toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args })+  = Just (HsUnfold lb (IfDFunUnfold (map toIfaceBndr bndrs) (map toIfaceExpr args)))+      -- No need to serialise the data constructor;+      -- we can recover it from the type of the dfun++toIfUnfolding _ _+  = Nothing++{-+************************************************************************+*                                                                      *+        Conversion of expressions+*                                                                      *+************************************************************************+-}++toIfaceExpr :: CoreExpr -> IfaceExpr+toIfaceExpr (Var v)         = toIfaceVar v+toIfaceExpr (Lit l)         = IfaceLit l+toIfaceExpr (Type ty)       = IfaceType (toIfaceType ty)+toIfaceExpr (Coercion co)   = IfaceCo   (toIfaceCoercion co)+toIfaceExpr (Lam x b)       = IfaceLam (toIfaceBndr x, toIfaceOneShot x) (toIfaceExpr b)+toIfaceExpr (App f a)       = toIfaceApp f [a]+toIfaceExpr (Case s x ty as)+  | null as                 = IfaceECase (toIfaceExpr s) (toIfaceType ty)+  | otherwise               = IfaceCase (toIfaceExpr s) (getOccFS x) (map toIfaceAlt as)+toIfaceExpr (Let b e)       = IfaceLet (toIfaceBind b) (toIfaceExpr e)+toIfaceExpr (Cast e co)     = IfaceCast (toIfaceExpr e) (toIfaceCoercion co)+toIfaceExpr (Tick t e)+  | Just t' <- toIfaceTickish t = IfaceTick t' (toIfaceExpr e)+  | otherwise                   = toIfaceExpr e++toIfaceOneShot :: Id -> IfaceOneShot+toIfaceOneShot id | isId id+                  , OneShotLam <- oneShotInfo (idInfo id)+                  = IfaceOneShot+                  | otherwise+                  = IfaceNoOneShot++---------------------+toIfaceTickish :: Tickish Id -> Maybe IfaceTickish+toIfaceTickish (ProfNote cc tick push) = Just (IfaceSCC cc tick push)+toIfaceTickish (HpcTick modl ix)       = Just (IfaceHpcTick modl ix)+toIfaceTickish (SourceNote src names)  = Just (IfaceSource src names)+toIfaceTickish (Breakpoint {})         = Nothing+   -- Ignore breakpoints, since they are relevant only to GHCi, and+   -- should not be serialised (Trac #8333)++---------------------+toIfaceBind :: Bind Id -> IfaceBinding+toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r)+toIfaceBind (Rec prs)    = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs]++---------------------+toIfaceAlt :: (AltCon, [Var], CoreExpr)+           -> (IfaceConAlt, [FastString], IfaceExpr)+toIfaceAlt (c,bs,r) = (toIfaceCon c, map getOccFS bs, toIfaceExpr r)++---------------------+toIfaceCon :: AltCon -> IfaceConAlt+toIfaceCon (DataAlt dc) = IfaceDataAlt (getName dc)+toIfaceCon (LitAlt l)   = IfaceLitAlt l+toIfaceCon DEFAULT      = IfaceDefault++---------------------+toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr+toIfaceApp (App f a) as = toIfaceApp f (a:as)+toIfaceApp (Var v) as+  = case isDataConWorkId_maybe v of+        -- We convert the *worker* for tuples into IfaceTuples+        Just dc |  saturated+                ,  Just tup_sort <- tyConTuple_maybe tc+                -> IfaceTuple tup_sort tup_args+          where+            val_args  = dropWhile isTypeArg as+            saturated = val_args `lengthIs` idArity v+            tup_args  = map toIfaceExpr val_args+            tc        = dataConTyCon dc++        _ -> mkIfaceApps (toIfaceVar v) as++toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as++mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr+mkIfaceApps f as = foldl (\f a -> IfaceApp f (toIfaceExpr a)) f as++---------------------+toIfaceVar :: Id -> IfaceExpr+toIfaceVar v+    | Just fcall <- isFCallId_maybe v            = IfaceFCall fcall (toIfaceType (idType v))+       -- Foreign calls have special syntax+    | isBootUnfolding (idUnfolding v)+    = IfaceApp (IfaceApp (IfaceExt noinlineIdName) (IfaceType (toIfaceType (idType v))))+               (IfaceExt name) -- don't use mkIfaceApps, or infinite loop+       -- See Note [Inlining and hs-boot files]+    | isExternalName name                        = IfaceExt name+    | otherwise                                  = IfaceLcl (getOccFS name)+  where name = idName v+++{- Note [Inlining and hs-boot files]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this example (Trac #10083, #12789):++    ---------- RSR.hs-boot ------------+    module RSR where+      data RSR+      eqRSR :: RSR -> RSR -> Bool++    ---------- SR.hs ------------+    module SR where+      import {-# SOURCE #-} RSR+      data SR = MkSR RSR+      eqSR (MkSR r1) (MkSR r2) = eqRSR r1 r2++    ---------- RSR.hs ------------+    module RSR where+      import SR+      data RSR = MkRSR SR -- deriving( Eq )+      eqRSR (MkRSR s1) (MkRSR s2) = (eqSR s1 s2)+      foo x y = not (eqRSR x y)++When compiling RSR we get this code++    RSR.eqRSR :: RSR -> RSR -> Bool+    RSR.eqRSR = \ (ds1 :: RSR.RSR) (ds2 :: RSR.RSR) ->+                case ds1 of _ { RSR.MkRSR s1 ->+                case ds2 of _ { RSR.MkRSR s2 ->+                SR.eqSR s1 s2 }}++    RSR.foo :: RSR -> RSR -> Bool+    RSR.foo = \ (x :: RSR) (y :: RSR) -> not (RSR.eqRSR x y)++Now, when optimising foo:+    Inline eqRSR (small, non-rec)+    Inline eqSR  (small, non-rec)+but the result of inlining eqSR from SR is another call to eqRSR, so+everything repeats.  Neither eqSR nor eqRSR are (apparently) loop+breakers.++Solution: in the unfolding of eqSR in SR.hi, replace `eqRSR` in SR+with `noinline eqRSR`, so that eqRSR doesn't get inlined.  This means+that when GHC inlines `eqSR`, it will not also inline `eqRSR`, exactly+as would have been the case if `foo` had been defined in SR.hs (and+marked as a loop-breaker).++But how do we arrange for this to happen?  There are two ingredients:++    1. When we serialize out unfoldings to IfaceExprs (toIfaceVar),+    for every variable reference we see if we are referring to an+    'Id' that came from an hs-boot file.  If so, we add a `noinline`+    to the reference.++    2. But how do we know if a reference came from an hs-boot file+    or not?  We could record this directly in the 'IdInfo', but+    actually we deduce this by looking at the unfolding: 'Id's+    that come from boot files are given a special unfolding+    (upon typechecking) 'BootUnfolding' which say that there is+    no unfolding, and the reason is because the 'Id' came from+    a boot file.++Here is a solution that doesn't work: when compiling RSR,+add a NOINLINE pragma to every function exported by the boot-file+for RSR (if it exists).  Doing so makes the bootstrapped GHC itself+slower by 8% overall (on Trac #9872a-d, and T1969: the reason+is that these NOINLINE'd functions now can't be profitably inlined+outside of the hs-boot loop.++-}
+ iface/ToIface.hs-boot view
@@ -0,0 +1,17 @@+module ToIface where++import {-# SOURCE #-} TyCoRep+import {-# SOURCE #-} IfaceType+import Var ( TyVar, TyVarBinder )+import TyCon ( TyCon )+import VarSet( VarSet )++-- For TyCoRep+toIfaceType :: Type -> IfaceType+toIfaceTypeX :: VarSet -> Type -> IfaceType+toIfaceTyLit :: TyLit -> IfaceTyLit+toIfaceForAllBndr :: TyVarBinder -> IfaceForAllBndr+toIfaceTvBndr :: TyVar -> IfaceTvBndr+toIfaceTyCon :: TyCon -> IfaceTyCon+toIfaceTcArgs :: TyCon -> [Type] -> IfaceTcArgs+toIfaceCoercion :: Coercion -> IfaceCoercion
+ llvmGen/Llvm.hs view
@@ -0,0 +1,64 @@+-- ----------------------------------------------------------------------------+-- | This module supplies bindings to generate Llvm IR from Haskell+-- (<http://www.llvm.org/docs/LangRef.html>).+--+-- Note: this module is developed in a demand driven way. It is no complete+-- LLVM binding library in Haskell, but enough to generate code for GHC.+--+-- This code is derived from code taken from the Essential Haskell Compiler+-- (EHC) project (<http://www.cs.uu.nl/wiki/Ehc/WebHome>).+--++module Llvm (++        -- * Modules, Functions and Blocks+        LlvmModule(..),++        LlvmFunction(..), LlvmFunctionDecl(..),+        LlvmFunctions, LlvmFunctionDecls,+        LlvmStatement(..), LlvmExpression(..),+        LlvmBlocks, LlvmBlock(..), LlvmBlockId,+        LlvmParamAttr(..), LlvmParameter,++        -- * Atomic operations+        LlvmAtomicOp(..),++        -- * Fence synchronization+        LlvmSyncOrdering(..),++        -- * Call Handling+        LlvmCallConvention(..), LlvmCallType(..), LlvmParameterListType(..),+        LlvmLinkageType(..), LlvmFuncAttr(..),++        -- * Operations and Comparisons+        LlvmCmpOp(..), LlvmMachOp(..), LlvmCastOp(..),++        -- * Variables and Type System+        LlvmVar(..), LlvmStatic(..), LlvmLit(..), LlvmType(..),+        LlvmAlias, LMGlobal(..), LMString, LMSection, LMAlign,+        LMConst(..),++        -- ** Some basic types+        i64, i32, i16, i8, i1, i8Ptr, llvmWord, llvmWordPtr,++        -- ** Metadata types+        MetaExpr(..), MetaAnnot(..), MetaDecl(..), MetaId(..),++        -- ** Operations on the type system.+        isGlobal, getLitType, getVarType,+        getLink, getStatType, pVarLift, pVarLower,+        pLift, pLower, isInt, isFloat, isPointer, isVector, llvmWidthInBits,++        -- * Pretty Printing+        ppLit, ppName, ppPlainName,+        ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals,+        ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions,+        ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, ppLlvmMetas, ppLlvmMeta,++    ) where++import Llvm.AbsSyn+import Llvm.MetaData+import Llvm.PpLlvm+import Llvm.Types+
+ llvmGen/Llvm/AbsSyn.hs view
@@ -0,0 +1,350 @@+--------------------------------------------------------------------------------+-- | The LLVM abstract syntax.+--++module Llvm.AbsSyn where++import Llvm.MetaData+import Llvm.Types++import Unique++-- | Block labels+type LlvmBlockId = Unique++-- | A block of LLVM code.+data LlvmBlock = LlvmBlock {+    -- | The code label for this block+    blockLabel :: LlvmBlockId,++    -- | A list of LlvmStatement's representing the code for this block.+    -- This list must end with a control flow statement.+    blockStmts :: [LlvmStatement]+  }++type LlvmBlocks = [LlvmBlock]++-- | An LLVM Module. This is a top level container in LLVM.+data LlvmModule = LlvmModule  {+    -- | Comments to include at the start of the module.+    modComments  :: [LMString],++    -- | LLVM Alias type definitions.+    modAliases   :: [LlvmAlias],++    -- | LLVM meta data.+    modMeta      :: [MetaDecl],++    -- | Global variables to include in the module.+    modGlobals   :: [LMGlobal],++    -- | LLVM Functions used in this module but defined in other modules.+    modFwdDecls  :: LlvmFunctionDecls,++    -- | LLVM Functions defined in this module.+    modFuncs     :: LlvmFunctions+  }++-- | An LLVM Function+data LlvmFunction = LlvmFunction {+    -- | The signature of this declared function.+    funcDecl      :: LlvmFunctionDecl,++    -- | The functions arguments+    funcArgs      :: [LMString],++    -- | The function attributes.+    funcAttrs     :: [LlvmFuncAttr],++    -- | The section to put the function into,+    funcSect      :: LMSection,++    -- | Prefix data+    funcPrefix    :: Maybe LlvmStatic,++    -- | The body of the functions.+    funcBody      :: LlvmBlocks+  }++type LlvmFunctions = [LlvmFunction]++type SingleThreaded = Bool++-- | LLVM ordering types for synchronization purposes. (Introduced in LLVM+-- 3.0). Please see the LLVM documentation for a better description.+data LlvmSyncOrdering+  -- | Some partial order of operations exists.+  = SyncUnord+  -- | A single total order for operations at a single address exists.+  | SyncMonotonic+  -- | Acquire synchronization operation.+  | SyncAcquire+  -- | Release synchronization operation.+  | SyncRelease+  -- | Acquire + Release synchronization operation.+  | SyncAcqRel+  -- | Full sequential Consistency operation.+  | SyncSeqCst+  deriving (Show, Eq)++-- | LLVM atomic operations. Please see the @atomicrmw@ instruction in+-- the LLVM documentation for a complete description.+data LlvmAtomicOp+  = LAO_Xchg+  | LAO_Add+  | LAO_Sub+  | LAO_And+  | LAO_Nand+  | LAO_Or+  | LAO_Xor+  | LAO_Max+  | LAO_Min+  | LAO_Umax+  | LAO_Umin+  deriving (Show, Eq)++-- | Llvm Statements+data LlvmStatement+  {- |+    Assign an expression to an variable:+      * dest:   Variable to assign to+      * source: Source expression+  -}+  = Assignment LlvmVar LlvmExpression++  {- |+    Memory fence operation+  -}+  | Fence Bool LlvmSyncOrdering++  {- |+    Always branch to the target label+  -}+  | Branch LlvmVar++  {- |+    Branch to label targetTrue if cond is true otherwise to label targetFalse+      * cond:        condition that will be tested, must be of type i1+      * targetTrue:  label to branch to if cond is true+      * targetFalse: label to branch to if cond is false+  -}+  | BranchIf LlvmVar LlvmVar LlvmVar++  {- |+    Comment+    Plain comment.+  -}+  | Comment [LMString]++  {- |+    Set a label on this position.+      * name: Identifier of this label, unique for this module+  -}+  | MkLabel LlvmBlockId++  {- |+    Store variable value in pointer ptr. If value is of type t then ptr must+    be of type t*.+      * value: Variable/Constant to store.+      * ptr:   Location to store the value in+  -}+  | Store LlvmVar LlvmVar++  {- |+    Multiway branch+      * scrutinee: Variable or constant which must be of integer type that is+                   determines which arm is chosen.+      * def:       The default label if there is no match in target.+      * target:    A list of (value,label) where the value is an integer+                   constant and label the corresponding label to jump to if the+                   scrutinee matches the value.+  -}+  | Switch LlvmVar LlvmVar [(LlvmVar, LlvmVar)]++  {- |+    Return a result.+      * result: The variable or constant to return+  -}+  | Return (Maybe LlvmVar)++  {- |+    An instruction for the optimizer that the code following is not reachable+  -}+  | Unreachable++  {- |+    Raise an expression to a statement (if don't want result or want to use+    Llvm unnamed values.+  -}+  | Expr LlvmExpression++  {- |+    A nop LLVM statement. Useful as its often more efficient to use this+    then to wrap LLvmStatement in a Just or [].+  -}+  | Nop++  {- |+    A LLVM statement with metadata attached to it.+  -}+  | MetaStmt [MetaAnnot] LlvmStatement++  deriving (Eq)+++-- | Llvm Expressions+data LlvmExpression+  {- |+    Allocate amount * sizeof(tp) bytes on the stack+      * tp:     LlvmType to reserve room for+      * amount: The nr of tp's which must be allocated+  -}+  = Alloca LlvmType Int++  {- |+    Perform the machine operator op on the operands left and right+      * op:    operator+      * left:  left operand+      * right: right operand+  -}+  | LlvmOp LlvmMachOp LlvmVar LlvmVar++  {- |+    Perform a compare operation on the operands left and right+      * op:    operator+      * left:  left operand+      * right: right operand+  -}+  | Compare LlvmCmpOp LlvmVar LlvmVar++  {- |+    Extract a scalar element from a vector+      * val: The vector+      * idx: The index of the scalar within the vector+  -}+  | Extract LlvmVar LlvmVar++  {- |+    Extract a scalar element from a structure+      * val: The structure+      * idx: The index of the scalar within the structure+    Corresponds to "extractvalue" instruction.+  -}+  | ExtractV LlvmVar Int++  {- |+    Insert a scalar element into a vector+      * val:   The source vector+      * elt:   The scalar to insert+      * index: The index at which to insert the scalar+  -}+  | Insert LlvmVar LlvmVar LlvmVar++  {- |+    Allocate amount * sizeof(tp) bytes on the heap+      * tp:     LlvmType to reserve room for+      * amount: The nr of tp's which must be allocated+  -}+  | Malloc LlvmType Int++  {- |+    Load the value at location ptr+  -}+  | Load LlvmVar++  {- |+    Atomic load of the value at location ptr+  -}+  | ALoad LlvmSyncOrdering SingleThreaded LlvmVar++  {- |+    Navigate in an structure, selecting elements+      * inbound: Is the pointer inbounds? (computed pointer doesn't overflow)+      * ptr:     Location of the structure+      * indexes: A list of indexes to select the correct value.+  -}+  | GetElemPtr Bool LlvmVar [LlvmVar]++  {- |+    Cast the variable from to the to type. This is an abstraction of three+    cast operators in Llvm, inttoptr, prttoint and bitcast.+       * cast: Cast type+       * from: Variable to cast+       * to:   type to cast to+  -}+  | Cast LlvmCastOp LlvmVar LlvmType++  {- |+    Atomic read-modify-write operation+       * op:       Atomic operation+       * addr:     Address to modify+       * operand:  Operand to operation+       * ordering: Ordering requirement+  -}+  | AtomicRMW LlvmAtomicOp LlvmVar LlvmVar LlvmSyncOrdering++  {- |+    Compare-and-exchange operation+       * addr:     Address to modify+       * old:      Expected value+       * new:      New value+       * suc_ord:  Ordering required in success case+       * fail_ord: Ordering required in failure case, can be no stronger than+                   suc_ord++    Result is an @i1@, true if store was successful.+  -}+  | CmpXChg LlvmVar LlvmVar LlvmVar LlvmSyncOrdering LlvmSyncOrdering++  {- |+    Call a function. The result is the value of the expression.+      * tailJumps: CallType to signal if the function should be tail called+      * fnptrval:  An LLVM value containing a pointer to a function to be+                   invoked. Can be indirect. Should be LMFunction type.+      * args:      Concrete arguments for the parameters+      * attrs:     A list of function attributes for the call. Only NoReturn,+                   NoUnwind, ReadOnly and ReadNone are valid here.+  -}+  | Call LlvmCallType LlvmVar [LlvmVar] [LlvmFuncAttr]++  {- |+    Call a function as above but potentially taking metadata as arguments.+      * tailJumps: CallType to signal if the function should be tail called+      * fnptrval:  An LLVM value containing a pointer to a function to be+                   invoked. Can be indirect. Should be LMFunction type.+      * args:      Arguments that may include metadata.+      * attrs:     A list of function attributes for the call. Only NoReturn,+                   NoUnwind, ReadOnly and ReadNone are valid here.+  -}+  | CallM LlvmCallType LlvmVar [MetaExpr] [LlvmFuncAttr]++  {- |+    Merge variables from different basic blocks which are predecessors of this+    basic block in a new variable of type tp.+      * tp:         type of the merged variable, must match the types of the+                    predecessor variables.+      * precessors: A list of variables and the basic block that they originate+                    from.+  -}+  | Phi LlvmType [(LlvmVar,LlvmVar)]++  {- |+    Inline assembly expression. Syntax is very similar to the style used by GCC.+      * assembly:    Actual inline assembly code.+      * constraints: Operand constraints.+      * return ty:   Return type of function.+      * vars:        Any variables involved in the assembly code.+      * sideeffect:  Does the expression have side effects not visible from the+                     constraints list.+      * alignstack:  Should the stack be conservatively aligned before this+                     expression is executed.+  -}+  | Asm LMString LMString LlvmType [LlvmVar] Bool Bool++  {- |+    A LLVM expression with metadata attached to it.+  -}+  | MExpr [MetaAnnot] LlvmExpression++  deriving (Eq)+
+ llvmGen/Llvm/MetaData.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Llvm.MetaData where++import Llvm.Types+import Outputable++-- The LLVM Metadata System.+--+-- The LLVM metadata feature is poorly documented but roughly follows the+-- following design:+-- * Metadata can be constructed in a few different ways (See below).+-- * After which it can either be attached to LLVM statements to pass along+-- extra information to the optimizer and code generator OR specifically named+-- metadata has an affect on the whole module (i.e., linking behaviour).+--+--+-- # Constructing metadata+-- Metadata comes largely in three forms:+--+-- * Metadata expressions -- these are the raw metadata values that encode+--   information. They consist of metadata strings, metadata nodes, regular+--   LLVM values (both literals and references to global variables) and+--   metadata expressions (i.e., recursive data type). Some examples:+--     !{ !"hello", !0, i32 0 }+--     !{ !1, !{ i32 0 } }+--+-- * Metadata nodes -- global metadata variables that attach a metadata+--   expression to a number. For example:+--     !0 = !{ [<metadata expressions>] !}+--+-- * Named metadata -- global metadata variables that attach a metadata nodes+--   to a name. Used ONLY to communicated module level information to LLVM+--   through a meaningful name. For example:+--     !llvm.module.linkage = !{ !0, !1 }+--+--+-- # Using Metadata+-- Using metadata depends on the form it is in:+--+-- * Attach to instructions -- metadata can be attached to LLVM instructions+--   using a specific reference as follows:+--     %l = load i32* @glob, !nontemporal !10+--     %m = load i32* @glob, !nontemporal !{ i32 0, !{ i32 0 } }+--   Only metadata nodes or expressions can be attached, named metadata cannot.+--   Refer to LLVM documentation for which instructions take metadata and its+--   meaning.+--+-- * As arguments -- llvm functions can take metadata as arguments, for+--   example:+--     call void @llvm.dbg.value(metadata !{ i32 0 }, i64 0, metadata !1)+--   As with instructions, only metadata nodes or expressions can be attached.+--+-- * As a named metadata -- Here the metadata is simply declared in global+--   scope using a specific name to communicate module level information to LLVM.+--   For example:+--     !llvm.module.linkage = !{ !0, !1 }+--++-- | A reference to an un-named metadata node.+newtype MetaId = MetaId Int+               deriving (Eq, Ord, Enum)++instance Outputable MetaId where+    ppr (MetaId n) = char '!' <> int n++-- | LLVM metadata expressions+data MetaExpr = MetaStr !LMString+              | MetaNode !MetaId+              | MetaVar !LlvmVar+              | MetaStruct [MetaExpr]+              deriving (Eq)++instance Outputable MetaExpr where+  ppr (MetaVar (LMLitVar (LMNullLit _))) = text "null"+  ppr (MetaStr    s ) = char '!' <> doubleQuotes (ftext s)+  ppr (MetaNode   n ) = ppr n+  ppr (MetaVar    v ) = ppr v+  ppr (MetaStruct es) = char '!' <> braces (ppCommaJoin es)++-- | Associates some metadata with a specific label for attaching to an+-- instruction.+data MetaAnnot = MetaAnnot LMString MetaExpr+               deriving (Eq)++-- | Metadata declarations. Metadata can only be declared in global scope.+data MetaDecl+    -- | Named metadata. Only used for communicating module information to+    -- LLVM. ('!name = !{ [!<n>] }' form).+    = MetaNamed !LMString [MetaId]+    -- | Metadata node declaration.+    -- ('!0 = metadata !{ <metadata expression> }' form).+    | MetaUnnamed !MetaId !MetaExpr
+ llvmGen/Llvm/PpLlvm.hs view
@@ -0,0 +1,497 @@+{-# LANGUAGE CPP #-}++--------------------------------------------------------------------------------+-- | Pretty print LLVM IR Code.+--++module Llvm.PpLlvm (++    -- * Top level LLVM objects.+    ppLlvmModule,+    ppLlvmComments,+    ppLlvmComment,+    ppLlvmGlobals,+    ppLlvmGlobal,+    ppLlvmAliases,+    ppLlvmAlias,+    ppLlvmMetas,+    ppLlvmMeta,+    ppLlvmFunctionDecls,+    ppLlvmFunctionDecl,+    ppLlvmFunctions,+    ppLlvmFunction,++    ) where++#include "HsVersions.h"++import Llvm.AbsSyn+import Llvm.MetaData+import Llvm.Types++import Data.List ( intersperse )+import Outputable+import Unique+import FastString ( sLit )++--------------------------------------------------------------------------------+-- * Top Level Print functions+--------------------------------------------------------------------------------++-- | Print out a whole LLVM module.+ppLlvmModule :: LlvmModule -> SDoc+ppLlvmModule (LlvmModule comments aliases meta globals decls funcs)+  = ppLlvmComments comments $+$ newLine+    $+$ ppLlvmAliases aliases $+$ newLine+    $+$ ppLlvmMetas meta $+$ newLine+    $+$ ppLlvmGlobals globals $+$ newLine+    $+$ ppLlvmFunctionDecls decls $+$ newLine+    $+$ ppLlvmFunctions funcs++-- | Print out a multi-line comment, can be inside a function or on its own+ppLlvmComments :: [LMString] -> SDoc+ppLlvmComments comments = vcat $ map ppLlvmComment comments++-- | Print out a comment, can be inside a function or on its own+ppLlvmComment :: LMString -> SDoc+ppLlvmComment com = semi <+> ftext com+++-- | Print out a list of global mutable variable definitions+ppLlvmGlobals :: [LMGlobal] -> SDoc+ppLlvmGlobals ls = vcat $ map ppLlvmGlobal ls++-- | Print out a global mutable variable definition+ppLlvmGlobal :: LMGlobal -> SDoc+ppLlvmGlobal (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) =+    let sect = case x of+            Just x' -> text ", section" <+> doubleQuotes (ftext x')+            Nothing -> empty++        align = case a of+            Just a' -> text ", align" <+> int a'+            Nothing -> empty++        rhs = case dat of+            Just stat -> pprSpecialStatic stat+            Nothing   -> ppr (pLower $ getVarType var)++        -- Position of linkage is different for aliases.+        const = case c of+          Global   -> text "global"+          Constant -> text "constant"+          Alias    -> text "alias"++    in ppAssignment var $ ppr link <+> const <+> rhs <> sect <> align+       $+$ newLine++ppLlvmGlobal (LMGlobal var val) = sdocWithDynFlags $ \dflags ->+  error $ "Non Global var ppr as global! "+          ++ showSDoc dflags (ppr var) ++ " " ++ showSDoc dflags (ppr val)+++-- | Print out a list of LLVM type aliases.+ppLlvmAliases :: [LlvmAlias] -> SDoc+ppLlvmAliases tys = vcat $ map ppLlvmAlias tys++-- | Print out an LLVM type alias.+ppLlvmAlias :: LlvmAlias -> SDoc+ppLlvmAlias (name, ty)+  = char '%' <> ftext name <+> equals <+> text "type" <+> ppr ty+++-- | Print out a list of LLVM metadata.+ppLlvmMetas :: [MetaDecl] -> SDoc+ppLlvmMetas metas = vcat $ map ppLlvmMeta metas++-- | Print out an LLVM metadata definition.+ppLlvmMeta :: MetaDecl -> SDoc+ppLlvmMeta (MetaUnnamed n m)+  = ppr n <+> equals <+> ppr m++ppLlvmMeta (MetaNamed n m)+  = exclamation <> ftext n <+> equals <+> exclamation <> braces nodes+  where+    nodes = hcat $ intersperse comma $ map ppr m+++-- | Print out a list of function definitions.+ppLlvmFunctions :: LlvmFunctions -> SDoc+ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs++-- | Print out a function definition.+ppLlvmFunction :: LlvmFunction -> SDoc+ppLlvmFunction fun =+    let attrDoc = ppSpaceJoin (funcAttrs fun)+        secDoc = case funcSect fun of+                      Just s' -> text "section" <+> (doubleQuotes $ ftext s')+                      Nothing -> empty+        prefixDoc = case funcPrefix fun of+                        Just v  -> text "prefix" <+> ppr v+                        Nothing -> empty+    in text "define" <+> ppLlvmFunctionHeader (funcDecl fun) (funcArgs fun)+        <+> attrDoc <+> secDoc <+> prefixDoc+        $+$ lbrace+        $+$ ppLlvmBlocks (funcBody fun)+        $+$ rbrace+        $+$ newLine+        $+$ newLine++-- | Print out a function definition header.+ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc+ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args+  = let varg' = case varg of+                      VarArgs | null p    -> sLit "..."+                              | otherwise -> sLit ", ..."+                      _otherwise          -> sLit ""+        align = case a of+                     Just a' -> text " align " <> ppr a'+                     Nothing -> empty+        args' = map (\((ty,p),n) -> ppr ty <+> ppSpaceJoin p <+> char '%'+                                    <> ftext n)+                    (zip p args)+    in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <> lparen <>+        (hsep $ punctuate comma args') <> ptext varg' <> rparen <> align++-- | Print out a list of function declaration.+ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc+ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs++-- | Print out a function declaration.+-- Declarations define the function type but don't define the actual body of+-- the function.+ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc+ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a)+  = let varg' = case varg of+                      VarArgs | null p    -> sLit "..."+                              | otherwise -> sLit ", ..."+                      _otherwise          -> sLit ""+        align = case a of+                     Just a' -> text " align" <+> ppr a'+                     Nothing -> empty+        args = hcat $ intersperse (comma <> space) $+                  map (\(t,a) -> ppr t <+> ppSpaceJoin a) p+    in text "declare" <+> ppr l <+> ppr c <+> ppr r <+> char '@' <>+        ftext n <> lparen <> args <> ptext varg' <> rparen <> align $+$ newLine+++-- | Print out a list of LLVM blocks.+ppLlvmBlocks :: LlvmBlocks -> SDoc+ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks++-- | Print out an LLVM block.+-- It must be part of a function definition.+ppLlvmBlock :: LlvmBlock -> SDoc+ppLlvmBlock (LlvmBlock blockId stmts) =+  let isLabel (MkLabel _) = True+      isLabel _           = False+      (block, rest)       = break isLabel stmts+      ppRest = case rest of+        MkLabel id:xs -> ppLlvmBlock (LlvmBlock id xs)+        _             -> empty+  in ppLlvmBlockLabel blockId+           $+$ (vcat $ map ppLlvmStatement block)+           $+$ newLine+           $+$ ppRest++-- | Print out an LLVM block label.+ppLlvmBlockLabel :: LlvmBlockId -> SDoc+ppLlvmBlockLabel id = pprUniqueAlways id <> colon+++-- | Print out an LLVM statement.+ppLlvmStatement :: LlvmStatement -> SDoc+ppLlvmStatement stmt =+  let ind = (text "  " <>)+  in case stmt of+        Assignment  dst expr      -> ind $ ppAssignment dst (ppLlvmExpression expr)+        Fence       st ord        -> ind $ ppFence st ord+        Branch      target        -> ind $ ppBranch target+        BranchIf    cond ifT ifF  -> ind $ ppBranchIf cond ifT ifF+        Comment     comments      -> ind $ ppLlvmComments comments+        MkLabel     label         -> ppLlvmBlockLabel label+        Store       value ptr     -> ind $ ppStore value ptr+        Switch      scrut def tgs -> ind $ ppSwitch scrut def tgs+        Return      result        -> ind $ ppReturn result+        Expr        expr          -> ind $ ppLlvmExpression expr+        Unreachable               -> ind $ text "unreachable"+        Nop                       -> empty+        MetaStmt    meta s        -> ppMetaStatement meta s+++-- | Print out an LLVM expression.+ppLlvmExpression :: LlvmExpression -> SDoc+ppLlvmExpression expr+  = case expr of+        Alloca     tp amount        -> ppAlloca tp amount+        LlvmOp     op left right    -> ppMachOp op left right+        Call       tp fp args attrs -> ppCall tp fp (map MetaVar args) attrs+        CallM      tp fp args attrs -> ppCall tp fp args attrs+        Cast       op from to       -> ppCast op from to+        Compare    op left right    -> ppCmpOp op left right+        Extract    vec idx          -> ppExtract vec idx+        ExtractV   struct idx       -> ppExtractV struct idx+        Insert     vec elt idx      -> ppInsert vec elt idx+        GetElemPtr inb ptr indexes  -> ppGetElementPtr inb ptr indexes+        Load       ptr              -> ppLoad ptr+        ALoad      ord st ptr       -> ppALoad ord st ptr+        Malloc     tp amount        -> ppMalloc tp amount+        AtomicRMW  aop tgt src ordering -> ppAtomicRMW aop tgt src ordering+        CmpXChg    addr old new s_ord f_ord -> ppCmpXChg addr old new s_ord f_ord+        Phi        tp precessors    -> ppPhi tp precessors+        Asm        asm c ty v se sk -> ppAsm asm c ty v se sk+        MExpr      meta expr        -> ppMetaExpr meta expr+++--------------------------------------------------------------------------------+-- * Individual print functions+--------------------------------------------------------------------------------++-- | Should always be a function pointer. So a global var of function type+-- (since globals are always pointers) or a local var of pointer function type.+ppCall :: LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc+ppCall ct fptr args attrs = case fptr of+                           --+    -- if local var function pointer, unwrap+    LMLocalVar _ (LMPointer (LMFunction d)) -> ppCall' d++    -- should be function type otherwise+    LMGlobalVar _ (LMFunction d) _ _ _ _    -> ppCall' d++    -- not pointer or function, so error+    _other -> error $ "ppCall called with non LMFunction type!\nMust be "+                ++ " called with either global var of function type or "+                ++ "local var of pointer function type."++    where+        ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) =+            let tc = if ct == TailCall then text "tail " else empty+                ppValues = hsep $ punctuate comma $ map ppCallMetaExpr args+                ppArgTy  = (ppCommaJoin $ map fst params) <>+                           (case argTy of+                               VarArgs   -> text ", ..."+                               FixedArgs -> empty)+                fnty = space <> lparen <> ppArgTy <> rparen+                attrDoc = ppSpaceJoin attrs+            in  tc <> text "call" <+> ppr cc <+> ppr ret+                    <> fnty <+> ppName fptr <> lparen <+> ppValues+                    <+> rparen <+> attrDoc++        -- Metadata needs to be marked as having the `metadata` type when used+        -- in a call argument+        ppCallMetaExpr (MetaVar v) = ppr v+        ppCallMetaExpr v           = text "metadata" <+> ppr v++ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc+ppMachOp op left right =+  (ppr op) <+> (ppr (getVarType left)) <+> ppName left+        <> comma <+> ppName right+++ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc+ppCmpOp op left right =+  let cmpOp+        | isInt (getVarType left) && isInt (getVarType right) = text "icmp"+        | isFloat (getVarType left) && isFloat (getVarType right) = text "fcmp"+        | otherwise = text "icmp" -- Just continue as its much easier to debug+        {-+        | otherwise = error ("can't compare different types, left = "+                ++ (show $ getVarType left) ++ ", right = "+                ++ (show $ getVarType right))+        -}+  in cmpOp <+> ppr op <+> ppr (getVarType left)+        <+> ppName left <> comma <+> ppName right+++ppAssignment :: LlvmVar -> SDoc -> SDoc+ppAssignment var expr = ppName var <+> equals <+> expr++ppFence :: Bool -> LlvmSyncOrdering -> SDoc+ppFence st ord =+  let singleThread = case st of True  -> text "singlethread"+                                False -> empty+  in text "fence" <+> singleThread <+> ppSyncOrdering ord++ppSyncOrdering :: LlvmSyncOrdering -> SDoc+ppSyncOrdering SyncUnord     = text "unordered"+ppSyncOrdering SyncMonotonic = text "monotonic"+ppSyncOrdering SyncAcquire   = text "acquire"+ppSyncOrdering SyncRelease   = text "release"+ppSyncOrdering SyncAcqRel    = text "acq_rel"+ppSyncOrdering SyncSeqCst    = text "seq_cst"++ppAtomicOp :: LlvmAtomicOp -> SDoc+ppAtomicOp LAO_Xchg = text "xchg"+ppAtomicOp LAO_Add  = text "add"+ppAtomicOp LAO_Sub  = text "sub"+ppAtomicOp LAO_And  = text "and"+ppAtomicOp LAO_Nand = text "nand"+ppAtomicOp LAO_Or   = text "or"+ppAtomicOp LAO_Xor  = text "xor"+ppAtomicOp LAO_Max  = text "max"+ppAtomicOp LAO_Min  = text "min"+ppAtomicOp LAO_Umax = text "umax"+ppAtomicOp LAO_Umin = text "umin"++ppAtomicRMW :: LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc+ppAtomicRMW aop tgt src ordering =+  text "atomicrmw" <+> ppAtomicOp aop <+> ppr tgt <> comma+  <+> ppr src <+> ppSyncOrdering ordering++ppCmpXChg :: LlvmVar -> LlvmVar -> LlvmVar+          -> LlvmSyncOrdering -> LlvmSyncOrdering -> SDoc+ppCmpXChg addr old new s_ord f_ord =+  text "cmpxchg" <+> ppr addr <> comma <+> ppr old <> comma <+> ppr new+  <+> ppSyncOrdering s_ord <+> ppSyncOrdering f_ord++-- XXX: On x86, vector types need to be 16-byte aligned for aligned access, but+-- we have no way of guaranteeing that this is true with GHC (we would need to+-- modify the layout of the stack and closures, change the storage manager,+-- etc.). So, we blindly tell LLVM that *any* vector store or load could be+-- unaligned. In the future we may be able to guarantee that certain vector+-- access patterns are aligned, in which case we will need a more granular way+-- of specifying alignment.++ppLoad :: LlvmVar -> SDoc+ppLoad var = text "load" <+> ppr derefType <> comma <+> ppr var <> align+  where+    derefType = pLower $ getVarType var+    align | isVector . pLower . getVarType $ var = text ", align 1"+          | otherwise = empty++ppALoad :: LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc+ppALoad ord st var = sdocWithDynFlags $ \dflags ->+  let alignment = (llvmWidthInBits dflags $ getVarType var) `quot` 8+      align     = text ", align" <+> ppr alignment+      sThreaded | st        = text " singlethread"+                | otherwise = empty+      derefType = pLower $ getVarType var+  in text "load atomic" <+> ppr derefType <> comma <+> ppr var <> sThreaded+            <+> ppSyncOrdering ord <> align++ppStore :: LlvmVar -> LlvmVar -> SDoc+ppStore val dst+    | isVecPtrVar dst = text "store" <+> ppr val <> comma <+> ppr dst <>+                        comma <+> text "align 1"+    | otherwise       = text "store" <+> ppr val <> comma <+> ppr dst+  where+    isVecPtrVar :: LlvmVar -> Bool+    isVecPtrVar = isVector . pLower . getVarType+++ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> SDoc+ppCast op from to+    =   ppr op+    <+> ppr (getVarType from) <+> ppName from+    <+> text "to"+    <+> ppr to+++ppMalloc :: LlvmType -> Int -> SDoc+ppMalloc tp amount =+  let amount' = LMLitVar $ LMIntLit (toInteger amount) i32+  in text "malloc" <+> ppr tp <> comma <+> ppr amount'+++ppAlloca :: LlvmType -> Int -> SDoc+ppAlloca tp amount =+  let amount' = LMLitVar $ LMIntLit (toInteger amount) i32+  in text "alloca" <+> ppr tp <> comma <+> ppr amount'+++ppGetElementPtr :: Bool -> LlvmVar -> [LlvmVar] -> SDoc+ppGetElementPtr inb ptr idx =+  let indexes = comma <+> ppCommaJoin idx+      inbound = if inb then text "inbounds" else empty+      derefType = pLower $ getVarType ptr+  in text "getelementptr" <+> inbound <+> ppr derefType <> comma <+> ppr ptr+                            <> indexes+++ppReturn :: Maybe LlvmVar -> SDoc+ppReturn (Just var) = text "ret" <+> ppr var+ppReturn Nothing    = text "ret" <+> ppr LMVoid+++ppBranch :: LlvmVar -> SDoc+ppBranch var = text "br" <+> ppr var+++ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc+ppBranchIf cond trueT falseT+  = text "br" <+> ppr cond <> comma <+> ppr trueT <> comma <+> ppr falseT+++ppPhi :: LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc+ppPhi tp preds =+  let ppPreds (val, label) = brackets $ ppName val <> comma <+> ppName label+  in text "phi" <+> ppr tp <+> hsep (punctuate comma $ map ppPreds preds)+++ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc+ppSwitch scrut dflt targets =+  let ppTarget  (val, lab) = ppr val <> comma <+> ppr lab+      ppTargets  xs        = brackets $ vcat (map ppTarget xs)+  in text "switch" <+> ppr scrut <> comma <+> ppr dflt+        <+> ppTargets targets+++ppAsm :: LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc+ppAsm asm constraints rty vars sideeffect alignstack =+  let asm'  = doubleQuotes $ ftext asm+      cons  = doubleQuotes $ ftext constraints+      rty'  = ppr rty+      vars' = lparen <+> ppCommaJoin vars <+> rparen+      side  = if sideeffect then text "sideeffect" else empty+      align = if alignstack then text "alignstack" else empty+  in text "call" <+> rty' <+> text "asm" <+> side <+> align <+> asm' <> comma+        <+> cons <> vars'++ppExtract :: LlvmVar -> LlvmVar -> SDoc+ppExtract vec idx =+    text "extractelement"+    <+> ppr (getVarType vec) <+> ppName vec <> comma+    <+> ppr idx++ppExtractV :: LlvmVar -> Int -> SDoc+ppExtractV struct idx =+    text "extractvalue"+    <+> ppr (getVarType struct) <+> ppName struct <> comma+    <+> ppr idx++ppInsert :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc+ppInsert vec elt idx =+    text "insertelement"+    <+> ppr (getVarType vec) <+> ppName vec <> comma+    <+> ppr (getVarType elt) <+> ppName elt <> comma+    <+> ppr idx+++ppMetaStatement :: [MetaAnnot] -> LlvmStatement -> SDoc+ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetaAnnots meta++ppMetaExpr :: [MetaAnnot] -> LlvmExpression -> SDoc+ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetaAnnots meta++ppMetaAnnots :: [MetaAnnot] -> SDoc+ppMetaAnnots meta = hcat $ map ppMeta meta+  where+    ppMeta (MetaAnnot name e)+        = comma <+> exclamation <> ftext name <+>+          case e of+            MetaNode n    -> ppr n+            MetaStruct ms -> exclamation <> braces (ppCommaJoin ms)+            other         -> exclamation <> braces (ppr other) -- possible?+++--------------------------------------------------------------------------------+-- * Misc functions+--------------------------------------------------------------------------------++-- | Blank line.+newLine :: SDoc+newLine = empty++-- | Exclamation point.+exclamation :: SDoc+exclamation = char '!'
+ llvmGen/Llvm/Types.hs view
@@ -0,0 +1,886 @@+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}++--------------------------------------------------------------------------------+-- | The LLVM Type System.+--++module Llvm.Types where++#include "HsVersions.h"++import Data.Char+import Data.Int+import Numeric++import DynFlags+import FastString+import Outputable+import Unique++-- from NCG+import PprBase++import GHC.Float++-- -----------------------------------------------------------------------------+-- * LLVM Basic Types and Variables+--++-- | A global mutable variable. Maybe defined or external+data LMGlobal = LMGlobal {+  getGlobalVar :: LlvmVar,          -- ^ Returns the variable of the 'LMGlobal'+  getGlobalValue :: Maybe LlvmStatic -- ^ Return the value of the 'LMGlobal'+  }++-- | A String in LLVM+type LMString = FastString++-- | A type alias+type LlvmAlias = (LMString, LlvmType)++-- | Llvm Types+data LlvmType+  = LMInt Int             -- ^ An integer with a given width in bits.+  | LMFloat               -- ^ 32 bit floating point+  | LMDouble              -- ^ 64 bit floating point+  | LMFloat80             -- ^ 80 bit (x86 only) floating point+  | LMFloat128            -- ^ 128 bit floating point+  | LMPointer LlvmType    -- ^ A pointer to a 'LlvmType'+  | LMArray Int LlvmType  -- ^ An array of 'LlvmType'+  | LMVector Int LlvmType -- ^ A vector of 'LlvmType'+  | LMLabel               -- ^ A 'LlvmVar' can represent a label (address)+  | LMVoid                -- ^ Void type+  | LMStruct [LlvmType]   -- ^ Packed structure type+  | LMStructU [LlvmType]  -- ^ Unpacked structure type+  | LMAlias LlvmAlias     -- ^ A type alias+  | LMMetadata            -- ^ LLVM Metadata++  -- | Function type, used to create pointers to functions+  | LMFunction LlvmFunctionDecl+  deriving (Eq)++instance Outputable LlvmType where+  ppr (LMInt size     ) = char 'i' <> ppr size+  ppr (LMFloat        ) = text "float"+  ppr (LMDouble       ) = text "double"+  ppr (LMFloat80      ) = text "x86_fp80"+  ppr (LMFloat128     ) = text "fp128"+  ppr (LMPointer x    ) = ppr x <> char '*'+  ppr (LMArray nr tp  ) = char '[' <> ppr nr <> text " x " <> ppr tp <> char ']'+  ppr (LMVector nr tp ) = char '<' <> ppr nr <> text " x " <> ppr tp <> char '>'+  ppr (LMLabel        ) = text "label"+  ppr (LMVoid         ) = text "void"+  ppr (LMStruct tys   ) = text "<{" <> ppCommaJoin tys <> text "}>"+  ppr (LMStructU tys  ) = text "{" <> ppCommaJoin tys <> text "}"+  ppr (LMMetadata     ) = text "metadata"++  ppr (LMFunction (LlvmFunctionDecl _ _ _ r varg p _))+    = ppr r <+> lparen <> ppParams varg p <> rparen++  ppr (LMAlias (s,_)) = char '%' <> ftext s++ppParams :: LlvmParameterListType -> [LlvmParameter] -> SDoc+ppParams varg p+  = let varg' = case varg of+          VarArgs | null args -> sLit "..."+                  | otherwise -> sLit ", ..."+          _otherwise          -> sLit ""+        -- by default we don't print param attributes+        args = map fst p+    in ppCommaJoin args <> ptext varg'++-- | An LLVM section definition. If Nothing then let LLVM decide the section+type LMSection = Maybe LMString+type LMAlign = Maybe Int++data LMConst = Global      -- ^ Mutable global variable+             | Constant    -- ^ Constant global variable+             | Alias       -- ^ Alias of another variable+             deriving (Eq)++-- | LLVM Variables+data LlvmVar+  -- | Variables with a global scope.+  = LMGlobalVar LMString LlvmType LlvmLinkageType LMSection LMAlign LMConst+  -- | Variables local to a function or parameters.+  | LMLocalVar Unique LlvmType+  -- | Named local variables. Sometimes we need to be able to explicitly name+  -- variables (e.g for function arguments).+  | LMNLocalVar LMString LlvmType+  -- | A constant variable+  | LMLitVar LlvmLit+  deriving (Eq)++instance Outputable LlvmVar where+  ppr (LMLitVar x)  = ppr x+  ppr (x         )  = ppr (getVarType x) <+> ppName x+++-- | Llvm Literal Data.+--+-- These can be used inline in expressions.+data LlvmLit+  -- | Refers to an integer constant (i64 42).+  = LMIntLit Integer LlvmType+  -- | Floating point literal+  | LMFloatLit Double LlvmType+  -- | Literal NULL, only applicable to pointer types+  | LMNullLit LlvmType+  -- | Vector literal+  | LMVectorLit [LlvmLit]+  -- | Undefined value, random bit pattern. Useful for optimisations.+  | LMUndefLit LlvmType+  deriving (Eq)++instance Outputable LlvmLit where+  ppr l@(LMVectorLit {}) = ppLit l+  ppr l                  = ppr (getLitType l) <+> ppLit l+++-- | Llvm Static Data.+--+-- These represent the possible global level variables and constants.+data LlvmStatic+  = LMComment LMString                  -- ^ A comment in a static section+  | LMStaticLit LlvmLit                 -- ^ A static variant of a literal value+  | LMUninitType LlvmType               -- ^ For uninitialised data+  | LMStaticStr LMString LlvmType       -- ^ Defines a static 'LMString'+  | LMStaticArray [LlvmStatic] LlvmType -- ^ A static array+  | LMStaticStruc [LlvmStatic] LlvmType -- ^ A static structure type+  | LMStaticPointer LlvmVar             -- ^ A pointer to other data++  -- static expressions, could split out but leave+  -- for moment for ease of use. Not many of them.++  | LMBitc LlvmStatic LlvmType         -- ^ Pointer to Pointer conversion+  | LMPtoI LlvmStatic LlvmType         -- ^ Pointer to Integer conversion+  | LMAdd LlvmStatic LlvmStatic        -- ^ Constant addition operation+  | LMSub LlvmStatic LlvmStatic        -- ^ Constant subtraction operation++instance Outputable LlvmStatic where+  ppr (LMComment       s) = text "; " <> ftext s+  ppr (LMStaticLit   l  ) = ppr l+  ppr (LMUninitType    t) = ppr t <> text " undef"+  ppr (LMStaticStr   s t) = ppr t <> text " c\"" <> ftext s <> text "\\00\""+  ppr (LMStaticArray d t) = ppr t <> text " [" <> ppCommaJoin d <> char ']'+  ppr (LMStaticStruc d t) = ppr t <> text "<{" <> ppCommaJoin d <> text "}>"+  ppr (LMStaticPointer v) = ppr v+  ppr (LMBitc v t)+      = ppr t <> text " bitcast (" <> ppr v <> text " to " <> ppr t <> char ')'+  ppr (LMPtoI v t)+      = ppr t <> text " ptrtoint (" <> ppr v <> text " to " <> ppr t <> char ')'++  ppr (LMAdd s1 s2)+      = pprStaticArith s1 s2 (sLit "add") (sLit "fadd") "LMAdd"+  ppr (LMSub s1 s2)+      = pprStaticArith s1 s2 (sLit "sub") (sLit "fsub") "LMSub"+++pprSpecialStatic :: LlvmStatic -> SDoc+pprSpecialStatic (LMBitc v t) =+    ppr (pLower t) <> text ", bitcast (" <> ppr v <> text " to " <> ppr t+        <> char ')'+pprSpecialStatic stat = ppr stat+++pprStaticArith :: LlvmStatic -> LlvmStatic -> LitString -> LitString -> String -> SDoc+pprStaticArith s1 s2 int_op float_op op_name =+  let ty1 = getStatType s1+      op  = if isFloat ty1 then float_op else int_op+  in if ty1 == getStatType s2+     then ppr ty1 <+> ptext op <+> lparen <> ppr s1 <> comma <> ppr s2 <> rparen+     else sdocWithDynFlags $ \dflags ->+            error $ op_name ++ " with different types! s1: "+                    ++ showSDoc dflags (ppr s1) ++ ", s2: " ++ showSDoc dflags (ppr s2)++-- -----------------------------------------------------------------------------+-- ** Operations on LLVM Basic Types and Variables+--++-- | Return the variable name or value of the 'LlvmVar'+-- in Llvm IR textual representation (e.g. @\@x@, @%y@ or @42@).+ppName :: LlvmVar -> SDoc+ppName v@(LMGlobalVar {}) = char '@' <> ppPlainName v+ppName v@(LMLocalVar  {}) = char '%' <> ppPlainName v+ppName v@(LMNLocalVar {}) = char '%' <> ppPlainName v+ppName v@(LMLitVar    {}) =             ppPlainName v++-- | Return the variable name or value of the 'LlvmVar'+-- in a plain textual representation (e.g. @x@, @y@ or @42@).+ppPlainName :: LlvmVar -> SDoc+ppPlainName (LMGlobalVar x _ _ _ _ _) = ftext x+ppPlainName (LMLocalVar  x LMLabel  ) = text (show x)+ppPlainName (LMLocalVar  x _        ) = text ('l' : show x)+ppPlainName (LMNLocalVar x _        ) = ftext x+ppPlainName (LMLitVar    x          ) = ppLit x++-- | Print a literal value. No type.+ppLit :: LlvmLit -> SDoc+ppLit (LMIntLit i (LMInt 32))  = ppr (fromInteger i :: Int32)+ppLit (LMIntLit i (LMInt 64))  = ppr (fromInteger i :: Int64)+ppLit (LMIntLit   i _       )  = ppr ((fromInteger i)::Int)+ppLit (LMFloatLit r LMFloat )  = ppFloat $ narrowFp r+ppLit (LMFloatLit r LMDouble)  = ppDouble r+ppLit f@(LMFloatLit _ _)       = sdocWithDynFlags (\dflags ->+                                   error $ "Can't print this float literal!" ++ showSDoc dflags (ppr f))+ppLit (LMVectorLit ls  )       = char '<' <+> ppCommaJoin ls <+> char '>'+ppLit (LMNullLit _     )       = text "null"+-- Trac 11487 was an issue where we passed undef for some arguments+-- that were actually live. By chance the registers holding those+-- arguments usually happened to have the right values anyways, but+-- that was not guaranteed. To find such bugs reliably, we set the+-- flag below when validating, which replaces undef literals (at+-- common types) with values that are likely to cause a crash or test+-- failure.+ppLit (LMUndefLit t    )       = sdocWithDynFlags f+  where f dflags+          | gopt Opt_LlvmFillUndefWithGarbage dflags,+            Just lit <- garbageLit t   = ppLit lit+          | otherwise                  = text "undef"++garbageLit :: LlvmType -> Maybe LlvmLit+garbageLit t@(LMInt w)     = Just (LMIntLit (0xbbbbbbbbbbbbbbb0 `mod` (2^w)) t)+  -- Use a value that looks like an untagged pointer, so we are more+  -- likely to try to enter it+garbageLit t+  | isFloat t              = Just (LMFloatLit 12345678.9 t)+garbageLit t@(LMPointer _) = Just (LMNullLit t)+  -- Using null isn't totally ideal, since some functions may check for null.+  -- But producing another value is inconvenient since it needs a cast,+  -- and the knowledge for how to format casts is in PpLlvm.+garbageLit _               = Nothing+  -- More cases could be added, but this should do for now.++-- | Return the 'LlvmType' of the 'LlvmVar'+getVarType :: LlvmVar -> LlvmType+getVarType (LMGlobalVar _ y _ _ _ _) = y+getVarType (LMLocalVar  _ y        ) = y+getVarType (LMNLocalVar _ y        ) = y+getVarType (LMLitVar    l          ) = getLitType l++-- | Return the 'LlvmType' of a 'LlvmLit'+getLitType :: LlvmLit -> LlvmType+getLitType (LMIntLit   _ t) = t+getLitType (LMFloatLit _ t) = t+getLitType (LMVectorLit [])  = panic "getLitType"+getLitType (LMVectorLit ls)  = LMVector (length ls) (getLitType (head ls))+getLitType (LMNullLit    t) = t+getLitType (LMUndefLit   t) = t++-- | Return the 'LlvmType' of the 'LlvmStatic'+getStatType :: LlvmStatic -> LlvmType+getStatType (LMStaticLit   l  ) = getLitType l+getStatType (LMUninitType    t) = t+getStatType (LMStaticStr   _ t) = t+getStatType (LMStaticArray _ t) = t+getStatType (LMStaticStruc _ t) = t+getStatType (LMStaticPointer v) = getVarType v+getStatType (LMBitc        _ t) = t+getStatType (LMPtoI        _ t) = t+getStatType (LMAdd         t _) = getStatType t+getStatType (LMSub         t _) = getStatType t+getStatType (LMComment       _) = error "Can't call getStatType on LMComment!"++-- | Return the 'LlvmLinkageType' for a 'LlvmVar'+getLink :: LlvmVar -> LlvmLinkageType+getLink (LMGlobalVar _ _ l _ _ _) = l+getLink _                         = Internal++-- | Add a pointer indirection to the supplied type. 'LMLabel' and 'LMVoid'+-- cannot be lifted.+pLift :: LlvmType -> LlvmType+pLift LMLabel    = error "Labels are unliftable"+pLift LMVoid     = error "Voids are unliftable"+pLift LMMetadata = error "Metadatas are unliftable"+pLift x          = LMPointer x++-- | Lift a variable to 'LMPointer' type.+pVarLift :: LlvmVar -> LlvmVar+pVarLift (LMGlobalVar s t l x a c) = LMGlobalVar s (pLift t) l x a c+pVarLift (LMLocalVar  s t        ) = LMLocalVar  s (pLift t)+pVarLift (LMNLocalVar s t        ) = LMNLocalVar s (pLift t)+pVarLift (LMLitVar    _          ) = error $ "Can't lower a literal type!"++-- | Remove the pointer indirection of the supplied type. Only 'LMPointer'+-- constructors can be lowered.+pLower :: LlvmType -> LlvmType+pLower (LMPointer x) = x+pLower x  = pprPanic "llvmGen(pLower)"+            $ ppr x <+> text " is a unlowerable type, need a pointer"++-- | Lower a variable of 'LMPointer' type.+pVarLower :: LlvmVar -> LlvmVar+pVarLower (LMGlobalVar s t l x a c) = LMGlobalVar s (pLower t) l x a c+pVarLower (LMLocalVar  s t        ) = LMLocalVar  s (pLower t)+pVarLower (LMNLocalVar s t        ) = LMNLocalVar s (pLower t)+pVarLower (LMLitVar    _          ) = error $ "Can't lower a literal type!"++-- | Test if the given 'LlvmType' is an integer+isInt :: LlvmType -> Bool+isInt (LMInt _) = True+isInt _         = False++-- | Test if the given 'LlvmType' is a floating point type+isFloat :: LlvmType -> Bool+isFloat LMFloat    = True+isFloat LMDouble   = True+isFloat LMFloat80  = True+isFloat LMFloat128 = True+isFloat _          = False++-- | Test if the given 'LlvmType' is an 'LMPointer' construct+isPointer :: LlvmType -> Bool+isPointer (LMPointer _) = True+isPointer _             = False++-- | Test if the given 'LlvmType' is an 'LMVector' construct+isVector :: LlvmType -> Bool+isVector (LMVector {}) = True+isVector _             = False++-- | Test if a 'LlvmVar' is global.+isGlobal :: LlvmVar -> Bool+isGlobal (LMGlobalVar _ _ _ _ _ _) = True+isGlobal _                         = False++-- | Width in bits of an 'LlvmType', returns 0 if not applicable+llvmWidthInBits :: DynFlags -> LlvmType -> Int+llvmWidthInBits _      (LMInt n)       = n+llvmWidthInBits _      (LMFloat)       = 32+llvmWidthInBits _      (LMDouble)      = 64+llvmWidthInBits _      (LMFloat80)     = 80+llvmWidthInBits _      (LMFloat128)    = 128+-- Could return either a pointer width here or the width of what+-- it points to. We will go with the former for now.+-- PMW: At least judging by the way LLVM outputs constants, pointers+--      should use the former, but arrays the latter.+llvmWidthInBits dflags (LMPointer _)   = llvmWidthInBits dflags (llvmWord dflags)+llvmWidthInBits dflags (LMArray n t)   = n * llvmWidthInBits dflags t+llvmWidthInBits dflags (LMVector n ty) = n * llvmWidthInBits dflags ty+llvmWidthInBits _      LMLabel         = 0+llvmWidthInBits _      LMVoid          = 0+llvmWidthInBits dflags (LMStruct tys)  = sum $ map (llvmWidthInBits dflags) tys+llvmWidthInBits _      (LMStructU _)   =+    -- It's not trivial to calculate the bit width of the unpacked structs,+    -- since they will be aligned depending on the specified datalayout (+    -- http://llvm.org/docs/LangRef.html#data-layout ). One way we could support+    -- this could be to make the LlvmCodeGen.Ppr.moduleLayout be a data type+    -- that exposes the alignment information. However, currently the only place+    -- we use unpacked structs is LLVM intrinsics that return them (e.g.,+    -- llvm.sadd.with.overflow.*), so we don't actually need to compute their+    -- bit width.+    panic "llvmWidthInBits: not implemented for LMStructU"+llvmWidthInBits _      (LMFunction  _) = 0+llvmWidthInBits dflags (LMAlias (_,t)) = llvmWidthInBits dflags t+llvmWidthInBits _      LMMetadata      = panic "llvmWidthInBits: Meta-data has no runtime representation!"+++-- -----------------------------------------------------------------------------+-- ** Shortcut for Common Types+--++i128, i64, i32, i16, i8, i1, i8Ptr :: LlvmType+i128  = LMInt 128+i64   = LMInt  64+i32   = LMInt  32+i16   = LMInt  16+i8    = LMInt   8+i1    = LMInt   1+i8Ptr = pLift i8++-- | The target architectures word size+llvmWord, llvmWordPtr :: DynFlags -> LlvmType+llvmWord    dflags = LMInt (wORD_SIZE dflags * 8)+llvmWordPtr dflags = pLift (llvmWord dflags)++-- -----------------------------------------------------------------------------+-- * LLVM Function Types+--++-- | An LLVM Function+data LlvmFunctionDecl = LlvmFunctionDecl {+        -- | Unique identifier of the function+        decName       :: LMString,+        -- | LinkageType of the function+        funcLinkage   :: LlvmLinkageType,+        -- | The calling convention of the function+        funcCc        :: LlvmCallConvention,+        -- | Type of the returned value+        decReturnType :: LlvmType,+        -- | Indicates if this function uses varargs+        decVarargs    :: LlvmParameterListType,+        -- | Parameter types and attributes+        decParams     :: [LlvmParameter],+        -- | Function align value, must be power of 2+        funcAlign     :: LMAlign+  }+  deriving (Eq)++instance Outputable LlvmFunctionDecl where+  ppr (LlvmFunctionDecl n l c r varg p a)+    = let align = case a of+                       Just a' -> text " align " <> ppr a'+                       Nothing -> empty+      in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <>+             lparen <> ppParams varg p <> rparen <> align++type LlvmFunctionDecls = [LlvmFunctionDecl]++type LlvmParameter = (LlvmType, [LlvmParamAttr])++-- | LLVM Parameter Attributes.+--+-- Parameter attributes are used to communicate additional information about+-- the result or parameters of a function+data LlvmParamAttr+  -- | This indicates to the code generator that the parameter or return value+  -- should be zero-extended to a 32-bit value by the caller (for a parameter)+  -- or the callee (for a return value).+  = ZeroExt+  -- | This indicates to the code generator that the parameter or return value+  -- should be sign-extended to a 32-bit value by the caller (for a parameter)+  -- or the callee (for a return value).+  | SignExt+  -- | This indicates that this parameter or return value should be treated in+  -- a special target-dependent fashion during while emitting code for a+  -- function call or return (usually, by putting it in a register as opposed+  -- to memory).+  | InReg+  -- | This indicates that the pointer parameter should really be passed by+  -- value to the function.+  | ByVal+  -- | This indicates that the pointer parameter specifies the address of a+  -- structure that is the return value of the function in the source program.+  | SRet+  -- | This indicates that the pointer does not alias any global or any other+  -- parameter.+  | NoAlias+  -- | This indicates that the callee does not make any copies of the pointer+  -- that outlive the callee itself+  | NoCapture+  -- | This indicates that the pointer parameter can be excised using the+  -- trampoline intrinsics.+  | Nest+  deriving (Eq)++instance Outputable LlvmParamAttr where+  ppr ZeroExt   = text "zeroext"+  ppr SignExt   = text "signext"+  ppr InReg     = text "inreg"+  ppr ByVal     = text "byval"+  ppr SRet      = text "sret"+  ppr NoAlias   = text "noalias"+  ppr NoCapture = text "nocapture"+  ppr Nest      = text "nest"++-- | Llvm Function Attributes.+--+-- Function attributes are set to communicate additional information about a+-- function. Function attributes are considered to be part of the function,+-- not of the function type, so functions with different parameter attributes+-- can have the same function type. Functions can have multiple attributes.+--+-- Descriptions taken from <http://llvm.org/docs/LangRef.html#fnattrs>+data LlvmFuncAttr+  -- | This attribute indicates that the inliner should attempt to inline this+  -- function into callers whenever possible, ignoring any active inlining+  -- size threshold for this caller.+  = AlwaysInline+  -- | This attribute indicates that the source code contained a hint that+  -- inlining this function is desirable (such as the \"inline\" keyword in+  -- C/C++). It is just a hint; it imposes no requirements on the inliner.+  | InlineHint+  -- | This attribute indicates that the inliner should never inline this+  -- function in any situation. This attribute may not be used together+  -- with the alwaysinline attribute.+  | NoInline+  -- | This attribute suggests that optimization passes and code generator+  -- passes make choices that keep the code size of this function low, and+  -- otherwise do optimizations specifically to reduce code size.+  | OptSize+  -- | This function attribute indicates that the function never returns+  -- normally. This produces undefined behavior at runtime if the function+  -- ever does dynamically return.+  | NoReturn+  -- | This function attribute indicates that the function never returns with+  -- an unwind or exceptional control flow. If the function does unwind, its+  -- runtime behavior is undefined.+  | NoUnwind+  -- | This attribute indicates that the function computes its result (or+  -- decides to unwind an exception) based strictly on its arguments, without+  -- dereferencing any pointer arguments or otherwise accessing any mutable+  -- state (e.g. memory, control registers, etc) visible to caller functions.+  -- It does not write through any pointer arguments (including byval+  -- arguments) and never changes any state visible to callers. This means+  -- that it cannot unwind exceptions by calling the C++ exception throwing+  -- methods, but could use the unwind instruction.+  | ReadNone+  -- | This attribute indicates that the function does not write through any+  -- pointer arguments (including byval arguments) or otherwise modify any+  -- state (e.g. memory, control registers, etc) visible to caller functions.+  -- It may dereference pointer arguments and read state that may be set in+  -- the caller. A readonly function always returns the same value (or unwinds+  -- an exception identically) when called with the same set of arguments and+  -- global state. It cannot unwind an exception by calling the C++ exception+  -- throwing methods, but may use the unwind instruction.+  | ReadOnly+  -- | This attribute indicates that the function should emit a stack smashing+  -- protector. It is in the form of a \"canary\"—a random value placed on the+  -- stack before the local variables that's checked upon return from the+  -- function to see if it has been overwritten. A heuristic is used to+  -- determine if a function needs stack protectors or not.+  --+  -- If a function that has an ssp attribute is inlined into a function that+  -- doesn't have an ssp attribute, then the resulting function will have an+  -- ssp attribute.+  | Ssp+  -- | This attribute indicates that the function should always emit a stack+  -- smashing protector. This overrides the ssp function attribute.+  --+  -- If a function that has an sspreq attribute is inlined into a function+  -- that doesn't have an sspreq attribute or which has an ssp attribute,+  -- then the resulting function will have an sspreq attribute.+  | SspReq+  -- | This attribute indicates that the code generator should not use a red+  -- zone, even if the target-specific ABI normally permits it.+  | NoRedZone+  -- | This attributes disables implicit floating point instructions.+  | NoImplicitFloat+  -- | This attribute disables prologue / epilogue emission for the function.+  -- This can have very system-specific consequences.+  | Naked+  deriving (Eq)++instance Outputable LlvmFuncAttr where+  ppr AlwaysInline       = text "alwaysinline"+  ppr InlineHint         = text "inlinehint"+  ppr NoInline           = text "noinline"+  ppr OptSize            = text "optsize"+  ppr NoReturn           = text "noreturn"+  ppr NoUnwind           = text "nounwind"+  ppr ReadNone           = text "readnon"+  ppr ReadOnly           = text "readonly"+  ppr Ssp                = text "ssp"+  ppr SspReq             = text "ssqreq"+  ppr NoRedZone          = text "noredzone"+  ppr NoImplicitFloat    = text "noimplicitfloat"+  ppr Naked              = text "naked"+++-- | Different types to call a function.+data LlvmCallType+  -- | Normal call, allocate a new stack frame.+  = StdCall+  -- | Tail call, perform the call in the current stack frame.+  | TailCall+  deriving (Eq,Show)++-- | Different calling conventions a function can use.+data LlvmCallConvention+  -- | The C calling convention.+  -- This calling convention (the default if no other calling convention is+  -- specified) matches the target C calling conventions. This calling+  -- convention supports varargs function calls and tolerates some mismatch in+  -- the declared prototype and implemented declaration of the function (as+  -- does normal C).+  = CC_Ccc+  -- | This calling convention attempts to make calls as fast as possible+  -- (e.g. by passing things in registers). This calling convention allows+  -- the target to use whatever tricks it wants to produce fast code for the+  -- target, without having to conform to an externally specified ABI+  -- (Application Binary Interface). Implementations of this convention should+  -- allow arbitrary tail call optimization to be supported. This calling+  -- convention does not support varargs and requires the prototype of al+  -- callees to exactly match the prototype of the function definition.+  | CC_Fastcc+  -- | This calling convention attempts to make code in the caller as efficient+  -- as possible under the assumption that the call is not commonly executed.+  -- As such, these calls often preserve all registers so that the call does+  -- not break any live ranges in the caller side. This calling convention+  -- does not support varargs and requires the prototype of all callees to+  -- exactly match the prototype of the function definition.+  | CC_Coldcc+  -- | The GHC-specific 'registerised' calling convention.+  | CC_Ghc+  -- | Any calling convention may be specified by number, allowing+  -- target-specific calling conventions to be used. Target specific calling+  -- conventions start at 64.+  | CC_Ncc Int+  -- | X86 Specific 'StdCall' convention. LLVM includes a specific alias for it+  -- rather than just using CC_Ncc.+  | CC_X86_Stdcc+  deriving (Eq)++instance Outputable LlvmCallConvention where+  ppr CC_Ccc       = text "ccc"+  ppr CC_Fastcc    = text "fastcc"+  ppr CC_Coldcc    = text "coldcc"+  ppr CC_Ghc       = text "ghccc"+  ppr (CC_Ncc i)   = text "cc " <> ppr i+  ppr CC_X86_Stdcc = text "x86_stdcallcc"+++-- | Functions can have a fixed amount of parameters, or a variable amount.+data LlvmParameterListType+  -- Fixed amount of arguments.+  = FixedArgs+  -- Variable amount of arguments.+  | VarArgs+  deriving (Eq,Show)+++-- | Linkage type of a symbol.+--+-- The description of the constructors is copied from the Llvm Assembly Language+-- Reference Manual <http://www.llvm.org/docs/LangRef.html#linkage>, because+-- they correspond to the Llvm linkage types.+data LlvmLinkageType+  -- | Global values with internal linkage are only directly accessible by+  -- objects in the current module. In particular, linking code into a module+  -- with an internal global value may cause the internal to be renamed as+  -- necessary to avoid collisions. Because the symbol is internal to the+  -- module, all references can be updated. This corresponds to the notion+  -- of the @static@ keyword in C.+  = Internal+  -- | Globals with @linkonce@ linkage are merged with other globals of the+  -- same name when linkage occurs. This is typically used to implement+  -- inline functions, templates, or other code which must be generated+  -- in each translation unit that uses it. Unreferenced linkonce globals are+  -- allowed to be discarded.+  | LinkOnce+  -- | @weak@ linkage is exactly the same as linkonce linkage, except that+  -- unreferenced weak globals may not be discarded. This is used for globals+  -- that may be emitted in multiple translation units, but that are not+  -- guaranteed to be emitted into every translation unit that uses them. One+  -- example of this are common globals in C, such as @int X;@ at global+  -- scope.+  | Weak+  -- | @appending@ linkage may only be applied to global variables of pointer+  -- to array type. When two global variables with appending linkage are+  -- linked together, the two global arrays are appended together. This is+  -- the Llvm, typesafe, equivalent of having the system linker append+  -- together @sections@ with identical names when .o files are linked.+  | Appending+  -- | The semantics of this linkage follow the ELF model: the symbol is weak+  -- until linked, if not linked, the symbol becomes null instead of being an+  -- undefined reference.+  | ExternWeak+  -- | The symbol participates in linkage and can be used to resolve external+  --  symbol references.+  | ExternallyVisible+  -- | Alias for 'ExternallyVisible' but with explicit textual form in LLVM+  --  assembly.+  | External+  -- | Symbol is private to the module and should not appear in the symbol table+  | Private+  deriving (Eq)++instance Outputable LlvmLinkageType where+  ppr Internal          = text "internal"+  ppr LinkOnce          = text "linkonce"+  ppr Weak              = text "weak"+  ppr Appending         = text "appending"+  ppr ExternWeak        = text "extern_weak"+  -- ExternallyVisible does not have a textual representation, it is+  -- the linkage type a function resolves to if no other is specified+  -- in Llvm.+  ppr ExternallyVisible = empty+  ppr External          = text "external"+  ppr Private           = text "private"++-- -----------------------------------------------------------------------------+-- * LLVM Operations+--++-- | Llvm binary operators machine operations.+data LlvmMachOp+  = LM_MO_Add  -- ^ add two integer, floating point or vector values.+  | LM_MO_Sub  -- ^ subtract two ...+  | LM_MO_Mul  -- ^ multiply ..+  | LM_MO_UDiv -- ^ unsigned integer or vector division.+  | LM_MO_SDiv -- ^ signed integer ..+  | LM_MO_URem -- ^ unsigned integer or vector remainder (mod)+  | LM_MO_SRem -- ^ signed ...++  | LM_MO_FAdd -- ^ add two floating point or vector values.+  | LM_MO_FSub -- ^ subtract two ...+  | LM_MO_FMul -- ^ multiply ...+  | LM_MO_FDiv -- ^ divide ...+  | LM_MO_FRem -- ^ remainder ...++  -- | Left shift+  | LM_MO_Shl+  -- | Logical shift right+  -- Shift right, filling with zero+  | LM_MO_LShr+  -- | Arithmetic shift right+  -- The most significant bits of the result will be equal to the sign bit of+  -- the left operand.+  | LM_MO_AShr++  | LM_MO_And -- ^ AND bitwise logical operation.+  | LM_MO_Or  -- ^ OR bitwise logical operation.+  | LM_MO_Xor -- ^ XOR bitwise logical operation.+  deriving (Eq)++instance Outputable LlvmMachOp where+  ppr LM_MO_Add  = text "add"+  ppr LM_MO_Sub  = text "sub"+  ppr LM_MO_Mul  = text "mul"+  ppr LM_MO_UDiv = text "udiv"+  ppr LM_MO_SDiv = text "sdiv"+  ppr LM_MO_URem = text "urem"+  ppr LM_MO_SRem = text "srem"+  ppr LM_MO_FAdd = text "fadd"+  ppr LM_MO_FSub = text "fsub"+  ppr LM_MO_FMul = text "fmul"+  ppr LM_MO_FDiv = text "fdiv"+  ppr LM_MO_FRem = text "frem"+  ppr LM_MO_Shl  = text "shl"+  ppr LM_MO_LShr = text "lshr"+  ppr LM_MO_AShr = text "ashr"+  ppr LM_MO_And  = text "and"+  ppr LM_MO_Or   = text "or"+  ppr LM_MO_Xor  = text "xor"+++-- | Llvm compare operations.+data LlvmCmpOp+  = LM_CMP_Eq  -- ^ Equal (Signed and Unsigned)+  | LM_CMP_Ne  -- ^ Not equal (Signed and Unsigned)+  | LM_CMP_Ugt -- ^ Unsigned greater than+  | LM_CMP_Uge -- ^ Unsigned greater than or equal+  | LM_CMP_Ult -- ^ Unsigned less than+  | LM_CMP_Ule -- ^ Unsigned less than or equal+  | LM_CMP_Sgt -- ^ Signed greater than+  | LM_CMP_Sge -- ^ Signed greater than or equal+  | LM_CMP_Slt -- ^ Signed less than+  | LM_CMP_Sle -- ^ Signed less than or equal++  -- Float comparisons. GHC uses a mix of ordered and unordered float+  -- comparisons.+  | LM_CMP_Feq -- ^ Float equal+  | LM_CMP_Fne -- ^ Float not equal+  | LM_CMP_Fgt -- ^ Float greater than+  | LM_CMP_Fge -- ^ Float greater than or equal+  | LM_CMP_Flt -- ^ Float less than+  | LM_CMP_Fle -- ^ Float less than or equal+  deriving (Eq)++instance Outputable LlvmCmpOp where+  ppr LM_CMP_Eq  = text "eq"+  ppr LM_CMP_Ne  = text "ne"+  ppr LM_CMP_Ugt = text "ugt"+  ppr LM_CMP_Uge = text "uge"+  ppr LM_CMP_Ult = text "ult"+  ppr LM_CMP_Ule = text "ule"+  ppr LM_CMP_Sgt = text "sgt"+  ppr LM_CMP_Sge = text "sge"+  ppr LM_CMP_Slt = text "slt"+  ppr LM_CMP_Sle = text "sle"+  ppr LM_CMP_Feq = text "oeq"+  ppr LM_CMP_Fne = text "une"+  ppr LM_CMP_Fgt = text "ogt"+  ppr LM_CMP_Fge = text "oge"+  ppr LM_CMP_Flt = text "olt"+  ppr LM_CMP_Fle = text "ole"+++-- | Llvm cast operations.+data LlvmCastOp+  = LM_Trunc    -- ^ Integer truncate+  | LM_Zext     -- ^ Integer extend (zero fill)+  | LM_Sext     -- ^ Integer extend (sign fill)+  | LM_Fptrunc  -- ^ Float truncate+  | LM_Fpext    -- ^ Float extend+  | LM_Fptoui   -- ^ Float to unsigned Integer+  | LM_Fptosi   -- ^ Float to signed Integer+  | LM_Uitofp   -- ^ Unsigned Integer to Float+  | LM_Sitofp   -- ^ Signed Int to Float+  | LM_Ptrtoint -- ^ Pointer to Integer+  | LM_Inttoptr -- ^ Integer to Pointer+  | LM_Bitcast  -- ^ Cast between types where no bit manipulation is needed+  deriving (Eq)++instance Outputable LlvmCastOp where+  ppr LM_Trunc    = text "trunc"+  ppr LM_Zext     = text "zext"+  ppr LM_Sext     = text "sext"+  ppr LM_Fptrunc  = text "fptrunc"+  ppr LM_Fpext    = text "fpext"+  ppr LM_Fptoui   = text "fptoui"+  ppr LM_Fptosi   = text "fptosi"+  ppr LM_Uitofp   = text "uitofp"+  ppr LM_Sitofp   = text "sitofp"+  ppr LM_Ptrtoint = text "ptrtoint"+  ppr LM_Inttoptr = text "inttoptr"+  ppr LM_Bitcast  = text "bitcast"+++-- -----------------------------------------------------------------------------+-- * Floating point conversion+--++-- | Convert a Haskell Double to an LLVM hex encoded floating point form. In+-- Llvm float literals can be printed in a big-endian hexadecimal format,+-- regardless of underlying architecture.+--+-- See Note [LLVM Float Types].+ppDouble :: Double -> SDoc+ppDouble d+  = let bs     = doubleToBytes d+        hex d' = case showHex d' "" of+                     []    -> error "dToStr: too few hex digits for float"+                     [x]   -> ['0',x]+                     [x,y] -> [x,y]+                     _     -> error "dToStr: too many hex digits for float"++        str  = map toUpper $ concat $ fixEndian $ map hex bs+    in  text "0x" <> text str++-- Note [LLVM Float Types]+-- ~~~~~~~~~~~~~~~~~~~~~~~+-- We use 'ppDouble' for both printing Float and Double floating point types. This is+-- as LLVM expects all floating point constants (single & double) to be in IEEE+-- 754 Double precision format. However, for single precision numbers (Float)+-- they should be *representable* in IEEE 754 Single precision format. So the+-- easiest way to do this is to narrow and widen again.+-- (i.e., Double -> Float -> Double). We must be careful doing this that GHC+-- doesn't optimize that away.++-- Note [narrowFp & widenFp]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~+-- NOTE: we use float2Double & co directly as GHC likes to optimize away+-- successive calls of 'realToFrac', defeating the narrowing. (Bug #7600).+-- 'realToFrac' has inconsistent behaviour with optimisation as well that can+-- also cause issues, these methods don't.++narrowFp :: Double -> Float+{-# NOINLINE narrowFp #-}+narrowFp = double2Float++widenFp :: Float -> Double+{-# NOINLINE widenFp #-}+widenFp = float2Double++ppFloat :: Float -> SDoc+ppFloat = ppDouble . widenFp++-- | Reverse or leave byte data alone to fix endianness on this target.+fixEndian :: [a] -> [a]+#ifdef WORDS_BIGENDIAN+fixEndian = id+#else+fixEndian = reverse+#endif+++--------------------------------------------------------------------------------+-- * Misc functions+--------------------------------------------------------------------------------++ppCommaJoin :: (Outputable a) => [a] -> SDoc+ppCommaJoin strs = hsep $ punctuate comma (map ppr strs)++ppSpaceJoin :: (Outputable a) => [a] -> SDoc+ppSpaceJoin strs = hsep (map ppr strs)
+ llvmGen/LlvmCodeGen.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE CPP, TypeFamilies #-}++-- -----------------------------------------------------------------------------+-- | This is the top-level module in the LLVM code generator.+--+module LlvmCodeGen ( llvmCodeGen, llvmFixupAsm ) where++#include "HsVersions.h"++import Llvm+import LlvmCodeGen.Base+import LlvmCodeGen.CodeGen+import LlvmCodeGen.Data+import LlvmCodeGen.Ppr+import LlvmCodeGen.Regs+import LlvmMangler++import BlockId+import CgUtils ( fixStgRegisters )+import Cmm+import CmmUtils+import Hoopl+import PprCmm++import BufWrite+import DynFlags+import ErrUtils+import FastString+import Outputable+import UniqSupply+import SysTools ( figureLlvmVersion )+import qualified Stream++import Control.Monad ( when )+import Data.Maybe ( fromMaybe, catMaybes )+import System.IO++-- -----------------------------------------------------------------------------+-- | Top-level of the LLVM Code generator+--+llvmCodeGen :: DynFlags -> Handle -> UniqSupply+               -> Stream.Stream IO RawCmmGroup ()+               -> IO ()+llvmCodeGen dflags h us cmm_stream+  = withTiming (pure dflags) (text "LLVM CodeGen") (const ()) $ do+       bufh <- newBufHandle h++       -- Pass header+       showPass dflags "LLVM CodeGen"++       -- get llvm version, cache for later use+       ver <- (fromMaybe supportedLlvmVersion) `fmap` figureLlvmVersion dflags++       -- warn if unsupported+       debugTraceMsg dflags 2+            (text "Using LLVM version:" <+> text (show ver))+       let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags+       when (ver /= supportedLlvmVersion && doWarn) $+           putMsg dflags (text "You are using an unsupported version of LLVM!"+                            $+$ text ("Currently only " +++                                      llvmVersionStr supportedLlvmVersion +++                                      " is supported.")+                            $+$ text "We will try though...")++       -- run code generation+       runLlvm dflags ver bufh us $+         llvmCodeGen' (liftStream cmm_stream)++       bFlush bufh++llvmCodeGen' :: Stream.Stream LlvmM RawCmmGroup () -> LlvmM ()+llvmCodeGen' cmm_stream+  = do  -- Preamble+        renderLlvm pprLlvmHeader+        ghcInternalFunctions+        cmmMetaLlvmPrelude++        -- Procedures+        let llvmStream = Stream.mapM llvmGroupLlvmGens cmm_stream+        _ <- Stream.collect llvmStream++        -- Declare aliases for forward references+        renderLlvm . pprLlvmData =<< generateExternDecls++        -- Postamble+        cmmUsedLlvmGens++llvmGroupLlvmGens :: RawCmmGroup -> LlvmM ()+llvmGroupLlvmGens cmm = do++        -- Insert functions into map, collect data+        let split (CmmData s d' )     = return $ Just (s, d')+            split (CmmProc h l live g) = do+              -- Set function type+              let l' = case mapLookup (g_entry g) h of+                         Nothing                   -> l+                         Just (Statics info_lbl _) -> info_lbl+              lml <- strCLabel_llvm l'+              funInsert lml =<< llvmFunTy live+              return Nothing+        cdata <- fmap catMaybes $ mapM split cmm++        {-# SCC "llvm_datas_gen" #-}+          cmmDataLlvmGens cdata+        {-# SCC "llvm_procs_gen" #-}+          mapM_ cmmLlvmGen cmm++-- -----------------------------------------------------------------------------+-- | Do LLVM code generation on all these Cmms data sections.+--+cmmDataLlvmGens :: [(Section,CmmStatics)] -> LlvmM ()++cmmDataLlvmGens statics+  = do lmdatas <- mapM genLlvmData statics++       let (gss, tss) = unzip lmdatas++       let regGlobal (LMGlobal (LMGlobalVar l ty _ _ _ _) _)+                        = funInsert l ty+           regGlobal _  = return ()+       mapM_ regGlobal (concat gss)+       gss' <- mapM aliasify $ concat gss++       renderLlvm $ pprLlvmData (concat gss', concat tss)++-- | LLVM can't handle entry blocks which loop back to themselves (could be+-- seen as an LLVM bug) so we rearrange the code to keep the original entry+-- label which branches to a newly generated second label that branches back+-- to itself. See: Trac #11649+fixBottom :: RawCmmDecl -> LlvmM RawCmmDecl+fixBottom cp@(CmmProc hdr entry_lbl live g) =+    maybe (pure cp) fix_block $ mapLookup (g_entry g) blk_map+  where+    blk_map = toBlockMap g++    fix_block :: CmmBlock -> LlvmM RawCmmDecl+    fix_block blk+        | (CmmEntry e_lbl tickscp, middle, CmmBranch b_lbl) <- blockSplit blk+        , isEmptyBlock middle+        , e_lbl == b_lbl = do+            new_lbl <- mkBlockId <$> getUniqueM++            let fst_blk =+                    BlockCC (CmmEntry e_lbl tickscp) BNil (CmmBranch new_lbl)+                snd_blk =+                    BlockCC (CmmEntry new_lbl tickscp) BNil (CmmBranch new_lbl)++            pure . CmmProc hdr entry_lbl live . ofBlockMap (g_entry g)+                $ mapFromList [(e_lbl, fst_blk), (new_lbl, snd_blk)]++    fix_block _ = pure cp++fixBottom rcd = pure rcd++-- | Complete LLVM code generation phase for a single top-level chunk of Cmm.+cmmLlvmGen ::RawCmmDecl -> LlvmM ()+cmmLlvmGen cmm@CmmProc{} = do++    -- rewrite assignments to global regs+    dflags <- getDynFlag id+    fixed_cmm <- fixBottom $+                    {-# SCC "llvm_fix_regs" #-}+                    fixStgRegisters dflags cmm++    dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmmGroup [fixed_cmm])++    -- generate llvm code from cmm+    llvmBC <- withClearVars $ genLlvmProc fixed_cmm++    -- pretty print+    (docs, ivars) <- fmap unzip $ mapM pprLlvmCmmDecl llvmBC++    -- Output, note down used variables+    renderLlvm (vcat docs)+    mapM_ markUsedVar $ concat ivars++cmmLlvmGen _ = return ()++-- -----------------------------------------------------------------------------+-- | Generate meta data nodes+--++cmmMetaLlvmPrelude :: LlvmM ()+cmmMetaLlvmPrelude = do+  metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do+    -- Generate / lookup meta data IDs+    tbaaId <- getMetaUniqueId+    setUniqMeta uniq tbaaId+    parentId <- maybe (return Nothing) getUniqMeta parent+    -- Build definition+    return $ MetaUnnamed tbaaId $ MetaStruct $+          case parentId of+              Just p  -> [ MetaStr name, MetaNode p ]+              -- As of LLVM 4.0, a node without parents should be rendered as+              -- just a name on its own. Previously `null` was accepted as the+              -- name.+              Nothing -> [ MetaStr name ]+  renderLlvm $ ppLlvmMetas metas++-- -----------------------------------------------------------------------------+-- | Marks variables as used where necessary+--++cmmUsedLlvmGens :: LlvmM ()+cmmUsedLlvmGens = do++  -- LLVM would discard variables that are internal and not obviously+  -- used if we didn't provide these hints. This will generate a+  -- definition of the form+  --+  --   @llvm.used = appending global [42 x i8*] [i8* bitcast <var> to i8*, ...]+  --+  -- Which is the LLVM way of protecting them against getting removed.+  ivars <- getUsedVars+  let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr+      ty     = (LMArray (length ivars) i8Ptr)+      usedArray = LMStaticArray (map cast ivars) ty+      sectName  = Just $ fsLit "llvm.metadata"+      lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing Constant+      lmUsed    = LMGlobal lmUsedVar (Just usedArray)+  if null ivars+     then return ()+     else renderLlvm $ pprLlvmData ([lmUsed], [])
+ llvmGen/LlvmCodeGen/Base.hs view
@@ -0,0 +1,550 @@+{-# LANGUAGE CPP #-}++-- ----------------------------------------------------------------------------+-- | Base LLVM Code Generation module+--+-- Contains functions useful through out the code generator.+--++module LlvmCodeGen.Base (++        LlvmCmmDecl, LlvmBasicBlock,+        LiveGlobalRegs,+        LlvmUnresData, LlvmData, UnresLabel, UnresStatic,++        LlvmVersion, supportedLlvmVersion, llvmVersionStr,++        LlvmM,+        runLlvm, liftStream, withClearVars, varLookup, varInsert,+        markStackReg, checkStackReg,+        funLookup, funInsert, getLlvmVer, getDynFlags, getDynFlag, getLlvmPlatform,+        dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars,+        ghcInternalFunctions,++        getMetaUniqueId,+        setUniqMeta, getUniqMeta,++        cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,+        llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,+        llvmPtrBits, tysToParams, llvmFunSection,++        strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm,+        getGlobalPtr, generateExternDecls,++        aliasify,+    ) where++#include "HsVersions.h"+#include "ghcautoconf.h"++import Llvm+import LlvmCodeGen.Regs++import CLabel+import CodeGen.Platform ( activeStgRegs )+import DynFlags+import FastString+import Cmm              hiding ( succ )+import Outputable as Outp+import Platform+import UniqFM+import Unique+import BufWrite   ( BufHandle )+import UniqSet+import UniqSupply+import ErrUtils+import qualified Stream++import Control.Monad (ap)++-- ----------------------------------------------------------------------------+-- * Some Data Types+--++type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe CmmStatics) (ListGraph LlvmStatement)+type LlvmBasicBlock = GenBasicBlock LlvmStatement++-- | Global registers live on proc entry+type LiveGlobalRegs = [GlobalReg]++-- | Unresolved code.+-- Of the form: (data label, data type, unresolved data)+type LlvmUnresData = (CLabel, Section, LlvmType, [UnresStatic])++-- | Top level LLVM Data (globals and type aliases)+type LlvmData = ([LMGlobal], [LlvmType])++-- | An unresolved Label.+--+-- Labels are unresolved when we haven't yet determined if they are defined in+-- the module we are currently compiling, or an external one.+type UnresLabel  = CmmLit+type UnresStatic = Either UnresLabel LlvmStatic++-- ----------------------------------------------------------------------------+-- * Type translations+--++-- | Translate a basic CmmType to an LlvmType.+cmmToLlvmType :: CmmType -> LlvmType+cmmToLlvmType ty | isVecType ty   = LMVector (vecLength ty) (cmmToLlvmType (vecElemType ty))+                 | isFloatType ty = widthToLlvmFloat $ typeWidth ty+                 | otherwise      = widthToLlvmInt   $ typeWidth ty++-- | Translate a Cmm Float Width to a LlvmType.+widthToLlvmFloat :: Width -> LlvmType+widthToLlvmFloat W32  = LMFloat+widthToLlvmFloat W64  = LMDouble+widthToLlvmFloat W80  = LMFloat80+widthToLlvmFloat W128 = LMFloat128+widthToLlvmFloat w    = panic $ "widthToLlvmFloat: Bad float size: " ++ show w++-- | Translate a Cmm Bit Width to a LlvmType.+widthToLlvmInt :: Width -> LlvmType+widthToLlvmInt w = LMInt $ widthInBits w++-- | GHC Call Convention for LLVM+llvmGhcCC :: DynFlags -> LlvmCallConvention+llvmGhcCC dflags+ | platformUnregisterised (targetPlatform dflags) = CC_Ccc+ | otherwise                                      = CC_Ghc++-- | Llvm Function type for Cmm function+llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType+llvmFunTy live = return . LMFunction =<< llvmFunSig' live (fsLit "a") ExternallyVisible++-- | Llvm Function signature+llvmFunSig :: LiveGlobalRegs ->  CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl+llvmFunSig live lbl link = do+  lbl' <- strCLabel_llvm lbl+  llvmFunSig' live lbl' link++llvmFunSig' :: LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl+llvmFunSig' live lbl link+  = do let toParams x | isPointer x = (x, [NoAlias, NoCapture])+                      | otherwise   = (x, [])+       dflags <- getDynFlags+       return $ LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs+                                 (map (toParams . getVarType) (llvmFunArgs dflags live))+                                 (llvmFunAlign dflags)++-- | Alignment to use for functions+llvmFunAlign :: DynFlags -> LMAlign+llvmFunAlign dflags = Just (wORD_SIZE dflags)++-- | Alignment to use for into tables+llvmInfAlign :: DynFlags -> LMAlign+llvmInfAlign dflags = Just (wORD_SIZE dflags)++-- | Section to use for a function+llvmFunSection :: DynFlags -> LMString -> LMSection+llvmFunSection dflags lbl+    | gopt Opt_SplitSections dflags = Just (concatFS [fsLit ".text.", lbl])+    | otherwise                     = Nothing++-- | A Function's arguments+llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar]+llvmFunArgs dflags live =+    map (lmGlobalRegArg dflags) (filter isPassed (activeStgRegs platform))+    where platform = targetPlatform dflags+          isLive r = not (isSSE r) || r `elem` alwaysLive || r `elem` live+          isPassed r = not (isSSE r) || isLive r+          isSSE (FloatReg _)  = True+          isSSE (DoubleReg _) = True+          isSSE (XmmReg _)    = True+          isSSE (YmmReg _)    = True+          isSSE (ZmmReg _)    = True+          isSSE _             = False++-- | Llvm standard fun attributes+llvmStdFunAttrs :: [LlvmFuncAttr]+llvmStdFunAttrs = [NoUnwind]++-- | Convert a list of types to a list of function parameters+-- (each with no parameter attributes)+tysToParams :: [LlvmType] -> [LlvmParameter]+tysToParams = map (\ty -> (ty, []))++-- | Pointer width+llvmPtrBits :: DynFlags -> Int+llvmPtrBits dflags = widthInBits $ typeWidth $ gcWord dflags++-- ----------------------------------------------------------------------------+-- * Llvm Version+--++-- | LLVM Version Number+type LlvmVersion = (Int, Int)++-- | The LLVM Version that is currently supported.+supportedLlvmVersion :: LlvmVersion+supportedLlvmVersion = sUPPORTED_LLVM_VERSION++llvmVersionStr :: LlvmVersion -> String+llvmVersionStr (major, minor) = show major ++ "." ++ show minor++-- ----------------------------------------------------------------------------+-- * Environment Handling+--++data LlvmEnv = LlvmEnv+  { envVersion :: LlvmVersion      -- ^ LLVM version+  , envDynFlags :: DynFlags        -- ^ Dynamic flags+  , envOutput :: BufHandle         -- ^ Output buffer+  , envUniq :: UniqSupply          -- ^ Supply of unique values+  , envFreshMeta :: MetaId         -- ^ Supply of fresh metadata IDs+  , envUniqMeta :: UniqFM MetaId   -- ^ Global metadata nodes+  , envFunMap :: LlvmEnvMap        -- ^ Global functions so far, with type+  , envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References]+  , envUsedVars :: [LlvmVar]       -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@)++    -- the following get cleared for every function (see @withClearVars@)+  , envVarMap :: LlvmEnvMap        -- ^ Local variables so far, with type+  , envStackRegs :: [GlobalReg]    -- ^ Non-constant registers (alloca'd in the function prelude)+  }++type LlvmEnvMap = UniqFM LlvmType++-- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad+newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) }++instance Functor LlvmM where+    fmap f m = LlvmM $ \env -> do (x, env') <- runLlvmM m env+                                  return (f x, env')++instance Applicative LlvmM where+    pure x = LlvmM $ \env -> return (x, env)+    (<*>) = ap++instance Monad LlvmM where+    m >>= f  = LlvmM $ \env -> do (x, env') <- runLlvmM m env+                                  runLlvmM (f x) env'++instance HasDynFlags LlvmM where+    getDynFlags = LlvmM $ \env -> return (envDynFlags env, env)++instance MonadUnique LlvmM where+    getUniqueSupplyM = do+        us <- getEnv envUniq+        let (us1, us2) = splitUniqSupply us+        modifyEnv (\s -> s { envUniq = us2 })+        return us1++    getUniqueM = do+        us <- getEnv envUniq+        let (u,us') = takeUniqFromSupply us+        modifyEnv (\s -> s { envUniq = us' })+        return u++-- | Lifting of IO actions. Not exported, as we want to encapsulate IO.+liftIO :: IO a -> LlvmM a+liftIO m = LlvmM $ \env -> do x <- m+                              return (x, env)++-- | Get initial Llvm environment.+runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> UniqSupply -> LlvmM () -> IO ()+runLlvm dflags ver out us m = do+    _ <- runLlvmM m env+    return ()+  where env = LlvmEnv { envFunMap = emptyUFM+                      , envVarMap = emptyUFM+                      , envStackRegs = []+                      , envUsedVars = []+                      , envAliases = emptyUniqSet+                      , envVersion = ver+                      , envDynFlags = dflags+                      , envOutput = out+                      , envUniq = us+                      , envFreshMeta = MetaId 0+                      , envUniqMeta = emptyUFM+                      }++-- | Get environment (internal)+getEnv :: (LlvmEnv -> a) -> LlvmM a+getEnv f = LlvmM (\env -> return (f env, env))++-- | Modify environment (internal)+modifyEnv :: (LlvmEnv -> LlvmEnv) -> LlvmM ()+modifyEnv f = LlvmM (\env -> return ((), f env))++-- | Lift a stream into the LlvmM monad+liftStream :: Stream.Stream IO a x -> Stream.Stream LlvmM a x+liftStream s = Stream.Stream $ do+  r <- liftIO $ Stream.runStream s+  case r of+    Left b        -> return (Left b)+    Right (a, r2) -> return (Right (a, liftStream r2))++-- | Clear variables from the environment for a subcomputation+withClearVars :: LlvmM a -> LlvmM a+withClearVars m = LlvmM $ \env -> do+    (x, env') <- runLlvmM m env { envVarMap = emptyUFM, envStackRegs = [] }+    return (x, env' { envVarMap = emptyUFM, envStackRegs = [] })++-- | Insert variables or functions into the environment.+varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmM ()+varInsert s t = modifyEnv $ \env -> env { envVarMap = addToUFM (envVarMap env) s t }+funInsert s t = modifyEnv $ \env -> env { envFunMap = addToUFM (envFunMap env) s t }++-- | Lookup variables or functions in the environment.+varLookup, funLookup :: Uniquable key => key -> LlvmM (Maybe LlvmType)+varLookup s = getEnv (flip lookupUFM s . envVarMap)+funLookup s = getEnv (flip lookupUFM s . envFunMap)++-- | Set a register as allocated on the stack+markStackReg :: GlobalReg -> LlvmM ()+markStackReg r = modifyEnv $ \env -> env { envStackRegs = r : envStackRegs env }++-- | Check whether a register is allocated on the stack+checkStackReg :: GlobalReg -> LlvmM Bool+checkStackReg r = getEnv ((elem r) . envStackRegs)++-- | Allocate a new global unnamed metadata identifier+getMetaUniqueId :: LlvmM MetaId+getMetaUniqueId = LlvmM $ \env ->+    return (envFreshMeta env, env { envFreshMeta = succ $ envFreshMeta env })++-- | Get the LLVM version we are generating code for+getLlvmVer :: LlvmM LlvmVersion+getLlvmVer = getEnv envVersion++-- | Get the platform we are generating code for+getDynFlag :: (DynFlags -> a) -> LlvmM a+getDynFlag f = getEnv (f . envDynFlags)++-- | Get the platform we are generating code for+getLlvmPlatform :: LlvmM Platform+getLlvmPlatform = getDynFlag targetPlatform++-- | Dumps the document if the corresponding flag has been set by the user+dumpIfSetLlvm :: DumpFlag -> String -> Outp.SDoc -> LlvmM ()+dumpIfSetLlvm flag hdr doc = do+  dflags <- getDynFlags+  liftIO $ dumpIfSet_dyn dflags flag hdr doc++-- | Prints the given contents to the output handle+renderLlvm :: Outp.SDoc -> LlvmM ()+renderLlvm sdoc = do++    -- Write to output+    dflags <- getDynFlags+    out <- getEnv envOutput+    liftIO $ Outp.bufLeftRenderSDoc dflags out+               (Outp.mkCodeStyle Outp.CStyle) sdoc++    -- Dump, if requested+    dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" sdoc+    return ()++-- | Marks a variable as "used"+markUsedVar :: LlvmVar -> LlvmM ()+markUsedVar v = modifyEnv $ \env -> env { envUsedVars = v : envUsedVars env }++-- | Return all variables marked as "used" so far+getUsedVars :: LlvmM [LlvmVar]+getUsedVars = getEnv envUsedVars++-- | Saves that at some point we didn't know the type of the label and+-- generated a reference to a type variable instead+saveAlias :: LMString -> LlvmM ()+saveAlias lbl = modifyEnv $ \env -> env { envAliases = addOneToUniqSet (envAliases env) lbl }++-- | Sets metadata node for a given unique+setUniqMeta :: Unique -> MetaId -> LlvmM ()+setUniqMeta f m = modifyEnv $ \env -> env { envUniqMeta = addToUFM (envUniqMeta env) f m }++-- | Gets metadata node for given unique+getUniqMeta :: Unique -> LlvmM (Maybe MetaId)+getUniqMeta s = getEnv (flip lookupUFM s . envUniqMeta)++-- ----------------------------------------------------------------------------+-- * Internal functions+--++-- | Here we pre-initialise some functions that are used internally by GHC+-- so as to make sure they have the most general type in the case that+-- user code also uses these functions but with a different type than GHC+-- internally. (Main offender is treating return type as 'void' instead of+-- 'void *'). Fixes trac #5486.+ghcInternalFunctions :: LlvmM ()+ghcInternalFunctions = do+    dflags <- getDynFlags+    mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]+    mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]+    mk "memset" i8Ptr [i8Ptr, llvmWord dflags, llvmWord dflags]+    mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr]+  where+    mk n ret args = do+      let n' = fsLit n `appendFS` fsLit "$def"+          decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret+                                 FixedArgs (tysToParams args) Nothing+      renderLlvm $ ppLlvmFunctionDecl decl+      funInsert n' (LMFunction decl)++-- ----------------------------------------------------------------------------+-- * Label handling+--++-- | Pretty print a 'CLabel'.+strCLabel_llvm :: CLabel -> LlvmM LMString+strCLabel_llvm lbl = do+    platform <- getLlvmPlatform+    dflags <- getDynFlags+    let sdoc = pprCLabel platform lbl+        str = Outp.renderWithStyle dflags sdoc (Outp.mkCodeStyle Outp.CStyle)+    return (fsLit str)++strDisplayName_llvm :: CLabel -> LlvmM LMString+strDisplayName_llvm lbl = do+    platform <- getLlvmPlatform+    dflags <- getDynFlags+    let sdoc = pprCLabel platform lbl+        depth = Outp.PartWay 1+        style = Outp.mkUserStyle dflags Outp.reallyAlwaysQualify depth+        str = Outp.renderWithStyle dflags sdoc style+    return (fsLit (dropInfoSuffix str))++dropInfoSuffix :: String -> String+dropInfoSuffix = go+  where go "_info"        = []+        go "_static_info" = []+        go "_con_info"    = []+        go (x:xs)         = x:go xs+        go []             = []++strProcedureName_llvm :: CLabel -> LlvmM LMString+strProcedureName_llvm lbl = do+    platform <- getLlvmPlatform+    dflags <- getDynFlags+    let sdoc = pprCLabel platform lbl+        depth = Outp.PartWay 1+        style = Outp.mkUserStyle dflags Outp.neverQualify depth+        str = Outp.renderWithStyle dflags sdoc style+    return (fsLit str)++-- ----------------------------------------------------------------------------+-- * Global variables / forward references+--++-- | Create/get a pointer to a global value. Might return an alias if+-- the value in question hasn't been defined yet. We especially make+-- no guarantees on the type of the returned pointer.+getGlobalPtr :: LMString -> LlvmM LlvmVar+getGlobalPtr llvmLbl = do+  m_ty <- funLookup llvmLbl+  let mkGlbVar lbl ty = LMGlobalVar lbl (LMPointer ty) Private Nothing Nothing+  case m_ty of+    -- Directly reference if we have seen it already+    Just ty -> return $ mkGlbVar (llvmLbl `appendFS` fsLit "$def") ty Global+    -- Otherwise use a forward alias of it+    Nothing -> do+      saveAlias llvmLbl+      return $ mkGlbVar llvmLbl i8 Alias++-- | Generate definitions for aliases forward-referenced by @getGlobalPtr@.+--+-- Must be called at a point where we are sure that no new global definitions+-- will be generated anymore!+generateExternDecls :: LlvmM ([LMGlobal], [LlvmType])+generateExternDecls = do+  delayed <- fmap nonDetEltsUniqSet $ getEnv envAliases+  -- This is non-deterministic but we do not+  -- currently support deterministic code-generation.+  -- See Note [Unique Determinism and code generation]+  defss <- flip mapM delayed $ \lbl -> do+    m_ty <- funLookup lbl+    case m_ty of+      -- If we have a definition we've already emitted the proper aliases+      -- when the symbol itself was emitted by @aliasify@+      Just _ -> return []++      -- If we don't have a definition this is an external symbol and we+      -- need to emit a declaration+      Nothing ->+        let var = LMGlobalVar lbl i8Ptr External Nothing Nothing Global+        in return [LMGlobal var Nothing]++  -- Reset forward list+  modifyEnv $ \env -> env { envAliases = emptyUniqSet }+  return (concat defss, [])++-- | Here we take a global variable definition, rename it with a+-- @$def@ suffix, and generate the appropriate alias.+aliasify :: LMGlobal -> LlvmM [LMGlobal]+aliasify (LMGlobal var val) = do+    let i8Ptr = LMPointer (LMInt 8)+        LMGlobalVar lbl ty link sect align const = var++        defLbl = lbl `appendFS` fsLit "$def"+        defVar = LMGlobalVar defLbl ty Internal sect align const++        defPtrVar = LMGlobalVar defLbl (LMPointer ty) link Nothing Nothing const+        aliasVar = LMGlobalVar lbl (LMPointer i8Ptr) link Nothing Nothing Alias+        aliasVal = LMBitc (LMStaticPointer defPtrVar) i8Ptr++    -- we need to mark the $def symbols as used so LLVM doesn't forget which+    -- section they need to go in. This will vanish once we switch away from+    -- mangling sections for TNTC.+    markUsedVar defVar++    return [ LMGlobal defVar val+           , LMGlobal aliasVar (Just aliasVal)+           ]++-- Note [Llvm Forward References]+--+-- The issue here is that LLVM insists on being strongly typed at+-- every corner, so the first time we mention something, we have to+-- settle what type we assign to it. That makes things awkward, as Cmm+-- will often reference things before their definition, and we have no+-- idea what (LLVM) type it is going to be before that point.+--+-- Our work-around is to define "aliases" of a standard type (i8 *) in+-- these kind of situations, which we later tell LLVM to be either+-- references to their actual local definitions (involving a cast) or+-- an external reference. This obviously only works for pointers.+--+-- In particular when we encounter a reference to a symbol in a chunk of+-- C-- there are three possible scenarios,+--+--   1. We have already seen a definition for the referenced symbol. This+--      means we already know its type.+--+--   2. We have not yet seen a definition but we will find one later in this+--      compilation unit. Since we want to be a good consumer of the+--      C-- streamed to us from upstream, we don't know the type of the+--      symbol at the time when we must emit the reference.+--+--   3. We have not yet seen a definition nor will we find one in this+--      compilation unit. In this case the reference refers to an+--      external symbol for which we do not know the type.+--+-- Let's consider case (2) for a moment: say we see a reference to+-- the symbol @fooBar@ for which we have not seen a definition. As we+-- do not know the symbol's type, we assume it is of type @i8*@ and emit+-- the appropriate casts in @getSymbolPtr@. Later on, when we+-- encounter the definition of @fooBar@ we emit it but with a modified+-- name, @fooBar$def@ (which we'll call the definition symbol), to+-- since we have already had to assume that the symbol @fooBar@+-- is of type @i8*@. We then emit @fooBar@ itself as an alias+-- of @fooBar$def@ with appropriate casts. This all happens in+-- @aliasify@.+--+-- Case (3) is quite similar to (2): References are emitted assuming+-- the referenced symbol is of type @i8*@. When we arrive at the end of+-- the compilation unit and realize that the symbol is external, we emit+-- an LLVM @external global@ declaration for the symbol @fooBar@+-- (handled in @generateExternDecls@). This takes advantage of the+-- fact that the aliases produced by @aliasify@ for exported symbols+-- have external linkage and can therefore be used as normal symbols.+--+-- Historical note: As of release 3.5 LLVM does not allow aliases to+-- refer to declarations. This the reason why aliases are produced at the+-- point of definition instead of the point of usage, as was previously+-- done. See #9142 for details.+--+-- Finally, case (1) is trival. As we already have a definition for+-- and therefore know the type of the referenced symbol, we can do+-- away with casting the alias to the desired type in @getSymbolPtr@+-- and instead just emit a reference to the definition symbol directly.+-- This is the @Just@ case in @getSymbolPtr@.
+ llvmGen/LlvmCodeGen/CodeGen.hs view
@@ -0,0 +1,1912 @@+{-# LANGUAGE CPP, GADTs #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+-- ----------------------------------------------------------------------------+-- | Handle conversion of CmmProc to LLVM code.+--+module LlvmCodeGen.CodeGen ( genLlvmProc ) where++#include "HsVersions.h"++import Llvm+import LlvmCodeGen.Base+import LlvmCodeGen.Regs++import BlockId+import CodeGen.Platform ( activeStgRegs, callerSaves )+import CLabel+import Cmm+import PprCmm+import CmmUtils+import CmmSwitch+import Hoopl++import DynFlags+import FastString+import ForeignCall+import Outputable hiding (panic, pprPanic)+import qualified Outputable+import Platform+import OrdList+import UniqSupply+import Unique+import Util++import Control.Monad.Trans.Class+import Control.Monad.Trans.Writer++#if __GLASGOW_HASKELL__ > 710+import Data.Semigroup   ( Semigroup )+import qualified Data.Semigroup as Semigroup+#endif+import Data.List ( nub )+import Data.Maybe ( catMaybes )++type Atomic = Bool+type LlvmStatements = OrdList LlvmStatement++-- -----------------------------------------------------------------------------+-- | Top-level of the LLVM proc Code generator+--+genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl]+genLlvmProc (CmmProc infos lbl live graph) = do+    let blocks = toBlockListEntryFirstFalseFallthrough graph+    (lmblocks, lmdata) <- basicBlocksCodeGen live blocks+    let info = mapLookup (g_entry graph) infos+        proc = CmmProc info lbl live (ListGraph lmblocks)+    return (proc:lmdata)++genLlvmProc _ = panic "genLlvmProc: case that shouldn't reach here!"++-- -----------------------------------------------------------------------------+-- * Block code generation+--++-- | Generate code for a list of blocks that make up a complete+-- procedure. The first block in the list is exepected to be the entry+-- point and will get the prologue.+basicBlocksCodeGen :: LiveGlobalRegs -> [CmmBlock]+                      -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl])+basicBlocksCodeGen _    []                     = panic "no entry block!"+basicBlocksCodeGen live (entryBlock:cmmBlocks)+  = do (prologue, prologueTops) <- funPrologue live (entryBlock:cmmBlocks)++       -- Generate code+       (BasicBlock bid entry, entryTops) <- basicBlockCodeGen entryBlock+       (blocks, topss) <- fmap unzip $ mapM basicBlockCodeGen cmmBlocks++       -- Compose+       let entryBlock = BasicBlock bid (fromOL prologue ++ entry)+       return (entryBlock : blocks, prologueTops ++ entryTops ++ concat topss)+++-- | Generate code for one block+basicBlockCodeGen :: CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] )+basicBlockCodeGen block+  = do let (_, nodes, tail)  = blockSplit block+           id = entryLabel block+       (mid_instrs, top) <- stmtsToInstrs $ blockToList nodes+       (tail_instrs, top')  <- stmtToInstrs tail+       let instrs = fromOL (mid_instrs `appOL` tail_instrs)+       return (BasicBlock id instrs, top' ++ top)++-- -----------------------------------------------------------------------------+-- * CmmNode code generation+--++-- A statement conversion return data.+--   * LlvmStatements: The compiled LLVM statements.+--   * LlvmCmmDecl: Any global data needed.+type StmtData = (LlvmStatements, [LlvmCmmDecl])+++-- | Convert a list of CmmNode's to LlvmStatement's+stmtsToInstrs :: [CmmNode e x] -> LlvmM StmtData+stmtsToInstrs stmts+   = do (instrss, topss) <- fmap unzip $ mapM stmtToInstrs stmts+        return (concatOL instrss, concat topss)+++-- | Convert a CmmStmt to a list of LlvmStatement's+stmtToInstrs :: CmmNode e x -> LlvmM StmtData+stmtToInstrs stmt = case stmt of++    CmmComment _         -> return (nilOL, []) -- nuke comments+    CmmTick    _         -> return (nilOL, [])+    CmmUnwind  {}        -> return (nilOL, [])++    CmmAssign reg src    -> genAssign reg src+    CmmStore addr src    -> genStore addr src++    CmmBranch id         -> genBranch id+    CmmCondBranch arg true false likely+                         -> genCondBranch arg true false likely+    CmmSwitch arg ids    -> genSwitch arg ids++    -- Foreign Call+    CmmUnsafeForeignCall target res args+        -> genCall target res args++    -- Tail call+    CmmCall { cml_target = arg,+              cml_args_regs = live } -> genJump arg live++    _ -> panic "Llvm.CodeGen.stmtToInstrs"++-- | Wrapper function to declare an instrinct function by function type+getInstrinct2 :: LMString -> LlvmType -> LlvmM ExprData+getInstrinct2 fname fty@(LMFunction funSig) = do++    let fv   = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing Constant++    fn <- funLookup fname+    tops <- case fn of+      Just _  ->+        return []+      Nothing -> do+        funInsert fname fty+        un <- getUniqueM+        let lbl = mkAsmTempLabel un+        return [CmmData (Section Data lbl) [([],[fty])]]++    return (fv, nilOL, tops)++getInstrinct2 _ _ = error "getInstrinct2: Non-function type!"++-- | Declares an instrinct function by return and parameter types+getInstrinct :: LMString -> LlvmType -> [LlvmType] -> LlvmM ExprData+getInstrinct fname retTy parTys =+    let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc retTy+                    FixedArgs (tysToParams parTys) Nothing+        fty = LMFunction funSig+    in getInstrinct2 fname fty++-- | Memory barrier instruction for LLVM >= 3.0+barrier :: LlvmM StmtData+barrier = do+    let s = Fence False SyncSeqCst+    return (unitOL s, [])++-- | Foreign Calls+genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual]+              -> LlvmM StmtData++-- Write barrier needs to be handled specially as it is implemented as an LLVM+-- intrinsic function.+genCall (PrimTarget MO_WriteBarrier) _ _ = do+    platform <- getLlvmPlatform+    if platformArch platform `elem` [ArchX86, ArchX86_64, ArchSPARC]+       then return (nilOL, [])+       else barrier++genCall (PrimTarget MO_Touch) _ _+ = return (nilOL, [])++genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = runStmtsDecls $ do+    dstV <- getCmmRegW (CmmLocal dst)+    let ty = cmmToLlvmType $ localRegType dst+        width = widthToLlvmFloat w+    castV <- lift $ mkLocalVar ty+    ve <- exprToVarW e+    statement $ Assignment castV $ Cast LM_Uitofp ve width+    statement $ Store castV dstV++genCall (PrimTarget (MO_UF_Conv _)) [_] args =+    panic $ "genCall: Too many arguments to MO_UF_Conv. " +++    "Can only handle 1, given" ++ show (length args) ++ "."++-- Handle prefetching data+genCall t@(PrimTarget (MO_Prefetch_Data localityInt)) [] args+  | 0 <= localityInt && localityInt <= 3 = runStmtsDecls $ do+    let argTy = [i8Ptr, i32, i32, i32]+        funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible+                             CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing++    let (_, arg_hints) = foreignTargetHints t+    let args_hints' = zip args arg_hints+    argVars <- arg_varsW args_hints' ([], nilOL, [])+    fptr    <- liftExprData $ getFunPtr funTy t+    argVars' <- castVarsW $ zip argVars argTy++    doTrashStmts+    let argSuffix = [mkIntLit i32 0, mkIntLit i32 localityInt, mkIntLit i32 1]+    statement $ Expr $ Call StdCall fptr (argVars' ++ argSuffix) []+  | otherwise = panic $ "prefetch locality level integer must be between 0 and 3, given: " ++ (show localityInt)++-- Handle PopCnt, Clz, Ctz, and BSwap that need to only convert arg+-- and return types+genCall t@(PrimTarget (MO_PopCnt w)) dsts args =+    genCallSimpleCast w t dsts args+genCall t@(PrimTarget (MO_Clz w)) dsts args =+    genCallSimpleCast w t dsts args+genCall t@(PrimTarget (MO_Ctz w)) dsts args =+    genCallSimpleCast w t dsts args+genCall t@(PrimTarget (MO_BSwap w)) dsts args =+    genCallSimpleCast w t dsts args++genCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = runStmtsDecls $ do+    addrVar <- exprToVarW addr+    nVar <- exprToVarW n+    let targetTy = widthToLlvmInt width+        ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy)+    ptrVar <- doExprW (pLift targetTy) ptrExpr+    dstVar <- getCmmRegW (CmmLocal dst)+    let op = case amop of+               AMO_Add  -> LAO_Add+               AMO_Sub  -> LAO_Sub+               AMO_And  -> LAO_And+               AMO_Nand -> LAO_Nand+               AMO_Or   -> LAO_Or+               AMO_Xor  -> LAO_Xor+    retVar <- doExprW targetTy $ AtomicRMW op ptrVar nVar SyncSeqCst+    statement $ Store retVar dstVar++genCall (PrimTarget (MO_AtomicRead _)) [dst] [addr] = runStmtsDecls $ do+    dstV <- getCmmRegW (CmmLocal dst)+    v1 <- genLoadW True addr (localRegType dst)+    statement $ Store v1 dstV++genCall (PrimTarget (MO_Cmpxchg _width))+        [dst] [addr, old, new] = runStmtsDecls $ do+    addrVar <- exprToVarW addr+    oldVar <- exprToVarW old+    newVar <- exprToVarW new+    let targetTy = getVarType oldVar+        ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy)+    ptrVar <- doExprW (pLift targetTy) ptrExpr+    dstVar <- getCmmRegW (CmmLocal dst)+    retVar <- doExprW (LMStructU [targetTy,i1])+              $ CmpXChg ptrVar oldVar newVar SyncSeqCst SyncSeqCst+    retVar' <- doExprW targetTy $ ExtractV retVar 0+    statement $ Store retVar' dstVar++genCall (PrimTarget (MO_AtomicWrite _width)) [] [addr, val] = runStmtsDecls $ do+    addrVar <- exprToVarW addr+    valVar <- exprToVarW val+    let ptrTy = pLift $ getVarType valVar+        ptrExpr = Cast LM_Inttoptr addrVar ptrTy+    ptrVar <- doExprW ptrTy ptrExpr+    statement $ Expr $ AtomicRMW LAO_Xchg ptrVar valVar SyncSeqCst++-- Handle memcpy function specifically since llvm's intrinsic version takes+-- some extra parameters.+genCall t@(PrimTarget op) [] args+ | Just align <- machOpMemcpyishAlign op = runStmtsDecls $ do+    dflags <- getDynFlags+    let isVolTy = [i1]+        isVolVal = [mkIntLit i1 0]+        argTy | MO_Memset _ <- op = [i8Ptr, i8,    llvmWord dflags, i32] ++ isVolTy+              | otherwise         = [i8Ptr, i8Ptr, llvmWord dflags, i32] ++ isVolTy+        funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible+                             CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing++    let (_, arg_hints) = foreignTargetHints t+    let args_hints = zip args arg_hints+    argVars       <- arg_varsW args_hints ([], nilOL, [])+    fptr          <- getFunPtrW funTy t+    argVars' <- castVarsW $ zip argVars argTy++    doTrashStmts+    let alignVal = mkIntLit i32 align+        arguments = argVars' ++ (alignVal:isVolVal)+    statement $ Expr $ Call StdCall fptr arguments []++-- We handle MO_U_Mul2 by simply using a 'mul' instruction, but with operands+-- twice the width (we first zero-extend them), e.g., on 64-bit arch we will+-- generate 'mul' on 128-bit operands. Then we only need some plumbing to+-- extract the two 64-bit values out of 128-bit result.+genCall (PrimTarget (MO_U_Mul2 w)) [dstH, dstL] [lhs, rhs] = runStmtsDecls $ do+    let width = widthToLlvmInt w+        bitWidth = widthInBits w+        width2x = LMInt (bitWidth * 2)+    -- First zero-extend the operands ('mul' instruction requires the operands+    -- and the result to be of the same type). Note that we don't use 'castVars'+    -- because it tries to do LM_Sext.+    lhsVar <- exprToVarW lhs+    rhsVar <- exprToVarW rhs+    lhsExt <- doExprW width2x $ Cast LM_Zext lhsVar width2x+    rhsExt <- doExprW width2x $ Cast LM_Zext rhsVar width2x+    -- Do the actual multiplication (note that the result is also 2x width).+    retV <- doExprW width2x $ LlvmOp LM_MO_Mul lhsExt rhsExt+    -- Extract the lower bits of the result into retL.+    retL <- doExprW width $ Cast LM_Trunc retV width+    -- Now we right-shift the higher bits by width.+    let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width+    retShifted <- doExprW width2x $ LlvmOp LM_MO_LShr retV widthLlvmLit+    -- And extract them into retH.+    retH <- doExprW width $ Cast LM_Trunc retShifted width+    dstRegL <- getCmmRegW (CmmLocal dstL)+    dstRegH <- getCmmRegW (CmmLocal dstH)+    statement $ Store retL dstRegL+    statement $ Store retH dstRegH++-- MO_U_QuotRem2 is another case we handle by widening the registers to double+-- the width and use normal LLVM instructions (similarly to the MO_U_Mul2). The+-- main difference here is that we need to combine two words into one register+-- and then use both 'udiv' and 'urem' instructions to compute the result.+genCall (PrimTarget (MO_U_QuotRem2 w))+        [dstQ, dstR] [lhsH, lhsL, rhs] = runStmtsDecls $ do+    let width = widthToLlvmInt w+        bitWidth = widthInBits w+        width2x = LMInt (bitWidth * 2)+    -- First zero-extend all parameters to double width.+    let zeroExtend expr = do+            var <- exprToVarW expr+            doExprW width2x $ Cast LM_Zext var width2x+    lhsExtH <- zeroExtend lhsH+    lhsExtL <- zeroExtend lhsL+    rhsExt <- zeroExtend rhs+    -- Now we combine the first two parameters (that represent the high and low+    -- bits of the value). So first left-shift the high bits to their position+    -- and then bit-or them with the low bits.+    let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width+    lhsExtHShifted <- doExprW width2x $ LlvmOp LM_MO_Shl lhsExtH widthLlvmLit+    lhsExt <- doExprW width2x $ LlvmOp LM_MO_Or lhsExtHShifted lhsExtL+    -- Finally, we can call 'udiv' and 'urem' to compute the results.+    retExtDiv <- doExprW width2x $ LlvmOp LM_MO_UDiv lhsExt rhsExt+    retExtRem <- doExprW width2x $ LlvmOp LM_MO_URem lhsExt rhsExt+    -- And since everything is in 2x width, we need to truncate the results and+    -- then return them.+    let narrow var = doExprW width $ Cast LM_Trunc var width+    retDiv <- narrow retExtDiv+    retRem <- narrow retExtRem+    dstRegQ <- lift $ getCmmReg (CmmLocal dstQ)+    dstRegR <- lift $ getCmmReg (CmmLocal dstR)+    statement $ Store retDiv dstRegQ+    statement $ Store retRem dstRegR++-- Handle the MO_{Add,Sub}IntC separately. LLVM versions return a record from+-- which we need to extract the actual values.+genCall t@(PrimTarget (MO_AddIntC w)) [dstV, dstO] [lhs, rhs] =+    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]+genCall t@(PrimTarget (MO_SubIntC w)) [dstV, dstO] [lhs, rhs] =+    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]++-- Similar to MO_{Add,Sub}IntC, but MO_Add2 expects the first element of the+-- return tuple to be the overflow bit and the second element to contain the+-- actual result of the addition. So we still use genCallWithOverflow but swap+-- the return registers.+genCall t@(PrimTarget (MO_Add2 w)) [dstO, dstV] [lhs, rhs] =+    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]++genCall t@(PrimTarget (MO_SubWordC w)) [dstV, dstO] [lhs, rhs] =+    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]++-- Handle all other foreign calls and prim ops.+genCall target res args = runStmtsDecls $ do+    dflags <- getDynFlags++    -- parameter types+    let arg_type (_, AddrHint) = i8Ptr+        -- cast pointers to i8*. Llvm equivalent of void*+        arg_type (expr, _) = cmmToLlvmType $ cmmExprType dflags expr++    -- ret type+    let ret_type [] = LMVoid+        ret_type [(_, AddrHint)] = i8Ptr+        ret_type [(reg, _)]      = cmmToLlvmType $ localRegType reg+        ret_type t = panic $ "genCall: Too many return values! Can only handle"+                        ++ " 0 or 1, given " ++ show (length t) ++ "."++    -- extract Cmm call convention, and translate to LLVM call convention+    platform <- lift $ getLlvmPlatform+    let lmconv = case target of+            ForeignTarget _ (ForeignConvention conv _ _ _) ->+              case conv of+                 StdCallConv  -> case platformArch platform of+                                 ArchX86    -> CC_X86_Stdcc+                                 ArchX86_64 -> CC_X86_Stdcc+                                 _          -> CC_Ccc+                 CCallConv    -> CC_Ccc+                 CApiConv     -> CC_Ccc+                 PrimCallConv -> panic "LlvmCodeGen.CodeGen.genCall: PrimCallConv"+                 JavaScriptCallConv -> panic "LlvmCodeGen.CodeGen.genCall: JavaScriptCallConv"++            PrimTarget   _ -> CC_Ccc++    {-+        CC_Ccc of the possibilities here are a worry with the use of a custom+        calling convention for passing STG args. In practice the more+        dangerous combinations (e.g StdCall + llvmGhcCC) don't occur.++        The native code generator only handles StdCall and CCallConv.+    -}++    -- call attributes+    let fnAttrs | never_returns = NoReturn : llvmStdFunAttrs+                | otherwise     = llvmStdFunAttrs++        never_returns = case target of+             ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns) -> True+             _ -> False++    -- fun type+    let (res_hints, arg_hints) = foreignTargetHints target+    let args_hints = zip args arg_hints+    let ress_hints = zip res  res_hints+    let ccTy  = StdCall -- tail calls should be done through CmmJump+    let retTy = ret_type ress_hints+    let argTy = tysToParams $ map arg_type args_hints+    let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible+                             lmconv retTy FixedArgs argTy (llvmFunAlign dflags)+++    argVars <- arg_varsW args_hints ([], nilOL, [])+    fptr    <- getFunPtrW funTy target++    let doReturn | ccTy == TailCall  = statement $ Return Nothing+                 | never_returns     = statement $ Unreachable+                 | otherwise         = return ()++    doTrashStmts++    -- make the actual call+    case retTy of+        LMVoid -> do+            statement $ Expr $ Call ccTy fptr argVars fnAttrs++        _ -> do+            v1 <- doExprW retTy $ Call ccTy fptr argVars fnAttrs+            -- get the return register+            let ret_reg [reg] = reg+                ret_reg t = panic $ "genCall: Bad number of registers! Can only handle"+                                ++ " 1, given " ++ show (length t) ++ "."+            let creg = ret_reg res+            vreg <- getCmmRegW (CmmLocal creg)+            if retTy == pLower (getVarType vreg)+                then do+                    statement $ Store v1 vreg+                    doReturn+                else do+                    let ty = pLower $ getVarType vreg+                    let op = case ty of+                            vt | isPointer vt -> LM_Bitcast+                               | isInt     vt -> LM_Ptrtoint+                               | otherwise    ->+                                   panic $ "genCall: CmmReg bad match for"+                                        ++ " returned type!"++                    v2 <- doExprW ty $ Cast op v1 ty+                    statement $ Store v2 vreg+                    doReturn++-- | Generate a call to an LLVM intrinsic that performs arithmetic operation+-- with overflow bit (i.e., returns a struct containing the actual result of the+-- operation and an overflow bit). This function will also extract the overflow+-- bit and zero-extend it (all the corresponding Cmm PrimOps represent the+-- overflow "bit" as a usual Int# or Word#).+genCallWithOverflow+  :: ForeignTarget -> Width -> [CmmFormal] -> [CmmActual] -> LlvmM StmtData+genCallWithOverflow t@(PrimTarget op) w [dstV, dstO] [lhs, rhs] = do+    -- So far this was only tested for the following four CallishMachOps.+    let valid = op `elem`   [ MO_Add2 w+                            , MO_AddIntC w+                            , MO_SubIntC w+                            , MO_SubWordC w+                            ]+    MASSERT(valid)+    let width = widthToLlvmInt w+    -- This will do most of the work of generating the call to the intrinsic and+    -- extracting the values from the struct.+    (value, overflowBit, (stmts, top)) <-+      genCallExtract t w (lhs, rhs) (width, i1)+    -- value is i<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+        storeO = Store overflow dstRegO+    return (stmts `snocOL` zext `snocOL` storeV `snocOL` storeO, top)+genCallWithOverflow _ _ _ _ =+    panic "genCallExtract: wrong ForeignTarget or number of arguments"++-- | A helper function for genCallWithOverflow that handles generating the call+-- to the LLVM intrinsic and extracting the result from the struct to LlvmVars.+genCallExtract+    :: ForeignTarget           -- ^ PrimOp+    -> Width                   -- ^ Width of the operands.+    -> (CmmActual, CmmActual)  -- ^ Actual arguments.+    -> (LlvmType, LlvmType)    -- ^ LLLVM types of the returned sturct.+    -> LlvmM (LlvmVar, LlvmVar, StmtData)+genCallExtract target@(PrimTarget op) w (argA, argB) (llvmTypeA, llvmTypeB) = do+    let width = widthToLlvmInt w+        argTy = [width, width]+        retTy = LMStructU [llvmTypeA, llvmTypeB]++    -- Process the arguments.+    let args_hints = zip [argA, argB] (snd $ foreignTargetHints target)+    (argsV1, args1, top1) <- arg_vars args_hints ([], nilOL, [])+    (argsV2, args2) <- castVars $ zip argsV1 argTy++    -- Get the function and make the call.+    fname <- cmmPrimOpFunctions op+    (fptr, _, top2) <- getInstrinct fname retTy argTy+    -- We use StdCall for primops. See also the last case of genCall.+    (retV, call) <- doExpr retTy $ Call StdCall fptr argsV2 []++    -- This will result in a two element struct, we need to use "extractvalue"+    -- to get them out of it.+    (res1, ext1) <- doExpr llvmTypeA (ExtractV retV 0)+    (res2, ext2) <- doExpr llvmTypeB (ExtractV retV 1)++    let stmts = args1 `appOL` args2 `snocOL` call `snocOL` ext1 `snocOL` ext2+        tops = top1 ++ top2+    return (res1, res2, (stmts, tops))++genCallExtract _ _ _ _ =+    panic "genCallExtract: unsupported ForeignTarget"++-- Handle simple function call that only need simple type casting, of the form:+--   truncate arg >>= \a -> call(a) >>= zext+--+-- since GHC only really has i32 and i64 types and things like Word8 are backed+-- by an i32 and just present a logical i8 range. So we must handle conversions+-- from i32 to i8 explicitly as LLVM is strict about types.+genCallSimpleCast :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual]+              -> LlvmM StmtData+genCallSimpleCast w t@(PrimTarget op) [dst] args = do+    let width = widthToLlvmInt w+        dstTy = cmmToLlvmType $ localRegType dst++    fname                       <- cmmPrimOpFunctions op+    (fptr, _, top3)             <- getInstrinct fname width [width]++    dstV                        <- getCmmReg (CmmLocal dst)++    let (_, arg_hints) = foreignTargetHints t+    let args_hints = zip args arg_hints+    (argsV, stmts2, top2)       <- arg_vars args_hints ([], nilOL, [])+    (argsV', stmts4)            <- castVars $ zip argsV [width]+    (retV, s1)                  <- doExpr width $ Call StdCall fptr argsV' []+    ([retV'], stmts5)           <- castVars [(retV,dstTy)]+    let s2                       = Store retV' dstV++    let stmts = stmts2 `appOL` stmts4 `snocOL`+                s1 `appOL` stmts5 `snocOL` s2+    return (stmts, top2 ++ top3)+genCallSimpleCast _ _ dsts _ =+    panic ("genCallSimpleCast: " ++ show (length dsts) ++ " dsts")++-- | Create a function pointer from a target.+getFunPtrW :: (LMString -> LlvmType) -> ForeignTarget+           -> WriterT LlvmAccum LlvmM LlvmVar+getFunPtrW funTy targ = liftExprData $ getFunPtr funTy targ++-- | Create a function pointer from a target.+getFunPtr :: (LMString -> LlvmType) -> ForeignTarget+          -> LlvmM ExprData+getFunPtr funTy targ = case targ of+    ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do+        name <- strCLabel_llvm lbl+        getHsFunc' name (funTy name)++    ForeignTarget expr _ -> do+        (v1, stmts, top) <- exprToVar expr+        dflags <- getDynFlags+        let fty = funTy $ fsLit "dynamic"+            cast = case getVarType v1 of+                ty | isPointer ty -> LM_Bitcast+                ty | isInt ty     -> LM_Inttoptr++                ty -> panic $ "genCall: Expr is of bad type for function"+                              ++ " call! (" ++ showSDoc dflags (ppr ty) ++ ")"++        (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)+        return (v2, stmts `snocOL` s1, top)++    PrimTarget mop -> do+        name <- cmmPrimOpFunctions mop+        let fty = funTy name+        getInstrinct2 name fty++-- | Conversion of call arguments.+arg_varsW :: [(CmmActual, ForeignHint)]+          -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])+          -> WriterT LlvmAccum LlvmM [LlvmVar]+arg_varsW xs ys = do+    (vars, stmts, decls) <- lift $ arg_vars xs ys+    tell $ LlvmAccum stmts decls+    return vars++-- | Conversion of call arguments.+arg_vars :: [(CmmActual, ForeignHint)]+         -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])+         -> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl])++arg_vars [] (vars, stmts, tops)+  = return (vars, stmts, tops)++arg_vars ((e, AddrHint):rest) (vars, stmts, tops)+  = do (v1, stmts', top') <- exprToVar e+       dflags <- getDynFlags+       let op = case getVarType v1 of+               ty | isPointer ty -> LM_Bitcast+               ty | isInt ty     -> LM_Inttoptr++               a  -> panic $ "genCall: Can't cast llvmType to i8*! ("+                           ++ showSDoc dflags (ppr a) ++ ")"++       (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr+       arg_vars rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1,+                               tops ++ top')++arg_vars ((e, _):rest) (vars, stmts, tops)+  = do (v1, stmts', top') <- exprToVar e+       arg_vars rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top')+++-- | Cast a collection of LLVM variables to specific types.+castVarsW :: [(LlvmVar, LlvmType)]+          -> WriterT LlvmAccum LlvmM [LlvmVar]+castVarsW vars = do+    (vars, stmts) <- lift $ castVars vars+    tell $ LlvmAccum stmts mempty+    return vars++-- | Cast a collection of LLVM variables to specific types.+castVars :: [(LlvmVar, LlvmType)]+         -> LlvmM ([LlvmVar], LlvmStatements)+castVars vars = do+                done <- mapM (uncurry castVar) vars+                let (vars', stmts) = unzip done+                return (vars', toOL stmts)++-- | Cast an LLVM variable to a specific type, panicing if it can't be done.+castVar :: LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement)+castVar v t | getVarType v == t+            = return (v, Nop)++            | otherwise+            = do dflags <- getDynFlags+                 let op = case (getVarType v, t) of+                      (LMInt n, LMInt m)+                          -> if n < m then LM_Sext else LM_Trunc+                      (vt, _) | isFloat vt && isFloat t+                          -> if llvmWidthInBits dflags vt < llvmWidthInBits dflags t+                                then LM_Fpext else LM_Fptrunc+                      (vt, _) | isInt vt && isFloat t       -> LM_Sitofp+                      (vt, _) | isFloat vt && isInt t       -> LM_Fptosi+                      (vt, _) | isInt vt && isPointer t     -> LM_Inttoptr+                      (vt, _) | isPointer vt && isInt t     -> LM_Ptrtoint+                      (vt, _) | isPointer vt && isPointer t -> LM_Bitcast+                      (vt, _) | isVector vt && isVector t   -> LM_Bitcast++                      (vt, _) -> panic $ "castVars: Can't cast this type ("+                                  ++ showSDoc dflags (ppr vt) ++ ") to (" ++ showSDoc dflags (ppr t) ++ ")"+                 doExpr t $ Cast op v t+++-- | Decide what C function to use to implement a CallishMachOp+cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString+cmmPrimOpFunctions mop = do++  dflags <- getDynFlags+  let intrinTy1 = "p0i8.p0i8." ++ showSDoc dflags (ppr $ llvmWord dflags)+      intrinTy2 = "p0i8." ++ showSDoc dflags (ppr $ llvmWord dflags)+      unsupported = panic ("cmmPrimOpFunctions: " ++ show mop+                        ++ " not supported here")++  return $ case mop of+    MO_F32_Exp    -> fsLit "expf"+    MO_F32_Log    -> fsLit "logf"+    MO_F32_Sqrt   -> fsLit "llvm.sqrt.f32"+    MO_F32_Fabs   -> fsLit "llvm.fabs.f32"+    MO_F32_Pwr    -> fsLit "llvm.pow.f32"++    MO_F32_Sin    -> fsLit "llvm.sin.f32"+    MO_F32_Cos    -> fsLit "llvm.cos.f32"+    MO_F32_Tan    -> fsLit "tanf"++    MO_F32_Asin   -> fsLit "asinf"+    MO_F32_Acos   -> fsLit "acosf"+    MO_F32_Atan   -> fsLit "atanf"++    MO_F32_Sinh   -> fsLit "sinhf"+    MO_F32_Cosh   -> fsLit "coshf"+    MO_F32_Tanh   -> fsLit "tanhf"++    MO_F64_Exp    -> fsLit "exp"+    MO_F64_Log    -> fsLit "log"+    MO_F64_Sqrt   -> fsLit "llvm.sqrt.f64"+    MO_F64_Fabs   -> fsLit "llvm.fabs.f64"+    MO_F64_Pwr    -> fsLit "llvm.pow.f64"++    MO_F64_Sin    -> fsLit "llvm.sin.f64"+    MO_F64_Cos    -> fsLit "llvm.cos.f64"+    MO_F64_Tan    -> fsLit "tan"++    MO_F64_Asin   -> fsLit "asin"+    MO_F64_Acos   -> fsLit "acos"+    MO_F64_Atan   -> fsLit "atan"++    MO_F64_Sinh   -> fsLit "sinh"+    MO_F64_Cosh   -> fsLit "cosh"+    MO_F64_Tanh   -> fsLit "tanh"++    MO_Memcpy _   -> fsLit $ "llvm.memcpy."  ++ intrinTy1+    MO_Memmove _  -> fsLit $ "llvm.memmove." ++ intrinTy1+    MO_Memset _   -> fsLit $ "llvm.memset."  ++ intrinTy2++    (MO_PopCnt w) -> fsLit $ "llvm.ctpop."  ++ showSDoc dflags (ppr $ widthToLlvmInt w)+    (MO_BSwap w)  -> fsLit $ "llvm.bswap."  ++ showSDoc dflags (ppr $ widthToLlvmInt w)+    (MO_Clz w)    -> fsLit $ "llvm.ctlz."   ++ showSDoc dflags (ppr $ widthToLlvmInt w)+    (MO_Ctz w)    -> fsLit $ "llvm.cttz."   ++ showSDoc dflags (ppr $ widthToLlvmInt w)++    (MO_Prefetch_Data _ )-> fsLit "llvm.prefetch"++    MO_AddIntC w    -> fsLit $ "llvm.sadd.with.overflow."+                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)+    MO_SubIntC w    -> fsLit $ "llvm.ssub.with.overflow."+                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)+    MO_Add2 w       -> fsLit $ "llvm.uadd.with.overflow."+                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)+    MO_SubWordC w   -> fsLit $ "llvm.usub.with.overflow."+                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)++    MO_S_QuotRem {}  -> unsupported+    MO_U_QuotRem {}  -> unsupported+    MO_U_QuotRem2 {} -> unsupported+    -- We support MO_U_Mul2 through ordinary LLVM mul instruction, see the+    -- appropriate case of genCall.+    MO_U_Mul2 {}     -> unsupported+    MO_WriteBarrier  -> unsupported+    MO_Touch         -> unsupported+    MO_UF_Conv _     -> unsupported++    MO_AtomicRead _  -> unsupported+    MO_AtomicRMW _ _ -> unsupported+    MO_AtomicWrite _ -> unsupported+    MO_Cmpxchg _     -> unsupported++-- | Tail function calls+genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData++-- Call to known function+genJump (CmmLit (CmmLabel lbl)) live = do+    (vf, stmts, top) <- getHsFunc live lbl+    (stgRegs, stgStmts) <- funEpilogue live+    let s1  = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs+    let s2  = Return Nothing+    return (stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top)+++-- Call to unknown function / address+genJump expr live = do+    fty <- llvmFunTy live+    (vf, stmts, top) <- exprToVar expr+    dflags <- getDynFlags++    let cast = case getVarType vf of+         ty | isPointer ty -> LM_Bitcast+         ty | isInt ty     -> LM_Inttoptr++         ty -> panic $ "genJump: Expr is of bad type for function call! ("+                     ++ showSDoc dflags (ppr ty) ++ ")"++    (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)+    (stgRegs, stgStmts) <- funEpilogue live+    let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs+    let s3 = Return Nothing+    return (stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3,+            top)+++-- | CmmAssign operation+--+-- We use stack allocated variables for CmmReg. The optimiser will replace+-- these with registers when possible.+genAssign :: CmmReg -> CmmExpr -> LlvmM StmtData+genAssign reg val = do+    vreg <- getCmmReg reg+    (vval, stmts2, top2) <- exprToVar val+    let stmts = stmts2++    let ty = (pLower . getVarType) vreg+    dflags <- getDynFlags+    case ty of+      -- Some registers are pointer types, so need to cast value to pointer+      LMPointer _ | getVarType vval == llvmWord dflags -> do+          (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty+          let s2 = Store v vreg+          return (stmts `snocOL` s1 `snocOL` s2, top2)++      LMVector _ _ -> do+          (v, s1) <- doExpr ty $ Cast LM_Bitcast vval ty+          let s2 = Store v vreg+          return (stmts `snocOL` s1 `snocOL` s2, top2)++      _ -> do+          let s1 = Store vval vreg+          return (stmts `snocOL` s1, top2)+++-- | CmmStore operation+genStore :: CmmExpr -> CmmExpr -> LlvmM StmtData++-- First we try to detect a few common cases and produce better code for+-- these then the default case. We are mostly trying to detect Cmm code+-- like I32[Sp + n] and use 'getelementptr' operations instead of the+-- generic case that uses casts and pointer arithmetic+genStore addr@(CmmReg (CmmGlobal r)) val+    = genStore_fast addr r 0 val++genStore addr@(CmmRegOff (CmmGlobal r) n) val+    = genStore_fast addr r n val++genStore addr@(CmmMachOp (MO_Add _) [+                            (CmmReg (CmmGlobal r)),+                            (CmmLit (CmmInt n _))])+                val+    = genStore_fast addr r (fromInteger n) val++genStore addr@(CmmMachOp (MO_Sub _) [+                            (CmmReg (CmmGlobal r)),+                            (CmmLit (CmmInt n _))])+                val+    = genStore_fast addr r (negate $ fromInteger n) val++-- generic case+genStore addr val+    = getTBAAMeta topN >>= genStore_slow addr val++-- | CmmStore operation+-- This is a special case for storing to a global register pointer+-- offset such as I32[Sp+8].+genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr+              -> LlvmM StmtData+genStore_fast addr r n val+  = do dflags <- getDynFlags+       (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)+       meta          <- getTBAARegMeta r+       let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt  `div` 8)+       case isPointer grt && rem == 0 of+            True -> do+                (vval,  stmts, top) <- exprToVar val+                (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]+                -- We might need a different pointer type, so check+                case pLower grt == getVarType vval of+                     -- were fine+                     True  -> do+                         let s3 = MetaStmt meta $ Store vval ptr+                         return (stmts `appOL` s1 `snocOL` s2+                                 `snocOL` s3, top)++                     -- cast to pointer type needed+                     False -> do+                         let ty = (pLift . getVarType) vval+                         (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty+                         let s4 = MetaStmt meta $ Store vval ptr'+                         return (stmts `appOL` s1 `snocOL` s2+                                 `snocOL` s3 `snocOL` s4, top)++            -- If its a bit type then we use the slow method since+            -- we can't avoid casting anyway.+            False -> genStore_slow addr val meta+++-- | CmmStore operation+-- Generic case. Uses casts and pointer arithmetic if needed.+genStore_slow :: CmmExpr -> CmmExpr -> [MetaAnnot] -> LlvmM StmtData+genStore_slow addr val meta = do+    (vaddr, stmts1, top1) <- exprToVar addr+    (vval,  stmts2, top2) <- exprToVar val++    let stmts = stmts1 `appOL` stmts2+    dflags <- getDynFlags+    case getVarType vaddr of+        -- sometimes we need to cast an int to a pointer before storing+        LMPointer ty@(LMPointer _) | getVarType vval == llvmWord dflags -> do+            (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty+            let s2 = MetaStmt meta $ Store v vaddr+            return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)++        LMPointer _ -> do+            let s1 = MetaStmt meta $ Store vval vaddr+            return (stmts `snocOL` s1, top1 ++ top2)++        i@(LMInt _) | i == llvmWord dflags -> do+            let vty = pLift $ getVarType vval+            (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty+            let s2 = MetaStmt meta $ Store vval vptr+            return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)++        other ->+            pprPanic "genStore: ptr not right type!"+                    (PprCmm.pprExpr addr <+> text (+                        "Size of Ptr: " ++ show (llvmPtrBits dflags) +++                        ", Size of var: " ++ show (llvmWidthInBits dflags other) +++                        ", Var: " ++ showSDoc dflags (ppr vaddr)))+++-- | Unconditional branch+genBranch :: BlockId -> LlvmM StmtData+genBranch id =+    let label = blockIdToLlvm id+    in return (unitOL $ Branch label, [])+++-- | Conditional branch+genCondBranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> LlvmM StmtData+genCondBranch cond idT idF likely = do+    let labelT = blockIdToLlvm idT+    let labelF = blockIdToLlvm idF+    -- See Note [Literals and branch conditions].+    (vc, stmts1, top1) <- exprToVarOpt i1Option cond+    if getVarType vc == i1+        then do+            (vc', (stmts2, top2)) <- case likely of+              Just b -> genExpectLit (if b then 1 else 0) i1  vc+              _      -> pure (vc, (nilOL, []))+            let s1 = BranchIf vc' labelT labelF+            return (stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2)+        else do+            dflags <- getDynFlags+            panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppr vc) ++ ")"+++-- | Generate call to llvm.expect.x intrinsic. Assigning result to a new var.+genExpectLit :: Integer -> LlvmType -> LlvmVar -> LlvmM (LlvmVar, StmtData)+genExpectLit expLit expTy var = do+  dflags <- getDynFlags++  let+    lit = LMLitVar $ LMIntLit expLit expTy++    llvmExpectName+      | isInt expTy = fsLit $ "llvm.expect." ++ showSDoc dflags (ppr expTy)+      | otherwise   = panic $ "genExpectedLit: Type not an int!"++  (llvmExpect, stmts, top) <-+    getInstrinct llvmExpectName expTy [expTy, expTy]+  (var', call) <- doExpr expTy $ Call StdCall llvmExpect [var, lit] []+  return (var', (stmts `snocOL` call, top))++{- Note [Literals and branch conditions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++It is important that whenever we generate branch conditions for+literals like '1', they are properly narrowed to an LLVM expression of+type 'i1' (for bools.) Otherwise, nobody is happy. So when we convert+a CmmExpr to an LLVM expression for a branch conditional, exprToVarOpt+must be certain to return a properly narrowed type. genLit is+responsible for this, in the case of literal integers.++Often, we won't see direct statements like:++    if(1) {+      ...+    } else {+      ...+    }++at this point in the pipeline, because the Glorious Code Generator+will do trivial branch elimination in the sinking pass (among others,)+which will eliminate the expression entirely.++However, it's certainly possible and reasonable for this to occur in+hand-written C-- code. Consider something like:++    #ifndef SOME_CONDITIONAL+    #define CHECK_THING(x) 1+    #else+    #define CHECK_THING(x) some_operation((x))+    #endif++    f() {++      if (CHECK_THING(xyz)) {+        ...+      } else {+        ...+      }++    }++In such an instance, CHECK_THING might result in an *expression* in+one case, and a *literal* in the other, depending on what in+particular was #define'd. So we must be sure to properly narrow the+literal in this case to i1 as it won't be eliminated beforehand.++For a real example of this, see ./rts/StgStdThunks.cmm++-}++++-- | Switch branch+genSwitch :: CmmExpr -> SwitchTargets -> LlvmM StmtData+genSwitch cond ids = do+    (vc, stmts, top) <- exprToVar cond+    let ty = getVarType vc++    let labels = [ (mkIntLit ty ix, blockIdToLlvm b)+                 | (ix, b) <- switchTargetsCases ids ]+    -- out of range is undefined, so let's just branch to first label+    let defLbl | Just l <- switchTargetsDefault ids = blockIdToLlvm l+               | otherwise                          = snd (head labels)++    let s1 = Switch vc defLbl labels+    return $ (stmts `snocOL` s1, top)+++-- -----------------------------------------------------------------------------+-- * CmmExpr code generation+--++-- | An expression conversion return data:+--   * LlvmVar: The var holding the result of the expression+--   * LlvmStatements: Any statements needed to evaluate the expression+--   * LlvmCmmDecl: Any global data needed for this expression+type ExprData = (LlvmVar, LlvmStatements, [LlvmCmmDecl])++-- | Values which can be passed to 'exprToVar' to configure its+-- behaviour in certain circumstances.+--+-- Currently just used for determining if a comparison should return+-- a boolean (i1) or a word. See Note [Literals and branch conditions].+newtype EOption = EOption { i1Expected :: Bool }+-- XXX: EOption is an ugly and inefficient solution to this problem.++-- | i1 type expected (condition scrutinee).+i1Option :: EOption+i1Option = EOption True++-- | Word type expected (usual).+wordOption :: EOption+wordOption = EOption False++-- | Convert a CmmExpr to a list of LlvmStatements with the result of the+-- expression being stored in the returned LlvmVar.+exprToVar :: CmmExpr -> LlvmM ExprData+exprToVar = exprToVarOpt wordOption++exprToVarOpt :: EOption -> CmmExpr -> LlvmM ExprData+exprToVarOpt opt e = case e of++    CmmLit lit+        -> genLit opt lit++    CmmLoad e' ty+        -> genLoad False e' ty++    -- Cmmreg in expression is the value, so must load. If you want actual+    -- reg pointer, call getCmmReg directly.+    CmmReg r -> do+        (v1, ty, s1) <- getCmmRegVal r+        case isPointer ty of+             True  -> do+                 -- Cmm wants the value, so pointer types must be cast to ints+                 dflags <- getDynFlags+                 (v2, s2) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint v1 (llvmWord dflags)+                 return (v2, s1 `snocOL` s2, [])++             False -> return (v1, s1, [])++    CmmMachOp op exprs+        -> genMachOp opt op exprs++    CmmRegOff r i+        -> do dflags <- getDynFlags+              exprToVar $ expandCmmReg dflags (r, i)++    CmmStackSlot _ _+        -> panic "exprToVar: CmmStackSlot not supported!"+++-- | Handle CmmMachOp expressions+genMachOp :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData++-- Unary Machop+genMachOp _ op [x] = case op of++    MO_Not w ->+        let all1 = mkIntLit (widthToLlvmInt w) (-1)+        in negate (widthToLlvmInt w) all1 LM_MO_Xor++    MO_S_Neg w ->+        let all0 = mkIntLit (widthToLlvmInt w) 0+        in negate (widthToLlvmInt w) all0 LM_MO_Sub++    MO_F_Neg w ->+        let all0 = LMLitVar $ LMFloatLit (-0) (widthToLlvmFloat w)+        in negate (widthToLlvmFloat w) all0 LM_MO_FSub++    MO_SF_Conv _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp+    MO_FS_Conv _ w -> fiConv (widthToLlvmInt w) LM_Fptosi++    MO_SS_Conv from to+        -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Sext++    MO_UU_Conv from to+        -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext++    MO_FF_Conv from to+        -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext++    MO_VS_Neg len w ->+        let ty    = widthToLlvmInt w+            vecty = LMVector len ty+            all0  = LMIntLit (-0) ty+            all0s = LMLitVar $ LMVectorLit (replicate len all0)+        in negateVec vecty all0s LM_MO_Sub++    MO_VF_Neg len w ->+        let ty    = widthToLlvmFloat w+            vecty = LMVector len ty+            all0  = LMFloatLit (-0) ty+            all0s = LMLitVar $ LMVectorLit (replicate len all0)+        in negateVec vecty all0s LM_MO_FSub++    -- Handle unsupported cases explicitly so we get a warning+    -- of missing case when new MachOps added+    MO_Add _          -> panicOp+    MO_Mul _          -> panicOp+    MO_Sub _          -> panicOp+    MO_S_MulMayOflo _ -> panicOp+    MO_S_Quot _       -> panicOp+    MO_S_Rem _        -> panicOp+    MO_U_MulMayOflo _ -> panicOp+    MO_U_Quot _       -> panicOp+    MO_U_Rem _        -> panicOp++    MO_Eq  _          -> panicOp+    MO_Ne  _          -> panicOp+    MO_S_Ge _         -> panicOp+    MO_S_Gt _         -> panicOp+    MO_S_Le _         -> panicOp+    MO_S_Lt _         -> panicOp+    MO_U_Ge _         -> panicOp+    MO_U_Gt _         -> panicOp+    MO_U_Le _         -> panicOp+    MO_U_Lt _         -> panicOp++    MO_F_Add        _ -> panicOp+    MO_F_Sub        _ -> panicOp+    MO_F_Mul        _ -> panicOp+    MO_F_Quot       _ -> panicOp+    MO_F_Eq         _ -> panicOp+    MO_F_Ne         _ -> panicOp+    MO_F_Ge         _ -> panicOp+    MO_F_Gt         _ -> panicOp+    MO_F_Le         _ -> panicOp+    MO_F_Lt         _ -> panicOp++    MO_And          _ -> panicOp+    MO_Or           _ -> panicOp+    MO_Xor          _ -> panicOp+    MO_Shl          _ -> panicOp+    MO_U_Shr        _ -> panicOp+    MO_S_Shr        _ -> panicOp++    MO_V_Insert   _ _ -> panicOp+    MO_V_Extract  _ _ -> panicOp++    MO_V_Add      _ _ -> panicOp+    MO_V_Sub      _ _ -> panicOp+    MO_V_Mul      _ _ -> panicOp++    MO_VS_Quot    _ _ -> panicOp+    MO_VS_Rem     _ _ -> panicOp++    MO_VU_Quot    _ _ -> panicOp+    MO_VU_Rem     _ _ -> panicOp++    MO_VF_Insert  _ _ -> panicOp+    MO_VF_Extract _ _ -> panicOp++    MO_VF_Add     _ _ -> panicOp+    MO_VF_Sub     _ _ -> panicOp+    MO_VF_Mul     _ _ -> panicOp+    MO_VF_Quot    _ _ -> panicOp++    where+        negate ty v2 negOp = do+            (vx, stmts, top) <- exprToVar x+            (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx+            return (v1, stmts `snocOL` s1, top)++        negateVec ty v2 negOp = do+            (vx, stmts1, top) <- exprToVar x+            ([vx'], stmts2) <- castVars [(vx, ty)]+            (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx'+            return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top)++        fiConv ty convOp = do+            (vx, stmts, top) <- exprToVar x+            (v1, s1) <- doExpr ty $ Cast convOp vx ty+            return (v1, stmts `snocOL` s1, top)++        sameConv from ty reduce expand = do+            x'@(vx, stmts, top) <- exprToVar x+            let sameConv' op = do+                    (v1, s1) <- doExpr ty $ Cast op vx ty+                    return (v1, stmts `snocOL` s1, top)+            dflags <- getDynFlags+            let toWidth = llvmWidthInBits dflags ty+            -- LLVM doesn't like trying to convert to same width, so+            -- need to check for that as we do get Cmm code doing it.+            case widthInBits from  of+                 w | w < toWidth -> sameConv' expand+                 w | w > toWidth -> sameConv' reduce+                 _w              -> return x'++        panicOp = panic $ "LLVM.CodeGen.genMachOp: non unary op encountered"+                       ++ "with one argument! (" ++ show op ++ ")"++-- Handle GlobalRegs pointers+genMachOp opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]+    = genMachOp_fast opt o r (fromInteger n) e++genMachOp opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]+    = genMachOp_fast opt o r (negate . fromInteger $ n) e++-- Generic case+genMachOp opt op e = genMachOp_slow opt op e+++-- | Handle CmmMachOp expressions+-- This is a specialised method that handles Global register manipulations like+-- 'Sp - 16', using the getelementptr instruction.+genMachOp_fast :: EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr]+               -> LlvmM ExprData+genMachOp_fast opt op r n e+  = do (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)+       dflags <- getDynFlags+       let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt  `div` 8)+       case isPointer grt && rem == 0 of+            True -> do+                (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]+                (var, s3) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint ptr (llvmWord dflags)+                return (var, s1 `snocOL` s2 `snocOL` s3, [])++            False -> genMachOp_slow opt op e+++-- | Handle CmmMachOp expressions+-- This handles all the cases not handle by the specialised genMachOp_fast.+genMachOp_slow :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData++-- Element extraction+genMachOp_slow _ (MO_V_Extract l w) [val, idx] = runExprData $ do+    vval <- exprToVarW val+    vidx <- exprToVarW idx+    [vval'] <- castVarsW [(vval, LMVector l ty)]+    doExprW ty $ Extract vval' vidx+  where+    ty = widthToLlvmInt w++genMachOp_slow _ (MO_VF_Extract l w) [val, idx] = runExprData $ do+    vval <- exprToVarW val+    vidx <- exprToVarW idx+    [vval'] <- castVarsW [(vval, LMVector l ty)]+    doExprW ty $ Extract vval' vidx+  where+    ty = widthToLlvmFloat w++-- Element insertion+genMachOp_slow _ (MO_V_Insert l w) [val, elt, idx] = runExprData $ do+    vval <- exprToVarW val+    velt <- exprToVarW elt+    vidx <- exprToVarW idx+    [vval'] <- castVarsW [(vval, ty)]+    doExprW ty $ Insert vval' velt vidx+  where+    ty = LMVector l (widthToLlvmInt w)++genMachOp_slow _ (MO_VF_Insert l w) [val, elt, idx] = runExprData $ do+    vval <- exprToVarW val+    velt <- exprToVarW elt+    vidx <- exprToVarW idx+    [vval'] <- castVarsW [(vval, ty)]+    doExprW ty $ Insert vval' velt vidx+  where+    ty = LMVector l (widthToLlvmFloat w)++-- Binary MachOp+genMachOp_slow opt op [x, y] = case op of++    MO_Eq _   -> genBinComp opt LM_CMP_Eq+    MO_Ne _   -> genBinComp opt LM_CMP_Ne++    MO_S_Gt _ -> genBinComp opt LM_CMP_Sgt+    MO_S_Ge _ -> genBinComp opt LM_CMP_Sge+    MO_S_Lt _ -> genBinComp opt LM_CMP_Slt+    MO_S_Le _ -> genBinComp opt LM_CMP_Sle++    MO_U_Gt _ -> genBinComp opt LM_CMP_Ugt+    MO_U_Ge _ -> genBinComp opt LM_CMP_Uge+    MO_U_Lt _ -> genBinComp opt LM_CMP_Ult+    MO_U_Le _ -> genBinComp opt LM_CMP_Ule++    MO_Add _ -> genBinMach LM_MO_Add+    MO_Sub _ -> genBinMach LM_MO_Sub+    MO_Mul _ -> genBinMach LM_MO_Mul++    MO_U_MulMayOflo _ -> panic "genMachOp: MO_U_MulMayOflo unsupported!"++    MO_S_MulMayOflo w -> isSMulOK w x y++    MO_S_Quot _ -> genBinMach LM_MO_SDiv+    MO_S_Rem  _ -> genBinMach LM_MO_SRem++    MO_U_Quot _ -> genBinMach LM_MO_UDiv+    MO_U_Rem  _ -> genBinMach LM_MO_URem++    MO_F_Eq _ -> genBinComp opt LM_CMP_Feq+    MO_F_Ne _ -> genBinComp opt LM_CMP_Fne+    MO_F_Gt _ -> genBinComp opt LM_CMP_Fgt+    MO_F_Ge _ -> genBinComp opt LM_CMP_Fge+    MO_F_Lt _ -> genBinComp opt LM_CMP_Flt+    MO_F_Le _ -> genBinComp opt LM_CMP_Fle++    MO_F_Add  _ -> genBinMach LM_MO_FAdd+    MO_F_Sub  _ -> genBinMach LM_MO_FSub+    MO_F_Mul  _ -> genBinMach LM_MO_FMul+    MO_F_Quot _ -> genBinMach LM_MO_FDiv++    MO_And _   -> genBinMach LM_MO_And+    MO_Or  _   -> genBinMach LM_MO_Or+    MO_Xor _   -> genBinMach LM_MO_Xor+    MO_Shl _   -> genBinMach LM_MO_Shl+    MO_U_Shr _ -> genBinMach LM_MO_LShr+    MO_S_Shr _ -> genBinMach LM_MO_AShr++    MO_V_Add l w   -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Add+    MO_V_Sub l w   -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Sub+    MO_V_Mul l w   -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Mul++    MO_VS_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SDiv+    MO_VS_Rem  l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SRem++    MO_VU_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_UDiv+    MO_VU_Rem  l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_URem++    MO_VF_Add  l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FAdd+    MO_VF_Sub  l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FSub+    MO_VF_Mul  l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FMul+    MO_VF_Quot l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FDiv++    MO_Not _       -> panicOp+    MO_S_Neg _     -> panicOp+    MO_F_Neg _     -> panicOp++    MO_SF_Conv _ _ -> panicOp+    MO_FS_Conv _ _ -> panicOp+    MO_SS_Conv _ _ -> panicOp+    MO_UU_Conv _ _ -> panicOp+    MO_FF_Conv _ _ -> panicOp++    MO_V_Insert  {} -> panicOp+    MO_V_Extract {} -> panicOp++    MO_VS_Neg {} -> panicOp++    MO_VF_Insert  {} -> panicOp+    MO_VF_Extract {} -> panicOp++    MO_VF_Neg {} -> panicOp++    where+        binLlvmOp ty binOp = runExprData $ do+            vx <- exprToVarW x+            vy <- exprToVarW y+            if getVarType vx == getVarType vy+                then do+                    doExprW (ty vx) $ binOp vx vy++                else do+                    -- Error. Continue anyway so we can debug the generated ll file.+                    dflags <- getDynFlags+                    let style = mkCodeStyle CStyle+                        toString doc = renderWithStyle dflags doc style+                        cmmToStr = (lines . toString . PprCmm.pprExpr)+                    statement $ Comment $ map fsLit $ cmmToStr x+                    statement $ Comment $ map fsLit $ cmmToStr y+                    doExprW (ty vx) $ binOp vx vy++        binCastLlvmOp ty binOp = runExprData $ do+            vx <- exprToVarW x+            vy <- exprToVarW y+            [vx', vy'] <- castVarsW [(vx, ty), (vy, ty)]+            doExprW ty $ binOp vx' vy'++        -- | Need to use EOption here as Cmm expects word size results from+        -- comparisons while LLVM return i1. Need to extend to llvmWord type+        -- if expected. See Note [Literals and branch conditions].+        genBinComp opt cmp = do+            ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp)+            dflags <- getDynFlags+            if getVarType v1 == i1+                then case i1Expected opt of+                    True  -> return ed+                    False -> do+                        let w_ = llvmWord dflags+                        (v2, s1) <- doExpr w_ $ Cast LM_Zext v1 w_+                        return (v2, stmts `snocOL` s1, top)+                else+                    panic $ "genBinComp: Compare returned type other then i1! "+                        ++ (showSDoc dflags $ ppr $ getVarType v1)++        genBinMach op = binLlvmOp getVarType (LlvmOp op)++        genCastBinMach ty op = binCastLlvmOp ty (LlvmOp op)++        -- | Detect if overflow will occur in signed multiply of the two+        -- CmmExpr's. This is the LLVM assembly equivalent of the NCG+        -- implementation. Its much longer due to type information/safety.+        -- This should actually compile to only about 3 asm instructions.+        isSMulOK :: Width -> CmmExpr -> CmmExpr -> LlvmM ExprData+        isSMulOK _ x y = runExprData $ do+            vx <- exprToVarW x+            vy <- exprToVarW y++            dflags <- getDynFlags+            let word  = getVarType vx+            let word2 = LMInt $ 2 * (llvmWidthInBits dflags $ getVarType vx)+            let shift = llvmWidthInBits dflags word+            let shift1 = toIWord dflags (shift - 1)+            let shift2 = toIWord dflags shift++            if isInt word+                then do+                    x1     <- doExprW word2 $ Cast LM_Sext vx word2+                    y1     <- doExprW word2 $ Cast LM_Sext vy word2+                    r1     <- doExprW word2 $ LlvmOp LM_MO_Mul x1 y1+                    rlow1  <- doExprW word $ Cast LM_Trunc r1 word+                    rlow2  <- doExprW word $ LlvmOp LM_MO_AShr rlow1 shift1+                    rhigh1 <- doExprW word2 $ LlvmOp LM_MO_AShr r1 shift2+                    rhigh2 <- doExprW word $ Cast LM_Trunc rhigh1 word+                    doExprW word $ LlvmOp LM_MO_Sub rlow2 rhigh2++                else+                    panic $ "isSMulOK: Not bit type! (" ++ showSDoc dflags (ppr word) ++ ")"++        panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encountered"+                       ++ "with two arguments! (" ++ show op ++ ")"++-- More then two expression, invalid!+genMachOp_slow _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!"+++-- | Handle CmmLoad expression.+genLoad :: Atomic -> CmmExpr -> CmmType -> LlvmM ExprData++-- First we try to detect a few common cases and produce better code for+-- these then the default case. We are mostly trying to detect Cmm code+-- like I32[Sp + n] and use 'getelementptr' operations instead of the+-- generic case that uses casts and pointer arithmetic+genLoad atomic e@(CmmReg (CmmGlobal r)) ty+    = genLoad_fast atomic e r 0 ty++genLoad atomic e@(CmmRegOff (CmmGlobal r) n) ty+    = genLoad_fast atomic e r n ty++genLoad atomic e@(CmmMachOp (MO_Add _) [+                            (CmmReg (CmmGlobal r)),+                            (CmmLit (CmmInt n _))])+                ty+    = genLoad_fast atomic e r (fromInteger n) ty++genLoad atomic e@(CmmMachOp (MO_Sub _) [+                            (CmmReg (CmmGlobal r)),+                            (CmmLit (CmmInt n _))])+                ty+    = genLoad_fast atomic e r (negate $ fromInteger n) ty++-- generic case+genLoad atomic e ty+    = getTBAAMeta topN >>= genLoad_slow atomic e ty++-- | Handle CmmLoad expression.+-- This is a special case for loading from a global register pointer+-- offset such as I32[Sp+8].+genLoad_fast :: Atomic -> CmmExpr -> GlobalReg -> Int -> CmmType+             -> LlvmM ExprData+genLoad_fast atomic e r n ty = do+    dflags <- getDynFlags+    (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)+    meta          <- getTBAARegMeta r+    let ty'      = cmmToLlvmType ty+        (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt  `div` 8)+    case isPointer grt && rem == 0 of+            True  -> do+                (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]+                -- We might need a different pointer type, so check+                case grt == ty' of+                     -- were fine+                     True -> do+                         (var, s3) <- doExpr ty' (MExpr meta $ loadInstr ptr)+                         return (var, s1 `snocOL` s2 `snocOL` s3,+                                     [])++                     -- cast to pointer type needed+                     False -> do+                         let pty = pLift ty'+                         (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty+                         (var, s4) <- doExpr ty' (MExpr meta $ loadInstr ptr')+                         return (var, s1 `snocOL` s2 `snocOL` s3+                                    `snocOL` s4, [])++            -- If its a bit type then we use the slow method since+            -- we can't avoid casting anyway.+            False -> genLoad_slow atomic  e ty meta+  where+    loadInstr ptr | atomic    = ALoad SyncSeqCst False ptr+                  | otherwise = Load ptr++-- | Handle Cmm load expression.+-- Generic case. Uses casts and pointer arithmetic if needed.+genLoad_slow :: Atomic -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData+genLoad_slow atomic e ty meta = runExprData $ do+    iptr <- exprToVarW e+    dflags <- getDynFlags+    case getVarType iptr of+         LMPointer _ -> do+                    doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr iptr)++         i@(LMInt _) | i == llvmWord dflags -> do+                    let pty = LMPointer $ cmmToLlvmType ty+                    ptr <- doExprW pty $ Cast LM_Inttoptr iptr pty+                    doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr ptr)++         other -> do pprPanic "exprToVar: CmmLoad expression is not right type!"+                        (PprCmm.pprExpr e <+> text (+                            "Size of Ptr: " ++ show (llvmPtrBits dflags) +++                            ", Size of var: " ++ show (llvmWidthInBits dflags other) +++                            ", Var: " ++ showSDoc dflags (ppr iptr)))+  where+    loadInstr ptr | atomic    = ALoad SyncSeqCst False ptr+                  | otherwise = Load ptr+++-- | Handle CmmReg expression. This will return a pointer to the stack+-- location of the register. Throws an error if it isn't allocated on+-- the stack.+getCmmReg :: CmmReg -> LlvmM LlvmVar+getCmmReg (CmmLocal (LocalReg un _))+  = do exists <- varLookup un+       dflags <- getDynFlags+       case exists of+         Just ety -> return (LMLocalVar un $ pLift ety)+         Nothing  -> fail $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr un) ++ " was not allocated!"+           -- This should never happen, as every local variable should+           -- have been assigned a value at some point, triggering+           -- "funPrologue" to allocate it on the stack.++getCmmReg (CmmGlobal g)+  = do onStack <- checkStackReg g+       dflags <- getDynFlags+       if onStack+         then return (lmGlobalRegVar dflags g)+         else fail $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr g) ++ " not stack-allocated!"++-- | Return the value of a given register, as well as its type. Might+-- need to be load from stack.+getCmmRegVal :: CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements)+getCmmRegVal reg =+  case reg of+    CmmGlobal g -> do+      onStack <- checkStackReg g+      dflags <- getDynFlags+      if onStack then loadFromStack else do+        let r = lmGlobalRegArg dflags g+        return (r, getVarType r, nilOL)+    _ -> loadFromStack+ where loadFromStack = do+         ptr <- getCmmReg reg+         let ty = pLower $ getVarType ptr+         (v, s) <- doExpr ty (Load ptr)+         return (v, ty, unitOL s)++-- | Allocate a local CmmReg on the stack+allocReg :: CmmReg -> (LlvmVar, LlvmStatements)+allocReg (CmmLocal (LocalReg un ty))+  = let ty' = cmmToLlvmType ty+        var = LMLocalVar un (LMPointer ty')+        alc = Alloca ty' 1+    in (var, unitOL $ Assignment var alc)++allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should"+                    ++ " have been handled elsewhere!"+++-- | Generate code for a literal+genLit :: EOption -> CmmLit -> LlvmM ExprData+genLit opt (CmmInt i w)+  -- See Note [Literals and branch conditions].+  = let width | i1Expected opt = i1+              | otherwise      = LMInt (widthInBits w)+        -- comm  = Comment [ fsLit $ "EOption: " ++ show opt+        --                 , fsLit $ "Width  : " ++ show w+        --                 , fsLit $ "Width' : " ++ show (widthInBits w)+        --                 ]+    in return (mkIntLit width i, nilOL, [])++genLit _ (CmmFloat r w)+  = return (LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w),+              nilOL, [])++genLit opt (CmmVec ls)+  = do llvmLits <- mapM toLlvmLit ls+       return (LMLitVar $ LMVectorLit llvmLits, nilOL, [])+  where+    toLlvmLit :: CmmLit -> LlvmM LlvmLit+    toLlvmLit lit = do+        (llvmLitVar, _, _) <- genLit opt lit+        case llvmLitVar of+          LMLitVar llvmLit -> return llvmLit+          _ -> panic "genLit"++genLit _ cmm@(CmmLabel l)+  = do var <- getGlobalPtr =<< strCLabel_llvm l+       dflags <- getDynFlags+       let lmty = cmmToLlvmType $ cmmLitType dflags cmm+       (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags)+       return (v1, unitOL s1, [])++genLit opt (CmmLabelOff label off) = do+    dflags <- getDynFlags+    (vlbl, stmts, stat) <- genLit opt (CmmLabel label)+    let voff = toIWord dflags off+    (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff+    return (v1, stmts `snocOL` s1, stat)++genLit opt (CmmLabelDiffOff l1 l2 off) = do+    dflags <- getDynFlags+    (vl1, stmts1, stat1) <- genLit opt (CmmLabel l1)+    (vl2, stmts2, stat2) <- genLit opt (CmmLabel l2)+    let voff = toIWord dflags off+    let ty1 = getVarType vl1+    let ty2 = getVarType vl2+    if (isInt ty1) && (isInt ty2)+       && (llvmWidthInBits dflags ty1 == llvmWidthInBits dflags ty2)++       then do+            (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2+            (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff+            return (v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2,+                        stat1 ++ stat2)++        else+            panic "genLit: CmmLabelDiffOff encountered with different label ty!"++genLit opt (CmmBlock b)+  = genLit opt (CmmLabel $ infoTblLbl b)++genLit _ CmmHighStackMark+  = panic "genStaticLit - CmmHighStackMark unsupported!"+++-- -----------------------------------------------------------------------------+-- * Misc+--++-- | Find CmmRegs that get assigned and allocate them on the stack+--+-- Any register that gets written needs to be allcoated on the+-- stack. This avoids having to map a CmmReg to an equivalent SSA form+-- and avoids having to deal with Phi node insertion.  This is also+-- the approach recommended by LLVM developers.+--+-- On the other hand, this is unnecessarily verbose if the register in+-- question is never written. Therefore we skip it where we can to+-- save a few lines in the output and hopefully speed compilation up a+-- bit.+funPrologue :: LiveGlobalRegs -> [CmmBlock] -> LlvmM StmtData+funPrologue live cmmBlocks = do++  trash <- getTrashRegs+  let getAssignedRegs :: CmmNode O O -> [CmmReg]+      getAssignedRegs (CmmAssign reg _)  = [reg]+      -- Calls will trash all registers. Unfortunately, this needs them to+      -- be stack-allocated in the first place.+      getAssignedRegs (CmmUnsafeForeignCall _ rs _) = map CmmGlobal trash ++ map CmmLocal rs+      getAssignedRegs _                  = []+      getRegsBlock (_, body, _)          = concatMap getAssignedRegs $ blockToList body+      assignedRegs = nub $ concatMap (getRegsBlock . blockSplit) cmmBlocks+      isLive r     = r `elem` alwaysLive || r `elem` live++  dflags <- getDynFlags+  stmtss <- flip mapM assignedRegs $ \reg ->+    case reg of+      CmmLocal (LocalReg un _) -> do+        let (newv, stmts) = allocReg reg+        varInsert un (pLower $ getVarType newv)+        return stmts+      CmmGlobal r -> do+        let reg   = lmGlobalRegVar dflags r+            arg   = lmGlobalRegArg dflags r+            ty    = (pLower . getVarType) reg+            trash = LMLitVar $ LMUndefLit ty+            rval  = if isLive r then arg else trash+            alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1+        markStackReg r+        return $ toOL [alloc, Store rval reg]++  return (concatOL stmtss, [])++-- | Function epilogue. Load STG variables to use as argument for call.+-- STG Liveness optimisation done here.+funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements)+funEpilogue live = do++    -- Have information and liveness optimisation is enabled?+    let liveRegs = alwaysLive ++ live+        isSSE (FloatReg _)  = True+        isSSE (DoubleReg _) = True+        isSSE (XmmReg _)    = True+        isSSE (YmmReg _)    = True+        isSSE (ZmmReg _)    = True+        isSSE _             = False++    -- Set to value or "undef" depending on whether the register is+    -- actually live+    dflags <- getDynFlags+    let loadExpr r = do+          (v, _, s) <- getCmmRegVal (CmmGlobal r)+          return (Just $ v, s)+        loadUndef r = do+          let ty = (pLower . getVarType $ lmGlobalRegVar dflags r)+          return (Just $ LMLitVar $ LMUndefLit ty, nilOL)+    platform <- getDynFlag targetPlatform+    loads <- flip mapM (activeStgRegs platform) $ \r -> case () of+      _ | r `elem` liveRegs  -> loadExpr r+        | not (isSSE r)      -> loadUndef r+        | otherwise          -> return (Nothing, nilOL)++    let (vars, stmts) = unzip loads+    return (catMaybes vars, concatOL stmts)+++-- | A series of statements to trash all the STG registers.+--+-- In LLVM we pass the STG registers around everywhere in function calls.+-- So this means LLVM considers them live across the entire function, when+-- in reality they usually aren't. For Caller save registers across C calls+-- the saving and restoring of them is done by the Cmm code generator,+-- using Cmm local vars. So to stop LLVM saving them as well (and saving+-- all of them since it thinks they're always live, we trash them just+-- before the call by assigning the 'undef' value to them. The ones we+-- need are restored from the Cmm local var and the ones we don't need+-- are fine to be trashed.+getTrashStmts :: LlvmM LlvmStatements+getTrashStmts = do+  regs <- getTrashRegs+  stmts <- flip mapM regs $ \ r -> do+    reg <- getCmmReg (CmmGlobal r)+    let ty = (pLower . getVarType) reg+    return $ Store (LMLitVar $ LMUndefLit ty) reg+  return $ toOL stmts++getTrashRegs :: LlvmM [GlobalReg]+getTrashRegs = do plat <- getLlvmPlatform+                  return $ filter (callerSaves plat) (activeStgRegs plat)++-- | Get a function pointer to the CLabel specified.+--+-- This is for Haskell functions, function type is assumed, so doesn't work+-- with foreign functions.+getHsFunc :: LiveGlobalRegs -> CLabel -> LlvmM ExprData+getHsFunc live lbl+  = do fty <- llvmFunTy live+       name <- strCLabel_llvm lbl+       getHsFunc' name fty++getHsFunc' :: LMString -> LlvmType -> LlvmM ExprData+getHsFunc' name fty+  = do fun <- getGlobalPtr name+       if getVarType fun == fty+         then return (fun, nilOL, [])+         else do (v1, s1) <- doExpr (pLift fty)+                               $ Cast LM_Bitcast fun (pLift fty)+                 return  (v1, unitOL s1, [])++-- | Create a new local var+mkLocalVar :: LlvmType -> LlvmM LlvmVar+mkLocalVar ty = do+    un <- getUniqueM+    return $ LMLocalVar un ty+++-- | Execute an expression, assigning result to a var+doExpr :: LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)+doExpr ty expr = do+    v <- mkLocalVar ty+    return (v, Assignment v expr)+++-- | Expand CmmRegOff+expandCmmReg :: DynFlags -> (CmmReg, Int) -> CmmExpr+expandCmmReg dflags (reg, off)+  = let width = typeWidth (cmmRegType dflags reg)+        voff  = CmmLit $ CmmInt (fromIntegral off) width+    in CmmMachOp (MO_Add width) [CmmReg reg, voff]+++-- | Convert a block id into a appropriate Llvm label+blockIdToLlvm :: BlockId -> LlvmVar+blockIdToLlvm bid = LMLocalVar (getUnique bid) LMLabel++-- | Create Llvm int Literal+mkIntLit :: Integral a => LlvmType -> a -> LlvmVar+mkIntLit ty i = LMLitVar $ LMIntLit (toInteger i) ty++-- | Convert int type to a LLvmVar of word or i32 size+toI32 :: Integral a => a -> LlvmVar+toI32 = mkIntLit i32++toIWord :: Integral a => DynFlags -> a -> LlvmVar+toIWord dflags = mkIntLit (llvmWord dflags)+++-- | Error functions+panic :: String -> a+panic s = Outputable.panic $ "LlvmCodeGen.CodeGen." ++ s++pprPanic :: String -> SDoc -> a+pprPanic s d = Outputable.pprPanic ("LlvmCodeGen.CodeGen." ++ s) d+++-- | Returns TBAA meta data by unique+getTBAAMeta :: Unique -> LlvmM [MetaAnnot]+getTBAAMeta u = do+    mi <- getUniqMeta u+    return [MetaAnnot tbaa (MetaNode i) | let Just i = mi]++-- | Returns TBAA meta data for given register+getTBAARegMeta :: GlobalReg -> LlvmM [MetaAnnot]+getTBAARegMeta = getTBAAMeta . getTBAA+++-- | A more convenient way of accumulating LLVM statements and declarations.+data LlvmAccum = LlvmAccum LlvmStatements [LlvmCmmDecl]++#if __GLASGOW_HASKELL__ > 710+instance Semigroup LlvmAccum where+  LlvmAccum stmtsA declsA <> LlvmAccum stmtsB declsB =+        LlvmAccum (stmtsA Semigroup.<> stmtsB) (declsA Semigroup.<> declsB)+#endif++instance Monoid LlvmAccum where+    mempty = LlvmAccum nilOL []+    LlvmAccum stmtsA declsA `mappend` LlvmAccum stmtsB declsB =+        LlvmAccum (stmtsA `mappend` stmtsB) (declsA `mappend` declsB)++liftExprData :: LlvmM ExprData -> WriterT LlvmAccum LlvmM LlvmVar+liftExprData action = do+    (var, stmts, decls) <- lift action+    tell $ LlvmAccum stmts decls+    return var++statement :: LlvmStatement -> WriterT LlvmAccum LlvmM ()+statement stmt = tell $ LlvmAccum (unitOL stmt) []++doExprW :: LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar+doExprW a b = do+    (var, stmt) <- lift $ doExpr a b+    statement stmt+    return var++exprToVarW :: CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar+exprToVarW = liftExprData . exprToVar++runExprData :: WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData+runExprData action = do+    (var, LlvmAccum stmts decls) <- runWriterT action+    return (var, stmts, decls)++runStmtsDecls :: WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl])+runStmtsDecls action = do+    LlvmAccum stmts decls <- execWriterT action+    return (stmts, decls)++getCmmRegW :: CmmReg -> WriterT LlvmAccum LlvmM LlvmVar+getCmmRegW = lift . getCmmReg++genLoadW :: Atomic -> CmmExpr -> CmmType -> WriterT LlvmAccum LlvmM LlvmVar+genLoadW atomic e ty = liftExprData $ genLoad atomic e ty++doTrashStmts :: WriterT LlvmAccum LlvmM ()+doTrashStmts = do+    stmts <- lift getTrashStmts+    tell $ LlvmAccum stmts mempty
+ llvmGen/LlvmCodeGen/Data.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE CPP #-}+-- ----------------------------------------------------------------------------+-- | Handle conversion of CmmData to LLVM code.+--++module LlvmCodeGen.Data (+        genLlvmData, genData+    ) where++#include "HsVersions.h"++import Llvm+import LlvmCodeGen.Base++import BlockId+import CLabel+import Cmm+import DynFlags+import Platform++import FastString+import Outputable++-- ----------------------------------------------------------------------------+-- * Constants+--++-- | The string appended to a variable name to create its structure type alias+structStr :: LMString+structStr = fsLit "_struct"++-- ----------------------------------------------------------------------------+-- * Top level+--++-- | Pass a CmmStatic section to an equivalent Llvm code.+genLlvmData :: (Section, CmmStatics) -> LlvmM LlvmData+genLlvmData (sec, Statics lbl xs) = do+    label <- strCLabel_llvm lbl+    static <- mapM genData xs+    lmsec <- llvmSection sec+    let types   = map getStatType static++        strucTy = LMStruct types+        tyAlias = LMAlias ((label `appendFS` structStr), strucTy)++        struct         = Just $ LMStaticStruc static tyAlias+        link           = if (externallyVisibleCLabel lbl)+                            then ExternallyVisible else Internal+        align          = case sec of+                            Section CString _ -> Just 1+                            _                 -> Nothing+        const          = if isSecConstant sec then Constant else Global+        varDef         = LMGlobalVar label tyAlias link lmsec align const+        globDef        = LMGlobal varDef struct++    return ([globDef], [tyAlias])++-- | Should a data in this section be considered constant+isSecConstant :: Section -> Bool+isSecConstant (Section t _) = case t of+    Text                    -> True+    ReadOnlyData            -> True+    RelocatableReadOnlyData -> True+    ReadOnlyData16          -> True+    CString                 -> True+    Data                    -> False+    UninitialisedData       -> False+    (OtherSection _)        -> False++-- | Format the section type part of a Cmm Section+llvmSectionType :: Platform -> SectionType -> FastString+llvmSectionType p t = case t of+    Text                    -> fsLit ".text"+    ReadOnlyData            -> fsLit ".rodata"+    RelocatableReadOnlyData -> fsLit ".data.rel.ro"+    ReadOnlyData16          -> fsLit ".rodata.cst16"+    Data                    -> fsLit ".data"+    UninitialisedData       -> fsLit ".bss"+    CString                 -> case platformOS p of+                                 OSMinGW32 -> fsLit ".rdata"+                                 _         -> fsLit ".rodata.str"+    (OtherSection _)        -> panic "llvmSectionType: unknown section type"++-- | Format a Cmm Section into a LLVM section name+llvmSection :: Section -> LlvmM LMSection+llvmSection (Section t suffix) = do+  dflags <- getDynFlags+  let splitSect = gopt Opt_SplitSections dflags+      platform  = targetPlatform dflags+  if not splitSect+  then return Nothing+  else do+    lmsuffix <- strCLabel_llvm suffix+    return (Just (concatFS [llvmSectionType platform t, fsLit ".", lmsuffix]))++-- ----------------------------------------------------------------------------+-- * Generate static data+--++-- | Handle static data+genData :: CmmStatic -> LlvmM LlvmStatic++genData (CmmString str) = do+    let v  = map (\x -> LMStaticLit $ LMIntLit (fromIntegral x) i8) str+        ve = v ++ [LMStaticLit $ LMIntLit 0 i8]+    return $ LMStaticArray ve (LMArray (length ve) i8)++genData (CmmUninitialised bytes)+    = return $ LMUninitType (LMArray bytes i8)++genData (CmmStaticLit lit)+    = genStaticLit lit++-- | Generate Llvm code for a static literal.+--+-- Will either generate the code or leave it unresolved if it is a 'CLabel'+-- which isn't yet known.+genStaticLit :: CmmLit -> LlvmM LlvmStatic+genStaticLit (CmmInt i w)+    = return $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w))++genStaticLit (CmmFloat r w)+    = return $ LMStaticLit (LMFloatLit (fromRational r) (widthToLlvmFloat w))++genStaticLit (CmmVec ls)+    = do sls <- mapM toLlvmLit ls+         return $ LMStaticLit (LMVectorLit sls)+  where+    toLlvmLit :: CmmLit -> LlvmM LlvmLit+    toLlvmLit lit = do+      slit <- genStaticLit lit+      case slit of+        LMStaticLit llvmLit -> return llvmLit+        _ -> panic "genStaticLit"++-- Leave unresolved, will fix later+genStaticLit cmm@(CmmLabel l) = do+    var <- getGlobalPtr =<< strCLabel_llvm l+    dflags <- getDynFlags+    let ptr = LMStaticPointer var+        lmty = cmmToLlvmType $ cmmLitType dflags cmm+    return $ LMPtoI ptr lmty++genStaticLit (CmmLabelOff label off) = do+    dflags <- getDynFlags+    var <- genStaticLit (CmmLabel label)+    let offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags)+    return $ LMAdd var offset++genStaticLit (CmmLabelDiffOff l1 l2 off) = do+    dflags <- getDynFlags+    var1 <- genStaticLit (CmmLabel l1)+    var2 <- genStaticLit (CmmLabel l2)+    let var = LMSub var1 var2+        offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags)+    return $ LMAdd var offset++genStaticLit (CmmBlock b) = genStaticLit $ CmmLabel $ infoTblLbl b++genStaticLit (CmmHighStackMark)+    = panic "genStaticLit: CmmHighStackMark unsupported!"
+ llvmGen/LlvmCodeGen/Ppr.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE CPP #-}++-- ----------------------------------------------------------------------------+-- | Pretty print helpers for the LLVM Code generator.+--+module LlvmCodeGen.Ppr (+        pprLlvmHeader, pprLlvmCmmDecl, pprLlvmData, infoSection+    ) where++#include "HsVersions.h"++import Llvm+import LlvmCodeGen.Base+import LlvmCodeGen.Data++import CLabel+import Cmm+import Platform++import FastString+import Outputable+import Unique+++-- ----------------------------------------------------------------------------+-- * Top level+--++-- | Header code for LLVM modules+pprLlvmHeader :: SDoc+pprLlvmHeader = moduleLayout+++-- | LLVM module layout description for the host target+moduleLayout :: SDoc+moduleLayout = sdocWithPlatform $ \platform ->+    case platform of+    Platform { platformArch = ArchX86, platformOS = OSDarwin } ->+        text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:32:64-f32:32:32-f64:32:64-v64:64:64-v128:128:128-a0:0:64-f80:128:128-n8:16:32\""+        $+$ text "target triple = \"i386-apple-darwin9.8\""+    Platform { platformArch = ArchX86, platformOS = OSMinGW32 } ->+        text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-f80:128:128-v64:64:64-v128:128:128-a0:0:64-f80:32:32-n8:16:32\""+        $+$ text "target triple = \"i686-pc-win32\""+    Platform { platformArch = ArchX86, platformOS = OSLinux } ->+        text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:32:64-f32:32:32-f64:32:64-v64:64:64-v128:128:128-a0:0:64-f80:32:32-n8:16:32\""+        $+$ text "target triple = \"i386-pc-linux-gnu\""+    Platform { platformArch = ArchX86_64, platformOS = OSDarwin } ->+        text "target datalayout = \"e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64\""+        $+$ text "target triple = \"x86_64-apple-darwin10.0.0\""+    Platform { platformArch = ArchX86_64, platformOS = OSLinux } ->+        text "target datalayout = \"e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64\""+        $+$ text "target triple = \"x86_64-linux-gnu\""+    Platform { platformArch = ArchARM {}, platformOS = OSLinux } ->+        text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\""+        $+$ text "target triple = \"armv6-unknown-linux-gnueabihf\""+    Platform { platformArch = ArchARM {}, platformOS = OSAndroid } ->+        text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\""+        $+$ text "target triple = \"arm-unknown-linux-androideabi\""+    Platform { platformArch = ArchARM {}, platformOS = OSQNXNTO } ->+        text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\""+        $+$ text "target triple = \"arm-unknown-nto-qnx8.0.0eabi\""+    Platform { platformArch = ArchARM {}, platformOS = OSiOS } ->+        text "target datalayout = \"e-m:o-p:32:32-f64:32:64-v64:32:64-v128:32:128-a:0:32-n32-S32\""+        $+$ text "target triple = \"thumbv7-apple-ios7.0.0\""+    Platform { platformArch = ArchARM64, platformOS = OSiOS } ->+        text "target datalayout = \"e-m:o-i64:64-i128:128-n32:64-S128\""+        $+$ text "target triple = \"arm64-apple-ios7.0.0\""+    Platform { platformArch = ArchX86, platformOS = OSiOS } ->+        text "target datalayout = \"e-m:o-p:32:32-f64:32:64-f80:128-n8:16:32-S128\""+        $+$ text "target triple = \"i386-apple-ios7.0.0\""+    Platform { platformArch = ArchX86_64, platformOS = OSiOS } ->+        text "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\""+        $+$ text "target triple = \"x86_64-apple-ios7.0.0\""+    Platform { platformArch = ArchARM64, platformOS = OSLinux } ->+        text "target datalayout = \"e-m:e-i64:64-i128:128-n32:64-S128\""+        $+$ text "target triple = \"aarch64-unknown-linux-gnu\""+    _ ->+        if platformIsCrossCompiling platform+            then panic "LlvmCodeGen.Ppr: Cross compiling without valid target info."+            else empty+        -- If you see the above panic, GHC is missing the required target datalayout+        -- and triple information. You can obtain this info by compiling a simple+        -- 'hello world' C program with the clang C compiler eg:+        --     clang -S hello.c -emit-llvm -o -+        -- and the first two lines of hello.ll should provide the 'target datalayout'+        -- and 'target triple' lines required.+++-- | Pretty print LLVM data code+pprLlvmData :: LlvmData -> SDoc+pprLlvmData (globals, types) =+    let ppLlvmTys (LMAlias    a) = ppLlvmAlias a+        ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f+        ppLlvmTys _other         = empty++        types'   = vcat $ map ppLlvmTys types+        globals' = ppLlvmGlobals globals+    in types' $+$ globals'+++-- | Pretty print LLVM code+pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar])+pprLlvmCmmDecl (CmmData _ lmdata)+  = return (vcat $ map pprLlvmData lmdata, [])++pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))+  = do let lbl = case mb_info of+                     Nothing                   -> entry_lbl+                     Just (Statics info_lbl _) -> info_lbl+           link = if externallyVisibleCLabel lbl+                      then ExternallyVisible+                      else Internal+           lmblocks = map (\(BasicBlock id stmts) ->+                                LlvmBlock (getUnique id) stmts) blks++       funDec <- llvmFunSig live lbl link+       dflags <- getDynFlags+       let buildArg = fsLit . showSDoc dflags . ppPlainName+           funArgs = map buildArg (llvmFunArgs dflags live)+           funSect = llvmFunSection dflags (decName funDec)++       -- generate the info table+       prefix <- case mb_info of+                     Nothing -> return Nothing+                     Just (Statics _ statics) -> do+                       infoStatics <- mapM genData statics+                       let infoTy = LMStruct $ map getStatType infoStatics+                       return $ Just $ LMStaticStruc infoStatics infoTy+++       let fun = LlvmFunction funDec funArgs llvmStdFunAttrs funSect+                              prefix lmblocks+           name = decName $ funcDecl fun+           defName = name `appendFS` fsLit "$def"+           funcDecl' = (funcDecl fun) { decName = defName }+           fun' = fun { funcDecl = funcDecl' }+           funTy = LMFunction funcDecl'+           funVar = LMGlobalVar name+                                (LMPointer funTy)+                                link+                                Nothing+                                Nothing+                                Alias+           defVar = LMGlobalVar defName+                                (LMPointer funTy)+                                (funcLinkage funcDecl')+                                (funcSect fun)+                                (funcAlign funcDecl')+                                Alias+           alias = LMGlobal funVar+                            (Just $ LMBitc (LMStaticPointer defVar)+                                           (LMPointer $ LMInt 8))++       return (ppLlvmGlobal alias $+$ ppLlvmFunction fun', [])+++-- | The section we are putting info tables and their entry code into, should+-- be unique since we process the assembly pattern matching this.+infoSection :: String+infoSection = "X98A__STRIP,__me"
+ llvmGen/LlvmCodeGen/Regs.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE CPP #-}++--------------------------------------------------------------------------------+-- | Deal with Cmm registers+--++module LlvmCodeGen.Regs (+        lmGlobalRegArg, lmGlobalRegVar, alwaysLive,+        stgTBAA, baseN, stackN, heapN, rxN, topN, tbaa, getTBAA+    ) where++#include "HsVersions.h"++import Llvm++import CmmExpr+import DynFlags+import FastString+import Outputable ( panic )+import Unique++-- | Get the LlvmVar function variable storing the real register+lmGlobalRegVar :: DynFlags -> GlobalReg -> LlvmVar+lmGlobalRegVar dflags = pVarLift . lmGlobalReg dflags "_Var"++-- | Get the LlvmVar function argument storing the real register+lmGlobalRegArg :: DynFlags -> GlobalReg -> LlvmVar+lmGlobalRegArg dflags = lmGlobalReg dflags "_Arg"++{- Need to make sure the names here can't conflict with the unique generated+   names. Uniques generated names containing only base62 chars. So using say+   the '_' char guarantees this.+-}+lmGlobalReg :: DynFlags -> String -> GlobalReg -> LlvmVar+lmGlobalReg dflags suf reg+  = case reg of+        BaseReg        -> ptrGlobal $ "Base" ++ suf+        Sp             -> ptrGlobal $ "Sp" ++ suf+        Hp             -> ptrGlobal $ "Hp" ++ suf+        VanillaReg 1 _ -> wordGlobal $ "R1" ++ suf+        VanillaReg 2 _ -> wordGlobal $ "R2" ++ suf+        VanillaReg 3 _ -> wordGlobal $ "R3" ++ suf+        VanillaReg 4 _ -> wordGlobal $ "R4" ++ suf+        VanillaReg 5 _ -> wordGlobal $ "R5" ++ suf+        VanillaReg 6 _ -> wordGlobal $ "R6" ++ suf+        VanillaReg 7 _ -> wordGlobal $ "R7" ++ suf+        VanillaReg 8 _ -> wordGlobal $ "R8" ++ suf+        SpLim          -> wordGlobal $ "SpLim" ++ suf+        FloatReg 1     -> floatGlobal $"F1" ++ suf+        FloatReg 2     -> floatGlobal $"F2" ++ suf+        FloatReg 3     -> floatGlobal $"F3" ++ suf+        FloatReg 4     -> floatGlobal $"F4" ++ suf+        FloatReg 5     -> floatGlobal $"F5" ++ suf+        FloatReg 6     -> floatGlobal $"F6" ++ suf+        DoubleReg 1    -> doubleGlobal $ "D1" ++ suf+        DoubleReg 2    -> doubleGlobal $ "D2" ++ suf+        DoubleReg 3    -> doubleGlobal $ "D3" ++ suf+        DoubleReg 4    -> doubleGlobal $ "D4" ++ suf+        DoubleReg 5    -> doubleGlobal $ "D5" ++ suf+        DoubleReg 6    -> doubleGlobal $ "D6" ++ suf+        XmmReg 1       -> xmmGlobal $ "XMM1" ++ suf+        XmmReg 2       -> xmmGlobal $ "XMM2" ++ suf+        XmmReg 3       -> xmmGlobal $ "XMM3" ++ suf+        XmmReg 4       -> xmmGlobal $ "XMM4" ++ suf+        XmmReg 5       -> xmmGlobal $ "XMM5" ++ suf+        XmmReg 6       -> xmmGlobal $ "XMM6" ++ suf+        YmmReg 1       -> ymmGlobal $ "YMM1" ++ suf+        YmmReg 2       -> ymmGlobal $ "YMM2" ++ suf+        YmmReg 3       -> ymmGlobal $ "YMM3" ++ suf+        YmmReg 4       -> ymmGlobal $ "YMM4" ++ suf+        YmmReg 5       -> ymmGlobal $ "YMM5" ++ suf+        YmmReg 6       -> ymmGlobal $ "YMM6" ++ suf+        ZmmReg 1       -> zmmGlobal $ "ZMM1" ++ suf+        ZmmReg 2       -> zmmGlobal $ "ZMM2" ++ suf+        ZmmReg 3       -> zmmGlobal $ "ZMM3" ++ suf+        ZmmReg 4       -> zmmGlobal $ "ZMM4" ++ suf+        ZmmReg 5       -> zmmGlobal $ "ZMM5" ++ suf+        ZmmReg 6       -> zmmGlobal $ "ZMM6" ++ suf+        MachSp         -> wordGlobal $ "MachSp" ++ suf+        _other         -> panic $ "LlvmCodeGen.Reg: GlobalReg (" ++ (show reg)+                                ++ ") not supported!"+        -- LongReg, HpLim, CCSS, CurrentTSO, CurrentNusery, HpAlloc+        -- EagerBlackholeInfo, GCEnter1, GCFun, BaseReg, PicBaseReg+    where+        wordGlobal   name = LMNLocalVar (fsLit name) (llvmWord dflags)+        ptrGlobal    name = LMNLocalVar (fsLit name) (llvmWordPtr dflags)+        floatGlobal  name = LMNLocalVar (fsLit name) LMFloat+        doubleGlobal name = LMNLocalVar (fsLit name) LMDouble+        xmmGlobal    name = LMNLocalVar (fsLit name) (LMVector 4 (LMInt 32))+        ymmGlobal    name = LMNLocalVar (fsLit name) (LMVector 8 (LMInt 32))+        zmmGlobal    name = LMNLocalVar (fsLit name) (LMVector 16 (LMInt 32))++-- | A list of STG Registers that should always be considered alive+alwaysLive :: [GlobalReg]+alwaysLive = [BaseReg, Sp, Hp, SpLim, HpLim, node]++-- | STG Type Based Alias Analysis hierarchy+stgTBAA :: [(Unique, LMString, Maybe Unique)]+stgTBAA+  = [ (rootN,  fsLit "root",   Nothing)+    , (topN,   fsLit "top",   Just rootN)+    , (stackN, fsLit "stack", Just topN)+    , (heapN,  fsLit "heap",  Just topN)+    , (rxN,    fsLit "rx",    Just heapN)+    , (baseN,  fsLit "base",  Just topN)+    -- FIX: Not 100% sure if this hierarchy is complete.  I think the big thing+    -- is Sp is never aliased, so might want to change the hierarchy to have Sp+    -- on its own branch that is never aliased (e.g never use top as a TBAA+    -- node).+    ]++-- | Id values+-- The `rootN` node is the root (there can be more than one) of the TBAA+-- hierarchy and as of LLVM 4.0 should *only* be referenced by other nodes. It+-- should never occur in any LLVM instruction statement.+rootN, topN, stackN, heapN, rxN, baseN :: Unique+rootN  = getUnique (fsLit "LlvmCodeGen.Regs.rootN")+topN   = getUnique (fsLit "LlvmCodeGen.Regs.topN")+stackN = getUnique (fsLit "LlvmCodeGen.Regs.stackN")+heapN  = getUnique (fsLit "LlvmCodeGen.Regs.heapN")+rxN    = getUnique (fsLit "LlvmCodeGen.Regs.rxN")+baseN  = getUnique (fsLit "LlvmCodeGen.Regs.baseN")++-- | The TBAA metadata identifier+tbaa :: LMString+tbaa = fsLit "tbaa"++-- | Get the correct TBAA metadata information for this register type+getTBAA :: GlobalReg -> Unique+getTBAA BaseReg          = baseN+getTBAA Sp               = stackN+getTBAA Hp               = heapN+getTBAA (VanillaReg _ _) = rxN+getTBAA _                = topN
+ llvmGen/LlvmMangler.hs view
@@ -0,0 +1,127 @@+-- -----------------------------------------------------------------------------+-- | GHC LLVM Mangler+--+-- This script processes the assembly produced by LLVM, rewriting all symbols+-- of type @function to @object. This keeps them from going through the PLT,+-- which would be bad due to tables-next-to-code. On x86_64,+-- it also rewrites AVX instructions that require alignment to their+-- unaligned counterparts, since the stack is only 16-byte aligned but these+-- instructions require 32-byte alignment.+--++module LlvmMangler ( llvmFixupAsm ) where++import DynFlags ( DynFlags, targetPlatform )+import Platform ( platformArch, Arch(..) )+import ErrUtils ( withTiming )+import Outputable ( text )++import Control.Exception+import qualified Data.ByteString.Char8 as B+import System.IO++-- | Read in assembly file and process+llvmFixupAsm :: DynFlags -> FilePath -> FilePath -> IO ()+llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-}+    withTiming (pure dflags) (text "LLVM Mangler") id $+    withBinaryFile f1 ReadMode $ \r -> withBinaryFile f2 WriteMode $ \w -> do+        go r w+        hClose r+        hClose w+        return ()+  where+    go :: Handle -> Handle -> IO ()+    go r w = do+      e_l <- try $ B.hGetLine r ::IO (Either IOError B.ByteString)+      let writeline a = B.hPutStrLn w (rewriteLine dflags rewrites a) >> go r w+      case e_l of+        Right l -> writeline l+        Left _  -> return ()++-- | These are the rewrites that the mangler will perform+rewrites :: [Rewrite]+rewrites = [rewriteSymType, rewriteAVX]++type Rewrite = DynFlags -> B.ByteString -> Maybe B.ByteString++-- | Rewrite a line of assembly source with the given rewrites,+-- taking the first rewrite that applies.+rewriteLine :: DynFlags -> [Rewrite] -> B.ByteString -> B.ByteString+rewriteLine dflags rewrites l+  -- We disable .subsections_via_symbols on darwin and ios, as the llvm code+  -- gen uses prefix data for the info table.  This however does not prevent+  -- llvm from generating .subsections_via_symbols, which in turn with+  -- -dead_strip, strips the info tables, and therefore breaks ghc.+  | isSubsectionsViaSymbols l =+    (B.pack "## no .subsection_via_symbols for ghc. We need our info tables!")+  | otherwise =+    case firstJust $ map (\rewrite -> rewrite dflags rest) rewrites of+      Nothing        -> l+      Just rewritten -> B.concat $ [symbol, B.pack "\t", rewritten]+  where+    isSubsectionsViaSymbols = B.isPrefixOf (B.pack ".subsections_via_symbols")++    (symbol, rest) = splitLine l++    firstJust :: [Maybe a] -> Maybe a+    firstJust (Just x:_) = Just x+    firstJust []         = Nothing+    firstJust (_:rest)   = firstJust rest++-- | This rewrites @.type@ annotations of function symbols to @%object@.+-- This is done as the linker can relocate @%functions@ through the+-- Procedure Linking Table (PLT). This is bad since we expect that the+-- info table will appear directly before the symbol's location. In the+-- case that the PLT is used, this will be not an info table but instead+-- some random PLT garbage.+rewriteSymType :: Rewrite+rewriteSymType _ l+  | isType l  = Just $ rewrite '@' $ rewrite '%' l+  | otherwise = Nothing+  where+    isType = B.isPrefixOf (B.pack ".type")++    rewrite :: Char -> B.ByteString -> B.ByteString+    rewrite prefix = replaceOnce funcType objType+      where+        funcType = prefix `B.cons` B.pack "function"+        objType  = prefix `B.cons` B.pack "object"++-- | This rewrites aligned AVX instructions to their unaligned counterparts on+-- x86-64. This is necessary because the stack is not adequately aligned for+-- aligned AVX spills, so LLVM would emit code that adjusts the stack pointer+-- and disable tail call optimization. Both would be catastrophic here so GHC+-- tells LLVM that the stack is 32-byte aligned (even though it isn't) and then+-- rewrites the instructions in the mangler.+rewriteAVX :: Rewrite+rewriteAVX dflags s+  | not isX86_64 = Nothing+  | isVmovdqa s  = Just $ replaceOnce (B.pack "vmovdqa") (B.pack "vmovdqu") s+  | isVmovap s   = Just $ replaceOnce (B.pack "vmovap") (B.pack "vmovup") s+  | otherwise    = Nothing+  where+    isX86_64 = platformArch (targetPlatform dflags) == ArchX86_64+    isVmovdqa = B.isPrefixOf (B.pack "vmovdqa")+    isVmovap = B.isPrefixOf (B.pack "vmovap")++-- | @replaceOnce match replace bs@ replaces the first occurrence of the+-- substring @match@ in @bs@ with @replace@.+replaceOnce :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString+replaceOnce matchBS replaceOnceBS = loop+  where+    loop :: B.ByteString -> B.ByteString+    loop cts =+        case B.breakSubstring matchBS cts of+          (hd,tl) | B.null tl -> hd+                  | otherwise -> hd `B.append` replaceOnceBS `B.append`+                                 B.drop (B.length matchBS) tl++-- | This function splits a line of assembly code into the label and the+-- rest of the code.+splitLine :: B.ByteString -> (B.ByteString, B.ByteString)+splitLine l = (symbol, B.dropWhile isSpace rest)+  where+    isSpace ' ' = True+    isSpace '\t' = True+    isSpace _ = False+    (symbol, rest) = B.span (not . isSpace) l
+ main/Annotations.hs view
@@ -0,0 +1,132 @@+-- |+-- Support for source code annotation feature of GHC. That is the ANN pragma.+--+-- (c) The University of Glasgow 2006+-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998+--+module Annotations (+        -- * Main Annotation data types+        Annotation(..), AnnPayload,+        AnnTarget(..), CoreAnnTarget,+        getAnnTargetName_maybe,++        -- * AnnEnv for collecting and querying Annotations+        AnnEnv,+        mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv,+        findAnns, findAnnsByTypeRep,+        deserializeAnns+    ) where++import Binary+import Module           ( Module )+import Name+import Outputable+import GHC.Serialized+import UniqFM+import Unique++import Control.Monad+import Data.Maybe+import Data.Typeable+import Data.Word        ( Word8 )+++-- | Represents an annotation after it has been sufficiently desugared from+-- it's initial form of 'HsDecls.AnnDecl'+data Annotation = Annotation {+        ann_target :: CoreAnnTarget,    -- ^ The target of the annotation+        ann_value  :: AnnPayload+    }++type AnnPayload = Serialized    -- ^ The "payload" of an annotation+                                --   allows recovery of its value at a given type,+                                --   and can be persisted to an interface file++-- | An annotation target+data AnnTarget name+  = NamedTarget name          -- ^ We are annotating something with a name:+                              --      a type or identifier+  | ModuleTarget Module       -- ^ We are annotating a particular module++-- | The kind of annotation target found in the middle end of the compiler+type CoreAnnTarget = AnnTarget Name++instance Functor AnnTarget where+    fmap f (NamedTarget nm) = NamedTarget (f nm)+    fmap _ (ModuleTarget mod) = ModuleTarget mod++-- | Get the 'name' of an annotation target if it exists.+getAnnTargetName_maybe :: AnnTarget name -> Maybe name+getAnnTargetName_maybe (NamedTarget nm) = Just nm+getAnnTargetName_maybe _                = Nothing++instance Uniquable name => Uniquable (AnnTarget name) where+    getUnique (NamedTarget nm) = getUnique nm+    getUnique (ModuleTarget mod) = deriveUnique (getUnique mod) 0+    -- deriveUnique prevents OccName uniques clashing with NamedTarget++instance Outputable name => Outputable (AnnTarget name) where+    ppr (NamedTarget nm) = text "Named target" <+> ppr nm+    ppr (ModuleTarget mod) = text "Module target" <+> ppr mod++instance Binary name => Binary (AnnTarget name) where+    put_ bh (NamedTarget a) = do+        putByte bh 0+        put_ bh a+    put_ bh (ModuleTarget a) = do+        putByte bh 1+        put_ bh a+    get bh = do+        h <- getByte bh+        case h of+            0 -> liftM NamedTarget  $ get bh+            _ -> liftM ModuleTarget $ get bh++instance Outputable Annotation where+    ppr ann = ppr (ann_target ann)++-- | A collection of annotations+-- Can't use a type synonym or we hit bug #2412 due to source import+newtype AnnEnv = MkAnnEnv (UniqFM [AnnPayload])++-- | An empty annotation environment.+emptyAnnEnv :: AnnEnv+emptyAnnEnv = MkAnnEnv emptyUFM++-- | Construct a new annotation environment that contains the list of+-- annotations provided.+mkAnnEnv :: [Annotation] -> AnnEnv+mkAnnEnv = extendAnnEnvList emptyAnnEnv++-- | Add the given annotation to the environment.+extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv+extendAnnEnvList (MkAnnEnv env) anns+  = MkAnnEnv $ addListToUFM_C (++) env $+    map (\ann -> (getUnique (ann_target ann), [ann_value ann])) anns++-- | Union two annotation environments.+plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv+plusAnnEnv (MkAnnEnv env1) (MkAnnEnv env2) = MkAnnEnv $ plusUFM_C (++) env1 env2++-- | Find the annotations attached to the given target as 'Typeable'+--   values of your choice. If no deserializer is specified,+--   only transient annotations will be returned.+findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]+findAnns deserialize (MkAnnEnv ann_env)+  = (mapMaybe (fromSerialized deserialize))+    . (lookupWithDefaultUFM ann_env [])++-- | Find the annotations attached to the given target as 'Typeable'+--   values of your choice. If no deserializer is specified,+--   only transient annotations will be returned.+findAnnsByTypeRep :: AnnEnv -> CoreAnnTarget -> TypeRep -> [[Word8]]+findAnnsByTypeRep (MkAnnEnv ann_env) target tyrep+  = [ ws | Serialized tyrep' ws <- lookupWithDefaultUFM ann_env [] target+    , tyrep' == tyrep ]++-- | Deserialize all annotations of a given type. This happens lazily, that is+--   no deserialization will take place until the [a] is actually demanded and+--   the [a] can also be empty (the UniqFM is not filtered).+deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> UniqFM [a]+deserializeAnns deserialize (MkAnnEnv ann_env)+  = mapUFM (mapMaybe (fromSerialized deserialize)) ann_env
+ main/CmdLineParser.hs view
@@ -0,0 +1,314 @@+{-# LANGUAGE CPP #-}++-------------------------------------------------------------------------------+--+-- | Command-line parser+--+-- This is an abstract command-line parser used by DynFlags.+--+-- (c) The University of Glasgow 2005+--+-------------------------------------------------------------------------------++module CmdLineParser+    (+      processArgs, OptKind(..), GhcFlagMode(..),+      CmdLineP(..), getCmdLineState, putCmdLineState,+      Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag,+      errorsToGhcException,++      EwM, runEwM, addErr, addWarn, getArg, getCurLoc, liftEwM, deprecate+    ) where++#include "HsVersions.h"++import Util+import Outputable+import Panic+import Bag+import SrcLoc++import Data.Function+import Data.List++import Control.Monad (liftM, ap)++--------------------------------------------------------+--         The Flag and OptKind types+--------------------------------------------------------++data Flag m = Flag+    {   flagName    :: String,     -- Flag, without the leading "-"+        flagOptKind :: OptKind m,  -- What to do if we see it+        flagGhcMode :: GhcFlagMode    -- Which modes this flag affects+    }++defFlag :: String -> OptKind m -> Flag m+defFlag name optKind = Flag name optKind AllModes++defGhcFlag :: String -> OptKind m -> Flag m+defGhcFlag name optKind = Flag name optKind OnlyGhc++defGhciFlag :: String -> OptKind m -> Flag m+defGhciFlag name optKind = Flag name optKind OnlyGhci++defHiddenFlag :: String -> OptKind m -> Flag m+defHiddenFlag name optKind = Flag name optKind HiddenFlag++-- | GHC flag modes describing when a flag has an effect.+data GhcFlagMode+    = OnlyGhc  -- ^ The flag only affects the non-interactive GHC+    | OnlyGhci -- ^ The flag only affects the interactive GHC+    | AllModes -- ^ The flag affects multiple ghc modes+    | HiddenFlag -- ^ This flag should not be seen in cli completion++data OptKind m                             -- Suppose the flag is -f+    = NoArg     (EwM m ())                 -- -f all by itself+    | HasArg    (String -> EwM m ())       -- -farg or -f arg+    | SepArg    (String -> EwM m ())       -- -f arg+    | Prefix    (String -> EwM m ())       -- -farg+    | OptPrefix (String -> EwM m ())       -- -f or -farg (i.e. the arg is optional)+    | OptIntSuffix (Maybe Int -> EwM m ()) -- -f or -f=n; pass n to fn+    | IntSuffix (Int -> EwM m ())          -- -f or -f=n; pass n to fn+    | FloatSuffix (Float -> EwM m ())      -- -f or -f=n; pass n to fn+    | PassFlag  (String -> EwM m ())       -- -f; pass "-f" fn+    | AnySuffix (String -> EwM m ())       -- -f or -farg; pass entire "-farg" to fn+    | PrefixPred    (String -> Bool) (String -> EwM m ())+    | AnySuffixPred (String -> Bool) (String -> EwM m ())+++--------------------------------------------------------+--         The EwM monad+--------------------------------------------------------++type Err   = Located String+type Warn  = Located String+type Errs  = Bag Err+type Warns = Bag Warn++-- EwM ("errors and warnings monad") is a monad+-- transformer for m that adds an (err, warn) state+newtype EwM m a = EwM { unEwM :: Located String -- Current parse arg+                              -> Errs -> Warns+                              -> m (Errs, Warns, a) }++instance Monad m => Functor (EwM m) where+    fmap = liftM++instance Monad m => Applicative (EwM m) where+    pure v = EwM (\_ e w -> return (e, w, v))+    (<*>) = ap++instance Monad m => Monad (EwM m) where+    (EwM f) >>= k = EwM (\l e w -> do (e', w', r) <- f l e w+                                      unEwM (k r) l e' w')++runEwM :: EwM m a -> m (Errs, Warns, a)+runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag emptyBag++setArg :: Located String -> EwM m () -> EwM m ()+setArg l (EwM f) = EwM (\_ es ws -> f l es ws)++addErr :: Monad m => String -> EwM m ()+addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` L loc e, ws, ()))++addWarn :: Monad m => String -> EwM m ()+addWarn msg = EwM (\(L loc _) es ws -> return (es, ws `snocBag` L loc msg, ()))++deprecate :: Monad m => String -> EwM m ()+deprecate s = do+    arg <- getArg+    addWarn (arg ++ " is deprecated: " ++ s)++getArg :: Monad m => EwM m String+getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg))++getCurLoc :: Monad m => EwM m SrcSpan+getCurLoc = EwM (\(L loc _) es ws -> return (es, ws, loc))++liftEwM :: Monad m => m a -> EwM m a+liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) })+++--------------------------------------------------------+-- A state monad for use in the command-line parser+--------------------------------------------------------++-- (CmdLineP s) typically instantiates the 'm' in (EwM m) and (OptKind m)+newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) }++instance Functor (CmdLineP s) where+    fmap = liftM++instance Applicative (CmdLineP s) where+    pure a = CmdLineP $ \s -> (a, s)+    (<*>) = ap++instance Monad (CmdLineP s) where+    m >>= k = CmdLineP $ \s ->+                  let (a, s') = runCmdLine m s+                  in runCmdLine (k a) s'+++getCmdLineState :: CmdLineP s s+getCmdLineState   = CmdLineP $ \s -> (s,s)+putCmdLineState :: s -> CmdLineP s ()+putCmdLineState s = CmdLineP $ \_ -> ((),s)+++--------------------------------------------------------+--         Processing arguments+--------------------------------------------------------++processArgs :: Monad m+            => [Flag m]               -- cmdline parser spec+            -> [Located String]       -- args+            -> m ( [Located String],  -- spare args+                   [Located String],  -- errors+                   [Located String] ) -- warnings+processArgs spec args = do+    (errs, warns, spare) <- runEwM action+    return (spare, bagToList errs, bagToList warns)+  where+    action = process args []++    -- process :: [Located String] -> [Located String] -> EwM m [Located String]+    process [] spare = return (reverse spare)++    process (locArg@(L _ ('-' : arg)) : args) spare =+        case findArg spec arg of+            Just (rest, opt_kind) ->+                case processOneArg opt_kind rest arg args of+                    Left err ->+                        let b = process args spare+                        in (setArg locArg $ addErr err) >> b++                    Right (action,rest) ->+                        let b = process rest spare+                        in (setArg locArg $ action) >> b++            Nothing -> process args (locArg : spare)++    process (arg : args) spare = process args (arg : spare)+++processOneArg :: OptKind m -> String -> String -> [Located String]+              -> Either String (EwM m (), [Located String])+processOneArg opt_kind rest arg args+  = let dash_arg = '-' : arg+        rest_no_eq = dropEq rest+    in case opt_kind of+        NoArg  a -> ASSERT(null rest) Right (a, args)++        HasArg f | notNull rest_no_eq -> Right (f rest_no_eq, args)+                 | otherwise -> case args of+                                    []               -> missingArgErr dash_arg+                                    (L _ arg1:args1) -> Right (f arg1, args1)++        -- See Trac #9776+        SepArg f -> case args of+                        []               -> missingArgErr dash_arg+                        (L _ arg1:args1) -> Right (f arg1, args1)++        Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args)+                 | otherwise          -> unknownFlagErr dash_arg++        PrefixPred _ f | notNull rest_no_eq -> Right (f rest_no_eq, args)+                       | otherwise          -> unknownFlagErr dash_arg++        PassFlag f  | notNull rest -> unknownFlagErr dash_arg+                    | otherwise    -> Right (f dash_arg, args)++        OptIntSuffix f | null rest                     -> Right (f Nothing,  args)+                       | Just n <- parseInt rest_no_eq -> Right (f (Just n), args)+                       | otherwise -> Left ("malformed integer argument in " ++ dash_arg)++        IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args)+                    | otherwise -> Left ("malformed integer argument in " ++ dash_arg)++        FloatSuffix f | Just n <- parseFloat rest_no_eq -> Right (f n, args)+                      | otherwise -> Left ("malformed float argument in " ++ dash_arg)++        OptPrefix f       -> Right (f rest_no_eq, args)+        AnySuffix f       -> Right (f dash_arg, args)+        AnySuffixPred _ f -> Right (f dash_arg, args)++findArg :: [Flag m] -> String -> Maybe (String, OptKind m)+findArg spec arg =+    case sortBy (compare `on` (length . fst)) -- prefer longest matching flag+           [ (removeSpaces rest, optKind)+           | flag <- spec,+             let optKind  = flagOptKind flag,+             Just rest <- [stripPrefix (flagName flag) arg],+             arg_ok optKind rest arg ]+    of+        []      -> Nothing+        (one:_) -> Just one++arg_ok :: OptKind t -> [Char] -> String -> Bool+arg_ok (NoArg           _)  rest _   = null rest+arg_ok (HasArg          _)  _    _   = True+arg_ok (SepArg          _)  rest _   = null rest+arg_ok (Prefix          _)  rest _   = notNull rest+arg_ok (PrefixPred p    _)  rest _   = notNull rest && p (dropEq rest)+arg_ok (OptIntSuffix    _)  _    _   = True+arg_ok (IntSuffix       _)  _    _   = True+arg_ok (FloatSuffix     _)  _    _   = True+arg_ok (OptPrefix       _)  _    _   = True+arg_ok (PassFlag        _)  rest _   = null rest+arg_ok (AnySuffix       _)  _    _   = True+arg_ok (AnySuffixPred p _)  _    arg = p arg++-- | Parse an Int+--+-- Looks for "433" or "=342", with no trailing gubbins+--   * n or =n      => Just n+--   * gibberish    => Nothing+parseInt :: String -> Maybe Int+parseInt s = case reads s of+                 ((n,""):_) -> Just n+                 _          -> Nothing++parseFloat :: String -> Maybe Float+parseFloat s = case reads s of+                   ((n,""):_) -> Just n+                   _          -> Nothing++-- | Discards a leading equals sign+dropEq :: String -> String+dropEq ('=' : s) = s+dropEq s         = s++unknownFlagErr :: String -> Either String a+unknownFlagErr f = Left ("unrecognised flag: " ++ f)++missingArgErr :: String -> Either String a+missingArgErr f = Left ("missing argument for flag: " ++ f)++--------------------------------------------------------+-- Utils+--------------------------------------------------------+++-- See Note [Handling errors when parsing flags]+errorsToGhcException :: [(String,    -- Location+                          String)]   -- Error+                     -> GhcException+errorsToGhcException errs =+    UsageError $ intercalate "\n" $ [ l ++ ": " ++ e | (l, e) <- errs ]++{- Note [Handling errors when parsing commandline flags]++Parsing of static and mode flags happens before any session is started, i.e.,+before the first call to 'GHC.withGhc'. Therefore, to report errors for+invalid usage of these two types of flags, we can not call any function that+needs DynFlags, as there are no DynFlags available yet (unsafeGlobalDynFlags+is not set either). So we always print "on the commandline" as the location,+which is true except for Api users, which is probably ok.++When reporting errors for invalid usage of dynamic flags we /can/ make use of+DynFlags, and we do so explicitly in DynFlags.parseDynamicFlagsFull.++Before, we called unsafeGlobalDynFlags when an invalid (combination of)+flag(s) was given on the commandline, resulting in panics (#9963).+-}
+ main/CodeOutput.hs view
@@ -0,0 +1,281 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998++\section{Code output phase}+-}++{-# LANGUAGE CPP #-}++module CodeOutput( codeOutput, outputForeignStubs ) where++#include "HsVersions.h"++import AsmCodeGen ( nativeCodeGen )+import LlvmCodeGen ( llvmCodeGen )++import UniqSupply       ( mkSplitUniqSupply )++import Finder           ( mkStubPaths )+import PprC             ( writeCs )+import CmmLint          ( cmmLint )+import Packages+import Cmm              ( RawCmmGroup )+import HscTypes+import DynFlags+import Config+import SysTools+import Stream           (Stream)+import qualified Stream++import ErrUtils+import Outputable+import Module+import SrcLoc++import Control.Exception+import System.Directory+import System.FilePath+import System.IO+import Control.Monad (forM)++{-+************************************************************************+*                                                                      *+\subsection{Steering}+*                                                                      *+************************************************************************+-}++codeOutput :: DynFlags+           -> Module+           -> FilePath+           -> ModLocation+           -> ForeignStubs+           -> [(ForeignSrcLang, String)]+           -- ^ additional files to be compiled with with the C compiler+           -> [InstalledUnitId]+           -> Stream IO RawCmmGroup ()                       -- Compiled C--+           -> IO (FilePath,+                  (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),+                  [(ForeignSrcLang, FilePath)]{-foreign_fps-})++codeOutput dflags this_mod filenm location foreign_stubs foreign_files pkg_deps+  cmm_stream+  =+    do  {+        -- Lint each CmmGroup as it goes past+        ; let linted_cmm_stream =+                 if gopt Opt_DoCmmLinting dflags+                    then Stream.mapM do_lint cmm_stream+                    else cmm_stream++              do_lint cmm = withTiming (pure dflags)+                                       (text "CmmLint"<+>brackets (ppr this_mod))+                                       (const ()) $ do+                { case cmmLint dflags cmm of+                        Just err -> do { log_action dflags+                                                   dflags+                                                   NoReason+                                                   SevDump+                                                   noSrcSpan+                                                   (defaultDumpStyle dflags)+                                                   err+                                       ; ghcExit dflags 1+                                       }+                        Nothing  -> return ()+                ; return cmm+                }++        ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs+        ; foreign_fps <- forM foreign_files $ \(lang, file_contents) -> do+            { fp <- outputForeignFile dflags lang file_contents;+            ; return (lang, fp);+            }+        ; case hscTarget dflags of {+             HscAsm         -> outputAsm dflags this_mod location filenm+                                         linted_cmm_stream;+             HscC           -> outputC dflags filenm linted_cmm_stream pkg_deps;+             HscLlvm        -> outputLlvm dflags filenm linted_cmm_stream;+             HscInterpreted -> panic "codeOutput: HscInterpreted";+             HscNothing     -> panic "codeOutput: HscNothing"+          }+        ; return (filenm, stubs_exist, foreign_fps)+        }++doOutput :: String -> (Handle -> IO a) -> IO a+doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action++{-+************************************************************************+*                                                                      *+\subsection{C}+*                                                                      *+************************************************************************+-}++outputC :: DynFlags+        -> FilePath+        -> Stream IO RawCmmGroup ()+        -> [InstalledUnitId]+        -> IO ()++outputC dflags filenm cmm_stream packages+  = do+       -- ToDo: make the C backend consume the C-- incrementally, by+       -- pushing the cmm_stream inside (c.f. nativeCodeGen)+       rawcmms <- Stream.collect cmm_stream++       -- figure out which header files to #include in the generated .hc file:+       --+       --   * extra_includes from packages+       --   * -#include options from the cmdline and OPTIONS pragmas+       --   * the _stub.h file, if there is one.+       --+       let rts = getPackageDetails dflags rtsUnitId++       let cc_injects = unlines (map mk_include (includes rts))+           mk_include h_file =+            case h_file of+               '"':_{-"-} -> "#include "++h_file+               '<':_      -> "#include "++h_file+               _          -> "#include \""++h_file++"\""++       let pkg_names = map installedUnitIdString packages++       doOutput filenm $ \ h -> do+          hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")+          hPutStr h cc_injects+          writeCs dflags h rawcmms++{-+************************************************************************+*                                                                      *+\subsection{Assembler}+*                                                                      *+************************************************************************+-}++outputAsm :: DynFlags -> Module -> ModLocation -> FilePath+          -> Stream IO RawCmmGroup ()+          -> IO ()+outputAsm dflags this_mod location filenm cmm_stream+ | cGhcWithNativeCodeGen == "YES"+  = do ncg_uniqs <- mkSplitUniqSupply 'n'++       debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm)++       _ <- {-# SCC "OutputAsm" #-} doOutput filenm $+           \h -> {-# SCC "NativeCodeGen" #-}+                 nativeCodeGen dflags this_mod location h ncg_uniqs cmm_stream+       return ()++ | otherwise+  = panic "This compiler was built without a native code generator"++{-+************************************************************************+*                                                                      *+\subsection{LLVM}+*                                                                      *+************************************************************************+-}++outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO ()+outputLlvm dflags filenm cmm_stream+  = do ncg_uniqs <- mkSplitUniqSupply 'n'++       {-# SCC "llvm_output" #-} doOutput filenm $+           \f -> {-# SCC "llvm_CodeGen" #-}+                 llvmCodeGen dflags f ncg_uniqs cmm_stream++{-+************************************************************************+*                                                                      *+\subsection{Foreign import/export}+*                                                                      *+************************************************************************+-}++outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs+                   -> IO (Bool,         -- Header file created+                          Maybe FilePath) -- C file created+outputForeignStubs dflags mod location stubs+ = do+   let stub_h = mkStubPaths dflags (moduleName mod) location+   stub_c <- newTempName dflags "c"++   case stubs of+     NoStubs ->+        return (False, Nothing)++     ForeignStubs h_code c_code -> do+        let+            stub_c_output_d = pprCode CStyle c_code+            stub_c_output_w = showSDoc dflags stub_c_output_d++            -- Header file protos for "foreign export"ed functions.+            stub_h_output_d = pprCode CStyle h_code+            stub_h_output_w = showSDoc dflags stub_h_output_d++        createDirectoryIfMissing True (takeDirectory stub_h)++        dumpIfSet_dyn dflags Opt_D_dump_foreign+                      "Foreign export header file" stub_h_output_d++        -- we need the #includes from the rts package for the stub files+        let rts_includes =+               let rts_pkg = getPackageDetails dflags rtsUnitId in+               concatMap mk_include (includes rts_pkg)+            mk_include i = "#include \"" ++ i ++ "\"\n"++            -- wrapper code mentions the ffi_arg type, which comes from ffi.h+            ffi_includes | cLibFFI   = "#include \"ffi.h\"\n"+                         | otherwise = ""++        stub_h_file_exists+           <- outputForeignStubs_help stub_h stub_h_output_w+                ("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr++        dumpIfSet_dyn dflags Opt_D_dump_foreign+                      "Foreign export stubs" stub_c_output_d++        stub_c_file_exists+           <- outputForeignStubs_help stub_c stub_c_output_w+                ("#define IN_STG_CODE 0\n" +++                 "#include \"Rts.h\"\n" +++                 rts_includes +++                 ffi_includes +++                 cplusplus_hdr)+                 cplusplus_ftr+           -- We're adding the default hc_header to the stub file, but this+           -- isn't really HC code, so we need to define IN_STG_CODE==0 to+           -- avoid the register variables etc. being enabled.++        return (stub_h_file_exists, if stub_c_file_exists+                                       then Just stub_c+                                       else Nothing )+ where+   cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"+   cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n"+++-- Don't use doOutput for dumping the f. export stubs+-- since it is more than likely that the stubs file will+-- turn out to be empty, in which case no file should be created.+outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool+outputForeignStubs_help _fname ""      _header _footer = return False+outputForeignStubs_help fname doc_str header footer+   = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")+        return True++outputForeignFile :: DynFlags -> ForeignSrcLang -> String -> IO FilePath+outputForeignFile dflags lang file_contents+ = do+   extension <- case lang of+     LangC -> return "c"+     LangCxx -> return "cpp"+     LangObjc -> return "m"+     LangObjcxx -> return "mm"+   fp <- newTempName dflags extension+   writeFile fp file_contents+   return fp
+ main/Constants.hs view
@@ -0,0 +1,40 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[Constants]{Info about this compilation}+-}++module Constants (module Constants) where++import Config++hiVersion :: Integer+hiVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer++-- All pretty arbitrary:++mAX_TUPLE_SIZE :: Int+mAX_TUPLE_SIZE = 62 -- Should really match the number+                    -- of decls in Data.Tuple++mAX_CTUPLE_SIZE :: Int   -- Constraint tuples+mAX_CTUPLE_SIZE = 62     -- Should match the number of decls in GHC.Classes++mAX_SUM_SIZE :: Int+mAX_SUM_SIZE = 62++-- | Default maximum depth for both class instance search and type family+-- reduction. See also Trac #5395.+mAX_REDUCTION_DEPTH :: Int+mAX_REDUCTION_DEPTH = 200++-- | Default maximum constraint-solver iterations+-- Typically there should be very few+mAX_SOLVER_ITERATIONS :: Int+mAX_SOLVER_ITERATIONS = 4++wORD64_SIZE :: Int+wORD64_SIZE = 8++tARGET_MAX_CHAR :: Int+tARGET_MAX_CHAR = 0x10ffff
+ main/DriverMkDepend.hs view
@@ -0,0 +1,406 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Makefile Dependency Generation+--+-- (c) The University of Glasgow 2005+--+-----------------------------------------------------------------------------++module DriverMkDepend (+        doMkDependHS+  ) where++#include "HsVersions.h"++import qualified GHC+import GhcMonad+import DynFlags+import Util+import HscTypes+import SysTools         ( newTempName )+import qualified SysTools+import Module+import Digraph          ( SCC(..) )+import Finder+import Outputable+import Panic+import SrcLoc+import Data.List+import FastString++import Exception+import ErrUtils++import System.Directory+import System.FilePath+import System.IO+import System.IO.Error  ( isEOFError )+import Control.Monad    ( when )+import Data.Maybe       ( isJust )++-----------------------------------------------------------------+--+--              The main function+--+-----------------------------------------------------------------++doMkDependHS :: GhcMonad m => [FilePath] -> m ()+doMkDependHS srcs = do+    -- Initialisation+    dflags0 <- GHC.getSessionDynFlags++    -- We kludge things a bit for dependency generation. Rather than+    -- generating dependencies for each way separately, we generate+    -- them once and then duplicate them for each way's osuf/hisuf.+    -- We therefore do the initial dependency generation with an empty+    -- way and .o/.hi extensions, regardless of any flags that might+    -- be specified.+    let dflags = dflags0 {+                     ways = [],+                     buildTag = mkBuildTag [],+                     hiSuf = "hi",+                     objectSuf = "o"+                 }+    _ <- GHC.setSessionDynFlags dflags++    when (null (depSuffixes dflags)) $ liftIO $+        throwGhcExceptionIO (ProgramError "You must specify at least one -dep-suffix")++    files <- liftIO $ beginMkDependHS dflags++    -- Do the downsweep to find all the modules+    targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs+    GHC.setTargets targets+    let excl_mods = depExcludeMods dflags+    mod_summaries <- GHC.depanal excl_mods True {- Allow dup roots -}++    -- Sort into dependency order+    -- There should be no cycles+    let sorted = GHC.topSortModuleGraph False mod_summaries Nothing++    -- Print out the dependencies if wanted+    liftIO $ debugTraceMsg dflags 2 (text "Module dependencies" $$ ppr sorted)++    -- Prcess them one by one, dumping results into makefile+    -- and complaining about cycles+    hsc_env <- getSession+    root <- liftIO getCurrentDirectory+    mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted++    -- If -ddump-mod-cycles, show cycles in the module graph+    liftIO $ dumpModCycles dflags mod_summaries++    -- Tidy up+    liftIO $ endMkDependHS dflags files++    -- Unconditional exiting is a bad idea.  If an error occurs we'll get an+    --exception; if that is not caught it's fine, but at least we have a+    --chance to find out exactly what went wrong.  Uncomment the following+    --line if you disagree.++    --`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1)++-----------------------------------------------------------------+--+--              beginMkDependHs+--      Create a temporary file,+--      find the Makefile,+--      slurp through it, etc+--+-----------------------------------------------------------------++data MkDepFiles+  = MkDep { mkd_make_file :: FilePath,          -- Name of the makefile+            mkd_make_hdl  :: Maybe Handle,      -- Handle for the open makefile+            mkd_tmp_file  :: FilePath,          -- Name of the temporary file+            mkd_tmp_hdl   :: Handle }           -- Handle of the open temporary file++beginMkDependHS :: DynFlags -> IO MkDepFiles+beginMkDependHS dflags = do+        -- open a new temp file in which to stuff the dependency info+        -- as we go along.+  tmp_file <- newTempName dflags "dep"+  tmp_hdl <- openFile tmp_file WriteMode++        -- open the makefile+  let makefile = depMakefile dflags+  exists <- doesFileExist makefile+  mb_make_hdl <-+        if not exists+        then return Nothing+        else do+           makefile_hdl <- openFile makefile ReadMode++                -- slurp through until we get the magic start string,+                -- copying the contents into dep_makefile+           let slurp = do+                l <- hGetLine makefile_hdl+                if (l == depStartMarker)+                        then return ()+                        else do hPutStrLn tmp_hdl l; slurp++                -- slurp through until we get the magic end marker,+                -- throwing away the contents+           let chuck = do+                l <- hGetLine makefile_hdl+                if (l == depEndMarker)+                        then return ()+                        else chuck++           catchIO slurp+                (\e -> if isEOFError e then return () else ioError e)+           catchIO chuck+                (\e -> if isEOFError e then return () else ioError e)++           return (Just makefile_hdl)+++        -- write the magic marker into the tmp file+  hPutStrLn tmp_hdl depStartMarker++  return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl,+                  mkd_tmp_file  = tmp_file, mkd_tmp_hdl  = tmp_hdl})+++-----------------------------------------------------------------+--+--              processDeps+--+-----------------------------------------------------------------++processDeps :: DynFlags+            -> HscEnv+            -> [ModuleName]+            -> FilePath+            -> Handle           -- Write dependencies to here+            -> SCC ModSummary+            -> IO ()+-- Write suitable dependencies to handle+-- Always:+--                      this.o : this.hs+--+-- If the dependency is on something other than a .hi file:+--                      this.o this.p_o ... : dep+-- otherwise+--                      this.o ...   : dep.hi+--                      this.p_o ... : dep.p_hi+--                      ...+-- (where .o is $osuf, and the other suffixes come from+-- the cmdline -s options).+--+-- For {-# SOURCE #-} imports the "hi" will be "hi-boot".++processDeps dflags _ _ _ _ (CyclicSCC nodes)+  =     -- There shouldn't be any cycles; report them+    throwGhcExceptionIO (ProgramError (showSDoc dflags $ GHC.cyclicModuleErr nodes))++processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node)+  = do  { let extra_suffixes = depSuffixes dflags+              include_pkg_deps = depIncludePkgDeps dflags+              src_file  = msHsFilePath node+              obj_file  = msObjFilePath node+              obj_files = insertSuffixes obj_file extra_suffixes++              do_imp loc is_boot pkg_qual imp_mod+                = do { mb_hi <- findDependency hsc_env loc pkg_qual imp_mod+                                               is_boot include_pkg_deps+                     ; case mb_hi of {+                           Nothing      -> return () ;+                           Just hi_file -> do+                     { let hi_files = insertSuffixes hi_file extra_suffixes+                           write_dep (obj,hi) = writeDependency root hdl [obj] hi++                        -- Add one dependency for each suffix;+                        -- e.g.         A.o   : B.hi+                        --              A.x_o : B.x_hi+                     ; mapM_ write_dep (obj_files `zip` hi_files) }}}+++                -- Emit std dependency of the object(s) on the source file+                -- Something like       A.o : A.hs+        ; writeDependency root hdl obj_files src_file++                -- Emit a dependency for each import++        ; let do_imps is_boot idecls = sequence_+                    [ do_imp loc is_boot mb_pkg mod+                    | (mb_pkg, L loc mod) <- idecls,+                      mod `notElem` excl_mods ]++        ; do_imps True  (ms_srcimps node)+        ; do_imps False (ms_imps node)+        }+++findDependency  :: HscEnv+                -> SrcSpan+                -> Maybe FastString     -- package qualifier, if any+                -> ModuleName           -- Imported module+                -> IsBootInterface      -- Source import+                -> Bool                 -- Record dependency on package modules+                -> IO (Maybe FilePath)  -- Interface file file+findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps+  = do  {       -- Find the module; this will be fast because+                -- we've done it once during downsweep+          r <- findImportedModule hsc_env imp pkg+        ; case r of+            Found loc _+                -- Home package: just depend on the .hi or hi-boot file+                | isJust (ml_hs_file loc) || include_pkg_deps+                -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))++                -- Not in this package: we don't need a dependency+                | otherwise+                -> return Nothing++            fail ->+                let dflags = hsc_dflags hsc_env+                in throwOneError $ mkPlainErrMsg dflags srcloc $+                        cannotFindModule dflags imp fail+        }++-----------------------------+writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()+-- (writeDependency r h [t1,t2] dep) writes to handle h the dependency+--      t1 t2 : dep+writeDependency root hdl targets dep+  = do let -- We need to avoid making deps on+           --     c:/foo/...+           -- on cygwin as make gets confused by the :+           -- Making relative deps avoids some instances of this.+           dep' = makeRelative root dep+           forOutput = escapeSpaces . reslash Forwards . normalise+           output = unwords (map forOutput targets) ++ " : " ++ forOutput dep'+       hPutStrLn hdl output++-----------------------------+insertSuffixes+        :: FilePath     -- Original filename;   e.g. "foo.o"+        -> [String]     -- Suffix prefixes      e.g. ["x_", "y_"]+        -> [FilePath]   -- Zapped filenames     e.g. ["foo.x_o", "foo.y_o"]+        -- Note that that the extra bit gets inserted *before* the old suffix+        -- We assume the old suffix contains no dots, so we know where to+        -- split it+insertSuffixes file_name extras+  = [ basename <.> (extra ++ suffix) | extra <- extras ]+  where+    (basename, suffix) = case splitExtension file_name of+                         -- Drop the "." from the extension+                         (b, s) -> (b, drop 1 s)+++-----------------------------------------------------------------+--+--              endMkDependHs+--      Complete the makefile, close the tmp file etc+--+-----------------------------------------------------------------++endMkDependHS :: DynFlags -> MkDepFiles -> IO ()++endMkDependHS dflags+   (MkDep { mkd_make_file = makefile, mkd_make_hdl =  makefile_hdl,+            mkd_tmp_file  = tmp_file, mkd_tmp_hdl  =  tmp_hdl })+  = do+  -- write the magic marker into the tmp file+  hPutStrLn tmp_hdl depEndMarker++  case makefile_hdl of+     Nothing  -> return ()+     Just hdl -> do++          -- slurp the rest of the original makefile and copy it into the output+        let slurp = do+                l <- hGetLine hdl+                hPutStrLn tmp_hdl l+                slurp++        catchIO slurp+                (\e -> if isEOFError e then return () else ioError e)++        hClose hdl++  hClose tmp_hdl  -- make sure it's flushed++        -- Create a backup of the original makefile+  when (isJust makefile_hdl)+       (SysTools.copy dflags ("Backing up " ++ makefile)+          makefile (makefile++".bak"))++        -- Copy the new makefile in place+  SysTools.copy dflags "Installing new makefile" tmp_file makefile+++-----------------------------------------------------------------+--              Module cycles+-----------------------------------------------------------------++dumpModCycles :: DynFlags -> [ModSummary] -> IO ()+dumpModCycles dflags mod_summaries+  | not (dopt Opt_D_dump_mod_cycles dflags)+  = return ()++  | null cycles+  = putMsg dflags (text "No module cycles")++  | otherwise+  = putMsg dflags (hang (text "Module cycles found:") 2 pp_cycles)+  where++    cycles :: [[ModSummary]]+    cycles = [ c | CyclicSCC c <- GHC.topSortModuleGraph True mod_summaries Nothing ]++    pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> ptext (sLit "----------"))+                        $$ pprCycle c $$ blankLine+                     | (n,c) <- [1..] `zip` cycles ]++pprCycle :: [ModSummary] -> SDoc+-- Print a cycle, but show only the imports within the cycle+pprCycle summaries = pp_group (CyclicSCC summaries)+  where+    cycle_mods :: [ModuleName]  -- The modules in this cycle+    cycle_mods = map (moduleName . ms_mod) summaries++    pp_group (AcyclicSCC ms) = pp_ms ms+    pp_group (CyclicSCC mss)+        = ASSERT( not (null boot_only) )+                -- The boot-only list must be non-empty, else there would+                -- be an infinite chain of non-boot imoprts, and we've+                -- already checked for that in processModDeps+          pp_ms loop_breaker $$ vcat (map pp_group groups)+        where+          (boot_only, others) = partition is_boot_only mss+          is_boot_only ms = not (any in_group (map snd (ms_imps ms)))+          in_group (L _ m) = m `elem` group_mods+          group_mods = map (moduleName . ms_mod) mss++          loop_breaker = head boot_only+          all_others   = tail boot_only ++ others+          groups = GHC.topSortModuleGraph True all_others Nothing++    pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' '))+                       <+> (pp_imps empty (map snd (ms_imps summary)) $$+                            pp_imps (text "{-# SOURCE #-}") (map snd (ms_srcimps summary)))+        where+          mod_str = moduleNameString (moduleName (ms_mod summary))++    pp_imps :: SDoc -> [Located ModuleName] -> SDoc+    pp_imps _    [] = empty+    pp_imps what lms+        = case [m | L _ m <- lms, m `elem` cycle_mods] of+            [] -> empty+            ms -> what <+> text "imports" <+>+                                pprWithCommas ppr ms++-----------------------------------------------------------------+--+--              Flags+--+-----------------------------------------------------------------++depStartMarker, depEndMarker :: String+depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"+depEndMarker   = "# DO NOT DELETE: End of Haskell dependencies"+
+ main/DriverPhases.hs view
@@ -0,0 +1,375 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--  $Id: DriverPhases.hs,v 1.38 2005/05/17 11:01:59 simonmar Exp $+--+-- GHC Driver+--+-- (c) The University of Glasgow 2002+--+-----------------------------------------------------------------------------++module DriverPhases (+   HscSource(..), isHsBootOrSig, hscSourceString,+   Phase(..),+   happensBefore, eqPhase, anyHsc, isStopLn,+   startPhase,+   phaseInputExt,++   isHaskellishSuffix,+   isHaskellSrcSuffix,+   isBackpackishSuffix,+   isObjectSuffix,+   isCishSuffix,+   isDynLibSuffix,+   isHaskellUserSrcSuffix,+   isHaskellSigSuffix,+   isSourceSuffix,++   isHaskellishTarget,++   isHaskellishFilename,+   isHaskellSrcFilename,+   isHaskellSigFilename,+   isObjectFilename,+   isCishFilename,+   isDynLibFilename,+   isHaskellUserSrcFilename,+   isSourceFilename+ ) where++#include "HsVersions.h"++import {-# SOURCE #-} DynFlags+import Outputable+import Platform+import System.FilePath+import Binary+import Util++-----------------------------------------------------------------------------+-- Phases++{-+   Phase of the           | Suffix saying | Flag saying   | (suffix of)+   compilation system     | ``start here''| ``stop after''| output file++   literate pre-processor | .lhs          | -             | -+   C pre-processor (opt.) | -             | -E            | -+   Haskell compiler       | .hs           | -C, -S        | .hc, .s+   C compiler (opt.)      | .hc or .c     | -S            | .s+   assembler              | .s  or .S     | -c            | .o+   linker                 | other         | -             | a.out+-}++-- Note [HscSource types]+-- ~~~~~~~~~~~~~~~~~~~~~~+-- There are three types of source file for Haskell code:+--+--      * HsSrcFile is an ordinary hs file which contains code,+--+--      * HsBootFile is an hs-boot file, which is used to break+--        recursive module imports (there will always be an+--        HsSrcFile associated with it), and+--+--      * HsigFile is an hsig file, which contains only type+--        signatures and is used to specify signatures for+--        modules.+--+-- Syntactically, hs-boot files and hsig files are quite similar: they+-- only include type signatures and must be associated with an+-- actual HsSrcFile.  isHsBootOrSig allows us to abstract over code+-- which is indifferent to which.  However, there are some important+-- differences, mostly owing to the fact that hsigs are proper+-- modules (you `import Sig` directly) whereas HsBootFiles are+-- temporary placeholders (you `import {-# SOURCE #-} Mod).+-- When we finish compiling the true implementation of an hs-boot,+-- we replace the HomeModInfo with the real HsSrcFile.  An HsigFile, on the+-- other hand, is never replaced (in particular, we *cannot* use the+-- HomeModInfo of the original HsSrcFile backing the signature, since it+-- will export too many symbols.)+--+-- Additionally, while HsSrcFile is the only Haskell file+-- which has *code*, we do generate .o files for HsigFile, because+-- this is how the recompilation checker figures out if a file+-- needs to be recompiled.  These are fake object files which+-- should NOT be linked against.++data HscSource+   = HsSrcFile | HsBootFile | HsigFile+     deriving( Eq, Ord, Show )+        -- Ord needed for the finite maps we build in CompManager++instance Binary HscSource where+    put_ bh HsSrcFile = putByte bh 0+    put_ bh HsBootFile = putByte bh 1+    put_ bh HsigFile = putByte bh 2+    get bh = do+        h <- getByte bh+        case h of+            0 -> return HsSrcFile+            1 -> return HsBootFile+            _ -> return HsigFile++hscSourceString :: HscSource -> String+hscSourceString HsSrcFile   = ""+hscSourceString HsBootFile  = "[boot]"+hscSourceString HsigFile    = "[sig]"++-- See Note [isHsBootOrSig]+isHsBootOrSig :: HscSource -> Bool+isHsBootOrSig HsBootFile = True+isHsBootOrSig HsigFile   = True+isHsBootOrSig _          = False++data Phase+        = Unlit HscSource+        | Cpp   HscSource+        | HsPp  HscSource+        | Hsc   HscSource+        | Ccxx          -- Compile C+++        | Cc            -- Compile C+        | Cobjc         -- Compile Objective-C+        | Cobjcxx       -- Compile Objective-C+++        | HCc           -- Haskellised C (as opposed to vanilla C) compilation+        | Splitter      -- Assembly file splitter (part of '-split-objs')+        | SplitAs       -- Assembler for split assembly files (part of '-split-objs')+        | As Bool       -- Assembler for regular assembly files (Bool: with-cpp)+        | LlvmOpt       -- Run LLVM opt tool over llvm assembly+        | LlvmLlc       -- LLVM bitcode to native assembly+        | LlvmMangle    -- Fix up TNTC by processing assembly produced by LLVM+        | CmmCpp        -- pre-process Cmm source+        | Cmm           -- parse & compile Cmm code+        | MergeForeign  -- merge in the foreign object files++        -- The final phase is a pseudo-phase that tells the pipeline to stop.+        -- There is no runPhase case for it.+        | StopLn        -- Stop, but linking will follow, so generate .o file+  deriving (Eq, Show)++instance Outputable Phase where+    ppr p = text (show p)++anyHsc :: Phase+anyHsc = Hsc (panic "anyHsc")++isStopLn :: Phase -> Bool+isStopLn StopLn = True+isStopLn _      = False++eqPhase :: Phase -> Phase -> Bool+-- Equality of constructors, ignoring the HscSource field+-- NB: the HscSource field can be 'bot'; see anyHsc above+eqPhase (Unlit _)   (Unlit _)  = True+eqPhase (Cpp   _)   (Cpp   _)  = True+eqPhase (HsPp  _)   (HsPp  _)  = True+eqPhase (Hsc   _)   (Hsc   _)  = True+eqPhase Cc          Cc         = True+eqPhase Cobjc       Cobjc      = True+eqPhase HCc         HCc        = True+eqPhase Splitter    Splitter   = True+eqPhase SplitAs     SplitAs    = True+eqPhase (As x)      (As y)     = x == y+eqPhase LlvmOpt     LlvmOpt    = True+eqPhase LlvmLlc     LlvmLlc    = True+eqPhase LlvmMangle  LlvmMangle = True+eqPhase CmmCpp      CmmCpp     = True+eqPhase Cmm         Cmm        = True+eqPhase MergeForeign MergeForeign  = True+eqPhase StopLn      StopLn     = True+eqPhase Ccxx        Ccxx       = True+eqPhase Cobjcxx     Cobjcxx    = True+eqPhase _           _          = False++{- Note [Partial ordering on phases]++We want to know which phases will occur before which others. This is used for+sanity checking, to ensure that the pipeline will stop at some point (see+DriverPipeline.runPipeline).++A < B iff A occurs before B in a normal compilation pipeline.++There is explicitly not a total ordering on phases, because in registerised+builds, the phase `HsC` doesn't happen before nor after any other phase.++Although we check that a normal user doesn't set the stop_phase to HsC through+use of -C with registerised builds (in Main.checkOptions), it is still+possible for a ghc-api user to do so. So be careful when using the function+happensBefore, and don't think that `not (a <= b)` implies `b < a`.+-}+happensBefore :: DynFlags -> Phase -> Phase -> Bool+happensBefore dflags p1 p2 = p1 `happensBefore'` p2+    where StopLn `happensBefore'` _ = False+          x      `happensBefore'` y = after_x `eqPhase` y+                                   || after_x `happensBefore'` y+              where after_x = nextPhase dflags x++nextPhase :: DynFlags -> Phase -> Phase+nextPhase dflags p+    -- A conservative approximation to the next phase, used in happensBefore+    = case p of+      Unlit sf   -> Cpp  sf+      Cpp   sf   -> HsPp sf+      HsPp  sf   -> Hsc  sf+      Hsc   _    -> maybeHCc+      Splitter   -> SplitAs+      LlvmOpt    -> LlvmLlc+      LlvmLlc    -> LlvmMangle+      LlvmMangle -> As False+      SplitAs    -> MergeForeign+      As _       -> MergeForeign+      Ccxx       -> As False+      Cc         -> As False+      Cobjc      -> As False+      Cobjcxx    -> As False+      CmmCpp     -> Cmm+      Cmm        -> maybeHCc+      HCc        -> As False+      MergeForeign -> StopLn+      StopLn     -> panic "nextPhase: nothing after StopLn"+    where maybeHCc = if platformUnregisterised (targetPlatform dflags)+                     then HCc+                     else As False++-- the first compilation phase for a given file is determined+-- by its suffix.+startPhase :: String -> Phase+startPhase "lhs"      = Unlit HsSrcFile+startPhase "lhs-boot" = Unlit HsBootFile+startPhase "lhsig"    = Unlit HsigFile+startPhase "hs"       = Cpp   HsSrcFile+startPhase "hs-boot"  = Cpp   HsBootFile+startPhase "hsig"     = Cpp   HsigFile+startPhase "hscpp"    = HsPp  HsSrcFile+startPhase "hspp"     = Hsc   HsSrcFile+startPhase "hc"       = HCc+startPhase "c"        = Cc+startPhase "cpp"      = Ccxx+startPhase "C"        = Cc+startPhase "m"        = Cobjc+startPhase "M"        = Cobjcxx+startPhase "mm"       = Cobjcxx+startPhase "cc"       = Ccxx+startPhase "cxx"      = Ccxx+startPhase "split_s"  = Splitter+startPhase "s"        = As False+startPhase "S"        = As True+startPhase "ll"       = LlvmOpt+startPhase "bc"       = LlvmLlc+startPhase "lm_s"     = LlvmMangle+startPhase "o"        = StopLn+startPhase "cmm"      = CmmCpp+startPhase "cmmcpp"   = Cmm+startPhase _          = StopLn     -- all unknown file types++-- This is used to determine the extension for the output from the+-- current phase (if it generates a new file).  The extension depends+-- on the next phase in the pipeline.+phaseInputExt :: Phase -> String+phaseInputExt (Unlit HsSrcFile)   = "lhs"+phaseInputExt (Unlit HsBootFile)  = "lhs-boot"+phaseInputExt (Unlit HsigFile)    = "lhsig"+phaseInputExt (Cpp   _)           = "lpp"       -- intermediate only+phaseInputExt (HsPp  _)           = "hscpp"     -- intermediate only+phaseInputExt (Hsc   _)           = "hspp"      -- intermediate only+        -- NB: as things stand, phaseInputExt (Hsc x) must not evaluate x+        --     because runPipeline uses the StopBefore phase to pick the+        --     output filename.  That could be fixed, but watch out.+phaseInputExt HCc                 = "hc"+phaseInputExt Ccxx                = "cpp"+phaseInputExt Cobjc               = "m"+phaseInputExt Cobjcxx             = "mm"+phaseInputExt Cc                  = "c"+phaseInputExt Splitter            = "split_s"+phaseInputExt (As True)           = "S"+phaseInputExt (As False)          = "s"+phaseInputExt LlvmOpt             = "ll"+phaseInputExt LlvmLlc             = "bc"+phaseInputExt LlvmMangle          = "lm_s"+phaseInputExt SplitAs             = "split_s"+phaseInputExt CmmCpp              = "cmm"+phaseInputExt Cmm                 = "cmmcpp"+phaseInputExt MergeForeign        = "o"+phaseInputExt StopLn              = "o"++haskellish_src_suffixes, backpackish_suffixes, haskellish_suffixes, cish_suffixes,+    haskellish_user_src_suffixes, haskellish_sig_suffixes+ :: [String]+-- When a file with an extension in the haskellish_src_suffixes group is+-- loaded in --make mode, its imports will be loaded too.+haskellish_src_suffixes      = haskellish_user_src_suffixes +++                               [ "hspp", "hscpp" ]+haskellish_suffixes          = haskellish_src_suffixes +++                               [ "hc", "cmm", "cmmcpp" ]+cish_suffixes                = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc", "lm_s", "m", "M", "mm" ]++-- Will not be deleted as temp files:+haskellish_user_src_suffixes =+  haskellish_sig_suffixes ++ [ "hs", "lhs", "hs-boot", "lhs-boot" ]+haskellish_sig_suffixes      = [ "hsig", "lhsig" ]+backpackish_suffixes         = [ "bkp" ]++objish_suffixes :: Platform -> [String]+-- Use the appropriate suffix for the system on which+-- the GHC-compiled code will run+objish_suffixes platform = case platformOS platform of+  OSMinGW32 -> [ "o", "O", "obj", "OBJ" ]+  _         -> [ "o" ]++dynlib_suffixes :: Platform -> [String]+dynlib_suffixes platform = case platformOS platform of+  OSMinGW32 -> ["dll", "DLL"]+  OSDarwin  -> ["dylib", "so"]+  _         -> ["so"]++isHaskellishSuffix, isBackpackishSuffix, isHaskellSrcSuffix, isCishSuffix,+    isHaskellUserSrcSuffix, isHaskellSigSuffix+ :: String -> Bool+isHaskellishSuffix     s = s `elem` haskellish_suffixes+isBackpackishSuffix    s = s `elem` backpackish_suffixes+isHaskellSigSuffix     s = s `elem` haskellish_sig_suffixes+isHaskellSrcSuffix     s = s `elem` haskellish_src_suffixes+isCishSuffix           s = s `elem` cish_suffixes+isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes++isObjectSuffix, isDynLibSuffix :: Platform -> String -> Bool+isObjectSuffix platform s = s `elem` objish_suffixes platform+isDynLibSuffix platform s = s `elem` dynlib_suffixes platform++isSourceSuffix :: String -> Bool+isSourceSuffix suff  = isHaskellishSuffix suff+                    || isCishSuffix suff+                    || isBackpackishSuffix suff++-- | When we are given files (modified by -x arguments) we need+-- to determine if they are Haskellish or not to figure out+-- how we should try to compile it.  The rules are:+--+--      1. If no -x flag was specified, we check to see if+--         the file looks like a module name, has no extension,+--         or has a Haskell source extension.+--+--      2. If an -x flag was specified, we just make sure the+--         specified suffix is a Haskell one.+isHaskellishTarget :: (String, Maybe Phase) -> Bool+isHaskellishTarget (f,Nothing) =+  looksLikeModuleName f || isHaskellSrcFilename f || not (hasExtension f)+isHaskellishTarget (_,Just phase) =+  phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm+                  , StopLn]++isHaskellishFilename, isHaskellSrcFilename, isCishFilename,+    isHaskellUserSrcFilename, isSourceFilename, isHaskellSigFilename+ :: FilePath -> Bool+-- takeExtension return .foo, so we drop 1 to get rid of the .+isHaskellishFilename     f = isHaskellishSuffix     (drop 1 $ takeExtension f)+isHaskellSrcFilename     f = isHaskellSrcSuffix     (drop 1 $ takeExtension f)+isCishFilename           f = isCishSuffix           (drop 1 $ takeExtension f)+isHaskellUserSrcFilename f = isHaskellUserSrcSuffix (drop 1 $ takeExtension f)+isSourceFilename         f = isSourceSuffix         (drop 1 $ takeExtension f)+isHaskellSigFilename     f = isHaskellSigSuffix     (drop 1 $ takeExtension f)++isObjectFilename, isDynLibFilename :: Platform -> FilePath -> Bool+isObjectFilename platform f = isObjectSuffix platform (drop 1 $ takeExtension f)+isDynLibFilename platform f = isDynLibSuffix platform (drop 1 $ takeExtension f)+
+ main/DriverPipeline.hs view
@@ -0,0 +1,2411 @@+{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation #-}+{-# OPTIONS_GHC -fno-cse #-}+-- -fno-cse is needed for GLOBAL_VAR's to behave properly++-----------------------------------------------------------------------------+--+-- GHC Driver+--+-- (c) The University of Glasgow 2005+--+-----------------------------------------------------------------------------++module DriverPipeline (+        -- Run a series of compilation steps in a pipeline, for a+        -- collection of source files.+   oneShot, compileFile,++        -- Interfaces for the batch-mode driver+   linkBinary,++        -- Interfaces for the compilation manager (interpreted/batch-mode)+   preprocess,+   compileOne, compileOne',+   link,++        -- Exports for hooks to override runPhase and link+   PhasePlus(..), CompPipeline(..), PipeEnv(..), PipeState(..),+   phaseOutputFilename, getOutputFilename, getPipeState, getPipeEnv,+   hscPostBackendPhase, getLocation, setModLocation, setDynFlags,+   runPhase, exeFileName,+   mkExtraObjToLinkIntoBinary, mkNoteObjsToLinkIntoBinary,+   maybeCreateManifest,+   linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode+  ) where++#include "HsVersions.h"++import PipelineMonad+import Packages+import HeaderInfo+import DriverPhases+import SysTools+import Elf+import HscMain+import Finder+import HscTypes hiding ( Hsc )+import Outputable+import Module+import ErrUtils+import DynFlags+import Config+import Panic+import Util+import StringBuffer     ( hGetStringBuffer )+import BasicTypes       ( SuccessFlag(..) )+import Maybes           ( expectJust )+import SrcLoc+import LlvmCodeGen      ( llvmFixupAsm )+import MonadUtils+import Platform+import TcRnTypes+import Hooks+import qualified GHC.LanguageExtensions as LangExt++import Exception+import System.Directory+import System.FilePath+import System.IO+import Control.Monad+import Data.List        ( isSuffixOf )+import Data.Maybe+import Data.Version++-- ---------------------------------------------------------------------------+-- Pre-process++-- | Just preprocess a file, put the result in a temp. file (used by the+-- compilation manager during the summary phase).+--+-- We return the augmented DynFlags, because they contain the result+-- of slurping in the OPTIONS pragmas++preprocess :: HscEnv+           -> (FilePath, Maybe Phase) -- ^ filename and starting phase+           -> IO (DynFlags, FilePath)+preprocess hsc_env (filename, mb_phase) =+  ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename)+  runPipeline anyHsc hsc_env (filename, fmap RealPhase mb_phase)+        Nothing Temporary Nothing{-no ModLocation-} []{-no foreign objects-}++-- ---------------------------------------------------------------------------++-- | Compile+--+-- Compile a single module, under the control of the compilation manager.+--+-- This is the interface between the compilation manager and the+-- compiler proper (hsc), where we deal with tedious details like+-- reading the OPTIONS pragma from the source file, converting the+-- C or assembly that GHC produces into an object file, and compiling+-- FFI stub files.+--+-- NB.  No old interface can also mean that the source has changed.++compileOne :: HscEnv+           -> ModSummary      -- ^ summary for module being compiled+           -> Int             -- ^ module N ...+           -> Int             -- ^ ... of M+           -> Maybe ModIface  -- ^ old interface, if we have one+           -> Maybe Linkable  -- ^ old linkable, if we have one+           -> SourceModified+           -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful++compileOne = compileOne' Nothing (Just batchMsg)++compileOne' :: Maybe TcGblEnv+            -> Maybe Messager+            -> HscEnv+            -> ModSummary      -- ^ summary for module being compiled+            -> Int             -- ^ module N ...+            -> Int             -- ^ ... of M+            -> Maybe ModIface  -- ^ old interface, if we have one+            -> Maybe Linkable  -- ^ old linkable, if we have one+            -> SourceModified+            -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful++compileOne' m_tc_result mHscMessage+            hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable+            source_modified0+ = do++   debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp)++   (status, hmi0) <- hscIncrementalCompile+                        always_do_basic_recompilation_check+                        m_tc_result mHscMessage+                        hsc_env summary source_modified mb_old_iface (mod_index, nmods)++   let flags = hsc_dflags hsc_env0+     in do unless (gopt Opt_KeepHiFiles flags) $+               addFilesToClean flags [ml_hi_file $ ms_location summary]+           unless (gopt Opt_KeepOFiles flags) $+               addFilesToClean flags [ml_obj_file $ ms_location summary]++   case (status, hsc_lang) of+        (HscUpToDate, _) ->+            -- TODO recomp014 triggers this assert. What's going on?!+            -- ASSERT( isJust maybe_old_linkable || isNoLink (ghcLink dflags) )+            return hmi0 { hm_linkable = maybe_old_linkable }+        (HscNotGeneratingCode, HscNothing) ->+            let mb_linkable = if isHsBootOrSig src_flavour+                                then Nothing+                                -- TODO: Questionable.+                                else Just (LM (ms_hs_date summary) this_mod [])+            in return hmi0 { hm_linkable = mb_linkable }+        (HscNotGeneratingCode, _) -> panic "compileOne HscNotGeneratingCode"+        (_, HscNothing) -> panic "compileOne HscNothing"+        (HscUpdateBoot, HscInterpreted) -> do+            return hmi0+        (HscUpdateBoot, _) -> do+            touchObjectFile dflags object_filename+            return hmi0+        (HscUpdateSig, HscInterpreted) ->+            let linkable = LM (ms_hs_date summary) this_mod []+            in return hmi0 { hm_linkable = Just linkable }+        (HscUpdateSig, _) -> do+            output_fn <- getOutputFilename next_phase+                            Temporary basename dflags next_phase (Just location)++            -- #10660: Use the pipeline instead of calling+            -- compileEmptyStub directly, so -dynamic-too gets+            -- handled properly+            _ <- runPipeline StopLn hsc_env+                              (output_fn,+                               Just (HscOut src_flavour+                                            mod_name HscUpdateSig))+                              (Just basename)+                              Persistent+                              (Just location)+                              []+            o_time <- getModificationUTCTime object_filename+            let linkable = LM o_time this_mod [DotO object_filename]+            return hmi0 { hm_linkable = Just linkable }+        (HscRecomp cgguts summary, HscInterpreted) -> do+            (hasStub, comp_bc, spt_entries) <-+                hscInteractive hsc_env cgguts summary++            stub_o <- case hasStub of+                      Nothing -> return []+                      Just stub_c -> do+                          stub_o <- compileStub hsc_env stub_c+                          return [DotO stub_o]++            let hs_unlinked = [BCOs comp_bc spt_entries]+                unlinked_time = ms_hs_date summary+              -- Why do we use the timestamp of the source file here,+              -- rather than the current time?  This works better in+              -- the case where the local clock is out of sync+              -- with the filesystem's clock.  It's just as accurate:+              -- if the source is modified, then the linkable will+              -- be out of date.+            let linkable = LM unlinked_time (ms_mod summary)+                           (hs_unlinked ++ stub_o)+            return hmi0 { hm_linkable = Just linkable }+        (HscRecomp cgguts summary, _) -> do+            output_fn <- getOutputFilename next_phase+                            Temporary basename dflags next_phase (Just location)+            -- We're in --make mode: finish the compilation pipeline.+            _ <- runPipeline StopLn hsc_env+                              (output_fn,+                               Just (HscOut src_flavour mod_name (HscRecomp cgguts summary)))+                              (Just basename)+                              Persistent+                              (Just location)+                              []+                  -- The object filename comes from the ModLocation+            o_time <- getModificationUTCTime object_filename+            let linkable = LM o_time this_mod [DotO object_filename]+            return hmi0 { hm_linkable = Just linkable }++ where dflags0     = ms_hspp_opts summary++       this_mod    = ms_mod summary+       location    = ms_location summary+       input_fn    = expectJust "compile:hs" (ml_hs_file location)+       input_fnpp  = ms_hspp_file summary+       mod_graph   = hsc_mod_graph hsc_env0+       needsTH     = any (xopt LangExt.TemplateHaskell . ms_hspp_opts) mod_graph+       needsQQ     = any (xopt LangExt.QuasiQuotes     . ms_hspp_opts) mod_graph+       needsLinker = needsTH || needsQQ+       isDynWay    = any (== WayDyn) (ways dflags0)+       isProfWay   = any (== WayProf) (ways dflags0)+       internalInterpreter = not (gopt Opt_ExternalInterpreter dflags0)++       src_flavour = ms_hsc_src summary+       mod_name = ms_mod_name summary+       next_phase = hscPostBackendPhase dflags src_flavour hsc_lang+       object_filename = ml_obj_file location++       -- #8180 - when using TemplateHaskell, switch on -dynamic-too so+       -- the linker can correctly load the object files.  This isn't necessary+       -- when using -fexternal-interpreter.+       dflags1 = if needsLinker && dynamicGhc && internalInterpreter &&+                    not isDynWay && not isProfWay+                  then gopt_set dflags0 Opt_BuildDynamicToo+                  else dflags0++       basename = dropExtension input_fn++       -- We add the directory in which the .hs files resides) to the import+       -- path.  This is needed when we try to compile the .hc file later, if it+       -- imports a _stub.h file that we created here.+       current_dir = takeDirectory basename+       old_paths   = includePaths dflags1+       prevailing_dflags = hsc_dflags hsc_env0+       dflags =+          dflags1 { includePaths = current_dir : old_paths+                  , log_action = log_action prevailing_dflags+                  , log_finaliser = log_finaliser prevailing_dflags }+                  -- use the prevailing log_action / log_finaliser,+                  -- not the one cached in the summary.  This is so+                  -- that we can change the log_action without having+                  -- to re-summarize all the source files.+       hsc_env     = hsc_env0 {hsc_dflags = dflags}++       -- Figure out what lang we're generating+       hsc_lang = hscTarget dflags++       -- -fforce-recomp should also work with --make+       force_recomp = gopt Opt_ForceRecomp dflags+       source_modified+         | force_recomp = SourceModified+         | otherwise = source_modified0++       always_do_basic_recompilation_check = case hsc_lang of+                                             HscInterpreted -> True+                                             _ -> False++-----------------------------------------------------------------------------+-- stub .h and .c files (for foreign export support), and cc files.++-- The _stub.c file is derived from the haskell source file, possibly taking+-- into account the -stubdir option.+--+-- The object file created by compiling the _stub.c file is put into a+-- temporary file, which will be later combined with the main .o file+-- (see the MergeForeigns phase).+--+-- Moreover, we also let the user emit arbitrary C/C++/ObjC/ObjC++ files+-- from TH, that are then compiled and linked to the module. This is+-- useful to implement facilities such as inline-c.++compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath+compileForeign hsc_env lang stub_c = do+        let phase = case lang of+              LangC -> Cc+              LangCxx -> Ccxx+              LangObjc -> Cobjc+              LangObjcxx -> Cobjcxx+        (_, stub_o) <- runPipeline StopLn hsc_env+                       (stub_c, Just (RealPhase phase))+                       Nothing Temporary Nothing{-no ModLocation-} []++        return stub_o++compileStub :: HscEnv -> FilePath -> IO FilePath+compileStub hsc_env stub_c = compileForeign hsc_env LangC stub_c++compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()+compileEmptyStub dflags hsc_env basename location mod_name = do+  -- To maintain the invariant that every Haskell file+  -- compiles to object code, we make an empty (but+  -- valid) stub object file for signatures.  However,+  -- we make sure this object file has a unique symbol,+  -- so that ranlib on OS X doesn't complain, see+  -- http://ghc.haskell.org/trac/ghc/ticket/12673+  -- and https://github.com/haskell/cabal/issues/2257+  empty_stub <- newTempName dflags "c"+  let src = text "int" <+> ppr (mkModule (thisPackage dflags) mod_name) <+> text "= 0;"+  writeFile empty_stub (showSDoc dflags (pprCode CStyle src))+  _ <- runPipeline StopLn hsc_env+                  (empty_stub, Nothing)+                  (Just basename)+                  Persistent+                  (Just location)+                  []+  return ()++-- ---------------------------------------------------------------------------+-- Link++link :: GhcLink                 -- interactive or batch+     -> DynFlags                -- dynamic flags+     -> Bool                    -- attempt linking in batch mode?+     -> HomePackageTable        -- what to link+     -> IO SuccessFlag++-- For the moment, in the batch linker, we don't bother to tell doLink+-- which packages to link -- it just tries all that are available.+-- batch_attempt_linking should only be *looked at* in batch mode.  It+-- should only be True if the upsweep was successful and someone+-- exports main, i.e., we have good reason to believe that linking+-- will succeed.++link ghcLink dflags+  = lookupHook linkHook l dflags ghcLink dflags+  where+    l LinkInMemory _ _ _+      = if cGhcWithInterpreter == "YES"+        then -- Not Linking...(demand linker will do the job)+             return Succeeded+        else panicBadLink LinkInMemory++    l NoLink _ _ _+      = return Succeeded++    l LinkBinary dflags batch_attempt_linking hpt+      = link' dflags batch_attempt_linking hpt++    l LinkStaticLib dflags batch_attempt_linking hpt+      = link' dflags batch_attempt_linking hpt++    l LinkDynLib dflags batch_attempt_linking hpt+      = link' dflags batch_attempt_linking hpt++panicBadLink :: GhcLink -> a+panicBadLink other = panic ("link: GHC not built to link this way: " +++                            show other)++link' :: DynFlags                -- dynamic flags+      -> Bool                    -- attempt linking in batch mode?+      -> HomePackageTable        -- what to link+      -> IO SuccessFlag++link' dflags batch_attempt_linking hpt+   | batch_attempt_linking+   = do+        let+            staticLink = case ghcLink dflags of+                          LinkStaticLib -> True+                          _ -> platformBinariesAreStaticLibs (targetPlatform dflags)++            home_mod_infos = eltsHpt hpt++            -- the packages we depend on+            pkg_deps  = concatMap (map fst . dep_pkgs . mi_deps . hm_iface) home_mod_infos++            -- the linkables to link+            linkables = map (expectJust "link".hm_linkable) home_mod_infos++        debugTraceMsg dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables))++        -- check for the -no-link flag+        if isNoLink (ghcLink dflags)+          then do debugTraceMsg dflags 3 (text "link(batch): linking omitted (-c flag given).")+                  return Succeeded+          else do++        let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)+            obj_files = concatMap getOfiles linkables++            exe_file = exeFileName staticLink dflags++        linking_needed <- linkingNeeded dflags staticLink linkables pkg_deps++        if not (gopt Opt_ForceRecomp dflags) && not linking_needed+           then do debugTraceMsg dflags 2 (text exe_file <+> text "is up to date, linking not required.")+                   return Succeeded+           else do++        compilationProgressMsg dflags ("Linking " ++ exe_file ++ " ...")++        -- Don't showPass in Batch mode; doLink will do that for us.+        let link = case ghcLink dflags of+                LinkBinary    -> linkBinary+                LinkStaticLib -> linkStaticLibCheck+                LinkDynLib    -> linkDynLibCheck+                other         -> panicBadLink other+        link dflags obj_files pkg_deps++        debugTraceMsg dflags 3 (text "link: done")++        -- linkBinary only returns if it succeeds+        return Succeeded++   | otherwise+   = do debugTraceMsg dflags 3 (text "link(batch): upsweep (partially) failed OR" $$+                                text "   Main.main not exported; not linking.")+        return Succeeded+++linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [InstalledUnitId] -> IO Bool+linkingNeeded dflags staticLink linkables pkg_deps = do+        -- if the modification time on the executable is later than the+        -- modification times on all of the objects and libraries, then omit+        -- linking (unless the -fforce-recomp flag was given).+  let exe_file = exeFileName staticLink dflags+  e_exe_time <- tryIO $ getModificationUTCTime exe_file+  case e_exe_time of+    Left _  -> return True+    Right t -> do+        -- first check object files and extra_ld_inputs+        let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]+        e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs+        let (errs,extra_times) = splitEithers e_extra_times+        let obj_times =  map linkableTime linkables ++ extra_times+        if not (null errs) || any (t <) obj_times+            then return True+            else do++        -- next, check libraries. XXX this only checks Haskell libraries,+        -- not extra_libraries or -l things from the command line.+        let pkg_hslibs  = [ (collectLibraryPaths dflags [c], lib)+                          | Just c <- map (lookupInstalledPackage dflags) pkg_deps,+                            lib <- packageHsLibs dflags c ]++        pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs+        if any isNothing pkg_libfiles then return True else do+        e_lib_times <- mapM (tryIO . getModificationUTCTime)+                          (catMaybes pkg_libfiles)+        let (lib_errs,lib_times) = splitEithers e_lib_times+        if not (null lib_errs) || any (t <) lib_times+           then return True+           else checkLinkInfo dflags pkg_deps exe_file++-- Returns 'False' if it was, and we can avoid linking, because the+-- previous binary was linked with "the same options".+checkLinkInfo :: DynFlags -> [InstalledUnitId] -> FilePath -> IO Bool+checkLinkInfo dflags pkg_deps exe_file+ | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))+ -- ToDo: Windows and OS X do not use the ELF binary format, so+ -- readelf does not work there.  We need to find another way to do+ -- this.+ = return False -- conservatively we should return True, but not+                -- linking in this case was the behaviour for a long+                -- time so we leave it as-is.+ | otherwise+ = do+   link_info <- getLinkInfo dflags pkg_deps+   debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info)+   m_exe_link_info <- readElfNoteAsString dflags exe_file+                          ghcLinkInfoSectionName ghcLinkInfoNoteName+   let sameLinkInfo = (Just link_info == m_exe_link_info)+   debugTraceMsg dflags 3 $ case m_exe_link_info of+     Nothing -> text "Exe link info: Not found"+     Just s+       | sameLinkInfo -> text ("Exe link info is the same")+       | otherwise    -> text ("Exe link info is different: " ++ s)+   return (not sameLinkInfo)++platformSupportsSavingLinkOpts :: OS -> Bool+platformSupportsSavingLinkOpts os+  | os == OSSolaris2 = False -- see #5382+  | otherwise        = osElfTarget os++-- See Note [LinkInfo section]+ghcLinkInfoSectionName :: String+ghcLinkInfoSectionName = ".debug-ghc-link-info"+   -- if we use the ".debug" prefix, then strip will strip it by default++-- Identifier for the note (see Note [LinkInfo section])+ghcLinkInfoNoteName :: String+ghcLinkInfoNoteName = "GHC link info"++findHSLib :: DynFlags -> [String] -> String -> IO (Maybe FilePath)+findHSLib dflags dirs lib = do+  let batch_lib_file = if WayDyn `notElem` ways dflags+                       then "lib" ++ lib <.> "a"+                       else mkSOName (targetPlatform dflags) lib+  found <- filterM doesFileExist (map (</> batch_lib_file) dirs)+  case found of+    [] -> return Nothing+    (x:_) -> return (Just x)++-- -----------------------------------------------------------------------------+-- Compile files in one-shot mode.++oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO ()+oneShot hsc_env stop_phase srcs = do+  o_files <- mapM (compileFile hsc_env stop_phase) srcs+  doLink (hsc_dflags hsc_env) stop_phase o_files++compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath+compileFile hsc_env stop_phase (src, mb_phase) = do+   exists <- doesFileExist src+   when (not exists) $+        throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src))++   let+        dflags    = hsc_dflags hsc_env+        split     = gopt Opt_SplitObjs dflags+        mb_o_file = outputFile dflags+        ghc_link  = ghcLink dflags      -- Set by -c or -no-link++        -- When linking, the -o argument refers to the linker's output.+        -- otherwise, we use it as the name for the pipeline's output.+        output+         -- If we are dong -fno-code, then act as if the output is+         -- 'Temporary'. This stops GHC trying to copy files to their+         -- final location.+         | HscNothing <- hscTarget dflags = Temporary+         | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent+                -- -o foo applies to linker+         | isJust mb_o_file = SpecificFile+                -- -o foo applies to the file we are compiling now+         | otherwise = Persistent++        stop_phase' = case stop_phase of+                        As _ | split -> SplitAs+                        _            -> stop_phase++   ( _, out_file) <- runPipeline stop_phase' hsc_env+                            (src, fmap RealPhase mb_phase) Nothing output+                            Nothing{-no ModLocation-} []+   return out_file+++doLink :: DynFlags -> Phase -> [FilePath] -> IO ()+doLink dflags stop_phase o_files+  | not (isStopLn stop_phase)+  = return ()           -- We stopped before the linking phase++  | otherwise+  = case ghcLink dflags of+        NoLink        -> return ()+        LinkBinary    -> linkBinary         dflags o_files []+        LinkStaticLib -> linkStaticLibCheck dflags o_files []+        LinkDynLib    -> linkDynLibCheck    dflags o_files []+        other         -> panicBadLink other+++-- ---------------------------------------------------------------------------++-- | Run a compilation pipeline, consisting of multiple phases.+--+-- This is the interface to the compilation pipeline, which runs+-- a series of compilation steps on a single source file, specifying+-- at which stage to stop.+--+-- The DynFlags can be modified by phases in the pipeline (eg. by+-- OPTIONS_GHC pragmas), and the changes affect later phases in the+-- pipeline.+runPipeline+  :: Phase                      -- ^ When to stop+  -> HscEnv                     -- ^ Compilation environment+  -> (FilePath,Maybe PhasePlus) -- ^ Input filename (and maybe -x suffix)+  -> Maybe FilePath             -- ^ original basename (if different from ^^^)+  -> PipelineOutput             -- ^ Output filename+  -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module+  -> [FilePath]                 -- ^ foreign objects+  -> IO (DynFlags, FilePath)    -- ^ (final flags, output filename)+runPipeline stop_phase hsc_env0 (input_fn, mb_phase)+             mb_basename output maybe_loc foreign_os++    = do let+             dflags0 = hsc_dflags hsc_env0++             -- Decide where dump files should go based on the pipeline output+             dflags = dflags0 { dumpPrefix = Just (basename ++ ".") }+             hsc_env = hsc_env0 {hsc_dflags = dflags}++             (input_basename, suffix) = splitExtension input_fn+             suffix' = drop 1 suffix -- strip off the .+             basename | Just b <- mb_basename = b+                      | otherwise             = input_basename++             -- If we were given a -x flag, then use that phase to start from+             start_phase = fromMaybe (RealPhase (startPhase suffix')) mb_phase++             isHaskell (RealPhase (Unlit _)) = True+             isHaskell (RealPhase (Cpp   _)) = True+             isHaskell (RealPhase (HsPp  _)) = True+             isHaskell (RealPhase (Hsc   _)) = True+             isHaskell (HscOut {})           = True+             isHaskell _                     = False++             isHaskellishFile = isHaskell start_phase++             env = PipeEnv{ stop_phase,+                            src_filename = input_fn,+                            src_basename = basename,+                            src_suffix = suffix',+                            output_spec = output }++         when (isBackpackishSuffix suffix') $+           throwGhcExceptionIO (UsageError+                       ("use --backpack to process " ++ input_fn))++         -- We want to catch cases of "you can't get there from here" before+         -- we start the pipeline, because otherwise it will just run off the+         -- end.+         let happensBefore' = happensBefore dflags+         case start_phase of+             RealPhase start_phase' ->+                 -- See Note [Partial ordering on phases]+                 -- Not the same as: (stop_phase `happensBefore` start_phase')+                 when (not (start_phase' `happensBefore'` stop_phase ||+                            start_phase' `eqPhase` stop_phase)) $+                       throwGhcExceptionIO (UsageError+                                   ("cannot compile this file to desired target: "+                                      ++ input_fn))+             HscOut {} -> return ()++         debugTraceMsg dflags 4 (text "Running the pipeline")+         r <- runPipeline' start_phase hsc_env env input_fn+                           maybe_loc foreign_os++         -- If we are compiling a Haskell module, and doing+         -- -dynamic-too, but couldn't do the -dynamic-too fast+         -- path, then rerun the pipeline for the dyn way+         let dflags = hsc_dflags hsc_env+         -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987)+         when (not $ platformOS (targetPlatform dflags) == OSMinGW32) $ do+           when isHaskellishFile $ whenCannotGenerateDynamicToo dflags $ do+               debugTraceMsg dflags 4+                   (text "Running the pipeline again for -dynamic-too")+               let dflags' = dynamicTooMkDynamicDynFlags dflags+               hsc_env' <- newHscEnv dflags'+               _ <- runPipeline' start_phase hsc_env' env input_fn+                                 maybe_loc foreign_os+               return ()+         return r++runPipeline'+  :: PhasePlus                  -- ^ When to start+  -> HscEnv                     -- ^ Compilation environment+  -> PipeEnv+  -> FilePath                   -- ^ Input filename+  -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module+  -> [FilePath]                 -- ^ foreign objects, if we have one+  -> IO (DynFlags, FilePath)    -- ^ (final flags, output filename)+runPipeline' start_phase hsc_env env input_fn+             maybe_loc foreign_os+  = do+  -- Execute the pipeline...+  let state = PipeState{ hsc_env, maybe_loc, foreign_os = foreign_os }++  evalP (pipeLoop start_phase input_fn) env state++-- ---------------------------------------------------------------------------+-- outer pipeline loop++-- | pipeLoop runs phases until we reach the stop phase+pipeLoop :: PhasePlus -> FilePath -> CompPipeline (DynFlags, FilePath)+pipeLoop phase input_fn = do+  env <- getPipeEnv+  dflags <- getDynFlags+  -- See Note [Partial ordering on phases]+  let happensBefore' = happensBefore dflags+      stopPhase = stop_phase env+  case phase of+   RealPhase realPhase | realPhase `eqPhase` stopPhase            -- All done+     -> -- Sometimes, a compilation phase doesn't actually generate any output+        -- (eg. the CPP phase when -fcpp is not turned on).  If we end on this+        -- stage, but we wanted to keep the output, then we have to explicitly+        -- copy the file, remembering to prepend a {-# LINE #-} pragma so that+        -- further compilation stages can tell what the original filename was.+        case output_spec env of+        Temporary ->+            return (dflags, input_fn)+        output ->+            do pst <- getPipeState+               final_fn <- liftIO $ getOutputFilename+                                        stopPhase output (src_basename env)+                                        dflags stopPhase (maybe_loc pst)+               when (final_fn /= input_fn) $ do+                  let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'")+                      line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n")+                  liftIO $ copyWithHeader dflags msg line_prag input_fn final_fn+               return (dflags, final_fn)+++     | not (realPhase `happensBefore'` stopPhase)+        -- Something has gone wrong.  We'll try to cover all the cases when+        -- this could happen, so if we reach here it is a panic.+        -- eg. it might happen if the -C flag is used on a source file that+        -- has {-# OPTIONS -fasm #-}.+     -> panic ("pipeLoop: at phase " ++ show realPhase +++           " but I wanted to stop at phase " ++ show stopPhase)++   _+     -> do liftIO $ debugTraceMsg dflags 4+                                  (text "Running phase" <+> ppr phase)+           (next_phase, output_fn) <- runHookedPhase phase input_fn dflags+           r <- pipeLoop next_phase output_fn+           case phase of+               HscOut {} ->+                   whenGeneratingDynamicToo dflags $ do+                       setDynFlags $ dynamicTooMkDynamicDynFlags dflags+                       -- TODO shouldn't ignore result:+                       _ <- pipeLoop phase input_fn+                       return ()+               _ ->+                   return ()+           return r++runHookedPhase :: PhasePlus -> FilePath -> DynFlags+               -> CompPipeline (PhasePlus, FilePath)+runHookedPhase pp input dflags =+  lookupHook runPhaseHook runPhase dflags pp input dflags++-- -----------------------------------------------------------------------------+-- In each phase, we need to know into what filename to generate the+-- output.  All the logic about which filenames we generate output+-- into is embodied in the following function.++-- | Computes the next output filename after we run @next_phase@.+-- Like 'getOutputFilename', but it operates in the 'CompPipeline' monad+-- (which specifies all of the ambient information.)+phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath+phaseOutputFilename next_phase = do+  PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv+  PipeState{maybe_loc, hsc_env} <- getPipeState+  let dflags = hsc_dflags hsc_env+  liftIO $ getOutputFilename stop_phase output_spec+                             src_basename dflags next_phase maybe_loc++-- | Computes the next output filename for something in the compilation+-- pipeline.  This is controlled by several variables:+--+--      1. 'Phase': the last phase to be run (e.g. 'stopPhase').  This+--         is used to tell if we're in the last phase or not, because+--         in that case flags like @-o@ may be important.+--      2. 'PipelineOutput': is this intended to be a 'Temporary' or+--         'Persistent' build output?  Temporary files just go in+--         a fresh temporary name.+--      3. 'String': what was the basename of the original input file?+--      4. 'DynFlags': the obvious thing+--      5. 'Phase': the phase we want to determine the output filename of.+--      6. @Maybe ModLocation@: the 'ModLocation' of the module we're+--         compiling; this can be used to override the default output+--         of an object file.  (TODO: do we actually need this?)+getOutputFilename+  :: Phase -> PipelineOutput -> String+  -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath+getOutputFilename stop_phase output basename dflags next_phase maybe_location+ | is_last_phase, Persistent   <- output = persistent_fn+ | is_last_phase, SpecificFile <- output = case outputFile dflags of+                                           Just f -> return f+                                           Nothing ->+                                               panic "SpecificFile: No filename"+ | keep_this_output                      = persistent_fn+ | otherwise                             = newTempName dflags suffix+    where+          hcsuf      = hcSuf dflags+          odir       = objectDir dflags+          osuf       = objectSuf dflags+          keep_hc    = gopt Opt_KeepHcFiles dflags+          keep_s     = gopt Opt_KeepSFiles dflags+          keep_bc    = gopt Opt_KeepLlvmFiles dflags++          myPhaseInputExt HCc       = hcsuf+          myPhaseInputExt MergeForeign = osuf+          myPhaseInputExt StopLn    = osuf+          myPhaseInputExt other     = phaseInputExt other++          is_last_phase = next_phase `eqPhase` stop_phase++          -- sometimes, we keep output from intermediate stages+          keep_this_output =+               case next_phase of+                       As _    | keep_s     -> True+                       LlvmOpt | keep_bc    -> True+                       HCc     | keep_hc    -> True+                       _other               -> False++          suffix = myPhaseInputExt next_phase++          -- persistent object files get put in odir+          persistent_fn+             | StopLn <- next_phase = return odir_persistent+             | otherwise            = return persistent++          persistent = basename <.> suffix++          odir_persistent+             | Just loc <- maybe_location = ml_obj_file loc+             | Just d <- odir = d </> persistent+             | otherwise      = persistent++-- -----------------------------------------------------------------------------+-- | Each phase in the pipeline returns the next phase to execute, and the+-- name of the file in which the output was placed.+--+-- We must do things dynamically this way, because we often don't know+-- what the rest of the phases will be until part-way through the+-- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning+-- of a source file can change the latter stages of the pipeline from+-- taking the LLVM route to using the native code generator.+--+runPhase :: PhasePlus   -- ^ Run this phase+         -> FilePath    -- ^ name of the input file+         -> DynFlags    -- ^ for convenience, we pass the current dflags in+         -> CompPipeline (PhasePlus,           -- next phase to run+                          FilePath)            -- output filename++        -- Invariant: the output filename always contains the output+        -- Interesting case: Hsc when there is no recompilation to do+        --                   Then the output filename is still a .o file+++-------------------------------------------------------------------------------+-- Unlit phase++runPhase (RealPhase (Unlit sf)) input_fn dflags+  = do+       output_fn <- phaseOutputFilename (Cpp sf)++       let flags = [ -- The -h option passes the file name for unlit to+                     -- put in a #line directive+                     SysTools.Option     "-h"+                     -- See Note [Don't normalise input filenames].+                   , SysTools.Option $ escape input_fn+                   , SysTools.FileOption "" input_fn+                   , SysTools.FileOption "" output_fn+                   ]++       liftIO $ SysTools.runUnlit dflags flags++       return (RealPhase (Cpp sf), output_fn)+  where+       -- escape the characters \, ", and ', but don't try to escape+       -- Unicode or anything else (so we don't use Util.charToC+       -- here).  If we get this wrong, then in+       -- Coverage.isGoodTickSrcSpan where we check that the filename in+       -- a SrcLoc is the same as the source filenaame, the two will+       -- look bogusly different. See test:+       -- libraries/hpc/tests/function/subdir/tough2.hs+       escape ('\\':cs) = '\\':'\\': escape cs+       escape ('\"':cs) = '\\':'\"': escape cs+       escape ('\'':cs) = '\\':'\'': escape cs+       escape (c:cs)    = c : escape cs+       escape []        = []++-------------------------------------------------------------------------------+-- Cpp phase : (a) gets OPTIONS out of file+--             (b) runs cpp if necessary++runPhase (RealPhase (Cpp sf)) input_fn dflags0+  = do+       src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn+       (dflags1, unhandled_flags, warns)+           <- liftIO $ parseDynamicFilePragma dflags0 src_opts+       setDynFlags dflags1+       liftIO $ checkProcessArgsResult dflags1 unhandled_flags++       if not (xopt LangExt.Cpp dflags1) then do+           -- we have to be careful to emit warnings only once.+           unless (gopt Opt_Pp dflags1) $+               liftIO $ handleFlagWarnings dflags1 warns++           -- no need to preprocess CPP, just pass input file along+           -- to the next phase of the pipeline.+           return (RealPhase (HsPp sf), input_fn)+        else do+            output_fn <- phaseOutputFilename (HsPp sf)+            liftIO $ doCpp dflags1 True{-raw-}+                           input_fn output_fn+            -- re-read the pragmas now that we've preprocessed the file+            -- See #2464,#3457+            src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn+            (dflags2, unhandled_flags, warns)+                <- liftIO $ parseDynamicFilePragma dflags0 src_opts+            liftIO $ checkProcessArgsResult dflags2 unhandled_flags+            unless (gopt Opt_Pp dflags2) $+                liftIO $ handleFlagWarnings dflags2 warns+            -- the HsPp pass below will emit warnings++            setDynFlags dflags2++            return (RealPhase (HsPp sf), output_fn)++-------------------------------------------------------------------------------+-- HsPp phase++runPhase (RealPhase (HsPp sf)) input_fn dflags+  = do+       if not (gopt Opt_Pp dflags) then+           -- no need to preprocess, just pass input file along+           -- to the next phase of the pipeline.+          return (RealPhase (Hsc sf), input_fn)+        else do+            PipeEnv{src_basename, src_suffix} <- getPipeEnv+            let orig_fn = src_basename <.> src_suffix+            output_fn <- phaseOutputFilename (Hsc sf)+            liftIO $ SysTools.runPp dflags+                           ( [ SysTools.Option     orig_fn+                             , SysTools.Option     input_fn+                             , SysTools.FileOption "" output_fn+                             ]+                           )++            -- re-read pragmas now that we've parsed the file (see #3674)+            src_opts <- liftIO $ getOptionsFromFile dflags output_fn+            (dflags1, unhandled_flags, warns)+                <- liftIO $ parseDynamicFilePragma dflags src_opts+            setDynFlags dflags1+            liftIO $ checkProcessArgsResult dflags1 unhandled_flags+            liftIO $ handleFlagWarnings dflags1 warns++            return (RealPhase (Hsc sf), output_fn)++-----------------------------------------------------------------------------+-- Hsc phase++-- Compilation of a single module, in "legacy" mode (_not_ under+-- the direction of the compilation manager).+runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0+ = do   -- normal Hsc mode, not mkdependHS++        PipeEnv{ stop_phase=stop,+                 src_basename=basename,+                 src_suffix=suff } <- getPipeEnv++  -- we add the current directory (i.e. the directory in which+  -- the .hs files resides) to the include path, since this is+  -- what gcc does, and it's probably what you want.+        let current_dir = takeDirectory basename+            paths = includePaths dflags0+            dflags = dflags0 { includePaths = current_dir : paths }++        setDynFlags dflags++  -- gather the imports and module name+        (hspp_buf,mod_name,imps,src_imps) <- liftIO $ do+          do+            buf <- hGetStringBuffer input_fn+            (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff)+            return (Just buf, mod_name, imps, src_imps)++  -- Take -o into account if present+  -- Very like -ohi, but we must *only* do this if we aren't linking+  -- (If we're linking then the -o applies to the linked thing, not to+  -- the object file for one module.)+  -- Note the nasty duplication with the same computation in compileFile above+        location <- getLocation src_flavour mod_name++        let o_file = ml_obj_file location -- The real object file+            hi_file = ml_hi_file location+            dest_file | writeInterfaceOnlyMode dflags+                            = hi_file+                      | otherwise+                            = o_file++  -- Figure out if the source has changed, for recompilation avoidance.+  --+  -- Setting source_unchanged to True means that M.o seems+  -- to be up to date wrt M.hs; so no need to recompile unless imports have+  -- changed (which the compiler itself figures out).+  -- Setting source_unchanged to False tells the compiler that M.o is out of+  -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.+        src_timestamp <- liftIO $ getModificationUTCTime (basename <.> suff)++        source_unchanged <- liftIO $+          if not (isStopLn stop)+                -- SourceModified unconditionally if+                --      (a) recompilation checker is off, or+                --      (b) we aren't going all the way to .o file (e.g. ghc -S)+             then return SourceModified+                -- Otherwise look at file modification dates+             else do dest_file_exists <- doesFileExist dest_file+                     if not dest_file_exists+                        then return SourceModified       -- Need to recompile+                        else do t2 <- getModificationUTCTime dest_file+                                if t2 > src_timestamp+                                  then return SourceUnmodified+                                  else return SourceModified++        PipeState{hsc_env=hsc_env'} <- getPipeState++  -- Tell the finder cache about this module+        mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location++  -- Make the ModSummary to hand to hscMain+        let+            mod_summary = ModSummary {  ms_mod       = mod,+                                        ms_hsc_src   = src_flavour,+                                        ms_hspp_file = input_fn,+                                        ms_hspp_opts = dflags,+                                        ms_hspp_buf  = hspp_buf,+                                        ms_location  = location,+                                        ms_hs_date   = src_timestamp,+                                        ms_obj_date  = Nothing,+                                        ms_parsed_mod   = Nothing,+                                        ms_iface_date   = Nothing,+                                        ms_textual_imps = imps,+                                        ms_srcimps      = src_imps }++  -- run the compiler!+        let msg hsc_env _ what _ = oneShotMsg hsc_env what+        (result, _) <- liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env'+                            mod_summary source_unchanged Nothing (1,1)++        return (HscOut src_flavour mod_name result,+                panic "HscOut doesn't have an input filename")++runPhase (HscOut src_flavour mod_name result) _ dflags = do+        location <- getLocation src_flavour mod_name+        setModLocation location++        let o_file = ml_obj_file location -- The real object file+            hsc_lang = hscTarget dflags+            next_phase = hscPostBackendPhase dflags src_flavour hsc_lang++        case result of+            HscNotGeneratingCode ->+                return (RealPhase StopLn,+                        panic "No output filename from Hsc when no-code")+            HscUpToDate ->+                do liftIO $ touchObjectFile dflags o_file+                   -- The .o file must have a later modification date+                   -- than the source file (else we wouldn't get Nothing)+                   -- but we touch it anyway, to keep 'make' happy (we think).+                   return (RealPhase StopLn, o_file)+            HscUpdateBoot ->+                do -- In the case of hs-boot files, generate a dummy .o-boot+                   -- stamp file for the benefit of Make+                   liftIO $ touchObjectFile dflags o_file+                   return (RealPhase StopLn, o_file)+            HscUpdateSig ->+                do -- We need to create a REAL but empty .o file+                   -- because we are going to attempt to put it in a library+                   PipeState{hsc_env=hsc_env'} <- getPipeState+                   let input_fn = expectJust "runPhase" (ml_hs_file location)+                       basename = dropExtension input_fn+                   liftIO $ compileEmptyStub dflags hsc_env' basename location mod_name+                   return (RealPhase StopLn, o_file)+            HscRecomp cgguts mod_summary+              -> do output_fn <- phaseOutputFilename next_phase++                    PipeState{hsc_env=hsc_env'} <- getPipeState++                    (outputFilename, mStub, foreign_files) <- liftIO $+                      hscGenHardCode hsc_env' cgguts mod_summary output_fn+                    stub_o <- liftIO (mapM (compileStub hsc_env') mStub)+                    foreign_os <- liftIO $+                      mapM (uncurry (compileForeign hsc_env')) foreign_files+                    setForeignOs (maybe [] return stub_o ++ foreign_os)++                    return (RealPhase next_phase, outputFilename)++-----------------------------------------------------------------------------+-- Cmm phase++runPhase (RealPhase CmmCpp) input_fn dflags+  = do+       output_fn <- phaseOutputFilename Cmm+       liftIO $ doCpp dflags False{-not raw-}+                      input_fn output_fn+       return (RealPhase Cmm, output_fn)++runPhase (RealPhase Cmm) input_fn dflags+  = do+        let hsc_lang = hscTarget dflags++        let next_phase = hscPostBackendPhase dflags HsSrcFile hsc_lang++        output_fn <- phaseOutputFilename next_phase++        PipeState{hsc_env} <- getPipeState++        liftIO $ hscCompileCmmFile hsc_env input_fn output_fn++        return (RealPhase next_phase, output_fn)++-----------------------------------------------------------------------------+-- Cc phase++-- we don't support preprocessing .c files (with -E) now.  Doing so introduces+-- way too many hacks, and I can't say I've ever used it anyway.++runPhase (RealPhase cc_phase) input_fn dflags+   | any (cc_phase `eqPhase`) [Cc, Ccxx, HCc, Cobjc, Cobjcxx]+   = do+        let platform = targetPlatform dflags+            hcc = cc_phase `eqPhase` HCc++        let cmdline_include_paths = includePaths dflags++        -- HC files have the dependent packages stamped into them+        pkgs <- if hcc then liftIO $ getHCFilePackages input_fn else return []++        -- add package include paths even if we're just compiling .c+        -- files; this is the Value Add(TM) that using ghc instead of+        -- gcc gives you :)+        pkg_include_dirs <- liftIO $ getPackageIncludePath dflags pkgs+        let include_paths = foldr (\ x xs -> ("-I" ++ x) : xs) []+                              (cmdline_include_paths ++ pkg_include_dirs)++        let gcc_extra_viac_flags = extraGccViaCFlags dflags+        let pic_c_flags = picCCOpts dflags++        let verbFlags = getVerbFlags dflags++        -- cc-options are not passed when compiling .hc files.  Our+        -- hc code doesn't not #include any header files anyway, so these+        -- options aren't necessary.+        pkg_extra_cc_opts <- liftIO $+          if cc_phase `eqPhase` HCc+             then return []+             else getPackageExtraCcOpts dflags pkgs++        framework_paths <-+            if platformUsesFrameworks platform+            then do pkgFrameworkPaths <- liftIO $ getPackageFrameworkPath dflags pkgs+                    let cmdlineFrameworkPaths = frameworkPaths dflags+                    return $ map ("-F"++)+                                 (cmdlineFrameworkPaths ++ pkgFrameworkPaths)+            else return []++        let split_objs = gopt Opt_SplitObjs dflags+            split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ]+                      | otherwise         = [ ]++        let cc_opt | optLevel dflags >= 2 = [ "-O2" ]+                   | optLevel dflags >= 1 = [ "-O" ]+                   | otherwise            = []++        -- Decide next phase+        let next_phase = As False+        output_fn <- phaseOutputFilename next_phase++        let+          more_hcc_opts =+                -- on x86 the floating point regs have greater precision+                -- than a double, which leads to unpredictable results.+                -- By default, we turn this off with -ffloat-store unless+                -- the user specified -fexcess-precision.+                (if platformArch platform == ArchX86 &&+                    not (gopt Opt_ExcessPrecision dflags)+                        then [ "-ffloat-store" ]+                        else []) ++++                -- gcc's -fstrict-aliasing allows two accesses to memory+                -- to be considered non-aliasing if they have different types.+                -- This interacts badly with the C code we generate, which is+                -- very weakly typed, being derived from C--.+                ["-fno-strict-aliasing"]++        ghcVersionH <- liftIO $ getGhcVersionPathName dflags++        let gcc_lang_opt | cc_phase `eqPhase` Ccxx    = "c++"+                         | cc_phase `eqPhase` Cobjc   = "objective-c"+                         | cc_phase `eqPhase` Cobjcxx = "objective-c++"+                         | otherwise                  = "c"+        liftIO $ SysTools.runCc dflags (+                -- force the C compiler to interpret this file as C when+                -- compiling .hc files, by adding the -x c option.+                -- Also useful for plain .c files, just in case GHC saw a+                -- -x c option.+                        [ SysTools.Option "-x", SysTools.Option gcc_lang_opt+                        , SysTools.FileOption "" input_fn+                        , SysTools.Option "-o"+                        , SysTools.FileOption "" output_fn+                        ]+                       ++ map SysTools.Option (+                          pic_c_flags++                -- Stub files generated for foreign exports references the runIO_closure+                -- and runNonIO_closure symbols, which are defined in the base package.+                -- These symbols are imported into the stub.c file via RtsAPI.h, and the+                -- way we do the import depends on whether we're currently compiling+                -- the base package or not.+                       ++ (if platformOS platform == OSMinGW32 &&+                              thisPackage dflags == baseUnitId+                                then [ "-DCOMPILING_BASE_PACKAGE" ]+                                else [])++        -- We only support SparcV9 and better because V8 lacks an atomic CAS+        -- instruction. Note that the user can still override this+        -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag+        -- regardless of the ordering.+        --+        -- This is a temporary hack. See #2872, commit+        -- 5bd3072ac30216a505151601884ac88bf404c9f2+                       ++ (if platformArch platform == ArchSPARC+                           then ["-mcpu=v9"]+                           else [])++                       -- GCC 4.6+ doesn't like -Wimplicit when compiling C++.+                       ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx)+                             then ["-Wimplicit"]+                             else [])++                       ++ (if hcc+                             then gcc_extra_viac_flags ++ more_hcc_opts+                             else [])+                       ++ verbFlags+                       ++ [ "-S" ]+                       ++ cc_opt+                       ++ [ "-include", ghcVersionH ]+                       ++ framework_paths+                       ++ split_opt+                       ++ include_paths+                       ++ pkg_extra_cc_opts+                       ))++        return (RealPhase next_phase, output_fn)++-----------------------------------------------------------------------------+-- Splitting phase++runPhase (RealPhase Splitter) input_fn dflags+  = do  -- tmp_pfx is the prefix used for the split .s files++        split_s_prefix <- liftIO $ SysTools.newTempName dflags "split"+        let n_files_fn = split_s_prefix++        liftIO $ SysTools.runSplit dflags+                          [ SysTools.FileOption "" input_fn+                          , SysTools.FileOption "" split_s_prefix+                          , SysTools.FileOption "" n_files_fn+                          ]++        -- Save the number of split files for future references+        s <- liftIO $ readFile n_files_fn+        let n_files = read s :: Int+            dflags' = dflags { splitInfo = Just (split_s_prefix, n_files) }++        setDynFlags dflags'++        -- Remember to delete all these files+        liftIO $ addFilesToClean dflags'+                                 [ split_s_prefix ++ "__" ++ show n ++ ".s"+                                 | n <- [1..n_files]]++        return (RealPhase SplitAs,+                "**splitter**") -- we don't use the filename in SplitAs++-----------------------------------------------------------------------------+-- As, SpitAs phase : Assembler++-- This is for calling the assembler on a regular assembly file (not split).+runPhase (RealPhase (As with_cpp)) input_fn dflags+  = do+        -- LLVM from version 3.0 onwards doesn't support the OS X system+        -- assembler, so we use clang as the assembler instead. (#5636)+        let whichAsProg | hscTarget dflags == HscLlvm &&+                          platformOS (targetPlatform dflags) == OSDarwin+                        = return SysTools.runClang+                        | otherwise = return SysTools.runAs++        as_prog <- whichAsProg+        let cmdline_include_paths = includePaths dflags+        let pic_c_flags = picCCOpts dflags++        next_phase <- maybeMergeForeign+        output_fn <- phaseOutputFilename next_phase++        -- we create directories for the object file, because it+        -- might be a hierarchical module.+        liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)++        ccInfo <- liftIO $ getCompilerInfo dflags+        let runAssembler inputFilename outputFilename+                = liftIO $ as_prog dflags+                       ([ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]++                       -- See Note [-fPIC for assembler]+                       ++ map SysTools.Option pic_c_flags++        -- We only support SparcV9 and better because V8 lacks an atomic CAS+        -- instruction so we have to make sure that the assembler accepts the+        -- instruction set. Note that the user can still override this+        -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag+        -- regardless of the ordering.+        --+        -- This is a temporary hack.+                       ++ (if platformArch (targetPlatform dflags) == ArchSPARC+                           then [SysTools.Option "-mcpu=v9"]+                           else [])+                       ++ (if any (ccInfo ==) [Clang, AppleClang, AppleClang51]+                            then [SysTools.Option "-Qunused-arguments"]+                            else [])+                       ++ [ SysTools.Option "-x"+                          , if with_cpp+                              then SysTools.Option "assembler-with-cpp"+                              else SysTools.Option "assembler"+                          , SysTools.Option "-c"+                          , SysTools.FileOption "" inputFilename+                          , SysTools.Option "-o"+                          , SysTools.FileOption "" outputFilename+                          ])++        liftIO $ debugTraceMsg dflags 4 (text "Running the assembler")+        runAssembler input_fn output_fn+        return (RealPhase next_phase, output_fn)+++-- This is for calling the assembler on a split assembly file (so a collection+-- of assembly files)+runPhase (RealPhase SplitAs) _input_fn dflags+  = do+        -- we'll handle the stub_o file in this phase, so don't MergeForeign,+        -- just jump straight to StopLn afterwards.+        let next_phase = StopLn+        output_fn <- phaseOutputFilename next_phase++        let base_o = dropExtension output_fn+            osuf = objectSuf dflags+            split_odir  = base_o ++ "_" ++ osuf ++ "_split"++        let pic_c_flags = picCCOpts dflags++        -- this also creates the hierarchy+        liftIO $ createDirectoryIfMissing True split_odir++        -- remove M_split/ *.o, because we're going to archive M_split/ *.o+        -- later and we don't want to pick up any old objects.+        fs <- liftIO $ getDirectoryContents split_odir+        liftIO $ mapM_ removeFile $+                map (split_odir </>) $ filter (osuf `isSuffixOf`) fs++        let (split_s_prefix, n) = case splitInfo dflags of+                                  Nothing -> panic "No split info"+                                  Just x -> x++        let split_s   n = split_s_prefix ++ "__" ++ show n <.> "s"++            split_obj :: Int -> FilePath+            split_obj n = split_odir </>+                          takeFileName base_o ++ "__" ++ show n <.> osuf++        let assemble_file n+              = SysTools.runAs dflags (++        -- We only support SparcV9 and better because V8 lacks an atomic CAS+        -- instruction so we have to make sure that the assembler accepts the+        -- instruction set. Note that the user can still override this+        -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag+        -- regardless of the ordering.+        --+        -- This is a temporary hack.+                          (if platformArch (targetPlatform dflags) == ArchSPARC+                           then [SysTools.Option "-mcpu=v9"]+                           else []) ++++                          -- See Note [-fPIC for assembler]+                          map SysTools.Option pic_c_flags ++++                          [ SysTools.Option "-c"+                          , SysTools.Option "-o"+                          , SysTools.FileOption "" (split_obj n)+                          , SysTools.FileOption "" (split_s n)+                          ])++        liftIO $ mapM_ assemble_file [1..n]++        -- Note [pipeline-split-init]+        -- If we have a stub file -- which will be part of foreign_os --+        --  it may contain constructor+        -- functions for initialisation of this module.  We can't+        -- simply leave the stub as a separate object file, because it+        -- will never be linked in: nothing refers to it.  We need to+        -- ensure that if we ever refer to the data in this module+        -- that needs initialisation, then we also pull in the+        -- initialisation routine.+        --+        -- To that end, we make a DANGEROUS ASSUMPTION here: the data+        -- that needs to be initialised is all in the FIRST split+        -- object.  See Note [codegen-split-init].+        --+        -- We also merge in all the foreign objects since we're at it.++        PipeState{foreign_os} <- getPipeState+        if null foreign_os+          then return ()+          else liftIO $ do+             tmp_split_1 <- newTempName dflags osuf+             let split_1 = split_obj 1+             copyFile split_1 tmp_split_1+             removeFile split_1+             joinObjectFiles dflags (tmp_split_1 : foreign_os) split_1++        -- join them into a single .o file+        liftIO $ joinObjectFiles dflags (map split_obj [1..n]) output_fn++        return (RealPhase next_phase, output_fn)++-----------------------------------------------------------------------------+-- LlvmOpt phase++runPhase (RealPhase LlvmOpt) input_fn dflags+  = do+    let opt_lvl  = max 0 (min 2 $ optLevel dflags)+        -- don't specify anything if user has specified commands. We do this+        -- for opt but not llc since opt is very specifically for optimisation+        -- passes only, so if the user is passing us extra options we assume+        -- they know what they are doing and don't get in the way.+        optFlag  = if null (getOpts dflags opt_lo)+                       then map SysTools.Option $ words (llvmOpts !! opt_lvl)+                       else []+        tbaa | gopt Opt_LlvmTBAA dflags = "--enable-tbaa=true"+             | otherwise                = "--enable-tbaa=false"+++    output_fn <- phaseOutputFilename LlvmLlc++    liftIO $ SysTools.runLlvmOpt dflags+               ([ SysTools.FileOption "" input_fn,+                    SysTools.Option "-o",+                    SysTools.FileOption "" output_fn]+                ++ optFlag+                ++ [SysTools.Option tbaa])++    return (RealPhase LlvmLlc, output_fn)+  where+        -- we always (unless -optlo specified) run Opt since we rely on it to+        -- fix up some pretty big deficiencies in the code we generate+        llvmOpts =  [ "-mem2reg -globalopt"+                    , "-O1 -globalopt"+                    , "-O2"+                    ]++-----------------------------------------------------------------------------+-- LlvmLlc phase++runPhase (RealPhase LlvmLlc) input_fn dflags+  = do+    let opt_lvl = max 0 (min 2 $ optLevel dflags)+        -- iOS requires external references to be loaded indirectly from the+        -- DATA segment or dyld traps at runtime writing into TEXT: see #7722+        rmodel | platformOS (targetPlatform dflags) == OSiOS = "dynamic-no-pic"+               | gopt Opt_PIC dflags                         = "pic"+               | WayDyn `elem` ways dflags                   = "dynamic-no-pic"+               | otherwise                                   = "static"+        tbaa | gopt Opt_LlvmTBAA dflags = "--enable-tbaa=true"+             | otherwise                = "--enable-tbaa=false"++    -- hidden debugging flag '-dno-llvm-mangler' to skip mangling+    let next_phase = case gopt Opt_NoLlvmMangler dflags of+                         False                            -> LlvmMangle+                         True | gopt Opt_SplitObjs dflags -> Splitter+                         True                             -> As False++    output_fn <- phaseOutputFilename next_phase++    liftIO $ SysTools.runLlvmLlc dflags+                ([ SysTools.Option (llvmOpts !! opt_lvl),+                    SysTools.Option $ "-relocation-model=" ++ rmodel,+                    SysTools.FileOption "" input_fn,+                    SysTools.Option "-o", SysTools.FileOption "" output_fn]+                ++ [SysTools.Option tbaa]+                ++ map SysTools.Option fpOpts+                ++ map SysTools.Option abiOpts+                ++ map SysTools.Option sseOpts+                ++ map SysTools.Option avxOpts+                ++ map SysTools.Option avx512Opts+                ++ map SysTools.Option stackAlignOpts)++    return (RealPhase next_phase, output_fn)+  where+        -- Bug in LLVM at O3 on OSX.+        llvmOpts = if platformOS (targetPlatform dflags) == OSDarwin+                   then ["-O1", "-O2", "-O2"]+                   else ["-O1", "-O2", "-O3"]+        -- On ARMv7 using LLVM, LLVM fails to allocate floating point registers+        -- while compiling GHC source code. It's probably due to fact that it+        -- does not enable VFP by default. Let's do this manually here+        fpOpts = case platformArch (targetPlatform dflags) of+                   ArchARM ARMv7 ext _ -> if (elem VFPv3 ext)+                                      then ["-mattr=+v7,+vfp3"]+                                      else if (elem VFPv3D16 ext)+                                           then ["-mattr=+v7,+vfp3,+d16"]+                                           else []+                   ArchARM ARMv6 ext _ -> if (elem VFPv2 ext)+                                          then ["-mattr=+v6,+vfp2"]+                                          else ["-mattr=+v6"]+                   _                 -> []+        -- On Ubuntu/Debian with ARM hard float ABI, LLVM's llc still+        -- compiles into soft-float ABI. We need to explicitly set abi+        -- to hard+        abiOpts = case platformArch (targetPlatform dflags) of+                    ArchARM _ _ HARD -> ["-float-abi=hard"]+                    ArchARM _ _ _    -> []+                    _                -> []++        sseOpts | isSse4_2Enabled dflags = ["-mattr=+sse42"]+                | isSse2Enabled dflags   = ["-mattr=+sse2"]+                | isSseEnabled dflags    = ["-mattr=+sse"]+                | otherwise              = []++        avxOpts | isAvx512fEnabled dflags = ["-mattr=+avx512f"]+                | isAvx2Enabled dflags    = ["-mattr=+avx2"]+                | isAvxEnabled dflags     = ["-mattr=+avx"]+                | otherwise               = []++        avx512Opts =+          [ "-mattr=+avx512cd" | isAvx512cdEnabled dflags ] +++          [ "-mattr=+avx512er" | isAvx512erEnabled dflags ] +++          [ "-mattr=+avx512pf" | isAvx512pfEnabled dflags ]++        stackAlignOpts =+            case platformArch (targetPlatform dflags) of+              ArchX86_64 | isAvxEnabled dflags -> ["-stack-alignment=32"]+              _                                -> []++-----------------------------------------------------------------------------+-- LlvmMangle phase++runPhase (RealPhase LlvmMangle) input_fn dflags+  = do+      let next_phase = if gopt Opt_SplitObjs dflags then Splitter else As False+      output_fn <- phaseOutputFilename next_phase+      liftIO $ llvmFixupAsm dflags input_fn output_fn+      return (RealPhase next_phase, output_fn)++-----------------------------------------------------------------------------+-- merge in stub objects++runPhase (RealPhase MergeForeign) input_fn dflags+ = do+     PipeState{foreign_os} <- getPipeState+     output_fn <- phaseOutputFilename StopLn+     liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)+     if null foreign_os+       then panic "runPhase(MergeForeign): no foreign objects"+       else do+         liftIO $ joinObjectFiles dflags (input_fn : foreign_os) output_fn+         return (RealPhase StopLn, output_fn)++-- warning suppression+runPhase (RealPhase other) _input_fn _dflags =+   panic ("runPhase: don't know how to run phase " ++ show other)++maybeMergeForeign :: CompPipeline Phase+maybeMergeForeign+ = do+     PipeState{foreign_os} <- getPipeState+     if null foreign_os then return StopLn else return MergeForeign++getLocation :: HscSource -> ModuleName -> CompPipeline ModLocation+getLocation src_flavour mod_name = do+    dflags <- getDynFlags++    PipeEnv{ src_basename=basename,+             src_suffix=suff } <- getPipeEnv++    -- Build a ModLocation to pass to hscMain.+    -- The source filename is rather irrelevant by now, but it's used+    -- by hscMain for messages.  hscMain also needs+    -- the .hi and .o filenames, and this is as good a way+    -- as any to generate them, and better than most. (e.g. takes+    -- into account the -osuf flags)+    location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff++    -- Boot-ify it if necessary+    let location2 | HsBootFile <- src_flavour = addBootSuffixLocn location1+                  | otherwise                 = location1+++    -- Take -ohi into account if present+    -- This can't be done in mkHomeModuleLocation because+    -- it only applies to the module being compiles+    let ohi = outputHi dflags+        location3 | Just fn <- ohi = location2{ ml_hi_file = fn }+                  | otherwise      = location2++    -- Take -o into account if present+    -- Very like -ohi, but we must *only* do this if we aren't linking+    -- (If we're linking then the -o applies to the linked thing, not to+    -- the object file for one module.)+    -- Note the nasty duplication with the same computation in compileFile above+    let expl_o_file = outputFile dflags+        location4 | Just ofile <- expl_o_file+                  , isNoLink (ghcLink dflags)+                  = location3 { ml_obj_file = ofile }+                  | otherwise = location3++    return location4++mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath+mkExtraObj dflags extn xs+ = do cFile <- newTempName dflags extn+      oFile <- newTempName dflags "o"+      writeFile cFile xs+      ccInfo <- liftIO $ getCompilerInfo dflags+      SysTools.runCc dflags+                ([Option        "-c",+                  FileOption "" cFile,+                  Option        "-o",+                  FileOption "" oFile]+                 ++ if extn /= "s"+                        then cOpts+                        else asmOpts ccInfo)+      return oFile+    where+      -- Pass a different set of options to the C compiler depending one whether+      -- we're compiling C or assembler. When compiling C, we pass the usual+      -- set of include directories and PIC flags.+      cOpts = map Option (picCCOpts dflags)+                    ++ map (FileOption "-I")+                            (includeDirs $ getPackageDetails dflags rtsUnitId)++      -- When compiling assembler code, we drop the usual C options, and if the+      -- compiler is Clang, we add an extra argument to tell Clang to ignore+      -- unused command line options. See trac #11684.+      asmOpts ccInfo =+            if any (ccInfo ==) [Clang, AppleClang, AppleClang51]+                then [Option "-Qunused-arguments"]+                else []+++-- When linking a binary, we need to create a C main() function that+-- starts everything off.  This used to be compiled statically as part+-- of the RTS, but that made it hard to change the -rtsopts setting,+-- so now we generate and compile a main() stub as part of every+-- binary and pass the -rtsopts setting directly to the RTS (#5373)+--+mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath+mkExtraObjToLinkIntoBinary dflags = do+   when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do+      putLogMsg dflags NoReason SevInfo noSrcSpan+          (defaultUserStyle dflags)+          (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$+           text "    Call hs_init_ghc() from your main() function to set these options.")++   mkExtraObj dflags "c" (showSDoc dflags main)++ where+  main+   | gopt Opt_NoHsMain dflags = Outputable.empty+   | otherwise = vcat [+      text "#include \"Rts.h\"",+      text "extern StgClosure ZCMain_main_closure;",+      text "int main(int argc, char *argv[])",+      char '{',+      text " RtsConfig __conf = defaultRtsConfig;",+      text " __conf.rts_opts_enabled = "+          <> text (show (rtsOptsEnabled dflags)) <> semi,+      text " __conf.rts_opts_suggestions = "+          <> text (if rtsOptsSuggestions dflags+                      then "true"+                      else "false") <> semi,+      case rtsOpts dflags of+         Nothing   -> Outputable.empty+         Just opts -> text "    __conf.rts_opts= " <>+                        text (show opts) <> semi,+      text " __conf.rts_hs_main = true;",+      text " return hs_main(argc,argv,&ZCMain_main_closure,__conf);",+      char '}',+      char '\n' -- final newline, to keep gcc happy+     ]++-- Write out the link info section into a new assembly file. Previously+-- this was included as inline assembly in the main.c file but this+-- is pretty fragile. gas gets upset trying to calculate relative offsets+-- that span the .note section (notably .text) when debug info is present+mkNoteObjsToLinkIntoBinary :: DynFlags -> [InstalledUnitId] -> IO [FilePath]+mkNoteObjsToLinkIntoBinary dflags dep_packages = do+   link_info <- getLinkInfo dflags dep_packages++   if (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))+     then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info))+     else return []++  where+    link_opts info = hcat [+      -- "link info" section (see Note [LinkInfo section])+      makeElfNote dflags ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info,++      -- ALL generated assembly must have this section to disable+      -- executable stacks.  See also+      -- compiler/nativeGen/AsmCodeGen.hs for another instance+      -- where we need to do this.+      if platformHasGnuNonexecStack (targetPlatform dflags)+        then text ".section .note.GNU-stack,\"\",@progbits\n"+        else Outputable.empty+      ]++-- | Return the "link info" string+--+-- See Note [LinkInfo section]+getLinkInfo :: DynFlags -> [InstalledUnitId] -> IO String+getLinkInfo dflags dep_packages = do+   package_link_opts <- getPackageLinkOpts dflags dep_packages+   pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags)+                     then getPackageFrameworks dflags dep_packages+                     else return []+   let extra_ld_inputs = ldInputs dflags+   let+      link_info = (package_link_opts,+                   pkg_frameworks,+                   rtsOpts dflags,+                   rtsOptsEnabled dflags,+                   gopt Opt_NoHsMain dflags,+                   map showOpt extra_ld_inputs,+                   getOpts dflags opt_l)+   --+   return (show link_info)+++{- Note [LinkInfo section]+   ~~~~~~~~~~~~~~~~~~~~~~~++The "link info" is a string representing the parameters of the link. We save+this information in the binary, and the next time we link, if nothing else has+changed, we use the link info stored in the existing binary to decide whether+to re-link or not.++The "link info" string is stored in a ELF section called ".debug-ghc-link-info"+(see ghcLinkInfoSectionName) with the SHT_NOTE type.  For some time, it used to+not follow the specified record-based format (see #11022).++-}+++-----------------------------------------------------------------------------+-- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file++getHCFilePackages :: FilePath -> IO [InstalledUnitId]+getHCFilePackages filename =+  Exception.bracket (openFile filename ReadMode) hClose $ \h -> do+    l <- hGetLine h+    case l of+      '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->+          return (map stringToInstalledUnitId (words rest))+      _other ->+          return []++-----------------------------------------------------------------------------+-- Static linking, of .o files++-- The list of packages passed to link is the list of packages on+-- which this program depends, as discovered by the compilation+-- manager.  It is combined with the list of packages that the user+-- specifies on the command line with -package flags.+--+-- In one-shot linking mode, we can't discover the package+-- dependencies (because we haven't actually done any compilation or+-- read any interface files), so the user must explicitly specify all+-- the packages.++{-+Note [-Xlinker -rpath vs -Wl,-rpath]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++-Wl takes a comma-separated list of options which in the case of+-Wl,-rpath -Wl,some,path,with,commas parses the the path with commas+as separate options.+Buck, the build system, produces paths with commas in them.++-Xlinker doesn't have this disadvantage and as far as I can tell+it is supported by both gcc and clang. Anecdotally nvcc supports+-Xlinker, but not -Wl.+-}++linkBinary :: DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()+linkBinary = linkBinary' False++linkBinary' :: Bool -> DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()+linkBinary' staticLink dflags o_files dep_packages = do+    let platform = targetPlatform dflags+        mySettings = settings dflags+        verbFlags = getVerbFlags dflags+        output_fn = exeFileName staticLink dflags++    -- get the full list of packages to link with, by combining the+    -- explicit packages with the auto packages and all of their+    -- dependencies, and eliminating duplicates.++    full_output_fn <- if isAbsolute output_fn+                      then return output_fn+                      else do d <- getCurrentDirectory+                              return $ normalise (d </> output_fn)+    pkg_lib_paths <- getPackageLibraryPath dflags dep_packages+    let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths+        get_pkg_lib_path_opts l+         | osElfTarget (platformOS platform) &&+           dynLibLoader dflags == SystemDependent &&+           WayDyn `elem` ways dflags+            = let libpath = if gopt Opt_RelativeDynlibPaths dflags+                            then "$ORIGIN" </>+                                 (l `makeRelativeTo` full_output_fn)+                            else l+                  -- See Note [-Xlinker -rpath vs -Wl,-rpath]+                  rpath = if gopt Opt_RPath dflags+                          then ["-Xlinker", "-rpath", "-Xlinker", libpath]+                          else []+                  -- Solaris 11's linker does not support -rpath-link option. It silently+                  -- ignores it and then complains about next option which is -l<some+                  -- dir> as being a directory and not expected object file, E.g+                  -- ld: elf error: file+                  -- /tmp/ghc-src/libraries/base/dist-install/build:+                  -- elf_begin: I/O error: region read: Is a directory+                  rpathlink = if (platformOS platform) == OSSolaris2+                              then []+                              else ["-Xlinker", "-rpath-link", "-Xlinker", l]+              in ["-L" ++ l] ++ rpathlink ++ rpath+         | osMachOTarget (platformOS platform) &&+           dynLibLoader dflags == SystemDependent &&+           WayDyn `elem` ways dflags &&+           gopt Opt_RPath dflags+            = let libpath = if gopt Opt_RelativeDynlibPaths dflags+                            then "@loader_path" </>+                                 (l `makeRelativeTo` full_output_fn)+                            else l+              in ["-L" ++ l] ++ ["-Xlinker", "-rpath", "-Xlinker", libpath]+         | otherwise = ["-L" ++ l]++    let+      dead_strip+        | gopt Opt_WholeArchiveHsLibs dflags = []+        | otherwise = if osSubsectionsViaSymbols (platformOS platform)+                        then ["-Wl,-dead_strip"]+                        else []+    let lib_paths = libraryPaths dflags+    let lib_path_opts = map ("-L"++) lib_paths++    extraLinkObj <- mkExtraObjToLinkIntoBinary dflags+    noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_packages++    let+      (pre_hs_libs, post_hs_libs)+        | gopt Opt_WholeArchiveHsLibs dflags+        = if platformOS platform == OSDarwin+            then (["-Wl,-all_load"], [])+              -- OS X does not have a flag to turn off -all_load+            else (["-Wl,--whole-archive"], ["-Wl,--no-whole-archive"])+        | otherwise+        = ([],[])++    pkg_link_opts <- do+        (package_hs_libs, extra_libs, other_flags) <- getPackageLinkOpts dflags dep_packages+        return $ if staticLink+            then package_hs_libs -- If building an executable really means making a static+                                 -- library (e.g. iOS), then we only keep the -l options for+                                 -- HS packages, because libtool doesn't accept other options.+                                 -- In the case of iOS these need to be added by hand to the+                                 -- final link in Xcode.+            else other_flags ++ dead_strip+                  ++ pre_hs_libs ++ package_hs_libs ++ post_hs_libs+                  ++ extra_libs+                 -- -Wl,-u,<sym> contained in other_flags+                 -- needs to be put before -l<package>,+                 -- otherwise Solaris linker fails linking+                 -- a binary with unresolved symbols in RTS+                 -- which are defined in base package+                 -- the reason for this is a note in ld(1) about+                 -- '-u' option: "The placement of this option+                 -- on the command line is significant.+                 -- This option must be placed before the library+                 -- that defines the symbol."++    -- frameworks+    pkg_framework_opts <- getPkgFrameworkOpts dflags platform dep_packages+    let framework_opts = getFrameworkOpts dflags platform++        -- probably _stub.o files+    let extra_ld_inputs = ldInputs dflags++    -- Here are some libs that need to be linked at the *end* of+    -- the command line, because they contain symbols that are referred to+    -- by the RTS.  We can't therefore use the ordinary way opts for these.+    let+        debug_opts | WayDebug `elem` ways dflags = [+#if defined(HAVE_LIBBFD)+                        "-lbfd", "-liberty"+#endif+                         ]+                   | otherwise            = []++    let thread_opts+         | WayThreaded `elem` ways dflags =+            let os = platformOS (targetPlatform dflags)+            in if os `elem` [OSMinGW32, OSFreeBSD, OSOpenBSD, OSAndroid,+                             OSNetBSD, OSHaiku, OSQNXNTO, OSiOS, OSDarwin]+               then []+               else ["-lpthread"]+         | otherwise               = []++    rc_objs <- maybeCreateManifest dflags output_fn++    let link = if staticLink+                   then SysTools.runLibtool+                   else SysTools.runLink+    link dflags (+                       map SysTools.Option verbFlags+                      ++ [ SysTools.Option "-o"+                         , SysTools.FileOption "" output_fn+                         ]+                      ++ map SysTools.Option (+                         []++                      -- See Note [No PIE eating when linking]+                      ++ (if sGccSupportsNoPie mySettings+                             then ["-no-pie"]+                             else [])++                      -- Permit the linker to auto link _symbol to _imp_symbol.+                      -- This lets us link against DLLs without needing an "import library".+                      ++ (if platformOS platform == OSMinGW32+                          then ["-Wl,--enable-auto-import"]+                          else [])++                      -- '-no_compact_unwind'+                      -- C++/Objective-C exceptions cannot use optimised+                      -- stack unwinding code. The optimised form is the+                      -- default in Xcode 4 on at least x86_64, and+                      -- without this flag we're also seeing warnings+                      -- like+                      --     ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog+                      -- on x86.+                      ++ (if sLdSupportsCompactUnwind mySettings &&+                             not staticLink &&+                             (platformOS platform == OSDarwin || platformOS platform == OSiOS) &&+                             case platformArch platform of+                               ArchX86 -> True+                               ArchX86_64 -> True+                               ArchARM {} -> True+                               ArchARM64  -> True+                               _ -> False+                          then ["-Wl,-no_compact_unwind"]+                          else [])++                      -- '-no_pie'+                      -- iOS uses 'dynamic-no-pic', so we must pass this to ld to suppress a warning; see #7722+                      ++ (if platformOS platform == OSiOS &&+                             not staticLink+                          then ["-Wl,-no_pie"]+                          else [])++                      -- '-Wl,-read_only_relocs,suppress'+                      -- ld gives loads of warnings like:+                      --     ld: warning: text reloc in _base_GHCziArr_unsafeArray_info to _base_GHCziArr_unsafeArray_closure+                      -- when linking any program. We're not sure+                      -- whether this is something we ought to fix, but+                      -- for now this flags silences them.+                      ++ (if platformOS   platform == OSDarwin &&+                             platformArch platform == ArchX86 &&+                             not staticLink+                          then ["-Wl,-read_only_relocs,suppress"]+                          else [])++                      ++ (if sLdIsGnuLd mySettings &&+                             not (gopt Opt_WholeArchiveHsLibs dflags)+                          then ["-Wl,--gc-sections"]+                          else [])++                      ++ o_files+                      ++ lib_path_opts)+                      ++ extra_ld_inputs+                      ++ map SysTools.Option (+                         rc_objs+                      ++ framework_opts+                      ++ pkg_lib_path_opts+                      ++ extraLinkObj:noteLinkObjs+                      ++ pkg_link_opts+                      ++ pkg_framework_opts+                      ++ debug_opts+                      ++ thread_opts+                    ))++exeFileName :: Bool -> DynFlags -> FilePath+exeFileName staticLink dflags+  | Just s <- outputFile dflags =+      case platformOS (targetPlatform dflags) of+          OSMinGW32 -> s <?.> "exe"+          _         -> if staticLink+                         then s <?.> "a"+                         else s+  | otherwise =+      if platformOS (targetPlatform dflags) == OSMinGW32+      then "main.exe"+      else if staticLink+           then "liba.a"+           else "a.out"+ where s <?.> ext | null (takeExtension s) = s <.> ext+                  | otherwise              = s++maybeCreateManifest+   :: DynFlags+   -> FilePath                          -- filename of executable+   -> IO [FilePath]                     -- extra objects to embed, maybe+maybeCreateManifest dflags exe_filename+ | platformOS (targetPlatform dflags) == OSMinGW32 &&+   gopt Opt_GenManifest dflags+    = do let manifest_filename = exe_filename <.> "manifest"++         writeFile manifest_filename $+             "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"+++             "  <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"+++             "  <assemblyIdentity version=\"1.0.0.0\"\n"+++             "     processorArchitecture=\"X86\"\n"+++             "     name=\"" ++ dropExtension exe_filename ++ "\"\n"+++             "     type=\"win32\"/>\n\n"+++             "  <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"+++             "    <security>\n"+++             "      <requestedPrivileges>\n"+++             "        <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"+++             "        </requestedPrivileges>\n"+++             "       </security>\n"+++             "  </trustInfo>\n"+++             "</assembly>\n"++         -- Windows will find the manifest file if it is named+         -- foo.exe.manifest. However, for extra robustness, and so that+         -- we can move the binary around, we can embed the manifest in+         -- the binary itself using windres:+         if not (gopt Opt_EmbedManifest dflags) then return [] else do++         rc_filename <- newTempName dflags "rc"+         rc_obj_filename <- newTempName dflags (objectSuf dflags)++         writeFile rc_filename $+             "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"+               -- magic numbers :-)+               -- show is a bit hackish above, but we need to escape the+               -- backslashes in the path.++         runWindres dflags $ map SysTools.Option $+               ["--input="++rc_filename,+                "--output="++rc_obj_filename,+                "--output-format=coff"]+               -- no FileOptions here: windres doesn't like seeing+               -- backslashes, apparently++         removeFile manifest_filename++         return [rc_obj_filename]+ | otherwise = return []+++linkDynLibCheck :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()+linkDynLibCheck dflags o_files dep_packages+ = do+    when (haveRtsOptsFlags dflags) $ do+      putLogMsg dflags NoReason SevInfo noSrcSpan+          (defaultUserStyle dflags)+          (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$+           text "    Call hs_init_ghc() from your main() function to set these options.")++    linkDynLib dflags o_files dep_packages++linkStaticLibCheck :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()+linkStaticLibCheck dflags o_files dep_packages+ = do+    when (platformOS (targetPlatform dflags) `notElem` [OSiOS, OSDarwin]) $+      throwGhcExceptionIO (ProgramError "Static archive creation only supported on Darwin/OS X/iOS")+    linkBinary' True dflags o_files dep_packages++-- -----------------------------------------------------------------------------+-- Running CPP++doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()+doCpp dflags raw input_fn output_fn = do+    let hscpp_opts = picPOpts dflags+    let cmdline_include_paths = includePaths dflags++    pkg_include_dirs <- getPackageIncludePath dflags []+    let include_paths = foldr (\ x xs -> "-I" : x : xs) []+                          (cmdline_include_paths ++ pkg_include_dirs)++    let verbFlags = getVerbFlags dflags++    let cpp_prog args | raw       = SysTools.runCpp dflags args+                      | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args)++    let target_defs =+          [ "-D" ++ HOST_OS     ++ "_BUILD_OS",+            "-D" ++ HOST_ARCH   ++ "_BUILD_ARCH",+            "-D" ++ TARGET_OS   ++ "_HOST_OS",+            "-D" ++ TARGET_ARCH ++ "_HOST_ARCH" ]+        -- remember, in code we *compile*, the HOST is the same our TARGET,+        -- and BUILD is the same as our HOST.++    let sse_defs =+          [ "-D__SSE__"      | isSseEnabled      dflags ] +++          [ "-D__SSE2__"     | isSse2Enabled     dflags ] +++          [ "-D__SSE4_2__"   | isSse4_2Enabled   dflags ]++    let avx_defs =+          [ "-D__AVX__"      | isAvxEnabled      dflags ] +++          [ "-D__AVX2__"     | isAvx2Enabled     dflags ] +++          [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] +++          [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] +++          [ "-D__AVX512F__"  | isAvx512fEnabled  dflags ] +++          [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]++    backend_defs <- getBackendDefs dflags++    let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]+    -- Default CPP defines in Haskell source+    ghcVersionH <- getGhcVersionPathName dflags+    let hsSourceCppOpts = [ "-include", ghcVersionH ]++    -- MIN_VERSION macros+    let uids = explicitPackages (pkgState dflags)+        pkgs = catMaybes (map (lookupPackage dflags) uids)+    mb_macro_include <-+        if not (null pkgs) && gopt Opt_VersionMacros dflags+            then do macro_stub <- newTempName dflags "h"+                    writeFile macro_stub (generatePackageVersionMacros pkgs)+                    -- Include version macros for every *exposed* package.+                    -- Without -hide-all-packages and with a package database+                    -- size of 1000 packages, it takes cpp an estimated 2+                    -- milliseconds to process this file. See Trac #10970+                    -- comment 8.+                    return [SysTools.FileOption "-include" macro_stub]+            else return []++    cpp_prog       (   map SysTools.Option verbFlags+                    ++ map SysTools.Option include_paths+                    ++ map SysTools.Option hsSourceCppOpts+                    ++ map SysTools.Option target_defs+                    ++ map SysTools.Option backend_defs+                    ++ map SysTools.Option th_defs+                    ++ map SysTools.Option hscpp_opts+                    ++ map SysTools.Option sse_defs+                    ++ map SysTools.Option avx_defs+                    ++ mb_macro_include+        -- Set the language mode to assembler-with-cpp when preprocessing. This+        -- alleviates some of the C99 macro rules relating to whitespace and the hash+        -- operator, which we tend to abuse. Clang in particular is not very happy+        -- about this.+                    ++ [ SysTools.Option     "-x"+                       , SysTools.Option     "assembler-with-cpp"+                       , SysTools.Option     input_fn+        -- We hackily use Option instead of FileOption here, so that the file+        -- name is not back-slashed on Windows.  cpp is capable of+        -- dealing with / in filenames, so it works fine.  Furthermore+        -- if we put in backslashes, cpp outputs #line directives+        -- with *double* backslashes.   And that in turn means that+        -- our error messages get double backslashes in them.+        -- In due course we should arrange that the lexer deals+        -- with these \\ escapes properly.+                       , SysTools.Option     "-o"+                       , SysTools.FileOption "" output_fn+                       ])++getBackendDefs :: DynFlags -> IO [String]+getBackendDefs dflags | hscTarget dflags == HscLlvm = do+    llvmVer <- figureLlvmVersion dflags+    return $ case llvmVer of+               Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ]+               _      -> []+  where+    format (major, minor)+      | minor >= 100 = error "getBackendDefs: Unsupported minor version"+      | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int++getBackendDefs _ =+    return []++-- ---------------------------------------------------------------------------+-- Macros (cribbed from Cabal)++generatePackageVersionMacros :: [PackageConfig] -> String+generatePackageVersionMacros pkgs = concat+  -- Do not add any C-style comments. See Trac #3389.+  [ generateMacros "" pkgname version+  | pkg <- pkgs+  , let version = packageVersion pkg+        pkgname = map fixchar (packageNameString pkg)+  ]++fixchar :: Char -> Char+fixchar '-' = '_'+fixchar c   = c++generateMacros :: String -> String -> Version -> String+generateMacros prefix name version =+  concat+  ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"+  ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"+  ,"  (major1) <  ",major1," || \\\n"+  ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"+  ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"+  ,"\n\n"+  ]+  where+    (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)++-- ---------------------------------------------------------------------------+-- join object files into a single relocatable object file, using ld -r++joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO ()+joinObjectFiles dflags o_files output_fn = do+  let mySettings = settings dflags+      ldIsGnuLd = sLdIsGnuLd mySettings+      osInfo = platformOS (targetPlatform dflags)+      ld_r args cc = SysTools.runLink dflags ([+                       SysTools.Option "-nostdlib",+                       SysTools.Option "-Wl,-r"+                     ]+                        -- See Note [No PIE eating while linking] in SysTools+                     ++ (if sGccSupportsNoPie mySettings+                          then [SysTools.Option "-no-pie"]+                          else [])++                     ++ (if any (cc ==) [Clang, AppleClang, AppleClang51]+                          then []+                          else [SysTools.Option "-nodefaultlibs"])+                     ++ (if osInfo == OSFreeBSD+                          then [SysTools.Option "-L/usr/lib"]+                          else [])+                        -- gcc on sparc sets -Wl,--relax implicitly, but+                        -- -r and --relax are incompatible for ld, so+                        -- disable --relax explicitly.+                     ++ (if platformArch (targetPlatform dflags)+                                `elem` [ArchSPARC, ArchSPARC64]+                         && ldIsGnuLd+                            then [SysTools.Option "-Wl,-no-relax"]+                            else [])+                     ++ map SysTools.Option ld_build_id+                     ++ [ SysTools.Option "-o",+                          SysTools.FileOption "" output_fn ]+                     ++ args)++      -- suppress the generation of the .note.gnu.build-id section,+      -- which we don't need and sometimes causes ld to emit a+      -- warning:+      ld_build_id | sLdSupportsBuildId mySettings = ["-Wl,--build-id=none"]+                  | otherwise                     = []++  ccInfo <- getCompilerInfo dflags+  if ldIsGnuLd+     then do+          script <- newTempName dflags "ldscript"+          cwd <- getCurrentDirectory+          let o_files_abs = map (\x -> "\"" ++ (cwd </> x) ++ "\"") o_files+          writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")"+          ld_r [SysTools.FileOption "" script] ccInfo+     else if sLdSupportsFilelist mySettings+     then do+          filelist <- newTempName dflags "filelist"+          writeFile filelist $ unlines o_files+          ld_r [SysTools.Option "-Wl,-filelist",+                SysTools.FileOption "-Wl," filelist] ccInfo+     else do+          ld_r (map (SysTools.FileOption "") o_files) ccInfo++-- -----------------------------------------------------------------------------+-- Misc.++writeInterfaceOnlyMode :: DynFlags -> Bool+writeInterfaceOnlyMode dflags =+ gopt Opt_WriteInterface dflags &&+ HscNothing == hscTarget dflags++-- | What phase to run after one of the backend code generators has run+hscPostBackendPhase :: DynFlags -> HscSource -> HscTarget -> Phase+hscPostBackendPhase _ HsBootFile _    =  StopLn+hscPostBackendPhase _ HsigFile _      =  StopLn+hscPostBackendPhase dflags _ hsc_lang =+  case hsc_lang of+        HscC -> HCc+        HscAsm | gopt Opt_SplitObjs dflags -> Splitter+               | otherwise                 -> As False+        HscLlvm        -> LlvmOpt+        HscNothing     -> StopLn+        HscInterpreted -> StopLn++touchObjectFile :: DynFlags -> FilePath -> IO ()+touchObjectFile dflags path = do+  createDirectoryIfMissing True $ takeDirectory path+  SysTools.touch dflags "Touching object file" path++haveRtsOptsFlags :: DynFlags -> Bool+haveRtsOptsFlags dflags =+         isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of+                                        RtsOptsSafeOnly -> False+                                        _ -> True++-- | Find out path to @ghcversion.h@ file+getGhcVersionPathName :: DynFlags -> IO FilePath+getGhcVersionPathName dflags = do+  dirs <- getPackageIncludePath dflags [toInstalledUnitId rtsUnitId]++  found <- filterM doesFileExist (map (</> "ghcversion.h") dirs)+  case found of+      []    -> throwGhcExceptionIO (InstallationError ("ghcversion.h missing"))+      (x:_) -> return x++-- Note [-fPIC for assembler]+-- When compiling .c source file GHC's driver pipeline basically+-- does the following two things:+--   1. ${CC}              -S 'PIC_CFLAGS' source.c+--   2. ${CC} -x assembler -c 'PIC_CFLAGS' source.S+--+-- Why do we need to pass 'PIC_CFLAGS' both to C compiler and assembler?+-- Because on some architectures (at least sparc32) assembler also chooses+-- the relocation type!+-- Consider the following C module:+--+--     /* pic-sample.c */+--     int v;+--     void set_v (int n) { v = n; }+--     int  get_v (void)  { return v; }+--+--     $ gcc -S -fPIC pic-sample.c+--     $ gcc -c       pic-sample.s -o pic-sample.no-pic.o # incorrect binary+--     $ gcc -c -fPIC pic-sample.s -o pic-sample.pic.o    # correct binary+--+--     $ objdump -r -d pic-sample.pic.o    > pic-sample.pic.o.od+--     $ objdump -r -d pic-sample.no-pic.o > pic-sample.no-pic.o.od+--     $ diff -u pic-sample.pic.o.od pic-sample.no-pic.o.od+--+-- Most of architectures won't show any difference in this test, but on sparc32+-- the following assembly snippet:+--+--    sethi   %hi(_GLOBAL_OFFSET_TABLE_-8), %l7+--+-- generates two kinds or relocations, only 'R_SPARC_PC22' is correct:+--+--       3c:  2f 00 00 00     sethi  %hi(0), %l7+--    -                       3c: R_SPARC_PC22        _GLOBAL_OFFSET_TABLE_-0x8+--    +                       3c: R_SPARC_HI22        _GLOBAL_OFFSET_TABLE_-0x8++{- Note [Don't normalise input filenames]++Summary+  We used to normalise input filenames when starting the unlit phase. This+  broke hpc in `--make` mode with imported literate modules (#2991).++Introduction+  1) --main+  When compiling a module with --main, GHC scans its imports to find out which+  other modules it needs to compile too. It turns out that there is a small+  difference between saying `ghc --make A.hs`, when `A` imports `B`, and+  specifying both modules on the command line with `ghc --make A.hs B.hs`. In+  the former case, the filename for B is inferred to be './B.hs' instead of+  'B.hs'.++  2) unlit+  When GHC compiles a literate haskell file, the source code first needs to go+  through unlit, which turns it into normal Haskell source code. At the start+  of the unlit phase, in `Driver.Pipeline.runPhase`, we call unlit with the+  option `-h` and the name of the original file. We used to normalise this+  filename using System.FilePath.normalise, which among other things removes+  an initial './'. unlit then uses that filename in #line directives that it+  inserts in the transformed source code.++  3) SrcSpan+  A SrcSpan represents a portion of a source code file. It has fields+  linenumber, start column, end column, and also a reference to the file it+  originated from. The SrcSpans for a literate haskell file refer to the+  filename that was passed to unlit -h.++  4) -fhpc+  At some point during compilation with -fhpc, in the function+  `deSugar.Coverage.isGoodTickSrcSpan`, we compare the filename that a+  `SrcSpan` refers to with the name of the file we are currently compiling.+  For some reason I don't yet understand, they can sometimes legitimally be+  different, and then hpc ignores that SrcSpan.++Problem+  When running `ghc --make -fhpc A.hs`, where `A.hs` imports the literate+  module `B.lhs`, `B` is inferred to be in the file `./B.lhs` (1). At the+  start of the unlit phase, the name `./B.lhs` is normalised to `B.lhs` (2).+  Therefore the SrcSpans of `B` refer to the file `B.lhs` (3), but we are+  still compiling `./B.lhs`. Hpc thinks these two filenames are different (4),+  doesn't include ticks for B, and we have unhappy customers (#2991).++Solution+  Do not normalise `input_fn` when starting the unlit phase.++Alternative solution+  Another option would be to not compare the two filenames on equality, but to+  use System.FilePath.equalFilePath. That function first normalises its+  arguments. The problem is that by the time we need to do the comparison, the+  filenames have been turned into FastStrings, probably for performance+  reasons, so System.FilePath.equalFilePath can not be used directly.++Archeology+  The call to `normalise` was added in a commit called "Fix slash+  direction on Windows with the new filePath code" (c9b6b5e8). The problem+  that commit was addressing has since been solved in a different manner, in a+  commit called "Fix the filename passed to unlit" (1eedbc6b). So the+  `normalise` is no longer necessary.+-}
+ main/DynFlags.hs view
@@ -0,0 +1,5335 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}++-------------------------------------------------------------------------------+--+-- | Dynamic flags+--+-- Most flags are dynamic flags, which means they can change from compilation+-- to compilation using @OPTIONS_GHC@ pragmas, and in a multi-session GHC each+-- session can be using different dynamic flags. Dynamic flags can also be set+-- at the prompt in GHCi.+--+-- (c) The University of Glasgow 2005+--+-------------------------------------------------------------------------------++{-# OPTIONS_GHC -fno-cse #-}+-- -fno-cse is needed for GLOBAL_VAR's to behave properly++module DynFlags (+        -- * Dynamic flags and associated configuration types+        DumpFlag(..),+        GeneralFlag(..),+        WarningFlag(..), WarnReason(..),+        Language(..),+        PlatformConstants(..),+        FatalMessager, LogAction, LogFinaliser, FlushOut(..), FlushErr(..),+        ProfAuto(..),+        glasgowExtsFlags,+        warningGroups, warningHierarchies,+        hasPprDebug, hasNoDebugOutput, hasNoStateHack, hasNoOptCoercion,+        dopt, dopt_set, dopt_unset,+        gopt, gopt_set, gopt_unset, setGeneralFlag', unSetGeneralFlag',+        wopt, wopt_set, wopt_unset,+        wopt_fatal,+        xopt, xopt_set, xopt_unset,+        lang_set,+        useUnicodeSyntax,+        whenGeneratingDynamicToo, ifGeneratingDynamicToo,+        whenCannotGenerateDynamicToo,+        dynamicTooMkDynamicDynFlags,+        DynFlags(..),+        FlagSpec(..),+        HasDynFlags(..), ContainsDynFlags(..),+        RtsOptsEnabled(..),+        HscTarget(..), isObjectTarget, defaultObjectTarget,+        targetRetainsAllBindings,+        GhcMode(..), isOneShot,+        GhcLink(..), isNoLink,+        PackageFlag(..), PackageArg(..), ModRenaming(..),+        packageFlagsChanged,+        IgnorePackageFlag(..), TrustFlag(..),+        PackageDBFlag(..), PkgConfRef(..),+        Option(..), showOpt,+        DynLibLoader(..),+        fFlags, fLangFlags, xFlags,+        wWarningFlags,+        dynFlagDependencies,+        tablesNextToCode, mkTablesNextToCode,+        makeDynFlagsConsistent,+        shouldUseColor,++        Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays,+        wayGeneralFlags, wayUnsetGeneralFlags,++        thisPackage, thisComponentId, thisUnitIdInsts,++        -- ** Log output+        putLogMsg,++        -- ** Safe Haskell+        SafeHaskellMode(..),+        safeHaskellOn, safeImportsOn, safeLanguageOn, safeInferOn,+        packageTrustOn,+        safeDirectImpsReq, safeImplicitImpsReq,+        unsafeFlags, unsafeFlagsForInfer,++        -- ** System tool settings and locations+        Settings(..),+        targetPlatform, programName, projectVersion,+        ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings,+        versionedAppDir,+        extraGccViaCFlags, systemPackageConfig,+        pgm_L, pgm_P, pgm_F, pgm_c, pgm_s, pgm_a, pgm_l, pgm_dll, pgm_T,+        pgm_windres, pgm_libtool, pgm_lo, pgm_lc, pgm_i,+        opt_L, opt_P, opt_F, opt_c, opt_a, opt_l, opt_i,+        opt_windres, opt_lo, opt_lc,+++        -- ** Manipulating DynFlags+        defaultDynFlags,                -- Settings -> DynFlags+        defaultWays,+        interpWays,+        interpreterProfiled, interpreterDynamic,+        initDynFlags,                   -- DynFlags -> IO DynFlags+        defaultFatalMessager,+        defaultLogAction,+        defaultLogActionHPrintDoc,+        defaultLogActionHPutStrDoc,+        defaultFlushOut,+        defaultFlushErr,++        getOpts,                        -- DynFlags -> (DynFlags -> [a]) -> [a]+        getVerbFlags,+        updOptLevel,+        setTmpDir,+        setUnitId,+        interpretPackageEnv,+        canonicalizeHomeModule,++        -- ** Parsing DynFlags+        parseDynamicFlagsCmdLine,+        parseDynamicFilePragma,+        parseDynamicFlagsFull,++        -- ** Available DynFlags+        allNonDeprecatedFlags,+        flagsAll,+        flagsDynamic,+        flagsPackage,+        flagsForCompletion,++        supportedLanguagesAndExtensions,+        languageExtensions,++        -- ** DynFlags C compiler options+        picCCOpts, picPOpts,++        -- * Compiler configuration suitable for display to the user+        compilerInfo,++        rtsIsProfiled,+        dynamicGhc,++#include "GHCConstantsHaskellExports.hs"+        bLOCK_SIZE_W,+        wORD_SIZE_IN_BITS,+        tAG_MASK,+        mAX_PTR_TAG,+        tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD,++        unsafeGlobalDynFlags, setUnsafeGlobalDynFlags,++        -- * SSE and AVX+        isSseEnabled,+        isSse2Enabled,+        isSse4_2Enabled,+        isAvxEnabled,+        isAvx2Enabled,+        isAvx512cdEnabled,+        isAvx512erEnabled,+        isAvx512fEnabled,+        isAvx512pfEnabled,++        -- * Linker/compiler information+        LinkerInfo(..),+        CompilerInfo(..),+  ) where++#include "HsVersions.h"++import Platform+import PlatformConstants+import Module+import PackageConfig+import {-# SOURCE #-} Hooks+import {-# SOURCE #-} PrelNames ( mAIN )+import {-# SOURCE #-} Packages (PackageState, emptyPackageState)+import DriverPhases     ( Phase(..), phaseInputExt )+import Config+import CmdLineParser+import Constants+import Panic+import qualified PprColour as Col+import Util+import Maybes+import MonadUtils+import qualified Pretty+import SrcLoc+import BasicTypes       ( IntWithInf, treatZeroAsInf )+import FastString+import Outputable+import Foreign.C        ( CInt(..) )+import System.IO.Unsafe ( unsafeDupablePerformIO )+import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn+                               , getCaretDiagnostic, dumpSDoc )+import Json+import SysTools.Terminal ( stderrSupportsAnsiColors )++import System.IO.Unsafe ( unsafePerformIO )+import Data.IORef+import Control.Arrow ((&&&))+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Writer+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Except+import Control.Exception (throwIO)++import Data.Ord+import Data.Bits+import Data.Char+import Data.Int+import Data.List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Word+import System.FilePath+import System.Directory+import System.Environment (getEnv, lookupEnv)+import System.IO+import System.IO.Error+import Text.ParserCombinators.ReadP hiding (char)+import Text.ParserCombinators.ReadP as R++import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet++import GHC.Foreign (withCString, peekCString)+import qualified GHC.LanguageExtensions as LangExt++import Foreign (Ptr) -- needed for 2nd stage++-- Note [Updating flag description in the User's Guide]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- If you modify anything in this file please make sure that your changes are+-- described in the User's Guide. Usually at least two sections need to be+-- updated:+--+--  * Flag Reference section generated from the modules in+--    utils/mkUserGuidePart/Options+--+--  * Flag description in docs/users_guide/using.rst provides a detailed+--    explanation of flags' usage.++-- Note [Supporting CLI completion]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- The command line interface completion (in for example bash) is an easy way+-- for the developer to learn what flags are available from GHC.+-- GHC helps by separating which flags are available when compiling with GHC,+-- and which flags are available when using GHCi.+-- A flag is assumed to either work in both these modes, or only in one of them.+-- When adding or changing a flag, please consider for which mode the flag will+-- have effect, and annotate it accordingly. For Flags use defFlag, defGhcFlag,+-- defGhciFlag, and for FlagSpec use flagSpec or flagGhciSpec.++-- Note [Adding a language extension]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- There are a few steps to adding (or removing) a language extension,+--+--  * Adding the extension to GHC.LanguageExtensions+--+--    The Extension type in libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs+--    is the canonical list of language extensions known by GHC.+--+--  * Adding a flag to DynFlags.xFlags+--+--    This is fairly self-explanatory. The name should be concise, memorable,+--    and consistent with any previous implementations of the similar idea in+--    other Haskell compilers.+--+--  * Adding the flag to the documentation+--+--    This is the same as any other flag. See+--    Note [Updating flag description in the User's Guide]+--+--  * Adding the flag to Cabal+--+--    The Cabal library has its own list of all language extensions supported+--    by all major compilers. This is the list that user code being uploaded+--    to Hackage is checked against to ensure language extension validity.+--    Consequently, it is very important that this list remains up-to-date.+--+--    To this end, there is a testsuite test (testsuite/tests/driver/T4437.hs)+--    whose job it is to ensure these GHC's extensions are consistent with+--    Cabal.+--+--    The recommended workflow is,+--+--     1. Temporarily add your new language extension to the+--        expectedGhcOnlyExtensions list in T4437 to ensure the test doesn't+--        break while Cabal is updated.+--+--     2. After your GHC change is accepted, submit a Cabal pull request adding+--        your new extension to Cabal's list (found in+--        Cabal/Language/Haskell/Extension.hs).+--+--     3. After your Cabal change is accepted, let the GHC developers know so+--        they can update the Cabal submodule and remove the extensions from+--        expectedGhcOnlyExtensions.+--+--  * Adding the flag to the GHC Wiki+--+--    There is a change log tracking language extension additions and removals+--    on the GHC wiki:  https://ghc.haskell.org/trac/ghc/wiki/LanguagePragmaHistory+--+--  See Trac #4437 and #8176.++-- -----------------------------------------------------------------------------+-- DynFlags++data DumpFlag+-- See Note [Updating flag description in the User's Guide]++   -- debugging flags+   = Opt_D_dump_cmm+   | Opt_D_dump_cmm_from_stg+   | Opt_D_dump_cmm_raw+   | Opt_D_dump_cmm_verbose+   -- All of the cmm subflags (there are a lot!) automatically+   -- enabled if you run -ddump-cmm-verbose+   -- Each flag corresponds to exact stage of Cmm pipeline.+   | Opt_D_dump_cmm_cfg+   | Opt_D_dump_cmm_cbe+   | Opt_D_dump_cmm_switch+   | Opt_D_dump_cmm_proc+   | Opt_D_dump_cmm_sp+   | Opt_D_dump_cmm_sink+   | Opt_D_dump_cmm_caf+   | Opt_D_dump_cmm_procmap+   | Opt_D_dump_cmm_split+   | Opt_D_dump_cmm_info+   | Opt_D_dump_cmm_cps+   -- end cmm subflags+   | Opt_D_dump_asm+   | Opt_D_dump_asm_native+   | Opt_D_dump_asm_liveness+   | Opt_D_dump_asm_regalloc+   | Opt_D_dump_asm_regalloc_stages+   | Opt_D_dump_asm_conflicts+   | Opt_D_dump_asm_stats+   | Opt_D_dump_asm_expanded+   | Opt_D_dump_llvm+   | Opt_D_dump_core_stats+   | Opt_D_dump_deriv+   | Opt_D_dump_ds+   | Opt_D_dump_foreign+   | Opt_D_dump_inlinings+   | Opt_D_dump_rule_firings+   | Opt_D_dump_rule_rewrites+   | Opt_D_dump_simpl_trace+   | Opt_D_dump_occur_anal+   | Opt_D_dump_parsed+   | Opt_D_dump_parsed_ast+   | Opt_D_dump_rn+   | Opt_D_dump_rn_ast+   | Opt_D_dump_shape+   | Opt_D_dump_simpl+   | Opt_D_dump_simpl_iterations+   | Opt_D_dump_spec+   | Opt_D_dump_prep+   | Opt_D_dump_stg+   | Opt_D_dump_call_arity+   | Opt_D_dump_stranal+   | Opt_D_dump_str_signatures+   | Opt_D_dump_tc+   | Opt_D_dump_tc_ast+   | Opt_D_dump_types+   | Opt_D_dump_rules+   | Opt_D_dump_cse+   | Opt_D_dump_worker_wrapper+   | Opt_D_dump_rn_trace+   | Opt_D_dump_rn_stats+   | Opt_D_dump_opt_cmm+   | Opt_D_dump_simpl_stats+   | Opt_D_dump_cs_trace -- Constraint solver in type checker+   | Opt_D_dump_tc_trace+   | Opt_D_dump_ec_trace -- Pattern match exhaustiveness checker+   | Opt_D_dump_if_trace+   | Opt_D_dump_vt_trace+   | Opt_D_dump_splices+   | Opt_D_th_dec_file+   | Opt_D_dump_BCOs+   | Opt_D_dump_vect+   | Opt_D_dump_ticked+   | Opt_D_dump_rtti+   | Opt_D_source_stats+   | Opt_D_verbose_stg2stg+   | Opt_D_dump_hi+   | Opt_D_dump_hi_diffs+   | Opt_D_dump_mod_cycles+   | Opt_D_dump_mod_map+   | Opt_D_dump_view_pattern_commoning+   | Opt_D_verbose_core2core+   | Opt_D_dump_debug+   | Opt_D_dump_json+   | Opt_D_ppr_debug+   | Opt_D_no_debug_output+   deriving (Eq, Show, Enum)++-- | Enumerates the simple on-or-off dynamic flags+data GeneralFlag+-- See Note [Updating flag description in the User's Guide]++   = Opt_DumpToFile                     -- ^ Append dump output to files instead of stdout.+   | Opt_D_faststring_stats+   | Opt_D_dump_minimal_imports+   | Opt_DoCoreLinting+   | Opt_DoStgLinting+   | Opt_DoCmmLinting+   | Opt_DoAsmLinting+   | Opt_DoAnnotationLinting+   | Opt_NoLlvmMangler                 -- hidden flag++   | Opt_WarnIsError                    -- -Werror; makes warnings fatal+   | Opt_ShowWarnGroups                 -- Show the group a warning belongs to+   | Opt_HideSourcePaths                -- Hide module source/object paths++   | Opt_PrintExplicitForalls+   | Opt_PrintExplicitKinds+   | Opt_PrintExplicitCoercions+   | Opt_PrintExplicitRuntimeReps+   | Opt_PrintEqualityRelations+   | Opt_PrintUnicodeSyntax+   | Opt_PrintExpandedSynonyms+   | Opt_PrintPotentialInstances+   | Opt_PrintTypecheckerElaboration++   -- optimisation opts+   | Opt_CallArity+   | Opt_Strictness+   | Opt_LateDmdAnal+   | Opt_KillAbsence+   | Opt_KillOneShot+   | Opt_FullLaziness+   | Opt_FloatIn+   | Opt_Specialise+   | Opt_SpecialiseAggressively+   | Opt_CrossModuleSpecialise+   | Opt_StaticArgumentTransformation+   | Opt_CSE+   | Opt_StgCSE+   | Opt_LiberateCase+   | Opt_SpecConstr+   | Opt_SpecConstrKeen+   | Opt_DoLambdaEtaExpansion+   | Opt_IgnoreAsserts+   | Opt_DoEtaReduction+   | Opt_CaseMerge+   | Opt_CaseFolding                    -- Constant folding through case-expressions+   | Opt_UnboxStrictFields+   | Opt_UnboxSmallStrictFields+   | Opt_DictsCheap+   | Opt_EnableRewriteRules             -- Apply rewrite rules during simplification+   | Opt_Vectorise+   | Opt_VectorisationAvoidance+   | Opt_RegsGraph                      -- do graph coloring register allocation+   | Opt_RegsIterative                  -- do iterative coalescing graph coloring register allocation+   | Opt_PedanticBottoms                -- Be picky about how we treat bottom+   | Opt_LlvmTBAA                       -- Use LLVM TBAA infastructure for improving AA (hidden flag)+   | Opt_LlvmPassVectorsInRegisters     -- Pass SIMD vectors in registers (requires a patched LLVM) (hidden flag)+   | Opt_LlvmFillUndefWithGarbage       -- Testing for undef bugs (hidden flag)+   | Opt_IrrefutableTuples+   | Opt_CmmSink+   | Opt_CmmElimCommonBlocks+   | Opt_OmitYields+   | Opt_FunToThunk               -- allow WwLib.mkWorkerArgs to remove all value lambdas+   | Opt_DictsStrict                     -- be strict in argument dictionaries+   | Opt_DmdTxDictSel              -- use a special demand transformer for dictionary selectors+   | Opt_Loopification                  -- See Note [Self-recursive tail calls]+   | Opt_CprAnal+   | Opt_WorkerWrapper+   | Opt_SolveConstantDicts++   -- Interface files+   | Opt_IgnoreInterfacePragmas+   | Opt_OmitInterfacePragmas+   | Opt_ExposeAllUnfoldings+   | Opt_WriteInterface -- forces .hi files to be written even with -fno-code++   -- profiling opts+   | Opt_AutoSccsOnIndividualCafs+   | Opt_ProfCountEntries++   -- misc opts+   | Opt_Pp+   | Opt_ForceRecomp+   | Opt_ExcessPrecision+   | Opt_EagerBlackHoling+   | Opt_NoHsMain+   | Opt_SplitObjs+   | Opt_SplitSections+   | Opt_StgStats+   | Opt_HideAllPackages+   | Opt_HideAllPluginPackages+   | Opt_PrintBindResult+   | Opt_Haddock+   | Opt_HaddockOptions+   | Opt_BreakOnException+   | Opt_BreakOnError+   | Opt_PrintEvldWithShow+   | Opt_PrintBindContents+   | Opt_GenManifest+   | Opt_EmbedManifest+   | Opt_SharedImplib+   | Opt_BuildingCabalPackage+   | Opt_IgnoreDotGhci+   | Opt_GhciSandbox+   | Opt_GhciHistory+   | Opt_LocalGhciHistory+   | Opt_HelpfulErrors+   | Opt_DeferTypeErrors+   | Opt_DeferTypedHoles+   | Opt_DeferOutOfScopeVariables+   | Opt_PIC+   | Opt_SccProfilingOn+   | Opt_Ticky+   | Opt_Ticky_Allocd+   | Opt_Ticky_LNE+   | Opt_Ticky_Dyn_Thunk+   | Opt_RPath+   | Opt_RelativeDynlibPaths+   | Opt_Hpc+   | Opt_FlatCache+   | Opt_ExternalInterpreter+   | Opt_OptimalApplicativeDo+   | Opt_VersionMacros+   | Opt_WholeArchiveHsLibs++   -- PreInlining is on by default. The option is there just to see how+   -- bad things get if you turn it off!+   | Opt_SimplPreInlining++   -- output style opts+   | Opt_ErrorSpans -- Include full span info in error messages,+                    -- instead of just the start position.+   | Opt_DiagnosticsShowCaret -- Show snippets of offending code+   | Opt_PprCaseAsLet+   | Opt_PprShowTicks+   | Opt_ShowHoleConstraints++   -- Suppress all coercions, them replacing with '...'+   | Opt_SuppressCoercions+   | Opt_SuppressVarKinds+   -- Suppress module id prefixes on variables.+   | Opt_SuppressModulePrefixes+   -- Suppress type applications.+   | Opt_SuppressTypeApplications+   -- Suppress info such as arity and unfoldings on identifiers.+   | Opt_SuppressIdInfo+   -- Suppress separate type signatures in core, but leave types on+   -- lambda bound vars+   | Opt_SuppressUnfoldings+   -- Suppress the details of even stable unfoldings+   | Opt_SuppressTypeSignatures+   -- Suppress unique ids on variables.+   -- Except for uniques, as some simplifier phases introduce new+   -- variables that have otherwise identical names.+   | Opt_SuppressUniques+   | Opt_SuppressTicks     -- Replaces Opt_PprShowTicks++   -- temporary flags+   | Opt_AutoLinkPackages+   | Opt_ImplicitImportQualified++   -- keeping stuff+   | Opt_KeepHiDiffs+   | Opt_KeepHcFiles+   | Opt_KeepSFiles+   | Opt_KeepTmpFiles+   | Opt_KeepRawTokenStream+   | Opt_KeepLlvmFiles+   | Opt_KeepHiFiles+   | Opt_KeepOFiles++   | Opt_BuildDynamicToo++   -- safe haskell flags+   | Opt_DistrustAllPackages+   | Opt_PackageTrust++   | Opt_G_NoStateHack+   | Opt_G_NoOptCoercion+   deriving (Eq, Show, Enum)++-- | Used when outputting warnings: if a reason is given, it is+-- displayed. If a warning isn't controlled by a flag, this is made+-- explicit at the point of use.+data WarnReason = NoReason | Reason !WarningFlag+  deriving Show++instance Outputable WarnReason where+  ppr = text . show++instance ToJson WarnReason where+  json NoReason = JSNull+  json (Reason wf) = JSString (show wf)++data WarningFlag =+-- See Note [Updating flag description in the User's Guide]+     Opt_WarnDuplicateExports+   | Opt_WarnDuplicateConstraints+   | Opt_WarnRedundantConstraints+   | Opt_WarnHiShadows+   | Opt_WarnImplicitPrelude+   | Opt_WarnIncompletePatterns+   | Opt_WarnIncompleteUniPatterns+   | Opt_WarnIncompletePatternsRecUpd+   | Opt_WarnOverflowedLiterals+   | Opt_WarnEmptyEnumerations+   | Opt_WarnMissingFields+   | Opt_WarnMissingImportList+   | Opt_WarnMissingMethods+   | Opt_WarnMissingSignatures+   | Opt_WarnMissingLocalSignatures+   | Opt_WarnNameShadowing+   | Opt_WarnOverlappingPatterns+   | Opt_WarnTypeDefaults+   | Opt_WarnMonomorphism+   | Opt_WarnUnusedTopBinds+   | Opt_WarnUnusedLocalBinds+   | Opt_WarnUnusedPatternBinds+   | Opt_WarnUnusedImports+   | Opt_WarnUnusedMatches+   | Opt_WarnUnusedTypePatterns+   | Opt_WarnUnusedForalls+   | Opt_WarnWarningsDeprecations+   | Opt_WarnDeprecatedFlags+   | Opt_WarnAMP -- Introduced in GHC 7.8, obsolete since 7.10+   | Opt_WarnMissingMonadFailInstances -- since 8.0+   | Opt_WarnSemigroup -- since 8.0+   | Opt_WarnDodgyExports+   | Opt_WarnDodgyImports+   | Opt_WarnOrphans+   | Opt_WarnAutoOrphans+   | Opt_WarnIdentities+   | Opt_WarnTabs+   | Opt_WarnUnrecognisedPragmas+   | Opt_WarnDodgyForeignImports+   | Opt_WarnUnusedDoBind+   | Opt_WarnWrongDoBind+   | Opt_WarnAlternativeLayoutRuleTransitional+   | Opt_WarnUnsafe+   | Opt_WarnSafe+   | Opt_WarnTrustworthySafe+   | Opt_WarnMissedSpecs+   | Opt_WarnAllMissedSpecs+   | Opt_WarnUnsupportedCallingConventions+   | Opt_WarnUnsupportedLlvmVersion+   | Opt_WarnInlineRuleShadowing+   | Opt_WarnTypedHoles+   | Opt_WarnPartialTypeSignatures+   | Opt_WarnMissingExportedSignatures+   | Opt_WarnUntickedPromotedConstructors+   | Opt_WarnDerivingTypeable+   | Opt_WarnDeferredTypeErrors+   | Opt_WarnDeferredOutOfScopeVariables+   | Opt_WarnNonCanonicalMonadInstances   -- since 8.0+   | Opt_WarnNonCanonicalMonadFailInstances -- since 8.0+   | Opt_WarnNonCanonicalMonoidInstances  -- since 8.0+   | Opt_WarnMissingPatternSynonymSignatures -- since 8.0+   | Opt_WarnUnrecognisedWarningFlags     -- since 8.0+   | Opt_WarnSimplifiableClassConstraints -- Since 8.2+   | Opt_WarnCPPUndef                     -- Since 8.2+   | Opt_WarnUnbangedStrictPatterns       -- Since 8.2+   | Opt_WarnMissingHomeModules           -- Since 8.2+   deriving (Eq, Show, Enum)++data Language = Haskell98 | Haskell2010+   deriving (Eq, Enum, Show)++instance Outputable Language where+    ppr = text . show++-- | The various Safe Haskell modes+data SafeHaskellMode+   = Sf_None+   | Sf_Unsafe+   | Sf_Trustworthy+   | Sf_Safe+   deriving (Eq)++instance Show SafeHaskellMode where+    show Sf_None         = "None"+    show Sf_Unsafe       = "Unsafe"+    show Sf_Trustworthy  = "Trustworthy"+    show Sf_Safe         = "Safe"++instance Outputable SafeHaskellMode where+    ppr = text . show++-- | Contains not only a collection of 'GeneralFlag's but also a plethora of+-- information relating to the compilation of a single file or GHC session+data DynFlags = DynFlags {+  ghcMode               :: GhcMode,+  ghcLink               :: GhcLink,+  hscTarget             :: HscTarget,+  settings              :: Settings,+  verbosity             :: Int,         -- ^ Verbosity level: see Note [Verbosity levels]+  optLevel              :: Int,         -- ^ Optimisation level+  debugLevel            :: Int,         -- ^ How much debug information to produce+  simplPhases           :: Int,         -- ^ Number of simplifier phases+  maxSimplIterations    :: Int,         -- ^ Max simplifier iterations+  maxPmCheckIterations  :: Int,         -- ^ Max no iterations for pm checking+  ruleCheck             :: Maybe String,+  strictnessBefore      :: [Int],       -- ^ Additional demand analysis++  parMakeCount          :: Maybe Int,   -- ^ The number of modules to compile in parallel+                                        --   in --make mode, where Nothing ==> compile as+                                        --   many in parallel as there are CPUs.++  enableTimeStats       :: Bool,        -- ^ Enable RTS timing statistics?+  ghcHeapSize           :: Maybe Int,   -- ^ The heap size to set.++  maxRelevantBinds      :: Maybe Int,   -- ^ Maximum number of bindings from the type envt+                                        --   to show in type error messages+  maxUncoveredPatterns  :: Int,         -- ^ Maximum number of unmatched patterns to show+                                        --   in non-exhaustiveness warnings+  simplTickFactor       :: Int,         -- ^ Multiplier for simplifier ticks+  specConstrThreshold   :: Maybe Int,   -- ^ Threshold for SpecConstr+  specConstrCount       :: Maybe Int,   -- ^ Max number of specialisations for any one function+  specConstrRecursive   :: Int,         -- ^ Max number of specialisations for recursive types+                                        --   Not optional; otherwise ForceSpecConstr can diverge.+  liberateCaseThreshold :: Maybe Int,   -- ^ Threshold for LiberateCase+  floatLamArgs          :: Maybe Int,   -- ^ Arg count for lambda floating+                                        --   See CoreMonad.FloatOutSwitches++  historySize           :: Int,         -- ^ Simplification history size++  importPaths           :: [FilePath],+  mainModIs             :: Module,+  mainFunIs             :: Maybe String,+  reductionDepth        :: IntWithInf,   -- ^ Typechecker maximum stack depth+  solverIterations      :: IntWithInf,   -- ^ Number of iterations in the constraints solver+                                         --   Typically only 1 is needed++  thisInstalledUnitId   :: InstalledUnitId,+  thisComponentId_      :: Maybe ComponentId,+  thisUnitIdInsts_      :: Maybe [(ModuleName, Module)],++  -- ways+  ways                  :: [Way],       -- ^ Way flags from the command line+  buildTag              :: String,      -- ^ The global \"way\" (e.g. \"p\" for prof)+  rtsBuildTag           :: String,      -- ^ The RTS \"way\"++  -- For object splitting+  splitInfo             :: Maybe (String,Int),++  -- paths etc.+  objectDir             :: Maybe String,+  dylibInstallName      :: Maybe String,+  hiDir                 :: Maybe String,+  stubDir               :: Maybe String,+  dumpDir               :: Maybe String,++  objectSuf             :: String,+  hcSuf                 :: String,+  hiSuf                 :: String,++  canGenerateDynamicToo :: IORef Bool,+  dynObjectSuf          :: String,+  dynHiSuf              :: String,++  -- Packages.isDllName needs to know whether a call is within a+  -- single DLL or not. Normally it does this by seeing if the call+  -- is to the same package, but for the ghc package, we split the+  -- package between 2 DLLs. The dllSplit tells us which sets of+  -- modules are in which package.+  dllSplitFile          :: Maybe FilePath,+  dllSplit              :: Maybe [Set String],++  outputFile            :: Maybe String,+  dynOutputFile         :: Maybe String,+  outputHi              :: Maybe String,+  dynLibLoader          :: DynLibLoader,++  -- | This is set by 'DriverPipeline.runPipeline' based on where+  --    its output is going.+  dumpPrefix            :: Maybe FilePath,++  -- | Override the 'dumpPrefix' set by 'DriverPipeline.runPipeline'.+  --    Set by @-ddump-file-prefix@+  dumpPrefixForce       :: Maybe FilePath,++  ldInputs              :: [Option],++  includePaths          :: [String],+  libraryPaths          :: [String],+  frameworkPaths        :: [String],    -- used on darwin only+  cmdlineFrameworks     :: [String],    -- ditto++  rtsOpts               :: Maybe String,+  rtsOptsEnabled        :: RtsOptsEnabled,+  rtsOptsSuggestions    :: Bool,++  hpcDir                :: String,      -- ^ Path to store the .mix files++  -- Plugins+  pluginModNames        :: [ModuleName],+  pluginModNameOpts     :: [(ModuleName,String)],+  frontendPluginOpts    :: [String],+    -- ^ the @-ffrontend-opt@ flags given on the command line, in *reverse*+    -- order that they're specified on the command line.++  -- GHC API hooks+  hooks                 :: Hooks,++  --  For ghc -M+  depMakefile           :: FilePath,+  depIncludePkgDeps     :: Bool,+  depExcludeMods        :: [ModuleName],+  depSuffixes           :: [String],++  --  Package flags+  packageDBFlags        :: [PackageDBFlag],+        -- ^ The @-package-db@ flags given on the command line, In+        -- *reverse* order that they're specified on the command line.+        -- This is intended to be applied with the list of "initial"+        -- package databases derived from @GHC_PACKAGE_PATH@; see+        -- 'getPackageConfRefs'.++  ignorePackageFlags    :: [IgnorePackageFlag],+        -- ^ The @-ignore-package@ flags from the command line.+        -- In *reverse* order that they're specified on the command line.+  packageFlags          :: [PackageFlag],+        -- ^ The @-package@ and @-hide-package@ flags from the command-line.+        -- In *reverse* order that they're specified on the command line.+  pluginPackageFlags    :: [PackageFlag],+        -- ^ The @-plugin-package-id@ flags from command line.+        -- In *reverse* order that they're specified on the command line.+  trustFlags            :: [TrustFlag],+        -- ^ The @-trust@ and @-distrust@ flags.+        -- In *reverse* order that they're specified on the command line.+  packageEnv            :: Maybe FilePath,+        -- ^ Filepath to the package environment file (if overriding default)++  -- Package state+  -- NB. do not modify this field, it is calculated by+  -- Packages.initPackages+  pkgDatabase           :: Maybe [(FilePath, [PackageConfig])],+  pkgState              :: PackageState,++  -- Temporary files+  -- These have to be IORefs, because the defaultCleanupHandler needs to+  -- know what to clean when an exception happens+  filesToClean          :: IORef [FilePath],+  dirsToClean           :: IORef (Map FilePath FilePath),+  filesToNotIntermediateClean :: IORef [FilePath],+  -- The next available suffix to uniquely name a temp file, updated atomically+  nextTempSuffix        :: IORef Int,++  -- Names of files which were generated from -ddump-to-file; used to+  -- track which ones we need to truncate because it's our first run+  -- through+  generatedDumps        :: IORef (Set FilePath),++  -- hsc dynamic flags+  dumpFlags             :: IntSet,+  generalFlags          :: IntSet,+  warningFlags          :: IntSet,+  fatalWarningFlags     :: IntSet,+  -- Don't change this without updating extensionFlags:+  language              :: Maybe Language,+  -- | Safe Haskell mode+  safeHaskell           :: SafeHaskellMode,+  safeInfer             :: Bool,+  safeInferred          :: Bool,+  -- We store the location of where some extension and flags were turned on so+  -- we can produce accurate error messages when Safe Haskell fails due to+  -- them.+  thOnLoc               :: SrcSpan,+  newDerivOnLoc         :: SrcSpan,+  overlapInstLoc        :: SrcSpan,+  incoherentOnLoc       :: SrcSpan,+  pkgTrustOnLoc         :: SrcSpan,+  warnSafeOnLoc         :: SrcSpan,+  warnUnsafeOnLoc       :: SrcSpan,+  trustworthyOnLoc      :: SrcSpan,+  -- Don't change this without updating extensionFlags:+  extensions            :: [OnOff LangExt.Extension],+  -- extensionFlags should always be equal to+  --     flattenExtensionFlags language extensions+  -- LangExt.Extension is defined in libraries/ghc-boot so that it can be used+  -- by template-haskell+  extensionFlags        :: IntSet,++  -- Unfolding control+  -- See Note [Discounts and thresholds] in CoreUnfold+  ufCreationThreshold   :: Int,+  ufUseThreshold        :: Int,+  ufFunAppDiscount      :: Int,+  ufDictDiscount        :: Int,+  ufKeenessFactor       :: Float,+  ufDearOp              :: Int,+  ufVeryAggressive      :: Bool,++  maxWorkerArgs         :: Int,++  ghciHistSize          :: Int,++  -- | MsgDoc output action: use "ErrUtils" instead of this if you can+  initLogAction         :: IO (Maybe LogOutput),+  log_action            :: LogAction,+  log_finaliser         :: LogFinaliser,+  flushOut              :: FlushOut,+  flushErr              :: FlushErr,++  haddockOptions        :: Maybe String,++  -- | GHCi scripts specified by -ghci-script, in reverse order+  ghciScripts           :: [String],++  -- Output style options+  pprUserLength         :: Int,+  pprCols               :: Int,++  useUnicode            :: Bool,+  useColor              :: OverridingBool,+  canUseColor           :: Bool,+  colScheme             :: Col.Scheme,++  -- | what kind of {-# SCC #-} to add automatically+  profAuto              :: ProfAuto,++  interactivePrint      :: Maybe String,++  nextWrapperNum        :: IORef (ModuleEnv Int),++  -- | Machine dependent flags (-m<blah> stuff)+  sseVersion            :: Maybe SseVersion,+  avx                   :: Bool,+  avx2                  :: Bool,+  avx512cd              :: Bool, -- Enable AVX-512 Conflict Detection Instructions.+  avx512er              :: Bool, -- Enable AVX-512 Exponential and Reciprocal Instructions.+  avx512f               :: Bool, -- Enable AVX-512 instructions.+  avx512pf              :: Bool, -- Enable AVX-512 PreFetch Instructions.++  -- | Run-time linker information (what options we need, etc.)+  rtldInfo              :: IORef (Maybe LinkerInfo),++  -- | Run-time compiler information+  rtccInfo              :: IORef (Maybe CompilerInfo),++  -- Constants used to control the amount of optimization done.++  -- | Max size, in bytes, of inline array allocations.+  maxInlineAllocSize    :: Int,++  -- | Only inline memcpy if it generates no more than this many+  -- pseudo (roughly: Cmm) instructions.+  maxInlineMemcpyInsns  :: Int,++  -- | Only inline memset if it generates no more than this many+  -- pseudo (roughly: Cmm) instructions.+  maxInlineMemsetInsns  :: Int,++  -- | Reverse the order of error messages in GHC/GHCi+  reverseErrors         :: Bool,++  -- | Limit the maximum number of errors to show+  maxErrors             :: Maybe Int,++  -- | Unique supply configuration for testing build determinism+  initialUnique         :: Int,+  uniqueIncrement       :: Int+}++class HasDynFlags m where+    getDynFlags :: m DynFlags++{- It would be desirable to have the more generalised++  instance (MonadTrans t, Monad m, HasDynFlags m) => HasDynFlags (t m) where+      getDynFlags = lift getDynFlags++instance definition. However, that definition would overlap with the+`HasDynFlags (GhcT m)` instance. Instead we define instances for a+couple of common Monad transformers explicitly. -}++instance (Monoid a, Monad m, HasDynFlags m) => HasDynFlags (WriterT a m) where+    getDynFlags = lift getDynFlags++instance (Monad m, HasDynFlags m) => HasDynFlags (ReaderT a m) where+    getDynFlags = lift getDynFlags++instance (Monad m, HasDynFlags m) => HasDynFlags (MaybeT m) where+    getDynFlags = lift getDynFlags++instance (Monad m, HasDynFlags m) => HasDynFlags (ExceptT e m) where+    getDynFlags = lift getDynFlags++class ContainsDynFlags t where+    extractDynFlags :: t -> DynFlags++data ProfAuto+  = NoProfAuto         -- ^ no SCC annotations added+  | ProfAutoAll        -- ^ top-level and nested functions are annotated+  | ProfAutoTop        -- ^ top-level functions annotated only+  | ProfAutoExports    -- ^ exported functions annotated only+  | ProfAutoCalls      -- ^ annotate call-sites+  deriving (Eq,Enum)++data Settings = Settings {+  sTargetPlatform        :: Platform,    -- Filled in by SysTools+  sGhcUsagePath          :: FilePath,    -- Filled in by SysTools+  sGhciUsagePath         :: FilePath,    -- ditto+  sTopDir                :: FilePath,+  sTmpDir                :: String,      -- no trailing '/'+  sProgramName           :: String,+  sProjectVersion        :: String,+  -- You shouldn't need to look things up in rawSettings directly.+  -- They should have their own fields instead.+  sRawSettings           :: [(String, String)],+  sExtraGccViaCFlags     :: [String],+  sSystemPackageConfig   :: FilePath,+  sLdSupportsCompactUnwind :: Bool,+  sLdSupportsBuildId       :: Bool,+  sLdSupportsFilelist      :: Bool,+  sLdIsGnuLd               :: Bool,+  sGccSupportsNoPie        :: Bool,+  -- commands for particular phases+  sPgm_L                 :: String,+  sPgm_P                 :: (String,[Option]),+  sPgm_F                 :: String,+  sPgm_c                 :: (String,[Option]),+  sPgm_s                 :: (String,[Option]),+  sPgm_a                 :: (String,[Option]),+  sPgm_l                 :: (String,[Option]),+  sPgm_dll               :: (String,[Option]),+  sPgm_T                 :: String,+  sPgm_windres           :: String,+  sPgm_libtool           :: String,+  sPgm_lo                :: (String,[Option]), -- LLVM: opt llvm optimiser+  sPgm_lc                :: (String,[Option]), -- LLVM: llc static compiler+  sPgm_i                 :: String,+  -- options for particular phases+  sOpt_L                 :: [String],+  sOpt_P                 :: [String],+  sOpt_F                 :: [String],+  sOpt_c                 :: [String],+  sOpt_a                 :: [String],+  sOpt_l                 :: [String],+  sOpt_windres           :: [String],+  sOpt_lo                :: [String], -- LLVM: llvm optimiser+  sOpt_lc                :: [String], -- LLVM: llc static compiler+  sOpt_i                 :: [String], -- iserv options++  sPlatformConstants     :: PlatformConstants+ }++targetPlatform :: DynFlags -> Platform+targetPlatform dflags = sTargetPlatform (settings dflags)+programName :: DynFlags -> String+programName dflags = sProgramName (settings dflags)+projectVersion :: DynFlags -> String+projectVersion dflags = sProjectVersion (settings dflags)+ghcUsagePath          :: DynFlags -> FilePath+ghcUsagePath dflags = sGhcUsagePath (settings dflags)+ghciUsagePath         :: DynFlags -> FilePath+ghciUsagePath dflags = sGhciUsagePath (settings dflags)+topDir                :: DynFlags -> FilePath+topDir dflags = sTopDir (settings dflags)+tmpDir                :: DynFlags -> String+tmpDir dflags = sTmpDir (settings dflags)+rawSettings           :: DynFlags -> [(String, String)]+rawSettings dflags = sRawSettings (settings dflags)+extraGccViaCFlags     :: DynFlags -> [String]+extraGccViaCFlags dflags = sExtraGccViaCFlags (settings dflags)+systemPackageConfig   :: DynFlags -> FilePath+systemPackageConfig dflags = sSystemPackageConfig (settings dflags)+pgm_L                 :: DynFlags -> String+pgm_L dflags = sPgm_L (settings dflags)+pgm_P                 :: DynFlags -> (String,[Option])+pgm_P dflags = sPgm_P (settings dflags)+pgm_F                 :: DynFlags -> String+pgm_F dflags = sPgm_F (settings dflags)+pgm_c                 :: DynFlags -> (String,[Option])+pgm_c dflags = sPgm_c (settings dflags)+pgm_s                 :: DynFlags -> (String,[Option])+pgm_s dflags = sPgm_s (settings dflags)+pgm_a                 :: DynFlags -> (String,[Option])+pgm_a dflags = sPgm_a (settings dflags)+pgm_l                 :: DynFlags -> (String,[Option])+pgm_l dflags = sPgm_l (settings dflags)+pgm_dll               :: DynFlags -> (String,[Option])+pgm_dll dflags = sPgm_dll (settings dflags)+pgm_T                 :: DynFlags -> String+pgm_T dflags = sPgm_T (settings dflags)+pgm_windres           :: DynFlags -> String+pgm_windres dflags = sPgm_windres (settings dflags)+pgm_libtool           :: DynFlags -> String+pgm_libtool dflags = sPgm_libtool (settings dflags)+pgm_lo                :: DynFlags -> (String,[Option])+pgm_lo dflags = sPgm_lo (settings dflags)+pgm_lc                :: DynFlags -> (String,[Option])+pgm_lc dflags = sPgm_lc (settings dflags)+pgm_i                 :: DynFlags -> String+pgm_i dflags = sPgm_i (settings dflags)+opt_L                 :: DynFlags -> [String]+opt_L dflags = sOpt_L (settings dflags)+opt_P                 :: DynFlags -> [String]+opt_P dflags = concatMap (wayOptP (targetPlatform dflags)) (ways dflags)+            ++ sOpt_P (settings dflags)+opt_F                 :: DynFlags -> [String]+opt_F dflags = sOpt_F (settings dflags)+opt_c                 :: DynFlags -> [String]+opt_c dflags = concatMap (wayOptc (targetPlatform dflags)) (ways dflags)+            ++ sOpt_c (settings dflags)+opt_a                 :: DynFlags -> [String]+opt_a dflags = sOpt_a (settings dflags)+opt_l                 :: DynFlags -> [String]+opt_l dflags = concatMap (wayOptl (targetPlatform dflags)) (ways dflags)+            ++ sOpt_l (settings dflags)+opt_windres           :: DynFlags -> [String]+opt_windres dflags = sOpt_windres (settings dflags)+opt_lo                :: DynFlags -> [String]+opt_lo dflags = sOpt_lo (settings dflags)+opt_lc                :: DynFlags -> [String]+opt_lc dflags = sOpt_lc (settings dflags)+opt_i                 :: DynFlags -> [String]+opt_i dflags = sOpt_i (settings dflags)++-- | The directory for this version of ghc in the user's app directory+-- (typically something like @~/.ghc/x86_64-linux-7.6.3@)+--+versionedAppDir :: DynFlags -> MaybeT IO FilePath+versionedAppDir dflags = do+  -- Make sure we handle the case the HOME isn't set (see #11678)+  appdir <- tryMaybeT $ getAppUserDataDirectory (programName dflags)+  return $ appdir </> versionedFilePath dflags++-- | A filepath like @x86_64-linux-7.6.3@ with the platform string to use when+-- constructing platform-version-dependent files that need to co-exist.+--+versionedFilePath :: DynFlags -> FilePath+versionedFilePath dflags =     TARGET_ARCH+                        ++ '-':TARGET_OS+                        ++ '-':projectVersion dflags+  -- NB: This functionality is reimplemented in Cabal, so if you+  -- change it, be sure to update Cabal.++-- | The target code type of the compilation (if any).+--+-- Whenever you change the target, also make sure to set 'ghcLink' to+-- something sensible.+--+-- 'HscNothing' can be used to avoid generating any output, however, note+-- that:+--+--  * If a program uses Template Haskell the typechecker may try to run code+--    from an imported module.  This will fail if no code has been generated+--    for this module.  You can use 'GHC.needsTemplateHaskell' to detect+--    whether this might be the case and choose to either switch to a+--    different target or avoid typechecking such modules.  (The latter may be+--    preferable for security reasons.)+--+data HscTarget+  = HscC           -- ^ Generate C code.+  | HscAsm         -- ^ Generate assembly using the native code generator.+  | HscLlvm        -- ^ Generate assembly using the llvm code generator.+  | HscInterpreted -- ^ Generate bytecode.  (Requires 'LinkInMemory')+  | HscNothing     -- ^ Don't generate any code.  See notes above.+  deriving (Eq, Show)++-- | Will this target result in an object file on the disk?+isObjectTarget :: HscTarget -> Bool+isObjectTarget HscC     = True+isObjectTarget HscAsm   = True+isObjectTarget HscLlvm  = True+isObjectTarget _        = False++-- | Does this target retain *all* top-level bindings for a module,+-- rather than just the exported bindings, in the TypeEnv and compiled+-- code (if any)?  In interpreted mode we do this, so that GHCi can+-- call functions inside a module.  In HscNothing mode we also do it,+-- so that Haddock can get access to the GlobalRdrEnv for a module+-- after typechecking it.+targetRetainsAllBindings :: HscTarget -> Bool+targetRetainsAllBindings HscInterpreted = True+targetRetainsAllBindings HscNothing     = True+targetRetainsAllBindings _              = False++-- | The 'GhcMode' tells us whether we're doing multi-module+-- compilation (controlled via the "GHC" API) or one-shot+-- (single-module) compilation.  This makes a difference primarily to+-- the "Finder": in one-shot mode we look for interface files for+-- imported modules, but in multi-module mode we look for source files+-- in order to check whether they need to be recompiled.+data GhcMode+  = CompManager         -- ^ @\-\-make@, GHCi, etc.+  | OneShot             -- ^ @ghc -c Foo.hs@+  | MkDepend            -- ^ @ghc -M@, see "Finder" for why we need this+  deriving Eq++instance Outputable GhcMode where+  ppr CompManager = text "CompManager"+  ppr OneShot     = text "OneShot"+  ppr MkDepend    = text "MkDepend"++isOneShot :: GhcMode -> Bool+isOneShot OneShot = True+isOneShot _other  = False++-- | What to do in the link step, if there is one.+data GhcLink+  = NoLink              -- ^ Don't link at all+  | LinkBinary          -- ^ Link object code into a binary+  | LinkInMemory        -- ^ Use the in-memory dynamic linker (works for both+                        --   bytecode and object code).+  | LinkDynLib          -- ^ Link objects into a dynamic lib (DLL on Windows, DSO on ELF platforms)+  | LinkStaticLib       -- ^ Link objects into a static lib+  deriving (Eq, Show)++isNoLink :: GhcLink -> Bool+isNoLink NoLink = True+isNoLink _      = False++-- | We accept flags which make packages visible, but how they select+-- the package varies; this data type reflects what selection criterion+-- is used.+data PackageArg =+      PackageArg String    -- ^ @-package@, by 'PackageName'+    | UnitIdArg UnitId     -- ^ @-package-id@, by 'UnitId'+  deriving (Eq, Show)+instance Outputable PackageArg where+    ppr (PackageArg pn) = text "package" <+> text pn+    ppr (UnitIdArg uid) = text "unit" <+> ppr uid++-- | Represents the renaming that may be associated with an exposed+-- package, e.g. the @rns@ part of @-package "foo (rns)"@.+--+-- Here are some example parsings of the package flags (where+-- a string literal is punned to be a 'ModuleName':+--+--      * @-package foo@ is @ModRenaming True []@+--      * @-package foo ()@ is @ModRenaming False []@+--      * @-package foo (A)@ is @ModRenaming False [("A", "A")]@+--      * @-package foo (A as B)@ is @ModRenaming False [("A", "B")]@+--      * @-package foo with (A as B)@ is @ModRenaming True [("A", "B")]@+data ModRenaming = ModRenaming {+    modRenamingWithImplicit :: Bool, -- ^ Bring all exposed modules into scope?+    modRenamings :: [(ModuleName, ModuleName)] -- ^ Bring module @m@ into scope+                                               --   under name @n@.+  } deriving (Eq)+instance Outputable ModRenaming where+    ppr (ModRenaming b rns) = ppr b <+> parens (ppr rns)++-- | Flags for manipulating the set of non-broken packages.+newtype IgnorePackageFlag = IgnorePackage String -- ^ @-ignore-package@+  deriving (Eq)++-- | Flags for manipulating package trust.+data TrustFlag+  = TrustPackage    String -- ^ @-trust@+  | DistrustPackage String -- ^ @-distrust@+  deriving (Eq)++-- | Flags for manipulating packages visibility.+data PackageFlag+  = ExposePackage   String PackageArg ModRenaming -- ^ @-package@, @-package-id@+  | HidePackage     String -- ^ @-hide-package@+  deriving (Eq) -- NB: equality instance is used by packageFlagsChanged++data PackageDBFlag+  = PackageDB PkgConfRef+  | NoUserPackageDB+  | NoGlobalPackageDB+  | ClearPackageDBs+  deriving (Eq)++packageFlagsChanged :: DynFlags -> DynFlags -> Bool+packageFlagsChanged idflags1 idflags0 =+  packageFlags idflags1 /= packageFlags idflags0 ||+  ignorePackageFlags idflags1 /= ignorePackageFlags idflags0 ||+  pluginPackageFlags idflags1 /= pluginPackageFlags idflags0 ||+  trustFlags idflags1 /= trustFlags idflags0 ||+  packageDBFlags idflags1 /= packageDBFlags idflags0 ||+  packageGFlags idflags1 /= packageGFlags idflags0+ where+   packageGFlags dflags = map (`gopt` dflags)+     [ Opt_HideAllPackages+     , Opt_HideAllPluginPackages+     , Opt_AutoLinkPackages ]++instance Outputable PackageFlag where+    ppr (ExposePackage n arg rn) = text n <> braces (ppr arg <+> ppr rn)+    ppr (HidePackage str) = text "-hide-package" <+> text str++defaultHscTarget :: Platform -> HscTarget+defaultHscTarget = defaultObjectTarget++-- | The 'HscTarget' value corresponding to the default way to create+-- object files on the current platform.+defaultObjectTarget :: Platform -> HscTarget+defaultObjectTarget platform+  | platformUnregisterised platform     =  HscC+  | cGhcWithNativeCodeGen == "YES"      =  HscAsm+  | otherwise                           =  HscLlvm++tablesNextToCode :: DynFlags -> Bool+tablesNextToCode dflags+    = mkTablesNextToCode (platformUnregisterised (targetPlatform dflags))++-- Determines whether we will be compiling+-- info tables that reside just before the entry code, or with an+-- indirection to the entry code.  See TABLES_NEXT_TO_CODE in+-- includes/rts/storage/InfoTables.h.+mkTablesNextToCode :: Bool -> Bool+mkTablesNextToCode unregisterised+    = not unregisterised && cGhcEnableTablesNextToCode == "YES"++data DynLibLoader+  = Deployable+  | SystemDependent+  deriving Eq++data RtsOptsEnabled = RtsOptsNone | RtsOptsSafeOnly | RtsOptsAll+  deriving (Show)++shouldUseColor :: DynFlags -> Bool+shouldUseColor dflags = overrideWith (canUseColor dflags) (useColor dflags)++-----------------------------------------------------------------------------+-- Ways++-- The central concept of a "way" is that all objects in a given+-- program must be compiled in the same "way".  Certain options change+-- parameters of the virtual machine, eg. profiling adds an extra word+-- to the object header, so profiling objects cannot be linked with+-- non-profiling objects.++-- After parsing the command-line options, we determine which "way" we+-- are building - this might be a combination way, eg. profiling+threaded.++-- We then find the "build-tag" associated with this way, and this+-- becomes the suffix used to find .hi files and libraries used in+-- this compilation.++data Way+  = WayCustom String -- for GHC API clients building custom variants+  | WayThreaded+  | WayDebug+  | WayProf+  | WayEventLog+  | WayDyn+  deriving (Eq, Ord, Show)++allowed_combination :: [Way] -> Bool+allowed_combination way = and [ x `allowedWith` y+                              | x <- way, y <- way, x < y ]+  where+        -- Note ordering in these tests: the left argument is+        -- <= the right argument, according to the Ord instance+        -- on Way above.++        -- dyn is allowed with everything+        _ `allowedWith` WayDyn                  = True+        WayDyn `allowedWith` _                  = True++        -- debug is allowed with everything+        _ `allowedWith` WayDebug                = True+        WayDebug `allowedWith` _                = True++        (WayCustom {}) `allowedWith` _          = True+        WayThreaded `allowedWith` WayProf       = True+        WayThreaded `allowedWith` WayEventLog   = True+        WayProf     `allowedWith` WayEventLog   = True+        _ `allowedWith` _                       = False++mkBuildTag :: [Way] -> String+mkBuildTag ways = concat (intersperse "_" (map wayTag ways))++wayTag :: Way -> String+wayTag (WayCustom xs) = xs+wayTag WayThreaded = "thr"+wayTag WayDebug    = "debug"+wayTag WayDyn      = "dyn"+wayTag WayProf     = "p"+wayTag WayEventLog = "l"++wayRTSOnly :: Way -> Bool+wayRTSOnly (WayCustom {}) = False+wayRTSOnly WayThreaded = True+wayRTSOnly WayDebug    = True+wayRTSOnly WayDyn      = False+wayRTSOnly WayProf     = False+wayRTSOnly WayEventLog = True++wayDesc :: Way -> String+wayDesc (WayCustom xs) = xs+wayDesc WayThreaded = "Threaded"+wayDesc WayDebug    = "Debug"+wayDesc WayDyn      = "Dynamic"+wayDesc WayProf     = "Profiling"+wayDesc WayEventLog = "RTS Event Logging"++-- Turn these flags on when enabling this way+wayGeneralFlags :: Platform -> Way -> [GeneralFlag]+wayGeneralFlags _ (WayCustom {}) = []+wayGeneralFlags _ WayThreaded = []+wayGeneralFlags _ WayDebug    = []+wayGeneralFlags _ WayDyn      = [Opt_PIC]+    -- We could get away without adding -fPIC when compiling the+    -- modules of a program that is to be linked with -dynamic; the+    -- program itself does not need to be position-independent, only+    -- the libraries need to be.  HOWEVER, GHCi links objects into a+    -- .so before loading the .so using the system linker.  Since only+    -- PIC objects can be linked into a .so, we have to compile even+    -- modules of the main program with -fPIC when using -dynamic.+wayGeneralFlags _ WayProf     = [Opt_SccProfilingOn]+wayGeneralFlags _ WayEventLog = []++-- Turn these flags off when enabling this way+wayUnsetGeneralFlags :: Platform -> Way -> [GeneralFlag]+wayUnsetGeneralFlags _ (WayCustom {}) = []+wayUnsetGeneralFlags _ WayThreaded = []+wayUnsetGeneralFlags _ WayDebug    = []+wayUnsetGeneralFlags _ WayDyn      = [-- There's no point splitting objects+                                      -- when we're going to be dynamically+                                      -- linking. Plus it breaks compilation+                                      -- on OSX x86.+                                      Opt_SplitObjs,+                                      -- If splitobjs wasn't useful for this,+                                      -- assume sections aren't either.+                                      Opt_SplitSections]+wayUnsetGeneralFlags _ WayProf     = []+wayUnsetGeneralFlags _ WayEventLog = []++wayOptc :: Platform -> Way -> [String]+wayOptc _ (WayCustom {}) = []+wayOptc platform WayThreaded = case platformOS platform of+                               OSOpenBSD -> ["-pthread"]+                               OSNetBSD  -> ["-pthread"]+                               _         -> []+wayOptc _ WayDebug      = []+wayOptc _ WayDyn        = []+wayOptc _ WayProf       = ["-DPROFILING"]+wayOptc _ WayEventLog   = ["-DTRACING"]++wayOptl :: Platform -> Way -> [String]+wayOptl _ (WayCustom {}) = []+wayOptl platform WayThreaded =+        case platformOS platform of+        -- FreeBSD's default threading library is the KSE-based M:N libpthread,+        -- which GHC has some problems with.  It's currently not clear whether+        -- the problems are our fault or theirs, but it seems that using the+        -- alternative 1:1 threading library libthr works around it:+        OSFreeBSD  -> ["-lthr"]+        OSOpenBSD  -> ["-pthread"]+        OSNetBSD   -> ["-pthread"]+        _          -> []+wayOptl _ WayDebug      = []+wayOptl _ WayDyn        = []+wayOptl _ WayProf       = []+wayOptl _ WayEventLog   = []++wayOptP :: Platform -> Way -> [String]+wayOptP _ (WayCustom {}) = []+wayOptP _ WayThreaded = []+wayOptP _ WayDebug    = []+wayOptP _ WayDyn      = []+wayOptP _ WayProf     = ["-DPROFILING"]+wayOptP _ WayEventLog = ["-DTRACING"]++whenGeneratingDynamicToo :: MonadIO m => DynFlags -> m () -> m ()+whenGeneratingDynamicToo dflags f = ifGeneratingDynamicToo dflags f (return ())++ifGeneratingDynamicToo :: MonadIO m => DynFlags -> m a -> m a -> m a+ifGeneratingDynamicToo dflags f g = generateDynamicTooConditional dflags f g g++whenCannotGenerateDynamicToo :: MonadIO m => DynFlags -> m () -> m ()+whenCannotGenerateDynamicToo dflags f+    = ifCannotGenerateDynamicToo dflags f (return ())++ifCannotGenerateDynamicToo :: MonadIO m => DynFlags -> m a -> m a -> m a+ifCannotGenerateDynamicToo dflags f g+    = generateDynamicTooConditional dflags g f g++generateDynamicTooConditional :: MonadIO m+                              => DynFlags -> m a -> m a -> m a -> m a+generateDynamicTooConditional dflags canGen cannotGen notTryingToGen+    = if gopt Opt_BuildDynamicToo dflags+      then do let ref = canGenerateDynamicToo dflags+              b <- liftIO $ readIORef ref+              if b then canGen else cannotGen+      else notTryingToGen++dynamicTooMkDynamicDynFlags :: DynFlags -> DynFlags+dynamicTooMkDynamicDynFlags dflags0+    = let dflags1 = addWay' WayDyn dflags0+          dflags2 = dflags1 {+                        outputFile = dynOutputFile dflags1,+                        hiSuf = dynHiSuf dflags1,+                        objectSuf = dynObjectSuf dflags1+                    }+          dflags3 = updateWays dflags2+          dflags4 = gopt_unset dflags3 Opt_BuildDynamicToo+      in dflags4++-----------------------------------------------------------------------------++-- | Used by 'GHC.runGhc' to partially initialize a new 'DynFlags' value+initDynFlags :: DynFlags -> IO DynFlags+initDynFlags dflags = do+ let -- We can't build with dynamic-too on Windows, as labels before+     -- the fork point are different depending on whether we are+     -- building dynamically or not.+     platformCanGenerateDynamicToo+         = platformOS (targetPlatform dflags) /= OSMinGW32+ refCanGenerateDynamicToo <- newIORef platformCanGenerateDynamicToo+ refNextTempSuffix <- newIORef 0+ refFilesToClean <- newIORef []+ refDirsToClean <- newIORef Map.empty+ refFilesToNotIntermediateClean <- newIORef []+ refGeneratedDumps <- newIORef Set.empty+ refRtldInfo <- newIORef Nothing+ refRtccInfo <- newIORef Nothing+ wrapperNum <- newIORef emptyModuleEnv+ canUseUnicode <- do let enc = localeEncoding+                         str = "‘’"+                     (withCString enc str $ \cstr ->+                          do str' <- peekCString enc cstr+                             return (str == str'))+                         `catchIOError` \_ -> return False+ canUseColor <- stderrSupportsAnsiColors+ maybeGhcColorsEnv  <- lookupEnv "GHC_COLORS"+ maybeGhcColoursEnv <- lookupEnv "GHC_COLOURS"+ let adjustCols (Just env) = Col.parseScheme env+     adjustCols Nothing    = id+ let (useColor', colScheme') =+       (adjustCols maybeGhcColoursEnv . adjustCols maybeGhcColorsEnv)+       (useColor dflags, colScheme dflags)+ return dflags{+        canGenerateDynamicToo = refCanGenerateDynamicToo,+        nextTempSuffix = refNextTempSuffix,+        filesToClean   = refFilesToClean,+        dirsToClean    = refDirsToClean,+        filesToNotIntermediateClean = refFilesToNotIntermediateClean,+        generatedDumps = refGeneratedDumps,+        nextWrapperNum = wrapperNum,+        useUnicode    = canUseUnicode,+        useColor      = useColor',+        canUseColor   = canUseColor,+        colScheme     = colScheme',+        rtldInfo      = refRtldInfo,+        rtccInfo      = refRtccInfo+        }++-- | The normal 'DynFlags'. Note that they are not suitable for use in this form+-- and must be fully initialized by 'GHC.runGhc' first.+defaultDynFlags :: Settings -> DynFlags+defaultDynFlags mySettings =+-- See Note [Updating flag description in the User's Guide]+     DynFlags {+        ghcMode                 = CompManager,+        ghcLink                 = LinkBinary,+        hscTarget               = defaultHscTarget (sTargetPlatform mySettings),+        verbosity               = 0,+        optLevel                = 0,+        debugLevel              = 0,+        simplPhases             = 2,+        maxSimplIterations      = 4,+        maxPmCheckIterations    = 2000000,+        ruleCheck               = Nothing,+        maxRelevantBinds        = Just 6,+        maxUncoveredPatterns    = 4,+        simplTickFactor         = 100,+        specConstrThreshold     = Just 2000,+        specConstrCount         = Just 3,+        specConstrRecursive     = 3,+        liberateCaseThreshold   = Just 2000,+        floatLamArgs            = Just 0, -- Default: float only if no fvs++        historySize             = 20,+        strictnessBefore        = [],++        parMakeCount            = Just 1,++        enableTimeStats         = False,+        ghcHeapSize             = Nothing,++        importPaths             = ["."],+        mainModIs               = mAIN,+        mainFunIs               = Nothing,+        reductionDepth          = treatZeroAsInf mAX_REDUCTION_DEPTH,+        solverIterations        = treatZeroAsInf mAX_SOLVER_ITERATIONS,++        thisInstalledUnitId     = toInstalledUnitId mainUnitId,+        thisUnitIdInsts_        = Nothing,+        thisComponentId_        = Nothing,++        objectDir               = Nothing,+        dylibInstallName        = Nothing,+        hiDir                   = Nothing,+        stubDir                 = Nothing,+        dumpDir                 = Nothing,++        objectSuf               = phaseInputExt StopLn,+        hcSuf                   = phaseInputExt HCc,+        hiSuf                   = "hi",++        canGenerateDynamicToo   = panic "defaultDynFlags: No canGenerateDynamicToo",+        dynObjectSuf            = "dyn_" ++ phaseInputExt StopLn,+        dynHiSuf                = "dyn_hi",++        dllSplitFile            = Nothing,+        dllSplit                = Nothing,++        pluginModNames          = [],+        pluginModNameOpts       = [],+        frontendPluginOpts      = [],+        hooks                   = emptyHooks,++        outputFile              = Nothing,+        dynOutputFile           = Nothing,+        outputHi                = Nothing,+        dynLibLoader            = SystemDependent,+        dumpPrefix              = Nothing,+        dumpPrefixForce         = Nothing,+        ldInputs                = [],+        includePaths            = [],+        libraryPaths            = [],+        frameworkPaths          = [],+        cmdlineFrameworks       = [],+        rtsOpts                 = Nothing,+        rtsOptsEnabled          = RtsOptsSafeOnly,+        rtsOptsSuggestions      = True,++        hpcDir                  = ".hpc",++        packageDBFlags          = [],+        packageFlags            = [],+        pluginPackageFlags      = [],+        ignorePackageFlags      = [],+        trustFlags              = [],+        packageEnv              = Nothing,+        pkgDatabase             = Nothing,+        -- This gets filled in with GHC.setSessionDynFlags+        pkgState                = emptyPackageState,+        ways                    = defaultWays mySettings,+        buildTag                = mkBuildTag (defaultWays mySettings),+        rtsBuildTag             = mkBuildTag (defaultWays mySettings),+        splitInfo               = Nothing,+        settings                = mySettings,+        -- ghc -M values+        depMakefile       = "Makefile",+        depIncludePkgDeps = False,+        depExcludeMods    = [],+        depSuffixes       = [],+        -- end of ghc -M values+        nextTempSuffix = panic "defaultDynFlags: No nextTempSuffix",+        filesToClean   = panic "defaultDynFlags: No filesToClean",+        dirsToClean    = panic "defaultDynFlags: No dirsToClean",+        filesToNotIntermediateClean = panic "defaultDynFlags: No filesToNotIntermediateClean",+        generatedDumps = panic "defaultDynFlags: No generatedDumps",+        haddockOptions = Nothing,+        dumpFlags = IntSet.empty,+        generalFlags = IntSet.fromList (map fromEnum (defaultFlags mySettings)),+        warningFlags = IntSet.fromList (map fromEnum standardWarnings),+        fatalWarningFlags = IntSet.empty,+        ghciScripts = [],+        language = Nothing,+        safeHaskell = Sf_None,+        safeInfer   = True,+        safeInferred = True,+        thOnLoc = noSrcSpan,+        newDerivOnLoc = noSrcSpan,+        overlapInstLoc = noSrcSpan,+        incoherentOnLoc = noSrcSpan,+        pkgTrustOnLoc = noSrcSpan,+        warnSafeOnLoc = noSrcSpan,+        warnUnsafeOnLoc = noSrcSpan,+        trustworthyOnLoc = noSrcSpan,+        extensions = [],+        extensionFlags = flattenExtensionFlags Nothing [],++        -- The ufCreationThreshold threshold must be reasonably high to+        -- take account of possible discounts.+        -- E.g. 450 is not enough in 'fulsom' for Interval.sqr to inline+        -- into Csg.calc (The unfolding for sqr never makes it into the+        -- interface file.)+        ufCreationThreshold = 750,+        ufUseThreshold      = 60,+        ufFunAppDiscount    = 60,+        -- Be fairly keen to inline a function if that means+        -- we'll be able to pick the right method from a dictionary+        ufDictDiscount      = 30,+        ufKeenessFactor     = 1.5,+        ufDearOp            = 40,+        ufVeryAggressive    = False,++        maxWorkerArgs = 10,++        ghciHistSize = 50, -- keep a log of length 50 by default++        -- Logging++        initLogAction = defaultLogOutput,++        log_action = defaultLogAction,+        log_finaliser = \ _ -> return (),++        flushOut = defaultFlushOut,+        flushErr = defaultFlushErr,+        pprUserLength = 5,+        pprCols = 100,+        useUnicode = False,+        useColor = Auto,+        canUseColor = False,+        colScheme = Col.defaultScheme,+        profAuto = NoProfAuto,+        interactivePrint = Nothing,+        nextWrapperNum = panic "defaultDynFlags: No nextWrapperNum",+        sseVersion = Nothing,+        avx = False,+        avx2 = False,+        avx512cd = False,+        avx512er = False,+        avx512f = False,+        avx512pf = False,+        rtldInfo = panic "defaultDynFlags: no rtldInfo",+        rtccInfo = panic "defaultDynFlags: no rtccInfo",++        maxInlineAllocSize = 128,+        maxInlineMemcpyInsns = 32,+        maxInlineMemsetInsns = 32,++        initialUnique = 0,+        uniqueIncrement = 1,++        reverseErrors = False,+        maxErrors     = Nothing+      }++defaultWays :: Settings -> [Way]+defaultWays settings = if pc_DYNAMIC_BY_DEFAULT (sPlatformConstants settings)+                       then [WayDyn]+                       else []++interpWays :: [Way]+interpWays+  | dynamicGhc = [WayDyn]+  | rtsIsProfiled = [WayProf]+  | otherwise = []++interpreterProfiled :: DynFlags -> Bool+interpreterProfiled dflags+  | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags+  | otherwise = rtsIsProfiled++interpreterDynamic :: DynFlags -> Bool+interpreterDynamic dflags+  | gopt Opt_ExternalInterpreter dflags = WayDyn `elem` ways dflags+  | otherwise = dynamicGhc++--------------------------------------------------------------------------+--+-- Note [JSON Error Messages]+--+-- When the user requests the compiler output to be dumped as json+-- we modify the log_action to collect all the messages in an IORef+-- and then finally in GHC.withCleanupSession the log_finaliser is+-- called which prints out the messages together.+--+-- Before the compiler calls log_action, it has already turned the `ErrMsg`+-- into a formatted message. This means that we lose some possible+-- information to provide to the user but refactoring log_action is quite+-- invasive as it is called in many places. So, for now I left it alone+-- and we can refine its behaviour as users request different output.++type FatalMessager = String -> IO ()++data LogOutput = LogOutput+               { getLogAction :: LogAction+               , getLogFinaliser :: LogFinaliser+               }++defaultLogOutput :: IO (Maybe LogOutput)+defaultLogOutput = return $ Nothing++type LogAction = DynFlags+              -> WarnReason+              -> Severity+              -> SrcSpan+              -> PprStyle+              -> MsgDoc+              -> IO ()++type LogFinaliser = DynFlags -> IO ()++defaultFatalMessager :: FatalMessager+defaultFatalMessager = hPutStrLn stderr+++-- See Note [JSON Error Messages]+jsonLogOutput :: IO (Maybe LogOutput)+jsonLogOutput = do+  ref <- newIORef []+  return . Just $ LogOutput (jsonLogAction ref) (jsonLogFinaliser ref)++jsonLogAction :: IORef [SDoc] -> LogAction+jsonLogAction iref dflags reason severity srcSpan style msg+  = do+      addMessage . withPprStyle (mkCodeStyle CStyle) . renderJSON $+        JSObject [ ( "span", json srcSpan )+                 , ( "doc" , JSString (showSDoc dflags msg) )+                 , ( "severity", json severity )+                 , ( "reason" ,   json reason )+                ]+      defaultLogAction dflags reason severity srcSpan style msg+  where+    addMessage m = modifyIORef iref (m:)+++jsonLogFinaliser :: IORef [SDoc] -> DynFlags -> IO ()+jsonLogFinaliser iref dflags = do+  msgs <- readIORef iref+  let fmt_msgs = brackets $ pprWithCommas (blankLine $$) msgs+  output fmt_msgs+  where+    -- dumpSDoc uses log_action to output the dump+    dflags' = dflags { log_action = defaultLogAction }+    output doc = dumpSDoc dflags' neverQualify Opt_D_dump_json "" doc+++defaultLogAction :: LogAction+defaultLogAction dflags reason severity srcSpan style msg+    = case severity of+      SevOutput      -> printOut msg style+      SevDump        -> printOut (msg $$ blankLine) style+      SevInteractive -> putStrSDoc msg style+      SevInfo        -> printErrs msg style+      SevFatal       -> printErrs msg style+      _              -> do -- otherwise (i.e. SevError or SevWarning)+                           hPutChar stderr '\n'+                           caretDiagnostic <-+                               if gopt Opt_DiagnosticsShowCaret dflags+                               then getCaretDiagnostic severity srcSpan+                               else pure empty+                           printErrs (message $+$ caretDiagnostic)+                               (setStyleColoured True style)+                           -- careful (#2302): printErrs prints in UTF-8,+                           -- whereas converting to string first and using+                           -- hPutStr would just emit the low 8 bits of+                           -- each unicode char.+    where printOut   = defaultLogActionHPrintDoc  dflags stdout+          printErrs  = defaultLogActionHPrintDoc  dflags stderr+          putStrSDoc = defaultLogActionHPutStrDoc dflags stdout+          -- Pretty print the warning flag, if any (#10752)+          message = mkLocMessageAnn flagMsg severity srcSpan msg+          flagMsg = case reason of+                        NoReason -> Nothing+                        Reason flag -> (\spec -> "-W" ++ flagSpecName spec ++ flagGrp flag) <$>+                                          flagSpecOf flag++          flagGrp flag+              | gopt Opt_ShowWarnGroups dflags =+                    case smallestGroups flag of+                        [] -> ""+                        groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")"+              | otherwise = ""++-- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline.+defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO ()+defaultLogActionHPrintDoc dflags h d sty+ = defaultLogActionHPutStrDoc dflags h (d $$ text "") sty++defaultLogActionHPutStrDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO ()+defaultLogActionHPutStrDoc dflags h d sty+  -- Don't add a newline at the end, so that successive+  -- calls to this log-action can output all on the same line+  = printSDoc Pretty.PageMode dflags h sty d++newtype FlushOut = FlushOut (IO ())++defaultFlushOut :: FlushOut+defaultFlushOut = FlushOut $ hFlush stdout++newtype FlushErr = FlushErr (IO ())++defaultFlushErr :: FlushErr+defaultFlushErr = FlushErr $ hFlush stderr++{-+Note [Verbosity levels]+~~~~~~~~~~~~~~~~~~~~~~~+    0   |   print errors & warnings only+    1   |   minimal verbosity: print "compiling M ... done." for each module.+    2   |   equivalent to -dshow-passes+    3   |   equivalent to existing "ghc -v"+    4   |   "ghc -v -ddump-most"+    5   |   "ghc -v -ddump-all"+-}++data OnOff a = On a+             | Off a+  deriving (Eq, Show)++instance Outputable a => Outputable (OnOff a) where+  ppr (On x)  = text "On" <+> ppr x+  ppr (Off x) = text "Off" <+> ppr x++-- OnOffs accumulate in reverse order, so we use foldr in order to+-- process them in the right order+flattenExtensionFlags :: Maybe Language -> [OnOff LangExt.Extension] -> IntSet+flattenExtensionFlags ml = foldr f defaultExtensionFlags+    where f (On f)  flags = IntSet.insert (fromEnum f) flags+          f (Off f) flags = IntSet.delete (fromEnum f) flags+          defaultExtensionFlags = IntSet.fromList (map fromEnum (languageExtensions ml))++languageExtensions :: Maybe Language -> [LangExt.Extension]++languageExtensions Nothing+    -- Nothing => the default case+    = LangExt.NondecreasingIndentation -- This has been on by default for some time+    : delete LangExt.DatatypeContexts  -- The Haskell' committee decided to+                                       -- remove datatype contexts from the+                                       -- language:+   -- http://www.haskell.org/pipermail/haskell-prime/2011-January/003335.html+      (languageExtensions (Just Haskell2010))++   -- NB: MonoPatBinds is no longer the default++languageExtensions (Just Haskell98)+    = [LangExt.ImplicitPrelude,+       LangExt.MonomorphismRestriction,+       LangExt.NPlusKPatterns,+       LangExt.DatatypeContexts,+       LangExt.TraditionalRecordSyntax,+       LangExt.NondecreasingIndentation+           -- strictly speaking non-standard, but we always had this+           -- on implicitly before the option was added in 7.1, and+           -- turning it off breaks code, so we're keeping it on for+           -- backwards compatibility.  Cabal uses -XHaskell98 by+           -- default unless you specify another language.+      ]++languageExtensions (Just Haskell2010)+    = [LangExt.ImplicitPrelude,+       LangExt.MonomorphismRestriction,+       LangExt.DatatypeContexts,+       LangExt.TraditionalRecordSyntax,+       LangExt.EmptyDataDecls,+       LangExt.ForeignFunctionInterface,+       LangExt.PatternGuards,+       LangExt.DoAndIfThenElse,+       LangExt.RelaxedPolyRec]++hasPprDebug :: DynFlags -> Bool+hasPprDebug = dopt Opt_D_ppr_debug++hasNoDebugOutput :: DynFlags -> Bool+hasNoDebugOutput = dopt Opt_D_no_debug_output++hasNoStateHack :: DynFlags -> Bool+hasNoStateHack = gopt Opt_G_NoStateHack++hasNoOptCoercion :: DynFlags -> Bool+hasNoOptCoercion = gopt Opt_G_NoOptCoercion+++-- | Test whether a 'DumpFlag' is set+dopt :: DumpFlag -> DynFlags -> Bool+dopt f dflags = (fromEnum f `IntSet.member` dumpFlags dflags)+             || (verbosity dflags >= 4 && enableIfVerbose f)+    where enableIfVerbose Opt_D_dump_tc_trace               = False+          enableIfVerbose Opt_D_dump_rn_trace               = False+          enableIfVerbose Opt_D_dump_cs_trace               = False+          enableIfVerbose Opt_D_dump_if_trace               = False+          enableIfVerbose Opt_D_dump_vt_trace               = False+          enableIfVerbose Opt_D_dump_tc                     = False+          enableIfVerbose Opt_D_dump_rn                     = False+          enableIfVerbose Opt_D_dump_shape                  = False+          enableIfVerbose Opt_D_dump_rn_stats               = False+          enableIfVerbose Opt_D_dump_hi_diffs               = False+          enableIfVerbose Opt_D_verbose_core2core           = False+          enableIfVerbose Opt_D_verbose_stg2stg             = False+          enableIfVerbose Opt_D_dump_splices                = False+          enableIfVerbose Opt_D_th_dec_file                 = False+          enableIfVerbose Opt_D_dump_rule_firings           = False+          enableIfVerbose Opt_D_dump_rule_rewrites          = False+          enableIfVerbose Opt_D_dump_simpl_trace            = False+          enableIfVerbose Opt_D_dump_rtti                   = False+          enableIfVerbose Opt_D_dump_inlinings              = False+          enableIfVerbose Opt_D_dump_core_stats             = False+          enableIfVerbose Opt_D_dump_asm_stats              = False+          enableIfVerbose Opt_D_dump_types                  = False+          enableIfVerbose Opt_D_dump_simpl_iterations       = False+          enableIfVerbose Opt_D_dump_ticked                 = False+          enableIfVerbose Opt_D_dump_view_pattern_commoning = False+          enableIfVerbose Opt_D_dump_mod_cycles             = False+          enableIfVerbose Opt_D_dump_mod_map                = False+          enableIfVerbose Opt_D_dump_ec_trace               = False+          enableIfVerbose _                                 = True++-- | Set a 'DumpFlag'+dopt_set :: DynFlags -> DumpFlag -> DynFlags+dopt_set dfs f = dfs{ dumpFlags = IntSet.insert (fromEnum f) (dumpFlags dfs) }++-- | Unset a 'DumpFlag'+dopt_unset :: DynFlags -> DumpFlag -> DynFlags+dopt_unset dfs f = dfs{ dumpFlags = IntSet.delete (fromEnum f) (dumpFlags dfs) }++-- | Test whether a 'GeneralFlag' is set+gopt :: GeneralFlag -> DynFlags -> Bool+gopt f dflags  = fromEnum f `IntSet.member` generalFlags dflags++-- | Set a 'GeneralFlag'+gopt_set :: DynFlags -> GeneralFlag -> DynFlags+gopt_set dfs f = dfs{ generalFlags = IntSet.insert (fromEnum f) (generalFlags dfs) }++-- | Unset a 'GeneralFlag'+gopt_unset :: DynFlags -> GeneralFlag -> DynFlags+gopt_unset dfs f = dfs{ generalFlags = IntSet.delete (fromEnum f) (generalFlags dfs) }++-- | Test whether a 'WarningFlag' is set+wopt :: WarningFlag -> DynFlags -> Bool+wopt f dflags  = fromEnum f `IntSet.member` warningFlags dflags++-- | Set a 'WarningFlag'+wopt_set :: DynFlags -> WarningFlag -> DynFlags+wopt_set dfs f = dfs{ warningFlags = IntSet.insert (fromEnum f) (warningFlags dfs) }++-- | Unset a 'WarningFlag'+wopt_unset :: DynFlags -> WarningFlag -> DynFlags+wopt_unset dfs f = dfs{ warningFlags = IntSet.delete (fromEnum f) (warningFlags dfs) }++-- | Test whether a 'WarningFlag' is set as fatal+wopt_fatal :: WarningFlag -> DynFlags -> Bool+wopt_fatal f dflags = fromEnum f `IntSet.member` fatalWarningFlags dflags++-- | Mark a 'WarningFlag' as fatal (do not set the flag)+wopt_set_fatal :: DynFlags -> WarningFlag -> DynFlags+wopt_set_fatal dfs f+    = dfs { fatalWarningFlags =+              IntSet.insert (fromEnum f) (fatalWarningFlags dfs) }++-- | Mark a 'WarningFlag' as not fatal+wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags+wopt_unset_fatal dfs f+    = dfs { fatalWarningFlags =+              IntSet.delete (fromEnum f) (fatalWarningFlags dfs) }++-- | Test whether a 'LangExt.Extension' is set+xopt :: LangExt.Extension -> DynFlags -> Bool+xopt f dflags = fromEnum f `IntSet.member` extensionFlags dflags++-- | Set a 'LangExt.Extension'+xopt_set :: DynFlags -> LangExt.Extension -> DynFlags+xopt_set dfs f+    = let onoffs = On f : extensions dfs+      in dfs { extensions = onoffs,+               extensionFlags = flattenExtensionFlags (language dfs) onoffs }++-- | Unset a 'LangExt.Extension'+xopt_unset :: DynFlags -> LangExt.Extension -> DynFlags+xopt_unset dfs f+    = let onoffs = Off f : extensions dfs+      in dfs { extensions = onoffs,+               extensionFlags = flattenExtensionFlags (language dfs) onoffs }++lang_set :: DynFlags -> Maybe Language -> DynFlags+lang_set dflags lang =+   dflags {+            language = lang,+            extensionFlags = flattenExtensionFlags lang (extensions dflags)+          }++-- | An internal helper to check whether to use unicode syntax for output.+--+-- Note: You should very likely be using 'Outputable.unicodeSyntax' instead+-- of this function.+useUnicodeSyntax :: DynFlags -> Bool+useUnicodeSyntax = gopt Opt_PrintUnicodeSyntax++-- | Set the Haskell language standard to use+setLanguage :: Language -> DynP ()+setLanguage l = upd (`lang_set` Just l)++-- | Some modules have dependencies on others through the DynFlags rather than textual imports+dynFlagDependencies :: DynFlags -> [ModuleName]+dynFlagDependencies = pluginModNames++-- | Is the -fpackage-trust mode on+packageTrustOn :: DynFlags -> Bool+packageTrustOn = gopt Opt_PackageTrust++-- | Is Safe Haskell on in some way (including inference mode)+safeHaskellOn :: DynFlags -> Bool+safeHaskellOn dflags = safeHaskell dflags /= Sf_None || safeInferOn dflags++-- | Is the Safe Haskell safe language in use+safeLanguageOn :: DynFlags -> Bool+safeLanguageOn dflags = safeHaskell dflags == Sf_Safe++-- | Is the Safe Haskell safe inference mode active+safeInferOn :: DynFlags -> Bool+safeInferOn = safeInfer++-- | Test if Safe Imports are on in some form+safeImportsOn :: DynFlags -> Bool+safeImportsOn dflags = safeHaskell dflags == Sf_Unsafe ||+                       safeHaskell dflags == Sf_Trustworthy ||+                       safeHaskell dflags == Sf_Safe++-- | Set a 'Safe Haskell' flag+setSafeHaskell :: SafeHaskellMode -> DynP ()+setSafeHaskell s = updM f+    where f dfs = do+              let sf = safeHaskell dfs+              safeM <- combineSafeFlags sf s+              case s of+                Sf_Safe -> return $ dfs { safeHaskell = safeM, safeInfer = False }+                -- leave safe inferrence on in Trustworthy mode so we can warn+                -- if it could have been inferred safe.+                Sf_Trustworthy -> do+                  l <- getCurLoc+                  return $ dfs { safeHaskell = safeM, trustworthyOnLoc = l }+                -- leave safe inference on in Unsafe mode as well.+                _ -> return $ dfs { safeHaskell = safeM }++-- | Are all direct imports required to be safe for this Safe Haskell mode?+-- Direct imports are when the code explicitly imports a module+safeDirectImpsReq :: DynFlags -> Bool+safeDirectImpsReq d = safeLanguageOn d++-- | Are all implicit imports required to be safe for this Safe Haskell mode?+-- Implicit imports are things in the prelude. e.g System.IO when print is used.+safeImplicitImpsReq :: DynFlags -> Bool+safeImplicitImpsReq d = safeLanguageOn d++-- | Combine two Safe Haskell modes correctly. Used for dealing with multiple flags.+-- This makes Safe Haskell very much a monoid but for now I prefer this as I don't+-- want to export this functionality from the module but do want to export the+-- type constructors.+combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode+combineSafeFlags a b | a == Sf_None         = return b+                     | b == Sf_None         = return a+                     | a == b               = return a+                     | otherwise            = addErr errm >> pure a+    where errm = "Incompatible Safe Haskell flags! ("+                    ++ show a ++ ", " ++ show b ++ ")"++-- | A list of unsafe flags under Safe Haskell. Tuple elements are:+--     * name of the flag+--     * function to get srcspan that enabled the flag+--     * function to test if the flag is on+--     * function to turn the flag off+unsafeFlags, unsafeFlagsForInfer+  :: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)]+unsafeFlags = [ ("-XGeneralizedNewtypeDeriving", newDerivOnLoc,+                    xopt LangExt.GeneralizedNewtypeDeriving,+                    flip xopt_unset LangExt.GeneralizedNewtypeDeriving)+              , ("-XTemplateHaskell", thOnLoc,+                    xopt LangExt.TemplateHaskell,+                    flip xopt_unset LangExt.TemplateHaskell)+              ]+unsafeFlagsForInfer = unsafeFlags+++-- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order+getOpts :: DynFlags             -- ^ 'DynFlags' to retrieve the options from+        -> (DynFlags -> [a])    -- ^ Relevant record accessor: one of the @opt_*@ accessors+        -> [a]                  -- ^ Correctly ordered extracted options+getOpts dflags opts = reverse (opts dflags)+        -- We add to the options from the front, so we need to reverse the list++-- | Gets the verbosity flag for the current verbosity level. This is fed to+-- other tools, so GHC-specific verbosity flags like @-ddump-most@ are not included+getVerbFlags :: DynFlags -> [String]+getVerbFlags dflags+  | verbosity dflags >= 4 = ["-v"]+  | otherwise             = []++setObjectDir, setHiDir, setStubDir, setDumpDir, setOutputDir,+         setDynObjectSuf, setDynHiSuf,+         setDylibInstallName,+         setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode,+         setPgmP, addOptl, addOptc, addOptP,+         addCmdlineFramework, addHaddockOpts, addGhciScript,+         setInteractivePrint+   :: String -> DynFlags -> DynFlags+setOutputFile, setDynOutputFile, setOutputHi, setDumpPrefixForce+   :: Maybe String -> DynFlags -> DynFlags++setObjectDir  f d = d { objectDir  = Just f}+setHiDir      f d = d { hiDir      = Just f}+setStubDir    f d = d { stubDir    = Just f, includePaths = f : includePaths d }+  -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file+  -- \#included from the .hc file when compiling via C (i.e. unregisterised+  -- builds).+setDumpDir    f d = d { dumpDir    = Just f}+setOutputDir  f = setObjectDir f . setHiDir f . setStubDir f . setDumpDir f+setDylibInstallName  f d = d { dylibInstallName = Just f}++setObjectSuf    f d = d { objectSuf    = f}+setDynObjectSuf f d = d { dynObjectSuf = f}+setHiSuf        f d = d { hiSuf        = f}+setDynHiSuf     f d = d { dynHiSuf     = f}+setHcSuf        f d = d { hcSuf        = f}++setOutputFile f d = d { outputFile = f}+setDynOutputFile f d = d { dynOutputFile = f}+setOutputHi   f d = d { outputHi   = f}++setJsonLogAction :: DynFlags -> DynFlags+setJsonLogAction d = d { initLogAction = jsonLogOutput }++thisComponentId :: DynFlags -> ComponentId+thisComponentId dflags =+  case thisComponentId_ dflags of+    Just cid -> cid+    Nothing  ->+      case thisUnitIdInsts_ dflags of+        Just _  ->+          throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id")+        Nothing -> ComponentId (unitIdFS (thisPackage dflags))++thisUnitIdInsts :: DynFlags -> [(ModuleName, Module)]+thisUnitIdInsts dflags =+    case thisUnitIdInsts_ dflags of+        Just insts -> insts+        Nothing    -> []++thisPackage :: DynFlags -> UnitId+thisPackage dflags =+    case thisUnitIdInsts_ dflags of+        Nothing -> default_uid+        Just insts+          | all (\(x,y) -> mkHoleModule x == y) insts+          -> newUnitId (thisComponentId dflags) insts+          | otherwise+          -> default_uid+  where+    default_uid = DefiniteUnitId (DefUnitId (thisInstalledUnitId dflags))++parseUnitIdInsts :: String -> [(ModuleName, Module)]+parseUnitIdInsts str = case filter ((=="").snd) (readP_to_S parse str) of+    [(r, "")] -> r+    _ -> throwGhcException $ CmdLineError ("Can't parse -instantiated-with: " ++ str)+  where parse = sepBy parseEntry (R.char ',')+        parseEntry = do+            n <- parseModuleName+            _ <- R.char '='+            m <- parseModuleId+            return (n, m)++setUnitIdInsts :: String -> DynFlags -> DynFlags+setUnitIdInsts s d =+    d { thisUnitIdInsts_ = Just (parseUnitIdInsts s) }++setComponentId :: String -> DynFlags -> DynFlags+setComponentId s d =+    d { thisComponentId_ = Just (ComponentId (fsLit s)) }++addPluginModuleName :: String -> DynFlags -> DynFlags+addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) }++addPluginModuleNameOption :: String -> DynFlags -> DynFlags+addPluginModuleNameOption optflag d = d { pluginModNameOpts = (mkModuleName m, option) : (pluginModNameOpts d) }+  where (m, rest) = break (== ':') optflag+        option = case rest of+          [] -> "" -- should probably signal an error+          (_:plug_opt) -> plug_opt -- ignore the ':' from break++addFrontendPluginOption :: String -> DynFlags -> DynFlags+addFrontendPluginOption s d = d { frontendPluginOpts = s : frontendPluginOpts d }++parseDynLibLoaderMode f d =+ case splitAt 8 f of+   ("deploy", "")       -> d { dynLibLoader = Deployable }+   ("sysdep", "")       -> d { dynLibLoader = SystemDependent }+   _                    -> throwGhcException (CmdLineError ("Unknown dynlib loader: " ++ f))++setDumpPrefixForce f d = d { dumpPrefixForce = f}++-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"]+-- Config.hs should really use Option.+setPgmP   f = let (pgm:args) = words f in alterSettings (\s -> s { sPgm_P   = (pgm, map Option args)})+addOptl   f = alterSettings (\s -> s { sOpt_l   = f : sOpt_l s})+addOptc   f = alterSettings (\s -> s { sOpt_c   = f : sOpt_c s})+addOptP   f = alterSettings (\s -> s { sOpt_P   = f : sOpt_P s})+++setDepMakefile :: FilePath -> DynFlags -> DynFlags+setDepMakefile f d = d { depMakefile = f }++setDepIncludePkgDeps :: Bool -> DynFlags -> DynFlags+setDepIncludePkgDeps b d = d { depIncludePkgDeps = b }++addDepExcludeMod :: String -> DynFlags -> DynFlags+addDepExcludeMod m d+    = d { depExcludeMods = mkModuleName m : depExcludeMods d }++addDepSuffix :: FilePath -> DynFlags -> DynFlags+addDepSuffix s d = d { depSuffixes = s : depSuffixes d }++addCmdlineFramework f d = d { cmdlineFrameworks = f : cmdlineFrameworks d}++addHaddockOpts f d = d { haddockOptions = Just f}++addGhciScript f d = d { ghciScripts = f : ghciScripts d}++setInteractivePrint f d = d { interactivePrint = Just f}++-- -----------------------------------------------------------------------------+-- Command-line options++-- | When invoking external tools as part of the compilation pipeline, we+-- pass these a sequence of options on the command-line. Rather than+-- just using a list of Strings, we use a type that allows us to distinguish+-- between filepaths and 'other stuff'. The reason for this is that+-- this type gives us a handle on transforming filenames, and filenames only,+-- to whatever format they're expected to be on a particular platform.+data Option+ = FileOption -- an entry that _contains_ filename(s) / filepaths.+              String  -- a non-filepath prefix that shouldn't be+                      -- transformed (e.g., "/out=")+              String  -- the filepath/filename portion+ | Option     String+ deriving ( Eq )++showOpt :: Option -> String+showOpt (FileOption pre f) = pre ++ f+showOpt (Option s)  = s++-----------------------------------------------------------------------------+-- Setting the optimisation level++updOptLevel :: Int -> DynFlags -> DynFlags+-- ^ Sets the 'DynFlags' to be appropriate to the optimisation level+updOptLevel n dfs+  = dfs2{ optLevel = final_n }+  where+   final_n = max 0 (min 2 n)    -- Clamp to 0 <= n <= 2+   dfs1 = foldr (flip gopt_unset) dfs  remove_gopts+   dfs2 = foldr (flip gopt_set)   dfs1 extra_gopts++   extra_gopts  = [ f | (ns,f) <- optLevelFlags, final_n `elem` ns ]+   remove_gopts = [ f | (ns,f) <- optLevelFlags, final_n `notElem` ns ]++{- **********************************************************************+%*                                                                      *+                DynFlags parser+%*                                                                      *+%********************************************************************* -}++-- -----------------------------------------------------------------------------+-- Parsing the dynamic flags.+++-- | Parse dynamic flags from a list of command line arguments.  Returns the+-- the parsed 'DynFlags', the left-over arguments, and a list of warnings.+-- Throws a 'UsageError' if errors occurred during parsing (such as unknown+-- flags or missing arguments).+parseDynamicFlagsCmdLine :: MonadIO m => DynFlags -> [Located String]+                         -> m (DynFlags, [Located String], [Located String])+                            -- ^ Updated 'DynFlags', left-over arguments, and+                            -- list of warnings.+parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True+++-- | Like 'parseDynamicFlagsCmdLine' but does not allow the package flags+-- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-db).+-- Used to parse flags set in a modules pragma.+parseDynamicFilePragma :: MonadIO m => DynFlags -> [Located String]+                       -> m (DynFlags, [Located String], [Located String])+                          -- ^ Updated 'DynFlags', left-over arguments, and+                          -- list of warnings.+parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False+++-- | Parses the dynamically set flags for GHC. This is the most general form of+-- the dynamic flag parser that the other methods simply wrap. It allows+-- saying which flags are valid flags and indicating if we are parsing+-- arguments from the command line or from a file pragma.+parseDynamicFlagsFull :: MonadIO m+                  => [Flag (CmdLineP DynFlags)]    -- ^ valid flags to match against+                  -> Bool                          -- ^ are the arguments from the command line?+                  -> DynFlags                      -- ^ current dynamic flags+                  -> [Located String]              -- ^ arguments to parse+                  -> m (DynFlags, [Located String], [Located String])+parseDynamicFlagsFull activeFlags cmdline dflags0 args = do+  let ((leftover, errs, warns), dflags1)+          = runCmdLine (processArgs activeFlags args) dflags0++  -- See Note [Handling errors when parsing commandline flags]+  unless (null errs) $ liftIO $ throwGhcExceptionIO $+      errorsToGhcException . map (showPpr dflags0 . getLoc &&& unLoc) $ errs++  -- check for disabled flags in safe haskell+  let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1+      dflags3 = updateWays dflags2+      theWays = ways dflags3++  unless (allowed_combination theWays) $ liftIO $+      throwGhcExceptionIO (CmdLineError ("combination not supported: " +++                               intercalate "/" (map wayDesc theWays)))++  let chooseOutput+        | isJust (outputFile dflags3)          -- Only iff user specified -o ...+        , not (isJust (dynOutputFile dflags3)) -- but not -dyno+        = return $ dflags3 { dynOutputFile = Just $ dynOut (fromJust $ outputFile dflags3) }+        | otherwise+        = return dflags3+        where+          dynOut = flip addExtension (dynObjectSuf dflags3) . dropExtension+  dflags4 <- ifGeneratingDynamicToo dflags3 chooseOutput (return dflags3)++  let (dflags5, consistency_warnings) = makeDynFlagsConsistent dflags4++  dflags6 <- case dllSplitFile dflags5 of+             Nothing -> return (dflags5 { dllSplit = Nothing })+             Just f ->+                 case dllSplit dflags5 of+                 Just _ ->+                     -- If dllSplit is out of date then it would have+                     -- been set to Nothing. As it's a Just, it must be+                     -- up-to-date.+                     return dflags5+                 Nothing ->+                     do xs <- liftIO $ readFile f+                        let ss = map (Set.fromList . words) (lines xs)+                        return $ dflags5 { dllSplit = Just ss }++  -- Set timer stats & heap size+  when (enableTimeStats dflags6) $ liftIO enableTimingStats+  case (ghcHeapSize dflags6) of+    Just x -> liftIO (setHeapSize x)+    _      -> return ()++  dflags7 <- liftIO $ setLogAction dflags6++  liftIO $ setUnsafeGlobalDynFlags dflags7++  return (dflags7, leftover, consistency_warnings ++ sh_warns ++ warns)++setLogAction :: DynFlags -> IO DynFlags+setLogAction dflags = do+ mlogger <- initLogAction dflags+ return $+    maybe+         dflags+         (\logger ->+            dflags+              { log_action    = getLogAction logger+              , log_finaliser = getLogFinaliser logger+              , initLogAction = return $ Nothing -- Don't initialise it twice+              })+         mlogger++-- | Write an error or warning to the 'LogOutput'.+putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle+          -> MsgDoc -> IO ()+putLogMsg dflags = log_action dflags dflags++updateWays :: DynFlags -> DynFlags+updateWays dflags+    = let theWays = sort $ nub $ ways dflags+      in dflags {+             ways        = theWays,+             buildTag    = mkBuildTag (filter (not . wayRTSOnly) theWays),+             rtsBuildTag = mkBuildTag                            theWays+         }++-- | Check (and potentially disable) any extensions that aren't allowed+-- in safe mode.+--+-- The bool is to indicate if we are parsing command line flags (false means+-- file pragma). This allows us to generate better warnings.+safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String])+safeFlagCheck _ dflags | safeLanguageOn dflags = (dflagsUnset, warns)+  where+    -- Handle illegal flags under safe language.+    (dflagsUnset, warns) = foldl check_method (dflags, []) unsafeFlags++    check_method (df, warns) (str,loc,test,fix)+        | test df   = (fix df, warns ++ safeFailure (loc df) str)+        | otherwise = (df, warns)++    safeFailure loc str+       = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring "+           ++ str]++safeFlagCheck cmdl dflags =+  case (safeInferOn dflags) of+    True | safeFlags -> (dflags', warn)+    True             -> (dflags' { safeInferred = False }, warn)+    False            -> (dflags', warn)++  where+    -- dynflags and warn for when -fpackage-trust by itself with no safe+    -- haskell flag+    (dflags', warn)+      | safeHaskell dflags == Sf_None && not cmdl && packageTrustOn dflags+      = (gopt_unset dflags Opt_PackageTrust, pkgWarnMsg)+      | otherwise = (dflags, [])++    pkgWarnMsg = [L (pkgTrustOnLoc dflags') $+                    "-fpackage-trust ignored;" +++                    " must be specified with a Safe Haskell flag"]++    -- Have we inferred Unsafe? See Note [HscMain . Safe Haskell Inference]+    safeFlags = all (\(_,_,t,_) -> not $ t dflags) unsafeFlagsForInfer+++{- **********************************************************************+%*                                                                      *+                DynFlags specifications+%*                                                                      *+%********************************************************************* -}++-- | All dynamic flags option strings without the deprecated ones.+-- These are the user facing strings for enabling and disabling options.+allNonDeprecatedFlags :: [String]+allNonDeprecatedFlags = allFlagsDeps False++-- | All flags with possibility to filter deprecated ones+allFlagsDeps :: Bool -> [String]+allFlagsDeps keepDeprecated = [ '-':flagName flag+                              | (deprecated, flag) <- flagsAllDeps+                              , ok (flagOptKind flag)+                              , keepDeprecated || not (isDeprecated deprecated)]+  where ok (PrefixPred _ _) = False+        ok _   = True+        isDeprecated Deprecated = True+        isDeprecated _ = False++{-+ - Below we export user facing symbols for GHC dynamic flags for use with the+ - GHC API.+ -}++-- All dynamic flags present in GHC.+flagsAll :: [Flag (CmdLineP DynFlags)]+flagsAll = map snd flagsAllDeps++-- All dynamic flags present in GHC with deprecation information.+flagsAllDeps :: [(Deprecation, Flag (CmdLineP DynFlags))]+flagsAllDeps =  package_flags_deps ++ dynamic_flags_deps+++-- All dynamic flags, minus package flags, present in GHC.+flagsDynamic :: [Flag (CmdLineP DynFlags)]+flagsDynamic = map snd dynamic_flags_deps++-- ALl package flags present in GHC.+flagsPackage :: [Flag (CmdLineP DynFlags)]+flagsPackage = map snd package_flags_deps++----------------Helpers to make flags and keep deprecation information----------++type FlagMaker m = String -> OptKind m -> Flag m+type DynFlagMaker = FlagMaker (CmdLineP DynFlags)+data Deprecation = NotDeprecated | Deprecated deriving (Eq, Ord)++-- Make a non-deprecated flag+make_ord_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags)+              -> (Deprecation, Flag (CmdLineP DynFlags))+make_ord_flag fm name kind = (NotDeprecated, fm name kind)++-- Make a deprecated flag+make_dep_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags) -> String+                 -> (Deprecation, Flag (CmdLineP DynFlags))+make_dep_flag fm name kind message = (Deprecated,+                                      fm name $ add_dep_message kind message)++add_dep_message :: OptKind (CmdLineP DynFlags) -> String+                -> OptKind (CmdLineP DynFlags)+add_dep_message (NoArg f) message = NoArg $ f >> deprecate message+add_dep_message (HasArg f) message = HasArg $ \s -> f s >> deprecate message+add_dep_message (SepArg f) message = SepArg $ \s -> f s >> deprecate message+add_dep_message (Prefix f) message = Prefix $ \s -> f s >> deprecate message+add_dep_message (OptPrefix f) message =+                                  OptPrefix $ \s -> f s >> deprecate message+add_dep_message (OptIntSuffix f) message =+                               OptIntSuffix $ \oi -> f oi >> deprecate message+add_dep_message (IntSuffix f) message =+                                  IntSuffix $ \i -> f i >> deprecate message+add_dep_message (FloatSuffix f) message =+                                FloatSuffix $ \fl -> f fl >> deprecate message+add_dep_message (PassFlag f) message =+                                   PassFlag $ \s -> f s >> deprecate message+add_dep_message (AnySuffix f) message =+                                  AnySuffix $ \s -> f s >> deprecate message+add_dep_message (PrefixPred pred f) message =+                            PrefixPred pred $ \s -> f s >> deprecate message+add_dep_message (AnySuffixPred pred f) message =+                         AnySuffixPred pred $ \s -> f s >> deprecate message++----------------------- The main flags themselves ------------------------------+-- See Note [Updating flag description in the User's Guide]+-- See Note [Supporting CLI completion]+dynamic_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))]+dynamic_flags_deps = [+    make_dep_flag defFlag "n" (NoArg $ return ())+        "The -n flag is deprecated and no longer has any effect"+  , make_ord_flag defFlag "cpp"      (NoArg (setExtensionFlag LangExt.Cpp))+  , make_ord_flag defFlag "F"        (NoArg (setGeneralFlag Opt_Pp))+  , (Deprecated, defFlag "#include"+      (HasArg (\_s ->+         addWarn ("-#include and INCLUDE pragmas are " +++                  "deprecated: They no longer have any effect"))))+  , make_ord_flag defFlag "v"        (OptIntSuffix setVerbosity)++  , make_ord_flag defGhcFlag "j"     (OptIntSuffix+        (\n -> case n of+                 Just n+                     | n > 0     -> upd (\d -> d { parMakeCount = Just n })+                     | otherwise -> addErr "Syntax: -j[n] where n > 0"+                 Nothing -> upd (\d -> d { parMakeCount = Nothing })))+                 -- When the number of parallel builds+                 -- is omitted, it is the same+                 -- as specifing that the number of+                 -- parallel builds is equal to the+                 -- result of getNumProcessors+  , make_ord_flag defFlag "instantiated-with"   (sepArg setUnitIdInsts)+  , make_ord_flag defFlag "this-component-id"   (sepArg setComponentId)++    -- RTS options -------------------------------------------------------------+  , make_ord_flag defFlag "H"           (HasArg (\s -> upd (\d ->+          d { ghcHeapSize = Just $ fromIntegral (decodeSize s)})))++  , make_ord_flag defFlag "Rghc-timing" (NoArg (upd (\d ->+                                               d { enableTimeStats = True })))++    ------- ways ---------------------------------------------------------------+  , make_ord_flag defGhcFlag "prof"           (NoArg (addWay WayProf))+  , make_ord_flag defGhcFlag "eventlog"       (NoArg (addWay WayEventLog))+  , make_dep_flag defGhcFlag "smp"+      (NoArg $ addWay WayThreaded) "Use -threaded instead"+  , make_ord_flag defGhcFlag "debug"          (NoArg (addWay WayDebug))+  , make_ord_flag defGhcFlag "threaded"       (NoArg (addWay WayThreaded))++  , make_ord_flag defGhcFlag "ticky"+      (NoArg (setGeneralFlag Opt_Ticky >> addWay WayDebug))++    -- -ticky enables ticky-ticky code generation, and also implies -debug which+    -- is required to get the RTS ticky support.++        ----- Linker --------------------------------------------------------+  , make_ord_flag defGhcFlag "static"         (NoArg removeWayDyn)+  , make_ord_flag defGhcFlag "dynamic"        (NoArg (addWay WayDyn))+  , make_ord_flag defGhcFlag "rdynamic" $ noArg $+#ifdef linux_HOST_OS+                              addOptl "-rdynamic"+#elif defined (mingw32_HOST_OS)+                              addOptl "-Wl,--export-all-symbols"+#else+    -- ignored for compat w/ gcc:+                              id+#endif+  , make_ord_flag defGhcFlag "relative-dynlib-paths"+      (NoArg (setGeneralFlag Opt_RelativeDynlibPaths))++        ------- Specific phases  --------------------------------------------+    -- need to appear before -pgmL to be parsed as LLVM flags.+  , make_ord_flag defFlag "pgmlo"+      (hasArg (\f -> alterSettings (\s -> s { sPgm_lo  = (f,[])})))+  , make_ord_flag defFlag "pgmlc"+      (hasArg (\f -> alterSettings (\s -> s { sPgm_lc  = (f,[])})))+  , make_ord_flag defFlag "pgmi"+      (hasArg (\f -> alterSettings (\s -> s { sPgm_i  =  f})))+  , make_ord_flag defFlag "pgmL"+      (hasArg (\f -> alterSettings (\s -> s { sPgm_L   = f})))+  , make_ord_flag defFlag "pgmP"+      (hasArg setPgmP)+  , make_ord_flag defFlag "pgmF"+      (hasArg (\f -> alterSettings (\s -> s { sPgm_F   = f})))+  , make_ord_flag defFlag "pgmc"+      (hasArg (\f -> alterSettings (\s -> s { sPgm_c   = (f,[])})))+  , make_ord_flag defFlag "pgms"+      (hasArg (\f -> alterSettings (\s -> s { sPgm_s   = (f,[])})))+  , make_ord_flag defFlag "pgma"+      (hasArg (\f -> alterSettings (\s -> s { sPgm_a   = (f,[])})))+  , make_ord_flag defFlag "pgml"+      (hasArg (\f -> alterSettings (\s -> s { sPgm_l   = (f,[])})))+  , make_ord_flag defFlag "pgmdll"+      (hasArg (\f -> alterSettings (\s -> s { sPgm_dll = (f,[])})))+  , make_ord_flag defFlag "pgmwindres"+      (hasArg (\f -> alterSettings (\s -> s { sPgm_windres = f})))+  , make_ord_flag defFlag "pgmlibtool"+      (hasArg (\f -> alterSettings (\s -> s { sPgm_libtool = f})))++    -- need to appear before -optl/-opta to be parsed as LLVM flags.+  , make_ord_flag defFlag "optlo"+      (hasArg (\f -> alterSettings (\s -> s { sOpt_lo  = f : sOpt_lo s})))+  , make_ord_flag defFlag "optlc"+      (hasArg (\f -> alterSettings (\s -> s { sOpt_lc  = f : sOpt_lc s})))+  , make_ord_flag defFlag "opti"+      (hasArg (\f -> alterSettings (\s -> s { sOpt_i   = f : sOpt_i s})))+  , make_ord_flag defFlag "optL"+      (hasArg (\f -> alterSettings (\s -> s { sOpt_L   = f : sOpt_L s})))+  , make_ord_flag defFlag "optP"+      (hasArg addOptP)+  , make_ord_flag defFlag "optF"+      (hasArg (\f -> alterSettings (\s -> s { sOpt_F   = f : sOpt_F s})))+  , make_ord_flag defFlag "optc"+      (hasArg addOptc)+  , make_ord_flag defFlag "opta"+      (hasArg (\f -> alterSettings (\s -> s { sOpt_a   = f : sOpt_a s})))+  , make_ord_flag defFlag "optl"+      (hasArg addOptl)+  , make_ord_flag defFlag "optwindres"+      (hasArg (\f ->+        alterSettings (\s -> s { sOpt_windres = f : sOpt_windres s})))++  , make_ord_flag defGhcFlag "split-objs"+      (NoArg (if can_split+                then setGeneralFlag Opt_SplitObjs+                else addWarn "ignoring -fsplit-objs"))++  , make_ord_flag defGhcFlag "split-sections"+      (noArgM (\dflags -> do+        if platformHasSubsectionsViaSymbols (targetPlatform dflags)+          then do addErr $+                    "-split-sections is not useful on this platform " +++                    "since it always uses subsections via symbols."+                  return dflags+          else return (gopt_set dflags Opt_SplitSections)))++        -------- ghc -M -----------------------------------------------------+  , make_ord_flag defGhcFlag "dep-suffix"              (hasArg addDepSuffix)+  , make_ord_flag defGhcFlag "dep-makefile"            (hasArg setDepMakefile)+  , make_ord_flag defGhcFlag "include-pkg-deps"+        (noArg (setDepIncludePkgDeps True))+  , make_ord_flag defGhcFlag "exclude-module"          (hasArg addDepExcludeMod)++        -------- Linking ----------------------------------------------------+  , make_ord_flag defGhcFlag "no-link"+        (noArg (\d -> d { ghcLink=NoLink }))+  , make_ord_flag defGhcFlag "shared"+        (noArg (\d -> d { ghcLink=LinkDynLib }))+  , make_ord_flag defGhcFlag "staticlib"+        (noArg (\d -> d { ghcLink=LinkStaticLib }))+  , make_ord_flag defGhcFlag "dynload"            (hasArg parseDynLibLoaderMode)+  , make_ord_flag defGhcFlag "dylib-install-name" (hasArg setDylibInstallName)+    -- -dll-split is an internal flag, used only during the GHC build+  , make_ord_flag defHiddenFlag "dll-split"+      (hasArg (\f d -> d { dllSplitFile = Just f, dllSplit = Nothing }))++        ------- Libraries ---------------------------------------------------+  , make_ord_flag defFlag "L"   (Prefix addLibraryPath)+  , make_ord_flag defFlag "l"   (hasArg (addLdInputs . Option . ("-l" ++)))++        ------- Frameworks --------------------------------------------------+        -- -framework-path should really be -F ...+  , make_ord_flag defFlag "framework-path" (HasArg addFrameworkPath)+  , make_ord_flag defFlag "framework"      (hasArg addCmdlineFramework)++        ------- Output Redirection ------------------------------------------+  , make_ord_flag defGhcFlag "odir"              (hasArg setObjectDir)+  , make_ord_flag defGhcFlag "o"                 (sepArg (setOutputFile . Just))+  , make_ord_flag defGhcFlag "dyno"+        (sepArg (setDynOutputFile . Just))+  , make_ord_flag defGhcFlag "ohi"+        (hasArg (setOutputHi . Just ))+  , make_ord_flag defGhcFlag "osuf"              (hasArg setObjectSuf)+  , make_ord_flag defGhcFlag "dynosuf"           (hasArg setDynObjectSuf)+  , make_ord_flag defGhcFlag "hcsuf"             (hasArg setHcSuf)+  , make_ord_flag defGhcFlag "hisuf"             (hasArg setHiSuf)+  , make_ord_flag defGhcFlag "dynhisuf"          (hasArg setDynHiSuf)+  , make_ord_flag defGhcFlag "hidir"             (hasArg setHiDir)+  , make_ord_flag defGhcFlag "tmpdir"            (hasArg setTmpDir)+  , make_ord_flag defGhcFlag "stubdir"           (hasArg setStubDir)+  , make_ord_flag defGhcFlag "dumpdir"           (hasArg setDumpDir)+  , make_ord_flag defGhcFlag "outputdir"         (hasArg setOutputDir)+  , make_ord_flag defGhcFlag "ddump-file-prefix"+        (hasArg (setDumpPrefixForce . Just))++  , make_ord_flag defGhcFlag "dynamic-too"+        (NoArg (setGeneralFlag Opt_BuildDynamicToo))++        ------- Keeping temporary files -------------------------------------+     -- These can be singular (think ghc -c) or plural (think ghc --make)+  , make_ord_flag defGhcFlag "keep-hc-file"+        (NoArg (setGeneralFlag Opt_KeepHcFiles))+  , make_ord_flag defGhcFlag "keep-hc-files"+        (NoArg (setGeneralFlag Opt_KeepHcFiles))+  , make_ord_flag defGhcFlag "keep-s-file"+        (NoArg (setGeneralFlag Opt_KeepSFiles))+  , make_ord_flag defGhcFlag "keep-s-files"+        (NoArg (setGeneralFlag Opt_KeepSFiles))+  , make_ord_flag defGhcFlag "keep-llvm-file"+        (NoArg $ setObjTarget HscLlvm >> setGeneralFlag Opt_KeepLlvmFiles)+  , make_ord_flag defGhcFlag "keep-llvm-files"+        (NoArg $ setObjTarget HscLlvm >> setGeneralFlag Opt_KeepLlvmFiles)+     -- This only makes sense as plural+  , make_ord_flag defGhcFlag "keep-tmp-files"+        (NoArg (setGeneralFlag Opt_KeepTmpFiles))+  , make_ord_flag defGhcFlag "keep-hi-file"+        (NoArg (setGeneralFlag Opt_KeepHiFiles))+  , make_ord_flag defGhcFlag "no-keep-hi-file"+        (NoArg (unSetGeneralFlag Opt_KeepHiFiles))+  , make_ord_flag defGhcFlag "keep-hi-files"+        (NoArg (setGeneralFlag Opt_KeepHiFiles))+  , make_ord_flag defGhcFlag "no-keep-hi-files"+        (NoArg (unSetGeneralFlag Opt_KeepHiFiles))+  , make_ord_flag defGhcFlag "keep-o-file"+        (NoArg (setGeneralFlag Opt_KeepOFiles))+  , make_ord_flag defGhcFlag "no-keep-o-file"+        (NoArg (unSetGeneralFlag Opt_KeepOFiles))+  , make_ord_flag defGhcFlag "keep-o-files"+        (NoArg (setGeneralFlag Opt_KeepOFiles))+  , make_ord_flag defGhcFlag "no-keep-o-files"+        (NoArg (unSetGeneralFlag Opt_KeepOFiles))++        ------- Miscellaneous ----------------------------------------------+  , make_ord_flag defGhcFlag "no-auto-link-packages"+        (NoArg (unSetGeneralFlag Opt_AutoLinkPackages))+  , make_ord_flag defGhcFlag "no-hs-main"+        (NoArg (setGeneralFlag Opt_NoHsMain))+  , make_ord_flag defGhcFlag "fno-state-hack"+        (NoArg (setGeneralFlag Opt_G_NoStateHack))+  , make_ord_flag defGhcFlag "fno-opt-coercion"+        (NoArg (setGeneralFlag Opt_G_NoOptCoercion))+  , make_ord_flag defGhcFlag "with-rtsopts"+        (HasArg setRtsOpts)+  , make_ord_flag defGhcFlag "rtsopts"+        (NoArg (setRtsOptsEnabled RtsOptsAll))+  , make_ord_flag defGhcFlag "rtsopts=all"+        (NoArg (setRtsOptsEnabled RtsOptsAll))+  , make_ord_flag defGhcFlag "rtsopts=some"+        (NoArg (setRtsOptsEnabled RtsOptsSafeOnly))+  , make_ord_flag defGhcFlag "rtsopts=none"+        (NoArg (setRtsOptsEnabled RtsOptsNone))+  , make_ord_flag defGhcFlag "no-rtsopts"+        (NoArg (setRtsOptsEnabled RtsOptsNone))+  , make_ord_flag defGhcFlag "no-rtsopts-suggestions"+      (noArg (\d -> d {rtsOptsSuggestions = False}))++  , make_ord_flag defGhcFlag "main-is"              (SepArg setMainIs)+  , make_ord_flag defGhcFlag "haddock"              (NoArg (setGeneralFlag Opt_Haddock))+  , make_ord_flag defGhcFlag "haddock-opts"         (hasArg addHaddockOpts)+  , make_ord_flag defGhcFlag "hpcdir"               (SepArg setOptHpcDir)+  , make_ord_flag defGhciFlag "ghci-script"         (hasArg addGhciScript)+  , make_ord_flag defGhciFlag "interactive-print"   (hasArg setInteractivePrint)+  , make_ord_flag defGhcFlag "ticky-allocd"+        (NoArg (setGeneralFlag Opt_Ticky_Allocd))+  , make_ord_flag defGhcFlag "ticky-LNE"+        (NoArg (setGeneralFlag Opt_Ticky_LNE))+  , make_ord_flag defGhcFlag "ticky-dyn-thunk"+        (NoArg (setGeneralFlag Opt_Ticky_Dyn_Thunk))+        ------- recompilation checker --------------------------------------+  , make_dep_flag defGhcFlag "recomp"+        (NoArg $ unSetGeneralFlag Opt_ForceRecomp)+             "Use -fno-force-recomp instead"+  , make_dep_flag defGhcFlag "no-recomp"+        (NoArg $ setGeneralFlag Opt_ForceRecomp) "Use -fforce-recomp instead"+  , make_ord_flag defFlag "fmax-errors"+      (intSuffix (\n d -> d { maxErrors = Just (max 1 n) }))+  , make_ord_flag defFlag "fno-max-errors"+      (noArg (\d -> d { maxErrors = Nothing }))+  , make_ord_flag defFlag "freverse-errors"+        (noArg (\d -> d {reverseErrors = True} ))+  , make_ord_flag defFlag "fno-reverse-errors"+        (noArg (\d -> d {reverseErrors = False} ))++        ------ HsCpp opts ---------------------------------------------------+  , make_ord_flag defFlag "D"              (AnySuffix (upd . addOptP))+  , make_ord_flag defFlag "U"              (AnySuffix (upd . addOptP))++        ------- Include/Import Paths ----------------------------------------+  , make_ord_flag defFlag "I"              (Prefix    addIncludePath)+  , make_ord_flag defFlag "i"              (OptPrefix addImportPath)++        ------ Output style options -----------------------------------------+  , make_ord_flag defFlag "dppr-user-length" (intSuffix (\n d ->+                                                       d { pprUserLength = n }))+  , make_ord_flag defFlag "dppr-cols"        (intSuffix (\n d ->+                                                             d { pprCols = n }))+  , make_ord_flag defFlag "fdiagnostics-color=auto"+      (NoArg (upd (\d -> d { useColor = Auto })))+  , make_ord_flag defFlag "fdiagnostics-color=always"+      (NoArg (upd (\d -> d { useColor = Always })))+  , make_ord_flag defFlag "fdiagnostics-color=never"+      (NoArg (upd (\d -> d { useColor = Never })))++  -- Suppress all that is suppressable in core dumps.+  -- Except for uniques, as some simplifier phases introduce new variables that+  -- have otherwise identical names.+  , make_ord_flag defGhcFlag "dsuppress-all"+      (NoArg $ do setGeneralFlag Opt_SuppressCoercions+                  setGeneralFlag Opt_SuppressVarKinds+                  setGeneralFlag Opt_SuppressModulePrefixes+                  setGeneralFlag Opt_SuppressTypeApplications+                  setGeneralFlag Opt_SuppressIdInfo+                  setGeneralFlag Opt_SuppressTicks+                  setGeneralFlag Opt_SuppressTypeSignatures)++        ------ Debugging ----------------------------------------------------+  , make_ord_flag defGhcFlag "dstg-stats"+        (NoArg (setGeneralFlag Opt_StgStats))++  , make_ord_flag defGhcFlag "ddump-cmm"+        (setDumpFlag Opt_D_dump_cmm)+  , make_ord_flag defGhcFlag "ddump-cmm-from-stg"+        (setDumpFlag Opt_D_dump_cmm_from_stg)+  , make_ord_flag defGhcFlag "ddump-cmm-raw"+        (setDumpFlag Opt_D_dump_cmm_raw)+  , make_ord_flag defGhcFlag "ddump-cmm-verbose"+        (setDumpFlag Opt_D_dump_cmm_verbose)+  , make_ord_flag defGhcFlag "ddump-cmm-cfg"+        (setDumpFlag Opt_D_dump_cmm_cfg)+  , make_ord_flag defGhcFlag "ddump-cmm-cbe"+        (setDumpFlag Opt_D_dump_cmm_cbe)+  , make_ord_flag defGhcFlag "ddump-cmm-switch"+        (setDumpFlag Opt_D_dump_cmm_switch)+  , make_ord_flag defGhcFlag "ddump-cmm-proc"+        (setDumpFlag Opt_D_dump_cmm_proc)+  , make_ord_flag defGhcFlag "ddump-cmm-sp"+        (setDumpFlag Opt_D_dump_cmm_sp)+  , make_ord_flag defGhcFlag "ddump-cmm-sink"+        (setDumpFlag Opt_D_dump_cmm_sink)+  , make_ord_flag defGhcFlag "ddump-cmm-caf"+        (setDumpFlag Opt_D_dump_cmm_caf)+  , make_ord_flag defGhcFlag "ddump-cmm-procmap"+        (setDumpFlag Opt_D_dump_cmm_procmap)+  , make_ord_flag defGhcFlag "ddump-cmm-split"+        (setDumpFlag Opt_D_dump_cmm_split)+  , make_ord_flag defGhcFlag "ddump-cmm-info"+        (setDumpFlag Opt_D_dump_cmm_info)+  , make_ord_flag defGhcFlag "ddump-cmm-cps"+        (setDumpFlag Opt_D_dump_cmm_cps)+  , make_ord_flag defGhcFlag "ddump-core-stats"+        (setDumpFlag Opt_D_dump_core_stats)+  , make_ord_flag defGhcFlag "ddump-asm"+        (setDumpFlag Opt_D_dump_asm)+  , make_ord_flag defGhcFlag "ddump-asm-native"+        (setDumpFlag Opt_D_dump_asm_native)+  , make_ord_flag defGhcFlag "ddump-asm-liveness"+        (setDumpFlag Opt_D_dump_asm_liveness)+  , make_ord_flag defGhcFlag "ddump-asm-regalloc"+        (setDumpFlag Opt_D_dump_asm_regalloc)+  , make_ord_flag defGhcFlag "ddump-asm-conflicts"+        (setDumpFlag Opt_D_dump_asm_conflicts)+  , make_ord_flag defGhcFlag "ddump-asm-regalloc-stages"+        (setDumpFlag Opt_D_dump_asm_regalloc_stages)+  , make_ord_flag defGhcFlag "ddump-asm-stats"+        (setDumpFlag Opt_D_dump_asm_stats)+  , make_ord_flag defGhcFlag "ddump-asm-expanded"+        (setDumpFlag Opt_D_dump_asm_expanded)+  , make_ord_flag defGhcFlag "ddump-llvm"+        (NoArg $ setObjTarget HscLlvm >> setDumpFlag' Opt_D_dump_llvm)+  , make_ord_flag defGhcFlag "ddump-deriv"+        (setDumpFlag Opt_D_dump_deriv)+  , make_ord_flag defGhcFlag "ddump-ds"+        (setDumpFlag Opt_D_dump_ds)+  , make_ord_flag defGhcFlag "ddump-foreign"+        (setDumpFlag Opt_D_dump_foreign)+  , make_ord_flag defGhcFlag "ddump-inlinings"+        (setDumpFlag Opt_D_dump_inlinings)+  , make_ord_flag defGhcFlag "ddump-rule-firings"+        (setDumpFlag Opt_D_dump_rule_firings)+  , make_ord_flag defGhcFlag "ddump-rule-rewrites"+        (setDumpFlag Opt_D_dump_rule_rewrites)+  , make_ord_flag defGhcFlag "ddump-simpl-trace"+        (setDumpFlag Opt_D_dump_simpl_trace)+  , make_ord_flag defGhcFlag "ddump-occur-anal"+        (setDumpFlag Opt_D_dump_occur_anal)+  , make_ord_flag defGhcFlag "ddump-parsed"+        (setDumpFlag Opt_D_dump_parsed)+  , make_ord_flag defGhcFlag "ddump-parsed-ast"+        (setDumpFlag Opt_D_dump_parsed_ast)+  , make_ord_flag defGhcFlag "ddump-rn"+        (setDumpFlag Opt_D_dump_rn)+  , make_ord_flag defGhcFlag "ddump-rn-ast"+        (setDumpFlag Opt_D_dump_rn_ast)+  , make_ord_flag defGhcFlag "ddump-simpl"+        (setDumpFlag Opt_D_dump_simpl)+  , make_ord_flag defGhcFlag "ddump-simpl-iterations"+      (setDumpFlag Opt_D_dump_simpl_iterations)+  , make_ord_flag defGhcFlag "ddump-spec"+        (setDumpFlag Opt_D_dump_spec)+  , make_ord_flag defGhcFlag "ddump-prep"+        (setDumpFlag Opt_D_dump_prep)+  , make_ord_flag defGhcFlag "ddump-stg"+        (setDumpFlag Opt_D_dump_stg)+  , make_ord_flag defGhcFlag "ddump-call-arity"+        (setDumpFlag Opt_D_dump_call_arity)+  , make_ord_flag defGhcFlag "ddump-stranal"+        (setDumpFlag Opt_D_dump_stranal)+  , make_ord_flag defGhcFlag "ddump-str-signatures"+        (setDumpFlag Opt_D_dump_str_signatures)+  , make_ord_flag defGhcFlag "ddump-tc"+        (setDumpFlag Opt_D_dump_tc)+  , make_ord_flag defGhcFlag "ddump-tc-ast"+        (setDumpFlag Opt_D_dump_tc_ast)+  , make_ord_flag defGhcFlag "ddump-types"+        (setDumpFlag Opt_D_dump_types)+  , make_ord_flag defGhcFlag "ddump-rules"+        (setDumpFlag Opt_D_dump_rules)+  , make_ord_flag defGhcFlag "ddump-cse"+        (setDumpFlag Opt_D_dump_cse)+  , make_ord_flag defGhcFlag "ddump-worker-wrapper"+        (setDumpFlag Opt_D_dump_worker_wrapper)+  , make_ord_flag defGhcFlag "ddump-rn-trace"+        (setDumpFlag Opt_D_dump_rn_trace)+  , make_ord_flag defGhcFlag "ddump-shape"+        (setDumpFlag Opt_D_dump_shape)+  , make_ord_flag defGhcFlag "ddump-if-trace"+        (setDumpFlag Opt_D_dump_if_trace)+  , make_ord_flag defGhcFlag "ddump-cs-trace"+        (setDumpFlag Opt_D_dump_cs_trace)+  , make_ord_flag defGhcFlag "ddump-tc-trace"+        (NoArg (do setDumpFlag' Opt_D_dump_tc_trace+                   setDumpFlag' Opt_D_dump_cs_trace))+  , make_ord_flag defGhcFlag "ddump-ec-trace"+        (setDumpFlag Opt_D_dump_ec_trace)+  , make_ord_flag defGhcFlag "ddump-vt-trace"+        (setDumpFlag Opt_D_dump_vt_trace)+  , make_ord_flag defGhcFlag "ddump-splices"+        (setDumpFlag Opt_D_dump_splices)+  , make_ord_flag defGhcFlag "dth-dec-file"+        (setDumpFlag Opt_D_th_dec_file)++  , make_ord_flag defGhcFlag "ddump-rn-stats"+        (setDumpFlag Opt_D_dump_rn_stats)+  , make_ord_flag defGhcFlag "ddump-opt-cmm"+        (setDumpFlag Opt_D_dump_opt_cmm)+  , make_ord_flag defGhcFlag "ddump-simpl-stats"+        (setDumpFlag Opt_D_dump_simpl_stats)+  , make_ord_flag defGhcFlag "ddump-bcos"+        (setDumpFlag Opt_D_dump_BCOs)+  , make_ord_flag defGhcFlag "dsource-stats"+        (setDumpFlag Opt_D_source_stats)+  , make_ord_flag defGhcFlag "dverbose-core2core"+        (NoArg $ setVerbosity (Just 2) >> setVerboseCore2Core)+  , make_ord_flag defGhcFlag "dverbose-stg2stg"+        (setDumpFlag Opt_D_verbose_stg2stg)+  , make_ord_flag defGhcFlag "ddump-hi"+        (setDumpFlag Opt_D_dump_hi)+  , make_ord_flag defGhcFlag "ddump-minimal-imports"+        (NoArg (setGeneralFlag Opt_D_dump_minimal_imports))+  , make_ord_flag defGhcFlag "ddump-vect"+        (setDumpFlag Opt_D_dump_vect)+  , make_ord_flag defGhcFlag "ddump-hpc"+        (setDumpFlag Opt_D_dump_ticked) -- back compat+  , make_ord_flag defGhcFlag "ddump-ticked"+        (setDumpFlag Opt_D_dump_ticked)+  , make_ord_flag defGhcFlag "ddump-mod-cycles"+        (setDumpFlag Opt_D_dump_mod_cycles)+  , make_ord_flag defGhcFlag "ddump-mod-map"+        (setDumpFlag Opt_D_dump_mod_map)+  , make_ord_flag defGhcFlag "ddump-view-pattern-commoning"+        (setDumpFlag Opt_D_dump_view_pattern_commoning)+  , make_ord_flag defGhcFlag "ddump-to-file"+        (NoArg (setGeneralFlag Opt_DumpToFile))+  , make_ord_flag defGhcFlag "ddump-hi-diffs"+        (setDumpFlag Opt_D_dump_hi_diffs)+  , make_ord_flag defGhcFlag "ddump-rtti"+        (setDumpFlag Opt_D_dump_rtti)+  , make_ord_flag defGhcFlag "dcore-lint"+        (NoArg (setGeneralFlag Opt_DoCoreLinting))+  , make_ord_flag defGhcFlag "dstg-lint"+        (NoArg (setGeneralFlag Opt_DoStgLinting))+  , make_ord_flag defGhcFlag "dcmm-lint"+        (NoArg (setGeneralFlag Opt_DoCmmLinting))+  , make_ord_flag defGhcFlag "dasm-lint"+        (NoArg (setGeneralFlag Opt_DoAsmLinting))+  , make_ord_flag defGhcFlag "dannot-lint"+        (NoArg (setGeneralFlag Opt_DoAnnotationLinting))+  , make_ord_flag defGhcFlag "dshow-passes"+        (NoArg $ forceRecompile >> (setVerbosity $ Just 2))+  , make_ord_flag defGhcFlag "dfaststring-stats"+        (NoArg (setGeneralFlag Opt_D_faststring_stats))+  , make_ord_flag defGhcFlag "dno-llvm-mangler"+        (NoArg (setGeneralFlag Opt_NoLlvmMangler)) -- hidden flag+  , make_ord_flag defGhcFlag "ddump-debug"+        (setDumpFlag Opt_D_dump_debug)+  , make_ord_flag defGhcFlag "ddump-json"+        (noArg (flip dopt_set Opt_D_dump_json . setJsonLogAction ) )+  , make_ord_flag defGhcFlag "dppr-debug"+        (setDumpFlag Opt_D_ppr_debug)+  , make_ord_flag defGhcFlag "dno-debug-output"+        (setDumpFlag Opt_D_no_debug_output)++        ------ Machine dependent (-m<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 "mavx"         (noArg (\d -> d { avx = True }))+  , make_ord_flag defGhcFlag "mavx2"        (noArg (\d -> d { avx2 = True }))+  , make_ord_flag defGhcFlag "mavx512cd"    (noArg (\d ->+                                                         d { avx512cd = True }))+  , make_ord_flag defGhcFlag "mavx512er"    (noArg (\d ->+                                                         d { avx512er = True }))+  , make_ord_flag defGhcFlag "mavx512f"     (noArg (\d -> d { avx512f = True }))+  , make_ord_flag defGhcFlag "mavx512pf"    (noArg (\d ->+                                                         d { avx512pf = True }))++     ------ Warning opts -------------------------------------------------+  , make_ord_flag defFlag "W"       (NoArg (mapM_ setWarningFlag minusWOpts))+  , make_ord_flag defFlag "Werror"+               (NoArg (do { setGeneralFlag Opt_WarnIsError+                          ; mapM_ setFatalWarningFlag minusWeverythingOpts   }))+  , make_ord_flag defFlag "Wwarn"+               (NoArg (do { unSetGeneralFlag Opt_WarnIsError+                          ; mapM_ unSetFatalWarningFlag minusWeverythingOpts }))+                          -- Opt_WarnIsError is still needed to pass -Werror+                          -- to CPP; see runCpp in SysTools+  , make_dep_flag defFlag "Wnot"    (NoArg (upd (\d ->+                                              d {warningFlags = IntSet.empty})))+                                             "Use -w or -Wno-everything instead"+  , make_ord_flag defFlag "w"       (NoArg (upd (\d ->+                                              d {warningFlags = IntSet.empty})))++     -- New-style uniform warning sets+     --+     -- Note that -Weverything > -Wall > -Wextra > -Wdefault > -Wno-everything+  , make_ord_flag defFlag "Weverything"    (NoArg (mapM_+                                           setWarningFlag minusWeverythingOpts))+  , make_ord_flag defFlag "Wno-everything"+                           (NoArg (upd (\d -> d {warningFlags = IntSet.empty})))++  , make_ord_flag defFlag "Wall"           (NoArg (mapM_+                                                  setWarningFlag minusWallOpts))+  , make_ord_flag defFlag "Wno-all"        (NoArg (mapM_+                                                unSetWarningFlag minusWallOpts))++  , make_ord_flag defFlag "Wextra"         (NoArg (mapM_+                                                     setWarningFlag minusWOpts))+  , make_ord_flag defFlag "Wno-extra"      (NoArg (mapM_+                                                   unSetWarningFlag minusWOpts))++  , make_ord_flag defFlag "Wdefault"       (NoArg (mapM_+                                               setWarningFlag standardWarnings))+  , make_ord_flag defFlag "Wno-default"    (NoArg (mapM_+                                             unSetWarningFlag standardWarnings))++  , make_ord_flag defFlag "Wcompat"        (NoArg (mapM_+                                               setWarningFlag minusWcompatOpts))+  , make_ord_flag defFlag "Wno-compat"     (NoArg (mapM_+                                             unSetWarningFlag minusWcompatOpts))++        ------ Plugin flags ------------------------------------------------+  , make_ord_flag defGhcFlag "fplugin-opt" (hasArg addPluginModuleNameOption)+  , make_ord_flag defGhcFlag "fplugin"     (hasArg addPluginModuleName)+  , make_ord_flag defGhcFlag "ffrontend-opt" (hasArg addFrontendPluginOption)++        ------ Optimisation flags ------------------------------------------+  , make_ord_flag defGhcFlag "O"      (noArgM (setOptLevel 1))+  , make_dep_flag defGhcFlag "Onot"   (noArgM $ setOptLevel 0 )+                                                            "Use -O0 instead"+  , make_ord_flag defGhcFlag "Odph"   (noArgM setDPHOpt)+  , make_ord_flag defGhcFlag "O"      (optIntSuffixM (\mb_n ->+                                                setOptLevel (mb_n `orElse` 1)))+                -- If the number is missing, use 1+++  , make_ord_flag defFlag "fmax-relevant-binds"+      (intSuffix (\n d -> d { maxRelevantBinds = Just n }))+  , make_ord_flag defFlag "fno-max-relevant-binds"+      (noArg (\d -> d { maxRelevantBinds = Nothing }))+  , make_ord_flag defFlag "fmax-uncovered-patterns"+      (intSuffix (\n d -> d { maxUncoveredPatterns = n }))+  , make_ord_flag defFlag "fsimplifier-phases"+      (intSuffix (\n d -> d { simplPhases = n }))+  , make_ord_flag defFlag "fmax-simplifier-iterations"+      (intSuffix (\n d -> d { maxSimplIterations = n }))+  , make_ord_flag defFlag "fmax-pmcheck-iterations"+      (intSuffix (\n d -> d{ maxPmCheckIterations = n }))+  , make_ord_flag defFlag "fsimpl-tick-factor"+      (intSuffix (\n d -> d { simplTickFactor = n }))+  , make_ord_flag defFlag "fspec-constr-threshold"+      (intSuffix (\n d -> d { specConstrThreshold = Just n }))+  , make_ord_flag defFlag "fno-spec-constr-threshold"+      (noArg (\d -> d { specConstrThreshold = Nothing }))+  , make_ord_flag defFlag "fspec-constr-count"+      (intSuffix (\n d -> d { specConstrCount = Just n }))+  , make_ord_flag defFlag "fno-spec-constr-count"+      (noArg (\d -> d { specConstrCount = Nothing }))+  , make_ord_flag defFlag "fspec-constr-recursive"+      (intSuffix (\n d -> d { specConstrRecursive = n }))+  , make_ord_flag defFlag "fliberate-case-threshold"+      (intSuffix (\n d -> d { liberateCaseThreshold = Just n }))+  , make_ord_flag defFlag "fno-liberate-case-threshold"+      (noArg (\d -> d { liberateCaseThreshold = Nothing }))+  , make_ord_flag defFlag "frule-check"+      (sepArg (\s d -> d { ruleCheck = Just s }))+  , make_ord_flag defFlag "freduction-depth"+      (intSuffix (\n d -> d { reductionDepth = treatZeroAsInf n }))+  , make_ord_flag defFlag "fconstraint-solver-iterations"+      (intSuffix (\n d -> d { solverIterations = treatZeroAsInf n }))+  , (Deprecated, defFlag "fcontext-stack"+      (intSuffixM (\n d ->+       do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead"+          ; return $ d { reductionDepth = treatZeroAsInf n } })))+  , (Deprecated, defFlag "ftype-function-depth"+      (intSuffixM (\n d ->+       do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead"+          ; return $ d { reductionDepth = treatZeroAsInf n } })))+  , make_ord_flag defFlag "fstrictness-before"+      (intSuffix (\n d -> d { strictnessBefore = n : strictnessBefore d }))+  , make_ord_flag defFlag "ffloat-lam-args"+      (intSuffix (\n d -> d { floatLamArgs = Just n }))+  , make_ord_flag defFlag "ffloat-all-lams"+      (noArg (\d -> d { floatLamArgs = Nothing }))+  , make_ord_flag defFlag "fhistory-size"+      (intSuffix (\n d -> d { historySize = n }))+  , make_ord_flag defFlag "funfolding-creation-threshold"+      (intSuffix   (\n d -> d {ufCreationThreshold = n}))+  , make_ord_flag defFlag "funfolding-use-threshold"+      (intSuffix   (\n d -> d {ufUseThreshold = n}))+  , make_ord_flag defFlag "funfolding-fun-discount"+      (intSuffix   (\n d -> d {ufFunAppDiscount = n}))+  , make_ord_flag defFlag "funfolding-dict-discount"+      (intSuffix   (\n d -> d {ufDictDiscount = n}))+  , make_ord_flag defFlag "funfolding-keeness-factor"+      (floatSuffix (\n d -> d {ufKeenessFactor = n}))+  , make_ord_flag defFlag "fmax-worker-args"+      (intSuffix (\n d -> d {maxWorkerArgs = n}))+  , make_ord_flag defGhciFlag "fghci-hist-size"+      (intSuffix (\n d -> d {ghciHistSize = n}))+  , make_ord_flag defGhcFlag "fmax-inline-alloc-size"+      (intSuffix (\n d -> d { maxInlineAllocSize = n }))+  , make_ord_flag defGhcFlag "fmax-inline-memcpy-insns"+      (intSuffix (\n d -> d { maxInlineMemcpyInsns = n }))+  , make_ord_flag defGhcFlag "fmax-inline-memset-insns"+      (intSuffix (\n d -> d { maxInlineMemsetInsns = n }))+  , make_ord_flag defGhcFlag "dinitial-unique"+      (intSuffix (\n d -> d { initialUnique = n }))+  , make_ord_flag defGhcFlag "dunique-increment"+      (intSuffix (\n d -> d { uniqueIncrement = n }))++        ------ Profiling ----------------------------------------------------++        -- OLD profiling flags+  , make_dep_flag defGhcFlag "auto-all"+                    (noArg (\d -> d { profAuto = ProfAutoAll } ))+                    "Use -fprof-auto instead"+  , make_dep_flag defGhcFlag "no-auto-all"+                    (noArg (\d -> d { profAuto = NoProfAuto } ))+                    "Use -fno-prof-auto instead"+  , make_dep_flag defGhcFlag "auto"+                    (noArg (\d -> d { profAuto = ProfAutoExports } ))+                    "Use -fprof-auto-exported instead"+  , make_dep_flag defGhcFlag "no-auto"+            (noArg (\d -> d { profAuto = NoProfAuto } ))+                    "Use -fno-prof-auto instead"+  , make_dep_flag defGhcFlag "caf-all"+            (NoArg (setGeneralFlag Opt_AutoSccsOnIndividualCafs))+                    "Use -fprof-cafs instead"+  , make_dep_flag defGhcFlag "no-caf-all"+            (NoArg (unSetGeneralFlag Opt_AutoSccsOnIndividualCafs))+                    "Use -fno-prof-cafs instead"++        -- NEW profiling flags+  , make_ord_flag defGhcFlag "fprof-auto"+      (noArg (\d -> d { profAuto = ProfAutoAll } ))+  , make_ord_flag defGhcFlag "fprof-auto-top"+      (noArg (\d -> d { profAuto = ProfAutoTop } ))+  , make_ord_flag defGhcFlag "fprof-auto-exported"+      (noArg (\d -> d { profAuto = ProfAutoExports } ))+  , make_ord_flag defGhcFlag "fprof-auto-calls"+      (noArg (\d -> d { profAuto = ProfAutoCalls } ))+  , make_ord_flag defGhcFlag "fno-prof-auto"+      (noArg (\d -> d { profAuto = NoProfAuto } ))++        ------ Compiler flags -----------------------------------------------++  , make_ord_flag defGhcFlag "fasm"             (NoArg (setObjTarget HscAsm))+  , make_ord_flag defGhcFlag "fvia-c"           (NoArg+         (addWarn $ "The -fvia-c flag does nothing; " +++                    "it will be removed in a future GHC release"))+  , make_ord_flag defGhcFlag "fvia-C"           (NoArg+         (addWarn $ "The -fvia-C flag does nothing; " +++                    "it will be removed in a future GHC release"))+  , make_ord_flag defGhcFlag "fllvm"            (NoArg (setObjTarget HscLlvm))++  , make_ord_flag defFlag "fno-code"         (NoArg ((upd $ \d ->+                  d { ghcLink=NoLink }) >> setTarget HscNothing))+  , make_ord_flag defFlag "fbyte-code"       (NoArg (setTarget HscInterpreted))+  , make_ord_flag defFlag "fobject-code"     (NoArg (setTargetWithPlatform+                                                             defaultHscTarget))+  , make_dep_flag defFlag "fglasgow-exts"+      (NoArg enableGlasgowExts) "Use individual extensions instead"+  , make_dep_flag defFlag "fno-glasgow-exts"+      (NoArg disableGlasgowExts) "Use individual extensions instead"+  , make_ord_flag defFlag "Wunused-binds" (NoArg enableUnusedBinds)+  , make_ord_flag defFlag "Wno-unused-binds" (NoArg disableUnusedBinds)+  , make_ord_flag defHiddenFlag "fwarn-unused-binds" (NoArg enableUnusedBinds)+  , make_ord_flag defHiddenFlag "fno-warn-unused-binds" (NoArg+                                                            disableUnusedBinds)++        ------ Safe Haskell flags -------------------------------------------+  , make_ord_flag defFlag "fpackage-trust"   (NoArg setPackageTrust)+  , make_ord_flag defFlag "fno-safe-infer"   (noArg (\d ->+                                                    d { safeInfer = False }))+  , make_ord_flag defGhcFlag "fPIC"          (NoArg (setGeneralFlag Opt_PIC))+  , make_ord_flag defGhcFlag "fno-PIC"       (NoArg (unSetGeneralFlag Opt_PIC))++         ------ Debugging flags ----------------------------------------------+  , make_ord_flag defGhcFlag "g"             (OptIntSuffix setDebugLevel)+ ]+ ++ map (mkFlag turnOn  ""          setGeneralFlag    ) negatableFlagsDeps+ ++ map (mkFlag turnOff "no-"       unSetGeneralFlag  ) negatableFlagsDeps+ ++ map (mkFlag turnOn  "d"         setGeneralFlag    ) dFlagsDeps+ ++ map (mkFlag turnOff "dno-"      unSetGeneralFlag  ) dFlagsDeps+ ++ map (mkFlag turnOn  "f"         setGeneralFlag    ) fFlagsDeps+ ++ map (mkFlag turnOff "fno-"      unSetGeneralFlag  ) fFlagsDeps+ ++ map (mkFlag turnOn  "W"         setWarningFlag    ) wWarningFlagsDeps+ ++ map (mkFlag turnOff "Wno-"      unSetWarningFlag  ) wWarningFlagsDeps+ ++ map (mkFlag turnOn  "Werror="   (\flag -> do {+                                       ; setWarningFlag flag+                                       ; setFatalWarningFlag flag }))+                                                        wWarningFlagsDeps+ ++ map (mkFlag turnOn  "Wwarn="     unSetFatalWarningFlag )+                                                        wWarningFlagsDeps+ ++ map (mkFlag turnOn  "Wno-error=" unSetFatalWarningFlag )+                                                        wWarningFlagsDeps+ ++ map (mkFlag turnOn  "fwarn-"    setWarningFlag   . hideFlag)+    wWarningFlagsDeps+ ++ map (mkFlag turnOff "fno-warn-" unSetWarningFlag . hideFlag)+    wWarningFlagsDeps+ ++ [ (NotDeprecated, unrecognisedWarning "W"),+      (Deprecated,    unrecognisedWarning "fwarn-"),+      (Deprecated,    unrecognisedWarning "fno-warn-") ]+ ++ map (mkFlag turnOn  "f"         setExtensionFlag  ) fLangFlagsDeps+ ++ map (mkFlag turnOff "fno-"      unSetExtensionFlag) fLangFlagsDeps+ ++ map (mkFlag turnOn  "X"         setExtensionFlag  ) xFlagsDeps+ ++ map (mkFlag turnOff "XNo"       unSetExtensionFlag) xFlagsDeps+ ++ map (mkFlag turnOn  "X"         setLanguage       ) languageFlagsDeps+ ++ map (mkFlag turnOn  "X"         setSafeHaskell    ) safeHaskellFlagsDeps+ ++ [ make_dep_flag defFlag "XGenerics"+        (NoArg $ return ())+                  ("it does nothing; look into -XDefaultSignatures " +++                   "and -XDeriveGeneric for generic programming support.")+    , make_dep_flag defFlag "XNoGenerics"+        (NoArg $ return ())+               ("it does nothing; look into -XDefaultSignatures and " +++                  "-XDeriveGeneric for generic programming support.") ]++-- | This is where we handle unrecognised warning flags. We only issue a warning+-- if -Wunrecognised-warning-flags is set. See Trac #11429 for context.+unrecognisedWarning :: String -> Flag (CmdLineP DynFlags)+unrecognisedWarning prefix = defHiddenFlag prefix (Prefix action)+  where+    action :: String -> EwM (CmdLineP DynFlags) ()+    action flag = do+      f <- wopt Opt_WarnUnrecognisedWarningFlags <$> liftEwM getCmdLineState+      when f $ addWarn $ "unrecognised warning flag: -" ++ prefix ++ flag++-- See Note [Supporting CLI completion]+package_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))]+package_flags_deps = [+        ------- Packages ----------------------------------------------------+    make_ord_flag defFlag "package-db"+      (HasArg (addPkgConfRef . PkgConfFile))+  , make_ord_flag defFlag "clear-package-db"      (NoArg clearPkgConf)+  , make_ord_flag defFlag "no-global-package-db"  (NoArg removeGlobalPkgConf)+  , make_ord_flag defFlag "no-user-package-db"    (NoArg removeUserPkgConf)+  , make_ord_flag defFlag "global-package-db"+      (NoArg (addPkgConfRef GlobalPkgConf))+  , make_ord_flag defFlag "user-package-db"+      (NoArg (addPkgConfRef UserPkgConf))+    -- backwards compat with GHC<=7.4 :+  , make_dep_flag defFlag "package-conf"+      (HasArg $ addPkgConfRef . PkgConfFile) "Use -package-db instead"+  , make_dep_flag defFlag "no-user-package-conf"+      (NoArg removeUserPkgConf)              "Use -no-user-package-db instead"+  , make_ord_flag defGhcFlag "package-name"       (HasArg $ \name -> do+                                      upd (setUnitId name))+                                      -- TODO: Since we JUST deprecated+                                      -- -this-package-key, let's keep this+                                      -- undeprecated for another cycle.+                                      -- Deprecate this eventually.+                                      -- deprecate "Use -this-unit-id instead")+  , make_dep_flag defGhcFlag "this-package-key"   (HasArg $ upd . setUnitId)+                                                  "Use -this-unit-id instead"+  , make_ord_flag defGhcFlag "this-unit-id"       (hasArg setUnitId)+  , make_ord_flag defFlag "package"               (HasArg exposePackage)+  , make_ord_flag defFlag "plugin-package-id"     (HasArg exposePluginPackageId)+  , make_ord_flag defFlag "plugin-package"        (HasArg exposePluginPackage)+  , make_ord_flag defFlag "package-id"            (HasArg exposePackageId)+  , make_ord_flag defFlag "hide-package"          (HasArg hidePackage)+  , make_ord_flag defFlag "hide-all-packages"+      (NoArg (setGeneralFlag Opt_HideAllPackages))+  , make_ord_flag defFlag "hide-all-plugin-packages"+      (NoArg (setGeneralFlag Opt_HideAllPluginPackages))+  , make_ord_flag defFlag "package-env"           (HasArg setPackageEnv)+  , make_ord_flag defFlag "ignore-package"        (HasArg ignorePackage)+  , make_dep_flag defFlag "syslib" (HasArg exposePackage) "Use -package instead"+  , make_ord_flag defFlag "distrust-all-packages"+      (NoArg (setGeneralFlag Opt_DistrustAllPackages))+  , make_ord_flag defFlag "trust"                 (HasArg trustPackage)+  , make_ord_flag defFlag "distrust"              (HasArg distrustPackage)+  ]+  where+    setPackageEnv env = upd $ \s -> s { packageEnv = Just env }++-- | Make a list of flags for shell completion.+-- Filter all available flags into two groups, for interactive GHC vs all other.+flagsForCompletion :: Bool -> [String]+flagsForCompletion isInteractive+    = [ '-':flagName flag+      | flag <- flagsAll+      , modeFilter (flagGhcMode flag)+      ]+    where+      modeFilter AllModes = True+      modeFilter OnlyGhci = isInteractive+      modeFilter OnlyGhc = not isInteractive+      modeFilter HiddenFlag = False++type TurnOnFlag = Bool   -- True  <=> we are turning the flag on+                         -- False <=> we are turning the flag off+turnOn  :: TurnOnFlag; turnOn  = True+turnOff :: TurnOnFlag; turnOff = False++data FlagSpec flag+   = FlagSpec+       { flagSpecName :: String   -- ^ Flag in string form+       , flagSpecFlag :: flag     -- ^ Flag in internal form+       , flagSpecAction :: (TurnOnFlag -> DynP ())+           -- ^ Extra action to run when the flag is found+           -- Typically, emit a warning or error+       , flagSpecGhcMode :: GhcFlagMode+           -- ^ In which ghc mode the flag has effect+       }++-- | Define a new flag.+flagSpec :: String -> flag -> (Deprecation, FlagSpec flag)+flagSpec name flag = flagSpec' name flag nop++-- | Define a new flag with an effect.+flagSpec' :: String -> flag -> (TurnOnFlag -> DynP ())+          -> (Deprecation, FlagSpec flag)+flagSpec' name flag act = (NotDeprecated, FlagSpec name flag act AllModes)++-- | Define a new deprecated flag with an effect.+depFlagSpecOp :: String -> flag -> (TurnOnFlag -> DynP ()) -> String+            -> (Deprecation, FlagSpec flag)+depFlagSpecOp name flag act dep =+    (Deprecated, snd (flagSpec' name flag (\f -> act f >> deprecate dep)))++-- | Define a new deprecated flag.+depFlagSpec :: String -> flag -> String+            -> (Deprecation, FlagSpec flag)+depFlagSpec name flag dep = depFlagSpecOp name flag nop dep++-- | Define a new deprecated flag with an effect where the deprecation message+-- depends on the flag value+depFlagSpecOp' :: String+             -> flag+             -> (TurnOnFlag -> DynP ())+             -> (TurnOnFlag -> String)+             -> (Deprecation, FlagSpec flag)+depFlagSpecOp' name flag act dep =+    (Deprecated, FlagSpec name flag (\f -> act f >> (deprecate $ dep f))+                                                                       AllModes)++-- | Define a new deprecated flag where the deprecation message+-- depends on the flag value+depFlagSpec' :: String+             -> flag+             -> (TurnOnFlag -> String)+             -> (Deprecation, FlagSpec flag)+depFlagSpec' name flag dep = depFlagSpecOp' name flag nop dep+++-- | Define a new deprecated flag where the deprecation message+-- is shown depending on the flag value+depFlagSpecCond :: String+                -> flag+                -> (TurnOnFlag -> Bool)+                -> String+                -> (Deprecation, FlagSpec flag)+depFlagSpecCond name flag cond dep =+    (Deprecated, FlagSpec name flag (\f -> when (cond f) $ deprecate dep)+                                                                       AllModes)++-- | Define a new flag for GHCi.+flagGhciSpec :: String -> flag -> (Deprecation, FlagSpec flag)+flagGhciSpec name flag = flagGhciSpec' name flag nop++-- | Define a new flag for GHCi with an effect.+flagGhciSpec' :: String -> flag -> (TurnOnFlag -> DynP ())+              -> (Deprecation, FlagSpec flag)+flagGhciSpec' name flag act = (NotDeprecated, FlagSpec name flag act OnlyGhci)++-- | Define a new flag invisible to CLI completion.+flagHiddenSpec :: String -> flag -> (Deprecation, FlagSpec flag)+flagHiddenSpec name flag = flagHiddenSpec' name flag nop++-- | Define a new flag invisible to CLI completion with an effect.+flagHiddenSpec' :: String -> flag -> (TurnOnFlag -> DynP ())+                -> (Deprecation, FlagSpec flag)+flagHiddenSpec' name flag act = (NotDeprecated, FlagSpec name flag act+                                                                     HiddenFlag)++-- | Hide a 'FlagSpec' from being displayed in @--show-options@.+--+-- This is for example useful for flags that are obsolete, but should not+-- (yet) be deprecated for compatibility reasons.+hideFlag :: (Deprecation, FlagSpec a) -> (Deprecation, FlagSpec a)+hideFlag (dep, fs) = (dep, fs { flagSpecGhcMode = HiddenFlag })++mkFlag :: TurnOnFlag            -- ^ True <=> it should be turned on+       -> String                -- ^ The flag prefix+       -> (flag -> DynP ())     -- ^ What to do when the flag is found+       -> (Deprecation, FlagSpec flag)  -- ^ Specification of+                                        -- this particular flag+       -> (Deprecation, Flag (CmdLineP DynFlags))+mkFlag turn_on flagPrefix f (dep, (FlagSpec name flag extra_action mode))+    = (dep,+       Flag (flagPrefix ++ name) (NoArg (f flag >> extra_action turn_on)) mode)++deprecatedForExtension :: String -> TurnOnFlag -> String+deprecatedForExtension lang turn_on+    = "use -X" ++ flag +++      " or pragma {-# LANGUAGE " ++ flag ++ " #-} instead"+    where+      flag | turn_on   = lang+           | otherwise = "No" ++ lang++useInstead :: String -> TurnOnFlag -> String+useInstead flag turn_on+  = "Use -f" ++ no ++ flag ++ " instead"+  where+    no = if turn_on then "" else "no-"++nop :: TurnOnFlag -> DynP ()+nop _ = return ()++-- | Find the 'FlagSpec' for a 'WarningFlag'.+flagSpecOf :: WarningFlag -> Maybe (FlagSpec WarningFlag)+flagSpecOf flag = listToMaybe $ filter check wWarningFlags+  where+    check fs = flagSpecFlag fs == flag++-- | These @-W\<blah\>@ flags can all be reversed with @-Wno-\<blah\>@+wWarningFlags :: [FlagSpec WarningFlag]+wWarningFlags = map snd (sortBy (comparing fst) wWarningFlagsDeps)++wWarningFlagsDeps :: [(Deprecation, FlagSpec WarningFlag)]+wWarningFlagsDeps = [+-- See Note [Updating flag description in the User's Guide]+-- See Note [Supporting CLI completion]+-- Please keep the list of flags below sorted alphabetically+  flagSpec "alternative-layout-rule-transitional"+                                      Opt_WarnAlternativeLayoutRuleTransitional,+  depFlagSpec "amp"                      Opt_WarnAMP+    "it has no effect",+  depFlagSpec "auto-orphans"             Opt_WarnAutoOrphans+    "it has no effect",+  flagSpec "cpp-undef"                   Opt_WarnCPPUndef,+  flagSpec "unbanged-strict-patterns"    Opt_WarnUnbangedStrictPatterns,+  flagSpec "deferred-type-errors"        Opt_WarnDeferredTypeErrors,+  flagSpec "deferred-out-of-scope-variables"+                                         Opt_WarnDeferredOutOfScopeVariables,+  flagSpec "deprecations"                Opt_WarnWarningsDeprecations,+  flagSpec "deprecated-flags"            Opt_WarnDeprecatedFlags,+  flagSpec "deriving-typeable"           Opt_WarnDerivingTypeable,+  flagSpec "dodgy-exports"               Opt_WarnDodgyExports,+  flagSpec "dodgy-foreign-imports"       Opt_WarnDodgyForeignImports,+  flagSpec "dodgy-imports"               Opt_WarnDodgyImports,+  flagSpec "empty-enumerations"          Opt_WarnEmptyEnumerations,+  depFlagSpec "duplicate-constraints"    Opt_WarnDuplicateConstraints+    "it is subsumed by -Wredundant-constraints",+  flagSpec "redundant-constraints"       Opt_WarnRedundantConstraints,+  flagSpec "duplicate-exports"           Opt_WarnDuplicateExports,+  flagSpec "hi-shadowing"                Opt_WarnHiShadows,+  flagSpec "implicit-prelude"            Opt_WarnImplicitPrelude,+  flagSpec "incomplete-patterns"         Opt_WarnIncompletePatterns,+  flagSpec "incomplete-record-updates"   Opt_WarnIncompletePatternsRecUpd,+  flagSpec "incomplete-uni-patterns"     Opt_WarnIncompleteUniPatterns,+  flagSpec "inline-rule-shadowing"       Opt_WarnInlineRuleShadowing,+  flagSpec "identities"                  Opt_WarnIdentities,+  flagSpec "missing-fields"              Opt_WarnMissingFields,+  flagSpec "missing-import-lists"        Opt_WarnMissingImportList,+  depFlagSpec "missing-local-sigs"       Opt_WarnMissingLocalSignatures+    "it is replaced by -Wmissing-local-signatures",+  flagSpec "missing-local-signatures"    Opt_WarnMissingLocalSignatures,+  flagSpec "missing-methods"             Opt_WarnMissingMethods,+  flagSpec "missing-monadfail-instances" Opt_WarnMissingMonadFailInstances,+  flagSpec "semigroup"                   Opt_WarnSemigroup,+  flagSpec "missing-signatures"          Opt_WarnMissingSignatures,+  depFlagSpec "missing-exported-sigs"    Opt_WarnMissingExportedSignatures+    "it is replaced by -Wmissing-exported-signatures",+  flagSpec "missing-exported-signatures" Opt_WarnMissingExportedSignatures,+  flagSpec "monomorphism-restriction"    Opt_WarnMonomorphism,+  flagSpec "name-shadowing"              Opt_WarnNameShadowing,+  flagSpec "noncanonical-monad-instances"+                                         Opt_WarnNonCanonicalMonadInstances,+  flagSpec "noncanonical-monadfail-instances"+                                         Opt_WarnNonCanonicalMonadFailInstances,+  flagSpec "noncanonical-monoid-instances"+                                         Opt_WarnNonCanonicalMonoidInstances,+  flagSpec "orphans"                     Opt_WarnOrphans,+  flagSpec "overflowed-literals"         Opt_WarnOverflowedLiterals,+  flagSpec "overlapping-patterns"        Opt_WarnOverlappingPatterns,+  flagSpec "missed-specialisations"      Opt_WarnMissedSpecs,+  flagSpec "missed-specializations"      Opt_WarnMissedSpecs,+  flagSpec "all-missed-specialisations"  Opt_WarnAllMissedSpecs,+  flagSpec "all-missed-specializations"  Opt_WarnAllMissedSpecs,+  flagSpec' "safe"                       Opt_WarnSafe setWarnSafe,+  flagSpec "trustworthy-safe"            Opt_WarnTrustworthySafe,+  flagSpec "tabs"                        Opt_WarnTabs,+  flagSpec "type-defaults"               Opt_WarnTypeDefaults,+  flagSpec "typed-holes"                 Opt_WarnTypedHoles,+  flagSpec "partial-type-signatures"     Opt_WarnPartialTypeSignatures,+  flagSpec "unrecognised-pragmas"        Opt_WarnUnrecognisedPragmas,+  flagSpec' "unsafe"                     Opt_WarnUnsafe setWarnUnsafe,+  flagSpec "unsupported-calling-conventions"+                                         Opt_WarnUnsupportedCallingConventions,+  flagSpec "unsupported-llvm-version"    Opt_WarnUnsupportedLlvmVersion,+  flagSpec "unticked-promoted-constructors"+                                         Opt_WarnUntickedPromotedConstructors,+  flagSpec "unused-do-bind"              Opt_WarnUnusedDoBind,+  flagSpec "unused-foralls"              Opt_WarnUnusedForalls,+  flagSpec "unused-imports"              Opt_WarnUnusedImports,+  flagSpec "unused-local-binds"          Opt_WarnUnusedLocalBinds,+  flagSpec "unused-matches"              Opt_WarnUnusedMatches,+  flagSpec "unused-pattern-binds"        Opt_WarnUnusedPatternBinds,+  flagSpec "unused-top-binds"            Opt_WarnUnusedTopBinds,+  flagSpec "unused-type-patterns"        Opt_WarnUnusedTypePatterns,+  flagSpec "warnings-deprecations"       Opt_WarnWarningsDeprecations,+  flagSpec "wrong-do-bind"               Opt_WarnWrongDoBind,+  flagSpec "missing-pattern-synonym-signatures"+                                    Opt_WarnMissingPatternSynonymSignatures,+  flagSpec "simplifiable-class-constraints" Opt_WarnSimplifiableClassConstraints,+  flagSpec "missing-home-modules"        Opt_WarnMissingHomeModules,+  flagSpec "unrecognised-warning-flags"  Opt_WarnUnrecognisedWarningFlags ]++-- | These @-\<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 "suppress-ticks" (not turn_on)),+  flagSpec "suppress-ticks"             Opt_SuppressTicks,+  flagSpec "suppress-coercions"         Opt_SuppressCoercions,+  flagSpec "suppress-idinfo"            Opt_SuppressIdInfo,+  flagSpec "suppress-unfoldings"        Opt_SuppressUnfoldings,+  flagSpec "suppress-module-prefixes"   Opt_SuppressModulePrefixes,+  flagSpec "suppress-type-applications" Opt_SuppressTypeApplications,+  flagSpec "suppress-type-signatures"   Opt_SuppressTypeSignatures,+  flagSpec "suppress-uniques"           Opt_SuppressUniques,+  flagSpec "suppress-var-kinds"         Opt_SuppressVarKinds]++-- | These @-f\<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+  flagGhciSpec "break-on-error"               Opt_BreakOnError,+  flagGhciSpec "break-on-exception"           Opt_BreakOnException,+  flagSpec "building-cabal-package"           Opt_BuildingCabalPackage,+  flagSpec "call-arity"                       Opt_CallArity,+  flagSpec "case-merge"                       Opt_CaseMerge,+  flagSpec "case-folding"                     Opt_CaseFolding,+  flagSpec "cmm-elim-common-blocks"           Opt_CmmElimCommonBlocks,+  flagSpec "cmm-sink"                         Opt_CmmSink,+  flagSpec "cse"                              Opt_CSE,+  flagSpec "stg-cse"                          Opt_StgCSE,+  flagSpec "cpr-anal"                         Opt_CprAnal,+  flagSpec "defer-type-errors"                Opt_DeferTypeErrors,+  flagSpec "defer-typed-holes"                Opt_DeferTypedHoles,+  flagSpec "defer-out-of-scope-variables"     Opt_DeferOutOfScopeVariables,+  flagSpec "diagnostics-show-caret"           Opt_DiagnosticsShowCaret,+  flagSpec "dicts-cheap"                      Opt_DictsCheap,+  flagSpec "dicts-strict"                     Opt_DictsStrict,+  flagSpec "dmd-tx-dict-sel"                  Opt_DmdTxDictSel,+  flagSpec "do-eta-reduction"                 Opt_DoEtaReduction,+  flagSpec "do-lambda-eta-expansion"          Opt_DoLambdaEtaExpansion,+  flagSpec "eager-blackholing"                Opt_EagerBlackHoling,+  flagSpec "embed-manifest"                   Opt_EmbedManifest,+  flagSpec "enable-rewrite-rules"             Opt_EnableRewriteRules,+  flagSpec "error-spans"                      Opt_ErrorSpans,+  flagSpec "excess-precision"                 Opt_ExcessPrecision,+  flagSpec "expose-all-unfoldings"            Opt_ExposeAllUnfoldings,+  flagSpec "external-interpreter"             Opt_ExternalInterpreter,+  flagSpec "flat-cache"                       Opt_FlatCache,+  flagSpec "float-in"                         Opt_FloatIn,+  flagSpec "force-recomp"                     Opt_ForceRecomp,+  flagSpec "full-laziness"                    Opt_FullLaziness,+  flagSpec "fun-to-thunk"                     Opt_FunToThunk,+  flagSpec "gen-manifest"                     Opt_GenManifest,+  flagSpec "ghci-history"                     Opt_GhciHistory,+  flagGhciSpec "local-ghci-history"           Opt_LocalGhciHistory,+  flagSpec "ghci-sandbox"                     Opt_GhciSandbox,+  flagSpec "helpful-errors"                   Opt_HelpfulErrors,+  flagSpec "hpc"                              Opt_Hpc,+  flagSpec "ignore-asserts"                   Opt_IgnoreAsserts,+  flagSpec "ignore-interface-pragmas"         Opt_IgnoreInterfacePragmas,+  flagGhciSpec "implicit-import-qualified"    Opt_ImplicitImportQualified,+  flagSpec "irrefutable-tuples"               Opt_IrrefutableTuples,+  flagSpec "kill-absence"                     Opt_KillAbsence,+  flagSpec "kill-one-shot"                    Opt_KillOneShot,+  flagSpec "late-dmd-anal"                    Opt_LateDmdAnal,+  flagSpec "liberate-case"                    Opt_LiberateCase,+  flagHiddenSpec "llvm-pass-vectors-in-regs"  Opt_LlvmPassVectorsInRegisters,+  flagHiddenSpec "llvm-tbaa"                  Opt_LlvmTBAA,+  flagHiddenSpec "llvm-fill-undef-with-garbage" Opt_LlvmFillUndefWithGarbage,+  flagSpec "loopification"                    Opt_Loopification,+  flagSpec "omit-interface-pragmas"           Opt_OmitInterfacePragmas,+  flagSpec "omit-yields"                      Opt_OmitYields,+  flagSpec "optimal-applicative-do"           Opt_OptimalApplicativeDo,+  flagSpec "pedantic-bottoms"                 Opt_PedanticBottoms,+  flagSpec "pre-inlining"                     Opt_SimplPreInlining,+  flagGhciSpec "print-bind-contents"          Opt_PrintBindContents,+  flagGhciSpec "print-bind-result"            Opt_PrintBindResult,+  flagGhciSpec "print-evld-with-show"         Opt_PrintEvldWithShow,+  flagSpec "print-explicit-foralls"           Opt_PrintExplicitForalls,+  flagSpec "print-explicit-kinds"             Opt_PrintExplicitKinds,+  flagSpec "print-explicit-coercions"         Opt_PrintExplicitCoercions,+  flagSpec "print-explicit-runtime-reps"      Opt_PrintExplicitRuntimeReps,+  flagSpec "print-equality-relations"         Opt_PrintEqualityRelations,+  flagSpec "print-unicode-syntax"             Opt_PrintUnicodeSyntax,+  flagSpec "print-expanded-synonyms"          Opt_PrintExpandedSynonyms,+  flagSpec "print-potential-instances"        Opt_PrintPotentialInstances,+  flagSpec "print-typechecker-elaboration"    Opt_PrintTypecheckerElaboration,+  flagSpec "prof-cafs"                        Opt_AutoSccsOnIndividualCafs,+  flagSpec "prof-count-entries"               Opt_ProfCountEntries,+  flagSpec "regs-graph"                       Opt_RegsGraph,+  flagSpec "regs-iterative"                   Opt_RegsIterative,+  depFlagSpec' "rewrite-rules"                Opt_EnableRewriteRules+   (useInstead "enable-rewrite-rules"),+  flagSpec "shared-implib"                    Opt_SharedImplib,+  flagSpec "spec-constr"                      Opt_SpecConstr,+  flagSpec "spec-constr-keen"                 Opt_SpecConstrKeen,+  flagSpec "specialise"                       Opt_Specialise,+  flagSpec "specialize"                       Opt_Specialise,+  flagSpec "specialise-aggressively"          Opt_SpecialiseAggressively,+  flagSpec "specialize-aggressively"          Opt_SpecialiseAggressively,+  flagSpec "cross-module-specialise"          Opt_CrossModuleSpecialise,+  flagSpec "cross-module-specialize"          Opt_CrossModuleSpecialise,+  flagSpec "static-argument-transformation"   Opt_StaticArgumentTransformation,+  flagSpec "strictness"                       Opt_Strictness,+  flagSpec "use-rpaths"                       Opt_RPath,+  flagSpec "write-interface"                  Opt_WriteInterface,+  flagSpec "unbox-small-strict-fields"        Opt_UnboxSmallStrictFields,+  flagSpec "unbox-strict-fields"              Opt_UnboxStrictFields,+  flagSpec "vectorisation-avoidance"          Opt_VectorisationAvoidance,+  flagSpec "vectorise"                        Opt_Vectorise,+  flagSpec "version-macros"                   Opt_VersionMacros,+  flagSpec "worker-wrapper"                   Opt_WorkerWrapper,+  flagSpec "solve-constant-dicts"             Opt_SolveConstantDicts,+  flagSpec "show-warning-groups"              Opt_ShowWarnGroups,+  flagSpec "hide-source-paths"                Opt_HideSourcePaths,+  flagSpec "show-hole-constraints"            Opt_ShowHoleConstraints,+  flagSpec "whole-archive-hs-libs"            Opt_WholeArchiveHsLibs+  ]++-- | 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' "mono-pat-binds"                 LangExt.MonoPatBinds+    (deprecatedForExtension "MonoPatBinds"),+  depFlagSpec' "extended-default-rules"         LangExt.ExtendedDefaultRules+    (deprecatedForExtension "ExtendedDefaultRules"),+  depFlagSpec' "implicit-params"                LangExt.ImplicitParams+    (deprecatedForExtension "ImplicitParams"),+  depFlagSpec' "scoped-type-variables"          LangExt.ScopedTypeVariables+    (deprecatedForExtension "ScopedTypeVariables"),+  depFlagSpec' "parr"                           LangExt.ParallelArrays+    (deprecatedForExtension "ParallelArrays"),+  depFlagSpec' "PArr"                           LangExt.ParallelArrays+    (deprecatedForExtension "ParallelArrays"),+  depFlagSpec' "allow-overlapping-instances"    LangExt.OverlappingInstances+    (deprecatedForExtension "OverlappingInstances"),+  depFlagSpec' "allow-undecidable-instances"    LangExt.UndecidableInstances+    (deprecatedForExtension "UndecidableInstances"),+  depFlagSpec' "allow-incoherent-instances"     LangExt.IncoherentInstances+    (deprecatedForExtension "IncoherentInstances")+  ]++supportedLanguages :: [String]+supportedLanguages = map (flagSpecName . snd) languageFlagsDeps++supportedLanguageOverlays :: [String]+supportedLanguageOverlays = map (flagSpecName . snd) safeHaskellFlagsDeps++supportedExtensions :: [String]+supportedExtensions = concatMap toFlagSpecNamePair xFlags+  where+    toFlagSpecNamePair flg+      | otherwise = [name, noName]+      where+        noName = "No" ++ name+        name = flagSpecName flg++supportedLanguagesAndExtensions :: [String]+supportedLanguagesAndExtensions =+    supportedLanguages ++ supportedLanguageOverlays ++ supportedExtensions++-- | These -X<blah> flags cannot be reversed with -XNo<blah>+languageFlagsDeps :: [(Deprecation, FlagSpec Language)]+languageFlagsDeps = [+  flagSpec "Haskell98"   Haskell98,+  flagSpec "Haskell2010" Haskell2010+  ]++-- | 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,+  flagSpec "AutoDeriveTypeable"               LangExt.AutoDeriveTypeable,+  flagSpec "BangPatterns"                     LangExt.BangPatterns,+  flagSpec "BinaryLiterals"                   LangExt.BinaryLiterals,+  flagSpec "CApiFFI"                          LangExt.CApiFFI,+  flagSpec "CPP"                              LangExt.Cpp,+  flagSpec "ConstrainedClassMethods"          LangExt.ConstrainedClassMethods,+  flagSpec "ConstraintKinds"                  LangExt.ConstraintKinds,+  flagSpec "DataKinds"                        LangExt.DataKinds,+  depFlagSpecCond "DatatypeContexts"          LangExt.DatatypeContexts+    id+         ("It was widely considered a misfeature, " +++                     "and has been removed from the Haskell language."),+  flagSpec "DefaultSignatures"                LangExt.DefaultSignatures,+  flagSpec "DeriveAnyClass"                   LangExt.DeriveAnyClass,+  flagSpec "DeriveDataTypeable"               LangExt.DeriveDataTypeable,+  flagSpec "DeriveFoldable"                   LangExt.DeriveFoldable,+  flagSpec "DeriveFunctor"                    LangExt.DeriveFunctor,+  flagSpec "DeriveGeneric"                    LangExt.DeriveGeneric,+  flagSpec "DeriveLift"                       LangExt.DeriveLift,+  flagSpec "DeriveTraversable"                LangExt.DeriveTraversable,+  flagSpec "DerivingStrategies"               LangExt.DerivingStrategies,+  flagSpec "DisambiguateRecordFields"         LangExt.DisambiguateRecordFields,+  flagSpec "DoAndIfThenElse"                  LangExt.DoAndIfThenElse,+  depFlagSpec' "DoRec"                        LangExt.RecursiveDo+    (deprecatedForExtension "RecursiveDo"),+  flagSpec "DuplicateRecordFields"            LangExt.DuplicateRecordFields,+  flagSpec "EmptyCase"                        LangExt.EmptyCase,+  flagSpec "EmptyDataDecls"                   LangExt.EmptyDataDecls,+  flagSpec "ExistentialQuantification"        LangExt.ExistentialQuantification,+  flagSpec "ExplicitForAll"                   LangExt.ExplicitForAll,+  flagSpec "ExplicitNamespaces"               LangExt.ExplicitNamespaces,+  flagSpec "ExtendedDefaultRules"             LangExt.ExtendedDefaultRules,+  flagSpec "FlexibleContexts"                 LangExt.FlexibleContexts,+  flagSpec "FlexibleInstances"                LangExt.FlexibleInstances,+  flagSpec "ForeignFunctionInterface"         LangExt.ForeignFunctionInterface,+  flagSpec "FunctionalDependencies"           LangExt.FunctionalDependencies,+  flagSpec "GADTSyntax"                       LangExt.GADTSyntax,+  flagSpec "GADTs"                            LangExt.GADTs,+  flagSpec "GHCForeignImportPrim"             LangExt.GHCForeignImportPrim,+  flagSpec' "GeneralizedNewtypeDeriving"      LangExt.GeneralizedNewtypeDeriving+                                              setGenDeriving,+  flagSpec "ImplicitParams"                   LangExt.ImplicitParams,+  flagSpec "ImplicitPrelude"                  LangExt.ImplicitPrelude,+  flagSpec "ImpredicativeTypes"               LangExt.ImpredicativeTypes,+  flagSpec' "IncoherentInstances"             LangExt.IncoherentInstances+                                              setIncoherentInsts,+  flagSpec "TypeFamilyDependencies"           LangExt.TypeFamilyDependencies,+  flagSpec "InstanceSigs"                     LangExt.InstanceSigs,+  flagSpec "ApplicativeDo"                    LangExt.ApplicativeDo,+  flagSpec "InterruptibleFFI"                 LangExt.InterruptibleFFI,+  flagSpec "JavaScriptFFI"                    LangExt.JavaScriptFFI,+  flagSpec "KindSignatures"                   LangExt.KindSignatures,+  flagSpec "LambdaCase"                       LangExt.LambdaCase,+  flagSpec "LiberalTypeSynonyms"              LangExt.LiberalTypeSynonyms,+  flagSpec "MagicHash"                        LangExt.MagicHash,+  flagSpec "MonadComprehensions"              LangExt.MonadComprehensions,+  flagSpec "MonadFailDesugaring"              LangExt.MonadFailDesugaring,+  flagSpec "MonoLocalBinds"                   LangExt.MonoLocalBinds,+  depFlagSpecCond "MonoPatBinds"              LangExt.MonoPatBinds+    id+         "Experimental feature now removed; has no effect",+  flagSpec "MonomorphismRestriction"          LangExt.MonomorphismRestriction,+  flagSpec "MultiParamTypeClasses"            LangExt.MultiParamTypeClasses,+  flagSpec "MultiWayIf"                       LangExt.MultiWayIf,+  flagSpec "NPlusKPatterns"                   LangExt.NPlusKPatterns,+  flagSpec "NamedFieldPuns"                   LangExt.RecordPuns,+  flagSpec "NamedWildCards"                   LangExt.NamedWildCards,+  flagSpec "NegativeLiterals"                 LangExt.NegativeLiterals,+  flagSpec "NondecreasingIndentation"         LangExt.NondecreasingIndentation,+  depFlagSpec' "NullaryTypeClasses"           LangExt.NullaryTypeClasses+    (deprecatedForExtension "MultiParamTypeClasses"),+  flagSpec "NumDecimals"                      LangExt.NumDecimals,+  depFlagSpecOp "OverlappingInstances"        LangExt.OverlappingInstances+    setOverlappingInsts+    "instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS",+  flagSpec "OverloadedLabels"                 LangExt.OverloadedLabels,+  flagSpec "OverloadedLists"                  LangExt.OverloadedLists,+  flagSpec "OverloadedStrings"                LangExt.OverloadedStrings,+  flagSpec "PackageImports"                   LangExt.PackageImports,+  flagSpec "ParallelArrays"                   LangExt.ParallelArrays,+  flagSpec "ParallelListComp"                 LangExt.ParallelListComp,+  flagSpec "PartialTypeSignatures"            LangExt.PartialTypeSignatures,+  flagSpec "PatternGuards"                    LangExt.PatternGuards,+  depFlagSpec' "PatternSignatures"            LangExt.ScopedTypeVariables+    (deprecatedForExtension "ScopedTypeVariables"),+  flagSpec "PatternSynonyms"                  LangExt.PatternSynonyms,+  flagSpec "PolyKinds"                        LangExt.PolyKinds,+  flagSpec "PolymorphicComponents"            LangExt.RankNTypes,+  flagSpec "PostfixOperators"                 LangExt.PostfixOperators,+  flagSpec "QuasiQuotes"                      LangExt.QuasiQuotes,+  flagSpec "Rank2Types"                       LangExt.RankNTypes,+  flagSpec "RankNTypes"                       LangExt.RankNTypes,+  flagSpec "RebindableSyntax"                 LangExt.RebindableSyntax,+  depFlagSpec' "RecordPuns"                   LangExt.RecordPuns+    (deprecatedForExtension "NamedFieldPuns"),+  flagSpec "RecordWildCards"                  LangExt.RecordWildCards,+  flagSpec "RecursiveDo"                      LangExt.RecursiveDo,+  flagSpec "RelaxedLayout"                    LangExt.RelaxedLayout,+  depFlagSpecCond "RelaxedPolyRec"            LangExt.RelaxedPolyRec+    not+         "You can't turn off RelaxedPolyRec any more",+  flagSpec "RoleAnnotations"                  LangExt.RoleAnnotations,+  flagSpec "ScopedTypeVariables"              LangExt.ScopedTypeVariables,+  flagSpec "StandaloneDeriving"               LangExt.StandaloneDeriving,+  flagSpec "StaticPointers"                   LangExt.StaticPointers,+  flagSpec "Strict"                           LangExt.Strict,+  flagSpec "StrictData"                       LangExt.StrictData,+  flagSpec' "TemplateHaskell"                 LangExt.TemplateHaskell+                                              checkTemplateHaskellOk,+  flagSpec "TemplateHaskellQuotes"            LangExt.TemplateHaskellQuotes,+  flagSpec "TraditionalRecordSyntax"          LangExt.TraditionalRecordSyntax,+  flagSpec "TransformListComp"                LangExt.TransformListComp,+  flagSpec "TupleSections"                    LangExt.TupleSections,+  flagSpec "TypeApplications"                 LangExt.TypeApplications,+  flagSpec "TypeInType"                       LangExt.TypeInType,+  flagSpec "TypeFamilies"                     LangExt.TypeFamilies,+  flagSpec "TypeOperators"                    LangExt.TypeOperators,+  flagSpec "TypeSynonymInstances"             LangExt.TypeSynonymInstances,+  flagSpec "UnboxedTuples"                    LangExt.UnboxedTuples,+  flagSpec "UnboxedSums"                      LangExt.UnboxedSums,+  flagSpec "UndecidableInstances"             LangExt.UndecidableInstances,+  flagSpec "UndecidableSuperClasses"          LangExt.UndecidableSuperClasses,+  flagSpec "UnicodeSyntax"                    LangExt.UnicodeSyntax,+  flagSpec "UnliftedFFITypes"                 LangExt.UnliftedFFITypes,+  flagSpec "ViewPatterns"                     LangExt.ViewPatterns+  ]++defaultFlags :: Settings -> [GeneralFlag]+defaultFlags settings+-- See Note [Updating flag description in the User's Guide]+  = [ Opt_AutoLinkPackages,+      Opt_DiagnosticsShowCaret,+      Opt_EmbedManifest,+      Opt_FlatCache,+      Opt_GenManifest,+      Opt_GhciHistory,+      Opt_GhciSandbox,+      Opt_HelpfulErrors,+      Opt_KeepHiFiles,+      Opt_KeepOFiles,+      Opt_OmitYields,+      Opt_PrintBindContents,+      Opt_ProfCountEntries,+      Opt_RPath,+      Opt_SharedImplib,+      Opt_SimplPreInlining,+      Opt_VersionMacros+    ]++    ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]+             -- The default -O0 options++    ++ default_PIC platform++    ++ concatMap (wayGeneralFlags platform) (defaultWays settings)++    where platform = sTargetPlatform settings++default_PIC :: Platform -> [GeneralFlag]+default_PIC platform =+  case (platformOS platform, platformArch platform) of+    (OSDarwin, ArchX86_64) -> [Opt_PIC]+    (OSOpenBSD, ArchX86_64) -> [Opt_PIC] -- Due to PIE support in+                                         -- OpenBSD since 5.3 release+                                         -- (1 May 2013) we need to+                                         -- always generate PIC. See+                                         -- #10597 for more+                                         -- information.+    _                      -> []++-- General flags that are switched on/off when other general flags are switched+-- on+impliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)]+impliedGFlags = [(Opt_DeferTypeErrors, turnOn, Opt_DeferTypedHoles)+                ,(Opt_DeferTypeErrors, turnOn, Opt_DeferOutOfScopeVariables)+                ,(Opt_Strictness, turnOn, Opt_WorkerWrapper)+                ]++-- General flags that are switched on/off when other general flags are switched+-- off+impliedOffGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)]+impliedOffGFlags = [(Opt_Strictness, turnOff, Opt_WorkerWrapper)]++impliedXFlags :: [(LangExt.Extension, TurnOnFlag, LangExt.Extension)]+impliedXFlags+-- See Note [Updating flag description in the User's Guide]+  = [ (LangExt.RankNTypes,                turnOn, LangExt.ExplicitForAll)+    , (LangExt.ScopedTypeVariables,       turnOn, LangExt.ExplicitForAll)+    , (LangExt.LiberalTypeSynonyms,       turnOn, LangExt.ExplicitForAll)+    , (LangExt.ExistentialQuantification, turnOn, LangExt.ExplicitForAll)+    , (LangExt.FlexibleInstances,         turnOn, LangExt.TypeSynonymInstances)+    , (LangExt.FunctionalDependencies,    turnOn, LangExt.MultiParamTypeClasses)+    , (LangExt.MultiParamTypeClasses,     turnOn, LangExt.ConstrainedClassMethods)  -- c.f. Trac #7854+    , (LangExt.TypeFamilyDependencies,    turnOn, LangExt.TypeFamilies)++    , (LangExt.RebindableSyntax, turnOff, LangExt.ImplicitPrelude)      -- NB: turn off!++    , (LangExt.GADTs,            turnOn, LangExt.GADTSyntax)+    , (LangExt.GADTs,            turnOn, LangExt.MonoLocalBinds)+    , (LangExt.TypeFamilies,     turnOn, LangExt.MonoLocalBinds)++    , (LangExt.TypeFamilies,     turnOn, LangExt.KindSignatures)  -- Type families use kind signatures+    , (LangExt.PolyKinds,        turnOn, LangExt.KindSignatures)  -- Ditto polymorphic kinds+    , (LangExt.TypeInType,       turnOn, LangExt.DataKinds)+    , (LangExt.TypeInType,       turnOn, LangExt.PolyKinds)+    , (LangExt.TypeInType,       turnOn, LangExt.KindSignatures)++    -- AutoDeriveTypeable is not very useful without DeriveDataTypeable+    , (LangExt.AutoDeriveTypeable, turnOn, LangExt.DeriveDataTypeable)++    -- We turn this on so that we can export associated type+    -- type synonyms in subordinates (e.g. MyClass(type AssocType))+    , (LangExt.TypeFamilies,     turnOn, LangExt.ExplicitNamespaces)+    , (LangExt.TypeOperators, turnOn, LangExt.ExplicitNamespaces)++    , (LangExt.ImpredicativeTypes,  turnOn, LangExt.RankNTypes)++        -- Record wild-cards implies field disambiguation+        -- Otherwise if you write (C {..}) you may well get+        -- stuff like " 'a' not in scope ", which is a bit silly+        -- if the compiler has just filled in field 'a' of constructor 'C'+    , (LangExt.RecordWildCards,     turnOn, LangExt.DisambiguateRecordFields)++    , (LangExt.ParallelArrays, turnOn, LangExt.ParallelListComp)++    , (LangExt.JavaScriptFFI, turnOn, LangExt.InterruptibleFFI)++    , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFunctor)+    , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFoldable)++    -- Duplicate record fields require field disambiguation+    , (LangExt.DuplicateRecordFields, turnOn, LangExt.DisambiguateRecordFields)++    , (LangExt.TemplateHaskell, turnOn, LangExt.TemplateHaskellQuotes)+    , (LangExt.Strict, turnOn, LangExt.StrictData)+  ]++-- Note [Documenting optimisation flags]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- If you change the list of flags enabled for particular optimisation levels+-- please remember to update the User's Guide. The relevant files are:+--+--  * utils/mkUserGuidePart/Options/+--  * docs/users_guide/using.rst+--+-- The first contains the Flag Refrence section, which breifly lists all+-- available flags. The second contains a detailed description of the+-- flags. Both places should contain information whether a flag is implied by+-- -O0, -O or -O2.++optLevelFlags :: [([Int], GeneralFlag)]+optLevelFlags -- see Note [Documenting optimisation flags]+  = [ ([0,1,2], Opt_DoLambdaEtaExpansion)+    , ([0,1,2], Opt_DoEtaReduction)       -- See Note [Eta-reduction in -O0]+    , ([0,1,2], Opt_DmdTxDictSel)+    , ([0,1,2], Opt_LlvmTBAA)+    , ([0,1,2], Opt_VectorisationAvoidance)+                -- This one is important for a tiresome reason:+                -- we want to make sure that the bindings for data+                -- constructors are eta-expanded.  This is probably+                -- a good thing anyway, but it seems fragile.++    , ([0],     Opt_IgnoreInterfacePragmas)+    , ([0],     Opt_OmitInterfacePragmas)++    , ([1,2],   Opt_CallArity)+    , ([1,2],   Opt_CaseMerge)+    , ([1,2],   Opt_CaseFolding)+    , ([1,2],   Opt_CmmElimCommonBlocks)+    , ([1,2],   Opt_CmmSink)+    , ([1,2],   Opt_CSE)+    , ([1,2],   Opt_StgCSE)+    , ([1,2],   Opt_EnableRewriteRules)  -- Off for -O0; see Note [Scoping for Builtin rules]+                                         --              in PrelRules+    , ([1,2],   Opt_FloatIn)+    , ([1,2],   Opt_FullLaziness)+    , ([1,2],   Opt_IgnoreAsserts)+    , ([1,2],   Opt_Loopification)+    , ([1,2],   Opt_Specialise)+    , ([1,2],   Opt_CrossModuleSpecialise)+    , ([1,2],   Opt_Strictness)+    , ([1,2],   Opt_UnboxSmallStrictFields)+    , ([1,2],   Opt_CprAnal)+    , ([1,2],   Opt_WorkerWrapper)+    , ([1,2],   Opt_SolveConstantDicts)++    , ([2],     Opt_LiberateCase)+    , ([2],     Opt_SpecConstr)+--  , ([2],     Opt_RegsGraph)+--   RegsGraph suffers performance regression. See #7679+--  , ([2],     Opt_StaticArgumentTransformation)+--   Static Argument Transformation needs investigation. See #9374+    ]++{- Note [Eta-reduction in -O0]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Trac #11562 showed an example which tripped an ASSERT in CoreToStg; a+function was marked as MayHaveCafRefs when in fact it obviously+didn't.  Reason was:+ * Eta reduction wasn't happening in the simplifier, but it was+   happening in CorePrep, on+        $fBla = MkDict (/\a. K a)+ * Result: rhsIsStatic told TidyPgm that $fBla might have CAF refs+   but the eta-reduced version (MkDict K) obviously doesn't+Simple solution: just let the simplifier do eta-reduction even in -O0.+After all, CorePrep does it unconditionally!  Not a big deal, but+removes an assertion failure. -}+++-- -----------------------------------------------------------------------------+-- Standard sets of warning options++-- Note [Documenting warning flags]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- If you change the list of warning enabled by default+-- please remember to update the User's Guide. The relevant file is:+--+--  * utils/mkUserGuidePart/+--  * docs/users_guide/using-warnings.rst++-- | Warning groups.+--+-- As all warnings are in the Weverything set, it is ignored when+-- displaying to the user which group a warning is in.+warningGroups :: [(String, [WarningFlag])]+warningGroups =+    [ ("compat",       minusWcompatOpts)+    , ("unused-binds", unusedBindsFlags)+    , ("default",      standardWarnings)+    , ("extra",        minusWOpts)+    , ("all",          minusWallOpts)+    , ("everything",   minusWeverythingOpts)+    ]++-- | Warning group hierarchies, where there is an explicit inclusion+-- relation.+--+-- Each inner list is a hierarchy of warning groups, ordered from+-- smallest to largest, where each group is a superset of the one+-- before it.+--+-- Separating this from 'warningGroups' allows for multiple+-- hierarchies with no inherent relation to be defined.+--+-- The special-case Weverything group is not included.+warningHierarchies :: [[String]]+warningHierarchies = hierarchies ++ map (:[]) rest+  where+    hierarchies = [["default", "extra", "all"]]+    rest = filter (`notElem` "everything" : concat hierarchies) $+           map fst warningGroups++-- | Find the smallest group in every hierarchy which a warning+-- belongs to, excluding Weverything.+smallestGroups :: WarningFlag -> [String]+smallestGroups flag = mapMaybe go warningHierarchies where+    -- Because each hierarchy is arranged from smallest to largest,+    -- the first group we find in a hierarchy which contains the flag+    -- is the smallest.+    go (group:rest) = fromMaybe (go rest) $ do+        flags <- lookup group warningGroups+        guard (flag `elem` flags)+        pure (Just group)+    go [] = Nothing++-- | Warnings enabled unless specified otherwise+standardWarnings :: [WarningFlag]+standardWarnings -- see Note [Documenting warning flags]+    = [ Opt_WarnOverlappingPatterns,+        Opt_WarnWarningsDeprecations,+        Opt_WarnDeprecatedFlags,+        Opt_WarnDeferredTypeErrors,+        Opt_WarnTypedHoles,+        Opt_WarnDeferredOutOfScopeVariables,+        Opt_WarnPartialTypeSignatures,+        Opt_WarnUnrecognisedPragmas,+        Opt_WarnDuplicateExports,+        Opt_WarnOverflowedLiterals,+        Opt_WarnEmptyEnumerations,+        Opt_WarnMissingFields,+        Opt_WarnMissingMethods,+        Opt_WarnWrongDoBind,+        Opt_WarnUnsupportedCallingConventions,+        Opt_WarnDodgyForeignImports,+        Opt_WarnInlineRuleShadowing,+        Opt_WarnAlternativeLayoutRuleTransitional,+        Opt_WarnUnsupportedLlvmVersion,+        Opt_WarnTabs,+        Opt_WarnUnrecognisedWarningFlags,+        Opt_WarnSimplifiableClassConstraints+      ]++-- | Things you get with -W+minusWOpts :: [WarningFlag]+minusWOpts+    = standardWarnings +++      [ Opt_WarnUnusedTopBinds,+        Opt_WarnUnusedLocalBinds,+        Opt_WarnUnusedPatternBinds,+        Opt_WarnUnusedMatches,+        Opt_WarnUnusedForalls,+        Opt_WarnUnusedImports,+        Opt_WarnIncompletePatterns,+        Opt_WarnDodgyExports,+        Opt_WarnDodgyImports,+        Opt_WarnUnbangedStrictPatterns+      ]++-- | Things you get with -Wall+minusWallOpts :: [WarningFlag]+minusWallOpts+    = minusWOpts +++      [ Opt_WarnTypeDefaults,+        Opt_WarnNameShadowing,+        Opt_WarnMissingSignatures,+        Opt_WarnHiShadows,+        Opt_WarnOrphans,+        Opt_WarnUnusedDoBind,+        Opt_WarnTrustworthySafe,+        Opt_WarnUntickedPromotedConstructors,+        Opt_WarnMissingPatternSynonymSignatures+      ]++-- | Things you get with -Weverything, i.e. *all* known warnings flags+minusWeverythingOpts :: [WarningFlag]+minusWeverythingOpts = [ toEnum 0 .. ]++-- | Things you get with -Wcompat.+--+-- This is intended to group together warnings that will be enabled by default+-- at some point in the future, so that library authors eager to make their+-- code future compatible to fix issues before they even generate warnings.+minusWcompatOpts :: [WarningFlag]+minusWcompatOpts+    = [ Opt_WarnMissingMonadFailInstances+      , Opt_WarnSemigroup+      , Opt_WarnNonCanonicalMonoidInstances+      ]++enableUnusedBinds :: DynP ()+enableUnusedBinds = mapM_ setWarningFlag unusedBindsFlags++disableUnusedBinds :: DynP ()+disableUnusedBinds = mapM_ unSetWarningFlag unusedBindsFlags++-- Things you get with -Wunused-binds+unusedBindsFlags :: [WarningFlag]+unusedBindsFlags = [ Opt_WarnUnusedTopBinds+                   , Opt_WarnUnusedLocalBinds+                   , Opt_WarnUnusedPatternBinds+                   ]++enableGlasgowExts :: DynP ()+enableGlasgowExts = do setGeneralFlag Opt_PrintExplicitForalls+                       mapM_ setExtensionFlag glasgowExtsFlags++disableGlasgowExts :: DynP ()+disableGlasgowExts = do unSetGeneralFlag Opt_PrintExplicitForalls+                        mapM_ unSetExtensionFlag glasgowExtsFlags++glasgowExtsFlags :: [LangExt.Extension]+glasgowExtsFlags = [+             LangExt.ConstrainedClassMethods+           , LangExt.DeriveDataTypeable+           , LangExt.DeriveFoldable+           , LangExt.DeriveFunctor+           , LangExt.DeriveGeneric+           , LangExt.DeriveTraversable+           , LangExt.EmptyDataDecls+           , LangExt.ExistentialQuantification+           , LangExt.ExplicitNamespaces+           , LangExt.FlexibleContexts+           , LangExt.FlexibleInstances+           , LangExt.ForeignFunctionInterface+           , LangExt.FunctionalDependencies+           , LangExt.GeneralizedNewtypeDeriving+           , LangExt.ImplicitParams+           , LangExt.KindSignatures+           , LangExt.LiberalTypeSynonyms+           , LangExt.MagicHash+           , LangExt.MultiParamTypeClasses+           , LangExt.ParallelListComp+           , LangExt.PatternGuards+           , LangExt.PostfixOperators+           , LangExt.RankNTypes+           , LangExt.RecursiveDo+           , LangExt.ScopedTypeVariables+           , LangExt.StandaloneDeriving+           , LangExt.TypeOperators+           , LangExt.TypeSynonymInstances+           , LangExt.UnboxedTuples+           , LangExt.UnicodeSyntax+           , LangExt.UnliftedFFITypes ]++foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO CInt++-- | Was the runtime system built with profiling enabled?+rtsIsProfiled :: Bool+rtsIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0++-- Consult the RTS to find whether GHC itself has been built with+-- dynamic linking.  This can't be statically known at compile-time,+-- because we build both the static and dynamic versions together with+-- -dynamic-too.+foreign import ccall unsafe "rts_isDynamic" rtsIsDynamicIO :: IO CInt++dynamicGhc :: Bool+dynamicGhc = unsafeDupablePerformIO rtsIsDynamicIO /= 0++setWarnSafe :: Bool -> DynP ()+setWarnSafe True  = getCurLoc >>= \l -> upd (\d -> d { warnSafeOnLoc = l })+setWarnSafe False = return ()++setWarnUnsafe :: Bool -> DynP ()+setWarnUnsafe True  = getCurLoc >>= \l -> upd (\d -> d { warnUnsafeOnLoc = l })+setWarnUnsafe False = return ()++setPackageTrust :: DynP ()+setPackageTrust = do+    setGeneralFlag Opt_PackageTrust+    l <- getCurLoc+    upd $ \d -> d { pkgTrustOnLoc = l }++setGenDeriving :: TurnOnFlag -> DynP ()+setGenDeriving True  = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l })+setGenDeriving False = return ()++setOverlappingInsts :: TurnOnFlag -> DynP ()+setOverlappingInsts False = return ()+setOverlappingInsts True = do+  l <- getCurLoc+  upd (\d -> d { overlapInstLoc = l })++setIncoherentInsts :: TurnOnFlag -> DynP ()+setIncoherentInsts False = return ()+setIncoherentInsts True = do+  l <- getCurLoc+  upd (\d -> d { incoherentOnLoc = l })++checkTemplateHaskellOk :: TurnOnFlag -> DynP ()+checkTemplateHaskellOk _turn_on+  = getCurLoc >>= \l -> upd (\d -> d { thOnLoc = l })++{- **********************************************************************+%*                                                                      *+                DynFlags constructors+%*                                                                      *+%********************************************************************* -}++type DynP = EwM (CmdLineP DynFlags)++upd :: (DynFlags -> DynFlags) -> DynP ()+upd f = liftEwM (do dflags <- getCmdLineState+                    putCmdLineState $! f dflags)++updM :: (DynFlags -> DynP DynFlags) -> DynP ()+updM f = do dflags <- liftEwM getCmdLineState+            dflags' <- f dflags+            liftEwM $ putCmdLineState $! dflags'++--------------- Constructor functions for OptKind -----------------+noArg :: (DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+noArg fn = NoArg (upd fn)++noArgM :: (DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags)+noArgM fn = NoArg (updM fn)++hasArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+hasArg fn = HasArg (upd . fn)++sepArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+sepArg fn = SepArg (upd . fn)++intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+intSuffix fn = IntSuffix (\n -> upd (fn n))++intSuffixM :: (Int -> DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags)+intSuffixM fn = IntSuffix (\n -> updM (fn n))++floatSuffix :: (Float -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+floatSuffix fn = FloatSuffix (\n -> upd (fn n))++optIntSuffixM :: (Maybe Int -> DynFlags -> DynP DynFlags)+              -> OptKind (CmdLineP DynFlags)+optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi))++setDumpFlag :: DumpFlag -> OptKind (CmdLineP DynFlags)+setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag)++--------------------------+addWay :: Way -> DynP ()+addWay w = upd (addWay' w)++addWay' :: Way -> DynFlags -> DynFlags+addWay' w dflags0 = let platform = targetPlatform dflags0+                        dflags1 = dflags0 { ways = w : ways dflags0 }+                        dflags2 = foldr setGeneralFlag' dflags1+                                        (wayGeneralFlags platform w)+                        dflags3 = foldr unSetGeneralFlag' dflags2+                                        (wayUnsetGeneralFlags platform w)+                    in dflags3++removeWayDyn :: DynP ()+removeWayDyn = upd (\dfs -> dfs { ways = filter (WayDyn /=) (ways dfs) })++--------------------------+setGeneralFlag, unSetGeneralFlag :: GeneralFlag -> DynP ()+setGeneralFlag   f = upd (setGeneralFlag' f)+unSetGeneralFlag f = upd (unSetGeneralFlag' f)++setGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags+setGeneralFlag' f dflags = foldr ($) (gopt_set dflags f) deps+  where+    deps = [ if turn_on then setGeneralFlag'   d+                        else unSetGeneralFlag' d+           | (f', turn_on, d) <- impliedGFlags, f' == f ]+        -- When you set f, set the ones it implies+        -- NB: use setGeneralFlag recursively, in case the implied flags+        --     implies further flags++unSetGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags+unSetGeneralFlag' f dflags = foldr ($) (gopt_unset dflags f) deps+  where+    deps = [ if turn_on then setGeneralFlag' d+                        else unSetGeneralFlag' d+           | (f', turn_on, d) <- impliedOffGFlags, f' == f ]+   -- In general, when you un-set f, we don't un-set the things it implies.+   -- There are however some exceptions, e.g., -fno-strictness implies+   -- -fno-worker-wrapper.+   --+   -- NB: use unSetGeneralFlag' recursively, in case the implied off flags+   --     imply further flags.++--------------------------+setWarningFlag, unSetWarningFlag :: WarningFlag -> DynP ()+setWarningFlag   f = upd (\dfs -> wopt_set dfs f)+unSetWarningFlag f = upd (\dfs -> wopt_unset dfs f)++setFatalWarningFlag, unSetFatalWarningFlag :: WarningFlag -> DynP ()+setFatalWarningFlag   f = upd (\dfs -> wopt_set_fatal dfs f)+unSetFatalWarningFlag f = upd (\dfs -> wopt_unset_fatal dfs f)++--------------------------+setExtensionFlag, unSetExtensionFlag :: LangExt.Extension -> DynP ()+setExtensionFlag f = upd (setExtensionFlag' f)+unSetExtensionFlag f = upd (unSetExtensionFlag' f)++setExtensionFlag', unSetExtensionFlag' :: LangExt.Extension -> DynFlags -> DynFlags+setExtensionFlag' f dflags = foldr ($) (xopt_set dflags f) deps+  where+    deps = [ if turn_on then setExtensionFlag'   d+                        else unSetExtensionFlag' d+           | (f', turn_on, d) <- impliedXFlags, f' == f ]+        -- When you set f, set the ones it implies+        -- NB: use setExtensionFlag recursively, in case the implied flags+        --     implies further flags++unSetExtensionFlag' f dflags = xopt_unset dflags f+   -- When you un-set f, however, we don't un-set the things it implies+   --      (except for -fno-glasgow-exts, which is treated specially)++--------------------------+alterSettings :: (Settings -> Settings) -> DynFlags -> DynFlags+alterSettings f dflags = dflags { settings = f (settings dflags) }++--------------------------+setDumpFlag' :: DumpFlag -> DynP ()+setDumpFlag' dump_flag+  = do upd (\dfs -> dopt_set dfs dump_flag)+       when want_recomp forceRecompile+    where -- Certain dumpy-things are really interested in what's going+          -- on during recompilation checking, so in those cases we+          -- don't want to turn it off.+          want_recomp = dump_flag `notElem` [Opt_D_dump_if_trace,+                                             Opt_D_dump_hi_diffs,+                                             Opt_D_no_debug_output]++forceRecompile :: DynP ()+-- Whenver we -ddump, force recompilation (by switching off the+-- recompilation checker), else you don't see the dump! However,+-- don't switch it off in --make mode, else *everything* gets+-- recompiled which probably isn't what you want+forceRecompile = do dfs <- liftEwM getCmdLineState+                    when (force_recomp dfs) (setGeneralFlag Opt_ForceRecomp)+        where+          force_recomp dfs = isOneShot (ghcMode dfs)+++setVerboseCore2Core :: DynP ()+setVerboseCore2Core = setDumpFlag' Opt_D_verbose_core2core++setVerbosity :: Maybe Int -> DynP ()+setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 })++setDebugLevel :: Maybe Int -> DynP ()+setDebugLevel mb_n = upd (\dfs -> dfs{ debugLevel = mb_n `orElse` 2 })++data PkgConfRef+  = GlobalPkgConf+  | UserPkgConf+  | PkgConfFile FilePath+  deriving Eq++addPkgConfRef :: PkgConfRef -> DynP ()+addPkgConfRef p = upd $ \s ->+  s { packageDBFlags = PackageDB p : packageDBFlags s }++removeUserPkgConf :: DynP ()+removeUserPkgConf = upd $ \s ->+  s { packageDBFlags = NoUserPackageDB : packageDBFlags s }++removeGlobalPkgConf :: DynP ()+removeGlobalPkgConf = upd $ \s ->+ s { packageDBFlags = NoGlobalPackageDB : packageDBFlags s }++clearPkgConf :: DynP ()+clearPkgConf = upd $ \s ->+  s { packageDBFlags = ClearPackageDBs : packageDBFlags s }++parsePackageFlag :: String                 -- the flag+                 -> ReadP PackageArg       -- type of argument+                 -> String                 -- string to parse+                 -> PackageFlag+parsePackageFlag flag arg_parse str+ = case filter ((=="").snd) (readP_to_S parse str) of+    [(r, "")] -> r+    _ -> throwGhcException $ CmdLineError ("Can't parse package flag: " ++ str)+  where doc = flag ++ " " ++ str+        parse = do+            pkg_arg <- tok arg_parse+            let mk_expose = ExposePackage doc pkg_arg+            ( do _ <- tok $ string "with"+                 fmap (mk_expose . ModRenaming True) parseRns+             <++ fmap (mk_expose . ModRenaming False) parseRns+             <++ return (mk_expose (ModRenaming True [])))+        parseRns = do _ <- tok $ R.char '('+                      rns <- tok $ sepBy parseItem (tok $ R.char ',')+                      _ <- tok $ R.char ')'+                      return rns+        parseItem = do+            orig <- tok $ parseModuleName+            (do _ <- tok $ string "as"+                new <- tok $ parseModuleName+                return (orig, new)+              ++++             return (orig, orig))+        tok m = m >>= \x -> skipSpaces >> return x++exposePackage, exposePackageId, hidePackage,+        exposePluginPackage, exposePluginPackageId,+        ignorePackage,+        trustPackage, distrustPackage :: String -> DynP ()+exposePackage p = upd (exposePackage' p)+exposePackageId p =+  upd (\s -> s{ packageFlags =+    parsePackageFlag "-package-id" parseUnitIdArg p : packageFlags s })+exposePluginPackage p =+  upd (\s -> s{ pluginPackageFlags =+    parsePackageFlag "-plugin-package" parsePackageArg p : pluginPackageFlags s })+exposePluginPackageId p =+  upd (\s -> s{ pluginPackageFlags =+    parsePackageFlag "-plugin-package-id" parseUnitIdArg p : pluginPackageFlags s })+hidePackage p =+  upd (\s -> s{ packageFlags = HidePackage p : packageFlags s })+ignorePackage p =+  upd (\s -> s{ ignorePackageFlags = IgnorePackage p : ignorePackageFlags s })++trustPackage p = exposePackage p >> -- both trust and distrust also expose a package+  upd (\s -> s{ trustFlags = TrustPackage p : trustFlags s })+distrustPackage p = exposePackage p >>+  upd (\s -> s{ trustFlags = DistrustPackage p : trustFlags s })++exposePackage' :: String -> DynFlags -> DynFlags+exposePackage' p dflags+    = dflags { packageFlags =+            parsePackageFlag "-package" parsePackageArg p : packageFlags dflags }++parsePackageArg :: ReadP PackageArg+parsePackageArg =+    fmap PackageArg (munch1 (\c -> isAlphaNum c || c `elem` ":-_."))++parseUnitIdArg :: ReadP PackageArg+parseUnitIdArg =+    fmap UnitIdArg parseUnitId++setUnitId :: String -> DynFlags -> DynFlags+setUnitId p d = d { thisInstalledUnitId = stringToInstalledUnitId p }++-- | Given a 'ModuleName' of a signature in the home library, find+-- out how it is instantiated.  E.g., the canonical form of+-- A in @p[A=q[]:A]@ is @q[]:A@.+canonicalizeHomeModule :: DynFlags -> ModuleName -> Module+canonicalizeHomeModule dflags mod_name =+    case lookup mod_name (thisUnitIdInsts dflags) of+        Nothing  -> mkModule (thisPackage dflags) mod_name+        Just mod -> mod+++-- -----------------------------------------------------------------------------+-- | Find the package environment (if one exists)+--+-- We interpret the package environment as a set of package flags; to be+-- specific, if we find a package environment file like+--+-- > clear-package-db+-- > global-package-db+-- > package-db blah/package.conf.d+-- > package-id id1+-- > package-id id2+--+-- we interpret this as+--+-- > [ -hide-all-packages+-- > , -clear-package-db+-- > , -global-package-db+-- > , -package-db blah/package.conf.d+-- > , -package-id id1+-- > , -package-id id2+-- > ]+--+-- There's also an older syntax alias for package-id, which is just an+-- unadorned package id+--+-- > id1+-- > id2+--+interpretPackageEnv :: DynFlags -> IO DynFlags+interpretPackageEnv dflags = do+    mPkgEnv <- runMaybeT $ msum $ [+                   getCmdLineArg >>= \env -> msum [+                       probeEnvFile env+                     , probeEnvName env+                     , cmdLineError env+                     ]+                 , getEnvVar >>= \env -> msum [+                       probeEnvFile env+                     , probeEnvName env+                     , envError     env+                     ]+                 , notIfHideAllPackages >> msum [+                       findLocalEnvFile >>= probeEnvFile+                     , probeEnvName defaultEnvName+                     ]+                 ]+    case mPkgEnv of+      Nothing ->+        -- No environment found. Leave DynFlags unchanged.+        return dflags+      Just envfile -> do+        content <- readFile envfile+        let setFlags :: DynP ()+            setFlags = do+              setGeneralFlag Opt_HideAllPackages+              parseEnvFile envfile content++            (_, dflags') = runCmdLine (runEwM setFlags) dflags++        return dflags'+  where+    -- Loading environments (by name or by location)++    namedEnvPath :: String -> MaybeT IO FilePath+    namedEnvPath name = do+     appdir <- versionedAppDir dflags+     return $ appdir </> "environments" </> name++    probeEnvName :: String -> MaybeT IO FilePath+    probeEnvName name = probeEnvFile =<< namedEnvPath name++    probeEnvFile :: FilePath -> MaybeT IO FilePath+    probeEnvFile path = do+      guard =<< liftMaybeT (doesFileExist path)+      return path++    parseEnvFile :: FilePath -> String -> DynP ()+    parseEnvFile envfile = mapM_ parseEntry . lines+      where+        parseEntry str = case words str of+          ("package-db": _)     -> addPkgConfRef (PkgConfFile (envdir </> db))+            -- relative package dbs are interpreted relative to the env file+            where envdir = takeDirectory envfile+                  db     = drop 11 str+          ["clear-package-db"]  -> clearPkgConf+          ["global-package-db"] -> addPkgConfRef GlobalPkgConf+          ["user-package-db"]   -> addPkgConfRef UserPkgConf+          ["package-id", pkgid] -> exposePackageId pkgid+          (('-':'-':_):_)       -> return () -- comments+          -- and the original syntax introduced in 7.10:+          [pkgid]               -> exposePackageId pkgid+          []                    -> return ()+          _                     -> throwGhcException $ CmdLineError $+                                        "Can't parse environment file entry: "+                                     ++ envfile ++ ": " ++ str++    -- Various ways to define which environment to use++    getCmdLineArg :: MaybeT IO String+    getCmdLineArg = MaybeT $ return $ packageEnv dflags++    getEnvVar :: MaybeT IO String+    getEnvVar = do+      mvar <- liftMaybeT $ try $ getEnv "GHC_ENVIRONMENT"+      case mvar of+        Right var -> return var+        Left err  -> if isDoesNotExistError err then mzero+                                                else liftMaybeT $ throwIO err++    notIfHideAllPackages :: MaybeT IO ()+    notIfHideAllPackages =+      guard (not (gopt Opt_HideAllPackages dflags))++    defaultEnvName :: String+    defaultEnvName = "default"++    -- e.g. .ghc.environment.x86_64-linux-7.6.3+    localEnvFileName :: FilePath+    localEnvFileName = ".ghc.environment" <.> versionedFilePath dflags++    -- Search for an env file, starting in the current dir and looking upwards.+    -- Fail if we get to the users home dir or the filesystem root. That is,+    -- we don't look for an env file in the user's home dir. The user-wide+    -- env lives in ghc's versionedAppDir/environments/default+    findLocalEnvFile :: MaybeT IO FilePath+    findLocalEnvFile = do+        curdir  <- liftMaybeT getCurrentDirectory+        homedir <- tryMaybeT getHomeDirectory+        let probe dir | isDrive dir || dir == homedir+                      = mzero+            probe dir = do+              let file = dir </> localEnvFileName+              exists <- liftMaybeT (doesFileExist file)+              if exists+                then return file+                else probe (takeDirectory dir)+        probe curdir++    -- Error reporting++    cmdLineError :: String -> MaybeT IO a+    cmdLineError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $+      "Package environment " ++ show env ++ " not found"++    envError :: String -> MaybeT IO a+    envError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $+         "Package environment "+      ++ show env+      ++ " (specified in GHC_ENVIRONMENT) not found"+++-- If we're linking a binary, then only targets that produce object+-- code are allowed (requests for other target types are ignored).+setTarget :: HscTarget -> DynP ()+setTarget l = setTargetWithPlatform (const l)++setTargetWithPlatform :: (Platform -> HscTarget) -> DynP ()+setTargetWithPlatform f = upd set+  where+   set dfs = let l = f (targetPlatform dfs)+             in if ghcLink dfs /= LinkBinary || isObjectTarget l+                then dfs{ hscTarget = l }+                else dfs++-- Changes the target only if we're compiling object code.  This is+-- used by -fasm and -fllvm, which switch from one to the other, but+-- not from bytecode to object-code.  The idea is that -fasm/-fllvm+-- can be safely used in an OPTIONS_GHC pragma.+setObjTarget :: HscTarget -> DynP ()+setObjTarget l = updM set+  where+   set dflags+     | isObjectTarget (hscTarget dflags)+       = return $ dflags { hscTarget = l }+     | otherwise = return dflags++setOptLevel :: Int -> DynFlags -> DynP DynFlags+setOptLevel n dflags = return (updOptLevel n dflags)++checkOptLevel :: Int -> DynFlags -> Either String DynFlags+checkOptLevel n dflags+   | hscTarget dflags == HscInterpreted && n > 0+     = Left "-O conflicts with --interactive; -O ignored."+   | otherwise+     = Right dflags++-- -Odph is equivalent to+--+--    -O2                               optimise as much as possible+--    -fmax-simplifier-iterations20     this is necessary sometimes+--    -fsimplifier-phases=3             we use an additional simplifier phase for fusion+--+setDPHOpt :: DynFlags -> DynP DynFlags+setDPHOpt dflags = setOptLevel 2 (dflags { maxSimplIterations  = 20+                                         , simplPhases         = 3+                                         })++setMainIs :: String -> DynP ()+setMainIs arg+  | not (null main_fn) && isLower (head main_fn)+     -- The arg looked like "Foo.Bar.baz"+  = upd $ \d -> d { mainFunIs = Just main_fn,+                   mainModIs = mkModule mainUnitId (mkModuleName main_mod) }++  | isUpper (head arg)  -- The arg looked like "Foo" or "Foo.Bar"+  = upd $ \d -> d { mainModIs = mkModule mainUnitId (mkModuleName arg) }++  | otherwise                   -- The arg looked like "baz"+  = upd $ \d -> d { mainFunIs = Just arg }+  where+    (main_mod, main_fn) = splitLongestPrefix arg (== '.')++addLdInputs :: Option -> DynFlags -> DynFlags+addLdInputs p dflags = dflags{ldInputs = ldInputs dflags ++ [p]}++-----------------------------------------------------------------------------+-- Paths & Libraries++addImportPath, addLibraryPath, addIncludePath, addFrameworkPath :: FilePath -> DynP ()++-- -i on its own deletes the import paths+addImportPath "" = upd (\s -> s{importPaths = []})+addImportPath p  = upd (\s -> s{importPaths = importPaths s ++ splitPathList p})++addLibraryPath p =+  upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p})++addIncludePath p =+  upd (\s -> s{includePaths = includePaths s ++ splitPathList p})++addFrameworkPath p =+  upd (\s -> s{frameworkPaths = frameworkPaths s ++ splitPathList p})++#ifndef mingw32_TARGET_OS+split_marker :: Char+split_marker = ':'   -- not configurable (ToDo)+#endif++splitPathList :: String -> [String]+splitPathList s = filter notNull (splitUp s)+                -- empty paths are ignored: there might be a trailing+                -- ':' in the initial list, for example.  Empty paths can+                -- cause confusion when they are translated into -I options+                -- for passing to gcc.+  where+#ifndef mingw32_TARGET_OS+    splitUp xs = split split_marker xs+#else+     -- Windows: 'hybrid' support for DOS-style paths in directory lists.+     --+     -- That is, if "foo:bar:baz" is used, this interpreted as+     -- consisting of three entries, 'foo', 'bar', 'baz'.+     -- However, with "c:/foo:c:\\foo;x:/bar", this is interpreted+     -- as 3 elts, "c:/foo", "c:\\foo", "x:/bar"+     --+     -- Notice that no attempt is made to fully replace the 'standard'+     -- split marker ':' with the Windows / DOS one, ';'. The reason being+     -- that this will cause too much breakage for users & ':' will+     -- work fine even with DOS paths, if you're not insisting on being silly.+     -- So, use either.+    splitUp []             = []+    splitUp (x:':':div:xs) | div `elem` dir_markers+                           = ((x:':':div:p): splitUp rs)+                           where+                              (p,rs) = findNextPath xs+          -- we used to check for existence of the path here, but that+          -- required the IO monad to be threaded through the command-line+          -- parser which is quite inconvenient.  The+    splitUp xs = cons p (splitUp rs)+               where+                 (p,rs) = findNextPath xs++                 cons "" xs = xs+                 cons x  xs = x:xs++    -- will be called either when we've consumed nought or the+    -- "<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 = alterSettings (\s -> s { sTmpDir = normalise dir })+  -- we used to fix /cygdrive/c/.. on Windows, but this doesn't+  -- seem necessary now --SDM 7/2/2008++-----------------------------------------------------------------------------+-- RTS opts++setRtsOpts :: String -> DynP ()+setRtsOpts arg  = upd $ \ d -> d {rtsOpts = Just arg}++setRtsOptsEnabled :: RtsOptsEnabled -> DynP ()+setRtsOptsEnabled arg  = upd $ \ d -> d {rtsOptsEnabled = arg}++-----------------------------------------------------------------------------+-- Hpc stuff++setOptHpcDir :: String -> DynP ()+setOptHpcDir arg  = upd $ \ d -> d {hpcDir = arg}++-----------------------------------------------------------------------------+-- Via-C compilation stuff++-- There are some options that we need to pass to gcc when compiling+-- Haskell code via C, but are only supported by recent versions of+-- gcc.  The configure script decides which of these options we need,+-- and puts them in the "settings" file in $topdir. The advantage of+-- having these in a separate file is that the file can be created at+-- install-time depending on the available gcc version, and even+-- re-generated later if gcc is upgraded.+--+-- The options below are not dependent on the version of gcc, only the+-- platform.++picCCOpts :: DynFlags -> [String]+picCCOpts dflags+    = case platformOS (targetPlatform dflags) of+      OSDarwin+          -- Apple prefers to do things the other way round.+          -- PIC is on by default.+          -- -mdynamic-no-pic:+          --     Turn off PIC code generation.+          -- -fno-common:+          --     Don't generate "common" symbols - these are unwanted+          --     in dynamic libraries.++       | gopt Opt_PIC dflags -> ["-fno-common", "-U__PIC__", "-D__PIC__"]+       | otherwise           -> ["-mdynamic-no-pic"]+      OSMinGW32 -- no -fPIC for Windows+       | gopt Opt_PIC dflags -> ["-U__PIC__", "-D__PIC__"]+       | otherwise           -> []+      _+      -- we need -fPIC for C files when we are compiling with -dynamic,+      -- otherwise things like stub.c files don't get compiled+      -- correctly.  They need to reference data in the Haskell+      -- objects, but can't without -fPIC.  See+      -- http://ghc.haskell.org/trac/ghc/wiki/Commentary/PositionIndependentCode+       | gopt Opt_PIC dflags || WayDyn `elem` ways dflags ->+          ["-fPIC", "-U__PIC__", "-D__PIC__"]+       | otherwise                             -> []++picPOpts :: DynFlags -> [String]+picPOpts dflags+ | gopt Opt_PIC dflags = ["-U__PIC__", "-D__PIC__"]+ | otherwise           = []++-- -----------------------------------------------------------------------------+-- Splitting++can_split :: Bool+can_split = cSupportsSplitObjs == "YES"++-- -----------------------------------------------------------------------------+-- Compiler Info++compilerInfo :: DynFlags -> [(String, String)]+compilerInfo dflags+    = -- We always make "Project name" be first to keep parsing in+      -- other languages simple, i.e. when looking for other fields,+      -- you don't have to worry whether there is a leading '[' or not+      ("Project name",                 cProjectName)+      -- Next come the settings, so anything else can be overridden+      -- in the settings file (as "lookup" uses the first match for the+      -- key)+    : rawSettings dflags+   ++ [("Project version",             projectVersion dflags),+       ("Project Git commit id",       cProjectGitCommitId),+       ("Booter version",              cBooterVersion),+       ("Stage",                       cStage),+       ("Build platform",              cBuildPlatformString),+       ("Host platform",               cHostPlatformString),+       ("Target platform",             cTargetPlatformString),+       ("Have interpreter",            cGhcWithInterpreter),+       ("Object splitting supported",  cSupportsSplitObjs),+       ("Have native code generator",  cGhcWithNativeCodeGen),+       ("Support SMP",                 cGhcWithSMP),+       ("Tables next to code",         cGhcEnableTablesNextToCode),+       ("RTS ways",                    cGhcRTSWays),+       ("RTS expects libdw",           showBool cGhcRtsWithLibdw),+       -- Whether or not we support @-dynamic-too@+       ("Support dynamic-too",         showBool $ not isWindows),+       -- Whether or not we support the @-j@ flag with @--make@.+       ("Support parallel --make",     "YES"),+       -- Whether or not we support "Foo from foo-0.1-XXX:Foo" syntax in+       -- installed package info.+       ("Support reexported-modules",  "YES"),+       -- Whether or not we support extended @-package foo (Foo)@ syntax.+       ("Support thinning and renaming package flags", "YES"),+       -- Whether or not we support Backpack.+       ("Support Backpack", "YES"),+       -- If true, we require that the 'id' field in installed package info+       -- match what is passed to the @-this-unit-id@ flag for modules+       -- built in it+       ("Requires unified installed package IDs", "YES"),+       -- Whether or not we support the @-this-package-key@ flag.  Prefer+       -- "Uses unit IDs" over it.+       ("Uses package keys",           "YES"),+       -- Whether or not we support the @-this-unit-id@ flag+       ("Uses unit IDs",               "YES"),+       -- Whether or not GHC compiles libraries as dynamic by default+       ("Dynamic by default",          showBool $ dYNAMIC_BY_DEFAULT dflags),+       -- Whether or not GHC was compiled using -dynamic+       ("GHC Dynamic",                 showBool dynamicGhc),+       -- Whether or not GHC was compiled using -prof+       ("GHC Profiled",                showBool rtsIsProfiled),+       ("Leading underscore",          cLeadingUnderscore),+       ("Debug on",                    show debugIsOn),+       ("LibDir",                      topDir dflags),+       -- The path of the global package database used by GHC+       ("Global Package DB",           systemPackageConfig dflags)+      ]+  where+    showBool True  = "YES"+    showBool False = "NO"+    isWindows = platformOS (targetPlatform dflags) == OSMinGW32++-- Produced by deriveConstants+#include "GHCConstantsHaskellWrappers.hs"++bLOCK_SIZE_W :: DynFlags -> Int+bLOCK_SIZE_W dflags = bLOCK_SIZE dflags `quot` wORD_SIZE dflags++wORD_SIZE_IN_BITS :: DynFlags -> Int+wORD_SIZE_IN_BITS dflags = wORD_SIZE dflags * 8++tAG_MASK :: DynFlags -> Int+tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1++mAX_PTR_TAG :: DynFlags -> Int+mAX_PTR_TAG = tAG_MASK++-- Might be worth caching these in targetPlatform?+tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD :: DynFlags -> Integer+tARGET_MIN_INT dflags+    = case platformWordSize (targetPlatform dflags) of+      4 -> toInteger (minBound :: Int32)+      8 -> toInteger (minBound :: Int64)+      w -> panic ("tARGET_MIN_INT: Unknown platformWordSize: " ++ show w)+tARGET_MAX_INT dflags+    = case platformWordSize (targetPlatform dflags) of+      4 -> toInteger (maxBound :: Int32)+      8 -> toInteger (maxBound :: Int64)+      w -> panic ("tARGET_MAX_INT: Unknown platformWordSize: " ++ show w)+tARGET_MAX_WORD dflags+    = case platformWordSize (targetPlatform dflags) of+      4 -> toInteger (maxBound :: Word32)+      8 -> toInteger (maxBound :: Word64)+      w -> panic ("tARGET_MAX_WORD: Unknown platformWordSize: " ++ show w)+++{- -----------------------------------------------------------------------------+Note [DynFlags consistency]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~++There are a number of number of DynFlags configurations which either+do not make sense or lead to unimplemented or buggy codepaths in the+compiler. makeDynFlagsConsistent is responsible for verifying the validity+of a set of DynFlags, fixing any issues, and reporting them back to the+caller.++GHCi and -O+---------------++When using optimization, the compiler can introduce several things+(such as unboxed tuples) into the intermediate code, which GHCi later+chokes on since the bytecode interpreter can't handle this (and while+this is arguably a bug these aren't handled, there are no plans to fix+it.)++While the driver pipeline always checks for this particular erroneous+combination when parsing flags, we also need to check when we update+the flags; this is because API clients may parse flags but update the+DynFlags afterwords, before finally running code inside a session (see+T10052 and #10052).+-}++-- | Resolve any internal inconsistencies in a set of 'DynFlags'.+-- Returns the consistent 'DynFlags' as well as a list of warnings+-- to report to the user.+makeDynFlagsConsistent :: DynFlags -> (DynFlags, [Located String])+-- Whenever makeDynFlagsConsistent does anything, it starts over, to+-- ensure that a later change doesn't invalidate an earlier check.+-- Be careful not to introduce potential loops!+makeDynFlagsConsistent dflags+ -- Disable -dynamic-too on Windows (#8228, #7134, #5987)+ | os == OSMinGW32 && gopt Opt_BuildDynamicToo dflags+    = let dflags' = gopt_unset dflags Opt_BuildDynamicToo+          warn    = "-dynamic-too is not supported on Windows"+      in loop dflags' warn+ | hscTarget dflags == HscC &&+   not (platformUnregisterised (targetPlatform dflags))+    = if cGhcWithNativeCodeGen == "YES"+      then let dflags' = dflags { hscTarget = HscAsm }+               warn = "Compiler not unregisterised, so using native code generator rather than compiling via C"+           in loop dflags' warn+      else let dflags' = dflags { hscTarget = HscLlvm }+               warn = "Compiler not unregisterised, so using LLVM rather than compiling via C"+           in loop dflags' warn+ | gopt Opt_Hpc dflags && hscTarget dflags == HscInterpreted+    = let dflags' = gopt_unset dflags Opt_Hpc+          warn = "Hpc can't be used with byte-code interpreter. Ignoring -fhpc."+      in loop dflags' warn+ | hscTarget dflags `elem` [HscAsm, HscLlvm] &&+   platformUnregisterised (targetPlatform dflags)+    = loop (dflags { hscTarget = HscC })+           "Compiler unregisterised, so compiling via C"+ | hscTarget dflags == HscAsm &&+   cGhcWithNativeCodeGen /= "YES"+      = let dflags' = dflags { hscTarget = HscLlvm }+            warn = "No native code generator, so using LLVM"+        in loop dflags' warn+ | hscTarget dflags == HscLlvm &&+   not ((arch == ArchX86_64) && (os == OSLinux || os == OSDarwin || os == OSFreeBSD)) &&+   not ((isARM arch) && (os == OSLinux)) &&+   (gopt Opt_PIC dflags || WayDyn `elem` ways dflags)+    = if cGhcWithNativeCodeGen == "YES"+      then let dflags' = dflags { hscTarget = HscAsm }+               warn = "Using native code generator rather than LLVM, as LLVM is incompatible with -fPIC and -dynamic on this platform"+           in loop dflags' warn+      else throwGhcException $ CmdLineError "Can't use -fPIC or -dynamic on this platform"+ | os == OSDarwin &&+   arch == ArchX86_64 &&+   not (gopt Opt_PIC dflags)+    = loop (gopt_set dflags Opt_PIC)+           "Enabling -fPIC as it is always on for this platform"+ | Left err <- checkOptLevel (optLevel dflags) dflags+    = loop (updOptLevel 0 dflags) err++ | LinkInMemory <- ghcLink dflags+ , not (gopt Opt_ExternalInterpreter dflags)+ , rtsIsProfiled+ , isObjectTarget (hscTarget dflags)+ , WayProf `notElem` ways dflags+    = loop dflags{ways = WayProf : ways dflags}+         "Enabling -prof, because -fobject-code is enabled and GHCi is profiled"++ | otherwise = (dflags, [])+    where loc = mkGeneralSrcSpan (fsLit "when making flags consistent")+          loop updated_dflags warning+              = case makeDynFlagsConsistent updated_dflags of+                (dflags', ws) -> (dflags', L loc warning : ws)+          platform = targetPlatform dflags+          arch = platformArch platform+          os   = platformOS   platform+++--------------------------------------------------------------------------+-- Do not use unsafeGlobalDynFlags!+--+-- unsafeGlobalDynFlags is a hack, necessary because we need to be able+-- to show SDocs when tracing, but we don't always have DynFlags+-- available.+--+-- Do not use it if you can help it. You may get the wrong value, or this+-- panic!++-- | This is the value that 'unsafeGlobalDynFlags' takes before it is+-- initialized.+defaultGlobalDynFlags :: DynFlags+defaultGlobalDynFlags =+    (defaultDynFlags settings) { verbosity = 2 }+  where+    settings = panic "v_unsafeGlobalDynFlags: not initialised"++#if STAGE < 2+GLOBAL_VAR(v_unsafeGlobalDynFlags, defaultGlobalDynFlags, DynFlags)+#else+SHARED_GLOBAL_VAR( v_unsafeGlobalDynFlags+                 , getOrSetLibHSghcGlobalDynFlags+                 , "getOrSetLibHSghcGlobalDynFlags"+                 , defaultGlobalDynFlags+                 , DynFlags )+#endif++unsafeGlobalDynFlags :: DynFlags+unsafeGlobalDynFlags = unsafePerformIO $ readIORef v_unsafeGlobalDynFlags++setUnsafeGlobalDynFlags :: DynFlags -> IO ()+setUnsafeGlobalDynFlags = writeIORef v_unsafeGlobalDynFlags++-- -----------------------------------------------------------------------------+-- SSE and AVX++-- TODO: Instead of using a separate predicate (i.e. isSse2Enabled) to+-- check if SSE is enabled, we might have x86-64 imply the -msse2+-- flag.++data SseVersion = SSE1+                | SSE2+                | SSE3+                | SSE4+                | SSE42+                deriving (Eq, Ord)++isSseEnabled :: DynFlags -> Bool+isSseEnabled dflags = case platformArch (targetPlatform dflags) of+    ArchX86_64 -> True+    ArchX86    -> sseVersion dflags >= Just SSE1+    _          -> False++isSse2Enabled :: DynFlags -> Bool+isSse2Enabled dflags = case platformArch (targetPlatform dflags) of+    ArchX86_64 -> -- SSE2 is fixed on for x86_64.  It would be+                  -- possible to make it optional, but we'd need to+                  -- fix at least the foreign call code where the+                  -- calling convention specifies the use of xmm regs,+                  -- and possibly other places.+                  True+    ArchX86    -> sseVersion dflags >= Just SSE2+    _          -> False++isSse4_2Enabled :: DynFlags -> Bool+isSse4_2Enabled dflags = sseVersion dflags >= Just SSE42++isAvxEnabled :: DynFlags -> Bool+isAvxEnabled dflags = avx dflags || avx2 dflags || avx512f dflags++isAvx2Enabled :: DynFlags -> Bool+isAvx2Enabled dflags = avx2 dflags || avx512f dflags++isAvx512cdEnabled :: DynFlags -> Bool+isAvx512cdEnabled dflags = avx512cd dflags++isAvx512erEnabled :: DynFlags -> Bool+isAvx512erEnabled dflags = avx512er dflags++isAvx512fEnabled :: DynFlags -> Bool+isAvx512fEnabled dflags = avx512f dflags++isAvx512pfEnabled :: DynFlags -> Bool+isAvx512pfEnabled dflags = avx512pf dflags++-- -----------------------------------------------------------------------------+-- Linker/compiler information++-- LinkerInfo contains any extra options needed by the system linker.+data LinkerInfo+  = GnuLD    [Option]+  | GnuGold  [Option]+  | DarwinLD [Option]+  | SolarisLD [Option]+  | AixLD    [Option]+  | UnknownLD+  deriving Eq++-- CompilerInfo tells us which C compiler we're using+data CompilerInfo+   = GCC+   | Clang+   | AppleClang+   | AppleClang51+   | UnknownCC+   deriving Eq++-- -----------------------------------------------------------------------------+-- RTS hooks++-- Convert sizes like "3.5M" into integers+decodeSize :: String -> Integer+decodeSize str+  | c == ""      = truncate n+  | c == "K" || c == "k" = truncate (n * 1000)+  | c == "M" || c == "m" = truncate (n * 1000 * 1000)+  | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000)+  | otherwise            = throwGhcException (CmdLineError ("can't decode size: " ++ str))+  where (m, c) = span pred str+        n      = readRational m+        pred c = isDigit c || c == '.'++foreign import ccall unsafe "setHeapSize"       setHeapSize       :: Int -> IO ()+foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO ()
+ main/DynFlags.hs-boot view
@@ -0,0 +1,17 @@++module DynFlags where++import Platform++data DynFlags+data DumpFlag++targetPlatform       :: DynFlags -> Platform+pprUserLength        :: DynFlags -> Int+pprCols              :: DynFlags -> Int+unsafeGlobalDynFlags :: DynFlags+useUnicode           :: DynFlags -> Bool+useUnicodeSyntax     :: DynFlags -> Bool+shouldUseColor       :: DynFlags -> Bool+hasPprDebug          :: DynFlags -> Bool+hasNoDebugOutput     :: DynFlags -> Bool
+ main/DynamicLoading.hs view
@@ -0,0 +1,269 @@+{-# LANGUAGE CPP, MagicHash #-}++-- | Dynamically lookup up values from modules and loading them.+module DynamicLoading (+#ifdef GHCI+        -- * Loading plugins+        loadPlugins,+        loadFrontendPlugin,++        -- * Force loading information+        forceLoadModuleInterfaces,+        forceLoadNameModuleInterface,+        forceLoadTyCon,++        -- * Finding names+        lookupRdrNameInModuleForPlugins,++        -- * Loading values+        getValueSafely,+        getHValueSafely,+        lessUnsafeCoerce+#else+        pluginError,+#endif+    ) where++#ifdef GHCI+import Linker           ( linkModule, getHValue )+import GHCi             ( wormhole )+import SrcLoc           ( noSrcSpan )+import Finder           ( findPluginModule, cannotFindModule )+import TcRnMonad        ( initTcInteractive, initIfaceTcRn )+import LoadIface        ( loadPluginInterface )+import RdrName          ( RdrName, ImportSpec(..), ImpDeclSpec(..)+                        , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName+                        , gre_name, mkRdrQual )+import OccName          ( OccName, mkVarOcc )+import RnNames          ( gresFromAvails )+import DynFlags+import Plugins          ( Plugin, FrontendPlugin, CommandLineOption )+import PrelNames        ( pluginTyConName, frontendPluginTyConName )++import HscTypes+import GHCi.RemoteTypes ( HValue )+import Type             ( Type, eqType, mkTyConTy, pprTyThingCategory )+import TyCon            ( TyCon )+import Name             ( Name, nameModule_maybe )+import Id               ( idType )+import Module           ( Module, ModuleName )+import Panic+import FastString+import ErrUtils+import Outputable+import Exception+import Hooks++import Data.Maybe        ( mapMaybe )+import GHC.Exts          ( unsafeCoerce# )++#else++import Module           ( ModuleName, moduleNameString )+import Panic++import Data.List        ( intercalate )++#endif++#ifdef GHCI++loadPlugins :: HscEnv -> IO [(ModuleName, Plugin, [CommandLineOption])]+loadPlugins hsc_env+  = do { plugins <- mapM (loadPlugin hsc_env) to_load+       ; return $ zipWith attachOptions to_load plugins }+  where+    dflags  = hsc_dflags hsc_env+    to_load = pluginModNames dflags++    attachOptions mod_nm plug = (mod_nm, plug, options)+      where+        options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags+                            , opt_mod_nm == mod_nm ]++loadPlugin :: HscEnv -> ModuleName -> IO Plugin+loadPlugin = loadPlugin' (mkVarOcc "plugin") pluginTyConName++loadFrontendPlugin :: HscEnv -> ModuleName -> IO FrontendPlugin+loadFrontendPlugin = loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName++loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO a+loadPlugin' occ_name plugin_name hsc_env mod_name+  = do { let plugin_rdr_name = mkRdrQual mod_name occ_name+             dflags = hsc_dflags hsc_env+       ; mb_name <- lookupRdrNameInModuleForPlugins hsc_env mod_name+                        plugin_rdr_name+       ; case mb_name of {+            Nothing ->+                throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep+                          [ text "The module", ppr mod_name+                          , text "did not export the plugin name"+                          , ppr plugin_rdr_name ]) ;+            Just name ->++     do { plugin_tycon <- forceLoadTyCon hsc_env plugin_name+        ; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon)+        ; case mb_plugin of+            Nothing ->+                throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep+                          [ text "The value", ppr name+                          , text "did not have the type"+                          , ppr pluginTyConName, text "as required"])+            Just plugin -> return plugin } } }+++-- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used+-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded.+forceLoadModuleInterfaces :: HscEnv -> SDoc -> [Module] -> IO ()+forceLoadModuleInterfaces hsc_env doc modules+    = (initTcInteractive hsc_env $+       initIfaceTcRn $+       mapM_ (loadPluginInterface doc) modules)+      >> return ()++-- | Force the interface for the module containing the name to be loaded. The 'SDoc' parameter is used+-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded.+forceLoadNameModuleInterface :: HscEnv -> SDoc -> Name -> IO ()+forceLoadNameModuleInterface hsc_env reason name = do+    let name_modules = mapMaybe nameModule_maybe [name]+    forceLoadModuleInterfaces hsc_env reason name_modules++-- | Load the 'TyCon' associated with the given name, come hell or high water. Fails if:+--+-- * The interface could not be loaded+-- * The name is not that of a 'TyCon'+-- * The name did not exist in the loaded module+forceLoadTyCon :: HscEnv -> Name -> IO TyCon+forceLoadTyCon hsc_env con_name = do+    forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of loadTyConTy") con_name++    mb_con_thing <- lookupTypeHscEnv hsc_env con_name+    case mb_con_thing of+        Nothing -> throwCmdLineErrorS dflags $ missingTyThingError con_name+        Just (ATyCon tycon) -> return tycon+        Just con_thing -> throwCmdLineErrorS dflags $ wrongTyThingError con_name con_thing+  where dflags = hsc_dflags hsc_env++-- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety+-- in that it is up to the user to ensure that that type corresponds to the type you try to use the return value at!+--+-- If the value found was not of the correct type, returns @Nothing@. Any other condition results in an exception:+--+-- * If we could not load the names module+-- * If the thing being loaded is not a value+-- * If the Name does not exist in the module+-- * If the link failed++getValueSafely :: HscEnv -> Name -> Type -> IO (Maybe a)+getValueSafely hsc_env val_name expected_type = do+  mb_hval <- lookupHook getValueSafelyHook getHValueSafely dflags hsc_env val_name expected_type+  case mb_hval of+    Nothing   -> return Nothing+    Just hval -> do+      value <- lessUnsafeCoerce dflags "getValueSafely" hval+      return (Just value)+  where+    dflags = hsc_dflags hsc_env++getHValueSafely :: HscEnv -> Name -> Type -> IO (Maybe HValue)+getHValueSafely hsc_env val_name expected_type = do+    forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of getHValueSafely") val_name+    -- Now look up the names for the value and type constructor in the type environment+    mb_val_thing <- lookupTypeHscEnv hsc_env val_name+    case mb_val_thing of+        Nothing -> throwCmdLineErrorS dflags $ missingTyThingError val_name+        Just (AnId id) -> do+            -- Check the value type in the interface against the type recovered from the type constructor+            -- before finally casting the value to the type we assume corresponds to that constructor+            if expected_type `eqType` idType id+             then do+                -- Link in the module that contains the value, if it has such a module+                case nameModule_maybe val_name of+                    Just mod -> do linkModule hsc_env mod+                                   return ()+                    Nothing ->  return ()+                -- Find the value that we just linked in and cast it given that we have proved it's type+                hval <- getHValue hsc_env val_name >>= wormhole dflags+                return (Just hval)+             else return Nothing+        Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing+   where dflags = hsc_dflags hsc_env++-- | Coerce a value as usual, but:+--+-- 1) Evaluate it immediately to get a segfault early if the coercion was wrong+--+-- 2) Wrap it in some debug messages at verbosity 3 or higher so we can see what happened+--    if it /does/ segfault+lessUnsafeCoerce :: DynFlags -> String -> a -> IO b+lessUnsafeCoerce dflags context what = do+    debugTraceMsg dflags 3 $ (text "Coercing a value in") <+> (text context) <>+                             (text "...")+    output <- evaluate (unsafeCoerce# what)+    debugTraceMsg dflags 3 (text "Successfully evaluated coercion")+    return output+++-- | Finds the 'Name' corresponding to the given 'RdrName' in the+-- context of the 'ModuleName'. Returns @Nothing@ if no such 'Name'+-- could be found. Any other condition results in an exception:+--+-- * If the module could not be found+-- * If we could not determine the imports of the module+--+-- Can only be used for looking up names while loading plugins (and is+-- *not* suitable for use within plugins).  The interface file is+-- loaded very partially: just enough that it can be used, without its+-- rules and instances affecting (and being linked from!) the module+-- being compiled.  This was introduced by 57d6798.+lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName -> IO (Maybe Name)+lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do+    -- First find the package the module resides in by searching exposed packages and home modules+    found_module <- findPluginModule hsc_env mod_name+    case found_module of+        Found _ mod -> do+            -- Find the exports of the module+            (_, mb_iface) <- initTcInteractive hsc_env $+                             initIfaceTcRn $+                             loadPluginInterface doc mod+            case mb_iface of+                Just iface -> do+                    -- Try and find the required name in the exports+                    let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name+                                                , is_qual = False, is_dloc = noSrcSpan }+                        imp_spec = ImpSpec decl_spec ImpAll+                        env = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) (mi_exports iface))+                    case lookupGRE_RdrName rdr_name env of+                        [gre] -> return (Just (gre_name gre))+                        []    -> return Nothing+                        _     -> panic "lookupRdrNameInModule"++                Nothing -> throwCmdLineErrorS dflags $ hsep [text "Could not determine the exports of the module", ppr mod_name]+        err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err+  where+    dflags = hsc_dflags hsc_env+    doc = text "contains a name used in an invocation of lookupRdrNameInModule"++wrongTyThingError :: Name -> TyThing -> SDoc+wrongTyThingError name got_thing = hsep [text "The name", ppr name, ptext (sLit "is not that of a value but rather a"), pprTyThingCategory got_thing]++missingTyThingError :: Name -> SDoc+missingTyThingError name = hsep [text "The name", ppr name, ptext (sLit "is not in the type environment: are you sure it exists?")]++throwCmdLineErrorS :: DynFlags -> SDoc -> IO a+throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags++throwCmdLineError :: String -> IO a+throwCmdLineError = throwGhcExceptionIO . CmdLineError++#else++pluginError :: [ModuleName] -> a+pluginError modnames = throwGhcException (CmdLineError msg)+  where+    msg = "not built for interactive use - can't load plugins ("+            -- module names are not z-encoded+          ++ intercalate ", " (map moduleNameString modnames)+          ++ ")"++#endif
+ main/Elf.hs view
@@ -0,0 +1,471 @@+{-+-----------------------------------------------------------------------------+--+-- (c) The University of Glasgow 2015+--+-- ELF format tools+--+-----------------------------------------------------------------------------+-}++module Elf (+    readElfSectionByName,+    readElfNoteAsString,+    makeElfNote+  ) where++import Exception+import DynFlags+import Platform+import ErrUtils+import Maybes     (MaybeT(..),runMaybeT)+import Util       (charToC)+import Outputable (text,hcat,SDoc)++import Control.Monad (when)+import Data.Binary.Get+import Data.Word+import Data.Char (ord)+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Lazy.Char8 as B8++{- Note [ELF specification]+   ~~~~~~~~~~~~~~~~~~~~~~~~++   ELF (Executable and Linking Format) is described in the System V Application+   Binary Interface (or ABI). The latter is composed of two parts: a generic+   part and a processor specific part. The generic ABI describes the parts of+   the interface that remain constant across all hardware implementations of+   System V.++   The latest release of the specification of the generic ABI is the version+   4.1 from March 18, 1997:++     - http://www.sco.com/developers/devspecs/gabi41.pdf++   Since 1997, snapshots of the draft for the "next" version are published:++     - http://www.sco.com/developers/gabi/++   Quoting the notice on the website: "There is more than one instance of these+   chapters to permit references to older instances to remain valid. All+   modifications to these chapters are forward-compatible, so that correct use+   of an older specification will not be invalidated by a newer instance.+   Approximately on a yearly basis, a new instance will be saved, as it reaches+   what appears to be a stable state."++   Nevertheless we will see that since 1998 it is not true for Note sections.++   Many ELF sections+   -----------------++   ELF-4.1: the normal section number fields in ELF are limited to 16 bits,+   which runs out of bits when you try to cram in more sections than that. Two+   fields are concerned: the one containing the number of the sections and the+   one containing the index of the section that contains section's names. (The+   same thing applies to the field containing the number of segments, but we+   don't care about it here).++   ELF-next: to solve this, theses fields in the ELF header have an escape+   value (different for each case), and the actual section number is stashed+   into unused fields in the first section header.++   We support this extension as it is forward-compatible with ELF-4.1.+   Moreover, GHC may generate objects with a lot of sections with the+   "function-sections" feature (one section per function).++   Note sections+   -------------++   Sections with type "note" (SHT_NOTE in the specification) are used to add+   arbitrary data into an ELF file. An entry in a note section is composed of a+   name, a type and a value.++   ELF-4.1: "The note information in sections and program header elements holds+   any number of entries, each of which is an array of 4-byte words in the+   format of the target processor." Each entry has the following format:+         | namesz |   Word32: size of the name string (including the ending \0)+         | descsz |   Word32: size of the value+         |  type  |   Word32: type of the note+         |  name  |   Name string (with \0 padding to ensure 4-byte alignment)+         |  ...   |+         |  desc  |   Value (with \0 padding to ensure 4-byte alignment)+         |  ...   |++   ELF-next: "The note information in sections and program header elements+   holds a variable amount of entries. In 64-bit objects (files with+   e_ident[EI_CLASS] equal to ELFCLASS64), each entry is an array of 8-byte+   words in the format of the target processor. In 32-bit objects (files with+   e_ident[EI_CLASS] equal to ELFCLASS32), each entry is an array of 4-byte+   words in the format of the target processor." (from 1998-2015 snapshots)++   This is not forward-compatible with ELF-4.1. In practice, for almost all+   platforms namesz, descz and type fields are 4-byte words for both 32-bit and+   64-bit objects (see elf.h and readelf source code).++   The only exception in readelf source code is for IA_64 machines with OpenVMS+   OS: "This OS has so many departures from the ELF standard that we test it at+   many places" (comment for is_ia64_vms() in readelf.c). In this case, namesz,+   descsz and type fields are 8-byte words and name and value fields are padded+   to ensure 8-byte alignment.++   We don't support this platform in the following code. Reading a note section+   could be done easily (by testing Machine and OS fields in the ELF header).+   Writing a note section, however, requires that we generate a different+   assembly code for GAS depending on the target platform and this is a little+   bit more involved.++-}+++-- | ELF header+--+-- The ELF header indicates the native word size (32-bit or 64-bit) and the+-- endianness of the target machine. We directly store getters for words of+-- different sizes as it is more convenient to use. We also store the word size+-- as it is useful to skip some uninteresting fields.+--+-- Other information such as the target machine and OS are left out as we don't+-- use them yet. We could add them in the future if we ever need them.+data ElfHeader = ElfHeader+   { gw16     :: Get Word16   -- ^ Get a Word16 with the correct endianness+   , gw32     :: Get Word32   -- ^ Get a Word32 with the correct endianness+   , gwN      :: Get Word64   -- ^ Get a Word with the correct word size+                              --   and endianness+   , wordSize :: Int          -- ^ Word size in bytes+   }+++-- | Read the ELF header+readElfHeader :: DynFlags -> ByteString -> IO (Maybe ElfHeader)+readElfHeader dflags bs = runGetOrThrow getHeader bs `catchIO` \_ -> do+    debugTraceMsg dflags 3 $+      text ("Unable to read ELF header")+    return Nothing+  where+    getHeader = do+      magic    <- getWord32be+      ws       <- getWord8+      endian   <- getWord8+      version  <- getWord8+      skip 9  -- skip OSABI, ABI version and padding+      when (magic /= 0x7F454C46 || version /= 1) $ fail "Invalid ELF header"++      case (ws, endian) of+          -- ELF 32, little endian+          (1,1) -> return . Just $ ElfHeader+                           getWord16le+                           getWord32le+                           (fmap fromIntegral getWord32le) 4+          -- ELF 32, big endian+          (1,2) -> return . Just $ ElfHeader+                           getWord16be+                           getWord32be+                           (fmap fromIntegral getWord32be) 4+          -- ELF 64, little endian+          (2,1) -> return . Just $ ElfHeader+                           getWord16le+                           getWord32le+                           (fmap fromIntegral getWord64le) 8+          -- ELF 64, big endian+          (2,2) -> return . Just $ ElfHeader+                           getWord16be+                           getWord32be+                           (fmap fromIntegral getWord64be) 8+          _     -> fail "Invalid ELF header"+++------------------+-- SECTIONS+------------------+++-- | Description of the section table+data SectionTable = SectionTable+  { sectionTableOffset :: Word64  -- ^ offset of the table describing sections+  , sectionEntrySize   :: Word16  -- ^ size of an entry in the section table+  , sectionEntryCount  :: Word64  -- ^ number of sections+  , sectionNameIndex   :: Word32  -- ^ index of a special section which+                                  --   contains section's names+  }++-- | Read the ELF section table+readElfSectionTable :: DynFlags+                    -> ElfHeader+                    -> ByteString+                    -> IO (Maybe SectionTable)++readElfSectionTable dflags hdr bs = action `catchIO` \_ -> do+    debugTraceMsg dflags 3 $+      text ("Unable to read ELF section table")+    return Nothing+  where+    getSectionTable :: Get SectionTable+    getSectionTable = do+      skip (24 + 2*wordSize hdr) -- skip header and some other fields+      secTableOffset <- gwN hdr+      skip 10+      entrySize      <- gw16 hdr+      entryCount     <- gw16 hdr+      secNameIndex   <- gw16 hdr+      return (SectionTable secTableOffset entrySize+                           (fromIntegral entryCount)+                           (fromIntegral secNameIndex))++    action = do+      secTable <- runGetOrThrow getSectionTable bs+      -- In some cases, the number of entries and the index of the section+      -- containing section's names must be found in unused fields of the first+      -- section entry (see Note [ELF specification])+      let+        offSize0 = fromIntegral $ sectionTableOffset secTable + 8+                                  + 3 * fromIntegral (wordSize hdr)+        offLink0 = fromIntegral $ offSize0 + fromIntegral (wordSize hdr)++      entryCount'     <- if sectionEntryCount secTable /= 0+                          then return (sectionEntryCount secTable)+                          else runGetOrThrow (gwN hdr) (LBS.drop offSize0 bs)+      entryNameIndex' <- if sectionNameIndex secTable /= 0xffff+                          then return (sectionNameIndex secTable)+                          else runGetOrThrow (gw32 hdr) (LBS.drop offLink0 bs)+      return (Just $ secTable+        { sectionEntryCount = entryCount'+        , sectionNameIndex  = entryNameIndex'+        })+++-- | A section+data Section = Section+  { entryName :: ByteString   -- ^ Name of the section+  , entryBS   :: ByteString   -- ^ Content of the section+  }++-- | Read a ELF section+readElfSectionByIndex :: DynFlags+                      -> ElfHeader+                      -> SectionTable+                      -> Word64+                      -> ByteString+                      -> IO (Maybe Section)++readElfSectionByIndex dflags hdr secTable i bs = action `catchIO` \_ -> do+    debugTraceMsg dflags 3 $+      text ("Unable to read ELF section")+    return Nothing+  where+    -- read an entry from the section table+    getEntry = do+      nameIndex <- gw32 hdr+      skip (4+2*wordSize hdr)+      offset    <- fmap fromIntegral $ gwN hdr+      size      <- fmap fromIntegral $ gwN hdr+      let bs' = LBS.take size (LBS.drop offset bs)+      return (nameIndex,bs')++    -- read the entry with the given index in the section table+    getEntryByIndex x = runGetOrThrow getEntry bs'+      where+        bs' = LBS.drop off bs+        off = fromIntegral $ sectionTableOffset secTable ++                             x * fromIntegral (sectionEntrySize secTable)++    -- Get the name of a section+    getEntryName nameIndex = do+      let idx = fromIntegral (sectionNameIndex secTable)+      (_,nameTable) <- getEntryByIndex idx+      let bs' = LBS.drop nameIndex nameTable+      runGetOrThrow getLazyByteStringNul bs'++    action = do+      (nameIndex,bs') <- getEntryByIndex (fromIntegral i)+      name            <- getEntryName (fromIntegral nameIndex)+      return (Just $ Section name bs')+++-- | Find a section from its name. Return the section contents.+--+-- We do not perform any check on the section type.+findSectionFromName :: DynFlags+                    -> ElfHeader+                    -> SectionTable+                    -> String+                    -> ByteString+                    -> IO (Maybe ByteString)+findSectionFromName dflags hdr secTable name bs =+    rec [0..sectionEntryCount secTable - 1]+  where+    -- convert the required section name into a ByteString to perform+    -- ByteString comparison instead of String comparison+    name' = B8.pack name++    -- compare recursively each section name and return the contents of+    -- the matching one, if any+    rec []     = return Nothing+    rec (x:xs) = do+      me <- readElfSectionByIndex dflags hdr secTable x bs+      case me of+        Just e | entryName e == name' -> return (Just (entryBS e))+        _                             -> rec xs+++-- | Given a section name, read its contents as a ByteString.+--+-- If the section isn't found or if there is any parsing error, we return+-- Nothing+readElfSectionByName :: DynFlags+                     -> ByteString+                     -> String+                     -> IO (Maybe LBS.ByteString)++readElfSectionByName dflags bs name = action `catchIO` \_ -> do+    debugTraceMsg dflags 3 $+      text ("Unable to read ELF section \"" ++ name ++ "\"")+    return Nothing+  where+    action = runMaybeT $ do+      hdr      <- MaybeT $ readElfHeader dflags bs+      secTable <- MaybeT $ readElfSectionTable dflags hdr bs+      MaybeT $ findSectionFromName dflags hdr secTable name bs++------------------+-- NOTE SECTIONS+------------------++-- | read a Note as a ByteString+--+-- If you try to read a note from a section which does not support the Note+-- format, the parsing is likely to fail and Nothing will be returned+readElfNoteBS :: DynFlags+              -> ByteString+              -> String+              -> String+              -> IO (Maybe LBS.ByteString)++readElfNoteBS dflags bs sectionName noteId = action `catchIO`  \_ -> do+    debugTraceMsg dflags 3 $+         text ("Unable to read ELF note \"" ++ noteId +++               "\" in section \"" ++ sectionName ++ "\"")+    return Nothing+  where+    -- align the getter on n bytes+    align n = do+      m <- bytesRead+      if m `mod` n == 0+        then return ()+        else skip 1 >> align n++    -- noteId as a bytestring+    noteId' = B8.pack noteId++    -- read notes recursively until the one with a valid identifier is found+    findNote hdr = do+      align 4+      namesz <- gw32 hdr+      descsz <- gw32 hdr+      _      <- gw32 hdr -- we don't use the note type+      name   <- if namesz == 0+                  then return LBS.empty+                  else getLazyByteStringNul+      align 4+      desc  <- if descsz == 0+                  then return LBS.empty+                  else getLazyByteString (fromIntegral descsz)+      if name == noteId'+        then return $ Just desc+        else findNote hdr+++    action = runMaybeT $ do+      hdr  <- MaybeT $ readElfHeader dflags bs+      sec  <- MaybeT $ readElfSectionByName dflags bs sectionName+      MaybeT $ runGetOrThrow (findNote hdr) sec++-- | read a Note as a String+--+-- If you try to read a note from a section which does not support the Note+-- format, the parsing is likely to fail and Nothing will be returned+readElfNoteAsString :: DynFlags+                    -> FilePath+                    -> String+                    -> String+                    -> IO (Maybe String)++readElfNoteAsString dflags path sectionName noteId = action `catchIO`  \_ -> do+    debugTraceMsg dflags 3 $+         text ("Unable to read ELF note \"" ++ noteId +++               "\" in section \"" ++ sectionName ++ "\"")+    return Nothing+  where+    action = do+      bs   <- LBS.readFile path+      note <- readElfNoteBS dflags bs sectionName noteId+      return (fmap B8.unpack note)+++-- | Generate the GAS code to create a Note section+--+-- Header fields for notes are 32-bit long (see Note [ELF specification]).+--+-- It seems there is no easy way to force GNU AS to generate a 32-bit word in+-- every case. Hence we use .int directive to create them: however "The byte+-- order and bit size of the number depends on what kind of target the assembly+-- is for." (https://sourceware.org/binutils/docs/as/Int.html#Int)+--+-- If we add new target platforms, we need to check that the generated words+-- are 32-bit long, otherwise we need to use platform specific directives to+-- force 32-bit .int in asWord32.+makeElfNote :: DynFlags -> String -> String -> Word32 -> String -> SDoc+makeElfNote dflags sectionName noteName typ contents = hcat [+    text "\t.section ",+    text sectionName,+    text ",\"\",",+    text elfSectionNote,+    text "\n",++    -- note name length (+ 1 for ending \0)+    asWord32 (length noteName + 1),++    -- note contents size+    asWord32 (length contents),++    -- note type+    asWord32 typ,++    -- note name (.asciz for \0 ending string) + padding+    text "\t.asciz \"",+    text noteName,+    text "\"\n",+    text "\t.align 4\n",++    -- note contents (.ascii to avoid ending \0) + padding+    text "\t.ascii \"",+    text (escape contents),+    text "\"\n",+    text "\t.align 4\n"]+  where+    escape :: String -> String+    escape = concatMap (charToC.fromIntegral.ord)++    asWord32 :: Show a => a -> SDoc+    asWord32 x = hcat [+      text "\t.int ",+      text (show x),+      text "\n"]++    elfSectionNote :: String+    elfSectionNote = case platformArch (targetPlatform dflags) of+                             ArchARM _ _ _ -> "%note"+                             _             -> "@note"++++------------------+-- Helpers+------------------++-- | runGet in IO monad that throws an IOException on failure+runGetOrThrow :: Get a -> LBS.ByteString -> IO a+runGetOrThrow g bs = case runGetOrFail g bs of+  Left _        -> fail "Error while reading file"+  Right (_,_,a) -> return a
+ main/ErrUtils.hs view
@@ -0,0 +1,675 @@+{-+(c) The AQUA Project, Glasgow University, 1994-1998++\section[ErrsUtils]{Utilities for error reporting}+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RecordWildCards #-}++module ErrUtils (+        -- * Basic types+        Validity(..), andValid, allValid, isValid, getInvalids,+        Severity(..),++        -- * Messages+        ErrMsg, errMsgDoc,+        ErrDoc, errDoc, errDocImportant, errDocContext, errDocSupplementary,+        WarnMsg, MsgDoc,+        Messages, ErrorMessages, WarningMessages,+        unionMessages,+        errMsgSpan, errMsgContext,+        errorsFound, isEmptyMessages,+        isWarnMsgFatal,++        -- ** Formatting+        pprMessageBag, pprErrMsgBagWithLoc,+        pprLocErrMsg, printBagOfErrors,+        formatErrDoc,++        -- ** Construction+        emptyMessages, mkLocMessage, mkLocMessageAnn, makeIntoWarning,+        mkErrMsg, mkPlainErrMsg, mkErrDoc, mkLongErrMsg, mkWarnMsg,+        mkPlainWarnMsg,+        warnIsErrorMsg, mkLongWarnMsg,++        -- * Utilities+        doIfSet, doIfSet_dyn,+        getCaretDiagnostic,++        -- * Dump files+        dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer,+        mkDumpDoc, dumpSDoc,++        -- * Issuing messages during compilation+        putMsg, printInfoForUser, printOutputForUser,+        logInfo, logOutput,+        errorMsg, warningMsg,+        fatalErrorMsg, fatalErrorMsg'',+        compilationProgressMsg,+        showPass, withTiming,+        debugTraceMsg,+        ghcExit,+        prettyPrintGhcErrors,+    ) where++#include "HsVersions.h"++import Bag+import Exception+import Outputable+import Panic+import qualified PprColour as Col+import SrcLoc+import DynFlags+import FastString (unpackFS)+import StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)+import Json++import System.Directory+import System.Exit      ( ExitCode(..), exitWith )+import System.FilePath  ( takeDirectory, (</>) )+import Data.List+import qualified Data.Set as Set+import Data.IORef+import Data.Maybe       ( fromMaybe )+import Data.Ord+import Data.Time+import Control.Monad+import Control.Monad.IO.Class+import System.IO+import System.IO.Error  ( catchIOError )+import GHC.Conc         ( getAllocationCounter )+import System.CPUTime++-------------------------+type MsgDoc  = SDoc++-------------------------+data Validity+  = IsValid            -- ^ Everything is fine+  | NotValid MsgDoc    -- ^ A problem, and some indication of why++isValid :: Validity -> Bool+isValid IsValid       = True+isValid (NotValid {}) = False++andValid :: Validity -> Validity -> Validity+andValid IsValid v = v+andValid v _       = v++-- | If they aren't all valid, return the first+allValid :: [Validity] -> Validity+allValid []       = IsValid+allValid (v : vs) = v `andValid` allValid vs++getInvalids :: [Validity] -> [MsgDoc]+getInvalids vs = [d | NotValid d <- vs]++-- -----------------------------------------------------------------------------+-- Basic error messages: just render a message with a source location.++type Messages        = (WarningMessages, ErrorMessages)+type WarningMessages = Bag WarnMsg+type ErrorMessages   = Bag ErrMsg++unionMessages :: Messages -> Messages -> Messages+unionMessages (warns1, errs1) (warns2, errs2) =+  (warns1 `unionBags` warns2, errs1 `unionBags` errs2)++data ErrMsg = ErrMsg {+        errMsgSpan        :: SrcSpan,+        errMsgContext     :: PrintUnqualified,+        errMsgDoc         :: ErrDoc,+        -- | This has the same text as errDocImportant . errMsgDoc.+        errMsgShortString :: String,+        errMsgSeverity    :: Severity,+        errMsgReason      :: WarnReason+        }+        -- The SrcSpan is used for sorting errors into line-number order+++-- | Categorise error msgs by their importance.  This is so each section can+-- be rendered visually distinct.  See Note [Error report] for where these come+-- from.+data ErrDoc = ErrDoc {+        -- | Primary error msg.+        errDocImportant     :: [MsgDoc],+        -- | Context e.g. \"In the second argument of ...\".+        errDocContext       :: [MsgDoc],+        -- | Supplementary information, e.g. \"Relevant bindings include ...\".+        errDocSupplementary :: [MsgDoc]+        }++errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc+errDoc = ErrDoc++type WarnMsg = ErrMsg++data Severity+  = SevOutput+  | SevFatal+  | SevInteractive++  | SevDump+    -- ^ Log messagse intended for compiler developers+    -- No file/line/column stuff++  | SevInfo+    -- ^ Log messages intended for end users.+    -- No file/line/column stuff.++  | SevWarning+  | SevError+    -- ^ SevWarning and SevError are used for warnings and errors+    --   o The message has a file/line/column heading,+    --     plus "warning:" or "error:",+    --     added by mkLocMessags+    --   o Output is intended for end users+  deriving Show+++instance ToJson Severity where+  json s = JSString (show s)+++instance Show ErrMsg where+    show em = errMsgShortString em++pprMessageBag :: Bag MsgDoc -> SDoc+pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))++-- | Make an unannotated error message with location info.+mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc+mkLocMessage = mkLocMessageAnn Nothing++-- | Make a possibly annotated error message with location info.+mkLocMessageAnn+  :: Maybe String                       -- ^ optional annotation+  -> Severity                           -- ^ severity+  -> SrcSpan                            -- ^ location+  -> MsgDoc                             -- ^ message+  -> MsgDoc+  -- Always print the location, even if it is unhelpful.  Error messages+  -- are supposed to be in a standard format, and one without a location+  -- would look strange.  Better to say explicitly "<no location info>".+mkLocMessageAnn ann severity locn msg+    = sdocWithDynFlags $ \dflags ->+      let locn' = if gopt Opt_ErrorSpans dflags+                  then ppr locn+                  else ppr (srcSpanStart locn)++          sevColour = getSeverityColour severity (colScheme dflags)++          -- Add optional information+          optAnn = case ann of+            Nothing -> text ""+            Just i  -> text " [" <> coloured sevColour (text i) <> text "]"++          -- Add prefixes, like    Foo.hs:34: warning:+          --                           <the warning message>+          header = locn' <> colon <+>+                   coloured sevColour sevText <> optAnn++      in coloured (Col.sMessage (colScheme dflags))+                  (hang (coloured (Col.sHeader (colScheme dflags)) header) 4+                        msg)++  where+    sevText =+      case severity of+        SevWarning -> text "warning:"+        SevError   -> text "error:"+        SevFatal   -> text "fatal:"+        _          -> empty++getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour+getSeverityColour SevWarning = Col.sWarning+getSeverityColour SevError   = Col.sError+getSeverityColour SevFatal   = Col.sFatal+getSeverityColour _          = const mempty++getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc+getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty+getCaretDiagnostic severity (RealSrcSpan span) = do+  caretDiagnostic <$> getSrcLine (srcSpanFile span) row++  where+    getSrcLine fn i =+      getLine i (unpackFS fn)+        `catchIOError` \_ ->+          pure Nothing++    getLine i fn = do+      -- StringBuffer has advantages over readFile:+      -- (a) no lazy IO, otherwise IO exceptions may occur in pure code+      -- (b) always UTF-8, rather than some system-dependent encoding+      --     (Haskell source code must be UTF-8 anyway)+      content <- hGetStringBuffer fn+      case atLine i content of+        Just at_line -> pure $+          case lines (fix <$> lexemeToString at_line (len at_line)) of+            srcLine : _ -> Just srcLine+            _           -> Nothing+        _ -> pure Nothing++    -- allow user to visibly see that their code is incorrectly encoded+    -- (StringBuffer.nextChar uses \0 to represent undecodable characters)+    fix '\0' = '\xfffd'+    fix c    = c++    row = srcSpanStartLine span+    rowStr = show row+    multiline = row /= srcSpanEndLine span++    caretDiagnostic Nothing = empty+    caretDiagnostic (Just srcLineWithNewline) =+      sdocWithDynFlags $ \ dflags ->+      let sevColour = getSeverityColour severity (colScheme dflags)+          marginColour = Col.sMargin (colScheme dflags)+      in+      coloured marginColour (text marginSpace) <>+      text ("\n") <>+      coloured marginColour (text marginRow) <>+      text (" " ++ srcLinePre) <>+      coloured sevColour (text srcLineSpan) <>+      text (srcLinePost ++ "\n") <>+      coloured marginColour (text marginSpace) <>+      coloured sevColour (text (" " ++ caretLine))++      where++        -- expand tabs in a device-independent manner #13664+        expandTabs tabWidth i s =+          case s of+            ""        -> ""+            '\t' : cs -> replicate effectiveWidth ' ' +++                         expandTabs tabWidth (i + effectiveWidth) cs+            c    : cs -> c : expandTabs tabWidth (i + 1) cs+          where effectiveWidth = tabWidth - i `mod` tabWidth++        srcLine = filter (/= '\n') (expandTabs 8 0 srcLineWithNewline)++        start = srcSpanStartCol span - 1+        end | multiline = length srcLine+            | otherwise = srcSpanEndCol span - 1+        width = max 1 (end - start)++        marginWidth = length rowStr+        marginSpace = replicate marginWidth ' ' ++ " |"+        marginRow   = rowStr ++ " |"++        (srcLinePre,  srcLineRest) = splitAt start srcLine+        (srcLineSpan, srcLinePost) = splitAt width srcLineRest++        caretEllipsis | multiline = "..."+                      | otherwise = ""+        caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis++makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg+makeIntoWarning reason err = err+    { errMsgSeverity = SevWarning+    , errMsgReason = reason }++-- -----------------------------------------------------------------------------+-- Collecting up messages for later ordering and printing.++mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg+mk_err_msg dflags sev locn print_unqual doc+ = ErrMsg { errMsgSpan = locn+          , errMsgContext = print_unqual+          , errMsgDoc = doc+          , errMsgShortString = showSDoc dflags (vcat (errDocImportant doc))+          , errMsgSeverity = sev+          , errMsgReason = NoReason }++mkErrDoc :: DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg+mkErrDoc dflags = mk_err_msg dflags SevError++mkLongErrMsg, mkLongWarnMsg   :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg+-- ^ A long (multi-line) error message+mkErrMsg, mkWarnMsg           :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc            -> ErrMsg+-- ^ A short (one-line) error message+mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan ->                     MsgDoc            -> ErrMsg+-- ^ Variant that doesn't care about qualified/unqualified names++mkLongErrMsg   dflags locn unqual msg extra = mk_err_msg dflags SevError   locn unqual        (ErrDoc [msg] [] [extra])+mkErrMsg       dflags locn unqual msg       = mk_err_msg dflags SevError   locn unqual        (ErrDoc [msg] [] [])+mkPlainErrMsg  dflags locn        msg       = mk_err_msg dflags SevError   locn alwaysQualify (ErrDoc [msg] [] [])+mkLongWarnMsg  dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual        (ErrDoc [msg] [] [extra])+mkWarnMsg      dflags locn unqual msg       = mk_err_msg dflags SevWarning locn unqual        (ErrDoc [msg] [] [])+mkPlainWarnMsg dflags locn        msg       = mk_err_msg dflags SevWarning locn alwaysQualify (ErrDoc [msg] [] [])++----------------+emptyMessages :: Messages+emptyMessages = (emptyBag, emptyBag)++isEmptyMessages :: Messages -> Bool+isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs++warnIsErrorMsg :: DynFlags -> ErrMsg+warnIsErrorMsg dflags+    = mkPlainErrMsg dflags noSrcSpan (text "\nFailing due to -Werror.")++errorsFound :: DynFlags -> Messages -> Bool+errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)++printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()+printBagOfErrors dflags bag_of_errors+  = sequence_ [ let style = mkErrStyle dflags unqual+                in putLogMsg dflags reason sev s style (formatErrDoc dflags doc)+              | ErrMsg { errMsgSpan      = s,+                         errMsgDoc       = doc,+                         errMsgSeverity  = sev,+                         errMsgReason    = reason,+                         errMsgContext   = unqual } <- sortMsgBag (Just dflags)+                                                                  bag_of_errors ]++formatErrDoc :: DynFlags -> ErrDoc -> SDoc+formatErrDoc dflags (ErrDoc important context supplementary)+  = case msgs of+        [msg] -> vcat msg+        _ -> vcat $ map starred msgs+    where+    msgs = filter (not . null) $ map (filter (not . Outputable.isEmpty dflags))+        [important, context, supplementary]+    starred = (bullet<+>) . vcat++pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc]+pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag Nothing bag ]++pprLocErrMsg :: ErrMsg -> SDoc+pprLocErrMsg (ErrMsg { errMsgSpan      = s+                     , errMsgDoc       = doc+                     , errMsgSeverity  = sev+                     , errMsgContext   = unqual })+  = sdocWithDynFlags $ \dflags ->+    withPprStyle (mkErrStyle dflags unqual) $+    mkLocMessage sev s (formatErrDoc dflags doc)++sortMsgBag :: Maybe DynFlags -> Bag ErrMsg -> [ErrMsg]+sortMsgBag dflags = maybeLimit . sortBy (maybeFlip cmp) . bagToList+  where maybeFlip :: (a -> a -> b) -> (a -> a -> b)+        maybeFlip+          | fromMaybe False (fmap reverseErrors dflags) = flip+          | otherwise                                   = id+        cmp = comparing errMsgSpan+        maybeLimit = case join (fmap maxErrors dflags) of+          Nothing        -> id+          Just err_limit -> take err_limit++ghcExit :: DynFlags -> Int -> IO ()+ghcExit dflags val+  | val == 0  = exitWith ExitSuccess+  | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n")+                   exitWith (ExitFailure val)++doIfSet :: Bool -> IO () -> IO ()+doIfSet flag action | flag      = action+                    | otherwise = return ()++doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO()+doIfSet_dyn dflags flag action | gopt flag dflags = action+                               | otherwise        = return ()++-- -----------------------------------------------------------------------------+-- Dumping++dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()+dumpIfSet dflags flag hdr doc+  | not flag   = return ()+  | otherwise  = putLogMsg  dflags+                            NoReason+                            SevDump+                            noSrcSpan+                            (defaultDumpStyle dflags)+                            (mkDumpDoc hdr doc)++-- | a wrapper around 'dumpSDoc'.+-- First check whether the dump flag is set+-- Do nothing if it is unset+dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()+dumpIfSet_dyn dflags flag hdr doc+  = when (dopt flag dflags) $ dumpSDoc dflags alwaysQualify flag hdr doc++-- | a wrapper around 'dumpSDoc'.+-- First check whether the dump flag is set+-- Do nothing if it is unset+--+-- Unlike 'dumpIfSet_dyn',+-- has a printer argument but no header argument+dumpIfSet_dyn_printer :: PrintUnqualified+                      -> DynFlags -> DumpFlag -> SDoc -> IO ()+dumpIfSet_dyn_printer printer dflags flag doc+  = when (dopt flag dflags) $ dumpSDoc dflags printer flag "" doc++mkDumpDoc :: String -> SDoc -> SDoc+mkDumpDoc hdr doc+   = vcat [blankLine,+           line <+> text hdr <+> line,+           doc,+           blankLine]+     where+        line = text (replicate 20 '=')+++-- | Write out a dump.+-- If --dump-to-file is set then this goes to a file.+-- otherwise emit to stdout.+--+-- When @hdr@ is empty, we print in a more compact format (no separators and+-- blank lines)+--+-- The 'DumpFlag' is used only to choose the filename to use if @--dump-to-file@+-- is used; it is not used to decide whether to dump the output+dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()+dumpSDoc dflags print_unqual flag hdr doc+ = do let mFile = chooseDumpFile dflags flag+          dump_style = mkDumpStyle dflags print_unqual+      case mFile of+            Just fileName+                 -> do+                        let gdref = generatedDumps dflags+                        gd <- readIORef gdref+                        let append = Set.member fileName gd+                            mode = if append then AppendMode else WriteMode+                        unless append $+                            writeIORef gdref (Set.insert fileName gd)+                        createDirectoryIfMissing True (takeDirectory fileName)+                        handle <- openFile fileName mode++                        -- We do not want the dump file to be affected by+                        -- environment variables, but instead to always use+                        -- UTF8. See:+                        -- https://ghc.haskell.org/trac/ghc/ticket/10762+                        hSetEncoding handle utf8++                        doc' <- if null hdr+                                then return doc+                                else do t <- getCurrentTime+                                        let d = text (show t)+                                             $$ blankLine+                                             $$ doc+                                        return $ mkDumpDoc hdr d+                        defaultLogActionHPrintDoc dflags handle doc' dump_style+                        hClose handle++            -- write the dump to stdout+            Nothing -> do+              let (doc', severity)+                    | null hdr  = (doc, SevOutput)+                    | otherwise = (mkDumpDoc hdr doc, SevDump)+              putLogMsg dflags NoReason severity noSrcSpan dump_style doc'+++-- | Choose where to put a dump file based on DynFlags+--+chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath+chooseDumpFile dflags flag++        | gopt Opt_DumpToFile dflags || flag == Opt_D_th_dec_file+        , Just prefix <- getPrefix+        = Just $ setDir (prefix ++ (beautifyDumpName flag))++        | otherwise+        = Nothing++        where getPrefix+                 -- dump file location is being forced+                 --      by the --ddump-file-prefix flag.+               | Just prefix <- dumpPrefixForce dflags+                  = Just prefix+                 -- dump file location chosen by DriverPipeline.runPipeline+               | Just prefix <- dumpPrefix dflags+                  = Just prefix+                 -- we haven't got a place to put a dump file.+               | otherwise+                  = Nothing+              setDir f = case dumpDir dflags of+                         Just d  -> d </> f+                         Nothing ->       f++-- | Build a nice file name from name of a 'DumpFlag' constructor+beautifyDumpName :: DumpFlag -> String+beautifyDumpName Opt_D_th_dec_file = "th.hs"+beautifyDumpName flag+ = let str = show flag+       suff = case stripPrefix "Opt_D_" str of+              Just x -> x+              Nothing -> panic ("Bad flag name: " ++ str)+       dash = map (\c -> if c == '_' then '-' else c) suff+   in dash+++-- -----------------------------------------------------------------------------+-- Outputting messages from the compiler++-- We want all messages to go through one place, so that we can+-- redirect them if necessary.  For example, when GHC is used as a+-- library we might want to catch all messages that GHC tries to+-- output and do something else with them.++ifVerbose :: DynFlags -> Int -> IO () -> IO ()+ifVerbose dflags val act+  | verbosity dflags >= val = act+  | otherwise               = return ()++errorMsg :: DynFlags -> MsgDoc -> IO ()+errorMsg dflags msg+   = putLogMsg dflags NoReason SevError noSrcSpan (defaultErrStyle dflags) msg++warningMsg :: DynFlags -> MsgDoc -> IO ()+warningMsg dflags msg+   = putLogMsg dflags NoReason SevWarning noSrcSpan (defaultErrStyle dflags) msg++fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()+fatalErrorMsg dflags msg =+    putLogMsg dflags NoReason SevFatal noSrcSpan (defaultErrStyle dflags) msg++fatalErrorMsg'' :: FatalMessager -> String -> IO ()+fatalErrorMsg'' fm msg = fm msg++compilationProgressMsg :: DynFlags -> String -> IO ()+compilationProgressMsg dflags msg+  = ifVerbose dflags 1 $+    logOutput dflags (defaultUserStyle dflags) (text msg)++showPass :: DynFlags -> String -> IO ()+showPass dflags what+  = ifVerbose dflags 2 $+    logInfo dflags (defaultUserStyle dflags) (text "***" <+> text what <> colon)++-- | Time a compilation phase.+--+-- When timings are enabled (e.g. with the @-v2@ flag), the allocations+-- and CPU time used by the phase will be reported to stderr. Consider+-- a typical usage: @withTiming getDynFlags (text "simplify") force pass@.+-- When timings are enabled the following costs are included in the+-- produced accounting,+--+--  - The cost of executing @pass@ to a result @r@ in WHNF+--  - The cost of evaluating @force r@ to WHNF (e.g. @()@)+--+-- The choice of the @force@ function depends upon the amount of forcing+-- desired; the goal here is to ensure that the cost of evaluating the result+-- is, to the greatest extent possible, included in the accounting provided by+-- 'withTiming'. Often the pass already sufficiently forces its result during+-- construction; in this case @const ()@ is a reasonable choice.+-- In other cases, it is necessary to evaluate the result to normal form, in+-- which case something like @Control.DeepSeq.rnf@ is appropriate.+--+-- To avoid adversely affecting compiler performance when timings are not+-- requested, the result is only forced when timings are enabled.+withTiming :: MonadIO m+           => m DynFlags  -- ^ A means of getting a 'DynFlags' (often+                          -- 'getDynFlags' will work here)+           -> SDoc        -- ^ The name of the phase+           -> (a -> ())   -- ^ A function to force the result+                          -- (often either @const ()@ or 'rnf')+           -> m a         -- ^ The body of the phase to be timed+           -> m a+withTiming getDFlags what force_result action+  = do dflags <- getDFlags+       if verbosity dflags >= 2+          then do liftIO $ logInfo dflags (defaultUserStyle dflags)+                         $ text "***" <+> what <> colon+                  alloc0 <- liftIO getAllocationCounter+                  start <- liftIO getCPUTime+                  !r <- action+                  () <- pure $ force_result r+                  end <- liftIO getCPUTime+                  alloc1 <- liftIO getAllocationCounter+                  -- recall that allocation counter counts down+                  let alloc = alloc0 - alloc1+                  liftIO $ logInfo dflags (defaultUserStyle dflags)+                      (text "!!!" <+> what <> colon <+> text "finished in"+                       <+> doublePrec 2 (realToFrac (end - start) * 1e-9)+                       <+> text "milliseconds"+                       <> comma+                       <+> text "allocated"+                       <+> doublePrec 3 (realToFrac alloc / 1024 / 1024)+                       <+> text "megabytes")+                  pure r+           else action++debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()+debugTraceMsg dflags val msg = ifVerbose dflags val $+                               logInfo dflags (defaultDumpStyle dflags) msg+putMsg :: DynFlags -> MsgDoc -> IO ()+putMsg dflags msg = logInfo dflags (defaultUserStyle dflags) msg++printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()+printInfoForUser dflags print_unqual msg+  = logInfo dflags (mkUserStyle dflags print_unqual AllTheWay) msg++printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()+printOutputForUser dflags print_unqual msg+  = logOutput dflags (mkUserStyle dflags print_unqual AllTheWay) msg++logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO ()+logInfo dflags sty msg+  = putLogMsg dflags NoReason SevInfo noSrcSpan sty msg++logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO ()+-- ^ Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'+logOutput dflags sty msg+  = putLogMsg dflags NoReason SevOutput noSrcSpan sty msg++prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a+prettyPrintGhcErrors dflags+    = ghandle $ \e -> case e of+                      PprPanic str doc ->+                          pprDebugAndThen dflags panic (text str) doc+                      PprSorry str doc ->+                          pprDebugAndThen dflags sorry (text str) doc+                      PprProgramError str doc ->+                          pprDebugAndThen dflags pgmError (text str) doc+                      _ ->+                          liftIO $ throwIO e++-- | Checks if given 'WarnMsg' is a fatal warning.+isWarnMsgFatal :: DynFlags -> WarnMsg -> Bool+isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag}+  = wopt_fatal wflag dflags+isWarnMsgFatal dflags _ = gopt Opt_WarnIsError dflags
+ main/ErrUtils.hs-boot view
@@ -0,0 +1,25 @@+module ErrUtils where++import Outputable (SDoc, PrintUnqualified )+import SrcLoc (SrcSpan)+import Json+import {-# SOURCE #-} DynFlags ( DynFlags, DumpFlag )++data Severity+  = SevOutput+  | SevFatal+  | SevInteractive+  | SevDump+  | SevInfo+  | SevWarning+  | SevError+++type MsgDoc = SDoc++mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc+mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc+getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc+dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()++instance ToJson Severity
+ main/Finder.hs view
@@ -0,0 +1,776 @@+{-+(c) The University of Glasgow, 2000-2006++\section[Finder]{Module Finder}+-}++{-# LANGUAGE CPP #-}++module Finder (+    flushFinderCaches,+    FindResult(..),+    findImportedModule,+    findPluginModule,+    findExactModule,+    findHomeModule,+    findExposedPackageModule,+    mkHomeModLocation,+    mkHomeModLocation2,+    mkHiOnlyModLocation,+    mkHiPath,+    mkObjPath,+    addHomeModuleToFinder,+    uncacheModule,+    mkStubPaths,++    findObjectLinkableMaybe,+    findObjectLinkable,++    cannotFindModule,+    cannotFindInterface,++  ) where++#include "HsVersions.h"++import Module+import HscTypes+import Packages+import FastString+import Util+import PrelNames        ( gHC_PRIM )+import DynFlags+import Outputable+import Maybes           ( expectJust )++import Data.IORef       ( IORef, readIORef, atomicModifyIORef' )+import System.Directory+import System.FilePath+import Control.Monad+import Data.Time+import Data.List        ( foldl' )+++type FileExt = String   -- Filename extension+type BaseName = String  -- Basename of file++-- -----------------------------------------------------------------------------+-- The Finder++-- The Finder provides a thin filesystem abstraction to the rest of+-- the compiler.  For a given module, it can tell you where the+-- source, interface, and object files for that module live.++-- It does *not* know which particular package a module lives in.  Use+-- Packages.lookupModuleInAllPackages for that.++-- -----------------------------------------------------------------------------+-- The finder's cache++-- remove all the home modules from the cache; package modules are+-- assumed to not move around during a session.+flushFinderCaches :: HscEnv -> IO ()+flushFinderCaches hsc_env =+  atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ())+ where+        this_pkg = thisPackage (hsc_dflags hsc_env)+        fc_ref = hsc_FC hsc_env+        is_ext mod _ | not (installedModuleUnitId mod `installedUnitIdEq` this_pkg) = True+                     | otherwise = False++addToFinderCache :: IORef FinderCache -> InstalledModule -> InstalledFindResult -> IO ()+addToFinderCache ref key val =+  atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ())++removeFromFinderCache :: IORef FinderCache -> InstalledModule -> IO ()+removeFromFinderCache ref key =+  atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ())++lookupFinderCache :: IORef FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult)+lookupFinderCache ref key = do+   c <- readIORef ref+   return $! lookupInstalledModuleEnv c key++-- -----------------------------------------------------------------------------+-- The three external entry points++-- | Locate a module that was imported by the user.  We have the+-- module's name, and possibly a package name.  Without a package+-- name, this function will use the search path and the known exposed+-- packages to find the module, if a package is specified then only+-- that package is searched for the module.++findImportedModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult+findImportedModule hsc_env mod_name mb_pkg =+  case mb_pkg of+        Nothing                        -> unqual_import+        Just pkg | pkg == fsLit "this" -> home_import -- "this" is special+                 | otherwise           -> pkg_import+  where+    home_import   = findHomeModule hsc_env mod_name++    pkg_import    = findExposedPackageModule hsc_env mod_name mb_pkg++    unqual_import = home_import+                    `orIfNotFound`+                    findExposedPackageModule hsc_env mod_name Nothing++-- | Locate a plugin module requested by the user, for a compiler+-- plugin.  This consults the same set of exposed packages as+-- 'findImportedModule', unless @-hide-all-plugin-packages@ or+-- @-plugin-package@ are specified.+findPluginModule :: HscEnv -> ModuleName -> IO FindResult+findPluginModule hsc_env mod_name =+  findHomeModule hsc_env mod_name+  `orIfNotFound`+  findExposedPluginPackageModule hsc_env mod_name++-- | Locate a specific 'Module'.  The purpose of this function is to+-- create a 'ModLocation' for a given 'Module', that is to find out+-- where the files associated with this module live.  It is used when+-- reading the interface for a module mentioned by another interface,+-- for example (a "system import").++findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult+findExactModule hsc_env mod =+    let dflags = hsc_dflags hsc_env+    in if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags+       then findInstalledHomeModule hsc_env (installedModuleName mod)+       else findPackageModule hsc_env mod++-- -----------------------------------------------------------------------------+-- Helpers++-- | Given a monadic actions @this@ and @or_this@, first execute+-- @this@.  If the returned 'FindResult' is successful, return+-- it; otherwise, execute @or_this@.  If both failed, this function+-- also combines their failure messages in a reasonable way.+orIfNotFound :: Monad m => m FindResult -> m FindResult -> m FindResult+orIfNotFound this or_this = do+  res <- this+  case res of+    NotFound { fr_paths = paths1, fr_mods_hidden = mh1+             , fr_pkgs_hidden = ph1, fr_suggestions = s1 }+     -> do res2 <- or_this+           case res2 of+             NotFound { fr_paths = paths2, fr_pkg = mb_pkg2, fr_mods_hidden = mh2+                      , fr_pkgs_hidden = ph2, fr_suggestions = s2 }+              -> return (NotFound { fr_paths = paths1 ++ paths2+                                  , fr_pkg = mb_pkg2 -- snd arg is the package search+                                  , fr_mods_hidden = mh1 ++ mh2+                                  , fr_pkgs_hidden = ph1 ++ ph2+                                  , fr_suggestions = s1  ++ s2 })+             _other -> return res2+    _other -> return res++-- | Helper function for 'findHomeModule': this function wraps an IO action+-- which would look up @mod_name@ in the file system (the home package),+-- and first consults the 'hsc_FC' cache to see if the lookup has already+-- been done.  Otherwise, do the lookup (with the IO action) and save+-- the result in the finder cache and the module location cache (if it+-- was successful.)+homeSearchCache :: HscEnv -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult+homeSearchCache hsc_env mod_name do_this = do+  let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name+  modLocationCache hsc_env mod do_this++findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString+                         -> IO FindResult+findExposedPackageModule hsc_env mod_name mb_pkg+  = findLookupResult hsc_env+  $ lookupModuleWithSuggestions+        (hsc_dflags hsc_env) mod_name mb_pkg++findExposedPluginPackageModule :: HscEnv -> ModuleName+                               -> IO FindResult+findExposedPluginPackageModule hsc_env mod_name+  = findLookupResult hsc_env+  $ lookupPluginModuleWithSuggestions+        (hsc_dflags hsc_env) mod_name Nothing++findLookupResult :: HscEnv -> LookupResult -> IO FindResult+findLookupResult hsc_env r = case r of+     LookupFound m pkg_conf -> do+       let im = fst (splitModuleInsts m)+       r' <- findPackageModule_ hsc_env im pkg_conf+       case r' of+        -- TODO: ghc -M is unlikely to do the right thing+        -- with just the location of the thing that was+        -- instantiated; you probably also need all of the+        -- implicit locations from the instances+        InstalledFound loc   _ -> return (Found loc m)+        InstalledNoPackage   _ -> return (NoPackage (moduleUnitId m))+        InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnitId m)+                                         , fr_pkgs_hidden = []+                                         , fr_mods_hidden = []+                                         , fr_suggestions = []})+     LookupMultiple rs ->+       return (FoundMultiple rs)+     LookupHidden pkg_hiddens mod_hiddens ->+       return (NotFound{ fr_paths = [], fr_pkg = Nothing+                       , fr_pkgs_hidden = map (moduleUnitId.fst) pkg_hiddens+                       , fr_mods_hidden = map (moduleUnitId.fst) mod_hiddens+                       , fr_suggestions = [] })+     LookupNotFound suggest ->+       return (NotFound{ fr_paths = [], fr_pkg = Nothing+                       , fr_pkgs_hidden = []+                       , fr_mods_hidden = []+                       , fr_suggestions = suggest })++modLocationCache :: HscEnv -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult+modLocationCache hsc_env mod do_this = do+  m <- lookupFinderCache (hsc_FC hsc_env) mod+  case m of+    Just result -> return result+    Nothing     -> do+        result <- do_this+        addToFinderCache (hsc_FC hsc_env) mod result+        return result++mkHomeInstalledModule :: DynFlags -> ModuleName -> InstalledModule+mkHomeInstalledModule dflags mod_name =+  let iuid = fst (splitUnitIdInsts (thisPackage dflags))+  in InstalledModule iuid mod_name++-- This returns a module because it's more convenient for users+addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module+addHomeModuleToFinder hsc_env mod_name loc = do+  let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name+  addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod)+  return (mkModule (thisPackage (hsc_dflags hsc_env)) mod_name)++uncacheModule :: HscEnv -> ModuleName -> IO ()+uncacheModule hsc_env mod_name = do+  let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name+  removeFromFinderCache (hsc_FC hsc_env) mod++-- -----------------------------------------------------------------------------+--      The internal workers++findHomeModule :: HscEnv -> ModuleName -> IO FindResult+findHomeModule hsc_env mod_name = do+  r <- findInstalledHomeModule hsc_env mod_name+  return $ case r of+    InstalledFound loc _ -> Found loc (mkModule uid mod_name)+    InstalledNoPackage _ -> NoPackage uid -- impossible+    InstalledNotFound fps _ -> NotFound {+        fr_paths = fps,+        fr_pkg = Just uid,+        fr_mods_hidden = [],+        fr_pkgs_hidden = [],+        fr_suggestions = []+      }+ where+  dflags = hsc_dflags hsc_env+  uid = thisPackage dflags++-- | Implements the search for a module name in the home package only.  Calling+-- this function directly is usually *not* what you want; currently, it's used+-- as a building block for the following operations:+--+--  1. When you do a normal package lookup, we first check if the module+--  is available in the home module, before looking it up in the package+--  database.+--+--  2. When you have a package qualified import with package name "this",+--  we shortcut to the home module.+--+--  3. When we look up an exact 'Module', if the unit id associated with+--  the module is the current home module do a look up in the home module.+--+--  4. Some special-case code in GHCi (ToDo: Figure out why that needs to+--  call this.)+findInstalledHomeModule :: HscEnv -> ModuleName -> IO InstalledFindResult+findInstalledHomeModule hsc_env mod_name =+   homeSearchCache hsc_env mod_name $+   let+     dflags = hsc_dflags hsc_env+     home_path = importPaths dflags+     hisuf = hiSuf dflags+     mod = mkHomeInstalledModule dflags mod_name++     source_exts =+      [ ("hs",   mkHomeModLocationSearched dflags mod_name "hs")+      , ("lhs",  mkHomeModLocationSearched dflags mod_name "lhs")+      , ("hsig",  mkHomeModLocationSearched dflags mod_name "hsig")+      , ("lhsig",  mkHomeModLocationSearched dflags mod_name "lhsig")+      ]++     hi_exts = [ (hisuf,                mkHiOnlyModLocation dflags hisuf)+               , (addBootSuffix hisuf,  mkHiOnlyModLocation dflags hisuf)+               ]++        -- In compilation manager modes, we look for source files in the home+        -- package because we can compile these automatically.  In one-shot+        -- compilation mode we look for .hi and .hi-boot files only.+     exts | isOneShot (ghcMode dflags) = hi_exts+          | otherwise                  = source_exts+   in++  -- special case for GHC.Prim; we won't find it in the filesystem.+  -- This is important only when compiling the base package (where GHC.Prim+  -- is a home module).+  if mod `installedModuleEq` gHC_PRIM+        then return (InstalledFound (error "GHC.Prim ModLocation") mod)+        else searchPathExts home_path mod exts+++-- | Search for a module in external packages only.+findPackageModule :: HscEnv -> InstalledModule -> IO InstalledFindResult+findPackageModule hsc_env mod = do+  let+        dflags = hsc_dflags hsc_env+        pkg_id = installedModuleUnitId mod+  --+  case lookupInstalledPackage dflags pkg_id of+     Nothing -> return (InstalledNoPackage pkg_id)+     Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf++-- | Look up the interface file associated with module @mod@.  This function+-- requires a few invariants to be upheld: (1) the 'Module' in question must+-- be the module identifier of the *original* implementation of a module,+-- not a reexport (this invariant is upheld by @Packages.hs@) and (2)+-- the 'PackageConfig' must be consistent with the unit id in the 'Module'.+-- The redundancy is to avoid an extra lookup in the package state+-- for the appropriate config.+findPackageModule_ :: HscEnv -> InstalledModule -> PackageConfig -> IO InstalledFindResult+findPackageModule_ hsc_env mod pkg_conf =+  ASSERT2( installedModuleUnitId mod == installedPackageConfigId pkg_conf, ppr (installedModuleUnitId mod) <+> ppr (installedPackageConfigId pkg_conf) )+  modLocationCache hsc_env mod $++  -- special case for GHC.Prim; we won't find it in the filesystem.+  if mod `installedModuleEq` gHC_PRIM+        then return (InstalledFound (error "GHC.Prim ModLocation") mod)+        else++  let+     dflags = hsc_dflags hsc_env+     tag = buildTag dflags++           -- hi-suffix for packages depends on the build tag.+     package_hisuf | null tag  = "hi"+                   | otherwise = tag ++ "_hi"++     mk_hi_loc = mkHiOnlyModLocation dflags package_hisuf++     import_dirs = importDirs pkg_conf+      -- we never look for a .hi-boot file in an external package;+      -- .hi-boot files only make sense for the home package.+  in+  case import_dirs of+    [one] | MkDepend <- ghcMode dflags -> do+          -- there's only one place that this .hi file can be, so+          -- don't bother looking for it.+          let basename = moduleNameSlashes (installedModuleName mod)+          loc <- mk_hi_loc one basename+          return (InstalledFound loc mod)+    _otherwise ->+          searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)]++-- -----------------------------------------------------------------------------+-- General path searching++searchPathExts+  :: [FilePath]         -- paths to search+  -> InstalledModule             -- module name+  -> [ (+        FileExt,                                -- suffix+        FilePath -> BaseName -> IO ModLocation  -- action+       )+     ]+  -> IO InstalledFindResult++searchPathExts paths mod exts+   = do result <- search to_search+{-+        hPutStrLn stderr (showSDoc $+                vcat [text "Search" <+> ppr mod <+> sep (map (text. fst) exts)+                    , nest 2 (vcat (map text paths))+                    , case result of+                        Succeeded (loc, p) -> text "Found" <+> ppr loc+                        Failed fs          -> text "not found"])+-}+        return result++  where+    basename = moduleNameSlashes (installedModuleName mod)++    to_search :: [(FilePath, IO ModLocation)]+    to_search = [ (file, fn path basename)+                | path <- paths,+                  (ext,fn) <- exts,+                  let base | path == "." = basename+                           | otherwise   = path </> basename+                      file = base <.> ext+                ]++    search [] = return (InstalledNotFound (map fst to_search) (Just (installedModuleUnitId mod)))++    search ((file, mk_result) : rest) = do+      b <- doesFileExist file+      if b+        then do { loc <- mk_result; return (InstalledFound loc mod) }+        else search rest++mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt+                          -> FilePath -> BaseName -> IO ModLocation+mkHomeModLocationSearched dflags mod suff path basename = do+   mkHomeModLocation2 dflags mod (path </> basename) suff++-- -----------------------------------------------------------------------------+-- Constructing a home module location++-- This is where we construct the ModLocation for a module in the home+-- package, for which we have a source file.  It is called from three+-- places:+--+--  (a) Here in the finder, when we are searching for a module to import,+--      using the search path (-i option).+--+--  (b) The compilation manager, when constructing the ModLocation for+--      a "root" module (a source file named explicitly on the command line+--      or in a :load command in GHCi).+--+--  (c) The driver in one-shot mode, when we need to construct a+--      ModLocation for a source file named on the command-line.+--+-- Parameters are:+--+-- mod+--      The name of the module+--+-- path+--      (a): The search path component where the source file was found.+--      (b) and (c): "."+--+-- src_basename+--      (a): (moduleNameSlashes mod)+--      (b) and (c): The filename of the source file, minus its extension+--+-- ext+--      The filename extension of the source file (usually "hs" or "lhs").++mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO ModLocation+mkHomeModLocation dflags mod src_filename = do+   let (basename,extension) = splitExtension src_filename+   mkHomeModLocation2 dflags mod basename extension++mkHomeModLocation2 :: DynFlags+                   -> ModuleName+                   -> FilePath  -- Of source module, without suffix+                   -> String    -- Suffix+                   -> IO ModLocation+mkHomeModLocation2 dflags mod src_basename ext = do+   let mod_basename = moduleNameSlashes mod++       obj_fn = mkObjPath  dflags src_basename mod_basename+       hi_fn  = mkHiPath   dflags src_basename mod_basename++   return (ModLocation{ ml_hs_file   = Just (src_basename <.> ext),+                        ml_hi_file   = hi_fn,+                        ml_obj_file  = obj_fn })++mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String+                    -> IO ModLocation+mkHiOnlyModLocation dflags hisuf path basename+ = do let full_basename = path </> basename+          obj_fn = mkObjPath  dflags full_basename basename+      return ModLocation{    ml_hs_file   = Nothing,+                             ml_hi_file   = full_basename <.> hisuf,+                                -- Remove the .hi-boot suffix from+                                -- hi_file, if it had one.  We always+                                -- want the name of the real .hi file+                                -- in the ml_hi_file field.+                             ml_obj_file  = obj_fn+                  }++-- | Constructs the filename of a .o file for a given source file.+-- Does /not/ check whether the .o file exists+mkObjPath+  :: DynFlags+  -> FilePath           -- the filename of the source file, minus the extension+  -> String             -- the module name with dots replaced by slashes+  -> FilePath+mkObjPath dflags basename mod_basename = obj_basename <.> osuf+  where+                odir = objectDir dflags+                osuf = objectSuf dflags++                obj_basename | Just dir <- odir = dir </> mod_basename+                             | otherwise        = basename+++-- | Constructs the filename of a .hi file for a given source file.+-- Does /not/ check whether the .hi file exists+mkHiPath+  :: DynFlags+  -> FilePath           -- the filename of the source file, minus the extension+  -> String             -- the module name with dots replaced by slashes+  -> FilePath+mkHiPath dflags basename mod_basename = hi_basename <.> hisuf+ where+                hidir = hiDir dflags+                hisuf = hiSuf dflags++                hi_basename | Just dir <- hidir = dir </> mod_basename+                            | otherwise         = basename++++-- -----------------------------------------------------------------------------+-- Filenames of the stub files++-- We don't have to store these in ModLocations, because they can be derived+-- from other available information, and they're only rarely needed.++mkStubPaths+  :: DynFlags+  -> ModuleName+  -> ModLocation+  -> FilePath++mkStubPaths dflags mod location+  = let+        stubdir = stubDir dflags++        mod_basename = moduleNameSlashes mod+        src_basename = dropExtension $ expectJust "mkStubPaths"+                                                  (ml_hs_file location)++        stub_basename0+            | Just dir <- stubdir = dir </> mod_basename+            | otherwise           = src_basename++        stub_basename = stub_basename0 ++ "_stub"+     in+        stub_basename <.> "h"++-- -----------------------------------------------------------------------------+-- findLinkable isn't related to the other stuff in here,+-- but there's no other obvious place for it++findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable)+findObjectLinkableMaybe mod locn+   = do let obj_fn = ml_obj_file locn+        maybe_obj_time <- modificationTimeIfExists obj_fn+        case maybe_obj_time of+          Nothing -> return Nothing+          Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time)++-- Make an object linkable when we know the object file exists, and we know+-- its modification time.+findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable+findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn])+  -- We used to look for _stub.o files here, but that was a bug (#706)+  -- Now GHC merges the stub.o into the main .o (#3687)++-- -----------------------------------------------------------------------------+-- Error messages++cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc+cannotFindModule = cantFindErr (sLit "Could not find module")+                               (sLit "Ambiguous module name")++cannotFindInterface  :: DynFlags -> ModuleName -> InstalledFindResult -> SDoc+cannotFindInterface = cantFindInstalledErr (sLit "Failed to load interface for")+                                           (sLit "Ambiguous interface for")++cantFindErr :: LitString -> LitString -> DynFlags -> ModuleName -> FindResult+            -> SDoc+cantFindErr _ multiple_found _ mod_name (FoundMultiple mods)+  | Just pkgs <- unambiguousPackages+  = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (+       sep [text "it was found in multiple packages:",+                hsep (map ppr pkgs) ]+    )+  | otherwise+  = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (+       vcat (map pprMod mods)+    )+  where+    unambiguousPackages = foldl' unambiguousPackage (Just []) mods+    unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _)+        = Just (moduleUnitId m : xs)+    unambiguousPackage _ _ = Nothing++    pprMod (m, o) = text "it is bound as" <+> ppr m <+>+                                text "by" <+> pprOrigin m o+    pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden"+    pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma (+      if e == Just True+          then [text "package" <+> ppr (moduleUnitId m)]+          else [] +++      map ((text "a reexport in package" <+>)+                .ppr.packageConfigId) res +++      if f then [text "a package flag"] else []+      )++cantFindErr cannot_find _ dflags mod_name find_result+  = ptext cannot_find <+> quotes (ppr mod_name)+    $$ more_info+  where+    more_info+      = case find_result of+            NoPackage pkg+                -> text "no unit id matching" <+> quotes (ppr pkg) <+>+                   text "was found"++            NotFound { fr_paths = files, fr_pkg = mb_pkg+                     , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens+                     , fr_suggestions = suggest }+                | Just pkg <- mb_pkg, pkg /= thisPackage dflags+                -> not_found_in_package pkg files++                | not (null suggest)+                -> pp_suggestions suggest $$ tried_these files++                | null files && null mod_hiddens && null pkg_hiddens+                -> text "It is not a module in the current program, or in any known package."++                | otherwise+                -> vcat (map pkg_hidden pkg_hiddens) $$+                   vcat (map mod_hidden mod_hiddens) $$+                   tried_these files++            _ -> panic "cantFindErr"++    build_tag = buildTag dflags++    not_found_in_package pkg files+       | build_tag /= ""+       = let+            build = if build_tag == "p" then "profiling"+                                        else "\"" ++ build_tag ++ "\""+         in+         text "Perhaps you haven't installed the " <> text build <>+         text " libraries for package " <> quotes (ppr pkg) <> char '?' $$+         tried_these files++       | otherwise+       = text "There are files missing in the " <> quotes (ppr pkg) <>+         text " package," $$+         text "try running 'ghc-pkg check'." $$+         tried_these files++    tried_these files+        | null files = Outputable.empty+        | verbosity dflags < 3 =+              text "Use -v to see a list of the files searched for."+        | otherwise =+               hang (text "Locations searched:") 2 $ vcat (map text files)++    pkg_hidden :: UnitId -> SDoc+    pkg_hidden pkgid =+        text "It is a member of the hidden package"+        <+> quotes (ppr pkgid)+        --FIXME: we don't really want to show the unit id here we should+        -- show the source package id or installed package id if it's ambiguous+        <> dot $$ cabal_pkg_hidden_hint pkgid+    cabal_pkg_hidden_hint pkgid+     | gopt Opt_BuildingCabalPackage dflags+        = let pkg = expectJust "pkg_hidden" (lookupPackage dflags pkgid)+           in text "Perhaps you need to add" <+>+              quotes (ppr (packageName pkg)) <+>+              text "to the build-depends in your .cabal file."+     | otherwise = Outputable.empty++    mod_hidden pkg =+        text "it is a hidden module in the package" <+> quotes (ppr pkg)++    pp_suggestions :: [ModuleSuggestion] -> SDoc+    pp_suggestions sugs+      | null sugs = Outputable.empty+      | otherwise = hang (text "Perhaps you meant")+                       2 (vcat (map pp_sugg sugs))++    -- NB: Prefer the *original* location, and then reexports, and then+    -- package flags when making suggestions.  ToDo: if the original package+    -- also has a reexport, prefer that one+    pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o+      where provenance ModHidden = Outputable.empty+            provenance (ModOrigin{ fromOrigPackage = e,+                                   fromExposedReexport = res,+                                   fromPackageFlag = f })+              | Just True <- e+                 = parens (text "from" <+> ppr (moduleUnitId mod))+              | f && moduleName mod == m+                 = parens (text "from" <+> ppr (moduleUnitId mod))+              | (pkg:_) <- res+                 = parens (text "from" <+> ppr (packageConfigId pkg)+                    <> comma <+> text "reexporting" <+> ppr mod)+              | f+                 = parens (text "defined via package flags to be"+                    <+> ppr mod)+              | otherwise = Outputable.empty+    pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o+      where provenance ModHidden =  Outputable.empty+            provenance (ModOrigin{ fromOrigPackage = e,+                                   fromHiddenReexport = rhs })+              | Just False <- e+                 = parens (text "needs flag -package-key"+                    <+> ppr (moduleUnitId mod))+              | (pkg:_) <- rhs+                 = parens (text "needs flag -package-id"+                    <+> ppr (packageConfigId pkg))+              | otherwise = Outputable.empty++cantFindInstalledErr :: LitString -> LitString -> DynFlags -> ModuleName -> InstalledFindResult+            -> SDoc+cantFindInstalledErr cannot_find _ dflags mod_name find_result+  = ptext cannot_find <+> quotes (ppr mod_name)+    $$ more_info+  where+    more_info+      = case find_result of+            InstalledNoPackage pkg+                -> text "no unit id matching" <+> quotes (ppr pkg) <+>+                   text "was found" $$ looks_like_srcpkgid pkg++            InstalledNotFound files mb_pkg+                | Just pkg <- mb_pkg, not (pkg `installedUnitIdEq` thisPackage dflags)+                -> not_found_in_package pkg files++                | null files+                -> text "It is not a module in the current program, or in any known package."++                | otherwise+                -> tried_these files++            _ -> panic "cantFindInstalledErr"++    build_tag = buildTag dflags++    looks_like_srcpkgid :: InstalledUnitId -> SDoc+    looks_like_srcpkgid pk+     -- Unsafely coerce a unit id FastString into a source package ID+     -- FastString and see if it means anything.+     | (pkg:pkgs) <- searchPackageId dflags (SourcePackageId (installedUnitIdFS pk))+     = parens (text "This unit ID looks like the source package ID;" $$+       text "the real unit ID is" <+> quotes (ftext (installedUnitIdFS (unitId pkg))) $$+       (if null pkgs then Outputable.empty+        else text "and" <+> int (length pkgs) <+> text "other candidates"))+     -- Todo: also check if it looks like a package name!+     | otherwise = Outputable.empty++    not_found_in_package pkg files+       | build_tag /= ""+       = let+            build = if build_tag == "p" then "profiling"+                                        else "\"" ++ build_tag ++ "\""+         in+         text "Perhaps you haven't installed the " <> text build <>+         text " libraries for package " <> quotes (ppr pkg) <> char '?' $$+         tried_these files++       | otherwise+       = text "There are files missing in the " <> quotes (ppr pkg) <>+         text " package," $$+         text "try running 'ghc-pkg check'." $$+         tried_these files++    tried_these files+        | null files = Outputable.empty+        | verbosity dflags < 3 =+              text "Use -v to see a list of the files searched for."+        | otherwise =+               hang (text "Locations searched:") 2 $ vcat (map text files)
+ main/GHC.hs view
@@ -0,0 +1,1541 @@+{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables,+             NamedFieldPuns, TupleSections #-}++-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow, 2005-2012+--+-- The GHC API+--+-- -----------------------------------------------------------------------------++module GHC (+        -- * Initialisation+        defaultErrorHandler,+        defaultCleanupHandler,+        prettyPrintGhcErrors,+        withSignalHandlers,+        withCleanupSession,++        -- * GHC Monad+        Ghc, GhcT, GhcMonad(..), HscEnv,+        runGhc, runGhcT, initGhcMonad,+        gcatch, gbracket, gfinally,+        printException,+        handleSourceError,+        needsTemplateHaskell,++        -- * Flags and settings+        DynFlags(..), GeneralFlag(..), Severity(..), HscTarget(..), gopt,+        GhcMode(..), GhcLink(..), defaultObjectTarget,+        parseDynamicFlags,+        getSessionDynFlags, setSessionDynFlags,+        getProgramDynFlags, setProgramDynFlags, setLogAction,+        getInteractiveDynFlags, setInteractiveDynFlags,++        -- * Targets+        Target(..), TargetId(..), Phase,+        setTargets,+        getTargets,+        addTarget,+        removeTarget,+        guessTarget,++        -- * Loading\/compiling the program+        depanal,+        load, LoadHowMuch(..), InteractiveImport(..),+        SuccessFlag(..), succeeded, failed,+        defaultWarnErrLogger, WarnErrLogger,+        workingDirectoryChanged,+        parseModule, typecheckModule, desugarModule, loadModule,+        ParsedModule(..), TypecheckedModule(..), DesugaredModule(..),+        TypecheckedSource, ParsedSource, RenamedSource,   -- ditto+        TypecheckedMod, ParsedMod,+        moduleInfo, renamedSource, typecheckedSource,+        parsedSource, coreModule,++        -- ** Compiling to Core+        CoreModule(..),+        compileToCoreModule, compileToCoreSimplified,++        -- * Inspecting the module structure of the program+        ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),+        getModSummary,+        getModuleGraph,+        isLoaded,+        topSortModuleGraph,++        -- * Inspecting modules+        ModuleInfo,+        getModuleInfo,+        modInfoTyThings,+        modInfoTopLevelScope,+        modInfoExports,+        modInfoExportsWithSelectors,+        modInfoInstances,+        modInfoIsExportedName,+        modInfoLookupName,+        modInfoIface,+        modInfoSafe,+        lookupGlobalName,+        findGlobalAnns,+        mkPrintUnqualifiedForModule,+        ModIface(..),+        SafeHaskellMode(..),++        -- * Querying the environment+        -- packageDbModules,++        -- * Printing+        PrintUnqualified, alwaysQualify,++        -- * Interactive evaluation++        -- ** Executing statements+        execStmt, ExecOptions(..), execOptions, ExecResult(..),+        resumeExec,++        -- ** Adding new declarations+        runDecls, runDeclsWithLocation,++        -- ** Get/set the current context+        parseImportDecl,+        setContext, getContext,+        setGHCiMonad, getGHCiMonad,++        -- ** Inspecting the current context+        getBindings, getInsts, getPrintUnqual,+        findModule, lookupModule,+        isModuleTrusted, moduleTrustReqs,+        getNamesInScope,+        getRdrNamesInScope,+        getGRE,+        moduleIsInterpreted,+        getInfo,+        showModule,+        moduleIsBootOrNotObjectLinkable,+        getNameToInstancesIndex,++        -- ** Inspecting types and kinds+        exprType, TcRnExprMode(..),+        typeKind,++        -- ** Looking up a Name+        parseName,+        lookupName,++        -- ** Compiling expressions+        HValue, parseExpr, compileParsedExpr,+        InteractiveEval.compileExpr, dynCompileExpr,+        ForeignHValue,+        compileExprRemote, compileParsedExprRemote,++        -- ** Other+        runTcInteractive,   -- Desired by some clients (Trac #8878)+        isStmt, hasImport, isImport, isDecl,++        -- ** The debugger+        SingleStep(..),+        Resume(..),+        History(historyBreakInfo, historyEnclosingDecls),+        GHC.getHistorySpan, getHistoryModule,+        abandon, abandonAll,+        getResumeContext,+        GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,+        modInfoModBreaks,+        ModBreaks(..), BreakIndex,+        BreakInfo(breakInfo_number, breakInfo_module),+        InteractiveEval.back,+        InteractiveEval.forward,++        -- * Abstract syntax elements++        -- ** Packages+        UnitId,++        -- ** Modules+        Module, mkModule, pprModule, moduleName, moduleUnitId,+        ModuleName, mkModuleName, moduleNameString,++        -- ** Names+        Name,+        isExternalName, nameModule, pprParenSymName, nameSrcSpan,+        NamedThing(..),+        RdrName(Qual,Unqual),++        -- ** Identifiers+        Id, idType,+        isImplicitId, isDeadBinder,+        isExportedId, isLocalId, isGlobalId,+        isRecordSelector,+        isPrimOpId, isFCallId, isClassOpId_maybe,+        isDataConWorkId, idDataCon,+        isBottomingId, isDictonaryId,+        recordSelectorTyCon,++        -- ** Type constructors+        TyCon,+        tyConTyVars, tyConDataCons, tyConArity,+        isClassTyCon, isTypeSynonymTyCon, isTypeFamilyTyCon, isNewTyCon,+        isPrimTyCon, isFunTyCon,+        isFamilyTyCon, isOpenFamilyTyCon, isOpenTypeFamilyTyCon,+        tyConClass_maybe,+        synTyConRhs_maybe, synTyConDefn_maybe, tyConKind,++        -- ** Type variables+        TyVar,+        alphaTyVars,++        -- ** Data constructors+        DataCon,+        dataConSig, dataConType, dataConTyCon, dataConFieldLabels,+        dataConIsInfix, isVanillaDataCon, dataConUserType,+        dataConSrcBangs,+        StrictnessMark(..), isMarkedStrict,++        -- ** Classes+        Class,+        classMethods, classSCTheta, classTvsFds, classATs,+        pprFundeps,++        -- ** Instances+        ClsInst,+        instanceDFunId,+        pprInstance, pprInstanceHdr,+        pprFamInst,++        FamInst,++        -- ** Types and Kinds+        Type, splitForAllTys, funResultTy,+        pprParendType, pprTypeApp,+        Kind,+        PredType,+        ThetaType, pprForAll, pprThetaArrowTy,++        -- ** Entities+        TyThing(..),++        -- ** Syntax+        module HsSyn, -- ToDo: remove extraneous bits++        -- ** Fixities+        FixityDirection(..),+        defaultFixity, maxPrecedence,+        negateFixity,+        compareFixity,+        LexicalFixity(..),++        -- ** Source locations+        SrcLoc(..), RealSrcLoc,+        mkSrcLoc, noSrcLoc,+        srcLocFile, srcLocLine, srcLocCol,+        SrcSpan(..), RealSrcSpan,+        mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,+        srcSpanStart, srcSpanEnd,+        srcSpanFile,+        srcSpanStartLine, srcSpanEndLine,+        srcSpanStartCol, srcSpanEndCol,++        -- ** Located+        GenLocated(..), Located,++        -- *** Constructing Located+        noLoc, mkGeneralLocated,++        -- *** Deconstructing Located+        getLoc, unLoc,++        -- *** Combining and comparing Located values+        eqLocated, cmpLocated, combineLocs, addCLoc,+        leftmost_smallest, leftmost_largest, rightmost,+        spans, isSubspanOf,++        -- * Exceptions+        GhcException(..), showGhcException,++        -- * Token stream manipulations+        Token,+        getTokenStream, getRichTokenStream,+        showRichTokenStream, addSourceToTokens,++        -- * Pure interface to the parser+        parser,++        -- * API Annotations+        ApiAnns,AnnKeywordId(..),AnnotationComment(..),+        getAnnotation, getAndRemoveAnnotation,+        getAnnotationComments, getAndRemoveAnnotationComments,+        unicodeAnn,++        -- * Miscellaneous+        --sessionHscEnv,+        cyclicModuleErr,+  ) where++{-+ ToDo:++  * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.+-}++#include "HsVersions.h"++import ByteCodeTypes+import InteractiveEval+import InteractiveEvalTypes+import TcRnDriver       ( runTcInteractive )+import GHCi+import GHCi.RemoteTypes++import PprTyThing       ( pprFamInst )+import HscMain+import GhcMake+import DriverPipeline   ( compileOne' )+import GhcMonad+import TcRnMonad        ( finalSafeMode, fixSafeInstances )+import TcRnTypes+import Packages+import NameSet+import RdrName+import HsSyn+import Type     hiding( typeKind )+import TcType           hiding( typeKind )+import Id+import TysPrim          ( alphaTyVars )+import TyCon+import Class+import DataCon+import Name             hiding ( varName )+import Avail+import InstEnv+import FamInstEnv ( FamInst )+import SrcLoc+import CoreSyn+import TidyPgm+import DriverPhases     ( Phase(..), isHaskellSrcFilename )+import Finder+import HscTypes+import DynFlags+import SysTools+import Annotations+import Module+import Panic+import Platform+import Bag              ( listToBag, unitBag )+import ErrUtils+import MonadUtils+import Util+import StringBuffer+import Outputable+import BasicTypes+import Maybes           ( expectJust )+import FastString+import qualified Parser+import Lexer+import ApiAnnotation+import qualified GHC.LanguageExtensions as LangExt+import NameEnv+import CoreFVs          ( orphNamesOfFamInst )+import FamInstEnv       ( famInstEnvElts )+import TcRnDriver+import Inst+import FamInst++import Data.Foldable+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Sequence as Seq+import System.Directory ( doesFileExist )+import Data.Maybe+import Data.List        ( find )+import Data.Time+import Data.Typeable    ( Typeable )+import Data.Word        ( Word8 )+import Control.Monad+import System.Exit      ( exitWith, ExitCode(..) )+import Exception+import Data.IORef+import System.FilePath+import System.IO+import Prelude hiding (init)+++-- %************************************************************************+-- %*                                                                      *+--             Initialisation: exception handlers+-- %*                                                                      *+-- %************************************************************************+++-- | Install some default exception handlers and run the inner computation.+-- Unless you want to handle exceptions yourself, you should wrap this around+-- the top level of your program.  The default handlers output the error+-- message(s) to stderr and exit cleanly.+defaultErrorHandler :: (ExceptionMonad m)+                    => FatalMessager -> FlushOut -> m a -> m a+defaultErrorHandler fm (FlushOut flushOut) inner =+  -- top-level exception handler: any unrecognised exception is a compiler bug.+  ghandle (\exception -> liftIO $ do+           flushOut+           case fromException exception of+                -- an IO exception probably isn't our fault, so don't panic+                Just (ioe :: IOException) ->+                  fatalErrorMsg'' fm (show ioe)+                _ -> case fromException exception of+                     Just UserInterrupt ->+                         -- Important to let this one propagate out so our+                         -- calling process knows we were interrupted by ^C+                         liftIO $ throwIO UserInterrupt+                     Just StackOverflow ->+                         fatalErrorMsg'' fm "stack overflow: use +RTS -K<size> to increase it"+                     _ -> case fromException exception of+                          Just (ex :: ExitCode) -> liftIO $ throwIO ex+                          _ ->+                              fatalErrorMsg'' fm+                                  (show (Panic (show exception)))+           exitWith (ExitFailure 1)+         ) $++  -- error messages propagated as exceptions+  handleGhcException+            (\ge -> liftIO $ do+                flushOut+                case ge of+                     Signal _ -> exitWith (ExitFailure 1)+                     _ -> do fatalErrorMsg'' fm (show ge)+                             exitWith (ExitFailure 1)+            ) $+  inner++-- | This function is no longer necessary, cleanup is now done by+-- runGhc/runGhcT.+{-# DEPRECATED defaultCleanupHandler "Cleanup is now done by runGhc/runGhcT" #-}+defaultCleanupHandler :: (ExceptionMonad m) => DynFlags -> m a -> m a+defaultCleanupHandler _ m = m+ where _warning_suppression = m `gonException` undefined+++-- %************************************************************************+-- %*                                                                      *+--             The Ghc Monad+-- %*                                                                      *+-- %************************************************************************++-- | Run function for the 'Ghc' monad.+--+-- It initialises the GHC session and warnings via 'initGhcMonad'.  Each call+-- to this function will create a new session which should not be shared among+-- several threads.+--+-- Any errors not handled inside the 'Ghc' action are propagated as IO+-- exceptions.++runGhc :: Maybe FilePath  -- ^ See argument to 'initGhcMonad'.+       -> Ghc a           -- ^ The action to perform.+       -> IO a+runGhc mb_top_dir ghc = do+  ref <- newIORef (panic "empty session")+  let session = Session ref+  flip unGhc session $ withSignalHandlers $ do -- catch ^C+    initGhcMonad mb_top_dir+    withCleanupSession ghc++-- | Run function for 'GhcT' monad transformer.+--+-- It initialises the GHC session and warnings via 'initGhcMonad'.  Each call+-- to this function will create a new session which should not be shared among+-- several threads.++runGhcT :: ExceptionMonad m =>+           Maybe FilePath  -- ^ See argument to 'initGhcMonad'.+        -> GhcT m a        -- ^ The action to perform.+        -> m a+runGhcT mb_top_dir ghct = do+  ref <- liftIO $ newIORef (panic "empty session")+  let session = Session ref+  flip unGhcT session $ withSignalHandlers $ do -- catch ^C+    initGhcMonad mb_top_dir+    withCleanupSession ghct++withCleanupSession :: GhcMonad m => m a -> m a+withCleanupSession ghc = ghc `gfinally` cleanup+  where+   cleanup = do+      hsc_env <- getSession+      let dflags = hsc_dflags hsc_env+      liftIO $ do+          cleanTempFiles dflags+          cleanTempDirs dflags+          stopIServ hsc_env -- shut down the IServ+          log_finaliser dflags dflags+          --  exceptions will be blocked while we clean the temporary files,+          -- so there shouldn't be any difficulty if we receive further+          -- signals.++-- | Initialise a GHC session.+--+-- If you implement a custom 'GhcMonad' you must call this function in the+-- monad run function.  It will initialise the session variable and clear all+-- warnings.+--+-- The first argument should point to the directory where GHC's library files+-- reside.  More precisely, this should be the output of @ghc --print-libdir@+-- of the version of GHC the module using this API is compiled with.  For+-- portability, you should use the @ghc-paths@ package, available at+-- <http://hackage.haskell.org/package/ghc-paths>.++initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()+initGhcMonad mb_top_dir+  = do { env <- liftIO $+                do { mySettings <- initSysTools mb_top_dir+                   ; dflags <- initDynFlags (defaultDynFlags mySettings)+                   ; checkBrokenTablesNextToCode dflags+                   ; setUnsafeGlobalDynFlags dflags+                      -- c.f. DynFlags.parseDynamicFlagsFull, which+                      -- creates DynFlags and sets the UnsafeGlobalDynFlags+                   ; newHscEnv dflags }+       ; setSession env }++-- | The binutils linker on ARM emits unnecessary R_ARM_COPY relocations which+-- breaks tables-next-to-code in dynamically linked modules. This+-- check should be more selective but there is currently no released+-- version where this bug is fixed.+-- See https://sourceware.org/bugzilla/show_bug.cgi?id=16177 and+-- https://ghc.haskell.org/trac/ghc/ticket/4210#comment:29+checkBrokenTablesNextToCode :: MonadIO m => DynFlags -> m ()+checkBrokenTablesNextToCode dflags+  = do { broken <- checkBrokenTablesNextToCode' dflags+       ; when broken+         $ do { _ <- liftIO $ throwIO $ mkApiErr dflags invalidLdErr+              ; fail "unsupported linker"+              }+       }+  where+    invalidLdErr = text "Tables-next-to-code not supported on ARM" <+>+                   text "when using binutils ld (please see:" <+>+                   text "https://sourceware.org/bugzilla/show_bug.cgi?id=16177)"++checkBrokenTablesNextToCode' :: MonadIO m => DynFlags -> m Bool+checkBrokenTablesNextToCode' dflags+  | not (isARM arch)              = return False+  | WayDyn `notElem` ways dflags  = return False+  | not (tablesNextToCode dflags) = return False+  | otherwise                     = do+    linkerInfo <- liftIO $ getLinkerInfo dflags+    case linkerInfo of+      GnuLD _  -> return True+      _        -> return False+  where platform = targetPlatform dflags+        arch = platformArch platform+++-- %************************************************************************+-- %*                                                                      *+--             Flags & settings+-- %*                                                                      *+-- %************************************************************************++-- $DynFlags+--+-- The GHC session maintains two sets of 'DynFlags':+--+--   * The "interactive" @DynFlags@, which are used for everything+--     related to interactive evaluation, including 'runStmt',+--     'runDecls', 'exprType', 'lookupName' and so on (everything+--     under \"Interactive evaluation\" in this module).+--+--   * The "program" @DynFlags@, which are used when loading+--     whole modules with 'load'+--+-- 'setInteractiveDynFlags', 'getInteractiveDynFlags' work with the+-- interactive @DynFlags@.+--+-- 'setProgramDynFlags', 'getProgramDynFlags' work with the+-- program @DynFlags@.+--+-- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags'+-- retrieves the program @DynFlags@ (for backwards compatibility).+++-- | Updates both the interactive and program DynFlags in a Session.+-- This also reads the package database (unless it has already been+-- read), and prepares the compilers knowledge about packages.  It can+-- be called again to load new packages: just add new package flags to+-- (packageFlags dflags).+--+-- Returns a list of new packages that may need to be linked in using+-- the dynamic linker (see 'linkPackages') as a result of new package+-- flags.  If you are not doing linking or doing static linking, you+-- can ignore the list of packages returned.+--+setSessionDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId]+setSessionDynFlags dflags = do+  dflags' <- checkNewDynFlags dflags+  (dflags'', preload) <- liftIO $ initPackages dflags'+  modifySession $ \h -> h{ hsc_dflags = dflags''+                         , hsc_IC = (hsc_IC h){ ic_dflags = dflags'' } }+  invalidateModSummaryCache+  return preload++-- | Sets the program 'DynFlags'.  Note: this invalidates the internal+-- cached module graph, causing more work to be done the next time+-- 'load' is called.+setProgramDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId]+setProgramDynFlags dflags = setProgramDynFlags_ True dflags++-- | Set the action taken when the compiler produces a message.  This+-- can also be accomplished using 'setProgramDynFlags', but using+-- 'setLogAction' avoids invalidating the cached module graph.+setLogAction :: GhcMonad m => LogAction -> LogFinaliser -> m ()+setLogAction action finaliser = do+  dflags' <- getProgramDynFlags+  void $ setProgramDynFlags_ False $+    dflags' { log_action = action+            , log_finaliser = finaliser }++setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [InstalledUnitId]+setProgramDynFlags_ invalidate_needed dflags = do+  dflags' <- checkNewDynFlags dflags+  dflags_prev <- getProgramDynFlags+  (dflags'', preload) <-+    if (packageFlagsChanged dflags_prev dflags')+       then liftIO $ initPackages dflags'+       else return (dflags', [])+  modifySession $ \h -> h{ hsc_dflags = dflags'' }+  when invalidate_needed $ invalidateModSummaryCache+  return preload+++-- When changing the DynFlags, we want the changes to apply to future+-- loads, but without completely discarding the program.  But the+-- DynFlags are cached in each ModSummary in the hsc_mod_graph, so+-- after a change to DynFlags, the changes would apply to new modules+-- but not existing modules; this seems undesirable.+--+-- Furthermore, the GHC API client might expect that changing+-- log_action would affect future compilation messages, but for those+-- modules we have cached ModSummaries for, we'll continue to use the+-- old log_action.  This is definitely wrong (#7478).+--+-- Hence, we invalidate the ModSummary cache after changing the+-- DynFlags.  We do this by tweaking the date on each ModSummary, so+-- that the next downsweep will think that all the files have changed+-- and preprocess them again.  This won't necessarily cause everything+-- to be recompiled, because by the time we check whether we need to+-- recopmile a module, we'll have re-summarised the module and have a+-- correct ModSummary.+--+invalidateModSummaryCache :: GhcMonad m => m ()+invalidateModSummaryCache =+  modifySession $ \h -> h { hsc_mod_graph = map inval (hsc_mod_graph h) }+ where+  inval ms = ms { ms_hs_date = addUTCTime (-1) (ms_hs_date ms) }++-- | Returns the program 'DynFlags'.+getProgramDynFlags :: GhcMonad m => m DynFlags+getProgramDynFlags = getSessionDynFlags++-- | Set the 'DynFlags' used to evaluate interactive expressions.+-- Note: this cannot be used for changes to packages.  Use+-- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the+-- 'pkgState' into the interactive @DynFlags@.+setInteractiveDynFlags :: GhcMonad m => DynFlags -> m ()+setInteractiveDynFlags dflags = do+  dflags' <- checkNewDynFlags dflags+  dflags'' <- checkNewInteractiveDynFlags dflags'+  modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags'' }}++-- | Get the 'DynFlags' used to evaluate interactive expressions.+getInteractiveDynFlags :: GhcMonad m => m DynFlags+getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h))+++parseDynamicFlags :: MonadIO m =>+                     DynFlags -> [Located String]+                  -> m (DynFlags, [Located String], [Located String])+parseDynamicFlags = parseDynamicFlagsCmdLine++-- | Checks the set of new DynFlags for possibly erroneous option+-- combinations when invoking 'setSessionDynFlags' and friends, and if+-- found, returns a fixed copy (if possible).+checkNewDynFlags :: MonadIO m => DynFlags -> m DynFlags+checkNewDynFlags dflags = do+  -- See Note [DynFlags consistency]+  let (dflags', warnings) = makeDynFlagsConsistent dflags+  liftIO $ handleFlagWarnings dflags warnings+  return dflags'++checkNewInteractiveDynFlags :: MonadIO m => DynFlags -> m DynFlags+checkNewInteractiveDynFlags dflags0 = do+  dflags1 <-+      if xopt LangExt.StaticPointers dflags0+      then do liftIO $ printOrThrowWarnings dflags0 $ listToBag+                [mkPlainWarnMsg dflags0 interactiveSrcSpan+                 $ text "StaticPointers is not supported in GHCi interactive expressions."]+              return $ xopt_unset dflags0 LangExt.StaticPointers+      else return dflags0+  return dflags1+++-- %************************************************************************+-- %*                                                                      *+--             Setting, getting, and modifying the targets+-- %*                                                                      *+-- %************************************************************************++-- ToDo: think about relative vs. absolute file paths. And what+-- happens when the current directory changes.++-- | Sets the targets for this session.  Each target may be a module name+-- or a filename.  The targets correspond to the set of root modules for+-- the program\/library.  Unloading the current program is achieved by+-- setting the current set of targets to be empty, followed by 'load'.+setTargets :: GhcMonad m => [Target] -> m ()+setTargets targets = modifySession (\h -> h{ hsc_targets = targets })++-- | Returns the current set of targets+getTargets :: GhcMonad m => m [Target]+getTargets = withSession (return . hsc_targets)++-- | Add another target.+addTarget :: GhcMonad m => Target -> m ()+addTarget target+  = modifySession (\h -> h{ hsc_targets = target : hsc_targets h })++-- | Remove a target+removeTarget :: GhcMonad m => TargetId -> m ()+removeTarget target_id+  = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) })+  where+   filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ]++-- | Attempts to guess what Target a string refers to.  This function+-- implements the @--make@/GHCi command-line syntax for filenames:+--+--   - if the string looks like a Haskell source filename, then interpret it+--     as such+--+--   - if adding a .hs or .lhs suffix yields the name of an existing file,+--     then use that+--+--   - otherwise interpret the string as a module name+--+guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target+guessTarget str (Just phase)+   = return (Target (TargetFile str (Just phase)) True Nothing)+guessTarget str Nothing+   | isHaskellSrcFilename file+   = return (target (TargetFile file Nothing))+   | otherwise+   = do exists <- liftIO $ doesFileExist hs_file+        if exists+           then return (target (TargetFile hs_file Nothing))+           else do+        exists <- liftIO $ doesFileExist lhs_file+        if exists+           then return (target (TargetFile lhs_file Nothing))+           else do+        if looksLikeModuleName file+           then return (target (TargetModule (mkModuleName file)))+           else do+        dflags <- getDynFlags+        liftIO $ throwGhcExceptionIO+                 (ProgramError (showSDoc dflags $+                 text "target" <+> quotes (text file) <+>+                 text "is not a module name or a source file"))+     where+         (file,obj_allowed)+                | '*':rest <- str = (rest, False)+                | otherwise       = (str,  True)++         hs_file  = file <.> "hs"+         lhs_file = file <.> "lhs"++         target tid = Target tid obj_allowed Nothing+++-- | Inform GHC that the working directory has changed.  GHC will flush+-- its cache of module locations, since it may no longer be valid.+--+-- Note: Before changing the working directory make sure all threads running+-- in the same session have stopped.  If you change the working directory,+-- you should also unload the current program (set targets to empty,+-- followed by load).+workingDirectoryChanged :: GhcMonad m => m ()+workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches)+++-- %************************************************************************+-- %*                                                                      *+--             Running phases one at a time+-- %*                                                                      *+-- %************************************************************************++class ParsedMod m where+  modSummary   :: m -> ModSummary+  parsedSource :: m -> ParsedSource++class ParsedMod m => TypecheckedMod m where+  renamedSource     :: m -> Maybe RenamedSource+  typecheckedSource :: m -> TypecheckedSource+  moduleInfo        :: m -> ModuleInfo+  tm_internals      :: m -> (TcGblEnv, ModDetails)+        -- ToDo: improvements that could be made here:+        --  if the module succeeded renaming but not typechecking,+        --  we can still get back the GlobalRdrEnv and exports, so+        --  perhaps the ModuleInfo should be split up into separate+        --  fields.++class TypecheckedMod m => DesugaredMod m where+  coreModule :: m -> ModGuts++-- | The result of successful parsing.+data ParsedModule =+  ParsedModule { pm_mod_summary   :: ModSummary+               , pm_parsed_source :: ParsedSource+               , pm_extra_src_files :: [FilePath]+               , pm_annotations :: ApiAnns }+               -- See Note [Api annotations] in ApiAnnotation.hs++instance ParsedMod ParsedModule where+  modSummary m    = pm_mod_summary m+  parsedSource m = pm_parsed_source m++-- | The result of successful typechecking.  It also contains the parser+--   result.+data TypecheckedModule =+  TypecheckedModule { tm_parsed_module       :: ParsedModule+                    , tm_renamed_source      :: Maybe RenamedSource+                    , tm_typechecked_source  :: TypecheckedSource+                    , tm_checked_module_info :: ModuleInfo+                    , tm_internals_          :: (TcGblEnv, ModDetails)+                    }++instance ParsedMod TypecheckedModule where+  modSummary m   = modSummary (tm_parsed_module m)+  parsedSource m = parsedSource (tm_parsed_module m)++instance TypecheckedMod TypecheckedModule where+  renamedSource m     = tm_renamed_source m+  typecheckedSource m = tm_typechecked_source m+  moduleInfo m        = tm_checked_module_info m+  tm_internals m      = tm_internals_ m++-- | The result of successful desugaring (i.e., translation to core).  Also+--  contains all the information of a typechecked module.+data DesugaredModule =+  DesugaredModule { dm_typechecked_module :: TypecheckedModule+                  , dm_core_module        :: ModGuts+             }++instance ParsedMod DesugaredModule where+  modSummary m   = modSummary (dm_typechecked_module m)+  parsedSource m = parsedSource (dm_typechecked_module m)++instance TypecheckedMod DesugaredModule where+  renamedSource m     = renamedSource (dm_typechecked_module m)+  typecheckedSource m = typecheckedSource (dm_typechecked_module m)+  moduleInfo m        = moduleInfo (dm_typechecked_module m)+  tm_internals m      = tm_internals_ (dm_typechecked_module m)++instance DesugaredMod DesugaredModule where+  coreModule m = dm_core_module m++type ParsedSource      = Located (HsModule RdrName)+type RenamedSource     = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],+                          Maybe LHsDocString)+type TypecheckedSource = LHsBinds Id++-- NOTE:+--   - things that aren't in the output of the typechecker right now:+--     - the export list+--     - the imports+--     - type signatures+--     - type/data/newtype declarations+--     - class declarations+--     - instances+--   - extra things in the typechecker's output:+--     - default methods are turned into top-level decls.+--     - dictionary bindings++-- | Return the 'ModSummary' of a module with the given name.+--+-- The module must be part of the module graph (see 'hsc_mod_graph' and+-- 'ModuleGraph').  If this is not the case, this function will throw a+-- 'GhcApiError'.+--+-- This function ignores boot modules and requires that there is only one+-- non-boot module with the given name.+getModSummary :: GhcMonad m => ModuleName -> m ModSummary+getModSummary mod = do+   mg <- liftM hsc_mod_graph getSession+   case [ ms | ms <- mg, ms_mod_name ms == mod, not (isBootSummary ms) ] of+     [] -> do dflags <- getDynFlags+              liftIO $ throwIO $ mkApiErr dflags (text "Module not part of module graph")+     [ms] -> return ms+     multiple -> do dflags <- getDynFlags+                    liftIO $ throwIO $ mkApiErr dflags (text "getModSummary is ambiguous: " <+> ppr multiple)++-- | Parse a module.+--+-- Throws a 'SourceError' on parse error.+parseModule :: GhcMonad m => ModSummary -> m ParsedModule+parseModule ms = do+   hsc_env <- getSession+   let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }+   hpm <- liftIO $ hscParse hsc_env_tmp ms+   return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm)+                           (hpm_annotations hpm))+               -- See Note [Api annotations] in ApiAnnotation.hs++-- | Typecheck and rename a parsed module.+--+-- Throws a 'SourceError' if either fails.+typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule+typecheckModule pmod = do+ let ms = modSummary pmod+ hsc_env <- getSession+ let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }+ (tc_gbl_env, rn_info)+       <- liftIO $ hscTypecheckRename hsc_env_tmp ms $+                      HsParsedModule { hpm_module = parsedSource pmod,+                                       hpm_src_files = pm_extra_src_files pmod,+                                       hpm_annotations = pm_annotations pmod }+ details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env+ safe    <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env++ return $+     TypecheckedModule {+       tm_internals_          = (tc_gbl_env, details),+       tm_parsed_module       = pmod,+       tm_renamed_source      = rn_info,+       tm_typechecked_source  = tcg_binds tc_gbl_env,+       tm_checked_module_info =+         ModuleInfo {+           minf_type_env  = md_types details,+           minf_exports   = md_exports details,+           minf_rdr_env   = Just (tcg_rdr_env tc_gbl_env),+           minf_instances = fixSafeInstances safe $ md_insts details,+           minf_iface     = Nothing,+           minf_safe      = safe,+           minf_modBreaks = emptyModBreaks+         }}++-- | Desugar a typechecked module.+desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule+desugarModule tcm = do+ let ms = modSummary tcm+ let (tcg, _) = tm_internals tcm+ hsc_env <- getSession+ let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }+ guts <- liftIO $ hscDesugar hsc_env_tmp ms tcg+ return $+     DesugaredModule {+       dm_typechecked_module = tcm,+       dm_core_module        = guts+     }++-- | Load a module.  Input doesn't need to be desugared.+--+-- A module must be loaded before dependent modules can be typechecked.  This+-- always includes generating a 'ModIface' and, depending on the+-- 'DynFlags.hscTarget', may also include code generation.+--+-- This function will always cause recompilation and will always overwrite+-- previous compilation results (potentially files on disk).+--+loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod+loadModule tcm = do+   let ms = modSummary tcm+   let mod = ms_mod_name ms+   let loc = ms_location ms+   let (tcg, _details) = tm_internals tcm++   mb_linkable <- case ms_obj_date ms of+                     Just t | t > ms_hs_date ms  -> do+                         l <- liftIO $ findObjectLinkable (ms_mod ms)+                                                  (ml_obj_file loc) t+                         return (Just l)+                     _otherwise -> return Nothing++   let source_modified | isNothing mb_linkable = SourceModified+                       | otherwise             = SourceUnmodified+                       -- we can't determine stability here++   -- compile doesn't change the session+   hsc_env <- getSession+   mod_info <- liftIO $ compileOne' (Just tcg) Nothing+                                    hsc_env ms 1 1 Nothing mb_linkable+                                    source_modified++   modifySession $ \e -> e{ hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }+   return tcm+++-- %************************************************************************+-- %*                                                                      *+--             Dealing with Core+-- %*                                                                      *+-- %************************************************************************++-- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for+-- the 'GHC.compileToCoreModule' interface.+data CoreModule+  = CoreModule {+      -- | Module name+      cm_module   :: !Module,+      -- | Type environment for types declared in this module+      cm_types    :: !TypeEnv,+      -- | Declarations+      cm_binds    :: CoreProgram,+      -- | Safe Haskell mode+      cm_safe     :: SafeHaskellMode+    }++instance Outputable CoreModule where+   ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb,+                    cm_safe = sf})+    = text "%module" <+> ppr mn <+> parens (ppr sf) <+> ppr te+      $$ vcat (map ppr cb)++-- | This is the way to get access to the Core bindings corresponding+-- to a module. 'compileToCore' parses, typechecks, and+-- desugars the module, then returns the resulting Core module (consisting of+-- the module name, type declarations, and function declarations) if+-- successful.+compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule+compileToCoreModule = compileCore False++-- | Like compileToCoreModule, but invokes the simplifier, so+-- as to return simplified and tidied Core.+compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule+compileToCoreSimplified = compileCore True++compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule+compileCore simplify fn = do+   -- First, set the target to the desired filename+   target <- guessTarget fn Nothing+   addTarget target+   _ <- load LoadAllTargets+   -- Then find dependencies+   modGraph <- depanal [] True+   case find ((== fn) . msHsFilePath) modGraph of+     Just modSummary -> do+       -- Now we have the module name;+       -- parse, typecheck and desugar the module+       mod_guts <- coreModule `fmap`+                      -- TODO: space leaky: call hsc* directly?+                      (desugarModule =<< typecheckModule =<< parseModule modSummary)+       liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $+         if simplify+          then do+             -- If simplify is true: simplify (hscSimplify), then tidy+             -- (tidyProgram).+             hsc_env <- getSession+             simpl_guts <- liftIO $ hscSimplify hsc_env mod_guts+             tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts+             return $ Left tidy_guts+          else+             return $ Right mod_guts++     Nothing -> panic "compileToCoreModule: target FilePath not found in\+                           module dependency graph"+  where -- two versions, based on whether we simplify (thus run tidyProgram,+        -- which returns a (CgGuts, ModDetails) pair, or not (in which case+        -- we just have a ModGuts.+        gutsToCoreModule :: SafeHaskellMode+                         -> Either (CgGuts, ModDetails) ModGuts+                         -> CoreModule+        gutsToCoreModule safe_mode (Left (cg, md)) = CoreModule {+          cm_module = cg_module cg,+          cm_types  = md_types md,+          cm_binds  = cg_binds cg,+          cm_safe   = safe_mode+        }+        gutsToCoreModule safe_mode (Right mg) = CoreModule {+          cm_module  = mg_module mg,+          cm_types   = typeEnvFromEntities (bindersOfBinds (mg_binds mg))+                                           (mg_tcs mg)+                                           (mg_fam_insts mg),+          cm_binds   = mg_binds mg,+          cm_safe    = safe_mode+         }++-- %************************************************************************+-- %*                                                                      *+--             Inspecting the session+-- %*                                                                      *+-- %************************************************************************++-- | Get the module dependency graph.+getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary+getModuleGraph = liftM hsc_mod_graph getSession++-- | Determines whether a set of modules requires Template Haskell.+--+-- Note that if the session's 'DynFlags' enabled Template Haskell when+-- 'depanal' was called, then each module in the returned module graph will+-- have Template Haskell enabled whether it is actually needed or not.+needsTemplateHaskell :: ModuleGraph -> Bool+needsTemplateHaskell ms =+    any (xopt LangExt.TemplateHaskell . ms_hspp_opts) ms++-- | Return @True@ <==> module is loaded.+isLoaded :: GhcMonad m => ModuleName -> m Bool+isLoaded m = withSession $ \hsc_env ->+  return $! isJust (lookupHpt (hsc_HPT hsc_env) m)++-- | Return the bindings for the current interactive session.+getBindings :: GhcMonad m => m [TyThing]+getBindings = withSession $ \hsc_env ->+    return $ icInScopeTTs $ hsc_IC hsc_env++-- | Return the instances for the current interactive session.+getInsts :: GhcMonad m => m ([ClsInst], [FamInst])+getInsts = withSession $ \hsc_env ->+    return $ ic_instances (hsc_IC hsc_env)++getPrintUnqual :: GhcMonad m => m PrintUnqualified+getPrintUnqual = withSession $ \hsc_env ->+  return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env))++-- | Container for information about a 'Module'.+data ModuleInfo = ModuleInfo {+        minf_type_env  :: TypeEnv,+        minf_exports   :: [AvailInfo],+        minf_rdr_env   :: Maybe GlobalRdrEnv,   -- Nothing for a compiled/package mod+        minf_instances :: [ClsInst],+        minf_iface     :: Maybe ModIface,+        minf_safe      :: SafeHaskellMode,+        minf_modBreaks :: ModBreaks+  }+        -- We don't want HomeModInfo here, because a ModuleInfo applies+        -- to package modules too.++-- | Request information about a loaded 'Module'+getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo)  -- XXX: Maybe X+getModuleInfo mdl = withSession $ \hsc_env -> do+  let mg = hsc_mod_graph hsc_env+  if mdl `elem` map ms_mod mg+        then liftIO $ getHomeModuleInfo hsc_env mdl+        else do+  {- if isHomeModule (hsc_dflags hsc_env) mdl+        then return Nothing+        else -} liftIO $ getPackageModuleInfo hsc_env mdl+   -- ToDo: we don't understand what the following comment means.+   --    (SDM, 19/7/2011)+   -- getPackageModuleInfo will attempt to find the interface, so+   -- we don't want to call it for a home module, just in case there+   -- was a problem loading the module and the interface doesn't+   -- exist... hence the isHomeModule test here.  (ToDo: reinstate)++getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)+getPackageModuleInfo hsc_env mdl+  = do  eps <- hscEPS hsc_env+        iface <- hscGetModuleInterface hsc_env mdl+        let+            avails = mi_exports iface+            pte    = eps_PTE eps+            tys    = [ ty | name <- concatMap availNames avails,+                            Just ty <- [lookupTypeEnv pte name] ]+        --+        return (Just (ModuleInfo {+                        minf_type_env  = mkTypeEnv tys,+                        minf_exports   = avails,+                        minf_rdr_env   = Just $! availsToGlobalRdrEnv (moduleName mdl) avails,+                        minf_instances = error "getModuleInfo: instances for package module unimplemented",+                        minf_iface     = Just iface,+                        minf_safe      = getSafeMode $ mi_trust iface,+                        minf_modBreaks = emptyModBreaks+                }))++getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)+getHomeModuleInfo hsc_env mdl =+  case lookupHpt (hsc_HPT hsc_env) (moduleName mdl) of+    Nothing  -> return Nothing+    Just hmi -> do+      let details = hm_details hmi+          iface   = hm_iface hmi+      return (Just (ModuleInfo {+                        minf_type_env  = md_types details,+                        minf_exports   = md_exports details,+                        minf_rdr_env   = mi_globals $! hm_iface hmi,+                        minf_instances = md_insts details,+                        minf_iface     = Just iface,+                        minf_safe      = getSafeMode $ mi_trust iface+                       ,minf_modBreaks = getModBreaks hmi+                        }))++-- | The list of top-level entities defined in a module+modInfoTyThings :: ModuleInfo -> [TyThing]+modInfoTyThings minf = typeEnvElts (minf_type_env minf)++modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]+modInfoTopLevelScope minf+  = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)++modInfoExports :: ModuleInfo -> [Name]+modInfoExports minf = concatMap availNames $! minf_exports minf++modInfoExportsWithSelectors :: ModuleInfo -> [Name]+modInfoExportsWithSelectors minf = concatMap availNamesWithSelectors $! minf_exports minf++-- | Returns the instances defined by the specified module.+-- Warning: currently unimplemented for package modules.+modInfoInstances :: ModuleInfo -> [ClsInst]+modInfoInstances = minf_instances++modInfoIsExportedName :: ModuleInfo -> Name -> Bool+modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf))++mkPrintUnqualifiedForModule :: GhcMonad m =>+                               ModuleInfo+                            -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X+mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do+  return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf))++modInfoLookupName :: GhcMonad m =>+                     ModuleInfo -> Name+                  -> m (Maybe TyThing) -- XXX: returns a Maybe X+modInfoLookupName minf name = withSession $ \hsc_env -> do+   case lookupTypeEnv (minf_type_env minf) name of+     Just tyThing -> return (Just tyThing)+     Nothing      -> do+       eps <- liftIO $ readIORef (hsc_EPS hsc_env)+       return $! lookupType (hsc_dflags hsc_env)+                            (hsc_HPT hsc_env) (eps_PTE eps) name++modInfoIface :: ModuleInfo -> Maybe ModIface+modInfoIface = minf_iface++-- | Retrieve module safe haskell mode+modInfoSafe :: ModuleInfo -> SafeHaskellMode+modInfoSafe = minf_safe++modInfoModBreaks :: ModuleInfo -> ModBreaks+modInfoModBreaks = minf_modBreaks++isDictonaryId :: Id -> Bool+isDictonaryId id+  = case tcSplitSigmaTy (idType id) of {+      (_tvs, _theta, tau) -> isDictTy tau }++-- | Looks up a global name: that is, any top-level name in any+-- visible module.  Unlike 'lookupName', lookupGlobalName does not use+-- the interactive context, and therefore does not require a preceding+-- 'setContext'.+lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing)+lookupGlobalName name = withSession $ \hsc_env -> do+   liftIO $ lookupTypeHscEnv hsc_env name++findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a]+findGlobalAnns deserialize target = withSession $ \hsc_env -> do+    ann_env <- liftIO $ prepareAnnotations hsc_env Nothing+    return (findAnns deserialize ann_env target)++-- | get the GlobalRdrEnv for a session+getGRE :: GhcMonad m => m GlobalRdrEnv+getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env)++-- | Retrieve all type and family instances in the environment, indexed+-- by 'Name'. Each name's lists will contain every instance in which that name+-- is mentioned in the instance head.+getNameToInstancesIndex :: GhcMonad m+  => m (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))+getNameToInstancesIndex = do+  hsc_env <- getSession+  liftIO $ runTcInteractive hsc_env $+    do { loadUnqualIfaces hsc_env (hsc_IC hsc_env)+       ; InstEnvs {ie_global, ie_local, ie_visible} <- tcGetInstEnvs+       ; (pkg_fie, home_fie) <- tcGetFamInstEnvs+       -- We use Data.Sequence.Seq because we are creating left associated+       -- mappends.+       -- cls_index and fam_index below are adapted from TcRnDriver.lookupInsts+       ; let cls_index = Map.fromListWith mappend+                 [ (n, Seq.singleton ispec)+                 | ispec <- instEnvElts ie_local ++ instEnvElts ie_global+                 , instIsVisible ie_visible ispec+                 , n <- nameSetElemsStable $ orphNamesOfClsInst ispec+                 ]+       ; let fam_index = Map.fromListWith mappend+                 [ (n, Seq.singleton fispec)+                 | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie+                 , n <- nameSetElemsStable $ orphNamesOfFamInst fispec+                 ]+       ; return $ mkNameEnv $+           [ (nm, (toList clss, toList fams))+           | (nm, (clss, fams)) <- Map.toList $ Map.unionWith mappend+               (fmap (,Seq.empty) cls_index)+               (fmap (Seq.empty,) fam_index)+           ] }++-- -----------------------------------------------------------------------------++{- ToDo: Move the primary logic here to compiler/main/Packages.hs+-- | Return all /external/ modules available in the package database.+-- Modules from the current session (i.e., from the 'HomePackageTable') are+-- not included.  This includes module names which are reexported by packages.+packageDbModules :: GhcMonad m =>+                    Bool  -- ^ Only consider exposed packages.+                 -> m [Module]+packageDbModules only_exposed = do+   dflags <- getSessionDynFlags+   let pkgs = eltsUFM (pkgIdMap (pkgState dflags))+   return $+     [ mkModule pid modname+     | p <- pkgs+     , not only_exposed || exposed p+     , let pid = packageConfigId p+     , modname <- exposedModules p+               ++ map exportName (reexportedModules p) ]+               -}++-- -----------------------------------------------------------------------------+-- Misc exported utils++dataConType :: DataCon -> Type+dataConType dc = idType (dataConWrapId dc)++-- | print a 'NamedThing', adding parentheses if the name is an operator.+pprParenSymName :: NamedThing a => a -> SDoc+pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))++-- ----------------------------------------------------------------------------++#if 0++-- ToDo:+--   - Data and Typeable instances for HsSyn.++-- ToDo: check for small transformations that happen to the syntax in+-- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral)++-- ToDo: maybe use TH syntax instead of IfaceSyn?  There's already a way+-- to get from TyCons, Ids etc. to TH syntax (reify).++-- :browse will use either lm_toplev or inspect lm_interface, depending+-- on whether the module is interpreted or not.++#endif++-- Extract the filename, stringbuffer content and dynflags associed to a module+--+-- XXX: Explain pre-conditions+getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags)+getModuleSourceAndFlags mod = do+  m <- getModSummary (moduleName mod)+  case ml_hs_file $ ms_location m of+    Nothing -> do dflags <- getDynFlags+                  liftIO $ throwIO $ mkApiErr dflags (text "No source available for module " <+> ppr mod)+    Just sourceFile -> do+        source <- liftIO $ hGetStringBuffer sourceFile+        return (sourceFile, source, ms_hspp_opts m)+++-- | Return module source as token stream, including comments.+--+-- The module must be in the module graph and its source must be available.+-- Throws a 'HscTypes.SourceError' on parse error.+getTokenStream :: GhcMonad m => Module -> m [Located Token]+getTokenStream mod = do+  (sourceFile, source, flags) <- getModuleSourceAndFlags mod+  let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1+  case lexTokenStream source startLoc flags of+    POk _ ts  -> return ts+    PFailed span err ->+        do dflags <- getDynFlags+           liftIO $ throwIO $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)++-- | Give even more information on the source than 'getTokenStream'+-- This function allows reconstructing the source completely with+-- 'showRichTokenStream'.+getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]+getRichTokenStream mod = do+  (sourceFile, source, flags) <- getModuleSourceAndFlags mod+  let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1+  case lexTokenStream source startLoc flags of+    POk _ ts -> return $ addSourceToTokens startLoc source ts+    PFailed span err ->+        do dflags <- getDynFlags+           liftIO $ throwIO $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)++-- | Given a source location and a StringBuffer corresponding to this+-- location, return a rich token stream with the source associated to the+-- tokens.+addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token]+                  -> [(Located Token, String)]+addSourceToTokens _ _ [] = []+addSourceToTokens loc buf (t@(L span _) : ts)+    = case span of+      UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts+      RealSrcSpan s   -> (t,str) : addSourceToTokens newLoc newBuf ts+        where+          (newLoc, newBuf, str) = go "" loc buf+          start = realSrcSpanStart s+          end = realSrcSpanEnd s+          go acc loc buf | loc < start = go acc nLoc nBuf+                         | start <= loc && loc < end = go (ch:acc) nLoc nBuf+                         | otherwise = (loc, buf, reverse acc)+              where (ch, nBuf) = nextChar buf+                    nLoc = advanceSrcLoc loc ch+++-- | Take a rich token stream such as produced from 'getRichTokenStream' and+-- return source code almost identical to the original code (except for+-- insignificant whitespace.)+showRichTokenStream :: [(Located Token, String)] -> String+showRichTokenStream ts = go startLoc ts ""+    where sourceFile = getFile $ map (getLoc . fst) ts+          getFile [] = panic "showRichTokenStream: No source file found"+          getFile (UnhelpfulSpan _ : xs) = getFile xs+          getFile (RealSrcSpan s : _) = srcSpanFile s+          startLoc = mkRealSrcLoc sourceFile 1 1+          go _ [] = id+          go loc ((L span _, str):ts)+              = case span of+                UnhelpfulSpan _ -> go loc ts+                RealSrcSpan s+                 | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++)+                                       . (str ++)+                                       . go tokEnd ts+                 | otherwise -> ((replicate (tokLine - locLine) '\n') ++)+                               . ((replicate (tokCol - 1) ' ') ++)+                              . (str ++)+                              . go tokEnd ts+                  where (locLine, locCol) = (srcLocLine loc, srcLocCol loc)+                        (tokLine, tokCol) = (srcSpanStartLine s, srcSpanStartCol s)+                        tokEnd = realSrcSpanEnd s++-- -----------------------------------------------------------------------------+-- Interactive evaluation++-- | Takes a 'ModuleName' and possibly a 'UnitId', and consults the+-- filesystem and package database to find the corresponding 'Module',+-- using the algorithm that is used for an @import@ declaration.+findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module+findModule mod_name maybe_pkg = withSession $ \hsc_env -> do+  let+    dflags   = hsc_dflags hsc_env+    this_pkg = thisPackage dflags+  --+  case maybe_pkg of+    Just pkg | fsToUnitId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do+      res <- findImportedModule hsc_env mod_name maybe_pkg+      case res of+        Found _ m -> return m+        err       -> throwOneError $ noModError dflags noSrcSpan mod_name err+    _otherwise -> do+      home <- lookupLoadedHomeModule mod_name+      case home of+        Just m  -> return m+        Nothing -> liftIO $ do+           res <- findImportedModule hsc_env mod_name maybe_pkg+           case res of+             Found loc m | moduleUnitId m /= this_pkg -> return m+                         | otherwise -> modNotLoadedError dflags m loc+             err -> throwOneError $ noModError dflags noSrcSpan mod_name err++modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a+modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $+   text "module is not loaded:" <+>+   quotes (ppr (moduleName m)) <+>+   parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))++-- | Like 'findModule', but differs slightly when the module refers to+-- a source file, and the file has not been loaded via 'load'.  In+-- this case, 'findModule' will throw an error (module not loaded),+-- but 'lookupModule' will check to see whether the module can also be+-- found in a package, and if so, that package 'Module' will be+-- returned.  If not, the usual module-not-found error will be thrown.+--+lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module+lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg)+lookupModule mod_name Nothing = withSession $ \hsc_env -> do+  home <- lookupLoadedHomeModule mod_name+  case home of+    Just m  -> return m+    Nothing -> liftIO $ do+      res <- findExposedPackageModule hsc_env mod_name Nothing+      case res of+        Found _ m -> return m+        err       -> throwOneError $ noModError (hsc_dflags hsc_env) noSrcSpan mod_name err++lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module)+lookupLoadedHomeModule mod_name = withSession $ \hsc_env ->+  case lookupHpt (hsc_HPT hsc_env) mod_name of+    Just mod_info      -> return (Just (mi_module (hm_iface mod_info)))+    _not_a_home_module -> return Nothing++-- | Check that a module is safe to import (according to Safe Haskell).+--+-- We return True to indicate the import is safe and False otherwise+-- although in the False case an error may be thrown first.+isModuleTrusted :: GhcMonad m => Module -> m Bool+isModuleTrusted m = withSession $ \hsc_env ->+    liftIO $ hscCheckSafe hsc_env m noSrcSpan++-- | Return if a module is trusted and the pkgs it depends on to be trusted.+moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set InstalledUnitId)+moduleTrustReqs m = withSession $ \hsc_env ->+    liftIO $ hscGetSafe hsc_env m noSrcSpan++-- | Set the monad GHCi lifts user statements into.+--+-- Checks that a type (in string form) is an instance of the+-- @GHC.GHCi.GHCiSandboxIO@ type class. Sets it to be the GHCi monad if it is,+-- throws an error otherwise.+setGHCiMonad :: GhcMonad m => String -> m ()+setGHCiMonad name = withSession $ \hsc_env -> do+    ty <- liftIO $ hscIsGHCiMonad hsc_env name+    modifySession $ \s ->+        let ic = (hsc_IC s) { ic_monad = ty }+        in s { hsc_IC = ic }++-- | Get the monad GHCi lifts user statements into.+getGHCiMonad :: GhcMonad m => m Name+getGHCiMonad = fmap (ic_monad . hsc_IC) getSession++getHistorySpan :: GhcMonad m => History -> m SrcSpan+getHistorySpan h = withSession $ \hsc_env ->+    return $ InteractiveEval.getHistorySpan hsc_env h++obtainTermFromVal :: GhcMonad m => Int ->  Bool -> Type -> a -> m Term+obtainTermFromVal bound force ty a = withSession $ \hsc_env ->+    liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a++obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term+obtainTermFromId bound force id = withSession $ \hsc_env ->+    liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id+++-- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any+-- entity known to GHC, including 'Name's defined using 'runStmt'.+lookupName :: GhcMonad m => Name -> m (Maybe TyThing)+lookupName name =+     withSession $ \hsc_env ->+       liftIO $ hscTcRcLookupName hsc_env name++-- -----------------------------------------------------------------------------+-- Pure API++-- | A pure interface to the module parser.+--+parser :: String         -- ^ Haskell module source text (full Unicode is supported)+       -> DynFlags       -- ^ the flags+       -> FilePath       -- ^ the filename (for source locations)+       -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName))++parser str dflags filename =+   let+       loc  = mkRealSrcLoc (mkFastString filename) 1 1+       buf  = stringToStringBuffer str+   in+   case unP Parser.parseModule (mkPState dflags buf loc) of++     PFailed span err   ->+         Left (unitBag (mkPlainErrMsg dflags span err))++     POk pst rdr_module ->+         let (warns,_) = getMessages pst dflags in+         Right (warns, rdr_module)
+ main/GhcMake.hs view
@@ -0,0 +1,2258 @@+{-# LANGUAGE BangPatterns, CPP, NondecreasingIndentation, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}+-- NB: we specifically ignore deprecations. GHC 7.6 marks the .QSem module as+-- deprecated, although it became un-deprecated later. As a result, using 7.6+-- as your bootstrap compiler throws annoying warnings.++-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow, 2011+--+-- This module implements multi-module compilation, and is used+-- by --make and GHCi.+--+-- -----------------------------------------------------------------------------+module GhcMake(+        depanal,+        load, load', LoadHowMuch(..),++        topSortModuleGraph,++        ms_home_srcimps, ms_home_imps,++        IsBoot(..),+        summariseModule,+        hscSourceToIsBoot,+        findExtraSigImports,+        implicitRequirements,++        noModError, cyclicModuleErr,+        moduleGraphNodes, SummaryNode+    ) where++#include "HsVersions.h"++import qualified Linker         ( unload )++import DriverPhases+import DriverPipeline+import DynFlags+import ErrUtils+import Finder+import GhcMonad+import HeaderInfo+import HscTypes+import Module+import TcIface          ( typecheckIface )+import TcRnMonad        ( initIfaceCheck )+import HscMain++import Bag              ( listToBag )+import BasicTypes+import Digraph+import Exception        ( tryIO, gbracket, gfinally )+import FastString+import Maybes           ( expectJust )+import Name+import MonadUtils       ( allM, MonadIO )+import Outputable+import Panic+import SrcLoc+import StringBuffer+import SysTools+import UniqFM+import UniqDSet+import TcBackpack+import Packages+import UniqSet+import Util+import qualified GHC.LanguageExtensions as LangExt+import NameEnv++import Data.Either ( rights, partitionEithers )+import qualified Data.Map as Map+import Data.Map (Map)+import qualified Data.Set as Set+import qualified FiniteMap as Map ( insertListWith )++import Control.Concurrent ( forkIOWithUnmask, killThread )+import qualified GHC.Conc as CC+import Control.Concurrent.MVar+import Control.Concurrent.QSem+import Control.Exception+import Control.Monad+import Data.IORef+import Data.List+import qualified Data.List as List+import Data.Maybe+import Data.Ord ( comparing )+import Data.Time+import System.Directory+import System.FilePath+import System.IO        ( fixIO )+import System.IO.Error  ( isDoesNotExistError )++import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )++label_self :: String -> IO ()+label_self thread_name = do+    self_tid <- CC.myThreadId+    CC.labelThread self_tid thread_name++-- -----------------------------------------------------------------------------+-- Loading the program++-- | Perform a dependency analysis starting from the current targets+-- and update the session with the new module graph.+--+-- Dependency analysis entails parsing the @import@ directives and may+-- therefore require running certain preprocessors.+--+-- Note that each 'ModSummary' in the module graph caches its 'DynFlags'.+-- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the+-- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module.  Thus if you want+-- changes to the 'DynFlags' to take effect you need to call this function+-- again.+--+depanal :: GhcMonad m =>+           [ModuleName]  -- ^ excluded modules+        -> Bool          -- ^ allow duplicate roots+        -> m ModuleGraph+depanal excluded_mods allow_dup_roots = do+  hsc_env <- getSession+  let+         dflags  = hsc_dflags hsc_env+         targets = hsc_targets hsc_env+         old_graph = hsc_mod_graph hsc_env++  withTiming (pure dflags) (text "Chasing dependencies") (const ()) $ do+    liftIO $ debugTraceMsg dflags 2 (hcat [+              text "Chasing modules from: ",+              hcat (punctuate comma (map pprTarget targets))])++    mod_graphE <- liftIO $ downsweep hsc_env old_graph+                                     excluded_mods allow_dup_roots+    mod_graph <- reportImportErrors mod_graphE++    warnMissingHomeModules hsc_env mod_graph++    setSession hsc_env { hsc_mod_graph = mod_graph }+    return mod_graph++-- Note [Missing home modules]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Sometimes user doesn't want GHC to pick up modules, not explicitly listed+-- in a command line. For example, cabal may want to enable this warning+-- when building a library, so that GHC warns user about modules, not listed+-- neither in `exposed-modules`, nor in `other-modules`.+--+-- Here "home module" means a module, that doesn't come from an other package.+--+-- For example, if GHC is invoked with modules "A" and "B" as targets,+-- but "A" imports some other module "C", then GHC will issue a warning+-- about module "C" not being listed in a command line.+--+-- The warning in enabled by `-Wmissing-home-modules`. See Trac #13129+warnMissingHomeModules :: GhcMonad m => HscEnv -> ModuleGraph -> m ()+warnMissingHomeModules hsc_env mod_graph =+    when (wopt Opt_WarnMissingHomeModules dflags && not (null missing)) $+        logWarnings (listToBag [warn])+  where+    dflags = hsc_dflags hsc_env+    targets = map targetId (hsc_targets hsc_env)++    is_known_module mod = any (is_my_target mod) targets++    -- We need to be careful to handle the case where (possibly+    -- path-qualified) filenames (aka 'TargetFile') rather than module+    -- names are being passed on the GHC command-line.+    --+    -- For instance, `ghc --make src-exe/Main.hs` and+    -- `ghc --make -isrc-exe Main` are supposed to be equivalent.+    -- Note also that we can't always infer the associated module name+    -- directly from the filename argument.  See Trac #13727.+    is_my_target mod (TargetModule name)+      = moduleName (ms_mod mod) == name+    is_my_target mod (TargetFile target_file _)+      | Just mod_file <- ml_hs_file (ms_location mod)+      = target_file == mod_file ||+           --  We can get a file target even if a module name was+           --  originally specified in a command line because it can+           --  be converted in guessTarget (by appending .hs/.lhs).+           --  So let's convert it back and compare with module name+           mkModuleName (fst $ splitExtension target_file)+            == moduleName (ms_mod mod)+    is_my_target _ _ = False++    missing = map (moduleName . ms_mod) $+      filter (not . is_known_module) mod_graph++    msg+      | gopt Opt_BuildingCabalPackage dflags+      = text "These modules are needed for compilation but not listed in your .cabal file's other-modules: "+        <> sep (map ppr missing)+      | otherwise+      = text "Modules are not listed in command line but needed for compilation: "+        <> sep (map ppr missing)+    warn = makeIntoWarning+      (Reason Opt_WarnMissingHomeModules)+      (mkPlainErrMsg dflags noSrcSpan msg)++-- | Describes which modules of the module graph need to be loaded.+data LoadHowMuch+   = LoadAllTargets+     -- ^ Load all targets and its dependencies.+   | LoadUpTo ModuleName+     -- ^ Load only the given module and its dependencies.+   | LoadDependenciesOf ModuleName+     -- ^ Load only the dependencies of the given module, but not the module+     -- itself.++-- | Try to load the program.  See 'LoadHowMuch' for the different modes.+--+-- This function implements the core of GHC's @--make@ mode.  It preprocesses,+-- compiles and loads the specified modules, avoiding re-compilation wherever+-- possible.  Depending on the target (see 'DynFlags.hscTarget') compiling+-- and loading may result in files being created on disk.+--+-- Calls the 'defaultWarnErrLogger' after each compiling each module, whether+-- successful or not.+--+-- Throw a 'SourceError' if errors are encountered before the actual+-- compilation starts (e.g., during dependency analysis).  All other errors+-- are reported using the 'defaultWarnErrLogger'.+--+load :: GhcMonad m => LoadHowMuch -> m SuccessFlag+load how_much = do+    mod_graph <- depanal [] False+    load' how_much (Just batchMsg) mod_graph++-- | Generalized version of 'load' which also supports a custom+-- 'Messager' (for reporting progress) and 'ModuleGraph' (generally+-- produced by calling 'depanal'.+load' :: GhcMonad m => LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag+load' how_much mHscMessage mod_graph = do+    modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph }+    guessOutputFile+    hsc_env <- getSession++    let hpt1   = hsc_HPT hsc_env+    let dflags = hsc_dflags hsc_env++    -- The "bad" boot modules are the ones for which we have+    -- B.hs-boot in the module graph, but no B.hs+    -- The downsweep should have ensured this does not happen+    -- (see msDeps)+    let all_home_mods = [ms_mod_name s+                        | s <- mod_graph, not (isBootSummary s)]+    -- TODO: Figure out what the correct form of this assert is. It's violated+    -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot+    -- files without corresponding hs files.+    --  bad_boot_mods = [s        | s <- mod_graph, isBootSummary s,+    --                              not (ms_mod_name s `elem` all_home_mods)]+    -- ASSERT( null bad_boot_mods ) return ()++    -- check that the module given in HowMuch actually exists, otherwise+    -- topSortModuleGraph will bomb later.+    let checkHowMuch (LoadUpTo m)           = checkMod m+        checkHowMuch (LoadDependenciesOf m) = checkMod m+        checkHowMuch _ = id++        checkMod m and_then+            | m `elem` all_home_mods = and_then+            | otherwise = do+                    liftIO $ errorMsg dflags (text "no such module:" <+>+                                     quotes (ppr m))+                    return Failed++    checkHowMuch how_much $ do++    -- mg2_with_srcimps drops the hi-boot nodes, returning a+    -- graph with cycles.  Among other things, it is used for+    -- backing out partially complete cycles following a failed+    -- upsweep, and for removing from hpt all the modules+    -- not in strict downwards closure, during calls to compile.+    let mg2_with_srcimps :: [SCC ModSummary]+        mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing++    -- If we can determine that any of the {-# SOURCE #-} imports+    -- are definitely unnecessary, then emit a warning.+    warnUnnecessarySourceImports mg2_with_srcimps++    let+        -- check the stability property for each module.+        stable_mods@(stable_obj,stable_bco)+            = checkStability hpt1 mg2_with_srcimps all_home_mods++        -- prune bits of the HPT which are definitely redundant now,+        -- to save space.+        pruned_hpt = pruneHomePackageTable hpt1+                            (flattenSCCs mg2_with_srcimps)+                            stable_mods++    _ <- liftIO $ evaluate pruned_hpt++    -- before we unload anything, make sure we don't leave an old+    -- interactive context around pointing to dead bindings.  Also,+    -- write the pruned HPT to allow the old HPT to be GC'd.+    setSession $ discardIC $ hsc_env { hsc_HPT = pruned_hpt }++    liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$+                            text "Stable BCO:" <+> ppr stable_bco)++    -- Unload any modules which are going to be re-linked this time around.+    let stable_linkables = [ linkable+                           | m <- stable_obj++stable_bco,+                             Just hmi <- [lookupHpt pruned_hpt m],+                             Just linkable <- [hm_linkable hmi] ]+    liftIO $ unload hsc_env stable_linkables++    -- We could at this point detect cycles which aren't broken by+    -- a source-import, and complain immediately, but it seems better+    -- to let upsweep_mods do this, so at least some useful work gets+    -- done before the upsweep is abandoned.+    --hPutStrLn stderr "after tsort:\n"+    --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))++    -- Now do the upsweep, calling compile for each module in+    -- turn.  Final result is version 3 of everything.++    -- Topologically sort the module graph, this time including hi-boot+    -- nodes, and possibly just including the portion of the graph+    -- reachable from the module specified in the 2nd argument to load.+    -- This graph should be cycle-free.+    -- If we're restricting the upsweep to a portion of the graph, we+    -- also want to retain everything that is still stable.+    let full_mg :: [SCC ModSummary]+        full_mg    = topSortModuleGraph False mod_graph Nothing++        maybe_top_mod = case how_much of+                            LoadUpTo m           -> Just m+                            LoadDependenciesOf m -> Just m+                            _                    -> Nothing++        partial_mg0 :: [SCC ModSummary]+        partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod++        -- LoadDependenciesOf m: we want the upsweep to stop just+        -- short of the specified module (unless the specified module+        -- is stable).+        partial_mg+            | LoadDependenciesOf _mod <- how_much+            = ASSERT( case last partial_mg0 of+                        AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False )+              List.init partial_mg0+            | otherwise+            = partial_mg0++        stable_mg =+            [ AcyclicSCC ms+            | AcyclicSCC ms <- full_mg,+              ms_mod_name ms `elem` stable_obj++stable_bco ]++        -- the modules from partial_mg that are not also stable+        -- NB. also keep cycles, we need to emit an error message later+        unstable_mg = filter not_stable partial_mg+          where not_stable (CyclicSCC _) = True+                not_stable (AcyclicSCC ms)+                   = ms_mod_name ms `notElem` stable_obj++stable_bco++        -- Load all the stable modules first, before attempting to load+        -- an unstable module (#7231).+        mg = stable_mg ++ unstable_mg++    -- clean up between compilations+    let cleanup hsc_env = intermediateCleanTempFiles (hsc_dflags hsc_env)+                              (flattenSCCs mg2_with_srcimps)+                              hsc_env++    liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")+                               2 (ppr mg))++    n_jobs <- case parMakeCount dflags of+                    Nothing -> liftIO getNumProcessors+                    Just n  -> return n+    let upsweep_fn | n_jobs > 1 = parUpsweep n_jobs+                   | otherwise  = upsweep++    setSession hsc_env{ hsc_HPT = emptyHomePackageTable }+    (upsweep_ok, modsUpswept)+       <- upsweep_fn mHscMessage pruned_hpt stable_mods cleanup mg++    -- Make modsDone be the summaries for each home module now+    -- available; this should equal the domain of hpt3.+    -- Get in in a roughly top .. bottom order (hence reverse).++    let modsDone = reverse modsUpswept++    -- Try and do linking in some form, depending on whether the+    -- upsweep was completely or only partially successful.++    if succeeded upsweep_ok++     then+       -- Easy; just relink it all.+       do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.")++          -- Clean up after ourselves+          hsc_env1 <- getSession+          liftIO $ intermediateCleanTempFiles dflags modsDone hsc_env1++          -- Issue a warning for the confusing case where the user+          -- said '-o foo' but we're not going to do any linking.+          -- We attempt linking if either (a) one of the modules is+          -- called Main, or (b) the user said -no-hs-main, indicating+          -- that main() is going to come from somewhere else.+          --+          let ofile = outputFile dflags+          let no_hs_main = gopt Opt_NoHsMain dflags+          let+            main_mod = mainModIs dflags+            a_root_is_Main = any ((==main_mod).ms_mod) mod_graph+            do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib++          -- link everything together+          linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)++          if ghcLink dflags == LinkBinary && isJust ofile && not do_linking+             then do+                liftIO $ errorMsg dflags $ text+                   ("output was redirected with -o, " +++                    "but no output will be generated\n" +++                    "because there is no " +++                    moduleNameString (moduleName main_mod) ++ " module.")+                -- This should be an error, not a warning (#10895).+                loadFinish Failed linkresult+             else+                loadFinish Succeeded linkresult++     else+       -- Tricky.  We need to back out the effects of compiling any+       -- half-done cycles, both so as to clean up the top level envs+       -- and to avoid telling the interactive linker to link them.+       do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.")++          let modsDone_names+                 = map ms_mod modsDone+          let mods_to_zap_names+                 = findPartiallyCompletedCycles modsDone_names+                      mg2_with_srcimps+          let mods_to_keep+                 = filter ((`Set.notMember` mods_to_zap_names).ms_mod)+                      modsDone++          hsc_env1 <- getSession+          let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)+                                          (hsc_HPT hsc_env1)++          -- Clean up after ourselves+          liftIO $ intermediateCleanTempFiles dflags mods_to_keep hsc_env1++          -- there should be no Nothings where linkables should be, now+          let just_linkables =+                    isNoLink (ghcLink dflags)+                 || allHpt (isJust.hm_linkable)+                        (filterHpt ((== HsSrcFile).mi_hsc_src.hm_iface)+                                hpt4)+          ASSERT( just_linkables ) do++          -- Link everything together+          linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4++          modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 }+          loadFinish Failed linkresult+++-- | Finish up after a load.+loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag++-- If the link failed, unload everything and return.+loadFinish _all_ok Failed+  = do hsc_env <- getSession+       liftIO $ unload hsc_env []+       modifySession discardProg+       return Failed++-- Empty the interactive context and set the module context to the topmost+-- newly loaded module, or the Prelude if none were loaded.+loadFinish all_ok Succeeded+  = do modifySession discardIC+       return all_ok+++-- | Forget the current program, but retain the persistent info in HscEnv+discardProg :: HscEnv -> HscEnv+discardProg hsc_env+  = discardIC $ hsc_env { hsc_mod_graph = emptyMG+                        , hsc_HPT = emptyHomePackageTable }++-- | Discard the contents of the InteractiveContext, but keep the DynFlags.+-- It will also keep ic_int_print and ic_monad if their names are from+-- external packages.+discardIC :: HscEnv -> HscEnv+discardIC hsc_env+  = hsc_env { hsc_IC = empty_ic { ic_int_print = new_ic_int_print+                                , ic_monad = new_ic_monad } }+  where+  -- Force the new values for ic_int_print and ic_monad to avoid leaking old_ic+  !new_ic_int_print = keep_external_name ic_int_print+  !new_ic_monad = keep_external_name ic_monad+  dflags = ic_dflags old_ic+  old_ic = hsc_IC hsc_env+  empty_ic = emptyInteractiveContext dflags+  keep_external_name ic_name+    | nameIsFromExternalPackage this_pkg old_name = old_name+    | otherwise = ic_name empty_ic+    where+    this_pkg = thisPackage dflags+    old_name = ic_name old_ic++intermediateCleanTempFiles :: DynFlags -> [ModSummary] -> HscEnv -> IO ()+intermediateCleanTempFiles dflags summaries hsc_env+ = do notIntermediate <- readIORef (filesToNotIntermediateClean dflags)+      cleanTempFilesExcept dflags (notIntermediate ++ except)+  where+    except =+          -- Save preprocessed files. The preprocessed file *might* be+          -- the same as the source file, but that doesn't do any+          -- harm.+          map ms_hspp_file summaries +++          -- Save object files for loaded modules.  The point of this+          -- is that we might have generated and compiled a stub C+          -- file, and in the case of GHCi the object file will be a+          -- temporary file which we must not remove because we need+          -- to load/link it later.+          hptObjs (hsc_HPT hsc_env)++-- | If there is no -o option, guess the name of target executable+-- by using top-level source file name as a base.+guessOutputFile :: GhcMonad m => m ()+guessOutputFile = modifySession $ \env ->+    let dflags = hsc_dflags env+        -- Force mod_graph to avoid leaking env+        !mod_graph = hsc_mod_graph env+        mainModuleSrcPath :: Maybe String+        mainModuleSrcPath = do+            let isMain = (== mainModIs dflags) . ms_mod+            [ms] <- return (filter isMain mod_graph)+            ml_hs_file (ms_location ms)+        name = fmap dropExtension mainModuleSrcPath++        name_exe = do+#if defined(mingw32_HOST_OS)+          -- we must add the .exe extension unconditionally here, otherwise+          -- when name has an extension of its own, the .exe extension will+          -- not be added by DriverPipeline.exeFileName.  See #2248+          name' <- fmap (<.> "exe") name+#else+          name' <- name+#endif+          mainModuleSrcPath' <- mainModuleSrcPath+          -- #9930: don't clobber input files (unless they ask for it)+          if name' == mainModuleSrcPath'+            then throwGhcException . UsageError $+                 "default output name would overwrite the input file; " +++                 "must specify -o explicitly"+            else Just name'+    in+    case outputFile dflags of+        Just _ -> env+        Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } }++-- -----------------------------------------------------------------------------+--+-- | Prune the HomePackageTable+--+-- Before doing an upsweep, we can throw away:+--+--   - For non-stable modules:+--      - all ModDetails, all linked code+--   - all unlinked code that is out of date with respect to+--     the source file+--+-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the+-- space at the end of the upsweep, because the topmost ModDetails of the+-- old HPT holds on to the entire type environment from the previous+-- compilation.+pruneHomePackageTable :: HomePackageTable+                      -> [ModSummary]+                      -> ([ModuleName],[ModuleName])+                      -> HomePackageTable+pruneHomePackageTable hpt summ (stable_obj, stable_bco)+  = mapHpt prune hpt+  where prune hmi+          | is_stable modl = hmi'+          | otherwise      = hmi'{ hm_details = emptyModDetails }+          where+           modl = moduleName (mi_module (hm_iface hmi))+           hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms+                = hmi{ hm_linkable = Nothing }+                | otherwise+                = hmi+                where ms = expectJust "prune" (lookupUFM ms_map modl)++        ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]++        is_stable m = m `elem` stable_obj || m `elem` stable_bco++-- -----------------------------------------------------------------------------+--+-- | Return (names of) all those in modsDone who are part of a cycle as defined+-- by theGraph.+findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> Set.Set Module+findPartiallyCompletedCycles modsDone theGraph+   = Set.unions+       [mods_in_this_cycle+       | CyclicSCC vs <- theGraph  -- Acyclic? Not interesting.+       , let names_in_this_cycle = Set.fromList (map ms_mod vs)+             mods_in_this_cycle =+                    Set.intersection (Set.fromList modsDone) names_in_this_cycle+         -- If size mods_in_this_cycle == size names_in_this_cycle,+         -- then this cycle has already been completed and we're not+         -- interested.+       , Set.size mods_in_this_cycle < Set.size names_in_this_cycle]+++-- ---------------------------------------------------------------------------+--+-- | Unloading+unload :: HscEnv -> [Linkable] -> IO ()+unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'+  = case ghcLink (hsc_dflags hsc_env) of+        LinkInMemory -> Linker.unload hsc_env stable_linkables+        _other -> return ()++-- -----------------------------------------------------------------------------+{- |++  Stability tells us which modules definitely do not need to be recompiled.+  There are two main reasons for having stability:++   - avoid doing a complete upsweep of the module graph in GHCi when+     modules near the bottom of the tree have not changed.++   - to tell GHCi when it can load object code: we can only load object code+     for a module when we also load object code fo  all of the imports of the+     module.  So we need to know that we will definitely not be recompiling+     any of these modules, and we can use the object code.++  The stability check is as follows.  Both stableObject and+  stableBCO are used during the upsweep phase later.++@+  stable m = stableObject m || stableBCO m++  stableObject m =+        all stableObject (imports m)+        && old linkable does not exist, or is == on-disk .o+        && date(on-disk .o) > date(.hs)++  stableBCO m =+        all stable (imports m)+        && date(BCO) > date(.hs)+@++  These properties embody the following ideas:++    - if a module is stable, then:++        - if it has been compiled in a previous pass (present in HPT)+          then it does not need to be compiled or re-linked.++        - if it has not been compiled in a previous pass,+          then we only need to read its .hi file from disk and+          link it to produce a 'ModDetails'.++    - if a modules is not stable, we will definitely be at least+      re-linking, and possibly re-compiling it during the 'upsweep'.+      All non-stable modules can (and should) therefore be unlinked+      before the 'upsweep'.++    - Note that objects are only considered stable if they only depend+      on other objects.  We can't link object code against byte code.++    - Note that even if an object is stable, we may end up recompiling+      if the interface is out of date because an *external* interface+      has changed.  The current code in GhcMake handles this case+      fairly poorly, so be careful.+-}+checkStability+        :: HomePackageTable   -- HPT from last compilation+        -> [SCC ModSummary]   -- current module graph (cyclic)+        -> [ModuleName]       -- all home modules+        -> ([ModuleName],     -- stableObject+            [ModuleName])     -- stableBCO++checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs+  where+   checkSCC (stable_obj, stable_bco) scc0+     | stableObjects = (scc_mods ++ stable_obj, stable_bco)+     | stableBCOs    = (stable_obj, scc_mods ++ stable_bco)+     | otherwise     = (stable_obj, stable_bco)+     where+        scc = flattenSCC scc0+        scc_mods = map ms_mod_name scc+        home_module m   = m `elem` all_home_mods && m `notElem` scc_mods++        scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc))+            -- all imports outside the current SCC, but in the home pkg++        stable_obj_imps = map (`elem` stable_obj) scc_allimps+        stable_bco_imps = map (`elem` stable_bco) scc_allimps++        stableObjects =+           and stable_obj_imps+           && all object_ok scc++        stableBCOs =+           and (zipWith (||) stable_obj_imps stable_bco_imps)+           && all bco_ok scc++        object_ok ms+          | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False+          | Just t <- ms_obj_date ms  =  t >= ms_hs_date ms+                                         && same_as_prev t+          | otherwise = False+          where+             same_as_prev t = case lookupHpt hpt (ms_mod_name ms) of+                                Just hmi  | Just l <- hm_linkable hmi+                                 -> isObjectLinkable l && t == linkableTime l+                                _other  -> True+                -- why '>=' rather than '>' above?  If the filesystem stores+                -- times to the nearset second, we may occasionally find that+                -- the object & source have the same modification time,+                -- especially if the source was automatically generated+                -- and compiled.  Using >= is slightly unsafe, but it matches+                -- make's behaviour.+                --+                -- But see #5527, where someone ran into this and it caused+                -- a problem.++        bco_ok ms+          | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False+          | otherwise = case lookupHpt hpt (ms_mod_name ms) of+                Just hmi  | Just l <- hm_linkable hmi ->+                        not (isObjectLinkable l) &&+                        linkableTime l >= ms_hs_date ms+                _other  -> False++{- Parallel Upsweep+ -+ - The parallel upsweep attempts to concurrently compile the modules in the+ - compilation graph using multiple Haskell threads.+ -+ - The Algorithm+ -+ - A Haskell thread is spawned for each module in the module graph, waiting for+ - its direct dependencies to finish building before it itself begins to build.+ -+ - Each module is associated with an initially empty MVar that stores the+ - result of that particular module's compile. If the compile succeeded, then+ - the HscEnv (synchronized by an MVar) is updated with the fresh HMI of that+ - module, and the module's HMI is deleted from the old HPT (synchronized by an+ - IORef) to save space.+ -+ - Instead of immediately outputting messages to the standard handles, all+ - compilation output is deferred to a per-module TQueue. A QSem is used to+ - limit the number of workers that are compiling simultaneously.+ -+ - Meanwhile, the main thread sequentially loops over all the modules in the+ - module graph, outputting the messages stored in each module's TQueue.+-}++-- | Each module is given a unique 'LogQueue' to redirect compilation messages+-- to. A 'Nothing' value contains the result of compilation, and denotes the+-- end of the message queue.+data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, PprStyle, MsgDoc)])+                         !(MVar ())++-- | The graph of modules to compile and their corresponding result 'MVar' and+-- 'LogQueue'.+type CompilationGraph = [(ModSummary, MVar SuccessFlag, LogQueue)]++-- | Build a 'CompilationGraph' out of a list of strongly-connected modules,+-- also returning the first, if any, encountered module cycle.+buildCompGraph :: [SCC ModSummary] -> IO (CompilationGraph, Maybe [ModSummary])+buildCompGraph [] = return ([], Nothing)+buildCompGraph (scc:sccs) = case scc of+    AcyclicSCC ms -> do+        mvar <- newEmptyMVar+        log_queue <- do+            ref <- newIORef []+            sem <- newEmptyMVar+            return (LogQueue ref sem)+        (rest,cycle) <- buildCompGraph sccs+        return ((ms,mvar,log_queue):rest, cycle)+    CyclicSCC mss -> return ([], Just mss)++-- A Module and whether it is a boot module.+type BuildModule = (Module, IsBoot)++-- | 'Bool' indicating if a module is a boot module or not.  We need to treat+-- boot modules specially when building compilation graphs, since they break+-- cycles.  Regular source files and signature files are treated equivalently.+data IsBoot = IsBoot | NotBoot+    deriving (Ord, Eq, Show, Read)++-- | Tests if an 'HscSource' is a boot file, primarily for constructing+-- elements of 'BuildModule'.+hscSourceToIsBoot :: HscSource -> IsBoot+hscSourceToIsBoot HsBootFile = IsBoot+hscSourceToIsBoot _ = NotBoot++mkBuildModule :: ModSummary -> BuildModule+mkBuildModule ms = (ms_mod ms, if isBootSummary ms then IsBoot else NotBoot)++-- | The entry point to the parallel upsweep.+--+-- See also the simpler, sequential 'upsweep'.+parUpsweep+    :: GhcMonad m+    => Int+    -- ^ The number of workers we wish to run in parallel+    -> Maybe Messager+    -> HomePackageTable+    -> ([ModuleName],[ModuleName])+    -> (HscEnv -> IO ())+    -> [SCC ModSummary]+    -> m (SuccessFlag,+          [ModSummary])+parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do+    hsc_env <- getSession+    let dflags = hsc_dflags hsc_env++    when (not (null (unitIdsToCheck dflags))) $+      throwGhcException (ProgramError "Backpack typechecking not supported with -j")++    -- The bits of shared state we'll be using:++    -- The global HscEnv is updated with the module's HMI when a module+    -- successfully compiles.+    hsc_env_var <- liftIO $ newMVar hsc_env++    -- The old HPT is used for recompilation checking in upsweep_mod. When a+    -- module successfully gets compiled, its HMI is pruned from the old HPT.+    old_hpt_var <- liftIO $ newIORef old_hpt++    -- What we use to limit parallelism with.+    par_sem <- liftIO $ newQSem n_jobs+++    let updNumCapabilities = liftIO $ do+            n_capabilities <- getNumCapabilities+            n_cpus <- getNumProcessors+            -- Setting number of capabilities more than+            -- CPU count usually leads to high userspace+            -- lock contention. Trac #9221+            let n_caps = min n_jobs n_cpus+            unless (n_capabilities /= 1) $ setNumCapabilities n_caps+            return n_capabilities+    -- Reset the number of capabilities once the upsweep ends.+    let resetNumCapabilities orig_n = liftIO $ setNumCapabilities orig_n++    gbracket updNumCapabilities resetNumCapabilities $ \_ -> do++    -- Sync the global session with the latest HscEnv once the upsweep ends.+    let finallySyncSession io = io `gfinally` do+            hsc_env <- liftIO $ readMVar hsc_env_var+            setSession hsc_env++    finallySyncSession $ do++    -- Build the compilation graph out of the list of SCCs. Module cycles are+    -- handled at the very end, after some useful work gets done. Note that+    -- this list is topologically sorted (by virtue of 'sccs' being sorted so).+    (comp_graph,cycle) <- liftIO $ buildCompGraph sccs+    let comp_graph_w_idx = zip comp_graph [1..]++    -- The list of all loops in the compilation graph.+    -- NB: For convenience, the last module of each loop (aka the module that+    -- finishes the loop) is prepended to the beginning of the loop.+    let comp_graph_loops = go (map fstOf3 (reverse comp_graph))+          where+            go [] = []+            go (ms:mss) | Just loop <- getModLoop ms (ms:mss)+                        = map mkBuildModule (ms:loop) : go mss+                        | otherwise+                        = go mss++    -- Build a Map out of the compilation graph with which we can efficiently+    -- look up the result MVar associated with a particular home module.+    let home_mod_map :: Map BuildModule (MVar SuccessFlag, Int)+        home_mod_map =+            Map.fromList [ (mkBuildModule ms, (mvar, idx))+                         | ((ms,mvar,_),idx) <- comp_graph_w_idx ]+++    liftIO $ label_self "main --make thread"+    -- For each module in the module graph, spawn a worker thread that will+    -- compile this module.+    let { spawnWorkers = forM comp_graph_w_idx $ \((mod,!mvar,!log_queue),!mod_idx) ->+            forkIOWithUnmask $ \unmask -> do+                liftIO $ label_self $ unwords+                    [ "worker --make thread"+                    , "for module"+                    , show (moduleNameString (ms_mod_name mod))+                    , "number"+                    , show mod_idx+                    ]+                -- Replace the default log_action with one that writes each+                -- message to the module's log_queue. The main thread will+                -- deal with synchronously printing these messages.+                --+                -- Use a local filesToClean var so that we can clean up+                -- intermediate files in a timely fashion (as soon as+                -- compilation for that module is finished) without having to+                -- worry about accidentally deleting a simultaneous compile's+                -- important files.+                lcl_files_to_clean <- newIORef []+                let lcl_dflags = dflags { log_action = parLogAction log_queue+                                        , filesToClean = lcl_files_to_clean }++                -- Unmask asynchronous exceptions and perform the thread-local+                -- work to compile the module (see parUpsweep_one).+                m_res <- try $ unmask $ prettyPrintGhcErrors lcl_dflags $+                        parUpsweep_one mod home_mod_map comp_graph_loops+                                       lcl_dflags mHscMessage cleanup+                                       par_sem hsc_env_var old_hpt_var+                                       stable_mods mod_idx (length sccs)++                res <- case m_res of+                    Right flag -> return flag+                    Left exc -> do+                        -- Don't print ThreadKilled exceptions: they are used+                        -- to kill the worker thread in the event of a user+                        -- interrupt, and the user doesn't have to be informed+                        -- about that.+                        when (fromException exc /= Just ThreadKilled)+                             (errorMsg lcl_dflags (text (show exc)))+                        return Failed++                -- Populate the result MVar.+                putMVar mvar res++                -- Write the end marker to the message queue, telling the main+                -- thread that it can stop waiting for messages from this+                -- particular compile.+                writeLogQueue log_queue Nothing++                -- Add the remaining files that weren't cleaned up to the+                -- global filesToClean ref, for cleanup later.+                files_kept <- readIORef (filesToClean lcl_dflags)+                addFilesToClean dflags files_kept+++        -- Kill all the workers, masking interrupts (since killThread is+        -- interruptible). XXX: This is not ideal.+        ; killWorkers = uninterruptibleMask_ . mapM_ killThread }+++    -- Spawn the workers, making sure to kill them later. Collect the results+    -- of each compile.+    results <- liftIO $ bracket spawnWorkers killWorkers $ \_ ->+        -- Loop over each module in the compilation graph in order, printing+        -- each message from its log_queue.+        forM comp_graph $ \(mod,mvar,log_queue) -> do+            printLogs dflags log_queue+            result <- readMVar mvar+            if succeeded result then return (Just mod) else return Nothing+++    -- Collect and return the ModSummaries of all the successful compiles.+    -- NB: Reverse this list to maintain output parity with the sequential upsweep.+    let ok_results = reverse (catMaybes results)++    -- Handle any cycle in the original compilation graph and return the result+    -- of the upsweep.+    case cycle of+        Just mss -> do+            liftIO $ fatalErrorMsg dflags (cyclicModuleErr mss)+            return (Failed,ok_results)+        Nothing  -> do+            let success_flag = successIf (all isJust results)+            return (success_flag,ok_results)++  where+    writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,PprStyle,MsgDoc) -> IO ()+    writeLogQueue (LogQueue ref sem) msg = do+        atomicModifyIORef' ref $ \msgs -> (msg:msgs,())+        _ <- tryPutMVar sem ()+        return ()++    -- The log_action callback that is used to synchronize messages from a+    -- worker thread.+    parLogAction :: LogQueue -> LogAction+    parLogAction log_queue _dflags !reason !severity !srcSpan !style !msg = do+        writeLogQueue log_queue (Just (reason,severity,srcSpan,style,msg))++    -- Print each message from the log_queue using the log_action from the+    -- session's DynFlags.+    printLogs :: DynFlags -> LogQueue -> IO ()+    printLogs !dflags (LogQueue ref sem) = read_msgs+      where read_msgs = do+                takeMVar sem+                msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs)+                print_loop msgs++            print_loop [] = read_msgs+            print_loop (x:xs) = case x of+                Just (reason,severity,srcSpan,style,msg) -> do+                    putLogMsg dflags reason severity srcSpan style msg+                    print_loop xs+                -- Exit the loop once we encounter the end marker.+                Nothing -> return ()++-- The interruptible subset of the worker threads' work.+parUpsweep_one+    :: ModSummary+    -- ^ The module we wish to compile+    -> Map BuildModule (MVar SuccessFlag, Int)+    -- ^ The map of home modules and their result MVar+    -> [[BuildModule]]+    -- ^ The list of all module loops within the compilation graph.+    -> DynFlags+    -- ^ The thread-local DynFlags+    -> Maybe Messager+    -- ^ The messager+    -> (HscEnv -> IO ())+    -- ^ The callback for cleaning up intermediate files+    -> QSem+    -- ^ The semaphore for limiting the number of simultaneous compiles+    -> MVar HscEnv+    -- ^ The MVar that synchronizes updates to the global HscEnv+    -> IORef HomePackageTable+    -- ^ The old HPT+    -> ([ModuleName],[ModuleName])+    -- ^ Lists of stable objects and BCOs+    -> Int+    -- ^ The index of this module+    -> Int+    -- ^ The total number of modules+    -> IO SuccessFlag+    -- ^ The result of this compile+parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup par_sem+               hsc_env_var old_hpt_var stable_mods mod_index num_mods = do++    let this_build_mod = mkBuildModule mod++    let home_imps     = map unLoc $ ms_home_imps mod+    let home_src_imps = map unLoc $ ms_home_srcimps mod++    -- All the textual imports of this module.+    let textual_deps = Set.fromList $ mapFst (mkModule (thisPackage lcl_dflags)) $+                            zip home_imps     (repeat NotBoot) +++                            zip home_src_imps (repeat IsBoot)++    -- Dealing with module loops+    -- ~~~~~~~~~~~~~~~~~~~~~~~~~+    --+    -- Not only do we have to deal with explicit textual dependencies, we also+    -- have to deal with implicit dependencies introduced by import cycles that+    -- are broken by an hs-boot file. We have to ensure that:+    --+    -- 1. A module that breaks a loop must depend on all the modules in the+    --    loop (transitively or otherwise). This is normally always fulfilled+    --    by the module's textual dependencies except in degenerate loops,+    --    e.g.:+    --+    --    A.hs imports B.hs-boot+    --    B.hs doesn't import A.hs+    --    C.hs imports A.hs, B.hs+    --+    --    In this scenario, getModLoop will detect the module loop [A,B] but+    --    the loop finisher B doesn't depend on A. So we have to explicitly add+    --    A in as a dependency of B when we are compiling B.+    --+    -- 2. A module that depends on a module in an external loop can't proceed+    --    until the entire loop is re-typechecked.+    --+    -- These two invariants have to be maintained to correctly build a+    -- compilation graph with one or more loops.+++    -- The loop that this module will finish. After this module successfully+    -- compiles, this loop is going to get re-typechecked.+    let finish_loop = listToMaybe+            [ tail loop | loop <- comp_graph_loops+                        , head loop == this_build_mod ]++    -- If this module finishes a loop then it must depend on all the other+    -- modules in that loop because the entire module loop is going to be+    -- re-typechecked once this module gets compiled. These extra dependencies+    -- are this module's "internal" loop dependencies, because this module is+    -- inside the loop in question.+    let int_loop_deps = Set.fromList $+            case finish_loop of+                Nothing   -> []+                Just loop -> filter (/= this_build_mod) loop++    -- If this module depends on a module within a loop then it must wait for+    -- that loop to get re-typechecked, i.e. it must wait on the module that+    -- finishes that loop. These extra dependencies are this module's+    -- "external" loop dependencies, because this module is outside of the+    -- loop(s) in question.+    let ext_loop_deps = Set.fromList+            [ head loop | loop <- comp_graph_loops+                        , any (`Set.member` textual_deps) loop+                        , this_build_mod `notElem` loop ]+++    let all_deps = foldl1 Set.union [textual_deps, int_loop_deps, ext_loop_deps]++    -- All of the module's home-module dependencies.+    let home_deps_with_idx =+            [ home_dep | dep <- Set.toList all_deps+                       , Just home_dep <- [Map.lookup dep home_mod_map] ]++    -- Sort the list of dependencies in reverse-topological order. This way, by+    -- the time we get woken up by the result of an earlier dependency,+    -- subsequent dependencies are more likely to have finished. This step+    -- effectively reduces the number of MVars that each thread blocks on.+    let home_deps = map fst $ sortBy (flip (comparing snd)) home_deps_with_idx++    -- Wait for the all the module's dependencies to finish building.+    deps_ok <- allM (fmap succeeded . readMVar) home_deps++    -- We can't build this module if any of its dependencies failed to build.+    if not deps_ok+      then return Failed+      else do+        -- Any hsc_env at this point is OK to use since we only really require+        -- that the HPT contains the HMIs of our dependencies.+        hsc_env <- readMVar hsc_env_var+        old_hpt <- readIORef old_hpt_var++        let logger err = printBagOfErrors lcl_dflags (srcErrorMessages err)++        -- Limit the number of parallel compiles.+        let withSem sem = bracket_ (waitQSem sem) (signalQSem sem)+        mb_mod_info <- withSem par_sem $+            handleSourceError (\err -> do logger err; return Nothing) $ do+                -- Have the ModSummary and HscEnv point to our local log_action+                -- and filesToClean var.+                let lcl_mod = localize_mod mod+                let lcl_hsc_env = localize_hsc_env hsc_env++                -- Re-typecheck the loop+                -- This is necessary to make sure the knot is tied when+                -- we close a recursive module loop, see bug #12035.+                type_env_var <- liftIO $ newIORef emptyNameEnv+                let lcl_hsc_env' = lcl_hsc_env { hsc_type_env_var =+                                    Just (ms_mod lcl_mod, type_env_var) }+                lcl_hsc_env'' <- case finish_loop of+                    Nothing   -> return lcl_hsc_env'+                    Just loop -> typecheckLoop lcl_dflags lcl_hsc_env' $+                                 map (moduleName . fst) loop++                -- Compile the module.+                mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt stable_mods+                                        lcl_mod mod_index num_mods+                return (Just mod_info)++        case mb_mod_info of+            Nothing -> return Failed+            Just mod_info -> do+                let this_mod = ms_mod_name mod++                -- Prune the old HPT unless this is an hs-boot module.+                unless (isBootSummary mod) $+                    atomicModifyIORef' old_hpt_var $ \old_hpt ->+                        (delFromHpt old_hpt this_mod, ())++                -- Update and fetch the global HscEnv.+                lcl_hsc_env' <- modifyMVar hsc_env_var $ \hsc_env -> do+                    let hsc_env' = hsc_env+                                     { hsc_HPT = addToHpt (hsc_HPT hsc_env)+                                                           this_mod mod_info }+                    -- If this module is a loop finisher, now is the time to+                    -- re-typecheck the loop.+                    hsc_env'' <- case finish_loop of+                        Nothing   -> return hsc_env'+                        Just loop -> typecheckLoop lcl_dflags hsc_env' $+                                     map (moduleName . fst) loop+                    return (hsc_env'', localize_hsc_env hsc_env'')++                -- Clean up any intermediate files.+                cleanup lcl_hsc_env'+                return Succeeded++  where+    localize_mod mod+        = mod { ms_hspp_opts = (ms_hspp_opts mod)+                 { log_action = log_action lcl_dflags+                 , filesToClean = filesToClean lcl_dflags } }++    localize_hsc_env hsc_env+        = hsc_env { hsc_dflags = (hsc_dflags hsc_env)+                     { log_action = log_action lcl_dflags+                     , filesToClean = filesToClean lcl_dflags } }++-- -----------------------------------------------------------------------------+--+-- | The upsweep+--+-- This is where we compile each module in the module graph, in a pass+-- from the bottom to the top of the graph.+--+-- There better had not be any cyclic groups here -- we check for them.+upsweep+    :: GhcMonad m+    => Maybe Messager+    -> HomePackageTable            -- ^ HPT from last time round (pruned)+    -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability)+    -> (HscEnv -> IO ())           -- ^ How to clean up unwanted tmp files+    -> [SCC ModSummary]            -- ^ Mods to do (the worklist)+    -> m (SuccessFlag,+          [ModSummary])+       -- ^ Returns:+       --+       --  1. A flag whether the complete upsweep was successful.+       --  2. The 'HscEnv' in the monad has an updated HPT+       --  3. A list of modules which succeeded loading.++upsweep mHscMessage old_hpt stable_mods cleanup sccs = do+   dflags <- getSessionDynFlags+   (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs)+                           (unitIdsToCheck dflags) done_holes+   return (res, reverse done)+ where+  done_holes = emptyUniqSet++  upsweep' _old_hpt done+     [] _ _ uids_to_check _+   = do hsc_env <- getSession+        liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) uids_to_check+        return (Succeeded, done)++  upsweep' _old_hpt done+     (CyclicSCC ms:_) _ _ _ _+   = do dflags <- getSessionDynFlags+        liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)+        return (Failed, done)++  upsweep' old_hpt done+     (AcyclicSCC mod:mods) mod_index nmods uids_to_check done_holes+   = do -- putStrLn ("UPSWEEP_MOD: hpt = " +++        --           show (map (moduleUserString.moduleName.mi_module.hm_iface)+        --                     (moduleEnvElts (hsc_HPT hsc_env)))+        let logger _mod = defaultWarnErrLogger++        hsc_env <- getSession++        -- TODO: Cache this, so that we don't repeatedly re-check+        -- our imports when you run --make.+        let (ready_uids, uids_to_check')+                = partition (\uid -> isEmptyUniqDSet+                    (unitIdFreeHoles uid `uniqDSetMinusUniqSet` done_holes))+                     uids_to_check+            done_holes'+                | ms_hsc_src mod == HsigFile+                = addOneToUniqSet done_holes (ms_mod_name mod)+                | otherwise = done_holes+        liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) ready_uids++        -- Remove unwanted tmp files between compilations+        liftIO (cleanup hsc_env)++        -- Get ready to tie the knot+        type_env_var <- liftIO $ newIORef emptyNameEnv+        let hsc_env1 = hsc_env { hsc_type_env_var =+                                    Just (ms_mod mod, type_env_var) }+        setSession hsc_env1++        -- Lazily reload the HPT modules participating in the loop.+        -- See Note [Tying the knot]--if we don't throw out the old HPT+        -- and reinitalize the knot-tying process, anything that was forced+        -- while we were previously typechecking won't get updated, this+        -- was bug #12035.+        hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done+        setSession hsc_env2++        mb_mod_info+            <- handleSourceError+                   (\err -> do logger mod (Just err); return Nothing) $ do+                 mod_info <- liftIO $ upsweep_mod hsc_env2 mHscMessage old_hpt stable_mods+                                                  mod mod_index nmods+                 logger mod Nothing -- log warnings+                 return (Just mod_info)++        case mb_mod_info of+          Nothing -> return (Failed, done)+          Just mod_info -> do+                let this_mod = ms_mod_name mod++                        -- Add new info to hsc_env+                    hpt1     = addToHpt (hsc_HPT hsc_env2) this_mod mod_info+                    hsc_env3 = hsc_env2 { hsc_HPT = hpt1, hsc_type_env_var = Nothing }++                        -- Space-saving: delete the old HPT entry+                        -- for mod BUT if mod is a hs-boot+                        -- node, don't delete it.  For the+                        -- interface, the HPT entry is probaby for the+                        -- main Haskell source file.  Deleting it+                        -- would force the real module to be recompiled+                        -- every time.+                    old_hpt1 | isBootSummary mod = old_hpt+                             | otherwise = delFromHpt old_hpt this_mod++                    done' = mod:done++                        -- fixup our HomePackageTable after we've finished compiling+                        -- a mutually-recursive loop.  We have to do this again+                        -- to make sure we have the final unfoldings, which may+                        -- not have been computed accurately in the previous+                        -- retypecheck.+                hsc_env4 <- liftIO $ reTypecheckLoop hsc_env3 mod done'+                setSession hsc_env4++                        -- Add any necessary entries to the static pointer+                        -- table. See Note [Grand plan for static forms] in+                        -- StaticPtrTable.+                when (hscTarget (hsc_dflags hsc_env4) == HscInterpreted) $+                    liftIO $ hscAddSptEntries hsc_env4+                                 [ spt+                                 | Just linkable <- pure $ hm_linkable mod_info+                                 , unlinked <- linkableUnlinked linkable+                                 , BCOs _ spts <- pure unlinked+                                 , spt <- spts+                                 ]++                upsweep' old_hpt1 done' mods (mod_index+1) nmods uids_to_check' done_holes'++unitIdsToCheck :: DynFlags -> [UnitId]+unitIdsToCheck dflags =+  nubSort $ concatMap goUnitId (explicitPackages (pkgState dflags))+ where+  goUnitId uid =+    case splitUnitIdInsts uid of+      (_, Just indef) ->+        let insts = indefUnitIdInsts indef+        in uid : concatMap (goUnitId . moduleUnitId . snd) insts+      _ -> []++maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime)+maybeGetIfaceDate dflags location+ | writeInterfaceOnlyMode dflags+    -- Minor optimization: it should be harmless to check the hi file location+    -- always, but it's better to avoid hitting the filesystem if possible.+    = modificationTimeIfExists (ml_hi_file location)+ | otherwise+    = return Nothing++-- | Compile a single module.  Always produce a Linkable for it if+-- successful.  If no compilation happened, return the old Linkable.+upsweep_mod :: HscEnv+            -> Maybe Messager+            -> HomePackageTable+            -> ([ModuleName],[ModuleName])+            -> ModSummary+            -> Int  -- index of module+            -> Int  -- total number of modules+            -> IO HomeModInfo+upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_index nmods+   =    let+            this_mod_name = ms_mod_name summary+            this_mod    = ms_mod summary+            mb_obj_date = ms_obj_date summary+            mb_if_date  = ms_iface_date summary+            obj_fn      = ml_obj_file (ms_location summary)+            hs_date     = ms_hs_date summary++            is_stable_obj = this_mod_name `elem` stable_obj+            is_stable_bco = this_mod_name `elem` stable_bco++            old_hmi = lookupHpt old_hpt this_mod_name++            -- We're using the dflags for this module now, obtained by+            -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.+            dflags = ms_hspp_opts summary+            prevailing_target = hscTarget (hsc_dflags hsc_env)+            local_target      = hscTarget dflags++            -- If OPTIONS_GHC contains -fasm or -fllvm, be careful that+            -- we don't do anything dodgy: these should only work to change+            -- from -fllvm to -fasm and vice-versa, otherwise we could+            -- end up trying to link object code to byte code.+            target = if prevailing_target /= local_target+                        && (not (isObjectTarget prevailing_target)+                            || not (isObjectTarget local_target))+                        then prevailing_target+                        else local_target++            -- store the corrected hscTarget into the summary+            summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } }++            -- The old interface is ok if+            --  a) we're compiling a source file, and the old HPT+            --     entry is for a source file+            --  b) we're compiling a hs-boot file+            -- Case (b) allows an hs-boot file to get the interface of its+            -- real source file on the second iteration of the compilation+            -- manager, but that does no harm.  Otherwise the hs-boot file+            -- will always be recompiled++            mb_old_iface+                = case old_hmi of+                     Nothing                              -> Nothing+                     Just hm_info | isBootSummary summary -> Just iface+                                  | not (mi_boot iface)   -> Just iface+                                  | otherwise             -> Nothing+                                   where+                                     iface = hm_iface hm_info++            compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo+            compile_it  mb_linkable src_modified =+                  compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods+                             mb_old_iface mb_linkable src_modified++            compile_it_discard_iface :: Maybe Linkable -> SourceModified+                                     -> IO HomeModInfo+            compile_it_discard_iface mb_linkable  src_modified =+                  compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods+                             Nothing mb_linkable src_modified++            -- With the HscNothing target we create empty linkables to avoid+            -- recompilation.  We have to detect these to recompile anyway if+            -- the target changed since the last compile.+            is_fake_linkable+               | Just hmi <- old_hmi, Just l <- hm_linkable hmi =+                  null (linkableUnlinked l)+               | otherwise =+                   -- we have no linkable, so it cannot be fake+                   False++            implies False _ = True+            implies True x  = x++        in+        case () of+         _+                -- Regardless of whether we're generating object code or+                -- byte code, we can always use an existing object file+                -- if it is *stable* (see checkStability).+          | is_stable_obj, Just hmi <- old_hmi -> do+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5+                           (text "skipping stable obj mod:" <+> ppr this_mod_name)+                return hmi+                -- object is stable, and we have an entry in the+                -- old HPT: nothing to do++          | is_stable_obj, isNothing old_hmi -> do+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5+                           (text "compiling stable on-disk mod:" <+> ppr this_mod_name)+                linkable <- liftIO $ findObjectLinkable this_mod obj_fn+                              (expectJust "upsweep1" mb_obj_date)+                compile_it (Just linkable) SourceUnmodifiedAndStable+                -- object is stable, but we need to load the interface+                -- off disk to make a HMI.++          | not (isObjectTarget target), is_stable_bco,+            (target /= HscNothing) `implies` not is_fake_linkable ->+                ASSERT(isJust old_hmi) -- must be in the old_hpt+                let Just hmi = old_hmi in do+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5+                           (text "skipping stable BCO mod:" <+> ppr this_mod_name)+                return hmi+                -- BCO is stable: nothing to do++          | not (isObjectTarget target),+            Just hmi <- old_hmi,+            Just l <- hm_linkable hmi,+            not (isObjectLinkable l),+            (target /= HscNothing) `implies` not is_fake_linkable,+            linkableTime l >= ms_hs_date summary -> do+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5+                           (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)+                compile_it (Just l) SourceUnmodified+                -- we have an old BCO that is up to date with respect+                -- to the source: do a recompilation check as normal.++          -- When generating object code, if there's an up-to-date+          -- object file on the disk, then we can use it.+          -- However, if the object file is new (compared to any+          -- linkable we had from a previous compilation), then we+          -- must discard any in-memory interface, because this+          -- means the user has compiled the source file+          -- separately and generated a new interface, that we must+          -- read from the disk.+          --+          | isObjectTarget target,+            Just obj_date <- mb_obj_date,+            obj_date >= hs_date -> do+                case old_hmi of+                  Just hmi+                    | Just l <- hm_linkable hmi,+                      isObjectLinkable l && linkableTime l == obj_date -> do+                          liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5+                                     (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)+                          compile_it (Just l) SourceUnmodified+                  _otherwise -> do+                          liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5+                                     (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)+                          linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date+                          compile_it_discard_iface (Just linkable) SourceUnmodified++          -- See Note [Recompilation checking when typechecking only]+          | writeInterfaceOnlyMode dflags,+            Just if_date <- mb_if_date,+            if_date >= hs_date -> do+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5+                           (text "skipping tc'd mod:" <+> ppr this_mod_name)+                compile_it Nothing SourceUnmodified++         _otherwise -> do+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5+                           (text "compiling mod:" <+> ppr this_mod_name)+                compile_it Nothing SourceModified++-- Note [Recompilation checking when typechecking only]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- If we are compiling with -fno-code -fwrite-interface, there won't+-- be any object code that we can compare against, nor should there+-- be: we're *just* generating interface files.  In this case, we+-- want to check if the interface file is new, in lieu of the object+-- file.  See also Trac #9243.+++-- Filter modules in the HPT+retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable+retainInTopLevelEnvs keep_these hpt+   = listToHpt   [ (mod, expectJust "retain" mb_mod_info)+                 | mod <- keep_these+                 , let mb_mod_info = lookupHpt hpt mod+                 , isJust mb_mod_info ]++-- ---------------------------------------------------------------------------+-- Typecheck module loops+{-+See bug #930.  This code fixes a long-standing bug in --make.  The+problem is that when compiling the modules *inside* a loop, a data+type that is only defined at the top of the loop looks opaque; but+after the loop is done, the structure of the data type becomes+apparent.++The difficulty is then that two different bits of code have+different notions of what the data type looks like.++The idea is that after we compile a module which also has an .hs-boot+file, we re-generate the ModDetails for each of the modules that+depends on the .hs-boot file, so that everyone points to the proper+TyCons, Ids etc. defined by the real module, not the boot module.+Fortunately re-generating a ModDetails from a ModIface is easy: the+function TcIface.typecheckIface does exactly that.++Picking the modules to re-typecheck is slightly tricky.  Starting from+the module graph consisting of the modules that have already been+compiled, we reverse the edges (so they point from the imported module+to the importing module), and depth-first-search from the .hs-boot+node.  This gives us all the modules that depend transitively on the+.hs-boot module, and those are exactly the modules that we need to+re-typecheck.++Following this fix, GHC can compile itself with --make -O2.+-}++reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv+reTypecheckLoop hsc_env ms graph+  | Just loop <- getModLoop ms graph+  -- SOME hs-boot files should still+  -- get used, just not the loop-closer.+  , let non_boot = filter (\l -> not (isBootSummary l &&+                                 ms_mod l == ms_mod ms)) loop+  = typecheckLoop (hsc_dflags hsc_env) hsc_env (map ms_mod_name non_boot)+  | otherwise+  = return hsc_env++getModLoop :: ModSummary -> ModuleGraph -> Maybe [ModSummary]+getModLoop ms graph+  | not (isBootSummary ms)+  , any (\m -> ms_mod m == this_mod && isBootSummary m) graph+  , let mss = reachableBackwards (ms_mod_name ms) graph+  = Just mss+  | otherwise+  = Nothing+ where+  this_mod = ms_mod ms++typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv+typecheckLoop dflags hsc_env mods = do+  debugTraceMsg dflags 2 $+     text "Re-typechecking loop: " <> ppr mods+  new_hpt <-+    fixIO $ \new_hpt -> do+      let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }+      mds <- initIfaceCheck (text "typecheckLoop") new_hsc_env $+                mapM (typecheckIface . hm_iface) hmis+      let new_hpt = addListToHpt old_hpt+                        (zip mods [ hmi{ hm_details = details }+                                  | (hmi,details) <- zip hmis mds ])+      return new_hpt+  return hsc_env{ hsc_HPT = new_hpt }+  where+    old_hpt = hsc_HPT hsc_env+    hmis    = map (expectJust "typecheckLoop" . lookupHpt old_hpt) mods++reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]+reachableBackwards mod summaries+  = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ]+  where -- the rest just sets up the graph:+        (graph, lookup_node) = moduleGraphNodes False summaries+        root  = expectJust "reachableBackwards" (lookup_node HsBootFile mod)++-- ---------------------------------------------------------------------------+--+-- | Topological sort of the module graph+topSortModuleGraph+          :: Bool+          -- ^ Drop hi-boot nodes? (see below)+          -> [ModSummary]+          -> Maybe ModuleName+             -- ^ Root module name.  If @Nothing@, use the full graph.+          -> [SCC ModSummary]+-- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes+-- The resulting list of strongly-connected-components is in topologically+-- sorted order, starting with the module(s) at the bottom of the+-- dependency graph (ie compile them first) and ending with the ones at+-- the top.+--+-- Drop hi-boot nodes (first boolean arg)?+--+-- - @False@:   treat the hi-boot summaries as nodes of the graph,+--              so the graph must be acyclic+--+-- - @True@:    eliminate the hi-boot nodes, and instead pretend+--              the a source-import of Foo is an import of Foo+--              The resulting graph has no hi-boot nodes, but can be cyclic++topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod+  = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph+  where+    -- stronglyConnCompG flips the original order, so if we reverse+    -- the summaries we get a stable topological sort.+    (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes (reverse summaries)++    initial_graph = case mb_root_mod of+        Nothing -> graph+        Just root_mod ->+            -- restrict the graph to just those modules reachable from+            -- the specified module.  We do this by building a graph with+            -- the full set of nodes, and determining the reachable set from+            -- the specified node.+            let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node+                     | otherwise = throwGhcException (ProgramError "module does not exist")+            in graphFromEdgedVerticesUniq (seq root (reachableG graph root))++type SummaryNode = (ModSummary, Int, [Int])++summaryNodeKey :: SummaryNode -> Int+summaryNodeKey (_, k, _) = k++summaryNodeSummary :: SummaryNode -> ModSummary+summaryNodeSummary (s, _, _) = s++moduleGraphNodes :: Bool -> [ModSummary]+  -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)+moduleGraphNodes drop_hs_boot_nodes summaries =+  (graphFromEdgedVerticesUniq nodes, lookup_node)+  where+    numbered_summaries = zip summaries [1..]++    lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode+    lookup_node hs_src mod = Map.lookup (mod, hscSourceToIsBoot hs_src) node_map++    lookup_key :: HscSource -> ModuleName -> Maybe Int+    lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)++    node_map :: NodeMap SummaryNode+    node_map = Map.fromList [ ((moduleName (ms_mod s),+                                hscSourceToIsBoot (ms_hsc_src s)), node)+                            | node@(s, _, _) <- nodes ]++    -- We use integers as the keys for the SCC algorithm+    nodes :: [SummaryNode]+    nodes = [ (s, key, out_keys)+            | (s, key) <- numbered_summaries+             -- Drop the hi-boot ones if told to do so+            , not (isBootSummary s && drop_hs_boot_nodes)+            , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) +++                             out_edge_keys HsSrcFile   (map unLoc (ms_home_imps s)) +++                             (-- see [boot-edges] below+                              if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile+                              then []+                              else case lookup_key HsBootFile (ms_mod_name s) of+                                    Nothing -> []+                                    Just k  -> [k]) ]++    -- [boot-edges] if this is a .hs and there is an equivalent+    -- .hs-boot, add a link from the former to the latter.  This+    -- has the effect of detecting bogus cases where the .hs-boot+    -- depends on the .hs, by introducing a cycle.  Additionally,+    -- it ensures that we will always process the .hs-boot before+    -- the .hs, and so the HomePackageTable will always have the+    -- most up to date information.++    -- Drop hs-boot nodes by using HsSrcFile as the key+    hs_boot_key | drop_hs_boot_nodes = HsSrcFile+                | otherwise          = HsBootFile++    out_edge_keys :: HscSource -> [ModuleName] -> [Int]+    out_edge_keys hi_boot ms = mapMaybe (lookup_key hi_boot) ms+        -- If we want keep_hi_boot_nodes, then we do lookup_key with+        -- IsBoot; else NotBoot++-- The nodes of the graph are keyed by (mod, is boot?) pairs+-- NB: hsig files show up as *normal* nodes (not boot!), since they don't+-- participate in cycles (for now)+type NodeKey   = (ModuleName, IsBoot)+type NodeMap a = Map.Map NodeKey a++msKey :: ModSummary -> NodeKey+msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot })+    = (moduleName mod, hscSourceToIsBoot boot)++mkNodeMap :: [ModSummary] -> NodeMap ModSummary+mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries]++nodeMapElts :: NodeMap a -> [a]+nodeMapElts = Map.elems++-- | If there are {-# SOURCE #-} imports between strongly connected+-- components in the topological sort, then those imports can+-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE+-- were necessary, then the edge would be part of a cycle.+warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()+warnUnnecessarySourceImports sccs = do+  dflags <- getDynFlags+  when (wopt Opt_WarnUnusedImports dflags)+    (logWarnings (listToBag (concatMap (check dflags . flattenSCC) sccs)))+  where check dflags ms =+           let mods_in_this_cycle = map ms_mod_name ms in+           [ warn dflags i | m <- ms, i <- ms_home_srcimps m,+                             unLoc i `notElem`  mods_in_this_cycle ]++        warn :: DynFlags -> Located ModuleName -> WarnMsg+        warn dflags (L loc mod) =+           mkPlainErrMsg dflags loc+                (text "Warning: {-# SOURCE #-} unnecessary in import of "+                 <+> quotes (ppr mod))+++reportImportErrors :: MonadIO m => [Either ErrMsg b] -> m [b]+reportImportErrors xs | null errs = return oks+                      | otherwise = throwManyErrors errs+  where (errs, oks) = partitionEithers xs++throwManyErrors :: MonadIO m => [ErrMsg] -> m ab+throwManyErrors errs = liftIO $ throwIO $ mkSrcErr $ listToBag errs+++-----------------------------------------------------------------------------+--+-- | Downsweep (dependency analysis)+--+-- Chase downwards from the specified root set, returning summaries+-- for all home modules encountered.  Only follow source-import+-- links.+--+-- We pass in the previous collection of summaries, which is used as a+-- cache to avoid recalculating a module summary if the source is+-- unchanged.+--+-- The returned list of [ModSummary] nodes has one node for each home-package+-- module, plus one for any hs-boot files.  The imports of these nodes+-- are all there, including the imports of non-home-package modules.+downsweep :: HscEnv+          -> [ModSummary]       -- Old summaries+          -> [ModuleName]       -- Ignore dependencies on these; treat+                                -- them as if they were package modules+          -> Bool               -- True <=> allow multiple targets to have+                                --          the same module name; this is+                                --          very useful for ghc -M+          -> IO [Either ErrMsg ModSummary]+                -- The elts of [ModSummary] all have distinct+                -- (Modules, IsBoot) identifiers, unless the Bool is true+                -- in which case there can be repeats+downsweep hsc_env old_summaries excl_mods allow_dup_roots+   = do+       rootSummaries <- mapM getRootSummary roots+       rootSummariesOk <- reportImportErrors rootSummaries+       let root_map = mkRootMap rootSummariesOk+       checkDuplicates root_map+       summs <- loop (concatMap calcDeps rootSummariesOk) root_map+       return summs+     where+        calcDeps = msDeps++        dflags = hsc_dflags hsc_env+        roots = hsc_targets hsc_env++        old_summary_map :: NodeMap ModSummary+        old_summary_map = mkNodeMap old_summaries++        getRootSummary :: Target -> IO (Either ErrMsg ModSummary)+        getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)+           = do exists <- liftIO $ doesFileExist file+                if exists+                    then Right `fmap` summariseFile hsc_env old_summaries file mb_phase+                                       obj_allowed maybe_buf+                    else return $ Left $ mkPlainErrMsg dflags noSrcSpan $+                           text "can't find file:" <+> text file+        getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)+           = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot+                                           (L rootLoc modl) obj_allowed+                                           maybe_buf excl_mods+                case maybe_summary of+                   Nothing -> return $ Left $ moduleNotFoundErr dflags modl+                   Just s  -> return s++        rootLoc = mkGeneralSrcSpan (fsLit "<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 :: NodeMap [Either ErrMsg ModSummary] -> IO ()+        checkDuplicates root_map+           | allow_dup_roots = return ()+           | null dup_roots  = return ()+           | otherwise       = liftIO $ multiRootsErr dflags (head dup_roots)+           where+             dup_roots :: [[ModSummary]]        -- Each at least of length 2+             dup_roots = filterOut isSingleton $ map rights $ nodeMapElts root_map++        loop :: [(Located ModuleName,IsBoot)]+                        -- Work list: process these modules+             -> NodeMap [Either ErrMsg ModSummary]+                        -- Visited set; the range is a list because+                        -- the roots can have the same module names+                        -- if allow_dup_roots is True+             -> IO [Either ErrMsg ModSummary]+                        -- The result includes the worklist, except+                        -- for those mentioned in the visited set+        loop [] done      = return (concat (nodeMapElts done))+        loop ((wanted_mod, is_boot) : ss) done+          | Just summs <- Map.lookup key done+          = if isSingleton summs then+                loop ss done+            else+                do { multiRootsErr dflags (rights summs); return [] }+          | otherwise+          = do mb_s <- summariseModule hsc_env old_summary_map+                                       is_boot wanted_mod True+                                       Nothing excl_mods+               case mb_s of+                   Nothing -> loop ss done+                   Just (Left e) -> loop ss (Map.insert key [Left e] done)+                   Just (Right s)-> loop (calcDeps s ++ ss)+                                         (Map.insert key [Right s] done)+          where+            key = (unLoc wanted_mod, is_boot)++mkRootMap :: [ModSummary] -> NodeMap [Either ErrMsg ModSummary]+mkRootMap summaries = Map.insertListWith (flip (++))+                                         [ (msKey s, [Right s]) | s <- summaries ]+                                         Map.empty++-- | Returns the dependencies of the ModSummary s.+-- A wrinkle is that for a {-# SOURCE #-} import we return+--      *both* the hs-boot file+--      *and* the source file+-- as "dependencies".  That ensures that the list of all relevant+-- modules always contains B.hs if it contains B.hs-boot.+-- Remember, this pass isn't doing the topological sort.  It's+-- just gathering the list of all relevant ModSummaries+msDeps :: ModSummary -> [(Located ModuleName, IsBoot)]+msDeps s =+    concat [ [(m,IsBoot), (m,NotBoot)] | m <- ms_home_srcimps s ]+        ++ [ (m,NotBoot) | m <- ms_home_imps s ]++home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]+home_imps imps = [ lmodname |  (mb_pkg, lmodname) <- imps,+                                  isLocal mb_pkg ]+  where isLocal Nothing = True+        isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special+        isLocal _ = False++ms_home_allimps :: ModSummary -> [ModuleName]+ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)++-- | Like 'ms_home_imps', but for SOURCE imports.+ms_home_srcimps :: ModSummary -> [Located ModuleName]+ms_home_srcimps = home_imps . ms_srcimps++-- | All of the (possibly) home module imports from a+-- 'ModSummary'; that is to say, each of these module names+-- could be a home import if an appropriately named file+-- existed.  (This is in contrast to package qualified+-- imports, which are guaranteed not to be home imports.)+ms_home_imps :: ModSummary -> [Located ModuleName]+ms_home_imps = home_imps . ms_imps++-----------------------------------------------------------------------------+-- Summarising modules++-- We have two types of summarisation:+--+--    * Summarise a file.  This is used for the root module(s) passed to+--      cmLoadModules.  The file is read, and used to determine the root+--      module name.  The module name may differ from the filename.+--+--    * Summarise a module.  We are given a module name, and must provide+--      a summary.  The finder is used to locate the file in which the module+--      resides.++summariseFile+        :: HscEnv+        -> [ModSummary]                 -- old summaries+        -> FilePath                     -- source file name+        -> Maybe Phase                  -- start phase+        -> Bool                         -- object code allowed?+        -> Maybe (StringBuffer,UTCTime)+        -> IO ModSummary++summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf+        -- we can use a cached summary if one is available and the+        -- source file hasn't changed,  But we have to look up the summary+        -- by source file, rather than module name as we do in summarise.+   | Just old_summary <- findSummaryBySourceFile old_summaries file+   = do+        let location = ms_location old_summary+            dflags = hsc_dflags hsc_env++        src_timestamp <- get_src_timestamp+                -- The file exists; we checked in getRootSummary above.+                -- If it gets removed subsequently, then this+                -- getModificationUTCTime may fail, but that's the right+                -- behaviour.++                -- return the cached summary if the source didn't change+        if ms_hs_date old_summary == src_timestamp &&+           not (gopt Opt_ForceRecomp (hsc_dflags hsc_env))+           then do -- update the object-file timestamp+                  obj_timestamp <-+                    if isObjectTarget (hscTarget (hsc_dflags hsc_env))+                        || obj_allowed -- bug #1205+                        then liftIO $ getObjTimestamp location NotBoot+                        else return Nothing+                  hi_timestamp <- maybeGetIfaceDate dflags location+                  return old_summary{ ms_obj_date = obj_timestamp+                                    , ms_iface_date = hi_timestamp }+           else+                new_summary src_timestamp++   | otherwise+   = do src_timestamp <- get_src_timestamp+        new_summary src_timestamp+  where+    get_src_timestamp = case maybe_buf of+                           Just (_,t) -> return t+                           Nothing    -> liftIO $ getModificationUTCTime file+                        -- getModificationUTCTime may fail++    new_summary src_timestamp = do+        let dflags = hsc_dflags hsc_env++        let hsc_src = if isHaskellSigFilename file then HsigFile else HsSrcFile++        (dflags', hspp_fn, buf)+            <- preprocessFile hsc_env file mb_phase maybe_buf++        (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file++        -- Make a ModLocation for this file+        location <- liftIO $ mkHomeModLocation dflags mod_name file++        -- Tell the Finder cache where it is, so that subsequent calls+        -- to findModule will find it, even if it's not on any search path+        mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location++        -- when the user asks to load a source file by name, we only+        -- use an object file if -fobject-code is on.  See #1205.+        obj_timestamp <-+            if isObjectTarget (hscTarget (hsc_dflags hsc_env))+               || obj_allowed -- bug #1205+                then liftIO $ modificationTimeIfExists (ml_obj_file location)+                else return Nothing++        hi_timestamp <- maybeGetIfaceDate dflags location++        extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name+        required_by_imports <- implicitRequirements hsc_env the_imps++        return (ModSummary { ms_mod = mod,+                             ms_hsc_src = hsc_src,+                             ms_location = location,+                             ms_hspp_file = hspp_fn,+                             ms_hspp_opts = dflags',+                             ms_hspp_buf  = Just buf,+                             ms_parsed_mod = Nothing,+                             ms_srcimps = srcimps,+                             ms_textual_imps = the_imps ++ extra_sig_imports ++ required_by_imports,+                             ms_hs_date = src_timestamp,+                             ms_iface_date = hi_timestamp,+                             ms_obj_date = obj_timestamp })++findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary+findSummaryBySourceFile summaries file+  = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],+                                 expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of+        [] -> Nothing+        (x:_) -> Just x++-- Summarise a module, and pick up source and timestamp.+summariseModule+          :: HscEnv+          -> NodeMap ModSummary -- Map of old summaries+          -> IsBoot             -- IsBoot <=> a {-# SOURCE #-} import+          -> Located ModuleName -- Imported module to be summarised+          -> Bool               -- object code allowed?+          -> Maybe (StringBuffer, UTCTime)+          -> [ModuleName]               -- Modules to exclude+          -> IO (Maybe (Either ErrMsg ModSummary))      -- Its new summary++summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)+                obj_allowed maybe_buf excl_mods+  | wanted_mod `elem` excl_mods+  = return Nothing++  | Just old_summary <- Map.lookup (wanted_mod, is_boot) old_summary_map+  = do          -- Find its new timestamp; all the+                -- ModSummaries in the old map have valid ml_hs_files+        let location = ms_location old_summary+            src_fn = expectJust "summariseModule" (ml_hs_file location)++                -- check the modification time on the source file, and+                -- return the cached summary if it hasn't changed.  If the+                -- file has disappeared, we need to call the Finder again.+        case maybe_buf of+           Just (_,t) -> check_timestamp old_summary location src_fn t+           Nothing    -> do+                m <- tryIO (getModificationUTCTime src_fn)+                case m of+                   Right t -> check_timestamp old_summary location src_fn t+                   Left e | isDoesNotExistError e -> find_it+                          | otherwise             -> ioError e++  | otherwise  = find_it+  where+    dflags = hsc_dflags hsc_env++    check_timestamp old_summary location src_fn src_timestamp+        | ms_hs_date old_summary == src_timestamp &&+          not (gopt Opt_ForceRecomp dflags) = do+                -- update the object-file timestamp+                obj_timestamp <-+                    if isObjectTarget (hscTarget (hsc_dflags hsc_env))+                       || obj_allowed -- bug #1205+                       then getObjTimestamp location is_boot+                       else return Nothing+                hi_timestamp <- maybeGetIfaceDate dflags location+                return (Just (Right old_summary{ ms_obj_date = obj_timestamp+                                               , ms_iface_date = hi_timestamp}))+        | otherwise =+                -- source changed: re-summarise.+                new_summary location (ms_mod old_summary) src_fn src_timestamp++    find_it = do+        -- Don't use the Finder's cache this time.  If the module was+        -- previously a package module, it may have now appeared on the+        -- search path, so we want to consider it to be a home module.  If+        -- the module was previously a home module, it may have moved.+        uncacheModule hsc_env wanted_mod+        found <- findImportedModule hsc_env wanted_mod Nothing+        case found of+             Found location mod+                | isJust (ml_hs_file location) ->+                        -- Home package+                         just_found location mod++             _ -> return Nothing+                        -- Not found+                        -- (If it is TRULY not found at all, we'll+                        -- error when we actually try to compile)++    just_found location mod = do+                -- Adjust location to point to the hs-boot source file,+                -- hi file, object file, when is_boot says so+        let location' | IsBoot <- is_boot = addBootSuffixLocn location+                      | otherwise         = location+            src_fn = expectJust "summarise2" (ml_hs_file location')++                -- Check that it exists+                -- It might have been deleted since the Finder last found it+        maybe_t <- modificationTimeIfExists src_fn+        case maybe_t of+          Nothing -> return $ Just $ Left $ noHsFileErr dflags loc src_fn+          Just t  -> new_summary location' mod src_fn t+++    new_summary location mod src_fn src_timestamp+      = do+        -- Preprocess the source file and get its imports+        -- The dflags' contains the OPTIONS pragmas+        (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf+        (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn++        -- NB: Despite the fact that is_boot is a top-level parameter, we+        -- don't actually know coming into this function what the HscSource+        -- of the module in question is.  This is because we may be processing+        -- this module because another module in the graph imported it: in this+        -- case, we know if it's a boot or not because of the {-# SOURCE #-}+        -- annotation, but we don't know if it's a signature or a regular+        -- module until we actually look it up on the filesystem.+        let hsc_src = case is_boot of+                IsBoot -> HsBootFile+                _ | isHaskellSigFilename src_fn -> HsigFile+                  | otherwise -> HsSrcFile++        when (mod_name /= wanted_mod) $+                throwOneError $ mkPlainErrMsg dflags' mod_loc $+                              text "File name does not match module name:"+                              $$ text "Saw:" <+> quotes (ppr mod_name)+                              $$ text "Expected:" <+> quotes (ppr wanted_mod)++        when (hsc_src == HsigFile && isNothing (lookup mod_name (thisUnitIdInsts dflags))) $+            let suggested_instantiated_with =+                    hcat (punctuate comma $+                        [ ppr k <> text "=" <> ppr v+                        | (k,v) <- ((mod_name, mkHoleModule mod_name)+                                : thisUnitIdInsts dflags)+                        ])+            in throwOneError $ mkPlainErrMsg dflags' mod_loc $+                text "Unexpected signature:" <+> quotes (ppr mod_name)+                $$ if gopt Opt_BuildingCabalPackage dflags+                    then parens (text "Try adding" <+> quotes (ppr mod_name)+                            <+> text "to the"+                            <+> quotes (text "signatures")+                            <+> text "field in your Cabal file.")+                    else parens (text "Try passing -instantiated-with=\"" <>+                                 suggested_instantiated_with <> text "\"" $$+                                text "replacing <" <> ppr mod_name <> text "> as necessary.")++                -- Find the object timestamp, and return the summary+        obj_timestamp <-+           if isObjectTarget (hscTarget (hsc_dflags hsc_env))+              || obj_allowed -- bug #1205+              then getObjTimestamp location is_boot+              else return Nothing++        hi_timestamp <- maybeGetIfaceDate dflags location++        extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name+        required_by_imports <- implicitRequirements hsc_env the_imps++        return (Just (Right (ModSummary { ms_mod       = mod,+                              ms_hsc_src   = hsc_src,+                              ms_location  = location,+                              ms_hspp_file = hspp_fn,+                              ms_hspp_opts = dflags',+                              ms_hspp_buf  = Just buf,+                              ms_parsed_mod = Nothing,+                              ms_srcimps      = srcimps,+                              ms_textual_imps = the_imps ++ extra_sig_imports ++ required_by_imports,+                              ms_hs_date   = src_timestamp,+                              ms_iface_date = hi_timestamp,+                              ms_obj_date  = obj_timestamp })))+++getObjTimestamp :: ModLocation -> IsBoot -> IO (Maybe UTCTime)+getObjTimestamp location is_boot+  = if is_boot == IsBoot then return Nothing+                         else modificationTimeIfExists (ml_obj_file location)+++preprocessFile :: HscEnv+               -> FilePath+               -> Maybe Phase -- ^ Starting phase+               -> Maybe (StringBuffer,UTCTime)+               -> IO (DynFlags, FilePath, StringBuffer)+preprocessFile hsc_env src_fn mb_phase Nothing+  = do+        (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)+        buf <- hGetStringBuffer hspp_fn+        return (dflags', hspp_fn, buf)++preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))+  = do+        let dflags = hsc_dflags hsc_env+        let local_opts = getOptions dflags buf src_fn++        (dflags', leftovers, warns)+            <- parseDynamicFilePragma dflags local_opts+        checkProcessArgsResult dflags leftovers+        handleFlagWarnings dflags' warns++        let needs_preprocessing+                | Just (Unlit _) <- mb_phase    = True+                | Nothing <- mb_phase, Unlit _ <- startPhase src_fn  = True+                  -- note: local_opts is only required if there's no Unlit phase+                | xopt LangExt.Cpp dflags'      = True+                | gopt Opt_Pp  dflags'          = True+                | otherwise                     = False++        when needs_preprocessing $+           throwGhcExceptionIO (ProgramError "buffer needs preprocesing; interactive check disabled")++        return (dflags', src_fn, buf)+++-----------------------------------------------------------------------------+--                      Error messages+-----------------------------------------------------------------------------++noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> ErrMsg+-- ToDo: we don't have a proper line number for this error+noModError dflags loc wanted_mod err+  = mkPlainErrMsg dflags loc $ cannotFindModule dflags wanted_mod err++noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrMsg+noHsFileErr dflags loc path+  = mkPlainErrMsg dflags loc $ text "Can't find" <+> text path++moduleNotFoundErr :: DynFlags -> ModuleName -> ErrMsg+moduleNotFoundErr dflags mod+  = mkPlainErrMsg dflags noSrcSpan $+        text "module" <+> quotes (ppr mod) <+> text "cannot be found locally"++multiRootsErr :: DynFlags -> [ModSummary] -> IO ()+multiRootsErr _      [] = panic "multiRootsErr"+multiRootsErr dflags summs@(summ1:_)+  = throwOneError $ mkPlainErrMsg dflags noSrcSpan $+        text "module" <+> quotes (ppr mod) <+>+        text "is defined in multiple files:" <+>+        sep (map text files)+  where+    mod = ms_mod summ1+    files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs++cyclicModuleErr :: [ModSummary] -> SDoc+-- From a strongly connected component we find+-- a single cycle to report+cyclicModuleErr mss+  = ASSERT( not (null mss) )+    case findCycle graph of+       Nothing   -> text "Unexpected non-cycle" <+> ppr mss+       Just path -> vcat [ text "Module imports form a cycle:"+                         , nest 2 (show_path path) ]+  where+    graph :: [Node NodeKey ModSummary]+    graph = [(ms, msKey ms, get_deps ms) | ms <- mss]++    get_deps :: ModSummary -> [NodeKey]+    get_deps ms = ([ (unLoc m, IsBoot)  | m <- ms_home_srcimps ms ] +++                   [ (unLoc m, NotBoot) | m <- ms_home_imps    ms ])++    show_path []         = panic "show_path"+    show_path [m]        = text "module" <+> ppr_ms m+                           <+> text "imports itself"+    show_path (m1:m2:ms) = vcat ( nest 7 (text "module" <+> ppr_ms m1)+                                : nest 6 (text "imports" <+> ppr_ms m2)+                                : go ms )+       where+         go []     = [text "which imports" <+> ppr_ms m1]+         go (m:ms) = (text "which imports" <+> ppr_ms m) : go ms+++    ppr_ms :: ModSummary -> SDoc+    ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>+                (parens (text (msHsFilePath ms)))
+ main/GhcMonad.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE CPP, RankNTypes #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}+-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow, 2010+--+-- The Session type and related functionality+--+-- -----------------------------------------------------------------------------++module GhcMonad (+        -- * 'Ghc' monad stuff+        GhcMonad(..),+        Ghc(..),+        GhcT(..), liftGhcT,+        reflectGhc, reifyGhc,+        getSessionDynFlags,+        liftIO,+        Session(..), withSession, modifySession, withTempSession,++        -- ** Warnings+        logWarnings, printException,+        WarnErrLogger, defaultWarnErrLogger+  ) where++import MonadUtils+import HscTypes+import DynFlags+import Exception+import ErrUtils++import Control.Monad+import Data.IORef++-- -----------------------------------------------------------------------------+-- | A monad that has all the features needed by GHC API calls.+--+-- In short, a GHC monad+--+--   - allows embedding of IO actions,+--+--   - can log warnings,+--+--   - allows handling of (extensible) exceptions, and+--+--   - maintains a current session.+--+-- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad'+-- before any call to the GHC API functions can occur.+--+class (Functor m, MonadIO m, ExceptionMonad m, HasDynFlags m) => GhcMonad m where+  getSession :: m HscEnv+  setSession :: HscEnv -> m ()++-- | Call the argument with the current session.+withSession :: GhcMonad m => (HscEnv -> m a) -> m a+withSession f = getSession >>= f++-- | Grabs the DynFlags from the Session+getSessionDynFlags :: GhcMonad m => m DynFlags+getSessionDynFlags = withSession (return . hsc_dflags)++-- | Set the current session to the result of applying the current session to+-- the argument.+modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m ()+modifySession f = do h <- getSession+                     setSession $! f h++withSavedSession :: GhcMonad m => m a -> m a+withSavedSession m = do+  saved_session <- getSession+  m `gfinally` setSession saved_session++-- | Call an action with a temporarily modified Session.+withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a+withTempSession f m =+  withSavedSession $ modifySession f >> m++-- -----------------------------------------------------------------------------+-- | A monad that allows logging of warnings.++logWarnings :: GhcMonad m => WarningMessages -> m ()+logWarnings warns = do+  dflags <- getSessionDynFlags+  liftIO $ printOrThrowWarnings dflags warns++-- -----------------------------------------------------------------------------+-- | A minimal implementation of a 'GhcMonad'.  If you need a custom monad,+-- e.g., to maintain additional state consider wrapping this monad or using+-- 'GhcT'.+newtype Ghc a = Ghc { unGhc :: Session -> IO a }++-- | The Session is a handle to the complete state of a compilation+-- session.  A compilation session consists of a set of modules+-- constituting the current program or library, the context for+-- interactive evaluation, and various caches.+data Session = Session !(IORef HscEnv)++instance Functor Ghc where+  fmap f m = Ghc $ \s -> f `fmap` unGhc m s++instance Applicative Ghc where+  pure a = Ghc $ \_ -> return a+  g <*> m = do f <- g; a <- m; return (f a)++instance Monad Ghc where+  m >>= g  = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s++instance MonadIO Ghc where+  liftIO ioA = Ghc $ \_ -> ioA++instance MonadFix Ghc where+  mfix f = Ghc $ \s -> mfix (\x -> unGhc (f x) s)++instance ExceptionMonad Ghc where+  gcatch act handle =+      Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s+  gmask f =+      Ghc $ \s -> gmask $ \io_restore ->+                             let+                                g_restore (Ghc m) = Ghc $ \s -> io_restore (m s)+                             in+                                unGhc (f g_restore) s++instance HasDynFlags Ghc where+  getDynFlags = getSessionDynFlags++instance GhcMonad Ghc where+  getSession = Ghc $ \(Session r) -> readIORef r+  setSession s' = Ghc $ \(Session r) -> writeIORef r s'++-- | Reflect a computation in the 'Ghc' monad into the 'IO' monad.+--+-- You can use this to call functions returning an action in the 'Ghc' monad+-- inside an 'IO' action.  This is needed for some (too restrictive) callback+-- arguments of some library functions:+--+-- > libFunc :: String -> (Int -> IO a) -> IO a+-- > ghcFunc :: Int -> Ghc a+-- >+-- > ghcFuncUsingLibFunc :: String -> Ghc a -> Ghc a+-- > ghcFuncUsingLibFunc str =+-- >   reifyGhc $ \s ->+-- >     libFunc $ \i -> do+-- >       reflectGhc (ghcFunc i) s+--+reflectGhc :: Ghc a -> Session -> IO a+reflectGhc m = unGhc m++-- > Dual to 'reflectGhc'.  See its documentation.+reifyGhc :: (Session -> IO a) -> Ghc a+reifyGhc act = Ghc $ act++-- -----------------------------------------------------------------------------+-- | A monad transformer to add GHC specific features to another monad.+--+-- Note that the wrapped monad must support IO and handling of exceptions.+newtype GhcT m a = GhcT { unGhcT :: Session -> m a }++liftGhcT :: m a -> GhcT m a+liftGhcT m = GhcT $ \_ -> m++instance Functor m => Functor (GhcT m) where+  fmap f m = GhcT $ \s -> f `fmap` unGhcT m s++instance Applicative m => Applicative (GhcT m) where+  pure x  = GhcT $ \_ -> pure x+  g <*> m = GhcT $ \s -> unGhcT g s <*> unGhcT m s++instance Monad m => Monad (GhcT m) where+  m >>= k  = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s++instance MonadIO m => MonadIO (GhcT m) where+  liftIO ioA = GhcT $ \_ -> liftIO ioA++instance ExceptionMonad m => ExceptionMonad (GhcT m) where+  gcatch act handle =+      GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s+  gmask f =+      GhcT $ \s -> gmask $ \io_restore ->+                           let+                              g_restore (GhcT m) = GhcT $ \s -> io_restore (m s)+                           in+                              unGhcT (f g_restore) s++instance MonadIO m => HasDynFlags (GhcT m) where+  getDynFlags = GhcT $ \(Session r) -> liftM hsc_dflags (liftIO $ readIORef r)++instance ExceptionMonad m => GhcMonad (GhcT m) where+  getSession = GhcT $ \(Session r) -> liftIO $ readIORef r+  setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s'+++-- | Print the error message and all warnings.  Useful inside exception+--   handlers.  Clears warnings after printing.+printException :: GhcMonad m => SourceError -> m ()+printException err = do+  dflags <- getSessionDynFlags+  liftIO $ printBagOfErrors dflags (srcErrorMessages err)++-- | A function called to log warnings and errors.+type WarnErrLogger = forall m. GhcMonad m => Maybe SourceError -> m ()++defaultWarnErrLogger :: WarnErrLogger+defaultWarnErrLogger Nothing  = return ()+defaultWarnErrLogger (Just e) = printException e+
+ main/GhcPlugins.hs view
@@ -0,0 +1,84 @@+{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}++-- | This module is not used by GHC itself.  Rather, it exports all of+-- the functions and types you are likely to need when writing a+-- plugin for GHC. So authors of plugins can probably get away simply+-- with saying "import GhcPlugins".+--+-- Particularly interesting modules for plugin writers include+-- "CoreSyn" and "CoreMonad".+module GhcPlugins(+        module Plugins,+        module RdrName, module OccName, module Name, module Var, module Id, module IdInfo,+        module CoreMonad, module CoreSyn, module Literal, module DataCon,+        module CoreUtils, module MkCore, module CoreFVs, module CoreSubst,+        module Rules, module Annotations,+        module DynFlags, module Packages,+        module Module, module Type, module TyCon, module Coercion,+        module TysWiredIn, module HscTypes, module BasicTypes,+        module VarSet, module VarEnv, module NameSet, module NameEnv,+        module UniqSet, module UniqFM, module FiniteMap,+        module Util, module GHC.Serialized, module SrcLoc, module Outputable,+        module UniqSupply, module Unique, module FastString+    ) where++-- Plugin stuff itself+import Plugins++-- Variable naming+import RdrName+import OccName  hiding  ( varName {- conflicts with Var.varName -} )+import Name     hiding  ( varName {- reexport from OccName, conflicts with Var.varName -} )+import Var+import Id       hiding  ( lazySetIdInfo, setIdExported, setIdNotExported {- all three conflict with Var -} )+import IdInfo++-- Core+import CoreMonad+import CoreSyn+import Literal+import DataCon+import CoreUtils+import MkCore+import CoreFVs+import CoreSubst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst )+       -- These names are also exported by Type++-- Core "extras"+import Rules+import Annotations++-- Pipeline-related stuff+import DynFlags+import Packages++-- Important GHC types+import Module+import Type     hiding {- conflict with CoreSubst -}+                ( substTy, extendTvSubst, extendTvSubstList, isInScope )+import Coercion hiding {- conflict with CoreSubst -}+                ( substCo )+import TyCon+import TysWiredIn+import HscTypes+import BasicTypes hiding ( Version {- conflicts with Packages.Version -} )++-- Collections and maps+import VarSet+import VarEnv+import NameSet+import NameEnv+import UniqSet+import UniqFM+-- Conflicts with UniqFM:+--import LazyUniqFM+import FiniteMap++-- Common utilities+import Util+import GHC.Serialized+import SrcLoc+import Outputable+import UniqSupply+import Unique           ( Unique, Uniquable(..) )+import FastString
+ main/HeaderInfo.hs view
@@ -0,0 +1,338 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- | Parsing the top of a Haskell source file to get its module name,+-- imports and options.+--+-- (c) Simon Marlow 2005+-- (c) Lemmih 2006+--+-----------------------------------------------------------------------------++module HeaderInfo ( getImports+                  , mkPrelImports -- used by the renamer too+                  , getOptionsFromFile, getOptions+                  , optionsErrorMsgs,+                    checkProcessArgsResult ) where++#include "HsVersions.h"++import RdrName+import HscTypes+import Parser           ( parseHeader )+import Lexer+import FastString+import HsSyn+import Module+import PrelNames+import StringBuffer+import SrcLoc+import DynFlags+import ErrUtils+import Util+import Outputable+import Pretty           ()+import Maybes+import Bag              ( emptyBag, listToBag, unitBag )+import MonadUtils+import Exception+import BasicTypes+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import System.IO+import System.IO.Unsafe+import Data.List++------------------------------------------------------------------------------++-- | Parse the imports of a source file.+--+-- Throws a 'SourceError' if parsing fails.+getImports :: DynFlags+           -> StringBuffer -- ^ Parse this.+           -> FilePath     -- ^ Filename the buffer came from.  Used for+                           --   reporting parse error locations.+           -> FilePath     -- ^ The original source filename (used for locations+                           --   in the function result)+           -> IO ([(Maybe FastString, Located ModuleName)],+                  [(Maybe FastString, Located ModuleName)],+                  Located ModuleName)+              -- ^ The source imports, normal imports, and the module name.+getImports dflags buf filename source_filename = do+  let loc  = mkRealSrcLoc (mkFastString filename) 1 1+  case unP parseHeader (mkPState dflags buf loc) of+    PFailed span err -> parseError dflags span err+    POk pst rdr_module -> do+      let _ms@(_warns, errs) = getMessages pst dflags+      -- don't log warnings: they'll be reported when we parse the file+      -- for real.  See #2500.+          ms = (emptyBag, errs)+      -- logWarnings warns+      if errorsFound dflags ms+        then throwIO $ mkSrcErr errs+        else+          case rdr_module of+            L _ hsmod ->+              let+                mb_mod = hsmodName hsmod+                imps = hsmodImports hsmod+                main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename) 1 1)+                mod = mb_mod `orElse` L main_loc mAIN_NAME+                (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps++                     -- GHC.Prim doesn't exist physically, so don't go looking for it.+                ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)+                                       ord_idecls++                implicit_prelude = xopt LangExt.ImplicitPrelude dflags+                implicit_imports = mkPrelImports (unLoc mod) main_loc+                                                 implicit_prelude imps+                convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i)+              in+              return (map convImport src_idecls,+                      map convImport (implicit_imports ++ ordinary_imps),+                      mod)++mkPrelImports :: ModuleName+              -> SrcSpan    -- Attribute the "import Prelude" to this location+              -> Bool -> [LImportDecl RdrName]+              -> [LImportDecl RdrName]+-- Construct the implicit declaration "import Prelude" (or not)+--+-- NB: opt_NoImplicitPrelude is slightly different to import Prelude ();+-- because the former doesn't even look at Prelude.hi for instance+-- declarations, whereas the latter does.+mkPrelImports this_mod loc implicit_prelude import_decls+  | this_mod == pRELUDE_NAME+   || explicit_prelude_import+   || not implicit_prelude+  = []+  | otherwise = [preludeImportDecl]+  where+      explicit_prelude_import+       = notNull [ () | L _ (ImportDecl { ideclName = mod+                                        , ideclPkgQual = Nothing })+                          <- import_decls+                      , unLoc mod == pRELUDE_NAME ]++      preludeImportDecl :: LImportDecl RdrName+      preludeImportDecl+        = L loc $ ImportDecl { ideclSourceSrc = NoSourceText,+                               ideclName      = L loc pRELUDE_NAME,+                               ideclPkgQual   = Nothing,+                               ideclSource    = False,+                               ideclSafe      = False,  -- Not a safe import+                               ideclQualified = False,+                               ideclImplicit  = True,   -- Implicit!+                               ideclAs        = Nothing,+                               ideclHiding    = Nothing  }++parseError :: DynFlags -> SrcSpan -> MsgDoc -> IO a+parseError dflags span err = throwOneError $ mkPlainErrMsg dflags span err++--------------------------------------------------------------+-- Get options+--------------------------------------------------------------++-- | Parse OPTIONS and LANGUAGE pragmas of the source file.+--+-- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)+getOptionsFromFile :: DynFlags+                   -> FilePath            -- ^ Input file+                   -> IO [Located String] -- ^ Parsed options, if any.+getOptionsFromFile dflags filename+    = Exception.bracket+              (openBinaryFile filename ReadMode)+              (hClose)+              (\handle -> do+                  opts <- fmap (getOptions' dflags)+                               (lazyGetToks dflags' filename handle)+                  seqList opts $ return opts)+    where -- We don't need to get haddock doc tokens when we're just+          -- getting the options from pragmas, and lazily lexing them+          -- correctly is a little tricky: If there is "\n" or "\n-"+          -- left at the end of a buffer then the haddock doc may+          -- continue past the end of the buffer, despite the fact that+          -- we already have an apparently-complete token.+          -- We therefore just turn Opt_Haddock off when doing the lazy+          -- lex.+          dflags' = gopt_unset dflags Opt_Haddock++blockSize :: Int+-- blockSize = 17 -- for testing :-)+blockSize = 1024++lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token]+lazyGetToks dflags filename handle = do+  buf <- hGetStringBufferBlock handle blockSize+  unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False blockSize+ where+  loc  = mkRealSrcLoc (mkFastString filename) 1 1++  lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token]+  lazyLexBuf handle state eof size = do+    case unP (lexer False return) state of+      POk state' t -> do+        -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ())+        if atEnd (buffer state') && not eof+           -- if this token reached the end of the buffer, and we haven't+           -- necessarily read up to the end of the file, then the token might+           -- be truncated, so read some more of the file and lex it again.+           then getMore handle state size+           else case t of+                  L _ ITeof -> return [t]+                  _other    -> do rest <- lazyLexBuf handle state' eof size+                                  return (t : rest)+      _ | not eof   -> getMore handle state size+        | otherwise -> return [L (RealSrcSpan (last_loc state)) ITeof]+                         -- parser assumes an ITeof sentinel at the end++  getMore :: Handle -> PState -> Int -> IO [Located Token]+  getMore handle state size = do+     -- pprTrace "getMore" (text (show (buffer state))) (return ())+     let new_size = size * 2+       -- double the buffer size each time we read a new block.  This+       -- counteracts the quadratic slowdown we otherwise get for very+       -- large module names (#5981)+     nextbuf <- hGetStringBufferBlock handle new_size+     if (len nextbuf == 0) then lazyLexBuf handle state True new_size else do+       newbuf <- appendStringBuffers (buffer state) nextbuf+       unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size+++getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]+getToks dflags filename buf = lexAll (pragState dflags buf loc)+ where+  loc  = mkRealSrcLoc (mkFastString filename) 1 1++  lexAll state = case unP (lexer False return) state of+                   POk _      t@(L _ ITeof) -> [t]+                   POk state' t -> t : lexAll state'+                   _ -> [L (RealSrcSpan (last_loc state)) ITeof]+++-- | Parse OPTIONS and LANGUAGE pragmas of the source file.+--+-- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)+getOptions :: DynFlags+           -> StringBuffer -- ^ Input Buffer+           -> FilePath     -- ^ Source filename.  Used for location info.+           -> [Located String] -- ^ Parsed options.+getOptions dflags buf filename+    = getOptions' dflags (getToks dflags filename buf)++-- The token parser is written manually because Happy can't+-- return a partial result when it encounters a lexer error.+-- We want to extract options before the buffer is passed through+-- CPP, so we can't use the same trick as 'getImports'.+getOptions' :: DynFlags+            -> [Located Token]      -- Input buffer+            -> [Located String]     -- Options.+getOptions' dflags toks+    = parseToks toks+    where+          getToken (L _loc tok) = tok+          getLoc (L loc _tok) = loc++          parseToks (open:close:xs)+              | IToptions_prag str <- getToken open+              , ITclose_prag       <- getToken close+              = case toArgs str of+                  Left err -> panic ("getOptions'.parseToks: " ++ err)+                  Right args -> map (L (getLoc open)) args ++ parseToks xs+          parseToks (open:close:xs)+              | ITinclude_prag str <- getToken open+              , ITclose_prag       <- getToken close+              = map (L (getLoc open)) ["-#include",removeSpaces str] +++                parseToks xs+          parseToks (open:close:xs)+              | ITdocOptions str <- getToken open+              , ITclose_prag     <- getToken close+              = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]+                ++ parseToks xs+          parseToks (open:xs)+              | ITlanguage_prag <- getToken open+              = parseLanguage xs+          parseToks (comment:xs) -- Skip over comments+              | isComment (getToken comment)+              = parseToks xs+          parseToks _ = []+          parseLanguage (L loc (ITconid fs):rest)+              = checkExtension dflags (L loc fs) :+                case rest of+                  (L _loc ITcomma):more -> parseLanguage more+                  (L _loc ITclose_prag):more -> parseToks more+                  (L loc _):_ -> languagePragParseError dflags loc+                  [] -> panic "getOptions'.parseLanguage(1) went past eof token"+          parseLanguage (tok:_)+              = languagePragParseError dflags (getLoc tok)+          parseLanguage []+              = panic "getOptions'.parseLanguage(2) went past eof token"++          isComment :: Token -> Bool+          isComment c =+            case c of+              (ITlineComment {})     -> True+              (ITblockComment {})    -> True+              (ITdocCommentNext {})  -> True+              (ITdocCommentPrev {})  -> True+              (ITdocCommentNamed {}) -> True+              (ITdocSection {})      -> True+              _                      -> False++-----------------------------------------------------------------------------++-- | Complain about non-dynamic flags in OPTIONS pragmas.+--+-- Throws a 'SourceError' if the input list is non-empty claiming that the+-- input flags are unknown.+checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m ()+checkProcessArgsResult dflags flags+  = when (notNull flags) $+      liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags+    where mkMsg (L loc flag)+              = mkPlainErrMsg dflags loc $+                  (text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+>+                   text flag)++-----------------------------------------------------------------------------++checkExtension :: DynFlags -> Located FastString -> Located String+checkExtension dflags (L l ext)+-- Checks if a given extension is valid, and if so returns+-- its corresponding flag. Otherwise it throws an exception.+ =  let ext' = unpackFS ext in+    if ext' `elem` supportedLanguagesAndExtensions+    then L l ("-X"++ext')+    else unsupportedExtnError dflags l ext'++languagePragParseError :: DynFlags -> SrcSpan -> a+languagePragParseError dflags loc =+  throw $ mkSrcErr $ unitBag $+     (mkPlainErrMsg dflags loc $+       vcat [ text "Cannot parse LANGUAGE pragma"+            , text "Expecting comma-separated list of language options,"+            , text "each starting with a capital letter"+            , nest 2 (text "E.g. {-# LANGUAGE TemplateHaskell, GADTs #-}") ])++unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a+unsupportedExtnError dflags loc unsup =+  throw $ mkSrcErr $ unitBag $+    mkPlainErrMsg dflags loc $+        text "Unsupported extension: " <> text unsup $$+        if null suggestions then Outputable.empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)+  where+     suggestions = fuzzyMatch unsup supportedLanguagesAndExtensions+++optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Messages+optionsErrorMsgs dflags unhandled_flags flags_lines _filename+  = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))+  where unhandled_flags_lines = [ L l f | f <- unhandled_flags,+                                          L l f' <- flags_lines, f == f' ]+        mkMsg (L flagSpan flag) =+            ErrUtils.mkPlainErrMsg dflags flagSpan $+                    text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+> text flag+
+ main/Hooks.hs view
@@ -0,0 +1,96 @@+-- \section[Hooks]{Low level API hooks}++-- NB: this module is SOURCE-imported by DynFlags, and should primarily+--     refer to *types*, rather than *code*+-- If you import too muchhere , then the revolting compiler_stage2_dll0_MODULES+-- stuff in compiler/ghc.mk makes DynFlags link to too much stuff++{-# LANGUAGE CPP #-}+module Hooks ( Hooks+             , emptyHooks+             , lookupHook+             , getHooked+               -- the hooks:+             , dsForeignsHook+             , tcForeignImportsHook+             , tcForeignExportsHook+             , hscFrontendHook+             , hscCompileCoreExprHook+             , ghcPrimIfaceHook+             , runPhaseHook+             , runMetaHook+             , linkHook+             , runRnSpliceHook+             , getValueSafelyHook+             , createIservProcessHook+             ) where++import DynFlags+import Name+import PipelineMonad+import HscTypes+import HsDecls+import HsBinds+import HsExpr+import OrdList+import Id+import TcRnTypes+import Bag+import RdrName+import CoreSyn+import GHCi.RemoteTypes+import SrcLoc+import Type+import System.Process+import BasicTypes++import Data.Maybe++{-+************************************************************************+*                                                                      *+\subsection{Hooks}+*                                                                      *+************************************************************************+-}++-- | Hooks can be used by GHC API clients to replace parts of+--   the compiler pipeline. If a hook is not installed, GHC+--   uses the default built-in behaviour++emptyHooks :: Hooks+emptyHooks = Hooks+  { dsForeignsHook         = Nothing+  , tcForeignImportsHook   = Nothing+  , tcForeignExportsHook   = Nothing+  , hscFrontendHook        = Nothing+  , hscCompileCoreExprHook = Nothing+  , ghcPrimIfaceHook       = Nothing+  , runPhaseHook           = Nothing+  , runMetaHook            = Nothing+  , linkHook               = Nothing+  , runRnSpliceHook        = Nothing+  , getValueSafelyHook     = Nothing+  , createIservProcessHook = Nothing+  }++data Hooks = Hooks+  { dsForeignsHook         :: Maybe ([LForeignDecl Id] -> DsM (ForeignStubs, OrdList (Id, CoreExpr)))+  , tcForeignImportsHook   :: Maybe ([LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt))+  , tcForeignExportsHook   :: Maybe ([LForeignDecl Name] -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt))+  , hscFrontendHook        :: Maybe (ModSummary -> Hsc FrontendResult)+  , hscCompileCoreExprHook :: Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue)+  , ghcPrimIfaceHook       :: Maybe ModIface+  , runPhaseHook           :: Maybe (PhasePlus -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath))+  , runMetaHook            :: Maybe (MetaHook TcM)+  , linkHook               :: Maybe (GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag)+  , runRnSpliceHook        :: Maybe (HsSplice Name -> RnM (HsSplice Name))+  , getValueSafelyHook     :: Maybe (HscEnv -> Name -> Type -> IO (Maybe HValue))+  , createIservProcessHook :: Maybe (CreateProcess -> IO ProcessHandle)+  }++getHooked :: (Functor f, HasDynFlags f) => (Hooks -> Maybe a) -> a -> f a+getHooked hook def = fmap (lookupHook hook def) getDynFlags++lookupHook :: (Hooks -> Maybe a) -> a -> DynFlags -> a+lookupHook hook def = fromMaybe def . hook . hooks
+ main/Hooks.hs-boot view
@@ -0,0 +1,5 @@+module Hooks where++data Hooks++emptyHooks :: Hooks
+ main/HscMain.hs view
@@ -0,0 +1,1784 @@+{-# LANGUAGE BangPatterns, CPP, MagicHash, NondecreasingIndentation #-}+{-# OPTIONS_GHC -fprof-auto-top #-}++-------------------------------------------------------------------------------+--+-- | Main API for compiling plain Haskell source code.+--+-- This module implements compilation of a Haskell source. It is+-- /not/ concerned with preprocessing of source files; this is handled+-- in "DriverPipeline".+--+-- There are various entry points depending on what mode we're in:+-- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and+-- "interactive" mode (GHCi). There are also entry points for+-- individual passes: parsing, typechecking/renaming, desugaring, and+-- simplification.+--+-- All the functions here take an 'HscEnv' as a parameter, but none of+-- them return a new one: 'HscEnv' is treated as an immutable value+-- from here on in (although it has mutable components, for the+-- caches).+--+-- We use the Hsc monad to deal with warning messages consistently:+-- specifically, while executing within an Hsc monad, warnings are+-- collected. When a Hsc monad returns to an IO monad, the+-- warnings are printed, or compilation aborts if the @-Werror@+-- flag is enabled.+--+-- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000+--+-------------------------------------------------------------------------------++module HscMain+    (+    -- * Making an HscEnv+      newHscEnv++    -- * Compiling complete source files+    , Messager, batchMsg+    , HscStatus (..)+    , hscIncrementalCompile+    , hscCompileCmmFile++    , hscGenHardCode+    , hscInteractive++    -- * Running passes separately+    , hscParse+    , hscTypecheckRename+    , hscDesugar+    , makeSimpleDetails+    , hscSimplify -- ToDo, shouldn't really export this++    -- * Safe Haskell+    , hscCheckSafe+    , hscGetSafe++    -- * Support for interactive evaluation+    , hscParseIdentifier+    , hscTcRcLookupName+    , hscTcRnGetInfo+    , hscIsGHCiMonad+    , hscGetModuleInterface+    , hscRnImportDecls+    , hscTcRnLookupRdrName+    , hscStmt, hscStmtWithLocation, hscParsedStmt+    , hscDecls, hscDeclsWithLocation+    , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType+    , hscParseExpr+    , hscCompileCoreExpr+    -- * Low-level exports for hooks+    , hscCompileCoreExpr'+      -- We want to make sure that we export enough to be able to redefine+      -- hscFileFrontEnd in client code+    , hscParse', hscSimplify', hscDesugar', tcRnModule'+    , getHscEnv+    , hscSimpleIface', hscNormalIface'+    , oneShotMsg+    , hscFileFrontEnd, genericHscFrontend, dumpIfaceStats+    , ioMsgMaybe+    , showModuleIndex+    , hscAddSptEntries+    ) where++import Data.Data hiding (Fixity, TyCon)+import Id+import GHCi             ( addSptEntry )+import GHCi.RemoteTypes ( ForeignHValue )+import ByteCodeGen      ( byteCodeGen, coreExprToBCOs )+import Linker+import CoreTidy         ( tidyExpr )+import Type             ( Type )+import {- Kind parts of -} Type         ( Kind )+import CoreLint         ( lintInteractiveExpr )+import VarEnv           ( emptyTidyEnv )+import Panic+import ConLike+import Control.Concurrent++import Module+import Packages+import RdrName+import HsSyn+import HsDumpAst+import CoreSyn+import StringBuffer+import Parser+import Lexer+import SrcLoc+import TcRnDriver+import TcIface          ( typecheckIface )+import TcRnMonad+import NameCache        ( initNameCache )+import LoadIface        ( ifaceStats, initExternalPackageState )+import PrelInfo+import MkIface+import Desugar+import SimplCore+import TidyPgm+import CorePrep+import CoreToStg        ( coreToStg )+import qualified StgCmm ( codeGen )+import StgSyn+import CostCentre+import ProfInit+import TyCon+import Name+import SimplStg         ( stg2stg )+import Cmm+import CmmParse         ( parseCmmFile )+import CmmBuildInfoTables+import CmmPipeline+import CmmInfo+import CodeOutput+import InstEnv+import FamInstEnv+import Fingerprint      ( Fingerprint )+import Hooks+import TcEnv++import DynFlags+import ErrUtils+import Platform ( platformOS, osSubsectionsViaSymbols )++import Outputable+import NameEnv+import HscStats         ( ppSourceStats )+import HscTypes+import FastString+import UniqSupply+import Bag+import Exception+import qualified Stream+import Stream (Stream)++import Util++import Data.List+import Control.Monad+import Data.IORef+import System.FilePath as FilePath+import System.Directory+import System.IO (fixIO)+import qualified Data.Map as Map+import qualified Data.Set as S+import Data.Set (Set)++#include "HsVersions.h"+++{- **********************************************************************+%*                                                                      *+                Initialisation+%*                                                                      *+%********************************************************************* -}++newHscEnv :: DynFlags -> IO HscEnv+newHscEnv dflags = do+    eps_var <- newIORef initExternalPackageState+    us      <- mkSplitUniqSupply 'r'+    nc_var  <- newIORef (initNameCache us knownKeyNames)+    fc_var  <- newIORef emptyInstalledModuleEnv+    iserv_mvar <- newMVar Nothing+    return HscEnv {  hsc_dflags       = dflags+                  ,  hsc_targets      = []+                  ,  hsc_mod_graph    = []+                  ,  hsc_IC           = emptyInteractiveContext dflags+                  ,  hsc_HPT          = emptyHomePackageTable+                  ,  hsc_EPS          = eps_var+                  ,  hsc_NC           = nc_var+                  ,  hsc_FC           = fc_var+                  ,  hsc_type_env_var = Nothing+                  , hsc_iserv        = iserv_mvar+                  }++-- -----------------------------------------------------------------------------++getWarnings :: Hsc WarningMessages+getWarnings = Hsc $ \_ w -> return (w, w)++clearWarnings :: Hsc ()+clearWarnings = Hsc $ \_ _ -> return ((), emptyBag)++logWarnings :: WarningMessages -> Hsc ()+logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)++getHscEnv :: Hsc HscEnv+getHscEnv = Hsc $ \e w -> return (e, w)++handleWarnings :: Hsc ()+handleWarnings = do+    dflags <- getDynFlags+    w <- getWarnings+    liftIO $ printOrThrowWarnings dflags w+    clearWarnings++-- | log warning in the monad, and if there are errors then+-- throw a SourceError exception.+logWarningsReportErrors :: Messages -> Hsc ()+logWarningsReportErrors (warns,errs) = do+    logWarnings warns+    when (not $ isEmptyBag errs) $ throwErrors errs++-- | Throw some errors.+throwErrors :: ErrorMessages -> Hsc a+throwErrors = liftIO . throwIO . mkSrcErr++-- | Deal with errors and warnings returned by a compilation step+--+-- In order to reduce dependencies to other parts of the compiler, functions+-- outside the "main" parts of GHC return warnings and errors as a parameter+-- and signal success via by wrapping the result in a 'Maybe' type. This+-- function logs the returned warnings and propagates errors as exceptions+-- (of type 'SourceError').+--+-- This function assumes the following invariants:+--+--  1. If the second result indicates success (is of the form 'Just x'),+--     there must be no error messages in the first result.+--+--  2. If there are no error messages, but the second result indicates failure+--     there should be warnings in the first result. That is, if the action+--     failed, it must have been due to the warnings (i.e., @-Werror@).+ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a+ioMsgMaybe ioA = do+    ((warns,errs), mb_r) <- liftIO ioA+    logWarnings warns+    case mb_r of+        Nothing -> throwErrors errs+        Just r  -> ASSERT( isEmptyBag errs ) return r++-- | like ioMsgMaybe, except that we ignore error messages and return+-- 'Nothing' instead.+ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a)+ioMsgMaybe' ioA = do+    ((warns,_errs), mb_r) <- liftIO $ ioA+    logWarnings warns+    return mb_r++-- -----------------------------------------------------------------------------+-- | Lookup things in the compiler's environment++hscTcRnLookupRdrName :: HscEnv -> Located RdrName -> IO [Name]+hscTcRnLookupRdrName hsc_env0 rdr_name+  = runInteractiveHsc hsc_env0 $+    do { hsc_env <- getHscEnv+       ; ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name }++hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)+hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do+  hsc_env <- getHscEnv+  ioMsgMaybe' $ tcRnLookupName hsc_env name+      -- ignore errors: the only error we're likely to get is+      -- "name not found", and the Maybe in the return type+      -- is used to indicate that.++hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst]))+hscTcRnGetInfo hsc_env0 name+  = runInteractiveHsc hsc_env0 $+    do { hsc_env <- getHscEnv+       ; ioMsgMaybe' $ tcRnGetInfo hsc_env name }++hscIsGHCiMonad :: HscEnv -> String -> IO Name+hscIsGHCiMonad hsc_env name+  = runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env name++hscGetModuleInterface :: HscEnv -> Module -> IO ModIface+hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do+  hsc_env <- getHscEnv+  ioMsgMaybe $ getModuleInterface hsc_env mod++-- -----------------------------------------------------------------------------+-- | Rename some import declarations+hscRnImportDecls :: HscEnv -> [LImportDecl RdrName] -> IO GlobalRdrEnv+hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do+  hsc_env <- getHscEnv+  ioMsgMaybe $ tcRnImportDecls hsc_env import_decls++-- -----------------------------------------------------------------------------+-- | parse a file, returning the abstract syntax++hscParse :: HscEnv -> ModSummary -> IO HsParsedModule+hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary++-- internal version, that doesn't fail due to -Werror+hscParse' :: ModSummary -> Hsc HsParsedModule+hscParse' mod_summary+ | Just r <- ms_parsed_mod mod_summary = return r+ | otherwise = {-# SCC "Parser" #-}+    withTiming getDynFlags+               (text "Parser"<+>brackets (ppr $ ms_mod mod_summary))+               (const ()) $ do+    dflags <- getDynFlags+    let src_filename  = ms_hspp_file mod_summary+        maybe_src_buf = ms_hspp_buf  mod_summary++    --------------------------  Parser  ----------------+    -- sometimes we already have the buffer in memory, perhaps+    -- because we needed to parse the imports out of it, or get the+    -- module name.+    buf <- case maybe_src_buf of+               Just b  -> return b+               Nothing -> liftIO $ hGetStringBuffer src_filename++    let loc = mkRealSrcLoc (mkFastString src_filename) 1 1+    let parseMod | HsigFile == ms_hsc_src mod_summary+                 = parseSignature+                 | otherwise = parseModule++    case unP parseMod (mkPState dflags buf loc) of+        PFailed span err ->+            liftIO $ throwOneError (mkPlainErrMsg dflags span err)++        POk pst rdr_module -> do+            logWarningsReportErrors (getMessages pst dflags)+            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $+                                   ppr rdr_module+            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $+                                   text (showAstData NoBlankSrcSpan rdr_module)+            liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $+                                   ppSourceStats False rdr_module++            -- To get the list of extra source files, we take the list+            -- that the parser gave us,+            --   - eliminate files beginning with '<'.  gcc likes to use+            --     pseudo-filenames like "<built-in>" and "<command-line>"+            --   - normalise them (elimiante differences between ./f and f)+            --   - filter out the preprocessed source file+            --   - filter out anything beginning with tmpdir+            --   - remove duplicates+            --   - filter out the .hs/.lhs source filename if we have one+            --+            let n_hspp  = FilePath.normalise src_filename+                srcs0 = nub $ filter (not . (tmpDir dflags `isPrefixOf`))+                            $ filter (not . (== n_hspp))+                            $ map FilePath.normalise+                            $ filter (not . (isPrefixOf "<"))+                            $ map unpackFS+                            $ srcfiles pst+                srcs1 = case ml_hs_file (ms_location mod_summary) of+                          Just f  -> filter (/= FilePath.normalise f) srcs0+                          Nothing -> srcs0++            -- sometimes we see source files from earlier+            -- preprocessing stages that cannot be found, so just+            -- filter them out:+            srcs2 <- liftIO $ filterM doesFileExist srcs1++            return HsParsedModule {+                      hpm_module    = rdr_module,+                      hpm_src_files = srcs2,+                      hpm_annotations+                              = (Map.fromListWith (++) $ annotations pst,+                                 Map.fromList $ ((noSrcSpan,comment_q pst)+                                                 :(annotations_comments pst)))+                   }++-- XXX: should this really be a Maybe X?  Check under which circumstances this+-- can become a Nothing and decide whether this should instead throw an+-- exception/signal an error.+type RenamedStuff =+        (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],+                Maybe LHsDocString))++-- | Rename and typecheck a module, additionally returning the renamed syntax+hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule+                   -> IO (TcGblEnv, RenamedStuff)+hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do+    tc_result <- hscTypecheck True mod_summary (Just rdr_module)++        -- This 'do' is in the Maybe monad!+    let rn_info = do decl <- tcg_rn_decls tc_result+                     let imports = tcg_rn_imports tc_result+                         exports = tcg_rn_exports tc_result+                         doc_hdr = tcg_doc_hdr tc_result+                     return (decl,imports,exports,doc_hdr)++    return (tc_result, rn_info)++hscTypecheck :: Bool -- ^ Keep renamed source?+             -> ModSummary -> Maybe HsParsedModule+             -> Hsc TcGblEnv+hscTypecheck keep_rn mod_summary mb_rdr_module = do+    hsc_env <- getHscEnv+    let hsc_src = ms_hsc_src mod_summary+        dflags = hsc_dflags hsc_env+        outer_mod = ms_mod mod_summary+        mod_name = moduleName outer_mod+        outer_mod' = mkModule (thisPackage dflags) mod_name+        inner_mod = canonicalizeHomeModule dflags mod_name+        src_filename  = ms_hspp_file mod_summary+        real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1+    MASSERT( moduleUnitId outer_mod == thisPackage dflags )+    if hsc_src == HsigFile && not (isHoleModule inner_mod)+        then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc+        else+         do hpm <- case mb_rdr_module of+                    Just hpm -> return hpm+                    Nothing -> hscParse' mod_summary+            tc_result0 <- tcRnModule' hsc_env mod_summary keep_rn hpm+            if hsc_src == HsigFile+                then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 Nothing+                        ioMsgMaybe $+                            tcRnMergeSignatures hsc_env hpm tc_result0 iface+                else return tc_result0++-- wrapper around tcRnModule to handle safe haskell extras+tcRnModule' :: HscEnv -> ModSummary -> Bool -> HsParsedModule+            -> Hsc TcGblEnv+tcRnModule' hsc_env sum save_rn_syntax mod = do+    tcg_res <- {-# SCC "Typecheck-Rename" #-}+               ioMsgMaybe $+                   tcRnModule hsc_env (ms_hsc_src sum) save_rn_syntax mod++    -- See Note [Safe Haskell Overlapping Instances Implementation]+    -- although this is used for more than just that failure case.+    (tcSafeOK, whyUnsafe) <- liftIO $ readIORef (tcg_safeInfer tcg_res)+    dflags   <- getDynFlags+    let allSafeOK = safeInferred dflags && tcSafeOK++    -- end of the safe haskell line, how to respond to user?+    if not (safeHaskellOn dflags) || (safeInferOn dflags && not allSafeOK)+        -- if safe Haskell off or safe infer failed, mark unsafe+        then markUnsafeInfer tcg_res whyUnsafe++        -- module (could be) safe, throw warning if needed+        else do+            tcg_res' <- hscCheckSafeImports tcg_res+            safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res')+            when safe $ do+              case wopt Opt_WarnSafe dflags of+                True -> (logWarnings $ unitBag $+                         makeIntoWarning (Reason Opt_WarnSafe) $+                         mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $+                         errSafe tcg_res')+                False | safeHaskell dflags == Sf_Trustworthy &&+                        wopt Opt_WarnTrustworthySafe dflags ->+                        (logWarnings $ unitBag $+                         makeIntoWarning (Reason Opt_WarnTrustworthySafe) $+                         mkPlainWarnMsg dflags (trustworthyOnLoc dflags) $+                         errTwthySafe tcg_res')+                False -> return ()+            return tcg_res'+  where+    pprMod t  = ppr $ moduleName $ tcg_mod t+    errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!"+    errTwthySafe t = quotes (pprMod t)+      <+> text "is marked as Trustworthy but has been inferred as safe!"++-- | Convert a typechecked module to Core+hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts+hscDesugar hsc_env mod_summary tc_result =+    runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result++hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts+hscDesugar' mod_location tc_result = do+    hsc_env <- getHscEnv+    r <- ioMsgMaybe $+      {-# SCC "deSugar" #-}+      deSugar hsc_env mod_location tc_result++    -- always check -Werror after desugaring, this is the last opportunity for+    -- warnings to arise before the backend.+    handleWarnings+    return r++-- | Make a 'ModDetails' from the results of typechecking. Used when+-- typechecking only, as opposed to full compilation.+makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails+makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result+++{- **********************************************************************+%*                                                                      *+                The main compiler pipeline+%*                                                                      *+%********************************************************************* -}++{-+                   --------------------------------+                        The compilation proper+                   --------------------------------++It's the task of the compilation proper to compile Haskell, hs-boot and core+files to either byte-code, hard-code (C, asm, LLVM, ect) or to nothing at all+(the module is still parsed and type-checked. This feature is mostly used by+IDE's and the likes). Compilation can happen in either 'one-shot', 'batch',+'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch'+mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode+targets byte-code.++The modes are kept separate because of their different types and meanings:++ * In 'one-shot' mode, we're only compiling a single file and can therefore+ discard the new ModIface and ModDetails. This is also the reason it only+ targets hard-code; compiling to byte-code or nothing doesn't make sense when+ we discard the result.++ * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface+ and ModDetails. 'Batch' mode doesn't target byte-code since that require us to+ return the newly compiled byte-code.++ * 'Nothing' mode has exactly the same type as 'batch' mode but they're still+ kept separate. This is because compiling to nothing is fairly special: We+ don't output any interface files, we don't run the simplifier and we don't+ generate any code.++ * 'Interactive' mode is similar to 'batch' mode except that we return the+ compiled byte-code together with the ModIface and ModDetails.++Trying to compile a hs-boot file to byte-code will result in a run-time error.+This is the only thing that isn't caught by the type-system.+-}+++type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModSummary -> IO ()++-- | This function runs GHC's frontend with recompilation+-- avoidance. Specifically, it checks if recompilation is needed,+-- and if it is, it parses and typechecks the input module.+-- It does not write out the results of typechecking (See+-- compileOne and hscIncrementalCompile).+hscIncrementalFrontend :: Bool -- always do basic recompilation check?+                       -> Maybe TcGblEnv+                       -> Maybe Messager+                       -> ModSummary+                       -> SourceModified+                       -> Maybe ModIface  -- Old interface, if available+                       -> (Int,Int)       -- (i,n) = module i of n (for msgs)+                       -> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))++hscIncrementalFrontend+  always_do_basic_recompilation_check m_tc_result+  mHscMessage mod_summary source_modified mb_old_iface mod_index+    = do+    hsc_env <- getHscEnv++    let msg what = case mHscMessage of+                   Just hscMessage -> hscMessage hsc_env mod_index what mod_summary+                   Nothing -> return ()++        skip iface = do+            liftIO $ msg UpToDate+            return $ Left iface++        compile mb_old_hash reason = do+            liftIO $ msg reason+            result <- genericHscFrontend mod_summary+            return $ Right (result, mb_old_hash)++        stable = case source_modified of+                     SourceUnmodifiedAndStable -> True+                     _                         -> False++    case m_tc_result of+         Just tc_result+          | not always_do_basic_recompilation_check ->+             return $ Right (FrontendTypecheck tc_result, Nothing)+         _ -> do+            (recomp_reqd, mb_checked_iface)+                <- {-# SCC "checkOldIface" #-}+                   liftIO $ checkOldIface hsc_env mod_summary+                                source_modified mb_old_iface+            -- save the interface that comes back from checkOldIface.+            -- In one-shot mode we don't have the old iface until this+            -- point, when checkOldIface reads it from the disk.+            let mb_old_hash = fmap mi_iface_hash mb_checked_iface++            case mb_checked_iface of+                Just iface | not (recompileRequired recomp_reqd) ->+                    -- If the module used TH splices when it was last+                    -- compiled, then the recompilation check is not+                    -- accurate enough (#481) and we must ignore+                    -- it.  However, if the module is stable (none of+                    -- the modules it depends on, directly or+                    -- indirectly, changed), then we *can* skip+                    -- recompilation. This is why the SourceModified+                    -- type contains SourceUnmodifiedAndStable, and+                    -- it's pretty important: otherwise ghc --make+                    -- would always recompile TH modules, even if+                    -- nothing at all has changed. Stability is just+                    -- the same check that make is doing for us in+                    -- one-shot mode.+                    case m_tc_result of+                    Nothing+                     | mi_used_th iface && not stable ->+                        compile mb_old_hash (RecompBecause "TH")+                    _ ->+                        skip iface+                _ ->+                    case m_tc_result of+                    Nothing -> compile mb_old_hash recomp_reqd+                    Just tc_result ->+                        return $ Right (FrontendTypecheck tc_result, mb_old_hash)++genericHscFrontend :: ModSummary -> Hsc FrontendResult+genericHscFrontend mod_summary =+  getHooked hscFrontendHook genericHscFrontend' >>= ($ mod_summary)++genericHscFrontend' :: ModSummary -> Hsc FrontendResult+genericHscFrontend' mod_summary+    = FrontendTypecheck `fmap` hscFileFrontEnd mod_summary++--------------------------------------------------------------+-- Compilers+--------------------------------------------------------------++-- Compile Haskell/boot in OneShot mode.+hscIncrementalCompile :: Bool+                      -> Maybe TcGblEnv+                      -> Maybe Messager+                      -> HscEnv+                      -> ModSummary+                      -> SourceModified+                      -> Maybe ModIface+                      -> (Int,Int)+                      -- HomeModInfo does not contain linkable, since we haven't+                      -- code-genned yet+                      -> IO (HscStatus, HomeModInfo)+hscIncrementalCompile always_do_basic_recompilation_check m_tc_result+    mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index+  = do+    -- One-shot mode needs a knot-tying mutable variable for interface+    -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var.+    -- See also Note [hsc_type_env_var hack]+    type_env_var <- newIORef emptyNameEnv+    let mod = ms_mod mod_summary+        hsc_env | isOneShot (ghcMode (hsc_dflags hsc_env'))+                = hsc_env' { hsc_type_env_var = Just (mod, type_env_var) }+                | otherwise+                = hsc_env'++    -- NB: enter Hsc monad here so that we don't bail out early with+    -- -Werror on typechecker warnings; we also want to run the desugarer+    -- to get those warnings too. (But we'll always exit at that point+    -- because the desugarer runs ioMsgMaybe.)+    runHsc hsc_env $ do+    let dflags = hsc_dflags hsc_env++    e <- hscIncrementalFrontend always_do_basic_recompilation_check m_tc_result mHscMessage+            mod_summary source_modified mb_old_iface mod_index+    case e of+        -- We didn't need to do any typechecking; the old interface+        -- file on disk was good enough.+        Left iface -> do+            -- Knot tying!  See Note [Knot-tying typecheckIface]+            hmi <- liftIO . fixIO $ \hmi' -> do+                let hsc_env' =+                        hsc_env {+                            hsc_HPT = addToHpt (hsc_HPT hsc_env)+                                        (ms_mod_name mod_summary) hmi'+                        }+                -- NB: This result is actually not that useful+                -- in one-shot mode, since we're not going to do+                -- any further typechecking.  It's much more useful+                -- in make mode, since this HMI will go into the HPT.+                details <- genModDetails hsc_env' iface+                return HomeModInfo{+                    hm_details = details,+                    hm_iface = iface,+                    hm_linkable = Nothing }+            return (HscUpToDate, hmi)+        -- We finished type checking.  (mb_old_hash is the hash of+        -- the interface that existed on disk; it's possible we had+        -- to retypecheck but the resulting interface is exactly+        -- the same.)+        Right (FrontendTypecheck tc_result, mb_old_hash) -> do+            (status, hmi, no_change)+                <- case ms_hsc_src mod_summary of+                        HsSrcFile | hscTarget dflags /= HscNothing ->+                            finish              hsc_env mod_summary tc_result mb_old_hash+                        _ ->+                            finishTypecheckOnly hsc_env mod_summary tc_result mb_old_hash+            liftIO $ hscMaybeWriteIface dflags (hm_iface hmi) no_change mod_summary+            return (status, hmi)++-- Generates and writes out the final interface for a typecheck.+finishTypecheckOnly :: HscEnv+              -> ModSummary+              -> TcGblEnv+              -> Maybe Fingerprint+              -> Hsc (HscStatus, HomeModInfo, Bool)+finishTypecheckOnly hsc_env summary tc_result mb_old_hash = do+    let dflags = hsc_dflags hsc_env+    (iface, changed, details) <- liftIO $ hscSimpleIface hsc_env tc_result mb_old_hash+    let hsc_status =+          case (hscTarget dflags, ms_hsc_src summary) of+            (HscNothing, _) -> HscNotGeneratingCode+            (_, HsBootFile) -> HscUpdateBoot+            (_, HsigFile) -> HscUpdateSig+            _ -> panic "finishTypecheckOnly"+    return (hsc_status,+            HomeModInfo{ hm_details  = details,+                         hm_iface    = iface,+                         hm_linkable = Nothing },+            changed)++-- Runs the post-typechecking frontend (desugar and simplify),+-- and then generates and writes out the final interface. We want+-- to write the interface AFTER simplification so we can get+-- as up-to-date and good unfoldings and other info as possible+-- in the interface file.  This is only ever run for HsSrcFile,+-- and NOT for HscNothing.+finish :: HscEnv+       -> ModSummary+       -> TcGblEnv+       -> Maybe Fingerprint+       -> Hsc (HscStatus, HomeModInfo, Bool)+finish hsc_env summary tc_result mb_old_hash = do+    let dflags = hsc_dflags hsc_env+    MASSERT( ms_hsc_src summary == HsSrcFile )+    MASSERT( hscTarget dflags /= HscNothing )+    guts0 <- hscDesugar' (ms_location summary) tc_result+    guts <- hscSimplify' guts0+    (iface, changed, details, cgguts) <- liftIO $ hscNormalIface hsc_env guts mb_old_hash++    return (HscRecomp cgguts summary,+            HomeModInfo{ hm_details  = details,+                         hm_iface    = iface,+                         hm_linkable = Nothing },+            changed)++hscMaybeWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()+hscMaybeWriteIface dflags iface changed summary =+    let force_write_interface = gopt Opt_WriteInterface dflags+        write_interface = case hscTarget dflags of+                            HscNothing      -> False+                            HscInterpreted  -> False+                            _               -> True+    in when (write_interface || force_write_interface) $+            hscWriteIface dflags iface changed summary++--------------------------------------------------------------+-- NoRecomp handlers+--------------------------------------------------------------++-- NB: this must be knot-tied appropriately, see hscIncrementalCompile+genModDetails :: HscEnv -> ModIface -> IO ModDetails+genModDetails hsc_env old_iface+  = do+    new_details <- {-# SCC "tcRnIface" #-}+                   initIfaceLoad hsc_env (typecheckIface old_iface)+    dumpIfaceStats hsc_env+    return new_details++--------------------------------------------------------------+-- Progress displayers.+--------------------------------------------------------------++oneShotMsg :: HscEnv -> RecompileRequired -> IO ()+oneShotMsg hsc_env recomp =+    case recomp of+        UpToDate ->+            compilationProgressMsg (hsc_dflags hsc_env) $+                   "compilation IS NOT required"+        _ ->+            return ()++batchMsg :: Messager+batchMsg hsc_env mod_index recomp mod_summary =+    case recomp of+        MustCompile -> showMsg "Compiling " ""+        UpToDate+            | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping  " ""+            | otherwise -> return ()+        RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")+    where+        dflags = hsc_dflags hsc_env+        showMsg msg reason =+            compilationProgressMsg dflags $+            (showModuleIndex mod_index +++            msg ++ showModMsg dflags (hscTarget dflags)+                              (recompileRequired recomp) mod_summary)+                ++ reason++--------------------------------------------------------------+-- FrontEnds+--------------------------------------------------------------++-- | Given a 'ModSummary', parses and typechecks it, returning the+-- 'TcGblEnv' resulting from type-checking.+hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv+hscFileFrontEnd mod_summary = hscTypecheck False mod_summary Nothing++--------------------------------------------------------------+-- Safe Haskell+--------------------------------------------------------------++-- Note [Safe Haskell Trust Check]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Safe Haskell checks that an import is trusted according to the following+-- rules for an import of module M that resides in Package P:+--+--   * If M is recorded as Safe and all its trust dependencies are OK+--     then M is considered safe.+--   * If M is recorded as Trustworthy and P is considered trusted and+--     all M's trust dependencies are OK then M is considered safe.+--+-- By trust dependencies we mean that the check is transitive. So if+-- a module M that is Safe relies on a module N that is trustworthy,+-- importing module M will first check (according to the second case)+-- that N is trusted before checking M is trusted.+--+-- This is a minimal description, so please refer to the user guide+-- for more details. The user guide is also considered the authoritative+-- source in this matter, not the comments or code.+++-- Note [Safe Haskell Inference]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Safe Haskell does Safe inference on modules that don't have any specific+-- safe haskell mode flag. The basic approach to this is:+--   * When deciding if we need to do a Safe language check, treat+--     an unmarked module as having -XSafe mode specified.+--   * For checks, don't throw errors but return them to the caller.+--   * Caller checks if there are errors:+--     * For modules explicitly marked -XSafe, we throw the errors.+--     * For unmarked modules (inference mode), we drop the errors+--       and mark the module as being Unsafe.+--+-- It used to be that we only did safe inference on modules that had no Safe+-- Haskell flags, but now we perform safe inference on all modules as we want+-- to allow users to set the `-Wsafe`, `-Wunsafe` and+-- `-Wtrustworthy-safe` flags on Trustworthy and Unsafe modules so that a+-- user can ensure their assumptions are correct and see reasons for why a+-- module is safe or unsafe.+--+-- This is tricky as we must be careful when we should throw an error compared+-- to just warnings. For checking safe imports we manage it as two steps. First+-- we check any imports that are required to be safe, then we check all other+-- imports to see if we can infer them to be safe.+++-- | Check that the safe imports of the module being compiled are valid.+-- If not we either issue a compilation error if the module is explicitly+-- using Safe Haskell, or mark the module as unsafe if we're in safe+-- inference mode.+hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv+hscCheckSafeImports tcg_env = do+    dflags   <- getDynFlags+    tcg_env' <- checkSafeImports dflags tcg_env+    checkRULES dflags tcg_env'++  where+    checkRULES dflags tcg_env' = do+      case safeLanguageOn dflags of+          True -> do+              -- XSafe: we nuke user written RULES+              logWarnings $ warns dflags (tcg_rules tcg_env')+              return tcg_env' { tcg_rules = [] }+          False+                -- SafeInferred: user defined RULES, so not safe+              | safeInferOn dflags && not (null $ tcg_rules tcg_env')+              -> markUnsafeInfer tcg_env' $ warns dflags (tcg_rules tcg_env')++                -- Trustworthy OR SafeInferred: with no RULES+              | otherwise+              -> return tcg_env'++    warns dflags rules = listToBag $ map (warnRules dflags) rules+    warnRules dflags (L loc (HsRule n _ _ _ _ _ _)) =+        mkPlainWarnMsg dflags loc $+            text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$+            text "User defined rules are disabled under Safe Haskell"++-- | Validate that safe imported modules are actually safe.  For modules in the+-- HomePackage (the package the module we are compiling in resides) this just+-- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules+-- that reside in another package we also must check that the external pacakge+-- is trusted. See the Note [Safe Haskell Trust Check] above for more+-- information.+--+-- The code for this is quite tricky as the whole algorithm is done in a few+-- distinct phases in different parts of the code base. See+-- RnNames.rnImportDecl for where package trust dependencies for a module are+-- collected and unioned.  Specifically see the Note [RnNames . Tracking Trust+-- Transitively] and the Note [RnNames . Trust Own Package].+checkSafeImports :: DynFlags -> TcGblEnv -> Hsc TcGblEnv+checkSafeImports dflags tcg_env+    = do+        imps <- mapM condense imports'+        let (safeImps, regImps) = partition (\(_,_,s) -> s) imps++        -- We want to use the warning state specifically for detecting if safe+        -- inference has failed, so store and clear any existing warnings.+        oldErrs <- getWarnings+        clearWarnings++        -- Check safe imports are correct+        safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps+        safeErrs <- getWarnings+        clearWarnings++        -- Check non-safe imports are correct if inferring safety+        -- See the Note [Safe Haskell Inference]+        (infErrs, infPkgs) <- case (safeInferOn dflags) of+          False -> return (emptyBag, S.empty)+          True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps+                     infErrs <- getWarnings+                     clearWarnings+                     return (infErrs, infPkgs)++        -- restore old errors+        logWarnings oldErrs++        case (isEmptyBag safeErrs) of+          -- Failed safe check+          False -> liftIO . throwIO . mkSrcErr $ safeErrs++          -- Passed safe check+          True -> do+            let infPassed = isEmptyBag infErrs+            tcg_env' <- case (not infPassed) of+              True  -> markUnsafeInfer tcg_env infErrs+              False -> return tcg_env+            when (packageTrustOn dflags) $ checkPkgTrust dflags pkgReqs+            let newTrust = pkgTrustReqs safePkgs infPkgs infPassed+            return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust }++  where+    impInfo  = tcg_imports tcg_env     -- ImportAvails+    imports  = imp_mods impInfo        -- ImportedMods+    imports1 = moduleEnvToList imports -- (Module, [ImportedBy])+    imports' = map (fmap importedByUser) imports1 -- (Module, [ImportedModsVal])+    pkgReqs  = imp_trust_pkgs impInfo  -- [UnitId]++    condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)+    condense (_, [])   = panic "HscMain.condense: Pattern match failure!"+    condense (m, x:xs) = do imv <- foldlM cond' x xs+                            return (m, imv_span imv, imv_is_safe imv)++    -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)+    cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal+    cond' v1 v2+        | imv_is_safe v1 /= imv_is_safe v2+        = throwErrors $ unitBag $ mkPlainErrMsg dflags (imv_span v1)+              (text "Module" <+> ppr (imv_name v1) <+>+              (text $ "is imported both as a safe and unsafe import!"))+        | otherwise+        = return v1++    -- easier interface to work with+    checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe InstalledUnitId)+    checkSafe (m, l, _) = fst `fmap` hscCheckSafe' dflags m l++    -- what pkg's to add to our trust requirements+    pkgTrustReqs :: Set InstalledUnitId -> Set InstalledUnitId -> Bool -> ImportAvails+    pkgTrustReqs req inf infPassed | safeInferOn dflags+                                  && safeHaskell dflags == Sf_None && infPassed+                                   = emptyImportAvails {+                                       imp_trust_pkgs = req `S.union` inf+                                   }+    pkgTrustReqs _   _ _ | safeHaskell dflags == Sf_Unsafe+                         = emptyImportAvails+    pkgTrustReqs req _ _ = emptyImportAvails { imp_trust_pkgs = req }++-- | Check that a module is safe to import.+--+-- We return True to indicate the import is safe and False otherwise+-- although in the False case an exception may be thrown first.+hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool+hscCheckSafe hsc_env m l = runHsc hsc_env $ do+    dflags <- getDynFlags+    pkgs <- snd `fmap` hscCheckSafe' dflags m l+    when (packageTrustOn dflags) $ checkPkgTrust dflags pkgs+    errs <- getWarnings+    return $ isEmptyBag errs++-- | Return if a module is trusted and the pkgs it depends on to be trusted.+hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set InstalledUnitId)+hscGetSafe hsc_env m l = runHsc hsc_env $ do+    dflags       <- getDynFlags+    (self, pkgs) <- hscCheckSafe' dflags m l+    good         <- isEmptyBag `fmap` getWarnings+    clearWarnings -- don't want them printed...+    let pkgs' | Just p <- self = S.insert p pkgs+              | otherwise      = pkgs+    return (good, pkgs')++-- | Is a module trusted? If not, throw or log errors depending on the type.+-- Return (regardless of trusted or not) if the trust type requires the modules+-- own package be trusted and a list of other packages required to be trusted+-- (these later ones haven't been checked) but the own package trust has been.+hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)+hscCheckSafe' dflags m l = do+    (tw, pkgs) <- isModSafe m l+    case tw of+        False              -> return (Nothing, pkgs)+        True | isHomePkg m -> return (Nothing, pkgs)+             -- TODO: do we also have to check the trust of the instantiation?+             -- Not necessary if that is reflected in dependencies+             | otherwise   -> return (Just $ toInstalledUnitId (moduleUnitId m), pkgs)+  where+    isModSafe :: Module -> SrcSpan -> Hsc (Bool, Set InstalledUnitId)+    isModSafe m l = do+        iface <- lookup' m+        case iface of+            -- can't load iface to check trust!+            Nothing -> throwErrors $ unitBag $ mkPlainErrMsg dflags l+                         $ text "Can't load the interface file for" <+> ppr m+                           <> text ", to check that it can be safely imported"++            -- got iface, check trust+            Just iface' ->+                let trust = getSafeMode $ mi_trust iface'+                    trust_own_pkg = mi_trust_pkg iface'+                    -- check module is trusted+                    safeM = trust `elem` [Sf_Safe, Sf_Trustworthy]+                    -- check package is trusted+                    safeP = packageTrusted trust trust_own_pkg m+                    -- pkg trust reqs+                    pkgRs = S.fromList . map fst $ filter snd $ dep_pkgs $ mi_deps iface'+                    -- General errors we throw but Safe errors we log+                    errs = case (safeM, safeP) of+                        (True, True ) -> emptyBag+                        (True, False) -> pkgTrustErr+                        (False, _   ) -> modTrustErr+                in do+                    logWarnings errs+                    return (trust == Sf_Trustworthy, pkgRs)++                where+                    pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $+                        sep [ ppr (moduleName m)+                                <> text ": Can't be safely imported!"+                            , text "The package (" <> ppr (moduleUnitId m)+                                <> text ") the module resides in isn't trusted."+                            ]+                    modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $+                        sep [ ppr (moduleName m)+                                <> text ": Can't be safely imported!"+                            , text "The module itself isn't safe." ]++    -- | Check the package a module resides in is trusted. Safe compiled+    -- modules are trusted without requiring that their package is trusted. For+    -- trustworthy modules, modules in the home package are trusted but+    -- otherwise we check the package trust flag.+    packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool+    packageTrusted Sf_None             _ _ = False -- shouldn't hit these cases+    packageTrusted Sf_Unsafe           _ _ = False -- prefer for completeness.+    packageTrusted _ _ _+        | not (packageTrustOn dflags)      = True+    packageTrusted Sf_Safe         False _ = True+    packageTrusted _ _ m+        | isHomePkg m = True+        | otherwise   = trusted $ getPackageDetails dflags (moduleUnitId m)++    lookup' :: Module -> Hsc (Maybe ModIface)+    lookup' m = do+        hsc_env <- getHscEnv+        hsc_eps <- liftIO $ hscEPS hsc_env+        let pkgIfaceT = eps_PIT hsc_eps+            homePkgT  = hsc_HPT hsc_env+            iface     = lookupIfaceByModule dflags homePkgT pkgIfaceT m+        -- the 'lookupIfaceByModule' method will always fail when calling from GHCi+        -- as the compiler hasn't filled in the various module tables+        -- so we need to call 'getModuleInterface' to load from disk+        iface' <- case iface of+            Just _  -> return iface+            Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m)+        return iface'+++    isHomePkg :: Module -> Bool+    isHomePkg m+        | thisPackage dflags == moduleUnitId m = True+        | otherwise                               = False++-- | Check the list of packages are trusted.+checkPkgTrust :: DynFlags -> Set InstalledUnitId -> Hsc ()+checkPkgTrust dflags pkgs =+    case errors of+        [] -> return ()+        _  -> (liftIO . throwIO . mkSrcErr . listToBag) errors+    where+        errors = S.foldr go [] pkgs+        go pkg acc+            | trusted $ getInstalledPackageDetails dflags pkg+            = acc+            | otherwise+            = (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual dflags)+                     $ text "The package (" <> ppr pkg <> text ") is required" <>+                       text " to be trusted but it isn't!"++-- | Set module to unsafe and (potentially) wipe trust information.+--+-- Make sure to call this method to set a module to inferred unsafe, it should+-- be a central and single failure method. We only wipe the trust information+-- when we aren't in a specific Safe Haskell mode.+--+-- While we only use this for recording that a module was inferred unsafe, we+-- may call it on modules using Trustworthy or Unsafe flags so as to allow+-- warning flags for safety to function correctly. See Note [Safe Haskell+-- Inference].+markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv+markUnsafeInfer tcg_env whyUnsafe = do+    dflags <- getDynFlags++    when (wopt Opt_WarnUnsafe dflags)+         (logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnUnsafe) $+             mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))++    liftIO $ writeIORef (tcg_safeInfer tcg_env) (False, whyUnsafe)+    -- NOTE: Only wipe trust when not in an explicity safe haskell mode. Other+    -- times inference may be on but we are in Trustworthy mode -- so we want+    -- to record safe-inference failed but not wipe the trust dependencies.+    case safeHaskell dflags == Sf_None of+      True  -> return $ tcg_env { tcg_imports = wiped_trust }+      False -> return tcg_env++  where+    wiped_trust   = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty }+    pprMod        = ppr $ moduleName $ tcg_mod tcg_env+    whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!"+                         , text "Reason:"+                         , nest 4 $ (vcat $ badFlags df) $+$+                                    (vcat $ pprErrMsgBagWithLoc whyUnsafe) $+$+                                    (vcat $ badInsts $ tcg_insts tcg_env)+                         ]+    badFlags df   = concat $ map (badFlag df) unsafeFlagsForInfer+    badFlag df (str,loc,on,_)+        | on df     = [mkLocMessage SevOutput (loc df) $+                            text str <+> text "is not allowed in Safe Haskell"]+        | otherwise = []+    badInsts insts = concat $ map badInst insts++    checkOverlap (NoOverlap _) = False+    checkOverlap _             = True++    badInst ins | checkOverlap (overlapMode (is_flag ins))+                = [mkLocMessage SevOutput (nameSrcSpan $ getName $ is_dfun ins) $+                      ppr (overlapMode $ is_flag ins) <+>+                      text "overlap mode isn't allowed in Safe Haskell"]+                | otherwise = []+++-- | Figure out the final correct safe haskell mode+hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode+hscGetSafeMode tcg_env = do+    dflags  <- getDynFlags+    liftIO $ finalSafeMode dflags tcg_env++--------------------------------------------------------------+-- Simplifiers+--------------------------------------------------------------++hscSimplify :: HscEnv -> ModGuts -> IO ModGuts+hscSimplify hsc_env modguts = runHsc hsc_env $ hscSimplify' modguts++hscSimplify' :: ModGuts -> Hsc ModGuts+hscSimplify' ds_result = do+    hsc_env <- getHscEnv+    {-# SCC "Core2Core" #-}+      liftIO $ core2core hsc_env ds_result++--------------------------------------------------------------+-- Interface generators+--------------------------------------------------------------++hscSimpleIface :: HscEnv+               -> TcGblEnv+               -> Maybe Fingerprint+               -> IO (ModIface, Bool, ModDetails)+hscSimpleIface hsc_env tc_result mb_old_iface+    = runHsc hsc_env $ hscSimpleIface' tc_result mb_old_iface++hscSimpleIface' :: TcGblEnv+                -> Maybe Fingerprint+                -> Hsc (ModIface, Bool, ModDetails)+hscSimpleIface' tc_result mb_old_iface = do+    hsc_env   <- getHscEnv+    details   <- liftIO $ mkBootModDetailsTc hsc_env tc_result+    safe_mode <- hscGetSafeMode tc_result+    (new_iface, no_change)+        <- {-# SCC "MkFinalIface" #-}+           liftIO $+               mkIfaceTc hsc_env mb_old_iface safe_mode details tc_result+    -- And the answer is ...+    liftIO $ dumpIfaceStats hsc_env+    return (new_iface, no_change, details)++hscNormalIface :: HscEnv+               -> ModGuts+               -> Maybe Fingerprint+               -> IO (ModIface, Bool, ModDetails, CgGuts)+hscNormalIface hsc_env simpl_result mb_old_iface =+    runHsc hsc_env $ hscNormalIface' simpl_result mb_old_iface++hscNormalIface' :: ModGuts+                -> Maybe Fingerprint+                -> Hsc (ModIface, Bool, ModDetails, CgGuts)+hscNormalIface' simpl_result mb_old_iface = do+    hsc_env <- getHscEnv+    (cg_guts, details) <- {-# SCC "CoreTidy" #-}+                          liftIO $ tidyProgram hsc_env simpl_result++    -- BUILD THE NEW ModIface and ModDetails+    --  and emit external core if necessary+    -- This has to happen *after* code gen so that the back-end+    -- info has been set. Not yet clear if it matters waiting+    -- until after code output+    (new_iface, no_change)+        <- {-# SCC "MkFinalIface" #-}+           liftIO $+               mkIface hsc_env mb_old_iface details simpl_result++    liftIO $ dumpIfaceStats hsc_env++    -- Return the prepared code.+    return (new_iface, no_change, details, cg_guts)++--------------------------------------------------------------+-- BackEnd combinators+--------------------------------------------------------------++hscWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()+hscWriteIface dflags iface no_change mod_summary = do+    let ifaceFile = ml_hi_file (ms_location mod_summary)+    unless no_change $+        {-# SCC "writeIface" #-}+        writeIfaceFile dflags ifaceFile iface+    whenGeneratingDynamicToo dflags $ do+        -- TODO: We should do a no_change check for the dynamic+        --       interface file too+        -- TODO: Should handle the dynamic hi filename properly+        let dynIfaceFile = replaceExtension ifaceFile (dynHiSuf dflags)+            dynIfaceFile' = addBootSuffix_maybe (mi_boot iface) dynIfaceFile+            dynDflags = dynamicTooMkDynamicDynFlags dflags+        writeIfaceFile dynDflags dynIfaceFile' iface++-- | Compile to hard-code.+hscGenHardCode :: HscEnv -> CgGuts -> ModSummary -> FilePath+               -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)])+               -- ^ @Just f@ <=> _stub.c is f+hscGenHardCode hsc_env cgguts mod_summary output_filename = do+        let CgGuts{ -- This is the last use of the ModGuts in a compilation.+                    -- From now on, we just use the bits we need.+                    cg_module   = this_mod,+                    cg_binds    = core_binds,+                    cg_tycons   = tycons,+                    cg_foreign  = foreign_stubs0,+                    cg_foreign_files = foreign_files,+                    cg_dep_pkgs = dependencies,+                    cg_hpc_info = hpc_info } = cgguts+            dflags = hsc_dflags hsc_env+            location = ms_location mod_summary+            data_tycons = filter isDataTyCon tycons+            -- cg_tycons includes newtypes, for the benefit of External Core,+            -- but we don't generate any code for newtypes++        -------------------+        -- PREPARE FOR CODE GENERATION+        -- Do saturation and convert to A-normal form+        prepd_binds <- {-# SCC "CorePrep" #-}+                       corePrepPgm hsc_env this_mod location+                                   core_binds data_tycons+        -----------------  Convert to STG ------------------+        (stg_binds, cost_centre_info)+            <- {-# SCC "CoreToStg" #-}+               myCoreToStg dflags this_mod prepd_binds++        let prof_init = profilingInitCode this_mod cost_centre_info+            foreign_stubs = foreign_stubs0 `appendStubC` prof_init++        ------------------  Code generation ------------------++        -- The back-end is streamed: each top-level function goes+        -- from Stg all the way to asm before dealing with the next+        -- top-level function, so showPass isn't very useful here.+        -- Hence we have one showPass for the whole backend, the+        -- next showPass after this will be "Assembler".+        withTiming (pure dflags)+                   (text "CodeGen"<+>brackets (ppr this_mod))+                   (const ()) $ do+            cmms <- {-# SCC "StgCmm" #-}+                            doCodeGen hsc_env this_mod data_tycons+                                cost_centre_info+                                stg_binds hpc_info++            ------------------  Code output -----------------------+            rawcmms0 <- {-# SCC "cmmToRawCmm" #-}+                      cmmToRawCmm dflags cmms++            let dump a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm"+                              (ppr a)+                            return a+                rawcmms1 = Stream.mapM dump rawcmms0++            (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps)+                <- {-# SCC "codeOutput" #-}+                  codeOutput dflags this_mod output_filename location+                  foreign_stubs foreign_files dependencies rawcmms1+            return (output_filename, stub_c_exists, foreign_fps)+++hscInteractive :: HscEnv+               -> CgGuts+               -> ModSummary+               -> IO (Maybe FilePath, CompiledByteCode, [SptEntry])+hscInteractive hsc_env cgguts mod_summary = do+    let dflags = hsc_dflags hsc_env+    let CgGuts{ -- This is the last use of the ModGuts in a compilation.+                -- From now on, we just use the bits we need.+               cg_module   = this_mod,+               cg_binds    = core_binds,+               cg_tycons   = tycons,+               cg_foreign  = foreign_stubs,+               cg_modBreaks = mod_breaks,+               cg_spt_entries = spt_entries } = cgguts++        location = ms_location mod_summary+        data_tycons = filter isDataTyCon tycons+        -- cg_tycons includes newtypes, for the benefit of External Core,+        -- but we don't generate any code for newtypes++    -------------------+    -- PREPARE FOR CODE GENERATION+    -- Do saturation and convert to A-normal form+    prepd_binds <- {-# SCC "CorePrep" #-}+                   corePrepPgm hsc_env this_mod location core_binds data_tycons+    -----------------  Generate byte code ------------------+    comp_bc <- byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks+    ------------------ Create f-x-dynamic C-side stuff -----+    (_istub_h_exists, istub_c_exists)+        <- outputForeignStubs dflags this_mod location foreign_stubs+    return (istub_c_exists, comp_bc, spt_entries)++------------------------------++hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO ()+hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do+    let dflags = hsc_dflags hsc_env+    cmm <- ioMsgMaybe $ parseCmmFile dflags filename+    liftIO $ do+        us <- mkSplitUniqSupply 'S'+        let initTopSRT = initUs_ us emptySRT+        dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose "Parsed Cmm" (ppr cmm)+        (_, cmmgroup) <- cmmPipeline hsc_env initTopSRT cmm+        rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup)+        let -- Make up a module name to give the NCG. We can't pass bottom here+            -- lest we reproduce #11784.+            mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename+            cmm_mod = mkModule (thisPackage dflags) mod_name+        _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] []+             rawCmms+        return ()+  where+    no_loc = ModLocation{ ml_hs_file  = Just filename,+                          ml_hi_file  = panic "hscCompileCmmFile: no hi file",+                          ml_obj_file = panic "hscCompileCmmFile: no obj file" }++-------------------- Stuff for new code gen ---------------------++doCodeGen   :: HscEnv -> Module -> [TyCon]+            -> CollectedCCs+            -> [StgTopBinding]+            -> HpcInfo+            -> IO (Stream IO CmmGroup ())+         -- Note we produce a 'Stream' of CmmGroups, so that the+         -- backend can be run incrementally.  Otherwise it generates all+         -- the C-- up front, which has a significant space cost.+doCodeGen hsc_env this_mod data_tycons+              cost_centre_info stg_binds hpc_info = do+    let dflags = hsc_dflags hsc_env++    let cmm_stream :: Stream IO CmmGroup ()+        cmm_stream = {-# SCC "StgCmm" #-}+            StgCmm.codeGen dflags this_mod data_tycons+                           cost_centre_info stg_binds hpc_info++        -- codegen consumes a stream of CmmGroup, and produces a new+        -- stream of CmmGroup (not necessarily synchronised: one+        -- CmmGroup on input may produce many CmmGroups on output due+        -- to proc-point splitting).++    let dump1 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_from_stg+                       "Cmm produced by codegen" (ppr a)+                     return a++        ppr_stream1 = Stream.mapM dump1 cmm_stream++    -- We are building a single SRT for the entire module, so+    -- we must thread it through all the procedures as we cps-convert them.+    us <- mkSplitUniqSupply 'S'++    -- When splitting, we generate one SRT per split chunk, otherwise+    -- we generate one SRT for the whole module.+    let+     pipeline_stream+      | gopt Opt_SplitObjs dflags || gopt Opt_SplitSections dflags ||+        osSubsectionsViaSymbols (platformOS (targetPlatform dflags))+        = {-# SCC "cmmPipeline" #-}+          let run_pipeline us cmmgroup = do+                let (topSRT', us') = initUs us emptySRT+                (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT' cmmgroup+                let srt | isEmptySRT topSRT = []+                        | otherwise         = srtToData topSRT+                return (us', srt ++ cmmgroup)++          in do _ <- Stream.mapAccumL run_pipeline us ppr_stream1+                return ()++      | otherwise+        = {-# SCC "cmmPipeline" #-}+          let initTopSRT = initUs_ us emptySRT+              run_pipeline = cmmPipeline hsc_env+          in do topSRT <- Stream.mapAccumL run_pipeline initTopSRT ppr_stream1+                Stream.yield (srtToData topSRT)++    let+        dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm+                        "Output Cmm" (ppr a)+                     return a++        ppr_stream2 = Stream.mapM dump2 pipeline_stream++    return ppr_stream2++++myCoreToStg :: DynFlags -> Module -> CoreProgram+            -> IO ( [StgTopBinding] -- output program+                  , CollectedCCs) -- cost centre info (declared and used)+myCoreToStg dflags this_mod prepd_binds = do+    let stg_binds+         = {-# SCC "Core2Stg" #-}+           coreToStg dflags this_mod prepd_binds++    (stg_binds2, cost_centre_info)+        <- {-# SCC "Stg2Stg" #-}+           stg2stg dflags this_mod stg_binds++    return (stg_binds2, cost_centre_info)+++{- **********************************************************************+%*                                                                      *+\subsection{Compiling a do-statement}+%*                                                                      *+%********************************************************************* -}++{-+When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When+you run it you get a list of HValues that should be the same length as the list+of names; add them to the ClosureEnv.++A naked expression returns a singleton Name [it]. The stmt is lifted into the+IO monad as explained in Note [Interactively-bound Ids in GHCi] in HscTypes+-}++-- | Compile a stmt all the way to an HValue, but don't run it+--+-- We return Nothing to indicate an empty statement (or comment only), not a+-- parse error.+hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv))+hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<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 RdrName  -- ^ The parsed statement+              -> IO ( Maybe ([Id]+                    , ForeignHValue {- IO [HValue] -}+                    , FixityEnv))+hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do+  -- Rename and typecheck it+  (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env stmt++  -- Desugar it+  ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr+  liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr)+  handleWarnings++  -- Then code-gen, and link it+  -- It's important NOT to have package 'interactive' as thisUnitId+  -- for linking, else we try to link 'main' and can't find it.+  -- Whereas the linker already knows to ignore 'interactive'+  let src_span = srcLocSpan interactiveSrcLoc+  hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr++  return $ Just (ids, hval, fix_env)++-- | Compile a decls+hscDecls :: HscEnv+         -> String -- ^ The statement+         -> IO ([TyThing], InteractiveContext)+hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1++-- | Compile a decls+hscDeclsWithLocation :: HscEnv+                     -> String -- ^ The statement+                     -> String -- ^ The source+                     -> Int    -- ^ Starting line+                     -> IO ([TyThing], InteractiveContext)+hscDeclsWithLocation hsc_env0 str source linenumber =+ runInteractiveHsc hsc_env0 $ do+    L _ (HsModule{ hsmodDecls = decls }) <-+        hscParseThingWithLocation source linenumber parseModule str++    {- Rename and typecheck it -}+    hsc_env <- getHscEnv+    tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env decls++    {- Grab the new instances -}+    -- We grab the whole environment because of the overlapping that may have+    -- been done. See the notes at the definition of InteractiveContext+    -- (ic_instances) for more details.+    let defaults = tcg_default tc_gblenv++    {- Desugar it -}+    -- We use a basically null location for iNTERACTIVE+    let iNTERACTIVELoc = ModLocation{ ml_hs_file   = Nothing,+                                      ml_hi_file   = panic "hsDeclsWithLocation:ml_hi_file",+                                      ml_obj_file  = panic "hsDeclsWithLocation:ml_hi_file"}+    ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv++    {- Simplify -}+    simpl_mg <- liftIO $ hscSimplify hsc_env ds_result++    {- Tidy -}+    (tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg++    let !CgGuts{ cg_module    = this_mod,+                 cg_binds     = core_binds,+                 cg_tycons    = tycons,+                 cg_modBreaks = mod_breaks } = tidy_cg++        !ModDetails { md_insts     = cls_insts+                    , md_fam_insts = fam_insts } = mod_details+            -- Get the *tidied* cls_insts and fam_insts++        data_tycons = filter isDataTyCon tycons++    {- Prepare For Code Generation -}+    -- Do saturation and convert to A-normal form+    prepd_binds <- {-# SCC "CorePrep" #-}+      liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons++    {- Generate byte code -}+    cbc <- liftIO $ byteCodeGen hsc_env this_mod+                                prepd_binds data_tycons mod_breaks++    let src_span = srcLocSpan interactiveSrcLoc+    liftIO $ linkDecls hsc_env src_span cbc++    {- Load static pointer table entries -}+    liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg)++    let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg)+        patsyns = mg_patsyns simpl_mg++        ext_ids = [ id | id <- bindersOfBinds core_binds+                       , isExternalName (idName id)+                       , not (isDFunId id || isImplicitId id) ]+            -- We only need to keep around the external bindings+            -- (as decided by TidyPgm), since those are the only ones+            -- that might later be looked up by name.  But we can exclude+            --    - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in HscTypes+            --    - Implicit Ids, which are implicit in tcs+            -- c.f. TcRnDriver.runTcInteractive, which reconstructs the TypeEnv++        new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns+        ictxt        = hsc_IC hsc_env+        -- See Note [Fixity declarations in GHCi]+        fix_env      = tcg_fix_env tc_gblenv+        new_ictxt    = extendInteractiveContext ictxt new_tythings cls_insts+                                                fam_insts defaults fix_env+    return (new_tythings, new_ictxt)++-- | Load the given static-pointer table entries into the interpreter.+-- See Note [Grand plan for static forms] in StaticPtrTable.+hscAddSptEntries :: HscEnv -> [SptEntry] -> IO ()+hscAddSptEntries hsc_env entries = do+    let add_spt_entry :: SptEntry -> IO ()+        add_spt_entry (SptEntry i fpr) = do+            val <- getHValue hsc_env (idName i)+            addSptEntry hsc_env fpr val+    mapM_ add_spt_entry entries++{-+  Note [Fixity declarations in GHCi]+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++  To support fixity declarations on types defined within GHCi (as requested+  in #10018) we record the fixity environment in InteractiveContext.+  When we want to evaluate something TcRnDriver.runTcInteractive pulls out this+  fixity environment and uses it to initialize the global typechecker environment.+  After the typechecker has finished its business, an updated fixity environment+  (reflecting whatever fixity declarations were present in the statements we+  passed it) will be returned from hscParsedStmt. This is passed to+  updateFixityEnv, which will stuff it back into InteractiveContext, to be+  used in evaluating the next statement.++-}++hscImport :: HscEnv -> String -> IO (ImportDecl RdrName)+hscImport hsc_env str = runInteractiveHsc hsc_env $ do+    (L _ (HsModule{hsmodImports=is})) <-+       hscParseThing parseModule str+    case is of+        [L _ i] -> return i+        _ -> liftIO $ throwOneError $+                 mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $+                     text "parse error in import declaration"++-- | Typecheck an expression (but don't run it)+hscTcExpr :: HscEnv+          -> TcRnExprMode+          -> String -- ^ The expression+          -> IO Type+hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do+  hsc_env <- getHscEnv+  parsed_expr <- hscParseExpr expr+  ioMsgMaybe $ tcRnExpr hsc_env mode parsed_expr++-- | Find the kind of a type+-- Currently this does *not* generalise the kinds of the type+hscKcType+  :: HscEnv+  -> Bool            -- ^ Normalise the type+  -> String          -- ^ The type as a string+  -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind+hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do+    hsc_env <- getHscEnv+    ty <- hscParseType str+    ioMsgMaybe $ tcRnType hsc_env normalise ty++hscParseExpr :: String -> Hsc (LHsExpr RdrName)+hscParseExpr expr = do+  hsc_env <- getHscEnv+  maybe_stmt <- hscParseStmt expr+  case maybe_stmt of+    Just (L _ (BodyStmt expr _ _ _)) -> return expr+    _ -> throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan+      (text "not an expression:" <+> quotes (text expr))++hscParseStmt :: String -> Hsc (Maybe (GhciLStmt RdrName))+hscParseStmt = hscParseThing parseStmt++hscParseStmtWithLocation :: String -> Int -> String+                         -> Hsc (Maybe (GhciLStmt RdrName))+hscParseStmtWithLocation source linenumber stmt =+    hscParseThingWithLocation source linenumber parseStmt stmt++hscParseType :: String -> Hsc (LHsType RdrName)+hscParseType = hscParseThing parseType++hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName)+hscParseIdentifier hsc_env str =+    runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str++hscParseThing :: (Outputable thing, Data thing)+              => Lexer.P thing -> String -> Hsc thing+hscParseThing = hscParseThingWithLocation "<interactive>" 1++hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int+                          -> Lexer.P thing -> String -> Hsc thing+hscParseThingWithLocation source linenumber parser str+  = withTiming getDynFlags+               (text "Parser [source]")+               (const ()) $ {-# SCC "Parser" #-} do+    dflags <- getDynFlags++    let buf = stringToStringBuffer str+        loc = mkRealSrcLoc (fsLit source) linenumber 1++    case unP parser (mkPState dflags buf loc) of+        PFailed span err -> do+            let msg = mkPlainErrMsg dflags span err+            throwErrors $ unitBag msg++        POk pst thing -> do+            logWarningsReportErrors (getMessages pst dflags)+            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)+            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $+                                   text $ showAstData NoBlankSrcSpan thing+            return thing+++{- **********************************************************************+%*                                                                      *+        Desugar, simplify, convert to bytecode, and link an expression+%*                                                                      *+%********************************************************************* -}++hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue+hscCompileCoreExpr hsc_env =+  lookupHook hscCompileCoreExprHook hscCompileCoreExpr' (hsc_dflags hsc_env) hsc_env++hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue+hscCompileCoreExpr' hsc_env srcspan ds_expr+    = do { let dflags = hsc_dflags hsc_env++           {- Simplify it -}+         ; simpl_expr <- simplifyExpr dflags ds_expr++           {- Tidy it (temporary, until coreSat does cloning) -}+         ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr++           {- Prepare for codegen -}+         ; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr++           {- Lint if necessary -}+         ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr++           {- Convert to BCOs -}+         ; bcos <- coreExprToBCOs hsc_env+                     (icInteractiveModule (hsc_IC hsc_env)) prepd_expr++           {- link it -}+         ; hval <- linkExpr hsc_env srcspan bcos++         ; return hval }+++{- **********************************************************************+%*                                                                      *+        Statistics on reading interfaces+%*                                                                      *+%********************************************************************* -}++dumpIfaceStats :: HscEnv -> IO ()+dumpIfaceStats hsc_env = do+    eps <- readIORef (hsc_EPS hsc_env)+    dumpIfSet dflags (dump_if_trace || dump_rn_stats)+              "Interface statistics"+              (ifaceStats eps)+  where+    dflags = hsc_dflags hsc_env+    dump_rn_stats = dopt Opt_D_dump_rn_stats dflags+    dump_if_trace = dopt Opt_D_dump_if_trace dflags+++{- **********************************************************************+%*                                                                      *+        Progress Messages: Module i of n+%*                                                                      *+%********************************************************************* -}++showModuleIndex :: (Int, Int) -> String+showModuleIndex (i,n) = "[" ++ padded ++ " of " ++ n_str ++ "] "+  where+    n_str = show n+    i_str = show i+    padded = replicate (length n_str - length i_str) ' ' ++ i_str
+ main/HscStats.hs view
@@ -0,0 +1,180 @@+-- |+-- Statistics for per-module compilations+--+-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998+--++{-# LANGUAGE FlexibleContexts #-}++module HscStats ( ppSourceStats ) where++import Bag+import HsSyn+import Outputable+import RdrName+import SrcLoc+import Util++import Data.Char+import Data.Foldable (foldl')++-- | Source Statistics+ppSourceStats :: Bool -> Located (HsModule RdrName) -> SDoc+ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))+  = (if short then hcat else vcat)+        (map pp_val+            [("ExportAll        ", export_all), -- 1 if no export list+             ("ExportDecls      ", export_ds),+             ("ExportModules    ", export_ms),+             ("Imports          ", imp_no),+             ("  ImpSafe        ", imp_safe),+             ("  ImpQual        ", imp_qual),+             ("  ImpAs          ", imp_as),+             ("  ImpAll         ", imp_all),+             ("  ImpPartial     ", imp_partial),+             ("  ImpHiding      ", imp_hiding),+             ("FixityDecls      ", fixity_sigs),+             ("DefaultDecls     ", default_ds),+             ("TypeDecls        ", type_ds),+             ("DataDecls        ", data_ds),+             ("NewTypeDecls     ", newt_ds),+             ("TypeFamilyDecls  ", type_fam_ds),+             ("DataConstrs      ", data_constrs),+             ("DataDerivings    ", data_derivs),+             ("ClassDecls       ", class_ds),+             ("ClassMethods     ", class_method_ds),+             ("DefaultMethods   ", default_method_ds),+             ("InstDecls        ", inst_ds),+             ("InstMethods      ", inst_method_ds),+             ("InstType         ", inst_type_ds),+             ("InstData         ", inst_data_ds),+             ("TypeSigs         ", bind_tys),+             ("ClassOpSigs      ", generic_sigs),+             ("ValBinds         ", val_bind_ds),+             ("FunBinds         ", fn_bind_ds),+             ("PatSynBinds      ", patsyn_ds),+             ("InlineMeths      ", method_inlines),+             ("InlineBinds      ", bind_inlines),+             ("SpecialisedMeths ", method_specs),+             ("SpecialisedBinds ", bind_specs)+            ])+  where+    decls = map unLoc ldecls++    pp_val (_, 0) = empty+    pp_val (str, n)+      | not short   = hcat [text str, int n]+      | otherwise   = hcat [text (trim str), equals, int n, semi]++    trim ls    = takeWhile (not.isSpace) (dropWhile isSpace ls)++    (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs)+        = count_sigs [d | SigD d <- decls]+                -- NB: this omits fixity decls on local bindings and+                -- in class decls. ToDo++    tycl_decls = [d | TyClD d <- decls]+    (class_ds, type_ds, data_ds, newt_ds, type_fam_ds) =+      countTyClDecls tycl_decls++    inst_decls = [d | InstD d <- decls]+    inst_ds    = length inst_decls+    default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls+    val_decls  = [d | ValD d <- decls]++    real_exports = case exports of { Nothing -> []; Just (L _ es) -> es }+    n_exports    = length real_exports+    export_ms    = count (\ e -> case unLoc e of { IEModuleContents{} -> True;_ -> False})+                         real_exports+    export_ds    = n_exports - export_ms+    export_all   = case exports of { Nothing -> 1; _ -> 0 }++    (val_bind_ds, fn_bind_ds, patsyn_ds)+        = sum3 (map count_bind val_decls)++    (imp_no, imp_safe, imp_qual, imp_as, imp_all, imp_partial, imp_hiding)+        = sum7 (map import_info imports)+    (data_constrs, data_derivs)+        = sum2 (map data_info tycl_decls)+    (class_method_ds, default_method_ds)+        = sum2 (map class_info tycl_decls)+    (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds)+        = sum5 (map inst_info inst_decls)++    count_bind (PatBind { pat_lhs = L _ (VarPat _) }) = (1,0,0)+    count_bind (PatBind {})                           = (0,1,0)+    count_bind (FunBind {})                           = (0,1,0)+    count_bind (PatSynBind {})                        = (0,0,1)+    count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b)++    count_sigs sigs = sum5 (map sig_info sigs)++    sig_info (FixSig {})     = (1,0,0,0,0)+    sig_info (TypeSig {})    = (0,1,0,0,0)+    sig_info (SpecSig {})    = (0,0,1,0,0)+    sig_info (InlineSig {})  = (0,0,0,1,0)+    sig_info (ClassOpSig {}) = (0,0,0,0,1)+    sig_info _               = (0,0,0,0,0)++    import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual+                                 , ideclAs = as, ideclHiding = spec }))+        = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec)+    safe_info = qual_info+    qual_info False  = 0+    qual_info True   = 1+    as_info Nothing  = 0+    as_info (Just _) = 1+    spec_info Nothing           = (0,0,0,0,1,0,0)+    spec_info (Just (False, _)) = (0,0,0,0,0,1,0)+    spec_info (Just (True, _))  = (0,0,0,0,0,0,1)++    data_info (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = cs+                                                   , dd_derivs = L _ derivs}})+        = ( length cs+          , foldl' (\s dc -> length (deriv_clause_tys $ unLoc dc) + s)+                   0 derivs )+    data_info _ = (0,0)++    class_info decl@(ClassDecl {})+        = (classops, addpr (sum3 (map count_bind methods)))+      where+        methods = map unLoc $ bagToList (tcdMeths decl)+        (_, classops, _, _, _) = count_sigs (map unLoc (tcdSigs decl))+    class_info _ = (0,0)++    inst_info (TyFamInstD {}) = (0,0,0,1,0)+    inst_info (DataFamInstD {}) = (0,0,0,0,1)+    inst_info (ClsInstD { cid_inst = ClsInstDecl {cid_binds = inst_meths+                                                 , cid_sigs = inst_sigs+                                                 , cid_tyfam_insts = ats+                                                 , cid_datafam_insts = adts } })+        = case count_sigs (map unLoc inst_sigs) of+            (_,_,ss,is,_) ->+                  (addpr (sum3 (map count_bind methods)),+                   ss, is, length ats, length adts)+      where+        methods = map unLoc $ bagToList inst_meths++    -- TODO: use Sum monoid+    addpr :: (Int,Int,Int) -> Int+    sum2 :: [(Int, Int)] -> (Int, Int)+    sum3 :: [(Int, Int, Int)] -> (Int, Int, Int)+    sum5 :: [(Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int)+    sum7 :: [(Int, Int, Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int, Int, Int)+    add7 :: (Int, Int, Int, Int, Int, Int, Int) -> (Int, Int, Int, Int, Int, Int, Int)+         -> (Int, Int, Int, Int, Int, Int, Int)++    addpr (x,y,z) = x+y+z+    sum2 = foldr add2 (0,0)+      where+        add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2)+    sum3 = foldr add3 (0,0,0)+      where+        add3 (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3)+    sum5 = foldr add5 (0,0,0,0,0)+      where+        add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5)+    sum7 = foldr add7 (0,0,0,0,0,0,0)++    add7 (x1,x2,x3,x4,x5,x6,x7) (y1,y2,y3,y4,y5,y6,y7) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6,x7+y7)+
+ main/HscTypes.hs view
@@ -0,0 +1,3115 @@+{-+(c) The University of Glasgow, 2006++\section[HscTypes]{Types for the per-module compiler}+-}++{-# LANGUAGE CPP, ScopedTypeVariables #-}++-- | Types for the per-module compiler+module HscTypes (+        -- * compilation state+        HscEnv(..), hscEPS,+        FinderCache, FindResult(..), InstalledFindResult(..),+        Target(..), TargetId(..), pprTarget, pprTargetId,+        ModuleGraph, emptyMG,+        HscStatus(..),+        IServ(..),++        -- * Hsc monad+        Hsc(..), runHsc, runInteractiveHsc,++        -- * Information about modules+        ModDetails(..), emptyModDetails,+        ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC,+        ImportedMods, ImportedBy(..), importedByUser, ImportedModsVal(..), SptEntry(..),+        ForeignSrcLang(..),++        ModSummary(..), ms_imps, ms_installed_mod, ms_mod_name, showModMsg, isBootSummary,+        msHsFilePath, msHiFilePath, msObjFilePath,+        SourceModified(..),++        -- * Information about the module being compiled+        -- (re-exported from DriverPhases)+        HscSource(..), isHsBootOrSig, hscSourceString,+++        -- * State relating to modules in this package+        HomePackageTable, HomeModInfo(..), emptyHomePackageTable,+        lookupHpt, eltsHpt, filterHpt, allHpt, mapHpt, delFromHpt,+        addToHpt, addListToHpt, lookupHptDirectly, listToHpt,+        hptCompleteSigs,+        hptInstances, hptRules, hptVectInfo, pprHPT,+        hptObjs,++        -- * State relating to known packages+        ExternalPackageState(..), EpsStats(..), addEpsInStats,+        PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable,+        lookupIfaceByModule, emptyModIface, lookupHptByModule,++        PackageInstEnv, PackageFamInstEnv, PackageRuleBase,+        PackageCompleteMatchMap,++        mkSOName, mkHsSOName, soExt,++        -- * Metaprogramming+        MetaRequest(..),+        MetaResult, -- data constructors not exported to ensure correct response type+        metaRequestE, metaRequestP, metaRequestT, metaRequestD, metaRequestAW,+        MetaHook,++        -- * Annotations+        prepareAnnotations,++        -- * Interactive context+        InteractiveContext(..), emptyInteractiveContext,+        icPrintUnqual, icInScopeTTs, icExtendGblRdrEnv,+        extendInteractiveContext, extendInteractiveContextWithIds,+        substInteractiveContext,+        setInteractivePrintName, icInteractiveModule,+        InteractiveImport(..), setInteractivePackage,+        mkPrintUnqualified, pprModulePrefix,+        mkQualPackage, mkQualModule, pkgQual,++        -- * Interfaces+        ModIface(..), mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache,+        emptyIfaceWarnCache, mi_boot, mi_fix,+        mi_semantic_module,+        mi_free_holes,+        renameFreeHoles,++        -- * Fixity+        FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv,++        -- * TyThings and type environments+        TyThing(..),  tyThingAvailInfo,+        tyThingTyCon, tyThingDataCon, tyThingConLike,+        tyThingId, tyThingCoAxiom, tyThingParent_maybe, tyThingsTyCoVars,+        implicitTyThings, implicitTyConThings, implicitClassThings,+        isImplicitTyThing,++        TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv,+        typeEnvFromEntities, mkTypeEnvWithImplicits,+        extendTypeEnv, extendTypeEnvList,+        extendTypeEnvWithIds, plusTypeEnv,+        lookupTypeEnv,+        typeEnvElts, typeEnvTyCons, typeEnvIds, typeEnvPatSyns,+        typeEnvDataCons, typeEnvCoAxioms, typeEnvClasses,++        -- * MonadThings+        MonadThings(..),++        -- * Information on imports and exports+        WhetherHasOrphans, IsBootInterface, Usage(..),+        Dependencies(..), noDependencies,+        updNameCacheIO,+        IfaceExport,++        -- * Warnings+        Warnings(..), WarningTxt(..), plusWarns,++        -- * Linker stuff+        Linkable(..), isObjectLinkable, linkableObjs,+        Unlinked(..), CompiledByteCode,+        isObject, nameOfObject, isInterpretable, byteCodeOfObject,++        -- * Program coverage+        HpcInfo(..), emptyHpcInfo, isHpcUsed, AnyHpcUsage,++        -- * Breakpoints+        ModBreaks (..), emptyModBreaks,++        -- * Vectorisation information+        VectInfo(..), IfaceVectInfo(..), noVectInfo, plusVectInfo,+        noIfaceVectInfo, isNoIfaceVectInfo,++        -- * Safe Haskell information+        IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo,+        trustInfoToNum, numToTrustInfo, IsSafeImport,++        -- * result of the parser+        HsParsedModule(..),++        -- * Compilation errors and warnings+        SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr,+        throwOneError, handleSourceError,+        handleFlagWarnings, printOrThrowWarnings,++        -- * COMPLETE signature+        CompleteMatch(..), CompleteMatchMap,+        mkCompleteMatchMap, extendCompleteMatchMap+    ) where++#include "HsVersions.h"++import ByteCodeTypes+import InteractiveEvalTypes ( Resume )+import GHCi.Message         ( Pipe )+import GHCi.RemoteTypes+import GHC.ForeignSrcLang++import UniqFM+import HsSyn+import RdrName+import Avail+import Module+import InstEnv          ( InstEnv, ClsInst, identicalClsInstHead )+import FamInstEnv+import CoreSyn          ( CoreProgram, RuleBase, CoreRule, CoreVect )+import Name+import NameEnv+import NameSet+import VarEnv+import VarSet+import Var+import Id+import IdInfo           ( IdDetails(..), RecSelParent(..))+import Type++import ApiAnnotation    ( ApiAnns )+import Annotations      ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv )+import Class+import TyCon+import CoAxiom+import ConLike+import DataCon+import PatSyn+import PrelNames        ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule+                        , eqTyConName )+import TysWiredIn+import Packages hiding  ( Version(..) )+import DynFlags+import DriverPhases     ( Phase, HscSource(..), isHsBootOrSig, hscSourceString )+import BasicTypes+import IfaceSyn+import Maybes+import Outputable+import SrcLoc+import Unique+import UniqDFM+import FastString+import StringBuffer     ( StringBuffer )+import Fingerprint+import MonadUtils+import Bag+import Binary+import ErrUtils+import NameCache+import Platform+import Util+import UniqDSet+import GHC.Serialized   ( Serialized )++import Foreign+import Control.Monad    ( guard, liftM, when, ap )+import Data.Foldable    ( foldl' )+import Data.IORef+import Data.Time+import Exception+import System.FilePath+import Control.Concurrent+import System.Process   ( ProcessHandle )++-- -----------------------------------------------------------------------------+-- Compilation state+-- -----------------------------------------------------------------------------++-- | Status of a compilation to hard-code+data HscStatus+    = HscNotGeneratingCode+    | HscUpToDate+    | HscUpdateBoot+    | HscUpdateSig+    | HscRecomp CgGuts ModSummary++-- -----------------------------------------------------------------------------+-- The Hsc monad: Passing an environment and warning state++newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages))++instance Functor Hsc where+    fmap = liftM++instance Applicative Hsc where+    pure a = Hsc $ \_ w -> return (a, w)+    (<*>) = ap++instance Monad Hsc where+    Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w+                                   case k a of+                                       Hsc k' -> k' e w1++instance MonadIO Hsc where+    liftIO io = Hsc $ \_ w -> do a <- io; return (a, w)++instance HasDynFlags Hsc where+    getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w)++runHsc :: HscEnv -> Hsc a -> IO a+runHsc hsc_env (Hsc hsc) = do+    (a, w) <- hsc hsc_env emptyBag+    printOrThrowWarnings (hsc_dflags hsc_env) w+    return a++runInteractiveHsc :: HscEnv -> Hsc a -> IO a+-- A variant of runHsc that switches in the DynFlags from the+-- InteractiveContext before running the Hsc computation.+runInteractiveHsc hsc_env+  = runHsc (hsc_env { hsc_dflags = interactive_dflags })+  where+    interactive_dflags = ic_dflags (hsc_IC hsc_env)++-- -----------------------------------------------------------------------------+-- Source Errors++-- When the compiler (HscMain) discovers errors, it throws an+-- exception in the IO monad.++mkSrcErr :: ErrorMessages -> SourceError+mkSrcErr = SourceError++srcErrorMessages :: SourceError -> ErrorMessages+srcErrorMessages (SourceError msgs) = msgs++mkApiErr :: DynFlags -> SDoc -> GhcApiError+mkApiErr dflags msg = GhcApiError (showSDoc dflags msg)++throwOneError :: MonadIO m => ErrMsg -> m ab+throwOneError err = liftIO $ throwIO $ mkSrcErr $ unitBag err++-- | A source error is an error that is caused by one or more errors in the+-- source code.  A 'SourceError' is thrown by many functions in the+-- compilation pipeline.  Inside GHC these errors are merely printed via+-- 'log_action', but API clients may treat them differently, for example,+-- insert them into a list box.  If you want the default behaviour, use the+-- idiom:+--+-- > handleSourceError printExceptionAndWarnings $ do+-- >   ... api calls that may fail ...+--+-- The 'SourceError's error messages can be accessed via 'srcErrorMessages'.+-- This list may be empty if the compiler failed due to @-Werror@+-- ('Opt_WarnIsError').+--+-- See 'printExceptionAndWarnings' for more information on what to take care+-- of when writing a custom error handler.+newtype SourceError = SourceError ErrorMessages++instance Show SourceError where+  show (SourceError msgs) = unlines . map show . bagToList $ msgs++instance Exception SourceError++-- | Perform the given action and call the exception handler if the action+-- throws a 'SourceError'.  See 'SourceError' for more information.+handleSourceError :: (ExceptionMonad m) =>+                     (SourceError -> m a) -- ^ exception handler+                  -> m a -- ^ action to perform+                  -> m a+handleSourceError handler act =+  gcatch act (\(e :: SourceError) -> handler e)++-- | An error thrown if the GHC API is used in an incorrect fashion.+newtype GhcApiError = GhcApiError String++instance Show GhcApiError where+  show (GhcApiError msg) = msg++instance Exception GhcApiError++-- | Given a bag of warnings, turn them into an exception if+-- -Werror is enabled, or print them out otherwise.+printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO ()+printOrThrowWarnings dflags warns+  | anyBag (isWarnMsgFatal dflags) warns+  = throwIO $ mkSrcErr $ warns `snocBag` warnIsErrorMsg dflags+  | otherwise+  = printBagOfErrors dflags warns++handleFlagWarnings :: DynFlags -> [Located String] -> IO ()+handleFlagWarnings dflags warns+ = when (wopt Opt_WarnDeprecatedFlags dflags) $ do+        -- It would be nicer if warns :: [Located MsgDoc], but that+        -- has circular import problems.+      let bag = listToBag [ mkPlainWarnMsg dflags loc (text warn)+                          | L loc warn <- warns ]++      printOrThrowWarnings dflags bag++{-+************************************************************************+*                                                                      *+\subsection{HscEnv}+*                                                                      *+************************************************************************+-}++-- | HscEnv is like 'Session', except that some of the fields are immutable.+-- An HscEnv is used to compile a single module from plain Haskell source+-- code (after preprocessing) to either C, assembly or C--.  Things like+-- the module graph don't change during a single compilation.+--+-- Historical note: \"hsc\" used to be the name of the compiler binary,+-- when there was a separate driver and compiler.  To compile a single+-- module, the driver would invoke hsc on the source code... so nowadays+-- we think of hsc as the layer of the compiler that deals with compiling+-- a single module.+data HscEnv+  = HscEnv {+        hsc_dflags :: DynFlags,+                -- ^ The dynamic flag settings++        hsc_targets :: [Target],+                -- ^ The targets (or roots) of the current session++        hsc_mod_graph :: ModuleGraph,+                -- ^ The module graph of the current session++        hsc_IC :: InteractiveContext,+                -- ^ The context for evaluating interactive statements++        hsc_HPT    :: HomePackageTable,+                -- ^ The home package table describes already-compiled+                -- home-package modules, /excluding/ the module we+                -- are compiling right now.+                -- (In one-shot mode the current module is the only+                -- home-package module, so hsc_HPT is empty.  All other+                -- modules count as \"external-package\" modules.+                -- However, even in GHCi mode, hi-boot interfaces are+                -- demand-loaded into the external-package table.)+                --+                -- 'hsc_HPT' is not mutable because we only demand-load+                -- external packages; the home package is eagerly+                -- loaded, module by module, by the compilation manager.+                --+                -- The HPT may contain modules compiled earlier by @--make@+                -- but not actually below the current module in the dependency+                -- graph.+                --+                -- (This changes a previous invariant: changed Jan 05.)++        hsc_EPS :: {-# UNPACK #-} !(IORef ExternalPackageState),+                -- ^ Information about the currently loaded external packages.+                -- This is mutable because packages will be demand-loaded during+                -- a compilation run as required.++        hsc_NC  :: {-# UNPACK #-} !(IORef NameCache),+                -- ^ As with 'hsc_EPS', this is side-effected by compiling to+                -- reflect sucking in interface files.  They cache the state of+                -- external interface files, in effect.++        hsc_FC   :: {-# UNPACK #-} !(IORef FinderCache),+                -- ^ The cached result of performing finding in the file system++        hsc_type_env_var :: Maybe (Module, IORef TypeEnv)+                -- ^ Used for one-shot compilation only, to initialise+                -- the 'IfGblEnv'. See 'TcRnTypes.tcg_type_env_var' for+                -- 'TcRnTypes.TcGblEnv'.  See also Note [hsc_type_env_var hack]++        , hsc_iserv :: MVar (Maybe IServ)+                -- ^ interactive server process.  Created the first+                -- time it is needed.+ }++-- Note [hsc_type_env_var hack]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- hsc_type_env_var is used to initialize tcg_type_env_var, and+-- eventually it is the mutable variable that is queried from+-- if_rec_types to get a TypeEnv.  So, clearly, it's something+-- related to knot-tying (see Note [Tying the knot]).+-- hsc_type_env_var is used in two places: initTcRn (where+-- it initializes tcg_type_env_var) and initIfaceCheck+-- (where it initializes if_rec_types).+--+-- But why do we need a way to feed a mutable variable in?  Why+-- can't we just initialize tcg_type_env_var when we start+-- typechecking?  The problem is we need to knot-tie the+-- EPS, and we may start adding things to the EPS before type+-- checking starts.+--+-- Here is a concrete example. Suppose we are running+-- "ghc -c A.hs", and we have this file system state:+--+--  A.hs-boot   A.hi-boot **up to date**+--  B.hs        B.hi      **up to date**+--  A.hs        A.hi      **stale**+--+-- The first thing we do is run checkOldIface on A.hi.+-- checkOldIface will call loadInterface on B.hi so it can+-- get its hands on the fingerprints, to find out if A.hi+-- needs recompilation.  But loadInterface also populates+-- the EPS!  And so if compilation turns out to be necessary,+-- as it is in this case, the thunks we put into the EPS for+-- B.hi need to have the correct if_rec_types mutable variable+-- to query.+--+-- If the mutable variable is only allocated WHEN we start+-- typechecking, then that's too late: we can't get the+-- information to the thunks.  So we need to pre-commit+-- to a type variable in 'hscIncrementalCompile' BEFORE we+-- check the old interface.+--+-- This is all a massive hack because arguably checkOldIface+-- should not populate the EPS. But that's a refactor for+-- another day.+++data IServ = IServ+  { iservPipe :: Pipe+  , iservProcess :: ProcessHandle+  , iservLookupSymbolCache :: IORef (UniqFM (Ptr ()))+  , iservPendingFrees :: [HValueRef]+  }++-- | Retrieve the ExternalPackageState cache.+hscEPS :: HscEnv -> IO ExternalPackageState+hscEPS hsc_env = readIORef (hsc_EPS hsc_env)++-- | A compilation target.+--+-- A target may be supplied with the actual text of the+-- module.  If so, use this instead of the file contents (this+-- is for use in an IDE where the file hasn't been saved by+-- the user yet).+data Target+  = Target {+      targetId           :: TargetId, -- ^ module or filename+      targetAllowObjCode :: Bool,     -- ^ object code allowed?+      targetContents     :: Maybe (StringBuffer,UTCTime)+                                        -- ^ in-memory text buffer?+    }++data TargetId+  = TargetModule ModuleName+        -- ^ A module name: search for the file+  | TargetFile FilePath (Maybe Phase)+        -- ^ A filename: preprocess & parse it to find the module name.+        -- If specified, the Phase indicates how to compile this file+        -- (which phase to start from).  Nothing indicates the starting phase+        -- should be determined from the suffix of the filename.+  deriving Eq++pprTarget :: Target -> SDoc+pprTarget (Target id obj _) =+    (if obj then char '*' else empty) <> pprTargetId id++instance Outputable Target where+    ppr = pprTarget++pprTargetId :: TargetId -> SDoc+pprTargetId (TargetModule m) = ppr m+pprTargetId (TargetFile f _) = text f++instance Outputable TargetId where+    ppr = pprTargetId++{-+************************************************************************+*                                                                      *+\subsection{Package and Module Tables}+*                                                                      *+************************************************************************+-}++-- | Helps us find information about modules in the home package+type HomePackageTable  = DModuleNameEnv HomeModInfo+        -- Domain = modules in the home package that have been fully compiled+        -- "home" unit id cached here for convenience++-- | Helps us find information about modules in the imported packages+type PackageIfaceTable = ModuleEnv ModIface+        -- Domain = modules in the imported packages++-- | Constructs an empty HomePackageTable+emptyHomePackageTable :: HomePackageTable+emptyHomePackageTable  = emptyUDFM++-- | Constructs an empty PackageIfaceTable+emptyPackageIfaceTable :: PackageIfaceTable+emptyPackageIfaceTable = emptyModuleEnv++pprHPT :: HomePackageTable -> SDoc+-- A bit arbitrary for now+pprHPT hpt = pprUDFM hpt $ \hms ->+    vcat [ hang (ppr (mi_module (hm_iface hm)))+              2 (ppr (md_types (hm_details hm)))+         | hm <- hms ]++lookupHpt :: HomePackageTable -> ModuleName -> Maybe HomeModInfo+lookupHpt = lookupUDFM++lookupHptDirectly :: HomePackageTable -> Unique -> Maybe HomeModInfo+lookupHptDirectly = lookupUDFM_Directly++eltsHpt :: HomePackageTable -> [HomeModInfo]+eltsHpt = eltsUDFM++filterHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> HomePackageTable+filterHpt = filterUDFM++allHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool+allHpt = allUDFM++mapHpt :: (HomeModInfo -> HomeModInfo) -> HomePackageTable -> HomePackageTable+mapHpt = mapUDFM++delFromHpt :: HomePackageTable -> ModuleName -> HomePackageTable+delFromHpt = delFromUDFM++addToHpt :: HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable+addToHpt = addToUDFM++addListToHpt+  :: HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable+addListToHpt = addListToUDFM++listToHpt :: [(ModuleName, HomeModInfo)] -> HomePackageTable+listToHpt = listToUDFM++lookupHptByModule :: HomePackageTable -> Module -> Maybe HomeModInfo+-- The HPT is indexed by ModuleName, not Module,+-- we must check for a hit on the right Module+lookupHptByModule hpt mod+  = case lookupHpt hpt (moduleName mod) of+      Just hm | mi_module (hm_iface hm) == mod -> Just hm+      _otherwise                               -> Nothing++-- | Information about modules in the package being compiled+data HomeModInfo+  = HomeModInfo {+      hm_iface    :: !ModIface,+        -- ^ The basic loaded interface file: every loaded module has one of+        -- these, even if it is imported from another package+      hm_details  :: !ModDetails,+        -- ^ Extra information that has been created from the 'ModIface' for+        -- the module, typically during typechecking+      hm_linkable :: !(Maybe Linkable)+        -- ^ The actual artifact we would like to link to access things in+        -- this module.+        --+        -- 'hm_linkable' might be Nothing:+        --+        --   1. If this is an .hs-boot module+        --+        --   2. Temporarily during compilation if we pruned away+        --      the old linkable because it was out of date.+        --+        -- After a complete compilation ('GHC.load'), all 'hm_linkable' fields+        -- in the 'HomePackageTable' will be @Just@.+        --+        -- When re-linking a module ('HscMain.HscNoRecomp'), we construct the+        -- 'HomeModInfo' by building a new 'ModDetails' from the old+        -- 'ModIface' (only).+    }++-- | Find the 'ModIface' for a 'Module', searching in both the loaded home+-- and external package module information+lookupIfaceByModule+        :: DynFlags+        -> HomePackageTable+        -> PackageIfaceTable+        -> Module+        -> Maybe ModIface+lookupIfaceByModule _dflags hpt pit mod+  = case lookupHptByModule hpt mod of+       Just hm -> Just (hm_iface hm)+       Nothing -> lookupModuleEnv pit mod++-- If the module does come from the home package, why do we look in the PIT as well?+-- (a) In OneShot mode, even home-package modules accumulate in the PIT+-- (b) Even in Batch (--make) mode, there is *one* case where a home-package+--     module is in the PIT, namely GHC.Prim when compiling the base package.+-- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package+-- of its own, but it doesn't seem worth the bother.++hptCompleteSigs :: HscEnv -> [CompleteMatch]+hptCompleteSigs = hptAllThings  (md_complete_sigs . hm_details)++-- | Find all the instance declarations (of classes and families) from+-- the Home Package Table filtered by the provided predicate function.+-- Used in @tcRnImports@, to select the instances that are in the+-- transitive closure of imports from the currently compiled module.+hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst])+hptInstances hsc_env want_this_module+  = let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do+                guard (want_this_module (moduleName (mi_module (hm_iface mod_info))))+                let details = hm_details mod_info+                return (md_insts details, md_fam_insts details)+    in (concat insts, concat famInsts)++-- | Get the combined VectInfo of all modules in the home package table. In+-- contrast to instances and rules, we don't care whether the modules are+-- "below" us in the dependency sense. The VectInfo of those modules not "below"+-- us does not affect the compilation of the current module.+hptVectInfo :: HscEnv -> VectInfo+hptVectInfo = concatVectInfo . hptAllThings ((: []) . md_vect_info . hm_details)++-- | Get rules from modules "below" this one (in the dependency sense)+hptRules :: HscEnv -> [(ModuleName, IsBootInterface)] -> [CoreRule]+hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False+++-- | Get annotations from modules "below" this one (in the dependency sense)+hptAnns :: HscEnv -> Maybe [(ModuleName, IsBootInterface)] -> [Annotation]+hptAnns hsc_env (Just deps) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env deps+hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env++hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a]+hptAllThings extract hsc_env = concatMap extract (eltsHpt (hsc_HPT hsc_env))++-- | Get things from modules "below" this one (in the dependency sense)+-- C.f Inst.hptInstances+hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> [(ModuleName, IsBootInterface)] -> [a]+hptSomeThingsBelowUs extract include_hi_boot hsc_env deps+  | isOneShot (ghcMode (hsc_dflags hsc_env)) = []++  | otherwise+  = let hpt = hsc_HPT hsc_env+    in+    [ thing+    |   -- Find each non-hi-boot module below me+      (mod, is_boot_mod) <- deps+    , include_hi_boot || not is_boot_mod++        -- unsavoury: when compiling the base package with --make, we+        -- sometimes try to look up RULES etc for GHC.Prim. GHC.Prim won't+        -- be in the HPT, because we never compile it; it's in the EPT+        -- instead. ToDo: clean up, and remove this slightly bogus filter:+    , mod /= moduleName gHC_PRIM++        -- Look it up in the HPT+    , let things = case lookupHpt hpt mod of+                    Just info -> extract info+                    Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg []+          msg = vcat [text "missing module" <+> ppr mod,+                      text "Probable cause: out-of-date interface files"]+                        -- This really shouldn't happen, but see Trac #962++        -- And get its dfuns+    , thing <- things ]++hptObjs :: HomePackageTable -> [FilePath]+hptObjs hpt = concat (map (maybe [] linkableObjs . hm_linkable) (eltsHpt hpt))++{-+************************************************************************+*                                                                      *+\subsection{Metaprogramming}+*                                                                      *+************************************************************************+-}++-- | The supported metaprogramming result types+data MetaRequest+  = MetaE  (LHsExpr RdrName   -> MetaResult)+  | MetaP  (LPat RdrName      -> MetaResult)+  | MetaT  (LHsType RdrName   -> MetaResult)+  | MetaD  ([LHsDecl RdrName] -> MetaResult)+  | MetaAW (Serialized        -> MetaResult)++-- | data constructors not exported to ensure correct result type+data MetaResult+  = MetaResE  { unMetaResE  :: LHsExpr RdrName   }+  | MetaResP  { unMetaResP  :: LPat RdrName      }+  | MetaResT  { unMetaResT  :: LHsType RdrName   }+  | MetaResD  { unMetaResD  :: [LHsDecl RdrName] }+  | MetaResAW { unMetaResAW :: Serialized        }++type MetaHook f = MetaRequest -> LHsExpr Id -> f MetaResult++metaRequestE :: Functor f => MetaHook f -> LHsExpr Id -> f (LHsExpr RdrName)+metaRequestE h = fmap unMetaResE . h (MetaE MetaResE)++metaRequestP :: Functor f => MetaHook f -> LHsExpr Id -> f (LPat RdrName)+metaRequestP h = fmap unMetaResP . h (MetaP MetaResP)++metaRequestT :: Functor f => MetaHook f -> LHsExpr Id -> f (LHsType RdrName)+metaRequestT h = fmap unMetaResT . h (MetaT MetaResT)++metaRequestD :: Functor f => MetaHook f -> LHsExpr Id -> f [LHsDecl RdrName]+metaRequestD h = fmap unMetaResD . h (MetaD MetaResD)++metaRequestAW :: Functor f => MetaHook f -> LHsExpr Id -> f Serialized+metaRequestAW h = fmap unMetaResAW . h (MetaAW MetaResAW)++{-+************************************************************************+*                                                                      *+\subsection{Dealing with Annotations}+*                                                                      *+************************************************************************+-}++-- | Deal with gathering annotations in from all possible places+--   and combining them into a single 'AnnEnv'+prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv+prepareAnnotations hsc_env mb_guts = do+    eps <- hscEPS hsc_env+    let -- Extract annotations from the module being compiled if supplied one+        mb_this_module_anns = fmap (mkAnnEnv . mg_anns) mb_guts+        -- Extract dependencies of the module if we are supplied one,+        -- otherwise load annotations from all home package table+        -- entries regardless of dependency ordering.+        home_pkg_anns  = (mkAnnEnv . hptAnns hsc_env) $ fmap (dep_mods . mg_deps) mb_guts+        other_pkg_anns = eps_ann_env eps+        ann_env        = foldl1' plusAnnEnv $ catMaybes [mb_this_module_anns,+                                                         Just home_pkg_anns,+                                                         Just other_pkg_anns]+    return ann_env++{-+************************************************************************+*                                                                      *+\subsection{The Finder cache}+*                                                                      *+************************************************************************+-}++-- | The 'FinderCache' maps modules to the result of+-- searching for that module. It records the results of searching for+-- modules along the search path. On @:load@, we flush the entire+-- contents of this cache.+--+type FinderCache = InstalledModuleEnv InstalledFindResult++data InstalledFindResult+  = InstalledFound ModLocation InstalledModule+  | InstalledNoPackage InstalledUnitId+  | InstalledNotFound [FilePath] (Maybe InstalledUnitId)++-- | The result of searching for an imported module.+--+-- NB: FindResult manages both user source-import lookups+-- (which can result in 'Module') as well as direct imports+-- for interfaces (which always result in 'InstalledModule').+data FindResult+  = Found ModLocation Module+        -- ^ The module was found+  | NoPackage UnitId+        -- ^ The requested package was not found+  | FoundMultiple [(Module, ModuleOrigin)]+        -- ^ _Error_: both in multiple packages++        -- | Not found+  | NotFound+      { fr_paths       :: [FilePath]       -- Places where I looked++      , fr_pkg         :: Maybe UnitId  -- Just p => module is in this package's+                                           --           manifest, but couldn't find+                                           --           the .hi file++      , fr_mods_hidden :: [UnitId]      -- Module is in these packages,+                                           --   but the *module* is hidden++      , fr_pkgs_hidden :: [UnitId]      -- Module is in these packages,+                                           --   but the *package* is hidden++      , fr_suggestions :: [ModuleSuggestion] -- Possible mis-spelled modules+      }++{-+************************************************************************+*                                                                      *+\subsection{Symbol tables and Module details}+*                                                                      *+************************************************************************+-}++-- | A 'ModIface' plus a 'ModDetails' summarises everything we know+-- about a compiled module.  The 'ModIface' is the stuff *before* linking,+-- and can be written out to an interface file. The 'ModDetails is after+-- linking and can be completely recovered from just the 'ModIface'.+--+-- When we read an interface file, we also construct a 'ModIface' from it,+-- except that we explicitly make the 'mi_decls' and a few other fields empty;+-- as when reading we consolidate the declarations etc. into a number of indexed+-- maps and environments in the 'ExternalPackageState'.+data ModIface+  = ModIface {+        mi_module     :: !Module,             -- ^ Name of the module we are for+        mi_sig_of     :: !(Maybe Module),     -- ^ Are we a sig of another mod?+        mi_iface_hash :: !Fingerprint,        -- ^ Hash of the whole interface+        mi_mod_hash   :: !Fingerprint,        -- ^ Hash of the ABI only+        mi_flag_hash  :: !Fingerprint,        -- ^ Hash of the important flags+                                              -- used when compiling this module++        mi_orphan     :: !WhetherHasOrphans,  -- ^ Whether this module has orphans+        mi_finsts     :: !WhetherHasFamInst,+                -- ^ Whether this module has family instances.+                -- See Note [The type family instance consistency story].+        mi_hsc_src    :: !HscSource,          -- ^ Boot? Signature?++        mi_deps     :: Dependencies,+                -- ^ The dependencies of the module.  This is+                -- consulted for directly-imported modules, but not+                -- for anything else (hence lazy)++        mi_usages   :: [Usage],+                -- ^ Usages; kept sorted so that it's easy to decide+                -- whether to write a new iface file (changing usages+                -- doesn't affect the hash of this module)+                -- NOT STRICT!  we read this field lazily from the interface file+                -- It is *only* consulted by the recompilation checker++        mi_exports  :: ![IfaceExport],+                -- ^ Exports+                -- Kept sorted by (mod,occ), to make version comparisons easier+                -- Records the modules that are the declaration points for things+                -- exported by this module, and the 'OccName's of those things++        mi_exp_hash :: !Fingerprint,+                -- ^ Hash of export list++        mi_used_th  :: !Bool,+                -- ^ Module required TH splices when it was compiled.+                -- This disables recompilation avoidance (see #481).++        mi_fixities :: [(OccName,Fixity)],+                -- ^ Fixities+                -- NOT STRICT!  we read this field lazily from the interface file++        mi_warns    :: Warnings,+                -- ^ Warnings+                -- NOT STRICT!  we read this field lazily from the interface file++        mi_anns     :: [IfaceAnnotation],+                -- ^ Annotations+                -- NOT STRICT!  we read this field lazily from the interface file+++        mi_decls    :: [(Fingerprint,IfaceDecl)],+                -- ^ Type, class and variable declarations+                -- The hash of an Id changes if its fixity or deprecations change+                --      (as well as its type of course)+                -- Ditto data constructors, class operations, except that+                -- the hash of the parent class/tycon changes++        mi_globals  :: !(Maybe GlobalRdrEnv),+                -- ^ Binds all the things defined at the top level in+                -- the /original source/ code for this module. which+                -- is NOT the same as mi_exports, nor mi_decls (which+                -- may contains declarations for things not actually+                -- defined by the user).  Used for GHCi and for inspecting+                -- the contents of modules via the GHC API only.+                --+                -- (We need the source file to figure out the+                -- top-level environment, if we didn't compile this module+                -- from source then this field contains @Nothing@).+                --+                -- Strictly speaking this field should live in the+                -- 'HomeModInfo', but that leads to more plumbing.++                -- Instance declarations and rules+        mi_insts       :: [IfaceClsInst],     -- ^ Sorted class instance+        mi_fam_insts   :: [IfaceFamInst],  -- ^ Sorted family instances+        mi_rules       :: [IfaceRule],     -- ^ Sorted rules+        mi_orphan_hash :: !Fingerprint,    -- ^ Hash for orphan rules, class and family+                                           -- instances, and vectorise pragmas combined++        mi_vect_info :: !IfaceVectInfo,    -- ^ Vectorisation information++                -- Cached environments for easy lookup+                -- These are computed (lazily) from other fields+                -- and are not put into the interface file+        mi_warn_fn   :: OccName -> Maybe WarningTxt,+                -- ^ Cached lookup for 'mi_warns'+        mi_fix_fn    :: OccName -> Maybe Fixity,+                -- ^ Cached lookup for 'mi_fixities'+        mi_hash_fn   :: OccName -> Maybe (OccName, Fingerprint),+                -- ^ Cached lookup for 'mi_decls'.+                -- The @Nothing@ in 'mi_hash_fn' means that the thing+                -- isn't in decls. It's useful to know that when+                -- seeing if we are up to date wrt. the old interface.+                -- The 'OccName' is the parent of the name, if it has one.++        mi_hpc       :: !AnyHpcUsage,+                -- ^ True if this program uses Hpc at any point in the program.++        mi_trust     :: !IfaceTrustInfo,+                -- ^ Safe Haskell Trust information for this module.++        mi_trust_pkg :: !Bool,+                -- ^ Do we require the package this module resides in be trusted+                -- to trust this module? This is used for the situation where a+                -- module is Safe (so doesn't require the package be trusted+                -- itself) but imports some trustworthy modules from its own+                -- package (which does require its own package be trusted).+                -- See Note [RnNames . Trust Own Package]+        mi_complete_sigs :: [IfaceCompleteMatch]+     }++-- | Old-style accessor for whether or not the ModIface came from an hs-boot+-- file.+mi_boot :: ModIface -> Bool+mi_boot iface = mi_hsc_src iface == HsBootFile++-- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be+-- found, 'defaultFixity' is returned instead.+mi_fix :: ModIface -> OccName -> Fixity+mi_fix iface name = mi_fix_fn iface name `orElse` defaultFixity++-- | The semantic module for this interface; e.g., if it's a interface+-- for a signature, if 'mi_module' is @p[A=<A>]:A@, 'mi_semantic_module'+-- will be @<A>@.+mi_semantic_module :: ModIface -> Module+mi_semantic_module iface = case mi_sig_of iface of+                            Nothing -> mi_module iface+                            Just mod -> mod++-- | The "precise" free holes, e.g., the signatures that this+-- 'ModIface' depends on.+mi_free_holes :: ModIface -> UniqDSet ModuleName+mi_free_holes iface =+  case splitModuleInsts (mi_module iface) of+    (_, Just indef)+        -- A mini-hack: we rely on the fact that 'renameFreeHoles'+        -- drops things that aren't holes.+        -> renameFreeHoles (mkUniqDSet cands) (indefUnitIdInsts (indefModuleUnitId indef))+    _   -> emptyUniqDSet+  where+    cands = map fst (dep_mods (mi_deps iface))++-- | Given a set of free holes, and a unit identifier, rename+-- the free holes according to the instantiation of the unit+-- identifier.  For example, if we have A and B free, and+-- our unit identity is @p[A=<C>,B=impl:B]@, the renamed free+-- holes are just C.+renameFreeHoles :: UniqDSet ModuleName -> [(ModuleName, Module)] -> UniqDSet ModuleName+renameFreeHoles fhs insts =+    unionManyUniqDSets (map lookup_impl (uniqDSetToList fhs))+  where+    hmap = listToUFM insts+    lookup_impl mod_name+        | Just mod <- lookupUFM hmap mod_name = moduleFreeHoles mod+        -- It wasn't actually a hole+        | otherwise                           = emptyUniqDSet++instance Binary ModIface where+   put_ bh (ModIface {+                 mi_module    = mod,+                 mi_sig_of    = sig_of,+                 mi_hsc_src   = hsc_src,+                 mi_iface_hash= iface_hash,+                 mi_mod_hash  = mod_hash,+                 mi_flag_hash = flag_hash,+                 mi_orphan    = orphan,+                 mi_finsts    = hasFamInsts,+                 mi_deps      = deps,+                 mi_usages    = usages,+                 mi_exports   = exports,+                 mi_exp_hash  = exp_hash,+                 mi_used_th   = used_th,+                 mi_fixities  = fixities,+                 mi_warns     = warns,+                 mi_anns      = anns,+                 mi_decls     = decls,+                 mi_insts     = insts,+                 mi_fam_insts = fam_insts,+                 mi_rules     = rules,+                 mi_orphan_hash = orphan_hash,+                 mi_vect_info = vect_info,+                 mi_hpc       = hpc_info,+                 mi_trust     = trust,+                 mi_trust_pkg = trust_pkg,+                 mi_complete_sigs = complete_sigs }) = do+        put_ bh mod+        put_ bh sig_of+        put_ bh hsc_src+        put_ bh iface_hash+        put_ bh mod_hash+        put_ bh flag_hash+        put_ bh orphan+        put_ bh hasFamInsts+        lazyPut bh deps+        lazyPut bh usages+        put_ bh exports+        put_ bh exp_hash+        put_ bh used_th+        put_ bh fixities+        lazyPut bh warns+        lazyPut bh anns+        put_ bh decls+        put_ bh insts+        put_ bh fam_insts+        lazyPut bh rules+        put_ bh orphan_hash+        put_ bh vect_info+        put_ bh hpc_info+        put_ bh trust+        put_ bh trust_pkg+        put_ bh complete_sigs++   get bh = do+        mod         <- get bh+        sig_of      <- get bh+        hsc_src     <- get bh+        iface_hash  <- get bh+        mod_hash    <- get bh+        flag_hash   <- get bh+        orphan      <- get bh+        hasFamInsts <- get bh+        deps        <- lazyGet bh+        usages      <- {-# SCC "bin_usages" #-} lazyGet bh+        exports     <- {-# SCC "bin_exports" #-} get bh+        exp_hash    <- get bh+        used_th     <- get bh+        fixities    <- {-# SCC "bin_fixities" #-} get bh+        warns       <- {-# SCC "bin_warns" #-} lazyGet bh+        anns        <- {-# SCC "bin_anns" #-} lazyGet bh+        decls       <- {-# SCC "bin_tycldecls" #-} get bh+        insts       <- {-# SCC "bin_insts" #-} get bh+        fam_insts   <- {-# SCC "bin_fam_insts" #-} get bh+        rules       <- {-# SCC "bin_rules" #-} lazyGet bh+        orphan_hash <- get bh+        vect_info   <- get bh+        hpc_info    <- get bh+        trust       <- get bh+        trust_pkg   <- get bh+        complete_sigs <- get bh+        return (ModIface {+                 mi_module      = mod,+                 mi_sig_of      = sig_of,+                 mi_hsc_src     = hsc_src,+                 mi_iface_hash  = iface_hash,+                 mi_mod_hash    = mod_hash,+                 mi_flag_hash   = flag_hash,+                 mi_orphan      = orphan,+                 mi_finsts      = hasFamInsts,+                 mi_deps        = deps,+                 mi_usages      = usages,+                 mi_exports     = exports,+                 mi_exp_hash    = exp_hash,+                 mi_used_th     = used_th,+                 mi_anns        = anns,+                 mi_fixities    = fixities,+                 mi_warns       = warns,+                 mi_decls       = decls,+                 mi_globals     = Nothing,+                 mi_insts       = insts,+                 mi_fam_insts   = fam_insts,+                 mi_rules       = rules,+                 mi_orphan_hash = orphan_hash,+                 mi_vect_info   = vect_info,+                 mi_hpc         = hpc_info,+                 mi_trust       = trust,+                 mi_trust_pkg   = trust_pkg,+                        -- And build the cached values+                 mi_warn_fn     = mkIfaceWarnCache warns,+                 mi_fix_fn      = mkIfaceFixCache fixities,+                 mi_hash_fn     = mkIfaceHashCache decls,+                 mi_complete_sigs = complete_sigs })++-- | The original names declared of a certain module that are exported+type IfaceExport = AvailInfo++-- | Constructs an empty ModIface+emptyModIface :: Module -> ModIface+emptyModIface mod+  = ModIface { mi_module      = mod,+               mi_sig_of      = Nothing,+               mi_iface_hash  = fingerprint0,+               mi_mod_hash    = fingerprint0,+               mi_flag_hash   = fingerprint0,+               mi_orphan      = False,+               mi_finsts      = False,+               mi_hsc_src     = HsSrcFile,+               mi_deps        = noDependencies,+               mi_usages      = [],+               mi_exports     = [],+               mi_exp_hash    = fingerprint0,+               mi_used_th     = False,+               mi_fixities    = [],+               mi_warns       = NoWarnings,+               mi_anns        = [],+               mi_insts       = [],+               mi_fam_insts   = [],+               mi_rules       = [],+               mi_decls       = [],+               mi_globals     = Nothing,+               mi_orphan_hash = fingerprint0,+               mi_vect_info   = noIfaceVectInfo,+               mi_warn_fn     = emptyIfaceWarnCache,+               mi_fix_fn      = emptyIfaceFixCache,+               mi_hash_fn     = emptyIfaceHashCache,+               mi_hpc         = False,+               mi_trust       = noIfaceTrustInfo,+               mi_trust_pkg   = False,+               mi_complete_sigs = [] }+++-- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface'+mkIfaceHashCache :: [(Fingerprint,IfaceDecl)]+                 -> (OccName -> Maybe (OccName, Fingerprint))+mkIfaceHashCache pairs+  = \occ -> lookupOccEnv env occ+  where+    env = foldl' add_decl emptyOccEnv pairs+    add_decl env0 (v,d) = foldl' add env0 (ifaceDeclFingerprints v d)+      where+        add env0 (occ,hash) = extendOccEnv env0 occ (occ,hash)++emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint)+emptyIfaceHashCache _occ = Nothing+++-- | The 'ModDetails' is essentially a cache for information in the 'ModIface'+-- for home modules only. Information relating to packages will be loaded into+-- global environments in 'ExternalPackageState'.+data ModDetails+  = ModDetails {+        -- The next two fields are created by the typechecker+        md_exports   :: [AvailInfo],+        md_types     :: !TypeEnv,       -- ^ Local type environment for this particular module+                                        -- Includes Ids, TyCons, PatSyns+        md_insts     :: ![ClsInst],     -- ^ 'DFunId's for the instances in this module+        md_fam_insts :: ![FamInst],+        md_rules     :: ![CoreRule],    -- ^ Domain may include 'Id's from other modules+        md_anns      :: ![Annotation],  -- ^ Annotations present in this module: currently+                                        -- they only annotate things also declared in this module+        md_vect_info :: !VectInfo,       -- ^ Module vectorisation information+        md_complete_sigs :: [CompleteMatch]+          -- ^ Complete match pragmas for this module+     }++-- | Constructs an empty ModDetails+emptyModDetails :: ModDetails+emptyModDetails+  = ModDetails { md_types     = emptyTypeEnv,+                 md_exports   = [],+                 md_insts     = [],+                 md_rules     = [],+                 md_fam_insts = [],+                 md_anns      = [],+                 md_vect_info = noVectInfo,+                 md_complete_sigs = [] }++-- | Records the modules directly imported by a module for extracting e.g.+-- usage information, and also to give better error message+type ImportedMods = ModuleEnv [ImportedBy]++-- | If a module was "imported" by the user, we associate it with+-- more detailed usage information 'ImportedModsVal'; a module+-- imported by the system only gets used for usage information.+data ImportedBy+    = ImportedByUser ImportedModsVal+    | ImportedBySystem++importedByUser :: [ImportedBy] -> [ImportedModsVal]+importedByUser (ImportedByUser imv : bys) = imv : importedByUser bys+importedByUser (ImportedBySystem   : bys) =       importedByUser bys+importedByUser [] = []++data ImportedModsVal+ = ImportedModsVal {+        imv_name :: ModuleName,          -- ^ The name the module is imported with+        imv_span :: SrcSpan,             -- ^ the source span of the whole import+        imv_is_safe :: IsSafeImport,     -- ^ whether this is a safe import+        imv_is_hiding :: Bool,           -- ^ whether this is an "hiding" import+        imv_all_exports :: GlobalRdrEnv, -- ^ all the things the module could provide+        imv_qualified :: Bool            -- ^ whether this is a qualified import+        }++-- | A ModGuts is carried through the compiler, accumulating stuff as it goes+-- There is only one ModGuts at any time, the one for the module+-- being compiled right now.  Once it is compiled, a 'ModIface' and+-- 'ModDetails' are extracted and the ModGuts is discarded.+data ModGuts+  = ModGuts {+        mg_module    :: !Module,         -- ^ Module being compiled+        mg_hsc_src   :: HscSource,       -- ^ Whether it's an hs-boot module+        mg_loc       :: SrcSpan,         -- ^ For error messages from inner passes+        mg_exports   :: ![AvailInfo],    -- ^ What it exports+        mg_deps      :: !Dependencies,   -- ^ What it depends on, directly or+                                         -- otherwise+        mg_usages    :: ![Usage],        -- ^ What was used?  Used for interfaces.++        mg_used_th   :: !Bool,           -- ^ Did we run a TH splice?+        mg_rdr_env   :: !GlobalRdrEnv,   -- ^ Top-level lexical environment++        -- These fields all describe the things **declared in this module**+        mg_fix_env   :: !FixityEnv,      -- ^ Fixities declared in this module.+                                         -- Used for creating interface files.+        mg_tcs       :: ![TyCon],        -- ^ TyCons declared in this module+                                         -- (includes TyCons for classes)+        mg_insts     :: ![ClsInst],      -- ^ Class instances declared in this module+        mg_fam_insts :: ![FamInst],+                                         -- ^ Family instances declared in this module+        mg_patsyns   :: ![PatSyn],       -- ^ Pattern synonyms declared in this module+        mg_rules     :: ![CoreRule],     -- ^ Before the core pipeline starts, contains+                                         -- See Note [Overall plumbing for rules] in Rules.hs+        mg_binds     :: !CoreProgram,    -- ^ Bindings for this module+        mg_foreign   :: !ForeignStubs,   -- ^ Foreign exports declared in this module+        mg_foreign_files :: ![(ForeignSrcLang, String)],+        -- ^ Files to be compiled with the C compiler+        mg_warns     :: !Warnings,       -- ^ Warnings declared in the module+        mg_anns      :: [Annotation],    -- ^ Annotations declared in this module+        mg_complete_sigs :: [CompleteMatch], -- ^ Complete Matches+        mg_hpc_info  :: !HpcInfo,        -- ^ Coverage tick boxes in the module+        mg_modBreaks :: !(Maybe ModBreaks), -- ^ Breakpoints for the module+        mg_vect_decls:: ![CoreVect],     -- ^ Vectorisation declarations in this module+                                         --   (produced by desugarer & consumed by vectoriser)+        mg_vect_info :: !VectInfo,       -- ^ Pool of vectorised declarations in the module++                        -- The next two fields are unusual, because they give instance+                        -- environments for *all* modules in the home package, including+                        -- this module, rather than for *just* this module.+                        -- Reason: when looking up an instance we don't want to have to+                        --         look at each module in the home package in turn+        mg_inst_env     :: InstEnv,             -- ^ Class instance environment for+                                                -- /home-package/ modules (including this+                                                -- one); c.f. 'tcg_inst_env'+        mg_fam_inst_env :: FamInstEnv,          -- ^ Type-family instance environment for+                                                -- /home-package/ modules (including this+                                                -- one); c.f. 'tcg_fam_inst_env'++        mg_safe_haskell :: SafeHaskellMode,     -- ^ Safe Haskell mode+        mg_trust_pkg    :: Bool                 -- ^ Do we need to trust our+                                                -- own package for Safe Haskell?+                                                -- See Note [RnNames . Trust Own Package]+    }++-- The ModGuts takes on several slightly different forms:+--+-- After simplification, the following fields change slightly:+--      mg_rules        Orphan rules only (local ones now attached to binds)+--      mg_binds        With rules attached++---------------------------------------------------------+-- The Tidy pass forks the information about this module:+--      * one lot goes to interface file generation (ModIface)+--        and later compilations (ModDetails)+--      * the other lot goes to code generation (CgGuts)++-- | A restricted form of 'ModGuts' for code generation purposes+data CgGuts+  = CgGuts {+        cg_module    :: !Module,+                -- ^ Module being compiled++        cg_tycons    :: [TyCon],+                -- ^ Algebraic data types (including ones that started+                -- life as classes); generate constructors and info+                -- tables. Includes newtypes, just for the benefit of+                -- External Core++        cg_binds     :: CoreProgram,+                -- ^ The tidied main bindings, including+                -- previously-implicit bindings for record and class+                -- selectors, and data constructor wrappers.  But *not*+                -- data constructor workers; reason: we we regard them+                -- as part of the code-gen of tycons++        cg_foreign   :: !ForeignStubs,   -- ^ Foreign export stubs+        cg_foreign_files :: ![(ForeignSrcLang, String)],+        cg_dep_pkgs  :: ![InstalledUnitId], -- ^ Dependent packages, used to+                                            -- generate #includes for C code gen+        cg_hpc_info  :: !HpcInfo,           -- ^ Program coverage tick box information+        cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints+        cg_spt_entries :: [SptEntry]+                -- ^ Static pointer table entries for static forms defined in+                -- the module.+                -- See Note [Grand plan for static forms] in StaticPtrTable+    }++-----------------------------------+-- | Foreign export stubs+data ForeignStubs+  = NoStubs+      -- ^ We don't have any stubs+  | ForeignStubs SDoc SDoc+      -- ^ There are some stubs. Parameters:+      --+      --  1) Header file prototypes for+      --     "foreign exported" functions+      --+      --  2) C stubs to use when calling+      --     "foreign exported" functions++appendStubC :: ForeignStubs -> SDoc -> ForeignStubs+appendStubC NoStubs            c_code = ForeignStubs empty c_code+appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code)++-- | An entry to be inserted into a module's static pointer table.+-- See Note [Grand plan for static forms] in StaticPtrTable.+data SptEntry = SptEntry Id Fingerprint++instance Outputable SptEntry where+  ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr++{-+************************************************************************+*                                                                      *+                The interactive context+*                                                                      *+************************************************************************++Note [The interactive package]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Type, class, and value declarations at the command prompt are treated+as if they were defined in modules+   interactive:Ghci1+   interactive:Ghci2+   ...etc...+with each bunch of declarations using a new module, all sharing a+common package 'interactive' (see Module.interactiveUnitId, and+PrelNames.mkInteractiveModule).++This scheme deals well with shadowing.  For example:++   ghci> data T = A+   ghci> data T = B+   ghci> :i A+   data Ghci1.T = A  -- Defined at <interactive>:2:10++Here we must display info about constructor A, but its type T has been+shadowed by the second declaration.  But it has a respectable+qualified name (Ghci1.T), and its source location says where it was+defined.++So the main invariant continues to hold, that in any session an+original name M.T only refers to one unique thing.  (In a previous+iteration both the T's above were called :Interactive.T, albeit with+different uniques, which gave rise to all sorts of trouble.)++The details are a bit tricky though:++ * The field ic_mod_index counts which Ghci module we've got up to.+   It is incremented when extending ic_tythings++ * ic_tythings contains only things from the 'interactive' package.++ * Module from the 'interactive' package (Ghci1, Ghci2 etc) never go+   in the Home Package Table (HPT).  When you say :load, that's when we+   extend the HPT.++ * The 'thisPackage' field of DynFlags is *not* set to 'interactive'.+   It stays as 'main' (or whatever -this-unit-id says), and is the+   package to which :load'ed modules are added to.++ * So how do we arrange that declarations at the command prompt get to+   be in the 'interactive' package?  Simply by setting the tcg_mod+   field of the TcGblEnv to "interactive:Ghci1".  This is done by the+   call to initTc in initTcInteractive, which in turn get the module+   from it 'icInteractiveModule' field of the interactive context.++   The 'thisPackage' field stays as 'main' (or whatever -this-unit-id says.++ * The main trickiness is that the type environment (tcg_type_env) and+   fixity envt (tcg_fix_env), now contain entities from all the+   interactive-package modules (Ghci1, Ghci2, ...) together, rather+   than just a single module as is usually the case.  So you can't use+   "nameIsLocalOrFrom" to decide whether to look in the TcGblEnv vs+   the HPT/PTE.  This is a change, but not a problem provided you+   know.++* However, the tcg_binds, tcg_sigs, tcg_insts, tcg_fam_insts, etc fields+  of the TcGblEnv, which collect "things defined in this module", all+  refer to stuff define in a single GHCi command, *not* all the commands+  so far.++  In contrast, tcg_inst_env, tcg_fam_inst_env, have instances from+  all GhciN modules, which makes sense -- they are all "home package"+  modules.+++Note [Interactively-bound Ids in GHCi]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The Ids bound by previous Stmts in GHCi are currently+        a) GlobalIds, with+        b) An External Name, like Ghci4.foo+           See Note [The interactive package] above+        c) A tidied type++ (a) They must be GlobalIds (not LocalIds) otherwise when we come to+     compile an expression using these ids later, the byte code+     generator will consider the occurrences to be free rather than+     global.++ (b) Having an External Name is important because of Note+     [GlobalRdrEnv shadowing] in RdrName++ (c) Their types are tidied. This is important, because :info may ask+     to look at them, and :info expects the things it looks up to have+     tidy types++Where do interactively-bound Ids come from?++  - GHCi REPL Stmts   e.g.+         ghci> let foo x = x+1+    These start with an Internal Name because a Stmt is a local+    construct, so the renamer naturally builds an Internal name for+    each of its binders.  Then in tcRnStmt they are externalised via+    TcRnDriver.externaliseAndTidyId, so they get Names like Ghic4.foo.++  - Ids bound by the debugger etc have Names constructed by+    IfaceEnv.newInteractiveBinder; at the call sites it is followed by+    mkVanillaGlobal or mkVanillaGlobalWithInfo.  So again, they are+    all Global, External.++  - TyCons, Classes, and Ids bound by other top-level declarations in+    GHCi (eg foreign import, record selectors) also get External+    Names, with Ghci9 (or 8, or 7, etc) as the module name.+++Note [ic_tythings]+~~~~~~~~~~~~~~~~~~+The ic_tythings field contains+  * The TyThings declared by the user at the command prompt+    (eg Ids, TyCons, Classes)++  * The user-visible Ids that arise from such things, which+    *don't* come from 'implicitTyThings', notably:+       - record selectors+       - class ops+    The implicitTyThings are readily obtained from the TyThings+    but record selectors etc are not++It does *not* contain+  * DFunIds (they can be gotten from ic_instances)+  * CoAxioms (ditto)++See also Note [Interactively-bound Ids in GHCi]++Note [Override identical instances in GHCi]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If you declare a new instance in GHCi that is identical to a previous one,+we simply override the previous one; we don't regard it as overlapping.+e.g.    Prelude> data T = A | B+        Prelude> instance Eq T where ...+        Prelude> instance Eq T where ...   -- This one overrides++It's exactly the same for type-family instances.  See Trac #7102+-}++-- | Interactive context, recording information about the state of the+-- context in which statements are executed in a GHC session.+data InteractiveContext+  = InteractiveContext {+         ic_dflags     :: DynFlags,+             -- ^ The 'DynFlags' used to evaluate interative expressions+             -- and statements.++         ic_mod_index :: Int,+             -- ^ Each GHCi stmt or declaration brings some new things into+             -- scope. We give them names like interactive:Ghci9.T,+             -- where the ic_index is the '9'.  The ic_mod_index is+             -- incremented whenever we add something to ic_tythings+             -- See Note [The interactive package]++         ic_imports :: [InteractiveImport],+             -- ^ The GHCi top-level scope (ic_rn_gbl_env) is extended with+             -- these imports+             --+             -- This field is only stored here so that the client+             -- can retrieve it with GHC.getContext. GHC itself doesn't+             -- use it, but does reset it to empty sometimes (such+             -- as before a GHC.load). The context is set with GHC.setContext.++         ic_tythings   :: [TyThing],+             -- ^ TyThings defined by the user, in reverse order of+             -- definition (ie most recent at the front)+             -- See Note [ic_tythings]++         ic_rn_gbl_env :: GlobalRdrEnv,+             -- ^ The cached 'GlobalRdrEnv', built by+             -- 'InteractiveEval.setContext' and updated regularly+             -- It contains everything in scope at the command line,+             -- including everything in ic_tythings++         ic_instances  :: ([ClsInst], [FamInst]),+             -- ^ All instances and family instances created during+             -- this session.  These are grabbed en masse after each+             -- update to be sure that proper overlapping is retained.+             -- That is, rather than re-check the overlapping each+             -- time we update the context, we just take the results+             -- from the instance code that already does that.++         ic_fix_env :: FixityEnv,+            -- ^ Fixities declared in let statements++         ic_default :: Maybe [Type],+             -- ^ The current default types, set by a 'default' declaration++          ic_resume :: [Resume],+             -- ^ The stack of breakpoint contexts++         ic_monad      :: Name,+             -- ^ The monad that GHCi is executing in++         ic_int_print  :: Name,+             -- ^ The function that is used for printing results+             -- of expressions in ghci and -e mode.++         ic_cwd :: Maybe FilePath+             -- virtual CWD of the program+    }++data InteractiveImport+  = IIDecl (ImportDecl RdrName)+      -- ^ Bring the exports of a particular module+      -- (filtered by an import decl) into scope++  | IIModule ModuleName+      -- ^ Bring into scope the entire top-level envt of+      -- of this module, including the things imported+      -- into it.+++-- | Constructs an empty InteractiveContext.+emptyInteractiveContext :: DynFlags -> InteractiveContext+emptyInteractiveContext dflags+  = InteractiveContext {+       ic_dflags     = dflags,+       ic_imports    = [],+       ic_rn_gbl_env = emptyGlobalRdrEnv,+       ic_mod_index  = 1,+       ic_tythings   = [],+       ic_instances  = ([],[]),+       ic_fix_env    = emptyNameEnv,+       ic_monad      = ioTyConName,  -- IO monad by default+       ic_int_print  = printName,    -- System.IO.print by default+       ic_default    = Nothing,+       ic_resume     = [],+       ic_cwd        = Nothing }++icInteractiveModule :: InteractiveContext -> Module+icInteractiveModule (InteractiveContext { ic_mod_index = index })+  = mkInteractiveModule index++-- | This function returns the list of visible TyThings (useful for+-- e.g. showBindings)+icInScopeTTs :: InteractiveContext -> [TyThing]+icInScopeTTs = ic_tythings++-- | Get the PrintUnqualified function based on the flags and this InteractiveContext+icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified+icPrintUnqual dflags InteractiveContext{ ic_rn_gbl_env = grenv } =+    mkPrintUnqualified dflags grenv++-- | extendInteractiveContext is called with new TyThings recently defined to update the+-- InteractiveContext to include them.  Ids are easily removed when shadowed,+-- but Classes and TyCons are not.  Some work could be done to determine+-- whether they are entirely shadowed, but as you could still have references+-- to them (e.g. instances for classes or values of the type for TyCons), it's+-- not clear whether removing them is even the appropriate behavior.+extendInteractiveContext :: InteractiveContext+                         -> [TyThing]+                         -> [ClsInst] -> [FamInst]+                         -> Maybe [Type]+                         -> FixityEnv+                         -> InteractiveContext+extendInteractiveContext ictxt new_tythings new_cls_insts new_fam_insts defaults fix_env+  = ictxt { ic_mod_index  = ic_mod_index ictxt + 1+                            -- Always bump this; even instances should create+                            -- a new mod_index (Trac #9426)+          , ic_tythings   = new_tythings ++ ic_tythings ictxt+          , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings+          , ic_instances  = ( new_cls_insts ++ old_cls_insts+                            , new_fam_insts ++ fam_insts )+                            -- we don't shadow old family instances (#7102),+                            -- so don't need to remove them here+          , ic_default    = defaults+          , ic_fix_env    = fix_env  -- See Note [Fixity declarations in GHCi]+          }+  where++    -- Discard old instances that have been fully overridden+    -- See Note [Override identical instances in GHCi]+    (cls_insts, fam_insts) = ic_instances ictxt+    old_cls_insts = filterOut (\i -> any (identicalClsInstHead i) new_cls_insts) cls_insts++extendInteractiveContextWithIds :: InteractiveContext -> [Id] -> InteractiveContext+-- Just a specialised version+extendInteractiveContextWithIds ictxt new_ids+  | null new_ids = ictxt+  | otherwise    = ictxt { ic_mod_index  = ic_mod_index ictxt + 1+                         , ic_tythings   = new_tythings ++ ic_tythings ictxt+                         , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings }+  where+    new_tythings = map AnId new_ids++setInteractivePackage :: HscEnv -> HscEnv+-- Set the 'thisPackage' DynFlag to 'interactive'+setInteractivePackage hsc_env+   = hsc_env { hsc_dflags = (hsc_dflags hsc_env)+                { thisInstalledUnitId = toInstalledUnitId interactiveUnitId } }++setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext+setInteractivePrintName ic n = ic{ic_int_print = n}++    -- ToDo: should not add Ids to the gbl env here++-- | Add TyThings to the GlobalRdrEnv, earlier ones in the list shadowing+-- later ones, and shadowing existing entries in the GlobalRdrEnv.+icExtendGblRdrEnv :: GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv+icExtendGblRdrEnv env tythings+  = foldr add env tythings  -- Foldr makes things in the front of+                            -- the list shadow things at the back+  where+    -- One at a time, to ensure each shadows the previous ones+    add thing env+       | is_sub_bndr thing+       = env+       | otherwise+       = foldl extendGlobalRdrEnv env1 (concatMap localGREsFromAvail avail)+       where+          env1  = shadowNames env (concatMap availNames avail)+          avail = tyThingAvailInfo thing++    -- Ugh! The new_tythings may include record selectors, since they+    -- are not implicit-ids, and must appear in the TypeEnv.  But they+    -- will also be brought into scope by the corresponding (ATyCon+    -- tc).  And we want the latter, because that has the correct+    -- parent (Trac #10520)+    is_sub_bndr (AnId f) = case idDetails f of+                             RecSelId {}  -> True+                             ClassOpId {} -> True+                             _            -> False+    is_sub_bndr _ = False++substInteractiveContext :: InteractiveContext -> TCvSubst -> InteractiveContext+substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst+  | isEmptyTCvSubst subst = ictxt+  | otherwise             = ictxt { ic_tythings = map subst_ty tts }+  where+    subst_ty (AnId id) = AnId $ id `setIdType` substTyUnchecked subst (idType id)+    subst_ty tt        = tt++instance Outputable InteractiveImport where+  ppr (IIModule m) = char '*' <> ppr m+  ppr (IIDecl d)   = ppr d++{-+************************************************************************+*                                                                      *+        Building a PrintUnqualified+*                                                                      *+************************************************************************++Note [Printing original names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Deciding how to print names is pretty tricky.  We are given a name+P:M.T, where P is the package name, M is the defining module, and T is+the occurrence name, and we have to decide in which form to display+the name given a GlobalRdrEnv describing the current scope.++Ideally we want to display the name in the form in which it is in+scope.  However, the name might not be in scope at all, and that's+where it gets tricky.  Here are the cases:++ 1. T uniquely maps to  P:M.T      --->  "T"      NameUnqual+ 2. There is an X for which X.T+       uniquely maps to  P:M.T     --->  "X.T"    NameQual X+ 3. There is no binding for "M.T"  --->  "M.T"    NameNotInScope1+ 4. Otherwise                      --->  "P:M.T"  NameNotInScope2++(3) and (4) apply when the entity P:M.T is not in the GlobalRdrEnv at+all. In these cases we still want to refer to the name as "M.T", *but*+"M.T" might mean something else in the current scope (e.g. if there's+an "import X as M"), so to avoid confusion we avoid using "M.T" if+there's already a binding for it.  Instead we write P:M.T.++There's one further subtlety: in case (3), what if there are two+things around, P1:M.T and P2:M.T?  Then we don't want to print both of+them as M.T!  However only one of the modules P1:M and P2:M can be+exposed (say P2), so we use M.T for that, and P1:M.T for the other one.+This is handled by the qual_mod component of PrintUnqualified, inside+the (ppr mod) of case (3), in Name.pprModulePrefix++Note [Printing unit ids]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the old days, original names were tied to PackageIds, which directly+corresponded to the entities that users wrote in Cabal files, and were perfectly+suitable for printing when we need to disambiguate packages.  However, with+UnitId, the situation can be different: if the key is instantiated with+some holes, we should try to give the user some more useful information.+-}++-- | Creates some functions that work out the best ways to format+-- names for the user according to a set of heuristics.+mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified+mkPrintUnqualified dflags env = QueryQualify qual_name+                                             (mkQualModule dflags)+                                             (mkQualPackage dflags)+  where+  qual_name mod occ+        | [gre] <- unqual_gres+        , right_name gre+        = NameUnqual   -- If there's a unique entity that's in scope+                       -- unqualified with 'occ' AND that entity is+                       -- the right one, then we can use the unqualified name++        | [] <- unqual_gres+        , any is_name forceUnqualNames+        , not (isDerivedOccName occ)+        = NameUnqual   -- Don't qualify names that come from modules+                       -- that come with GHC, often appear in error messages,+                       -- but aren't typically in scope. Doing this does not+                       -- cause ambiguity, and it reduces the amount of+                       -- qualification in error messages thus improving+                       -- readability.+                       --+                       -- A motivating example is 'Constraint'. It's often not+                       -- in scope, but printing GHC.Prim.Constraint seems+                       -- overkill.++        | [gre] <- qual_gres+        = NameQual (greQualModName gre)++        | null qual_gres+        = if null (lookupGRE_RdrName (mkRdrQual (moduleName mod) occ) env)+          then NameNotInScope1+          else NameNotInScope2++        | otherwise+        = NameNotInScope1   -- Can happen if 'f' is bound twice in the module+                            -- Eg  f = True; g = 0; f = False+      where+        is_name :: Name -> Bool+        is_name name = ASSERT2( isExternalName name, ppr name )+                       nameModule name == mod && nameOccName name == occ++        forceUnqualNames :: [Name]+        forceUnqualNames =+          map tyConName [ constraintKindTyCon, heqTyCon, coercibleTyCon+                        , starKindTyCon, unicodeStarKindTyCon ]+          ++ [ eqTyConName ]++        right_name gre = nameModule_maybe (gre_name gre) == Just mod++        unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env+        qual_gres   = filter right_name (lookupGlobalRdrEnv env occ)++    -- we can mention a module P:M without the P: qualifier iff+    -- "import M" would resolve unambiguously to P:M.  (if P is the+    -- current package we can just assume it is unqualified).++-- | Creates a function for formatting modules based on two heuristics:+-- (1) if the module is the current module, don't qualify, and (2) if there+-- is only one exposed package which exports this module, don't qualify.+mkQualModule :: DynFlags -> QueryQualifyModule+mkQualModule dflags mod+     | moduleUnitId mod == thisPackage dflags = False++     | [(_, pkgconfig)] <- lookup,+       packageConfigId pkgconfig == moduleUnitId mod+        -- this says: we are given a module P:M, is there just one exposed package+        -- that exposes a module M, and is it package P?+     = False++     | otherwise = True+     where lookup = lookupModuleInAllPackages dflags (moduleName mod)++-- | Creates a function for formatting packages based on two heuristics:+-- (1) don't qualify if the package in question is "main", and (2) only qualify+-- with a unit id if the package ID would be ambiguous.+mkQualPackage :: DynFlags -> QueryQualifyPackage+mkQualPackage dflags pkg_key+     | pkg_key == mainUnitId || pkg_key == interactiveUnitId+        -- Skip the lookup if it's main, since it won't be in the package+        -- database!+     = False+     | Just pkgid <- mb_pkgid+     , searchPackageId dflags pkgid `lengthIs` 1+        -- this says: we are given a package pkg-0.1@MMM, are there only one+        -- exposed packages whose package ID is pkg-0.1?+     = False+     | otherwise+     = True+     where mb_pkgid = fmap sourcePackageId (lookupPackage dflags pkg_key)++-- | A function which only qualifies package names if necessary; but+-- qualifies all other identifiers.+pkgQual :: DynFlags -> PrintUnqualified+pkgQual dflags = alwaysQualify {+        queryQualifyPackage = mkQualPackage dflags+    }++{-+************************************************************************+*                                                                      *+                Implicit TyThings+*                                                                      *+************************************************************************++Note [Implicit TyThings]+~~~~~~~~~~~~~~~~~~~~~~~~+  DEFINITION: An "implicit" TyThing is one that does not have its own+  IfaceDecl in an interface file.  Instead, its binding in the type+  environment is created as part of typechecking the IfaceDecl for+  some other thing.++Examples:+  * All DataCons are implicit, because they are generated from the+    IfaceDecl for the data/newtype.  Ditto class methods.++  * Record selectors are *not* implicit, because they get their own+    free-standing IfaceDecl.++  * Associated data/type families are implicit because they are+    included in the IfaceDecl of the parent class.  (NB: the+    IfaceClass decl happens to use IfaceDecl recursively for the+    associated types, but that's irrelevant here.)++  * Dictionary function Ids are not implicit.++  * Axioms for newtypes are implicit (same as above), but axioms+    for data/type family instances are *not* implicit (like DFunIds).+-}++-- | Determine the 'TyThing's brought into scope by another 'TyThing'+-- /other/ than itself. For example, Id's don't have any implicit TyThings+-- as they just bring themselves into scope, but classes bring their+-- dictionary datatype, type constructor and some selector functions into+-- scope, just for a start!++-- N.B. the set of TyThings returned here *must* match the set of+-- names returned by LoadIface.ifaceDeclImplicitBndrs, in the sense that+-- TyThing.getOccName should define a bijection between the two lists.+-- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop])+-- The order of the list does not matter.+implicitTyThings :: TyThing -> [TyThing]+implicitTyThings (AnId _)       = []+implicitTyThings (ACoAxiom _cc) = []+implicitTyThings (ATyCon tc)    = implicitTyConThings tc+implicitTyThings (AConLike cl)  = implicitConLikeThings cl++implicitConLikeThings :: ConLike -> [TyThing]+implicitConLikeThings (RealDataCon dc)+  = dataConImplicitTyThings dc++implicitConLikeThings (PatSynCon {})+  = []  -- Pattern synonyms have no implicit Ids; the wrapper and matcher+        -- are not "implicit"; they are simply new top-level bindings,+        -- and they have their own declaration in an interface file+        -- Unless a record pat syn when there are implicit selectors+        -- They are still not included here as `implicitConLikeThings` is+        -- used by `tcTyClsDecls` whilst pattern synonyms are typed checked+        -- by `tcTopValBinds`.++implicitClassThings :: Class -> [TyThing]+implicitClassThings cl+  = -- Does not include default methods, because those Ids may have+    --    their own pragmas, unfoldings etc, not derived from the Class object++    -- associated types+    --    No recursive call for the classATs, because they+    --    are only the family decls; they have no implicit things+    map ATyCon (classATs cl) ++++    -- superclass and operation selectors+    map AnId (classAllSelIds cl)++implicitTyConThings :: TyCon -> [TyThing]+implicitTyConThings tc+  = class_stuff +++      -- fields (names of selectors)++      -- (possibly) implicit newtype axioms+      -- or type family axioms+    implicitCoTyCon tc ++++      -- for each data constructor in order,+      --   the constructor, worker, and (possibly) wrapper+    [ thing | dc    <- tyConDataCons tc+            , thing <- AConLike (RealDataCon dc) : dataConImplicitTyThings dc ]+      -- NB. record selectors are *not* implicit, they have fully-fledged+      -- bindings that pass through the compilation pipeline as normal.+  where+    class_stuff = case tyConClass_maybe tc of+        Nothing -> []+        Just cl -> implicitClassThings cl++-- For newtypes and closed type families (only) add the implicit coercion tycon+implicitCoTyCon :: TyCon -> [TyThing]+implicitCoTyCon tc+  | Just co <- newTyConCo_maybe tc = [ACoAxiom $ toBranchedAxiom co]+  | Just co <- isClosedSynFamilyTyConWithAxiom_maybe tc+                                   = [ACoAxiom co]+  | otherwise                      = []++-- | Returns @True@ if there should be no interface-file declaration+-- for this thing on its own: either it is built-in, or it is part+-- of some other declaration, or it is generated implicitly by some+-- other declaration.+isImplicitTyThing :: TyThing -> Bool+isImplicitTyThing (AConLike cl) = case cl of+                                    RealDataCon {} -> True+                                    PatSynCon {}   -> False+isImplicitTyThing (AnId id)     = isImplicitId id+isImplicitTyThing (ATyCon tc)   = isImplicitTyCon tc+isImplicitTyThing (ACoAxiom ax) = isImplicitCoAxiom ax++-- | tyThingParent_maybe x returns (Just p)+-- when pprTyThingInContext should print a declaration for p+-- (albeit with some "..." in it) when asked to show x+-- It returns the *immediate* parent.  So a datacon returns its tycon+-- but the tycon could be the associated type of a class, so it in turn+-- might have a parent.+tyThingParent_maybe :: TyThing -> Maybe TyThing+tyThingParent_maybe (AConLike cl) = case cl of+    RealDataCon dc  -> Just (ATyCon (dataConTyCon dc))+    PatSynCon{}     -> Nothing+tyThingParent_maybe (ATyCon tc)   = case tyConAssoc_maybe tc of+                                      Just cls -> Just (ATyCon (classTyCon cls))+                                      Nothing  -> Nothing+tyThingParent_maybe (AnId id)     = case idDetails id of+                                      RecSelId { sel_tycon = RecSelData tc } ->+                                          Just (ATyCon tc)+                                      ClassOpId cls               ->+                                          Just (ATyCon (classTyCon cls))+                                      _other                      -> Nothing+tyThingParent_maybe _other = Nothing++tyThingsTyCoVars :: [TyThing] -> TyCoVarSet+tyThingsTyCoVars tts =+    unionVarSets $ map ttToVarSet tts+    where+        ttToVarSet (AnId id)     = tyCoVarsOfType $ idType id+        ttToVarSet (AConLike cl) = case cl of+            RealDataCon dc  -> tyCoVarsOfType $ dataConRepType dc+            PatSynCon{}     -> emptyVarSet+        ttToVarSet (ATyCon tc)+          = case tyConClass_maybe tc of+              Just cls -> (mkVarSet . fst . classTvsFds) cls+              Nothing  -> tyCoVarsOfType $ tyConKind tc+        ttToVarSet (ACoAxiom _)  = emptyVarSet++-- | The Names that a TyThing should bring into scope.  Used to build+-- the GlobalRdrEnv for the InteractiveContext.+tyThingAvailInfo :: TyThing -> [AvailInfo]+tyThingAvailInfo (ATyCon t)+   = case tyConClass_maybe t of+        Just c  -> [AvailTC n (n : map getName (classMethods c)+                                 ++ map getName (classATs c))+                             [] ]+             where n = getName c+        Nothing -> [AvailTC n (n : map getName dcs) flds]+             where n    = getName t+                   dcs  = tyConDataCons t+                   flds = tyConFieldLabels t+tyThingAvailInfo (AConLike (PatSynCon p))+  = map avail ((getName p) : map flSelector (patSynFieldLabels p))+tyThingAvailInfo t+   = [avail (getName t)]++{-+************************************************************************+*                                                                      *+                TypeEnv+*                                                                      *+************************************************************************+-}++-- | A map from 'Name's to 'TyThing's, constructed by typechecking+-- local declarations or interface files+type TypeEnv = NameEnv TyThing++emptyTypeEnv    :: TypeEnv+typeEnvElts     :: TypeEnv -> [TyThing]+typeEnvTyCons   :: TypeEnv -> [TyCon]+typeEnvCoAxioms :: TypeEnv -> [CoAxiom Branched]+typeEnvIds      :: TypeEnv -> [Id]+typeEnvPatSyns  :: TypeEnv -> [PatSyn]+typeEnvDataCons :: TypeEnv -> [DataCon]+typeEnvClasses  :: TypeEnv -> [Class]+lookupTypeEnv   :: TypeEnv -> Name -> Maybe TyThing++emptyTypeEnv        = emptyNameEnv+typeEnvElts     env = nameEnvElts env+typeEnvTyCons   env = [tc | ATyCon tc   <- typeEnvElts env]+typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env]+typeEnvIds      env = [id | AnId id     <- typeEnvElts env]+typeEnvPatSyns  env = [ps | AConLike (PatSynCon ps) <- typeEnvElts env]+typeEnvDataCons env = [dc | AConLike (RealDataCon dc) <- typeEnvElts env]+typeEnvClasses  env = [cl | tc <- typeEnvTyCons env,+                            Just cl <- [tyConClass_maybe tc]]++mkTypeEnv :: [TyThing] -> TypeEnv+mkTypeEnv things = extendTypeEnvList emptyTypeEnv things++mkTypeEnvWithImplicits :: [TyThing] -> TypeEnv+mkTypeEnvWithImplicits things =+  mkTypeEnv things+    `plusNameEnv`+  mkTypeEnv (concatMap implicitTyThings things)++typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst] -> TypeEnv+typeEnvFromEntities ids tcs famInsts =+  mkTypeEnv (   map AnId ids+             ++ map ATyCon all_tcs+             ++ concatMap implicitTyConThings all_tcs+             ++ map (ACoAxiom . toBranchedAxiom . famInstAxiom) famInsts+            )+ where+  all_tcs = tcs ++ famInstsRepTyCons famInsts++lookupTypeEnv = lookupNameEnv++-- Extend the type environment+extendTypeEnv :: TypeEnv -> TyThing -> TypeEnv+extendTypeEnv env thing = extendNameEnv env (getName thing) thing++extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv+extendTypeEnvList env things = foldl extendTypeEnv env things++extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv+extendTypeEnvWithIds env ids+  = extendNameEnvList env [(getName id, AnId id) | id <- ids]++plusTypeEnv :: TypeEnv -> TypeEnv -> TypeEnv+plusTypeEnv env1 env2 = plusNameEnv env1 env2++-- | Find the 'TyThing' for the given 'Name' by using all the resources+-- at our disposal: the compiled modules in the 'HomePackageTable' and the+-- compiled modules in other packages that live in 'PackageTypeEnv'. Note+-- that this does NOT look up the 'TyThing' in the module being compiled: you+-- have to do that yourself, if desired+lookupType :: DynFlags+           -> HomePackageTable+           -> PackageTypeEnv+           -> Name+           -> Maybe TyThing++lookupType dflags hpt pte name+  | isOneShot (ghcMode dflags)  -- in one-shot, we don't use the HPT+  = lookupNameEnv pte name+  | otherwise+  = case lookupHptByModule hpt mod of+       Just hm -> lookupNameEnv (md_types (hm_details hm)) name+       Nothing -> lookupNameEnv pte name+  where+    mod = ASSERT2( isExternalName name, ppr name )+          if isHoleName name+            then mkModule (thisPackage dflags) (moduleName (nameModule name))+            else nameModule name++-- | As 'lookupType', but with a marginally easier-to-use interface+-- if you have a 'HscEnv'+lookupTypeHscEnv :: HscEnv -> Name -> IO (Maybe TyThing)+lookupTypeHscEnv hsc_env name = do+    eps <- readIORef (hsc_EPS hsc_env)+    return $! lookupType dflags hpt (eps_PTE eps) name+  where+    dflags = hsc_dflags hsc_env+    hpt = hsc_HPT hsc_env++-- | Get the 'TyCon' from a 'TyThing' if it is a type constructor thing. Panics otherwise+tyThingTyCon :: TyThing -> TyCon+tyThingTyCon (ATyCon tc) = tc+tyThingTyCon other       = pprPanic "tyThingTyCon" (ppr other)++-- | Get the 'CoAxiom' from a 'TyThing' if it is a coercion axiom thing. Panics otherwise+tyThingCoAxiom :: TyThing -> CoAxiom Branched+tyThingCoAxiom (ACoAxiom ax) = ax+tyThingCoAxiom other         = pprPanic "tyThingCoAxiom" (ppr other)++-- | Get the 'DataCon' from a 'TyThing' if it is a data constructor thing. Panics otherwise+tyThingDataCon :: TyThing -> DataCon+tyThingDataCon (AConLike (RealDataCon dc)) = dc+tyThingDataCon other                       = pprPanic "tyThingDataCon" (ppr other)++-- | Get the 'ConLike' from a 'TyThing' if it is a data constructor thing.+-- Panics otherwise+tyThingConLike :: TyThing -> ConLike+tyThingConLike (AConLike dc) = dc+tyThingConLike other         = pprPanic "tyThingConLike" (ppr other)++-- | Get the 'Id' from a 'TyThing' if it is a id *or* data constructor thing. Panics otherwise+tyThingId :: TyThing -> Id+tyThingId (AnId id)                   = id+tyThingId (AConLike (RealDataCon dc)) = dataConWrapId dc+tyThingId other                       = pprPanic "tyThingId" (ppr other)++{-+************************************************************************+*                                                                      *+\subsection{MonadThings and friends}+*                                                                      *+************************************************************************+-}++-- | Class that abstracts out the common ability of the monads in GHC+-- to lookup a 'TyThing' in the monadic environment by 'Name'. Provides+-- a number of related convenience functions for accessing particular+-- kinds of 'TyThing'+class Monad m => MonadThings m where+        lookupThing :: Name -> m TyThing++        lookupId :: Name -> m Id+        lookupId = liftM tyThingId . lookupThing++        lookupDataCon :: Name -> m DataCon+        lookupDataCon = liftM tyThingDataCon . lookupThing++        lookupTyCon :: Name -> m TyCon+        lookupTyCon = liftM tyThingTyCon . lookupThing++{-+************************************************************************+*                                                                      *+\subsection{Auxiliary types}+*                                                                      *+************************************************************************++These types are defined here because they are mentioned in ModDetails,+but they are mostly elaborated elsewhere+-}++------------------ Warnings -------------------------+-- | Warning information for a module+data Warnings+  = NoWarnings                          -- ^ Nothing deprecated+  | WarnAll WarningTxt                  -- ^ Whole module deprecated+  | WarnSome [(OccName,WarningTxt)]     -- ^ Some specific things deprecated++     -- Only an OccName is needed because+     --    (1) a deprecation always applies to a binding+     --        defined in the module in which the deprecation appears.+     --    (2) deprecations are only reported outside the defining module.+     --        this is important because, otherwise, if we saw something like+     --+     --        {-# DEPRECATED f "" #-}+     --        f = ...+     --        h = f+     --        g = let f = undefined in f+     --+     --        we'd need more information than an OccName to know to say something+     --        about the use of f in h but not the use of the locally bound f in g+     --+     --        however, because we only report about deprecations from the outside,+     --        and a module can only export one value called f,+     --        an OccName suffices.+     --+     --        this is in contrast with fixity declarations, where we need to map+     --        a Name to its fixity declaration.+  deriving( Eq )++instance Binary Warnings where+    put_ bh NoWarnings     = putByte bh 0+    put_ bh (WarnAll t) = do+            putByte bh 1+            put_ bh t+    put_ bh (WarnSome ts) = do+            putByte bh 2+            put_ bh ts++    get bh = do+            h <- getByte bh+            case h of+              0 -> return NoWarnings+              1 -> do aa <- get bh+                      return (WarnAll aa)+              _ -> do aa <- get bh+                      return (WarnSome aa)++-- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface'+mkIfaceWarnCache :: Warnings -> OccName -> Maybe WarningTxt+mkIfaceWarnCache NoWarnings  = \_ -> Nothing+mkIfaceWarnCache (WarnAll t) = \_ -> Just t+mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs)++emptyIfaceWarnCache :: OccName -> Maybe WarningTxt+emptyIfaceWarnCache _ = Nothing++plusWarns :: Warnings -> Warnings -> Warnings+plusWarns d NoWarnings = d+plusWarns NoWarnings d = d+plusWarns _ (WarnAll t) = WarnAll t+plusWarns (WarnAll t) _ = WarnAll t+plusWarns (WarnSome v1) (WarnSome v2) = WarnSome (v1 ++ v2)++-- | Creates cached lookup for the 'mi_fix_fn' field of 'ModIface'+mkIfaceFixCache :: [(OccName, Fixity)] -> OccName -> Maybe Fixity+mkIfaceFixCache pairs+  = \n -> lookupOccEnv env n+  where+   env = mkOccEnv pairs++emptyIfaceFixCache :: OccName -> Maybe Fixity+emptyIfaceFixCache _ = Nothing++-- | Fixity environment mapping names to their fixities+type FixityEnv = NameEnv FixItem++-- | Fixity information for an 'Name'. We keep the OccName in the range+-- so that we can generate an interface from it+data FixItem = FixItem OccName Fixity++instance Outputable FixItem where+  ppr (FixItem occ fix) = ppr fix <+> ppr occ++emptyFixityEnv :: FixityEnv+emptyFixityEnv = emptyNameEnv++lookupFixity :: FixityEnv -> Name -> Fixity+lookupFixity env n = case lookupNameEnv env n of+                        Just (FixItem _ fix) -> fix+                        Nothing         -> defaultFixity++{-+************************************************************************+*                                                                      *+\subsection{WhatsImported}+*                                                                      *+************************************************************************+-}++-- | Records whether a module has orphans. An \"orphan\" is one of:+--+-- * An instance declaration in a module other than the definition+--   module for one of the type constructors or classes in the instance head+--+-- * A transformation rule in a module other than the one defining+--   the function in the head of the rule+--+-- * A vectorisation pragma+type WhetherHasOrphans   = Bool++-- | Does this module define family instances?+type WhetherHasFamInst = Bool++-- | Did this module originate from a *-boot file?+type IsBootInterface = Bool++-- | Dependency information about ALL modules and packages below this one+-- in the import hierarchy.+--+-- Invariant: the dependencies of a module @M@ never includes @M@.+--+-- Invariant: none of the lists contain duplicates.+data Dependencies+  = Deps { dep_mods   :: [(ModuleName, IsBootInterface)]+                        -- ^ All home-package modules transitively below this one+                        -- I.e. modules that this one imports, or that are in the+                        --      dep_mods of those directly-imported modules++         , dep_pkgs   :: [(InstalledUnitId, Bool)]+                        -- ^ All packages transitively below this module+                        -- I.e. packages to which this module's direct imports belong,+                        --      or that are in the dep_pkgs of those modules+                        -- The bool indicates if the package is required to be+                        -- trusted when the module is imported as a safe import+                        -- (Safe Haskell). See Note [RnNames . Tracking Trust Transitively]++         , dep_orphs  :: [Module]+                        -- ^ Transitive closure of orphan modules (whether+                        -- home or external pkg).+                        --+                        -- (Possible optimization: don't include family+                        -- instance orphans as they are anyway included in+                        -- 'dep_finsts'.  But then be careful about code+                        -- which relies on dep_orphs having the complete list!)+                        -- This does NOT include us, unlike 'imp_orphs'.++         , dep_finsts :: [Module]+                        -- ^ Transitive closure of depended upon modules which+                        -- contain family instances (whether home or external).+                        -- This is used by 'checkFamInstConsistency'.  This+                        -- does NOT include us, unlike 'imp_finsts'. See Note+                        -- [The type family instance consistency story].+         }+  deriving( Eq )+        -- Equality used only for old/new comparison in MkIface.addFingerprints+        -- See 'TcRnTypes.ImportAvails' for details on dependencies.++instance Binary Dependencies where+    put_ bh deps = do put_ bh (dep_mods deps)+                      put_ bh (dep_pkgs deps)+                      put_ bh (dep_orphs deps)+                      put_ bh (dep_finsts deps)++    get bh = do ms <- get bh+                ps <- get bh+                os <- get bh+                fis <- get bh+                return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,+                               dep_finsts = fis })++noDependencies :: Dependencies+noDependencies = Deps [] [] [] []++-- | Records modules for which changes may force recompilation of this module+-- See wiki: http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance+--+-- This differs from Dependencies.  A module X may be in the dep_mods of this+-- module (via an import chain) but if we don't use anything from X it won't+-- appear in our Usage+data Usage+  -- | Module from another package+  = UsagePackageModule {+        usg_mod      :: Module,+           -- ^ External package module depended on+        usg_mod_hash :: Fingerprint,+            -- ^ Cached module fingerprint+        usg_safe :: IsSafeImport+            -- ^ Was this module imported as a safe import+    }+  -- | Module from the current package+  | UsageHomeModule {+        usg_mod_name :: ModuleName,+            -- ^ Name of the module+        usg_mod_hash :: Fingerprint,+            -- ^ Cached module fingerprint+        usg_entities :: [(OccName,Fingerprint)],+            -- ^ Entities we depend on, sorted by occurrence name and fingerprinted.+            -- NB: usages are for parent names only, e.g. type constructors+            -- but not the associated data constructors.+        usg_exports  :: Maybe Fingerprint,+            -- ^ Fingerprint for the export list of this module,+            -- if we directly imported it (and hence we depend on its export list)+        usg_safe :: IsSafeImport+            -- ^ Was this module imported as a safe import+    }                                           -- ^ Module from the current package+  -- | A file upon which the module depends, e.g. a CPP #include, or using TH's+  -- 'addDependentFile'+  | UsageFile {+        usg_file_path  :: FilePath,+        -- ^ External file dependency. From a CPP #include or TH+        -- addDependentFile. Should be absolute.+        usg_file_hash  :: Fingerprint+        -- ^ 'Fingerprint' of the file contents.++        -- Note: We don't consider things like modification timestamps+        -- here, because there's no reason to recompile if the actual+        -- contents don't change.  This previously lead to odd+        -- recompilation behaviors; see #8114+  }+  -- | A requirement which was merged into this one.+  | UsageMergedRequirement {+        usg_mod :: Module,+        usg_mod_hash :: Fingerprint+  }+    deriving( Eq )+        -- The export list field is (Just v) if we depend on the export list:+        --      i.e. we imported the module directly, whether or not we+        --           enumerated the things we imported, or just imported+        --           everything+        -- We need to recompile if M's exports change, because+        -- if the import was    import M,       we might now have a name clash+        --                                      in the importing module.+        -- if the import was    import M(x)     M might no longer export x+        -- The only way we don't depend on the export list is if we have+        --                      import M()+        -- And of course, for modules that aren't imported directly we don't+        -- depend on their export lists++instance Binary Usage where+    put_ bh usg@UsagePackageModule{} = do+        putByte bh 0+        put_ bh (usg_mod usg)+        put_ bh (usg_mod_hash usg)+        put_ bh (usg_safe     usg)++    put_ bh usg@UsageHomeModule{} = do+        putByte bh 1+        put_ bh (usg_mod_name usg)+        put_ bh (usg_mod_hash usg)+        put_ bh (usg_exports  usg)+        put_ bh (usg_entities usg)+        put_ bh (usg_safe     usg)++    put_ bh usg@UsageFile{} = do+        putByte bh 2+        put_ bh (usg_file_path usg)+        put_ bh (usg_file_hash usg)++    put_ bh usg@UsageMergedRequirement{} = do+        putByte bh 3+        put_ bh (usg_mod      usg)+        put_ bh (usg_mod_hash usg)++    get bh = do+        h <- getByte bh+        case h of+          0 -> do+            nm    <- get bh+            mod   <- get bh+            safe  <- get bh+            return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe }+          1 -> do+            nm    <- get bh+            mod   <- get bh+            exps  <- get bh+            ents  <- get bh+            safe  <- get bh+            return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,+                     usg_exports = exps, usg_entities = ents, usg_safe = safe }+          2 -> do+            fp   <- get bh+            hash <- get bh+            return UsageFile { usg_file_path = fp, usg_file_hash = hash }+          3 -> do+            mod <- get bh+            hash <- get bh+            return UsageMergedRequirement { usg_mod = mod, usg_mod_hash = hash }+          i -> error ("Binary.get(Usage): " ++ show i)++{-+************************************************************************+*                                                                      *+                The External Package State+*                                                                      *+************************************************************************+-}++type PackageTypeEnv          = TypeEnv+type PackageRuleBase         = RuleBase+type PackageInstEnv          = InstEnv+type PackageFamInstEnv       = FamInstEnv+type PackageVectInfo         = VectInfo+type PackageAnnEnv           = AnnEnv+type PackageCompleteMatchMap = CompleteMatchMap++-- | Information about other packages that we have slurped in by reading+-- their interface files+data ExternalPackageState+  = EPS {+        eps_is_boot :: !(ModuleNameEnv (ModuleName, IsBootInterface)),+                -- ^ In OneShot mode (only), home-package modules+                -- accumulate in the external package state, and are+                -- sucked in lazily.  For these home-pkg modules+                -- (only) we need to record which are boot modules.+                -- We set this field after loading all the+                -- explicitly-imported interfaces, but before doing+                -- anything else+                --+                -- The 'ModuleName' part is not necessary, but it's useful for+                -- debug prints, and it's convenient because this field comes+                -- direct from 'TcRnTypes.imp_dep_mods'++        eps_PIT :: !PackageIfaceTable,+                -- ^ The 'ModIface's for modules in external packages+                -- whose interfaces we have opened.+                -- The declarations in these interface files are held in the+                -- 'eps_decls', 'eps_inst_env', 'eps_fam_inst_env' and 'eps_rules'+                -- fields of this record, not in the 'mi_decls' fields of the+                -- interface we have sucked in.+                --+                -- What /is/ in the PIT is:+                --+                -- * The Module+                --+                -- * Fingerprint info+                --+                -- * Its exports+                --+                -- * Fixities+                --+                -- * Deprecations and warnings++        eps_free_holes :: InstalledModuleEnv (UniqDSet ModuleName),+                -- ^ Cache for 'mi_free_holes'.  Ordinarily, we can rely on+                -- the 'eps_PIT' for this information, EXCEPT that when+                -- we do dependency analysis, we need to look at the+                -- 'Dependencies' of our imports to determine what their+                -- precise free holes are ('moduleFreeHolesPrecise').  We+                -- don't want to repeatedly reread in the interface+                -- for every import, so cache it here.  When the PIT+                -- gets filled in we can drop these entries.++        eps_PTE :: !PackageTypeEnv,+                -- ^ Result of typechecking all the external package+                -- interface files we have sucked in. The domain of+                -- the mapping is external-package modules++        eps_inst_env     :: !PackageInstEnv,   -- ^ The total 'InstEnv' accumulated+                                               -- from all the external-package modules+        eps_fam_inst_env :: !PackageFamInstEnv,-- ^ The total 'FamInstEnv' accumulated+                                               -- from all the external-package modules+        eps_rule_base    :: !PackageRuleBase,  -- ^ The total 'RuleEnv' accumulated+                                               -- from all the external-package modules+        eps_vect_info    :: !PackageVectInfo,  -- ^ The total 'VectInfo' accumulated+                                               -- from all the external-package modules+        eps_ann_env      :: !PackageAnnEnv,    -- ^ The total 'AnnEnv' accumulated+                                               -- from all the external-package modules+        eps_complete_matches :: !PackageCompleteMatchMap,+                                  -- ^ The total 'CompleteMatchMap' accumulated+                                  -- from all the external-package modules++        eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- ^ The family instances accumulated from external+                                                         -- packages, keyed off the module that declared them++        eps_stats :: !EpsStats                 -- ^ Stastics about what was loaded from external packages+  }++-- | Accumulated statistics about what we are putting into the 'ExternalPackageState'.+-- \"In\" means stuff that is just /read/ from interface files,+-- \"Out\" means actually sucked in and type-checked+data EpsStats = EpsStats { n_ifaces_in+                         , n_decls_in, n_decls_out+                         , n_rules_in, n_rules_out+                         , n_insts_in, n_insts_out :: !Int }++addEpsInStats :: EpsStats -> Int -> Int -> Int -> EpsStats+-- ^ Add stats for one newly-read interface+addEpsInStats stats n_decls n_insts n_rules+  = stats { n_ifaces_in = n_ifaces_in stats + 1+          , n_decls_in  = n_decls_in stats + n_decls+          , n_insts_in  = n_insts_in stats + n_insts+          , n_rules_in  = n_rules_in stats + n_rules }++{-+Names in a NameCache are always stored as a Global, and have the SrcLoc+of their binding locations.++Actually that's not quite right.  When we first encounter the original+name, we might not be at its binding site (e.g. we are reading an+interface file); so we give it 'noSrcLoc' then.  Later, when we find+its binding site, we fix it up.+-}++updNameCacheIO :: HscEnv+               -> (NameCache -> (NameCache, c))  -- The updating function+               -> IO c+updNameCacheIO hsc_env upd_fn+  = atomicModifyIORef' (hsc_NC hsc_env) upd_fn++mkSOName :: Platform -> FilePath -> FilePath+mkSOName platform root+    = case platformOS platform of+      OSMinGW32 ->           root  <.> soExt platform+      _         -> ("lib" ++ root) <.> soExt platform++mkHsSOName :: Platform -> FilePath -> FilePath+mkHsSOName platform root = ("lib" ++ root) <.> soExt platform++soExt :: Platform -> FilePath+soExt platform+    = case platformOS platform of+      OSDarwin  -> "dylib"+      OSiOS     -> "dylib"+      OSMinGW32 -> "dll"+      _         -> "so"++{-+************************************************************************+*                                                                      *+                The module graph and ModSummary type+        A ModSummary is a node in the compilation manager's+        dependency graph, and it's also passed to hscMain+*                                                                      *+************************************************************************+-}++-- | A ModuleGraph contains all the nodes from the home package (only).+-- There will be a node for each source module, plus a node for each hi-boot+-- module.+--+-- The graph is not necessarily stored in topologically-sorted order.  Use+-- 'GHC.topSortModuleGraph' and 'Digraph.flattenSCC' to achieve this.+type ModuleGraph = [ModSummary]++emptyMG :: ModuleGraph+emptyMG = []++-- | A single node in a 'ModuleGraph'. The nodes of the module graph+-- are one of:+--+-- * A regular Haskell source module+-- * A hi-boot source module+--+data ModSummary+   = ModSummary {+        ms_mod          :: Module,+          -- ^ Identity of the module+        ms_hsc_src      :: HscSource,+          -- ^ The module source either plain Haskell or hs-boot+        ms_location     :: ModLocation,+          -- ^ Location of the various files belonging to the module+        ms_hs_date      :: UTCTime,+          -- ^ Timestamp of source file+        ms_obj_date     :: Maybe UTCTime,+          -- ^ Timestamp of object, if we have one+        ms_iface_date   :: Maybe UTCTime,+          -- ^ Timestamp of hi file, if we *only* are typechecking (it is+          -- 'Nothing' otherwise.+          -- See Note [Recompilation checking when typechecking only] and #9243+        ms_srcimps      :: [(Maybe FastString, Located ModuleName)],+          -- ^ Source imports of the module+        ms_textual_imps :: [(Maybe FastString, Located ModuleName)],+          -- ^ Non-source imports of the module from the module *text*+        ms_parsed_mod   :: Maybe HsParsedModule,+          -- ^ The parsed, nonrenamed source, if we have it.  This is also+          -- used to support "inline module syntax" in Backpack files.+        ms_hspp_file    :: FilePath,+          -- ^ Filename of preprocessed source file+        ms_hspp_opts    :: DynFlags,+          -- ^ Cached flags from @OPTIONS@, @INCLUDE@ and @LANGUAGE@+          -- pragmas in the modules source code+        ms_hspp_buf     :: Maybe StringBuffer+          -- ^ The actual preprocessed source, if we have it+     }++ms_installed_mod :: ModSummary -> InstalledModule+ms_installed_mod = fst . splitModuleInsts . ms_mod++ms_mod_name :: ModSummary -> ModuleName+ms_mod_name = moduleName . ms_mod++ms_imps :: ModSummary -> [(Maybe FastString, Located ModuleName)]+ms_imps ms =+  ms_textual_imps ms +++  map mk_additional_import (dynFlagDependencies (ms_hspp_opts ms))+  where+    mk_additional_import mod_nm = (Nothing, noLoc mod_nm)++-- The ModLocation contains both the original source filename and the+-- filename of the cleaned-up source file after all preprocessing has been+-- done.  The point is that the summariser will have to cpp/unlit/whatever+-- all files anyway, and there's no point in doing this twice -- just+-- park the result in a temp file, put the name of it in the location,+-- and let @compile@ read from that file on the way back up.++-- The ModLocation is stable over successive up-sweeps in GHCi, wheres+-- the ms_hs_date and imports can, of course, change++msHsFilePath, msHiFilePath, msObjFilePath :: ModSummary -> FilePath+msHsFilePath  ms = expectJust "msHsFilePath" (ml_hs_file  (ms_location ms))+msHiFilePath  ms = ml_hi_file  (ms_location ms)+msObjFilePath ms = ml_obj_file (ms_location ms)++-- | Did this 'ModSummary' originate from a hs-boot file?+isBootSummary :: ModSummary -> Bool+isBootSummary ms = ms_hsc_src ms == HsBootFile++instance Outputable ModSummary where+   ppr ms+      = sep [text "ModSummary {",+             nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)),+                          text "ms_mod =" <+> ppr (ms_mod ms)+                                <> text (hscSourceString (ms_hsc_src ms)) <> comma,+                          text "ms_textual_imps =" <+> ppr (ms_textual_imps ms),+                          text "ms_srcimps =" <+> ppr (ms_srcimps ms)]),+             char '}'+            ]++showModMsg :: DynFlags -> HscTarget -> Bool -> ModSummary -> String+showModMsg dflags target recomp mod_summary = showSDoc dflags $+   if gopt Opt_HideSourcePaths dflags+      then text mod_str+      else hsep+         [ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ')+         , char '('+         , text (op $ msHsFilePath mod_summary) <> char ','+         , case target of+              HscInterpreted | recomp -> text "interpreted"+              HscNothing              -> text "nothing"+              _                       -> text (op $ msObjFilePath mod_summary)+         , char ')'+         ]+  where+    op      = normalise+    mod     = moduleName (ms_mod mod_summary)+    mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary)++{-+************************************************************************+*                                                                      *+\subsection{Recmpilation}+*                                                                      *+************************************************************************+-}++-- | Indicates whether a given module's source has been modified since it+-- was last compiled.+data SourceModified+  = SourceModified+       -- ^ the source has been modified+  | SourceUnmodified+       -- ^ the source has not been modified.  Compilation may or may+       -- not be necessary, depending on whether any dependencies have+       -- changed since we last compiled.+  | SourceUnmodifiedAndStable+       -- ^ the source has not been modified, and furthermore all of+       -- its (transitive) dependencies are up to date; it definitely+       -- does not need to be recompiled.  This is important for two+       -- reasons: (a) we can omit the version check in checkOldIface,+       -- and (b) if the module used TH splices we don't need to force+       -- recompilation.++{-+************************************************************************+*                                                                      *+\subsection{Hpc Support}+*                                                                      *+************************************************************************+-}++-- | Information about a modules use of Haskell Program Coverage+data HpcInfo+  = HpcInfo+     { hpcInfoTickCount :: Int+     , hpcInfoHash      :: Int+     }+  | NoHpcInfo+     { hpcUsed          :: AnyHpcUsage  -- ^ Is hpc used anywhere on the module \*tree\*?+     }++-- | This is used to signal if one of my imports used HPC instrumentation+-- even if there is no module-local HPC usage+type AnyHpcUsage = Bool++emptyHpcInfo :: AnyHpcUsage -> HpcInfo+emptyHpcInfo = NoHpcInfo++-- | Find out if HPC is used by this module or any of the modules+-- it depends upon+isHpcUsed :: HpcInfo -> AnyHpcUsage+isHpcUsed (HpcInfo {})                   = True+isHpcUsed (NoHpcInfo { hpcUsed = used }) = used++{-+************************************************************************+*                                                                      *+\subsection{Vectorisation Support}+*                                                                      *+************************************************************************++The following information is generated and consumed by the vectorisation+subsystem.  It communicates the vectorisation status of declarations from one+module to another.++Why do we need both f and f_v in the ModGuts/ModDetails/EPS version VectInfo+below?  We need to know `f' when converting to IfaceVectInfo.  However, during+vectorisation, we need to know `f_v', whose `Var' we cannot lookup based+on just the OccName easily in a Core pass.+-}++-- |Vectorisation information for 'ModGuts', 'ModDetails' and 'ExternalPackageState'; see also+-- documentation at 'Vectorise.Env.GlobalEnv'.+--+-- NB: The following tables may also include 'Var's, 'TyCon's and 'DataCon's from imported modules,+--     which have been subsequently vectorised in the current module.+--+data VectInfo+  = VectInfo+    { vectInfoVar            :: DVarEnv (Var    , Var  )    -- ^ @(f, f_v)@ keyed on @f@+    , vectInfoTyCon          :: NameEnv (TyCon  , TyCon)    -- ^ @(T, T_v)@ keyed on @T@+    , vectInfoDataCon        :: NameEnv (DataCon, DataCon)  -- ^ @(C, C_v)@ keyed on @C@+    , vectInfoParallelVars   :: DVarSet                     -- ^ set of parallel variables+    , vectInfoParallelTyCons :: NameSet                     -- ^ set of parallel type constructors+    }++-- |Vectorisation information for 'ModIface'; i.e, the vectorisation information propagated+-- across module boundaries.+--+-- NB: The field 'ifaceVectInfoVar' explicitly contains the workers of data constructors as well as+--     class selectors — i.e., their mappings are /not/ implicitly generated from the data types.+--     Moreover, whether the worker of a data constructor is in 'ifaceVectInfoVar' determines+--     whether that data constructor was vectorised (or is part of an abstractly vectorised type+--     constructor).+--+data IfaceVectInfo+  = IfaceVectInfo+    { ifaceVectInfoVar            :: [Name]  -- ^ All variables in here have a vectorised variant+    , ifaceVectInfoTyCon          :: [Name]  -- ^ All 'TyCon's in here have a vectorised variant;+                                             -- the name of the vectorised variant and those of its+                                             -- data constructors are determined by+                                             -- 'OccName.mkVectTyConOcc' and+                                             -- 'OccName.mkVectDataConOcc'; the names of the+                                             -- isomorphisms are determined by 'OccName.mkVectIsoOcc'+    , ifaceVectInfoTyConReuse     :: [Name]  -- ^ The vectorised form of all the 'TyCon's in here+                                             -- coincides with the unconverted form; the name of the+                                             -- isomorphisms is determined by 'OccName.mkVectIsoOcc'+    , ifaceVectInfoParallelVars   :: [Name]  -- iface version of 'vectInfoParallelVar'+    , ifaceVectInfoParallelTyCons :: [Name]  -- iface version of 'vectInfoParallelTyCon'+    }++noVectInfo :: VectInfo+noVectInfo+  = VectInfo emptyDVarEnv emptyNameEnv emptyNameEnv emptyDVarSet emptyNameSet++plusVectInfo :: VectInfo -> VectInfo -> VectInfo+plusVectInfo vi1 vi2 =+  VectInfo (vectInfoVar            vi1 `plusDVarEnv`   vectInfoVar            vi2)+           (vectInfoTyCon          vi1 `plusNameEnv`   vectInfoTyCon          vi2)+           (vectInfoDataCon        vi1 `plusNameEnv`   vectInfoDataCon        vi2)+           (vectInfoParallelVars   vi1 `unionDVarSet`  vectInfoParallelVars   vi2)+           (vectInfoParallelTyCons vi1 `unionNameSet` vectInfoParallelTyCons vi2)++concatVectInfo :: [VectInfo] -> VectInfo+concatVectInfo = foldr plusVectInfo noVectInfo++noIfaceVectInfo :: IfaceVectInfo+noIfaceVectInfo = IfaceVectInfo [] [] [] [] []++isNoIfaceVectInfo :: IfaceVectInfo -> Bool+isNoIfaceVectInfo (IfaceVectInfo l1 l2 l3 l4 l5)+  = null l1 && null l2 && null l3 && null l4 && null l5++instance Outputable VectInfo where+  ppr info = vcat+             [ text "variables       :" <+> ppr (vectInfoVar            info)+             , text "tycons          :" <+> ppr (vectInfoTyCon          info)+             , text "datacons        :" <+> ppr (vectInfoDataCon        info)+             , text "parallel vars   :" <+> ppr (vectInfoParallelVars   info)+             , text "parallel tycons :" <+> ppr (vectInfoParallelTyCons info)+             ]++instance Outputable IfaceVectInfo where+  ppr info = vcat+             [ text "variables       :" <+> ppr (ifaceVectInfoVar            info)+             , text "tycons          :" <+> ppr (ifaceVectInfoTyCon          info)+             , text "tycons reuse    :" <+> ppr (ifaceVectInfoTyConReuse     info)+             , text "parallel vars   :" <+> ppr (ifaceVectInfoParallelVars   info)+             , text "parallel tycons :" <+> ppr (ifaceVectInfoParallelTyCons info)+             ]+++instance Binary IfaceVectInfo where+    put_ bh (IfaceVectInfo a1 a2 a3 a4 a5) = do+        put_ bh a1+        put_ bh a2+        put_ bh a3+        put_ bh a4+        put_ bh a5+    get bh = do+        a1 <- get bh+        a2 <- get bh+        a3 <- get bh+        a4 <- get bh+        a5 <- get bh+        return (IfaceVectInfo a1 a2 a3 a4 a5)++{-+************************************************************************+*                                                                      *+\subsection{Safe Haskell Support}+*                                                                      *+************************************************************************++This stuff here is related to supporting the Safe Haskell extension,+primarily about storing under what trust type a module has been compiled.+-}++-- | Is an import a safe import?+type IsSafeImport = Bool++-- | Safe Haskell information for 'ModIface'+-- Simply a wrapper around SafeHaskellMode to sepperate iface and flags+newtype IfaceTrustInfo = TrustInfo SafeHaskellMode++getSafeMode :: IfaceTrustInfo -> SafeHaskellMode+getSafeMode (TrustInfo x) = x++setSafeMode :: SafeHaskellMode -> IfaceTrustInfo+setSafeMode = TrustInfo++noIfaceTrustInfo :: IfaceTrustInfo+noIfaceTrustInfo = setSafeMode Sf_None++trustInfoToNum :: IfaceTrustInfo -> Word8+trustInfoToNum it+  = case getSafeMode it of+            Sf_None         -> 0+            Sf_Unsafe       -> 1+            Sf_Trustworthy  -> 2+            Sf_Safe         -> 3++numToTrustInfo :: Word8 -> IfaceTrustInfo+numToTrustInfo 0 = setSafeMode Sf_None+numToTrustInfo 1 = setSafeMode Sf_Unsafe+numToTrustInfo 2 = setSafeMode Sf_Trustworthy+numToTrustInfo 3 = setSafeMode Sf_Safe+numToTrustInfo 4 = setSafeMode Sf_Safe -- retained for backwards compat, used+                                       -- to be Sf_SafeInfered but we no longer+                                       -- differentiate.+numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")"++instance Outputable IfaceTrustInfo where+    ppr (TrustInfo Sf_None)          = text "none"+    ppr (TrustInfo Sf_Unsafe)        = text "unsafe"+    ppr (TrustInfo Sf_Trustworthy)   = text "trustworthy"+    ppr (TrustInfo Sf_Safe)          = text "safe"++instance Binary IfaceTrustInfo where+    put_ bh iftrust = putByte bh $ trustInfoToNum iftrust+    get bh = getByte bh >>= (return . numToTrustInfo)++{-+************************************************************************+*                                                                      *+\subsection{Parser result}+*                                                                      *+************************************************************************+-}++data HsParsedModule = HsParsedModule {+    hpm_module    :: Located (HsModule RdrName),+    hpm_src_files :: [FilePath],+       -- ^ extra source files (e.g. from #includes).  The lexer collects+       -- these from '# <file> <line>' pragmas, which the C preprocessor+       -- leaves behind.  These files and their timestamps are stored in+       -- the .hi file, so that we can force recompilation if any of+       -- them change (#3589)+    hpm_annotations :: ApiAnns+    -- See note [Api annotations] in ApiAnnotation.hs+  }++{-+************************************************************************+*                                                                      *+\subsection{Linkable stuff}+*                                                                      *+************************************************************************++This stuff is in here, rather than (say) in Linker.hs, because the Linker.hs+stuff is the *dynamic* linker, and isn't present in a stage-1 compiler+-}++-- | Information we can use to dynamically link modules into the compiler+data Linkable = LM {+  linkableTime     :: UTCTime,          -- ^ Time at which this linkable was built+                                        -- (i.e. when the bytecodes were produced,+                                        --       or the mod date on the files)+  linkableModule   :: Module,           -- ^ The linkable module itself+  linkableUnlinked :: [Unlinked]+    -- ^ Those files and chunks of code we have yet to link.+    --+    -- INVARIANT: A valid linkable always has at least one 'Unlinked' item.+    -- If this list is empty, the Linkable represents a fake linkable, which+    -- is generated in HscNothing mode to avoid recompiling modules.+    --+    -- ToDo: Do items get removed from this list when they get linked?+ }++isObjectLinkable :: Linkable -> Bool+isObjectLinkable l = not (null unlinked) && all isObject unlinked+  where unlinked = linkableUnlinked l+        -- A linkable with no Unlinked's is treated as a BCO.  We can+        -- generate a linkable with no Unlinked's as a result of+        -- compiling a module in HscNothing mode, and this choice+        -- happens to work well with checkStability in module GHC.++linkableObjs :: Linkable -> [FilePath]+linkableObjs l = [ f | DotO f <- linkableUnlinked l ]++instance Outputable Linkable where+   ppr (LM when_made mod unlinkeds)+      = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod)+        $$ nest 3 (ppr unlinkeds)++-------------------------------------------++-- | Objects which have yet to be linked by the compiler+data Unlinked+   = DotO FilePath      -- ^ An object file (.o)+   | DotA FilePath      -- ^ Static archive file (.a)+   | DotDLL FilePath    -- ^ Dynamically linked library file (.so, .dll, .dylib)+   | BCOs CompiledByteCode+          [SptEntry]    -- ^ A byte-code object, lives only in memory. Also+                        -- carries some static pointer table entries which+                        -- should be loaded along with the BCOs.+                        -- See Note [Grant plan for static forms] in+                        -- StaticPtrTable.++instance Outputable Unlinked where+   ppr (DotO path)   = text "DotO" <+> text path+   ppr (DotA path)   = text "DotA" <+> text path+   ppr (DotDLL path) = text "DotDLL" <+> text path+   ppr (BCOs bcos spt) = text "BCOs" <+> ppr bcos <+> ppr spt++-- | Is this an actual file on disk we can link in somehow?+isObject :: Unlinked -> Bool+isObject (DotO _)   = True+isObject (DotA _)   = True+isObject (DotDLL _) = True+isObject _          = False++-- | Is this a bytecode linkable with no file on disk?+isInterpretable :: Unlinked -> Bool+isInterpretable = not . isObject++-- | Retrieve the filename of the linkable if possible. Panic if it is a byte-code object+nameOfObject :: Unlinked -> FilePath+nameOfObject (DotO fn)   = fn+nameOfObject (DotA fn)   = fn+nameOfObject (DotDLL fn) = fn+nameOfObject other       = pprPanic "nameOfObject" (ppr other)++-- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable+byteCodeOfObject :: Unlinked -> CompiledByteCode+byteCodeOfObject (BCOs bc _) = bc+byteCodeOfObject other       = pprPanic "byteCodeOfObject" (ppr other)+++-------------------------------------------++-- | A list of conlikes which represents a complete pattern match.+-- These arise from @COMPLETE@ signatures.++-- See Note [Implementation of COMPLETE signatures]+data CompleteMatch = CompleteMatch {+                            completeMatchConLikes :: [Name]+                            -- ^ The ConLikes that form a covering family+                            -- (e.g. Nothing, Just)+                          , completeMatchTyCon :: Name+                            -- ^ The TyCon that they cover (e.g. Maybe)+                          }++instance Outputable CompleteMatch where+  ppr (CompleteMatch cl ty) = text "CompleteMatch:" <+> ppr cl+                                                    <+> dcolon <+> ppr ty++-- | A map keyed by the 'completeMatchTyCon'.++-- See Note [Implementation of COMPLETE signatures]+type CompleteMatchMap = UniqFM [CompleteMatch]++mkCompleteMatchMap :: [CompleteMatch] -> CompleteMatchMap+mkCompleteMatchMap = extendCompleteMatchMap emptyUFM++extendCompleteMatchMap :: CompleteMatchMap -> [CompleteMatch]+                       -> CompleteMatchMap+extendCompleteMatchMap = foldl' insertMatch+  where+    insertMatch :: CompleteMatchMap -> CompleteMatch -> CompleteMatchMap+    insertMatch ufm c@(CompleteMatch _ t) = addToUFM_C (++) ufm t [c]++{-+Note [Implementation of COMPLETE signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A COMPLETE signature represents a set of conlikes (i.e., constructors or+pattern synonyms) such that if they are all pattern-matched against in a+function, it gives rise to a total function. An example is:++  newtype Boolean = Boolean Int+  pattern F, T :: Boolean+  pattern F = Boolean 0+  pattern T = Boolean 1+  {-# COMPLETE F, T #-}++  -- This is a total function+  booleanToInt :: Boolean -> Int+  booleanToInt F = 0+  booleanToInt T = 1++COMPLETE sets are represented internally in GHC with the CompleteMatch data+type. For example, {-# COMPLETE F, T #-} would be represented as:++  CompleteMatch { complateMatchConLikes = [F, T]+                , completeMatchTyCon    = Boolean }++Note that GHC was able to infer the completeMatchTyCon (Boolean), but for the+cases in which it's ambiguous, you can also explicitly specify it in the source+language by writing this:++  {-# COMPLETE F, T :: Boolean #-}++For efficiency purposes, GHC collects all of the CompleteMatches that it knows+about into a CompleteMatchMap, which is a map that is keyed by the+completeMatchTyCon. In other words, you could have a multiple COMPLETE sets+for the same TyCon:++  {-# COMPLETE F, T1 :: Boolean #-}+  {-# COMPLETE F, T2 :: Boolean #-}++And looking up the values in the CompleteMatchMap associated with Boolean+would give you [CompleteMatch [F, T1] Boolean, CompleteMatch [F, T2] Boolean].+dsGetCompleteMatches in DsMeta accomplishes this lookup.++Also see Note [Typechecking Complete Matches] in TcBinds for a more detailed+explanation for how GHC ensures that all the conlikes in a COMPLETE set are+consistent.+-}
+ main/InteractiveEval.hs view
@@ -0,0 +1,937 @@+{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, UnboxedTuples,+    RecordWildCards, BangPatterns #-}++-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow, 2005-2007+--+-- Running statements interactively+--+-- -----------------------------------------------------------------------------++module InteractiveEval (+        Resume(..), History(..),+        execStmt, ExecOptions(..), execOptions, ExecResult(..), resumeExec,+        runDecls, runDeclsWithLocation,+        isStmt, hasImport, isImport, isDecl,+        parseImportDecl, SingleStep(..),+        abandon, abandonAll,+        getResumeContext,+        getHistorySpan,+        getModBreaks,+        getHistoryModule,+        back, forward,+        setContext, getContext,+        availsToGlobalRdrEnv,+        getNamesInScope,+        getRdrNamesInScope,+        moduleIsInterpreted,+        getInfo,+        exprType,+        typeKind,+        parseName,+        showModule,+        moduleIsBootOrNotObjectLinkable,+        parseExpr, compileParsedExpr,+        compileExpr, dynCompileExpr,+        compileExprRemote, compileParsedExprRemote,+        Term(..), obtainTermFromId, obtainTermFromVal, reconstructType+        ) where++#include "HsVersions.h"++import InteractiveEvalTypes++import GHCi+import GHCi.Message+import GHCi.RemoteTypes+import GhcMonad+import HscMain+import HsSyn+import HscTypes+import InstEnv+import IfaceEnv   ( newInteractiveBinder )+import FamInstEnv ( FamInst )+import CoreFVs    ( orphNamesOfFamInst )+import TyCon+import Type             hiding( typeKind )+import RepType+import TcType           hiding( typeKind )+import Var+import Id+import Name             hiding ( varName )+import NameSet+import Avail+import RdrName+import VarEnv+import ByteCodeTypes+import Linker+import DynFlags+import Unique+import UniqSupply+import MonadUtils+import Module+import PrelNames  ( toDynName, pretendNameIsInScope )+import Panic+import Maybes+import ErrUtils+import SrcLoc+import RtClosureInspect+import Outputable+import FastString+import Bag+import qualified Lexer (P (..), ParseResult(..), unP, mkPState)+import qualified Parser (parseStmt, parseModule, parseDeclaration, parseImport)++import System.Directory+import Data.Dynamic+import Data.Either+import qualified Data.IntMap as IntMap+import Data.List (find,intercalate)+import StringBuffer (stringToStringBuffer)+import Control.Monad+import GHC.Exts+import Data.Array+import Exception++-- -----------------------------------------------------------------------------+-- running a statement interactively++getResumeContext :: GhcMonad m => m [Resume]+getResumeContext = withSession (return . ic_resume . hsc_IC)++mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History+mkHistory hsc_env hval bi = History hval bi (findEnclosingDecls hsc_env bi)++getHistoryModule :: History -> Module+getHistoryModule = breakInfo_module . historyBreakInfo++getHistorySpan :: HscEnv -> History -> SrcSpan+getHistorySpan hsc_env History{..} =+  let BreakInfo{..} = historyBreakInfo in+  case lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module) of+    Just hmi -> modBreaks_locs (getModBreaks hmi) ! breakInfo_number+    _ -> panic "getHistorySpan"++getModBreaks :: HomeModInfo -> ModBreaks+getModBreaks hmi+  | Just linkable <- hm_linkable hmi,+    [BCOs cbc _] <- linkableUnlinked linkable+  = fromMaybe emptyModBreaks (bc_breaks cbc)+  | otherwise+  = emptyModBreaks -- probably object code++{- | Finds the enclosing top level function name -}+-- ToDo: a better way to do this would be to keep hold of the decl_path computed+-- by the coverage pass, which gives the list of lexically-enclosing bindings+-- for each tick.+findEnclosingDecls :: HscEnv -> BreakInfo -> [String]+findEnclosingDecls hsc_env (BreakInfo modl ix) =+   let hmi = expectJust "findEnclosingDecls" $+             lookupHpt (hsc_HPT hsc_env) (moduleName modl)+       mb = getModBreaks hmi+   in modBreaks_decls mb ! ix++-- | Update fixity environment in the current interactive context.+updateFixityEnv :: GhcMonad m => FixityEnv -> m ()+updateFixityEnv fix_env = do+  hsc_env <- getSession+  let ic = hsc_IC hsc_env+  setSession $ hsc_env { hsc_IC = ic { ic_fix_env = fix_env } }++-- -----------------------------------------------------------------------------+-- execStmt++-- | default ExecOptions+execOptions :: ExecOptions+execOptions = ExecOptions+  { execSingleStep = RunToCompletion+  , execSourceFile = "<interactive>"+  , execLineNumber = 1+  , execWrap = EvalThis -- just run the statement, don't wrap it in anything+  }++-- | Run a statement in the current interactive context.+execStmt+  :: GhcMonad m+  => String             -- ^ a statement (bind or expression)+  -> ExecOptions+  -> m ExecResult+execStmt stmt ExecOptions{..} = do+    hsc_env <- getSession++    -- Turn off -fwarn-unused-local-binds when running a statement, to hide+    -- warnings about the implicit bindings we introduce.+    let ic       = hsc_IC hsc_env -- use the interactive dflags+        idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedLocalBinds+        hsc_env' = hsc_env{ hsc_IC = ic{ ic_dflags = idflags' } }++    -- compile to value (IO [HValue]), don't run+    r <- liftIO $ hscStmtWithLocation hsc_env' stmt+                    execSourceFile execLineNumber++    case r of+      -- empty statement / comment+      Nothing -> return (ExecComplete (Right []) 0)++      Just (ids, hval, fix_env) -> do+        updateFixityEnv fix_env++        status <-+          withVirtualCWD $+            liftIO $+              evalStmt hsc_env' (isStep execSingleStep) (execWrap hval)++        let ic = hsc_IC hsc_env+            bindings = (ic_tythings ic, ic_rn_gbl_env ic)++            size = ghciHistSize idflags'++        handleRunStatus execSingleStep stmt bindings ids+                        status (emptyHistory size)+++runDecls :: GhcMonad m => String -> m [Name]+runDecls = runDeclsWithLocation "<interactive>" 1++-- | Run some declarations and return any user-visible names that were brought+-- into scope.+runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name]+runDeclsWithLocation source linenumber expr =+  do+    hsc_env <- getSession+    (tyThings, ic) <- liftIO $ hscDeclsWithLocation hsc_env expr source linenumber++    setSession $ hsc_env { hsc_IC = ic }+    hsc_env <- getSession+    hsc_env' <- liftIO $ rttiEnvironment hsc_env+    setSession hsc_env'+    return $ filter (not . isDerivedOccName . nameOccName)+             -- For this filter, see Note [What to show to users]+           $ map getName tyThings++{- Note [What to show to users]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don't want to display internally-generated bindings to users.+Things like the coercion axiom for newtypes. These bindings all get+OccNames that users can't write, to avoid the possiblity of name+clashes (in linker symbols).  That gives a convenient way to suppress+them. The relevant predicate is OccName.isDerivedOccName.+See Trac #11051 for more background and examples.+-}++withVirtualCWD :: GhcMonad m => m a -> m a+withVirtualCWD m = do+  hsc_env <- getSession++    -- a virtual CWD is only necessary when we're running interpreted code in+    -- the same process as the compiler.+  if gopt Opt_ExternalInterpreter (hsc_dflags hsc_env) then m else do++  let ic = hsc_IC hsc_env+  let set_cwd = do+        dir <- liftIO $ getCurrentDirectory+        case ic_cwd ic of+           Just dir -> liftIO $ setCurrentDirectory dir+           Nothing  -> return ()+        return dir++      reset_cwd orig_dir = do+        virt_dir <- liftIO $ getCurrentDirectory+        hsc_env <- getSession+        let old_IC = hsc_IC hsc_env+        setSession hsc_env{  hsc_IC = old_IC{ ic_cwd = Just virt_dir } }+        liftIO $ setCurrentDirectory orig_dir++  gbracket set_cwd reset_cwd $ \_ -> m++parseImportDecl :: GhcMonad m => String -> m (ImportDecl RdrName)+parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr++emptyHistory :: Int -> BoundedList History+emptyHistory size = nilBL size++handleRunStatus :: GhcMonad m+                => SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id]+                -> EvalStatus_ [ForeignHValue] [HValueRef]+                -> BoundedList History+                -> m ExecResult++handleRunStatus step expr bindings final_ids status history+  | RunAndLogSteps <- step = tracing+  | otherwise              = not_tracing+ where+  tracing+    | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt _ccs <- status+    , not is_exception+    = do+       hsc_env <- getSession+       let hmi = expectJust "handleRunStatus" $+                   lookupHptDirectly (hsc_HPT hsc_env)+                                     (mkUniqueGrimily mod_uniq)+           modl = mi_module (hm_iface hmi)+           breaks = getModBreaks hmi++       b <- liftIO $+              breakpointStatus hsc_env (modBreaks_flags breaks) ix+       if b+         then not_tracing+           -- This breakpoint is explicitly enabled; we want to stop+           -- instead of just logging it.+         else do+           apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref+           let bi = BreakInfo modl ix+               !history' = mkHistory hsc_env apStack_fhv bi `consBL` history+                 -- history is strict, otherwise our BoundedList is pointless.+           fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt+           status <- liftIO $ GHCi.resumeStmt hsc_env True fhv+           handleRunStatus RunAndLogSteps expr bindings final_ids+                           status history'+    | otherwise+    = not_tracing++  not_tracing+    -- Hit a breakpoint+    | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt ccs <- status+    = do+         hsc_env <- getSession+         resume_ctxt_fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt+         apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref+         let hmi = expectJust "handleRunStatus" $+                     lookupHptDirectly (hsc_HPT hsc_env)+                                       (mkUniqueGrimily mod_uniq)+             modl = mi_module (hm_iface hmi)+             bp | is_exception = Nothing+                | otherwise = Just (BreakInfo modl ix)+         (hsc_env1, names, span, decl) <- liftIO $+           bindLocalsAtBreakpoint hsc_env apStack_fhv bp+         let+           resume = Resume+             { resumeStmt = expr, resumeContext = resume_ctxt_fhv+             , resumeBindings = bindings, resumeFinalIds = final_ids+             , resumeApStack = apStack_fhv+             , resumeBreakInfo = bp+             , resumeSpan = span, resumeHistory = toListBL history+             , resumeDecl = decl+             , resumeCCS = ccs+             , resumeHistoryIx = 0 }+           hsc_env2 = pushResume hsc_env1 resume++         setSession hsc_env2+         return (ExecBreak names bp)++    -- Completed successfully+    | EvalComplete allocs (EvalSuccess hvals) <- status+    = do hsc_env <- getSession+         let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids+             final_names = map getName final_ids+         liftIO $ Linker.extendLinkEnv (zip final_names hvals)+         hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}+         setSession hsc_env'+         return (ExecComplete (Right final_names) allocs)++    -- Completed with an exception+    | EvalComplete alloc (EvalException e) <- status+    = return (ExecComplete (Left (fromSerializableException e)) alloc)++    | otherwise+    = panic "not_tracing" -- actually exhaustive, but GHC can't tell+++resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m ExecResult+resumeExec canLogSpan step+ = do+   hsc_env <- getSession+   let ic = hsc_IC hsc_env+       resume = ic_resume ic++   case resume of+     [] -> liftIO $+           throwGhcExceptionIO (ProgramError "not stopped at a breakpoint")+     (r:rs) -> do+        -- unbind the temporary locals by restoring the TypeEnv from+        -- before the breakpoint, and drop this Resume from the+        -- InteractiveContext.+        let (resume_tmp_te,resume_rdr_env) = resumeBindings r+            ic' = ic { ic_tythings = resume_tmp_te,+                       ic_rn_gbl_env = resume_rdr_env,+                       ic_resume   = rs }+        setSession hsc_env{ hsc_IC = ic' }++        -- remove any bindings created since the breakpoint from the+        -- linker's environment+        let old_names = map getName resume_tmp_te+            new_names = [ n | thing <- ic_tythings ic+                            , let n = getName thing+                            , not (n `elem` old_names) ]+        liftIO $ Linker.deleteFromLinkEnv new_names++        case r of+          Resume { resumeStmt = expr, resumeContext = fhv+                 , resumeBindings = bindings, resumeFinalIds = final_ids+                 , resumeApStack = apStack, resumeBreakInfo = mb_brkpt+                 , resumeSpan = span+                 , resumeHistory = hist } -> do+               withVirtualCWD $ do+                status <- liftIO $ GHCi.resumeStmt hsc_env (isStep step) fhv+                let prevHistoryLst = fromListBL 50 hist+                    hist' = case mb_brkpt of+                       Nothing -> prevHistoryLst+                       Just bi+                         | not $canLogSpan span -> prevHistoryLst+                         | otherwise -> mkHistory hsc_env apStack bi `consBL`+                                                        fromListBL 50 hist+                handleRunStatus step expr bindings final_ids status hist'++back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)+back n = moveHist (+n)++forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)+forward n = moveHist (subtract n)++moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan, String)+moveHist fn = do+  hsc_env <- getSession+  case ic_resume (hsc_IC hsc_env) of+     [] -> liftIO $+           throwGhcExceptionIO (ProgramError "not stopped at a breakpoint")+     (r:rs) -> do+        let ix = resumeHistoryIx r+            history = resumeHistory r+            new_ix = fn ix+        --+        when (new_ix > length history) $ liftIO $+           throwGhcExceptionIO (ProgramError "no more logged breakpoints")+        when (new_ix < 0) $ liftIO $+           throwGhcExceptionIO (ProgramError "already at the beginning of the history")++        let+          update_ic apStack mb_info = do+            (hsc_env1, names, span, decl) <-+              liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info+            let ic = hsc_IC hsc_env1+                r' = r { resumeHistoryIx = new_ix }+                ic' = ic { ic_resume = r':rs }++            setSession hsc_env1{ hsc_IC = ic' }++            return (names, new_ix, span, decl)++        -- careful: we want apStack to be the AP_STACK itself, not a thunk+        -- around it, hence the cases are carefully constructed below to+        -- make this the case.  ToDo: this is v. fragile, do something better.+        if new_ix == 0+           then case r of+                   Resume { resumeApStack = apStack,+                            resumeBreakInfo = mb_brkpt } ->+                          update_ic apStack mb_brkpt+           else case history !! (new_ix - 1) of+                   History{..} ->+                     update_ic historyApStack (Just historyBreakInfo)+++-- -----------------------------------------------------------------------------+-- After stopping at a breakpoint, add free variables to the environment++result_fs :: FastString+result_fs = fsLit "_result"++bindLocalsAtBreakpoint+        :: HscEnv+        -> ForeignHValue+        -> Maybe BreakInfo+        -> IO (HscEnv, [Name], SrcSpan, String)++-- Nothing case: we stopped when an exception was raised, not at a+-- breakpoint.  We have no location information or local variables to+-- bind, all we can do is bind a local variable to the exception+-- value.+bindLocalsAtBreakpoint hsc_env apStack Nothing = do+   let exn_occ = mkVarOccFS (fsLit "_exception")+       span    = mkGeneralSrcSpan (fsLit "<unknown>")+   exn_name <- newInteractiveBinder hsc_env exn_occ span++   let e_fs    = fsLit "e"+       e_name  = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span+       e_tyvar = mkRuntimeUnkTyVar e_name liftedTypeKind+       exn_id  = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)++       ictxt0 = hsc_IC hsc_env+       ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id]+   --+   Linker.extendLinkEnv [(exn_name, apStack)]+   return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "<exception thrown>")++-- Just case: we stopped at a breakpoint, we have information about the location+-- of the breakpoint and the free variables of the expression.+bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do+   let+       hmi       = expectJust "bindLocalsAtBreakpoint" $+                     lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module)+       breaks    = getModBreaks hmi+       info      = expectJust "bindLocalsAtBreakpoint2" $+                     IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks)+       vars      = cgb_vars info+       result_ty = cgb_resty info+       occs      = modBreaks_vars breaks ! breakInfo_number+       span      = modBreaks_locs breaks ! breakInfo_number+       decl      = intercalate "." $ modBreaks_decls breaks ! breakInfo_number++           -- Filter out any unboxed ids;+           -- we can't bind these at the prompt+       pointers = filter (\(id,_) -> isPointer id) vars+       isPointer id | [rep] <- typePrimRep (idType id)+                    , isGcPtrRep rep                   = True+                    | otherwise                        = False++       (ids, offsets) = unzip pointers++       free_tvs = tyCoVarsOfTypesList (result_ty:map idType ids)++   -- It might be that getIdValFromApStack fails, because the AP_STACK+   -- has been accidentally evaluated, or something else has gone wrong.+   -- So that we don't fall over in a heap when this happens, just don't+   -- bind any free variables instead, and we emit a warning.+   mb_hValues <-+      mapM (getBreakpointVar hsc_env apStack_fhv . fromIntegral) offsets+   when (any isNothing mb_hValues) $+      debugTraceMsg (hsc_dflags hsc_env) 1 $+          text "Warning: _result has been evaluated, some bindings have been lost"++   us <- mkSplitUniqSupply 'I'   -- Dodgy; will give the same uniques every time+   let tv_subst     = newTyVars us free_tvs+       filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]+       (_,tidy_tys) = tidyOpenTypes emptyTidyEnv $+                      map (substTy tv_subst . idType) filtered_ids++   new_ids     <- zipWith3M mkNewId occs tidy_tys filtered_ids+   result_name <- newInteractiveBinder hsc_env (mkVarOccFS result_fs) span++   let result_id = Id.mkVanillaGlobal result_name+                     (substTy tv_subst result_ty)+       result_ok = isPointer result_id++       final_ids | result_ok = result_id : new_ids+                 | otherwise = new_ids+       ictxt0 = hsc_IC hsc_env+       ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids+       names  = map idName new_ids++   let fhvs = catMaybes mb_hValues+   Linker.extendLinkEnv (zip names fhvs)+   when result_ok $ Linker.extendLinkEnv [(result_name, apStack_fhv)]+   hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }+   return (hsc_env1, if result_ok then result_name:names else names, span, decl)+  where+        -- We need a fresh Unique for each Id we bind, because the linker+        -- state is single-threaded and otherwise we'd spam old bindings+        -- whenever we stop at a breakpoint.  The InteractveContext is properly+        -- saved/restored, but not the linker state.  See #1743, test break026.+   mkNewId :: OccName -> Type -> Id -> IO Id+   mkNewId occ ty old_id+     = do { name <- newInteractiveBinder hsc_env occ (getSrcSpan old_id)+          ; return (Id.mkVanillaGlobalWithInfo name ty (idInfo old_id)) }++   newTyVars :: UniqSupply -> [TcTyVar] -> TCvSubst+     -- Similarly, clone the type variables mentioned in the types+     -- we have here, *and* make them all RuntimeUnk tyvars+   newTyVars us tvs+     = mkTvSubstPrs [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv)))+                    | (tv, uniq) <- tvs `zip` uniqsFromSupply us+                    , let name = setNameUnique (tyVarName tv) uniq ]++rttiEnvironment :: HscEnv -> IO HscEnv+rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do+   let tmp_ids = [id | AnId id <- ic_tythings ic]+       incompletelyTypedIds =+           [id | id <- tmp_ids+               , not $ noSkolems id+               , (occNameFS.nameOccName.idName) id /= result_fs]+   hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)+   return hsc_env'+    where+     noSkolems = noFreeVarsOfType . idType+     improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do+      let tmp_ids = [id | AnId id <- ic_tythings ic]+          Just id = find (\i -> idName i == name) tmp_ids+      if noSkolems id+         then return hsc_env+         else do+           mb_new_ty <- reconstructType hsc_env 10 id+           let old_ty = idType id+           case mb_new_ty of+             Nothing -> return hsc_env+             Just new_ty -> do+              case improveRTTIType hsc_env old_ty new_ty of+               Nothing -> return $+                        WARN(True, text (":print failed to calculate the "+                                           ++ "improvement for a type")) hsc_env+               Just subst -> do+                 let dflags = hsc_dflags hsc_env+                 when (dopt Opt_D_dump_rtti dflags) $+                      printInfoForUser dflags alwaysQualify $+                      fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]++                 let ic' = substInteractiveContext ic subst+                 return hsc_env{hsc_IC=ic'}++pushResume :: HscEnv -> Resume -> HscEnv+pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }+  where+        ictxt0 = hsc_IC hsc_env+        ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }++-- -----------------------------------------------------------------------------+-- Abandoning a resume context++abandon :: GhcMonad m => m Bool+abandon = do+   hsc_env <- getSession+   let ic = hsc_IC hsc_env+       resume = ic_resume ic+   case resume of+      []    -> return False+      r:rs  -> do+         setSession hsc_env{ hsc_IC = ic { ic_resume = rs } }+         liftIO $ abandonStmt hsc_env (resumeContext r)+         return True++abandonAll :: GhcMonad m => m Bool+abandonAll = do+   hsc_env <- getSession+   let ic = hsc_IC hsc_env+       resume = ic_resume ic+   case resume of+      []  -> return False+      rs  -> do+         setSession hsc_env{ hsc_IC = ic { ic_resume = [] } }+         liftIO $ mapM_ (abandonStmt hsc_env. resumeContext) rs+         return True++-- -----------------------------------------------------------------------------+-- Bounded list, optimised for repeated cons++data BoundedList a = BL+                        {-# UNPACK #-} !Int  -- length+                        {-# UNPACK #-} !Int  -- bound+                        [a] -- left+                        [a] -- right,  list is (left ++ reverse right)++nilBL :: Int -> BoundedList a+nilBL bound = BL 0 bound [] []++consBL :: a -> BoundedList a -> BoundedList a+consBL a (BL len bound left right)+  | len < bound = BL (len+1) bound (a:left) right+  | null right  = BL len     bound [a]      $! tail (reverse left)+  | otherwise   = BL len     bound (a:left) $! tail right++toListBL :: BoundedList a -> [a]+toListBL (BL _ _ left right) = left ++ reverse right++fromListBL :: Int -> [a] -> BoundedList a+fromListBL bound l = BL (length l) bound l []++-- lenBL (BL len _ _ _) = len++-- -----------------------------------------------------------------------------+-- | Set the interactive evaluation context.+--+-- (setContext imports) sets the ic_imports field (which in turn+-- determines what is in scope at the prompt) to 'imports', and+-- constructs the ic_rn_glb_env environment to reflect it.+--+-- We retain in scope all the things defined at the prompt, and kept+-- in ic_tythings.  (Indeed, they shadow stuff from ic_imports.)++setContext :: GhcMonad m => [InteractiveImport] -> m ()+setContext imports+  = do { hsc_env <- getSession+       ; let dflags = hsc_dflags hsc_env+       ; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports+       ; case all_env_err of+           Left (mod, err) ->+               liftIO $ throwGhcExceptionIO (formatError dflags mod err)+           Right all_env -> do {+       ; let old_ic         = hsc_IC hsc_env+             !final_rdr_env = all_env `icExtendGblRdrEnv` ic_tythings old_ic+       ; setSession+         hsc_env{ hsc_IC = old_ic { ic_imports    = imports+                                  , ic_rn_gbl_env = final_rdr_env }}}}+  where+    formatError dflags mod err = ProgramError . showSDoc dflags $+      text "Cannot add module" <+> ppr mod <+>+      text "to context:" <+> text err++findGlobalRdrEnv :: HscEnv -> [InteractiveImport]+                 -> IO (Either (ModuleName, String) GlobalRdrEnv)+-- Compute the GlobalRdrEnv for the interactive context+findGlobalRdrEnv hsc_env imports+  = do { idecls_env <- hscRnImportDecls hsc_env idecls+                    -- This call also loads any orphan modules+       ; return $ case partitionEithers (map mkEnv imods) of+           ([], imods_env) -> Right (foldr plusGlobalRdrEnv idecls_env imods_env)+           (err : _, _)    -> Left err }+  where+    idecls :: [LImportDecl RdrName]+    idecls = [noLoc d | IIDecl d <- imports]++    imods :: [ModuleName]+    imods = [m | IIModule m <- imports]++    mkEnv mod = case mkTopLevEnv (hsc_HPT hsc_env) mod of+      Left err -> Left (mod, err)+      Right env -> Right env++availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv+availsToGlobalRdrEnv mod_name avails+  = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) avails)+  where+      -- We're building a GlobalRdrEnv as if the user imported+      -- all the specified modules into the global interactive module+    imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll}+    decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,+                         is_qual = False,+                         is_dloc = srcLocSpan interactiveSrcLoc }++mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv+mkTopLevEnv hpt modl+  = case lookupHpt hpt modl of+      Nothing -> Left "not a home module"+      Just details ->+         case mi_globals (hm_iface details) of+                Nothing  -> Left "not interpreted"+                Just env -> Right env++-- | Get the interactive evaluation context, consisting of a pair of the+-- set of modules from which we take the full top-level scope, and the set+-- of modules from which we take just the exports respectively.+getContext :: GhcMonad m => m [InteractiveImport]+getContext = withSession $ \HscEnv{ hsc_IC=ic } ->+             return (ic_imports ic)++-- | Returns @True@ if the specified module is interpreted, and hence has+-- its full top-level scope available.+moduleIsInterpreted :: GhcMonad m => Module -> m Bool+moduleIsInterpreted modl = withSession $ \h ->+ if moduleUnitId modl /= thisPackage (hsc_dflags h)+        then return False+        else case lookupHpt (hsc_HPT h) (moduleName modl) of+                Just details       -> return (isJust (mi_globals (hm_iface details)))+                _not_a_home_module -> return False++-- | Looks up an identifier in the current interactive context (for :info)+-- Filter the instances by the ones whose tycons (or clases resp)+-- are in scope (qualified or otherwise).  Otherwise we list a whole lot too many!+-- The exact choice of which ones to show, and which to hide, is a judgement call.+--      (see Trac #1581)+getInfo :: GhcMonad m => Bool -> Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst]))+getInfo allInfo name+  = withSession $ \hsc_env ->+    do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name+       case mb_stuff of+         Nothing -> return Nothing+         Just (thing, fixity, cls_insts, fam_insts) -> do+           let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)++           -- Filter the instances based on whether the constituent names of their+           -- instance heads are all in scope.+           let cls_insts' = filter (plausible rdr_env . orphNamesOfClsInst) cls_insts+               fam_insts' = filter (plausible rdr_env . orphNamesOfFamInst) fam_insts+           return (Just (thing, fixity, cls_insts', fam_insts'))+  where+    plausible rdr_env names+          -- Dfun involving only names that are in ic_rn_glb_env+        = allInfo+       || nameSetAll ok names+        where   -- A name is ok if it's in the rdr_env,+                -- whether qualified or not+          ok n | n == name              = True+                       -- The one we looked for in the first place!+               | pretendNameIsInScope n = True+               | isBuiltInSyntax n      = True+               | isExternalName n       = isJust (lookupGRE_Name rdr_env n)+               | otherwise              = True++-- | Returns all names in scope in the current interactive context+getNamesInScope :: GhcMonad m => m [Name]+getNamesInScope = withSession $ \hsc_env -> do+  return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))++-- | Returns all 'RdrName's in scope in the current interactive+-- context, excluding any that are internally-generated.+getRdrNamesInScope :: GhcMonad m => m [RdrName]+getRdrNamesInScope = withSession $ \hsc_env -> do+  let+      ic = hsc_IC hsc_env+      gbl_rdrenv = ic_rn_gbl_env ic+      gbl_names = concatMap greRdrNames $ globalRdrEnvElts gbl_rdrenv+  -- Exclude internally generated names; see e.g. Trac #11328+  return (filter (not . isDerivedOccName . rdrNameOcc) gbl_names)+++-- | Parses a string as an identifier, and returns the list of 'Name's that+-- the identifier can refer to in the current interactive context.+parseName :: GhcMonad m => String -> m [Name]+parseName str = withSession $ \hsc_env -> liftIO $+   do { lrdr_name <- hscParseIdentifier hsc_env str+      ; hscTcRnLookupRdrName hsc_env lrdr_name }++-- | Returns @True@ if passed string is a statement.+isStmt :: DynFlags -> String -> Bool+isStmt dflags stmt =+  case parseThing Parser.parseStmt dflags stmt of+    Lexer.POk _ _ -> True+    Lexer.PFailed _ _ -> False++-- | Returns @True@ if passed string has an import declaration.+hasImport :: DynFlags -> String -> Bool+hasImport dflags stmt =+  case parseThing Parser.parseModule dflags stmt of+    Lexer.POk _ thing -> hasImports thing+    Lexer.PFailed _ _ -> False+  where+    hasImports = not . null . hsmodImports . unLoc++-- | Returns @True@ if passed string is an import declaration.+isImport :: DynFlags -> String -> Bool+isImport dflags stmt =+  case parseThing Parser.parseImport dflags stmt of+    Lexer.POk _ _ -> True+    Lexer.PFailed _ _ -> False++-- | Returns @True@ if passed string is a declaration but __/not a splice/__.+isDecl :: DynFlags -> String -> Bool+isDecl dflags stmt = do+  case parseThing Parser.parseDeclaration dflags stmt of+    Lexer.POk _ thing ->+      case unLoc thing of+        SpliceD _ -> False+        _ -> True+    Lexer.PFailed _ _ -> False++parseThing :: Lexer.P thing -> DynFlags -> String -> Lexer.ParseResult thing+parseThing parser dflags stmt = do+  let buf = stringToStringBuffer stmt+      loc = mkRealSrcLoc (fsLit "<interactive>") 1 1++  Lexer.unP parser (Lexer.mkPState dflags buf loc)++-- -----------------------------------------------------------------------------+-- Getting the type of an expression++-- | Get the type of an expression+-- Returns the type as described by 'TcRnExprMode'+exprType :: GhcMonad m => TcRnExprMode -> String -> m Type+exprType mode expr = withSession $ \hsc_env -> do+   ty <- liftIO $ hscTcExpr hsc_env mode expr+   return $ tidyType emptyTidyEnv ty++-- -----------------------------------------------------------------------------+-- Getting the kind of a type++-- | Get the kind of a  type+typeKind  :: GhcMonad m => Bool -> String -> m (Type, Kind)+typeKind normalise str = withSession $ \hsc_env -> do+   liftIO $ hscKcType hsc_env normalise str++-----------------------------------------------------------------------------+-- Compile an expression, run it and deliver the result++-- | Parse an expression, the parsed expression can be further processed and+-- passed to compileParsedExpr.+parseExpr :: GhcMonad m => String -> m (LHsExpr RdrName)+parseExpr expr = withSession $ \hsc_env -> do+  liftIO $ runInteractiveHsc hsc_env $ hscParseExpr expr++-- | Compile an expression, run it and deliver the resulting HValue.+compileExpr :: GhcMonad m => String -> m HValue+compileExpr expr = do+  parsed_expr <- parseExpr expr+  compileParsedExpr parsed_expr++-- | Compile an expression, run it and deliver the resulting HValue.+compileExprRemote :: GhcMonad m => String -> m ForeignHValue+compileExprRemote expr = do+  parsed_expr <- parseExpr expr+  compileParsedExprRemote parsed_expr++-- | Compile an parsed expression (before renaming), run it and deliver+-- the resulting HValue.+compileParsedExprRemote :: GhcMonad m => LHsExpr RdrName -> m ForeignHValue+compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do+  -- > let _compileParsedExpr = expr+  -- Create let stmt from expr to make hscParsedStmt happy.+  -- We will ignore the returned [Id], namely [expr_id], and not really+  -- create a new binding.+  let expr_fs = fsLit "_compileParsedExpr"+      expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc+      let_stmt = L loc . LetStmt . L loc . HsValBinds $+        ValBindsIn (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) []++  Just ([_id], hvals_io, fix_env) <- liftIO $ hscParsedStmt hsc_env let_stmt+  updateFixityEnv fix_env+  status <- liftIO $ evalStmt hsc_env False (EvalThis hvals_io)+  case status of+    EvalComplete _ (EvalSuccess [hval]) -> return hval+    EvalComplete _ (EvalException e) ->+      liftIO $ throwIO (fromSerializableException e)+    _ -> panic "compileParsedExpr"++compileParsedExpr :: GhcMonad m => LHsExpr RdrName -> m HValue+compileParsedExpr expr = do+   fhv <- compileParsedExprRemote expr+   dflags <- getDynFlags+   liftIO $ wormhole dflags fhv++-- | Compile an expression, run it and return the result as a Dynamic.+dynCompileExpr :: GhcMonad m => String -> m Dynamic+dynCompileExpr expr = do+  parsed_expr <- parseExpr expr+  -- > Data.Dynamic.toDyn expr+  let loc = getLoc parsed_expr+      to_dyn_expr = mkHsApp (L loc . HsVar . L loc $ getRdrName toDynName)+                            parsed_expr+  hval <- compileParsedExpr to_dyn_expr+  return (unsafeCoerce# hval :: Dynamic)++-----------------------------------------------------------------------------+-- show a module and it's source/object filenames++showModule :: GhcMonad m => ModSummary -> m String+showModule mod_summary =+    withSession $ \hsc_env -> do+        interpreted <- moduleIsBootOrNotObjectLinkable mod_summary+        let dflags = hsc_dflags hsc_env+        return (showModMsg dflags (hscTarget dflags) interpreted mod_summary)++moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool+moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env ->+  case lookupHpt (hsc_HPT hsc_env) (ms_mod_name mod_summary) of+        Nothing       -> panic "missing linkable"+        Just mod_info -> return $ case hm_linkable mod_info of+          Nothing       -> True+          Just linkable -> not (isObjectLinkable linkable)++----------------------------------------------------------------------------+-- RTTI primitives++obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term+obtainTermFromVal hsc_env bound force ty x =+              cvObtainTerm hsc_env bound force ty (unsafeCoerce# x)++obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term+obtainTermFromId hsc_env bound force id =  do+  let dflags = hsc_dflags hsc_env+  hv <- Linker.getHValue hsc_env (varName id) >>= wormhole dflags+  cvObtainTerm hsc_env bound force (idType id) hv++-- Uses RTTI to reconstruct the type of an Id, making it less polymorphic+reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)+reconstructType hsc_env bound id = do+  let dflags = hsc_dflags hsc_env+  hv <- Linker.getHValue hsc_env (varName id) >>= wormhole dflags+  cvReconstructType hsc_env bound (idType id) hv++mkRuntimeUnkTyVar :: Name -> Kind -> TyVar+mkRuntimeUnkTyVar name kind = mkTcTyVar name kind RuntimeUnk
+ main/InteractiveEvalTypes.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE CPP #-}++-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow, 2005-2007+--+-- Running statements interactively+--+-- -----------------------------------------------------------------------------++module InteractiveEvalTypes (+        Resume(..), History(..), ExecResult(..),+        SingleStep(..), isStep, ExecOptions(..),+        BreakInfo(..)+        ) where++import GHCi.RemoteTypes+import GHCi.Message (EvalExpr, ResumeContext)+import Id+import Name+import Module+import RdrName+import Type+import SrcLoc+import Exception++import Data.Word+#if MIN_VERSION_base(4,9,0)+import GHC.Stack.CCS+#else+import GHC.Stack as GHC.Stack.CCS+#endif++data ExecOptions+ = ExecOptions+     { execSingleStep :: SingleStep         -- ^ stepping mode+     , execSourceFile :: String             -- ^ filename (for errors)+     , execLineNumber :: Int                -- ^ line number (for errors)+     , execWrap :: ForeignHValue -> EvalExpr ForeignHValue+     }++data SingleStep+   = RunToCompletion+   | SingleStep+   | RunAndLogSteps++isStep :: SingleStep -> Bool+isStep RunToCompletion = False+isStep _ = True++data ExecResult+  = ExecComplete+       { execResult :: Either SomeException [Name]+       , execAllocation :: Word64+       }+  | ExecBreak+       { breakNames :: [Name]+       , breakInfo :: Maybe BreakInfo+       }++data BreakInfo = BreakInfo+  { breakInfo_module :: Module+  , breakInfo_number :: Int+  }++data Resume = Resume+       { resumeStmt      :: String       -- the original statement+       , resumeContext   :: ForeignRef (ResumeContext [HValueRef])+       , resumeBindings  :: ([TyThing], GlobalRdrEnv)+       , resumeFinalIds  :: [Id]         -- [Id] to bind on completion+       , resumeApStack   :: ForeignHValue -- The object from which we can get+                                        -- value of the free variables.+       , resumeBreakInfo :: Maybe BreakInfo+                                        -- the breakpoint we stopped at+                                        -- (module, index)+                                        -- (Nothing <=> exception)+       , resumeSpan      :: SrcSpan      -- just a copy of the SrcSpan+                                        -- from the ModBreaks,+                                        -- otherwise it's a pain to+                                        -- fetch the ModDetails &+                                        -- ModBreaks to get this.+       , resumeDecl      :: String       -- ditto+       , resumeCCS       :: RemotePtr CostCentreStack+       , resumeHistory   :: [History]+       , resumeHistoryIx :: Int           -- 0 <==> at the top of the history+       }++data History+   = History {+        historyApStack   :: ForeignHValue,+        historyBreakInfo :: BreakInfo,+        historyEnclosingDecls :: [String]  -- declarations enclosing the breakpoint+   }
+ main/PackageConfig.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE CPP, RecordWildCards, FlexibleInstances, MultiParamTypeClasses #-}++-- |+-- Package configuration information: essentially the interface to Cabal, with+-- some utilities+--+-- (c) The University of Glasgow, 2004+--+module PackageConfig (+        -- $package_naming++        -- * UnitId+        packageConfigId,+        expandedPackageConfigId,+        definitePackageConfigId,+        installedPackageConfigId,++        -- * The PackageConfig type: information about a package+        PackageConfig,+        InstalledPackageInfo(..),+        ComponentId(..),+        SourcePackageId(..),+        PackageName(..),+        Version(..),+        defaultPackageConfig,+        sourcePackageIdString,+        packageNameString,+        pprPackageConfig,+    ) where++#include "HsVersions.h"++import GHC.PackageDb+import Data.Version++import FastString+import Outputable+import Module+import Unique++-- -----------------------------------------------------------------------------+-- Our PackageConfig type is the InstalledPackageInfo from ghc-boot,+-- which is similar to a subset of the InstalledPackageInfo type from Cabal.++type PackageConfig = InstalledPackageInfo+                       ComponentId+                       SourcePackageId+                       PackageName+                       Module.InstalledUnitId+                       Module.UnitId+                       Module.ModuleName+                       Module.Module++-- TODO: there's no need for these to be FastString, as we don't need the uniq+--       feature, but ghc doesn't currently have convenient support for any+--       other compact string types, e.g. plain ByteString or Text.++newtype SourcePackageId    = SourcePackageId    FastString deriving (Eq, Ord)+newtype PackageName        = PackageName        FastString deriving (Eq, Ord)++instance BinaryStringRep SourcePackageId where+  fromStringRep = SourcePackageId . mkFastStringByteString+  toStringRep (SourcePackageId s) = fastStringToByteString s++instance BinaryStringRep PackageName where+  fromStringRep = PackageName . mkFastStringByteString+  toStringRep (PackageName s) = fastStringToByteString s++instance Uniquable SourcePackageId where+  getUnique (SourcePackageId n) = getUnique n++instance Uniquable PackageName where+  getUnique (PackageName n) = getUnique n++instance Outputable SourcePackageId where+  ppr (SourcePackageId str) = ftext str++instance Outputable PackageName where+  ppr (PackageName str) = ftext str++defaultPackageConfig :: PackageConfig+defaultPackageConfig = emptyInstalledPackageInfo++sourcePackageIdString :: PackageConfig -> String+sourcePackageIdString pkg = unpackFS str+  where+    SourcePackageId str = sourcePackageId pkg++packageNameString :: PackageConfig -> String+packageNameString pkg = unpackFS str+  where+    PackageName str = packageName pkg++pprPackageConfig :: PackageConfig -> SDoc+pprPackageConfig InstalledPackageInfo {..} =+    vcat [+      field "name"                 (ppr packageName),+      field "version"              (text (showVersion packageVersion)),+      field "id"                   (ppr unitId),+      field "exposed"              (ppr exposed),+      field "exposed-modules"      (ppr exposedModules),+      field "hidden-modules"       (fsep (map ppr hiddenModules)),+      field "trusted"              (ppr trusted),+      field "import-dirs"          (fsep (map text importDirs)),+      field "library-dirs"         (fsep (map text libraryDirs)),+      field "dynamic-library-dirs" (fsep (map text libraryDynDirs)),+      field "hs-libraries"         (fsep (map text hsLibraries)),+      field "extra-libraries"      (fsep (map text extraLibraries)),+      field "extra-ghci-libraries" (fsep (map text extraGHCiLibraries)),+      field "include-dirs"         (fsep (map text includeDirs)),+      field "includes"             (fsep (map text includes)),+      field "depends"              (fsep (map ppr  depends)),+      field "cc-options"           (fsep (map text ccOptions)),+      field "ld-options"           (fsep (map text ldOptions)),+      field "framework-dirs"       (fsep (map text frameworkDirs)),+      field "frameworks"           (fsep (map text frameworks)),+      field "haddock-interfaces"   (fsep (map text haddockInterfaces)),+      field "haddock-html"         (fsep (map text haddockHTMLs))+    ]+  where+    field name body = text name <> colon <+> nest 4 body++-- -----------------------------------------------------------------------------+-- UnitId (package names, versions and dep hash)++-- $package_naming+-- #package_naming#+-- Mostly the compiler deals in terms of 'UnitId's, which are md5 hashes+-- of a package ID, keys of its dependencies, and Cabal flags. You're expected+-- to pass in the unit id in the @-this-unit-id@ flag. However, for+-- wired-in packages like @base@ & @rts@, we don't necessarily know what the+-- version is, so these are handled specially; see #wired_in_packages#.++-- | Get the GHC 'UnitId' right out of a Cabalish 'PackageConfig'+installedPackageConfigId :: PackageConfig -> InstalledUnitId+installedPackageConfigId = unitId++packageConfigId :: PackageConfig -> UnitId+packageConfigId p =+    if indefinite p+        then newUnitId (componentId p) (instantiatedWith p)+        else DefiniteUnitId (DefUnitId (unitId p))++expandedPackageConfigId :: PackageConfig -> UnitId+expandedPackageConfigId p =+    newUnitId (componentId p) (instantiatedWith p)++definitePackageConfigId :: PackageConfig -> Maybe DefUnitId+definitePackageConfigId p =+    case packageConfigId p of+        DefiniteUnitId def_uid -> Just def_uid+        _ -> Nothing
+ main/PackageConfig.hs-boot view
@@ -0,0 +1,7 @@+module PackageConfig where+import FastString+import {-# SOURCE #-} Module+import GHC.PackageDb+newtype PackageName = PackageName FastString+newtype SourcePackageId = SourcePackageId FastString+type PackageConfig = InstalledPackageInfo ComponentId SourcePackageId PackageName UnitId ModuleName Module
+ main/Packages.hs view
@@ -0,0 +1,2042 @@+-- (c) The University of Glasgow, 2006++{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns, FlexibleContexts #-}++-- | Package manipulation+module Packages (+        module PackageConfig,++        -- * Reading the package config, and processing cmdline args+        PackageState(preloadPackages, explicitPackages, requirementContext),+        PackageConfigMap,+        emptyPackageState,+        initPackages,+        readPackageConfigs,+        getPackageConfRefs,+        resolvePackageConfig,+        readPackageConfig,+        listPackageConfigMap,++        -- * Querying the package config+        lookupPackage,+        lookupPackage',+        lookupInstalledPackage,+        lookupPackageName,+        improveUnitId,+        searchPackageId,+        getPackageDetails,+        getInstalledPackageDetails,+        componentIdString,+        displayInstalledUnitId,+        listVisibleModuleNames,+        lookupModuleInAllPackages,+        lookupModuleWithSuggestions,+        lookupPluginModuleWithSuggestions,+        LookupResult(..),+        ModuleSuggestion(..),+        ModuleOrigin(..),++        -- * Inspecting the set of packages in scope+        getPackageIncludePath,+        getPackageLibraryPath,+        getPackageLinkOpts,+        getPackageExtraCcOpts,+        getPackageFrameworkPath,+        getPackageFrameworks,+        getPackageConfigMap,+        getPreloadPackagesAnd,++        collectIncludeDirs, collectLibraryPaths, collectLinkOpts,+        packageHsLibs,++        -- * Utils+        unwireUnitId,+        pprFlag,+        pprPackages,+        pprPackagesSimple,+        pprModuleMap,+        isDllName+    )+where++#include "HsVersions.h"++import GHC.PackageDb+import PackageConfig+import DynFlags+import Name             ( Name, nameModule_maybe )+import UniqFM+import UniqDFM+import UniqSet+import Module+import Util+import Panic+import Outputable+import Maybes++import System.Environment ( getEnv )+import FastString+import ErrUtils         ( debugTraceMsg, MsgDoc, printInfoForUser )+import Exception++import System.Directory+import System.FilePath as FilePath+import qualified System.FilePath.Posix as FilePath.Posix+import Control.Monad+import Data.Graph (stronglyConnComp, SCC(..))+import Data.Char ( toUpper )+import Data.List as List+import Data.Map (Map)+import Data.Set (Set)+import Data.Maybe (mapMaybe)+import Data.Monoid (First(..))+#if __GLASGOW_HASKELL__ > 710+import Data.Semigroup   ( Semigroup )+import qualified Data.Semigroup as Semigroup+#endif+import qualified Data.Map as Map+import qualified Data.Map.Strict as MapStrict+import qualified Data.Set as Set+import Data.Version++-- ---------------------------------------------------------------------------+-- The Package state++-- | Package state is all stored in 'DynFlags', including the details of+-- all packages, which packages are exposed, and which modules they+-- provide.+--+-- The package state is computed by 'initPackages', and kept in DynFlags.+-- It is influenced by various package flags:+--+--   * @-package <pkg>@ and @-package-id <pkg>@ cause @<pkg>@ to become exposed.+--     If @-hide-all-packages@ was not specified, these commands also cause+--      all other packages with the same name to become hidden.+--+--   * @-hide-package <pkg>@ causes @<pkg>@ to become hidden.+--+--   * (there are a few more flags, check below for their semantics)+--+-- The package state has the following properties.+--+--   * Let @exposedPackages@ be the set of packages thus exposed.+--     Let @depExposedPackages@ be the transitive closure from @exposedPackages@ of+--     their dependencies.+--+--   * When searching for a module from an preload import declaration,+--     only the exposed modules in @exposedPackages@ are valid.+--+--   * When searching for a module from an implicit import, all modules+--     from @depExposedPackages@ are valid.+--+--   * When linking in a compilation manager mode, we link in packages the+--     program depends on (the compiler knows this list by the+--     time it gets to the link step).  Also, we link in all packages+--     which were mentioned with preload @-package@ flags on the command-line,+--     or are a transitive dependency of same, or are \"base\"\/\"rts\".+--     The reason for this is that we might need packages which don't+--     contain any Haskell modules, and therefore won't be discovered+--     by the normal mechanism of dependency tracking.++-- Notes on DLLs+-- ~~~~~~~~~~~~~+-- When compiling module A, which imports module B, we need to+-- know whether B will be in the same DLL as A.+--      If it's in the same DLL, we refer to B_f_closure+--      If it isn't, we refer to _imp__B_f_closure+-- When compiling A, we record in B's Module value whether it's+-- in a different DLL, by setting the DLL flag.++-- | Given a module name, there may be multiple ways it came into scope,+-- possibly simultaneously.  This data type tracks all the possible ways+-- it could have come into scope.  Warning: don't use the record functions,+-- they're partial!+data ModuleOrigin =+    -- | Module is hidden, and thus never will be available for import.+    -- (But maybe the user didn't realize), so we'll still keep track+    -- of these modules.)+    ModHidden+    -- | Module is public, and could have come from some places.+  | ModOrigin {+        -- | @Just False@ means that this module is in+        -- someone's @exported-modules@ list, but that package is hidden;+        -- @Just True@ means that it is available; @Nothing@ means neither+        -- applies.+        fromOrigPackage :: Maybe Bool+        -- | Is the module available from a reexport of an exposed package?+        -- There could be multiple.+      , fromExposedReexport :: [PackageConfig]+        -- | Is the module available from a reexport of a hidden package?+      , fromHiddenReexport :: [PackageConfig]+        -- | Did the module export come from a package flag? (ToDo: track+        -- more information.+      , fromPackageFlag :: Bool+      }++instance Outputable ModuleOrigin where+    ppr ModHidden = text "hidden module"+    ppr (ModOrigin e res rhs f) = sep (punctuate comma (+        (case e of+            Nothing -> []+            Just False -> [text "hidden package"]+            Just True -> [text "exposed package"]) +++        (if null res+            then []+            else [text "reexport by" <+>+                    sep (map (ppr . packageConfigId) res)]) +++        (if null rhs+            then []+            else [text "hidden reexport by" <+>+                    sep (map (ppr . packageConfigId) res)]) +++        (if f then [text "package flag"] else [])+        ))++-- | Smart constructor for a module which is in @exposed-modules@.  Takes+-- as an argument whether or not the defining package is exposed.+fromExposedModules :: Bool -> ModuleOrigin+fromExposedModules e = ModOrigin (Just e) [] [] False++-- | Smart constructor for a module which is in @reexported-modules@.  Takes+-- as an argument whether or not the reexporting package is expsed, and+-- also its 'PackageConfig'.+fromReexportedModules :: Bool -> PackageConfig -> ModuleOrigin+fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False+fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False++-- | Smart constructor for a module which was bound by a package flag.+fromFlag :: ModuleOrigin+fromFlag = ModOrigin Nothing [] [] True++#if __GLASGOW_HASKELL__ > 710+instance Semigroup ModuleOrigin where+    ModOrigin e res rhs f <> ModOrigin e' res' rhs' f' =+        ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f')+      where g (Just b) (Just b')+                | b == b'   = Just b+                | otherwise = panic "ModOrigin: package both exposed/hidden"+            g Nothing x = x+            g x Nothing = x+    _x <> _y = panic "ModOrigin: hidden module redefined"+#endif++instance Monoid ModuleOrigin where+    mempty = ModOrigin Nothing [] [] False+    mappend (ModOrigin e res rhs f) (ModOrigin e' res' rhs' f') =+        ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f')+      where g (Just b) (Just b')+                | b == b'   = Just b+                | otherwise = panic "ModOrigin: package both exposed/hidden"+            g Nothing x = x+            g x Nothing = x+    mappend _ _ = panic "ModOrigin: hidden module redefined"++-- | Is the name from the import actually visible? (i.e. does it cause+-- ambiguity, or is it only relevant when we're making suggestions?)+originVisible :: ModuleOrigin -> Bool+originVisible ModHidden = False+originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f++-- | Are there actually no providers for this module?  This will never occur+-- except when we're filtering based on package imports.+originEmpty :: ModuleOrigin -> Bool+originEmpty (ModOrigin Nothing [] [] False) = True+originEmpty _ = False++-- | 'UniqFM' map from 'InstalledUnitId'+type InstalledUnitIdMap = UniqDFM++-- | 'UniqFM' map from 'UnitId' to 'PackageConfig', plus+-- the transitive closure of preload packages.+data PackageConfigMap = PackageConfigMap {+        unPackageConfigMap :: InstalledUnitIdMap PackageConfig,+        -- | The set of transitively reachable packages according+        -- to the explicitly provided command line arguments.+        -- See Note [UnitId to InstalledUnitId improvement]+        preloadClosure :: UniqSet InstalledUnitId+    }++-- | 'UniqFM' map from 'UnitId' to a 'UnitVisibility'.+type VisibilityMap = Map UnitId UnitVisibility++-- | 'UnitVisibility' records the various aspects of visibility of a particular+-- 'UnitId'.+data UnitVisibility = UnitVisibility+    { uv_expose_all :: Bool+      --  ^ Should all modules in exposed-modules should be dumped into scope?+    , uv_renamings :: [(ModuleName, ModuleName)]+      -- ^ Any custom renamings that should bring extra 'ModuleName's into+      -- scope.+    , uv_package_name :: First FastString+      -- ^ The package name is associated with the 'UnitId'.  This is used+      -- to implement legacy behavior where @-package foo-0.1@ implicitly+      -- hides any packages named @foo@+    , uv_requirements :: Map ModuleName (Set IndefModule)+      -- ^ The signatures which are contributed to the requirements context+      -- from this unit ID.+    , uv_explicit :: Bool+      -- ^ Whether or not this unit was explicitly brought into scope,+      -- as opposed to implicitly via the 'exposed' fields in the+      -- package database (when @-hide-all-packages@ is not passed.)+    }++instance Outputable UnitVisibility where+    ppr (UnitVisibility {+        uv_expose_all = b,+        uv_renamings = rns,+        uv_package_name = First mb_pn,+        uv_requirements = reqs,+        uv_explicit = explicit+    }) = ppr (b, rns, mb_pn, reqs, explicit)+instance Monoid UnitVisibility where+    mempty = UnitVisibility+             { uv_expose_all = False+             , uv_renamings = []+             , uv_package_name = First Nothing+             , uv_requirements = Map.empty+             , uv_explicit = False+             }+    mappend uv1 uv2+        = UnitVisibility+          { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2+          , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2+          , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2)+          , uv_requirements = Map.unionWith Set.union (uv_requirements uv1) (uv_requirements uv2)+          , uv_explicit = uv_explicit uv1 || uv_explicit uv2+          }++type WiredUnitId = DefUnitId+type PreloadUnitId = InstalledUnitId++-- | Map from 'ModuleName' to 'Module' to all the origins of the bindings+-- in scope.  The 'PackageConf' is not cached, mostly for convenience reasons+-- (since this is the slow path, we'll just look it up again).+type ModuleToPkgConfAll =+    Map ModuleName (Map Module ModuleOrigin)++data PackageState = PackageState {+  -- | A mapping of 'UnitId' to 'PackageConfig'.  This list is adjusted+  -- so that only valid packages are here.  'PackageConfig' reflects+  -- what was stored *on disk*, except for the 'trusted' flag, which+  -- is adjusted at runtime.  (In particular, some packages in this map+  -- may have the 'exposed' flag be 'False'.)+  pkgIdMap              :: PackageConfigMap,++  -- | A mapping of 'PackageName' to 'ComponentId'.  This is used when+  -- users refer to packages in Backpack includes.+  packageNameMap            :: Map PackageName ComponentId,++  -- | A mapping from wired in names to the original names from the+  -- package database.+  unwireMap :: Map WiredUnitId WiredUnitId,++  -- | The packages we're going to link in eagerly.  This list+  -- should be in reverse dependency order; that is, a package+  -- is always mentioned before the packages it depends on.+  preloadPackages      :: [PreloadUnitId],++  -- | Packages which we explicitly depend on (from a command line flag).+  -- We'll use this to generate version macros.+  explicitPackages      :: [UnitId],++  -- | This is a full map from 'ModuleName' to all modules which may possibly+  -- be providing it.  These providers may be hidden (but we'll still want+  -- to report them in error messages), or it may be an ambiguous import.+  moduleToPkgConfAll    :: !ModuleToPkgConfAll,++  -- | A map, like 'moduleToPkgConfAll', but controlling plugin visibility.+  pluginModuleToPkgConfAll    :: !ModuleToPkgConfAll,++  -- | A map saying, for each requirement, what interfaces must be merged+  -- together when we use them.  For example, if our dependencies+  -- are @p[A=<A>]@ and @q[A=<A>,B=r[C=<A>]:B]@, then the interfaces+  -- to merge for A are @p[A=<A>]:A@, @q[A=<A>,B=r[C=<A>]:B]:A@+  -- and @r[C=<A>]:C@.+  --+  -- There's an entry in this map for each hole in our home library.+  requirementContext :: Map ModuleName [IndefModule]+  }++emptyPackageState :: PackageState+emptyPackageState = PackageState {+    pkgIdMap = emptyPackageConfigMap,+    packageNameMap = Map.empty,+    unwireMap = Map.empty,+    preloadPackages = [],+    explicitPackages = [],+    moduleToPkgConfAll = Map.empty,+    pluginModuleToPkgConfAll = Map.empty,+    requirementContext = Map.empty+    }++type InstalledPackageIndex = Map InstalledUnitId PackageConfig++-- | Empty package configuration map+emptyPackageConfigMap :: PackageConfigMap+emptyPackageConfigMap = PackageConfigMap emptyUDFM emptyUniqSet++-- | Find the package we know about with the given unit id, if any+lookupPackage :: DynFlags -> UnitId -> Maybe PackageConfig+lookupPackage dflags = lookupPackage' (isIndefinite dflags) (pkgIdMap (pkgState dflags))++-- | A more specialized interface, which takes a boolean specifying+-- whether or not to look for on-the-fly renamed interfaces, and+-- just a 'PackageConfigMap' rather than a 'DynFlags' (so it can+-- be used while we're initializing 'DynFlags'+lookupPackage' :: Bool -> PackageConfigMap -> UnitId -> Maybe PackageConfig+lookupPackage' False (PackageConfigMap pkg_map _) uid = lookupUDFM pkg_map uid+lookupPackage' True m@(PackageConfigMap pkg_map _) uid =+    case splitUnitIdInsts uid of+        (iuid, Just indef) ->+            fmap (renamePackage m (indefUnitIdInsts indef))+                 (lookupUDFM pkg_map iuid)+        (_, Nothing) -> lookupUDFM pkg_map uid++{-+-- | Find the indefinite package for a given 'ComponentId'.+-- The way this works is just by fiat'ing that every indefinite package's+-- unit key is precisely its component ID; and that they share uniques.+lookupComponentId :: DynFlags -> ComponentId -> Maybe PackageConfig+lookupComponentId dflags (ComponentId cid_fs) = lookupUDFM pkg_map cid_fs+  where+    PackageConfigMap pkg_map = pkgIdMap (pkgState dflags)+-}++-- | Find the package we know about with the given package name (e.g. @foo@), if any+-- (NB: there might be a locally defined unit name which overrides this)+lookupPackageName :: DynFlags -> PackageName -> Maybe ComponentId+lookupPackageName dflags n = Map.lookup n (packageNameMap (pkgState dflags))++-- | Search for packages with a given package ID (e.g. \"foo-0.1\")+searchPackageId :: DynFlags -> SourcePackageId -> [PackageConfig]+searchPackageId dflags pid = filter ((pid ==) . sourcePackageId)+                               (listPackageConfigMap dflags)++-- | Extends the package configuration map with a list of package configs.+extendPackageConfigMap+   :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap+extendPackageConfigMap (PackageConfigMap pkg_map closure) new_pkgs+  = PackageConfigMap (foldl add pkg_map new_pkgs) closure+    -- We also add the expanded version of the packageConfigId, so that+    -- 'improveUnitId' can find it.+  where add pkg_map p = addToUDFM (addToUDFM pkg_map (expandedPackageConfigId p) p)+                                  (installedPackageConfigId p) p++-- | Looks up the package with the given id in the package state, panicing if it is+-- not found+getPackageDetails :: DynFlags -> UnitId -> PackageConfig+getPackageDetails dflags pid =+    expectJust "getPackageDetails" (lookupPackage dflags pid)++lookupInstalledPackage :: DynFlags -> InstalledUnitId -> Maybe PackageConfig+lookupInstalledPackage dflags uid = lookupInstalledPackage' (pkgIdMap (pkgState dflags)) uid++lookupInstalledPackage' :: PackageConfigMap -> InstalledUnitId -> Maybe PackageConfig+lookupInstalledPackage' (PackageConfigMap db _) uid = lookupUDFM db uid++getInstalledPackageDetails :: DynFlags -> InstalledUnitId -> PackageConfig+getInstalledPackageDetails dflags uid =+    expectJust "getInstalledPackageDetails" $+        lookupInstalledPackage dflags uid++-- | Get a list of entries from the package database.  NB: be careful with+-- this function, although all packages in this map are "visible", this+-- does not imply that the exposed-modules of the package are available+-- (they may have been thinned or renamed).+listPackageConfigMap :: DynFlags -> [PackageConfig]+listPackageConfigMap dflags = eltsUDFM pkg_map+  where+    PackageConfigMap pkg_map _ = pkgIdMap (pkgState dflags)++-- ----------------------------------------------------------------------------+-- Loading the package db files and building up the package state++-- | Call this after 'DynFlags.parseDynFlags'.  It reads the package+-- database files, and sets up various internal tables of package+-- information, according to the package-related flags on the+-- command-line (@-package@, @-hide-package@ etc.)+--+-- Returns a list of packages to link in if we're doing dynamic linking.+-- This list contains the packages that the user explicitly mentioned with+-- @-package@ flags.+--+-- 'initPackages' can be called again subsequently after updating the+-- 'packageFlags' field of the 'DynFlags', and it will update the+-- 'pkgState' in 'DynFlags' and return a list of packages to+-- link in.+initPackages :: DynFlags -> IO (DynFlags, [PreloadUnitId])+initPackages dflags0 = do+  dflags <- interpretPackageEnv dflags0+  pkg_db <-+    case pkgDatabase dflags of+        Nothing -> readPackageConfigs dflags+        Just db -> return $ map (\(p, pkgs)+                                    -> (p, setBatchPackageFlags dflags pkgs)) db+  (pkg_state, preload, insts)+        <- mkPackageState dflags pkg_db []+  return (dflags{ pkgDatabase = Just pkg_db,+                  pkgState = pkg_state,+                  thisUnitIdInsts_ = insts },+          preload)++-- -----------------------------------------------------------------------------+-- Reading the package database(s)++readPackageConfigs :: DynFlags -> IO [(FilePath, [PackageConfig])]+readPackageConfigs dflags = do+  conf_refs <- getPackageConfRefs dflags+  confs     <- liftM catMaybes $ mapM (resolvePackageConfig dflags) conf_refs+  mapM (readPackageConfig dflags) confs+++getPackageConfRefs :: DynFlags -> IO [PkgConfRef]+getPackageConfRefs dflags = do+  let system_conf_refs = [UserPkgConf, GlobalPkgConf]++  e_pkg_path <- tryIO (getEnv $ map toUpper (programName dflags) ++ "_PACKAGE_PATH")+  let base_conf_refs = case e_pkg_path of+        Left _ -> system_conf_refs+        Right path+         | not (null path) && isSearchPathSeparator (last path)+         -> map PkgConfFile (splitSearchPath (init path)) ++ system_conf_refs+         | otherwise+         -> map PkgConfFile (splitSearchPath path)++  -- Apply the package DB-related flags from the command line to get the+  -- final list of package DBs.+  --+  -- Notes on ordering:+  --  * The list of flags is reversed (later ones first)+  --  * We work with the package DB list in "left shadows right" order+  --  * and finally reverse it at the end, to get "right shadows left"+  --+  return $ reverse (foldr doFlag base_conf_refs (packageDBFlags dflags))+ where+  doFlag (PackageDB p) dbs = p : dbs+  doFlag NoUserPackageDB dbs = filter isNotUser dbs+  doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs+  doFlag ClearPackageDBs _ = []++  isNotUser UserPkgConf = False+  isNotUser _ = True++  isNotGlobal GlobalPkgConf = False+  isNotGlobal _ = True++resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath)+resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig dflags)+-- NB: This logic is reimplemented in Cabal, so if you change it,+-- make sure you update Cabal.  (Or, better yet, dump it in the+-- compiler info so Cabal can use the info.)+resolvePackageConfig dflags UserPkgConf = runMaybeT $ do+  dir <- versionedAppDir dflags+  let pkgconf = dir </> "package.conf.d"+  exist <- tryMaybeT $ doesDirectoryExist pkgconf+  if exist then return pkgconf else mzero+resolvePackageConfig _ (PkgConfFile name) = return $ Just name++readPackageConfig :: DynFlags -> FilePath -> IO (FilePath, [PackageConfig])+readPackageConfig dflags conf_file = do+  isdir <- doesDirectoryExist conf_file++  proto_pkg_configs <-+    if isdir+       then readDirStylePackageConfig conf_file+       else do+            isfile <- doesFileExist conf_file+            if isfile+               then do+                 mpkgs <- tryReadOldFileStylePackageConfig+                 case mpkgs of+                   Just pkgs -> return pkgs+                   Nothing   -> throwGhcExceptionIO $ InstallationError $+                      "ghc no longer supports single-file style package " +++                      "databases (" ++ conf_file +++                      ") use 'ghc-pkg init' to create the database with " +++                      "the correct format."+               else throwGhcExceptionIO $ InstallationError $+                      "can't find a package database at " ++ conf_file++  let+      top_dir = topDir dflags+      pkgroot = takeDirectory conf_file+      pkg_configs1 = map (mungePackageConfig top_dir pkgroot)+                         proto_pkg_configs+      pkg_configs2 = setBatchPackageFlags dflags pkg_configs1+  --+  return (conf_file, pkg_configs2)+  where+    readDirStylePackageConfig conf_dir = do+      let filename = conf_dir </> "package.cache"+      cache_exists <- doesFileExist filename+      if cache_exists+        then do+          debugTraceMsg dflags 2 $ text "Using binary package database:"+                                    <+> text filename+          readPackageDbForGhc filename+        else do+          -- If there is no package.cache file, we check if the database is not+          -- empty by inspecting if the directory contains any .conf file. If it+          -- does, something is wrong and we fail. Otherwise we assume that the+          -- database is empty.+          debugTraceMsg dflags 2 $ text "There is no package.cache in"+                               <+> text conf_dir+                                <> text ", checking if the database is empty"+          db_empty <- all (not . isSuffixOf ".conf")+                   <$> getDirectoryContents conf_dir+          if db_empty+            then do+              debugTraceMsg dflags 3 $ text "There are no .conf files in"+                                   <+> text conf_dir <> text ", treating"+                                   <+> text "package database as empty"+              return []+            else do+              throwGhcExceptionIO $ InstallationError $+                "there is no package.cache in " ++ conf_dir +++                " even though package database is not empty"+++    -- Single-file style package dbs have been deprecated for some time, but+    -- it turns out that Cabal was using them in one place. So this is a+    -- workaround to allow older Cabal versions to use this newer ghc.+    -- We check if the file db contains just "[]" and if so, we look for a new+    -- dir-style db in conf_file.d/, ie in a dir next to the given file.+    -- We cannot just replace the file with a new dir style since Cabal still+    -- assumes it's a file and tries to overwrite with 'writeFile'.+    -- ghc-pkg also cooperates with this workaround.+    tryReadOldFileStylePackageConfig = do+      content <- readFile conf_file `catchIO` \_ -> return ""+      if take 2 content == "[]"+        then do+          let conf_dir = conf_file <.> "d"+          direxists <- doesDirectoryExist conf_dir+          if direxists+             then do debugTraceMsg dflags 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir)+                     liftM Just (readDirStylePackageConfig conf_dir)+             else return (Just []) -- ghc-pkg will create it when it's updated+        else return Nothing++setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig]+setBatchPackageFlags dflags pkgs = maybeDistrustAll pkgs+  where+    maybeDistrustAll pkgs'+      | gopt Opt_DistrustAllPackages dflags = map distrust pkgs'+      | otherwise                           = pkgs'++    distrust pkg = pkg{ trusted = False }++mungePackageConfig :: FilePath -> FilePath+                   -> PackageConfig -> PackageConfig+mungePackageConfig top_dir pkgroot =+    mungeDynLibFields+  . mungePackagePaths top_dir pkgroot++mungeDynLibFields :: PackageConfig -> PackageConfig+mungeDynLibFields pkg =+    pkg {+      libraryDynDirs     = libraryDynDirs pkg+                `orIfNull` libraryDirs pkg+    }+  where+    orIfNull [] flags = flags+    orIfNull flags _  = flags++-- TODO: This code is duplicated in utils/ghc-pkg/Main.hs+mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig+-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec+-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)+-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.+-- The "pkgroot" is the directory containing the package database.+--+-- Also perform a similar substitution for the older GHC-specific+-- "$topdir" variable. The "topdir" is the location of the ghc+-- installation (obtained from the -B option).+mungePackagePaths top_dir pkgroot pkg =+    pkg {+      importDirs  = munge_paths (importDirs pkg),+      includeDirs = munge_paths (includeDirs pkg),+      libraryDirs = munge_paths (libraryDirs pkg),+      libraryDynDirs = munge_paths (libraryDynDirs pkg),+      frameworkDirs = munge_paths (frameworkDirs pkg),+      haddockInterfaces = munge_paths (haddockInterfaces pkg),+      haddockHTMLs = munge_urls (haddockHTMLs pkg)+    }+  where+    munge_paths = map munge_path+    munge_urls  = map munge_url++    munge_path p+      | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'+      | Just p' <- stripVarPrefix "$topdir"    p = top_dir ++ p'+      | otherwise                                = p++    munge_url p+      | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'+      | Just p' <- stripVarPrefix "$httptopdir"   p = toUrlPath top_dir p'+      | otherwise                                   = p++    toUrlPath r p = "file:///"+                 -- URLs always use posix style '/' separators:+                 ++ FilePath.Posix.joinPath+                        (r : -- We need to drop a leading "/" or "\\"+                             -- if there is one:+                             dropWhile (all isPathSeparator)+                                       (FilePath.splitDirectories p))++    -- We could drop the separator here, and then use </> above. However,+    -- by leaving it in and using ++ we keep the same path separator+    -- rather than letting FilePath change it to use \ as the separator+    stripVarPrefix var path = case stripPrefix var path of+                              Just [] -> Just []+                              Just cs@(c : _) | isPathSeparator c -> Just cs+                              _ -> Nothing+++-- -----------------------------------------------------------------------------+-- Modify our copy of the package database based on trust flags,+-- -trust and -distrust.++applyTrustFlag+   :: DynFlags+   -> PackagePrecedenceIndex+   -> UnusablePackages+   -> [PackageConfig]+   -> TrustFlag+   -> IO [PackageConfig]+applyTrustFlag dflags prec_map unusable pkgs flag =+  case flag of+    -- we trust all matching packages. Maybe should only trust first one?+    -- and leave others the same or set them untrusted+    TrustPackage str ->+       case selectPackages prec_map (PackageArg str) pkgs unusable of+         Left ps       -> trustFlagErr dflags flag ps+         Right (ps,qs) -> return (map trust ps ++ qs)+          where trust p = p {trusted=True}++    DistrustPackage str ->+       case selectPackages prec_map (PackageArg str) pkgs unusable of+         Left ps       -> trustFlagErr dflags flag ps+         Right (ps,qs) -> return (map distrust ps ++ qs)+          where distrust p = p {trusted=False}++-- | A little utility to tell if the 'thisPackage' is indefinite+-- (if it is not, we should never use on-the-fly renaming.)+isIndefinite :: DynFlags -> Bool+isIndefinite dflags = not (unitIdIsDefinite (thisPackage dflags))++applyPackageFlag+   :: DynFlags+   -> PackagePrecedenceIndex+   -> PackageConfigMap+   -> UnusablePackages+   -> Bool -- if False, if you expose a package, it implicitly hides+           -- any previously exposed packages with the same name+   -> [PackageConfig]+   -> VisibilityMap           -- Initially exposed+   -> PackageFlag               -- flag to apply+   -> IO VisibilityMap        -- Now exposed++applyPackageFlag dflags prec_map pkg_db unusable no_hide_others pkgs vm flag =+  case flag of+    ExposePackage _ arg (ModRenaming b rns) ->+       case findPackages prec_map pkg_db arg pkgs unusable of+         Left ps         -> packageFlagErr dflags flag ps+         Right (p:_) -> return vm'+          where+           n = fsPackageName p++           -- If a user says @-unit-id p[A=<A>]@, this imposes+           -- a requirement on us: whatever our signature A is,+           -- it must fulfill all of p[A=<A>]:A's requirements.+           -- This method is responsible for computing what our+           -- inherited requirements are.+           reqs | UnitIdArg orig_uid <- arg = collectHoles orig_uid+                | otherwise                 = Map.empty++           collectHoles uid = case splitUnitIdInsts uid of+                (_, Just indef) ->+                  let local = [ Map.singleton+                                  (moduleName mod)+                                  (Set.singleton $ IndefModule indef mod_name)+                              | (mod_name, mod) <- indefUnitIdInsts indef+                              , isHoleModule mod ]+                      recurse = [ collectHoles (moduleUnitId mod)+                                | (_, mod) <- indefUnitIdInsts indef ]+                  in Map.unionsWith Set.union $ local ++ recurse+                -- Other types of unit identities don't have holes+                (_, Nothing) -> Map.empty+++           uv = UnitVisibility+                { uv_expose_all = b+                , uv_renamings = rns+                , uv_package_name = First (Just n)+                , uv_requirements = reqs+                , uv_explicit = True+                }+           vm' = Map.insertWith mappend (packageConfigId p) uv vm_cleared+           -- In the old days, if you said `ghc -package p-0.1 -package p-0.2`+           -- (or if p-0.1 was registered in the pkgdb as exposed: True),+           -- the second package flag would override the first one and you+           -- would only see p-0.2 in exposed modules.  This is good for+           -- usability.+           --+           -- However, with thinning and renaming (or Backpack), there might be+           -- situations where you legitimately want to see two versions of a+           -- package at the same time, and this behavior would make it+           -- impossible to do so.  So we decided that if you pass+           -- -hide-all-packages, this should turn OFF the overriding behavior+           -- where an exposed package hides all other packages with the same+           -- name.  This should not affect Cabal at all, which only ever+           -- exposes one package at a time.+           --+           -- NB: Why a variable no_hide_others?  We have to apply this logic to+           -- -plugin-package too, and it's more consistent if the switch in+           -- behavior is based off of+           -- -hide-all-packages/-hide-all-plugin-packages depending on what+           -- flag is in question.+           vm_cleared | no_hide_others = vm+                      -- NB: renamings never clear+                      | (_:_) <- rns = vm+                      | otherwise = Map.filterWithKey+                            (\k uv -> k == packageConfigId p+                                   || First (Just n) /= uv_package_name uv) vm+         _ -> panic "applyPackageFlag"++    HidePackage str ->+       case findPackages prec_map pkg_db (PackageArg str) pkgs unusable of+         Left ps  -> packageFlagErr dflags flag ps+         Right ps -> return vm'+          where vm' = foldl' (flip Map.delete) vm (map packageConfigId ps)++-- | Like 'selectPackages', but doesn't return a list of unmatched+-- packages.  Furthermore, any packages it returns are *renamed*+-- if the 'UnitArg' has a renaming associated with it.+findPackages :: PackagePrecedenceIndex+             -> PackageConfigMap -> PackageArg -> [PackageConfig]+             -> UnusablePackages+             -> Either [(PackageConfig, UnusablePackageReason)]+                [PackageConfig]+findPackages prec_map pkg_db arg pkgs unusable+  = let ps = mapMaybe (finder arg) pkgs+    in if null ps+        then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y))+                            (Map.elems unusable))+        else Right (sortByPreference prec_map ps)+  where+    finder (PackageArg str) p+      = if str == sourcePackageIdString p || str == packageNameString p+          then Just p+          else Nothing+    finder (UnitIdArg uid) p+      = let (iuid, mb_indef) = splitUnitIdInsts uid+        in if iuid == installedPackageConfigId p+              then Just (case mb_indef of+                            Nothing    -> p+                            Just indef -> renamePackage pkg_db (indefUnitIdInsts indef) p)+              else Nothing++selectPackages :: PackagePrecedenceIndex -> PackageArg -> [PackageConfig]+               -> UnusablePackages+               -> Either [(PackageConfig, UnusablePackageReason)]+                  ([PackageConfig], [PackageConfig])+selectPackages prec_map arg pkgs unusable+  = let matches = matching arg+        (ps,rest) = partition matches pkgs+    in if null ps+        then Left (filter (matches.fst) (Map.elems unusable))+        else Right (sortByPreference prec_map ps, rest)++-- | Rename a 'PackageConfig' according to some module instantiation.+renamePackage :: PackageConfigMap -> [(ModuleName, Module)]+              -> PackageConfig -> PackageConfig+renamePackage pkg_map insts conf =+    let hsubst = listToUFM insts+        smod  = renameHoleModule' pkg_map hsubst+        new_insts = map (\(k,v) -> (k,smod v)) (instantiatedWith conf)+    in conf {+        instantiatedWith = new_insts,+        exposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod))+                             (exposedModules conf)+    }+++-- A package named on the command line can either include the+-- version, or just the name if it is unambiguous.+matchingStr :: String -> PackageConfig -> Bool+matchingStr str p+        =  str == sourcePackageIdString p+        || str == packageNameString p++matchingId :: InstalledUnitId -> PackageConfig -> Bool+matchingId uid p = uid == installedPackageConfigId p++matching :: PackageArg -> PackageConfig -> Bool+matching (PackageArg str) = matchingStr str+matching (UnitIdArg (DefiniteUnitId (DefUnitId uid)))  = matchingId uid+matching (UnitIdArg _)  = \_ -> False -- TODO: warn in this case++-- | This sorts a list of packages, putting "preferred" packages first.+-- See 'compareByPreference' for the semantics of "preference".+sortByPreference :: PackagePrecedenceIndex -> [PackageConfig] -> [PackageConfig]+sortByPreference prec_map = sortBy (flip (compareByPreference prec_map))++-- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking+-- which should be "active".  Here is the order of preference:+--+--      1. First, prefer the latest version+--      2. If the versions are the same, prefer the package that+--      came in the latest package database.+--+-- Pursuant to #12518, we could change this policy to, for example, remove+-- the version preference, meaning that we would always prefer the packages+-- in alter package database.+--+compareByPreference+    :: PackagePrecedenceIndex+    -> PackageConfig+    -> PackageConfig+    -> Ordering+compareByPreference prec_map pkg pkg' =+    case comparing packageVersion pkg pkg' of+        GT -> GT+        EQ | Just prec  <- Map.lookup (unitId pkg)  prec_map+           , Just prec' <- Map.lookup (unitId pkg') prec_map+           -- Prefer the package from the later DB flag (i.e., higher+           -- precedence)+           -> compare prec prec'+           | otherwise+           -> EQ+        LT -> LT++comparing :: Ord a => (t -> a) -> t -> t -> Ordering+comparing f a b = f a `compare` f b++packageFlagErr :: DynFlags+               -> PackageFlag+               -> [(PackageConfig, UnusablePackageReason)]+               -> IO a++-- for missing DPH package we emit a more helpful error message, because+-- this may be the result of using -fdph-par or -fdph-seq.+packageFlagErr dflags (ExposePackage _ (PackageArg pkg) _) []+  | is_dph_package pkg+  = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ dph_err))+  where dph_err = text "the " <> text pkg <> text " package is not installed."+                  $$ text "To install it: \"cabal install dph\"."+        is_dph_package pkg = "dph" `isPrefixOf` pkg+packageFlagErr dflags flag reasons+  = packageFlagErr' dflags (pprFlag flag) reasons++trustFlagErr :: DynFlags+             -> TrustFlag+             -> [(PackageConfig, UnusablePackageReason)]+             -> IO a+trustFlagErr dflags flag reasons+  = packageFlagErr' dflags (pprTrustFlag flag) reasons++packageFlagErr' :: DynFlags+               -> SDoc+               -> [(PackageConfig, UnusablePackageReason)]+               -> IO a+packageFlagErr' dflags flag_doc reasons+  = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err))+  where err = text "cannot satisfy " <> flag_doc <>+                (if null reasons then Outputable.empty else text ": ") $$+              nest 4 (ppr_reasons $$+                      text "(use -v for more information)")+        ppr_reasons = vcat (map ppr_reason reasons)+        ppr_reason (p, reason) =+            pprReason (ppr (unitId p) <+> text "is") reason++pprFlag :: PackageFlag -> SDoc+pprFlag flag = case flag of+    HidePackage p   -> text "-hide-package " <> text p+    ExposePackage doc _ _ -> text doc++pprTrustFlag :: TrustFlag -> SDoc+pprTrustFlag flag = case flag of+    TrustPackage p    -> text "-trust " <> text p+    DistrustPackage p -> text "-distrust " <> text p++-- -----------------------------------------------------------------------------+-- Wired-in packages++wired_in_pkgids :: [String]+wired_in_pkgids = map unitIdString wiredInUnitIds++type WiredPackagesMap = Map WiredUnitId WiredUnitId++findWiredInPackages+   :: DynFlags+   -> PackagePrecedenceIndex+   -> [PackageConfig]           -- database+   -> VisibilityMap             -- info on what packages are visible+                                -- for wired in selection+   -> IO ([PackageConfig],  -- package database updated for wired in+          WiredPackagesMap) -- map from unit id to wired identity++findWiredInPackages dflags prec_map pkgs vis_map = do+  --+  -- Now we must find our wired-in packages, and rename them to+  -- their canonical names (eg. base-1.0 ==> base).+  --+  let+        matches :: PackageConfig -> String -> Bool+        pc `matches` pid = packageNameString pc == pid++        -- find which package corresponds to each wired-in package+        -- delete any other packages with the same name+        -- update the package and any dependencies to point to the new+        -- one.+        --+        -- When choosing which package to map to a wired-in package+        -- name, we try to pick the latest version of exposed packages.+        -- However, if there are no exposed wired in packages available+        -- (e.g. -hide-all-packages was used), we can't bail: we *have*+        -- to assign a package for the wired-in package: so we try again+        -- with hidden packages included to (and pick the latest+        -- version).+        --+        -- You can also override the default choice by using -ignore-package:+        -- this works even when there is no exposed wired in package+        -- available.+        --+        findWiredInPackage :: [PackageConfig] -> String+                           -> IO (Maybe PackageConfig)+        findWiredInPackage pkgs wired_pkg =+           let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ]+               all_exposed_ps =+                    [ p | p <- all_ps+                        , Map.member (packageConfigId p) vis_map ] in+           case all_exposed_ps of+            [] -> case all_ps of+                       []   -> notfound+                       many -> pick (head (sortByPreference prec_map many))+            many -> pick (head (sortByPreference prec_map many))+          where+                notfound = do+                          debugTraceMsg dflags 2 $+                            text "wired-in package "+                                 <> text wired_pkg+                                 <> text " not found."+                          return Nothing+                pick :: PackageConfig+                     -> IO (Maybe PackageConfig)+                pick pkg = do+                        debugTraceMsg dflags 2 $+                            text "wired-in package "+                                 <> text wired_pkg+                                 <> text " mapped to "+                                 <> ppr (unitId pkg)+                        return (Just pkg)+++  mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_pkgids+  let+        wired_in_pkgs = catMaybes mb_wired_in_pkgs+        wired_in_ids = mapMaybe definitePackageConfigId wired_in_pkgs++        -- this is old: we used to assume that if there were+        -- multiple versions of wired-in packages installed that+        -- they were mutually exclusive.  Now we're assuming that+        -- you have one "main" version of each wired-in package+        -- (the latest version), and the others are backward-compat+        -- wrappers that depend on this one.  e.g. base-4.0 is the+        -- latest, base-3.0 is a compat wrapper depending on base-4.0.+        {-+        deleteOtherWiredInPackages pkgs = filterOut bad pkgs+          where bad p = any (p `matches`) wired_in_pkgids+                      && package p `notElem` map fst wired_in_ids+        -}++        wiredInMap :: Map WiredUnitId WiredUnitId+        wiredInMap = foldl' add_mapping Map.empty pkgs+          where add_mapping m pkg+                  | Just key <- definitePackageConfigId pkg+                  , key `elem` wired_in_ids+                  = Map.insert key (DefUnitId (stringToInstalledUnitId (packageNameString pkg))) m+                  | otherwise = m++        updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs+          where upd_pkg pkg+                  | Just def_uid <- definitePackageConfigId pkg+                  , def_uid `elem` wired_in_ids+                  = let PackageName fs = packageName pkg+                    in pkg {+                      unitId = fsToInstalledUnitId fs,+                      componentId = ComponentId fs+                    }+                  | otherwise+                  = pkg+                upd_deps pkg = pkg {+                      -- temporary harmless DefUnitId invariant violation+                      depends = map (unDefUnitId . upd_wired_in wiredInMap . DefUnitId) (depends pkg),+                      exposedModules+                        = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v))+                              (exposedModules pkg)+                    }+++  return (updateWiredInDependencies pkgs, wiredInMap)++-- Helper functions for rewiring Module and UnitId.  These+-- rewrite UnitIds of modules in wired-in packages to the form known to the+-- compiler. For instance, base-4.9.0.0 will be rewritten to just base, to match+-- what appears in PrelNames.++upd_wired_in_mod :: WiredPackagesMap -> Module -> Module+upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m++upd_wired_in_uid :: WiredPackagesMap -> UnitId -> UnitId+upd_wired_in_uid wiredInMap (DefiniteUnitId def_uid) =+    DefiniteUnitId (upd_wired_in wiredInMap def_uid)+upd_wired_in_uid wiredInMap (IndefiniteUnitId indef_uid) =+    IndefiniteUnitId $ newIndefUnitId+        (indefUnitIdComponentId indef_uid)+        (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (indefUnitIdInsts indef_uid))++upd_wired_in :: WiredPackagesMap -> DefUnitId -> DefUnitId+upd_wired_in wiredInMap key+    | Just key' <- Map.lookup key wiredInMap = key'+    | otherwise = key++updateVisibilityMap :: WiredPackagesMap -> VisibilityMap -> VisibilityMap+updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap)+  where f vm (from, to) = case Map.lookup (DefiniteUnitId from) vis_map of+                    Nothing -> vm+                    Just r -> Map.insert (DefiniteUnitId to) r+                                (Map.delete (DefiniteUnitId from) vm)+++-- ----------------------------------------------------------------------------++-- | The reason why a package is unusable.+data UnusablePackageReason+  = -- | We ignored it explicitly using @-ignore-package@.+    IgnoredWithFlag+    -- | This package transitively depends on a package that was never present+    -- in any of the provided databases.+  | BrokenDependencies   [InstalledUnitId]+    -- | This package transitively depends on a package involved in a cycle.+    -- Note that the list of 'InstalledUnitId' reports the direct dependencies+    -- of this package that (transitively) depended on the cycle, and not+    -- the actual cycle itself (which we report separately at high verbosity.)+  | CyclicDependencies   [InstalledUnitId]+    -- | This package transitively depends on a package which was ignored.+  | IgnoredDependencies  [InstalledUnitId]+    -- | This package transitively depends on a package which was+    -- shadowed by an ABI-incompatible package.+  | ShadowedDependencies [InstalledUnitId]++instance Outputable UnusablePackageReason where+    ppr IgnoredWithFlag = text "[ignored with flag]"+    ppr (BrokenDependencies uids)   = brackets (text "broken" <+> ppr uids)+    ppr (CyclicDependencies uids)   = brackets (text "cyclic" <+> ppr uids)+    ppr (IgnoredDependencies uids)  = brackets (text "ignored" <+> ppr uids)+    ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids)++type UnusablePackages = Map InstalledUnitId+                            (PackageConfig, UnusablePackageReason)++pprReason :: SDoc -> UnusablePackageReason -> SDoc+pprReason pref reason = case reason of+  IgnoredWithFlag ->+      pref <+> text "ignored due to an -ignore-package flag"+  BrokenDependencies deps ->+      pref <+> text "unusable due to missing dependencies:" $$+        nest 2 (hsep (map ppr deps))+  CyclicDependencies deps ->+      pref <+> text "unusable due to cyclic dependencies:" $$+        nest 2 (hsep (map ppr deps))+  IgnoredDependencies deps ->+      pref <+> text "unusable due to ignored dependencies:" $$+        nest 2 (hsep (map ppr deps))+  ShadowedDependencies deps ->+      pref <+> text "unusable due to shadowed dependencies:" $$+        nest 2 (hsep (map ppr deps))++reportCycles :: DynFlags -> [SCC PackageConfig] -> IO ()+reportCycles dflags sccs = mapM_ report sccs+  where+    report (AcyclicSCC _) = return ()+    report (CyclicSCC vs) =+        debugTraceMsg dflags 2 $+          text "these packages are involved in a cycle:" $$+            nest 2 (hsep (map (ppr . unitId) vs))++reportUnusable :: DynFlags -> UnusablePackages -> IO ()+reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs)+  where+    report (ipid, (_, reason)) =+       debugTraceMsg dflags 2 $+         pprReason+           (text "package" <+> ppr ipid <+> text "is") reason++-- ----------------------------------------------------------------------------+--+-- Utilities on the database+--++-- | A reverse dependency index, mapping an 'InstalledUnitId' to+-- the 'InstalledUnitId's which have a dependency on it.+type RevIndex = Map InstalledUnitId [InstalledUnitId]++-- | Compute the reverse dependency index of a package database.+reverseDeps :: InstalledPackageIndex -> RevIndex+reverseDeps db = Map.foldl' go Map.empty db+  where+    go r pkg = foldl' (go' (unitId pkg)) r (depends pkg)+    go' from r to = Map.insertWith (++) to [from] r++-- | Given a list of 'InstalledUnitId's to remove, a database,+-- and a reverse dependency index (as computed by 'reverseDeps'),+-- remove those packages, plus any packages which depend on them.+-- Returns the pruned database, as well as a list of 'PackageConfig's+-- that was removed.+removePackages :: [InstalledUnitId] -> RevIndex+               -> InstalledPackageIndex+               -> (InstalledPackageIndex, [PackageConfig])+removePackages uids index m = go uids (m,[])+  where+    go [] (m,pkgs) = (m,pkgs)+    go (uid:uids) (m,pkgs)+        | Just pkg <- Map.lookup uid m+        = case Map.lookup uid index of+            Nothing    -> go uids (Map.delete uid m, pkg:pkgs)+            Just rdeps -> go (rdeps ++ uids) (Map.delete uid m, pkg:pkgs)+        | otherwise+        = go uids (m,pkgs)++-- | Given a 'PackageConfig' from some 'InstalledPackageIndex',+-- return all entries in 'depends' which correspond to packages+-- that do not exist in the index.+depsNotAvailable :: InstalledPackageIndex+                 -> PackageConfig+                 -> [InstalledUnitId]+depsNotAvailable pkg_map pkg = filter (not . (`Map.member` pkg_map)) (depends pkg)++-- | Given a 'PackageConfig' from some 'InstalledPackageIndex'+-- return all entries in 'abiDepends' which correspond to packages+-- that do not exist, OR have mismatching ABIs.+depsAbiMismatch :: InstalledPackageIndex+                -> PackageConfig+                -> [InstalledUnitId]+depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ abiDepends pkg+  where+    abiMatch (dep_uid, abi)+        | Just dep_pkg <- Map.lookup dep_uid pkg_map+        = abiHash dep_pkg == abi+        | otherwise+        = False++-- -----------------------------------------------------------------------------+-- Ignore packages++ignorePackages :: [IgnorePackageFlag] -> [PackageConfig] -> UnusablePackages+ignorePackages flags pkgs = Map.fromList (concatMap doit flags)+  where+  doit (IgnorePackage str) =+     case partition (matchingStr str) pkgs of+         (ps, _) -> [ (unitId p, (p, IgnoredWithFlag))+                    | p <- ps ]+        -- missing package is not an error for -ignore-package,+        -- because a common usage is to -ignore-package P as+        -- a preventative measure just in case P exists.++-- ----------------------------------------------------------------------------+--+-- Merging databases+--++-- | For each package, a mapping from uid -> i indicates that this+-- package was brought into GHC by the ith @-package-db@ flag on+-- the command line.  We use this mapping to make sure we prefer+-- packages that were defined later on the command line, if there+-- is an ambiguity.+type PackagePrecedenceIndex = Map InstalledUnitId Int++-- | Given a list of databases, merge them together, where+-- packages with the same unit id in later databases override+-- earlier ones.  This does NOT check if the resulting database+-- makes sense (that's done by 'validateDatabase').+mergeDatabases :: DynFlags -> [(FilePath, [PackageConfig])]+               -> IO (InstalledPackageIndex, PackagePrecedenceIndex)+mergeDatabases dflags = foldM merge (Map.empty, Map.empty) . zip [1..]+  where+    merge (pkg_map, prec_map) (i, (db_path, db)) = do+      debugTraceMsg dflags 2 $+          text "loading package database" <+> text db_path+      forM_ (Set.toList override_set) $ \pkg ->+          debugTraceMsg dflags 2 $+              text "package" <+> ppr pkg <+>+              text "overrides a previously defined package"+      return (pkg_map', prec_map')+     where+      db_map = mk_pkg_map db+      mk_pkg_map = Map.fromList . map (\p -> (unitId p, p))++      -- The set of UnitIds which appear in both db and pkgs.  These are the+      -- ones that get overridden.  Compute this just to give some+      -- helpful debug messages at -v2+      override_set :: Set InstalledUnitId+      override_set = Set.intersection (Map.keysSet db_map)+                                      (Map.keysSet pkg_map)++      -- Now merge the sets together (NB: in case of duplicate,+      -- first argument preferred)+      pkg_map' :: InstalledPackageIndex+      pkg_map' = Map.union db_map pkg_map++      prec_map' :: PackagePrecedenceIndex+      prec_map' = Map.union (Map.map (const i) db_map) prec_map++-- | Validates a database, removing unusable packages from it+-- (this includes removing packages that the user has explicitly+-- ignored.)  Our general strategy:+--+-- 1. Remove all broken packages (dangling dependencies)+-- 2. Remove all packages that are cyclic+-- 3. Apply ignore flags+-- 4. Remove all packages which have deps with mismatching ABIs+--+validateDatabase :: DynFlags -> InstalledPackageIndex+                 -> (InstalledPackageIndex, UnusablePackages, [SCC PackageConfig])+validateDatabase dflags pkg_map1 =+    (pkg_map5, unusable, sccs)+  where+    ignore_flags = reverse (ignorePackageFlags dflags)++    -- Compute the reverse dependency index+    index = reverseDeps pkg_map1++    -- Helper function+    mk_unusable mk_err dep_matcher m uids =+      Map.fromList [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg)))+                   | pkg <- uids ]++    -- Find broken packages+    directly_broken = filter (not . null . depsNotAvailable pkg_map1)+                             (Map.elems pkg_map1)+    (pkg_map2, broken) = removePackages (map unitId directly_broken) index pkg_map1+    unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken++    -- Find recursive packages+    sccs = stronglyConnComp [ (pkg, unitId pkg, depends pkg)+                            | pkg <- Map.elems pkg_map2 ]+    getCyclicSCC (CyclicSCC vs) = map unitId vs+    getCyclicSCC (AcyclicSCC _) = []+    (pkg_map3, cyclic) = removePackages (concatMap getCyclicSCC sccs) index pkg_map2+    unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic++    -- Apply ignore flags+    directly_ignored = ignorePackages ignore_flags (Map.elems pkg_map3)+    (pkg_map4, ignored) = removePackages (Map.keys directly_ignored) index pkg_map3+    unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored++    -- Knock out packages whose dependencies don't agree with ABI+    -- (i.e., got invalidated due to shadowing)+    directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4)+                               (Map.elems pkg_map4)+    (pkg_map5, shadowed) = removePackages (map unitId directly_shadowed) index pkg_map4+    unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed++    unusable = directly_ignored `Map.union` unusable_ignored+                                `Map.union` unusable_broken+                                `Map.union` unusable_cyclic+                                `Map.union` unusable_shadowed++-- -----------------------------------------------------------------------------+-- When all the command-line options are in, we can process our package+-- settings and populate the package state.++mkPackageState+    :: DynFlags+    -- initial databases, in the order they were specified on+    -- the command line (later databases shadow earlier ones)+    -> [(FilePath, [PackageConfig])]+    -> [PreloadUnitId]              -- preloaded packages+    -> IO (PackageState,+           [PreloadUnitId],         -- new packages to preload+           Maybe [(ModuleName, Module)])++mkPackageState dflags dbs preload0 = do+{-+   Plan.++   There are two main steps for making the package state:++    1. We want to build a single, unified package database based+       on all of the input databases, which upholds the invariant that+       there is only one package per any UnitId and there are no+       dangling dependencies.  We'll do this by merging, and+       then successively filtering out bad dependencies.++       a) Merge all the databases together.+          If an input database defines unit ID that is already in+          the unified database, that package SHADOWS the existing+          package in the current unified database.  Note that+          order is important: packages defined later in the list of+          command line arguments shadow those defined earlier.++       b) Remove all packages with missing dependencies, or+          mutually recursive dependencies.++       b) Remove packages selected by -ignore-package from input database++       c) Remove all packages which depended on packages that are now+          shadowed by an ABI-incompatible package++       d) report (with -v) any packages that were removed by steps 1-3++    2. We want to look at the flags controlling package visibility,+       and build a mapping of what module names are in scope and+       where they live.++       a) on the final, unified database, we apply -trust/-distrust+          flags directly, modifying the database so that the 'trusted'+          field has the correct value.++       b) we use the -package/-hide-package flags to compute a+          visibility map, stating what packages are "exposed" for+          the purposes of computing the module map.+          * if any flag refers to a package which was removed by 1-5, then+            we can give an error message explaining why+          * if -hide-all-packages what not specified, this step also+            hides packages which are superseded by later exposed packages+          * this step is done TWICE if -plugin-package/-hide-all-plugin-packages+            are used++       c) based on the visibility map, we pick wired packages and rewrite+          them to have the expected unitId.++       d) finally, using the visibility map and the package database,+          we build a mapping saying what every in scope module name points to.+-}++  -- This, and the other reverse's that you will see, are due to the face that+  -- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order+  -- than they are on the command line.+  let other_flags = reverse (packageFlags dflags)+  debugTraceMsg dflags 2 $+      text "package flags" <+> ppr other_flags++  -- Merge databases together, without checking validity+  (pkg_map1, prec_map) <- mergeDatabases dflags dbs++  -- Now that we've merged everything together, prune out unusable+  -- packages.+  let (pkg_map2, unusable, sccs) = validateDatabase dflags pkg_map1++  reportCycles dflags sccs+  reportUnusable dflags unusable++  -- Apply trust flags (these flags apply regardless of whether+  -- or not packages are visible or not)+  pkgs1 <- foldM (applyTrustFlag dflags prec_map unusable)+                 (Map.elems pkg_map2) (reverse (trustFlags dflags))+  let prelim_pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs1++  --+  -- Calculate the initial set of packages, prior to any package flags.+  -- This set contains the latest version of all valid (not unusable) packages,+  -- or is empty if we have -hide-all-packages+  --+  let preferLater pkg pkg' =+        case compareByPreference prec_map pkg pkg' of+            GT -> pkg+            _  -> pkg'+      calcInitial m pkg = addToUDFM_C preferLater m (fsPackageName pkg) pkg+      initial = if gopt Opt_HideAllPackages dflags+                    then emptyUDFM+                    else foldl' calcInitial emptyUDFM pkgs1+      vis_map1 = foldUDFM (\p vm ->+                            -- Note: we NEVER expose indefinite packages by+                            -- default, because it's almost assuredly not+                            -- what you want (no mix-in linking has occurred).+                            if exposed p && unitIdIsDefinite (packageConfigId p)+                               then Map.insert (packageConfigId p)+                                               UnitVisibility {+                                                 uv_expose_all = True,+                                                 uv_renamings = [],+                                                 uv_package_name = First (Just (fsPackageName p)),+                                                 uv_requirements = Map.empty,+                                                 uv_explicit = False+                                               }+                                               vm+                               else vm)+                         Map.empty initial++  --+  -- Compute a visibility map according to the command-line flags (-package,+  -- -hide-package).  This needs to know about the unusable packages, since if a+  -- user tries to enable an unusable package, we should let them know.+  --+  vis_map2 <- foldM (applyPackageFlag dflags prec_map prelim_pkg_db unusable+                        (gopt Opt_HideAllPackages dflags) pkgs1)+                            vis_map1 other_flags++  --+  -- Sort out which packages are wired in. This has to be done last, since+  -- it modifies the unit ids of wired in packages, but when we process+  -- package arguments we need to key against the old versions.+  --+  (pkgs2, wired_map) <- findWiredInPackages dflags prec_map pkgs1 vis_map2+  let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs2++  -- Update the visibility map, so we treat wired packages as visible.+  let vis_map = updateVisibilityMap wired_map vis_map2++  let hide_plugin_pkgs = gopt Opt_HideAllPluginPackages dflags+  plugin_vis_map <-+    case pluginPackageFlags dflags of+        -- common case; try to share the old vis_map+        [] | not hide_plugin_pkgs -> return vis_map+           | otherwise -> return Map.empty+        _ -> do let plugin_vis_map1+                        | hide_plugin_pkgs = Map.empty+                        -- Use the vis_map PRIOR to wired in,+                        -- because otherwise applyPackageFlag+                        -- won't work.+                        | otherwise = vis_map2+                plugin_vis_map2+                    <- foldM (applyPackageFlag dflags prec_map prelim_pkg_db unusable+                                (gopt Opt_HideAllPluginPackages dflags) pkgs1)+                             plugin_vis_map1+                             (reverse (pluginPackageFlags dflags))+                -- Updating based on wired in packages is mostly+                -- good hygiene, because it won't matter: no wired in+                -- package has a compiler plugin.+                -- TODO: If a wired in package had a compiler plugin,+                -- and you tried to pick different wired in packages+                -- with the plugin flags and the normal flags... what+                -- would happen?  I don't know!  But this doesn't seem+                -- likely to actually happen.+                return (updateVisibilityMap wired_map plugin_vis_map2)++  --+  -- Here we build up a set of the packages mentioned in -package+  -- flags on the command line; these are called the "preload"+  -- packages.  we link these packages in eagerly.  The preload set+  -- should contain at least rts & base, which is why we pretend that+  -- the command line contains -package rts & -package base.+  --+  -- NB: preload IS important even for type-checking, because we+  -- need the correct include path to be set.+  --+  let preload1 = Map.keys (Map.filter uv_explicit vis_map)++  let pkgname_map = foldl add Map.empty pkgs2+        where add pn_map p+                = Map.insert (packageName p) (componentId p) pn_map++  -- The explicitPackages accurately reflects the set of packages we have turned+  -- on; as such, it also is the only way one can come up with requirements.+  -- The requirement context is directly based off of this: we simply+  -- look for nested unit IDs that are directly fed holes: the requirements+  -- of those units are precisely the ones we need to track+  let explicit_pkgs = Map.keys vis_map+      req_ctx = Map.map (Set.toList)+              $ Map.unionsWith Set.union (map uv_requirements (Map.elems vis_map))+++  let preload2 = preload1++  let+      -- add base & rts to the preload packages+      basicLinkedPackages+       | gopt Opt_AutoLinkPackages dflags+          = filter (flip elemUDFM (unPackageConfigMap pkg_db))+                [baseUnitId, rtsUnitId]+       | otherwise = []+      -- but in any case remove the current package from the set of+      -- preloaded packages so that base/rts does not end up in the+      -- set up preloaded package when we are just building it+      -- (NB: since this is only relevant for base/rts it doesn't matter+      -- that thisUnitIdInsts_ is not wired yet)+      --+      preload3 = nub $ filter (/= thisPackage dflags)+                     $ (basicLinkedPackages ++ preload2)++  -- Close the preload packages with their dependencies+  dep_preload <- closeDeps dflags pkg_db (zip (map toInstalledUnitId preload3) (repeat Nothing))+  let new_dep_preload = filter (`notElem` preload0) dep_preload++  let mod_map = mkModuleToPkgConfAll dflags pkg_db vis_map+  when (dopt Opt_D_dump_mod_map dflags) $+      printInfoForUser (dflags { pprCols = 200 })+                       alwaysQualify (pprModuleMap mod_map)++  -- Force pstate to avoid leaking the dflags0 passed to mkPackageState+  let !pstate = PackageState{+    preloadPackages     = dep_preload,+    explicitPackages    = explicit_pkgs,+    pkgIdMap            = pkg_db,+    moduleToPkgConfAll  = mod_map,+    pluginModuleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db plugin_vis_map,+    packageNameMap          = pkgname_map,+    unwireMap = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ],+    requirementContext = req_ctx+    }+  let new_insts = fmap (map (fmap (upd_wired_in_mod wired_map))) (thisUnitIdInsts_ dflags)+  return (pstate, new_dep_preload, new_insts)++-- | Given a wired-in 'UnitId', "unwire" it into the 'UnitId'+-- that it was recorded as in the package database.+unwireUnitId :: DynFlags -> UnitId -> UnitId+unwireUnitId dflags uid@(DefiniteUnitId def_uid) =+    maybe uid DefiniteUnitId (Map.lookup def_uid (unwireMap (pkgState dflags)))+unwireUnitId _ uid = uid++-- -----------------------------------------------------------------------------+-- | Makes the mapping from module to package info++-- Slight irritation: we proceed by leafing through everything+-- in the installed package database, which makes handling indefinite+-- packages a bit bothersome.++mkModuleToPkgConfAll+  :: DynFlags+  -> PackageConfigMap+  -> VisibilityMap+  -> ModuleToPkgConfAll+mkModuleToPkgConfAll dflags pkg_db vis_map =+    Map.foldlWithKey extend_modmap emptyMap vis_map+ where+  emptyMap = Map.empty+  sing pk m _ = Map.singleton (mkModule pk m)+  addListTo = foldl' merge+  merge m (k, v) = MapStrict.insertWith (Map.unionWith mappend) k v m+  setOrigins m os = fmap (const os) m+  extend_modmap modmap uid+    UnitVisibility { uv_expose_all = b, uv_renamings = rns }+    = addListTo modmap theBindings+   where+    pkg = pkg_lookup uid++    theBindings :: [(ModuleName, Map Module ModuleOrigin)]+    theBindings = newBindings b rns++    newBindings :: Bool+                -> [(ModuleName, ModuleName)]+                -> [(ModuleName, Map Module ModuleOrigin)]+    newBindings e rns  = es e ++ hiddens ++ map rnBinding rns++    rnBinding :: (ModuleName, ModuleName)+              -> (ModuleName, Map Module ModuleOrigin)+    rnBinding (orig, new) = (new, setOrigins origEntry fromFlag)+     where origEntry = case lookupUFM esmap orig of+            Just r -> r+            Nothing -> throwGhcException (CmdLineError (showSDoc dflags+                        (text "package flag: could not find module name" <+>+                            ppr orig <+> text "in package" <+> ppr pk)))++    es :: Bool -> [(ModuleName, Map Module ModuleOrigin)]+    es e = do+     (m, exposedReexport) <- exposed_mods+     let (pk', m', pkg', origin') =+          case exposedReexport of+           Nothing -> (pk, m, pkg, fromExposedModules e)+           Just (Module pk' m') ->+            let pkg' = pkg_lookup pk'+            in (pk', m', pkg', fromReexportedModules e pkg')+     return (m, sing pk' m' pkg' origin')++    esmap :: UniqFM (Map Module ModuleOrigin)+    esmap = listToUFM (es False) -- parameter here doesn't matter, orig will+                                 -- be overwritten++    hiddens = [(m, sing pk m pkg ModHidden) | m <- hidden_mods]++    pk = packageConfigId pkg+    pkg_lookup uid = lookupPackage' (isIndefinite dflags) pkg_db uid+                        `orElse` pprPanic "pkg_lookup" (ppr uid)++    exposed_mods = exposedModules pkg+    hidden_mods = hiddenModules pkg++-- -----------------------------------------------------------------------------+-- Extracting information from the packages in scope++-- Many of these functions take a list of packages: in those cases,+-- the list is expected to contain the "dependent packages",+-- i.e. those packages that were found to be depended on by the+-- current module/program.  These can be auto or non-auto packages, it+-- doesn't really matter.  The list is always combined with the list+-- of preload (command-line) packages to determine which packages to+-- use.++-- | Find all the include directories in these and the preload packages+getPackageIncludePath :: DynFlags -> [PreloadUnitId] -> IO [String]+getPackageIncludePath dflags pkgs =+  collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs++collectIncludeDirs :: [PackageConfig] -> [FilePath]+collectIncludeDirs ps = nub (filter notNull (concatMap includeDirs ps))++-- | Find all the library paths in these and the preload packages+getPackageLibraryPath :: DynFlags -> [PreloadUnitId] -> IO [String]+getPackageLibraryPath dflags pkgs =+  collectLibraryPaths dflags `fmap` getPreloadPackagesAnd dflags pkgs++collectLibraryPaths :: DynFlags -> [PackageConfig] -> [FilePath]+collectLibraryPaths dflags = nub . filter notNull+                           . concatMap (libraryDirsForWay dflags)++-- | Find all the link options in these and the preload packages,+-- returning (package hs lib options, extra library options, other flags)+getPackageLinkOpts :: DynFlags -> [PreloadUnitId] -> IO ([String], [String], [String])+getPackageLinkOpts dflags pkgs =+  collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs++collectLinkOpts :: DynFlags -> [PackageConfig] -> ([String], [String], [String])+collectLinkOpts dflags ps =+    (+        concatMap (map ("-l" ++) . packageHsLibs dflags) ps,+        concatMap (map ("-l" ++) . extraLibraries) ps,+        concatMap ldOptions ps+    )++packageHsLibs :: DynFlags -> PackageConfig -> [String]+packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p)+  where+        ways0 = ways dflags++        ways1 = filter (/= WayDyn) ways0+        -- the name of a shared library is libHSfoo-ghc<version>.so+        -- we leave out the _dyn, because it is superfluous++        -- debug and profiled RTSs include support for -eventlog+        ways2 | WayDebug `elem` ways1 || WayProf `elem` ways1+              = filter (/= WayEventLog) ways1+              | otherwise+              = ways1++        tag     = mkBuildTag (filter (not . wayRTSOnly) ways2)+        rts_tag = mkBuildTag ways2++        mkDynName x+         | WayDyn `notElem` ways dflags = x+         | "HS" `isPrefixOf` x          =+              x ++ '-':programName dflags ++ projectVersion dflags+           -- For non-Haskell libraries, we use the name "Cfoo". The .a+           -- file is libCfoo.a, and the .so is libfoo.so. That way the+           -- linker knows what we mean for the vanilla (-lCfoo) and dyn+           -- (-lfoo) ways. We therefore need to strip the 'C' off here.+         | Just x' <- stripPrefix "C" x = x'+         | otherwise+            = panic ("Don't understand library name " ++ x)++        addSuffix rts@"HSrts"    = rts       ++ (expandTag rts_tag)+        addSuffix other_lib      = other_lib ++ (expandTag tag)++        expandTag t | null t = ""+                    | otherwise = '_':t++-- | Either the 'libraryDirs' or 'libraryDynDirs' as appropriate for the way.+libraryDirsForWay :: DynFlags -> PackageConfig -> [String]+libraryDirsForWay dflags+  | WayDyn `elem` ways dflags = libraryDynDirs+  | otherwise                 = libraryDirs++-- | Find all the C-compiler options in these and the preload packages+getPackageExtraCcOpts :: DynFlags -> [PreloadUnitId] -> IO [String]+getPackageExtraCcOpts dflags pkgs = do+  ps <- getPreloadPackagesAnd dflags pkgs+  return (concatMap ccOptions ps)++-- | Find all the package framework paths in these and the preload packages+getPackageFrameworkPath  :: DynFlags -> [PreloadUnitId] -> IO [String]+getPackageFrameworkPath dflags pkgs = do+  ps <- getPreloadPackagesAnd dflags pkgs+  return (nub (filter notNull (concatMap frameworkDirs ps)))++-- | Find all the package frameworks in these and the preload packages+getPackageFrameworks  :: DynFlags -> [PreloadUnitId] -> IO [String]+getPackageFrameworks dflags pkgs = do+  ps <- getPreloadPackagesAnd dflags pkgs+  return (concatMap frameworks ps)++-- -----------------------------------------------------------------------------+-- Package Utils++-- | Takes a 'ModuleName', and if the module is in any package returns+-- list of modules which take that name.+lookupModuleInAllPackages :: DynFlags+                          -> ModuleName+                          -> [(Module, PackageConfig)]+lookupModuleInAllPackages dflags m+  = case lookupModuleWithSuggestions dflags m Nothing of+      LookupFound a b -> [(a,b)]+      LookupMultiple rs -> map f rs+        where f (m,_) = (m, expectJust "lookupModule" (lookupPackage dflags+                                                         (moduleUnitId m)))+      _ -> []++-- | The result of performing a lookup+data LookupResult =+    -- | Found the module uniquely, nothing else to do+    LookupFound Module PackageConfig+    -- | Multiple modules with the same name in scope+  | LookupMultiple [(Module, ModuleOrigin)]+    -- | No modules found, but there were some hidden ones with+    -- an exact name match.  First is due to package hidden, second+    -- is due to module being hidden+  | LookupHidden [(Module, ModuleOrigin)] [(Module, ModuleOrigin)]+    -- | Nothing found, here are some suggested different names+  | LookupNotFound [ModuleSuggestion] -- suggestions++data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin+                      | SuggestHidden ModuleName Module ModuleOrigin++lookupModuleWithSuggestions :: DynFlags+                            -> ModuleName+                            -> Maybe FastString+                            -> LookupResult+lookupModuleWithSuggestions dflags+  = lookupModuleWithSuggestions' dflags+        (moduleToPkgConfAll (pkgState dflags))++lookupPluginModuleWithSuggestions :: DynFlags+                                  -> ModuleName+                                  -> Maybe FastString+                                  -> LookupResult+lookupPluginModuleWithSuggestions dflags+  = lookupModuleWithSuggestions' dflags+        (pluginModuleToPkgConfAll (pkgState dflags))++lookupModuleWithSuggestions' :: DynFlags+                            -> ModuleToPkgConfAll+                            -> ModuleName+                            -> Maybe FastString+                            -> LookupResult+lookupModuleWithSuggestions' dflags mod_map m mb_pn+  = case Map.lookup m mod_map of+        Nothing -> LookupNotFound suggestions+        Just xs ->+          case foldl' classify ([],[],[]) (Map.toList xs) of+            ([], [], []) -> LookupNotFound suggestions+            (_, _, [(m, _)])             -> LookupFound m (mod_pkg m)+            (_, _, exposed@(_:_))        -> LookupMultiple exposed+            (hidden_pkg, hidden_mod, []) -> LookupHidden hidden_pkg hidden_mod+  where+    classify (hidden_pkg, hidden_mod, exposed) (m, origin0) =+      let origin = filterOrigin mb_pn (mod_pkg m) origin0+          x = (m, origin)+      in case origin of+          ModHidden                  -> (hidden_pkg,   x:hidden_mod, exposed)+          _ | originEmpty origin     -> (hidden_pkg,   hidden_mod,   exposed)+            | originVisible origin   -> (hidden_pkg,   hidden_mod,   x:exposed)+            | otherwise              -> (x:hidden_pkg, hidden_mod,   exposed)++    pkg_lookup p = lookupPackage dflags p `orElse` pprPanic "lookupModuleWithSuggestions" (ppr p <+> ppr m)+    mod_pkg = pkg_lookup . moduleUnitId++    -- Filters out origins which are not associated with the given package+    -- qualifier.  No-op if there is no package qualifier.  Test if this+    -- excluded all origins with 'originEmpty'.+    filterOrigin :: Maybe FastString+                 -> PackageConfig+                 -> ModuleOrigin+                 -> ModuleOrigin+    filterOrigin Nothing _ o = o+    filterOrigin (Just pn) pkg o =+      case o of+          ModHidden -> if go pkg then ModHidden else mempty+          ModOrigin { fromOrigPackage = e, fromExposedReexport = res,+                      fromHiddenReexport = rhs }+            -> ModOrigin {+                  fromOrigPackage = if go pkg then e else Nothing+                , fromExposedReexport = filter go res+                , fromHiddenReexport = filter go rhs+                , fromPackageFlag = False -- always excluded+                }+      where go pkg = pn == fsPackageName pkg++    suggestions+      | gopt Opt_HelpfulErrors dflags =+           fuzzyLookup (moduleNameString m) all_mods+      | otherwise = []++    all_mods :: [(String, ModuleSuggestion)]     -- All modules+    all_mods = sortBy (comparing fst) $+        [ (moduleNameString m, suggestion)+        | (m, e) <- Map.toList (moduleToPkgConfAll (pkgState dflags))+        , suggestion <- map (getSuggestion m) (Map.toList e)+        ]+    getSuggestion name (mod, origin) =+        (if originVisible origin then SuggestVisible else SuggestHidden)+            name mod origin++listVisibleModuleNames :: DynFlags -> [ModuleName]+listVisibleModuleNames dflags =+    map fst (filter visible (Map.toList (moduleToPkgConfAll (pkgState dflags))))+  where visible (_, ms) = any originVisible (Map.elems ms)++-- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of+-- 'PackageConfig's+getPreloadPackagesAnd :: DynFlags -> [PreloadUnitId] -> IO [PackageConfig]+getPreloadPackagesAnd dflags pkgids =+  let+      state   = pkgState dflags+      pkg_map = pkgIdMap state+      preload = preloadPackages state+      pairs = zip pkgids (repeat Nothing)+  in do+  all_pkgs <- throwErr dflags (foldM (add_package dflags pkg_map) preload pairs)+  return (map (getInstalledPackageDetails dflags) all_pkgs)++-- Takes a list of packages, and returns the list with dependencies included,+-- in reverse dependency order (a package appears before those it depends on).+closeDeps :: DynFlags+          -> PackageConfigMap+          -> [(InstalledUnitId, Maybe InstalledUnitId)]+          -> IO [InstalledUnitId]+closeDeps dflags pkg_map ps+    = throwErr dflags (closeDepsErr dflags pkg_map ps)++throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a+throwErr dflags m+              = case m of+                Failed e    -> throwGhcExceptionIO (CmdLineError (showSDoc dflags e))+                Succeeded r -> return r++closeDepsErr :: DynFlags+             -> PackageConfigMap+             -> [(InstalledUnitId,Maybe InstalledUnitId)]+             -> MaybeErr MsgDoc [InstalledUnitId]+closeDepsErr dflags pkg_map ps = foldM (add_package dflags pkg_map) [] ps++-- internal helper+add_package :: DynFlags+            -> PackageConfigMap+            -> [PreloadUnitId]+            -> (PreloadUnitId,Maybe PreloadUnitId)+            -> MaybeErr MsgDoc [PreloadUnitId]+add_package dflags pkg_db ps (p, mb_parent)+  | p `elem` ps = return ps     -- Check if we've already added this package+  | otherwise =+      case lookupInstalledPackage' pkg_db p of+        Nothing -> Failed (missingPackageMsg p <>+                           missingDependencyMsg mb_parent)+        Just pkg -> do+           -- Add the package's dependents also+           ps' <- foldM add_unit_key ps (depends pkg)+           return (p : ps')+          where+            add_unit_key ps key+              = add_package dflags pkg_db ps (key, Just p)++missingPackageMsg :: Outputable pkgid => pkgid -> SDoc+missingPackageMsg p = text "unknown package:" <+> ppr p++missingDependencyMsg :: Maybe InstalledUnitId -> SDoc+missingDependencyMsg Nothing = Outputable.empty+missingDependencyMsg (Just parent)+  = space <> parens (text "dependency of" <+> ftext (installedUnitIdFS parent))++-- -----------------------------------------------------------------------------++componentIdString :: DynFlags -> ComponentId -> Maybe String+componentIdString dflags cid = do+    conf <- lookupInstalledPackage dflags (componentIdToInstalledUnitId cid)+    return $+        case sourceLibName conf of+            Nothing -> sourcePackageIdString conf+            Just (PackageName libname) ->+                packageNameString conf+                    ++ "-" ++ showVersion (packageVersion conf)+                    ++ ":" ++ unpackFS libname++displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String+displayInstalledUnitId dflags uid =+    fmap sourcePackageIdString (lookupInstalledPackage dflags uid)++-- | Will the 'Name' come from a dynamically linked library?+isDllName :: DynFlags -> Module -> Name -> Bool+-- Despite the "dll", I think this function just means that+-- the symbol comes from another dynamically-linked package,+-- and applies on all platforms, not just Windows+isDllName dflags this_mod name+  | WayDyn `notElem` ways dflags = False+  | Just mod <- nameModule_maybe name+    -- Issue #8696 - when GHC is dynamically linked, it will attempt+    -- to load the dynamic dependencies of object files at compile+    -- time for things like QuasiQuotes or+    -- TemplateHaskell. Unfortunately, this interacts badly with+    -- intra-package linking, because we don't generate indirect+    -- (dynamic) symbols for intra-package calls. This means that if a+    -- module with an intra-package call is loaded without its+    -- dependencies, then GHC fails to link. This is the cause of #+    --+    -- In the mean time, always force dynamic indirections to be+    -- generated: when the module name isn't the module being+    -- compiled, references are dynamic.+    = if mod /= this_mod+      then True+      else case dllSplit dflags of+           Nothing -> False+           Just ss ->+               let findMod m = let modStr = moduleNameString (moduleName m)+                               in case find (modStr `Set.member`) ss of+                                  Just i -> i+                                  Nothing -> panic ("Can't find " ++ modStr ++ "in DLL split")+               in findMod mod /= findMod this_mod++  | otherwise = False  -- no, it is not even an external name++-- -----------------------------------------------------------------------------+-- Displaying packages++-- | Show (very verbose) package info+pprPackages :: DynFlags -> SDoc+pprPackages = pprPackagesWith pprPackageConfig++pprPackagesWith :: (PackageConfig -> SDoc) -> DynFlags -> SDoc+pprPackagesWith pprIPI dflags =+    vcat (intersperse (text "---") (map pprIPI (listPackageConfigMap dflags)))++-- | Show simplified package info.+--+-- The idea is to only print package id, and any information that might+-- be different from the package databases (exposure, trust)+pprPackagesSimple :: DynFlags -> SDoc+pprPackagesSimple = pprPackagesWith pprIPI+    where pprIPI ipi = let i = installedUnitIdFS (unitId ipi)+                           e = if exposed ipi then text "E" else text " "+                           t = if trusted ipi then text "T" else text " "+                       in e <> t <> text "  " <> ftext i++-- | Show the mapping of modules to where they come from.+pprModuleMap :: ModuleToPkgConfAll -> SDoc+pprModuleMap mod_map =+  vcat (map pprLine (Map.toList mod_map))+    where+      pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e)))+      pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc+      pprEntry m (m',o)+        | m == moduleName m' = ppr (moduleUnitId m') <+> parens (ppr o)+        | otherwise = ppr m' <+> parens (ppr o)++fsPackageName :: PackageConfig -> FastString+fsPackageName = mkFastString . packageNameString++-- | Given a fully instantiated 'UnitId', improve it into a+-- 'InstalledUnitId' if we can find it in the package database.+improveUnitId :: PackageConfigMap -> UnitId -> UnitId+improveUnitId _ uid@(DefiniteUnitId _) = uid -- short circuit+improveUnitId pkg_map uid =+    -- Do NOT lookup indefinite ones, they won't be useful!+    case lookupPackage' False pkg_map uid of+        Nothing  -> uid+        Just pkg ->+            -- Do NOT improve if the indefinite unit id is not+            -- part of the closure unique set.  See+            -- Note [UnitId to InstalledUnitId improvement]+            if installedPackageConfigId pkg `elementOfUniqSet` preloadClosure pkg_map+                then packageConfigId pkg+                else uid++-- | Retrieve the 'PackageConfigMap' from 'DynFlags'; used+-- in the @hs-boot@ loop-breaker.+getPackageConfigMap :: DynFlags -> PackageConfigMap+getPackageConfigMap = pkgIdMap . pkgState
+ main/Packages.hs-boot view
@@ -0,0 +1,10 @@+module Packages where+import {-# SOURCE #-} DynFlags(DynFlags)+import {-# SOURCE #-} Module(ComponentId, UnitId, InstalledUnitId)+data PackageState+data PackageConfigMap+emptyPackageState :: PackageState+componentIdString :: DynFlags -> ComponentId -> Maybe String+displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String+improveUnitId :: PackageConfigMap -> UnitId -> UnitId+getPackageConfigMap :: DynFlags -> PackageConfigMap
+ main/PipelineMonad.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE NamedFieldPuns #-}+-- | The CompPipeline monad and associated ops+--+-- Defined in separate module so that it can safely be imported from Hooks+module PipelineMonad (+    CompPipeline(..), evalP+  , PhasePlus(..)+  , PipeEnv(..), PipeState(..), PipelineOutput(..)+  , getPipeEnv, getPipeState, setDynFlags, setModLocation, setForeignOs+  ) where++import MonadUtils+import Outputable+import DynFlags+import DriverPhases+import HscTypes+import Module++import Control.Monad++newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) }++evalP :: CompPipeline a -> PipeEnv -> PipeState -> IO a+evalP f env st = liftM snd $ unP f env st++instance Functor CompPipeline where+    fmap = liftM++instance Applicative CompPipeline where+    pure a = P $ \_env state -> return (state, a)+    (<*>) = ap++instance Monad CompPipeline where+  P m >>= k = P $ \env state -> do (state',a) <- m env state+                                   unP (k a) env state'++instance MonadIO CompPipeline where+    liftIO m = P $ \_env state -> do a <- m; return (state, a)++data PhasePlus = RealPhase Phase+               | HscOut HscSource ModuleName HscStatus++instance Outputable PhasePlus where+    ppr (RealPhase p) = ppr p+    ppr (HscOut {}) = text "HscOut"++-- -----------------------------------------------------------------------------+-- The pipeline uses a monad to carry around various bits of information++-- PipeEnv: invariant information passed down+data PipeEnv = PipeEnv {+       stop_phase   :: Phase,       -- ^ Stop just before this phase+       src_filename :: String,      -- ^ basename of original input source+       src_basename :: String,      -- ^ basename of original input source+       src_suffix   :: String,      -- ^ its extension+       output_spec  :: PipelineOutput -- ^ says where to put the pipeline output+  }++-- PipeState: information that might change during a pipeline run+data PipeState = PipeState {+       hsc_env   :: HscEnv,+          -- ^ only the DynFlags change in the HscEnv.  The DynFlags change+          -- at various points, for example when we read the OPTIONS_GHC+          -- pragmas in the Cpp phase.+       maybe_loc :: Maybe ModLocation,+          -- ^ the ModLocation.  This is discovered during compilation,+          -- in the Hsc phase where we read the module header.+       foreign_os :: [FilePath]+         -- ^ additional object files resulting from compiling foreign+         -- code. They come from two sources: foreign stubs, and+         -- add{C,Cxx,Objc,Objcxx}File from template haskell+  }++data PipelineOutput+  = Temporary+        -- ^ Output should be to a temporary file: we're going to+        -- run more compilation steps on this output later.+  | Persistent+        -- ^ We want a persistent file, i.e. a file in the current directory+        -- derived from the input filename, but with the appropriate extension.+        -- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o.+  | SpecificFile+        -- ^ The output must go into the specific outputFile in DynFlags.+        -- We don't store the filename in the constructor as it changes+        -- when doing -dynamic-too.+    deriving Show++getPipeEnv :: CompPipeline PipeEnv+getPipeEnv = P $ \env state -> return (state, env)++getPipeState :: CompPipeline PipeState+getPipeState = P $ \_env state -> return (state, state)++instance HasDynFlags CompPipeline where+    getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state))++setDynFlags :: DynFlags -> CompPipeline ()+setDynFlags dflags = P $ \_env state ->+  return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ())++setModLocation :: ModLocation -> CompPipeline ()+setModLocation loc = P $ \_env state ->+  return (state{ maybe_loc = Just loc }, ())++setForeignOs :: [FilePath] -> CompPipeline ()+setForeignOs os = P $ \_env state ->+  return (state{ foreign_os = os }, ())
+ main/PlatformConstants.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE CPP #-}++-------------------------------------------------------------------------------+--+-- | Platform constants+--+-- (c) The University of Glasgow 2013+--+-------------------------------------------------------------------------------++module PlatformConstants (PlatformConstants(..)) where++-- Produced by deriveConstants+#include "GHCConstantsHaskellType.hs"+
+ main/Plugins.hs view
@@ -0,0 +1,48 @@+module Plugins (+    FrontendPlugin(..), defaultFrontendPlugin,+    Plugin(..), CommandLineOption,+    defaultPlugin+    ) where++import CoreMonad ( CoreToDo, CoreM )+import TcRnTypes ( TcPlugin )+import GhcMonad+import DriverPhases+++-- | Command line options gathered from the -PModule.Name:stuff syntax+-- are given to you as this type+type CommandLineOption = String++-- | 'Plugin' is the core compiler plugin data type. Try to avoid+-- constructing one of these directly, and just modify some fields of+-- 'defaultPlugin' instead: this is to try and preserve source-code+-- compatibility when we add fields to this.+--+-- Nonetheless, this API is preliminary and highly likely to change in+-- the future.+data Plugin = Plugin {+    installCoreToDos :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]+    -- ^ Modify the Core pipeline that will be used for compilation.+    -- This is called as the Core pipeline is built for every module+    -- being compiled, and plugins get the opportunity to modify the+    -- pipeline in a nondeterministic order.+  , tcPlugin :: [CommandLineOption] -> Maybe TcPlugin+    -- ^ An optional typechecker plugin, which may modify the+    -- behaviour of the constraint solver.+  }++-- | Default plugin: does nothing at all! For compatibility reasons+-- you should base all your plugin definitions on this default value.+defaultPlugin :: Plugin+defaultPlugin = Plugin {+        installCoreToDos = const return+      , tcPlugin         = const Nothing+    }++type FrontendPluginAction = [String] -> [(String, Maybe Phase)] -> Ghc ()+data FrontendPlugin = FrontendPlugin {+      frontend :: FrontendPluginAction+    }+defaultFrontendPlugin :: FrontendPlugin+defaultFrontendPlugin = FrontendPlugin { frontend = \_ _ -> return () }
+ main/PprTyThing.hs view
@@ -0,0 +1,171 @@+-----------------------------------------------------------------------------+--+-- Pretty-printing TyThings+--+-- (c) The GHC Team 2005+--+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+module PprTyThing (+        pprTyThing,+        pprTyThingInContext,+        pprTyThingLoc,+        pprTyThingInContextLoc,+        pprTyThingHdr,+        pprTypeForUser,+        pprFamInst+  ) where++#include "HsVersions.h"++import Type    ( TyThing(..) )+import IfaceSyn ( ShowSub(..), ShowHowMuch(..), AltPpr(..)+  , showToHeader, pprIfaceDecl )+import CoAxiom ( coAxiomTyCon )+import HscTypes( tyThingParent_maybe )+import MkIface ( tyThingToIfaceDecl )+import Type ( tidyOpenType )+import FamInstEnv( FamInst(..), FamFlavor(..) )+import Type( Type, pprTypeApp, pprSigmaType )+import Name+import VarEnv( emptyTidyEnv )+import Outputable++-- -----------------------------------------------------------------------------+-- Pretty-printing entities that we get from the GHC API++{-  Note [Pretty-printing TyThings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We pretty-print a TyThing by converting it to an IfaceDecl,+and pretty-printing that (see ppr_ty_thing below).+Here is why:++* When pretty-printing (a type, say), the idiomatic solution is not to+  "rename type variables on the fly", but rather to "tidy" the type+  (which gives each variable a distinct print-name), and then+  pretty-print it (without renaming). Separate the two+  concerns. Functions like tidyType do this.++* Alas, for type constructors, TyCon, tidying does not work well,+  because a TyCon includes DataCons which include Types, which mention+  TyCons. And tidying can't tidy a mutually recursive data structure+  graph, only trees.++* One alternative would be to ensure that TyCons get type variables+  with distinct print-names. That's ok for type variables but less+  easy for kind variables. Processing data type declarations is+  already so complicated that I don't think it's sensible to add the+  extra requirement that it generates only "pretty" types and kinds.++*  One place the non-pretty names can show up is in GHCi. But another+   is in interface files. Look at MkIface.tyThingToIfaceDecl which+   converts a TyThing (i.e. TyCon, Class etc) to an IfaceDecl. And it+   already does tidying as part of that conversion!  Why? Because+   interface files contains fast-strings, not uniques, so the names+   must at least be distinct.++So if we convert to IfaceDecl, we get a nice tidy IfaceDecl, and can+print that.  Of course, that means that pretty-printing IfaceDecls+must be careful to display nice user-friendly results, but that's ok.++See #7730, #8776 for details   -}++--------------------+-- | Pretty-prints a 'FamInst' (type/data family instance) with its defining location.+pprFamInst :: FamInst -> SDoc+--  * For data instances we go via pprTyThing of the representational TyCon,+--    because there is already much cleverness associated with printing+--    data type declarations that I don't want to duplicate+--  * For type instances we print directly here; there is no TyCon+--    to give to pprTyThing+--+-- FamInstEnv.pprFamInst does a more quick-and-dirty job for internal purposes++pprFamInst (FamInst { fi_flavor = DataFamilyInst rep_tc })+  = pprTyThingInContextLoc (ATyCon rep_tc)++pprFamInst (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom+                    , fi_tys = lhs_tys, fi_rhs = rhs })+  = showWithLoc (pprDefinedAt (getName axiom)) $+    hang (text "type instance" <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys)+       2 (equals <+> ppr rhs)++----------------------------+-- | Pretty-prints a 'TyThing' with its defining location.+pprTyThingLoc :: TyThing -> SDoc+pprTyThingLoc tyThing+  = showWithLoc (pprDefinedAt (getName tyThing))+                (pprTyThing showToHeader tyThing)++-- | Pretty-prints the 'TyThing' header. For functions and data constructors+-- the function is equivalent to 'pprTyThing' but for type constructors+-- and classes it prints only the header part of the declaration.+pprTyThingHdr :: TyThing -> SDoc+pprTyThingHdr = pprTyThing showToHeader++-- | Pretty-prints a 'TyThing' in context: that is, if the entity+-- is a data constructor, record selector, or class method, then+-- the entity's parent declaration is pretty-printed with irrelevant+-- parts omitted.+pprTyThingInContext :: ShowSub -> TyThing -> SDoc+pprTyThingInContext show_sub thing+  = go [] thing+  where+    go ss thing+      = case tyThingParent_maybe thing of+          Just parent ->+            go (getOccName thing : ss) parent+          Nothing ->+            pprTyThing+              (show_sub { ss_how_much = ShowSome ss (AltPpr Nothing) })+              thing++-- | Like 'pprTyThingInContext', but adds the defining location.+pprTyThingInContextLoc :: TyThing -> SDoc+pprTyThingInContextLoc tyThing+  = showWithLoc (pprDefinedAt (getName tyThing))+                (pprTyThingInContext showToHeader tyThing)++-- | Pretty-prints a 'TyThing'.+pprTyThing :: ShowSub -> TyThing -> SDoc+-- We pretty-print 'TyThing' via 'IfaceDecl'+-- See Note [Pretty-printing TyThings]+pprTyThing ss ty_thing+  = pprIfaceDecl ss' (tyThingToIfaceDecl ty_thing)+  where+    ss' = case ss_how_much ss of+      ShowHeader (AltPpr Nothing)  -> ss { ss_how_much = ShowHeader ppr' }+      ShowSome xs (AltPpr Nothing) -> ss { ss_how_much = ShowSome xs ppr' }+      _                   -> ss++    ppr' = AltPpr $ ppr_bndr $ getName ty_thing++    ppr_bndr :: Name -> Maybe (OccName -> SDoc)+    ppr_bndr name+      | isBuiltInSyntax name+         = Nothing+      | otherwise+         = case nameModule_maybe name of+             Just mod -> Just $ \occ -> getPprStyle $ \sty ->+               pprModulePrefix sty mod occ <> ppr occ+             Nothing  -> WARN( True, ppr name ) Nothing+             -- Nothing is unexpected here; TyThings have External names++pprTypeForUser :: Type -> SDoc+-- The type is tidied+pprTypeForUser ty+  = pprSigmaType tidy_ty+  where+    (_, tidy_ty)     = tidyOpenType emptyTidyEnv ty+     -- Often the types/kinds we print in ghci are fully generalised+     -- and have no free variables, but it turns out that we sometimes+     -- print un-generalised kinds (eg when doing :k T), so it's+     -- better to use tidyOpenType here++showWithLoc :: SDoc -> SDoc -> SDoc+showWithLoc loc doc+    = hang doc 2 (char '\t' <> comment <+> loc)+                -- The tab tries to make them line up a bit+  where+    comment = text "--"
+ main/StaticPtrTable.hs view
@@ -0,0 +1,290 @@+-- | Code generation for the Static Pointer Table+--+-- (c) 2014 I/O Tweag+--+-- Each module that uses 'static' keyword declares an initialization function of+-- the form hs_spt_init_<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_spt_insert to insert the static+-- pointers of this module in the hashtable of the RTS, and it looks something+-- like this:+--+-- > static void hs_hpc_init_Main(void) __attribute__((constructor));+-- > static void hs_hpc_init_Main(void) {+-- >+-- >   static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL};+-- >   extern StgPtr Main_r2wb_closure;+-- >   hs_spt_insert(k0, &Main_r2wb_closure);+-- >+-- >   static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL};+-- >   extern StgPtr Main_r2wc_closure;+-- >   hs_spt_insert(k1, &Main_r2wc_closure);+-- >+-- > }+--+-- where the constants are fingerprints produced from the static forms.+--+-- The linker must find the definitions matching the @extern StgPtr <name>@+-- declarations. For this to work, the identifiers of static pointers need to be+-- exported. This is done in SetLevels.newLvlVar.+--+-- There is also a finalization function for the time when the module is+-- unloaded.+--+-- > static void hs_hpc_fini_Main(void) __attribute__((destructor));+-- > static void hs_hpc_fini_Main(void) {+-- >+-- >   static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL};+-- >   hs_spt_remove(k0);+-- >+-- >   static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL};+-- >   hs_spt_remove(k1);+-- >+-- > }+--++{-# LANGUAGE ViewPatterns, TupleSections #-}+module StaticPtrTable+    ( sptCreateStaticBinds+    , sptModuleInitCode+    ) where++{- Note [Grand plan for static forms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Static forms go through the compilation phases as follows.+Here is a running example:++   f x = let k = map toUpper+         in ...(static k)...++* The renamer looks for out-of-scope names in the body of the static+  form, as always If all names are in scope, the free variables of the+  body are stored in AST at the location of the static form.++* The typechecker verifies that all free variables occurring in the+  static form are floatable to top level (see Note [Meaning of+  IdBindingInfo] in TcRnTypes).  In our example, 'k' is floatable, even+  though it is bound in a nested let, we are fine.++* The desugarer replaces the static form with an application of the+  function 'makeStatic' (defined in module GHC.StaticPtr.Internal of+  base).  So we get++   f x = let k = map toUpper+         in ...fromStaticPtr (makeStatic location k)...++* The simplifier runs the FloatOut pass which moves the calls to 'makeStatic'+  to the top level. Thus the FloatOut pass is always executed, even when+  optimizations are disabled.  So we get++   k = map toUpper+   static_ptr = makeStatic location k+   f x = ...fromStaticPtr static_ptr...++  The FloatOut pass is careful to produce an /exported/ Id for a floated+  'makeStatic' call, so the binding is not removed or inlined by the+  simplifier.+  E.g. the code for `f` above might look like++    static_ptr = makeStatic location k+    f x = ...(case static_ptr of ...)...++  which might be simplified to++    f x = ...(case makeStatic location k of ...)...++  BUT the top-level binding for static_ptr must remain, so that it can be+  collected to populate the Static Pointer Table.++  Making the binding exported also has a necessary effect during the+  CoreTidy pass.++* The CoreTidy pass replaces all bindings of the form++  b = /\ ... -> makeStatic location value++  with++  b = /\ ... -> StaticPtr key (StaticPtrInfo "pkg key" "module" location) value++  where a distinct key is generated for each binding.++* If we are compiling to object code we insert a C stub (generated by+  sptModuleInitCode) into the final object which runs when the module is loaded,+  inserting the static forms defined by the module into the RTS's static pointer+  table.++* If we are compiling for the byte-code interpreter, we instead explicitly add+  the SPT entries (recorded in CgGuts' cg_spt_entries field) to the interpreter+  process' SPT table using the addSptEntry interpreter message. This happens+  in upsweep after we have compiled the module (see GhcMake.upsweep').+-}++import CLabel+import CoreSyn+import CoreUtils (collectMakeStaticArgs)+import DataCon+import DynFlags+import HscTypes+import Id+import MkCore (mkStringExprFSWith)+import Module+import Name+import Outputable+import Platform+import PrelNames+import TcEnv (lookupGlobal)+import Type++import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.State+import Data.List+import Data.Maybe+import GHC.Fingerprint+import qualified GHC.LanguageExtensions as LangExt++-- | Replaces all bindings of the form+--+-- > b = /\ ... -> makeStatic location value+--+--  with+--+-- > b = /\ ... ->+-- >   StaticPtr key (StaticPtrInfo "pkg key" "module" location) value+--+--  where a distinct key is generated for each binding.+--+-- It also yields the C stub that inserts these bindings into the static+-- pointer table.+sptCreateStaticBinds :: HscEnv -> Module -> CoreProgram+                     -> IO ([SptEntry], CoreProgram)+sptCreateStaticBinds hsc_env this_mod binds+    | not (xopt LangExt.StaticPointers dflags) =+      return ([], binds)+    | otherwise = do+      -- Make sure the required interface files are loaded.+      _ <- lookupGlobal hsc_env unpackCStringName+      (fps, binds') <- evalStateT (go [] [] binds) 0+      return (fps, binds')+  where+    go fps bs xs = case xs of+      []        -> return (reverse fps, reverse bs)+      bnd : xs' -> do+        (fps', bnd') <- replaceStaticBind bnd+        go (reverse fps' ++ fps) (bnd' : bs) xs'++    dflags = hsc_dflags hsc_env++    -- Generates keys and replaces 'makeStatic' with 'StaticPtr'.+    --+    -- The 'Int' state is used to produce a different key for each binding.+    replaceStaticBind :: CoreBind+                      -> StateT Int IO ([SptEntry], CoreBind)+    replaceStaticBind (NonRec b e) = do (mfp, (b', e')) <- replaceStatic b e+                                        return (maybeToList mfp, NonRec b' e')+    replaceStaticBind (Rec rbs) = do+      (mfps, rbs') <- unzip <$> mapM (uncurry replaceStatic) rbs+      return (catMaybes mfps, Rec rbs')++    replaceStatic :: Id -> CoreExpr+                  -> StateT Int IO (Maybe SptEntry, (Id, CoreExpr))+    replaceStatic b e@(collectTyBinders -> (tvs, e0)) =+      case collectMakeStaticArgs e0 of+        Nothing      -> return (Nothing, (b, e))+        Just (_, t, info, arg) -> do+          (fp, e') <- mkStaticBind t info arg+          return (Just (SptEntry b fp), (b, foldr Lam e' tvs))++    mkStaticBind :: Type -> CoreExpr -> CoreExpr+                 -> StateT Int IO (Fingerprint, CoreExpr)+    mkStaticBind t srcLoc e = do+      i <- get+      put (i + 1)+      staticPtrInfoDataCon <-+        lift $ lookupDataConHscEnv staticPtrInfoDataConName+      let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i+      info <- mkConApp staticPtrInfoDataCon <$>+            (++[srcLoc]) <$>+            mapM (mkStringExprFSWith (lift . lookupIdHscEnv))+                 [ unitIdFS $ moduleUnitId this_mod+                 , moduleNameFS $ moduleName this_mod+                 ]++      -- The module interface of GHC.StaticPtr should be loaded at least+      -- when looking up 'fromStatic' during type-checking.+      staticPtrDataCon <- lift $ lookupDataConHscEnv staticPtrDataConName+      return (fp, mkConApp staticPtrDataCon+                               [ Type t+                               , mkWord64LitWordRep dflags w0+                               , mkWord64LitWordRep dflags w1+                               , info+                               , e ])++    mkStaticPtrFingerprint :: Int -> Fingerprint+    mkStaticPtrFingerprint n = fingerprintString $ intercalate ":"+        [ unitIdString $ moduleUnitId this_mod+        , moduleNameString $ moduleName this_mod+        , show n+        ]++    -- Choose either 'Word64#' or 'Word#' to represent the arguments of the+    -- 'Fingerprint' data constructor.+    mkWord64LitWordRep dflags+      | platformWordSize (targetPlatform dflags) < 8 = mkWord64LitWord64+      | otherwise = mkWordLit dflags . toInteger++    lookupIdHscEnv :: Name -> IO Id+    lookupIdHscEnv n = lookupTypeHscEnv hsc_env n >>=+                         maybe (getError n) (return . tyThingId)++    lookupDataConHscEnv :: Name -> IO DataCon+    lookupDataConHscEnv n = lookupTypeHscEnv hsc_env n >>=+                              maybe (getError n) (return . tyThingDataCon)++    getError n = pprPanic "sptCreateStaticBinds.get: not found" $+      text "Couldn't find" <+> ppr n++-- | @sptModuleInitCode module fps@ is a C stub to insert the static entries+-- of @module@ into the static pointer table.+--+-- @fps@ is a list associating each binding corresponding to a static entry with+-- its fingerprint.+sptModuleInitCode :: Module -> [SptEntry] -> SDoc+sptModuleInitCode _ [] = Outputable.empty+sptModuleInitCode this_mod entries = vcat+    [ text "static void hs_spt_init_" <> ppr this_mod+           <> text "(void) __attribute__((constructor));"+    , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)"+    , braces $ vcat $+        [  text "static StgWord64 k" <> int i <> text "[2] = "+           <> pprFingerprint fp <> semi+        $$ text "extern StgPtr "+           <> (ppr $ mkClosureLabel (idName n) (idCafInfo n)) <> semi+        $$ text "hs_spt_insert" <> parens+             (hcat $ punctuate comma+                [ char 'k' <> int i+                , char '&' <> ppr (mkClosureLabel (idName n) (idCafInfo n))+                ]+             )+        <> semi+        |  (i, SptEntry n fp) <- zip [0..] entries+        ]+    , text "static void hs_spt_fini_" <> ppr this_mod+           <> text "(void) __attribute__((destructor));"+    , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)"+    , braces $ vcat $+        [  text "StgWord64 k" <> int i <> text "[2] = "+           <> pprFingerprint fp <> semi+        $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi+        | (i, (SptEntry _ fp)) <- zip [0..] entries+        ]+    ]+  where+    pprFingerprint :: Fingerprint -> SDoc+    pprFingerprint (Fingerprint w1 w2) =+      braces $ hcat $ punctuate comma+                 [ integer (fromIntegral w1) <> text "ULL"+                 , integer (fromIntegral w2) <> text "ULL"+                 ]
+ main/SysTools.hs view
@@ -0,0 +1,1784 @@+{-+-----------------------------------------------------------------------------+--+-- (c) The University of Glasgow 2001-2003+--+-- Access to system tools: gcc, cp, rm etc+--+-----------------------------------------------------------------------------+-}++{-# LANGUAGE CPP, ScopedTypeVariables #-}++module SysTools (+        -- Initialisation+        initSysTools,++        -- Interface to system tools+        runUnlit, runCpp, runCc, -- [Option] -> IO ()+        runPp,                   -- [Option] -> IO ()+        runSplit,                -- [Option] -> IO ()+        runAs, runLink, runLibtool, -- [Option] -> IO ()+        runMkDLL,+        runWindres,+        runLlvmOpt,+        runLlvmLlc,+        runClang,+        figureLlvmVersion,++        getLinkerInfo,+        getCompilerInfo,++        linkDynLib,++        askLd,++        touch,                  -- String -> String -> IO ()+        copy,+        copyWithHeader,++        -- Temporary-file management+        setTmpDir,+        newTempName, newTempLibName,+        cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,+        addFilesToClean,++        Option(..),++        -- frameworks+        getPkgFrameworkOpts,+        getFrameworkOpts+++ ) where++#include "HsVersions.h"++import DriverPhases+import Module+import Packages+import Config+import Outputable+import ErrUtils+import Panic+import Platform+import Util+import DynFlags+import Exception++import LlvmCodeGen.Base (llvmVersionStr, supportedLlvmVersion)++import Data.IORef+import Control.Monad+import System.Exit+import System.Environment+import System.FilePath+import System.IO+import System.IO.Error as IO+import System.Directory+import Data.Char+import Data.List+import qualified Data.Map as Map+import qualified Data.Set as Set++#ifndef mingw32_HOST_OS+import qualified System.Posix.Internals+#else /* Must be Win32 */+import Foreign+import Foreign.C.String+#if MIN_VERSION_Win32(2,5,0)+import qualified System.Win32.Types as Win32+#else+import qualified System.Win32.Info as Win32+#endif+import System.Win32.Types (DWORD, LPTSTR, HANDLE)+import System.Win32.Types (failIfNull, failIf, iNVALID_HANDLE_VALUE)+import System.Win32.File (createFile,closeHandle, gENERIC_READ, fILE_SHARE_READ, oPEN_EXISTING, fILE_ATTRIBUTE_NORMAL, fILE_FLAG_BACKUP_SEMANTICS )+import System.Win32.DLL (loadLibrary, getProcAddress)+#endif++import System.Process+import Control.Concurrent+import FastString+import SrcLoc           ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )++#ifdef mingw32_HOST_OS+# if defined(i386_HOST_ARCH)+#  define WINDOWS_CCONV stdcall+# elif defined(x86_64_HOST_ARCH)+#  define WINDOWS_CCONV ccall+# else+#  error Unknown mingw32 arch+# endif+#endif++{-+How GHC finds its files+~~~~~~~~~~~~~~~~~~~~~~~++[Note topdir]++GHC needs various support files (library packages, RTS etc), plus+various auxiliary programs (cp, gcc, etc).  It starts by finding topdir,+the root of GHC's support files++On Unix:+  - ghc always has a shell wrapper that passes a -B<dir> option++On Windows:+  - ghc never has a shell wrapper.+  - we can find the location of the ghc binary, which is+        $topdir/<foo>/<something>.exe+    where <something> may be "ghc", "ghc-stage2", or similar+  - we strip off the "<foo>/<something>.exe" to leave $topdir.++from topdir we can find package.conf, ghc-asm, etc.+++SysTools.initSysProgs figures out exactly where all the auxiliary programs+are, and initialises mutable variables to make it easy to call them.+To to this, it makes use of definitions in Config.hs, which is a Haskell+file containing variables whose value is figured out by the build system.++Config.hs contains two sorts of things++  cGCC,         The *names* of the programs+  cCPP            e.g.  cGCC = gcc+  cUNLIT                cCPP = gcc -E+  etc           They do *not* include paths+++  cUNLIT_DIR   The *path* to the directory containing unlit, split etc+  cSPLIT_DIR   *relative* to the root of the build tree,+                   for use when running *in-place* in a build tree (only)++++---------------------------------------------+NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):++Another hair-brained scheme for simplifying the current tool location+nightmare in GHC: Simon originally suggested using another+configuration file along the lines of GCC's specs file - which is fine+except that it means adding code to read yet another configuration+file.  What I didn't notice is that the current package.conf is+general enough to do this:++Package+    {name = "tools",    import_dirs = [],  source_dirs = [],+     library_dirs = [], hs_libraries = [], extra_libraries = [],+     include_dirs = [], c_includes = [],   package_deps = [],+     extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],+     extra_cc_opts = [], extra_ld_opts = []}++Which would have the advantage that we get to collect together in one+place the path-specific package stuff with the path-specific tool+stuff.+                End of NOTES+---------------------------------------------++************************************************************************+*                                                                      *+\subsection{Initialisation}+*                                                                      *+************************************************************************+-}++initSysTools :: Maybe String    -- Maybe TopDir path (without the '-B' prefix)+             -> IO Settings     -- Set all the mutable variables above, holding+                                --      (a) the system programs+                                --      (b) the package-config file+                                --      (c) the GHC usage message+initSysTools mbMinusB+  = do top_dir <- findTopDir mbMinusB+             -- see [Note topdir]+             -- NB: top_dir is assumed to be in standard Unix+             -- format, '/' separated++       let settingsFile = top_dir </> "settings"+           platformConstantsFile = top_dir </> "platformConstants"+           installed :: FilePath -> FilePath+           installed file = top_dir </> file+           libexec :: FilePath -> FilePath+           libexec file = top_dir </> "bin" </> file++       settingsStr <- readFile settingsFile+       platformConstantsStr <- readFile platformConstantsFile+       mySettings <- case maybeReadFuzzy settingsStr of+                     Just s ->+                         return s+                     Nothing ->+                         pgmError ("Can't parse " ++ show settingsFile)+       platformConstants <- case maybeReadFuzzy platformConstantsStr of+                            Just s ->+                                return s+                            Nothing ->+                                pgmError ("Can't parse " +++                                          show platformConstantsFile)+       let getSetting key = case lookup key mySettings of+                            Just xs ->+                                return $ case stripPrefix "$topdir" xs of+                                         Just [] ->+                                             top_dir+                                         Just xs'@(c:_)+                                          | isPathSeparator c ->+                                             top_dir ++ xs'+                                         _ ->+                                             xs+                            Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)+           getBooleanSetting key = case lookup key mySettings of+                                   Just "YES" -> return True+                                   Just "NO" -> return False+                                   Just xs -> pgmError ("Bad value for " ++ show key ++ ": " ++ show xs)+                                   Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)+           readSetting key = case lookup key mySettings of+                             Just xs ->+                                 case maybeRead xs of+                                 Just v -> return v+                                 Nothing -> pgmError ("Failed to read " ++ show key ++ " value " ++ show xs)+                             Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)+       crossCompiling <- getBooleanSetting "cross compiling"+       targetArch <- readSetting "target arch"+       targetOS <- readSetting "target os"+       targetWordSize <- readSetting "target word size"+       targetUnregisterised <- getBooleanSetting "Unregisterised"+       targetHasGnuNonexecStack <- readSetting "target has GNU nonexec stack"+       targetHasIdentDirective <- readSetting "target has .ident directive"+       targetHasSubsectionsViaSymbols <- readSetting "target has subsections via symbols"+       myExtraGccViaCFlags <- getSetting "GCC extra via C opts"+       -- On Windows, mingw is distributed with GHC,+       -- so we look in TopDir/../mingw/bin+       -- It would perhaps be nice to be able to override this+       -- with the settings file, but it would be a little fiddly+       -- to make that possible, so for now you can't.+       gcc_prog <- getSetting "C compiler command"+       gcc_args_str <- getSetting "C compiler flags"+       gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie"+       cpp_prog <- getSetting "Haskell CPP command"+       cpp_args_str <- getSetting "Haskell CPP flags"+       let unreg_gcc_args = if targetUnregisterised+                            then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]+                            else []+           -- TABLES_NEXT_TO_CODE affects the info table layout.+           tntc_gcc_args+            | mkTablesNextToCode targetUnregisterised+               = ["-DTABLES_NEXT_TO_CODE"]+            | otherwise = []+           cpp_args= map Option (words cpp_args_str)+           gcc_args = map Option (words gcc_args_str+                               ++ unreg_gcc_args+                               ++ tntc_gcc_args)+       ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind"+       ldSupportsBuildId       <- getBooleanSetting "ld supports build-id"+       ldSupportsFilelist      <- getBooleanSetting "ld supports filelist"+       ldIsGnuLd               <- getBooleanSetting "ld is GNU ld"+       perl_path <- getSetting "perl command"++       let pkgconfig_path = installed "package.conf.d"+           ghc_usage_msg_path  = installed "ghc-usage.txt"+           ghci_usage_msg_path = installed "ghci-usage.txt"++             -- For all systems, unlit, split, mangle are GHC utilities+             -- architecture-specific stuff is done when building Config.hs+           unlit_path = libexec cGHC_UNLIT_PGM++             -- split is a Perl script+           split_script  = libexec cGHC_SPLIT_PGM++       windres_path <- getSetting "windres command"+       libtool_path <- getSetting "libtool command"++       tmpdir <- getTemporaryDirectory++       touch_path <- getSetting "touch command"++       let -- On Win32 we don't want to rely on #!/bin/perl, so we prepend+           -- a call to Perl to get the invocation of split.+           -- On Unix, scripts are invoked using the '#!' method.  Binary+           -- installations of GHC on Unix place the correct line on the+           -- front of the script at installation time, so we don't want+           -- to wire-in our knowledge of $(PERL) on the host system here.+           (split_prog,  split_args)+             | isWindowsHost = (perl_path,    [Option split_script])+             | otherwise     = (split_script, [])+       mkdll_prog <- getSetting "dllwrap command"+       let mkdll_args = []++       -- cpp is derived from gcc on all platforms+       -- HACK, see setPgmP below. We keep 'words' here to remember to fix+       -- Config.hs one day.+++       -- Other things being equal, as and ld are simply gcc+       gcc_link_args_str <- getSetting "C compiler link flags"+       let   as_prog  = gcc_prog+             as_args  = gcc_args+             ld_prog  = gcc_prog+             ld_args  = gcc_args ++ map Option (words gcc_link_args_str)++       -- We just assume on command line+       lc_prog <- getSetting "LLVM llc command"+       lo_prog <- getSetting "LLVM opt command"++       let iserv_prog = libexec "ghc-iserv"++       let platform = Platform {+                          platformArch = targetArch,+                          platformOS   = targetOS,+                          platformWordSize = targetWordSize,+                          platformUnregisterised = targetUnregisterised,+                          platformHasGnuNonexecStack = targetHasGnuNonexecStack,+                          platformHasIdentDirective = targetHasIdentDirective,+                          platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols,+                          platformIsCrossCompiling = crossCompiling+                      }++       return $ Settings {+                    sTargetPlatform = platform,+                    sTmpDir         = normalise tmpdir,+                    sGhcUsagePath   = ghc_usage_msg_path,+                    sGhciUsagePath  = ghci_usage_msg_path,+                    sTopDir         = top_dir,+                    sRawSettings    = mySettings,+                    sExtraGccViaCFlags = words myExtraGccViaCFlags,+                    sSystemPackageConfig = pkgconfig_path,+                    sLdSupportsCompactUnwind = ldSupportsCompactUnwind,+                    sLdSupportsBuildId       = ldSupportsBuildId,+                    sLdSupportsFilelist      = ldSupportsFilelist,+                    sLdIsGnuLd               = ldIsGnuLd,+                    sGccSupportsNoPie        = gccSupportsNoPie,+                    sProgramName             = "ghc",+                    sProjectVersion          = cProjectVersion,+                    sPgm_L   = unlit_path,+                    sPgm_P   = (cpp_prog, cpp_args),+                    sPgm_F   = "",+                    sPgm_c   = (gcc_prog, gcc_args),+                    sPgm_s   = (split_prog,split_args),+                    sPgm_a   = (as_prog, as_args),+                    sPgm_l   = (ld_prog, ld_args),+                    sPgm_dll = (mkdll_prog,mkdll_args),+                    sPgm_T   = touch_path,+                    sPgm_windres = windres_path,+                    sPgm_libtool = libtool_path,+                    sPgm_lo  = (lo_prog,[]),+                    sPgm_lc  = (lc_prog,[]),+                    sPgm_i   = iserv_prog,+                    sOpt_L       = [],+                    sOpt_P       = [],+                    sOpt_F       = [],+                    sOpt_c       = [],+                    sOpt_a       = [],+                    sOpt_l       = [],+                    sOpt_windres = [],+                    sOpt_lo      = [],+                    sOpt_lc      = [],+                    sOpt_i       = [],+                    sPlatformConstants = platformConstants+             }++-- returns a Unix-format path (relying on getBaseDir to do so too)+findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix).+           -> IO String    -- TopDir (in Unix format '/' separated)+findTopDir (Just minusb) = return (normalise minusb)+findTopDir Nothing+    = do -- Get directory of executable+         maybe_exec_dir <- getBaseDir+         case maybe_exec_dir of+             -- "Just" on Windows, "Nothing" on unix+             Nothing  -> throwGhcExceptionIO (InstallationError "missing -B<dir> option")+             Just dir -> return dir++{-+************************************************************************+*                                                                      *+\subsection{Running an external program}+*                                                                      *+************************************************************************+-}++runUnlit :: DynFlags -> [Option] -> IO ()+runUnlit dflags args = do+  let prog = pgm_L dflags+      opts = getOpts dflags opt_L+  runSomething dflags "Literate pre-processor" prog+               (map Option opts ++ args)++runCpp :: DynFlags -> [Option] -> IO ()+runCpp dflags args =   do+  let (p,args0) = pgm_P dflags+      args1 = map Option (getOpts dflags opt_P)+      args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags]+                ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags]+  mb_env <- getGccEnv args2+  runSomethingFiltered dflags id  "C pre-processor" p+                       (args0 ++ args1 ++ args2 ++ args) mb_env++runPp :: DynFlags -> [Option] -> IO ()+runPp dflags args =   do+  let prog = pgm_F dflags+      opts = map Option (getOpts dflags opt_F)+  runSomething dflags "Haskell pre-processor" prog (args ++ opts)++runCc :: DynFlags -> [Option] -> IO ()+runCc dflags args =   do+  let (p,args0) = pgm_c dflags+      args1 = map Option (getOpts dflags opt_c)+      args2 = args0 ++ args1 ++ args+  mb_env <- getGccEnv args2+  runSomethingResponseFile dflags cc_filter "C Compiler" p args2 mb_env+ where+  -- discard some harmless warnings from gcc that we can't turn off+  cc_filter = unlines . doFilter . lines++  {-+  gcc gives warnings in chunks like so:+      In file included from /foo/bar/baz.h:11,+                       from /foo/bar/baz2.h:22,+                       from wibble.c:33:+      /foo/flibble:14: global register variable ...+      /foo/flibble:15: warning: call-clobbered r...+  We break it up into its chunks, remove any call-clobbered register+  warnings from each chunk, and then delete any chunks that we have+  emptied of warnings.+  -}+  doFilter = unChunkWarnings . filterWarnings . chunkWarnings []+  -- We can't assume that the output will start with an "In file inc..."+  -- line, so we start off expecting a list of warnings rather than a+  -- location stack.+  chunkWarnings :: [String] -- The location stack to use for the next+                            -- list of warnings+                -> [String] -- The remaining lines to look at+                -> [([String], [String])]+  chunkWarnings loc_stack [] = [(loc_stack, [])]+  chunkWarnings loc_stack xs+      = case break loc_stack_start xs of+        (warnings, lss:xs') ->+            case span loc_start_continuation xs' of+            (lsc, xs'') ->+                (loc_stack, warnings) : chunkWarnings (lss : lsc) xs''+        _ -> [(loc_stack, xs)]++  filterWarnings :: [([String], [String])] -> [([String], [String])]+  filterWarnings [] = []+  -- If the warnings are already empty then we are probably doing+  -- something wrong, so don't delete anything+  filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs+  filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of+                                       [] -> filterWarnings zs+                                       ys' -> (xs, ys') : filterWarnings zs++  unChunkWarnings :: [([String], [String])] -> [String]+  unChunkWarnings [] = []+  unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs++  loc_stack_start        s = "In file included from " `isPrefixOf` s+  loc_start_continuation s = "                 from " `isPrefixOf` s+  wantedWarning w+   | "warning: call-clobbered register used" `isContainedIn` w = False+   | otherwise = True++isContainedIn :: String -> String -> Bool+xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)++-- | Run the linker with some arguments and return the output+askLd :: DynFlags -> [Option] -> IO String+askLd dflags args = do+  let (p,args0) = pgm_l dflags+      args1     = map Option (getOpts dflags opt_l)+      args2     = args0 ++ args1 ++ args+  mb_env <- getGccEnv args2+  runSomethingWith dflags "gcc" p args2 $ \real_args ->+    readCreateProcessWithExitCode' (proc p real_args){ env = mb_env }++-- Similar to System.Process.readCreateProcessWithExitCode, but stderr is+-- inherited from the parent process, and output to stderr is not captured.+readCreateProcessWithExitCode'+    :: CreateProcess+    -> IO (ExitCode, String)    -- ^ stdout+readCreateProcessWithExitCode' proc = do+    (_, Just outh, _, pid) <-+        createProcess proc{ std_out = CreatePipe }++    -- fork off a thread to start consuming the output+    output  <- hGetContents outh+    outMVar <- newEmptyMVar+    _ <- forkIO $ evaluate (length output) >> putMVar outMVar ()++    -- wait on the output+    takeMVar outMVar+    hClose outh++    -- wait on the process+    ex <- waitForProcess pid++    return (ex, output)++replaceVar :: (String, String) -> [(String, String)] -> [(String, String)]+replaceVar (var, value) env =+    (var, value) : filter (\(var',_) -> var /= var') env++-- | Version of @System.Process.readProcessWithExitCode@ that takes a+-- key-value tuple to insert into the environment.+readProcessEnvWithExitCode+    :: String -- ^ program path+    -> [String] -- ^ program args+    -> (String, String) -- ^ addition to the environment+    -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr)+readProcessEnvWithExitCode prog args env_update = do+    current_env <- getEnvironment+    readCreateProcessWithExitCode (proc prog args) {+        env = Just (replaceVar env_update current_env) } ""++-- Don't let gcc localize version info string, #8825+c_locale_env :: (String, String)+c_locale_env = ("LANGUAGE", "C")++-- If the -B<dir> option is set, add <dir> to PATH.  This works around+-- a bug in gcc on Windows Vista where it can't find its auxiliary+-- binaries (see bug #1110).+getGccEnv :: [Option] -> IO (Maybe [(String,String)])+getGccEnv opts =+  if null b_dirs+     then return Nothing+     else do env <- getEnvironment+             return (Just (map mangle_path env))+ where+  (b_dirs, _) = partitionWith get_b_opt opts++  get_b_opt (Option ('-':'B':dir)) = Left dir+  get_b_opt other = Right other++  mangle_path (path,paths) | map toUpper path == "PATH"+        = (path, '\"' : head b_dirs ++ "\";" ++ paths)+  mangle_path other = other++runSplit :: DynFlags -> [Option] -> IO ()+runSplit dflags args = do+  let (p,args0) = pgm_s dflags+  runSomething dflags "Splitter" p (args0++args)++runAs :: DynFlags -> [Option] -> IO ()+runAs dflags args = do+  let (p,args0) = pgm_a dflags+      args1 = map Option (getOpts dflags opt_a)+      args2 = args0 ++ args1 ++ args+  mb_env <- getGccEnv args2+  runSomethingFiltered dflags id "Assembler" p args2 mb_env++-- | Run the LLVM Optimiser+runLlvmOpt :: DynFlags -> [Option] -> IO ()+runLlvmOpt dflags args = do+  let (p,args0) = pgm_lo dflags+      args1 = map Option (getOpts dflags opt_lo)+  runSomething dflags "LLVM Optimiser" p (args0 ++ args1 ++ args)++-- | Run the LLVM Compiler+runLlvmLlc :: DynFlags -> [Option] -> IO ()+runLlvmLlc dflags args = do+  let (p,args0) = pgm_lc dflags+      args1 = map Option (getOpts dflags opt_lc)+  runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args)++-- | Run the clang compiler (used as an assembler for the LLVM+-- backend on OS X as LLVM doesn't support the OS X system+-- assembler)+runClang :: DynFlags -> [Option] -> IO ()+runClang dflags args = do+  -- we simply assume its available on the PATH+  let clang = "clang"+      -- be careful what options we call clang with+      -- see #5903 and #7617 for bugs caused by this.+      (_,args0) = pgm_a dflags+      args1 = map Option (getOpts dflags opt_a)+      args2 = args0 ++ args1 ++ args+  mb_env <- getGccEnv args2+  Exception.catch (do+        runSomethingFiltered dflags id "Clang (Assembler)" clang args2 mb_env+    )+    (\(err :: SomeException) -> do+        errorMsg dflags $+            text ("Error running clang! you need clang installed to use the" +++                  " LLVM backend") $+$+            text "(or GHC tried to execute clang incorrectly)"+        throwIO err+    )++-- | Figure out which version of LLVM we are running this session+figureLlvmVersion :: DynFlags -> IO (Maybe (Int, Int))+figureLlvmVersion dflags = do+  let (pgm,opts) = pgm_lc dflags+      args = filter notNull (map showOpt opts)+      -- we grab the args even though they should be useless just in+      -- case the user is using a customised 'llc' that requires some+      -- of the options they've specified. llc doesn't care what other+      -- options are specified when '-version' is used.+      args' = args ++ ["-version"]+  ver <- catchIO (do+             (pin, pout, perr, _) <- runInteractiveProcess pgm args'+                                             Nothing Nothing+             {- > llc -version+                  LLVM (http://llvm.org/):+                    LLVM version 3.5.2+                    ...+             -}+             hSetBinaryMode pout False+             _     <- hGetLine pout+             vline <- dropWhile (not . isDigit) `fmap` hGetLine pout+             v     <- case span (/= '.') vline of+                        ("",_)  -> fail "no digits!"+                        (x,y) -> return (read x+                                        , read $ takeWhile isDigit $ drop 1 y)++             hClose pin+             hClose pout+             hClose perr+             return $ Just v+            )+            (\err -> do+                debugTraceMsg dflags 2+                    (text "Error (figuring out LLVM version):" <+>+                     text (show err))+                errorMsg dflags $ vcat+                    [ text "Warning:", nest 9 $+                          text "Couldn't figure out LLVM version!" $$+                          text ("Make sure you have installed LLVM " +++                                llvmVersionStr supportedLlvmVersion) ]+                return Nothing)+  return ver++{- Note [Windows stack usage]++See: Trac #8870 (and #8834 for related info) and #12186++On Windows, occasionally we need to grow the stack. In order to do+this, we would normally just bump the stack pointer - but there's a+catch on Windows.++If the stack pointer is bumped by more than a single page, then the+pages between the initial pointer and the resulting location must be+properly committed by the Windows virtual memory subsystem. This is+only needed in the event we bump by more than one page (i.e 4097 bytes+or more).++Windows compilers solve this by emitting a call to a special function+called _chkstk, which does this committing of the pages for you.++The reason this was causing a segfault was because due to the fact the+new code generator tends to generate larger functions, we needed more+stack space in GHC itself. In the x86 codegen, we needed approximately+~12kb of stack space in one go, which caused the process to segfault,+as the intervening pages were not committed.++GCC can emit such a check for us automatically but only when the flag+-fstack-check is used.++See https://gcc.gnu.org/onlinedocs/gnat_ugn/Stack-Overflow-Checking.html+for more information.++-}++{- Note [Run-time linker info]++See also: Trac #5240, Trac #6063, Trac #10110++Before 'runLink', we need to be sure to get the relevant information+about the linker we're using at runtime to see if we need any extra+options. For example, GNU ld requires '--reduce-memory-overheads' and+'--hash-size=31' in order to use reasonable amounts of memory (see+trac #5240.) But this isn't supported in GNU gold.++Generally, the linker changing from what was detected at ./configure+time has always been possible using -pgml, but on Linux it can happen+'transparently' by installing packages like binutils-gold, which+change what /usr/bin/ld actually points to.++Clang vs GCC notes:++For gcc, 'gcc -Wl,--version' gives a bunch of output about how to+invoke the linker before the version information string. For 'clang',+the version information for 'ld' is all that's output. For this+reason, we typically need to slurp up all of the standard error output+and look through it.++Other notes:++We cache the LinkerInfo inside DynFlags, since clients may link+multiple times. The definition of LinkerInfo is there to avoid a+circular dependency.++-}++{- Note [ELF needed shared libs]++Some distributions change the link editor's default handling of+ELF DT_NEEDED tags to include only those shared objects that are+needed to resolve undefined symbols. For Template Haskell we need+the last temporary shared library also if it is not needed for the+currently linked temporary shared library. We specify --no-as-needed+to override the default. This flag exists in GNU ld and GNU gold.++The flag is only needed on ELF systems. On Windows (PE) and Mac OS X+(Mach-O) the flag is not needed.++-}++{- Note [Windows static libGCC]++The GCC versions being upgraded to in #10726 are configured with+dynamic linking of libgcc supported. This results in libgcc being+linked dynamically when a shared library is created.++This introduces thus an extra dependency on GCC dll that was not+needed before by shared libraries created with GHC. This is a particular+issue on Windows because you get a non-obvious error due to this missing+dependency. This dependent dll is also not commonly on your path.++For this reason using the static libgcc is preferred as it preserves+the same behaviour that existed before. There are however some very good+reasons to have the shared version as well as described on page 181 of+https://gcc.gnu.org/onlinedocs/gcc-5.2.0/gcc.pdf :++"There are several situations in which an application should use the+ shared ‘libgcc’ instead of the static version. The most common of these+ is when the application wishes to throw and catch exceptions across different+ shared libraries. In that case, each of the libraries as well as the application+ itself should use the shared ‘libgcc’. "++-}++neededLinkArgs :: LinkerInfo -> [Option]+neededLinkArgs (GnuLD o)     = o+neededLinkArgs (GnuGold o)   = o+neededLinkArgs (DarwinLD o)  = o+neededLinkArgs (SolarisLD o) = o+neededLinkArgs (AixLD o)     = o+neededLinkArgs UnknownLD     = []++-- Grab linker info and cache it in DynFlags.+getLinkerInfo :: DynFlags -> IO LinkerInfo+getLinkerInfo dflags = do+  info <- readIORef (rtldInfo dflags)+  case info of+    Just v  -> return v+    Nothing -> do+      v <- getLinkerInfo' dflags+      writeIORef (rtldInfo dflags) (Just v)+      return v++-- See Note [Run-time linker info].+getLinkerInfo' :: DynFlags -> IO LinkerInfo+getLinkerInfo' dflags = do+  let platform = targetPlatform dflags+      os = platformOS platform+      (pgm,args0) = pgm_l dflags+      args1     = map Option (getOpts dflags opt_l)+      args2     = args0 ++ args1+      args3     = filter notNull (map showOpt args2)++      -- Try to grab the info from the process output.+      parseLinkerInfo stdo _stde _exitc+        | any ("GNU ld" `isPrefixOf`) stdo =+          -- GNU ld specifically needs to use less memory. This especially+          -- hurts on small object files. Trac #5240.+          -- Set DT_NEEDED for all shared libraries. Trac #10110.+          -- TODO: Investigate if these help or hurt when using split sections.+          return (GnuLD $ map Option ["-Wl,--hash-size=31",+                                      "-Wl,--reduce-memory-overheads",+                                      -- ELF specific flag+                                      -- see Note [ELF needed shared libs]+                                      "-Wl,--no-as-needed"])++        | any ("GNU gold" `isPrefixOf`) stdo =+          -- GNU gold only needs --no-as-needed. Trac #10110.+          -- ELF specific flag, see Note [ELF needed shared libs]+          return (GnuGold [Option "-Wl,--no-as-needed"])++         -- Unknown linker.+        | otherwise = fail "invalid --version output, or linker is unsupported"++  -- Process the executable call+  info <- catchIO (do+             case os of+               OSSolaris2 ->+                 -- Solaris uses its own Solaris linker. Even all+                 -- GNU C are recommended to configure with Solaris+                 -- linker instead of using GNU binutils linker. Also+                 -- all GCC distributed with Solaris follows this rule+                 -- precisely so we assume here, the Solaris linker is+                 -- used.+                 return $ SolarisLD []+               OSAIX ->+                 -- IBM AIX uses its own non-binutils linker as well+                 return $ AixLD []+               OSDarwin ->+                 -- Darwin has neither GNU Gold or GNU LD, but a strange linker+                 -- that doesn't support --version. We can just assume that's+                 -- what we're using.+                 return $ DarwinLD []+               OSiOS ->+                 -- Ditto for iOS+                 return $ DarwinLD []+               OSMinGW32 ->+                 -- GHC doesn't support anything but GNU ld on Windows anyway.+                 -- Process creation is also fairly expensive on win32, so+                 -- we short-circuit here.+                 return $ GnuLD $ map Option+                   [ -- Reduce ld memory usage+                     "-Wl,--hash-size=31"+                   , "-Wl,--reduce-memory-overheads"+                     -- Emit gcc stack checks+                     -- Note [Windows stack usage]+                   , "-fstack-check"+                     -- Force static linking of libGCC+                     -- Note [Windows static libGCC]+                   , "-static-libgcc" ]+               _ -> do+                 -- In practice, we use the compiler as the linker here. Pass+                 -- -Wl,--version to get linker version info.+                 (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm+                                        (["-Wl,--version"] ++ args3)+                                        c_locale_env+                 -- Split the output by lines to make certain kinds+                 -- of processing easier. In particular, 'clang' and 'gcc'+                 -- have slightly different outputs for '-Wl,--version', but+                 -- it's still easy to figure out.+                 parseLinkerInfo (lines stdo) (lines stde) exitc+            )+            (\err -> do+                debugTraceMsg dflags 2+                    (text "Error (figuring out linker information):" <+>+                     text (show err))+                errorMsg dflags $ hang (text "Warning:") 9 $+                  text "Couldn't figure out linker information!" $$+                  text "Make sure you're using GNU ld, GNU gold" <+>+                  text "or the built in OS X linker, etc."+                return UnknownLD)+  return info++-- Grab compiler info and cache it in DynFlags.+getCompilerInfo :: DynFlags -> IO CompilerInfo+getCompilerInfo dflags = do+  info <- readIORef (rtccInfo dflags)+  case info of+    Just v  -> return v+    Nothing -> do+      v <- getCompilerInfo' dflags+      writeIORef (rtccInfo dflags) (Just v)+      return v++-- See Note [Run-time linker info].+getCompilerInfo' :: DynFlags -> IO CompilerInfo+getCompilerInfo' dflags = do+  let (pgm,_) = pgm_c dflags+      -- Try to grab the info from the process output.+      parseCompilerInfo _stdo stde _exitc+        -- Regular GCC+        | any ("gcc version" `isInfixOf`) stde =+          return GCC+        -- Regular clang+        | any ("clang version" `isInfixOf`) stde =+          return Clang+        -- XCode 5.1 clang+        | any ("Apple LLVM version 5.1" `isPrefixOf`) stde =+          return AppleClang51+        -- XCode 5 clang+        | any ("Apple LLVM version" `isPrefixOf`) stde =+          return AppleClang+        -- XCode 4.1 clang+        | any ("Apple clang version" `isPrefixOf`) stde =+          return AppleClang+         -- Unknown linker.+        | otherwise = fail "invalid -v output, or compiler is unsupported"++  -- Process the executable call+  info <- catchIO (do+                (exitc, stdo, stde) <-+                    readProcessEnvWithExitCode pgm ["-v"] c_locale_env+                -- Split the output by lines to make certain kinds+                -- of processing easier.+                parseCompilerInfo (lines stdo) (lines stde) exitc+            )+            (\err -> do+                debugTraceMsg dflags 2+                    (text "Error (figuring out C compiler information):" <+>+                     text (show err))+                errorMsg dflags $ hang (text "Warning:") 9 $+                  text "Couldn't figure out C compiler information!" $$+                  text "Make sure you're using GNU gcc, or clang"+                return UnknownCC)+  return info++runLink :: DynFlags -> [Option] -> IO ()+runLink dflags args = do+  -- See Note [Run-time linker info]+  linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags+  let (p,args0) = pgm_l dflags+      args1     = map Option (getOpts dflags opt_l)+      args2     = args0 ++ linkargs ++ args1 ++ args+  mb_env <- getGccEnv args2+  runSomethingResponseFile dflags ld_filter "Linker" p args2 mb_env+  where+    ld_filter = case (platformOS (targetPlatform dflags)) of+                  OSSolaris2 -> sunos_ld_filter+                  _ -> id+{-+  SunOS/Solaris ld emits harmless warning messages about unresolved+  symbols in case of compiling into shared library when we do not+  link against all the required libs. That is the case of GHC which+  does not link against RTS library explicitly in order to be able to+  choose the library later based on binary application linking+  parameters. The warnings look like:++Undefined                       first referenced+ symbol                             in file+stg_ap_n_fast                       ./T2386_Lib.o+stg_upd_frame_info                  ./T2386_Lib.o+templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o+templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o+templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o+templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o+newCAF                              ./T2386_Lib.o+stg_bh_upd_frame_info               ./T2386_Lib.o+stg_ap_ppp_fast                     ./T2386_Lib.o+templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o+stg_ap_p_fast                       ./T2386_Lib.o+stg_ap_pp_fast                      ./T2386_Lib.o+ld: warning: symbol referencing errors++  this is actually coming from T2386 testcase. The emitting of those+  warnings is also a reason why so many TH testcases fail on Solaris.++  Following filter code is SunOS/Solaris linker specific and should+  filter out only linker warnings. Please note that the logic is a+  little bit more complex due to the simple reason that we need to preserve+  any other linker emitted messages. If there are any. Simply speaking+  if we see "Undefined" and later "ld: warning:..." then we omit all+  text between (including) the marks. Otherwise we copy the whole output.+-}+    sunos_ld_filter :: String -> String+    sunos_ld_filter = unlines . sunos_ld_filter' . lines+    sunos_ld_filter' x = if (undefined_found x && ld_warning_found x)+                         then (ld_prefix x) ++ (ld_postfix x)+                         else x+    breakStartsWith x y = break (isPrefixOf x) y+    ld_prefix = fst . breakStartsWith "Undefined"+    undefined_found = not . null . snd . breakStartsWith "Undefined"+    ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors"+    ld_postfix = tail . snd . ld_warn_break+    ld_warning_found = not . null . snd . ld_warn_break+++runLibtool :: DynFlags -> [Option] -> IO ()+runLibtool dflags args = do+  linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags+  let args1      = map Option (getOpts dflags opt_l)+      args2      = [Option "-static"] ++ args1 ++ args ++ linkargs+      libtool    = pgm_libtool dflags+  mb_env <- getGccEnv args2+  runSomethingFiltered dflags id "Linker" libtool args2 mb_env++runMkDLL :: DynFlags -> [Option] -> IO ()+runMkDLL dflags args = do+  let (p,args0) = pgm_dll dflags+      args1 = args0 ++ args+  mb_env <- getGccEnv (args0++args)+  runSomethingFiltered dflags id "Make DLL" p args1 mb_env++runWindres :: DynFlags -> [Option] -> IO ()+runWindres dflags args = do+  let (gcc, gcc_args) = pgm_c dflags+      windres = pgm_windres dflags+      opts = map Option (getOpts dflags opt_windres)+      quote x = "\"" ++ x ++ "\""+      args' = -- If windres.exe and gcc.exe are in a directory containing+              -- spaces then windres fails to run gcc. We therefore need+              -- to tell it what command to use...+              Option ("--preprocessor=" +++                      unwords (map quote (gcc :+                                          map showOpt gcc_args +++                                          map showOpt opts +++                                          ["-E", "-xc", "-DRC_INVOKED"])))+              -- ...but if we do that then if windres calls popen then+              -- it can't understand the quoting, so we have to use+              -- --use-temp-file so that it interprets it correctly.+              -- See #1828.+            : Option "--use-temp-file"+            : args+  mb_env <- getGccEnv gcc_args+  runSomethingFiltered dflags id "Windres" windres args' mb_env++touch :: DynFlags -> String -> String -> IO ()+touch dflags purpose arg =+  runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]++copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()+copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to++copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath+               -> IO ()+copyWithHeader dflags purpose maybe_header from to = do+  showPass dflags purpose++  hout <- openBinaryFile to   WriteMode+  hin  <- openBinaryFile from ReadMode+  ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up+  maybe (return ()) (header hout) maybe_header+  hPutStr hout ls+  hClose hout+  hClose hin+ where+  -- write the header string in UTF-8.  The header is something like+  --   {-# LINE "foo.hs" #-}+  -- and we want to make sure a Unicode filename isn't mangled.+  header h str = do+   hSetEncoding h utf8+   hPutStr h str+   hSetBinaryMode h True++++{-+************************************************************************+*                                                                      *+\subsection{Managing temporary files+*                                                                      *+************************************************************************+-}++cleanTempDirs :: DynFlags -> IO ()+cleanTempDirs dflags+   = unless (gopt Opt_KeepTmpFiles dflags)+   $ mask_+   $ do let ref = dirsToClean dflags+        ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds)+        removeTmpDirs dflags (Map.elems ds)++cleanTempFiles :: DynFlags -> IO ()+cleanTempFiles dflags+   = unless (gopt Opt_KeepTmpFiles dflags)+   $ mask_+   $ do let ref = filesToClean dflags+        fs <- atomicModifyIORef' ref $ \fs -> ([],fs)+        removeTmpFiles dflags fs++cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()+cleanTempFilesExcept dflags dont_delete+   = unless (gopt Opt_KeepTmpFiles dflags)+   $ mask_+   $ do let ref = filesToClean dflags+        to_delete <- atomicModifyIORef' ref $ \files ->+            let res@(_to_keep, _to_delete) =+                    partition (`Set.member` dont_delete_set) files+            in  res+        removeTmpFiles dflags to_delete+  where dont_delete_set = Set.fromList dont_delete+++-- Return a unique numeric temp file suffix+newTempSuffix :: DynFlags -> IO Int+newTempSuffix dflags = atomicModifyIORef' (nextTempSuffix dflags) $ \n -> (n+1,n)++-- Find a temporary name that doesn't already exist.+newTempName :: DynFlags -> Suffix -> IO FilePath+newTempName dflags extn+  = do d <- getTempDir dflags+       findTempName (d </> "ghc_") -- See Note [Deterministic base name]+  where+    findTempName :: FilePath -> IO FilePath+    findTempName prefix+      = do n <- newTempSuffix dflags+           let filename = prefix ++ show n <.> extn+           b <- doesFileExist filename+           if b then findTempName prefix+                else do -- clean it up later+                        consIORef (filesToClean dflags) filename+                        return filename++newTempLibName :: DynFlags -> Suffix -> IO (FilePath, FilePath, String)+newTempLibName dflags extn+  = do d <- getTempDir dflags+       findTempName d ("ghc_")+  where+    findTempName :: FilePath -> String -> IO (FilePath, FilePath, String)+    findTempName dir prefix+      = do n <- newTempSuffix dflags -- See Note [Deterministic base name]+           let libname = prefix ++ show n+               filename = dir </> "lib" ++ libname <.> extn+           b <- doesFileExist filename+           if b then findTempName dir prefix+                else do -- clean it up later+                        consIORef (filesToClean dflags) filename+                        return (filename, dir, libname)+++-- Return our temporary directory within tmp_dir, creating one if we+-- don't have one yet.+getTempDir :: DynFlags -> IO FilePath+getTempDir dflags = do+    mapping <- readIORef dir_ref+    case Map.lookup tmp_dir mapping of+        Nothing -> do+            pid <- getProcessID+            let prefix = tmp_dir </> "ghc" ++ show pid ++ "_"+            mask_ $ mkTempDir prefix+        Just dir -> return dir+  where+    tmp_dir = tmpDir dflags+    dir_ref = dirsToClean dflags++    mkTempDir :: FilePath -> IO FilePath+    mkTempDir prefix = do+        n <- newTempSuffix dflags+        let our_dir = prefix ++ show n++        -- 1. Speculatively create our new directory.+        createDirectory our_dir++        -- 2. Update the dirsToClean mapping unless an entry already exists+        -- (i.e. unless another thread beat us to it).+        their_dir <- atomicModifyIORef' dir_ref $ \mapping ->+            case Map.lookup tmp_dir mapping of+                Just dir -> (mapping, Just dir)+                Nothing  -> (Map.insert tmp_dir our_dir mapping, Nothing)++        -- 3. If there was an existing entry, return it and delete the+        -- directory we created.  Otherwise return the directory we created.+        case their_dir of+            Nothing  -> do+                debugTraceMsg dflags 2 $+                    text "Created temporary directory:" <+> text our_dir+                return our_dir+            Just dir -> do+                removeDirectory our_dir+                return dir+      `catchIO` \e -> if isAlreadyExistsError e+                      then mkTempDir prefix else ioError e++-- Note [Deterministic base name]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- The filename of temporary files, especially the basename of C files, can end+-- up in the output in some form, e.g. as part of linker debug information. In the+-- interest of bit-wise exactly reproducible compilation (#4012), the basename of+-- the temporary file no longer contains random information (it used to contain+-- the process id).+--+-- This is ok, as the temporary directory used contains the pid (see getTempDir).++addFilesToClean :: DynFlags -> [FilePath] -> IO ()+-- May include wildcards [used by DriverPipeline.run_phase SplitMangle]+addFilesToClean dflags new_files+    = atomicModifyIORef' (filesToClean dflags) $ \files -> (new_files++files, ())++removeTmpDirs :: DynFlags -> [FilePath] -> IO ()+removeTmpDirs dflags ds+  = traceCmd dflags "Deleting temp dirs"+             ("Deleting: " ++ unwords ds)+             (mapM_ (removeWith dflags removeDirectory) ds)++removeTmpFiles :: DynFlags -> [FilePath] -> IO ()+removeTmpFiles dflags fs+  = warnNon $+    traceCmd dflags "Deleting temp files"+             ("Deleting: " ++ unwords deletees)+             (mapM_ (removeWith dflags removeFile) deletees)+  where+     -- Flat out refuse to delete files that are likely to be source input+     -- files (is there a worse bug than having a compiler delete your source+     -- files?)+     --+     -- Deleting source files is a sign of a bug elsewhere, so prominently flag+     -- the condition.+    warnNon act+     | null non_deletees = act+     | otherwise         = do+        putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))+        act++    (non_deletees, deletees) = partition isHaskellUserSrcFilename fs++removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()+removeWith dflags remover f = remover f `catchIO`+  (\e ->+   let msg = if isDoesNotExistError e+             then text "Warning: deleting non-existent" <+> text f+             else text "Warning: exception raised when deleting"+                                            <+> text f <> colon+               $$ text (show e)+   in debugTraceMsg dflags 2 msg+  )++-----------------------------------------------------------------------------+-- Running an external program++runSomething :: DynFlags+             -> String          -- For -v message+             -> String          -- Command name (possibly a full path)+                                --      assumed already dos-ified+             -> [Option]        -- Arguments+                                --      runSomething will dos-ify them+             -> IO ()++runSomething dflags phase_name pgm args =+  runSomethingFiltered dflags id phase_name pgm args Nothing++-- | Run a command, placing the arguments in an external response file.+--+-- This command is used in order to avoid overlong command line arguments on+-- Windows. The command line arguments are first written to an external,+-- temporary response file, and then passed to the linker via @filepath.+-- response files for passing them in. See:+--+--     https://gcc.gnu.org/wiki/Response_Files+--     https://ghc.haskell.org/trac/ghc/ticket/10777+runSomethingResponseFile+  :: DynFlags -> (String->String) -> String -> String -> [Option]+  -> Maybe [(String,String)] -> IO ()++runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env =+    runSomethingWith dflags phase_name pgm args $ \real_args -> do+        fp <- getResponseFile real_args+        let args = ['@':fp]+        r <- builderMainLoop dflags filter_fn pgm args mb_env+        return (r,())+  where+    getResponseFile args = do+      fp <- newTempName dflags "rsp"+      withFile fp WriteMode $ \h -> do+#if defined(mingw32_HOST_OS)+          hSetEncoding h latin1+#else+          hSetEncoding h utf8+#endif+          hPutStr h $ unlines $ map escape args+      return fp++    -- Note: Response files have backslash-escaping, double quoting, and are+    -- whitespace separated (some implementations use newline, others any+    -- whitespace character). Therefore, escape any backslashes, newlines, and+    -- double quotes in the argument, and surround the content with double+    -- quotes.+    --+    -- Another possibility that could be considered would be to convert+    -- backslashes in the argument to forward slashes. This would generally do+    -- the right thing, since backslashes in general only appear in arguments+    -- as part of file paths on Windows, and the forward slash is accepted for+    -- those. However, escaping is more reliable, in case somehow a backslash+    -- appears in a non-file.+    escape x = concat+        [ "\""+        , concatMap+            (\c ->+                case c of+                    '\\' -> "\\\\"+                    '\n' -> "\\n"+                    '\"' -> "\\\""+                    _    -> [c])+            x+        , "\""+        ]++runSomethingFiltered+  :: DynFlags -> (String->String) -> String -> String -> [Option]+  -> Maybe [(String,String)] -> IO ()++runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do+    runSomethingWith dflags phase_name pgm args $ \real_args -> do+        r <- builderMainLoop dflags filter_fn pgm real_args mb_env+        return (r,())++runSomethingWith+  :: DynFlags -> String -> String -> [Option]+  -> ([String] -> IO (ExitCode, a))+  -> IO a++runSomethingWith dflags phase_name pgm args io = do+  let real_args = filter notNull (map showOpt args)+      cmdLine = showCommandForUser pgm real_args+  traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args++handleProc :: String -> String -> IO (ExitCode, r) -> IO r+handleProc pgm phase_name proc = do+    (rc, r) <- proc `catchIO` handler+    case rc of+      ExitSuccess{} -> return r+      ExitFailure n -> throwGhcExceptionIO (+            ProgramError ("`" ++ takeFileName pgm ++ "'" +++                          " failed in phase `" ++ phase_name ++ "'." +++                          " (Exit code: " ++ show n ++ ")"))+  where+    handler err =+       if IO.isDoesNotExistError err+          then does_not_exist+          else throwGhcExceptionIO (ProgramError $ show err)++    does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))+++builderMainLoop :: DynFlags -> (String -> String) -> FilePath+                -> [String] -> Maybe [(String, String)]+                -> IO ExitCode+builderMainLoop dflags filter_fn pgm real_args mb_env = do+  chan <- newChan+  (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env++  -- and run a loop piping the output from the compiler to the log_action in DynFlags+  hSetBuffering hStdOut LineBuffering+  hSetBuffering hStdErr LineBuffering+  _ <- forkIO (readerProc chan hStdOut filter_fn)+  _ <- forkIO (readerProc chan hStdErr filter_fn)+  -- we don't want to finish until 2 streams have been completed+  -- (stdout and stderr)+  -- nor until 1 exit code has been retrieved.+  rc <- loop chan hProcess (2::Integer) (1::Integer) ExitSuccess+  -- after that, we're done here.+  hClose hStdIn+  hClose hStdOut+  hClose hStdErr+  return rc+  where+    -- status starts at zero, and increments each time either+    -- a reader process gets EOF, or the build proc exits.  We wait+    -- for all of these to happen (status==3).+    -- ToDo: we should really have a contingency plan in case any of+    -- the threads dies, such as a timeout.+    loop _    _        0 0 exitcode = return exitcode+    loop chan hProcess t p exitcode = do+      mb_code <- if p > 0+                   then getProcessExitCode hProcess+                   else return Nothing+      case mb_code of+        Just code -> loop chan hProcess t (p-1) code+        Nothing+          | t > 0 -> do+              msg <- readChan chan+              case msg of+                BuildMsg msg -> do+                  putLogMsg dflags NoReason SevInfo noSrcSpan+                     (defaultUserStyle dflags) msg+                  loop chan hProcess t p exitcode+                BuildError loc msg -> do+                  putLogMsg dflags NoReason SevError (mkSrcSpan loc loc)+                     (defaultUserStyle dflags) msg+                  loop chan hProcess t p exitcode+                EOF ->+                  loop chan hProcess (t-1) p exitcode+          | otherwise -> loop chan hProcess t p exitcode++readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()+readerProc chan hdl filter_fn =+    (do str <- hGetContents hdl+        loop (linesPlatform (filter_fn str)) Nothing)+    `finally`+       writeChan chan EOF+        -- ToDo: check errors more carefully+        -- ToDo: in the future, the filter should be implemented as+        -- a stream transformer.+    where+        loop []     Nothing    = return ()+        loop []     (Just err) = writeChan chan err+        loop (l:ls) in_err     =+                case in_err of+                  Just err@(BuildError srcLoc msg)+                    | leading_whitespace l -> do+                        loop ls (Just (BuildError srcLoc (msg $$ text l)))+                    | otherwise -> do+                        writeChan chan err+                        checkError l ls+                  Nothing -> do+                        checkError l ls+                  _ -> panic "readerProc/loop"++        checkError l ls+           = case parseError l of+                Nothing -> do+                    writeChan chan (BuildMsg (text l))+                    loop ls Nothing+                Just (file, lineNum, colNum, msg) -> do+                    let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum+                    loop ls (Just (BuildError srcLoc (text msg)))++        leading_whitespace []    = False+        leading_whitespace (x:_) = isSpace x++parseError :: String -> Maybe (String, Int, Int, String)+parseError s0 = case breakColon s0 of+                Just (filename, s1) ->+                    case breakIntColon s1 of+                    Just (lineNum, s2) ->+                        case breakIntColon s2 of+                        Just (columnNum, s3) ->+                            Just (filename, lineNum, columnNum, s3)+                        Nothing ->+                            Just (filename, lineNum, 0, s2)+                    Nothing -> Nothing+                Nothing -> Nothing++breakColon :: String -> Maybe (String, String)+breakColon xs = case break (':' ==) xs of+                    (ys, _:zs) -> Just (ys, zs)+                    _ -> Nothing++breakIntColon :: String -> Maybe (Int, String)+breakIntColon xs = case break (':' ==) xs of+                       (ys, _:zs)+                        | not (null ys) && all isAscii ys && all isDigit ys ->+                           Just (read ys, zs)+                       _ -> Nothing++data BuildMessage+  = BuildMsg   !SDoc+  | BuildError !SrcLoc !SDoc+  | EOF++traceCmd :: DynFlags -> String -> String -> IO a -> IO a+-- trace the command (at two levels of verbosity)+traceCmd dflags phase_name cmd_line action+ = do   { let verb = verbosity dflags+        ; showPass dflags phase_name+        ; debugTraceMsg dflags 3 (text cmd_line)+        ; case flushErr dflags of+              FlushErr io -> io++           -- And run it!+        ; action `catchIO` handle_exn verb+        }+  where+    handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')+                              ; debugTraceMsg dflags 2 (text "Failed:" <+> text cmd_line <+> text (show exn))+                              ; throwGhcExceptionIO (ProgramError (show exn))}++{-+************************************************************************+*                                                                      *+\subsection{Support code}+*                                                                      *+************************************************************************+-}++-----------------------------------------------------------------------------+-- Define       getBaseDir     :: IO (Maybe String)++getBaseDir :: IO (Maybe String)+#if defined(mingw32_HOST_OS)+-- Assuming we are running ghc, accessed by path  $(stuff)/<foo>/ghc.exe,+-- return the path $(stuff)/lib.+getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.+  where+    try_size size = allocaArray (fromIntegral size) $ \buf -> do+        ret <- c_GetModuleFileName nullPtr buf size+        case ret of+          0 -> return Nothing+          _ | ret < size -> do+                path <- peekCWString buf+                real <- getFinalPath path -- try to resolve symlinks paths+                let libdir = (rootDir . sanitize . maybe path id) real+                exists <- doesDirectoryExist libdir+                if exists+                   then return $ Just libdir+                   else fail path+            | otherwise  -> try_size (size * 2)++    -- getFinalPath returns paths in full raw form.+    -- Unfortunately GHC isn't set up to handle these+    -- So if the call succeeded, we need to drop the+    -- \\?\ prefix.+    sanitize s = if "\\\\?\\" `isPrefixOf` s+                    then drop 4 s+                    else s++    rootDir s = case splitFileName $ normalise s of+                (d, ghc_exe)+                 | lower ghc_exe `elem` ["ghc.exe",+                                         "ghc-stage1.exe",+                                         "ghc-stage2.exe",+                                         "ghc-stage3.exe"] ->+                    case splitFileName $ takeDirectory d of+                    -- ghc is in $topdir/bin/ghc.exe+                    (d', _) -> takeDirectory d' </> "lib"+                _ -> fail s++    fail s = panic ("can't decompose ghc.exe path: " ++ show s)+    lower = map toLower++foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"+  c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32++-- Attempt to resolve symlinks in order to find the actual location GHC+-- is located at. See Trac #11759.+getFinalPath :: FilePath -> IO (Maybe FilePath)+getFinalPath name = do+    dllHwnd <- failIfNull "LoadLibray"     $ loadLibrary "kernel32.dll"+    -- Note: The API GetFinalPathNameByHandleW is only available starting from Windows Vista.+    -- This means that we can't bind directly to it since it may be missing.+    -- Instead try to find it's address at runtime and if we don't succeed consider the+    -- function failed.+    addr_m  <- (fmap Just $ failIfNull "getProcAddress" $ getProcAddress dllHwnd "GetFinalPathNameByHandleW")+                  `catch` (\(_ :: SomeException) -> return Nothing)+    case addr_m of+      Nothing   -> return Nothing+      Just addr -> do handle  <- failIf (==iNVALID_HANDLE_VALUE) "CreateFile"+                                        $ createFile name+                                                     gENERIC_READ+                                                     fILE_SHARE_READ+                                                     Nothing+                                                     oPEN_EXISTING+                                                     (fILE_ATTRIBUTE_NORMAL .|. fILE_FLAG_BACKUP_SEMANTICS)+                                                     Nothing+                      let fnPtr = makeGetFinalPathNameByHandle $ castPtrToFunPtr addr+                      path    <- Win32.try "GetFinalPathName"+                                    (\buf len -> fnPtr handle buf len 0) 512+                                    `finally` closeHandle handle+                      return $ Just path++type GetFinalPath = HANDLE -> LPTSTR -> DWORD -> DWORD -> IO DWORD++foreign import WINDOWS_CCONV unsafe "dynamic"+  makeGetFinalPathNameByHandle :: FunPtr GetFinalPath -> GetFinalPath+#else+getBaseDir = return Nothing+#endif++#ifdef mingw32_HOST_OS+foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows+#else+getProcessID :: IO Int+getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral+#endif++-- Divvy up text stream into lines, taking platform dependent+-- line termination into account.+linesPlatform :: String -> [String]+#if !defined(mingw32_HOST_OS)+linesPlatform ls = lines ls+#else+linesPlatform "" = []+linesPlatform xs =+  case lineBreak xs of+    (as,xs1) -> as : linesPlatform xs1+  where+   lineBreak "" = ("","")+   lineBreak ('\r':'\n':xs) = ([],xs)+   lineBreak ('\n':xs) = ([],xs)+   lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)++#endif++{-+Note [No PIE eating while linking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As of 2016 some Linux distributions (e.g. Debian) have started enabling -pie by+default in their gcc builds. This is incompatible with -r as it implies that we+are producing an executable. Consequently, we must manually pass -no-pie to gcc+when joining object files or linking dynamic libraries. See #12759.+-}++linkDynLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()+linkDynLib dflags0 o_files dep_packages+ = do+    let -- This is a rather ugly hack to fix dynamically linked+        -- GHC on Windows. If GHC is linked with -threaded, then+        -- it links against libHSrts_thr. But if base is linked+        -- against libHSrts, then both end up getting loaded,+        -- and things go wrong. We therefore link the libraries+        -- with the same RTS flags that we link GHC with.+        dflags1 = if cGhcThreaded then addWay' WayThreaded dflags0+                                  else                     dflags0+        dflags2 = if cGhcDebugged then addWay' WayDebug dflags1+                                  else                  dflags1+        dflags = updateWays dflags2++        verbFlags = getVerbFlags dflags+        o_file = outputFile dflags++    pkgs <- getPreloadPackagesAnd dflags dep_packages++    let pkg_lib_paths = collectLibraryPaths dflags pkgs+    let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths+        get_pkg_lib_path_opts l+         | ( osElfTarget (platformOS (targetPlatform dflags)) ||+             osMachOTarget (platformOS (targetPlatform dflags)) ) &&+           dynLibLoader dflags == SystemDependent &&+           WayDyn `elem` ways dflags+            = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l]+              -- See Note [-Xlinker -rpath vs -Wl,-rpath]+         | otherwise = ["-L" ++ l]++    let lib_paths = libraryPaths dflags+    let lib_path_opts = map ("-L"++) lib_paths++    -- We don't want to link our dynamic libs against the RTS package,+    -- because the RTS lib comes in several flavours and we want to be+    -- able to pick the flavour when a binary is linked.+    -- On Windows we need to link the RTS import lib as Windows does+    -- not allow undefined symbols.+    -- The RTS library path is still added to the library search path+    -- above in case the RTS is being explicitly linked in (see #3807).+    let platform = targetPlatform dflags+        os = platformOS platform+        pkgs_no_rts = case os of+                      OSMinGW32 ->+                          pkgs+                      _ ->+                          filter ((/= rtsUnitId) . packageConfigId) pkgs+    let pkg_link_opts = let (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs_no_rts+                        in  package_hs_libs ++ extra_libs ++ other_flags++        -- probably _stub.o files+        -- and last temporary shared object file+    let extra_ld_inputs = ldInputs dflags++    -- frameworks+    pkg_framework_opts <- getPkgFrameworkOpts dflags platform+                                              (map unitId pkgs)+    let framework_opts = getFrameworkOpts dflags platform++    case os of+        OSMinGW32 -> do+            -------------------------------------------------------------+            -- Making a DLL+            -------------------------------------------------------------+            let output_fn = case o_file of+                            Just s -> s+                            Nothing -> "HSdll.dll"++            runLink dflags (+                    map Option verbFlags+                 ++ [ Option "-o"+                    , FileOption "" output_fn+                    , Option "-shared"+                    ] +++                    [ FileOption "-Wl,--out-implib=" (output_fn ++ ".a")+                    | gopt Opt_SharedImplib dflags+                    ]+                 ++ map (FileOption "") o_files++                 -- Permit the linker to auto link _symbol to _imp_symbol+                 -- This lets us link against DLLs without needing an "import library"+                 ++ [Option "-Wl,--enable-auto-import"]++                 ++ extra_ld_inputs+                 ++ map Option (+                    lib_path_opts+                 ++ pkg_lib_path_opts+                 ++ pkg_link_opts+                ))+        OSDarwin -> do+            -------------------------------------------------------------------+            -- Making a darwin dylib+            -------------------------------------------------------------------+            -- About the options used for Darwin:+            -- -dynamiclib+            --   Apple's way of saying -shared+            -- -undefined dynamic_lookup:+            --   Without these options, we'd have to specify the correct+            --   dependencies for each of the dylibs. Note that we could+            --   (and should) do without this for all libraries except+            --   the RTS; all we need to do is to pass the correct+            --   HSfoo_dyn.dylib files to the link command.+            --   This feature requires Mac OS X 10.3 or later; there is+            --   a similar feature, -flat_namespace -undefined suppress,+            --   which works on earlier versions, but it has other+            --   disadvantages.+            -- -single_module+            --   Build the dynamic library as a single "module", i.e. no+            --   dynamic binding nonsense when referring to symbols from+            --   within the library. The NCG assumes that this option is+            --   specified (on i386, at least).+            -- -install_name+            --   Mac OS/X stores the path where a dynamic library is (to+            --   be) installed in the library itself.  It's called the+            --   "install name" of the library. Then any library or+            --   executable that links against it before it's installed+            --   will search for it in its ultimate install location.+            --   By default we set the install name to the absolute path+            --   at build time, but it can be overridden by the+            --   -dylib-install-name option passed to ghc. Cabal does+            --   this.+            -------------------------------------------------------------------++            let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }++            instName <- case dylibInstallName dflags of+                Just n -> return n+                Nothing -> return $ "@rpath" `combine` (takeFileName output_fn)+            runLink dflags (+                    map Option verbFlags+                 ++ [ Option "-dynamiclib"+                    , Option "-o"+                    , FileOption "" output_fn+                    ]+                 ++ map Option o_files+                 ++ [ Option "-undefined",+                      Option "dynamic_lookup",+                      Option "-single_module" ]+                 ++ (if platformArch platform == ArchX86_64+                     then [ ]+                     else [ Option "-Wl,-read_only_relocs,suppress" ])+                 ++ [ Option "-install_name", Option instName ]+                 ++ map Option lib_path_opts+                 ++ extra_ld_inputs+                 ++ map Option framework_opts+                 ++ map Option pkg_lib_path_opts+                 ++ map Option pkg_link_opts+                 ++ map Option pkg_framework_opts+              )+        OSiOS -> throwGhcExceptionIO (ProgramError "dynamic libraries are not supported on iOS target")+        _ -> do+            -------------------------------------------------------------------+            -- Making a DSO+            -------------------------------------------------------------------++            let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }+            let bsymbolicFlag = -- we need symbolic linking to resolve+                                -- non-PIC intra-package-relocations+                                ["-Wl,-Bsymbolic"]++            runLink dflags (+                    map Option verbFlags+                 ++ [ Option "-o"+                    , FileOption "" output_fn+                    ]+                    -- See Note [No PIE eating when linking]+                 ++ (if sGccSupportsNoPie (settings dflags)+                     then [Option "-no-pie"]+                     else [])+                 ++ map Option o_files+                 ++ [ Option "-shared" ]+                 ++ map Option bsymbolicFlag+                    -- Set the library soname. We use -h rather than -soname as+                    -- Solaris 10 doesn't support the latter:+                 ++ [ Option ("-Wl,-h," ++ takeFileName output_fn) ]+                 ++ extra_ld_inputs+                 ++ map Option lib_path_opts+                 ++ map Option pkg_lib_path_opts+                 ++ map Option pkg_link_opts+              )++getPkgFrameworkOpts :: DynFlags -> Platform -> [InstalledUnitId] -> IO [String]+getPkgFrameworkOpts dflags platform dep_packages+  | platformUsesFrameworks platform = do+    pkg_framework_path_opts <- do+        pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages+        return $ map ("-F" ++) pkg_framework_paths++    pkg_framework_opts <- do+        pkg_frameworks <- getPackageFrameworks dflags dep_packages+        return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ]++    return (pkg_framework_path_opts ++ pkg_framework_opts)++  | otherwise = return []++getFrameworkOpts :: DynFlags -> Platform -> [String]+getFrameworkOpts dflags platform+  | platformUsesFrameworks platform = framework_path_opts ++ framework_opts+  | otherwise = []+  where+    framework_paths     = frameworkPaths dflags+    framework_path_opts = map ("-F" ++) framework_paths++    frameworks     = cmdlineFrameworks dflags+    -- reverse because they're added in reverse order from the cmd line:+    framework_opts = concat [ ["-framework", fw]+                            | fw <- reverse frameworks ]
+ main/SysTools/Terminal.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+module SysTools.Terminal (stderrSupportsAnsiColors) where+#if defined MIN_VERSION_terminfo+import Control.Exception (catch)+import Data.Maybe (fromMaybe)+import System.Console.Terminfo (SetupTermError, Terminal, getCapability,+                                setupTermFromEnv, termColors)+import System.Posix (queryTerminal, stdError)+#elif defined mingw32_HOST_OS+import Control.Exception (catch, try)+import Data.Bits ((.|.), (.&.))+import Data.List (isInfixOf, isPrefixOf, isSuffixOf)+import Foreign (FunPtr, Ptr, allocaBytes, castPtrToFunPtr,+                peek, plusPtr, sizeOf, with)+import Foreign.C (CInt(..), CWchar, peekCWStringLen)+import qualified Graphics.Win32 as Win32+import qualified System.Win32 as Win32+#endif++#if defined mingw32_HOST_OS && !defined WINAPI+# if defined i386_HOST_ARCH+#  define WINAPI stdcall+# elif defined x86_64_HOST_ARCH+#  define WINAPI ccall+# else+#  error unknown architecture+# endif+#endif++-- | Check if ANSI escape sequences can be used to control color in stderr.+stderrSupportsAnsiColors :: IO Bool+stderrSupportsAnsiColors = do+#if defined MIN_VERSION_terminfo+  queryTerminal stdError `andM` do+    (termSupportsColors <$> setupTermFromEnv)+      `catch` \ (_ :: SetupTermError) ->+        pure False++  where++    andM :: Monad m => m Bool -> m Bool -> m Bool+    andM mx my = do+      x <- mx+      if x+        then my+        else pure x++    termSupportsColors :: Terminal -> Bool+    termSupportsColors term = fromMaybe 0 (getCapability term termColors) > 0++#elif defined mingw32_HOST_OS+  h <- Win32.getStdHandle Win32.sTD_ERROR_HANDLE+         `catch` \ (_ :: IOError) ->+           pure Win32.nullHANDLE+  if h == Win32.nullHANDLE+    then pure False+    else do+      eMode <- try (getConsoleMode h)+      case eMode of+        Left (_ :: IOError) -> queryCygwinTerminal h+        Right mode+          | modeHasVTP mode -> pure True+          | otherwise       -> enableVTP h mode++  where++    queryCygwinTerminal :: Win32.HANDLE -> IO Bool+    queryCygwinTerminal h = do+        fileType <- Win32.getFileType h+        if fileType /= Win32.fILE_TYPE_PIPE+          then pure False+          else do+            fn <- getFileNameByHandle h+            pure (("\\cygwin-" `isPrefixOf` fn || "\\msys-" `isPrefixOf` fn) &&+                  "-pty" `isInfixOf` fn &&+                  "-master" `isSuffixOf` fn)+      `catch` \ (_ :: IOError) ->+        pure False++    enableVTP :: Win32.HANDLE -> Win32.DWORD -> IO Bool+    enableVTP h mode = do+        setConsoleMode h (modeAddVTP mode)+        modeHasVTP <$> getConsoleMode h+      `catch` \ (_ :: IOError) ->+        pure False++    modeHasVTP :: Win32.DWORD -> Bool+    modeHasVTP mode = mode .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING /= 0++    modeAddVTP :: Win32.DWORD -> Win32.DWORD+    modeAddVTP mode = mode .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING++eNABLE_VIRTUAL_TERMINAL_PROCESSING :: Win32.DWORD+eNABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0004++getConsoleMode :: Win32.HANDLE -> IO Win32.DWORD+getConsoleMode h = with 64 $ \ mode -> do+  Win32.failIfFalse_ "GetConsoleMode" (c_GetConsoleMode h mode)+  peek mode++setConsoleMode :: Win32.HANDLE -> Win32.DWORD -> IO ()+setConsoleMode h mode = do+  Win32.failIfFalse_ "SetConsoleMode" (c_SetConsoleMode h mode)++foreign import WINAPI unsafe "windows.h GetConsoleMode" c_GetConsoleMode+  :: Win32.HANDLE -> Ptr Win32.DWORD -> IO Win32.BOOL++foreign import WINAPI unsafe "windows.h SetConsoleMode" c_SetConsoleMode+  :: Win32.HANDLE -> Win32.DWORD -> IO Win32.BOOL++fileNameInfo :: CInt+fileNameInfo = 2++mAX_PATH :: Num a => a+mAX_PATH = 260++getFileNameByHandle :: Win32.HANDLE -> IO String+getFileNameByHandle h = do+  let sizeOfDWORD = sizeOf (undefined :: Win32.DWORD)+  let sizeOfWchar = sizeOf (undefined :: CWchar)+  -- note: implicitly assuming that DWORD has stronger alignment than wchar_t+  let bufSize = sizeOfDWORD + mAX_PATH * sizeOfWchar+  allocaBytes bufSize $ \ buf -> do+    getFileInformationByHandleEx h fileNameInfo buf (fromIntegral bufSize)+    len :: Win32.DWORD <- peek buf+    let len' = fromIntegral len `div` sizeOfWchar+    peekCWStringLen (buf `plusPtr` sizeOfDWORD, min len' mAX_PATH)++getFileInformationByHandleEx+  :: Win32.HANDLE -> CInt -> Ptr a -> Win32.DWORD -> IO ()+getFileInformationByHandleEx h cls buf bufSize = do+  lib <- Win32.getModuleHandle (Just "kernel32.dll")+  ptr <- Win32.getProcAddress lib "GetFileInformationByHandleEx"+  let c_GetFileInformationByHandleEx =+        mk_GetFileInformationByHandleEx (castPtrToFunPtr ptr)+  Win32.failIfFalse_ "getFileInformationByHandleEx"+    (c_GetFileInformationByHandleEx h cls buf bufSize)++type F_GetFileInformationByHandleEx a =+  Win32.HANDLE -> CInt -> Ptr a -> Win32.DWORD -> IO Win32.BOOL++foreign import WINAPI "dynamic"+  mk_GetFileInformationByHandleEx+  :: FunPtr (F_GetFileInformationByHandleEx a)+  -> F_GetFileInformationByHandleEx a++#else+   pure False+#endif
+ main/TidyPgm.hs view
@@ -0,0 +1,1492 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section{Tidying up Core}+-}++{-# LANGUAGE CPP, ViewPatterns #-}++module TidyPgm (+       mkBootModDetailsTc, tidyProgram, globaliseAndTidyId+   ) where++#include "HsVersions.h"++import TcRnTypes+import DynFlags+import CoreSyn+import CoreUnfold+import CoreFVs+import CoreTidy+import CoreMonad+import CorePrep+import CoreUtils        (rhsIsStatic)+import CoreStats        (coreBindsStats, CoreStats(..))+import CoreSeq          (seqBinds)+import CoreLint+import Literal+import Rules+import PatSyn+import ConLike+import CoreArity        ( exprArity, exprBotStrictness_maybe )+import StaticPtrTable+import VarEnv+import VarSet+import Var+import Id+import MkId             ( mkDictSelRhs )+import IdInfo+import InstEnv+import FamInstEnv+import Type             ( tidyTopType )+import Demand           ( appIsBottom, isTopSig, isBottomingSig )+import BasicTypes+import Name hiding (varName)+import NameSet+import NameEnv+import NameCache+import Avail+import IfaceEnv+import TcEnv+import TcRnMonad+import DataCon+import TyCon+import Class+import Module+import Packages( isDllName )+import HscTypes+import Maybes+import UniqSupply+import ErrUtils (Severity(..))+import Outputable+import UniqDFM+import SrcLoc+import qualified ErrUtils as Err++import Control.Monad+import Data.Function+import Data.List        ( sortBy )+import Data.IORef       ( atomicModifyIORef' )++{-+Constructing the TypeEnv, Instances, Rules, VectInfo from which the+ModIface is constructed, and which goes on to subsequent modules in+--make mode.++Most of the interface file is obtained simply by serialising the+TypeEnv.  One important consequence is that if the *interface file*+has pragma info if and only if the final TypeEnv does. This is not so+important for *this* module, but it's essential for ghc --make:+subsequent compilations must not see (e.g.) the arity if the interface+file does not contain arity If they do, they'll exploit the arity;+then the arity might change, but the iface file doesn't change =>+recompilation does not happen => disaster.++For data types, the final TypeEnv will have a TyThing for the TyCon,+plus one for each DataCon; the interface file will contain just one+data type declaration, but it is de-serialised back into a collection+of TyThings.++************************************************************************+*                                                                      *+                Plan A: simpleTidyPgm+*                                                                      *+************************************************************************+++Plan A: mkBootModDetails: omit pragmas, make interfaces small+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* Ignore the bindings++* Drop all WiredIn things from the TypeEnv+        (we never want them in interface files)++* Retain all TyCons and Classes in the TypeEnv, to avoid+        having to find which ones are mentioned in the+        types of exported Ids++* Trim off the constructors of non-exported TyCons, both+        from the TyCon and from the TypeEnv++* Drop non-exported Ids from the TypeEnv++* Tidy the types of the DFunIds of Instances,+  make them into GlobalIds, (they already have External Names)+  and add them to the TypeEnv++* Tidy the types of the (exported) Ids in the TypeEnv,+  make them into GlobalIds (they already have External Names)++* Drop rules altogether++* Tidy the bindings, to ensure that the Caf and Arity+  information is correct for each top-level binder; the+  code generator needs it. And to ensure that local names have+  distinct OccNames in case of object-file splitting++* If this an hsig file, drop the instances altogether too (they'll+  get pulled in by the implicit module import.+-}++-- This is Plan A: make a small type env when typechecking only,+-- or when compiling a hs-boot file, or simply when not using -O+--+-- We don't look at the bindings at all -- there aren't any+-- for hs-boot files++mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails+mkBootModDetailsTc hsc_env+        TcGblEnv{ tcg_exports   = exports,+                  tcg_type_env  = type_env, -- just for the Ids+                  tcg_tcs       = tcs,+                  tcg_patsyns   = pat_syns,+                  tcg_insts     = insts,+                  tcg_fam_insts = fam_insts,+                  tcg_mod       = this_mod+                }+  = -- This timing isn't terribly useful since the result isn't forced, but+    -- the message is useful to locating oneself in the compilation process.+    Err.withTiming (pure dflags)+                   (text "CoreTidy"<+>brackets (ppr this_mod))+                   (const ()) $+    do  { let { insts'     = map (tidyClsInstDFun globaliseAndTidyId) insts+              ; pat_syns'  = map (tidyPatSynIds   globaliseAndTidyId) pat_syns+              ; type_env1  = mkBootTypeEnv (availsToNameSet exports)+                                           (typeEnvIds type_env) tcs fam_insts+              ; type_env2  = extendTypeEnvWithPatSyns pat_syns' type_env1+              ; dfun_ids   = map instanceDFunId insts'+              ; type_env'  = extendTypeEnvWithIds type_env2 dfun_ids+              }+        ; return (ModDetails { md_types     = type_env'+                             , md_insts     = insts'+                             , md_fam_insts = fam_insts+                             , md_rules     = []+                             , md_anns      = []+                             , md_exports   = exports+                             , md_vect_info = noVectInfo+                             , md_complete_sigs = []+                             })+        }+  where+    dflags = hsc_dflags hsc_env++mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst] -> TypeEnv+mkBootTypeEnv exports ids tcs fam_insts+  = tidyTypeEnv True $+       typeEnvFromEntities final_ids tcs fam_insts+  where+        -- Find the LocalIds in the type env that are exported+        -- Make them into GlobalIds, and tidy their types+        --+        -- It's very important to remove the non-exported ones+        -- because we don't tidy the OccNames, and if we don't remove+        -- the non-exported ones we'll get many things with the+        -- same name in the interface file, giving chaos.+        --+        -- Do make sure that we keep Ids that are already Global.+        -- When typechecking an .hs-boot file, the Ids come through as+        -- GlobalIds.+    final_ids = [ (if isLocalId id then globaliseAndTidyId id+                                   else id)+                        `setIdUnfolding` BootUnfolding+                | id <- ids+                , keep_it id ]++        -- default methods have their export flag set, but everything+        -- else doesn't (yet), because this is pre-desugaring, so we+        -- must test both.+    keep_it id = isExportedId id || idName id `elemNameSet` exports++++globaliseAndTidyId :: Id -> Id+-- Takes an LocalId with an External Name,+-- makes it into a GlobalId+--     * unchanged Name (might be Internal or External)+--     * unchanged details+--     * VanillaIdInfo (makes a conservative assumption about Caf-hood)+globaliseAndTidyId id+  = Id.setIdType (globaliseId id) tidy_type+  where+    tidy_type = tidyTopType (idType id)++{-+************************************************************************+*                                                                      *+        Plan B: tidy bindings, make TypeEnv full of IdInfo+*                                                                      *+************************************************************************++Plan B: include pragmas, make interfaces+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* Figure out which Ids are externally visible++* Tidy the bindings, externalising appropriate Ids++* Drop all Ids from the TypeEnv, and add all the External Ids from+  the bindings.  (This adds their IdInfo to the TypeEnv; and adds+  floated-out Ids that weren't even in the TypeEnv before.)++Step 1: Figure out external Ids+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [choosing external names]++See also the section "Interface stability" in the+RecompilationAvoidance commentary:+  http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance++First we figure out which Ids are "external" Ids.  An+"external" Id is one that is visible from outside the compilation+unit.  These are+  a) the user exported ones+  b) the ones bound to static forms+  c) ones mentioned in the unfoldings, workers,+     rules of externally-visible ones ,+     or vectorised versions of externally-visible ones++While figuring out which Ids are external, we pick a "tidy" OccName+for each one.  That is, we make its OccName distinct from the other+external OccNames in this module, so that in interface files and+object code we can refer to it unambiguously by its OccName.  The+OccName for each binder is prefixed by the name of the exported Id+that references it; e.g. if "f" references "x" in its unfolding, then+"x" is renamed to "f_x".  This helps distinguish the different "x"s+from each other, and means that if "f" is later removed, things that+depend on the other "x"s will not need to be recompiled.  Of course,+if there are multiple "f_x"s, then we have to disambiguate somehow; we+use "f_x0", "f_x1" etc.++As far as possible we should assign names in a deterministic fashion.+Each time this module is compiled with the same options, we should end+up with the same set of external names with the same types.  That is,+the ABI hash in the interface should not change.  This turns out to be+quite tricky, since the order of the bindings going into the tidy+phase is already non-deterministic, as it is based on the ordering of+Uniques, which are assigned unpredictably.++To name things in a stable way, we do a depth-first-search of the+bindings, starting from the exports sorted by name.  This way, as long+as the bindings themselves are deterministic (they sometimes aren't!),+the order in which they are presented to the tidying phase does not+affect the names we assign.++Step 2: Tidy the program+~~~~~~~~~~~~~~~~~~~~~~~~+Next we traverse the bindings top to bottom.  For each *top-level*+binder++ 1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal,+    reflecting the fact that from now on we regard it as a global,+    not local, Id++ 2. Give it a system-wide Unique.+    [Even non-exported things need system-wide Uniques because the+    byte-code generator builds a single Name->BCO symbol table.]++    We use the NameCache kept in the HscEnv as the+    source of such system-wide uniques.++    For external Ids, use the original-name cache in the NameCache+    to ensure that the unique assigned is the same as the Id had+    in any previous compilation run.++ 3. Rename top-level Ids according to the names we chose in step 1.+    If it's an external Id, make it have a External Name, otherwise+    make it have an Internal Name.  This is used by the code generator+    to decide whether to make the label externally visible++ 4. Give it its UTTERLY FINAL IdInfo; in ptic,+        * its unfolding, if it should have one++        * its arity, computed from the number of visible lambdas++        * its CAF info, computed from what is free in its RHS+++Finally, substitute these new top-level binders consistently+throughout, including in unfoldings.  We also tidy binders in+RHSs, so that they print nicely in interfaces.+-}++tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)+tidyProgram hsc_env  (ModGuts { mg_module    = mod+                              , mg_exports   = exports+                              , mg_rdr_env   = rdr_env+                              , mg_tcs       = tcs+                              , mg_insts     = cls_insts+                              , mg_fam_insts = fam_insts+                              , mg_binds     = binds+                              , mg_patsyns   = patsyns+                              , mg_rules     = imp_rules+                              , mg_vect_info = vect_info+                              , mg_anns      = anns+                              , mg_complete_sigs = complete_sigs+                              , mg_deps      = deps+                              , mg_foreign   = foreign_stubs+                              , mg_foreign_files = foreign_files+                              , mg_hpc_info  = hpc_info+                              , mg_modBreaks = modBreaks+                              })++  = Err.withTiming (pure dflags)+                   (text "CoreTidy"<+>brackets (ppr mod))+                   (const ()) $+    do  { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags+              ; expose_all = gopt Opt_ExposeAllUnfoldings  dflags+              ; print_unqual = mkPrintUnqualified dflags rdr_env+              }++        ; let { type_env = typeEnvFromEntities [] tcs fam_insts++              ; implicit_binds+                  = concatMap getClassImplicitBinds (typeEnvClasses type_env) +++                    concatMap getTyConImplicitBinds (typeEnvTyCons type_env)+              }++        ; (unfold_env, tidy_occ_env)+              <- chooseExternalIds hsc_env mod omit_prags expose_all+                                   binds implicit_binds imp_rules (vectInfoVar vect_info)+        ; let { (trimmed_binds, trimmed_rules)+                    = findExternalRules omit_prags binds imp_rules unfold_env }++        ; (tidy_env, tidy_binds)+                 <- tidyTopBinds hsc_env mod unfold_env tidy_occ_env trimmed_binds++        ; let { final_ids  = [ id | id <- bindersOfBinds tidy_binds,+                                    isExternalName (idName id)]+              ; type_env1  = extendTypeEnvWithIds type_env final_ids++              ; tidy_cls_insts = map (tidyClsInstDFun (tidyVarOcc tidy_env)) cls_insts+                -- A DFunId will have a binding in tidy_binds, and so will now be in+                -- tidy_type_env, replete with IdInfo.  Its name will be unchanged since+                -- it was born, but we want Global, IdInfo-rich (or not) DFunId in the+                -- tidy_cls_insts.  Similarly the Ids inside a PatSyn.++              ; tidy_rules = tidyRules tidy_env trimmed_rules+                -- You might worry that the tidy_env contains IdInfo-rich stuff+                -- and indeed it does, but if omit_prags is on, ext_rules is+                -- empty++              ; tidy_vect_info = tidyVectInfo tidy_env vect_info++                -- Tidy the Ids inside each PatSyn, very similarly to DFunIds+                -- and then override the PatSyns in the type_env with the new tidy ones+                -- This is really the only reason we keep mg_patsyns at all; otherwise+                -- they could just stay in type_env+              ; tidy_patsyns = map (tidyPatSynIds (tidyVarOcc tidy_env)) patsyns+              ; type_env2    = extendTypeEnvWithPatSyns tidy_patsyns type_env1++              ; tidy_type_env = tidyTypeEnv omit_prags type_env2+              }+          -- See Note [Grand plan for static forms] in StaticPtrTable.+        ; (spt_entries, tidy_binds') <-+             sptCreateStaticBinds hsc_env mod tidy_binds+        ; let { spt_init_code = sptModuleInitCode mod spt_entries+              ; add_spt_init_code =+                  case hscTarget dflags of+                    -- If we are compiling for the interpreter we will insert+                    -- any necessary SPT entries dynamically+                    HscInterpreted -> id+                    -- otherwise add a C stub to do so+                    _              -> (`appendStubC` spt_init_code)+              }++        ; let { -- See Note [Injecting implicit bindings]+                all_tidy_binds = implicit_binds ++ tidy_binds'++              -- Get the TyCons to generate code for.  Careful!  We must use+              -- the untidied TypeEnv here, because we need+              --  (a) implicit TyCons arising from types and classes defined+              --      in this module+              --  (b) wired-in TyCons, which are normally removed from the+              --      TypeEnv we put in the ModDetails+              --  (c) Constructors even if they are not exported (the+              --      tidied TypeEnv has trimmed these away)+              ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)+              }++        ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules++          -- If the endPass didn't print the rules, but ddump-rules is+          -- on, print now+        ; unless (dopt Opt_D_dump_simpl dflags) $+            Err.dumpIfSet_dyn dflags Opt_D_dump_rules+              (showSDoc dflags (ppr CoreTidy <+> text "rules"))+              (pprRulesForUser dflags tidy_rules)++          -- Print one-line size info+        ; let cs = coreBindsStats tidy_binds+        ; when (dopt Opt_D_dump_core_stats dflags)+               (putLogMsg dflags NoReason SevDump noSrcSpan+                          (defaultDumpStyle dflags)+                          (text "Tidy size (terms,types,coercions)"+                           <+> ppr (moduleName mod) <> colon+                           <+> int (cs_tm cs)+                           <+> int (cs_ty cs)+                           <+> int (cs_co cs) ))++        ; return (CgGuts { cg_module   = mod,+                           cg_tycons   = alg_tycons,+                           cg_binds    = all_tidy_binds,+                           cg_foreign  = add_spt_init_code foreign_stubs,+                           cg_foreign_files = foreign_files,+                           cg_dep_pkgs = map fst $ dep_pkgs deps,+                           cg_hpc_info = hpc_info,+                           cg_modBreaks = modBreaks,+                           cg_spt_entries = spt_entries },++                   ModDetails { md_types     = tidy_type_env,+                                md_rules     = tidy_rules,+                                md_insts     = tidy_cls_insts,+                                md_vect_info = tidy_vect_info,+                                md_fam_insts = fam_insts,+                                md_exports   = exports,+                                md_anns      = anns,      -- are already tidy+                                md_complete_sigs = complete_sigs+                              })+        }+  where+    dflags = hsc_dflags hsc_env++tidyTypeEnv :: Bool       -- Compiling without -O, so omit prags+            -> TypeEnv -> TypeEnv++-- The competed type environment is gotten from+--      a) the types and classes defined here (plus implicit things)+--      b) adding Ids with correct IdInfo, including unfoldings,+--              gotten from the bindings+-- From (b) we keep only those Ids with External names;+--          the CoreTidy pass makes sure these are all and only+--          the externally-accessible ones+-- This truncates the type environment to include only the+-- exported Ids and things needed from them, which saves space+--+-- See Note [Don't attempt to trim data types]++tidyTypeEnv omit_prags type_env+ = let+        type_env1 = filterNameEnv (not . isWiredInName . getName) type_env+          -- (1) remove wired-in things+        type_env2 | omit_prags = mapNameEnv trimThing type_env1+                  | otherwise  = type_env1+          -- (2) trimmed if necessary+    in+    type_env2++--------------------------+trimThing :: TyThing -> TyThing+-- Trim off inessentials, for boot files and no -O+trimThing (AnId id)+   | not (isImplicitId id)+   = AnId (id `setIdInfo` vanillaIdInfo)++trimThing other_thing+  = other_thing++extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv+extendTypeEnvWithPatSyns tidy_patsyns type_env+  = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ]++tidyVectInfo :: TidyEnv -> VectInfo -> VectInfo+tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar          = vars+                                         , vectInfoParallelVars = parallelVars+                                         })+  = info { vectInfoVar          = tidy_vars+         , vectInfoParallelVars = tidy_parallelVars+         }+  where+      -- we only export mappings whose domain and co-domain is exported (otherwise, the iface is+      -- inconsistent)+    tidy_vars = mkDVarEnv [ (tidy_var, (tidy_var, tidy_var_v))+                          | (var, var_v) <- eltsUDFM vars+                          , let tidy_var   = lookup_var var+                                tidy_var_v = lookup_var var_v+                          , isExternalId tidy_var   && isExportedId tidy_var+                          , isExternalId tidy_var_v && isExportedId tidy_var_v+                          , isDataConWorkId var || not (isImplicitId var)+                          ]++    tidy_parallelVars = mkDVarSet+                          [ tidy_var+                          | var <- dVarSetElems parallelVars+                          , let tidy_var = lookup_var var+                          , isExternalId tidy_var && isExportedId tidy_var+                          ]++    lookup_var var = lookupWithDefaultVarEnv var_env var var++    -- We need to make sure that all names getting into the iface version of 'VectInfo' are+    -- external; otherwise, 'MkIface' will bomb out.+    isExternalId = isExternalName . idName++{-+Note [Don't attempt to trim data types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For some time GHC tried to avoid exporting the data constructors+of a data type if it wasn't strictly necessary to do so; see Trac #835.+But "strictly necessary" accumulated a longer and longer list+of exceptions, and finally I gave up the battle:++    commit 9a20e540754fc2af74c2e7392f2786a81d8d5f11+    Author: Simon Peyton Jones <simonpj@microsoft.com>+    Date:   Thu Dec 6 16:03:16 2012 +0000++    Stop attempting to "trim" data types in interface files++    Without -O, we previously tried to make interface files smaller+    by not including the data constructors of data types.  But+    there are a lot of exceptions, notably when Template Haskell is+    involved or, more recently, DataKinds.++    However Trac #7445 shows that even without TemplateHaskell, using+    the Data class and invoking Language.Haskell.TH.Quote.dataToExpQ+    is enough to require us to expose the data constructors.++    So I've given up on this "optimisation" -- it's probably not+    important anyway.  Now I'm simply not attempting to trim off+    the data constructors.  The gain in simplicity is worth the+    modest cost in interface file growth, which is limited to the+    bits reqd to describe those data constructors.++************************************************************************+*                                                                      *+        Implicit bindings+*                                                                      *+************************************************************************++Note [Injecting implicit bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We inject the implicit bindings right at the end, in CoreTidy.+Some of these bindings, notably record selectors, are not+constructed in an optimised form.  E.g. record selector for+        data T = MkT { x :: {-# UNPACK #-} !Int }+Then the unfolding looks like+        x = \t. case t of MkT x1 -> let x = I# x1 in x+This generates bad code unless it's first simplified a bit.  That is+why CoreUnfold.mkImplicitUnfolding uses simpleOptExpr to do a bit of+optimisation first.  (Only matters when the selector is used curried;+eg map x ys.)  See Trac #2070.++[Oct 09: in fact, record selectors are no longer implicit Ids at all,+because we really do want to optimise them properly. They are treated+much like any other Id.  But doing "light" optimisation on an implicit+Id still makes sense.]++At one time I tried injecting the implicit bindings *early*, at the+beginning of SimplCore.  But that gave rise to real difficulty,+because GlobalIds are supposed to have *fixed* IdInfo, but the+simplifier and other core-to-core passes mess with IdInfo all the+time.  The straw that broke the camels back was when a class selector+got the wrong arity -- ie the simplifier gave it arity 2, whereas+importing modules were expecting it to have arity 1 (Trac #2844).+It's much safer just to inject them right at the end, after tidying.++Oh: two other reasons for injecting them late:++  - If implicit Ids are already in the bindings when we start TidyPgm,+    we'd have to be careful not to treat them as external Ids (in+    the sense of chooseExternalIds); else the Ids mentioned in *their*+    RHSs will be treated as external and you get an interface file+    saying      a18 = <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.++There is one sort of implicit binding that is injected still later,+namely those for data constructor workers. Reason (I think): it's+really just a code generation trick.... binding itself makes no sense.+See Note [Data constructor workers] in CorePrep.+-}++getTyConImplicitBinds :: TyCon -> [CoreBind]+getTyConImplicitBinds tc = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc))++getClassImplicitBinds :: Class -> [CoreBind]+getClassImplicitBinds cls+  = [ NonRec op (mkDictSelRhs cls val_index)+    | (op, val_index) <- classAllSelIds cls `zip` [0..] ]++get_defn :: Id -> CoreBind+get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id))++{-+************************************************************************+*                                                                      *+\subsection{Step 1: finding externals}+*                                                                      *+************************************************************************++See Note [Choosing external names].+-}++type UnfoldEnv  = IdEnv (Name{-new name-}, Bool {-show unfolding-})+  -- Maps each top-level Id to its new Name (the Id is tidied in step 2)+  -- The Unique is unchanged.  If the new Name is external, it will be+  -- visible in the interface file.+  --+  -- Bool => expose unfolding or not.++chooseExternalIds :: HscEnv+                  -> Module+                  -> Bool -> Bool+                  -> [CoreBind]+                  -> [CoreBind]+                  -> [CoreRule]+                  -> DVarEnv (Var, Var)+                  -> IO (UnfoldEnv, TidyOccEnv)+                  -- Step 1 from the notes above++chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules vect_vars+  = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env+       ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders+       ; tidy_internal internal_ids unfold_env1 occ_env1 }+ where+  nc_var = hsc_NC hsc_env++  -- init_ext_ids is the intial list of Ids that should be+  -- externalised.  It serves as the starting point for finding a+  -- deterministic, tidy, renaming for all external Ids in this+  -- module.+  --+  -- It is sorted, so that it has adeterministic order (i.e. it's the+  -- same list every time this module is compiled), in contrast to the+  -- bindings, which are ordered non-deterministically.+  init_work_list = zip init_ext_ids init_ext_ids+  init_ext_ids   = sortBy (compare `on` getOccName) $ filter is_external binders++  -- An Id should be external if either (a) it is exported,+  -- (b) it appears in the RHS of a local rule for an imported Id, or+  -- (c) it is the vectorised version of an imported Id.+  -- See Note [Which rules to expose]+  is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars+                 || id `elemVarSet` vect_var_vs++  rule_rhs_vars  = mapUnionVarSet ruleRhsFreeVars imp_id_rules+  vect_var_vs    = mkVarSet [var_v | (var, var_v) <- eltsUDFM vect_vars, isGlobalId var]++  binders          = map fst $ flattenBinds binds+  implicit_binders = bindersOfBinds implicit_binds+  binder_set       = mkVarSet binders++  avoids   = [getOccName name | bndr <- binders ++ implicit_binders,+                                let name = idName bndr,+                                isExternalName name ]+                -- In computing our "avoids" list, we must include+                --      all implicit Ids+                --      all things with global names (assigned once and for+                --                                      all by the renamer)+                -- since their names are "taken".+                -- The type environment is a convenient source of such things.+                -- In particular, the set of binders doesn't include+                -- implicit Ids at this stage.++        -- We also make sure to avoid any exported binders.  Consider+        --      f{-u1-} = 1     -- Local decl+        --      ...+        --      f{-u2-} = 2     -- Exported decl+        --+        -- The second exported decl must 'get' the name 'f', so we+        -- have to put 'f' in the avoids list before we get to the first+        -- decl.  tidyTopId then does a no-op on exported binders.+  init_occ_env = initTidyOccEnv avoids+++  search :: [(Id,Id)]    -- The work-list: (external id, referring id)+                         -- Make a tidy, external Name for the external id,+                         --   add it to the UnfoldEnv, and do the same for the+                         --   transitive closure of Ids it refers to+                         -- The referring id is used to generate a tidy+                         ---  name for the external id+         -> UnfoldEnv    -- id -> (new Name, show_unfold)+         -> TidyOccEnv   -- occ env for choosing new Names+         -> IO (UnfoldEnv, TidyOccEnv)++  search [] unfold_env occ_env = return (unfold_env, occ_env)++  search ((idocc,referrer) : rest) unfold_env occ_env+    | idocc `elemVarEnv` unfold_env = search rest unfold_env occ_env+    | otherwise = do+      (occ_env', name') <- tidyTopName mod nc_var (Just referrer) occ_env idocc+      let+          (new_ids, show_unfold)+                | omit_prags = ([], False)+                | otherwise  = addExternal expose_all refined_id++                -- add vectorised version if any exists+          new_ids' = new_ids ++ maybeToList (fmap snd $ lookupDVarEnv vect_vars idocc)++                -- 'idocc' is an *occurrence*, but we need to see the+                -- unfolding in the *definition*; so look up in binder_set+          refined_id = case lookupVarSet binder_set idocc of+                         Just id -> id+                         Nothing -> WARN( True, ppr idocc ) idocc++          unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold)+          referrer' | isExportedId refined_id = refined_id+                    | otherwise               = referrer+      --+      search (zip new_ids' (repeat referrer') ++ rest) unfold_env' occ_env'++  tidy_internal :: [Id] -> UnfoldEnv -> TidyOccEnv+                -> IO (UnfoldEnv, TidyOccEnv)+  tidy_internal []       unfold_env occ_env = return (unfold_env,occ_env)+  tidy_internal (id:ids) unfold_env occ_env = do+      (occ_env', name') <- tidyTopName mod nc_var Nothing occ_env id+      let unfold_env' = extendVarEnv unfold_env id (name',False)+      tidy_internal ids unfold_env' occ_env'++addExternal :: Bool -> Id -> ([Id], Bool)+addExternal expose_all id = (new_needed_ids, show_unfold)+  where+    new_needed_ids = bndrFvsInOrder show_unfold id+    idinfo         = idInfo id+    show_unfold    = show_unfolding (unfoldingInfo idinfo)+    never_active   = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo))+    loop_breaker   = isStrongLoopBreaker (occInfo idinfo)+    bottoming_fn   = isBottomingSig (strictnessInfo idinfo)++        -- Stuff to do with the Id's unfolding+        -- We leave the unfolding there even if there is a worker+        -- In GHCi the unfolding is used by importers++    show_unfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance })+       =  expose_all         -- 'expose_all' says to expose all+                             -- unfoldings willy-nilly++       || isStableSource src     -- Always expose things whose+                                 -- source is an inline rule++       || not (bottoming_fn      -- No need to inline bottom functions+           || never_active       -- Or ones that say not to+           || loop_breaker       -- Or that are loop breakers+           || neverUnfoldGuidance guidance)+    show_unfolding (DFunUnfolding {}) = True+    show_unfolding _                  = False++{-+************************************************************************+*                                                                      *+               Deterministic free variables+*                                                                      *+************************************************************************++We want a deterministic free-variable list.  exprFreeVars gives us+a VarSet, which is in a non-deterministic order when converted to a+list.  Hence, here we define a free-variable finder that returns+the free variables in the order that they are encountered.++See Note [Choosing external names]+-}++bndrFvsInOrder :: Bool -> Id -> [Id]+bndrFvsInOrder show_unfold id+  = run (dffvLetBndr show_unfold id)++run :: DFFV () -> [Id]+run (DFFV m) = case m emptyVarSet (emptyVarSet, []) of+                 ((_,ids),_) -> ids++newtype DFFV a+  = DFFV (VarSet              -- Envt: non-top-level things that are in scope+                              -- we don't want to record these as free vars+      -> (VarSet, [Var])      -- Input State: (set, list) of free vars so far+      -> ((VarSet,[Var]),a))  -- Output state++instance Functor DFFV where+    fmap = liftM++instance Applicative DFFV where+    pure a = DFFV $ \_ st -> (st, a)+    (<*>) = ap++instance Monad DFFV where+  (DFFV m) >>= k = DFFV $ \env st ->+    case m env st of+       (st',a) -> case k a of+                     DFFV f -> f env st'++extendScope :: Var -> DFFV a -> DFFV a+extendScope v (DFFV f) = DFFV (\env st -> f (extendVarSet env v) st)++extendScopeList :: [Var] -> DFFV a -> DFFV a+extendScopeList vs (DFFV f) = DFFV (\env st -> f (extendVarSetList env vs) st)++insert :: Var -> DFFV ()+insert v = DFFV $ \ env (set, ids) ->+           let keep_me = isLocalId v &&+                         not (v `elemVarSet` env) &&+                           not (v `elemVarSet` set)+           in if keep_me+              then ((extendVarSet set v, v:ids), ())+              else ((set,                ids),   ())+++dffvExpr :: CoreExpr -> DFFV ()+dffvExpr (Var v)              = insert v+dffvExpr (App e1 e2)          = dffvExpr e1 >> dffvExpr e2+dffvExpr (Lam v e)            = extendScope v (dffvExpr e)+dffvExpr (Tick (Breakpoint _ ids) e) = mapM_ insert ids >> dffvExpr e+dffvExpr (Tick _other e)    = dffvExpr e+dffvExpr (Cast e _)           = dffvExpr e+dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e)+dffvExpr (Let (Rec prs) e)    = extendScopeList (map fst prs) $+                                (mapM_ dffvBind prs >> dffvExpr e)+dffvExpr (Case e b _ as)      = dffvExpr e >> extendScope b (mapM_ dffvAlt as)+dffvExpr _other               = return ()++dffvAlt :: (t, [Var], CoreExpr) -> DFFV ()+dffvAlt (_,xs,r) = extendScopeList xs (dffvExpr r)++dffvBind :: (Id, CoreExpr) -> DFFV ()+dffvBind(x,r)+  | not (isId x) = dffvExpr r+  | otherwise    = dffvLetBndr False x >> dffvExpr r+                -- Pass False because we are doing the RHS right here+                -- If you say True you'll get *exponential* behaviour!++dffvLetBndr :: Bool -> Id -> DFFV ()+-- Gather the free vars of the RULES and unfolding of a binder+-- We always get the free vars of a *stable* unfolding, but+-- for a *vanilla* one (InlineRhs), the flag controls what happens:+--   True <=> get fvs of even a *vanilla* unfolding+--   False <=> ignore an InlineRhs+-- For nested bindings (call from dffvBind) we always say "False" because+--       we are taking the fvs of the RHS anyway+-- For top-level bindings (call from addExternal, via bndrFvsInOrder)+--       we say "True" if we are exposing that unfolding+dffvLetBndr vanilla_unfold id+  = do { go_unf (unfoldingInfo idinfo)+       ; mapM_ go_rule (ruleInfoRules (ruleInfo idinfo)) }+  where+    idinfo = idInfo id++    go_unf (CoreUnfolding { uf_tmpl = rhs, uf_src = src })+       = case src of+           InlineRhs | vanilla_unfold -> dffvExpr rhs+                     | otherwise      -> return ()+           _                          -> dffvExpr rhs++    go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args })+             = extendScopeList bndrs $ mapM_ dffvExpr args+    go_unf _ = return ()++    go_rule (BuiltinRule {}) = return ()+    go_rule (Rule { ru_bndrs = bndrs, ru_rhs = rhs })+      = extendScopeList bndrs (dffvExpr rhs)++{-+************************************************************************+*                                                                      *+               findExternalRules+*                                                                      *+************************************************************************++Note [Finding external rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The complete rules are gotten by combining+   a) local rules for imported Ids+   b) rules embedded in the top-level Ids++There are two complications:+  * Note [Which rules to expose]+  * Note [Trimming auto-rules]++Note [Which rules to expose]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The function 'expose_rule' filters out rules that mention, on the LHS,+Ids that aren't externally visible; these rules can't fire in a client+module.++The externally-visible binders are computed (by chooseExternalIds)+assuming that all orphan rules are externalised (see init_ext_ids in+function 'search'). So in fact it's a bit conservative and we may+export more than we need.  (It's a sort of mutual recursion.)++Note [Trimming auto-rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Second, with auto-specialisation we may specialise local or imported+dfuns or INLINE functions, and then later inline them.  That may leave+behind something like+   RULE "foo" forall d. f @ Int d = f_spec+where f is either local or imported, and there is no remaining+reference to f_spec except from the RULE.++Now that RULE *might* be useful to an importing module, but that is+purely speculative, and meanwhile the code is taking up space and+codegen time.  I found that binary sizes jumped by 6-10% when I+started to specialise INLINE functions (again, Note [Inline+specialisations] in Specialise).++So it seems better to drop the binding for f_spec, and the rule+itself, if the auto-generated rule is the *only* reason that it is+being kept alive.++(The RULE still might have been useful in the past; that is, it was+the right thing to have generated it in the first place.  See Note+[Inline specialisations] in Specialise.  But now it has served its+purpose, and can be discarded.)++So findExternalRules does this:+  * Remove all bindings that are kept alive *only* by isAutoRule rules+      (this is done in trim_binds)+  * Remove all auto rules that mention bindings that have been removed+      (this is done by filtering by keep_rule)++NB: if a binding is kept alive for some *other* reason (e.g. f_spec is+called in the final code), we keep the rule too.++This stuff is the only reason for the ru_auto field in a Rule.+-}++findExternalRules :: Bool       -- Omit pragmas+                  -> [CoreBind]+                  -> [CoreRule] -- Local rules for imported fns+                  -> UnfoldEnv  -- Ids that are exported, so we need their rules+                  -> ([CoreBind], [CoreRule])+-- See Note [Finding external rules]+findExternalRules omit_prags binds imp_id_rules unfold_env+  = (trimmed_binds, filter keep_rule all_rules)+  where+    imp_rules         = filter expose_rule imp_id_rules+    imp_user_rule_fvs = mapUnionVarSet user_rule_rhs_fvs imp_rules++    user_rule_rhs_fvs rule | isAutoRule rule = emptyVarSet+                           | otherwise       = ruleRhsFreeVars rule++    (trimmed_binds, local_bndrs, _, all_rules) = trim_binds binds++    keep_rule rule = ruleFreeVars rule `subVarSet` local_bndrs+        -- Remove rules that make no sense, because they mention a+        -- local binder (on LHS or RHS) that we have now discarded.+        -- (NB: ruleFreeVars only includes LocalIds)+        --+        -- LHS: we have already filtered out rules that mention internal Ids+        --     on LHS but that isn't enough because we might have by now+        --     discarded a binding with an external Id. (How?+        --     chooseExternalIds is a bit conservative.)+        --+        -- RHS: the auto rules that might mention a binder that has+        --      been discarded; see Note [Trimming auto-rules]++    expose_rule rule+        | omit_prags = False+        | otherwise  = all is_external_id (ruleLhsFreeIdsList rule)+                -- Don't expose a rule whose LHS mentions a locally-defined+                -- Id that is completely internal (i.e. not visible to an+                -- importing module).  NB: ruleLhsFreeIds only returns LocalIds.+                -- See Note [Which rules to expose]++    is_external_id id = case lookupVarEnv unfold_env id of+                          Just (name, _) -> isExternalName name+                          Nothing        -> False++    trim_binds :: [CoreBind]+               -> ( [CoreBind]   -- Trimmed bindings+                  , VarSet       -- Binders of those bindings+                  , VarSet       -- Free vars of those bindings + rhs of user rules+                                 -- (we don't bother to delete the binders)+                  , [CoreRule])  -- All rules, imported + from the bindings+    -- This function removes unnecessary bindings, and gathers up rules from+    -- the bindings we keep.  See Note [Trimming auto-rules]+    trim_binds []  -- Base case, start with imp_user_rule_fvs+       = ([], emptyVarSet, imp_user_rule_fvs, imp_rules)++    trim_binds (bind:binds)+       | any needed bndrs    -- Keep binding+       = ( bind : binds', bndr_set', needed_fvs', local_rules ++ rules )+       | otherwise           -- Discard binding altogether+       = stuff+       where+         stuff@(binds', bndr_set, needed_fvs, rules)+                       = trim_binds binds+         needed bndr   = isExportedId bndr || bndr `elemVarSet` needed_fvs++         bndrs         = bindersOf  bind+         rhss          = rhssOfBind bind+         bndr_set'     = bndr_set `extendVarSetList` bndrs++         needed_fvs'   = needed_fvs                                   `unionVarSet`+                         mapUnionVarSet idUnfoldingVars   bndrs       `unionVarSet`+                              -- Ignore type variables in the type of bndrs+                         mapUnionVarSet exprFreeVars      rhss        `unionVarSet`+                         mapUnionVarSet user_rule_rhs_fvs local_rules+            -- In needed_fvs', we don't bother to delete binders from the fv set++         local_rules  = [ rule+                        | id <- bndrs+                        , is_external_id id   -- Only collect rules for external Ids+                        , rule <- idCoreRules id+                        , expose_rule rule ]  -- and ones that can fire in a client++{-+************************************************************************+*                                                                      *+               tidyTopName+*                                                                      *+************************************************************************++This is where we set names to local/global based on whether they really are+externally visible (see comment at the top of this module).  If the name+was previously local, we have to give it a unique occurrence name if+we intend to externalise it.+-}++tidyTopName :: Module -> IORef NameCache -> Maybe Id -> TidyOccEnv+            -> Id -> IO (TidyOccEnv, Name)+tidyTopName mod nc_var maybe_ref occ_env id+  | global && internal = return (occ_env, localiseName name)++  | global && external = return (occ_env, name)+        -- Global names are assumed to have been allocated by the renamer,+        -- so they already have the "right" unique+        -- And it's a system-wide unique too++  -- Now we get to the real reason that all this is in the IO Monad:+  -- we have to update the name cache in a nice atomic fashion++  | local  && internal = do { new_local_name <- atomicModifyIORef' nc_var mk_new_local+                            ; return (occ_env', new_local_name) }+        -- Even local, internal names must get a unique occurrence, because+        -- if we do -split-objs we externalise the name later, in the code generator+        --+        -- Similarly, we must make sure it has a system-wide Unique, because+        -- the byte-code generator builds a system-wide Name->BCO symbol table++  | local  && external = do { new_external_name <- atomicModifyIORef' nc_var mk_new_external+                            ; return (occ_env', new_external_name) }++  | otherwise = panic "tidyTopName"+  where+    name        = idName id+    external    = isJust maybe_ref+    global      = isExternalName name+    local       = not global+    internal    = not external+    loc         = nameSrcSpan name++    old_occ     = nameOccName name+    new_occ | Just ref <- maybe_ref+            , ref /= id+            = mkOccName (occNameSpace old_occ) $+                   let+                       ref_str = occNameString (getOccName ref)+                       occ_str = occNameString old_occ+                   in+                   case occ_str of+                     '$':'w':_ -> occ_str+                        -- workers: the worker for a function already+                        -- includes the occname for its parent, so there's+                        -- no need to prepend the referrer.+                     _other | isSystemName name -> ref_str+                            | otherwise         -> ref_str ++ '_' : occ_str+                        -- If this name was system-generated, then don't bother+                        -- to retain its OccName, just use the referrer.  These+                        -- system-generated names will become "f1", "f2", etc. for+                        -- a referrer "f".+            | otherwise = old_occ++    (occ_env', occ') = tidyOccName occ_env new_occ++    mk_new_local nc = (nc { nsUniqs = us }, mkInternalName uniq occ' loc)+                    where+                      (uniq, us) = takeUniqFromSupply (nsUniqs nc)++    mk_new_external nc = allocateGlobalBinder nc mod occ' loc+        -- If we want to externalise a currently-local name, check+        -- whether we have already assigned a unique for it.+        -- If so, use it; if not, extend the table.+        -- All this is done by allcoateGlobalBinder.+        -- This is needed when *re*-compiling a module in GHCi; we must+        -- use the same name for externally-visible things as we did before.++{-+************************************************************************+*                                                                      *+\subsection{Step 2: top-level tidying}+*                                                                      *+************************************************************************+-}++-- TopTidyEnv: when tidying we need to know+--   * nc_var: The NameCache, containing a unique supply and any pre-ordained Names.+--        These may have arisen because the+--        renamer read in an interface file mentioning M.$wf, say,+--        and assigned it unique r77.  If, on this compilation, we've+--        invented an Id whose name is $wf (but with a different unique)+--        we want to rename it to have unique r77, so that we can do easy+--        comparisons with stuff from the interface file+--+--   * occ_env: The TidyOccEnv, which tells us which local occurrences+--     are 'used'+--+--   * subst_env: A Var->Var mapping that substitutes the new Var for the old++tidyTopBinds :: HscEnv+             -> Module+             -> UnfoldEnv+             -> TidyOccEnv+             -> CoreProgram+             -> IO (TidyEnv, CoreProgram)++tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds+  = do mkIntegerId <- lookupMkIntegerName dflags hsc_env+       integerSDataCon <- lookupIntegerSDataConName dflags hsc_env+       let cvt_integer = cvtLitInteger dflags mkIntegerId integerSDataCon+           result      = tidy cvt_integer init_env binds+       seqBinds (snd result) `seq` return result+       -- This seqBinds avoids a spike in space usage (see #13564)+  where+    dflags = hsc_dflags hsc_env++    init_env = (init_occ_env, emptyVarEnv)++    tidy _           env []     = (env, [])+    tidy cvt_integer env (b:bs)+        = let (env1, b')  = tidyTopBind dflags this_mod+                                        cvt_integer unfold_env env b+              (env2, bs') = tidy cvt_integer env1 bs+          in  (env2, b':bs')++------------------------+tidyTopBind  :: DynFlags+             -> Module+             -> (Integer -> CoreExpr)+             -> UnfoldEnv+             -> TidyEnv+             -> CoreBind+             -> (TidyEnv, CoreBind)++tidyTopBind dflags this_mod cvt_integer unfold_env+            (occ_env,subst1) (NonRec bndr rhs)+  = (tidy_env2,  NonRec bndr' rhs')+  where+    Just (name',show_unfold) = lookupVarEnv unfold_env bndr+    caf_info      = hasCafRefs dflags this_mod (subst1, cvt_integer)+                               (idArity bndr) rhs+    (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 caf_info name'+                                (bndr, rhs)+    subst2        = extendVarEnv subst1 bndr bndr'+    tidy_env2     = (occ_env, subst2)++tidyTopBind dflags this_mod cvt_integer unfold_env+            (occ_env, subst1) (Rec prs)+  = (tidy_env2, Rec prs')+  where+    prs' = [ tidyTopPair dflags show_unfold tidy_env2 caf_info name' (id,rhs)+           | (id,rhs) <- prs,+             let (name',show_unfold) =+                    expectJust "tidyTopBind" $ lookupVarEnv unfold_env id+           ]++    subst2    = extendVarEnvList subst1 (bndrs `zip` map fst prs')+    tidy_env2 = (occ_env, subst2)++    bndrs = map fst prs++        -- the CafInfo for a recursive group says whether *any* rhs in+        -- the group may refer indirectly to a CAF (because then, they all do).+    caf_info+        | or [ mayHaveCafRefs (hasCafRefs dflags this_mod+                                          (subst1, cvt_integer)+                                          (idArity bndr) rhs)+             | (bndr,rhs) <- prs ] = MayHaveCafRefs+        | otherwise                = NoCafRefs++-----------------------------------------------------------+tidyTopPair :: DynFlags+            -> Bool  -- show unfolding+            -> TidyEnv  -- The TidyEnv is used to tidy the IdInfo+                        -- It is knot-tied: don't look at it!+            -> CafInfo+            -> Name             -- New name+            -> (Id, CoreExpr)   -- Binder and RHS before tidying+            -> (Id, CoreExpr)+        -- This function is the heart of Step 2+        -- The rec_tidy_env is the one to use for the IdInfo+        -- It's necessary because when we are dealing with a recursive+        -- group, a variable late in the group might be mentioned+        -- in the IdInfo of one early in the group++tidyTopPair dflags show_unfold rhs_tidy_env caf_info name' (bndr, rhs)+  = (bndr1, rhs1)+  where+    bndr1    = mkGlobalId details name' ty' idinfo'+    details  = idDetails bndr   -- Preserve the IdDetails+    ty'      = tidyTopType (idType bndr)+    rhs1     = tidyExpr rhs_tidy_env rhs+    idinfo'  = tidyTopIdInfo dflags rhs_tidy_env name' rhs rhs1 (idInfo bndr)+                             show_unfold caf_info++-- tidyTopIdInfo creates the final IdInfo for top-level+-- binders.  There are two delicate pieces:+--+--  * Arity.  After CoreTidy, this arity must not change any more.+--      Indeed, CorePrep must eta expand where necessary to make+--      the manifest arity equal to the claimed arity.+--+--  * CAF info.  This must also remain valid through to code generation.+--      We add the info here so that it propagates to all+--      occurrences of the binders in RHSs, and hence to occurrences in+--      unfoldings, which are inside Ids imported by GHCi. Ditto RULES.+--      CoreToStg makes use of this when constructing SRTs.+tidyTopIdInfo :: DynFlags -> TidyEnv -> Name -> CoreExpr -> CoreExpr+              -> IdInfo -> Bool -> CafInfo -> IdInfo+tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info+  | not is_external     -- For internal Ids (not externally visible)+  = vanillaIdInfo       -- we only need enough info for code generation+                        -- Arity and strictness info are enough;+                        --      c.f. CoreTidy.tidyLetBndr+        `setCafInfo`        caf_info+        `setArityInfo`      arity+        `setStrictnessInfo` final_sig++  | otherwise           -- Externally-visible Ids get the whole lot+  = vanillaIdInfo+        `setCafInfo`           caf_info+        `setArityInfo`         arity+        `setStrictnessInfo`    final_sig+        `setOccInfo`           robust_occ_info+        `setInlinePragInfo`    (inlinePragInfo idinfo)+        `setUnfoldingInfo`     unfold_info+                -- NB: we throw away the Rules+                -- They have already been extracted by findExternalRules+  where+    is_external = isExternalName name++    --------- OccInfo ------------+    robust_occ_info = zapFragileOcc (occInfo idinfo)+    -- It's important to keep loop-breaker information+    -- when we are doing -fexpose-all-unfoldings++    --------- Strictness ------------+    mb_bot_str = exprBotStrictness_maybe orig_rhs++    sig = strictnessInfo idinfo+    final_sig | not $ isTopSig sig+              = WARN( _bottom_hidden sig , ppr name ) sig+              -- try a cheap-and-cheerful bottom analyser+              | Just (_, nsig) <- mb_bot_str = nsig+              | otherwise                    = sig++    _bottom_hidden id_sig = case mb_bot_str of+                                  Nothing         -> False+                                  Just (arity, _) -> not (appIsBottom id_sig arity)++    --------- Unfolding ------------+    unf_info = unfoldingInfo idinfo+    unfold_info | show_unfold = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs+                | otherwise   = noUnfolding+    unf_from_rhs = mkTopUnfolding dflags is_bot tidy_rhs+    is_bot = isBottomingSig final_sig+    -- NB: do *not* expose the worker if show_unfold is off,+    --     because that means this thing is a loop breaker or+    --     marked NOINLINE or something like that+    -- This is important: if you expose the worker for a loop-breaker+    -- then you can make the simplifier go into an infinite loop, because+    -- in effect the unfolding is exposed.  See Trac #1709+    --+    -- You might think that if show_unfold is False, then the thing should+    -- not be w/w'd in the first place.  But a legitimate reason is this:+    --    the function returns bottom+    -- In this case, show_unfold will be false (we don't expose unfoldings+    -- for bottoming functions), but we might still have a worker/wrapper+    -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.hs++    --------- Arity ------------+    -- Usually the Id will have an accurate arity on it, because+    -- the simplifier has just run, but not always.+    -- One case I found was when the last thing the simplifier+    -- did was to let-bind a non-atomic argument and then float+    -- it to the top level. So it seems more robust just to+    -- fix it here.+    arity = exprArity orig_rhs++{-+************************************************************************+*                                                                      *+           Figuring out CafInfo for an expression+*                                                                      *+************************************************************************++hasCafRefs decides whether a top-level closure can point into the dynamic heap.+We mark such things as `MayHaveCafRefs' because this information is+used to decide whether a particular closure needs to be referenced+in an SRT or not.++There are two reasons for setting MayHaveCafRefs:+        a) The RHS is a CAF: a top-level updatable thunk.+        b) The RHS refers to something that MayHaveCafRefs++Possible improvement: In an effort to keep the number of CAFs (and+hence the size of the SRTs) down, we could also look at the expression and+decide whether it requires a small bounded amount of heap, so we can ignore+it as a CAF.  In these cases however, we would need to use an additional+CAF list to keep track of non-collectable CAFs.++Note [Disgusting computation of CafRefs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We compute hasCafRefs here, because IdInfo is supposed to be finalised+after TidyPgm.  But CorePrep does some transformations that affect CAF-hood.+So we have to *predict* the result here, which is revolting.++In particular CorePrep expands Integer literals.  So in the prediction code+here we resort to applying the same expansion (cvt_integer). Ugh!+-}++type CafRefEnv = (VarEnv Id, Integer -> CoreExpr)+  -- The env finds the Caf-ness of the Id+  -- The Integer -> CoreExpr is the desugaring function for Integer literals+  -- See Note [Disgusting computation of CafRefs]++hasCafRefs :: DynFlags -> Module+           -> CafRefEnv -> Arity -> CoreExpr+           -> CafInfo+hasCafRefs dflags this_mod p@(_,cvt_integer) arity expr+  | is_caf || mentions_cafs = MayHaveCafRefs+  | otherwise               = NoCafRefs+ where+  mentions_cafs   = cafRefsE p expr+  is_dynamic_name = isDllName dflags this_mod+  is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name cvt_integer expr)++  -- NB. we pass in the arity of the expression, which is expected+  -- to be calculated by exprArity.  This is because exprArity+  -- knows how much eta expansion is going to be done by+  -- CorePrep later on, and we don't want to duplicate that+  -- knowledge in rhsIsStatic below.++cafRefsE :: CafRefEnv -> Expr a -> Bool+cafRefsE p (Var id)            = cafRefsV p id+cafRefsE p (Lit lit)           = cafRefsL p lit+cafRefsE p (App f a)           = cafRefsE p f || cafRefsE p a+cafRefsE p (Lam _ e)           = cafRefsE p e+cafRefsE p (Let b e)           = cafRefsEs p (rhssOfBind b) || cafRefsE p e+cafRefsE p (Case e _ _ alts)   = cafRefsE p e || cafRefsEs p (rhssOfAlts alts)+cafRefsE p (Tick _n e)         = cafRefsE p e+cafRefsE p (Cast e _co)        = cafRefsE p e+cafRefsE _ (Type _)            = False+cafRefsE _ (Coercion _)        = False++cafRefsEs :: CafRefEnv -> [Expr a] -> Bool+cafRefsEs _ []     = False+cafRefsEs p (e:es) = cafRefsE p e || cafRefsEs p es++cafRefsL :: CafRefEnv -> Literal -> Bool+-- Don't forget that mk_integer id might have Caf refs!+-- We first need to convert the Integer into its final form, to+-- see whether mkInteger is used.+cafRefsL p@(_, cvt_integer) (LitInteger i _) = cafRefsE p (cvt_integer i)+cafRefsL _                  _                = False++cafRefsV :: CafRefEnv -> Id -> Bool+cafRefsV (subst, _) id+  | not (isLocalId id)                = mayHaveCafRefs (idCafInfo id)+  | Just id' <- lookupVarEnv subst id = mayHaveCafRefs (idCafInfo id')+  | otherwise                         = False+++{-+************************************************************************+*                                                                      *+                  Old, dead, type-trimming code+*                                                                      *+************************************************************************++We used to try to "trim off" the constructors of data types that are+not exported, to reduce the size of interface files, at least without+-O.  But that is not always possible: see the old Note [When we can't+trim types] below for exceptions.++Then (Trac #7445) I realised that the TH problem arises for any data type+that we have deriving( Data ), because we can invoke+   Language.Haskell.TH.Quote.dataToExpQ+to get a TH Exp representation of a value built from that data type.+You don't even need {-# LANGUAGE TemplateHaskell #-}.++At this point I give up. The pain of trimming constructors just+doesn't seem worth the gain.  So I've dumped all the code, and am just+leaving it here at the end of the module in case something like this+is ever resurrected.+++Note [When we can't trim types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The basic idea of type trimming is to export algebraic data types+abstractly (without their data constructors) when compiling without+-O, unless of course they are explicitly exported by the user.++We always export synonyms, because they can be mentioned in the type+of an exported Id.  We could do a full dependency analysis starting+from the explicit exports, but that's quite painful, and not done for+now.++But there are some times we can't do that, indicated by the 'no_trim_types' flag.++First, Template Haskell.  Consider (Trac #2386) this+        module M(T, makeOne) where+          data T = Yay String+          makeOne = [| Yay "Yep" |]+Notice that T is exported abstractly, but makeOne effectively exports it too!+A module that splices in $(makeOne) will then look for a declaration of Yay,+so it'd better be there.  Hence, brutally but simply, we switch off type+constructor trimming if TH is enabled in this module.++Second, data kinds.  Consider (Trac #5912)+     {-# LANGUAGE DataKinds #-}+     module M() where+     data UnaryTypeC a = UnaryDataC a+     type Bug = 'UnaryDataC+We always export synonyms, so Bug is exposed, and that means that+UnaryTypeC must be too, even though it's not explicitly exported.  In+effect, DataKinds means that we'd need to do a full dependency analysis+to see what data constructors are mentioned.  But we don't do that yet.++In these two cases we just switch off type trimming altogether.++mustExposeTyCon :: Bool         -- Type-trimming flag+                -> NameSet      -- Exports+                -> TyCon        -- The tycon+                -> Bool         -- Can its rep be hidden?+-- We are compiling without -O, and thus trying to write as little as+-- possible into the interface file.  But we must expose the details of+-- any data types whose constructors or fields are exported+mustExposeTyCon no_trim_types exports tc+  | no_trim_types               -- See Note [When we can't trim types]+  = True++  | not (isAlgTyCon tc)         -- Always expose synonyms (otherwise we'd have to+                                -- figure out whether it was mentioned in the type+                                -- of any other exported thing)+  = True++  | isEnumerationTyCon tc       -- For an enumeration, exposing the constructors+  = True                        -- won't lead to the need for further exposure++  | isFamilyTyCon tc            -- Open type family+  = True++  -- Below here we just have data/newtype decls or family instances++  | null data_cons              -- Ditto if there are no data constructors+  = True                        -- (NB: empty data types do not count as enumerations+                                -- see Note [Enumeration types] in TyCon++  | any exported_con data_cons  -- Expose rep if any datacon or field is exported+  = True++  | isNewTyCon tc && isFFITy (snd (newTyConRhs tc))+  = True   -- Expose the rep for newtypes if the rep is an FFI type.+           -- For a very annoying reason.  'Foreign import' is meant to+           -- be able to look through newtypes transparently, but it+           -- can only do that if it can "see" the newtype representation++  | otherwise+  = False+  where+    data_cons = tyConDataCons tc+    exported_con con = any (`elemNameSet` exports)+                           (dataConName con : dataConFieldLabels con)+-}
+ nativeGen/AsmCodeGen.hs view
@@ -0,0 +1,1227 @@+-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow 1993-2004+--+-- This is the top-level module in the native code generator.+--+-- -----------------------------------------------------------------------------++{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, UnboxedTuples #-}++module AsmCodeGen (+                    -- * Module entry point+                    nativeCodeGen++                    -- * Test-only exports: see trac #12744+                    -- used by testGraphNoSpills, which needs to access+                    -- the register allocator intermediate data structures+                    -- cmmNativeGen emits+                  , cmmNativeGen+                  , NcgImpl(..)+                  , x86NcgImpl+                  ) where++#include "HsVersions.h"+#include "nativeGen/NCG.h"+++import qualified X86.CodeGen+import qualified X86.Regs+import qualified X86.Instr+import qualified X86.Ppr++import qualified SPARC.CodeGen+import qualified SPARC.Regs+import qualified SPARC.Instr+import qualified SPARC.Ppr+import qualified SPARC.ShortcutJump+import qualified SPARC.CodeGen.Expand++import qualified PPC.CodeGen+import qualified PPC.Regs+import qualified PPC.RegInfo+import qualified PPC.Instr+import qualified PPC.Ppr++import RegAlloc.Liveness+import qualified RegAlloc.Linear.Main           as Linear++import qualified GraphColor                     as Color+import qualified RegAlloc.Graph.Main            as Color+import qualified RegAlloc.Graph.Stats           as Color+import qualified RegAlloc.Graph.TrivColorable   as Color++import TargetReg+import Platform+import Config+import Instruction+import PIC+import Reg+import NCGMonad+import Dwarf+import Debug++import BlockId+import CgUtils          ( fixStgRegisters )+import Cmm+import CmmUtils+import Hoopl+import CmmOpt           ( cmmMachOpFold )+import PprCmm+import CLabel++import UniqFM+import UniqSupply+import DynFlags+import Util+import Unique++import BasicTypes       ( Alignment )+import Digraph+import qualified Pretty+import BufWrite+import Outputable+import FastString+import UniqSet+import ErrUtils+import Module+import Stream (Stream)+import qualified Stream++-- DEBUGGING ONLY+--import OrdList++import Data.List+import Data.Maybe+import Data.Ord         ( comparing )+import Control.Exception+import Control.Monad+import System.IO++{-+The native-code generator has machine-independent and+machine-dependent modules.++This module ("AsmCodeGen") is the top-level machine-independent+module.  Before entering machine-dependent land, we do some+machine-independent optimisations (defined below) on the+'CmmStmts's.++We convert to the machine-specific 'Instr' datatype with+'cmmCodeGen', assuming an infinite supply of registers.  We then use+a machine-independent register allocator ('regAlloc') to rejoin+reality.  Obviously, 'regAlloc' has machine-specific helper+functions (see about "RegAllocInfo" below).++Finally, we order the basic blocks of the function so as to minimise+the number of jumps between blocks, by utilising fallthrough wherever+possible.++The machine-dependent bits break down as follows:++  * ["MachRegs"]  Everything about the target platform's machine+    registers (and immediate operands, and addresses, which tend to+    intermingle/interact with registers).++  * ["MachInstrs"]  Includes the 'Instr' datatype (possibly should+    have a module of its own), plus a miscellany of other things+    (e.g., 'targetDoubleSize', 'smStablePtrTable', ...)++  * ["MachCodeGen"]  is where 'Cmm' stuff turns into+    machine instructions.++  * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really+    a 'SDoc').++  * ["RegAllocInfo"] In the register allocator, we manipulate+    'MRegsState's, which are 'BitSet's, one bit per machine register.+    When we want to say something about a specific machine register+    (e.g., ``it gets clobbered by this instruction''), we set/unset+    its bit.  Obviously, we do this 'BitSet' thing for efficiency+    reasons.++    The 'RegAllocInfo' module collects together the machine-specific+    info needed to do register allocation.++   * ["RegisterAlloc"] The (machine-independent) register allocator.+-}++-- -----------------------------------------------------------------------------+-- Top-level of the native codegen++data NcgImpl statics instr jumpDest = NcgImpl {+    cmmTopCodeGen             :: RawCmmDecl -> NatM [NatCmmDecl statics instr],+    generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr),+    getJumpDestBlockId        :: jumpDest -> Maybe BlockId,+    canShortcut               :: instr -> Maybe jumpDest,+    shortcutStatics           :: (BlockId -> Maybe jumpDest) -> statics -> statics,+    shortcutJump              :: (BlockId -> Maybe jumpDest) -> instr -> instr,+    pprNatCmmDecl             :: NatCmmDecl statics instr -> SDoc,+    maxSpillSlots             :: Int,+    allocatableRegs           :: [RealReg],+    ncg_x86fp_kludge          :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],+    ncgExpandTop              :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],+    ncgAllocMoreStack         :: Int -> NatCmmDecl statics instr -> UniqSM (NatCmmDecl statics instr),+    ncgMakeFarBranches        :: LabelMap CmmStatics+                              -> [NatBasicBlock instr] -> [NatBasicBlock instr],+    extractUnwindPoints       :: [instr] -> [UnwindPoint]+    -- ^ given the instruction sequence of a block, produce a list of+    -- the block's 'UnwindPoint's+    -- See Note [What is this unwinding business?] in Debug+    -- and Note [Unwinding information in the NCG] in this module.+    }++--------------------+nativeCodeGen :: DynFlags -> Module -> ModLocation -> Handle -> UniqSupply+              -> Stream IO RawCmmGroup ()+              -> IO UniqSupply+nativeCodeGen dflags this_mod modLoc h us cmms+ = let platform = targetPlatform dflags+       nCG' :: (Outputable statics, Outputable instr, Instruction instr)+            => NcgImpl statics instr jumpDest -> IO UniqSupply+       nCG' ncgImpl = nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms+   in case platformArch platform of+      ArchX86       -> nCG' (x86NcgImpl    dflags)+      ArchX86_64    -> nCG' (x86_64NcgImpl dflags)+      ArchPPC       -> nCG' (ppcNcgImpl    dflags)+      ArchSPARC     -> nCG' (sparcNcgImpl  dflags)+      ArchSPARC64   -> panic "nativeCodeGen: No NCG for SPARC64"+      ArchARM {}    -> panic "nativeCodeGen: No NCG for ARM"+      ArchARM64     -> panic "nativeCodeGen: No NCG for ARM64"+      ArchPPC_64 _  -> nCG' (ppcNcgImpl    dflags)+      ArchAlpha     -> panic "nativeCodeGen: No NCG for Alpha"+      ArchMipseb    -> panic "nativeCodeGen: No NCG for mipseb"+      ArchMipsel    -> panic "nativeCodeGen: No NCG for mipsel"+      ArchUnknown   -> panic "nativeCodeGen: No NCG for unknown arch"+      ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript"++x86NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics) X86.Instr.Instr X86.Instr.JumpDest+x86NcgImpl dflags+ = (x86_64NcgImpl dflags) { ncg_x86fp_kludge = map x86fp_kludge }++x86_64NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics) X86.Instr.Instr X86.Instr.JumpDest+x86_64NcgImpl dflags+ = NcgImpl {+        cmmTopCodeGen             = X86.CodeGen.cmmTopCodeGen+       ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr dflags+       ,getJumpDestBlockId        = X86.Instr.getJumpDestBlockId+       ,canShortcut               = X86.Instr.canShortcut+       ,shortcutStatics           = X86.Instr.shortcutStatics+       ,shortcutJump              = X86.Instr.shortcutJump+       ,pprNatCmmDecl             = X86.Ppr.pprNatCmmDecl+       ,maxSpillSlots             = X86.Instr.maxSpillSlots dflags+       ,allocatableRegs           = X86.Regs.allocatableRegs platform+       ,ncg_x86fp_kludge          = id+       ,ncgAllocMoreStack         = X86.Instr.allocMoreStack platform+       ,ncgExpandTop              = id+       ,ncgMakeFarBranches        = const id+       ,extractUnwindPoints       = X86.CodeGen.extractUnwindPoints+   }+    where platform = targetPlatform dflags++ppcNcgImpl :: DynFlags -> NcgImpl CmmStatics PPC.Instr.Instr PPC.RegInfo.JumpDest+ppcNcgImpl dflags+ = NcgImpl {+        cmmTopCodeGen             = PPC.CodeGen.cmmTopCodeGen+       ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr dflags+       ,getJumpDestBlockId        = PPC.RegInfo.getJumpDestBlockId+       ,canShortcut               = PPC.RegInfo.canShortcut+       ,shortcutStatics           = PPC.RegInfo.shortcutStatics+       ,shortcutJump              = PPC.RegInfo.shortcutJump+       ,pprNatCmmDecl             = PPC.Ppr.pprNatCmmDecl+       ,maxSpillSlots             = PPC.Instr.maxSpillSlots dflags+       ,allocatableRegs           = PPC.Regs.allocatableRegs platform+       ,ncg_x86fp_kludge          = id+       ,ncgAllocMoreStack         = PPC.Instr.allocMoreStack platform+       ,ncgExpandTop              = id+       ,ncgMakeFarBranches        = PPC.Instr.makeFarBranches+       ,extractUnwindPoints       = const []+   }+    where platform = targetPlatform dflags++sparcNcgImpl :: DynFlags -> NcgImpl CmmStatics SPARC.Instr.Instr SPARC.ShortcutJump.JumpDest+sparcNcgImpl dflags+ = NcgImpl {+        cmmTopCodeGen             = SPARC.CodeGen.cmmTopCodeGen+       ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr dflags+       ,getJumpDestBlockId        = SPARC.ShortcutJump.getJumpDestBlockId+       ,canShortcut               = SPARC.ShortcutJump.canShortcut+       ,shortcutStatics           = SPARC.ShortcutJump.shortcutStatics+       ,shortcutJump              = SPARC.ShortcutJump.shortcutJump+       ,pprNatCmmDecl             = SPARC.Ppr.pprNatCmmDecl+       ,maxSpillSlots             = SPARC.Instr.maxSpillSlots dflags+       ,allocatableRegs           = SPARC.Regs.allocatableRegs+       ,ncg_x86fp_kludge          = id+       ,ncgAllocMoreStack         = noAllocMoreStack+       ,ncgExpandTop              = map SPARC.CodeGen.Expand.expandTop+       ,ncgMakeFarBranches        = const id+       ,extractUnwindPoints       = const []+   }++--+-- Allocating more stack space for spilling is currently only+-- supported for the linear register allocator on x86/x86_64, the rest+-- default to the panic below.  To support allocating extra stack on+-- more platforms provide a definition of ncgAllocMoreStack.+--+noAllocMoreStack :: Int -> NatCmmDecl statics instr -> UniqSM (NatCmmDecl statics instr)+noAllocMoreStack amount _+  = panic $   "Register allocator: out of stack slots (need " ++ show amount ++ ")\n"+        ++  "   If you are trying to compile SHA1.hs from the crypto library then this\n"+        ++  "   is a known limitation in the linear allocator.\n"+        ++  "\n"+        ++  "   Try enabling the graph colouring allocator with -fregs-graph instead."+        ++  "   You can still file a bug report if you like.\n"+++-- | Data accumulated during code generation. Mostly about statistics,+-- but also collects debug data for DWARF generation.+data NativeGenAcc statics instr+  = NGS { ngs_imports     :: ![[CLabel]]+        , ngs_natives     :: ![[NatCmmDecl statics instr]]+             -- ^ Native code generated, for statistics. This might+             -- hold a lot of data, so it is important to clear this+             -- field as early as possible if it isn't actually+             -- required.+        , ngs_colorStats  :: ![[Color.RegAllocStats statics instr]]+        , ngs_linearStats :: ![[Linear.RegAllocStats]]+        , ngs_labels      :: ![Label]+        , ngs_debug       :: ![DebugBlock]+        , ngs_dwarfFiles  :: !DwarfFiles+        , ngs_unwinds     :: !(LabelMap [UnwindPoint])+             -- ^ see Note [Unwinding information in the NCG]+             -- and Note [What is this unwinding business?] in Debug.+        }++{-+Note [Unwinding information in the NCG]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Unwind information is a type of metadata which allows a debugging tool+to reconstruct the values of machine registers at the time a procedure was+entered. For the most part, the production of unwind information is handled by+the Cmm stage, where it is represented by CmmUnwind nodes.++Unfortunately, the Cmm stage doesn't know everything necessary to produce+accurate unwinding information. For instance, the x86-64 calling convention+requires that the stack pointer be aligned to 16 bytes, which in turn means that+GHC must sometimes add padding to $sp prior to performing a foreign call. When+this happens unwind information must be updated accordingly.+For this reason, we make the NCG backends responsible for producing+unwinding tables (with the extractUnwindPoints function in NcgImpl).++We accumulate the produced unwind tables over CmmGroups in the ngs_unwinds+field of NativeGenAcc. This is a label map which contains an entry for each+procedure, containing a list of unwinding points (e.g. a label and an associated+unwinding table).++See also Note [What is this unwinding business?] in Debug.+-}++nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr)+               => DynFlags+               -> Module -> ModLocation+               -> NcgImpl statics instr jumpDest+               -> Handle+               -> UniqSupply+               -> Stream IO RawCmmGroup ()+               -> IO UniqSupply+nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms+ = do+        -- BufHandle is a performance hack.  We could hide it inside+        -- Pretty if it weren't for the fact that we do lots of little+        -- printDocs here (in order to do codegen in constant space).+        bufh <- newBufHandle h+        let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty+        (ngs, us') <- cmmNativeGenStream dflags this_mod modLoc ncgImpl bufh us+                                         cmms ngs0+        finishNativeGen dflags modLoc bufh us' ngs++finishNativeGen :: Instruction instr+                => DynFlags+                -> ModLocation+                -> BufHandle+                -> UniqSupply+                -> NativeGenAcc statics instr+                -> IO UniqSupply+finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs+ = do+        -- Write debug data and finish+        let emitDw = debugLevel dflags > 0 && not (gopt Opt_SplitObjs dflags)+        us' <- if not emitDw then return us else do+          (dwarf, us') <- dwarfGen dflags modLoc us (ngs_debug ngs)+          emitNativeCode dflags bufh dwarf+          return us'+        bFlush bufh++        -- dump global NCG stats for graph coloring allocator+        let stats = concat (ngs_colorStats ngs)+        when (not (null stats)) $ do++          -- build the global register conflict graph+          let graphGlobal+                  = foldl Color.union Color.initGraph+                  $ [ Color.raGraph stat+                          | stat@Color.RegAllocStatsStart{} <- stats]++          dump_stats (Color.pprStats stats graphGlobal)++          let platform = targetPlatform dflags+          dumpIfSet_dyn dflags+                  Opt_D_dump_asm_conflicts "Register conflict graph"+                  $ Color.dotGraph+                          (targetRegDotColor platform)+                          (Color.trivColorable platform+                                  (targetVirtualRegSqueeze platform)+                                  (targetRealRegSqueeze platform))+                  $ graphGlobal+++        -- dump global NCG stats for linear allocator+        let linearStats = concat (ngs_linearStats ngs)+        when (not (null linearStats)) $+          dump_stats (Linear.pprStats (concat (ngs_natives ngs)) linearStats)++        -- write out the imports+        printSDocLn Pretty.LeftMode dflags h (mkCodeStyle AsmStyle)+                $ makeImportsDoc dflags (concat (ngs_imports ngs))+        return us'+  where+    dump_stats = dumpSDoc dflags alwaysQualify Opt_D_dump_asm_stats "NCG stats"++cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr)+              => DynFlags+              -> Module -> ModLocation+              -> NcgImpl statics instr jumpDest+              -> BufHandle+              -> UniqSupply+              -> Stream IO RawCmmGroup ()+              -> NativeGenAcc statics instr+              -> IO (NativeGenAcc statics instr, UniqSupply)++cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs+ = do r <- Stream.runStream cmm_stream+      case r of+        Left () ->+          return (ngs { ngs_imports = reverse $ ngs_imports ngs+                      , ngs_natives = reverse $ ngs_natives ngs+                      , ngs_colorStats = reverse $ ngs_colorStats ngs+                      , ngs_linearStats = reverse $ ngs_linearStats ngs+                      },+                  us)+        Right (cmms, cmm_stream') -> do++          -- Generate debug information+          let debugFlag = debugLevel dflags > 0+              !ndbgs | debugFlag = cmmDebugGen modLoc cmms+                     | otherwise = []+              dbgMap = debugToMap ndbgs++          -- Insert split marker, generate native code+          let splitObjs = gopt Opt_SplitObjs dflags+              split_marker = CmmProc mapEmpty mkSplitMarkerLabel [] $+                             ofBlockList (panic "split_marker_entry") []+              cmms' | splitObjs  = split_marker : cmms+                    | otherwise  = cmms+          (ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h+                                             dbgMap us cmms' ngs 0++          -- Link native code information into debug blocks+          -- See Note [What is this unwinding business?] in Debug.+          let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs+          dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos"+            (vcat $ map ppr ldbgs)++          -- Emit & clear DWARF information when generating split+          -- object files, as we need it to land in the same object file+          -- When using split sections, note that we do not split the debug+          -- info but emit all the info at once in finishNativeGen.+          (ngs'', us'') <-+            if debugFlag && splitObjs+            then do (dwarf, us'') <- dwarfGen dflags modLoc us ldbgs+                    emitNativeCode dflags h dwarf+                    return (ngs' { ngs_debug = []+                                 , ngs_dwarfFiles = emptyUFM+                                 , ngs_labels = [] },+                            us'')+            else return (ngs' { ngs_debug  = ngs_debug ngs' ++ ldbgs+                              , ngs_labels = [] },+                         us')++          cmmNativeGenStream dflags this_mod modLoc ncgImpl h us''+              cmm_stream' ngs''++-- | Do native code generation on all these cmms.+--+cmmNativeGens :: forall statics instr jumpDest.+                 (Outputable statics, Outputable instr, Instruction instr)+              => DynFlags+              -> Module -> ModLocation+              -> NcgImpl statics instr jumpDest+              -> BufHandle+              -> LabelMap DebugBlock+              -> UniqSupply+              -> [RawCmmDecl]+              -> NativeGenAcc statics instr+              -> Int+              -> IO (NativeGenAcc statics instr, UniqSupply)++cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap = go+  where+    go :: UniqSupply -> [RawCmmDecl]+       -> NativeGenAcc statics instr -> Int+       -> IO (NativeGenAcc statics instr, UniqSupply)++    go us [] ngs !_ =+        return (ngs, us)++    go us (cmm : cmms) ngs count = do+        let fileIds = ngs_dwarfFiles ngs+        (us', fileIds', native, imports, colorStats, linearStats, unwinds)+          <- {-# SCC "cmmNativeGen" #-}+             cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap+                          cmm count++        -- Generate .file directives for every new file that has been+        -- used. Note that it is important that we generate these in+        -- ascending order, as Clang's 3.6 assembler complains.+        let newFileIds = sortBy (comparing snd) $+                         nonDetEltsUFM $ fileIds' `minusUFM` fileIds+            -- See Note [Unique Determinism and code generation]+            pprDecl (f,n) = text "\t.file " <> ppr n <+>+                            doubleQuotes (ftext f)++        emitNativeCode dflags h $ vcat $+          map pprDecl newFileIds +++          map (pprNatCmmDecl ncgImpl) native++        -- force evaluation all this stuff to avoid space leaks+        {-# SCC "seqString" #-} evaluate $ seqString (showSDoc dflags $ vcat $ map ppr imports)++        let !labels' = if debugLevel dflags > 0+                       then cmmDebugLabels isMetaInstr native else []+            !natives' = if dopt Opt_D_dump_asm_stats dflags+                        then native : ngs_natives ngs else []++            mCon = maybe id (:)+            ngs' = ngs{ ngs_imports     = imports : ngs_imports ngs+                      , ngs_natives     = natives'+                      , ngs_colorStats  = colorStats `mCon` ngs_colorStats ngs+                      , ngs_linearStats = linearStats `mCon` ngs_linearStats ngs+                      , ngs_labels      = ngs_labels ngs ++ labels'+                      , ngs_dwarfFiles  = fileIds'+                      , ngs_unwinds     = ngs_unwinds ngs `mapUnion` unwinds+                      }+        go us' cmms ngs' (count + 1)++    seqString []            = ()+    seqString (x:xs)        = x `seq` seqString xs+++emitNativeCode :: DynFlags -> BufHandle -> SDoc -> IO ()+emitNativeCode dflags h sdoc = do++        {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc dflags h+                                      (mkCodeStyle AsmStyle) sdoc++        -- dump native code+        dumpIfSet_dyn dflags+                Opt_D_dump_asm "Asm code"+                sdoc++-- | Complete native code generation phase for a single top-level chunk of Cmm.+--      Dumping the output of each stage along the way.+--      Global conflict graph and NGC stats+cmmNativeGen+        :: (Outputable statics, Outputable instr, Instruction instr)+    => DynFlags+    -> Module -> ModLocation+    -> NcgImpl statics instr jumpDest+        -> UniqSupply+        -> DwarfFiles+        -> LabelMap DebugBlock+        -> RawCmmDecl                                   -- ^ the cmm to generate code for+        -> Int                                          -- ^ sequence number of this top thing+        -> IO   ( UniqSupply+                , DwarfFiles+                , [NatCmmDecl statics instr]                -- native code+                , [CLabel]                                  -- things imported by this cmm+                , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator+                , Maybe [Linear.RegAllocStats]              -- stats for the linear register allocators+                , LabelMap [UnwindPoint]                    -- unwinding information for blocks+                )++cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count+ = do+        let platform = targetPlatform dflags++        -- rewrite assignments to global regs+        let fixed_cmm =+                {-# SCC "fixStgRegisters" #-}+                fixStgRegisters dflags cmm++        -- cmm to cmm optimisations+        let (opt_cmm, imports) =+                {-# SCC "cmmToCmm" #-}+                cmmToCmm dflags this_mod fixed_cmm++        dumpIfSet_dyn dflags+                Opt_D_dump_opt_cmm "Optimised Cmm"+                (pprCmmGroup [opt_cmm])++        -- generate native code from cmm+        let ((native, lastMinuteImports, fileIds'), usGen) =+                {-# SCC "genMachCode" #-}+                initUs us $ genMachCode dflags this_mod modLoc+                                        (cmmTopCodeGen ncgImpl)+                                        fileIds dbgMap opt_cmm++        dumpIfSet_dyn dflags+                Opt_D_dump_asm_native "Native code"+                (vcat $ map (pprNatCmmDecl ncgImpl) native)++        -- tag instructions with register liveness information+        let (withLiveness, usLive) =+                {-# SCC "regLiveness" #-}+                initUs usGen+                        $ mapM (regLiveness platform)+                        $ map natCmmTopToLive native++        dumpIfSet_dyn dflags+                Opt_D_dump_asm_liveness "Liveness annotations added"+                (vcat $ map ppr withLiveness)++        -- allocate registers+        (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <-+         if ( gopt Opt_RegsGraph dflags+           || gopt Opt_RegsIterative dflags )+          then do+                -- the regs usable for allocation+                let (alloc_regs :: UniqFM (UniqSet RealReg))+                        = foldr (\r -> plusUFM_C unionUniqSets+                                        $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r))+                                emptyUFM+                        $ allocatableRegs ncgImpl++                -- do the graph coloring register allocation+                let ((alloced, regAllocStats), usAlloc)+                        = {-# SCC "RegAlloc-color" #-}+                          initUs usLive+                          $ Color.regAlloc+                                dflags+                                alloc_regs+                                (mkUniqSet [0 .. maxSpillSlots ncgImpl])+                                withLiveness++                -- dump out what happened during register allocation+                dumpIfSet_dyn dflags+                        Opt_D_dump_asm_regalloc "Registers allocated"+                        (vcat $ map (pprNatCmmDecl ncgImpl) alloced)++                dumpIfSet_dyn dflags+                        Opt_D_dump_asm_regalloc_stages "Build/spill stages"+                        (vcat   $ map (\(stage, stats)+                                        -> text "# --------------------------"+                                        $$ text "#  cmm " <> int count <> text " Stage " <> int stage+                                        $$ ppr stats)+                                $ zip [0..] regAllocStats)++                let mPprStats =+                        if dopt Opt_D_dump_asm_stats dflags+                         then Just regAllocStats else Nothing++                -- force evaluation of the Maybe to avoid space leak+                mPprStats `seq` return ()++                return  ( alloced, usAlloc+                        , mPprStats+                        , Nothing)++          else do+                -- do linear register allocation+                let reg_alloc proc = do+                       (alloced, maybe_more_stack, ra_stats) <-+                               Linear.regAlloc dflags proc+                       case maybe_more_stack of+                         Nothing -> return ( alloced, ra_stats )+                         Just amount -> do+                           alloced' <- ncgAllocMoreStack ncgImpl amount alloced+                           return (alloced', ra_stats )++                let ((alloced, regAllocStats), usAlloc)+                        = {-# SCC "RegAlloc-linear" #-}+                          initUs usLive+                          $ liftM unzip+                          $ mapM reg_alloc withLiveness++                dumpIfSet_dyn dflags+                        Opt_D_dump_asm_regalloc "Registers allocated"+                        (vcat $ map (pprNatCmmDecl ncgImpl) alloced)++                let mPprStats =+                        if dopt Opt_D_dump_asm_stats dflags+                         then Just (catMaybes regAllocStats) else Nothing++                -- force evaluation of the Maybe to avoid space leak+                mPprStats `seq` return ()++                return  ( alloced, usAlloc+                        , Nothing+                        , mPprStats)++        ---- x86fp_kludge.  This pass inserts ffree instructions to clear+        ---- the FPU stack on x86.  The x86 ABI requires that the FPU stack+        ---- is clear, and library functions can return odd results if it+        ---- isn't.+        ----+        ---- NB. must happen before shortcutBranches, because that+        ---- generates JXX_GBLs which we can't fix up in x86fp_kludge.+        let kludged = {-# SCC "x86fp_kludge" #-} ncg_x86fp_kludge ncgImpl alloced++        ---- generate jump tables+        let tabled      =+                {-# SCC "generateJumpTables" #-}+                generateJumpTables ncgImpl kludged++        ---- shortcut branches+        let shorted     =+                {-# SCC "shortcutBranches" #-}+                shortcutBranches dflags ncgImpl tabled++        ---- sequence blocks+        let sequenced   =+                {-# SCC "sequenceBlocks" #-}+                map (sequenceTop ncgImpl) shorted++        ---- expansion of SPARC synthetic instrs+        let expanded =+                {-# SCC "sparc_expand" #-}+                ncgExpandTop ncgImpl sequenced++        dumpIfSet_dyn dflags+                Opt_D_dump_asm_expanded "Synthetic instructions expanded"+                (vcat $ map (pprNatCmmDecl ncgImpl) expanded)++        -- generate unwinding information from cmm+        let unwinds :: BlockMap [UnwindPoint]+            unwinds =+                {-# SCC "unwindingInfo" #-}+                foldl' addUnwind mapEmpty expanded+              where+                addUnwind acc proc =+                    acc `mapUnion` computeUnwinding dflags ncgImpl proc++        return  ( usAlloc+                , fileIds'+                , expanded+                , lastMinuteImports ++ imports+                , ppr_raStatsColor+                , ppr_raStatsLinear+                , unwinds )+++x86fp_kludge :: NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr+x86fp_kludge top@(CmmData _ _) = top+x86fp_kludge (CmmProc info lbl live (ListGraph code)) =+        CmmProc info lbl live (ListGraph $ X86.Instr.i386_insert_ffrees code)++-- | Compute unwinding tables for the blocks of a procedure+computeUnwinding :: Instruction instr+                 => DynFlags -> NcgImpl statics instr jumpDest+                 -> NatCmmDecl statics instr+                    -- ^ the native code generated for the procedure+                 -> LabelMap [UnwindPoint]+                    -- ^ unwinding tables for all points of all blocks of the+                    -- procedure+computeUnwinding dflags _ _+  | debugLevel dflags == 0         = mapEmpty+computeUnwinding _ _ (CmmData _ _) = mapEmpty+computeUnwinding _ ncgImpl (CmmProc _ _ _ (ListGraph blks)) =+    -- In general we would need to push unwinding information down the+    -- block-level call-graph to ensure that we fully account for all+    -- relevant register writes within a procedure.+    --+    -- However, the only unwinding information that we care about in GHC is for+    -- Sp. The fact that CmmLayoutStack already ensures that we have unwind+    -- information at the beginning of every block means that there is no need+    -- to perform this sort of push-down.+    mapFromList [ (blk_lbl, extractUnwindPoints ncgImpl instrs)+                | BasicBlock blk_lbl instrs <- blks ]++-- | Build a doc for all the imports.+--+makeImportsDoc :: DynFlags -> [CLabel] -> SDoc+makeImportsDoc dflags imports+ = dyld_stubs imports+            $$+            -- On recent versions of Darwin, the linker supports+            -- dead-stripping of code and data on a per-symbol basis.+            -- There's a hack to make this work in PprMach.pprNatCmmDecl.+            (if platformHasSubsectionsViaSymbols platform+             then text ".subsections_via_symbols"+             else Outputable.empty)+            $$+                -- On recent GNU ELF systems one can mark an object file+                -- as not requiring an executable stack. If all objects+                -- linked into a program have this note then the program+                -- will not use an executable stack, which is good for+                -- security. GHC generated code does not need an executable+                -- stack so add the note in:+            (if platformHasGnuNonexecStack platform+             then text ".section .note.GNU-stack,\"\",@progbits"+             else Outputable.empty)+            $$+                -- And just because every other compiler does, let's stick in+                -- an identifier directive: .ident "GHC x.y.z"+            (if platformHasIdentDirective platform+             then let compilerIdent = text "GHC" <+> text cProjectVersion+                   in text ".ident" <+> doubleQuotes compilerIdent+             else Outputable.empty)++ where+        platform = targetPlatform dflags+        arch = platformArch platform+        os   = platformOS   platform++        -- Generate "symbol stubs" for all external symbols that might+        -- come from a dynamic library.+        dyld_stubs :: [CLabel] -> SDoc+{-      dyld_stubs imps = vcat $ map pprDyldSymbolStub $+                                    map head $ group $ sort imps-}+        -- (Hack) sometimes two Labels pretty-print the same, but have+        -- different uniques; so we compare their text versions...+        dyld_stubs imps+                | needImportedSymbols dflags arch os+                = vcat $+                        (pprGotDeclaration dflags arch os :) $+                        map ( pprImportedSymbol dflags platform . fst . head) $+                        groupBy (\(_,a) (_,b) -> a == b) $+                        sortBy (\(_,a) (_,b) -> compare a b) $+                        map doPpr $+                        imps+                | otherwise+                = Outputable.empty++        doPpr lbl = (lbl, renderWithStyle dflags (pprCLabel platform lbl) astyle)+        astyle = mkCodeStyle AsmStyle+++-- -----------------------------------------------------------------------------+-- Sequencing the basic blocks++-- Cmm BasicBlocks are self-contained entities: they always end in a+-- jump, either non-local or to another basic block in the same proc.+-- In this phase, we attempt to place the basic blocks in a sequence+-- such that as many of the local jumps as possible turn into+-- fallthroughs.++sequenceTop+        :: Instruction instr+    => NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> NatCmmDecl statics instr++sequenceTop _       top@(CmmData _ _) = top+sequenceTop ncgImpl (CmmProc info lbl live (ListGraph blocks)) =+  CmmProc info lbl live (ListGraph $ ncgMakeFarBranches ncgImpl info $ sequenceBlocks info blocks)++-- The algorithm is very simple (and stupid): we make a graph out of+-- the blocks where there is an edge from one block to another iff the+-- first block ends by jumping to the second.  Then we topologically+-- sort this graph.  Then traverse the list: for each block, we first+-- output the block, then if it has an out edge, we move the+-- destination of the out edge to the front of the list, and continue.++-- FYI, the classic layout for basic blocks uses postorder DFS; this+-- algorithm is implemented in Hoopl.++sequenceBlocks+        :: Instruction instr+        => LabelMap i+        -> [NatBasicBlock instr]+        -> [NatBasicBlock instr]++sequenceBlocks _ [] = []+sequenceBlocks infos (entry:blocks) =+  seqBlocks infos (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))+  -- the first block is the entry point ==> it must remain at the start.+++sccBlocks+        :: Instruction instr+        => [NatBasicBlock instr]+        -> [SCC ( NatBasicBlock instr+                , BlockId+                , [BlockId])]++sccBlocks blocks = stronglyConnCompFromEdgedVerticesUniqR (map mkNode blocks)++-- we're only interested in the last instruction of+-- the block, and only if it has a single destination.+getOutEdges+        :: Instruction instr+        => [instr] -> [BlockId]++getOutEdges instrs+        = case jumpDestsOfInstr (last instrs) of+                [one] -> [one]+                _many -> []++mkNode :: (Instruction t)+       => GenBasicBlock t+       -> (GenBasicBlock t, BlockId, [BlockId])+mkNode block@(BasicBlock id instrs) = (block, id, getOutEdges instrs)++seqBlocks :: LabelMap i -> [(GenBasicBlock t1, BlockId, [BlockId])]+                        -> [GenBasicBlock t1]+seqBlocks infos blocks = placeNext pullable0 todo0+  where+    -- pullable: Blocks that are not yet placed+    -- todo:     Original order of blocks, to be followed if we have no good+    --           reason not to;+    --           may include blocks that have already been placed, but then+    --           these are not in pullable+    pullable0 = listToUFM [ (i,(b,n)) | (b,i,n) <- blocks ]+    todo0     = [i | (_,i,_) <- blocks ]++    placeNext _ [] = []+    placeNext pullable (i:rest)+        | Just (block, pullable') <- lookupDeleteUFM pullable i+        = place pullable' rest block+        | otherwise+        -- We already placed this block, so ignore+        = placeNext pullable rest++    place pullable todo (block,[])+                          = block : placeNext pullable todo+    place pullable todo (block@(BasicBlock id instrs),[next])+        | mapMember next infos+        = block : placeNext pullable todo+        | Just (nextBlock, pullable') <- lookupDeleteUFM pullable next+        = BasicBlock id (init instrs) : place pullable' todo nextBlock+        | otherwise+        = block : placeNext pullable todo+    place _ _ (_,tooManyNextNodes)+        = pprPanic "seqBlocks" (ppr tooManyNextNodes)+++lookupDeleteUFM :: Uniquable key => UniqFM elt -> key -> Maybe (elt, UniqFM elt)+lookupDeleteUFM m k = do -- Maybe monad+    v <- lookupUFM m k+    return (v, delFromUFM m k)++-- -----------------------------------------------------------------------------+-- Generate jump tables++-- Analyzes all native code and generates data sections for all jump+-- table instructions.+generateJumpTables+        :: NcgImpl statics instr jumpDest+        -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]+generateJumpTables ncgImpl xs = concatMap f xs+    where f p@(CmmProc _ _ _ (ListGraph xs)) = p : concatMap g xs+          f p = [p]+          g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs)++-- -----------------------------------------------------------------------------+-- Shortcut branches++shortcutBranches+        :: DynFlags+    -> NcgImpl statics instr jumpDest+        -> [NatCmmDecl statics instr]+        -> [NatCmmDecl statics instr]++shortcutBranches dflags ncgImpl tops+  | optLevel dflags < 1 = tops    -- only with -O or higher+  | otherwise           = map (apply_mapping ncgImpl mapping) tops'+  where+    (tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops+    mapping = foldr plusUFM emptyUFM mappings++build_mapping :: NcgImpl statics instr jumpDest+              -> GenCmmDecl d (LabelMap t) (ListGraph instr)+              -> (GenCmmDecl d (LabelMap t) (ListGraph instr), UniqFM jumpDest)+build_mapping _ top@(CmmData _ _) = (top, emptyUFM)+build_mapping _ (CmmProc info lbl live (ListGraph []))+  = (CmmProc info lbl live (ListGraph []), emptyUFM)+build_mapping ncgImpl (CmmProc info lbl live (ListGraph (head:blocks)))+  = (CmmProc info lbl live (ListGraph (head:others)), mapping)+        -- drop the shorted blocks, but don't ever drop the first one,+        -- because it is pointed to by a global label.+  where+    -- find all the blocks that just consist of a jump that can be+    -- shorted.+    -- Don't completely eliminate loops here -- that can leave a dangling jump!+    (_, shortcut_blocks, others) =+        foldl split (setEmpty :: LabelSet, [], []) blocks+    split (s, shortcut_blocks, others) b@(BasicBlock id [insn])+        | Just jd <- canShortcut ncgImpl insn,+          Just dest <- getJumpDestBlockId ncgImpl jd,+          not (has_info id),+          (setMember dest s) || dest == id -- loop checks+        = (s, shortcut_blocks, b : others)+    split (s, shortcut_blocks, others) (BasicBlock id [insn])+        | Just dest <- canShortcut ncgImpl insn,+          not (has_info id)+        = (setInsert id s, (id,dest) : shortcut_blocks, others)+    split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others)++    -- do not eliminate blocks that have an info table+    has_info l = mapMember l info++    -- build a mapping from BlockId to JumpDest for shorting branches+    mapping = foldl add emptyUFM shortcut_blocks+    add ufm (id,dest) = addToUFM ufm id dest++apply_mapping :: NcgImpl statics instr jumpDest+              -> UniqFM jumpDest+              -> GenCmmDecl statics h (ListGraph instr)+              -> GenCmmDecl statics h (ListGraph instr)+apply_mapping ncgImpl ufm (CmmData sec statics)+  = CmmData sec (shortcutStatics ncgImpl (lookupUFM ufm) statics)+apply_mapping ncgImpl ufm (CmmProc info lbl live (ListGraph blocks))+  = CmmProc info lbl live (ListGraph $ map short_bb blocks)+  where+    short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns+    short_insn i = shortcutJump ncgImpl (lookupUFM ufm) i+                 -- shortcutJump should apply the mapping repeatedly,+                 -- just in case we can short multiple branches.++-- -----------------------------------------------------------------------------+-- Instruction selection++-- Native code instruction selection for a chunk of stix code.  For+-- this part of the computation, we switch from the UniqSM monad to+-- the NatM monad.  The latter carries not only a Unique, but also an+-- Int denoting the current C stack pointer offset in the generated+-- code; this is needed for creating correct spill offsets on+-- architectures which don't offer, or for which it would be+-- prohibitively expensive to employ, a frame pointer register.  Viz,+-- x86.++-- The offset is measured in bytes, and indicates the difference+-- between the current (simulated) C stack-ptr and the value it was at+-- the beginning of the block.  For stacks which grow down, this value+-- should be either zero or negative.++-- Along with the stack pointer offset, we also carry along a LabelMap of+-- DebugBlocks, which we read to generate .location directives.+--+-- Switching between the two monads whilst carrying along the same+-- Unique supply breaks abstraction.  Is that bad?++genMachCode+        :: DynFlags+        -> Module -> ModLocation+        -> (RawCmmDecl -> NatM [NatCmmDecl statics instr])+        -> DwarfFiles+        -> LabelMap DebugBlock+        -> RawCmmDecl+        -> UniqSM+                ( [NatCmmDecl statics instr]+                , [CLabel]+                , DwarfFiles)++genMachCode dflags this_mod modLoc cmmTopCodeGen fileIds dbgMap cmm_top+  = do  { initial_us <- getUniqueSupplyM+        ; let initial_st           = mkNatM_State initial_us 0 dflags this_mod+                                                  modLoc fileIds dbgMap+              (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)+              final_delta          = natm_delta final_st+              final_imports        = natm_imports final_st+        ; if   final_delta == 0+          then return (new_tops, final_imports, natm_fileid final_st)+          else pprPanic "genMachCode: nonzero final delta" (int final_delta)+    }++-- -----------------------------------------------------------------------------+-- Generic Cmm optimiser++{-+Here we do:++  (a) Constant folding+  (c) Position independent code and dynamic linking+        (i)  introduce the appropriate indirections+             and position independent refs+        (ii) compile a list of imported symbols+  (d) Some arch-specific optimizations++(a) will be moving to the new Hoopl pipeline, however, (c) and+(d) are only needed by the native backend and will continue to live+here.++Ideas for other things we could do (put these in Hoopl please!):++  - shortcut jumps-to-jumps+  - simple CSE: if an expr is assigned to a temp, then replace later occs of+    that expr with the temp, until the expr is no longer valid (can push through+    temp assignments, and certain assigns to mem...)+-}++cmmToCmm :: DynFlags -> Module -> RawCmmDecl -> (RawCmmDecl, [CLabel])+cmmToCmm _ _ top@(CmmData _ _) = (top, [])+cmmToCmm dflags this_mod (CmmProc info lbl live graph)+    = runCmmOpt dflags this_mod $+      do blocks' <- mapM cmmBlockConFold (toBlockList graph)+         return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks')++newtype CmmOptM a = CmmOptM (DynFlags -> Module -> [CLabel] -> (# a, [CLabel] #))++instance Functor CmmOptM where+    fmap = liftM++instance Applicative CmmOptM where+    pure x = CmmOptM $ \_ _ imports -> (# x, imports #)+    (<*>) = ap++instance Monad CmmOptM where+  (CmmOptM f) >>= g =+    CmmOptM $ \dflags this_mod imports ->+                case f dflags this_mod imports of+                  (# x, imports' #) ->+                    case g x of+                      CmmOptM g' -> g' dflags this_mod imports'++instance CmmMakeDynamicReferenceM CmmOptM where+    addImport = addImportCmmOpt+    getThisModule = CmmOptM $ \_ this_mod imports -> (# this_mod, imports #)++addImportCmmOpt :: CLabel -> CmmOptM ()+addImportCmmOpt lbl = CmmOptM $ \_ _ imports -> (# (), lbl:imports #)++instance HasDynFlags CmmOptM where+    getDynFlags = CmmOptM $ \dflags _ imports -> (# dflags, imports #)++runCmmOpt :: DynFlags -> Module -> CmmOptM a -> (a, [CLabel])+runCmmOpt dflags this_mod (CmmOptM f) = case f dflags this_mod [] of+                        (# result, imports #) -> (result, imports)++cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock+cmmBlockConFold block = do+  let (entry, middle, last) = blockSplit block+      stmts = blockToList middle+  stmts' <- mapM cmmStmtConFold stmts+  last' <- cmmStmtConFold last+  return $ blockJoin entry (blockFromList stmts') last'++-- This does three optimizations, but they're very quick to check, so we don't+-- bother turning them off even when the Hoopl code is active.  Since+-- this is on the old Cmm representation, we can't reuse the code either:+--  * reg = reg      --> nop+--  * if 0 then jump --> nop+--  * if 1 then jump --> jump+-- We might be tempted to skip this step entirely of not Opt_PIC, but+-- there is some PowerPC code for the non-PIC case, which would also+-- have to be separated.+cmmStmtConFold :: CmmNode e x -> CmmOptM (CmmNode e x)+cmmStmtConFold stmt+   = case stmt of+        CmmAssign reg src+           -> do src' <- cmmExprConFold DataReference src+                 return $ case src' of+                   CmmReg reg' | reg == reg' -> CmmComment (fsLit "nop")+                   new_src -> CmmAssign reg new_src++        CmmStore addr src+           -> do addr' <- cmmExprConFold DataReference addr+                 src'  <- cmmExprConFold DataReference src+                 return $ CmmStore addr' src'++        CmmCall { cml_target = addr }+           -> do addr' <- cmmExprConFold JumpReference addr+                 return $ stmt { cml_target = addr' }++        CmmUnsafeForeignCall target regs args+           -> do target' <- case target of+                              ForeignTarget e conv -> do+                                e' <- cmmExprConFold CallReference e+                                return $ ForeignTarget e' conv+                              PrimTarget _ ->+                                return target+                 args' <- mapM (cmmExprConFold DataReference) args+                 return $ CmmUnsafeForeignCall target' regs args'++        CmmCondBranch test true false likely+           -> do test' <- cmmExprConFold DataReference test+                 return $ case test' of+                   CmmLit (CmmInt 0 _) -> CmmBranch false+                   CmmLit (CmmInt _ _) -> CmmBranch true+                   _other -> CmmCondBranch test' true false likely++        CmmSwitch expr ids+           -> do expr' <- cmmExprConFold DataReference expr+                 return $ CmmSwitch expr' ids++        other+           -> return other++cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr+cmmExprConFold referenceKind expr = do+    dflags <- getDynFlags++    -- With -O1 and greater, the cmmSink pass does constant-folding, so+    -- we don't need to do it again here.+    let expr' = if optLevel dflags >= 1+                    then expr+                    else cmmExprCon dflags expr++    cmmExprNative referenceKind expr'++cmmExprCon :: DynFlags -> CmmExpr -> CmmExpr+cmmExprCon dflags (CmmLoad addr rep) = CmmLoad (cmmExprCon dflags addr) rep+cmmExprCon dflags (CmmMachOp mop args)+    = cmmMachOpFold dflags mop (map (cmmExprCon dflags) args)+cmmExprCon _ other = other++-- handles both PIC and non-PIC cases... a very strange mixture+-- of things to do.+cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr+cmmExprNative referenceKind expr = do+     dflags <- getDynFlags+     let platform = targetPlatform dflags+         arch = platformArch platform+     case expr of+        CmmLoad addr rep+           -> do addr' <- cmmExprNative DataReference addr+                 return $ CmmLoad addr' rep++        CmmMachOp mop args+           -> do args' <- mapM (cmmExprNative DataReference) args+                 return $ CmmMachOp mop args'++        CmmLit (CmmBlock id)+           -> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id)))+           -- we must convert block Ids to CLabels here, because we+           -- might have to do the PIC transformation.  Hence we must+           -- not modify BlockIds beyond this point.++        CmmLit (CmmLabel lbl)+           -> do+                cmmMakeDynamicReference dflags referenceKind lbl+        CmmLit (CmmLabelOff lbl off)+           -> do+                 dynRef <- cmmMakeDynamicReference dflags referenceKind lbl+                 -- need to optimize here, since it's late+                 return $ cmmMachOpFold dflags (MO_Add (wordWidth dflags)) [+                     dynRef,+                     (CmmLit $ CmmInt (fromIntegral off) (wordWidth dflags))+                   ]++        -- On powerpc (non-PIC), it's easier to jump directly to a label than+        -- to use the register table, so we replace these registers+        -- with the corresponding labels:+        CmmReg (CmmGlobal EagerBlackholeInfo)+          | arch == ArchPPC && not (gopt Opt_PIC dflags)+          -> cmmExprNative referenceKind $+             CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_EAGER_BLACKHOLE_info")))+        CmmReg (CmmGlobal GCEnter1)+          | arch == ArchPPC && not (gopt Opt_PIC dflags)+          -> cmmExprNative referenceKind $+             CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_enter_1")))+        CmmReg (CmmGlobal GCFun)+          | arch == ArchPPC && not (gopt Opt_PIC dflags)+          -> cmmExprNative referenceKind $+             CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_fun")))++        other+           -> return other
+ nativeGen/CPrim.hs view
@@ -0,0 +1,101 @@+-- | Generating C symbol names emitted by the compiler.+module CPrim+    ( atomicReadLabel+    , atomicWriteLabel+    , atomicRMWLabel+    , cmpxchgLabel+    , popCntLabel+    , bSwapLabel+    , clzLabel+    , ctzLabel+    , word2FloatLabel+    ) where++import CmmType+import CmmMachOp+import Outputable++popCntLabel :: Width -> String+popCntLabel w = "hs_popcnt" ++ pprWidth w+  where+    pprWidth W8  = "8"+    pprWidth W16 = "16"+    pprWidth W32 = "32"+    pprWidth W64 = "64"+    pprWidth w   = pprPanic "popCntLabel: Unsupported word width " (ppr w)++bSwapLabel :: Width -> String+bSwapLabel w = "hs_bswap" ++ pprWidth w+  where+    pprWidth W16 = "16"+    pprWidth W32 = "32"+    pprWidth W64 = "64"+    pprWidth w   = pprPanic "bSwapLabel: Unsupported word width " (ppr w)++clzLabel :: Width -> String+clzLabel w = "hs_clz" ++ pprWidth w+  where+    pprWidth W8  = "8"+    pprWidth W16 = "16"+    pprWidth W32 = "32"+    pprWidth W64 = "64"+    pprWidth w   = pprPanic "clzLabel: Unsupported word width " (ppr w)++ctzLabel :: Width -> String+ctzLabel w = "hs_ctz" ++ pprWidth w+  where+    pprWidth W8  = "8"+    pprWidth W16 = "16"+    pprWidth W32 = "32"+    pprWidth W64 = "64"+    pprWidth w   = pprPanic "ctzLabel: Unsupported word width " (ppr w)++word2FloatLabel :: Width -> String+word2FloatLabel w = "hs_word2float" ++ pprWidth w+  where+    pprWidth W32 = "32"+    pprWidth W64 = "64"+    pprWidth w   = pprPanic "word2FloatLabel: Unsupported word width " (ppr w)++atomicRMWLabel :: Width -> AtomicMachOp -> String+atomicRMWLabel w amop = "hs_atomic_" ++ pprFunName amop ++ pprWidth w+  where+    pprWidth W8  = "8"+    pprWidth W16 = "16"+    pprWidth W32 = "32"+    pprWidth W64 = "64"+    pprWidth w   = pprPanic "atomicRMWLabel: Unsupported word width " (ppr w)++    pprFunName AMO_Add  = "add"+    pprFunName AMO_Sub  = "sub"+    pprFunName AMO_And  = "and"+    pprFunName AMO_Nand = "nand"+    pprFunName AMO_Or   = "or"+    pprFunName AMO_Xor  = "xor"++cmpxchgLabel :: Width -> String+cmpxchgLabel w = "hs_cmpxchg" ++ pprWidth w+  where+    pprWidth W8  = "8"+    pprWidth W16 = "16"+    pprWidth W32 = "32"+    pprWidth W64 = "64"+    pprWidth w   = pprPanic "cmpxchgLabel: Unsupported word width " (ppr w)++atomicReadLabel :: Width -> String+atomicReadLabel w = "hs_atomicread" ++ pprWidth w+  where+    pprWidth W8  = "8"+    pprWidth W16 = "16"+    pprWidth W32 = "32"+    pprWidth W64 = "64"+    pprWidth w   = pprPanic "atomicReadLabel: Unsupported word width " (ppr w)++atomicWriteLabel :: Width -> String+atomicWriteLabel w = "hs_atomicwrite" ++ pprWidth w+  where+    pprWidth W8  = "8"+    pprWidth W16 = "16"+    pprWidth W32 = "32"+    pprWidth W64 = "64"+    pprWidth w   = pprPanic "atomicWriteLabel: Unsupported word width " (ppr w)
+ nativeGen/Dwarf.hs view
@@ -0,0 +1,259 @@+module Dwarf (+  dwarfGen+  ) where++import CLabel+import CmmExpr         ( GlobalReg(..) )+import Config          ( cProjectName, cProjectVersion )+import CoreSyn         ( Tickish(..) )+import Debug+import DynFlags+import Module+import Outputable+import Platform+import Unique+import UniqSupply++import Dwarf.Constants+import Dwarf.Types++import Control.Arrow    ( first )+import Control.Monad    ( mfilter )+import Data.Maybe+import Data.List        ( sortBy )+import Data.Ord         ( comparing )+import qualified Data.Map as Map+import System.FilePath+import System.Directory ( getCurrentDirectory )++import qualified Compiler.Hoopl as H++-- | Generate DWARF/debug information+dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock]+            -> IO (SDoc, UniqSupply)+dwarfGen _  _      us [] = return (empty, us)+dwarfGen df modLoc us blocks = do++  -- Convert debug data structures to DWARF info records+  -- We strip out block information when running with -g0 or -g1.+  let procs = debugSplitProcs blocks+      stripBlocks dbg+        | debugLevel df < 2 = dbg { dblBlocks = [] }+        | otherwise         = dbg+  compPath <- getCurrentDirectory+  let lowLabel = dblCLabel $ head procs+      highLabel = mkAsmTempEndLabel $ dblCLabel $ last procs+      dwarfUnit = DwarfCompileUnit+        { dwChildren = map (procToDwarf df) (map stripBlocks procs)+        , dwName = fromMaybe "" (ml_hs_file modLoc)+        , dwCompDir = addTrailingPathSeparator compPath+        , dwProducer = cProjectName ++ " " ++ cProjectVersion+        , dwLowLabel = lowLabel+        , dwHighLabel = highLabel+        , dwLineLabel = dwarfLineLabel+        }++  -- Check whether we have any source code information, so we do not+  -- end up writing a pointer to an empty .debug_line section+  -- (dsymutil on Mac Os gets confused by this).+  let haveSrcIn blk = isJust (dblSourceTick blk) && isJust (dblPosition blk)+                      || any haveSrcIn (dblBlocks blk)+      haveSrc = any haveSrcIn procs++  -- .debug_abbrev section: Declare the format we're using+  let abbrevSct = pprAbbrevDecls haveSrc++  -- .debug_info section: Information records on procedures and blocks+  let -- unique to identify start and end compilation unit .debug_inf+      (unitU, us') = takeUniqFromSupply us+      infoSct = vcat [ ptext dwarfInfoLabel <> colon+                     , dwarfInfoSection+                     , compileUnitHeader unitU+                     , pprDwarfInfo haveSrc dwarfUnit+                     , compileUnitFooter unitU+                     ]++  -- .debug_line section: Generated mainly by the assembler, but we+  -- need to label it+  let lineSct = dwarfLineSection $$+                ptext dwarfLineLabel <> colon++  -- .debug_frame section: Information about the layout of the GHC stack+  let (framesU, us'') = takeUniqFromSupply us'+      frameSct = dwarfFrameSection $$+                 ptext dwarfFrameLabel <> colon $$+                 pprDwarfFrame (debugFrame framesU procs)++  -- .aranges section: Information about the bounds of compilation units+  let aranges' | gopt Opt_SplitSections df = map mkDwarfARange procs+               | otherwise                 = [DwarfARange lowLabel highLabel]+  let aranges = dwarfARangesSection $$ pprDwarfARanges aranges' unitU++  return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'')++-- | Build an address range entry for one proc.+-- With split sections, each proc needs its own entry, since they may get+-- scattered in the final binary. Without split sections, we could make a+-- single arange based on the first/last proc.+mkDwarfARange :: DebugBlock -> DwarfARange+mkDwarfARange proc = DwarfARange start end+  where+    start = dblCLabel proc+    end = mkAsmTempEndLabel start++-- | Header for a compilation unit, establishing global format+-- parameters+compileUnitHeader :: Unique -> SDoc+compileUnitHeader unitU = sdocWithPlatform $ \plat ->+  let cuLabel = mkAsmTempLabel unitU  -- sits right before initialLength field+      length = ppr (mkAsmTempEndLabel cuLabel) <> char '-' <> ppr cuLabel+               <> text "-4"       -- length of initialLength field+  in vcat [ ppr cuLabel <> colon+          , text "\t.long " <> length  -- compilation unit size+          , pprHalf 3                          -- DWARF version+          , sectionOffset (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel)+                                               -- abbrevs offset+          , text "\t.byte " <> ppr (platformWordSize plat) -- word size+          ]++-- | Compilation unit footer, mainly establishing size of debug sections+compileUnitFooter :: Unique -> SDoc+compileUnitFooter unitU =+  let cuEndLabel = mkAsmTempEndLabel $ mkAsmTempLabel unitU+  in ppr cuEndLabel <> colon++-- | Splits the blocks by procedures. In the result all nested blocks+-- will come from the same procedure as the top-level block. See+-- Note [Splitting DebugBlocks] for details.+debugSplitProcs :: [DebugBlock] -> [DebugBlock]+debugSplitProcs b = concat $ H.mapElems $ mergeMaps $ map (split Nothing) b+  where mergeMaps = foldr (H.mapUnionWithKey (const (++))) H.mapEmpty+        split :: Maybe DebugBlock -> DebugBlock -> H.LabelMap [DebugBlock]+        split parent blk = H.mapInsert prc [blk'] nested+          where prc = dblProcedure blk+                blk' = blk { dblBlocks = own_blks+                           , dblParent = parent+                           }+                own_blks = fromMaybe [] $ H.mapLookup prc nested+                nested = mergeMaps $ map (split parent') $ dblBlocks blk+                -- Figure out who should be the parent of nested blocks.+                -- If @blk@ is optimized out then it isn't a good choice+                -- and we just use its parent.+                parent'+                  | Nothing <- dblPosition blk = parent+                  | otherwise                  = Just blk++{-+Note [Splitting DebugBlocks]++DWARF requires that we break up the the nested DebugBlocks produced from+the C-- AST. For instance, we begin with tick trees containing nested procs.+For example,++    proc A [tick1, tick2]+      block B [tick3]+        proc C [tick4]++when producing DWARF we need to procs (which are represented in DWARF as+TAG_subprogram DIEs) to be top-level DIEs. debugSplitProcs is responsible for+this transform, pulling out the nested procs into top-level procs.++However, in doing this we need to be careful to preserve the parentage of the+nested procs. This is the reason DebugBlocks carry the dblParent field, allowing+us to reorganize the above tree as,++    proc A [tick1, tick2]+      block B [tick3]+    proc C [tick4] parent=B++Here we have annotated the new proc C with an attribute giving its original+parent, B.+-}++-- | Generate DWARF info for a procedure debug block+procToDwarf :: DynFlags -> DebugBlock -> DwarfInfo+procToDwarf df prc+  = DwarfSubprogram { dwChildren = map (blockToDwarf df) (dblBlocks prc)+                    , dwName     = case dblSourceTick prc of+                         Just s@SourceNote{} -> sourceName s+                         _otherwise -> showSDocDump df $ ppr $ dblLabel prc+                    , dwLabel    = dblCLabel prc+                    , dwParent   = fmap mkAsmTempDieLabel+                                   $ mfilter (/= dblCLabel prc)+                                   $ fmap dblCLabel (dblParent prc)+                      -- Omit parent if it would be self-referential+                    }++-- | Generate DWARF info for a block+blockToDwarf :: DynFlags -> DebugBlock -> DwarfInfo+blockToDwarf df blk+  = DwarfBlock { dwChildren = concatMap (tickToDwarf df) (dblTicks blk)+                              ++ map (blockToDwarf df) (dblBlocks blk)+               , dwLabel    = dblCLabel blk+               , dwMarker   = marker+               }+  where+    marker+      | Just _ <- dblPosition blk = Just $ mkAsmTempLabel $ dblLabel blk+      | otherwise                 = Nothing   -- block was optimized out++tickToDwarf :: DynFlags -> Tickish () -> [DwarfInfo]+tickToDwarf _  (SourceNote ss _) = [DwarfSrcNote ss]+tickToDwarf _ _ = []++-- | Generates the data for the debug frame section, which encodes the+-- desired stack unwind behaviour for the debugger+debugFrame :: Unique -> [DebugBlock] -> DwarfFrame+debugFrame u procs+  = DwarfFrame { dwCieLabel = mkAsmTempLabel u+               , dwCieInit  = initUws+               , dwCieProcs = map (procToFrame initUws) procs+               }+  where+    initUws :: UnwindTable+    initUws = Map.fromList [(Sp, Just (UwReg Sp 0))]++-- | Generates unwind information for a procedure debug block+procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc+procToFrame initUws blk+  = DwarfFrameProc { dwFdeProc    = dblCLabel blk+                   , dwFdeHasInfo = dblHasInfoTbl blk+                   , dwFdeBlocks  = map (uncurry blockToFrame)+                                        (setHasInfo blockUws)+                   }+  where blockUws :: [(DebugBlock, [UnwindPoint])]+        blockUws = map snd $ sortBy (comparing fst) $ flatten blk++        flatten :: DebugBlock+                -> [(Int, (DebugBlock, [UnwindPoint]))]+        flatten b@DebugBlock{ dblPosition=pos, dblUnwind=uws, dblBlocks=blocks }+          | Just p <- pos  = (p, (b, uws')):nested+          | otherwise      = nested -- block was optimized out+          where uws'   = addDefaultUnwindings initUws uws+                nested = concatMap flatten blocks++        -- | If the current procedure has an info table, then we also say that+        -- its first block has one to ensure that it gets the necessary -1+        -- offset applied to its start address.+        -- See Note [Info Offset] in Dwarf.Types.+        setHasInfo :: [(DebugBlock, [UnwindPoint])]+                   -> [(DebugBlock, [UnwindPoint])]+        setHasInfo [] = []+        setHasInfo (c0:cs) = first setIt c0 : cs+          where+            setIt child =+              child { dblHasInfoTbl = dblHasInfoTbl child+                                      || dblHasInfoTbl blk }++blockToFrame :: DebugBlock -> [UnwindPoint] -> DwarfFrameBlock+blockToFrame blk uws+  = DwarfFrameBlock { dwFdeBlkHasInfo = dblHasInfoTbl blk+                    , dwFdeUnwind     = uws+                    }++addDefaultUnwindings :: UnwindTable -> [UnwindPoint] -> [UnwindPoint]+addDefaultUnwindings tbl pts =+    [ UnwindPoint lbl (tbl' `mappend` tbl)+      -- mappend is left-biased+    | UnwindPoint lbl tbl' <- pts+    ]
+ nativeGen/Dwarf/Constants.hs view
@@ -0,0 +1,225 @@+-- | Constants describing the DWARF format. Most of this simply+-- mirrors /usr/include/dwarf.h.++module Dwarf.Constants where++import FastString+import Platform+import Outputable++import Reg+import X86.Regs++import Data.Word++-- | Language ID used for Haskell.+dW_LANG_Haskell :: Word+dW_LANG_Haskell = 0x18+  -- Thanks to Nathan Howell for getting us our very own language ID!++-- * Dwarf tags+dW_TAG_compile_unit, dW_TAG_subroutine_type,+  dW_TAG_file_type, dW_TAG_subprogram, dW_TAG_lexical_block,+  dW_TAG_base_type, dW_TAG_structure_type, dW_TAG_pointer_type,+  dW_TAG_array_type, dW_TAG_subrange_type, dW_TAG_typedef,+  dW_TAG_variable, dW_TAG_arg_variable, dW_TAG_auto_variable,+  dW_TAG_ghc_src_note :: Word+dW_TAG_array_type      = 1+dW_TAG_lexical_block   = 11+dW_TAG_pointer_type    = 15+dW_TAG_compile_unit    = 17+dW_TAG_structure_type  = 19+dW_TAG_typedef         = 22+dW_TAG_subroutine_type = 32+dW_TAG_subrange_type   = 33+dW_TAG_base_type       = 36+dW_TAG_file_type       = 41+dW_TAG_subprogram      = 46+dW_TAG_variable        = 52+dW_TAG_auto_variable   = 256+dW_TAG_arg_variable    = 257++dW_TAG_ghc_src_note    = 0x5b00++-- * Dwarf attributes+dW_AT_name, dW_AT_stmt_list, dW_AT_low_pc, dW_AT_high_pc, dW_AT_language,+  dW_AT_comp_dir, dW_AT_producer, dW_AT_external, dW_AT_frame_base,+  dW_AT_use_UTF8, dW_AT_MIPS_linkage_name :: Word+dW_AT_name              = 0x03+dW_AT_stmt_list         = 0x10+dW_AT_low_pc            = 0x11+dW_AT_high_pc           = 0x12+dW_AT_language          = 0x13+dW_AT_comp_dir          = 0x1b+dW_AT_producer          = 0x25+dW_AT_external          = 0x3f+dW_AT_frame_base        = 0x40+dW_AT_use_UTF8          = 0x53+dW_AT_MIPS_linkage_name = 0x2007++-- * Custom DWARF attributes+-- Chosen a more or less random section of the vendor-extensible region++-- ** Describing C-- blocks+-- These appear in DW_TAG_lexical_scope DIEs corresponding to C-- blocks+dW_AT_ghc_tick_parent :: Word+dW_AT_ghc_tick_parent     = 0x2b20++-- ** Describing source notes+-- These appear in DW_TAG_ghc_src_note DIEs+dW_AT_ghc_span_file, dW_AT_ghc_span_start_line,+  dW_AT_ghc_span_start_col, dW_AT_ghc_span_end_line,+  dW_AT_ghc_span_end_col :: Word+dW_AT_ghc_span_file       = 0x2b00+dW_AT_ghc_span_start_line = 0x2b01+dW_AT_ghc_span_start_col  = 0x2b02+dW_AT_ghc_span_end_line   = 0x2b03+dW_AT_ghc_span_end_col    = 0x2b04+++-- * Abbrev declarations+dW_CHILDREN_no, dW_CHILDREN_yes :: Word8+dW_CHILDREN_no  = 0+dW_CHILDREN_yes = 1++dW_FORM_addr, dW_FORM_data2, dW_FORM_data4, dW_FORM_string, dW_FORM_flag,+  dW_FORM_block1, dW_FORM_ref4, dW_FORM_ref_addr, dW_FORM_flag_present :: Word+dW_FORM_addr   = 0x01+dW_FORM_data2  = 0x05+dW_FORM_data4  = 0x06+dW_FORM_string = 0x08+dW_FORM_flag   = 0x0c+dW_FORM_block1 = 0x0a+dW_FORM_ref_addr     = 0x10+dW_FORM_ref4         = 0x13+dW_FORM_flag_present = 0x19++-- * Dwarf native types+dW_ATE_address, dW_ATE_boolean, dW_ATE_float, dW_ATE_signed,+  dW_ATE_signed_char, dW_ATE_unsigned, dW_ATE_unsigned_char :: Word+dW_ATE_address       = 1+dW_ATE_boolean       = 2+dW_ATE_float         = 4+dW_ATE_signed        = 5+dW_ATE_signed_char   = 6+dW_ATE_unsigned      = 7+dW_ATE_unsigned_char = 8++-- * Call frame information+dW_CFA_set_loc, dW_CFA_undefined, dW_CFA_same_value,+  dW_CFA_def_cfa, dW_CFA_def_cfa_offset, dW_CFA_def_cfa_expression,+  dW_CFA_expression, dW_CFA_offset_extended_sf, dW_CFA_def_cfa_offset_sf,+  dW_CFA_def_cfa_sf, dW_CFA_val_offset, dW_CFA_val_expression,+  dW_CFA_offset :: Word8+dW_CFA_set_loc            = 0x01+dW_CFA_undefined          = 0x07+dW_CFA_same_value         = 0x08+dW_CFA_def_cfa            = 0x0c+dW_CFA_def_cfa_offset     = 0x0e+dW_CFA_def_cfa_expression = 0x0f+dW_CFA_expression         = 0x10+dW_CFA_offset_extended_sf = 0x11+dW_CFA_def_cfa_sf         = 0x12+dW_CFA_def_cfa_offset_sf  = 0x13+dW_CFA_val_offset         = 0x14+dW_CFA_val_expression     = 0x16+dW_CFA_offset             = 0x80++-- * Operations+dW_OP_addr, dW_OP_deref, dW_OP_consts,+  dW_OP_minus, dW_OP_mul, dW_OP_plus,+  dW_OP_lit0, dW_OP_breg0, dW_OP_call_frame_cfa :: Word8+dW_OP_addr           = 0x03+dW_OP_deref          = 0x06+dW_OP_consts         = 0x11+dW_OP_minus          = 0x1c+dW_OP_mul            = 0x1e+dW_OP_plus           = 0x22+dW_OP_lit0           = 0x30+dW_OP_breg0          = 0x70+dW_OP_call_frame_cfa = 0x9c++-- * Dwarf section declarations+dwarfInfoSection, dwarfAbbrevSection, dwarfLineSection,+  dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: SDoc+dwarfInfoSection    = dwarfSection "info"+dwarfAbbrevSection  = dwarfSection "abbrev"+dwarfLineSection    = dwarfSection "line"+dwarfFrameSection   = dwarfSection "frame"+dwarfGhcSection     = dwarfSection "ghc"+dwarfARangesSection = dwarfSection "aranges"++dwarfSection :: String -> SDoc+dwarfSection name = sdocWithPlatform $ \plat -> ftext $ mkFastString $+  case platformOS plat of+    os | osElfTarget os+       -> "\t.section .debug_" ++ name ++ ",\"\",@progbits"+       | osMachOTarget os+       -> "\t.section __DWARF,__debug_" ++ name ++ ",regular,debug"+       | otherwise+       -> "\t.section .debug_" ++ name ++ ",\"dr\""++-- * Dwarf section labels+dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: LitString+dwarfInfoLabel   = sLit ".Lsection_info"+dwarfAbbrevLabel = sLit ".Lsection_abbrev"+dwarfLineLabel   = sLit ".Lsection_line"+dwarfFrameLabel  = sLit ".Lsection_frame"++-- | Mapping of registers to DWARF register numbers+dwarfRegNo :: Platform -> Reg -> Word8+dwarfRegNo p r = case platformArch p of+  ArchX86+    | r == eax  -> 0+    | r == ecx  -> 1  -- yes, no typo+    | r == edx  -> 2+    | r == ebx  -> 3+    | r == esp  -> 4+    | r == ebp  -> 5+    | r == esi  -> 6+    | r == edi  -> 7+  ArchX86_64+    | r == rax  -> 0+    | r == rdx  -> 1 -- this neither. The order GCC allocates registers in?+    | r == rcx  -> 2+    | r == rbx  -> 3+    | r == rsi  -> 4+    | r == rdi  -> 5+    | r == rbp  -> 6+    | r == rsp  -> 7+    | r == r8   -> 8+    | r == r9   -> 9+    | r == r10  -> 10+    | r == r11  -> 11+    | r == r12  -> 12+    | r == r13  -> 13+    | r == r14  -> 14+    | r == r15  -> 15+    | r == xmm0 -> 17+    | r == xmm1 -> 18+    | r == xmm2 -> 19+    | r == xmm3 -> 20+    | r == xmm4 -> 21+    | r == xmm5 -> 22+    | r == xmm6 -> 23+    | r == xmm7 -> 24+    | r == xmm8 -> 25+    | r == xmm9 -> 26+    | r == xmm10 -> 27+    | r == xmm11 -> 28+    | r == xmm12 -> 29+    | r == xmm13 -> 30+    | r == xmm14 -> 31+    | r == xmm15 -> 32+  _other -> error "dwarfRegNo: Unsupported platform or unknown register!"++-- | Virtual register number to use for return address.+dwarfReturnRegNo :: Platform -> Word8+dwarfReturnRegNo p+  -- We "overwrite" IP with our pseudo register - that makes sense, as+  -- when using this mechanism gdb already knows the IP anyway. Clang+  -- does this too, so it must be safe.+  = case platformArch p of+    ArchX86    -> 8  -- eip+    ArchX86_64 -> 16 -- rip+    _other     -> error "dwarfReturnRegNo: Unsupported platform!"
+ nativeGen/Dwarf/Types.hs view
@@ -0,0 +1,602 @@+module Dwarf.Types+  ( -- * Dwarf information+    DwarfInfo(..)+  , pprDwarfInfo+  , pprAbbrevDecls+    -- * Dwarf address range table+  , DwarfARange(..)+  , pprDwarfARanges+    -- * Dwarf frame+  , DwarfFrame(..), DwarfFrameProc(..), DwarfFrameBlock(..)+  , pprDwarfFrame+    -- * Utilities+  , pprByte+  , pprHalf+  , pprData4'+  , pprDwWord+  , pprWord+  , pprLEBWord+  , pprLEBInt+  , wordAlign+  , sectionOffset+  )+  where++import Debug+import CLabel+import CmmExpr         ( GlobalReg(..) )+import Encoding+import FastString+import Outputable+import Platform+import Unique+import Reg+import SrcLoc++import Dwarf.Constants++import qualified Control.Monad.Trans.State.Strict as S+import Control.Monad (zipWithM, join)+import Data.Bits+import qualified Data.Map as Map+import Data.Word+import Data.Char++import CodeGen.Platform++-- | Individual dwarf records. Each one will be encoded as an entry in+-- the @.debug_info@ section.+data DwarfInfo+  = DwarfCompileUnit { dwChildren :: [DwarfInfo]+                     , dwName :: String+                     , dwProducer :: String+                     , dwCompDir :: String+                     , dwLowLabel :: CLabel+                     , dwHighLabel :: CLabel+                     , dwLineLabel :: LitString }+  | DwarfSubprogram { dwChildren :: [DwarfInfo]+                    , dwName :: String+                    , dwLabel :: CLabel+                    , dwParent :: Maybe CLabel+                      -- ^ label of DIE belonging to the parent tick+                    }+  | DwarfBlock { dwChildren :: [DwarfInfo]+               , dwLabel :: CLabel+               , dwMarker :: Maybe CLabel+               }+  | DwarfSrcNote { dwSrcSpan :: RealSrcSpan+                 }++-- | Abbreviation codes used for encoding above records in the+-- @.debug_info@ section.+data DwarfAbbrev+  = DwAbbrNull          -- ^ Pseudo, used for marking the end of lists+  | DwAbbrCompileUnit+  | DwAbbrSubprogram+  | DwAbbrSubprogramWithParent+  | DwAbbrBlockWithoutCode+  | DwAbbrBlock+  | DwAbbrGhcSrcNote+  deriving (Eq, Enum)++-- | Generate assembly for the given abbreviation code+pprAbbrev :: DwarfAbbrev -> SDoc+pprAbbrev = pprLEBWord . fromIntegral . fromEnum++-- | Abbreviation declaration. This explains the binary encoding we+-- use for representing 'DwarfInfo'. Be aware that this must be updated+-- along with 'pprDwarfInfo'.+pprAbbrevDecls :: Bool -> SDoc+pprAbbrevDecls haveDebugLine =+  let mkAbbrev abbr tag chld flds =+        let fld (tag, form) = pprLEBWord tag $$ pprLEBWord form+        in pprAbbrev abbr $$ pprLEBWord tag $$ pprByte chld $$+           vcat (map fld flds) $$ pprByte 0 $$ pprByte 0+      -- These are shared between DwAbbrSubprogram and+      -- DwAbbrSubprogramWithParent+      subprogramAttrs =+           [ (dW_AT_name, dW_FORM_string)+           , (dW_AT_MIPS_linkage_name, dW_FORM_string)+           , (dW_AT_external, dW_FORM_flag)+           , (dW_AT_low_pc, dW_FORM_addr)+           , (dW_AT_high_pc, dW_FORM_addr)+           , (dW_AT_frame_base, dW_FORM_block1)+           ]+  in dwarfAbbrevSection $$+     ptext dwarfAbbrevLabel <> colon $$+     mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes+       ([(dW_AT_name,     dW_FORM_string)+       , (dW_AT_producer, dW_FORM_string)+       , (dW_AT_language, dW_FORM_data4)+       , (dW_AT_comp_dir, dW_FORM_string)+       , (dW_AT_use_UTF8, dW_FORM_flag_present)  -- not represented in body+       , (dW_AT_low_pc,   dW_FORM_addr)+       , (dW_AT_high_pc,  dW_FORM_addr)+       ] +++       (if haveDebugLine+        then [ (dW_AT_stmt_list, dW_FORM_data4) ]+        else [])) $$+     mkAbbrev DwAbbrSubprogram dW_TAG_subprogram dW_CHILDREN_yes+       subprogramAttrs $$+     mkAbbrev DwAbbrSubprogramWithParent dW_TAG_subprogram dW_CHILDREN_yes+       (subprogramAttrs ++ [(dW_AT_ghc_tick_parent, dW_FORM_ref_addr)]) $$+     mkAbbrev DwAbbrBlockWithoutCode dW_TAG_lexical_block dW_CHILDREN_yes+       [ (dW_AT_name, dW_FORM_string)+       ] $$+     mkAbbrev DwAbbrBlock dW_TAG_lexical_block dW_CHILDREN_yes+       [ (dW_AT_name, dW_FORM_string)+       , (dW_AT_low_pc, dW_FORM_addr)+       , (dW_AT_high_pc, dW_FORM_addr)+       ] $$+     mkAbbrev DwAbbrGhcSrcNote dW_TAG_ghc_src_note dW_CHILDREN_no+       [ (dW_AT_ghc_span_file, dW_FORM_string)+       , (dW_AT_ghc_span_start_line, dW_FORM_data4)+       , (dW_AT_ghc_span_start_col, dW_FORM_data2)+       , (dW_AT_ghc_span_end_line, dW_FORM_data4)+       , (dW_AT_ghc_span_end_col, dW_FORM_data2)+       ] $$+     pprByte 0++-- | Generate assembly for DWARF data+pprDwarfInfo :: Bool -> DwarfInfo -> SDoc+pprDwarfInfo haveSrc d+  = case d of+      DwarfCompileUnit {}  -> hasChildren+      DwarfSubprogram {}   -> hasChildren+      DwarfBlock {}        -> hasChildren+      DwarfSrcNote {}      -> noChildren+  where+    hasChildren =+        pprDwarfInfoOpen haveSrc d $$+        vcat (map (pprDwarfInfo haveSrc) (dwChildren d)) $$+        pprDwarfInfoClose+    noChildren = pprDwarfInfoOpen haveSrc d++-- | Prints assembler data corresponding to DWARF info records. Note+-- that the binary format of this is parameterized in @abbrevDecls@ and+-- has to be kept in synch.+pprDwarfInfoOpen :: Bool -> DwarfInfo -> SDoc+pprDwarfInfoOpen haveSrc (DwarfCompileUnit _ name producer compDir lowLabel+                                           highLabel lineLbl) =+  pprAbbrev DwAbbrCompileUnit+  $$ pprString name+  $$ pprString producer+  $$ pprData4 dW_LANG_Haskell+  $$ pprString compDir+  $$ pprWord (ppr lowLabel)+  $$ pprWord (ppr highLabel)+  $$ if haveSrc+     then sectionOffset (ptext lineLbl) (ptext dwarfLineLabel)+     else empty+pprDwarfInfoOpen _ (DwarfSubprogram _ name label+                                    parent) = sdocWithDynFlags $ \df ->+  ppr (mkAsmTempDieLabel label) <> colon+  $$ pprAbbrev abbrev+  $$ pprString name+  $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))+  $$ pprFlag (externallyVisibleCLabel label)+  $$ pprWord (ppr label)+  $$ pprWord (ppr $ mkAsmTempEndLabel label)+  $$ pprByte 1+  $$ pprByte dW_OP_call_frame_cfa+  $$ parentValue+  where+    abbrev = case parent of Nothing -> DwAbbrSubprogram+                            Just _  -> DwAbbrSubprogramWithParent+    parentValue = maybe empty pprParentDie parent+    pprParentDie sym = sectionOffset (ppr sym) (ptext dwarfInfoLabel)+pprDwarfInfoOpen _ (DwarfBlock _ label Nothing) = sdocWithDynFlags $ \df ->+  ppr (mkAsmTempDieLabel label) <> colon+  $$ pprAbbrev DwAbbrBlockWithoutCode+  $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))+pprDwarfInfoOpen _ (DwarfBlock _ label (Just marker)) = sdocWithDynFlags $ \df ->+  ppr (mkAsmTempDieLabel label) <> colon+  $$ pprAbbrev DwAbbrBlock+  $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))+  $$ pprWord (ppr marker)+  $$ pprWord (ppr $ mkAsmTempEndLabel marker)+pprDwarfInfoOpen _ (DwarfSrcNote ss) =+  pprAbbrev DwAbbrGhcSrcNote+  $$ pprString' (ftext $ srcSpanFile ss)+  $$ pprData4 (fromIntegral $ srcSpanStartLine ss)+  $$ pprHalf (fromIntegral $ srcSpanStartCol ss)+  $$ pprData4 (fromIntegral $ srcSpanEndLine ss)+  $$ pprHalf (fromIntegral $ srcSpanEndCol ss)++-- | Close a DWARF info record with children+pprDwarfInfoClose :: SDoc+pprDwarfInfoClose = pprAbbrev DwAbbrNull++-- | A DWARF address range. This is used by the debugger to quickly locate+-- which compilation unit a given address belongs to. This type assumes+-- a non-segmented address-space.+data DwarfARange+  = DwarfARange+    { dwArngStartLabel :: CLabel+    , dwArngEndLabel   :: CLabel+    }++-- | Print assembler directives corresponding to a DWARF @.debug_aranges@+-- address table entry.+pprDwarfARanges :: [DwarfARange] -> Unique -> SDoc+pprDwarfARanges arngs unitU = sdocWithPlatform $ \plat ->+  let wordSize = platformWordSize plat+      paddingSize = 4 :: Int+      -- header is 12 bytes long.+      -- entry is 8 bytes (32-bit platform) or 16 bytes (64-bit platform).+      -- pad such that first entry begins at multiple of entry size.+      pad n = vcat $ replicate n $ pprByte 0+      initialLength = 8 + paddingSize + 2*2*wordSize+  in pprDwWord (ppr initialLength)+     $$ pprHalf 2+     $$ sectionOffset (ppr $ mkAsmTempLabel $ unitU)+                      (ptext dwarfInfoLabel)+     $$ pprByte (fromIntegral wordSize)+     $$ pprByte 0+     $$ pad paddingSize+     -- body+     $$ vcat (map pprDwarfARange arngs)+     -- terminus+     $$ pprWord (char '0')+     $$ pprWord (char '0')++pprDwarfARange :: DwarfARange -> SDoc+pprDwarfARange arng = pprWord (ppr $ dwArngStartLabel arng) $$ pprWord length+  where+    length = ppr (dwArngEndLabel arng)+             <> char '-' <> ppr (dwArngStartLabel arng)++-- | Information about unwind instructions for a procedure. This+-- corresponds to a "Common Information Entry" (CIE) in DWARF.+data DwarfFrame+  = DwarfFrame+    { dwCieLabel :: CLabel+    , dwCieInit  :: UnwindTable+    , dwCieProcs :: [DwarfFrameProc]+    }++-- | Unwind instructions for an individual procedure. Corresponds to a+-- "Frame Description Entry" (FDE) in DWARF.+data DwarfFrameProc+  = DwarfFrameProc+    { dwFdeProc    :: CLabel+    , dwFdeHasInfo :: Bool+    , dwFdeBlocks  :: [DwarfFrameBlock]+      -- ^ List of blocks. Order must match asm!+    }++-- | Unwind instructions for a block. Will become part of the+-- containing FDE.+data DwarfFrameBlock+  = DwarfFrameBlock+    { dwFdeBlkHasInfo :: Bool+    , dwFdeUnwind     :: [UnwindPoint]+      -- ^ these unwind points must occur in the same order as they occur+      -- in the block+    }++instance Outputable DwarfFrameBlock where+  ppr (DwarfFrameBlock hasInfo unwinds) = braces $ ppr hasInfo <+> ppr unwinds++-- | Header for the @.debug_frame@ section. Here we emit the "Common+-- Information Entry" record that etablishes general call frame+-- parameters and the default stack layout.+pprDwarfFrame :: DwarfFrame -> SDoc+pprDwarfFrame DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs}+  = sdocWithPlatform $ \plat ->+    let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start")+        cieEndLabel = mkAsmTempEndLabel cieLabel+        length      = ppr cieEndLabel <> char '-' <> ppr cieStartLabel+        spReg       = dwarfGlobalRegNo plat Sp+        retReg      = dwarfReturnRegNo plat+        wordSize    = platformWordSize plat+        pprInit :: (GlobalReg, Maybe UnwindExpr) -> SDoc+        pprInit (g, uw) = pprSetUnwind plat g (Nothing, uw)++        -- Preserve C stack pointer: This necessary to override that default+        -- unwinding behavior of setting $sp = CFA.+        preserveSp = case platformArch plat of+          ArchX86    -> pprByte dW_CFA_same_value $$ pprLEBWord 4+          ArchX86_64 -> pprByte dW_CFA_same_value $$ pprLEBWord 7+          _          -> empty+    in vcat [ ppr cieLabel <> colon+            , pprData4' length -- Length of CIE+            , ppr cieStartLabel <> colon+            , pprData4' (text "-1")+                               -- Common Information Entry marker (-1 = 0xf..f)+            , pprByte 3        -- CIE version (we require DWARF 3)+            , pprByte 0        -- Augmentation (none)+            , pprByte 1        -- Code offset multiplicator+            , pprByte (128-fromIntegral wordSize)+                               -- Data offset multiplicator+                               -- (stacks grow down => "-w" in signed LEB128)+            , pprByte retReg   -- virtual register holding return address+            ] $$+       -- Initial unwind table+       vcat (map pprInit $ Map.toList cieInit) $$+       vcat [ -- RET = *CFA+              pprByte (dW_CFA_offset+retReg)+            , pprByte 0++              -- Preserve C stack pointer+            , preserveSp++              -- Sp' = CFA+              -- (we need to set this manually as our (STG) Sp register is+              -- often not the architecture's default stack register)+            , pprByte dW_CFA_val_offset+            , pprLEBWord (fromIntegral spReg)+            , pprLEBWord 0+            ] $$+       wordAlign $$+       ppr cieEndLabel <> colon $$+       -- Procedure unwind tables+       vcat (map (pprFrameProc cieLabel cieInit) procs)++-- | Writes a "Frame Description Entry" for a procedure. This consists+-- mainly of referencing the CIE and writing state machine+-- instructions to describe how the frame base (CFA) changes.+pprFrameProc :: CLabel -> UnwindTable -> DwarfFrameProc -> SDoc+pprFrameProc frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks)+  = let fdeLabel    = mkAsmTempDerivedLabel procLbl (fsLit "_fde")+        fdeEndLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde_end")+        procEnd     = mkAsmTempEndLabel procLbl+        ifInfo str  = if hasInfo then text str else empty+                      -- see [Note: Info Offset]+    in vcat [ ifPprDebug $ text "# Unwinding for" <+> ppr procLbl <> colon+            , pprData4' (ppr fdeEndLabel <> char '-' <> ppr fdeLabel)+            , ppr fdeLabel <> colon+            , pprData4' (ppr frameLbl <> char '-' <>+                         ptext dwarfFrameLabel)    -- Reference to CIE+            , pprWord (ppr procLbl <> ifInfo "-1") -- Code pointer+            , pprWord (ppr procEnd <> char '-' <>+                       ppr procLbl <> ifInfo "+1") -- Block byte length+            ] $$+       vcat (S.evalState (mapM pprFrameBlock blocks) initUw) $$+       wordAlign $$+       ppr fdeEndLabel <> colon++-- | Generates unwind information for a block. We only generate+-- instructions where unwind information actually changes. This small+-- optimisations saves a lot of space, as subsequent blocks often have+-- the same unwind information.+pprFrameBlock :: DwarfFrameBlock -> S.State UnwindTable SDoc+pprFrameBlock (DwarfFrameBlock hasInfo uws0) =+    vcat <$> zipWithM pprFrameDecl (True : repeat False) uws0+  where+    pprFrameDecl :: Bool -> UnwindPoint -> S.State UnwindTable SDoc+    pprFrameDecl firstDecl (UnwindPoint lbl uws) = S.state $ \oldUws ->+        let -- Did a register's unwind expression change?+            isChanged :: GlobalReg -> Maybe UnwindExpr+                      -> Maybe (Maybe UnwindExpr, Maybe UnwindExpr)+            isChanged g new+                -- the value didn't change+              | Just new == old = Nothing+                -- the value was and still is undefined+              | Nothing <- old+              , Nothing <- new  = Nothing+                -- the value changed+              | otherwise       = Just (join old, new)+              where+                old = Map.lookup g oldUws++            changed = Map.toList $ Map.mapMaybeWithKey isChanged uws++        in if oldUws == uws+             then (empty, oldUws)+             else let -- see [Note: Info Offset]+                      needsOffset = firstDecl && hasInfo+                      lblDoc = ppr lbl <>+                               if needsOffset then text "-1" else empty+                      doc = sdocWithPlatform $ \plat ->+                           pprByte dW_CFA_set_loc $$ pprWord lblDoc $$+                           vcat (map (uncurry $ pprSetUnwind plat) changed)+                  in (doc, uws)++-- Note [Info Offset]+--+-- GDB was pretty much written with C-like programs in mind, and as a+-- result they assume that once you have a return address, it is a+-- good idea to look at (PC-1) to unwind further - as that's where the+-- "call" instruction is supposed to be.+--+-- Now on one hand, code generated by GHC looks nothing like what GDB+-- expects, and in fact going up from a return pointer is guaranteed+-- to land us inside an info table! On the other hand, that actually+-- gives us some wiggle room, as we expect IP to never *actually* end+-- up inside the info table, so we can "cheat" by putting whatever GDB+-- expects to see there. This is probably pretty safe, as GDB cannot+-- assume (PC-1) to be a valid code pointer in the first place - and I+-- have seen no code trying to correct this.+--+-- Note that this will not prevent GDB from failing to look-up the+-- correct function name for the frame, as that uses the symbol table,+-- which we can not manipulate as easily.++-- | Get DWARF register ID for a given GlobalReg+dwarfGlobalRegNo :: Platform -> GlobalReg -> Word8+dwarfGlobalRegNo p UnwindReturnReg = dwarfReturnRegNo p+dwarfGlobalRegNo p reg = maybe 0 (dwarfRegNo p . RegReal) $ globalRegMaybe p reg++-- | Generate code for setting the unwind information for a register,+-- optimized using its known old value in the table. Note that "Sp" is+-- special: We see it as synonym for the CFA.+pprSetUnwind :: Platform+             -> GlobalReg+                -- ^ the register to produce an unwinding table entry for+             -> (Maybe UnwindExpr, Maybe UnwindExpr)+                -- ^ the old and new values of the register+             -> SDoc+pprSetUnwind plat g  (_, Nothing)+  = pprUndefUnwind plat g+pprSetUnwind _    Sp (Just (UwReg s _), Just (UwReg s' o')) | s == s'+  = if o' >= 0+    then pprByte dW_CFA_def_cfa_offset $$ pprLEBWord (fromIntegral o')+    else pprByte dW_CFA_def_cfa_offset_sf $$ pprLEBInt o'+pprSetUnwind plat Sp (_, Just (UwReg s' o'))+  = if o' >= 0+    then pprByte dW_CFA_def_cfa $$+         pprLEBRegNo plat s' $$+         pprLEBWord (fromIntegral o')+    else pprByte dW_CFA_def_cfa_sf $$+         pprLEBRegNo plat s' $$+         pprLEBInt o'+pprSetUnwind _    Sp (_, Just uw)+  = pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr False uw+pprSetUnwind plat g  (_, Just (UwDeref (UwReg Sp o)))+  | o < 0 && ((-o) `mod` platformWordSize plat) == 0 -- expected case+  = pprByte (dW_CFA_offset + dwarfGlobalRegNo plat g) $$+    pprLEBWord (fromIntegral ((-o) `div` platformWordSize plat))+  | otherwise+  = pprByte dW_CFA_offset_extended_sf $$+    pprLEBRegNo plat g $$+    pprLEBInt o+pprSetUnwind plat g  (_, Just (UwDeref uw))+  = pprByte dW_CFA_expression $$+    pprLEBRegNo plat g $$+    pprUnwindExpr True uw+pprSetUnwind plat g  (_, Just (UwReg g' 0))+  | g == g'+  = pprByte dW_CFA_same_value $$+    pprLEBRegNo plat g+pprSetUnwind plat g  (_, Just uw)+  = pprByte dW_CFA_val_expression $$+    pprLEBRegNo plat g $$+    pprUnwindExpr True uw++-- | Print the register number of the given 'GlobalReg' as an unsigned LEB128+-- encoded number.+pprLEBRegNo :: Platform -> GlobalReg -> SDoc+pprLEBRegNo plat = pprLEBWord . fromIntegral . dwarfGlobalRegNo plat++-- | Generates a DWARF expression for the given unwind expression. If+-- @spIsCFA@ is true, we see @Sp@ as the frame base CFA where it gets+-- mentioned.+pprUnwindExpr :: Bool -> UnwindExpr -> SDoc+pprUnwindExpr spIsCFA expr+  = sdocWithPlatform $ \plat ->+    let pprE (UwConst i)+          | i >= 0 && i < 32 = pprByte (dW_OP_lit0 + fromIntegral i)+          | otherwise        = pprByte dW_OP_consts $$ pprLEBInt i -- lazy...+        pprE (UwReg Sp i) | spIsCFA+                             = if i == 0+                               then pprByte dW_OP_call_frame_cfa+                               else pprE (UwPlus (UwReg Sp 0) (UwConst i))+        pprE (UwReg g i)      = pprByte (dW_OP_breg0+dwarfGlobalRegNo plat g) $$+                               pprLEBInt i+        pprE (UwDeref u)      = pprE u $$ pprByte dW_OP_deref+        pprE (UwLabel l)      = pprByte dW_OP_addr $$ pprWord (ppr l)+        pprE (UwPlus u1 u2)   = pprE u1 $$ pprE u2 $$ pprByte dW_OP_plus+        pprE (UwMinus u1 u2)  = pprE u1 $$ pprE u2 $$ pprByte dW_OP_minus+        pprE (UwTimes u1 u2)  = pprE u1 $$ pprE u2 $$ pprByte dW_OP_mul+    in text "\t.uleb128 1f-.-1" $$ -- DW_FORM_block length+       pprE expr $$+       text "1:"++-- | Generate code for re-setting the unwind information for a+-- register to @undefined@+pprUndefUnwind :: Platform -> GlobalReg -> SDoc+pprUndefUnwind plat g  = pprByte dW_CFA_undefined $$+                         pprLEBRegNo plat g+++-- | Align assembly at (machine) word boundary+wordAlign :: SDoc+wordAlign = sdocWithPlatform $ \plat ->+  text "\t.align " <> case platformOS plat of+    OSDarwin -> case platformWordSize plat of+      8      -> text "3"+      4      -> text "2"+      _other -> error "wordAlign: Unsupported word size!"+    _other   -> ppr (platformWordSize plat)++-- | Assembly for a single byte of constant DWARF data+pprByte :: Word8 -> SDoc+pprByte x = text "\t.byte " <> ppr (fromIntegral x :: Word)++-- | Assembly for a two-byte constant integer+pprHalf :: Word16 -> SDoc+pprHalf x = text "\t.short" <+> ppr (fromIntegral x :: Word)++-- | Assembly for a constant DWARF flag+pprFlag :: Bool -> SDoc+pprFlag f = pprByte (if f then 0xff else 0x00)++-- | Assembly for 4 bytes of dynamic DWARF data+pprData4' :: SDoc -> SDoc+pprData4' x = text "\t.long " <> x++-- | Assembly for 4 bytes of constant DWARF data+pprData4 :: Word -> SDoc+pprData4 = pprData4' . ppr++-- | Assembly for a DWARF word of dynamic data. This means 32 bit, as+-- we are generating 32 bit DWARF.+pprDwWord :: SDoc -> SDoc+pprDwWord = pprData4'++-- | Assembly for a machine word of dynamic data. Depends on the+-- architecture we are currently generating code for.+pprWord :: SDoc -> SDoc+pprWord s = (<> s) . sdocWithPlatform $ \plat ->+  case platformWordSize plat of+    4 -> text "\t.long "+    8 -> text "\t.quad "+    n -> panic $ "pprWord: Unsupported target platform word length " +++                 show n ++ "!"++-- | Prints a number in "little endian base 128" format. The idea is+-- to optimize for small numbers by stopping once all further bytes+-- would be 0. The highest bit in every byte signals whether there+-- are further bytes to read.+pprLEBWord :: Word -> SDoc+pprLEBWord x | x < 128   = pprByte (fromIntegral x)+             | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$+                           pprLEBWord (x `shiftR` 7)++-- | Same as @pprLEBWord@, but for a signed number+pprLEBInt :: Int -> SDoc+pprLEBInt x | x >= -64 && x < 64+                        = pprByte (fromIntegral (x .&. 127))+            | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$+                          pprLEBInt (x `shiftR` 7)++-- | Generates a dynamic null-terminated string. If required the+-- caller needs to make sure that the string is escaped properly.+pprString' :: SDoc -> SDoc+pprString' str = text "\t.asciz \"" <> str <> char '"'++-- | Generate a string constant. We take care to escape the string.+pprString :: String -> SDoc+pprString str+  = pprString' $ hcat $ map escapeChar $+    if utf8EncodedLength str == length str+    then str+    else map (chr . fromIntegral) $ bytesFS $ mkFastString str++-- | Escape a single non-unicode character+escapeChar :: Char -> SDoc+escapeChar '\\' = text "\\\\"+escapeChar '\"' = text "\\\""+escapeChar '\n' = text "\\n"+escapeChar c+  | isAscii c && isPrint c && c /= '?' -- prevents trigraph warnings+  = char c+  | otherwise+  = char '\\' <> char (intToDigit (ch `div` 64)) <>+                 char (intToDigit ((ch `div` 8) `mod` 8)) <>+                 char (intToDigit (ch `mod` 8))+  where ch = ord c++-- | Generate an offset into another section. This is tricky because+-- this is handled differently depending on platform: Mac Os expects+-- us to calculate the offset using assembler arithmetic. Linux expects+-- us to just reference the target directly, and will figure out on+-- their own that we actually need an offset. Finally, Windows has+-- a special directive to refer to relative offsets. Fun.+sectionOffset :: SDoc -> SDoc -> SDoc+sectionOffset target section = sdocWithPlatform $ \plat ->+  case platformOS plat of+    OSDarwin  -> pprDwWord (target <> char '-' <> section)+    OSMinGW32 -> text "\t.secrel32 " <> target+    _other    -> pprDwWord target
+ nativeGen/Format.hs view
@@ -0,0 +1,104 @@+-- | Formats on this architecture+--      A Format is a combination of width and class+--+--      TODO:   Signed vs unsigned?+--+--      TODO:   This module is currenly shared by all architectures because+--              NCGMonad need to know about it to make a VReg. It would be better+--              to have architecture specific formats, and do the overloading+--              properly. eg SPARC doesn't care about FF80.+--+module Format (+    Format(..),+    intFormat,+    floatFormat,+    isFloatFormat,+    cmmTypeFormat,+    formatToWidth,+    formatInBytes+)++where++import Cmm+import Outputable++-- It looks very like the old MachRep, but it's now of purely local+-- significance, here in the native code generator.  You can change it+-- without global consequences.+--+-- A major use is as an opcode qualifier; thus the opcode+--      mov.l a b+-- might be encoded+--      MOV II32 a b+-- where the Format field encodes the ".l" part.++-- ToDo: it's not clear to me that we need separate signed-vs-unsigned formats+--        here.  I've removed them from the x86 version, we'll see what happens --SDM++-- ToDo: quite a few occurrences of Format could usefully be replaced by Width++data Format+        = II8+        | II16+        | II32+        | II64+        | FF32+        | FF64+        | FF80+        deriving (Show, Eq)+++-- | Get the integer format of this width.+intFormat :: Width -> Format+intFormat width+ = case width of+        W8      -> II8+        W16     -> II16+        W32     -> II32+        W64     -> II64+        other   -> sorry $ "The native code generator cannot " +++            "produce code for Format.intFormat " ++ show other+            ++ "\n\tConsider using the llvm backend with -fllvm"+++-- | Get the float format of this width.+floatFormat :: Width -> Format+floatFormat width+ = case width of+        W32     -> FF32+        W64     -> FF64+        other   -> pprPanic "Format.floatFormat" (ppr other)+++-- | Check if a format represents a floating point value.+isFloatFormat :: Format -> Bool+isFloatFormat format+ = case format of+        FF32    -> True+        FF64    -> True+        FF80    -> True+        _       -> False+++-- | Convert a Cmm type to a Format.+cmmTypeFormat :: CmmType -> Format+cmmTypeFormat ty+        | isFloatType ty        = floatFormat (typeWidth ty)+        | otherwise             = intFormat (typeWidth ty)+++-- | Get the Width of a Format.+formatToWidth :: Format -> Width+formatToWidth format+ = case format of+        II8             -> W8+        II16            -> W16+        II32            -> W32+        II64            -> W64+        FF32            -> W32+        FF64            -> W64+        FF80            -> W80++formatInBytes :: Format -> Int+formatInBytes = widthInBytes . formatToWidth
+ nativeGen/Instruction.hs view
@@ -0,0 +1,201 @@++module Instruction (+        RegUsage(..),+        noUsage,+        GenBasicBlock(..), blockId,+        ListGraph(..),+        NatCmm,+        NatCmmDecl,+        NatBasicBlock,+        topInfoTable,+        entryBlocks,+        Instruction(..)+)++where++import Reg++import BlockId+import Hoopl+import DynFlags+import Cmm hiding (topInfoTable)+import Platform++-- | Holds a list of source and destination registers used by a+--      particular instruction.+--+--   Machine registers that are pre-allocated to stgRegs are filtered+--      out, because they are uninteresting from a register allocation+--      standpoint.  (We wouldn't want them to end up on the free list!)+--+--   As far as we are concerned, the fixed registers simply don't exist+--      (for allocation purposes, anyway).+--+data RegUsage+        = RU [Reg] [Reg]++-- | No regs read or written to.+noUsage :: RegUsage+noUsage  = RU [] []++-- Our flavours of the Cmm types+-- Type synonyms for Cmm populated with native code+type NatCmm instr+        = GenCmmGroup+                CmmStatics+                (LabelMap CmmStatics)+                (ListGraph instr)++type NatCmmDecl statics instr+        = GenCmmDecl+                statics+                (LabelMap CmmStatics)+                (ListGraph instr)+++type NatBasicBlock instr+        = GenBasicBlock instr+++-- | Returns the info table associated with the CmmDecl's entry point,+-- if any.+topInfoTable :: GenCmmDecl a (LabelMap i) (ListGraph b) -> Maybe i+topInfoTable (CmmProc infos _ _ (ListGraph (b:_)))+  = mapLookup (blockId b) infos+topInfoTable _+  = Nothing++-- | Return the list of BlockIds in a CmmDecl that are entry points+-- for this proc (i.e. they may be jumped to from outside this proc).+entryBlocks :: GenCmmDecl a (LabelMap i) (ListGraph b) -> [BlockId]+entryBlocks (CmmProc info _ _ (ListGraph code)) = entries+  where+        infos = mapKeys info+        entries = case code of+                    [] -> infos+                    BasicBlock entry _ : _ -- first block is the entry point+                       | entry `elem` infos -> infos+                       | otherwise          -> entry : infos+entryBlocks _ = []++-- | Common things that we can do with instructions, on all architectures.+--      These are used by the shared parts of the native code generator,+--      specifically the register allocators.+--+class   Instruction instr where++        -- | Get the registers that are being used by this instruction.+        --      regUsage doesn't need to do any trickery for jumps and such.+        --      Just state precisely the regs read and written by that insn.+        --      The consequences of control flow transfers, as far as register+        --      allocation goes, are taken care of by the register allocator.+        --+        regUsageOfInstr+                :: Platform+                -> instr+                -> RegUsage+++        -- | Apply a given mapping to all the register references in this+        --      instruction.+        patchRegsOfInstr+                :: instr+                -> (Reg -> Reg)+                -> instr+++        -- | Checks whether this instruction is a jump/branch instruction.+        --      One that can change the flow of control in a way that the+        --      register allocator needs to worry about.+        isJumpishInstr+                :: instr -> Bool+++        -- | Give the possible destinations of this jump instruction.+        --      Must be defined for all jumpish instructions.+        jumpDestsOfInstr+                :: instr -> [BlockId]+++        -- | Change the destination of this jump instruction.+        --      Used in the linear allocator when adding fixup blocks for join+        --      points.+        patchJumpInstr+                :: instr+                -> (BlockId -> BlockId)+                -> instr+++        -- | An instruction to spill a register into a spill slot.+        mkSpillInstr+                :: DynFlags+                -> Reg          -- ^ the reg to spill+                -> Int          -- ^ the current stack delta+                -> Int          -- ^ spill slot to use+                -> instr+++        -- | An instruction to reload a register from a spill slot.+        mkLoadInstr+                :: DynFlags+                -> Reg          -- ^ the reg to reload.+                -> Int          -- ^ the current stack delta+                -> Int          -- ^ the spill slot to use+                -> instr++        -- | See if this instruction is telling us the current C stack delta+        takeDeltaInstr+                :: instr+                -> Maybe Int++        -- | Check whether this instruction is some meta thing inserted into+        --      the instruction stream for other purposes.+        --+        --      Not something that has to be treated as a real machine instruction+        --      and have its registers allocated.+        --+        --      eg, comments, delta, ldata, etc.+        isMetaInstr+                :: instr+                -> Bool++++        -- | Copy the value in a register to another one.+        --      Must work for all register classes.+        mkRegRegMoveInstr+                :: Platform+                -> Reg          -- ^ source register+                -> Reg          -- ^ destination register+                -> instr++        -- | Take the source and destination from this reg -> reg move instruction+        --      or Nothing if it's not one+        takeRegRegMoveInstr+                :: instr+                -> Maybe (Reg, Reg)++        -- | Make an unconditional jump instruction.+        --      For architectures with branch delay slots, its ok to put+        --      a NOP after the jump. Don't fill the delay slot with an+        --      instruction that references regs or you'll confuse the+        --      linear allocator.+        mkJumpInstr+                :: BlockId+                -> [instr]+++        -- Subtract an amount from the C stack pointer+        mkStackAllocInstr+                :: Platform  -- TODO: remove (needed by x86/x86_64+                             -- because they share an Instr type)+                -> Int+                -> instr++        -- Add an amount to the C stack pointer+        mkStackDeallocInstr+                :: Platform  -- TODO: remove (needed by x86/x86_64+                             -- because they share an Instr type)+                -> Int+                -> instr
+ nativeGen/NCG.h view
@@ -0,0 +1,14 @@+/* -----------------------------------------------------------------------------++   (c) The University of Glasgow, 1994-2004++   Native-code generator header file - just useful macros for now.++   -------------------------------------------------------------------------- */++#ifndef NCG_H+#define NCG_H++#include "ghc_boot_platform.h"++#endif
+ nativeGen/NCGMonad.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE CPP #-}++-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow 1993-2004+--+-- The native code generator's monad.+--+-- -----------------------------------------------------------------------------++module NCGMonad (+        NatM_State(..), mkNatM_State,++        NatM, -- instance Monad+        initNat,+        addImportNat,+        getUniqueNat,+        mapAccumLNat,+        setDeltaNat,+        getDeltaNat,+        getThisModuleNat,+        getBlockIdNat,+        getNewLabelNat,+        getNewRegNat,+        getNewRegPairNat,+        getPicBaseMaybeNat,+        getPicBaseNat,+        getDynFlags,+        getModLoc,+        getFileId,+        getDebugBlock,++        DwarfFiles+)++where++#include "HsVersions.h"++import Reg+import Format+import TargetReg++import BlockId+import Hoopl+import CLabel           ( CLabel, mkAsmTempLabel )+import Debug+import FastString       ( FastString )+import UniqFM+import UniqSupply+import Unique           ( Unique )+import DynFlags+import Module++import Control.Monad    ( liftM, ap )++import Compiler.Hoopl   ( LabelMap, Label )++data NatM_State+        = NatM_State {+                natm_us          :: UniqSupply,+                natm_delta       :: Int,+                natm_imports     :: [(CLabel)],+                natm_pic         :: Maybe Reg,+                natm_dflags      :: DynFlags,+                natm_this_module :: Module,+                natm_modloc      :: ModLocation,+                natm_fileid      :: DwarfFiles,+                natm_debug_map   :: LabelMap DebugBlock+        }++type DwarfFiles = UniqFM (FastString, Int)++newtype NatM result = NatM (NatM_State -> (result, NatM_State))++unNat :: NatM a -> NatM_State -> (a, NatM_State)+unNat (NatM a) = a++mkNatM_State :: UniqSupply -> Int -> DynFlags -> Module -> ModLocation ->+                DwarfFiles -> LabelMap DebugBlock -> NatM_State+mkNatM_State us delta dflags this_mod+        = NatM_State us delta [] Nothing dflags this_mod++initNat :: NatM_State -> NatM a -> (a, NatM_State)+initNat init_st m+        = case unNat m init_st of { (r,st) -> (r,st) }++instance Functor NatM where+      fmap = liftM++instance Applicative NatM where+      pure = returnNat+      (<*>) = ap++instance Monad NatM where+  (>>=) = thenNat++instance MonadUnique NatM where+  getUniqueSupplyM = NatM $ \st ->+      case splitUniqSupply (natm_us st) of+          (us1, us2) -> (us1, st {natm_us = us2})++  getUniqueM = NatM $ \st ->+      case takeUniqFromSupply (natm_us st) of+          (uniq, us') -> (uniq, st {natm_us = us'})++thenNat :: NatM a -> (a -> NatM b) -> NatM b+thenNat expr cont+        = NatM $ \st -> case unNat expr st of+                        (result, st') -> unNat (cont result) st'++returnNat :: a -> NatM a+returnNat result+        = NatM $ \st ->  (result, st)++mapAccumLNat :: (acc -> x -> NatM (acc, y))+                -> acc+                -> [x]+                -> NatM (acc, [y])++mapAccumLNat _ b []+  = return (b, [])+mapAccumLNat f b (x:xs)+  = do (b__2, x__2)  <- f b x+       (b__3, xs__2) <- mapAccumLNat f b__2 xs+       return (b__3, x__2:xs__2)++getUniqueNat :: NatM Unique+getUniqueNat = NatM $ \ st ->+    case takeUniqFromSupply $ natm_us st of+    (uniq, us') -> (uniq, st {natm_us = us'})++instance HasDynFlags NatM where+    getDynFlags = NatM $ \ st -> (natm_dflags st, st)+++getDeltaNat :: NatM Int+getDeltaNat = NatM $ \ st -> (natm_delta st, st)+++setDeltaNat :: Int -> NatM ()+setDeltaNat delta = NatM $ \ st -> ((), st {natm_delta = delta})+++getThisModuleNat :: NatM Module+getThisModuleNat = NatM $ \ st -> (natm_this_module st, st)+++addImportNat :: CLabel -> NatM ()+addImportNat imp+        = NatM $ \ st -> ((), st {natm_imports = imp : natm_imports st})+++getBlockIdNat :: NatM BlockId+getBlockIdNat+ = do   u <- getUniqueNat+        return (mkBlockId u)+++getNewLabelNat :: NatM CLabel+getNewLabelNat+ = do   u <- getUniqueNat+        return (mkAsmTempLabel u)+++getNewRegNat :: Format -> NatM Reg+getNewRegNat rep+ = do u <- getUniqueNat+      dflags <- getDynFlags+      return (RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep)+++getNewRegPairNat :: Format -> NatM (Reg,Reg)+getNewRegPairNat rep+ = do u <- getUniqueNat+      dflags <- getDynFlags+      let vLo = targetMkVirtualReg (targetPlatform dflags) u rep+      let lo  = RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep+      let hi  = RegVirtual $ getHiVirtualRegFromLo vLo+      return (lo, hi)+++getPicBaseMaybeNat :: NatM (Maybe Reg)+getPicBaseMaybeNat+        = NatM (\state -> (natm_pic state, state))+++getPicBaseNat :: Format -> NatM Reg+getPicBaseNat rep+ = do   mbPicBase <- getPicBaseMaybeNat+        case mbPicBase of+                Just picBase -> return picBase+                Nothing+                 -> do+                        reg <- getNewRegNat rep+                        NatM (\state -> (reg, state { natm_pic = Just reg }))++getModLoc :: NatM ModLocation+getModLoc+        = NatM $ \ st -> (natm_modloc st, st)++getFileId :: FastString -> NatM Int+getFileId f = NatM $ \st ->+  case lookupUFM (natm_fileid st) f of+    Just (_,n) -> (n, st)+    Nothing    -> let n = 1 + sizeUFM (natm_fileid st)+                      fids = addToUFM (natm_fileid st) f (f,n)+                  in n `seq` fids `seq` (n, st { natm_fileid = fids  })++getDebugBlock :: Label -> NatM (Maybe DebugBlock)+getDebugBlock l = NatM $ \st -> (mapLookup l (natm_debug_map st), st)
+ nativeGen/PIC.hs view
@@ -0,0 +1,898 @@+{-+  This module handles generation of position independent code and+  dynamic-linking related issues for the native code generator.++  This depends both the architecture and OS, so we define it here+  instead of in one of the architecture specific modules.++  Things outside this module which are related to this:++  + module CLabel+    - PIC base label (pretty printed as local label 1)+    - DynamicLinkerLabels - several kinds:+        CodeStub, SymbolPtr, GotSymbolPtr, GotSymbolOffset+    - labelDynamic predicate+  + module Cmm+    - The GlobalReg datatype has a PicBaseReg constructor+    - The CmmLit datatype has a CmmLabelDiffOff constructor+  + codeGen & RTS+    - When tablesNextToCode, no absolute addresses are stored in info tables+      any more. Instead, offsets from the info label are used.+    - For Win32 only, SRTs might contain addresses of __imp_ symbol pointers+      because Win32 doesn't support external references in data sections.+      TODO: make sure this still works, it might be bitrotted+  + NCG+    - The cmmToCmm pass in AsmCodeGen calls cmmMakeDynamicReference for all+      labels.+    - nativeCodeGen calls pprImportedSymbol and pprGotDeclaration to output+      all the necessary stuff for imported symbols.+    - The NCG monad keeps track of a list of imported symbols.+    - MachCodeGen invokes initializePicBase to generate code to initialize+      the PIC base register when needed.+    - MachCodeGen calls cmmMakeDynamicReference whenever it uses a CLabel+      that wasn't in the original Cmm code (e.g. floating point literals).+-}++module PIC (+        cmmMakeDynamicReference,+        CmmMakeDynamicReferenceM(..),+        ReferenceKind(..),+        needImportedSymbols,+        pprImportedSymbol,+        pprGotDeclaration,++        initializePicBase_ppc,+        initializePicBase_x86+)++where++import qualified PPC.Instr      as PPC+import qualified PPC.Regs       as PPC++import qualified X86.Instr      as X86++import Platform+import Instruction+import Reg+import NCGMonad+++import Hoopl+import Cmm+import CLabel           ( CLabel, ForeignLabelSource(..), pprCLabel,+                          mkDynamicLinkerLabel, DynamicLinkerLabelInfo(..),+                          dynamicLinkerLabelInfo, mkPicBaseLabel,+                          labelDynamic, externallyVisibleCLabel )++import CLabel           ( mkForeignLabel )+++import BasicTypes+import Module++import Outputable++import DynFlags+import FastString++++--------------------------------------------------------------------------------+-- It gets called by the cmmToCmm pass for every CmmLabel in the Cmm+-- code. It does The Right Thing(tm) to convert the CmmLabel into a+-- position-independent, dynamic-linking-aware reference to the thing+-- in question.+-- Note that this also has to be called from MachCodeGen in order to+-- access static data like floating point literals (labels that were+-- created after the cmmToCmm pass).+-- The function must run in a monad that can keep track of imported symbols+-- A function for recording an imported symbol must be passed in:+-- - addImportCmmOpt for the CmmOptM monad+-- - addImportNat for the NatM monad.++data ReferenceKind+        = DataReference+        | CallReference+        | JumpReference+        deriving(Eq)++class Monad m => CmmMakeDynamicReferenceM m where+    addImport :: CLabel -> m ()+    getThisModule :: m Module++instance CmmMakeDynamicReferenceM NatM where+    addImport = addImportNat+    getThisModule = getThisModuleNat++cmmMakeDynamicReference+  :: CmmMakeDynamicReferenceM m+  => DynFlags+  -> ReferenceKind     -- whether this is the target of a jump+  -> CLabel            -- the label+  -> m CmmExpr++cmmMakeDynamicReference dflags referenceKind lbl+  | Just _ <- dynamicLinkerLabelInfo lbl+  = return $ CmmLit $ CmmLabel lbl   -- already processed it, pass through++  | otherwise+  = do this_mod <- getThisModule+       case howToAccessLabel+                dflags+                (platformArch $ targetPlatform dflags)+                (platformOS   $ targetPlatform dflags)+                this_mod+                referenceKind lbl of++        AccessViaStub -> do+              let stub = mkDynamicLinkerLabel CodeStub lbl+              addImport stub+              return $ CmmLit $ CmmLabel stub++        AccessViaSymbolPtr -> do+              let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl+              addImport symbolPtr+              return $ CmmLoad (cmmMakePicReference dflags symbolPtr) (bWord dflags)++        AccessDirectly -> case referenceKind of+                -- for data, we might have to make some calculations:+              DataReference -> return $ cmmMakePicReference dflags lbl+                -- all currently supported processors support+                -- PC-relative branch and call instructions,+                -- so just jump there if it's a call or a jump+              _ -> return $ CmmLit $ CmmLabel lbl+++-- -----------------------------------------------------------------------------+-- Create a position independent reference to a label.+-- (but do not bother with dynamic linking).+-- We calculate the label's address by adding some (platform-dependent)+-- offset to our base register; this offset is calculated by+-- the function picRelative in the platform-dependent part below.++cmmMakePicReference :: DynFlags -> CLabel -> CmmExpr+cmmMakePicReference dflags lbl++        -- Windows doesn't need PIC,+        -- everything gets relocated at runtime+        | OSMinGW32 <- platformOS $ targetPlatform dflags+        = CmmLit $ CmmLabel lbl++        | OSAIX <- platformOS $ targetPlatform dflags+        = CmmMachOp (MO_Add W32)+                [ CmmReg (CmmGlobal PicBaseReg)+                , CmmLit $ picRelative+                                (platformArch   $ targetPlatform dflags)+                                (platformOS     $ targetPlatform dflags)+                                lbl ]++        -- both ABI versions default to medium code model+        | ArchPPC_64 _ <- platformArch $ targetPlatform dflags+        = CmmMachOp (MO_Add W32) -- code model medium+                [ CmmReg (CmmGlobal PicBaseReg)+                , CmmLit $ picRelative+                                (platformArch   $ targetPlatform dflags)+                                (platformOS     $ targetPlatform dflags)+                                lbl ]++        | (gopt Opt_PIC dflags || WayDyn `elem` ways dflags) && absoluteLabel lbl+        = CmmMachOp (MO_Add (wordWidth dflags))+                [ CmmReg (CmmGlobal PicBaseReg)+                , CmmLit $ picRelative+                                (platformArch   $ targetPlatform dflags)+                                (platformOS     $ targetPlatform dflags)+                                lbl ]++        | otherwise+        = CmmLit $ CmmLabel lbl+++absoluteLabel :: CLabel -> Bool+absoluteLabel lbl+ = case dynamicLinkerLabelInfo lbl of+        Just (GotSymbolPtr, _)    -> False+        Just (GotSymbolOffset, _) -> False+        _                         -> True+++--------------------------------------------------------------------------------+-- Knowledge about how special dynamic linker labels like symbol+-- pointers, code stubs and GOT offsets look like is located in the+-- module CLabel.++-- We have to decide which labels need to be accessed+-- indirectly or via a piece of stub code.+data LabelAccessStyle+        = AccessViaStub+        | AccessViaSymbolPtr+        | AccessDirectly++howToAccessLabel+        :: DynFlags -> Arch -> OS -> Module -> ReferenceKind -> CLabel -> LabelAccessStyle+++-- Windows+-- In Windows speak, a "module" is a set of objects linked into the+-- same Portable Exectuable (PE) file. (both .exe and .dll files are PEs).+--+-- If we're compiling a multi-module program then symbols from other modules+-- are accessed by a symbol pointer named __imp_SYMBOL. At runtime we have the+-- following.+--+--   (in the local module)+--     __imp_SYMBOL: addr of SYMBOL+--+--   (in the other module)+--     SYMBOL: the real function / data.+--+-- To access the function at SYMBOL from our local module, we just need to+-- dereference the local __imp_SYMBOL.+--+-- If not compiling with -dynamic we assume that all our code will be linked+-- into the same .exe file. In this case we always access symbols directly,+-- and never use __imp_SYMBOL.+--+howToAccessLabel dflags _ OSMinGW32 this_mod _ lbl++        -- Assume all symbols will be in the same PE, so just access them directly.+        | WayDyn `notElem` ways dflags+        = AccessDirectly++        -- If the target symbol is in another PE we need to access it via the+        --      appropriate __imp_SYMBOL pointer.+        | labelDynamic dflags this_mod lbl+        = AccessViaSymbolPtr++        -- Target symbol is in the same PE as the caller, so just access it directly.+        | otherwise+        = AccessDirectly+++-- Mach-O (Darwin, Mac OS X)+--+-- Indirect access is required in the following cases:+--  * things imported from a dynamic library+--  * (not on x86_64) data from a different module, if we're generating PIC code+-- It is always possible to access something indirectly,+-- even when it's not necessary.+--+howToAccessLabel dflags arch OSDarwin this_mod DataReference lbl+        -- data access to a dynamic library goes via a symbol pointer+        | labelDynamic dflags this_mod lbl+        = AccessViaSymbolPtr++        -- when generating PIC code, all cross-module data references must+        -- must go via a symbol pointer, too, because the assembler+        -- cannot generate code for a label difference where one+        -- label is undefined. Doesn't apply t x86_64.+        -- Unfortunately, we don't know whether it's cross-module,+        -- so we do it for all externally visible labels.+        -- This is a slight waste of time and space, but otherwise+        -- we'd need to pass the current Module all the way in to+        -- this function.+        | arch /= ArchX86_64+        , gopt Opt_PIC dflags && externallyVisibleCLabel lbl+        = AccessViaSymbolPtr++        | otherwise+        = AccessDirectly++howToAccessLabel dflags arch OSDarwin this_mod JumpReference lbl+        -- dyld code stubs don't work for tailcalls because the+        -- stack alignment is only right for regular calls.+        -- Therefore, we have to go via a symbol pointer:+        | arch == ArchX86 || arch == ArchX86_64+        , labelDynamic dflags this_mod lbl+        = AccessViaSymbolPtr+++howToAccessLabel dflags arch OSDarwin this_mod _ lbl+        -- Code stubs are the usual method of choice for imported code;+        -- not needed on x86_64 because Apple's new linker, ld64, generates+        -- them automatically.+        | arch /= ArchX86_64+        , labelDynamic dflags this_mod lbl+        = AccessViaStub++        | otherwise+        = AccessDirectly+++----------------------------------------------------------------------------+-- AIX++-- quite simple (for now)+howToAccessLabel _dflags _arch OSAIX _this_mod kind _lbl+        = case kind of+            DataReference -> AccessViaSymbolPtr+            CallReference -> AccessDirectly+            JumpReference -> AccessDirectly++-- ELF (Linux)+--+-- ELF tries to pretend to the main application code that dynamic linking does+-- not exist. While this may sound convenient, it tends to mess things up in+-- very bad ways, so we have to be careful when we generate code for the main+-- program (-dynamic but no -fPIC).+--+-- Indirect access is required for references to imported symbols+-- from position independent code. It is also required from the main program+-- when dynamic libraries containing Haskell code are used.++howToAccessLabel _ (ArchPPC_64 _) os _ kind _+        | osElfTarget os+        = case kind of+          -- ELF PPC64 (powerpc64-linux), AIX, MacOS 9, BeOS/PPC+          DataReference -> AccessViaSymbolPtr+          -- RTLD does not generate stubs for function descriptors+          -- in tail calls. Create a symbol pointer and generate+          -- the code to load the function descriptor at the call site.+          JumpReference -> AccessViaSymbolPtr+          -- regular calls are handled by the runtime linker+          _             -> AccessDirectly++howToAccessLabel dflags _ os _ _ _+        -- no PIC -> the dynamic linker does everything for us;+        --           if we don't dynamically link to Haskell code,+        --           it actually manages to do so without messing things up.+        | osElfTarget os+        , not (gopt Opt_PIC dflags) && WayDyn `notElem` ways dflags+        = AccessDirectly++howToAccessLabel dflags arch os this_mod DataReference lbl+        | osElfTarget os+        = case () of+            -- A dynamic label needs to be accessed via a symbol pointer.+          _ | labelDynamic dflags this_mod lbl+            -> AccessViaSymbolPtr++            -- For PowerPC32 -fPIC, we have to access even static data+            -- via a symbol pointer (see below for an explanation why+            -- PowerPC32 Linux is especially broken).+            | arch == ArchPPC+            , gopt Opt_PIC dflags+            -> AccessViaSymbolPtr++            | otherwise+            -> AccessDirectly+++        -- In most cases, we have to avoid symbol stubs on ELF, for the following reasons:+        --   on i386, the position-independent symbol stubs in the Procedure Linkage Table+        --   require the address of the GOT to be loaded into register %ebx on entry.+        --   The linker will take any reference to the symbol stub as a hint that+        --   the label in question is a code label. When linking executables, this+        --   will cause the linker to replace even data references to the label with+        --   references to the symbol stub.++        -- This leaves calling a (foreign) function from non-PIC code+        -- (AccessDirectly, because we get an implicit symbol stub)+        -- and calling functions from PIC code on non-i386 platforms (via a symbol stub)++howToAccessLabel dflags arch os this_mod CallReference lbl+        | osElfTarget os+        , labelDynamic dflags this_mod lbl && not (gopt Opt_PIC dflags)+        = AccessDirectly++        | osElfTarget os+        , arch /= ArchX86+        , labelDynamic dflags this_mod lbl && gopt Opt_PIC dflags+        = AccessViaStub++howToAccessLabel dflags _ os this_mod _ lbl+        | osElfTarget os+        = if labelDynamic dflags this_mod lbl+            then AccessViaSymbolPtr+            else AccessDirectly++-- all other platforms+howToAccessLabel dflags _ _ _ _ _+        | not (gopt Opt_PIC dflags)+        = AccessDirectly++        | otherwise+        = panic "howToAccessLabel: PIC not defined for this platform"++++-- -------------------------------------------------------------------+-- | Says what we we have to add to our 'PIC base register' in order to+--      get the address of a label.++picRelative :: Arch -> OS -> CLabel -> CmmLit++-- Darwin, but not x86_64:+-- The PIC base register points to the PIC base label at the beginning+-- of the current CmmDecl. We just have to use a label difference to+-- get the offset.+-- We have already made sure that all labels that are not from the current+-- module are accessed indirectly ('as' can't calculate differences between+-- undefined labels).+picRelative arch OSDarwin lbl+        | arch /= ArchX86_64+        = CmmLabelDiffOff lbl mkPicBaseLabel 0++-- On AIX we use an indirect local TOC anchored by 'gotLabel'.+-- This way we use up only one global TOC entry per compilation-unit+-- (this is quite similiar to GCC's @-mminimal-toc@ compilation mode)+picRelative _ OSAIX lbl+        = CmmLabelDiffOff lbl gotLabel 0++-- PowerPC Linux:+-- The PIC base register points to our fake GOT. Use a label difference+-- to get the offset.+-- We have made sure that *everything* is accessed indirectly, so this+-- is only used for offsets from the GOT to symbol pointers inside the+-- GOT.+picRelative ArchPPC os lbl+        | osElfTarget os+        = CmmLabelDiffOff lbl gotLabel 0+++-- Most Linux versions:+-- The PIC base register points to the GOT. Use foo@got for symbol+-- pointers, and foo@gotoff for everything else.+-- Linux and Darwin on x86_64:+-- The PIC base register is %rip, we use foo@gotpcrel for symbol pointers,+-- and a GotSymbolOffset label for other things.+-- For reasons of tradition, the symbol offset label is written as a plain label.+picRelative arch os lbl+        | osElfTarget os || (os == OSDarwin && arch == ArchX86_64)+        = let   result+                        | Just (SymbolPtr, lbl') <- dynamicLinkerLabelInfo lbl+                        = CmmLabel $ mkDynamicLinkerLabel GotSymbolPtr lbl'++                        | otherwise+                        = CmmLabel $ mkDynamicLinkerLabel GotSymbolOffset lbl++          in    result++picRelative _ _ _+        = panic "PositionIndependentCode.picRelative undefined for this platform"++++--------------------------------------------------------------------------------++needImportedSymbols :: DynFlags -> Arch -> OS -> Bool+needImportedSymbols dflags arch os+        | os    == OSDarwin+        , arch  /= ArchX86_64+        = True++        | os    == OSAIX+        = True++        -- PowerPC Linux: -fPIC or -dynamic+        | osElfTarget os+        , arch  == ArchPPC+        = gopt Opt_PIC dflags || WayDyn `elem` ways dflags++        -- PowerPC 64 Linux: always+        | osElfTarget os+        , arch == ArchPPC_64 ELF_V1 || arch == ArchPPC_64 ELF_V2+        = True++        -- i386 (and others?): -dynamic but not -fPIC+        | osElfTarget os+        , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2+        = WayDyn `elem` ways dflags && not (gopt Opt_PIC dflags)++        | otherwise+        = False++-- gotLabel+-- The label used to refer to our "fake GOT" from+-- position-independent code.+gotLabel :: CLabel+gotLabel+        -- HACK: this label isn't really foreign+        = mkForeignLabel+                (fsLit ".LCTOC1")+                Nothing ForeignLabelInThisPackage IsData++++--------------------------------------------------------------------------------+-- We don't need to declare any offset tables.+-- However, for PIC on x86, we need a small helper function.+pprGotDeclaration :: DynFlags -> Arch -> OS -> SDoc+pprGotDeclaration dflags ArchX86 OSDarwin+        | gopt Opt_PIC dflags+        = vcat [+                text ".section __TEXT,__textcoal_nt,coalesced,no_toc",+                text ".weak_definition ___i686.get_pc_thunk.ax",+                text ".private_extern ___i686.get_pc_thunk.ax",+                text "___i686.get_pc_thunk.ax:",+                text "\tmovl (%esp), %eax",+                text "\tret" ]++pprGotDeclaration _ _ OSDarwin+        = empty++-- Emit XCOFF TOC section+pprGotDeclaration _ _ OSAIX+        = vcat $ [ text ".toc"+                 , text ".tc ghc_toc_table[TC],.LCTOC1"+                 , text ".csect ghc_toc_table[RW]"+                   -- See Note [.LCTOC1 in PPC PIC code]+                 , text ".set .LCTOC1,$+0x8000"+                 ]+++-- PPC 64 ELF v1 needs a Table Of Contents (TOC) on Linux+pprGotDeclaration _ (ArchPPC_64 ELF_V1) OSLinux+        = text ".section \".toc\",\"aw\""+-- In ELF v2 we also need to tell the assembler that we want ABI+-- version 2. This would normally be done at the top of the file+-- right after a file directive, but I could not figure out how+-- to do that.+pprGotDeclaration _ (ArchPPC_64 ELF_V2) OSLinux+        = vcat [ text ".abiversion 2",+                 text ".section \".toc\",\"aw\""+               ]+pprGotDeclaration _ (ArchPPC_64 _) _+        = panic "pprGotDeclaration: ArchPPC_64 only Linux supported"++-- Emit GOT declaration+-- Output whatever needs to be output once per .s file.+pprGotDeclaration dflags arch os+        | osElfTarget os+        , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2+        , not (gopt Opt_PIC dflags)+        = empty++        | osElfTarget os+        , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2+        = vcat [+                -- See Note [.LCTOC1 in PPC PIC code]+                text ".section \".got2\",\"aw\"",+                text ".LCTOC1 = .+32768" ]++pprGotDeclaration _ _ _+        = panic "pprGotDeclaration: no match"+++--------------------------------------------------------------------------------+-- On Darwin, we have to generate our own stub code for lazy binding..+-- For each processor architecture, there are two versions, one for PIC+-- and one for non-PIC.+--+-- Whenever you change something in this assembler output, make sure+-- the splitter in driver/split/ghc-split.pl recognizes the new output++pprImportedSymbol :: DynFlags -> Platform -> CLabel -> SDoc+pprImportedSymbol dflags platform@(Platform { platformArch = ArchPPC, platformOS = OSDarwin }) importedLbl+        | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl+        = case gopt Opt_PIC dflags of+           False ->+            vcat [+                text ".symbol_stub",+                text "L" <> pprCLabel platform lbl <> ptext (sLit "$stub:"),+                    text "\t.indirect_symbol" <+> pprCLabel platform lbl,+                    text "\tlis r11,ha16(L" <> pprCLabel platform lbl+                        <> text "$lazy_ptr)",+                    text "\tlwz r12,lo16(L" <> pprCLabel platform lbl+                        <> text "$lazy_ptr)(r11)",+                    text "\tmtctr r12",+                    text "\taddi r11,r11,lo16(L" <> pprCLabel platform lbl+                        <> text "$lazy_ptr)",+                    text "\tbctr"+            ]+           True ->+            vcat [+                text ".section __TEXT,__picsymbolstub1,"+                  <> text "symbol_stubs,pure_instructions,32",+                text "\t.align 2",+                text "L" <> pprCLabel platform lbl <> ptext (sLit "$stub:"),+                    text "\t.indirect_symbol" <+> pprCLabel platform lbl,+                    text "\tmflr r0",+                    text "\tbcl 20,31,L0$" <> pprCLabel platform lbl,+                text "L0$" <> pprCLabel platform lbl <> char ':',+                    text "\tmflr r11",+                    text "\taddis r11,r11,ha16(L" <> pprCLabel platform lbl+                        <> text "$lazy_ptr-L0$" <> pprCLabel platform lbl <> char ')',+                    text "\tmtlr r0",+                    text "\tlwzu r12,lo16(L" <> pprCLabel platform lbl+                        <> text "$lazy_ptr-L0$" <> pprCLabel platform lbl+                        <> text ")(r11)",+                    text "\tmtctr r12",+                    text "\tbctr"+            ]+          $+$ vcat [+                text ".lazy_symbol_pointer",+                text "L" <> pprCLabel platform lbl <> ptext (sLit "$lazy_ptr:"),+                text "\t.indirect_symbol" <+> pprCLabel platform lbl,+                text "\t.long dyld_stub_binding_helper"]++        | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl+        = vcat [+                text ".non_lazy_symbol_pointer",+                char 'L' <> pprCLabel platform lbl <> text "$non_lazy_ptr:",+                text "\t.indirect_symbol" <+> pprCLabel platform lbl,+                text "\t.long\t0"]++        | otherwise+        = empty+++pprImportedSymbol dflags platform@(Platform { platformArch = ArchX86, platformOS = OSDarwin }) importedLbl+        | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl+        = case gopt Opt_PIC dflags of+           False ->+            vcat [+                text ".symbol_stub",+                text "L" <> pprCLabel platform lbl <> ptext (sLit "$stub:"),+                    text "\t.indirect_symbol" <+> pprCLabel platform lbl,+                    text "\tjmp *L" <> pprCLabel platform lbl+                        <> text "$lazy_ptr",+                text "L" <> pprCLabel platform lbl+                    <> text "$stub_binder:",+                    text "\tpushl $L" <> pprCLabel platform lbl+                        <> text "$lazy_ptr",+                    text "\tjmp dyld_stub_binding_helper"+            ]+           True ->+            vcat [+                text ".section __TEXT,__picsymbolstub2,"+                    <> text "symbol_stubs,pure_instructions,25",+                text "L" <> pprCLabel platform lbl <> ptext (sLit "$stub:"),+                    text "\t.indirect_symbol" <+> pprCLabel platform lbl,+                    text "\tcall ___i686.get_pc_thunk.ax",+                text "1:",+                    text "\tmovl L" <> pprCLabel platform lbl+                        <> text "$lazy_ptr-1b(%eax),%edx",+                    text "\tjmp *%edx",+                text "L" <> pprCLabel platform lbl+                    <> text "$stub_binder:",+                    text "\tlea L" <> pprCLabel platform lbl+                        <> text "$lazy_ptr-1b(%eax),%eax",+                    text "\tpushl %eax",+                    text "\tjmp dyld_stub_binding_helper"+            ]+          $+$ vcat [        text ".section __DATA, __la_sym_ptr"+                    <> (if gopt Opt_PIC dflags then int 2 else int 3)+                    <> text ",lazy_symbol_pointers",+                text "L" <> pprCLabel platform lbl <> ptext (sLit "$lazy_ptr:"),+                    text "\t.indirect_symbol" <+> pprCLabel platform lbl,+                    text "\t.long L" <> pprCLabel platform lbl+                    <> text "$stub_binder"]++        | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl+        = vcat [+                text ".non_lazy_symbol_pointer",+                char 'L' <> pprCLabel platform lbl <> text "$non_lazy_ptr:",+                text "\t.indirect_symbol" <+> pprCLabel platform lbl,+                text "\t.long\t0"]++        | otherwise+        = empty+++pprImportedSymbol _ (Platform { platformOS = OSDarwin }) _+        = empty++-- XCOFF / AIX+--+-- Similiar to PPC64 ELF v1, there's dedicated TOC register (r2). To+-- workaround the limitation of a global TOC we use an indirect TOC+-- with the label `ghc_toc_table`.+--+-- See also GCC's `-mminimal-toc` compilation mode or+-- http://www.ibm.com/developerworks/rational/library/overview-toc-aix/+--+-- NB: No DSO-support yet++pprImportedSymbol _ platform@(Platform { platformOS = OSAIX }) importedLbl+        = case dynamicLinkerLabelInfo importedLbl of+            Just (SymbolPtr, lbl)+              -> vcat [+                   text "LC.." <> pprCLabel platform lbl <> char ':',+                   text "\t.long" <+> pprCLabel platform lbl ]+            _ -> empty++-- ELF / Linux+--+-- In theory, we don't need to generate any stubs or symbol pointers+-- by hand for Linux.+--+-- Reality differs from this in two areas.+--+-- 1) If we just use a dynamically imported symbol directly in a read-only+--    section of the main executable (as GCC does), ld generates R_*_COPY+--    relocations, which are fundamentally incompatible with reversed info+--    tables. Therefore, we need a table of imported addresses in a writable+--    section.+--    The "official" GOT mechanism (label@got) isn't intended to be used+--    in position dependent code, so we have to create our own "fake GOT"+--    when not Opt_PIC && WayDyn `elem` ways dflags.+--+-- 2) PowerPC Linux is just plain broken.+--    While it's theoretically possible to use GOT offsets larger+--    than 16 bit, the standard crt*.o files don't, which leads to+--    linker errors as soon as the GOT size exceeds 16 bit.+--    Also, the assembler doesn't support @gotoff labels.+--    In order to be able to use a larger GOT, we have to circumvent the+--    entire GOT mechanism and do it ourselves (this is also what GCC does).+++-- When needImportedSymbols is defined,+-- the NCG will keep track of all DynamicLinkerLabels it uses+-- and output each of them using pprImportedSymbol.++pprImportedSymbol _ platform@(Platform { platformArch = ArchPPC_64 _ })+                  importedLbl+        | osElfTarget (platformOS platform)+        = case dynamicLinkerLabelInfo importedLbl of+            Just (SymbolPtr, lbl)+              -> vcat [+                   text ".section \".toc\", \"aw\"",+                   text ".LC_" <> pprCLabel platform lbl <> char ':',+                   text "\t.quad" <+> pprCLabel platform lbl ]+            _ -> empty++pprImportedSymbol dflags platform importedLbl+        | osElfTarget (platformOS platform)+        = case dynamicLinkerLabelInfo importedLbl of+            Just (SymbolPtr, lbl)+              -> let symbolSize = case wordWidth dflags of+                         W32 -> sLit "\t.long"+                         W64 -> sLit "\t.quad"+                         _ -> panic "Unknown wordRep in pprImportedSymbol"++                 in vcat [+                      text ".section \".got2\", \"aw\"",+                      text ".LC_" <> pprCLabel platform lbl <> char ':',+                      ptext symbolSize <+> pprCLabel platform lbl ]++            -- PLT code stubs are generated automatically by the dynamic linker.+            _ -> empty++pprImportedSymbol _ _ _+        = panic "PIC.pprImportedSymbol: no match"++--------------------------------------------------------------------------------+-- Generate code to calculate the address that should be put in the+-- PIC base register.+-- This is called by MachCodeGen for every CmmProc that accessed the+-- PIC base register. It adds the appropriate instructions to the+-- top of the CmmProc.++-- It is assumed that the first NatCmmDecl in the input list is a Proc+-- and the rest are CmmDatas.++-- Darwin is simple: just fetch the address of a local label.+-- The FETCHPC pseudo-instruction is expanded to multiple instructions+-- during pretty-printing so that we don't have to deal with the+-- local label:++-- PowerPC version:+--          bcl 20,31,1f.+--      1:  mflr picReg++-- i386 version:+--          call 1f+--      1:  popl %picReg++++-- Get a pointer to our own fake GOT, which is defined on a per-module basis.+-- This is exactly how GCC does it in linux.++initializePicBase_ppc+        :: Arch -> OS -> Reg+        -> [NatCmmDecl CmmStatics PPC.Instr]+        -> NatM [NatCmmDecl CmmStatics PPC.Instr]++initializePicBase_ppc ArchPPC os picReg+    (CmmProc info lab live (ListGraph blocks) : statics)+    | osElfTarget os+    = do+        let+            gotOffset = PPC.ImmConstantDiff+                                (PPC.ImmCLbl gotLabel)+                                (PPC.ImmCLbl mkPicBaseLabel)++            blocks' = case blocks of+                       [] -> []+                       (b:bs) -> fetchPC b : map maybeFetchPC bs++            maybeFetchPC b@(BasicBlock bID _)+              | bID `mapMember` info = fetchPC b+              | otherwise            = b++            -- GCC does PIC prologs thusly:+            --     bcl 20,31,.L1+            -- .L1:+            --     mflr 30+            --     addis 30,30,.LCTOC1-.L1@ha+            --     addi 30,30,.LCTOC1-.L1@l+            -- TODO: below we use it over temporary register,+            -- it can and should be optimised by picking+            -- correct PIC reg.+            fetchPC (BasicBlock bID insns) =+              BasicBlock bID (PPC.FETCHPC picReg+                              : PPC.ADDIS picReg picReg (PPC.HA gotOffset)+                              : PPC.ADD picReg picReg+                                        (PPC.RIImm (PPC.LO gotOffset))+                              : PPC.MR PPC.r30 picReg+                              : insns)++        return (CmmProc info lab live (ListGraph blocks') : statics)+++initializePicBase_ppc ArchPPC OSDarwin picReg+        (CmmProc info lab live (ListGraph (entry:blocks)) : statics) -- just one entry because of splitting+        = return (CmmProc info lab live (ListGraph (b':blocks)) : statics)++        where   BasicBlock bID insns = entry+                b' = BasicBlock bID (PPC.FETCHPC picReg : insns)++-------------------------------------------------------------------------+-- Load TOC into register 2+-- PowerPC 64-bit ELF ABI 2.0 requires the address of the callee+-- in register 12.+-- We pass the label to FETCHTOC and create a .localentry too.+-- TODO: Explain this better and refer to ABI spec!+{-+We would like to do approximately this, but spill slot allocation+might be added before the first BasicBlock. That violates the ABI.++For now we will emit the prologue code in the pretty printer,+which is also what we do for ELF v1.+initializePicBase_ppc (ArchPPC_64 ELF_V2) OSLinux picReg+        (CmmProc info lab live (ListGraph (entry:blocks)) : statics)+        = do+           bID <-getUniqueM+           return (CmmProc info lab live (ListGraph (b':entry:blocks))+                                         : statics)+        where   BasicBlock entryID _ = entry+                b' = BasicBlock bID [PPC.FETCHTOC picReg lab,+                                     PPC.BCC PPC.ALWAYS entryID]+-}++initializePicBase_ppc _ _ _ _+        = panic "initializePicBase_ppc: not needed"+++-- We cheat a bit here by defining a pseudo-instruction named FETCHGOT+-- which pretty-prints as:+--              call 1f+-- 1:           popl %picReg+--              addl __GLOBAL_OFFSET_TABLE__+.-1b, %picReg+-- (See PprMach.hs)++initializePicBase_x86+        :: Arch -> OS -> Reg+        -> [NatCmmDecl (Alignment, CmmStatics) X86.Instr]+        -> NatM [NatCmmDecl (Alignment, CmmStatics) X86.Instr]++initializePicBase_x86 ArchX86 os picReg+        (CmmProc info lab live (ListGraph blocks) : statics)+    | osElfTarget os+    = return (CmmProc info lab live (ListGraph blocks') : statics)+    where blocks' = case blocks of+                     [] -> []+                     (b:bs) -> fetchGOT b : map maybeFetchGOT bs++          -- we want to add a FETCHGOT instruction to the beginning of+          -- every block that is an entry point, which corresponds to+          -- the blocks that have entries in the info-table mapping.+          maybeFetchGOT b@(BasicBlock bID _)+            | bID `mapMember` info = fetchGOT b+            | otherwise            = b++          fetchGOT (BasicBlock bID insns) =+             BasicBlock bID (X86.FETCHGOT picReg : insns)++initializePicBase_x86 ArchX86 OSDarwin picReg+        (CmmProc info lab live (ListGraph (entry:blocks)) : statics)+        = return (CmmProc info lab live (ListGraph (block':blocks)) : statics)++    where BasicBlock bID insns = entry+          block' = BasicBlock bID (X86.FETCHPC picReg : insns)++initializePicBase_x86 _ _ _ _+        = panic "initializePicBase_x86: not needed"+
+ nativeGen/PPC/CodeGen.hs view
@@ -0,0 +1,2307 @@+{-# LANGUAGE CPP, GADTs #-}++-----------------------------------------------------------------------------+--+-- Generating machine code (instruction selection)+--+-- (c) The University of Glasgow 1996-2004+--+-----------------------------------------------------------------------------++-- This is a big module, but, if you pay attention to+-- (a) the sectioning, and (b) the type signatures,+-- the structure should not be too overwhelming.++module PPC.CodeGen (+        cmmTopCodeGen,+        generateJumpTableForInstr,+        InstrBlock+)++where++#include "HsVersions.h"+#include "nativeGen/NCG.h"+#include "MachDeps.h"++-- NCG stuff:+import CodeGen.Platform+import PPC.Instr+import PPC.Cond+import PPC.Regs+import CPrim+import NCGMonad+import Instruction+import PIC+import Format+import RegClass+import Reg+import TargetReg+import Platform++-- Our intermediate code:+import BlockId+import PprCmm           ( pprExpr )+import Cmm+import CmmUtils+import CmmSwitch+import CLabel+import Hoopl++-- The rest:+import OrdList+import Outputable+import Unique+import DynFlags++import Control.Monad    ( mapAndUnzipM, when )+import Data.Bits+import Data.Word++import BasicTypes+import FastString+import Util++-- -----------------------------------------------------------------------------+-- Top-level of the instruction selector++-- | 'InstrBlock's are the insn sequences generated by the insn selectors.+-- They are really trees of insns to facilitate fast appending, where a+-- left-to-right traversal (pre-order?) yields the insns in the correct+-- order.++cmmTopCodeGen+        :: RawCmmDecl+        -> NatM [NatCmmDecl CmmStatics Instr]++cmmTopCodeGen (CmmProc info lab live graph) = do+  let blocks = toBlockListEntryFirst graph+  (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks+  dflags <- getDynFlags+  let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)+      tops = proc : concat statics+      os   = platformOS $ targetPlatform dflags+      arch = platformArch $ targetPlatform dflags+  case arch of+    ArchPPC | os == OSAIX -> return tops+            | otherwise -> do+      picBaseMb <- getPicBaseMaybeNat+      case picBaseMb of+           Just picBase -> initializePicBase_ppc arch os picBase tops+           Nothing -> return tops+    ArchPPC_64 ELF_V1 -> return tops+                      -- generating function descriptor is handled in+                      -- pretty printer+    ArchPPC_64 ELF_V2 -> return tops+                      -- generating function prologue is handled in+                      -- pretty printer+    _          -> panic "PPC.cmmTopCodeGen: unknown arch"++cmmTopCodeGen (CmmData sec dat) = do+  return [CmmData sec dat]  -- no translation, we just use CmmStatic++basicBlockCodeGen+        :: Block CmmNode C C+        -> NatM ( [NatBasicBlock Instr]+                , [NatCmmDecl CmmStatics Instr])++basicBlockCodeGen block = do+  let (_, nodes, tail)  = blockSplit block+      id = entryLabel block+      stmts = blockToList nodes+  mid_instrs <- stmtsToInstrs stmts+  tail_instrs <- stmtToInstrs tail+  let instrs = mid_instrs `appOL` tail_instrs+  -- code generation may introduce new basic block boundaries, which+  -- are indicated by the NEWBLOCK instruction.  We must split up the+  -- instruction stream into basic blocks again.  Also, we extract+  -- LDATAs here too.+  let+        (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs++        mkBlocks (NEWBLOCK id) (instrs,blocks,statics)+          = ([], BasicBlock id instrs : blocks, statics)+        mkBlocks (LDATA sec dat) (instrs,blocks,statics)+          = (instrs, blocks, CmmData sec dat:statics)+        mkBlocks instr (instrs,blocks,statics)+          = (instr:instrs, blocks, statics)+  return (BasicBlock id top : other_blocks, statics)++stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock+stmtsToInstrs stmts+   = do instrss <- mapM stmtToInstrs stmts+        return (concatOL instrss)++stmtToInstrs :: CmmNode e x -> NatM InstrBlock+stmtToInstrs stmt = do+  dflags <- getDynFlags+  case stmt of+    CmmComment s   -> return (unitOL (COMMENT s))+    CmmTick {}     -> return nilOL+    CmmUnwind {}   -> return nilOL++    CmmAssign reg src+      | isFloatType ty -> assignReg_FltCode format reg src+      | target32Bit (targetPlatform dflags) &&+        isWord64 ty    -> assignReg_I64Code      reg src+      | otherwise        -> assignReg_IntCode format reg src+        where ty = cmmRegType dflags reg+              format = cmmTypeFormat ty++    CmmStore addr src+      | isFloatType ty -> assignMem_FltCode format addr src+      | target32Bit (targetPlatform dflags) &&+        isWord64 ty      -> assignMem_I64Code      addr src+      | otherwise        -> assignMem_IntCode format addr src+        where ty = cmmExprType dflags src+              format = cmmTypeFormat ty++    CmmUnsafeForeignCall target result_regs args+       -> genCCall target result_regs args++    CmmBranch id          -> genBranch id+    CmmCondBranch arg true false _ -> do+      b1 <- genCondJump true arg+      b2 <- genBranch false+      return (b1 `appOL` b2)+    CmmSwitch arg ids -> do dflags <- getDynFlags+                            genSwitch dflags arg ids+    CmmCall { cml_target = arg } -> genJump arg+    _ ->+      panic "stmtToInstrs: statement should have been cps'd away"+++--------------------------------------------------------------------------------+-- | 'InstrBlock's are the insn sequences generated by the insn selectors.+--      They are really trees of insns to facilitate fast appending, where a+--      left-to-right traversal yields the insns in the correct order.+--+type InstrBlock+        = OrdList Instr+++-- | Register's passed up the tree.  If the stix code forces the register+--      to live in a pre-decided machine register, it comes out as @Fixed@;+--      otherwise, it comes out as @Any@, and the parent can decide which+--      register to put it in.+--+data Register+        = Fixed Format Reg InstrBlock+        | Any   Format (Reg -> InstrBlock)+++swizzleRegisterRep :: Register -> Format -> Register+swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code+swizzleRegisterRep (Any _ codefn)     format = Any   format codefn+++-- | Grab the Reg for a CmmReg+getRegisterReg :: Platform -> CmmReg -> Reg++getRegisterReg _ (CmmLocal (LocalReg u pk))+  = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk)++getRegisterReg platform (CmmGlobal mid)+  = case globalRegMaybe platform mid of+        Just reg -> RegReal reg+        Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)+        -- By this stage, the only MagicIds remaining should be the+        -- ones which map to a real machine register on this+        -- platform.  Hence ...++-- | Convert a BlockId to some CmmStatic data+jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic+jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags))+jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)+    where blockLabel = mkAsmTempLabel (getUnique blockid)++++-- -----------------------------------------------------------------------------+-- General things for putting together code sequences++-- Expand CmmRegOff.  ToDo: should we do it this way around, or convert+-- CmmExprs into CmmRegOff?+mangleIndexTree :: DynFlags -> CmmExpr -> CmmExpr+mangleIndexTree dflags (CmmRegOff reg off)+  = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]+  where width = typeWidth (cmmRegType dflags reg)++mangleIndexTree _ _+        = panic "PPC.CodeGen.mangleIndexTree: no match"++-- -----------------------------------------------------------------------------+--  Code gen for 64-bit arithmetic on 32-bit platforms++{-+Simple support for generating 64-bit code (ie, 64 bit values and 64+bit assignments) on 32-bit platforms.  Unlike the main code generator+we merely shoot for generating working code as simply as possible, and+pay little attention to code quality.  Specifically, there is no+attempt to deal cleverly with the fixed-vs-floating register+distinction; all values are generated into (pairs of) floating+registers, even if this would mean some redundant reg-reg moves as a+result.  Only one of the VRegUniques is returned, since it will be+of the VRegUniqueLo form, and the upper-half VReg can be determined+by applying getHiVRegFromLo to it.+-}++data ChildCode64        -- a.k.a "Register64"+      = ChildCode64+           InstrBlock   -- code+           Reg          -- the lower 32-bit temporary which contains the+                        -- result; use getHiVRegFromLo to find the other+                        -- VRegUnique.  Rules of this simplified insn+                        -- selection game are therefore that the returned+                        -- Reg may be modified+++-- | Compute an expression into a register, but+--      we don't mind which one it is.+getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)+getSomeReg expr = do+  r <- getRegister expr+  case r of+    Any rep code -> do+        tmp <- getNewRegNat rep+        return (tmp, code tmp)+    Fixed _ reg code ->+        return (reg, code)++getI64Amodes :: CmmExpr -> NatM (AddrMode, AddrMode, InstrBlock)+getI64Amodes addrTree = do+    Amode hi_addr addr_code <- getAmode D addrTree+    case addrOffset hi_addr 4 of+        Just lo_addr -> return (hi_addr, lo_addr, addr_code)+        Nothing      -> do (hi_ptr, code) <- getSomeReg addrTree+                           return (AddrRegImm hi_ptr (ImmInt 0),+                                   AddrRegImm hi_ptr (ImmInt 4),+                                   code)+++assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock+assignMem_I64Code addrTree valueTree = do+        (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree+        ChildCode64 vcode rlo <- iselExpr64 valueTree+        let+                rhi = getHiVRegFromLo rlo++                -- Big-endian store+                mov_hi = ST II32 rhi hi_addr+                mov_lo = ST II32 rlo lo_addr+        return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)+++assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock+assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do+   ChildCode64 vcode r_src_lo <- iselExpr64 valueTree+   let+         r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32+         r_dst_hi = getHiVRegFromLo r_dst_lo+         r_src_hi = getHiVRegFromLo r_src_lo+         mov_lo = MR r_dst_lo r_src_lo+         mov_hi = MR r_dst_hi r_src_hi+   return (+        vcode `snocOL` mov_lo `snocOL` mov_hi+     )++assignReg_I64Code _ _+   = panic "assignReg_I64Code(powerpc): invalid lvalue"+++iselExpr64        :: CmmExpr -> NatM ChildCode64+iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do+    (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree+    (rlo, rhi) <- getNewRegPairNat II32+    let mov_hi = LD II32 rhi hi_addr+        mov_lo = LD II32 rlo lo_addr+    return $ ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)+                         rlo++iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty+   = return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32))++iselExpr64 (CmmLit (CmmInt i _)) = do+  (rlo,rhi) <- getNewRegPairNat II32+  let+        half0 = fromIntegral (fromIntegral i :: Word16)+        half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16)+        half2 = fromIntegral (fromIntegral (i `shiftR` 32) :: Word16)+        half3 = fromIntegral (fromIntegral (i `shiftR` 48) :: Word16)++        code = toOL [+                LIS rlo (ImmInt half1),+                OR rlo rlo (RIImm $ ImmInt half0),+                LIS rhi (ImmInt half3),+                OR rhi rhi (RIImm $ ImmInt half2)+                ]+  return (ChildCode64 code rlo)++iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do+   ChildCode64 code1 r1lo <- iselExpr64 e1+   ChildCode64 code2 r2lo <- iselExpr64 e2+   (rlo,rhi) <- getNewRegPairNat II32+   let+        r1hi = getHiVRegFromLo r1lo+        r2hi = getHiVRegFromLo r2lo+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ ADDC rlo r1lo r2lo,+                       ADDE rhi r1hi r2hi ]+   return (ChildCode64 code rlo)++iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do+   ChildCode64 code1 r1lo <- iselExpr64 e1+   ChildCode64 code2 r2lo <- iselExpr64 e2+   (rlo,rhi) <- getNewRegPairNat II32+   let+        r1hi = getHiVRegFromLo r1lo+        r2hi = getHiVRegFromLo r2lo+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ SUBFC rlo r2lo (RIReg r1lo),+                       SUBFE rhi r2hi r1hi ]+   return (ChildCode64 code rlo)++iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do+    (expr_reg,expr_code) <- getSomeReg expr+    (rlo, rhi) <- getNewRegPairNat II32+    let mov_hi = LI rhi (ImmInt 0)+        mov_lo = MR rlo expr_reg+    return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)+                         rlo+iselExpr64 expr+   = pprPanic "iselExpr64(powerpc)" (pprExpr expr)++++getRegister :: CmmExpr -> NatM Register+getRegister e = do dflags <- getDynFlags+                   getRegister' dflags e++getRegister' :: DynFlags -> CmmExpr -> NatM Register++getRegister' dflags (CmmReg (CmmGlobal PicBaseReg))+  | OSAIX <- platformOS (targetPlatform dflags) = do+        let code dst = toOL [ LD II32 dst tocAddr ]+            tocAddr = AddrRegImm toc (ImmLit (text "ghc_toc_table[TC]"))+        return (Any II32 code)+  | target32Bit (targetPlatform dflags) = do+      reg <- getPicBaseNat $ archWordFormat (target32Bit (targetPlatform dflags))+      return (Fixed (archWordFormat (target32Bit (targetPlatform dflags)))+                    reg nilOL)+  | otherwise = return (Fixed II64 toc nilOL)++getRegister' dflags (CmmReg reg)+  = return (Fixed (cmmTypeFormat (cmmRegType dflags reg))+                  (getRegisterReg (targetPlatform dflags) reg) nilOL)++getRegister' dflags tree@(CmmRegOff _ _)+  = getRegister' dflags (mangleIndexTree dflags tree)++    -- for 32-bit architectuers, support some 64 -> 32 bit conversions:+    -- TO_W_(x), TO_W_(x >> 32)++getRegister' dflags (CmmMachOp (MO_UU_Conv W64 W32)+                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])+ | target32Bit (targetPlatform dflags) = do+  ChildCode64 code rlo <- iselExpr64 x+  return $ Fixed II32 (getHiVRegFromLo rlo) code++getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32)+                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])+ | target32Bit (targetPlatform dflags) = do+  ChildCode64 code rlo <- iselExpr64 x+  return $ Fixed II32 (getHiVRegFromLo rlo) code++getRegister' dflags (CmmMachOp (MO_UU_Conv W64 W32) [x])+ | target32Bit (targetPlatform dflags) = do+  ChildCode64 code rlo <- iselExpr64 x+  return $ Fixed II32 rlo code++getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32) [x])+ | target32Bit (targetPlatform dflags) = do+  ChildCode64 code rlo <- iselExpr64 x+  return $ Fixed II32 rlo code++getRegister' dflags (CmmLoad mem pk)+ | not (isWord64 pk) = do+        let platform = targetPlatform dflags+        Amode addr addr_code <- getAmode D mem+        let code dst = ASSERT((targetClassOfReg platform dst == RcDouble) == isFloatType pk)+                       addr_code `snocOL` LD format dst addr+        return (Any format code)+ | not (target32Bit (targetPlatform dflags)) = do+        Amode addr addr_code <- getAmode DS mem+        let code dst = addr_code `snocOL` LD II64 dst addr+        return (Any II64 code)++          where format = cmmTypeFormat pk++-- catch simple cases of zero- or sign-extended load+getRegister' _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _]) = do+    Amode addr addr_code <- getAmode D mem+    return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr))++getRegister' _ (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad mem _]) = do+    Amode addr addr_code <- getAmode D mem+    return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr))++-- Note: there is no Load Byte Arithmetic instruction, so no signed case here++getRegister' _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _]) = do+    Amode addr addr_code <- getAmode D mem+    return (Any II32 (\dst -> addr_code `snocOL` LD II16 dst addr))++getRegister' _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _]) = do+    Amode addr addr_code <- getAmode D mem+    return (Any II32 (\dst -> addr_code `snocOL` LA II16 dst addr))++getRegister' _ (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad mem _]) = do+    Amode addr addr_code <- getAmode D mem+    return (Any II64 (\dst -> addr_code `snocOL` LD II16 dst addr))++getRegister' _ (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad mem _]) = do+    Amode addr addr_code <- getAmode D mem+    return (Any II64 (\dst -> addr_code `snocOL` LA II16 dst addr))++getRegister' _ (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad mem _]) = do+    Amode addr addr_code <- getAmode D mem+    return (Any II64 (\dst -> addr_code `snocOL` LD II32 dst addr))++getRegister' _ (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad mem _]) = do+    -- lwa is DS-form. See Note [Power instruction format]+    Amode addr addr_code <- getAmode DS mem+    return (Any II64 (\dst -> addr_code `snocOL` LA II32 dst addr))++getRegister' dflags (CmmMachOp mop [x]) -- unary MachOps+  = case mop of+      MO_Not rep   -> triv_ucode_int rep NOT++      MO_F_Neg w   -> triv_ucode_float w FNEG+      MO_S_Neg w   -> triv_ucode_int   w NEG++      MO_FF_Conv W64 W32 -> trivialUCode  FF32 FRSP x+      MO_FF_Conv W32 W64 -> conversionNop FF64 x++      MO_FS_Conv from to -> coerceFP2Int from to x+      MO_SF_Conv from to -> coerceInt2FP from to x++      MO_SS_Conv from to+        | from == to    -> conversionNop (intFormat to) x++        -- narrowing is a nop: we treat the high bits as undefined+      MO_SS_Conv W64 to+        | arch32    -> panic "PPC.CodeGen.getRegister no 64 bit int register"+        | otherwise -> conversionNop (intFormat to) x+      MO_SS_Conv W32 to+        | arch32    -> conversionNop (intFormat to) x+        | otherwise -> case to of+            W64 -> triv_ucode_int to (EXTS II32)+            W16 -> conversionNop II16 x+            W8  -> conversionNop II8 x+            _   -> panic "PPC.CodeGen.getRegister: no match"+      MO_SS_Conv W16 W8 -> conversionNop II8 x+      MO_SS_Conv W8  to -> triv_ucode_int to (EXTS II8)+      MO_SS_Conv W16 to -> triv_ucode_int to (EXTS II16)++      MO_UU_Conv from to+        | from == to -> conversionNop (intFormat to) x+        -- narrowing is a nop: we treat the high bits as undefined+      MO_UU_Conv W64 to+        | arch32    -> panic "PPC.CodeGen.getRegister no 64 bit target"+        | otherwise -> conversionNop (intFormat to) x+      MO_UU_Conv W32 to+        | arch32    -> conversionNop (intFormat to) x+        | otherwise ->+          case to of+           W64 -> trivialCode to False AND x (CmmLit (CmmInt 4294967295 W64))+           W16 -> conversionNop II16 x+           W8  -> conversionNop II8 x+           _   -> panic "PPC.CodeGen.getRegister: no match"+      MO_UU_Conv W16 W8 -> conversionNop II8 x+      MO_UU_Conv W8 to  -> trivialCode to False AND x (CmmLit (CmmInt 255 W32))+      MO_UU_Conv W16 to -> trivialCode to False AND x (CmmLit (CmmInt 65535 W32))+      _ -> panic "PPC.CodeGen.getRegister: no match"++    where+        triv_ucode_int   width instr = trivialUCode (intFormat    width) instr x+        triv_ucode_float width instr = trivialUCode (floatFormat  width) instr x++        conversionNop new_format expr+            = do e_code <- getRegister' dflags expr+                 return (swizzleRegisterRep e_code new_format)+        arch32 = target32Bit $ targetPlatform dflags++getRegister' dflags (CmmMachOp mop [x, y]) -- dyadic PrimOps+  = case mop of+      MO_F_Eq _ -> condFltReg EQQ x y+      MO_F_Ne _ -> condFltReg NE  x y+      MO_F_Gt _ -> condFltReg GTT x y+      MO_F_Ge _ -> condFltReg GE  x y+      MO_F_Lt _ -> condFltReg LTT x y+      MO_F_Le _ -> condFltReg LE  x y++      MO_Eq rep -> condIntReg EQQ  (extendUExpr dflags rep x)+                                   (extendUExpr dflags rep y)+      MO_Ne rep -> condIntReg NE   (extendUExpr dflags rep x)+                                   (extendUExpr dflags rep y)++      MO_S_Gt rep -> condIntReg GTT  (extendSExpr dflags rep x)+                                     (extendSExpr dflags rep y)+      MO_S_Ge rep -> condIntReg GE   (extendSExpr dflags rep x)+                                     (extendSExpr dflags rep y)+      MO_S_Lt rep -> condIntReg LTT  (extendSExpr dflags rep x)+                                     (extendSExpr dflags rep y)+      MO_S_Le rep -> condIntReg LE   (extendSExpr dflags rep x)+                                     (extendSExpr dflags rep y)++      MO_U_Gt rep -> condIntReg GU   (extendUExpr dflags rep x)+                                     (extendUExpr dflags rep y)+      MO_U_Ge rep -> condIntReg GEU  (extendUExpr dflags rep x)+                                     (extendUExpr dflags rep y)+      MO_U_Lt rep -> condIntReg LU   (extendUExpr dflags rep x)+                                     (extendUExpr dflags rep y)+      MO_U_Le rep -> condIntReg LEU  (extendUExpr dflags rep x)+                                     (extendUExpr dflags rep y)++      MO_F_Add w  -> triv_float w FADD+      MO_F_Sub w  -> triv_float w FSUB+      MO_F_Mul w  -> triv_float w FMUL+      MO_F_Quot w -> triv_float w FDIV++         -- optimize addition with 32-bit immediate+         -- (needed for PIC)+      MO_Add W32 ->+        case y of+          CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate W32 True imm+            -> trivialCode W32 True ADD x (CmmLit $ CmmInt imm immrep)+          CmmLit lit+            -> do+                (src, srcCode) <- getSomeReg x+                let imm = litToImm lit+                    code dst = srcCode `appOL` toOL [+                                    ADDIS dst src (HA imm),+                                    ADD dst dst (RIImm (LO imm))+                                ]+                return (Any II32 code)+          _ -> trivialCode W32 True ADD x y++      MO_Add rep -> trivialCode rep True ADD x y+      MO_Sub rep ->+        case y of+          CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate rep True (-imm)+            -> trivialCode rep True ADD x (CmmLit $ CmmInt (-imm) immrep)+          _ -> case x of+                 CmmLit (CmmInt imm _)+                   | Just _ <- makeImmediate rep True imm+                   -- subfi ('substract from' with immediate) doesn't exist+                   -> trivialCode rep True SUBFC y x+                 _ -> trivialCodeNoImm' (intFormat rep) SUBF y x++      MO_Mul rep -> shiftMulCode rep True MULL x y+      MO_S_MulMayOflo rep -> do+        (src1, code1) <- getSomeReg x+        (src2, code2) <- getSomeReg y+        let+          format = intFormat rep+          code dst = code1 `appOL` code2+                       `appOL` toOL [ MULLO format dst src1 src2+                                    , MFOV  format dst+                                    ]+        return (Any format code)++      MO_S_Quot rep -> trivialCodeNoImmSign (intFormat rep) True DIV+                (extendSExpr dflags rep x) (extendSExpr dflags rep y)+      MO_U_Quot rep -> trivialCodeNoImmSign (intFormat rep) False DIV+                (extendUExpr dflags rep x) (extendUExpr dflags rep y)++      MO_S_Rem rep -> remainderCode rep True (extendSExpr dflags rep x)+                                             (extendSExpr dflags rep y)+      MO_U_Rem rep -> remainderCode rep False (extendUExpr dflags rep x)+                                              (extendUExpr dflags rep y)++      MO_And rep   -> case y of+        (CmmLit (CmmInt imm _)) | imm == -8 || imm == -4+            -> do+                (src, srcCode) <- getSomeReg x+                let clear_mask = if imm == -4 then 2 else 3+                    fmt = intFormat rep+                    code dst = srcCode+                               `appOL` unitOL (CLRRI fmt dst src clear_mask)+                return (Any fmt code)+        _ -> trivialCode rep False AND x y+      MO_Or rep    -> trivialCode rep False OR x y+      MO_Xor rep   -> trivialCode rep False XOR x y++      MO_Shl rep   -> shiftMulCode rep False SL x y+      MO_S_Shr rep -> shiftMulCode rep False SRA (extendSExpr dflags rep x) y+      MO_U_Shr rep -> shiftMulCode rep False SR (extendUExpr dflags rep x) y+      _         -> panic "PPC.CodeGen.getRegister: no match"++  where+    triv_float :: Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register+    triv_float width instr = trivialCodeNoImm (floatFormat width) instr x y++getRegister' _ (CmmLit (CmmInt i rep))+  | Just imm <- makeImmediate rep True i+  = let+        code dst = unitOL (LI dst imm)+    in+        return (Any (intFormat rep) code)++getRegister' _ (CmmLit (CmmFloat f frep)) = do+    lbl <- getNewLabelNat+    dflags <- getDynFlags+    dynRef <- cmmMakeDynamicReference dflags DataReference lbl+    Amode addr addr_code <- getAmode D dynRef+    let format = floatFormat frep+        code dst =+            LDATA (Section ReadOnlyData lbl)+                  (Statics lbl [CmmStaticLit (CmmFloat f frep)])+            `consOL` (addr_code `snocOL` LD format dst addr)+    return (Any format code)++getRegister' dflags (CmmLit lit)+  | target32Bit (targetPlatform dflags)+  = let rep = cmmLitType dflags lit+        imm = litToImm lit+        code dst = toOL [+              LIS dst (HA imm),+              ADD dst dst (RIImm (LO imm))+          ]+    in return (Any (cmmTypeFormat rep) code)+  | otherwise+  = do lbl <- getNewLabelNat+       dflags <- getDynFlags+       dynRef <- cmmMakeDynamicReference dflags DataReference lbl+       Amode addr addr_code <- getAmode D dynRef+       let rep = cmmLitType dflags lit+           format = cmmTypeFormat rep+           code dst =+            LDATA (Section ReadOnlyData lbl) (Statics lbl [CmmStaticLit lit])+            `consOL` (addr_code `snocOL` LD format dst addr)+       return (Any format code)++getRegister' _ other = pprPanic "getRegister(ppc)" (pprExpr other)++    -- extend?Rep: wrap integer expression of type rep+    -- in a conversion to II32 or II64 resp.+extendSExpr :: DynFlags -> Width -> CmmExpr -> CmmExpr+extendSExpr dflags W32 x+ | target32Bit (targetPlatform dflags) = x++extendSExpr dflags W64 x+ | not (target32Bit (targetPlatform dflags)) = x++extendSExpr dflags rep x =+    let size = if target32Bit $ targetPlatform dflags+               then W32+               else W64+    in CmmMachOp (MO_SS_Conv rep size) [x]++extendUExpr :: DynFlags -> Width -> CmmExpr -> CmmExpr+extendUExpr dflags W32 x+ | target32Bit (targetPlatform dflags) = x+extendUExpr dflags W64 x+ | not (target32Bit (targetPlatform dflags)) = x+extendUExpr dflags rep x =+    let size = if target32Bit $ targetPlatform dflags+               then W32+               else W64+    in CmmMachOp (MO_UU_Conv rep size) [x]++-- -----------------------------------------------------------------------------+--  The 'Amode' type: Memory addressing modes passed up the tree.++data Amode+        = Amode AddrMode InstrBlock++{-+Now, given a tree (the argument to an CmmLoad) that references memory,+produce a suitable addressing mode.++A Rule of the Game (tm) for Amodes: use of the addr bit must+immediately follow use of the code part, since the code part puts+values in registers which the addr then refers to.  So you can't put+anything in between, lest it overwrite some of those registers.  If+you need to do some other computation between the code part and use of+the addr bit, first store the effective address from the amode in a+temporary, then do the other computation, and then use the temporary:++    code+    LEA amode, tmp+    ... other computation ...+    ... (tmp) ...+-}++{- Note [Power instruction format]+In some instructions the 16 bit offset must be a multiple of 4, i.e.+the two least significant bits must be zero. The "Power ISA" specification+calls these instruction formats "DS-FORM" and the instructions with+arbitrary 16 bit offsets are "D-FORM".++The Power ISA specification document can be obtained from www.power.org.+-}+data InstrForm = D | DS++getAmode :: InstrForm -> CmmExpr -> NatM Amode+getAmode inf tree@(CmmRegOff _ _)+  = do dflags <- getDynFlags+       getAmode inf (mangleIndexTree dflags tree)++getAmode _ (CmmMachOp (MO_Sub W32) [x, CmmLit (CmmInt i _)])+  | Just off <- makeImmediate W32 True (-i)+  = do+        (reg, code) <- getSomeReg x+        return (Amode (AddrRegImm reg off) code)+++getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit (CmmInt i _)])+  | Just off <- makeImmediate W32 True i+  = do+        (reg, code) <- getSomeReg x+        return (Amode (AddrRegImm reg off) code)++getAmode D (CmmMachOp (MO_Sub W64) [x, CmmLit (CmmInt i _)])+  | Just off <- makeImmediate W64 True (-i)+  = do+        (reg, code) <- getSomeReg x+        return (Amode (AddrRegImm reg off) code)+++getAmode D (CmmMachOp (MO_Add W64) [x, CmmLit (CmmInt i _)])+  | Just off <- makeImmediate W64 True i+  = do+        (reg, code) <- getSomeReg x+        return (Amode (AddrRegImm reg off) code)++getAmode DS (CmmMachOp (MO_Sub W64) [x, CmmLit (CmmInt i _)])+  | Just off <- makeImmediate W64 True (-i)+  = do+        (reg, code) <- getSomeReg x+        (reg', off', code')  <-+                     if i `mod` 4 == 0+                      then do return (reg, off, code)+                      else do+                           tmp <- getNewRegNat II64+                           return (tmp, ImmInt 0,+                                  code `snocOL` ADD tmp reg (RIImm off))+        return (Amode (AddrRegImm reg' off') code')++getAmode DS (CmmMachOp (MO_Add W64) [x, CmmLit (CmmInt i _)])+  | Just off <- makeImmediate W64 True i+  = do+        (reg, code) <- getSomeReg x+        (reg', off', code')  <-+                     if i `mod` 4 == 0+                      then do return (reg, off, code)+                      else do+                           tmp <- getNewRegNat II64+                           return (tmp, ImmInt 0,+                                  code `snocOL` ADD tmp reg (RIImm off))+        return (Amode (AddrRegImm reg' off') code')++   -- optimize addition with 32-bit immediate+   -- (needed for PIC)+getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit lit])+  = do+        dflags <- getDynFlags+        (src, srcCode) <- getSomeReg x+        let imm = litToImm lit+        case () of+            _ | OSAIX <- platformOS (targetPlatform dflags)+              , isCmmLabelType lit ->+                    -- HA16/LO16 relocations on labels not supported on AIX+                    return (Amode (AddrRegImm src imm) srcCode)+              | otherwise -> do+                    tmp <- getNewRegNat II32+                    let code = srcCode `snocOL` ADDIS tmp src (HA imm)+                    return (Amode (AddrRegImm tmp (LO imm)) code)+  where+      isCmmLabelType (CmmLabel {})        = True+      isCmmLabelType (CmmLabelOff {})     = True+      isCmmLabelType (CmmLabelDiffOff {}) = True+      isCmmLabelType _                    = False++getAmode _ (CmmLit lit)+  = do+        dflags <- getDynFlags+        case platformArch $ targetPlatform dflags of+             ArchPPC -> do+                 tmp <- getNewRegNat II32+                 let imm = litToImm lit+                     code = unitOL (LIS tmp (HA imm))+                 return (Amode (AddrRegImm tmp (LO imm)) code)+             _        -> do -- TODO: Load from TOC,+                            -- see getRegister' _ (CmmLit lit)+                 tmp <- getNewRegNat II64+                 let imm = litToImm lit+                     code =  toOL [+                          LIS tmp (HIGHESTA imm),+                          OR tmp tmp (RIImm (HIGHERA imm)),+                          SL  II64 tmp tmp (RIImm (ImmInt 32)),+                          ORIS tmp tmp (HA imm)+                          ]+                 return (Amode (AddrRegImm tmp (LO imm)) code)++getAmode _ (CmmMachOp (MO_Add W32) [x, y])+  = do+        (regX, codeX) <- getSomeReg x+        (regY, codeY) <- getSomeReg y+        return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))++getAmode _ (CmmMachOp (MO_Add W64) [x, y])+  = do+        (regX, codeX) <- getSomeReg x+        (regY, codeY) <- getSomeReg y+        return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))++getAmode _ other+  = do+        (reg, code) <- getSomeReg other+        let+            off  = ImmInt 0+        return (Amode (AddrRegImm reg off) code)+++--  The 'CondCode' type:  Condition codes passed up the tree.+data CondCode+        = CondCode Bool Cond InstrBlock++-- Set up a condition code for a conditional branch.++getCondCode :: CmmExpr -> NatM CondCode++-- almost the same as everywhere else - but we need to+-- extend small integers to 32 bit or 64 bit first++getCondCode (CmmMachOp mop [x, y])+  = do+    dflags <- getDynFlags+    case mop of+      MO_F_Eq W32 -> condFltCode EQQ x y+      MO_F_Ne W32 -> condFltCode NE  x y+      MO_F_Gt W32 -> condFltCode GTT x y+      MO_F_Ge W32 -> condFltCode GE  x y+      MO_F_Lt W32 -> condFltCode LTT x y+      MO_F_Le W32 -> condFltCode LE  x y++      MO_F_Eq W64 -> condFltCode EQQ x y+      MO_F_Ne W64 -> condFltCode NE  x y+      MO_F_Gt W64 -> condFltCode GTT x y+      MO_F_Ge W64 -> condFltCode GE  x y+      MO_F_Lt W64 -> condFltCode LTT x y+      MO_F_Le W64 -> condFltCode LE  x y++      MO_Eq rep -> condIntCode EQQ  (extendUExpr dflags rep x)+                                    (extendUExpr dflags rep y)+      MO_Ne rep -> condIntCode NE   (extendUExpr dflags rep x)+                                    (extendUExpr dflags rep y)++      MO_S_Gt rep -> condIntCode GTT  (extendSExpr dflags rep x)+                                      (extendSExpr dflags rep y)+      MO_S_Ge rep -> condIntCode GE   (extendSExpr dflags rep x)+                                      (extendSExpr dflags rep y)+      MO_S_Lt rep -> condIntCode LTT  (extendSExpr dflags rep x)+                                      (extendSExpr dflags rep y)+      MO_S_Le rep -> condIntCode LE   (extendSExpr dflags rep x)+                                      (extendSExpr dflags rep y)++      MO_U_Gt rep -> condIntCode GU   (extendSExpr dflags rep x)+                                      (extendSExpr dflags rep y)+      MO_U_Ge rep -> condIntCode GEU  (extendSExpr dflags rep x)+                                      (extendSExpr dflags rep y)+      MO_U_Lt rep -> condIntCode LU   (extendSExpr dflags rep x)+                                      (extendSExpr dflags rep y)+      MO_U_Le rep -> condIntCode LEU  (extendSExpr dflags rep x)+                                      (extendSExpr dflags rep y)++      _ -> pprPanic "getCondCode(powerpc)" (pprMachOp mop)++getCondCode _ = panic "getCondCode(2)(powerpc)"+++-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be+-- passed back up the tree.++condIntCode, condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode++-- optimize pointer tag checks. Operation andi. sets condition register+-- so cmpi ..., 0 is redundant.+condIntCode cond (CmmMachOp (MO_And _) [x, CmmLit (CmmInt imm rep)])+                 (CmmLit (CmmInt 0 _))+  | not $ condUnsigned cond,+    Just src2 <- makeImmediate rep False imm+  = do+      (src1, code) <- getSomeReg x+      let code' = code `snocOL` AND r0 src1 (RIImm src2)+      return (CondCode False cond code')++condIntCode cond x (CmmLit (CmmInt y rep))+  | Just src2 <- makeImmediate rep (not $ condUnsigned cond) y+  = do+        (src1, code) <- getSomeReg x+        dflags <- getDynFlags+        let format = archWordFormat $ target32Bit $ targetPlatform dflags+            code' = code `snocOL`+              (if condUnsigned cond then CMPL else CMP) format src1 (RIImm src2)+        return (CondCode False cond code')++condIntCode cond x y = do+    (src1, code1) <- getSomeReg x+    (src2, code2) <- getSomeReg y+    dflags <- getDynFlags+    let format = archWordFormat $ target32Bit $ targetPlatform dflags+        code' = code1 `appOL` code2 `snocOL`+          (if condUnsigned cond then CMPL else CMP) format src1 (RIReg src2)+    return (CondCode False cond code')++condFltCode cond x y = do+    (src1, code1) <- getSomeReg x+    (src2, code2) <- getSomeReg y+    let+        code'  = code1 `appOL` code2 `snocOL` FCMP src1 src2+        code'' = case cond of -- twiddle CR to handle unordered case+                    GE -> code' `snocOL` CRNOR ltbit eqbit gtbit+                    LE -> code' `snocOL` CRNOR gtbit eqbit ltbit+                    _ -> code'+                 where+                    ltbit = 0 ; eqbit = 2 ; gtbit = 1+    return (CondCode True cond code'')++++-- -----------------------------------------------------------------------------+-- Generating assignments++-- Assignments are really at the heart of the whole code generation+-- business.  Almost all top-level nodes of any real importance are+-- assignments, which correspond to loads, stores, or register+-- transfers.  If we're really lucky, some of the register transfers+-- will go away, because we can use the destination register to+-- complete the code generation for the right hand side.  This only+-- fails when the right hand side is forced into a fixed register+-- (e.g. the result of a call).++assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock++assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock++assignMem_IntCode pk addr src = do+    (srcReg, code) <- getSomeReg src+    Amode dstAddr addr_code <- case pk of+                                II64 -> getAmode DS addr+                                _    -> getAmode D  addr+    return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr++-- dst is a reg, but src could be anything+assignReg_IntCode _ reg src+    = do+        dflags <- getDynFlags+        let dst = getRegisterReg (targetPlatform dflags) reg+        r <- getRegister src+        return $ case r of+            Any _ code         -> code dst+            Fixed _ freg fcode -> fcode `snocOL` MR dst freg++++-- Easy, isn't it?+assignMem_FltCode = assignMem_IntCode+assignReg_FltCode = assignReg_IntCode++++genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock++genJump (CmmLit (CmmLabel lbl))+  = return (unitOL $ JMP lbl)++genJump tree+  = do+        dflags <- getDynFlags+        genJump' tree (platformToGCP (targetPlatform dflags))++genJump' :: CmmExpr -> GenCCallPlatform -> NatM InstrBlock++genJump' tree (GCPLinux64ELF 1)+  = do+        (target,code) <- getSomeReg tree+        return (code+               `snocOL` LD II64 r11 (AddrRegImm target (ImmInt 0))+               `snocOL` LD II64 toc (AddrRegImm target (ImmInt 8))+               `snocOL` MTCTR r11+               `snocOL` LD II64 r11 (AddrRegImm target (ImmInt 16))+               `snocOL` BCTR [] Nothing)++genJump' tree (GCPLinux64ELF 2)+  = do+        (target,code) <- getSomeReg tree+        return (code+               `snocOL` MR r12 target+               `snocOL` MTCTR r12+               `snocOL` BCTR [] Nothing)++genJump' tree _+  = do+        (target,code) <- getSomeReg tree+        return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing)++-- -----------------------------------------------------------------------------+--  Unconditional branches+genBranch :: BlockId -> NatM InstrBlock+genBranch = return . toOL . mkJumpInstr+++-- -----------------------------------------------------------------------------+--  Conditional jumps++{-+Conditional jumps are always to local labels, so we can use branch+instructions.  We peek at the arguments to decide what kind of+comparison to do.+-}+++genCondJump+    :: BlockId      -- the branch target+    -> CmmExpr      -- the condition on which to branch+    -> NatM InstrBlock++genCondJump id bool = do+  CondCode _ cond code <- getCondCode bool+  return (code `snocOL` BCC cond id)++++-- -----------------------------------------------------------------------------+--  Generating C calls++-- Now the biggest nightmare---calls.  Most of the nastiness is buried in+-- @get_arg@, which moves the arguments to the correct registers/stack+-- locations.  Apart from that, the code is easy.++genCCall :: ForeignTarget      -- function to call+         -> [CmmFormal]        -- where to put the result+         -> [CmmActual]        -- arguments (of mixed type)+         -> NatM InstrBlock+genCCall (PrimTarget MO_WriteBarrier) _ _+ = return $ unitOL LWSYNC++genCCall (PrimTarget MO_Touch) _ _+ = return $ nilOL++genCCall (PrimTarget (MO_Prefetch_Data _)) _ _+ = return $ nilOL++genCCall (PrimTarget (MO_Clz width)) [dst] [src]+ = do dflags <- getDynFlags+      let platform = targetPlatform dflags+          reg_dst = getRegisterReg platform (CmmLocal dst)+      if target32Bit platform && width == W64+        then do+          ChildCode64 code vr_lo <- iselExpr64 src+          lbl1 <- getBlockIdNat+          lbl2 <- getBlockIdNat+          lbl3 <- getBlockIdNat+          let vr_hi = getHiVRegFromLo vr_lo+              cntlz = toOL [ CMPL II32 vr_hi (RIImm (ImmInt 0))+                           , BCC NE lbl2+                           , BCC ALWAYS lbl1++                           , NEWBLOCK lbl1+                           , CNTLZ II32 reg_dst vr_lo+                           , ADD reg_dst reg_dst (RIImm (ImmInt 32))+                           , BCC ALWAYS lbl3++                           , NEWBLOCK lbl2+                           , CNTLZ II32 reg_dst vr_hi+                           , BCC ALWAYS lbl3++                           , NEWBLOCK lbl3+                           ]+          return $ code `appOL` cntlz+        else do+          let format = if width == W64 then II64 else II32+          (s_reg, s_code) <- getSomeReg src+          (pre, reg , post) <-+            case width of+              W64 -> return (nilOL, s_reg, nilOL)+              W32 -> return (nilOL, s_reg, nilOL)+              W16 -> do+                reg_tmp <- getNewRegNat format+                return+                  ( unitOL $ AND reg_tmp s_reg (RIImm (ImmInt 65535))+                  , reg_tmp+                  , unitOL $ ADD reg_dst reg_dst (RIImm (ImmInt (-16)))+                  )+              W8  -> do+                reg_tmp <- getNewRegNat format+                return+                  ( unitOL $ AND reg_tmp s_reg (RIImm (ImmInt 255))+                  , reg_tmp+                  , unitOL $ ADD reg_dst reg_dst (RIImm (ImmInt (-24)))+                  )+              _   -> panic "genCall: Clz wrong format"+          let cntlz = unitOL (CNTLZ format reg_dst reg)+          return $ s_code `appOL` pre `appOL` cntlz `appOL` post++genCCall (PrimTarget (MO_Ctz width)) [dst] [src]+ = do dflags <- getDynFlags+      let platform = targetPlatform dflags+          reg_dst = getRegisterReg platform (CmmLocal dst)+      if target32Bit platform && width == W64+        then do+          let format = II32+          ChildCode64 code vr_lo <- iselExpr64 src+          lbl1 <- getBlockIdNat+          lbl2 <- getBlockIdNat+          lbl3 <- getBlockIdNat+          x' <- getNewRegNat format+          x'' <- getNewRegNat format+          r' <- getNewRegNat format+          cnttzlo <- cnttz format reg_dst vr_lo+          let vr_hi = getHiVRegFromLo vr_lo+              cnttz64 = toOL [ CMPL format vr_lo (RIImm (ImmInt 0))+                             , BCC NE lbl2+                             , BCC ALWAYS lbl1++                             , NEWBLOCK lbl1+                             , ADD x' vr_hi (RIImm (ImmInt (-1)))+                             , ANDC x'' x' vr_hi+                             , CNTLZ format r' x''+                               -- 32 + (32 - clz(x''))+                             , SUBFC reg_dst r' (RIImm (ImmInt 64))+                             , BCC ALWAYS lbl3++                             , NEWBLOCK lbl2+                             ]+                        `appOL` cnttzlo `appOL`+                        toOL [ BCC ALWAYS lbl3++                             , NEWBLOCK lbl3+                             ]+          return $ code `appOL` cnttz64+        else do+          let format = if width == W64 then II64 else II32+          (s_reg, s_code) <- getSomeReg src+          (reg_ctz, pre_code) <-+            case width of+              W64 -> return (s_reg, nilOL)+              W32 -> return (s_reg, nilOL)+              W16 -> do+                reg_tmp <- getNewRegNat format+                return (reg_tmp, unitOL $ ORIS reg_tmp s_reg (ImmInt 1))+              W8  -> do+                reg_tmp <- getNewRegNat format+                return (reg_tmp, unitOL $ OR reg_tmp s_reg (RIImm (ImmInt 256)))+              _   -> panic "genCall: Ctz wrong format"+          ctz_code <- cnttz format reg_dst reg_ctz+          return $ s_code `appOL` pre_code `appOL` ctz_code+        where+          -- cnttz(x) = sizeof(x) - cntlz(~x & (x - 1))+          -- see Henry S. Warren, Hacker's Delight, p 107+          cnttz format dst src = do+            let format_bits = 8 * formatInBytes format+            x' <- getNewRegNat format+            x'' <- getNewRegNat format+            r' <- getNewRegNat format+            return $ toOL [ ADD x' src (RIImm (ImmInt (-1)))+                          , ANDC x'' x' src+                          , CNTLZ format r' x''+                          , SUBFC dst r' (RIImm (ImmInt (format_bits)))+                          ]++genCCall target dest_regs argsAndHints+ = do dflags <- getDynFlags+      let platform = targetPlatform dflags+      case target of+        PrimTarget (MO_S_QuotRem  width) -> divOp1 platform True  width+                                                   dest_regs argsAndHints+        PrimTarget (MO_U_QuotRem  width) -> divOp1 platform False width+                                                   dest_regs argsAndHints+        PrimTarget (MO_U_QuotRem2 width) -> divOp2 platform width dest_regs+                                                   argsAndHints+        PrimTarget (MO_U_Mul2 width) -> multOp2 platform width dest_regs+                                                argsAndHints+        PrimTarget (MO_Add2 _) -> add2Op platform dest_regs argsAndHints+        PrimTarget (MO_SubWordC _) -> subcOp platform dest_regs argsAndHints+        PrimTarget (MO_AddIntC width) -> addSubCOp ADDO platform width+                                                   dest_regs argsAndHints+        PrimTarget (MO_SubIntC width) -> addSubCOp SUBFO platform width+                                                   dest_regs argsAndHints+        PrimTarget MO_F64_Fabs -> fabs platform dest_regs argsAndHints+        PrimTarget MO_F32_Fabs -> fabs platform dest_regs argsAndHints+        _ -> genCCall' dflags (platformToGCP platform)+                       target dest_regs argsAndHints+        where divOp1 platform signed width [res_q, res_r] [arg_x, arg_y]+                = do let reg_q = getRegisterReg platform (CmmLocal res_q)+                         reg_r = getRegisterReg platform (CmmLocal res_r)+                         fmt   = intFormat width+                     (x_reg, x_code) <- getSomeReg arg_x+                     (y_reg, y_code) <- getSomeReg arg_y+                     return $       y_code `appOL` x_code+                            `appOL` toOL [ DIV fmt signed reg_q x_reg y_reg+                                         , MULL fmt reg_r reg_q (RIReg y_reg)+                                         , SUBF reg_r reg_r x_reg+                                         ]++              divOp1 _ _ _ _ _+                = panic "genCCall: Wrong number of arguments for divOp1"+              divOp2 platform width [res_q, res_r]+                                    [arg_x_high, arg_x_low, arg_y]+                = do let reg_q = getRegisterReg platform (CmmLocal res_q)+                         reg_r = getRegisterReg platform (CmmLocal res_r)+                         fmt   = intFormat width+                         half  = 4 * (formatInBytes fmt)+                     (xh_reg, xh_code) <- getSomeReg arg_x_high+                     (xl_reg, xl_code) <- getSomeReg arg_x_low+                     (y_reg, y_code) <- getSomeReg arg_y+                     s <- getNewRegNat fmt+                     b <- getNewRegNat fmt+                     v <- getNewRegNat fmt+                     vn1 <- getNewRegNat fmt+                     vn0 <- getNewRegNat fmt+                     un32 <- getNewRegNat fmt+                     tmp  <- getNewRegNat fmt+                     un10 <- getNewRegNat fmt+                     un1 <- getNewRegNat fmt+                     un0 <- getNewRegNat fmt+                     q1 <- getNewRegNat fmt+                     rhat <- getNewRegNat fmt+                     tmp1 <- getNewRegNat fmt+                     q0 <- getNewRegNat fmt+                     un21 <- getNewRegNat fmt+                     again1 <- getBlockIdNat+                     no1 <- getBlockIdNat+                     then1 <- getBlockIdNat+                     endif1 <- getBlockIdNat+                     again2 <- getBlockIdNat+                     no2 <- getBlockIdNat+                     then2 <- getBlockIdNat+                     endif2 <- getBlockIdNat+                     return $ y_code `appOL` xl_code `appOL` xh_code `appOL`+                              -- see Hacker's Delight p 196 Figure 9-3+                              toOL [ -- b = 2 ^ (bits_in_word / 2)+                                     LI b (ImmInt 1)+                                   , SL fmt b b (RIImm (ImmInt half))+                                     -- s = clz(y)+                                   , CNTLZ fmt s y_reg+                                     -- v = y << s+                                   , SL fmt v y_reg (RIReg s)+                                     -- vn1 = upper half of v+                                   , SR fmt vn1 v (RIImm (ImmInt half))+                                     -- vn0 = lower half of v+                                   , CLRLI fmt vn0 v half+                                     -- un32 = (u1 << s)+                                     --      | (u0 >> (bits_in_word - s))+                                   , SL fmt un32 xh_reg (RIReg s)+                                   , SUBFC tmp s+                                        (RIImm (ImmInt (8 * formatInBytes fmt)))+                                   , SR fmt tmp xl_reg (RIReg tmp)+                                   , OR un32 un32 (RIReg tmp)+                                     -- un10 = u0 << s+                                   , SL fmt un10 xl_reg (RIReg s)+                                     -- un1 = upper half of un10+                                   , SR fmt un1 un10 (RIImm (ImmInt half))+                                     -- un0 = lower half of un10+                                   , CLRLI fmt un0 un10 half+                                     -- q1 = un32/vn1+                                   , DIV fmt False q1 un32 vn1+                                     -- rhat = un32 - q1*vn1+                                   , MULL fmt tmp q1 (RIReg vn1)+                                   , SUBF rhat tmp un32+                                   , BCC ALWAYS again1++                                   , NEWBLOCK again1+                                     -- if (q1 >= b || q1*vn0 > b*rhat + un1)+                                   , CMPL fmt q1 (RIReg b)+                                   , BCC GEU then1+                                   , BCC ALWAYS no1++                                   , NEWBLOCK no1+                                   , MULL fmt tmp q1 (RIReg vn0)+                                   , SL fmt tmp1 rhat (RIImm (ImmInt half))+                                   , ADD tmp1 tmp1 (RIReg un1)+                                   , CMPL fmt tmp (RIReg tmp1)+                                   , BCC LEU endif1+                                   , BCC ALWAYS then1++                                   , NEWBLOCK then1+                                     -- q1 = q1 - 1+                                   , ADD q1 q1 (RIImm (ImmInt (-1)))+                                     -- rhat = rhat + vn1+                                   , ADD rhat rhat (RIReg vn1)+                                     -- if (rhat < b) goto again1+                                   , CMPL fmt rhat (RIReg b)+                                   , BCC LTT again1+                                   , BCC ALWAYS endif1++                                   , NEWBLOCK endif1+                                     -- un21 = un32*b + un1 - q1*v+                                   , SL fmt un21 un32 (RIImm (ImmInt half))+                                   , ADD un21 un21 (RIReg un1)+                                   , MULL fmt tmp q1 (RIReg v)+                                   , SUBF un21 tmp un21+                                     -- compute second quotient digit+                                     -- q0 = un21/vn1+                                   , DIV fmt False q0 un21 vn1+                                     -- rhat = un21- q0*vn1+                                   , MULL fmt tmp q0 (RIReg vn1)+                                   , SUBF rhat tmp un21+                                   , BCC ALWAYS again2++                                   , NEWBLOCK again2+                                     -- if (q0>b || q0*vn0 > b*rhat + un0)+                                   , CMPL fmt q0 (RIReg b)+                                   , BCC GEU then2+                                   , BCC ALWAYS no2++                                   , NEWBLOCK no2+                                   , MULL fmt tmp q0 (RIReg vn0)+                                   , SL fmt tmp1 rhat (RIImm (ImmInt half))+                                   , ADD tmp1 tmp1 (RIReg un0)+                                   , CMPL fmt tmp (RIReg tmp1)+                                   , BCC LEU endif2+                                   , BCC ALWAYS then2++                                   , NEWBLOCK then2+                                     -- q0 = q0 - 1+                                   , ADD q0 q0 (RIImm (ImmInt (-1)))+                                     -- rhat = rhat + vn1+                                   , ADD rhat rhat (RIReg vn1)+                                     -- if (rhat<b) goto again2+                                   , CMPL fmt rhat (RIReg b)+                                   , BCC LTT again2+                                   , BCC ALWAYS endif2++                                   , NEWBLOCK endif2+                                     -- compute remainder+                                     -- r = (un21*b + un0 - q0*v) >> s+                                   , SL fmt reg_r un21 (RIImm (ImmInt half))+                                   , ADD reg_r reg_r (RIReg un0)+                                   , MULL fmt tmp q0 (RIReg v)+                                   , SUBF reg_r tmp reg_r+                                   , SR fmt reg_r reg_r (RIReg s)+                                     -- compute quotient+                                     -- q = q1*b + q0+                                   , SL fmt reg_q q1 (RIImm (ImmInt half))+                                   , ADD reg_q reg_q (RIReg q0)+                                   ]+              divOp2 _ _ _ _+                = panic "genCCall: Wrong number of arguments for divOp2"+              multOp2 platform width [res_h, res_l] [arg_x, arg_y]+                = do let reg_h = getRegisterReg platform (CmmLocal res_h)+                         reg_l = getRegisterReg platform (CmmLocal res_l)+                         fmt = intFormat width+                     (x_reg, x_code) <- getSomeReg arg_x+                     (y_reg, y_code) <- getSomeReg arg_y+                     return $ y_code `appOL` x_code+                            `appOL` toOL [ MULL fmt reg_l x_reg (RIReg y_reg)+                                         , MULHU fmt reg_h x_reg y_reg+                                         ]+              multOp2 _ _ _ _+                = panic "genCall: Wrong number of arguments for multOp2"+              add2Op platform [res_h, res_l] [arg_x, arg_y]+                = do let reg_h = getRegisterReg platform (CmmLocal res_h)+                         reg_l = getRegisterReg platform (CmmLocal res_l)+                     (x_reg, x_code) <- getSomeReg arg_x+                     (y_reg, y_code) <- getSomeReg arg_y+                     return $ y_code `appOL` x_code+                            `appOL` toOL [ LI reg_h (ImmInt 0)+                                         , ADDC reg_l x_reg y_reg+                                         , ADDZE reg_h reg_h+                                         ]+              add2Op _ _ _+                = panic "genCCall: Wrong number of arguments/results for add2"++              -- PowerPC subfc sets the carry for rT = ~(rA) + rB + 1,+              -- which is 0 for borrow and 1 otherwise. We need 1 and 0+              -- so xor with 1.+              subcOp platform [res_r, res_c] [arg_x, arg_y]+                = do let reg_r = getRegisterReg platform (CmmLocal res_r)+                         reg_c = getRegisterReg platform (CmmLocal res_c)+                     (x_reg, x_code) <- getSomeReg arg_x+                     (y_reg, y_code) <- getSomeReg arg_y+                     return $ y_code `appOL` x_code+                            `appOL` toOL [ LI reg_c (ImmInt 0)+                                         , SUBFC reg_r y_reg (RIReg x_reg)+                                         , ADDZE reg_c reg_c+                                         , XOR reg_c reg_c (RIImm (ImmInt 1))+                                         ]+              subcOp _ _ _+                = panic "genCCall: Wrong number of arguments/results for subc"+              addSubCOp instr platform width [res_r, res_c] [arg_x, arg_y]+                = do let reg_r = getRegisterReg platform (CmmLocal res_r)+                         reg_c = getRegisterReg platform (CmmLocal res_c)+                     (x_reg, x_code) <- getSomeReg arg_x+                     (y_reg, y_code) <- getSomeReg arg_y+                     return $ y_code `appOL` x_code+                            `appOL` toOL [ instr reg_r y_reg x_reg,+                                           -- SUBFO argument order reversed!+                                           MFOV (intFormat width) reg_c+                                         ]+              addSubCOp _ _ _ _ _+                = panic "genCall: Wrong number of arguments/results for addC"+              fabs platform [res] [arg]+                = do let res_r = getRegisterReg platform (CmmLocal res)+                     (arg_reg, arg_code) <- getSomeReg arg+                     return $ arg_code `snocOL` FABS res_r arg_reg+              fabs _ _ _+                = panic "genCall: Wrong number of arguments/results for fabs"++-- TODO: replace 'Int' by an enum such as 'PPC_64ABI'+data GenCCallPlatform = GCPLinux | GCPDarwin | GCPLinux64ELF !Int | GCPAIX++platformToGCP :: Platform -> GenCCallPlatform+platformToGCP platform = case platformOS platform of+    OSLinux  -> case platformArch platform of+        ArchPPC           -> GCPLinux+        ArchPPC_64 ELF_V1 -> GCPLinux64ELF 1+        ArchPPC_64 ELF_V2 -> GCPLinux64ELF 2+        _ -> panic "PPC.CodeGen.platformToGCP: Unknown Linux"+    OSAIX    -> GCPAIX+    OSDarwin -> GCPDarwin+    _ -> panic "PPC.CodeGen.platformToGCP: not defined for this OS"+++genCCall'+    :: DynFlags+    -> GenCCallPlatform+    -> ForeignTarget            -- function to call+    -> [CmmFormal]        -- where to put the result+    -> [CmmActual]        -- arguments (of mixed type)+    -> NatM InstrBlock++{-+    The PowerPC calling convention for Darwin/Mac OS X+    is described in Apple's document+    "Inside Mac OS X - Mach-O Runtime Architecture".++    PowerPC Linux uses the System V Release 4 Calling Convention+    for PowerPC. It is described in the+    "System V Application Binary Interface PowerPC Processor Supplement".++    Both conventions are similar:+    Parameters may be passed in general-purpose registers starting at r3, in+    floating point registers starting at f1, or on the stack.++    But there are substantial differences:+    * The number of registers used for parameter passing and the exact set of+      nonvolatile registers differs (see MachRegs.hs).+    * On Darwin, stack space is always reserved for parameters, even if they are+      passed in registers. The called routine may choose to save parameters from+      registers to the corresponding space on the stack.+    * On Darwin, a corresponding amount of GPRs is skipped when a floating point+      parameter is passed in an FPR.+    * SysV insists on either passing I64 arguments on the stack, or in two GPRs,+      starting with an odd-numbered GPR. It may skip a GPR to achieve this.+      Darwin just treats an I64 like two separate II32s (high word first).+    * I64 and FF64 arguments are 8-byte aligned on the stack for SysV, but only+      4-byte aligned like everything else on Darwin.+    * The SysV spec claims that FF32 is represented as FF64 on the stack. GCC on+      PowerPC Linux does not agree, so neither do we.++    PowerPC 64 Linux uses the System V Release 4 Calling Convention for+    64-bit PowerPC. It is specified in+    "64-bit PowerPC ELF Application Binary Interface Supplement 1.9"+    (PPC64 ELF v1.9).+    PowerPC 64 Linux in little endian mode uses the "Power Architecture 64-Bit+    ELF V2 ABI Specification -- OpenPOWER ABI for Linux Supplement"+    (PPC64 ELF v2).+    AIX follows the "PowerOpen ABI: Application Binary Interface Big-Endian+    32-Bit Hardware Implementation"++    According to all conventions, the parameter area should be part of the+    caller's stack frame, allocated in the caller's prologue code (large enough+    to hold the parameter lists for all called routines). The NCG already+    uses the stack for register spilling, leaving 64 bytes free at the top.+    If we need a larger parameter area than that, we just allocate a new stack+    frame just before ccalling.+-}+++genCCall' dflags gcp target dest_regs args+  = ASSERT(not $ any (`elem` [II16]) $ map cmmTypeFormat argReps)+        -- we rely on argument promotion in the codeGen+    do+        (finalStack,passArgumentsCode,usedRegs) <- passArguments+                                                        (zip args argReps)+                                                        allArgRegs+                                                        (allFPArgRegs platform)+                                                        initialStackOffset+                                                        (toOL []) []++        (labelOrExpr, reduceToFF32) <- case target of+            ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do+                uses_pic_base_implicitly+                return (Left lbl, False)+            ForeignTarget expr _ -> do+                uses_pic_base_implicitly+                return (Right expr, False)+            PrimTarget mop -> outOfLineMachOp mop++        let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode+            codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32++        case labelOrExpr of+            Left lbl -> do -- the linker does all the work for us+                return (         codeBefore+                        `snocOL` BL lbl usedRegs+                        `appOL`  maybeNOP -- some ABI require a NOP after BL+                        `appOL`  codeAfter)+            Right dyn -> do -- implement call through function pointer+                (dynReg, dynCode) <- getSomeReg dyn+                case gcp of+                     GCPLinux64ELF 1 -> return ( dynCode+                       `appOL`  codeBefore+                       `snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 40))+                       `snocOL` LD II64 r11 (AddrRegImm dynReg (ImmInt 0))+                       `snocOL` LD II64 toc (AddrRegImm dynReg (ImmInt 8))+                       `snocOL` MTCTR r11+                       `snocOL` LD II64 r11 (AddrRegImm dynReg (ImmInt 16))+                       `snocOL` BCTRL usedRegs+                       `snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 40))+                       `appOL`  codeAfter)+                     GCPLinux64ELF 2 -> return ( dynCode+                       `appOL`  codeBefore+                       `snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 24))+                       `snocOL` MR r12 dynReg+                       `snocOL` MTCTR r12+                       `snocOL` BCTRL usedRegs+                       `snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 24))+                       `appOL`  codeAfter)+                     GCPAIX          -> return ( dynCode+                       -- AIX/XCOFF follows the PowerOPEN ABI+                       -- which is quite similiar to LinuxPPC64/ELFv1+                       `appOL`  codeBefore+                       `snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 20))+                       `snocOL` LD II32 r11 (AddrRegImm dynReg (ImmInt 0))+                       `snocOL` LD II32 toc (AddrRegImm dynReg (ImmInt 4))+                       `snocOL` MTCTR r11+                       `snocOL` LD II32 r11 (AddrRegImm dynReg (ImmInt 8))+                       `snocOL` BCTRL usedRegs+                       `snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 20))+                       `appOL`  codeAfter)+                     _              -> return ( dynCode+                       `snocOL` MTCTR dynReg+                       `appOL`  codeBefore+                       `snocOL` BCTRL usedRegs+                       `appOL`  codeAfter)+    where+        platform = targetPlatform dflags++        uses_pic_base_implicitly = do+            -- See Note [implicit register in PPC PIC code]+            -- on why we claim to use PIC register here+            when (gopt Opt_PIC dflags && target32Bit platform) $ do+                _ <- getPicBaseNat $ archWordFormat True+                return ()++        initialStackOffset = case gcp of+                             GCPAIX          -> 24+                             GCPDarwin       -> 24+                             GCPLinux        -> 8+                             GCPLinux64ELF 1 -> 48+                             GCPLinux64ELF 2 -> 32+                             _ -> panic "genCall': unknown calling convention"+            -- size of linkage area + size of arguments, in bytes+        stackDelta finalStack = case gcp of+                                GCPAIX ->+                                    roundTo 16 $ (24 +) $ max 32 $ sum $+                                    map (widthInBytes . typeWidth) argReps+                                GCPDarwin ->+                                    roundTo 16 $ (24 +) $ max 32 $ sum $+                                    map (widthInBytes . typeWidth) argReps+                                GCPLinux -> roundTo 16 finalStack+                                GCPLinux64ELF 1 ->+                                    roundTo 16 $ (48 +) $ max 64 $ sum $+                                    map (roundTo 8 . widthInBytes . typeWidth)+                                        argReps+                                GCPLinux64ELF 2 ->+                                    roundTo 16 $ (32 +) $ max 64 $ sum $+                                    map (roundTo 8 . widthInBytes . typeWidth)+                                        argReps+                                _ -> panic "genCall': unknown calling conv."++        argReps = map (cmmExprType dflags) args++        roundTo a x | x `mod` a == 0 = x+                    | otherwise = x + a - (x `mod` a)++        spFormat = if target32Bit platform then II32 else II64++        -- TODO: Do not create a new stack frame if delta is too large.+        move_sp_down finalStack+               | delta > stackFrameHeaderSize dflags =+                        toOL [STU spFormat sp (AddrRegImm sp (ImmInt (-delta))),+                              DELTA (-delta)]+               | otherwise = nilOL+               where delta = stackDelta finalStack+        move_sp_up finalStack+               | delta > stackFrameHeaderSize dflags =+                        toOL [ADD sp sp (RIImm (ImmInt delta)),+                              DELTA 0]+               | otherwise = nilOL+               where delta = stackDelta finalStack++        -- A NOP instruction is required after a call (bl instruction)+        -- on AIX and 64-Bit Linux.+        -- If the call is to a function with a different TOC (r2) the+        -- link editor replaces the NOP instruction with a load of the TOC+        -- from the stack to restore the TOC.+        maybeNOP = case gcp of+           -- See Section 3.9.4 of OpenPower ABI+           GCPAIX          -> unitOL NOP+           -- See Section 3.5.11 of PPC64 ELF v1.9+           GCPLinux64ELF 1 -> unitOL NOP+           -- See Section 2.3.6 of PPC64 ELF v2+           GCPLinux64ELF 2 -> unitOL NOP+           _               -> nilOL++        passArguments [] _ _ stackOffset accumCode accumUsed = return (stackOffset, accumCode, accumUsed)+        passArguments ((arg,arg_ty):args) gprs fprs stackOffset+               accumCode accumUsed | isWord64 arg_ty+                                     && target32Bit (targetPlatform dflags) =+            do+                ChildCode64 code vr_lo <- iselExpr64 arg+                let vr_hi = getHiVRegFromLo vr_lo++                case gcp of+                    GCPAIX -> -- same as for Darwin+                        do let storeWord vr (gpr:_) _ = MR gpr vr+                               storeWord vr [] offset+                                   = ST II32 vr (AddrRegImm sp (ImmInt offset))+                           passArguments args+                                         (drop 2 gprs)+                                         fprs+                                         (stackOffset+8)+                                         (accumCode `appOL` code+                                               `snocOL` storeWord vr_hi gprs stackOffset+                                               `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4))+                                         ((take 2 gprs) ++ accumUsed)+                    GCPDarwin ->+                        do let storeWord vr (gpr:_) _ = MR gpr vr+                               storeWord vr [] offset+                                   = ST II32 vr (AddrRegImm sp (ImmInt offset))+                           passArguments args+                                         (drop 2 gprs)+                                         fprs+                                         (stackOffset+8)+                                         (accumCode `appOL` code+                                               `snocOL` storeWord vr_hi gprs stackOffset+                                               `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4))+                                         ((take 2 gprs) ++ accumUsed)+                    GCPLinux ->+                        do let stackOffset' = roundTo 8 stackOffset+                               stackCode = accumCode `appOL` code+                                   `snocOL` ST II32 vr_hi (AddrRegImm sp (ImmInt stackOffset'))+                                   `snocOL` ST II32 vr_lo (AddrRegImm sp (ImmInt (stackOffset'+4)))+                               regCode hireg loreg =+                                   accumCode `appOL` code+                                       `snocOL` MR hireg vr_hi+                                       `snocOL` MR loreg vr_lo++                           case gprs of+                               hireg : loreg : regs | even (length gprs) ->+                                   passArguments args regs fprs stackOffset+                                                 (regCode hireg loreg) (hireg : loreg : accumUsed)+                               _skipped : hireg : loreg : regs ->+                                   passArguments args regs fprs stackOffset+                                                 (regCode hireg loreg) (hireg : loreg : accumUsed)+                               _ -> -- only one or no regs left+                                   passArguments args [] fprs (stackOffset'+8)+                                                 stackCode accumUsed+                    GCPLinux64ELF _ -> panic "passArguments: 32 bit code"++        passArguments ((arg,rep):args) gprs fprs stackOffset accumCode accumUsed+            | reg : _ <- regs = do+                register <- getRegister arg+                let code = case register of+                            Fixed _ freg fcode -> fcode `snocOL` MR reg freg+                            Any _ acode -> acode reg+                    stackOffsetRes = case gcp of+                                     -- The Darwin ABI requires that we reserve+                                     -- stack slots for register parameters+                                     GCPDarwin -> stackOffset + stackBytes+                                     -- ... so does the PowerOpen ABI.+                                     GCPAIX    -> stackOffset + stackBytes+                                     -- ... the SysV ABI 32-bit doesn't.+                                     GCPLinux -> stackOffset+                                     -- ... but SysV ABI 64-bit does.+                                     GCPLinux64ELF _ -> stackOffset + stackBytes+                passArguments args+                              (drop nGprs gprs)+                              (drop nFprs fprs)+                              stackOffsetRes+                              (accumCode `appOL` code)+                              (reg : accumUsed)+            | otherwise = do+                (vr, code) <- getSomeReg arg+                passArguments args+                              (drop nGprs gprs)+                              (drop nFprs fprs)+                              (stackOffset' + stackBytes)+                              (accumCode `appOL` code `snocOL` ST (cmmTypeFormat rep) vr stackSlot)+                              accumUsed+            where+                stackOffset' = case gcp of+                               GCPDarwin ->+                                   -- stackOffset is at least 4-byte aligned+                                   -- The Darwin ABI is happy with that.+                                   stackOffset+                               GCPAIX ->+                                   -- The 32bit PowerOPEN ABI is happy with+                                   -- 32bit-alignment as well...+                                   stackOffset+                               GCPLinux+                                   -- ... the SysV ABI requires 8-byte+                                   -- alignment for doubles.+                                | isFloatType rep && typeWidth rep == W64 ->+                                   roundTo 8 stackOffset+                                | otherwise ->+                                   stackOffset+                               GCPLinux64ELF _ ->+                                   -- Everything on the stack is mapped to+                                   -- 8-byte aligned doublewords+                                   stackOffset+                stackOffset''+                     | isFloatType rep && typeWidth rep == W32 =+                         case gcp of+                         -- The ELF v1 ABI Section 3.2.3 requires:+                         -- "Single precision floating point values+                         -- are mapped to the second word in a single+                         -- doubleword"+                         GCPLinux64ELF 1 -> stackOffset' + 4+                         _               -> stackOffset'+                     | otherwise = stackOffset'++                stackSlot = AddrRegImm sp (ImmInt stackOffset'')+                (nGprs, nFprs, stackBytes, regs)+                    = case gcp of+                      GCPAIX ->+                          case cmmTypeFormat rep of+                          II8  -> (1, 0, 4, gprs)+                          II16 -> (1, 0, 4, gprs)+                          II32 -> (1, 0, 4, gprs)+                          -- The PowerOpen ABI requires that we skip a+                          -- corresponding number of GPRs when we use+                          -- the FPRs.+                          --+                          -- E.g. for a `double` two GPRs are skipped,+                          -- whereas for a `float` one GPR is skipped+                          -- when parameters are assigned to+                          -- registers.+                          --+                          -- The PowerOpen ABI specification can be found at+                          -- ftp://www.sourceware.org/pub/binutils/ppc-docs/ppc-poweropen/+                          FF32 -> (1, 1, 4, fprs)+                          FF64 -> (2, 1, 8, fprs)+                          II64 -> panic "genCCall' passArguments II64"+                          FF80 -> panic "genCCall' passArguments FF80"+                      GCPDarwin ->+                          case cmmTypeFormat rep of+                          II8  -> (1, 0, 4, gprs)+                          II16 -> (1, 0, 4, gprs)+                          II32 -> (1, 0, 4, gprs)+                          -- The Darwin ABI requires that we skip a+                          -- corresponding number of GPRs when we use+                          -- the FPRs.+                          FF32 -> (1, 1, 4, fprs)+                          FF64 -> (2, 1, 8, fprs)+                          II64 -> panic "genCCall' passArguments II64"+                          FF80 -> panic "genCCall' passArguments FF80"+                      GCPLinux ->+                          case cmmTypeFormat rep of+                          II8  -> (1, 0, 4, gprs)+                          II16 -> (1, 0, 4, gprs)+                          II32 -> (1, 0, 4, gprs)+                          -- ... the SysV ABI doesn't.+                          FF32 -> (0, 1, 4, fprs)+                          FF64 -> (0, 1, 8, fprs)+                          II64 -> panic "genCCall' passArguments II64"+                          FF80 -> panic "genCCall' passArguments FF80"+                      GCPLinux64ELF _ ->+                          case cmmTypeFormat rep of+                          II8  -> (1, 0, 8, gprs)+                          II16 -> (1, 0, 8, gprs)+                          II32 -> (1, 0, 8, gprs)+                          II64 -> (1, 0, 8, gprs)+                          -- The ELFv1 ABI requires that we skip a+                          -- corresponding number of GPRs when we use+                          -- the FPRs.+                          FF32 -> (1, 1, 8, fprs)+                          FF64 -> (1, 1, 8, fprs)+                          FF80 -> panic "genCCall' passArguments FF80"++        moveResult reduceToFF32 =+            case dest_regs of+                [] -> nilOL+                [dest]+                    | reduceToFF32 && isFloat32 rep   -> unitOL (FRSP r_dest f1)+                    | isFloat32 rep || isFloat64 rep -> unitOL (MR r_dest f1)+                    | isWord64 rep && target32Bit (targetPlatform dflags)+                       -> toOL [MR (getHiVRegFromLo r_dest) r3,+                                MR r_dest r4]+                    | otherwise -> unitOL (MR r_dest r3)+                    where rep = cmmRegType dflags (CmmLocal dest)+                          r_dest = getRegisterReg platform (CmmLocal dest)+                _ -> panic "genCCall' moveResult: Bad dest_regs"++        outOfLineMachOp mop =+            do+                dflags <- getDynFlags+                mopExpr <- cmmMakeDynamicReference dflags CallReference $+                              mkForeignLabel functionName Nothing ForeignLabelInThisPackage IsFunction+                let mopLabelOrExpr = case mopExpr of+                        CmmLit (CmmLabel lbl) -> Left lbl+                        _ -> Right mopExpr+                return (mopLabelOrExpr, reduce)+            where+                (functionName, reduce) = case mop of+                    MO_F32_Exp   -> (fsLit "exp", True)+                    MO_F32_Log   -> (fsLit "log", True)+                    MO_F32_Sqrt  -> (fsLit "sqrt", True)+                    MO_F32_Fabs  -> unsupported++                    MO_F32_Sin   -> (fsLit "sin", True)+                    MO_F32_Cos   -> (fsLit "cos", True)+                    MO_F32_Tan   -> (fsLit "tan", True)++                    MO_F32_Asin  -> (fsLit "asin", True)+                    MO_F32_Acos  -> (fsLit "acos", True)+                    MO_F32_Atan  -> (fsLit "atan", True)++                    MO_F32_Sinh  -> (fsLit "sinh", True)+                    MO_F32_Cosh  -> (fsLit "cosh", True)+                    MO_F32_Tanh  -> (fsLit "tanh", True)+                    MO_F32_Pwr   -> (fsLit "pow", True)++                    MO_F64_Exp   -> (fsLit "exp", False)+                    MO_F64_Log   -> (fsLit "log", False)+                    MO_F64_Sqrt  -> (fsLit "sqrt", False)+                    MO_F64_Fabs  -> unsupported++                    MO_F64_Sin   -> (fsLit "sin", False)+                    MO_F64_Cos   -> (fsLit "cos", False)+                    MO_F64_Tan   -> (fsLit "tan", False)++                    MO_F64_Asin  -> (fsLit "asin", False)+                    MO_F64_Acos  -> (fsLit "acos", False)+                    MO_F64_Atan  -> (fsLit "atan", False)++                    MO_F64_Sinh  -> (fsLit "sinh", False)+                    MO_F64_Cosh  -> (fsLit "cosh", False)+                    MO_F64_Tanh  -> (fsLit "tanh", False)+                    MO_F64_Pwr   -> (fsLit "pow", False)++                    MO_UF_Conv w -> (fsLit $ word2FloatLabel w, False)++                    MO_Memcpy _  -> (fsLit "memcpy", False)+                    MO_Memset _  -> (fsLit "memset", False)+                    MO_Memmove _ -> (fsLit "memmove", False)++                    MO_BSwap w   -> (fsLit $ bSwapLabel w, False)+                    MO_PopCnt w  -> (fsLit $ popCntLabel w, False)+                    MO_Clz w     -> (fsLit $ clzLabel w, False)+                    MO_Ctz w     -> (fsLit $ ctzLabel w, False)+                    MO_AtomicRMW w amop -> (fsLit $ atomicRMWLabel w amop, False)+                    MO_Cmpxchg w -> (fsLit $ cmpxchgLabel w, False)+                    MO_AtomicRead w  -> (fsLit $ atomicReadLabel w, False)+                    MO_AtomicWrite w -> (fsLit $ atomicWriteLabel w, False)++                    MO_S_QuotRem {}  -> unsupported+                    MO_U_QuotRem {}  -> unsupported+                    MO_U_QuotRem2 {} -> unsupported+                    MO_Add2 {}       -> unsupported+                    MO_SubWordC {}   -> unsupported+                    MO_AddIntC {}    -> unsupported+                    MO_SubIntC {}    -> unsupported+                    MO_U_Mul2 {}     -> unsupported+                    MO_WriteBarrier  -> unsupported+                    MO_Touch         -> unsupported+                    (MO_Prefetch_Data _ ) -> unsupported+                unsupported = panic ("outOfLineCmmOp: " ++ show mop+                                  ++ " not supported")++-- -----------------------------------------------------------------------------+-- Generating a table-branch++genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock+genSwitch dflags expr targets+  | OSAIX <- platformOS (targetPlatform dflags)+  = do+        (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)+        let fmt = archWordFormat $ target32Bit $ targetPlatform dflags+            sha = if target32Bit $ targetPlatform dflags then 2 else 3+        tmp <- getNewRegNat fmt+        lbl <- getNewLabelNat+        dynRef <- cmmMakeDynamicReference dflags DataReference lbl+        (tableReg,t_code) <- getSomeReg $ dynRef+        let code = e_code `appOL` t_code `appOL` toOL [+                            SL fmt tmp reg (RIImm (ImmInt sha)),+                            LD fmt tmp (AddrRegReg tableReg tmp),+                            MTCTR tmp,+                            BCTR ids (Just lbl)+                    ]+        return code++  | (gopt Opt_PIC dflags) || (not $ target32Bit $ targetPlatform dflags)+  = do+        (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)+        let fmt = archWordFormat $ target32Bit $ targetPlatform dflags+            sha = if target32Bit $ targetPlatform dflags then 2 else 3+        tmp <- getNewRegNat fmt+        lbl <- getNewLabelNat+        dynRef <- cmmMakeDynamicReference dflags DataReference lbl+        (tableReg,t_code) <- getSomeReg $ dynRef+        let code = e_code `appOL` t_code `appOL` toOL [+                            SL fmt tmp reg (RIImm (ImmInt sha)),+                            LD fmt tmp (AddrRegReg tableReg tmp),+                            ADD tmp tmp (RIReg tableReg),+                            MTCTR tmp,+                            BCTR ids (Just lbl)+                    ]+        return code+  | otherwise+  = do+        (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)+        let fmt = archWordFormat $ target32Bit $ targetPlatform dflags+            sha = if target32Bit $ targetPlatform dflags then 2 else 3+        tmp <- getNewRegNat fmt+        lbl <- getNewLabelNat+        let code = e_code `appOL` toOL [+                            SL fmt tmp reg (RIImm (ImmInt sha)),+                            ADDIS tmp tmp (HA (ImmCLbl lbl)),+                            LD fmt tmp (AddrRegImm tmp (LO (ImmCLbl lbl))),+                            MTCTR tmp,+                            BCTR ids (Just lbl)+                    ]+        return code+  where (offset, ids) = switchTargetsToTable targets++generateJumpTableForInstr :: DynFlags -> Instr+                          -> Maybe (NatCmmDecl CmmStatics Instr)+generateJumpTableForInstr dflags (BCTR ids (Just lbl)) =+    let jumpTable+            | (gopt Opt_PIC dflags)+              || (not $ target32Bit $ targetPlatform dflags)+            = map jumpTableEntryRel ids+            | otherwise = map (jumpTableEntry dflags) ids+                where jumpTableEntryRel Nothing+                        = CmmStaticLit (CmmInt 0 (wordWidth dflags))+                      jumpTableEntryRel (Just blockid)+                        = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)+                            where blockLabel = mkAsmTempLabel (getUnique blockid)+    in Just (CmmData (Section ReadOnlyData lbl) (Statics lbl jumpTable))+generateJumpTableForInstr _ _ = Nothing++-- -----------------------------------------------------------------------------+-- 'condIntReg' and 'condFltReg': condition codes into registers++-- Turn those condition codes into integers now (when they appear on+-- the right hand side of an assignment).++condIntReg, condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register++condReg :: NatM CondCode -> NatM Register+condReg getCond = do+    CondCode _ cond cond_code <- getCond+    dflags <- getDynFlags+    let+        code dst = cond_code+            `appOL` negate_code+            `appOL` toOL [+                MFCR dst,+                RLWINM dst dst (bit + 1) 31 31+            ]++        negate_code | do_negate = unitOL (CRNOR bit bit bit)+                    | otherwise = nilOL++        (bit, do_negate) = case cond of+            LTT -> (0, False)+            LE  -> (1, True)+            EQQ -> (2, False)+            GE  -> (0, True)+            GTT -> (1, False)++            NE  -> (2, True)++            LU  -> (0, False)+            LEU -> (1, True)+            GEU -> (0, True)+            GU  -> (1, False)+            _   -> panic "PPC.CodeGen.codeReg: no match"++        format = archWordFormat $ target32Bit $ targetPlatform dflags+    return (Any format code)++condIntReg cond x y = condReg (condIntCode cond x y)+condFltReg cond x y = condReg (condFltCode cond x y)++++-- -----------------------------------------------------------------------------+-- 'trivial*Code': deal with trivial instructions++-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',+-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.+-- Only look for constants on the right hand side, because that's+-- where the generic optimizer will have put them.++-- Similarly, for unary instructions, we don't have to worry about+-- matching an StInt as the argument, because genericOpt will already+-- have handled the constant-folding.++++{-+Wolfgang's PowerPC version of The Rules:++A slightly modified version of The Rules to take advantage of the fact+that PowerPC instructions work on all registers and don't implicitly+clobber any fixed registers.++* The only expression for which getRegister returns Fixed is (CmmReg reg).++* If getRegister returns Any, then the code it generates may modify only:+        (a) fresh temporaries+        (b) the destination register+  It may *not* modify global registers, unless the global+  register happens to be the destination register.+  It may not clobber any other registers. In fact, only ccalls clobber any+  fixed registers.+  Also, it may not modify the counter register (used by genCCall).++  Corollary: If a getRegister for a subexpression returns Fixed, you need+  not move it to a fresh temporary before evaluating the next subexpression.+  The Fixed register won't be modified.+  Therefore, we don't need a counterpart for the x86's getStableReg on PPC.++* SDM's First Rule is valid for PowerPC, too: subexpressions can depend on+  the value of the destination register.+-}++trivialCode+        :: Width+        -> Bool+        -> (Reg -> Reg -> RI -> Instr)+        -> CmmExpr+        -> CmmExpr+        -> NatM Register++trivialCode rep signed instr x (CmmLit (CmmInt y _))+    | Just imm <- makeImmediate rep signed y+    = do+        (src1, code1) <- getSomeReg x+        let code dst = code1 `snocOL` instr dst src1 (RIImm imm)+        return (Any (intFormat rep) code)++trivialCode rep _ instr x y = do+    (src1, code1) <- getSomeReg x+    (src2, code2) <- getSomeReg y+    let code dst = code1 `appOL` code2 `snocOL` instr dst src1 (RIReg src2)+    return (Any (intFormat rep) code)++shiftMulCode+        :: Width+        -> Bool+        -> (Format-> Reg -> Reg -> RI -> Instr)+        -> CmmExpr+        -> CmmExpr+        -> NatM Register+shiftMulCode width sign instr x (CmmLit (CmmInt y _))+    | Just imm <- makeImmediate width sign y+    = do+        (src1, code1) <- getSomeReg x+        let format = intFormat width+        let code dst = code1 `snocOL` instr format dst src1 (RIImm imm)+        return (Any format code)++shiftMulCode width _ instr x y = do+    (src1, code1) <- getSomeReg x+    (src2, code2) <- getSomeReg y+    let format = intFormat width+    let code dst = code1 `appOL` code2 `snocOL` instr format dst src1 (RIReg src2)+    return (Any format code)++trivialCodeNoImm' :: Format -> (Reg -> Reg -> Reg -> Instr)+                 -> CmmExpr -> CmmExpr -> NatM Register+trivialCodeNoImm' format instr x y = do+    (src1, code1) <- getSomeReg x+    (src2, code2) <- getSomeReg y+    let code dst = code1 `appOL` code2 `snocOL` instr dst src1 src2+    return (Any format code)++trivialCodeNoImm :: Format -> (Format -> Reg -> Reg -> Reg -> Instr)+                 -> CmmExpr -> CmmExpr -> NatM Register+trivialCodeNoImm format instr x y = trivialCodeNoImm' format (instr format) x y++trivialCodeNoImmSign :: Format -> Bool+                     -> (Format -> Bool -> Reg -> Reg -> Reg -> Instr)+                     -> CmmExpr -> CmmExpr -> NatM Register+trivialCodeNoImmSign  format sgn instr x y+  = trivialCodeNoImm' format (instr format sgn) x y+++trivialUCode+        :: Format+        -> (Reg -> Reg -> Instr)+        -> CmmExpr+        -> NatM Register+trivialUCode rep instr x = do+    (src, code) <- getSomeReg x+    let code' dst = code `snocOL` instr dst src+    return (Any rep code')++-- There is no "remainder" instruction on the PPC, so we have to do+-- it the hard way.+-- The "sgn" parameter is the signedness for the division instruction++remainderCode :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register+remainderCode rep sgn x y = do+    let fmt = intFormat rep+    (src1, code1) <- getSomeReg x+    (src2, code2) <- getSomeReg y+    let code dst = code1 `appOL` code2 `appOL` toOL [+                DIV fmt sgn dst src1 src2,+                MULL fmt dst dst (RIReg src2),+                SUBF dst dst src1+            ]+    return (Any (intFormat rep) code)++coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register+coerceInt2FP fromRep toRep x = do+    dflags <- getDynFlags+    let arch =  platformArch $ targetPlatform dflags+    coerceInt2FP' arch fromRep toRep x++coerceInt2FP' :: Arch -> Width -> Width -> CmmExpr -> NatM Register+coerceInt2FP' ArchPPC fromRep toRep x = do+    (src, code) <- getSomeReg x+    lbl <- getNewLabelNat+    itmp <- getNewRegNat II32+    ftmp <- getNewRegNat FF64+    dflags <- getDynFlags+    dynRef <- cmmMakeDynamicReference dflags DataReference lbl+    Amode addr addr_code <- getAmode D dynRef+    let+        code' dst = code `appOL` maybe_exts `appOL` toOL [+                LDATA (Section ReadOnlyData lbl) $ Statics lbl+                                 [CmmStaticLit (CmmInt 0x43300000 W32),+                                  CmmStaticLit (CmmInt 0x80000000 W32)],+                XORIS itmp src (ImmInt 0x8000),+                ST II32 itmp (spRel dflags 3),+                LIS itmp (ImmInt 0x4330),+                ST II32 itmp (spRel dflags 2),+                LD FF64 ftmp (spRel dflags 2)+            ] `appOL` addr_code `appOL` toOL [+                LD FF64 dst addr,+                FSUB FF64 dst ftmp dst+            ] `appOL` maybe_frsp dst++        maybe_exts = case fromRep of+                        W8 ->  unitOL $ EXTS II8 src src+                        W16 -> unitOL $ EXTS II16 src src+                        W32 -> nilOL+                        _       -> panic "PPC.CodeGen.coerceInt2FP: no match"++        maybe_frsp dst+                = case toRep of+                        W32 -> unitOL $ FRSP dst dst+                        W64 -> nilOL+                        _       -> panic "PPC.CodeGen.coerceInt2FP: no match"++    return (Any (floatFormat toRep) code')++-- On an ELF v1 Linux we use the compiler doubleword in the stack frame+-- this is the TOC pointer doubleword on ELF v2 Linux. The latter is only+-- set right before a call and restored right after return from the call.+-- So it is fine.+coerceInt2FP' (ArchPPC_64 _) fromRep toRep x = do+    (src, code) <- getSomeReg x+    dflags <- getDynFlags+    let+        code' dst = code `appOL` maybe_exts `appOL` toOL [+                ST II64 src (spRel dflags 3),+                LD FF64 dst (spRel dflags 3),+                FCFID dst dst+            ] `appOL` maybe_frsp dst++        maybe_exts = case fromRep of+                        W8 ->  unitOL $ EXTS II8 src src+                        W16 -> unitOL $ EXTS II16 src src+                        W32 -> unitOL $ EXTS II32 src src+                        W64 -> nilOL+                        _       -> panic "PPC.CodeGen.coerceInt2FP: no match"++        maybe_frsp dst+                = case toRep of+                        W32 -> unitOL $ FRSP dst dst+                        W64 -> nilOL+                        _       -> panic "PPC.CodeGen.coerceInt2FP: no match"++    return (Any (floatFormat toRep) code')++coerceInt2FP' _ _ _ _ = panic "PPC.CodeGen.coerceInt2FP: unknown arch"+++coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register+coerceFP2Int fromRep toRep x = do+    dflags <- getDynFlags+    let arch =  platformArch $ targetPlatform dflags+    coerceFP2Int' arch fromRep toRep x++coerceFP2Int' :: Arch -> Width -> Width -> CmmExpr -> NatM Register+coerceFP2Int' ArchPPC _ toRep x = do+    dflags <- getDynFlags+    -- the reps don't really matter: F*->FF64 and II32->I* are no-ops+    (src, code) <- getSomeReg x+    tmp <- getNewRegNat FF64+    let+        code' dst = code `appOL` toOL [+                -- convert to int in FP reg+            FCTIWZ tmp src,+                -- store value (64bit) from FP to stack+            ST FF64 tmp (spRel dflags 2),+                -- read low word of value (high word is undefined)+            LD II32 dst (spRel dflags 3)]+    return (Any (intFormat toRep) code')++coerceFP2Int' (ArchPPC_64 _) _ toRep x = do+    dflags <- getDynFlags+    -- the reps don't really matter: F*->FF64 and II64->I* are no-ops+    (src, code) <- getSomeReg x+    tmp <- getNewRegNat FF64+    let+        code' dst = code `appOL` toOL [+                -- convert to int in FP reg+            FCTIDZ tmp src,+                -- store value (64bit) from FP to compiler word on stack+            ST FF64 tmp (spRel dflags 3),+            LD II64 dst (spRel dflags 3)]+    return (Any (intFormat toRep) code')++coerceFP2Int' _ _ _ _ = panic "PPC.CodeGen.coerceFP2Int: unknown arch"++-- Note [.LCTOC1 in PPC PIC code]+-- The .LCTOC1 label is defined to point 32768 bytes into the GOT table+-- to make the most of the PPC's 16-bit displacements.+-- As 16-bit signed offset is used (usually via addi/lwz instructions)+-- first element will have '-32768' offset against .LCTOC1.++-- Note [implicit register in PPC PIC code]+-- PPC generates calls by labels in assembly+-- in form of:+--     bl puts+32768@plt+-- in this form it's not seen directly (by GHC NCG)+-- that r30 (PicBaseReg) is used,+-- but r30 is a required part of PLT code setup:+--   puts+32768@plt:+--       lwz     r11,-30484(r30) ; offset in .LCTOC1+--       mtctr   r11+--       bctr
+ nativeGen/PPC/Cond.hs view
@@ -0,0 +1,61 @@+module PPC.Cond (+        Cond(..),+        condNegate,+        condUnsigned,+        condToSigned,+        condToUnsigned,+)++where++import Panic++data Cond+        = ALWAYS+        | EQQ+        | GE+        | GEU+        | GTT+        | GU+        | LE+        | LEU+        | LTT+        | LU+        | NE+        deriving Eq+++condNegate :: Cond -> Cond+condNegate ALWAYS  = panic "condNegate: ALWAYS"+condNegate EQQ     = NE+condNegate GE      = LTT+condNegate GEU     = LU+condNegate GTT     = LE+condNegate GU      = LEU+condNegate LE      = GTT+condNegate LEU     = GU+condNegate LTT     = GE+condNegate LU      = GEU+condNegate NE      = EQQ++-- Condition utils+condUnsigned :: Cond -> Bool+condUnsigned GU  = True+condUnsigned LU  = True+condUnsigned GEU = True+condUnsigned LEU = True+condUnsigned _   = False++condToSigned :: Cond -> Cond+condToSigned GU  = GTT+condToSigned LU  = LTT+condToSigned GEU = GE+condToSigned LEU = LE+condToSigned x   = x++condToUnsigned :: Cond -> Cond+condToUnsigned GTT = GU+condToUnsigned LTT = LU+condToUnsigned GE  = GEU+condToUnsigned LE  = LEU+condToUnsigned x   = x
+ nativeGen/PPC/Instr.hs view
@@ -0,0 +1,686 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Machine-dependent assembly language+--+-- (c) The University of Glasgow 1993-2004+--+-----------------------------------------------------------------------------++#include "HsVersions.h"+#include "nativeGen/NCG.h"++module PPC.Instr (+    archWordFormat,+    RI(..),+    Instr(..),+    stackFrameHeaderSize,+    maxSpillSlots,+    allocMoreStack,+    makeFarBranches+)++where++import PPC.Regs+import PPC.Cond+import Instruction+import Format+import TargetReg+import RegClass+import Reg++import CodeGen.Platform+import BlockId+import Hoopl+import DynFlags+import Cmm+import CmmInfo+import FastString+import CLabel+import Outputable+import Platform+import UniqFM (listToUFM, lookupUFM)+import UniqSupply++import Control.Monad (replicateM)+import Data.Maybe (fromMaybe)++--------------------------------------------------------------------------------+-- Format of a PPC memory address.+--+archWordFormat :: Bool -> Format+archWordFormat is32Bit+ | is32Bit   = II32+ | otherwise = II64+++-- | Instruction instance for powerpc+instance Instruction Instr where+        regUsageOfInstr         = ppc_regUsageOfInstr+        patchRegsOfInstr        = ppc_patchRegsOfInstr+        isJumpishInstr          = ppc_isJumpishInstr+        jumpDestsOfInstr        = ppc_jumpDestsOfInstr+        patchJumpInstr          = ppc_patchJumpInstr+        mkSpillInstr            = ppc_mkSpillInstr+        mkLoadInstr             = ppc_mkLoadInstr+        takeDeltaInstr          = ppc_takeDeltaInstr+        isMetaInstr             = ppc_isMetaInstr+        mkRegRegMoveInstr _     = ppc_mkRegRegMoveInstr+        takeRegRegMoveInstr     = ppc_takeRegRegMoveInstr+        mkJumpInstr             = ppc_mkJumpInstr+        mkStackAllocInstr       = ppc_mkStackAllocInstr+        mkStackDeallocInstr     = ppc_mkStackDeallocInstr+++ppc_mkStackAllocInstr :: Platform -> Int -> Instr+ppc_mkStackAllocInstr platform amount+  = ppc_mkStackAllocInstr' platform (-amount)++ppc_mkStackDeallocInstr :: Platform -> Int -> Instr+ppc_mkStackDeallocInstr platform amount+  = ppc_mkStackAllocInstr' platform amount++ppc_mkStackAllocInstr' :: Platform -> Int -> Instr+ppc_mkStackAllocInstr' platform amount+  = case platformArch platform of+    ArchPPC      -> UPDATE_SP II32 (ImmInt amount)+    ArchPPC_64 _ -> UPDATE_SP II64 (ImmInt amount)+    _            -> panic $ "ppc_mkStackAllocInstr' "+                            ++ show (platformArch platform)++--+-- See note [extra spill slots] in X86/Instr.hs+--+allocMoreStack+  :: Platform+  -> Int+  -> NatCmmDecl statics PPC.Instr.Instr+  -> UniqSM (NatCmmDecl statics PPC.Instr.Instr)++allocMoreStack _ _ top@(CmmData _ _) = return top+allocMoreStack platform slots (CmmProc info lbl live (ListGraph code)) = do+    let+        infos   = mapKeys info+        entries = case code of+                    [] -> infos+                    BasicBlock entry _ : _ -- first block is the entry point+                        | entry `elem` infos -> infos+                        | otherwise          -> entry : infos++    uniqs <- replicateM (length entries) getUniqueM++    let+        delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up+            where x = slots * spillSlotSize -- sp delta++        alloc   = mkStackAllocInstr   platform delta+        dealloc = mkStackDeallocInstr platform delta++        new_blockmap :: LabelMap BlockId+        new_blockmap = mapFromList (zip entries (map mkBlockId uniqs))++        insert_stack_insns (BasicBlock id insns)+            | Just new_blockid <- mapLookup id new_blockmap+                = [ BasicBlock id [alloc, BCC ALWAYS new_blockid]+                  , BasicBlock new_blockid block'+                  ]+            | otherwise+                = [ BasicBlock id block' ]+            where+              block' = foldr insert_dealloc [] insns++        insert_dealloc insn r+            -- BCTR might or might not be a non-local jump. For+            -- "labeled-goto" we use JMP, and for "computed-goto" we+            -- use MTCTR followed by BCTR. See 'PPC.CodeGen.genJump'.+            = case insn of+                JMP _           -> dealloc : insn : r+                BCTR [] Nothing -> dealloc : insn : r+                BCTR ids label  -> BCTR (map (fmap retarget) ids) label : r+                BCCFAR cond b   -> BCCFAR cond (retarget b) : r+                BCC    cond b   -> BCC    cond (retarget b) : r+                _               -> insn : r+            -- BL and BCTRL are call-like instructions rather than+            -- jumps, and are used only for C calls.++        retarget :: BlockId -> BlockId+        retarget b+            = fromMaybe b (mapLookup b new_blockmap)++        new_code+            = concatMap insert_stack_insns code++    -- in+    return (CmmProc info lbl live (ListGraph new_code))+++-- -----------------------------------------------------------------------------+-- Machine's assembly language++-- We have a few common "instructions" (nearly all the pseudo-ops) but+-- mostly all of 'Instr' is machine-specific.++-- Register or immediate+data RI+    = RIReg Reg+    | RIImm Imm++data Instr+    -- comment pseudo-op+    = COMMENT FastString++    -- some static data spat out during code+    -- generation.  Will be extracted before+    -- pretty-printing.+    | LDATA   Section CmmStatics++    -- start a new basic block.  Useful during+    -- codegen, removed later.  Preceding+    -- instruction should be a jump, as per the+    -- invariants for a BasicBlock (see Cmm).+    | NEWBLOCK BlockId++    -- specify current stack offset for+    -- benefit of subsequent passes+    | DELTA   Int++    -- Loads and stores.+    | LD      Format Reg AddrMode   -- Load format, dst, src+    | LDFAR   Format Reg AddrMode   -- Load format, dst, src 32 bit offset+    | LA      Format Reg AddrMode   -- Load arithmetic format, dst, src+    | ST      Format Reg AddrMode   -- Store format, src, dst+    | STFAR   Format Reg AddrMode   -- Store format, src, dst 32 bit offset+    | STU     Format Reg AddrMode   -- Store with Update format, src, dst+    | LIS     Reg Imm               -- Load Immediate Shifted dst, src+    | LI      Reg Imm               -- Load Immediate dst, src+    | MR      Reg Reg               -- Move Register dst, src -- also for fmr++    | CMP     Format Reg RI         -- format, src1, src2+    | CMPL    Format Reg RI         -- format, src1, src2++    | BCC     Cond BlockId+    | BCCFAR  Cond BlockId+    | JMP     CLabel                -- same as branch,+                                    -- but with CLabel instead of block ID+    | MTCTR   Reg+    | BCTR    [Maybe BlockId] (Maybe CLabel) -- with list of local destinations, and jump table location if necessary+    | BL      CLabel [Reg]          -- with list of argument regs+    | BCTRL   [Reg]++    | ADD     Reg Reg RI            -- dst, src1, src2+    | ADDO    Reg Reg Reg           -- add and set overflow+    | ADDC    Reg Reg Reg           -- (carrying) dst, src1, src2+    | ADDE    Reg Reg Reg           -- (extended) dst, src1, src2+    | ADDZE   Reg Reg               -- (to zero extended) dst, src+    | ADDIS   Reg Reg Imm           -- Add Immediate Shifted dst, src1, src2+    | SUBF    Reg Reg Reg           -- dst, src1, src2 ; dst = src2 - src1+    | SUBFO   Reg Reg Reg           -- subtract from and set overflow+    | SUBFC   Reg Reg RI            -- (carrying) dst, src1, src2 ;+                                    -- dst = src2 - src1+    | SUBFE   Reg Reg Reg           -- (extended) dst, src1, src2 ;+                                    -- dst = src2 - src1+    | MULL    Format Reg Reg RI+    | MULLO   Format Reg Reg Reg    -- multiply and set overflow+    | MFOV    Format Reg            -- move overflow bit (1|33) to register+                                    -- pseudo-instruction; pretty printed as+                                    -- mfxer dst+                                    -- extr[w|d]i dst, dst, 1, [1|33]+    | MULHU   Format Reg Reg Reg+    | DIV     Format Bool Reg Reg Reg+    | AND     Reg Reg RI            -- dst, src1, src2+    | ANDC    Reg Reg Reg           -- AND with complement, dst = src1 & ~ src2+    | OR      Reg Reg RI            -- dst, src1, src2+    | ORIS    Reg Reg Imm           -- OR Immediate Shifted dst, src1, src2+    | XOR     Reg Reg RI            -- dst, src1, src2+    | XORIS   Reg Reg Imm           -- XOR Immediate Shifted dst, src1, src2++    | EXTS    Format Reg Reg+    | CNTLZ   Format Reg Reg++    | NEG     Reg Reg+    | NOT     Reg Reg++    | SL      Format Reg Reg RI            -- shift left+    | SR      Format Reg Reg RI            -- shift right+    | SRA     Format Reg Reg RI            -- shift right arithmetic++    | RLWINM  Reg Reg Int Int Int   -- Rotate Left Word Immediate then AND with Mask+    | CLRLI   Format Reg Reg Int    -- clear left immediate (extended mnemonic)+    | CLRRI   Format Reg Reg Int    -- clear right immediate (extended mnemonic)++    | FADD    Format Reg Reg Reg+    | FSUB    Format Reg Reg Reg+    | FMUL    Format Reg Reg Reg+    | FDIV    Format Reg Reg Reg+    | FABS    Reg Reg               -- abs is the same for single and double+    | FNEG    Reg Reg               -- negate is the same for single and double prec.++    | FCMP    Reg Reg++    | FCTIWZ  Reg Reg           -- convert to integer word+    | FCTIDZ  Reg Reg           -- convert to integer double word+    | FCFID   Reg Reg           -- convert from integer double word+    | FRSP    Reg Reg           -- reduce to single precision+                                -- (but destination is a FP register)++    | CRNOR   Int Int Int       -- condition register nor+    | MFCR    Reg               -- move from condition register++    | MFLR    Reg               -- move from link register+    | FETCHPC Reg               -- pseudo-instruction:+                                -- bcl to next insn, mflr reg+    | LWSYNC                    -- memory barrier+    | NOP                       -- no operation, PowerPC 64 bit+                                -- needs this as place holder to+                                -- reload TOC pointer+    | UPDATE_SP Format Imm      -- expand/shrink spill area on C stack+                                -- pseudo-instruction++-- | Get the registers that are being used by this instruction.+-- regUsage doesn't need to do any trickery for jumps and such.+-- Just state precisely the regs read and written by that insn.+-- The consequences of control flow transfers, as far as register+-- allocation goes, are taken care of by the register allocator.+--+ppc_regUsageOfInstr :: Platform -> Instr -> RegUsage+ppc_regUsageOfInstr platform instr+ = case instr of+    LD      _ reg addr       -> usage (regAddr addr, [reg])+    LDFAR   _ reg addr       -> usage (regAddr addr, [reg])+    LA      _ reg addr       -> usage (regAddr addr, [reg])+    ST      _ reg addr       -> usage (reg : regAddr addr, [])+    STFAR   _ reg addr       -> usage (reg : regAddr addr, [])+    STU     _ reg addr       -> usage (reg : regAddr addr, [])+    LIS     reg _            -> usage ([], [reg])+    LI      reg _            -> usage ([], [reg])+    MR      reg1 reg2        -> usage ([reg2], [reg1])+    CMP     _ reg ri         -> usage (reg : regRI ri,[])+    CMPL    _ reg ri         -> usage (reg : regRI ri,[])+    BCC     _ _              -> noUsage+    BCCFAR  _ _              -> noUsage+    MTCTR   reg              -> usage ([reg],[])+    BCTR    _ _              -> noUsage+    BL      _ params         -> usage (params, callClobberedRegs platform)+    BCTRL   params           -> usage (params, callClobberedRegs platform)++    ADD     reg1 reg2 ri     -> usage (reg2 : regRI ri, [reg1])+    ADDO    reg1 reg2 reg3   -> usage ([reg2,reg3], [reg1])+    ADDC    reg1 reg2 reg3   -> usage ([reg2,reg3], [reg1])+    ADDE    reg1 reg2 reg3   -> usage ([reg2,reg3], [reg1])+    ADDZE   reg1 reg2        -> usage ([reg2], [reg1])+    ADDIS   reg1 reg2 _      -> usage ([reg2], [reg1])+    SUBF    reg1 reg2 reg3   -> usage ([reg2,reg3], [reg1])+    SUBFO   reg1 reg2 reg3   -> usage ([reg2,reg3], [reg1])+    SUBFC   reg1 reg2 ri     -> usage (reg2 : regRI ri, [reg1])+    SUBFE   reg1 reg2 reg3   -> usage ([reg2,reg3], [reg1])+    MULL    _ reg1 reg2 ri   -> usage (reg2 : regRI ri, [reg1])+    MULLO   _ reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1])+    MFOV    _ reg            -> usage ([], [reg])+    MULHU   _ reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1])+    DIV     _ _ reg1 reg2 reg3+                             -> usage ([reg2,reg3], [reg1])++    AND     reg1 reg2 ri    -> usage (reg2 : regRI ri, [reg1])+    ANDC    reg1 reg2 reg3  -> usage ([reg2,reg3], [reg1])+    OR      reg1 reg2 ri    -> usage (reg2 : regRI ri, [reg1])+    ORIS    reg1 reg2 _     -> usage ([reg2], [reg1])+    XOR     reg1 reg2 ri    -> usage (reg2 : regRI ri, [reg1])+    XORIS   reg1 reg2 _     -> usage ([reg2], [reg1])+    EXTS    _  reg1 reg2    -> usage ([reg2], [reg1])+    CNTLZ   _  reg1 reg2    -> usage ([reg2], [reg1])+    NEG     reg1 reg2       -> usage ([reg2], [reg1])+    NOT     reg1 reg2       -> usage ([reg2], [reg1])+    SL      _ reg1 reg2 ri  -> usage (reg2 : regRI ri, [reg1])+    SR      _ reg1 reg2 ri  -> usage (reg2 : regRI ri, [reg1])+    SRA     _ reg1 reg2 ri  -> usage (reg2 : regRI ri, [reg1])+    RLWINM  reg1 reg2 _ _ _ -> usage ([reg2], [reg1])+    CLRLI   _ reg1 reg2 _   -> usage ([reg2], [reg1])+    CLRRI   _ reg1 reg2 _   -> usage ([reg2], [reg1])++    FADD    _ r1 r2 r3      -> usage ([r2,r3], [r1])+    FSUB    _ r1 r2 r3      -> usage ([r2,r3], [r1])+    FMUL    _ r1 r2 r3      -> usage ([r2,r3], [r1])+    FDIV    _ r1 r2 r3      -> usage ([r2,r3], [r1])+    FABS    r1 r2           -> usage ([r2], [r1])+    FNEG    r1 r2           -> usage ([r2], [r1])+    FCMP    r1 r2           -> usage ([r1,r2], [])+    FCTIWZ  r1 r2           -> usage ([r2], [r1])+    FCTIDZ  r1 r2           -> usage ([r2], [r1])+    FCFID   r1 r2           -> usage ([r2], [r1])+    FRSP    r1 r2           -> usage ([r2], [r1])+    MFCR    reg             -> usage ([], [reg])+    MFLR    reg             -> usage ([], [reg])+    FETCHPC reg             -> usage ([], [reg])+    UPDATE_SP _ _           -> usage ([], [sp])+    _                       -> noUsage+  where+    usage (src, dst) = RU (filter (interesting platform) src)+                          (filter (interesting platform) dst)+    regAddr (AddrRegReg r1 r2) = [r1, r2]+    regAddr (AddrRegImm r1 _)  = [r1]++    regRI (RIReg r) = [r]+    regRI  _        = []++interesting :: Platform -> Reg -> Bool+interesting _        (RegVirtual _)              = True+interesting platform (RegReal (RealRegSingle i)) = freeReg platform i+interesting _        (RegReal (RealRegPair{}))+    = panic "PPC.Instr.interesting: no reg pairs on this arch"++++-- | Apply a given mapping to all the register references in this+-- instruction.+ppc_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr+ppc_patchRegsOfInstr instr env+ = case instr of+    LD      fmt reg addr    -> LD fmt (env reg) (fixAddr addr)+    LDFAR   fmt reg addr    -> LDFAR fmt (env reg) (fixAddr addr)+    LA      fmt reg addr    -> LA fmt (env reg) (fixAddr addr)+    ST      fmt reg addr    -> ST fmt (env reg) (fixAddr addr)+    STFAR   fmt reg addr    -> STFAR fmt (env reg) (fixAddr addr)+    STU     fmt reg addr    -> STU fmt (env reg) (fixAddr addr)+    LIS     reg imm         -> LIS (env reg) imm+    LI      reg imm         -> LI (env reg) imm+    MR      reg1 reg2       -> MR (env reg1) (env reg2)+    CMP     fmt reg ri      -> CMP fmt (env reg) (fixRI ri)+    CMPL    fmt reg ri      -> CMPL fmt (env reg) (fixRI ri)+    BCC     cond lbl        -> BCC cond lbl+    BCCFAR  cond lbl        -> BCCFAR cond lbl+    MTCTR   reg             -> MTCTR (env reg)+    BCTR    targets lbl     -> BCTR targets lbl+    BL      imm argRegs     -> BL imm argRegs    -- argument regs+    BCTRL   argRegs         -> BCTRL argRegs     -- cannot be remapped+    ADD     reg1 reg2 ri    -> ADD (env reg1) (env reg2) (fixRI ri)+    ADDO    reg1 reg2 reg3  -> ADDO (env reg1) (env reg2) (env reg3)+    ADDC    reg1 reg2 reg3  -> ADDC (env reg1) (env reg2) (env reg3)+    ADDE    reg1 reg2 reg3  -> ADDE (env reg1) (env reg2) (env reg3)+    ADDZE   reg1 reg2       -> ADDZE (env reg1) (env reg2)+    ADDIS   reg1 reg2 imm   -> ADDIS (env reg1) (env reg2) imm+    SUBF    reg1 reg2 reg3  -> SUBF (env reg1) (env reg2) (env reg3)+    SUBFO   reg1 reg2 reg3  -> SUBFO (env reg1) (env reg2) (env reg3)+    SUBFC   reg1 reg2 ri    -> SUBFC (env reg1) (env reg2) (fixRI ri)+    SUBFE   reg1 reg2 reg3  -> SUBFE (env reg1) (env reg2) (env reg3)+    MULL    fmt reg1 reg2 ri+                            -> MULL fmt (env reg1) (env reg2) (fixRI ri)+    MULLO   fmt reg1 reg2 reg3+                            -> MULLO fmt (env reg1) (env reg2) (env reg3)+    MFOV    fmt reg         -> MFOV fmt (env reg)+    MULHU   fmt reg1 reg2 reg3+                            -> MULHU fmt (env reg1) (env reg2) (env reg3)+    DIV     fmt sgn reg1 reg2 reg3+                            -> DIV fmt sgn (env reg1) (env reg2) (env reg3)++    AND     reg1 reg2 ri    -> AND (env reg1) (env reg2) (fixRI ri)+    ANDC    reg1 reg2 reg3  -> ANDC (env reg1) (env reg2) (env reg3)+    OR      reg1 reg2 ri    -> OR  (env reg1) (env reg2) (fixRI ri)+    ORIS    reg1 reg2 imm   -> ORIS (env reg1) (env reg2) imm+    XOR     reg1 reg2 ri    -> XOR (env reg1) (env reg2) (fixRI ri)+    XORIS   reg1 reg2 imm   -> XORIS (env reg1) (env reg2) imm+    EXTS    fmt reg1 reg2   -> EXTS fmt (env reg1) (env reg2)+    CNTLZ   fmt reg1 reg2   -> CNTLZ fmt (env reg1) (env reg2)+    NEG     reg1 reg2       -> NEG (env reg1) (env reg2)+    NOT     reg1 reg2       -> NOT (env reg1) (env reg2)+    SL      fmt reg1 reg2 ri+                            -> SL fmt (env reg1) (env reg2) (fixRI ri)+    SR      fmt reg1 reg2 ri+                            -> SR fmt (env reg1) (env reg2) (fixRI ri)+    SRA     fmt reg1 reg2 ri+                            -> SRA fmt (env reg1) (env reg2) (fixRI ri)+    RLWINM  reg1 reg2 sh mb me+                            -> RLWINM (env reg1) (env reg2) sh mb me+    CLRLI   fmt reg1 reg2 n -> CLRLI fmt (env reg1) (env reg2) n+    CLRRI   fmt reg1 reg2 n -> CLRRI fmt (env reg1) (env reg2) n+    FADD    fmt r1 r2 r3    -> FADD fmt (env r1) (env r2) (env r3)+    FSUB    fmt r1 r2 r3    -> FSUB fmt (env r1) (env r2) (env r3)+    FMUL    fmt r1 r2 r3    -> FMUL fmt (env r1) (env r2) (env r3)+    FDIV    fmt r1 r2 r3    -> FDIV fmt (env r1) (env r2) (env r3)+    FABS    r1 r2           -> FABS (env r1) (env r2)+    FNEG    r1 r2           -> FNEG (env r1) (env r2)+    FCMP    r1 r2           -> FCMP (env r1) (env r2)+    FCTIWZ  r1 r2           -> FCTIWZ (env r1) (env r2)+    FCTIDZ  r1 r2           -> FCTIDZ (env r1) (env r2)+    FCFID   r1 r2           -> FCFID (env r1) (env r2)+    FRSP    r1 r2           -> FRSP (env r1) (env r2)+    MFCR    reg             -> MFCR (env reg)+    MFLR    reg             -> MFLR (env reg)+    FETCHPC reg             -> FETCHPC (env reg)+    _                       -> instr+  where+    fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2)+    fixAddr (AddrRegImm r1 i)  = AddrRegImm (env r1) i++    fixRI (RIReg r) = RIReg (env r)+    fixRI other     = other+++--------------------------------------------------------------------------------+-- | Checks whether this instruction is a jump/branch instruction.+-- One that can change the flow of control in a way that the+-- register allocator needs to worry about.+ppc_isJumpishInstr :: Instr -> Bool+ppc_isJumpishInstr instr+ = case instr of+    BCC{}       -> True+    BCCFAR{}    -> True+    BCTR{}      -> True+    BCTRL{}     -> True+    BL{}        -> True+    JMP{}       -> True+    _           -> False+++-- | Checks whether this instruction is a jump/branch instruction.+-- One that can change the flow of control in a way that the+-- register allocator needs to worry about.+ppc_jumpDestsOfInstr :: Instr -> [BlockId]+ppc_jumpDestsOfInstr insn+  = case insn of+        BCC _ id        -> [id]+        BCCFAR _ id     -> [id]+        BCTR targets _  -> [id | Just id <- targets]+        _               -> []+++-- | Change the destination of this jump instruction.+-- Used in the linear allocator when adding fixup blocks for join+-- points.+ppc_patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr+ppc_patchJumpInstr insn patchF+  = case insn of+        BCC cc id       -> BCC cc (patchF id)+        BCCFAR cc id    -> BCCFAR cc (patchF id)+        BCTR ids lbl    -> BCTR (map (fmap patchF) ids) lbl+        _               -> insn+++-- -----------------------------------------------------------------------------++-- | An instruction to spill a register into a spill slot.+ppc_mkSpillInstr+   :: DynFlags+   -> Reg       -- register to spill+   -> Int       -- current stack delta+   -> Int       -- spill slot to use+   -> Instr++ppc_mkSpillInstr dflags reg delta slot+  = let platform = targetPlatform dflags+        off      = spillSlotToOffset dflags slot+        arch     = platformArch platform+    in+    let fmt = case targetClassOfReg platform reg of+                RcInteger -> case arch of+                                ArchPPC -> II32+                                _       -> II64+                RcDouble  -> FF64+                _         -> panic "PPC.Instr.mkSpillInstr: no match"+        instr = case makeImmediate W32 True (off-delta) of+                Just _  -> ST+                Nothing -> STFAR -- pseudo instruction: 32 bit offsets++    in instr fmt reg (AddrRegImm sp (ImmInt (off-delta)))+++ppc_mkLoadInstr+   :: DynFlags+   -> Reg       -- register to load+   -> Int       -- current stack delta+   -> Int       -- spill slot to use+   -> Instr++ppc_mkLoadInstr dflags reg delta slot+  = let platform = targetPlatform dflags+        off      = spillSlotToOffset dflags slot+        arch     = platformArch platform+    in+    let fmt = case targetClassOfReg platform reg of+                RcInteger ->  case arch of+                                 ArchPPC -> II32+                                 _       -> II64+                RcDouble  -> FF64+                _         -> panic "PPC.Instr.mkLoadInstr: no match"+        instr = case makeImmediate W32 True (off-delta) of+                Just _  -> LD+                Nothing -> LDFAR -- pseudo instruction: 32 bit offsets++    in instr fmt reg (AddrRegImm sp (ImmInt (off-delta)))+++-- | The size of a minimal stackframe header including minimal+-- parameter save area.+stackFrameHeaderSize :: DynFlags -> Int+stackFrameHeaderSize dflags+  = case platformOS platform of+      OSLinux  -> case platformArch platform of+                             -- header + parameter save area+        ArchPPC           -> 64 -- TODO: check ABI spec+        ArchPPC_64 ELF_V1 -> 48 + 8 * 8+        ArchPPC_64 ELF_V2 -> 32 + 8 * 8+        _ -> panic "PPC.stackFrameHeaderSize: Unknown Linux"+      OSAIX    -> 24 + 8 * 4+      OSDarwin -> 64 -- TODO: check ABI spec+      _ -> panic "PPC.stackFrameHeaderSize: not defined for this OS"+     where platform = targetPlatform dflags++-- | The maximum number of bytes required to spill a register. PPC32+-- has 32-bit GPRs and 64-bit FPRs, while PPC64 has 64-bit GPRs and+-- 64-bit FPRs. So the maximum is 8 regardless of platforms unlike+-- x86. Note that AltiVec's vector registers are 128-bit wide so we+-- must not use this to spill them.+spillSlotSize :: Int+spillSlotSize = 8++-- | The number of spill slots available without allocating more.+maxSpillSlots :: DynFlags -> Int+maxSpillSlots dflags+    = ((rESERVED_C_STACK_BYTES dflags - stackFrameHeaderSize dflags)+       `div` spillSlotSize) - 1+--     = 0 -- useful for testing allocMoreStack++-- | The number of bytes that the stack pointer should be aligned+-- to. This is 16 both on PPC32 and PPC64 at least for Darwin, and+-- Linux (see ELF processor specific supplements).+stackAlign :: Int+stackAlign = 16++-- | Convert a spill slot number to a *byte* offset, with no sign.+spillSlotToOffset :: DynFlags -> Int -> Int+spillSlotToOffset dflags slot+   = stackFrameHeaderSize dflags + spillSlotSize * slot+++--------------------------------------------------------------------------------+-- | See if this instruction is telling us the current C stack delta+ppc_takeDeltaInstr+    :: Instr+    -> Maybe Int++ppc_takeDeltaInstr instr+ = case instr of+     DELTA i  -> Just i+     _        -> Nothing+++ppc_isMetaInstr+    :: Instr+    -> Bool++ppc_isMetaInstr instr+ = case instr of+    COMMENT{}   -> True+    LDATA{}     -> True+    NEWBLOCK{}  -> True+    DELTA{}     -> True+    _           -> False+++-- | Copy the value in a register to another one.+-- Must work for all register classes.+ppc_mkRegRegMoveInstr+    :: Reg+    -> Reg+    -> Instr++ppc_mkRegRegMoveInstr src dst+    = MR dst src+++-- | Make an unconditional jump instruction.+-- For architectures with branch delay slots, its ok to put+-- a NOP after the jump. Don't fill the delay slot with an+-- instruction that references regs or you'll confuse the+-- linear allocator.+ppc_mkJumpInstr+    :: BlockId+    -> [Instr]++ppc_mkJumpInstr id+    = [BCC ALWAYS id]+++-- | Take the source and destination from this reg -> reg move instruction+-- or Nothing if it's not one+ppc_takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg)+ppc_takeRegRegMoveInstr (MR dst src) = Just (src,dst)+ppc_takeRegRegMoveInstr _  = Nothing++-- -----------------------------------------------------------------------------+-- Making far branches++-- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too+-- big, we have to work around this limitation.++makeFarBranches+        :: LabelMap CmmStatics+        -> [NatBasicBlock Instr]+        -> [NatBasicBlock Instr]+makeFarBranches info_env blocks+    | last blockAddresses < nearLimit = blocks+    | otherwise = zipWith handleBlock blockAddresses blocks+    where+        blockAddresses = scanl (+) 0 $ map blockLen blocks+        blockLen (BasicBlock _ instrs) = length instrs++        handleBlock addr (BasicBlock id instrs)+                = BasicBlock id (zipWith makeFar [addr..] instrs)++        makeFar _ (BCC ALWAYS tgt) = BCC ALWAYS tgt+        makeFar addr (BCC cond tgt)+            | abs (addr - targetAddr) >= nearLimit+            = BCCFAR cond tgt+            | otherwise+            = BCC cond tgt+            where Just targetAddr = lookupUFM blockAddressMap tgt+        makeFar _ other            = other++        -- 8192 instructions are allowed; let's keep some distance, as+        -- we have a few pseudo-insns that are pretty-printed as+        -- multiple instructions, and it's just not worth the effort+        -- to calculate things exactly+        nearLimit = 7000 - mapSize info_env * maxRetInfoTableSizeW++        blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses
+ nativeGen/PPC/Ppr.hs view
@@ -0,0 +1,1041 @@+-----------------------------------------------------------------------------+--+-- Pretty-printing assembly language+--+-- (c) The University of Glasgow 1993-2005+--+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -fno-warn-orphans #-}+module PPC.Ppr (pprNatCmmDecl) where++import PPC.Regs+import PPC.Instr+import PPC.Cond+import PprBase+import Instruction+import Format+import Reg+import RegClass+import TargetReg++import Cmm hiding (topInfoTable)+import Hoopl++import CLabel++import Unique                ( pprUniqueAlways, Uniquable(..) )+import Platform+import FastString+import Outputable+import DynFlags++import Data.Word+import Data.Int+import Data.Bits++-- -----------------------------------------------------------------------------+-- Printing this stuff out++pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc+pprNatCmmDecl (CmmData section dats) =+  pprSectionAlign section $$ pprDatas dats++pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =+  case topInfoTable proc of+    Nothing ->+       sdocWithPlatform $ \platform ->+       case blocks of+         []     -> -- special case for split markers:+           pprLabel lbl+         blocks -> -- special case for code without info table:+           pprSectionAlign (Section Text lbl) $$+           (case platformArch platform of+              ArchPPC_64 ELF_V1 -> pprFunctionDescriptor lbl+              ArchPPC_64 ELF_V2 -> pprFunctionPrologue lbl+              _ -> pprLabel lbl) $$ -- blocks guaranteed not null,+                                     -- so label needed+           vcat (map (pprBasicBlock top_info) blocks)++    Just (Statics info_lbl _) ->+      sdocWithPlatform $ \platform ->+      pprSectionAlign (Section Text info_lbl) $$+      (if platformHasSubsectionsViaSymbols platform+          then ppr (mkDeadStripPreventer info_lbl) <> char ':'+          else empty) $$+      vcat (map (pprBasicBlock top_info) blocks) $$+      -- above: Even the first block gets a label, because with branch-chain+      -- elimination, it might be the target of a goto.+      (if platformHasSubsectionsViaSymbols platform+       then+       -- See Note [Subsections Via Symbols] in X86/Ppr.hs+                text "\t.long "+            <+> ppr info_lbl+            <+> char '-'+            <+> ppr (mkDeadStripPreventer info_lbl)+       else empty)++pprFunctionDescriptor :: CLabel -> SDoc+pprFunctionDescriptor lab = pprGloblDecl lab+                        $$  text ".section \".opd\",\"aw\""+                        $$  text ".align 3"+                        $$  ppr lab <> char ':'+                        $$  text ".quad ."+                        <> ppr lab+                        <> text ",.TOC.@tocbase,0"+                        $$  text ".previous"+                        $$  text ".type "+                        <> ppr lab+                        <> text ", @function"+                        $$  char '.'+                        <> ppr lab+                        <> char ':'++pprFunctionPrologue :: CLabel ->SDoc+pprFunctionPrologue lab =  pprGloblDecl lab+                        $$  text ".type "+                        <> ppr lab+                        <> text ", @function"+                        $$ ppr lab <> char ':'+                        $$ text "0:\taddis\t" <> pprReg toc+                        <> text ",12,.TOC.-0b@ha"+                        $$ text "\taddi\t" <> pprReg toc+                        <> char ',' <> pprReg toc <> text ",.TOC.-0b@l"+                        $$ text "\t.localentry\t" <> ppr lab+                        <> text ",.-" <> ppr lab++pprBasicBlock :: LabelMap CmmStatics -> NatBasicBlock Instr -> SDoc+pprBasicBlock info_env (BasicBlock blockid instrs)+  = maybe_infotable $$+    pprLabel (mkAsmTempLabel (getUnique blockid)) $$+    vcat (map pprInstr instrs)+  where+    maybe_infotable = case mapLookup blockid info_env of+       Nothing   -> empty+       Just (Statics info_lbl info) ->+           pprAlignForSection Text $$+           vcat (map pprData info) $$+           pprLabel info_lbl++++pprDatas :: CmmStatics -> SDoc+pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats)++pprData :: CmmStatic -> SDoc+pprData (CmmString str)          = pprASCII str+pprData (CmmUninitialised bytes) = keyword <> int bytes+    where keyword = sdocWithPlatform $ \platform ->+                    case platformOS platform of+                    OSDarwin -> text ".space "+                    OSAIX    -> text ".space "+                    _        -> text ".skip "+pprData (CmmStaticLit lit)       = pprDataItem lit++pprGloblDecl :: CLabel -> SDoc+pprGloblDecl lbl+  | not (externallyVisibleCLabel lbl) = empty+  | otherwise = text ".globl " <> ppr lbl++pprTypeAndSizeDecl :: CLabel -> SDoc+pprTypeAndSizeDecl lbl+  = sdocWithPlatform $ \platform ->+    if platformOS platform == OSLinux && externallyVisibleCLabel lbl+    then text ".type " <>+         ppr lbl <> text ", @object"+    else empty++pprLabel :: CLabel -> SDoc+pprLabel lbl = pprGloblDecl lbl+            $$ pprTypeAndSizeDecl lbl+            $$ (ppr lbl <> char ':')+++pprASCII :: [Word8] -> SDoc+pprASCII str+  = vcat (map do1 str) $$ do1 0+    where+       do1 :: Word8 -> SDoc+       do1 w = text "\t.byte\t" <> int (fromIntegral w)+++-- -----------------------------------------------------------------------------+-- pprInstr: print an 'Instr'++instance Outputable Instr where+    ppr instr = pprInstr instr+++pprReg :: Reg -> SDoc++pprReg r+  = case r of+      RegReal    (RealRegSingle i) -> ppr_reg_no i+      RegReal    (RealRegPair{})   -> panic "PPC.pprReg: no reg pairs on this arch"+      RegVirtual (VirtualRegI  u)  -> text "%vI_"   <> pprUniqueAlways u+      RegVirtual (VirtualRegHi u)  -> text "%vHi_"  <> pprUniqueAlways u+      RegVirtual (VirtualRegF  u)  -> text "%vF_"   <> pprUniqueAlways u+      RegVirtual (VirtualRegD  u)  -> text "%vD_"   <> pprUniqueAlways u+      RegVirtual (VirtualRegSSE u) -> text "%vSSE_" <> pprUniqueAlways u+  where+    ppr_reg_no :: Int -> SDoc+    ppr_reg_no i =+        sdocWithPlatform $ \platform ->+        case platformOS platform of+        OSDarwin ->+            ptext+                (case i of {+                 0 -> sLit "r0";   1 -> sLit "r1";+                 2 -> sLit "r2";   3 -> sLit "r3";+                 4 -> sLit "r4";   5 -> sLit "r5";+                 6 -> sLit "r6";   7 -> sLit "r7";+                 8 -> sLit "r8";   9 -> sLit "r9";+                10 -> sLit "r10";  11 -> sLit "r11";+                12 -> sLit "r12";  13 -> sLit "r13";+                14 -> sLit "r14";  15 -> sLit "r15";+                16 -> sLit "r16";  17 -> sLit "r17";+                18 -> sLit "r18";  19 -> sLit "r19";+                20 -> sLit "r20";  21 -> sLit "r21";+                22 -> sLit "r22";  23 -> sLit "r23";+                24 -> sLit "r24";  25 -> sLit "r25";+                26 -> sLit "r26";  27 -> sLit "r27";+                28 -> sLit "r28";  29 -> sLit "r29";+                30 -> sLit "r30";  31 -> sLit "r31";+                32 -> sLit "f0";  33 -> sLit "f1";+                34 -> sLit "f2";  35 -> sLit "f3";+                36 -> sLit "f4";  37 -> sLit "f5";+                38 -> sLit "f6";  39 -> sLit "f7";+                40 -> sLit "f8";  41 -> sLit "f9";+                42 -> sLit "f10"; 43 -> sLit "f11";+                44 -> sLit "f12"; 45 -> sLit "f13";+                46 -> sLit "f14"; 47 -> sLit "f15";+                48 -> sLit "f16"; 49 -> sLit "f17";+                50 -> sLit "f18"; 51 -> sLit "f19";+                52 -> sLit "f20"; 53 -> sLit "f21";+                54 -> sLit "f22"; 55 -> sLit "f23";+                56 -> sLit "f24"; 57 -> sLit "f25";+                58 -> sLit "f26"; 59 -> sLit "f27";+                60 -> sLit "f28"; 61 -> sLit "f29";+                62 -> sLit "f30"; 63 -> sLit "f31";+                _  -> sLit "very naughty powerpc register"+              })+        _+         | i <= 31   -> int i      -- GPRs+         | i <= 63   -> int (i-32) -- FPRs+         | otherwise -> text "very naughty powerpc register"++++pprFormat :: Format -> SDoc+pprFormat x+ = ptext (case x of+                II8  -> sLit "b"+                II16 -> sLit "h"+                II32 -> sLit "w"+                II64 -> sLit "d"+                FF32 -> sLit "fs"+                FF64 -> sLit "fd"+                _    -> panic "PPC.Ppr.pprFormat: no match")+++pprCond :: Cond -> SDoc+pprCond c+ = ptext (case c of {+                ALWAYS  -> sLit "";+                EQQ     -> sLit "eq";  NE    -> sLit "ne";+                LTT     -> sLit "lt";  GE    -> sLit "ge";+                GTT     -> sLit "gt";  LE    -> sLit "le";+                LU      -> sLit "lt";  GEU   -> sLit "ge";+                GU      -> sLit "gt";  LEU   -> sLit "le"; })+++pprImm :: Imm -> SDoc++pprImm (ImmInt i)     = int i+pprImm (ImmInteger i) = integer i+pprImm (ImmCLbl l)    = ppr l+pprImm (ImmIndex l i) = ppr l <> char '+' <> int i+pprImm (ImmLit s)     = s++pprImm (ImmFloat _)  = text "naughty float immediate"+pprImm (ImmDouble _) = text "naughty double immediate"++pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b+pprImm (ImmConstantDiff a b) = pprImm a <> char '-'+                   <> lparen <> pprImm b <> rparen++pprImm (LO (ImmInt i))     = pprImm (LO (ImmInteger (toInteger i)))+pprImm (LO (ImmInteger i)) = pprImm (ImmInteger (toInteger lo16))+  where+    lo16 = fromInteger (i .&. 0xffff) :: Int16++pprImm (LO i)+  = sdocWithPlatform $ \platform ->+    if platformOS platform == OSDarwin+    then hcat [ text "lo16(", pprImm i, rparen ]+    else pprImm i <> text "@l"++pprImm (HI i)+  = sdocWithPlatform $ \platform ->+    if platformOS platform == OSDarwin+    then hcat [ text "hi16(", pprImm i, rparen ]+    else pprImm i <> text "@h"++pprImm (HA (ImmInt i))     = pprImm (HA (ImmInteger (toInteger i)))+pprImm (HA (ImmInteger i)) = pprImm (ImmInteger ha16)+  where+    ha16 = if lo16 >= 0x8000 then hi16+1 else hi16+    hi16 = (i `shiftR` 16)+    lo16 = i .&. 0xffff++pprImm (HA i)+  = sdocWithPlatform $ \platform ->+    if platformOS platform == OSDarwin+    then hcat [ text "ha16(", pprImm i, rparen ]+    else pprImm i <> text "@ha"++pprImm (HIGHERA i)+  = sdocWithPlatform $ \platform ->+    if platformOS platform == OSDarwin+    then panic "PPC.pprImm: highera not implemented on Darwin"+    else pprImm i <> text "@highera"++pprImm (HIGHESTA i)+  = sdocWithPlatform $ \platform ->+    if platformOS platform == OSDarwin+    then panic "PPC.pprImm: highesta not implemented on Darwin"+    else pprImm i <> text "@highesta"+++pprAddr :: AddrMode -> SDoc+pprAddr (AddrRegReg r1 r2)+  = pprReg r1 <+> text ", " <+> pprReg r2++pprAddr (AddrRegImm r1 (ImmInt i)) = hcat [ int i, char '(', pprReg r1, char ')' ]+pprAddr (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg r1, char ')' ]+pprAddr (AddrRegImm r1 imm) = hcat [ pprImm imm, char '(', pprReg r1, char ')' ]+++pprSectionAlign :: Section -> SDoc+pprSectionAlign sec@(Section seg _) =+ sdocWithPlatform $ \platform ->+   pprSectionHeader platform sec $$+   pprAlignForSection seg++-- | Print appropriate alignment for the given section type.+pprAlignForSection :: SectionType -> SDoc+pprAlignForSection seg =+ sdocWithPlatform $ \platform ->+ let osDarwin = platformOS platform == OSDarwin+     ppc64    = not $ target32Bit platform+ in ptext $ case seg of+       Text              -> sLit ".align 2"+       Data+        | ppc64          -> sLit ".align 3"+        | otherwise      -> sLit ".align 2"+       ReadOnlyData+        | osDarwin       -> sLit ".align 2"+        | ppc64          -> sLit ".align 3"+        | otherwise      -> sLit ".align 2"+       RelocatableReadOnlyData+        | osDarwin       -> sLit ".align 2"+        | ppc64          -> sLit ".align 3"+        | otherwise      -> sLit ".align 2"+       UninitialisedData+        | osDarwin       -> sLit ".align 2"+        | ppc64          -> sLit ".align 3"+        | otherwise      -> sLit ".align 2"+       ReadOnlyData16+        | osDarwin       -> sLit ".align 4"+        | otherwise      -> sLit ".align 4"+       -- TODO: This is copied from the ReadOnlyData case, but it can likely be+       -- made more efficient.+       CString+        | osDarwin       -> sLit ".align 2"+        | ppc64          -> sLit ".align 3"+        | otherwise      -> sLit ".align 2"+       OtherSection _    -> panic "PprMach.pprSectionAlign: unknown section"++pprDataItem :: CmmLit -> SDoc+pprDataItem lit+  = sdocWithDynFlags $ \dflags ->+    vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit dflags)+    where+        imm = litToImm lit+        archPPC_64 dflags = not $ target32Bit $ targetPlatform dflags++        ppr_item II8   _ _ = [text "\t.byte\t" <> pprImm imm]++        ppr_item II32  _ _ = [text "\t.long\t" <> pprImm imm]++        ppr_item II64 _ dflags+           | archPPC_64 dflags = [text "\t.quad\t" <> pprImm imm]+++        ppr_item FF32 (CmmFloat r _) _+           = let bs = floatToBytes (fromRational r)+             in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs++        ppr_item FF64 (CmmFloat r _) _+           = let bs = doubleToBytes (fromRational r)+             in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs++        ppr_item II16 _ _      = [text "\t.short\t" <> pprImm imm]++        ppr_item II64 (CmmInt x _) dflags+           | not(archPPC_64 dflags) =+                [text "\t.long\t"+                    <> int (fromIntegral+                        (fromIntegral (x `shiftR` 32) :: Word32)),+                 text "\t.long\t"+                    <> int (fromIntegral (fromIntegral x :: Word32))]++        ppr_item _ _ _+                = panic "PPC.Ppr.pprDataItem: no match"+++pprInstr :: Instr -> SDoc++pprInstr (COMMENT _) = empty -- nuke 'em+{-+pprInstr (COMMENT s) =+     if platformOS platform == OSLinux+     then text "# " <> ftext s+     else text "; " <> ftext s+-}+pprInstr (DELTA d)+   = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))++pprInstr (NEWBLOCK _)+   = panic "PprMach.pprInstr: NEWBLOCK"++pprInstr (LDATA _ _)+   = panic "PprMach.pprInstr: LDATA"++{-+pprInstr (SPILL reg slot)+   = hcat [+           text "\tSPILL",+        char '\t',+        pprReg reg,+        comma,+        text "SLOT" <> parens (int slot)]++pprInstr (RELOAD slot reg)+   = hcat [+           text "\tRELOAD",+        char '\t',+        text "SLOT" <> parens (int slot),+        comma,+        pprReg reg]+-}++pprInstr (LD fmt reg addr) = hcat [+        char '\t',+        text "l",+        ptext (case fmt of+            II8  -> sLit "bz"+            II16 -> sLit "hz"+            II32 -> sLit "wz"+            II64 -> sLit "d"+            FF32 -> sLit "fs"+            FF64 -> sLit "fd"+            _         -> panic "PPC.Ppr.pprInstr: no match"+            ),+        case addr of AddrRegImm _ _ -> empty+                     AddrRegReg _ _ -> char 'x',+        char '\t',+        pprReg reg,+        text ", ",+        pprAddr addr+    ]+pprInstr (LDFAR fmt reg (AddrRegImm source off)) =+   sdocWithPlatform $ \platform -> vcat [+         pprInstr (ADDIS (tmpReg platform) source (HA off)),+         pprInstr (LD fmt reg (AddrRegImm (tmpReg platform) (LO off)))+    ]++pprInstr (LDFAR _ _ _) =+   panic "PPC.Ppr.pprInstr LDFAR: no match"++pprInstr (LA fmt reg addr) = hcat [+        char '\t',+        text "l",+        ptext (case fmt of+            II8  -> sLit "ba"+            II16 -> sLit "ha"+            II32 -> sLit "wa"+            II64 -> sLit "d"+            FF32 -> sLit "fs"+            FF64 -> sLit "fd"+            _         -> panic "PPC.Ppr.pprInstr: no match"+            ),+        case addr of AddrRegImm _ _ -> empty+                     AddrRegReg _ _ -> char 'x',+        char '\t',+        pprReg reg,+        text ", ",+        pprAddr addr+    ]+pprInstr (ST fmt reg addr) = hcat [+        char '\t',+        text "st",+        pprFormat fmt,+        case addr of AddrRegImm _ _ -> empty+                     AddrRegReg _ _ -> char 'x',+        char '\t',+        pprReg reg,+        text ", ",+        pprAddr addr+    ]+pprInstr (STFAR fmt reg (AddrRegImm source off)) =+   sdocWithPlatform $ \platform -> vcat [+         pprInstr (ADDIS (tmpReg platform) source (HA off)),+         pprInstr (ST fmt reg (AddrRegImm (tmpReg platform) (LO off)))+    ]+pprInstr (STFAR _ _ _) =+   panic "PPC.Ppr.pprInstr STFAR: no match"+pprInstr (STU fmt reg addr) = hcat [+        char '\t',+        text "st",+        pprFormat fmt,+        char 'u',+        case addr of AddrRegImm _ _ -> empty+                     AddrRegReg _ _ -> char 'x',+        char '\t',+        pprReg reg,+        text ", ",+        pprAddr addr+    ]+pprInstr (LIS reg imm) = hcat [+        char '\t',+        text "lis",+        char '\t',+        pprReg reg,+        text ", ",+        pprImm imm+    ]+pprInstr (LI reg imm) = hcat [+        char '\t',+        text "li",+        char '\t',+        pprReg reg,+        text ", ",+        pprImm imm+    ]+pprInstr (MR reg1 reg2)+    | reg1 == reg2 = empty+    | otherwise = hcat [+        char '\t',+        sdocWithPlatform $ \platform ->+        case targetClassOfReg platform reg1 of+            RcInteger -> text "mr"+            _ -> text "fmr",+        char '\t',+        pprReg reg1,+        text ", ",+        pprReg reg2+    ]+pprInstr (CMP fmt reg ri) = hcat [+        char '\t',+        op,+        char '\t',+        pprReg reg,+        text ", ",+        pprRI ri+    ]+    where+        op = hcat [+                text "cmp",+                pprFormat fmt,+                case ri of+                    RIReg _ -> empty+                    RIImm _ -> char 'i'+            ]+pprInstr (CMPL fmt reg ri) = hcat [+        char '\t',+        op,+        char '\t',+        pprReg reg,+        text ", ",+        pprRI ri+    ]+    where+        op = hcat [+                text "cmpl",+                pprFormat fmt,+                case ri of+                    RIReg _ -> empty+                    RIImm _ -> char 'i'+            ]+pprInstr (BCC cond blockid) = hcat [+        char '\t',+        text "b",+        pprCond cond,+        char '\t',+        ppr lbl+    ]+    where lbl = mkAsmTempLabel (getUnique blockid)++pprInstr (BCCFAR cond blockid) = vcat [+        hcat [+            text "\tb",+            pprCond (condNegate cond),+            text "\t$+8"+        ],+        hcat [+            text "\tb\t",+            ppr lbl+        ]+    ]+    where lbl = mkAsmTempLabel (getUnique blockid)++pprInstr (JMP lbl)+  -- We never jump to ForeignLabels; if we ever do, c.f. handling for "BL"+  | isForeignLabel lbl = panic "PPC.Ppr.pprInstr: JMP to ForeignLabel"+  | otherwise =+    hcat [ -- an alias for b that takes a CLabel+        char '\t',+        text "b",+        char '\t',+        ppr lbl+    ]++pprInstr (MTCTR reg) = hcat [+        char '\t',+        text "mtctr",+        char '\t',+        pprReg reg+    ]+pprInstr (BCTR _ _) = hcat [+        char '\t',+        text "bctr"+    ]+pprInstr (BL lbl _) = do+    sdocWithPlatform $ \platform -> case platformOS platform of+        OSAIX ->+          -- On AIX, "printf" denotes a function-descriptor (for use+          -- by function pointers), whereas the actual entry-code+          -- address is denoted by the dot-prefixed ".printf" label.+          -- Moreover, the PPC NCG only ever emits a BL instruction+          -- for calling C ABI functions. Most of the time these calls+          -- originate from FFI imports and have a 'ForeignLabel',+          -- but when profiling the codegen inserts calls via+          -- 'emitRtsCallGen' which are 'CmmLabel's even though+          -- they'd technically be more like 'ForeignLabel's.+          hcat [+            text "\tbl\t.",+            ppr lbl+          ]+        _ ->+          hcat [+            text "\tbl\t",+            ppr lbl+          ]+pprInstr (BCTRL _) = hcat [+        char '\t',+        text "bctrl"+    ]+pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri+pprInstr (ADDIS reg1 reg2 imm) = hcat [+        char '\t',+        text "addis",+        char '\t',+        pprReg reg1,+        text ", ",+        pprReg reg2,+        text ", ",+        pprImm imm+    ]++pprInstr (ADDO reg1 reg2 reg3) = pprLogic (sLit "addo") reg1 reg2 (RIReg reg3)+pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3)+pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3)+pprInstr (ADDZE reg1 reg2) = pprUnary (sLit "addze") reg1 reg2+pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3)+pprInstr (SUBFO reg1 reg2 reg3) = pprLogic (sLit "subfo") reg1 reg2 (RIReg reg3)+pprInstr (SUBFC reg1 reg2 ri) = hcat [+        char '\t',+        text "subf",+        case ri of+            RIReg _ -> empty+            RIImm _ -> char 'i',+        text "c\t",+        pprReg reg1,+        text ", ",+        pprReg reg2,+        text ", ",+        pprRI ri+    ]+pprInstr (SUBFE reg1 reg2 reg3) = pprLogic (sLit "subfe") reg1 reg2 (RIReg reg3)+pprInstr (MULL fmt reg1 reg2 ri) = pprMul fmt reg1 reg2 ri+pprInstr (MULLO fmt reg1 reg2 reg3) = hcat [+        char '\t',+        text "mull",+        case fmt of+          II32 -> char 'w'+          II64 -> char 'd'+          _    -> panic "PPC: illegal format",+        text "o\t",+        pprReg reg1,+        text ", ",+        pprReg reg2,+        text ", ",+        pprReg reg3+    ]+pprInstr (MFOV fmt reg) = vcat [+        hcat [+            char '\t',+            text "mfxer",+            char '\t',+            pprReg reg+            ],+        hcat [+            char '\t',+            text "extr",+            case fmt of+              II32 -> char 'w'+              II64 -> char 'd'+              _    -> panic "PPC: illegal format",+            text "i\t",+            pprReg reg,+            text ", ",+            pprReg reg,+            text ", 1, ",+            case fmt of+              II32 -> text "1"+              II64 -> text "33"+              _    -> panic "PPC: illegal format"+            ]+        ]++pprInstr (MULHU fmt reg1 reg2 reg3) = hcat [+        char '\t',+        text "mulh",+        case fmt of+          II32 -> char 'w'+          II64 -> char 'd'+          _    -> panic "PPC: illegal format",+        text "u\t",+        pprReg reg1,+        text ", ",+        pprReg reg2,+        text ", ",+        pprReg reg3+    ]++pprInstr (DIV fmt sgn reg1 reg2 reg3) = pprDiv fmt sgn reg1 reg2 reg3++        -- for some reason, "andi" doesn't exist.+        -- we'll use "andi." instead.+pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [+        char '\t',+        text "andi.",+        char '\t',+        pprReg reg1,+        text ", ",+        pprReg reg2,+        text ", ",+        pprImm imm+    ]+pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri+pprInstr (ANDC reg1 reg2 reg3) = pprLogic (sLit "andc") reg1 reg2 (RIReg reg3)++pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri+pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri++pprInstr (ORIS reg1 reg2 imm) = hcat [+        char '\t',+        text "oris",+        char '\t',+        pprReg reg1,+        text ", ",+        pprReg reg2,+        text ", ",+        pprImm imm+    ]++pprInstr (XORIS reg1 reg2 imm) = hcat [+        char '\t',+        text "xoris",+        char '\t',+        pprReg reg1,+        text ", ",+        pprReg reg2,+        text ", ",+        pprImm imm+    ]++pprInstr (EXTS fmt reg1 reg2) = hcat [+        char '\t',+        text "exts",+        pprFormat fmt,+        char '\t',+        pprReg reg1,+        text ", ",+        pprReg reg2+    ]+pprInstr (CNTLZ fmt reg1 reg2) = hcat [+        char '\t',+        text "cntlz",+        case fmt of+          II32 -> char 'w'+          II64 -> char 'd'+          _    -> panic "PPC: illegal format",+        char '\t',+        pprReg reg1,+        text ", ",+        pprReg reg2+    ]++pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2+pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2++pprInstr (SR II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0  || i > 31 =+    -- Handle the case where we are asked to shift a 32 bit register by+    -- less than zero or more than 31 bits. We convert this into a clear+    -- of the destination register.+    -- Fixes ticket http://ghc.haskell.org/trac/ghc/ticket/5900+    pprInstr (XOR reg1 reg2 (RIReg reg2))++pprInstr (SL II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0  || i > 31 =+    -- As above for SR, but for left shifts.+    -- Fixes ticket http://ghc.haskell.org/trac/ghc/ticket/10870+    pprInstr (XOR reg1 reg2 (RIReg reg2))++pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt i))) | i > 31 =+    -- PT: I don't know what to do for negative shift amounts:+    -- For now just panic.+    --+    -- For shift amounts greater than 31 set all bit to the+    -- value of the sign bit, this also what sraw does.+    pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt 31)))++pprInstr (SL fmt reg1 reg2 ri) =+         let op = case fmt of+                       II32 -> "slw"+                       II64 -> "sld"+                       _    -> panic "PPC.Ppr.pprInstr: shift illegal size"+         in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)++pprInstr (SR fmt reg1 reg2 ri) =+         let op = case fmt of+                       II32 -> "srw"+                       II64 -> "srd"+                       _    -> panic "PPC.Ppr.pprInstr: shift illegal size"+         in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)++pprInstr (SRA fmt reg1 reg2 ri) =+         let op = case fmt of+                       II32 -> "sraw"+                       II64 -> "srad"+                       _    -> panic "PPC.Ppr.pprInstr: shift illegal size"+         in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)++pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [+        text "\trlwinm\t",+        pprReg reg1,+        text ", ",+        pprReg reg2,+        text ", ",+        int sh,+        text ", ",+        int mb,+        text ", ",+        int me+    ]++pprInstr (CLRLI fmt reg1 reg2 n) = hcat [+        text "\tclrl",+        pprFormat fmt,+        text "i ",+        pprReg reg1,+        text ", ",+        pprReg reg2,+        text ", ",+        int n+    ]+pprInstr (CLRRI fmt reg1 reg2 n) = hcat [+        text "\tclrr",+        pprFormat fmt,+        text "i ",+        pprReg reg1,+        text ", ",+        pprReg reg2,+        text ", ",+        int n+    ]++pprInstr (FADD fmt reg1 reg2 reg3) = pprBinaryF (sLit "fadd") fmt reg1 reg2 reg3+pprInstr (FSUB fmt reg1 reg2 reg3) = pprBinaryF (sLit "fsub") fmt reg1 reg2 reg3+pprInstr (FMUL fmt reg1 reg2 reg3) = pprBinaryF (sLit "fmul") fmt reg1 reg2 reg3+pprInstr (FDIV fmt reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") fmt reg1 reg2 reg3+pprInstr (FABS reg1 reg2) = pprUnary (sLit "fabs") reg1 reg2+pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2++pprInstr (FCMP reg1 reg2) = hcat [+        char '\t',+        text "fcmpu\t0, ",+            -- Note: we're using fcmpu, not fcmpo+            -- The difference is with fcmpo, compare with NaN is an invalid operation.+            -- We don't handle invalid fp ops, so we don't care.+            -- Morever, we use `fcmpu 0, ...` rather than `fcmpu cr0, ...` for+            -- better portability since some non-GNU assembler (such as+            -- IBM's `as`) tend not to support the symbolic register name cr0.+            -- This matches the syntax that GCC seems to emit for PPC targets.+        pprReg reg1,+        text ", ",+        pprReg reg2+    ]++pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2+pprInstr (FCTIDZ reg1 reg2) = pprUnary (sLit "fctidz") reg1 reg2+pprInstr (FCFID reg1 reg2) = pprUnary (sLit "fcfid") reg1 reg2+pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2++pprInstr (CRNOR dst src1 src2) = hcat [+        text "\tcrnor\t",+        int dst,+        text ", ",+        int src1,+        text ", ",+        int src2+    ]++pprInstr (MFCR reg) = hcat [+        char '\t',+        text "mfcr",+        char '\t',+        pprReg reg+    ]++pprInstr (MFLR reg) = hcat [+        char '\t',+        text "mflr",+        char '\t',+        pprReg reg+    ]++pprInstr (FETCHPC reg) = vcat [+        text "\tbcl\t20,31,1f",+        hcat [ text "1:\tmflr\t", pprReg reg ]+    ]++pprInstr LWSYNC = text "\tlwsync"++pprInstr NOP = text "\tnop"++pprInstr (UPDATE_SP fmt amount@(ImmInt offset))+   | fits16Bits offset = vcat [+       pprInstr (LD fmt r0 (AddrRegImm sp (ImmInt 0))),+       pprInstr (STU fmt r0 (AddrRegImm sp amount))+     ]++pprInstr (UPDATE_SP fmt amount)+   = sdocWithPlatform $ \platform ->+       let tmp = tmpReg platform in+         vcat [+           pprInstr (LD fmt r0 (AddrRegImm sp (ImmInt 0))),+           pprInstr (ADDIS tmp sp (HA amount)),+           pprInstr (ADD tmp tmp (RIImm (LO amount))),+           pprInstr (STU fmt r0 (AddrRegReg sp tmp))+         ]++-- pprInstr _ = panic "pprInstr (ppc)"+++pprLogic :: LitString -> Reg -> Reg -> RI -> SDoc+pprLogic op reg1 reg2 ri = hcat [+        char '\t',+        ptext op,+        case ri of+            RIReg _ -> empty+            RIImm _ -> char 'i',+        char '\t',+        pprReg reg1,+        text ", ",+        pprReg reg2,+        text ", ",+        pprRI ri+    ]+++pprMul :: Format -> Reg -> Reg -> RI -> SDoc+pprMul fmt reg1 reg2 ri = hcat [+        char '\t',+        text "mull",+        case ri of+            RIReg _ -> case fmt of+              II32 -> char 'w'+              II64 -> char 'd'+              _    -> panic "PPC: illegal format"+            RIImm _ -> char 'i',+        char '\t',+        pprReg reg1,+        text ", ",+        pprReg reg2,+        text ", ",+        pprRI ri+    ]+++pprDiv :: Format -> Bool -> Reg -> Reg -> Reg -> SDoc+pprDiv fmt sgn reg1 reg2 reg3 = hcat [+        char '\t',+        text "div",+        case fmt of+          II32 -> char 'w'+          II64 -> char 'd'+          _    -> panic "PPC: illegal format",+        if sgn then empty else char 'u',+        char '\t',+        pprReg reg1,+        text ", ",+        pprReg reg2,+        text ", ",+        pprReg reg3+    ]+++pprUnary :: LitString -> Reg -> Reg -> SDoc+pprUnary op reg1 reg2 = hcat [+        char '\t',+        ptext op,+        char '\t',+        pprReg reg1,+        text ", ",+        pprReg reg2+    ]+++pprBinaryF :: LitString -> Format -> Reg -> Reg -> Reg -> SDoc+pprBinaryF op fmt reg1 reg2 reg3 = hcat [+        char '\t',+        ptext op,+        pprFFormat fmt,+        char '\t',+        pprReg reg1,+        text ", ",+        pprReg reg2,+        text ", ",+        pprReg reg3+    ]++pprRI :: RI -> SDoc+pprRI (RIReg r) = pprReg r+pprRI (RIImm r) = pprImm r+++pprFFormat :: Format -> SDoc+pprFFormat FF64     = empty+pprFFormat FF32     = char 's'+pprFFormat _        = panic "PPC.Ppr.pprFFormat: no match"++    -- limit immediate argument for shift instruction to range 0..63+    -- for 64 bit size and 0..32 otherwise+limitShiftRI :: Format -> RI -> RI+limitShiftRI II64 (RIImm (ImmInt i)) | i > 63 || i < 0 =+  panic $ "PPC.Ppr: Shift by " ++ show i ++ " bits is not allowed."+limitShiftRI II32 (RIImm (ImmInt i)) | i > 31 || i < 0 =+  panic $ "PPC.Ppr: 32 bit: Shift by " ++ show i ++ " bits is not allowed."+limitShiftRI _ x = x
+ nativeGen/PPC/RegInfo.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Machine-specific parts of the register allocator+--+-- (c) The University of Glasgow 1996-2004+--+-----------------------------------------------------------------------------+module PPC.RegInfo (+        JumpDest( DestBlockId ), getJumpDestBlockId,+        canShortcut,+        shortcutJump,++        shortcutStatics+)++where++#include "nativeGen/NCG.h"+#include "HsVersions.h"++import PPC.Instr++import BlockId+import Cmm+import CLabel++import Unique++data JumpDest = DestBlockId BlockId++getJumpDestBlockId :: JumpDest -> Maybe BlockId+getJumpDestBlockId (DestBlockId bid) = Just bid++canShortcut :: Instr -> Maybe JumpDest+canShortcut _ = Nothing++shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr+shortcutJump _ other = other+++-- Here because it knows about JumpDest+shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics+shortcutStatics fn (Statics lbl statics)+  = Statics lbl $ map (shortcutStatic fn) statics+  -- we need to get the jump tables, so apply the mapping to the entries+  -- of a CmmData too.++shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel+shortcutLabel fn lab+  | Just uq <- maybeAsmTemp lab = shortBlockId fn (mkBlockId uq)+  | otherwise                   = lab++shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic+shortcutStatic fn (CmmStaticLit (CmmLabel lab))+  = CmmStaticLit (CmmLabel (shortcutLabel fn lab))+shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off))+  = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off)+        -- slightly dodgy, we're ignoring the second label, but this+        -- works with the way we use CmmLabelDiffOff for jump tables now.+shortcutStatic _ other_static+        = other_static++shortBlockId+        :: (BlockId -> Maybe JumpDest)+        -> BlockId+        -> CLabel++shortBlockId fn blockid =+   case fn blockid of+      Nothing -> mkAsmTempLabel uq+      Just (DestBlockId blockid')  -> shortBlockId fn blockid'+   where uq = getUnique blockid
+ nativeGen/PPC/Regs.hs view
@@ -0,0 +1,342 @@+{-# LANGUAGE CPP #-}++-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow 1994-2004+--+-- -----------------------------------------------------------------------------++module PPC.Regs (+        -- squeeze functions+        virtualRegSqueeze,+        realRegSqueeze,++        mkVirtualReg,+        regDotColor,++        -- immediates+        Imm(..),+        strImmLit,+        litToImm,++        -- addressing modes+        AddrMode(..),+        addrOffset,++        -- registers+        spRel,+        argRegs,+        allArgRegs,+        callClobberedRegs,+        allMachRegNos,+        classOfRealReg,+        showReg,++        -- machine specific+        allFPArgRegs,+        fits16Bits,+        makeImmediate,+        fReg,+        r0, sp, toc, r3, r4, r11, r12, r27, r28, r30,+        tmpReg,+        f1, f20, f21,++        allocatableRegs++)++where++#include "nativeGen/NCG.h"+#include "HsVersions.h"++import Reg+import RegClass+import Format++import Cmm+import CLabel           ( CLabel )+import Unique++import CodeGen.Platform+import DynFlags+import Outputable+import Platform++import Data.Word        ( Word8, Word16, Word32, Word64 )+import Data.Int         ( Int8, Int16, Int32, Int64 )+++-- squeese functions for the graph allocator -----------------------------------++-- | regSqueeze_class reg+--      Calculuate the maximum number of register colors that could be+--      denied to a node of this class due to having this reg+--      as a neighbour.+--+{-# INLINE virtualRegSqueeze #-}+virtualRegSqueeze :: RegClass -> VirtualReg -> Int+virtualRegSqueeze cls vr+ = case cls of+        RcInteger+         -> case vr of+                VirtualRegI{}           -> 1+                VirtualRegHi{}          -> 1+                _other                  -> 0++        RcDouble+         -> case vr of+                VirtualRegD{}           -> 1+                VirtualRegF{}           -> 0+                _other                  -> 0++        _other -> 0++{-# INLINE realRegSqueeze #-}+realRegSqueeze :: RegClass -> RealReg -> Int+realRegSqueeze cls rr+ = case cls of+        RcInteger+         -> case rr of+                RealRegSingle regNo+                        | regNo < 32    -> 1     -- first fp reg is 32+                        | otherwise     -> 0++                RealRegPair{}           -> 0++        RcDouble+         -> case rr of+                RealRegSingle regNo+                        | regNo < 32    -> 0+                        | otherwise     -> 1++                RealRegPair{}           -> 0++        _other -> 0++mkVirtualReg :: Unique -> Format -> VirtualReg+mkVirtualReg u format+   | not (isFloatFormat format) = VirtualRegI u+   | otherwise+   = case format of+        FF32    -> VirtualRegD u+        FF64    -> VirtualRegD u+        _       -> panic "mkVirtualReg"++regDotColor :: RealReg -> SDoc+regDotColor reg+ = case classOfRealReg reg of+        RcInteger       -> text "blue"+        RcFloat         -> text "red"+        RcDouble        -> text "green"+        RcDoubleSSE     -> text "yellow"+++-- immediates ------------------------------------------------------------------+data Imm+        = ImmInt        Int+        | ImmInteger    Integer     -- Sigh.+        | ImmCLbl       CLabel      -- AbstractC Label (with baggage)+        | ImmLit        SDoc        -- Simple string+        | ImmIndex    CLabel Int+        | ImmFloat      Rational+        | ImmDouble     Rational+        | ImmConstantSum Imm Imm+        | ImmConstantDiff Imm Imm+        | LO Imm+        | HI Imm+        | HA Imm        {- high halfword adjusted -}+        | HIGHERA Imm+        | HIGHESTA Imm+++strImmLit :: String -> Imm+strImmLit s = ImmLit (text s)+++litToImm :: CmmLit -> Imm+litToImm (CmmInt i w)        = ImmInteger (narrowS w i)+                -- narrow to the width: a CmmInt might be out of+                -- range, but we assume that ImmInteger only contains+                -- in-range values.  A signed value should be fine here.+litToImm (CmmFloat f W32)    = ImmFloat f+litToImm (CmmFloat f W64)    = ImmDouble f+litToImm (CmmLabel l)        = ImmCLbl l+litToImm (CmmLabelOff l off) = ImmIndex l off+litToImm (CmmLabelDiffOff l1 l2 off)+                             = ImmConstantSum+                               (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))+                               (ImmInt off)+litToImm _                   = panic "PPC.Regs.litToImm: no match"+++-- addressing modes ------------------------------------------------------------++data AddrMode+        = AddrRegReg    Reg Reg+        | AddrRegImm    Reg Imm+++addrOffset :: AddrMode -> Int -> Maybe AddrMode+addrOffset addr off+  = case addr of+      AddrRegImm r (ImmInt n)+       | fits16Bits n2 -> Just (AddrRegImm r (ImmInt n2))+       | otherwise     -> Nothing+       where n2 = n + off++      AddrRegImm r (ImmInteger n)+       | fits16Bits n2 -> Just (AddrRegImm r (ImmInt (fromInteger n2)))+       | otherwise     -> Nothing+       where n2 = n + toInteger off++      _ -> Nothing+++-- registers -------------------------------------------------------------------+-- @spRel@ gives us a stack relative addressing mode for volatile+-- temporaries and for excess call arguments.  @fpRel@, where+-- applicable, is the same but for the frame pointer.++spRel :: DynFlags+      -> Int    -- desired stack offset in words, positive or negative+      -> AddrMode++spRel dflags n = AddrRegImm sp (ImmInt (n * wORD_SIZE dflags))+++-- argRegs is the set of regs which are read for an n-argument call to C.+-- For archs which pass all args on the stack (x86), is empty.+-- Sparc passes up to the first 6 args in regs.+argRegs :: RegNo -> [Reg]+argRegs 0 = []+argRegs 1 = map regSingle [3]+argRegs 2 = map regSingle [3,4]+argRegs 3 = map regSingle [3..5]+argRegs 4 = map regSingle [3..6]+argRegs 5 = map regSingle [3..7]+argRegs 6 = map regSingle [3..8]+argRegs 7 = map regSingle [3..9]+argRegs 8 = map regSingle [3..10]+argRegs _ = panic "MachRegs.argRegs(powerpc): don't know about >8 arguments!"+++allArgRegs :: [Reg]+allArgRegs = map regSingle [3..10]+++-- these are the regs which we cannot assume stay alive over a C call.+callClobberedRegs :: Platform -> [Reg]+callClobberedRegs platform+  = case platformOS platform of+    OSAIX    -> map regSingle (0:[2..12] ++ map fReg [0..13])+    OSDarwin -> map regSingle (0:[2..12] ++ map fReg [0..13])+    OSLinux  -> map regSingle (0:[2..13] ++ map fReg [0..13])+    _        -> panic "PPC.Regs.callClobberedRegs: not defined for this architecture"+++allMachRegNos   :: [RegNo]+allMachRegNos   = [0..63]+++{-# INLINE classOfRealReg      #-}+classOfRealReg :: RealReg -> RegClass+classOfRealReg (RealRegSingle i)+        | i < 32        = RcInteger+        | otherwise     = RcDouble++classOfRealReg (RealRegPair{})+        = panic "regClass(ppr): no reg pairs on this architecture"++showReg :: RegNo -> String+showReg n+    | n >= 0 && n <= 31   = "%r" ++ show n+    | n >= 32 && n <= 63  = "%f" ++ show (n - 32)+    | otherwise           = "%unknown_powerpc_real_reg_" ++ show n++++-- machine specific ------------------------------------------------------------++allFPArgRegs :: Platform -> [Reg]+allFPArgRegs platform+    = case platformOS platform of+      OSAIX    -> map (regSingle . fReg) [1..13]+      OSDarwin -> map (regSingle . fReg) [1..13]+      OSLinux  -> case platformArch platform of+        ArchPPC      -> map (regSingle . fReg) [1..8]+        ArchPPC_64 _ -> map (regSingle . fReg) [1..13]+        _            -> panic "PPC.Regs.allFPArgRegs: unknown PPC Linux"+      _        -> panic "PPC.Regs.allFPArgRegs: not defined for this architecture"++fits16Bits :: Integral a => a -> Bool+fits16Bits x = x >= -32768 && x < 32768++makeImmediate :: Integral a => Width -> Bool -> a -> Maybe Imm+makeImmediate rep signed x = fmap ImmInt (toI16 rep signed)+    where+        narrow W64 False = fromIntegral (fromIntegral x :: Word64)+        narrow W32 False = fromIntegral (fromIntegral x :: Word32)+        narrow W16 False = fromIntegral (fromIntegral x :: Word16)+        narrow W8  False = fromIntegral (fromIntegral x :: Word8)+        narrow W64 True  = fromIntegral (fromIntegral x :: Int64)+        narrow W32 True  = fromIntegral (fromIntegral x :: Int32)+        narrow W16 True  = fromIntegral (fromIntegral x :: Int16)+        narrow W8  True  = fromIntegral (fromIntegral x :: Int8)+        narrow _   _     = panic "PPC.Regs.narrow: no match"++        narrowed = narrow rep signed++        toI16 W32 True+            | narrowed >= -32768 && narrowed < 32768 = Just narrowed+            | otherwise = Nothing+        toI16 W32 False+            | narrowed >= 0 && narrowed < 65536 = Just narrowed+            | otherwise = Nothing+        toI16 W64 True+            | narrowed >= -32768 && narrowed < 32768 = Just narrowed+            | otherwise = Nothing+        toI16 W64 False+            | narrowed >= 0 && narrowed < 65536 = Just narrowed+            | otherwise = Nothing+        toI16 _ _  = Just narrowed+++{-+The PowerPC has 64 registers of interest; 32 integer registers and 32 floating+point registers.+-}++fReg :: Int -> RegNo+fReg x = (32 + x)++r0, sp, toc, r3, r4, r11, r12, r27, r28, r30, f1, f20, f21 :: Reg+r0      = regSingle 0+sp      = regSingle 1+toc     = regSingle 2+r3      = regSingle 3+r4      = regSingle 4+r11     = regSingle 11+r12     = regSingle 12+r27     = regSingle 27+r28     = regSingle 28+r30     = regSingle 30+f1      = regSingle $ fReg 1+f20     = regSingle $ fReg 20+f21     = regSingle $ fReg 21++-- allocatableRegs is allMachRegNos with the fixed-use regs removed.+-- i.e., these are the regs for which we are prepared to allow the+-- register allocator to attempt to map VRegs to.+allocatableRegs :: Platform -> [RealReg]+allocatableRegs platform+   = let isFree i = freeReg platform i+     in  map RealRegSingle $ filter isFree allMachRegNos++-- temporary register for compiler use+tmpReg :: Platform -> Reg+tmpReg platform =+       case platformArch platform of+       ArchPPC      -> regSingle 13+       ArchPPC_64 _ -> regSingle 30+       _            -> panic "PPC.Regs.tmpReg: unknowm arch"
+ nativeGen/PprBase.hs view
@@ -0,0 +1,153 @@+-----------------------------------------------------------------------------+--+-- Pretty-printing assembly language+--+-- (c) The University of Glasgow 1993-2005+--+-----------------------------------------------------------------------------++module PprBase (+        castFloatToWord8Array,+        castDoubleToWord8Array,+        floatToBytes,+        doubleToBytes,+        pprSectionHeader+)++where++import CLabel+import Cmm+import DynFlags+import FastString+import Outputable+import Platform++import qualified Data.Array.Unsafe as U ( castSTUArray )+import Data.Array.ST++import Control.Monad.ST++import Data.Word++++-- -----------------------------------------------------------------------------+-- Converting floating-point literals to integrals for printing++castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)+castFloatToWord8Array = U.castSTUArray++castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8)+castDoubleToWord8Array = U.castSTUArray++-- floatToBytes and doubleToBytes convert to the host's byte+-- order.  Providing that we're not cross-compiling for a+-- target with the opposite endianness, this should work ok+-- on all targets.++-- ToDo: this stuff is very similar to the shenanigans in PprAbs,+-- could they be merged?++floatToBytes :: Float -> [Int]+floatToBytes f+   = runST (do+        arr <- newArray_ ((0::Int),3)+        writeArray arr 0 f+        arr <- castFloatToWord8Array arr+        i0 <- readArray arr 0+        i1 <- readArray arr 1+        i2 <- readArray arr 2+        i3 <- readArray arr 3+        return (map fromIntegral [i0,i1,i2,i3])+     )++doubleToBytes :: Double -> [Int]+doubleToBytes d+   = runST (do+        arr <- newArray_ ((0::Int),7)+        writeArray arr 0 d+        arr <- castDoubleToWord8Array arr+        i0 <- readArray arr 0+        i1 <- readArray arr 1+        i2 <- readArray arr 2+        i3 <- readArray arr 3+        i4 <- readArray arr 4+        i5 <- readArray arr 5+        i6 <- readArray arr 6+        i7 <- readArray arr 7+        return (map fromIntegral [i0,i1,i2,i3,i4,i5,i6,i7])+     )++-- ----------------------------------------------------------------------------+-- Printing section headers.+--+-- If -split-section was specified, include the suffix label, otherwise just+-- print the section type. For Darwin, where subsections-for-symbols are+-- used instead, only print section type.+--+-- For string literals, additional flags are specified to enable merging of+-- identical strings in the linker. With -split-sections each string also gets+-- a unique section to allow strings from unused code to be GC'd.++pprSectionHeader :: Platform -> Section -> SDoc+pprSectionHeader platform (Section t suffix) =+ case platformOS platform of+   OSAIX    -> pprXcoffSectionHeader t+   OSDarwin -> pprDarwinSectionHeader t+   _        -> pprGNUSectionHeader t suffix++pprGNUSectionHeader :: SectionType -> CLabel -> SDoc+pprGNUSectionHeader t suffix = sdocWithDynFlags $ \dflags ->+  let splitSections = gopt Opt_SplitSections dflags+      subsection | splitSections = char '.' <> ppr suffix+                 | otherwise     = empty+  in  text ".section " <> ptext (header dflags) <> subsection <>+      flags dflags+  where+    header dflags = case t of+      Text -> sLit ".text"+      Data -> sLit ".data"+      ReadOnlyData -> sLit ".rodata"+      RelocatableReadOnlyData -> sLit ".data.rel.ro"+      UninitialisedData -> sLit ".bss"+      ReadOnlyData16 -> sLit ".rodata.cst16"+      CString+        | OSMinGW32 <- platformOS (targetPlatform dflags)+          -> sLit ".rdata"+        | otherwise -> sLit ".rodata.str"+      OtherSection _ ->+        panic "PprBase.pprGNUSectionHeader: unknown section type"+    flags dflags = case t of+      CString+        | OSMinGW32 <- platformOS (targetPlatform dflags)+          -> text ",\"dr\""+        | otherwise -> text ",\"aMS\",@progbits,1"+      _ -> empty++-- XCOFF doesn't support relocating label-differences, so we place all+-- RO sections into .text[PR] sections+pprXcoffSectionHeader :: SectionType -> SDoc+pprXcoffSectionHeader t = text $ case t of+     Text                    -> ".csect .text[PR]"+     Data                    -> ".csect .data[RW]"+     ReadOnlyData            -> ".csect .text[PR] # ReadOnlyData"+     RelocatableReadOnlyData -> ".csect .text[PR] # RelocatableReadOnlyData"+     ReadOnlyData16          -> ".csect .text[PR] # ReadOnlyData16"+     CString                 -> ".csect .text[PR] # CString"+     UninitialisedData       -> ".csect .data[BS]"+     OtherSection _          ->+       panic "PprBase.pprXcoffSectionHeader: unknown section type"++pprDarwinSectionHeader :: SectionType -> SDoc+pprDarwinSectionHeader t =+  ptext $ case t of+     Text -> sLit ".text"+     Data -> sLit ".data"+     ReadOnlyData -> sLit ".const"+     RelocatableReadOnlyData -> sLit ".const_data"+     UninitialisedData -> sLit ".data"+     ReadOnlyData16 -> sLit ".const"+     CString -> sLit ".section\t__TEXT,__cstring,cstring_literals"+     OtherSection _ ->+       panic "PprBase.pprDarwinSectionHeader: unknown section type"
+ nativeGen/Reg.hs view
@@ -0,0 +1,239 @@+-- | An architecture independent description of a register.+--      This needs to stay architecture independent because it is used+--      by NCGMonad and the register allocators, which are shared+--      by all architectures.+--+module Reg (+        RegNo,+        Reg(..),+        regPair,+        regSingle,+        isRealReg,      takeRealReg,+        isVirtualReg,   takeVirtualReg,++        VirtualReg(..),+        renameVirtualReg,+        classOfVirtualReg,+        getHiVirtualRegFromLo,+        getHiVRegFromLo,++        RealReg(..),+        regNosOfRealReg,+        realRegsAlias,++        liftPatchFnToRegReg+)++where++import Outputable+import Unique+import RegClass+import Data.List++-- | An identifier for a primitive real machine register.+type RegNo+        = Int++-- VirtualRegs are virtual registers.  The register allocator will+--      eventually have to map them into RealRegs, or into spill slots.+--+--      VirtualRegs are allocated on the fly, usually to represent a single+--      value in the abstract assembly code (i.e. dynamic registers are+--      usually single assignment).+--+--      The  single assignment restriction isn't necessary to get correct code,+--      although a better register allocation will result if single+--      assignment is used -- because the allocator maps a VirtualReg into+--      a single RealReg, even if the VirtualReg has multiple live ranges.+--+--      Virtual regs can be of either class, so that info is attached.+--+data VirtualReg+        = VirtualRegI  {-# UNPACK #-} !Unique+        | VirtualRegHi {-# UNPACK #-} !Unique  -- High part of 2-word register+        | VirtualRegF  {-# UNPACK #-} !Unique+        | VirtualRegD  {-# UNPACK #-} !Unique+        | VirtualRegSSE {-# UNPACK #-} !Unique+        deriving (Eq, Show)++-- This is laborious, but necessary. We can't derive Ord because+-- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the+-- implementation. See Note [No Ord for Unique]+-- This is non-deterministic but we do not currently support deterministic+-- code-generation. See Note [Unique Determinism and code generation]+instance Ord VirtualReg where+  compare (VirtualRegI a) (VirtualRegI b) = nonDetCmpUnique a b+  compare (VirtualRegHi a) (VirtualRegHi b) = nonDetCmpUnique a b+  compare (VirtualRegF a) (VirtualRegF b) = nonDetCmpUnique a b+  compare (VirtualRegD a) (VirtualRegD b) = nonDetCmpUnique a b+  compare (VirtualRegSSE a) (VirtualRegSSE b) = nonDetCmpUnique a b+  compare VirtualRegI{} _ = LT+  compare _ VirtualRegI{} = GT+  compare VirtualRegHi{} _ = LT+  compare _ VirtualRegHi{} = GT+  compare VirtualRegF{} _ = LT+  compare _ VirtualRegF{} = GT+  compare VirtualRegD{} _ = LT+  compare _ VirtualRegD{} = GT+++instance Uniquable VirtualReg where+        getUnique reg+         = case reg of+                VirtualRegI u   -> u+                VirtualRegHi u  -> u+                VirtualRegF u   -> u+                VirtualRegD u   -> u+                VirtualRegSSE u -> u++instance Outputable VirtualReg where+        ppr reg+         = case reg of+                VirtualRegI  u  -> text "%vI_"   <> pprUniqueAlways u+                VirtualRegHi u  -> text "%vHi_"  <> pprUniqueAlways u+                VirtualRegF  u  -> text "%vF_"   <> pprUniqueAlways u+                VirtualRegD  u  -> text "%vD_"   <> pprUniqueAlways u+                VirtualRegSSE u -> text "%vSSE_" <> pprUniqueAlways u+++renameVirtualReg :: Unique -> VirtualReg -> VirtualReg+renameVirtualReg u r+ = case r of+        VirtualRegI _   -> VirtualRegI  u+        VirtualRegHi _  -> VirtualRegHi u+        VirtualRegF _   -> VirtualRegF  u+        VirtualRegD _   -> VirtualRegD  u+        VirtualRegSSE _ -> VirtualRegSSE u+++classOfVirtualReg :: VirtualReg -> RegClass+classOfVirtualReg vr+ = case vr of+        VirtualRegI{}   -> RcInteger+        VirtualRegHi{}  -> RcInteger+        VirtualRegF{}   -> RcFloat+        VirtualRegD{}   -> RcDouble+        VirtualRegSSE{} -> RcDoubleSSE+++-- Determine the upper-half vreg for a 64-bit quantity on a 32-bit platform+-- when supplied with the vreg for the lower-half of the quantity.+-- (NB. Not reversible).+getHiVirtualRegFromLo :: VirtualReg -> VirtualReg+getHiVirtualRegFromLo reg+ = case reg of+        -- makes a pseudo-unique with tag 'H'+        VirtualRegI u   -> VirtualRegHi (newTagUnique u 'H')+        _               -> panic "Reg.getHiVirtualRegFromLo"++getHiVRegFromLo :: Reg -> Reg+getHiVRegFromLo reg+ = case reg of+        RegVirtual  vr  -> RegVirtual (getHiVirtualRegFromLo vr)+        RegReal _       -> panic "Reg.getHiVRegFromLo"+++------------------------------------------------------------------------------------+-- | RealRegs are machine regs which are available for allocation, in+--      the usual way.  We know what class they are, because that's part of+--      the processor's architecture.+--+--      RealRegPairs are pairs of real registers that are allocated together+--      to hold a larger value, such as with Double regs on SPARC.+--+data RealReg+        = RealRegSingle {-# UNPACK #-} !RegNo+        | RealRegPair   {-# UNPACK #-} !RegNo {-# UNPACK #-} !RegNo+        deriving (Eq, Show, Ord)++instance Uniquable RealReg where+        getUnique reg+         = case reg of+                RealRegSingle i         -> mkRegSingleUnique i+                RealRegPair r1 r2       -> mkRegPairUnique (r1 * 65536 + r2)++instance Outputable RealReg where+        ppr reg+         = case reg of+                RealRegSingle i         -> text "%r"  <> int i+                RealRegPair r1 r2       -> text "%r(" <> int r1+                                           <> vbar <> int r2 <> text ")"++regNosOfRealReg :: RealReg -> [RegNo]+regNosOfRealReg rr+ = case rr of+        RealRegSingle r1        -> [r1]+        RealRegPair   r1 r2     -> [r1, r2]+++realRegsAlias :: RealReg -> RealReg -> Bool+realRegsAlias rr1 rr2+        = not $ null $ intersect (regNosOfRealReg rr1) (regNosOfRealReg rr2)++--------------------------------------------------------------------------------+-- | A register, either virtual or real+data Reg+        = RegVirtual !VirtualReg+        | RegReal    !RealReg+        deriving (Eq, Ord)++regSingle :: RegNo -> Reg+regSingle regNo         = RegReal $ RealRegSingle regNo++regPair :: RegNo -> RegNo -> Reg+regPair regNo1 regNo2   = RegReal $ RealRegPair regNo1 regNo2+++-- We like to have Uniques for Reg so that we can make UniqFM and UniqSets+-- in the register allocator.+instance Uniquable Reg where+        getUnique reg+         = case reg of+                RegVirtual vr   -> getUnique vr+                RegReal    rr   -> getUnique rr++-- | Print a reg in a generic manner+--      If you want the architecture specific names, then use the pprReg+--      function from the appropriate Ppr module.+instance Outputable Reg where+        ppr reg+         = case reg of+                RegVirtual vr   -> ppr vr+                RegReal    rr   -> ppr rr+++isRealReg :: Reg -> Bool+isRealReg reg+ = case reg of+        RegReal _       -> True+        RegVirtual _    -> False++takeRealReg :: Reg -> Maybe RealReg+takeRealReg reg+ = case reg of+        RegReal rr      -> Just rr+        _               -> Nothing+++isVirtualReg :: Reg -> Bool+isVirtualReg reg+ = case reg of+        RegReal _       -> False+        RegVirtual _    -> True++takeVirtualReg :: Reg -> Maybe VirtualReg+takeVirtualReg reg+ = case reg of+        RegReal _       -> Nothing+        RegVirtual vr   -> Just vr+++-- | The patch function supplied by the allocator maps VirtualReg to RealReg+--      regs, but sometimes we want to apply it to plain old Reg.+--+liftPatchFnToRegReg  :: (VirtualReg -> RealReg) -> (Reg -> Reg)+liftPatchFnToRegReg patchF reg+ = case reg of+        RegVirtual vr   -> RegReal (patchF vr)+        RegReal _       -> reg
+ nativeGen/RegAlloc/Graph/ArchBase.hs view
@@ -0,0 +1,159 @@++-- | Utils for calculating general worst, bound, squeese and free, functions.+--+--   as per: "A Generalized Algorithm for Graph-Coloring Register Allocation"+--           Michael Smith, Normal Ramsey, Glenn Holloway.+--           PLDI 2004+--+--   These general versions are not used in GHC proper because they are too slow.+--   Instead, hand written optimised versions are provided for each architecture+--   in MachRegs*.hs+--+--   This code is here because we can test the architecture specific code against+--   it.+--+module RegAlloc.Graph.ArchBase (+        RegClass(..),+        Reg(..),+        RegSub(..),++        worst,+        bound,+        squeese+) where+import UniqSet+import UniqFM+import Unique+++-- Some basic register classes.+--      These aren't nessesarally in 1-to-1 correspondance with the allocatable+--      RegClasses in MachRegs.hs+data RegClass+        -- general purpose regs+        = ClassG32      -- 32 bit GPRs+        | ClassG16      -- 16 bit GPRs+        | ClassG8       -- 8  bit GPRs++        -- floating point regs+        | ClassF64      -- 64 bit FPRs+        deriving (Show, Eq, Enum)+++-- | A register of some class+data Reg+        -- a register of some class+        = Reg RegClass Int++        -- a sub-component of one of the other regs+        | RegSub RegSub Reg+        deriving (Show, Eq)+++-- | so we can put regs in UniqSets+instance Uniquable Reg where+        getUnique (Reg c i)+         = mkRegSingleUnique+         $ fromEnum c * 1000 + i++        getUnique (RegSub s (Reg c i))+         = mkRegSubUnique+         $ fromEnum s * 10000 + fromEnum c * 1000 + i++        getUnique (RegSub _ (RegSub _ _))+          = error "RegArchBase.getUnique: can't have a sub-reg of a sub-reg."+++-- | A subcomponent of another register+data RegSub+        = SubL16        -- lowest 16 bits+        | SubL8         -- lowest  8 bits+        | SubL8H        -- second lowest 8 bits+        deriving (Show, Enum, Ord, Eq)+++-- | Worst case displacement+--+--      a node N of classN has some number of neighbors,+--      all of which are from classC.+--+--      (worst neighbors classN classC) is the maximum number of potential+--      colors for N that can be lost by coloring its neighbors.+--+-- This should be hand coded/cached for each particular architecture,+--      because the compute time is very long..+worst   :: (RegClass    -> UniqSet Reg)+        -> (Reg         -> UniqSet Reg)+        -> Int -> RegClass -> RegClass -> Int++worst regsOfClass regAlias neighbors classN classC+ = let  regAliasS regs  = unionManyUniqSets+                        $ map regAlias+                        $ nonDetEltsUniqSet regs+                        -- This is non-deterministic but we do not+                        -- currently support deterministic code-generation.+                        -- See Note [Unique Determinism and code generation]++        -- all the regs in classes N, C+        regsN           = regsOfClass classN+        regsC           = regsOfClass classC++        -- all the possible subsets of c which have size < m+        regsS           = filter (\s -> sizeUniqSet s >= 1+                                     && sizeUniqSet s <= neighbors)+                        $ powersetLS regsC++        -- for each of the subsets of C, the regs which conflict+        -- with posiblities for N+        regsS_conflict+                = map (\s -> intersectUniqSets regsN (regAliasS s)) regsS++  in    maximum $ map sizeUniqSet $ regsS_conflict+++-- | For a node N of classN and neighbors of classesC+--      (bound classN classesC) is the maximum number of potential+--      colors for N that can be lost by coloring its neighbors.+bound   :: (RegClass    -> UniqSet Reg)+        -> (Reg         -> UniqSet Reg)+        -> RegClass -> [RegClass] -> Int++bound regsOfClass regAlias classN classesC+ = let  regAliasS regs  = unionManyUniqSets+                        $ map regAlias+                        $ nonDetEltsUFM regs+                        -- See Note [Unique Determinism and code generation]++        regsC_aliases+                = unionManyUniqSets+                $ map (regAliasS . getUniqSet . regsOfClass) classesC++        overlap = intersectUniqSets (regsOfClass classN) regsC_aliases++   in   sizeUniqSet overlap+++-- | The total squeese on a particular node with a list of neighbors.+--+--   A version of this should be constructed for each particular architecture,+--   possibly including uses of bound, so that alised registers don't get+--   counted twice, as per the paper.+squeese :: (RegClass    -> UniqSet Reg)+        -> (Reg         -> UniqSet Reg)+        -> RegClass -> [(Int, RegClass)] -> Int++squeese regsOfClass regAlias classN countCs+        = sum+        $ map (\(i, classC) -> worst regsOfClass regAlias i classN classC)+        $ countCs+++-- | powerset (for lists)+powersetL :: [a] -> [[a]]+powersetL       = map concat . mapM (\x -> [[],[x]])+++-- | powersetLS (list of sets)+powersetLS :: Uniquable a => UniqSet a -> [UniqSet a]+powersetLS s    = map mkUniqSet $ powersetL $ nonDetEltsUniqSet s+  -- See Note [Unique Determinism and code generation]
+ nativeGen/RegAlloc/Graph/ArchX86.hs view
@@ -0,0 +1,146 @@++-- | A description of the register set of the X86.+--+--   This isn't used directly in GHC proper.+--+--   See RegArchBase.hs for the reference.+--   See MachRegs.hs for the actual trivColorable function used in GHC.+--+module RegAlloc.Graph.ArchX86 (+        classOfReg,+        regsOfClass,+        regName,+        regAlias,+        worst,+        squeese,+) where+import RegAlloc.Graph.ArchBase  (Reg(..), RegSub(..), RegClass(..))+import UniqSet+++-- | Determine the class of a register+classOfReg :: Reg -> RegClass+classOfReg reg+ = case reg of+        Reg c _         -> c++        RegSub SubL16 _ -> ClassG16+        RegSub SubL8  _ -> ClassG8+        RegSub SubL8H _ -> ClassG8+++-- | Determine all the regs that make up a certain class.+regsOfClass :: RegClass -> UniqSet Reg+regsOfClass c+ = case c of+        ClassG32+         -> mkUniqSet   [ Reg ClassG32  i+                        | i <- [0..7] ]++        ClassG16+         -> mkUniqSet   [ RegSub SubL16 (Reg ClassG32 i)+                        | i <- [0..7] ]++        ClassG8+         -> unionUniqSets+                (mkUniqSet [ RegSub SubL8  (Reg ClassG32 i) | i <- [0..3] ])+                (mkUniqSet [ RegSub SubL8H (Reg ClassG32 i) | i <- [0..3] ])++        ClassF64+         -> mkUniqSet   [ Reg ClassF64  i+                        | i <- [0..5] ]+++-- | Determine the common name of a reg+--      returns Nothing if this reg is not part of the machine.+regName :: Reg -> Maybe String+regName reg+ = case reg of+        Reg ClassG32 i+         | i <= 7-> Just $ [ "eax", "ebx", "ecx", "edx"+                           , "ebp", "esi", "edi", "esp" ] !! i++        RegSub SubL16 (Reg ClassG32 i)+         | i <= 7 -> Just $ [ "ax", "bx", "cx", "dx"+                            , "bp", "si", "di", "sp"] !! i++        RegSub SubL8  (Reg ClassG32 i)+         | i <= 3 -> Just $ [ "al", "bl", "cl", "dl"] !! i++        RegSub SubL8H (Reg ClassG32 i)+         | i <= 3 -> Just $ [ "ah", "bh", "ch", "dh"] !! i++        _         -> Nothing+++-- | Which regs alias what other regs.+regAlias :: Reg -> UniqSet Reg+regAlias reg+ = case reg of++        -- 32 bit regs alias all of the subregs+        Reg ClassG32 i++         -- for eax, ebx, ecx, eds+         |  i <= 3+         -> mkUniqSet+         $ [ Reg ClassG32 i,   RegSub SubL16 reg+           , RegSub SubL8 reg, RegSub SubL8H reg ]++         -- for esi, edi, esp, ebp+         | 4 <= i && i <= 7+         -> mkUniqSet+         $ [ Reg ClassG32 i,   RegSub SubL16 reg ]++        -- 16 bit subregs alias the whole reg+        RegSub SubL16 r@(Reg ClassG32 _)+         ->     regAlias r++        -- 8 bit subregs alias the 32 and 16, but not the other 8 bit subreg+        RegSub SubL8  r@(Reg ClassG32 _)+         -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8 r ]++        RegSub SubL8H r@(Reg ClassG32 _)+         -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8H r ]++        -- fp+        Reg ClassF64 _+         -> unitUniqSet reg++        _ -> error "regAlias: invalid register"+++-- | Optimised versions of RegColorBase.{worst, squeese} specific to x86+worst :: Int -> RegClass -> RegClass -> Int+worst n classN classC+ = case classN of+        ClassG32+         -> case classC of+                ClassG32        -> min n 8+                ClassG16        -> min n 8+                ClassG8         -> min n 4+                ClassF64        -> 0++        ClassG16+         -> case classC of+                ClassG32        -> min n 8+                ClassG16        -> min n 8+                ClassG8         -> min n 4+                ClassF64        -> 0++        ClassG8+         -> case classC of+                ClassG32        -> min (n*2) 8+                ClassG16        -> min (n*2) 8+                ClassG8         -> min n 8+                ClassF64        -> 0++        ClassF64+         -> case classC of+                ClassF64        -> min n 6+                _               -> 0++squeese :: RegClass -> [(Int, RegClass)] -> Int+squeese classN countCs+        = sum (map (\(i, classC) -> worst i classN classC) countCs)+
+ nativeGen/RegAlloc/Graph/Coalesce.hs view
@@ -0,0 +1,99 @@+-- | Register coalescing.+module RegAlloc.Graph.Coalesce (+        regCoalesce,+        slurpJoinMovs+) where+import RegAlloc.Liveness+import Instruction+import Reg++import Cmm+import Bag+import Digraph+import UniqFM+import UniqSet+import UniqSupply++import Data.List+++-- | Do register coalescing on this top level thing+--+--   For Reg -> Reg moves, if the first reg dies at the same time the+--   second reg is born then the mov only serves to join live ranges.+--   The two regs can be renamed to be the same and the move instruction+--   safely erased.+regCoalesce+        :: Instruction instr+        => [LiveCmmDecl statics instr]+        -> UniqSM [LiveCmmDecl statics instr]++regCoalesce code+ = do+        let joins       = foldl' unionBags emptyBag+                        $ map slurpJoinMovs code++        let alloc       = foldl' buildAlloc emptyUFM+                        $ bagToList joins++        let patched     = map (patchEraseLive (sinkReg alloc)) code++        return patched+++-- | Add a v1 = v2 register renaming to the map.+--   The register with the lowest lexical name is set as the+--   canonical version.+buildAlloc :: UniqFM Reg -> (Reg, Reg) -> UniqFM Reg+buildAlloc fm (r1, r2)+ = let  rmin    = min r1 r2+        rmax    = max r1 r2+   in   addToUFM fm rmax rmin+++-- | Determine the canonical name for a register by following+--   v1 = v2 renamings in this map.+sinkReg :: UniqFM Reg -> Reg -> Reg+sinkReg fm r+ = case lookupUFM fm r of+        Nothing -> r+        Just r' -> sinkReg fm r'+++-- | Slurp out mov instructions that only serve to join live ranges.+--+--   During a mov, if the source reg dies and the destiation reg is+--   born then we can rename the two regs to the same thing and+--   eliminate the move.+slurpJoinMovs+        :: Instruction instr+        => LiveCmmDecl statics instr+        -> Bag (Reg, Reg)++slurpJoinMovs live+        = slurpCmm emptyBag live+ where+        slurpCmm   rs  CmmData{}+         = rs++        slurpCmm   rs (CmmProc _ _ _ sccs)+         = foldl' slurpBlock rs (flattenSCCs sccs)++        slurpBlock rs (BasicBlock _ instrs)+         = foldl' slurpLI    rs instrs++        slurpLI    rs (LiveInstr _      Nothing)    = rs+        slurpLI    rs (LiveInstr instr (Just live))+                | Just (r1, r2) <- takeRegRegMoveInstr instr+                , elementOfUniqSet r1 $ liveDieRead live+                , elementOfUniqSet r2 $ liveBorn live++                -- only coalesce movs between two virtuals for now,+                -- else we end up with allocatable regs in the live+                -- regs list..+                , isVirtualReg r1 && isVirtualReg r2+                = consBag (r1, r2) rs++                | otherwise+                = rs+
+ nativeGen/RegAlloc/Graph/Main.hs view
@@ -0,0 +1,453 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- | Graph coloring register allocator.+module RegAlloc.Graph.Main (+        regAlloc+) where+import qualified GraphColor as Color+import RegAlloc.Liveness+import RegAlloc.Graph.Spill+import RegAlloc.Graph.SpillClean+import RegAlloc.Graph.SpillCost+import RegAlloc.Graph.Stats+import RegAlloc.Graph.TrivColorable+import Instruction+import TargetReg+import RegClass+import Reg++import Bag+import DynFlags+import Outputable+import Platform+import UniqFM+import UniqSet+import UniqSupply+import Util (seqList)++import Data.List+import Data.Maybe+import Control.Monad+++-- | The maximum number of build\/spill cycles we'll allow.+--+--   It should only take 3 or 4 cycles for the allocator to converge.+--   If it takes any longer than this it's probably in an infinite loop,+--   so it's better just to bail out and report a bug.+maxSpinCount    :: Int+maxSpinCount    = 10+++-- | The top level of the graph coloring register allocator.+regAlloc+        :: (Outputable statics, Outputable instr, Instruction instr)+        => DynFlags+        -> UniqFM (UniqSet RealReg)     -- ^ registers we can use for allocation+        -> UniqSet Int                  -- ^ set of available spill slots.+        -> [LiveCmmDecl statics instr]  -- ^ code annotated with liveness information.+        -> UniqSM ( [NatCmmDecl statics instr], [RegAllocStats statics instr] )+           -- ^ code with registers allocated and stats for each stage of+           -- allocation++regAlloc dflags regsFree slotsFree code+ = do+        -- TODO: the regClass function is currently hard coded to the default+        --       target architecture. Would prefer to determine this from dflags.+        --       There are other uses of targetRegClass later in this module.+        let platform = targetPlatform dflags+            triv = trivColorable platform+                        (targetVirtualRegSqueeze platform)+                        (targetRealRegSqueeze platform)++        (code_final, debug_codeGraphs, _)+                <- regAlloc_spin dflags 0+                        triv+                        regsFree slotsFree [] code++        return  ( code_final+                , reverse debug_codeGraphs )+++-- | Perform solver iterations for the graph coloring allocator.+--+--   We extract a register confict graph from the provided cmm code,+--   and try to colour it. If that works then we use the solution rewrite+--   the code with real hregs. If coloring doesn't work we add spill code+--   and try to colour it again. After `maxSpinCount` iterations we give up.+--+regAlloc_spin+        :: (Instruction instr,+            Outputable instr,+            Outputable statics)+        => DynFlags+        -> Int  -- ^ Number of solver iterations we've already performed.+        -> Color.Triv VirtualReg RegClass RealReg+                -- ^ Function for calculating whether a register is trivially+                --   colourable.+        -> UniqFM (UniqSet RealReg)      -- ^ Free registers that we can allocate.+        -> UniqSet Int                   -- ^ Free stack slots that we can use.+        -> [RegAllocStats statics instr] -- ^ Current regalloc stats to add to.+        -> [LiveCmmDecl statics instr]   -- ^ Liveness annotated code to allocate.+        -> UniqSM ( [NatCmmDecl statics instr]+                  , [RegAllocStats statics instr]+                  , Color.Graph VirtualReg RegClass RealReg)++regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code+ = do+        let platform = targetPlatform dflags++        -- If any of these dump flags are turned on we want to hang on to+        -- intermediate structures in the allocator - otherwise tell the+        -- allocator to ditch them early so we don't end up creating space leaks.+        let dump = or+                [ dopt Opt_D_dump_asm_regalloc_stages dflags+                , dopt Opt_D_dump_asm_stats dflags+                , dopt Opt_D_dump_asm_conflicts dflags ]++        -- Check that we're not running off down the garden path.+        when (spinCount > maxSpinCount)+         $ pprPanic "regAlloc_spin: max build/spill cycle count exceeded."+           (  text "It looks like the register allocator is stuck in an infinite loop."+           $$ text "max cycles  = " <> int maxSpinCount+           $$ text "regsFree    = " <> (hcat $ punctuate space $ map ppr+                                             $ nonDetEltsUniqSet $ unionManyUniqSets+                                             $ nonDetEltsUFM regsFree)+              -- This is non-deterministic but we do not+              -- currently support deterministic code-generation.+              -- See Note [Unique Determinism and code generation]+           $$ text "slotsFree   = " <> ppr (sizeUniqSet slotsFree))++        -- Build the register conflict graph from the cmm code.+        (graph  :: Color.Graph VirtualReg RegClass RealReg)+                <- {-# SCC "BuildGraph" #-} buildGraph code++        -- VERY IMPORTANT:+        --   We really do want the graph to be fully evaluated _before_ we+        --   start coloring. If we don't do this now then when the call to+        --   Color.colorGraph forces bits of it, the heap will be filled with+        --   half evaluated pieces of graph and zillions of apply thunks.+        seqGraph graph `seq` return ()++        -- Build a map of the cost of spilling each instruction.+        -- This is a lazy binding, so the map will only be computed if we+        -- actually have to spill to the stack.+        let spillCosts  = foldl' plusSpillCostInfo zeroSpillCostInfo+                        $ map (slurpSpillCostInfo platform) code++        -- The function to choose regs to leave uncolored.+        let spill       = chooseSpill spillCosts++        -- Record startup state in our log.+        let stat1+             = if spinCount == 0+                 then   Just $ RegAllocStatsStart+                        { raLiveCmm     = code+                        , raGraph       = graph+                        , raSpillCosts  = spillCosts }+                 else   Nothing++        -- Try and color the graph.+        let (graph_colored, rsSpill, rmCoalesce)+                = {-# SCC "ColorGraph" #-}+                  Color.colorGraph+                       (gopt Opt_RegsIterative dflags)+                       spinCount+                       regsFree triv spill graph++        -- Rewrite registers in the code that have been coalesced.+        let patchF reg+                | RegVirtual vr <- reg+                = case lookupUFM rmCoalesce vr of+                        Just vr'        -> patchF (RegVirtual vr')+                        Nothing         -> reg++                | otherwise+                = reg++        let code_coalesced+                = map (patchEraseLive patchF) code++        -- Check whether we've found a coloring.+        if isEmptyUniqSet rsSpill++         -- Coloring was successful because no registers needed to be spilled.+         then do+                -- if -fasm-lint is turned on then validate the graph.+                -- This checks for bugs in the graph allocator itself.+                let graph_colored_lint  =+                        if gopt Opt_DoAsmLinting dflags+                                then Color.validateGraph (text "")+                                        True    -- Require all nodes to be colored.+                                        graph_colored+                                else graph_colored++                -- Rewrite the code to use real hregs, using the colored graph.+                let code_patched+                        = map (patchRegsFromGraph platform graph_colored_lint)+                              code_coalesced++                -- Clean out unneeded SPILL/RELOAD meta instructions.+                --   The spill code generator just spills the entire live range+                --   of a vreg, but it might not need to be on the stack for+                --   its entire lifetime.+                let code_spillclean+                        = map (cleanSpills platform) code_patched++                -- Strip off liveness information from the allocated code.+                -- Also rewrite SPILL/RELOAD meta instructions into real machine+                -- instructions along the way+                let code_final+                        = map (stripLive dflags) code_spillclean++                -- Record what happened in this stage for debugging+                let stat+                     =  RegAllocStatsColored+                        { raCode                = code+                        , raGraph               = graph+                        , raGraphColored        = graph_colored_lint+                        , raCoalesced           = rmCoalesce+                        , raCodeCoalesced       = code_coalesced+                        , raPatched             = code_patched+                        , raSpillClean          = code_spillclean+                        , raFinal               = code_final+                        , raSRMs                = foldl' addSRM (0, 0, 0)+                                                $ map countSRMs code_spillclean }++                -- Bundle up all the register allocator statistics.+                --   .. but make sure to drop them on the floor if they're not+                --      needed, otherwise we'll get a space leak.+                let statList =+                        if dump then [stat] ++ maybeToList stat1 ++ debug_codeGraphs+                                else []++                -- Ensure all the statistics are evaluated, to avoid space leaks.+                seqList statList (return ())++                return  ( code_final+                        , statList+                        , graph_colored_lint)++         -- Coloring was unsuccessful. We need to spill some register to the+         -- stack, make a new graph, and try to color it again.+         else do+                -- if -fasm-lint is turned on then validate the graph+                let graph_colored_lint  =+                        if gopt Opt_DoAsmLinting dflags+                                then Color.validateGraph (text "")+                                        False   -- don't require nodes to be colored+                                        graph_colored+                                else graph_colored++                -- Spill uncolored regs to the stack.+                (code_spilled, slotsFree', spillStats)+                        <- regSpill platform code_coalesced slotsFree rsSpill++                -- Recalculate liveness information.+                -- NOTE: we have to reverse the SCCs here to get them back into+                --       the reverse-dependency order required by computeLiveness.+                --       If they're not in the correct order that function will panic.+                code_relive     <- mapM (regLiveness platform . reverseBlocksInTops)+                                        code_spilled++                -- Record what happened in this stage for debugging.+                let stat        =+                        RegAllocStatsSpill+                        { raCode        = code+                        , raGraph       = graph_colored_lint+                        , raCoalesced   = rmCoalesce+                        , raSpillStats  = spillStats+                        , raSpillCosts  = spillCosts+                        , raSpilled     = code_spilled }++                -- Bundle up all the register allocator statistics.+                --   .. but make sure to drop them on the floor if they're not+                --      needed, otherwise we'll get a space leak.+                let statList =+                        if dump+                                then [stat] ++ maybeToList stat1 ++ debug_codeGraphs+                                else []++                -- Ensure all the statistics are evaluated, to avoid space leaks.+                seqList statList (return ())++                regAlloc_spin dflags (spinCount + 1) triv regsFree slotsFree'+                        statList+                        code_relive+++-- | Build a graph from the liveness and coalesce information in this code.+buildGraph+        :: Instruction instr+        => [LiveCmmDecl statics instr]+        -> UniqSM (Color.Graph VirtualReg RegClass RealReg)++buildGraph code+ = do+        -- Slurp out the conflicts and reg->reg moves from this code.+        let (conflictList, moveList) =+                unzip $ map slurpConflicts code++        -- Slurp out the spill/reload coalesces.+        let moveList2           = map slurpReloadCoalesce code++        -- Add the reg-reg conflicts to the graph.+        let conflictBag         = unionManyBags conflictList+        let graph_conflict+                = foldrBag graphAddConflictSet Color.initGraph conflictBag++        -- Add the coalescences edges to the graph.+        let moveBag+                = unionBags (unionManyBags moveList2)+                            (unionManyBags moveList)++        let graph_coalesce+                = foldrBag graphAddCoalesce graph_conflict moveBag++        return  graph_coalesce+++-- | Add some conflict edges to the graph.+--   Conflicts between virtual and real regs are recorded as exclusions.+graphAddConflictSet+        :: UniqSet Reg+        -> Color.Graph VirtualReg RegClass RealReg+        -> Color.Graph VirtualReg RegClass RealReg++graphAddConflictSet set graph+ = let  virtuals        = mkUniqSet+                        [ vr | RegVirtual vr <- nonDetEltsUniqSet set ]++        graph1  = Color.addConflicts virtuals classOfVirtualReg graph++        graph2  = foldr (\(r1, r2) -> Color.addExclusion r1 classOfVirtualReg r2)+                        graph1+                        [ (vr, rr)+                                | RegVirtual vr <- nonDetEltsUniqSet set+                                , RegReal    rr <- nonDetEltsUniqSet set]+                          -- See Note [Unique Determinism and code generation]++   in   graph2+++-- | Add some coalesence edges to the graph+--   Coalesences between virtual and real regs are recorded as preferences.+graphAddCoalesce+        :: (Reg, Reg)+        -> Color.Graph VirtualReg RegClass RealReg+        -> Color.Graph VirtualReg RegClass RealReg++graphAddCoalesce (r1, r2) graph+        | RegReal rr            <- r1+        , RegVirtual vr         <- r2+        = Color.addPreference (vr, classOfVirtualReg vr) rr graph++        | RegReal rr            <- r2+        , RegVirtual vr         <- r1+        = Color.addPreference (vr, classOfVirtualReg vr) rr graph++        | RegVirtual vr1        <- r1+        , RegVirtual vr2        <- r2+        = Color.addCoalesce+                (vr1, classOfVirtualReg vr1)+                (vr2, classOfVirtualReg vr2)+                graph++        -- We can't coalesce two real regs, but there could well be existing+        --      hreg,hreg moves in the input code. We'll just ignore these+        --      for coalescing purposes.+        | RegReal _             <- r1+        , RegReal _             <- r2+        = graph++        | otherwise+        = panic "graphAddCoalesce"+++-- | Patch registers in code using the reg -> reg mapping in this graph.+patchRegsFromGraph+        :: (Outputable statics, Outputable instr, Instruction instr)+        => Platform -> Color.Graph VirtualReg RegClass RealReg+        -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr++patchRegsFromGraph platform graph code+ = patchEraseLive patchF code+ where+        -- Function to lookup the hardreg for a virtual reg from the graph.+        patchF reg+                -- leave real regs alone.+                | RegReal{}     <- reg+                = reg++                -- this virtual has a regular node in the graph.+                | RegVirtual vr <- reg+                , Just node     <- Color.lookupNode graph vr+                = case Color.nodeColor node of+                        Just color      -> RegReal    color+                        Nothing         -> RegVirtual vr++                -- no node in the graph for this virtual, bad news.+                | otherwise+                = pprPanic "patchRegsFromGraph: register mapping failed."+                        (  text "There is no node in the graph for register "+                                <> ppr reg+                        $$ ppr code+                        $$ Color.dotGraph+                                (\_ -> text "white")+                                (trivColorable platform+                                        (targetVirtualRegSqueeze platform)+                                        (targetRealRegSqueeze platform))+                                graph)+++-----+-- for when laziness just isn't what you wanted...+--  We need to deepSeq the whole graph before trying to colour it to avoid+--  space leaks.+seqGraph :: Color.Graph VirtualReg RegClass RealReg -> ()+seqGraph graph          = seqNodes (nonDetEltsUFM (Color.graphMap graph))+   -- See Note [Unique Determinism and code generation]++seqNodes :: [Color.Node VirtualReg RegClass RealReg] -> ()+seqNodes ns+ = case ns of+        []              -> ()+        (n : ns)        -> seqNode n `seq` seqNodes ns++seqNode :: Color.Node VirtualReg RegClass RealReg -> ()+seqNode node+        =     seqVirtualReg     (Color.nodeId node)+        `seq` seqRegClass       (Color.nodeClass node)+        `seq` seqMaybeRealReg   (Color.nodeColor node)+        `seq` (seqVirtualRegList (nonDetEltsUniqSet (Color.nodeConflicts node)))+        `seq` (seqRealRegList    (nonDetEltsUniqSet (Color.nodeExclusions node)))+        `seq` (seqRealRegList (Color.nodePreference node))+        `seq` (seqVirtualRegList (nonDetEltsUniqSet (Color.nodeCoalesce node)))+              -- It's OK to use nonDetEltsUniqSet for seq++seqVirtualReg :: VirtualReg -> ()+seqVirtualReg reg = reg `seq` ()++seqRealReg :: RealReg -> ()+seqRealReg reg = reg `seq` ()++seqRegClass :: RegClass -> ()+seqRegClass c = c `seq` ()++seqMaybeRealReg :: Maybe RealReg -> ()+seqMaybeRealReg mr+ = case mr of+        Nothing         -> ()+        Just r          -> seqRealReg r++seqVirtualRegList :: [VirtualReg] -> ()+seqVirtualRegList rs+ = case rs of+        []              -> ()+        (r : rs)        -> seqVirtualReg r `seq` seqVirtualRegList rs++seqRealRegList :: [RealReg] -> ()+seqRealRegList rs+ = case rs of+        []              -> ()+        (r : rs)        -> seqRealReg r `seq` seqRealRegList rs
+ nativeGen/RegAlloc/Graph/Spill.hs view
@@ -0,0 +1,379 @@++-- | When there aren't enough registers to hold all the vregs we have to spill+--   some of those vregs to slots on the stack. This module is used modify the+--   code to use those slots.+module RegAlloc.Graph.Spill (+        regSpill,+        SpillStats(..),+        accSpillSL+) where+import RegAlloc.Liveness+import Instruction+import Reg+import Cmm hiding (RegSet)+import BlockId+import Hoopl++import MonadUtils+import State+import Unique+import UniqFM+import UniqSet+import UniqSupply+import Outputable+import Platform++import Data.List+import Data.Maybe+import Data.IntSet              (IntSet)+import qualified Data.IntSet    as IntSet+++-- | Spill all these virtual regs to stack slots.+--+--   TODO: See if we can split some of the live ranges instead of just globally+--         spilling the virtual reg. This might make the spill cleaner's job easier.+--+--   TODO: On CISCy x86 and x86_64 we don't nessesarally have to add a mov instruction+--         when making spills. If an instr is using a spilled virtual we may be able to+--         address the spill slot directly.+--+regSpill+        :: Instruction instr+        => Platform+        -> [LiveCmmDecl statics instr]  -- ^ the code+        -> UniqSet Int                  -- ^ available stack slots+        -> UniqSet VirtualReg           -- ^ the regs to spill+        -> UniqSM+            ([LiveCmmDecl statics instr]+                 -- code with SPILL and RELOAD meta instructions added.+            , UniqSet Int               -- left over slots+            , SpillStats )              -- stats about what happened during spilling++regSpill platform code slotsFree regs++        -- Not enough slots to spill these regs.+        | sizeUniqSet slotsFree < sizeUniqSet regs+        = pprPanic "regSpill: out of spill slots!"+                (  text "   regs to spill = " <> ppr (sizeUniqSet regs)+                $$ text "   slots left    = " <> ppr (sizeUniqSet slotsFree))++        | otherwise+        = do+                -- Allocate a slot for each of the spilled regs.+                let slots       = take (sizeUniqSet regs) $ nonDetEltsUniqSet slotsFree+                let regSlotMap  = listToUFM+                                $ zip (nonDetEltsUniqSet regs) slots+                    -- This is non-deterministic but we do not+                    -- currently support deterministic code-generation.+                    -- See Note [Unique Determinism and code generation]++                -- Grab the unique supply from the monad.+                us      <- getUniqueSupplyM++                -- Run the spiller on all the blocks.+                let (code', state')     =+                        runState (mapM (regSpill_top platform regSlotMap) code)+                                 (initSpillS us)++                return  ( code'+                        , minusUniqSet slotsFree (mkUniqSet slots)+                        , makeSpillStats state')+++-- | Spill some registers to stack slots in a top-level thing.+regSpill_top+        :: Instruction instr+        => Platform+        -> RegMap Int+                -- ^ map of vregs to slots they're being spilled to.+        -> LiveCmmDecl statics instr+                -- ^ the top level thing.+        -> SpillM (LiveCmmDecl statics instr)++regSpill_top platform regSlotMap cmm+ = case cmm of+        CmmData{}+         -> return cmm++        CmmProc info label live sccs+         |  LiveInfo static firstId mLiveVRegsOnEntry liveSlotsOnEntry <- info+         -> do+                -- We should only passed Cmms with the liveness maps filled in,+                -- but we'll create empty ones if they're not there just in case.+                let liveVRegsOnEntry    = fromMaybe mapEmpty mLiveVRegsOnEntry++                -- The liveVRegsOnEntry contains the set of vregs that are live+                -- on entry to each basic block. If we spill one of those vregs+                -- we remove it from that set and add the corresponding slot+                -- number to the liveSlotsOnEntry set. The spill cleaner needs+                -- this information to erase unneeded spill and reload instructions+                -- after we've done a successful allocation.+                let liveSlotsOnEntry' :: BlockMap IntSet+                    liveSlotsOnEntry'+                        = mapFoldWithKey patchLiveSlot+                                         liveSlotsOnEntry liveVRegsOnEntry++                let info'+                        = LiveInfo static firstId+                                (Just liveVRegsOnEntry)+                                liveSlotsOnEntry'++                -- Apply the spiller to all the basic blocks in the CmmProc.+                sccs'   <- mapM (mapSCCM (regSpill_block platform regSlotMap)) sccs++                return  $ CmmProc info' label live sccs'++ where  -- Given a BlockId and the set of registers live in it,+        -- if registers in this block are being spilled to stack slots,+        -- then record the fact that these slots are now live in those blocks+        -- in the given slotmap.+        patchLiveSlot+                :: BlockId -> RegSet+                -> BlockMap IntSet -> BlockMap IntSet++        patchLiveSlot blockId regsLive slotMap+         = let+                -- Slots that are already recorded as being live.+                curSlotsLive    = fromMaybe IntSet.empty+                                $ mapLookup blockId slotMap++                moreSlotsLive   = IntSet.fromList+                                $ catMaybes+                                $ map (lookupUFM regSlotMap)+                                $ nonDetEltsUniqSet regsLive+                    -- See Note [Unique Determinism and code generation]++                slotMap'+                 = mapInsert blockId (IntSet.union curSlotsLive moreSlotsLive)+                             slotMap++           in   slotMap'+++-- | Spill some registers to stack slots in a basic block.+regSpill_block+        :: Instruction instr+        => Platform+        -> UniqFM Int   -- ^ map of vregs to slots they're being spilled to.+        -> LiveBasicBlock instr+        -> SpillM (LiveBasicBlock instr)++regSpill_block platform regSlotMap (BasicBlock i instrs)+ = do   instrss'        <- mapM (regSpill_instr platform regSlotMap) instrs+        return  $ BasicBlock i (concat instrss')+++-- | Spill some registers to stack slots in a single instruction.+--   If the instruction uses registers that need to be spilled, then it is+--   prefixed (or postfixed) with the appropriate RELOAD or SPILL meta+--   instructions.+regSpill_instr+        :: Instruction instr+        => Platform+        -> UniqFM Int -- ^ map of vregs to slots they're being spilled to.+        -> LiveInstr instr+        -> SpillM [LiveInstr instr]++regSpill_instr _ _ li@(LiveInstr _ Nothing)+ = do   return [li]++regSpill_instr platform regSlotMap+        (LiveInstr instr (Just _))+ = do+        -- work out which regs are read and written in this instr+        let RU rlRead rlWritten = regUsageOfInstr platform instr++        -- sometimes a register is listed as being read more than once,+        --      nub this so we don't end up inserting two lots of spill code.+        let rsRead_             = nub rlRead+        let rsWritten_          = nub rlWritten++        -- if a reg is modified, it appears in both lists, want to undo this..+        let rsRead              = rsRead_    \\ rsWritten_+        let rsWritten           = rsWritten_ \\ rsRead_+        let rsModify            = intersect rsRead_ rsWritten_++        -- work out if any of the regs being used are currently being spilled.+        let rsSpillRead         = filter (\r -> elemUFM r regSlotMap) rsRead+        let rsSpillWritten      = filter (\r -> elemUFM r regSlotMap) rsWritten+        let rsSpillModify       = filter (\r -> elemUFM r regSlotMap) rsModify++        -- rewrite the instr and work out spill code.+        (instr1, prepost1)      <- mapAccumLM (spillRead   regSlotMap) instr  rsSpillRead+        (instr2, prepost2)      <- mapAccumLM (spillWrite  regSlotMap) instr1 rsSpillWritten+        (instr3, prepost3)      <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify++        let (mPrefixes, mPostfixes)     = unzip (prepost1 ++ prepost2 ++ prepost3)+        let prefixes                    = concat mPrefixes+        let postfixes                   = concat mPostfixes++        -- final code+        let instrs'     =  prefixes+                        ++ [LiveInstr instr3 Nothing]+                        ++ postfixes++        return $ instrs'+++-- | Add a RELOAD met a instruction to load a value for an instruction that+--   writes to a vreg that is being spilled.+spillRead+        :: Instruction instr+        => UniqFM Int+        -> instr+        -> Reg+        -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))++spillRead regSlotMap instr reg+ | Just slot     <- lookupUFM regSlotMap reg+ = do    (instr', nReg)  <- patchInstr reg instr++         modify $ \s -> s+                { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) }++         return  ( instr'+                 , ( [LiveInstr (RELOAD slot nReg) Nothing]+                 , []) )++ | otherwise     = panic "RegSpill.spillRead: no slot defined for spilled reg"+++-- | Add a SPILL meta instruction to store a value for an instruction that+--   writes to a vreg that is being spilled.+spillWrite+        :: Instruction instr+        => UniqFM Int+        -> instr+        -> Reg+        -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))++spillWrite regSlotMap instr reg+ | Just slot     <- lookupUFM regSlotMap reg+ = do    (instr', nReg)  <- patchInstr reg instr++         modify $ \s -> s+                { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) }++         return  ( instr'+                 , ( []+                   , [LiveInstr (SPILL nReg slot) Nothing]))++ | otherwise     = panic "RegSpill.spillWrite: no slot defined for spilled reg"+++-- | Add both RELOAD and SPILL meta instructions for an instruction that+--   both reads and writes to a vreg that is being spilled.+spillModify+        :: Instruction instr+        => UniqFM Int+        -> instr+        -> Reg+        -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))++spillModify regSlotMap instr reg+ | Just slot     <- lookupUFM regSlotMap reg+ = do    (instr', nReg)  <- patchInstr reg instr++         modify $ \s -> s+                { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) }++         return  ( instr'+                 , ( [LiveInstr (RELOAD slot nReg) Nothing]+                   , [LiveInstr (SPILL nReg slot) Nothing]))++ | otherwise     = panic "RegSpill.spillModify: no slot defined for spilled reg"+++-- | Rewrite uses of this virtual reg in an instr to use a different+--   virtual reg.+patchInstr+        :: Instruction instr+        => Reg -> instr -> SpillM (instr, Reg)++patchInstr reg instr+ = do   nUnique         <- newUnique++        -- The register we're rewriting is suppoed to be virtual.+        -- If it's not then something has gone horribly wrong.+        let nReg+             = case reg of+                RegVirtual vr+                 -> RegVirtual (renameVirtualReg nUnique vr)++                RegReal{}+                 -> panic "RegAlloc.Graph.Spill.patchIntr: not patching real reg"++        let instr'      = patchReg1 reg nReg instr+        return          (instr', nReg)+++patchReg1+        :: Instruction instr+        => Reg -> Reg -> instr -> instr++patchReg1 old new instr+ = let  patchF r+                | r == old      = new+                | otherwise     = r+   in   patchRegsOfInstr instr patchF+++-- Spiller monad --------------------------------------------------------------+-- | State monad for the spill code generator.+type SpillM a+        = State SpillS a++-- | Spill code generator state.+data SpillS+        = SpillS+        { -- | Unique supply for generating fresh vregs.+          stateUS       :: UniqSupply++          -- | Spilled vreg vs the number of times it was loaded, stored.+        , stateSpillSL  :: UniqFM (Reg, Int, Int) }+++-- | Create a new spiller state.+initSpillS :: UniqSupply -> SpillS+initSpillS uniqueSupply+        = SpillS+        { stateUS       = uniqueSupply+        , stateSpillSL  = emptyUFM }+++-- | Allocate a new unique in the spiller monad.+newUnique :: SpillM Unique+newUnique+ = do   us      <- gets stateUS+        case takeUniqFromSupply us of+         (uniq, us')+          -> do modify $ \s -> s { stateUS = us' }+                return uniq+++-- | Add a spill/reload count to a stats record for a register.+accSpillSL :: (Reg, Int, Int) -> (Reg, Int, Int) -> (Reg, Int, Int)+accSpillSL (r1, s1, l1) (_, s2, l2)+        = (r1, s1 + s2, l1 + l2)+++-- Spiller stats --------------------------------------------------------------+-- | Spiller statistics.+--   Tells us what registers were spilled.+data SpillStats+        = SpillStats+        { spillStoreLoad        :: UniqFM (Reg, Int, Int) }+++-- | Extract spiller statistics from the spiller state.+makeSpillStats :: SpillS -> SpillStats+makeSpillStats s+        = SpillStats+        { spillStoreLoad        = stateSpillSL s }+++instance Outputable SpillStats where+ ppr stats+        = pprUFM (spillStoreLoad stats)+                 (vcat . map (\(r, s, l) -> ppr r <+> int s <+> int l))
+ nativeGen/RegAlloc/Graph/SpillClean.hs view
@@ -0,0 +1,612 @@++-- | Clean out unneeded spill\/reload instructions.+--+--   Handling of join points+--   ~~~~~~~~~~~~~~~~~~~~~~~+--+--   B1:                          B2:+--    ...                          ...+--       RELOAD SLOT(0), %r1          RELOAD SLOT(0), %r1+--       ... A ...                    ... B ...+--       jump B3                      jump B3+--+--                B3: ... C ...+--                    RELOAD SLOT(0), %r1+--                    ...+--+--   The Plan+--   ~~~~~~~~+--   As long as %r1 hasn't been written to in A, B or C then we don't need+--   the reload in B3.+--+--   What we really care about here is that on the entry to B3, %r1 will+--   always have the same value that is in SLOT(0) (ie, %r1 is _valid_)+--+--   This also works if the reloads in B1\/B2 were spills instead, because+--   spilling %r1 to a slot makes that slot have the same value as %r1.+--+module RegAlloc.Graph.SpillClean (+        cleanSpills+) where+import RegAlloc.Liveness+import Instruction+import Reg++import BlockId+import Hoopl+import Cmm+import UniqSet+import UniqFM+import Unique+import State+import Outputable+import Platform++import Data.List+import Data.Maybe+import Data.IntSet              (IntSet)+import qualified Data.IntSet    as IntSet+++-- | The identification number of a spill slot.+--   A value is stored in a spill slot when we don't have a free+--   register to hold it.+type Slot = Int+++-- | Clean out unneeded spill\/reloads from this top level thing.+cleanSpills+        :: Instruction instr+        => Platform+        -> LiveCmmDecl statics instr+        -> LiveCmmDecl statics instr++cleanSpills platform cmm+        = evalState (cleanSpin platform 0 cmm) initCleanS+++-- | Do one pass of cleaning.+cleanSpin+        :: Instruction instr+        => Platform+        -> Int                              -- ^ Iteration number for the cleaner.+        -> LiveCmmDecl statics instr        -- ^ Liveness annotated code to clean.+        -> CleanM (LiveCmmDecl statics instr)++cleanSpin platform spinCount code+ = do+        -- Initialise count of cleaned spill and reload instructions.+        modify $ \s -> s+                { sCleanedSpillsAcc     = 0+                , sCleanedReloadsAcc    = 0+                , sReloadedBy           = emptyUFM }++        code_forward    <- mapBlockTopM (cleanBlockForward platform) code+        code_backward   <- cleanTopBackward code_forward++        -- During the cleaning of each block we collected information about+        -- what regs were valid across each jump. Based on this, work out+        -- whether it will be safe to erase reloads after join points for+        -- the next pass.+        collateJoinPoints++        -- Remember how many spill and reload instructions we cleaned in this pass.+        spills          <- gets sCleanedSpillsAcc+        reloads         <- gets sCleanedReloadsAcc+        modify $ \s -> s+                { sCleanedCount = (spills, reloads) : sCleanedCount s }++        -- If nothing was cleaned in this pass or the last one+        --      then we're done and it's time to bail out.+        cleanedCount    <- gets sCleanedCount+        if take 2 cleanedCount == [(0, 0), (0, 0)]+           then return code++        -- otherwise go around again+           else cleanSpin platform (spinCount + 1) code_backward+++-------------------------------------------------------------------------------+-- | Clean out unneeded reload instructions,+--   while walking forward over the code.+cleanBlockForward+        :: Instruction instr+        => Platform+        -> LiveBasicBlock instr+        -> CleanM (LiveBasicBlock instr)++cleanBlockForward platform (BasicBlock blockId instrs)+ = do+        -- See if we have a valid association for the entry to this block.+        jumpValid       <- gets sJumpValid+        let assoc       = case lookupUFM jumpValid blockId of+                                Just assoc      -> assoc+                                Nothing         -> emptyAssoc++        instrs_reload   <- cleanForward platform blockId assoc [] instrs+        return  $ BasicBlock blockId instrs_reload++++-- | Clean out unneeded reload instructions.+--+--   Walking forwards across the code+--     On a reload, if we know a reg already has the same value as a slot+--     then we don't need to do the reload.+--+cleanForward+        :: Instruction instr+        => Platform+        -> BlockId                  -- ^ the block that we're currently in+        -> Assoc Store              -- ^ two store locations are associated if+                                    --     they have the same value+        -> [LiveInstr instr]        -- ^ acc+        -> [LiveInstr instr]        -- ^ instrs to clean (in backwards order)+        -> CleanM [LiveInstr instr] -- ^ cleaned instrs  (in forward   order)++cleanForward _ _ _ acc []+        = return acc++-- Rewrite live range joins via spill slots to just a spill and a reg-reg move+-- hopefully the spill will be also be cleaned in the next pass+cleanForward platform blockId assoc acc (li1 : li2 : instrs)++        | LiveInstr (SPILL  reg1  slot1) _      <- li1+        , LiveInstr (RELOAD slot2 reg2)  _      <- li2+        , slot1 == slot2+        = do+                modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }+                cleanForward platform blockId assoc acc+                 $ li1 : LiveInstr (mkRegRegMoveInstr platform reg1 reg2) Nothing+                       : instrs++cleanForward platform blockId assoc acc (li@(LiveInstr i1 _) : instrs)+        | Just (r1, r2) <- takeRegRegMoveInstr i1+        = if r1 == r2+                -- Erase any left over nop reg reg moves while we're here+                -- this will also catch any nop moves that the previous case+                -- happens to add.+                then cleanForward platform blockId assoc acc instrs++                -- If r1 has the same value as some slots and we copy r1 to r2,+                --      then r2 is now associated with those slots instead+                else do let assoc'      = addAssoc (SReg r1) (SReg r2)+                                        $ delAssoc (SReg r2)+                                        $ assoc++                        cleanForward platform blockId assoc' (li : acc) instrs+++cleanForward platform blockId assoc acc (li : instrs)++        -- Update association due to the spill.+        | LiveInstr (SPILL reg slot) _  <- li+        = let   assoc'  = addAssoc (SReg reg)  (SSlot slot)+                        $ delAssoc (SSlot slot)+                        $ assoc+          in    cleanForward platform blockId assoc' (li : acc) instrs++        -- Clean a reload instr.+        | LiveInstr (RELOAD{}) _        <- li+        = do    (assoc', mli)   <- cleanReload platform blockId assoc li+                case mli of+                 Nothing        -> cleanForward platform blockId assoc' acc+                                                instrs++                 Just li'       -> cleanForward platform blockId assoc' (li' : acc)+                                                instrs++        -- Remember the association over a jump.+        | LiveInstr instr _     <- li+        , targets               <- jumpDestsOfInstr instr+        , not $ null targets+        = do    mapM_ (accJumpValid assoc) targets+                cleanForward platform blockId assoc (li : acc) instrs++        -- Writing to a reg changes its value.+        | LiveInstr instr _     <- li+        , RU _ written          <- regUsageOfInstr platform instr+        = let assoc'    = foldr delAssoc assoc (map SReg $ nub written)+          in  cleanForward platform blockId assoc' (li : acc) instrs++++-- | Try and rewrite a reload instruction to something more pleasing+cleanReload+        :: Instruction instr+        => Platform+        -> BlockId+        -> Assoc Store+        -> LiveInstr instr+        -> CleanM (Assoc Store, Maybe (LiveInstr instr))++cleanReload platform blockId assoc li@(LiveInstr (RELOAD slot reg) _)++        -- If the reg we're reloading already has the same value as the slot+        --      then we can erase the instruction outright.+        | elemAssoc (SSlot slot) (SReg reg) assoc+        = do    modify  $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }+                return  (assoc, Nothing)++        -- If we can find another reg with the same value as this slot then+        --      do a move instead of a reload.+        | Just reg2     <- findRegOfSlot assoc slot+        = do    modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }++                let assoc'      = addAssoc (SReg reg) (SReg reg2)+                                $ delAssoc (SReg reg)+                                $ assoc++                return  ( assoc'+                        , Just $ LiveInstr (mkRegRegMoveInstr platform reg2 reg) Nothing)++        -- Gotta keep this instr.+        | otherwise+        = do    -- Update the association.+                let assoc'+                        = addAssoc (SReg reg)  (SSlot slot)+                                -- doing the reload makes reg and slot the same value+                        $ delAssoc (SReg reg)+                                -- reg value changes on reload+                        $ assoc++                -- Remember that this block reloads from this slot.+                accBlockReloadsSlot blockId slot++                return  (assoc', Just li)++cleanReload _ _ _ _+        = panic "RegSpillClean.cleanReload: unhandled instr"+++-------------------------------------------------------------------------------+-- | Clean out unneeded spill instructions,+--   while walking backwards over the code.+--+--      If there were no reloads from a slot between a spill and the last one+--      then the slot was never read and we don't need the spill.+--+--      SPILL   r0 -> s1+--      RELOAD  s1 -> r2+--      SPILL   r3 -> s1        <--- don't need this spill+--      SPILL   r4 -> s1+--      RELOAD  s1 -> r5+--+--      Maintain a set of+--              "slots which were spilled to but not reloaded from yet"+--+--      Walking backwards across the code:+--       a) On a reload from a slot, remove it from the set.+--+--       a) On a spill from a slot+--              If the slot is in set then we can erase the spill,+--               because it won't be reloaded from until after the next spill.+--+--              otherwise+--               keep the spill and add the slot to the set+--+-- TODO: This is mostly inter-block+--       we should really be updating the noReloads set as we cross jumps also.+--+-- TODO: generate noReloads from liveSlotsOnEntry+--+cleanTopBackward+        :: Instruction instr+        => LiveCmmDecl statics instr+        -> CleanM (LiveCmmDecl statics instr)++cleanTopBackward cmm+ = case cmm of+        CmmData{}+         -> return cmm++        CmmProc info label live sccs+         | LiveInfo _ _ _ liveSlotsOnEntry <- info+         -> do  sccs'   <- mapM (mapSCCM (cleanBlockBackward liveSlotsOnEntry)) sccs+                return  $ CmmProc info label live sccs'+++cleanBlockBackward+        :: Instruction instr+        => BlockMap IntSet+        -> LiveBasicBlock instr+        -> CleanM (LiveBasicBlock instr)++cleanBlockBackward liveSlotsOnEntry (BasicBlock blockId instrs)+ = do   instrs_spill    <- cleanBackward liveSlotsOnEntry  emptyUniqSet  [] instrs+        return  $ BasicBlock blockId instrs_spill++++cleanBackward+        :: Instruction instr+        => BlockMap IntSet          -- ^ Slots live on entry to each block+        -> UniqSet Int              -- ^ Slots that have been spilled, but not reloaded from+        -> [LiveInstr instr]        -- ^ acc+        -> [LiveInstr instr]        -- ^ Instrs to clean (in forwards order)+        -> CleanM [LiveInstr instr] -- ^ Cleaned instrs  (in backwards order)++cleanBackward liveSlotsOnEntry noReloads acc lis+ = do   reloadedBy      <- gets sReloadedBy+        cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc lis+++cleanBackward'+        :: Instruction instr+        => BlockMap IntSet+        -> UniqFM [BlockId]+        -> UniqSet Int+        -> [LiveInstr instr]+        -> [LiveInstr instr]+        -> State CleanS [LiveInstr instr]++cleanBackward' _ _ _      acc []+        = return  acc++cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc (li : instrs)++        -- If nothing ever reloads from this slot then we don't need the spill.+        | LiveInstr (SPILL _ slot) _    <- li+        , Nothing       <- lookupUFM reloadedBy (SSlot slot)+        = do    modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 }+                cleanBackward liveSlotsOnEntry noReloads acc instrs++        | LiveInstr (SPILL _ slot) _    <- li+        = if elementOfUniqSet slot noReloads++           -- We can erase this spill because the slot won't be read until+           -- after the next one+           then do+                modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 }+                cleanBackward liveSlotsOnEntry noReloads acc instrs++           else do+                -- This slot is being spilled to, but we haven't seen any reloads yet.+                let noReloads'  = addOneToUniqSet noReloads slot+                cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs++        -- if we reload from a slot then it's no longer unused+        | LiveInstr (RELOAD slot _) _   <- li+        , noReloads'            <- delOneFromUniqSet noReloads slot+        = cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs++        -- If a slot is live in a jump target then assume it's reloaded there.+        --+        -- TODO: A real dataflow analysis would do a better job here.+        --       If the target block _ever_ used the slot then we assume+        --       it always does, but if those reloads are cleaned the slot+        --       liveness map doesn't get updated.+        | LiveInstr instr _     <- li+        , targets               <- jumpDestsOfInstr instr+        = do+                let slotsReloadedByTargets+                        = IntSet.unions+                        $ catMaybes+                        $ map (flip mapLookup liveSlotsOnEntry)+                        $ targets++                let noReloads'+                        = foldl' delOneFromUniqSet noReloads+                        $ IntSet.toList slotsReloadedByTargets++                cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs++        -- some other instruction+        | otherwise+        = cleanBackward liveSlotsOnEntry noReloads (li : acc) instrs+++-- | Combine the associations from all the inward control flow edges.+--+collateJoinPoints :: CleanM ()+collateJoinPoints+ = modify $ \s -> s+        { sJumpValid    = mapUFM intersects (sJumpValidAcc s)+        , sJumpValidAcc = emptyUFM }++intersects :: [Assoc Store]     -> Assoc Store+intersects []           = emptyAssoc+intersects assocs       = foldl1' intersectAssoc assocs+++-- | See if we have a reg with the same value as this slot in the association table.+findRegOfSlot :: Assoc Store -> Int -> Maybe Reg+findRegOfSlot assoc slot+        | close                 <- closeAssoc (SSlot slot) assoc+        , Just (SReg reg)       <- find isStoreReg $ nonDetEltsUniqSet close+           -- See Note [Unique Determinism and code generation]+        = Just reg++        | otherwise+        = Nothing+++-------------------------------------------------------------------------------+-- | Cleaner monad.+type CleanM+        = State CleanS++-- | Cleaner state.+data CleanS+        = CleanS+        { -- | Regs which are valid at the start of each block.+          sJumpValid            :: UniqFM (Assoc Store)++          -- | Collecting up what regs were valid across each jump.+          --    in the next pass we can collate these and write the results+          --    to sJumpValid.+        , sJumpValidAcc         :: UniqFM [Assoc Store]++          -- | Map of (slot -> blocks which reload from this slot)+          --    used to decide if whether slot spilled to will ever be+          --    reloaded from on this path.+        , sReloadedBy           :: UniqFM [BlockId]++          -- | Spills and reloads cleaned each pass (latest at front)+        , sCleanedCount         :: [(Int, Int)]++          -- | Spills and reloads that have been cleaned in this pass so far.+        , sCleanedSpillsAcc     :: Int+        , sCleanedReloadsAcc    :: Int }+++-- | Construct the initial cleaner state.+initCleanS :: CleanS+initCleanS+        = CleanS+        { sJumpValid            = emptyUFM+        , sJumpValidAcc         = emptyUFM++        , sReloadedBy           = emptyUFM++        , sCleanedCount         = []++        , sCleanedSpillsAcc     = 0+        , sCleanedReloadsAcc    = 0 }+++-- | Remember the associations before a jump.+accJumpValid :: Assoc Store -> BlockId -> CleanM ()+accJumpValid assocs target+ = modify $ \s -> s {+        sJumpValidAcc = addToUFM_C (++)+                                (sJumpValidAcc s)+                                target+                                [assocs] }+++accBlockReloadsSlot :: BlockId -> Slot -> CleanM ()+accBlockReloadsSlot blockId slot+ = modify $ \s -> s {+        sReloadedBy = addToUFM_C (++)+                                (sReloadedBy s)+                                (SSlot slot)+                                [blockId] }+++-------------------------------------------------------------------------------+-- A store location can be a stack slot or a register+data Store+        = SSlot Int+        | SReg  Reg+++-- | Check if this is a reg store.+isStoreReg :: Store -> Bool+isStoreReg ss+ = case ss of+        SSlot _ -> False+        SReg  _ -> True+++-- Spill cleaning is only done once all virtuals have been allocated to realRegs+instance Uniquable Store where+    getUnique (SReg  r)+        | RegReal (RealRegSingle i)     <- r+        = mkRegSingleUnique i++        | RegReal (RealRegPair r1 r2)   <- r+        = mkRegPairUnique (r1 * 65535 + r2)++        | otherwise+        = error $ "RegSpillClean.getUnique: found virtual reg during spill clean,"+                ++ "only real regs expected."++    getUnique (SSlot i) = mkRegSubUnique i    -- [SLPJ] I hope "SubUnique" is ok+++instance Outputable Store where+        ppr (SSlot i)   = text "slot" <> int i+        ppr (SReg  r)   = ppr r+++-------------------------------------------------------------------------------+-- Association graphs.+-- In the spill cleaner, two store locations are associated if they are known+-- to hold the same value.+--+type Assoc a    = UniqFM (UniqSet a)++-- | An empty association+emptyAssoc :: Assoc a+emptyAssoc      = emptyUFM+++-- | Add an association between these two things.+addAssoc :: Uniquable a+         => a -> a -> Assoc a -> Assoc a++addAssoc a b m+ = let  m1      = addToUFM_C unionUniqSets m  a (unitUniqSet b)+        m2      = addToUFM_C unionUniqSets m1 b (unitUniqSet a)+   in   m2+++-- | Delete all associations to a node.+delAssoc :: (Uniquable a)+         => a -> Assoc a -> Assoc a++delAssoc a m+        | Just aSet     <- lookupUFM  m a+        , m1            <- delFromUFM m a+        = nonDetFoldUniqSet (\x m -> delAssoc1 x a m) m1 aSet+          -- It's OK to use nonDetFoldUFM here because deletion is commutative++        | otherwise     = m+++-- | Delete a single association edge (a -> b).+delAssoc1 :: Uniquable a+          => a -> a -> Assoc a -> Assoc a++delAssoc1 a b m+        | Just aSet     <- lookupUFM m a+        = addToUFM m a (delOneFromUniqSet aSet b)++        | otherwise     = m+++-- | Check if these two things are associated.+elemAssoc :: (Uniquable a)+          => a -> a -> Assoc a -> Bool++elemAssoc a b m+        = elementOfUniqSet b (closeAssoc a m)+++-- | Find the refl. trans. closure of the association from this point.+closeAssoc :: (Uniquable a)+        => a -> Assoc a -> UniqSet a++closeAssoc a assoc+ =      closeAssoc' assoc emptyUniqSet (unitUniqSet a)+ where+        closeAssoc' assoc visited toVisit+         = case nonDetEltsUniqSet toVisit of+             -- See Note [Unique Determinism and code generation]++                -- nothing else to visit, we're done+                []      -> visited++                (x:_)+                 -- we've already seen this node+                 |  elementOfUniqSet x visited+                 -> closeAssoc' assoc visited (delOneFromUniqSet toVisit x)++                 -- haven't seen this node before,+                 --     remember to visit all its neighbors+                 |  otherwise+                 -> let neighbors+                         = case lookupUFM assoc x of+                                Nothing         -> emptyUniqSet+                                Just set        -> set++                   in closeAssoc' assoc+                        (addOneToUniqSet visited x)+                        (unionUniqSets   toVisit neighbors)++-- | Intersect two associations.+intersectAssoc :: Assoc a -> Assoc a -> Assoc a+intersectAssoc a b+        = intersectUFM_C (intersectUniqSets) a b+
+ nativeGen/RegAlloc/Graph/SpillCost.hs view
@@ -0,0 +1,291 @@++module RegAlloc.Graph.SpillCost (+        SpillCostRecord,+        plusSpillCostRecord,+        pprSpillCostRecord,++        SpillCostInfo,+        zeroSpillCostInfo,+        plusSpillCostInfo,++        slurpSpillCostInfo,+        chooseSpill,++        lifeMapFromSpillCostInfo+) where+import RegAlloc.Liveness+import Instruction+import RegClass+import Reg++import GraphBase++import Hoopl (mapLookup)+import Cmm+import UniqFM+import UniqSet+import Digraph          (flattenSCCs)+import Outputable+import Platform+import State++import Data.List        (nub, minimumBy)+import Data.Maybe+++-- | Records the expected cost to spill some regster.+type SpillCostRecord+ =      ( VirtualReg    -- register name+        , Int           -- number of writes to this reg+        , Int           -- number of reads from this reg+        , Int)          -- number of instrs this reg was live on entry to+++-- | Map of `SpillCostRecord`+type SpillCostInfo+        = UniqFM SpillCostRecord+++-- | An empty map of spill costs.+zeroSpillCostInfo :: SpillCostInfo+zeroSpillCostInfo       = emptyUFM+++-- | Add two spill cost infos.+plusSpillCostInfo :: SpillCostInfo -> SpillCostInfo -> SpillCostInfo+plusSpillCostInfo sc1 sc2+        = plusUFM_C plusSpillCostRecord sc1 sc2+++-- | Add two spill cost records.+plusSpillCostRecord :: SpillCostRecord -> SpillCostRecord -> SpillCostRecord+plusSpillCostRecord (r1, a1, b1, c1) (r2, a2, b2, c2)+        | r1 == r2      = (r1, a1 + a2, b1 + b2, c1 + c2)+        | otherwise     = error "RegSpillCost.plusRegInt: regs don't match"+++-- | Slurp out information used for determining spill costs.+--+--   For each vreg, the number of times it was written to, read from,+--   and the number of instructions it was live on entry to (lifetime)+--+slurpSpillCostInfo :: (Outputable instr, Instruction instr)+                   => Platform+                   -> LiveCmmDecl statics instr+                   -> SpillCostInfo++slurpSpillCostInfo platform cmm+        = execState (countCmm cmm) zeroSpillCostInfo+ where+        countCmm CmmData{}              = return ()+        countCmm (CmmProc info _ _ sccs)+                = mapM_ (countBlock info)+                $ flattenSCCs sccs++        -- Lookup the regs that are live on entry to this block in+        --      the info table from the CmmProc.+        countBlock info (BasicBlock blockId instrs)+                | LiveInfo _ _ (Just blockLive) _ <- info+                , Just rsLiveEntry  <- mapLookup blockId blockLive+                , rsLiveEntry_virt  <- takeVirtuals rsLiveEntry+                = countLIs rsLiveEntry_virt instrs++                | otherwise+                = error "RegAlloc.SpillCost.slurpSpillCostInfo: bad block"++        countLIs _      []+                = return ()++        -- Skip over comment and delta pseudo instrs.+        countLIs rsLive (LiveInstr instr Nothing : lis)+                | isMetaInstr instr+                = countLIs rsLive lis++                | otherwise+                = pprPanic "RegSpillCost.slurpSpillCostInfo"+                $ text "no liveness information on instruction " <> ppr instr++        countLIs rsLiveEntry (LiveInstr instr (Just live) : lis)+         = do+                -- Increment the lifetime counts for regs live on entry to this instr.+                mapM_ incLifetime $ nonDetEltsUniqSet rsLiveEntry+                    -- This is non-deterministic but we do not+                    -- currently support deterministic code-generation.+                    -- See Note [Unique Determinism and code generation]++                -- Increment counts for what regs were read/written from.+                let (RU read written)   = regUsageOfInstr platform instr+                mapM_ incUses   $ catMaybes $ map takeVirtualReg $ nub read+                mapM_ incDefs   $ catMaybes $ map takeVirtualReg $ nub written++                -- Compute liveness for entry to next instruction.+                let liveDieRead_virt    = takeVirtuals (liveDieRead  live)+                let liveDieWrite_virt   = takeVirtuals (liveDieWrite live)+                let liveBorn_virt       = takeVirtuals (liveBorn     live)++                let rsLiveAcross+                        = rsLiveEntry `minusUniqSet` liveDieRead_virt++                let rsLiveNext+                        = (rsLiveAcross `unionUniqSets` liveBorn_virt)+                                        `minusUniqSet`  liveDieWrite_virt++                countLIs rsLiveNext lis++        incDefs     reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 1, 0, 0)+        incUses     reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 1, 0)+        incLifetime reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 0, 1)+++-- | Take all the virtual registers from this set.+takeVirtuals :: UniqSet Reg -> UniqSet VirtualReg+takeVirtuals set = mkUniqSet+  [ vr | RegVirtual vr <- nonDetEltsUniqSet set ]+  -- See Note [Unique Determinism and code generation]+++-- | Choose a node to spill from this graph+chooseSpill+        :: SpillCostInfo+        -> Graph VirtualReg RegClass RealReg+        -> VirtualReg++chooseSpill info graph+ = let  cost    = spillCost_length info graph+        node    = minimumBy (\n1 n2 -> compare (cost $ nodeId n1) (cost $ nodeId n2))+                $ nonDetEltsUFM $ graphMap graph+                -- See Note [Unique Determinism and code generation]++   in   nodeId node+++-------------------------------------------------------------------------------+-- | Chaitins spill cost function is:+--+--   cost =     sum         loadCost * freq (u)  +    sum        storeCost * freq (d)+--          u <- uses (v)                         d <- defs (v)+--+--   There are no loops in our code at the momemnt, so we can set the freq's to 1.+--+--  If we don't have live range splitting then Chaitins function performs badly+--  if we have lots of nested live ranges and very few registers.+--+--               v1 v2 v3+--      def v1   .+--      use v1   .+--      def v2   .  .+--      def v3   .  .  .+--      use v1   .  .  .+--      use v3   .  .  .+--      use v2   .  .+--      use v1   .+--+--           defs uses degree   cost+--      v1:  1     3     3      1.5+--      v2:  1     2     3      1.0+--      v3:  1     1     3      0.666+--+--   v3 has the lowest cost, but if we only have 2 hardregs and we insert+--   spill code for v3 then this isn't going to improve the colorability of+--   the graph.+--+--  When compiling SHA1, which as very long basic blocks and some vregs+--  with very long live ranges the allocator seems to try and spill from+--  the inside out and eventually run out of stack slots.+--+--  Without live range splitting, its's better to spill from the outside+--  in so set the cost of very long live ranges to zero+--+{-+spillCost_chaitin+        :: SpillCostInfo+        -> Graph Reg RegClass Reg+        -> Reg+        -> Float++spillCost_chaitin info graph reg+        -- Spilling a live range that only lives for 1 instruction+        -- isn't going to help us at all - and we definitely want to avoid+        -- trying to re-spill previously inserted spill code.+        | lifetime <= 1         = 1/0++        -- It's unlikely that we'll find a reg for a live range this long+        -- better to spill it straight up and not risk trying to keep it around+        -- and have to go through the build/color cycle again.+        | lifetime > allocatableRegsInClass (regClass reg) * 10+        = 0++        -- Otherwise revert to chaitin's regular cost function.+        | otherwise     = fromIntegral (uses + defs)+                        / fromIntegral (nodeDegree graph reg)+        where (_, defs, uses, lifetime)+                = fromMaybe (reg, 0, 0, 0) $ lookupUFM info reg+-}++-- Just spill the longest live range.+spillCost_length+        :: SpillCostInfo+        -> Graph VirtualReg RegClass RealReg+        -> VirtualReg+        -> Float++spillCost_length info _ reg+        | lifetime <= 1         = 1/0+        | otherwise             = 1 / fromIntegral lifetime+        where (_, _, _, lifetime)+                = fromMaybe (reg, 0, 0, 0)+                $ lookupUFM info reg+++-- | Extract a map of register lifetimes from a `SpillCostInfo`.+lifeMapFromSpillCostInfo :: SpillCostInfo -> UniqFM (VirtualReg, Int)+lifeMapFromSpillCostInfo info+        = listToUFM+        $ map (\(r, _, _, life) -> (r, (r, life)))+        $ nonDetEltsUFM info+        -- See Note [Unique Determinism and code generation]+++-- | Determine the degree (number of neighbors) of this node which+--   have the same class.+nodeDegree+        :: (VirtualReg -> RegClass)+        -> Graph VirtualReg RegClass RealReg+        -> VirtualReg+        -> Int++nodeDegree classOfVirtualReg graph reg+        | Just node     <- lookupUFM (graphMap graph) reg++        , virtConflicts+           <- length+           $ filter (\r -> classOfVirtualReg r == classOfVirtualReg reg)+           $ nonDetEltsUniqSet+           -- See Note [Unique Determinism and code generation]+           $ nodeConflicts node++        = virtConflicts + sizeUniqSet (nodeExclusions node)++        | otherwise+        = 0+++-- | Show a spill cost record, including the degree from the graph+--   and final calulated spill cost.+pprSpillCostRecord+        :: (VirtualReg -> RegClass)+        -> (Reg -> SDoc)+        -> Graph VirtualReg RegClass RealReg+        -> SpillCostRecord+        -> SDoc++pprSpillCostRecord regClass pprReg graph (reg, uses, defs, life)+        =  hsep+        [ pprReg (RegVirtual reg)+        , ppr uses+        , ppr defs+        , ppr life+        , ppr $ nodeDegree regClass graph reg+        , text $ show $ (fromIntegral (uses + defs)+                       / fromIntegral (nodeDegree regClass graph reg) :: Float) ]+
+ nativeGen/RegAlloc/Graph/Stats.hs view
@@ -0,0 +1,348 @@+{-# LANGUAGE BangPatterns, CPP #-}++-- | Carries interesting info for debugging / profiling of the+--   graph coloring register allocator.+module RegAlloc.Graph.Stats (+        RegAllocStats (..),++        pprStats,+        pprStatsSpills,+        pprStatsLifetimes,+        pprStatsConflict,+        pprStatsLifeConflict,++        countSRMs, addSRM+) where++#include "nativeGen/NCG.h"++import qualified GraphColor as Color+import RegAlloc.Liveness+import RegAlloc.Graph.Spill+import RegAlloc.Graph.SpillCost+import RegAlloc.Graph.TrivColorable+import Instruction+import RegClass+import Reg+import TargetReg++import PprCmm()+import Outputable+import UniqFM+import UniqSet+import State++import Data.List+++-- | Holds interesting statistics from the register allocator.+data RegAllocStats statics instr++        -- Information about the initial conflict graph.+        = RegAllocStatsStart+        { -- | Initial code, with liveness.+          raLiveCmm     :: [LiveCmmDecl statics instr]++          -- | The initial, uncolored graph.+        , raGraph       :: Color.Graph VirtualReg RegClass RealReg++          -- | Information to help choose which regs to spill.+        , raSpillCosts  :: SpillCostInfo }+++        -- Information about an intermediate graph.+        -- This is one that we couldn't color, so had to insert spill code+        -- instruction stream.+        | RegAllocStatsSpill+        { -- | Code we tried to allocate registers for.+          raCode        :: [LiveCmmDecl statics instr]++          -- | Partially colored graph.+        , raGraph       :: Color.Graph VirtualReg RegClass RealReg++          -- | The regs that were coalesced.+        , raCoalesced   :: UniqFM VirtualReg++          -- | Spiller stats.+        , raSpillStats  :: SpillStats++          -- | Number of instructions each reg lives for.+        , raSpillCosts  :: SpillCostInfo++          -- | Code with spill instructions added.+        , raSpilled     :: [LiveCmmDecl statics instr] }+++        -- a successful coloring+        | RegAllocStatsColored+        { -- | Code we tried to allocate registers for.+          raCode          :: [LiveCmmDecl statics instr]++          -- | Uncolored graph.+        , raGraph         :: Color.Graph VirtualReg RegClass RealReg++          -- | Coalesced and colored graph.+        , raGraphColored  :: Color.Graph VirtualReg RegClass RealReg++          -- | Regs that were coalesced.+        , raCoalesced     :: UniqFM VirtualReg++          -- | Code with coalescings applied.+        , raCodeCoalesced :: [LiveCmmDecl statics instr]++          -- | Code with vregs replaced by hregs.+        , raPatched       :: [LiveCmmDecl statics instr]++          -- | Code with unneeded spill\/reloads cleaned out.+        , raSpillClean    :: [LiveCmmDecl statics instr]++          -- | Final code.+        , raFinal         :: [NatCmmDecl statics instr]++          -- | Spill\/reload\/reg-reg moves present in this code.+        , raSRMs          :: (Int, Int, Int) }+++instance (Outputable statics, Outputable instr)+       => Outputable (RegAllocStats statics instr) where++ ppr (s@RegAllocStatsStart{}) = sdocWithPlatform $ \platform ->+           text "#  Start"+        $$ text "#  Native code with liveness information."+        $$ ppr (raLiveCmm s)+        $$ text ""+        $$ text "#  Initial register conflict graph."+        $$ Color.dotGraph+                (targetRegDotColor platform)+                (trivColorable platform+                        (targetVirtualRegSqueeze platform)+                        (targetRealRegSqueeze platform))+                (raGraph s)+++ ppr (s@RegAllocStatsSpill{}) =+           text "#  Spill"++        $$ text "#  Code with liveness information."+        $$ ppr (raCode s)+        $$ text ""++        $$ (if (not $ isNullUFM $ raCoalesced s)+                then    text "#  Registers coalesced."+                        $$ pprUFMWithKeys (raCoalesced s) (vcat . map ppr)+                        $$ text ""+                else empty)++        $$ text "#  Spills inserted."+        $$ ppr (raSpillStats s)+        $$ text ""++        $$ text "#  Code with spills inserted."+        $$ ppr (raSpilled s)+++ ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) })+    = sdocWithPlatform $ \platform ->+           text "#  Colored"++        $$ text "#  Code with liveness information."+        $$ ppr (raCode s)+        $$ text ""++        $$ text "#  Register conflict graph (colored)."+        $$ Color.dotGraph+                (targetRegDotColor platform)+                (trivColorable platform+                        (targetVirtualRegSqueeze platform)+                        (targetRealRegSqueeze platform))+                (raGraphColored s)+        $$ text ""++        $$ (if (not $ isNullUFM $ raCoalesced s)+                then    text "#  Registers coalesced."+                        $$ pprUFMWithKeys (raCoalesced s) (vcat . map ppr)+                        $$ text ""+                else empty)++        $$ text "#  Native code after coalescings applied."+        $$ ppr (raCodeCoalesced s)+        $$ text ""++        $$ text "#  Native code after register allocation."+        $$ ppr (raPatched s)+        $$ text ""++        $$ text "#  Clean out unneeded spill/reloads."+        $$ ppr (raSpillClean s)+        $$ text ""++        $$ text "#  Final code, after rewriting spill/rewrite pseudo instrs."+        $$ ppr (raFinal s)+        $$ text ""+        $$  text "#  Score:"+        $$ (text "#          spills  inserted: " <> int spills)+        $$ (text "#          reloads inserted: " <> int reloads)+        $$ (text "#   reg-reg moves remaining: " <> int moves)+        $$ text ""+++-- | Do all the different analysis on this list of RegAllocStats+pprStats+        :: [RegAllocStats statics instr]+        -> Color.Graph VirtualReg RegClass RealReg+        -> SDoc++pprStats stats graph+ = let  outSpills       = pprStatsSpills    stats+        outLife         = pprStatsLifetimes stats+        outConflict     = pprStatsConflict  stats+        outScatter      = pprStatsLifeConflict stats graph++  in    vcat [outSpills, outLife, outConflict, outScatter]+++-- | Dump a table of how many spill loads \/ stores were inserted for each vreg.+pprStatsSpills+        :: [RegAllocStats statics instr] -> SDoc++pprStatsSpills stats+ = let+        finals  = [ s   | s@RegAllocStatsColored{} <- stats]++        -- sum up how many stores\/loads\/reg-reg-moves were left in the code+        total   = foldl' addSRM (0, 0, 0)+                $ map raSRMs finals++    in  (  text "-- spills-added-total"+        $$ text "--    (stores, loads, reg_reg_moves_remaining)"+        $$ ppr total+        $$ text "")+++-- | Dump a table of how long vregs tend to live for in the initial code.+pprStatsLifetimes+        :: [RegAllocStats statics instr] -> SDoc++pprStatsLifetimes stats+ = let  info            = foldl' plusSpillCostInfo zeroSpillCostInfo+                                [ raSpillCosts s+                                        | s@RegAllocStatsStart{} <- stats ]++        lifeBins        = binLifetimeCount $ lifeMapFromSpillCostInfo info++   in   (  text "-- vreg-population-lifetimes"+        $$ text "--   (instruction_count, number_of_vregs_that_lived_that_long)"+        $$ pprUFM lifeBins (vcat . map ppr)+        $$ text "\n")+++binLifetimeCount :: UniqFM (VirtualReg, Int) -> UniqFM (Int, Int)+binLifetimeCount fm+ = let  lifes   = map (\l -> (l, (l, 1)))+                $ map snd+                $ nonDetEltsUFM fm+                -- See Note [Unique Determinism and code generation]++   in   addListToUFM_C+                (\(l1, c1) (_, c2) -> (l1, c1 + c2))+                emptyUFM+                lifes+++-- | Dump a table of how many conflicts vregs tend to have in the initial code.+pprStatsConflict+        :: [RegAllocStats statics instr] -> SDoc++pprStatsConflict stats+ = let  confMap = foldl' (plusUFM_C (\(c1, n1) (_, n2) -> (c1, n1 + n2)))+                        emptyUFM+                $ map Color.slurpNodeConflictCount+                        [ raGraph s | s@RegAllocStatsStart{} <- stats ]++   in   (  text "-- vreg-conflicts"+        $$ text "--   (conflict_count, number_of_vregs_that_had_that_many_conflicts)"+        $$ pprUFM confMap (vcat . map ppr)+        $$ text "\n")+++-- | For every vreg, dump it's how many conflicts it has and its lifetime+--      good for making a scatter plot.+pprStatsLifeConflict+        :: [RegAllocStats statics instr]+        -> Color.Graph VirtualReg RegClass RealReg -- ^ global register conflict graph+        -> SDoc++pprStatsLifeConflict stats graph+ = let  lifeMap = lifeMapFromSpillCostInfo+                $ foldl' plusSpillCostInfo zeroSpillCostInfo+                $ [ raSpillCosts s | s@RegAllocStatsStart{} <- stats ]++        scatter = map   (\r ->  let lifetime    = case lookupUFM lifeMap r of+                                                        Just (_, l)     -> l+                                                        Nothing         -> 0+                                    Just node   = Color.lookupNode graph r+                                in parens $ hcat $ punctuate (text ", ")+                                        [ doubleQuotes $ ppr $ Color.nodeId node+                                        , ppr $ sizeUniqSet (Color.nodeConflicts node)+                                        , ppr $ lifetime ])+                $ map Color.nodeId+                $ nonDetEltsUFM+                -- See Note [Unique Determinism and code generation]+                $ Color.graphMap graph++   in   (  text "-- vreg-conflict-lifetime"+        $$ text "--   (vreg, vreg_conflicts, vreg_lifetime)"+        $$ (vcat scatter)+        $$ text "\n")+++-- | Count spill/reload/reg-reg moves.+--      Lets us see how well the register allocator has done.+countSRMs+        :: Instruction instr+        => LiveCmmDecl statics instr -> (Int, Int, Int)++countSRMs cmm+        = execState (mapBlockTopM countSRM_block cmm) (0, 0, 0)+++countSRM_block+        :: Instruction instr+        => GenBasicBlock (LiveInstr instr)+        -> State (Int, Int, Int) (GenBasicBlock (LiveInstr instr))++countSRM_block (BasicBlock i instrs)+ = do   instrs' <- mapM countSRM_instr instrs+        return  $ BasicBlock i instrs'+++countSRM_instr+        :: Instruction instr+        => LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr)++countSRM_instr li+        | LiveInstr SPILL{} _    <- li+        = do    modify  $ \(s, r, m)    -> (s + 1, r, m)+                return li++        | LiveInstr RELOAD{} _  <- li+        = do    modify  $ \(s, r, m)    -> (s, r + 1, m)+                return li++        | LiveInstr instr _     <- li+        , Just _        <- takeRegRegMoveInstr instr+        = do    modify  $ \(s, r, m)    -> (s, r, m + 1)+                return li++        | otherwise+        =       return li+++-- sigh..+addSRM :: (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int)+addSRM (s1, r1, m1) (s2, r2, m2)+ = let  !s = s1 + s2+        !r = r1 + r2+        !m = m1 + m2+   in   (s, r, m)+
+ nativeGen/RegAlloc/Graph/TrivColorable.hs view
@@ -0,0 +1,283 @@+{-# LANGUAGE CPP #-}++module RegAlloc.Graph.TrivColorable (+        trivColorable,+)++where++#include "HsVersions.h"++import RegClass+import Reg++import GraphBase++import UniqSet+import Platform+import Panic++-- trivColorable ---------------------------------------------------------------++-- trivColorable function for the graph coloring allocator+--+--      This gets hammered by scanGraph during register allocation,+--      so needs to be fairly efficient.+--+--      NOTE:   This only works for arcitectures with just RcInteger and RcDouble+--              (which are disjoint) ie. x86, x86_64 and ppc+--+--      The number of allocatable regs is hard coded in here so we can do+--              a fast comparison in trivColorable.+--+--      It's ok if these numbers are _less_ than the actual number of free+--              regs, but they can't be more or the register conflict+--              graph won't color.+--+--      If the graph doesn't color then the allocator will panic, but it won't+--              generate bad object code or anything nasty like that.+--+--      There is an allocatableRegsInClass :: RegClass -> Int, but doing+--      the unboxing is too slow for us here.+--      TODO: Is that still true? Could we use allocatableRegsInClass+--      without losing performance now?+--+--      Look at includes/stg/MachRegs.h to get the numbers.+--+++-- Disjoint registers ----------------------------------------------------------+--+--      The definition has been unfolded into individual cases for speed.+--      Each architecture has a different register setup, so we use a+--      different regSqueeze function for each.+--+accSqueeze+        :: Int+        -> Int+        -> (reg -> Int)+        -> UniqSet reg+        -> Int++accSqueeze count maxCount squeeze us = acc count (nonDetEltsUniqSet us)+  -- See Note [Unique Determinism and code generation]+  where acc count [] = count+        acc count _ | count >= maxCount = count+        acc count (r:rs) = acc (count + squeeze r) rs++{- Note [accSqueeze]+~~~~~~~~~~~~~~~~~~~~+BL 2007/09+Doing a nice fold over the UniqSet makes trivColorable use+32% of total compile time and 42% of total alloc when compiling SHA1.hs from darcs.+Therefore the UniqFM is made non-abstract and we use custom fold.++MS 2010/04+When converting UniqFM to use Data.IntMap, the fold cannot use UniqFM internal+representation any more. But it is imperative that the accSqueeze stops+the folding if the count gets greater or equal to maxCount. We thus convert+UniqFM to a (lazy) list, do the fold and stops if necessary, which was+the most efficient variant tried. Benchmark compiling 10-times SHA1.hs follows.+(original = previous implementation, folding = fold of the whole UFM,+ lazyFold = the current implementation,+ hackFold = using internal representation of Data.IntMap)++                                 original  folding   hackFold  lazyFold+ -O -fasm (used everywhere)      31.509s   30.387s   30.791s   30.603s+                                 100.00%   96.44%    97.72%    97.12%+ -fregs-graph                    67.938s   74.875s   62.673s   64.679s+                                 100.00%   110.21%   92.25%    95.20%+ -fregs-iterative                89.761s   143.913s  81.075s   86.912s+                                 100.00%   160.33%   90.32%    96.83%+ -fnew-codegen                   38.225s   37.142s   37.551s   37.119s+                                 100.00%   97.17%    98.24%    97.11%+ -fnew-codegen -fregs-graph      91.786s   91.51s    87.368s   86.88s+                                 100.00%   99.70%    95.19%    94.65%+ -fnew-codegen -fregs-iterative  206.72s   343.632s  194.694s  208.677s+                                 100.00%   166.23%   94.18%    100.95%+-}++trivColorable+        :: Platform+        -> (RegClass -> VirtualReg -> Int)+        -> (RegClass -> RealReg    -> Int)+        -> Triv VirtualReg RegClass RealReg++trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions+        | let cALLOCATABLE_REGS_INTEGER+                  =        (case platformArch platform of+                            ArchX86       -> 3+                            ArchX86_64    -> 5+                            ArchPPC       -> 16+                            ArchSPARC     -> 14+                            ArchSPARC64   -> panic "trivColorable ArchSPARC64"+                            ArchPPC_64 _  -> 15+                            ArchARM _ _ _ -> panic "trivColorable ArchARM"+                            ArchARM64     -> panic "trivColorable ArchARM64"+                            ArchAlpha     -> panic "trivColorable ArchAlpha"+                            ArchMipseb    -> panic "trivColorable ArchMipseb"+                            ArchMipsel    -> panic "trivColorable ArchMipsel"+                            ArchJavaScript-> panic "trivColorable ArchJavaScript"+                            ArchUnknown   -> panic "trivColorable ArchUnknown")+        , count2        <- accSqueeze 0 cALLOCATABLE_REGS_INTEGER+                                (virtualRegSqueeze RcInteger)+                                conflicts++        , count3        <- accSqueeze  count2    cALLOCATABLE_REGS_INTEGER+                                (realRegSqueeze   RcInteger)+                                exclusions++        = count3 < cALLOCATABLE_REGS_INTEGER++trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions+        | let cALLOCATABLE_REGS_FLOAT+                  =        (case platformArch platform of+                            ArchX86       -> 0+                            ArchX86_64    -> 0+                            ArchPPC       -> 0+                            ArchSPARC     -> 22+                            ArchSPARC64   -> panic "trivColorable ArchSPARC64"+                            ArchPPC_64 _  -> 0+                            ArchARM _ _ _ -> panic "trivColorable ArchARM"+                            ArchARM64     -> panic "trivColorable ArchARM64"+                            ArchAlpha     -> panic "trivColorable ArchAlpha"+                            ArchMipseb    -> panic "trivColorable ArchMipseb"+                            ArchMipsel    -> panic "trivColorable ArchMipsel"+                            ArchJavaScript-> panic "trivColorable ArchJavaScript"+                            ArchUnknown   -> panic "trivColorable ArchUnknown")+        , count2        <- accSqueeze 0 cALLOCATABLE_REGS_FLOAT+                                (virtualRegSqueeze RcFloat)+                                conflicts++        , count3        <- accSqueeze  count2    cALLOCATABLE_REGS_FLOAT+                                (realRegSqueeze   RcFloat)+                                exclusions++        = count3 < cALLOCATABLE_REGS_FLOAT++trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions+        | let cALLOCATABLE_REGS_DOUBLE+                  =        (case platformArch platform of+                            ArchX86       -> 6+                            ArchX86_64    -> 0+                            ArchPPC       -> 26+                            ArchSPARC     -> 11+                            ArchSPARC64   -> panic "trivColorable ArchSPARC64"+                            ArchPPC_64 _  -> 20+                            ArchARM _ _ _ -> panic "trivColorable ArchARM"+                            ArchARM64     -> panic "trivColorable ArchARM64"+                            ArchAlpha     -> panic "trivColorable ArchAlpha"+                            ArchMipseb    -> panic "trivColorable ArchMipseb"+                            ArchMipsel    -> panic "trivColorable ArchMipsel"+                            ArchJavaScript-> panic "trivColorable ArchJavaScript"+                            ArchUnknown   -> panic "trivColorable ArchUnknown")+        , count2        <- accSqueeze 0 cALLOCATABLE_REGS_DOUBLE+                                (virtualRegSqueeze RcDouble)+                                conflicts++        , count3        <- accSqueeze  count2    cALLOCATABLE_REGS_DOUBLE+                                (realRegSqueeze   RcDouble)+                                exclusions++        = count3 < cALLOCATABLE_REGS_DOUBLE++trivColorable platform virtualRegSqueeze realRegSqueeze RcDoubleSSE conflicts exclusions+        | let cALLOCATABLE_REGS_SSE+                  =        (case platformArch platform of+                            ArchX86       -> 8+                            ArchX86_64    -> 10+                            ArchPPC       -> 0+                            ArchSPARC     -> 0+                            ArchSPARC64   -> panic "trivColorable ArchSPARC64"+                            ArchPPC_64 _  -> 0+                            ArchARM _ _ _ -> panic "trivColorable ArchARM"+                            ArchARM64     -> panic "trivColorable ArchARM64"+                            ArchAlpha     -> panic "trivColorable ArchAlpha"+                            ArchMipseb    -> panic "trivColorable ArchMipseb"+                            ArchMipsel    -> panic "trivColorable ArchMipsel"+                            ArchJavaScript-> panic "trivColorable ArchJavaScript"+                            ArchUnknown   -> panic "trivColorable ArchUnknown")+        , count2        <- accSqueeze 0 cALLOCATABLE_REGS_SSE+                                (virtualRegSqueeze RcDoubleSSE)+                                conflicts++        , count3        <- accSqueeze  count2    cALLOCATABLE_REGS_SSE+                                (realRegSqueeze   RcDoubleSSE)+                                exclusions++        = count3 < cALLOCATABLE_REGS_SSE+++-- Specification Code ----------------------------------------------------------+--+--      The trivColorable function for each particular architecture should+--      implement the following function, but faster.+--++{-+trivColorable :: RegClass -> UniqSet Reg -> UniqSet Reg -> Bool+trivColorable classN conflicts exclusions+ = let++        acc :: Reg -> (Int, Int) -> (Int, Int)+        acc r (cd, cf)+         = case regClass r of+                RcInteger       -> (cd+1, cf)+                RcFloat         -> (cd,   cf+1)+                _               -> panic "Regs.trivColorable: reg class not handled"++        tmp                     = nonDetFoldUFM acc (0, 0) conflicts+        (countInt,  countFloat) = nonDetFoldUFM acc tmp    exclusions++        squeese         = worst countInt   classN RcInteger+                        + worst countFloat classN RcFloat++   in   squeese < allocatableRegsInClass classN++-- | Worst case displacement+--      node N of classN has n neighbors of class C.+--+--      We currently only have RcInteger and RcDouble, which don't conflict at all.+--      This is a bit boring compared to what's in RegArchX86.+--+worst :: Int -> RegClass -> RegClass -> Int+worst n classN classC+ = case classN of+        RcInteger+         -> case classC of+                RcInteger       -> min n (allocatableRegsInClass RcInteger)+                RcFloat         -> 0++        RcDouble+         -> case classC of+                RcFloat         -> min n (allocatableRegsInClass RcFloat)+                RcInteger       -> 0++-- allocatableRegs is allMachRegNos with the fixed-use regs removed.+-- i.e., these are the regs for which we are prepared to allow the+-- register allocator to attempt to map VRegs to.+allocatableRegs :: [RegNo]+allocatableRegs+   = let isFree i = freeReg i+     in  filter isFree allMachRegNos+++-- | The number of regs in each class.+--      We go via top level CAFs to ensure that we're not recomputing+--      the length of these lists each time the fn is called.+allocatableRegsInClass :: RegClass -> Int+allocatableRegsInClass cls+ = case cls of+        RcInteger       -> allocatableRegsInteger+        RcFloat         -> allocatableRegsDouble++allocatableRegsInteger :: Int+allocatableRegsInteger+        = length $ filter (\r -> regClass r == RcInteger)+                 $ map RealReg allocatableRegs++allocatableRegsFloat :: Int+allocatableRegsFloat+        = length $ filter (\r -> regClass r == RcFloat+                 $ map RealReg allocatableRegs+-}
+ nativeGen/RegAlloc/Linear/Base.hs view
@@ -0,0 +1,132 @@++-- | Put common type definitions here to break recursive module dependencies.++module RegAlloc.Linear.Base (+        BlockAssignment,++        Loc(..),+        regsOfLoc,++        -- for stats+        SpillReason(..),+        RegAllocStats(..),++        -- the allocator monad+        RA_State(..),+)++where++import RegAlloc.Linear.StackMap+import RegAlloc.Liveness+import Reg++import DynFlags+import Outputable+import Unique+import UniqFM+import UniqSupply+++-- | Used to store the register assignment on entry to a basic block.+--      We use this to handle join points, where multiple branch instructions+--      target a particular label. We have to insert fixup code to make+--      the register assignments from the different sources match up.+--+type BlockAssignment freeRegs+        = BlockMap (freeRegs, RegMap Loc)+++-- | Where a vreg is currently stored+--      A temporary can be marked as living in both a register and memory+--      (InBoth), for example if it was recently loaded from a spill location.+--      This makes it cheap to spill (no save instruction required), but we+--      have to be careful to turn this into InReg if the value in the+--      register is changed.++--      This is also useful when a temporary is about to be clobbered.  We+--      save it in a spill location, but mark it as InBoth because the current+--      instruction might still want to read it.+--+data Loc+        -- | vreg is in a register+        = InReg   !RealReg++        -- | vreg is held in a stack slot+        | InMem   {-# UNPACK #-}  !StackSlot+++        -- | vreg is held in both a register and a stack slot+        | InBoth   !RealReg+                   {-# UNPACK #-} !StackSlot+        deriving (Eq, Show, Ord)++instance Outputable Loc where+        ppr l = text (show l)+++-- | Get the reg numbers stored in this Loc.+regsOfLoc :: Loc -> [RealReg]+regsOfLoc (InReg r)    = [r]+regsOfLoc (InBoth r _) = [r]+regsOfLoc (InMem _)    = []+++-- | Reasons why instructions might be inserted by the spiller.+--      Used when generating stats for -ddrop-asm-stats.+--+data SpillReason+        -- | vreg was spilled to a slot so we could use its+        --      current hreg for another vreg+        = SpillAlloc    !Unique++        -- | vreg was moved because its hreg was clobbered+        | SpillClobber  !Unique++        -- | vreg was loaded from a spill slot+        | SpillLoad     !Unique++        -- | reg-reg move inserted during join to targets+        | SpillJoinRR   !Unique++        -- | reg-mem move inserted during join to targets+        | SpillJoinRM   !Unique+++-- | Used to carry interesting stats out of the register allocator.+data RegAllocStats+        = RegAllocStats+        { ra_spillInstrs        :: UniqFM [Int] }+++-- | The register allocator state+data RA_State freeRegs+        = RA_State++        {+        -- | the current mapping from basic blocks to+        --      the register assignments at the beginning of that block.+          ra_blockassig :: BlockAssignment freeRegs++        -- | free machine registers+        , ra_freeregs   :: !freeRegs++        -- | assignment of temps to locations+        , ra_assig      :: RegMap Loc++        -- | current stack delta+        , ra_delta      :: Int++        -- | free stack slots for spilling+        , ra_stack      :: StackMap++        -- | unique supply for generating names for join point fixup blocks.+        , ra_us         :: UniqSupply++        -- | Record why things were spilled, for -ddrop-asm-stats.+        --      Just keep a list here instead of a map of regs -> reasons.+        --      We don't want to slow down the allocator if we're not going to emit the stats.+        , ra_spills     :: [SpillReason]+        , ra_DynFlags   :: DynFlags }++
+ nativeGen/RegAlloc/Linear/FreeRegs.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE CPP #-}++module RegAlloc.Linear.FreeRegs (+    FR(..),+    maxSpillSlots+)++#include "HsVersions.h"++where++import Reg+import RegClass++import DynFlags+import Panic+import Platform++-- -----------------------------------------------------------------------------+-- The free register set+-- This needs to be *efficient*+-- Here's an inefficient 'executable specification' of the FreeRegs data type:+--+--      type FreeRegs = [RegNo]+--      noFreeRegs = 0+--      releaseReg n f = if n `elem` f then f else (n : f)+--      initFreeRegs = allocatableRegs+--      getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f+--      allocateReg f r = filter (/= r) f++import qualified RegAlloc.Linear.PPC.FreeRegs    as PPC+import qualified RegAlloc.Linear.SPARC.FreeRegs  as SPARC+import qualified RegAlloc.Linear.X86.FreeRegs    as X86+import qualified RegAlloc.Linear.X86_64.FreeRegs as X86_64++import qualified PPC.Instr+import qualified SPARC.Instr+import qualified X86.Instr++class Show freeRegs => FR freeRegs where+    frAllocateReg :: Platform -> RealReg -> freeRegs -> freeRegs+    frGetFreeRegs :: Platform -> RegClass -> freeRegs -> [RealReg]+    frInitFreeRegs :: Platform -> freeRegs+    frReleaseReg :: Platform -> RealReg -> freeRegs -> freeRegs++instance FR X86.FreeRegs where+    frAllocateReg  = \_ -> X86.allocateReg+    frGetFreeRegs  = X86.getFreeRegs+    frInitFreeRegs = X86.initFreeRegs+    frReleaseReg   = \_ -> X86.releaseReg++instance FR X86_64.FreeRegs where+    frAllocateReg  = \_ -> X86_64.allocateReg+    frGetFreeRegs  = X86_64.getFreeRegs+    frInitFreeRegs = X86_64.initFreeRegs+    frReleaseReg   = \_ -> X86_64.releaseReg++instance FR PPC.FreeRegs where+    frAllocateReg  = \_ -> PPC.allocateReg+    frGetFreeRegs  = \_ -> PPC.getFreeRegs+    frInitFreeRegs = PPC.initFreeRegs+    frReleaseReg   = \_ -> PPC.releaseReg++instance FR SPARC.FreeRegs where+    frAllocateReg  = SPARC.allocateReg+    frGetFreeRegs  = \_ -> SPARC.getFreeRegs+    frInitFreeRegs = SPARC.initFreeRegs+    frReleaseReg   = SPARC.releaseReg++maxSpillSlots :: DynFlags -> Int+maxSpillSlots dflags+              = case platformArch (targetPlatform dflags) of+                ArchX86       -> X86.Instr.maxSpillSlots dflags+                ArchX86_64    -> X86.Instr.maxSpillSlots dflags+                ArchPPC       -> PPC.Instr.maxSpillSlots dflags+                ArchSPARC     -> SPARC.Instr.maxSpillSlots dflags+                ArchSPARC64   -> panic "maxSpillSlots ArchSPARC64"+                ArchARM _ _ _ -> panic "maxSpillSlots ArchARM"+                ArchARM64     -> panic "maxSpillSlots ArchARM64"+                ArchPPC_64 _  -> PPC.Instr.maxSpillSlots dflags+                ArchAlpha     -> panic "maxSpillSlots ArchAlpha"+                ArchMipseb    -> panic "maxSpillSlots ArchMipseb"+                ArchMipsel    -> panic "maxSpillSlots ArchMipsel"+                ArchJavaScript-> panic "maxSpillSlots ArchJavaScript"+                ArchUnknown   -> panic "maxSpillSlots ArchUnknown"+
+ nativeGen/RegAlloc/Linear/JoinToTargets.hs view
@@ -0,0 +1,368 @@++-- | Handles joining of a jump instruction to its targets.++--      The first time we encounter a jump to a particular basic block, we+--      record the assignment of temporaries.  The next time we encounter a+--      jump to the same block, we compare our current assignment to the+--      stored one.  They might be different if spilling has occurred in one+--      branch; so some fixup code will be required to match up the assignments.+--+module RegAlloc.Linear.JoinToTargets (joinToTargets) where++import RegAlloc.Linear.State+import RegAlloc.Linear.Base+import RegAlloc.Linear.FreeRegs+import RegAlloc.Liveness+import Instruction+import Reg++import BlockId+import Hoopl+import Digraph+import DynFlags+import Outputable+import Unique+import UniqFM+import UniqSet++import Data.Foldable (foldl')++-- | For a jump instruction at the end of a block, generate fixup code so its+--      vregs are in the correct regs for its destination.+--+joinToTargets+        :: (FR freeRegs, Instruction instr)+        => BlockMap RegSet              -- ^ maps the unique of the blockid to the set of vregs+                                        --      that are known to be live on the entry to each block.++        -> BlockId                      -- ^ id of the current block+        -> instr                        -- ^ branch instr on the end of the source block.++        -> RegM freeRegs ([NatBasicBlock instr] -- fresh blocks of fixup code.+                         , instr)               -- the original branch+                                                -- instruction, but maybe+                                                -- patched to jump+                                                -- to a fixup block first.++joinToTargets block_live id instr++        -- we only need to worry about jump instructions.+        | not $ isJumpishInstr instr+        = return ([], instr)++        | otherwise+        = joinToTargets' block_live [] id instr (jumpDestsOfInstr instr)++-----+joinToTargets'+        :: (FR freeRegs, Instruction instr)+        => BlockMap RegSet              -- ^ maps the unique of the blockid to the set of vregs+                                        --      that are known to be live on the entry to each block.++        -> [NatBasicBlock instr]        -- ^ acc blocks of fixup code.++        -> BlockId                      -- ^ id of the current block+        -> instr                        -- ^ branch instr on the end of the source block.++        -> [BlockId]                    -- ^ branch destinations still to consider.++        -> RegM freeRegs ([NatBasicBlock instr], instr)++-- no more targets to consider. all done.+joinToTargets' _          new_blocks _ instr []+        = return (new_blocks, instr)++-- handle a branch target.+joinToTargets' block_live new_blocks block_id instr (dest:dests)+ = do+        -- get the map of where the vregs are stored on entry to each basic block.+        block_assig     <- getBlockAssigR++        -- get the assignment on entry to the branch instruction.+        assig           <- getAssigR++        -- adjust the current assignment to remove any vregs that are not live+        -- on entry to the destination block.+        let Just live_set       = mapLookup dest block_live+        let still_live uniq _   = uniq `elemUniqSet_Directly` live_set+        let adjusted_assig      = filterUFM_Directly still_live assig++        -- and free up those registers which are now free.+        let to_free =+                [ r     | (reg, loc) <- nonDetUFMToList assig+                        -- This is non-deterministic but we do not+                        -- currently support deterministic code-generation.+                        -- See Note [Unique Determinism and code generation]+                        , not (elemUniqSet_Directly reg live_set)+                        , r          <- regsOfLoc loc ]++        case mapLookup dest block_assig of+         Nothing+          -> joinToTargets_first+                        block_live new_blocks block_id instr dest dests+                        block_assig adjusted_assig to_free++         Just (_, dest_assig)+          -> joinToTargets_again+                        block_live new_blocks block_id instr dest dests+                        adjusted_assig dest_assig+++-- this is the first time we jumped to this block.+joinToTargets_first :: (FR freeRegs, Instruction instr)+                    => BlockMap RegSet+                    -> [NatBasicBlock instr]+                    -> BlockId+                    -> instr+                    -> BlockId+                    -> [BlockId]+                    -> BlockAssignment freeRegs+                    -> RegMap Loc+                    -> [RealReg]+                    -> RegM freeRegs ([NatBasicBlock instr], instr)+joinToTargets_first block_live new_blocks block_id instr dest dests+        block_assig src_assig+        to_free++ = do   dflags <- getDynFlags+        let platform = targetPlatform dflags++        -- free up the regs that are not live on entry to this block.+        freeregs        <- getFreeRegsR+        let freeregs' = foldl' (flip $ frReleaseReg platform) freeregs to_free++        -- remember the current assignment on entry to this block.+        setBlockAssigR (mapInsert dest (freeregs', src_assig) block_assig)++        joinToTargets' block_live new_blocks block_id instr dests+++-- we've jumped to this block before+joinToTargets_again :: (Instruction instr, FR freeRegs)+                    => BlockMap RegSet+                    -> [NatBasicBlock instr]+                    -> BlockId+                    -> instr+                    -> BlockId+                    -> [BlockId]+                    -> UniqFM Loc+                    -> UniqFM Loc+                    -> RegM freeRegs ([NatBasicBlock instr], instr)+joinToTargets_again+    block_live new_blocks block_id instr dest dests+    src_assig dest_assig++        -- the assignments already match, no problem.+        | nonDetUFMToList dest_assig == nonDetUFMToList src_assig+        -- This is non-deterministic but we do not+        -- currently support deterministic code-generation.+        -- See Note [Unique Determinism and code generation]+        = joinToTargets' block_live new_blocks block_id instr dests++        -- assignments don't match, need fixup code+        | otherwise+        = do++                -- make a graph of what things need to be moved where.+                let graph = makeRegMovementGraph src_assig dest_assig++                -- look for cycles in the graph. This can happen if regs need to be swapped.+                -- Note that we depend on the fact that this function does a+                --      bottom up traversal of the tree-like portions of the graph.+                --+                --  eg, if we have+                --      R1 -> R2 -> R3+                --+                --  ie move value in R1 to R2 and value in R2 to R3.+                --+                -- We need to do the R2 -> R3 move before R1 -> R2.+                --+                let sccs  = stronglyConnCompFromEdgedVerticesOrdR graph++{-              -- debugging+                pprTrace+                        ("joinToTargets: making fixup code")+                        (vcat   [ text "        in block: "     <> ppr block_id+                                , text " jmp instruction: "     <> ppr instr+                                , text "  src assignment: "     <> ppr src_assig+                                , text " dest assignment: "     <> ppr dest_assig+                                , text "  movement graph: "     <> ppr graph+                                , text "   sccs of graph: "     <> ppr sccs+                                , text ""])+                        (return ())+-}+                delta           <- getDeltaR+                fixUpInstrs_    <- mapM (handleComponent delta instr) sccs+                let fixUpInstrs = concat fixUpInstrs_++                -- make a new basic block containing the fixup code.+                --      A the end of the current block we will jump to the fixup one,+                --      then that will jump to our original destination.+                fixup_block_id <- getUniqueR+                let block = BasicBlock (mkBlockId fixup_block_id)+                                $ fixUpInstrs ++ mkJumpInstr dest++{-              pprTrace+                        ("joinToTargets: fixup code is:")+                        (vcat   [ ppr block+                                , text ""])+                        (return ())+-}+                -- if we didn't need any fixups, then don't include the block+                case fixUpInstrs of+                 []     -> joinToTargets' block_live new_blocks block_id instr dests++                 -- patch the original branch instruction so it goes to our+                 --     fixup block instead.+                 _      -> let  instr'  =  patchJumpInstr instr+                                                (\bid -> if bid == dest+                                                                then mkBlockId fixup_block_id+                                                                else bid) -- no change!++                           in   joinToTargets' block_live (block : new_blocks) block_id instr' dests+++-- | Construct a graph of register\/spill movements.+--+--      Cyclic components seem to occur only very rarely.+--+--      We cut some corners by not handling memory-to-memory moves.+--      This shouldn't happen because every temporary gets its own stack slot.+--+makeRegMovementGraph :: RegMap Loc -> RegMap Loc -> [(Unique, Loc, [Loc])]+makeRegMovementGraph adjusted_assig dest_assig+ = [ node       | (vreg, src) <- nonDetUFMToList adjusted_assig+                    -- This is non-deterministic but we do not+                    -- currently support deterministic code-generation.+                    -- See Note [Unique Determinism and code generation]+                    -- source reg might not be needed at the dest:+                , Just loc <- [lookupUFM_Directly dest_assig vreg]+                , node <- expandNode vreg src loc ]+++-- | Expand out the destination, so InBoth destinations turn into+--      a combination of InReg and InMem.++--      The InBoth handling is a little tricky here.  If the destination is+--      InBoth, then we must ensure that the value ends up in both locations.+--      An InBoth  destination must conflict with an InReg or InMem source, so+--      we expand an InBoth destination as necessary.+--+--      An InBoth source is slightly different: we only care about the register+--      that the source value is in, so that we can move it to the destinations.+--+expandNode+        :: a+        -> Loc                  -- ^ source of move+        -> Loc                  -- ^ destination of move+        -> [(a, Loc, [Loc])]++expandNode vreg loc@(InReg src) (InBoth dst mem)+        | src == dst = [(vreg, loc, [InMem mem])]+        | otherwise  = [(vreg, loc, [InReg dst, InMem mem])]++expandNode vreg loc@(InMem src) (InBoth dst mem)+        | src == mem = [(vreg, loc, [InReg dst])]+        | otherwise  = [(vreg, loc, [InReg dst, InMem mem])]++expandNode _        (InBoth _ src) (InMem dst)+        | src == dst = [] -- guaranteed to be true++expandNode _        (InBoth src _) (InReg dst)+        | src == dst = []++expandNode vreg     (InBoth src _) dst+        = expandNode vreg (InReg src) dst++expandNode vreg src dst+        | src == dst = []+        | otherwise  = [(vreg, src, [dst])]+++-- | Generate fixup code for a particular component in the move graph+--      This component tells us what values need to be moved to what+--      destinations. We have eliminated any possibility of single-node+--      cycles in expandNode above.+--+handleComponent+        :: Instruction instr+        => Int -> instr -> SCC (Unique, Loc, [Loc])+        -> RegM freeRegs [instr]++-- If the graph is acyclic then we won't get the swapping problem below.+--      In this case we can just do the moves directly, and avoid having to+--      go via a spill slot.+--+handleComponent delta _  (AcyclicSCC (vreg, src, dsts))+        = mapM (makeMove delta vreg src) dsts+++-- Handle some cyclic moves.+--      This can happen if we have two regs that need to be swapped.+--      eg:+--           vreg   source loc   dest loc+--          (vreg1, InReg r1,    [InReg r2])+--          (vreg2, InReg r2,    [InReg r1])+--+--      To avoid needing temp register, we just spill all the source regs, then+--      reaload them into their destination regs.+--+--      Note that we can not have cycles that involve memory locations as+--      sources as single destination because memory locations (stack slots)+--      are allocated exclusively for a virtual register and therefore can not+--      require a fixup.+--+handleComponent delta instr+        (CyclicSCC ((vreg, InReg sreg, (InReg dreg: _)) : rest))+        -- dest list may have more than one element, if the reg is also InMem.+ = do+        -- spill the source into its slot+        (instrSpill, slot)+                        <- spillR (RegReal sreg) vreg++        -- reload into destination reg+        instrLoad       <- loadR (RegReal dreg) slot++        remainingFixUps <- mapM (handleComponent delta instr)+                                (stronglyConnCompFromEdgedVerticesOrdR rest)++        -- make sure to do all the reloads after all the spills,+        --      so we don't end up clobbering the source values.+        return ([instrSpill] ++ concat remainingFixUps ++ [instrLoad])++handleComponent _ _ (CyclicSCC _)+ = panic "Register Allocator: handleComponent cyclic"+++-- | Move a vreg between these two locations.+--+makeMove+    :: Instruction instr+    => Int      -- ^ current C stack delta.+    -> Unique   -- ^ unique of the vreg that we're moving.+    -> Loc      -- ^ source location.+    -> Loc      -- ^ destination location.+    -> RegM freeRegs instr  -- ^ move instruction.++makeMove delta vreg src dst+ = do dflags <- getDynFlags+      let platform = targetPlatform dflags++      case (src, dst) of+          (InReg s, InReg d) ->+              do recordSpill (SpillJoinRR vreg)+                 return $ mkRegRegMoveInstr platform (RegReal s) (RegReal d)+          (InMem s, InReg d) ->+              do recordSpill (SpillJoinRM vreg)+                 return $ mkLoadInstr dflags (RegReal d) delta s+          (InReg s, InMem d) ->+              do recordSpill (SpillJoinRM vreg)+                 return $ mkSpillInstr dflags (RegReal s) delta d+          _ ->+              -- we don't handle memory to memory moves.+              -- they shouldn't happen because we don't share+              -- stack slots between vregs.+              panic ("makeMove " ++ show vreg ++ " (" ++ show src ++ ") ("+                  ++ show dst ++ ")"+                  ++ " we don't handle mem->mem moves.")+
+ nativeGen/RegAlloc/Linear/Main.hs view
@@ -0,0 +1,907 @@+{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-}++-----------------------------------------------------------------------------+--+-- The register allocator+--+-- (c) The University of Glasgow 2004+--+-----------------------------------------------------------------------------++{-+The algorithm is roughly:++  1) Compute strongly connected components of the basic block list.++  2) Compute liveness (mapping from pseudo register to+     point(s) of death?).++  3) Walk instructions in each basic block.  We keep track of+        (a) Free real registers (a bitmap?)+        (b) Current assignment of temporaries to machine registers and/or+            spill slots (call this the "assignment").+        (c) Partial mapping from basic block ids to a virt-to-loc mapping.+            When we first encounter a branch to a basic block,+            we fill in its entry in this table with the current mapping.++     For each instruction:+        (a) For each temporary *read* by the instruction:+            If the temporary does not have a real register allocation:+                - Allocate a real register from the free list.  If+                  the list is empty:+                  - Find a temporary to spill.  Pick one that is+                    not used in this instruction (ToDo: not+                    used for a while...)+                  - generate a spill instruction+                - If the temporary was previously spilled,+                  generate an instruction to read the temp from its spill loc.+            (optimisation: if we can see that a real register is going to+            be used soon, then don't use it for allocation).++        (b) For each real register clobbered by this instruction:+            If a temporary resides in it,+                If the temporary is live after this instruction,+                    Move the temporary to another (non-clobbered & free) reg,+                    or spill it to memory.  Mark the temporary as residing+                    in both memory and a register if it was spilled (it might+                    need to be read by this instruction).++            (ToDo: this is wrong for jump instructions?)++            We do this after step (a), because if we start with+               movq v1, %rsi+            which is an instruction that clobbers %rsi, if v1 currently resides+            in %rsi we want to get+               movq %rsi, %freereg+               movq %rsi, %rsi     -- will disappear+            instead of+               movq %rsi, %freereg+               movq %freereg, %rsi++        (c) Update the current assignment++        (d) If the instruction is a branch:+              if the destination block already has a register assignment,+                Generate a new block with fixup code and redirect the+                jump to the new block.+              else,+                Update the block id->assignment mapping with the current+                assignment.++        (e) Delete all register assignments for temps which are read+            (only) and die here.  Update the free register list.++        (f) Mark all registers clobbered by this instruction as not free,+            and mark temporaries which have been spilled due to clobbering+            as in memory (step (a) marks then as in both mem & reg).++        (g) For each temporary *written* by this instruction:+            Allocate a real register as for (b), spilling something+            else if necessary.+                - except when updating the assignment, drop any memory+                  locations that the temporary was previously in, since+                  they will be no longer valid after this instruction.++        (h) Delete all register assignments for temps which are+            written and die here (there should rarely be any).  Update+            the free register list.++        (i) Rewrite the instruction with the new mapping.++        (j) For each spilled reg known to be now dead, re-add its stack slot+            to the free list.++-}++module RegAlloc.Linear.Main (+        regAlloc,+        module  RegAlloc.Linear.Base,+        module  RegAlloc.Linear.Stats+  ) where++#include "HsVersions.h"+++import RegAlloc.Linear.State+import RegAlloc.Linear.Base+import RegAlloc.Linear.StackMap+import RegAlloc.Linear.FreeRegs+import RegAlloc.Linear.Stats+import RegAlloc.Linear.JoinToTargets+import qualified RegAlloc.Linear.PPC.FreeRegs    as PPC+import qualified RegAlloc.Linear.SPARC.FreeRegs  as SPARC+import qualified RegAlloc.Linear.X86.FreeRegs    as X86+import qualified RegAlloc.Linear.X86_64.FreeRegs as X86_64+import TargetReg+import RegAlloc.Liveness+import Instruction+import Reg++import BlockId+import Hoopl+import Cmm hiding (RegSet)++import Digraph+import DynFlags+import Unique+import UniqSet+import UniqFM+import UniqSupply+import Outputable+import Platform++import Data.Maybe+import Data.List+import Control.Monad++-- -----------------------------------------------------------------------------+-- Top level of the register allocator++-- Allocate registers+regAlloc+        :: (Outputable instr, Instruction instr)+        => DynFlags+        -> LiveCmmDecl statics instr+        -> UniqSM ( NatCmmDecl statics instr+                  , Maybe Int  -- number of extra stack slots required,+                               -- beyond maxSpillSlots+                  , Maybe RegAllocStats)++regAlloc _ (CmmData sec d)+        = return+                ( CmmData sec d+                , Nothing+                , Nothing )++regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl live [])+        = return ( CmmProc info lbl live (ListGraph [])+                 , Nothing+                 , Nothing )++regAlloc dflags (CmmProc static lbl live sccs)+        | LiveInfo info entry_ids@(first_id:_) (Just block_live) _ <- static+        = do+                -- do register allocation on each component.+                (final_blocks, stats, stack_use)+                        <- linearRegAlloc dflags entry_ids block_live sccs++                -- make sure the block that was first in the input list+                --      stays at the front of the output+                let ((first':_), rest')+                                = partition ((== first_id) . blockId) final_blocks++                let max_spill_slots = maxSpillSlots dflags+                    extra_stack+                      | stack_use > max_spill_slots+                      = Just (stack_use - max_spill_slots)+                      | otherwise+                      = Nothing++                return  ( CmmProc info lbl live (ListGraph (first' : rest'))+                        , extra_stack+                        , Just stats)++-- bogus. to make non-exhaustive match warning go away.+regAlloc _ (CmmProc _ _ _ _)+        = panic "RegAllocLinear.regAlloc: no match"+++-- -----------------------------------------------------------------------------+-- Linear sweep to allocate registers+++-- | Do register allocation on some basic blocks.+--   But be careful to allocate a block in an SCC only if it has+--   an entry in the block map or it is the first block.+--+linearRegAlloc+        :: (Outputable instr, Instruction instr)+        => DynFlags+        -> [BlockId] -- ^ entry points+        -> BlockMap RegSet+              -- ^ live regs on entry to each basic block+        -> [SCC (LiveBasicBlock instr)]+              -- ^ instructions annotated with "deaths"+        -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)++linearRegAlloc dflags entry_ids block_live sccs+ = case platformArch platform of+      ArchX86        -> go $ (frInitFreeRegs platform :: X86.FreeRegs)+      ArchX86_64     -> go $ (frInitFreeRegs platform :: X86_64.FreeRegs)+      ArchSPARC      -> go $ (frInitFreeRegs platform :: SPARC.FreeRegs)+      ArchSPARC64    -> panic "linearRegAlloc ArchSPARC64"+      ArchPPC        -> go $ (frInitFreeRegs platform :: PPC.FreeRegs)+      ArchARM _ _ _  -> panic "linearRegAlloc ArchARM"+      ArchARM64      -> panic "linearRegAlloc ArchARM64"+      ArchPPC_64 _   -> go $ (frInitFreeRegs platform :: PPC.FreeRegs)+      ArchAlpha      -> panic "linearRegAlloc ArchAlpha"+      ArchMipseb     -> panic "linearRegAlloc ArchMipseb"+      ArchMipsel     -> panic "linearRegAlloc ArchMipsel"+      ArchJavaScript -> panic "linearRegAlloc ArchJavaScript"+      ArchUnknown    -> panic "linearRegAlloc ArchUnknown"+ where+  go f = linearRegAlloc' dflags f entry_ids block_live sccs+  platform = targetPlatform dflags++linearRegAlloc'+        :: (FR freeRegs, Outputable instr, Instruction instr)+        => DynFlags+        -> freeRegs+        -> [BlockId]                    -- ^ entry points+        -> BlockMap RegSet              -- ^ live regs on entry to each basic block+        -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"+        -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)++linearRegAlloc' dflags initFreeRegs entry_ids block_live sccs+ = do   us      <- getUniqueSupplyM+        let (_, stack, stats, blocks) =+                runR dflags mapEmpty initFreeRegs emptyRegMap (emptyStackMap dflags) us+                    $ linearRA_SCCs entry_ids block_live [] sccs+        return  (blocks, stats, getStackUse stack)+++linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr)+              => [BlockId]+              -> BlockMap RegSet+              -> [NatBasicBlock instr]+              -> [SCC (LiveBasicBlock instr)]+              -> RegM freeRegs [NatBasicBlock instr]++linearRA_SCCs _ _ blocksAcc []+        = return $ reverse blocksAcc++linearRA_SCCs entry_ids block_live blocksAcc (AcyclicSCC block : sccs)+ = do   blocks' <- processBlock block_live block+        linearRA_SCCs entry_ids block_live+                ((reverse blocks') ++ blocksAcc)+                sccs++linearRA_SCCs entry_ids block_live blocksAcc (CyclicSCC blocks : sccs)+ = do+        blockss' <- process entry_ids block_live blocks [] (return []) False+        linearRA_SCCs entry_ids block_live+                (reverse (concat blockss') ++ blocksAcc)+                sccs++{- from John Dias's patch 2008/10/16:+   The linear-scan allocator sometimes allocates a block+   before allocating one of its predecessors, which could lead to+   inconsistent allocations. Make it so a block is only allocated+   if a predecessor has set the "incoming" assignments for the block, or+   if it's the procedure's entry block.++   BL 2009/02: Careful. If the assignment for a block doesn't get set for+   some reason then this function will loop. We should probably do some+   more sanity checking to guard against this eventuality.+-}++process :: (FR freeRegs, Instruction instr, Outputable instr)+        => [BlockId]+        -> BlockMap RegSet+        -> [GenBasicBlock (LiveInstr instr)]+        -> [GenBasicBlock (LiveInstr instr)]+        -> [[NatBasicBlock instr]]+        -> Bool+        -> RegM freeRegs [[NatBasicBlock instr]]++process _ _ [] []         accum _+        = return $ reverse accum++process entry_ids block_live [] next_round accum madeProgress+        | not madeProgress++          {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming.+             pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out."+                (  text "Unreachable blocks:"+                $$ vcat (map ppr next_round)) -}+        = return $ reverse accum++        | otherwise+        = process entry_ids block_live+                  next_round [] accum False++process entry_ids block_live (b@(BasicBlock id _) : blocks)+        next_round accum madeProgress+ = do+        block_assig <- getBlockAssigR++        if isJust (mapLookup id block_assig)+             || id `elem` entry_ids+         then do+                b'  <- processBlock block_live b+                process entry_ids block_live blocks+                        next_round (b' : accum) True++         else   process entry_ids block_live blocks+                        (b : next_round) accum madeProgress+++-- | Do register allocation on this basic block+--+processBlock+        :: (FR freeRegs, Outputable instr, Instruction instr)+        => BlockMap RegSet              -- ^ live regs on entry to each basic block+        -> LiveBasicBlock instr         -- ^ block to do register allocation on+        -> RegM freeRegs [NatBasicBlock instr]   -- ^ block with registers allocated++processBlock block_live (BasicBlock id instrs)+ = do   initBlock id block_live+        (instrs', fixups)+                <- linearRA block_live [] [] id instrs+        return  $ BasicBlock id instrs' : fixups+++-- | Load the freeregs and current reg assignment into the RegM state+--      for the basic block with this BlockId.+initBlock :: FR freeRegs+          => BlockId -> BlockMap RegSet -> RegM freeRegs ()+initBlock id block_live+ = do   dflags <- getDynFlags+        let platform = targetPlatform dflags+        block_assig     <- getBlockAssigR+        case mapLookup id block_assig of+                -- no prior info about this block: we must consider+                -- any fixed regs to be allocated, but we can ignore+                -- virtual regs (presumably this is part of a loop,+                -- and we'll iterate again).  The assignment begins+                -- empty.+                Nothing+                 -> do  -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ())+                        case mapLookup id block_live of+                          Nothing ->+                            setFreeRegsR    (frInitFreeRegs platform)+                          Just live ->+                            setFreeRegsR $ foldl' (flip $ frAllocateReg platform) (frInitFreeRegs platform)+                                                  [ r | RegReal r <- nonDetEltsUniqSet live ]+                            -- See Note [Unique Determinism and code generation]+                        setAssigR       emptyRegMap++                -- load info about register assignments leading into this block.+                Just (freeregs, assig)+                 -> do  setFreeRegsR    freeregs+                        setAssigR       assig+++-- | Do allocation for a sequence of instructions.+linearRA+        :: (FR freeRegs, Outputable instr, Instruction instr)+        => BlockMap RegSet                      -- ^ map of what vregs are live on entry to each block.+        -> [instr]                              -- ^ accumulator for instructions already processed.+        -> [NatBasicBlock instr]                -- ^ accumulator for blocks of fixup code.+        -> BlockId                              -- ^ id of the current block, for debugging.+        -> [LiveInstr instr]                    -- ^ liveness annotated instructions in this block.++        -> RegM freeRegs+                ( [instr]                       --   instructions after register allocation+                , [NatBasicBlock instr])        --   fresh blocks of fixup code.+++linearRA _          accInstr accFixup _ []+        = return+                ( reverse accInstr              -- instrs need to be returned in the correct order.+                , accFixup)                     -- it doesn't matter what order the fixup blocks are returned in.+++linearRA block_live accInstr accFixups id (instr:instrs)+ = do+        (accInstr', new_fixups) <- raInsn block_live accInstr id instr++        linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs+++-- | Do allocation for a single instruction.+raInsn+        :: (FR freeRegs, Outputable instr, Instruction instr)+        => BlockMap RegSet                      -- ^ map of what vregs are love on entry to each block.+        -> [instr]                              -- ^ accumulator for instructions already processed.+        -> BlockId                              -- ^ the id of the current block, for debugging+        -> LiveInstr instr                      -- ^ the instr to have its regs allocated, with liveness info.+        -> RegM freeRegs+                ( [instr]                       -- new instructions+                , [NatBasicBlock instr])        -- extra fixup blocks++raInsn _     new_instrs _ (LiveInstr ii Nothing)+        | Just n        <- takeDeltaInstr ii+        = do    setDeltaR n+                return (new_instrs, [])++raInsn _     new_instrs _ (LiveInstr ii@(Instr i) Nothing)+        | isMetaInstr ii+        = return (i : new_instrs, [])+++raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live))+ = do+    assig    <- getAssigR++    -- If we have a reg->reg move between virtual registers, where the+    -- src register is not live after this instruction, and the dst+    -- register does not already have an assignment,+    -- and the source register is assigned to a register, not to a spill slot,+    -- then we can eliminate the instruction.+    -- (we can't eliminate it if the source register is on the stack, because+    --  we do not want to use one spill slot for different virtual registers)+    case takeRegRegMoveInstr instr of+        Just (src,dst)  | src `elementOfUniqSet` (liveDieRead live),+                          isVirtualReg dst,+                          not (dst `elemUFM` assig),+                          isRealReg src || isInReg src assig -> do+           case src of+              (RegReal rr) -> setAssigR (addToUFM assig dst (InReg rr))+                -- if src is a fixed reg, then we just map dest to this+                -- reg in the assignment.  src must be an allocatable reg,+                -- otherwise it wouldn't be in r_dying.+              _virt -> case lookupUFM assig src of+                         Nothing -> panic "raInsn"+                         Just loc ->+                           setAssigR (addToUFM (delFromUFM assig src) dst loc)++           -- we have eliminated this instruction+          {-+          freeregs <- getFreeRegsR+          assig <- getAssigR+          pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr)+                        $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do+          -}+           return (new_instrs, [])++        _ -> genRaInsn block_live new_instrs id instr+                        (nonDetEltsUniqSet $ liveDieRead live)+                        (nonDetEltsUniqSet $ liveDieWrite live)+                        -- See Note [Unique Determinism and code generation]++raInsn _ _ _ instr+        = pprPanic "raInsn" (text "no match for:" <> ppr instr)++-- ToDo: what can we do about+--+--     R1 = x+--     jump I64[x] // [R1]+--+-- where x is mapped to the same reg as R1.  We want to coalesce x and+-- R1, but the register allocator doesn't know whether x will be+-- assigned to again later, in which case x and R1 should be in+-- different registers.  Right now we assume the worst, and the+-- assignment to R1 will clobber x, so we'll spill x into another reg,+-- generating another reg->reg move.+++isInReg :: Reg -> RegMap Loc -> Bool+isInReg src assig | Just (InReg _) <- lookupUFM assig src = True+                  | otherwise = False+++genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr)+          => BlockMap RegSet+          -> [instr]+          -> BlockId+          -> instr+          -> [Reg]+          -> [Reg]+          -> RegM freeRegs ([instr], [NatBasicBlock instr])++genRaInsn block_live new_instrs block_id instr r_dying w_dying = do+  dflags <- getDynFlags+  let platform = targetPlatform dflags+  case regUsageOfInstr platform instr of { RU read written ->+    do+    let real_written    = [ rr  | (RegReal     rr) <- written ]+    let virt_written    = [ vr  | (RegVirtual  vr) <- written ]++    -- we don't need to do anything with real registers that are+    -- only read by this instr.  (the list is typically ~2 elements,+    -- so using nub isn't a problem).+    let virt_read       = nub [ vr      | (RegVirtual vr) <- read ]++    -- debugging+{-    freeregs <- getFreeRegsR+    assig    <- getAssigR+    pprDebugAndThen (defaultDynFlags Settings{ sTargetPlatform=platform }) trace "genRaInsn"+        (ppr instr+                $$ text "r_dying      = " <+> ppr r_dying+                $$ text "w_dying      = " <+> ppr w_dying+                $$ text "virt_read    = " <+> ppr virt_read+                $$ text "virt_written = " <+> ppr virt_written+                $$ text "freeregs     = " <+> text (show freeregs)+                $$ text "assig        = " <+> ppr assig)+        $ do+-}++    -- (a), (b) allocate real regs for all regs read by this instruction.+    (r_spills, r_allocd) <-+        allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read++    -- (c) save any temporaries which will be clobbered by this instruction+    clobber_saves <- saveClobberedTemps real_written r_dying++    -- (d) Update block map for new destinations+    -- NB. do this before removing dead regs from the assignment, because+    -- these dead regs might in fact be live in the jump targets (they're+    -- only dead in the code that follows in the current basic block).+    (fixup_blocks, adjusted_instr)+        <- joinToTargets block_live block_id instr++    -- (e) Delete all register assignments for temps which are read+    --     (only) and die here.  Update the free register list.+    releaseRegs r_dying++    -- (f) Mark regs which are clobbered as unallocatable+    clobberRegs real_written++    -- (g) Allocate registers for temporaries *written* (only)+    (w_spills, w_allocd) <-+        allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written++    -- (h) Release registers for temps which are written here and not+    -- used again.+    releaseRegs w_dying++    let+        -- (i) Patch the instruction+        patch_map+                = listToUFM+                        [ (t, RegReal r)+                                | (t, r) <- zip virt_read    r_allocd+                                         ++ zip virt_written w_allocd ]++        patched_instr+                = patchRegsOfInstr adjusted_instr patchLookup++        patchLookup x+                = case lookupUFM patch_map x of+                        Nothing -> x+                        Just y  -> y+++    -- (j) free up stack slots for dead spilled regs+    -- TODO (can't be bothered right now)++    -- erase reg->reg moves where the source and destination are the same.+    --  If the src temp didn't die in this instr but happened to be allocated+    --  to the same real reg as the destination, then we can erase the move anyway.+    let squashed_instr  = case takeRegRegMoveInstr patched_instr of+                                Just (src, dst)+                                 | src == dst   -> []+                                _               -> [patched_instr]++    let code = squashed_instr ++ w_spills ++ reverse r_spills+                ++ clobber_saves ++ new_instrs++--    pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do+--    pprTrace "pached-fixup" ((ppr fixup_blocks)) $ do++    return (code, fixup_blocks)++  }++-- -----------------------------------------------------------------------------+-- releaseRegs++releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs ()+releaseRegs regs = do+  dflags <- getDynFlags+  let platform = targetPlatform dflags+  assig <- getAssigR+  free <- getFreeRegsR+  let loop assig !free [] = do setAssigR assig; setFreeRegsR free; return ()+      loop assig !free (RegReal rr : rs) = loop assig (frReleaseReg platform rr free) rs+      loop assig !free (r:rs) =+         case lookupUFM assig r of+         Just (InBoth real _) -> loop (delFromUFM assig r)+                                      (frReleaseReg platform real free) rs+         Just (InReg real)    -> loop (delFromUFM assig r)+                                      (frReleaseReg platform real free) rs+         _                    -> loop (delFromUFM assig r) free rs+  loop assig free regs+++-- -----------------------------------------------------------------------------+-- Clobber real registers++-- For each temp in a register that is going to be clobbered:+--      - if the temp dies after this instruction, do nothing+--      - otherwise, put it somewhere safe (another reg if possible,+--              otherwise spill and record InBoth in the assignment).+--      - for allocateRegs on the temps *read*,+--      - clobbered regs are allocatable.+--+--      for allocateRegs on the temps *written*,+--        - clobbered regs are not allocatable.+--++saveClobberedTemps+        :: (Instruction instr, FR freeRegs)+        => [RealReg]            -- real registers clobbered by this instruction+        -> [Reg]                -- registers which are no longer live after this insn+        -> RegM freeRegs [instr]         -- return: instructions to spill any temps that will+                                -- be clobbered.++saveClobberedTemps [] _+        = return []++saveClobberedTemps clobbered dying+ = do+        assig   <- getAssigR+        let to_spill+                = [ (temp,reg)+                        | (temp, InReg reg) <- nonDetUFMToList assig+                        -- This is non-deterministic but we do not+                        -- currently support deterministic code-generation.+                        -- See Note [Unique Determinism and code generation]+                        , any (realRegsAlias reg) clobbered+                        , temp `notElem` map getUnique dying  ]++        (instrs,assig') <- clobber assig [] to_spill+        setAssigR assig'+        return instrs++   where+     clobber assig instrs []+            = return (instrs, assig)++     clobber assig instrs ((temp, reg) : rest)+       = do dflags <- getDynFlags+            let platform = targetPlatform dflags++            freeRegs <- getFreeRegsR+            let regclass = targetClassOfRealReg platform reg+                freeRegs_thisClass = frGetFreeRegs platform regclass freeRegs++            case filter (`notElem` clobbered) freeRegs_thisClass of++              -- (1) we have a free reg of the right class that isn't+              -- clobbered by this instruction; use it to save the+              -- clobbered value.+              (my_reg : _) -> do+                  setFreeRegsR (frAllocateReg platform my_reg freeRegs)++                  let new_assign = addToUFM assig temp (InReg my_reg)+                  let instr = mkRegRegMoveInstr platform+                                  (RegReal reg) (RegReal my_reg)++                  clobber new_assign (instr : instrs) rest++              -- (2) no free registers: spill the value+              [] -> do+                  (spill, slot)   <- spillR (RegReal reg) temp++                  -- record why this reg was spilled for profiling+                  recordSpill (SpillClobber temp)++                  let new_assign  = addToUFM assig temp (InBoth reg slot)++                  clobber new_assign (spill : instrs) rest++++-- | Mark all these real regs as allocated,+--      and kick out their vreg assignments.+--+clobberRegs :: FR freeRegs => [RealReg] -> RegM freeRegs ()+clobberRegs []+        = return ()++clobberRegs clobbered+ = do   dflags <- getDynFlags+        let platform = targetPlatform dflags++        freeregs        <- getFreeRegsR+        setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs clobbered++        assig           <- getAssigR+        setAssigR $! clobber assig (nonDetUFMToList assig)+          -- This is non-deterministic but we do not+          -- currently support deterministic code-generation.+          -- See Note [Unique Determinism and code generation]++   where+        -- if the temp was InReg and clobbered, then we will have+        -- saved it in saveClobberedTemps above.  So the only case+        -- we have to worry about here is InBoth.  Note that this+        -- also catches temps which were loaded up during allocation+        -- of read registers, not just those saved in saveClobberedTemps.++        clobber assig []+                = assig++        clobber assig ((temp, InBoth reg slot) : rest)+                | any (realRegsAlias reg) clobbered+                = clobber (addToUFM assig temp (InMem slot)) rest++        clobber assig (_:rest)+                = clobber assig rest++-- -----------------------------------------------------------------------------+-- allocateRegsAndSpill++-- Why are we performing a spill?+data SpillLoc = ReadMem StackSlot  -- reading from register only in memory+              | WriteNew           -- writing to a new variable+              | WriteMem           -- writing to register only in memory+-- Note that ReadNew is not valid, since you don't want to be reading+-- from an uninitialized register.  We also don't need the location of+-- the register in memory, since that will be invalidated by the write.+-- Technically, we could coalesce WriteNew and WriteMem into a single+-- entry as well. -- EZY++-- This function does several things:+--   For each temporary referred to by this instruction,+--   we allocate a real register (spilling another temporary if necessary).+--   We load the temporary up from memory if necessary.+--   We also update the register assignment in the process, and+--   the list of free registers and free stack slots.++allocateRegsAndSpill+        :: (FR freeRegs, Outputable instr, Instruction instr)+        => Bool                 -- True <=> reading (load up spilled regs)+        -> [VirtualReg]         -- don't push these out+        -> [instr]              -- spill insns+        -> [RealReg]            -- real registers allocated (accum.)+        -> [VirtualReg]         -- temps to allocate+        -> RegM freeRegs ( [instr] , [RealReg])++allocateRegsAndSpill _       _    spills alloc []+        = return (spills, reverse alloc)++allocateRegsAndSpill reading keep spills alloc (r:rs)+ = do   assig <- getAssigR+        let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig+        case lookupUFM assig r of+                -- case (1a): already in a register+                Just (InReg my_reg) ->+                        allocateRegsAndSpill reading keep spills (my_reg:alloc) rs++                -- case (1b): already in a register (and memory)+                -- NB1. if we're writing this register, update its assignment to be+                -- InReg, because the memory value is no longer valid.+                -- NB2. This is why we must process written registers here, even if they+                -- are also read by the same instruction.+                Just (InBoth my_reg _)+                 -> do  when (not reading) (setAssigR (addToUFM assig r (InReg my_reg)))+                        allocateRegsAndSpill reading keep spills (my_reg:alloc) rs++                -- Not already in a register, so we need to find a free one...+                Just (InMem slot) | reading   -> doSpill (ReadMem slot)+                                  | otherwise -> doSpill WriteMem+                Nothing | reading   ->+                   pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r)+                   -- NOTE: if the input to the NCG contains some+                   -- unreachable blocks with junk code, this panic+                   -- might be triggered.  Make sure you only feed+                   -- sensible code into the NCG.  In CmmPipeline we+                   -- call removeUnreachableBlocks at the end for this+                   -- reason.++                        | otherwise -> doSpill WriteNew+++-- reading is redundant with reason, but we keep it around because it's+-- convenient and it maintains the recursive structure of the allocator. -- EZY+allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr)+                        => Bool+                        -> [VirtualReg]+                        -> [instr]+                        -> [RealReg]+                        -> VirtualReg+                        -> [VirtualReg]+                        -> UniqFM Loc+                        -> SpillLoc+                        -> RegM freeRegs ([instr], [RealReg])+allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc+ = do   dflags <- getDynFlags+        let platform = targetPlatform dflags+        freeRegs                <- getFreeRegsR+        let freeRegs_thisClass  = frGetFreeRegs platform (classOfVirtualReg r) freeRegs++        case freeRegs_thisClass of++         -- case (2): we have a free register+         (my_reg : _) ->+           do   spills'   <- loadTemp r spill_loc my_reg spills++                setAssigR       (addToUFM assig r $! newLocation spill_loc my_reg)+                setFreeRegsR $  frAllocateReg platform my_reg freeRegs++                allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs+++          -- case (3): we need to push something out to free up a register+         [] ->+           do   let keep' = map getUnique keep++                -- the vregs we could kick out that are already in a slot+                let candidates_inBoth+                        = [ (temp, reg, mem)+                          | (temp, InBoth reg mem) <- nonDetUFMToList assig+                          -- This is non-deterministic but we do not+                          -- currently support deterministic code-generation.+                          -- See Note [Unique Determinism and code generation]+                          , temp `notElem` keep'+                          , targetClassOfRealReg platform reg == classOfVirtualReg r ]++                -- the vregs we could kick out that are only in a reg+                --      this would require writing the reg to a new slot before using it.+                let candidates_inReg+                        = [ (temp, reg)+                          | (temp, InReg reg) <- nonDetUFMToList assig+                          -- This is non-deterministic but we do not+                          -- currently support deterministic code-generation.+                          -- See Note [Unique Determinism and code generation]+                          , temp `notElem` keep'+                          , targetClassOfRealReg platform reg == classOfVirtualReg r ]++                let result++                        -- we have a temporary that is in both register and mem,+                        -- just free up its register for use.+                        | (temp, my_reg, slot) : _      <- candidates_inBoth+                        = do    spills' <- loadTemp r spill_loc my_reg spills+                                let assig1  = addToUFM assig temp (InMem slot)+                                let assig2  = addToUFM assig1 r $! newLocation spill_loc my_reg++                                setAssigR assig2+                                allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs++                        -- otherwise, we need to spill a temporary that currently+                        -- resides in a register.+                        | (temp_to_push_out, (my_reg :: RealReg)) : _+                                        <- candidates_inReg+                        = do+                                (spill_insn, slot) <- spillR (RegReal my_reg) temp_to_push_out+                                let spill_store  = (if reading then id else reverse)+                                                        [ -- COMMENT (fsLit "spill alloc")+                                                           spill_insn ]++                                -- record that this temp was spilled+                                recordSpill (SpillAlloc temp_to_push_out)++                                -- update the register assignment+                                let assig1  = addToUFM assig temp_to_push_out   (InMem slot)+                                let assig2  = addToUFM assig1 r                 $! newLocation spill_loc my_reg+                                setAssigR assig2++                                -- if need be, load up a spilled temp into the reg we've just freed up.+                                spills' <- loadTemp r spill_loc my_reg spills++                                allocateRegsAndSpill reading keep+                                        (spill_store ++ spills')+                                        (my_reg:alloc) rs+++                        -- there wasn't anything to spill, so we're screwed.+                        | otherwise+                        = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n")+                        $ vcat+                                [ text "allocating vreg:  " <> text (show r)+                                , text "assignment:       " <> ppr assig+                                , text "freeRegs:         " <> text (show freeRegs)+                                , text "initFreeRegs:     " <> text (show (frInitFreeRegs platform `asTypeOf` freeRegs)) ]++                result+++-- | Calculate a new location after a register has been loaded.+newLocation :: SpillLoc -> RealReg -> Loc+-- if the tmp was read from a slot, then now its in a reg as well+newLocation (ReadMem slot) my_reg = InBoth my_reg slot+-- writes will always result in only the register being available+newLocation _ my_reg = InReg my_reg++-- | Load up a spilled temporary if we need to (read from memory).+loadTemp+        :: (Instruction instr)+        => VirtualReg   -- the temp being loaded+        -> SpillLoc     -- the current location of this temp+        -> RealReg      -- the hreg to load the temp into+        -> [instr]+        -> RegM freeRegs [instr]++loadTemp vreg (ReadMem slot) hreg spills+ = do+        insn <- loadR (RegReal hreg) slot+        recordSpill (SpillLoad $ getUnique vreg)+        return  $  {- COMMENT (fsLit "spill load") : -} insn : spills++loadTemp _ _ _ spills =+   return spills+
+ nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs view
@@ -0,0 +1,60 @@+-- | Free regs map for PowerPC+module RegAlloc.Linear.PPC.FreeRegs+where++import PPC.Regs+import RegClass+import Reg++import Outputable+import Platform++import Data.Word+import Data.Bits+import Data.Foldable (foldl')++-- The PowerPC has 32 integer and 32 floating point registers.+-- This is 32bit PowerPC, so Word64 is inefficient - two Word32s are much+-- better.+-- Note that when getFreeRegs scans for free registers, it starts at register+-- 31 and counts down. This is a hack for the PowerPC - the higher-numbered+-- registers are callee-saves, while the lower regs are caller-saves, so it+-- makes sense to start at the high end.+-- Apart from that, the code does nothing PowerPC-specific, so feel free to+-- add your favourite platform to the #if (if you have 64 registers but only+-- 32-bit words).++data FreeRegs = FreeRegs !Word32 !Word32+              deriving( Show )  -- The Show is used in an ASSERT++noFreeRegs :: FreeRegs+noFreeRegs = FreeRegs 0 0++releaseReg :: RealReg -> FreeRegs -> FreeRegs+releaseReg (RealRegSingle r) (FreeRegs g f)+    | r > 31    = FreeRegs g (f .|. (1 `shiftL` (r - 32)))+    | otherwise = FreeRegs (g .|. (1 `shiftL` r)) f++releaseReg _ _+        = panic "RegAlloc.Linear.PPC.releaseReg: bad reg"++initFreeRegs :: Platform -> FreeRegs+initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)++getFreeRegs :: RegClass -> FreeRegs -> [RealReg]        -- lazily+getFreeRegs cls (FreeRegs g f)+    | RcDouble <- cls = go f (0x80000000) 63+    | RcInteger <- cls = go g (0x80000000) 31+    | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class" (ppr cls)+    where+        go _ 0 _ = []+        go x m i | x .&. m /= 0 = RealRegSingle i : (go x (m `shiftR` 1) $! i-1)+                 | otherwise    = go x (m `shiftR` 1) $! i-1++allocateReg :: RealReg -> FreeRegs -> FreeRegs+allocateReg (RealRegSingle r) (FreeRegs g f)+    | r > 31    = FreeRegs g (f .&. complement (1 `shiftL` (r - 32)))+    | otherwise = FreeRegs (g .&. complement (1 `shiftL` r)) f++allocateReg _ _+        = panic "RegAlloc.Linear.PPC.allocateReg: bad reg"
+ nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs view
@@ -0,0 +1,186 @@++-- | Free regs map for SPARC+module RegAlloc.Linear.SPARC.FreeRegs+where++import SPARC.Regs+import RegClass+import Reg++import CodeGen.Platform+import Outputable+import Platform++import Data.Word+import Data.Bits+import Data.Foldable (foldl')+++--------------------------------------------------------------------------------+-- SPARC is like PPC, except for twinning of floating point regs.+--      When we allocate a double reg we must take an even numbered+--      float reg, as well as the one after it.+++-- Holds bitmaps showing what registers are currently allocated.+--      The float and double reg bitmaps overlap, but we only alloc+--      float regs into the float map, and double regs into the double map.+--+--      Free regs have a bit set in the corresponding bitmap.+--+data FreeRegs+        = FreeRegs+                !Word32         -- int    reg bitmap    regs  0..31+                !Word32         -- float  reg bitmap    regs 32..63+                !Word32         -- double reg bitmap    regs 32..63++instance Show FreeRegs where+        show = showFreeRegs++-- | A reg map where no regs are free to be allocated.+noFreeRegs :: FreeRegs+noFreeRegs = FreeRegs 0 0 0+++-- | The initial set of free regs.+initFreeRegs :: Platform -> FreeRegs+initFreeRegs platform+ =      foldl' (flip $ releaseReg platform) noFreeRegs allocatableRegs+++-- | Get all the free registers of this class.+getFreeRegs :: RegClass -> FreeRegs -> [RealReg]        -- lazily+getFreeRegs cls (FreeRegs g f d)+        | RcInteger <- cls = map RealRegSingle                  $ go 1 g 1 0+        | RcFloat   <- cls = map RealRegSingle                  $ go 1 f 1 32+        | RcDouble  <- cls = map (\i -> RealRegPair i (i+1))    $ go 2 d 1 32+        | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class " (ppr cls)+        where+                go _    _      0    _+                        = []++                go step bitmap mask ix+                        | bitmap .&. mask /= 0+                        = ix : (go step bitmap (mask `shiftL` step) $! ix + step)++                        | otherwise+                        = go step bitmap (mask `shiftL` step) $! ix + step+++-- | Grab a register.+allocateReg :: Platform -> RealReg -> FreeRegs -> FreeRegs+allocateReg platform+         reg@(RealRegSingle r)+             (FreeRegs g f d)++        -- can't allocate free regs+        | not $ freeReg platform r+        = pprPanic "SPARC.FreeRegs.allocateReg: not allocating pinned reg" (ppr reg)++        -- a general purpose reg+        | r <= 31+        = let   mask    = complement (bitMask r)+          in    FreeRegs+                        (g .&. mask)+                        f+                        d++        -- a float reg+        | r >= 32, r <= 63+        = let   mask    = complement (bitMask (r - 32))++                -- the mask of the double this FP reg aliases+                maskLow = if r `mod` 2 == 0+                                then complement (bitMask (r - 32))+                                else complement (bitMask (r - 32 - 1))+          in    FreeRegs+                        g+                        (f .&. mask)+                        (d .&. maskLow)++        | otherwise+        = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg)++allocateReg _+         reg@(RealRegPair r1 r2)+             (FreeRegs g f d)++        | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0+        , r2 >= 32, r2 <= 63+        = let   mask1   = complement (bitMask (r1 - 32))+                mask2   = complement (bitMask (r2 - 32))+          in+                FreeRegs+                        g+                        ((f .&. mask1) .&. mask2)+                        (d .&. mask1)++        | otherwise+        = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg)++++-- | Release a register from allocation.+--      The register liveness information says that most regs die after a C call,+--      but we still don't want to allocate to some of them.+--+releaseReg :: Platform -> RealReg -> FreeRegs -> FreeRegs+releaseReg platform+         reg@(RealRegSingle r)+        regs@(FreeRegs g f d)++        -- don't release pinned reg+        | not $ freeReg platform r+        = regs++        -- a general purpose reg+        | r <= 31+        = let   mask    = bitMask r+          in    FreeRegs (g .|. mask) f d++        -- a float reg+        | r >= 32, r <= 63+        = let   mask    = bitMask (r - 32)++                -- the mask of the double this FP reg aliases+                maskLow = if r `mod` 2 == 0+                                then bitMask (r - 32)+                                else bitMask (r - 32 - 1)+          in    FreeRegs+                        g+                        (f .|. mask)+                        (d .|. maskLow)++        | otherwise+        = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg)++releaseReg _+         reg@(RealRegPair r1 r2)+             (FreeRegs g f d)++        | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0+        , r2 >= 32, r2 <= 63+        = let   mask1   = bitMask (r1 - 32)+                mask2   = bitMask (r2 - 32)+          in+                FreeRegs+                        g+                        ((f .|. mask1) .|. mask2)+                        (d .|. mask1)++        | otherwise+        = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg)++++bitMask :: Int -> Word32+bitMask n       = 1 `shiftL` n+++showFreeRegs :: FreeRegs -> String+showFreeRegs regs+        =  "FreeRegs\n"+        ++ "    integer: " ++ (show $ getFreeRegs RcInteger regs)       ++ "\n"+        ++ "      float: " ++ (show $ getFreeRegs RcFloat   regs)       ++ "\n"+        ++ "     double: " ++ (show $ getFreeRegs RcDouble  regs)       ++ "\n"+
+ nativeGen/RegAlloc/Linear/StackMap.hs view
@@ -0,0 +1,59 @@++-- | The assignment of virtual registers to stack slots++--      We have lots of stack slots. Memory-to-memory moves are a pain on most+--      architectures. Therefore, we avoid having to generate memory-to-memory moves+--      by simply giving every virtual register its own stack slot.++--      The StackMap stack map keeps track of virtual register - stack slot+--      associations and of which stack slots are still free. Once it has been+--      associated, a stack slot is never "freed" or removed from the StackMap again,+--      it remains associated until we are done with the current CmmProc.+--+module RegAlloc.Linear.StackMap (+        StackSlot,+        StackMap(..),+        emptyStackMap,+        getStackSlotFor,+        getStackUse+)++where++import DynFlags+import UniqFM+import Unique+++-- | Identifier for a stack slot.+type StackSlot = Int++data StackMap+        = StackMap+        { -- | The slots that are still available to be allocated.+          stackMapNextFreeSlot  :: !Int++          -- | Assignment of vregs to stack slots.+        , stackMapAssignment    :: UniqFM StackSlot }+++-- | An empty stack map, with all slots available.+emptyStackMap :: DynFlags -> StackMap+emptyStackMap _ = StackMap 0 emptyUFM+++-- | If this vreg unique already has a stack assignment then return the slot number,+--      otherwise allocate a new slot, and update the map.+--+getStackSlotFor :: StackMap -> Unique -> (StackMap, Int)++getStackSlotFor fs@(StackMap _ reserved) reg+  | Just slot <- lookupUFM reserved reg  =  (fs, slot)++getStackSlotFor (StackMap freeSlot reserved) reg =+    (StackMap (freeSlot+1) (addToUFM reserved reg freeSlot), freeSlot)++-- | Return the number of stack slots that were allocated+getStackUse :: StackMap -> Int+getStackUse (StackMap freeSlot _) = freeSlot+
+ nativeGen/RegAlloc/Linear/State.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE UnboxedTuples #-}++-- | State monad for the linear register allocator.++--      Here we keep all the state that the register allocator keeps track+--      of as it walks the instructions in a basic block.++module RegAlloc.Linear.State (+        RA_State(..),+        RegM,+        runR,++        spillR,+        loadR,++        getFreeRegsR,+        setFreeRegsR,++        getAssigR,+        setAssigR,++        getBlockAssigR,+        setBlockAssigR,++        setDeltaR,+        getDeltaR,++        getUniqueR,++        recordSpill+)+where++import RegAlloc.Linear.Stats+import RegAlloc.Linear.StackMap+import RegAlloc.Linear.Base+import RegAlloc.Liveness+import Instruction+import Reg++import DynFlags+import Unique+import UniqSupply++import Control.Monad (liftM, ap)++-- | The register allocator monad type.+newtype RegM freeRegs a+        = RegM { unReg :: RA_State freeRegs -> (# RA_State freeRegs, a #) }++instance Functor (RegM freeRegs) where+      fmap = liftM++instance Applicative (RegM freeRegs) where+      pure a  =  RegM $ \s -> (# s, a #)+      (<*>) = ap++instance Monad (RegM freeRegs) where+  m >>= k   =  RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s }++instance HasDynFlags (RegM a) where+    getDynFlags = RegM $ \s -> (# s, ra_DynFlags s #)+++-- | Run a computation in the RegM register allocator monad.+runR    :: DynFlags+        -> BlockAssignment freeRegs+        -> freeRegs+        -> RegMap Loc+        -> StackMap+        -> UniqSupply+        -> RegM freeRegs a+        -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a)++runR dflags block_assig freeregs assig stack us thing =+  case unReg thing+        (RA_State+                { ra_blockassig = block_assig+                , ra_freeregs   = freeregs+                , ra_assig      = assig+                , ra_delta      = 0{-???-}+                , ra_stack      = stack+                , ra_us         = us+                , ra_spills     = []+                , ra_DynFlags   = dflags })+   of+        (# state'@RA_State+                { ra_blockassig = block_assig+                , ra_stack      = stack' }+                , returned_thing #)++         ->     (block_assig, stack', makeRAStats state', returned_thing)+++-- | Make register allocator stats from its final state.+makeRAStats :: RA_State freeRegs -> RegAllocStats+makeRAStats state+        = RegAllocStats+        { ra_spillInstrs        = binSpillReasons (ra_spills state) }+++spillR :: Instruction instr+       => Reg -> Unique -> RegM freeRegs (instr, Int)++spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->+  let dflags = ra_DynFlags s+      (stack',slot) = getStackSlotFor stack temp+      instr  = mkSpillInstr dflags reg delta slot+  in+  (# s{ra_stack=stack'}, (instr,slot) #)+++loadR :: Instruction instr+      => Reg -> Int -> RegM freeRegs instr++loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} ->+  let dflags = ra_DynFlags s+  in (# s, mkLoadInstr dflags reg delta slot #)++getFreeRegsR :: RegM freeRegs freeRegs+getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->+  (# s, freeregs #)++setFreeRegsR :: freeRegs -> RegM freeRegs ()+setFreeRegsR regs = RegM $ \ s ->+  (# s{ra_freeregs = regs}, () #)++getAssigR :: RegM freeRegs (RegMap Loc)+getAssigR = RegM $ \ s@RA_State{ra_assig = assig} ->+  (# s, assig #)++setAssigR :: RegMap Loc -> RegM freeRegs ()+setAssigR assig = RegM $ \ s ->+  (# s{ra_assig=assig}, () #)++getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs)+getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->+  (# s, assig #)++setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs ()+setBlockAssigR assig = RegM $ \ s ->+  (# s{ra_blockassig = assig}, () #)++setDeltaR :: Int -> RegM freeRegs ()+setDeltaR n = RegM $ \ s ->+  (# s{ra_delta = n}, () #)++getDeltaR :: RegM freeRegs Int+getDeltaR = RegM $ \s -> (# s, ra_delta s #)++getUniqueR :: RegM freeRegs Unique+getUniqueR = RegM $ \s ->+  case takeUniqFromSupply (ra_us s) of+    (uniq, us) -> (# s{ra_us = us}, uniq #)+++-- | Record that a spill instruction was inserted, for profiling.+recordSpill :: SpillReason -> RegM freeRegs ()+recordSpill spill+    = RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #)+
+ nativeGen/RegAlloc/Linear/Stats.hs view
@@ -0,0 +1,86 @@+module RegAlloc.Linear.Stats (+        binSpillReasons,+        countRegRegMovesNat,+        pprStats+)++where++import RegAlloc.Linear.Base+import RegAlloc.Liveness+import Instruction++import UniqFM+import Outputable++import Data.List+import State++-- | Build a map of how many times each reg was alloced, clobbered, loaded etc.+binSpillReasons+        :: [SpillReason] -> UniqFM [Int]++binSpillReasons reasons+        = addListToUFM_C+                (zipWith (+))+                emptyUFM+                (map (\reason -> case reason of+                        SpillAlloc r    -> (r, [1, 0, 0, 0, 0])+                        SpillClobber r  -> (r, [0, 1, 0, 0, 0])+                        SpillLoad r     -> (r, [0, 0, 1, 0, 0])+                        SpillJoinRR r   -> (r, [0, 0, 0, 1, 0])+                        SpillJoinRM r   -> (r, [0, 0, 0, 0, 1])) reasons)+++-- | Count reg-reg moves remaining in this code.+countRegRegMovesNat+        :: Instruction instr+        => NatCmmDecl statics instr -> Int++countRegRegMovesNat cmm+        = execState (mapGenBlockTopM countBlock cmm) 0+ where+        countBlock b@(BasicBlock _ instrs)+         = do   mapM_ countInstr instrs+                return  b++        countInstr instr+                | Just _        <- takeRegRegMoveInstr instr+                = do    modify (+ 1)+                        return instr++                | otherwise+                =       return instr+++-- | Pretty print some RegAllocStats+pprStats+        :: Instruction instr+        => [NatCmmDecl statics instr] -> [RegAllocStats] -> SDoc++pprStats code statss+ = let  -- sum up all the instrs inserted by the spiller+        spills          = foldl' (plusUFM_C (zipWith (+)))+                                emptyUFM+                        $ map ra_spillInstrs statss++        spillTotals     = foldl' (zipWith (+))+                                [0, 0, 0, 0, 0]+                        $ nonDetEltsUFM spills+                        -- See Note [Unique Determinism and code generation]++        -- count how many reg-reg-moves remain in the code+        moves           = sum $ map countRegRegMovesNat code++        pprSpill (reg, spills)+                = parens $ (hcat $ punctuate (text ", ")  (doubleQuotes (ppr reg) : map ppr spills))++   in   (  text "-- spills-added-total"+        $$ text "--    (allocs, clobbers, loads, joinRR, joinRM, reg_reg_moves_remaining)"+        $$ (parens $ (hcat $ punctuate (text ", ") (map ppr spillTotals ++ [ppr moves])))+        $$ text ""+        $$ text "-- spills-added"+        $$ text "--    (reg_name, allocs, clobbers, loads, joinRR, joinRM)"+        $$ (pprUFMWithKeys spills (vcat . map pprSpill))+        $$ text "")+
+ nativeGen/RegAlloc/Linear/X86/FreeRegs.hs view
@@ -0,0 +1,52 @@++-- | Free regs map for i386+module RegAlloc.Linear.X86.FreeRegs+where++import X86.Regs+import RegClass+import Reg+import Panic+import Platform++import Data.Word+import Data.Bits+import Data.Foldable (foldl')++newtype FreeRegs = FreeRegs Word32+    deriving Show++noFreeRegs :: FreeRegs+noFreeRegs = FreeRegs 0++releaseReg :: RealReg -> FreeRegs -> FreeRegs+releaseReg (RealRegSingle n) (FreeRegs f)+        = FreeRegs (f .|. (1 `shiftL` n))++releaseReg _ _+        = panic "RegAlloc.Linear.X86.FreeRegs.releaseReg: no reg"++initFreeRegs :: Platform -> FreeRegs+initFreeRegs platform+        = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)++getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily+getFreeRegs platform cls (FreeRegs f) = go f 0++  where go 0 _ = []+        go n m+          | n .&. 1 /= 0 && classOfRealReg platform (RealRegSingle m) == cls+          = RealRegSingle m : (go (n `shiftR` 1) $! (m+1))++          | otherwise+          = go (n `shiftR` 1) $! (m+1)+        -- ToDo: there's no point looking through all the integer registers+        -- in order to find a floating-point one.++allocateReg :: RealReg -> FreeRegs -> FreeRegs+allocateReg (RealRegSingle r) (FreeRegs f)+        = FreeRegs (f .&. complement (1 `shiftL` r))++allocateReg _ _+        = panic "RegAlloc.Linear.X86.FreeRegs.allocateReg: no reg"+
+ nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs view
@@ -0,0 +1,53 @@++-- | Free regs map for x86_64+module RegAlloc.Linear.X86_64.FreeRegs+where++import X86.Regs+import RegClass+import Reg+import Panic+import Platform++import Data.Foldable (foldl')+import Data.Word+import Data.Bits++newtype FreeRegs = FreeRegs Word64+    deriving Show++noFreeRegs :: FreeRegs+noFreeRegs = FreeRegs 0++releaseReg :: RealReg -> FreeRegs -> FreeRegs+releaseReg (RealRegSingle n) (FreeRegs f)+        = FreeRegs (f .|. (1 `shiftL` n))++releaseReg _ _+        = panic "RegAlloc.Linear.X86_64.FreeRegs.releaseReg: no reg"++initFreeRegs :: Platform -> FreeRegs+initFreeRegs platform+        = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)++getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily+getFreeRegs platform cls (FreeRegs f) = go f 0++  where go 0 _ = []+        go n m+          | n .&. 1 /= 0 && classOfRealReg platform (RealRegSingle m) == cls+          = RealRegSingle m : (go (n `shiftR` 1) $! (m+1))++          | otherwise+          = go (n `shiftR` 1) $! (m+1)+        -- ToDo: there's no point looking through all the integer registers+        -- in order to find a floating-point one.++allocateReg :: RealReg -> FreeRegs -> FreeRegs+allocateReg (RealRegSingle r) (FreeRegs f)+        = FreeRegs (f .&. complement (1 `shiftL` r))++allocateReg _ _+        = panic "RegAlloc.Linear.X86_64.FreeRegs.allocateReg: no reg"++
+ nativeGen/RegAlloc/Liveness.hs view
@@ -0,0 +1,1009 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++-----------------------------------------------------------------------------+--+-- The register liveness determinator+--+-- (c) The University of Glasgow 2004-2013+--+-----------------------------------------------------------------------------++module RegAlloc.Liveness (+        RegSet,+        RegMap, emptyRegMap,+        BlockMap, mapEmpty,+        LiveCmmDecl,+        InstrSR   (..),+        LiveInstr (..),+        Liveness (..),+        LiveInfo (..),+        LiveBasicBlock,++        mapBlockTop,    mapBlockTopM,   mapSCCM,+        mapGenBlockTop, mapGenBlockTopM,+        stripLive,+        stripLiveBlock,+        slurpConflicts,+        slurpReloadCoalesce,+        eraseDeltasLive,+        patchEraseLive,+        patchRegsLiveInstr,+        reverseBlocksInTops,+        regLiveness,+        natCmmTopToLive+  ) where+import Reg+import Instruction++import BlockId+import Hoopl+import Cmm hiding (RegSet, emptyRegSet)+import PprCmm()++import Digraph+import DynFlags+import MonadUtils+import Outputable+import Platform+import UniqSet+import UniqFM+import UniqSupply+import Bag+import State++import Data.List+import Data.Maybe+import Data.IntSet              (IntSet)++-----------------------------------------------------------------------------+type RegSet = UniqSet Reg++type RegMap a = UniqFM a++emptyRegMap :: UniqFM a+emptyRegMap = emptyUFM++emptyRegSet :: RegSet+emptyRegSet = emptyUniqSet++type BlockMap a = LabelMap a+++-- | A top level thing which carries liveness information.+type LiveCmmDecl statics instr+        = GenCmmDecl+                statics+                LiveInfo+                [SCC (LiveBasicBlock instr)]+++-- | The register allocator also wants to use SPILL/RELOAD meta instructions,+--   so we'll keep those here.+data InstrSR instr+        -- | A real machine instruction+        = Instr  instr++        -- | spill this reg to a stack slot+        | SPILL  Reg Int++        -- | reload this reg from a stack slot+        | RELOAD Int Reg++instance Instruction instr => Instruction (InstrSR instr) where+        regUsageOfInstr platform i+         = case i of+                Instr  instr    -> regUsageOfInstr platform instr+                SPILL  reg _    -> RU [reg] []+                RELOAD _ reg    -> RU [] [reg]++        patchRegsOfInstr i f+         = case i of+                Instr instr     -> Instr (patchRegsOfInstr instr f)+                SPILL  reg slot -> SPILL (f reg) slot+                RELOAD slot reg -> RELOAD slot (f reg)++        isJumpishInstr i+         = case i of+                Instr instr     -> isJumpishInstr instr+                _               -> False++        jumpDestsOfInstr i+         = case i of+                Instr instr     -> jumpDestsOfInstr instr+                _               -> []++        patchJumpInstr i f+         = case i of+                Instr instr     -> Instr (patchJumpInstr instr f)+                _               -> i++        mkSpillInstr            = error "mkSpillInstr[InstrSR]: Not making SPILL meta-instr"+        mkLoadInstr             = error "mkLoadInstr[InstrSR]: Not making LOAD meta-instr"++        takeDeltaInstr i+         = case i of+                Instr instr     -> takeDeltaInstr instr+                _               -> Nothing++        isMetaInstr i+         = case i of+                Instr instr     -> isMetaInstr instr+                _               -> False++        mkRegRegMoveInstr platform r1 r2+            = Instr (mkRegRegMoveInstr platform r1 r2)++        takeRegRegMoveInstr i+         = case i of+                Instr instr     -> takeRegRegMoveInstr instr+                _               -> Nothing++        mkJumpInstr target      = map Instr (mkJumpInstr target)++        mkStackAllocInstr platform amount =+             Instr (mkStackAllocInstr platform amount)++        mkStackDeallocInstr platform amount =+             Instr (mkStackDeallocInstr platform amount)+++-- | An instruction with liveness information.+data LiveInstr instr+        = LiveInstr (InstrSR instr) (Maybe Liveness)++-- | Liveness information.+--   The regs which die are ones which are no longer live in the *next* instruction+--   in this sequence.+--   (NB. if the instruction is a jump, these registers might still be live+--   at the jump target(s) - you have to check the liveness at the destination+--   block to find out).++data Liveness+        = Liveness+        { liveBorn      :: RegSet       -- ^ registers born in this instruction (written to for first time).+        , liveDieRead   :: RegSet       -- ^ registers that died because they were read for the last time.+        , liveDieWrite  :: RegSet }     -- ^ registers that died because they were clobbered by something.+++-- | Stash regs live on entry to each basic block in the info part of the cmm code.+data LiveInfo+        = LiveInfo+                (LabelMap CmmStatics)     -- cmm info table static stuff+                [BlockId]                 -- entry points (first one is the+                                          -- entry point for the proc).+                (Maybe (BlockMap RegSet)) -- argument locals live on entry to this block+                (BlockMap IntSet)         -- stack slots live on entry to this block+++-- | A basic block with liveness information.+type LiveBasicBlock instr+        = GenBasicBlock (LiveInstr instr)+++instance Outputable instr+      => Outputable (InstrSR instr) where++        ppr (Instr realInstr)+           = ppr realInstr++        ppr (SPILL reg slot)+           = hcat [+                text "\tSPILL",+                char ' ',+                ppr reg,+                comma,+                text "SLOT" <> parens (int slot)]++        ppr (RELOAD slot reg)+           = hcat [+                text "\tRELOAD",+                char ' ',+                text "SLOT" <> parens (int slot),+                comma,+                ppr reg]++instance Outputable instr+      => Outputable (LiveInstr instr) where++        ppr (LiveInstr instr Nothing)+         = ppr instr++        ppr (LiveInstr instr (Just live))+         =  ppr instr+                $$ (nest 8+                        $ vcat+                        [ pprRegs (text "# born:    ") (liveBorn live)+                        , pprRegs (text "# r_dying: ") (liveDieRead live)+                        , pprRegs (text "# w_dying: ") (liveDieWrite live) ]+                    $+$ space)++         where  pprRegs :: SDoc -> RegSet -> SDoc+                pprRegs name regs+                 | isEmptyUniqSet regs  = empty+                 | otherwise            = name <>+                     (pprUFM (getUniqSet regs) (hcat . punctuate space . map ppr))++instance Outputable LiveInfo where+    ppr (LiveInfo mb_static entryIds liveVRegsOnEntry liveSlotsOnEntry)+        =  (ppr mb_static)+        $$ text "# entryIds         = " <> ppr entryIds+        $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry+        $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry)++++-- | map a function across all the basic blocks in this code+--+mapBlockTop+        :: (LiveBasicBlock instr -> LiveBasicBlock instr)+        -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr++mapBlockTop f cmm+        = evalState (mapBlockTopM (\x -> return $ f x) cmm) ()+++-- | map a function across all the basic blocks in this code (monadic version)+--+mapBlockTopM+        :: Monad m+        => (LiveBasicBlock instr -> m (LiveBasicBlock instr))+        -> LiveCmmDecl statics instr -> m (LiveCmmDecl statics instr)++mapBlockTopM _ cmm@(CmmData{})+        = return cmm++mapBlockTopM f (CmmProc header label live sccs)+ = do   sccs'   <- mapM (mapSCCM f) sccs+        return  $ CmmProc header label live sccs'++mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b)+mapSCCM f (AcyclicSCC x)+ = do   x'      <- f x+        return  $ AcyclicSCC x'++mapSCCM f (CyclicSCC xs)+ = do   xs'     <- mapM f xs+        return  $ CyclicSCC xs'+++-- map a function across all the basic blocks in this code+mapGenBlockTop+        :: (GenBasicBlock             i -> GenBasicBlock            i)+        -> (GenCmmDecl d h (ListGraph i) -> GenCmmDecl d h (ListGraph i))++mapGenBlockTop f cmm+        = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) ()+++-- | map a function across all the basic blocks in this code (monadic version)+mapGenBlockTopM+        :: Monad m+        => (GenBasicBlock            i  -> m (GenBasicBlock            i))+        -> (GenCmmDecl d h (ListGraph i) -> m (GenCmmDecl d h (ListGraph i)))++mapGenBlockTopM _ cmm@(CmmData{})+        = return cmm++mapGenBlockTopM f (CmmProc header label live (ListGraph blocks))+ = do   blocks' <- mapM f blocks+        return  $ CmmProc header label live (ListGraph blocks')+++-- | Slurp out the list of register conflicts and reg-reg moves from this top level thing.+--   Slurping of conflicts and moves is wrapped up together so we don't have+--   to make two passes over the same code when we want to build the graph.+--+slurpConflicts+        :: Instruction instr+        => LiveCmmDecl statics instr+        -> (Bag (UniqSet Reg), Bag (Reg, Reg))++slurpConflicts live+        = slurpCmm (emptyBag, emptyBag) live++ where  slurpCmm   rs  CmmData{}                = rs+        slurpCmm   rs (CmmProc info _ _ sccs)+                = foldl' (slurpSCC info) rs sccs++        slurpSCC  info rs (AcyclicSCC b)+                = slurpBlock info rs b++        slurpSCC  info rs (CyclicSCC bs)+                = foldl'  (slurpBlock info) rs bs++        slurpBlock info rs (BasicBlock blockId instrs)+                | LiveInfo _ _ (Just blockLive) _ <- info+                , Just rsLiveEntry                <- mapLookup blockId blockLive+                , (conflicts, moves)              <- slurpLIs rsLiveEntry rs instrs+                = (consBag rsLiveEntry conflicts, moves)++                | otherwise+                = panic "Liveness.slurpConflicts: bad block"++        slurpLIs rsLive (conflicts, moves) []+                = (consBag rsLive conflicts, moves)++        slurpLIs rsLive rs (LiveInstr _ Nothing     : lis)+                = slurpLIs rsLive rs lis++        slurpLIs rsLiveEntry (conflicts, moves) (LiveInstr instr (Just live) : lis)+         = let+                -- regs that die because they are read for the last time at the start of an instruction+                --      are not live across it.+                rsLiveAcross    = rsLiveEntry `minusUniqSet` (liveDieRead live)++                -- regs live on entry to the next instruction.+                --      be careful of orphans, make sure to delete dying regs _after_ unioning+                --      in the ones that are born here.+                rsLiveNext      = (rsLiveAcross `unionUniqSets` (liveBorn     live))+                                                `minusUniqSet`  (liveDieWrite live)++                -- orphan vregs are the ones that die in the same instruction they are born in.+                --      these are likely to be results that are never used, but we still+                --      need to assign a hreg to them..+                rsOrphans       = intersectUniqSets+                                        (liveBorn live)+                                        (unionUniqSets (liveDieWrite live) (liveDieRead live))++                --+                rsConflicts     = unionUniqSets rsLiveNext rsOrphans++          in    case takeRegRegMoveInstr instr of+                 Just rr        -> slurpLIs rsLiveNext+                                        ( consBag rsConflicts conflicts+                                        , consBag rr moves) lis++                 Nothing        -> slurpLIs rsLiveNext+                                        ( consBag rsConflicts conflicts+                                        , moves) lis+++-- | For spill\/reloads+--+--   SPILL  v1, slot1+--   ...+--   RELOAD slot1, v2+--+--   If we can arrange that v1 and v2 are allocated to the same hreg it's more likely+--   the spill\/reload instrs can be cleaned and replaced by a nop reg-reg move.+--+--+slurpReloadCoalesce+        :: forall statics instr. Instruction instr+        => LiveCmmDecl statics instr+        -> Bag (Reg, Reg)++slurpReloadCoalesce live+        = slurpCmm emptyBag live++ where+        slurpCmm :: Bag (Reg, Reg)+                 -> GenCmmDecl t t1 [SCC (LiveBasicBlock instr)]+                 -> Bag (Reg, Reg)+        slurpCmm cs CmmData{}   = cs+        slurpCmm cs (CmmProc _ _ _ sccs)+                = slurpComp cs (flattenSCCs sccs)++        slurpComp :: Bag (Reg, Reg)+                     -> [LiveBasicBlock instr]+                     -> Bag (Reg, Reg)+        slurpComp  cs blocks+         = let  (moveBags, _)   = runState (slurpCompM blocks) emptyUFM+           in   unionManyBags (cs : moveBags)++        slurpCompM :: [LiveBasicBlock instr]+                   -> State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)]+        slurpCompM blocks+         = do   -- run the analysis once to record the mapping across jumps.+                mapM_   (slurpBlock False) blocks++                -- run it a second time while using the information from the last pass.+                --      We /could/ run this many more times to deal with graphical control+                --      flow and propagating info across multiple jumps, but it's probably+                --      not worth the trouble.+                mapM    (slurpBlock True) blocks++        slurpBlock :: Bool -> LiveBasicBlock instr+                   -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg))+        slurpBlock propagate (BasicBlock blockId instrs)+         = do   -- grab the slot map for entry to this block+                slotMap         <- if propagate+                                        then getSlotMap blockId+                                        else return emptyUFM++                (_, mMoves)     <- mapAccumLM slurpLI slotMap instrs+                return $ listToBag $ catMaybes mMoves++        slurpLI :: UniqFM Reg                           -- current slotMap+                -> LiveInstr instr+                -> State (UniqFM [UniqFM Reg])          -- blockId -> [slot -> reg]+                                                        --      for tracking slotMaps across jumps++                         ( UniqFM Reg                   -- new slotMap+                         , Maybe (Reg, Reg))            -- maybe a new coalesce edge++        slurpLI slotMap li++                -- remember what reg was stored into the slot+                | LiveInstr (SPILL reg slot) _  <- li+                , slotMap'                      <- addToUFM slotMap slot reg+                = return (slotMap', Nothing)++                -- add an edge between the this reg and the last one stored into the slot+                | LiveInstr (RELOAD slot reg) _ <- li+                = case lookupUFM slotMap slot of+                        Just reg2+                         | reg /= reg2  -> return (slotMap, Just (reg, reg2))+                         | otherwise    -> return (slotMap, Nothing)++                        Nothing         -> return (slotMap, Nothing)++                -- if we hit a jump, remember the current slotMap+                | LiveInstr (Instr instr) _     <- li+                , targets                       <- jumpDestsOfInstr instr+                , not $ null targets+                = do    mapM_   (accSlotMap slotMap) targets+                        return  (slotMap, Nothing)++                | otherwise+                = return (slotMap, Nothing)++        -- record a slotmap for an in edge to this block+        accSlotMap slotMap blockId+                = modify (\s -> addToUFM_C (++) s blockId [slotMap])++        -- work out the slot map on entry to this block+        --      if we have slot maps for multiple in-edges then we need to merge them.+        getSlotMap blockId+         = do   map             <- get+                let slotMaps    = fromMaybe [] (lookupUFM map blockId)+                return          $ foldr mergeSlotMaps emptyUFM slotMaps++        mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg+        mergeSlotMaps map1 map2+                = listToUFM+                $ [ (k, r1)+                  | (k, r1) <- nonDetUFMToList map1+                  -- This is non-deterministic but we do not+                  -- currently support deterministic code-generation.+                  -- See Note [Unique Determinism and code generation]+                  , case lookupUFM map2 k of+                          Nothing -> False+                          Just r2 -> r1 == r2 ]+++-- | Strip away liveness information, yielding NatCmmDecl+stripLive+        :: (Outputable statics, Outputable instr, Instruction instr)+        => DynFlags+        -> LiveCmmDecl statics instr+        -> NatCmmDecl statics instr++stripLive dflags live+        = stripCmm live++ where  stripCmm :: (Outputable statics, Outputable instr, Instruction instr)+                 => LiveCmmDecl statics instr -> NatCmmDecl statics instr+        stripCmm (CmmData sec ds)       = CmmData sec ds+        stripCmm (CmmProc (LiveInfo info (first_id:_) _ _) label live sccs)+         = let  final_blocks    = flattenSCCs sccs++                -- make sure the block that was first in the input list+                --      stays at the front of the output. This is the entry point+                --      of the proc, and it needs to come first.+                ((first':_), rest')+                                = partition ((== first_id) . blockId) final_blocks++           in   CmmProc info label live+                          (ListGraph $ map (stripLiveBlock dflags) $ first' : rest')++        -- procs used for stg_split_markers don't contain any blocks, and have no first_id.+        stripCmm (CmmProc (LiveInfo info [] _ _) label live [])+         =      CmmProc info label live (ListGraph [])++        -- If the proc has blocks but we don't know what the first one was, then we're dead.+        stripCmm proc+                 = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc)++-- | Strip away liveness information from a basic block,+--   and make real spill instructions out of SPILL, RELOAD pseudos along the way.++stripLiveBlock+        :: Instruction instr+        => DynFlags+        -> LiveBasicBlock instr+        -> NatBasicBlock instr++stripLiveBlock dflags (BasicBlock i lis)+ =      BasicBlock i instrs'++ where  (instrs', _)+                = runState (spillNat [] lis) 0++        spillNat acc []+         =      return (reverse acc)++        spillNat acc (LiveInstr (SPILL reg slot) _ : instrs)+         = do   delta   <- get+                spillNat (mkSpillInstr dflags reg delta slot : acc) instrs++        spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs)+         = do   delta   <- get+                spillNat (mkLoadInstr dflags reg delta slot : acc) instrs++        spillNat acc (LiveInstr (Instr instr) _ : instrs)+         | Just i <- takeDeltaInstr instr+         = do   put i+                spillNat acc instrs++        spillNat acc (LiveInstr (Instr instr) _ : instrs)+         =      spillNat (instr : acc) instrs+++-- | Erase Delta instructions.++eraseDeltasLive+        :: Instruction instr+        => LiveCmmDecl statics instr+        -> LiveCmmDecl statics instr++eraseDeltasLive cmm+        = mapBlockTop eraseBlock cmm+ where+        eraseBlock (BasicBlock id lis)+                = BasicBlock id+                $ filter (\(LiveInstr i _) -> not $ isJust $ takeDeltaInstr i)+                $ lis+++-- | Patch the registers in this code according to this register mapping.+--   also erase reg -> reg moves when the reg is the same.+--   also erase reg -> reg moves when the destination dies in this instr.+patchEraseLive+        :: Instruction instr+        => (Reg -> Reg)+        -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr++patchEraseLive patchF cmm+        = patchCmm cmm+ where+        patchCmm cmm@CmmData{}  = cmm++        patchCmm (CmmProc info label live sccs)+         | LiveInfo static id (Just blockMap) mLiveSlots <- info+         = let+                patchRegSet set = mkUniqSet $ map patchF $ nonDetEltsUFM set+                  -- See Note [Unique Determinism and code generation]+                blockMap'       = mapMap (patchRegSet . getUniqSet) blockMap++                info'           = LiveInfo static id (Just blockMap') mLiveSlots+           in   CmmProc info' label live $ map patchSCC sccs++         | otherwise+         = panic "RegAlloc.Liveness.patchEraseLive: no blockMap"++        patchSCC (AcyclicSCC b)  = AcyclicSCC (patchBlock b)+        patchSCC (CyclicSCC  bs) = CyclicSCC  (map patchBlock bs)++        patchBlock (BasicBlock id lis)+                = BasicBlock id $ patchInstrs lis++        patchInstrs []          = []+        patchInstrs (li : lis)++                | LiveInstr i (Just live)       <- li'+                , Just (r1, r2) <- takeRegRegMoveInstr i+                , eatMe r1 r2 live+                = patchInstrs lis++                | otherwise+                = li' : patchInstrs lis++                where   li'     = patchRegsLiveInstr patchF li++        eatMe   r1 r2 live+                -- source and destination regs are the same+                | r1 == r2      = True++                -- destination reg is never used+                | elementOfUniqSet r2 (liveBorn live)+                , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live)+                = True++                | otherwise     = False+++-- | Patch registers in this LiveInstr, including the liveness information.+--+patchRegsLiveInstr+        :: Instruction instr+        => (Reg -> Reg)+        -> LiveInstr instr -> LiveInstr instr++patchRegsLiveInstr patchF li+ = case li of+        LiveInstr instr Nothing+         -> LiveInstr (patchRegsOfInstr instr patchF) Nothing++        LiveInstr instr (Just live)+         -> LiveInstr+                (patchRegsOfInstr instr patchF)+                (Just live+                        { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg+                          liveBorn      = mapUniqSet patchF $ liveBorn live+                        , liveDieRead   = mapUniqSet patchF $ liveDieRead live+                        , liveDieWrite  = mapUniqSet patchF $ liveDieWrite live })+                          -- See Note [Unique Determinism and code generation]+++--------------------------------------------------------------------------------+-- | Convert a NatCmmDecl to a LiveCmmDecl, with empty liveness information++natCmmTopToLive+        :: Instruction instr+        => NatCmmDecl statics instr+        -> LiveCmmDecl statics instr++natCmmTopToLive (CmmData i d)+        = CmmData i d++natCmmTopToLive (CmmProc info lbl live (ListGraph []))+        = CmmProc (LiveInfo info [] Nothing mapEmpty) lbl live []++natCmmTopToLive proc@(CmmProc info lbl live (ListGraph blocks@(first : _)))+ = let  first_id        = blockId first+        all_entry_ids   = entryBlocks proc+        sccs            = sccBlocks blocks all_entry_ids+        entry_ids       = filter (/= first_id) all_entry_ids+        sccsLive        = map (fmap (\(BasicBlock l instrs) ->+                                        BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs)))+                        $ sccs++   in   CmmProc (LiveInfo info (first_id : entry_ids) Nothing mapEmpty)+                lbl live sccsLive+++--+-- Compute the liveness graph of the set of basic blocks.  Important:+-- we also discard any unreachable code here, starting from the entry+-- points (the first block in the list, and any blocks with info+-- tables).  Unreachable code arises when code blocks are orphaned in+-- earlier optimisation passes, and may confuse the register allocator+-- by referring to registers that are not initialised.  It's easy to+-- discard the unreachable code as part of the SCC pass, so that's+-- exactly what we do. (#7574)+--+sccBlocks+        :: Instruction instr+        => [NatBasicBlock instr]+        -> [BlockId]+        -> [SCC (NatBasicBlock instr)]++sccBlocks blocks entries = map (fmap get_node) sccs+  where+        -- nodes :: [(NatBasicBlock instr, Unique, [Unique])]+        nodes = [ (block, id, getOutEdges instrs)+                | block@(BasicBlock id instrs) <- blocks ]++        g1 = graphFromEdgedVerticesUniq nodes++        reachable :: LabelSet+        reachable = setFromList [ id | (_,id,_) <- reachablesG g1 roots ]++        g2 = graphFromEdgedVerticesUniq [ node | node@(_,id,_) <- nodes+                                               , id `setMember` reachable ]++        sccs = stronglyConnCompG g2++        get_node (n, _, _) = n++        getOutEdges :: Instruction instr => [instr] -> [BlockId]+        getOutEdges instrs = concat $ map jumpDestsOfInstr instrs++        -- This is truly ugly, but I don't see a good alternative.+        -- Digraph just has the wrong API.  We want to identify nodes+        -- by their keys (BlockId), but Digraph requires the whole+        -- node: (NatBasicBlock, BlockId, [BlockId]).  This takes+        -- advantage of the fact that Digraph only looks at the key,+        -- even though it asks for the whole triple.+        roots = [(panic "sccBlocks",b,panic "sccBlocks") | b <- entries ]++++--------------------------------------------------------------------------------+-- Annotate code with register liveness information+--+regLiveness+        :: (Outputable instr, Instruction instr)+        => Platform+        -> LiveCmmDecl statics instr+        -> UniqSM (LiveCmmDecl statics instr)++regLiveness _ (CmmData i d)+        = return $ CmmData i d++regLiveness _ (CmmProc info lbl live [])+        | LiveInfo static mFirst _ _    <- info+        = return $ CmmProc+                        (LiveInfo static mFirst (Just mapEmpty) mapEmpty)+                        lbl live []++regLiveness platform (CmmProc info lbl live sccs)+        | LiveInfo static mFirst _ liveSlotsOnEntry     <- info+        = let   (ann_sccs, block_live)  = computeLiveness platform sccs++          in    return $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry)+                           lbl live ann_sccs+++-- -----------------------------------------------------------------------------+-- | Check ordering of Blocks+--   The computeLiveness function requires SCCs to be in reverse+--   dependent order.  If they're not the liveness information will be+--   wrong, and we'll get a bad allocation.  Better to check for this+--   precondition explicitly or some other poor sucker will waste a+--   day staring at bad assembly code..+--+checkIsReverseDependent+        :: Instruction instr+        => [SCC (LiveBasicBlock instr)]         -- ^ SCCs of blocks that we're about to run the liveness determinator on.+        -> Maybe BlockId                        -- ^ BlockIds that fail the test (if any)++checkIsReverseDependent sccs'+ = go emptyUniqSet sccs'++ where  go _ []+         = Nothing++        go blocksSeen (AcyclicSCC block : sccs)+         = let  dests           = slurpJumpDestsOfBlock block+                blocksSeen'     = unionUniqSets blocksSeen $ mkUniqSet [blockId block]+                badDests        = dests `minusUniqSet` blocksSeen'+           in   case nonDetEltsUniqSet badDests of+                 -- See Note [Unique Determinism and code generation]+                 []             -> go blocksSeen' sccs+                 bad : _        -> Just bad++        go blocksSeen (CyclicSCC blocks : sccs)+         = let  dests           = unionManyUniqSets $ map slurpJumpDestsOfBlock blocks+                blocksSeen'     = unionUniqSets blocksSeen $ mkUniqSet $ map blockId blocks+                badDests        = dests `minusUniqSet` blocksSeen'+           in   case nonDetEltsUniqSet badDests of+                 -- See Note [Unique Determinism and code generation]+                 []             -> go blocksSeen' sccs+                 bad : _        -> Just bad++        slurpJumpDestsOfBlock (BasicBlock _ instrs)+                = unionManyUniqSets+                $ map (mkUniqSet . jumpDestsOfInstr)+                        [ i | LiveInstr i _ <- instrs]+++-- | If we've compute liveness info for this code already we have to reverse+--   the SCCs in each top to get them back to the right order so we can do it again.+reverseBlocksInTops :: LiveCmmDecl statics instr -> LiveCmmDecl statics instr+reverseBlocksInTops top+ = case top of+        CmmData{}                       -> top+        CmmProc info lbl live sccs      -> CmmProc info lbl live (reverse sccs)+++-- | Computing liveness+--+--  On entry, the SCCs must be in "reverse" order: later blocks may transfer+--  control to earlier ones only, else `panic`.+--+--  The SCCs returned are in the *opposite* order, which is exactly what we+--  want for the next pass.+--+computeLiveness+        :: (Outputable instr, Instruction instr)+        => Platform+        -> [SCC (LiveBasicBlock instr)]+        -> ([SCC (LiveBasicBlock instr)],       -- instructions annotated with list of registers+                                                -- which are "dead after this instruction".+               BlockMap RegSet)                 -- blocks annotated with set of live registers+                                                -- on entry to the block.++computeLiveness platform sccs+ = case checkIsReverseDependent sccs of+        Nothing         -> livenessSCCs platform mapEmpty [] sccs+        Just bad        -> pprPanic "RegAlloc.Liveness.computeLivenss"+                                (vcat   [ text "SCCs aren't in reverse dependent order"+                                        , text "bad blockId" <+> ppr bad+                                        , ppr sccs])++livenessSCCs+       :: Instruction instr+       => Platform+       -> BlockMap RegSet+       -> [SCC (LiveBasicBlock instr)]          -- accum+       -> [SCC (LiveBasicBlock instr)]+       -> ( [SCC (LiveBasicBlock instr)]+          , BlockMap RegSet)++livenessSCCs _ blockmap done []+        = (done, blockmap)++livenessSCCs platform blockmap done (AcyclicSCC block : sccs)+ = let  (blockmap', block')     = livenessBlock platform blockmap block+   in   livenessSCCs platform blockmap' (AcyclicSCC block' : done) sccs++livenessSCCs platform blockmap done+        (CyclicSCC blocks : sccs) =+        livenessSCCs platform blockmap' (CyclicSCC blocks':done) sccs+ where      (blockmap', blocks')+                = iterateUntilUnchanged linearLiveness equalBlockMaps+                                      blockmap blocks++            iterateUntilUnchanged+                :: (a -> b -> (a,c)) -> (a -> a -> Bool)+                -> a -> b+                -> (a,c)++            iterateUntilUnchanged f eq a b+                = head $+                  concatMap tail $+                  groupBy (\(a1, _) (a2, _) -> eq a1 a2) $+                  iterate (\(a, _) -> f a b) $+                  (a, panic "RegLiveness.livenessSCCs")+++            linearLiveness+                :: Instruction instr+                => BlockMap RegSet -> [LiveBasicBlock instr]+                -> (BlockMap RegSet, [LiveBasicBlock instr])++            linearLiveness = mapAccumL (livenessBlock platform)++                -- probably the least efficient way to compare two+                -- BlockMaps for equality.+            equalBlockMaps a b+                = a' == b'+              where a' = map f $ mapToList a+                    b' = map f $ mapToList b+                    f (key,elt) = (key, nonDetEltsUniqSet elt)+                    -- See Note [Unique Determinism and code generation]++++-- | Annotate a basic block with register liveness information.+--+livenessBlock+        :: Instruction instr+        => Platform+        -> BlockMap RegSet+        -> LiveBasicBlock instr+        -> (BlockMap RegSet, LiveBasicBlock instr)++livenessBlock platform blockmap (BasicBlock block_id instrs)+ = let+        (regsLiveOnEntry, instrs1)+            = livenessBack platform emptyUniqSet blockmap [] (reverse instrs)+        blockmap'       = mapInsert block_id regsLiveOnEntry blockmap++        instrs2         = livenessForward platform regsLiveOnEntry instrs1++        output          = BasicBlock block_id instrs2++   in   ( blockmap', output)++-- | Calculate liveness going forwards,+--   filling in when regs are born++livenessForward+        :: Instruction instr+        => Platform+        -> RegSet                       -- regs live on this instr+        -> [LiveInstr instr] -> [LiveInstr instr]++livenessForward _        _           []  = []+livenessForward platform rsLiveEntry (li@(LiveInstr instr mLive) : lis)+        | Just live <- mLive+        = let+                RU _ written  = regUsageOfInstr platform instr+                -- Regs that are written to but weren't live on entry to this instruction+                --      are recorded as being born here.+                rsBorn          = mkUniqSet+                                $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written++                rsLiveNext      = (rsLiveEntry `unionUniqSets` rsBorn)+                                        `minusUniqSet` (liveDieRead live)+                                        `minusUniqSet` (liveDieWrite live)++        in LiveInstr instr (Just live { liveBorn = rsBorn })+                : livenessForward platform rsLiveNext lis++        | otherwise+        = li : livenessForward platform rsLiveEntry lis+++-- | Calculate liveness going backwards,+--   filling in when regs die, and what regs are live across each instruction++livenessBack+        :: Instruction instr+        => Platform+        -> RegSet                       -- regs live on this instr+        -> BlockMap RegSet              -- regs live on entry to other BBs+        -> [LiveInstr instr]            -- instructions (accum)+        -> [LiveInstr instr]            -- instructions+        -> (RegSet, [LiveInstr instr])++livenessBack _        liveregs _        done []  = (liveregs, done)++livenessBack platform liveregs blockmap acc (instr : instrs)+ = let  (liveregs', instr')     = liveness1 platform liveregs blockmap instr+   in   livenessBack platform liveregs' blockmap (instr' : acc) instrs+++-- don't bother tagging comments or deltas with liveness+liveness1+        :: Instruction instr+        => Platform+        -> RegSet+        -> BlockMap RegSet+        -> LiveInstr instr+        -> (RegSet, LiveInstr instr)++liveness1 _ liveregs _ (LiveInstr instr _)+        | isMetaInstr instr+        = (liveregs, LiveInstr instr Nothing)++liveness1 platform liveregs blockmap (LiveInstr instr _)++        | not_a_branch+        = (liveregs1, LiveInstr instr+                        (Just $ Liveness+                        { liveBorn      = emptyUniqSet+                        , liveDieRead   = mkUniqSet r_dying+                        , liveDieWrite  = mkUniqSet w_dying }))++        | otherwise+        = (liveregs_br, LiveInstr instr+                        (Just $ Liveness+                        { liveBorn      = emptyUniqSet+                        , liveDieRead   = mkUniqSet r_dying_br+                        , liveDieWrite  = mkUniqSet w_dying }))++        where+            !(RU read written) = regUsageOfInstr platform instr++            -- registers that were written here are dead going backwards.+            -- registers that were read here are live going backwards.+            liveregs1   = (liveregs `delListFromUniqSet` written)+                                    `addListToUniqSet` read++            -- registers that are not live beyond this point, are recorded+            --  as dying here.+            r_dying     = [ reg | reg <- read, reg `notElem` written,+                              not (elementOfUniqSet reg liveregs) ]++            w_dying     = [ reg | reg <- written,+                             not (elementOfUniqSet reg liveregs) ]++            -- union in the live regs from all the jump destinations of this+            -- instruction.+            targets      = jumpDestsOfInstr instr -- where we go from here+            not_a_branch = null targets++            targetLiveRegs target+                  = case mapLookup target blockmap of+                                Just ra -> ra+                                Nothing -> emptyRegSet++            live_from_branch = unionManyUniqSets (map targetLiveRegs targets)++            liveregs_br = liveregs1 `unionUniqSets` live_from_branch++            -- registers that are live only in the branch targets should+            -- be listed as dying here.+            live_branch_only = live_from_branch `minusUniqSet` liveregs+            r_dying_br  = nonDetEltsUniqSet (mkUniqSet r_dying `unionUniqSets`+                                             live_branch_only)+                          -- See Note [Unique Determinism and code generation]++
+ nativeGen/RegClass.hs view
@@ -0,0 +1,33 @@+-- | An architecture independent description of a register's class.+module RegClass+        ( RegClass (..) )++where++import  Outputable+import  Unique+++-- | The class of a register.+--      Used in the register allocator.+--      We treat all registers in a class as being interchangable.+--+data RegClass+        = RcInteger+        | RcFloat+        | RcDouble+        | RcDoubleSSE -- x86 only: the SSE regs are a separate class+        deriving Eq+++instance Uniquable RegClass where+    getUnique RcInteger = mkRegClassUnique 0+    getUnique RcFloat   = mkRegClassUnique 1+    getUnique RcDouble  = mkRegClassUnique 2+    getUnique RcDoubleSSE = mkRegClassUnique 3++instance Outputable RegClass where+    ppr RcInteger       = Outputable.text "I"+    ppr RcFloat         = Outputable.text "F"+    ppr RcDouble        = Outputable.text "D"+    ppr RcDoubleSSE     = Outputable.text "S"
+ nativeGen/SPARC/AddrMode.hs view
@@ -0,0 +1,42 @@++module SPARC.AddrMode (+        AddrMode(..),+        addrOffset+)++where++import SPARC.Imm+import SPARC.Base+import Reg++-- addressing modes ------------------------------------------------------------++-- | Represents a memory address in an instruction.+--      Being a RISC machine, the SPARC addressing modes are very regular.+--+data AddrMode+        = AddrRegReg    Reg Reg         -- addr = r1 + r2+        | AddrRegImm    Reg Imm         -- addr = r1 + imm+++-- | Add an integer offset to the address in an AddrMode.+--+addrOffset :: AddrMode -> Int -> Maybe AddrMode+addrOffset addr off+  = case addr of+      AddrRegImm r (ImmInt n)+       | fits13Bits n2 -> Just (AddrRegImm r (ImmInt n2))+       | otherwise     -> Nothing+       where n2 = n + off++      AddrRegImm r (ImmInteger n)+       | fits13Bits n2 -> Just (AddrRegImm r (ImmInt (fromInteger n2)))+       | otherwise     -> Nothing+       where n2 = n + toInteger off++      AddrRegReg r (RegReal (RealRegSingle 0))+       | fits13Bits off -> Just (AddrRegImm r (ImmInt off))+       | otherwise     -> Nothing++      _ -> Nothing
+ nativeGen/SPARC/Base.hs view
@@ -0,0 +1,75 @@++-- | Bits and pieces on the bottom of the module dependency tree.+--      Also import the required constants, so we know what we're using.+--+--      In the interests of cross-compilation, we want to free ourselves+--      from the autoconf generated modules like main/Constants++module SPARC.Base (+        wordLength,+        wordLengthInBits,+        spillAreaLength,+        spillSlotSize,+        extraStackArgsHere,+        fits13Bits,+        is32BitInteger,+        largeOffsetError+)++where++import DynFlags+import Panic++import Data.Int+++-- On 32 bit SPARC, pointers are 32 bits.+wordLength :: Int+wordLength = 4++wordLengthInBits :: Int+wordLengthInBits+        = wordLength * 8++-- Size of the available spill area+spillAreaLength :: DynFlags -> Int+spillAreaLength+        = rESERVED_C_STACK_BYTES++-- | We need 8 bytes because our largest registers are 64 bit.+spillSlotSize :: Int+spillSlotSize = 8+++-- | We (allegedly) put the first six C-call arguments in registers;+--      where do we start putting the rest of them?+extraStackArgsHere :: Int+extraStackArgsHere = 23+++{-# SPECIALIZE fits13Bits :: Int -> Bool, Integer -> Bool #-}+-- | Check whether an offset is representable with 13 bits.+fits13Bits :: Integral a => a -> Bool+fits13Bits x = x >= -4096 && x < 4096++-- | Check whether an integer will fit in 32 bits.+--      A CmmInt is intended to be truncated to the appropriate+--      number of bits, so here we truncate it to Int64.  This is+--      important because e.g. -1 as a CmmInt might be either+--      -1 or 18446744073709551615.+--+is32BitInteger :: Integer -> Bool+is32BitInteger i+        = i64 <= 0x7fffffff && i64 >= -0x80000000+        where i64 = fromIntegral i :: Int64+++-- | Sadness.+largeOffsetError :: (Show a) => a -> b+largeOffsetError i+  = panic ("ERROR: SPARC native-code generator cannot handle large offset ("+                ++ show i ++ ");\nprobably because of large constant data structures;" +++                "\nworkaround: use -fllvm on this module.\n")++
+ nativeGen/SPARC/CodeGen.hs view
@@ -0,0 +1,674 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Generating machine code (instruction selection)+--+-- (c) The University of Glasgow 1996-2013+--+-----------------------------------------------------------------------------++{-# LANGUAGE GADTs #-}+module SPARC.CodeGen (+        cmmTopCodeGen,+        generateJumpTableForInstr,+        InstrBlock+)++where++#include "HsVersions.h"+#include "nativeGen/NCG.h"+#include "MachDeps.h"++-- NCG stuff:+import SPARC.Base+import SPARC.CodeGen.Sanity+import SPARC.CodeGen.Amode+import SPARC.CodeGen.CondCode+import SPARC.CodeGen.Gen64+import SPARC.CodeGen.Gen32+import SPARC.CodeGen.Base+import SPARC.Ppr        ()+import SPARC.Instr+import SPARC.Imm+import SPARC.AddrMode+import SPARC.Regs+import SPARC.Stack+import Instruction+import Format+import NCGMonad++-- Our intermediate code:+import BlockId+import Cmm+import CmmUtils+import CmmSwitch+import Hoopl+import PIC+import Reg+import CLabel+import CPrim++-- The rest:+import BasicTypes+import DynFlags+import FastString+import OrdList+import Outputable+import Platform+import Unique++import Control.Monad    ( mapAndUnzipM )++-- | Top level code generation+cmmTopCodeGen :: RawCmmDecl+              -> NatM [NatCmmDecl CmmStatics Instr]++cmmTopCodeGen (CmmProc info lab live graph)+ = do let blocks = toBlockListEntryFirst graph+      (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks++      let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)+      let tops = proc : concat statics++      return tops++cmmTopCodeGen (CmmData sec dat) = do+  return [CmmData sec dat]  -- no translation, we just use CmmStatic+++-- | Do code generation on a single block of CMM code.+--      code generation may introduce new basic block boundaries, which+--      are indicated by the NEWBLOCK instruction.  We must split up the+--      instruction stream into basic blocks again.  Also, we extract+--      LDATAs here too.+basicBlockCodeGen :: CmmBlock+                  -> NatM ( [NatBasicBlock Instr]+                          , [NatCmmDecl CmmStatics Instr])++basicBlockCodeGen block = do+  let (_, nodes, tail)  = blockSplit block+      id = entryLabel block+      stmts = blockToList nodes+  mid_instrs <- stmtsToInstrs stmts+  tail_instrs <- stmtToInstrs tail+  let instrs = mid_instrs `appOL` tail_instrs+  let+        (top,other_blocks,statics)+                = foldrOL mkBlocks ([],[],[]) instrs++        mkBlocks (NEWBLOCK id) (instrs,blocks,statics)+          = ([], BasicBlock id instrs : blocks, statics)++        mkBlocks (LDATA sec dat) (instrs,blocks,statics)+          = (instrs, blocks, CmmData sec dat:statics)++        mkBlocks instr (instrs,blocks,statics)+          = (instr:instrs, blocks, statics)++        -- do intra-block sanity checking+        blocksChecked+                = map (checkBlock block)+                $ BasicBlock id top : other_blocks++  return (blocksChecked, statics)+++-- | Convert some Cmm statements to SPARC instructions.+stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock+stmtsToInstrs stmts+   = do instrss <- mapM stmtToInstrs stmts+        return (concatOL instrss)+++stmtToInstrs :: CmmNode e x -> NatM InstrBlock+stmtToInstrs stmt = do+  dflags <- getDynFlags+  case stmt of+    CmmComment s   -> return (unitOL (COMMENT s))+    CmmTick {}     -> return nilOL+    CmmUnwind {}   -> return nilOL++    CmmAssign reg src+      | isFloatType ty  -> assignReg_FltCode format reg src+      | isWord64 ty     -> assignReg_I64Code        reg src+      | otherwise       -> assignReg_IntCode format reg src+        where ty = cmmRegType dflags reg+              format = cmmTypeFormat ty++    CmmStore addr src+      | isFloatType ty  -> assignMem_FltCode format addr src+      | isWord64 ty     -> assignMem_I64Code      addr src+      | otherwise       -> assignMem_IntCode format addr src+        where ty = cmmExprType dflags src+              format = cmmTypeFormat ty++    CmmUnsafeForeignCall target result_regs args+       -> genCCall target result_regs args++    CmmBranch   id              -> genBranch id+    CmmCondBranch arg true false _ -> do+      b1 <- genCondJump true arg+      b2 <- genBranch false+      return (b1 `appOL` b2)+    CmmSwitch arg ids   -> do dflags <- getDynFlags+                              genSwitch dflags arg ids+    CmmCall { cml_target = arg } -> genJump arg++    _+     -> panic "stmtToInstrs: statement should have been cps'd away"+++{-+Now, given a tree (the argument to an CmmLoad) that references memory,+produce a suitable addressing mode.++A Rule of the Game (tm) for Amodes: use of the addr bit must+immediately follow use of the code part, since the code part puts+values in registers which the addr then refers to.  So you can't put+anything in between, lest it overwrite some of those registers.  If+you need to do some other computation between the code part and use of+the addr bit, first store the effective address from the amode in a+temporary, then do the other computation, and then use the temporary:++    code+    LEA amode, tmp+    ... other computation ...+    ... (tmp) ...+-}++++-- | Convert a BlockId to some CmmStatic data+jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic+jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags))+jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)+    where blockLabel = mkAsmTempLabel (getUnique blockid)++++-- -----------------------------------------------------------------------------+-- Generating assignments++-- Assignments are really at the heart of the whole code generation+-- business.  Almost all top-level nodes of any real importance are+-- assignments, which correspond to loads, stores, or register+-- transfers.  If we're really lucky, some of the register transfers+-- will go away, because we can use the destination register to+-- complete the code generation for the right hand side.  This only+-- fails when the right hand side is forced into a fixed register+-- (e.g. the result of a call).++assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignMem_IntCode pk addr src = do+    (srcReg, code) <- getSomeReg src+    Amode dstAddr addr_code <- getAmode addr+    return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr+++assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock+assignReg_IntCode _ reg src = do+    dflags <- getDynFlags+    r <- getRegister src+    let dst = getRegisterReg (targetPlatform dflags) reg+    return $ case r of+        Any _ code         -> code dst+        Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst++++-- Floating point assignment to memory+assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignMem_FltCode pk addr src = do+    dflags <- getDynFlags+    Amode dst__2 code1 <- getAmode addr+    (src__2, code2) <- getSomeReg src+    tmp1 <- getNewRegNat pk+    let+        pk__2   = cmmExprType dflags src+        code__2 = code1 `appOL` code2 `appOL`+            if   formatToWidth pk == typeWidth pk__2+            then unitOL (ST pk src__2 dst__2)+            else toOL   [ FxTOy (cmmTypeFormat pk__2) pk src__2 tmp1+                        , ST    pk tmp1 dst__2]+    return code__2++-- Floating point assignment to a register/temporary+assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock+assignReg_FltCode pk dstCmmReg srcCmmExpr = do+    dflags <- getDynFlags+    let platform = targetPlatform dflags+    srcRegister <- getRegister srcCmmExpr+    let dstReg  = getRegisterReg platform dstCmmReg++    return $ case srcRegister of+        Any _ code                  -> code dstReg+        Fixed _ srcFixedReg srcCode -> srcCode `snocOL` FMOV pk srcFixedReg dstReg+++++genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock++genJump (CmmLit (CmmLabel lbl))+  = return (toOL [CALL (Left target) 0 True, NOP])+  where+    target = ImmCLbl lbl++genJump tree+  = do+        (target, code) <- getSomeReg tree+        return (code `snocOL` JMP (AddrRegReg target g0)  `snocOL` NOP)++-- -----------------------------------------------------------------------------+--  Unconditional branches++genBranch :: BlockId -> NatM InstrBlock+genBranch = return . toOL . mkJumpInstr+++-- -----------------------------------------------------------------------------+--  Conditional jumps++{-+Conditional jumps are always to local labels, so we can use branch+instructions.  We peek at the arguments to decide what kind of+comparison to do.++SPARC: First, we have to ensure that the condition codes are set+according to the supplied comparison operation.  We generate slightly+different code for floating point comparisons, because a floating+point operation cannot directly precede a @BF@.  We assume the worst+and fill that slot with a @NOP@.++SPARC: Do not fill the delay slots here; you will confuse the register+allocator.+-}+++genCondJump+    :: BlockId      -- the branch target+    -> CmmExpr      -- the condition on which to branch+    -> NatM InstrBlock++++genCondJump bid bool = do+  CondCode is_float cond code <- getCondCode bool+  return (+       code `appOL`+       toOL (+         if   is_float+         then [NOP, BF cond False bid, NOP]+         else [BI cond False bid, NOP]+       )+    )++++-- -----------------------------------------------------------------------------+-- Generating a table-branch++genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock+genSwitch dflags expr targets+        | gopt Opt_PIC dflags+        = error "MachCodeGen: sparc genSwitch PIC not finished\n"++        | otherwise+        = do    (e_reg, e_code) <- getSomeReg (cmmOffset dflags expr offset)++                base_reg        <- getNewRegNat II32+                offset_reg      <- getNewRegNat II32+                dst             <- getNewRegNat II32++                label           <- getNewLabelNat++                return $ e_code `appOL`+                 toOL+                        [ -- load base of jump table+                          SETHI (HI (ImmCLbl label)) base_reg+                        , OR    False base_reg (RIImm $ LO $ ImmCLbl label) base_reg++                        -- the addrs in the table are 32 bits wide..+                        , SLL   e_reg (RIImm $ ImmInt 2) offset_reg++                        -- load and jump to the destination+                        , LD      II32 (AddrRegReg base_reg offset_reg) dst+                        , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label+                        , NOP ]+  where (offset, ids) = switchTargetsToTable targets++generateJumpTableForInstr :: DynFlags -> Instr+                          -> Maybe (NatCmmDecl CmmStatics Instr)+generateJumpTableForInstr dflags (JMP_TBL _ ids label) =+  let jumpTable = map (jumpTableEntry dflags) ids+  in Just (CmmData (Section ReadOnlyData label) (Statics label jumpTable))+generateJumpTableForInstr _ _ = Nothing++++-- -----------------------------------------------------------------------------+-- Generating C calls++{-+   Now the biggest nightmare---calls.  Most of the nastiness is buried in+   @get_arg@, which moves the arguments to the correct registers/stack+   locations.  Apart from that, the code is easy.++   The SPARC calling convention is an absolute+   nightmare.  The first 6x32 bits of arguments are mapped into+   %o0 through %o5, and the remaining arguments are dumped to the+   stack, beginning at [%sp+92].  (Note that %o6 == %sp.)++   If we have to put args on the stack, move %o6==%sp down by+   the number of words to go on the stack, to ensure there's enough space.++   According to Fraser and Hanson's lcc book, page 478, fig 17.2,+   16 words above the stack pointer is a word for the address of+   a structure return value.  I use this as a temporary location+   for moving values from float to int regs.  Certainly it isn't+   safe to put anything in the 16 words starting at %sp, since+   this area can get trashed at any time due to window overflows+   caused by signal handlers.++   A final complication (if the above isn't enough) is that+   we can't blithely calculate the arguments one by one into+   %o0 .. %o5.  Consider the following nested calls:++       fff a (fff b c)++   Naive code moves a into %o0, and (fff b c) into %o1.  Unfortunately+   the inner call will itself use %o0, which trashes the value put there+   in preparation for the outer call.  Upshot: we need to calculate the+   args into temporary regs, and move those to arg regs or onto the+   stack only immediately prior to the call proper.  Sigh.+-}++genCCall+    :: ForeignTarget            -- function to call+    -> [CmmFormal]        -- where to put the result+    -> [CmmActual]        -- arguments (of mixed type)+    -> NatM InstrBlock++++-- On SPARC under TSO (Total Store Ordering), writes earlier in the instruction stream+-- are guaranteed to take place before writes afterwards (unlike on PowerPC).+-- Ref: Section 8.4 of the SPARC V9 Architecture manual.+--+-- In the SPARC case we don't need a barrier.+--+genCCall (PrimTarget MO_WriteBarrier) _ _+ = return $ nilOL++genCCall (PrimTarget (MO_Prefetch_Data _)) _ _+ = return $ nilOL++genCCall target dest_regs args+ = do   -- work out the arguments, and assign them to integer regs+        argcode_and_vregs       <- mapM arg_to_int_vregs args+        let (argcodes, vregss)  = unzip argcode_and_vregs+        let vregs               = concat vregss++        let n_argRegs           = length allArgRegs+        let n_argRegs_used      = min (length vregs) n_argRegs+++        -- deal with static vs dynamic call targets+        callinsns <- case target of+                ForeignTarget (CmmLit (CmmLabel lbl)) _ ->+                        return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))++                ForeignTarget expr _+                 -> do  (dyn_c, [dyn_r]) <- arg_to_int_vregs expr+                        return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)++                PrimTarget mop+                 -> do  res     <- outOfLineMachOp mop+                        lblOrMopExpr <- case res of+                                Left lbl -> do+                                        return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))++                                Right mopExpr -> do+                                        (dyn_c, [dyn_r]) <- arg_to_int_vregs mopExpr+                                        return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)++                        return lblOrMopExpr++        let argcode = concatOL argcodes++        let (move_sp_down, move_sp_up)+                   = let diff = length vregs - n_argRegs+                         nn   = if odd diff then diff + 1 else diff -- keep 8-byte alignment+                     in  if   nn <= 0+                         then (nilOL, nilOL)+                         else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))++        let transfer_code+                = toOL (move_final vregs allArgRegs extraStackArgsHere)++        dflags <- getDynFlags+        return+         $      argcode                 `appOL`+                move_sp_down            `appOL`+                transfer_code           `appOL`+                callinsns               `appOL`+                unitOL NOP              `appOL`+                move_sp_up              `appOL`+                assign_code (targetPlatform dflags) dest_regs+++-- | Generate code to calculate an argument, and move it into one+--      or two integer vregs.+arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg])+arg_to_int_vregs arg = do dflags <- getDynFlags+                          arg_to_int_vregs' dflags arg++arg_to_int_vregs' :: DynFlags -> CmmExpr -> NatM (OrdList Instr, [Reg])+arg_to_int_vregs' dflags arg++        -- If the expr produces a 64 bit int, then we can just use iselExpr64+        | isWord64 (cmmExprType dflags arg)+        = do    (ChildCode64 code r_lo) <- iselExpr64 arg+                let r_hi                = getHiVRegFromLo r_lo+                return (code, [r_hi, r_lo])++        | otherwise+        = do    (src, code)     <- getSomeReg arg+                let pk          = cmmExprType dflags arg++                case cmmTypeFormat pk of++                 -- Load a 64 bit float return value into two integer regs.+                 FF64 -> do+                        v1 <- getNewRegNat II32+                        v2 <- getNewRegNat II32++                        let code2 =+                                code                            `snocOL`+                                FMOV FF64 src f0                `snocOL`+                                ST   FF32  f0 (spRel 16)        `snocOL`+                                LD   II32  (spRel 16) v1        `snocOL`+                                ST   FF32  f1 (spRel 16)        `snocOL`+                                LD   II32  (spRel 16) v2++                        return  (code2, [v1,v2])++                 -- Load a 32 bit float return value into an integer reg+                 FF32 -> do+                        v1 <- getNewRegNat II32++                        let code2 =+                                code                            `snocOL`+                                ST   FF32  src (spRel 16)       `snocOL`+                                LD   II32  (spRel 16) v1++                        return (code2, [v1])++                 -- Move an integer return value into its destination reg.+                 _ -> do+                        v1 <- getNewRegNat II32++                        let code2 =+                                code                            `snocOL`+                                OR False g0 (RIReg src) v1++                        return (code2, [v1])+++-- | Move args from the integer vregs into which they have been+--      marshalled, into %o0 .. %o5, and the rest onto the stack.+--+move_final :: [Reg] -> [Reg] -> Int -> [Instr]++-- all args done+move_final [] _ _+        = []++-- out of aregs; move to stack+move_final (v:vs) [] offset+        = ST II32 v (spRel offset)+        : move_final vs [] (offset+1)++-- move into an arg (%o[0..5]) reg+move_final (v:vs) (a:az) offset+        = OR False g0 (RIReg v) a+        : move_final vs az offset+++-- | Assign results returned from the call into their+--      destination regs.+--+assign_code :: Platform -> [LocalReg] -> OrdList Instr++assign_code _ [] = nilOL++assign_code platform [dest]+ = let  rep     = localRegType dest+        width   = typeWidth rep+        r_dest  = getRegisterReg platform (CmmLocal dest)++        result+                | isFloatType rep+                , W32   <- width+                = unitOL $ FMOV FF32 (regSingle $ fReg 0) r_dest++                | isFloatType rep+                , W64   <- width+                = unitOL $ FMOV FF64 (regSingle $ fReg 0) r_dest++                | not $ isFloatType rep+                , W32   <- width+                = unitOL $ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest++                | not $ isFloatType rep+                , W64           <- width+                , r_dest_hi     <- getHiVRegFromLo r_dest+                = toOL  [ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest_hi+                        , mkRegRegMoveInstr platform (regSingle $ oReg 1) r_dest]++                | otherwise+                = panic "SPARC.CodeGen.GenCCall: no match"++   in   result++assign_code _ _+        = panic "SPARC.CodeGen.GenCCall: no match"++++-- | Generate a call to implement an out-of-line floating point operation+outOfLineMachOp+        :: CallishMachOp+        -> NatM (Either CLabel CmmExpr)++outOfLineMachOp mop+ = do   let functionName+                = outOfLineMachOp_table mop++        dflags  <- getDynFlags+        mopExpr <- cmmMakeDynamicReference dflags CallReference+                $  mkForeignLabel functionName Nothing ForeignLabelInExternalPackage IsFunction++        let mopLabelOrExpr+                = case mopExpr of+                        CmmLit (CmmLabel lbl)   -> Left lbl+                        _                       -> Right mopExpr++        return mopLabelOrExpr+++-- | Decide what C function to use to implement a CallishMachOp+--+outOfLineMachOp_table+        :: CallishMachOp+        -> FastString++outOfLineMachOp_table mop+ = case mop of+        MO_F32_Exp    -> fsLit "expf"+        MO_F32_Log    -> fsLit "logf"+        MO_F32_Sqrt   -> fsLit "sqrtf"+        MO_F32_Fabs   -> unsupported+        MO_F32_Pwr    -> fsLit "powf"++        MO_F32_Sin    -> fsLit "sinf"+        MO_F32_Cos    -> fsLit "cosf"+        MO_F32_Tan    -> fsLit "tanf"++        MO_F32_Asin   -> fsLit "asinf"+        MO_F32_Acos   -> fsLit "acosf"+        MO_F32_Atan   -> fsLit "atanf"++        MO_F32_Sinh   -> fsLit "sinhf"+        MO_F32_Cosh   -> fsLit "coshf"+        MO_F32_Tanh   -> fsLit "tanhf"++        MO_F64_Exp    -> fsLit "exp"+        MO_F64_Log    -> fsLit "log"+        MO_F64_Sqrt   -> fsLit "sqrt"+        MO_F64_Fabs   -> unsupported+        MO_F64_Pwr    -> fsLit "pow"++        MO_F64_Sin    -> fsLit "sin"+        MO_F64_Cos    -> fsLit "cos"+        MO_F64_Tan    -> fsLit "tan"++        MO_F64_Asin   -> fsLit "asin"+        MO_F64_Acos   -> fsLit "acos"+        MO_F64_Atan   -> fsLit "atan"++        MO_F64_Sinh   -> fsLit "sinh"+        MO_F64_Cosh   -> fsLit "cosh"+        MO_F64_Tanh   -> fsLit "tanh"++        MO_UF_Conv w -> fsLit $ word2FloatLabel w++        MO_Memcpy _  -> fsLit "memcpy"+        MO_Memset _  -> fsLit "memset"+        MO_Memmove _ -> fsLit "memmove"++        MO_BSwap w   -> fsLit $ bSwapLabel w+        MO_PopCnt w  -> fsLit $ popCntLabel w+        MO_Clz w     -> fsLit $ clzLabel w+        MO_Ctz w     -> fsLit $ ctzLabel w+        MO_AtomicRMW w amop -> fsLit $ atomicRMWLabel w amop+        MO_Cmpxchg w -> fsLit $ cmpxchgLabel w+        MO_AtomicRead w -> fsLit $ atomicReadLabel w+        MO_AtomicWrite w -> fsLit $ atomicWriteLabel w++        MO_S_QuotRem {}  -> unsupported+        MO_U_QuotRem {}  -> unsupported+        MO_U_QuotRem2 {} -> unsupported+        MO_Add2 {}       -> unsupported+        MO_SubWordC {}   -> unsupported+        MO_AddIntC {}    -> unsupported+        MO_SubIntC {}    -> unsupported+        MO_U_Mul2 {}     -> unsupported+        MO_WriteBarrier  -> unsupported+        MO_Touch         -> unsupported+        (MO_Prefetch_Data _) -> unsupported+    where unsupported = panic ("outOfLineCmmOp: " ++ show mop+                            ++ " not supported here")+
+ nativeGen/SPARC/CodeGen/Amode.hs view
@@ -0,0 +1,72 @@+module SPARC.CodeGen.Amode (+        getAmode+)++where++import {-# SOURCE #-} SPARC.CodeGen.Gen32+import SPARC.CodeGen.Base+import SPARC.AddrMode+import SPARC.Imm+import SPARC.Instr+import SPARC.Regs+import SPARC.Base+import NCGMonad+import Format++import Cmm++import OrdList+++-- | Generate code to reference a memory address.+getAmode+        :: CmmExpr      -- ^ expr producing an address+        -> NatM Amode++getAmode tree@(CmmRegOff _ _)+    = do dflags <- getDynFlags+         getAmode (mangleIndexTree dflags tree)++getAmode (CmmMachOp (MO_Sub _) [x, CmmLit (CmmInt i _)])+  | fits13Bits (-i)+  = do+       (reg, code) <- getSomeReg x+       let+         off  = ImmInt (-(fromInteger i))+       return (Amode (AddrRegImm reg off) code)+++getAmode (CmmMachOp (MO_Add _) [x, CmmLit (CmmInt i _)])+  | fits13Bits i+  = do+       (reg, code) <- getSomeReg x+       let+         off  = ImmInt (fromInteger i)+       return (Amode (AddrRegImm reg off) code)++getAmode (CmmMachOp (MO_Add _) [x, y])+  = do+    (regX, codeX) <- getSomeReg x+    (regY, codeY) <- getSomeReg y+    let+        code = codeX `appOL` codeY+    return (Amode (AddrRegReg regX regY) code)++getAmode (CmmLit lit)+  = do+        let imm__2      = litToImm lit+        tmp1    <- getNewRegNat II32+        tmp2    <- getNewRegNat II32++        let code = toOL [ SETHI (HI imm__2) tmp1+                        , OR    False tmp1 (RIImm (LO imm__2)) tmp2]++        return (Amode (AddrRegReg tmp2 g0) code)++getAmode other+  = do+       (reg, code) <- getSomeReg other+       let+            off  = ImmInt 0+       return (Amode (AddrRegImm reg off) code)
+ nativeGen/SPARC/CodeGen/Base.hs view
@@ -0,0 +1,117 @@+module SPARC.CodeGen.Base (+        InstrBlock,+        CondCode(..),+        ChildCode64(..),+        Amode(..),++        Register(..),+        setFormatOfRegister,++        getRegisterReg,+        mangleIndexTree+)++where++import SPARC.Instr+import SPARC.Cond+import SPARC.AddrMode+import SPARC.Regs+import Format+import Reg++import CodeGen.Platform+import DynFlags+import Cmm+import PprCmmExpr ()+import Platform++import Outputable+import OrdList++--------------------------------------------------------------------------------+-- | 'InstrBlock's are the insn sequences generated by the insn selectors.+--      They are really trees of insns to facilitate fast appending, where a+--      left-to-right traversal yields the insns in the correct order.+--+type InstrBlock+        = OrdList Instr+++-- | Condition codes passed up the tree.+--+data CondCode+        = CondCode Bool Cond InstrBlock+++-- | a.k.a "Register64"+--      Reg is the lower 32-bit temporary which contains the result.+--      Use getHiVRegFromLo to find the other VRegUnique.+--+--      Rules of this simplified insn selection game are therefore that+--      the returned Reg may be modified+--+data ChildCode64+   = ChildCode64+        InstrBlock+        Reg+++-- | Holds code that references a memory address.+data Amode+        = Amode+                -- the AddrMode we can use in the instruction+                --      that does the real load\/store.+                AddrMode++                -- other setup code we have to run first before we can use the+                --      above AddrMode.+                InstrBlock++++--------------------------------------------------------------------------------+-- | Code to produce a result into a register.+--      If the result must go in a specific register, it comes out as Fixed.+--      Otherwise, the parent can decide which register to put it in.+--+data Register+        = Fixed Format Reg InstrBlock+        | Any   Format (Reg -> InstrBlock)+++-- | Change the format field in a Register.+setFormatOfRegister+        :: Register -> Format -> Register++setFormatOfRegister reg format+ = case reg of+        Fixed _ reg code        -> Fixed format reg code+        Any _ codefn            -> Any   format codefn+++--------------------------------------------------------------------------------+-- | Grab the Reg for a CmmReg+getRegisterReg :: Platform -> CmmReg -> Reg++getRegisterReg _ (CmmLocal (LocalReg u pk))+        = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk)++getRegisterReg platform (CmmGlobal mid)+  = case globalRegMaybe platform mid of+        Just reg -> RegReal reg+        Nothing  -> pprPanic+                        "SPARC.CodeGen.Base.getRegisterReg: global is in memory"+                        (ppr $ CmmGlobal mid)+++-- Expand CmmRegOff.  ToDo: should we do it this way around, or convert+-- CmmExprs into CmmRegOff?+mangleIndexTree :: DynFlags -> CmmExpr -> CmmExpr++mangleIndexTree dflags (CmmRegOff reg off)+        = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]+        where width = typeWidth (cmmRegType dflags reg)++mangleIndexTree _ _+        = panic "SPARC.CodeGen.Base.mangleIndexTree: no match"
+ nativeGen/SPARC/CodeGen/CondCode.hs view
@@ -0,0 +1,108 @@+module SPARC.CodeGen.CondCode (+        getCondCode,+        condIntCode,+        condFltCode+)++where++import {-# SOURCE #-} SPARC.CodeGen.Gen32+import SPARC.CodeGen.Base+import SPARC.Instr+import SPARC.Regs+import SPARC.Cond+import SPARC.Imm+import SPARC.Base+import NCGMonad+import Format++import Cmm++import OrdList+import Outputable+++getCondCode :: CmmExpr -> NatM CondCode+getCondCode (CmmMachOp mop [x, y])+  =+    case mop of+      MO_F_Eq W32 -> condFltCode EQQ x y+      MO_F_Ne W32 -> condFltCode NE  x y+      MO_F_Gt W32 -> condFltCode GTT x y+      MO_F_Ge W32 -> condFltCode GE  x y+      MO_F_Lt W32 -> condFltCode LTT x y+      MO_F_Le W32 -> condFltCode LE  x y++      MO_F_Eq W64 -> condFltCode EQQ x y+      MO_F_Ne W64 -> condFltCode NE  x y+      MO_F_Gt W64 -> condFltCode GTT x y+      MO_F_Ge W64 -> condFltCode GE  x y+      MO_F_Lt W64 -> condFltCode LTT x y+      MO_F_Le W64 -> condFltCode LE  x y++      MO_Eq   _   -> condIntCode EQQ  x y+      MO_Ne   _   -> condIntCode NE   x y++      MO_S_Gt _   -> condIntCode GTT  x y+      MO_S_Ge _   -> condIntCode GE   x y+      MO_S_Lt _   -> condIntCode LTT  x y+      MO_S_Le _   -> condIntCode LE   x y++      MO_U_Gt _   -> condIntCode GU   x y+      MO_U_Ge _   -> condIntCode GEU  x y+      MO_U_Lt _   -> condIntCode LU   x y+      MO_U_Le _   -> condIntCode LEU  x y++      _           -> pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr (CmmMachOp mop [x,y]))++getCondCode other = pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr other)++++++-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be+-- passed back up the tree.++condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode+condIntCode cond x (CmmLit (CmmInt y _))+  | fits13Bits y+  = do+       (src1, code) <- getSomeReg x+       let+           src2 = ImmInt (fromInteger y)+           code' = code `snocOL` SUB False True src1 (RIImm src2) g0+       return (CondCode False cond code')++condIntCode cond x y = do+    (src1, code1) <- getSomeReg x+    (src2, code2) <- getSomeReg y+    let+        code__2 = code1 `appOL` code2 `snocOL`+                  SUB False True src1 (RIReg src2) g0+    return (CondCode False cond code__2)+++condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode+condFltCode cond x y = do+    dflags <- getDynFlags+    (src1, code1) <- getSomeReg x+    (src2, code2) <- getSomeReg y+    tmp <- getNewRegNat FF64+    let+        promote x = FxTOy FF32 FF64 x tmp++        pk1   = cmmExprType dflags x+        pk2   = cmmExprType dflags y++        code__2 =+                if pk1 `cmmEqType` pk2 then+                    code1 `appOL` code2 `snocOL`+                    FCMP True (cmmTypeFormat pk1) src1 src2+                else if typeWidth pk1 == W32 then+                    code1 `snocOL` promote src1 `appOL` code2 `snocOL`+                    FCMP True FF64 tmp src2+                else+                    code1 `appOL` code2 `snocOL` promote src2 `snocOL`+                    FCMP True FF64 src1 tmp+    return (CondCode True cond code__2)
+ nativeGen/SPARC/CodeGen/Expand.hs view
@@ -0,0 +1,153 @@+-- | Expand out synthetic instructions into single machine instrs.+module SPARC.CodeGen.Expand (+        expandTop+)++where++import SPARC.Instr+import SPARC.Imm+import SPARC.AddrMode+import SPARC.Regs+import SPARC.Ppr        ()+import Instruction+import Reg+import Format+import Cmm+++import Outputable+import OrdList++-- | Expand out synthetic instructions in this top level thing+expandTop :: NatCmmDecl CmmStatics Instr -> NatCmmDecl CmmStatics Instr+expandTop top@(CmmData{})+        = top++expandTop (CmmProc info lbl live (ListGraph blocks))+        = CmmProc info lbl live (ListGraph $ map expandBlock blocks)+++-- | Expand out synthetic instructions in this block+expandBlock :: NatBasicBlock Instr -> NatBasicBlock Instr++expandBlock (BasicBlock label instrs)+ = let  instrs_ol       = expandBlockInstrs instrs+        instrs'         = fromOL instrs_ol+   in   BasicBlock label instrs'+++-- | Expand out some instructions+expandBlockInstrs :: [Instr] -> OrdList Instr+expandBlockInstrs []    = nilOL++expandBlockInstrs (ii:is)+ = let  ii_doubleRegs   = remapRegPair ii+        is_misaligned   = expandMisalignedDoubles ii_doubleRegs++   in   is_misaligned `appOL` expandBlockInstrs is++++-- | In the SPARC instruction set the FP register pairs that are used+--      to hold 64 bit floats are refered to by just the first reg+--      of the pair. Remap our internal reg pairs to the appropriate reg.+--+--      For example:+--          ldd [%l1], (%f0 | %f1)+--+--      gets mapped to+--          ldd [$l1], %f0+--+remapRegPair :: Instr -> Instr+remapRegPair instr+ = let  patchF reg+         = case reg of+                RegReal (RealRegSingle _)+                        -> reg++                RegReal (RealRegPair r1 r2)++                        -- sanity checking+                        | r1         >= 32+                        , r1         <= 63+                        , r1 `mod` 2 == 0+                        , r2         == r1 + 1+                        -> RegReal (RealRegSingle r1)++                        | otherwise+                        -> pprPanic "SPARC.CodeGen.Expand: not remapping dodgy looking reg pair " (ppr reg)++                RegVirtual _+                        -> pprPanic "SPARC.CodeGen.Expand: not remapping virtual reg " (ppr reg)++   in   patchRegsOfInstr instr patchF+++++-- Expand out 64 bit load/stores into individual instructions to handle+--      possible double alignment problems.+--+--      TODO:   It'd be better to use a scratch reg instead of the add/sub thing.+--              We might be able to do this faster if we use the UA2007 instr set+--              instead of restricting ourselves to SPARC V9.+--+expandMisalignedDoubles :: Instr -> OrdList Instr+expandMisalignedDoubles instr++        -- Translate to:+        --    add g1,g2,g1+        --    ld  [g1],%fn+        --    ld  [g1+4],%f(n+1)+        --    sub g1,g2,g1           -- to restore g1+        | LD FF64 (AddrRegReg r1 r2) fReg       <- instr+        =       toOL    [ ADD False False r1 (RIReg r2) r1+                        , LD  FF32  (AddrRegReg r1 g0)          fReg+                        , LD  FF32  (AddrRegImm r1 (ImmInt 4))  (fRegHi fReg)+                        , SUB False False r1 (RIReg r2) r1 ]++        -- Translate to+        --    ld  [addr],%fn+        --    ld  [addr+4],%f(n+1)+        | LD FF64 addr fReg                     <- instr+        = let   Just addr'      = addrOffset addr 4+          in    toOL    [ LD  FF32  addr        fReg+                        , LD  FF32  addr'       (fRegHi fReg) ]++        -- Translate to:+        --    add g1,g2,g1+        --    st  %fn,[g1]+        --    st  %f(n+1),[g1+4]+        --    sub g1,g2,g1           -- to restore g1+        | ST FF64 fReg (AddrRegReg r1 r2)       <- instr+        =       toOL    [ ADD False False r1 (RIReg r2) r1+                        , ST  FF32  fReg           (AddrRegReg r1 g0)+                        , ST  FF32  (fRegHi fReg)  (AddrRegImm r1 (ImmInt 4))+                        , SUB False False r1 (RIReg r2) r1 ]++        -- Translate to+        --    ld  [addr],%fn+        --    ld  [addr+4],%f(n+1)+        | ST FF64 fReg addr                     <- instr+        = let   Just addr'      = addrOffset addr 4+          in    toOL    [ ST  FF32  fReg           addr+                        , ST  FF32  (fRegHi fReg)  addr'         ]++        -- some other instr+        | otherwise+        = unitOL instr++++-- | The the high partner for this float reg.+fRegHi :: Reg -> Reg+fRegHi (RegReal (RealRegSingle r1))+        | r1            >= 32+        , r1            <= 63+        , r1 `mod` 2 == 0+        = (RegReal $ RealRegSingle (r1 + 1))++-- Can't take high partner for non-low reg.+fRegHi reg+        = pprPanic "SPARC.CodeGen.Expand: can't take fRegHi from " (ppr reg)
+ nativeGen/SPARC/CodeGen/Gen32.hs view
@@ -0,0 +1,690 @@+-- | Evaluation of 32 bit values.+module SPARC.CodeGen.Gen32 (+        getSomeReg,+        getRegister+)++where++import SPARC.CodeGen.CondCode+import SPARC.CodeGen.Amode+import SPARC.CodeGen.Gen64+import SPARC.CodeGen.Base+import SPARC.Stack+import SPARC.Instr+import SPARC.Cond+import SPARC.AddrMode+import SPARC.Imm+import SPARC.Regs+import SPARC.Base+import NCGMonad+import Format+import Reg++import Cmm++import Control.Monad (liftM)+import DynFlags+import OrdList+import Outputable++-- | The dual to getAnyReg: compute an expression into a register, but+--      we don't mind which one it is.+getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)+getSomeReg expr = do+  r <- getRegister expr+  case r of+    Any rep code -> do+        tmp <- getNewRegNat rep+        return (tmp, code tmp)+    Fixed _ reg code ->+        return (reg, code)++++-- | Make code to evaluate a 32 bit expression.+--+getRegister :: CmmExpr -> NatM Register++getRegister (CmmReg reg)+  = do dflags <- getDynFlags+       let platform = targetPlatform dflags+       return (Fixed (cmmTypeFormat (cmmRegType dflags reg))+                     (getRegisterReg platform reg) nilOL)++getRegister tree@(CmmRegOff _ _)+  = do dflags <- getDynFlags+       getRegister (mangleIndexTree dflags tree)++getRegister (CmmMachOp (MO_UU_Conv W64 W32)+             [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do+  ChildCode64 code rlo <- iselExpr64 x+  return $ Fixed II32 (getHiVRegFromLo rlo) code++getRegister (CmmMachOp (MO_SS_Conv W64 W32)+             [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do+  ChildCode64 code rlo <- iselExpr64 x+  return $ Fixed II32 (getHiVRegFromLo rlo) code++getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do+  ChildCode64 code rlo <- iselExpr64 x+  return $ Fixed II32 rlo code++getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do+  ChildCode64 code rlo <- iselExpr64 x+  return $ Fixed II32 rlo code+++-- Load a literal float into a float register.+--      The actual literal is stored in a new data area, and we load it+--      at runtime.+getRegister (CmmLit (CmmFloat f W32)) = do++    -- a label for the new data area+    lbl <- getNewLabelNat+    tmp <- getNewRegNat II32++    let code dst = toOL [+            -- the data area+            LDATA (Section ReadOnlyData lbl) $ Statics lbl+                         [CmmStaticLit (CmmFloat f W32)],++            -- load the literal+            SETHI (HI (ImmCLbl lbl)) tmp,+            LD II32 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]++    return (Any FF32 code)++getRegister (CmmLit (CmmFloat d W64)) = do+    lbl <- getNewLabelNat+    tmp <- getNewRegNat II32+    let code dst = toOL [+            LDATA (Section ReadOnlyData lbl) $ Statics lbl+                         [CmmStaticLit (CmmFloat d W64)],+            SETHI (HI (ImmCLbl lbl)) tmp,+            LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]+    return (Any FF64 code)+++-- Unary machine ops+getRegister (CmmMachOp mop [x])+  = case mop of+        -- Floating point negation -------------------------+        MO_F_Neg W32            -> trivialUFCode FF32 (FNEG FF32) x+        MO_F_Neg W64            -> trivialUFCode FF64 (FNEG FF64) x+++        -- Integer negation --------------------------------+        MO_S_Neg rep            -> trivialUCode (intFormat rep) (SUB False False g0) x+        MO_Not rep              -> trivialUCode (intFormat rep) (XNOR False g0) x+++        -- Float word size conversion ----------------------+        MO_FF_Conv W64 W32      -> coerceDbl2Flt x+        MO_FF_Conv W32 W64      -> coerceFlt2Dbl x+++        -- Float <-> Signed Int conversion -----------------+        MO_FS_Conv from to      -> coerceFP2Int from to x+        MO_SF_Conv from to      -> coerceInt2FP from to x+++        -- Unsigned integer word size conversions ----------++        -- If it's the same size, then nothing needs to be done.+        MO_UU_Conv from to+         | from == to           -> conversionNop (intFormat to)  x++        -- To narrow an unsigned word, mask out the high bits to simulate what would+        --      happen if we copied the value into a smaller register.+        MO_UU_Conv W16 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))+        MO_UU_Conv W32 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))++        -- for narrowing 32 bit to 16 bit, don't use a literal mask value like the W16->W8+        --      case because the only way we can load it is via SETHI, which needs 2 ops.+        --      Do some shifts to chop out the high bits instead.+        MO_UU_Conv W32 W16+         -> do  tmpReg          <- getNewRegNat II32+                (xReg, xCode)   <- getSomeReg x+                let code dst+                        =       xCode+                        `appOL` toOL+                                [ SLL xReg   (RIImm $ ImmInt 16) tmpReg+                                , SRL tmpReg (RIImm $ ImmInt 16) dst]++                return  $ Any II32 code++                --       trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16))++        -- To widen an unsigned word we don't have to do anything.+        --      Just leave it in the same register and mark the result as the new size.+        MO_UU_Conv W8  W16      -> conversionNop (intFormat W16)  x+        MO_UU_Conv W8  W32      -> conversionNop (intFormat W32)  x+        MO_UU_Conv W16 W32      -> conversionNop (intFormat W32)  x+++        -- Signed integer word size conversions ------------++        -- Mask out high bits when narrowing them+        MO_SS_Conv W16 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))+        MO_SS_Conv W32 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))+        MO_SS_Conv W32 W16      -> trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16))++        -- Sign extend signed words when widening them.+        MO_SS_Conv W8  W16      -> integerExtend W8  W16 x+        MO_SS_Conv W8  W32      -> integerExtend W8  W32 x+        MO_SS_Conv W16 W32      -> integerExtend W16 W32 x++        _                       -> panic ("Unknown unary mach op: " ++ show mop)+++-- Binary machine ops+getRegister (CmmMachOp mop [x, y])+  = case mop of+      MO_Eq _           -> condIntReg EQQ x y+      MO_Ne _           -> condIntReg NE x y++      MO_S_Gt _         -> condIntReg GTT x y+      MO_S_Ge _         -> condIntReg GE x y+      MO_S_Lt _         -> condIntReg LTT x y+      MO_S_Le _         -> condIntReg LE x y++      MO_U_Gt W32       -> condIntReg GU  x y+      MO_U_Ge W32       -> condIntReg GEU x y+      MO_U_Lt W32       -> condIntReg LU  x y+      MO_U_Le W32       -> condIntReg LEU x y++      MO_U_Gt W16       -> condIntReg GU  x y+      MO_U_Ge W16       -> condIntReg GEU x y+      MO_U_Lt W16       -> condIntReg LU  x y+      MO_U_Le W16       -> condIntReg LEU x y++      MO_Add W32        -> trivialCode W32 (ADD False False) x y+      MO_Sub W32        -> trivialCode W32 (SUB False False) x y++      MO_S_MulMayOflo rep -> imulMayOflo rep x y++      MO_S_Quot W32     -> idiv True  False x y+      MO_U_Quot W32     -> idiv False False x y++      MO_S_Rem  W32     -> irem True  x y+      MO_U_Rem  W32     -> irem False x y++      MO_F_Eq _         -> condFltReg EQQ x y+      MO_F_Ne _         -> condFltReg NE x y++      MO_F_Gt _         -> condFltReg GTT x y+      MO_F_Ge _         -> condFltReg GE x y+      MO_F_Lt _         -> condFltReg LTT x y+      MO_F_Le _         -> condFltReg LE x y++      MO_F_Add  w       -> trivialFCode w FADD x y+      MO_F_Sub  w       -> trivialFCode w FSUB x y+      MO_F_Mul  w       -> trivialFCode w FMUL x y+      MO_F_Quot w       -> trivialFCode w FDIV x y++      MO_And rep        -> trivialCode rep (AND False) x y+      MO_Or  rep        -> trivialCode rep (OR  False) x y+      MO_Xor rep        -> trivialCode rep (XOR False) x y++      MO_Mul rep        -> trivialCode rep (SMUL False) x y++      MO_Shl rep        -> trivialCode rep SLL  x y+      MO_U_Shr rep      -> trivialCode rep SRL x y+      MO_S_Shr rep      -> trivialCode rep SRA x y++      _                 -> pprPanic "getRegister(sparc) - binary CmmMachOp (1)" (pprMachOp mop)++getRegister (CmmLoad mem pk) = do+    Amode src code <- getAmode mem+    let+        code__2 dst     = code `snocOL` LD (cmmTypeFormat pk) src dst+    return (Any (cmmTypeFormat pk) code__2)++getRegister (CmmLit (CmmInt i _))+  | fits13Bits i+  = let+        src = ImmInt (fromInteger i)+        code dst = unitOL (OR False g0 (RIImm src) dst)+    in+        return (Any II32 code)++getRegister (CmmLit lit)+  = let imm = litToImm lit+        code dst = toOL [+            SETHI (HI imm) dst,+            OR False dst (RIImm (LO imm)) dst]+    in return (Any II32 code)+++getRegister _+        = panic "SPARC.CodeGen.Gen32.getRegister: no match"+++-- | sign extend and widen+integerExtend+        :: Width                -- ^ width of source expression+        -> Width                -- ^ width of result+        -> CmmExpr              -- ^ source expression+        -> NatM Register++integerExtend from to expr+ = do   -- load the expr into some register+        (reg, e_code)   <- getSomeReg expr+        tmp             <- getNewRegNat II32+        let bitCount+                = case (from, to) of+                        (W8,  W32)      -> 24+                        (W16, W32)      -> 16+                        (W8,  W16)      -> 24+                        _               -> panic "SPARC.CodeGen.Gen32: no match"+        let code dst+                = e_code++                -- local shift word left to load the sign bit+                `snocOL`  SLL reg (RIImm (ImmInt bitCount)) tmp++                -- arithmetic shift right to sign extend+                `snocOL`  SRA tmp (RIImm (ImmInt bitCount)) dst++        return (Any (intFormat to) code)+++-- | For nop word format conversions we set the resulting value to have the+--      required size, but don't need to generate any actual code.+--+conversionNop+        :: Format -> CmmExpr -> NatM Register++conversionNop new_rep expr+ = do   e_code <- getRegister expr+        return (setFormatOfRegister e_code new_rep)++++-- | Generate an integer division instruction.+idiv :: Bool -> Bool -> CmmExpr -> CmmExpr -> NatM Register++-- For unsigned division with a 32 bit numerator,+--              we can just clear the Y register.+idiv False cc x y+ = do+        (a_reg, a_code)         <- getSomeReg x+        (b_reg, b_code)         <- getSomeReg y++        let code dst+                =       a_code+                `appOL` b_code+                `appOL` toOL+                        [ WRY  g0 g0+                        , UDIV cc a_reg (RIReg b_reg) dst]++        return (Any II32 code)+++-- For _signed_ division with a 32 bit numerator,+--              we have to sign extend the numerator into the Y register.+idiv True cc x y+ = do+        (a_reg, a_code)         <- getSomeReg x+        (b_reg, b_code)         <- getSomeReg y++        tmp                     <- getNewRegNat II32++        let code dst+                =       a_code+                `appOL` b_code+                `appOL` toOL+                        [ SRA  a_reg (RIImm (ImmInt 16)) tmp            -- sign extend+                        , SRA  tmp   (RIImm (ImmInt 16)) tmp++                        , WRY  tmp g0+                        , SDIV cc a_reg (RIReg b_reg) dst]++        return (Any II32 code)+++-- | Do an integer remainder.+--+--       NOTE:  The SPARC v8 architecture manual says that integer division+--              instructions _may_ generate a remainder, depending on the implementation.+--              If so it is _recommended_ that the remainder is placed in the Y register.+--+--          The UltraSparc 2007 manual says Y is _undefined_ after division.+--+--              The SPARC T2 doesn't store the remainder, not sure about the others.+--              It's probably best not to worry about it, and just generate our own+--              remainders.+--+irem :: Bool -> CmmExpr -> CmmExpr -> NatM Register++-- For unsigned operands:+--              Division is between a 64 bit numerator and a 32 bit denominator,+--              so we still have to clear the Y register.+irem False x y+ = do+        (a_reg, a_code) <- getSomeReg x+        (b_reg, b_code) <- getSomeReg y++        tmp_reg         <- getNewRegNat II32++        let code dst+                =       a_code+                `appOL` b_code+                `appOL` toOL+                        [ WRY   g0 g0+                        , UDIV  False         a_reg (RIReg b_reg) tmp_reg+                        , UMUL  False       tmp_reg (RIReg b_reg) tmp_reg+                        , SUB   False False   a_reg (RIReg tmp_reg) dst]++        return  (Any II32 code)++++-- For signed operands:+--              Make sure to sign extend into the Y register, or the remainder+--              will have the wrong sign when the numerator is negative.+--+--      TODO:   When sign extending, GCC only shifts the a_reg right by 17 bits,+--              not the full 32. Not sure why this is, something to do with overflow?+--              If anyone cares enough about the speed of signed remainder they+--              can work it out themselves (then tell me). -- BL 2009/01/20+irem True x y+ = do+        (a_reg, a_code) <- getSomeReg x+        (b_reg, b_code) <- getSomeReg y++        tmp1_reg        <- getNewRegNat II32+        tmp2_reg        <- getNewRegNat II32++        let code dst+                =       a_code+                `appOL` b_code+                `appOL` toOL+                        [ SRA   a_reg      (RIImm (ImmInt 16)) tmp1_reg -- sign extend+                        , SRA   tmp1_reg   (RIImm (ImmInt 16)) tmp1_reg -- sign extend+                        , WRY   tmp1_reg g0++                        , SDIV  False          a_reg (RIReg b_reg)    tmp2_reg+                        , SMUL  False       tmp2_reg (RIReg b_reg)    tmp2_reg+                        , SUB   False False    a_reg (RIReg tmp2_reg) dst]++        return (Any II32 code)+++imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register+imulMayOflo rep a b+ = do+        (a_reg, a_code) <- getSomeReg a+        (b_reg, b_code) <- getSomeReg b+        res_lo <- getNewRegNat II32+        res_hi <- getNewRegNat II32++        let shift_amt  = case rep of+                          W32 -> 31+                          W64 -> 63+                          _ -> panic "shift_amt"++        let code dst = a_code `appOL` b_code `appOL`+                       toOL [+                           SMUL False a_reg (RIReg b_reg) res_lo,+                           RDY res_hi,+                           SRA res_lo (RIImm (ImmInt shift_amt)) res_lo,+                           SUB False False res_lo (RIReg res_hi) dst+                        ]+        return (Any II32 code)+++-- -----------------------------------------------------------------------------+-- 'trivial*Code': deal with trivial instructions++-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',+-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.+-- Only look for constants on the right hand side, because that's+-- where the generic optimizer will have put them.++-- Similarly, for unary instructions, we don't have to worry about+-- matching an StInt as the argument, because genericOpt will already+-- have handled the constant-folding.++trivialCode+        :: Width+        -> (Reg -> RI -> Reg -> Instr)+        -> CmmExpr+        -> CmmExpr+        -> NatM Register++trivialCode _ instr x (CmmLit (CmmInt y _))+  | fits13Bits y+  = do+      (src1, code) <- getSomeReg x+      let+        src2 = ImmInt (fromInteger y)+        code__2 dst = code `snocOL` instr src1 (RIImm src2) dst+      return (Any II32 code__2)+++trivialCode _ instr x y = do+    (src1, code1) <- getSomeReg x+    (src2, code2) <- getSomeReg y+    let+        code__2 dst = code1 `appOL` code2 `snocOL`+                      instr src1 (RIReg src2) dst+    return (Any II32 code__2)+++trivialFCode+        :: Width+        -> (Format -> Reg -> Reg -> Reg -> Instr)+        -> CmmExpr+        -> CmmExpr+        -> NatM Register++trivialFCode pk instr x y = do+    dflags <- getDynFlags+    (src1, code1) <- getSomeReg x+    (src2, code2) <- getSomeReg y+    tmp <- getNewRegNat FF64+    let+        promote x = FxTOy FF32 FF64 x tmp++        pk1   = cmmExprType dflags x+        pk2   = cmmExprType dflags y++        code__2 dst =+                if pk1 `cmmEqType` pk2 then+                    code1 `appOL` code2 `snocOL`+                    instr (floatFormat pk) src1 src2 dst+                else if typeWidth pk1 == W32 then+                    code1 `snocOL` promote src1 `appOL` code2 `snocOL`+                    instr FF64 tmp src2 dst+                else+                    code1 `appOL` code2 `snocOL` promote src2 `snocOL`+                    instr FF64 src1 tmp dst+    return (Any (cmmTypeFormat $ if pk1 `cmmEqType` pk2 then pk1 else cmmFloat W64)+                code__2)++++trivialUCode+        :: Format+        -> (RI -> Reg -> Instr)+        -> CmmExpr+        -> NatM Register++trivialUCode format instr x = do+    (src, code) <- getSomeReg x+    let+        code__2 dst = code `snocOL` instr (RIReg src) dst+    return (Any format code__2)+++trivialUFCode+        :: Format+        -> (Reg -> Reg -> Instr)+        -> CmmExpr+        -> NatM Register++trivialUFCode pk instr x = do+    (src, code) <- getSomeReg x+    let+        code__2 dst = code `snocOL` instr src dst+    return (Any pk code__2)+++++-- Coercions -------------------------------------------------------------------++-- | Coerce a integer value to floating point+coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register+coerceInt2FP width1 width2 x = do+    (src, code) <- getSomeReg x+    let+        code__2 dst = code `appOL` toOL [+            ST (intFormat width1) src (spRel (-2)),+            LD (intFormat width1) (spRel (-2)) dst,+            FxTOy (intFormat width1) (floatFormat width2) dst dst]+    return (Any (floatFormat $ width2) code__2)++++-- | Coerce a floating point value to integer+--+--   NOTE: On sparc v9 there are no instructions to move a value from an+--         FP register directly to an int register, so we have to use a load/store.+--+coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register+coerceFP2Int width1 width2 x+ = do   let fformat1      = floatFormat width1+            fformat2      = floatFormat width2++            iformat2      = intFormat   width2++        (fsrc, code)    <- getSomeReg x+        fdst            <- getNewRegNat fformat2++        let code2 dst+                =       code+                `appOL` toOL+                        -- convert float to int format, leaving it in a float reg.+                        [ FxTOy fformat1 iformat2 fsrc fdst++                        -- store the int into mem, then load it back to move+                        --      it into an actual int reg.+                        , ST    fformat2 fdst (spRel (-2))+                        , LD    iformat2 (spRel (-2)) dst]++        return (Any iformat2 code2)+++-- | Coerce a double precision floating point value to single precision.+coerceDbl2Flt :: CmmExpr -> NatM Register+coerceDbl2Flt x = do+    (src, code) <- getSomeReg x+    return (Any FF32 (\dst -> code `snocOL` FxTOy FF64 FF32 src dst))+++-- | Coerce a single precision floating point value to double precision+coerceFlt2Dbl :: CmmExpr -> NatM Register+coerceFlt2Dbl x = do+    (src, code) <- getSomeReg x+    return (Any FF64 (\dst -> code `snocOL` FxTOy FF32 FF64 src dst))+++++-- Condition Codes -------------------------------------------------------------+--+-- Evaluate a comparison, and get the result into a register.+--+-- Do not fill the delay slots here. you will confuse the register allocator.+--+condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register+condIntReg EQQ x (CmmLit (CmmInt 0 _)) = do+    (src, code) <- getSomeReg x+    let+        code__2 dst = code `appOL` toOL [+            SUB False True g0 (RIReg src) g0,+            SUB True False g0 (RIImm (ImmInt (-1))) dst]+    return (Any II32 code__2)++condIntReg EQQ x y = do+    (src1, code1) <- getSomeReg x+    (src2, code2) <- getSomeReg y+    let+        code__2 dst = code1 `appOL` code2 `appOL` toOL [+            XOR False src1 (RIReg src2) dst,+            SUB False True g0 (RIReg dst) g0,+            SUB True False g0 (RIImm (ImmInt (-1))) dst]+    return (Any II32 code__2)++condIntReg NE x (CmmLit (CmmInt 0 _)) = do+    (src, code) <- getSomeReg x+    let+        code__2 dst = code `appOL` toOL [+            SUB False True g0 (RIReg src) g0,+            ADD True False g0 (RIImm (ImmInt 0)) dst]+    return (Any II32 code__2)++condIntReg NE x y = do+    (src1, code1) <- getSomeReg x+    (src2, code2) <- getSomeReg y+    let+        code__2 dst = code1 `appOL` code2 `appOL` toOL [+            XOR False src1 (RIReg src2) dst,+            SUB False True g0 (RIReg dst) g0,+            ADD True False g0 (RIImm (ImmInt 0)) dst]+    return (Any II32 code__2)++condIntReg cond x y = do+    bid1 <- liftM (\a -> seq a a) getBlockIdNat+    bid2 <- liftM (\a -> seq a a) getBlockIdNat+    CondCode _ cond cond_code <- condIntCode cond x y+    let+        code__2 dst+         =      cond_code+          `appOL` toOL+                [ BI cond False bid1+                , NOP++                , OR False g0 (RIImm (ImmInt 0)) dst+                , BI ALWAYS False bid2+                , NOP++                , NEWBLOCK bid1+                , OR False g0 (RIImm (ImmInt 1)) dst+                , BI ALWAYS False bid2+                , NOP++                , NEWBLOCK bid2]++    return (Any II32 code__2)+++condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register+condFltReg cond x y = do+    bid1 <- liftM (\a -> seq a a) getBlockIdNat+    bid2 <- liftM (\a -> seq a a) getBlockIdNat++    CondCode _ cond cond_code <- condFltCode cond x y+    let+        code__2 dst+         =      cond_code+          `appOL` toOL+                [ NOP+                , BF cond False bid1+                , NOP++                , OR False g0 (RIImm (ImmInt 0)) dst+                , BI ALWAYS False bid2+                , NOP++                , NEWBLOCK bid1+                , OR False g0 (RIImm (ImmInt 1)) dst+                , BI ALWAYS False bid2+                , NOP++                , NEWBLOCK bid2 ]++    return (Any II32 code__2)
+ nativeGen/SPARC/CodeGen/Gen32.hs-boot view
@@ -0,0 +1,16 @@++module SPARC.CodeGen.Gen32 (+        getSomeReg,+        getRegister+)++where++import SPARC.CodeGen.Base+import NCGMonad+import Reg++import Cmm++getSomeReg  :: CmmExpr -> NatM (Reg, InstrBlock)+getRegister :: CmmExpr -> NatM Register
+ nativeGen/SPARC/CodeGen/Gen64.hs view
@@ -0,0 +1,196 @@+-- | Evaluation of 64 bit values on 32 bit platforms.+module SPARC.CodeGen.Gen64 (+        assignMem_I64Code,+        assignReg_I64Code,+        iselExpr64+)++where++import {-# SOURCE #-} SPARC.CodeGen.Gen32+import SPARC.CodeGen.Base+import SPARC.CodeGen.Amode+import SPARC.Regs+import SPARC.AddrMode+import SPARC.Imm+import SPARC.Instr+import SPARC.Ppr()+import NCGMonad+import Instruction+import Format+import Reg++import Cmm++import DynFlags+import OrdList+import Outputable++-- | Code to assign a 64 bit value to memory.+assignMem_I64Code+        :: CmmExpr              -- ^ expr producing the destination address+        -> CmmExpr              -- ^ expr producing the source value.+        -> NatM InstrBlock++assignMem_I64Code addrTree valueTree+ = do+     ChildCode64 vcode rlo      <- iselExpr64 valueTree++     (src, acode) <- getSomeReg addrTree+     let+         rhi = getHiVRegFromLo rlo++         -- Big-endian store+         mov_hi = ST II32 rhi (AddrRegImm src (ImmInt 0))+         mov_lo = ST II32 rlo (AddrRegImm src (ImmInt 4))++         code   = vcode `appOL` acode `snocOL` mov_hi `snocOL` mov_lo++{-     pprTrace "assignMem_I64Code"+        (vcat   [ text "addrTree:  " <+> ppr addrTree+                , text "valueTree: " <+> ppr valueTree+                , text "vcode:"+                , vcat $ map ppr $ fromOL vcode+                , text ""+                , text "acode:"+                , vcat $ map ppr $ fromOL acode ])+       $ -}+     return code+++-- | Code to assign a 64 bit value to a register.+assignReg_I64Code+        :: CmmReg               -- ^ the destination register+        -> CmmExpr              -- ^ expr producing the source value+        -> NatM InstrBlock++assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree+ = do+     ChildCode64 vcode r_src_lo <- iselExpr64 valueTree+     let+         r_dst_lo = RegVirtual $ mkVirtualReg u_dst (cmmTypeFormat pk)+         r_dst_hi = getHiVRegFromLo r_dst_lo+         r_src_hi = getHiVRegFromLo r_src_lo+         mov_lo = mkMOV r_src_lo r_dst_lo+         mov_hi = mkMOV r_src_hi r_dst_hi+         mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg++     return (vcode `snocOL` mov_hi `snocOL` mov_lo)++assignReg_I64Code _ _+   = panic "assignReg_I64Code(sparc): invalid lvalue"+++++-- | Get the value of an expression into a 64 bit register.++iselExpr64 :: CmmExpr -> NatM ChildCode64++-- Load a 64 bit word+iselExpr64 (CmmLoad addrTree ty)+ | isWord64 ty+ = do   Amode amode addr_code   <- getAmode addrTree+        let result++                | AddrRegReg r1 r2      <- amode+                = do    rlo     <- getNewRegNat II32+                        tmp     <- getNewRegNat II32+                        let rhi = getHiVRegFromLo rlo++                        return  $ ChildCode64+                                (        addr_code+                                `appOL`  toOL+                                         [ ADD False False r1 (RIReg r2) tmp+                                         , LD II32 (AddrRegImm tmp (ImmInt 0)) rhi+                                         , LD II32 (AddrRegImm tmp (ImmInt 4)) rlo ])+                                rlo++                | AddrRegImm r1 (ImmInt i) <- amode+                = do    rlo     <- getNewRegNat II32+                        let rhi = getHiVRegFromLo rlo++                        return  $ ChildCode64+                                (        addr_code+                                `appOL`  toOL+                                         [ LD II32 (AddrRegImm r1 (ImmInt $ 0 + i)) rhi+                                         , LD II32 (AddrRegImm r1 (ImmInt $ 4 + i)) rlo ])+                                rlo++                | otherwise+                = panic "SPARC.CodeGen.Gen64: no match"++        result+++-- Add a literal to a 64 bit integer+iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)])+ = do   ChildCode64 code1 r1_lo <- iselExpr64 e1+        let r1_hi       = getHiVRegFromLo r1_lo++        r_dst_lo        <- getNewRegNat II32+        let r_dst_hi    =  getHiVRegFromLo r_dst_lo++        let code =      code1+                `appOL` toOL+                        [ ADD False True  r1_lo (RIImm (ImmInteger i)) r_dst_lo+                        , ADD True  False r1_hi (RIReg g0)         r_dst_hi ]++        return  $ ChildCode64 code r_dst_lo+++-- Addition of II64+iselExpr64 (CmmMachOp (MO_Add _) [e1, e2])+ = do   ChildCode64 code1 r1_lo <- iselExpr64 e1+        let r1_hi       = getHiVRegFromLo r1_lo++        ChildCode64 code2 r2_lo <- iselExpr64 e2+        let r2_hi       = getHiVRegFromLo r2_lo++        r_dst_lo        <- getNewRegNat II32+        let r_dst_hi    = getHiVRegFromLo r_dst_lo++        let code =      code1+                `appOL` code2+                `appOL` toOL+                        [ ADD False True  r1_lo (RIReg r2_lo) r_dst_lo+                        , ADD True  False r1_hi (RIReg r2_hi) r_dst_hi ]++        return  $ ChildCode64 code r_dst_lo+++iselExpr64 (CmmReg (CmmLocal (LocalReg uq ty)))+ | isWord64 ty+ = do+     r_dst_lo <-  getNewRegNat II32+     let r_dst_hi = getHiVRegFromLo r_dst_lo+         r_src_lo = RegVirtual $ mkVirtualReg uq II32+         r_src_hi = getHiVRegFromLo r_src_lo+         mov_lo = mkMOV r_src_lo r_dst_lo+         mov_hi = mkMOV r_src_hi r_dst_hi+         mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg+     return (+            ChildCode64 (toOL [mov_hi, mov_lo]) r_dst_lo+         )++-- Convert something into II64+iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr])+ = do+        r_dst_lo        <- getNewRegNat II32+        let r_dst_hi    = getHiVRegFromLo r_dst_lo++        -- compute expr and load it into r_dst_lo+        (a_reg, a_code) <- getSomeReg expr++        dflags <- getDynFlags+        let platform = targetPlatform dflags+            code        = a_code+                `appOL` toOL+                        [ mkRegRegMoveInstr platform g0    r_dst_hi     -- clear high 32 bits+                        , mkRegRegMoveInstr platform a_reg r_dst_lo ]++        return  $ ChildCode64 code r_dst_lo+++iselExpr64 expr+   = pprPanic "iselExpr64(sparc)" (ppr expr)
+ nativeGen/SPARC/CodeGen/Sanity.hs view
@@ -0,0 +1,67 @@+-- | One ounce of sanity checking is worth 10000000000000000 ounces+-- of staring blindly at assembly code trying to find the problem..+module SPARC.CodeGen.Sanity (+        checkBlock+)++where++import SPARC.Instr+import SPARC.Ppr        ()+import Instruction++import Cmm++import Outputable+++-- | Enforce intra-block invariants.+--+checkBlock :: CmmBlock+           -> NatBasicBlock Instr+           -> NatBasicBlock Instr++checkBlock cmm block@(BasicBlock _ instrs)+        | checkBlockInstrs instrs+        = block++        | otherwise+        = pprPanic+                ("SPARC.CodeGen: bad block\n")+                ( vcat  [ text " -- cmm -----------------\n"+                        , ppr cmm+                        , text " -- native code ---------\n"+                        , ppr block ])+++checkBlockInstrs :: [Instr] -> Bool+checkBlockInstrs ii++        -- An unconditional jumps end the block.+        --      There must be an unconditional jump in the block, otherwise+        --      the register liveness determinator will get the liveness+        --      information wrong.+        --+        --      If the block ends with a cmm call that never returns+        --      then there can be unreachable instructions after the jump,+        --      but we don't mind here.+        --+        | instr : NOP : _       <- ii+        , isUnconditionalJump instr+        = True++        -- All jumps must have a NOP in their branch delay slot.+        --      The liveness determinator and register allocators aren't smart+        --      enough to handle branch delay slots.+        --+        | instr : NOP : is      <- ii+        , isJumpishInstr instr+        = checkBlockInstrs is++        -- keep checking+        | _:i2:is               <- ii+        = checkBlockInstrs (i2:is)++        -- this block is no good+        | otherwise+        = False
+ nativeGen/SPARC/Cond.hs view
@@ -0,0 +1,52 @@+module SPARC.Cond (+        Cond(..),+        condUnsigned,+        condToSigned,+        condToUnsigned+)++where++-- | Branch condition codes.+data Cond+        = ALWAYS+        | EQQ+        | GE+        | GEU+        | GTT+        | GU+        | LE+        | LEU+        | LTT+        | LU+        | NE+        | NEG+        | NEVER+        | POS+        | VC+        | VS+        deriving Eq+++condUnsigned :: Cond -> Bool+condUnsigned GU  = True+condUnsigned LU  = True+condUnsigned GEU = True+condUnsigned LEU = True+condUnsigned _   = False+++condToSigned :: Cond -> Cond+condToSigned GU  = GTT+condToSigned LU  = LTT+condToSigned GEU = GE+condToSigned LEU = LE+condToSigned x   = x+++condToUnsigned :: Cond -> Cond+condToUnsigned GTT = GU+condToUnsigned LTT = LU+condToUnsigned GE  = GEU+condToUnsigned LE  = LEU+condToUnsigned x   = x
+ nativeGen/SPARC/Imm.hs view
@@ -0,0 +1,65 @@+module SPARC.Imm (+        -- immediate values+        Imm(..),+        strImmLit,+        litToImm+)++where++import Cmm+import CLabel++import Outputable++-- | An immediate value.+--      Not all of these are directly representable by the machine.+--      Things like ImmLit are slurped out and put in a data segment instead.+--+data Imm+        = ImmInt        Int++        -- Sigh.+        | ImmInteger    Integer++        -- AbstractC Label (with baggage)+        | ImmCLbl       CLabel++        -- Simple string+        | ImmLit        SDoc+        | ImmIndex      CLabel Int+        | ImmFloat      Rational+        | ImmDouble     Rational++        | ImmConstantSum  Imm Imm+        | ImmConstantDiff Imm Imm++        | LO    Imm+        | HI    Imm+++-- | Create a ImmLit containing this string.+strImmLit :: String -> Imm+strImmLit s = ImmLit (text s)+++-- | Convert a CmmLit to an Imm.+--      Narrow to the width: a CmmInt might be out of+--      range, but we assume that ImmInteger only contains+--      in-range values.  A signed value should be fine here.+--+litToImm :: CmmLit -> Imm+litToImm lit+ = case lit of+        CmmInt i w              -> ImmInteger (narrowS w i)+        CmmFloat f W32          -> ImmFloat f+        CmmFloat f W64          -> ImmDouble f+        CmmLabel l              -> ImmCLbl l+        CmmLabelOff l off       -> ImmIndex l off++        CmmLabelDiffOff l1 l2 off+         -> ImmConstantSum+                (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))+                (ImmInt off)++        _               -> panic "SPARC.Regs.litToImm: no match"
+ nativeGen/SPARC/Instr.hs view
@@ -0,0 +1,483 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Machine-dependent assembly language+--+-- (c) The University of Glasgow 1993-2004+--+-----------------------------------------------------------------------------+#include "HsVersions.h"+#include "nativeGen/NCG.h"++module SPARC.Instr (+        RI(..),+        riZero,++        fpRelEA,+        moveSp,++        isUnconditionalJump,++        Instr(..),+        maxSpillSlots+)++where++import SPARC.Stack+import SPARC.Imm+import SPARC.AddrMode+import SPARC.Cond+import SPARC.Regs+import SPARC.Base+import TargetReg+import Instruction+import RegClass+import Reg+import Format++import CLabel+import CodeGen.Platform+import BlockId+import DynFlags+import Cmm+import FastString+import Outputable+import Platform+++-- | Register or immediate+data RI+        = RIReg Reg+        | RIImm Imm++-- | Check if a RI represents a zero value.+--      - a literal zero+--      - register %g0, which is always zero.+--+riZero :: RI -> Bool+riZero (RIImm (ImmInt 0))                       = True+riZero (RIImm (ImmInteger 0))                   = True+riZero (RIReg (RegReal (RealRegSingle 0)))      = True+riZero _                                        = False+++-- | Calculate the effective address which would be used by the+--      corresponding fpRel sequence.+fpRelEA :: Int -> Reg -> Instr+fpRelEA n dst+   = ADD False False fp (RIImm (ImmInt (n * wordLength))) dst+++-- | Code to shift the stack pointer by n words.+moveSp :: Int -> Instr+moveSp n+   = ADD False False sp (RIImm (ImmInt (n * wordLength))) sp++-- | An instruction that will cause the one after it never to be exectuted+isUnconditionalJump :: Instr -> Bool+isUnconditionalJump ii+ = case ii of+        CALL{}          -> True+        JMP{}           -> True+        JMP_TBL{}       -> True+        BI ALWAYS _ _   -> True+        BF ALWAYS _ _   -> True+        _               -> False+++-- | instance for sparc instruction set+instance Instruction Instr where+        regUsageOfInstr         = sparc_regUsageOfInstr+        patchRegsOfInstr        = sparc_patchRegsOfInstr+        isJumpishInstr          = sparc_isJumpishInstr+        jumpDestsOfInstr        = sparc_jumpDestsOfInstr+        patchJumpInstr          = sparc_patchJumpInstr+        mkSpillInstr            = sparc_mkSpillInstr+        mkLoadInstr             = sparc_mkLoadInstr+        takeDeltaInstr          = sparc_takeDeltaInstr+        isMetaInstr             = sparc_isMetaInstr+        mkRegRegMoveInstr       = sparc_mkRegRegMoveInstr+        takeRegRegMoveInstr     = sparc_takeRegRegMoveInstr+        mkJumpInstr             = sparc_mkJumpInstr+        mkStackAllocInstr       = panic "no sparc_mkStackAllocInstr"+        mkStackDeallocInstr     = panic "no sparc_mkStackDeallocInstr"+++-- | SPARC instruction set.+--      Not complete. This is only the ones we need.+--+data Instr++        -- meta ops --------------------------------------------------+        -- comment pseudo-op+        = COMMENT FastString++        -- some static data spat out during code generation.+        -- Will be extracted before pretty-printing.+        | LDATA   Section CmmStatics++        -- Start a new basic block.  Useful during codegen, removed later.+        -- Preceding instruction should be a jump, as per the invariants+        -- for a BasicBlock (see Cmm).+        | NEWBLOCK BlockId++        -- specify current stack offset for benefit of subsequent passes.+        | DELTA   Int++        -- real instrs -----------------------------------------------+        -- Loads and stores.+        | LD            Format AddrMode Reg             -- format, src, dst+        | ST            Format Reg AddrMode             -- format, src, dst++        -- Int Arithmetic.+        --      x:   add/sub with carry bit.+        --              In SPARC V9 addx and friends were renamed addc.+        --+        --      cc:  modify condition codes+        --+        | ADD           Bool Bool Reg RI Reg            -- x?, cc?, src1, src2, dst+        | SUB           Bool Bool Reg RI Reg            -- x?, cc?, src1, src2, dst++        | UMUL          Bool Reg RI Reg                 --     cc?, src1, src2, dst+        | SMUL          Bool Reg RI Reg                 --     cc?, src1, src2, dst+++        -- The SPARC divide instructions perform 64bit by 32bit division+        --   The Y register is xored into the first operand.++        --   On _some implementations_ the Y register is overwritten by+        --   the remainder, so we have to make sure it is 0 each time.++        --   dst <- ((Y `shiftL` 32) `or` src1) `div` src2+        | UDIV          Bool Reg RI Reg                 --     cc?, src1, src2, dst+        | SDIV          Bool Reg RI Reg                 --     cc?, src1, src2, dst++        | RDY           Reg                             -- move contents of Y register to reg+        | WRY           Reg  Reg                        -- Y <- src1 `xor` src2++        -- Logic operations.+        | AND           Bool Reg RI Reg                 -- cc?, src1, src2, dst+        | ANDN          Bool Reg RI Reg                 -- cc?, src1, src2, dst+        | OR            Bool Reg RI Reg                 -- cc?, src1, src2, dst+        | ORN           Bool Reg RI Reg                 -- cc?, src1, src2, dst+        | XOR           Bool Reg RI Reg                 -- cc?, src1, src2, dst+        | XNOR          Bool Reg RI Reg                 -- cc?, src1, src2, dst+        | SLL           Reg RI Reg                      -- src1, src2, dst+        | SRL           Reg RI Reg                      -- src1, src2, dst+        | SRA           Reg RI Reg                      -- src1, src2, dst++        -- Load immediates.+        | SETHI         Imm Reg                         -- src, dst++        -- Do nothing.+        -- Implemented by the assembler as SETHI 0, %g0, but worth an alias+        | NOP++        -- Float Arithmetic.+        -- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single+        -- instructions right up until we spit them out.+        --+        | FABS          Format Reg Reg                  -- src dst+        | FADD          Format Reg Reg Reg              -- src1, src2, dst+        | FCMP          Bool Format Reg Reg             -- exception?, src1, src2, dst+        | FDIV          Format Reg Reg Reg              -- src1, src2, dst+        | FMOV          Format Reg Reg                  -- src, dst+        | FMUL          Format Reg Reg Reg              -- src1, src2, dst+        | FNEG          Format Reg Reg                  -- src, dst+        | FSQRT         Format Reg Reg                  -- src, dst+        | FSUB          Format Reg Reg Reg              -- src1, src2, dst+        | FxTOy         Format Format Reg Reg           -- src, dst++        -- Jumping around.+        | BI            Cond Bool BlockId               -- cond, annul?, target+        | BF            Cond Bool BlockId               -- cond, annul?, target++        | JMP           AddrMode                        -- target++        -- With a tabled jump we know all the possible destinations.+        -- We also need this info so we can work out what regs are live across the jump.+        --+        | JMP_TBL       AddrMode [Maybe BlockId] CLabel++        | CALL          (Either Imm Reg) Int Bool       -- target, args, terminal+++-- | regUsage returns the sets of src and destination registers used+--      by a particular instruction.  Machine registers that are+--      pre-allocated to stgRegs are filtered out, because they are+--      uninteresting from a register allocation standpoint.  (We wouldn't+--      want them to end up on the free list!)  As far as we are concerned,+--      the fixed registers simply don't exist (for allocation purposes,+--      anyway).++--      regUsage doesn't need to do any trickery for jumps and such.  Just+--      state precisely the regs read and written by that insn.  The+--      consequences of control flow transfers, as far as register+--      allocation goes, are taken care of by the register allocator.+--+sparc_regUsageOfInstr :: Platform -> Instr -> RegUsage+sparc_regUsageOfInstr platform instr+ = case instr of+    LD    _ addr reg            -> usage (regAddr addr,         [reg])+    ST    _ reg addr            -> usage (reg : regAddr addr,   [])+    ADD   _ _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])+    SUB   _ _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])+    UMUL    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])+    SMUL    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])+    UDIV    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])+    SDIV    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])+    RDY       rd                -> usage ([],                   [rd])+    WRY       r1 r2             -> usage ([r1, r2],             [])+    AND     _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])+    ANDN    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])+    OR      _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])+    ORN     _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])+    XOR     _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])+    XNOR    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])+    SLL       r1 ar r2          -> usage (r1 : regRI ar,        [r2])+    SRL       r1 ar r2          -> usage (r1 : regRI ar,        [r2])+    SRA       r1 ar r2          -> usage (r1 : regRI ar,        [r2])+    SETHI   _ reg               -> usage ([],                   [reg])+    FABS    _ r1 r2             -> usage ([r1],                 [r2])+    FADD    _ r1 r2 r3          -> usage ([r1, r2],             [r3])+    FCMP    _ _  r1 r2          -> usage ([r1, r2],             [])+    FDIV    _ r1 r2 r3          -> usage ([r1, r2],             [r3])+    FMOV    _ r1 r2             -> usage ([r1],                 [r2])+    FMUL    _ r1 r2 r3          -> usage ([r1, r2],             [r3])+    FNEG    _ r1 r2             -> usage ([r1],                 [r2])+    FSQRT   _ r1 r2             -> usage ([r1],                 [r2])+    FSUB    _ r1 r2 r3          -> usage ([r1, r2],             [r3])+    FxTOy   _ _  r1 r2          -> usage ([r1],                 [r2])++    JMP     addr                -> usage (regAddr addr, [])+    JMP_TBL addr _ _            -> usage (regAddr addr, [])++    CALL  (Left _  )  _ True    -> noUsage+    CALL  (Left _  )  n False   -> usage (argRegs n, callClobberedRegs)+    CALL  (Right reg) _ True    -> usage ([reg], [])+    CALL  (Right reg) n False   -> usage (reg : (argRegs n), callClobberedRegs)+    _                           -> noUsage++  where+    usage (src, dst)+     = RU (filter (interesting platform) src)+          (filter (interesting platform) dst)++    regAddr (AddrRegReg r1 r2)  = [r1, r2]+    regAddr (AddrRegImm r1 _)   = [r1]++    regRI (RIReg r)             = [r]+    regRI  _                    = []+++-- | Interesting regs are virtuals, or ones that are allocatable+--      by the register allocator.+interesting :: Platform -> Reg -> Bool+interesting platform reg+ = case reg of+        RegVirtual _                    -> True+        RegReal (RealRegSingle r1)      -> freeReg platform r1+        RegReal (RealRegPair r1 _)      -> freeReg platform r1++++-- | Apply a given mapping to tall the register references in this instruction.+sparc_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr+sparc_patchRegsOfInstr instr env = case instr of+    LD    fmt addr reg          -> LD fmt (fixAddr addr) (env reg)+    ST    fmt reg addr          -> ST fmt (env reg) (fixAddr addr)++    ADD   x cc r1 ar r2         -> ADD   x cc  (env r1) (fixRI ar) (env r2)+    SUB   x cc r1 ar r2         -> SUB   x cc  (env r1) (fixRI ar) (env r2)+    UMUL    cc r1 ar r2         -> UMUL    cc  (env r1) (fixRI ar) (env r2)+    SMUL    cc r1 ar r2         -> SMUL    cc  (env r1) (fixRI ar) (env r2)+    UDIV    cc r1 ar r2         -> UDIV    cc  (env r1) (fixRI ar) (env r2)+    SDIV    cc r1 ar r2         -> SDIV    cc  (env r1) (fixRI ar) (env r2)+    RDY   rd                    -> RDY         (env rd)+    WRY   r1 r2                 -> WRY         (env r1) (env r2)+    AND   b r1 ar r2            -> AND   b     (env r1) (fixRI ar) (env r2)+    ANDN  b r1 ar r2            -> ANDN  b     (env r1) (fixRI ar) (env r2)+    OR    b r1 ar r2            -> OR    b     (env r1) (fixRI ar) (env r2)+    ORN   b r1 ar r2            -> ORN   b     (env r1) (fixRI ar) (env r2)+    XOR   b r1 ar r2            -> XOR   b     (env r1) (fixRI ar) (env r2)+    XNOR  b r1 ar r2            -> XNOR  b     (env r1) (fixRI ar) (env r2)+    SLL   r1 ar r2              -> SLL         (env r1) (fixRI ar) (env r2)+    SRL   r1 ar r2              -> SRL         (env r1) (fixRI ar) (env r2)+    SRA   r1 ar r2              -> SRA         (env r1) (fixRI ar) (env r2)++    SETHI imm reg               -> SETHI imm (env reg)++    FABS  s r1 r2               -> FABS    s   (env r1) (env r2)+    FADD  s r1 r2 r3            -> FADD    s   (env r1) (env r2) (env r3)+    FCMP  e s r1 r2             -> FCMP e  s   (env r1) (env r2)+    FDIV  s r1 r2 r3            -> FDIV    s   (env r1) (env r2) (env r3)+    FMOV  s r1 r2               -> FMOV    s   (env r1) (env r2)+    FMUL  s r1 r2 r3            -> FMUL    s   (env r1) (env r2) (env r3)+    FNEG  s r1 r2               -> FNEG    s   (env r1) (env r2)+    FSQRT s r1 r2               -> FSQRT   s   (env r1) (env r2)+    FSUB  s r1 r2 r3            -> FSUB    s   (env r1) (env r2) (env r3)+    FxTOy s1 s2 r1 r2           -> FxTOy s1 s2 (env r1) (env r2)++    JMP     addr                -> JMP     (fixAddr addr)+    JMP_TBL addr ids l          -> JMP_TBL (fixAddr addr) ids l++    CALL  (Left i) n t          -> CALL (Left i) n t+    CALL  (Right r) n t         -> CALL (Right (env r)) n t+    _                           -> instr++  where+    fixAddr (AddrRegReg r1 r2)  = AddrRegReg   (env r1) (env r2)+    fixAddr (AddrRegImm r1 i)   = AddrRegImm   (env r1) i++    fixRI (RIReg r)             = RIReg (env r)+    fixRI other                 = other+++--------------------------------------------------------------------------------+sparc_isJumpishInstr :: Instr -> Bool+sparc_isJumpishInstr instr+ = case instr of+        BI{}            -> True+        BF{}            -> True+        JMP{}           -> True+        JMP_TBL{}       -> True+        CALL{}          -> True+        _               -> False++sparc_jumpDestsOfInstr :: Instr -> [BlockId]+sparc_jumpDestsOfInstr insn+  = case insn of+        BI   _ _ id     -> [id]+        BF   _ _ id     -> [id]+        JMP_TBL _ ids _ -> [id | Just id <- ids]+        _               -> []+++sparc_patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr+sparc_patchJumpInstr insn patchF+  = case insn of+        BI cc annul id  -> BI cc annul (patchF id)+        BF cc annul id  -> BF cc annul (patchF id)+        JMP_TBL n ids l -> JMP_TBL n (map (fmap patchF) ids) l+        _               -> insn+++--------------------------------------------------------------------------------+-- | Make a spill instruction.+--      On SPARC we spill below frame pointer leaving 2 words/spill+sparc_mkSpillInstr+    :: DynFlags+    -> Reg      -- ^ register to spill+    -> Int      -- ^ current stack delta+    -> Int      -- ^ spill slot to use+    -> Instr++sparc_mkSpillInstr dflags reg _ slot+ = let  platform = targetPlatform dflags+        off      = spillSlotToOffset dflags slot+        off_w    = 1 + (off `div` 4)+        fmt      = case targetClassOfReg platform reg of+                        RcInteger -> II32+                        RcFloat   -> FF32+                        RcDouble  -> FF64+                        _         -> panic "sparc_mkSpillInstr"++    in ST fmt reg (fpRel (negate off_w))+++-- | Make a spill reload instruction.+sparc_mkLoadInstr+    :: DynFlags+    -> Reg      -- ^ register to load into+    -> Int      -- ^ current stack delta+    -> Int      -- ^ spill slot to use+    -> Instr++sparc_mkLoadInstr dflags reg _ slot+  = let platform = targetPlatform dflags+        off      = spillSlotToOffset dflags slot+        off_w    = 1 + (off `div` 4)+        fmt      = case targetClassOfReg platform reg of+                        RcInteger -> II32+                        RcFloat   -> FF32+                        RcDouble  -> FF64+                        _         -> panic "sparc_mkLoadInstr"++        in LD fmt (fpRel (- off_w)) reg+++--------------------------------------------------------------------------------+-- | See if this instruction is telling us the current C stack delta+sparc_takeDeltaInstr+        :: Instr+        -> Maybe Int++sparc_takeDeltaInstr instr+ = case instr of+        DELTA i         -> Just i+        _               -> Nothing+++sparc_isMetaInstr+        :: Instr+        -> Bool++sparc_isMetaInstr instr+ = case instr of+        COMMENT{}       -> True+        LDATA{}         -> True+        NEWBLOCK{}      -> True+        DELTA{}         -> True+        _               -> False+++-- | Make a reg-reg move instruction.+--      On SPARC v8 there are no instructions to move directly between+--      floating point and integer regs. If we need to do that then we+--      have to go via memory.+--+sparc_mkRegRegMoveInstr+    :: Platform+    -> Reg+    -> Reg+    -> Instr++sparc_mkRegRegMoveInstr platform src dst+        | srcClass      <- targetClassOfReg platform src+        , dstClass      <- targetClassOfReg platform dst+        , srcClass == dstClass+        = case srcClass of+                RcInteger -> ADD  False False src (RIReg g0) dst+                RcDouble  -> FMOV FF64 src dst+                RcFloat   -> FMOV FF32 src dst+                _         -> panic "sparc_mkRegRegMoveInstr"++        | otherwise+        = panic "SPARC.Instr.mkRegRegMoveInstr: classes of src and dest not the same"+++-- | Check whether an instruction represents a reg-reg move.+--      The register allocator attempts to eliminate reg->reg moves whenever it can,+--      by assigning the src and dest temporaries to the same real register.+--+sparc_takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg)+sparc_takeRegRegMoveInstr instr+ = case instr of+        ADD False False src (RIReg src2) dst+         | g0 == src2           -> Just (src, dst)++        FMOV FF64 src dst       -> Just (src, dst)+        FMOV FF32  src dst      -> Just (src, dst)+        _                       -> Nothing+++-- | Make an unconditional branch instruction.+sparc_mkJumpInstr+        :: BlockId+        -> [Instr]++sparc_mkJumpInstr id+ =       [BI ALWAYS False id+        , NOP]                  -- fill the branch delay slot.
+ nativeGen/SPARC/Ppr.hs view
@@ -0,0 +1,647 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Pretty-printing assembly language+--+-- (c) The University of Glasgow 1993-2005+--+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -fno-warn-orphans #-}++module SPARC.Ppr (+        pprNatCmmDecl,+        pprBasicBlock,+        pprData,+        pprInstr,+        pprFormat,+        pprImm,+        pprDataItem+)++where++#include "HsVersions.h"+#include "nativeGen/NCG.h"++import SPARC.Regs+import SPARC.Instr+import SPARC.Cond+import SPARC.Imm+import SPARC.AddrMode+import SPARC.Base+import Instruction+import Reg+import Format+import PprBase++import Cmm hiding (topInfoTable)+import PprCmm()+import CLabel+import Hoopl++import Unique           ( Uniquable(..), pprUniqueAlways )+import Outputable+import Platform+import FastString+import Data.Word++-- -----------------------------------------------------------------------------+-- Printing this stuff out++pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc+pprNatCmmDecl (CmmData section dats) =+  pprSectionAlign section $$ pprDatas dats++pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =+  case topInfoTable proc of+    Nothing ->+       case blocks of+         []     -> -- special case for split markers:+           pprLabel lbl+         blocks -> -- special case for code without info table:+           pprSectionAlign (Section Text lbl) $$+           pprLabel lbl $$ -- blocks guaranteed not null, so label needed+           vcat (map (pprBasicBlock top_info) blocks)++    Just (Statics info_lbl _) ->+      sdocWithPlatform $ \platform ->+      (if platformHasSubsectionsViaSymbols platform+          then pprSectionAlign dspSection $$+               ppr (mkDeadStripPreventer info_lbl) <> char ':'+          else empty) $$+      vcat (map (pprBasicBlock top_info) blocks) $$+      -- above: Even the first block gets a label, because with branch-chain+      -- elimination, it might be the target of a goto.+      (if platformHasSubsectionsViaSymbols platform+       then+       -- See Note [Subsections Via Symbols] in X86/Ppr.hs+                text "\t.long "+            <+> ppr info_lbl+            <+> char '-'+            <+> ppr (mkDeadStripPreventer info_lbl)+       else empty)++dspSection :: Section+dspSection = Section Text $+    panic "subsections-via-symbols doesn't combine with split-sections"++pprBasicBlock :: LabelMap CmmStatics -> NatBasicBlock Instr -> SDoc+pprBasicBlock info_env (BasicBlock blockid instrs)+  = maybe_infotable $$+    pprLabel (mkAsmTempLabel (getUnique blockid)) $$+    vcat (map pprInstr instrs)+  where+    maybe_infotable = case mapLookup blockid info_env of+       Nothing   -> empty+       Just (Statics info_lbl info) ->+           pprAlignForSection Text $$+           vcat (map pprData info) $$+           pprLabel info_lbl+++pprDatas :: CmmStatics -> SDoc+pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats)++pprData :: CmmStatic -> SDoc+pprData (CmmString str)          = pprASCII str+pprData (CmmUninitialised bytes) = text ".skip " <> int bytes+pprData (CmmStaticLit lit)       = pprDataItem lit++pprGloblDecl :: CLabel -> SDoc+pprGloblDecl lbl+  | not (externallyVisibleCLabel lbl) = empty+  | otherwise = text ".global " <> ppr lbl++pprTypeAndSizeDecl :: CLabel -> SDoc+pprTypeAndSizeDecl lbl+    = sdocWithPlatform $ \platform ->+      if platformOS platform == OSLinux && externallyVisibleCLabel lbl+      then text ".type " <> ppr lbl <> ptext (sLit ", @object")+      else empty++pprLabel :: CLabel -> SDoc+pprLabel lbl = pprGloblDecl lbl+            $$ pprTypeAndSizeDecl lbl+            $$ (ppr lbl <> char ':')+++pprASCII :: [Word8] -> SDoc+pprASCII str+  = vcat (map do1 str) $$ do1 0+    where+       do1 :: Word8 -> SDoc+       do1 w = text "\t.byte\t" <> int (fromIntegral w)+++-- -----------------------------------------------------------------------------+-- pprInstr: print an 'Instr'++instance Outputable Instr where+    ppr instr = pprInstr instr+++-- | Pretty print a register.+pprReg :: Reg -> SDoc+pprReg reg+ = case reg of+        RegVirtual vr+         -> case vr of+                VirtualRegI   u -> text "%vI_"   <> pprUniqueAlways u+                VirtualRegHi  u -> text "%vHi_"  <> pprUniqueAlways u+                VirtualRegF   u -> text "%vF_"   <> pprUniqueAlways u+                VirtualRegD   u -> text "%vD_"   <> pprUniqueAlways u+                VirtualRegSSE u -> text "%vSSE_" <> pprUniqueAlways u++        RegReal rr+         -> case rr of+                RealRegSingle r1+                 -> pprReg_ofRegNo r1++                RealRegPair r1 r2+                 -> text "(" <> pprReg_ofRegNo r1+                 <> vbar     <> pprReg_ofRegNo r2+                 <> text ")"++++-- | Pretty print a register name, based on this register number.+--   The definition has been unfolded so we get a jump-table in the+--   object code. This function is called quite a lot when emitting+--   the asm file..+--+pprReg_ofRegNo :: Int -> SDoc+pprReg_ofRegNo i+ = ptext+    (case i of {+         0 -> sLit "%g0";   1 -> sLit "%g1";+         2 -> sLit "%g2";   3 -> sLit "%g3";+         4 -> sLit "%g4";   5 -> sLit "%g5";+         6 -> sLit "%g6";   7 -> sLit "%g7";+         8 -> sLit "%o0";   9 -> sLit "%o1";+        10 -> sLit "%o2";  11 -> sLit "%o3";+        12 -> sLit "%o4";  13 -> sLit "%o5";+        14 -> sLit "%o6";  15 -> sLit "%o7";+        16 -> sLit "%l0";  17 -> sLit "%l1";+        18 -> sLit "%l2";  19 -> sLit "%l3";+        20 -> sLit "%l4";  21 -> sLit "%l5";+        22 -> sLit "%l6";  23 -> sLit "%l7";+        24 -> sLit "%i0";  25 -> sLit "%i1";+        26 -> sLit "%i2";  27 -> sLit "%i3";+        28 -> sLit "%i4";  29 -> sLit "%i5";+        30 -> sLit "%i6";  31 -> sLit "%i7";+        32 -> sLit "%f0";  33 -> sLit "%f1";+        34 -> sLit "%f2";  35 -> sLit "%f3";+        36 -> sLit "%f4";  37 -> sLit "%f5";+        38 -> sLit "%f6";  39 -> sLit "%f7";+        40 -> sLit "%f8";  41 -> sLit "%f9";+        42 -> sLit "%f10"; 43 -> sLit "%f11";+        44 -> sLit "%f12"; 45 -> sLit "%f13";+        46 -> sLit "%f14"; 47 -> sLit "%f15";+        48 -> sLit "%f16"; 49 -> sLit "%f17";+        50 -> sLit "%f18"; 51 -> sLit "%f19";+        52 -> sLit "%f20"; 53 -> sLit "%f21";+        54 -> sLit "%f22"; 55 -> sLit "%f23";+        56 -> sLit "%f24"; 57 -> sLit "%f25";+        58 -> sLit "%f26"; 59 -> sLit "%f27";+        60 -> sLit "%f28"; 61 -> sLit "%f29";+        62 -> sLit "%f30"; 63 -> sLit "%f31";+        _  -> sLit "very naughty sparc register" })+++-- | Pretty print a format for an instruction suffix.+pprFormat :: Format -> SDoc+pprFormat x+ = ptext+    (case x of+        II8     -> sLit "ub"+        II16    -> sLit "uh"+        II32    -> sLit ""+        II64    -> sLit "d"+        FF32    -> sLit ""+        FF64    -> sLit "d"+        _       -> panic "SPARC.Ppr.pprFormat: no match")+++-- | Pretty print a format for an instruction suffix.+--      eg LD is 32bit on sparc, but LDD is 64 bit.+pprStFormat :: Format -> SDoc+pprStFormat x+ = ptext+    (case x of+        II8   -> sLit "b"+        II16  -> sLit "h"+        II32  -> sLit ""+        II64  -> sLit "x"+        FF32  -> sLit ""+        FF64  -> sLit "d"+        _       -> panic "SPARC.Ppr.pprFormat: no match")+++-- | Pretty print a condition code.+pprCond :: Cond -> SDoc+pprCond c+ = ptext+    (case c of+        ALWAYS  -> sLit ""+        NEVER   -> sLit "n"+        GEU     -> sLit "geu"+        LU      -> sLit "lu"+        EQQ     -> sLit "e"+        GTT     -> sLit "g"+        GE      -> sLit "ge"+        GU      -> sLit "gu"+        LTT     -> sLit "l"+        LE      -> sLit "le"+        LEU     -> sLit "leu"+        NE      -> sLit "ne"+        NEG     -> sLit "neg"+        POS     -> sLit "pos"+        VC      -> sLit "vc"+        VS      -> sLit "vs")+++-- | Pretty print an address mode.+pprAddr :: AddrMode -> SDoc+pprAddr am+ = case am of+        AddrRegReg r1 (RegReal (RealRegSingle 0))+         -> pprReg r1++        AddrRegReg r1 r2+         -> hcat [ pprReg r1, char '+', pprReg r2 ]++        AddrRegImm r1 (ImmInt i)+         | i == 0               -> pprReg r1+         | not (fits13Bits i)   -> largeOffsetError i+         | otherwise            -> hcat [ pprReg r1, pp_sign, int i ]+         where+                pp_sign = if i > 0 then char '+' else empty++        AddrRegImm r1 (ImmInteger i)+         | i == 0               -> pprReg r1+         | not (fits13Bits i)   -> largeOffsetError i+         | otherwise            -> hcat [ pprReg r1, pp_sign, integer i ]+         where+                pp_sign = if i > 0 then char '+' else empty++        AddrRegImm r1 imm+         -> hcat [ pprReg r1, char '+', pprImm imm ]+++-- | Pretty print an immediate value.+pprImm :: Imm -> SDoc+pprImm imm+ = case imm of+        ImmInt i        -> int i+        ImmInteger i    -> integer i+        ImmCLbl l       -> ppr l+        ImmIndex l i    -> ppr l <> char '+' <> int i+        ImmLit s        -> s++        ImmConstantSum a b+         -> pprImm a <> char '+' <> pprImm b++        ImmConstantDiff a b+         -> pprImm a <> char '-' <> lparen <> pprImm b <> rparen++        LO i+         -> hcat [ text "%lo(", pprImm i, rparen ]++        HI i+         -> hcat [ text "%hi(", pprImm i, rparen ]++        -- these should have been converted to bytes and placed+        --      in the data section.+        ImmFloat _      -> text "naughty float immediate"+        ImmDouble _     -> text "naughty double immediate"+++-- | Pretty print a section \/ segment header.+--      On SPARC all the data sections must be at least 8 byte aligned+--      incase we store doubles in them.+--+pprSectionAlign :: Section -> SDoc+pprSectionAlign sec@(Section seg _) =+  sdocWithPlatform $ \platform ->+    pprSectionHeader platform sec $$+    pprAlignForSection seg++-- | Print appropriate alignment for the given section type.+pprAlignForSection :: SectionType -> SDoc+pprAlignForSection seg =+    ptext (case seg of+      Text              -> sLit ".align 4"+      Data              -> sLit ".align 8"+      ReadOnlyData      -> sLit ".align 8"+      RelocatableReadOnlyData+                        -> sLit ".align 8"+      UninitialisedData -> sLit ".align 8"+      ReadOnlyData16    -> sLit ".align 16"+      -- TODO: This is copied from the ReadOnlyData case, but it can likely be+      -- made more efficient.+      CString           -> sLit ".align 8"+      OtherSection _    -> panic "PprMach.pprSectionHeader: unknown section")++-- | Pretty print a data item.+pprDataItem :: CmmLit -> SDoc+pprDataItem lit+  = sdocWithDynFlags $ \dflags ->+    vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit)+    where+        imm = litToImm lit++        ppr_item II8   _        = [text "\t.byte\t" <> pprImm imm]+        ppr_item II32  _        = [text "\t.long\t" <> pprImm imm]++        ppr_item FF32  (CmmFloat r _)+         = let bs = floatToBytes (fromRational r)+           in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs++        ppr_item FF64 (CmmFloat r _)+         = let bs = doubleToBytes (fromRational r)+           in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs++        ppr_item II16  _        = [text "\t.short\t" <> pprImm imm]+        ppr_item II64  _        = [text "\t.quad\t" <> pprImm imm]+        ppr_item _ _            = panic "SPARC.Ppr.pprDataItem: no match"+++-- | Pretty print an instruction.+pprInstr :: Instr -> SDoc++-- nuke comments.+pprInstr (COMMENT _)+        = empty++pprInstr (DELTA d)+        = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))++-- Newblocks and LData should have been slurped out before producing the .s file.+pprInstr (NEWBLOCK _)+        = panic "X86.Ppr.pprInstr: NEWBLOCK"++pprInstr (LDATA _ _)+        = panic "PprMach.pprInstr: LDATA"++-- 64 bit FP loads are expanded into individual instructions in CodeGen.Expand+pprInstr (LD FF64 _ reg)+        | RegReal (RealRegSingle{})     <- reg+        = panic "SPARC.Ppr: not emitting potentially misaligned LD FF64 instr"++pprInstr (LD format addr reg)+        = hcat [+               text "\tld",+               pprFormat format,+               char '\t',+               lbrack,+               pprAddr addr,+               pp_rbracket_comma,+               pprReg reg+            ]++-- 64 bit FP storees are expanded into individual instructions in CodeGen.Expand+pprInstr (ST FF64 reg _)+        | RegReal (RealRegSingle{}) <- reg+        = panic "SPARC.Ppr: not emitting potentially misaligned ST FF64 instr"++-- no distinction is made between signed and unsigned bytes on stores for the+-- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),+-- so we call a special-purpose pprFormat for ST..+pprInstr (ST format reg addr)+        = hcat [+               text "\tst",+               pprStFormat format,+               char '\t',+               pprReg reg,+               pp_comma_lbracket,+               pprAddr addr,+               rbrack+            ]+++pprInstr (ADD x cc reg1 ri reg2)+        | not x && not cc && riZero ri+        = hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ]++        | otherwise+        = pprRegRIReg (if x then sLit "addx" else sLit "add") cc reg1 ri reg2+++pprInstr (SUB x cc reg1 ri reg2)+        | not x && cc && reg2 == g0+        = hcat [ text "\tcmp\t", pprReg reg1, comma, pprRI ri ]++        | not x && not cc && riZero ri+        = hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ]++        | otherwise+        = pprRegRIReg (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2++pprInstr (AND  b reg1 ri reg2) = pprRegRIReg (sLit "and")  b reg1 ri reg2++pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg (sLit "andn") b reg1 ri reg2++pprInstr (OR b reg1 ri reg2)+        | not b && reg1 == g0+        = let doit = hcat [ text "\tmov\t", pprRI ri, comma, pprReg reg2 ]+          in  case ri of+                   RIReg rrr | rrr == reg2 -> empty+                   _                       -> doit++        | otherwise+        = pprRegRIReg (sLit "or") b reg1 ri reg2++pprInstr (ORN b reg1 ri reg2)  = pprRegRIReg (sLit "orn") b reg1 ri reg2++pprInstr (XOR  b reg1 ri reg2) = pprRegRIReg (sLit "xor")  b reg1 ri reg2+pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg (sLit "xnor") b reg1 ri reg2++pprInstr (SLL reg1 ri reg2)    = pprRegRIReg (sLit "sll") False reg1 ri reg2+pprInstr (SRL reg1 ri reg2)    = pprRegRIReg (sLit "srl") False reg1 ri reg2+pprInstr (SRA reg1 ri reg2)    = pprRegRIReg (sLit "sra") False reg1 ri reg2++pprInstr (RDY rd)              = text "\trd\t%y," <> pprReg rd+pprInstr (WRY reg1 reg2)+        = text "\twr\t"+                <> pprReg reg1+                <> char ','+                <> pprReg reg2+                <> char ','+                <> text "%y"++pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg (sLit "smul")  b reg1 ri reg2+pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg (sLit "umul")  b reg1 ri reg2+pprInstr (SDIV b reg1 ri reg2) = pprRegRIReg (sLit "sdiv")  b reg1 ri reg2+pprInstr (UDIV b reg1 ri reg2) = pprRegRIReg (sLit "udiv")  b reg1 ri reg2++pprInstr (SETHI imm reg)+  = hcat [+        text "\tsethi\t",+        pprImm imm,+        comma,+        pprReg reg+    ]++pprInstr NOP+        = text "\tnop"++pprInstr (FABS format reg1 reg2)+        = pprFormatRegReg (sLit "fabs") format reg1 reg2++pprInstr (FADD format reg1 reg2 reg3)+        = pprFormatRegRegReg (sLit "fadd") format reg1 reg2 reg3++pprInstr (FCMP e format reg1 reg2)+        = pprFormatRegReg (if e then sLit "fcmpe" else sLit "fcmp")+                          format reg1 reg2++pprInstr (FDIV format reg1 reg2 reg3)+        = pprFormatRegRegReg (sLit "fdiv") format reg1 reg2 reg3++pprInstr (FMOV format reg1 reg2)+        = pprFormatRegReg (sLit "fmov") format reg1 reg2++pprInstr (FMUL format reg1 reg2 reg3)+        = pprFormatRegRegReg (sLit "fmul") format reg1 reg2 reg3++pprInstr (FNEG format reg1 reg2)+        = pprFormatRegReg (sLit "fneg") format reg1 reg2++pprInstr (FSQRT format reg1 reg2)+        = pprFormatRegReg (sLit "fsqrt") format reg1 reg2++pprInstr (FSUB format reg1 reg2 reg3)+        = pprFormatRegRegReg (sLit "fsub") format reg1 reg2 reg3++pprInstr (FxTOy format1 format2 reg1 reg2)+  = hcat [+        text "\tf",+        ptext+        (case format1 of+            II32  -> sLit "ito"+            FF32  -> sLit "sto"+            FF64  -> sLit "dto"+            _     -> panic "SPARC.Ppr.pprInstr.FxToY: no match"),+        ptext+        (case format2 of+            II32  -> sLit "i\t"+            II64  -> sLit "x\t"+            FF32  -> sLit "s\t"+            FF64  -> sLit "d\t"+            _     -> panic "SPARC.Ppr.pprInstr.FxToY: no match"),+        pprReg reg1, comma, pprReg reg2+    ]+++pprInstr (BI cond b blockid)+  = hcat [+        text "\tb", pprCond cond,+        if b then pp_comma_a else empty,+        char '\t',+        ppr (mkAsmTempLabel (getUnique blockid))+    ]++pprInstr (BF cond b blockid)+  = hcat [+        text "\tfb", pprCond cond,+        if b then pp_comma_a else empty,+        char '\t',+        ppr (mkAsmTempLabel (getUnique blockid))+    ]++pprInstr (JMP addr) = text "\tjmp\t" <> pprAddr addr+pprInstr (JMP_TBL op _ _)  = pprInstr (JMP op)++pprInstr (CALL (Left imm) n _)+  = hcat [ text "\tcall\t", pprImm imm, comma, int n ]++pprInstr (CALL (Right reg) n _)+  = hcat [ text "\tcall\t", pprReg reg, comma, int n ]+++-- | Pretty print a RI+pprRI :: RI -> SDoc+pprRI (RIReg r) = pprReg r+pprRI (RIImm r) = pprImm r+++-- | Pretty print a two reg instruction.+pprFormatRegReg :: LitString -> Format -> Reg -> Reg -> SDoc+pprFormatRegReg name format reg1 reg2+  = hcat [+        char '\t',+        ptext name,+        (case format of+            FF32 -> text "s\t"+            FF64 -> text "d\t"+            _    -> panic "SPARC.Ppr.pprFormatRegReg: no match"),++        pprReg reg1,+        comma,+        pprReg reg2+    ]+++-- | Pretty print a three reg instruction.+pprFormatRegRegReg :: LitString -> Format -> Reg -> Reg -> Reg -> SDoc+pprFormatRegRegReg name format reg1 reg2 reg3+  = hcat [+        char '\t',+        ptext name,+        (case format of+            FF32  -> text "s\t"+            FF64  -> text "d\t"+            _    -> panic "SPARC.Ppr.pprFormatRegReg: no match"),+        pprReg reg1,+        comma,+        pprReg reg2,+        comma,+        pprReg reg3+    ]+++-- | Pretty print an instruction of two regs and a ri.+pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> SDoc+pprRegRIReg name b reg1 ri reg2+  = hcat [+        char '\t',+        ptext name,+        if b then text "cc\t" else char '\t',+        pprReg reg1,+        comma,+        pprRI ri,+        comma,+        pprReg reg2+    ]++{-+pprRIReg :: LitString -> Bool -> RI -> Reg -> SDoc+pprRIReg name b ri reg1+  = hcat [+        char '\t',+        ptext name,+        if b then text "cc\t" else char '\t',+        pprRI ri,+        comma,+        pprReg reg1+    ]+-}++{-+pp_ld_lbracket :: SDoc+pp_ld_lbracket    = text "\tld\t["+-}++pp_rbracket_comma :: SDoc+pp_rbracket_comma = text "],"+++pp_comma_lbracket :: SDoc+pp_comma_lbracket = text ",["+++pp_comma_a :: SDoc+pp_comma_a        = text ",a"+
+ nativeGen/SPARC/Regs.hs view
@@ -0,0 +1,259 @@+-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow 1994-2004+--+-- -----------------------------------------------------------------------------++module SPARC.Regs (+        -- registers+        showReg,+        virtualRegSqueeze,+        realRegSqueeze,+        classOfRealReg,+        allRealRegs,++        -- machine specific info+        gReg, iReg, lReg, oReg, fReg,+        fp, sp, g0, g1, g2, o0, o1, f0, f1, f6, f8, f22, f26, f27,++        -- allocatable+        allocatableRegs,++        -- args+        argRegs,+        allArgRegs,+        callClobberedRegs,++        --+        mkVirtualReg,+        regDotColor+)++where+++import CodeGen.Platform.SPARC+import Reg+import RegClass+import Format++import Unique+import Outputable++{-+        The SPARC has 64 registers of interest; 32 integer registers and 32+        floating point registers.  The mapping of STG registers to SPARC+        machine registers is defined in StgRegs.h.  We are, of course,+        prepared for any eventuality.++        The whole fp-register pairing thing on sparcs is a huge nuisance.  See+        includes/stg/MachRegs.h for a description of what's going on+        here.+-}+++-- | Get the standard name for the register with this number.+showReg :: RegNo -> String+showReg n+        | n >= 0  && n < 8   = "%g" ++ show n+        | n >= 8  && n < 16  = "%o" ++ show (n-8)+        | n >= 16 && n < 24  = "%l" ++ show (n-16)+        | n >= 24 && n < 32  = "%i" ++ show (n-24)+        | n >= 32 && n < 64  = "%f" ++ show (n-32)+        | otherwise          = panic "SPARC.Regs.showReg: unknown sparc register"+++-- Get the register class of a certain real reg+classOfRealReg :: RealReg -> RegClass+classOfRealReg reg+ = case reg of+        RealRegSingle i+                | i < 32        -> RcInteger+                | otherwise     -> RcFloat++        RealRegPair{}           -> RcDouble+++-- | regSqueeze_class reg+--      Calculuate the maximum number of register colors that could be+--      denied to a node of this class due to having this reg+--      as a neighbour.+--+{-# INLINE virtualRegSqueeze #-}+virtualRegSqueeze :: RegClass -> VirtualReg -> Int++virtualRegSqueeze cls vr+ = case cls of+        RcInteger+         -> case vr of+                VirtualRegI{}           -> 1+                VirtualRegHi{}          -> 1+                _other                  -> 0++        RcFloat+         -> case vr of+                VirtualRegF{}           -> 1+                VirtualRegD{}           -> 2+                _other                  -> 0++        RcDouble+         -> case vr of+                VirtualRegF{}           -> 1+                VirtualRegD{}           -> 1+                _other                  -> 0++        _other -> 0++{-# INLINE realRegSqueeze #-}+realRegSqueeze :: RegClass -> RealReg -> Int++realRegSqueeze cls rr+ = case cls of+        RcInteger+         -> case rr of+                RealRegSingle regNo+                        | regNo < 32    -> 1+                        | otherwise     -> 0++                RealRegPair{}           -> 0++        RcFloat+         -> case rr of+                RealRegSingle regNo+                        | regNo < 32    -> 0+                        | otherwise     -> 1++                RealRegPair{}           -> 2++        RcDouble+         -> case rr of+                RealRegSingle regNo+                        | regNo < 32    -> 0+                        | otherwise     -> 1++                RealRegPair{}           -> 1++        _other -> 0++-- | All the allocatable registers in the machine,+--      including register pairs.+allRealRegs :: [RealReg]+allRealRegs+        =  [ (RealRegSingle i)          | i <- [0..63] ]+        ++ [ (RealRegPair   i (i+1))    | i <- [32, 34 .. 62 ] ]+++-- | Get the regno for this sort of reg+gReg, lReg, iReg, oReg, fReg :: Int -> RegNo++gReg x  = x             -- global regs+oReg x  = (8 + x)       -- output regs+lReg x  = (16 + x)      -- local regs+iReg x  = (24 + x)      -- input regs+fReg x  = (32 + x)      -- float regs+++-- | Some specific regs used by the code generator.+g0, g1, g2, fp, sp, o0, o1, f0, f1, f6, f8, f22, f26, f27 :: Reg++f6  = RegReal (RealRegSingle (fReg 6))+f8  = RegReal (RealRegSingle (fReg 8))+f22 = RegReal (RealRegSingle (fReg 22))+f26 = RegReal (RealRegSingle (fReg 26))+f27 = RegReal (RealRegSingle (fReg 27))++-- g0 is always zero, and writes to it vanish.+g0  = RegReal (RealRegSingle (gReg 0))+g1  = RegReal (RealRegSingle (gReg 1))+g2  = RegReal (RealRegSingle (gReg 2))++-- FP, SP, int and float return (from C) regs.+fp  = RegReal (RealRegSingle (iReg 6))+sp  = RegReal (RealRegSingle (oReg 6))+o0  = RegReal (RealRegSingle (oReg 0))+o1  = RegReal (RealRegSingle (oReg 1))+f0  = RegReal (RealRegSingle (fReg 0))+f1  = RegReal (RealRegSingle (fReg 1))++-- | Produce the second-half-of-a-double register given the first half.+{-+fPair :: Reg -> Maybe Reg+fPair (RealReg n)+        | n >= 32 && n `mod` 2 == 0  = Just (RealReg (n+1))++fPair (VirtualRegD u)+        = Just (VirtualRegHi u)++fPair reg+        = trace ("MachInstrs.fPair: can't get high half of supposed double reg " ++ showPpr reg)+                Nothing+-}+++-- | All the regs that the register allocator can allocate to,+--      with the the fixed use regs removed.+--+allocatableRegs :: [RealReg]+allocatableRegs+   = let isFree rr+           = case rr of+                RealRegSingle r     -> freeReg r+                RealRegPair   r1 r2 -> freeReg r1 && freeReg r2+     in filter isFree allRealRegs+++-- | The registers to place arguments for function calls,+--      for some number of arguments.+--+argRegs :: RegNo -> [Reg]+argRegs r+ = case r of+        0       -> []+        1       -> map (RegReal . RealRegSingle . oReg) [0]+        2       -> map (RegReal . RealRegSingle . oReg) [0,1]+        3       -> map (RegReal . RealRegSingle . oReg) [0,1,2]+        4       -> map (RegReal . RealRegSingle . oReg) [0,1,2,3]+        5       -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4]+        6       -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4,5]+        _       -> panic "MachRegs.argRegs(sparc): don't know about >6 arguments!"+++-- | All all the regs that could possibly be returned by argRegs+--+allArgRegs :: [Reg]+allArgRegs+        = map (RegReal . RealRegSingle) [oReg i | i <- [0..5]]+++-- These are the regs that we cannot assume stay alive over a C call.+--      TODO: Why can we assume that o6 isn't clobbered? -- BL 2009/02+--+callClobberedRegs :: [Reg]+callClobberedRegs+        = map (RegReal . RealRegSingle)+                (  oReg 7 :+                  [oReg i | i <- [0..5]] +++                  [gReg i | i <- [1..7]] +++                  [fReg i | i <- [0..31]] )++++-- | Make a virtual reg with this format.+mkVirtualReg :: Unique -> Format -> VirtualReg+mkVirtualReg u format+        | not (isFloatFormat format)+        = VirtualRegI u++        | otherwise+        = case format of+                FF32    -> VirtualRegF u+                FF64    -> VirtualRegD u+                _       -> panic "mkVReg"+++regDotColor :: RealReg -> SDoc+regDotColor reg+ = case classOfRealReg reg of+        RcInteger       -> text "blue"+        RcFloat         -> text "red"+        _other          -> text "green"
+ nativeGen/SPARC/ShortcutJump.hs view
@@ -0,0 +1,69 @@+module SPARC.ShortcutJump (+        JumpDest(..), getJumpDestBlockId,+        canShortcut,+        shortcutJump,+        shortcutStatics,+        shortBlockId+)++where++import SPARC.Instr+import SPARC.Imm++import CLabel+import BlockId+import Cmm++import Panic+import Unique++++data JumpDest+        = DestBlockId BlockId+        | DestImm Imm++getJumpDestBlockId :: JumpDest -> Maybe BlockId+getJumpDestBlockId (DestBlockId bid) = Just bid+getJumpDestBlockId _                 = Nothing+++canShortcut :: Instr -> Maybe JumpDest+canShortcut _ = Nothing+++shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr+shortcutJump _ other = other++++shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics+shortcutStatics fn (Statics lbl statics)+  = Statics lbl $ map (shortcutStatic fn) statics+  -- we need to get the jump tables, so apply the mapping to the entries+  -- of a CmmData too.++shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel+shortcutLabel fn lab+  | Just uq <- maybeAsmTemp lab = shortBlockId fn (mkBlockId uq)+  | otherwise                   = lab++shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic+shortcutStatic fn (CmmStaticLit (CmmLabel lab))+        = CmmStaticLit (CmmLabel (shortcutLabel fn lab))+shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off))+        = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off)+-- slightly dodgy, we're ignoring the second label, but this+-- works with the way we use CmmLabelDiffOff for jump tables now.+shortcutStatic _ other_static+        = other_static+++shortBlockId :: (BlockId -> Maybe JumpDest) -> BlockId -> CLabel+shortBlockId fn blockid =+   case fn blockid of+      Nothing -> mkAsmTempLabel (getUnique blockid)+      Just (DestBlockId blockid')  -> shortBlockId fn blockid'+      Just (DestImm (ImmCLbl lbl)) -> lbl+      _other -> panic "shortBlockId"
+ nativeGen/SPARC/Stack.hs view
@@ -0,0 +1,57 @@+module SPARC.Stack (+        spRel,+        fpRel,+        spillSlotToOffset,+        maxSpillSlots+)++where++import SPARC.AddrMode+import SPARC.Regs+import SPARC.Base+import SPARC.Imm++import DynFlags+import Outputable++-- | Get an AddrMode relative to the address in sp.+--      This gives us a stack relative addressing mode for volatile+--      temporaries and for excess call arguments.+--+spRel :: Int            -- ^ stack offset in words, positive or negative+      -> AddrMode++spRel n = AddrRegImm sp (ImmInt (n * wordLength))+++-- | Get an address relative to the frame pointer.+--      This doesn't work work for offsets greater than 13 bits; we just hope for the best+--+fpRel :: Int -> AddrMode+fpRel n+        = AddrRegImm fp (ImmInt (n * wordLength))+++-- | Convert a spill slot number to a *byte* offset, with no sign.+--+spillSlotToOffset :: DynFlags -> Int -> Int+spillSlotToOffset dflags slot+        | slot >= 0 && slot < maxSpillSlots dflags+        = 64 + spillSlotSize * slot++        | otherwise+        = pprPanic "spillSlotToOffset:"+                      (   text "invalid spill location: " <> int slot+                      $$  text "maxSpillSlots:          " <> int (maxSpillSlots dflags))+++-- | The maximum number of spill slots available on the C stack.+--      If we use up all of the slots, then we're screwed.+--+--      Why do we reserve 64 bytes, instead of using the whole thing??+--              -- BL 2009/02/15+--+maxSpillSlots :: DynFlags -> Int+maxSpillSlots dflags+        = ((spillAreaLength dflags - 64) `div` spillSlotSize) - 1
+ nativeGen/TargetReg.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE CPP #-}+-- | Hard wired things related to registers.+--      This is module is preventing the native code generator being able to+--      emit code for non-host architectures.+--+--      TODO: Do a better job of the overloading, and eliminate this module.+--      We'd probably do better with a Register type class, and hook this to+--      Instruction somehow.+--+--      TODO: We should also make arch specific versions of RegAlloc.Graph.TrivColorable+module TargetReg (+        targetVirtualRegSqueeze,+        targetRealRegSqueeze,+        targetClassOfRealReg,+        targetMkVirtualReg,+        targetRegDotColor,+        targetClassOfReg+)++where++#include "HsVersions.h"++import Reg+import RegClass+import Format++import Outputable+import Unique+import Platform++import qualified X86.Regs       as X86+import qualified X86.RegInfo    as X86++import qualified PPC.Regs       as PPC++import qualified SPARC.Regs     as SPARC++targetVirtualRegSqueeze :: Platform -> RegClass -> VirtualReg -> Int+targetVirtualRegSqueeze platform+    = case platformArch platform of+      ArchX86       -> X86.virtualRegSqueeze+      ArchX86_64    -> X86.virtualRegSqueeze+      ArchPPC       -> PPC.virtualRegSqueeze+      ArchSPARC     -> SPARC.virtualRegSqueeze+      ArchSPARC64   -> panic "targetVirtualRegSqueeze ArchSPARC64"+      ArchPPC_64 _  -> PPC.virtualRegSqueeze+      ArchARM _ _ _ -> panic "targetVirtualRegSqueeze ArchARM"+      ArchARM64     -> panic "targetVirtualRegSqueeze ArchARM64"+      ArchAlpha     -> panic "targetVirtualRegSqueeze ArchAlpha"+      ArchMipseb    -> panic "targetVirtualRegSqueeze ArchMipseb"+      ArchMipsel    -> panic "targetVirtualRegSqueeze ArchMipsel"+      ArchJavaScript-> panic "targetVirtualRegSqueeze ArchJavaScript"+      ArchUnknown   -> panic "targetVirtualRegSqueeze ArchUnknown"+++targetRealRegSqueeze :: Platform -> RegClass -> RealReg -> Int+targetRealRegSqueeze platform+    = case platformArch platform of+      ArchX86       -> X86.realRegSqueeze+      ArchX86_64    -> X86.realRegSqueeze+      ArchPPC       -> PPC.realRegSqueeze+      ArchSPARC     -> SPARC.realRegSqueeze+      ArchSPARC64   -> panic "targetRealRegSqueeze ArchSPARC64"+      ArchPPC_64 _  -> PPC.realRegSqueeze+      ArchARM _ _ _ -> panic "targetRealRegSqueeze ArchARM"+      ArchARM64     -> panic "targetRealRegSqueeze ArchARM64"+      ArchAlpha     -> panic "targetRealRegSqueeze ArchAlpha"+      ArchMipseb    -> panic "targetRealRegSqueeze ArchMipseb"+      ArchMipsel    -> panic "targetRealRegSqueeze ArchMipsel"+      ArchJavaScript-> panic "targetRealRegSqueeze ArchJavaScript"+      ArchUnknown   -> panic "targetRealRegSqueeze ArchUnknown"++targetClassOfRealReg :: Platform -> RealReg -> RegClass+targetClassOfRealReg platform+    = case platformArch platform of+      ArchX86       -> X86.classOfRealReg platform+      ArchX86_64    -> X86.classOfRealReg platform+      ArchPPC       -> PPC.classOfRealReg+      ArchSPARC     -> SPARC.classOfRealReg+      ArchSPARC64   -> panic "targetClassOfRealReg ArchSPARC64"+      ArchPPC_64 _  -> PPC.classOfRealReg+      ArchARM _ _ _ -> panic "targetClassOfRealReg ArchARM"+      ArchARM64     -> panic "targetClassOfRealReg ArchARM64"+      ArchAlpha     -> panic "targetClassOfRealReg ArchAlpha"+      ArchMipseb    -> panic "targetClassOfRealReg ArchMipseb"+      ArchMipsel    -> panic "targetClassOfRealReg ArchMipsel"+      ArchJavaScript-> panic "targetClassOfRealReg ArchJavaScript"+      ArchUnknown   -> panic "targetClassOfRealReg ArchUnknown"++targetMkVirtualReg :: Platform -> Unique -> Format -> VirtualReg+targetMkVirtualReg platform+    = case platformArch platform of+      ArchX86       -> X86.mkVirtualReg+      ArchX86_64    -> X86.mkVirtualReg+      ArchPPC       -> PPC.mkVirtualReg+      ArchSPARC     -> SPARC.mkVirtualReg+      ArchSPARC64   -> panic "targetMkVirtualReg ArchSPARC64"+      ArchPPC_64 _  -> PPC.mkVirtualReg+      ArchARM _ _ _ -> panic "targetMkVirtualReg ArchARM"+      ArchARM64     -> panic "targetMkVirtualReg ArchARM64"+      ArchAlpha     -> panic "targetMkVirtualReg ArchAlpha"+      ArchMipseb    -> panic "targetMkVirtualReg ArchMipseb"+      ArchMipsel    -> panic "targetMkVirtualReg ArchMipsel"+      ArchJavaScript-> panic "targetMkVirtualReg ArchJavaScript"+      ArchUnknown   -> panic "targetMkVirtualReg ArchUnknown"++targetRegDotColor :: Platform -> RealReg -> SDoc+targetRegDotColor platform+    = case platformArch platform of+      ArchX86       -> X86.regDotColor platform+      ArchX86_64    -> X86.regDotColor platform+      ArchPPC       -> PPC.regDotColor+      ArchSPARC     -> SPARC.regDotColor+      ArchSPARC64   -> panic "targetRegDotColor ArchSPARC64"+      ArchPPC_64 _  -> PPC.regDotColor+      ArchARM _ _ _ -> panic "targetRegDotColor ArchARM"+      ArchARM64     -> panic "targetRegDotColor ArchARM64"+      ArchAlpha     -> panic "targetRegDotColor ArchAlpha"+      ArchMipseb    -> panic "targetRegDotColor ArchMipseb"+      ArchMipsel    -> panic "targetRegDotColor ArchMipsel"+      ArchJavaScript-> panic "targetRegDotColor ArchJavaScript"+      ArchUnknown   -> panic "targetRegDotColor ArchUnknown"+++targetClassOfReg :: Platform -> Reg -> RegClass+targetClassOfReg platform reg+ = case reg of+   RegVirtual vr -> classOfVirtualReg vr+   RegReal rr -> targetClassOfRealReg platform rr
+ nativeGen/X86/CodeGen.hs view
@@ -0,0 +1,3121 @@+{-# LANGUAGE CPP, GADTs, NondecreasingIndentation #-}++-- The default iteration limit is a bit too low for the definitions+-- in this module.+#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}+#endif++-----------------------------------------------------------------------------+--+-- Generating machine code (instruction selection)+--+-- (c) The University of Glasgow 1996-2004+--+-----------------------------------------------------------------------------++-- This is a big module, but, if you pay attention to+-- (a) the sectioning, and (b) the type signatures, the+-- structure should not be too overwhelming.++module X86.CodeGen (+        cmmTopCodeGen,+        generateJumpTableForInstr,+        extractUnwindPoints,+        InstrBlock+)++where++#include "HsVersions.h"+#include "nativeGen/NCG.h"+#include "MachDeps.h"++-- NCG stuff:+import X86.Instr+import X86.Cond+import X86.Regs+import X86.RegInfo+import CodeGen.Platform+import CPrim+import Debug            ( DebugBlock(..), UnwindPoint(..), UnwindTable+                        , UnwindExpr(UwReg), toUnwindExpr )+import Instruction+import PIC+import NCGMonad+import Format+import Reg+import Platform++-- Our intermediate code:+import BasicTypes+import BlockId+import Module           ( primUnitId )+import PprCmm           ()+import CmmUtils+import CmmSwitch+import Cmm+import Hoopl+import CLabel+import CoreSyn          ( Tickish(..) )+import SrcLoc           ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )++-- The rest:+import ForeignCall      ( CCallConv(..) )+import OrdList+import Outputable+import Unique+import FastString+import DynFlags+import Util+import UniqSupply       ( getUniqueM )++import Control.Monad+import Data.Bits+import Data.Foldable (fold)+import Data.Int+import Data.Maybe+import Data.Word++import qualified Data.Map as M++is32BitPlatform :: NatM Bool+is32BitPlatform = do+    dflags <- getDynFlags+    return $ target32Bit (targetPlatform dflags)++sse2Enabled :: NatM Bool+sse2Enabled = do+  dflags <- getDynFlags+  return (isSse2Enabled dflags)++sse4_2Enabled :: NatM Bool+sse4_2Enabled = do+  dflags <- getDynFlags+  return (isSse4_2Enabled dflags)++if_sse2 :: NatM a -> NatM a -> NatM a+if_sse2 sse2 x87 = do+  b <- sse2Enabled+  if b then sse2 else x87++cmmTopCodeGen+        :: RawCmmDecl+        -> NatM [NatCmmDecl (Alignment, CmmStatics) Instr]++cmmTopCodeGen (CmmProc info lab live graph) = do+  let blocks = toBlockListEntryFirst graph+  (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks+  picBaseMb <- getPicBaseMaybeNat+  dflags <- getDynFlags+  let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)+      tops = proc : concat statics+      os   = platformOS $ targetPlatform dflags++  case picBaseMb of+      Just picBase -> initializePicBase_x86 ArchX86 os picBase tops+      Nothing -> return tops++cmmTopCodeGen (CmmData sec dat) = do+  return [CmmData sec (1, dat)]  -- no translation, we just use CmmStatic+++basicBlockCodeGen+        :: CmmBlock+        -> NatM ( [NatBasicBlock Instr]+                , [NatCmmDecl (Alignment, CmmStatics) Instr])++basicBlockCodeGen block = do+  let (_, nodes, tail)  = blockSplit block+      id = entryLabel block+      stmts = blockToList nodes+  -- Generate location directive+  dbg <- getDebugBlock (entryLabel block)+  loc_instrs <- case dblSourceTick =<< dbg of+    Just (SourceNote span name)+      -> do fileId <- getFileId (srcSpanFile span)+            let line = srcSpanStartLine span; col = srcSpanStartCol span+            return $ unitOL $ LOCATION fileId line col name+    _ -> return nilOL+  mid_instrs <- stmtsToInstrs stmts+  tail_instrs <- stmtToInstrs tail+  let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs+  instrs' <- fold <$> traverse addSpUnwindings instrs+  -- code generation may introduce new basic block boundaries, which+  -- are indicated by the NEWBLOCK instruction.  We must split up the+  -- instruction stream into basic blocks again.  Also, we extract+  -- LDATAs here too.+  let+        (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs'++        mkBlocks (NEWBLOCK id) (instrs,blocks,statics)+          = ([], BasicBlock id instrs : blocks, statics)+        mkBlocks (LDATA sec dat) (instrs,blocks,statics)+          = (instrs, blocks, CmmData sec dat:statics)+        mkBlocks instr (instrs,blocks,statics)+          = (instr:instrs, blocks, statics)+  return (BasicBlock id top : other_blocks, statics)++-- | Convert 'DELTA' instructions into 'UNWIND' instructions to capture changes+-- in the @sp@ register. See Note [What is this unwinding business?] in Debug+-- for details.+addSpUnwindings :: Instr -> NatM (OrdList Instr)+addSpUnwindings instr@(DELTA d) = do+    dflags <- getDynFlags+    if debugLevel dflags >= 1+        then do lbl <- mkAsmTempLabel <$> getUniqueM+                let unwind = M.singleton MachSp (Just $ UwReg MachSp $ negate d)+                return $ toOL [ instr, UNWIND lbl unwind ]+        else return (unitOL instr)+addSpUnwindings instr = return $ unitOL instr++stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock+stmtsToInstrs stmts+   = do instrss <- mapM stmtToInstrs stmts+        return (concatOL instrss)+++stmtToInstrs :: CmmNode e x -> NatM InstrBlock+stmtToInstrs stmt = do+  dflags <- getDynFlags+  is32Bit <- is32BitPlatform+  case stmt of+    CmmComment s   -> return (unitOL (COMMENT s))+    CmmTick {}     -> return nilOL++    CmmUnwind regs -> do+      let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable+          to_unwind_entry (reg, expr) = M.singleton reg (fmap toUnwindExpr expr)+      case foldMap to_unwind_entry regs of+        tbl | M.null tbl -> return nilOL+            | otherwise  -> do+                lbl <- mkAsmTempLabel <$> getUniqueM+                return $ unitOL $ UNWIND lbl tbl++    CmmAssign reg src+      | isFloatType ty         -> assignReg_FltCode format reg src+      | is32Bit && isWord64 ty -> assignReg_I64Code      reg src+      | otherwise              -> assignReg_IntCode format reg src+        where ty = cmmRegType dflags reg+              format = cmmTypeFormat ty++    CmmStore addr src+      | isFloatType ty         -> assignMem_FltCode format addr src+      | is32Bit && isWord64 ty -> assignMem_I64Code      addr src+      | otherwise              -> assignMem_IntCode format addr src+        where ty = cmmExprType dflags src+              format = cmmTypeFormat ty++    CmmUnsafeForeignCall target result_regs args+       -> genCCall dflags is32Bit target result_regs args++    CmmBranch id          -> genBranch id+    CmmCondBranch arg true false _ -> do+      b1 <- genCondJump true arg+      b2 <- genBranch false+      return (b1 `appOL` b2)+    CmmSwitch arg ids -> do dflags <- getDynFlags+                            genSwitch dflags arg ids+    CmmCall { cml_target = arg+            , cml_args_regs = gregs } -> do+                                dflags <- getDynFlags+                                genJump arg (jumpRegs dflags gregs)+    _ ->+      panic "stmtToInstrs: statement should have been cps'd away"+++jumpRegs :: DynFlags -> [GlobalReg] -> [Reg]+jumpRegs dflags gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ]+    where platform = targetPlatform dflags++--------------------------------------------------------------------------------+-- | 'InstrBlock's are the insn sequences generated by the insn selectors.+--      They are really trees of insns to facilitate fast appending, where a+--      left-to-right traversal yields the insns in the correct order.+--+type InstrBlock+        = OrdList Instr+++-- | Condition codes passed up the tree.+--+data CondCode+        = CondCode Bool Cond InstrBlock+++-- | a.k.a "Register64"+--      Reg is the lower 32-bit temporary which contains the result.+--      Use getHiVRegFromLo to find the other VRegUnique.+--+--      Rules of this simplified insn selection game are therefore that+--      the returned Reg may be modified+--+data ChildCode64+   = ChildCode64+        InstrBlock+        Reg+++-- | Register's passed up the tree.  If the stix code forces the register+--      to live in a pre-decided machine register, it comes out as @Fixed@;+--      otherwise, it comes out as @Any@, and the parent can decide which+--      register to put it in.+--+data Register+        = Fixed Format Reg InstrBlock+        | Any   Format (Reg -> InstrBlock)+++swizzleRegisterRep :: Register -> Format -> Register+swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code+swizzleRegisterRep (Any _ codefn)     format = Any   format codefn+++-- | Grab the Reg for a CmmReg+getRegisterReg :: Platform -> Bool -> CmmReg -> Reg++getRegisterReg _ use_sse2 (CmmLocal (LocalReg u pk))+  = let fmt = cmmTypeFormat pk in+    if isFloatFormat fmt && not use_sse2+       then RegVirtual (mkVirtualReg u FF80)+       else RegVirtual (mkVirtualReg u fmt)++getRegisterReg platform _ (CmmGlobal mid)+  = case globalRegMaybe platform mid of+        Just reg -> RegReal $ reg+        Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)+        -- By this stage, the only MagicIds remaining should be the+        -- ones which map to a real machine register on this+        -- platform.  Hence ...+++-- | Memory addressing modes passed up the tree.+data Amode+        = Amode AddrMode InstrBlock++{-+Now, given a tree (the argument to an CmmLoad) that references memory,+produce a suitable addressing mode.++A Rule of the Game (tm) for Amodes: use of the addr bit must+immediately follow use of the code part, since the code part puts+values in registers which the addr then refers to.  So you can't put+anything in between, lest it overwrite some of those registers.  If+you need to do some other computation between the code part and use of+the addr bit, first store the effective address from the amode in a+temporary, then do the other computation, and then use the temporary:++    code+    LEA amode, tmp+    ... other computation ...+    ... (tmp) ...+-}+++-- | Check whether an integer will fit in 32 bits.+--      A CmmInt is intended to be truncated to the appropriate+--      number of bits, so here we truncate it to Int64.  This is+--      important because e.g. -1 as a CmmInt might be either+--      -1 or 18446744073709551615.+--+is32BitInteger :: Integer -> Bool+is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000+  where i64 = fromIntegral i :: Int64+++-- | Convert a BlockId to some CmmStatic data+jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic+jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags))+jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)+    where blockLabel = mkAsmTempLabel (getUnique blockid)+++-- -----------------------------------------------------------------------------+-- General things for putting together code sequences++-- Expand CmmRegOff.  ToDo: should we do it this way around, or convert+-- CmmExprs into CmmRegOff?+mangleIndexTree :: DynFlags -> CmmReg -> Int -> CmmExpr+mangleIndexTree dflags reg off+  = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]+  where width = typeWidth (cmmRegType dflags reg)++-- | The dual to getAnyReg: compute an expression into a register, but+--      we don't mind which one it is.+getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)+getSomeReg expr = do+  r <- getRegister expr+  case r of+    Any rep code -> do+        tmp <- getNewRegNat rep+        return (tmp, code tmp)+    Fixed _ reg code ->+        return (reg, code)+++assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock+assignMem_I64Code addrTree valueTree = do+  Amode addr addr_code <- getAmode addrTree+  ChildCode64 vcode rlo <- iselExpr64 valueTree+  let+        rhi = getHiVRegFromLo rlo++        -- Little-endian store+        mov_lo = MOV II32 (OpReg rlo) (OpAddr addr)+        mov_hi = MOV II32 (OpReg rhi) (OpAddr (fromJust (addrOffset addr 4)))+  return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)+++assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock+assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do+   ChildCode64 vcode r_src_lo <- iselExpr64 valueTree+   let+         r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32+         r_dst_hi = getHiVRegFromLo r_dst_lo+         r_src_hi = getHiVRegFromLo r_src_lo+         mov_lo = MOV II32 (OpReg r_src_lo) (OpReg r_dst_lo)+         mov_hi = MOV II32 (OpReg r_src_hi) (OpReg r_dst_hi)+   return (+        vcode `snocOL` mov_lo `snocOL` mov_hi+     )++assignReg_I64Code _ _+   = panic "assignReg_I64Code(i386): invalid lvalue"+++iselExpr64        :: CmmExpr -> NatM ChildCode64+iselExpr64 (CmmLit (CmmInt i _)) = do+  (rlo,rhi) <- getNewRegPairNat II32+  let+        r = fromIntegral (fromIntegral i :: Word32)+        q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)+        code = toOL [+                MOV II32 (OpImm (ImmInteger r)) (OpReg rlo),+                MOV II32 (OpImm (ImmInteger q)) (OpReg rhi)+                ]+  return (ChildCode64 code rlo)++iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do+   Amode addr addr_code <- getAmode addrTree+   (rlo,rhi) <- getNewRegPairNat II32+   let+        mov_lo = MOV II32 (OpAddr addr) (OpReg rlo)+        mov_hi = MOV II32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi)+   return (+            ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)+                        rlo+     )++iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty+   = return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32))++-- we handle addition, but rather badly+iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do+   ChildCode64 code1 r1lo <- iselExpr64 e1+   (rlo,rhi) <- getNewRegPairNat II32+   let+        r = fromIntegral (fromIntegral i :: Word32)+        q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)+        r1hi = getHiVRegFromLo r1lo+        code =  code1 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       ADD II32 (OpImm (ImmInteger r)) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ]+   return (ChildCode64 code rlo)++iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do+   ChildCode64 code1 r1lo <- iselExpr64 e1+   ChildCode64 code2 r2lo <- iselExpr64 e2+   (rlo,rhi) <- getNewRegPairNat II32+   let+        r1hi = getHiVRegFromLo r1lo+        r2hi = getHiVRegFromLo r2lo+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       ADD II32 (OpReg r2lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       ADC II32 (OpReg r2hi) (OpReg rhi) ]+   return (ChildCode64 code rlo)++iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do+   ChildCode64 code1 r1lo <- iselExpr64 e1+   ChildCode64 code2 r2lo <- iselExpr64 e2+   (rlo,rhi) <- getNewRegPairNat II32+   let+        r1hi = getHiVRegFromLo r1lo+        r2hi = getHiVRegFromLo r2lo+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       SUB II32 (OpReg r2lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       SBB II32 (OpReg r2hi) (OpReg rhi) ]+   return (ChildCode64 code rlo)++iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do+     fn <- getAnyReg expr+     r_dst_lo <-  getNewRegNat II32+     let r_dst_hi = getHiVRegFromLo r_dst_lo+         code = fn r_dst_lo+     return (+             ChildCode64 (code `snocOL`+                          MOV II32 (OpImm (ImmInt 0)) (OpReg r_dst_hi))+                          r_dst_lo+            )++iselExpr64 expr+   = pprPanic "iselExpr64(i386)" (ppr expr)+++--------------------------------------------------------------------------------+getRegister :: CmmExpr -> NatM Register+getRegister e = do dflags <- getDynFlags+                   is32Bit <- is32BitPlatform+                   getRegister' dflags is32Bit e++getRegister' :: DynFlags -> Bool -> CmmExpr -> NatM Register++getRegister' dflags is32Bit (CmmReg reg)+  = case reg of+        CmmGlobal PicBaseReg+         | is32Bit ->+            -- on x86_64, we have %rip for PicBaseReg, but it's not+            -- a full-featured register, it can only be used for+            -- rip-relative addressing.+            do reg' <- getPicBaseNat (archWordFormat is32Bit)+               return (Fixed (archWordFormat is32Bit) reg' nilOL)+        _ ->+            do use_sse2 <- sse2Enabled+               let+                 fmt = cmmTypeFormat (cmmRegType dflags reg)+                 format | not use_sse2 && isFloatFormat fmt = FF80+                        | otherwise                         = fmt+               --+               let platform = targetPlatform dflags+               return (Fixed format+                             (getRegisterReg platform use_sse2 reg)+                             nilOL)+++getRegister' dflags is32Bit (CmmRegOff r n)+  = getRegister' dflags is32Bit $ mangleIndexTree dflags r n++-- for 32-bit architectuers, support some 64 -> 32 bit conversions:+-- TO_W_(x), TO_W_(x >> 32)++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32)+                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])+ | is32Bit = do+  ChildCode64 code rlo <- iselExpr64 x+  return $ Fixed II32 (getHiVRegFromLo rlo) code++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32)+                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])+ | is32Bit = do+  ChildCode64 code rlo <- iselExpr64 x+  return $ Fixed II32 (getHiVRegFromLo rlo) code++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x])+ | is32Bit = do+  ChildCode64 code rlo <- iselExpr64 x+  return $ Fixed II32 rlo code++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x])+ | is32Bit = do+  ChildCode64 code rlo <- iselExpr64 x+  return $ Fixed II32 rlo code++getRegister' _ _ (CmmLit lit@(CmmFloat f w)) =+  if_sse2 float_const_sse2 float_const_x87+ where+  float_const_sse2+    | f == 0.0 = do+      let+          format = floatFormat w+          code dst = unitOL  (XOR format (OpReg dst) (OpReg dst))+        -- I don't know why there are xorpd, xorps, and pxor instructions.+        -- They all appear to do the same thing --SDM+      return (Any format code)++   | otherwise = do+      Amode addr code <- memConstant (widthInBytes w) lit+      loadFloatAmode True w addr code++  float_const_x87 = case w of+    W64+      | f == 0.0 ->+        let code dst = unitOL (GLDZ dst)+        in  return (Any FF80 code)++      | f == 1.0 ->+        let code dst = unitOL (GLD1 dst)+        in  return (Any FF80 code)++    _otherwise -> do+      Amode addr code <- memConstant (widthInBytes w) lit+      loadFloatAmode False w addr code++-- catch simple cases of zero- or sign-extended load+getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _]) = do+  code <- intLoadCode (MOVZxL II8) addr+  return (Any II32 code)++getRegister' _ _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _]) = do+  code <- intLoadCode (MOVSxL II8) addr+  return (Any II32 code)++getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _]) = do+  code <- intLoadCode (MOVZxL II16) addr+  return (Any II32 code)++getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _]) = do+  code <- intLoadCode (MOVSxL II16) addr+  return (Any II32 code)++-- catch simple cases of zero- or sign-extended load+getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _])+ | not is32Bit = do+  code <- intLoadCode (MOVZxL II8) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _])+ | not is32Bit = do+  code <- intLoadCode (MOVSxL II8) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _])+ | not is32Bit = do+  code <- intLoadCode (MOVZxL II16) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _])+ | not is32Bit = do+  code <- intLoadCode (MOVSxL II16) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _])+ | not is32Bit = do+  code <- intLoadCode (MOV II32) addr -- 32-bit loads zero-extend+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _])+ | not is32Bit = do+  code <- intLoadCode (MOVSxL II32) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),+                                     CmmLit displacement])+ | not is32Bit = do+      return $ Any II64 (\dst -> unitOL $+        LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst))++getRegister' dflags is32Bit (CmmMachOp mop [x]) = do -- unary MachOps+    sse2 <- sse2Enabled+    case mop of+      MO_F_Neg w+         | sse2      -> sse2NegCode w x+         | otherwise -> trivialUFCode FF80 (GNEG FF80) x++      MO_S_Neg w -> triv_ucode NEGI (intFormat w)+      MO_Not w   -> triv_ucode NOT  (intFormat w)++      -- Nop conversions+      MO_UU_Conv W32 W8  -> toI8Reg  W32 x+      MO_SS_Conv W32 W8  -> toI8Reg  W32 x+      MO_UU_Conv W16 W8  -> toI8Reg  W16 x+      MO_SS_Conv W16 W8  -> toI8Reg  W16 x+      MO_UU_Conv W32 W16 -> toI16Reg W32 x+      MO_SS_Conv W32 W16 -> toI16Reg W32 x++      MO_UU_Conv W64 W32 | not is32Bit -> conversionNop II64 x+      MO_SS_Conv W64 W32 | not is32Bit -> conversionNop II64 x+      MO_UU_Conv W64 W16 | not is32Bit -> toI16Reg W64 x+      MO_SS_Conv W64 W16 | not is32Bit -> toI16Reg W64 x+      MO_UU_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x+      MO_SS_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x++      MO_UU_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x+      MO_SS_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x++      -- widenings+      MO_UU_Conv W8  W32 -> integerExtend W8  W32 MOVZxL x+      MO_UU_Conv W16 W32 -> integerExtend W16 W32 MOVZxL x+      MO_UU_Conv W8  W16 -> integerExtend W8  W16 MOVZxL x++      MO_SS_Conv W8  W32 -> integerExtend W8  W32 MOVSxL x+      MO_SS_Conv W16 W32 -> integerExtend W16 W32 MOVSxL x+      MO_SS_Conv W8  W16 -> integerExtend W8  W16 MOVSxL x++      MO_UU_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOVZxL x+      MO_UU_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVZxL x+      MO_UU_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVZxL x+      MO_SS_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOVSxL x+      MO_SS_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVSxL x+      MO_SS_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVSxL x+        -- for 32-to-64 bit zero extension, amd64 uses an ordinary movl.+        -- However, we don't want the register allocator to throw it+        -- away as an unnecessary reg-to-reg move, so we keep it in+        -- the form of a movzl and print it as a movl later.++      MO_FF_Conv W32 W64+        | sse2      -> coerceFP2FP W64 x+        | otherwise -> conversionNop FF80 x++      MO_FF_Conv W64 W32 -> coerceFP2FP W32 x++      MO_FS_Conv from to -> coerceFP2Int from to x+      MO_SF_Conv from to -> coerceInt2FP from to x++      MO_V_Insert {}   -> needLlvm+      MO_V_Extract {}  -> needLlvm+      MO_V_Add {}      -> needLlvm+      MO_V_Sub {}      -> needLlvm+      MO_V_Mul {}      -> needLlvm+      MO_VS_Quot {}    -> needLlvm+      MO_VS_Rem {}     -> needLlvm+      MO_VS_Neg {}     -> needLlvm+      MO_VU_Quot {}    -> needLlvm+      MO_VU_Rem {}     -> needLlvm+      MO_VF_Insert {}  -> needLlvm+      MO_VF_Extract {} -> needLlvm+      MO_VF_Add {}     -> needLlvm+      MO_VF_Sub {}     -> needLlvm+      MO_VF_Mul {}     -> needLlvm+      MO_VF_Quot {}    -> needLlvm+      MO_VF_Neg {}     -> needLlvm++      _other -> pprPanic "getRegister" (pprMachOp mop)+   where+        triv_ucode :: (Format -> Operand -> Instr) -> Format -> NatM Register+        triv_ucode instr format = trivialUCode format (instr format) x++        -- signed or unsigned extension.+        integerExtend :: Width -> Width+                      -> (Format -> Operand -> Operand -> Instr)+                      -> CmmExpr -> NatM Register+        integerExtend from to instr expr = do+            (reg,e_code) <- if from == W8 then getByteReg expr+                                          else getSomeReg expr+            let+                code dst =+                  e_code `snocOL`+                  instr (intFormat from) (OpReg reg) (OpReg dst)+            return (Any (intFormat to) code)++        toI8Reg :: Width -> CmmExpr -> NatM Register+        toI8Reg new_rep expr+            = do codefn <- getAnyReg expr+                 return (Any (intFormat new_rep) codefn)+                -- HACK: use getAnyReg to get a byte-addressable register.+                -- If the source was a Fixed register, this will add the+                -- mov instruction to put it into the desired destination.+                -- We're assuming that the destination won't be a fixed+                -- non-byte-addressable register; it won't be, because all+                -- fixed registers are word-sized.++        toI16Reg = toI8Reg -- for now++        conversionNop :: Format -> CmmExpr -> NatM Register+        conversionNop new_format expr+            = do e_code <- getRegister' dflags is32Bit expr+                 return (swizzleRegisterRep e_code new_format)+++getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps+  sse2 <- sse2Enabled+  case mop of+      MO_F_Eq _ -> condFltReg is32Bit EQQ x y+      MO_F_Ne _ -> condFltReg is32Bit NE  x y+      MO_F_Gt _ -> condFltReg is32Bit GTT x y+      MO_F_Ge _ -> condFltReg is32Bit GE  x y+      MO_F_Lt _ -> condFltReg is32Bit LTT x y+      MO_F_Le _ -> condFltReg is32Bit LE  x y++      MO_Eq _   -> condIntReg EQQ x y+      MO_Ne _   -> condIntReg NE  x y++      MO_S_Gt _ -> condIntReg GTT x y+      MO_S_Ge _ -> condIntReg GE  x y+      MO_S_Lt _ -> condIntReg LTT x y+      MO_S_Le _ -> condIntReg LE  x y++      MO_U_Gt _ -> condIntReg GU  x y+      MO_U_Ge _ -> condIntReg GEU x y+      MO_U_Lt _ -> condIntReg LU  x y+      MO_U_Le _ -> condIntReg LEU x y++      MO_F_Add w  | sse2      -> trivialFCode_sse2 w ADD  x y+                  | otherwise -> trivialFCode_x87    GADD x y+      MO_F_Sub w  | sse2      -> trivialFCode_sse2 w SUB  x y+                  | otherwise -> trivialFCode_x87    GSUB x y+      MO_F_Quot w | sse2      -> trivialFCode_sse2 w FDIV x y+                  | otherwise -> trivialFCode_x87    GDIV x y+      MO_F_Mul w  | sse2      -> trivialFCode_sse2 w MUL x y+                  | otherwise -> trivialFCode_x87    GMUL x y++      MO_Add rep -> add_code rep x y+      MO_Sub rep -> sub_code rep x y++      MO_S_Quot rep -> div_code rep True  True  x y+      MO_S_Rem  rep -> div_code rep True  False x y+      MO_U_Quot rep -> div_code rep False True  x y+      MO_U_Rem  rep -> div_code rep False False x y++      MO_S_MulMayOflo rep -> imulMayOflo rep x y++      MO_Mul rep -> triv_op rep IMUL+      MO_And rep -> triv_op rep AND+      MO_Or  rep -> triv_op rep OR+      MO_Xor rep -> triv_op rep XOR++        {- Shift ops on x86s have constraints on their source, it+           either has to be Imm, CL or 1+            => trivialCode is not restrictive enough (sigh.)+        -}+      MO_Shl rep   -> shift_code rep SHL x y {-False-}+      MO_U_Shr rep -> shift_code rep SHR x y {-False-}+      MO_S_Shr rep -> shift_code rep SAR x y {-False-}++      MO_V_Insert {}   -> needLlvm+      MO_V_Extract {}  -> needLlvm+      MO_V_Add {}      -> needLlvm+      MO_V_Sub {}      -> needLlvm+      MO_V_Mul {}      -> needLlvm+      MO_VS_Quot {}    -> needLlvm+      MO_VS_Rem {}     -> needLlvm+      MO_VS_Neg {}     -> needLlvm+      MO_VF_Insert {}  -> needLlvm+      MO_VF_Extract {} -> needLlvm+      MO_VF_Add {}     -> needLlvm+      MO_VF_Sub {}     -> needLlvm+      MO_VF_Mul {}     -> needLlvm+      MO_VF_Quot {}    -> needLlvm+      MO_VF_Neg {}     -> needLlvm++      _other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop)+  where+    --------------------+    triv_op width instr = trivialCode width op (Just op) x y+                        where op   = instr (intFormat width)++    imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register+    imulMayOflo rep a b = do+         (a_reg, a_code) <- getNonClobberedReg a+         b_code <- getAnyReg b+         let+             shift_amt  = case rep of+                           W32 -> 31+                           W64 -> 63+                           _ -> panic "shift_amt"++             format = intFormat rep+             code = a_code `appOL` b_code eax `appOL`+                        toOL [+                           IMUL2 format (OpReg a_reg),   -- result in %edx:%eax+                           SAR format (OpImm (ImmInt shift_amt)) (OpReg eax),+                                -- sign extend lower part+                           SUB format (OpReg edx) (OpReg eax)+                                -- compare against upper+                           -- eax==0 if high part == sign extended low part+                        ]+         return (Fixed format eax code)++    --------------------+    shift_code :: Width+               -> (Format -> Operand -> Operand -> Instr)+               -> CmmExpr+               -> CmmExpr+               -> NatM Register++    {- Case1: shift length as immediate -}+    shift_code width instr x (CmmLit lit) = do+          x_code <- getAnyReg x+          let+               format = intFormat width+               code dst+                  = x_code dst `snocOL`+                    instr format (OpImm (litToImm lit)) (OpReg dst)+          return (Any format code)++    {- Case2: shift length is complex (non-immediate)+      * y must go in %ecx.+      * we cannot do y first *and* put its result in %ecx, because+        %ecx might be clobbered by x.+      * if we do y second, then x cannot be+        in a clobbered reg.  Also, we cannot clobber x's reg+        with the instruction itself.+      * so we can either:+        - do y first, put its result in a fresh tmp, then copy it to %ecx later+        - do y second and put its result into %ecx.  x gets placed in a fresh+          tmp.  This is likely to be better, because the reg alloc can+          eliminate this reg->reg move here (it won't eliminate the other one,+          because the move is into the fixed %ecx).+    -}+    shift_code width instr x y{-amount-} = do+        x_code <- getAnyReg x+        let format = intFormat width+        tmp <- getNewRegNat format+        y_code <- getAnyReg y+        let+           code = x_code tmp `appOL`+                  y_code ecx `snocOL`+                  instr format (OpReg ecx) (OpReg tmp)+        return (Fixed format tmp code)++    --------------------+    add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register+    add_code rep x (CmmLit (CmmInt y _))+        | is32BitInteger y = add_int rep x y+    add_code rep x y = trivialCode rep (ADD format) (Just (ADD format)) x y+      where format = intFormat rep+    -- TODO: There are other interesting patterns we want to replace+    --     with a LEA, e.g. `(x + offset) + (y << shift)`.++    --------------------+    sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register+    sub_code rep x (CmmLit (CmmInt y _))+        | is32BitInteger (-y) = add_int rep x (-y)+    sub_code rep x y = trivialCode rep (SUB (intFormat rep)) Nothing x y++    -- our three-operand add instruction:+    add_int width x y = do+        (x_reg, x_code) <- getSomeReg x+        let+            format = intFormat width+            imm = ImmInt (fromInteger y)+            code dst+               = x_code `snocOL`+                 LEA format+                        (OpAddr (AddrBaseIndex (EABaseReg x_reg) EAIndexNone imm))+                        (OpReg dst)+        --+        return (Any format code)++    ----------------------+    div_code width signed quotient x y = do+           (y_op, y_code) <- getRegOrMem y -- cannot be clobbered+           x_code <- getAnyReg x+           let+             format = intFormat width+             widen | signed    = CLTD format+                   | otherwise = XOR format (OpReg edx) (OpReg edx)++             instr | signed    = IDIV+                   | otherwise = DIV++             code = y_code `appOL`+                    x_code eax `appOL`+                    toOL [widen, instr format y_op]++             result | quotient  = eax+                    | otherwise = edx++           return (Fixed format result code)+++getRegister' _ _ (CmmLoad mem pk)+  | isFloatType pk+  = do+    Amode addr mem_code <- getAmode mem+    use_sse2 <- sse2Enabled+    loadFloatAmode use_sse2 (typeWidth pk) addr mem_code++getRegister' _ is32Bit (CmmLoad mem pk)+  | is32Bit && not (isWord64 pk)+  = do+    code <- intLoadCode instr mem+    return (Any format code)+  where+    width = typeWidth pk+    format = intFormat width+    instr = case width of+                W8     -> MOVZxL II8+                _other -> MOV format+        -- We always zero-extend 8-bit loads, if we+        -- can't think of anything better.  This is because+        -- we can't guarantee access to an 8-bit variant of every register+        -- (esi and edi don't have 8-bit variants), so to make things+        -- simpler we do our 8-bit arithmetic with full 32-bit registers.++-- Simpler memory load code on x86_64+getRegister' _ is32Bit (CmmLoad mem pk)+ | not is32Bit+  = do+    code <- intLoadCode (MOV format) mem+    return (Any format code)+  where format = intFormat $ typeWidth pk++getRegister' _ is32Bit (CmmLit (CmmInt 0 width))+  = let+        format = intFormat width++        -- x86_64: 32-bit xor is one byte shorter, and zero-extends to 64 bits+        format1 = if is32Bit then format+                           else case format of+                                II64 -> II32+                                _ -> format+        code dst+           = unitOL (XOR format1 (OpReg dst) (OpReg dst))+    in+        return (Any format code)++  -- optimisation for loading small literals on x86_64: take advantage+  -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit+  -- instruction forms are shorter.+getRegister' dflags is32Bit (CmmLit lit)+  | not is32Bit, isWord64 (cmmLitType dflags lit), not (isBigLit lit)+  = let+        imm = litToImm lit+        code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst))+    in+        return (Any II64 code)+  where+   isBigLit (CmmInt i _) = i < 0 || i > 0xffffffff+   isBigLit _ = False+        -- note1: not the same as (not.is32BitLit), because that checks for+        -- signed literals that fit in 32 bits, but we want unsigned+        -- literals here.+        -- note2: all labels are small, because we're assuming the+        -- small memory model (see gcc docs, -mcmodel=small).++getRegister' dflags _ (CmmLit lit)+  = do let format = cmmTypeFormat (cmmLitType dflags lit)+           imm = litToImm lit+           code dst = unitOL (MOV format (OpImm imm) (OpReg dst))+       return (Any format code)++getRegister' _ _ other+    | isVecExpr other  = needLlvm+    | otherwise        = pprPanic "getRegister(x86)" (ppr other)+++intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr+   -> NatM (Reg -> InstrBlock)+intLoadCode instr mem = do+  Amode src mem_code <- getAmode mem+  return (\dst -> mem_code `snocOL` instr (OpAddr src) (OpReg dst))++-- Compute an expression into *any* register, adding the appropriate+-- move instruction if necessary.+getAnyReg :: CmmExpr -> NatM (Reg -> InstrBlock)+getAnyReg expr = do+  r <- getRegister expr+  anyReg r++anyReg :: Register -> NatM (Reg -> InstrBlock)+anyReg (Any _ code)          = return code+anyReg (Fixed rep reg fcode) = return (\dst -> fcode `snocOL` reg2reg rep reg dst)++-- A bit like getSomeReg, but we want a reg that can be byte-addressed.+-- Fixed registers might not be byte-addressable, so we make sure we've+-- got a temporary, inserting an extra reg copy if necessary.+getByteReg :: CmmExpr -> NatM (Reg, InstrBlock)+getByteReg expr = do+  is32Bit <- is32BitPlatform+  if is32Bit+      then do r <- getRegister expr+              case r of+                Any rep code -> do+                    tmp <- getNewRegNat rep+                    return (tmp, code tmp)+                Fixed rep reg code+                    | isVirtualReg reg -> return (reg,code)+                    | otherwise -> do+                        tmp <- getNewRegNat rep+                        return (tmp, code `snocOL` reg2reg rep reg tmp)+                    -- ToDo: could optimise slightly by checking for+                    -- byte-addressable real registers, but that will+                    -- happen very rarely if at all.+      else getSomeReg expr -- all regs are byte-addressable on x86_64++-- Another variant: this time we want the result in a register that cannot+-- be modified by code to evaluate an arbitrary expression.+getNonClobberedReg :: CmmExpr -> NatM (Reg, InstrBlock)+getNonClobberedReg expr = do+  dflags <- getDynFlags+  r <- getRegister expr+  case r of+    Any rep code -> do+        tmp <- getNewRegNat rep+        return (tmp, code tmp)+    Fixed rep reg code+        -- only certain regs can be clobbered+        | reg `elem` instrClobberedRegs (targetPlatform dflags)+        -> do+                tmp <- getNewRegNat rep+                return (tmp, code `snocOL` reg2reg rep reg tmp)+        | otherwise ->+                return (reg, code)++reg2reg :: Format -> Reg -> Reg -> Instr+reg2reg format src dst+  | format == FF80 = GMOV src dst+  | otherwise    = MOV format (OpReg src) (OpReg dst)+++--------------------------------------------------------------------------------+getAmode :: CmmExpr -> NatM Amode+getAmode e = do is32Bit <- is32BitPlatform+                getAmode' is32Bit e++getAmode' :: Bool -> CmmExpr -> NatM Amode+getAmode' _ (CmmRegOff r n) = do dflags <- getDynFlags+                                 getAmode $ mangleIndexTree dflags r n++getAmode' is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),+                                                  CmmLit displacement])+ | not is32Bit+    = return $ Amode (ripRel (litToImm displacement)) nilOL+++-- This is all just ridiculous, since it carefully undoes+-- what mangleIndexTree has just done.+getAmode' is32Bit (CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)])+  | is32BitLit is32Bit lit+  -- ASSERT(rep == II32)???+  = do (x_reg, x_code) <- getSomeReg x+       let off = ImmInt (-(fromInteger i))+       return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)++getAmode' is32Bit (CmmMachOp (MO_Add _rep) [x, CmmLit lit])+  | is32BitLit is32Bit lit+  -- ASSERT(rep == II32)???+  = do (x_reg, x_code) <- getSomeReg x+       let off = litToImm lit+       return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)++-- Turn (lit1 << n  + lit2) into  (lit2 + lit1 << n) so it will be+-- recognised by the next rule.+getAmode' is32Bit (CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _),+                                  b@(CmmLit _)])+  = getAmode' is32Bit (CmmMachOp (MO_Add rep) [b,a])++-- Matches: (x + offset) + (y << shift)+getAmode' _ (CmmMachOp (MO_Add _) [CmmRegOff x offset,+                                   CmmMachOp (MO_Shl _)+                                        [y, CmmLit (CmmInt shift _)]])+  | shift == 0 || shift == 1 || shift == 2 || shift == 3+  = x86_complex_amode (CmmReg x) y shift (fromIntegral offset)++getAmode' _ (CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Shl _)+                                        [y, CmmLit (CmmInt shift _)]])+  | shift == 0 || shift == 1 || shift == 2 || shift == 3+  = x86_complex_amode x y shift 0++getAmode' _ (CmmMachOp (MO_Add _)+                [x, CmmMachOp (MO_Add _)+                        [CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)],+                         CmmLit (CmmInt offset _)]])+  | shift == 0 || shift == 1 || shift == 2 || shift == 3+  && is32BitInteger offset+  = x86_complex_amode x y shift offset++getAmode' _ (CmmMachOp (MO_Add _) [x,y])+  = x86_complex_amode x y 0 0++getAmode' is32Bit (CmmLit lit) | is32BitLit is32Bit lit+  = return (Amode (ImmAddr (litToImm lit) 0) nilOL)++getAmode' _ expr = do+  (reg,code) <- getSomeReg expr+  return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code)++-- | Like 'getAmode', but on 32-bit use simple register addressing+-- (i.e. no index register). This stops us from running out of+-- registers on x86 when using instructions such as cmpxchg, which can+-- use up to three virtual registers and one fixed register.+getSimpleAmode :: DynFlags -> Bool -> CmmExpr -> NatM Amode+getSimpleAmode dflags is32Bit addr+    | is32Bit = do+        addr_code <- getAnyReg addr+        addr_r <- getNewRegNat (intFormat (wordWidth dflags))+        let amode = AddrBaseIndex (EABaseReg addr_r) EAIndexNone (ImmInt 0)+        return $! Amode amode (addr_code addr_r)+    | otherwise = getAmode addr++x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode+x86_complex_amode base index shift offset+  = do (x_reg, x_code) <- getNonClobberedReg base+        -- x must be in a temp, because it has to stay live over y_code+        -- we could compre x_reg and y_reg and do something better here...+       (y_reg, y_code) <- getSomeReg index+       let+           code = x_code `appOL` y_code+           base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8;+                                n -> panic $ "x86_complex_amode: unhandled shift! (" ++ show n ++ ")"+       return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt (fromIntegral offset)))+               code)+++++-- -----------------------------------------------------------------------------+-- getOperand: sometimes any operand will do.++-- getNonClobberedOperand: the value of the operand will remain valid across+-- the computation of an arbitrary expression, unless the expression+-- is computed directly into a register which the operand refers to+-- (see trivialCode where this function is used for an example).++getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock)+getNonClobberedOperand (CmmLit lit) = do+  use_sse2 <- sse2Enabled+  if use_sse2 && isSuitableFloatingPointLit lit+    then do+      let CmmFloat _ w = lit+      Amode addr code <- memConstant (widthInBytes w) lit+      return (OpAddr addr, code)+     else do++  is32Bit <- is32BitPlatform+  dflags <- getDynFlags+  if is32BitLit is32Bit lit && not (isFloatType (cmmLitType dflags lit))+    then return (OpImm (litToImm lit), nilOL)+    else getNonClobberedOperand_generic (CmmLit lit)++getNonClobberedOperand (CmmLoad mem pk) = do+  is32Bit <- is32BitPlatform+  use_sse2 <- sse2Enabled+  if (not (isFloatType pk) || use_sse2)+      && (if is32Bit then not (isWord64 pk) else True)+    then do+      dflags <- getDynFlags+      let platform = targetPlatform dflags+      Amode src mem_code <- getAmode mem+      (src',save_code) <-+        if (amodeCouldBeClobbered platform src)+                then do+                   tmp <- getNewRegNat (archWordFormat is32Bit)+                   return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0),+                           unitOL (LEA (archWordFormat is32Bit)+                                       (OpAddr src)+                                       (OpReg tmp)))+                else+                   return (src, nilOL)+      return (OpAddr src', mem_code `appOL` save_code)+    else do+      getNonClobberedOperand_generic (CmmLoad mem pk)++getNonClobberedOperand e = getNonClobberedOperand_generic e++getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)+getNonClobberedOperand_generic e = do+    (reg, code) <- getNonClobberedReg e+    return (OpReg reg, code)++amodeCouldBeClobbered :: Platform -> AddrMode -> Bool+amodeCouldBeClobbered platform amode = any (regClobbered platform) (addrModeRegs amode)++regClobbered :: Platform -> Reg -> Bool+regClobbered platform (RegReal (RealRegSingle rr)) = freeReg platform rr+regClobbered _ _ = False++-- getOperand: the operand is not required to remain valid across the+-- computation of an arbitrary expression.+getOperand :: CmmExpr -> NatM (Operand, InstrBlock)++getOperand (CmmLit lit) = do+  use_sse2 <- sse2Enabled+  if (use_sse2 && isSuitableFloatingPointLit lit)+    then do+      let CmmFloat _ w = lit+      Amode addr code <- memConstant (widthInBytes w) lit+      return (OpAddr addr, code)+    else do++  is32Bit <- is32BitPlatform+  dflags <- getDynFlags+  if is32BitLit is32Bit lit && not (isFloatType (cmmLitType dflags lit))+    then return (OpImm (litToImm lit), nilOL)+    else getOperand_generic (CmmLit lit)++getOperand (CmmLoad mem pk) = do+  is32Bit <- is32BitPlatform+  use_sse2 <- sse2Enabled+  if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True)+     then do+       Amode src mem_code <- getAmode mem+       return (OpAddr src, mem_code)+     else+       getOperand_generic (CmmLoad mem pk)++getOperand e = getOperand_generic e++getOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)+getOperand_generic e = do+    (reg, code) <- getSomeReg e+    return (OpReg reg, code)++isOperand :: Bool -> CmmExpr -> Bool+isOperand _ (CmmLoad _ _) = True+isOperand is32Bit (CmmLit lit)  = is32BitLit is32Bit lit+                          || isSuitableFloatingPointLit lit+isOperand _ _            = False++memConstant :: Int -> CmmLit -> NatM Amode+memConstant align lit = do+  lbl <- getNewLabelNat+  let rosection = Section ReadOnlyData lbl+  dflags <- getDynFlags+  (addr, addr_code) <- if target32Bit (targetPlatform dflags)+                       then do dynRef <- cmmMakeDynamicReference+                                             dflags+                                             DataReference+                                             lbl+                               Amode addr addr_code <- getAmode dynRef+                               return (addr, addr_code)+                       else return (ripRel (ImmCLbl lbl), nilOL)+  let code =+        LDATA rosection (align, Statics lbl [CmmStaticLit lit])+        `consOL` addr_code+  return (Amode addr code)+++loadFloatAmode :: Bool -> Width -> AddrMode -> InstrBlock -> NatM Register+loadFloatAmode use_sse2 w addr addr_code = do+  let format = floatFormat w+      code dst = addr_code `snocOL`+                 if use_sse2+                    then MOV format (OpAddr addr) (OpReg dst)+                    else GLD format addr dst+  return (Any (if use_sse2 then format else FF80) code)+++-- if we want a floating-point literal as an operand, we can+-- use it directly from memory.  However, if the literal is+-- zero, we're better off generating it into a register using+-- xor.+isSuitableFloatingPointLit :: CmmLit -> Bool+isSuitableFloatingPointLit (CmmFloat f _) = f /= 0.0+isSuitableFloatingPointLit _ = False++getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock)+getRegOrMem e@(CmmLoad mem pk) = do+  is32Bit <- is32BitPlatform+  use_sse2 <- sse2Enabled+  if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True)+     then do+       Amode src mem_code <- getAmode mem+       return (OpAddr src, mem_code)+     else do+       (reg, code) <- getNonClobberedReg e+       return (OpReg reg, code)+getRegOrMem e = do+    (reg, code) <- getNonClobberedReg e+    return (OpReg reg, code)++is32BitLit :: Bool -> CmmLit -> Bool+is32BitLit is32Bit (CmmInt i W64)+ | not is32Bit+    = -- assume that labels are in the range 0-2^31-1: this assumes the+      -- small memory model (see gcc docs, -mcmodel=small).+      is32BitInteger i+is32BitLit _ _ = True+++++-- Set up a condition code for a conditional branch.++getCondCode :: CmmExpr -> NatM CondCode++-- yes, they really do seem to want exactly the same!++getCondCode (CmmMachOp mop [x, y])+  =+    case mop of+      MO_F_Eq W32 -> condFltCode EQQ x y+      MO_F_Ne W32 -> condFltCode NE  x y+      MO_F_Gt W32 -> condFltCode GTT x y+      MO_F_Ge W32 -> condFltCode GE  x y+      MO_F_Lt W32 -> condFltCode LTT x y+      MO_F_Le W32 -> condFltCode LE  x y++      MO_F_Eq W64 -> condFltCode EQQ x y+      MO_F_Ne W64 -> condFltCode NE  x y+      MO_F_Gt W64 -> condFltCode GTT x y+      MO_F_Ge W64 -> condFltCode GE  x y+      MO_F_Lt W64 -> condFltCode LTT x y+      MO_F_Le W64 -> condFltCode LE  x y++      _ -> condIntCode (machOpToCond mop) x y++getCondCode other = pprPanic "getCondCode(2)(x86,x86_64)" (ppr other)++machOpToCond :: MachOp -> Cond+machOpToCond mo = case mo of+  MO_Eq _   -> EQQ+  MO_Ne _   -> NE+  MO_S_Gt _ -> GTT+  MO_S_Ge _ -> GE+  MO_S_Lt _ -> LTT+  MO_S_Le _ -> LE+  MO_U_Gt _ -> GU+  MO_U_Ge _ -> GEU+  MO_U_Lt _ -> LU+  MO_U_Le _ -> LEU+  _other -> pprPanic "machOpToCond" (pprMachOp mo)+++-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be+-- passed back up the tree.++condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode+condIntCode cond x y = do is32Bit <- is32BitPlatform+                          condIntCode' is32Bit cond x y++condIntCode' :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode++-- memory vs immediate+condIntCode' is32Bit cond (CmmLoad x pk) (CmmLit lit)+ | is32BitLit is32Bit lit = do+    Amode x_addr x_code <- getAmode x+    let+        imm  = litToImm lit+        code = x_code `snocOL`+                  CMP (cmmTypeFormat pk) (OpImm imm) (OpAddr x_addr)+    --+    return (CondCode False cond code)++-- anything vs zero, using a mask+-- TODO: Add some sanity checking!!!!+condIntCode' is32Bit cond (CmmMachOp (MO_And _) [x,o2]) (CmmLit (CmmInt 0 pk))+    | (CmmLit lit@(CmmInt mask _)) <- o2, is32BitLit is32Bit lit+    = do+      (x_reg, x_code) <- getSomeReg x+      let+         code = x_code `snocOL`+                TEST (intFormat pk) (OpImm (ImmInteger mask)) (OpReg x_reg)+      --+      return (CondCode False cond code)++-- anything vs zero+condIntCode' _ cond x (CmmLit (CmmInt 0 pk)) = do+    (x_reg, x_code) <- getSomeReg x+    let+        code = x_code `snocOL`+                  TEST (intFormat pk) (OpReg x_reg) (OpReg x_reg)+    --+    return (CondCode False cond code)++-- anything vs operand+condIntCode' is32Bit cond x y+ | isOperand is32Bit y = do+    dflags <- getDynFlags+    (x_reg, x_code) <- getNonClobberedReg x+    (y_op,  y_code) <- getOperand y+    let+        code = x_code `appOL` y_code `snocOL`+                  CMP (cmmTypeFormat (cmmExprType dflags x)) y_op (OpReg x_reg)+    return (CondCode False cond code)+-- operand vs. anything: invert the comparison so that we can use a+-- single comparison instruction.+ | isOperand is32Bit x+ , Just revcond <- maybeFlipCond cond = do+    dflags <- getDynFlags+    (y_reg, y_code) <- getNonClobberedReg y+    (x_op,  x_code) <- getOperand x+    let+        code = y_code `appOL` x_code `snocOL`+                  CMP (cmmTypeFormat (cmmExprType dflags x)) x_op (OpReg y_reg)+    return (CondCode False revcond code)++-- anything vs anything+condIntCode' _ cond x y = do+  dflags <- getDynFlags+  (y_reg, y_code) <- getNonClobberedReg y+  (x_op, x_code) <- getRegOrMem x+  let+        code = y_code `appOL`+               x_code `snocOL`+                  CMP (cmmTypeFormat (cmmExprType dflags x)) (OpReg y_reg) x_op+  return (CondCode False cond code)++++--------------------------------------------------------------------------------+condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode++condFltCode cond x y+  = if_sse2 condFltCode_sse2 condFltCode_x87+  where++  condFltCode_x87+    = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT])) do+    (x_reg, x_code) <- getNonClobberedReg x+    (y_reg, y_code) <- getSomeReg y+    let+        code = x_code `appOL` y_code `snocOL`+                GCMP cond x_reg y_reg+    -- The GCMP insn does the test and sets the zero flag if comparable+    -- and true.  Hence we always supply EQQ as the condition to test.+    return (CondCode True EQQ code)++  -- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be+  -- an operand, but the right must be a reg.  We can probably do better+  -- than this general case...+  condFltCode_sse2 = do+    dflags <- getDynFlags+    (x_reg, x_code) <- getNonClobberedReg x+    (y_op, y_code) <- getOperand y+    let+        code = x_code `appOL`+               y_code `snocOL`+                  CMP (floatFormat $ cmmExprWidth dflags x) y_op (OpReg x_reg)+        -- NB(1): we need to use the unsigned comparison operators on the+        -- result of this comparison.+    return (CondCode True (condToUnsigned cond) code)++-- -----------------------------------------------------------------------------+-- Generating assignments++-- Assignments are really at the heart of the whole code generation+-- business.  Almost all top-level nodes of any real importance are+-- assignments, which correspond to loads, stores, or register+-- transfers.  If we're really lucky, some of the register transfers+-- will go away, because we can use the destination register to+-- complete the code generation for the right hand side.  This only+-- fails when the right hand side is forced into a fixed register+-- (e.g. the result of a call).++assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock++assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock+++-- integer assignment to memory++-- specific case of adding/subtracting an integer to a particular address.+-- ToDo: catch other cases where we can use an operation directly on a memory+-- address.+assignMem_IntCode pk addr (CmmMachOp op [CmmLoad addr2 _,+                                                 CmmLit (CmmInt i _)])+   | addr == addr2, pk /= II64 || is32BitInteger i,+     Just instr <- check op+   = do Amode amode code_addr <- getAmode addr+        let code = code_addr `snocOL`+                   instr pk (OpImm (ImmInt (fromIntegral i))) (OpAddr amode)+        return code+   where+        check (MO_Add _) = Just ADD+        check (MO_Sub _) = Just SUB+        check _ = Nothing+        -- ToDo: more?++-- general case+assignMem_IntCode pk addr src = do+    is32Bit <- is32BitPlatform+    Amode addr code_addr <- getAmode addr+    (code_src, op_src)   <- get_op_RI is32Bit src+    let+        code = code_src `appOL`+               code_addr `snocOL`+                  MOV pk op_src (OpAddr addr)+        -- NOTE: op_src is stable, so it will still be valid+        -- after code_addr.  This may involve the introduction+        -- of an extra MOV to a temporary register, but we hope+        -- the register allocator will get rid of it.+    --+    return code+  where+    get_op_RI :: Bool -> CmmExpr -> NatM (InstrBlock,Operand)   -- code, operator+    get_op_RI is32Bit (CmmLit lit) | is32BitLit is32Bit lit+      = return (nilOL, OpImm (litToImm lit))+    get_op_RI _ op+      = do (reg,code) <- getNonClobberedReg op+           return (code, OpReg reg)+++-- Assign; dst is a reg, rhs is mem+assignReg_IntCode pk reg (CmmLoad src _) = do+  load_code <- intLoadCode (MOV pk) src+  dflags <- getDynFlags+  let platform = targetPlatform dflags+  return (load_code (getRegisterReg platform False{-no sse2-} reg))++-- dst is a reg, but src could be anything+assignReg_IntCode _ reg src = do+  dflags <- getDynFlags+  let platform = targetPlatform dflags+  code <- getAnyReg src+  return (code (getRegisterReg platform False{-no sse2-} reg))+++-- Floating point assignment to memory+assignMem_FltCode pk addr src = do+  (src_reg, src_code) <- getNonClobberedReg src+  Amode addr addr_code <- getAmode addr+  use_sse2 <- sse2Enabled+  let+        code = src_code `appOL`+               addr_code `snocOL`+                if use_sse2 then MOV pk (OpReg src_reg) (OpAddr addr)+                            else GST pk src_reg addr+  return code++-- Floating point assignment to a register/temporary+assignReg_FltCode _ reg src = do+  use_sse2 <- sse2Enabled+  src_code <- getAnyReg src+  dflags <- getDynFlags+  let platform = targetPlatform dflags+  return (src_code (getRegisterReg platform use_sse2 reg))+++genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock++genJump (CmmLoad mem _) regs = do+  Amode target code <- getAmode mem+  return (code `snocOL` JMP (OpAddr target) regs)++genJump (CmmLit lit) regs = do+  return (unitOL (JMP (OpImm (litToImm lit)) regs))++genJump expr regs = do+  (reg,code) <- getSomeReg expr+  return (code `snocOL` JMP (OpReg reg) regs)+++-- -----------------------------------------------------------------------------+--  Unconditional branches++genBranch :: BlockId -> NatM InstrBlock+genBranch = return . toOL . mkJumpInstr++++-- -----------------------------------------------------------------------------+--  Conditional jumps++{-+Conditional jumps are always to local labels, so we can use branch+instructions.  We peek at the arguments to decide what kind of+comparison to do.++I386: First, we have to ensure that the condition+codes are set according to the supplied comparison operation.+-}++genCondJump+    :: BlockId      -- the branch target+    -> CmmExpr      -- the condition on which to branch+    -> NatM InstrBlock++genCondJump id expr = do+  is32Bit <- is32BitPlatform+  genCondJump' is32Bit id expr++genCondJump' :: Bool -> BlockId -> CmmExpr -> NatM InstrBlock++-- 64-bit integer comparisons on 32-bit+genCondJump' is32Bit true (CmmMachOp mop [e1,e2])+  | is32Bit, Just W64 <- maybeIntComparison mop = do+  ChildCode64 code1 r1_lo <- iselExpr64 e1+  ChildCode64 code2 r2_lo <- iselExpr64 e2+  let r1_hi = getHiVRegFromLo r1_lo+      r2_hi = getHiVRegFromLo r2_lo+      cond = machOpToCond mop+      Just cond' = maybeFlipCond cond+  false <- getBlockIdNat+  return $ code1 `appOL` code2 `appOL` toOL [+    CMP II32 (OpReg r2_hi) (OpReg r1_hi),+    JXX cond true,+    JXX cond' false,+    CMP II32 (OpReg r2_lo) (OpReg r1_lo),+    JXX cond true,+    NEWBLOCK false ]++genCondJump' _ id bool = do+  CondCode is_float cond cond_code <- getCondCode bool+  use_sse2 <- sse2Enabled+  if not is_float || not use_sse2+    then+        return (cond_code `snocOL` JXX cond id)+    else do+        lbl <- getBlockIdNat++        -- see comment with condFltReg+        let code = case cond of+                        NE  -> or_unordered+                        GU  -> plain_test+                        GEU -> plain_test+                        _   -> and_ordered++            plain_test = unitOL (+                  JXX cond id+                )+            or_unordered = toOL [+                  JXX cond id,+                  JXX PARITY id+                ]+            and_ordered = toOL [+                  JXX PARITY lbl,+                  JXX cond id,+                  JXX ALWAYS lbl,+                  NEWBLOCK lbl+                ]+        return (cond_code `appOL` code)++-- -----------------------------------------------------------------------------+--  Generating C calls++-- Now the biggest nightmare---calls.  Most of the nastiness is buried in+-- @get_arg@, which moves the arguments to the correct registers/stack+-- locations.  Apart from that, the code is easy.+--+-- (If applicable) Do not fill the delay slots here; you will confuse the+-- register allocator.++genCCall+    :: DynFlags+    -> Bool                     -- 32 bit platform?+    -> ForeignTarget            -- function to call+    -> [CmmFormal]        -- where to put the result+    -> [CmmActual]        -- arguments (of mixed type)+    -> NatM InstrBlock++-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -++-- Unroll memcpy calls if the source and destination pointers are at+-- least DWORD aligned and the number of bytes to copy isn't too+-- large.  Otherwise, call C's memcpy.+genCCall dflags is32Bit (PrimTarget (MO_Memcpy align)) _+         [dst, src, CmmLit (CmmInt n _)]+    | fromInteger insns <= maxInlineMemcpyInsns dflags && align .&. 3 == 0 = do+        code_dst <- getAnyReg dst+        dst_r <- getNewRegNat format+        code_src <- getAnyReg src+        src_r <- getNewRegNat format+        tmp_r <- getNewRegNat format+        return $ code_dst dst_r `appOL` code_src src_r `appOL`+            go dst_r src_r tmp_r (fromInteger n)+  where+    -- The number of instructions we will generate (approx). We need 2+    -- instructions per move.+    insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes)++    format = if align .&. 4 /= 0 then II32 else (archWordFormat is32Bit)++    -- The size of each move, in bytes.+    sizeBytes :: Integer+    sizeBytes = fromIntegral (formatInBytes format)++    go :: Reg -> Reg -> Reg -> Integer -> OrdList Instr+    go dst src tmp i+        | i >= sizeBytes =+            unitOL (MOV format (OpAddr src_addr) (OpReg tmp)) `appOL`+            unitOL (MOV format (OpReg tmp) (OpAddr dst_addr)) `appOL`+            go dst src tmp (i - sizeBytes)+        -- Deal with remaining bytes.+        | i >= 4 =  -- Will never happen on 32-bit+            unitOL (MOV II32 (OpAddr src_addr) (OpReg tmp)) `appOL`+            unitOL (MOV II32 (OpReg tmp) (OpAddr dst_addr)) `appOL`+            go dst src tmp (i - 4)+        | i >= 2 =+            unitOL (MOVZxL II16 (OpAddr src_addr) (OpReg tmp)) `appOL`+            unitOL (MOV II16 (OpReg tmp) (OpAddr dst_addr)) `appOL`+            go dst src tmp (i - 2)+        | i >= 1 =+            unitOL (MOVZxL II8 (OpAddr src_addr) (OpReg tmp)) `appOL`+            unitOL (MOV II8 (OpReg tmp) (OpAddr dst_addr)) `appOL`+            go dst src tmp (i - 1)+        | otherwise = nilOL+      where+        src_addr = AddrBaseIndex (EABaseReg src) EAIndexNone+                   (ImmInteger (n - i))+        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone+                   (ImmInteger (n - i))++genCCall dflags _ (PrimTarget (MO_Memset align)) _+         [dst,+          CmmLit (CmmInt c _),+          CmmLit (CmmInt n _)]+    | fromInteger insns <= maxInlineMemsetInsns dflags && align .&. 3 == 0 = do+        code_dst <- getAnyReg dst+        dst_r <- getNewRegNat format+        return $ code_dst dst_r `appOL` go dst_r (fromInteger n)+  where+    (format, val) = case align .&. 3 of+        2 -> (II16, c2)+        0 -> (II32, c4)+        _ -> (II8, c)+    c2 = c `shiftL` 8 .|. c+    c4 = c2 `shiftL` 16 .|. c2++    -- The number of instructions we will generate (approx). We need 1+    -- instructions per move.+    insns = (n + sizeBytes - 1) `div` sizeBytes++    -- The size of each move, in bytes.+    sizeBytes :: Integer+    sizeBytes = fromIntegral (formatInBytes format)++    go :: Reg -> Integer -> OrdList Instr+    go dst i+        -- TODO: Add movabs instruction and support 64-bit sets.+        | i >= sizeBytes =  -- This might be smaller than the below sizes+            unitOL (MOV format (OpImm (ImmInteger val)) (OpAddr dst_addr)) `appOL`+            go dst (i - sizeBytes)+        | i >= 4 =  -- Will never happen on 32-bit+            unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr dst_addr)) `appOL`+            go dst (i - 4)+        | i >= 2 =+            unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr dst_addr)) `appOL`+            go dst (i - 2)+        | i >= 1 =+            unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr dst_addr)) `appOL`+            go dst (i - 1)+        | otherwise = nilOL+      where+        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone+                   (ImmInteger (n - i))++genCCall _ _ (PrimTarget MO_WriteBarrier) _ _ = return nilOL+        -- write barrier compiles to no code on x86/x86-64;+        -- we keep it this long in order to prevent earlier optimisations.++genCCall _ _ (PrimTarget MO_Touch) _ _ = return nilOL++genCCall _ is32bit (PrimTarget (MO_Prefetch_Data n )) _  [src] =+        case n of+            0 -> genPrefetch src $ PREFETCH NTA  format+            1 -> genPrefetch src $ PREFETCH Lvl2 format+            2 -> genPrefetch src $ PREFETCH Lvl1 format+            3 -> genPrefetch src $ PREFETCH Lvl0 format+            l -> panic $ "unexpected prefetch level in genCCall MO_Prefetch_Data: " ++ (show l)+            -- the c / llvm prefetch convention is 0, 1, 2, and 3+            -- the x86 corresponding names are : NTA, 2 , 1, and 0+   where+        format = archWordFormat is32bit+        -- need to know what register width for pointers!+        genPrefetch inRegSrc prefetchCTor =+            do+                code_src <- getAnyReg inRegSrc+                src_r <- getNewRegNat format+                return $ code_src src_r `appOL`+                  (unitOL (prefetchCTor  (OpAddr+                              ((AddrBaseIndex (EABaseReg src_r )   EAIndexNone (ImmInt 0))))  ))+                  -- prefetch always takes an address++genCCall dflags is32Bit (PrimTarget (MO_BSwap width)) [dst] [src] = do+    let platform = targetPlatform dflags+    let dst_r = getRegisterReg platform False (CmmLocal dst)+    case width of+        W64 | is32Bit -> do+               ChildCode64 vcode rlo <- iselExpr64 src+               let dst_rhi = getHiVRegFromLo dst_r+                   rhi     = getHiVRegFromLo rlo+               return $ vcode `appOL`+                        toOL [ MOV II32 (OpReg rlo) (OpReg dst_rhi),+                               MOV II32 (OpReg rhi) (OpReg dst_r),+                               BSWAP II32 dst_rhi,+                               BSWAP II32 dst_r ]+        W16 -> do code_src <- getAnyReg src+                  return $ code_src dst_r `appOL`+                           unitOL (BSWAP II32 dst_r) `appOL`+                           unitOL (SHR II32 (OpImm $ ImmInt 16) (OpReg dst_r))+        _   -> do code_src <- getAnyReg src+                  return $ code_src dst_r `appOL` unitOL (BSWAP format dst_r)+  where+    format = intFormat width++genCCall dflags is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst]+         args@[src] = do+    sse4_2 <- sse4_2Enabled+    let platform = targetPlatform dflags+    if sse4_2+        then do code_src <- getAnyReg src+                src_r <- getNewRegNat format+                let dst_r = getRegisterReg platform False (CmmLocal dst)+                return $ code_src src_r `appOL`+                    (if width == W8 then+                         -- The POPCNT instruction doesn't take a r/m8+                         unitOL (MOVZxL II8 (OpReg src_r) (OpReg src_r)) `appOL`+                         unitOL (POPCNT II16 (OpReg src_r) dst_r)+                     else+                         unitOL (POPCNT format (OpReg src_r) dst_r)) `appOL`+                    (if width == W8 || width == W16 then+                         -- We used a 16-bit destination register above,+                         -- so zero-extend+                         unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))+                     else nilOL)+        else do+            targetExpr <- cmmMakeDynamicReference dflags+                          CallReference lbl+            let target = ForeignTarget targetExpr (ForeignConvention CCallConv+                                                           [NoHint] [NoHint]+                                                           CmmMayReturn)+            genCCall dflags is32Bit target dest_regs args+  where+    format = intFormat width+    lbl = mkCmmCodeLabel primUnitId (fsLit (popCntLabel width))++genCCall dflags is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src]+  | is32Bit && width == W64 = do+    -- Fallback to `hs_clz64` on i386+    targetExpr <- cmmMakeDynamicReference dflags CallReference lbl+    let target = ForeignTarget targetExpr (ForeignConvention CCallConv+                                           [NoHint] [NoHint]+                                           CmmMayReturn)+    genCCall dflags is32Bit target dest_regs args++  | otherwise = do+    code_src <- getAnyReg src+    src_r <- getNewRegNat format+    tmp_r <- getNewRegNat format+    let dst_r = getRegisterReg platform False (CmmLocal dst)++    -- The following insn sequence makes sure 'clz 0' has a defined value.+    -- starting with Haswell, one could use the LZCNT insn instead.+    return $ code_src src_r `appOL` toOL+             ([ MOVZxL  II8    (OpReg src_r) (OpReg src_r) | width == W8 ] +++              [ BSR     format (OpReg src_r) tmp_r+              , MOV     II32   (OpImm (ImmInt (2*bw-1))) (OpReg dst_r)+              , CMOV NE format (OpReg tmp_r) dst_r+              , XOR     format (OpImm (ImmInt (bw-1))) (OpReg dst_r)+              ]) -- NB: We don't need to zero-extend the result for the+                 -- W8/W16 cases because the 'MOV' insn already+                 -- took care of implicitly clearing the upper bits+  where+    bw = widthInBits width+    platform = targetPlatform dflags+    format = if width == W8 then II16 else intFormat width+    lbl = mkCmmCodeLabel primUnitId (fsLit (clzLabel width))++genCCall dflags is32Bit (PrimTarget (MO_Ctz width)) [dst] [src]+  | is32Bit, width == W64 = do+      ChildCode64 vcode rlo <- iselExpr64 src+      let rhi     = getHiVRegFromLo rlo+          dst_r   = getRegisterReg platform False (CmmLocal dst)+      lbl1 <- getBlockIdNat+      lbl2 <- getBlockIdNat+      tmp_r <- getNewRegNat format++      -- The following instruction sequence corresponds to the pseudo-code+      --+      --  if (src) {+      --    dst = src.lo32 ? BSF(src.lo32) : (BSF(src.hi32) + 32);+      --  } else {+      --    dst = 64;+      --  }+      return $ vcode `appOL` toOL+               ([ MOV      II32 (OpReg rhi)         (OpReg tmp_r)+                , OR       II32 (OpReg rlo)         (OpReg tmp_r)+                , MOV      II32 (OpImm (ImmInt 64)) (OpReg dst_r)+                , JXX EQQ    lbl2+                , JXX ALWAYS lbl1++                , NEWBLOCK   lbl1+                , BSF     II32 (OpReg rhi)         dst_r+                , ADD     II32 (OpImm (ImmInt 32)) (OpReg dst_r)+                , BSF     II32 (OpReg rlo)         tmp_r+                , CMOV NE II32 (OpReg tmp_r)       dst_r+                , JXX ALWAYS lbl2++                , NEWBLOCK   lbl2+                ])++  | otherwise = do+    code_src <- getAnyReg src+    src_r <- getNewRegNat format+    tmp_r <- getNewRegNat format+    let dst_r = getRegisterReg platform False (CmmLocal dst)++    -- The following insn sequence makes sure 'ctz 0' has a defined value.+    -- starting with Haswell, one could use the TZCNT insn instead.+    return $ code_src src_r `appOL` toOL+             ([ MOVZxL  II8    (OpReg src_r) (OpReg src_r) | width == W8 ] +++              [ BSF     format (OpReg src_r) tmp_r+              , MOV     II32   (OpImm (ImmInt bw)) (OpReg dst_r)+              , CMOV NE format (OpReg tmp_r) dst_r+              ]) -- NB: We don't need to zero-extend the result for the+                 -- W8/W16 cases because the 'MOV' insn already+                 -- took care of implicitly clearing the upper bits+  where+    bw = widthInBits width+    platform = targetPlatform dflags+    format = if width == W8 then II16 else intFormat width++genCCall dflags is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args = do+    targetExpr <- cmmMakeDynamicReference dflags+                  CallReference lbl+    let target = ForeignTarget targetExpr (ForeignConvention CCallConv+                                           [NoHint] [NoHint]+                                           CmmMayReturn)+    genCCall dflags is32Bit target dest_regs args+  where+    lbl = mkCmmCodeLabel primUnitId (fsLit (word2FloatLabel width))++genCCall dflags is32Bit (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = do+    Amode amode addr_code <-+        if amop `elem` [AMO_Add, AMO_Sub]+        then getAmode addr+        else getSimpleAmode dflags is32Bit addr  -- See genCCall for MO_Cmpxchg+    arg <- getNewRegNat format+    arg_code <- getAnyReg n+    use_sse2 <- sse2Enabled+    let platform = targetPlatform dflags+        dst_r    = getRegisterReg platform use_sse2 (CmmLocal dst)+    code <- op_code dst_r arg amode+    return $ addr_code `appOL` arg_code arg `appOL` code+  where+    -- Code for the operation+    op_code :: Reg       -- Destination reg+            -> Reg       -- Register containing argument+            -> AddrMode  -- Address of location to mutate+            -> NatM (OrdList Instr)+    op_code dst_r arg amode = case amop of+        -- In the common case where dst_r is a virtual register the+        -- final move should go away, because it's the last use of arg+        -- and the first use of dst_r.+        AMO_Add  -> return $ toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode))+                                  , MOV format (OpReg arg) (OpReg dst_r)+                                  ]+        AMO_Sub  -> return $ toOL [ NEGI format (OpReg arg)+                                  , LOCK (XADD format (OpReg arg) (OpAddr amode))+                                  , MOV format (OpReg arg) (OpReg dst_r)+                                  ]+        AMO_And  -> cmpxchg_code (\ src dst -> unitOL $ AND format src dst)+        AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND format src dst+                                                    , NOT format dst+                                                    ])+        AMO_Or   -> cmpxchg_code (\ src dst -> unitOL $ OR format src dst)+        AMO_Xor  -> cmpxchg_code (\ src dst -> unitOL $ XOR format src dst)+      where+        -- Simulate operation that lacks a dedicated instruction using+        -- cmpxchg.+        cmpxchg_code :: (Operand -> Operand -> OrdList Instr)+                     -> NatM (OrdList Instr)+        cmpxchg_code instrs = do+            lbl <- getBlockIdNat+            tmp <- getNewRegNat format+            return $ toOL+                [ MOV format (OpAddr amode) (OpReg eax)+                , JXX ALWAYS lbl+                , NEWBLOCK lbl+                  -- Keep old value so we can return it:+                , MOV format (OpReg eax) (OpReg dst_r)+                , MOV format (OpReg eax) (OpReg tmp)+                ]+                `appOL` instrs (OpReg arg) (OpReg tmp) `appOL` toOL+                [ LOCK (CMPXCHG format (OpReg tmp) (OpAddr amode))+                , JXX NE lbl+                ]++    format = intFormat width++genCCall dflags _ (PrimTarget (MO_AtomicRead width)) [dst] [addr] = do+  load_code <- intLoadCode (MOV (intFormat width)) addr+  let platform = targetPlatform dflags+  use_sse2 <- sse2Enabled+  return (load_code (getRegisterReg platform use_sse2 (CmmLocal dst)))++genCCall _ _ (PrimTarget (MO_AtomicWrite width)) [] [addr, val] = do+    code <- assignMem_IntCode (intFormat width) addr val+    return $ code `snocOL` MFENCE++genCCall dflags is32Bit (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] = do+    -- On x86 we don't have enough registers to use cmpxchg with a+    -- complicated addressing mode, so on that architecture we+    -- pre-compute the address first.+    Amode amode addr_code <- getSimpleAmode dflags is32Bit addr+    newval <- getNewRegNat format+    newval_code <- getAnyReg new+    oldval <- getNewRegNat format+    oldval_code <- getAnyReg old+    use_sse2 <- sse2Enabled+    let platform = targetPlatform dflags+        dst_r    = getRegisterReg platform use_sse2 (CmmLocal dst)+        code     = toOL+                   [ MOV format (OpReg oldval) (OpReg eax)+                   , LOCK (CMPXCHG format (OpReg newval) (OpAddr amode))+                   , MOV format (OpReg eax) (OpReg dst_r)+                   ]+    return $ addr_code `appOL` newval_code newval `appOL` oldval_code oldval+        `appOL` code+  where+    format = intFormat width++genCCall _ is32Bit target dest_regs args = do+  dflags <- getDynFlags+  let platform = targetPlatform dflags+      sse2     = isSse2Enabled dflags+  case (target, dest_regs) of+    -- void return type prim op+    (PrimTarget op, []) ->+        outOfLineCmmOp op Nothing args+    -- we only cope with a single result for foreign calls+    (PrimTarget op, [r])+      | sse2 -> case op of+          MO_F32_Fabs -> case args of+            [x] -> sse2FabsCode W32 x+            _ -> panic "genCCall: Wrong number of arguments for fabs"+          MO_F64_Fabs -> case args of+            [x] -> sse2FabsCode W64 x+            _ -> panic "genCCall: Wrong number of arguments for fabs"+          _other_op -> outOfLineCmmOp op (Just r) args+      | otherwise -> do+        l1 <- getNewLabelNat+        l2 <- getNewLabelNat+        if sse2+          then+            outOfLineCmmOp op (Just r) args+          else case op of+              MO_F32_Sqrt -> actuallyInlineFloatOp GSQRT FF32 args+              MO_F64_Sqrt -> actuallyInlineFloatOp GSQRT FF64 args++              MO_F32_Sin  -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF32 args+              MO_F64_Sin  -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF64 args++              MO_F32_Cos  -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF32 args+              MO_F64_Cos  -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF64 args++              MO_F32_Tan  -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF32 args+              MO_F64_Tan  -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF64 args++              _other_op   -> outOfLineCmmOp op (Just r) args++       where+        actuallyInlineFloatOp instr format [x]+              = do res <- trivialUFCode format (instr format) x+                   any <- anyReg res+                   return (any (getRegisterReg platform False (CmmLocal r)))++        actuallyInlineFloatOp _ _ args+              = panic $ "genCCall.actuallyInlineFloatOp: bad number of arguments! ("+                      ++ show (length args) ++ ")"++        sse2FabsCode :: Width -> CmmExpr -> NatM InstrBlock+        sse2FabsCode w x = do+          let fmt = floatFormat w+          x_code <- getAnyReg x+          let+            const | FF32 <- fmt = CmmInt 0x7fffffff W32+                  | otherwise   = CmmInt 0x7fffffffffffffff W64+          Amode amode amode_code <- memConstant (widthInBytes w) const+          tmp <- getNewRegNat fmt+          let+            code dst = x_code dst `appOL` amode_code `appOL` toOL [+                MOV fmt (OpAddr amode) (OpReg tmp),+                AND fmt (OpReg tmp) (OpReg dst)+                ]++          return $ code (getRegisterReg platform True (CmmLocal r))++    (PrimTarget (MO_S_QuotRem  width), _) -> divOp1 platform True  width dest_regs args+    (PrimTarget (MO_U_QuotRem  width), _) -> divOp1 platform False width dest_regs args+    (PrimTarget (MO_U_QuotRem2 width), _) -> divOp2 platform False width dest_regs args+    (PrimTarget (MO_Add2 width), [res_h, res_l]) ->+        case args of+        [arg_x, arg_y] ->+            do hCode <- getAnyReg (CmmLit (CmmInt 0 width))+               let format = intFormat width+               lCode <- anyReg =<< trivialCode width (ADD_CC format)+                                     (Just (ADD_CC format)) arg_x arg_y+               let reg_l = getRegisterReg platform True (CmmLocal res_l)+                   reg_h = getRegisterReg platform True (CmmLocal res_h)+                   code = hCode reg_h `appOL`+                          lCode reg_l `snocOL`+                          ADC format (OpImm (ImmInteger 0)) (OpReg reg_h)+               return code+        _ -> panic "genCCall: Wrong number of arguments/results for add2"+    (PrimTarget (MO_SubWordC width), [res_r, res_c]) ->+        addSubIntC platform SUB_CC (const Nothing) CARRY width res_r res_c args+    (PrimTarget (MO_AddIntC width), [res_r, res_c]) ->+        addSubIntC platform ADD_CC (Just . ADD_CC) OFLO width res_r res_c args+    (PrimTarget (MO_SubIntC width), [res_r, res_c]) ->+        addSubIntC platform SUB_CC (const Nothing) OFLO width res_r res_c args+    (PrimTarget (MO_U_Mul2 width), [res_h, res_l]) ->+        case args of+        [arg_x, arg_y] ->+            do (y_reg, y_code) <- getRegOrMem arg_y+               x_code <- getAnyReg arg_x+               let format = intFormat width+                   reg_h = getRegisterReg platform True (CmmLocal res_h)+                   reg_l = getRegisterReg platform True (CmmLocal res_l)+                   code = y_code `appOL`+                          x_code rax `appOL`+                          toOL [MUL2 format y_reg,+                                MOV format (OpReg rdx) (OpReg reg_h),+                                MOV format (OpReg rax) (OpReg reg_l)]+               return code+        _ -> panic "genCCall: Wrong number of arguments/results for mul2"++    _ -> if is32Bit+         then genCCall32' dflags target dest_regs args+         else genCCall64' dflags target dest_regs args++  where divOp1 platform signed width results [arg_x, arg_y]+            = divOp platform signed width results Nothing arg_x arg_y+        divOp1 _ _ _ _ _+            = panic "genCCall: Wrong number of arguments for divOp1"+        divOp2 platform signed width results [arg_x_high, arg_x_low, arg_y]+            = divOp platform signed width results (Just arg_x_high) arg_x_low arg_y+        divOp2 _ _ _ _ _+            = panic "genCCall: Wrong number of arguments for divOp2"+        divOp platform signed width [res_q, res_r]+              m_arg_x_high arg_x_low arg_y+            = do let format = intFormat width+                     reg_q = getRegisterReg platform True (CmmLocal res_q)+                     reg_r = getRegisterReg platform True (CmmLocal res_r)+                     widen | signed    = CLTD format+                           | otherwise = XOR format (OpReg rdx) (OpReg rdx)+                     instr | signed    = IDIV+                           | otherwise = DIV+                 (y_reg, y_code) <- getRegOrMem arg_y+                 x_low_code <- getAnyReg arg_x_low+                 x_high_code <- case m_arg_x_high of+                                Just arg_x_high ->+                                    getAnyReg arg_x_high+                                Nothing ->+                                    return $ const $ unitOL widen+                 return $ y_code `appOL`+                          x_low_code rax `appOL`+                          x_high_code rdx `appOL`+                          toOL [instr format y_reg,+                                MOV format (OpReg rax) (OpReg reg_q),+                                MOV format (OpReg rdx) (OpReg reg_r)]+        divOp _ _ _ _ _ _ _+            = panic "genCCall: Wrong number of results for divOp"++        addSubIntC platform instr mrevinstr cond width+                   res_r res_c [arg_x, arg_y]+            = do let format = intFormat width+                 rCode <- anyReg =<< trivialCode width (instr format)+                                       (mrevinstr format) arg_x arg_y+                 reg_tmp <- getNewRegNat II8+                 let reg_c = getRegisterReg platform True (CmmLocal res_c)+                     reg_r = getRegisterReg platform True (CmmLocal res_r)+                     code = rCode reg_r `snocOL`+                            SETCC cond (OpReg reg_tmp) `snocOL`+                            MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)++                 return code+        addSubIntC _ _ _ _ _ _ _ _+            = panic "genCCall: Wrong number of arguments/results for addSubIntC"++genCCall32' :: DynFlags+            -> ForeignTarget            -- function to call+            -> [CmmFormal]        -- where to put the result+            -> [CmmActual]        -- arguments (of mixed type)+            -> NatM InstrBlock+genCCall32' dflags target dest_regs args = do+        let+            prom_args = map (maybePromoteCArg dflags W32) args++            -- Align stack to 16n for calls, assuming a starting stack+            -- alignment of 16n - word_size on procedure entry. Which we+            -- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86]+            sizes               = map (arg_size . cmmExprType dflags) (reverse args)+            raw_arg_size        = sum sizes + wORD_SIZE dflags+            arg_pad_size        = (roundTo 16 $ raw_arg_size) - raw_arg_size+            tot_arg_size        = raw_arg_size + arg_pad_size - wORD_SIZE dflags+        delta0 <- getDeltaNat+        setDeltaNat (delta0 - arg_pad_size)++        use_sse2 <- sse2Enabled+        push_codes <- mapM (push_arg use_sse2) (reverse prom_args)+        delta <- getDeltaNat+        MASSERT(delta == delta0 - tot_arg_size)++        -- deal with static vs dynamic call targets+        (callinsns,cconv) <-+          case target of+            ForeignTarget (CmmLit (CmmLabel lbl)) conv+               -> -- ToDo: stdcall arg sizes+                  return (unitOL (CALL (Left fn_imm) []), conv)+               where fn_imm = ImmCLbl lbl+            ForeignTarget expr conv+               -> do { (dyn_r, dyn_c) <- getSomeReg expr+                     ; ASSERT( isWord32 (cmmExprType dflags expr) )+                       return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) }+            PrimTarget _+                -> panic $ "genCCall: Can't handle PrimTarget call type here, error "+                            ++ "probably because too many return values."++        let push_code+                | arg_pad_size /= 0+                = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp),+                        DELTA (delta0 - arg_pad_size)]+                  `appOL` concatOL push_codes+                | otherwise+                = concatOL push_codes++              -- Deallocate parameters after call for ccall;+              -- but not for stdcall (callee does it)+              --+              -- We have to pop any stack padding we added+              -- even if we are doing stdcall, though (#5052)+            pop_size+               | ForeignConvention StdCallConv _ _ _ <- cconv = arg_pad_size+               | otherwise = tot_arg_size++            call = callinsns `appOL`+                   toOL (+                      (if pop_size==0 then [] else+                       [ADD II32 (OpImm (ImmInt pop_size)) (OpReg esp)])+                      +++                      [DELTA delta0]+                   )+        setDeltaNat delta0++        dflags <- getDynFlags+        let platform = targetPlatform dflags++        let+            -- assign the results, if necessary+            assign_code []     = nilOL+            assign_code [dest]+              | isFloatType ty =+                 if use_sse2+                    then let tmp_amode = AddrBaseIndex (EABaseReg esp)+                                                       EAIndexNone+                                                       (ImmInt 0)+                             fmt = floatFormat w+                         in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp),+                                   DELTA (delta0 - b),+                                   GST fmt fake0 tmp_amode,+                                   MOV fmt (OpAddr tmp_amode) (OpReg r_dest),+                                   ADD II32 (OpImm (ImmInt b)) (OpReg esp),+                                   DELTA delta0]+                    else unitOL (GMOV fake0 r_dest)+              | isWord64 ty    = toOL [MOV II32 (OpReg eax) (OpReg r_dest),+                                        MOV II32 (OpReg edx) (OpReg r_dest_hi)]+              | otherwise      = unitOL (MOV (intFormat w)+                                             (OpReg eax)+                                             (OpReg r_dest))+              where+                    ty = localRegType dest+                    w  = typeWidth ty+                    b  = widthInBytes w+                    r_dest_hi = getHiVRegFromLo r_dest+                    r_dest    = getRegisterReg platform use_sse2 (CmmLocal dest)+            assign_code many = pprPanic "genCCall.assign_code - too many return values:" (ppr many)++        return (push_code `appOL`+                call `appOL`+                assign_code dest_regs)++      where+        arg_size :: CmmType -> Int  -- Width in bytes+        arg_size ty = widthInBytes (typeWidth ty)++        roundTo a x | x `mod` a == 0 = x+                    | otherwise = x + a - (x `mod` a)++        push_arg :: Bool -> CmmActual {-current argument-}+                        -> NatM InstrBlock  -- code++        push_arg use_sse2 arg -- we don't need the hints on x86+          | isWord64 arg_ty = do+            ChildCode64 code r_lo <- iselExpr64 arg+            delta <- getDeltaNat+            setDeltaNat (delta - 8)+            let r_hi = getHiVRegFromLo r_lo+            return (       code `appOL`+                           toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4),+                                 PUSH II32 (OpReg r_lo), DELTA (delta - 8),+                                 DELTA (delta-8)]+                )++          | isFloatType arg_ty = do+            (reg, code) <- getSomeReg arg+            delta <- getDeltaNat+            setDeltaNat (delta-size)+            return (code `appOL`+                            toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp),+                                  DELTA (delta-size),+                                  let addr = AddrBaseIndex (EABaseReg esp)+                                                            EAIndexNone+                                                            (ImmInt 0)+                                      format = floatFormat (typeWidth arg_ty)+                                  in+                                  if use_sse2+                                     then MOV format (OpReg reg) (OpAddr addr)+                                     else GST format reg addr+                                 ]+                           )++          | otherwise = do+            (operand, code) <- getOperand arg+            delta <- getDeltaNat+            setDeltaNat (delta-size)+            return (code `snocOL`+                    PUSH II32 operand `snocOL`+                    DELTA (delta-size))++          where+             arg_ty = cmmExprType dflags arg+             size = arg_size arg_ty -- Byte size++genCCall64' :: DynFlags+            -> ForeignTarget      -- function to call+            -> [CmmFormal]        -- where to put the result+            -> [CmmActual]        -- arguments (of mixed type)+            -> NatM InstrBlock+genCCall64' dflags target dest_regs args = do+    -- load up the register arguments+    let prom_args = map (maybePromoteCArg dflags W32) args++    (stack_args, int_regs_used, fp_regs_used, load_args_code, assign_args_code)+         <-+        if platformOS platform == OSMinGW32+        then load_args_win prom_args [] [] (allArgRegs platform) nilOL+        else do+           (stack_args, aregs, fregs, load_args_code, assign_args_code)+               <- load_args prom_args (allIntArgRegs platform)+                                      (allFPArgRegs platform)+                                      nilOL nilOL+           let used_regs rs as = reverse (drop (length rs) (reverse as))+               fregs_used      = used_regs fregs (allFPArgRegs platform)+               aregs_used      = used_regs aregs (allIntArgRegs platform)+           return (stack_args, aregs_used, fregs_used, load_args_code+                                                      , assign_args_code)++    let+        arg_regs_used = int_regs_used ++ fp_regs_used+        arg_regs = [eax] ++ arg_regs_used+                -- for annotating the call instruction with+        sse_regs = length fp_regs_used+        arg_stack_slots = if platformOS platform == OSMinGW32+                          then length stack_args + length (allArgRegs platform)+                          else length stack_args+        tot_arg_size = arg_size * arg_stack_slots+++    -- Align stack to 16n for calls, assuming a starting stack+    -- alignment of 16n - word_size on procedure entry. Which we+    -- maintain. See Note [rts/StgCRun.c : Stack Alignment on X86]+    (real_size, adjust_rsp) <-+        if (tot_arg_size + wORD_SIZE dflags) `rem` 16 == 0+            then return (tot_arg_size, nilOL)+            else do -- we need to adjust...+                delta <- getDeltaNat+                setDeltaNat (delta - wORD_SIZE dflags)+                return (tot_arg_size + wORD_SIZE dflags, toOL [+                                SUB II64 (OpImm (ImmInt (wORD_SIZE dflags))) (OpReg rsp),+                                DELTA (delta - wORD_SIZE dflags) ])++    -- push the stack args, right to left+    push_code <- push_args (reverse stack_args) nilOL+    -- On Win64, we also have to leave stack space for the arguments+    -- that we are passing in registers+    lss_code <- if platformOS platform == OSMinGW32+                then leaveStackSpace (length (allArgRegs platform))+                else return nilOL+    delta <- getDeltaNat++    -- deal with static vs dynamic call targets+    (callinsns,_cconv) <-+      case target of+        ForeignTarget (CmmLit (CmmLabel lbl)) conv+           -> -- ToDo: stdcall arg sizes+              return (unitOL (CALL (Left fn_imm) arg_regs), conv)+           where fn_imm = ImmCLbl lbl+        ForeignTarget expr conv+           -> do (dyn_r, dyn_c) <- getSomeReg expr+                 return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv)+        PrimTarget _+            -> panic $ "genCCall: Can't handle PrimTarget call type here, error "+                        ++ "probably because too many return values."++    let+        -- The x86_64 ABI requires us to set %al to the number of SSE2+        -- registers that contain arguments, if the called routine+        -- is a varargs function.  We don't know whether it's a+        -- varargs function or not, so we have to assume it is.+        --+        -- It's not safe to omit this assignment, even if the number+        -- of SSE2 regs in use is zero.  If %al is larger than 8+        -- on entry to a varargs function, seg faults ensue.+        assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax))++    let call = callinsns `appOL`+               toOL (+                    -- Deallocate parameters after call for ccall;+                    -- stdcall has callee do it, but is not supported on+                    -- x86_64 target (see #3336)+                  (if real_size==0 then [] else+                   [ADD (intFormat (wordWidth dflags)) (OpImm (ImmInt real_size)) (OpReg esp)])+                  +++                  [DELTA (delta + real_size)]+               )+    setDeltaNat (delta + real_size)++    let+        -- assign the results, if necessary+        assign_code []     = nilOL+        assign_code [dest] =+          case typeWidth rep of+                W32 | isFloatType rep -> unitOL (MOV (floatFormat W32)+                                                     (OpReg xmm0)+                                                     (OpReg r_dest))+                W64 | isFloatType rep -> unitOL (MOV (floatFormat W64)+                                                     (OpReg xmm0)+                                                     (OpReg r_dest))+                _ -> unitOL (MOV (cmmTypeFormat rep) (OpReg rax) (OpReg r_dest))+          where+                rep = localRegType dest+                r_dest = getRegisterReg platform True (CmmLocal dest)+        assign_code _many = panic "genCCall.assign_code many"++    return (adjust_rsp          `appOL`+            push_code           `appOL`+            load_args_code      `appOL`+            assign_args_code    `appOL`+            lss_code            `appOL`+            assign_eax sse_regs `appOL`+            call                `appOL`+            assign_code dest_regs)++  where platform = targetPlatform dflags+        arg_size = 8 -- always, at the mo+++        load_args :: [CmmExpr]+                  -> [Reg]         -- int regs avail for args+                  -> [Reg]         -- FP regs avail for args+                  -> InstrBlock    -- code computing args+                  -> InstrBlock    -- code assigning args to ABI regs+                  -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock)+        -- no more regs to use+        load_args args [] [] code acode     =+            return (args, [], [], code, acode)++        -- no more args to push+        load_args [] aregs fregs code acode =+            return ([], aregs, fregs, code, acode)++        load_args (arg : rest) aregs fregs code acode+            | isFloatType arg_rep = case fregs of+                 []     -> push_this_arg+                 (r:rs) -> do+                    (code',acode') <- reg_this_arg r+                    load_args rest aregs rs code' acode'+            | otherwise           = case aregs of+                 []     -> push_this_arg+                 (r:rs) -> do+                    (code',acode') <- reg_this_arg r+                    load_args rest rs fregs code' acode'+            where++              -- put arg into the list of stack pushed args+              push_this_arg = do+                 (args',ars,frs,code',acode')+                     <- load_args rest aregs fregs code acode+                 return (arg:args', ars, frs, code', acode')++              -- pass the arg into the given register+              reg_this_arg r+                -- "operand" args can be directly assigned into r+                | isOperand False arg = do+                    arg_code <- getAnyReg arg+                    return (code, (acode `appOL` arg_code r))+                -- The last non-operand arg can be directly assigned after its+                -- computation without going into a temporary register+                | all (isOperand False) rest = do+                    arg_code   <- getAnyReg arg+                    return (code `appOL` arg_code r,acode)++                -- other args need to be computed beforehand to avoid clobbering+                -- previously assigned registers used to pass parameters (see+                -- #11792, #12614). They are assigned into temporary registers+                -- and get assigned to proper call ABI registers after they all+                -- have been computed.+                | otherwise     = do+                    arg_code <- getAnyReg arg+                    tmp      <- getNewRegNat arg_fmt+                    let+                      code'  = code `appOL` arg_code tmp+                      acode' = acode `snocOL` reg2reg arg_fmt tmp r+                    return (code',acode')++              arg_rep = cmmExprType dflags arg+              arg_fmt = cmmTypeFormat arg_rep++        load_args_win :: [CmmExpr]+                      -> [Reg]        -- used int regs+                      -> [Reg]        -- used FP regs+                      -> [(Reg, Reg)] -- (int, FP) regs avail for args+                      -> InstrBlock+                      -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock)+        load_args_win args usedInt usedFP [] code+            = return (args, usedInt, usedFP, code, nilOL)+            -- no more regs to use+        load_args_win [] usedInt usedFP _ code+            = return ([], usedInt, usedFP, code, nilOL)+            -- no more args to push+        load_args_win (arg : rest) usedInt usedFP+                      ((ireg, freg) : regs) code+            | isFloatType arg_rep = do+                 arg_code <- getAnyReg arg+                 load_args_win rest (ireg : usedInt) (freg : usedFP) regs+                               (code `appOL`+                                arg_code freg `snocOL`+                                -- If we are calling a varargs function+                                -- then we need to define ireg as well+                                -- as freg+                                MOV II64 (OpReg freg) (OpReg ireg))+            | otherwise = do+                 arg_code <- getAnyReg arg+                 load_args_win rest (ireg : usedInt) usedFP regs+                               (code `appOL` arg_code ireg)+            where+              arg_rep = cmmExprType dflags arg++        push_args [] code = return code+        push_args (arg:rest) code+           | isFloatType arg_rep = do+             (arg_reg, arg_code) <- getSomeReg arg+             delta <- getDeltaNat+             setDeltaNat (delta-arg_size)+             let code' = code `appOL` arg_code `appOL` toOL [+                            SUB (intFormat (wordWidth dflags)) (OpImm (ImmInt arg_size)) (OpReg rsp),+                            DELTA (delta-arg_size),+                            MOV (floatFormat width) (OpReg arg_reg) (OpAddr (spRel dflags 0))]+             push_args rest code'++           | otherwise = do+             ASSERT(width == W64) return ()+             (arg_op, arg_code) <- getOperand arg+             delta <- getDeltaNat+             setDeltaNat (delta-arg_size)+             let code' = code `appOL` arg_code `appOL` toOL [+                                    PUSH II64 arg_op,+                                    DELTA (delta-arg_size)]+             push_args rest code'+            where+              arg_rep = cmmExprType dflags arg+              width = typeWidth arg_rep++        leaveStackSpace n = do+             delta <- getDeltaNat+             setDeltaNat (delta - n * arg_size)+             return $ toOL [+                         SUB II64 (OpImm (ImmInt (n * wORD_SIZE dflags))) (OpReg rsp),+                         DELTA (delta - n * arg_size)]++maybePromoteCArg :: DynFlags -> Width -> CmmExpr -> CmmExpr+maybePromoteCArg dflags wto arg+ | wfrom < wto = CmmMachOp (MO_UU_Conv wfrom wto) [arg]+ | otherwise   = arg+ where+   wfrom = cmmExprWidth dflags arg++outOfLineCmmOp :: CallishMachOp -> Maybe CmmFormal -> [CmmActual] -> NatM InstrBlock+outOfLineCmmOp mop res args+  = do+      dflags <- getDynFlags+      targetExpr <- cmmMakeDynamicReference dflags CallReference lbl+      let target = ForeignTarget targetExpr+                           (ForeignConvention CCallConv [] [] CmmMayReturn)++      stmtToInstrs (CmmUnsafeForeignCall target (catMaybes [res]) args)+  where+        -- Assume we can call these functions directly, and that they're not in a dynamic library.+        -- TODO: Why is this ok? Under linux this code will be in libm.so+        --       Is it because they're really implemented as a primitive instruction by the assembler??  -- BL 2009/12/31+        lbl = mkForeignLabel fn Nothing ForeignLabelInThisPackage IsFunction++        fn = case mop of+              MO_F32_Sqrt  -> fsLit "sqrtf"+              MO_F32_Fabs  -> fsLit "fabsf"+              MO_F32_Sin   -> fsLit "sinf"+              MO_F32_Cos   -> fsLit "cosf"+              MO_F32_Tan   -> fsLit "tanf"+              MO_F32_Exp   -> fsLit "expf"+              MO_F32_Log   -> fsLit "logf"++              MO_F32_Asin  -> fsLit "asinf"+              MO_F32_Acos  -> fsLit "acosf"+              MO_F32_Atan  -> fsLit "atanf"++              MO_F32_Sinh  -> fsLit "sinhf"+              MO_F32_Cosh  -> fsLit "coshf"+              MO_F32_Tanh  -> fsLit "tanhf"+              MO_F32_Pwr   -> fsLit "powf"++              MO_F64_Sqrt  -> fsLit "sqrt"+              MO_F64_Fabs  -> fsLit "fabs"+              MO_F64_Sin   -> fsLit "sin"+              MO_F64_Cos   -> fsLit "cos"+              MO_F64_Tan   -> fsLit "tan"+              MO_F64_Exp   -> fsLit "exp"+              MO_F64_Log   -> fsLit "log"++              MO_F64_Asin  -> fsLit "asin"+              MO_F64_Acos  -> fsLit "acos"+              MO_F64_Atan  -> fsLit "atan"++              MO_F64_Sinh  -> fsLit "sinh"+              MO_F64_Cosh  -> fsLit "cosh"+              MO_F64_Tanh  -> fsLit "tanh"+              MO_F64_Pwr   -> fsLit "pow"++              MO_Memcpy _  -> fsLit "memcpy"+              MO_Memset _  -> fsLit "memset"+              MO_Memmove _ -> fsLit "memmove"++              MO_PopCnt _  -> fsLit "popcnt"+              MO_BSwap _   -> fsLit "bswap"+              MO_Clz w     -> fsLit $ clzLabel w+              MO_Ctz _     -> unsupported++              MO_AtomicRMW _ _ -> fsLit "atomicrmw"+              MO_AtomicRead _  -> fsLit "atomicread"+              MO_AtomicWrite _ -> fsLit "atomicwrite"+              MO_Cmpxchg _     -> fsLit "cmpxchg"++              MO_UF_Conv _ -> unsupported++              MO_S_QuotRem {}  -> unsupported+              MO_U_QuotRem {}  -> unsupported+              MO_U_QuotRem2 {} -> unsupported+              MO_Add2 {}       -> unsupported+              MO_AddIntC {}    -> unsupported+              MO_SubIntC {}    -> unsupported+              MO_SubWordC {}   -> unsupported+              MO_U_Mul2 {}     -> unsupported+              MO_WriteBarrier  -> unsupported+              MO_Touch         -> unsupported+              (MO_Prefetch_Data _ ) -> unsupported+        unsupported = panic ("outOfLineCmmOp: " ++ show mop+                          ++ " not supported here")++-- -----------------------------------------------------------------------------+-- Generating a table-branch++genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock++genSwitch dflags expr targets+  | gopt Opt_PIC dflags+  = do+        (reg,e_code) <- getNonClobberedReg (cmmOffset dflags expr offset)+           -- getNonClobberedReg because it needs to survive across t_code+        lbl <- getNewLabelNat+        dflags <- getDynFlags+        let is32bit = target32Bit (targetPlatform dflags)+            os = platformOS (targetPlatform dflags)+            -- Might want to use .rodata.<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 dflags DataReference lbl+        (tableReg,t_code) <- getSomeReg $ dynRef+        let op = OpAddr (AddrBaseIndex (EABaseReg tableReg)+                                       (EAIndex reg (wORD_SIZE dflags)) (ImmInt 0))++        offsetReg <- getNewRegNat (intFormat (wordWidth dflags))+        return $ if is32bit || os == OSDarwin+                 then e_code `appOL` t_code `appOL` toOL [+                                ADD (intFormat (wordWidth dflags)) op (OpReg tableReg),+                                JMP_TBL (OpReg tableReg) ids rosection lbl+                       ]+                 else -- HACK: On x86_64 binutils<2.17 is only able to generate+                      -- PC32 relocations, hence we only get 32-bit offsets in+                      -- the jump table. As these offsets are always negative+                      -- we need to properly sign extend them to 64-bit. This+                      -- hack should be removed in conjunction with the hack in+                      -- PprMach.hs/pprDataItem once binutils 2.17 is standard.+                      e_code `appOL` t_code `appOL` toOL [+                               MOVSxL II32 op (OpReg offsetReg),+                               ADD (intFormat (wordWidth dflags))+                                   (OpReg offsetReg)+                                   (OpReg tableReg),+                               JMP_TBL (OpReg tableReg) ids rosection lbl+                       ]+  | otherwise+  = do+        (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)+        lbl <- getNewLabelNat+        let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (wORD_SIZE dflags)) (ImmCLbl lbl))+            code = e_code `appOL` toOL [+                    JMP_TBL op ids (Section ReadOnlyData lbl) lbl+                 ]+        return code+  where (offset, ids) = switchTargetsToTable targets++generateJumpTableForInstr :: DynFlags -> Instr -> Maybe (NatCmmDecl (Alignment, CmmStatics) Instr)+generateJumpTableForInstr dflags (JMP_TBL _ ids section lbl)+    = Just (createJumpTable dflags ids section lbl)+generateJumpTableForInstr _ _ = Nothing++createJumpTable :: DynFlags -> [Maybe BlockId] -> Section -> CLabel+                -> GenCmmDecl (Alignment, CmmStatics) h g+createJumpTable dflags ids section lbl+    = let jumpTable+            | gopt Opt_PIC dflags =+                  let jumpTableEntryRel Nothing+                          = CmmStaticLit (CmmInt 0 (wordWidth dflags))+                      jumpTableEntryRel (Just blockid)+                          = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)+                          where blockLabel = mkAsmTempLabel (getUnique blockid)+                  in map jumpTableEntryRel ids+            | otherwise = map (jumpTableEntry dflags) ids+      in CmmData section (1, Statics lbl jumpTable)++extractUnwindPoints :: [Instr] -> [UnwindPoint]+extractUnwindPoints instrs =+    [ UnwindPoint lbl unwinds | UNWIND lbl unwinds <- instrs]++-- -----------------------------------------------------------------------------+-- 'condIntReg' and 'condFltReg': condition codes into registers++-- Turn those condition codes into integers now (when they appear on+-- the right hand side of an assignment).+--+-- (If applicable) Do not fill the delay slots here; you will confuse the+-- register allocator.++condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register++condIntReg cond x y = do+  CondCode _ cond cond_code <- condIntCode cond x y+  tmp <- getNewRegNat II8+  let+        code dst = cond_code `appOL` toOL [+                    SETCC cond (OpReg tmp),+                    MOVZxL II8 (OpReg tmp) (OpReg dst)+                  ]+  return (Any II32 code)++++condFltReg :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM Register+condFltReg is32Bit cond x y = if_sse2 condFltReg_sse2 condFltReg_x87+ where+  condFltReg_x87 = do+    CondCode _ cond cond_code <- condFltCode cond x y+    tmp <- getNewRegNat II8+    let+        code dst = cond_code `appOL` toOL [+                    SETCC cond (OpReg tmp),+                    MOVZxL II8 (OpReg tmp) (OpReg dst)+                  ]+    return (Any II32 code)++  condFltReg_sse2 = do+    CondCode _ cond cond_code <- condFltCode cond x y+    tmp1 <- getNewRegNat (archWordFormat is32Bit)+    tmp2 <- getNewRegNat (archWordFormat is32Bit)+    let+        -- We have to worry about unordered operands (eg. comparisons+        -- against NaN).  If the operands are unordered, the comparison+        -- sets the parity flag, carry flag and zero flag.+        -- All comparisons are supposed to return false for unordered+        -- operands except for !=, which returns true.+        --+        -- Optimisation: we don't have to test the parity flag if we+        -- know the test has already excluded the unordered case: eg >+        -- and >= test for a zero carry flag, which can only occur for+        -- ordered operands.+        --+        -- ToDo: by reversing comparisons we could avoid testing the+        -- parity flag in more cases.++        code dst =+           cond_code `appOL`+             (case cond of+                NE  -> or_unordered dst+                GU  -> plain_test   dst+                GEU -> plain_test   dst+                _   -> and_ordered  dst)++        plain_test dst = toOL [+                    SETCC cond (OpReg tmp1),+                    MOVZxL II8 (OpReg tmp1) (OpReg dst)+                 ]+        or_unordered dst = toOL [+                    SETCC cond (OpReg tmp1),+                    SETCC PARITY (OpReg tmp2),+                    OR II8 (OpReg tmp1) (OpReg tmp2),+                    MOVZxL II8 (OpReg tmp2) (OpReg dst)+                  ]+        and_ordered dst = toOL [+                    SETCC cond (OpReg tmp1),+                    SETCC NOTPARITY (OpReg tmp2),+                    AND II8 (OpReg tmp1) (OpReg tmp2),+                    MOVZxL II8 (OpReg tmp2) (OpReg dst)+                  ]+    return (Any II32 code)+++-- -----------------------------------------------------------------------------+-- 'trivial*Code': deal with trivial instructions++-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',+-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.+-- Only look for constants on the right hand side, because that's+-- where the generic optimizer will have put them.++-- Similarly, for unary instructions, we don't have to worry about+-- matching an StInt as the argument, because genericOpt will already+-- have handled the constant-folding.+++{-+The Rules of the Game are:++* You cannot assume anything about the destination register dst;+  it may be anything, including a fixed reg.++* You may compute an operand into a fixed reg, but you may not+  subsequently change the contents of that fixed reg.  If you+  want to do so, first copy the value either to a temporary+  or into dst.  You are free to modify dst even if it happens+  to be a fixed reg -- that's not your problem.++* You cannot assume that a fixed reg will stay live over an+  arbitrary computation.  The same applies to the dst reg.++* Temporary regs obtained from getNewRegNat are distinct from+  each other and from all other regs, and stay live over+  arbitrary computations.++--------------------++SDM's version of The Rules:++* If getRegister returns Any, that means it can generate correct+  code which places the result in any register, period.  Even if that+  register happens to be read during the computation.++  Corollary #1: this means that if you are generating code for an+  operation with two arbitrary operands, you cannot assign the result+  of the first operand into the destination register before computing+  the second operand.  The second operand might require the old value+  of the destination register.++  Corollary #2: A function might be able to generate more efficient+  code if it knows the destination register is a new temporary (and+  therefore not read by any of the sub-computations).++* If getRegister returns Any, then the code it generates may modify only:+        (a) fresh temporaries+        (b) the destination register+        (c) known registers (eg. %ecx is used by shifts)+  In particular, it may *not* modify global registers, unless the global+  register happens to be the destination register.+-}++trivialCode :: Width -> (Operand -> Operand -> Instr)+            -> Maybe (Operand -> Operand -> Instr)+            -> CmmExpr -> CmmExpr -> NatM Register+trivialCode width instr m a b+    = do is32Bit <- is32BitPlatform+         trivialCode' is32Bit width instr m a b++trivialCode' :: Bool -> Width -> (Operand -> Operand -> Instr)+             -> Maybe (Operand -> Operand -> Instr)+             -> CmmExpr -> CmmExpr -> NatM Register+trivialCode' is32Bit width _ (Just revinstr) (CmmLit lit_a) b+  | is32BitLit is32Bit lit_a = do+  b_code <- getAnyReg b+  let+       code dst+         = b_code dst `snocOL`+           revinstr (OpImm (litToImm lit_a)) (OpReg dst)+  return (Any (intFormat width) code)++trivialCode' _ width instr _ a b+  = genTrivialCode (intFormat width) instr a b++-- This is re-used for floating pt instructions too.+genTrivialCode :: Format -> (Operand -> Operand -> Instr)+               -> CmmExpr -> CmmExpr -> NatM Register+genTrivialCode rep instr a b = do+  (b_op, b_code) <- getNonClobberedOperand b+  a_code <- getAnyReg a+  tmp <- getNewRegNat rep+  let+     -- We want the value of b to stay alive across the computation of a.+     -- But, we want to calculate a straight into the destination register,+     -- because the instruction only has two operands (dst := dst `op` src).+     -- The troublesome case is when the result of b is in the same register+     -- as the destination reg.  In this case, we have to save b in a+     -- new temporary across the computation of a.+     code dst+        | dst `regClashesWithOp` b_op =+                b_code `appOL`+                unitOL (MOV rep b_op (OpReg tmp)) `appOL`+                a_code dst `snocOL`+                instr (OpReg tmp) (OpReg dst)+        | otherwise =+                b_code `appOL`+                a_code dst `snocOL`+                instr b_op (OpReg dst)+  return (Any rep code)++regClashesWithOp :: Reg -> Operand -> Bool+reg `regClashesWithOp` OpReg reg2   = reg == reg2+reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode)+_   `regClashesWithOp` _            = False++-----------++trivialUCode :: Format -> (Operand -> Instr)+             -> CmmExpr -> NatM Register+trivialUCode rep instr x = do+  x_code <- getAnyReg x+  let+     code dst =+        x_code dst `snocOL`+        instr (OpReg dst)+  return (Any rep code)++-----------++trivialFCode_x87 :: (Format -> Reg -> Reg -> Reg -> Instr)+                 -> CmmExpr -> CmmExpr -> NatM Register+trivialFCode_x87 instr x y = do+  (x_reg, x_code) <- getNonClobberedReg x -- these work for float regs too+  (y_reg, y_code) <- getSomeReg y+  let+     format = FF80 -- always, on x87+     code dst =+        x_code `appOL`+        y_code `snocOL`+        instr format x_reg y_reg dst+  return (Any format code)++trivialFCode_sse2 :: Width -> (Format -> Operand -> Operand -> Instr)+                  -> CmmExpr -> CmmExpr -> NatM Register+trivialFCode_sse2 pk instr x y+    = genTrivialCode format (instr format) x y+    where format = floatFormat pk+++trivialUFCode :: Format -> (Reg -> Reg -> Instr) -> CmmExpr -> NatM Register+trivialUFCode format instr x = do+  (x_reg, x_code) <- getSomeReg x+  let+     code dst =+        x_code `snocOL`+        instr x_reg dst+  return (Any format code)+++--------------------------------------------------------------------------------+coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register+coerceInt2FP from to x = if_sse2 coerce_sse2 coerce_x87+ where+   coerce_x87 = do+     (x_reg, x_code) <- getSomeReg x+     let+           opc  = case to of W32 -> GITOF; W64 -> GITOD;+                             n -> panic $ "coerceInt2FP.x87: unhandled width ("+                                         ++ show n ++ ")"+           code dst = x_code `snocOL` opc x_reg dst+        -- ToDo: works for non-II32 reps?+     return (Any FF80 code)++   coerce_sse2 = do+     (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand+     let+           opc  = case to of W32 -> CVTSI2SS; W64 -> CVTSI2SD+                             n -> panic $ "coerceInt2FP.sse: unhandled width ("+                                         ++ show n ++ ")"+           code dst = x_code `snocOL` opc (intFormat from) x_op dst+     return (Any (floatFormat to) code)+        -- works even if the destination rep is <II32++--------------------------------------------------------------------------------+coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register+coerceFP2Int from to x = if_sse2 coerceFP2Int_sse2 coerceFP2Int_x87+ where+   coerceFP2Int_x87 = do+     (x_reg, x_code) <- getSomeReg x+     let+           opc  = case from of W32 -> GFTOI; W64 -> GDTOI+                               n -> panic $ "coerceFP2Int.x87: unhandled width ("+                                           ++ show n ++ ")"+           code dst = x_code `snocOL` opc x_reg dst+        -- ToDo: works for non-II32 reps?+     return (Any (intFormat to) code)++   coerceFP2Int_sse2 = do+     (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand+     let+           opc  = case from of W32 -> CVTTSS2SIQ; W64 -> CVTTSD2SIQ;+                               n -> panic $ "coerceFP2Init.sse: unhandled width ("+                                           ++ show n ++ ")"+           code dst = x_code `snocOL` opc (intFormat to) x_op dst+     return (Any (intFormat to) code)+         -- works even if the destination rep is <II32+++--------------------------------------------------------------------------------+coerceFP2FP :: Width -> CmmExpr -> NatM Register+coerceFP2FP to x = do+  use_sse2 <- sse2Enabled+  (x_reg, x_code) <- getSomeReg x+  let+        opc | use_sse2  = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD;+                                     n -> panic $ "coerceFP2FP: unhandled width ("+                                                 ++ show n ++ ")"+            | otherwise = GDTOF+        code dst = x_code `snocOL` opc x_reg dst+  return (Any (if use_sse2 then floatFormat to else FF80) code)++--------------------------------------------------------------------------------++sse2NegCode :: Width -> CmmExpr -> NatM Register+sse2NegCode w x = do+  let fmt = floatFormat w+  x_code <- getAnyReg x+  -- This is how gcc does it, so it can't be that bad:+  let+    const = case fmt of+      FF32 -> CmmInt 0x80000000 W32+      FF64 -> CmmInt 0x8000000000000000 W64+      x@II8  -> wrongFmt x+      x@II16 -> wrongFmt x+      x@II32 -> wrongFmt x+      x@II64 -> wrongFmt x+      x@FF80 -> wrongFmt x+      where+        wrongFmt x = panic $ "sse2NegCode: " ++ show x+  Amode amode amode_code <- memConstant (widthInBytes w) const+  tmp <- getNewRegNat fmt+  let+    code dst = x_code dst `appOL` amode_code `appOL` toOL [+        MOV fmt (OpAddr amode) (OpReg tmp),+        XOR fmt (OpReg tmp) (OpReg dst)+        ]+  --+  return (Any fmt code)++isVecExpr :: CmmExpr -> Bool+isVecExpr (CmmMachOp (MO_V_Insert {}) _)   = True+isVecExpr (CmmMachOp (MO_V_Extract {}) _)  = True+isVecExpr (CmmMachOp (MO_V_Add {}) _)      = True+isVecExpr (CmmMachOp (MO_V_Sub {}) _)      = True+isVecExpr (CmmMachOp (MO_V_Mul {}) _)      = True+isVecExpr (CmmMachOp (MO_VS_Quot {}) _)    = True+isVecExpr (CmmMachOp (MO_VS_Rem {}) _)     = True+isVecExpr (CmmMachOp (MO_VS_Neg {}) _)     = True+isVecExpr (CmmMachOp (MO_VF_Insert {}) _)  = True+isVecExpr (CmmMachOp (MO_VF_Extract {}) _) = True+isVecExpr (CmmMachOp (MO_VF_Add {}) _)     = True+isVecExpr (CmmMachOp (MO_VF_Sub {}) _)     = True+isVecExpr (CmmMachOp (MO_VF_Mul {}) _)     = True+isVecExpr (CmmMachOp (MO_VF_Quot {}) _)    = True+isVecExpr (CmmMachOp (MO_VF_Neg {}) _)     = True+isVecExpr (CmmMachOp _ [e])                = isVecExpr e+isVecExpr _                                = False++needLlvm :: NatM a+needLlvm =+    sorry $ unlines ["The native code generator does not support vector"+                    ,"instructions. Please use -fllvm."]
+ nativeGen/X86/Cond.hs view
@@ -0,0 +1,68 @@+module X86.Cond (+        Cond(..),+        condUnsigned,+        condToSigned,+        condToUnsigned,+        maybeFlipCond+)++where++data Cond+        = ALWAYS        -- What's really used? ToDo+        | EQQ+        | GE+        | GEU+        | GTT+        | GU+        | LE+        | LEU+        | LTT+        | LU+        | NE+        | NEG+        | POS+        | CARRY+        | OFLO+        | PARITY+        | NOTPARITY+        deriving Eq++condUnsigned :: Cond -> Bool+condUnsigned GU  = True+condUnsigned LU  = True+condUnsigned GEU = True+condUnsigned LEU = True+condUnsigned _   = False+++condToSigned :: Cond -> Cond+condToSigned GU  = GTT+condToSigned LU  = LTT+condToSigned GEU = GE+condToSigned LEU = LE+condToSigned x   = x+++condToUnsigned :: Cond -> Cond+condToUnsigned GTT = GU+condToUnsigned LTT = LU+condToUnsigned GE  = GEU+condToUnsigned LE  = LEU+condToUnsigned x   = x++-- | @maybeFlipCond c@ returns @Just c'@ if it is possible to flip the+-- arguments to the conditional @c@, and the new condition should be @c'@.+maybeFlipCond :: Cond -> Maybe Cond+maybeFlipCond cond  = case cond of+        EQQ   -> Just EQQ+        NE    -> Just NE+        LU    -> Just GU+        GU    -> Just LU+        LEU   -> Just GEU+        GEU   -> Just LEU+        LTT   -> Just GTT+        GTT   -> Just LTT+        LE    -> Just GE+        GE    -> Just LE+        _other -> Nothing
+ nativeGen/X86/Instr.hs view
@@ -0,0 +1,1059 @@+{-# LANGUAGE CPP, TypeFamilies #-}++-----------------------------------------------------------------------------+--+-- Machine-dependent assembly language+--+-- (c) The University of Glasgow 1993-2004+--+-----------------------------------------------------------------------------++module X86.Instr (Instr(..), Operand(..), PrefetchVariant(..), JumpDest,+                  getJumpDestBlockId, canShortcut, shortcutStatics,+                  shortcutJump, i386_insert_ffrees, allocMoreStack,+                  maxSpillSlots, archWordFormat)+where++#include "HsVersions.h"+#include "nativeGen/NCG.h"++import X86.Cond+import X86.Regs+import Instruction+import Format+import RegClass+import Reg+import TargetReg++import BlockId+import Hoopl+import CodeGen.Platform+import Cmm+import FastString+import Outputable+import Platform++import BasicTypes       (Alignment)+import CLabel+import DynFlags+import UniqSet+import Unique+import UniqSupply+import Debug (UnwindTable)++import Control.Monad+import Data.Maybe       (fromMaybe)++-- Format of an x86/x86_64 memory address, in bytes.+--+archWordFormat :: Bool -> Format+archWordFormat is32Bit+ | is32Bit   = II32+ | otherwise = II64++-- | Instruction instance for x86 instruction set.+instance Instruction Instr where+        regUsageOfInstr         = x86_regUsageOfInstr+        patchRegsOfInstr        = x86_patchRegsOfInstr+        isJumpishInstr          = x86_isJumpishInstr+        jumpDestsOfInstr        = x86_jumpDestsOfInstr+        patchJumpInstr          = x86_patchJumpInstr+        mkSpillInstr            = x86_mkSpillInstr+        mkLoadInstr             = x86_mkLoadInstr+        takeDeltaInstr          = x86_takeDeltaInstr+        isMetaInstr             = x86_isMetaInstr+        mkRegRegMoveInstr       = x86_mkRegRegMoveInstr+        takeRegRegMoveInstr     = x86_takeRegRegMoveInstr+        mkJumpInstr             = x86_mkJumpInstr+        mkStackAllocInstr       = x86_mkStackAllocInstr+        mkStackDeallocInstr     = x86_mkStackDeallocInstr+++-- -----------------------------------------------------------------------------+-- Intel x86 instructions++{-+Intel, in their infinite wisdom, selected a stack model for floating+point registers on x86.  That might have made sense back in 1979 --+nowadays we can see it for the nonsense it really is.  A stack model+fits poorly with the existing nativeGen infrastructure, which assumes+flat integer and FP register sets.  Prior to this commit, nativeGen+could not generate correct x86 FP code -- to do so would have meant+somehow working the register-stack paradigm into the register+allocator and spiller, which sounds very difficult.++We have decided to cheat, and go for a simple fix which requires no+infrastructure modifications, at the expense of generating ropey but+correct FP code.  All notions of the x86 FP stack and its insns have+been removed.  Instead, we pretend (to the instruction selector and+register allocator) that x86 has six floating point registers, %fake0+.. %fake5, which can be used in the usual flat manner.  We further+claim that x86 has floating point instructions very similar to SPARC+and Alpha, that is, a simple 3-operand register-register arrangement.+Code generation and register allocation proceed on this basis.++When we come to print out the final assembly, our convenient fiction+is converted to dismal reality.  Each fake instruction is+independently converted to a series of real x86 instructions.+%fake0 .. %fake5 are mapped to %st(0) .. %st(5).  To do reg-reg+arithmetic operations, the two operands are pushed onto the top of the+FP stack, the operation done, and the result copied back into the+relevant register.  There are only six %fake registers because 2 are+needed for the translation, and x86 has 8 in total.++The translation is inefficient but is simple and it works.  A cleverer+translation would handle a sequence of insns, simulating the FP stack+contents, would not impose a fixed mapping from %fake to %st regs, and+hopefully could avoid most of the redundant reg-reg moves of the+current translation.++We might as well make use of whatever unique FP facilities Intel have+chosen to bless us with (let's not be churlish, after all).+Hence GLDZ and GLD1.  Bwahahahahahahaha!+-}++{-+Note [x86 Floating point precision]++Intel's internal floating point registers are by default 80 bit+extended precision.  This means that all operations done on values in+registers are done at 80 bits, and unless the intermediate values are+truncated to the appropriate size (32 or 64 bits) by storing in+memory, calculations in registers will give different results from+calculations which pass intermediate values in memory (eg. via+function calls).++One solution is to set the FPU into 64 bit precision mode.  Some OSs+do this (eg. FreeBSD) and some don't (eg. Linux).  The problem here is+that this will only affect 64-bit precision arithmetic; 32-bit+calculations will still be done at 64-bit precision in registers.  So+it doesn't solve the whole problem.++There's also the issue of what the C library is expecting in terms of+precision.  It seems to be the case that glibc on Linux expects the+FPU to be set to 80 bit precision, so setting it to 64 bit could have+unexpected effects.  Changing the default could have undesirable+effects on other 3rd-party library code too, so the right thing would+be to save/restore the FPU control word across Haskell code if we were+to do this.++gcc's -ffloat-store gives consistent results by always storing the+results of floating-point calculations in memory, which works for both+32 and 64-bit precision.  However, it only affects the values of+user-declared floating point variables in C, not intermediate results.+GHC in -fvia-C mode uses -ffloat-store (see the -fexcess-precision+flag).++Another problem is how to spill floating point registers in the+register allocator.  Should we spill the whole 80 bits, or just 64?+On an OS which is set to 64 bit precision, spilling 64 is fine.  On+Linux, spilling 64 bits will round the results of some operations.+This is what gcc does.  Spilling at 80 bits requires taking up a full+128 bit slot (so we get alignment).  We spill at 80-bits and ignore+the alignment problems.++In the future [edit: now available in GHC 7.0.1, with the -msse2+flag], we'll use the SSE registers for floating point.  This requires+a CPU that supports SSE2 (ordinary SSE only supports 32 bit precision+float ops), which means P4 or Xeon and above.  Using SSE will solve+all these problems, because the SSE registers use fixed 32 bit or 64+bit precision.++--SDM 1/2003+-}++data Instr+        -- comment pseudo-op+        = COMMENT FastString++        -- location pseudo-op (file, line, col, name)+        | LOCATION Int Int Int String++        -- some static data spat out during code+        -- generation.  Will be extracted before+        -- pretty-printing.+        | LDATA   Section (Alignment, CmmStatics)++        -- start a new basic block.  Useful during+        -- codegen, removed later.  Preceding+        -- instruction should be a jump, as per the+        -- invariants for a BasicBlock (see Cmm).+        | NEWBLOCK BlockId++        -- unwinding information+        -- See Note [Unwinding information in the NCG].+        | UNWIND CLabel UnwindTable++        -- specify current stack offset for benefit of subsequent passes.+        -- This carries a BlockId so it can be used in unwinding information.+        | DELTA  Int++        -- Moves.+        | MOV         Format Operand Operand+        | CMOV   Cond Format Operand Reg+        | MOVZxL      Format Operand Operand -- format is the size of operand 1+        | MOVSxL      Format Operand Operand -- format is the size of operand 1+        -- x86_64 note: plain mov into a 32-bit register always zero-extends+        -- into the 64-bit reg, in contrast to the 8 and 16-bit movs which+        -- don't affect the high bits of the register.++        -- Load effective address (also a very useful three-operand add instruction :-)+        | LEA         Format Operand Operand++        -- Int Arithmetic.+        | ADD         Format Operand Operand+        | ADC         Format Operand Operand+        | SUB         Format Operand Operand+        | SBB         Format Operand Operand++        | MUL         Format Operand Operand+        | MUL2        Format Operand         -- %edx:%eax = operand * %rax+        | IMUL        Format Operand Operand -- signed int mul+        | IMUL2       Format Operand         -- %edx:%eax = operand * %eax++        | DIV         Format Operand         -- eax := eax:edx/op, edx := eax:edx%op+        | IDIV        Format Operand         -- ditto, but signed++        -- Int Arithmetic, where the effects on the condition register+        -- are important. Used in specialized sequences such as MO_Add2.+        -- Do not rewrite these instructions to "equivalent" ones that+        -- have different effect on the condition register! (See #9013.)+        | ADD_CC      Format Operand Operand+        | SUB_CC      Format Operand Operand++        -- Simple bit-twiddling.+        | AND         Format Operand Operand+        | OR          Format Operand Operand+        | XOR         Format Operand Operand+        | NOT         Format Operand+        | NEGI        Format Operand         -- NEG instruction (name clash with Cond)+        | BSWAP       Format Reg++        -- Shifts (amount may be immediate or %cl only)+        | SHL         Format Operand{-amount-} Operand+        | SAR         Format Operand{-amount-} Operand+        | SHR         Format Operand{-amount-} Operand++        | BT          Format Imm Operand+        | NOP++        -- x86 Float Arithmetic.+        -- Note that we cheat by treating G{ABS,MOV,NEG} of doubles+        -- as single instructions right up until we spit them out.+        -- all the 3-operand fake fp insns are src1 src2 dst+        -- and furthermore are constrained to be fp regs only.+        -- IMPORTANT: keep is_G_insn up to date with any changes here+        | GMOV        Reg Reg -- src(fpreg), dst(fpreg)+        | GLD         Format AddrMode Reg -- src, dst(fpreg)+        | GST         Format Reg AddrMode -- src(fpreg), dst++        | GLDZ        Reg -- dst(fpreg)+        | GLD1        Reg -- dst(fpreg)++        | GFTOI       Reg Reg -- src(fpreg), dst(intreg)+        | GDTOI       Reg Reg -- src(fpreg), dst(intreg)++        | GITOF       Reg Reg -- src(intreg), dst(fpreg)+        | GITOD       Reg Reg -- src(intreg), dst(fpreg)++        | GDTOF       Reg Reg -- src(fpreg), dst(fpreg)++        | GADD        Format Reg Reg Reg -- src1, src2, dst+        | GDIV        Format Reg Reg Reg -- src1, src2, dst+        | GSUB        Format Reg Reg Reg -- src1, src2, dst+        | GMUL        Format Reg Reg Reg -- src1, src2, dst++                -- FP compare.  Cond must be `elem` [EQQ, NE, LE, LTT, GE, GTT]+                -- Compare src1 with src2; set the Zero flag iff the numbers are+                -- comparable and the comparison is True.  Subsequent code must+                -- test the %eflags zero flag regardless of the supplied Cond.+        | GCMP        Cond Reg Reg -- src1, src2++        | GABS        Format Reg Reg -- src, dst+        | GNEG        Format Reg Reg -- src, dst+        | GSQRT       Format Reg Reg -- src, dst+        | GSIN        Format CLabel CLabel Reg Reg -- src, dst+        | GCOS        Format CLabel CLabel Reg Reg -- src, dst+        | GTAN        Format CLabel CLabel Reg Reg -- src, dst++        | GFREE         -- do ffree on all x86 regs; an ugly hack+++        -- SSE2 floating point: we use a restricted set of the available SSE2+        -- instructions for floating-point.+        -- use MOV for moving (either movss or movsd (movlpd better?))+        | CVTSS2SD      Reg Reg            -- F32 to F64+        | CVTSD2SS      Reg Reg            -- F64 to F32+        | CVTTSS2SIQ    Format Operand Reg -- F32 to I32/I64 (with truncation)+        | CVTTSD2SIQ    Format Operand Reg -- F64 to I32/I64 (with truncation)+        | CVTSI2SS      Format Operand Reg -- I32/I64 to F32+        | CVTSI2SD      Format Operand Reg -- I32/I64 to F64++        -- use ADD & SUB for arithmetic.  In both cases, operands+        -- are  Operand Reg.++        -- SSE2 floating-point division:+        | FDIV          Format Operand Operand   -- divisor, dividend(dst)++        -- use CMP for comparisons.  ucomiss and ucomisd instructions+        -- compare single/double prec floating point respectively.++        | SQRT          Format Operand Reg      -- src, dst+++        -- Comparison+        | TEST          Format Operand Operand+        | CMP           Format Operand Operand+        | SETCC         Cond Operand++        -- Stack Operations.+        | PUSH          Format Operand+        | POP           Format Operand+        -- both unused (SDM):+        --  | PUSHA+        --  | POPA++        -- Jumping around.+        | JMP         Operand [Reg] -- including live Regs at the call+        | JXX         Cond BlockId  -- includes unconditional branches+        | JXX_GBL     Cond Imm      -- non-local version of JXX+        -- Table jump+        | JMP_TBL     Operand   -- Address to jump to+                      [Maybe BlockId] -- Blocks in the jump table+                      Section   -- Data section jump table should be put in+                      CLabel    -- Label of jump table+        | CALL        (Either Imm Reg) [Reg]++        -- Other things.+        | CLTD Format            -- sign extend %eax into %edx:%eax++        | FETCHGOT    Reg        -- pseudo-insn for ELF position-independent code+                                 -- pretty-prints as+                                 --       call 1f+                                 -- 1:    popl %reg+                                 --       addl __GLOBAL_OFFSET_TABLE__+.-1b, %reg+        | FETCHPC     Reg        -- pseudo-insn for Darwin position-independent code+                                 -- pretty-prints as+                                 --       call 1f+                                 -- 1:    popl %reg++    -- bit counting instructions+        | POPCNT      Format Operand Reg -- [SSE4.2] count number of bits set to 1+        | BSF         Format Operand Reg -- bit scan forward+        | BSR         Format Operand Reg -- bit scan reverse++    -- prefetch+        | PREFETCH  PrefetchVariant Format Operand -- prefetch Variant, addr size, address to prefetch+                                        -- variant can be NTA, Lvl0, Lvl1, or Lvl2++        | LOCK        Instr -- lock prefix+        | XADD        Format Operand Operand -- src (r), dst (r/m)+        | CMPXCHG     Format Operand Operand -- src (r), dst (r/m), eax implicit+        | MFENCE++data PrefetchVariant = NTA | Lvl0 | Lvl1 | Lvl2+++data Operand+        = OpReg  Reg            -- register+        | OpImm  Imm            -- immediate value+        | OpAddr AddrMode       -- memory reference++++-- | Returns which registers are read and written as a (read, written)+-- pair.+x86_regUsageOfInstr :: Platform -> Instr -> RegUsage+x86_regUsageOfInstr platform instr+ = case instr of+    MOV    _ src dst    -> usageRW src dst+    CMOV _ _ src dst    -> mkRU (use_R src [dst]) [dst]+    MOVZxL _ src dst    -> usageRW src dst+    MOVSxL _ src dst    -> usageRW src dst+    LEA    _ src dst    -> usageRW src dst+    ADD    _ src dst    -> usageRM src dst+    ADC    _ src dst    -> usageRM src dst+    SUB    _ src dst    -> usageRM src dst+    SBB    _ src dst    -> usageRM src dst+    IMUL   _ src dst    -> usageRM src dst+    IMUL2  _ src       -> mkRU (eax:use_R src []) [eax,edx]+    MUL    _ src dst    -> usageRM src dst+    MUL2   _ src        -> mkRU (eax:use_R src []) [eax,edx]+    DIV    _ op -> mkRU (eax:edx:use_R op []) [eax,edx]+    IDIV   _ op -> mkRU (eax:edx:use_R op []) [eax,edx]+    ADD_CC _ src dst    -> usageRM src dst+    SUB_CC _ src dst    -> usageRM src dst+    AND    _ src dst    -> usageRM src dst+    OR     _ src dst    -> usageRM src dst++    XOR    _ (OpReg src) (OpReg dst)+        | src == dst    -> mkRU [] [dst]++    XOR    _ src dst    -> usageRM src dst+    NOT    _ op         -> usageM op+    BSWAP  _ reg        -> mkRU [reg] [reg]+    NEGI   _ op         -> usageM op+    SHL    _ imm dst    -> usageRM imm dst+    SAR    _ imm dst    -> usageRM imm dst+    SHR    _ imm dst    -> usageRM imm dst+    BT     _ _   src    -> mkRUR (use_R src [])++    PUSH   _ op         -> mkRUR (use_R op [])+    POP    _ op         -> mkRU [] (def_W op)+    TEST   _ src dst    -> mkRUR (use_R src $! use_R dst [])+    CMP    _ src dst    -> mkRUR (use_R src $! use_R dst [])+    SETCC  _ op         -> mkRU [] (def_W op)+    JXX    _ _          -> mkRU [] []+    JXX_GBL _ _         -> mkRU [] []+    JMP     op regs     -> mkRUR (use_R op regs)+    JMP_TBL op _ _ _    -> mkRUR (use_R op [])+    CALL (Left _)  params   -> mkRU params (callClobberedRegs platform)+    CALL (Right reg) params -> mkRU (reg:params) (callClobberedRegs platform)+    CLTD   _            -> mkRU [eax] [edx]+    NOP                 -> mkRU [] []++    GMOV   src dst      -> mkRU [src] [dst]+    GLD    _ src dst    -> mkRU (use_EA src []) [dst]+    GST    _ src dst    -> mkRUR (src : use_EA dst [])++    GLDZ   dst          -> mkRU [] [dst]+    GLD1   dst          -> mkRU [] [dst]++    GFTOI  src dst      -> mkRU [src] [dst]+    GDTOI  src dst      -> mkRU [src] [dst]++    GITOF  src dst      -> mkRU [src] [dst]+    GITOD  src dst      -> mkRU [src] [dst]++    GDTOF  src dst      -> mkRU [src] [dst]++    GADD   _ s1 s2 dst  -> mkRU [s1,s2] [dst]+    GSUB   _ s1 s2 dst  -> mkRU [s1,s2] [dst]+    GMUL   _ s1 s2 dst  -> mkRU [s1,s2] [dst]+    GDIV   _ s1 s2 dst  -> mkRU [s1,s2] [dst]++    GCMP   _ src1 src2   -> mkRUR [src1,src2]+    GABS   _ src dst     -> mkRU [src] [dst]+    GNEG   _ src dst     -> mkRU [src] [dst]+    GSQRT  _ src dst     -> mkRU [src] [dst]+    GSIN   _ _ _ src dst -> mkRU [src] [dst]+    GCOS   _ _ _ src dst -> mkRU [src] [dst]+    GTAN   _ _ _ src dst -> mkRU [src] [dst]++    CVTSS2SD   src dst  -> mkRU [src] [dst]+    CVTSD2SS   src dst  -> mkRU [src] [dst]+    CVTTSS2SIQ _ src dst -> mkRU (use_R src []) [dst]+    CVTTSD2SIQ _ src dst -> mkRU (use_R src []) [dst]+    CVTSI2SS   _ src dst -> mkRU (use_R src []) [dst]+    CVTSI2SD   _ src dst -> mkRU (use_R src []) [dst]+    FDIV _     src dst  -> usageRM src dst++    FETCHGOT reg        -> mkRU [] [reg]+    FETCHPC  reg        -> mkRU [] [reg]++    COMMENT _           -> noUsage+    LOCATION{}          -> noUsage+    UNWIND{}            -> noUsage+    DELTA   _           -> noUsage++    POPCNT _ src dst -> mkRU (use_R src []) [dst]+    BSF    _ src dst -> mkRU (use_R src []) [dst]+    BSR    _ src dst -> mkRU (use_R src []) [dst]++    -- note: might be a better way to do this+    PREFETCH _  _ src -> mkRU (use_R src []) []+    LOCK i              -> x86_regUsageOfInstr platform i+    XADD _ src dst      -> usageMM src dst+    CMPXCHG _ src dst   -> usageRMM src dst (OpReg eax)+    MFENCE -> noUsage++    _other              -> panic "regUsage: unrecognised instr"+ where+    -- # Definitions+    --+    -- Written: If the operand is a register, it's written. If it's an+    -- address, registers mentioned in the address are read.+    --+    -- Modified: If the operand is a register, it's both read and+    -- written. If it's an address, registers mentioned in the address+    -- are read.++    -- 2 operand form; first operand Read; second Written+    usageRW :: Operand -> Operand -> RegUsage+    usageRW op (OpReg reg)      = mkRU (use_R op []) [reg]+    usageRW op (OpAddr ea)      = mkRUR (use_R op $! use_EA ea [])+    usageRW _ _                 = panic "X86.RegInfo.usageRW: no match"++    -- 2 operand form; first operand Read; second Modified+    usageRM :: Operand -> Operand -> RegUsage+    usageRM op (OpReg reg)      = mkRU (use_R op [reg]) [reg]+    usageRM op (OpAddr ea)      = mkRUR (use_R op $! use_EA ea [])+    usageRM _ _                 = panic "X86.RegInfo.usageRM: no match"++    -- 2 operand form; first operand Modified; second Modified+    usageMM :: Operand -> Operand -> RegUsage+    usageMM (OpReg src) (OpReg dst) = mkRU [src, dst] [src, dst]+    usageMM (OpReg src) (OpAddr ea) = mkRU (use_EA ea [src]) [src]+    usageMM _ _                     = panic "X86.RegInfo.usageMM: no match"++    -- 3 operand form; first operand Read; second Modified; third Modified+    usageRMM :: Operand -> Operand -> Operand -> RegUsage+    usageRMM (OpReg src) (OpReg dst) (OpReg reg) = mkRU [src, dst, reg] [dst, reg]+    usageRMM (OpReg src) (OpAddr ea) (OpReg reg) = mkRU (use_EA ea [src, reg]) [reg]+    usageRMM _ _ _                               = panic "X86.RegInfo.usageRMM: no match"++    -- 1 operand form; operand Modified+    usageM :: Operand -> RegUsage+    usageM (OpReg reg)          = mkRU [reg] [reg]+    usageM (OpAddr ea)          = mkRUR (use_EA ea [])+    usageM _                    = panic "X86.RegInfo.usageM: no match"++    -- Registers defd when an operand is written.+    def_W (OpReg reg)           = [reg]+    def_W (OpAddr _ )           = []+    def_W _                     = panic "X86.RegInfo.def_W: no match"++    -- Registers used when an operand is read.+    use_R (OpReg reg)  tl = reg : tl+    use_R (OpImm _)    tl = tl+    use_R (OpAddr ea)  tl = use_EA ea tl++    -- Registers used to compute an effective address.+    use_EA (ImmAddr _ _) tl = tl+    use_EA (AddrBaseIndex base index _) tl =+        use_base base $! use_index index tl+        where use_base (EABaseReg r)  tl = r : tl+              use_base _              tl = tl+              use_index EAIndexNone   tl = tl+              use_index (EAIndex i _) tl = i : tl++    mkRUR src = src' `seq` RU src' []+        where src' = filter (interesting platform) src++    mkRU src dst = src' `seq` dst' `seq` RU src' dst'+        where src' = filter (interesting platform) src+              dst' = filter (interesting platform) dst++-- | Is this register interesting for the register allocator?+interesting :: Platform -> Reg -> Bool+interesting _        (RegVirtual _)              = True+interesting platform (RegReal (RealRegSingle i)) = freeReg platform i+interesting _        (RegReal (RealRegPair{}))   = panic "X86.interesting: no reg pairs on this arch"++++-- | Applies the supplied function to all registers in instructions.+-- Typically used to change virtual registers to real registers.+x86_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr+x86_patchRegsOfInstr instr env+ = case instr of+    MOV  fmt src dst     -> patch2 (MOV  fmt) src dst+    CMOV cc fmt src dst  -> CMOV cc fmt (patchOp src) (env dst)+    MOVZxL fmt src dst   -> patch2 (MOVZxL fmt) src dst+    MOVSxL fmt src dst   -> patch2 (MOVSxL fmt) src dst+    LEA  fmt src dst     -> patch2 (LEA  fmt) src dst+    ADD  fmt src dst     -> patch2 (ADD  fmt) src dst+    ADC  fmt src dst     -> patch2 (ADC  fmt) src dst+    SUB  fmt src dst     -> patch2 (SUB  fmt) src dst+    SBB  fmt src dst     -> patch2 (SBB  fmt) src dst+    IMUL fmt src dst     -> patch2 (IMUL fmt) src dst+    IMUL2 fmt src        -> patch1 (IMUL2 fmt) src+    MUL fmt src dst      -> patch2 (MUL fmt) src dst+    MUL2 fmt src         -> patch1 (MUL2 fmt) src+    IDIV fmt op          -> patch1 (IDIV fmt) op+    DIV fmt op           -> patch1 (DIV fmt) op+    ADD_CC fmt src dst   -> patch2 (ADD_CC fmt) src dst+    SUB_CC fmt src dst   -> patch2 (SUB_CC fmt) src dst+    AND  fmt src dst     -> patch2 (AND  fmt) src dst+    OR   fmt src dst     -> patch2 (OR   fmt) src dst+    XOR  fmt src dst     -> patch2 (XOR  fmt) src dst+    NOT  fmt op          -> patch1 (NOT  fmt) op+    BSWAP fmt reg        -> BSWAP fmt (env reg)+    NEGI fmt op          -> patch1 (NEGI fmt) op+    SHL  fmt imm dst     -> patch1 (SHL fmt imm) dst+    SAR  fmt imm dst     -> patch1 (SAR fmt imm) dst+    SHR  fmt imm dst     -> patch1 (SHR fmt imm) dst+    BT   fmt imm src     -> patch1 (BT  fmt imm) src+    TEST fmt src dst     -> patch2 (TEST fmt) src dst+    CMP  fmt src dst     -> patch2 (CMP  fmt) src dst+    PUSH fmt op          -> patch1 (PUSH fmt) op+    POP  fmt op          -> patch1 (POP  fmt) op+    SETCC cond op        -> patch1 (SETCC cond) op+    JMP op regs          -> JMP (patchOp op) regs+    JMP_TBL op ids s lbl -> JMP_TBL (patchOp op) ids s lbl++    GMOV src dst         -> GMOV (env src) (env dst)+    GLD  fmt src dst     -> GLD fmt (lookupAddr src) (env dst)+    GST  fmt src dst     -> GST fmt (env src) (lookupAddr dst)++    GLDZ dst            -> GLDZ (env dst)+    GLD1 dst            -> GLD1 (env dst)++    GFTOI src dst       -> GFTOI (env src) (env dst)+    GDTOI src dst       -> GDTOI (env src) (env dst)++    GITOF src dst       -> GITOF (env src) (env dst)+    GITOD src dst       -> GITOD (env src) (env dst)++    GDTOF src dst       -> GDTOF (env src) (env dst)++    GADD fmt s1 s2 dst   -> GADD fmt (env s1) (env s2) (env dst)+    GSUB fmt s1 s2 dst   -> GSUB fmt (env s1) (env s2) (env dst)+    GMUL fmt s1 s2 dst   -> GMUL fmt (env s1) (env s2) (env dst)+    GDIV fmt s1 s2 dst   -> GDIV fmt (env s1) (env s2) (env dst)++    GCMP fmt src1 src2   -> GCMP fmt (env src1) (env src2)+    GABS fmt src dst     -> GABS fmt (env src) (env dst)+    GNEG fmt src dst     -> GNEG fmt (env src) (env dst)+    GSQRT fmt src dst    -> GSQRT fmt (env src) (env dst)+    GSIN fmt l1 l2 src dst       -> GSIN fmt l1 l2 (env src) (env dst)+    GCOS fmt l1 l2 src dst       -> GCOS fmt l1 l2 (env src) (env dst)+    GTAN fmt l1 l2 src dst       -> GTAN fmt l1 l2 (env src) (env dst)++    CVTSS2SD src dst    -> CVTSS2SD (env src) (env dst)+    CVTSD2SS src dst    -> CVTSD2SS (env src) (env dst)+    CVTTSS2SIQ fmt src dst -> CVTTSS2SIQ fmt (patchOp src) (env dst)+    CVTTSD2SIQ fmt src dst -> CVTTSD2SIQ fmt (patchOp src) (env dst)+    CVTSI2SS fmt src dst -> CVTSI2SS fmt (patchOp src) (env dst)+    CVTSI2SD fmt src dst -> CVTSI2SD fmt (patchOp src) (env dst)+    FDIV fmt src dst     -> FDIV fmt (patchOp src) (patchOp dst)++    CALL (Left _)  _    -> instr+    CALL (Right reg) p  -> CALL (Right (env reg)) p++    FETCHGOT reg        -> FETCHGOT (env reg)+    FETCHPC  reg        -> FETCHPC  (env reg)++    NOP                 -> instr+    COMMENT _           -> instr+    LOCATION {}         -> instr+    UNWIND {}           -> instr+    DELTA _             -> instr++    JXX _ _             -> instr+    JXX_GBL _ _         -> instr+    CLTD _              -> instr++    POPCNT fmt src dst -> POPCNT fmt (patchOp src) (env dst)+    BSF    fmt src dst -> BSF    fmt (patchOp src) (env dst)+    BSR    fmt src dst -> BSR    fmt (patchOp src) (env dst)++    PREFETCH lvl format src -> PREFETCH lvl format (patchOp src)++    LOCK i               -> LOCK (x86_patchRegsOfInstr i env)+    XADD fmt src dst     -> patch2 (XADD fmt) src dst+    CMPXCHG fmt src dst  -> patch2 (CMPXCHG fmt) src dst+    MFENCE               -> instr++    _other              -> panic "patchRegs: unrecognised instr"++  where+    patch1 :: (Operand -> a) -> Operand -> a+    patch1 insn op      = insn $! patchOp op+    patch2 :: (Operand -> Operand -> a) -> Operand -> Operand -> a+    patch2 insn src dst = (insn $! patchOp src) $! patchOp dst++    patchOp (OpReg  reg) = OpReg $! env reg+    patchOp (OpImm  imm) = OpImm imm+    patchOp (OpAddr ea)  = OpAddr $! lookupAddr ea++    lookupAddr (ImmAddr imm off) = ImmAddr imm off+    lookupAddr (AddrBaseIndex base index disp)+      = ((AddrBaseIndex $! lookupBase base) $! lookupIndex index) disp+      where+        lookupBase EABaseNone       = EABaseNone+        lookupBase EABaseRip        = EABaseRip+        lookupBase (EABaseReg r)    = EABaseReg $! env r++        lookupIndex EAIndexNone     = EAIndexNone+        lookupIndex (EAIndex r i)   = (EAIndex $! env r) i+++--------------------------------------------------------------------------------+x86_isJumpishInstr+        :: Instr -> Bool++x86_isJumpishInstr instr+ = case instr of+        JMP{}           -> True+        JXX{}           -> True+        JXX_GBL{}       -> True+        JMP_TBL{}       -> True+        CALL{}          -> True+        _               -> False+++x86_jumpDestsOfInstr+        :: Instr+        -> [BlockId]++x86_jumpDestsOfInstr insn+  = case insn of+        JXX _ id        -> [id]+        JMP_TBL _ ids _ _ -> [id | Just id <- ids]+        _               -> []+++x86_patchJumpInstr+        :: Instr -> (BlockId -> BlockId) -> Instr++x86_patchJumpInstr insn patchF+  = case insn of+        JXX cc id       -> JXX cc (patchF id)+        JMP_TBL op ids section lbl+          -> JMP_TBL op (map (fmap patchF) ids) section lbl+        _               -> insn+++++-- -----------------------------------------------------------------------------+-- | Make a spill instruction.+x86_mkSpillInstr+    :: DynFlags+    -> Reg      -- register to spill+    -> Int      -- current stack delta+    -> Int      -- spill slot to use+    -> Instr++x86_mkSpillInstr dflags reg delta slot+  = let off     = spillSlotToOffset platform slot - delta+    in+    case targetClassOfReg platform reg of+           RcInteger   -> MOV (archWordFormat is32Bit)+                              (OpReg reg) (OpAddr (spRel dflags off))+           RcDouble    -> GST FF80 reg (spRel dflags off) {- RcFloat/RcDouble -}+           RcDoubleSSE -> MOV FF64 (OpReg reg) (OpAddr (spRel dflags off))+           _         -> panic "X86.mkSpillInstr: no match"+    where platform = targetPlatform dflags+          is32Bit = target32Bit platform++-- | Make a spill reload instruction.+x86_mkLoadInstr+    :: DynFlags+    -> Reg      -- register to load+    -> Int      -- current stack delta+    -> Int      -- spill slot to use+    -> Instr++x86_mkLoadInstr dflags reg delta slot+  = let off     = spillSlotToOffset platform slot - delta+    in+        case targetClassOfReg platform reg of+              RcInteger -> MOV (archWordFormat is32Bit)+                               (OpAddr (spRel dflags off)) (OpReg reg)+              RcDouble  -> GLD FF80 (spRel dflags off) reg {- RcFloat/RcDouble -}+              RcDoubleSSE -> MOV FF64 (OpAddr (spRel dflags off)) (OpReg reg)+              _           -> panic "X86.x86_mkLoadInstr"+    where platform = targetPlatform dflags+          is32Bit = target32Bit platform++spillSlotSize :: Platform -> Int+spillSlotSize dflags = if is32Bit then 12 else 8+    where is32Bit = target32Bit dflags++maxSpillSlots :: DynFlags -> Int+maxSpillSlots dflags+    = ((rESERVED_C_STACK_BYTES dflags - 64) `div` spillSlotSize (targetPlatform dflags)) - 1+--     = 0 -- useful for testing allocMoreStack++-- number of bytes that the stack pointer should be aligned to+stackAlign :: Int+stackAlign = 16++-- convert a spill slot number to a *byte* offset, with no sign:+-- decide on a per arch basis whether you are spilling above or below+-- the C stack pointer.+spillSlotToOffset :: Platform -> Int -> Int+spillSlotToOffset platform slot+   = 64 + spillSlotSize platform * slot++--------------------------------------------------------------------------------++-- | See if this instruction is telling us the current C stack delta+x86_takeDeltaInstr+        :: Instr+        -> Maybe Int++x86_takeDeltaInstr instr+ = case instr of+        DELTA i         -> Just i+        _               -> Nothing+++x86_isMetaInstr+        :: Instr+        -> Bool++x86_isMetaInstr instr+ = case instr of+        COMMENT{}       -> True+        LOCATION{}      -> True+        LDATA{}         -> True+        NEWBLOCK{}      -> True+        UNWIND{}        -> True+        DELTA{}         -> True+        _               -> False++++-- | Make a reg-reg move instruction.+--      On SPARC v8 there are no instructions to move directly between+--      floating point and integer regs. If we need to do that then we+--      have to go via memory.+--+x86_mkRegRegMoveInstr+    :: Platform+    -> Reg+    -> Reg+    -> Instr++x86_mkRegRegMoveInstr platform src dst+ = case targetClassOfReg platform src of+        RcInteger -> case platformArch platform of+                     ArchX86    -> MOV II32 (OpReg src) (OpReg dst)+                     ArchX86_64 -> MOV II64 (OpReg src) (OpReg dst)+                     _          -> panic "x86_mkRegRegMoveInstr: Bad arch"+        RcDouble    -> GMOV src dst+        RcDoubleSSE -> MOV FF64 (OpReg src) (OpReg dst)+        _     -> panic "X86.RegInfo.mkRegRegMoveInstr: no match"++-- | Check whether an instruction represents a reg-reg move.+--      The register allocator attempts to eliminate reg->reg moves whenever it can,+--      by assigning the src and dest temporaries to the same real register.+--+x86_takeRegRegMoveInstr+        :: Instr+        -> Maybe (Reg,Reg)++x86_takeRegRegMoveInstr (MOV _ (OpReg r1) (OpReg r2))+        = Just (r1,r2)++x86_takeRegRegMoveInstr _  = Nothing+++-- | Make an unconditional branch instruction.+x86_mkJumpInstr+        :: BlockId+        -> [Instr]++x86_mkJumpInstr id+        = [JXX ALWAYS id]+++x86_mkStackAllocInstr+        :: Platform+        -> Int+        -> Instr+x86_mkStackAllocInstr platform amount+  = case platformArch platform of+      ArchX86    -> SUB II32 (OpImm (ImmInt amount)) (OpReg esp)+      ArchX86_64 -> SUB II64 (OpImm (ImmInt amount)) (OpReg rsp)+      _ -> panic "x86_mkStackAllocInstr"++x86_mkStackDeallocInstr+        :: Platform+        -> Int+        -> Instr+x86_mkStackDeallocInstr platform amount+  = case platformArch platform of+      ArchX86    -> ADD II32 (OpImm (ImmInt amount)) (OpReg esp)+      ArchX86_64 -> ADD II64 (OpImm (ImmInt amount)) (OpReg rsp)+      _ -> panic "x86_mkStackDeallocInstr"++i386_insert_ffrees+        :: [GenBasicBlock Instr]+        -> [GenBasicBlock Instr]++i386_insert_ffrees blocks+   | any (any is_G_instr) [ instrs | BasicBlock _ instrs <- blocks ]+   = map insertGFREEs blocks+   | otherwise+   = blocks+ where+   insertGFREEs (BasicBlock id insns)+     = BasicBlock id (insertBeforeNonlocalTransfers GFREE insns)++insertBeforeNonlocalTransfers :: Instr -> [Instr] -> [Instr]+insertBeforeNonlocalTransfers insert insns+     = foldr p [] insns+     where p insn r = case insn of+                        CALL _ _    -> insert : insn : r+                        JMP _ _     -> insert : insn : r+                        JXX_GBL _ _ -> panic "insertBeforeNonlocalTransfers: cannot handle JXX_GBL"+                        _           -> insn : r+++-- if you ever add a new FP insn to the fake x86 FP insn set,+-- you must update this too+is_G_instr :: Instr -> Bool+is_G_instr instr+   = case instr of+        GMOV{}          -> True+        GLD{}           -> True+        GST{}           -> True+        GLDZ{}          -> True+        GLD1{}          -> True+        GFTOI{}         -> True+        GDTOI{}         -> True+        GITOF{}         -> True+        GITOD{}         -> True+        GDTOF{}         -> True+        GADD{}          -> True+        GDIV{}          -> True+        GSUB{}          -> True+        GMUL{}          -> True+        GCMP{}          -> True+        GABS{}          -> True+        GNEG{}          -> True+        GSQRT{}         -> True+        GSIN{}          -> True+        GCOS{}          -> True+        GTAN{}          -> True+        GFREE           -> panic "is_G_instr: GFREE (!)"+        _               -> False+++--+-- Note [extra spill slots]+--+-- If the register allocator used more spill slots than we have+-- pre-allocated (rESERVED_C_STACK_BYTES), then we must allocate more+-- C stack space on entry and exit from this proc.  Therefore we+-- insert a "sub $N, %rsp" at every entry point, and an "add $N, %rsp"+-- before every non-local jump.+--+-- This became necessary when the new codegen started bundling entire+-- functions together into one proc, because the register allocator+-- assigns a different stack slot to each virtual reg within a proc.+-- To avoid using so many slots we could also:+--+--   - split up the proc into connected components before code generator+--+--   - rename the virtual regs, so that we re-use vreg names and hence+--     stack slots for non-overlapping vregs.+--+-- Note that when a block is both a non-local entry point (with an+-- info table) and a local branch target, we have to split it into+-- two, like so:+--+--    <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.+--+allocMoreStack+  :: Platform+  -> Int+  -> NatCmmDecl statics X86.Instr.Instr+  -> UniqSM (NatCmmDecl statics X86.Instr.Instr)++allocMoreStack _ _ top@(CmmData _ _) = return top+allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do+    let entries = entryBlocks proc++    uniqs <- replicateM (length entries) getUniqueM++    let+      delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up+        where x = slots * spillSlotSize platform -- sp delta++      alloc   = mkStackAllocInstr   platform delta+      dealloc = mkStackDeallocInstr platform delta++      new_blockmap :: LabelMap BlockId+      new_blockmap = mapFromList (zip entries (map mkBlockId uniqs))++      insert_stack_insns (BasicBlock id insns)+         | Just new_blockid <- mapLookup id new_blockmap+         = [ BasicBlock id [alloc, JXX ALWAYS new_blockid]+           , BasicBlock new_blockid block' ]+         | otherwise+         = [ BasicBlock id block' ]+         where+           block' = foldr insert_dealloc [] insns++      insert_dealloc insn r = case insn of+         JMP _ _     -> dealloc : insn : r+         JXX_GBL _ _ -> panic "insert_dealloc: cannot handle JXX_GBL"+         _other      -> x86_patchJumpInstr insn retarget : r+           where retarget b = fromMaybe b (mapLookup b new_blockmap)++      new_code = concatMap insert_stack_insns code+    -- in+    return (CmmProc info lbl live (ListGraph new_code))+++data JumpDest = DestBlockId BlockId | DestImm Imm++getJumpDestBlockId :: JumpDest -> Maybe BlockId+getJumpDestBlockId (DestBlockId bid) = Just bid+getJumpDestBlockId _                 = Nothing++canShortcut :: Instr -> Maybe JumpDest+canShortcut (JXX ALWAYS id)      = Just (DestBlockId id)+canShortcut (JMP (OpImm imm) _)  = Just (DestImm imm)+canShortcut _                    = Nothing+++-- This helper shortcuts a sequence of branches.+-- The blockset helps avoid following cycles.+shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr+shortcutJump fn insn = shortcutJump' fn (setEmpty :: LabelSet) insn+  where shortcutJump' fn seen insn@(JXX cc id) =+          if setMember id seen then insn+          else case fn id of+                 Nothing                -> insn+                 Just (DestBlockId id') -> shortcutJump' fn seen' (JXX cc id')+                 Just (DestImm imm)     -> shortcutJump' fn seen' (JXX_GBL cc imm)+               where seen' = setInsert id seen+        shortcutJump' _ _ other = other++-- Here because it knows about JumpDest+shortcutStatics :: (BlockId -> Maybe JumpDest) -> (Alignment, CmmStatics) -> (Alignment, CmmStatics)+shortcutStatics fn (align, Statics lbl statics)+  = (align, Statics lbl $ map (shortcutStatic fn) statics)+  -- we need to get the jump tables, so apply the mapping to the entries+  -- of a CmmData too.++shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel+shortcutLabel fn lab+  | Just uq <- maybeAsmTemp lab = shortBlockId fn emptyUniqSet (mkBlockId uq)+  | otherwise                   = lab++shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic+shortcutStatic fn (CmmStaticLit (CmmLabel lab))+  = CmmStaticLit (CmmLabel (shortcutLabel fn lab))+shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off))+  = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off)+        -- slightly dodgy, we're ignoring the second label, but this+        -- works with the way we use CmmLabelDiffOff for jump tables now.+shortcutStatic _ other_static+        = other_static++shortBlockId+        :: (BlockId -> Maybe JumpDest)+        -> UniqSet Unique+        -> BlockId+        -> CLabel++shortBlockId fn seen blockid =+  case (elementOfUniqSet uq seen, fn blockid) of+    (True, _)    -> mkAsmTempLabel uq+    (_, Nothing) -> mkAsmTempLabel uq+    (_, Just (DestBlockId blockid'))  -> shortBlockId fn (addOneToUniqSet seen uq) blockid'+    (_, Just (DestImm (ImmCLbl lbl))) -> lbl+    (_, _other) -> panic "shortBlockId"+  where uq = getUnique blockid
+ nativeGen/X86/Ppr.hs view
@@ -0,0 +1,1303 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Pretty-printing assembly language+--+-- (c) The University of Glasgow 1993-2005+--+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -fno-warn-orphans #-}+module X86.Ppr (+        pprNatCmmDecl,+        pprData,+        pprInstr,+        pprFormat,+        pprImm,+        pprDataItem,+)++where++#include "HsVersions.h"+#include "nativeGen/NCG.h"++import X86.Regs+import X86.Instr+import X86.Cond+import Instruction+import Format+import Reg+import PprBase+++import Hoopl+import BasicTypes       (Alignment)+import DynFlags+import Cmm              hiding (topInfoTable)+import CLabel+import Unique           ( pprUniqueAlways, Uniquable(..) )+import Platform+import FastString+import Outputable++import Data.Word++import Data.Char++import Data.Bits++-- -----------------------------------------------------------------------------+-- Printing this stuff out+--+--+-- Note [Subsections Via Symbols]+--+-- If we are using the .subsections_via_symbols directive+-- (available on recent versions of Darwin),+-- we have to make sure that there is some kind of reference+-- from the entry code to a label on the _top_ of of the info table,+-- so that the linker will not think it is unreferenced and dead-strip+-- it. That's why the label is called a DeadStripPreventer (_dsp).+--+-- The LLVM code gen already creates `iTableSuf` symbols, where+-- the X86 would generate the DeadStripPreventer (_dsp) symbol.+-- Therefore all that is left for llvm code gen, is to ensure+-- that all the `iTableSuf` symbols are marked as used.+-- As of this writing the documentation regarding the+-- .subsections_via_symbols and -dead_strip can be found at+-- <https://developer.apple.com/library/mac/documentation/DeveloperTools/Reference/Assembler/040-Assembler_Directives/asm_directives.html#//apple_ref/doc/uid/TP30000823-TPXREF101>++pprNatCmmDecl :: NatCmmDecl (Alignment, CmmStatics) Instr -> SDoc+pprNatCmmDecl (CmmData section dats) =+  pprSectionAlign section $$ pprDatas dats++pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =+  sdocWithDynFlags $ \dflags ->+  case topInfoTable proc of+    Nothing ->+       case blocks of+         []     -> -- special case for split markers:+           pprLabel lbl+         blocks -> -- special case for code without info table:+           pprSectionAlign (Section Text lbl) $$+           pprLabel lbl $$ -- blocks guaranteed not null, so label needed+           vcat (map (pprBasicBlock top_info) blocks) $$+           (if debugLevel dflags > 0+            then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$+           pprSizeDecl lbl++    Just (Statics info_lbl _) ->+      sdocWithPlatform $ \platform ->+      pprSectionAlign (Section Text info_lbl) $$+      (if platformHasSubsectionsViaSymbols platform+          then ppr (mkDeadStripPreventer info_lbl) <> char ':'+          else empty) $$+      vcat (map (pprBasicBlock top_info) blocks) $$+      -- above: Even the first block gets a label, because with branch-chain+      -- elimination, it might be the target of a goto.+      (if platformHasSubsectionsViaSymbols platform+       then -- See Note [Subsections Via Symbols]+                text "\t.long "+            <+> ppr info_lbl+            <+> char '-'+            <+> ppr (mkDeadStripPreventer info_lbl)+       else empty) $$+      (if debugLevel dflags > 0+       then ppr (mkAsmTempEndLabel info_lbl) <> char ':' else empty) $$+      pprSizeDecl info_lbl++-- | Output the ELF .size directive.+pprSizeDecl :: CLabel -> SDoc+pprSizeDecl lbl+ = sdocWithPlatform $ \platform ->+   if osElfTarget (platformOS platform)+   then text "\t.size" <+> ppr lbl <> ptext (sLit ", .-") <> ppr lbl+   else empty++pprBasicBlock :: LabelMap CmmStatics -> NatBasicBlock Instr -> SDoc+pprBasicBlock info_env (BasicBlock blockid instrs)+  = sdocWithDynFlags $ \dflags ->+    maybe_infotable $$+    pprLabel asmLbl $$+    vcat (map pprInstr instrs) $$+    (if debugLevel dflags > 0+     then ppr (mkAsmTempEndLabel asmLbl) <> char ':' else empty)+  where+    asmLbl = mkAsmTempLabel (getUnique blockid)+    maybe_infotable = case mapLookup blockid info_env of+       Nothing   -> empty+       Just (Statics info_lbl info) ->+           pprAlignForSection Text $$+           infoTableLoc $$+           vcat (map pprData info) $$+           pprLabel info_lbl+    -- Make sure the info table has the right .loc for the block+    -- coming right after it. See [Note: Info Offset]+    infoTableLoc = case instrs of+      (l@LOCATION{} : _) -> pprInstr l+      _other             -> empty++pprDatas :: (Alignment, CmmStatics) -> SDoc+pprDatas (align, (Statics lbl dats))+ = vcat (pprAlign align : pprLabel lbl : map pprData dats)++pprData :: CmmStatic -> SDoc+pprData (CmmString str)+ = ptext (sLit "\t.asciz ") <> doubleQuotes (pprASCII str)++pprData (CmmUninitialised bytes)+ = sdocWithPlatform $ \platform ->+   if platformOS platform == OSDarwin then text ".space " <> int bytes+                                      else text ".skip "  <> int bytes++pprData (CmmStaticLit lit) = pprDataItem lit++pprGloblDecl :: CLabel -> SDoc+pprGloblDecl lbl+  | not (externallyVisibleCLabel lbl) = empty+  | otherwise = text ".globl " <> ppr lbl++pprTypeAndSizeDecl :: CLabel -> SDoc+pprTypeAndSizeDecl lbl+    = sdocWithPlatform $ \platform ->+      if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl+      then text ".type " <> ppr lbl <> ptext (sLit ", @object")+      else empty++pprLabel :: CLabel -> SDoc+pprLabel lbl = pprGloblDecl lbl+            $$ pprTypeAndSizeDecl lbl+            $$ (ppr lbl <> char ':')+++pprASCII :: [Word8] -> SDoc+pprASCII str+  = hcat (map (do1 . fromIntegral) str)+    where+       do1 :: Int -> SDoc+       do1 w | '\t' <- chr w = ptext (sLit "\\t")+       do1 w | '\n' <- chr w = ptext (sLit "\\n")+       do1 w | '"'  <- chr w = ptext (sLit "\\\"")+       do1 w | '\\' <- chr w = ptext (sLit "\\\\")+       do1 w | isPrint (chr w) = char (chr w)+       do1 w | otherwise = char '\\' <> octal w++       octal :: Int -> SDoc+       octal w = int ((w `div` 64) `mod` 8)+                  <> int ((w `div` 8) `mod` 8)+                  <> int (w `mod` 8)++pprAlign :: Int -> SDoc+pprAlign bytes+        = sdocWithPlatform $ \platform ->+          text ".align " <> int (alignment platform)+  where+        alignment platform = if platformOS platform == OSDarwin+                             then log2 bytes+                             else      bytes++        log2 :: Int -> Int  -- cache the common ones+        log2 1 = 0+        log2 2 = 1+        log2 4 = 2+        log2 8 = 3+        log2 n = 1 + log2 (n `quot` 2)++-- -----------------------------------------------------------------------------+-- pprInstr: print an 'Instr'++instance Outputable Instr where+    ppr instr = pprInstr instr+++pprReg :: Format -> Reg -> SDoc+pprReg f r+  = case r of+      RegReal    (RealRegSingle i) ->+          sdocWithPlatform $ \platform ->+          if target32Bit platform then ppr32_reg_no f i+                                  else ppr64_reg_no f i+      RegReal    (RealRegPair _ _) -> panic "X86.Ppr: no reg pairs on this arch"+      RegVirtual (VirtualRegI  u)  -> text "%vI_"   <> pprUniqueAlways u+      RegVirtual (VirtualRegHi u)  -> text "%vHi_"  <> pprUniqueAlways u+      RegVirtual (VirtualRegF  u)  -> text "%vF_"   <> pprUniqueAlways u+      RegVirtual (VirtualRegD  u)  -> text "%vD_"   <> pprUniqueAlways u+      RegVirtual (VirtualRegSSE u) -> text "%vSSE_" <> pprUniqueAlways u+  where+    ppr32_reg_no :: Format -> Int -> SDoc+    ppr32_reg_no II8   = ppr32_reg_byte+    ppr32_reg_no II16  = ppr32_reg_word+    ppr32_reg_no _     = ppr32_reg_long++    ppr32_reg_byte i = ptext+      (case i of {+         0 -> sLit "%al";     1 -> sLit "%bl";+         2 -> sLit "%cl";     3 -> sLit "%dl";+        _  -> sLit "very naughty I386 byte register"+      })++    ppr32_reg_word i = ptext+      (case i of {+         0 -> sLit "%ax";     1 -> sLit "%bx";+         2 -> sLit "%cx";     3 -> sLit "%dx";+         4 -> sLit "%si";     5 -> sLit "%di";+         6 -> sLit "%bp";     7 -> sLit "%sp";+        _  -> sLit "very naughty I386 word register"+      })++    ppr32_reg_long i = ptext+      (case i of {+         0 -> sLit "%eax";    1 -> sLit "%ebx";+         2 -> sLit "%ecx";    3 -> sLit "%edx";+         4 -> sLit "%esi";    5 -> sLit "%edi";+         6 -> sLit "%ebp";    7 -> sLit "%esp";+         _  -> ppr_reg_float i+      })++    ppr64_reg_no :: Format -> Int -> SDoc+    ppr64_reg_no II8   = ppr64_reg_byte+    ppr64_reg_no II16  = ppr64_reg_word+    ppr64_reg_no II32  = ppr64_reg_long+    ppr64_reg_no _     = ppr64_reg_quad++    ppr64_reg_byte i = ptext+      (case i of {+         0 -> sLit "%al";     1 -> sLit "%bl";+         2 -> sLit "%cl";     3 -> sLit "%dl";+         4 -> sLit "%sil";    5 -> sLit "%dil"; -- new 8-bit regs!+         6 -> sLit "%bpl";    7 -> sLit "%spl";+         8 -> sLit "%r8b";    9  -> sLit "%r9b";+        10 -> sLit "%r10b";   11 -> sLit "%r11b";+        12 -> sLit "%r12b";   13 -> sLit "%r13b";+        14 -> sLit "%r14b";   15 -> sLit "%r15b";+        _  -> sLit "very naughty x86_64 byte register"+      })++    ppr64_reg_word i = ptext+      (case i of {+         0 -> sLit "%ax";     1 -> sLit "%bx";+         2 -> sLit "%cx";     3 -> sLit "%dx";+         4 -> sLit "%si";     5 -> sLit "%di";+         6 -> sLit "%bp";     7 -> sLit "%sp";+         8 -> sLit "%r8w";    9  -> sLit "%r9w";+        10 -> sLit "%r10w";   11 -> sLit "%r11w";+        12 -> sLit "%r12w";   13 -> sLit "%r13w";+        14 -> sLit "%r14w";   15 -> sLit "%r15w";+        _  -> sLit "very naughty x86_64 word register"+      })++    ppr64_reg_long i = ptext+      (case i of {+         0 -> sLit "%eax";    1  -> sLit "%ebx";+         2 -> sLit "%ecx";    3  -> sLit "%edx";+         4 -> sLit "%esi";    5  -> sLit "%edi";+         6 -> sLit "%ebp";    7  -> sLit "%esp";+         8 -> sLit "%r8d";    9  -> sLit "%r9d";+        10 -> sLit "%r10d";   11 -> sLit "%r11d";+        12 -> sLit "%r12d";   13 -> sLit "%r13d";+        14 -> sLit "%r14d";   15 -> sLit "%r15d";+        _  -> sLit "very naughty x86_64 register"+      })++    ppr64_reg_quad i = ptext+      (case i of {+         0 -> sLit "%rax";      1 -> sLit "%rbx";+         2 -> sLit "%rcx";      3 -> sLit "%rdx";+         4 -> sLit "%rsi";      5 -> sLit "%rdi";+         6 -> sLit "%rbp";      7 -> sLit "%rsp";+         8 -> sLit "%r8";       9 -> sLit "%r9";+        10 -> sLit "%r10";    11 -> sLit "%r11";+        12 -> sLit "%r12";    13 -> sLit "%r13";+        14 -> sLit "%r14";    15 -> sLit "%r15";+        _  -> ppr_reg_float i+      })++ppr_reg_float :: Int -> LitString+ppr_reg_float i = case i of+        16 -> sLit "%fake0";  17 -> sLit "%fake1"+        18 -> sLit "%fake2";  19 -> sLit "%fake3"+        20 -> sLit "%fake4";  21 -> sLit "%fake5"+        24 -> sLit "%xmm0";   25 -> sLit "%xmm1"+        26 -> sLit "%xmm2";   27 -> sLit "%xmm3"+        28 -> sLit "%xmm4";   29 -> sLit "%xmm5"+        30 -> sLit "%xmm6";   31 -> sLit "%xmm7"+        32 -> sLit "%xmm8";   33 -> sLit "%xmm9"+        34 -> sLit "%xmm10";  35 -> sLit "%xmm11"+        36 -> sLit "%xmm12";  37 -> sLit "%xmm13"+        38 -> sLit "%xmm14";  39 -> sLit "%xmm15"+        _  -> sLit "very naughty x86 register"++pprFormat :: Format -> SDoc+pprFormat x+ = ptext (case x of+                II8   -> sLit "b"+                II16  -> sLit "w"+                II32  -> sLit "l"+                II64  -> sLit "q"+                FF32  -> sLit "ss"      -- "scalar single-precision float" (SSE2)+                FF64  -> sLit "sd"      -- "scalar double-precision float" (SSE2)+                FF80  -> sLit "t"+                )++pprFormat_x87 :: Format -> SDoc+pprFormat_x87 x+  = ptext $ case x of+                FF32  -> sLit "s"+                FF64  -> sLit "l"+                FF80  -> sLit "t"+                _     -> panic "X86.Ppr.pprFormat_x87"++pprCond :: Cond -> SDoc+pprCond c+ = ptext (case c of {+                GEU     -> sLit "ae";   LU    -> sLit "b";+                EQQ     -> sLit "e";    GTT   -> sLit "g";+                GE      -> sLit "ge";   GU    -> sLit "a";+                LTT     -> sLit "l";    LE    -> sLit "le";+                LEU     -> sLit "be";   NE    -> sLit "ne";+                NEG     -> sLit "s";    POS   -> sLit "ns";+                CARRY   -> sLit "c";   OFLO  -> sLit "o";+                PARITY  -> sLit "p";   NOTPARITY -> sLit "np";+                ALWAYS  -> sLit "mp"})+++pprImm :: Imm -> SDoc+pprImm (ImmInt i)     = int i+pprImm (ImmInteger i) = integer i+pprImm (ImmCLbl l)    = ppr l+pprImm (ImmIndex l i) = ppr l <> char '+' <> int i+pprImm (ImmLit s)     = s++pprImm (ImmFloat _)  = text "naughty float immediate"+pprImm (ImmDouble _) = text "naughty double immediate"++pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b+pprImm (ImmConstantDiff a b) = pprImm a <> char '-'+                            <> lparen <> pprImm b <> rparen++++pprAddr :: AddrMode -> SDoc+pprAddr (ImmAddr imm off)+  = let pp_imm = pprImm imm+    in+    if (off == 0) then+        pp_imm+    else if (off < 0) then+        pp_imm <> int off+    else+        pp_imm <> char '+' <> int off++pprAddr (AddrBaseIndex base index displacement)+  = sdocWithPlatform $ \platform ->+    let+        pp_disp  = ppr_disp displacement+        pp_off p = pp_disp <> char '(' <> p <> char ')'+        pp_reg r = pprReg (archWordFormat (target32Bit platform)) r+    in+    case (base, index) of+      (EABaseNone,  EAIndexNone) -> pp_disp+      (EABaseReg b, EAIndexNone) -> pp_off (pp_reg b)+      (EABaseRip,   EAIndexNone) -> pp_off (text "%rip")+      (EABaseNone,  EAIndex r i) -> pp_off (comma <> pp_reg r <> comma <> int i)+      (EABaseReg b, EAIndex r i) -> pp_off (pp_reg b <> comma <> pp_reg r+                                       <> comma <> int i)+      _                         -> panic "X86.Ppr.pprAddr: no match"++  where+    ppr_disp (ImmInt 0) = empty+    ppr_disp imm        = pprImm imm++-- | Print section header and appropriate alignment for that section.+pprSectionAlign :: Section -> SDoc+pprSectionAlign (Section (OtherSection _) _) =+     panic "X86.Ppr.pprSectionAlign: unknown section"+pprSectionAlign sec@(Section seg _) =+  sdocWithPlatform $ \platform ->+    pprSectionHeader platform sec $$+    pprAlignForSection seg++-- | Print appropriate alignment for the given section type.+pprAlignForSection :: SectionType -> SDoc+pprAlignForSection seg =+  sdocWithPlatform $ \platform ->+    text ".align " <>+    case platformOS platform of+      -- Darwin: alignments are given as shifts.+      OSDarwin+       | target32Bit platform ->+          case seg of+           ReadOnlyData16    -> int 4+           CString           -> int 1+           _                 -> int 2+       | otherwise ->+          case seg of+           ReadOnlyData16    -> int 4+           CString           -> int 1+           _                 -> int 3+      -- Other: alignments are given as bytes.+      _+       | target32Bit platform ->+          case seg of+           Text              -> text "4,0x90"+           ReadOnlyData16    -> int 16+           CString           -> int 1+           _                 -> int 4+       | otherwise ->+          case seg of+           ReadOnlyData16    -> int 16+           CString           -> int 1+           _                 -> int 8++pprDataItem :: CmmLit -> SDoc+pprDataItem lit = sdocWithDynFlags $ \dflags -> pprDataItem' dflags lit++pprDataItem' :: DynFlags -> CmmLit -> SDoc+pprDataItem' dflags lit+  = vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit)+    where+        platform = targetPlatform dflags+        imm = litToImm lit++        -- These seem to be common:+        ppr_item II8   _ = [text "\t.byte\t" <> pprImm imm]+        ppr_item II16  _ = [text "\t.word\t" <> pprImm imm]+        ppr_item II32  _ = [text "\t.long\t" <> pprImm imm]++        ppr_item FF32  (CmmFloat r _)+           = let bs = floatToBytes (fromRational r)+             in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs++        ppr_item FF64 (CmmFloat r _)+           = let bs = doubleToBytes (fromRational r)+             in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs++        ppr_item II64 _+            = case platformOS platform of+              OSDarwin+               | target32Bit platform ->+                  case lit of+                  CmmInt x _ ->+                      [text "\t.long\t"+                          <> int (fromIntegral (fromIntegral x :: Word32)),+                       text "\t.long\t"+                          <> int (fromIntegral+                              (fromIntegral (x `shiftR` 32) :: Word32))]+                  _ -> panic "X86.Ppr.ppr_item: no match for II64"+               | otherwise ->+                  [text "\t.quad\t" <> pprImm imm]+              _+               | target32Bit platform ->+                  [text "\t.quad\t" <> pprImm imm]+               | otherwise ->+                  -- x86_64: binutils can't handle the R_X86_64_PC64+                  -- relocation type, which means we can't do+                  -- pc-relative 64-bit addresses. Fortunately we're+                  -- assuming the small memory model, in which all such+                  -- offsets will fit into 32 bits, so we have to stick+                  -- to 32-bit offset fields and modify the RTS+                  -- appropriately+                  --+                  -- See Note [x86-64-relative] in includes/rts/storage/InfoTables.h+                  --+                  case lit of+                  -- A relative relocation:+                  CmmLabelDiffOff _ _ _ ->+                      [text "\t.long\t" <> pprImm imm,+                       text "\t.long\t0"]+                  _ ->+                      [text "\t.quad\t" <> pprImm imm]++        ppr_item _ _+                = panic "X86.Ppr.ppr_item: no match"+++asmComment :: SDoc -> SDoc+asmComment c = ifPprDebug $ text "# " <> c++pprInstr :: Instr -> SDoc++pprInstr (COMMENT s)+   = asmComment (ftext s)++pprInstr (LOCATION file line col _name)+   = text "\t.loc " <> ppr file <+> ppr line <+> ppr col++pprInstr (DELTA d)+   = asmComment $ text ("\tdelta = " ++ show d)++pprInstr (NEWBLOCK _)+   = panic "PprMach.pprInstr: NEWBLOCK"++pprInstr (UNWIND lbl d)+   = asmComment (text "\tunwind = " <> ppr d)+     $$ ppr lbl <> colon++pprInstr (LDATA _ _)+   = panic "PprMach.pprInstr: LDATA"++{-+pprInstr (SPILL reg slot)+   = hcat [+        text "\tSPILL",+        char ' ',+        pprUserReg reg,+        comma,+        text "SLOT" <> parens (int slot)]++pprInstr (RELOAD slot reg)+   = hcat [+        text "\tRELOAD",+        char ' ',+        text "SLOT" <> parens (int slot),+        comma,+        pprUserReg reg]+-}++-- Replace 'mov $0x0,%reg' by 'xor %reg,%reg', which is smaller and cheaper.+-- The code generator catches most of these already, but not all.+pprInstr (MOV format (OpImm (ImmInt 0)) dst@(OpReg _))+  = pprInstr (XOR format' dst dst)+  where format' = case format of+          II64 -> II32          -- 32-bit version is equivalent, and smaller+          _    -> format+pprInstr (MOV format src dst)+  = pprFormatOpOp (sLit "mov") format src dst++pprInstr (CMOV cc format src dst)+  = pprCondOpReg (sLit "cmov") format cc src dst++pprInstr (MOVZxL II32 src dst) = pprFormatOpOp (sLit "mov") II32 src dst+        -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple+        -- movl.  But we represent it as a MOVZxL instruction, because+        -- the reg alloc would tend to throw away a plain reg-to-reg+        -- move, and we still want it to do that.++pprInstr (MOVZxL formats src dst)+  = pprFormatOpOpCoerce (sLit "movz") formats II32 src dst+        -- zero-extension only needs to extend to 32 bits: on x86_64,+        -- the remaining zero-extension to 64 bits is automatic, and the 32-bit+        -- instruction is shorter.++pprInstr (MOVSxL formats src dst)+  = sdocWithPlatform $ \platform ->+    pprFormatOpOpCoerce (sLit "movs") formats (archWordFormat (target32Bit platform)) src dst++-- here we do some patching, since the physical registers are only set late+-- in the code generation.+pprInstr (LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))+  | reg1 == reg3+  = pprFormatOpOp (sLit "add") format (OpReg reg2) dst++pprInstr (LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))+  | reg2 == reg3+  = pprFormatOpOp (sLit "add") format (OpReg reg1) dst++pprInstr (LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3))+  | reg1 == reg3+  = pprInstr (ADD format (OpImm displ) dst)++pprInstr (LEA format src dst) = pprFormatOpOp (sLit "lea") format src dst++pprInstr (ADD format (OpImm (ImmInt (-1))) dst)+  = pprFormatOp (sLit "dec") format dst+pprInstr (ADD format (OpImm (ImmInt 1)) dst)+  = pprFormatOp (sLit "inc") format dst+pprInstr (ADD format src dst) = pprFormatOpOp (sLit "add") format src dst+pprInstr (ADC format src dst) = pprFormatOpOp (sLit "adc") format src dst+pprInstr (SUB format src dst) = pprFormatOpOp (sLit "sub") format src dst+pprInstr (SBB format src dst) = pprFormatOpOp (sLit "sbb") format src dst+pprInstr (IMUL format op1 op2) = pprFormatOpOp (sLit "imul") format op1 op2++pprInstr (ADD_CC format src dst)+  = pprFormatOpOp (sLit "add") format src dst+pprInstr (SUB_CC format src dst)+  = pprFormatOpOp (sLit "sub") format src dst++{- A hack.  The Intel documentation says that "The two and three+   operand forms [of IMUL] may also be used with unsigned operands+   because the lower half of the product is the same regardless if+   (sic) the operands are signed or unsigned.  The CF and OF flags,+   however, cannot be used to determine if the upper half of the+   result is non-zero."  So there.+-}++-- Use a 32-bit instruction when possible as it saves a byte.+-- Notably, extracting the tag bits of a pointer has this form.+-- TODO: we could save a byte in a subsequent CMP instruction too,+-- but need something like a peephole pass for this+pprInstr (AND II64 src@(OpImm (ImmInteger mask)) dst)+  | 0 <= mask && mask < 0xffffffff+    = pprInstr (AND II32 src dst)+pprInstr (AND FF32 src dst) = pprOpOp (sLit "andps") FF32 src dst+pprInstr (AND FF64 src dst) = pprOpOp (sLit "andpd") FF64 src dst+pprInstr (AND format src dst) = pprFormatOpOp (sLit "and") format src dst+pprInstr (OR  format src dst) = pprFormatOpOp (sLit "or")  format src dst++pprInstr (XOR FF32 src dst) = pprOpOp (sLit "xorps") FF32 src dst+pprInstr (XOR FF64 src dst) = pprOpOp (sLit "xorpd") FF64 src dst+pprInstr (XOR format src dst) = pprFormatOpOp (sLit "xor")  format src dst++pprInstr (POPCNT format src dst) = pprOpOp (sLit "popcnt") format src (OpReg dst)+pprInstr (BSF format src dst)    = pprOpOp (sLit "bsf")    format src (OpReg dst)+pprInstr (BSR format src dst)    = pprOpOp (sLit "bsr")    format src (OpReg dst)++pprInstr (PREFETCH NTA format src ) = pprFormatOp_ (sLit "prefetchnta") format src+pprInstr (PREFETCH Lvl0 format src) = pprFormatOp_ (sLit "prefetcht0") format src+pprInstr (PREFETCH Lvl1 format src) = pprFormatOp_ (sLit "prefetcht1") format src+pprInstr (PREFETCH Lvl2 format src) = pprFormatOp_ (sLit "prefetcht2") format src++pprInstr (NOT format op) = pprFormatOp (sLit "not") format op+pprInstr (BSWAP format op) = pprFormatOp (sLit "bswap") format (OpReg op)+pprInstr (NEGI format op) = pprFormatOp (sLit "neg") format op++pprInstr (SHL format src dst) = pprShift (sLit "shl") format src dst+pprInstr (SAR format src dst) = pprShift (sLit "sar") format src dst+pprInstr (SHR format src dst) = pprShift (sLit "shr") format src dst++pprInstr (BT  format imm src) = pprFormatImmOp (sLit "bt") format imm src++pprInstr (CMP format src dst)+  | isFloatFormat format =  pprFormatOpOp (sLit "ucomi") format src dst -- SSE2+  | otherwise     =  pprFormatOpOp (sLit "cmp")   format src dst++pprInstr (TEST format src dst) = sdocWithPlatform $ \platform ->+  let format' = case (src,dst) of+        -- Match instructions like 'test $0x3,%esi' or 'test $0x7,%rbx'.+        -- We can replace them by equivalent, but smaller instructions+        -- by reducing the size of the immediate operand as far as possible.+        -- (We could handle masks larger than a single byte too,+        -- but it would complicate the code considerably+        -- and tag checks are by far the most common case.)+        -- The mask must have the high bit clear for this smaller encoding+        -- to be completely equivalent to the original; in particular so+        -- that the signed comparison condition bits are the same as they+        -- would be if doing a full word comparison. See Trac #13425.+        (OpImm (ImmInteger mask), OpReg dstReg)+          | 0 <= mask && mask < 128 -> minSizeOfReg platform dstReg+        _ -> format+  in pprFormatOpOp (sLit "test") format' src dst+  where+    minSizeOfReg platform (RegReal (RealRegSingle i))+      | target32Bit platform && i <= 3        = II8  -- al, bl, cl, dl+      | target32Bit platform && i <= 7        = II16 -- si, di, bp, sp+      | not (target32Bit platform) && i <= 15 = II8  -- al .. r15b+    minSizeOfReg _ _ = format                 -- other++pprInstr (PUSH format op) = pprFormatOp (sLit "push") format op+pprInstr (POP format op) = pprFormatOp (sLit "pop") format op++-- both unused (SDM):+-- pprInstr PUSHA = text "\tpushal"+-- pprInstr POPA = text "\tpopal"++pprInstr NOP = text "\tnop"+pprInstr (CLTD II32) = text "\tcltd"+pprInstr (CLTD II64) = text "\tcqto"++pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op)++pprInstr (JXX cond blockid)+  = pprCondInstr (sLit "j") cond (ppr lab)+  where lab = mkAsmTempLabel (getUnique blockid)++pprInstr        (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm)++pprInstr        (JMP (OpImm imm) _) = text "\tjmp " <> pprImm imm+pprInstr (JMP op _)          = sdocWithPlatform $ \platform ->+                               text "\tjmp *"+                                   <> pprOperand (archWordFormat (target32Bit platform)) op+pprInstr (JMP_TBL op _ _ _)  = pprInstr (JMP op [])+pprInstr        (CALL (Left imm) _)    = text "\tcall " <> pprImm imm+pprInstr (CALL (Right reg) _)   = sdocWithPlatform $ \platform ->+                                  text "\tcall *"+                                      <> pprReg (archWordFormat (target32Bit platform)) reg++pprInstr (IDIV fmt op)   = pprFormatOp (sLit "idiv") fmt op+pprInstr (DIV fmt op)    = pprFormatOp (sLit "div")  fmt op+pprInstr (IMUL2 fmt op)  = pprFormatOp (sLit "imul") fmt op++-- x86_64 only+pprInstr (MUL format op1 op2) = pprFormatOpOp (sLit "mul") format op1 op2+pprInstr (MUL2 format op) = pprFormatOp (sLit "mul") format op++pprInstr (FDIV format op1 op2) = pprFormatOpOp (sLit "div") format op1 op2++pprInstr (CVTSS2SD from to)      = pprRegReg (sLit "cvtss2sd") from to+pprInstr (CVTSD2SS from to)      = pprRegReg (sLit "cvtsd2ss") from to+pprInstr (CVTTSS2SIQ fmt from to) = pprFormatFormatOpReg (sLit "cvttss2si") FF32 fmt from to+pprInstr (CVTTSD2SIQ fmt from to) = pprFormatFormatOpReg (sLit "cvttsd2si") FF64 fmt from to+pprInstr (CVTSI2SS fmt from to)   = pprFormatOpReg (sLit "cvtsi2ss") fmt from to+pprInstr (CVTSI2SD fmt from to)   = pprFormatOpReg (sLit "cvtsi2sd") fmt from to++    -- FETCHGOT for PIC on ELF platforms+pprInstr (FETCHGOT reg)+   = vcat [ text "\tcall 1f",+            hcat [ text "1:\tpopl\t", pprReg II32 reg ],+            hcat [ text "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), ",+                   pprReg II32 reg ]+          ]++    -- FETCHPC for PIC on Darwin/x86+    -- get the instruction pointer into a register+    -- (Terminology note: the IP is called Program Counter on PPC,+    --  and it's a good thing to use the same name on both platforms)+pprInstr (FETCHPC reg)+   = vcat [ text "\tcall 1f",+            hcat [ text "1:\tpopl\t", pprReg II32 reg ]+          ]+++-- -----------------------------------------------------------------------------+-- i386 floating-point++-- Simulating a flat register set on the x86 FP stack is tricky.+-- you have to free %st(7) before pushing anything on the FP reg stack+-- so as to preclude the possibility of a FP stack overflow exception.+pprInstr g@(GMOV src dst)+   | src == dst+   = empty+   | otherwise+   = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])++-- GLD fmt addr dst ==> FLDsz addr ; FSTP (dst+1)+pprInstr g@(GLD fmt addr dst)+ = pprG g (hcat [gtab, text "fld", pprFormat_x87 fmt, gsp,+                 pprAddr addr, gsemi, gpop dst 1])++-- GST fmt src addr ==> FLD dst ; FSTPsz addr+pprInstr g@(GST fmt src addr)+ | src == fake0 && fmt /= FF80 -- fstt instruction doesn't exist+ = pprG g (hcat [gtab,+                 text "fst", pprFormat_x87 fmt, gsp, pprAddr addr])+ | otherwise+ = pprG g (hcat [gtab, gpush src 0, gsemi,+                 text "fstp", pprFormat_x87 fmt, gsp, pprAddr addr])++pprInstr g@(GLDZ dst)+ = pprG g (hcat [gtab, text "fldz ; ", gpop dst 1])+pprInstr g@(GLD1 dst)+ = pprG g (hcat [gtab, text "fld1 ; ", gpop dst 1])++pprInstr (GFTOI src dst)+   = pprInstr (GDTOI src dst)++pprInstr g@(GDTOI src dst)+   = pprG g (vcat [+         hcat [gtab, text "subl $8, %esp ; fnstcw 4(%esp)"],+         hcat [gtab, gpush src 0],+         hcat [gtab, text "movzwl 4(%esp), ", reg,+                     text " ; orl $0xC00, ", reg],+         hcat [gtab, text "movl ", reg, text ", 0(%esp) ; fldcw 0(%esp)"],+         hcat [gtab, text "fistpl 0(%esp)"],+         hcat [gtab, text "fldcw 4(%esp) ; movl 0(%esp), ", reg],+         hcat [gtab, text "addl $8, %esp"]+     ])+   where+     reg = pprReg II32 dst++pprInstr (GITOF src dst)+   = pprInstr (GITOD src dst)++pprInstr g@(GITOD src dst)+   = pprG g (hcat [gtab, text "pushl ", pprReg II32 src,+                   text " ; fildl (%esp) ; ",+                   gpop dst 1, text " ; addl $4,%esp"])++pprInstr g@(GDTOF src dst)+  = pprG g (vcat [gtab <> gpush src 0,+                  gtab <> text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ;",+                  gtab <> gpop dst 1])++{- Gruesome swamp follows.  If you're unfortunate enough to have ventured+   this far into the jungle AND you give a Rat's Ass (tm) what's going+   on, here's the deal.  Generate code to do a floating point comparison+   of src1 and src2, of kind cond, and set the Zero flag if true.++   The complications are to do with handling NaNs correctly.  We want the+   property that if either argument is NaN, then the result of the+   comparison is False ... except if we're comparing for inequality,+   in which case the answer is True.++   Here's how the general (non-inequality) case works.  As an+   example, consider generating the an equality test:++     pushl %eax         -- we need to mess with this+     <get src1 to top of FPU stack>+     fcomp <src2 location in FPU stack> and pop pushed src1+                -- Result of comparison is in FPU Status Register bits+                -- C3 C2 and C0+     fstsw %ax  -- Move FPU Status Reg to %ax+     sahf       -- move C3 C2 C0 from %ax to integer flag reg+     -- now the serious magic begins+     setpo %ah     -- %ah = if comparable(neither arg was NaN) then 1 else 0+     sete  %al     -- %al = if arg1 == arg2 then 1 else 0+     andb %ah,%al  -- %al &= %ah+                   -- so %al == 1 iff (comparable && same); else it holds 0+     decb %al      -- %al == 0, ZeroFlag=1  iff (comparable && same);+                      else %al == 0xFF, ZeroFlag=0+     -- the zero flag is now set as we desire.+     popl %eax++   The special case of inequality differs thusly:++     setpe %ah     -- %ah = if incomparable(either arg was NaN) then 1 else 0+     setne %al     -- %al = if arg1 /= arg2 then 1 else 0+     orb %ah,%al   -- %al = if (incomparable || different) then 1 else 0+     decb %al      -- if (incomparable || different) then (%al == 0, ZF=1)+                                                     else (%al == 0xFF, ZF=0)+-}+pprInstr g@(GCMP cond src1 src2)+   | case cond of { NE -> True; _ -> False }+   = pprG g (vcat [+        hcat [gtab, text "pushl %eax ; ",gpush src1 0],+        hcat [gtab, text "fcomp ", greg src2 1,+                    text "; fstsw %ax ; sahf ;  setpe %ah"],+        hcat [gtab, text "setne %al ;  ",+              text "orb %ah,%al ;  decb %al ;  popl %eax"]+    ])+   | otherwise+   = pprG g (vcat [+        hcat [gtab, text "pushl %eax ; ",gpush src1 0],+        hcat [gtab, text "fcomp ", greg src2 1,+                    text "; fstsw %ax ; sahf ;  setpo %ah"],+        hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ;  ",+              text "andb %ah,%al ;  decb %al ;  popl %eax"]+    ])+    where+        {- On the 486, the flags set by FP compare are the unsigned ones!+           (This looks like a HACK to me.  WDP 96/03)+        -}+        fix_FP_cond :: Cond -> Cond+        fix_FP_cond GE   = GEU+        fix_FP_cond GTT  = GU+        fix_FP_cond LTT  = LU+        fix_FP_cond LE   = LEU+        fix_FP_cond EQQ  = EQQ+        fix_FP_cond NE   = NE+        fix_FP_cond _    = panic "X86.Ppr.fix_FP_cond: no match"+        -- there should be no others+++pprInstr g@(GABS _ src dst)+   = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])++pprInstr g@(GNEG _ src dst)+   = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])++pprInstr g@(GSQRT fmt src dst)+   = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$+             hcat [gtab, gcoerceto fmt, gpop dst 1])++pprInstr g@(GSIN fmt l1 l2 src dst)+   = pprG g (pprTrigOp "fsin" False l1 l2 src dst fmt)++pprInstr g@(GCOS fmt l1 l2 src dst)+   = pprG g (pprTrigOp "fcos" False l1 l2 src dst fmt)++pprInstr g@(GTAN fmt l1 l2 src dst)+   = pprG g (pprTrigOp "fptan" True l1 l2 src dst fmt)++-- In the translations for GADD, GMUL, GSUB and GDIV,+-- the first two cases are mere optimisations.  The otherwise clause+-- generates correct code under all circumstances.++pprInstr g@(GADD _ src1 src2 dst)+   | src1 == dst+   = pprG g (text "\t#GADD-xxxcase1" $$+             hcat [gtab, gpush src2 0,+                   text " ; faddp %st(0),", greg src1 1])+   | src2 == dst+   = pprG g (text "\t#GADD-xxxcase2" $$+             hcat [gtab, gpush src1 0,+                   text " ; faddp %st(0),", greg src2 1])+   | otherwise+   = pprG g (hcat [gtab, gpush src1 0,+                   text " ; fadd ", greg src2 1, text ",%st(0)",+                   gsemi, gpop dst 1])+++pprInstr g@(GMUL _ src1 src2 dst)+   | src1 == dst+   = pprG g (text "\t#GMUL-xxxcase1" $$+             hcat [gtab, gpush src2 0,+                   text " ; fmulp %st(0),", greg src1 1])+   | src2 == dst+   = pprG g (text "\t#GMUL-xxxcase2" $$+             hcat [gtab, gpush src1 0,+                   text " ; fmulp %st(0),", greg src2 1])+   | otherwise+   = pprG g (hcat [gtab, gpush src1 0,+             text " ; fmul ", greg src2 1, text ",%st(0)",+             gsemi, gpop dst 1])+++pprInstr g@(GSUB _ src1 src2 dst)+   | src1 == dst+   = pprG g (text "\t#GSUB-xxxcase1" $$+             hcat [gtab, gpush src2 0,+                   text " ; fsubrp %st(0),", greg src1 1])+   | src2 == dst+   = pprG g (text "\t#GSUB-xxxcase2" $$+             hcat [gtab, gpush src1 0,+                   text " ; fsubp %st(0),", greg src2 1])+   | otherwise+   = pprG g (hcat [gtab, gpush src1 0,+                   text " ; fsub ", greg src2 1, text ",%st(0)",+                   gsemi, gpop dst 1])+++pprInstr g@(GDIV _ src1 src2 dst)+   | src1 == dst+   = pprG g (text "\t#GDIV-xxxcase1" $$+             hcat [gtab, gpush src2 0,+                   text " ; fdivrp %st(0),", greg src1 1])+   | src2 == dst+   = pprG g (text "\t#GDIV-xxxcase2" $$+             hcat [gtab, gpush src1 0,+                   text " ; fdivp %st(0),", greg src2 1])+   | otherwise+   = pprG g (hcat [gtab, gpush src1 0,+                   text " ; fdiv ", greg src2 1, text ",%st(0)",+                   gsemi, gpop dst 1])+++pprInstr GFREE+   = vcat [ text "\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)",+            text "\tffree %st(4) ;ffree %st(5)"+          ]++-- Atomics++pprInstr (LOCK i) = text "\tlock" $$ pprInstr i++pprInstr MFENCE = text "\tmfence"++pprInstr (XADD format src dst) = pprFormatOpOp (sLit "xadd") format src dst++pprInstr (CMPXCHG format src dst)+   = pprFormatOpOp (sLit "cmpxchg") format src dst++pprInstr _+        = panic "X86.Ppr.pprInstr: no match"+++pprTrigOp :: String -> Bool -> CLabel -> CLabel+          -> Reg -> Reg -> Format -> SDoc+pprTrigOp op -- fsin, fcos or fptan+          isTan -- we need a couple of extra steps if we're doing tan+          l1 l2 -- internal labels for us to use+          src dst fmt+    = -- We'll be needing %eax later on+      hcat [gtab, text "pushl %eax;"] $$+      -- tan is going to use an extra space on the FP stack+      (if isTan then hcat [gtab, text "ffree %st(6)"] else empty) $$+      -- First put the value in %st(0) and try to apply the op to it+      hcat [gpush src 0, text ("; " ++ op)] $$+      -- Now look to see if C2 was set (overflow, |value| >= 2^63)+      hcat [gtab, text "fnstsw %ax"] $$+      hcat [gtab, text "test   $0x400,%eax"] $$+      -- If we were in bounds then jump to the end+      hcat [gtab, text "je     " <> ppr l1] $$+      -- Otherwise we need to shrink the value. Start by+      -- loading pi, doubleing it (by adding it to itself),+      -- and then swapping pi with the value, so the value we+      -- want to apply op to is in %st(0) again+      hcat [gtab, text "ffree %st(7); fldpi"] $$+      hcat [gtab, text "fadd   %st(0),%st"] $$+      hcat [gtab, text "fxch   %st(1)"] $$+      -- Now we have a loop in which we make the value smaller,+      -- see if it's small enough, and loop if not+      (ppr l2 <> char ':') $$+      hcat [gtab, text "fprem1"] $$+      -- My Debian libc uses fstsw here for the tan code, but I can't+      -- see any reason why it should need to be different for tan.+      hcat [gtab, text "fnstsw %ax"] $$+      hcat [gtab, text "test   $0x400,%eax"] $$+      hcat [gtab, text "jne    " <> ppr l2] $$+      hcat [gtab, text "fstp   %st(1)"] $$+      hcat [gtab, text op] $$+      (ppr l1 <> char ':') $$+      -- Pop the 1.0 tan gave us+      (if isTan then hcat [gtab, text "fstp %st(0)"] else empty) $$+      -- Restore %eax+      hcat [gtab, text "popl %eax;"] $$+      -- And finally make the result the right size+      hcat [gtab, gcoerceto fmt, gpop dst 1]++--------------------------++-- coerce %st(0) to the specified size+gcoerceto :: Format -> SDoc+gcoerceto FF64 = empty+gcoerceto FF32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "+gcoerceto _    = panic "X86.Ppr.gcoerceto: no match"++gpush :: Reg -> RegNo -> SDoc+gpush reg offset+   = hcat [text "fld ", greg reg offset]++gpop :: Reg -> RegNo -> SDoc+gpop reg offset+   = hcat [text "fstp ", greg reg offset]++greg :: Reg -> RegNo -> SDoc+greg reg offset = text "%st(" <> int (gregno reg - firstfake+offset) <> char ')'++gsemi :: SDoc+gsemi = text " ; "++gtab :: SDoc+gtab  = char '\t'++gsp :: SDoc+gsp   = char ' '++gregno :: Reg -> RegNo+gregno (RegReal (RealRegSingle i)) = i+gregno _           = --pprPanic "gregno" (ppr other)+                     999   -- bogus; only needed for debug printing++pprG :: Instr -> SDoc -> SDoc+pprG fake actual+   = (char '#' <> pprGInstr fake) $$ actual+++pprGInstr :: Instr -> SDoc+pprGInstr (GMOV src dst)   = pprFormatRegReg (sLit "gmov") FF64 src dst+pprGInstr (GLD fmt src dst) = pprFormatAddrReg (sLit "gld") fmt src dst+pprGInstr (GST fmt src dst) = pprFormatRegAddr (sLit "gst") fmt src dst++pprGInstr (GLDZ dst) = pprFormatReg (sLit "gldz") FF64 dst+pprGInstr (GLD1 dst) = pprFormatReg (sLit "gld1") FF64 dst++pprGInstr (GFTOI src dst) = pprFormatFormatRegReg (sLit "gftoi") FF32 II32 src dst+pprGInstr (GDTOI src dst) = pprFormatFormatRegReg (sLit "gdtoi") FF64 II32 src dst++pprGInstr (GITOF src dst) = pprFormatFormatRegReg (sLit "gitof") II32 FF32 src dst+pprGInstr (GITOD src dst) = pprFormatFormatRegReg (sLit "gitod") II32 FF64 src dst+pprGInstr (GDTOF src dst) = pprFormatFormatRegReg (sLit "gdtof") FF64 FF32 src dst++pprGInstr (GCMP co src dst) = pprCondRegReg (sLit "gcmp_") FF64 co src dst+pprGInstr (GABS fmt src dst) = pprFormatRegReg (sLit "gabs") fmt src dst+pprGInstr (GNEG fmt src dst) = pprFormatRegReg (sLit "gneg") fmt src dst+pprGInstr (GSQRT fmt src dst) = pprFormatRegReg (sLit "gsqrt") fmt src dst+pprGInstr (GSIN fmt _ _ src dst) = pprFormatRegReg (sLit "gsin") fmt src dst+pprGInstr (GCOS fmt _ _ src dst) = pprFormatRegReg (sLit "gcos") fmt src dst+pprGInstr (GTAN fmt _ _ src dst) = pprFormatRegReg (sLit "gtan") fmt src dst++pprGInstr (GADD fmt src1 src2 dst) = pprFormatRegRegReg (sLit "gadd") fmt src1 src2 dst+pprGInstr (GSUB fmt src1 src2 dst) = pprFormatRegRegReg (sLit "gsub") fmt src1 src2 dst+pprGInstr (GMUL fmt src1 src2 dst) = pprFormatRegRegReg (sLit "gmul") fmt src1 src2 dst+pprGInstr (GDIV fmt src1 src2 dst) = pprFormatRegRegReg (sLit "gdiv") fmt src1 src2 dst++pprGInstr _ = panic "X86.Ppr.pprGInstr: no match"++pprDollImm :: Imm -> SDoc+pprDollImm i = text "$" <> pprImm i+++pprOperand :: Format -> Operand -> SDoc+pprOperand f (OpReg r)   = pprReg f r+pprOperand _ (OpImm i)   = pprDollImm i+pprOperand _ (OpAddr ea) = pprAddr ea+++pprMnemonic_  :: LitString -> SDoc+pprMnemonic_ name =+   char '\t' <> ptext name <> space+++pprMnemonic  :: LitString -> Format -> SDoc+pprMnemonic name format =+   char '\t' <> ptext name <> pprFormat format <> space+++pprFormatImmOp :: LitString -> Format -> Imm -> Operand -> SDoc+pprFormatImmOp name format imm op1+  = hcat [+        pprMnemonic name format,+        char '$',+        pprImm imm,+        comma,+        pprOperand format op1+    ]+++pprFormatOp_ :: LitString -> Format -> Operand -> SDoc+pprFormatOp_ name format op1+  = hcat [+        pprMnemonic_ name ,+        pprOperand format op1+    ]++pprFormatOp :: LitString -> Format -> Operand -> SDoc+pprFormatOp name format op1+  = hcat [+        pprMnemonic name format,+        pprOperand format op1+    ]+++pprFormatOpOp :: LitString -> Format -> Operand -> Operand -> SDoc+pprFormatOpOp name format op1 op2+  = hcat [+        pprMnemonic name format,+        pprOperand format op1,+        comma,+        pprOperand format op2+    ]+++pprOpOp :: LitString -> Format -> Operand -> Operand -> SDoc+pprOpOp name format op1 op2+  = hcat [+        pprMnemonic_ name,+        pprOperand format op1,+        comma,+        pprOperand format op2+    ]+++pprFormatReg :: LitString -> Format -> Reg -> SDoc+pprFormatReg name format reg1+  = hcat [+        pprMnemonic name format,+        pprReg format reg1+    ]+++pprFormatRegReg :: LitString -> Format -> Reg -> Reg -> SDoc+pprFormatRegReg name format reg1 reg2+  = hcat [+        pprMnemonic name format,+        pprReg format reg1,+        comma,+        pprReg format reg2+    ]+++pprRegReg :: LitString -> Reg -> Reg -> SDoc+pprRegReg name reg1 reg2+  = sdocWithPlatform $ \platform ->+    hcat [+        pprMnemonic_ name,+        pprReg (archWordFormat (target32Bit platform)) reg1,+        comma,+        pprReg (archWordFormat (target32Bit platform)) reg2+    ]+++pprFormatOpReg :: LitString -> Format -> Operand -> Reg -> SDoc+pprFormatOpReg name format op1 reg2+  = sdocWithPlatform $ \platform ->+    hcat [+        pprMnemonic name format,+        pprOperand format op1,+        comma,+        pprReg (archWordFormat (target32Bit platform)) reg2+    ]++pprCondOpReg :: LitString -> Format -> Cond -> Operand -> Reg -> SDoc+pprCondOpReg name format cond op1 reg2+  = hcat [+        char '\t',+        ptext name,+        pprCond cond,+        space,+        pprOperand format op1,+        comma,+        pprReg format reg2+    ]++pprCondRegReg :: LitString -> Format -> Cond -> Reg -> Reg -> SDoc+pprCondRegReg name format cond reg1 reg2+  = hcat [+        char '\t',+        ptext name,+        pprCond cond,+        space,+        pprReg format reg1,+        comma,+        pprReg format reg2+    ]++pprFormatFormatRegReg :: LitString -> Format -> Format -> Reg -> Reg -> SDoc+pprFormatFormatRegReg name format1 format2 reg1 reg2+  = hcat [+        char '\t',+        ptext name,+        pprFormat format1,+        pprFormat format2,+        space,+        pprReg format1 reg1,+        comma,+        pprReg format2 reg2+    ]++pprFormatFormatOpReg :: LitString -> Format -> Format -> Operand -> Reg -> SDoc+pprFormatFormatOpReg name format1 format2 op1 reg2+  = hcat [+        pprMnemonic name format2,+        pprOperand format1 op1,+        comma,+        pprReg format2 reg2+    ]++pprFormatRegRegReg :: LitString -> Format -> Reg -> Reg -> Reg -> SDoc+pprFormatRegRegReg name format reg1 reg2 reg3+  = hcat [+        pprMnemonic name format,+        pprReg format reg1,+        comma,+        pprReg format reg2,+        comma,+        pprReg format reg3+    ]+++pprFormatAddrReg :: LitString -> Format -> AddrMode -> Reg -> SDoc+pprFormatAddrReg name format op dst+  = hcat [+        pprMnemonic name format,+        pprAddr op,+        comma,+        pprReg format dst+    ]+++pprFormatRegAddr :: LitString -> Format -> Reg -> AddrMode -> SDoc+pprFormatRegAddr name format src op+  = hcat [+        pprMnemonic name format,+        pprReg format src,+        comma,+        pprAddr op+    ]+++pprShift :: LitString -> Format -> Operand -> Operand -> SDoc+pprShift name format src dest+  = hcat [+        pprMnemonic name format,+        pprOperand II8 src,  -- src is 8-bit sized+        comma,+        pprOperand format dest+    ]+++pprFormatOpOpCoerce :: LitString -> Format -> Format -> Operand -> Operand -> SDoc+pprFormatOpOpCoerce name format1 format2 op1 op2+  = hcat [ char '\t', ptext name, pprFormat format1, pprFormat format2, space,+        pprOperand format1 op1,+        comma,+        pprOperand format2 op2+    ]+++pprCondInstr :: LitString -> Cond -> SDoc -> SDoc+pprCondInstr name cond arg+  = hcat [ char '\t', ptext name, pprCond cond, space, arg]+
+ nativeGen/X86/RegInfo.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE CPP #-}+module X86.RegInfo (+        mkVirtualReg,+        regDotColor+)++where++#include "nativeGen/NCG.h"+#include "HsVersions.h"++import Format+import Reg++import Outputable+import Platform+import Unique++import UniqFM+import X86.Regs+++mkVirtualReg :: Unique -> Format -> VirtualReg+mkVirtualReg u format+   = case format of+        FF32    -> VirtualRegSSE u+        FF64    -> VirtualRegSSE u+        FF80    -> VirtualRegD   u+        _other  -> VirtualRegI   u++regDotColor :: Platform -> RealReg -> SDoc+regDotColor platform reg+ = let Just str = lookupUFM (regColors platform) reg+   in text str++regColors :: Platform -> UniqFM [Char]+regColors platform = listToUFM (normalRegColors platform ++ fpRegColors)++normalRegColors :: Platform -> [(Reg,String)]+normalRegColors platform+ | target32Bit platform = [ (eax, "#00ff00")+                          , (ebx, "#0000ff")+                          , (ecx, "#00ffff")+                          , (edx, "#0080ff") ]+ | otherwise            = [ (rax, "#00ff00"), (eax, "#00ff00")+                          , (rbx, "#0000ff"), (ebx, "#0000ff")+                          , (rcx, "#00ffff"), (ecx, "#00ffff")+                          , (rdx, "#0080ff"), (edx, "#00ffff")+                          , (r8,  "#00ff80")+                          , (r9,  "#008080")+                          , (r10, "#0040ff")+                          , (r11, "#00ff40")+                          , (r12, "#008040")+                          , (r13, "#004080")+                          , (r14, "#004040")+                          , (r15, "#002080") ]++fpRegColors :: [(Reg,String)]+fpRegColors =+        [ (fake0, "#ff00ff")+        , (fake1, "#ff00aa")+        , (fake2, "#aa00ff")+        , (fake3, "#aa00aa")+        , (fake4, "#ff0055")+        , (fake5, "#5500ff") ]++        ++ zip (map regSingle [24..39]) (repeat "red")
+ nativeGen/X86/Regs.hs view
@@ -0,0 +1,449 @@+{-# LANGUAGE CPP #-}++module X86.Regs (+        -- squeese functions for the graph allocator+        virtualRegSqueeze,+        realRegSqueeze,++        -- immediates+        Imm(..),+        strImmLit,+        litToImm,++        -- addressing modes+        AddrMode(..),+        addrOffset,++        -- registers+        spRel,+        argRegs,+        allArgRegs,+        allIntArgRegs,+        callClobberedRegs,+        instrClobberedRegs,+        allMachRegNos,+        classOfRealReg,+        showReg,++        -- machine specific+        EABase(..), EAIndex(..), addrModeRegs,++        eax, ebx, ecx, edx, esi, edi, ebp, esp,+        fake0, fake1, fake2, fake3, fake4, fake5, firstfake,++        rax, rbx, rcx, rdx, rsi, rdi, rbp, rsp,+        r8,  r9,  r10, r11, r12, r13, r14, r15,+        xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7,+        xmm8, xmm9, xmm10, xmm11, xmm12, xmm13, xmm14, xmm15,+        xmm,++        ripRel,+        allFPArgRegs,++        allocatableRegs+)++where++#include "nativeGen/NCG.h"+#include "HsVersions.h"++import CodeGen.Platform+import Reg+import RegClass++import Cmm+import CLabel           ( CLabel )+import DynFlags+import Outputable+import Platform++-- | regSqueeze_class reg+--      Calculuate the maximum number of register colors that could be+--      denied to a node of this class due to having this reg+--      as a neighbour.+--+{-# INLINE virtualRegSqueeze #-}+virtualRegSqueeze :: RegClass -> VirtualReg -> Int++virtualRegSqueeze cls vr+ = case cls of+        RcInteger+         -> case vr of+                VirtualRegI{}           -> 1+                VirtualRegHi{}          -> 1+                _other                  -> 0++        RcDouble+         -> case vr of+                VirtualRegD{}           -> 1+                VirtualRegF{}           -> 0+                _other                  -> 0++        RcDoubleSSE+         -> case vr of+                VirtualRegSSE{}         -> 1+                _other                  -> 0++        _other -> 0++{-# INLINE realRegSqueeze #-}+realRegSqueeze :: RegClass -> RealReg -> Int+realRegSqueeze cls rr+ = case cls of+        RcInteger+         -> case rr of+                RealRegSingle regNo+                        | regNo < firstfake -> 1+                        | otherwise     -> 0++                RealRegPair{}           -> 0++        RcDouble+         -> case rr of+                RealRegSingle regNo+                        | regNo >= firstfake && regNo <= lastfake -> 1+                        | otherwise     -> 0++                RealRegPair{}           -> 0++        RcDoubleSSE+         -> case rr of+                RealRegSingle regNo | regNo >= firstxmm -> 1+                _otherwise                        -> 0++        _other -> 0++-- -----------------------------------------------------------------------------+-- Immediates++data Imm+  = ImmInt      Int+  | ImmInteger  Integer     -- Sigh.+  | ImmCLbl     CLabel      -- AbstractC Label (with baggage)+  | ImmLit      SDoc        -- Simple string+  | ImmIndex    CLabel Int+  | ImmFloat    Rational+  | ImmDouble   Rational+  | ImmConstantSum Imm Imm+  | ImmConstantDiff Imm Imm+++strImmLit :: String -> Imm+strImmLit s = ImmLit (text s)+++litToImm :: CmmLit -> Imm+litToImm (CmmInt i w)        = ImmInteger (narrowS w i)+                -- narrow to the width: a CmmInt might be out of+                -- range, but we assume that ImmInteger only contains+                -- in-range values.  A signed value should be fine here.+litToImm (CmmFloat f W32)    = ImmFloat f+litToImm (CmmFloat f W64)    = ImmDouble f+litToImm (CmmLabel l)        = ImmCLbl l+litToImm (CmmLabelOff l off) = ImmIndex l off+litToImm (CmmLabelDiffOff l1 l2 off)+                             = ImmConstantSum+                               (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))+                               (ImmInt off)+litToImm _                   = panic "X86.Regs.litToImm: no match"++-- addressing modes ------------------------------------------------------------++data AddrMode+        = AddrBaseIndex EABase EAIndex Displacement+        | ImmAddr Imm Int++data EABase       = EABaseNone  | EABaseReg Reg | EABaseRip+data EAIndex      = EAIndexNone | EAIndex Reg Int+type Displacement = Imm+++addrOffset :: AddrMode -> Int -> Maybe AddrMode+addrOffset addr off+  = case addr of+      ImmAddr i off0      -> Just (ImmAddr i (off0 + off))++      AddrBaseIndex r i (ImmInt n) -> Just (AddrBaseIndex r i (ImmInt (n + off)))+      AddrBaseIndex r i (ImmInteger n)+        -> Just (AddrBaseIndex r i (ImmInt (fromInteger (n + toInteger off))))++      AddrBaseIndex r i (ImmCLbl lbl)+        -> Just (AddrBaseIndex r i (ImmIndex lbl off))++      AddrBaseIndex r i (ImmIndex lbl ix)+        -> Just (AddrBaseIndex r i (ImmIndex lbl (ix+off)))++      _ -> Nothing  -- in theory, shouldn't happen+++addrModeRegs :: AddrMode -> [Reg]+addrModeRegs (AddrBaseIndex b i _) =  b_regs ++ i_regs+  where+   b_regs = case b of { EABaseReg r -> [r]; _ -> [] }+   i_regs = case i of { EAIndex r _ -> [r]; _ -> [] }+addrModeRegs _ = []+++-- registers -------------------------------------------------------------------++-- @spRel@ gives us a stack relative addressing mode for volatile+-- temporaries and for excess call arguments.  @fpRel@, where+-- applicable, is the same but for the frame pointer.+++spRel :: DynFlags+      -> Int -- ^ desired stack offset in bytes, positive or negative+      -> AddrMode+spRel dflags n+ | target32Bit (targetPlatform dflags)+    = AddrBaseIndex (EABaseReg esp) EAIndexNone (ImmInt n)+ | otherwise+    = AddrBaseIndex (EABaseReg rsp) EAIndexNone (ImmInt n)++-- The register numbers must fit into 32 bits on x86, so that we can+-- use a Word32 to represent the set of free registers in the register+-- allocator.++firstfake, lastfake :: RegNo+firstfake = 16+lastfake  = 21++firstxmm :: RegNo+firstxmm  = 24++lastxmm :: Platform -> RegNo+lastxmm platform+ | target32Bit platform = 31+ | otherwise            = 39++lastint :: Platform -> RegNo+lastint platform+ | target32Bit platform = 7 -- not %r8..%r15+ | otherwise            = 15++intregnos :: Platform -> [RegNo]+intregnos platform = [0 .. lastint platform]++fakeregnos :: [RegNo]+fakeregnos  = [firstfake .. lastfake]++xmmregnos :: Platform -> [RegNo]+xmmregnos platform = [firstxmm  .. lastxmm platform]++floatregnos :: Platform -> [RegNo]+floatregnos platform = fakeregnos ++ xmmregnos platform+++-- argRegs is the set of regs which are read for an n-argument call to C.+-- For archs which pass all args on the stack (x86), is empty.+-- Sparc passes up to the first 6 args in regs.+argRegs :: RegNo -> [Reg]+argRegs _       = panic "MachRegs.argRegs(x86): should not be used!"++-- | The complete set of machine registers.+allMachRegNos :: Platform -> [RegNo]+allMachRegNos platform = intregnos platform ++ floatregnos platform++-- | Take the class of a register.+{-# INLINE classOfRealReg #-}+classOfRealReg :: Platform -> RealReg -> RegClass+-- On x86, we might want to have an 8-bit RegClass, which would+-- contain just regs 1-4 (the others don't have 8-bit versions).+-- However, we can get away without this at the moment because the+-- only allocatable integer regs are also 8-bit compatible (1, 3, 4).+classOfRealReg platform reg+ = case reg of+        RealRegSingle i+          | i <= lastint platform -> RcInteger+          | i <= lastfake         -> RcDouble+          | otherwise             -> RcDoubleSSE++        RealRegPair{}   -> panic "X86.Regs.classOfRealReg: RegPairs on this arch"++-- | Get the name of the register with this number.+showReg :: Platform -> RegNo -> String+showReg platform n+        | n >= firstxmm  = "%xmm" ++ show (n-firstxmm)+        | n >= firstfake = "%fake" ++ show (n-firstfake)+        | n >= 8         = "%r" ++ show n+        | otherwise      = regNames platform !! n++regNames :: Platform -> [String]+regNames platform+    = if target32Bit platform+      then ["%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "%ebp", "%esp"]+      else ["%rax", "%rbx", "%rcx", "%rdx", "%rsi", "%rdi", "%rbp", "%rsp"]++++-- machine specific ------------------------------------------------------------+++{-+Intel x86 architecture:+- All registers except 7 (esp) are available for use.+- Only ebx, esi, edi and esp are available across a C call (they are callee-saves).+- Registers 0-7 have 16-bit counterparts (ax, bx etc.)+- Registers 0-3 have 8 bit counterparts (ah, bh etc.)+- Registers fake0..fake5 are fakes; we pretend x86 has 6 conventionally-addressable+  fp registers, and 3-operand insns for them, and we translate this into+  real stack-based x86 fp code after register allocation.++The fp registers are all Double registers; we don't have any RcFloat class+regs.  @regClass@ barfs if you give it a VirtualRegF, and mkVReg above should+never generate them.+-}++fake0, fake1, fake2, fake3, fake4, fake5,+       eax, ebx, ecx, edx, esp, ebp, esi, edi :: Reg++eax   = regSingle 0+ebx   = regSingle 1+ecx   = regSingle 2+edx   = regSingle 3+esi   = regSingle 4+edi   = regSingle 5+ebp   = regSingle 6+esp   = regSingle 7+fake0 = regSingle 16+fake1 = regSingle 17+fake2 = regSingle 18+fake3 = regSingle 19+fake4 = regSingle 20+fake5 = regSingle 21++++{-+AMD x86_64 architecture:+- All 16 integer registers are addressable as 8, 16, 32 and 64-bit values:++  8     16    32    64+  ---------------------+  al    ax    eax   rax+  bl    bx    ebx   rbx+  cl    cx    ecx   rcx+  dl    dx    edx   rdx+  sil   si    esi   rsi+  dil   si    edi   rdi+  bpl   bp    ebp   rbp+  spl   sp    esp   rsp+  r10b  r10w  r10d  r10+  r11b  r11w  r11d  r11+  r12b  r12w  r12d  r12+  r13b  r13w  r13d  r13+  r14b  r14w  r14d  r14+  r15b  r15w  r15d  r15+-}++rax, rbx, rcx, rdx, rsp, rbp, rsi, rdi,+  r8, r9, r10, r11, r12, r13, r14, r15,+  xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7,+  xmm8, xmm9, xmm10, xmm11, xmm12, xmm13, xmm14, xmm15 :: Reg++rax   = regSingle 0+rbx   = regSingle 1+rcx   = regSingle 2+rdx   = regSingle 3+rsi   = regSingle 4+rdi   = regSingle 5+rbp   = regSingle 6+rsp   = regSingle 7+r8    = regSingle 8+r9    = regSingle 9+r10   = regSingle 10+r11   = regSingle 11+r12   = regSingle 12+r13   = regSingle 13+r14   = regSingle 14+r15   = regSingle 15+xmm0  = regSingle 24+xmm1  = regSingle 25+xmm2  = regSingle 26+xmm3  = regSingle 27+xmm4  = regSingle 28+xmm5  = regSingle 29+xmm6  = regSingle 30+xmm7  = regSingle 31+xmm8  = regSingle 32+xmm9  = regSingle 33+xmm10 = regSingle 34+xmm11 = regSingle 35+xmm12 = regSingle 36+xmm13 = regSingle 37+xmm14 = regSingle 38+xmm15 = regSingle 39++ripRel :: Displacement -> AddrMode+ripRel imm      = AddrBaseIndex EABaseRip EAIndexNone imm+++ -- so we can re-use some x86 code:+{-+eax = rax+ebx = rbx+ecx = rcx+edx = rdx+esi = rsi+edi = rdi+ebp = rbp+esp = rsp+-}++xmm :: RegNo -> Reg+xmm n = regSingle (firstxmm+n)+++++-- | these are the regs which we cannot assume stay alive over a C call.+callClobberedRegs       :: Platform -> [Reg]+-- caller-saves registers+callClobberedRegs platform+ | target32Bit platform = [eax,ecx,edx] ++ map regSingle (floatregnos platform)+ | platformOS platform == OSMinGW32+   = [rax,rcx,rdx,r8,r9,r10,r11]+   ++ map regSingle (floatregnos platform)+ | otherwise+    -- all xmm regs are caller-saves+    -- caller-saves registers+    = [rax,rcx,rdx,rsi,rdi,r8,r9,r10,r11]+   ++ map regSingle (floatregnos platform)++allArgRegs :: Platform -> [(Reg, Reg)]+allArgRegs platform+ | platformOS platform == OSMinGW32 = zip [rcx,rdx,r8,r9]+                                          (map regSingle [firstxmm ..])+ | otherwise = panic "X86.Regs.allArgRegs: not defined for this arch"++allIntArgRegs :: Platform -> [Reg]+allIntArgRegs platform+ | (platformOS platform == OSMinGW32) || target32Bit platform+    = panic "X86.Regs.allIntArgRegs: not defined for this platform"+ | otherwise = [rdi,rsi,rdx,rcx,r8,r9]++allFPArgRegs :: Platform -> [Reg]+allFPArgRegs platform+ | platformOS platform == OSMinGW32+    = panic "X86.Regs.allFPArgRegs: not defined for this platform"+ | otherwise = map regSingle [firstxmm .. firstxmm+7]++-- Machine registers which might be clobbered by instructions that+-- generate results into fixed registers, or need arguments in a fixed+-- register.+instrClobberedRegs :: Platform -> [Reg]+instrClobberedRegs platform+ | target32Bit platform = [ eax, ecx, edx ]+ | otherwise            = [ rax, rcx, rdx ]++--++-- allocatableRegs is allMachRegNos with the fixed-use regs removed.+-- i.e., these are the regs for which we are prepared to allow the+-- register allocator to attempt to map VRegs to.+allocatableRegs :: Platform -> [RealReg]+allocatableRegs platform+   = let isFree i = freeReg platform i+     in  map RealRegSingle $ filter isFree (allMachRegNos platform)+
+ parser/ApiAnnotation.hs view
@@ -0,0 +1,362 @@+{-# LANGUAGE DeriveDataTypeable #-}++module ApiAnnotation (+  getAnnotation, getAndRemoveAnnotation,+  getAnnotationComments,getAndRemoveAnnotationComments,+  ApiAnns,+  ApiAnnKey,+  AnnKeywordId(..),+  AnnotationComment(..),+  IsUnicodeSyntax(..),+  unicodeAnn,+  HasE(..),+  LRdrName -- Exists for haddocks only+  ) where++import RdrName+import Outputable+import SrcLoc+import qualified Data.Map as Map+import Data.Data+++{-+Note [Api annotations]+~~~~~~~~~~~~~~~~~~~~~~+Given a parse tree of a Haskell module, how can we reconstruct+the original Haskell source code, retaining all whitespace and+source code comments?  We need to track the locations of all+elements from the original source: this includes keywords such as+'let' / 'in' / 'do' etc as well as punctuation such as commas and+braces, and also comments.  We collectively refer to this+metadata as the "API annotations".++Rather than annotate the resulting parse tree with these locations+directly (this would be a major change to some fairly core data+structures in GHC), we instead capture locations for these elements in a+structure separate from the parse tree, and returned in the+pm_annotations field of the ParsedModule type.++The full ApiAnns type is++> type ApiAnns = ( Map.Map ApiAnnKey [SrcSpan]                  -- non-comments+>                , Map.Map SrcSpan [Located AnnotationComment]) -- comments++NON-COMMENT ELEMENTS++Intuitively, every AST element directly contains a bag of keywords+(keywords can show up more than once in a node: a semicolon i.e. newline+can show up multiple times before the next AST element), each of which+needs to be associated with its location in the original source code.++Consequently, the structure that records non-comment elements is logically+a two level map, from the SrcSpan of the AST element containing it, to+a map from keywords ('AnnKeyWord') to all locations of the keyword directly+in the AST element:++> type ApiAnnKey = (SrcSpan,AnnKeywordId)+>+> Map.Map ApiAnnKey [SrcSpan]++So++> let x = 1 in 2 *x++would result in the AST element++  L span (HsLet (binds for x = 1) (2 * x))++and the annotations++  (span,AnnLet) having the location of the 'let' keyword+  (span,AnnEqual) having the location of the '=' sign+  (span,AnnIn)  having the location of the 'in' keyword++For any given element in the AST, there is only a set number of+keywords that are applicable for it (e.g., you'll never see an+'import' keyword associated with a let-binding.)  The set of allowed+keywords is documented in a comment associated with the constructor+of a given AST element, although the ground truth is in Parser+and RdrHsSyn (which actually add the annotations; see #13012).++COMMENT ELEMENTS++Every comment is associated with a *located* AnnotationComment.+We associate comments with the lowest (most specific) AST element+enclosing them:++> Map.Map SrcSpan [Located AnnotationComment]++PARSER STATE++There are three fields in PState (the parser state) which play a role+with annotations.++>  annotations :: [(ApiAnnKey,[SrcSpan])],+>  comment_q :: [Located AnnotationComment],+>  annotations_comments :: [(SrcSpan,[Located AnnotationComment])]++The 'annotations' and 'annotations_comments' fields are simple: they simply+accumulate annotations that will end up in 'ApiAnns' at the end+(after they are passed to Map.fromList).++The 'comment_q' field captures comments as they are seen in the token stream,+so that when they are ready to be allocated via the parser they are+available (at the time we lex a comment, we don't know what the enclosing+AST node of it is, so we can't associate it with a SrcSpan in+annotations_comments).++PARSER EMISSION OF ANNOTATIONS++The parser interacts with the lexer using the function++> addAnnotation :: SrcSpan -> AnnKeywordId -> SrcSpan -> P ()++which takes the AST element SrcSpan, the annotation keyword and the+target SrcSpan.++This adds the annotation to the `annotations` field of `PState` and+transfers any comments in `comment_q` WHICH ARE ENCLOSED by+the SrcSpan of this element to the `annotations_comments`+field.  (Comments which are outside of this annotation are deferred+until later. 'allocateComments' in 'Lexer' is responsible for+making sure we only attach comments that actually fit in the 'SrcSpan'.)++The wiki page describing this feature is+https://ghc.haskell.org/trac/ghc/wiki/ApiAnnotations++-}+-- ---------------------------------------------------------------------++-- If you update this, update the Note [Api annotations] above+type ApiAnns = ( Map.Map ApiAnnKey [SrcSpan]+               , Map.Map SrcSpan [Located AnnotationComment])++-- If you update this, update the Note [Api annotations] above+type ApiAnnKey = (SrcSpan,AnnKeywordId)+++-- | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan'+-- of the annotated AST element, and the known type of the annotation.+getAnnotation :: ApiAnns -> SrcSpan -> AnnKeywordId -> [SrcSpan]+getAnnotation (anns,_) span ann+   = case Map.lookup (span,ann) anns of+       Nothing -> []+       Just ss -> ss++-- | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan'+-- of the annotated AST element, and the known type of the annotation.+-- The list is removed from the annotations.+getAndRemoveAnnotation :: ApiAnns -> SrcSpan -> AnnKeywordId+                       -> ([SrcSpan],ApiAnns)+getAndRemoveAnnotation (anns,cs) span ann+   = case Map.lookup (span,ann) anns of+       Nothing -> ([],(anns,cs))+       Just ss -> (ss,(Map.delete (span,ann) anns,cs))++-- |Retrieve the comments allocated to the current 'SrcSpan'+--+--  Note: A given 'SrcSpan' may appear in multiple AST elements,+--  beware of duplicates+getAnnotationComments :: ApiAnns -> SrcSpan -> [Located AnnotationComment]+getAnnotationComments (_,anns) span =+  case Map.lookup span anns of+    Just cs -> cs+    Nothing -> []++-- |Retrieve the comments allocated to the current 'SrcSpan', and+-- remove them from the annotations+getAndRemoveAnnotationComments :: ApiAnns -> SrcSpan+                               -> ([Located AnnotationComment],ApiAnns)+getAndRemoveAnnotationComments (anns,canns) span =+  case Map.lookup span canns of+    Just cs -> (cs,(anns,Map.delete span canns))+    Nothing -> ([],(anns,canns))++-- --------------------------------------------------------------------++-- | API Annotations exist so that tools can perform source to source+-- conversions of Haskell code. They are used to keep track of the+-- various syntactic keywords that are not captured in the existing+-- AST.+--+-- The annotations, together with original source comments are made+-- available in the @'pm_annotations'@ field of @'GHC.ParsedModule'@.+-- Comments are only retained if @'Opt_KeepRawTokenStream'@ is set in+-- @'DynFlags.DynFlags'@ before parsing.+--+-- The wiki page describing this feature is+-- https://ghc.haskell.org/trac/ghc/wiki/ApiAnnotations+--+-- Note: in general the names of these are taken from the+-- corresponding token, unless otherwise noted+-- See note [Api annotations] above for details of the usage+data AnnKeywordId+    = AnnAnyclass+    | AnnAs+    | AnnAt+    | AnnBang  -- ^ '!'+    | AnnBackquote -- ^ '`'+    | AnnBy+    | AnnCase -- ^ case or lambda case+    | AnnClass+    | AnnClose -- ^  '\#)' or '\#-}'  etc+    | AnnCloseB -- ^ '|)'+    | AnnCloseBU -- ^ '|)', unicode variant+    | AnnCloseC -- ^ '}'+    | AnnCloseQ  -- ^ '|]'+    | AnnCloseQU -- ^ '|]', unicode variant+    | AnnCloseP -- ^ ')'+    | AnnCloseS -- ^ ']'+    | AnnColon+    | AnnComma -- ^ as a list separator+    | AnnCommaTuple -- ^ in a RdrName for a tuple+    | AnnDarrow -- ^ '=>'+    | AnnDarrowU -- ^ '=>', unicode variant+    | AnnData+    | AnnDcolon -- ^ '::'+    | AnnDcolonU -- ^ '::', unicode variant+    | AnnDefault+    | AnnDeriving+    | AnnDo+    | AnnDot    -- ^ '.'+    | AnnDotdot -- ^ '..'+    | AnnElse+    | AnnEqual+    | AnnExport+    | AnnFamily+    | AnnForall+    | AnnForallU -- ^ Unicode variant+    | AnnForeign+    | AnnFunId -- ^ for function name in matches where there are+               -- multiple equations for the function.+    | AnnGroup+    | AnnHeader -- ^ for CType+    | AnnHiding+    | AnnIf+    | AnnImport+    | AnnIn+    | AnnInfix -- ^ 'infix' or 'infixl' or 'infixr'+    | AnnInstance+    | AnnLam+    | AnnLarrow     -- ^ '<-'+    | AnnLarrowU    -- ^ '<-', unicode variant+    | AnnLet+    | AnnMdo+    | AnnMinus -- ^ '-'+    | AnnModule+    | AnnNewtype+    | AnnName -- ^ where a name loses its location in the AST, this carries it+    | AnnOf+    | AnnOpen    -- ^ '(\#' or '{-\# LANGUAGE' etc+    | AnnOpenB   -- ^ '(|'+    | AnnOpenBU  -- ^ '(|', unicode variant+    | AnnOpenC   -- ^ '{'+    | AnnOpenE   -- ^ '[e|' or '[e||'+    | AnnOpenEQ  -- ^ '[|'+    | AnnOpenEQU -- ^ '[|', unicode variant+    | AnnOpenP   -- ^ '('+    | AnnOpenPE  -- ^ '$('+    | AnnOpenPTE -- ^ '$$('+    | AnnOpenS   -- ^ '['+    | AnnPackageName+    | AnnPattern+    | AnnProc+    | AnnQualified+    | AnnRarrow -- ^ '->'+    | AnnRarrowU -- ^ '->', unicode variant+    | AnnRec+    | AnnRole+    | AnnSafe+    | AnnSemi -- ^ ';'+    | AnnSimpleQuote -- ^ '''+    | AnnSignature+    | AnnStatic -- ^ 'static'+    | AnnStock+    | AnnThen+    | AnnThIdSplice -- ^ '$'+    | AnnThIdTySplice -- ^ '$$'+    | AnnThTyQuote -- ^ double '''+    | AnnTilde -- ^ '~'+    | AnnTildehsh -- ^ '~#'+    | AnnType+    | AnnUnit -- ^ '()' for types+    | AnnUsing+    | AnnVal  -- ^ e.g. INTEGER+    | AnnValStr  -- ^ String value, will need quotes when output+    | AnnVbar -- ^ '|'+    | AnnWhere+    | Annlarrowtail -- ^ '-<'+    | AnnlarrowtailU -- ^ '-<', unicode variant+    | Annrarrowtail -- ^ '->'+    | AnnrarrowtailU -- ^ '->', unicode variant+    | AnnLarrowtail -- ^ '-<<'+    | AnnLarrowtailU -- ^ '-<<', unicode variant+    | AnnRarrowtail -- ^ '>>-'+    | AnnRarrowtailU -- ^ '>>-', unicode variant+    | AnnEofPos+    deriving (Eq, Ord, Data, Show)++instance Outputable AnnKeywordId where+  ppr x = text (show x)++-- ---------------------------------------------------------------------++data AnnotationComment =+  -- Documentation annotations+    AnnDocCommentNext  String     -- ^ something beginning '-- |'+  | AnnDocCommentPrev  String     -- ^ something beginning '-- ^'+  | AnnDocCommentNamed String     -- ^ something beginning '-- $'+  | AnnDocSection      Int String -- ^ a section heading+  | AnnDocOptions      String     -- ^ doc options (prune, ignore-exports, etc)+  | AnnLineComment     String     -- ^ comment starting by "--"+  | AnnBlockComment    String     -- ^ comment in {- -}+    deriving (Eq, Ord, Data, Show)+-- Note: these are based on the Token versions, but the Token type is+-- defined in Lexer.x and bringing it in here would create a loop++instance Outputable AnnotationComment where+  ppr x = text (show x)++-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',+--             'ApiAnnotation.AnnClose','ApiAnnotation.AnnComma',+--             'ApiAnnotation.AnnRarrow','ApiAnnotation.AnnTildehsh',+--             'ApiAnnotation.AnnTilde'+--   - May have 'ApiAnnotation.AnnComma' when in a list+type LRdrName = Located RdrName+++-- | Certain tokens can have alternate representations when unicode syntax is+-- enabled. This flag is attached to those tokens in the lexer so that the+-- original source representation can be reproduced in the corresponding+-- 'ApiAnnotation'+data IsUnicodeSyntax = UnicodeSyntax | NormalSyntax+    deriving (Eq, Ord, Data, Show)++-- | Convert a normal annotation into its unicode equivalent one+unicodeAnn :: AnnKeywordId -> AnnKeywordId+unicodeAnn AnnForall     = AnnForallU+unicodeAnn AnnDcolon     = AnnDcolonU+unicodeAnn AnnLarrow     = AnnLarrowU+unicodeAnn AnnRarrow     = AnnRarrowU+unicodeAnn AnnDarrow     = AnnDarrowU+unicodeAnn Annlarrowtail = AnnlarrowtailU+unicodeAnn Annrarrowtail = AnnrarrowtailU+unicodeAnn AnnLarrowtail = AnnLarrowtailU+unicodeAnn AnnRarrowtail = AnnRarrowtailU+unicodeAnn AnnOpenB      = AnnOpenBU+unicodeAnn AnnCloseB     = AnnCloseBU+unicodeAnn AnnOpenEQ     = AnnOpenEQU+unicodeAnn AnnCloseQ     = AnnCloseQU+unicodeAnn ann           = ann+++-- | Some template haskell tokens have two variants, one with an `e` the other+-- not:+--+-- >  [| or [e|+-- >  [|| or [e||+--+-- This type indicates whether the 'e' is present or not.+data HasE = HasE | NoE+     deriving (Eq, Ord, Data, Show)
+ parser/Ctype.hs view
@@ -0,0 +1,216 @@+-- Character classification+{-# LANGUAGE CPP #-}+module Ctype+        ( is_ident      -- Char# -> Bool+        , is_symbol     -- Char# -> Bool+        , is_any        -- Char# -> Bool+        , is_space      -- Char# -> Bool+        , is_lower      -- Char# -> Bool+        , is_upper      -- Char# -> Bool+        , is_digit      -- Char# -> Bool+        , is_alphanum   -- Char# -> Bool++        , is_decdigit, is_hexdigit, is_octdigit, is_bindigit+        , hexDigit, octDecDigit+        ) where++#include "HsVersions.h"++import Data.Int         ( Int32 )+import Data.Bits        ( Bits((.&.)) )+import Data.Char        ( ord, chr )+import Panic++-- Bit masks++cIdent, cSymbol, cAny, cSpace, cLower, cUpper, cDigit :: Int+cIdent  =  1+cSymbol =  2+cAny    =  4+cSpace  =  8+cLower  = 16+cUpper  = 32+cDigit  = 64++-- | The predicates below look costly, but aren't, GHC+GCC do a great job+-- at the big case below.++{-# INLINE is_ctype #-}+is_ctype :: Int -> Char -> Bool+is_ctype mask c = (fromIntegral (charType c) .&. fromIntegral mask) /= (0::Int32)++is_ident, is_symbol, is_any, is_space, is_lower, is_upper, is_digit,+    is_alphanum :: Char -> Bool+is_ident  = is_ctype cIdent+is_symbol = is_ctype cSymbol+is_any    = is_ctype cAny+is_space  = is_ctype cSpace+is_lower  = is_ctype cLower+is_upper  = is_ctype cUpper+is_digit  = is_ctype cDigit+is_alphanum = is_ctype (cLower+cUpper+cDigit)++-- Utils++hexDigit :: Char -> Int+hexDigit c | is_decdigit c = ord c - ord '0'+           | otherwise     = ord (to_lower c) - ord 'a' + 10++octDecDigit :: Char -> Int+octDecDigit c = ord c - ord '0'++is_decdigit :: Char -> Bool+is_decdigit c+        =  c >= '0' && c <= '9'++is_hexdigit :: Char -> Bool+is_hexdigit c+        =  is_decdigit c+        || (c >= 'a' && c <= 'f')+        || (c >= 'A' && c <= 'F')++is_octdigit :: Char -> Bool+is_octdigit c = c >= '0' && c <= '7'++is_bindigit :: Char -> Bool+is_bindigit c = c == '0' || c == '1'++to_lower :: Char -> Char+to_lower c+  | c >=  'A' && c <= 'Z' = chr (ord c - (ord 'A' - ord 'a'))+  | otherwise = c++-- | We really mean .|. instead of + below, but GHC currently doesn't do+--  any constant folding with bitops. *sigh*++charType :: Char -> Int+charType c = case c of+   '\0'   -> 0                         -- \000+   '\1'   -> 0                         -- \001+   '\2'   -> 0                         -- \002+   '\3'   -> 0                         -- \003+   '\4'   -> 0                         -- \004+   '\5'   -> 0                         -- \005+   '\6'   -> 0                         -- \006+   '\7'   -> 0                         -- \007+   '\8'   -> 0                         -- \010+   '\9'   -> cSpace                    -- \t  (not allowed in strings, so !cAny)+   '\10'  -> cSpace                    -- \n  (ditto)+   '\11'  -> cSpace                    -- \v  (ditto)+   '\12'  -> cSpace                    -- \f  (ditto)+   '\13'  -> cSpace                    --  ^M (ditto)+   '\14'  -> 0                         -- \016+   '\15'  -> 0                         -- \017+   '\16'  -> 0                         -- \020+   '\17'  -> 0                         -- \021+   '\18'  -> 0                         -- \022+   '\19'  -> 0                         -- \023+   '\20'  -> 0                         -- \024+   '\21'  -> 0                         -- \025+   '\22'  -> 0                         -- \026+   '\23'  -> 0                         -- \027+   '\24'  -> 0                         -- \030+   '\25'  -> 0                         -- \031+   '\26'  -> 0                         -- \032+   '\27'  -> 0                         -- \033+   '\28'  -> 0                         -- \034+   '\29'  -> 0                         -- \035+   '\30'  -> 0                         -- \036+   '\31'  -> 0                         -- \037+   '\32'  -> cAny + cSpace             --+   '\33'  -> cAny + cSymbol            -- !+   '\34'  -> cAny                      -- "+   '\35'  -> cAny + cSymbol            --  #+   '\36'  -> cAny + cSymbol            --  $+   '\37'  -> cAny + cSymbol            -- %+   '\38'  -> cAny + cSymbol            -- &+   '\39'  -> cAny + cIdent             -- '+   '\40'  -> cAny                      -- (+   '\41'  -> cAny                      -- )+   '\42'  -> cAny + cSymbol            --  *+   '\43'  -> cAny + cSymbol            -- ++   '\44'  -> cAny                      -- ,+   '\45'  -> cAny + cSymbol            -- -+   '\46'  -> cAny + cSymbol            -- .+   '\47'  -> cAny + cSymbol            --  /+   '\48'  -> cAny + cIdent  + cDigit   -- 0+   '\49'  -> cAny + cIdent  + cDigit   -- 1+   '\50'  -> cAny + cIdent  + cDigit   -- 2+   '\51'  -> cAny + cIdent  + cDigit   -- 3+   '\52'  -> cAny + cIdent  + cDigit   -- 4+   '\53'  -> cAny + cIdent  + cDigit   -- 5+   '\54'  -> cAny + cIdent  + cDigit   -- 6+   '\55'  -> cAny + cIdent  + cDigit   -- 7+   '\56'  -> cAny + cIdent  + cDigit   -- 8+   '\57'  -> cAny + cIdent  + cDigit   -- 9+   '\58'  -> cAny + cSymbol            -- :+   '\59'  -> cAny                      -- ;+   '\60'  -> cAny + cSymbol            -- <+   '\61'  -> cAny + cSymbol            -- =+   '\62'  -> cAny + cSymbol            -- >+   '\63'  -> cAny + cSymbol            -- ?+   '\64'  -> cAny + cSymbol            -- @+   '\65'  -> cAny + cIdent  + cUpper   -- A+   '\66'  -> cAny + cIdent  + cUpper   -- B+   '\67'  -> cAny + cIdent  + cUpper   -- C+   '\68'  -> cAny + cIdent  + cUpper   -- D+   '\69'  -> cAny + cIdent  + cUpper   -- E+   '\70'  -> cAny + cIdent  + cUpper   -- F+   '\71'  -> cAny + cIdent  + cUpper   -- G+   '\72'  -> cAny + cIdent  + cUpper   -- H+   '\73'  -> cAny + cIdent  + cUpper   -- I+   '\74'  -> cAny + cIdent  + cUpper   -- J+   '\75'  -> cAny + cIdent  + cUpper   -- K+   '\76'  -> cAny + cIdent  + cUpper   -- L+   '\77'  -> cAny + cIdent  + cUpper   -- M+   '\78'  -> cAny + cIdent  + cUpper   -- N+   '\79'  -> cAny + cIdent  + cUpper   -- O+   '\80'  -> cAny + cIdent  + cUpper   -- P+   '\81'  -> cAny + cIdent  + cUpper   -- Q+   '\82'  -> cAny + cIdent  + cUpper   -- R+   '\83'  -> cAny + cIdent  + cUpper   -- S+   '\84'  -> cAny + cIdent  + cUpper   -- T+   '\85'  -> cAny + cIdent  + cUpper   -- U+   '\86'  -> cAny + cIdent  + cUpper   -- V+   '\87'  -> cAny + cIdent  + cUpper   -- W+   '\88'  -> cAny + cIdent  + cUpper   -- X+   '\89'  -> cAny + cIdent  + cUpper   -- Y+   '\90'  -> cAny + cIdent  + cUpper   -- Z+   '\91'  -> cAny                      -- [+   '\92'  -> cAny + cSymbol            -- backslash+   '\93'  -> cAny                      -- ]+   '\94'  -> cAny + cSymbol            --  ^+   '\95'  -> cAny + cIdent  + cLower   -- _+   '\96'  -> cAny                      -- `+   '\97'  -> cAny + cIdent  + cLower   -- a+   '\98'  -> cAny + cIdent  + cLower   -- b+   '\99'  -> cAny + cIdent  + cLower   -- c+   '\100' -> cAny + cIdent  + cLower   -- d+   '\101' -> cAny + cIdent  + cLower   -- e+   '\102' -> cAny + cIdent  + cLower   -- f+   '\103' -> cAny + cIdent  + cLower   -- g+   '\104' -> cAny + cIdent  + cLower   -- h+   '\105' -> cAny + cIdent  + cLower   -- i+   '\106' -> cAny + cIdent  + cLower   -- j+   '\107' -> cAny + cIdent  + cLower   -- k+   '\108' -> cAny + cIdent  + cLower   -- l+   '\109' -> cAny + cIdent  + cLower   -- m+   '\110' -> cAny + cIdent  + cLower   -- n+   '\111' -> cAny + cIdent  + cLower   -- o+   '\112' -> cAny + cIdent  + cLower   -- p+   '\113' -> cAny + cIdent  + cLower   -- q+   '\114' -> cAny + cIdent  + cLower   -- r+   '\115' -> cAny + cIdent  + cLower   -- s+   '\116' -> cAny + cIdent  + cLower   -- t+   '\117' -> cAny + cIdent  + cLower   -- u+   '\118' -> cAny + cIdent  + cLower   -- v+   '\119' -> cAny + cIdent  + cLower   -- w+   '\120' -> cAny + cIdent  + cLower   -- x+   '\121' -> cAny + cIdent  + cLower   -- y+   '\122' -> cAny + cIdent  + cLower   -- z+   '\123' -> cAny                      -- {+   '\124' -> cAny + cSymbol            --  |+   '\125' -> cAny                      -- }+   '\126' -> cAny + cSymbol            -- ~+   '\127' -> 0                         -- \177+   _ -> panic ("charType: " ++ show c)
+ parser/HaddockUtils.hs view
@@ -0,0 +1,32 @@++module HaddockUtils where++import HsSyn+import SrcLoc++import Control.Monad++-- -----------------------------------------------------------------------------+-- Adding documentation to record fields (used in parsing).++addFieldDoc :: LConDeclField a -> Maybe LHsDocString -> LConDeclField a+addFieldDoc (L l fld) doc+  = L l (fld { cd_fld_doc = cd_fld_doc fld `mplus` doc })++addFieldDocs :: [LConDeclField a] -> Maybe LHsDocString -> [LConDeclField a]+addFieldDocs [] _ = []+addFieldDocs (x:xs) doc = addFieldDoc x doc : xs+++addConDoc :: LConDecl a -> Maybe LHsDocString -> LConDecl a+addConDoc decl    Nothing = decl+addConDoc (L p c) doc     = L p ( c { con_doc = con_doc c `mplus` doc } )++addConDocs :: [LConDecl a] -> Maybe LHsDocString -> [LConDecl a]+addConDocs [] _ = []+addConDocs [x] doc = [addConDoc x doc]+addConDocs (x:xs) doc = x : addConDocs xs doc++addConDocFirst :: [LConDecl a] -> Maybe LHsDocString -> [LConDecl a]+addConDocFirst [] _ = []+addConDocFirst (x:xs) doc = addConDoc x doc : xs
+ parser/Lexer.x view
@@ -0,0 +1,2968 @@+-----------------------------------------------------------------------------+-- (c) The University of Glasgow, 2006+--+-- GHC's lexer for Haskell 2010 [1].+--+-- This is a combination of an Alex-generated lexer [2] from a regex+-- definition, with some hand-coded bits. [3]+--+-- Completely accurate information about token-spans within the source+-- file is maintained.  Every token has a start and end RealSrcLoc+-- attached to it.+--+-- References:+-- [1] https://www.haskell.org/onlinereport/haskell2010/haskellch2.html+-- [2] http://www.haskell.org/alex/+-- [3] https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/Parser+--+-----------------------------------------------------------------------------++--   ToDo / known bugs:+--    - parsing integers is a bit slow+--    - readRational is a bit slow+--+--   Known bugs, that were also in the previous version:+--    - M... should be 3 tokens, not 1.+--    - pragma-end should be only valid in a pragma++--   qualified operator NOTES.+--+--   - If M.(+) is a single lexeme, then..+--     - Probably (+) should be a single lexeme too, for consistency.+--       Otherwise ( + ) would be a prefix operator, but M.( + ) would not be.+--     - But we have to rule out reserved operators, otherwise (..) becomes+--       a different lexeme.+--     - Should we therefore also rule out reserved operators in the qualified+--       form?  This is quite difficult to achieve.  We don't do it for+--       qualified varids.+++-- -----------------------------------------------------------------------------+-- Alex "Haskell code fragment top"++{+{-# LANGUAGE BangPatterns #-}++-- See Note [Warnings in code generated by Alex] in compiler/parser/Lexer.x+{-# OPTIONS_GHC -fno-warn-unused-matches #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++{-# OPTIONS_GHC -funbox-strict-fields #-}++module Lexer (+   Token(..), lexer, pragState, mkPState, mkPStatePure, PState(..),+   P(..), ParseResult(..), mkParserFlags, ParserFlags(..), getSrcLoc,+   getPState, extopt, withThisPackage,+   failLocMsgP, failSpanMsgP, srcParseFail,+   getMessages,+   popContext, pushModuleContext, setLastToken, setSrcLoc,+   activeContext, nextIsEOF,+   getLexState, popLexState, pushLexState,+   extension, bangPatEnabled, datatypeContextsEnabled,+   traditionalRecordSyntaxEnabled,+   explicitForallEnabled,+   inRulePrag,+   explicitNamespacesEnabled,+   patternSynonymsEnabled,+   sccProfilingOn, hpcEnabled,+   addWarning,+   lexTokenStream,+   addAnnotation,AddAnn,addAnnsAt,mkParensApiAnn,+   commentToAnnotation,+   moveAnnotations+  ) where++-- base+import Control.Monad+#if __GLASGOW_HASKELL__ > 710+import Control.Monad.Fail+#endif+import Data.Bits+import Data.Char+import Data.List+import Data.Maybe+import Data.Word++import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet++-- ghc-boot+import qualified GHC.LanguageExtensions as LangExt++-- bytestring+import Data.ByteString (ByteString)++-- containers+import Data.Map (Map)+import qualified Data.Map as Map++-- compiler/utils+import Bag+import Outputable+import StringBuffer+import FastString+import UniqFM+import Util             ( readRational )++-- compiler/main+import ErrUtils+import DynFlags++-- compiler/basicTypes+import SrcLoc+import Module+import BasicTypes     ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..),+                        SourceText(..) )++-- compiler/parser+import Ctype++import ApiAnnotation+}++-- -----------------------------------------------------------------------------+-- Alex "Character set macros"++-- NB: The logic behind these definitions is also reflected in basicTypes/Lexeme.hs+-- Any changes here should likely be reflected there.+$unispace    = \x05 -- Trick Alex into handling Unicode. See alexGetByte.+$nl          = [\n\r\f]+$whitechar   = [$nl\v\ $unispace]+$white_no_nl = $whitechar # \n -- TODO #8424+$tab         = \t++$ascdigit  = 0-9+$unidigit  = \x03 -- Trick Alex into handling Unicode. See alexGetByte.+$decdigit  = $ascdigit -- for now, should really be $digit (ToDo)+$digit     = [$ascdigit $unidigit]++$special   = [\(\)\,\;\[\]\`\{\}]+$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]+$unisymbol = \x04 -- Trick Alex into handling Unicode. See alexGetByte.+$symbol    = [$ascsymbol $unisymbol] # [$special \_\"\']++$unilarge  = \x01 -- Trick Alex into handling Unicode. See alexGetByte.+$asclarge  = [A-Z]+$large     = [$asclarge $unilarge]++$unismall  = \x02 -- Trick Alex into handling Unicode. See alexGetByte.+$ascsmall  = [a-z]+$small     = [$ascsmall $unismall \_]++$unigraphic = \x06 -- Trick Alex into handling Unicode. See alexGetByte.+$graphic   = [$small $large $symbol $digit $special $unigraphic \"\']++$binit     = 0-1+$octit     = 0-7+$hexit     = [$decdigit A-F a-f]++$uniidchar = \x07 -- Trick Alex into handling Unicode. See alexGetByte.+$idchar    = [$small $large $digit $uniidchar \']++$pragmachar = [$small $large $digit]++$docsym    = [\| \^ \* \$]+++-- -----------------------------------------------------------------------------+-- Alex "Regular expression macros"++@varid     = $small $idchar*          -- variable identifiers+@conid     = $large $idchar*          -- constructor identifiers++@varsym    = ($symbol # \:) $symbol*  -- variable (operator) symbol+@consym    = \: $symbol*              -- constructor (operator) symbol++@decimal     = $decdigit++@binary      = $binit++@octal       = $octit++@hexadecimal = $hexit++@exponent    = [eE] [\-\+]? @decimal++@qual = (@conid \.)++@qvarid = @qual @varid+@qconid = @qual @conid+@qvarsym = @qual @varsym+@qconsym = @qual @consym++@floating_point = @decimal \. @decimal @exponent? | @decimal @exponent++-- normal signed numerical literals can only be explicitly negative,+-- not explicitly positive (contrast @exponent)+@negative = \-+@signed = @negative ?+++-- -----------------------------------------------------------------------------+-- Alex "Identifier"++haskell :-+++-- -----------------------------------------------------------------------------+-- Alex "Rules"++-- everywhere: skip whitespace+$white_no_nl+ ;+$tab          { warnTab }++-- Everywhere: deal with nested comments.  We explicitly rule out+-- pragmas, "{-#", so that we don't accidentally treat them as comments.+-- (this can happen even though pragmas will normally take precedence due to+-- longest-match, because pragmas aren't valid in every state, but comments+-- are). We also rule out nested Haddock comments, if the -haddock flag is+-- set.++"{-" / { isNormalComment } { nested_comment lexToken }++-- Single-line comments are a bit tricky.  Haskell 98 says that two or+-- more dashes followed by a symbol should be parsed as a varsym, so we+-- have to exclude those.++-- Since Haddock comments aren't valid in every state, we need to rule them+-- out here.++-- The following two rules match comments that begin with two dashes, but+-- continue with a different character. The rules test that this character+-- is not a symbol (in which case we'd have a varsym), and that it's not a+-- space followed by a Haddock comment symbol (docsym) (in which case we'd+-- have a Haddock comment). The rules then munch the rest of the line.++"-- " ~$docsym .* { lineCommentToken }+"--" [^$symbol \ ] .* { lineCommentToken }++-- Next, match Haddock comments if no -haddock flag++"-- " $docsym .* / { ifExtension (not . haddockEnabled) } { lineCommentToken }++-- Now, when we've matched comments that begin with 2 dashes and continue+-- with a different character, we need to match comments that begin with three+-- or more dashes (which clearly can't be Haddock comments). We only need to+-- make sure that the first non-dash character isn't a symbol, and munch the+-- rest of the line.++"---"\-* ~$symbol .* { lineCommentToken }++-- Since the previous rules all match dashes followed by at least one+-- character, we also need to match a whole line filled with just dashes.++"--"\-* / { atEOL } { lineCommentToken }++-- We need this rule since none of the other single line comment rules+-- actually match this case.++"-- " / { atEOL } { lineCommentToken }++-- 'bol' state: beginning of a line.  Slurp up all the whitespace (including+-- blank lines) until we find a non-whitespace character, then do layout+-- processing.+--+-- One slight wibble here: what if the line begins with {-#? In+-- theory, we have to lex the pragma to see if it's one we recognise,+-- and if it is, then we backtrack and do_bol, otherwise we treat it+-- as a nested comment.  We don't bother with this: if the line begins+-- with {-#, then we'll assume it's a pragma we know about and go for do_bol.+<bol> {+  \n                                    ;+  ^\# line                              { begin line_prag1 }+  ^\# / { followedByDigit }             { begin line_prag1 }+  ^\# pragma .* \n                      ; -- GCC 3.3 CPP generated, apparently+  ^\# \! .* \n                          ; -- #!, for scripts+  ()                                    { do_bol }+}++-- after a layout keyword (let, where, do, of), we begin a new layout+-- context if the curly brace is missing.+-- Careful! This stuff is quite delicate.+<layout, layout_do, layout_if> {+  \{ / { notFollowedBy '-' }            { hopefully_open_brace }+        -- we might encounter {-# here, but {- has been handled already+  \n                                    ;+  ^\# (line)?                           { begin line_prag1 }+}++-- after an 'if', a vertical bar starts a layout context for MultiWayIf+<layout_if> {+  \| / { notFollowedBySymbol }          { new_layout_context True dontGenerateSemic ITvbar }+  ()                                    { pop }+}++-- do is treated in a subtly different way, see new_layout_context+<layout>    ()                          { new_layout_context True  generateSemic ITvocurly }+<layout_do> ()                          { new_layout_context False generateSemic ITvocurly }++-- after a new layout context which was found to be to the left of the+-- previous context, we have generated a '{' token, and we now need to+-- generate a matching '}' token.+<layout_left>  ()                       { do_layout_left }++<0,option_prags> \n                     { begin bol }++"{-#" $whitechar* $pragmachar+ / { known_pragma linePrags }+                                { dispatch_pragmas linePrags }++-- single-line line pragmas, of the form+--    # <line> "<file>" <extra-stuff> \n+<line_prag1> @decimal                   { setLine line_prag1a }+<line_prag1a> \" [$graphic \ ]* \"      { setFile line_prag1b }+<line_prag1b> .*                        { pop }++-- Haskell-style line pragmas, of the form+--    {-# LINE <line> "<file>" #-}+<line_prag2> @decimal                   { setLine line_prag2a }+<line_prag2a> \" [$graphic \ ]* \"      { setFile line_prag2b }+<line_prag2b> "#-}"|"-}"                { pop }+   -- NOTE: accept -} at the end of a LINE pragma, for compatibility+   -- with older versions of GHC which generated these.++-- Haskell-style column pragmas, of the form+--    {-# COLUMN <column> #-}+<column_prag> @decimal $whitechar* "#-}" { setColumn }++<0,option_prags> {+  "{-#" $whitechar* $pragmachar++        $whitechar+ $pragmachar+ / { known_pragma twoWordPrags }+                                 { dispatch_pragmas twoWordPrags }++  "{-#" $whitechar* $pragmachar+ / { known_pragma oneWordPrags }+                                 { dispatch_pragmas oneWordPrags }++  -- We ignore all these pragmas, but don't generate a warning for them+  "{-#" $whitechar* $pragmachar+ / { known_pragma ignoredPrags }+                                 { dispatch_pragmas ignoredPrags }++  -- ToDo: should only be valid inside a pragma:+  "#-}"                          { endPrag }+}++<option_prags> {+  "{-#"  $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags }+                                   { dispatch_pragmas fileHeaderPrags }+}++<0> {+  -- In the "0" mode we ignore these pragmas+  "{-#"  $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags }+                     { nested_comment lexToken }+}++<0,option_prags> {+  "{-#"  { warnThen Opt_WarnUnrecognisedPragmas (text "Unrecognised pragma")+                    (nested_comment lexToken) }+}++-- '0' state: ordinary lexemes++-- Haddock comments++<0,option_prags> {+  "-- " $docsym      / { ifExtension haddockEnabled } { multiline_doc_comment }+  "{-" \ ? $docsym   / { ifExtension haddockEnabled } { nested_doc_comment }+}++-- "special" symbols++<0> {+  "[:" / { ifExtension parrEnabled }    { token ITopabrack }+  ":]" / { ifExtension parrEnabled }    { token ITcpabrack }+}++<0> {+  "[|"        / { ifExtension thQuotesEnabled } { token (ITopenExpQuote NoE+                                                                NormalSyntax) }+  "[||"       / { ifExtension thQuotesEnabled } { token (ITopenTExpQuote NoE) }+  "[e|"       / { ifExtension thQuotesEnabled } { token (ITopenExpQuote HasE+                                                                NormalSyntax) }+  "[e||"      / { ifExtension thQuotesEnabled } { token (ITopenTExpQuote HasE) }+  "[p|"       / { ifExtension thQuotesEnabled } { token ITopenPatQuote }+  "[d|"       / { ifExtension thQuotesEnabled } { layout_token ITopenDecQuote }+  "[t|"       / { ifExtension thQuotesEnabled } { token ITopenTypQuote }+  "|]"        / { ifExtension thQuotesEnabled } { token (ITcloseQuote+                                                                NormalSyntax) }+  "||]"       / { ifExtension thQuotesEnabled } { token ITcloseTExpQuote }+  \$ @varid   / { ifExtension thEnabled } { skip_one_varid ITidEscape }+  "$$" @varid / { ifExtension thEnabled } { skip_two_varid ITidTyEscape }+  "$("        / { ifExtension thEnabled } { token ITparenEscape }+  "$$("       / { ifExtension thEnabled } { token ITparenTyEscape }++  "[" @varid "|"  / { ifExtension qqEnabled }+                     { lex_quasiquote_tok }++  -- qualified quasi-quote (#5555)+  "[" @qvarid "|"  / { ifExtension qqEnabled }+                     { lex_qquasiquote_tok }++  $unigraphic -- ⟦+    / { ifCurrentChar '⟦' `alexAndPred`+        ifExtension (\i -> unicodeSyntaxEnabled i && thQuotesEnabled i) }+    { token (ITopenExpQuote NoE UnicodeSyntax) }+  $unigraphic -- ⟧+    / { ifCurrentChar '⟧' `alexAndPred`+        ifExtension (\i -> unicodeSyntaxEnabled i && thQuotesEnabled i) }+    { token (ITcloseQuote UnicodeSyntax) }+}++  -- See Note [Lexing type applications]+<0> {+    [^ $idchar \) ] ^+  "@"+    / { ifExtension typeApplicationEnabled `alexAndPred` notFollowedBySymbol }+    { token ITtypeApp }+}++<0> {+  "(|" / { ifExtension arrowsEnabled `alexAndPred` notFollowedBySymbol }+                                        { special (IToparenbar NormalSyntax) }+  "|)" / { ifExtension arrowsEnabled }  { special (ITcparenbar NormalSyntax) }++  $unigraphic -- ⦇+    / { ifCurrentChar '⦇' `alexAndPred`+        ifExtension (\i -> unicodeSyntaxEnabled i && arrowsEnabled i) }+    { special (IToparenbar UnicodeSyntax) }+  $unigraphic -- ⦈+    / { ifCurrentChar '⦈' `alexAndPred`+        ifExtension (\i -> unicodeSyntaxEnabled i && arrowsEnabled i) }+    { special (ITcparenbar UnicodeSyntax) }+}++<0> {+  \? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid }+}++<0> {+  "#" @varid / { ifExtension overloadedLabelsEnabled }+               { skip_one_varid ITlabelvarid }+}++<0> {+  "(#" / { orExtensions unboxedTuplesEnabled unboxedSumsEnabled }+         { token IToubxparen }+  "#)" / { orExtensions unboxedTuplesEnabled unboxedSumsEnabled }+         { token ITcubxparen }+}++<0,option_prags> {+  \(                                    { special IToparen }+  \)                                    { special ITcparen }+  \[                                    { special ITobrack }+  \]                                    { special ITcbrack }+  \,                                    { special ITcomma }+  \;                                    { special ITsemi }+  \`                                    { special ITbackquote }++  \{                                    { open_brace }+  \}                                    { close_brace }+}++<0,option_prags> {+  @qvarid                       { idtoken qvarid }+  @qconid                       { idtoken qconid }+  @varid                        { varid }+  @conid                        { idtoken conid }+}++<0> {+  @qvarid "#"+      / { ifExtension magicHashEnabled } { idtoken qvarid }+  @qconid "#"+      / { ifExtension magicHashEnabled } { idtoken qconid }+  @varid "#"+       / { ifExtension magicHashEnabled } { varid }+  @conid "#"+       / { ifExtension magicHashEnabled } { idtoken conid }+}++-- ToDo: - move `var` and (sym) into lexical syntax?+--       - remove backquote from $special?+<0> {+  @qvarsym                                         { idtoken qvarsym }+  @qconsym                                         { idtoken qconsym }+  @varsym                                          { varsym }+  @consym                                          { consym }+}++-- For the normal boxed literals we need to be careful+-- when trying to be close to Haskell98+<0> {+  -- Normal integral literals (:: Num a => a, from Integer)+  @decimal                                                               { tok_num positive 0 0 decimal }+  0[bB] @binary                / { ifExtension binaryLiteralsEnabled }   { tok_num positive 2 2 binary }+  0[oO] @octal                                                           { tok_num positive 2 2 octal }+  0[xX] @hexadecimal                                                     { tok_num positive 2 2 hexadecimal }+  @negative @decimal           / { ifExtension negativeLiteralsEnabled } { tok_num negative 1 1 decimal }+  @negative 0[bB] @binary      / { ifExtension negativeLiteralsEnabled `alexAndPred`+                                   ifExtension binaryLiteralsEnabled }   { tok_num negative 3 3 binary }+  @negative 0[oO] @octal       / { ifExtension negativeLiteralsEnabled } { tok_num negative 3 3 octal }+  @negative 0[xX] @hexadecimal / { ifExtension negativeLiteralsEnabled } { tok_num negative 3 3 hexadecimal }++  -- Normal rational literals (:: Fractional a => a, from Rational)+  @floating_point                                                        { strtoken tok_float }+  @negative @floating_point    / { ifExtension negativeLiteralsEnabled } { strtoken tok_float }+}++<0> {+  -- Unboxed ints (:: Int#) and words (:: Word#)+  -- It's simpler (and faster?) to give separate cases to the negatives,+  -- especially considering octal/hexadecimal prefixes.+  @decimal                     \# / { ifExtension magicHashEnabled } { tok_primint positive 0 1 decimal }+  0[bB] @binary                \# / { ifExtension magicHashEnabled `alexAndPred`+                                      ifExtension binaryLiteralsEnabled } { tok_primint positive 2 3 binary }+  0[oO] @octal                 \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 octal }+  0[xX] @hexadecimal           \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 hexadecimal }+  @negative @decimal           \# / { ifExtension magicHashEnabled } { tok_primint negative 1 2 decimal }+  @negative 0[bB] @binary      \# / { ifExtension magicHashEnabled `alexAndPred`+                                      ifExtension binaryLiteralsEnabled } { tok_primint negative 3 4 binary }+  @negative 0[oO] @octal       \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 octal }+  @negative 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 hexadecimal }++  @decimal                     \# \# / { ifExtension magicHashEnabled } { tok_primword 0 2 decimal }+  0[bB] @binary                \# \# / { ifExtension magicHashEnabled `alexAndPred`+                                         ifExtension binaryLiteralsEnabled } { tok_primword 2 4 binary }+  0[oO] @octal                 \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 octal }+  0[xX] @hexadecimal           \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 hexadecimal }++  -- Unboxed floats and doubles (:: Float#, :: Double#)+  -- prim_{float,double} work with signed literals+  @signed @floating_point \# / { ifExtension magicHashEnabled } { init_strtoken 1 tok_primfloat }+  @signed @floating_point \# \# / { ifExtension magicHashEnabled } { init_strtoken 2 tok_primdouble }+}++-- Strings and chars are lexed by hand-written code.  The reason is+-- that even if we recognise the string or char here in the regex+-- lexer, we would still have to parse the string afterward in order+-- to convert it to a String.+<0> {+  \'                            { lex_char_tok }+  \"                            { lex_string_tok }+}++-- Note [Lexing type applications]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The desired syntax for type applications is to prefix the type application+-- with '@', like this:+--+--   foo @Int @Bool baz bum+--+-- This, of course, conflicts with as-patterns. The conflict arises because+-- expressions and patterns use the same parser, and also because we want+-- to allow type patterns within expression patterns.+--+-- Disambiguation is accomplished by requiring *something* to appear between+-- type application and the preceding token. This something must end with+-- a character that cannot be the end of the variable bound in an as-pattern.+-- Currently (June 2015), this means that the something cannot end with a+-- $idchar or a close-paren. (The close-paren is necessary if the as-bound+-- identifier is symbolic.)+--+-- Note that looking for whitespace before the '@' is insufficient, because+-- of this pathological case:+--+--   foo {- hi -}@Int+--+-- This design is predicated on the fact that as-patterns are generally+-- whitespace-free, and also that this whole thing is opt-in, with the+-- TypeApplications extension.++-- -----------------------------------------------------------------------------+-- Alex "Haskell code fragment bottom"++{++-- -----------------------------------------------------------------------------+-- The token type++data Token+  = ITas                        -- Haskell keywords+  | ITcase+  | ITclass+  | ITdata+  | ITdefault+  | ITderiving+  | ITdo+  | ITelse+  | IThiding+  | ITforeign+  | ITif+  | ITimport+  | ITin+  | ITinfix+  | ITinfixl+  | ITinfixr+  | ITinstance+  | ITlet+  | ITmodule+  | ITnewtype+  | ITof+  | ITqualified+  | ITthen+  | ITtype+  | ITwhere++  | ITforall            IsUnicodeSyntax -- GHC extension keywords+  | ITexport+  | ITlabel+  | ITdynamic+  | ITsafe+  | ITinterruptible+  | ITunsafe+  | ITstdcallconv+  | ITccallconv+  | ITcapiconv+  | ITprimcallconv+  | ITjavascriptcallconv+  | ITmdo+  | ITfamily+  | ITrole+  | ITgroup+  | ITby+  | ITusing+  | ITpattern+  | ITstatic+  | ITstock+  | ITanyclass++  -- Backpack tokens+  | ITunit+  | ITsignature+  | ITdependency+  | ITrequires++  -- Pragmas, see  note [Pragma source text] in BasicTypes+  | ITinline_prag       SourceText InlineSpec RuleMatchInfo+  | ITspec_prag         SourceText                -- SPECIALISE+  | ITspec_inline_prag  SourceText Bool    -- SPECIALISE INLINE (or NOINLINE)+  | ITsource_prag       SourceText+  | ITrules_prag        SourceText+  | ITwarning_prag      SourceText+  | ITdeprecated_prag   SourceText+  | ITline_prag+  | ITscc_prag          SourceText+  | ITgenerated_prag    SourceText+  | ITcore_prag         SourceText         -- hdaume: core annotations+  | ITunpack_prag       SourceText+  | ITnounpack_prag     SourceText+  | ITann_prag          SourceText+  | ITcomplete_prag     SourceText+  | ITclose_prag+  | IToptions_prag String+  | ITinclude_prag String+  | ITlanguage_prag+  | ITvect_prag         SourceText+  | ITvect_scalar_prag  SourceText+  | ITnovect_prag       SourceText+  | ITminimal_prag      SourceText+  | IToverlappable_prag SourceText  -- instance overlap mode+  | IToverlapping_prag  SourceText  -- instance overlap mode+  | IToverlaps_prag     SourceText  -- instance overlap mode+  | ITincoherent_prag   SourceText  -- instance overlap mode+  | ITctype             SourceText++  | ITdotdot                    -- reserved symbols+  | ITcolon+  | ITdcolon            IsUnicodeSyntax+  | ITequal+  | ITlam+  | ITlcase+  | ITvbar+  | ITlarrow            IsUnicodeSyntax+  | ITrarrow            IsUnicodeSyntax+  | ITat+  | ITtilde+  | ITtildehsh+  | ITdarrow            IsUnicodeSyntax+  | ITminus+  | ITbang+  | ITdot++  | ITbiglam                    -- GHC-extension symbols++  | ITocurly                    -- special symbols+  | ITccurly+  | ITvocurly+  | ITvccurly+  | ITobrack+  | ITopabrack                  -- [:, for parallel arrays with -XParallelArrays+  | ITcpabrack                  -- :], for parallel arrays with -XParallelArrays+  | ITcbrack+  | IToparen+  | ITcparen+  | IToubxparen+  | ITcubxparen+  | ITsemi+  | ITcomma+  | ITunderscore+  | ITbackquote+  | ITsimpleQuote               --  '++  | ITvarid   FastString        -- identifiers+  | ITconid   FastString+  | ITvarsym  FastString+  | ITconsym  FastString+  | ITqvarid  (FastString,FastString)+  | ITqconid  (FastString,FastString)+  | ITqvarsym (FastString,FastString)+  | ITqconsym (FastString,FastString)++  | ITdupipvarid   FastString   -- GHC extension: implicit param: ?x+  | ITlabelvarid   FastString   -- Overloaded label: #x++  | ITchar     SourceText Char       -- Note [Literal source text] in BasicTypes+  | ITstring   SourceText FastString -- Note [Literal source text] in BasicTypes+  | ITinteger  SourceText Integer    -- Note [Literal source text] in BasicTypes+  | ITrational FractionalLit++  | ITprimchar   SourceText Char     -- Note [Literal source text] in BasicTypes+  | ITprimstring SourceText ByteString -- Note [Literal source text] @BasicTypes+  | ITprimint    SourceText Integer  -- Note [Literal source text] in BasicTypes+  | ITprimword   SourceText Integer  -- Note [Literal source text] in BasicTypes+  | ITprimfloat  FractionalLit+  | ITprimdouble FractionalLit++  -- Template Haskell extension tokens+  | ITopenExpQuote HasE IsUnicodeSyntax --  [| or [e|+  | ITopenPatQuote                      --  [p|+  | ITopenDecQuote                      --  [d|+  | ITopenTypQuote                      --  [t|+  | ITcloseQuote IsUnicodeSyntax        --  |]+  | ITopenTExpQuote HasE                --  [|| or [e||+  | ITcloseTExpQuote                    --  ||]+  | ITidEscape   FastString             --  $x+  | ITparenEscape                       --  $(+  | ITidTyEscape   FastString           --  $$x+  | ITparenTyEscape                     --  $$(+  | ITtyQuote                           --  ''+  | ITquasiQuote (FastString,FastString,RealSrcSpan)+    -- ITquasiQuote(quoter, quote, loc)+    -- represents a quasi-quote of the form+    -- [quoter| quote |]+  | ITqQuasiQuote (FastString,FastString,FastString,RealSrcSpan)+    -- ITqQuasiQuote(Qual, quoter, quote, loc)+    -- represents a qualified quasi-quote of the form+    -- [Qual.quoter| quote |]++  -- Arrow notation extension+  | ITproc+  | ITrec+  | IToparenbar  IsUnicodeSyntax --  (|+  | ITcparenbar  IsUnicodeSyntax --  |)+  | ITlarrowtail IsUnicodeSyntax --  -<+  | ITrarrowtail IsUnicodeSyntax --  >-+  | ITLarrowtail IsUnicodeSyntax --  -<<+  | ITRarrowtail IsUnicodeSyntax --  >>-++  -- type application '@' (lexed differently than as-pattern '@',+  -- due to checking for preceding whitespace)+  | ITtypeApp+++  | ITunknown String            -- Used when the lexer can't make sense of it+  | ITeof                       -- end of file token++  -- Documentation annotations+  | ITdocCommentNext  String     -- something beginning '-- |'+  | ITdocCommentPrev  String     -- something beginning '-- ^'+  | ITdocCommentNamed String     -- something beginning '-- $'+  | ITdocSection      Int String -- a section heading+  | ITdocOptions      String     -- doc options (prune, ignore-exports, etc)+  | ITlineComment     String     -- comment starting by "--"+  | ITblockComment    String     -- comment in {- -}++  deriving Show++instance Outputable Token where+  ppr x = text (show x)+++-- the bitmap provided as the third component indicates whether the+-- corresponding extension keyword is valid under the extension options+-- provided to the compiler; if the extension corresponding to *any* of the+-- bits set in the bitmap is enabled, the keyword is valid (this setup+-- facilitates using a keyword in two different extensions that can be+-- activated independently)+--+reservedWordsFM :: UniqFM (Token, ExtsBitmap)+reservedWordsFM = listToUFM $+    map (\(x, y, z) -> (mkFastString x, (y, z)))+        [( "_",              ITunderscore,    0 ),+         ( "as",             ITas,            0 ),+         ( "case",           ITcase,          0 ),+         ( "class",          ITclass,         0 ),+         ( "data",           ITdata,          0 ),+         ( "default",        ITdefault,       0 ),+         ( "deriving",       ITderiving,      0 ),+         ( "do",             ITdo,            0 ),+         ( "else",           ITelse,          0 ),+         ( "hiding",         IThiding,        0 ),+         ( "if",             ITif,            0 ),+         ( "import",         ITimport,        0 ),+         ( "in",             ITin,            0 ),+         ( "infix",          ITinfix,         0 ),+         ( "infixl",         ITinfixl,        0 ),+         ( "infixr",         ITinfixr,        0 ),+         ( "instance",       ITinstance,      0 ),+         ( "let",            ITlet,           0 ),+         ( "module",         ITmodule,        0 ),+         ( "newtype",        ITnewtype,       0 ),+         ( "of",             ITof,            0 ),+         ( "qualified",      ITqualified,     0 ),+         ( "then",           ITthen,          0 ),+         ( "type",           ITtype,          0 ),+         ( "where",          ITwhere,         0 ),++         ( "forall",         ITforall NormalSyntax,+                                              xbit ExplicitForallBit .|.+                                              xbit InRulePragBit),+         ( "mdo",            ITmdo,           xbit RecursiveDoBit),+             -- See Note [Lexing type pseudo-keywords]+         ( "family",         ITfamily,        0 ),+         ( "role",           ITrole,          0 ),+         ( "pattern",        ITpattern,       xbit PatternSynonymsBit),+         ( "static",         ITstatic,        0 ),+         ( "stock",          ITstock,         0 ),+         ( "anyclass",       ITanyclass,      0 ),+         ( "group",          ITgroup,         xbit TransformComprehensionsBit),+         ( "by",             ITby,            xbit TransformComprehensionsBit),+         ( "using",          ITusing,         xbit TransformComprehensionsBit),++         ( "foreign",        ITforeign,       xbit FfiBit),+         ( "export",         ITexport,        xbit FfiBit),+         ( "label",          ITlabel,         xbit FfiBit),+         ( "dynamic",        ITdynamic,       xbit FfiBit),+         ( "safe",           ITsafe,          xbit FfiBit .|.+                                              xbit SafeHaskellBit),+         ( "interruptible",  ITinterruptible, xbit InterruptibleFfiBit),+         ( "unsafe",         ITunsafe,        xbit FfiBit),+         ( "stdcall",        ITstdcallconv,   xbit FfiBit),+         ( "ccall",          ITccallconv,     xbit FfiBit),+         ( "capi",           ITcapiconv,      xbit CApiFfiBit),+         ( "prim",           ITprimcallconv,  xbit FfiBit),+         ( "javascript",     ITjavascriptcallconv, xbit FfiBit),++         ( "unit",           ITunit,          0 ),+         ( "dependency",     ITdependency,       0 ),+         ( "signature",      ITsignature,     0 ),++         ( "rec",            ITrec,           xbit ArrowsBit .|.+                                              xbit RecursiveDoBit),+         ( "proc",           ITproc,          xbit ArrowsBit)+     ]++{-----------------------------------+Note [Lexing type pseudo-keywords]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++One might think that we wish to treat 'family' and 'role' as regular old+varids whenever -XTypeFamilies and -XRoleAnnotations are off, respectively.+But, there is no need to do so. These pseudo-keywords are not stolen syntax:+they are only used after the keyword 'type' at the top-level, where varids are+not allowed. Furthermore, checks further downstream (TcTyClsDecls) ensure that+type families and role annotations are never declared without their extensions+on. In fact, by unconditionally lexing these pseudo-keywords as special, we+can get better error messages.++Also, note that these are included in the `varid` production in the parser --+a key detail to make all this work.+-------------------------------------}++reservedSymsFM :: UniqFM (Token, ExtsBitmap -> Bool)+reservedSymsFM = listToUFM $+    map (\ (x,y,z) -> (mkFastString x,(y,z)))+      [ ("..",  ITdotdot,              always)+        -- (:) is a reserved op, meaning only list cons+       ,(":",   ITcolon,               always)+       ,("::",  ITdcolon NormalSyntax, always)+       ,("=",   ITequal,               always)+       ,("\\",  ITlam,                 always)+       ,("|",   ITvbar,                always)+       ,("<-",  ITlarrow NormalSyntax, always)+       ,("->",  ITrarrow NormalSyntax, always)+       ,("@",   ITat,                  always)+       ,("~",   ITtilde,               always)+       ,("~#",  ITtildehsh,            magicHashEnabled)+       ,("=>",  ITdarrow NormalSyntax, always)+       ,("-",   ITminus,               always)+       ,("!",   ITbang,                always)++        -- For 'forall a . t'+       ,(".", ITdot,  always) -- \i -> explicitForallEnabled i || inRulePrag i)++       ,("-<",  ITlarrowtail NormalSyntax, arrowsEnabled)+       ,(">-",  ITrarrowtail NormalSyntax, arrowsEnabled)+       ,("-<<", ITLarrowtail NormalSyntax, arrowsEnabled)+       ,(">>-", ITRarrowtail NormalSyntax, arrowsEnabled)++       ,("∷",   ITdcolon UnicodeSyntax, unicodeSyntaxEnabled)+       ,("⇒",   ITdarrow UnicodeSyntax, unicodeSyntaxEnabled)+       ,("∀",   ITforall UnicodeSyntax, unicodeSyntaxEnabled)+       ,("→",   ITrarrow UnicodeSyntax, unicodeSyntaxEnabled)+       ,("←",   ITlarrow UnicodeSyntax, unicodeSyntaxEnabled)++       ,("⤙",   ITlarrowtail UnicodeSyntax,+                                \i -> unicodeSyntaxEnabled i && arrowsEnabled i)+       ,("⤚",   ITrarrowtail UnicodeSyntax,+                                \i -> unicodeSyntaxEnabled i && arrowsEnabled i)+       ,("⤛",   ITLarrowtail UnicodeSyntax,+                                \i -> unicodeSyntaxEnabled i && arrowsEnabled i)+       ,("⤜",   ITRarrowtail UnicodeSyntax,+                                \i -> unicodeSyntaxEnabled i && arrowsEnabled i)++        -- ToDo: ideally, → and ∷ should be "specials", so that they cannot+        -- form part of a large operator.  This would let us have a better+        -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe).+       ]++-- -----------------------------------------------------------------------------+-- Lexer actions++type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated Token)++special :: Token -> Action+special tok span _buf _len = return (L span tok)++token, layout_token :: Token -> Action+token t span _buf _len = return (L span t)+layout_token t span _buf _len = pushLexState layout >> return (L span t)++idtoken :: (StringBuffer -> Int -> Token) -> Action+idtoken f span buf len = return (L span $! (f buf len))++skip_one_varid :: (FastString -> Token) -> Action+skip_one_varid f span buf len+  = return (L span $! f (lexemeToFastString (stepOn buf) (len-1)))++skip_two_varid :: (FastString -> Token) -> Action+skip_two_varid f span buf len+  = return (L span $! f (lexemeToFastString (stepOn (stepOn buf)) (len-2)))++strtoken :: (String -> Token) -> Action+strtoken f span buf len =+  return (L span $! (f $! lexemeToString buf len))++init_strtoken :: Int -> (String -> Token) -> Action+-- like strtoken, but drops the last N character(s)+init_strtoken drop f span buf len =+  return (L span $! (f $! lexemeToString buf (len-drop)))++begin :: Int -> Action+begin code _span _str _len = do pushLexState code; lexToken++pop :: Action+pop _span _buf _len = do _ <- popLexState+                         lexToken++hopefully_open_brace :: Action+hopefully_open_brace span buf len+ = do relaxed <- extension relaxedLayout+      ctx <- getContext+      (AI l _) <- getInput+      let offset = srcLocCol l+          isOK = relaxed ||+                 case ctx of+                 Layout prev_off _ : _ -> prev_off < offset+                 _                     -> True+      if isOK then pop_and open_brace span buf len+              else failSpanMsgP (RealSrcSpan span) (text "Missing block")++pop_and :: Action -> Action+pop_and act span buf len = do _ <- popLexState+                              act span buf len++{-# INLINE nextCharIs #-}+nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool+nextCharIs buf p = not (atEnd buf) && p (currentChar buf)++{-# INLINE nextCharIsNot #-}+nextCharIsNot :: StringBuffer -> (Char -> Bool) -> Bool+nextCharIsNot buf p = not (nextCharIs buf p)++notFollowedBy :: Char -> AlexAccPred ExtsBitmap+notFollowedBy char _ _ _ (AI _ buf)+  = nextCharIsNot buf (== char)++notFollowedBySymbol :: AlexAccPred ExtsBitmap+notFollowedBySymbol _ _ _ (AI _ buf)+  = nextCharIsNot buf (`elem` "!#$%&*+./<=>?@\\^|-~")++followedByDigit :: AlexAccPred ExtsBitmap+followedByDigit _ _ _ (AI _ buf)+  = afterOptionalSpace buf (\b -> nextCharIs b (`elem` ['0'..'9']))++ifCurrentChar :: Char -> AlexAccPred ExtsBitmap+ifCurrentChar char _ (AI _ buf) _ _+  = nextCharIs buf (== char)++-- We must reject doc comments as being ordinary comments everywhere.+-- In some cases the doc comment will be selected as the lexeme due to+-- maximal munch, but not always, because the nested comment rule is+-- valid in all states, but the doc-comment rules are only valid in+-- the non-layout states.+isNormalComment :: AlexAccPred ExtsBitmap+isNormalComment bits _ _ (AI _ buf)+  | haddockEnabled bits = notFollowedByDocOrPragma+  | otherwise           = nextCharIsNot buf (== '#')+  where+    notFollowedByDocOrPragma+       = afterOptionalSpace buf (\b -> nextCharIsNot b (`elem` "|^*$#"))++afterOptionalSpace :: StringBuffer -> (StringBuffer -> Bool) -> Bool+afterOptionalSpace buf p+    = if nextCharIs buf (== ' ')+      then p (snd (nextChar buf))+      else p buf++atEOL :: AlexAccPred ExtsBitmap+atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n'++ifExtension :: (ExtsBitmap -> Bool) -> AlexAccPred ExtsBitmap+ifExtension pred bits _ _ _ = pred bits++orExtensions :: (ExtsBitmap -> Bool) -> (ExtsBitmap -> Bool) -> AlexAccPred ExtsBitmap+orExtensions pred1 pred2 bits _ _ _ = pred1 bits || pred2 bits++multiline_doc_comment :: Action+multiline_doc_comment span buf _len = withLexedDocType (worker "")+  where+    worker commentAcc input docType checkNextLine = case alexGetChar' input of+      Just ('\n', input')+        | checkNextLine -> case checkIfCommentLine input' of+          Just input -> worker ('\n':commentAcc) input docType checkNextLine+          Nothing -> docCommentEnd input commentAcc docType buf span+        | otherwise -> docCommentEnd input commentAcc docType buf span+      Just (c, input) -> worker (c:commentAcc) input docType checkNextLine+      Nothing -> docCommentEnd input commentAcc docType buf span++    -- Check if the next line of input belongs to this doc comment as well.+    -- A doc comment continues onto the next line when the following+    -- conditions are met:+    --   * The line starts with "--"+    --   * The line doesn't start with "---".+    --   * The line doesn't start with "-- $", because that would be the+    --     start of a /new/ named haddock chunk (#10398).+    checkIfCommentLine :: AlexInput -> Maybe AlexInput+    checkIfCommentLine input = check (dropNonNewlineSpace input)+      where+        check input = do+          ('-', input) <- alexGetChar' input+          ('-', input) <- alexGetChar' input+          (c, after_c) <- alexGetChar' input+          case c of+            '-' -> Nothing+            ' ' -> case alexGetChar' after_c of+                     Just ('$', _) -> Nothing+                     _ -> Just input+            _   -> Just input++        dropNonNewlineSpace input = case alexGetChar' input of+          Just (c, input')+            | isSpace c && c /= '\n' -> dropNonNewlineSpace input'+            | otherwise -> input+          Nothing -> input++lineCommentToken :: Action+lineCommentToken span buf len = do+  b <- extension rawTokenStreamEnabled+  if b then strtoken ITlineComment span buf len else lexToken++{-+  nested comments require traversing by hand, they can't be parsed+  using regular expressions.+-}+nested_comment :: P (RealLocated Token) -> Action+nested_comment cont span buf len = do+  input <- getInput+  go (reverse $ lexemeToString buf len) (1::Int) input+  where+    go commentAcc 0 input = do+      setInput input+      b <- extension rawTokenStreamEnabled+      if b+        then docCommentEnd input commentAcc ITblockComment buf span+        else cont+    go commentAcc n input = case alexGetChar' input of+      Nothing -> errBrace input span+      Just ('-',input) -> case alexGetChar' input of+        Nothing  -> errBrace input span+        Just ('\125',input) -> go ('\125':'-':commentAcc) (n-1) input -- '}'+        Just (_,_)          -> go ('-':commentAcc) n input+      Just ('\123',input) -> case alexGetChar' input of  -- '{' char+        Nothing  -> errBrace input span+        Just ('-',input) -> go ('-':'\123':commentAcc) (n+1) input+        Just (_,_)       -> go ('\123':commentAcc) n input+      Just (c,input) -> go (c:commentAcc) n input++nested_doc_comment :: Action+nested_doc_comment span buf _len = withLexedDocType (go "")+  where+    go commentAcc input docType _ = case alexGetChar' input of+      Nothing -> errBrace input span+      Just ('-',input) -> case alexGetChar' input of+        Nothing -> errBrace input span+        Just ('\125',input) ->+          docCommentEnd input commentAcc docType buf span+        Just (_,_) -> go ('-':commentAcc) input docType False+      Just ('\123', input) -> case alexGetChar' input of+        Nothing  -> errBrace input span+        Just ('-',input) -> do+          setInput input+          let cont = do input <- getInput; go commentAcc input docType False+          nested_comment cont span buf _len+        Just (_,_) -> go ('\123':commentAcc) input docType False+      Just (c,input) -> go (c:commentAcc) input docType False++withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (RealLocated Token))+                 -> P (RealLocated Token)+withLexedDocType lexDocComment = do+  input@(AI _ buf) <- getInput+  case prevChar buf ' ' of+    -- The `Bool` argument to lexDocComment signals whether or not the next+    -- line of input might also belong to this doc comment.+    '|' -> lexDocComment input ITdocCommentNext True+    '^' -> lexDocComment input ITdocCommentPrev True+    '$' -> lexDocComment input ITdocCommentNamed True+    '*' -> lexDocSection 1 input+    _ -> panic "withLexedDocType: Bad doc type"+ where+    lexDocSection n input = case alexGetChar' input of+      Just ('*', input) -> lexDocSection (n+1) input+      Just (_,   _)     -> lexDocComment input (ITdocSection n) False+      Nothing -> do setInput input; lexToken -- eof reached, lex it normally++-- RULES pragmas turn on the forall and '.' keywords, and we turn them+-- off again at the end of the pragma.+rulePrag :: Action+rulePrag span buf len = do+  setExts (.|. xbit InRulePragBit)+  let !src = lexemeToString buf len+  return (L span (ITrules_prag (SourceText src)))++endPrag :: Action+endPrag span _buf _len = do+  setExts (.&. complement (xbit InRulePragBit))+  return (L span ITclose_prag)++-- docCommentEnd+-------------------------------------------------------------------------------+-- This function is quite tricky. We can't just return a new token, we also+-- need to update the state of the parser. Why? Because the token is longer+-- than what was lexed by Alex, and the lexToken function doesn't know this, so+-- it writes the wrong token length to the parser state. This function is+-- called afterwards, so it can just update the state.++docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer ->+                 RealSrcSpan -> P (RealLocated Token)+docCommentEnd input commentAcc docType buf span = do+  setInput input+  let (AI loc nextBuf) = input+      comment = reverse commentAcc+      span' = mkRealSrcSpan (realSrcSpanStart span) loc+      last_len = byteDiff buf nextBuf++  span `seq` setLastToken span' last_len+  return (L span' (docType comment))++errBrace :: AlexInput -> RealSrcSpan -> P a+errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) end "unterminated `{-'"++open_brace, close_brace :: Action+open_brace span _str _len = do+  ctx <- getContext+  setContext (NoLayout:ctx)+  return (L span ITocurly)+close_brace span _str _len = do+  popContext+  return (L span ITccurly)++qvarid, qconid :: StringBuffer -> Int -> Token+qvarid buf len = ITqvarid $! splitQualName buf len False+qconid buf len = ITqconid $! splitQualName buf len False++splitQualName :: StringBuffer -> Int -> Bool -> (FastString,FastString)+-- takes a StringBuffer and a length, and returns the module name+-- and identifier parts of a qualified name.  Splits at the *last* dot,+-- because of hierarchical module names.+splitQualName orig_buf len parens = split orig_buf orig_buf+  where+    split buf dot_buf+        | orig_buf `byteDiff` buf >= len  = done dot_buf+        | c == '.'                        = found_dot buf'+        | otherwise                       = split buf' dot_buf+      where+       (c,buf') = nextChar buf++    -- careful, we might get names like M....+    -- so, if the character after the dot is not upper-case, this is+    -- the end of the qualifier part.+    found_dot buf -- buf points after the '.'+        | isUpper c    = split buf' buf+        | otherwise    = done buf+      where+       (c,buf') = nextChar buf++    done dot_buf =+        (lexemeToFastString orig_buf (qual_size - 1),+         if parens -- Prelude.(+)+            then lexemeToFastString (stepOn dot_buf) (len - qual_size - 2)+            else lexemeToFastString dot_buf (len - qual_size))+      where+        qual_size = orig_buf `byteDiff` dot_buf++varid :: Action+varid span buf len =+  case lookupUFM reservedWordsFM fs of+    Just (ITcase, _) -> do+      lambdaCase <- extension lambdaCaseEnabled+      keyword <- if lambdaCase+                 then do+                   lastTk <- getLastTk+                   return $ case lastTk of+                     Just ITlam -> ITlcase+                     _          -> ITcase+                 else+                   return ITcase+      maybe_layout keyword+      return $ L span keyword+    Just (ITstatic, _) -> do+      staticPointers <- extension staticPointersEnabled+      if staticPointers+        then return $ L span ITstatic+        else return $ L span $ ITvarid fs+    Just (keyword, 0) -> do+      maybe_layout keyword+      return $ L span keyword+    Just (keyword, exts) -> do+      extsEnabled <- extension $ \i -> exts .&. i /= 0+      if extsEnabled+        then do+          maybe_layout keyword+          return $ L span keyword+        else+          return $ L span $ ITvarid fs+    Nothing ->+      return $ L span $ ITvarid fs+  where+    !fs = lexemeToFastString buf len++conid :: StringBuffer -> Int -> Token+conid buf len = ITconid $! lexemeToFastString buf len++qvarsym, qconsym :: StringBuffer -> Int -> Token+qvarsym buf len = ITqvarsym $! splitQualName buf len False+qconsym buf len = ITqconsym $! splitQualName buf len False++varsym, consym :: Action+varsym = sym ITvarsym+consym = sym ITconsym++sym :: (FastString -> Token) -> Action+sym con span buf len =+  case lookupUFM reservedSymsFM fs of+    Just (keyword, exts) -> do+      extsEnabled <- extension exts+      let !tk | extsEnabled = keyword+              | otherwise   = con fs+      return $ L span tk+    Nothing ->+      return $ L span $! con fs+  where+    !fs = lexemeToFastString buf len++-- Variations on the integral numeric literal.+tok_integral :: (SourceText -> Integer -> Token)+             -> (Integer -> Integer)+             -> Int -> Int+             -> (Integer, (Char -> Int))+             -> Action+tok_integral itint transint transbuf translen (radix,char_to_int) span buf len+ = return $ L span $ itint (SourceText $ lexemeToString buf len)+       $! transint $ parseUnsignedInteger+       (offsetBytes transbuf buf) (subtract translen len) radix char_to_int++-- some conveniences for use with tok_integral+tok_num :: (Integer -> Integer)+        -> Int -> Int+        -> (Integer, (Char->Int)) -> Action+tok_num = tok_integral ITinteger+tok_primint :: (Integer -> Integer)+            -> Int -> Int+            -> (Integer, (Char->Int)) -> Action+tok_primint = tok_integral ITprimint+tok_primword :: Int -> Int+             -> (Integer, (Char->Int)) -> Action+tok_primword = tok_integral ITprimword positive+positive, negative :: (Integer -> Integer)+positive = id+negative = negate+decimal, octal, hexadecimal :: (Integer, Char -> Int)+decimal = (10,octDecDigit)+binary = (2,octDecDigit)+octal = (8,octDecDigit)+hexadecimal = (16,hexDigit)++-- readRational can understand negative rationals, exponents, everything.+tok_float, tok_primfloat, tok_primdouble :: String -> Token+tok_float        str = ITrational   $! readFractionalLit str+tok_primfloat    str = ITprimfloat  $! readFractionalLit str+tok_primdouble   str = ITprimdouble $! readFractionalLit str++readFractionalLit :: String -> FractionalLit+readFractionalLit str = (FL $! str) $! readRational str++-- -----------------------------------------------------------------------------+-- Layout processing++-- we're at the first token on a line, insert layout tokens if necessary+do_bol :: Action+do_bol span _str _len = do+        (pos, gen_semic) <- getOffside+        case pos of+            LT -> do+                --trace "layout: inserting '}'" $ do+                popContext+                -- do NOT pop the lex state, we might have a ';' to insert+                return (L span ITvccurly)+            EQ | gen_semic -> do+                --trace "layout: inserting ';'" $ do+                _ <- popLexState+                return (L span ITsemi)+            _ -> do+                _ <- popLexState+                lexToken++-- certain keywords put us in the "layout" state, where we might+-- add an opening curly brace.+maybe_layout :: Token -> P ()+maybe_layout t = do -- If the alternative layout rule is enabled then+                    -- we never create an implicit layout context here.+                    -- Layout is handled XXX instead.+                    -- The code for closing implicit contexts, or+                    -- inserting implicit semi-colons, is therefore+                    -- irrelevant as it only applies in an implicit+                    -- context.+                    alr <- extension alternativeLayoutRule+                    unless alr $ f t+    where f ITdo    = pushLexState layout_do+          f ITmdo   = pushLexState layout_do+          f ITof    = pushLexState layout+          f ITlcase = pushLexState layout+          f ITlet   = pushLexState layout+          f ITwhere = pushLexState layout+          f ITrec   = pushLexState layout+          f ITif    = pushLexState layout_if+          f _       = return ()++-- Pushing a new implicit layout context.  If the indentation of the+-- next token is not greater than the previous layout context, then+-- Haskell 98 says that the new layout context should be empty; that is+-- the lexer must generate {}.+--+-- We are slightly more lenient than this: when the new context is started+-- by a 'do', then we allow the new context to be at the same indentation as+-- the previous context.  This is what the 'strict' argument is for.+new_layout_context :: Bool -> Bool -> Token -> Action+new_layout_context strict gen_semic tok span _buf len = do+    _ <- popLexState+    (AI l _) <- getInput+    let offset = srcLocCol l - len+    ctx <- getContext+    nondecreasing <- extension nondecreasingIndentation+    let strict' = strict || not nondecreasing+    case ctx of+        Layout prev_off _ : _  |+           (strict'     && prev_off >= offset  ||+            not strict' && prev_off > offset) -> do+                -- token is indented to the left of the previous context.+                -- we must generate a {} sequence now.+                pushLexState layout_left+                return (L span tok)+        _ -> do setContext (Layout offset gen_semic : ctx)+                return (L span tok)++do_layout_left :: Action+do_layout_left span _buf _len = do+    _ <- popLexState+    pushLexState bol  -- we must be at the start of a line+    return (L span ITvccurly)++-- -----------------------------------------------------------------------------+-- LINE pragmas++setLine :: Int -> Action+setLine code span buf len = do+  let line = parseUnsignedInteger buf len 10 octDecDigit+  setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)+        -- subtract one: the line number refers to the *following* line+  _ <- popLexState+  pushLexState code+  lexToken++setColumn :: Action+setColumn span buf len = do+  let column =+        case reads (lexemeToString buf len) of+          [(column, _)] -> column+          _ -> error "setColumn: expected integer" -- shouldn't happen+  setSrcLoc (mkRealSrcLoc (srcSpanFile span) (srcSpanEndLine span)+                          (fromIntegral (column :: Integer)))+  _ <- popLexState+  lexToken++setFile :: Int -> Action+setFile code span buf len = do+  let file = mkFastString (go (lexemeToString (stepOn buf) (len-2)))+        where go ('\\':c:cs) = c : go cs+              go (c:cs)      = c : go cs+              go []          = []+              -- decode escapes in the filename.  e.g. on Windows+              -- when our filenames have backslashes in, gcc seems to+              -- escape the backslashes.  One symptom of not doing this+              -- is that filenames in error messages look a bit strange:+              --   C:\\foo\bar.hs+              -- only the first backslash is doubled, because we apply+              -- System.FilePath.normalise before printing out+              -- filenames and it does not remove duplicate+              -- backslashes after the drive letter (should it?).+  setAlrLastLoc $ alrInitialLoc file+  setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))+  addSrcFile file+  _ <- popLexState+  pushLexState code+  lexToken++alrInitialLoc :: FastString -> RealSrcSpan+alrInitialLoc file = mkRealSrcSpan loc loc+    where -- This is a hack to ensure that the first line in a file+          -- looks like it is after the initial location:+          loc = mkRealSrcLoc file (-1) (-1)++-- -----------------------------------------------------------------------------+-- Options, includes and language pragmas.++lex_string_prag :: (String -> Token) -> Action+lex_string_prag mkTok span _buf _len+    = do input <- getInput+         start <- getSrcLoc+         tok <- go [] input+         end <- getSrcLoc+         return (L (mkRealSrcSpan start end) tok)+    where go acc input+              = if isString input "#-}"+                   then do setInput input+                           return (mkTok (reverse acc))+                   else case alexGetChar input of+                          Just (c,i) -> go (c:acc) i+                          Nothing -> err input+          isString _ [] = True+          isString i (x:xs)+              = case alexGetChar i of+                  Just (c,i') | c == x    -> isString i' xs+                  _other -> False+          err (AI end _) = failLocMsgP (realSrcSpanStart span) end "unterminated options pragma"+++-- -----------------------------------------------------------------------------+-- Strings & Chars++-- This stuff is horrible.  I hates it.++lex_string_tok :: Action+lex_string_tok span buf _len = do+  tok <- lex_string ""+  (AI end bufEnd) <- getInput+  let+    tok' = case tok of+            ITprimstring _ bs -> ITprimstring (SourceText src) bs+            ITstring _ s -> ITstring (SourceText src) s+            _ -> panic "lex_string_tok"+    src = lexemeToString buf (cur bufEnd - cur buf)+  return (L (mkRealSrcSpan (realSrcSpanStart span) end) tok')++lex_string :: String -> P Token+lex_string s = do+  i <- getInput+  case alexGetChar' i of+    Nothing -> lit_error i++    Just ('"',i)  -> do+        setInput i+        magicHash <- extension magicHashEnabled+        if magicHash+          then do+            i <- getInput+            case alexGetChar' i of+              Just ('#',i) -> do+                   setInput i+                   if any (> '\xFF') s+                    then failMsgP "primitive string literal must contain only characters <= \'\\xFF\'"+                    else let bs = unsafeMkByteString (reverse s)+                         in return (ITprimstring (SourceText (reverse s)) bs)+              _other ->+                return (ITstring (SourceText (reverse s))+                                 (mkFastString (reverse s)))+          else+                return (ITstring (SourceText (reverse s))+                                 (mkFastString (reverse s)))++    Just ('\\',i)+        | Just ('&',i) <- next -> do+                setInput i; lex_string s+        | Just (c,i) <- next, c <= '\x7f' && is_space c -> do+                           -- is_space only works for <= '\x7f' (#3751, #5425)+                setInput i; lex_stringgap s+        where next = alexGetChar' i++    Just (c, i1) -> do+        case c of+          '\\' -> do setInput i1; c' <- lex_escape; lex_string (c':s)+          c | isAny c -> do setInput i1; lex_string (c:s)+          _other -> lit_error i++lex_stringgap :: String -> P Token+lex_stringgap s = do+  i <- getInput+  c <- getCharOrFail i+  case c of+    '\\' -> lex_string s+    c | c <= '\x7f' && is_space c -> lex_stringgap s+                           -- is_space only works for <= '\x7f' (#3751, #5425)+    _other -> lit_error i+++lex_char_tok :: Action+-- Here we are basically parsing character literals, such as 'x' or '\n'+-- but we additionally spot 'x and ''T, returning ITsimpleQuote and+-- ITtyQuote respectively, but WITHOUT CONSUMING the x or T part+-- (the parser does that).+-- So we have to do two characters of lookahead: when we see 'x we need to+-- see if there's a trailing quote+lex_char_tok span buf _len = do        -- We've seen '+   i1 <- getInput       -- Look ahead to first character+   let loc = realSrcSpanStart span+   case alexGetChar' i1 of+        Nothing -> lit_error  i1++        Just ('\'', i2@(AI end2 _)) -> do       -- We've seen ''+                   setInput i2+                   return (L (mkRealSrcSpan loc end2)  ITtyQuote)++        Just ('\\', i2@(AI _end2 _)) -> do      -- We've seen 'backslash+                  setInput i2+                  lit_ch <- lex_escape+                  i3 <- getInput+                  mc <- getCharOrFail i3 -- Trailing quote+                  if mc == '\'' then finish_char_tok buf loc lit_ch+                                else lit_error i3++        Just (c, i2@(AI _end2 _))+                | not (isAny c) -> lit_error i1+                | otherwise ->++                -- We've seen 'x, where x is a valid character+                --  (i.e. not newline etc) but not a quote or backslash+           case alexGetChar' i2 of      -- Look ahead one more character+                Just ('\'', i3) -> do   -- We've seen 'x'+                        setInput i3+                        finish_char_tok buf loc c+                _other -> do            -- We've seen 'x not followed by quote+                                        -- (including the possibility of EOF)+                                        -- Just parse the quote only+                        let (AI end _) = i1+                        return (L (mkRealSrcSpan loc end) ITsimpleQuote)++finish_char_tok :: StringBuffer -> RealSrcLoc -> Char -> P (RealLocated Token)+finish_char_tok buf loc ch  -- We've already seen the closing quote+                        -- Just need to check for trailing #+  = do  magicHash <- extension magicHashEnabled+        i@(AI end bufEnd) <- getInput+        let src = lexemeToString buf (cur bufEnd - cur buf)+        if magicHash then do+            case alexGetChar' i of+              Just ('#',i@(AI end _)) -> do+                setInput i+                return (L (mkRealSrcSpan loc end)+                          (ITprimchar (SourceText src) ch))+              _other ->+                return (L (mkRealSrcSpan loc end)+                          (ITchar (SourceText src) ch))+            else do+              return (L (mkRealSrcSpan loc end) (ITchar (SourceText src) ch))++isAny :: Char -> Bool+isAny c | c > '\x7f' = isPrint c+        | otherwise  = is_any c++lex_escape :: P Char+lex_escape = do+  i0 <- getInput+  c <- getCharOrFail i0+  case c of+        'a'   -> return '\a'+        'b'   -> return '\b'+        'f'   -> return '\f'+        'n'   -> return '\n'+        'r'   -> return '\r'+        't'   -> return '\t'+        'v'   -> return '\v'+        '\\'  -> return '\\'+        '"'   -> return '\"'+        '\''  -> return '\''+        '^'   -> do i1 <- getInput+                    c <- getCharOrFail i1+                    if c >= '@' && c <= '_'+                        then return (chr (ord c - ord '@'))+                        else lit_error i1++        'x'   -> readNum is_hexdigit 16 hexDigit+        'o'   -> readNum is_octdigit  8 octDecDigit+        x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x)++        c1 ->  do+           i <- getInput+           case alexGetChar' i of+            Nothing -> lit_error i0+            Just (c2,i2) ->+              case alexGetChar' i2 of+                Nothing -> do lit_error i0+                Just (c3,i3) ->+                   let str = [c1,c2,c3] in+                   case [ (c,rest) | (p,c) <- silly_escape_chars,+                                     Just rest <- [stripPrefix p str] ] of+                          (escape_char,[]):_ -> do+                                setInput i3+                                return escape_char+                          (escape_char,_:_):_ -> do+                                setInput i2+                                return escape_char+                          [] -> lit_error i0++readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char+readNum is_digit base conv = do+  i <- getInput+  c <- getCharOrFail i+  if is_digit c+        then readNum2 is_digit base conv (conv c)+        else lit_error i++readNum2 :: (Char -> Bool) -> Int -> (Char -> Int) -> Int -> P Char+readNum2 is_digit base conv i = do+  input <- getInput+  read i input+  where read i input = do+          case alexGetChar' input of+            Just (c,input') | is_digit c -> do+               let i' = i*base + conv c+               if i' > 0x10ffff+                  then setInput input >> lexError "numeric escape sequence out of range"+                  else read i' input'+            _other -> do+              setInput input; return (chr i)+++silly_escape_chars :: [(String, Char)]+silly_escape_chars = [+        ("NUL", '\NUL'),+        ("SOH", '\SOH'),+        ("STX", '\STX'),+        ("ETX", '\ETX'),+        ("EOT", '\EOT'),+        ("ENQ", '\ENQ'),+        ("ACK", '\ACK'),+        ("BEL", '\BEL'),+        ("BS", '\BS'),+        ("HT", '\HT'),+        ("LF", '\LF'),+        ("VT", '\VT'),+        ("FF", '\FF'),+        ("CR", '\CR'),+        ("SO", '\SO'),+        ("SI", '\SI'),+        ("DLE", '\DLE'),+        ("DC1", '\DC1'),+        ("DC2", '\DC2'),+        ("DC3", '\DC3'),+        ("DC4", '\DC4'),+        ("NAK", '\NAK'),+        ("SYN", '\SYN'),+        ("ETB", '\ETB'),+        ("CAN", '\CAN'),+        ("EM", '\EM'),+        ("SUB", '\SUB'),+        ("ESC", '\ESC'),+        ("FS", '\FS'),+        ("GS", '\GS'),+        ("RS", '\RS'),+        ("US", '\US'),+        ("SP", '\SP'),+        ("DEL", '\DEL')+        ]++-- before calling lit_error, ensure that the current input is pointing to+-- the position of the error in the buffer.  This is so that we can report+-- a correct location to the user, but also so we can detect UTF-8 decoding+-- errors if they occur.+lit_error :: AlexInput -> P a+lit_error i = do setInput i; lexError "lexical error in string/character literal"++getCharOrFail :: AlexInput -> P Char+getCharOrFail i =  do+  case alexGetChar' i of+        Nothing -> lexError "unexpected end-of-file in string/character literal"+        Just (c,i)  -> do setInput i; return c++-- -----------------------------------------------------------------------------+-- QuasiQuote++lex_qquasiquote_tok :: Action+lex_qquasiquote_tok span buf len = do+  let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False+  quoteStart <- getSrcLoc+  quote <- lex_quasiquote quoteStart ""+  end <- getSrcLoc+  return (L (mkRealSrcSpan (realSrcSpanStart span) end)+           (ITqQuasiQuote (qual,+                           quoter,+                           mkFastString (reverse quote),+                           mkRealSrcSpan quoteStart end)))++lex_quasiquote_tok :: Action+lex_quasiquote_tok span buf len = do+  let quoter = tail (lexemeToString buf (len - 1))+                -- 'tail' drops the initial '[',+                -- while the -1 drops the trailing '|'+  quoteStart <- getSrcLoc+  quote <- lex_quasiquote quoteStart ""+  end <- getSrcLoc+  return (L (mkRealSrcSpan (realSrcSpanStart span) end)+           (ITquasiQuote (mkFastString quoter,+                          mkFastString (reverse quote),+                          mkRealSrcSpan quoteStart end)))++lex_quasiquote :: RealSrcLoc -> String -> P String+lex_quasiquote start s = do+  i <- getInput+  case alexGetChar' i of+    Nothing -> quasiquote_error start++    -- NB: The string "|]" terminates the quasiquote,+    -- with absolutely no escaping. See the extensive+    -- discussion on Trac #5348 for why there is no+    -- escape handling.+    Just ('|',i)+        | Just (']',i) <- alexGetChar' i+        -> do { setInput i; return s }++    Just (c, i) -> do+         setInput i; lex_quasiquote start (c : s)++quasiquote_error :: RealSrcLoc -> P a+quasiquote_error start = do+  (AI end buf) <- getInput+  reportLexError start end buf "unterminated quasiquotation"++-- -----------------------------------------------------------------------------+-- Warnings++warnTab :: Action+warnTab srcspan _buf _len = do+    addTabWarning srcspan+    lexToken++warnThen :: WarningFlag -> SDoc -> Action -> Action+warnThen option warning action srcspan buf len = do+    addWarning option (RealSrcSpan srcspan) warning+    action srcspan buf len++-- -----------------------------------------------------------------------------+-- The Parse Monad++-- | Do we want to generate ';' layout tokens? In some cases we just want to+-- generate '}', e.g. in MultiWayIf we don't need ';'s because '|' separates+-- alternatives (unlike a `case` expression where we need ';' to as a separator+-- between alternatives).+type GenSemic = Bool++generateSemic, dontGenerateSemic :: GenSemic+generateSemic     = True+dontGenerateSemic = False++data LayoutContext+  = NoLayout+  | Layout !Int !GenSemic+  deriving Show++data ParseResult a+  = POk PState a+  | PFailed+        SrcSpan         -- The start and end of the text span related to+                        -- the error.  Might be used in environments which can+                        -- show this span, e.g. by highlighting it.+        MsgDoc          -- The error message++-- | Test whether a 'WarningFlag' is set+warnopt :: WarningFlag -> ParserFlags -> Bool+warnopt f options = fromEnum f `IntSet.member` pWarningFlags options++-- | Test whether a 'LangExt.Extension' is set+extopt :: LangExt.Extension -> ParserFlags -> Bool+extopt f options = fromEnum f `IntSet.member` pExtensionFlags options++-- | The subset of the 'DynFlags' used by the parser+data ParserFlags = ParserFlags {+    pWarningFlags   :: IntSet+  , pExtensionFlags :: IntSet+  , pThisPackage    :: UnitId      -- ^ key of package currently being compiled+  , pExtsBitmap     :: !ExtsBitmap -- ^ bitmap of permitted extensions+  }++data PState = PState {+        buffer     :: StringBuffer,+        options    :: ParserFlags,+        -- This needs to take DynFlags as an argument until+        -- we have a fix for #10143+        messages   :: DynFlags -> Messages,+        tab_first  :: Maybe RealSrcSpan, -- pos of first tab warning in the file+        tab_count  :: !Int,              -- number of tab warnings in the file+        last_tk    :: Maybe Token,+        last_loc   :: RealSrcSpan, -- pos of previous token+        last_len   :: !Int,        -- len of previous token+        loc        :: RealSrcLoc,  -- current loc (end of prev token + 1)+        context    :: [LayoutContext],+        lex_state  :: [Int],+        srcfiles   :: [FastString],+        -- Used in the alternative layout rule:+        -- These tokens are the next ones to be sent out. They are+        -- just blindly emitted, without the rule looking at them again:+        alr_pending_implicit_tokens :: [RealLocated Token],+        -- This is the next token to be considered or, if it is Nothing,+        -- we need to get the next token from the input stream:+        alr_next_token :: Maybe (RealLocated Token),+        -- This is what we consider to be the location of the last token+        -- emitted:+        alr_last_loc :: RealSrcSpan,+        -- The stack of layout contexts:+        alr_context :: [ALRContext],+        -- Are we expecting a '{'? If it's Just, then the ALRLayout tells+        -- us what sort of layout the '{' will open:+        alr_expecting_ocurly :: Maybe ALRLayout,+        -- Have we just had the '}' for a let block? If so, than an 'in'+        -- token doesn't need to close anything:+        alr_justClosedExplicitLetBlock :: Bool,++        -- The next three are used to implement Annotations giving the+        -- locations of 'noise' tokens in the source, so that users of+        -- the GHC API can do source to source conversions.+        -- See note [Api annotations] in ApiAnnotation.hs+        annotations :: [(ApiAnnKey,[SrcSpan])],+        comment_q :: [Located AnnotationComment],+        annotations_comments :: [(SrcSpan,[Located AnnotationComment])]+     }+        -- last_loc and last_len are used when generating error messages,+        -- and in pushCurrentContext only.  Sigh, if only Happy passed the+        -- current token to happyError, we could at least get rid of last_len.+        -- Getting rid of last_loc would require finding another way to+        -- implement pushCurrentContext (which is only called from one place).++data ALRContext = ALRNoLayout Bool{- does it contain commas? -}+                              Bool{- is it a 'let' block? -}+                | ALRLayout ALRLayout Int+data ALRLayout = ALRLayoutLet+               | ALRLayoutWhere+               | ALRLayoutOf+               | ALRLayoutDo++newtype P a = P { unP :: PState -> ParseResult a }++instance Functor P where+  fmap = liftM++instance Applicative P where+  pure = returnP+  (<*>) = ap++instance Monad P where+  (>>=) = thenP+  fail = failP++#if __GLASGOW_HASKELL__ > 710+instance MonadFail P where+  fail = failP+#endif++returnP :: a -> P a+returnP a = a `seq` (P $ \s -> POk s a)++thenP :: P a -> (a -> P b) -> P b+(P m) `thenP` k = P $ \ s ->+        case m s of+                POk s1 a         -> (unP (k a)) s1+                PFailed span err -> PFailed span err++failP :: String -> P a+failP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg)++failMsgP :: String -> P a+failMsgP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg)++failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a+failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str)++failSpanMsgP :: SrcSpan -> SDoc -> P a+failSpanMsgP span msg = P $ \_ -> PFailed span msg++getPState :: P PState+getPState = P $ \s -> POk s s++withThisPackage :: (UnitId -> a) -> P a+withThisPackage f = P $ \s@(PState{options = o}) -> POk s (f (pThisPackage o))++extension :: (ExtsBitmap -> Bool) -> P Bool+extension p = P $ \s -> POk s (p $! (pExtsBitmap . options) s)++getExts :: P ExtsBitmap+getExts = P $ \s -> POk s (pExtsBitmap . options $ s)++setExts :: (ExtsBitmap -> ExtsBitmap) -> P ()+setExts f = P $ \s -> POk s {+  options =+    let p = options s+    in  p { pExtsBitmap = f (pExtsBitmap p) }+  } ()++setSrcLoc :: RealSrcLoc -> P ()+setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()++getSrcLoc :: P RealSrcLoc+getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc++addSrcFile :: FastString -> P ()+addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } ()++setLastToken :: RealSrcSpan -> Int -> P ()+setLastToken loc len = P $ \s -> POk s {+  last_loc=loc,+  last_len=len+  } ()++setLastTk :: Token -> P ()+setLastTk tk = P $ \s -> POk s { last_tk = Just tk } ()++getLastTk :: P (Maybe Token)+getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk++data AlexInput = AI RealSrcLoc StringBuffer++alexInputPrevChar :: AlexInput -> Char+alexInputPrevChar (AI _ buf) = prevChar buf '\n'++-- backwards compatibility for Alex 2.x+alexGetChar :: AlexInput -> Maybe (Char,AlexInput)+alexGetChar inp = case alexGetByte inp of+                    Nothing    -> Nothing+                    Just (b,i) -> c `seq` Just (c,i)+                       where c = chr $ fromIntegral b++alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)+alexGetByte (AI loc s)+  | atEnd s   = Nothing+  | otherwise = byte `seq` loc' `seq` s' `seq`+                --trace (show (ord c)) $+                Just (byte, (AI loc' s'))+  where (c,s') = nextChar s+        loc'   = advanceSrcLoc loc c+        byte   = fromIntegral $ ord adj_c++        non_graphic     = '\x00'+        upper           = '\x01'+        lower           = '\x02'+        digit           = '\x03'+        symbol          = '\x04'+        space           = '\x05'+        other_graphic   = '\x06'+        uniidchar       = '\x07'++        adj_c+          | c <= '\x07' = non_graphic+          | c <= '\x7f' = c+          -- Alex doesn't handle Unicode, so when Unicode+          -- character is encountered we output these values+          -- with the actual character value hidden in the state.+          | otherwise =+                -- NB: The logic behind these definitions is also reflected+                -- in basicTypes/Lexeme.hs+                -- Any changes here should likely be reflected there.++                case generalCategory c of+                  UppercaseLetter       -> upper+                  LowercaseLetter       -> lower+                  TitlecaseLetter       -> upper+                  ModifierLetter        -> uniidchar -- see #10196+                  OtherLetter           -> lower -- see #1103+                  NonSpacingMark        -> uniidchar -- see #7650+                  SpacingCombiningMark  -> other_graphic+                  EnclosingMark         -> other_graphic+                  DecimalNumber         -> digit+                  LetterNumber          -> other_graphic+                  OtherNumber           -> digit -- see #4373+                  ConnectorPunctuation  -> symbol+                  DashPunctuation       -> symbol+                  OpenPunctuation       -> other_graphic+                  ClosePunctuation      -> other_graphic+                  InitialQuote          -> other_graphic+                  FinalQuote            -> other_graphic+                  OtherPunctuation      -> symbol+                  MathSymbol            -> symbol+                  CurrencySymbol        -> symbol+                  ModifierSymbol        -> symbol+                  OtherSymbol           -> symbol+                  Space                 -> space+                  _other                -> non_graphic++-- This version does not squash unicode characters, it is used when+-- lexing strings.+alexGetChar' :: AlexInput -> Maybe (Char,AlexInput)+alexGetChar' (AI loc s)+  | atEnd s   = Nothing+  | otherwise = c `seq` loc' `seq` s' `seq`+                --trace (show (ord c)) $+                Just (c, (AI loc' s'))+  where (c,s') = nextChar s+        loc'   = advanceSrcLoc loc c++getInput :: P AlexInput+getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b)++setInput :: AlexInput -> P ()+setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } ()++nextIsEOF :: P Bool+nextIsEOF = do+  AI _ s <- getInput+  return $ atEnd s++pushLexState :: Int -> P ()+pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} ()++popLexState :: P Int+popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls++getLexState :: P Int+getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls++popNextToken :: P (Maybe (RealLocated Token))+popNextToken+    = P $ \s@PState{ alr_next_token = m } ->+              POk (s {alr_next_token = Nothing}) m++activeContext :: P Bool+activeContext = do+  ctxt <- getALRContext+  expc <- getAlrExpectingOCurly+  impt <- implicitTokenPending+  case (ctxt,expc) of+    ([],Nothing) -> return impt+    _other       -> return True++setAlrLastLoc :: RealSrcSpan -> P ()+setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) ()++getAlrLastLoc :: P RealSrcSpan+getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l++getALRContext :: P [ALRContext]+getALRContext = P $ \s@(PState {alr_context = cs}) -> POk s cs++setALRContext :: [ALRContext] -> P ()+setALRContext cs = P $ \s -> POk (s {alr_context = cs}) ()++getALRTransitional :: P Bool+getALRTransitional = P $ \s@PState {options = o} ->+  POk s (extopt LangExt.AlternativeLayoutRuleTransitional o)++getJustClosedExplicitLetBlock :: P Bool+getJustClosedExplicitLetBlock+ = P $ \s@(PState {alr_justClosedExplicitLetBlock = b}) -> POk s b++setJustClosedExplicitLetBlock :: Bool -> P ()+setJustClosedExplicitLetBlock b+ = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) ()++setNextToken :: RealLocated Token -> P ()+setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) ()++implicitTokenPending :: P Bool+implicitTokenPending+    = P $ \s@PState{ alr_pending_implicit_tokens = ts } ->+              case ts of+              [] -> POk s False+              _  -> POk s True++popPendingImplicitToken :: P (Maybe (RealLocated Token))+popPendingImplicitToken+    = P $ \s@PState{ alr_pending_implicit_tokens = ts } ->+              case ts of+              [] -> POk s Nothing+              (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t)++setPendingImplicitTokens :: [RealLocated Token] -> P ()+setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) ()++getAlrExpectingOCurly :: P (Maybe ALRLayout)+getAlrExpectingOCurly = P $ \s@(PState {alr_expecting_ocurly = b}) -> POk s b++setAlrExpectingOCurly :: Maybe ALRLayout -> P ()+setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) ()++-- for reasons of efficiency, flags indicating language extensions (eg,+-- -fglasgow-exts or -XParallelArrays) are represented by a bitmap+-- stored in an unboxed Word64+type ExtsBitmap = Word64++xbit :: ExtBits -> ExtsBitmap+xbit = bit . fromEnum++xtest :: ExtBits -> ExtsBitmap -> Bool+xtest ext xmap = testBit xmap (fromEnum ext)++data ExtBits+  = FfiBit+  | InterruptibleFfiBit+  | CApiFfiBit+  | ParrBit+  | ArrowsBit+  | ThBit+  | ThQuotesBit+  | IpBit+  | OverloadedLabelsBit -- #x overloaded labels+  | ExplicitForallBit -- the 'forall' keyword and '.' symbol+  | BangPatBit -- Tells the parser to understand bang-patterns+               -- (doesn't affect the lexer)+  | PatternSynonymsBit -- pattern synonyms+  | HaddockBit-- Lex and parse Haddock comments+  | MagicHashBit -- "#" in both functions and operators+  | RecursiveDoBit -- mdo+  | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc+  | UnboxedTuplesBit -- (# and #)+  | UnboxedSumsBit -- (# and #)+  | DatatypeContextsBit+  | TransformComprehensionsBit+  | QqBit -- enable quasiquoting+  | InRulePragBit+  | RawTokenStreamBit -- producing a token stream with all comments included+  | SccProfilingOnBit+  | HpcBit+  | AlternativeLayoutRuleBit+  | RelaxedLayoutBit+  | NondecreasingIndentationBit+  | SafeHaskellBit+  | TraditionalRecordSyntaxBit+  | ExplicitNamespacesBit+  | LambdaCaseBit+  | BinaryLiteralsBit+  | NegativeLiteralsBit+  | TypeApplicationsBit+  | StaticPointersBit+  deriving Enum+++always :: ExtsBitmap -> Bool+always           _     = True+parrEnabled :: ExtsBitmap -> Bool+parrEnabled = xtest ParrBit+arrowsEnabled :: ExtsBitmap -> Bool+arrowsEnabled = xtest ArrowsBit+thEnabled :: ExtsBitmap -> Bool+thEnabled = xtest ThBit+thQuotesEnabled :: ExtsBitmap -> Bool+thQuotesEnabled = xtest ThQuotesBit+ipEnabled :: ExtsBitmap -> Bool+ipEnabled = xtest IpBit+overloadedLabelsEnabled :: ExtsBitmap -> Bool+overloadedLabelsEnabled = xtest OverloadedLabelsBit+explicitForallEnabled :: ExtsBitmap -> Bool+explicitForallEnabled = xtest ExplicitForallBit+bangPatEnabled :: ExtsBitmap -> Bool+bangPatEnabled = xtest BangPatBit+haddockEnabled :: ExtsBitmap -> Bool+haddockEnabled = xtest HaddockBit+magicHashEnabled :: ExtsBitmap -> Bool+magicHashEnabled = xtest MagicHashBit+unicodeSyntaxEnabled :: ExtsBitmap -> Bool+unicodeSyntaxEnabled = xtest UnicodeSyntaxBit+unboxedTuplesEnabled :: ExtsBitmap -> Bool+unboxedTuplesEnabled = xtest UnboxedTuplesBit+unboxedSumsEnabled :: ExtsBitmap -> Bool+unboxedSumsEnabled = xtest UnboxedSumsBit+datatypeContextsEnabled :: ExtsBitmap -> Bool+datatypeContextsEnabled = xtest DatatypeContextsBit+qqEnabled :: ExtsBitmap -> Bool+qqEnabled = xtest QqBit+inRulePrag :: ExtsBitmap -> Bool+inRulePrag = xtest InRulePragBit+rawTokenStreamEnabled :: ExtsBitmap -> Bool+rawTokenStreamEnabled = xtest RawTokenStreamBit+alternativeLayoutRule :: ExtsBitmap -> Bool+alternativeLayoutRule = xtest AlternativeLayoutRuleBit+hpcEnabled :: ExtsBitmap -> Bool+hpcEnabled = xtest HpcBit+relaxedLayout :: ExtsBitmap -> Bool+relaxedLayout = xtest RelaxedLayoutBit+nondecreasingIndentation :: ExtsBitmap -> Bool+nondecreasingIndentation = xtest NondecreasingIndentationBit+sccProfilingOn :: ExtsBitmap -> Bool+sccProfilingOn = xtest SccProfilingOnBit+traditionalRecordSyntaxEnabled :: ExtsBitmap -> Bool+traditionalRecordSyntaxEnabled = xtest TraditionalRecordSyntaxBit++explicitNamespacesEnabled :: ExtsBitmap -> Bool+explicitNamespacesEnabled = xtest ExplicitNamespacesBit+lambdaCaseEnabled :: ExtsBitmap -> Bool+lambdaCaseEnabled = xtest LambdaCaseBit+binaryLiteralsEnabled :: ExtsBitmap -> Bool+binaryLiteralsEnabled = xtest BinaryLiteralsBit+negativeLiteralsEnabled :: ExtsBitmap -> Bool+negativeLiteralsEnabled = xtest NegativeLiteralsBit+patternSynonymsEnabled :: ExtsBitmap -> Bool+patternSynonymsEnabled = xtest PatternSynonymsBit+typeApplicationEnabled :: ExtsBitmap -> Bool+typeApplicationEnabled = xtest TypeApplicationsBit+staticPointersEnabled :: ExtsBitmap -> Bool+staticPointersEnabled = xtest StaticPointersBit++-- PState for parsing options pragmas+--+pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState+pragState dynflags buf loc = (mkPState dynflags buf loc) {+                                 lex_state = [bol, option_prags, 0]+                             }++-- | Extracts the flag information needed for parsing+mkParserFlags :: DynFlags -> ParserFlags+mkParserFlags flags =+    ParserFlags {+      pWarningFlags = DynFlags.warningFlags flags+    , pExtensionFlags = DynFlags.extensionFlags flags+    , pThisPackage = DynFlags.thisPackage flags+    , pExtsBitmap = bitmap+    }+  where+      bitmap =     FfiBit                      `setBitIf` xopt LangExt.ForeignFunctionInterface flags+               .|. InterruptibleFfiBit         `setBitIf` xopt LangExt.InterruptibleFFI         flags+               .|. CApiFfiBit                  `setBitIf` xopt LangExt.CApiFFI                  flags+               .|. ParrBit                     `setBitIf` xopt LangExt.ParallelArrays           flags+               .|. ArrowsBit                   `setBitIf` xopt LangExt.Arrows                   flags+               .|. ThBit                       `setBitIf` xopt LangExt.TemplateHaskell          flags+               .|. ThQuotesBit                 `setBitIf` xopt LangExt.TemplateHaskellQuotes    flags+               .|. QqBit                       `setBitIf` xopt LangExt.QuasiQuotes              flags+               .|. IpBit                       `setBitIf` xopt LangExt.ImplicitParams           flags+               .|. OverloadedLabelsBit         `setBitIf` xopt LangExt.OverloadedLabels         flags+               .|. ExplicitForallBit           `setBitIf` xopt LangExt.ExplicitForAll           flags+               .|. BangPatBit                  `setBitIf` xopt LangExt.BangPatterns             flags+               .|. HaddockBit                  `setBitIf` gopt Opt_Haddock                      flags+               .|. MagicHashBit                `setBitIf` xopt LangExt.MagicHash                flags+               .|. RecursiveDoBit              `setBitIf` xopt LangExt.RecursiveDo              flags+               .|. UnicodeSyntaxBit            `setBitIf` xopt LangExt.UnicodeSyntax            flags+               .|. UnboxedTuplesBit            `setBitIf` xopt LangExt.UnboxedTuples            flags+               .|. UnboxedSumsBit              `setBitIf` xopt LangExt.UnboxedSums              flags+               .|. DatatypeContextsBit         `setBitIf` xopt LangExt.DatatypeContexts         flags+               .|. TransformComprehensionsBit  `setBitIf` xopt LangExt.TransformListComp        flags+               .|. TransformComprehensionsBit  `setBitIf` xopt LangExt.MonadComprehensions      flags+               .|. RawTokenStreamBit           `setBitIf` gopt Opt_KeepRawTokenStream           flags+               .|. HpcBit                      `setBitIf` gopt Opt_Hpc                          flags+               .|. AlternativeLayoutRuleBit    `setBitIf` xopt LangExt.AlternativeLayoutRule    flags+               .|. RelaxedLayoutBit            `setBitIf` xopt LangExt.RelaxedLayout            flags+               .|. SccProfilingOnBit           `setBitIf` gopt Opt_SccProfilingOn               flags+               .|. NondecreasingIndentationBit `setBitIf` xopt LangExt.NondecreasingIndentation flags+               .|. SafeHaskellBit              `setBitIf` safeImportsOn                         flags+               .|. TraditionalRecordSyntaxBit  `setBitIf` xopt LangExt.TraditionalRecordSyntax  flags+               .|. ExplicitNamespacesBit       `setBitIf` xopt LangExt.ExplicitNamespaces flags+               .|. LambdaCaseBit               `setBitIf` xopt LangExt.LambdaCase               flags+               .|. BinaryLiteralsBit           `setBitIf` xopt LangExt.BinaryLiterals           flags+               .|. NegativeLiteralsBit         `setBitIf` xopt LangExt.NegativeLiterals         flags+               .|. PatternSynonymsBit          `setBitIf` xopt LangExt.PatternSynonyms          flags+               .|. TypeApplicationsBit         `setBitIf` xopt LangExt.TypeApplications         flags+               .|. StaticPointersBit           `setBitIf` xopt LangExt.StaticPointers           flags++      setBitIf :: ExtBits -> Bool -> ExtsBitmap+      b `setBitIf` cond | cond      = xbit b+                        | otherwise = 0++-- | Creates a parse state from a 'DynFlags' value+mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState+mkPState flags = mkPStatePure (mkParserFlags flags)++-- | Creates a parse state from a 'ParserFlags' value+mkPStatePure :: ParserFlags -> StringBuffer -> RealSrcLoc -> PState+mkPStatePure options buf loc =+  PState {+      buffer        = buf,+      options       = options,+      messages      = const emptyMessages,+      tab_first     = Nothing,+      tab_count     = 0,+      last_tk       = Nothing,+      last_loc      = mkRealSrcSpan loc loc,+      last_len      = 0,+      loc           = loc,+      context       = [],+      lex_state     = [bol, 0],+      srcfiles      = [],+      alr_pending_implicit_tokens = [],+      alr_next_token = Nothing,+      alr_last_loc = alrInitialLoc (fsLit "<no file>"),+      alr_context = [],+      alr_expecting_ocurly = Nothing,+      alr_justClosedExplicitLetBlock = False,+      annotations = [],+      comment_q = [],+      annotations_comments = []+    }++addWarning :: WarningFlag -> SrcSpan -> SDoc -> P ()+addWarning option srcspan warning+ = P $ \s@PState{messages=m, options=o} ->+       let+           m' d =+               let (ws, es) = m d+                   warning' = makeIntoWarning (Reason option) $+                      mkWarnMsg d srcspan alwaysQualify warning+                   ws' = if warnopt option o then ws `snocBag` warning' else ws+               in (ws', es)+       in POk s{messages=m'} ()++addTabWarning :: RealSrcSpan -> P ()+addTabWarning srcspan+ = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} ->+       let tf' = if isJust tf then tf else Just srcspan+           tc' = tc + 1+           s' = if warnopt Opt_WarnTabs o+                then s{tab_first = tf', tab_count = tc'}+                else s+       in POk s' ()++mkTabWarning :: PState -> DynFlags -> Maybe ErrMsg+mkTabWarning PState{tab_first=tf, tab_count=tc} d =+  let middle = if tc == 1+        then text ""+        else text ", and in" <+> speakNOf (tc - 1) (text "further location")+      message = text "Tab character found here"+                <> middle+                <> text "."+                $+$ text "Please use spaces instead."+  in fmap (\s -> makeIntoWarning (Reason Opt_WarnTabs) $+                 mkWarnMsg d (RealSrcSpan s) alwaysQualify message) tf++getMessages :: PState -> DynFlags -> Messages+getMessages p@PState{messages=m} d =+  let (ws, es) = m d+      tabwarning = mkTabWarning p d+      ws' = maybe ws (`consBag` ws) tabwarning+  in (ws', es)++getContext :: P [LayoutContext]+getContext = P $ \s@PState{context=ctx} -> POk s ctx++setContext :: [LayoutContext] -> P ()+setContext ctx = P $ \s -> POk s{context=ctx} ()++popContext :: P ()+popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx,+                              last_len = len, last_loc = last_loc }) ->+  case ctx of+        (_:tl) -> POk s{ context = tl } ()+        []     -> PFailed (RealSrcSpan last_loc) (srcParseErr o buf len)++-- Push a new layout context at the indentation of the last token read.+pushCurrentContext :: GenSemic -> P ()+pushCurrentContext gen_semic = P $ \ s@PState{ last_loc=loc, context=ctx } ->+    POk s{context = Layout (srcSpanStartCol loc) gen_semic : ctx} ()++-- This is only used at the outer level of a module when the 'module' keyword is+-- missing.+pushModuleContext :: P ()+pushModuleContext = pushCurrentContext generateSemic++getOffside :: P (Ordering, Bool)+getOffside = P $ \s@PState{last_loc=loc, context=stk} ->+                let offs = srcSpanStartCol loc in+                let ord = case stk of+                            Layout n gen_semic : _ ->+                              --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $+                              (compare offs n, gen_semic)+                            _ ->+                              (GT, dontGenerateSemic)+                in POk s ord++-- ---------------------------------------------------------------------------+-- Construct a parse error++srcParseErr+  :: ParserFlags+  -> StringBuffer       -- current buffer (placed just after the last token)+  -> Int                -- length of the previous token+  -> MsgDoc+srcParseErr options buf len+  = if null token+         then text "parse error (possibly incorrect indentation or mismatched brackets)"+         else text "parse error on input" <+> quotes (text token)+              $$ ppWhen (not th_enabled && token == "$") -- #7396+                        (text "Perhaps you intended to use TemplateHaskell")+              $$ ppWhen (token == "<-")+                        (text "Perhaps this statement should be within a 'do' block?")+              $$ ppWhen (token == "=")+                        (text "Perhaps you need a 'let' in a 'do' block?"+                         $$ text "e.g. 'let x = 5' instead of 'x = 5'")+              $$ ppWhen (not ps_enabled && pattern == "pattern") -- #12429+                        (text "Perhaps you intended to use PatternSynonyms")+  where token = lexemeToString (offsetBytes (-len) buf) len+        pattern = lexemeToString (offsetBytes (-len - 8) buf) 7+        th_enabled = extopt LangExt.TemplateHaskell options+        ps_enabled = extopt LangExt.PatternSynonyms options++-- Report a parse failure, giving the span of the previous token as+-- the location of the error.  This is the entry point for errors+-- detected during parsing.+srcParseFail :: P a+srcParseFail = P $ \PState{ buffer = buf, options = o, last_len = len,+                            last_loc = last_loc } ->+    PFailed (RealSrcSpan last_loc) (srcParseErr o buf len)++-- A lexical error is reported at a particular position in the source file,+-- not over a token range.+lexError :: String -> P a+lexError str = do+  loc <- getSrcLoc+  (AI end buf) <- getInput+  reportLexError loc end buf str++-- -----------------------------------------------------------------------------+-- This is the top-level function: called from the parser each time a+-- new token is to be read from the input.++lexer :: Bool -> (Located Token -> P a) -> P a+lexer queueComments cont = do+  alr <- extension alternativeLayoutRule+  let lexTokenFun = if alr then lexTokenAlr else lexToken+  (L span tok) <- lexTokenFun+  --trace ("token: " ++ show tok) $ do++  case tok of+    ITeof -> addAnnotationOnly noSrcSpan AnnEofPos (RealSrcSpan span)+    _ -> return ()++  if (queueComments && isDocComment tok)+    then queueComment (L (RealSrcSpan span) tok)+    else return ()++  if (queueComments && isComment tok)+    then queueComment (L (RealSrcSpan span) tok) >> lexer queueComments cont+    else cont (L (RealSrcSpan span) tok)++lexTokenAlr :: P (RealLocated Token)+lexTokenAlr = do mPending <- popPendingImplicitToken+                 t <- case mPending of+                      Nothing ->+                          do mNext <- popNextToken+                             t <- case mNext of+                                  Nothing -> lexToken+                                  Just next -> return next+                             alternativeLayoutRuleToken t+                      Just t ->+                          return t+                 setAlrLastLoc (getLoc t)+                 case unLoc t of+                     ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere)+                     ITlet   -> setAlrExpectingOCurly (Just ALRLayoutLet)+                     ITof    -> setAlrExpectingOCurly (Just ALRLayoutOf)+                     ITdo    -> setAlrExpectingOCurly (Just ALRLayoutDo)+                     ITmdo   -> setAlrExpectingOCurly (Just ALRLayoutDo)+                     ITrec   -> setAlrExpectingOCurly (Just ALRLayoutDo)+                     _       -> return ()+                 return t++alternativeLayoutRuleToken :: RealLocated Token -> P (RealLocated Token)+alternativeLayoutRuleToken t+    = do context <- getALRContext+         lastLoc <- getAlrLastLoc+         mExpectingOCurly <- getAlrExpectingOCurly+         transitional <- getALRTransitional+         justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock+         setJustClosedExplicitLetBlock False+         let thisLoc = getLoc t+             thisCol = srcSpanStartCol thisLoc+             newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc+         case (unLoc t, context, mExpectingOCurly) of+             -- This case handles a GHC extension to the original H98+             -- layout rule...+             (ITocurly, _, Just alrLayout) ->+                 do setAlrExpectingOCurly Nothing+                    let isLet = case alrLayout of+                                ALRLayoutLet -> True+                                _ -> False+                    setALRContext (ALRNoLayout (containsCommas ITocurly) isLet : context)+                    return t+             -- ...and makes this case unnecessary+             {-+             -- I think our implicit open-curly handling is slightly+             -- different to John's, in how it interacts with newlines+             -- and "in"+             (ITocurly, _, Just _) ->+                 do setAlrExpectingOCurly Nothing+                    setNextToken t+                    lexTokenAlr+             -}+             (_, ALRLayout _ col : _ls, Just expectingOCurly)+              | (thisCol > col) ||+                (thisCol == col &&+                 isNonDecreasingIntentation expectingOCurly) ->+                 do setAlrExpectingOCurly Nothing+                    setALRContext (ALRLayout expectingOCurly thisCol : context)+                    setNextToken t+                    return (L thisLoc ITocurly)+              | otherwise ->+                 do setAlrExpectingOCurly Nothing+                    setPendingImplicitTokens [L lastLoc ITccurly]+                    setNextToken t+                    return (L lastLoc ITocurly)+             (_, _, Just expectingOCurly) ->+                 do setAlrExpectingOCurly Nothing+                    setALRContext (ALRLayout expectingOCurly thisCol : context)+                    setNextToken t+                    return (L thisLoc ITocurly)+             -- We do the [] cases earlier than in the spec, as we+             -- have an actual EOF token+             (ITeof, ALRLayout _ _ : ls, _) ->+                 do setALRContext ls+                    setNextToken t+                    return (L thisLoc ITccurly)+             (ITeof, _, _) ->+                 return t+             -- the other ITeof case omitted; general case below covers it+             (ITin, _, _)+              | justClosedExplicitLetBlock ->+                 return t+             (ITin, ALRLayout ALRLayoutLet _ : ls, _)+              | newLine ->+                 do setPendingImplicitTokens [t]+                    setALRContext ls+                    return (L thisLoc ITccurly)+             -- This next case is to handle a transitional issue:+             (ITwhere, ALRLayout _ col : ls, _)+              | newLine && thisCol == col && transitional ->+                 do addWarning Opt_WarnAlternativeLayoutRuleTransitional+                               (RealSrcSpan thisLoc)+                               (transitionalAlternativeLayoutWarning+                                    "`where' clause at the same depth as implicit layout block")+                    setALRContext ls+                    setNextToken t+                    -- Note that we use lastLoc, as we may need to close+                    -- more layouts, or give a semicolon+                    return (L lastLoc ITccurly)+             -- This next case is to handle a transitional issue:+             (ITvbar, ALRLayout _ col : ls, _)+              | newLine && thisCol == col && transitional ->+                 do addWarning Opt_WarnAlternativeLayoutRuleTransitional+                               (RealSrcSpan thisLoc)+                               (transitionalAlternativeLayoutWarning+                                    "`|' at the same depth as implicit layout block")+                    setALRContext ls+                    setNextToken t+                    -- Note that we use lastLoc, as we may need to close+                    -- more layouts, or give a semicolon+                    return (L lastLoc ITccurly)+             (_, ALRLayout _ col : ls, _)+              | newLine && thisCol == col ->+                 do setNextToken t+                    return (L thisLoc ITsemi)+              | newLine && thisCol < col ->+                 do setALRContext ls+                    setNextToken t+                    -- Note that we use lastLoc, as we may need to close+                    -- more layouts, or give a semicolon+                    return (L lastLoc ITccurly)+             -- We need to handle close before open, as 'then' is both+             -- an open and a close+             (u, _, _)+              | isALRclose u ->+                 case context of+                 ALRLayout _ _ : ls ->+                     do setALRContext ls+                        setNextToken t+                        return (L thisLoc ITccurly)+                 ALRNoLayout _ isLet : ls ->+                     do let ls' = if isALRopen u+                                     then ALRNoLayout (containsCommas u) False : ls+                                     else ls+                        setALRContext ls'+                        when isLet $ setJustClosedExplicitLetBlock True+                        return t+                 [] ->+                     do let ls = if isALRopen u+                                    then [ALRNoLayout (containsCommas u) False]+                                    else []+                        setALRContext ls+                        -- XXX This is an error in John's code, but+                        -- it looks reachable to me at first glance+                        return t+             (u, _, _)+              | isALRopen u ->+                 do setALRContext (ALRNoLayout (containsCommas u) False : context)+                    return t+             (ITin, ALRLayout ALRLayoutLet _ : ls, _) ->+                 do setALRContext ls+                    setPendingImplicitTokens [t]+                    return (L thisLoc ITccurly)+             (ITin, ALRLayout _ _ : ls, _) ->+                 do setALRContext ls+                    setNextToken t+                    return (L thisLoc ITccurly)+             -- the other ITin case omitted; general case below covers it+             (ITcomma, ALRLayout _ _ : ls, _)+              | topNoLayoutContainsCommas ls ->+                 do setALRContext ls+                    setNextToken t+                    return (L thisLoc ITccurly)+             (ITwhere, ALRLayout ALRLayoutDo _ : ls, _) ->+                 do setALRContext ls+                    setPendingImplicitTokens [t]+                    return (L thisLoc ITccurly)+             -- the other ITwhere case omitted; general case below covers it+             (_, _, _) -> return t++transitionalAlternativeLayoutWarning :: String -> SDoc+transitionalAlternativeLayoutWarning msg+    = text "transitional layout will not be accepted in the future:"+   $$ text msg++isALRopen :: Token -> Bool+isALRopen ITcase          = True+isALRopen ITif            = True+isALRopen ITthen          = True+isALRopen IToparen        = True+isALRopen ITobrack        = True+isALRopen ITocurly        = True+-- GHC Extensions:+isALRopen IToubxparen     = True+isALRopen ITparenEscape   = True+isALRopen ITparenTyEscape = True+isALRopen _               = False++isALRclose :: Token -> Bool+isALRclose ITof     = True+isALRclose ITthen   = True+isALRclose ITelse   = True+isALRclose ITcparen = True+isALRclose ITcbrack = True+isALRclose ITccurly = True+-- GHC Extensions:+isALRclose ITcubxparen = True+isALRclose _        = False++isNonDecreasingIntentation :: ALRLayout -> Bool+isNonDecreasingIntentation ALRLayoutDo = True+isNonDecreasingIntentation _           = False++containsCommas :: Token -> Bool+containsCommas IToparen = True+containsCommas ITobrack = True+-- John doesn't have {} as containing commas, but records contain them,+-- which caused a problem parsing Cabal's Distribution.Simple.InstallDirs+-- (defaultInstallDirs).+containsCommas ITocurly = True+-- GHC Extensions:+containsCommas IToubxparen = True+containsCommas _        = False++topNoLayoutContainsCommas :: [ALRContext] -> Bool+topNoLayoutContainsCommas [] = False+topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls+topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b++lexToken :: P (RealLocated Token)+lexToken = do+  inp@(AI loc1 buf) <- getInput+  sc <- getLexState+  exts <- getExts+  case alexScanUser exts inp sc of+    AlexEOF -> do+        let span = mkRealSrcSpan loc1 loc1+        setLastToken span 0+        return (L span ITeof)+    AlexError (AI loc2 buf) ->+        reportLexError loc1 loc2 buf "lexical error"+    AlexSkip inp2 _ -> do+        setInput inp2+        lexToken+    AlexToken inp2@(AI end buf2) _ t -> do+        setInput inp2+        let span = mkRealSrcSpan loc1 end+        let bytes = byteDiff buf buf2+        span `seq` setLastToken span bytes+        lt <- t span buf bytes+        case unLoc lt of+          ITlineComment _  -> return lt+          ITblockComment _ -> return lt+          lt' -> do+            setLastTk lt'+            return lt++reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a+reportLexError loc1 loc2 buf str+  | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input")+  | otherwise =+  let c = fst (nextChar buf)+  in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar#+     then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)")+     else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c)++lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token]+lexTokenStream buf loc dflags = unP go initState+    where dflags' = gopt_set (gopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream+          initState = mkPState dflags' buf loc+          go = do+            ltok <- lexer False return+            case ltok of+              L _ ITeof -> return []+              _ -> liftM (ltok:) go++linePrags = Map.singleton "line" (begin line_prag2)++fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag),+                                 ("options_ghc", lex_string_prag IToptions_prag),+                                 ("options_haddock", lex_string_prag ITdocOptions),+                                 ("language", token ITlanguage_prag),+                                 ("include", lex_string_prag ITinclude_prag)])++ignoredPrags = Map.fromList (map ignored pragmas)+               where ignored opt = (opt, nested_comment lexToken)+                     impls = ["hugs", "nhc98", "jhc", "yhc", "catch", "derive"]+                     options_pragmas = map ("options_" ++) impls+                     -- CFILES is a hugs-only thing.+                     pragmas = options_pragmas ++ ["cfiles", "contract"]++oneWordPrags = Map.fromList [+     ("rules", rulePrag),+     ("inline",+         strtoken (\s -> (ITinline_prag (SourceText s) Inline FunLike))),+     ("inlinable",+         strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))),+     ("inlineable",+         strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))),+                                    -- Spelling variant+     ("notinline",+         strtoken (\s -> (ITinline_prag (SourceText s) NoInline FunLike))),+     ("specialize", strtoken (\s -> ITspec_prag (SourceText s))),+     ("source", strtoken (\s -> ITsource_prag (SourceText s))),+     ("warning", strtoken (\s -> ITwarning_prag (SourceText s))),+     ("deprecated", strtoken (\s -> ITdeprecated_prag (SourceText s))),+     ("scc", strtoken (\s -> ITscc_prag (SourceText s))),+     ("generated", strtoken (\s -> ITgenerated_prag (SourceText s))),+     ("core", strtoken (\s -> ITcore_prag (SourceText s))),+     ("unpack", strtoken (\s -> ITunpack_prag (SourceText s))),+     ("nounpack", strtoken (\s -> ITnounpack_prag (SourceText s))),+     ("ann", strtoken (\s -> ITann_prag (SourceText s))),+     ("vectorize", strtoken (\s -> ITvect_prag (SourceText s))),+     ("novectorize", strtoken (\s -> ITnovect_prag (SourceText s))),+     ("minimal", strtoken (\s -> ITminimal_prag (SourceText s))),+     ("overlaps", strtoken (\s -> IToverlaps_prag (SourceText s))),+     ("overlappable", strtoken (\s -> IToverlappable_prag (SourceText s))),+     ("overlapping", strtoken (\s -> IToverlapping_prag (SourceText s))),+     ("incoherent", strtoken (\s -> ITincoherent_prag (SourceText s))),+     ("ctype", strtoken (\s -> ITctype (SourceText s))),+     ("complete", strtoken (\s -> ITcomplete_prag (SourceText s))),+     ("column", begin column_prag)+     ]++twoWordPrags = Map.fromList([+     ("inline conlike",+         strtoken (\s -> (ITinline_prag (SourceText s) Inline ConLike))),+     ("notinline conlike",+         strtoken (\s -> (ITinline_prag (SourceText s) NoInline ConLike))),+     ("specialize inline",+         strtoken (\s -> (ITspec_inline_prag (SourceText s) True))),+     ("specialize notinline",+         strtoken (\s -> (ITspec_inline_prag (SourceText s) False))),+     ("vectorize scalar",+         strtoken (\s -> ITvect_scalar_prag (SourceText s)))])++dispatch_pragmas :: Map String Action -> Action+dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of+                                       Just found -> found span buf len+                                       Nothing -> lexError "unknown pragma"++known_pragma :: Map String Action -> AlexAccPred ExtsBitmap+known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf)+ = isKnown && nextCharIsNot curbuf pragmaNameChar+    where l = lexemeToString startbuf (byteDiff startbuf curbuf)+          isKnown = isJust $ Map.lookup (clean_pragma l) prags+          pragmaNameChar c = isAlphaNum c || c == '_'++clean_pragma :: String -> String+clean_pragma prag = canon_ws (map toLower (unprefix prag))+                    where unprefix prag' = case stripPrefix "{-#" prag' of+                                             Just rest -> rest+                                             Nothing -> prag'+                          canonical prag' = case prag' of+                                              "noinline" -> "notinline"+                                              "specialise" -> "specialize"+                                              "vectorise" -> "vectorize"+                                              "novectorise" -> "novectorize"+                                              "constructorlike" -> "conlike"+                                              _ -> prag'+                          canon_ws s = unwords (map canonical (words s))++++{-+%************************************************************************+%*                                                                      *+        Helper functions for generating annotations in the parser+%*                                                                      *+%************************************************************************+-}++-- | Encapsulated call to addAnnotation, requiring only the SrcSpan of+--   the AST construct the annotation belongs to; together with the+--   AnnKeywordId, this is the key of the annotation map.+--+--   This type is useful for places in the parser where it is not yet+--   known what SrcSpan an annotation should be added to.  The most+--   common situation is when we are parsing a list: the annotations+--   need to be associated with the AST element that *contains* the+--   list, not the list itself.  'AddAnn' lets us defer adding the+--   annotations until we finish parsing the list and are now parsing+--   the enclosing element; we then apply the 'AddAnn' to associate+--   the annotations.  Another common situation is where a common fragment of+--   the AST has been factored out but there is no separate AST node for+--   this fragment (this occurs in class and data declarations). In this+--   case, the annotation belongs to the parent data declaration.+--+--   The usual way an 'AddAnn' is created is using the 'mj' ("make jump")+--   function, and then it can be discharged using the 'ams' function.+type AddAnn = SrcSpan -> P ()++addAnnotation :: SrcSpan          -- SrcSpan of enclosing AST construct+              -> AnnKeywordId     -- The first two parameters are the key+              -> SrcSpan          -- The location of the keyword itself+              -> P ()+addAnnotation l a v = do+  addAnnotationOnly l a v+  allocateComments l++addAnnotationOnly :: SrcSpan -> AnnKeywordId -> SrcSpan -> P ()+addAnnotationOnly l a v = P $ \s -> POk s {+  annotations = ((l,a), [v]) : annotations s+  } ()++-- |Given a location and a list of AddAnn, apply them all to the location.+addAnnsAt :: SrcSpan -> [AddAnn] -> P ()+addAnnsAt loc anns = mapM_ (\a -> a loc) anns++-- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate+-- 'AddAnn' values for the opening and closing bordering on the start+-- and end of the span+mkParensApiAnn :: SrcSpan -> [AddAnn]+mkParensApiAnn (UnhelpfulSpan _)  = []+mkParensApiAnn s@(RealSrcSpan ss) = [mj AnnOpenP lo,mj AnnCloseP lc]+  where+    mj a l = (\s -> addAnnotation s a l)+    f = srcSpanFile ss+    sl = srcSpanStartLine ss+    sc = srcSpanStartCol ss+    el = srcSpanEndLine ss+    ec = srcSpanEndCol ss+    lo = mkSrcSpan (srcSpanStart s)         (mkSrcLoc f sl (sc+1))+    lc = mkSrcSpan (mkSrcLoc f el (ec - 1)) (srcSpanEnd s)++-- | Move the annotations and comments belonging to the @old@ span to the @new@+--   one.+moveAnnotations :: SrcSpan -> SrcSpan -> P ()+moveAnnotations old new = P $ \s ->+  let+    updateAnn ((l,a),v)+      | l == old = ((new,a),v)+      | otherwise = ((l,a),v)+    updateComment (l,c)+      | l == old = (new,c)+      | otherwise = (l,c)+  in+    POk s {+       annotations = map updateAnn (annotations s)+     , annotations_comments = map updateComment (annotations_comments s)+     } ()++queueComment :: Located Token -> P()+queueComment c = P $ \s -> POk s {+  comment_q = commentToAnnotation c : comment_q s+  } ()++-- | Go through the @comment_q@ in @PState@ and remove all comments+-- that belong within the given span+allocateComments :: SrcSpan -> P ()+allocateComments ss = P $ \s ->+  let+    (before,rest)  = break (\(L l _) -> isSubspanOf l ss) (comment_q s)+    (middle,after) = break (\(L l _) -> not (isSubspanOf l ss)) rest+    comment_q' = before ++ after+    newAnns = if null middle then []+                             else [(ss,middle)]+  in+    POk s {+       comment_q = comment_q'+     , annotations_comments = newAnns ++ (annotations_comments s)+     } ()++commentToAnnotation :: Located Token -> Located AnnotationComment+commentToAnnotation (L l (ITdocCommentNext s))  = L l (AnnDocCommentNext s)+commentToAnnotation (L l (ITdocCommentPrev s))  = L l (AnnDocCommentPrev s)+commentToAnnotation (L l (ITdocCommentNamed s)) = L l (AnnDocCommentNamed s)+commentToAnnotation (L l (ITdocSection n s))    = L l (AnnDocSection n s)+commentToAnnotation (L l (ITdocOptions s))      = L l (AnnDocOptions s)+commentToAnnotation (L l (ITlineComment s))     = L l (AnnLineComment s)+commentToAnnotation (L l (ITblockComment s))    = L l (AnnBlockComment s)+commentToAnnotation _                           = panic "commentToAnnotation"++-- ---------------------------------------------------------------------++isComment :: Token -> Bool+isComment (ITlineComment     _)   = True+isComment (ITblockComment    _)   = True+isComment _ = False++isDocComment :: Token -> Bool+isDocComment (ITdocCommentNext  _)   = True+isDocComment (ITdocCommentPrev  _)   = True+isDocComment (ITdocCommentNamed _)   = True+isDocComment (ITdocSection      _ _) = True+isDocComment (ITdocOptions      _)   = True+isDocComment _ = False++{- Note [Warnings in code generated by Alex]++We add the following warning suppression flags to all code generated by Alex:++{-# OPTIONS_GHC -fno-warn-unused-matches #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++Without these flags, current versions of Alex will generate code that is not+warning free. Note that this is the result of Alex' internals, not of the way+we have written our (Lexer).x files.++As always, we need code to be warning free when validating with -Werror.++The list of flags is as short as possible (at the time of writing), to try to+avoid suppressing warnings for bugs in our own code.++TODO. Reevaluate this situation once Alex >3.1.4 is released. Hopefully you+can remove these flags from all (Lexer).x files in the repository, and also+delete this Note. Don't forget to update aclocal.m4, and send a HEADS UP+message to ghc-devs.++The first release of Alex after 3.1.4 will either suppress all warnings itself+[1] (bad), or most warnings will be fixed and only a few select ones will be+suppressed by default [2] (better).++[1] https://github.com/simonmar/alex/commit/1eefcde22ba1bb9b51d523814415714e20f0761e+[2] https://github.com/simonmar/alex/pull/69+-}+}
+ parser/Parser.y view
@@ -0,0 +1,3723 @@+--                                                              -*-haskell-*-+-- ---------------------------------------------------------------------------+-- (c) The University of Glasgow 1997-2003+---+-- The GHC grammar.+--+-- Author(s): Simon Marlow, Sven Panne 1997, 1998, 1999+-- ---------------------------------------------------------------------------++{+-- | This module provides the generated Happy parser for Haskell. It exports+-- a number of parsers which may be used in any library that uses the GHC API.+-- A common usage pattern is to initialize the parser state with a given string+-- and then parse that string:+--+-- @+--     runParser :: DynFlags -> String -> P a -> ParseResult a+--     runParser flags str parser = unP parser parseState+--     where+--       filename = "\<interactive\>"+--       location = mkRealSrcLoc (mkFastString filename) 1 1+--       buffer = stringToStringBuffer str+--       parseState = mkPState flags buffer location+-- @+module Parser (parseModule, parseSignature, parseImport, parseStatement, parseBackpack,+               parseDeclaration, parseExpression, parsePattern,+               parseTypeSignature,+               parseStmt, parseIdentifier,+               parseType, parseHeader) where++-- base+import Control.Monad    ( unless, liftM )+import GHC.Exts+import Data.Char+import Control.Monad    ( mplus )+import Control.Applicative ((<$))++-- compiler/hsSyn+import HsSyn++-- compiler/main+import HscTypes         ( IsBootInterface, WarningTxt(..) )+import DynFlags+import BkpSyn+import PackageConfig++-- compiler/utils+import OrdList+import BooleanFormula   ( BooleanFormula(..), LBooleanFormula(..), mkTrue )+import FastString+import Maybes           ( orElse )+import Outputable++-- compiler/basicTypes+import RdrName+import OccName          ( varName, dataName, tcClsName, tvName, startsWithUnderscore )+import DataCon          ( DataCon, dataConName )+import SrcLoc+import Module+import BasicTypes++-- compiler/types+import Type             ( funTyCon )+import Kind             ( Kind )+import Class            ( FunDep )++-- compiler/parser+import RdrHsSyn+import Lexer+import HaddockUtils+import ApiAnnotation++-- compiler/typecheck+import TcEvidence       ( emptyTcEvBinds )++-- compiler/prelude+import ForeignCall+import TysPrim          ( eqPrimTyCon )+import PrelNames        ( eqTyCon_RDR )+import TysWiredIn       ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon,+                          unboxedUnitTyCon, unboxedUnitDataCon,+                          listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR )++-- compiler/utils+import Util             ( looksLikePackageName )+import Prelude++import qualified GHC.LanguageExtensions as LangExt+}++%expect 36 -- shift/reduce conflicts++{- Last updated: 3 Aug 2016++If you modify this parser and add a conflict, please update this comment.+You can learn more about the conflicts by passing 'happy' the -i flag:++    happy -agc --strict compiler/parser/Parser.y -idetailed-info++How is this section formatted? Look up the state the conflict is+reported at, and copy the list of applicable rules (at the top, without the+rule numbers).  Mark *** for the rule that is the conflicting reduction (that+is, the interpretation which is NOT taken).  NB: Happy doesn't print a rule+in a state if it is empty, but you should include it in the list (you can+look these up in the Grammar section of the info file).++Obviously the state numbers are not stable across modifications to the parser,+the idea is to reproduce enough information on each conflict so you can figure+out what happened if the states were renumbered.  Try not to gratuitously move+productions around in this file.++-------------------------------------------------------------------------------++state 0 contains 1 shift/reduce conflicts.++    Conflicts: DOCNEXT (empty missing_module_keyword reduces)++Ambiguity when the source file starts with "-- | doc". We need another+token of lookahead to determine if a top declaration or the 'module' keyword+follows. Shift parses as if the 'module' keyword follows.++-------------------------------------------------------------------------------++state 48 contains 2 shift/reduce conflicts.++    *** strict_mark -> unpackedness .+        strict_mark -> unpackedness . strictness++    Conflicts: '~' '!'++-------------------------------------------------------------------------------++state 52 contains 1 shift/reduce conflict.++        context -> btype .+    *** type -> btype .+        type -> btype . '->' ctype++    Conflicts: '->'++-------------------------------------------------------------------------------++state 53 contains 9 shift/reduce conflicts.++    *** btype -> tyapps .+        tyapps -> tyapps . tyapp++    Conflicts: ':' '-' '!' '.' '`' VARSYM CONSYM QVARSYM QCONSYM++-------------------------------------------------------------------------------++state 134 contains 14 shift/reduce conflicts.++        exp -> infixexp . '::' sigtype+        exp -> infixexp . '-<' exp+        exp -> infixexp . '>-' exp+        exp -> infixexp . '-<<' exp+        exp -> infixexp . '>>-' exp+    *** exp -> infixexp .+        infixexp -> infixexp . qop exp10++    Conflicts: ':' '::' '-' '!' '-<' '>-' '-<<' '>>-'+               '.' '`' VARSYM CONSYM QVARSYM QCONSYM++Examples of ambiguity:+    'if x then y else z -< e'+    'if x then y else z :: T'+    'if x then y else z + 1' (NB: '+' is in VARSYM)++Shift parses as (per longest-parse rule):+    'if x then y else (z -< T)'+    'if x then y else (z :: T)'+    'if x then y else (z + 1)'++-------------------------------------------------------------------------------++state 299 contains 1 shift/reduce conflicts.++        rule -> STRING . rule_activation rule_forall infixexp '=' exp++    Conflict: '[' (empty rule_activation reduces)++We don't know whether the '[' starts the activation or not: it+might be the start of the declaration with the activation being+empty.  --SDM 1/4/2002++Example ambiguity:+    '{-# RULE [0] f = ... #-}'++We parse this as having a [0] rule activation for rewriting 'f', rather+a rule instructing how to rewrite the expression '[0] f'.++-------------------------------------------------------------------------------++state 309 contains 1 shift/reduce conflict.++    *** type -> btype .+        type -> btype . '->' ctype++    Conflict: '->'++Same as state 50 but without contexts.++-------------------------------------------------------------------------------++state 348 contains 1 shift/reduce conflicts.++        tup_exprs -> commas . tup_tail+        sysdcon_nolist -> '(' commas . ')'+        commas -> commas . ','++    Conflict: ')' (empty tup_tail reduces)++A tuple section with NO free variables '(,,)' is indistinguishable+from the Haskell98 data constructor for a tuple.  Shift resolves in+favor of sysdcon, which is good because a tuple section will get rejected+if -XTupleSections is not specified.++-------------------------------------------------------------------------------++state 402 contains 1 shift/reduce conflicts.++        tup_exprs -> commas . tup_tail+        sysdcon_nolist -> '(#' commas . '#)'+        commas -> commas . ','++    Conflict: '#)' (empty tup_tail reduces)++Same as State 324 for unboxed tuples.++-------------------------------------------------------------------------------++state 477 contains 1 shift/reduce conflict.++        oqtycon -> '(' qtyconsym . ')'+    *** qtyconop -> qtyconsym .++    Conflict: ')'++TODO: Why?++-------------------------------------------------------------------------------++state 658 contains 1 shift/reduce conflicts.++    *** aexp2 -> ipvar .+        dbind -> ipvar . '=' exp++    Conflict: '='++Example ambiguity: 'let ?x ...'++The parser can't tell whether the ?x is the lhs of a normal binding or+an implicit binding.  Fortunately, resolving as shift gives it the only+sensible meaning, namely the lhs of an implicit binding.++-------------------------------------------------------------------------------++state 731 contains 1 shift/reduce conflicts.++        rule -> STRING rule_activation . rule_forall infixexp '=' exp++    Conflict: 'forall' (empty rule_forall reduces)++Example ambiguity: '{-# RULES "name" forall = ... #-}'++'forall' is a valid variable name---we don't know whether+to treat a forall on the input as the beginning of a quantifier+or the beginning of the rule itself.  Resolving to shift means+it's always treated as a quantifier, hence the above is disallowed.+This saves explicitly defining a grammar for the rule lhs that+doesn't include 'forall'.++-------------------------------------------------------------------------------++state 963 contains 1 shift/reduce conflicts.++        transformqual -> 'then' 'group' . 'using' exp+        transformqual -> 'then' 'group' . 'by' exp 'using' exp+    *** special_id -> 'group' .++    Conflict: 'by'++-------------------------------------------------------------------------------++state 1303 contains 1 shift/reduce conflict.++    *** atype -> tyvar .+        tv_bndr -> '(' tyvar . '::' kind ')'++    Conflict: '::'++TODO: Why?++-------------------------------------------------------------------------------+-- API Annotations+--++A lot of the productions are now cluttered with calls to+aa,am,ams,amms etc.++These are helper functions to make sure that the locations of the+various keywords such as do / let / in are captured for use by tools+that want to do source to source conversions, such as refactorers or+structured editors.++The helper functions are defined at the bottom of this file.++See+  https://ghc.haskell.org/trac/ghc/wiki/ApiAnnotations and+  https://ghc.haskell.org/trac/ghc/wiki/GhcAstAnnotations+for some background.++If you modify the parser and want to ensure that the API annotations are processed+correctly, see the README in (REPO)/utils/check-api-annotations for details on+how to set up a test using the check-api-annotations utility, and interpret the+output it generates.++Note [Parsing lists]+---------------------+You might be wondering why we spend so much effort encoding our lists this+way:++importdecls+        : importdecls ';' importdecl+        | importdecls ';'+        | importdecl+        | {- empty -}++This might seem like an awfully roundabout way to declare a list; plus, to add+insult to injury you have to reverse the results at the end.  The answer is that+left recursion prevents us from running out of stack space when parsing long+sequences.  See: https://www.haskell.org/happy/doc/html/sec-sequences.html for+more guidance.++By adding/removing branches, you can affect what lists are accepted.  Here+are the most common patterns, rewritten as regular expressions for clarity:++    -- Equivalent to: ';'* (x ';'+)* x?  (can be empty, permits leading/trailing semis)+    xs : xs ';' x+       | xs ';'+       | x+       | {- empty -}++    -- Equivalent to x (';' x)* ';'*  (non-empty, permits trailing semis)+    xs : xs ';' x+       | xs ';'+       | x++    -- Equivalent to ';'* alts (';' alts)* ';'* (non-empty, permits leading/trailing semis)+    alts : alts1+         | ';' alts+    alts1 : alts1 ';' alt+          | alts1 ';'+          | alt++    -- Equivalent to x (',' x)+ (non-empty, no trailing semis)+    xs : x+       | x ',' xs++-- -----------------------------------------------------------------------------++-}++%token+ '_'            { L _ ITunderscore }            -- Haskell keywords+ 'as'           { L _ ITas }+ 'case'         { L _ ITcase }+ 'class'        { L _ ITclass }+ 'data'         { L _ ITdata }+ 'default'      { L _ ITdefault }+ 'deriving'     { L _ ITderiving }+ 'do'           { L _ ITdo }+ 'else'         { L _ ITelse }+ 'hiding'       { L _ IThiding }+ 'if'           { L _ ITif }+ 'import'       { L _ ITimport }+ 'in'           { L _ ITin }+ 'infix'        { L _ ITinfix }+ 'infixl'       { L _ ITinfixl }+ 'infixr'       { L _ ITinfixr }+ 'instance'     { L _ ITinstance }+ 'let'          { L _ ITlet }+ 'module'       { L _ ITmodule }+ 'newtype'      { L _ ITnewtype }+ 'of'           { L _ ITof }+ 'qualified'    { L _ ITqualified }+ 'then'         { L _ ITthen }+ 'type'         { L _ ITtype }+ 'where'        { L _ ITwhere }++ 'forall'       { L _ (ITforall _) }                -- GHC extension keywords+ 'foreign'      { L _ ITforeign }+ 'export'       { L _ ITexport }+ 'label'        { L _ ITlabel }+ 'dynamic'      { L _ ITdynamic }+ 'safe'         { L _ ITsafe }+ 'interruptible' { L _ ITinterruptible }+ 'unsafe'       { L _ ITunsafe }+ 'mdo'          { L _ ITmdo }+ 'family'       { L _ ITfamily }+ 'role'         { L _ ITrole }+ 'stdcall'      { L _ ITstdcallconv }+ 'ccall'        { L _ ITccallconv }+ 'capi'         { L _ ITcapiconv }+ 'prim'         { L _ ITprimcallconv }+ 'javascript'   { L _ ITjavascriptcallconv }+ 'proc'         { L _ ITproc }          -- for arrow notation extension+ 'rec'          { L _ ITrec }           -- for arrow notation extension+ 'group'    { L _ ITgroup }     -- for list transform extension+ 'by'       { L _ ITby }        -- for list transform extension+ 'using'    { L _ ITusing }     -- for list transform extension+ 'pattern'      { L _ ITpattern } -- for pattern synonyms+ 'static'       { L _ ITstatic }  -- for static pointers extension+ 'stock'        { L _ ITstock }    -- for DerivingStrategies extension+ 'anyclass'     { L _ ITanyclass } -- for DerivingStrategies extension++ 'unit'         { L _ ITunit }+ 'signature'    { L _ ITsignature }+ 'dependency'   { L _ ITdependency }++ '{-# INLINE'             { L _ (ITinline_prag _ _ _) } -- INLINE or INLINABLE+ '{-# SPECIALISE'         { L _ (ITspec_prag _) }+ '{-# SPECIALISE_INLINE'  { L _ (ITspec_inline_prag _ _) }+ '{-# SOURCE'             { L _ (ITsource_prag _) }+ '{-# RULES'              { L _ (ITrules_prag _) }+ '{-# CORE'               { L _ (ITcore_prag _) }      -- hdaume: annotated core+ '{-# SCC'                { L _ (ITscc_prag _)}+ '{-# GENERATED'          { L _ (ITgenerated_prag _) }+ '{-# DEPRECATED'         { L _ (ITdeprecated_prag _) }+ '{-# WARNING'            { L _ (ITwarning_prag _) }+ '{-# UNPACK'             { L _ (ITunpack_prag _) }+ '{-# NOUNPACK'           { L _ (ITnounpack_prag _) }+ '{-# ANN'                { L _ (ITann_prag _) }+ '{-# VECTORISE'          { L _ (ITvect_prag _) }+ '{-# VECTORISE_SCALAR'   { L _ (ITvect_scalar_prag _) }+ '{-# NOVECTORISE'        { L _ (ITnovect_prag _) }+ '{-# MINIMAL'            { L _ (ITminimal_prag _) }+ '{-# CTYPE'              { L _ (ITctype _) }+ '{-# OVERLAPPING'        { L _ (IToverlapping_prag _) }+ '{-# OVERLAPPABLE'       { L _ (IToverlappable_prag _) }+ '{-# OVERLAPS'           { L _ (IToverlaps_prag _) }+ '{-# INCOHERENT'         { L _ (ITincoherent_prag _) }+ '{-# COMPLETE'           { L _ (ITcomplete_prag _)   }+ '#-}'                    { L _ ITclose_prag }++ '..'           { L _ ITdotdot }                        -- reserved symbols+ ':'            { L _ ITcolon }+ '::'           { L _ (ITdcolon _) }+ '='            { L _ ITequal }+ '\\'           { L _ ITlam }+ 'lcase'        { L _ ITlcase }+ '|'            { L _ ITvbar }+ '<-'           { L _ (ITlarrow _) }+ '->'           { L _ (ITrarrow _) }+ '@'            { L _ ITat }+ '~'            { L _ ITtilde }+ '~#'           { L _ ITtildehsh }+ '=>'           { L _ (ITdarrow _) }+ '-'            { L _ ITminus }+ '!'            { L _ ITbang }+ '-<'           { L _ (ITlarrowtail _) }            -- for arrow notation+ '>-'           { L _ (ITrarrowtail _) }            -- for arrow notation+ '-<<'          { L _ (ITLarrowtail _) }            -- for arrow notation+ '>>-'          { L _ (ITRarrowtail _) }            -- for arrow notation+ '.'            { L _ ITdot }+ TYPEAPP        { L _ ITtypeApp }++ '{'            { L _ ITocurly }                        -- special symbols+ '}'            { L _ ITccurly }+ vocurly        { L _ ITvocurly } -- virtual open curly (from layout)+ vccurly        { L _ ITvccurly } -- virtual close curly (from layout)+ '['            { L _ ITobrack }+ ']'            { L _ ITcbrack }+ '[:'           { L _ ITopabrack }+ ':]'           { L _ ITcpabrack }+ '('            { L _ IToparen }+ ')'            { L _ ITcparen }+ '(#'           { L _ IToubxparen }+ '#)'           { L _ ITcubxparen }+ '(|'           { L _ (IToparenbar _) }+ '|)'           { L _ (ITcparenbar _) }+ ';'            { L _ ITsemi }+ ','            { L _ ITcomma }+ '`'            { L _ ITbackquote }+ SIMPLEQUOTE    { L _ ITsimpleQuote      }     -- 'x++ VARID          { L _ (ITvarid    _) }          -- identifiers+ CONID          { L _ (ITconid    _) }+ VARSYM         { L _ (ITvarsym   _) }+ CONSYM         { L _ (ITconsym   _) }+ QVARID         { L _ (ITqvarid   _) }+ QCONID         { L _ (ITqconid   _) }+ QVARSYM        { L _ (ITqvarsym  _) }+ QCONSYM        { L _ (ITqconsym  _) }++ IPDUPVARID     { L _ (ITdupipvarid   _) }              -- GHC extension+ LABELVARID     { L _ (ITlabelvarid   _) }++ CHAR           { L _ (ITchar   _ _) }+ STRING         { L _ (ITstring _ _) }+ INTEGER        { L _ (ITinteger _ _) }+ RATIONAL       { L _ (ITrational _) }++ PRIMCHAR       { L _ (ITprimchar   _ _) }+ PRIMSTRING     { L _ (ITprimstring _ _) }+ PRIMINTEGER    { L _ (ITprimint    _ _) }+ PRIMWORD       { L _ (ITprimword   _ _) }+ PRIMFLOAT      { L _ (ITprimfloat  _) }+ PRIMDOUBLE     { L _ (ITprimdouble _) }++ DOCNEXT        { L _ (ITdocCommentNext _) }+ DOCPREV        { L _ (ITdocCommentPrev _) }+ DOCNAMED       { L _ (ITdocCommentNamed _) }+ DOCSECTION     { L _ (ITdocSection _ _) }++-- Template Haskell+'[|'            { L _ (ITopenExpQuote _ _) }+'[p|'           { L _ ITopenPatQuote  }+'[t|'           { L _ ITopenTypQuote  }+'[d|'           { L _ ITopenDecQuote  }+'|]'            { L _ (ITcloseQuote _) }+'[||'           { L _ (ITopenTExpQuote _) }+'||]'           { L _ ITcloseTExpQuote  }+TH_ID_SPLICE    { L _ (ITidEscape _)  }     -- $x+'$('            { L _ ITparenEscape   }     -- $( exp )+TH_ID_TY_SPLICE { L _ (ITidTyEscape _)  }   -- $$x+'$$('           { L _ ITparenTyEscape   }   -- $$( exp )+TH_TY_QUOTE     { L _ ITtyQuote       }      -- ''T+TH_QUASIQUOTE   { L _ (ITquasiQuote _) }+TH_QQUASIQUOTE  { L _ (ITqQuasiQuote _) }++%monad { P } { >>= } { return }+%lexer { (lexer True) } { L _ ITeof }+%tokentype { (Located Token) }++-- Exported parsers+%name parseModule module+%name parseSignature signature+%name parseImport importdecl+%name parseStatement stmt+%name parseDeclaration topdecl+%name parseExpression exp+%name parsePattern pat+%name parseTypeSignature sigdecl+%name parseStmt   maybe_stmt+%name parseIdentifier  identifier+%name parseType ctype+%name parseBackpack backpack+%partial parseHeader header+%%++-----------------------------------------------------------------------------+-- Identifiers; one of the entry points+identifier :: { Located RdrName }+        : qvar                          { $1 }+        | qcon                          { $1 }+        | qvarop                        { $1 }+        | qconop                        { $1 }+    | '(' '->' ')'      {% ams (sLL $1 $> $ getRdrName funTyCon)+                               [mj AnnOpenP $1,mu AnnRarrow $2,mj AnnCloseP $3] }++-----------------------------------------------------------------------------+-- Backpack stuff++backpack :: { [LHsUnit PackageName] }+         : implicit_top units close { fromOL $2 }+         | '{' units '}'            { fromOL $2 }++units :: { OrdList (LHsUnit PackageName) }+         : units ';' unit { $1 `appOL` unitOL $3 }+         | units ';'      { $1 }+         | unit           { unitOL $1 }++unit :: { LHsUnit PackageName }+        : 'unit' pkgname 'where' unitbody+            { sL1 $1 $ HsUnit { hsunitName = $2+                              , hsunitBody = fromOL $4 } }++unitid :: { LHsUnitId PackageName }+        : pkgname                  { sL1 $1 $ HsUnitId $1 [] }+        | pkgname '[' msubsts ']'  { sLL $1 $> $ HsUnitId $1 (fromOL $3) }++msubsts :: { OrdList (LHsModuleSubst PackageName) }+        : msubsts ',' msubst { $1 `appOL` unitOL $3 }+        | msubsts ','        { $1 }+        | msubst             { unitOL $1 }++msubst :: { LHsModuleSubst PackageName }+        : modid '=' moduleid { sLL $1 $> $ ($1, $3) }+        | modid VARSYM modid VARSYM { sLL $1 $> $ ($1, sLL $2 $> $ HsModuleVar $3) }++moduleid :: { LHsModuleId PackageName }+          : VARSYM modid VARSYM { sLL $1 $> $ HsModuleVar $2 }+          | unitid ':' modid    { sLL $1 $> $ HsModuleId $1 $3 }++pkgname :: { Located PackageName }+        : STRING     { sL1 $1 $ PackageName (getSTRING $1) }+        | litpkgname { sL1 $1 $ PackageName (unLoc $1) }++litpkgname_segment :: { Located FastString }+        : VARID  { sL1 $1 $ getVARID $1 }+        | CONID  { sL1 $1 $ getCONID $1 }+        | special_id { $1 }++litpkgname :: { Located FastString }+        : litpkgname_segment { $1 }+        -- a bit of a hack, means p - b is parsed same as p-b, enough for now.+        | litpkgname_segment '-' litpkgname  { sLL $1 $> $ appendFS (unLoc $1) (consFS '-' (unLoc $3)) }++mayberns :: { Maybe [LRenaming] }+        : {- empty -} { Nothing }+        | '(' rns ')' { Just (fromOL $2) }++rns :: { OrdList LRenaming }+        : rns ',' rn { $1 `appOL` unitOL $3 }+        | rns ','    { $1 }+        | rn         { unitOL $1 }++rn :: { LRenaming }+        : modid 'as' modid { sLL $1 $> $ Renaming $1 (Just $3) }+        | modid            { sL1 $1    $ Renaming $1 Nothing }++unitbody :: { OrdList (LHsUnitDecl PackageName) }+        : '{'     unitdecls '}'   { $2 }+        | vocurly unitdecls close { $2 }++unitdecls :: { OrdList (LHsUnitDecl PackageName) }+        : unitdecls ';' unitdecl { $1 `appOL` unitOL $3 }+        | unitdecls ';'         { $1 }+        | unitdecl              { unitOL $1 }++unitdecl :: { LHsUnitDecl PackageName }+        : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body+             -- XXX not accurate+             { sL1 $2 $ DeclD ModuleD $3 (Just (sL1 $2 (HsModule (Just $3) $5 (fst $ snd $7) (snd $ snd $7) $4 $1))) }+        | maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body+             { sL1 $2 $ DeclD SignatureD $3 (Just (sL1 $2 (HsModule (Just $3) $5 (fst $ snd $7) (snd $ snd $7) $4 $1))) }+        -- NB: MUST have maybedocheader here, otherwise shift-reduce conflict+        -- will prevent us from parsing both forms.+        | maybedocheader 'module' modid+             { sL1 $2 $ DeclD ModuleD $3 Nothing }+        | maybedocheader 'signature' modid+             { sL1 $2 $ DeclD SignatureD $3 Nothing }+        | 'dependency' unitid mayberns+             { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $2+                                              , idModRenaming = $3+                                              , idSignatureInclude = False }) }+        | 'dependency' 'signature' unitid+             { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $3+                                              , idModRenaming = Nothing+                                              , idSignatureInclude = True }) }++-----------------------------------------------------------------------------+-- Module Header++-- The place for module deprecation is really too restrictive, but if it+-- was allowed at its natural place just before 'module', we get an ugly+-- s/r conflict with the second alternative. Another solution would be the+-- introduction of a new pragma DEPRECATED_MODULE, but this is not very nice,+-- either, and DEPRECATED is only expected to be used by people who really+-- know what they are doing. :-)++signature :: { Located (HsModule RdrName) }+       : maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body+             {% fileSrcSpan >>= \ loc ->+                ams (L loc (HsModule (Just $3) $5 (fst $ snd $7)+                              (snd $ snd $7) $4 $1)+                    )+                    ([mj AnnSignature $2, mj AnnWhere $6] ++ fst $7) }++module :: { Located (HsModule RdrName) }+       : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body+             {% fileSrcSpan >>= \ loc ->+                ams (L loc (HsModule (Just $3) $5 (fst $ snd $7)+                              (snd $ snd $7) $4 $1)+                    )+                    ([mj AnnModule $2, mj AnnWhere $6] ++ fst $7) }+        | body2+                {% fileSrcSpan >>= \ loc ->+                   ams (L loc (HsModule Nothing Nothing+                               (fst $ snd $1) (snd $ snd $1) Nothing Nothing))+                       (fst $1) }++maybedocheader :: { Maybe LHsDocString }+        : moduleheader            { $1 }+        | {- empty -}             { Nothing }++missing_module_keyword :: { () }+        : {- empty -}                           {% pushModuleContext }++implicit_top :: { () }+        : {- empty -}                           {% pushModuleContext }++maybemodwarning :: { Maybe (Located WarningTxt) }+    : '{-# DEPRECATED' strings '#-}'+                      {% ajs (Just (sLL $1 $> $ DeprecatedTxt (sL1 $1 (getDEPRECATED_PRAGs $1)) (snd $ unLoc $2)))+                             (mo $1:mc $3: (fst $ unLoc $2)) }+    | '{-# WARNING' strings '#-}'+                         {% ajs (Just (sLL $1 $> $ WarningTxt (sL1 $1 (getWARNING_PRAGs $1)) (snd $ unLoc $2)))+                                (mo $1:mc $3 : (fst $ unLoc $2)) }+    |  {- empty -}                  { Nothing }++body    :: { ([AddAnn]+             ,([LImportDecl RdrName], [LHsDecl RdrName])) }+        :  '{'            top '}'      { (moc $1:mcc $3:(fst $2)+                                         , snd $2) }+        |      vocurly    top close    { (fst $2, snd $2) }++body2   :: { ([AddAnn]+             ,([LImportDecl RdrName], [LHsDecl RdrName])) }+        :  '{' top '}'                          { (moc $1:mcc $3+                                                   :(fst $2), snd $2) }+        |  missing_module_keyword top close     { ([],snd $2) }+++top     :: { ([AddAnn]+             ,([LImportDecl RdrName], [LHsDecl RdrName])) }+        : semis top1                            { ($1, $2) }++top1    :: { ([LImportDecl RdrName], [LHsDecl RdrName]) }+        : importdecls_semi topdecls_semi        { (reverse $1, cvTopDecls $2) }+        | importdecls_semi topdecls             { (reverse $1, cvTopDecls $2) }+        | importdecls                           { (reverse $1, []) }++-----------------------------------------------------------------------------+-- Module declaration & imports only++header  :: { Located (HsModule RdrName) }+        : maybedocheader 'module' modid maybemodwarning maybeexports 'where' header_body+                {% fileSrcSpan >>= \ loc ->+                   ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1+                          )) [mj AnnModule $2,mj AnnWhere $6] }+        | maybedocheader 'signature' modid maybemodwarning maybeexports 'where' header_body+                {% fileSrcSpan >>= \ loc ->+                   ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1+                          )) [mj AnnModule $2,mj AnnWhere $6] }+        | header_body2+                {% fileSrcSpan >>= \ loc ->+                   return (L loc (HsModule Nothing Nothing $1 [] Nothing+                          Nothing)) }++header_body :: { [LImportDecl RdrName] }+        :  '{'            header_top            { $2 }+        |      vocurly    header_top            { $2 }++header_body2 :: { [LImportDecl RdrName] }+        :  '{' header_top                       { $2 }+        |  missing_module_keyword header_top    { $2 }++header_top :: { [LImportDecl RdrName] }+        :  semis header_top_importdecls         { $2 }++header_top_importdecls :: { [LImportDecl RdrName] }+        :  importdecls_semi                     { $1 }+        |  importdecls                          { $1 }++-----------------------------------------------------------------------------+-- The Export List++maybeexports :: { (Maybe (Located [LIE RdrName])) }+        :  '(' exportlist ')'       {% ams (sLL $1 $> ()) [mop $1,mcp $3] >>+                                       return (Just (sLL $1 $> (fromOL $2))) }+        |  {- empty -}              { Nothing }++exportlist :: { OrdList (LIE RdrName) }+        : expdoclist ',' expdoclist   {% addAnnotation (oll $1) AnnComma (gl $2)+                                         >> return ($1 `appOL` $3) }+        | exportlist1                 { $1 }++exportlist1 :: { OrdList (LIE RdrName) }+        : expdoclist export expdoclist ',' exportlist1+                          {% (addAnnotation (oll ($1 `appOL` $2 `appOL` $3))+                                            AnnComma (gl $4) ) >>+                              return ($1 `appOL` $2 `appOL` $3 `appOL` $5) }+        | expdoclist export expdoclist             { $1 `appOL` $2 `appOL` $3 }+        | expdoclist                               { $1 }++expdoclist :: { OrdList (LIE RdrName) }+        : exp_doc expdoclist                           { $1 `appOL` $2 }+        | {- empty -}                                  { nilOL }++exp_doc :: { OrdList (LIE RdrName) }+        : docsection    { unitOL (sL1 $1 (case (unLoc $1) of (n, doc) -> IEGroup n doc)) }+        | docnamed      { unitOL (sL1 $1 (IEDocNamed ((fst . unLoc) $1))) }+        | docnext       { unitOL (sL1 $1 (IEDoc (unLoc $1))) }+++   -- No longer allow things like [] and (,,,) to be exported+   -- They are built in syntax, always available+export  :: { OrdList (LIE RdrName) }+        : qcname_ext export_subspec  {% mkModuleImpExp $1 (snd $ unLoc $2)+                                          >>= \ie -> amsu (sLL $1 $> ie) (fst $ unLoc $2) }+        |  'module' modid            {% amsu (sLL $1 $> (IEModuleContents $2))+                                             [mj AnnModule $1] }+        |  'pattern' qcon            {% amsu (sLL $1 $> (IEVar (sLL $1 $> (IEPattern $2))))+                                             [mj AnnPattern $1] }++export_subspec :: { Located ([AddAnn],ImpExpSubSpec) }+        : {- empty -}             { sL0 ([],ImpExpAbs) }+        | '(' qcnames ')'         {% mkImpExpSubSpec (reverse (snd $2))+                                      >>= \(as,ie) -> return $ sLL $1 $>+                                            (as ++ [mop $1,mcp $3] ++ fst $2, ie) }+++qcnames :: { ([AddAnn], [Located ImpExpQcSpec]) }+  : {- empty -}                   { ([],[]) }+  | qcnames1                      { $1 }++qcnames1 :: { ([AddAnn], [Located ImpExpQcSpec]) }     -- A reversed list+        :  qcnames1 ',' qcname_ext_w_wildcard  {% case (head (snd $1)) of+                                                    l@(L _ ImpExpQcWildcard) ->+                                                       return ([mj AnnComma $2, mj AnnDotdot l]+                                                               ,(snd (unLoc $3)  : snd $1))+                                                    l -> (ams (head (snd $1)) [mj AnnComma $2] >>+                                                          return (fst $1 ++ fst (unLoc $3),+                                                                  snd (unLoc $3) : snd $1)) }+++        -- Annotations re-added in mkImpExpSubSpec+        |  qcname_ext_w_wildcard                   { (fst (unLoc $1),[snd (unLoc $1)]) }++-- Variable, data constructor or wildcard+-- or tagged type constructor+qcname_ext_w_wildcard :: { Located ([AddAnn], Located ImpExpQcSpec) }+        :  qcname_ext               { sL1 $1 ([],$1) }+        |  '..'                     { sL1 $1 ([mj AnnDotdot $1], sL1 $1 ImpExpQcWildcard)  }++qcname_ext :: { Located ImpExpQcSpec }+        :  qcname                   { sL1 $1 (ImpExpQcName $1) }+        |  'type' oqtycon           {% do { n <- mkTypeImpExp $2+                                          ; ams (sLL $1 $> (ImpExpQcType n))+                                                [mj AnnType $1] } }++qcname  :: { Located RdrName }  -- Variable or type constructor+        :  qvar                 { $1 } -- Things which look like functions+                                       -- Note: This includes record selectors but+                                       -- also (-.->), see #11432+        |  oqtycon_no_varcon    { $1 } -- see Note [Type constructors in export list]++-----------------------------------------------------------------------------+-- Import Declarations++-- importdecls and topdecls must contain at least one declaration;+-- top handles the fact that these may be optional.++-- One or more semicolons+semis1  :: { [AddAnn] }+semis1  : semis1 ';'  { mj AnnSemi $2 : $1 }+        | ';'         { [mj AnnSemi $1] }++-- Zero or more semicolons+semis   :: { [AddAnn] }+semis   : semis ';'   { mj AnnSemi $2 : $1 }+        | {- empty -} { [] }++-- No trailing semicolons, non-empty+importdecls :: { [LImportDecl RdrName] }+importdecls+        : importdecls_semi importdecl+                                { $2 : $1 }++-- May have trailing semicolons, can be empty+importdecls_semi :: { [LImportDecl RdrName] }+importdecls_semi+        : importdecls_semi importdecl semis1+                                {% ams $2 $3 >> return ($2 : $1) }+        | {- empty -}           { [] }++importdecl :: { LImportDecl RdrName }+        : 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec+                {% ams (L (comb4 $1 $6 (snd $7) $8) $+                  ImportDecl { ideclSourceSrc = snd $ fst $2+                             , ideclName = $6, ideclPkgQual = snd $5+                             , ideclSource = snd $2, ideclSafe = snd $3+                             , ideclQualified = snd $4, ideclImplicit = False+                             , ideclAs = unLoc (snd $7)+                             , ideclHiding = unLoc $8 })+                   ((mj AnnImport $1 : (fst $ fst $2) ++ fst $3 ++ fst $4+                                    ++ fst $5 ++ fst $7)) }++maybe_src :: { (([AddAnn],SourceText),IsBootInterface) }+        : '{-# SOURCE' '#-}'        { (([mo $1,mc $2],getSOURCE_PRAGs $1)+                                      ,True) }+        | {- empty -}               { (([],NoSourceText),False) }++maybe_safe :: { ([AddAnn],Bool) }+        : 'safe'                                { ([mj AnnSafe $1],True) }+        | {- empty -}                           { ([],False) }++maybe_pkg :: { ([AddAnn],Maybe StringLiteral) }+        : STRING  {% let pkgFS = getSTRING $1 in+                     if looksLikePackageName (unpackFS pkgFS)+                        then return ([mj AnnPackageName $1], Just (StringLiteral (getSTRINGs $1) pkgFS))+                        else parseErrorSDoc (getLoc $1) $ vcat [+                             text "parse error" <> colon <+> quotes (ppr pkgFS),+                             text "Version number or non-alphanumeric" <+>+                             text "character in package name"] }+        | {- empty -}                           { ([],Nothing) }++optqualified :: { ([AddAnn],Bool) }+        : 'qualified'                           { ([mj AnnQualified $1],True)  }+        | {- empty -}                           { ([],False) }++maybeas :: { ([AddAnn],Located (Maybe (Located ModuleName))) }+        : 'as' modid                           { ([mj AnnAs $1]+                                                 ,sLL $1 $> (Just $2)) }+        | {- empty -}                          { ([],noLoc Nothing) }++maybeimpspec :: { Located (Maybe (Bool, Located [LIE RdrName])) }+        : impspec                  {% let (b, ie) = unLoc $1 in+                                       checkImportSpec ie+                                        >>= \checkedIe ->+                                          return (L (gl $1) (Just (b, checkedIe)))  }+        | {- empty -}              { noLoc Nothing }++impspec :: { Located (Bool, Located [LIE RdrName]) }+        :  '(' exportlist ')'               {% ams (sLL $1 $> (False,+                                                      sLL $1 $> $ fromOL $2))+                                                   [mop $1,mcp $3] }+        |  'hiding' '(' exportlist ')'      {% ams (sLL $1 $> (True,+                                                      sLL $1 $> $ fromOL $3))+                                               [mj AnnHiding $1,mop $2,mcp $4] }++-----------------------------------------------------------------------------+-- Fixity Declarations++prec    :: { Located (SourceText,Int) }+        : {- empty -}           { noLoc (NoSourceText,9) }+        | INTEGER+                 {% checkPrecP (sL1 $1 (getINTEGERs $1,fromInteger (getINTEGER $1))) }++infix   :: { Located FixityDirection }+        : 'infix'                               { sL1 $1 InfixN  }+        | 'infixl'                              { sL1 $1 InfixL  }+        | 'infixr'                              { sL1 $1 InfixR }++ops     :: { Located (OrdList (Located RdrName)) }+        : ops ',' op       {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >>+                              return (sLL $1 $> ((unLoc $1) `appOL` unitOL $3))}+        | op               { sL1 $1 (unitOL $1) }++-----------------------------------------------------------------------------+-- Top-Level Declarations++-- No trailing semicolons, non-empty+topdecls :: { OrdList (LHsDecl RdrName) }+        : topdecls_semi topdecl        { $1 `snocOL` $2 }++-- May have trailing semicolons, can be empty+topdecls_semi :: { OrdList (LHsDecl RdrName) }+        : topdecls_semi topdecl semis1 {% ams $2 $3 >> return ($1 `snocOL` $2) }+        | {- empty -}                  { nilOL }++topdecl :: { LHsDecl RdrName }+        : cl_decl                               { sL1 $1 (TyClD (unLoc $1)) }+        | ty_decl                               { sL1 $1 (TyClD (unLoc $1)) }+        | inst_decl                             { sL1 $1 (InstD (unLoc $1)) }+        | stand_alone_deriving                  { sLL $1 $> (DerivD (unLoc $1)) }+        | role_annot                            { sL1 $1 (RoleAnnotD (unLoc $1)) }+        | 'default' '(' comma_types0 ')'    {% ams (sLL $1 $> (DefD (DefaultDecl $3)))+                                                         [mj AnnDefault $1+                                                         ,mop $2,mcp $4] }+        | 'foreign' fdecl          {% ams (sLL $1 $> (snd $ unLoc $2))+                                           (mj AnnForeign $1:(fst $ unLoc $2)) }+        | '{-# DEPRECATED' deprecations '#-}'   {% ams (sLL $1 $> $ WarningD (Warnings (getDEPRECATED_PRAGs $1) (fromOL $2)))+                                                       [mo $1,mc $3] }+        | '{-# WARNING' warnings '#-}'          {% ams (sLL $1 $> $ WarningD (Warnings (getWARNING_PRAGs $1) (fromOL $2)))+                                                       [mo $1,mc $3] }+        | '{-# RULES' rules '#-}'               {% ams (sLL $1 $> $ RuleD (HsRules (getRULES_PRAGs $1) (fromOL $2)))+                                                       [mo $1,mc $3] }+        | '{-# VECTORISE' qvar '=' exp '#-}' {% ams (sLL $1 $> $ VectD (HsVect (getVECT_PRAGs $1) $2 $4))+                                                    [mo $1,mj AnnEqual $3+                                                    ,mc $5] }+        | '{-# NOVECTORISE' qvar '#-}'       {% ams (sLL $1 $> $ VectD (HsNoVect (getNOVECT_PRAGs $1) $2))+                                                     [mo $1,mc $3] }+        | '{-# VECTORISE' 'type' gtycon '#-}'+                                {% ams (sLL $1 $> $+                                    VectD (HsVectTypeIn (getVECT_PRAGs $1) False $3 Nothing))+                                    [mo $1,mj AnnType $2,mc $4] }++        | '{-# VECTORISE_SCALAR' 'type' gtycon '#-}'+                                {% ams (sLL $1 $> $+                                    VectD (HsVectTypeIn (getVECT_SCALAR_PRAGs $1) True $3 Nothing))+                                    [mo $1,mj AnnType $2,mc $4] }++        | '{-# VECTORISE' 'type' gtycon '=' gtycon '#-}'+                                {% ams (sLL $1 $> $+                                    VectD (HsVectTypeIn (getVECT_PRAGs $1) False $3 (Just $5)))+                                    [mo $1,mj AnnType $2,mj AnnEqual $4,mc $6] }+        | '{-# VECTORISE_SCALAR' 'type' gtycon '=' gtycon '#-}'+                                {% ams (sLL $1 $> $+                                    VectD (HsVectTypeIn (getVECT_SCALAR_PRAGs $1) True $3 (Just $5)))+                                    [mo $1,mj AnnType $2,mj AnnEqual $4,mc $6] }++        | '{-# VECTORISE' 'class' gtycon '#-}'+                                         {% ams (sLL $1 $>  $ VectD (HsVectClassIn (getVECT_PRAGs $1) $3))+                                                 [mo $1,mj AnnClass $2,mc $4] }+        | annotation { $1 }+        | decl_no_th                            { $1 }++        -- Template Haskell Extension+        -- The $(..) form is one possible form of infixexp+        -- but we treat an arbitrary expression just as if+        -- it had a $(..) wrapped around it+        | infixexp_top                          { sLL $1 $> $ mkSpliceDecl $1 }++-- Type classes+--+cl_decl :: { LTyClDecl RdrName }+        : 'class' tycl_hdr fds where_cls+                {% amms (mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (snd $ unLoc $4))+                        (mj AnnClass $1:(fst $ unLoc $3)++(fst $ unLoc $4)) }++-- Type declarations (toplevel)+--+ty_decl :: { LTyClDecl RdrName }+           -- ordinary type synonyms+        : 'type' type '=' ctypedoc+                -- Note ctype, not sigtype, on the right of '='+                -- We allow an explicit for-all but we don't insert one+                -- in   type Foo a = (b,b)+                -- Instead we just say b is out of scope+                --+                -- Note the use of type for the head; this allows+                -- infix type constructors to be declared+                {% amms (mkTySynonym (comb2 $1 $4) $2 $4)+                        [mj AnnType $1,mj AnnEqual $3] }++           -- type family declarations+        | 'type' 'family' type opt_tyfam_kind_sig opt_injective_info+                          where_type_family+                -- Note the use of type for the head; this allows+                -- infix type constructors to be declared+                {% amms (mkFamDecl (comb4 $1 $3 $4 $5) (snd $ unLoc $6) $3+                                   (snd $ unLoc $4) (snd $ unLoc $5))+                        (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)+                           ++ (fst $ unLoc $5) ++ (fst $ unLoc $6)) }++          -- ordinary data type or newtype declaration+        | data_or_newtype capi_ctype tycl_hdr constrs maybe_derivings+                {% amms (mkTyData (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3+                           Nothing (reverse (snd $ unLoc $4))+                                   (fmap reverse $5))+                                   -- We need the location on tycl_hdr in case+                                   -- constrs and deriving are both empty+                        ((fst $ unLoc $1):(fst $ unLoc $4)) }++          -- ordinary GADT declaration+        | data_or_newtype capi_ctype tycl_hdr opt_kind_sig+                 gadt_constrlist+                 maybe_derivings+            {% amms (mkTyData (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2 $3+                            (snd $ unLoc $4) (snd $ unLoc $5)+                            (fmap reverse $6) )+                                   -- We need the location on tycl_hdr in case+                                   -- constrs and deriving are both empty+                    ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) }++          -- data/newtype family+        | 'data' 'family' type opt_datafam_kind_sig+                {% amms (mkFamDecl (comb3 $1 $2 $4) DataFamily $3+                                   (snd $ unLoc $4) Nothing)+                        (mj AnnData $1:mj AnnFamily $2:(fst $ unLoc $4)) }++inst_decl :: { LInstDecl RdrName }+        : 'instance' overlap_pragma inst_type where_inst+       {% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $4)+             ; let cid = ClsInstDecl { cid_poly_ty = $3, cid_binds = binds+                                     , cid_sigs = mkClassOpSigs sigs+                                     , cid_tyfam_insts = ats+                                     , cid_overlap_mode = $2+                                     , cid_datafam_insts = adts }+             ; ams (L (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_inst = cid }))+                   (mj AnnInstance $1 : (fst $ unLoc $4)) } }++           -- type instance declarations+        | 'type' 'instance' ty_fam_inst_eqn+                {% ams $3 (fst $ unLoc $3)+                >> amms (mkTyFamInst (comb2 $1 $3) (snd $ unLoc $3))+                    (mj AnnType $1:mj AnnInstance $2:(fst $ unLoc $3)) }++          -- data/newtype instance declaration+        | data_or_newtype 'instance' capi_ctype tycl_hdr constrs+                          maybe_derivings+            {% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 $4+                                      Nothing (reverse (snd  $ unLoc $5))+                                              (fmap reverse $6))+                    ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $5)) }++          -- GADT instance declaration+        | data_or_newtype 'instance' capi_ctype tycl_hdr opt_kind_sig+                 gadt_constrlist+                 maybe_derivings+            {% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 $4+                                   (snd $ unLoc $5) (snd $ unLoc $6)+                                   (fmap reverse $7))+                    ((fst $ unLoc $1):mj AnnInstance $2+                       :(fst $ unLoc $5)++(fst $ unLoc $6)) }++overlap_pragma :: { Maybe (Located OverlapMode) }+  : '{-# OVERLAPPABLE'    '#-}' {% ajs (Just (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1))))+                                       [mo $1,mc $2] }+  | '{-# OVERLAPPING'     '#-}' {% ajs (Just (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1))))+                                       [mo $1,mc $2] }+  | '{-# OVERLAPS'        '#-}' {% ajs (Just (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1))))+                                       [mo $1,mc $2] }+  | '{-# INCOHERENT'      '#-}' {% ajs (Just (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1))))+                                       [mo $1,mc $2] }+  | {- empty -}                 { Nothing }++deriv_strategy :: { Maybe (Located DerivStrategy) }+  : 'stock'                     {% ajs (Just (sL1 $1 StockStrategy))+                                       [mj AnnStock $1] }+  | 'anyclass'                  {% ajs (Just (sL1 $1 AnyclassStrategy))+                                       [mj AnnAnyclass $1] }+  | 'newtype'                   {% ajs (Just (sL1 $1 NewtypeStrategy))+                                       [mj AnnNewtype $1] }+  | {- empty -}                 { Nothing }++-- Injective type families++opt_injective_info :: { Located ([AddAnn], Maybe (LInjectivityAnn RdrName)) }+        : {- empty -}               { noLoc ([], Nothing) }+        | '|' injectivity_cond      { sLL $1 $> ([mj AnnVbar $1]+                                                , Just ($2)) }++injectivity_cond :: { LInjectivityAnn RdrName }+        : tyvarid '->' inj_varids+           {% ams (sLL $1 $> (InjectivityAnn $1 (reverse (unLoc $3))))+                  [mu AnnRarrow $2] }++inj_varids :: { Located [Located RdrName] }+        : inj_varids tyvarid  { sLL $1 $> ($2 : unLoc $1) }+        | tyvarid             { sLL $1 $> [$1]            }++-- Closed type families++where_type_family :: { Located ([AddAnn],FamilyInfo RdrName) }+        : {- empty -}                      { noLoc ([],OpenTypeFamily) }+        | 'where' ty_fam_inst_eqn_list+               { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2)+                    ,ClosedTypeFamily (fmap reverse $ snd $ unLoc $2)) }++ty_fam_inst_eqn_list :: { Located ([AddAnn],Maybe [LTyFamInstEqn RdrName]) }+        :     '{' ty_fam_inst_eqns '}'     { sLL $1 $> ([moc $1,mcc $3]+                                                ,Just (unLoc $2)) }+        | vocurly ty_fam_inst_eqns close   { let L loc _ = $2 in+                                             L loc ([],Just (unLoc $2)) }+        |     '{' '..' '}'                 { sLL $1 $> ([moc $1,mj AnnDotdot $2+                                                 ,mcc $3],Nothing) }+        | vocurly '..' close               { let L loc _ = $2 in+                                             L loc ([mj AnnDotdot $2],Nothing) }++ty_fam_inst_eqns :: { Located [LTyFamInstEqn RdrName] }+        : ty_fam_inst_eqns ';' ty_fam_inst_eqn+                                      {% asl (unLoc $1) $2 (snd $ unLoc $3)+                                         >> ams $3 (fst $ unLoc $3)+                                         >> return (sLL $1 $> ((snd $ unLoc $3) : unLoc $1)) }+        | ty_fam_inst_eqns ';'        {% addAnnotation (gl $1) AnnSemi (gl $2)+                                         >> return (sLL $1 $>  (unLoc $1)) }+        | ty_fam_inst_eqn             {% ams $1 (fst $ unLoc $1)+                                         >> return (sLL $1 $> [snd $ unLoc $1]) }+        | {- empty -}                 { noLoc [] }++ty_fam_inst_eqn :: { Located ([AddAnn],LTyFamInstEqn RdrName) }+        : type '=' ctype+                -- Note the use of type for the head; this allows+                -- infix type constructors and type patterns+              {% do { (eqn,ann) <- mkTyFamInstEqn $1 $3+                    ; return (sLL $1 $> (mj AnnEqual $2:ann, sLL $1 $> eqn))  } }++-- Associated type family declarations+--+-- * They have a different syntax than on the toplevel (no family special+--   identifier).+--+-- * They also need to be separate from instances; otherwise, data family+--   declarations without a kind signature cause parsing conflicts with empty+--   data declarations.+--+at_decl_cls :: { LHsDecl RdrName }+        :  -- data family declarations, with optional 'family' keyword+          'data' opt_family type opt_datafam_kind_sig+                {% amms (liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4) DataFamily $3+                                                  (snd $ unLoc $4) Nothing))+                        (mj AnnData $1:$2++(fst $ unLoc $4)) }++           -- type family declarations, with optional 'family' keyword+           -- (can't use opt_instance because you get shift/reduce errors+        | 'type' type opt_at_kind_inj_sig+               {% amms (liftM mkTyClD+                        (mkFamDecl (comb3 $1 $2 $3) OpenTypeFamily $2+                                   (fst . snd $ unLoc $3)+                                   (snd . snd $ unLoc $3)))+                       (mj AnnType $1:(fst $ unLoc $3)) }+        | 'type' 'family' type opt_at_kind_inj_sig+               {% amms (liftM mkTyClD+                        (mkFamDecl (comb3 $1 $3 $4) OpenTypeFamily $3+                                   (fst . snd $ unLoc $4)+                                   (snd . snd $ unLoc $4)))+                       (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)) }++           -- default type instances, with optional 'instance' keyword+        | 'type' ty_fam_inst_eqn+                {% ams $2 (fst $ unLoc $2) >>+                   amms (liftM mkInstD (mkTyFamInst (comb2 $1 $2) (snd $ unLoc $2)))+                        (mj AnnType $1:(fst $ unLoc $2)) }+        | 'type' 'instance' ty_fam_inst_eqn+                {% ams $3 (fst $ unLoc $3) >>+                   amms (liftM mkInstD (mkTyFamInst (comb2 $1 $3) (snd $ unLoc $3)))+                        (mj AnnType $1:mj AnnInstance $2:(fst $ unLoc $3)) }++opt_family   :: { [AddAnn] }+              : {- empty -}   { [] }+              | 'family'      { [mj AnnFamily $1] }++-- Associated type instances+--+at_decl_inst :: { LInstDecl RdrName }+           -- type instance declarations+        : 'type' ty_fam_inst_eqn+                -- Note the use of type for the head; this allows+                -- infix type constructors and type patterns+                {% ams $2 (fst $ unLoc $2) >>+                   amms (mkTyFamInst (comb2 $1 $2) (snd $ unLoc $2))+                        (mj AnnType $1:(fst $ unLoc $2)) }++        -- data/newtype instance declaration+        | data_or_newtype capi_ctype tycl_hdr constrs maybe_derivings+               {% amms (mkDataFamInst (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3+                                    Nothing (reverse (snd $ unLoc $4))+                                            (fmap reverse $5))+                       ((fst $ unLoc $1):(fst $ unLoc $4)) }++        -- GADT instance declaration+        | data_or_newtype capi_ctype tycl_hdr opt_kind_sig+                 gadt_constrlist+                 maybe_derivings+                {% amms (mkDataFamInst (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2+                                $3 (snd $ unLoc $4) (snd $ unLoc $5)+                                (fmap reverse $6))+                        ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) }++data_or_newtype :: { Located (AddAnn, NewOrData) }+        : 'data'        { sL1 $1 (mj AnnData    $1,DataType) }+        | 'newtype'     { sL1 $1 (mj AnnNewtype $1,NewType) }++-- Family result/return kind signatures++opt_kind_sig :: { Located ([AddAnn], Maybe (LHsKind RdrName)) }+        :               { noLoc     ([]               , Nothing) }+        | '::' kind     { sLL $1 $> ([mu AnnDcolon $1], Just $2) }++opt_datafam_kind_sig :: { Located ([AddAnn], LFamilyResultSig RdrName) }+        :               { noLoc     ([]               , noLoc NoSig           )}+        | '::' kind     { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig $2))}++opt_tyfam_kind_sig :: { Located ([AddAnn], LFamilyResultSig RdrName) }+        :              { noLoc     ([]               , noLoc      NoSig       )}+        | '::' kind    { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig  $2))}+        | '='  tv_bndr { sLL $1 $> ([mj AnnEqual $1] , sLL $1 $> (TyVarSig $2))}++opt_at_kind_inj_sig :: { Located ([AddAnn], ( LFamilyResultSig RdrName+                                            , Maybe (LInjectivityAnn RdrName)))}+        :            { noLoc ([], (noLoc NoSig, Nothing)) }+        | '::' kind  { sLL $1 $> ( [mu AnnDcolon $1]+                                 , (sLL $2 $> (KindSig $2), Nothing)) }+        | '='  tv_bndr '|' injectivity_cond+                { sLL $1 $> ([mj AnnEqual $1, mj AnnVbar $3]+                            , (sLL $1 $2 (TyVarSig $2), Just $4))}++-- tycl_hdr parses the header of a class or data type decl,+-- which takes the form+--      T a b+--      Eq a => T a+--      (Eq a, Ord b) => T a b+--      T Int [a]                       -- for associated types+-- Rather a lot of inlining here, else we get reduce/reduce errors+tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) }+        : context '=>' type         {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)+                                       >> (return (sLL $1 $> (Just $1, $3)))+                                    }+        | type                      { sL1 $1 (Nothing, $1) }++capi_ctype :: { Maybe (Located CType) }+capi_ctype : '{-# CTYPE' STRING STRING '#-}'+                       {% ajs (Just (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRINGs $2) (getSTRING $2)))+                                        (getSTRINGs $3,getSTRING $3))))+                              [mo $1,mj AnnHeader $2,mj AnnVal $3,mc $4] }++           | '{-# CTYPE'        STRING '#-}'+                       {% ajs (Just (sLL $1 $> (CType (getCTYPEs $1) Nothing  (getSTRINGs $2, getSTRING $2))))+                              [mo $1,mj AnnVal $2,mc $3] }++           |           { Nothing }++-----------------------------------------------------------------------------+-- Stand-alone deriving++-- Glasgow extension: stand-alone deriving declarations+stand_alone_deriving :: { LDerivDecl RdrName }+  : 'deriving' deriv_strategy 'instance' overlap_pragma inst_type+                {% do { let { err = text "in the stand-alone deriving instance"+                                    <> colon <+> quotes (ppr $5) }+                      ; ams (sLL $1 (hsSigType $>) (DerivDecl $5 $2 $4))+                            [mj AnnDeriving $1, mj AnnInstance $3] } }++-----------------------------------------------------------------------------+-- Role annotations++role_annot :: { LRoleAnnotDecl RdrName }+role_annot : 'type' 'role' oqtycon maybe_roles+          {% amms (mkRoleAnnotDecl (comb3 $1 $3 $4) $3 (reverse (unLoc $4)))+                  [mj AnnType $1,mj AnnRole $2] }++-- Reversed!+maybe_roles :: { Located [Located (Maybe FastString)] }+maybe_roles : {- empty -}    { noLoc [] }+            | roles          { $1 }++roles :: { Located [Located (Maybe FastString)] }+roles : role             { sLL $1 $> [$1] }+      | roles role       { sLL $1 $> $ $2 : unLoc $1 }++-- read it in as a varid for better error messages+role :: { Located (Maybe FastString) }+role : VARID             { sL1 $1 $ Just $ getVARID $1 }+     | '_'               { sL1 $1 Nothing }++-- Pattern synonyms++-- Glasgow extension: pattern synonyms+pattern_synonym_decl :: { LHsDecl RdrName }+        : 'pattern' pattern_synonym_lhs '=' pat+         {%      let (name, args,as ) = $2 in+                 ams (sLL $1 $> . ValD $ mkPatSynBind name args $4+                                                    ImplicitBidirectional)+               (as ++ [mj AnnPattern $1, mj AnnEqual $3])+         }++        | 'pattern' pattern_synonym_lhs '<-' pat+         {%    let (name, args, as) = $2 in+               ams (sLL $1 $> . ValD $ mkPatSynBind name args $4 Unidirectional)+               (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) }++        | 'pattern' pattern_synonym_lhs '<-' pat where_decls+            {% do { let (name, args, as) = $2+                  ; mg <- mkPatSynMatchGroup name (snd $ unLoc $5)+                  ; ams (sLL $1 $> . ValD $+                           mkPatSynBind name args $4 (ExplicitBidirectional mg))+                       (as ++ ((mj AnnPattern $1:mu AnnLarrow $3:(fst $ unLoc $5))) )+                   }}++pattern_synonym_lhs :: { (Located RdrName, HsPatSynDetails (Located RdrName), [AddAnn]) }+        : con vars0 { ($1, PrefixPatSyn $2, []) }+        | varid conop varid { ($2, InfixPatSyn $1 $3, []) }+        | con '{' cvars1 '}' { ($1, RecordPatSyn $3, [moc $2, mcc $4] ) }++vars0 :: { [Located RdrName] }+        : {- empty -}                 { [] }+        | varid vars0                 { $1 : $2 }++cvars1 :: { [RecordPatSynField (Located RdrName)] }+       : varid                        { [RecordPatSynField $1 $1] }+       | varid ',' cvars1             {% addAnnotation (getLoc $1) AnnComma (getLoc $2) >>+                                         return ((RecordPatSynField $1 $1) : $3 )}++where_decls :: { Located ([AddAnn]+                         , Located (OrdList (LHsDecl RdrName))) }+        : 'where' '{' decls '}'       { sLL $1 $> ((mj AnnWhere $1:moc $2+                                           :mcc $4:(fst $ unLoc $3)),sL1 $3 (snd $ unLoc $3)) }+        | 'where' vocurly decls close { L (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3))+                                          ,sL1 $3 (snd $ unLoc $3)) }++pattern_synonym_sig :: { LSig RdrName }+        : 'pattern' con_list '::' sigtypedoc+                   {% ams (sLL $1 $> $ PatSynSig (unLoc $2) (mkLHsSigType $4))+                          [mj AnnPattern $1, mu AnnDcolon $3] }++-----------------------------------------------------------------------------+-- Nested declarations++-- Declaration in class bodies+--+decl_cls  :: { LHsDecl RdrName }+decl_cls  : at_decl_cls                 { $1 }+          | decl                        { $1 }++          -- A 'default' signature used with the generic-programming extension+          | 'default' infixexp '::' sigtypedoc+                    {% do { v <- checkValSigLhs $2+                          ; let err = text "in default signature" <> colon <+>+                                      quotes (ppr $2)+                          ; ams (sLL $1 $> $ SigD $ ClassOpSig True [v] $ mkLHsSigType $4)+                                [mj AnnDefault $1,mu AnnDcolon $3] } }++decls_cls :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) }  -- Reversed+          : decls_cls ';' decl_cls      {% if isNilOL (snd $ unLoc $1)+                                             then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)+                                                                    , unitOL $3))+                                             else ams (lastOL (snd $ unLoc $1)) [mj AnnSemi $2]+                                           >> return (sLL $1 $> (fst $ unLoc $1+                                                                ,(snd $ unLoc $1) `appOL` unitOL $3)) }+          | decls_cls ';'               {% if isNilOL (snd $ unLoc $1)+                                             then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)+                                                                                   ,snd $ unLoc $1))+                                             else ams (lastOL (snd $ unLoc $1)) [mj AnnSemi $2]+                                           >> return (sLL $1 $>  (unLoc $1)) }+          | decl_cls                    { sL1 $1 ([], unitOL $1) }+          | {- empty -}                 { noLoc ([],nilOL) }++decllist_cls+        :: { Located ([AddAnn]+                     , OrdList (LHsDecl RdrName)) }      -- Reversed+        : '{'         decls_cls '}'     { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2)+                                             ,snd $ unLoc $2) }+        |     vocurly decls_cls close   { $2 }++-- Class body+--+where_cls :: { Located ([AddAnn]+                       ,(OrdList (LHsDecl RdrName))) }    -- Reversed+                                -- No implicit parameters+                                -- May have type declarations+        : 'where' decllist_cls          { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2)+                                             ,snd $ unLoc $2) }+        | {- empty -}                   { noLoc ([],nilOL) }++-- Declarations in instance bodies+--+decl_inst  :: { Located (OrdList (LHsDecl RdrName)) }+decl_inst  : at_decl_inst               { sLL $1 $> (unitOL (sL1 $1 (InstD (unLoc $1)))) }+           | decl                       { sLL $1 $> (unitOL $1) }++decls_inst :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) }   -- Reversed+           : decls_inst ';' decl_inst   {% if isNilOL (snd $ unLoc $1)+                                             then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)+                                                                    , unLoc $3))+                                             else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2]+                                           >> return+                                            (sLL $1 $> (fst $ unLoc $1+                                                       ,(snd $ unLoc $1) `appOL` unLoc $3)) }+           | decls_inst ';'             {% if isNilOL (snd $ unLoc $1)+                                             then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)+                                                                                   ,snd $ unLoc $1))+                                             else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2]+                                           >> return (sLL $1 $> (unLoc $1)) }+           | decl_inst                  { sL1 $1 ([],unLoc $1) }+           | {- empty -}                { noLoc ([],nilOL) }++decllist_inst+        :: { Located ([AddAnn]+                     , OrdList (LHsDecl RdrName)) }      -- Reversed+        : '{'         decls_inst '}'    { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2),snd $ unLoc $2) }+        |     vocurly decls_inst close  { L (gl $2) (unLoc $2) }++-- Instance body+--+where_inst :: { Located ([AddAnn]+                        , OrdList (LHsDecl RdrName)) }   -- Reversed+                                -- No implicit parameters+                                -- May have type declarations+        : 'where' decllist_inst         { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2)+                                             ,(snd $ unLoc $2)) }+        | {- empty -}                   { noLoc ([],nilOL) }++-- Declarations in binding groups other than classes and instances+--+decls   :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) }+        : decls ';' decl    {% if isNilOL (snd $ unLoc $1)+                                 then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)+                                                        , unitOL $3))+                                 else do ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2]+                                           >> return (+                                          let { this = unitOL $3;+                                                rest = snd $ unLoc $1;+                                                these = rest `appOL` this }+                                          in rest `seq` this `seq` these `seq`+                                             (sLL $1 $> (fst $ unLoc $1,these))) }+        | decls ';'          {% if isNilOL (snd $ unLoc $1)+                                  then return (sLL $1 $> ((mj AnnSemi $2:(fst $ unLoc $1)+                                                          ,snd $ unLoc $1)))+                                  else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2]+                                           >> return (sLL $1 $> (unLoc $1)) }+        | decl                          { sL1 $1 ([], unitOL $1) }+        | {- empty -}                   { noLoc ([],nilOL) }++decllist :: { Located ([AddAnn],Located (OrdList (LHsDecl RdrName))) }+        : '{'            decls '}'     { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2)+                                                   ,sL1 $2 $ snd $ unLoc $2) }+        |     vocurly    decls close   { L (gl $2) (fst $ unLoc $2,sL1 $2 $ snd $ unLoc $2) }++-- Binding groups other than those of class and instance declarations+--+binds   ::  { Located ([AddAnn],Located (HsLocalBinds RdrName)) }+                                         -- May have implicit parameters+                                                -- No type declarations+        : decllist          {% do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc $1)+                                  ; return (sL1 $1 (fst $ unLoc $1+                                                    ,sL1 $1 $ HsValBinds val_binds)) } }++        | '{'            dbinds '}'     { sLL $1 $> ([moc $1,mcc $3]+                                             ,sL1 $2 $ HsIPBinds (IPBinds (reverse $ unLoc $2)+                                                         emptyTcEvBinds)) }++        |     vocurly    dbinds close   { L (getLoc $2) ([]+                                            ,sL1 $2 $ HsIPBinds (IPBinds (reverse $ unLoc $2)+                                                        emptyTcEvBinds)) }+++wherebinds :: { Located ([AddAnn],Located (HsLocalBinds RdrName)) }+                                                -- May have implicit parameters+                                                -- No type declarations+        : 'where' binds                 { sLL $1 $> (mj AnnWhere $1 : (fst $ unLoc $2)+                                             ,snd $ unLoc $2) }+        | {- empty -}                   { noLoc ([],noLoc emptyLocalBinds) }+++-----------------------------------------------------------------------------+-- Transformation Rules++rules   :: { OrdList (LRuleDecl RdrName) }+        :  rules ';' rule              {% addAnnotation (oll $1) AnnSemi (gl $2)+                                          >> return ($1 `snocOL` $3) }+        |  rules ';'                   {% addAnnotation (oll $1) AnnSemi (gl $2)+                                          >> return $1 }+        |  rule                        { unitOL $1 }+        |  {- empty -}                 { nilOL }++rule    :: { LRuleDecl RdrName }+        : STRING rule_activation rule_forall infixexp '=' exp+         {%ams (sLL $1 $> $ (HsRule (L (gl $1) (getSTRINGs $1,getSTRING $1))+                                  ((snd $2) `orElse` AlwaysActive)+                                  (snd $3) $4 placeHolderNames $6+                                  placeHolderNames))+               (mj AnnEqual $5 : (fst $2) ++ (fst $3)) }++-- Rules can be specified to be NeverActive, unlike inline/specialize pragmas+rule_activation :: { ([AddAnn],Maybe Activation) }+        : {- empty -}                           { ([],Nothing) }+        | rule_explicit_activation              { (fst $1,Just (snd $1)) }++rule_explicit_activation :: { ([AddAnn]+                              ,Activation) }  -- In brackets+        : '[' INTEGER ']'       { ([mos $1,mj AnnVal $2,mcs $3]+                                  ,ActiveAfter  (getINTEGERs $2) (fromInteger (getINTEGER $2))) }+        | '[' '~' INTEGER ']'   { ([mos $1,mj AnnTilde $2,mj AnnVal $3,mcs $4]+                                  ,ActiveBefore (getINTEGERs $3) (fromInteger (getINTEGER $3))) }+        | '[' '~' ']'           { ([mos $1,mj AnnTilde $2,mcs $3]+                                  ,NeverActive) }++rule_forall :: { ([AddAnn],[LRuleBndr RdrName]) }+        : 'forall' rule_var_list '.'     { ([mu AnnForall $1,mj AnnDot $3],$2) }+        | {- empty -}                    { ([],[]) }++rule_var_list :: { [LRuleBndr RdrName] }+        : rule_var                              { [$1] }+        | rule_var rule_var_list                { $1 : $2 }++rule_var :: { LRuleBndr RdrName }+        : varid                         { sLL $1 $> (RuleBndr $1) }+        | '(' varid '::' ctype ')'      {% ams (sLL $1 $> (RuleBndrSig $2+                                                       (mkLHsSigWcType $4)))+                                               [mop $1,mu AnnDcolon $3,mcp $5] }++-----------------------------------------------------------------------------+-- Warnings and deprecations (c.f. rules)++warnings :: { OrdList (LWarnDecl RdrName) }+        : warnings ';' warning         {% addAnnotation (oll $1) AnnSemi (gl $2)+                                          >> return ($1 `appOL` $3) }+        | warnings ';'                 {% addAnnotation (oll $1) AnnSemi (gl $2)+                                          >> return $1 }+        | warning                      { $1 }+        | {- empty -}                  { nilOL }++-- SUP: TEMPORARY HACK, not checking for `module Foo'+warning :: { OrdList (LWarnDecl RdrName) }+        : namelist strings+                {% amsu (sLL $1 $> (Warning (unLoc $1) (WarningTxt (noLoc NoSourceText) $ snd $ unLoc $2)))+                     (fst $ unLoc $2) }++deprecations :: { OrdList (LWarnDecl RdrName) }+        : deprecations ';' deprecation+                                       {% addAnnotation (oll $1) AnnSemi (gl $2)+                                          >> return ($1 `appOL` $3) }+        | deprecations ';'             {% addAnnotation (oll $1) AnnSemi (gl $2)+                                          >> return $1 }+        | deprecation                  { $1 }+        | {- empty -}                  { nilOL }++-- SUP: TEMPORARY HACK, not checking for `module Foo'+deprecation :: { OrdList (LWarnDecl RdrName) }+        : namelist strings+             {% amsu (sLL $1 $> $ (Warning (unLoc $1) (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc $2)))+                     (fst $ unLoc $2) }++strings :: { Located ([AddAnn],[Located StringLiteral]) }+    : STRING { sL1 $1 ([],[L (gl $1) (getStringLiteral $1)]) }+    | '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) }++stringlist :: { Located (OrdList (Located StringLiteral)) }+    : stringlist ',' STRING {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >>+                               return (sLL $1 $> (unLoc $1 `snocOL`+                                                  (L (gl $3) (getStringLiteral $3)))) }+    | STRING                { sLL $1 $> (unitOL (L (gl $1) (getStringLiteral $1))) }+    | {- empty -}           { noLoc nilOL }++-----------------------------------------------------------------------------+-- Annotations+annotation :: { LHsDecl RdrName }+    : '{-# ANN' name_var aexp '#-}'      {% ams (sLL $1 $> (AnnD $ HsAnnotation+                                            (getANN_PRAGs $1)+                                            (ValueAnnProvenance $2) $3))+                                            [mo $1,mc $4] }++    | '{-# ANN' 'type' tycon aexp '#-}'  {% ams (sLL $1 $> (AnnD $ HsAnnotation+                                            (getANN_PRAGs $1)+                                            (TypeAnnProvenance $3) $4))+                                            [mo $1,mj AnnType $2,mc $5] }++    | '{-# ANN' 'module' aexp '#-}'      {% ams (sLL $1 $> (AnnD $ HsAnnotation+                                                (getANN_PRAGs $1)+                                                 ModuleAnnProvenance $3))+                                                [mo $1,mj AnnModule $2,mc $4] }+++-----------------------------------------------------------------------------+-- Foreign import and export declarations++fdecl :: { Located ([AddAnn],HsDecl RdrName) }+fdecl : 'import' callconv safety fspec+               {% mkImport $2 $3 (snd $ unLoc $4) >>= \i ->+                 return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $4),i))  }+      | 'import' callconv        fspec+               {% do { d <- mkImport $2 (noLoc PlaySafe) (snd $ unLoc $3);+                    return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $3),d)) }}+      | 'export' callconv fspec+               {% mkExport $2 (snd $ unLoc $3) >>= \i ->+                  return (sLL $1 $> (mj AnnExport $1 : (fst $ unLoc $3),i) ) }++callconv :: { Located CCallConv }+          : 'stdcall'                   { sLL $1 $> StdCallConv }+          | 'ccall'                     { sLL $1 $> CCallConv   }+          | 'capi'                      { sLL $1 $> CApiConv    }+          | 'prim'                      { sLL $1 $> PrimCallConv}+          | 'javascript'                { sLL $1 $> JavaScriptCallConv }++safety :: { Located Safety }+        : 'unsafe'                      { sLL $1 $> PlayRisky }+        | 'safe'                        { sLL $1 $> PlaySafe }+        | 'interruptible'               { sLL $1 $> PlayInterruptible }++fspec :: { Located ([AddAnn]+                    ,(Located StringLiteral, Located RdrName, LHsSigType RdrName)) }+       : STRING var '::' sigtypedoc     { sLL $1 $> ([mu AnnDcolon $3]+                                             ,(L (getLoc $1)+                                                    (getStringLiteral $1), $2, mkLHsSigType $4)) }+       |        var '::' sigtypedoc     { sLL $1 $> ([mu AnnDcolon $2]+                                             ,(noLoc (StringLiteral NoSourceText nilFS), $1, mkLHsSigType $3)) }+         -- if the entity string is missing, it defaults to the empty string;+         -- the meaning of an empty entity string depends on the calling+         -- convention++-----------------------------------------------------------------------------+-- Type signatures++opt_sig :: { ([AddAnn], Maybe (LHsType RdrName)) }+        : {- empty -}                   { ([],Nothing) }+        | '::' sigtype                  { ([mu AnnDcolon $1],Just $2) }++opt_asig :: { ([AddAnn],Maybe (LHsType RdrName)) }+        : {- empty -}                   { ([],Nothing) }+        | '::' atype                    { ([mu AnnDcolon $1],Just $2) }++opt_tyconsig :: { ([AddAnn], Maybe (Located RdrName)) }+             : {- empty -}              { ([], Nothing) }+             | '::' gtycon              { ([mu AnnDcolon $1], Just $2) }++sigtype :: { LHsType RdrName }+        : ctype                            { $1 }++sigtypedoc :: { LHsType RdrName }+        : ctypedoc                         { $1 }+++sig_vars :: { Located [Located RdrName] }    -- Returned in reversed order+         : sig_vars ',' var           {% addAnnotation (gl $ head $ unLoc $1)+                                                       AnnComma (gl $2)+                                         >> return (sLL $1 $> ($3 : unLoc $1)) }+         | var                        { sL1 $1 [$1] }++sigtypes1 :: { (OrdList (LHsSigType RdrName)) }+   : sigtype                 { unitOL (mkLHsSigType $1) }+   | sigtype ',' sigtypes1   {% addAnnotation (gl $1) AnnComma (gl $2)+                                >> return (unitOL (mkLHsSigType $1) `appOL` $3) }++-----------------------------------------------------------------------------+-- Types++strict_mark :: { Located ([AddAnn],HsSrcBang) }+        : strictness { sL1 $1 (let (a, str) = unLoc $1 in (a, HsSrcBang NoSourceText NoSrcUnpack str)) }+        | unpackedness { sL1 $1 (let (a, prag, unpk) = unLoc $1 in (a, HsSrcBang prag unpk NoSrcStrict)) }+        | unpackedness strictness { sLL $1 $> (let { (a, prag, unpk) = unLoc $1+                                                   ; (a', str) = unLoc $2 }+                                                in (a ++ a', HsSrcBang prag unpk str)) }+        -- Although UNPACK with no '!' without StrictData and UNPACK with '~' are illegal,+        -- we get a better error message if we parse them here++strictness :: { Located ([AddAnn], SrcStrictness) }+        : '!' { sL1 $1 ([mj AnnBang $1], SrcStrict) }+        | '~' { sL1 $1 ([mj AnnTilde $1], SrcLazy) }++unpackedness :: { Located ([AddAnn], SourceText, SrcUnpackedness) }+        : '{-# UNPACK' '#-}'   { sLL $1 $> ([mo $1, mc $2], getUNPACK_PRAGs $1, SrcUnpack) }+        | '{-# NOUNPACK' '#-}' { sLL $1 $> ([mo $1, mc $2], getNOUNPACK_PRAGs $1, SrcNoUnpack) }++-- A ctype is a for-all type+ctype   :: { LHsType RdrName }+        : 'forall' tv_bndrs '.' ctype   {% hintExplicitForall (getLoc $1) >>+                                           ams (sLL $1 $> $+                                                HsForAllTy { hst_bndrs = $2+                                                           , hst_body = $4 })+                                               [mu AnnForall $1, mj AnnDot $3] }+        | context '=>' ctype          {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)+                                         >> return (sLL $1 $> $+                                            HsQualTy { hst_ctxt = $1+                                                     , hst_body = $3 }) }+        | ipvar '::' type             {% ams (sLL $1 $> (HsIParamTy $1 $3))+                                             [mu AnnDcolon $2] }+        | type                        { $1 }++----------------------+-- Notes for 'ctypedoc'+-- It would have been nice to simplify the grammar by unifying `ctype` and+-- ctypedoc` into one production, allowing comments on types everywhere (and+-- rejecting them after parsing, where necessary).  This is however not possible+-- since it leads to ambiguity. The reason is the support for comments on record+-- fields:+--         data R = R { field :: Int -- ^ comment on the field }+-- If we allow comments on types here, it's not clear if the comment applies+-- to 'field' or to 'Int'. So we must use `ctype` to describe the type.++ctypedoc :: { LHsType RdrName }+        : 'forall' tv_bndrs '.' ctypedoc {% hintExplicitForall (getLoc $1) >>+                                            ams (sLL $1 $> $+                                                 HsForAllTy { hst_bndrs = $2+                                                            , hst_body = $4 })+                                                [mu AnnForall $1,mj AnnDot $3] }+        | context '=>' ctypedoc       {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)+                                         >> return (sLL $1 $> $+                                            HsQualTy { hst_ctxt = $1+                                                     , hst_body = $3 }) }+        | ipvar '::' type             {% ams (sLL $1 $> (HsIParamTy $1 $3))+                                             [mu AnnDcolon $2] }+        | typedoc                     { $1 }++----------------------+-- Notes for 'context'+-- We parse a context as a btype so that we don't get reduce/reduce+-- errors in ctype.  The basic problem is that+--      (Eq a, Ord a)+-- looks so much like a tuple type.  We can't tell until we find the =>++-- We have the t1 ~ t2 form both in 'context' and in type,+-- to permit an individual equational constraint without parenthesis.+-- Thus for some reason we allow    f :: a~b => blah+-- but not                          f :: ?x::Int => blah+-- See Note [Parsing ~]+context :: { LHsContext RdrName }+        :  btype                        {% do { (anns,ctx) <- checkContext $1+                                                ; if null (unLoc ctx)+                                                   then addAnnotation (gl $1) AnnUnit (gl $1)+                                                   else return ()+                                                ; ams ctx anns+                                                } }++context_no_ops :: { LHsContext RdrName }+        : btype_no_ops                 {% do { ty <- splitTilde $1+                                             ; (anns,ctx) <- checkContext ty+                                             ; if null (unLoc ctx)+                                                   then addAnnotation (gl ty) AnnUnit (gl ty)+                                                   else return ()+                                             ; ams ctx anns+                                             } }++{- Note [GADT decl discards annotations]+~~~~~~~~~~~~~~~~~~~~~+The type production for++    btype `->` btype++adds the AnnRarrow annotation twice, in different places.++This is because if the type is processed as usual, it belongs on the annotations+for the type as a whole.++But if the type is passed to mkGadtDecl, it discards the top level SrcSpan, and+the top-level annotation will be disconnected. Hence for this specific case it+is connected to the first type too.+-}++type :: { LHsType RdrName }+        : btype                        { $1 }+        | btype '->' ctype             {% ams $1 [mu AnnRarrow $2] -- See note [GADT decl discards annotations]+                                       >> ams (sLL $1 $> $ HsFunTy $1 $3)+                                              [mu AnnRarrow $2] }+++typedoc :: { LHsType RdrName }+        : btype                          { $1 }+        | btype docprev                  { sLL $1 $> $ HsDocTy $1 $2 }+        | btype '->'     ctypedoc        {% ams (sLL $1 $> $ HsFunTy $1 $3)+                                                [mu AnnRarrow $2] }+        | btype docprev '->' ctypedoc    {% ams (sLL $1 $> $+                                                 HsFunTy (L (comb2 $1 $2) (HsDocTy $1 $2))+                                                         $4)+                                                [mu AnnRarrow $3] }++-- See Note [Parsing ~]+btype :: { LHsType RdrName }+        : tyapps                      {%  splitTildeApps (reverse (unLoc $1)) >>=+                                          \ts -> return $ sL1 $1 $ HsAppsTy ts }++-- Used for parsing Haskell98-style data constructors,+-- in order to forbid the blasphemous+-- > data Foo = Int :+ Char :* Bool+-- See also Note [Parsing data constructors is hard] in RdrHsSyn+btype_no_ops :: { LHsType RdrName }+        : btype_no_ops atype            { sLL $1 $> $ HsAppTy $1 $2 }+        | atype                         { $1 }++tyapps :: { Located [LHsAppType RdrName] }   -- NB: This list is reversed+        : tyapp                         { sL1 $1 [$1] }+        | tyapps tyapp                  { sLL $1 $> $ $2 : (unLoc $1) }++-- See Note [HsAppsTy] in HsTypes+tyapp :: { LHsAppType RdrName }+        : atype                         { sL1 $1 $ HsAppPrefix $1 }+        | qtyconop                      { sL1 $1 $ HsAppInfix $1 }+        | tyvarop                       { sL1 $1 $ HsAppInfix $1 }+        | SIMPLEQUOTE qconop            {% ams (sLL $1 $> $ HsAppInfix $2)+                                               [mj AnnSimpleQuote $1] }+        | SIMPLEQUOTE varop             {% ams (sLL $1 $> $ HsAppInfix $2)+                                               [mj AnnSimpleQuote $1] }++atype :: { LHsType RdrName }+        : ntgtycon                       { sL1 $1 (HsTyVar NotPromoted $1) }      -- Not including unit tuples+        | tyvar                          { sL1 $1 (HsTyVar NotPromoted $1) }      -- (See Note [Unit tuples])+        | strict_mark atype              {% ams (sLL $1 $> (HsBangTy (snd $ unLoc $1) $2))+                                                (fst $ unLoc $1) }  -- Constructor sigs only+        | '{' fielddecls '}'             {% amms (checkRecordSyntax+                                                    (sLL $1 $> $ HsRecTy $2))+                                                        -- Constructor sigs only+                                                 [moc $1,mcc $3] }+        | '(' ')'                        {% ams (sLL $1 $> $ HsTupleTy+                                                    HsBoxedOrConstraintTuple [])+                                                [mop $1,mcp $2] }+        | '(' ctype ',' comma_types1 ')' {% addAnnotation (gl $2) AnnComma+                                                          (gl $3) >>+                                            ams (sLL $1 $> $ HsTupleTy+                                             HsBoxedOrConstraintTuple ($2 : $4))+                                                [mop $1,mcp $5] }+        | '(#' '#)'                   {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple [])+                                             [mo $1,mc $2] }+        | '(#' comma_types1 '#)'      {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple $2)+                                             [mo $1,mc $3] }+        | '(#' bar_types2 '#)'        {% ams (sLL $1 $> $ HsSumTy $2)+                                             [mo $1,mc $3] }+        | '[' ctype ']'               {% ams (sLL $1 $> $ HsListTy  $2) [mos $1,mcs $3] }+        | '[:' ctype ':]'             {% ams (sLL $1 $> $ HsPArrTy  $2) [mo $1,mc $3] }+        | '(' ctype ')'               {% ams (sLL $1 $> $ HsParTy   $2) [mop $1,mcp $3] }+        | '(' ctype '::' kind ')'     {% ams (sLL $1 $> $ HsKindSig $2 $4)+                                             [mop $1,mu AnnDcolon $3,mcp $5] }+        | quasiquote                  { sL1 $1 (HsSpliceTy (unLoc $1) placeHolderKind) }+        | '$(' exp ')'                {% ams (sLL $1 $> $ mkHsSpliceTy HasParens $2)+                                             [mj AnnOpenPE $1,mj AnnCloseP $3] }+        | TH_ID_SPLICE                {%ams (sLL $1 $> $ mkHsSpliceTy HasDollar $ sL1 $1 $ HsVar $+                                             (sL1 $1 (mkUnqual varName (getTH_ID_SPLICE $1))))+                                             [mj AnnThIdSplice $1] }+                                      -- see Note [Promotion] for the followings+        | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar Promoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] }+        | SIMPLEQUOTE  '(' ctype ',' comma_types1 ')'+                             {% addAnnotation (gl $3) AnnComma (gl $4) >>+                                ams (sLL $1 $> $ HsExplicitTupleTy [] ($3 : $5))+                                    [mj AnnSimpleQuote $1,mop $2,mcp $6] }+        | SIMPLEQUOTE  '[' comma_types0 ']'     {% ams (sLL $1 $> $ HsExplicitListTy Promoted+                                                            placeHolderKind $3)+                                                       [mj AnnSimpleQuote $1,mos $2,mcs $4] }+        | SIMPLEQUOTE var                       {% ams (sLL $1 $> $ HsTyVar Promoted $2)+                                                       [mj AnnSimpleQuote $1,mj AnnName $2] }++        -- Two or more [ty, ty, ty] must be a promoted list type, just as+        -- if you had written '[ty, ty, ty]+        -- (One means a list type, zero means the list type constructor,+        -- so you have to quote those.)+        | '[' ctype ',' comma_types1 ']'  {% addAnnotation (gl $2) AnnComma+                                                           (gl $3) >>+                                             ams (sLL $1 $> $ HsExplicitListTy NotPromoted+                                                     placeHolderKind ($2 : $4))+                                                 [mos $1,mcs $5] }+        | INTEGER              { sLL $1 $> $ HsTyLit $ HsNumTy (getINTEGERs $1)+                                                               (getINTEGER $1) }+        | STRING               { sLL $1 $> $ HsTyLit $ HsStrTy (getSTRINGs $1)+                                                               (getSTRING  $1) }+        | '_'                  { sL1 $1 $ mkAnonWildCardTy }++-- An inst_type is what occurs in the head of an instance decl+--      e.g.  (Foo a, Gaz b) => Wibble a b+-- It's kept as a single type for convenience.+inst_type :: { LHsSigType RdrName }+        : sigtype                       { mkLHsSigType $1 }++deriv_types :: { [LHsSigType RdrName] }+        : typedoc                       { [mkLHsSigType $1] }++        | typedoc ',' deriv_types       {% addAnnotation (gl $1) AnnComma (gl $2)+                                           >> return (mkLHsSigType $1 : $3) }++comma_types0  :: { [LHsType RdrName] }  -- Zero or more:  ty,ty,ty+        : comma_types1                  { $1 }+        | {- empty -}                   { [] }++comma_types1    :: { [LHsType RdrName] }  -- One or more:  ty,ty,ty+        : ctype                        { [$1] }+        | ctype  ',' comma_types1      {% addAnnotation (gl $1) AnnComma (gl $2)+                                          >> return ($1 : $3) }++bar_types2    :: { [LHsType RdrName] }  -- Two or more:  ty|ty|ty+        : ctype  '|' ctype             {% addAnnotation (gl $1) AnnVbar (gl $2)+                                          >> return [$1,$3] }+        | ctype  '|' bar_types2        {% addAnnotation (gl $1) AnnVbar (gl $2)+                                          >> return ($1 : $3) }++tv_bndrs :: { [LHsTyVarBndr RdrName] }+         : tv_bndr tv_bndrs             { $1 : $2 }+         | {- empty -}                  { [] }++tv_bndr :: { LHsTyVarBndr RdrName }+        : tyvar                         { sL1 $1 (UserTyVar $1) }+        | '(' tyvar '::' kind ')'       {% ams (sLL $1 $>  (KindedTyVar $2 $4))+                                               [mop $1,mu AnnDcolon $3+                                               ,mcp $5] }++fds :: { Located ([AddAnn],[Located (FunDep (Located RdrName))]) }+        : {- empty -}                   { noLoc ([],[]) }+        | '|' fds1                      { (sLL $1 $> ([mj AnnVbar $1]+                                                 ,reverse (unLoc $2))) }++fds1 :: { Located [Located (FunDep (Located RdrName))] }+        : fds1 ',' fd   {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2)+                           >> return (sLL $1 $> ($3 : unLoc $1)) }+        | fd            { sL1 $1 [$1] }++fd :: { Located (FunDep (Located RdrName)) }+        : varids0 '->' varids0  {% ams (L (comb3 $1 $2 $3)+                                       (reverse (unLoc $1), reverse (unLoc $3)))+                                       [mu AnnRarrow $2] }++varids0 :: { Located [Located RdrName] }+        : {- empty -}                   { noLoc [] }+        | varids0 tyvar                 { sLL $1 $> ($2 : unLoc $1) }++{-+Note [Parsing ~]+~~~~~~~~~~~~~~~~++Due to parsing conflicts between laziness annotations in data type+declarations (see strict_mark) and equality types ~'s are always+parsed as laziness annotations, and turned into HsEqTy's in the+correct places using RdrHsSyn.splitTilde.++Since strict_mark is parsed as part of atype which is part of type,+typedoc and context (where HsEqTy previously appeared) it made most+sense and was simplest to parse ~ as part of strict_mark and later+turn them into HsEqTy's.++-}+++-----------------------------------------------------------------------------+-- Kinds++kind :: { LHsKind RdrName }+        : ctype                  { $1 }++{- Note [Promotion]+   ~~~~~~~~~~~~~~~~++- Syntax of promoted qualified names+We write 'Nat.Zero instead of Nat.'Zero when dealing with qualified+names. Moreover ticks are only allowed in types, not in kinds, for a+few reasons:+  1. we don't need quotes since we cannot define names in kinds+  2. if one day we merge types and kinds, tick would mean look in DataName+  3. we don't have a kind namespace anyway++- Name resolution+When the user write Zero instead of 'Zero in types, we parse it a+HsTyVar ("Zero", TcClsName) instead of HsTyVar ("Zero", DataName). We+deal with this in the renamer. If a HsTyVar ("Zero", TcClsName) is not+bounded in the type level, then we look for it in the term level (we+change its namespace to DataName, see Note [Demotion] in OccName). And+both become a HsTyVar ("Zero", DataName) after the renamer.++-}+++-----------------------------------------------------------------------------+-- Datatype declarations++gadt_constrlist :: { Located ([AddAnn]+                          ,[LConDecl RdrName]) } -- Returned in order+        : 'where' '{'        gadt_constrs '}'   { L (comb2 $1 $3)+                                                    ([mj AnnWhere $1+                                                     ,moc $2+                                                     ,mcc $4]+                                                    , unLoc $3) }+        | 'where' vocurly    gadt_constrs close  { L (comb2 $1 $3)+                                                     ([mj AnnWhere $1]+                                                     , unLoc $3) }+        | {- empty -}                            { noLoc ([],[]) }++gadt_constrs :: { Located [LConDecl RdrName] }+        : gadt_constr_with_doc ';' gadt_constrs+                  {% addAnnotation (gl $1) AnnSemi (gl $2)+                     >> return (L (comb2 $1 $3) ($1 : unLoc $3)) }+        | gadt_constr_with_doc          { L (gl $1) [$1] }+        | {- empty -}                   { noLoc [] }++-- We allow the following forms:+--      C :: Eq a => a -> T a+--      C :: forall a. Eq a => !a -> T a+--      D { x,y :: a } :: T a+--      forall a. Eq a => D { x,y :: a } :: T a++gadt_constr_with_doc :: { LConDecl RdrName }+gadt_constr_with_doc+        : maybe_docnext ';' gadt_constr+                {% return $ addConDoc $3 $1 }+        | gadt_constr+                {% return $1 }++gadt_constr :: { LConDecl RdrName }+    -- see Note [Difference in parsing GADT and data constructors]+    -- Returns a list because of:   C,D :: ty+        : con_list '::' sigtype+                {% ams (sLL $1 $> (mkGadtDecl (unLoc $1) (mkLHsSigType $3)))+                       [mu AnnDcolon $2] }++{- Note [Difference in parsing GADT and data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GADT constructors have simpler syntax than usual data constructors:+in GADTs, types cannot occur to the left of '::', so they cannot be mixed+with constructor names (see Note [Parsing data constructors is hard]).++Due to simplified syntax, GADT constructor names (left-hand side of '::')+use simpler grammar production than usual data constructor names. As a+consequence, GADT constructor names are resticted (names like '(*)' are+allowed in usual data constructors, but not in GADTs).+-}++constrs :: { Located ([AddAnn],[LConDecl RdrName]) }+        : maybe_docnext '=' constrs1    { L (comb2 $2 $3) ([mj AnnEqual $2]+                                                     ,addConDocs (unLoc $3) $1)}++constrs1 :: { Located [LConDecl RdrName] }+        : constrs1 maybe_docnext '|' maybe_docprev constr+            {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $3)+               >> return (sLL $1 $> (addConDoc $5 $2 : addConDocFirst (unLoc $1) $4)) }+        | constr                                          { sL1 $1 [$1] }++constr :: { LConDecl RdrName }+        : maybe_docnext forall context_no_ops '=>' constr_stuff maybe_docprev+                {% ams (let (con,details) = unLoc $5 in+                  addConDoc (L (comb4 $2 $3 $4 $5) (mkConDeclH98 con+                                                   (snd $ unLoc $2) $3 details))+                            ($1 `mplus` $6))+                        (mu AnnDarrow $4:(fst $ unLoc $2)) }+        | maybe_docnext forall constr_stuff maybe_docprev+                {% ams ( let (con,details) = unLoc $3 in+                  addConDoc (L (comb2 $2 $3) (mkConDeclH98 con+                                           (snd $ unLoc $2) (noLoc []) details))+                            ($1 `mplus` $4))+                       (fst $ unLoc $2) }++forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr RdrName]) }+        : 'forall' tv_bndrs '.'       { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) }+        | {- empty -}                 { noLoc ([], Nothing) }++constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) }+    -- See Note [Parsing data constructors is hard] in RdrHsSyn+        : btype_no_ops                         {% do { c <- splitCon $1+                                                     ; return $ sLL $1 $> c } }+        | btype_no_ops conop btype_no_ops      {% do { ty <- splitTilde $1+                                                     ; return $ sLL $1 $> ($2, InfixCon ty $3) } }++fielddecls :: { [LConDeclField RdrName] }+        : {- empty -}     { [] }+        | fielddecls1     { $1 }++fielddecls1 :: { [LConDeclField RdrName] }+        : fielddecl maybe_docnext ',' maybe_docprev fielddecls1+            {% addAnnotation (gl $1) AnnComma (gl $3) >>+               return ((addFieldDoc $1 $4) : addFieldDocs $5 $2) }+        | fielddecl   { [$1] }++fielddecl :: { LConDeclField RdrName }+                                              -- A list because of   f,g :: Int+        : maybe_docnext sig_vars '::' ctype maybe_docprev+            {% ams (L (comb2 $2 $4)+                      (ConDeclField (reverse (map (\ln@(L l n) -> L l $ FieldOcc ln PlaceHolder) (unLoc $2))) $4 ($1 `mplus` $5)))+                   [mu AnnDcolon $3] }++-- Reversed!+maybe_derivings :: { HsDeriving RdrName }+        : {- empty -}             { noLoc [] }+        | derivings               { $1 }++-- A list of one or more deriving clauses at the end of a datatype+derivings :: { HsDeriving RdrName }+        : derivings deriving      { sLL $1 $> $ $2 : unLoc $1 }+        | deriving                { sLL $1 $> [$1] }++-- The outer Located is just to allow the caller to+-- know the rightmost extremity of the 'deriving' clause+deriving :: { LHsDerivingClause RdrName }+        : 'deriving' deriv_strategy qtycondoc+              {% let { full_loc = comb2 $1 $> }+                 in ams (L full_loc $ HsDerivingClause $2 $ L full_loc+                            [mkLHsSigType $3])+                        [mj AnnDeriving $1] }++        | 'deriving' deriv_strategy '(' ')'+              {% let { full_loc = comb2 $1 $> }+                 in ams (L full_loc $ HsDerivingClause $2 $ L full_loc [])+                        [mj AnnDeriving $1,mop $3,mcp $4] }++        | 'deriving' deriv_strategy '(' deriv_types ')'+              {% let { full_loc = comb2 $1 $> }+                 in ams (L full_loc $ HsDerivingClause $2 $ L full_loc $4)+                        [mj AnnDeriving $1,mop $3,mcp $5] }+             -- Glasgow extension: allow partial+             -- applications in derivings++-----------------------------------------------------------------------------+-- Value definitions++{- Note [Declaration/signature overlap]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There's an awkward overlap with a type signature.  Consider+        f :: Int -> Int = ...rhs...+   Then we can't tell whether it's a type signature or a value+   definition with a result signature until we see the '='.+   So we have to inline enough to postpone reductions until we know.+-}++{-+  ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var+  instead of qvar, we get another shift/reduce-conflict. Consider the+  following programs:++     { (^^) :: Int->Int ; }          Type signature; only var allowed++     { (^^) :: Int->Int = ... ; }    Value defn with result signature;+                                     qvar allowed (because of instance decls)++  We can't tell whether to reduce var to qvar until after we've read the signatures.+-}++docdecl :: { LHsDecl RdrName }+        : docdecld { sL1 $1 (DocD (unLoc $1)) }++docdecld :: { LDocDecl }+        : docnext                               { sL1 $1 (DocCommentNext (unLoc $1)) }+        | docprev                               { sL1 $1 (DocCommentPrev (unLoc $1)) }+        | docnamed                              { sL1 $1 (case (unLoc $1) of (n, doc) -> DocCommentNamed n doc) }+        | docsection                            { sL1 $1 (case (unLoc $1) of (n, doc) -> DocGroup n doc) }++decl_no_th :: { LHsDecl RdrName }+        : sigdecl               { $1 }++        | '!' aexp rhs          {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)+                                              -- Turn it all into an expression so that+                                              -- checkPattern can check that bangs are enabled+                                            ; l = comb2 $1 $> };+                                        (ann, r) <- checkValDef empty SrcStrict e Nothing $3 ;+                                        -- Depending upon what the pattern looks like we might get either+                                        -- a FunBind or PatBind back from checkValDef. See Note+                                        -- [Varieties of binding pattern matches]+                                        case r of {+                                          (FunBind n _ _ _ _) ->+                                                ams (L l ()) [mj AnnFunId n] >> return () ;+                                          (PatBind (L lh _lhs) _rhs _ _ _) ->+                                                ams (L lh ()) [] >> return () } ;++                                        _ <- ams (L l ()) (ann ++ fst (unLoc $3) ++ [mj AnnBang $1]) ;+                                        return $! (sL l $ ValD r) } }++        | infixexp_top opt_sig rhs  {% do { (ann,r) <- checkValDef empty NoSrcStrict $1 (snd $2) $3;+                                        let { l = comb2 $1 $> };+                                        -- Depending upon what the pattern looks like we might get either+                                        -- a FunBind or PatBind back from checkValDef. See Note+                                        -- [Varieties of binding pattern matches]+                                        case r of {+                                          (FunBind n _ _ _ _) ->+                                                ams (L l ()) (mj AnnFunId n:(fst $2)) >> return () ;+                                          (PatBind (L lh _lhs) _rhs _ _ _) ->+                                                ams (L lh ()) (fst $2) >> return () } ;+                                        _ <- ams (L l ()) (ann ++ (fst $ unLoc $3));+                                        return $! (sL l $ ValD r) } }+        | pattern_synonym_decl  { $1 }+        | docdecl               { $1 }++decl    :: { LHsDecl RdrName }+        : decl_no_th            { $1 }++        -- Why do we only allow naked declaration splices in top-level+        -- declarations and not here? Short answer: because readFail009+        -- fails terribly with a panic in cvBindsAndSigs otherwise.+        | splice_exp            { sLL $1 $> $ mkSpliceDecl $1 }++rhs     :: { Located ([AddAnn],GRHSs RdrName (LHsExpr RdrName)) }+        : '=' exp wherebinds    { sL (comb3 $1 $2 $3)+                                    ((mj AnnEqual $1 : (fst $ unLoc $3))+                                    ,GRHSs (unguardedRHS (comb3 $1 $2 $3) $2)+                                   (snd $ unLoc $3)) }+        | gdrhs wherebinds      { sLL $1 $>  (fst $ unLoc $2+                                    ,GRHSs (reverse (unLoc $1))+                                                    (snd $ unLoc $2)) }++gdrhs :: { Located [LGRHS RdrName (LHsExpr RdrName)] }+        : gdrhs gdrh            { sLL $1 $> ($2 : unLoc $1) }+        | gdrh                  { sL1 $1 [$1] }++gdrh :: { LGRHS RdrName (LHsExpr RdrName) }+        : '|' guardquals '=' exp  {% ams (sL (comb2 $1 $>) $ GRHS (unLoc $2) $4)+                                         [mj AnnVbar $1,mj AnnEqual $3] }++sigdecl :: { LHsDecl RdrName }+        :+        -- See Note [Declaration/signature overlap] for why we need infixexp here+          infixexp_top '::' sigtypedoc+                        {% do v <- checkValSigLhs $1+                        ; _ <- ams (sLL $1 $> ()) [mu AnnDcolon $2]+                        ; return (sLL $1 $> $ SigD $+                                  TypeSig [v] (mkLHsSigWcType $3)) }++        | var ',' sig_vars '::' sigtypedoc+           {% do { let sig = TypeSig ($1 : reverse (unLoc $3))+                                     (mkLHsSigWcType $5)+                 ; addAnnotation (gl $1) AnnComma (gl $2)+                 ; ams ( sLL $1 $> $ SigD sig )+                       [mu AnnDcolon $4] } }++        | infix prec ops+              {% ams (sLL $1 $> $ SigD+                        (FixSig (FixitySig (fromOL $ unLoc $3)+                                (Fixity (fst $ unLoc $2) (snd $ unLoc $2) (unLoc $1)))))+                     [mj AnnInfix $1,mj AnnVal $2] }++        | pattern_synonym_sig   { sLL $1 $> . SigD . unLoc $ $1 }++        | '{-# COMPLETE' con_list opt_tyconsig  '#-}'+                {% let (dcolon, tc) = $3+                   in ams+                       (sLL $1 $>+                         (SigD (CompleteMatchSig (getCOMPLETE_PRAGs $1) $2 tc)))+                    ([ mo $1 ] ++ dcolon ++ [mc $4]) }++        -- This rule is for both INLINE and INLINABLE pragmas+        | '{-# INLINE' activation qvar '#-}'+                {% ams ((sLL $1 $> $ SigD (InlineSig $3+                            (mkInlinePragma (getINLINE_PRAGs $1) (getINLINE $1)+                                            (snd $2)))))+                       ((mo $1:fst $2) ++ [mc $4]) }++        | '{-# SCC' qvar '#-}'+          {% ams (sLL $1 $> (SigD (SCCFunSig (getSCC_PRAGs $1) $2 Nothing)))+                 [mo $1, mc $3] }++        | '{-# SCC' qvar STRING '#-}'+          {% do { scc <- getSCC $3+                ; let str_lit = StringLiteral (getSTRINGs $3) scc+                ; ams (sLL $1 $> (SigD (SCCFunSig (getSCC_PRAGs $1) $2 (Just ( sL1 $3 str_lit)))))+                      [mo $1, mc $4] } }++        | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'+             {% ams (+                 let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)+                                             (EmptyInlineSpec, FunLike) (snd $2)+                  in sLL $1 $> $ SigD (SpecSig $3 (fromOL $5) inl_prag))+                    (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) }++        | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'+             {% ams (sLL $1 $> $ SigD (SpecSig $3 (fromOL $5)+                               (mkInlinePragma (getSPEC_INLINE_PRAGs $1)+                                               (getSPEC_INLINE $1) (snd $2))))+                       (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) }++        | '{-# SPECIALISE' 'instance' inst_type '#-}'+                {% ams (sLL $1 $>+                                  $ SigD (SpecInstSig (getSPEC_PRAGs $1) $3))+                       [mo $1,mj AnnInstance $2,mc $4] }++        -- A minimal complete definition+        | '{-# MINIMAL' name_boolformula_opt '#-}'+            {% ams (sLL $1 $> $ SigD (MinimalSig (getMINIMAL_PRAGs $1) $2))+                   [mo $1,mc $3] }++activation :: { ([AddAnn],Maybe Activation) }+        : {- empty -}                           { ([],Nothing) }+        | explicit_activation                   { (fst $1,Just (snd $1)) }++explicit_activation :: { ([AddAnn],Activation) }  -- In brackets+        : '[' INTEGER ']'       { ([mj AnnOpenS $1,mj AnnVal $2,mj AnnCloseS $3]+                                  ,ActiveAfter  (getINTEGERs $2) (fromInteger (getINTEGER $2))) }+        | '[' '~' INTEGER ']'   { ([mj AnnOpenS $1,mj AnnTilde $2,mj AnnVal $3+                                                 ,mj AnnCloseS $4]+                                  ,ActiveBefore (getINTEGERs $3) (fromInteger (getINTEGER $3))) }++-----------------------------------------------------------------------------+-- Expressions++quasiquote :: { Located (HsSplice RdrName) }+        : TH_QUASIQUOTE   { let { loc = getLoc $1+                                ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1+                                ; quoterId = mkUnqual varName quoter }+                            in sL1 $1 (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }+        | TH_QQUASIQUOTE  { let { loc = getLoc $1+                                ; ITqQuasiQuote (qual, quoter, quote, quoteSpan) = unLoc $1+                                ; quoterId = mkQual varName (qual, quoter) }+                            in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }++exp   :: { LHsExpr RdrName }+        : infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig $1 (mkLHsSigWcType $3))+                                       [mu AnnDcolon $2] }+        | infixexp '-<' exp     {% ams (sLL $1 $> $ HsArrApp $1 $3 placeHolderType+                                                        HsFirstOrderApp True)+                                       [mu Annlarrowtail $2] }+        | infixexp '>-' exp     {% ams (sLL $1 $> $ HsArrApp $3 $1 placeHolderType+                                                      HsFirstOrderApp False)+                                       [mu Annrarrowtail $2] }+        | infixexp '-<<' exp    {% ams (sLL $1 $> $ HsArrApp $1 $3 placeHolderType+                                                      HsHigherOrderApp True)+                                       [mu AnnLarrowtail $2] }+        | infixexp '>>-' exp    {% ams (sLL $1 $> $ HsArrApp $3 $1 placeHolderType+                                                      HsHigherOrderApp False)+                                       [mu AnnRarrowtail $2] }+        | infixexp              { $1 }++infixexp :: { LHsExpr RdrName }+        : exp10 { $1 }+        | infixexp qop exp10  {% ams (sLL $1 $> (OpApp $1 $2 placeHolderFixity $3))+                                     [mj AnnVal $2] }+                 -- AnnVal annotation for NPlusKPat, which discards the operator++infixexp_top :: { LHsExpr RdrName }+        : exp10_top               { $1 }+        | infixexp_top qop exp10_top+                                  {% ams (sLL $1 $> (OpApp $1 $2 placeHolderFixity $3))+                                         [mj AnnVal $2] }++exp10_top :: { LHsExpr RdrName }+        : '\\' apat apats opt_asig '->' exp+                   {% ams (sLL $1 $> $ HsLam (mkMatchGroup FromSource+                            [sLL $1 $> $ Match { m_ctxt = LambdaExpr+                                               , m_pats = $2:$3+                                               , m_type = snd $4+                                               , m_grhss = unguardedGRHSs $6 }]))+                          (mj AnnLam $1:mu AnnRarrow $5:(fst $4)) }++        | 'let' binds 'in' exp          {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4)+                                               (mj AnnLet $1:mj AnnIn $3+                                                 :(fst $ unLoc $2)) }+        | '\\' 'lcase' altslist+            {% ams (sLL $1 $> $ HsLamCase+                                   (mkMatchGroup FromSource (snd $ unLoc $3)))+                   (mj AnnLam $1:mj AnnCase $2:(fst $ unLoc $3)) }+        | 'if' exp optSemi 'then' exp optSemi 'else' exp+                           {% checkDoAndIfThenElse $2 (snd $3) $5 (snd $6) $8 >>+                              ams (sLL $1 $> $ mkHsIf $2 $5 $8)+                                  (mj AnnIf $1:mj AnnThen $4+                                     :mj AnnElse $7+                                     :(map (\l -> mj AnnSemi l) (fst $3))+                                    ++(map (\l -> mj AnnSemi l) (fst $6))) }+        | 'if' ifgdpats                 {% hintMultiWayIf (getLoc $1) >>+                                           ams (sLL $1 $> $ HsMultiIf+                                                     placeHolderType+                                                     (reverse $ snd $ unLoc $2))+                                               (mj AnnIf $1:(fst $ unLoc $2)) }+        | 'case' exp 'of' altslist      {% ams (sLL $1 $> $ HsCase $2 (mkMatchGroup+                                                   FromSource (snd $ unLoc $4)))+                                               (mj AnnCase $1:mj AnnOf $3+                                                  :(fst $ unLoc $4)) }+        | '-' fexp                      {% ams (sLL $1 $> $ NegApp $2 noSyntaxExpr)+                                               [mj AnnMinus $1] }++        | 'do' stmtlist              {% ams (L (comb2 $1 $2)+                                               (mkHsDo DoExpr (snd $ unLoc $2)))+                                               (mj AnnDo $1:(fst $ unLoc $2)) }+        | 'mdo' stmtlist            {% ams (L (comb2 $1 $2)+                                              (mkHsDo MDoExpr (snd $ unLoc $2)))+                                           (mj AnnMdo $1:(fst $ unLoc $2)) }++        | hpc_annot exp        {% ams (sLL $1 $> $ HsTickPragma (snd $ fst $ fst $ unLoc $1)+                                                                (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)+                                      (fst $ fst $ fst $ unLoc $1) }++        | 'proc' aexp '->' exp+                       {% checkPattern empty $2 >>= \ p ->+                           checkCommand $4 >>= \ cmd ->+                           ams (sLL $1 $> $ HsProc p (sLL $1 $> $ HsCmdTop cmd placeHolderType+                                                placeHolderType []))+                                            -- TODO: is LL right here?+                               [mj AnnProc $1,mu AnnRarrow $3] }++        | '{-# CORE' STRING '#-}' exp  {% ams (sLL $1 $> $ HsCoreAnn (getCORE_PRAGs $1) (getStringLiteral $2) $4)+                                              [mo $1,mj AnnVal $2+                                              ,mc $3] }+                                          -- hdaume: core annotation+        | fexp                         { $1 }++exp10 :: { LHsExpr RdrName }+        : exp10_top            { $1 }+        | scc_annot exp        {% ams (sLL $1 $> $ HsSCC (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)+                                      (fst $ fst $ unLoc $1) }++optSemi :: { ([Located a],Bool) }+        : ';'         { ([$1],True) }+        | {- empty -} { ([],False) }++scc_annot :: { Located (([AddAnn],SourceText),StringLiteral) }+        : '{-# SCC' STRING '#-}'      {% do scc <- getSCC $2+                                            ; return $ sLL $1 $>+                                               (([mo $1,mj AnnValStr $2+                                                ,mc $3],getSCC_PRAGs $1),(StringLiteral (getSTRINGs $2) scc)) }+        | '{-# SCC' VARID  '#-}'      { sLL $1 $> (([mo $1,mj AnnVal $2+                                         ,mc $3],getSCC_PRAGs $1)+                                        ,(StringLiteral NoSourceText (getVARID $2))) }++hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,Int))),+                         ((SourceText,SourceText),(SourceText,SourceText))+                       ) }+      : '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'+                                      { sLL $1 $> $ ((([mo $1,mj AnnVal $2+                                              ,mj AnnVal $3,mj AnnColon $4+                                              ,mj AnnVal $5,mj AnnMinus $6+                                              ,mj AnnVal $7,mj AnnColon $8+                                              ,mj AnnVal $9,mc $10],+                                                getGENERATED_PRAGs $1)+                                              ,((getStringLiteral $2)+                                               ,( fromInteger $ getINTEGER $3+                                                , fromInteger $ getINTEGER $5+                                                )+                                               ,( fromInteger $ getINTEGER $7+                                                , fromInteger $ getINTEGER $9+                                                )+                                               ))+                                             , (( getINTEGERs $3+                                                , getINTEGERs $5+                                                )+                                               ,( getINTEGERs $7+                                                , getINTEGERs $9+                                                )))+                                         }++fexp    :: { LHsExpr RdrName }+        : fexp aexp                  { sLL $1 $> $ HsApp $1 $2 }+        | fexp TYPEAPP atype         {% ams (sLL $1 $> $ HsAppType $1 (mkHsWildCardBndrs $3))+                                            [mj AnnAt $2] }+        | 'static' aexp              {% ams (sLL $1 $> $ HsStatic placeHolderNames $2)+                                            [mj AnnStatic $1] }+        | aexp                       { $1 }++aexp    :: { LHsExpr RdrName }+        : qvar '@' aexp         {% ams (sLL $1 $> $ EAsPat $1 $3) [mj AnnAt $2] }+            -- If you change the parsing, make sure to understand+            -- Note [Lexing type applications] in Lexer.x++        | '~' aexp              {% ams (sLL $1 $> $ ELazyPat $2) [mj AnnTilde $1] }+        | aexp1                 { $1 }++aexp1   :: { LHsExpr RdrName }+        : aexp1 '{' fbinds '}' {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4)+                                                                   (snd $3)+                                     ; _ <- ams (sLL $1 $> ()) (moc $2:mcc $4:(fst $3))+                                     ; checkRecordSyntax (sLL $1 $> r) }}+        | aexp2                { $1 }++aexp2   :: { LHsExpr RdrName }+        : qvar                          { sL1 $1 (HsVar   $! $1) }+        | qcon                          { sL1 $1 (HsVar   $! $1) }+        | ipvar                         { sL1 $1 (HsIPVar $! unLoc $1) }+        | overloaded_label              { sL1 $1 (HsOverLabel Nothing $! unLoc $1) }+        | literal                       { sL1 $1 (HsLit   $! unLoc $1) }+-- This will enable overloaded strings permanently.  Normally the renamer turns HsString+-- into HsOverLit when -foverloaded-strings is on.+--      | STRING    { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRINGs $1)+--                                       (getSTRING $1) placeHolderType) }+        | INTEGER   { sL (getLoc $1) (HsOverLit $! mkHsIntegral (getINTEGERs $1)+                                         (getINTEGER $1) placeHolderType) }+        | RATIONAL  { sL (getLoc $1) (HsOverLit $! mkHsFractional+                                          (getRATIONAL $1) placeHolderType) }++        -- N.B.: sections get parsed by these next two productions.+        -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't+        -- correct Haskell (you'd have to write '((+ 3), (4 -))')+        -- but the less cluttered version fell out of having texps.+        | '(' texp ')'                  {% ams (sLL $1 $> (HsPar $2)) [mop $1,mcp $3] }+        | '(' tup_exprs ')'             {% do { e <- mkSumOrTuple Boxed (comb2 $1 $3) (snd $2)+                                              ; ams (sLL $1 $> e) ((mop $1:fst $2) ++ [mcp $3]) } }++        | '(#' texp '#)'                {% ams (sLL $1 $> (ExplicitTuple [L (gl $2)+                                                         (Present $2)] Unboxed))+                                               [mo $1,mc $3] }+        | '(#' tup_exprs '#)'           {% do { e <- mkSumOrTuple Unboxed (comb2 $1 $3) (snd $2)+                                              ; ams (sLL $1 $> e) ((mo $1:fst $2) ++ [mc $3]) } }++        | '[' list ']'      {% ams (sLL $1 $> (snd $2)) (mos $1:mcs $3:(fst $2)) }+        | '[:' parr ':]'    {% ams (sLL $1 $> (snd $2)) (mo $1:mc $3:(fst $2)) }+        | '_'               { sL1 $1 EWildPat }++        -- Template Haskell Extension+        | splice_exp            { $1 }++        | SIMPLEQUOTE  qvar     {% ams (sLL $1 $> $ HsBracket (VarBr True  (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }+        | SIMPLEQUOTE  qcon     {% ams (sLL $1 $> $ HsBracket (VarBr True  (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }+        | TH_TY_QUOTE tyvar     {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }+        | TH_TY_QUOTE gtycon    {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }+        | '[|' exp '|]'       {% ams (sLL $1 $> $ HsBracket (ExpBr $2))+                                      (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3]+                                                    else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) }+        | '[||' exp '||]'     {% ams (sLL $1 $> $ HsBracket (TExpBr $2))+                                      (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) }+        | '[t|' ctype '|]'    {% ams (sLL $1 $> $ HsBracket (TypBr $2)) [mo $1,mu AnnCloseQ $3] }+        | '[p|' infixexp '|]' {% checkPattern empty $2 >>= \p ->+                                      ams (sLL $1 $> $ HsBracket (PatBr p))+                                          [mo $1,mu AnnCloseQ $3] }+        | '[d|' cvtopbody '|]' {% ams (sLL $1 $> $ HsBracket (DecBrL (snd $2)))+                                      (mo $1:mu AnnCloseQ $3:fst $2) }+        | quasiquote          { sL1 $1 (HsSpliceE (unLoc $1)) }++        -- arrow notation extension+        | '(|' aexp2 cmdargs '|)'  {% ams (sLL $1 $> $ HsArrForm $2+                                                           Nothing (reverse $3))+                                          [mu AnnOpenB $1,mu AnnCloseB $4] }++splice_exp :: { LHsExpr RdrName }+        : TH_ID_SPLICE          {% ams (sL1 $1 $ mkHsSpliceE HasDollar+                                        (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName+                                                           (getTH_ID_SPLICE $1)))))+                                       [mj AnnThIdSplice $1] }+        | '$(' exp ')'          {% ams (sLL $1 $> $ mkHsSpliceE HasParens $2)+                                       [mj AnnOpenPE $1,mj AnnCloseP $3] }+        | TH_ID_TY_SPLICE       {% ams (sL1 $1 $ mkHsSpliceTE HasDollar+                                        (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName+                                                        (getTH_ID_TY_SPLICE $1)))))+                                       [mj AnnThIdTySplice $1] }+        | '$$(' exp ')'         {% ams (sLL $1 $> $ mkHsSpliceTE HasParens $2)+                                       [mj AnnOpenPTE $1,mj AnnCloseP $3] }++cmdargs :: { [LHsCmdTop RdrName] }+        : cmdargs acmd                  { $2 : $1 }+        | {- empty -}                   { [] }++acmd    :: { LHsCmdTop RdrName }+        : aexp2                 {% checkCommand $1 >>= \ cmd ->+                                    return (sL1 $1 $ HsCmdTop cmd+                                           placeHolderType placeHolderType []) }++cvtopbody :: { ([AddAnn],[LHsDecl RdrName]) }+        :  '{'            cvtopdecls0 '}'      { ([mj AnnOpenC $1+                                                  ,mj AnnCloseC $3],$2) }+        |      vocurly    cvtopdecls0 close    { ([],$2) }++cvtopdecls0 :: { [LHsDecl RdrName] }+        : topdecls_semi         { cvTopDecls $1 }+        | topdecls              { cvTopDecls $1 }++-----------------------------------------------------------------------------+-- Tuple expressions++-- "texp" is short for tuple expressions:+-- things that can appear unparenthesized as long as they're+-- inside parens or delimitted by commas+texp :: { LHsExpr RdrName }+        : exp                           { $1 }++        -- Note [Parsing sections]+        -- ~~~~~~~~~~~~~~~~~~~~~~~+        -- We include left and right sections here, which isn't+        -- technically right according to the Haskell standard.+        -- For example (3 +, True) isn't legal.+        -- However, we want to parse bang patterns like+        --      (!x, !y)+        -- and it's convenient to do so here as a section+        -- Then when converting expr to pattern we unravel it again+        -- Meanwhile, the renamer checks that real sections appear+        -- inside parens.+        | infixexp qop        { sLL $1 $> $ SectionL $1 $2 }+        | qopm infixexp       { sLL $1 $> $ SectionR $1 $2 }++       -- View patterns get parenthesized above+        | exp '->' texp   {% ams (sLL $1 $> $ EViewPat $1 $3) [mu AnnRarrow $2] }++-- Always at least one comma or bar.+tup_exprs :: { ([AddAnn],SumOrTuple) }+           : texp commas_tup_tail+                          {% do { addAnnotation (gl $1) AnnComma (fst $2)+                                ; return ([],Tuple ((sL1 $1 (Present $1)) : snd $2)) } }++           | texp bars    { (mvbars (fst $2), Sum 1  (snd $2 + 1) $1) }++           | commas tup_tail+                {% do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst $1)+                      ; return+                           ([],Tuple (map (\l -> L l missingTupArg) (fst $1) ++ $2)) } }++           | bars texp bars0+                { (mvbars (fst $1) ++ mvbars (fst $3), Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2) }++-- Always starts with commas; always follows an expr+commas_tup_tail :: { (SrcSpan,[LHsTupArg RdrName]) }+commas_tup_tail : commas tup_tail+       {% do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst $1)+             ; return (+            (head $ fst $1+            ,(map (\l -> L l missingTupArg) (tail $ fst $1)) ++ $2)) } }++-- Always follows a comma+tup_tail :: { [LHsTupArg RdrName] }+          : texp commas_tup_tail {% addAnnotation (gl $1) AnnComma (fst $2) >>+                                    return ((L (gl $1) (Present $1)) : snd $2) }+          | texp                 { [L (gl $1) (Present $1)] }+          | {- empty -}          { [noLoc missingTupArg] }++-----------------------------------------------------------------------------+-- List expressions++-- The rules below are little bit contorted to keep lexps left-recursive while+-- avoiding another shift/reduce-conflict.+list :: { ([AddAnn],HsExpr RdrName) }+        : texp    { ([],ExplicitList placeHolderType Nothing [$1]) }+        | lexps   { ([],ExplicitList placeHolderType Nothing+                                                   (reverse (unLoc $1))) }+        | texp '..'             { ([mj AnnDotdot $2],+                                      ArithSeq noPostTcExpr Nothing (From $1)) }+        | texp ',' exp '..'     { ([mj AnnComma $2,mj AnnDotdot $4],+                                  ArithSeq noPostTcExpr Nothing+                                                             (FromThen $1 $3)) }+        | texp '..' exp         { ([mj AnnDotdot $2],+                                   ArithSeq noPostTcExpr Nothing+                                                               (FromTo $1 $3)) }+        | texp ',' exp '..' exp { ([mj AnnComma $2,mj AnnDotdot $4],+                                    ArithSeq noPostTcExpr Nothing+                                                (FromThenTo $1 $3 $5)) }+        | texp '|' flattenedpquals+             {% checkMonadComp >>= \ ctxt ->+                return ([mj AnnVbar $2],+                        mkHsComp ctxt (unLoc $3) $1) }++lexps :: { Located [LHsExpr RdrName] }+        : lexps ',' texp          {% addAnnotation (gl $ head $ unLoc $1)+                                                            AnnComma (gl $2) >>+                                      return (sLL $1 $> (((:) $! $3) $! unLoc $1)) }+        | texp ',' texp            {% addAnnotation (gl $1) AnnComma (gl $2) >>+                                      return (sLL $1 $> [$3,$1]) }++-----------------------------------------------------------------------------+-- List Comprehensions++flattenedpquals :: { Located [LStmt RdrName (LHsExpr RdrName)] }+    : pquals   { case (unLoc $1) of+                    [qs] -> sL1 $1 qs+                    -- We just had one thing in our "parallel" list so+                    -- we simply return that thing directly++                    qss -> sL1 $1 [sL1 $1 $ ParStmt [ParStmtBlock qs [] noSyntaxExpr |+                                            qs <- qss]+                                            noExpr noSyntaxExpr placeHolderType]+                    -- We actually found some actual parallel lists so+                    -- we wrap them into as a ParStmt+                }++pquals :: { Located [[LStmt RdrName (LHsExpr RdrName)]] }+    : squals '|' pquals+                     {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $2) >>+                        return (sLL $1 $> (reverse (unLoc $1) : unLoc $3)) }+    | squals         { L (getLoc $1) [reverse (unLoc $1)] }++squals :: { Located [LStmt RdrName (LHsExpr RdrName)] }   -- In reverse order, because the last+                                        -- one can "grab" the earlier ones+    : squals ',' transformqual+             {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >>+                ams (sLL $1 $> ()) (fst $ unLoc $3) >>+                return (sLL $1 $> [sLL $1 $> ((snd $ unLoc $3) (reverse (unLoc $1)))]) }+    | squals ',' qual+             {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >>+                return (sLL $1 $> ($3 : unLoc $1)) }+    | transformqual        {% ams $1 (fst $ unLoc $1) >>+                              return (sLL $1 $> [L (getLoc $1) ((snd $ unLoc $1) [])]) }+    | qual                                { sL1 $1 [$1] }+--  | transformquals1 ',' '{|' pquals '|}'   { sLL $1 $> ($4 : unLoc $1) }+--  | '{|' pquals '|}'                       { sL1 $1 [$2] }++-- It is possible to enable bracketing (associating) qualifier lists+-- by uncommenting the lines with {| |} above. Due to a lack of+-- consensus on the syntax, this feature is not being used until we+-- get user demand.++transformqual :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)] -> Stmt RdrName (LHsExpr RdrName)) }+                        -- Function is applied to a list of stmts *in order*+    : 'then' exp               { sLL $1 $> ([mj AnnThen $1], \ss -> (mkTransformStmt ss $2)) }+    | 'then' exp 'by' exp      { sLL $1 $> ([mj AnnThen $1,mj AnnBy  $3],\ss -> (mkTransformByStmt ss $2 $4)) }+    | 'then' 'group' 'using' exp+             { sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3], \ss -> (mkGroupUsingStmt ss $4)) }++    | 'then' 'group' 'by' exp 'using' exp+             { sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5], \ss -> (mkGroupByUsingStmt ss $4 $6)) }++-- Note that 'group' is a special_id, which means that you can enable+-- TransformListComp while still using Data.List.group. However, this+-- introduces a shift/reduce conflict. Happy chooses to resolve the conflict+-- in by choosing the "group by" variant, which is what we want.++-----------------------------------------------------------------------------+-- Parallel array expressions++-- The rules below are little bit contorted; see the list case for details.+-- Note that, in contrast to lists, we only have finite arithmetic sequences.+-- Moreover, we allow explicit arrays with no element (represented by the nil+-- constructor in the list case).++parr :: { ([AddAnn],HsExpr RdrName) }+        :                      { ([],ExplicitPArr placeHolderType []) }+        | texp                 { ([],ExplicitPArr placeHolderType [$1]) }+        | lexps                { ([],ExplicitPArr placeHolderType+                                                          (reverse (unLoc $1))) }+        | texp '..' exp        { ([mj AnnDotdot $2]+                                 ,PArrSeq noPostTcExpr (FromTo $1 $3)) }+        | texp ',' exp '..' exp+                        { ([mj AnnComma $2,mj AnnDotdot $4]+                          ,PArrSeq noPostTcExpr (FromThenTo $1 $3 $5)) }+        | texp '|' flattenedpquals+                        { ([mj AnnVbar $2],mkHsComp PArrComp (unLoc $3) $1) }++-- We are reusing `lexps' and `flattenedpquals' from the list case.++-----------------------------------------------------------------------------+-- Guards++guardquals :: { Located [LStmt RdrName (LHsExpr RdrName)] }+    : guardquals1           { L (getLoc $1) (reverse (unLoc $1)) }++guardquals1 :: { Located [LStmt RdrName (LHsExpr RdrName)] }+    : guardquals1 ',' qual  {% addAnnotation (gl $ head $ unLoc $1) AnnComma+                                             (gl $2) >>+                               return (sLL $1 $> ($3 : unLoc $1)) }+    | qual                  { sL1 $1 [$1] }++-----------------------------------------------------------------------------+-- Case alternatives++altslist :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) }+        : '{'            alts '}'  { sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2))+                                               ,(reverse (snd $ unLoc $2))) }+        |     vocurly    alts  close { L (getLoc $2) (fst $ unLoc $2+                                        ,(reverse (snd $ unLoc $2))) }+        | '{'                 '}'    { noLoc ([moc $1,mcc $2],[]) }+        |     vocurly          close { noLoc ([],[]) }++alts    :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) }+        : alts1                    { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }+        | ';' alts                 { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2))+                                               ,snd $ unLoc $2) }++alts1   :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) }+        : alts1 ';' alt         {% if null (snd $ unLoc $1)+                                     then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)+                                                  ,[$3]))+                                     else (ams (head $ snd $ unLoc $1)+                                               (mj AnnSemi $2:(fst $ unLoc $1))+                                           >> return (sLL $1 $> ([],$3 : (snd $ unLoc $1))) ) }+        | alts1 ';'             {% if null (snd $ unLoc $1)+                                     then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)+                                                  ,snd $ unLoc $1))+                                     else (ams (head $ snd $ unLoc $1)+                                               (mj AnnSemi $2:(fst $ unLoc $1))+                                           >> return (sLL $1 $> ([],snd $ unLoc $1))) }+        | alt                   { sL1 $1 ([],[$1]) }++alt     :: { LMatch RdrName (LHsExpr RdrName) }+        : pat opt_asig alt_rhs  {%ams (sLL $1 $> (Match { m_ctxt = CaseAlt+                                                        , m_pats = [$1]+                                                        , m_type = snd $2+                                                        , m_grhss = snd $ unLoc $3 }))+                                      (fst $2 ++ (fst $ unLoc $3))}++alt_rhs :: { Located ([AddAnn],GRHSs RdrName (LHsExpr RdrName)) }+        : ralt wherebinds           { sLL $1 $> (fst $ unLoc $2,+                                            GRHSs (unLoc $1) (snd $ unLoc $2)) }++ralt :: { Located [LGRHS RdrName (LHsExpr RdrName)] }+        : '->' exp            {% ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) $2))+                                     [mu AnnRarrow $1] }+        | gdpats              { sL1 $1 (reverse (unLoc $1)) }++gdpats :: { Located [LGRHS RdrName (LHsExpr RdrName)] }+        : gdpats gdpat                  { sLL $1 $> ($2 : unLoc $1) }+        | gdpat                         { sL1 $1 [$1] }++-- layout for MultiWayIf doesn't begin with an open brace, because it's hard to+-- generate the open brace in addition to the vertical bar in the lexer, and+-- we don't need it.+ifgdpats :: { Located ([AddAnn],[LGRHS RdrName (LHsExpr RdrName)]) }+         : '{' gdpats '}'                 { sLL $1 $> ([moc $1,mcc $3],unLoc $2)  }+         |     gdpats close               { sL1 $1 ([],unLoc $1) }++gdpat   :: { LGRHS RdrName (LHsExpr RdrName) }+        : '|' guardquals '->' exp+                                  {% ams (sL (comb2 $1 $>) $ GRHS (unLoc $2) $4)+                                         [mj AnnVbar $1,mu AnnRarrow $3] }++-- 'pat' recognises a pattern, including one with a bang at the top+--      e.g.  "!x" or "!(x,y)" or "C a b" etc+-- Bangs inside are parsed as infix operator applications, so that+-- we parse them right when bang-patterns are off+pat     :: { LPat RdrName }+pat     :  exp          {% checkPattern empty $1 }+        | '!' aexp      {% amms (checkPattern empty (sLL $1 $> (SectionR+                                                     (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)))+                                [mj AnnBang $1] }++bindpat :: { LPat RdrName }+bindpat :  exp            {% checkPattern+                                (text "Possibly caused by a missing 'do'?") $1 }+        | '!' aexp        {% amms (checkPattern+                                     (text "Possibly caused by a missing 'do'?")+                                     (sLL $1 $> (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)))+                                  [mj AnnBang $1] }++apat   :: { LPat RdrName }+apat    : aexp                  {% checkPattern empty $1 }+        | '!' aexp              {% amms (checkPattern empty+                                            (sLL $1 $> (SectionR+                                                (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)))+                                        [mj AnnBang $1] }++apats  :: { [LPat RdrName] }+        : apat apats            { $1 : $2 }+        | {- empty -}           { [] }++-----------------------------------------------------------------------------+-- Statement sequences++stmtlist :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) }+        : '{'           stmts '}'       { sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2))+                                             ,(reverse $ snd $ unLoc $2)) } -- AZ:performance of reverse?+        |     vocurly   stmts close     { L (gl $2) (fst $ unLoc $2+                                                    ,reverse $ snd $ unLoc $2) }++--      do { ;; s ; s ; ; s ;; }+-- The last Stmt should be an expression, but that's hard to enforce+-- here, because we need too much lookahead if we see do { e ; }+-- So we use BodyStmts throughout, and switch the last one over+-- in ParseUtils.checkDo instead++stmts :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) }+        : stmts ';' stmt  {% if null (snd $ unLoc $1)+                              then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)+                                                     ,$3 : (snd $ unLoc $1)))+                              else do+                               { ams (head $ snd $ unLoc $1) [mj AnnSemi $2]+                               ; return $ sLL $1 $> (fst $ unLoc $1,$3 :(snd $ unLoc $1)) }}++        | stmts ';'     {% if null (snd $ unLoc $1)+                             then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1),snd $ unLoc $1))+                             else do+                               { ams (head $ snd $ unLoc $1)+                                               [mj AnnSemi $2]+                               ; return $1 } }+        | stmt                   { sL1 $1 ([],[$1]) }+        | {- empty -}            { noLoc ([],[]) }+++-- For typing stmts at the GHCi prompt, where+-- the input may consist of just comments.+maybe_stmt :: { Maybe (LStmt RdrName (LHsExpr RdrName)) }+        : stmt                          { Just $1 }+        | {- nothing -}                 { Nothing }++stmt  :: { LStmt RdrName (LHsExpr RdrName) }+        : qual                          { $1 }+        | 'rec' stmtlist                {% ams (sLL $1 $> $ mkRecStmt (snd $ unLoc $2))+                                               (mj AnnRec $1:(fst $ unLoc $2)) }++qual  :: { LStmt RdrName (LHsExpr RdrName) }+    : bindpat '<-' exp                  {% ams (sLL $1 $> $ mkBindStmt $1 $3)+                                               [mu AnnLarrow $2] }+    | exp                               { sL1 $1 $ mkBodyStmt $1 }+    | 'let' binds                       {% ams (sLL $1 $>$ LetStmt (snd $ unLoc $2))+                                               (mj AnnLet $1:(fst $ unLoc $2)) }++-----------------------------------------------------------------------------+-- Record Field Update/Construction++fbinds  :: { ([AddAnn],([LHsRecField RdrName (LHsExpr RdrName)], Bool)) }+        : fbinds1                       { $1 }+        | {- empty -}                   { ([],([], False)) }++fbinds1 :: { ([AddAnn],([LHsRecField RdrName (LHsExpr RdrName)], Bool)) }+        : fbind ',' fbinds1+                {% addAnnotation (gl $1) AnnComma (gl $2) >>+                   return (case $3 of (ma,(flds, dd)) -> (ma,($1 : flds, dd))) }+        | fbind                         { ([],([$1], False)) }+        | '..'                          { ([mj AnnDotdot $1],([],   True)) }++fbind   :: { LHsRecField RdrName (LHsExpr RdrName) }+        : qvar '=' texp {% ams  (sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) $3 False)+                                [mj AnnEqual $2] }+                        -- RHS is a 'texp', allowing view patterns (Trac #6038)+                        -- and, incidentally, sections.  Eg+                        -- f (R { x = show -> s }) = ...++        | qvar          { sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) placeHolderPunRhs True }+                        -- In the punning case, use a place-holder+                        -- The renamer fills in the final value++-----------------------------------------------------------------------------+-- Implicit Parameter Bindings++dbinds  :: { Located [LIPBind RdrName] }+        : dbinds ';' dbind+                      {% addAnnotation (gl $ last $ unLoc $1) AnnSemi (gl $2) >>+                         return (let { this = $3; rest = unLoc $1 }+                              in rest `seq` this `seq` sLL $1 $> (this : rest)) }+        | dbinds ';'  {% addAnnotation (gl $ last $ unLoc $1) AnnSemi (gl $2) >>+                         return (sLL $1 $> (unLoc $1)) }+        | dbind                        { let this = $1 in this `seq` sL1 $1 [this] }+--      | {- empty -}                  { [] }++dbind   :: { LIPBind RdrName }+dbind   : ipvar '=' exp                {% ams (sLL $1 $> (IPBind (Left $1) $3))+                                              [mj AnnEqual $2] }++ipvar   :: { Located HsIPName }+        : IPDUPVARID            { sL1 $1 (HsIPName (getIPDUPVARID $1)) }++-----------------------------------------------------------------------------+-- Overloaded labels++overloaded_label :: { Located FastString }+        : LABELVARID          { sL1 $1 (getLABELVARID $1) }++-----------------------------------------------------------------------------+-- Warnings and deprecations++name_boolformula_opt :: { LBooleanFormula (Located RdrName) }+        : name_boolformula          { $1 }+        | {- empty -}               { noLoc mkTrue }++name_boolformula :: { LBooleanFormula (Located RdrName) }+        : name_boolformula_and                      { $1 }+        | name_boolformula_and '|' name_boolformula+                           {% aa $1 (AnnVbar, $2)+                              >> return (sLL $1 $> (Or [$1,$3])) }++name_boolformula_and :: { LBooleanFormula (Located RdrName) }+        : name_boolformula_and_list+                  { sLL (head $1) (last $1) (And ($1)) }++name_boolformula_and_list :: { [LBooleanFormula (Located RdrName)] }+        : name_boolformula_atom                               { [$1] }+        | name_boolformula_atom ',' name_boolformula_and_list+            {% aa $1 (AnnComma, $2) >> return ($1 : $3) }++name_boolformula_atom :: { LBooleanFormula (Located RdrName) }+        : '(' name_boolformula ')'  {% ams (sLL $1 $> (Parens $2)) [mop $1,mcp $3] }+        | name_var                  { sL1 $1 (Var $1) }++namelist :: { Located [Located RdrName] }+namelist : name_var              { sL1 $1 [$1] }+         | name_var ',' namelist {% addAnnotation (gl $1) AnnComma (gl $2) >>+                                    return (sLL $1 $> ($1 : unLoc $3)) }++name_var :: { Located RdrName }+name_var : var { $1 }+         | con { $1 }++-----------------------------------------+-- Data constructors+-- There are two different productions here as lifted list constructors+-- are parsed differently.++qcon_nowiredlist :: { Located RdrName }+        : gen_qcon                     { $1 }+        | sysdcon_nolist               { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) }++qcon :: { Located RdrName }+  : gen_qcon              { $1}+  | sysdcon               { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) }++gen_qcon :: { Located RdrName }+  : qconid                { $1 }+  | '(' qconsym ')'       {% ams (sLL $1 $> (unLoc $2))+                                   [mop $1,mj AnnVal $2,mcp $3] }++-- The case of '[:' ':]' is part of the production `parr'++con     :: { Located RdrName }+        : conid                 { $1 }+        | '(' consym ')'        {% ams (sLL $1 $> (unLoc $2))+                                       [mop $1,mj AnnVal $2,mcp $3] }+        | sysdcon               { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) }++con_list :: { Located [Located RdrName] }+con_list : con                  { sL1 $1 [$1] }+         | con ',' con_list     {% addAnnotation (gl $1) AnnComma (gl $2) >>+                                   return (sLL $1 $> ($1 : unLoc $3)) }++sysdcon_nolist :: { Located DataCon }  -- Wired in data constructors+        : '(' ')'               {% ams (sLL $1 $> unitDataCon) [mop $1,mcp $2] }+        | '(' commas ')'        {% ams (sLL $1 $> $ tupleDataCon Boxed (snd $2 + 1))+                                       (mop $1:mcp $3:(mcommas (fst $2))) }+        | '(#' '#)'             {% ams (sLL $1 $> $ unboxedUnitDataCon) [mo $1,mc $2] }+        | '(#' commas '#)'      {% ams (sLL $1 $> $ tupleDataCon Unboxed (snd $2 + 1))+                                       (mo $1:mc $3:(mcommas (fst $2))) }++sysdcon :: { Located DataCon }+        : sysdcon_nolist                 { $1 }+        | '[' ']'               {% ams (sLL $1 $> nilDataCon) [mos $1,mcs $2] }++conop :: { Located RdrName }+        : consym                { $1 }+        | '`' conid '`'         {% ams (sLL $1 $> (unLoc $2))+                                       [mj AnnBackquote $1,mj AnnVal $2+                                       ,mj AnnBackquote $3] }++qconop :: { Located RdrName }+        : qconsym               { $1 }+        | '`' qconid '`'        {% ams (sLL $1 $> (unLoc $2))+                                       [mj AnnBackquote $1,mj AnnVal $2+                                       ,mj AnnBackquote $3] }++----------------------------------------------------------------------------+-- Type constructors+++-- See Note [Unit tuples] in HsTypes for the distinction+-- between gtycon and ntgtycon+gtycon :: { Located RdrName }  -- A "general" qualified tycon, including unit tuples+        : ntgtycon                     { $1 }+        | '(' ')'                      {% ams (sLL $1 $> $ getRdrName unitTyCon)+                                              [mop $1,mcp $2] }+        | '(#' '#)'                    {% ams (sLL $1 $> $ getRdrName unboxedUnitTyCon)+                                              [mo $1,mc $2] }++ntgtycon :: { Located RdrName }  -- A "general" qualified tycon, excluding unit tuples+        : oqtycon               { $1 }+        | '(' commas ')'        {% ams (sLL $1 $> $ getRdrName (tupleTyCon Boxed+                                                        (snd $2 + 1)))+                                       (mop $1:mcp $3:(mcommas (fst $2))) }+        | '(#' commas '#)'      {% ams (sLL $1 $> $ getRdrName (tupleTyCon Unboxed+                                                        (snd $2 + 1)))+                                       (mo $1:mc $3:(mcommas (fst $2))) }+        | '(' '->' ')'          {% ams (sLL $1 $> $ getRdrName funTyCon)+                                       [mop $1,mu AnnRarrow $2,mcp $3] }+        | '[' ']'               {% ams (sLL $1 $> $ listTyCon_RDR) [mos $1,mcs $2] }+        | '[:' ':]'             {% ams (sLL $1 $> $ parrTyCon_RDR) [mo $1,mc $2] }+        | '(' '~#' ')'          {% ams (sLL $1 $> $ getRdrName eqPrimTyCon)+                                        [mop $1,mj AnnTildehsh $2,mcp $3] }++oqtycon :: { Located RdrName }  -- An "ordinary" qualified tycon;+                                -- These can appear in export lists+        : qtycon                        { $1 }+        | '(' qtyconsym ')'             {% ams (sLL $1 $> (unLoc $2))+                                               [mop $1,mj AnnVal $2,mcp $3] }+        | '(' '~' ')'                   {% ams (sLL $1 $> $ eqTyCon_RDR)+                                               [mop $1,mj AnnVal $2,mcp $3] }++oqtycon_no_varcon :: { Located RdrName }  -- Type constructor which cannot be mistaken+                                          -- for variable constructor in export lists+                                          -- see Note [Type constructors in export list]+        :  qtycon            { $1 }+        | '(' QCONSYM ')'    {% let name = sL1 $2 $! mkQual tcClsName (getQCONSYM $2)+                                in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] }+        | '(' CONSYM ')'     {% let name = sL1 $2 $! mkUnqual tcClsName (getCONSYM $2)+                                in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] }+        | '(' ':' ')'        {% let name = sL1 $2 $! consDataCon_RDR+                                in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] }+        | '(' '~' ')'        {% ams (sLL $1 $> $ eqTyCon_RDR) [mop $1,mj AnnTilde $2,mcp $3] }++{- Note [Type constructors in export list]+~~~~~~~~~~~~~~~~~~~~~+Mixing type constructors and data constructors in export lists introduces+ambiguity in grammar: e.g. (*) may be both a type constructor and a function.++-XExplicitNamespaces allows to disambiguate by explicitly prefixing type+constructors with 'type' keyword.++This ambiguity causes reduce/reduce conflicts in parser, which are always+resolved in favour of data constructors. To get rid of conflicts we demand+that ambiguous type constructors (those, which are formed by the same+productions as variable constructors) are always prefixed with 'type' keyword.+Unambiguous type constructors may occur both with or without 'type' keyword.++Note that in the parser we still parse data constructors as type+constructors. As such, they still end up in the type constructor namespace+until after renaming when we resolve the proper namespace for each exported+child.+-}++qtyconop :: { Located RdrName } -- Qualified or unqualified+        : qtyconsym                     { $1 }+        | '`' qtycon '`'                {% ams (sLL $1 $> (unLoc $2))+                                               [mj AnnBackquote $1,mj AnnVal $2+                                               ,mj AnnBackquote $3] }++qtycon :: { Located RdrName }   -- Qualified or unqualified+        : QCONID            { sL1 $1 $! mkQual tcClsName (getQCONID $1) }+        | tycon             { $1 }++qtycondoc :: { LHsType RdrName } -- Qualified or unqualified+        : qtycon            { sL1 $1                     (HsTyVar NotPromoted $1)      }+        | qtycon docprev    { sLL $1 $> (HsDocTy (sL1 $1 (HsTyVar NotPromoted $1)) $2) }++tycon   :: { Located RdrName }  -- Unqualified+        : CONID                   { sL1 $1 $! mkUnqual tcClsName (getCONID $1) }++qtyconsym :: { Located RdrName }+        : QCONSYM            { sL1 $1 $! mkQual tcClsName (getQCONSYM $1) }+        | QVARSYM            { sL1 $1 $! mkQual tcClsName (getQVARSYM $1) }+        | tyconsym           { $1 }++-- Does not include "!", because that is used for strictness marks+--               or ".", because that separates the quantified type vars from the rest+tyconsym :: { Located RdrName }+        : CONSYM                { sL1 $1 $! mkUnqual tcClsName (getCONSYM $1) }+        | VARSYM                { sL1 $1 $! mkUnqual tcClsName (getVARSYM $1) }+        | ':'                   { sL1 $1 $! consDataCon_RDR }+        | '-'                   { sL1 $1 $! mkUnqual tcClsName (fsLit "-") }+++-----------------------------------------------------------------------------+-- Operators++op      :: { Located RdrName }   -- used in infix decls+        : varop                 { $1 }+        | conop                 { $1 }++varop   :: { Located RdrName }+        : varsym                { $1 }+        | '`' varid '`'         {% ams (sLL $1 $> (unLoc $2))+                                       [mj AnnBackquote $1,mj AnnVal $2+                                       ,mj AnnBackquote $3] }++qop     :: { LHsExpr RdrName }   -- used in sections+        : qvarop                { sL1 $1 $ HsVar $1 }+        | qconop                { sL1 $1 $ HsVar $1 }+        | '`' '_' '`'           {% ams (sLL $1 $> EWildPat)+                                       [mj AnnBackquote $1,mj AnnVal $2+                                       ,mj AnnBackquote $3] }++qopm    :: { LHsExpr RdrName }   -- used in sections+        : qvaropm               { sL1 $1 $ HsVar $1 }+        | qconop                { sL1 $1 $ HsVar $1 }++qvarop :: { Located RdrName }+        : qvarsym               { $1 }+        | '`' qvarid '`'        {% ams (sLL $1 $> (unLoc $2))+                                       [mj AnnBackquote $1,mj AnnVal $2+                                       ,mj AnnBackquote $3] }++qvaropm :: { Located RdrName }+        : qvarsym_no_minus      { $1 }+        | '`' qvarid '`'        {% ams (sLL $1 $> (unLoc $2))+                                       [mj AnnBackquote $1,mj AnnVal $2+                                       ,mj AnnBackquote $3] }++-----------------------------------------------------------------------------+-- Type variables++tyvar   :: { Located RdrName }+tyvar   : tyvarid               { $1 }++tyvarop :: { Located RdrName }+tyvarop : '`' tyvarid '`'       {% ams (sLL $1 $> (unLoc $2))+                                       [mj AnnBackquote $1,mj AnnVal $2+                                       ,mj AnnBackquote $3] }+        | '.'                   {% hintExplicitForall' (getLoc $1) }++tyvarid :: { Located RdrName }+        : VARID            { sL1 $1 $! mkUnqual tvName (getVARID $1) }+        | special_id       { sL1 $1 $! mkUnqual tvName (unLoc $1) }+        | 'unsafe'         { sL1 $1 $! mkUnqual tvName (fsLit "unsafe") }+        | 'safe'           { sL1 $1 $! mkUnqual tvName (fsLit "safe") }+        | 'interruptible'  { sL1 $1 $! mkUnqual tvName (fsLit "interruptible") }++-----------------------------------------------------------------------------+-- Variables++var     :: { Located RdrName }+        : varid                 { $1 }+        | '(' varsym ')'        {% ams (sLL $1 $> (unLoc $2))+                                       [mop $1,mj AnnVal $2,mcp $3] }++ -- Lexing type applications depends subtly on what characters can possibly+ -- end a qvar. Currently (June 2015), only $idchars and ")" can end a qvar.+ -- If you're changing this, please see Note [Lexing type applications] in+ -- Lexer.x.+qvar    :: { Located RdrName }+        : qvarid                { $1 }+        | '(' varsym ')'        {% ams (sLL $1 $> (unLoc $2))+                                       [mop $1,mj AnnVal $2,mcp $3] }+        | '(' qvarsym1 ')'      {% ams (sLL $1 $> (unLoc $2))+                                       [mop $1,mj AnnVal $2,mcp $3] }+-- We've inlined qvarsym here so that the decision about+-- whether it's a qvar or a var can be postponed until+-- *after* we see the close paren.++qvarid :: { Located RdrName }+        : varid               { $1 }+        | QVARID              { sL1 $1 $! mkQual varName (getQVARID $1) }++-- Note that 'role' and 'family' get lexed separately regardless of+-- the use of extensions. However, because they are listed here,+-- this is OK and they can be used as normal varids.+-- See Note [Lexing type pseudo-keywords] in Lexer.x+varid :: { Located RdrName }+        : VARID            { sL1 $1 $! mkUnqual varName (getVARID $1) }+        | special_id       { sL1 $1 $! mkUnqual varName (unLoc $1) }+        | 'unsafe'         { sL1 $1 $! mkUnqual varName (fsLit "unsafe") }+        | 'safe'           { sL1 $1 $! mkUnqual varName (fsLit "safe") }+        | 'interruptible'  { sL1 $1 $! mkUnqual varName (fsLit "interruptible")}+        | 'forall'         { sL1 $1 $! mkUnqual varName (fsLit "forall") }+        | 'family'         { sL1 $1 $! mkUnqual varName (fsLit "family") }+        | 'role'           { sL1 $1 $! mkUnqual varName (fsLit "role") }++qvarsym :: { Located RdrName }+        : varsym                { $1 }+        | qvarsym1              { $1 }++qvarsym_no_minus :: { Located RdrName }+        : varsym_no_minus       { $1 }+        | qvarsym1              { $1 }++qvarsym1 :: { Located RdrName }+qvarsym1 : QVARSYM              { sL1 $1 $ mkQual varName (getQVARSYM $1) }++varsym :: { Located RdrName }+        : varsym_no_minus       { $1 }+        | '-'                   { sL1 $1 $ mkUnqual varName (fsLit "-") }++varsym_no_minus :: { Located RdrName } -- varsym not including '-'+        : VARSYM               { sL1 $1 $ mkUnqual varName (getVARSYM $1) }+        | special_sym          { sL1 $1 $ mkUnqual varName (unLoc $1) }+++-- These special_ids are treated as keywords in various places,+-- but as ordinary ids elsewhere.   'special_id' collects all these+-- except 'unsafe', 'interruptible', 'forall', 'family', 'role', 'stock', and+-- 'anyclass', whose treatment differs depending on context+special_id :: { Located FastString }+special_id+        : 'as'                  { sL1 $1 (fsLit "as") }+        | 'qualified'           { sL1 $1 (fsLit "qualified") }+        | 'hiding'              { sL1 $1 (fsLit "hiding") }+        | 'export'              { sL1 $1 (fsLit "export") }+        | 'label'               { sL1 $1 (fsLit "label")  }+        | 'dynamic'             { sL1 $1 (fsLit "dynamic") }+        | 'stdcall'             { sL1 $1 (fsLit "stdcall") }+        | 'ccall'               { sL1 $1 (fsLit "ccall") }+        | 'capi'                { sL1 $1 (fsLit "capi") }+        | 'prim'                { sL1 $1 (fsLit "prim") }+        | 'javascript'          { sL1 $1 (fsLit "javascript") }+        | 'group'               { sL1 $1 (fsLit "group") }+        | 'stock'               { sL1 $1 (fsLit "stock") }+        | 'anyclass'            { sL1 $1 (fsLit "anyclass") }+        | 'unit'                { sL1 $1 (fsLit "unit") }+        | 'dependency'          { sL1 $1 (fsLit "dependency") }+        | 'signature'           { sL1 $1 (fsLit "signature") }++special_sym :: { Located FastString }+special_sym : '!'       {% ams (sL1 $1 (fsLit "!")) [mj AnnBang $1] }+            | '.'       { sL1 $1 (fsLit ".") }++-----------------------------------------------------------------------------+-- Data constructors++qconid :: { Located RdrName }   -- Qualified or unqualified+        : conid              { $1 }+        | QCONID             { sL1 $1 $! mkQual dataName (getQCONID $1) }++conid   :: { Located RdrName }+        : CONID                { sL1 $1 $ mkUnqual dataName (getCONID $1) }++qconsym :: { Located RdrName }  -- Qualified or unqualified+        : consym               { $1 }+        | QCONSYM              { sL1 $1 $ mkQual dataName (getQCONSYM $1) }++consym :: { Located RdrName }+        : CONSYM              { sL1 $1 $ mkUnqual dataName (getCONSYM $1) }++        -- ':' means only list cons+        | ':'                { sL1 $1 $ consDataCon_RDR }+++-----------------------------------------------------------------------------+-- Literals++literal :: { Located HsLit }+        : CHAR              { sL1 $1 $ HsChar       (getCHARs $1) $ getCHAR $1 }+        | STRING            { sL1 $1 $ HsString     (getSTRINGs $1)+                                                   $ getSTRING $1 }+        | PRIMINTEGER       { sL1 $1 $ HsIntPrim    (getPRIMINTEGERs $1)+                                                   $ getPRIMINTEGER $1 }+        | PRIMWORD          { sL1 $1 $ HsWordPrim   (getPRIMWORDs $1)+                                                   $ getPRIMWORD $1 }+        | PRIMCHAR          { sL1 $1 $ HsCharPrim   (getPRIMCHARs $1)+                                                   $ getPRIMCHAR $1 }+        | PRIMSTRING        { sL1 $1 $ HsStringPrim (getPRIMSTRINGs $1)+                                                   $ getPRIMSTRING $1 }+        | PRIMFLOAT         { sL1 $1 $ HsFloatPrim  $ getPRIMFLOAT $1 }+        | PRIMDOUBLE        { sL1 $1 $ HsDoublePrim $ getPRIMDOUBLE $1 }++-----------------------------------------------------------------------------+-- Layout++close :: { () }+        : vccurly               { () } -- context popped in lexer.+        | error                 {% popContext }++-----------------------------------------------------------------------------+-- Miscellaneous (mostly renamings)++modid   :: { Located ModuleName }+        : CONID                 { sL1 $1 $ mkModuleNameFS (getCONID $1) }+        | QCONID                { sL1 $1 $ let (mod,c) = getQCONID $1 in+                                  mkModuleNameFS+                                   (mkFastString+                                     (unpackFS mod ++ '.':unpackFS c))+                                }++commas :: { ([SrcSpan],Int) }   -- One or more commas+        : commas ','             { ((fst $1)++[gl $2],snd $1 + 1) }+        | ','                    { ([gl $1],1) }++bars0 :: { ([SrcSpan],Int) }     -- Zero or more bars+        : bars                   { $1 }+        |                        { ([], 0) }++bars :: { ([SrcSpan],Int) }     -- One or more bars+        : bars '|'               { ((fst $1)++[gl $2],snd $1 + 1) }+        | '|'                    { ([gl $1],1) }++-----------------------------------------------------------------------------+-- Documentation comments++docnext :: { LHsDocString }+  : DOCNEXT {% return (sL1 $1 (HsDocString (mkFastString (getDOCNEXT $1)))) }++docprev :: { LHsDocString }+  : DOCPREV {% return (sL1 $1 (HsDocString (mkFastString (getDOCPREV $1)))) }++docnamed :: { Located (String, HsDocString) }+  : DOCNAMED {%+      let string = getDOCNAMED $1+          (name, rest) = break isSpace string+      in return (sL1 $1 (name, HsDocString (mkFastString rest))) }++docsection :: { Located (Int, HsDocString) }+  : DOCSECTION {% let (n, doc) = getDOCSECTION $1 in+        return (sL1 $1 (n, HsDocString (mkFastString doc))) }++moduleheader :: { Maybe LHsDocString }+        : DOCNEXT {% let string = getDOCNEXT $1 in+                     return (Just (sL1 $1 (HsDocString (mkFastString string)))) }++maybe_docprev :: { Maybe LHsDocString }+        : docprev                       { Just $1 }+        | {- empty -}                   { Nothing }++maybe_docnext :: { Maybe LHsDocString }+        : docnext                       { Just $1 }+        | {- empty -}                   { Nothing }++{+happyError :: P a+happyError = srcParseFail++getVARID        (L _ (ITvarid    x)) = x+getCONID        (L _ (ITconid    x)) = x+getVARSYM       (L _ (ITvarsym   x)) = x+getCONSYM       (L _ (ITconsym   x)) = x+getQVARID       (L _ (ITqvarid   x)) = x+getQCONID       (L _ (ITqconid   x)) = x+getQVARSYM      (L _ (ITqvarsym  x)) = x+getQCONSYM      (L _ (ITqconsym  x)) = x+getIPDUPVARID   (L _ (ITdupipvarid   x)) = x+getLABELVARID   (L _ (ITlabelvarid   x)) = x+getCHAR         (L _ (ITchar   _ x)) = x+getSTRING       (L _ (ITstring _ x)) = x+getINTEGER      (L _ (ITinteger _ x)) = x+getRATIONAL     (L _ (ITrational x)) = x+getPRIMCHAR     (L _ (ITprimchar _ x)) = x+getPRIMSTRING   (L _ (ITprimstring _ x)) = x+getPRIMINTEGER  (L _ (ITprimint  _ x)) = x+getPRIMWORD     (L _ (ITprimword _ x)) = x+getPRIMFLOAT    (L _ (ITprimfloat x)) = x+getPRIMDOUBLE   (L _ (ITprimdouble x)) = x+getTH_ID_SPLICE (L _ (ITidEscape x)) = x+getTH_ID_TY_SPLICE (L _ (ITidTyEscape x)) = x+getINLINE       (L _ (ITinline_prag _ inl conl)) = (inl,conl)+getSPEC_INLINE  (L _ (ITspec_inline_prag _ True))  = (Inline,  FunLike)+getSPEC_INLINE  (L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike)+getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x++getDOCNEXT (L _ (ITdocCommentNext x)) = x+getDOCPREV (L _ (ITdocCommentPrev x)) = x+getDOCNAMED (L _ (ITdocCommentNamed x)) = x+getDOCSECTION (L _ (ITdocSection n x)) = (n, x)++getCHARs        (L _ (ITchar       src _)) = src+getSTRINGs      (L _ (ITstring     src _)) = src+getINTEGERs     (L _ (ITinteger    src _)) = src+getPRIMCHARs    (L _ (ITprimchar   src _)) = src+getPRIMSTRINGs  (L _ (ITprimstring src _)) = src+getPRIMINTEGERs (L _ (ITprimint    src _)) = src+getPRIMWORDs    (L _ (ITprimword   src _)) = src++-- See Note [Pragma source text] in BasicTypes for the following+getINLINE_PRAGs       (L _ (ITinline_prag       src _ _)) = src+getSPEC_PRAGs         (L _ (ITspec_prag         src))     = src+getSPEC_INLINE_PRAGs  (L _ (ITspec_inline_prag  src _))   = src+getSOURCE_PRAGs       (L _ (ITsource_prag       src)) = src+getRULES_PRAGs        (L _ (ITrules_prag        src)) = src+getWARNING_PRAGs      (L _ (ITwarning_prag      src)) = src+getDEPRECATED_PRAGs   (L _ (ITdeprecated_prag   src)) = src+getSCC_PRAGs          (L _ (ITscc_prag          src)) = src+getGENERATED_PRAGs    (L _ (ITgenerated_prag    src)) = src+getCORE_PRAGs         (L _ (ITcore_prag         src)) = src+getUNPACK_PRAGs       (L _ (ITunpack_prag       src)) = src+getNOUNPACK_PRAGs     (L _ (ITnounpack_prag     src)) = src+getANN_PRAGs          (L _ (ITann_prag          src)) = src+getVECT_PRAGs         (L _ (ITvect_prag         src)) = src+getVECT_SCALAR_PRAGs  (L _ (ITvect_scalar_prag  src)) = src+getNOVECT_PRAGs       (L _ (ITnovect_prag       src)) = src+getMINIMAL_PRAGs      (L _ (ITminimal_prag      src)) = src+getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src+getOVERLAPPING_PRAGs  (L _ (IToverlapping_prag  src)) = src+getOVERLAPS_PRAGs     (L _ (IToverlaps_prag     src)) = src+getINCOHERENT_PRAGs   (L _ (ITincoherent_prag   src)) = src+getCTYPEs             (L _ (ITctype             src)) = src++getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l)++isUnicode :: Located Token -> Bool+isUnicode (L _ (ITforall         iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITdarrow         iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITdcolon         iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITlarrow         iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITrarrow         iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITlarrowtail     iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITrarrowtail     iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITLarrowtail     iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITRarrowtail     iu)) = iu == UnicodeSyntax+isUnicode (L _ (IToparenbar      iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITcparenbar      iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITcloseQuote     iu)) = iu == UnicodeSyntax+isUnicode _                           = False++hasE :: Located Token -> Bool+hasE (L _ (ITopenExpQuote HasE _)) = True+hasE (L _ (ITopenTExpQuote HasE))  = True+hasE _                             = False++getSCC :: Located Token -> P FastString+getSCC lt = do let s = getSTRING lt+                   err = "Spaces are not allowed in SCCs"+               -- We probably actually want to be more restrictive than this+               if ' ' `elem` unpackFS s+                   then failSpanMsgP (getLoc lt) (text err)+                   else return s++-- Utilities for combining source spans+comb2 :: Located a -> Located b -> SrcSpan+comb2 a b = a `seq` b `seq` combineLocs a b++comb3 :: Located a -> Located b -> Located c -> SrcSpan+comb3 a b c = a `seq` b `seq` c `seq`+    combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c))++comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan+comb4 a b c d = a `seq` b `seq` c `seq` d `seq`+    (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $+                combineSrcSpans (getLoc c) (getLoc d))++-- strict constructor version:+{-# INLINE sL #-}+sL :: SrcSpan -> a -> Located a+sL span a = span `seq` a `seq` L span a++-- See Note [Adding location info] for how these utility functions are used++-- replaced last 3 CPP macros in this file+{-# INLINE sL0 #-}+sL0 :: a -> Located a+sL0 = L noSrcSpan       -- #define L0   L noSrcSpan++{-# INLINE sL1 #-}+sL1 :: Located a -> b -> Located b+sL1 x = sL (getLoc x)   -- #define sL1   sL (getLoc $1)++{-# INLINE sLL #-}+sLL :: Located a -> Located b -> c -> Located c+sLL x y = sL (comb2 x y) -- #define LL   sL (comb2 $1 $>)++{- Note [Adding location info]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~++This is done using the three functions below, sL0, sL1+and sLL.  Note that these functions were mechanically+converted from the three macros that used to exist before,+namely L0, L1 and LL.++They each add a SrcSpan to their argument.++   sL0  adds 'noSrcSpan', used for empty productions+     -- This doesn't seem to work anymore -=chak++   sL1  for a production with a single token on the lhs.  Grabs the SrcSpan+        from that token.++   sLL  for a production with >1 token on the lhs.  Makes up a SrcSpan from+        the first and last tokens.++These suffice for the majority of cases.  However, we must be+especially careful with empty productions: sLL won't work if the first+or last token on the lhs can represent an empty span.  In these cases,+we have to calculate the span using more of the tokens from the lhs, eg.++        | 'newtype' tycl_hdr '=' newconstr deriving+                { L (comb3 $1 $4 $5)+                    (mkTyData NewType (unLoc $2) $4 (unLoc $5)) }++We provide comb3 and comb4 functions which are useful in such cases.++Be careful: there's no checking that you actually got this right, the+only symptom will be that the SrcSpans of your syntax will be+incorrect.++-}++-- Make a source location for the file.  We're a bit lazy here and just+-- make a point SrcSpan at line 1, column 0.  Strictly speaking we should+-- try to find the span of the whole file (ToDo).+fileSrcSpan :: P SrcSpan+fileSrcSpan = do+  l <- getSrcLoc;+  let loc = mkSrcLoc (srcLocFile l) 1 1;+  return (mkSrcSpan loc loc)++-- Hint about the MultiWayIf extension+hintMultiWayIf :: SrcSpan -> P ()+hintMultiWayIf span = do+  mwiEnabled <- liftM ((LangExt.MultiWayIf `extopt`) . options) getPState+  unless mwiEnabled $ parseErrorSDoc span $+    text "Multi-way if-expressions need MultiWayIf turned on"++-- Hint about if usage for beginners+hintIf :: SrcSpan -> String -> P (LHsExpr RdrName)+hintIf span msg = do+  mwiEnabled <- liftM ((LangExt.MultiWayIf `extopt`) . options) getPState+  if mwiEnabled+    then parseErrorSDoc span $ text $ "parse error in if statement"+    else parseErrorSDoc span $ text $ "parse error in if statement: "++msg++-- Hint about explicit-forall, assuming UnicodeSyntax is on+hintExplicitForall :: SrcSpan -> P ()+hintExplicitForall span = do+    forall      <- extension explicitForallEnabled+    rulePrag    <- extension inRulePrag+    unless (forall || rulePrag) $ parseErrorSDoc span $ vcat+      [ text "Illegal symbol '\x2200' in type" -- U+2200 FOR ALL+      , text "Perhaps you intended to use RankNTypes or a similar language"+      , text "extension to enable explicit-forall syntax: \x2200 <tvs>. <type>"+      ]++-- Hint about explicit-forall, assuming UnicodeSyntax is off+hintExplicitForall' :: SrcSpan -> P (GenLocated SrcSpan RdrName)+hintExplicitForall' span = do+    forall    <- extension explicitForallEnabled+    let illegalDot = "Illegal symbol '.' in type"+    if forall+      then parseErrorSDoc span $ vcat+        [ text illegalDot+        , text "Perhaps you meant to write 'forall <tvs>. <type>'?"+        ]+      else parseErrorSDoc span $ vcat+        [ text illegalDot+        , text "Perhaps you intended to use RankNTypes or a similar language"+        , text "extension to enable explicit-forall syntax: forall <tvs>. <type>"+        ]++{-+%************************************************************************+%*                                                                      *+        Helper functions for generating annotations in the parser+%*                                                                      *+%************************************************************************++For the general principles of the following routines, see Note [Api annotations]+in ApiAnnotation.hs++-}++-- |Construct an AddAnn from the annotation keyword and the location+-- of the keyword itself+mj :: AnnKeywordId -> Located e -> AddAnn+mj a l s = addAnnotation s a (gl l)++-- |Construct an AddAnn from the annotation keyword and the Located Token. If+-- the token has a unicode equivalent and this has been used, provide the+-- unicode variant of the annotation.+mu :: AnnKeywordId -> Located Token -> AddAnn+mu a lt@(L l t) = (\s -> addAnnotation s (toUnicodeAnn a lt) l)++-- | If the 'Token' is using its unicode variant return the unicode variant of+--   the annotation+toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId+toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a++gl = getLoc++-- |Add an annotation to the located element, and return the located+-- element as a pass through+aa :: Located a -> (AnnKeywordId,Located c) -> P (Located a)+aa a@(L l _) (b,s) = addAnnotation l b (gl s) >> return a++-- |Add an annotation to a located element resulting from a monadic action+am :: P (Located a) -> (AnnKeywordId, Located b) -> P (Located a)+am a (b,s) = do+  av@(L l _) <- a+  addAnnotation l b (gl s)+  return av++-- | Add a list of AddAnns to the given AST element.  For example,+-- the parsing rule for @let@ looks like:+--+-- @+--      | 'let' binds 'in' exp    {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4)+--                                       (mj AnnLet $1:mj AnnIn $3+--                                         :(fst $ unLoc $2)) }+-- @+--+-- This adds an AnnLet annotation for @let@, an AnnIn for @in@, as well+-- as any annotations that may arise in the binds. This will include open+-- and closing braces if they are used to delimit the let expressions.+--+ams :: Located a -> [AddAnn] -> P (Located a)+ams a@(L l _) bs = addAnnsAt l bs >> return a++-- |Add all [AddAnn] to an AST element wrapped in a Just+aljs :: Located (Maybe a) -> [AddAnn] -> P (Located (Maybe a))+aljs a@(L l _) bs = addAnnsAt l bs >> return a++-- |Add all [AddAnn] to an AST element wrapped in a Just+ajs a@(Just (L l _)) bs = addAnnsAt l bs >> return a++-- |Add a list of AddAnns to the given AST element, where the AST element is the+--  result of a monadic action+amms :: P (Located a) -> [AddAnn] -> P (Located a)+amms a bs = do { av@(L l _) <- a+               ; addAnnsAt l bs+               ; return av }++-- |Add a list of AddAnns to the AST element, and return the element as a+--  OrdList+amsu :: Located a -> [AddAnn] -> P (OrdList (Located a))+amsu a@(L l _) bs = addAnnsAt l bs >> return (unitOL a)++-- |Synonyms for AddAnn versions of AnnOpen and AnnClose+mo,mc :: Located Token -> AddAnn+mo ll = mj AnnOpen ll+mc ll = mj AnnClose ll++moc,mcc :: Located Token -> AddAnn+moc ll = mj AnnOpenC ll+mcc ll = mj AnnCloseC ll++mop,mcp :: Located Token -> AddAnn+mop ll = mj AnnOpenP ll+mcp ll = mj AnnCloseP ll++mos,mcs :: Located Token -> AddAnn+mos ll = mj AnnOpenS ll+mcs ll = mj AnnCloseS ll++-- |Given a list of the locations of commas, provide a [AddAnn] with an AnnComma+--  entry for each SrcSpan+mcommas :: [SrcSpan] -> [AddAnn]+mcommas ss = map (\s -> mj AnnCommaTuple (L s ())) ss++-- |Given a list of the locations of '|'s, provide a [AddAnn] with an AnnVbar+--  entry for each SrcSpan+mvbars :: [SrcSpan] -> [AddAnn]+mvbars ss = map (\s -> mj AnnVbar (L s ())) ss++-- |Get the location of the last element of a OrdList, or noSrcSpan+oll :: OrdList (Located a) -> SrcSpan+oll l =+  if isNilOL l then noSrcSpan+               else getLoc (lastOL l)++-- |Add a semicolon annotation in the right place in a list. If the+-- leading list is empty, add it to the tail+asl :: [Located a] -> Located b -> Located a -> P()+asl [] (L ls _) (L l _) = addAnnotation l          AnnSemi ls+asl (x:_xs) (L ls _) _x = addAnnotation (getLoc x) AnnSemi ls+}
+ parser/RdrHsSyn.hs view
@@ -0,0 +1,1562 @@+--+--  (c) The University of Glasgow 2002-2006+--++-- Functions over HsSyn specialised to RdrName.++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}++module   RdrHsSyn (+        mkHsOpApp,+        mkHsIntegral, mkHsFractional, mkHsIsString,+        mkHsDo, mkSpliceDecl,+        mkRoleAnnotDecl,+        mkClassDecl,+        mkTyData, mkDataFamInst,+        mkTySynonym, mkTyFamInstEqn,+        mkTyFamInst,+        mkFamDecl, mkLHsSigType,+        splitCon, mkInlinePragma,+        mkPatSynMatchGroup,+        mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp+        mkTyClD, mkInstD,+        mkRdrRecordCon, mkRdrRecordUpd,+        setRdrNameSpace,++        cvBindGroup,+        cvBindsAndSigs,+        cvTopDecls,+        placeHolderPunRhs,++        -- Stuff to do with Foreign declarations+        mkImport,+        parseCImport,+        mkExport,+        mkExtName,           -- RdrName -> CLabelString+        mkGadtDecl,          -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName+        mkConDeclH98,+        mkATDefault,++        -- Bunch of functions in the parser monad for+        -- checking and constructing values+        checkPrecP,           -- Int -> P Int+        checkContext,         -- HsType -> P HsContext+        checkPattern,         -- HsExp -> P HsPat+        bang_RDR,+        checkPatterns,        -- SrcLoc -> [HsExp] -> P [HsPat]+        checkMonadComp,       -- P (HsStmtContext RdrName)+        checkCommand,         -- LHsExpr RdrName -> P (LHsCmd RdrName)+        checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl+        checkValSigLhs,+        checkDoAndIfThenElse,+        checkRecordSyntax,+        parseErrorSDoc,+        splitTilde, splitTildeApps,++        -- Help with processing exports+        ImpExpSubSpec(..),+        ImpExpQcSpec(..),+        mkModuleImpExp,+        mkTypeImpExp,+        mkImpExpSubSpec,+        checkImportSpec,++        SumOrTuple (..), mkSumOrTuple++    ) where++import HsSyn            -- Lots of it+import Class            ( FunDep )+import TyCon            ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )+import DataCon          ( DataCon, dataConTyCon )+import ConLike          ( ConLike(..) )+import CoAxiom          ( Role, fsFromRole )+import RdrName+import Name+import BasicTypes+import TcEvidence       ( idHsWrapper )+import Lexer+import Lexeme           ( isLexCon )+import Type             ( TyThing(..) )+import TysWiredIn       ( cTupleTyConName, tupleTyCon, tupleDataCon,+                          nilDataConName, nilDataConKey,+                          listTyConName, listTyConKey,+                          starKindTyConName, unicodeStarKindTyConName )+import ForeignCall+import PrelNames        ( forall_tv_RDR, eqTyCon_RDR, allNameStrings )+import SrcLoc+import Unique           ( hasKey )+import OrdList          ( OrdList, fromOL )+import Bag              ( emptyBag, consBag )+import Outputable+import FastString+import Maybes+import Util+import ApiAnnotation+import Data.List+import qualified GHC.LanguageExtensions as LangExt+import MonadUtils++import Control.Monad+import Text.ParserCombinators.ReadP as ReadP+import Data.Char++import Data.Data       ( dataTypeOf, fromConstr, dataTypeConstrs )++#include "HsVersions.h"+++{- **********************************************************************++  Construction functions for Rdr stuff++  ********************************************************************* -}++-- | mkClassDecl builds a RdrClassDecl, filling in the names for tycon and+-- datacon by deriving them from the name of the class.  We fill in the names+-- for the tycon and datacon corresponding to the class, by deriving them+-- from the name of the class itself.  This saves recording the names in the+-- interface file (which would be equally good).++-- Similarly for mkConDecl, mkClassOpSig and default-method names.++--         *** See Note [The Naming story] in HsDecls ****++mkTyClD :: LTyClDecl n -> LHsDecl n+mkTyClD (L loc d) = L loc (TyClD d)++mkInstD :: LInstDecl n -> LHsDecl n+mkInstD (L loc d) = L loc (InstD d)++mkClassDecl :: SrcSpan+            -> Located (Maybe (LHsContext RdrName), LHsType RdrName)+            -> Located (a,[Located (FunDep (Located RdrName))])+            -> OrdList (LHsDecl RdrName)+            -> P (LTyClDecl RdrName)++mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls+  = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls+       ; let cxt = fromMaybe (noLoc []) mcxt+       ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr+       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan+       ; tyvars <- checkTyVarsP (text "class") whereDots cls tparams+       ; at_defs <- mapM (eitherToP . mkATDefault) at_insts+       ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars+                                  , tcdFixity = fixity+                                  , tcdFDs = snd (unLoc fds)+                                  , tcdSigs = mkClassOpSigs sigs+                                  , tcdMeths = binds+                                  , tcdATs = ats, tcdATDefs = at_defs, tcdDocs  = docs+                                  , tcdFVs = placeHolderNames })) }++mkATDefault :: LTyFamInstDecl RdrName+            -> Either (SrcSpan, SDoc) (LTyFamDefltEqn RdrName)+-- Take a type-family instance declaration and turn it into+-- a type-family default equation for a class declaration+-- We parse things as the former and use this function to convert to the latter+--+-- We use the Either monad because this also called+-- from Convert.hs+mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e }))+      | TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_fixity = fixity+                 , tfe_rhs = rhs } <- e+      = do { tvs <- checkTyVars (text "default") equalsDots tc (hsib_body pats)+           ; return (L loc (TyFamEqn { tfe_tycon = tc+                                     , tfe_pats = tvs+                                     , tfe_fixity = fixity+                                     , tfe_rhs = rhs })) }++mkTyData :: SrcSpan+         -> NewOrData+         -> Maybe (Located CType)+         -> Located (Maybe (LHsContext RdrName), LHsType RdrName)+         -> Maybe (LHsKind RdrName)+         -> [LConDecl RdrName]+         -> HsDeriving RdrName+         -> P (LTyClDecl RdrName)+mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv+  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr+       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan+       ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams+       ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv+       ; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars,+                                   tcdFixity = fixity,+                                   tcdDataDefn = defn,+                                   tcdDataCusk = PlaceHolder,+                                   tcdFVs = placeHolderNames })) }++mkDataDefn :: NewOrData+           -> Maybe (Located CType)+           -> Maybe (LHsContext RdrName)+           -> Maybe (LHsKind RdrName)+           -> [LConDecl RdrName]+           -> HsDeriving RdrName+           -> P (HsDataDefn RdrName)+mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv+  = do { checkDatatypeContext mcxt+       ; let cxt = fromMaybe (noLoc []) mcxt+       ; return (HsDataDefn { dd_ND = new_or_data, dd_cType = cType+                            , dd_ctxt = cxt+                            , dd_cons = data_cons+                            , dd_kindSig = ksig+                            , dd_derivs = maybe_deriv }) }+++mkTySynonym :: SrcSpan+            -> LHsType RdrName  -- LHS+            -> LHsType RdrName  -- RHS+            -> P (LTyClDecl RdrName)+mkTySynonym loc lhs rhs+  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs+       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan+       ; tyvars <- checkTyVarsP (text "type") equalsDots tc tparams+       ; return (L loc (SynDecl { tcdLName = tc, tcdTyVars = tyvars+                                , tcdFixity = fixity+                                , tcdRhs = rhs, tcdFVs = placeHolderNames })) }++mkTyFamInstEqn :: LHsType RdrName+               -> LHsType RdrName+               -> P (TyFamInstEqn RdrName,[AddAnn])+mkTyFamInstEqn lhs rhs+  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs+       ; return (TyFamEqn { tfe_tycon = tc+                          , tfe_pats  = mkHsImplicitBndrs tparams+                          , tfe_fixity = fixity+                          , tfe_rhs   = rhs },+                 ann) }++mkDataFamInst :: SrcSpan+              -> NewOrData+              -> Maybe (Located CType)+              -> Located (Maybe (LHsContext RdrName), LHsType RdrName)+              -> Maybe (LHsKind RdrName)+              -> [LConDecl RdrName]+              -> HsDeriving RdrName+              -> P (LInstDecl RdrName)+mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv+  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr+       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan+       ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv+       ; return (L loc (DataFamInstD (+                  DataFamInstDecl { dfid_tycon = tc+                                  , dfid_pats = mkHsImplicitBndrs tparams+                                  , dfid_fixity = fixity+                                  , dfid_defn = defn, dfid_fvs = placeHolderNames }))) }++mkTyFamInst :: SrcSpan+            -> LTyFamInstEqn RdrName+            -> P (LInstDecl RdrName)+mkTyFamInst loc eqn+  = return (L loc (TyFamInstD (TyFamInstDecl { tfid_eqn  = eqn+                                             , tfid_fvs  = placeHolderNames })))++mkFamDecl :: SrcSpan+          -> FamilyInfo RdrName+          -> LHsType RdrName                   -- LHS+          -> Located (FamilyResultSig RdrName) -- Optional result signature+          -> Maybe (LInjectivityAnn RdrName)   -- Injectivity annotation+          -> P (LTyClDecl RdrName)+mkFamDecl loc info lhs ksig injAnn+  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs+       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan+       ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams+       ; return (L loc (FamDecl (FamilyDecl{ fdInfo      = info, fdLName = tc+                                           , fdTyVars    = tyvars+                                           , fdFixity    = fixity+                                           , fdResultSig = ksig+                                           , fdInjectivityAnn = injAnn }))) }+  where+    equals_or_where = case info of+                        DataFamily          -> empty+                        OpenTypeFamily      -> empty+                        ClosedTypeFamily {} -> whereDots++mkSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName+-- If the user wrote+--      [pads| ... ]   then return a QuasiQuoteD+--      $(e)           then return a SpliceD+-- but if she wrote, say,+--      f x            then behave as if she'd written $(f x)+--                     ie a SpliceD+--+-- Typed splices are not allowed at the top level, thus we do not represent them+-- as spliced declaration.  See #10945+mkSpliceDecl lexpr@(L loc expr)+  | HsSpliceE splice@(HsUntypedSplice {}) <- expr+  = SpliceD (SpliceDecl (L loc splice) ExplicitSplice)++  | HsSpliceE splice@(HsQuasiQuote {}) <- expr+  = SpliceD (SpliceDecl (L loc splice) ExplicitSplice)++  | otherwise+  = SpliceD (SpliceDecl (L loc (mkUntypedSplice NoParens lexpr)) ImplicitSplice)++mkRoleAnnotDecl :: SrcSpan+                -> Located RdrName                   -- type being annotated+                -> [Located (Maybe FastString)]      -- roles+                -> P (LRoleAnnotDecl RdrName)+mkRoleAnnotDecl loc tycon roles+  = do { roles' <- mapM parse_role roles+       ; return $ L loc $ RoleAnnotDecl tycon roles' }+  where+    role_data_type = dataTypeOf (undefined :: Role)+    all_roles = map fromConstr $ dataTypeConstrs role_data_type+    possible_roles = [(fsFromRole role, role) | role <- all_roles]++    parse_role (L loc_role Nothing) = return $ L loc_role Nothing+    parse_role (L loc_role (Just role))+      = case lookup role possible_roles of+          Just found_role -> return $ L loc_role $ Just found_role+          Nothing         ->+            let nearby = fuzzyLookup (unpackFS role) (mapFst unpackFS possible_roles) in+            parseErrorSDoc loc_role+              (text "Illegal role name" <+> quotes (ppr role) $$+               suggestions nearby)++    suggestions []   = empty+    suggestions [r]  = text "Perhaps you meant" <+> quotes (ppr r)+      -- will this last case ever happen??+    suggestions list = hang (text "Perhaps you meant one of these:")+                       2 (pprWithCommas (quotes . ppr) list)++{- **********************************************************************++  #cvBinds-etc# Converting to @HsBinds@, etc.++  ********************************************************************* -}++-- | Function definitions are restructured here. Each is assumed to be recursive+-- initially, and non recursive definitions are discovered by the dependency+-- analyser.+++--  | Groups together bindings for a single function+cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]+cvTopDecls decls = go (fromOL decls)+  where+    go :: [LHsDecl RdrName] -> [LHsDecl RdrName]+    go []                   = []+    go (L l (ValD b) : ds)  = L l' (ValD b') : go ds'+                            where (L l' b', ds') = getMonoBind (L l b) ds+    go (d : ds)             = d : go ds++-- Declaration list may only contain value bindings and signatures.+cvBindGroup :: OrdList (LHsDecl RdrName) -> P (HsValBinds RdrName)+cvBindGroup binding+  = do { (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _) <- cvBindsAndSigs binding+       ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts)+         return $ ValBindsIn mbs sigs }++cvBindsAndSigs :: OrdList (LHsDecl RdrName)+  -> P (LHsBinds RdrName, [LSig RdrName], [LFamilyDecl RdrName]+          , [LTyFamInstDecl RdrName], [LDataFamInstDecl RdrName], [LDocDecl])+-- Input decls contain just value bindings and signatures+-- and in case of class or instance declarations also+-- associated type declarations. They might also contain Haddock comments.+cvBindsAndSigs fb = go (fromOL fb)+  where+    go []              = return (emptyBag, [], [], [], [], [])+    go (L l (ValD b) : ds)+      = do { (bs, ss, ts, tfis, dfis, docs) <- go ds'+           ; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) }+      where+        (b', ds') = getMonoBind (L l b) ds+    go (L l decl : ds)+      = do { (bs, ss, ts, tfis, dfis, docs) <- go ds+           ; case decl of+               SigD s+                 -> return (bs, L l s : ss, ts, tfis, dfis, docs)+               TyClD (FamDecl t)+                 -> return (bs, ss, L l t : ts, tfis, dfis, docs)+               InstD (TyFamInstD { tfid_inst = tfi })+                 -> return (bs, ss, ts, L l tfi : tfis, dfis, docs)+               InstD (DataFamInstD { dfid_inst = dfi })+                 -> return (bs, ss, ts, tfis, L l dfi : dfis, docs)+               DocD d+                 -> return (bs, ss, ts, tfis, dfis, L l d : docs)+               SpliceD d+                 -> parseErrorSDoc l $+                    hang (text "Declaration splices are allowed only" <+>+                          text "at the top level:")+                       2 (ppr d)+               _ -> pprPanic "cvBindsAndSigs" (ppr decl) }++-----------------------------------------------------------------------------+-- Group function bindings into equation groups++getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]+  -> (LHsBind RdrName, [LHsDecl RdrName])+-- Suppose      (b',ds') = getMonoBind b ds+--      ds is a list of parsed bindings+--      b is a MonoBinds that has just been read off the front++-- Then b' is the result of grouping more equations from ds that+-- belong with b into a single MonoBinds, and ds' is the depleted+-- list of parsed bindings.+--+-- All Haddock comments between equations inside the group are+-- discarded.+--+-- No AndMonoBinds or EmptyMonoBinds here; just single equations++getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1),+                               fun_matches+                                 = MG { mg_alts = L _ mtchs1 } })) binds+  | has_args mtchs1+  = go mtchs1 loc1 binds []+  where+    go mtchs loc+       (L loc2 (ValD (FunBind { fun_id = L _ f2,+                                fun_matches+                                  = MG { mg_alts = L _ mtchs2 } })) : binds) _+        | f1 == f2 = go (mtchs2 ++ mtchs)+                        (combineSrcSpans loc loc2) binds []+    go mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls+        = let doc_decls' = doc_decl : doc_decls+          in go mtchs (combineSrcSpans loc loc2) binds doc_decls'+    go mtchs loc binds doc_decls+        = ( L loc (makeFunBind fun_id1 (reverse mtchs))+          , (reverse doc_decls) ++ binds)+        -- Reverse the final matches, to get it back in the right order+        -- Do the same thing with the trailing doc comments++getMonoBind bind binds = (bind, binds)++has_args :: [LMatch RdrName (LHsExpr RdrName)] -> Bool+has_args []                           = panic "RdrHsSyn:has_args"+has_args ((L _ (Match _ args _ _)) : _) = not (null args)+        -- Don't group together FunBinds if they have+        -- no arguments.  This is necessary now that variable bindings+        -- with no arguments are now treated as FunBinds rather+        -- than pattern bindings (tests/rename/should_fail/rnfail002).++{- **********************************************************************++  #PrefixToHS-utils# Utilities for conversion++  ********************************************************************* -}++{- Note [Parsing data constructors is hard]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We parse the RHS of the constructor declaration+     data T = C t1 t2+as a btype_no_ops (treating C as a type constructor) and then convert C to be+a data constructor.  Reason: it might continue like this:+     data T = C t1 t2 :% D Int+in which case C really /would/ be a type constructor.  We can't resolve this+ambiguity till we come across the constructor oprerator :% (or not, more usually)++So the plan is:++* Parse the data constructor declration as a type (actually btype_no_ops)++* Use 'splitCon' to rejig it into the data constructor and the args++* In doing so, we use 'tyConToDataCon' to convert the RdrName for+  the data con, which has been parsed as a tycon, back to a datacon.+  This is more than just adjusting the name space; for operators we+  need to check that it begins with a colon.  E.g.+     data T = (+++)+  will parse ok (since tycons can be operators), but we should reject+  it (Trac #12051).+-}++splitCon :: LHsType RdrName+      -> P (Located RdrName, HsConDeclDetails RdrName)+-- See Note [Parsing data constructors is hard]+-- This gets given a "type" that should look like+--      C Int Bool+-- or   C { x::Int, y::Bool }+-- and returns the pieces+splitCon ty+ = split ty []+ where+   -- This is used somewhere where HsAppsTy is not used+   split (L _ (HsAppTy t u)) ts       = split t (u : ts)+   split (L l (HsTyVar _ (L _ tc)))  ts = do data_con <- tyConToDataCon l tc+                                             return (data_con, mk_rest ts)+   split (L l (HsTupleTy HsBoxedOrConstraintTuple ts)) []+      = return (L l (getRdrName (tupleDataCon Boxed (length ts))), PrefixCon ts)+   split (L l _) _ = parseErrorSDoc l (text "Cannot parse data constructor in a data/newtype declaration:" <+> ppr ty)++   mk_rest [L l (HsRecTy flds)] = RecCon (L l flds)+   mk_rest ts                   = PrefixCon ts++tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)+-- See Note [Parsing data constructors is hard]+-- Data constructor RHSs are parsed as types+tyConToDataCon loc tc+  | isTcOcc occ+  , isLexCon (occNameFS occ)+  = return (L loc (setRdrNameSpace tc srcDataName))++  | otherwise+  = parseErrorSDoc loc (msg $$ extra)+  where+    occ = rdrNameOcc tc++    msg = text "Not a data constructor:" <+> quotes (ppr tc)+    extra | tc == forall_tv_RDR+          = text "Perhaps you intended to use ExistentialQuantification"+          | otherwise = empty++mkPatSynMatchGroup :: Located RdrName+                   -> Located (OrdList (LHsDecl RdrName))+                   -> P (MatchGroup RdrName (LHsExpr RdrName))+mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =+    do { matches <- mapM fromDecl (fromOL decls)+       ; when (null matches) (wrongNumberErr loc)+       ; return $ mkMatchGroup FromSource matches }+  where+    fromDecl (L loc decl@(ValD (PatBind pat@(L _ (ConPatIn ln@(L _ name) details)) rhs _ _ _))) =+        do { unless (name == patsyn_name) $+               wrongNameBindingErr loc decl+           ; match <- case details of+               PrefixCon pats ->+                        return $ Match (FunRhs ln Prefix NoSrcStrict) pats Nothing rhs+               InfixCon pat1 pat2 ->+                       return $ Match (FunRhs ln Infix NoSrcStrict) [pat1, pat2] Nothing rhs+               RecCon{} -> recordPatSynErr loc pat+           ; return $ L loc match }+    fromDecl (L loc decl) = extraDeclErr loc decl++    extraDeclErr loc decl =+        parseErrorSDoc loc $+        text "pattern synonym 'where' clause must contain a single binding:" $$+        ppr decl++    wrongNameBindingErr loc decl =+        parseErrorSDoc loc $+        text "pattern synonym 'where' clause must bind the pattern synonym's name" <+>+        quotes (ppr patsyn_name) $$ ppr decl++    wrongNumberErr loc =+      parseErrorSDoc loc $+      text "pattern synonym 'where' clause cannot be empty" $$+      text "In the pattern synonym declaration for: " <+> ppr (patsyn_name)++recordPatSynErr :: SrcSpan -> LPat RdrName -> P a+recordPatSynErr loc pat =+    parseErrorSDoc loc $+    text "record syntax not supported for pattern synonym declarations:" $$+    ppr pat++mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr RdrName]+                -> LHsContext RdrName -> HsConDeclDetails RdrName+                -> ConDecl RdrName++mkConDeclH98 name mb_forall cxt details+  = ConDeclH98 { con_name     = name+               , con_qvars    = fmap mkHsQTvs mb_forall+               , con_cxt      = Just cxt+                             -- AZ:TODO: when can cxt be Nothing?+                             --          remembering that () is a valid context.+               , con_details  = details+               , con_doc      = Nothing }++mkGadtDecl :: [Located RdrName]+           -> LHsSigType RdrName     -- Always a HsForAllTy+           -> ConDecl RdrName+mkGadtDecl names ty = ConDeclGADT { con_names = names+                                  , con_type  = ty+                                  , con_doc   = Nothing }++setRdrNameSpace :: RdrName -> NameSpace -> RdrName+-- ^ This rather gruesome function is used mainly by the parser.+-- When parsing:+--+-- > data T a = T | T1 Int+--+-- we parse the data constructors as /types/ because of parser ambiguities,+-- so then we need to change the /type constr/ to a /data constr/+--+-- The exact-name case /can/ occur when parsing:+--+-- > data [] a = [] | a : [a]+--+-- For the exact-name case we return an original name.+setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ)+setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ)+setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ)+setRdrNameSpace (Exact n)    ns+  | Just thing <- wiredInNameTyThing_maybe n+  = setWiredInNameSpace thing ns+    -- Preserve Exact Names for wired-in things,+    -- notably tuples and lists++  | isExternalName n+  = Orig (nameModule n) occ++  | otherwise   -- This can happen when quoting and then+                -- splicing a fixity declaration for a type+  = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n))+  where+    occ = setOccNameSpace ns (nameOccName n)++setWiredInNameSpace :: TyThing -> NameSpace -> RdrName+setWiredInNameSpace (ATyCon tc) ns+  | isDataConNameSpace ns+  = ty_con_data_con tc+  | isTcClsNameSpace ns+  = Exact (getName tc)      -- No-op++setWiredInNameSpace (AConLike (RealDataCon dc)) ns+  | isTcClsNameSpace ns+  = data_con_ty_con dc+  | isDataConNameSpace ns+  = Exact (getName dc)      -- No-op++setWiredInNameSpace thing ns+  = pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing)++ty_con_data_con :: TyCon -> RdrName+ty_con_data_con tc+  | isTupleTyCon tc+  , Just dc <- tyConSingleDataCon_maybe tc+  = Exact (getName dc)++  | tc `hasKey` listTyConKey+  = Exact nilDataConName++  | otherwise  -- See Note [setRdrNameSpace for wired-in names]+  = Unqual (setOccNameSpace srcDataName (getOccName tc))++data_con_ty_con :: DataCon -> RdrName+data_con_ty_con dc+  | let tc = dataConTyCon dc+  , isTupleTyCon tc+  = Exact (getName tc)++  | dc `hasKey` nilDataConKey+  = Exact listTyConName++  | otherwise  -- See Note [setRdrNameSpace for wired-in names]+  = Unqual (setOccNameSpace tcClsName (getOccName dc))+++{- Note [setRdrNameSpace for wired-in names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In GHC.Types, which declares (:), we have+  infixr 5 :+The ambiguity about which ":" is meant is resolved by parsing it as a+data constructor, but then using dataTcOccs to try the type constructor too;+and that in turn calls setRdrNameSpace to change the name-space of ":" to+tcClsName.  There isn't a corresponding ":" type constructor, but it's painful+to make setRdrNameSpace partial, so we just make an Unqual name instead. It+really doesn't matter!+-}++-- | Note [Sorting out the result type]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- In a GADT declaration which is not a record, we put the whole constr type+-- into the res_ty for a ConDeclGADT for now; the renamer will unravel it once+-- it has sorted out operator fixities. Consider for example+--      C :: a :*: b -> a :*: b -> a :+: b+-- Initially this type will parse as+--       a :*: (b -> (a :*: (b -> (a :+: b))))+--+-- so it's hard to split up the arguments until we've done the precedence+-- resolution (in the renamer). On the other hand, for a record+--         { x,y :: Int } -> a :*: b+-- there is no doubt.  AND we need to sort records out so that+-- we can bring x,y into scope.  So:+--    * For PrefixCon we keep all the args in the res_ty+--    * For RecCon we do not++checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsQTyVars RdrName)+-- Same as checkTyVars, but in the P monad+checkTyVarsP pp_what equals_or_where tc tparms+  = eitherToP $ checkTyVars pp_what equals_or_where tc tparms++eitherToP :: Either (SrcSpan, SDoc) a -> P a+-- Adapts the Either monad to the P monad+eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc+eitherToP (Right thing)     = return thing++checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName]+            -> Either (SrcSpan, SDoc) (LHsQTyVars RdrName)+-- Check whether the given list of type parameters are all type variables+-- (possibly with a kind signature)+-- We use the Either monad because it's also called (via mkATDefault) from+-- Convert.hs+checkTyVars pp_what equals_or_where tc tparms+  = do { tvs <- mapM chk tparms+       ; return (mkHsQTvs tvs) }+  where++    chk (L _ (HsParTy ty)) = chk ty+    chk (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = chk ty++        -- Check that the name space is correct!+    chk (L l (HsKindSig+            (L _ (HsAppsTy [L _ (HsAppPrefix (L lv (HsTyVar _ (L _ tv))))])) k))+        | isRdrTyVar tv    = return (L l (KindedTyVar (L lv tv) k))+    chk (L l (HsTyVar _ (L ltv tv)))+        | isRdrTyVar tv    = return (L l (UserTyVar (L ltv tv)))+    chk t@(L loc _)+        = Left (loc,+                vcat [ text "Unexpected type" <+> quotes (ppr t)+                     , text "In the" <+> pp_what <+> ptext (sLit "declaration for") <+> quotes (ppr tc)+                     , vcat[ (text "A" <+> pp_what <+> ptext (sLit "declaration should have form"))+                     , nest 2 (pp_what <+> ppr tc+                                       <+> hsep (map text (takeList tparms allNameStrings))+                                       <+> equals_or_where) ] ])++whereDots, equalsDots :: SDoc+-- Second argument to checkTyVars+whereDots  = text "where ..."+equalsDots = text "= ..."++checkDatatypeContext :: Maybe (LHsContext RdrName) -> P ()+checkDatatypeContext Nothing = return ()+checkDatatypeContext (Just (L loc c))+    = do allowed <- extension datatypeContextsEnabled+         unless allowed $+             parseErrorSDoc loc+                 (text "Illegal datatype context (use DatatypeContexts):" <+>+                  pprHsContext c)++checkRecordSyntax :: Outputable a => Located a -> P (Located a)+checkRecordSyntax lr@(L loc r)+    = do allowed <- extension traditionalRecordSyntaxEnabled+         if allowed+             then return lr+             else parseErrorSDoc loc+                      (text "Illegal record syntax (use TraditionalRecordSyntax):" <+>+                       ppr r)++checkTyClHdr :: Bool               -- True  <=> class header+                                   -- False <=> type header+             -> LHsType RdrName+             -> P (Located RdrName,          -- the head symbol (type or class name)+                   [LHsType RdrName],        -- parameters of head symbol+                   LexicalFixity,         -- the declaration is in infix format+                   [AddAnn]) -- API Annotation for HsParTy when stripping parens+-- Well-formedness check and decomposition of type and class heads.+-- Decomposes   T ty1 .. tyn   into    (T, [ty1, ..., tyn])+--              Int :*: Bool   into    (:*:, [Int, Bool])+-- returning the pieces+checkTyClHdr is_cls ty+  = goL ty [] [] Prefix+  where+    goL (L l ty) acc ann fix = go l ty acc ann fix++    go l (HsTyVar _ (L _ tc)) acc ann fix+      | isRdrTc tc               = return (L l tc, acc, fix, ann)+    go _ (HsOpTy t1 ltc@(L _ tc) t2) acc ann _fix+      | isRdrTc tc               = return (ltc, t1:t2:acc, Infix, ann)+    go l (HsParTy ty)    acc ann fix = goL ty acc (ann ++ mkParensApiAnn l) fix+    go _ (HsAppTy t1 t2) acc ann fix = goL t1 (t2:acc) ann fix+    go _ (HsAppsTy ts)   acc ann _fix+      | Just (head, args, fixity) <- getAppsTyHead_maybe ts+      = goL head (args ++ acc) ann fixity++    go _ (HsAppsTy [L _ (HsAppInfix (L loc star))]) [] ann fix+      | occNameFS (rdrNameOcc star) == fsLit "*"+      = return (L loc (nameRdrName starKindTyConName), [], fix, ann)+      | occNameFS (rdrNameOcc star) == fsLit "★"+      = return (L loc (nameRdrName unicodeStarKindTyConName), [], fix, ann)++    go l (HsTupleTy HsBoxedOrConstraintTuple ts) [] ann fix+      = return (L l (nameRdrName tup_name), ts, fix, ann)+      where+        arity = length ts+        tup_name | is_cls    = cTupleTyConName arity+                 | otherwise = getName (tupleTyCon Boxed arity)+                 -- See Note [Unit tuples] in HsTypes  (TODO: is this still relevant?)+    go l _ _ _ _+      = parseErrorSDoc l (text "Malformed head of type or class declaration:"+                          <+> ppr ty)++checkContext :: LHsType RdrName -> P ([AddAnn],LHsContext RdrName)+checkContext (L l orig_t)+  = check [] (L l orig_t)+ where+  check anns (L lp (HsTupleTy _ ts))   -- (Eq a, Ord b) shows up as a tuple type+    = return (anns ++ mkParensApiAnn lp,L l ts)                -- Ditto ()++    -- don't let HsAppsTy get in the way+  check anns (L _ (HsAppsTy [L _ (HsAppPrefix ty)]))+    = check anns ty++  check anns (L lp1 (HsParTy ty))-- to be sure HsParTy doesn't get into the way+       = check anns' ty+         where anns' = if l == lp1 then anns+                                   else (anns ++ mkParensApiAnn lp1)++  check _anns _+    = return ([],L l [L l orig_t]) -- no need for anns, returning original++-- -------------------------------------------------------------------------+-- Checking Patterns.++-- We parse patterns as expressions and check for valid patterns below,+-- converting the expression into a pattern at the same time.++checkPattern :: SDoc -> LHsExpr RdrName -> P (LPat RdrName)+checkPattern msg e = checkLPat msg e++checkPatterns :: SDoc -> [LHsExpr RdrName] -> P [LPat RdrName]+checkPatterns msg es = mapM (checkPattern msg) es++checkLPat :: SDoc -> LHsExpr RdrName -> P (LPat RdrName)+checkLPat msg e@(L l _) = checkPat msg l e []++checkPat :: SDoc -> SrcSpan -> LHsExpr RdrName -> [LPat RdrName]+         -> P (LPat RdrName)+checkPat _ loc (L l (HsVar (L _ c))) args+  | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))+checkPat msg loc e args     -- OK to let this happen even if bang-patterns+                        -- are not enabled, because there is no valid+                        -- non-bang-pattern parse of (C ! e)+  | Just (e', args') <- splitBang e+  = do  { args'' <- checkPatterns msg args'+        ; checkPat msg loc e' (args'' ++ args) }+checkPat msg loc (L _ (HsApp f e)) args+  = do p <- checkLPat msg e+       checkPat msg loc f (p : args)+checkPat msg loc (L _ e) []+  = do p <- checkAPat msg loc e+       return (L loc p)+checkPat msg loc e _+  = patFail msg loc (unLoc e)++checkAPat :: SDoc -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)+checkAPat msg loc e0 = do+ pState <- getPState+ let opts = options pState+ case e0 of+   EWildPat -> return (WildPat placeHolderType)+   HsVar x  -> return (VarPat x)+   HsLit (HsStringPrim _ _) -- (#13260)+       -> parseErrorSDoc loc (text "Illegal unboxed string literal in pattern:" $$ ppr e0)++   HsLit l  -> return (LitPat l)++   -- Overloaded numeric patterns (e.g. f 0 x = x)+   -- Negation is recorded separately, so that the literal is zero or +ve+   -- NB. Negative *primitive* literals are already handled by the lexer+   HsOverLit pos_lit          -> return (mkNPat (L loc pos_lit) Nothing)+   NegApp (L l (HsOverLit pos_lit)) _+                        -> return (mkNPat (L l pos_lit) (Just noSyntaxExpr))++   SectionR (L lb (HsVar (L _ bang))) e    -- (! x)+        | bang == bang_RDR+        -> do { bang_on <- extension bangPatEnabled+              ; if bang_on then do { e' <- checkLPat msg e+                                   ; addAnnotation loc AnnBang lb+                                   ; return  (BangPat e') }+                else parseErrorSDoc loc (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e0) }++   ELazyPat e         -> checkLPat msg e >>= (return . LazyPat)+   EAsPat n e         -> checkLPat msg e >>= (return . AsPat n)+   -- view pattern is well-formed if the pattern is+   EViewPat expr patE  -> checkLPat msg patE >>=+                            (return . (\p -> ViewPat expr p placeHolderType))+   ExprWithTySig e t   -> do e <- checkLPat msg e+                             return (SigPatIn e t)++   -- n+k patterns+   OpApp (L nloc (HsVar (L _ n))) (L _ (HsVar (L _ plus))) _+         (L lloc (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))+                      | extopt LangExt.NPlusKPatterns opts && (plus == plus_RDR)+                      -> return (mkNPlusKPat (L nloc n) (L lloc lit))++   OpApp l op _fix r  -> do l <- checkLPat msg l+                            r <- checkLPat msg r+                            case op of+                               L cl (HsVar (L _ c)) | isDataOcc (rdrNameOcc c)+                                      -> return (ConPatIn (L cl c) (InfixCon l r))+                               _ -> patFail msg loc e0++   HsPar e            -> checkLPat msg e >>= (return . ParPat)+   ExplicitList _ _ es  -> do ps <- mapM (checkLPat msg) es+                              return (ListPat ps placeHolderType Nothing)+   ExplicitPArr _ es  -> do ps <- mapM (checkLPat msg) es+                            return (PArrPat ps placeHolderType)++   ExplicitTuple es b+     | all tupArgPresent es  -> do ps <- mapM (checkLPat msg)+                                              [e | L _ (Present e) <- es]+                                   return (TuplePat ps b [])+     | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)++   ExplicitSum alt arity expr _ -> do+     p <- checkLPat msg expr+     return (SumPat p alt arity placeHolderType)++   RecordCon { rcon_con_name = c, rcon_flds = HsRecFields fs dd }+                        -> do fs <- mapM (checkPatField msg) fs+                              return (ConPatIn c (RecCon (HsRecFields fs dd)))+   HsSpliceE s | not (isTypedSplice s)+               -> return (SplicePat s)+   _           -> patFail msg loc e0++placeHolderPunRhs :: LHsExpr RdrName+-- The RHS of a punned record field will be filled in by the renamer+-- It's better not to make it an error, in case we want to print it when debugging+placeHolderPunRhs = noLoc (HsVar (noLoc pun_RDR))++plus_RDR, bang_RDR, pun_RDR :: RdrName+plus_RDR = mkUnqual varName (fsLit "+") -- Hack+bang_RDR = mkUnqual varName (fsLit "!") -- Hack+pun_RDR  = mkUnqual varName (fsLit "pun-right-hand-side")++checkPatField :: SDoc -> LHsRecField RdrName (LHsExpr RdrName)+              -> P (LHsRecField RdrName (LPat RdrName))+checkPatField msg (L l fld) = do p <- checkLPat msg (hsRecFieldArg fld)+                                 return (L l (fld { hsRecFieldArg = p }))++patFail :: SDoc -> SrcSpan -> HsExpr RdrName -> P a+patFail msg loc e = parseErrorSDoc loc err+    where err = text "Parse error in pattern:" <+> ppr e+             $$ msg+++---------------------------------------------------------------------------+-- Check Equation Syntax++checkValDef :: SDoc+            -> SrcStrictness+            -> LHsExpr RdrName+            -> Maybe (LHsType RdrName)+            -> Located (a,GRHSs RdrName (LHsExpr RdrName))+            -> P ([AddAnn],HsBind RdrName)++checkValDef msg _strictness lhs (Just sig) grhss+        -- x :: ty = rhs  parses as a *pattern* binding+  = checkPatBind msg (L (combineLocs lhs sig)+                        (ExprWithTySig lhs (mkLHsSigWcType sig))) grhss++checkValDef msg strictness lhs opt_sig g@(L l (_,grhss))+  = do  { mb_fun <- isFunLhs lhs+        ; case mb_fun of+            Just (fun, is_infix, pats, ann) ->+              checkFunBind msg strictness ann (getLoc lhs)+                           fun is_infix pats opt_sig (L l grhss)+            Nothing -> checkPatBind msg lhs g }++checkFunBind :: SDoc+             -> SrcStrictness+             -> [AddAnn]+             -> SrcSpan+             -> Located RdrName+             -> LexicalFixity+             -> [LHsExpr RdrName]+             -> Maybe (LHsType RdrName)+             -> Located (GRHSs RdrName (LHsExpr RdrName))+             -> P ([AddAnn],HsBind RdrName)+checkFunBind msg strictness ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)+  = do  ps <- checkPatterns msg pats+        let match_span = combineSrcSpans lhs_loc rhs_span+        -- Add back the annotations stripped from any HsPar values in the lhs+        -- mapM_ (\a -> a match_span) ann+        return (ann, makeFunBind fun+                  [L match_span (Match { m_ctxt = FunRhs fun is_infix strictness+                                       , m_pats = ps+                                       , m_type = opt_sig+                                       , m_grhss = grhss })])+        -- The span of the match covers the entire equation.+        -- That isn't quite right, but it'll do for now.++makeFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)]+            -> HsBind RdrName+-- Like HsUtils.mkFunBind, but we need to be able to set the fixity too+makeFunBind fn ms+  = FunBind { fun_id = fn,+              fun_matches = mkMatchGroup FromSource ms,+              fun_co_fn = idHsWrapper,+              bind_fvs = placeHolderNames,+              fun_tick = [] }++checkPatBind :: SDoc+             -> LHsExpr RdrName+             -> Located (a,GRHSs RdrName (LHsExpr RdrName))+             -> P ([AddAnn],HsBind RdrName)+checkPatBind msg lhs (L _ (_,grhss))+  = do  { lhs <- checkPattern msg lhs+        ; return ([],PatBind lhs grhss placeHolderType placeHolderNames+                    ([],[])) }++checkValSigLhs :: LHsExpr RdrName -> P (Located RdrName)+checkValSigLhs (L _ (HsVar lrdr@(L _ v)))+  | isUnqual v+  , not (isDataOcc (rdrNameOcc v))+  = return lrdr++checkValSigLhs lhs@(L l _)+  = parseErrorSDoc l ((text "Invalid type signature:" <+>+                       ppr lhs <+> text ":: ...")+                      $$ text hint)+  where+    hint | foreign_RDR `looks_like` lhs+         = "Perhaps you meant to use ForeignFunctionInterface?"+         | default_RDR `looks_like` lhs+         = "Perhaps you meant to use DefaultSignatures?"+         | pattern_RDR `looks_like` lhs+         = "Perhaps you meant to use PatternSynonyms?"+         | otherwise+         = "Should be of form <variable> :: <type>"++    -- A common error is to forget the ForeignFunctionInterface flag+    -- so check for that, and suggest.  cf Trac #3805+    -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword+    looks_like s (L _ (HsVar (L _ v))) = v == s+    looks_like s (L _ (HsApp lhs _))   = looks_like s lhs+    looks_like _ _                     = False++    foreign_RDR = mkUnqual varName (fsLit "foreign")+    default_RDR = mkUnqual varName (fsLit "default")+    pattern_RDR = mkUnqual varName (fsLit "pattern")+++checkDoAndIfThenElse :: LHsExpr RdrName+                     -> Bool+                     -> LHsExpr RdrName+                     -> Bool+                     -> LHsExpr RdrName+                     -> P ()+checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr+ | semiThen || semiElse+    = do pState <- getPState+         unless (extopt LangExt.DoAndIfThenElse (options pState)) $ do+             parseErrorSDoc (combineLocs guardExpr elseExpr)+                            (text "Unexpected semi-colons in conditional:"+                          $$ nest 4 expr+                          $$ text "Perhaps you meant to use DoAndIfThenElse?")+ | otherwise            = return ()+    where pprOptSemi True  = semi+          pprOptSemi False = empty+          expr = text "if"   <+> ppr guardExpr <> pprOptSemi semiThen <+>+                 text "then" <+> ppr thenExpr  <> pprOptSemi semiElse <+>+                 text "else" <+> ppr elseExpr+++        -- The parser left-associates, so there should+        -- not be any OpApps inside the e's+splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])+-- Splits (f ! g a b) into (f, [(! g), a, b])+splitBang (L _ (OpApp l_arg bang@(L _ (HsVar (L _ op))) _ r_arg))+  | op == bang_RDR = Just (l_arg, L l' (SectionR bang arg1) : argns)+  where+    l' = combineLocs bang arg1+    (arg1,argns) = split_bang r_arg []+    split_bang (L _ (HsApp f e)) es = split_bang f (e:es)+    split_bang e                 es = (e,es)+splitBang _ = Nothing++isFunLhs :: LHsExpr RdrName+      -> P (Maybe (Located RdrName, LexicalFixity, [LHsExpr RdrName],[AddAnn]))+-- A variable binding is parsed as a FunBind.+-- Just (fun, is_infix, arg_pats) if e is a function LHS+--+-- The whole LHS is parsed as a single expression.+-- Any infix operators on the LHS will parse left-associatively+-- E.g.         f !x y !z+--      will parse (rather strangely) as+--              (f ! x y) ! z+--      It's up to isFunLhs to sort out the mess+--+-- a .!. !b++isFunLhs e = go e [] []+ where+   go (L loc (HsVar (L _ f))) es ann+        | not (isRdrDataCon f)       = return (Just (L loc f, Prefix, es, ann))+   go (L _ (HsApp f e)) es       ann = go f (e:es) ann+   go (L l (HsPar e))   es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)++        -- Things of the form `!x` are also FunBinds+        -- See Note [Varieties of binding pattern matches]+   go (L _ (SectionR (L _ (HsVar (L _ bang))) (L l (HsVar (L _ var))))) [] ann+        | bang == bang_RDR+        , not (isRdrDataCon var)     = return (Just (L l var, Prefix, [], ann))++        -- For infix function defns, there should be only one infix *function*+        -- (though there may be infix *datacons* involved too).  So we don't+        -- need fixity info to figure out which function is being defined.+        --      a `K1` b `op` c `K2` d+        -- must parse as+        --      (a `K1` b) `op` (c `K2` d)+        -- The renamer checks later that the precedences would yield such a parse.+        --+        -- There is a complication to deal with bang patterns.+        --+        -- ToDo: what about this?+        --              x + 1 `op` y = ...++   go e@(L loc (OpApp l (L loc' (HsVar (L _ op))) fix r)) es ann+        | Just (e',es') <- splitBang e+        = do { bang_on <- extension bangPatEnabled+             ; if bang_on then go e' (es' ++ es) ann+               else return (Just (L loc' op, Infix, (l:r:es), ann)) }+                -- No bangs; behave just like the next case+        | not (isRdrDataCon op)         -- We have found the function!+        = return (Just (L loc' op, Infix, (l:r:es), ann))+        | otherwise                     -- Infix data con; keep going+        = do { mb_l <- go l es ann+             ; case mb_l of+                 Just (op', Infix, j : k : es', ann')+                   -> return (Just (op', Infix, j : op_app : es', ann'))+                   where+                     op_app = L loc (OpApp k (L loc' (HsVar (L loc' op))) fix r)+                 _ -> return Nothing }+   go _ _ _ = return Nothing+++-- | Transform btype_no_ops with strict_mark's into HsEqTy's+-- (((~a) ~b) c) ~d ==> ((~a) ~ (b c)) ~ d+splitTilde :: LHsType RdrName -> P (LHsType RdrName)+splitTilde t = go t+  where go (L loc (HsAppTy t1 t2))+          | L lo (HsBangTy (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) t2')+                                                                          <- t2+          = do+              moveAnnotations lo loc+              t1' <- go t1+              return (L loc (HsEqTy t1' t2'))+          | otherwise+          = do+              t1' <- go t1+              case t1' of+                (L lo (HsEqTy tl tr)) -> do+                  let lr = combineLocs tr t2+                  moveAnnotations lo loc+                  return (L loc (HsEqTy tl (L lr (HsAppTy tr t2))))+                t -> do+                  return (L loc (HsAppTy t t2))++        go t = return t+++-- | Transform tyapps with strict_marks into uses of twiddle+-- [~a, ~b, c, ~d] ==> (~a) ~ b c ~ d+splitTildeApps :: [LHsAppType RdrName] -> P [LHsAppType RdrName]+splitTildeApps []         = return []+splitTildeApps (t : rest) = do+  rest' <- concatMapM go rest+  return (t : rest')+  where go (L l (HsAppPrefix+            (L loc (HsBangTy+                    (HsSrcBang NoSourceText NoSrcUnpack SrcLazy)+                    ty))))+          = addAnnotation l AnnTilde tilde_loc >>+            return+              [L tilde_loc (HsAppInfix (L tilde_loc eqTyCon_RDR)),+               L l (HsAppPrefix ty)]+               -- NOTE: no annotation is attached to an HsAppPrefix, so the+               --       surrounding SrcSpan is not critical+          where+            tilde_loc = srcSpanFirstCharacter loc++        go t = return [t]++++---------------------------------------------------------------------------+-- Check for monad comprehensions+--+-- If the flag MonadComprehensions is set, return a `MonadComp' context,+-- otherwise use the usual `ListComp' context++checkMonadComp :: P (HsStmtContext Name)+checkMonadComp = do+    pState <- getPState+    return $ if extopt LangExt.MonadComprehensions (options pState)+                then MonadComp+                else ListComp++-- -------------------------------------------------------------------------+-- Checking arrow syntax.++-- We parse arrow syntax as expressions and check for valid syntax below,+-- converting the expression into a pattern at the same time.++checkCommand :: LHsExpr RdrName -> P (LHsCmd RdrName)+checkCommand lc = locMap checkCmd lc++locMap :: (SrcSpan -> a -> P b) -> Located a -> P (Located b)+locMap f (L l a) = f l a >>= (\b -> return $ L l b)++checkCmd :: SrcSpan -> HsExpr RdrName -> P (HsCmd RdrName)+checkCmd _ (HsArrApp e1 e2 ptt haat b) =+    return $ HsCmdArrApp e1 e2 ptt haat b+checkCmd _ (HsArrForm e mf args) =+    return $ HsCmdArrForm e Prefix mf args+checkCmd _ (HsApp e1 e2) =+    checkCommand e1 >>= (\c -> return $ HsCmdApp c e2)+checkCmd _ (HsLam mg) =+    checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam mg')+checkCmd _ (HsPar e) =+    checkCommand e >>= (\c -> return $ HsCmdPar c)+checkCmd _ (HsCase e mg) =+    checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase e mg')+checkCmd _ (HsIf cf ep et ee) = do+    pt <- checkCommand et+    pe <- checkCommand ee+    return $ HsCmdIf cf ep pt pe+checkCmd _ (HsLet lb e) =+    checkCommand e >>= (\c -> return $ HsCmdLet lb c)+checkCmd _ (HsDo DoExpr (L l stmts) ty) =+    mapM checkCmdLStmt stmts >>= (\ss -> return $ HsCmdDo (L l ss) ty)++checkCmd _ (OpApp eLeft op _fixity eRight) = do+    -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it+    c1 <- checkCommand eLeft+    c2 <- checkCommand eRight+    let arg1 = L (getLoc c1) $ HsCmdTop c1 placeHolderType placeHolderType []+        arg2 = L (getLoc c2) $ HsCmdTop c2 placeHolderType placeHolderType []+    return $ HsCmdArrForm op Infix Nothing [arg1, arg2]++checkCmd l e = cmdFail l e++checkCmdLStmt :: ExprLStmt RdrName -> P (CmdLStmt RdrName)+checkCmdLStmt = locMap checkCmdStmt++checkCmdStmt :: SrcSpan -> ExprStmt RdrName -> P (CmdStmt RdrName)+checkCmdStmt _ (LastStmt e s r) =+    checkCommand e >>= (\c -> return $ LastStmt c s r)+checkCmdStmt _ (BindStmt pat e b f t) =+    checkCommand e >>= (\c -> return $ BindStmt pat c b f t)+checkCmdStmt _ (BodyStmt e t g ty) =+    checkCommand e >>= (\c -> return $ BodyStmt c t g ty)+checkCmdStmt _ (LetStmt bnds) = return $ LetStmt bnds+checkCmdStmt _ stmt@(RecStmt { recS_stmts = stmts }) = do+    ss <- mapM checkCmdLStmt stmts+    return $ stmt { recS_stmts = ss }+checkCmdStmt l stmt = cmdStmtFail l stmt++checkCmdMatchGroup :: MatchGroup RdrName (LHsExpr RdrName) -> P (MatchGroup RdrName (LHsCmd RdrName))+checkCmdMatchGroup mg@(MG { mg_alts = L l ms }) = do+    ms' <- mapM (locMap $ const convert) ms+    return $ mg { mg_alts = L l ms' }+    where convert (Match mf pat mty grhss) = do+            grhss' <- checkCmdGRHSs grhss+            return $ Match mf pat mty grhss'++checkCmdGRHSs :: GRHSs RdrName (LHsExpr RdrName) -> P (GRHSs RdrName (LHsCmd RdrName))+checkCmdGRHSs (GRHSs grhss binds) = do+    grhss' <- mapM checkCmdGRHS grhss+    return $ GRHSs grhss' binds++checkCmdGRHS :: LGRHS RdrName (LHsExpr RdrName) -> P (LGRHS RdrName (LHsCmd RdrName))+checkCmdGRHS = locMap $ const convert+  where+    convert (GRHS stmts e) = do+        c <- checkCommand e+--        cmdStmts <- mapM checkCmdLStmt stmts+        return $ GRHS {- cmdStmts -} stmts c+++cmdFail :: SrcSpan -> HsExpr RdrName -> P a+cmdFail loc e = parseErrorSDoc loc (text "Parse error in command:" <+> ppr e)+cmdStmtFail :: SrcSpan -> Stmt RdrName (LHsExpr RdrName) -> P a+cmdStmtFail loc e = parseErrorSDoc loc+                    (text "Parse error in command statement:" <+> ppr e)++---------------------------------------------------------------------------+-- Miscellaneous utilities++checkPrecP :: Located (SourceText,Int) -> P (Located (SourceText,Int))+checkPrecP (L l (src,i))+ | 0 <= i && i <= maxPrecedence = return (L l (src,i))+ | otherwise+    = parseErrorSDoc l (text ("Precedence out of range: " ++ show i))++mkRecConstrOrUpdate+        :: LHsExpr RdrName+        -> SrcSpan+        -> ([LHsRecField RdrName (LHsExpr RdrName)], Bool)+        -> P (HsExpr RdrName)++mkRecConstrOrUpdate (L l (HsVar (L _ c))) _ (fs,dd)+  | isRdrDataCon c+  = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd))+mkRecConstrOrUpdate exp@(L l _) _ (fs,dd)+  | dd        = parseErrorSDoc l (text "You cannot use `..' in a record update")+  | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs))++mkRdrRecordUpd :: LHsExpr RdrName -> [LHsRecUpdField RdrName] -> HsExpr RdrName+mkRdrRecordUpd exp flds+  = RecordUpd { rupd_expr = exp+              , rupd_flds = flds+              , rupd_cons    = PlaceHolder, rupd_in_tys  = PlaceHolder+              , rupd_out_tys = PlaceHolder, rupd_wrap    = PlaceHolder }++mkRdrRecordCon :: Located RdrName -> HsRecordBinds RdrName -> HsExpr RdrName+mkRdrRecordCon con flds+  = RecordCon { rcon_con_name = con, rcon_flds = flds+              , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder }++mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg+mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }+mk_rec_fields fs True  = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }++mk_rec_upd_field :: HsRecField RdrName (LHsExpr RdrName) -> HsRecUpdField RdrName+mk_rec_upd_field (HsRecField (L loc (FieldOcc rdr _)) arg pun)+  = HsRecField (L loc (Unambiguous rdr PlaceHolder)) arg pun++mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation+               -> InlinePragma+-- The (Maybe Activation) is because the user can omit+-- the activation spec (and usually does)+mkInlinePragma src (inl, match_info) mb_act+  = InlinePragma { inl_src = src -- Note [Pragma source text] in BasicTypes+                 , inl_inline = inl+                 , inl_sat    = Nothing+                 , inl_act    = act+                 , inl_rule   = match_info }+  where+    act = case mb_act of+            Just act -> act+            Nothing  -> -- No phase specified+                        case inl of+                          NoInline -> NeverActive+                          _other   -> AlwaysActive++-----------------------------------------------------------------------------+-- utilities for foreign declarations++-- construct a foreign import declaration+--+mkImport :: Located CCallConv+         -> Located Safety+         -> (Located StringLiteral, Located RdrName, LHsSigType RdrName)+         -> P (HsDecl RdrName)+mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) =+    case cconv of+      L _ CCallConv          -> mkCImport+      L _ CApiConv           -> mkCImport+      L _ StdCallConv        -> mkCImport+      L _ PrimCallConv       -> mkOtherImport+      L _ JavaScriptCallConv -> mkOtherImport+  where+    -- Parse a C-like entity string of the following form:+    --   "[static] [chname] [&] [cid]" | "dynamic" | "wrapper"+    -- If 'cid' is missing, the function name 'v' is used instead as symbol+    -- name (cf section 8.5.1 in Haskell 2010 report).+    mkCImport = do+      let e = unpackFS entity+      case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of+        Nothing         -> parseErrorSDoc loc (text "Malformed entity string")+        Just importSpec -> returnSpec importSpec++    -- currently, all the other import conventions only support a symbol name in+    -- the entity string. If it is missing, we use the function name instead.+    mkOtherImport = returnSpec importSpec+      where+        entity'    = if nullFS entity+                        then mkExtName (unLoc v)+                        else entity+        funcTarget = CFunction (StaticTarget esrc entity' Nothing True)+        importSpec = CImport cconv safety Nothing funcTarget (L loc esrc)++    returnSpec spec = return $ ForD $ ForeignImport+          { fd_name   = v+          , fd_sig_ty = ty+          , fd_co     = noForeignImportCoercionYet+          , fd_fi     = spec+          }++++-- the string "foo" is ambiguous: either a header or a C identifier.  The+-- C identifier case comes first in the alternatives below, so we pick+-- that one.+parseCImport :: Located CCallConv -> Located Safety -> FastString -> String+             -> Located SourceText+             -> Maybe ForeignImport+parseCImport cconv safety nm str sourceText =+ listToMaybe $ map fst $ filter (null.snd) $+     readP_to_S parse str+ where+   parse = do+       skipSpaces+       r <- choice [+          string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)),+          string "wrapper" >> return (mk Nothing CWrapper),+          do optional (token "static" >> skipSpaces)+             ((mk Nothing <$> cimp nm) ++++              (do h <- munch1 hdr_char+                  skipSpaces+                  mk (Just (Header (SourceText h) (mkFastString h)))+                      <$> cimp nm))+         ]+       skipSpaces+       return r++   token str = do _ <- string str+                  toks <- look+                  case toks of+                      c : _+                       | id_char c -> pfail+                      _            -> return ()++   mk h n = CImport cconv safety h n sourceText++   hdr_char c = not (isSpace c) -- header files are filenames, which can contain+                                -- pretty much any char (depending on the platform),+                                -- so just accept any non-space character+   id_first_char c = isAlpha    c || c == '_'+   id_char       c = isAlphaNum c || c == '_'++   cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)+             +++ (do isFun <- case cconv of+                              L _ CApiConv ->+                                  option True+                                         (do token "value"+                                             skipSpaces+                                             return False)+                              _ -> return True+                     cid' <- cid+                     return (CFunction (StaticTarget NoSourceText cid'+                                        Nothing isFun)))+          where+            cid = return nm ++++                  (do c  <- satisfy id_first_char+                      cs <-  many (satisfy id_char)+                      return (mkFastString (c:cs)))+++-- construct a foreign export declaration+--+mkExport :: Located CCallConv+         -> (Located StringLiteral, Located RdrName, LHsSigType RdrName)+         -> P (HsDecl RdrName)+mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty)+ = return $ ForD $+   ForeignExport { fd_name = v, fd_sig_ty = ty+                 , fd_co = noForeignExportCoercionYet+                 , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv))+                                   (L le esrc) }+  where+    entity' | nullFS entity = mkExtName (unLoc v)+            | otherwise     = entity++-- Supplying the ext_name in a foreign decl is optional; if it+-- isn't there, the Haskell name is assumed. Note that no transformation+-- of the Haskell name is then performed, so if you foreign export (++),+-- it's external name will be "++". Too bad; it's important because we don't+-- want z-encoding (e.g. names with z's in them shouldn't be doubled)+--+mkExtName :: RdrName -> CLabelString+mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))++--------------------------------------------------------------------------------+-- Help with module system imports/exports++data ImpExpSubSpec = ImpExpAbs+                   | ImpExpAll+                   | ImpExpList [Located ImpExpQcSpec]+                   | ImpExpAllWith [Located ImpExpQcSpec]++data ImpExpQcSpec = ImpExpQcName (Located RdrName)+                  | ImpExpQcType (Located RdrName)+                  | ImpExpQcWildcard++mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE RdrName)+mkModuleImpExp (L l specname) subs =+  case subs of+    ImpExpAbs+      | isVarNameSpace (rdrNameSpace name)+                               -> return $ IEVar (L l (ieNameFromSpec specname))+      | otherwise              -> IEThingAbs . L l <$> nameT+    ImpExpAll                  -> IEThingAll . L l <$> nameT+    ImpExpList xs              ->+      (\newName -> IEThingWith (L l newName) NoIEWildcard (wrapped xs) [])+        <$> nameT+    ImpExpAllWith xs                       ->+      do allowed <- extension patternSynonymsEnabled+         if allowed+          then+            let withs = map unLoc xs+                pos   = maybe NoIEWildcard IEWildcard+                          (findIndex isImpExpQcWildcard withs)+                ies   = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs+            in (\newName -> IEThingWith (L l newName) pos ies []) <$> nameT+          else parseErrorSDoc l+            (text "Illegal export form (use PatternSynonyms to enable)")+  where+    name = ieNameVal specname+    nameT =+      if isVarNameSpace (rdrNameSpace name)+        then parseErrorSDoc l+              (text "Expecting a type constructor but found a variable,"+               <+> quotes (ppr name) <> text "."+              $$ if isSymOcc $ rdrNameOcc name+                   then text "If" <+> quotes (ppr name) <+> text "is a type constructor"+                    <+> text "then enable ExplicitNamespaces and use the 'type' keyword."+                   else empty)+        else return $ ieNameFromSpec specname++    ieNameVal (ImpExpQcName ln)  = unLoc ln+    ieNameVal (ImpExpQcType ln)  = unLoc ln+    ieNameVal (ImpExpQcWildcard) = panic "ieNameVal got wildcard"++    ieNameFromSpec (ImpExpQcName ln)  = IEName ln+    ieNameFromSpec (ImpExpQcType ln)  = IEType ln+    ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard"++    wrapped = map (\(L l x) -> L l (ieNameFromSpec x))++mkTypeImpExp :: Located RdrName   -- TcCls or Var name space+             -> P (Located RdrName)+mkTypeImpExp name =+  do allowed <- extension explicitNamespacesEnabled+     if allowed+       then return (fmap (`setRdrNameSpace` tcClsName) name)+       else parseErrorSDoc (getLoc name)+              (text "Illegal keyword 'type' (use ExplicitNamespaces to enable)")++checkImportSpec :: Located [LIE RdrName] -> P (Located [LIE RdrName])+checkImportSpec ie@(L _ specs) =+    case [l | (L l (IEThingWith _ (IEWildcard _) _ _)) <- specs] of+      [] -> return ie+      (l:_) -> importSpecError l+  where+    importSpecError l =+      parseErrorSDoc l+        (text "Illegal import form, this syntax can only be used to bundle"+        $+$ text "pattern synonyms with types in module exports.")++-- In the correct order+mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec)+mkImpExpSubSpec [] = return ([], ImpExpList [])+mkImpExpSubSpec [L _ ImpExpQcWildcard] =+  return ([], ImpExpAll)+mkImpExpSubSpec xs =+  if (any (isImpExpQcWildcard . unLoc) xs)+    then return $ ([], ImpExpAllWith xs)+    else return $ ([], ImpExpList xs)++isImpExpQcWildcard :: ImpExpQcSpec -> Bool+isImpExpQcWildcard ImpExpQcWildcard = True+isImpExpQcWildcard _                = False++-----------------------------------------------------------------------------+-- Misc utils++parseErrorSDoc :: SrcSpan -> SDoc -> P a+parseErrorSDoc span s = failSpanMsgP span s++data SumOrTuple+  = Sum ConTag Arity (LHsExpr RdrName)+  | Tuple [LHsTupArg RdrName]++mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P (HsExpr RdrName)++-- Tuple+mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple es boxity)++-- Sum+mkSumOrTuple Unboxed _ (Sum alt arity e) =+    return (ExplicitSum alt arity e PlaceHolder)+mkSumOrTuple Boxed l (Sum alt arity (L _ e)) =+    parseErrorSDoc l (hang (text "Boxed sums not supported:") 2 (ppr_boxed_sum alt arity e))+  where+    ppr_boxed_sum :: ConTag -> Arity -> HsExpr RdrName -> SDoc+    ppr_boxed_sum alt arity e =+      text "(" <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) <+> text ")"++    ppr_bars n = hsep (replicate n (Outputable.char '|'))
+ parser/cutils.c view
@@ -0,0 +1,47 @@+/*+These utility routines are used various+places in the GHC library.+*/++#include "Rts.h"++#include "HsFFI.h"++#include <string.h>++#ifdef HAVE_UNISTD_H+#include <unistd.h>+#endif++/*+Calling 'strlen' and 'memcpy' directly gives problems with GCC's inliner,+and causes gcc to require too many registers on x84+*/++HsInt+ghc_strlen( HsPtr a )+{+    return (strlen((char *)a));+}++HsInt+ghc_memcmp( HsPtr a1, HsPtr a2, HsInt len )+{+    return (memcmp((char *)a1, a2, len));+}++void+enableTimingStats( void )       /* called from the driver */+{+    RtsFlags.GcFlags.giveStats = ONELINE_GC_STATS;+}++void+setHeapSize( HsInt size )+{+    RtsFlags.GcFlags.heapSizeSuggestion = size / BLOCK_SIZE;+    if (RtsFlags.GcFlags.maxHeapSize != 0 &&+        RtsFlags.GcFlags.heapSizeSuggestion > RtsFlags.GcFlags.maxHeapSize) {+        RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion;+    }+}
+ parser/cutils.h view
@@ -0,0 +1,15 @@+/* -----------------------------------------------------------------------------+ *+ * Utility C functions.+ *+ * -------------------------------------------------------------------------- */++#include "HsFFI.h"++// Out-of-line string functions, see compiler/utils/FastString.hs+HsInt ghc_strlen( HsAddr a );+HsInt ghc_memcmp( HsAddr a1, HsAddr a2, HsInt len );+++void enableTimingStats( void );+void setHeapSize( HsInt size );
+ prelude/ForeignCall.hs view
@@ -0,0 +1,346 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[Foreign]{Foreign calls}+-}++{-# LANGUAGE DeriveDataTypeable #-}++module ForeignCall (+        ForeignCall(..), isSafeForeignCall,+        Safety(..), playSafe, playInterruptible,++        CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,+        CCallSpec(..),+        CCallTarget(..), isDynamicTarget,+        CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,++        Header(..), CType(..),+    ) where++import FastString+import Binary+import Outputable+import Module+import BasicTypes ( SourceText, pprWithSourceText )++import Data.Char+import Data.Data++{-+************************************************************************+*                                                                      *+\subsubsection{Data types}+*                                                                      *+************************************************************************+-}++newtype ForeignCall = CCall CCallSpec+  deriving Eq++isSafeForeignCall :: ForeignCall -> Bool+isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe++-- We may need more clues to distinguish foreign calls+-- but this simple printer will do for now+instance Outputable ForeignCall where+  ppr (CCall cc)  = ppr cc++data Safety+  = PlaySafe            -- Might invoke Haskell GC, or do a call back, or+                        -- switch threads, etc.  So make sure things are+                        -- tidy before the call. Additionally, in the threaded+                        -- RTS we arrange for the external call to be executed+                        -- by a separate OS thread, i.e., _concurrently_ to the+                        -- execution of other Haskell threads.++  | PlayInterruptible   -- Like PlaySafe, but additionally+                        -- the worker thread running this foreign call may+                        -- be unceremoniously killed, so it must be scheduled+                        -- on an unbound thread.++  | PlayRisky           -- None of the above can happen; the call will return+                        -- without interacting with the runtime system at all+  deriving ( Eq, Show, Data )+        -- Show used just for Show Lex.Token, I think++instance Outputable Safety where+  ppr PlaySafe = text "safe"+  ppr PlayInterruptible = text "interruptible"+  ppr PlayRisky = text "unsafe"++playSafe :: Safety -> Bool+playSafe PlaySafe = True+playSafe PlayInterruptible = True+playSafe PlayRisky = False++playInterruptible :: Safety -> Bool+playInterruptible PlayInterruptible = True+playInterruptible _ = False++{-+************************************************************************+*                                                                      *+\subsubsection{Calling C}+*                                                                      *+************************************************************************+-}++data CExportSpec+  = CExportStatic               -- foreign export ccall foo :: ty+        SourceText              -- of the CLabelString.+                                -- See note [Pragma source text] in BasicTypes+        CLabelString            -- C Name of exported function+        CCallConv+  deriving Data++data CCallSpec+  =  CCallSpec  CCallTarget     -- What to call+                CCallConv       -- Calling convention to use.+                Safety+  deriving( Eq )++-- The call target:++-- | How to call a particular function in C-land.+data CCallTarget+  -- An "unboxed" ccall# to named function in a particular package.+  = StaticTarget+        SourceText                -- of the CLabelString.+                                  -- See note [Pragma source text] in BasicTypes+        CLabelString                    -- C-land name of label.++        (Maybe UnitId)              -- What package the function is in.+                                        -- If Nothing, then it's taken to be in the current package.+                                        -- Note: This information is only used for PrimCalls on Windows.+                                        --       See CLabel.labelDynamic and CoreToStg.coreToStgApp+                                        --       for the difference in representation between PrimCalls+                                        --       and ForeignCalls. If the CCallTarget is representing+                                        --       a regular ForeignCall then it's safe to set this to Nothing.++  -- The first argument of the import is the name of a function pointer (an Addr#).+  --    Used when importing a label as "foreign import ccall "dynamic" ..."+        Bool                            -- True => really a function+                                        -- False => a value; only+                                        -- allowed in CAPI imports+  | DynamicTarget++  deriving( Eq, Data )++isDynamicTarget :: CCallTarget -> Bool+isDynamicTarget DynamicTarget = True+isDynamicTarget _             = False++{-+Stuff to do with calling convention:++ccall:          Caller allocates parameters, *and* deallocates them.++stdcall:        Caller allocates parameters, callee deallocates.+                Function name has @N after it, where N is number of arg bytes+                e.g.  _Foo@8. This convention is x86 (win32) specific.++See: http://www.programmersheaven.com/2/Calling-conventions+-}++-- any changes here should be replicated in  the CallConv type in template haskell+data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv | JavaScriptCallConv+  deriving (Eq, Data)++instance Outputable CCallConv where+  ppr StdCallConv = text "stdcall"+  ppr CCallConv   = text "ccall"+  ppr CApiConv    = text "capi"+  ppr PrimCallConv = text "prim"+  ppr JavaScriptCallConv = text "javascript"++defaultCCallConv :: CCallConv+defaultCCallConv = CCallConv++ccallConvToInt :: CCallConv -> Int+ccallConvToInt StdCallConv = 0+ccallConvToInt CCallConv   = 1+ccallConvToInt CApiConv    = panic "ccallConvToInt CApiConv"+ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv"+ccallConvToInt JavaScriptCallConv = panic "ccallConvToInt JavaScriptCallConv"++{-+Generate the gcc attribute corresponding to the given+calling convention (used by PprAbsC):+-}++ccallConvAttribute :: CCallConv -> SDoc+ccallConvAttribute StdCallConv       = text "__attribute__((__stdcall__))"+ccallConvAttribute CCallConv         = empty+ccallConvAttribute CApiConv          = empty+ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv"+ccallConvAttribute JavaScriptCallConv = panic "ccallConvAttribute JavaScriptCallConv"++type CLabelString = FastString          -- A C label, completely unencoded++pprCLabelString :: CLabelString -> SDoc+pprCLabelString lbl = ftext lbl++isCLabelString :: CLabelString -> Bool  -- Checks to see if this is a valid C label+isCLabelString lbl+  = all ok (unpackFS lbl)+  where+    ok c = isAlphaNum c || c == '_' || c == '.'+        -- The '.' appears in e.g. "foo.so" in the+        -- module part of a ExtName.  Maybe it should be separate++-- Printing into C files:++instance Outputable CExportSpec where+  ppr (CExportStatic _ str _) = pprCLabelString str++instance Outputable CCallSpec where+  ppr (CCallSpec fun cconv safety)+    = hcat [ ifPprDebug callconv, ppr_fun fun ]+    where+      callconv = text "{-" <> ppr cconv <> text "-}"++      gc_suf | playSafe safety = text "_GC"+             | otherwise       = empty++      ppr_fun (StaticTarget st _fn mPkgId isFun)+        = text (if isFun then "__pkg_ccall"+                         else "__pkg_ccall_value")+       <> gc_suf+       <+> (case mPkgId of+            Nothing -> empty+            Just pkgId -> ppr pkgId)+       <+> (pprWithSourceText st empty)++      ppr_fun DynamicTarget+        = text "__dyn_ccall" <> gc_suf <+> text "\"\""++-- The filename for a C header file+-- Note [Pragma source text] in BasicTypes+data Header = Header SourceText FastString+    deriving (Eq, Data)++instance Outputable Header where+    ppr (Header st h) = pprWithSourceText st (doubleQuotes $ ppr h)++-- | A C type, used in CAPI FFI calls+--+--  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CTYPE'@,+--        'ApiAnnotation.AnnHeader','ApiAnnotation.AnnVal',+--        'ApiAnnotation.AnnClose' @'\#-}'@,++-- For details on above see note [Api annotations] in ApiAnnotation+data CType = CType SourceText -- Note [Pragma source text] in BasicTypes+                   (Maybe Header) -- header to include for this type+                   (SourceText,FastString) -- the type itself+    deriving (Eq, Data)++instance Outputable CType where+    ppr (CType stp mh (stct,ct))+      = pprWithSourceText stp (text "{-# CTYPE") <+> hDoc+        <+> pprWithSourceText stct (doubleQuotes (ftext ct)) <+> text "#-}"+        where hDoc = case mh of+                     Nothing -> empty+                     Just h -> ppr h++{-+************************************************************************+*                                                                      *+\subsubsection{Misc}+*                                                                      *+************************************************************************+-}++instance Binary ForeignCall where+    put_ bh (CCall aa) = put_ bh aa+    get bh = do aa <- get bh; return (CCall aa)++instance Binary Safety where+    put_ bh PlaySafe = do+            putByte bh 0+    put_ bh PlayInterruptible = do+            putByte bh 1+    put_ bh PlayRisky = do+            putByte bh 2+    get bh = do+            h <- getByte bh+            case h of+              0 -> do return PlaySafe+              1 -> do return PlayInterruptible+              _ -> do return PlayRisky++instance Binary CExportSpec where+    put_ bh (CExportStatic ss aa ab) = do+            put_ bh ss+            put_ bh aa+            put_ bh ab+    get bh = do+          ss <- get bh+          aa <- get bh+          ab <- get bh+          return (CExportStatic ss aa ab)++instance Binary CCallSpec where+    put_ bh (CCallSpec aa ab ac) = do+            put_ bh aa+            put_ bh ab+            put_ bh ac+    get bh = do+          aa <- get bh+          ab <- get bh+          ac <- get bh+          return (CCallSpec aa ab ac)++instance Binary CCallTarget where+    put_ bh (StaticTarget ss aa ab ac) = do+            putByte bh 0+            put_ bh ss+            put_ bh aa+            put_ bh ab+            put_ bh ac+    put_ bh DynamicTarget = do+            putByte bh 1+    get bh = do+            h <- getByte bh+            case h of+              0 -> do ss <- get bh+                      aa <- get bh+                      ab <- get bh+                      ac <- get bh+                      return (StaticTarget ss aa ab ac)+              _ -> do return DynamicTarget++instance Binary CCallConv where+    put_ bh CCallConv = do+            putByte bh 0+    put_ bh StdCallConv = do+            putByte bh 1+    put_ bh PrimCallConv = do+            putByte bh 2+    put_ bh CApiConv = do+            putByte bh 3+    put_ bh JavaScriptCallConv = do+            putByte bh 4+    get bh = do+            h <- getByte bh+            case h of+              0 -> do return CCallConv+              1 -> do return StdCallConv+              2 -> do return PrimCallConv+              3 -> do return CApiConv+              _ -> do return JavaScriptCallConv++instance Binary CType where+    put_ bh (CType s mh fs) = do put_ bh s+                                 put_ bh mh+                                 put_ bh fs+    get bh = do s  <- get bh+                mh <- get bh+                fs <- get bh+                return (CType s mh fs)++instance Binary Header where+    put_ bh (Header s h) = put_ bh s >> put_ bh h+    get bh = do s <- get bh+                h <- get bh+                return (Header s h)
+ prelude/KnownUniques.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE CPP #-}++-- | This is where we define a mapping from Uniques to their associated+-- known-key Names for things associated with tuples and sums. We use this+-- mapping while deserializing known-key Names in interface file symbol tables,+-- which are encoded as their Unique. See Note [Symbol table representation of+-- names] for details.+--++module KnownUniques+    ( -- * Looking up known-key names+      knownUniqueName++      -- * Getting the 'Unique's of 'Name's+      -- ** Anonymous sums+    , mkSumTyConUnique+    , mkSumDataConUnique+      -- ** Tuples+      -- *** Vanilla+    , mkTupleTyConUnique+    , mkTupleDataConUnique+      -- *** Constraint+    , mkCTupleTyConUnique+    , mkCTupleDataConUnique+    ) where++#include "HsVersions.h"++import TysWiredIn+import TyCon+import DataCon+import Id+import BasicTypes+import Outputable+import Unique+import Name+import Util++import Data.Bits+import Data.Maybe++-- | Get the 'Name' associated with a known-key 'Unique'.+knownUniqueName :: Unique -> Maybe Name+knownUniqueName u =+    case tag of+      'z' -> Just $ getUnboxedSumName n+      '4' -> Just $ getTupleTyConName Boxed n+      '5' -> Just $ getTupleTyConName Unboxed n+      '7' -> Just $ getTupleDataConName Boxed n+      '8' -> Just $ getTupleDataConName Unboxed n+      'k' -> Just $ getCTupleTyConName n+      'm' -> Just $ getCTupleDataConUnique n+      _   -> Nothing+  where+    (tag, n) = unpkUnique u++--------------------------------------------------+-- Anonymous sums+--+-- Sum arities start from 2. The encoding is a bit funny: we break up the+-- integral part into bitfields for the arity, an alternative index (which is+-- taken to be 0xff in the case of the TyCon), and, in the case of a datacon, a+-- tag (used to identify the sum's TypeRep binding).+--+-- This layout is chosen to remain compatible with the usual unique allocation+-- for wired-in data constructors described in Unique.hs+--+-- TyCon for sum of arity k:+--   00000000 kkkkkkkk 11111100++-- TypeRep of TyCon for sum of arity k:+--   00000000 kkkkkkkk 11111101+--+-- DataCon for sum of arity k and alternative n (zero-based):+--   00000000 kkkkkkkk nnnnnn00+--+-- TypeRep for sum DataCon of arity k and alternative n (zero-based):+--   00000000 kkkkkkkk nnnnnn10++mkSumTyConUnique :: Arity -> Unique+mkSumTyConUnique arity =+    ASSERT(arity < 0xff)+    mkUnique 'z' (arity `shiftL` 8 .|. 0xfc)++mkSumDataConUnique :: ConTagZ -> Arity -> Unique+mkSumDataConUnique alt arity+  | alt >= arity+  = panic ("mkSumDataConUnique: " ++ show alt ++ " >= " ++ show arity)+  | otherwise+  = mkUnique 'z' (arity `shiftL` 8 + alt `shiftL` 2) {- skip the tycon -}++getUnboxedSumName :: Int -> Name+getUnboxedSumName n+  | n .&. 0xfc == 0xfc+  = case tag of+      0x0 -> tyConName $ sumTyCon arity+      0x1 -> getRep $ sumTyCon arity+      _   -> pprPanic "getUnboxedSumName: invalid tag" (ppr tag)+  | tag == 0x0+  = dataConName $ sumDataCon (alt + 1) arity+  | tag == 0x2+  = getRep $ promoteDataCon $ sumDataCon (alt + 1) arity+  | otherwise+  = pprPanic "getUnboxedSumName" (ppr n)+  where+    arity = n `shiftR` 8+    alt = (n .&. 0xff) `shiftR` 2+    tag = 0x3 .&. n+    getRep tycon =+        fromMaybe (pprPanic "getUnboxedSumName" (ppr tycon))+        $ tyConRepName_maybe tycon++-- Note [Uniques for tuple type and data constructors]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Wired-in type constructor keys occupy *two* slots:+--    * u: the TyCon itself+--    * u+1: the TyConRepName of the TyCon+--+-- Wired-in tuple data constructor keys occupy *three* slots:+--    * u: the DataCon itself+--    * u+1: its worker Id+--    * u+2: the TyConRepName of the promoted TyCon++--------------------------------------------------+-- Constraint tuples++mkCTupleTyConUnique :: Arity -> Unique+mkCTupleTyConUnique a = mkUnique 'k' (2*a)++mkCTupleDataConUnique :: Arity -> Unique+mkCTupleDataConUnique a = mkUnique 'm' (3*a)++getCTupleTyConName :: Int -> Name+getCTupleTyConName n =+    case n `divMod` 2 of+      (arity, 0) -> cTupleTyConName arity+      (arity, 1) -> mkPrelTyConRepName $ cTupleTyConName arity+      _          -> panic "getCTupleTyConName: impossible"++getCTupleDataConUnique :: Int -> Name+getCTupleDataConUnique n =+    case n `divMod` 3 of+      (arity,  0) -> cTupleDataConName arity+      (_arity, 1) -> panic "getCTupleDataConName: no worker"+      (arity,  2) -> mkPrelTyConRepName $ cTupleDataConName arity+      _           -> panic "getCTupleDataConName: impossible"++--------------------------------------------------+-- Normal tuples++mkTupleDataConUnique :: Boxity -> Arity -> Unique+mkTupleDataConUnique Boxed          a = mkUnique '7' (3*a)    -- may be used in C labels+mkTupleDataConUnique Unboxed        a = mkUnique '8' (3*a)++mkTupleTyConUnique :: Boxity -> Arity -> Unique+mkTupleTyConUnique Boxed           a  = mkUnique '4' (2*a)+mkTupleTyConUnique Unboxed         a  = mkUnique '5' (2*a)++getTupleTyConName :: Boxity -> Int -> Name+getTupleTyConName boxity n =+    case n `divMod` 2 of+      (arity, 0) -> tyConName $ tupleTyCon boxity arity+      (arity, 1) -> fromMaybe (panic "getTupleTyConName")+                    $ tyConRepName_maybe $ tupleTyCon boxity arity+      _          -> panic "getTupleTyConName: impossible"++getTupleDataConName :: Boxity -> Int -> Name+getTupleDataConName boxity n =+    case n `divMod` 3 of+      (arity, 0) -> dataConName $ tupleDataCon boxity arity+      (arity, 1) -> idName $ dataConWorkId $ tupleDataCon boxity arity+      (arity, 2) -> fromMaybe (panic "getTupleDataCon")+                    $ tyConRepName_maybe $ promotedTupleDataCon boxity arity+      _          -> panic "getTupleDataConName: impossible"
+ prelude/KnownUniques.hs-boot view
@@ -0,0 +1,17 @@+module KnownUniques where++import Unique+import Name+import BasicTypes++-- Needed by TysWiredIn+knownUniqueName :: Unique -> Maybe Name++mkSumTyConUnique :: Arity -> Unique+mkSumDataConUnique :: ConTagZ -> Arity -> Unique++mkCTupleTyConUnique :: Arity -> Unique+mkCTupleDataConUnique :: Arity -> Unique++mkTupleTyConUnique :: Boxity -> Arity -> Unique+mkTupleDataConUnique :: Boxity -> Arity -> Unique
+ prelude/PrelInfo.hs view
@@ -0,0 +1,266 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++-}++{-# LANGUAGE CPP #-}++-- | The @PrelInfo@ interface to the compiler's prelude knowledge.+--+-- This module serves as the central gathering point for names which the+-- compiler knows something about. This includes functions for,+--+--  * discerning whether a 'Name' is known-key+--+--  * given a 'Unique', looking up its corresponding known-key 'Name'+--+-- See Note [Known-key names] and Note [About wired-in things] for information+-- about the two types of prelude things in GHC.+--+module PrelInfo (+        -- * Known-key names+        isKnownKeyName,+        lookupKnownKeyName,++        -- ** Internal use+        -- | 'knownKeyNames' is exported to seed the original name cache only;+        -- if you find yourself wanting to look at it you might consider using+        -- 'lookupKnownKeyName' or 'isKnownKeyName'.+        knownKeyNames,++        -- * Miscellaneous+        wiredInIds, ghcPrimIds,+        primOpRules, builtinRules,++        ghcPrimExports,+        primOpId,++        -- * Random other things+        maybeCharLikeCon, maybeIntLikeCon,++        -- * Class categories+        isNumericClass, isStandardClass++    ) where++#include "HsVersions.h"++import KnownUniques+import Unique           ( isValidKnownKeyUnique )++import ConLike          ( ConLike(..) )+import THNames          ( templateHaskellNames )+import PrelNames+import PrelRules+import Avail+import PrimOp+import DataCon+import Id+import Name+import NameEnv+import MkId+import TysPrim+import TysWiredIn+import HscTypes+import Class+import TyCon+import UniqFM+import Util+import Panic+import {-# SOURCE #-} TcTypeNats ( typeNatTyCons )++import Control.Applicative ((<|>))+import Data.List        ( intercalate )+import Data.Array+import Data.Maybe++{-+************************************************************************+*                                                                      *+\subsection[builtinNameInfo]{Lookup built-in names}+*                                                                      *+************************************************************************++Note [About wired-in things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* Wired-in things are Ids\/TyCons that are completely known to the compiler.+  They are global values in GHC, (e.g.  listTyCon :: TyCon).++* A wired in Name contains the thing itself inside the Name:+        see Name.wiredInNameTyThing_maybe+  (E.g. listTyConName contains listTyCon.++* The name cache is initialised with (the names of) all wired-in things+  (except tuples and sums; see Note [Known-])++* The type environment itself contains no wired in things. The type+  checker sees if the Name is wired in before looking up the name in+  the type environment.++* MkIface prunes out wired-in things before putting them in an interface file.+  So interface files never contain wired-in things.+-}+++-- | This list is used to ensure that when you say "Prelude.map" in your source+-- code, or in an interface file, you get a Name with the correct known key (See+-- Note [Known-key names] in PrelNames)+knownKeyNames :: [Name]+knownKeyNames+  | debugIsOn+  , Just badNamesStr <- knownKeyNamesOkay all_names+  = panic ("badAllKnownKeyNames:\n" ++ badNamesStr)+       -- NB: We can't use ppr here, because this is sometimes evaluated in a+       -- context where there are no DynFlags available, leading to a cryptic+       -- "<<details unavailable>>" error. (This seems to happen only in the+       -- stage 2 compiler, for reasons I [Richard] have no clue of.)+  | otherwise+  = all_names+  where+    all_names =+      concat [ wired_tycon_kk_names funTyCon+             , concatMap wired_tycon_kk_names primTyCons++             , concatMap wired_tycon_kk_names wiredInTyCons+               -- Does not include tuples++             , concatMap wired_tycon_kk_names typeNatTyCons++             , map idName wiredInIds+             , map (idName . primOpId) allThePrimOps+             , basicKnownKeyNames+             , templateHaskellNames+             ]+    -- All of the names associated with a wired-in TyCon.+    -- This includes the TyCon itself, its DataCons and promoted TyCons.+    wired_tycon_kk_names :: TyCon -> [Name]+    wired_tycon_kk_names tc =+        tyConName tc : (rep_names tc ++ implicits)+      where implicits = concatMap thing_kk_names (implicitTyConThings tc)++    wired_datacon_kk_names :: DataCon -> [Name]+    wired_datacon_kk_names dc =+      dataConName dc : rep_names (promoteDataCon dc)++    thing_kk_names :: TyThing -> [Name]+    thing_kk_names (ATyCon tc)                 = wired_tycon_kk_names tc+    thing_kk_names (AConLike (RealDataCon dc)) = wired_datacon_kk_names dc+    thing_kk_names thing                       = [getName thing]++    -- The TyConRepName for a known-key TyCon has a known key,+    -- but isn't itself an implicit thing.  Yurgh.+    -- NB: if any of the wired-in TyCons had record fields, the record+    --     field names would be in a similar situation.  Ditto class ops.+    --     But it happens that there aren't any+    rep_names tc = case tyConRepName_maybe tc of+                        Just n  -> [n]+                        Nothing -> []++-- | Check the known-key names list of consistency.+knownKeyNamesOkay :: [Name] -> Maybe String+knownKeyNamesOkay all_names+  | ns@(_:_) <- filter (not . isValidKnownKeyUnique . getUnique) all_names+  = Just $ "    Out-of-range known-key uniques: ["+        ++ intercalate ", " (map (occNameString . nameOccName) ns) +++         "]"+  | null badNamesPairs+  = Nothing+  | otherwise+  = Just badNamesStr+  where+    namesEnv      = foldl (\m n -> extendNameEnv_Acc (:) singleton m n n)+                          emptyUFM all_names+    badNamesEnv   = filterNameEnv (\ns -> length ns > 1) namesEnv+    badNamesPairs = nonDetUFMToList badNamesEnv+      -- It's OK to use nonDetUFMToList here because the ordering only affects+      -- the message when we get a panic+    badNamesStrs  = map pairToStr badNamesPairs+    badNamesStr   = unlines badNamesStrs++    pairToStr (uniq, ns) = "        " +++                           show uniq +++                           ": [" +++                           intercalate ", " (map (occNameString . nameOccName) ns) +++                           "]"++-- | Given a 'Unique' lookup its associated 'Name' if it corresponds to a+-- known-key thing.+lookupKnownKeyName :: Unique -> Maybe Name+lookupKnownKeyName u =+    knownUniqueName u <|> lookupUFM knownKeysMap u++-- | Is a 'Name' known-key?+isKnownKeyName :: Name -> Bool+isKnownKeyName n =+    isJust (knownUniqueName $ nameUnique n) || elemUFM n knownKeysMap++knownKeysMap :: UniqFM Name+knownKeysMap = listToUFM [ (nameUnique n, n) | n <- knownKeyNames ]++{-+We let a lot of "non-standard" values be visible, so that we can make+sense of them in interface pragmas. It's cool, though they all have+"non-standard" names, so they won't get past the parser in user code.++************************************************************************+*                                                                      *+                PrimOpIds+*                                                                      *+************************************************************************+-}++primOpIds :: Array Int Id+-- A cache of the PrimOp Ids, indexed by PrimOp tag+primOpIds = array (1,maxPrimOpTag) [ (primOpTag op, mkPrimOpId op)+                                   | op <- allThePrimOps ]++primOpId :: PrimOp -> Id+primOpId op = primOpIds ! primOpTag op++{-+************************************************************************+*                                                                      *+            Export lists for pseudo-modules (GHC.Prim)+*                                                                      *+************************************************************************++GHC.Prim "exports" all the primops and primitive types, some+wired-in Ids.+-}++ghcPrimExports :: [IfaceExport]+ghcPrimExports+ = map (avail . idName) ghcPrimIds +++   map (avail . idName . primOpId) allThePrimOps +++   [ AvailTC n [n] []+   | tc <- funTyCon : primTyCons, let n = tyConName tc  ]++{-+************************************************************************+*                                                                      *+            Built-in keys+*                                                                      *+************************************************************************++ToDo: make it do the ``like'' part properly (as in 0.26 and before).+-}++maybeCharLikeCon, maybeIntLikeCon :: DataCon -> Bool+maybeCharLikeCon con = con `hasKey` charDataConKey+maybeIntLikeCon  con = con `hasKey` intDataConKey++{-+************************************************************************+*                                                                      *+            Class predicates+*                                                                      *+************************************************************************+-}++isNumericClass, isStandardClass :: Class -> Bool++isNumericClass     clas = classKey clas `is_elem` numericClassKeys+isStandardClass    clas = classKey clas `is_elem` standardClassKeys++is_elem :: Eq a => a -> [a] -> Bool+is_elem = isIn "is_X_Class"
+ prelude/PrelNames.hs view
@@ -0,0 +1,2457 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[PrelNames]{Definitions of prelude modules and names}+++Nota Bene: all Names defined in here should come from the base package++ - ModuleNames for prelude modules,+        e.g.    pREL_BASE_Name :: ModuleName++ - Modules for prelude modules+        e.g.    pREL_Base :: Module++ - Uniques for Ids, DataCons, TyCons and Classes that the compiler+   "knows about" in some way+        e.g.    intTyConKey :: Unique+                minusClassOpKey :: Unique++ - Names for Ids, DataCons, TyCons and Classes that the compiler+   "knows about" in some way+        e.g.    intTyConName :: Name+                minusName    :: Name+   One of these Names contains+        (a) the module and occurrence name of the thing+        (b) its Unique+   The may way the compiler "knows about" one of these things is+   where the type checker or desugarer needs to look it up. For+   example, when desugaring list comprehensions the desugarer+   needs to conjure up 'foldr'.  It does this by looking up+   foldrName in the environment.++ - RdrNames for Ids, DataCons etc that the compiler may emit into+   generated code (e.g. for deriving).  It's not necessary to know+   the uniques for these guys, only their names+++Note [Known-key names]+~~~~~~~~~~~~~~~~~~~~~~+It is *very* important that the compiler gives wired-in things and+things with "known-key" names the correct Uniques wherever they+occur. We have to be careful about this in exactly two places:++  1. When we parse some source code, renaming the AST better yield an+     AST whose Names have the correct uniques++  2. When we read an interface file, the read-in gubbins better have+     the right uniques++This is accomplished through a combination of mechanisms:++  1. When parsing source code, the RdrName-decorated AST has some+     RdrNames which are Exact. These are wired-in RdrNames where the+     we could directly tell from the parsed syntax what Name to+     use. For example, when we parse a [] in a type we can just insert+     an Exact RdrName Name with the listTyConKey.++     Currently, I believe this is just an optimisation: it would be+     equally valid to just output Orig RdrNames that correctly record+     the module etc we expect the final Name to come from. However,+     were we to eliminate isBuiltInOcc_maybe it would become essential+     (see point 3).++  2. The knownKeyNames (which consist of the basicKnownKeyNames from+     the module, and those names reachable via the wired-in stuff from+     TysWiredIn) are used to initialise the "OrigNameCache" in+     IfaceEnv.  This initialization ensures that when the type checker+     or renamer (both of which use IfaceEnv) look up an original name+     (i.e. a pair of a Module and an OccName) for a known-key name+     they get the correct Unique.++     This is the most important mechanism for ensuring that known-key+     stuff gets the right Unique, and is why it is so important to+     place your known-key names in the appropriate lists.++  3. For "infinite families" of known-key names (i.e. tuples and sums), we+     have to be extra careful. Because there are an infinite number of+     these things, we cannot add them to the list of known-key names+     used to initialise the OrigNameCache. Instead, we have to+     rely on never having to look them up in that cache. See+     Note [Infinite families of known-key names] for details.+++Note [Infinite families of known-key names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Infinite families of known-key things (e.g. tuples and sums) pose a tricky+problem: we can't add them to the knownKeyNames finite map which we use to+ensure that, e.g., a reference to (,) gets assigned the right unique (if this+doesn't sound familiar see Note [Known-key names] above).++We instead handle tuples and sums separately from the "vanilla" known-key+things,++  a) The parser recognises them specially and generates an Exact Name (hence not+     looked up in the orig-name cache)++  b) The known infinite families of names are specially serialised by+     BinIface.putName, with that special treatment detected when we read back to+     ensure that we get back to the correct uniques. See Note [Symbol table+     representation of names] in BinIface and Note [How tuples work] in+     TysWiredIn.++Most of the infinite families cannot occur in source code, so mechanisms (a) and (b)+suffice to ensure that they always have the right Unique. In particular,+implicit param TyCon names, constraint tuples and Any TyCons cannot be mentioned+by the user. For those things that *can* appear in source programs,++  c) IfaceEnv.lookupOrigNameCache uses isBuiltInOcc_maybe to map built-in syntax+     directly onto the corresponding name, rather than trying to find it in the+     original-name cache.++     See also Note [Built-in syntax and the OrigNameCache]+-}++{-# LANGUAGE CPP #-}++module PrelNames (+        Unique, Uniquable(..), hasKey,  -- Re-exported for convenience++        -----------------------------------------------------------+        module PrelNames,       -- A huge bunch of (a) Names,  e.g. intTyConName+                                --                 (b) Uniques e.g. intTyConKey+                                --                 (c) Groups of classes and types+                                --                 (d) miscellaneous things+                                -- So many that we export them all+    ) where++#include "HsVersions.h"++import Module+import OccName+import RdrName+import Unique+import Name+import SrcLoc+import FastString+import Config ( cIntegerLibraryType, IntegerLibrary(..) )+import Panic ( panic )++{-+************************************************************************+*                                                                      *+     allNameStrings+*                                                                      *+************************************************************************+-}++allNameStrings :: [String]+-- Infinite list of a,b,c...z, aa, ab, ac, ... etc+allNameStrings = [ c:cs | cs <- "" : allNameStrings, c <- ['a'..'z'] ]++{-+************************************************************************+*                                                                      *+\subsection{Local Names}+*                                                                      *+************************************************************************++This *local* name is used by the interactive stuff+-}++itName :: Unique -> SrcSpan -> Name+itName uniq loc = mkInternalName uniq (mkOccNameFS varName (fsLit "it")) loc++-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly+-- during compiler debugging.+mkUnboundName :: OccName -> Name+mkUnboundName occ = mkInternalName unboundKey occ noSrcSpan++isUnboundName :: Name -> Bool+isUnboundName name = name `hasKey` unboundKey++{-+************************************************************************+*                                                                      *+\subsection{Known key Names}+*                                                                      *+************************************************************************++This section tells what the compiler knows about the association of+names with uniques.  These ones are the *non* wired-in ones.  The+wired in ones are defined in TysWiredIn etc.+-}++basicKnownKeyNames :: [Name]+basicKnownKeyNames+ = genericTyConNames+ ++ [   --  Classes.  *Must* include:+        --      classes that are grabbed by key (e.g., eqClassKey)+        --      classes in "Class.standardClassKeys" (quite a few)+        eqClassName,                    -- mentioned, derivable+        ordClassName,                   -- derivable+        boundedClassName,               -- derivable+        numClassName,                   -- mentioned, numeric+        enumClassName,                  -- derivable+        monadClassName,+        functorClassName,+        realClassName,                  -- numeric+        integralClassName,              -- numeric+        fractionalClassName,            -- numeric+        floatingClassName,              -- numeric+        realFracClassName,              -- numeric+        realFloatClassName,             -- numeric+        dataClassName,+        isStringClassName,+        applicativeClassName,+        alternativeClassName,+        foldableClassName,+        traversableClassName,+        semigroupClassName, sappendName,+        monoidClassName, memptyName, mappendName, mconcatName,++        -- The IO type+        -- See Note [TyConRepNames for non-wired-in TyCons]+        ioTyConName, ioDataConName,+        runMainIOName,++        -- Type representation types+        trModuleTyConName, trModuleDataConName,+        trNameTyConName, trNameSDataConName, trNameDDataConName,+        trTyConTyConName, trTyConDataConName,++        -- Typeable+        typeableClassName,+        typeRepTyConName,+        someTypeRepTyConName,+        someTypeRepDataConName,+        kindRepTyConName,+        kindRepTyConAppDataConName,+        kindRepVarDataConName,+        kindRepAppDataConName,+        kindRepFunDataConName,+        kindRepTYPEDataConName,+        kindRepTypeLitSDataConName,+        kindRepTypeLitDDataConName,+        typeLitSortTyConName,+        typeLitSymbolDataConName,+        typeLitNatDataConName,+        typeRepIdName,+        mkTrConName,+        mkTrAppName,+        mkTrFunName,+        typeSymbolTypeRepName, typeNatTypeRepName,+        trGhcPrimModuleName,++        -- KindReps for common cases+        starKindRepName,+        starArrStarKindRepName,+        starArrStarArrStarKindRepName,++        -- Dynamic+        toDynName,++        -- Numeric stuff+        negateName, minusName, geName, eqName,++        -- Conversion functions+        rationalTyConName,+        ratioTyConName, ratioDataConName,+        fromRationalName, fromIntegerName,+        toIntegerName, toRationalName,+        fromIntegralName, realToFracName,++        -- Int# stuff+        divIntName, modIntName,++        -- String stuff+        fromStringName,++        -- Enum stuff+        enumFromName, enumFromThenName,+        enumFromThenToName, enumFromToName,++        -- Applicative stuff+        pureAName, apAName, thenAName,++        -- Functor stuff+        fmapName,++        -- Monad stuff+        thenIOName, bindIOName, returnIOName, failIOName, bindMName, thenMName,+        returnMName, joinMName,++        -- MonadFail+        monadFailClassName, failMName, failMName_preMFP,++        -- MonadFix+        monadFixClassName, mfixName,++        -- Arrow stuff+        arrAName, composeAName, firstAName,+        appAName, choiceAName, loopAName,++        -- Ix stuff+        ixClassName,++        -- Show stuff+        showClassName,++        -- Read stuff+        readClassName,++        -- Stable pointers+        newStablePtrName,++        -- GHC Extensions+        groupWithName,++        -- Strings and lists+        unpackCStringName,+        unpackCStringFoldrName, unpackCStringUtf8Name,++        -- Overloaded lists+        isListClassName,+        fromListName,+        fromListNName,+        toListName,++        -- List operations+        concatName, filterName, mapName,+        zipName, foldrName, buildName, augmentName, appendName,++        -- FFI primitive types that are not wired-in.+        stablePtrTyConName, ptrTyConName, funPtrTyConName,+        int8TyConName, int16TyConName, int32TyConName, int64TyConName,+        word16TyConName, word32TyConName, word64TyConName,++        -- Others+        otherwiseIdName, inlineIdName,+        eqStringName, assertName, breakpointName, breakpointCondName,+        breakpointAutoName,  opaqueTyConName,+        assertErrorName,+        printName, fstName, sndName,++        -- Integer+        integerTyConName, mkIntegerName,+        integerToWord64Name, integerToInt64Name,+        word64ToIntegerName, int64ToIntegerName,+        plusIntegerName, timesIntegerName, smallIntegerName,+        wordToIntegerName,+        integerToWordName, integerToIntName, minusIntegerName,+        negateIntegerName, eqIntegerPrimName, neqIntegerPrimName,+        absIntegerName, signumIntegerName,+        leIntegerPrimName, gtIntegerPrimName, ltIntegerPrimName, geIntegerPrimName,+        compareIntegerName, quotRemIntegerName, divModIntegerName,+        quotIntegerName, remIntegerName, divIntegerName, modIntegerName,+        floatFromIntegerName, doubleFromIntegerName,+        encodeFloatIntegerName, encodeDoubleIntegerName,+        decodeDoubleIntegerName,+        gcdIntegerName, lcmIntegerName,+        andIntegerName, orIntegerName, xorIntegerName, complementIntegerName,+        shiftLIntegerName, shiftRIntegerName, bitIntegerName,++        -- Natural+        naturalTyConName,+        naturalFromIntegerName,++        -- Float/Double+        rationalToFloatName,+        rationalToDoubleName,++        -- Other classes+        randomClassName, randomGenClassName, monadPlusClassName,++        -- Type-level naturals+        knownNatClassName, knownSymbolClassName,++        -- Overloaded labels+        isLabelClassName,++        -- Implicit Parameters+        ipClassName,++        -- Overloaded record fields+        hasFieldClassName,++        -- Call Stacks+        callStackTyConName,+        emptyCallStackName, pushCallStackName,++        -- Source Locations+        srcLocDataConName,++        -- Annotation type checking+        toAnnotationWrapperName++        -- The Ordering type+        , orderingTyConName+        , ltDataConName, eqDataConName, gtDataConName++        -- The SPEC type for SpecConstr+        , specTyConName++        -- The Either type+        , eitherTyConName, leftDataConName, rightDataConName++        -- Plugins+        , pluginTyConName+        , frontendPluginTyConName++        -- Generics+        , genClassName, gen1ClassName+        , datatypeClassName, constructorClassName, selectorClassName++        -- Monad comprehensions+        , guardMName+        , liftMName+        , mzipName++        -- GHCi Sandbox+        , ghciIoClassName, ghciStepIoMName++        -- StaticPtr+        , makeStaticName+        , staticPtrTyConName+        , staticPtrDataConName, staticPtrInfoDataConName+        , fromStaticPtrName++        -- Fingerprint+        , fingerprintDataConName++        -- Custom type errors+        , errorMessageTypeErrorFamName+        , typeErrorTextDataConName+        , typeErrorAppendDataConName+        , typeErrorVAppendDataConName+        , typeErrorShowTypeDataConName++        -- homogeneous equality+        , eqTyConName++    ] ++ case cIntegerLibraryType of+           IntegerGMP    -> [integerSDataConName]+           IntegerSimple -> []++genericTyConNames :: [Name]+genericTyConNames = [+    v1TyConName, u1TyConName, par1TyConName, rec1TyConName,+    k1TyConName, m1TyConName, sumTyConName, prodTyConName,+    compTyConName, rTyConName, dTyConName,+    cTyConName, sTyConName, rec0TyConName,+    d1TyConName, c1TyConName, s1TyConName, noSelTyConName,+    repTyConName, rep1TyConName, uRecTyConName,+    uAddrTyConName, uCharTyConName, uDoubleTyConName,+    uFloatTyConName, uIntTyConName, uWordTyConName,+    prefixIDataConName, infixIDataConName, leftAssociativeDataConName,+    rightAssociativeDataConName, notAssociativeDataConName,+    sourceUnpackDataConName, sourceNoUnpackDataConName,+    noSourceUnpackednessDataConName, sourceLazyDataConName,+    sourceStrictDataConName, noSourceStrictnessDataConName,+    decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName,+    metaDataDataConName, metaConsDataConName, metaSelDataConName+  ]++{-+************************************************************************+*                                                                      *+\subsection{Module names}+*                                                                      *+************************************************************************+++--MetaHaskell Extension Add a new module here+-}++pRELUDE :: Module+pRELUDE         = mkBaseModule_ pRELUDE_NAME++gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,+    gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING,+    gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER_TYPE, gHC_NATURAL, gHC_LIST,+    gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING,+    dATA_FOLDABLE, dATA_TRAVERSABLE, dATA_MONOID, dATA_SEMIGROUP,+    gHC_CONC, gHC_IO, gHC_IO_Exception,+    gHC_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,+    gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC,+    tYPEABLE, tYPEABLE_INTERNAL, gENERICS,+    rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP, mONAD_FAIL,+    aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS,+    cONTROL_EXCEPTION_BASE, gHC_TYPELITS, gHC_TYPENATS, dATA_TYPE_EQUALITY,+    dATA_COERCE :: Module++gHC_PRIM        = mkPrimModule (fsLit "GHC.Prim")   -- Primitive types and values+gHC_TYPES       = mkPrimModule (fsLit "GHC.Types")+gHC_MAGIC       = mkPrimModule (fsLit "GHC.Magic")+gHC_CSTRING     = mkPrimModule (fsLit "GHC.CString")+gHC_CLASSES     = mkPrimModule (fsLit "GHC.Classes")++gHC_BASE        = mkBaseModule (fsLit "GHC.Base")+gHC_ENUM        = mkBaseModule (fsLit "GHC.Enum")+gHC_GHCI        = mkBaseModule (fsLit "GHC.GHCi")+gHC_SHOW        = mkBaseModule (fsLit "GHC.Show")+gHC_READ        = mkBaseModule (fsLit "GHC.Read")+gHC_NUM         = mkBaseModule (fsLit "GHC.Num")+gHC_INTEGER_TYPE= mkIntegerModule (fsLit "GHC.Integer.Type")+gHC_NATURAL     = mkBaseModule (fsLit "GHC.Natural")+gHC_LIST        = mkBaseModule (fsLit "GHC.List")+gHC_TUPLE       = mkPrimModule (fsLit "GHC.Tuple")+dATA_TUPLE      = mkBaseModule (fsLit "Data.Tuple")+dATA_EITHER     = mkBaseModule (fsLit "Data.Either")+dATA_STRING     = mkBaseModule (fsLit "Data.String")+dATA_FOLDABLE   = mkBaseModule (fsLit "Data.Foldable")+dATA_TRAVERSABLE= mkBaseModule (fsLit "Data.Traversable")+dATA_SEMIGROUP  = mkBaseModule (fsLit "Data.Semigroup")+dATA_MONOID     = mkBaseModule (fsLit "Data.Monoid")+gHC_CONC        = mkBaseModule (fsLit "GHC.Conc")+gHC_IO          = mkBaseModule (fsLit "GHC.IO")+gHC_IO_Exception = mkBaseModule (fsLit "GHC.IO.Exception")+gHC_ST          = mkBaseModule (fsLit "GHC.ST")+gHC_ARR         = mkBaseModule (fsLit "GHC.Arr")+gHC_STABLE      = mkBaseModule (fsLit "GHC.Stable")+gHC_PTR         = mkBaseModule (fsLit "GHC.Ptr")+gHC_ERR         = mkBaseModule (fsLit "GHC.Err")+gHC_REAL        = mkBaseModule (fsLit "GHC.Real")+gHC_FLOAT       = mkBaseModule (fsLit "GHC.Float")+gHC_TOP_HANDLER = mkBaseModule (fsLit "GHC.TopHandler")+sYSTEM_IO       = mkBaseModule (fsLit "System.IO")+dYNAMIC         = mkBaseModule (fsLit "Data.Dynamic")+tYPEABLE        = mkBaseModule (fsLit "Data.Typeable")+tYPEABLE_INTERNAL = mkBaseModule (fsLit "Data.Typeable.Internal")+gENERICS        = mkBaseModule (fsLit "Data.Data")+rEAD_PREC       = mkBaseModule (fsLit "Text.ParserCombinators.ReadPrec")+lEX             = mkBaseModule (fsLit "Text.Read.Lex")+gHC_INT         = mkBaseModule (fsLit "GHC.Int")+gHC_WORD        = mkBaseModule (fsLit "GHC.Word")+mONAD           = mkBaseModule (fsLit "Control.Monad")+mONAD_FIX       = mkBaseModule (fsLit "Control.Monad.Fix")+mONAD_ZIP       = mkBaseModule (fsLit "Control.Monad.Zip")+mONAD_FAIL      = mkBaseModule (fsLit "Control.Monad.Fail")+aRROW           = mkBaseModule (fsLit "Control.Arrow")+cONTROL_APPLICATIVE = mkBaseModule (fsLit "Control.Applicative")+gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar")+rANDOM          = mkBaseModule (fsLit "System.Random")+gHC_EXTS        = mkBaseModule (fsLit "GHC.Exts")+cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base")+gHC_GENERICS    = mkBaseModule (fsLit "GHC.Generics")+gHC_TYPELITS    = mkBaseModule (fsLit "GHC.TypeLits")+gHC_TYPENATS    = mkBaseModule (fsLit "GHC.TypeNats")+dATA_TYPE_EQUALITY = mkBaseModule (fsLit "Data.Type.Equality")+dATA_COERCE     = mkBaseModule (fsLit "Data.Coerce")++gHC_PARR' :: Module+gHC_PARR' = mkBaseModule (fsLit "GHC.PArr")++gHC_SRCLOC :: Module+gHC_SRCLOC = mkBaseModule (fsLit "GHC.SrcLoc")++gHC_STACK, gHC_STACK_TYPES :: Module+gHC_STACK = mkBaseModule (fsLit "GHC.Stack")+gHC_STACK_TYPES = mkBaseModule (fsLit "GHC.Stack.Types")++gHC_STATICPTR :: Module+gHC_STATICPTR = mkBaseModule (fsLit "GHC.StaticPtr")++gHC_STATICPTR_INTERNAL :: Module+gHC_STATICPTR_INTERNAL = mkBaseModule (fsLit "GHC.StaticPtr.Internal")++gHC_FINGERPRINT_TYPE :: Module+gHC_FINGERPRINT_TYPE = mkBaseModule (fsLit "GHC.Fingerprint.Type")++gHC_OVER_LABELS :: Module+gHC_OVER_LABELS = mkBaseModule (fsLit "GHC.OverloadedLabels")++gHC_RECORDS :: Module+gHC_RECORDS = mkBaseModule (fsLit "GHC.Records")++mAIN, rOOT_MAIN :: Module+mAIN            = mkMainModule_ mAIN_NAME+rOOT_MAIN       = mkMainModule (fsLit ":Main") -- Root module for initialisation++mkInteractiveModule :: Int -> Module+-- (mkInteractiveMoudule 9) makes module 'interactive:M9'+mkInteractiveModule n = mkModule interactiveUnitId (mkModuleName ("Ghci" ++ show n))++pRELUDE_NAME, mAIN_NAME :: ModuleName+pRELUDE_NAME   = mkModuleNameFS (fsLit "Prelude")+mAIN_NAME      = mkModuleNameFS (fsLit "Main")++dATA_ARRAY_PARALLEL_NAME, dATA_ARRAY_PARALLEL_PRIM_NAME :: ModuleName+dATA_ARRAY_PARALLEL_NAME      = mkModuleNameFS (fsLit "Data.Array.Parallel")+dATA_ARRAY_PARALLEL_PRIM_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel.Prim")++mkPrimModule :: FastString -> Module+mkPrimModule m = mkModule primUnitId (mkModuleNameFS m)++mkIntegerModule :: FastString -> Module+mkIntegerModule m = mkModule integerUnitId (mkModuleNameFS m)++mkBaseModule :: FastString -> Module+mkBaseModule m = mkModule baseUnitId (mkModuleNameFS m)++mkBaseModule_ :: ModuleName -> Module+mkBaseModule_ m = mkModule baseUnitId m++mkThisGhcModule :: FastString -> Module+mkThisGhcModule m = mkModule thisGhcUnitId (mkModuleNameFS m)++mkThisGhcModule_ :: ModuleName -> Module+mkThisGhcModule_ m = mkModule thisGhcUnitId m++mkMainModule :: FastString -> Module+mkMainModule m = mkModule mainUnitId (mkModuleNameFS m)++mkMainModule_ :: ModuleName -> Module+mkMainModule_ m = mkModule mainUnitId m++{-+************************************************************************+*                                                                      *+                        RdrNames+*                                                                      *+************************************************************************+-}++main_RDR_Unqual    :: RdrName+main_RDR_Unqual = mkUnqual varName (fsLit "main")+        -- We definitely don't want an Orig RdrName, because+        -- main might, in principle, be imported into module Main++forall_tv_RDR, dot_tv_RDR :: RdrName+forall_tv_RDR = mkUnqual tvName (fsLit "forall")+dot_tv_RDR    = mkUnqual tvName (fsLit ".")++eq_RDR, ge_RDR, ne_RDR, le_RDR, lt_RDR, gt_RDR, compare_RDR,+    ltTag_RDR, eqTag_RDR, gtTag_RDR :: RdrName+eq_RDR                  = nameRdrName eqName+ge_RDR                  = nameRdrName geName+ne_RDR                  = varQual_RDR  gHC_CLASSES (fsLit "/=")+le_RDR                  = varQual_RDR  gHC_CLASSES (fsLit "<=")+lt_RDR                  = varQual_RDR  gHC_CLASSES (fsLit "<")+gt_RDR                  = varQual_RDR  gHC_CLASSES (fsLit ">")+compare_RDR             = varQual_RDR  gHC_CLASSES (fsLit "compare")+ltTag_RDR               = dataQual_RDR gHC_TYPES (fsLit "LT")+eqTag_RDR               = dataQual_RDR gHC_TYPES (fsLit "EQ")+gtTag_RDR               = dataQual_RDR gHC_TYPES (fsLit "GT")++eqClass_RDR, numClass_RDR, ordClass_RDR, enumClass_RDR, monadClass_RDR+    :: RdrName+eqClass_RDR             = nameRdrName eqClassName+numClass_RDR            = nameRdrName numClassName+ordClass_RDR            = nameRdrName ordClassName+enumClass_RDR           = nameRdrName enumClassName+monadClass_RDR          = nameRdrName monadClassName++map_RDR, append_RDR :: RdrName+map_RDR                 = varQual_RDR gHC_BASE (fsLit "map")+append_RDR              = varQual_RDR gHC_BASE (fsLit "++")++foldr_RDR, build_RDR, returnM_RDR, bindM_RDR, failM_RDR_preMFP, failM_RDR:: RdrName+foldr_RDR               = nameRdrName foldrName+build_RDR               = nameRdrName buildName+returnM_RDR             = nameRdrName returnMName+bindM_RDR               = nameRdrName bindMName+failM_RDR_preMFP        = nameRdrName failMName_preMFP+failM_RDR               = nameRdrName failMName++left_RDR, right_RDR :: RdrName+left_RDR                = nameRdrName leftDataConName+right_RDR               = nameRdrName rightDataConName++fromEnum_RDR, toEnum_RDR :: RdrName+fromEnum_RDR            = varQual_RDR gHC_ENUM (fsLit "fromEnum")+toEnum_RDR              = varQual_RDR gHC_ENUM (fsLit "toEnum")++enumFrom_RDR, enumFromTo_RDR, enumFromThen_RDR, enumFromThenTo_RDR :: RdrName+enumFrom_RDR            = nameRdrName enumFromName+enumFromTo_RDR          = nameRdrName enumFromToName+enumFromThen_RDR        = nameRdrName enumFromThenName+enumFromThenTo_RDR      = nameRdrName enumFromThenToName++ratioDataCon_RDR, plusInteger_RDR, timesInteger_RDR :: RdrName+ratioDataCon_RDR        = nameRdrName ratioDataConName+plusInteger_RDR         = nameRdrName plusIntegerName+timesInteger_RDR        = nameRdrName timesIntegerName++ioDataCon_RDR :: RdrName+ioDataCon_RDR           = nameRdrName ioDataConName++eqString_RDR, unpackCString_RDR, unpackCStringFoldr_RDR,+    unpackCStringUtf8_RDR :: RdrName+eqString_RDR            = nameRdrName eqStringName+unpackCString_RDR       = nameRdrName unpackCStringName+unpackCStringFoldr_RDR  = nameRdrName unpackCStringFoldrName+unpackCStringUtf8_RDR   = nameRdrName unpackCStringUtf8Name++newStablePtr_RDR :: RdrName+newStablePtr_RDR        = nameRdrName newStablePtrName++bindIO_RDR, returnIO_RDR :: RdrName+bindIO_RDR              = nameRdrName bindIOName+returnIO_RDR            = nameRdrName returnIOName++fromInteger_RDR, fromRational_RDR, minus_RDR, times_RDR, plus_RDR :: RdrName+fromInteger_RDR         = nameRdrName fromIntegerName+fromRational_RDR        = nameRdrName fromRationalName+minus_RDR               = nameRdrName minusName+times_RDR               = varQual_RDR  gHC_NUM (fsLit "*")+plus_RDR                = varQual_RDR gHC_NUM (fsLit "+")++toInteger_RDR, toRational_RDR, fromIntegral_RDR :: RdrName+toInteger_RDR           = nameRdrName toIntegerName+toRational_RDR          = nameRdrName toRationalName+fromIntegral_RDR        = nameRdrName fromIntegralName++stringTy_RDR, fromString_RDR :: RdrName+stringTy_RDR            = tcQual_RDR gHC_BASE (fsLit "String")+fromString_RDR          = nameRdrName fromStringName++fromList_RDR, fromListN_RDR, toList_RDR :: RdrName+fromList_RDR = nameRdrName fromListName+fromListN_RDR = nameRdrName fromListNName+toList_RDR = nameRdrName toListName++compose_RDR :: RdrName+compose_RDR             = varQual_RDR gHC_BASE (fsLit ".")++not_RDR, getTag_RDR, succ_RDR, pred_RDR, minBound_RDR, maxBound_RDR,+    and_RDR, range_RDR, inRange_RDR, index_RDR,+    unsafeIndex_RDR, unsafeRangeSize_RDR :: RdrName+and_RDR                 = varQual_RDR gHC_CLASSES (fsLit "&&")+not_RDR                 = varQual_RDR gHC_CLASSES (fsLit "not")+getTag_RDR              = varQual_RDR gHC_BASE (fsLit "getTag")+succ_RDR                = varQual_RDR gHC_ENUM (fsLit "succ")+pred_RDR                = varQual_RDR gHC_ENUM (fsLit "pred")+minBound_RDR            = varQual_RDR gHC_ENUM (fsLit "minBound")+maxBound_RDR            = varQual_RDR gHC_ENUM (fsLit "maxBound")+range_RDR               = varQual_RDR gHC_ARR (fsLit "range")+inRange_RDR             = varQual_RDR gHC_ARR (fsLit "inRange")+index_RDR               = varQual_RDR gHC_ARR (fsLit "index")+unsafeIndex_RDR         = varQual_RDR gHC_ARR (fsLit "unsafeIndex")+unsafeRangeSize_RDR     = varQual_RDR gHC_ARR (fsLit "unsafeRangeSize")++readList_RDR, readListDefault_RDR, readListPrec_RDR, readListPrecDefault_RDR,+    readPrec_RDR, parens_RDR, choose_RDR, lexP_RDR, expectP_RDR :: RdrName+readList_RDR            = varQual_RDR gHC_READ (fsLit "readList")+readListDefault_RDR     = varQual_RDR gHC_READ (fsLit "readListDefault")+readListPrec_RDR        = varQual_RDR gHC_READ (fsLit "readListPrec")+readListPrecDefault_RDR = varQual_RDR gHC_READ (fsLit "readListPrecDefault")+readPrec_RDR            = varQual_RDR gHC_READ (fsLit "readPrec")+parens_RDR              = varQual_RDR gHC_READ (fsLit "parens")+choose_RDR              = varQual_RDR gHC_READ (fsLit "choose")+lexP_RDR                = varQual_RDR gHC_READ (fsLit "lexP")+expectP_RDR             = varQual_RDR gHC_READ (fsLit "expectP")++punc_RDR, ident_RDR, symbol_RDR :: RdrName+punc_RDR                = dataQual_RDR lEX (fsLit "Punc")+ident_RDR               = dataQual_RDR lEX (fsLit "Ident")+symbol_RDR              = dataQual_RDR lEX (fsLit "Symbol")++step_RDR, alt_RDR, reset_RDR, prec_RDR, pfail_RDR :: RdrName+step_RDR                = varQual_RDR  rEAD_PREC (fsLit "step")+alt_RDR                 = varQual_RDR  rEAD_PREC (fsLit "+++")+reset_RDR               = varQual_RDR  rEAD_PREC (fsLit "reset")+prec_RDR                = varQual_RDR  rEAD_PREC (fsLit "prec")+pfail_RDR               = varQual_RDR  rEAD_PREC (fsLit "pfail")++showList_RDR, showList___RDR, showsPrec_RDR, shows_RDR, showString_RDR,+    showSpace_RDR, showCommaSpace_RDR, showParen_RDR :: RdrName+showList_RDR            = varQual_RDR gHC_SHOW (fsLit "showList")+showList___RDR          = varQual_RDR gHC_SHOW (fsLit "showList__")+showsPrec_RDR           = varQual_RDR gHC_SHOW (fsLit "showsPrec")+shows_RDR               = varQual_RDR gHC_SHOW (fsLit "shows")+showString_RDR          = varQual_RDR gHC_SHOW (fsLit "showString")+showSpace_RDR           = varQual_RDR gHC_SHOW (fsLit "showSpace")+showCommaSpace_RDR      = varQual_RDR gHC_SHOW (fsLit "showCommaSpace")+showParen_RDR           = varQual_RDR gHC_SHOW (fsLit "showParen")++undefined_RDR :: RdrName+undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined")++error_RDR :: RdrName+error_RDR = varQual_RDR gHC_ERR (fsLit "error")++-- Generics (constructors and functions)+u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR,+  k1DataCon_RDR, m1DataCon_RDR, l1DataCon_RDR, r1DataCon_RDR,+  prodDataCon_RDR, comp1DataCon_RDR,+  unPar1_RDR, unRec1_RDR, unK1_RDR, unComp1_RDR,+  from_RDR, from1_RDR, to_RDR, to1_RDR,+  datatypeName_RDR, moduleName_RDR, packageName_RDR, isNewtypeName_RDR,+  conName_RDR, conFixity_RDR, conIsRecord_RDR, selName_RDR,+  prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR,+  rightAssocDataCon_RDR, notAssocDataCon_RDR,+  uAddrDataCon_RDR, uCharDataCon_RDR, uDoubleDataCon_RDR,+  uFloatDataCon_RDR, uIntDataCon_RDR, uWordDataCon_RDR,+  uAddrHash_RDR, uCharHash_RDR, uDoubleHash_RDR,+  uFloatHash_RDR, uIntHash_RDR, uWordHash_RDR :: RdrName++u1DataCon_RDR    = dataQual_RDR gHC_GENERICS (fsLit "U1")+par1DataCon_RDR  = dataQual_RDR gHC_GENERICS (fsLit "Par1")+rec1DataCon_RDR  = dataQual_RDR gHC_GENERICS (fsLit "Rec1")+k1DataCon_RDR    = dataQual_RDR gHC_GENERICS (fsLit "K1")+m1DataCon_RDR    = dataQual_RDR gHC_GENERICS (fsLit "M1")++l1DataCon_RDR     = dataQual_RDR gHC_GENERICS (fsLit "L1")+r1DataCon_RDR     = dataQual_RDR gHC_GENERICS (fsLit "R1")++prodDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit ":*:")+comp1DataCon_RDR  = dataQual_RDR gHC_GENERICS (fsLit "Comp1")++unPar1_RDR  = varQual_RDR gHC_GENERICS (fsLit "unPar1")+unRec1_RDR  = varQual_RDR gHC_GENERICS (fsLit "unRec1")+unK1_RDR    = varQual_RDR gHC_GENERICS (fsLit "unK1")+unComp1_RDR = varQual_RDR gHC_GENERICS (fsLit "unComp1")++from_RDR  = varQual_RDR gHC_GENERICS (fsLit "from")+from1_RDR = varQual_RDR gHC_GENERICS (fsLit "from1")+to_RDR    = varQual_RDR gHC_GENERICS (fsLit "to")+to1_RDR   = varQual_RDR gHC_GENERICS (fsLit "to1")++datatypeName_RDR  = varQual_RDR gHC_GENERICS (fsLit "datatypeName")+moduleName_RDR    = varQual_RDR gHC_GENERICS (fsLit "moduleName")+packageName_RDR   = varQual_RDR gHC_GENERICS (fsLit "packageName")+isNewtypeName_RDR = varQual_RDR gHC_GENERICS (fsLit "isNewtype")+selName_RDR       = varQual_RDR gHC_GENERICS (fsLit "selName")+conName_RDR       = varQual_RDR gHC_GENERICS (fsLit "conName")+conFixity_RDR     = varQual_RDR gHC_GENERICS (fsLit "conFixity")+conIsRecord_RDR   = varQual_RDR gHC_GENERICS (fsLit "conIsRecord")++prefixDataCon_RDR     = dataQual_RDR gHC_GENERICS (fsLit "Prefix")+infixDataCon_RDR      = dataQual_RDR gHC_GENERICS (fsLit "Infix")+leftAssocDataCon_RDR  = dataQual_RDR gHC_GENERICS (fsLit "LeftAssociative")+rightAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "RightAssociative")+notAssocDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit "NotAssociative")++uAddrDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit "UAddr")+uCharDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit "UChar")+uDoubleDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UDouble")+uFloatDataCon_RDR  = dataQual_RDR gHC_GENERICS (fsLit "UFloat")+uIntDataCon_RDR    = dataQual_RDR gHC_GENERICS (fsLit "UInt")+uWordDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit "UWord")++uAddrHash_RDR   = varQual_RDR gHC_GENERICS (fsLit "uAddr#")+uCharHash_RDR   = varQual_RDR gHC_GENERICS (fsLit "uChar#")+uDoubleHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uDouble#")+uFloatHash_RDR  = varQual_RDR gHC_GENERICS (fsLit "uFloat#")+uIntHash_RDR    = varQual_RDR gHC_GENERICS (fsLit "uInt#")+uWordHash_RDR   = varQual_RDR gHC_GENERICS (fsLit "uWord#")++fmap_RDR, replace_RDR, pure_RDR, ap_RDR, liftA2_RDR, foldable_foldr_RDR,+    foldMap_RDR, traverse_RDR, mempty_RDR, mappend_RDR :: RdrName+fmap_RDR                = varQual_RDR gHC_BASE (fsLit "fmap")+replace_RDR             = varQual_RDR gHC_BASE (fsLit "<$")+pure_RDR                = nameRdrName pureAName+ap_RDR                  = nameRdrName apAName+liftA2_RDR              = varQual_RDR gHC_BASE (fsLit "liftA2")+foldable_foldr_RDR      = varQual_RDR dATA_FOLDABLE       (fsLit "foldr")+foldMap_RDR             = varQual_RDR dATA_FOLDABLE       (fsLit "foldMap")+traverse_RDR            = varQual_RDR dATA_TRAVERSABLE    (fsLit "traverse")+mempty_RDR              = varQual_RDR gHC_BASE            (fsLit "mempty")+mappend_RDR             = varQual_RDR gHC_BASE            (fsLit "mappend")++eqTyCon_RDR :: RdrName+eqTyCon_RDR = tcQual_RDR dATA_TYPE_EQUALITY (fsLit "~")++----------------------+varQual_RDR, tcQual_RDR, clsQual_RDR, dataQual_RDR+    :: Module -> FastString -> RdrName+varQual_RDR  mod str = mkOrig mod (mkOccNameFS varName str)+tcQual_RDR   mod str = mkOrig mod (mkOccNameFS tcName str)+clsQual_RDR  mod str = mkOrig mod (mkOccNameFS clsName str)+dataQual_RDR mod str = mkOrig mod (mkOccNameFS dataName str)++{-+************************************************************************+*                                                                      *+\subsection{Known-key names}+*                                                                      *+************************************************************************++Many of these Names are not really "built in", but some parts of the+compiler (notably the deriving mechanism) need to mention their names,+and it's convenient to write them all down in one place.++--MetaHaskell Extension  add the constrs and the lower case case+-- guys as well (perhaps) e.g. see  trueDataConName     below+-}++wildCardName :: Name+wildCardName = mkSystemVarName wildCardKey (fsLit "wild")++runMainIOName :: Name+runMainIOName = varQual gHC_TOP_HANDLER (fsLit "runMainIO") runMainKey++orderingTyConName, ltDataConName, eqDataConName, gtDataConName :: Name+orderingTyConName = tcQual  gHC_TYPES (fsLit "Ordering") orderingTyConKey+ltDataConName     = dcQual gHC_TYPES (fsLit "LT") ltDataConKey+eqDataConName     = dcQual gHC_TYPES (fsLit "EQ") eqDataConKey+gtDataConName     = dcQual gHC_TYPES (fsLit "GT") gtDataConKey++specTyConName :: Name+specTyConName     = tcQual gHC_TYPES (fsLit "SPEC") specTyConKey++eitherTyConName, leftDataConName, rightDataConName :: Name+eitherTyConName   = tcQual  dATA_EITHER (fsLit "Either") eitherTyConKey+leftDataConName   = dcQual dATA_EITHER (fsLit "Left")   leftDataConKey+rightDataConName  = dcQual dATA_EITHER (fsLit "Right")  rightDataConKey++-- Generics (types)+v1TyConName, u1TyConName, par1TyConName, rec1TyConName,+  k1TyConName, m1TyConName, sumTyConName, prodTyConName,+  compTyConName, rTyConName, dTyConName,+  cTyConName, sTyConName, rec0TyConName,+  d1TyConName, c1TyConName, s1TyConName, noSelTyConName,+  repTyConName, rep1TyConName, uRecTyConName,+  uAddrTyConName, uCharTyConName, uDoubleTyConName,+  uFloatTyConName, uIntTyConName, uWordTyConName,+  prefixIDataConName, infixIDataConName, leftAssociativeDataConName,+  rightAssociativeDataConName, notAssociativeDataConName,+  sourceUnpackDataConName, sourceNoUnpackDataConName,+  noSourceUnpackednessDataConName, sourceLazyDataConName,+  sourceStrictDataConName, noSourceStrictnessDataConName,+  decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName,+  metaDataDataConName, metaConsDataConName, metaSelDataConName :: Name++v1TyConName  = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey+u1TyConName  = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey+par1TyConName  = tcQual gHC_GENERICS (fsLit "Par1") par1TyConKey+rec1TyConName  = tcQual gHC_GENERICS (fsLit "Rec1") rec1TyConKey+k1TyConName  = tcQual gHC_GENERICS (fsLit "K1") k1TyConKey+m1TyConName  = tcQual gHC_GENERICS (fsLit "M1") m1TyConKey++sumTyConName    = tcQual gHC_GENERICS (fsLit ":+:") sumTyConKey+prodTyConName   = tcQual gHC_GENERICS (fsLit ":*:") prodTyConKey+compTyConName   = tcQual gHC_GENERICS (fsLit ":.:") compTyConKey++rTyConName  = tcQual gHC_GENERICS (fsLit "R") rTyConKey+dTyConName  = tcQual gHC_GENERICS (fsLit "D") dTyConKey+cTyConName  = tcQual gHC_GENERICS (fsLit "C") cTyConKey+sTyConName  = tcQual gHC_GENERICS (fsLit "S") sTyConKey++rec0TyConName  = tcQual gHC_GENERICS (fsLit "Rec0") rec0TyConKey+d1TyConName  = tcQual gHC_GENERICS (fsLit "D1") d1TyConKey+c1TyConName  = tcQual gHC_GENERICS (fsLit "C1") c1TyConKey+s1TyConName  = tcQual gHC_GENERICS (fsLit "S1") s1TyConKey+noSelTyConName = tcQual gHC_GENERICS (fsLit "NoSelector") noSelTyConKey++repTyConName  = tcQual gHC_GENERICS (fsLit "Rep")  repTyConKey+rep1TyConName = tcQual gHC_GENERICS (fsLit "Rep1") rep1TyConKey++uRecTyConName      = tcQual gHC_GENERICS (fsLit "URec") uRecTyConKey+uAddrTyConName     = tcQual gHC_GENERICS (fsLit "UAddr") uAddrTyConKey+uCharTyConName     = tcQual gHC_GENERICS (fsLit "UChar") uCharTyConKey+uDoubleTyConName   = tcQual gHC_GENERICS (fsLit "UDouble") uDoubleTyConKey+uFloatTyConName    = tcQual gHC_GENERICS (fsLit "UFloat") uFloatTyConKey+uIntTyConName      = tcQual gHC_GENERICS (fsLit "UInt") uIntTyConKey+uWordTyConName     = tcQual gHC_GENERICS (fsLit "UWord") uWordTyConKey++prefixIDataConName = dcQual gHC_GENERICS (fsLit "PrefixI")  prefixIDataConKey+infixIDataConName  = dcQual gHC_GENERICS (fsLit "InfixI")   infixIDataConKey+leftAssociativeDataConName  = dcQual gHC_GENERICS (fsLit "LeftAssociative")   leftAssociativeDataConKey+rightAssociativeDataConName = dcQual gHC_GENERICS (fsLit "RightAssociative")  rightAssociativeDataConKey+notAssociativeDataConName   = dcQual gHC_GENERICS (fsLit "NotAssociative")    notAssociativeDataConKey++sourceUnpackDataConName         = dcQual gHC_GENERICS (fsLit "SourceUnpack")         sourceUnpackDataConKey+sourceNoUnpackDataConName       = dcQual gHC_GENERICS (fsLit "SourceNoUnpack")       sourceNoUnpackDataConKey+noSourceUnpackednessDataConName = dcQual gHC_GENERICS (fsLit "NoSourceUnpackedness") noSourceUnpackednessDataConKey+sourceLazyDataConName           = dcQual gHC_GENERICS (fsLit "SourceLazy")           sourceLazyDataConKey+sourceStrictDataConName         = dcQual gHC_GENERICS (fsLit "SourceStrict")         sourceStrictDataConKey+noSourceStrictnessDataConName   = dcQual gHC_GENERICS (fsLit "NoSourceStrictness")   noSourceStrictnessDataConKey+decidedLazyDataConName          = dcQual gHC_GENERICS (fsLit "DecidedLazy")          decidedLazyDataConKey+decidedStrictDataConName        = dcQual gHC_GENERICS (fsLit "DecidedStrict")        decidedStrictDataConKey+decidedUnpackDataConName        = dcQual gHC_GENERICS (fsLit "DecidedUnpack")        decidedUnpackDataConKey++metaDataDataConName  = dcQual gHC_GENERICS (fsLit "MetaData")  metaDataDataConKey+metaConsDataConName  = dcQual gHC_GENERICS (fsLit "MetaCons")  metaConsDataConKey+metaSelDataConName   = dcQual gHC_GENERICS (fsLit "MetaSel")   metaSelDataConKey++-- Primitive Int+divIntName, modIntName :: Name+divIntName = varQual gHC_CLASSES (fsLit "divInt#") divIntIdKey+modIntName = varQual gHC_CLASSES (fsLit "modInt#") modIntIdKey++-- Base strings Strings+unpackCStringName, unpackCStringFoldrName,+    unpackCStringUtf8Name, eqStringName :: Name+unpackCStringName       = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey+unpackCStringFoldrName  = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey+unpackCStringUtf8Name   = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey+eqStringName            = varQual gHC_BASE (fsLit "eqString")  eqStringIdKey++-- The 'inline' function+inlineIdName :: Name+inlineIdName            = varQual gHC_MAGIC (fsLit "inline") inlineIdKey++-- Base classes (Eq, Ord, Functor)+fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name+eqClassName       = clsQual gHC_CLASSES (fsLit "Eq")      eqClassKey+eqName            = varQual gHC_CLASSES (fsLit "==")      eqClassOpKey+ordClassName      = clsQual gHC_CLASSES (fsLit "Ord")     ordClassKey+geName            = varQual gHC_CLASSES (fsLit ">=")      geClassOpKey+functorClassName  = clsQual gHC_BASE    (fsLit "Functor") functorClassKey+fmapName          = varQual gHC_BASE    (fsLit "fmap")    fmapClassOpKey++-- Class Monad+monadClassName, thenMName, bindMName, returnMName, failMName_preMFP :: Name+monadClassName     = clsQual gHC_BASE (fsLit "Monad")  monadClassKey+thenMName          = varQual gHC_BASE (fsLit ">>")     thenMClassOpKey+bindMName          = varQual gHC_BASE (fsLit ">>=")    bindMClassOpKey+returnMName        = varQual gHC_BASE (fsLit "return") returnMClassOpKey+failMName_preMFP   = varQual gHC_BASE (fsLit "fail")   failMClassOpKey_preMFP++-- Class MonadFail+monadFailClassName, failMName :: Name+monadFailClassName = clsQual mONAD_FAIL (fsLit "MonadFail") monadFailClassKey+failMName          = varQual mONAD_FAIL (fsLit "fail")      failMClassOpKey++-- Class Applicative+applicativeClassName, pureAName, apAName, thenAName :: Name+applicativeClassName = clsQual gHC_BASE (fsLit "Applicative") applicativeClassKey+apAName              = varQual gHC_BASE (fsLit "<*>")         apAClassOpKey+pureAName            = varQual gHC_BASE (fsLit "pure")        pureAClassOpKey+thenAName            = varQual gHC_BASE (fsLit "*>")          thenAClassOpKey++-- Classes (Foldable, Traversable)+foldableClassName, traversableClassName :: Name+foldableClassName     = clsQual  dATA_FOLDABLE       (fsLit "Foldable")    foldableClassKey+traversableClassName  = clsQual  dATA_TRAVERSABLE    (fsLit "Traversable") traversableClassKey++-- Classes (Semigroup, Monoid)+semigroupClassName, sappendName :: Name+semigroupClassName = clsQual dATA_SEMIGROUP (fsLit "Semigroup") semigroupClassKey+sappendName        = varQual dATA_SEMIGROUP (fsLit "<>")        sappendClassOpKey+monoidClassName, memptyName, mappendName, mconcatName :: Name+monoidClassName    = clsQual gHC_BASE       (fsLit "Monoid")    monoidClassKey+memptyName         = varQual gHC_BASE       (fsLit "mempty")    memptyClassOpKey+mappendName        = varQual gHC_BASE       (fsLit "mappend")   mappendClassOpKey+mconcatName        = varQual gHC_BASE       (fsLit "mconcat")   mconcatClassOpKey++++-- AMP additions++joinMName, alternativeClassName :: Name+joinMName            = varQual gHC_BASE (fsLit "join")        joinMIdKey+alternativeClassName = clsQual mONAD (fsLit "Alternative") alternativeClassKey++--+joinMIdKey, apAClassOpKey, pureAClassOpKey, thenAClassOpKey,+    alternativeClassKey :: Unique+joinMIdKey          = mkPreludeMiscIdUnique 750+apAClassOpKey       = mkPreludeMiscIdUnique 751 -- <*>+pureAClassOpKey     = mkPreludeMiscIdUnique 752+thenAClassOpKey     = mkPreludeMiscIdUnique 753+alternativeClassKey = mkPreludeMiscIdUnique 754+++-- Functions for GHC extensions+groupWithName :: Name+groupWithName = varQual gHC_EXTS (fsLit "groupWith") groupWithIdKey++-- Random PrelBase functions+fromStringName, otherwiseIdName, foldrName, buildName, augmentName,+    mapName, appendName, assertName,+    breakpointName, breakpointCondName, breakpointAutoName,+    opaqueTyConName :: Name+fromStringName = varQual dATA_STRING (fsLit "fromString") fromStringClassOpKey+otherwiseIdName   = varQual gHC_BASE (fsLit "otherwise")  otherwiseIdKey+foldrName         = varQual gHC_BASE (fsLit "foldr")      foldrIdKey+buildName         = varQual gHC_BASE (fsLit "build")      buildIdKey+augmentName       = varQual gHC_BASE (fsLit "augment")    augmentIdKey+mapName           = varQual gHC_BASE (fsLit "map")        mapIdKey+appendName        = varQual gHC_BASE (fsLit "++")         appendIdKey+assertName        = varQual gHC_BASE (fsLit "assert")     assertIdKey+breakpointName    = varQual gHC_BASE (fsLit "breakpoint") breakpointIdKey+breakpointCondName= varQual gHC_BASE (fsLit "breakpointCond") breakpointCondIdKey+breakpointAutoName= varQual gHC_BASE (fsLit "breakpointAuto") breakpointAutoIdKey+opaqueTyConName   = tcQual  gHC_BASE (fsLit "Opaque")     opaqueTyConKey++breakpointJumpName :: Name+breakpointJumpName+    = mkInternalName+        breakpointJumpIdKey+        (mkOccNameFS varName (fsLit "breakpointJump"))+        noSrcSpan+breakpointCondJumpName :: Name+breakpointCondJumpName+    = mkInternalName+        breakpointCondJumpIdKey+        (mkOccNameFS varName (fsLit "breakpointCondJump"))+        noSrcSpan+breakpointAutoJumpName :: Name+breakpointAutoJumpName+    = mkInternalName+        breakpointAutoJumpIdKey+        (mkOccNameFS varName (fsLit "breakpointAutoJump"))+        noSrcSpan++-- PrelTup+fstName, sndName :: Name+fstName           = varQual dATA_TUPLE (fsLit "fst") fstIdKey+sndName           = varQual dATA_TUPLE (fsLit "snd") sndIdKey++-- Module GHC.Num+numClassName, fromIntegerName, minusName, negateName :: Name+numClassName      = clsQual gHC_NUM (fsLit "Num")         numClassKey+fromIntegerName   = varQual gHC_NUM (fsLit "fromInteger") fromIntegerClassOpKey+minusName         = varQual gHC_NUM (fsLit "-")           minusClassOpKey+negateName        = varQual gHC_NUM (fsLit "negate")      negateClassOpKey++integerTyConName, mkIntegerName, integerSDataConName,+    integerToWord64Name, integerToInt64Name,+    word64ToIntegerName, int64ToIntegerName,+    plusIntegerName, timesIntegerName, smallIntegerName,+    wordToIntegerName,+    integerToWordName, integerToIntName, minusIntegerName,+    negateIntegerName, eqIntegerPrimName, neqIntegerPrimName,+    absIntegerName, signumIntegerName,+    leIntegerPrimName, gtIntegerPrimName, ltIntegerPrimName, geIntegerPrimName,+    compareIntegerName, quotRemIntegerName, divModIntegerName,+    quotIntegerName, remIntegerName, divIntegerName, modIntegerName,+    floatFromIntegerName, doubleFromIntegerName,+    encodeFloatIntegerName, encodeDoubleIntegerName,+    decodeDoubleIntegerName,+    gcdIntegerName, lcmIntegerName,+    andIntegerName, orIntegerName, xorIntegerName, complementIntegerName,+    shiftLIntegerName, shiftRIntegerName, bitIntegerName :: Name+integerTyConName      = tcQual  gHC_INTEGER_TYPE (fsLit "Integer")           integerTyConKey+integerSDataConName   = dcQual gHC_INTEGER_TYPE (fsLit n)                   integerSDataConKey+  where n = case cIntegerLibraryType of+            IntegerGMP    -> "S#"+            IntegerSimple -> panic "integerSDataConName evaluated for integer-simple"+mkIntegerName         = varQual gHC_INTEGER_TYPE (fsLit "mkInteger")         mkIntegerIdKey+integerToWord64Name   = varQual gHC_INTEGER_TYPE (fsLit "integerToWord64")   integerToWord64IdKey+integerToInt64Name    = varQual gHC_INTEGER_TYPE (fsLit "integerToInt64")    integerToInt64IdKey+word64ToIntegerName   = varQual gHC_INTEGER_TYPE (fsLit "word64ToInteger")   word64ToIntegerIdKey+int64ToIntegerName    = varQual gHC_INTEGER_TYPE (fsLit "int64ToInteger")    int64ToIntegerIdKey+plusIntegerName       = varQual gHC_INTEGER_TYPE (fsLit "plusInteger")       plusIntegerIdKey+timesIntegerName      = varQual gHC_INTEGER_TYPE (fsLit "timesInteger")      timesIntegerIdKey+smallIntegerName      = varQual gHC_INTEGER_TYPE (fsLit "smallInteger")      smallIntegerIdKey+wordToIntegerName     = varQual gHC_INTEGER_TYPE (fsLit "wordToInteger")     wordToIntegerIdKey+integerToWordName     = varQual gHC_INTEGER_TYPE (fsLit "integerToWord")     integerToWordIdKey+integerToIntName      = varQual gHC_INTEGER_TYPE (fsLit "integerToInt")      integerToIntIdKey+minusIntegerName      = varQual gHC_INTEGER_TYPE (fsLit "minusInteger")      minusIntegerIdKey+negateIntegerName     = varQual gHC_INTEGER_TYPE (fsLit "negateInteger")     negateIntegerIdKey+eqIntegerPrimName     = varQual gHC_INTEGER_TYPE (fsLit "eqInteger#")        eqIntegerPrimIdKey+neqIntegerPrimName    = varQual gHC_INTEGER_TYPE (fsLit "neqInteger#")       neqIntegerPrimIdKey+absIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "absInteger")        absIntegerIdKey+signumIntegerName     = varQual gHC_INTEGER_TYPE (fsLit "signumInteger")     signumIntegerIdKey+leIntegerPrimName     = varQual gHC_INTEGER_TYPE (fsLit "leInteger#")        leIntegerPrimIdKey+gtIntegerPrimName     = varQual gHC_INTEGER_TYPE (fsLit "gtInteger#")        gtIntegerPrimIdKey+ltIntegerPrimName     = varQual gHC_INTEGER_TYPE (fsLit "ltInteger#")        ltIntegerPrimIdKey+geIntegerPrimName     = varQual gHC_INTEGER_TYPE (fsLit "geInteger#")        geIntegerPrimIdKey+compareIntegerName    = varQual gHC_INTEGER_TYPE (fsLit "compareInteger")    compareIntegerIdKey+quotRemIntegerName    = varQual gHC_INTEGER_TYPE (fsLit "quotRemInteger")    quotRemIntegerIdKey+divModIntegerName     = varQual gHC_INTEGER_TYPE (fsLit "divModInteger")     divModIntegerIdKey+quotIntegerName       = varQual gHC_INTEGER_TYPE (fsLit "quotInteger")       quotIntegerIdKey+remIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "remInteger")        remIntegerIdKey+divIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "divInteger")        divIntegerIdKey+modIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "modInteger")        modIntegerIdKey+floatFromIntegerName  = varQual gHC_INTEGER_TYPE (fsLit "floatFromInteger")      floatFromIntegerIdKey+doubleFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "doubleFromInteger")     doubleFromIntegerIdKey+encodeFloatIntegerName  = varQual gHC_INTEGER_TYPE (fsLit "encodeFloatInteger")  encodeFloatIntegerIdKey+encodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeDoubleInteger") encodeDoubleIntegerIdKey+decodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "decodeDoubleInteger") decodeDoubleIntegerIdKey+gcdIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "gcdInteger")        gcdIntegerIdKey+lcmIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "lcmInteger")        lcmIntegerIdKey+andIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "andInteger")        andIntegerIdKey+orIntegerName         = varQual gHC_INTEGER_TYPE (fsLit "orInteger")         orIntegerIdKey+xorIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "xorInteger")        xorIntegerIdKey+complementIntegerName = varQual gHC_INTEGER_TYPE (fsLit "complementInteger") complementIntegerIdKey+shiftLIntegerName     = varQual gHC_INTEGER_TYPE (fsLit "shiftLInteger")     shiftLIntegerIdKey+shiftRIntegerName     = varQual gHC_INTEGER_TYPE (fsLit "shiftRInteger")     shiftRIntegerIdKey+bitIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "bitInteger")        bitIntegerIdKey++-- GHC.Natural types+naturalTyConName :: Name+naturalTyConName     = tcQual gHC_NATURAL (fsLit "Natural") naturalTyConKey++naturalFromIntegerName :: Name+naturalFromIntegerName = varQual gHC_NATURAL (fsLit "naturalFromInteger") naturalFromIntegerIdKey++-- GHC.Real types and classes+rationalTyConName, ratioTyConName, ratioDataConName, realClassName,+    integralClassName, realFracClassName, fractionalClassName,+    fromRationalName, toIntegerName, toRationalName, fromIntegralName,+    realToFracName :: Name+rationalTyConName   = tcQual  gHC_REAL (fsLit "Rational")     rationalTyConKey+ratioTyConName      = tcQual  gHC_REAL (fsLit "Ratio")        ratioTyConKey+ratioDataConName    = dcQual  gHC_REAL (fsLit ":%")           ratioDataConKey+realClassName       = clsQual gHC_REAL (fsLit "Real")         realClassKey+integralClassName   = clsQual gHC_REAL (fsLit "Integral")     integralClassKey+realFracClassName   = clsQual gHC_REAL (fsLit "RealFrac")     realFracClassKey+fractionalClassName = clsQual gHC_REAL (fsLit "Fractional")   fractionalClassKey+fromRationalName    = varQual gHC_REAL (fsLit "fromRational") fromRationalClassOpKey+toIntegerName       = varQual gHC_REAL (fsLit "toInteger")    toIntegerClassOpKey+toRationalName      = varQual gHC_REAL (fsLit "toRational")   toRationalClassOpKey+fromIntegralName    = varQual  gHC_REAL (fsLit "fromIntegral")fromIntegralIdKey+realToFracName      = varQual  gHC_REAL (fsLit "realToFrac")  realToFracIdKey++-- PrelFloat classes+floatingClassName, realFloatClassName :: Name+floatingClassName  = clsQual gHC_FLOAT (fsLit "Floating")  floatingClassKey+realFloatClassName = clsQual gHC_FLOAT (fsLit "RealFloat") realFloatClassKey++-- other GHC.Float functions+rationalToFloatName, rationalToDoubleName :: Name+rationalToFloatName  = varQual gHC_FLOAT (fsLit "rationalToFloat") rationalToFloatIdKey+rationalToDoubleName = varQual gHC_FLOAT (fsLit "rationalToDouble") rationalToDoubleIdKey++-- Class Ix+ixClassName :: Name+ixClassName = clsQual gHC_ARR (fsLit "Ix") ixClassKey++-- Typeable representation types+trModuleTyConName+  , trModuleDataConName+  , trNameTyConName+  , trNameSDataConName+  , trNameDDataConName+  , trTyConTyConName+  , trTyConDataConName+  :: Name+trModuleTyConName     = tcQual gHC_TYPES          (fsLit "Module")         trModuleTyConKey+trModuleDataConName   = dcQual gHC_TYPES          (fsLit "Module")         trModuleDataConKey+trNameTyConName       = tcQual gHC_TYPES          (fsLit "TrName")         trNameTyConKey+trNameSDataConName    = dcQual gHC_TYPES          (fsLit "TrNameS")        trNameSDataConKey+trNameDDataConName    = dcQual gHC_TYPES          (fsLit "TrNameD")        trNameDDataConKey+trTyConTyConName      = tcQual gHC_TYPES          (fsLit "TyCon")          trTyConTyConKey+trTyConDataConName    = dcQual gHC_TYPES          (fsLit "TyCon")          trTyConDataConKey++kindRepTyConName+  , kindRepTyConAppDataConName+  , kindRepVarDataConName+  , kindRepAppDataConName+  , kindRepFunDataConName+  , kindRepTYPEDataConName+  , kindRepTypeLitSDataConName+  , kindRepTypeLitDDataConName+  :: Name+kindRepTyConName      = tcQual gHC_TYPES          (fsLit "KindRep")        kindRepTyConKey+kindRepTyConAppDataConName = dcQual gHC_TYPES     (fsLit "KindRepTyConApp") kindRepTyConAppDataConKey+kindRepVarDataConName = dcQual gHC_TYPES          (fsLit "KindRepVar")     kindRepVarDataConKey+kindRepAppDataConName = dcQual gHC_TYPES          (fsLit "KindRepApp")     kindRepAppDataConKey+kindRepFunDataConName = dcQual gHC_TYPES          (fsLit "KindRepFun")     kindRepFunDataConKey+kindRepTYPEDataConName = dcQual gHC_TYPES         (fsLit "KindRepTYPE")    kindRepTYPEDataConKey+kindRepTypeLitSDataConName = dcQual gHC_TYPES     (fsLit "KindRepTypeLitS") kindRepTypeLitSDataConKey+kindRepTypeLitDDataConName = dcQual gHC_TYPES     (fsLit "KindRepTypeLitD") kindRepTypeLitDDataConKey++typeLitSortTyConName+  , typeLitSymbolDataConName+  , typeLitNatDataConName+  :: Name+typeLitSortTyConName     = tcQual gHC_TYPES       (fsLit "TypeLitSort")    typeLitSortTyConKey+typeLitSymbolDataConName = dcQual gHC_TYPES       (fsLit "TypeLitSymbol")  typeLitSymbolDataConKey+typeLitNatDataConName    = dcQual gHC_TYPES       (fsLit "TypeLitNat")     typeLitNatDataConKey++-- Class Typeable, and functions for constructing `Typeable` dictionaries+typeableClassName+  , typeRepTyConName+  , someTypeRepTyConName+  , someTypeRepDataConName+  , mkTrConName+  , mkTrAppName+  , mkTrFunName+  , typeRepIdName+  , typeNatTypeRepName+  , typeSymbolTypeRepName+  , trGhcPrimModuleName+  :: Name+typeableClassName     = clsQual tYPEABLE_INTERNAL (fsLit "Typeable")       typeableClassKey+typeRepTyConName      = tcQual  tYPEABLE_INTERNAL (fsLit "TypeRep")        typeRepTyConKey+someTypeRepTyConName   = tcQual tYPEABLE_INTERNAL (fsLit "SomeTypeRep")    someTypeRepTyConKey+someTypeRepDataConName = dcQual tYPEABLE_INTERNAL (fsLit "SomeTypeRep")    someTypeRepDataConKey+typeRepIdName         = varQual tYPEABLE_INTERNAL (fsLit "typeRep#")       typeRepIdKey+mkTrConName           = varQual tYPEABLE_INTERNAL (fsLit "mkTrCon")        mkTrConKey+mkTrAppName           = varQual tYPEABLE_INTERNAL (fsLit "mkTrApp")        mkTrAppKey+mkTrFunName           = varQual tYPEABLE_INTERNAL (fsLit "mkTrFun")        mkTrFunKey+typeNatTypeRepName    = varQual tYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey+typeSymbolTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeSymbolTypeRep") typeSymbolTypeRepKey+-- this is the Typeable 'Module' for GHC.Prim (which has no code, so we place in GHC.Types)+-- See Note [Grand plan for Typeable] in TcTypeable.+trGhcPrimModuleName   = varQual gHC_TYPES         (fsLit "tr$ModuleGHCPrim")  trGhcPrimModuleKey++-- Typeable KindReps for some common cases+starKindRepName, starArrStarKindRepName, starArrStarArrStarKindRepName :: Name+starKindRepName        = varQual gHC_TYPES         (fsLit "krep$*")         starKindRepKey+starArrStarKindRepName = varQual gHC_TYPES         (fsLit "krep$*Arr*")     starArrStarKindRepKey+starArrStarArrStarKindRepName = varQual gHC_TYPES  (fsLit "krep$*->*->*")   starArrStarArrStarKindRepKey++-- Custom type errors+errorMessageTypeErrorFamName+  , typeErrorTextDataConName+  , typeErrorAppendDataConName+  , typeErrorVAppendDataConName+  , typeErrorShowTypeDataConName+  :: Name++errorMessageTypeErrorFamName =+  tcQual gHC_TYPELITS (fsLit "TypeError") errorMessageTypeErrorFamKey++typeErrorTextDataConName =+  dcQual gHC_TYPELITS (fsLit "Text") typeErrorTextDataConKey++typeErrorAppendDataConName =+  dcQual gHC_TYPELITS (fsLit ":<>:") typeErrorAppendDataConKey++typeErrorVAppendDataConName =+  dcQual gHC_TYPELITS (fsLit ":$$:") typeErrorVAppendDataConKey++typeErrorShowTypeDataConName =+  dcQual gHC_TYPELITS (fsLit "ShowType") typeErrorShowTypeDataConKey++++-- Dynamic+toDynName :: Name+toDynName = varQual dYNAMIC (fsLit "toDyn") toDynIdKey++-- Class Data+dataClassName :: Name+dataClassName = clsQual gENERICS (fsLit "Data") dataClassKey++-- Error module+assertErrorName    :: Name+assertErrorName   = varQual gHC_IO_Exception (fsLit "assertError") assertErrorIdKey++-- Enum module (Enum, Bounded)+enumClassName, enumFromName, enumFromToName, enumFromThenName,+    enumFromThenToName, boundedClassName :: Name+enumClassName      = clsQual gHC_ENUM (fsLit "Enum")           enumClassKey+enumFromName       = varQual gHC_ENUM (fsLit "enumFrom")       enumFromClassOpKey+enumFromToName     = varQual gHC_ENUM (fsLit "enumFromTo")     enumFromToClassOpKey+enumFromThenName   = varQual gHC_ENUM (fsLit "enumFromThen")   enumFromThenClassOpKey+enumFromThenToName = varQual gHC_ENUM (fsLit "enumFromThenTo") enumFromThenToClassOpKey+boundedClassName   = clsQual gHC_ENUM (fsLit "Bounded")        boundedClassKey++-- List functions+concatName, filterName, zipName :: Name+concatName        = varQual gHC_LIST (fsLit "concat") concatIdKey+filterName        = varQual gHC_LIST (fsLit "filter") filterIdKey+zipName           = varQual gHC_LIST (fsLit "zip")    zipIdKey++-- Overloaded lists+isListClassName, fromListName, fromListNName, toListName :: Name+isListClassName = clsQual gHC_EXTS (fsLit "IsList")    isListClassKey+fromListName    = varQual gHC_EXTS (fsLit "fromList")  fromListClassOpKey+fromListNName   = varQual gHC_EXTS (fsLit "fromListN") fromListNClassOpKey+toListName      = varQual gHC_EXTS (fsLit "toList")    toListClassOpKey++-- Class Show+showClassName :: Name+showClassName   = clsQual gHC_SHOW (fsLit "Show")      showClassKey++-- Class Read+readClassName :: Name+readClassName   = clsQual gHC_READ (fsLit "Read")      readClassKey++-- Classes Generic and Generic1, Datatype, Constructor and Selector+genClassName, gen1ClassName, datatypeClassName, constructorClassName,+  selectorClassName :: Name+genClassName  = clsQual gHC_GENERICS (fsLit "Generic")  genClassKey+gen1ClassName = clsQual gHC_GENERICS (fsLit "Generic1") gen1ClassKey++datatypeClassName    = clsQual gHC_GENERICS (fsLit "Datatype")    datatypeClassKey+constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey+selectorClassName    = clsQual gHC_GENERICS (fsLit "Selector")    selectorClassKey++genericClassNames :: [Name]+genericClassNames = [genClassName, gen1ClassName]++-- GHCi things+ghciIoClassName, ghciStepIoMName :: Name+ghciIoClassName = clsQual gHC_GHCI (fsLit "GHCiSandboxIO") ghciIoClassKey+ghciStepIoMName = varQual gHC_GHCI (fsLit "ghciStepIO") ghciStepIoMClassOpKey++-- IO things+ioTyConName, ioDataConName,+  thenIOName, bindIOName, returnIOName, failIOName :: Name+ioTyConName       = tcQual  gHC_TYPES (fsLit "IO")       ioTyConKey+ioDataConName     = dcQual  gHC_TYPES (fsLit "IO")       ioDataConKey+thenIOName        = varQual gHC_BASE  (fsLit "thenIO")   thenIOIdKey+bindIOName        = varQual gHC_BASE  (fsLit "bindIO")   bindIOIdKey+returnIOName      = varQual gHC_BASE  (fsLit "returnIO") returnIOIdKey+failIOName        = varQual gHC_IO    (fsLit "failIO")   failIOIdKey++-- IO things+printName :: Name+printName         = varQual sYSTEM_IO (fsLit "print") printIdKey++-- Int, Word, and Addr things+int8TyConName, int16TyConName, int32TyConName, int64TyConName :: Name+int8TyConName     = tcQual gHC_INT  (fsLit "Int8")  int8TyConKey+int16TyConName    = tcQual gHC_INT  (fsLit "Int16") int16TyConKey+int32TyConName    = tcQual gHC_INT  (fsLit "Int32") int32TyConKey+int64TyConName    = tcQual gHC_INT  (fsLit "Int64") int64TyConKey++-- Word module+word16TyConName, word32TyConName, word64TyConName :: Name+word16TyConName   = tcQual  gHC_WORD (fsLit "Word16") word16TyConKey+word32TyConName   = tcQual  gHC_WORD (fsLit "Word32") word32TyConKey+word64TyConName   = tcQual  gHC_WORD (fsLit "Word64") word64TyConKey++-- PrelPtr module+ptrTyConName, funPtrTyConName :: Name+ptrTyConName      = tcQual   gHC_PTR (fsLit "Ptr")    ptrTyConKey+funPtrTyConName   = tcQual   gHC_PTR (fsLit "FunPtr") funPtrTyConKey++-- Foreign objects and weak pointers+stablePtrTyConName, newStablePtrName :: Name+stablePtrTyConName    = tcQual   gHC_STABLE (fsLit "StablePtr")    stablePtrTyConKey+newStablePtrName      = varQual  gHC_STABLE (fsLit "newStablePtr") newStablePtrIdKey++-- Recursive-do notation+monadFixClassName, mfixName :: Name+monadFixClassName  = clsQual mONAD_FIX (fsLit "MonadFix") monadFixClassKey+mfixName           = varQual mONAD_FIX (fsLit "mfix")     mfixIdKey++-- Arrow notation+arrAName, composeAName, firstAName, appAName, choiceAName, loopAName :: Name+arrAName           = varQual aRROW (fsLit "arr")       arrAIdKey+composeAName       = varQual gHC_DESUGAR (fsLit ">>>") composeAIdKey+firstAName         = varQual aRROW (fsLit "first")     firstAIdKey+appAName           = varQual aRROW (fsLit "app")       appAIdKey+choiceAName        = varQual aRROW (fsLit "|||")       choiceAIdKey+loopAName          = varQual aRROW (fsLit "loop")      loopAIdKey++-- Monad comprehensions+guardMName, liftMName, mzipName :: Name+guardMName         = varQual mONAD (fsLit "guard")    guardMIdKey+liftMName          = varQual mONAD (fsLit "liftM")    liftMIdKey+mzipName           = varQual mONAD_ZIP (fsLit "mzip") mzipIdKey+++-- Annotation type checking+toAnnotationWrapperName :: Name+toAnnotationWrapperName = varQual gHC_DESUGAR (fsLit "toAnnotationWrapper") toAnnotationWrapperIdKey++-- Other classes, needed for type defaulting+monadPlusClassName, randomClassName, randomGenClassName,+    isStringClassName :: Name+monadPlusClassName  = clsQual mONAD (fsLit "MonadPlus")      monadPlusClassKey+randomClassName     = clsQual rANDOM (fsLit "Random")        randomClassKey+randomGenClassName  = clsQual rANDOM (fsLit "RandomGen")     randomGenClassKey+isStringClassName   = clsQual dATA_STRING (fsLit "IsString") isStringClassKey++-- Type-level naturals+knownNatClassName :: Name+knownNatClassName     = clsQual gHC_TYPENATS (fsLit "KnownNat") knownNatClassNameKey+knownSymbolClassName :: Name+knownSymbolClassName  = clsQual gHC_TYPELITS (fsLit "KnownSymbol") knownSymbolClassNameKey++-- Overloaded labels+isLabelClassName :: Name+isLabelClassName+ = clsQual gHC_OVER_LABELS (fsLit "IsLabel") isLabelClassNameKey++-- Implicit Parameters+ipClassName :: Name+ipClassName+  = clsQual gHC_CLASSES (fsLit "IP") ipClassKey++-- Overloaded record fields+hasFieldClassName :: Name+hasFieldClassName+ = clsQual gHC_RECORDS (fsLit "HasField") hasFieldClassNameKey++-- Source Locations+callStackTyConName, emptyCallStackName, pushCallStackName,+  srcLocDataConName :: Name+callStackTyConName+  = tcQual gHC_STACK_TYPES  (fsLit "CallStack") callStackTyConKey+emptyCallStackName+  = varQual gHC_STACK_TYPES (fsLit "emptyCallStack") emptyCallStackKey+pushCallStackName+  = varQual gHC_STACK_TYPES (fsLit "pushCallStack") pushCallStackKey+srcLocDataConName+  = dcQual gHC_STACK_TYPES  (fsLit "SrcLoc")    srcLocDataConKey++-- plugins+pLUGINS :: Module+pLUGINS = mkThisGhcModule (fsLit "Plugins")+pluginTyConName :: Name+pluginTyConName = tcQual pLUGINS (fsLit "Plugin") pluginTyConKey+frontendPluginTyConName :: Name+frontendPluginTyConName = tcQual pLUGINS (fsLit "FrontendPlugin") frontendPluginTyConKey++-- Static pointers+makeStaticName :: Name+makeStaticName =+    varQual gHC_STATICPTR_INTERNAL (fsLit "makeStatic") makeStaticKey++staticPtrInfoTyConName :: Name+staticPtrInfoTyConName =+    tcQual gHC_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoTyConKey++staticPtrInfoDataConName :: Name+staticPtrInfoDataConName =+    dcQual gHC_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoDataConKey++staticPtrTyConName :: Name+staticPtrTyConName =+    tcQual gHC_STATICPTR (fsLit "StaticPtr") staticPtrTyConKey++staticPtrDataConName :: Name+staticPtrDataConName =+    dcQual gHC_STATICPTR (fsLit "StaticPtr") staticPtrDataConKey++fromStaticPtrName :: Name+fromStaticPtrName =+    varQual gHC_STATICPTR (fsLit "fromStaticPtr") fromStaticPtrClassOpKey++fingerprintDataConName :: Name+fingerprintDataConName =+    dcQual gHC_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey++-- homogeneous equality. See Note [The equality types story] in TysPrim+eqTyConName :: Name+eqTyConName        = tcQual dATA_TYPE_EQUALITY (fsLit "~")         eqTyConKey++{-+************************************************************************+*                                                                      *+\subsection{Local helpers}+*                                                                      *+************************************************************************++All these are original names; hence mkOrig+-}++varQual, tcQual, clsQual, dcQual :: Module -> FastString -> Unique -> Name+varQual  = mk_known_key_name varName+tcQual   = mk_known_key_name tcName+clsQual  = mk_known_key_name clsName+dcQual   = mk_known_key_name dataName++mk_known_key_name :: NameSpace -> Module -> FastString -> Unique -> Name+mk_known_key_name space modu str unique+  = mkExternalName unique modu (mkOccNameFS space str) noSrcSpan+++{-+************************************************************************+*                                                                      *+\subsubsection[Uniques-prelude-Classes]{@Uniques@ for wired-in @Classes@}+*                                                                      *+************************************************************************+--MetaHaskell extension hand allocate keys here+-}++boundedClassKey, enumClassKey, eqClassKey, floatingClassKey,+    fractionalClassKey, integralClassKey, monadClassKey, dataClassKey,+    functorClassKey, numClassKey, ordClassKey, readClassKey, realClassKey,+    realFloatClassKey, realFracClassKey, showClassKey, ixClassKey :: Unique+boundedClassKey         = mkPreludeClassUnique 1+enumClassKey            = mkPreludeClassUnique 2+eqClassKey              = mkPreludeClassUnique 3+floatingClassKey        = mkPreludeClassUnique 5+fractionalClassKey      = mkPreludeClassUnique 6+integralClassKey        = mkPreludeClassUnique 7+monadClassKey           = mkPreludeClassUnique 8+dataClassKey            = mkPreludeClassUnique 9+functorClassKey         = mkPreludeClassUnique 10+numClassKey             = mkPreludeClassUnique 11+ordClassKey             = mkPreludeClassUnique 12+readClassKey            = mkPreludeClassUnique 13+realClassKey            = mkPreludeClassUnique 14+realFloatClassKey       = mkPreludeClassUnique 15+realFracClassKey        = mkPreludeClassUnique 16+showClassKey            = mkPreludeClassUnique 17+ixClassKey              = mkPreludeClassUnique 18++typeableClassKey, typeable1ClassKey, typeable2ClassKey, typeable3ClassKey,+    typeable4ClassKey, typeable5ClassKey, typeable6ClassKey, typeable7ClassKey+    :: Unique+typeableClassKey        = mkPreludeClassUnique 20+typeable1ClassKey       = mkPreludeClassUnique 21+typeable2ClassKey       = mkPreludeClassUnique 22+typeable3ClassKey       = mkPreludeClassUnique 23+typeable4ClassKey       = mkPreludeClassUnique 24+typeable5ClassKey       = mkPreludeClassUnique 25+typeable6ClassKey       = mkPreludeClassUnique 26+typeable7ClassKey       = mkPreludeClassUnique 27++monadFixClassKey :: Unique+monadFixClassKey        = mkPreludeClassUnique 28++monadFailClassKey :: Unique+monadFailClassKey       = mkPreludeClassUnique 29++monadPlusClassKey, randomClassKey, randomGenClassKey :: Unique+monadPlusClassKey       = mkPreludeClassUnique 30+randomClassKey          = mkPreludeClassUnique 31+randomGenClassKey       = mkPreludeClassUnique 32++isStringClassKey :: Unique+isStringClassKey        = mkPreludeClassUnique 33++applicativeClassKey, foldableClassKey, traversableClassKey :: Unique+applicativeClassKey     = mkPreludeClassUnique 34+foldableClassKey        = mkPreludeClassUnique 35+traversableClassKey     = mkPreludeClassUnique 36++genClassKey, gen1ClassKey, datatypeClassKey, constructorClassKey,+  selectorClassKey :: Unique+genClassKey   = mkPreludeClassUnique 37+gen1ClassKey  = mkPreludeClassUnique 38++datatypeClassKey    = mkPreludeClassUnique 39+constructorClassKey = mkPreludeClassUnique 40+selectorClassKey    = mkPreludeClassUnique 41++-- KnownNat: see Note [KnowNat & KnownSymbol and EvLit] in TcEvidence+knownNatClassNameKey :: Unique+knownNatClassNameKey = mkPreludeClassUnique 42++-- KnownSymbol: see Note [KnownNat & KnownSymbol and EvLit] in TcEvidence+knownSymbolClassNameKey :: Unique+knownSymbolClassNameKey = mkPreludeClassUnique 43++ghciIoClassKey :: Unique+ghciIoClassKey = mkPreludeClassUnique 44++isLabelClassNameKey :: Unique+isLabelClassNameKey = mkPreludeClassUnique 45++semigroupClassKey, monoidClassKey :: Unique+semigroupClassKey = mkPreludeClassUnique 46+monoidClassKey    = mkPreludeClassUnique 47++-- Implicit Parameters+ipClassKey :: Unique+ipClassKey = mkPreludeClassUnique 48++-- Overloaded record fields+hasFieldClassNameKey :: Unique+hasFieldClassNameKey = mkPreludeClassUnique 49+++---------------- Template Haskell -------------------+--      THNames.hs: USES ClassUniques 200-299+-----------------------------------------------------++{-+************************************************************************+*                                                                      *+\subsubsection[Uniques-prelude-TyCons]{@Uniques@ for wired-in @TyCons@}+*                                                                      *+************************************************************************+-}++addrPrimTyConKey, arrayPrimTyConKey, arrayArrayPrimTyConKey, boolTyConKey,+    byteArrayPrimTyConKey, charPrimTyConKey, charTyConKey, doublePrimTyConKey,+    doubleTyConKey, floatPrimTyConKey, floatTyConKey, funTyConKey,+    intPrimTyConKey, intTyConKey, int8TyConKey, int16TyConKey,+    int32PrimTyConKey, int32TyConKey, int64PrimTyConKey, int64TyConKey,+    integerTyConKey, naturalTyConKey,+    listTyConKey, foreignObjPrimTyConKey, maybeTyConKey,+    weakPrimTyConKey, mutableArrayPrimTyConKey, mutableArrayArrayPrimTyConKey,+    mutableByteArrayPrimTyConKey, orderingTyConKey, mVarPrimTyConKey,+    ratioTyConKey, rationalTyConKey, realWorldTyConKey, stablePtrPrimTyConKey,+    stablePtrTyConKey, eqTyConKey, heqTyConKey,+    smallArrayPrimTyConKey, smallMutableArrayPrimTyConKey :: Unique+addrPrimTyConKey                        = mkPreludeTyConUnique  1+arrayPrimTyConKey                       = mkPreludeTyConUnique  3+boolTyConKey                            = mkPreludeTyConUnique  4+byteArrayPrimTyConKey                   = mkPreludeTyConUnique  5+charPrimTyConKey                        = mkPreludeTyConUnique  7+charTyConKey                            = mkPreludeTyConUnique  8+doublePrimTyConKey                      = mkPreludeTyConUnique  9+doubleTyConKey                          = mkPreludeTyConUnique 10+floatPrimTyConKey                       = mkPreludeTyConUnique 11+floatTyConKey                           = mkPreludeTyConUnique 12+funTyConKey                             = mkPreludeTyConUnique 13+intPrimTyConKey                         = mkPreludeTyConUnique 14+intTyConKey                             = mkPreludeTyConUnique 15+int8TyConKey                            = mkPreludeTyConUnique 16+int16TyConKey                           = mkPreludeTyConUnique 17+int32PrimTyConKey                       = mkPreludeTyConUnique 18+int32TyConKey                           = mkPreludeTyConUnique 19+int64PrimTyConKey                       = mkPreludeTyConUnique 20+int64TyConKey                           = mkPreludeTyConUnique 21+integerTyConKey                         = mkPreludeTyConUnique 22+naturalTyConKey                         = mkPreludeTyConUnique 23++listTyConKey                            = mkPreludeTyConUnique 24+foreignObjPrimTyConKey                  = mkPreludeTyConUnique 25+maybeTyConKey                           = mkPreludeTyConUnique 26+weakPrimTyConKey                        = mkPreludeTyConUnique 27+mutableArrayPrimTyConKey                = mkPreludeTyConUnique 28+mutableByteArrayPrimTyConKey            = mkPreludeTyConUnique 29+orderingTyConKey                        = mkPreludeTyConUnique 30+mVarPrimTyConKey                        = mkPreludeTyConUnique 31+ratioTyConKey                           = mkPreludeTyConUnique 32+rationalTyConKey                        = mkPreludeTyConUnique 33+realWorldTyConKey                       = mkPreludeTyConUnique 34+stablePtrPrimTyConKey                   = mkPreludeTyConUnique 35+stablePtrTyConKey                       = mkPreludeTyConUnique 36+eqTyConKey                              = mkPreludeTyConUnique 38+heqTyConKey                             = mkPreludeTyConUnique 39+arrayArrayPrimTyConKey                  = mkPreludeTyConUnique 40+mutableArrayArrayPrimTyConKey           = mkPreludeTyConUnique 41++statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey,+    mutVarPrimTyConKey, ioTyConKey,+    wordPrimTyConKey, wordTyConKey, word8TyConKey, word16TyConKey,+    word32PrimTyConKey, word32TyConKey, word64PrimTyConKey, word64TyConKey,+    liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey,+    typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey,+    funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey,+    eqReprPrimTyConKey, eqPhantPrimTyConKey, voidPrimTyConKey,+    compactPrimTyConKey :: Unique+statePrimTyConKey                       = mkPreludeTyConUnique 50+stableNamePrimTyConKey                  = mkPreludeTyConUnique 51+stableNameTyConKey                      = mkPreludeTyConUnique 52+eqPrimTyConKey                          = mkPreludeTyConUnique 53+eqReprPrimTyConKey                      = mkPreludeTyConUnique 54+eqPhantPrimTyConKey                     = mkPreludeTyConUnique 55+mutVarPrimTyConKey                      = mkPreludeTyConUnique 56+ioTyConKey                              = mkPreludeTyConUnique 57+voidPrimTyConKey                        = mkPreludeTyConUnique 58+wordPrimTyConKey                        = mkPreludeTyConUnique 59+wordTyConKey                            = mkPreludeTyConUnique 60+word8TyConKey                           = mkPreludeTyConUnique 61+word16TyConKey                          = mkPreludeTyConUnique 62+word32PrimTyConKey                      = mkPreludeTyConUnique 63+word32TyConKey                          = mkPreludeTyConUnique 64+word64PrimTyConKey                      = mkPreludeTyConUnique 65+word64TyConKey                          = mkPreludeTyConUnique 66+liftedConKey                            = mkPreludeTyConUnique 67+unliftedConKey                          = mkPreludeTyConUnique 68+anyBoxConKey                            = mkPreludeTyConUnique 69+kindConKey                              = mkPreludeTyConUnique 70+boxityConKey                            = mkPreludeTyConUnique 71+typeConKey                              = mkPreludeTyConUnique 72+threadIdPrimTyConKey                    = mkPreludeTyConUnique 73+bcoPrimTyConKey                         = mkPreludeTyConUnique 74+ptrTyConKey                             = mkPreludeTyConUnique 75+funPtrTyConKey                          = mkPreludeTyConUnique 76+tVarPrimTyConKey                        = mkPreludeTyConUnique 77+compactPrimTyConKey                     = mkPreludeTyConUnique 78++-- Parallel array type constructor+parrTyConKey :: Unique+parrTyConKey                            = mkPreludeTyConUnique 82++-- dotnet interop+objectTyConKey :: Unique+objectTyConKey                          = mkPreludeTyConUnique 83++eitherTyConKey :: Unique+eitherTyConKey                          = mkPreludeTyConUnique 84++-- Kind constructors+liftedTypeKindTyConKey, tYPETyConKey,+  constraintKindTyConKey,+  starKindTyConKey, unicodeStarKindTyConKey, runtimeRepTyConKey,+  vecCountTyConKey, vecElemTyConKey :: Unique+liftedTypeKindTyConKey                  = mkPreludeTyConUnique 87+tYPETyConKey                            = mkPreludeTyConUnique 88+constraintKindTyConKey                  = mkPreludeTyConUnique 92+starKindTyConKey                        = mkPreludeTyConUnique 93+unicodeStarKindTyConKey                 = mkPreludeTyConUnique 94+runtimeRepTyConKey                      = mkPreludeTyConUnique 95+vecCountTyConKey                        = mkPreludeTyConUnique 96+vecElemTyConKey                         = mkPreludeTyConUnique 97++pluginTyConKey, frontendPluginTyConKey :: Unique+pluginTyConKey                          = mkPreludeTyConUnique 102+frontendPluginTyConKey                  = mkPreludeTyConUnique 103++unknownTyConKey, unknown1TyConKey, unknown2TyConKey, unknown3TyConKey,+    opaqueTyConKey :: Unique+unknownTyConKey                         = mkPreludeTyConUnique 129+unknown1TyConKey                        = mkPreludeTyConUnique 130+unknown2TyConKey                        = mkPreludeTyConUnique 131+unknown3TyConKey                        = mkPreludeTyConUnique 132+opaqueTyConKey                          = mkPreludeTyConUnique 133++-- Generics (Unique keys)+v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey,+  k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey,+  compTyConKey, rTyConKey, dTyConKey,+  cTyConKey, sTyConKey, rec0TyConKey,+  d1TyConKey, c1TyConKey, s1TyConKey, noSelTyConKey,+  repTyConKey, rep1TyConKey, uRecTyConKey,+  uAddrTyConKey, uCharTyConKey, uDoubleTyConKey,+  uFloatTyConKey, uIntTyConKey, uWordTyConKey :: Unique++v1TyConKey    = mkPreludeTyConUnique 135+u1TyConKey    = mkPreludeTyConUnique 136+par1TyConKey  = mkPreludeTyConUnique 137+rec1TyConKey  = mkPreludeTyConUnique 138+k1TyConKey    = mkPreludeTyConUnique 139+m1TyConKey    = mkPreludeTyConUnique 140++sumTyConKey   = mkPreludeTyConUnique 141+prodTyConKey  = mkPreludeTyConUnique 142+compTyConKey  = mkPreludeTyConUnique 143++rTyConKey = mkPreludeTyConUnique 144+dTyConKey = mkPreludeTyConUnique 146+cTyConKey = mkPreludeTyConUnique 147+sTyConKey = mkPreludeTyConUnique 148++rec0TyConKey  = mkPreludeTyConUnique 149+d1TyConKey    = mkPreludeTyConUnique 151+c1TyConKey    = mkPreludeTyConUnique 152+s1TyConKey    = mkPreludeTyConUnique 153+noSelTyConKey = mkPreludeTyConUnique 154++repTyConKey  = mkPreludeTyConUnique 155+rep1TyConKey = mkPreludeTyConUnique 156++uRecTyConKey    = mkPreludeTyConUnique 157+uAddrTyConKey   = mkPreludeTyConUnique 158+uCharTyConKey   = mkPreludeTyConUnique 159+uDoubleTyConKey = mkPreludeTyConUnique 160+uFloatTyConKey  = mkPreludeTyConUnique 161+uIntTyConKey    = mkPreludeTyConUnique 162+uWordTyConKey   = mkPreludeTyConUnique 163++-- Type-level naturals+typeNatKindConNameKey, typeSymbolKindConNameKey,+  typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey,+  typeNatLeqTyFamNameKey, typeNatSubTyFamNameKey+  , typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey+  :: Unique+typeNatKindConNameKey     = mkPreludeTyConUnique 164+typeSymbolKindConNameKey  = mkPreludeTyConUnique 165+typeNatAddTyFamNameKey    = mkPreludeTyConUnique 166+typeNatMulTyFamNameKey    = mkPreludeTyConUnique 167+typeNatExpTyFamNameKey    = mkPreludeTyConUnique 168+typeNatLeqTyFamNameKey    = mkPreludeTyConUnique 169+typeNatSubTyFamNameKey    = mkPreludeTyConUnique 170+typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 171+typeNatCmpTyFamNameKey    = mkPreludeTyConUnique 172++-- Custom user type-errors+errorMessageTypeErrorFamKey :: Unique+errorMessageTypeErrorFamKey =  mkPreludeTyConUnique 173++++ntTyConKey:: Unique+ntTyConKey = mkPreludeTyConUnique 174+coercibleTyConKey :: Unique+coercibleTyConKey = mkPreludeTyConUnique 175++proxyPrimTyConKey :: Unique+proxyPrimTyConKey = mkPreludeTyConUnique 176++specTyConKey :: Unique+specTyConKey = mkPreludeTyConUnique 177++anyTyConKey :: Unique+anyTyConKey = mkPreludeTyConUnique 178++smallArrayPrimTyConKey        = mkPreludeTyConUnique  179+smallMutableArrayPrimTyConKey = mkPreludeTyConUnique  180++staticPtrTyConKey  :: Unique+staticPtrTyConKey  = mkPreludeTyConUnique 181++staticPtrInfoTyConKey :: Unique+staticPtrInfoTyConKey = mkPreludeTyConUnique 182++callStackTyConKey :: Unique+callStackTyConKey = mkPreludeTyConUnique 183++-- Typeables+typeRepTyConKey, someTypeRepTyConKey, someTypeRepDataConKey :: Unique+typeRepTyConKey       = mkPreludeTyConUnique 184+someTypeRepTyConKey   = mkPreludeTyConUnique 185+someTypeRepDataConKey = mkPreludeTyConUnique 186+++typeSymbolAppendFamNameKey :: Unique+typeSymbolAppendFamNameKey = mkPreludeTyConUnique 187++---------------- Template Haskell -------------------+--      THNames.hs: USES TyConUniques 200-299+-----------------------------------------------------++----------------------- SIMD ------------------------+--      USES TyConUniques 300-399+-----------------------------------------------------++#include "primop-vector-uniques.hs-incl"++{-+************************************************************************+*                                                                      *+\subsubsection[Uniques-prelude-DataCons]{@Uniques@ for wired-in @DataCons@}+*                                                                      *+************************************************************************+-}++charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey,+    floatDataConKey, intDataConKey, integerSDataConKey, nilDataConKey,+    ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey,+    word8DataConKey, ioDataConKey, integerDataConKey, heqDataConKey,+    coercibleDataConKey, nothingDataConKey, justDataConKey :: Unique++charDataConKey                          = mkPreludeDataConUnique  1+consDataConKey                          = mkPreludeDataConUnique  2+doubleDataConKey                        = mkPreludeDataConUnique  3+falseDataConKey                         = mkPreludeDataConUnique  4+floatDataConKey                         = mkPreludeDataConUnique  5+intDataConKey                           = mkPreludeDataConUnique  6+integerSDataConKey                      = mkPreludeDataConUnique  7+nothingDataConKey                       = mkPreludeDataConUnique  8+justDataConKey                          = mkPreludeDataConUnique  9+nilDataConKey                           = mkPreludeDataConUnique 11+ratioDataConKey                         = mkPreludeDataConUnique 12+word8DataConKey                         = mkPreludeDataConUnique 13+stableNameDataConKey                    = mkPreludeDataConUnique 14+trueDataConKey                          = mkPreludeDataConUnique 15+wordDataConKey                          = mkPreludeDataConUnique 16+ioDataConKey                            = mkPreludeDataConUnique 17+integerDataConKey                       = mkPreludeDataConUnique 18+heqDataConKey                           = mkPreludeDataConUnique 19++-- Generic data constructors+crossDataConKey, inlDataConKey, inrDataConKey, genUnitDataConKey :: Unique+crossDataConKey                         = mkPreludeDataConUnique 20+inlDataConKey                           = mkPreludeDataConUnique 21+inrDataConKey                           = mkPreludeDataConUnique 22+genUnitDataConKey                       = mkPreludeDataConUnique 23++-- Data constructor for parallel arrays+parrDataConKey :: Unique+parrDataConKey                          = mkPreludeDataConUnique 24++leftDataConKey, rightDataConKey :: Unique+leftDataConKey                          = mkPreludeDataConUnique 25+rightDataConKey                         = mkPreludeDataConUnique 26++ltDataConKey, eqDataConKey, gtDataConKey :: Unique+ltDataConKey                            = mkPreludeDataConUnique 27+eqDataConKey                            = mkPreludeDataConUnique 28+gtDataConKey                            = mkPreludeDataConUnique 29++coercibleDataConKey                     = mkPreludeDataConUnique 32++staticPtrDataConKey :: Unique+staticPtrDataConKey                     = mkPreludeDataConUnique 33++staticPtrInfoDataConKey :: Unique+staticPtrInfoDataConKey                 = mkPreludeDataConUnique 34++fingerprintDataConKey :: Unique+fingerprintDataConKey                   = mkPreludeDataConUnique 35++srcLocDataConKey :: Unique+srcLocDataConKey                        = mkPreludeDataConUnique 37++trTyConTyConKey, trTyConDataConKey,+  trModuleTyConKey, trModuleDataConKey,+  trNameTyConKey, trNameSDataConKey, trNameDDataConKey,+  trGhcPrimModuleKey, kindRepTyConKey,+  typeLitSortTyConKey :: Unique+trTyConTyConKey                         = mkPreludeDataConUnique 40+trTyConDataConKey                       = mkPreludeDataConUnique 41+trModuleTyConKey                        = mkPreludeDataConUnique 42+trModuleDataConKey                      = mkPreludeDataConUnique 43+trNameTyConKey                          = mkPreludeDataConUnique 44+trNameSDataConKey                       = mkPreludeDataConUnique 45+trNameDDataConKey                       = mkPreludeDataConUnique 46+trGhcPrimModuleKey                      = mkPreludeDataConUnique 47+kindRepTyConKey                         = mkPreludeDataConUnique 48+typeLitSortTyConKey                     = mkPreludeDataConUnique 49++typeErrorTextDataConKey,+  typeErrorAppendDataConKey,+  typeErrorVAppendDataConKey,+  typeErrorShowTypeDataConKey+  :: Unique+typeErrorTextDataConKey                 = mkPreludeDataConUnique 50+typeErrorAppendDataConKey               = mkPreludeDataConUnique 51+typeErrorVAppendDataConKey              = mkPreludeDataConUnique 52+typeErrorShowTypeDataConKey             = mkPreludeDataConUnique 53++prefixIDataConKey, infixIDataConKey, leftAssociativeDataConKey,+    rightAssociativeDataConKey, notAssociativeDataConKey,+    sourceUnpackDataConKey, sourceNoUnpackDataConKey,+    noSourceUnpackednessDataConKey, sourceLazyDataConKey,+    sourceStrictDataConKey, noSourceStrictnessDataConKey,+    decidedLazyDataConKey, decidedStrictDataConKey, decidedUnpackDataConKey,+    metaDataDataConKey, metaConsDataConKey, metaSelDataConKey :: Unique+prefixIDataConKey                       = mkPreludeDataConUnique 54+infixIDataConKey                        = mkPreludeDataConUnique 55+leftAssociativeDataConKey               = mkPreludeDataConUnique 56+rightAssociativeDataConKey              = mkPreludeDataConUnique 57+notAssociativeDataConKey                = mkPreludeDataConUnique 58+sourceUnpackDataConKey                  = mkPreludeDataConUnique 59+sourceNoUnpackDataConKey                = mkPreludeDataConUnique 60+noSourceUnpackednessDataConKey          = mkPreludeDataConUnique 61+sourceLazyDataConKey                    = mkPreludeDataConUnique 62+sourceStrictDataConKey                  = mkPreludeDataConUnique 63+noSourceStrictnessDataConKey            = mkPreludeDataConUnique 64+decidedLazyDataConKey                   = mkPreludeDataConUnique 65+decidedStrictDataConKey                 = mkPreludeDataConUnique 66+decidedUnpackDataConKey                 = mkPreludeDataConUnique 67+metaDataDataConKey                      = mkPreludeDataConUnique 68+metaConsDataConKey                      = mkPreludeDataConUnique 69+metaSelDataConKey                       = mkPreludeDataConUnique 70++vecRepDataConKey, tupleRepDataConKey, sumRepDataConKey :: Unique+vecRepDataConKey                        = mkPreludeDataConUnique 71+tupleRepDataConKey                      = mkPreludeDataConUnique 72+sumRepDataConKey                        = mkPreludeDataConUnique 73++-- See Note [Wiring in RuntimeRep] in TysWiredIn+runtimeRepSimpleDataConKeys :: [Unique]+liftedRepDataConKey :: Unique+runtimeRepSimpleDataConKeys@(+  liftedRepDataConKey : _)+  = map mkPreludeDataConUnique [74..82]++-- See Note [Wiring in RuntimeRep] in TysWiredIn+-- VecCount+vecCountDataConKeys :: [Unique]+vecCountDataConKeys = map mkPreludeDataConUnique [83..88]++-- See Note [Wiring in RuntimeRep] in TysWiredIn+-- VecElem+vecElemDataConKeys :: [Unique]+vecElemDataConKeys = map mkPreludeDataConUnique [89..98]++-- Typeable things+kindRepTyConAppDataConKey, kindRepVarDataConKey, kindRepAppDataConKey,+    kindRepFunDataConKey, kindRepTYPEDataConKey,+    kindRepTypeLitSDataConKey, kindRepTypeLitDDataConKey+    :: Unique+kindRepTyConAppDataConKey = mkPreludeDataConUnique 100+kindRepVarDataConKey      = mkPreludeDataConUnique 101+kindRepAppDataConKey      = mkPreludeDataConUnique 102+kindRepFunDataConKey      = mkPreludeDataConUnique 103+kindRepTYPEDataConKey     = mkPreludeDataConUnique 104+kindRepTypeLitSDataConKey = mkPreludeDataConUnique 105+kindRepTypeLitDDataConKey = mkPreludeDataConUnique 106++typeLitSymbolDataConKey, typeLitNatDataConKey :: Unique+typeLitSymbolDataConKey   = mkPreludeDataConUnique 107+typeLitNatDataConKey      = mkPreludeDataConUnique 108+++---------------- Template Haskell -------------------+--      THNames.hs: USES DataUniques 200-250+-----------------------------------------------------+++{-+************************************************************************+*                                                                      *+\subsubsection[Uniques-prelude-Ids]{@Uniques@ for wired-in @Ids@ (except @DataCons@)}+*                                                                      *+************************************************************************+-}++wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey,+    buildIdKey, errorIdKey, foldrIdKey, recSelErrorIdKey,+    seqIdKey, irrefutPatErrorIdKey, eqStringIdKey,+    noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey,+    runtimeErrorIdKey, patErrorIdKey, voidPrimIdKey,+    realWorldPrimIdKey, recConErrorIdKey,+    unpackCStringUtf8IdKey, unpackCStringAppendIdKey,+    unpackCStringFoldrIdKey, unpackCStringIdKey,+    typeErrorIdKey, divIntIdKey, modIntIdKey :: Unique++wildCardKey                   = mkPreludeMiscIdUnique  0  -- See Note [WildCard binders]+absentErrorIdKey              = mkPreludeMiscIdUnique  1+augmentIdKey                  = mkPreludeMiscIdUnique  2+appendIdKey                   = mkPreludeMiscIdUnique  3+buildIdKey                    = mkPreludeMiscIdUnique  4+errorIdKey                    = mkPreludeMiscIdUnique  5+foldrIdKey                    = mkPreludeMiscIdUnique  6+recSelErrorIdKey              = mkPreludeMiscIdUnique  7+seqIdKey                      = mkPreludeMiscIdUnique  8+irrefutPatErrorIdKey          = mkPreludeMiscIdUnique  9+eqStringIdKey                 = mkPreludeMiscIdUnique 10+noMethodBindingErrorIdKey     = mkPreludeMiscIdUnique 11+nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 12+runtimeErrorIdKey             = mkPreludeMiscIdUnique 13+patErrorIdKey                 = mkPreludeMiscIdUnique 14+realWorldPrimIdKey            = mkPreludeMiscIdUnique 15+recConErrorIdKey              = mkPreludeMiscIdUnique 16+unpackCStringUtf8IdKey        = mkPreludeMiscIdUnique 17+unpackCStringAppendIdKey      = mkPreludeMiscIdUnique 18+unpackCStringFoldrIdKey       = mkPreludeMiscIdUnique 19+unpackCStringIdKey            = mkPreludeMiscIdUnique 20+voidPrimIdKey                 = mkPreludeMiscIdUnique 21+typeErrorIdKey                = mkPreludeMiscIdUnique 22+divIntIdKey                   = mkPreludeMiscIdUnique 23+modIntIdKey                   = mkPreludeMiscIdUnique 24++unsafeCoerceIdKey, concatIdKey, filterIdKey, zipIdKey, bindIOIdKey,+    returnIOIdKey, newStablePtrIdKey,+    printIdKey, failIOIdKey, nullAddrIdKey, voidArgIdKey,+    fstIdKey, sndIdKey, otherwiseIdKey, assertIdKey :: Unique+unsafeCoerceIdKey             = mkPreludeMiscIdUnique 30+concatIdKey                   = mkPreludeMiscIdUnique 31+filterIdKey                   = mkPreludeMiscIdUnique 32+zipIdKey                      = mkPreludeMiscIdUnique 33+bindIOIdKey                   = mkPreludeMiscIdUnique 34+returnIOIdKey                 = mkPreludeMiscIdUnique 35+newStablePtrIdKey             = mkPreludeMiscIdUnique 36+printIdKey                    = mkPreludeMiscIdUnique 37+failIOIdKey                   = mkPreludeMiscIdUnique 38+nullAddrIdKey                 = mkPreludeMiscIdUnique 39+voidArgIdKey                  = mkPreludeMiscIdUnique 40+fstIdKey                      = mkPreludeMiscIdUnique 41+sndIdKey                      = mkPreludeMiscIdUnique 42+otherwiseIdKey                = mkPreludeMiscIdUnique 43+assertIdKey                   = mkPreludeMiscIdUnique 44++mkIntegerIdKey, smallIntegerIdKey, wordToIntegerIdKey,+    integerToWordIdKey, integerToIntIdKey,+    integerToWord64IdKey, integerToInt64IdKey,+    word64ToIntegerIdKey, int64ToIntegerIdKey,+    plusIntegerIdKey, timesIntegerIdKey, minusIntegerIdKey,+    negateIntegerIdKey,+    eqIntegerPrimIdKey, neqIntegerPrimIdKey, absIntegerIdKey, signumIntegerIdKey,+    leIntegerPrimIdKey, gtIntegerPrimIdKey, ltIntegerPrimIdKey, geIntegerPrimIdKey,+    compareIntegerIdKey, quotRemIntegerIdKey, divModIntegerIdKey,+    quotIntegerIdKey, remIntegerIdKey, divIntegerIdKey, modIntegerIdKey,+    floatFromIntegerIdKey, doubleFromIntegerIdKey,+    encodeFloatIntegerIdKey, encodeDoubleIntegerIdKey,+    decodeDoubleIntegerIdKey,+    gcdIntegerIdKey, lcmIntegerIdKey,+    andIntegerIdKey, orIntegerIdKey, xorIntegerIdKey, complementIntegerIdKey,+    shiftLIntegerIdKey, shiftRIntegerIdKey :: Unique+mkIntegerIdKey                = mkPreludeMiscIdUnique 60+smallIntegerIdKey             = mkPreludeMiscIdUnique 61+integerToWordIdKey            = mkPreludeMiscIdUnique 62+integerToIntIdKey             = mkPreludeMiscIdUnique 63+integerToWord64IdKey          = mkPreludeMiscIdUnique 64+integerToInt64IdKey           = mkPreludeMiscIdUnique 65+plusIntegerIdKey              = mkPreludeMiscIdUnique 66+timesIntegerIdKey             = mkPreludeMiscIdUnique 67+minusIntegerIdKey             = mkPreludeMiscIdUnique 68+negateIntegerIdKey            = mkPreludeMiscIdUnique 69+eqIntegerPrimIdKey            = mkPreludeMiscIdUnique 70+neqIntegerPrimIdKey           = mkPreludeMiscIdUnique 71+absIntegerIdKey               = mkPreludeMiscIdUnique 72+signumIntegerIdKey            = mkPreludeMiscIdUnique 73+leIntegerPrimIdKey            = mkPreludeMiscIdUnique 74+gtIntegerPrimIdKey            = mkPreludeMiscIdUnique 75+ltIntegerPrimIdKey            = mkPreludeMiscIdUnique 76+geIntegerPrimIdKey            = mkPreludeMiscIdUnique 77+compareIntegerIdKey           = mkPreludeMiscIdUnique 78+quotIntegerIdKey              = mkPreludeMiscIdUnique 79+remIntegerIdKey               = mkPreludeMiscIdUnique 80+divIntegerIdKey               = mkPreludeMiscIdUnique 81+modIntegerIdKey               = mkPreludeMiscIdUnique 82+divModIntegerIdKey            = mkPreludeMiscIdUnique 83+quotRemIntegerIdKey           = mkPreludeMiscIdUnique 84+floatFromIntegerIdKey         = mkPreludeMiscIdUnique 85+doubleFromIntegerIdKey        = mkPreludeMiscIdUnique 86+encodeFloatIntegerIdKey       = mkPreludeMiscIdUnique 87+encodeDoubleIntegerIdKey      = mkPreludeMiscIdUnique 88+gcdIntegerIdKey               = mkPreludeMiscIdUnique 89+lcmIntegerIdKey               = mkPreludeMiscIdUnique 90+andIntegerIdKey               = mkPreludeMiscIdUnique 91+orIntegerIdKey                = mkPreludeMiscIdUnique 92+xorIntegerIdKey               = mkPreludeMiscIdUnique 93+complementIntegerIdKey        = mkPreludeMiscIdUnique 94+shiftLIntegerIdKey            = mkPreludeMiscIdUnique 95+shiftRIntegerIdKey            = mkPreludeMiscIdUnique 96+wordToIntegerIdKey            = mkPreludeMiscIdUnique 97+word64ToIntegerIdKey          = mkPreludeMiscIdUnique 98+int64ToIntegerIdKey           = mkPreludeMiscIdUnique 99+decodeDoubleIntegerIdKey      = mkPreludeMiscIdUnique 100++rootMainKey, runMainKey :: Unique+rootMainKey                   = mkPreludeMiscIdUnique 101+runMainKey                    = mkPreludeMiscIdUnique 102++thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey :: Unique+thenIOIdKey                   = mkPreludeMiscIdUnique 103+lazyIdKey                     = mkPreludeMiscIdUnique 104+assertErrorIdKey              = mkPreludeMiscIdUnique 105+oneShotKey                    = mkPreludeMiscIdUnique 106+runRWKey                      = mkPreludeMiscIdUnique 107++breakpointIdKey, breakpointCondIdKey, breakpointAutoIdKey,+    breakpointJumpIdKey, breakpointCondJumpIdKey,+    breakpointAutoJumpIdKey :: Unique+breakpointIdKey               = mkPreludeMiscIdUnique 110+breakpointCondIdKey           = mkPreludeMiscIdUnique 111+breakpointAutoIdKey           = mkPreludeMiscIdUnique 112+breakpointJumpIdKey           = mkPreludeMiscIdUnique 113+breakpointCondJumpIdKey       = mkPreludeMiscIdUnique 114+breakpointAutoJumpIdKey       = mkPreludeMiscIdUnique 115++inlineIdKey, noinlineIdKey :: Unique+inlineIdKey                   = mkPreludeMiscIdUnique 120+-- see below++mapIdKey, groupWithIdKey, dollarIdKey :: Unique+mapIdKey              = mkPreludeMiscIdUnique 121+groupWithIdKey        = mkPreludeMiscIdUnique 122+dollarIdKey           = mkPreludeMiscIdUnique 123++coercionTokenIdKey :: Unique+coercionTokenIdKey    = mkPreludeMiscIdUnique 124++noinlineIdKey                 = mkPreludeMiscIdUnique 125++rationalToFloatIdKey, rationalToDoubleIdKey :: Unique+rationalToFloatIdKey   = mkPreludeMiscIdUnique 130+rationalToDoubleIdKey  = mkPreludeMiscIdUnique 131++-- dotnet interop+unmarshalObjectIdKey, marshalObjectIdKey, marshalStringIdKey,+    unmarshalStringIdKey, checkDotnetResNameIdKey :: Unique+unmarshalObjectIdKey          = mkPreludeMiscIdUnique 150+marshalObjectIdKey            = mkPreludeMiscIdUnique 151+marshalStringIdKey            = mkPreludeMiscIdUnique 152+unmarshalStringIdKey          = mkPreludeMiscIdUnique 153+checkDotnetResNameIdKey       = mkPreludeMiscIdUnique 154++undefinedKey :: Unique+undefinedKey                  = mkPreludeMiscIdUnique 155++magicDictKey :: Unique+magicDictKey                  = mkPreludeMiscIdUnique 156++coerceKey :: Unique+coerceKey                     = mkPreludeMiscIdUnique 157++{-+Certain class operations from Prelude classes.  They get their own+uniques so we can look them up easily when we want to conjure them up+during type checking.+-}++-- Just a placeholder for unbound variables produced by the renamer:+unboundKey :: Unique+unboundKey                    = mkPreludeMiscIdUnique 158++fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey,+    enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey,+    enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey,+    failMClassOpKey_preMFP, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey,+    fmapClassOpKey+    :: Unique+fromIntegerClassOpKey         = mkPreludeMiscIdUnique 160+minusClassOpKey               = mkPreludeMiscIdUnique 161+fromRationalClassOpKey        = mkPreludeMiscIdUnique 162+enumFromClassOpKey            = mkPreludeMiscIdUnique 163+enumFromThenClassOpKey        = mkPreludeMiscIdUnique 164+enumFromToClassOpKey          = mkPreludeMiscIdUnique 165+enumFromThenToClassOpKey      = mkPreludeMiscIdUnique 166+eqClassOpKey                  = mkPreludeMiscIdUnique 167+geClassOpKey                  = mkPreludeMiscIdUnique 168+negateClassOpKey              = mkPreludeMiscIdUnique 169+failMClassOpKey_preMFP        = mkPreludeMiscIdUnique 170+bindMClassOpKey               = mkPreludeMiscIdUnique 171 -- (>>=)+thenMClassOpKey               = mkPreludeMiscIdUnique 172 -- (>>)+fmapClassOpKey                = mkPreludeMiscIdUnique 173+returnMClassOpKey             = mkPreludeMiscIdUnique 174++-- Recursive do notation+mfixIdKey :: Unique+mfixIdKey       = mkPreludeMiscIdUnique 175++-- MonadFail operations+failMClassOpKey :: Unique+failMClassOpKey = mkPreludeMiscIdUnique 176++-- Arrow notation+arrAIdKey, composeAIdKey, firstAIdKey, appAIdKey, choiceAIdKey,+    loopAIdKey :: Unique+arrAIdKey       = mkPreludeMiscIdUnique 180+composeAIdKey   = mkPreludeMiscIdUnique 181 -- >>>+firstAIdKey     = mkPreludeMiscIdUnique 182+appAIdKey       = mkPreludeMiscIdUnique 183+choiceAIdKey    = mkPreludeMiscIdUnique 184 --  |||+loopAIdKey      = mkPreludeMiscIdUnique 185++fromStringClassOpKey :: Unique+fromStringClassOpKey          = mkPreludeMiscIdUnique 186++-- Annotation type checking+toAnnotationWrapperIdKey :: Unique+toAnnotationWrapperIdKey      = mkPreludeMiscIdUnique 187++-- Conversion functions+fromIntegralIdKey, realToFracIdKey, toIntegerClassOpKey, toRationalClassOpKey :: Unique+fromIntegralIdKey    = mkPreludeMiscIdUnique 190+realToFracIdKey      = mkPreludeMiscIdUnique 191+toIntegerClassOpKey  = mkPreludeMiscIdUnique 192+toRationalClassOpKey = mkPreludeMiscIdUnique 193++-- Monad comprehensions+guardMIdKey, liftMIdKey, mzipIdKey :: Unique+guardMIdKey     = mkPreludeMiscIdUnique 194+liftMIdKey      = mkPreludeMiscIdUnique 195+mzipIdKey       = mkPreludeMiscIdUnique 196++-- GHCi+ghciStepIoMClassOpKey :: Unique+ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197++-- Overloaded lists+isListClassKey, fromListClassOpKey, fromListNClassOpKey, toListClassOpKey :: Unique+isListClassKey = mkPreludeMiscIdUnique 198+fromListClassOpKey = mkPreludeMiscIdUnique 199+fromListNClassOpKey = mkPreludeMiscIdUnique 500+toListClassOpKey = mkPreludeMiscIdUnique 501++proxyHashKey :: Unique+proxyHashKey = mkPreludeMiscIdUnique 502++---------------- Template Haskell -------------------+--      THNames.hs: USES IdUniques 200-499+-----------------------------------------------------++-- Used to make `Typeable` dictionaries+mkTyConKey+  , mkTrConKey+  , mkTrAppKey+  , mkTrFunKey+  , typeNatTypeRepKey+  , typeSymbolTypeRepKey+  , typeRepIdKey+  :: Unique+mkTyConKey            = mkPreludeMiscIdUnique 503+mkTrConKey            = mkPreludeMiscIdUnique 504+mkTrAppKey            = mkPreludeMiscIdUnique 505+typeNatTypeRepKey     = mkPreludeMiscIdUnique 506+typeSymbolTypeRepKey  = mkPreludeMiscIdUnique 507+typeRepIdKey          = mkPreludeMiscIdUnique 508+mkTrFunKey            = mkPreludeMiscIdUnique 509++-- Representations for primitive types+trTYPEKey+  ,trTYPE'PtrRepLiftedKey+  , trRuntimeRepKey+  , tr'PtrRepLiftedKey+  :: Unique+trTYPEKey              = mkPreludeMiscIdUnique 510+trTYPE'PtrRepLiftedKey = mkPreludeMiscIdUnique 511+trRuntimeRepKey        = mkPreludeMiscIdUnique 512+tr'PtrRepLiftedKey     = mkPreludeMiscIdUnique 513++-- KindReps for common cases+starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey :: Unique+starKindRepKey        = mkPreludeMiscIdUnique 520+starArrStarKindRepKey = mkPreludeMiscIdUnique 521+starArrStarArrStarKindRepKey = mkPreludeMiscIdUnique 522++-- Dynamic+toDynIdKey :: Unique+toDynIdKey            = mkPreludeMiscIdUnique 550++bitIntegerIdKey :: Unique+bitIntegerIdKey       = mkPreludeMiscIdUnique 551++heqSCSelIdKey, coercibleSCSelIdKey :: Unique+heqSCSelIdKey       = mkPreludeMiscIdUnique 552+coercibleSCSelIdKey = mkPreludeMiscIdUnique 553++sappendClassOpKey :: Unique+sappendClassOpKey = mkPreludeMiscIdUnique 554++memptyClassOpKey, mappendClassOpKey, mconcatClassOpKey :: Unique+memptyClassOpKey  = mkPreludeMiscIdUnique 555+mappendClassOpKey = mkPreludeMiscIdUnique 556+mconcatClassOpKey = mkPreludeMiscIdUnique 557++emptyCallStackKey, pushCallStackKey :: Unique+emptyCallStackKey = mkPreludeMiscIdUnique 558+pushCallStackKey  = mkPreludeMiscIdUnique 559++fromStaticPtrClassOpKey :: Unique+fromStaticPtrClassOpKey = mkPreludeMiscIdUnique 560++makeStaticKey :: Unique+makeStaticKey = mkPreludeMiscIdUnique 561++-- Natural+naturalFromIntegerIdKey :: Unique+naturalFromIntegerIdKey = mkPreludeMiscIdUnique 562++{-+************************************************************************+*                                                                      *+\subsection[Class-std-groups]{Standard groups of Prelude classes}+*                                                                      *+************************************************************************++NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@+even though every numeric class has these two as a superclass,+because the list of ambiguous dictionaries hasn't been simplified.+-}++numericClassKeys :: [Unique]+numericClassKeys =+        [ numClassKey+        , realClassKey+        , integralClassKey+        ]+        ++ fractionalClassKeys++fractionalClassKeys :: [Unique]+fractionalClassKeys =+        [ fractionalClassKey+        , floatingClassKey+        , realFracClassKey+        , realFloatClassKey+        ]++-- The "standard classes" are used in defaulting (Haskell 98 report 4.3.4),+-- and are: "classes defined in the Prelude or a standard library"+standardClassKeys :: [Unique]+standardClassKeys = derivableClassKeys ++ numericClassKeys+                  ++ [randomClassKey, randomGenClassKey,+                      functorClassKey,+                      monadClassKey, monadPlusClassKey, monadFailClassKey,+                      semigroupClassKey, monoidClassKey,+                      isStringClassKey,+                      applicativeClassKey, foldableClassKey,+                      traversableClassKey, alternativeClassKey+                     ]++{-+@derivableClassKeys@ is also used in checking \tr{deriving} constructs+(@TcDeriv@).+-}++derivableClassKeys :: [Unique]+derivableClassKeys+  = [ eqClassKey, ordClassKey, enumClassKey, ixClassKey,+      boundedClassKey, showClassKey, readClassKey ]+++-- These are the "interactive classes" that are consulted when doing+-- defaulting. Does not include Num or IsString, which have special+-- handling.+interactiveClassNames :: [Name]+interactiveClassNames+  = [ showClassName, eqClassName, ordClassName, foldableClassName+    , traversableClassName ]++interactiveClassKeys :: [Unique]+interactiveClassKeys = map getUnique interactiveClassNames++{-+************************************************************************+*                                                                      *+   Semi-builtin names+*                                                                      *+************************************************************************++The following names should be considered by GHCi to be in scope always.++-}++pretendNameIsInScope :: Name -> Bool+pretendNameIsInScope n+  = any (n `hasKey`)+    [ starKindTyConKey, liftedTypeKindTyConKey, tYPETyConKey+    , runtimeRepTyConKey, liftedRepDataConKey ]
+ prelude/PrelNames.hs-boot view
@@ -0,0 +1,8 @@+module PrelNames where++import Module+import Unique++mAIN :: Module+starKindTyConKey :: Unique+unicodeStarKindTyConKey :: Unique
+ prelude/PrelRules.hs view
@@ -0,0 +1,1477 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[ConFold]{Constant Folder}++Conceptually, constant folding should be parameterized with the kind+of target machine to get identical behaviour during compilation time+and runtime. We cheat a little bit here...++ToDo:+   check boundaries before folding, e.g. we can fold the Float addition+   (i1 + i2) only if it results in a valid Float.+-}++{-# LANGUAGE CPP, RankNTypes #-}+{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}++module PrelRules+   ( primOpRules+   , builtinRules+   , caseRules+   )+where++#include "HsVersions.h"+#include "MachDeps.h"++import {-# SOURCE #-} MkId ( mkPrimOpId, magicDictId )++import CoreSyn+import MkCore+import Id+import Literal+import CoreOpt     ( exprIsLiteral_maybe )+import PrimOp      ( PrimOp(..), tagToEnumKey )+import TysWiredIn+import TysPrim+import TyCon       ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon, unwrapNewTyCon_maybe )+import DataCon     ( dataConTag, dataConTyCon, dataConWorkId )+import CoreUtils   ( cheapEqExpr, exprIsHNF )+import CoreUnfold  ( exprIsConApp_maybe )+import Type+import OccName     ( occNameFS )+import PrelNames+import Maybes      ( orElse )+import Name        ( Name, nameOccName )+import Outputable+import FastString+import BasicTypes+import DynFlags+import Platform+import Util+import Coercion     (mkUnbranchedAxInstCo,mkSymCo,Role(..))++import Control.Applicative ( Alternative(..) )++import Control.Monad+#if __GLASGOW_HASKELL__ > 710+import qualified Control.Monad.Fail as MonadFail+#endif+import Data.Bits as Bits+import qualified Data.ByteString as BS+import Data.Int+import Data.Ratio+import Data.Word++{-+Note [Constant folding]+~~~~~~~~~~~~~~~~~~~~~~~+primOpRules generates a rewrite rule for each primop+These rules do what is often called "constant folding"+E.g. the rules for +# might say+        4 +# 5 = 9+Well, of course you'd need a lot of rules if you did it+like that, so we use a BuiltinRule instead, so that we+can match in any two literal values.  So the rule is really+more like+        (Lit x) +# (Lit y) = Lit (x+#y)+where the (+#) on the rhs is done at compile time++That is why these rules are built in here.+-}++primOpRules :: Name -> PrimOp -> Maybe CoreRule+    -- ToDo: something for integer-shift ops?+    --       NotOp+primOpRules nm TagToEnumOp = mkPrimOpRule nm 2 [ tagToEnumRule ]+primOpRules nm DataToTagOp = mkPrimOpRule nm 2 [ dataToTagRule ]++-- Int operations+primOpRules nm IntAddOp    = mkPrimOpRule nm 2 [ binaryLit (intOp2 (+))+                                               , identityDynFlags zeroi ]+primOpRules nm IntSubOp    = mkPrimOpRule nm 2 [ binaryLit (intOp2 (-))+                                               , rightIdentityDynFlags zeroi+                                               , equalArgs >> retLit zeroi ]+primOpRules nm IntMulOp    = mkPrimOpRule nm 2 [ binaryLit (intOp2 (*))+                                               , zeroElem zeroi+                                               , identityDynFlags onei ]+primOpRules nm IntQuotOp   = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot)+                                               , leftZero zeroi+                                               , rightIdentityDynFlags onei+                                               , equalArgs >> retLit onei ]+primOpRules nm IntRemOp    = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem)+                                               , leftZero zeroi+                                               , do l <- getLiteral 1+                                                    dflags <- getDynFlags+                                                    guard (l == onei dflags)+                                                    retLit zeroi+                                               , equalArgs >> retLit zeroi+                                               , equalArgs >> retLit zeroi ]+primOpRules nm AndIOp      = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.&.))+                                               , idempotent+                                               , zeroElem zeroi ]+primOpRules nm OrIOp       = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.))+                                               , idempotent+                                               , identityDynFlags zeroi ]+primOpRules nm XorIOp      = mkPrimOpRule nm 2 [ binaryLit (intOp2 xor)+                                               , identityDynFlags zeroi+                                               , equalArgs >> retLit zeroi ]+primOpRules nm NotIOp      = mkPrimOpRule nm 1 [ unaryLit complementOp+                                               , inversePrimOp NotIOp ]+primOpRules nm IntNegOp    = mkPrimOpRule nm 1 [ unaryLit negOp+                                               , inversePrimOp IntNegOp ]+primOpRules nm ISllOp      = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftL)+                                               , rightIdentityDynFlags zeroi ]+primOpRules nm ISraOp      = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftR)+                                               , rightIdentityDynFlags zeroi ]+primOpRules nm ISrlOp      = mkPrimOpRule nm 2 [ binaryLit (intOp2' shiftRightLogical)+                                               , rightIdentityDynFlags zeroi ]++-- Word operations+primOpRules nm WordAddOp   = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+))+                                               , identityDynFlags zerow ]+primOpRules nm WordSubOp   = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-))+                                               , rightIdentityDynFlags zerow+                                               , equalArgs >> retLit zerow ]+primOpRules nm WordMulOp   = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*))+                                               , identityDynFlags onew ]+primOpRules nm WordQuotOp  = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot)+                                               , rightIdentityDynFlags onew ]+primOpRules nm WordRemOp   = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem)+                                               , leftZero zerow+                                               , do l <- getLiteral 1+                                                    dflags <- getDynFlags+                                                    guard (l == onew dflags)+                                                    retLit zerow+                                               , equalArgs >> retLit zerow ]+primOpRules nm AndOp       = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.))+                                               , idempotent+                                               , zeroElem zerow ]+primOpRules nm OrOp        = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.))+                                               , idempotent+                                               , identityDynFlags zerow ]+primOpRules nm XorOp       = mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor)+                                               , identityDynFlags zerow+                                               , equalArgs >> retLit zerow ]+primOpRules nm NotOp       = mkPrimOpRule nm 1 [ unaryLit complementOp+                                               , inversePrimOp NotOp ]+primOpRules nm SllOp       = mkPrimOpRule nm 2 [ wordShiftRule (const Bits.shiftL) ]+primOpRules nm SrlOp       = mkPrimOpRule nm 2 [ wordShiftRule shiftRightLogical ]++-- coercions+primOpRules nm Word2IntOp     = mkPrimOpRule nm 1 [ liftLitDynFlags word2IntLit+                                                  , inversePrimOp Int2WordOp ]+primOpRules nm Int2WordOp     = mkPrimOpRule nm 1 [ liftLitDynFlags int2WordLit+                                                  , inversePrimOp Word2IntOp ]+primOpRules nm Narrow8IntOp   = mkPrimOpRule nm 1 [ liftLit narrow8IntLit+                                                  , subsumedByPrimOp Narrow8IntOp+                                                  , Narrow8IntOp `subsumesPrimOp` Narrow16IntOp+                                                  , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp ]+primOpRules nm Narrow16IntOp  = mkPrimOpRule nm 1 [ liftLit narrow16IntLit+                                                  , subsumedByPrimOp Narrow8IntOp+                                                  , subsumedByPrimOp Narrow16IntOp+                                                  , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp ]+primOpRules nm Narrow32IntOp  = mkPrimOpRule nm 1 [ liftLit narrow32IntLit+                                                  , subsumedByPrimOp Narrow8IntOp+                                                  , subsumedByPrimOp Narrow16IntOp+                                                  , subsumedByPrimOp Narrow32IntOp+                                                  , removeOp32 ]+primOpRules nm Narrow8WordOp  = mkPrimOpRule nm 1 [ liftLit narrow8WordLit+                                                  , subsumedByPrimOp Narrow8WordOp+                                                  , Narrow8WordOp `subsumesPrimOp` Narrow16WordOp+                                                  , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp ]+primOpRules nm Narrow16WordOp = mkPrimOpRule nm 1 [ liftLit narrow16WordLit+                                                  , subsumedByPrimOp Narrow8WordOp+                                                  , subsumedByPrimOp Narrow16WordOp+                                                  , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp ]+primOpRules nm Narrow32WordOp = mkPrimOpRule nm 1 [ liftLit narrow32WordLit+                                                  , subsumedByPrimOp Narrow8WordOp+                                                  , subsumedByPrimOp Narrow16WordOp+                                                  , subsumedByPrimOp Narrow32WordOp+                                                  , removeOp32 ]+primOpRules nm OrdOp          = mkPrimOpRule nm 1 [ liftLit char2IntLit+                                                  , inversePrimOp ChrOp ]+primOpRules nm ChrOp          = mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs+                                                       guard (litFitsInChar lit)+                                                       liftLit int2CharLit+                                                  , inversePrimOp OrdOp ]+primOpRules nm Float2IntOp    = mkPrimOpRule nm 1 [ liftLit float2IntLit ]+primOpRules nm Int2FloatOp    = mkPrimOpRule nm 1 [ liftLit int2FloatLit ]+primOpRules nm Double2IntOp   = mkPrimOpRule nm 1 [ liftLit double2IntLit ]+primOpRules nm Int2DoubleOp   = mkPrimOpRule nm 1 [ liftLit int2DoubleLit ]+-- SUP: Not sure what the standard says about precision in the following 2 cases+primOpRules nm Float2DoubleOp = mkPrimOpRule nm 1 [ liftLit float2DoubleLit ]+primOpRules nm Double2FloatOp = mkPrimOpRule nm 1 [ liftLit double2FloatLit ]++-- Float+primOpRules nm FloatAddOp   = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+))+                                                , identity zerof ]+primOpRules nm FloatSubOp   = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-))+                                                , rightIdentity zerof ]+primOpRules nm FloatMulOp   = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*))+                                                , identity onef+                                                , strengthReduction twof FloatAddOp  ]+                         -- zeroElem zerof doesn't hold because of NaN+primOpRules nm FloatDivOp   = mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/))+                                                , rightIdentity onef ]+primOpRules nm FloatNegOp   = mkPrimOpRule nm 1 [ unaryLit negOp+                                                , inversePrimOp FloatNegOp ]++-- Double+primOpRules nm DoubleAddOp   = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+))+                                                 , identity zerod ]+primOpRules nm DoubleSubOp   = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-))+                                                 , rightIdentity zerod ]+primOpRules nm DoubleMulOp   = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*))+                                                 , identity oned+                                                 , strengthReduction twod DoubleAddOp  ]+                          -- zeroElem zerod doesn't hold because of NaN+primOpRules nm DoubleDivOp   = mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/))+                                                 , rightIdentity oned ]+primOpRules nm DoubleNegOp   = mkPrimOpRule nm 1 [ unaryLit negOp+                                                 , inversePrimOp DoubleNegOp ]++-- Relational operators++primOpRules nm IntEqOp    = mkRelOpRule nm (==) [ litEq True ]+primOpRules nm IntNeOp    = mkRelOpRule nm (/=) [ litEq False ]+primOpRules nm CharEqOp   = mkRelOpRule nm (==) [ litEq True ]+primOpRules nm CharNeOp   = mkRelOpRule nm (/=) [ litEq False ]++primOpRules nm IntGtOp    = mkRelOpRule nm (>)  [ boundsCmp Gt ]+primOpRules nm IntGeOp    = mkRelOpRule nm (>=) [ boundsCmp Ge ]+primOpRules nm IntLeOp    = mkRelOpRule nm (<=) [ boundsCmp Le ]+primOpRules nm IntLtOp    = mkRelOpRule nm (<)  [ boundsCmp Lt ]++primOpRules nm CharGtOp   = mkRelOpRule nm (>)  [ boundsCmp Gt ]+primOpRules nm CharGeOp   = mkRelOpRule nm (>=) [ boundsCmp Ge ]+primOpRules nm CharLeOp   = mkRelOpRule nm (<=) [ boundsCmp Le ]+primOpRules nm CharLtOp   = mkRelOpRule nm (<)  [ boundsCmp Lt ]++primOpRules nm FloatGtOp  = mkFloatingRelOpRule nm (>)+primOpRules nm FloatGeOp  = mkFloatingRelOpRule nm (>=)+primOpRules nm FloatLeOp  = mkFloatingRelOpRule nm (<=)+primOpRules nm FloatLtOp  = mkFloatingRelOpRule nm (<)+primOpRules nm FloatEqOp  = mkFloatingRelOpRule nm (==)+primOpRules nm FloatNeOp  = mkFloatingRelOpRule nm (/=)++primOpRules nm DoubleGtOp = mkFloatingRelOpRule nm (>)+primOpRules nm DoubleGeOp = mkFloatingRelOpRule nm (>=)+primOpRules nm DoubleLeOp = mkFloatingRelOpRule nm (<=)+primOpRules nm DoubleLtOp = mkFloatingRelOpRule nm (<)+primOpRules nm DoubleEqOp = mkFloatingRelOpRule nm (==)+primOpRules nm DoubleNeOp = mkFloatingRelOpRule nm (/=)++primOpRules nm WordGtOp   = mkRelOpRule nm (>)  [ boundsCmp Gt ]+primOpRules nm WordGeOp   = mkRelOpRule nm (>=) [ boundsCmp Ge ]+primOpRules nm WordLeOp   = mkRelOpRule nm (<=) [ boundsCmp Le ]+primOpRules nm WordLtOp   = mkRelOpRule nm (<)  [ boundsCmp Lt ]+primOpRules nm WordEqOp   = mkRelOpRule nm (==) [ litEq True ]+primOpRules nm WordNeOp   = mkRelOpRule nm (/=) [ litEq False ]++primOpRules nm AddrAddOp  = mkPrimOpRule nm 2 [ rightIdentityDynFlags zeroi ]++primOpRules nm SeqOp      = mkPrimOpRule nm 4 [ seqRule ]+primOpRules nm SparkOp    = mkPrimOpRule nm 4 [ sparkRule ]++primOpRules _  _          = Nothing++{-+************************************************************************+*                                                                      *+\subsection{Doing the business}+*                                                                      *+************************************************************************+-}++-- useful shorthands+mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule+mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules)++mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)+            -> [RuleM CoreExpr] -> Maybe CoreRule+mkRelOpRule nm cmp extra+  = mkPrimOpRule nm 2 $+    binaryCmpLit cmp : equal_rule : extra+  where+        -- x `cmp` x does not depend on x, so+        -- compute it for the arbitrary value 'True'+        -- and use that result+    equal_rule = do { equalArgs+                    ; dflags <- getDynFlags+                    ; return (if cmp True True+                              then trueValInt  dflags+                              else falseValInt dflags) }++{- Note [Rules for floating-point comparisons]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need different rules for floating-point values because for floats+it is not true that x = x (for NaNs); so we do not want the equal_rule+rule that mkRelOpRule uses.++Note also that, in the case of equality/inequality, we do /not/+want to switch to a case-expression.  For example, we do not want+to convert+   case (eqFloat# x 3.8#) of+     True -> this+     False -> that+to+  case x of+    3.8#::Float# -> this+    _            -> that+See Trac #9238.  Reason: comparing floating-point values for equality+delicate, and we don't want to implement that delicacy in the code for+case expressions.  So we make it an invariant of Core that a case+expression never scrutinises a Float# or Double#.++This transformation is what the litEq rule does;+see Note [The litEq rule: converting equality to case].+So we /refrain/ from using litEq for mkFloatingRelOpRule.+-}++mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)+                    -> Maybe CoreRule+-- See Note [Rules for floating-point comparisons]+mkFloatingRelOpRule nm cmp+  = mkPrimOpRule nm 2 [binaryCmpLit cmp]++-- common constants+zeroi, onei, zerow, onew :: DynFlags -> Literal+zeroi dflags = mkMachInt  dflags 0+onei  dflags = mkMachInt  dflags 1+zerow dflags = mkMachWord dflags 0+onew  dflags = mkMachWord dflags 1++zerof, onef, twof, zerod, oned, twod :: Literal+zerof = mkMachFloat 0.0+onef  = mkMachFloat 1.0+twof  = mkMachFloat 2.0+zerod = mkMachDouble 0.0+oned  = mkMachDouble 1.0+twod  = mkMachDouble 2.0++cmpOp :: DynFlags -> (forall a . Ord a => a -> a -> Bool)+      -> Literal -> Literal -> Maybe CoreExpr+cmpOp dflags cmp = go+  where+    done True  = Just $ trueValInt  dflags+    done False = Just $ falseValInt dflags++    -- These compares are at different types+    go (MachChar i1)   (MachChar i2)   = done (i1 `cmp` i2)+    go (MachInt i1)    (MachInt i2)    = done (i1 `cmp` i2)+    go (MachInt64 i1)  (MachInt64 i2)  = done (i1 `cmp` i2)+    go (MachWord i1)   (MachWord i2)   = done (i1 `cmp` i2)+    go (MachWord64 i1) (MachWord64 i2) = done (i1 `cmp` i2)+    go (MachFloat i1)  (MachFloat i2)  = done (i1 `cmp` i2)+    go (MachDouble i1) (MachDouble i2) = done (i1 `cmp` i2)+    go _               _               = Nothing++--------------------------++negOp :: DynFlags -> Literal -> Maybe CoreExpr  -- Negate+negOp _      (MachFloat 0.0)  = Nothing  -- can't represent -0.0 as a Rational+negOp dflags (MachFloat f)    = Just (mkFloatVal dflags (-f))+negOp _      (MachDouble 0.0) = Nothing+negOp dflags (MachDouble d)   = Just (mkDoubleVal dflags (-d))+negOp dflags (MachInt i)      = intResult dflags (-i)+negOp _      _                = Nothing++complementOp :: DynFlags -> Literal -> Maybe CoreExpr  -- Binary complement+complementOp dflags (MachWord i) = wordResult dflags (complement i)+complementOp dflags (MachInt i)  = intResult  dflags (complement i)+complementOp _      _            = Nothing++--------------------------+intOp2 :: (Integral a, Integral b)+       => (a -> b -> Integer)+       -> DynFlags -> Literal -> Literal -> Maybe CoreExpr+intOp2 = intOp2' . const++intOp2' :: (Integral a, Integral b)+        => (DynFlags -> a -> b -> Integer)+        -> DynFlags -> Literal -> Literal -> Maybe CoreExpr+intOp2' op dflags (MachInt i1) (MachInt i2) =+  let o = op dflags+  in  intResult dflags (fromInteger i1 `o` fromInteger i2)+intOp2' _  _      _            _            = Nothing  -- Could find LitLit++shiftRightLogical :: DynFlags -> Integer -> Int -> Integer+-- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do+-- Do this by converting to Word and back.  Obviously this won't work for big+-- values, but its ok as we use it here+shiftRightLogical dflags x n+  | wordSizeInBits dflags == 32 = fromIntegral (fromInteger x `shiftR` n :: Word32)+  | wordSizeInBits dflags == 64 = fromIntegral (fromInteger x `shiftR` n :: Word64)+  | otherwise = panic "shiftRightLogical: unsupported word size"++--------------------------+retLit :: (DynFlags -> Literal) -> RuleM CoreExpr+retLit l = do dflags <- getDynFlags+              return $ Lit $ l dflags++wordOp2 :: (Integral a, Integral b)+        => (a -> b -> Integer)+        -> DynFlags -> Literal -> Literal -> Maybe CoreExpr+wordOp2 op dflags (MachWord w1) (MachWord w2)+    = wordResult dflags (fromInteger w1 `op` fromInteger w2)+wordOp2 _ _ _ _ = Nothing  -- Could find LitLit++wordShiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr+                 -- Shifts take an Int; hence third arg of op is Int+-- See Note [Guarding against silly shifts]+wordShiftRule shift_op+  = do { dflags <- getDynFlags+       ; [e1, Lit (MachInt shift_len)] <- getArgs+       ; case e1 of+           _ | shift_len == 0+             -> return e1+             | shift_len < 0 || wordSizeInBits dflags < shift_len+             -> return (mkRuntimeErrorApp rUNTIME_ERROR_ID wordPrimTy+                                        ("Bad shift length" ++ show shift_len))+           Lit (MachWord x)+             -> let op = shift_op dflags+                in  liftMaybe $ wordResult dflags (x `op` fromInteger shift_len)+                    -- Do the shift at type Integer, but shift length is Int+           _ -> mzero }++wordSizeInBits :: DynFlags -> Integer+wordSizeInBits dflags = toInteger (platformWordSize (targetPlatform dflags) `shiftL` 3)++--------------------------+floatOp2 :: (Rational -> Rational -> Rational)+         -> DynFlags -> Literal -> Literal+         -> Maybe (Expr CoreBndr)+floatOp2 op dflags (MachFloat f1) (MachFloat f2)+  = Just (mkFloatVal dflags (f1 `op` f2))+floatOp2 _ _ _ _ = Nothing++--------------------------+doubleOp2 :: (Rational -> Rational -> Rational)+          -> DynFlags -> Literal -> Literal+          -> Maybe (Expr CoreBndr)+doubleOp2 op dflags (MachDouble f1) (MachDouble f2)+  = Just (mkDoubleVal dflags (f1 `op` f2))+doubleOp2 _ _ _ _ = Nothing++--------------------------+{- Note [The litEq rule: converting equality to case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This stuff turns+     n ==# 3#+into+     case n of+       3# -> True+       m  -> False++This is a Good Thing, because it allows case-of case things+to happen, and case-default absorption to happen.  For+example:++     if (n ==# 3#) || (n ==# 4#) then e1 else e2+will transform to+     case n of+       3# -> e1+       4# -> e1+       m  -> e2+(modulo the usual precautions to avoid duplicating e1)+-}++litEq :: Bool  -- True <=> equality, False <=> inequality+      -> RuleM CoreExpr+litEq is_eq = msum+  [ do [Lit lit, expr] <- getArgs+       dflags <- getDynFlags+       do_lit_eq dflags lit expr+  , do [expr, Lit lit] <- getArgs+       dflags <- getDynFlags+       do_lit_eq dflags lit expr ]+  where+    do_lit_eq dflags lit expr = do+      guard (not (litIsLifted lit))+      return (mkWildCase expr (literalType lit) intPrimTy+                    [(DEFAULT,    [], val_if_neq),+                     (LitAlt lit, [], val_if_eq)])+      where+        val_if_eq  | is_eq     = trueValInt  dflags+                   | otherwise = falseValInt dflags+        val_if_neq | is_eq     = falseValInt dflags+                   | otherwise = trueValInt  dflags+++-- | Check if there is comparison with minBound or maxBound, that is+-- always true or false. For instance, an Int cannot be smaller than its+-- minBound, so we can replace such comparison with False.+boundsCmp :: Comparison -> RuleM CoreExpr+boundsCmp op = do+  dflags <- getDynFlags+  [a, b] <- getArgs+  liftMaybe $ mkRuleFn dflags op a b++data Comparison = Gt | Ge | Lt | Le++mkRuleFn :: DynFlags -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr+mkRuleFn dflags Gt (Lit lit) _ | isMinBound dflags lit = Just $ falseValInt dflags+mkRuleFn dflags Le (Lit lit) _ | isMinBound dflags lit = Just $ trueValInt  dflags+mkRuleFn dflags Ge _ (Lit lit) | isMinBound dflags lit = Just $ trueValInt  dflags+mkRuleFn dflags Lt _ (Lit lit) | isMinBound dflags lit = Just $ falseValInt dflags+mkRuleFn dflags Ge (Lit lit) _ | isMaxBound dflags lit = Just $ trueValInt  dflags+mkRuleFn dflags Lt (Lit lit) _ | isMaxBound dflags lit = Just $ falseValInt dflags+mkRuleFn dflags Gt _ (Lit lit) | isMaxBound dflags lit = Just $ falseValInt dflags+mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just $ trueValInt  dflags+mkRuleFn _ _ _ _                                       = Nothing++isMinBound :: DynFlags -> Literal -> Bool+isMinBound _      (MachChar c)   = c == minBound+isMinBound dflags (MachInt i)    = i == tARGET_MIN_INT dflags+isMinBound _      (MachInt64 i)  = i == toInteger (minBound :: Int64)+isMinBound _      (MachWord i)   = i == 0+isMinBound _      (MachWord64 i) = i == 0+isMinBound _      _              = False++isMaxBound :: DynFlags -> Literal -> Bool+isMaxBound _      (MachChar c)   = c == maxBound+isMaxBound dflags (MachInt i)    = i == tARGET_MAX_INT dflags+isMaxBound _      (MachInt64 i)  = i == toInteger (maxBound :: Int64)+isMaxBound dflags (MachWord i)   = i == tARGET_MAX_WORD dflags+isMaxBound _      (MachWord64 i) = i == toInteger (maxBound :: Word64)+isMaxBound _      _              = False+++-- Note [Word/Int underflow/overflow]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- According to the Haskell Report 2010 (Sections 18.1 and 23.1 about signed and+-- unsigned integral types): "All arithmetic is performed modulo 2^n, where n is+-- the number of bits in the type."+--+-- GHC stores Word# and Int# constant values as Integer. Core optimizations such+-- as constant folding must ensure that the Integer value remains in the valid+-- target Word/Int range (see #13172). The following functions are used to+-- ensure this.+--+-- Note that we *don't* warn the user about overflow. It's not done at runtime+-- either, and compilation of completely harmless things like+--    ((124076834 :: Word32) + (2147483647 :: Word32))+-- doesn't yield a warning. Instead we simply squash the value into the *target*+-- Int/Word range.++-- | Ensure the given Integer is in the target Int range+intResult' :: DynFlags -> Integer -> Integer+intResult' dflags result = case platformWordSize (targetPlatform dflags) of+   4 -> toInteger (fromInteger result :: Int32)+   8 -> toInteger (fromInteger result :: Int64)+   w -> panic ("intResult: Unknown platformWordSize: " ++ show w)++-- | Ensure the given Integer is in the target Word range+wordResult' :: DynFlags -> Integer -> Integer+wordResult' dflags result = case platformWordSize (targetPlatform dflags) of+   4 -> toInteger (fromInteger result :: Word32)+   8 -> toInteger (fromInteger result :: Word64)+   w -> panic ("wordResult: Unknown platformWordSize: " ++ show w)++-- | Create an Int literal expression while ensuring the given Integer is in the+-- target Int range+intResult :: DynFlags -> Integer -> Maybe CoreExpr+intResult dflags result = Just (mkIntVal dflags (intResult' dflags result))++-- | Create a Word literal expression while ensuring the given Integer is in the+-- target Word range+wordResult :: DynFlags -> Integer -> Maybe CoreExpr+wordResult dflags result = Just (mkWordVal dflags (wordResult' dflags result))+++++inversePrimOp :: PrimOp -> RuleM CoreExpr+inversePrimOp primop = do+  [Var primop_id `App` e] <- getArgs+  matchPrimOpId primop primop_id+  return e++subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr+this `subsumesPrimOp` that = do+  [Var primop_id `App` e] <- getArgs+  matchPrimOpId that primop_id+  return (Var (mkPrimOpId this) `App` e)++subsumedByPrimOp :: PrimOp -> RuleM CoreExpr+subsumedByPrimOp primop = do+  [e@(Var primop_id `App` _)] <- getArgs+  matchPrimOpId primop primop_id+  return e++idempotent :: RuleM CoreExpr+idempotent = do [e1, e2] <- getArgs+                guard $ cheapEqExpr e1 e2+                return e1++{-+Note [Guarding against silly shifts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this code:++  import Data.Bits( (.|.), shiftL )+  chunkToBitmap :: [Bool] -> Word32+  chunkToBitmap chunk = foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ]++This optimises to:+Shift.$wgo = \ (w_sCS :: GHC.Prim.Int#) (w1_sCT :: [GHC.Types.Bool]) ->+    case w1_sCT of _ {+      [] -> 0##;+      : x_aAW xs_aAX ->+        case x_aAW of _ {+          GHC.Types.False ->+            case w_sCS of wild2_Xh {+              __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild2_Xh 1) xs_aAX;+              9223372036854775807 -> 0## };+          GHC.Types.True ->+            case GHC.Prim.>=# w_sCS 64 of _ {+              GHC.Types.False ->+                case w_sCS of wild3_Xh {+                  __DEFAULT ->+                    case Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX of ww_sCW { __DEFAULT ->+                      GHC.Prim.or# (GHC.Prim.narrow32Word#+                                      (GHC.Prim.uncheckedShiftL# 1## wild3_Xh))+                                   ww_sCW+                     };+                  9223372036854775807 ->+                    GHC.Prim.narrow32Word#+!!!!-->                  (GHC.Prim.uncheckedShiftL# 1## 9223372036854775807)+                };+              GHC.Types.True ->+                case w_sCS of wild3_Xh {+                  __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX;+                  9223372036854775807 -> 0##+                } } } }++Note the massive shift on line "!!!!".  It can't happen, because we've checked+that w < 64, but the optimiser didn't spot that. We DO NO want to constant-fold this!+Moreover, if the programmer writes (n `uncheckedShiftL` 9223372036854775807), we+can't constant fold it, but if it gets to the assember we get+     Error: operand type mismatch for `shl'++So the best thing to do is to rewrite the shift with a call to error,+when the second arg is stupid.++************************************************************************+*                                                                      *+\subsection{Vaguely generic functions}+*                                                                      *+************************************************************************+-}++mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule+-- Gives the Rule the same name as the primop itself+mkBasicRule op_name n_args rm+  = BuiltinRule { ru_name = occNameFS (nameOccName op_name),+                  ru_fn = op_name,+                  ru_nargs = n_args,+                  ru_try = \ dflags in_scope _ -> runRuleM rm dflags in_scope }++newtype RuleM r = RuleM+  { runRuleM :: DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r }++instance Functor RuleM where+    fmap = liftM++instance Applicative RuleM where+    pure x = RuleM $ \_ _ _ -> Just x+    (<*>) = ap++instance Monad RuleM where+  RuleM f >>= g = RuleM $ \dflags iu e -> case f dflags iu e of+    Nothing -> Nothing+    Just r -> runRuleM (g r) dflags iu e+  fail _ = mzero++#if __GLASGOW_HASKELL__ > 710+instance MonadFail.MonadFail RuleM where+    fail _ = mzero+#endif++instance Alternative RuleM where+  empty = RuleM $ \_ _ _ -> Nothing+  RuleM f1 <|> RuleM f2 = RuleM $ \dflags iu args ->+    f1 dflags iu args <|> f2 dflags iu args++instance MonadPlus RuleM++instance HasDynFlags RuleM where+    getDynFlags = RuleM $ \dflags _ _ -> Just dflags++liftMaybe :: Maybe a -> RuleM a+liftMaybe Nothing = mzero+liftMaybe (Just x) = return x++liftLit :: (Literal -> Literal) -> RuleM CoreExpr+liftLit f = liftLitDynFlags (const f)++liftLitDynFlags :: (DynFlags -> Literal -> Literal) -> RuleM CoreExpr+liftLitDynFlags f = do+  dflags <- getDynFlags+  [Lit lit] <- getArgs+  return $ Lit (f dflags lit)++removeOp32 :: RuleM CoreExpr+removeOp32 = do+  dflags <- getDynFlags+  if wordSizeInBits dflags == 32+  then do+    [e] <- getArgs+    return e+  else mzero++getArgs :: RuleM [CoreExpr]+getArgs = RuleM $ \_ _ args -> Just args++getInScopeEnv :: RuleM InScopeEnv+getInScopeEnv = RuleM $ \_ iu _ -> Just iu++-- return the n-th argument of this rule, if it is a literal+-- argument indices start from 0+getLiteral :: Int -> RuleM Literal+getLiteral n = RuleM $ \_ _ exprs -> case drop n exprs of+  (Lit l:_) -> Just l+  _ -> Nothing++unaryLit :: (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr+unaryLit op = do+  dflags <- getDynFlags+  [Lit l] <- getArgs+  liftMaybe $ op dflags (convFloating dflags l)++binaryLit :: (DynFlags -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr+binaryLit op = do+  dflags <- getDynFlags+  [Lit l1, Lit l2] <- getArgs+  liftMaybe $ op dflags (convFloating dflags l1) (convFloating dflags l2)++binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr+binaryCmpLit op = do+  dflags <- getDynFlags+  binaryLit (\_ -> cmpOp dflags op)++leftIdentity :: Literal -> RuleM CoreExpr+leftIdentity id_lit = leftIdentityDynFlags (const id_lit)++rightIdentity :: Literal -> RuleM CoreExpr+rightIdentity id_lit = rightIdentityDynFlags (const id_lit)++identity :: Literal -> RuleM CoreExpr+identity lit = leftIdentity lit `mplus` rightIdentity lit++leftIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr+leftIdentityDynFlags id_lit = do+  dflags <- getDynFlags+  [Lit l1, e2] <- getArgs+  guard $ l1 == id_lit dflags+  return e2++rightIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr+rightIdentityDynFlags id_lit = do+  dflags <- getDynFlags+  [e1, Lit l2] <- getArgs+  guard $ l2 == id_lit dflags+  return e1++identityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr+identityDynFlags lit = leftIdentityDynFlags lit `mplus` rightIdentityDynFlags lit++leftZero :: (DynFlags -> Literal) -> RuleM CoreExpr+leftZero zero = do+  dflags <- getDynFlags+  [Lit l1, _] <- getArgs+  guard $ l1 == zero dflags+  return $ Lit l1++rightZero :: (DynFlags -> Literal) -> RuleM CoreExpr+rightZero zero = do+  dflags <- getDynFlags+  [_, Lit l2] <- getArgs+  guard $ l2 == zero dflags+  return $ Lit l2++zeroElem :: (DynFlags -> Literal) -> RuleM CoreExpr+zeroElem lit = leftZero lit `mplus` rightZero lit++equalArgs :: RuleM ()+equalArgs = do+  [e1, e2] <- getArgs+  guard $ e1 `cheapEqExpr` e2++nonZeroLit :: Int -> RuleM ()+nonZeroLit n = getLiteral n >>= guard . not . isZeroLit++-- When excess precision is not requested, cut down the precision of the+-- Rational value to that of Float/Double. We confuse host architecture+-- and target architecture here, but it's convenient (and wrong :-).+convFloating :: DynFlags -> Literal -> Literal+convFloating dflags (MachFloat  f) | not (gopt Opt_ExcessPrecision dflags) =+   MachFloat  (toRational (fromRational f :: Float ))+convFloating dflags (MachDouble d) | not (gopt Opt_ExcessPrecision dflags) =+   MachDouble (toRational (fromRational d :: Double))+convFloating _ l = l++guardFloatDiv :: RuleM ()+guardFloatDiv = do+  [Lit (MachFloat f1), Lit (MachFloat f2)] <- getArgs+  guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero]+       && f2 /= 0            -- avoid NaN and Infinity/-Infinity++guardDoubleDiv :: RuleM ()+guardDoubleDiv = do+  [Lit (MachDouble d1), Lit (MachDouble d2)] <- getArgs+  guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero]+       && d2 /= 0            -- avoid NaN and Infinity/-Infinity+-- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to+-- zero, but we might want to preserve the negative zero here which+-- is representable in Float/Double but not in (normalised)+-- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?++strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr+strengthReduction two_lit add_op = do -- Note [Strength reduction]+  arg <- msum [ do [arg, Lit mult_lit] <- getArgs+                   guard (mult_lit == two_lit)+                   return arg+              , do [Lit mult_lit, arg] <- getArgs+                   guard (mult_lit == two_lit)+                   return arg ]+  return $ Var (mkPrimOpId add_op) `App` arg `App` arg++-- Note [Strength reduction]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- This rule turns floating point multiplications of the form 2.0 * x and+-- x * 2.0 into x + x addition, because addition costs less than multiplication.+-- See #7116++-- Note [What's true and false]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- trueValInt and falseValInt represent true and false values returned by+-- comparison primops for Char, Int, Word, Integer, Double, Float and Addr.+-- True is represented as an unboxed 1# literal, while false is represented+-- as 0# literal.+-- We still need Bool data constructors (True and False) to use in a rule+-- for constant folding of equal Strings++trueValInt, falseValInt :: DynFlags -> Expr CoreBndr+trueValInt  dflags = Lit $ onei  dflags -- see Note [What's true and false]+falseValInt dflags = Lit $ zeroi dflags++trueValBool, falseValBool :: Expr CoreBndr+trueValBool   = Var trueDataConId -- see Note [What's true and false]+falseValBool  = Var falseDataConId++ltVal, eqVal, gtVal :: Expr CoreBndr+ltVal = Var ltDataConId+eqVal = Var eqDataConId+gtVal = Var gtDataConId++mkIntVal :: DynFlags -> Integer -> Expr CoreBndr+mkIntVal dflags i = Lit (mkMachInt dflags i)+mkWordVal :: DynFlags -> Integer -> Expr CoreBndr+mkWordVal dflags w = Lit (mkMachWord dflags w)+mkFloatVal :: DynFlags -> Rational -> Expr CoreBndr+mkFloatVal dflags f = Lit (convFloating dflags (MachFloat  f))+mkDoubleVal :: DynFlags -> Rational -> Expr CoreBndr+mkDoubleVal dflags d = Lit (convFloating dflags (MachDouble d))++matchPrimOpId :: PrimOp -> Id -> RuleM ()+matchPrimOpId op id = do+  op' <- liftMaybe $ isPrimOpId_maybe id+  guard $ op == op'++{-+************************************************************************+*                                                                      *+\subsection{Special rules for seq, tagToEnum, dataToTag}+*                                                                      *+************************************************************************++Note [tagToEnum#]+~~~~~~~~~~~~~~~~~+Nasty check to ensure that tagToEnum# is applied to a type that is an+enumeration TyCon.  Unification may refine the type later, but this+check won't see that, alas.  It's crude but it works.++Here's are two cases that should fail+        f :: forall a. a+        f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable++        g :: Int+        g = tagToEnum# 0        -- Int is not an enumeration++We used to make this check in the type inference engine, but it's quite+ugly to do so, because the delayed constraint solving means that we don't+really know what's going on until the end. It's very much a corner case+because we don't expect the user to call tagToEnum# at all; we merely+generate calls in derived instances of Enum.  So we compromise: a+rewrite rule rewrites a bad instance of tagToEnum# to an error call,+and emits a warning.+-}++tagToEnumRule :: RuleM CoreExpr+-- If     data T a = A | B | C+-- then   tag2Enum# (T ty) 2# -->  B ty+tagToEnumRule = do+  [Type ty, Lit (MachInt i)] <- getArgs+  case splitTyConApp_maybe ty of+    Just (tycon, tc_args) | isEnumerationTyCon tycon -> do+      let tag = fromInteger i+          correct_tag dc = (dataConTag dc - fIRST_TAG) == tag+      (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])+      ASSERT(null rest) return ()+      return $ mkTyApps (Var (dataConWorkId dc)) tc_args++    -- See Note [tagToEnum#]+    _ -> WARN( True, text "tagToEnum# on non-enumeration type" <+> ppr ty )+         return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"++{-+For dataToTag#, we can reduce if either++        (a) the argument is a constructor+        (b) the argument is a variable whose unfolding is a known constructor+-}++dataToTagRule :: RuleM CoreExpr+dataToTagRule = a `mplus` b+  where+    a = do+      [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs+      guard $ tag_to_enum `hasKey` tagToEnumKey+      guard $ ty1 `eqType` ty2+      return tag -- dataToTag (tagToEnum x)   ==>   x+    b = do+      dflags <- getDynFlags+      [_, val_arg] <- getArgs+      in_scope <- getInScopeEnv+      (dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg+      ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return ()+      return $ mkIntVal dflags (toInteger (dataConTag dc - fIRST_TAG))++{-+************************************************************************+*                                                                      *+\subsection{Rules for seq# and spark#}+*                                                                      *+************************************************************************+-}++-- seq# :: forall a s . a -> State# s -> (# State# s, a #)+seqRule :: RuleM CoreExpr+seqRule = do+  [Type ty_a, Type ty_s, a, s] <- getArgs+  guard $ exprIsHNF a+  return $ mkCoreUbxTup [mkStatePrimTy ty_s, ty_a] [s, a]++-- spark# :: forall a s . a -> State# s -> (# State# s, a #)+sparkRule :: RuleM CoreExpr+sparkRule = seqRule -- reduce on HNF, just the same+  -- XXX perhaps we shouldn't do this, because a spark eliminated by+  -- this rule won't be counted as a dud at runtime?++{-+************************************************************************+*                                                                      *+\subsection{Built in rules}+*                                                                      *+************************************************************************++Note [Scoping for Builtin rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When compiling a (base-package) module that defines one of the+functions mentioned in the RHS of a built-in rule, there's a danger+that we'll see++        f = ...(eq String x)....++        ....and lower down...++        eqString = ...++Then a rewrite would give++        f = ...(eqString x)...+        ....and lower down...+        eqString = ...++and lo, eqString is not in scope.  This only really matters when we get to code+generation.  With -O we do a GlomBinds step that does a new SCC analysis on the whole+set of bindings, which sorts out the dependency.  Without -O we don't do any rule+rewriting so again we are fine.++(This whole thing doesn't show up for non-built-in rules because their dependencies+are explicit.)+-}++builtinRules :: [CoreRule]+-- Rules for non-primops that can't be expressed using a RULE pragma+builtinRules+  = [BuiltinRule { ru_name = fsLit "AppendLitString",+                   ru_fn = unpackCStringFoldrName,+                   ru_nargs = 4, ru_try = match_append_lit },+     BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,+                   ru_nargs = 2, ru_try = match_eq_string },+     BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,+                   ru_nargs = 2, ru_try = \_ _ _ -> match_inline },+     BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId,+                   ru_nargs = 4, ru_try = \_ _ _ -> match_magicDict },+     mkBasicRule divIntName 2 $ msum+        [ nonZeroLit 1 >> binaryLit (intOp2 div)+        , leftZero zeroi+        , do+          [arg, Lit (MachInt d)] <- getArgs+          Just n <- return $ exactLog2 d+          dflags <- getDynFlags+          return $ Var (mkPrimOpId ISraOp) `App` arg `App` mkIntVal dflags n+        ],+     mkBasicRule modIntName 2 $ msum+        [ nonZeroLit 1 >> binaryLit (intOp2 mod)+        , leftZero zeroi+        , do+          [arg, Lit (MachInt d)] <- getArgs+          Just _ <- return $ exactLog2 d+          dflags <- getDynFlags+          return $ Var (mkPrimOpId AndIOp)+            `App` arg `App` mkIntVal dflags (d - 1)+        ]+     ]+ ++ builtinIntegerRules++builtinIntegerRules :: [CoreRule]+builtinIntegerRules =+ [rule_IntToInteger   "smallInteger"        smallIntegerName,+  rule_WordToInteger  "wordToInteger"       wordToIntegerName,+  rule_Int64ToInteger  "int64ToInteger"     int64ToIntegerName,+  rule_Word64ToInteger "word64ToInteger"    word64ToIntegerName,+  rule_convert        "integerToWord"       integerToWordName       mkWordLitWord,+  rule_convert        "integerToInt"        integerToIntName        mkIntLitInt,+  rule_convert        "integerToWord64"     integerToWord64Name     (\_ -> mkWord64LitWord64),+  rule_convert        "integerToInt64"      integerToInt64Name      (\_ -> mkInt64LitInt64),+  rule_binop          "plusInteger"         plusIntegerName         (+),+  rule_binop          "minusInteger"        minusIntegerName        (-),+  rule_binop          "timesInteger"        timesIntegerName        (*),+  rule_unop           "negateInteger"       negateIntegerName       negate,+  rule_binop_Prim     "eqInteger#"          eqIntegerPrimName       (==),+  rule_binop_Prim     "neqInteger#"         neqIntegerPrimName      (/=),+  rule_unop           "absInteger"          absIntegerName          abs,+  rule_unop           "signumInteger"       signumIntegerName       signum,+  rule_binop_Prim     "leInteger#"          leIntegerPrimName       (<=),+  rule_binop_Prim     "gtInteger#"          gtIntegerPrimName       (>),+  rule_binop_Prim     "ltInteger#"          ltIntegerPrimName       (<),+  rule_binop_Prim     "geInteger#"          geIntegerPrimName       (>=),+  rule_binop_Ordering "compareInteger"      compareIntegerName      compare,+  rule_encodeFloat    "encodeFloatInteger"  encodeFloatIntegerName  mkFloatLitFloat,+  rule_convert        "floatFromInteger"    floatFromIntegerName    (\_ -> mkFloatLitFloat),+  rule_encodeFloat    "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble,+  rule_decodeDouble   "decodeDoubleInteger" decodeDoubleIntegerName,+  rule_convert        "doubleFromInteger"   doubleFromIntegerName   (\_ -> mkDoubleLitDouble),+  rule_rationalTo     "rationalToFloat"     rationalToFloatName     mkFloatExpr,+  rule_rationalTo     "rationalToDouble"    rationalToDoubleName    mkDoubleExpr,+  rule_binop          "gcdInteger"          gcdIntegerName          gcd,+  rule_binop          "lcmInteger"          lcmIntegerName          lcm,+  rule_binop          "andInteger"          andIntegerName          (.&.),+  rule_binop          "orInteger"           orIntegerName           (.|.),+  rule_binop          "xorInteger"          xorIntegerName          xor,+  rule_unop           "complementInteger"   complementIntegerName   complement,+  rule_Int_binop      "shiftLInteger"       shiftLIntegerName       shiftL,+  rule_Int_binop      "shiftRInteger"       shiftRIntegerName       shiftR,+  rule_bitInteger     "bitInteger"          bitIntegerName,+  -- See Note [Integer division constant folding] in libraries/base/GHC/Real.hs+  rule_divop_one      "quotInteger"         quotIntegerName         quot,+  rule_divop_one      "remInteger"          remIntegerName          rem,+  rule_divop_one      "divInteger"          divIntegerName          div,+  rule_divop_one      "modInteger"          modIntegerName          mod,+  rule_divop_both     "divModInteger"       divModIntegerName       divMod,+  rule_divop_both     "quotRemInteger"      quotRemIntegerName      quotRem,+  -- These rules below don't actually have to be built in, but if we+  -- put them in the Haskell source then we'd have to duplicate them+  -- between all Integer implementations+  rule_XToIntegerToX "smallIntegerToInt"       integerToIntName    smallIntegerName,+  rule_XToIntegerToX "wordToIntegerToWord"     integerToWordName   wordToIntegerName,+  rule_XToIntegerToX "int64ToIntegerToInt64"   integerToInt64Name  int64ToIntegerName,+  rule_XToIntegerToX "word64ToIntegerToWord64" integerToWord64Name word64ToIntegerName,+  rule_smallIntegerTo "smallIntegerToWord"   integerToWordName     Int2WordOp,+  rule_smallIntegerTo "smallIntegerToFloat"  floatFromIntegerName  Int2FloatOp,+  rule_smallIntegerTo "smallIntegerToDouble" doubleFromIntegerName Int2DoubleOp+  ]+    where rule_convert str name convert+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,+                           ru_try = match_Integer_convert convert }+          rule_IntToInteger str name+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,+                           ru_try = match_IntToInteger }+          rule_WordToInteger str name+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,+                           ru_try = match_WordToInteger }+          rule_Int64ToInteger str name+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,+                           ru_try = match_Int64ToInteger }+          rule_Word64ToInteger str name+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,+                           ru_try = match_Word64ToInteger }+          rule_unop str name op+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,+                           ru_try = match_Integer_unop op }+          rule_bitInteger str name+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,+                           ru_try = match_IntToInteger_unop (bit . fromIntegral) }+          rule_binop str name op+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,+                           ru_try = match_Integer_binop op }+          rule_divop_both str name op+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,+                           ru_try = match_Integer_divop_both op }+          rule_divop_one str name op+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,+                           ru_try = match_Integer_divop_one op }+          rule_Int_binop str name op+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,+                           ru_try = match_Integer_Int_binop op }+          rule_binop_Prim str name op+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,+                           ru_try = match_Integer_binop_Prim op }+          rule_binop_Ordering str name op+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,+                           ru_try = match_Integer_binop_Ordering op }+          rule_encodeFloat str name op+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,+                           ru_try = match_Integer_Int_encodeFloat op }+          rule_decodeDouble str name+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,+                           ru_try = match_decodeDouble }+          rule_XToIntegerToX str name toIntegerName+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,+                           ru_try = match_XToIntegerToX toIntegerName }+          rule_smallIntegerTo str name primOp+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,+                           ru_try = match_smallIntegerTo primOp }+          rule_rationalTo str name mkLit+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,+                           ru_try = match_rationalTo mkLit }++---------------------------------------------------+-- The rule is this:+--      unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)+--      =  unpackFoldrCString# "foobaz" c n++match_append_lit :: RuleFun+match_append_lit _ id_unf _+        [ Type ty1+        , lit1+        , c1+        , Var unpk `App` Type ty2+                   `App` lit2+                   `App` c2+                   `App` n+        ]+  | unpk `hasKey` unpackCStringFoldrIdKey &&+    c1 `cheapEqExpr` c2+  , Just (MachStr s1) <- exprIsLiteral_maybe id_unf lit1+  , Just (MachStr s2) <- exprIsLiteral_maybe id_unf lit2+  = ASSERT( ty1 `eqType` ty2 )+    Just (Var unpk `App` Type ty1+                   `App` Lit (MachStr (s1 `BS.append` s2))+                   `App` c1+                   `App` n)++match_append_lit _ _ _ _ = Nothing++---------------------------------------------------+-- The rule is this:+--      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2++match_eq_string :: RuleFun+match_eq_string _ id_unf _+        [Var unpk1 `App` lit1, Var unpk2 `App` lit2]+  | unpk1 `hasKey` unpackCStringIdKey+  , unpk2 `hasKey` unpackCStringIdKey+  , Just (MachStr s1) <- exprIsLiteral_maybe id_unf lit1+  , Just (MachStr s2) <- exprIsLiteral_maybe id_unf lit2+  = Just (if s1 == s2 then trueValBool else falseValBool)++match_eq_string _ _ _ _ = Nothing+++---------------------------------------------------+-- The rule is this:+--      inline f_ty (f a b c) = <f's unfolding> a b c+-- (if f has an unfolding, EVEN if it's a loop breaker)+--+-- It's important to allow the argument to 'inline' to have args itself+-- (a) because its more forgiving to allow the programmer to write+--       inline f a b c+--   or  inline (f a b c)+-- (b) because a polymorphic f wll get a type argument that the+--     programmer can't avoid+--+-- Also, don't forget about 'inline's type argument!+match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)+match_inline (Type _ : e : _)+  | (Var f, args1) <- collectArgs e,+    Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)+             -- Ignore the IdUnfoldingFun here!+  = Just (mkApps unf args1)++match_inline _ = Nothing+++-- See Note [magicDictId magic] in `basicTypes/MkId.hs`+-- for a description of what is going on here.+match_magicDict :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)+match_magicDict [Type _, Var wrap `App` Type a `App` Type _ `App` f, x, y ]+  | Just (fieldTy, _)   <- splitFunTy_maybe $ dropForAlls $ idType wrap+  , Just (dictTy, _)    <- splitFunTy_maybe fieldTy+  , Just dictTc         <- tyConAppTyCon_maybe dictTy+  , Just (_,_,co)       <- unwrapNewTyCon_maybe dictTc+  = Just+  $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a] []))+      `App` y++match_magicDict _ = Nothing++-------------------------------------------------+-- Integer rules+--   smallInteger  (79::Int#)  = 79::Integer+--   wordToInteger (79::Word#) = 79::Integer+-- Similarly Int64, Word64++match_IntToInteger :: RuleFun+match_IntToInteger = match_IntToInteger_unop id++match_WordToInteger :: RuleFun+match_WordToInteger _ id_unf id [xl]+  | Just (MachWord x) <- exprIsLiteral_maybe id_unf xl+  = case splitFunTy_maybe (idType id) of+    Just (_, integerTy) ->+        Just (Lit (LitInteger x integerTy))+    _ ->+        panic "match_WordToInteger: Id has the wrong type"+match_WordToInteger _ _ _ _ = Nothing++match_Int64ToInteger :: RuleFun+match_Int64ToInteger _ id_unf id [xl]+  | Just (MachInt64 x) <- exprIsLiteral_maybe id_unf xl+  = case splitFunTy_maybe (idType id) of+    Just (_, integerTy) ->+        Just (Lit (LitInteger x integerTy))+    _ ->+        panic "match_Int64ToInteger: Id has the wrong type"+match_Int64ToInteger _ _ _ _ = Nothing++match_Word64ToInteger :: RuleFun+match_Word64ToInteger _ id_unf id [xl]+  | Just (MachWord64 x) <- exprIsLiteral_maybe id_unf xl+  = case splitFunTy_maybe (idType id) of+    Just (_, integerTy) ->+        Just (Lit (LitInteger x integerTy))+    _ ->+        panic "match_Word64ToInteger: Id has the wrong type"+match_Word64ToInteger _ _ _ _ = Nothing++-------------------------------------------------+match_Integer_convert :: Num a+                      => (DynFlags -> a -> Expr CoreBndr)+                      -> RuleFun+match_Integer_convert convert dflags id_unf _ [xl]+  | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl+  = Just (convert dflags (fromInteger x))+match_Integer_convert _ _ _ _ _ = Nothing++match_Integer_unop :: (Integer -> Integer) -> RuleFun+match_Integer_unop unop _ id_unf _ [xl]+  | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl+  = Just (Lit (LitInteger (unop x) i))+match_Integer_unop _ _ _ _ _ = Nothing++{- Note [Rewriting bitInteger]++For most types the bitInteger operation can be implemented in terms of shifts.+The integer-gmp package, however, can do substantially better than this if+allowed to provide its own implementation. However, in so doing it previously lost+constant-folding (see Trac #8832). The bitInteger rule above provides constant folding+specifically for this function.++There is, however, a bit of trickiness here when it comes to ranges. While the+AST encodes all integers (even MachInts) as Integers, `bit` expects the bit+index to be given as an Int. Hence we coerce to an Int in the rule definition.+This will behave a bit funny for constants larger than the word size, but the user+should expect some funniness given that they will have at very least ignored a+warning in this case.+-}++match_IntToInteger_unop :: (Integer -> Integer) -> RuleFun+match_IntToInteger_unop unop _ id_unf fn [xl]+  | Just (MachInt x) <- exprIsLiteral_maybe id_unf xl+  = case splitFunTy_maybe (idType fn) of+    Just (_, integerTy) ->+        Just (Lit (LitInteger (unop x) integerTy))+    _ ->+        panic "match_IntToInteger_unop: Id has the wrong type"+match_IntToInteger_unop _ _ _ _ _ = Nothing++match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun+match_Integer_binop binop _ id_unf _ [xl,yl]+  | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl+  , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl+  = Just (Lit (LitInteger (x `binop` y) i))+match_Integer_binop _ _ _ _ _ = Nothing++-- This helper is used for the quotRem and divMod functions+match_Integer_divop_both+   :: (Integer -> Integer -> (Integer, Integer)) -> RuleFun+match_Integer_divop_both divop _ id_unf _ [xl,yl]+  | Just (LitInteger x t) <- exprIsLiteral_maybe id_unf xl+  , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl+  , y /= 0+  , (r,s) <- x `divop` y+  = Just $ mkCoreUbxTup [t,t] [Lit (LitInteger r t), Lit (LitInteger s t)]+match_Integer_divop_both _ _ _ _ _ = Nothing++-- This helper is used for the quot and rem functions+match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun+match_Integer_divop_one divop _ id_unf _ [xl,yl]+  | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl+  , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl+  , y /= 0+  = Just (Lit (LitInteger (x `divop` y) i))+match_Integer_divop_one _ _ _ _ _ = Nothing++match_Integer_Int_binop :: (Integer -> Int -> Integer) -> RuleFun+match_Integer_Int_binop binop _ id_unf _ [xl,yl]+  | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl+  , Just (MachInt y)      <- exprIsLiteral_maybe id_unf yl+  = Just (Lit (LitInteger (x `binop` fromIntegral y) i))+match_Integer_Int_binop _ _ _ _ _ = Nothing++match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun+match_Integer_binop_Prim binop dflags id_unf _ [xl, yl]+  | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl+  , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl+  = Just (if x `binop` y then trueValInt dflags else falseValInt dflags)+match_Integer_binop_Prim _ _ _ _ _ = Nothing++match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun+match_Integer_binop_Ordering binop _ id_unf _ [xl, yl]+  | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl+  , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl+  = Just $ case x `binop` y of+             LT -> ltVal+             EQ -> eqVal+             GT -> gtVal+match_Integer_binop_Ordering _ _ _ _ _ = Nothing++match_Integer_Int_encodeFloat :: RealFloat a+                              => (a -> Expr CoreBndr)+                              -> RuleFun+match_Integer_Int_encodeFloat mkLit _ id_unf _ [xl,yl]+  | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl+  , Just (MachInt y)      <- exprIsLiteral_maybe id_unf yl+  = Just (mkLit $ encodeFloat x (fromInteger y))+match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing++---------------------------------------------------+-- constant folding for Float/Double+--+-- This turns+--      rationalToFloat n d+-- into a literal Float, and similarly for Doubles.+--+-- it's important to not match d == 0, because that may represent a+-- literal "0/0" or similar, and we can't produce a literal value for+-- NaN or +-Inf+match_rationalTo :: RealFloat a+                 => (a -> Expr CoreBndr)+                 -> RuleFun+match_rationalTo mkLit _ id_unf _ [xl, yl]+  | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl+  , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl+  , y /= 0+  = Just (mkLit (fromRational (x % y)))+match_rationalTo _ _ _ _ _ = Nothing++match_decodeDouble :: RuleFun+match_decodeDouble _ id_unf fn [xl]+  | Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl+  = case splitFunTy_maybe (idType fn) of+    Just (_, res)+      | Just [_lev1, _lev2, integerTy, intHashTy] <- tyConAppArgs_maybe res+      -> case decodeFloat (fromRational x :: Double) of+           (y, z) ->+             Just $ mkCoreUbxTup [integerTy, intHashTy]+                                 [Lit (LitInteger y integerTy),+                                  Lit (MachInt (toInteger z))]+    _ ->+        pprPanic "match_decodeDouble: Id has the wrong type"+          (ppr fn <+> dcolon <+> ppr (idType fn))+match_decodeDouble _ _ _ _ = Nothing++match_XToIntegerToX :: Name -> RuleFun+match_XToIntegerToX n _ _ _ [App (Var x) y]+  | idName x == n+  = Just y+match_XToIntegerToX _ _ _ _ _ = Nothing++match_smallIntegerTo :: PrimOp -> RuleFun+match_smallIntegerTo primOp _ _ _ [App (Var x) y]+  | idName x == smallIntegerName+  = Just $ App (Var (mkPrimOpId primOp)) y+match_smallIntegerTo _ _ _ _ _ = Nothing++++--------------------------------------------------------+-- Constant folding through case-expressions+--+-- cf Scrutinee Constant Folding in simplCore/SimplUtils+--------------------------------------------------------++-- | Match the scrutinee of a case and potentially return a new scrutinee and a+-- function to apply to each literal alternative.+caseRules :: DynFlags -> CoreExpr -> Maybe (CoreExpr, Integer -> Integer)+caseRules dflags scrut = case scrut of++   -- We need to call wordResult' and intResult' to ensure that the literal+   -- alternatives remain in Word/Int target ranges (cf Note [Word/Int+   -- underflow/overflow] and #13172).++   -- v `op` x#+   App (App (Var f) v) (Lit l)+      | Just op <- isPrimOpId_maybe f+      , Just x  <- isLitValue_maybe l ->+      case op of+         WordAddOp -> Just (v, \y -> wordResult' dflags $ y-x      )+         IntAddOp  -> Just (v, \y -> intResult'  dflags $ y-x      )+         WordSubOp -> Just (v, \y -> wordResult' dflags $ y+x      )+         IntSubOp  -> Just (v, \y -> intResult'  dflags $ y+x      )+         XorOp     -> Just (v, \y -> wordResult' dflags $ y `xor` x)+         XorIOp    -> Just (v, \y -> intResult'  dflags $ y `xor` x)+         _         -> Nothing++   -- x# `op` v+   App (App (Var f) (Lit l)) v+      | Just op <- isPrimOpId_maybe f+      , Just x  <- isLitValue_maybe l ->+      case op of+         WordAddOp -> Just (v, \y -> wordResult' dflags $ y-x      )+         IntAddOp  -> Just (v, \y -> intResult'  dflags $ y-x      )+         WordSubOp -> Just (v, \y -> wordResult' dflags $ x-y      )+         IntSubOp  -> Just (v, \y -> intResult'  dflags $ x-y      )+         XorOp     -> Just (v, \y -> wordResult' dflags $ y `xor` x)+         XorIOp    -> Just (v, \y -> intResult'  dflags $ y `xor` x)+         _         -> Nothing++   -- op v+   App (Var f) v+      | Just op <- isPrimOpId_maybe f ->+      case op of+         NotOp     -> Just (v, \y -> wordResult' dflags $ complement y)+         NotIOp    -> Just (v, \y -> intResult'  dflags $ complement y)+         IntNegOp  -> Just (v, \y -> intResult'  dflags $ negate y    )+         _         -> Nothing++   _ -> Nothing
+ prelude/PrimOp.hs view
@@ -0,0 +1,629 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[PrimOp]{Primitive operations (machine-level)}+-}++{-# LANGUAGE CPP #-}++-- The default is a bit too low for the quite large primOpInfo definition+#if __GLASGOW_HASKELL__ >= 801+{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}+#endif++module PrimOp (+        PrimOp(..), PrimOpVecCat(..), allThePrimOps,+        primOpType, primOpSig,+        primOpTag, maxPrimOpTag, primOpOcc,++        tagToEnumKey,++        primOpOutOfLine, primOpCodeSize,+        primOpOkForSpeculation, primOpOkForSideEffects,+        primOpIsCheap, primOpFixity,++        getPrimOpResultInfo,  PrimOpResultInfo(..),++        PrimCall(..)+    ) where++#include "HsVersions.h"++import TysPrim+import TysWiredIn++import CmmType+import Demand+import OccName          ( OccName, pprOccName, mkVarOccFS )+import TyCon            ( TyCon, isPrimTyCon, PrimRep(..) )+import Type+import RepType          ( typePrimRep1, tyConPrimRep1 )+import BasicTypes       ( Arity, Fixity(..), FixityDirection(..), Boxity(..),+                          SourceText(..) )+import ForeignCall      ( CLabelString )+import Unique           ( Unique, mkPrimOpIdUnique )+import Outputable+import FastString+import Module           ( UnitId )++{-+************************************************************************+*                                                                      *+\subsection[PrimOp-datatype]{Datatype for @PrimOp@ (an enumeration)}+*                                                                      *+************************************************************************++These are in \tr{state-interface.verb} order.+-}++-- supplies:+-- data PrimOp = ...+#include "primop-data-decl.hs-incl"++-- supplies+-- primOpTag :: PrimOp -> Int+#include "primop-tag.hs-incl"+primOpTag _ = error "primOpTag: unknown primop"+++instance Eq PrimOp where+    op1 == op2 = primOpTag op1 == primOpTag op2++instance Ord PrimOp where+    op1 <  op2 =  primOpTag op1 < primOpTag op2+    op1 <= op2 =  primOpTag op1 <= primOpTag op2+    op1 >= op2 =  primOpTag op1 >= primOpTag op2+    op1 >  op2 =  primOpTag op1 > primOpTag op2+    op1 `compare` op2 | op1 < op2  = LT+                      | op1 == op2 = EQ+                      | otherwise  = GT++instance Outputable PrimOp where+    ppr op = pprPrimOp op++data PrimOpVecCat = IntVec+                  | WordVec+                  | FloatVec++-- An @Enum@-derived list would be better; meanwhile... (ToDo)++allThePrimOps :: [PrimOp]+allThePrimOps =+#include "primop-list.hs-incl"++tagToEnumKey :: Unique+tagToEnumKey = mkPrimOpIdUnique (primOpTag TagToEnumOp)++{-+************************************************************************+*                                                                      *+\subsection[PrimOp-info]{The essential info about each @PrimOp@}+*                                                                      *+************************************************************************++The @String@ in the @PrimOpInfos@ is the ``base name'' by which the user may+refer to the primitive operation.  The conventional \tr{#}-for-+unboxed ops is added on later.++The reason for the funny characters in the names is so we do not+interfere with the programmer's Haskell name spaces.++We use @PrimKinds@ for the ``type'' information, because they're+(slightly) more convenient to use than @TyCons@.+-}++data PrimOpInfo+  = Dyadic      OccName         -- string :: T -> T -> T+                Type+  | Monadic     OccName         -- string :: T -> T+                Type+  | Compare     OccName         -- string :: T -> T -> Int#+                Type+  | GenPrimOp   OccName         -- string :: \/a1..an . T1 -> .. -> Tk -> T+                [TyVar]+                [Type]+                Type++mkDyadic, mkMonadic, mkCompare :: FastString -> Type -> PrimOpInfo+mkDyadic str  ty = Dyadic  (mkVarOccFS str) ty+mkMonadic str ty = Monadic (mkVarOccFS str) ty+mkCompare str ty = Compare (mkVarOccFS str) ty++mkGenPrimOp :: FastString -> [TyVar] -> [Type] -> Type -> PrimOpInfo+mkGenPrimOp str tvs tys ty = GenPrimOp (mkVarOccFS str) tvs tys ty++{-+************************************************************************+*                                                                      *+\subsubsection{Strictness}+*                                                                      *+************************************************************************++Not all primops are strict!+-}++primOpStrictness :: PrimOp -> Arity -> StrictSig+        -- See Demand.StrictnessInfo for discussion of what the results+        -- The arity should be the arity of the primop; that's why+        -- this function isn't exported.+#include "primop-strictness.hs-incl"++{-+************************************************************************+*                                                                      *+\subsubsection{Fixity}+*                                                                      *+************************************************************************+-}++primOpFixity :: PrimOp -> Maybe Fixity+#include "primop-fixity.hs-incl"++{-+************************************************************************+*                                                                      *+\subsubsection[PrimOp-comparison]{PrimOpInfo basic comparison ops}+*                                                                      *+************************************************************************++@primOpInfo@ gives all essential information (from which everything+else, notably a type, can be constructed) for each @PrimOp@.+-}++primOpInfo :: PrimOp -> PrimOpInfo+#include "primop-primop-info.hs-incl"+primOpInfo _ = error "primOpInfo: unknown primop"++{-+Here are a load of comments from the old primOp info:++A @Word#@ is an unsigned @Int#@.++@decodeFloat#@ is given w/ Integer-stuff (it's similar).++@decodeDouble#@ is given w/ Integer-stuff (it's similar).++Decoding of floating-point numbers is sorta Integer-related.  Encoding+is done with plain ccalls now (see PrelNumExtra.hs).++A @Weak@ Pointer is created by the @mkWeak#@ primitive:++        mkWeak# :: k -> v -> f -> State# RealWorld+                        -> (# State# RealWorld, Weak# v #)++In practice, you'll use the higher-level++        data Weak v = Weak# v+        mkWeak :: k -> v -> IO () -> IO (Weak v)++The following operation dereferences a weak pointer.  The weak pointer+may have been finalized, so the operation returns a result code which+must be inspected before looking at the dereferenced value.++        deRefWeak# :: Weak# v -> State# RealWorld ->+                        (# State# RealWorld, v, Int# #)++Only look at v if the Int# returned is /= 0 !!++The higher-level op is++        deRefWeak :: Weak v -> IO (Maybe v)++Weak pointers can be finalized early by using the finalize# operation:++        finalizeWeak# :: Weak# v -> State# RealWorld ->+                           (# State# RealWorld, Int#, IO () #)++The Int# returned is either++        0 if the weak pointer has already been finalized, or it has no+          finalizer (the third component is then invalid).++        1 if the weak pointer is still alive, with the finalizer returned+          as the third component.++A {\em stable name/pointer} is an index into a table of stable name+entries.  Since the garbage collector is told about stable pointers,+it is safe to pass a stable pointer to external systems such as C+routines.++\begin{verbatim}+makeStablePtr#  :: a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #)+freeStablePtr   :: StablePtr# a -> State# RealWorld -> State# RealWorld+deRefStablePtr# :: StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #)+eqStablePtr#    :: StablePtr# a -> StablePtr# a -> Int#+\end{verbatim}++It may seem a bit surprising that @makeStablePtr#@ is a @IO@+operation since it doesn't (directly) involve IO operations.  The+reason is that if some optimisation pass decided to duplicate calls to+@makeStablePtr#@ and we only pass one of the stable pointers over, a+massive space leak can result.  Putting it into the IO monad+prevents this.  (Another reason for putting them in a monad is to+ensure correct sequencing wrt the side-effecting @freeStablePtr@+operation.)++An important property of stable pointers is that if you call+makeStablePtr# twice on the same object you get the same stable+pointer back.++Note that we can implement @freeStablePtr#@ using @_ccall_@ (and,+besides, it's not likely to be used from Haskell) so it's not a+primop.++Question: Why @RealWorld@ - won't any instance of @_ST@ do the job? [ADR]++Stable Names+~~~~~~~~~~~~++A stable name is like a stable pointer, but with three important differences:++        (a) You can't deRef one to get back to the original object.+        (b) You can convert one to an Int.+        (c) You don't need to 'freeStableName'++The existence of a stable name doesn't guarantee to keep the object it+points to alive (unlike a stable pointer), hence (a).++Invariants:++        (a) makeStableName always returns the same value for a given+            object (same as stable pointers).++        (b) if two stable names are equal, it implies that the objects+            from which they were created were the same.++        (c) stableNameToInt always returns the same Int for a given+            stable name.+++These primops are pretty weird.++        dataToTag# :: a -> Int    (arg must be an evaluated data type)+        tagToEnum# :: Int -> a    (result type must be an enumerated type)++The constraints aren't currently checked by the front end, but the+code generator will fall over if they aren't satisfied.++************************************************************************+*                                                                      *+            Which PrimOps are out-of-line+*                                                                      *+************************************************************************++Some PrimOps need to be called out-of-line because they either need to+perform a heap check or they block.+-}++primOpOutOfLine :: PrimOp -> Bool+#include "primop-out-of-line.hs-incl"++{-+************************************************************************+*                                                                      *+            Failure and side effects+*                                                                      *+************************************************************************++Note [PrimOp can_fail and has_side_effects]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Both can_fail and has_side_effects mean that the primop has+some effect that is not captured entirely by its result value.++----------  has_side_effects ---------------------+A primop "has_side_effects" if it has some *write* effect, visible+elsewhere+    - writing to the world (I/O)+    - writing to a mutable data structure (writeIORef)+    - throwing a synchronous Haskell exception++Often such primops have a type like+   State -> input -> (State, output)+so the state token guarantees ordering.  In general we rely *only* on+data dependencies of the state token to enforce write-effect ordering++ * NB1: if you inline unsafePerformIO, you may end up with+   side-effecting ops whose 'state' output is discarded.+   And programmers may do that by hand; see Trac #9390.+   That is why we (conservatively) do not discard write-effecting+   primops even if both their state and result is discarded.++ * NB2: We consider primops, such as raiseIO#, that can raise a+   (Haskell) synchronous exception to "have_side_effects" but not+   "can_fail".  We must be careful about not discarding such things;+   see the paper "A semantics for imprecise exceptions".++ * NB3: *Read* effects (like reading an IORef) don't count here,+   because it doesn't matter if we don't do them, or do them more than+   once.  *Sequencing* is maintained by the data dependency of the state+   token.++----------  can_fail ----------------------------+A primop "can_fail" if it can fail with an *unchecked* exception on+some elements of its input domain. Main examples:+   division (fails on zero demoninator)+   array indexing (fails if the index is out of bounds)++An "unchecked exception" is one that is an outright error, (not+turned into a Haskell exception,) such as seg-fault or+divide-by-zero error.  Such can_fail primops are ALWAYS surrounded+with a test that checks for the bad cases, but we need to be+very careful about code motion that might move it out of+the scope of the test.++Note [Transformations affected by can_fail and has_side_effects]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The can_fail and has_side_effects properties have the following effect+on program transformations.  Summary table is followed by details.++            can_fail     has_side_effects+Discard        YES           NO+Float in       YES           YES+Float out      NO            NO+Duplicate      YES           NO++* Discarding.   case (a `op` b) of _ -> rhs  ===>   rhs+  You should not discard a has_side_effects primop; e.g.+     case (writeIntArray# a i v s of (# _, _ #) -> True+  Arguably you should be able to discard this, since the+  returned stat token is not used, but that relies on NEVER+  inlining unsafePerformIO, and programmers sometimes write+  this kind of stuff by hand (Trac #9390).  So we (conservatively)+  never discard a has_side_effects primop.++  However, it's fine to discard a can_fail primop.  For example+     case (indexIntArray# a i) of _ -> True+  We can discard indexIntArray#; it has can_fail, but not+  has_side_effects; see Trac #5658 which was all about this.+  Notice that indexIntArray# is (in a more general handling of+  effects) read effect, but we don't care about that here, and+  treat read effects as *not* has_side_effects.++  Similarly (a `/#` b) can be discarded.  It can seg-fault or+  cause a hardware exception, but not a synchronous Haskell+  exception.++++  Synchronous Haskell exceptions, e.g. from raiseIO#, are treated+  as has_side_effects and hence are not discarded.++* Float in.  You can float a can_fail or has_side_effects primop+  *inwards*, but not inside a lambda (see Duplication below).++* Float out.  You must not float a can_fail primop *outwards* lest+  you escape the dynamic scope of the test.  Example:+      case d ># 0# of+        True  -> case x /# d of r -> r +# 1+        False -> 0+  Here we must not float the case outwards to give+      case x/# d of r ->+      case d ># 0# of+        True  -> r +# 1+        False -> 0++  Nor can you float out a has_side_effects primop.  For example:+       if blah then case writeMutVar# v True s0 of (# s1 #) -> s1+               else s0+  Notice that s0 is mentioned in both branches of the 'if', but+  only one of these two will actually be consumed.  But if we+  float out to+      case writeMutVar# v True s0 of (# s1 #) ->+      if blah then s1 else s0+  the writeMutVar will be performed in both branches, which is+  utterly wrong.++* Duplication.  You cannot duplicate a has_side_effect primop.  You+  might wonder how this can occur given the state token threading, but+  just look at Control.Monad.ST.Lazy.Imp.strictToLazy!  We get+  something like this+        p = case readMutVar# s v of+              (# s', r #) -> (S# s', r)+        s' = case p of (s', r) -> s'+        r  = case p of (s', r) -> r++  (All these bindings are boxed.)  If we inline p at its two call+  sites, we get a catastrophe: because the read is performed once when+  s' is demanded, and once when 'r' is demanded, which may be much+  later.  Utterly wrong.  Trac #3207 is real example of this happening.++  However, it's fine to duplicate a can_fail primop.  That is really+  the only difference between can_fail and has_side_effects.++Note [Implementation: how can_fail/has_side_effects affect transformations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+How do we ensure that that floating/duplication/discarding are done right+in the simplifier?++Two main predicates on primpops test these flags:+  primOpOkForSideEffects <=> not has_side_effects+  primOpOkForSpeculation <=> not (has_side_effects || can_fail)++  * The "no-float-out" thing is achieved by ensuring that we never+    let-bind a can_fail or has_side_effects primop.  The RHS of a+    let-binding (which can float in and out freely) satisfies+    exprOkForSpeculation; this is the let/app invariant.  And+    exprOkForSpeculation is false of can_fail and has_side_effects.++  * So can_fail and has_side_effects primops will appear only as the+    scrutinees of cases, and that's why the FloatIn pass is capable+    of floating case bindings inwards.++  * The no-duplicate thing is done via primOpIsCheap, by making+    has_side_effects things (very very very) not-cheap!+-}++primOpHasSideEffects :: PrimOp -> Bool+#include "primop-has-side-effects.hs-incl"++primOpCanFail :: PrimOp -> Bool+#include "primop-can-fail.hs-incl"++primOpOkForSpeculation :: PrimOp -> Bool+  -- See Note [PrimOp can_fail and has_side_effects]+  -- See comments with CoreUtils.exprOkForSpeculation+  -- primOpOkForSpeculation => primOpOkForSideEffects+primOpOkForSpeculation op+  =  primOpOkForSideEffects op+  && not (primOpOutOfLine op || primOpCanFail op)+    -- I think the "out of line" test is because out of line things can+    -- be expensive (eg sine, cosine), and so we may not want to speculate them++primOpOkForSideEffects :: PrimOp -> Bool+primOpOkForSideEffects op+  = not (primOpHasSideEffects op)++{-+Note [primOpIsCheap]+~~~~~~~~~~~~~~~~~~~~+@primOpIsCheap@, as used in \tr{SimplUtils.hs}.  For now (HACK+WARNING), we just borrow some other predicates for a+what-should-be-good-enough test.  "Cheap" means willing to call it more+than once, and/or push it inside a lambda.  The latter could change the+behaviour of 'seq' for primops that can fail, so we don't treat them as cheap.+-}++primOpIsCheap :: PrimOp -> Bool+-- See Note [PrimOp can_fail and has_side_effects]+primOpIsCheap op = primOpOkForSpeculation op+-- In March 2001, we changed this to+--      primOpIsCheap op = False+-- thereby making *no* primops seem cheap.  But this killed eta+-- expansion on case (x ==# y) of True -> \s -> ...+-- which is bad.  In particular a loop like+--      doLoop n = loop 0+--     where+--         loop i | i == n    = return ()+--                | otherwise = bar i >> loop (i+1)+-- allocated a closure every time round because it doesn't eta expand.+--+-- The problem that originally gave rise to the change was+--      let x = a +# b *# c in x +# x+-- were we don't want to inline x. But primopIsCheap doesn't control+-- that (it's exprIsDupable that does) so the problem doesn't occur+-- even if primOpIsCheap sometimes says 'True'.++{-+************************************************************************+*                                                                      *+               PrimOp code size+*                                                                      *+************************************************************************++primOpCodeSize+~~~~~~~~~~~~~~+Gives an indication of the code size of a primop, for the purposes of+calculating unfolding sizes; see CoreUnfold.sizeExpr.+-}++primOpCodeSize :: PrimOp -> Int+#include "primop-code-size.hs-incl"++primOpCodeSizeDefault :: Int+primOpCodeSizeDefault = 1+  -- CoreUnfold.primOpSize already takes into account primOpOutOfLine+  -- and adds some further costs for the args in that case.++primOpCodeSizeForeignCall :: Int+primOpCodeSizeForeignCall = 4++{-+************************************************************************+*                                                                      *+               PrimOp types+*                                                                      *+************************************************************************+-}++primOpType :: PrimOp -> Type  -- you may want to use primOpSig instead+primOpType op+  = case primOpInfo op of+    Dyadic  _occ ty -> dyadic_fun_ty ty+    Monadic _occ ty -> monadic_fun_ty ty+    Compare _occ ty -> compare_fun_ty ty++    GenPrimOp _occ tyvars arg_tys res_ty ->+        mkSpecForAllTys tyvars (mkFunTys arg_tys res_ty)++primOpOcc :: PrimOp -> OccName+primOpOcc op = case primOpInfo op of+               Dyadic    occ _     -> occ+               Monadic   occ _     -> occ+               Compare   occ _     -> occ+               GenPrimOp occ _ _ _ -> occ++-- primOpSig is like primOpType but gives the result split apart:+-- (type variables, argument types, result type)+-- It also gives arity, strictness info++primOpSig :: PrimOp -> ([TyVar], [Type], Type, Arity, StrictSig)+primOpSig op+  = (tyvars, arg_tys, res_ty, arity, primOpStrictness op arity)+  where+    arity = length arg_tys+    (tyvars, arg_tys, res_ty)+      = case (primOpInfo op) of+        Monadic   _occ ty                    -> ([],     [ty],    ty       )+        Dyadic    _occ ty                    -> ([],     [ty,ty], ty       )+        Compare   _occ ty                    -> ([],     [ty,ty], intPrimTy)+        GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty   )++data PrimOpResultInfo+  = ReturnsPrim     PrimRep+  | ReturnsAlg      TyCon++-- Some PrimOps need not return a manifest primitive or algebraic value+-- (i.e. they might return a polymorphic value).  These PrimOps *must*+-- be out of line, or the code generator won't work.++getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo+getPrimOpResultInfo op+  = case (primOpInfo op) of+      Dyadic  _ ty                        -> ReturnsPrim (typePrimRep1 ty)+      Monadic _ ty                        -> ReturnsPrim (typePrimRep1 ty)+      Compare _ _                         -> ReturnsPrim (tyConPrimRep1 intPrimTyCon)+      GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep1 tc)+                         | otherwise      -> ReturnsAlg tc+                         where+                           tc = tyConAppTyCon ty+                        -- All primops return a tycon-app result+                        -- The tycon can be an unboxed tuple or sum, though,+                        -- which gives rise to a ReturnAlg++{-+We do not currently make use of whether primops are commutable.++We used to try to move constants to the right hand side for strength+reduction.+-}++{-+commutableOp :: PrimOp -> Bool+#include "primop-commutable.hs-incl"+-}++-- Utils:++dyadic_fun_ty, monadic_fun_ty, compare_fun_ty :: Type -> Type+dyadic_fun_ty  ty = mkFunTys [ty, ty] ty+monadic_fun_ty ty = mkFunTy  ty ty+compare_fun_ty ty = mkFunTys [ty, ty] intPrimTy++-- Output stuff:++pprPrimOp  :: PrimOp -> SDoc+pprPrimOp other_op = pprOccName (primOpOcc other_op)++{-+************************************************************************+*                                                                      *+\subsubsection[PrimCall]{User-imported primitive calls}+*                                                                      *+************************************************************************+-}++data PrimCall = PrimCall CLabelString UnitId++instance Outputable PrimCall where+  ppr (PrimCall lbl pkgId)+        = text "__primcall" <+> ppr pkgId <+> ppr lbl
+ prelude/PrimOp.hs-boot view
@@ -0,0 +1,3 @@+module PrimOp where++data PrimOp
+ prelude/THNames.hs view
@@ -0,0 +1,1088 @@+-- %************************************************************************+-- %*                                                                   *+--              The known-key names for Template Haskell+-- %*                                                                   *+-- %************************************************************************++module THNames where++import PrelNames( mk_known_key_name )+import Module( Module, mkModuleNameFS, mkModule, thUnitId )+import Name( Name )+import OccName( tcName, clsName, dataName, varName )+import RdrName( RdrName, nameRdrName )+import Unique+import FastString++-- To add a name, do three things+--+--  1) Allocate a key+--  2) Make a "Name"+--  3) Add the name to templateHaskellNames++templateHaskellNames :: [Name]+-- The names that are implicitly mentioned by ``bracket''+-- Should stay in sync with the import list of DsMeta++templateHaskellNames = [+    returnQName, bindQName, sequenceQName, newNameName, liftName,+    mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,+    mkNameSName,+    liftStringName,+    unTypeName,+    unTypeQName,+    unsafeTExpCoerceName,++    -- Lit+    charLName, stringLName, integerLName, intPrimLName, wordPrimLName,+    floatPrimLName, doublePrimLName, rationalLName, stringPrimLName,+    charPrimLName,+    -- Pat+    litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName,+    conPName, tildePName, bangPName, infixPName,+    asPName, wildPName, recPName, listPName, sigPName, viewPName,+    -- FieldPat+    fieldPatName,+    -- Match+    matchName,+    -- Clause+    clauseName,+    -- Exp+    varEName, conEName, litEName, appEName, appTypeEName, infixEName,+    infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName,+    tupEName, unboxedTupEName, unboxedSumEName,+    condEName, multiIfEName, letEName, caseEName, doEName, compEName,+    fromEName, fromThenEName, fromToEName, fromThenToEName,+    listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName,+    -- FieldExp+    fieldExpName,+    -- Body+    guardedBName, normalBName,+    -- Guard+    normalGEName, patGEName,+    -- Stmt+    bindSName, letSName, noBindSName, parSName,+    -- Dec+    funDName, valDName, dataDName, newtypeDName, tySynDName,+    classDName, instanceWithOverlapDName,+    standaloneDerivWithStrategyDName, sigDName, forImpDName,+    pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,+    pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName,+    dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,+    dataInstDName, newtypeInstDName, tySynInstDName,+    infixLDName, infixRDName, infixNDName,+    roleAnnotDName, patSynDName, patSynSigDName,+    -- Cxt+    cxtName,++    -- SourceUnpackedness+    noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName,+    -- SourceStrictness+    noSourceStrictnessName, sourceLazyName, sourceStrictName,+    -- Con+    normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName,+    -- Bang+    bangName,+    -- BangType+    bangTypeName,+    -- VarBangType+    varBangTypeName,+    -- PatSynDir (for pattern synonyms)+    unidirPatSynName, implBidirPatSynName, explBidirPatSynName,+    -- PatSynArgs (for pattern synonyms)+    prefixPatSynName, infixPatSynName, recordPatSynName,+    -- Type+    forallTName, varTName, conTName, appTName, equalityTName,+    tupleTName, unboxedTupleTName, unboxedSumTName,+    arrowTName, listTName, sigTName, litTName,+    promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName,+    wildCardTName,+    -- TyLit+    numTyLitName, strTyLitName,+    -- TyVarBndr+    plainTVName, kindedTVName,+    -- Role+    nominalRName, representationalRName, phantomRName, inferRName,+    -- Kind+    varKName, conKName, tupleKName, arrowKName, listKName, appKName,+    starKName, constraintKName,+    -- FamilyResultSig+    noSigName, kindSigName, tyVarSigName,+    -- InjectivityAnn+    injectivityAnnName,+    -- Callconv+    cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName,+    -- Safety+    unsafeName,+    safeName,+    interruptibleName,+    -- Inline+    noInlineDataConName, inlineDataConName, inlinableDataConName,+    -- RuleMatch+    conLikeDataConName, funLikeDataConName,+    -- Phases+    allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName,+    -- Overlap+    overlappableDataConName, overlappingDataConName, overlapsDataConName,+    incoherentDataConName,+    -- DerivStrategy+    stockStrategyDataConName, anyclassStrategyDataConName,+    newtypeStrategyDataConName,+    -- TExp+    tExpDataConName,+    -- RuleBndr+    ruleVarName, typedRuleVarName,+    -- FunDep+    funDepName,+    -- FamFlavour+    typeFamName, dataFamName,+    -- TySynEqn+    tySynEqnName,+    -- AnnTarget+    valueAnnotationName, typeAnnotationName, moduleAnnotationName,+    -- DerivClause+    derivClauseName,++    -- The type classes+    liftClassName,++    -- And the tycons+    qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,+    clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,+    stmtQTyConName, decQTyConName, conQTyConName, bangTypeQTyConName,+    varBangTypeQTyConName, typeQTyConName, expTyConName, decTyConName,+    typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,+    patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,+    predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName,+    roleTyConName, tExpTyConName, injAnnTyConName, kindTyConName,+    overlapTyConName, derivClauseQTyConName, derivStrategyTyConName,++    -- Quasiquoting+    quoteDecName, quoteTypeName, quoteExpName, quotePatName]++thSyn, thLib, qqLib :: Module+thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")+thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib")+qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")++mkTHModule :: FastString -> Module+mkTHModule m = mkModule thUnitId (mkModuleNameFS m)++libFun, libTc, thFun, thTc, thCls, thCon, qqFun :: FastString -> Unique -> Name+libFun = mk_known_key_name OccName.varName  thLib+libTc  = mk_known_key_name OccName.tcName   thLib+thFun  = mk_known_key_name OccName.varName  thSyn+thTc   = mk_known_key_name OccName.tcName   thSyn+thCls  = mk_known_key_name OccName.clsName  thSyn+thCon  = mk_known_key_name OccName.dataName thSyn+qqFun  = mk_known_key_name OccName.varName  qqLib++-------------------- TH.Syntax -----------------------+liftClassName :: Name+liftClassName = thCls (fsLit "Lift") liftClassKey++qTyConName, nameTyConName, fieldExpTyConName, patTyConName,+    fieldPatTyConName, expTyConName, decTyConName, typeTyConName,+    tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName,+    predTyConName, tExpTyConName, injAnnTyConName, kindTyConName,+    overlapTyConName, derivStrategyTyConName :: Name+qTyConName             = thTc (fsLit "Q")              qTyConKey+nameTyConName          = thTc (fsLit "Name")           nameTyConKey+fieldExpTyConName      = thTc (fsLit "FieldExp")       fieldExpTyConKey+patTyConName           = thTc (fsLit "Pat")            patTyConKey+fieldPatTyConName      = thTc (fsLit "FieldPat")       fieldPatTyConKey+expTyConName           = thTc (fsLit "Exp")            expTyConKey+decTyConName           = thTc (fsLit "Dec")            decTyConKey+typeTyConName          = thTc (fsLit "Type")           typeTyConKey+tyVarBndrTyConName     = thTc (fsLit "TyVarBndr")      tyVarBndrTyConKey+matchTyConName         = thTc (fsLit "Match")          matchTyConKey+clauseTyConName        = thTc (fsLit "Clause")         clauseTyConKey+funDepTyConName        = thTc (fsLit "FunDep")         funDepTyConKey+predTyConName          = thTc (fsLit "Pred")           predTyConKey+tExpTyConName          = thTc (fsLit "TExp")           tExpTyConKey+injAnnTyConName        = thTc (fsLit "InjectivityAnn") injAnnTyConKey+kindTyConName          = thTc (fsLit "Kind")           kindTyConKey+overlapTyConName       = thTc (fsLit "Overlap")        overlapTyConKey+derivStrategyTyConName = thTc (fsLit "DerivStrategy")  derivStrategyTyConKey++returnQName, bindQName, sequenceQName, newNameName, liftName,+    mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,+    mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeQName,+    unsafeTExpCoerceName :: Name+returnQName    = thFun (fsLit "returnQ")   returnQIdKey+bindQName      = thFun (fsLit "bindQ")     bindQIdKey+sequenceQName  = thFun (fsLit "sequenceQ") sequenceQIdKey+newNameName    = thFun (fsLit "newName")   newNameIdKey+liftName       = thFun (fsLit "lift")      liftIdKey+liftStringName = thFun (fsLit "liftString")  liftStringIdKey+mkNameName     = thFun (fsLit "mkName")     mkNameIdKey+mkNameG_vName  = thFun (fsLit "mkNameG_v")  mkNameG_vIdKey+mkNameG_dName  = thFun (fsLit "mkNameG_d")  mkNameG_dIdKey+mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey+mkNameLName    = thFun (fsLit "mkNameL")    mkNameLIdKey+mkNameSName    = thFun (fsLit "mkNameS")    mkNameSIdKey+unTypeName     = thFun (fsLit "unType")     unTypeIdKey+unTypeQName    = thFun (fsLit "unTypeQ")    unTypeQIdKey+unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey+++-------------------- TH.Lib -----------------------+-- data Lit = ...+charLName, stringLName, integerLName, intPrimLName, wordPrimLName,+    floatPrimLName, doublePrimLName, rationalLName, stringPrimLName,+    charPrimLName :: Name+charLName       = libFun (fsLit "charL")       charLIdKey+stringLName     = libFun (fsLit "stringL")     stringLIdKey+integerLName    = libFun (fsLit "integerL")    integerLIdKey+intPrimLName    = libFun (fsLit "intPrimL")    intPrimLIdKey+wordPrimLName   = libFun (fsLit "wordPrimL")   wordPrimLIdKey+floatPrimLName  = libFun (fsLit "floatPrimL")  floatPrimLIdKey+doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey+rationalLName   = libFun (fsLit "rationalL")     rationalLIdKey+stringPrimLName = libFun (fsLit "stringPrimL") stringPrimLIdKey+charPrimLName   = libFun (fsLit "charPrimL")   charPrimLIdKey++-- data Pat = ...+litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, conPName,+    infixPName, tildePName, bangPName, asPName, wildPName, recPName, listPName,+    sigPName, viewPName :: Name+litPName   = libFun (fsLit "litP")   litPIdKey+varPName   = libFun (fsLit "varP")   varPIdKey+tupPName   = libFun (fsLit "tupP")   tupPIdKey+unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey+unboxedSumPName = libFun (fsLit "unboxedSumP") unboxedSumPIdKey+conPName   = libFun (fsLit "conP")   conPIdKey+infixPName = libFun (fsLit "infixP") infixPIdKey+tildePName = libFun (fsLit "tildeP") tildePIdKey+bangPName  = libFun (fsLit "bangP")  bangPIdKey+asPName    = libFun (fsLit "asP")    asPIdKey+wildPName  = libFun (fsLit "wildP")  wildPIdKey+recPName   = libFun (fsLit "recP")   recPIdKey+listPName  = libFun (fsLit "listP")  listPIdKey+sigPName   = libFun (fsLit "sigP")   sigPIdKey+viewPName  = libFun (fsLit "viewP")  viewPIdKey++-- type FieldPat = ...+fieldPatName :: Name+fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey++-- data Match = ...+matchName :: Name+matchName = libFun (fsLit "match") matchIdKey++-- data Clause = ...+clauseName :: Name+clauseName = libFun (fsLit "clause") clauseIdKey++-- data Exp = ...+varEName, conEName, litEName, appEName, appTypeEName, infixEName, infixAppName,+    sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,+    unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName,+    caseEName, doEName, compEName, staticEName, unboundVarEName :: Name+varEName        = libFun (fsLit "varE")        varEIdKey+conEName        = libFun (fsLit "conE")        conEIdKey+litEName        = libFun (fsLit "litE")        litEIdKey+appEName        = libFun (fsLit "appE")        appEIdKey+appTypeEName    = libFun (fsLit "appTypeE")    appTypeEIdKey+infixEName      = libFun (fsLit "infixE")      infixEIdKey+infixAppName    = libFun (fsLit "infixApp")    infixAppIdKey+sectionLName    = libFun (fsLit "sectionL")    sectionLIdKey+sectionRName    = libFun (fsLit "sectionR")    sectionRIdKey+lamEName        = libFun (fsLit "lamE")        lamEIdKey+lamCaseEName    = libFun (fsLit "lamCaseE")    lamCaseEIdKey+tupEName        = libFun (fsLit "tupE")        tupEIdKey+unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey+unboxedSumEName = libFun (fsLit "unboxedSumE") unboxedSumEIdKey+condEName       = libFun (fsLit "condE")       condEIdKey+multiIfEName    = libFun (fsLit "multiIfE")    multiIfEIdKey+letEName        = libFun (fsLit "letE")        letEIdKey+caseEName       = libFun (fsLit "caseE")       caseEIdKey+doEName         = libFun (fsLit "doE")         doEIdKey+compEName       = libFun (fsLit "compE")       compEIdKey+-- ArithSeq skips a level+fromEName, fromThenEName, fromToEName, fromThenToEName :: Name+fromEName       = libFun (fsLit "fromE")       fromEIdKey+fromThenEName   = libFun (fsLit "fromThenE")   fromThenEIdKey+fromToEName     = libFun (fsLit "fromToE")     fromToEIdKey+fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey+-- end ArithSeq+listEName, sigEName, recConEName, recUpdEName :: Name+listEName       = libFun (fsLit "listE")       listEIdKey+sigEName        = libFun (fsLit "sigE")        sigEIdKey+recConEName     = libFun (fsLit "recConE")     recConEIdKey+recUpdEName     = libFun (fsLit "recUpdE")     recUpdEIdKey+staticEName     = libFun (fsLit "staticE")     staticEIdKey+unboundVarEName = libFun (fsLit "unboundVarE") unboundVarEIdKey++-- type FieldExp = ...+fieldExpName :: Name+fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey++-- data Body = ...+guardedBName, normalBName :: Name+guardedBName = libFun (fsLit "guardedB") guardedBIdKey+normalBName  = libFun (fsLit "normalB")  normalBIdKey++-- data Guard = ...+normalGEName, patGEName :: Name+normalGEName = libFun (fsLit "normalGE") normalGEIdKey+patGEName    = libFun (fsLit "patGE")    patGEIdKey++-- data Stmt = ...+bindSName, letSName, noBindSName, parSName :: Name+bindSName   = libFun (fsLit "bindS")   bindSIdKey+letSName    = libFun (fsLit "letS")    letSIdKey+noBindSName = libFun (fsLit "noBindS") noBindSIdKey+parSName    = libFun (fsLit "parS")    parSIdKey++-- data Dec = ...+funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,+    instanceWithOverlapDName, sigDName, forImpDName, pragInlDName,+    pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName,+    pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName,+    dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,+    openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName,+    infixNDName, roleAnnotDName, patSynDName, patSynSigDName,+    pragCompleteDName :: Name+funDName             = libFun (fsLit "funD")              funDIdKey+valDName             = libFun (fsLit "valD")              valDIdKey+dataDName            = libFun (fsLit "dataD")             dataDIdKey+newtypeDName         = libFun (fsLit "newtypeD")          newtypeDIdKey+tySynDName           = libFun (fsLit "tySynD")            tySynDIdKey+classDName           = libFun (fsLit "classD")            classDIdKey+instanceWithOverlapDName+  = libFun (fsLit "instanceWithOverlapD")              instanceWithOverlapDIdKey+standaloneDerivWithStrategyDName = libFun+        (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey+sigDName             = libFun (fsLit "sigD")              sigDIdKey+defaultSigDName      = libFun (fsLit "defaultSigD")       defaultSigDIdKey+forImpDName          = libFun (fsLit "forImpD")           forImpDIdKey+pragInlDName         = libFun (fsLit "pragInlD")          pragInlDIdKey+pragSpecDName        = libFun (fsLit "pragSpecD")         pragSpecDIdKey+pragSpecInlDName     = libFun (fsLit "pragSpecInlD")      pragSpecInlDIdKey+pragSpecInstDName    = libFun (fsLit "pragSpecInstD")     pragSpecInstDIdKey+pragRuleDName        = libFun (fsLit "pragRuleD")         pragRuleDIdKey+pragCompleteDName    = libFun (fsLit "pragCompleteD")     pragCompleteDIdKey+pragAnnDName         = libFun (fsLit "pragAnnD")          pragAnnDIdKey+dataInstDName        = libFun (fsLit "dataInstD")         dataInstDIdKey+newtypeInstDName     = libFun (fsLit "newtypeInstD")      newtypeInstDIdKey+tySynInstDName       = libFun (fsLit "tySynInstD")        tySynInstDIdKey+openTypeFamilyDName  = libFun (fsLit "openTypeFamilyD")   openTypeFamilyDIdKey+closedTypeFamilyDName= libFun (fsLit "closedTypeFamilyD") closedTypeFamilyDIdKey+dataFamilyDName      = libFun (fsLit "dataFamilyD")       dataFamilyDIdKey+infixLDName          = libFun (fsLit "infixLD")           infixLDIdKey+infixRDName          = libFun (fsLit "infixRD")           infixRDIdKey+infixNDName          = libFun (fsLit "infixND")           infixNDIdKey+roleAnnotDName       = libFun (fsLit "roleAnnotD")        roleAnnotDIdKey+patSynDName          = libFun (fsLit "patSynD")           patSynDIdKey+patSynSigDName       = libFun (fsLit "patSynSigD")        patSynSigDIdKey++-- type Ctxt = ...+cxtName :: Name+cxtName = libFun (fsLit "cxt") cxtIdKey++-- data SourceUnpackedness = ...+noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName :: Name+noSourceUnpackednessName = libFun (fsLit "noSourceUnpackedness") noSourceUnpackednessKey+sourceNoUnpackName       = libFun (fsLit "sourceNoUnpack")       sourceNoUnpackKey+sourceUnpackName         = libFun (fsLit "sourceUnpack")         sourceUnpackKey++-- data SourceStrictness = ...+noSourceStrictnessName, sourceLazyName, sourceStrictName :: Name+noSourceStrictnessName = libFun (fsLit "noSourceStrictness") noSourceStrictnessKey+sourceLazyName         = libFun (fsLit "sourceLazy")         sourceLazyKey+sourceStrictName       = libFun (fsLit "sourceStrict")       sourceStrictKey++-- data Con = ...+normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName :: Name+normalCName  = libFun (fsLit "normalC" ) normalCIdKey+recCName     = libFun (fsLit "recC"    ) recCIdKey+infixCName   = libFun (fsLit "infixC"  ) infixCIdKey+forallCName  = libFun (fsLit "forallC" ) forallCIdKey+gadtCName    = libFun (fsLit "gadtC"   ) gadtCIdKey+recGadtCName = libFun (fsLit "recGadtC") recGadtCIdKey++-- data Bang = ...+bangName :: Name+bangName = libFun (fsLit "bang") bangIdKey++-- type BangType = ...+bangTypeName :: Name+bangTypeName = libFun (fsLit "bangType") bangTKey++-- type VarBangType = ...+varBangTypeName :: Name+varBangTypeName = libFun (fsLit "varBangType") varBangTKey++-- data PatSynDir = ...+unidirPatSynName, implBidirPatSynName, explBidirPatSynName :: Name+unidirPatSynName    = libFun (fsLit "unidir")    unidirPatSynIdKey+implBidirPatSynName = libFun (fsLit "implBidir") implBidirPatSynIdKey+explBidirPatSynName = libFun (fsLit "explBidir") explBidirPatSynIdKey++-- data PatSynArgs = ...+prefixPatSynName, infixPatSynName, recordPatSynName :: Name+prefixPatSynName = libFun (fsLit "prefixPatSyn") prefixPatSynIdKey+infixPatSynName  = libFun (fsLit "infixPatSyn")  infixPatSynIdKey+recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey++-- data Type = ...+forallTName, varTName, conTName, tupleTName, unboxedTupleTName,+    unboxedSumTName, arrowTName, listTName, appTName, sigTName, equalityTName,+    litTName, promotedTName, promotedTupleTName, promotedNilTName,+    promotedConsTName, wildCardTName :: Name+forallTName         = libFun (fsLit "forallT")        forallTIdKey+varTName            = libFun (fsLit "varT")           varTIdKey+conTName            = libFun (fsLit "conT")           conTIdKey+tupleTName          = libFun (fsLit "tupleT")         tupleTIdKey+unboxedTupleTName   = libFun (fsLit "unboxedTupleT")  unboxedTupleTIdKey+unboxedSumTName     = libFun (fsLit "unboxedSumT")    unboxedSumTIdKey+arrowTName          = libFun (fsLit "arrowT")         arrowTIdKey+listTName           = libFun (fsLit "listT")          listTIdKey+appTName            = libFun (fsLit "appT")           appTIdKey+sigTName            = libFun (fsLit "sigT")           sigTIdKey+equalityTName       = libFun (fsLit "equalityT")      equalityTIdKey+litTName            = libFun (fsLit "litT")           litTIdKey+promotedTName       = libFun (fsLit "promotedT")      promotedTIdKey+promotedTupleTName  = libFun (fsLit "promotedTupleT") promotedTupleTIdKey+promotedNilTName    = libFun (fsLit "promotedNilT")   promotedNilTIdKey+promotedConsTName   = libFun (fsLit "promotedConsT")  promotedConsTIdKey+wildCardTName       = libFun (fsLit "wildCardT")      wildCardTIdKey++-- data TyLit = ...+numTyLitName, strTyLitName :: Name+numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey+strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey++-- data TyVarBndr = ...+plainTVName, kindedTVName :: Name+plainTVName       = libFun (fsLit "plainTV")       plainTVIdKey+kindedTVName      = libFun (fsLit "kindedTV")      kindedTVIdKey++-- data Role = ...+nominalRName, representationalRName, phantomRName, inferRName :: Name+nominalRName          = libFun (fsLit "nominalR")          nominalRIdKey+representationalRName = libFun (fsLit "representationalR") representationalRIdKey+phantomRName          = libFun (fsLit "phantomR")          phantomRIdKey+inferRName            = libFun (fsLit "inferR")            inferRIdKey++-- data Kind = ...+varKName, conKName, tupleKName, arrowKName, listKName, appKName,+  starKName, constraintKName :: Name+varKName        = libFun (fsLit "varK")         varKIdKey+conKName        = libFun (fsLit "conK")         conKIdKey+tupleKName      = libFun (fsLit "tupleK")       tupleKIdKey+arrowKName      = libFun (fsLit "arrowK")       arrowKIdKey+listKName       = libFun (fsLit "listK")        listKIdKey+appKName        = libFun (fsLit "appK")         appKIdKey+starKName       = libFun (fsLit "starK")        starKIdKey+constraintKName = libFun (fsLit "constraintK")  constraintKIdKey++-- data FamilyResultSig = ...+noSigName, kindSigName, tyVarSigName :: Name+noSigName       = libFun (fsLit "noSig")        noSigIdKey+kindSigName     = libFun (fsLit "kindSig")      kindSigIdKey+tyVarSigName    = libFun (fsLit "tyVarSig")     tyVarSigIdKey++-- data InjectivityAnn = ...+injectivityAnnName :: Name+injectivityAnnName = libFun (fsLit "injectivityAnn") injectivityAnnIdKey++-- data Callconv = ...+cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName :: Name+cCallName = libFun (fsLit "cCall") cCallIdKey+stdCallName = libFun (fsLit "stdCall") stdCallIdKey+cApiCallName = libFun (fsLit "cApi") cApiCallIdKey+primCallName = libFun (fsLit "prim") primCallIdKey+javaScriptCallName = libFun (fsLit "javaScript") javaScriptCallIdKey++-- data Safety = ...+unsafeName, safeName, interruptibleName :: Name+unsafeName     = libFun (fsLit "unsafe") unsafeIdKey+safeName       = libFun (fsLit "safe") safeIdKey+interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey++-- newtype TExp a = ...+tExpDataConName :: Name+tExpDataConName = thCon (fsLit "TExp") tExpDataConKey++-- data RuleBndr = ...+ruleVarName, typedRuleVarName :: Name+ruleVarName      = libFun (fsLit ("ruleVar"))      ruleVarIdKey+typedRuleVarName = libFun (fsLit ("typedRuleVar")) typedRuleVarIdKey++-- data FunDep = ...+funDepName :: Name+funDepName     = libFun (fsLit "funDep") funDepIdKey++-- data FamFlavour = ...+typeFamName, dataFamName :: Name+typeFamName = libFun (fsLit "typeFam") typeFamIdKey+dataFamName = libFun (fsLit "dataFam") dataFamIdKey++-- data TySynEqn = ...+tySynEqnName :: Name+tySynEqnName = libFun (fsLit "tySynEqn") tySynEqnIdKey++-- data AnnTarget = ...+valueAnnotationName, typeAnnotationName, moduleAnnotationName :: Name+valueAnnotationName  = libFun (fsLit "valueAnnotation")  valueAnnotationIdKey+typeAnnotationName   = libFun (fsLit "typeAnnotation")   typeAnnotationIdKey+moduleAnnotationName = libFun (fsLit "moduleAnnotation") moduleAnnotationIdKey++-- type DerivClause = ...+derivClauseName :: Name+derivClauseName = libFun (fsLit "derivClause") derivClauseIdKey++matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,+    decQTyConName, conQTyConName, bangTypeQTyConName,+    varBangTypeQTyConName, typeQTyConName, fieldExpQTyConName,+    patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName,+    ruleBndrQTyConName, tySynEqnQTyConName, roleTyConName,+    derivClauseQTyConName :: Name+matchQTyConName         = libTc (fsLit "MatchQ")         matchQTyConKey+clauseQTyConName        = libTc (fsLit "ClauseQ")        clauseQTyConKey+expQTyConName           = libTc (fsLit "ExpQ")           expQTyConKey+stmtQTyConName          = libTc (fsLit "StmtQ")          stmtQTyConKey+decQTyConName           = libTc (fsLit "DecQ")           decQTyConKey+decsQTyConName          = libTc (fsLit "DecsQ")          decsQTyConKey  -- Q [Dec]+conQTyConName           = libTc (fsLit "ConQ")           conQTyConKey+bangTypeQTyConName      = libTc (fsLit "BangTypeQ")      bangTypeQTyConKey+varBangTypeQTyConName   = libTc (fsLit "VarBangTypeQ")   varBangTypeQTyConKey+typeQTyConName          = libTc (fsLit "TypeQ")          typeQTyConKey+fieldExpQTyConName      = libTc (fsLit "FieldExpQ")      fieldExpQTyConKey+patQTyConName           = libTc (fsLit "PatQ")           patQTyConKey+fieldPatQTyConName      = libTc (fsLit "FieldPatQ")      fieldPatQTyConKey+predQTyConName          = libTc (fsLit "PredQ")          predQTyConKey+ruleBndrQTyConName      = libTc (fsLit "RuleBndrQ")      ruleBndrQTyConKey+tySynEqnQTyConName      = libTc (fsLit "TySynEqnQ")      tySynEqnQTyConKey+roleTyConName           = libTc (fsLit "Role")           roleTyConKey+derivClauseQTyConName   = libTc (fsLit "DerivClauseQ")   derivClauseQTyConKey++-- quasiquoting+quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name+quoteExpName        = qqFun (fsLit "quoteExp")  quoteExpKey+quotePatName        = qqFun (fsLit "quotePat")  quotePatKey+quoteDecName        = qqFun (fsLit "quoteDec")  quoteDecKey+quoteTypeName       = qqFun (fsLit "quoteType") quoteTypeKey++-- data Inline = ...+noInlineDataConName, inlineDataConName, inlinableDataConName :: Name+noInlineDataConName  = thCon (fsLit "NoInline")  noInlineDataConKey+inlineDataConName    = thCon (fsLit "Inline")    inlineDataConKey+inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey++-- data RuleMatch = ...+conLikeDataConName, funLikeDataConName :: Name+conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey+funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey++-- data Phases = ...+allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name+allPhasesDataConName   = thCon (fsLit "AllPhases")   allPhasesDataConKey+fromPhaseDataConName   = thCon (fsLit "FromPhase")   fromPhaseDataConKey+beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey++-- data Overlap = ...+overlappableDataConName,+  overlappingDataConName,+  overlapsDataConName,+  incoherentDataConName :: Name+overlappableDataConName = thCon (fsLit "Overlappable") overlappableDataConKey+overlappingDataConName  = thCon (fsLit "Overlapping")  overlappingDataConKey+overlapsDataConName     = thCon (fsLit "Overlaps")     overlapsDataConKey+incoherentDataConName   = thCon (fsLit "Incoherent")   incoherentDataConKey++-- data DerivStrategy = ...+stockStrategyDataConName, anyclassStrategyDataConName,+  newtypeStrategyDataConName :: Name+stockStrategyDataConName    = thCon (fsLit "StockStrategy")    stockDataConKey+anyclassStrategyDataConName = thCon (fsLit "AnyclassStrategy") anyclassDataConKey+newtypeStrategyDataConName  = thCon (fsLit "NewtypeStrategy")  newtypeDataConKey++{- *********************************************************************+*                                                                      *+                     Class keys+*                                                                      *+********************************************************************* -}++-- ClassUniques available: 200-299+-- Check in PrelNames if you want to change this++liftClassKey :: Unique+liftClassKey = mkPreludeClassUnique 200++{- *********************************************************************+*                                                                      *+                     TyCon keys+*                                                                      *+********************************************************************* -}++-- TyConUniques available: 200-299+-- Check in PrelNames if you want to change this++expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,+    decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,+    stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey,+    decTyConKey, bangTypeQTyConKey, varBangTypeQTyConKey,+    fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,+    fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,+    predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey,+    roleTyConKey, tExpTyConKey, injAnnTyConKey, kindTyConKey,+    overlapTyConKey, derivClauseQTyConKey, derivStrategyTyConKey :: Unique+expTyConKey             = mkPreludeTyConUnique 200+matchTyConKey           = mkPreludeTyConUnique 201+clauseTyConKey          = mkPreludeTyConUnique 202+qTyConKey               = mkPreludeTyConUnique 203+expQTyConKey            = mkPreludeTyConUnique 204+decQTyConKey            = mkPreludeTyConUnique 205+patTyConKey             = mkPreludeTyConUnique 206+matchQTyConKey          = mkPreludeTyConUnique 207+clauseQTyConKey         = mkPreludeTyConUnique 208+stmtQTyConKey           = mkPreludeTyConUnique 209+conQTyConKey            = mkPreludeTyConUnique 210+typeQTyConKey           = mkPreludeTyConUnique 211+typeTyConKey            = mkPreludeTyConUnique 212+decTyConKey             = mkPreludeTyConUnique 213+bangTypeQTyConKey       = mkPreludeTyConUnique 214+varBangTypeQTyConKey    = mkPreludeTyConUnique 215+fieldExpTyConKey        = mkPreludeTyConUnique 216+fieldPatTyConKey        = mkPreludeTyConUnique 217+nameTyConKey            = mkPreludeTyConUnique 218+patQTyConKey            = mkPreludeTyConUnique 219+fieldPatQTyConKey       = mkPreludeTyConUnique 220+fieldExpQTyConKey       = mkPreludeTyConUnique 221+funDepTyConKey          = mkPreludeTyConUnique 222+predTyConKey            = mkPreludeTyConUnique 223+predQTyConKey           = mkPreludeTyConUnique 224+tyVarBndrTyConKey       = mkPreludeTyConUnique 225+decsQTyConKey           = mkPreludeTyConUnique 226+ruleBndrQTyConKey       = mkPreludeTyConUnique 227+tySynEqnQTyConKey       = mkPreludeTyConUnique 228+roleTyConKey            = mkPreludeTyConUnique 229+tExpTyConKey            = mkPreludeTyConUnique 230+injAnnTyConKey          = mkPreludeTyConUnique 231+kindTyConKey            = mkPreludeTyConUnique 232+overlapTyConKey         = mkPreludeTyConUnique 233+derivClauseQTyConKey    = mkPreludeTyConUnique 234+derivStrategyTyConKey   = mkPreludeTyConUnique 235++{- *********************************************************************+*                                                                      *+                     DataCon keys+*                                                                      *+********************************************************************* -}++-- DataConUniques available: 100-150+-- If you want to change this, make sure you check in PrelNames++-- data Inline = ...+noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique+noInlineDataConKey  = mkPreludeDataConUnique 200+inlineDataConKey    = mkPreludeDataConUnique 201+inlinableDataConKey = mkPreludeDataConUnique 202++-- data RuleMatch = ...+conLikeDataConKey, funLikeDataConKey :: Unique+conLikeDataConKey = mkPreludeDataConUnique 203+funLikeDataConKey = mkPreludeDataConUnique 204++-- data Phases = ...+allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique+allPhasesDataConKey   = mkPreludeDataConUnique 205+fromPhaseDataConKey   = mkPreludeDataConUnique 206+beforePhaseDataConKey = mkPreludeDataConUnique 207++-- newtype TExp a = ...+tExpDataConKey :: Unique+tExpDataConKey = mkPreludeDataConUnique 208++-- data Overlap = ..+overlappableDataConKey,+  overlappingDataConKey,+  overlapsDataConKey,+  incoherentDataConKey :: Unique+overlappableDataConKey = mkPreludeDataConUnique 209+overlappingDataConKey  = mkPreludeDataConUnique 210+overlapsDataConKey     = mkPreludeDataConUnique 211+incoherentDataConKey   = mkPreludeDataConUnique 212++-- data DerivStrategy = ...+stockDataConKey, anyclassDataConKey, newtypeDataConKey :: Unique+stockDataConKey    = mkPreludeDataConUnique 213+anyclassDataConKey = mkPreludeDataConUnique 214+newtypeDataConKey  = mkPreludeDataConUnique 215++{- *********************************************************************+*                                                                      *+                     Id keys+*                                                                      *+********************************************************************* -}++-- IdUniques available: 200-499+-- If you want to change this, make sure you check in PrelNames++returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,+    mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,+    mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeQIdKey,+    unsafeTExpCoerceIdKey :: Unique+returnQIdKey        = mkPreludeMiscIdUnique 200+bindQIdKey          = mkPreludeMiscIdUnique 201+sequenceQIdKey      = mkPreludeMiscIdUnique 202+liftIdKey           = mkPreludeMiscIdUnique 203+newNameIdKey         = mkPreludeMiscIdUnique 204+mkNameIdKey          = mkPreludeMiscIdUnique 205+mkNameG_vIdKey       = mkPreludeMiscIdUnique 206+mkNameG_dIdKey       = mkPreludeMiscIdUnique 207+mkNameG_tcIdKey      = mkPreludeMiscIdUnique 208+mkNameLIdKey         = mkPreludeMiscIdUnique 209+mkNameSIdKey         = mkPreludeMiscIdUnique 210+unTypeIdKey          = mkPreludeMiscIdUnique 211+unTypeQIdKey         = mkPreludeMiscIdUnique 212+unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 213+++-- data Lit = ...+charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey,+    floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey, stringPrimLIdKey,+    charPrimLIdKey:: Unique+charLIdKey        = mkPreludeMiscIdUnique 220+stringLIdKey      = mkPreludeMiscIdUnique 221+integerLIdKey     = mkPreludeMiscIdUnique 222+intPrimLIdKey     = mkPreludeMiscIdUnique 223+wordPrimLIdKey    = mkPreludeMiscIdUnique 224+floatPrimLIdKey   = mkPreludeMiscIdUnique 225+doublePrimLIdKey  = mkPreludeMiscIdUnique 226+rationalLIdKey    = mkPreludeMiscIdUnique 227+stringPrimLIdKey  = mkPreludeMiscIdUnique 228+charPrimLIdKey    = mkPreludeMiscIdUnique 229++liftStringIdKey :: Unique+liftStringIdKey     = mkPreludeMiscIdUnique 230++-- data Pat = ...+litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, unboxedSumPIdKey, conPIdKey,+  infixPIdKey, tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey,+  listPIdKey, sigPIdKey, viewPIdKey :: Unique+litPIdKey         = mkPreludeMiscIdUnique 240+varPIdKey         = mkPreludeMiscIdUnique 241+tupPIdKey         = mkPreludeMiscIdUnique 242+unboxedTupPIdKey  = mkPreludeMiscIdUnique 243+unboxedSumPIdKey  = mkPreludeMiscIdUnique 244+conPIdKey         = mkPreludeMiscIdUnique 245+infixPIdKey       = mkPreludeMiscIdUnique 246+tildePIdKey       = mkPreludeMiscIdUnique 247+bangPIdKey        = mkPreludeMiscIdUnique 248+asPIdKey          = mkPreludeMiscIdUnique 249+wildPIdKey        = mkPreludeMiscIdUnique 250+recPIdKey         = mkPreludeMiscIdUnique 251+listPIdKey        = mkPreludeMiscIdUnique 252+sigPIdKey         = mkPreludeMiscIdUnique 253+viewPIdKey        = mkPreludeMiscIdUnique 254++-- type FieldPat = ...+fieldPatIdKey :: Unique+fieldPatIdKey       = mkPreludeMiscIdUnique 260++-- data Match = ...+matchIdKey :: Unique+matchIdKey          = mkPreludeMiscIdUnique 261++-- data Clause = ...+clauseIdKey :: Unique+clauseIdKey         = mkPreludeMiscIdUnique 262+++-- data Exp = ...+varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey,+    infixAppIdKey, sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey,+    tupEIdKey, unboxedTupEIdKey, unboxedSumEIdKey, condEIdKey, multiIfEIdKey,+    letEIdKey, caseEIdKey, doEIdKey, compEIdKey,+    fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,+    listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey,+    unboundVarEIdKey :: Unique+varEIdKey         = mkPreludeMiscIdUnique 270+conEIdKey         = mkPreludeMiscIdUnique 271+litEIdKey         = mkPreludeMiscIdUnique 272+appEIdKey         = mkPreludeMiscIdUnique 273+appTypeEIdKey     = mkPreludeMiscIdUnique 274+infixEIdKey       = mkPreludeMiscIdUnique 275+infixAppIdKey     = mkPreludeMiscIdUnique 276+sectionLIdKey     = mkPreludeMiscIdUnique 277+sectionRIdKey     = mkPreludeMiscIdUnique 278+lamEIdKey         = mkPreludeMiscIdUnique 279+lamCaseEIdKey     = mkPreludeMiscIdUnique 280+tupEIdKey         = mkPreludeMiscIdUnique 281+unboxedTupEIdKey  = mkPreludeMiscIdUnique 282+unboxedSumEIdKey  = mkPreludeMiscIdUnique 283+condEIdKey        = mkPreludeMiscIdUnique 284+multiIfEIdKey     = mkPreludeMiscIdUnique 285+letEIdKey         = mkPreludeMiscIdUnique 286+caseEIdKey        = mkPreludeMiscIdUnique 287+doEIdKey          = mkPreludeMiscIdUnique 288+compEIdKey        = mkPreludeMiscIdUnique 289+fromEIdKey        = mkPreludeMiscIdUnique 290+fromThenEIdKey    = mkPreludeMiscIdUnique 291+fromToEIdKey      = mkPreludeMiscIdUnique 292+fromThenToEIdKey  = mkPreludeMiscIdUnique 293+listEIdKey        = mkPreludeMiscIdUnique 294+sigEIdKey         = mkPreludeMiscIdUnique 295+recConEIdKey      = mkPreludeMiscIdUnique 296+recUpdEIdKey      = mkPreludeMiscIdUnique 297+staticEIdKey      = mkPreludeMiscIdUnique 298+unboundVarEIdKey  = mkPreludeMiscIdUnique 299++-- type FieldExp = ...+fieldExpIdKey :: Unique+fieldExpIdKey       = mkPreludeMiscIdUnique 305++-- data Body = ...+guardedBIdKey, normalBIdKey :: Unique+guardedBIdKey     = mkPreludeMiscIdUnique 306+normalBIdKey      = mkPreludeMiscIdUnique 307++-- data Guard = ...+normalGEIdKey, patGEIdKey :: Unique+normalGEIdKey     = mkPreludeMiscIdUnique 308+patGEIdKey        = mkPreludeMiscIdUnique 309++-- data Stmt = ...+bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique+bindSIdKey       = mkPreludeMiscIdUnique 310+letSIdKey        = mkPreludeMiscIdUnique 311+noBindSIdKey     = mkPreludeMiscIdUnique 312+parSIdKey        = mkPreludeMiscIdUnique 313++-- data Dec = ...+funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,+    instanceWithOverlapDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey,+    pragInlDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey,+    pragRuleDIdKey, pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey,+    openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey,+    newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,+    infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,+    patSynSigDIdKey, pragCompleteDIdKey :: Unique+funDIdKey                         = mkPreludeMiscIdUnique 320+valDIdKey                         = mkPreludeMiscIdUnique 321+dataDIdKey                        = mkPreludeMiscIdUnique 322+newtypeDIdKey                     = mkPreludeMiscIdUnique 323+tySynDIdKey                       = mkPreludeMiscIdUnique 324+classDIdKey                       = mkPreludeMiscIdUnique 325+instanceWithOverlapDIdKey         = mkPreludeMiscIdUnique 326+instanceDIdKey                    = mkPreludeMiscIdUnique 327+sigDIdKey                         = mkPreludeMiscIdUnique 328+forImpDIdKey                      = mkPreludeMiscIdUnique 329+pragInlDIdKey                     = mkPreludeMiscIdUnique 330+pragSpecDIdKey                    = mkPreludeMiscIdUnique 331+pragSpecInlDIdKey                 = mkPreludeMiscIdUnique 332+pragSpecInstDIdKey                = mkPreludeMiscIdUnique 333+pragRuleDIdKey                    = mkPreludeMiscIdUnique 334+pragAnnDIdKey                     = mkPreludeMiscIdUnique 335+dataFamilyDIdKey                  = mkPreludeMiscIdUnique 336+openTypeFamilyDIdKey              = mkPreludeMiscIdUnique 337+dataInstDIdKey                    = mkPreludeMiscIdUnique 338+newtypeInstDIdKey                 = mkPreludeMiscIdUnique 339+tySynInstDIdKey                   = mkPreludeMiscIdUnique 340+closedTypeFamilyDIdKey            = mkPreludeMiscIdUnique 341+infixLDIdKey                      = mkPreludeMiscIdUnique 342+infixRDIdKey                      = mkPreludeMiscIdUnique 343+infixNDIdKey                      = mkPreludeMiscIdUnique 344+roleAnnotDIdKey                   = mkPreludeMiscIdUnique 345+standaloneDerivWithStrategyDIdKey = mkPreludeMiscIdUnique 346+defaultSigDIdKey                  = mkPreludeMiscIdUnique 347+patSynDIdKey                      = mkPreludeMiscIdUnique 348+patSynSigDIdKey                   = mkPreludeMiscIdUnique 349+pragCompleteDIdKey                = mkPreludeMiscIdUnique 350++-- type Cxt = ...+cxtIdKey :: Unique+cxtIdKey               = mkPreludeMiscIdUnique 351++-- data SourceUnpackedness = ...+noSourceUnpackednessKey, sourceNoUnpackKey, sourceUnpackKey :: Unique+noSourceUnpackednessKey = mkPreludeMiscIdUnique 352+sourceNoUnpackKey       = mkPreludeMiscIdUnique 353+sourceUnpackKey         = mkPreludeMiscIdUnique 354++-- data SourceStrictness = ...+noSourceStrictnessKey, sourceLazyKey, sourceStrictKey :: Unique+noSourceStrictnessKey   = mkPreludeMiscIdUnique 355+sourceLazyKey           = mkPreludeMiscIdUnique 356+sourceStrictKey         = mkPreludeMiscIdUnique 357++-- data Con = ...+normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey, gadtCIdKey,+  recGadtCIdKey :: Unique+normalCIdKey      = mkPreludeMiscIdUnique 358+recCIdKey         = mkPreludeMiscIdUnique 359+infixCIdKey       = mkPreludeMiscIdUnique 360+forallCIdKey      = mkPreludeMiscIdUnique 361+gadtCIdKey        = mkPreludeMiscIdUnique 362+recGadtCIdKey     = mkPreludeMiscIdUnique 363++-- data Bang = ...+bangIdKey :: Unique+bangIdKey         = mkPreludeMiscIdUnique 364++-- type BangType = ...+bangTKey :: Unique+bangTKey          = mkPreludeMiscIdUnique 365++-- type VarBangType = ...+varBangTKey :: Unique+varBangTKey       = mkPreludeMiscIdUnique 366++-- data PatSynDir = ...+unidirPatSynIdKey, implBidirPatSynIdKey, explBidirPatSynIdKey :: Unique+unidirPatSynIdKey    = mkPreludeMiscIdUnique 367+implBidirPatSynIdKey = mkPreludeMiscIdUnique 368+explBidirPatSynIdKey = mkPreludeMiscIdUnique 369++-- data PatSynArgs = ...+prefixPatSynIdKey, infixPatSynIdKey, recordPatSynIdKey :: Unique+prefixPatSynIdKey = mkPreludeMiscIdUnique 370+infixPatSynIdKey  = mkPreludeMiscIdUnique 371+recordPatSynIdKey = mkPreludeMiscIdUnique 372++-- data Type = ...+forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey,+    unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey, sigTIdKey,+    equalityTIdKey, litTIdKey, promotedTIdKey, promotedTupleTIdKey,+    promotedNilTIdKey, promotedConsTIdKey, wildCardTIdKey :: Unique+forallTIdKey        = mkPreludeMiscIdUnique 381+varTIdKey           = mkPreludeMiscIdUnique 382+conTIdKey           = mkPreludeMiscIdUnique 383+tupleTIdKey         = mkPreludeMiscIdUnique 384+unboxedTupleTIdKey  = mkPreludeMiscIdUnique 385+unboxedSumTIdKey    = mkPreludeMiscIdUnique 386+arrowTIdKey         = mkPreludeMiscIdUnique 387+listTIdKey          = mkPreludeMiscIdUnique 388+appTIdKey           = mkPreludeMiscIdUnique 389+sigTIdKey           = mkPreludeMiscIdUnique 390+equalityTIdKey      = mkPreludeMiscIdUnique 391+litTIdKey           = mkPreludeMiscIdUnique 392+promotedTIdKey      = mkPreludeMiscIdUnique 393+promotedTupleTIdKey = mkPreludeMiscIdUnique 394+promotedNilTIdKey   = mkPreludeMiscIdUnique 395+promotedConsTIdKey  = mkPreludeMiscIdUnique 396+wildCardTIdKey      = mkPreludeMiscIdUnique 397++-- data TyLit = ...+numTyLitIdKey, strTyLitIdKey :: Unique+numTyLitIdKey = mkPreludeMiscIdUnique 400+strTyLitIdKey = mkPreludeMiscIdUnique 401++-- data TyVarBndr = ...+plainTVIdKey, kindedTVIdKey :: Unique+plainTVIdKey       = mkPreludeMiscIdUnique 402+kindedTVIdKey      = mkPreludeMiscIdUnique 403++-- data Role = ...+nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique+nominalRIdKey          = mkPreludeMiscIdUnique 404+representationalRIdKey = mkPreludeMiscIdUnique 405+phantomRIdKey          = mkPreludeMiscIdUnique 406+inferRIdKey            = mkPreludeMiscIdUnique 407++-- data Kind = ...+varKIdKey, conKIdKey, tupleKIdKey, arrowKIdKey, listKIdKey, appKIdKey,+  starKIdKey, constraintKIdKey :: Unique+varKIdKey         = mkPreludeMiscIdUnique 408+conKIdKey         = mkPreludeMiscIdUnique 409+tupleKIdKey       = mkPreludeMiscIdUnique 410+arrowKIdKey       = mkPreludeMiscIdUnique 411+listKIdKey        = mkPreludeMiscIdUnique 412+appKIdKey         = mkPreludeMiscIdUnique 413+starKIdKey        = mkPreludeMiscIdUnique 414+constraintKIdKey  = mkPreludeMiscIdUnique 415++-- data FamilyResultSig = ...+noSigIdKey, kindSigIdKey, tyVarSigIdKey :: Unique+noSigIdKey        = mkPreludeMiscIdUnique 416+kindSigIdKey      = mkPreludeMiscIdUnique 417+tyVarSigIdKey     = mkPreludeMiscIdUnique 418++-- data InjectivityAnn = ...+injectivityAnnIdKey :: Unique+injectivityAnnIdKey = mkPreludeMiscIdUnique 419++-- data Callconv = ...+cCallIdKey, stdCallIdKey, cApiCallIdKey, primCallIdKey,+  javaScriptCallIdKey :: Unique+cCallIdKey          = mkPreludeMiscIdUnique 420+stdCallIdKey        = mkPreludeMiscIdUnique 421+cApiCallIdKey       = mkPreludeMiscIdUnique 422+primCallIdKey       = mkPreludeMiscIdUnique 423+javaScriptCallIdKey = mkPreludeMiscIdUnique 424++-- data Safety = ...+unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique+unsafeIdKey        = mkPreludeMiscIdUnique 430+safeIdKey          = mkPreludeMiscIdUnique 431+interruptibleIdKey = mkPreludeMiscIdUnique 432++-- data FunDep = ...+funDepIdKey :: Unique+funDepIdKey = mkPreludeMiscIdUnique 440++-- data FamFlavour = ...+typeFamIdKey, dataFamIdKey :: Unique+typeFamIdKey = mkPreludeMiscIdUnique 450+dataFamIdKey = mkPreludeMiscIdUnique 451++-- data TySynEqn = ...+tySynEqnIdKey :: Unique+tySynEqnIdKey = mkPreludeMiscIdUnique 460++-- quasiquoting+quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique+quoteExpKey  = mkPreludeMiscIdUnique 470+quotePatKey  = mkPreludeMiscIdUnique 471+quoteDecKey  = mkPreludeMiscIdUnique 472+quoteTypeKey = mkPreludeMiscIdUnique 473++-- data RuleBndr = ...+ruleVarIdKey, typedRuleVarIdKey :: Unique+ruleVarIdKey      = mkPreludeMiscIdUnique 480+typedRuleVarIdKey = mkPreludeMiscIdUnique 481++-- data AnnTarget = ...+valueAnnotationIdKey, typeAnnotationIdKey, moduleAnnotationIdKey :: Unique+valueAnnotationIdKey  = mkPreludeMiscIdUnique 490+typeAnnotationIdKey   = mkPreludeMiscIdUnique 491+moduleAnnotationIdKey = mkPreludeMiscIdUnique 492++-- type DerivPred = ...+derivClauseIdKey :: Unique+derivClauseIdKey = mkPreludeMiscIdUnique 493++{-+************************************************************************+*                                                                      *+                        RdrNames+*                                                                      *+************************************************************************+-}++lift_RDR, mkNameG_dRDR, mkNameG_vRDR :: RdrName+lift_RDR     = nameRdrName liftName+mkNameG_dRDR = nameRdrName mkNameG_dName+mkNameG_vRDR = nameRdrName mkNameG_vName++-- data Exp = ...+conE_RDR, litE_RDR, appE_RDR, infixApp_RDR :: RdrName+conE_RDR     = nameRdrName conEName+litE_RDR     = nameRdrName litEName+appE_RDR     = nameRdrName appEName+infixApp_RDR = nameRdrName infixAppName++-- data Lit = ...+stringL_RDR, intPrimL_RDR, wordPrimL_RDR, floatPrimL_RDR,+    doublePrimL_RDR, stringPrimL_RDR, charPrimL_RDR :: RdrName+stringL_RDR     = nameRdrName stringLName+intPrimL_RDR    = nameRdrName intPrimLName+wordPrimL_RDR   = nameRdrName wordPrimLName+floatPrimL_RDR  = nameRdrName floatPrimLName+doublePrimL_RDR = nameRdrName doublePrimLName+stringPrimL_RDR = nameRdrName stringPrimLName+charPrimL_RDR   = nameRdrName charPrimLName
+ prelude/TysPrim.hs view
@@ -0,0 +1,1003 @@+{-+(c) The AQUA Project, Glasgow University, 1994-1998+++\section[TysPrim]{Wired-in knowledge about primitive types}+-}++{-# LANGUAGE CPP #-}++-- | This module defines TyCons that can't be expressed in Haskell.+--   They are all, therefore, wired-in TyCons.  C.f module TysWiredIn+module TysPrim(+        mkPrimTyConName, -- For implicit parameters in TysWiredIn only++        mkTemplateKindVars, mkTemplateTyVars, mkTemplateTyVarsFrom,+        mkTemplateKiTyVars,++        mkTemplateTyConBinders, mkTemplateKindTyConBinders,+        mkTemplateAnonTyConBinders,++        alphaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,+        alphaTys, alphaTy, betaTy, gammaTy, deltaTy,+        runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep1Ty, runtimeRep2Ty,+        openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar,++        -- Kind constructors...+        tYPETyCon, tYPETyConName,++        -- Kinds+        tYPE, primRepToRuntimeRep,++        funTyCon, funTyConName,+        primTyCons,++        charPrimTyCon,          charPrimTy, charPrimTyConName,+        intPrimTyCon,           intPrimTy, intPrimTyConName,+        wordPrimTyCon,          wordPrimTy, wordPrimTyConName,+        addrPrimTyCon,          addrPrimTy, addrPrimTyConName,+        floatPrimTyCon,         floatPrimTy, floatPrimTyConName,+        doublePrimTyCon,        doublePrimTy, doublePrimTyConName,++        voidPrimTyCon,          voidPrimTy,+        statePrimTyCon,         mkStatePrimTy,+        realWorldTyCon,         realWorldTy, realWorldStatePrimTy,++        proxyPrimTyCon,         mkProxyPrimTy,++        arrayPrimTyCon, mkArrayPrimTy,+        byteArrayPrimTyCon,     byteArrayPrimTy,+        arrayArrayPrimTyCon, mkArrayArrayPrimTy,+        smallArrayPrimTyCon, mkSmallArrayPrimTy,+        mutableArrayPrimTyCon, mkMutableArrayPrimTy,+        mutableByteArrayPrimTyCon, mkMutableByteArrayPrimTy,+        mutableArrayArrayPrimTyCon, mkMutableArrayArrayPrimTy,+        smallMutableArrayPrimTyCon, mkSmallMutableArrayPrimTy,+        mutVarPrimTyCon, mkMutVarPrimTy,++        mVarPrimTyCon,                  mkMVarPrimTy,+        tVarPrimTyCon,                  mkTVarPrimTy,+        stablePtrPrimTyCon,             mkStablePtrPrimTy,+        stableNamePrimTyCon,            mkStableNamePrimTy,+        compactPrimTyCon,               compactPrimTy,+        bcoPrimTyCon,                   bcoPrimTy,+        weakPrimTyCon,                  mkWeakPrimTy,+        threadIdPrimTyCon,              threadIdPrimTy,++        int32PrimTyCon,         int32PrimTy,+        word32PrimTyCon,        word32PrimTy,++        int64PrimTyCon,         int64PrimTy,+        word64PrimTyCon,        word64PrimTy,++        eqPrimTyCon,            -- ty1 ~# ty2+        eqReprPrimTyCon,        -- ty1 ~R# ty2  (at role Representational)+        eqPhantPrimTyCon,       -- ty1 ~P# ty2  (at role Phantom)++        -- * SIMD+#include "primop-vector-tys-exports.hs-incl"+  ) where++#include "HsVersions.h"++import {-# SOURCE #-} TysWiredIn+  ( runtimeRepTy, unboxedTupleKind, liftedTypeKind+  , vecRepDataConTyCon, tupleRepDataConTyCon+  , liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy+  , wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy+  , floatRepDataConTy, doubleRepDataConTy+  , vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy+  , vec64DataConTy+  , int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy+  , int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy+  , word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy+  , doubleElemRepDataConTy+  , mkPromotedListTy )++import Var              ( TyVar, TyVarBndr(TvBndr), mkTyVar )+import Name+import TyCon+import SrcLoc+import Unique+import PrelNames+import FastString+import Outputable+import TyCoRep   -- Doesn't need special access, but this is easier to avoid+                 -- import loops which show up if you import Type instead++import Data.Char++{-+************************************************************************+*                                                                      *+\subsection{Primitive type constructors}+*                                                                      *+************************************************************************+-}++primTyCons :: [TyCon]+primTyCons+  = [ addrPrimTyCon+    , arrayPrimTyCon+    , byteArrayPrimTyCon+    , arrayArrayPrimTyCon+    , smallArrayPrimTyCon+    , charPrimTyCon+    , doublePrimTyCon+    , floatPrimTyCon+    , intPrimTyCon+    , int32PrimTyCon+    , int64PrimTyCon+    , bcoPrimTyCon+    , weakPrimTyCon+    , mutableArrayPrimTyCon+    , mutableByteArrayPrimTyCon+    , mutableArrayArrayPrimTyCon+    , smallMutableArrayPrimTyCon+    , mVarPrimTyCon+    , tVarPrimTyCon+    , mutVarPrimTyCon+    , realWorldTyCon+    , stablePtrPrimTyCon+    , stableNamePrimTyCon+    , compactPrimTyCon+    , statePrimTyCon+    , voidPrimTyCon+    , proxyPrimTyCon+    , threadIdPrimTyCon+    , wordPrimTyCon+    , word32PrimTyCon+    , word64PrimTyCon+    , eqPrimTyCon+    , eqReprPrimTyCon+    , eqPhantPrimTyCon++    , tYPETyCon++#include "primop-vector-tycons.hs-incl"+    ]++mkPrimTc :: FastString -> Unique -> TyCon -> Name+mkPrimTc fs unique tycon+  = mkWiredInName gHC_PRIM (mkTcOccFS fs)+                  unique+                  (ATyCon tycon)        -- Relevant TyCon+                  UserSyntax++mkBuiltInPrimTc :: FastString -> Unique -> TyCon -> Name+mkBuiltInPrimTc fs unique tycon+  = mkWiredInName gHC_PRIM (mkTcOccFS fs)+                  unique+                  (ATyCon tycon)        -- Relevant TyCon+                  BuiltInSyntax+++charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, voidPrimTyConName :: Name+charPrimTyConName             = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon+intPrimTyConName              = mkPrimTc (fsLit "Int#") intPrimTyConKey  intPrimTyCon+int32PrimTyConName            = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon+int64PrimTyConName            = mkPrimTc (fsLit "Int64#") int64PrimTyConKey int64PrimTyCon+wordPrimTyConName             = mkPrimTc (fsLit "Word#") wordPrimTyConKey wordPrimTyCon+word32PrimTyConName           = mkPrimTc (fsLit "Word32#") word32PrimTyConKey word32PrimTyCon+word64PrimTyConName           = mkPrimTc (fsLit "Word64#") word64PrimTyConKey word64PrimTyCon+addrPrimTyConName             = mkPrimTc (fsLit "Addr#") addrPrimTyConKey addrPrimTyCon+floatPrimTyConName            = mkPrimTc (fsLit "Float#") floatPrimTyConKey floatPrimTyCon+doublePrimTyConName           = mkPrimTc (fsLit "Double#") doublePrimTyConKey doublePrimTyCon+statePrimTyConName            = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon+voidPrimTyConName             = mkPrimTc (fsLit "Void#") voidPrimTyConKey voidPrimTyCon+proxyPrimTyConName            = mkPrimTc (fsLit "Proxy#") proxyPrimTyConKey proxyPrimTyCon+eqPrimTyConName               = mkPrimTc (fsLit "~#") eqPrimTyConKey eqPrimTyCon+eqReprPrimTyConName           = mkBuiltInPrimTc (fsLit "~R#") eqReprPrimTyConKey eqReprPrimTyCon+eqPhantPrimTyConName          = mkBuiltInPrimTc (fsLit "~P#") eqPhantPrimTyConKey eqPhantPrimTyCon+realWorldTyConName            = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon+arrayPrimTyConName            = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon+byteArrayPrimTyConName        = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon+arrayArrayPrimTyConName           = mkPrimTc (fsLit "ArrayArray#") arrayArrayPrimTyConKey arrayArrayPrimTyCon+smallArrayPrimTyConName       = mkPrimTc (fsLit "SmallArray#") smallArrayPrimTyConKey smallArrayPrimTyCon+mutableArrayPrimTyConName     = mkPrimTc (fsLit "MutableArray#") mutableArrayPrimTyConKey mutableArrayPrimTyCon+mutableByteArrayPrimTyConName = mkPrimTc (fsLit "MutableByteArray#") mutableByteArrayPrimTyConKey mutableByteArrayPrimTyCon+mutableArrayArrayPrimTyConName= mkPrimTc (fsLit "MutableArrayArray#") mutableArrayArrayPrimTyConKey mutableArrayArrayPrimTyCon+smallMutableArrayPrimTyConName= mkPrimTc (fsLit "SmallMutableArray#") smallMutableArrayPrimTyConKey smallMutableArrayPrimTyCon+mutVarPrimTyConName           = mkPrimTc (fsLit "MutVar#") mutVarPrimTyConKey mutVarPrimTyCon+mVarPrimTyConName             = mkPrimTc (fsLit "MVar#") mVarPrimTyConKey mVarPrimTyCon+tVarPrimTyConName             = mkPrimTc (fsLit "TVar#") tVarPrimTyConKey tVarPrimTyCon+stablePtrPrimTyConName        = mkPrimTc (fsLit "StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon+stableNamePrimTyConName       = mkPrimTc (fsLit "StableName#") stableNamePrimTyConKey stableNamePrimTyCon+compactPrimTyConName          = mkPrimTc (fsLit "Compact#") compactPrimTyConKey compactPrimTyCon+bcoPrimTyConName              = mkPrimTc (fsLit "BCO#") bcoPrimTyConKey bcoPrimTyCon+weakPrimTyConName             = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon+threadIdPrimTyConName         = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon++{-+************************************************************************+*                                                                      *+\subsection{Support code}+*                                                                      *+************************************************************************++alphaTyVars is a list of type variables for use in templates:+        ["a", "b", ..., "z", "t1", "t2", ... ]+-}++mkTemplateKindVars :: [Kind] -> [TyVar]+-- k0  with unique (mkAlphaTyVarUnique 0)+-- k1  with unique (mkAlphaTyVarUnique 1)+-- ... etc+mkTemplateKindVars kinds+  = [ mkTyVar name kind+    | (kind, u) <- kinds `zip` [0..]+    , let occ = mkTyVarOccFS (mkFastString ('k' : show u))+          name = mkInternalName (mkAlphaTyVarUnique u) occ noSrcSpan+    ]++mkTemplateTyVarsFrom :: Int -> [Kind] -> [TyVar]+-- a  with unique (mkAlphaTyVarUnique n)+-- b  with unique (mkAlphaTyVarUnique n+1)+-- ... etc+-- Typically called as+--   mkTemplateTyVarsFrom (legth kv_bndrs) kinds+-- where kv_bndrs are the kind-level binders of a TyCon+mkTemplateTyVarsFrom n kinds+  = [ mkTyVar name kind+    | (kind, index) <- zip kinds [0..],+      let ch_ord = index + ord 'a'+          name_str | ch_ord <= ord 'z' = [chr ch_ord]+                   | otherwise         = 't':show index+          uniq = mkAlphaTyVarUnique (index + n)+          name = mkInternalName uniq occ noSrcSpan+          occ  = mkTyVarOccFS (mkFastString name_str)+    ]++mkTemplateTyVars :: [Kind] -> [TyVar]+mkTemplateTyVars = mkTemplateTyVarsFrom 1++mkTemplateTyConBinders+    :: [Kind]                -- [k1, .., kn]   Kinds of kind-forall'd vars+    -> ([Kind] -> [Kind])    -- Arg is [kv1:k1, ..., kvn:kn]+                             --     same length as first arg+                             -- Result is anon arg kinds+    -> [TyConBinder]+mkTemplateTyConBinders kind_var_kinds mk_anon_arg_kinds+  = kv_bndrs ++ tv_bndrs+  where+    kv_bndrs   = mkTemplateKindTyConBinders kind_var_kinds+    anon_kinds = mk_anon_arg_kinds (mkTyVarTys (binderVars kv_bndrs))+    tv_bndrs   = mkTemplateAnonTyConBindersFrom (length kv_bndrs) anon_kinds++mkTemplateKiTyVars+    :: [Kind]                -- [k1, .., kn]   Kinds of kind-forall'd vars+    -> ([Kind] -> [Kind])    -- Arg is [kv1:k1, ..., kvn:kn]+                             --     same length as first arg+                             -- Result is anon arg kinds [ak1, .., akm]+    -> [TyVar]   -- [kv1:k1, ..., kvn:kn, av1:ak1, ..., avm:akm]+-- Example: if you want the tyvars for+--   forall (r:RuntimeRep) (a:TYPE r) (b:*). blah+-- call mkTemplateKiTyVars [RuntimeRep] (\[r]. [TYPE r, *)+mkTemplateKiTyVars kind_var_kinds mk_arg_kinds+  = kv_bndrs ++ tv_bndrs+  where+    kv_bndrs   = mkTemplateKindVars kind_var_kinds+    anon_kinds = mk_arg_kinds (mkTyVarTys kv_bndrs)+    tv_bndrs   = mkTemplateTyVarsFrom (length kv_bndrs) anon_kinds++mkTemplateKindTyConBinders :: [Kind] -> [TyConBinder]+-- Makes named, Specified binders+mkTemplateKindTyConBinders kinds = [mkNamedTyConBinder Specified tv | tv <- mkTemplateKindVars kinds]++mkTemplateAnonTyConBinders :: [Kind] -> [TyConBinder]+mkTemplateAnonTyConBinders kinds = map mkAnonTyConBinder (mkTemplateTyVars kinds)++mkTemplateAnonTyConBindersFrom :: Int -> [Kind] -> [TyConBinder]+mkTemplateAnonTyConBindersFrom n kinds = map mkAnonTyConBinder (mkTemplateTyVarsFrom n kinds)++alphaTyVars :: [TyVar]+alphaTyVars = mkTemplateTyVars $ repeat liftedTypeKind++alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar :: TyVar+(alphaTyVar:betaTyVar:gammaTyVar:deltaTyVar:_) = alphaTyVars++alphaTys :: [Type]+alphaTys = mkTyVarTys alphaTyVars+alphaTy, betaTy, gammaTy, deltaTy :: Type+(alphaTy:betaTy:gammaTy:deltaTy:_) = alphaTys++runtimeRep1TyVar, runtimeRep2TyVar :: TyVar+(runtimeRep1TyVar : runtimeRep2TyVar : _)+  = drop 16 (mkTemplateTyVars (repeat runtimeRepTy))  -- selects 'q','r'++runtimeRep1Ty, runtimeRep2Ty :: Type+runtimeRep1Ty = mkTyVarTy runtimeRep1TyVar+runtimeRep2Ty = mkTyVarTy runtimeRep2TyVar++openAlphaTyVar, openBetaTyVar :: TyVar+[openAlphaTyVar,openBetaTyVar]+  = mkTemplateTyVars [tYPE runtimeRep1Ty, tYPE runtimeRep2Ty]++openAlphaTy, openBetaTy :: Type+openAlphaTy = mkTyVarTy openAlphaTyVar+openBetaTy  = mkTyVarTy openBetaTyVar++{-+************************************************************************+*                                                                      *+                FunTyCon+*                                                                      *+************************************************************************+-}++funTyConName :: Name+funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon++-- | The @(->)@ type constructor.+--+-- @+-- (->) :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep).+--         TYPE rep1 -> TYPE rep2 -> *+-- @+funTyCon :: TyCon+funTyCon = mkFunTyCon funTyConName tc_bndrs tc_rep_nm+  where+    tc_bndrs = [ TvBndr runtimeRep1TyVar (NamedTCB Inferred)+               , TvBndr runtimeRep2TyVar (NamedTCB Inferred)+               ]+               ++ mkTemplateAnonTyConBinders [ tYPE runtimeRep1Ty+                                             , tYPE runtimeRep2Ty+                                             ]+    tc_rep_nm = mkPrelTyConRepName funTyConName++{-+************************************************************************+*                                                                      *+                Kinds+*                                                                      *+************************************************************************++Note [TYPE and RuntimeRep]+~~~~~~~~~~~~~~~~~~~~~~~~~~+All types that classify values have a kind of the form (TYPE rr), where++    data RuntimeRep     -- Defined in ghc-prim:GHC.Types+      = LiftedRep+      | UnliftedRep+      | IntRep+      | FloatRep+      .. etc ..++    rr :: RuntimeRep++    TYPE :: RuntimeRep -> TYPE 'LiftedRep  -- Built in++So for example:+    Int        :: TYPE 'LiftedRep+    Array# Int :: TYPE 'UnliftedRep+    Int#       :: TYPE 'IntRep+    Float#     :: TYPE 'FloatRep+    Maybe      :: TYPE 'LiftedRep -> TYPE 'LiftedRep+    (# , #)    :: TYPE r1 -> TYPE r2 -> TYPE (TupleRep [r1, r2])++We abbreviate '*' specially:+    type * = TYPE 'LiftedRep++The 'rr' parameter tells us how the value is represented at runime.++Generally speaking, you can't be polymorphic in 'rr'.  E.g+   f :: forall (rr:RuntimeRep) (a:TYPE rr). a -> [a]+   f = /\(rr:RuntimeRep) (a:rr) \(a:rr). ...+This is no good: we could not generate code code for 'f', because the+calling convention for 'f' varies depending on whether the argument is+a a Int, Int#, or Float#.  (You could imagine generating specialised+code, one for each instantiation of 'rr', but we don't do that.)++Certain functions CAN be runtime-rep-polymorphic, because the code+generator never has to manipulate a value of type 'a :: TYPE rr'.++* error :: forall (rr:RuntimeRep) (a:TYPE rr). String -> a+  Code generator never has to manipulate the return value.++* unsafeCoerce#, defined in MkId.unsafeCoerceId:+  Always inlined to be a no-op+     unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)+                             (a :: TYPE r1) (b :: TYPE r2).+                             a -> b++* Unboxed tuples, and unboxed sums, defined in TysWiredIn+  Always inlined, and hence specialised to the call site+     (#,#) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)+                     (a :: TYPE r1) (b :: TYPE r2).+                     a -> b -> TYPE ('TupleRep '[r1, r2])++Note [PrimRep and kindPrimRep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As part of its source code, in TyCon, GHC has+  data PrimRep = LiftedRep | UnliftedRep | IntRep | FloatRep | ...etc...++Notice that+ * RuntimeRep is part of the syntax tree of the program being compiled+     (defined in a library: ghc-prim:GHC.Types)+ * PrimRep is part of GHC's source code.+     (defined in TyCon)++We need to get from one to the other; that is what kindPrimRep does.+Suppose we have a value+   (v :: t) where (t :: k)+Given this kind+    k = TyConApp "TYPE" [rep]+GHC needs to be able to figure out how 'v' is represented at runtime.+It expects 'rep' to be form+    TyConApp rr_dc args+where 'rr_dc' is a promoteed data constructor from RuntimeRep. So+now we need to go from 'dc' to the corresponding PrimRep.  We store this+PrimRep in the promoted data constructor itself: see TyCon.promDcRepInfo.++-}++tYPETyCon :: TyCon+tYPETyConName :: Name++tYPETyCon = mkKindTyCon tYPETyConName+                        (mkTemplateAnonTyConBinders [runtimeRepTy])+                        liftedTypeKind+                        [Nominal]+                        (mkPrelTyConRepName tYPETyConName)++--------------------------+-- ... and now their names++-- If you edit these, you may need to update the GHC formalism+-- See Note [GHC Formalism] in coreSyn/CoreLint.hs+tYPETyConName             = mkPrimTyConName (fsLit "TYPE") tYPETyConKey tYPETyCon++mkPrimTyConName :: FastString -> Unique -> TyCon -> Name+mkPrimTyConName = mkPrimTcName BuiltInSyntax+  -- All of the super kinds and kinds are defined in Prim,+  -- and use BuiltInSyntax, because they are never in scope in the source++mkPrimTcName :: BuiltInSyntax -> FastString -> Unique -> TyCon -> Name+mkPrimTcName built_in_syntax occ key tycon+  = mkWiredInName gHC_PRIM (mkTcOccFS occ) key (ATyCon tycon) built_in_syntax++-----------------------------+-- | Given a RuntimeRep, applies TYPE to it.+-- see Note [TYPE and RuntimeRep]+tYPE :: Type -> Type+tYPE rr = TyConApp tYPETyCon [rr]++{-+************************************************************************+*                                                                      *+\subsection[TysPrim-basic]{Basic primitive types (@Char#@, @Int#@, etc.)}+*                                                                      *+************************************************************************+-}++-- only used herein+pcPrimTyCon :: Name -> [Role] -> PrimRep -> TyCon+pcPrimTyCon name roles rep+  = mkPrimTyCon name binders result_kind roles+  where+    binders     = mkTemplateAnonTyConBinders (map (const liftedTypeKind) roles)+    result_kind = tYPE (primRepToRuntimeRep rep)++-- | Convert a 'PrimRep' to a 'Type' of kind RuntimeRep+-- Defined here to avoid (more) module loops+primRepToRuntimeRep :: PrimRep -> Type+primRepToRuntimeRep rep = case rep of+  VoidRep       -> TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy []]+  LiftedRep     -> liftedRepDataConTy+  UnliftedRep   -> unliftedRepDataConTy+  IntRep        -> intRepDataConTy+  WordRep       -> wordRepDataConTy+  Int64Rep      -> int64RepDataConTy+  Word64Rep     -> word64RepDataConTy+  AddrRep       -> addrRepDataConTy+  FloatRep      -> floatRepDataConTy+  DoubleRep     -> doubleRepDataConTy+  VecRep n elem -> TyConApp vecRepDataConTyCon [n', elem']+    where+      n' = case n of+        2  -> vec2DataConTy+        4  -> vec4DataConTy+        8  -> vec8DataConTy+        16 -> vec16DataConTy+        32 -> vec32DataConTy+        64 -> vec64DataConTy+        _  -> pprPanic "Disallowed VecCount" (ppr n)++      elem' = case elem of+        Int8ElemRep   -> int8ElemRepDataConTy+        Int16ElemRep  -> int16ElemRepDataConTy+        Int32ElemRep  -> int32ElemRepDataConTy+        Int64ElemRep  -> int64ElemRepDataConTy+        Word8ElemRep  -> word8ElemRepDataConTy+        Word16ElemRep -> word16ElemRepDataConTy+        Word32ElemRep -> word32ElemRepDataConTy+        Word64ElemRep -> word64ElemRepDataConTy+        FloatElemRep  -> floatElemRepDataConTy+        DoubleElemRep -> doubleElemRepDataConTy++pcPrimTyCon0 :: Name -> PrimRep -> TyCon+pcPrimTyCon0 name rep+  = pcPrimTyCon name [] rep++charPrimTy :: Type+charPrimTy      = mkTyConTy charPrimTyCon+charPrimTyCon :: TyCon+charPrimTyCon   = pcPrimTyCon0 charPrimTyConName WordRep++intPrimTy :: Type+intPrimTy       = mkTyConTy intPrimTyCon+intPrimTyCon :: TyCon+intPrimTyCon    = pcPrimTyCon0 intPrimTyConName IntRep++int32PrimTy :: Type+int32PrimTy     = mkTyConTy int32PrimTyCon+int32PrimTyCon :: TyCon+int32PrimTyCon  = pcPrimTyCon0 int32PrimTyConName IntRep++int64PrimTy :: Type+int64PrimTy     = mkTyConTy int64PrimTyCon+int64PrimTyCon :: TyCon+int64PrimTyCon  = pcPrimTyCon0 int64PrimTyConName Int64Rep++wordPrimTy :: Type+wordPrimTy      = mkTyConTy wordPrimTyCon+wordPrimTyCon :: TyCon+wordPrimTyCon   = pcPrimTyCon0 wordPrimTyConName WordRep++word32PrimTy :: Type+word32PrimTy    = mkTyConTy word32PrimTyCon+word32PrimTyCon :: TyCon+word32PrimTyCon = pcPrimTyCon0 word32PrimTyConName WordRep++word64PrimTy :: Type+word64PrimTy    = mkTyConTy word64PrimTyCon+word64PrimTyCon :: TyCon+word64PrimTyCon = pcPrimTyCon0 word64PrimTyConName Word64Rep++addrPrimTy :: Type+addrPrimTy      = mkTyConTy addrPrimTyCon+addrPrimTyCon :: TyCon+addrPrimTyCon   = pcPrimTyCon0 addrPrimTyConName AddrRep++floatPrimTy     :: Type+floatPrimTy     = mkTyConTy floatPrimTyCon+floatPrimTyCon :: TyCon+floatPrimTyCon  = pcPrimTyCon0 floatPrimTyConName FloatRep++doublePrimTy :: Type+doublePrimTy    = mkTyConTy doublePrimTyCon+doublePrimTyCon :: TyCon+doublePrimTyCon = pcPrimTyCon0 doublePrimTyConName DoubleRep++{-+************************************************************************+*                                                                      *+\subsection[TysPrim-state]{The @State#@ type (and @_RealWorld@ types)}+*                                                                      *+************************************************************************++Note [The equality types story]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC sports a veritable menagerie of equality types:++              Hetero?   Levity      Result       Role      Defining module+              ------------------------------------------------------------+  ~#          hetero    unlifted    #            nominal   GHC.Prim+  ~~          hetero    lifted      Constraint   nominal   GHC.Types+  ~           homo      lifted      Constraint   nominal   Data.Type.Equality+  :~:         homo      lifted      *            nominal   Data.Type.Equality++  ~R#         hetero    unlifted    #            repr      GHC.Prim+  Coercible   homo      lifted      Constraint   repr      GHC.Types+  Coercion    homo      lifted      *            repr      Data.Type.Coercion++  ~P#         hetero    unlifted                 phantom   GHC.Prim++Recall that "hetero" means the equality can related types of different+kinds. Knowing that (t1 ~# t2) or (t1 ~R# t2) or even that (t1 ~P# t2)+also means that (k1 ~# k2), where (t1 :: k1) and (t2 :: k2).++To produce less confusion for end users, when not dumping and without+-fprint-equality-relations, each of these groups is printed as the bottommost+listed equality. That is, (~#) and (~~) are both rendered as (~) in+error messages, and (~R#) is rendered as Coercible.++Let's take these one at a time:++    --------------------------+    (~#) :: forall k1 k2. k1 -> k2 -> #+    --------------------------+This is The Type Of Equality in GHC. It classifies nominal coercions.+This type is used in the solver for recording equality constraints.+It responds "yes" to Type.isEqPred and classifies as an EqPred in+Type.classifyPredType.++All wanted constraints of this type are built with coercion holes.+(See Note [Coercion holes] in TyCoRep.) But see also+Note [Deferred errors for coercion holes] in TcErrors to see how+equality constraints are deferred.++Within GHC, ~# is called eqPrimTyCon, and it is defined in TysPrim.+++    --------------------------+    (~~) :: forall k1 k2. k1 -> k2 -> Constraint+    --------------------------+This is (almost) an ordinary class, defined as if by+  class a ~# b => a ~~ b+  instance a ~# b => a ~~ b+Here's what's unusual about it:+ * We can't actually declare it that way because we don't have syntax for ~#.+   And ~# isn't a constraint, so even if we could write it, it wouldn't kind+   check.++ * Users cannot write instances of it.++ * It is "naturally coherent". This means that the solver won't hesitate to+   solve a goal of type (a ~~ b) even if there is, say (Int ~~ c) in the+   context. (Normally, it waits to learn more, just in case the given+   influences what happens next.) This is quite like having+   IncoherentInstances enabled.++ * It always terminates. That is, in the UndecidableInstances checks, we+   don't worry if a (~~) constraint is too big, as we know that solving+   equality terminates.++On the other hand, this behaves just like any class w.r.t. eager superclass+unpacking in the solver. So a lifted equality given quickly becomes an unlifted+equality given. This is good, because the solver knows all about unlifted+equalities. There is some special-casing in TcInteract.matchClassInst to+pretend that there is an instance of this class, as we can't write the instance+in Haskell.++Within GHC, ~~ is called heqTyCon, and it is defined in TysWiredIn.+++    --------------------------+    (~) :: forall k. k -> k -> Constraint+    --------------------------+This is defined in Data.Type.Equality:+  class a ~~ b => (a :: k) ~ (b :: k)+  instance a ~~ b => a ~ b+This is even more so an ordinary class than (~~), with the following exceptions:+ * Users cannot write instances of it.++ * It is "naturally coherent". (See (~~).)++ * (~) is magical syntax, as ~ is a reserved symbol. It cannot be exported+   or imported.++ * It always terminates.++Within GHC, ~ is called eqTyCon, and it is defined in PrelNames. Note that+it is *not* wired in.+++    --------------------------+    (:~:) :: forall k. k -> k -> *+    --------------------------+This is a perfectly ordinary GADT, wrapping (~). It is not defined within+GHC at all.+++    --------------------------+    (~R#) :: forall k1 k2. k1 -> k2 -> #+    --------------------------+The is the representational analogue of ~#. This is the type of representational+equalities that the solver works on. All wanted constraints of this type are+built with coercion holes.++Within GHC, ~R# is called eqReprPrimTyCon, and it is defined in TysPrim.+++    --------------------------+    Coercible :: forall k. k -> k -> Constraint+    --------------------------+This is quite like (~~) in the way it's defined and treated within GHC, but+it's homogeneous. Homogeneity helps with type inference (as GHC can solve one+kind from the other) and, in my (Richard's) estimation, will be more intuitive+for users.++An alternative design included HCoercible (like (~~)) and Coercible (like (~)).+One annoyance was that we want `coerce :: Coercible a b => a -> b`, and+we need the type of coerce to be fully wired-in. So the HCoercible/Coercible+split required that both types be fully wired-in. Instead of doing this,+I just got rid of HCoercible, as I'm not sure who would use it, anyway.++Within GHC, Coercible is called coercibleTyCon, and it is defined in+TysWiredIn.+++    --------------------------+    Coercion :: forall k. k -> k -> *+    --------------------------+This is a perfectly ordinary GADT, wrapping Coercible. It is not defined+within GHC at all.+++    --------------------------+    (~P#) :: forall k1 k2. k1 -> k2 -> #+    --------------------------+This is the phantom analogue of ~# and it is barely used at all.+(The solver has no idea about this one.) Here is the motivation:++    data Phant a = MkPhant+    type role Phant phantom++    Phant <Int, Bool>_P :: Phant Int ~P# Phant Bool++We just need to have something to put on that last line. You probably+don't need to worry about it.++++Note [The State# TyCon]+~~~~~~~~~~~~~~~~~~~~~~~+State# is the primitive, unlifted type of states.  It has one type parameter,+thus+        State# RealWorld+or+        State# s++where s is a type variable. The only purpose of the type parameter is to+keep different state threads separate.  It is represented by nothing at all.++The type parameter to State# is intended to keep separate threads separate.+Even though this parameter is not used in the definition of State#, it is+given role Nominal to enforce its intended use.+-}++mkStatePrimTy :: Type -> Type+mkStatePrimTy ty = TyConApp statePrimTyCon [ty]++statePrimTyCon :: TyCon   -- See Note [The State# TyCon]+statePrimTyCon   = pcPrimTyCon statePrimTyConName [Nominal] VoidRep++{-+RealWorld is deeply magical.  It is *primitive*, but it is not+*unlifted* (hence ptrArg).  We never manipulate values of type+RealWorld; it's only used in the type system, to parameterise State#.+-}++realWorldTyCon :: TyCon+realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName [] liftedTypeKind []+realWorldTy :: Type+realWorldTy          = mkTyConTy realWorldTyCon+realWorldStatePrimTy :: Type+realWorldStatePrimTy = mkStatePrimTy realWorldTy        -- State# RealWorld++-- Note: the ``state-pairing'' types are not truly primitive,+-- so they are defined in \tr{TysWiredIn.hs}, not here.+++voidPrimTy :: Type+voidPrimTy = TyConApp voidPrimTyCon []++voidPrimTyCon :: TyCon+voidPrimTyCon    = pcPrimTyCon voidPrimTyConName [] VoidRep++mkProxyPrimTy :: Type -> Type -> Type+mkProxyPrimTy k ty = TyConApp proxyPrimTyCon [k, ty]++proxyPrimTyCon :: TyCon+proxyPrimTyCon = mkPrimTyCon proxyPrimTyConName binders res_kind [Nominal,Nominal]+  where+     -- Kind: forall k. k -> Void#+     binders = mkTemplateTyConBinders [liftedTypeKind] (\ks-> ks)+     res_kind = unboxedTupleKind []+++{- *********************************************************************+*                                                                      *+                Primitive equality constraints+    See Note [The equality types story]+*                                                                      *+********************************************************************* -}++eqPrimTyCon :: TyCon  -- The representation type for equality predicates+                      -- See Note [The equality types story]+eqPrimTyCon  = mkPrimTyCon eqPrimTyConName binders res_kind roles+  where+    -- Kind :: forall k1 k2. k1 -> k2 -> Void#+    binders  = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] (\ks -> ks)+    res_kind = unboxedTupleKind []+    roles    = [Nominal, Nominal, Nominal, Nominal]++-- like eqPrimTyCon, but the type for *Representational* coercions+-- this should only ever appear as the type of a covar. Its role is+-- interpreted in coercionRole+eqReprPrimTyCon :: TyCon   -- See Note [The equality types story]+eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName binders res_kind roles+  where+    -- Kind :: forall k1 k2. k1 -> k2 -> Void#+    binders  = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] (\ks -> ks)+    res_kind = unboxedTupleKind []+    roles    = [Nominal, Nominal, Representational, Representational]++-- like eqPrimTyCon, but the type for *Phantom* coercions.+-- This is only used to make higher-order equalities. Nothing+-- should ever actually have this type!+eqPhantPrimTyCon :: TyCon+eqPhantPrimTyCon = mkPrimTyCon eqPhantPrimTyConName binders res_kind roles+  where+    -- Kind :: forall k1 k2. k1 -> k2 -> Void#+    binders  = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] (\ks -> ks)+    res_kind = unboxedTupleKind []+    roles    = [Nominal, Nominal, Phantom, Phantom]++{- *********************************************************************+*                                                                      *+             The primitive array types+*                                                                      *+********************************************************************* -}++arrayPrimTyCon, mutableArrayPrimTyCon, mutableByteArrayPrimTyCon,+    byteArrayPrimTyCon, arrayArrayPrimTyCon, mutableArrayArrayPrimTyCon,+    smallArrayPrimTyCon, smallMutableArrayPrimTyCon :: TyCon+arrayPrimTyCon             = pcPrimTyCon arrayPrimTyConName             [Representational] UnliftedRep+mutableArrayPrimTyCon      = pcPrimTyCon  mutableArrayPrimTyConName     [Nominal, Representational] UnliftedRep+mutableByteArrayPrimTyCon  = pcPrimTyCon mutableByteArrayPrimTyConName  [Nominal] UnliftedRep+byteArrayPrimTyCon         = pcPrimTyCon0 byteArrayPrimTyConName        UnliftedRep+arrayArrayPrimTyCon        = pcPrimTyCon0 arrayArrayPrimTyConName       UnliftedRep+mutableArrayArrayPrimTyCon = pcPrimTyCon mutableArrayArrayPrimTyConName [Nominal] UnliftedRep+smallArrayPrimTyCon        = pcPrimTyCon smallArrayPrimTyConName        [Representational] UnliftedRep+smallMutableArrayPrimTyCon = pcPrimTyCon smallMutableArrayPrimTyConName [Nominal, Representational] UnliftedRep++mkArrayPrimTy :: Type -> Type+mkArrayPrimTy elt           = TyConApp arrayPrimTyCon [elt]+byteArrayPrimTy :: Type+byteArrayPrimTy             = mkTyConTy byteArrayPrimTyCon+mkArrayArrayPrimTy :: Type+mkArrayArrayPrimTy = mkTyConTy arrayArrayPrimTyCon+mkSmallArrayPrimTy :: Type -> Type+mkSmallArrayPrimTy elt = TyConApp smallArrayPrimTyCon [elt]+mkMutableArrayPrimTy :: Type -> Type -> Type+mkMutableArrayPrimTy s elt  = TyConApp mutableArrayPrimTyCon [s, elt]+mkMutableByteArrayPrimTy :: Type -> Type+mkMutableByteArrayPrimTy s  = TyConApp mutableByteArrayPrimTyCon [s]+mkMutableArrayArrayPrimTy :: Type -> Type+mkMutableArrayArrayPrimTy s = TyConApp mutableArrayArrayPrimTyCon [s]+mkSmallMutableArrayPrimTy :: Type -> Type -> Type+mkSmallMutableArrayPrimTy s elt = TyConApp smallMutableArrayPrimTyCon [s, elt]+++{- *********************************************************************+*                                                                      *+                The mutable variable type+*                                                                      *+********************************************************************* -}++mutVarPrimTyCon :: TyCon+mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName [Nominal, Representational] UnliftedRep++mkMutVarPrimTy :: Type -> Type -> Type+mkMutVarPrimTy s elt        = TyConApp mutVarPrimTyCon [s, elt]++{-+************************************************************************+*                                                                      *+\subsection[TysPrim-synch-var]{The synchronizing variable type}+*                                                                      *+************************************************************************+-}++mVarPrimTyCon :: TyCon+mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName [Nominal, Representational] UnliftedRep++mkMVarPrimTy :: Type -> Type -> Type+mkMVarPrimTy s elt          = TyConApp mVarPrimTyCon [s, elt]++{-+************************************************************************+*                                                                      *+\subsection[TysPrim-stm-var]{The transactional variable type}+*                                                                      *+************************************************************************+-}++tVarPrimTyCon :: TyCon+tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName [Nominal, Representational] UnliftedRep++mkTVarPrimTy :: Type -> Type -> Type+mkTVarPrimTy s elt = TyConApp tVarPrimTyCon [s, elt]++{-+************************************************************************+*                                                                      *+\subsection[TysPrim-stable-ptrs]{The stable-pointer type}+*                                                                      *+************************************************************************+-}++stablePtrPrimTyCon :: TyCon+stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName [Representational] AddrRep++mkStablePtrPrimTy :: Type -> Type+mkStablePtrPrimTy ty = TyConApp stablePtrPrimTyCon [ty]++{-+************************************************************************+*                                                                      *+\subsection[TysPrim-stable-names]{The stable-name type}+*                                                                      *+************************************************************************+-}++stableNamePrimTyCon :: TyCon+stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName [Representational] UnliftedRep++mkStableNamePrimTy :: Type -> Type+mkStableNamePrimTy ty = TyConApp stableNamePrimTyCon [ty]++{-+************************************************************************+*                                                                      *+\subsection[TysPrim-compact-nfdata]{The Compact NFData (CNF) type}+*                                                                      *+************************************************************************+-}++compactPrimTyCon :: TyCon+compactPrimTyCon = pcPrimTyCon0 compactPrimTyConName UnliftedRep++compactPrimTy :: Type+compactPrimTy = mkTyConTy compactPrimTyCon++{-+************************************************************************+*                                                                      *+\subsection[TysPrim-BCOs]{The ``bytecode object'' type}+*                                                                      *+************************************************************************+-}++bcoPrimTy    :: Type+bcoPrimTy    = mkTyConTy bcoPrimTyCon+bcoPrimTyCon :: TyCon+bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName UnliftedRep++{-+************************************************************************+*                                                                      *+\subsection[TysPrim-Weak]{The ``weak pointer'' type}+*                                                                      *+************************************************************************+-}++weakPrimTyCon :: TyCon+weakPrimTyCon = pcPrimTyCon weakPrimTyConName [Representational] UnliftedRep++mkWeakPrimTy :: Type -> Type+mkWeakPrimTy v = TyConApp weakPrimTyCon [v]++{-+************************************************************************+*                                                                      *+\subsection[TysPrim-thread-ids]{The ``thread id'' type}+*                                                                      *+************************************************************************++A thread id is represented by a pointer to the TSO itself, to ensure+that they are always unique and we can always find the TSO for a given+thread id.  However, this has the unfortunate consequence that a+ThreadId# for a given thread is treated as a root by the garbage+collector and can keep TSOs around for too long.++Hence the programmer API for thread manipulation uses a weak pointer+to the thread id internally.+-}++threadIdPrimTy :: Type+threadIdPrimTy    = mkTyConTy threadIdPrimTyCon+threadIdPrimTyCon :: TyCon+threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName UnliftedRep++{-+************************************************************************+*                                                                      *+\subsection{SIMD vector types}+*                                                                      *+************************************************************************+-}++#include "primop-vector-tys.hs-incl"
+ prelude/TysWiredIn.hs view
@@ -0,0 +1,1652 @@+{-+(c) The GRASP Project, Glasgow University, 1994-1998++\section[TysWiredIn]{Wired-in knowledge about {\em non-primitive} types}+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++-- | This module is about types that can be defined in Haskell, but which+--   must be wired into the compiler nonetheless.  C.f module TysPrim+module TysWiredIn (+        -- * Helper functions defined here+        mkWiredInTyConName, -- This is used in TcTypeNats to define the+                            -- built-in functions for evaluation.++        mkWiredInIdName,    -- used in MkId++        mkFunKind, mkForAllKind,++        -- * All wired in things+        wiredInTyCons, isBuiltInOcc_maybe,++        -- * Bool+        boolTy, boolTyCon, boolTyCon_RDR, boolTyConName,+        trueDataCon,  trueDataConId,  true_RDR,+        falseDataCon, falseDataConId, false_RDR,+        promotedFalseDataCon, promotedTrueDataCon,++        -- * Ordering+        orderingTyCon,+        ltDataCon, ltDataConId,+        eqDataCon, eqDataConId,+        gtDataCon, gtDataConId,+        promotedLTDataCon, promotedEQDataCon, promotedGTDataCon,++        -- * Boxing primitive types+        boxingDataCon_maybe,++        -- * Char+        charTyCon, charDataCon, charTyCon_RDR,+        charTy, stringTy, charTyConName,++        -- * Double+        doubleTyCon, doubleDataCon, doubleTy, doubleTyConName,++        -- * Float+        floatTyCon, floatDataCon, floatTy, floatTyConName,++        -- * Int+        intTyCon, intDataCon, intTyCon_RDR, intDataCon_RDR, intTyConName,+        intTy,++        -- * Word+        wordTyCon, wordDataCon, wordTyConName, wordTy,++        -- * Word8+        word8TyCon, word8DataCon, word8TyConName, word8Ty,++        -- * List+        listTyCon, listTyCon_RDR, listTyConName, listTyConKey,+        nilDataCon, nilDataConName, nilDataConKey,+        consDataCon_RDR, consDataCon, consDataConName,+        promotedNilDataCon, promotedConsDataCon,+        mkListTy, mkPromotedListTy,++        -- * Maybe+        maybeTyCon, maybeTyConName,+        nothingDataCon, nothingDataConName, promotedNothingDataCon,+        justDataCon, justDataConName, promotedJustDataCon,++        -- * Tuples+        mkTupleTy, mkBoxedTupleTy,+        tupleTyCon, tupleDataCon, tupleTyConName,+        promotedTupleDataCon,+        unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey,+        pairTyCon,+        unboxedUnitTyCon, unboxedUnitDataCon,+        unboxedTupleKind, unboxedSumKind,++        -- ** Constraint tuples+        cTupleTyConName, cTupleTyConNames, isCTupleTyConName,+        cTupleDataConName, cTupleDataConNames,++        -- * Any+        anyTyCon, anyTy, anyTypeOfKind,++        -- * Sums+        mkSumTy, sumTyCon, sumDataCon,++        -- * Kinds+        typeNatKindCon, typeNatKind, typeSymbolKindCon, typeSymbolKind,+        isLiftedTypeKindTyConName, liftedTypeKind, constraintKind,+        starKindTyCon, starKindTyConName,+        unicodeStarKindTyCon, unicodeStarKindTyConName,+        liftedTypeKindTyCon, constraintKindTyCon,++        -- * Parallel arrays+        mkPArrTy,+        parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon,+        parrTyCon_RDR, parrTyConName,++        -- * Equality predicates+        heqTyCon, heqClass, heqDataCon,+        coercibleTyCon, coercibleDataCon, coercibleClass,++        -- * RuntimeRep and friends+        runtimeRepTyCon, vecCountTyCon, vecElemTyCon,++        runtimeRepTy, liftedRepTy, liftedRepDataCon, liftedRepDataConTyCon,++        vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon,++        liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy,+        wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy,+        floatRepDataConTy, doubleRepDataConTy,++        vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,+        vec64DataConTy,++        int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,+        int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy,+        word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy,+        doubleElemRepDataConTy++    ) where++#include "HsVersions.h"+#include "MachDeps.h"++import {-# SOURCE #-} MkId( mkDataConWorkId, mkDictSelId )++-- friends:+import PrelNames+import TysPrim+import {-# SOURCE #-} KnownUniques++-- others:+import CoAxiom+import Id+import Constants        ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE )+import Module           ( Module )+import Type+import RepType+import DataCon+import {-# SOURCE #-} ConLike+import TyCon+import Class            ( Class, mkClass )+import RdrName+import Name+import NameEnv          ( NameEnv, mkNameEnv, lookupNameEnv )+import NameSet          ( NameSet, mkNameSet, elemNameSet )+import BasicTypes       ( Arity, Boxity(..), TupleSort(..), ConTagZ,+                          SourceText(..) )+import ForeignCall+import SrcLoc           ( noSrcSpan )+import Unique+import Data.Array+import FastString+import Outputable+import Util+import BooleanFormula   ( mkAnd )++import qualified Data.ByteString.Char8 as BS+#if !MIN_VERSION_bytestring(0,10,8)+import qualified Data.ByteString.Internal as BSI+import qualified Data.ByteString.Unsafe as BSU+#endif++alpha_tyvar :: [TyVar]+alpha_tyvar = [alphaTyVar]++alpha_ty :: [Type]+alpha_ty = [alphaTy]++{-+Note [Wiring in RuntimeRep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+The RuntimeRep type (and friends) in GHC.Types has a bunch of constructors,+making it a pain to wire in. To ease the pain somewhat, we use lists of+the different bits, like Uniques, Names, DataCons. These lists must be+kept in sync with each other. The rule is this: use the order as declared+in GHC.Types. All places where such lists exist should contain a reference+to this Note, so a search for this Note's name should find all the lists.++************************************************************************+*                                                                      *+\subsection{Wired in type constructors}+*                                                                      *+************************************************************************++If you change which things are wired in, make sure you change their+names in PrelNames, so they use wTcQual, wDataQual, etc+-}++-- This list is used only to define PrelInfo.wiredInThings. That in turn+-- is used to initialise the name environment carried around by the renamer.+-- This means that if we look up the name of a TyCon (or its implicit binders)+-- that occurs in this list that name will be assigned the wired-in key we+-- define here.+--+-- Because of their infinite nature, this list excludes tuples, Any and implicit+-- parameter TyCons (see Note [Built-in syntax and the OrigNameCache]).+--+-- See also Note [Known-key names]+wiredInTyCons :: [TyCon]++wiredInTyCons = [ -- Units are not treated like other tuples, because then+                  -- are defined in GHC.Base, and there's only a few of them. We+                  -- put them in wiredInTyCons so that they will pre-populate+                  -- the name cache, so the parser in isBuiltInOcc_maybe doesn't+                  -- need to look out for them.+                  unitTyCon+                , unboxedUnitTyCon+                , anyTyCon+                , boolTyCon+                , charTyCon+                , doubleTyCon+                , floatTyCon+                , intTyCon+                , wordTyCon+                , word8TyCon+                , listTyCon+                , maybeTyCon+                , parrTyCon+                , heqTyCon+                , coercibleTyCon+                , typeNatKindCon+                , typeSymbolKindCon+                , runtimeRepTyCon+                , vecCountTyCon+                , vecElemTyCon+                , constraintKindTyCon+                , liftedTypeKindTyCon+                , starKindTyCon+                , unicodeStarKindTyCon+                ]++mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name+mkWiredInTyConName built_in modu fs unique tycon+  = mkWiredInName modu (mkTcOccFS fs) unique+                  (ATyCon tycon)        -- Relevant TyCon+                  built_in++mkWiredInDataConName :: BuiltInSyntax -> Module -> FastString -> Unique -> DataCon -> Name+mkWiredInDataConName built_in modu fs unique datacon+  = mkWiredInName modu (mkDataOccFS fs) unique+                  (AConLike (RealDataCon datacon))    -- Relevant DataCon+                  built_in++mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name+mkWiredInIdName mod fs uniq id+ = mkWiredInName mod (mkOccNameFS Name.varName fs) uniq (AnId id) UserSyntax++-- See Note [Kind-changing of (~) and Coercible]+-- in libraries/ghc-prim/GHC/Types.hs+heqTyConName, heqDataConName, heqSCSelIdName :: Name+heqTyConName   = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "~~")   heqTyConKey      heqTyCon+heqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#")  heqDataConKey heqDataCon+heqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "HEq_sc") heqSCSelIdKey heqSCSelId++-- See Note [Kind-changing of (~) and Coercible] in libraries/ghc-prim/GHC/Types.hs+coercibleTyConName, coercibleDataConName, coercibleSCSelIdName :: Name+coercibleTyConName   = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Coercible")  coercibleTyConKey   coercibleTyCon+coercibleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "MkCoercible") coercibleDataConKey coercibleDataCon+coercibleSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "Coercible_sc") coercibleSCSelIdKey coercibleSCSelId++charTyConName, charDataConName, intTyConName, intDataConName :: Name+charTyConName     = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Char") charTyConKey charTyCon+charDataConName   = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "C#") charDataConKey charDataCon+intTyConName      = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Int") intTyConKey   intTyCon+intDataConName    = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "I#") intDataConKey  intDataCon++boolTyConName, falseDataConName, trueDataConName :: Name+boolTyConName     = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Bool") boolTyConKey boolTyCon+falseDataConName  = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "False") falseDataConKey falseDataCon+trueDataConName   = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "True")  trueDataConKey  trueDataCon++listTyConName, nilDataConName, consDataConName :: Name+listTyConName     = mkWiredInTyConName   BuiltInSyntax gHC_TYPES (fsLit "[]") listTyConKey listTyCon+nilDataConName    = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") nilDataConKey nilDataCon+consDataConName   = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon++maybeTyConName, nothingDataConName, justDataConName :: Name+maybeTyConName     = mkWiredInTyConName   UserSyntax gHC_BASE (fsLit "Maybe")+                                          maybeTyConKey maybeTyCon+nothingDataConName = mkWiredInDataConName UserSyntax gHC_BASE (fsLit "Nothing")+                                          nothingDataConKey nothingDataCon+justDataConName    = mkWiredInDataConName UserSyntax gHC_BASE (fsLit "Just")+                                          justDataConKey justDataCon++wordTyConName, wordDataConName, word8TyConName, word8DataConName :: Name+wordTyConName      = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Word")   wordTyConKey     wordTyCon+wordDataConName    = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "W#")     wordDataConKey   wordDataCon+word8TyConName     = mkWiredInTyConName   UserSyntax gHC_WORD  (fsLit "Word8")  word8TyConKey    word8TyCon+word8DataConName   = mkWiredInDataConName UserSyntax gHC_WORD  (fsLit "W8#")    word8DataConKey  word8DataCon++floatTyConName, floatDataConName, doubleTyConName, doubleDataConName :: Name+floatTyConName     = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Float")  floatTyConKey    floatTyCon+floatDataConName   = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "F#")     floatDataConKey  floatDataCon+doubleTyConName    = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Double") doubleTyConKey   doubleTyCon+doubleDataConName  = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#")     doubleDataConKey doubleDataCon++-- Any++{-+Note [Any types]+~~~~~~~~~~~~~~~~+The type constructor Any,++    type family Any :: k where { }++It has these properties:++  * Note that 'Any' is kind polymorphic since in some program we may+    need to use Any to fill in a type variable of some kind other than *+    (see #959 for examples).  Its kind is thus `forall k. k``.++  * It is defined in module GHC.Types, and exported so that it is+    available to users.  For this reason it's treated like any other+    wired-in type:+      - has a fixed unique, anyTyConKey,+      - lives in the global name cache++  * It is a *closed* type family, with no instances.  This means that+    if   ty :: '(k1, k2)  we add a given coercion+             g :: ty ~ (Fst ty, Snd ty)+    If Any was a *data* type, then we'd get inconsistency because 'ty'+    could be (Any '(k1,k2)) and then we'd have an equality with Any on+    one side and '(,) on the other. See also #9097 and #9636.++  * When instantiated at a lifted type it is inhabited by at least one value,+    namely bottom++  * You can safely coerce any /lifted/ type to Any, and back with unsafeCoerce.++  * It does not claim to be a *data* type, and that's important for+    the code generator, because the code gen may *enter* a data value+    but never enters a function value.++  * It is wired-in so we can easily refer to it where we don't have a name+    environment (e.g. see Rules.matchRule for one example)++  * If (Any k) is the type of a value, it must be a /lifted/ value. So+    if we have (Any @(TYPE rr)) then rr must be 'LiftedRep.  See+    Note [TYPE and RuntimeRep] in TysPrim.  This is a convenient+    invariant, and makes isUnliftedTyCon well-defined; otherwise what+    would (isUnliftedTyCon Any) be?++It's used to instantiate un-constrained type variables after type checking. For+example, 'length' has type++  length :: forall a. [a] -> Int++and the list datacon for the empty list has type++  [] :: forall a. [a]++In order to compose these two terms as @length []@ a type+application is required, but there is no constraint on the+choice.  In this situation GHC uses 'Any',++> length (Any *) ([] (Any *))++Above, we print kinds explicitly, as if with --fprint-explicit-kinds.++The Any tycon used to be quite magic, but we have since been able to+implement it merely with an empty kind polymorphic type family. See #10886 for a+bit of history.+-}+++anyTyConName :: Name+anyTyConName =+    mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Any") anyTyConKey anyTyCon++anyTyCon :: TyCon+anyTyCon = mkFamilyTyCon anyTyConName binders res_kind Nothing+                         (ClosedSynFamilyTyCon Nothing)+                         Nothing+                         NotInjective+  where+    binders@[kv] = mkTemplateKindTyConBinders [liftedTypeKind]+    res_kind = mkTyVarTy (binderVar kv)++anyTy :: Type+anyTy = mkTyConTy anyTyCon++anyTypeOfKind :: Kind -> Type+anyTypeOfKind kind = mkTyConApp anyTyCon [kind]++-- Kinds+typeNatKindConName, typeSymbolKindConName :: Name+typeNatKindConName    = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Nat")    typeNatKindConNameKey    typeNatKindCon+typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Symbol") typeSymbolKindConNameKey typeSymbolKindCon++constraintKindTyConName :: Name+constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint") constraintKindTyConKey   constraintKindTyCon++liftedTypeKindTyConName, starKindTyConName, unicodeStarKindTyConName+  :: Name+liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type") liftedTypeKindTyConKey liftedTypeKindTyCon+starKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "*") starKindTyConKey starKindTyCon+unicodeStarKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "★") unicodeStarKindTyConKey unicodeStarKindTyCon++runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName :: Name+runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon+vecRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "VecRep") vecRepDataConKey vecRepDataCon+tupleRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "TupleRep") tupleRepDataConKey tupleRepDataCon+sumRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "SumRep") sumRepDataConKey sumRepDataCon++-- See Note [Wiring in RuntimeRep]+runtimeRepSimpleDataConNames :: [Name]+runtimeRepSimpleDataConNames+  = zipWith3Lazy mk_special_dc_name+      [ fsLit "LiftedRep", fsLit "UnliftedRep"+      , fsLit "IntRep"+      , fsLit "WordRep", fsLit "Int64Rep", fsLit "Word64Rep"+      , fsLit "AddrRep", fsLit "FloatRep", fsLit "DoubleRep" ]+      runtimeRepSimpleDataConKeys+      runtimeRepSimpleDataCons++vecCountTyConName :: Name+vecCountTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecCount") vecCountTyConKey vecCountTyCon++-- See Note [Wiring in RuntimeRep]+vecCountDataConNames :: [Name]+vecCountDataConNames = zipWith3Lazy mk_special_dc_name+                         [ fsLit "Vec2", fsLit "Vec4", fsLit "Vec8"+                         , fsLit "Vec16", fsLit "Vec32", fsLit "Vec64" ]+                         vecCountDataConKeys+                         vecCountDataCons++vecElemTyConName :: Name+vecElemTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecElem") vecElemTyConKey vecElemTyCon++-- See Note [Wiring in RuntimeRep]+vecElemDataConNames :: [Name]+vecElemDataConNames = zipWith3Lazy mk_special_dc_name+                        [ fsLit "Int8ElemRep", fsLit "Int16ElemRep", fsLit "Int32ElemRep"+                        , fsLit "Int64ElemRep", fsLit "Word8ElemRep", fsLit "Word16ElemRep"+                        , fsLit "Word32ElemRep", fsLit "Word64ElemRep"+                        , fsLit "FloatElemRep", fsLit "DoubleElemRep" ]+                        vecElemDataConKeys+                        vecElemDataCons++mk_special_dc_name :: FastString -> Unique -> DataCon -> Name+mk_special_dc_name fs u dc = mkWiredInDataConName UserSyntax gHC_TYPES fs u dc++parrTyConName, parrDataConName :: Name+parrTyConName   = mkWiredInTyConName   BuiltInSyntax+                    gHC_PARR' (fsLit "[::]") parrTyConKey parrTyCon+parrDataConName = mkWiredInDataConName UserSyntax+                    gHC_PARR' (fsLit "PArr") parrDataConKey parrDataCon++boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR,+    intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR :: RdrName+boolTyCon_RDR   = nameRdrName boolTyConName+false_RDR       = nameRdrName falseDataConName+true_RDR        = nameRdrName trueDataConName+intTyCon_RDR    = nameRdrName intTyConName+charTyCon_RDR   = nameRdrName charTyConName+intDataCon_RDR  = nameRdrName intDataConName+listTyCon_RDR   = nameRdrName listTyConName+consDataCon_RDR = nameRdrName consDataConName+parrTyCon_RDR   = nameRdrName parrTyConName++{-+************************************************************************+*                                                                      *+\subsection{mkWiredInTyCon}+*                                                                      *+************************************************************************+-}++pcNonEnumTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon+-- Not an enumeration+pcNonEnumTyCon = pcTyCon False++-- This function assumes that the types it creates have all parameters at+-- Representational role, and that there is no kind polymorphism.+pcTyCon :: Bool -> Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon+pcTyCon is_enum name cType tyvars cons+  = mkAlgTyCon name+                (mkAnonTyConBinders tyvars)+                liftedTypeKind+                (map (const Representational) tyvars)+                cType+                []              -- No stupid theta+                (DataTyCon cons is_enum)+                (VanillaAlgTyCon (mkPrelTyConRepName name))+                False           -- Not in GADT syntax++pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon+pcDataCon n univs = pcDataConWithFixity False n univs []  -- no ex_tvs++pcDataConWithFixity :: Bool      -- ^ declared infix?+                    -> Name      -- ^ datacon name+                    -> [TyVar]   -- ^ univ tyvars+                    -> [TyVar]   -- ^ ex tyvars+                    -> [Type]    -- ^ args+                    -> TyCon+                    -> DataCon+pcDataConWithFixity infx n = pcDataConWithFixity' infx n (dataConWorkerUnique (nameUnique n))+                                                  NoRRI+-- The Name's unique is the first of two free uniques;+-- the first is used for the datacon itself,+-- the second is used for the "worker name"+--+-- To support this the mkPreludeDataConUnique function "allocates"+-- one DataCon unique per pair of Ints.++pcDataConWithFixity' :: Bool -> Name -> Unique -> RuntimeRepInfo+                     -> [TyVar] -> [TyVar]+                     -> [Type] -> TyCon -> DataCon+-- The Name should be in the DataName name space; it's the name+-- of the DataCon itself.++pcDataConWithFixity' declared_infix dc_name wrk_key rri tyvars ex_tyvars arg_tys tycon+  = data_con+  where+    data_con = mkDataCon dc_name declared_infix prom_info+                (map (const no_bang) arg_tys)+                []      -- No labelled fields+                (mkTyVarBinders Specified tyvars)+                (mkTyVarBinders Specified ex_tyvars)+                []      -- No equality spec+                []      -- No theta+                arg_tys (mkTyConApp tycon (mkTyVarTys tyvars))+                rri+                tycon+                []      -- No stupid theta+                (mkDataConWorkId wrk_name data_con)+                NoDataConRep    -- Wired-in types are too simple to need wrappers++    no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict++    wrk_name = mkDataConWorkerName data_con wrk_key++    prom_info = mkPrelTyConRepName dc_name++mkDataConWorkerName :: DataCon -> Unique -> Name+mkDataConWorkerName data_con wrk_key =+    mkWiredInName modu wrk_occ wrk_key+                  (AnId (dataConWorkId data_con)) UserSyntax+  where+    modu     = ASSERT( isExternalName dc_name )+               nameModule dc_name+    dc_name = dataConName data_con+    dc_occ  = nameOccName dc_name+    wrk_occ = mkDataConWorkerOcc dc_occ++-- used for RuntimeRep and friends+pcSpecialDataCon :: Name -> [Type] -> TyCon -> RuntimeRepInfo -> DataCon+pcSpecialDataCon dc_name arg_tys tycon rri+  = pcDataConWithFixity' False dc_name (dataConWorkerUnique (nameUnique dc_name)) rri+                         [] [] arg_tys tycon++{-+************************************************************************+*                                                                      *+      Kinds+*                                                                      *+************************************************************************+-}++typeNatKindCon, typeSymbolKindCon :: TyCon+-- data Nat+-- data Symbol+typeNatKindCon    = pcTyCon False typeNatKindConName    Nothing [] []+typeSymbolKindCon = pcTyCon False typeSymbolKindConName Nothing [] []++typeNatKind, typeSymbolKind :: Kind+typeNatKind    = mkTyConTy typeNatKindCon+typeSymbolKind = mkTyConTy typeSymbolKindCon++constraintKindTyCon :: TyCon+constraintKindTyCon = pcTyCon False constraintKindTyConName+                              Nothing [] []++liftedTypeKind, constraintKind :: Kind+liftedTypeKind   = tYPE liftedRepTy+constraintKind   = mkTyConApp constraintKindTyCon []++-- mkFunKind and mkForAllKind are defined here+-- solely so that TyCon can use them via a SOURCE import+mkFunKind :: Kind -> Kind -> Kind+mkFunKind = mkFunTy++mkForAllKind :: TyVar -> ArgFlag -> Kind -> Kind+mkForAllKind = mkForAllTy++{-+************************************************************************+*                                                                      *+                Stuff for dealing with tuples+*                                                                      *+************************************************************************++Note [How tuples work]  See also Note [Known-key names] in PrelNames+~~~~~~~~~~~~~~~~~~~~~~+* There are three families of tuple TyCons and corresponding+  DataCons, expressed by the type BasicTypes.TupleSort:+    data TupleSort = BoxedTuple | UnboxedTuple | ConstraintTuple++* All three families are AlgTyCons, whose AlgTyConRhs is TupleTyCon++* BoxedTuples+    - A wired-in type+    - Data type declarations in GHC.Tuple+    - The data constructors really have an info table++* UnboxedTuples+    - A wired-in type+    - Have a pretend DataCon, defined in GHC.Prim,+      but no actual declaration and no info table++* ConstraintTuples+    - Are known-key rather than wired-in. Reason: it's awkward to+      have all the superclass selectors wired-in.+    - Declared as classes in GHC.Classes, e.g.+         class (c1,c2) => (c1,c2)+    - Given constraints: the superclasses automatically become available+    - Wanted constraints: there is a built-in instance+         instance (c1,c2) => (c1,c2)+    - Currently just go up to 16; beyond that+      you have to use manual nesting+    - Their OccNames look like (%,,,%), so they can easily be+      distinguished from term tuples.  But (following Haskell) we+      pretty-print saturated constraint tuples with round parens; see+      BasicTypes.tupleParens.++* In quite a lot of places things are restrcted just to+  BoxedTuple/UnboxedTuple, and then we used BasicTypes.Boxity to distinguish+  E.g. tupleTyCon has a Boxity argument++* When looking up an OccName in the original-name cache+  (IfaceEnv.lookupOrigNameCache), we spot the tuple OccName to make sure+  we get the right wired-in name.  This guy can't tell the difference+  between BoxedTuple and ConstraintTuple (same OccName!), so tuples+  are not serialised into interface files using OccNames at all.++* Serialization to interface files works via the usual mechanism for known-key+  things: instead of serializing the OccName we just serialize the key. During+  deserialization we lookup the Name associated with the unique with the logic+  in KnownUniques. See Note [Symbol table representation of names] for details.++Note [One-tuples]+~~~~~~~~~~~~~~~~~+GHC supports both boxed and unboxed one-tuples:+ - Unboxed one-tuples are sometimes useful when returning a+   single value after CPR analysis+ - A boxed one-tuple is used by DsUtils.mkSelectorBinds, when+   there is just one binder+Basically it keeps everythig uniform.++However the /naming/ of the type/data constructors for one-tuples is a+bit odd:+  3-tuples:  (,,)   (,,)#+  2-tuples:  (,)    (,)#+  1-tuples:  ??+  0-tuples:  ()     ()#++Zero-tuples have used up the logical name. So we use 'Unit' and 'Unit#'+for one-tuples.  So in ghc-prim:GHC.Tuple we see the declarations:+  data ()     = ()+  data Unit a = Unit a+  data (a,b)  = (a,b)++NB (Feb 16): for /constraint/ one-tuples I have 'Unit%' but no class+decl in GHC.Classes, so I think this part may not work properly. But+it's unused I think.+-}++-- | Built-in syntax isn't "in scope" so these OccNames map to wired-in Names+-- with BuiltInSyntax. However, this should only be necessary while resolving+-- names produced by Template Haskell splices since we take care to encode+-- built-in syntax names specially in interface files. See+-- Note [Symbol table representation of names].+--+-- Moreover, there is no need to include names of things that the user can't+-- write (e.g. type representation bindings like $tc(,,,)).+isBuiltInOcc_maybe :: OccName -> Maybe Name+isBuiltInOcc_maybe occ =+    case name of+      "[]" -> Just $ choose_ns listTyConName nilDataConName+      ":"    -> Just consDataConName++      "[::]" -> Just parrTyConName++      -- boxed tuple data/tycon+      "()"    -> Just $ tup_name Boxed 0+      _ | Just rest <- "(" `stripPrefix` name+        , (commas, rest') <- BS.span (==',') rest+        , ")" <- rest'+             -> Just $ tup_name Boxed (1+BS.length commas)++      -- unboxed tuple data/tycon+      "(##)"  -> Just $ tup_name Unboxed 0+      "Unit#" -> Just $ tup_name Unboxed 1+      _ | Just rest <- "(#" `stripPrefix` name+        , (commas, rest') <- BS.span (==',') rest+        , "#)" <- rest'+             -> Just $ tup_name Unboxed (1+BS.length commas)++      -- unboxed sum tycon+      _ | Just rest <- "(#" `stripPrefix` name+        , (pipes, rest') <- BS.span (=='|') rest+        , "#)" <- rest'+             -> Just $ tyConName $ sumTyCon (1+BS.length pipes)++      -- unboxed sum datacon+      _ | Just rest <- "(#" `stripPrefix` name+        , (pipes1, rest') <- BS.span (=='|') rest+        , Just rest'' <- "_" `stripPrefix` rest'+        , (pipes2, rest''') <- BS.span (=='|') rest''+        , "#)" <- rest'''+             -> let arity = BS.length pipes1 + BS.length pipes2 + 1+                    alt = BS.length pipes1 + 1+                in Just $ dataConName $ sumDataCon alt arity+      _ -> Nothing+  where+    -- TODO: Drop when bytestring 0.10.8 can be assumed+#if MIN_VERSION_bytestring(0,10,8)+    stripPrefix = BS.stripPrefix+#else+    stripPrefix bs1@(BSI.PS _ _ l1) bs2+      | bs1 `BS.isPrefixOf` bs2 = Just (BSU.unsafeDrop l1 bs2)+      | otherwise = Nothing+#endif++    name = fastStringToByteString $ occNameFS occ++    choose_ns :: Name -> Name -> Name+    choose_ns tc dc+      | isTcClsNameSpace ns   = tc+      | isDataConNameSpace ns = dc+      | otherwise             = pprPanic "tup_name" (ppr occ)+      where ns = occNameSpace occ++    tup_name boxity arity+      = choose_ns (getName (tupleTyCon   boxity arity))+                  (getName (tupleDataCon boxity arity))++mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName+-- No need to cache these, the caching is done in mk_tuple+mkTupleOcc ns Boxed   ar = mkOccName ns (mkBoxedTupleStr   ar)+mkTupleOcc ns Unboxed ar = mkOccName ns (mkUnboxedTupleStr ar)++mkCTupleOcc :: NameSpace -> Arity -> OccName+mkCTupleOcc ns ar = mkOccName ns (mkConstraintTupleStr ar)++mkBoxedTupleStr :: Arity -> String+mkBoxedTupleStr 0  = "()"+mkBoxedTupleStr 1  = "Unit"   -- See Note [One-tuples]+mkBoxedTupleStr ar = '(' : commas ar ++ ")"++mkUnboxedTupleStr :: Arity -> String+mkUnboxedTupleStr 0  = "(##)"+mkUnboxedTupleStr 1  = "Unit#"  -- See Note [One-tuples]+mkUnboxedTupleStr ar = "(#" ++ commas ar ++ "#)"++mkConstraintTupleStr :: Arity -> String+mkConstraintTupleStr 0  = "(%%)"+mkConstraintTupleStr 1  = "Unit%"   -- See Note [One-tuples]+mkConstraintTupleStr ar = "(%" ++ commas ar ++ "%)"++commas :: Arity -> String+commas ar = take (ar-1) (repeat ',')++cTupleTyConName :: Arity -> Name+cTupleTyConName arity+  = mkExternalName (mkCTupleTyConUnique arity) gHC_CLASSES+                   (mkCTupleOcc tcName arity) noSrcSpan++cTupleTyConNames :: [Name]+cTupleTyConNames = map cTupleTyConName (0 : [2..mAX_CTUPLE_SIZE])++cTupleTyConNameSet :: NameSet+cTupleTyConNameSet = mkNameSet cTupleTyConNames++isCTupleTyConName :: Name -> Bool+-- Use Type.isCTupleClass where possible+isCTupleTyConName n+ = ASSERT2( isExternalName n, ppr n )+   nameModule n == gHC_CLASSES+   && n `elemNameSet` cTupleTyConNameSet++cTupleDataConName :: Arity -> Name+cTupleDataConName arity+  = mkExternalName (mkCTupleDataConUnique arity) gHC_CLASSES+                   (mkCTupleOcc dataName arity) noSrcSpan++cTupleDataConNames :: [Name]+cTupleDataConNames = map cTupleDataConName (0 : [2..mAX_CTUPLE_SIZE])++tupleTyCon :: Boxity -> Arity -> TyCon+tupleTyCon sort i | i > mAX_TUPLE_SIZE = fst (mk_tuple sort i)  -- Build one specially+tupleTyCon Boxed   i = fst (boxedTupleArr   ! i)+tupleTyCon Unboxed i = fst (unboxedTupleArr ! i)++tupleTyConName :: TupleSort -> Arity -> Name+tupleTyConName ConstraintTuple a = cTupleTyConName a+tupleTyConName BoxedTuple      a = tyConName (tupleTyCon Boxed a)+tupleTyConName UnboxedTuple    a = tyConName (tupleTyCon Unboxed a)++promotedTupleDataCon :: Boxity -> Arity -> TyCon+promotedTupleDataCon boxity i = promoteDataCon (tupleDataCon boxity i)++tupleDataCon :: Boxity -> Arity -> DataCon+tupleDataCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i)    -- Build one specially+tupleDataCon Boxed   i = snd (boxedTupleArr   ! i)+tupleDataCon Unboxed i = snd (unboxedTupleArr ! i)++boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon)+boxedTupleArr   = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed   i | i <- [0..mAX_TUPLE_SIZE]]+unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]]++-- | Given the TupleRep/SumRep tycon and list of RuntimeReps of the unboxed+-- tuple/sum arguments, produces the return kind of an unboxed tuple/sum type+-- constructor. @unboxedTupleSumKind [IntRep, LiftedRep] --> TYPE (TupleRep/SumRep+-- [IntRep, LiftedRep])@+unboxedTupleSumKind :: TyCon -> [Type] -> Kind+unboxedTupleSumKind tc rr_tys+  = tYPE (mkTyConApp tc [mkPromotedListTy runtimeRepTy rr_tys])++-- | Specialization of 'unboxedTupleSumKind' for tuples+unboxedTupleKind :: [Type] -> Kind+unboxedTupleKind = unboxedTupleSumKind tupleRepDataConTyCon++mk_tuple :: Boxity -> Int -> (TyCon,DataCon)+mk_tuple Boxed arity = (tycon, tuple_con)+  where+    tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tuple_con+                         BoxedTuple flavour++    tc_binders  = mkTemplateAnonTyConBinders (nOfThem arity liftedTypeKind)+    tc_res_kind = liftedTypeKind+    tc_arity    = arity+    flavour     = VanillaAlgTyCon (mkPrelTyConRepName tc_name)++    dc_tvs     = binderVars tc_binders+    dc_arg_tys = mkTyVarTys dc_tvs+    tuple_con  = pcDataCon dc_name dc_tvs dc_arg_tys tycon++    boxity  = Boxed+    modu    = gHC_TUPLE+    tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq+                         (ATyCon tycon) BuiltInSyntax+    dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq+                            (AConLike (RealDataCon tuple_con)) BuiltInSyntax+    tc_uniq = mkTupleTyConUnique   boxity arity+    dc_uniq = mkTupleDataConUnique boxity arity++mk_tuple Unboxed arity = (tycon, tuple_con)+  where+    tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tuple_con+                         UnboxedTuple flavour++    -- See Note [Unboxed tuple RuntimeRep vars] in TyCon+    -- Kind:  forall (k1:RuntimeRep) (k2:RuntimeRep). TYPE k1 -> TYPE k2 -> #+    tc_binders = mkTemplateTyConBinders (nOfThem arity runtimeRepTy)+                                        (\ks -> map tYPE ks)++    tc_res_kind = unboxedTupleKind rr_tys++    tc_arity    = arity * 2+    flavour     = UnboxedAlgTyCon $ Just (mkPrelTyConRepName tc_name)++    dc_tvs               = binderVars tc_binders+    (rr_tys, dc_arg_tys) = splitAt arity (mkTyVarTys dc_tvs)+    tuple_con            = pcDataCon dc_name dc_tvs dc_arg_tys tycon++    boxity  = Unboxed+    modu    = gHC_PRIM+    tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq+                         (ATyCon tycon) BuiltInSyntax+    dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq+                            (AConLike (RealDataCon tuple_con)) BuiltInSyntax+    tc_uniq = mkTupleTyConUnique   boxity arity+    dc_uniq = mkTupleDataConUnique boxity arity++unitTyCon :: TyCon+unitTyCon = tupleTyCon Boxed 0++unitTyConKey :: Unique+unitTyConKey = getUnique unitTyCon++unitDataCon :: DataCon+unitDataCon   = head (tyConDataCons unitTyCon)++unitDataConId :: Id+unitDataConId = dataConWorkId unitDataCon++pairTyCon :: TyCon+pairTyCon = tupleTyCon Boxed 2++unboxedUnitTyCon :: TyCon+unboxedUnitTyCon = tupleTyCon Unboxed 0++unboxedUnitDataCon :: DataCon+unboxedUnitDataCon = tupleDataCon   Unboxed 0+++{- *********************************************************************+*                                                                      *+      Unboxed sums+*                                                                      *+********************************************************************* -}++-- | OccName for n-ary unboxed sum type constructor.+mkSumTyConOcc :: Arity -> OccName+mkSumTyConOcc n = mkOccName tcName str+  where+    -- No need to cache these, the caching is done in mk_sum+    str = '(' : '#' : bars ++ "#)"+    bars = replicate (n-1) '|'++-- | OccName for i-th alternative of n-ary unboxed sum data constructor.+mkSumDataConOcc :: ConTag -> Arity -> OccName+mkSumDataConOcc alt n = mkOccName dataName str+  where+    -- No need to cache these, the caching is done in mk_sum+    str = '(' : '#' : bars alt ++ '_' : bars (n - alt - 1) ++ "#)"+    bars i = replicate i '|'++-- | Type constructor for n-ary unboxed sum.+sumTyCon :: Arity -> TyCon+sumTyCon arity+  | arity > mAX_SUM_SIZE+  = fst (mk_sum arity)  -- Build one specially++  | arity < 2+  = panic ("sumTyCon: Arity starts from 2. (arity: " ++ show arity ++ ")")++  | otherwise+  = fst (unboxedSumArr ! arity)++-- | Data constructor for i-th alternative of a n-ary unboxed sum.+sumDataCon :: ConTag -- Alternative+           -> Arity  -- Arity+           -> DataCon+sumDataCon alt arity+  | alt > arity+  = panic ("sumDataCon: index out of bounds: alt: "+           ++ show alt ++ " > arity " ++ show arity)++  | alt <= 0+  = panic ("sumDataCon: Alts start from 1. (alt: " ++ show alt+           ++ ", arity: " ++ show arity ++ ")")++  | arity < 2+  = panic ("sumDataCon: Arity starts from 2. (alt: " ++ show alt+           ++ ", arity: " ++ show arity ++ ")")++  | arity > mAX_SUM_SIZE+  = snd (mk_sum arity) ! (alt - 1)  -- Build one specially++  | otherwise+  = snd (unboxedSumArr ! arity) ! (alt - 1)++-- | Cached type and data constructors for sums. The outer array is+-- indexed by the arity of the sum and the inner array is indexed by+-- the alternative.+unboxedSumArr :: Array Int (TyCon, Array Int DataCon)+unboxedSumArr = listArray (2,mAX_SUM_SIZE) [mk_sum i | i <- [2..mAX_SUM_SIZE]]++-- | Specialization of 'unboxedTupleSumKind' for sums+unboxedSumKind :: [Type] -> Kind+unboxedSumKind = unboxedTupleSumKind sumRepDataConTyCon++-- | Create type constructor and data constructors for n-ary unboxed sum.+mk_sum :: Arity -> (TyCon, Array ConTagZ DataCon)+mk_sum arity = (tycon, sum_cons)+  where+    tycon   = mkSumTyCon tc_name tc_binders tc_res_kind (arity * 2) tyvars (elems sum_cons)+                         (UnboxedAlgTyCon rep_name)++    -- Unboxed sums are currently not Typeable due to efficiency concerns. See #13276.+    rep_name = Nothing -- Just $ mkPrelTyConRepName tc_name++    tc_binders = mkTemplateTyConBinders (nOfThem arity runtimeRepTy)+                                        (\ks -> map tYPE ks)++    tyvars = binderVars tc_binders++    tc_res_kind = unboxedSumKind rr_tys++    (rr_tys, tyvar_tys) = splitAt arity (mkTyVarTys tyvars)++    tc_name = mkWiredInName gHC_PRIM (mkSumTyConOcc arity) tc_uniq+                            (ATyCon tycon) BuiltInSyntax++    sum_cons = listArray (0,arity-1) [sum_con i | i <- [0..arity-1]]+    sum_con i = let dc = pcDataCon dc_name+                                   tyvars -- univ tyvars+                                   [tyvar_tys !! i] -- arg types+                                   tycon++                    dc_name = mkWiredInName gHC_PRIM+                                            (mkSumDataConOcc i arity)+                                            (dc_uniq i)+                                            (AConLike (RealDataCon dc))+                                            BuiltInSyntax+                in dc++    tc_uniq   = mkSumTyConUnique   arity+    dc_uniq i = mkSumDataConUnique i arity++{-+************************************************************************+*                                                                      *+              Equality types and classes+*                                                                      *+********************************************************************* -}++-- See Note [The equality types story] in TysPrim+-- (:~~: :: forall k1 k2 (a :: k1) (b :: k2). a -> b -> Constraint)+--+-- It's tempting to put functional dependencies on (~~), but it's not+-- necessary because the functional-dependency coverage check looks+-- through superclasses, and (~#) is handled in that check.++heqTyCon, coercibleTyCon :: TyCon+heqClass, coercibleClass :: Class+heqDataCon, coercibleDataCon :: DataCon+heqSCSelId, coercibleSCSelId :: Id++(heqTyCon, heqClass, heqDataCon, heqSCSelId)+  = (tycon, klass, datacon, sc_sel_id)+  where+    tycon     = mkClassTyCon heqTyConName binders roles+                             rhs klass+                             (mkPrelTyConRepName heqTyConName)+    klass     = mk_class tycon sc_pred sc_sel_id+    datacon   = pcDataCon heqDataConName tvs [sc_pred] tycon++    -- Kind: forall k1 k2. k1 -> k2 -> Constraint+    binders   = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] (\ks -> ks)+    roles     = [Nominal, Nominal, Nominal, Nominal]+    rhs       = DataTyCon { data_cons = [datacon], is_enum = False }++    tvs       = binderVars binders+    sc_pred   = mkTyConApp eqPrimTyCon (mkTyVarTys tvs)+    sc_sel_id = mkDictSelId heqSCSelIdName klass++(coercibleTyCon, coercibleClass, coercibleDataCon, coercibleSCSelId)+  = (tycon, klass, datacon, sc_sel_id)+  where+    tycon     = mkClassTyCon coercibleTyConName binders roles+                             rhs klass+                             (mkPrelTyConRepName coercibleTyConName)+    klass     = mk_class tycon sc_pred sc_sel_id+    datacon   = pcDataCon coercibleDataConName tvs [sc_pred] tycon++    -- Kind: forall k. k -> k -> Constraint+    binders   = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k])+    roles     = [Nominal, Representational, Representational]+    rhs       = DataTyCon { data_cons = [datacon], is_enum = False }++    tvs@[k,a,b] = binderVars binders+    sc_pred     = mkTyConApp eqReprPrimTyCon (mkTyVarTys [k, k, a, b])+    sc_sel_id   = mkDictSelId coercibleSCSelIdName klass++mk_class :: TyCon -> PredType -> Id -> Class+mk_class tycon sc_pred sc_sel_id+  = mkClass (tyConName tycon) (tyConTyVars tycon) [] [sc_pred] [sc_sel_id]+            [] [] (mkAnd []) tycon++{- *********************************************************************+*                                                                      *+                Kinds and RuntimeRep+*                                                                      *+********************************************************************* -}++-- For information about the usage of the following type,+-- see Note [TYPE and RuntimeRep] in module TysPrim+runtimeRepTy :: Type+runtimeRepTy = mkTyConTy runtimeRepTyCon++liftedTypeKindTyCon, starKindTyCon, unicodeStarKindTyCon :: TyCon++-- Type syononyms; see Note [TYPE and RuntimeRep] in TysPrim+-- type Type = tYPE 'LiftedRep+-- type *    = tYPE 'LiftedRep+-- type *    = tYPE 'LiftedRep  -- Unicode variant++liftedTypeKindTyCon   = buildSynTyCon liftedTypeKindTyConName+                                       [] liftedTypeKind []+                                       (tYPE liftedRepTy)++starKindTyCon         = buildSynTyCon starKindTyConName+                                       [] liftedTypeKind []+                                       (tYPE liftedRepTy)++unicodeStarKindTyCon  = buildSynTyCon unicodeStarKindTyConName+                                       [] liftedTypeKind []+                                       (tYPE liftedRepTy)++runtimeRepTyCon :: TyCon+runtimeRepTyCon = pcNonEnumTyCon runtimeRepTyConName Nothing []+                          (vecRepDataCon : tupleRepDataCon :+                           sumRepDataCon : runtimeRepSimpleDataCons)++vecRepDataCon :: DataCon+vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon+                                                   , mkTyConTy vecElemTyCon ]+                                 runtimeRepTyCon+                                 (RuntimeRep prim_rep_fun)+  where+    prim_rep_fun [count, elem]+      | VecCount n <- tyConRuntimeRepInfo (tyConAppTyCon count)+      , VecElem  e <- tyConRuntimeRepInfo (tyConAppTyCon elem)+      = [VecRep n e]+    prim_rep_fun args+      = pprPanic "vecRepDataCon" (ppr args)++vecRepDataConTyCon :: TyCon+vecRepDataConTyCon = promoteDataCon vecRepDataCon++tupleRepDataCon :: DataCon+tupleRepDataCon = pcSpecialDataCon tupleRepDataConName [ mkListTy runtimeRepTy ]+                                   runtimeRepTyCon (RuntimeRep prim_rep_fun)+  where+    prim_rep_fun [rr_ty_list]+      = concatMap (runtimeRepPrimRep doc) rr_tys+      where+        rr_tys = extractPromotedList rr_ty_list+        doc    = text "tupleRepDataCon" <+> ppr rr_tys+    prim_rep_fun args+      = pprPanic "tupleRepDataCon" (ppr args)++tupleRepDataConTyCon :: TyCon+tupleRepDataConTyCon = promoteDataCon tupleRepDataCon++sumRepDataCon :: DataCon+sumRepDataCon = pcSpecialDataCon sumRepDataConName [ mkListTy runtimeRepTy ]+                                 runtimeRepTyCon (RuntimeRep prim_rep_fun)+  where+    prim_rep_fun [rr_ty_list]+      = map slotPrimRep (ubxSumRepType prim_repss)+      where+        rr_tys     = extractPromotedList rr_ty_list+        doc        = text "sumRepDataCon" <+> ppr rr_tys+        prim_repss = map (runtimeRepPrimRep doc) rr_tys+    prim_rep_fun args+      = pprPanic "sumRepDataCon" (ppr args)++sumRepDataConTyCon :: TyCon+sumRepDataConTyCon = promoteDataCon sumRepDataCon++-- See Note [Wiring in RuntimeRep]+runtimeRepSimpleDataCons :: [DataCon]+liftedRepDataCon :: DataCon+runtimeRepSimpleDataCons@(liftedRepDataCon : _)+  = zipWithLazy mk_runtime_rep_dc+    [ LiftedRep, UnliftedRep, IntRep, WordRep, Int64Rep+    , Word64Rep, AddrRep, FloatRep, DoubleRep ]+    runtimeRepSimpleDataConNames+  where+    mk_runtime_rep_dc primrep name+      = pcSpecialDataCon name [] runtimeRepTyCon (RuntimeRep (\_ -> [primrep]))++-- See Note [Wiring in RuntimeRep]+liftedRepDataConTy, unliftedRepDataConTy,+  intRepDataConTy, wordRepDataConTy, int64RepDataConTy,+  word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy :: Type+[liftedRepDataConTy, unliftedRepDataConTy,+   intRepDataConTy, wordRepDataConTy, int64RepDataConTy,+   word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy]+  = map (mkTyConTy . promoteDataCon) runtimeRepSimpleDataCons++vecCountTyCon :: TyCon+vecCountTyCon = pcTyCon True vecCountTyConName Nothing []+                        vecCountDataCons++-- See Note [Wiring in RuntimeRep]+vecCountDataCons :: [DataCon]+vecCountDataCons = zipWithLazy mk_vec_count_dc+                     [ 2, 4, 8, 16, 32, 64 ]+                     vecCountDataConNames+  where+    mk_vec_count_dc n name+      = pcSpecialDataCon name [] vecCountTyCon (VecCount n)++-- See Note [Wiring in RuntimeRep]+vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,+  vec64DataConTy :: Type+[vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,+  vec64DataConTy] = map (mkTyConTy . promoteDataCon) vecCountDataCons++vecElemTyCon :: TyCon+vecElemTyCon = pcTyCon True vecElemTyConName Nothing [] vecElemDataCons++-- See Note [Wiring in RuntimeRep]+vecElemDataCons :: [DataCon]+vecElemDataCons = zipWithLazy mk_vec_elem_dc+                    [ Int8ElemRep, Int16ElemRep, Int32ElemRep, Int64ElemRep+                    , Word8ElemRep, Word16ElemRep, Word32ElemRep, Word64ElemRep+                    , FloatElemRep, DoubleElemRep ]+                    vecElemDataConNames+  where+    mk_vec_elem_dc elem name+      = pcSpecialDataCon name [] vecElemTyCon (VecElem elem)++-- See Note [Wiring in RuntimeRep]+int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,+  int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy,+  word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy,+  doubleElemRepDataConTy :: Type+[int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,+  int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy,+  word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy,+  doubleElemRepDataConTy] = map (mkTyConTy . promoteDataCon)+                                vecElemDataCons++liftedRepDataConTyCon :: TyCon+liftedRepDataConTyCon = promoteDataCon liftedRepDataCon++-- The type ('LiftedRep)+liftedRepTy :: Type+liftedRepTy = mkTyConTy liftedRepDataConTyCon++{- *********************************************************************+*                                                                      *+     The boxed primitive types: Char, Int, etc+*                                                                      *+********************************************************************* -}++boxingDataCon_maybe :: TyCon -> Maybe DataCon+--    boxingDataCon_maybe Char# = C#+--    boxingDataCon_maybe Int#  = I#+--    ... etc ...+-- See Note [Boxing primitive types]+boxingDataCon_maybe tc+  = lookupNameEnv boxing_constr_env (tyConName tc)++boxing_constr_env :: NameEnv DataCon+boxing_constr_env+  = mkNameEnv [(charPrimTyConName  , charDataCon  )+              ,(intPrimTyConName   , intDataCon   )+              ,(wordPrimTyConName  , wordDataCon  )+              ,(floatPrimTyConName , floatDataCon )+              ,(doublePrimTyConName, doubleDataCon) ]++{- Note [Boxing primitive types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For a handful of primitive types (Int, Char, Word, Flaot, Double),+we can readily box and an unboxed version (Int#, Char# etc) using+the corresponding data constructor.  This is useful in a couple+of places, notably let-floating -}+++charTy :: Type+charTy = mkTyConTy charTyCon++charTyCon :: TyCon+charTyCon   = pcNonEnumTyCon charTyConName+                   (Just (CType NoSourceText Nothing+                                  (NoSourceText,fsLit "HsChar")))+                   [] [charDataCon]+charDataCon :: DataCon+charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon++stringTy :: Type+stringTy = mkListTy charTy -- convenience only++intTy :: Type+intTy = mkTyConTy intTyCon++intTyCon :: TyCon+intTyCon = pcNonEnumTyCon intTyConName+               (Just (CType NoSourceText Nothing (NoSourceText,fsLit "HsInt")))+                 [] [intDataCon]+intDataCon :: DataCon+intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon++wordTy :: Type+wordTy = mkTyConTy wordTyCon++wordTyCon :: TyCon+wordTyCon = pcNonEnumTyCon wordTyConName+            (Just (CType NoSourceText Nothing (NoSourceText, fsLit "HsWord")))+               [] [wordDataCon]+wordDataCon :: DataCon+wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon++word8Ty :: Type+word8Ty = mkTyConTy word8TyCon++word8TyCon :: TyCon+word8TyCon = pcNonEnumTyCon word8TyConName+                      (Just (CType NoSourceText Nothing+                             (NoSourceText, fsLit "HsWord8"))) []+                      [word8DataCon]+word8DataCon :: DataCon+word8DataCon = pcDataCon word8DataConName [] [wordPrimTy] word8TyCon++floatTy :: Type+floatTy = mkTyConTy floatTyCon++floatTyCon :: TyCon+floatTyCon   = pcNonEnumTyCon floatTyConName+                      (Just (CType NoSourceText Nothing+                             (NoSourceText, fsLit "HsFloat"))) []+                      [floatDataCon]+floatDataCon :: DataCon+floatDataCon = pcDataCon         floatDataConName [] [floatPrimTy] floatTyCon++doubleTy :: Type+doubleTy = mkTyConTy doubleTyCon++doubleTyCon :: TyCon+doubleTyCon = pcNonEnumTyCon doubleTyConName+                      (Just (CType NoSourceText Nothing+                             (NoSourceText,fsLit "HsDouble"))) []+                      [doubleDataCon]++doubleDataCon :: DataCon+doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon++{-+************************************************************************+*                                                                      *+              The Bool type+*                                                                      *+************************************************************************++An ordinary enumeration type, but deeply wired in.  There are no+magical operations on @Bool@ (just the regular Prelude code).++{\em BEGIN IDLE SPECULATION BY SIMON}++This is not the only way to encode @Bool@.  A more obvious coding makes+@Bool@ just a boxed up version of @Bool#@, like this:+\begin{verbatim}+type Bool# = Int#+data Bool = MkBool Bool#+\end{verbatim}++Unfortunately, this doesn't correspond to what the Report says @Bool@+looks like!  Furthermore, we get slightly less efficient code (I+think) with this coding. @gtInt@ would look like this:++\begin{verbatim}+gtInt :: Int -> Int -> Bool+gtInt x y = case x of I# x# ->+            case y of I# y# ->+            case (gtIntPrim x# y#) of+                b# -> MkBool b#+\end{verbatim}++Notice that the result of the @gtIntPrim@ comparison has to be turned+into an integer (here called @b#@), and returned in a @MkBool@ box.++The @if@ expression would compile to this:+\begin{verbatim}+case (gtInt x y) of+  MkBool b# -> case b# of { 1# -> e1; 0# -> e2 }+\end{verbatim}++I think this code is a little less efficient than the previous code,+but I'm not certain.  At all events, corresponding with the Report is+important.  The interesting thing is that the language is expressive+enough to describe more than one alternative; and that a type doesn't+necessarily need to be a straightforwardly boxed version of its+primitive counterpart.++{\em END IDLE SPECULATION BY SIMON}+-}++boolTy :: Type+boolTy = mkTyConTy boolTyCon++boolTyCon :: TyCon+boolTyCon = pcTyCon True boolTyConName+                    (Just (CType NoSourceText Nothing+                           (NoSourceText, fsLit "HsBool")))+                    [] [falseDataCon, trueDataCon]++falseDataCon, trueDataCon :: DataCon+falseDataCon = pcDataCon falseDataConName [] [] boolTyCon+trueDataCon  = pcDataCon trueDataConName  [] [] boolTyCon++falseDataConId, trueDataConId :: Id+falseDataConId = dataConWorkId falseDataCon+trueDataConId  = dataConWorkId trueDataCon++orderingTyCon :: TyCon+orderingTyCon = pcTyCon True orderingTyConName Nothing+                        [] [ltDataCon, eqDataCon, gtDataCon]++ltDataCon, eqDataCon, gtDataCon :: DataCon+ltDataCon = pcDataCon ltDataConName  [] [] orderingTyCon+eqDataCon = pcDataCon eqDataConName  [] [] orderingTyCon+gtDataCon = pcDataCon gtDataConName  [] [] orderingTyCon++ltDataConId, eqDataConId, gtDataConId :: Id+ltDataConId = dataConWorkId ltDataCon+eqDataConId = dataConWorkId eqDataCon+gtDataConId = dataConWorkId gtDataCon++{-+************************************************************************+*                                                                      *+            The List type+   Special syntax, deeply wired in,+   but otherwise an ordinary algebraic data type+*                                                                      *+************************************************************************++       data [] a = [] | a : (List a)+-}++mkListTy :: Type -> Type+mkListTy ty = mkTyConApp listTyCon [ty]++listTyCon :: TyCon+listTyCon = buildAlgTyCon listTyConName alpha_tyvar [Representational]+                          Nothing []+                          (DataTyCon [nilDataCon, consDataCon] False )+                          False+                          (VanillaAlgTyCon $ mkPrelTyConRepName listTyConName)++nilDataCon :: DataCon+nilDataCon  = pcDataCon nilDataConName alpha_tyvar [] listTyCon++consDataCon :: DataCon+consDataCon = pcDataConWithFixity True {- Declared infix -}+               consDataConName+               alpha_tyvar [] [alphaTy, mkTyConApp listTyCon alpha_ty] listTyCon+-- Interesting: polymorphic recursion would help here.+-- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy+-- gets the over-specific type (Type -> Type)++-- Wired-in type Maybe++maybeTyCon :: TyCon+maybeTyCon = pcTyCon False maybeTyConName Nothing alpha_tyvar+                     [nothingDataCon, justDataCon]++nothingDataCon :: DataCon+nothingDataCon = pcDataCon nothingDataConName alpha_tyvar [] maybeTyCon++justDataCon :: DataCon+justDataCon = pcDataCon justDataConName alpha_tyvar [alphaTy] maybeTyCon++{-+** *********************************************************************+*                                                                      *+            The tuple types+*                                                                      *+************************************************************************++The tuple types are definitely magic, because they form an infinite+family.++\begin{itemize}+\item+They have a special family of type constructors, of type @TyCon@+These contain the tycon arity, but don't require a Unique.++\item+They have a special family of constructors, of type+@Id@. Again these contain their arity but don't need a Unique.++\item+There should be a magic way of generating the info tables and+entry code for all tuples.++But at the moment we just compile a Haskell source+file\srcloc{lib/prelude/...} containing declarations like:+\begin{verbatim}+data Tuple0             = Tup0+data Tuple2  a b        = Tup2  a b+data Tuple3  a b c      = Tup3  a b c+data Tuple4  a b c d    = Tup4  a b c d+...+\end{verbatim}+The print-names associated with the magic @Id@s for tuple constructors+``just happen'' to be the same as those generated by these+declarations.++\item+The instance environment should have a magic way to know+that each tuple type is an instances of classes @Eq@, @Ix@, @Ord@ and+so on. \ToDo{Not implemented yet.}++\item+There should also be a way to generate the appropriate code for each+of these instances, but (like the info tables and entry code) it is+done by enumeration\srcloc{lib/prelude/InTup?.hs}.+\end{itemize}+-}++-- | Make a tuple type. The list of types should /not/ include any+-- RuntimeRep specifications.+mkTupleTy :: Boxity -> [Type] -> Type+-- Special case for *boxed* 1-tuples, which are represented by the type itself+mkTupleTy Boxed   [ty] = ty+mkTupleTy Boxed   tys  = mkTyConApp (tupleTyCon Boxed (length tys)) tys+mkTupleTy Unboxed tys  = mkTyConApp (tupleTyCon Unboxed (length tys))+                                        (map (getRuntimeRep "mkTupleTy") tys ++ tys)++-- | Build the type of a small tuple that holds the specified type of thing+mkBoxedTupleTy :: [Type] -> Type+mkBoxedTupleTy tys = mkTupleTy Boxed tys++unitTy :: Type+unitTy = mkTupleTy Boxed []++{- *********************************************************************+*                                                                      *+            The sum types+*                                                                      *+************************************************************************+-}++mkSumTy :: [Type] -> Type+mkSumTy tys = mkTyConApp (sumTyCon (length tys))+                         (map (getRuntimeRep "mkSumTy") tys ++ tys)++{- *********************************************************************+*                                                                      *+        The parallel-array type,  [::]+*                                                                      *+************************************************************************++Special syntax for parallel arrays needs some wired in definitions.+-}++-- | Construct a type representing the application of the parallel array constructor+mkPArrTy    :: Type -> Type+mkPArrTy ty  = mkTyConApp parrTyCon [ty]++-- | Represents the type constructor of parallel arrays+--+--  * This must match the definition in @PrelPArr@+--+-- NB: Although the constructor is given here, it will not be accessible in+--     user code as it is not in the environment of any compiled module except+--     @PrelPArr@.+--+parrTyCon :: TyCon+parrTyCon  = pcNonEnumTyCon parrTyConName Nothing alpha_tyvar [parrDataCon]++parrDataCon :: DataCon+parrDataCon  = pcDataCon+                 parrDataConName+                 alpha_tyvar            -- forall'ed type variables+                 [intTy,                -- 1st argument: Int+                  mkTyConApp            -- 2nd argument: Array# a+                    arrayPrimTyCon+                    alpha_ty]+                 parrTyCon++-- | Check whether a type constructor is the constructor for parallel arrays+isPArrTyCon    :: TyCon -> Bool+isPArrTyCon tc  = tyConName tc == parrTyConName++-- | Fake array constructors+--+-- * These constructors are never really used to represent array values;+--   however, they are very convenient during desugaring (and, in particular,+--   in the pattern matching compiler) to treat array pattern just like+--   yet another constructor pattern+--+parrFakeCon                        :: Arity -> DataCon+parrFakeCon i | i > mAX_TUPLE_SIZE  = mkPArrFakeCon  i  -- build one specially+parrFakeCon i                       = parrFakeConArr!i++-- pre-defined set of constructors+--+parrFakeConArr :: Array Int DataCon+parrFakeConArr  = array (0, mAX_TUPLE_SIZE) [(i, mkPArrFakeCon i)+                                            | i <- [0..mAX_TUPLE_SIZE]]++-- build a fake parallel array constructor for the given arity+--+mkPArrFakeCon       :: Int -> DataCon+mkPArrFakeCon arity  = data_con+  where+        data_con  = pcDataCon name [tyvar] tyvarTys parrTyCon+        tyvar     = head alphaTyVars+        tyvarTys  = replicate arity $ mkTyVarTy tyvar+        nameStr   = mkFastString ("MkPArr" ++ show arity)+        name      = mkWiredInName gHC_PARR' (mkDataOccFS nameStr) unique+                                  (AConLike (RealDataCon data_con)) UserSyntax+        unique      = mkPArrDataConUnique arity++-- | Checks whether a data constructor is a fake constructor for parallel arrays+isPArrFakeCon      :: DataCon -> Bool+isPArrFakeCon dcon  = dcon == parrFakeCon (dataConSourceArity dcon)++-- Promoted Booleans++promotedFalseDataCon, promotedTrueDataCon :: TyCon+promotedTrueDataCon   = promoteDataCon trueDataCon+promotedFalseDataCon  = promoteDataCon falseDataCon++-- Promoted Maybe+promotedNothingDataCon, promotedJustDataCon :: TyCon+promotedNothingDataCon = promoteDataCon nothingDataCon+promotedJustDataCon    = promoteDataCon justDataCon++-- Promoted Ordering++promotedLTDataCon+  , promotedEQDataCon+  , promotedGTDataCon+  :: TyCon+promotedLTDataCon     = promoteDataCon ltDataCon+promotedEQDataCon     = promoteDataCon eqDataCon+promotedGTDataCon     = promoteDataCon gtDataCon++-- Promoted List+promotedConsDataCon, promotedNilDataCon :: TyCon+promotedConsDataCon   = promoteDataCon consDataCon+promotedNilDataCon    = promoteDataCon nilDataCon++-- | Make a *promoted* list.+mkPromotedListTy :: Kind   -- ^ of the elements of the list+                 -> [Type] -- ^ elements+                 -> Type+mkPromotedListTy k tys+  = foldr cons nil tys+  where+    cons :: Type  -- element+         -> Type  -- list+         -> Type+    cons elt list = mkTyConApp promotedConsDataCon [k, elt, list]++    nil :: Type+    nil = mkTyConApp promotedNilDataCon [k]++-- | Extract the elements of a promoted list. Panics if the type is not a+-- promoted list+extractPromotedList :: Type    -- ^ The promoted list+                    -> [Type]+extractPromotedList tys = go tys+  where+    go list_ty+      | Just (tc, [_k, t, ts]) <- splitTyConApp_maybe list_ty+      = ASSERT( tc `hasKey` consDataConKey )+        t : go ts++      | Just (tc, [_k]) <- splitTyConApp_maybe list_ty+      = ASSERT( tc `hasKey` nilDataConKey )+        []++      | otherwise+      = pprPanic "extractPromotedList" (ppr tys)
+ prelude/TysWiredIn.hs-boot view
@@ -0,0 +1,37 @@+module TysWiredIn where++import Var( TyVar, ArgFlag )+import {-# SOURCE #-} TyCon      ( TyCon )+import {-# SOURCE #-} TyCoRep    (Type, Kind)+++mkFunKind :: Kind -> Kind -> Kind+mkForAllKind :: TyVar -> ArgFlag -> Kind -> Kind++listTyCon :: TyCon+typeNatKind, typeSymbolKind :: Type+mkBoxedTupleTy :: [Type] -> Type++liftedTypeKind :: Kind+constraintKind :: Kind++runtimeRepTyCon, vecCountTyCon, vecElemTyCon :: TyCon+runtimeRepTy :: Type++liftedRepDataConTyCon, vecRepDataConTyCon, tupleRepDataConTyCon :: TyCon++liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy,+  wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy,+  floatRepDataConTy, doubleRepDataConTy :: Type++vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,+  vec64DataConTy :: Type++int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,+  int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy,+  word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy,+  doubleElemRepDataConTy :: Type++anyTypeOfKind :: Kind -> Type+unboxedTupleKind :: [Type] -> Type+mkPromotedListTy :: Type -> [Type] -> Type
+ profiling/CostCentre.hs view
@@ -0,0 +1,326 @@+{-# LANGUAGE DeriveDataTypeable #-}+module CostCentre (+        CostCentre(..), CcName, IsCafCC(..),+                -- All abstract except to friend: ParseIface.y++        CostCentreStack,+        CollectedCCs,+        noCCS, currentCCS, dontCareCCS,+        noCCSAttached, isCurrentCCS,+        maybeSingletonCCS,++        mkUserCC, mkAutoCC, mkAllCafsCC,+        mkSingletonCCS,+        isCafCCS, isCafCC, isSccCountCC, sccAbleCC, ccFromThisModule,++        pprCostCentreCore,+        costCentreUserName, costCentreUserNameFS,+        costCentreSrcSpan,++        cmpCostCentre   -- used for removing dups in a list+    ) where++import Binary+import Var+import Name+import Module+import Unique+import Outputable+import SrcLoc+import FastString+import Util++import Data.Data++-----------------------------------------------------------------------------+-- Cost Centres++-- | A Cost Centre is a single @{-# SCC #-}@ annotation.++data CostCentre+  = NormalCC {+                cc_key  :: {-# UNPACK #-} !Int,+                 -- ^ Two cost centres may have the same name and+                 -- module but different SrcSpans, so we need a way to+                 -- distinguish them easily and give them different+                 -- object-code labels.  So every CostCentre has a+                 -- Unique that is distinct from every other+                 -- CostCentre in the same module.+                 --+                 -- XXX: should really be using Unique here, but we+                 -- need to derive Data below and there's no Data+                 -- instance for Unique.+                cc_name :: CcName,      -- ^ Name of the cost centre itself+                cc_mod  :: Module,      -- ^ Name of module defining this CC.+                cc_loc  :: SrcSpan,+                cc_is_caf  :: IsCafCC   -- see below+    }++  | AllCafsCC {+                cc_mod  :: Module,      -- Name of module defining this CC.+                cc_loc  :: SrcSpan+    }+  deriving Data++type CcName = FastString++data IsCafCC = NotCafCC | CafCC+  deriving (Eq, Ord, Data)+++instance Eq CostCentre where+        c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }++instance Ord CostCentre where+        compare = cmpCostCentre++cmpCostCentre :: CostCentre -> CostCentre -> Ordering++cmpCostCentre (AllCafsCC  {cc_mod = m1}) (AllCafsCC  {cc_mod = m2})+  = m1 `compare` m2++cmpCostCentre NormalCC {cc_key = n1, cc_mod =  m1}+              NormalCC {cc_key = n2, cc_mod =  m2}+    -- first key is module name, then the integer key+  = (m1 `compare` m2) `thenCmp` (n1 `compare` n2)++cmpCostCentre other_1 other_2+  = let+        tag1 = tag_CC other_1+        tag2 = tag_CC other_2+    in+    if tag1 < tag2 then LT else GT+  where+    tag_CC :: CostCentre -> Int+    tag_CC (NormalCC   {}) = 0+    tag_CC (AllCafsCC  {}) = 1+++-----------------------------------------------------------------------------+-- Predicates on CostCentre++isCafCC :: CostCentre -> Bool+isCafCC (AllCafsCC {})                 = True+isCafCC (NormalCC {cc_is_caf = CafCC}) = True+isCafCC _                              = False++-- | Is this a cost-centre which records scc counts+isSccCountCC :: CostCentre -> Bool+isSccCountCC cc | isCafCC cc  = False+                | otherwise   = True++-- | Is this a cost-centre which can be sccd ?+sccAbleCC :: CostCentre -> Bool+sccAbleCC cc | isCafCC cc = False+             | otherwise  = True++ccFromThisModule :: CostCentre -> Module -> Bool+ccFromThisModule cc m = cc_mod cc == m+++-----------------------------------------------------------------------------+-- Building cost centres++mkUserCC :: FastString -> Module -> SrcSpan -> Unique -> CostCentre+mkUserCC cc_name mod loc key+  = NormalCC { cc_key = getKey key, cc_name = cc_name, cc_mod =  mod, cc_loc = loc,+               cc_is_caf = NotCafCC {-might be changed-}+    }++mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre+mkAutoCC id mod is_caf+  = NormalCC { cc_key = getKey (getUnique id),+               cc_name = str, cc_mod =  mod,+               cc_loc = nameSrcSpan (getName id),+               cc_is_caf = is_caf+    }+  where+        name = getName id+        -- beware: only external names are guaranteed to have unique+        -- Occnames.  If the name is not external, we must append its+        -- Unique.+        -- See bug #249, tests prof001, prof002,  also #2411+        str | isExternalName name = occNameFS (getOccName id)+            | otherwise           = occNameFS (getOccName id)+                                    `appendFS`+                                    mkFastString ('_' : show (getUnique name))+mkAllCafsCC :: Module -> SrcSpan -> CostCentre+mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc }++-----------------------------------------------------------------------------+-- Cost Centre Stacks++-- | A Cost Centre Stack is something that can be attached to a closure.+-- This is either:+--+--      * the current cost centre stack (CCCS)+--      * a pre-defined cost centre stack (there are several+--        pre-defined CCSs, see below).++data CostCentreStack+  = NoCCS++  | CurrentCCS          -- Pinned on a let(rec)-bound+                        -- thunk/function/constructor, this says that the+                        -- cost centre to be attached to the object, when it+                        -- is allocated, is whatever is in the+                        -- current-cost-centre-stack register.++  | DontCareCCS         -- We need a CCS to stick in static closures+                        -- (for data), but we *don't* expect them to+                        -- accumulate any costs.  But we still need+                        -- the placeholder.  This CCS is it.++  | SingletonCCS CostCentre++  deriving (Eq, Ord)    -- needed for Ord on CLabel+++-- synonym for triple which describes the cost centre info in the generated+-- code for a module.+type CollectedCCs+  = ( [CostCentre]       -- local cost-centres that need to be decl'd+    , [CostCentre]       -- "extern" cost-centres+    , [CostCentreStack]  -- pre-defined "singleton" cost centre stacks+    )+++noCCS, currentCCS, dontCareCCS :: CostCentreStack++noCCS                   = NoCCS+currentCCS              = CurrentCCS+dontCareCCS             = DontCareCCS++-----------------------------------------------------------------------------+-- Predicates on Cost-Centre Stacks++noCCSAttached :: CostCentreStack -> Bool+noCCSAttached NoCCS                     = True+noCCSAttached _                         = False++isCurrentCCS :: CostCentreStack -> Bool+isCurrentCCS CurrentCCS                 = True+isCurrentCCS _                          = False++isCafCCS :: CostCentreStack -> Bool+isCafCCS (SingletonCCS cc)              = isCafCC cc+isCafCCS _                              = False++maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre+maybeSingletonCCS (SingletonCCS cc)     = Just cc+maybeSingletonCCS _                     = Nothing++mkSingletonCCS :: CostCentre -> CostCentreStack+mkSingletonCCS cc = SingletonCCS cc+++-----------------------------------------------------------------------------+-- Printing Cost Centre Stacks.++-- The outputable instance for CostCentreStack prints the CCS as a C+-- expression.++instance Outputable CostCentreStack where+  ppr NoCCS             = text "NO_CCS"+  ppr CurrentCCS        = text "CCCS"+  ppr DontCareCCS       = text "CCS_DONT_CARE"+  ppr (SingletonCCS cc) = ppr cc <> text "_ccs"+++-----------------------------------------------------------------------------+-- Printing Cost Centres+--+-- There are several different ways in which we might want to print a+-- cost centre:+--+--      - the name of the cost centre, for profiling output (a C string)+--      - the label, i.e. C label for cost centre in .hc file.+--      - the debugging name, for output in -ddump things+--      - the interface name, for printing in _scc_ exprs in iface files.+--+-- The last 3 are derived from costCentreStr below.  The first is given+-- by costCentreName.++instance Outputable CostCentre where+  ppr cc = getPprStyle $ \ sty ->+           if codeStyle sty+           then ppCostCentreLbl cc+           else text (costCentreUserName cc)++-- Printing in Core+pprCostCentreCore :: CostCentre -> SDoc+pprCostCentreCore (AllCafsCC {cc_mod = m})+  = text "__sccC" <+> braces (ppr m)+pprCostCentreCore (NormalCC {cc_key = key, cc_name = n, cc_mod = m, cc_loc = loc,+                             cc_is_caf = caf})+  = text "__scc" <+> braces (hsep [+        ppr m <> char '.' <> ftext n,+        ifPprDebug (ppr key),+        pp_caf caf,+        ifPprDebug (ppr loc)+    ])++pp_caf :: IsCafCC -> SDoc+pp_caf CafCC = text "__C"+pp_caf _     = empty++-- Printing as a C label+ppCostCentreLbl :: CostCentre -> SDoc+ppCostCentreLbl (AllCafsCC  {cc_mod = m}) = ppr m <> text "_CAFs_cc"+ppCostCentreLbl (NormalCC {cc_key = k, cc_name = n, cc_mod = m,+                           cc_is_caf = is_caf})+  = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <>+        case is_caf of { CafCC -> text "CAF"; _ -> ppr (mkUniqueGrimily k)} <> text "_cc"++-- This is the name to go in the user-displayed string,+-- recorded in the cost centre declaration+costCentreUserName :: CostCentre -> String+costCentreUserName = unpackFS . costCentreUserNameFS++costCentreUserNameFS :: CostCentre -> FastString+costCentreUserNameFS (AllCafsCC {})  = mkFastString "CAF"+costCentreUserNameFS (NormalCC {cc_name = name, cc_is_caf = is_caf})+  =  case is_caf of+      CafCC -> mkFastString "CAF:" `appendFS` name+      _     -> name++costCentreSrcSpan :: CostCentre -> SrcSpan+costCentreSrcSpan = cc_loc++instance Binary IsCafCC where+    put_ bh CafCC = do+            putByte bh 0+    put_ bh NotCafCC = do+            putByte bh 1+    get bh = do+            h <- getByte bh+            case h of+              0 -> do return CafCC+              _ -> do return NotCafCC++instance Binary CostCentre where+    put_ bh (NormalCC aa ab ac _ad ae) = do+            putByte bh 0+            put_ bh aa+            put_ bh ab+            put_ bh ac+            put_ bh ae+    put_ bh (AllCafsCC ae _af) = do+            putByte bh 1+            put_ bh ae+    get bh = do+            h <- getByte bh+            case h of+              0 -> do aa <- get bh+                      ab <- get bh+                      ac <- get bh+                      ae <- get bh+                      return (NormalCC aa ab ac noSrcSpan ae)+              _ -> do ae <- get bh+                      return (AllCafsCC ae noSrcSpan)++    -- We ignore the SrcSpans in CostCentres when we serialise them,+    -- and set the SrcSpans to noSrcSpan when deserialising.  This is+    -- ok, because we only need the SrcSpan when declaring the+    -- CostCentre in the original module, it is not used by importing+    -- modules.
+ profiling/ProfInit.hs view
@@ -0,0 +1,46 @@+-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow, 2011+--+-- Generate code to initialise cost centres+--+-- -----------------------------------------------------------------------------++module ProfInit (profilingInitCode) where++import CLabel+import CostCentre+import DynFlags+import Outputable+import FastString+import Module++-- -----------------------------------------------------------------------------+-- Initialising cost centres++-- We must produce declarations for the cost-centres defined in this+-- module;++profilingInitCode :: Module -> CollectedCCs -> SDoc+profilingInitCode this_mod (local_CCs, ___extern_CCs, singleton_CCSs)+ = sdocWithDynFlags $ \dflags ->+   if not (gopt Opt_SccProfilingOn dflags)+   then empty+   else vcat+    [ text "static void prof_init_" <> ppr this_mod+         <> text "(void) __attribute__((constructor));"+    , text "static void prof_init_" <> ppr this_mod <> text "(void)"+    , braces (vcat (+         map emitRegisterCC           local_CCs +++         map emitRegisterCCS          singleton_CCSs+       ))+    ]+ where+   emitRegisterCC cc   =+      text "extern CostCentre " <> cc_lbl <> ptext (sLit "[];") $$+      text "REGISTER_CC(" <> cc_lbl <> char ')' <> semi+     where cc_lbl = ppr (mkCCLabel cc)+   emitRegisterCCS ccs =+      text "extern CostCentreStack " <> ccs_lbl <> ptext (sLit "[];") $$+      text "REGISTER_CCS(" <> ccs_lbl <> char ')' <> semi+     where ccs_lbl = ppr (mkCCSLabel ccs)
+ profiling/SCCfinal.hs view
@@ -0,0 +1,285 @@+-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+-- Modify and collect code generation for final STG program++{-+ This is now a sort-of-normal STG-to-STG pass (WDP 94/06), run by stg2stg.++  - Traverses the STG program collecting the cost centres. These are required+    to declare the cost centres at the start of code generation.++    Note: because of cross-module unfolding, some of these cost centres may be+    from other modules.++  - Puts on CAF cost-centres if the user has asked for individual CAF+    cost-centres.+-}++module SCCfinal ( stgMassageForProfiling ) where++#include "HsVersions.h"++import StgSyn++import CostCentre       -- lots of things+import Id+import Name+import Module+import UniqSupply       ( UniqSupply )+import ListSetOps       ( removeDups )+import Outputable+import DynFlags+import CoreSyn          ( Tickish(..) )+import FastString+import SrcLoc+import Util++import Control.Monad (liftM, ap)++stgMassageForProfiling+        :: DynFlags+        -> Module                       -- module name+        -> UniqSupply                   -- unique supply+        -> [StgTopBinding]              -- input+        -> (CollectedCCs, [StgTopBinding])++stgMassageForProfiling dflags mod_name _us stg_binds+  = let+        ((local_ccs, extern_ccs, cc_stacks),+         stg_binds2)+          = initMM mod_name (do_top_bindings stg_binds)++        (fixed_ccs, fixed_cc_stacks)+          = if gopt Opt_AutoSccsOnIndividualCafs dflags+            then ([],[])  -- don't need "all CAFs" CC+            else ([all_cafs_cc], [all_cafs_ccs])++        local_ccs_no_dups  = fst (removeDups cmpCostCentre local_ccs)+        extern_ccs_no_dups = fst (removeDups cmpCostCentre extern_ccs)+    in+    ((fixed_ccs ++ local_ccs_no_dups,+      extern_ccs_no_dups,+      fixed_cc_stacks ++ cc_stacks), stg_binds2)+  where++    span = mkGeneralSrcSpan (mkFastString "<entire-module>") -- XXX do better+    all_cafs_cc  = mkAllCafsCC mod_name span+    all_cafs_ccs = mkSingletonCCS all_cafs_cc++    ----------+    do_top_bindings :: [StgTopBinding] -> MassageM [StgTopBinding]++    do_top_bindings [] = return []++    do_top_bindings (StgTopLifted (StgNonRec b rhs) : bs) = do+        rhs' <- do_top_rhs b rhs+        bs' <- do_top_bindings bs+        return (StgTopLifted (StgNonRec b rhs') : bs')++    do_top_bindings (StgTopLifted (StgRec pairs) : bs) = do+        pairs2 <- mapM do_pair pairs+        bs' <- do_top_bindings bs+        return (StgTopLifted (StgRec pairs2) : bs')+      where+        do_pair (b, rhs) = do+             rhs2 <- do_top_rhs b rhs+             return (b, rhs2)++    do_top_bindings (b@StgTopStringLit{} : bs) = do+        bs' <- do_top_bindings bs+        return (b : bs')++    ----------+    do_top_rhs :: Id -> StgRhs -> MassageM StgRhs++    do_top_rhs _ (StgRhsClosure _ _ _ _ []+                     (StgTick (ProfNote _cc False{-not tick-} _push)+                              (StgConApp con args _)))+      | not (isDllConApp dflags mod_name con args)+        -- Trivial _scc_ around nothing but static data+        -- Eliminate _scc_ ... and turn into StgRhsCon++        -- isDllConApp checks for LitLit args too+      = return (StgRhsCon dontCareCCS con args)++    do_top_rhs binder (StgRhsClosure _ bi fv u [] body)+      = do+        -- Top level CAF without a cost centre attached+        -- Attach CAF cc (collect if individual CAF ccs)+        caf_ccs <- if gopt Opt_AutoSccsOnIndividualCafs dflags+                   then let cc = mkAutoCC binder modl CafCC+                            ccs = mkSingletonCCS cc+                                   -- careful: the binder might be :Main.main,+                                   -- which doesn't belong to module mod_name.+                                   -- bug #249, tests prof001, prof002+                            modl | Just m <- nameModule_maybe (idName binder) = m+                                 | otherwise = mod_name+                        in do+                        collectNewCC  cc+                        collectCCS ccs+                        return ccs+                   else+                        return all_cafs_ccs+        body' <- do_expr body+        return (StgRhsClosure caf_ccs bi fv u [] body')++    do_top_rhs _ (StgRhsClosure _no_ccs bi fv u args body)+      = do body' <- do_expr body+           return (StgRhsClosure dontCareCCS bi fv u args body')++    do_top_rhs _ (StgRhsCon _ con args)+        -- Top-level (static) data is not counted in heap+        -- profiles; nor do we set CCCS from it; so we+        -- just slam in dontCareCostCentre+      = return (StgRhsCon dontCareCCS con args)++    ------+    do_expr :: StgExpr -> MassageM StgExpr++    do_expr (StgLit l) = return (StgLit l)++    do_expr (StgApp fn args)+      = return (StgApp fn args)++    do_expr (StgConApp con args ty_args)+      = return (StgConApp con args ty_args)++    do_expr (StgOpApp con args res_ty)+      = return (StgOpApp con args res_ty)++    do_expr (StgTick note@(ProfNote cc _ _) expr) = do+        -- Ha, we found a cost centre!+        collectCC cc+        expr' <- do_expr expr+        return (StgTick note expr')++    do_expr (StgTick ti expr) = do+        expr' <- do_expr expr+        return (StgTick ti expr')++    do_expr (StgCase expr bndr alt_type alts) = do+        expr' <- do_expr expr+        alts' <- mapM do_alt alts+        return (StgCase expr' bndr alt_type alts')+      where+        do_alt (id, bs, e) = do+            e' <- do_expr e+            return (id, bs, e')++    do_expr (StgLet b e) = do+          (b,e) <- do_let b e+          return (StgLet b e)++    do_expr (StgLetNoEscape b e) = do+          (b,e) <- do_let b e+          return (StgLetNoEscape b e)++    do_expr other = pprPanic "SCCfinal.do_expr" (ppr other)++    ----------------------------------++    do_let (StgNonRec b rhs) e = do+        rhs' <- do_rhs rhs+        e' <- do_expr e+        return (StgNonRec b rhs',e')++    do_let (StgRec pairs) e = do+        pairs' <- mapM do_pair pairs+        e' <- do_expr e+        return (StgRec pairs', e')+      where+        do_pair (b, rhs) = do+             rhs2 <- do_rhs rhs+             return (b, rhs2)++    ----------------------------------+    do_rhs :: StgRhs -> MassageM StgRhs+        -- We play much the same game as we did in do_top_rhs above;+        -- but we don't have to worry about cafs etc.++        -- throw away the SCC if we don't have to count entries.  This+        -- is a little bit wrong, because we're attributing the+        -- allocation of the constructor to the wrong place (XXX)+        -- We should really attach (PushCC cc CurrentCCS) to the rhs,+        -- but need to reinstate PushCC for that.+    do_rhs (StgRhsClosure _closure_cc _bi _fv _u []+               (StgTick (ProfNote cc False{-not tick-} _push)+                        (StgConApp con args _)))+      = do collectCC cc+           return (StgRhsCon currentCCS con args)++    do_rhs (StgRhsClosure _ bi fv u args expr) = do+        expr' <- do_expr expr+        return (StgRhsClosure currentCCS bi fv u args expr')++    do_rhs (StgRhsCon _ con args)+      = return (StgRhsCon currentCCS con args)+++-- -----------------------------------------------------------------------------+-- Boring monad stuff for this++newtype MassageM result+  = MassageM {+      unMassageM :: Module              -- module name+                 -> CollectedCCs+                 -> (CollectedCCs, result)+    }++instance Functor MassageM where+      fmap = liftM++instance Applicative MassageM where+      pure x = MassageM (\_ ccs -> (ccs, x))+      (<*>) = ap+      (*>) = thenMM_++instance Monad MassageM where+    (>>=) = thenMM+    (>>)  = (*>)++-- the initMM function also returns the final CollectedCCs++initMM :: Module        -- module name, which we may consult+       -> MassageM a+       -> (CollectedCCs, a)++initMM mod_name (MassageM m) = m mod_name ([],[],[])++thenMM  :: MassageM a -> (a -> MassageM b) -> MassageM b+thenMM_ :: MassageM a -> (MassageM b) -> MassageM b++thenMM expr cont = MassageM $ \mod ccs ->+    case unMassageM expr mod ccs of { (ccs2, result) ->+    unMassageM (cont result) mod ccs2 }++thenMM_ expr cont = MassageM $ \mod ccs ->+    case unMassageM expr mod ccs of { (ccs2, _) ->+    unMassageM cont mod ccs2 }+++collectCC :: CostCentre -> MassageM ()+collectCC cc+ = MassageM $ \mod_name (local_ccs, extern_ccs, ccss)+  -> if (cc `ccFromThisModule` mod_name) then+        ((cc : local_ccs, extern_ccs, ccss), ())+     else -- must declare it "extern"+        ((local_ccs, cc : extern_ccs, ccss), ())++-- Version of collectCC used when we definitely want to declare this+-- CC as local, even if its module name is not the same as the current+-- module name (eg. the special :Main module) see bug #249, #1472,+-- test prof001,prof002.+collectNewCC :: CostCentre -> MassageM ()+collectNewCC cc+ = MassageM $ \_mod_name (local_ccs, extern_ccs, ccss)+              -> ((cc : local_ccs, extern_ccs, ccss), ())++collectCCS :: CostCentreStack -> MassageM ()++collectCCS ccs+ = MassageM $ \_mod_name (local_ccs, extern_ccs, ccss)+              -> ASSERT(not (noCCSAttached ccs))+                       ((local_ccs, extern_ccs, ccs : ccss), ())
+ rename/RnBinds.hs view
@@ -0,0 +1,1234 @@+{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}++{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[RnBinds]{Renaming and dependency analysis of bindings}++This module does renaming and dependency analysis on value bindings in+the abstract syntax.  It does {\em not} do cycle-checks on class or+type-synonym declarations; those cannot be done at this stage because+they may be affected by renaming (which isn't fully worked out yet).+-}++module RnBinds (+   -- Renaming top-level bindings+   rnTopBindsLHS, rnTopBindsBoot, rnValBindsRHS,++   -- Renaming local bindings+   rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,++   -- Other bindings+   rnMethodBinds, renameSigs,+   rnMatchGroup, rnGRHSs, rnGRHS,+   makeMiniFixityEnv, MiniFixityEnv,+   HsSigCtxt(..)+   ) where++import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )++import HsSyn+import TcRnMonad+import TcEvidence     ( emptyTcEvBinds )+import RnTypes+import RnPat+import RnNames+import RnEnv+import DynFlags+import Module+import Name+import NameEnv+import NameSet+import RdrName          ( RdrName, rdrNameOcc )+import SrcLoc+import ListSetOps       ( findDupsEq )+import BasicTypes       ( RecFlag(..), LexicalFixity(..) )+import Digraph          ( SCC(..) )+import Bag+import Util+import Outputable+import FastString+import UniqSet+import Maybes           ( orElse )+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Data.List        ( partition, sort )++{-+-- ToDo: Put the annotations into the monad, so that they arrive in the proper+-- place and can be used when complaining.++The code tree received by the function @rnBinds@ contains definitions+in where-clauses which are all apparently mutually recursive, but which may+not really depend upon each other. For example, in the top level program+\begin{verbatim}+f x = y where a = x+              y = x+\end{verbatim}+the definitions of @a@ and @y@ do not depend on each other at all.+Unfortunately, the typechecker cannot always check such definitions.+\footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive+definitions. In Proceedings of the International Symposium on Programming,+Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}+However, the typechecker usually can check definitions in which only the+strongly connected components have been collected into recursive bindings.+This is precisely what the function @rnBinds@ does.++ToDo: deal with case where a single monobinds binds the same variable+twice.++The vertag tag is a unique @Int@; the tags only need to be unique+within one @MonoBinds@, so that unique-Int plumbing is done explicitly+(heavy monad machinery not needed).+++************************************************************************+*                                                                      *+* naming conventions                                                   *+*                                                                      *+************************************************************************++\subsection[name-conventions]{Name conventions}++The basic algorithm involves walking over the tree and returning a tuple+containing the new tree plus its free variables. Some functions, such+as those walking polymorphic bindings (HsBinds) and qualifier lists in+list comprehensions (@Quals@), return the variables bound in local+environments. These are then used to calculate the free variables of the+expression evaluated in these environments.++Conventions for variable names are as follows:+\begin{itemize}+\item+new code is given a prime to distinguish it from the old.++\item+a set of variables defined in @Exp@ is written @dvExp@++\item+a set of variables free in @Exp@ is written @fvExp@+\end{itemize}++************************************************************************+*                                                                      *+* analysing polymorphic bindings (HsBindGroup, HsBind)+*                                                                      *+************************************************************************++\subsubsection[dep-HsBinds]{Polymorphic bindings}++Non-recursive expressions are reconstructed without any changes at top+level, although their component expressions may have to be altered.+However, non-recursive expressions are currently not expected as+\Haskell{} programs, and this code should not be executed.++Monomorphic bindings contain information that is returned in a tuple+(a @FlatMonoBinds@) containing:++\begin{enumerate}+\item+a unique @Int@ that serves as the ``vertex tag'' for this binding.++\item+the name of a function or the names in a pattern. These are a set+referred to as @dvLhs@, the defined variables of the left hand side.++\item+the free variables of the body. These are referred to as @fvBody@.++\item+the definition's actual code. This is referred to as just @code@.+\end{enumerate}++The function @nonRecDvFv@ returns two sets of variables. The first is+the set of variables defined in the set of monomorphic bindings, while the+second is the set of free variables in those bindings.++The set of variables defined in a non-recursive binding is just the+union of all of them, as @union@ removes duplicates. However, the+free variables in each successive set of cumulative bindings is the+union of those in the previous set plus those of the newest binding after+the defined variables of the previous set have been removed.++@rnMethodBinds@ deals only with the declarations in class and+instance declarations.  It expects only to see @FunMonoBind@s, and+it expects the global environment to contain bindings for the binders+(which are all class operations).++************************************************************************+*                                                                      *+\subsubsection{ Top-level bindings}+*                                                                      *+************************************************************************+-}++-- for top-level bindings, we need to make top-level names,+-- so we have a different entry point than for local bindings+rnTopBindsLHS :: MiniFixityEnv+              -> HsValBinds RdrName+              -> RnM (HsValBindsLR Name RdrName)+rnTopBindsLHS fix_env binds+  = rnValBindsLHS (topRecNameMaker fix_env) binds++rnTopBindsBoot :: NameSet -> HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses)+-- A hs-boot file has no bindings.+-- Return a single HsBindGroup with empty binds and renamed signatures+rnTopBindsBoot bound_names (ValBindsIn mbinds sigs)+  = do  { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)+        ; (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs+        ; return (ValBindsOut [] sigs', usesOnly fvs) }+rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b)++{-+*********************************************************+*                                                      *+                HsLocalBinds+*                                                      *+*********************************************************+-}++rnLocalBindsAndThen :: HsLocalBinds RdrName+                    -> (HsLocalBinds Name -> FreeVars -> RnM (result, FreeVars))+                    -> RnM (result, FreeVars)+-- This version (a) assumes that the binding vars are *not* already in scope+--               (b) removes the binders from the free vars of the thing inside+-- The parser doesn't produce ThenBinds+rnLocalBindsAndThen EmptyLocalBinds thing_inside =+  thing_inside EmptyLocalBinds emptyNameSet++rnLocalBindsAndThen (HsValBinds val_binds) thing_inside+  = rnLocalValBindsAndThen val_binds $ \ val_binds' ->+      thing_inside (HsValBinds val_binds')++rnLocalBindsAndThen (HsIPBinds binds) thing_inside = do+    (binds',fv_binds) <- rnIPBinds binds+    (thing, fvs_thing) <- thing_inside (HsIPBinds binds') fv_binds+    return (thing, fvs_thing `plusFV` fv_binds)++rnIPBinds :: HsIPBinds RdrName -> RnM (HsIPBinds Name, FreeVars)+rnIPBinds (IPBinds ip_binds _no_dict_binds) = do+    (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds+    return (IPBinds ip_binds' emptyTcEvBinds, plusFVs fvs_s)++rnIPBind :: IPBind RdrName -> RnM (IPBind Name, FreeVars)+rnIPBind (IPBind ~(Left n) expr) = do+    (expr',fvExpr) <- rnLExpr expr+    return (IPBind (Left n) expr', fvExpr)++{-+************************************************************************+*                                                                      *+                ValBinds+*                                                                      *+************************************************************************+-}++-- Renaming local binding groups+-- Does duplicate/shadow check+rnLocalValBindsLHS :: MiniFixityEnv+                   -> HsValBinds RdrName+                   -> RnM ([Name], HsValBindsLR Name RdrName)+rnLocalValBindsLHS fix_env binds+  = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds++         -- Check for duplicates and shadowing+         -- Must do this *after* renaming the patterns+         -- See Note [Collect binders only after renaming] in HsUtils++         -- We need to check for dups here because we+         -- don't don't bind all of the variables from the ValBinds at once+         -- with bindLocatedLocals any more.+         --+         -- Note that we don't want to do this at the top level, since+         -- sorting out duplicates and shadowing there happens elsewhere.+         -- The behavior is even different. For example,+         --   import A(f)+         --   f = ...+         -- should not produce a shadowing warning (but it will produce+         -- an ambiguity warning if you use f), but+         --   import A(f)+         --   g = let f = ... in f+         -- should.+       ; let bound_names = collectHsValBinders binds'+             -- There should be only Ids, but if there are any bogus+             -- pattern synonyms, we'll collect them anyway, so that+             -- we don't generate subsequent out-of-scope messages+       ; envs <- getRdrEnvs+       ; checkDupAndShadowedNames envs bound_names++       ; return (bound_names, binds') }++-- renames the left-hand sides+-- generic version used both at the top level and for local binds+-- does some error checking, but not what gets done elsewhere at the top level+rnValBindsLHS :: NameMaker+              -> HsValBinds RdrName+              -> RnM (HsValBindsLR Name RdrName)+rnValBindsLHS topP (ValBindsIn mbinds sigs)+  = do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds+       ; return $ ValBindsIn mbinds' sigs }+  where+    bndrs = collectHsBindsBinders mbinds+    doc   = text "In the binding group for:" <+> pprWithCommas ppr bndrs++rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b)++-- General version used both from the top-level and for local things+-- Assumes the LHS vars are in scope+--+-- Does not bind the local fixity declarations+rnValBindsRHS :: HsSigCtxt+              -> HsValBindsLR Name RdrName+              -> RnM (HsValBinds Name, DefUses)++rnValBindsRHS ctxt (ValBindsIn mbinds sigs)+  = do { (sigs', sig_fvs) <- renameSigs ctxt sigs+       ; binds_w_dus <- mapBagM (rnLBind (mkSigTvFn sigs')) mbinds+       ; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus++       ; let patsyn_fvs = foldr (unionNameSet . psb_fvs) emptyNameSet $+                          getPatSynBinds anal_binds+                -- The uses in binds_w_dus for PatSynBinds do not include+                -- variables used in the patsyn builders; see+                -- Note [Pattern synonym builders don't yield dependencies]+                -- But psb_fvs /does/ include those builder fvs.  So we+                -- add them back in here to avoid bogus warnings about+                -- unused variables (Trac #12548)++             valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs+                                     `plusDU` usesOnly patsyn_fvs+                            -- Put the sig uses *after* the bindings+                            -- so that the binders are removed from+                            -- the uses in the sigs++        ; return (ValBindsOut anal_binds sigs', valbind'_dus) }++rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b)++-- Wrapper for local binds+--+-- The *client* of this function is responsible for checking for unused binders;+-- it doesn't (and can't: we don't have the thing inside the binds) happen here+--+-- The client is also responsible for bringing the fixities into scope+rnLocalValBindsRHS :: NameSet  -- names bound by the LHSes+                   -> HsValBindsLR Name RdrName+                   -> RnM (HsValBinds Name, DefUses)+rnLocalValBindsRHS bound_names binds+  = rnValBindsRHS (LocalBindCtxt bound_names) binds++-- for local binds+-- wrapper that does both the left- and right-hand sides+--+-- here there are no local fixity decls passed in;+-- the local fixity decls come from the ValBinds sigs+rnLocalValBindsAndThen+  :: HsValBinds RdrName+  -> (HsValBinds Name -> FreeVars -> RnM (result, FreeVars))+  -> RnM (result, FreeVars)+rnLocalValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside+ = do   {     -- (A) Create the local fixity environment+          new_fixities <- makeMiniFixityEnv [L loc sig+                                                  | L loc (FixSig sig) <- sigs]++              -- (B) Rename the LHSes+        ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds++              --     ...and bring them (and their fixities) into scope+        ; bindLocalNamesFV bound_names              $+          addLocalFixities new_fixities bound_names $ do++        {      -- (C) Do the RHS and thing inside+          (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs+        ; (result, result_fvs) <- thing_inside binds' (allUses dus)++                -- Report unused bindings based on the (accurate)+                -- findUses.  E.g.+                --      let x = x in 3+                -- should report 'x' unused+        ; let real_uses = findUses dus result_fvs+              -- Insert fake uses for variables introduced implicitly by+              -- wildcards (#4404)+              implicit_uses = hsValBindsImplicits binds'+        ; warnUnusedLocalBinds bound_names+                                      (real_uses `unionNameSet` implicit_uses)++        ; let+            -- The variables "used" in the val binds are:+            --   (1) the uses of the binds (allUses)+            --   (2) the FVs of the thing-inside+            all_uses = allUses dus `plusFV` result_fvs+                -- Note [Unused binding hack]+                -- ~~~~~~~~~~~~~~~~~~~~~~~~~~+                -- Note that *in contrast* to the above reporting of+                -- unused bindings, (1) above uses duUses to return *all*+                -- the uses, even if the binding is unused.  Otherwise consider:+                --      x = 3+                --      y = let p = x in 'x'    -- NB: p not used+                -- If we don't "see" the dependency of 'y' on 'x', we may put the+                -- bindings in the wrong order, and the type checker will complain+                -- that x isn't in scope+                --+                -- But note that this means we won't report 'x' as unused,+                -- whereas we would if we had { x = 3; p = x; y = 'x' }++        ; return (result, all_uses) }}+                -- The bound names are pruned out of all_uses+                -- by the bindLocalNamesFV call above++rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs)+++---------------------++-- renaming a single bind++rnBindLHS :: NameMaker+          -> SDoc+          -> HsBind RdrName+          -- returns the renamed left-hand side,+          -- and the FreeVars *of the LHS*+          -- (i.e., any free variables of the pattern)+          -> RnM (HsBindLR Name RdrName)++rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat })+  = do+      -- we don't actually use the FV processing of rnPatsAndThen here+      (pat',pat'_fvs) <- rnBindPat name_maker pat+      return (bind { pat_lhs = pat', bind_fvs = pat'_fvs })+                -- We temporarily store the pat's FVs in bind_fvs;+                -- gets updated to the FVs of the whole bind+                -- when doing the RHS below++rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name })+  = do { name <- applyNameMaker name_maker rdr_name+       ; return (bind { fun_id   = name+                      , bind_fvs = placeHolderNamesTc }) }++rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname })+  | isTopRecNameMaker name_maker+  = do { addLocM checkConName rdrname+       ; name <- lookupLocatedTopBndrRn rdrname   -- Should be in scope already+       ; return (PatSynBind psb{ psb_id = name }) }++  | otherwise  -- Pattern synonym, not at top level+  = do { addErr localPatternSynonymErr  -- Complain, but make up a fake+                                        -- name so that we can carry on+       ; name <- applyNameMaker name_maker rdrname+       ; return (PatSynBind psb{ psb_id = name }) }+  where+    localPatternSynonymErr :: SDoc+    localPatternSynonymErr+      = hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname))+           2 (text "Pattern synonym declarations are only valid at top level")++rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b)++rnLBind :: (Name -> [Name])             -- Signature tyvar function+        -> LHsBindLR Name RdrName+        -> RnM (LHsBind Name, [Name], Uses)+rnLBind sig_fn (L loc bind)+  = setSrcSpan loc $+    do { (bind', bndrs, dus) <- rnBind sig_fn bind+       ; return (L loc bind', bndrs, dus) }++-- assumes the left-hands-side vars are in scope+rnBind :: (Name -> [Name])              -- Signature tyvar function+       -> HsBindLR Name RdrName+       -> RnM (HsBind Name, [Name], Uses)+rnBind _ bind@(PatBind { pat_lhs = pat+                       , pat_rhs = grhss+                                   -- pat fvs were stored in bind_fvs+                                   -- after processing the LHS+                       , bind_fvs = pat_fvs })+  = do  { mod <- getModule+        ; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs rnLExpr grhss++                -- No scoped type variables for pattern bindings+        ; let all_fvs = pat_fvs `plusFV` rhs_fvs+              fvs'    = filterNameSet (nameIsLocalOrFrom mod) all_fvs+                -- Keep locally-defined Names+                -- As well as dependency analysis, we need these for the+                -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan+              bndrs = collectPatBinders pat+              bind' = bind { pat_rhs  = grhss',+                             pat_rhs_ty = placeHolderType, bind_fvs = fvs' }+              is_wild_pat = case pat of+                              L _ (WildPat {})                 -> True+                              L _ (BangPat (L _ (WildPat {}))) -> True -- #9127+                              _                                -> False++        -- Warn if the pattern binds no variables, except for the+        -- entirely-explicit idiom    _ = rhs+        -- which (a) is not that different from  _v = rhs+        --       (b) is sometimes used to give a type sig for,+        --           or an occurrence of, a variable on the RHS+        ; whenWOptM Opt_WarnUnusedPatternBinds $+          when (null bndrs && not is_wild_pat) $+          addWarn (Reason Opt_WarnUnusedPatternBinds) $ unusedPatBindWarn bind'++        ; fvs' `seq` -- See Note [Free-variable space leak]+          return (bind', bndrs, all_fvs) }++rnBind sig_fn bind@(FunBind { fun_id = name+                            , fun_matches = matches })+       -- invariant: no free vars here when it's a FunBind+  = do  { let plain_name = unLoc name++        ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $+                                -- bindSigTyVars tests for LangExt.ScopedTyVars+                                 rnMatchGroup (mkPrefixFunRhs name)+                                              rnLExpr matches+        ; let is_infix = isInfixFunBind bind+        ; when is_infix $ checkPrecMatch plain_name matches'++        ; mod <- getModule+        ; let fvs' = filterNameSet (nameIsLocalOrFrom mod) rhs_fvs+                -- Keep locally-defined Names+                -- As well as dependency analysis, we need these for the+                -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan++        ; fvs' `seq` -- See Note [Free-variable space leak]+          return (bind { fun_matches = matches'+                       , bind_fvs   = fvs' },+                  [plain_name], rhs_fvs)+      }++rnBind sig_fn (PatSynBind bind)+  = do  { (bind', name, fvs) <- rnPatSynBind sig_fn bind+        ; return (PatSynBind bind', name, fvs) }++rnBind _ b = pprPanic "rnBind" (ppr b)++{-+Note [Free-variable space leak]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have+    fvs' = trim fvs+and we seq fvs' before turning it as part of a record.++The reason is that trim is sometimes something like+    \xs -> intersectNameSet (mkNameSet bound_names) xs+and we don't want to retain the list bound_names. This showed up in+trac ticket #1136.+-}++{- *********************************************************************+*                                                                      *+          Dependency analysis and other support functions+*                                                                      *+********************************************************************* -}++depAnalBinds :: Bag (LHsBind Name, [Name], Uses)+             -> ([(RecFlag, LHsBinds Name)], DefUses)+-- Dependency analysis; this is important so that+-- unused-binding reporting is accurate+depAnalBinds binds_w_dus+  = (map get_binds sccs, map get_du sccs)+  where+    sccs = depAnal (\(_, defs, _) -> defs)+                   (\(_, _, uses) -> nonDetEltsUniqSet uses)+                   -- It's OK to use nonDetEltsUniqSet here as explained in+                   -- Note [depAnal determinism] in NameEnv.+                   (bagToList binds_w_dus)++    get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind)+    get_binds (CyclicSCC  binds_w_dus)  = (Recursive, listToBag [b | (b,_,_) <- binds_w_dus])++    get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses)+    get_du (CyclicSCC  binds_w_dus)      = (Just defs, uses)+        where+          defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs]+          uses = unionNameSets [u | (_,_,u) <- binds_w_dus]++---------------------+-- Bind the top-level forall'd type variables in the sigs.+-- E.g  f :: a -> a+--      f = rhs+--      The 'a' scopes over the rhs+--+-- NB: there'll usually be just one (for a function binding)+--     but if there are many, one may shadow the rest; too bad!+--      e.g  x :: [a] -> [a]+--           y :: [(a,a)] -> a+--           (x,y) = e+--      In e, 'a' will be in scope, and it'll be the one from 'y'!++mkSigTvFn :: [LSig Name] -> (Name -> [Name])+-- Return a lookup function that maps an Id Name to the names+-- of the type variables that should scope over its body.+mkSigTvFn sigs = \n -> lookupNameEnv env n `orElse` []+  where+    env = mkHsSigEnv get_scoped_tvs sigs++    get_scoped_tvs :: LSig Name -> Maybe ([Located Name], [Name])+    -- Returns (binders, scoped tvs for those binders)+    get_scoped_tvs (L _ (ClassOpSig _ names sig_ty))+      = Just (names, hsScopedTvs sig_ty)+    get_scoped_tvs (L _ (TypeSig names sig_ty))+      = Just (names, hsWcScopedTvs sig_ty)+    get_scoped_tvs (L _ (PatSynSig names sig_ty))+      = Just (names, hsScopedTvs sig_ty)+    get_scoped_tvs _ = Nothing++-- Process the fixity declarations, making a FastString -> (Located Fixity) map+-- (We keep the location around for reporting duplicate fixity declarations.)+--+-- Checks for duplicates, but not that only locally defined things are fixed.+-- Note: for local fixity declarations, duplicates would also be checked in+--       check_sigs below.  But we also use this function at the top level.++makeMiniFixityEnv :: [LFixitySig RdrName] -> RnM MiniFixityEnv++makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls+ where+   add_one_sig env (L loc (FixitySig names fixity)) =+     foldlM add_one env [ (loc,name_loc,name,fixity)+                        | L name_loc name <- names ]++   add_one env (loc, name_loc, name,fixity) = do+     { -- this fixity decl is a duplicate iff+       -- the ReaderName's OccName's FastString is already in the env+       -- (we only need to check the local fix_env because+       --  definitions of non-local will be caught elsewhere)+       let { fs = occNameFS (rdrNameOcc name)+           ; fix_item = L loc fixity };++       case lookupFsEnv env fs of+         Nothing -> return $ extendFsEnv env fs fix_item+         Just (L loc' _) -> do+           { setSrcSpan loc $+             addErrAt name_loc (dupFixityDecl loc' name)+           ; return env}+     }++dupFixityDecl :: SrcSpan -> RdrName -> SDoc+dupFixityDecl loc rdr_name+  = vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name),+          text "also at " <+> ppr loc]+++{- *********************************************************************+*                                                                      *+                Pattern synonym bindings+*                                                                      *+********************************************************************* -}++rnPatSynBind :: (Name -> [Name])                -- Signature tyvar function+             -> PatSynBind Name RdrName+             -> RnM (PatSynBind Name Name, [Name], Uses)+rnPatSynBind sig_fn bind@(PSB { psb_id = L l name+                              , psb_args = details+                              , psb_def = pat+                              , psb_dir = dir })+       -- invariant: no free vars here when it's a FunBind+  = do  { pattern_synonym_ok <- xoptM LangExt.PatternSynonyms+        ; unless pattern_synonym_ok (addErr patternSynonymErr)+        ; let sig_tvs = sig_fn name++        ; ((pat', details'), fvs1) <- bindSigTyVarsFV sig_tvs $+                                      rnPat PatSyn pat $ \pat' ->+         -- We check the 'RdrName's instead of the 'Name's+         -- so that the binding locations are reported+         -- from the left-hand side+            case details of+               PrefixPatSyn vars ->+                   do { checkDupRdrNames vars+                      ; names <- mapM lookupVar vars+                      ; return ( (pat', PrefixPatSyn names)+                               , mkFVs (map unLoc names)) }+               InfixPatSyn var1 var2 ->+                   do { checkDupRdrNames [var1, var2]+                      ; name1 <- lookupVar var1+                      ; name2 <- lookupVar var2+                      -- ; checkPrecMatch -- TODO+                      ; return ( (pat', InfixPatSyn name1 name2)+                               , mkFVs (map unLoc [name1, name2])) }+               RecordPatSyn vars ->+                   do { checkDupRdrNames (map recordPatSynSelectorId vars)+                      ; let rnRecordPatSynField+                              (RecordPatSynField { recordPatSynSelectorId = visible+                                                 , recordPatSynPatVar = hidden })+                              = do { visible' <- lookupLocatedTopBndrRn visible+                                   ; hidden'  <- lookupVar hidden+                                   ; return $ RecordPatSynField { recordPatSynSelectorId = visible'+                                                                , recordPatSynPatVar = hidden' } }+                      ; names <- mapM rnRecordPatSynField  vars+                      ; return ( (pat', RecordPatSyn names)+                               , mkFVs (map (unLoc . recordPatSynPatVar) names)) }++        ; (dir', fvs2) <- case dir of+            Unidirectional -> return (Unidirectional, emptyFVs)+            ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs)+            ExplicitBidirectional mg ->+                do { (mg', fvs) <- bindSigTyVarsFV sig_tvs $+                                   rnMatchGroup (mkPrefixFunRhs (L l name))+                                                rnLExpr mg+                   ; return (ExplicitBidirectional mg', fvs) }++        ; mod <- getModule+        ; let fvs = fvs1 `plusFV` fvs2+              fvs' = filterNameSet (nameIsLocalOrFrom mod) fvs+                -- Keep locally-defined Names+                -- As well as dependency analysis, we need these for the+                -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan++              bind' = bind{ psb_args = details'+                          , psb_def = pat'+                          , psb_dir = dir'+                          , psb_fvs = fvs' }+              selector_names = case details' of+                                 RecordPatSyn names ->+                                  map (unLoc . recordPatSynSelectorId) names+                                 _ -> []++        ; fvs' `seq` -- See Note [Free-variable space leak]+          return (bind', name : selector_names , fvs1)+          -- Why fvs1?  See Note [Pattern synonym builders don't yield dependencies]+      }+  where+    lookupVar = wrapLocM lookupOccRn++    patternSynonymErr :: SDoc+    patternSynonymErr+      = hang (text "Illegal pattern synonym declaration")+           2 (text "Use -XPatternSynonyms to enable this extension")++{-+Note [Pattern synonym builders don't yield dependencies]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When renaming a pattern synonym that has an explicit builder,+references in the builder definition should not be used when+calculating dependencies. For example, consider the following pattern+synonym definition:++pattern P x <- C1 x where+  P x = f (C1 x)++f (P x) = C2 x++In this case, 'P' needs to be typechecked in two passes:++1. Typecheck the pattern definition of 'P', which fully determines the+   type of 'P'. This step doesn't require knowing anything about 'f',+   since the builder definition is not looked at.++2. Typecheck the builder definition, which needs the typechecked+   definition of 'f' to be in scope; done by calls oo tcPatSynBuilderBind+   in TcBinds.tcValBinds.++This behaviour is implemented in 'tcValBinds', but it crucially+depends on 'P' not being put in a recursive group with 'f' (which+would make it look like a recursive pattern synonym a la 'pattern P =+P' which is unsound and rejected).++So:+ * We do not include builder fvs in the Uses returned by rnPatSynBind+   (which is then used for dependency analysis)+ * But we /do/ include them in the psb_fvs for the PatSynBind+ * In rnValBinds we record these builder uses, to avoid bogus+   unused-variable warnings (Trac #12548)+-}++{- *********************************************************************+*                                                                      *+                Class/instance method bindings+*                                                                      *+********************************************************************* -}++{- @rnMethodBinds@ is used for the method bindings of a class and an instance+declaration.   Like @rnBinds@ but without dependency analysis.++NOTA BENE: we record each {\em binder} of a method-bind group as a free variable.+That's crucial when dealing with an instance decl:+\begin{verbatim}+        instance Foo (T a) where+           op x = ...+\end{verbatim}+This might be the {\em sole} occurrence of @op@ for an imported class @Foo@,+and unless @op@ occurs we won't treat the type signature of @op@ in the class+decl for @Foo@ as a source of instance-decl gates.  But we should!  Indeed,+in many ways the @op@ in an instance decl is just like an occurrence, not+a binder.+-}++rnMethodBinds :: Bool                   -- True <=> is a class declaration+              -> Name                   -- Class name+              -> [Name]                 -- Type variables from the class/instance header+              -> LHsBinds RdrName       -- Binds+              -> [LSig RdrName]         -- and signatures/pragmas+              -> RnM (LHsBinds Name, [LSig Name], FreeVars)+-- Used for+--   * the default method bindings in a class decl+--   * the method bindings in an instance decl+rnMethodBinds is_cls_decl cls ktv_names binds sigs+  = do { checkDupRdrNames (collectMethodBinders binds)+             -- Check that the same method is not given twice in the+             -- same instance decl      instance C T where+             --                       f x = ...+             --                       g y = ...+             --                       f x = ...+             -- We must use checkDupRdrNames because the Name of the+             -- method is the Name of the class selector, whose SrcSpan+             -- points to the class declaration; and we use rnMethodBinds+             -- for instance decls too++       -- Rename the bindings LHSs+       ; binds' <- foldrBagM (rnMethodBindLHS is_cls_decl cls) emptyBag binds++       -- Rename the pragmas and signatures+       -- Annoyingly the type variables /are/ in scope for signatures, but+       -- /are not/ in scope in the SPECIALISE instance pramas; e.g.+       --    instance Eq a => Eq (T a) where+       --       (==) :: a -> a -> a+       --       {-# SPECIALISE instance Eq a => Eq (T [a]) #-}+       ; let (spec_inst_prags, other_sigs) = partition isSpecInstLSig sigs+             bound_nms = mkNameSet (collectHsBindsBinders binds')+             sig_ctxt | is_cls_decl = ClsDeclCtxt cls+                      | otherwise   = InstDeclCtxt bound_nms+       ; (spec_inst_prags', sip_fvs) <- renameSigs sig_ctxt spec_inst_prags+       ; (other_sigs',      sig_fvs) <- extendTyVarEnvFVRn ktv_names $+                                        renameSigs sig_ctxt other_sigs++       -- Rename the bindings RHSs.  Again there's an issue about whether the+       -- type variables from the class/instance head are in scope.+       -- Answer no in Haskell 2010, but yes if you have -XScopedTypeVariables+       ; scoped_tvs  <- xoptM LangExt.ScopedTypeVariables+       ; (binds'', bind_fvs) <- maybe_extend_tyvar_env scoped_tvs $+              do { binds_w_dus <- mapBagM (rnLBind (mkSigTvFn other_sigs')) binds'+                 ; let bind_fvs = foldrBag (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2)+                                           emptyFVs binds_w_dus+                 ; return (mapBag fstOf3 binds_w_dus, bind_fvs) }++       ; return ( binds'', spec_inst_prags' ++ other_sigs'+                , sig_fvs `plusFV` sip_fvs `plusFV` bind_fvs) }+  where+    -- For the method bindings in class and instance decls, we extend+    -- the type variable environment iff -XScopedTypeVariables+    maybe_extend_tyvar_env scoped_tvs thing_inside+       | scoped_tvs = extendTyVarEnvFVRn ktv_names thing_inside+       | otherwise  = thing_inside++rnMethodBindLHS :: Bool -> Name+                -> LHsBindLR RdrName RdrName+                -> LHsBindsLR Name RdrName+                -> RnM (LHsBindsLR Name RdrName)+rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest+  = setSrcSpan loc $ do+    do { sel_name <- wrapLocM (lookupInstDeclBndr cls (text "method")) name+                     -- We use the selector name as the binder+       ; let bind' = bind { fun_id = sel_name+                          , bind_fvs = placeHolderNamesTc }++       ; return (L loc bind' `consBag` rest ) }++-- Report error for all other forms of bindings+-- This is why we use a fold rather than map+rnMethodBindLHS is_cls_decl _ (L loc bind) rest+  = do { addErrAt loc $+         vcat [ what <+> text "not allowed in" <+> decl_sort+              , nest 2 (ppr bind) ]+       ; return rest }+  where+    decl_sort | is_cls_decl = text "class declaration:"+              | otherwise   = text "instance declaration:"+    what = case bind of+              PatBind {}    -> text "Pattern bindings (except simple variables)"+              PatSynBind {} -> text "Pattern synonyms"+                               -- Associated pattern synonyms are not implemented yet+              _ -> pprPanic "rnMethodBind" (ppr bind)++{-+************************************************************************+*                                                                      *+\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}+*                                                                      *+************************************************************************++@renameSigs@ checks for:+\begin{enumerate}+\item more than one sig for one thing;+\item signatures given for things not bound here;+\end{enumerate}++At the moment we don't gather free-var info from the types in+signatures.  We'd only need this if we wanted to report unused tyvars.+-}++renameSigs :: HsSigCtxt+           -> [LSig RdrName]+           -> RnM ([LSig Name], FreeVars)+-- Renames the signatures and performs error checks+renameSigs ctxt sigs+  = do  { mapM_ dupSigDeclErr (findDupSigs sigs)++        ; checkDupMinimalSigs sigs++        ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs++        ; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs'+        ; mapM_ misplacedSigErr bad_sigs                 -- Misplaced++        ; return (good_sigs, sig_fvs) }++----------------------+-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory+-- because this won't work for:+--      instance Foo T where+--        {-# INLINE op #-}+--        Baz.op = ...+-- We'll just rename the INLINE prag to refer to whatever other 'op'+-- is in scope.  (I'm assuming that Baz.op isn't in scope unqualified.)+-- Doesn't seem worth much trouble to sort this.++renameSig :: HsSigCtxt -> Sig RdrName -> RnM (Sig Name, FreeVars)+-- FixitySig is renamed elsewhere.+renameSig _ (IdSig x)+  = return (IdSig x, emptyFVs)    -- Actually this never occurs++renameSig ctxt sig@(TypeSig vs ty)+  = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs+        ; let doc = TypeSigCtx (ppr_sig_bndrs vs)+        ; (new_ty, fvs) <- rnHsSigWcType doc ty+        ; return (TypeSig new_vs new_ty, fvs) }++renameSig ctxt sig@(ClassOpSig is_deflt vs ty)+  = do  { defaultSigs_on <- xoptM LangExt.DefaultSignatures+        ; when (is_deflt && not defaultSigs_on) $+          addErr (defaultSigErr sig)+        ; new_v <- mapM (lookupSigOccRn ctxt sig) vs+        ; (new_ty, fvs) <- rnHsSigType ty_ctxt ty+        ; return (ClassOpSig is_deflt new_v new_ty, fvs) }+  where+    (v1:_) = vs+    ty_ctxt = GenericCtx (text "a class method signature for"+                          <+> quotes (ppr v1))++renameSig _ (SpecInstSig src ty)+  = do  { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx ty+        ; return (SpecInstSig src new_ty,fvs) }++-- {-# SPECIALISE #-} pragmas can refer to imported Ids+-- so, in the top-level case (when mb_names is Nothing)+-- we use lookupOccRn.  If there's both an imported and a local 'f'+-- then the SPECIALISE pragma is ambiguous, unlike all other signatures+renameSig ctxt sig@(SpecSig v tys inl)+  = do  { new_v <- case ctxt of+                     TopSigCtxt {} -> lookupLocatedOccRn v+                     _             -> lookupSigOccRn ctxt sig v+        ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys+        ; return (SpecSig new_v new_ty inl, fvs) }+  where+    ty_ctxt = GenericCtx (text "a SPECIALISE signature for"+                          <+> quotes (ppr v))+    do_one (tys,fvs) ty+      = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt ty+           ; return ( new_ty:tys, fvs_ty `plusFV` fvs) }++renameSig ctxt sig@(InlineSig v s)+  = do  { new_v <- lookupSigOccRn ctxt sig v+        ; return (InlineSig new_v s, emptyFVs) }++renameSig ctxt sig@(FixSig (FixitySig vs f))+  = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs+        ; return (FixSig (FixitySig new_vs f), emptyFVs) }++renameSig ctxt sig@(MinimalSig s (L l bf))+  = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf+       return (MinimalSig s (L l new_bf), emptyFVs)++renameSig ctxt sig@(PatSynSig vs ty)+  = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs+        ; (ty', fvs) <- rnHsSigType ty_ctxt ty+        ; return (PatSynSig new_vs ty', fvs) }+  where+    ty_ctxt = GenericCtx (text "a pattern synonym signature for"+                          <+> ppr_sig_bndrs vs)++renameSig ctxt sig@(SCCFunSig st v s)+  = do  { new_v <- lookupSigOccRn ctxt sig v+        ; return (SCCFunSig st new_v s, emptyFVs) }++-- COMPLETE Sigs can refer to imported IDs which is why we use+-- lookupLocatedOccRn rather than lookupSigOccRn+renameSig _ctxt sig@(CompleteMatchSig s (L l bf) mty)+  = do new_bf <- traverse lookupLocatedOccRn bf+       new_mty  <- traverse lookupLocatedOccRn mty++       this_mod <- fmap tcg_mod getGblEnv+       unless (any (nameIsLocalOrFrom this_mod . unLoc) new_bf) $ do+         -- Why 'any'? See Note [Orphan COMPLETE pragmas]+         addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError++       return (CompleteMatchSig s (L l new_bf) new_mty, emptyFVs)+  where+    orphanError :: SDoc+    orphanError =+      text "Orphan COMPLETE pragmas not supported" $$+      text "A COMPLETE pragma must mention at least one data constructor" $$+      text "or pattern synonym defined in the same module."++{-+Note [Orphan COMPLETE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We define a COMPLETE pragma to be a non-orphan if it includes at least+one conlike defined in the current module. Why is this sufficient?+Well if you have a pattern match++  case expr of+    P1 -> ...+    P2 -> ...+    P3 -> ...++any COMPLETE pragma which mentions a conlike other than P1, P2 or P3+will not be of any use in verifying that the pattern match is+exhaustive. So as we have certainly read the interface files that+define P1, P2 and P3, we will have loaded all non-orphan COMPLETE+pragmas that could be relevant to this pattern match.++For now we simply disallow orphan COMPLETE pragmas, as the added+complexity of supporting them properly doesn't seem worthwhile.+-}++ppr_sig_bndrs :: [Located RdrName] -> SDoc+ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)++okHsSig :: HsSigCtxt -> LSig a -> Bool+okHsSig ctxt (L _ sig)+  = case (sig, ctxt) of+     (ClassOpSig {}, ClsDeclCtxt {})  -> True+     (ClassOpSig {}, InstDeclCtxt {}) -> True+     (ClassOpSig {}, _)               -> False++     (TypeSig {}, ClsDeclCtxt {})  -> False+     (TypeSig {}, InstDeclCtxt {}) -> False+     (TypeSig {}, _)               -> True++     (PatSynSig {}, TopSigCtxt{}) -> True+     (PatSynSig {}, _)            -> False++     (FixSig {}, InstDeclCtxt {}) -> False+     (FixSig {}, _)               -> True++     (IdSig {}, TopSigCtxt {})   -> True+     (IdSig {}, InstDeclCtxt {}) -> True+     (IdSig {}, _)               -> False++     (InlineSig {}, HsBootCtxt {}) -> False+     (InlineSig {}, _)             -> True++     (SpecSig {}, TopSigCtxt {})    -> True+     (SpecSig {}, LocalBindCtxt {}) -> True+     (SpecSig {}, InstDeclCtxt {})  -> True+     (SpecSig {}, _)                -> False++     (SpecInstSig {}, InstDeclCtxt {}) -> True+     (SpecInstSig {}, _)               -> False++     (MinimalSig {}, ClsDeclCtxt {}) -> True+     (MinimalSig {}, _)              -> False++     (SCCFunSig {}, HsBootCtxt {}) -> False+     (SCCFunSig {}, _)             -> True++     (CompleteMatchSig {}, TopSigCtxt {} ) -> True+     (CompleteMatchSig {}, _)              -> False++-------------------+findDupSigs :: [LSig RdrName] -> [[(Located RdrName, Sig RdrName)]]+-- Check for duplicates on RdrName version,+-- because renamed version has unboundName for+-- not-in-scope binders, which gives bogus dup-sig errors+-- NB: in a class decl, a 'generic' sig is not considered+--     equal to an ordinary sig, so we allow, say+--           class C a where+--             op :: a -> a+--             default op :: Eq a => a -> a+findDupSigs sigs+  = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs)+  where+    expand_sig sig@(FixSig (FixitySig ns _)) = zip ns (repeat sig)+    expand_sig sig@(InlineSig n _)           = [(n,sig)]+    expand_sig sig@(TypeSig ns _)            = [(n,sig) | n <- ns]+    expand_sig sig@(ClassOpSig _ ns _)       = [(n,sig) | n <- ns]+    expand_sig sig@(PatSynSig ns  _ )        = [(n,sig) | n <- ns]+    expand_sig sig@(SCCFunSig _ n _)         = [(n,sig)]+    expand_sig _ = []++    matching_sig (L _ n1,sig1) (L _ n2,sig2)       = n1 == n2 && mtch sig1 sig2+    mtch (FixSig {})           (FixSig {})         = True+    mtch (InlineSig {})        (InlineSig {})      = True+    mtch (TypeSig {})          (TypeSig {})        = True+    mtch (ClassOpSig d1 _ _)   (ClassOpSig d2 _ _) = d1 == d2+    mtch (PatSynSig _ _)       (PatSynSig _ _)     = True+    mtch (SCCFunSig{})         (SCCFunSig{})       = True+    mtch _ _ = False++-- Warn about multiple MINIMAL signatures+checkDupMinimalSigs :: [LSig RdrName] -> RnM ()+checkDupMinimalSigs sigs+  = case filter isMinimalLSig sigs of+      minSigs@(_:_:_) -> dupMinimalSigErr minSigs+      _ -> return ()++{-+************************************************************************+*                                                                      *+\subsection{Match}+*                                                                      *+************************************************************************+-}++rnMatchGroup :: Outputable (body RdrName) => HsMatchContext Name+             -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))+             -> MatchGroup RdrName (Located (body RdrName))+             -> RnM (MatchGroup Name (Located (body Name)), FreeVars)+rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin })+  = do { empty_case_ok <- xoptM LangExt.EmptyCase+       ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt))+       ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms+       ; return (mkMatchGroup origin new_ms, ms_fvs) }++rnMatch :: Outputable (body RdrName) => HsMatchContext Name+        -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))+        -> LMatch RdrName (Located (body RdrName))+        -> RnM (LMatch Name (Located (body Name)), FreeVars)+rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody)++rnMatch' :: Outputable (body RdrName) => HsMatchContext Name+         -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))+         -> Match RdrName (Located (body RdrName))+         -> RnM (Match Name (Located (body Name)), FreeVars)+rnMatch' ctxt rnBody match@(Match { m_ctxt = mf, m_pats = pats+                                  , m_type = maybe_rhs_sig, m_grhss = grhss })+  = do  {       -- Result type signatures are no longer supported+          case maybe_rhs_sig of+                Nothing -> return ()+                Just (L loc ty) -> addErrAt loc (resSigErr match ty)++        ; let fixity = if isInfixMatch match then Infix else Prefix+               -- Now the main event+               -- Note that there are no local fixity decls for matches+        ; rnPats ctxt pats      $ \ pats' -> do+        { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss+        ; let mf' = case (ctxt,mf) of+                      (FunRhs (L _ funid) _ _,FunRhs (L lf _) _ strict)+                                            -> FunRhs (L lf funid) fixity strict+                      _                     -> ctxt+        ; return (Match { m_ctxt = mf', m_pats = pats'+                        , m_type = Nothing, m_grhss = grhss'}, grhss_fvs ) }}++emptyCaseErr :: HsMatchContext Name -> SDoc+emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt)+                       2 (text "Use EmptyCase to allow this")+  where+    pp_ctxt = case ctxt of+                CaseAlt    -> text "case expression"+                LambdaExpr -> text "\\case expression"+                _ -> text "(unexpected)" <+> pprMatchContextNoun ctxt+++resSigErr :: Outputable body+          => Match RdrName body -> HsType RdrName -> SDoc+resSigErr match ty+   = vcat [ text "Illegal result type signature" <+> quotes (ppr ty)+          , nest 2 $ ptext (sLit+                 "Result signatures are no longer supported in pattern matches")+          , pprMatchInCtxt match ]++{-+************************************************************************+*                                                                      *+\subsubsection{Guarded right-hand sides (GRHSs)}+*                                                                      *+************************************************************************+-}++rnGRHSs :: HsMatchContext Name+        -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))+        -> GRHSs RdrName (Located (body RdrName))+        -> RnM (GRHSs Name (Located (body Name)), FreeVars)+rnGRHSs ctxt rnBody (GRHSs grhss (L l binds))+  = rnLocalBindsAndThen binds   $ \ binds' _ -> do+    (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss+    return (GRHSs grhss' (L l binds'), fvGRHSs)++rnGRHS :: HsMatchContext Name+       -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))+       -> LGRHS RdrName (Located (body RdrName))+       -> RnM (LGRHS Name (Located (body Name)), FreeVars)+rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody)++rnGRHS' :: HsMatchContext Name+        -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))+        -> GRHS RdrName (Located (body RdrName))+        -> RnM (GRHS Name (Located (body Name)), FreeVars)+rnGRHS' ctxt rnBody (GRHS guards rhs)+  = do  { pattern_guards_allowed <- xoptM LangExt.PatternGuards+        ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ ->+                                    rnBody rhs++        ; unless (pattern_guards_allowed || is_standard_guard guards')+                 (addWarn NoReason (nonStdGuardErr guards'))++        ; return (GRHS guards' rhs', fvs) }+  where+        -- Standard Haskell 1.4 guards are just a single boolean+        -- expression, rather than a list of qualifiers as in the+        -- Glasgow extension+    is_standard_guard []                       = True+    is_standard_guard [L _ (BodyStmt _ _ _ _)] = True+    is_standard_guard _                        = False++{-+************************************************************************+*                                                                      *+\subsection{Error messages}+*                                                                      *+************************************************************************+-}++dupSigDeclErr :: [(Located RdrName, Sig RdrName)] -> RnM ()+dupSigDeclErr pairs@((L loc name, sig) : _)+  = addErrAt loc $+    vcat [ text "Duplicate" <+> what_it_is+           <> text "s for" <+> quotes (ppr name)+         , text "at" <+> vcat (map ppr $ sort $ map (getLoc . fst) pairs) ]+  where+    what_it_is = hsSigDoc sig++dupSigDeclErr [] = panic "dupSigDeclErr"++misplacedSigErr :: LSig Name -> RnM ()+misplacedSigErr (L loc sig)+  = addErrAt loc $+    sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig]++defaultSigErr :: Sig RdrName -> SDoc+defaultSigErr sig = vcat [ hang (text "Unexpected default signature:")+                              2 (ppr sig)+                         , text "Use DefaultSignatures to enable default signatures" ]++bindsInHsBootFile :: LHsBindsLR Name RdrName -> SDoc+bindsInHsBootFile mbinds+  = hang (text "Bindings in hs-boot files are not allowed")+       2 (ppr mbinds)++nonStdGuardErr :: Outputable body => [LStmtLR Name Name body] -> SDoc+nonStdGuardErr guards+  = hang (text "accepting non-standard pattern guards (use PatternGuards to suppress this message)")+       4 (interpp'SP guards)++unusedPatBindWarn :: HsBind Name -> SDoc+unusedPatBindWarn bind+  = hang (text "This pattern-binding binds no variables:")+       2 (ppr bind)++dupMinimalSigErr :: [LSig RdrName] -> RnM ()+dupMinimalSigErr sigs@(L loc _ : _)+  = addErrAt loc $+    vcat [ text "Multiple minimal complete definitions"+         , text "at" <+> vcat (map ppr $ sort $ map getLoc sigs)+         , text "Combine alternative minimal complete definitions with `|'" ]+dupMinimalSigErr [] = panic "dupMinimalSigErr"
+ rename/RnEnv.hs view
@@ -0,0 +1,2350 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-2006++\section[RnEnv]{Environment manipulation for the renamer monad}+-}++{-# LANGUAGE CPP, MultiWayIf #-}++module RnEnv (+        newTopSrcBinder,+        lookupLocatedTopBndrRn, lookupTopBndrRn,+        lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe,+        lookupLocalOccRn_maybe, lookupInfoOccRn,+        lookupLocalOccThLvl_maybe,+        lookupTypeOccRn, lookupKindOccRn,+        lookupGlobalOccRn, lookupGlobalOccRn_maybe,+        lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, lookupExactOcc,+        reportUnboundName, unknownNameSuggestions,+        addNameClashErrRn,++        HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,+        lookupSigCtxtOccRn,++        lookupFixityRn, lookupFixityRn_help,+        lookupFieldFixityRn, lookupTyFixityRn,+        lookupInstDeclBndr, lookupRecFieldOcc, lookupFamInstName,+        lookupConstructorFields,+        lookupSyntaxName, lookupSyntaxName', lookupSyntaxNames,+        lookupIfThenElse,+        lookupGreAvailRn,+        getLookupOccRn,mkUnboundName, mkUnboundNameRdr, isUnboundName,+        addUsedGRE, addUsedGREs, addUsedDataCons,++        newLocalBndrRn, newLocalBndrsRn,+        bindLocalNames, bindLocalNamesFV,+        MiniFixityEnv,+        addLocalFixities,+        bindLocatedLocalsFV, bindLocatedLocalsRn,+        extendTyVarEnvFVRn,++        -- Role annotations+        RoleAnnotEnv, emptyRoleAnnotEnv, mkRoleAnnotEnv,+        lookupRoleAnnot, getRoleAnnots,++        checkDupRdrNames, checkShadowedRdrNames,+        checkDupNames, checkDupAndShadowedNames, dupNamesErr,+        checkTupSize,+        addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS,+        warnUnusedMatches, warnUnusedTypePatterns,+        warnUnusedTopBinds, warnUnusedLocalBinds,+        mkFieldEnv,+        dataTcOccs, kindSigErr, perhapsForallMsg, unknownSubordinateErr,+        HsDocContext(..), pprHsDocContext,+        inHsDocContext, withHsDocContext+    ) where++#include "HsVersions.h"++import LoadIface        ( loadInterfaceForName, loadSrcInterface_maybe )+import IfaceEnv+import HsSyn+import RdrName+import HscTypes+import TcEnv+import TcRnMonad+import RdrHsSyn         ( setRdrNameSpace )+import TysWiredIn       ( starKindTyConName, unicodeStarKindTyConName )+import Name+import NameSet+import NameEnv+import Avail+import Module+import ConLike+import DataCon+import TyCon+import PrelNames        ( mkUnboundName, isUnboundName, rOOT_MAIN, forall_tv_RDR )+import ErrUtils         ( MsgDoc )+import BasicTypes       ( Fixity(..), FixityDirection(..), minPrecedence,+                          defaultFixity, pprWarningTxtForMsg, SourceText(..) )+import SrcLoc+import Outputable+import Util+import Maybes+import BasicTypes       ( TopLevelFlag(..) )+import ListSetOps       ( removeDups )+import DynFlags+import FastString+import Control.Monad+import Data.List+import Data.Function    ( on )+import ListSetOps       ( minusList )+import Constants        ( mAX_TUPLE_SIZE )+import qualified GHC.LanguageExtensions as LangExt+import Data.Maybe (isJust)++{-+*********************************************************+*                                                      *+                Source-code binders+*                                                      *+*********************************************************++Note [Signature lazy interface loading]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++GHC's lazy interface loading can be a bit confusing, so this Note is an+empirical description of what happens in one interesting case. When+compiling a signature module against an its implementation, we do NOT+load interface files associated with its names until after the type+checking phase.  For example:++    module ASig where+        data T+        f :: T -> T++Suppose we compile this with -sig-of "A is ASig":++    module B where+        data T = T+        f T = T++    module A(module B) where+        import B++During type checking, we'll load A.hi because we need to know what the+RdrEnv for the module is, but we DO NOT load the interface for B.hi!+It's wholly unnecessary: our local definition 'data T' in ASig is all+the information we need to finish type checking.  This is contrast to+type checking of ordinary Haskell files, in which we would not have the+local definition "data T" and would need to consult B.hi immediately.+(Also, this situation never occurs for hs-boot files, since you're not+allowed to reexport from another module.)++After type checking, we then check that the types we provided are+consistent with the backing implementation (in checkHiBootOrHsigIface).+At this point, B.hi is loaded, because we need something to compare+against.++I discovered this behavior when trying to figure out why type class+instances for Data.Map weren't in the EPS when I was type checking a+test very much like ASig (sigof02dm): the associated interface hadn't+been loaded yet!  (The larger issue is a moot point, since an instance+declared in a signature can never be a duplicate.)++This behavior might change in the future.  Consider this+alternate module B:++    module B where+        {-# DEPRECATED T, f "Don't use" #-}+        data T = T+        f T = T++One might conceivably want to report deprecation warnings when compiling+ASig with -sig-of B, in which case we need to look at B.hi to find the+deprecation warnings during renaming.  At the moment, you don't get any+warning until you use the identifier further downstream.  This would+require adjusting addUsedGRE so that during signature compilation,+we do not report deprecation warnings for LocalDef.  See also+Note [Handling of deprecations]+-}++newTopSrcBinder :: Located RdrName -> RnM Name+newTopSrcBinder (L loc rdr_name)+  | Just name <- isExact_maybe rdr_name+  =     -- This is here to catch+        --   (a) Exact-name binders created by Template Haskell+        --   (b) The PrelBase defn of (say) [] and similar, for which+        --       the parser reads the special syntax and returns an Exact RdrName+        -- We are at a binding site for the name, so check first that it+        -- the current module is the correct one; otherwise GHC can get+        -- very confused indeed. This test rejects code like+        --      data T = (,) Int Int+        -- unless we are in GHC.Tup+    if isExternalName name then+      do { this_mod <- getModule+         ; unless (this_mod == nameModule name)+                  (addErrAt loc (badOrigBinding rdr_name))+         ; return name }+    else   -- See Note [Binders in Template Haskell] in Convert.hs+      do { this_mod <- getModule+         ; externaliseName this_mod name }++  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name+  = do  { this_mod <- getModule+        ; unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN)+                 (addErrAt loc (badOrigBinding rdr_name))+        -- When reading External Core we get Orig names as binders,+        -- but they should agree with the module gotten from the monad+        --+        -- We can get built-in syntax showing up here too, sadly.  If you type+        --      data T = (,,,)+        -- the constructor is parsed as a type, and then RdrHsSyn.tyConToDataCon+        -- uses setRdrNameSpace to make it into a data constructors.  At that point+        -- the nice Exact name for the TyCon gets swizzled to an Orig name.+        -- Hence the badOrigBinding error message.+        --+        -- Except for the ":Main.main = ..." definition inserted into+        -- the Main module; ugh!++        -- Because of this latter case, we call newGlobalBinder with a module from+        -- the RdrName, not from the environment.  In principle, it'd be fine to+        -- have an arbitrary mixture of external core definitions in a single module,+        -- (apart from module-initialisation issues, perhaps).+        ; newGlobalBinder rdr_mod rdr_occ loc }++  | otherwise+  = do  { unless (not (isQual rdr_name))+                 (addErrAt loc (badQualBndrErr rdr_name))+                -- Binders should not be qualified; if they are, and with a different+                -- module name, we we get a confusing "M.T is not in scope" error later++        ; stage <- getStage+        ; if isBrackStage stage then+                -- We are inside a TH bracket, so make an *Internal* name+                -- See Note [Top-level Names in Template Haskell decl quotes] in RnNames+             do { uniq <- newUnique+                ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }+          else+             do { this_mod <- getModule+                ; traceRn "newTopSrcBinder" (ppr this_mod $$ ppr rdr_name $$ ppr loc)+                ; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc }+        }++{-+*********************************************************+*                                                      *+        Source code occurrences+*                                                      *+*********************************************************++Looking up a name in the RnEnv.++Note [Type and class operator definitions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to reject all of these unless we have -XTypeOperators (Trac #3265)+   data a :*: b  = ...+   class a :*: b where ...+   data (:*:) a b  = ....+   class (:*:) a b where ...+The latter two mean that we are not just looking for a+*syntactically-infix* declaration, but one that uses an operator+OccName.  We use OccName.isSymOcc to detect that case, which isn't+terribly efficient, but there seems to be no better way.+-}++lookupTopBndrRn :: RdrName -> RnM Name+lookupTopBndrRn n = do nopt <- lookupTopBndrRn_maybe n+                       case nopt of+                         Just n' -> return n'+                         Nothing -> do traceRn "lookupTopBndrRn fail" (ppr n)+                                       unboundName WL_LocalTop n++lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name)+lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn++lookupTopBndrRn_maybe :: RdrName -> RnM (Maybe Name)+-- Look up a top-level source-code binder.   We may be looking up an unqualified 'f',+-- and there may be several imported 'f's too, which must not confuse us.+-- For example, this is OK:+--      import Foo( f )+--      infix 9 f       -- The 'f' here does not need to be qualified+--      f x = x         -- Nor here, of course+-- So we have to filter out the non-local ones.+--+-- A separate function (importsFromLocalDecls) reports duplicate top level+-- decls, so here it's safe just to choose an arbitrary one.+--+-- There should never be a qualified name in a binding position in Haskell,+-- but there can be if we have read in an external-Core file.+-- The Haskell parser checks for the illegal qualified name in Haskell+-- source files, so we don't need to do so here.++lookupTopBndrRn_maybe rdr_name+  | Just name <- isExact_maybe rdr_name+  = do { name' <- lookupExactOcc name; return (Just name') }++  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name+        -- This deals with the case of derived bindings, where+        -- we don't bother to call newTopSrcBinder first+        -- We assume there is no "parent" name+  = do  { loc <- getSrcSpanM+        ; n <- newGlobalBinder rdr_mod rdr_occ loc+        ; return (Just n)}++  | otherwise+  = do  {  -- Check for operators in type or class declarations+           -- See Note [Type and class operator definitions]+          let occ = rdrNameOcc rdr_name+        ; when (isTcOcc occ && isSymOcc occ)+               (do { op_ok <- xoptM LangExt.TypeOperators+                   ; unless op_ok (addErr (opDeclErr rdr_name)) })++        ; env <- getGlobalRdrEnv+        ; case filter isLocalGRE (lookupGRE_RdrName rdr_name env) of+            [gre] -> return (Just (gre_name gre))+            _     -> return Nothing  -- Ambiguous (can't happen) or unbound+    }++-----------------------------------------------+-- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames].+-- This adds an error if the name cannot be found.+lookupExactOcc :: Name -> RnM Name+lookupExactOcc name+  = do { result <- lookupExactOcc_either name+       ; case result of+           Left err -> do { addErr err+                          ; return name }+           Right name' -> return name' }++-- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames].+-- This never adds an error, but it may return one.+lookupExactOcc_either :: Name -> RnM (Either MsgDoc Name)+-- See Note [Looking up Exact RdrNames]+lookupExactOcc_either name+  | Just thing <- wiredInNameTyThing_maybe name+  , Just tycon <- case thing of+                    ATyCon tc                 -> Just tc+                    AConLike (RealDataCon dc) -> Just (dataConTyCon dc)+                    _                         -> Nothing+  , isTupleTyCon tycon+  = do { checkTupSize (tyConArity tycon)+       ; return (Right name) }++  | isExternalName name+  = return (Right name)++  | otherwise+  = do { env <- getGlobalRdrEnv+       ; let -- See Note [Splicing Exact names]+             main_occ =  nameOccName name+             demoted_occs = case demoteOccName main_occ of+                              Just occ -> [occ]+                              Nothing  -> []+             gres = [ gre | occ <- main_occ : demoted_occs+                          , gre <- lookupGlobalRdrEnv env occ+                          , gre_name gre == name ]+       ; case gres of+           [gre] -> return (Right (gre_name gre))++           []    -> -- See Note [Splicing Exact names]+                    do { lcl_env <- getLocalRdrEnv+                       ; if name `inLocalRdrEnvScope` lcl_env+                         then return (Right name)+                         else+                         do { th_topnames_var <- fmap tcg_th_topnames getGblEnv+                            ; th_topnames <- readTcRef th_topnames_var+                            ; if name `elemNameSet` th_topnames+                              then return (Right name)+                              else return (Left exact_nm_err)+                            }+                       }+           gres -> return (Left (sameNameErr gres))   -- Ugh!  See Note [Template Haskell ambiguity]+       }+  where+    exact_nm_err = hang (text "The exact Name" <+> quotes (ppr name) <+> ptext (sLit "is not in scope"))+                      2 (vcat [ text "Probable cause: you used a unique Template Haskell name (NameU), "+                              , text "perhaps via newName, but did not bind it"+                              , text "If that's it, then -ddump-splices might be useful" ])++sameNameErr :: [GlobalRdrElt] -> MsgDoc+sameNameErr [] = panic "addSameNameErr: empty list"+sameNameErr gres@(_ : _)+  = hang (text "Same exact name in multiple name-spaces:")+       2 (vcat (map pp_one sorted_names) $$ th_hint)+  where+    sorted_names = sortWith nameSrcLoc (map gre_name gres)+    pp_one name+      = hang (pprNameSpace (occNameSpace (getOccName name))+              <+> quotes (ppr name) <> comma)+           2 (text "declared at:" <+> ppr (nameSrcLoc name))++    th_hint = vcat [ text "Probable cause: you bound a unique Template Haskell name (NameU),"+                   , text "perhaps via newName, in different name-spaces."+                   , text "If that's it, then -ddump-splices might be useful" ]+++-----------------------------------------------+lookupInstDeclBndr :: Name -> SDoc -> RdrName -> RnM Name+-- This is called on the method name on the left-hand side of an+-- instance declaration binding. eg.  instance Functor T where+--                                       fmap = ...+--                                       ^^^^ called on this+-- Regardless of how many unqualified fmaps are in scope, we want+-- the one that comes from the Functor class.+--+-- Furthermore, note that we take no account of whether the+-- name is only in scope qualified.  I.e. even if method op is+-- in scope as M.op, we still allow plain 'op' on the LHS of+-- an instance decl+--+-- The "what" parameter says "method" or "associated type",+-- depending on what we are looking up+lookupInstDeclBndr cls what rdr+  = do { when (isQual rdr)+              (addErr (badQualBndrErr rdr))+                -- In an instance decl you aren't allowed+                -- to use a qualified name for the method+                -- (Although it'd make perfect sense.)+       ; mb_name <- lookupSubBndrOcc+                          False -- False => we don't give deprecated+                                -- warnings when a deprecated class+                                -- method is defined. We only warn+                                -- when it's used+                          cls doc rdr+       ; case mb_name of+           Left err -> do { addErr err; return (mkUnboundNameRdr rdr) }+           Right nm -> return nm }+  where+    doc = what <+> text "of class" <+> quotes (ppr cls)+++-----------------------------------------------+lookupFamInstName :: Maybe Name -> Located RdrName -> RnM (Located Name)+-- Used for TyData and TySynonym family instances only,+-- See Note [Family instance binders]+lookupFamInstName (Just cls) tc_rdr  -- Associated type; c.f RnBinds.rnMethodBind+  = wrapLocM (lookupInstDeclBndr cls (text "associated type")) tc_rdr+lookupFamInstName Nothing tc_rdr     -- Family instance; tc_rdr is an *occurrence*+  = lookupLocatedOccRn tc_rdr++-----------------------------------------------+lookupConstructorFields :: Name -> RnM [FieldLabel]+-- Look up the fields of a given constructor+--   *  For constructors from this module, use the record field env,+--      which is itself gathered from the (as yet un-typechecked)+--      data type decls+--+--    * For constructors from imported modules, use the *type* environment+--      since imported modles are already compiled, the info is conveniently+--      right there++lookupConstructorFields con_name+  = do  { this_mod <- getModule+        ; if nameIsLocalOrFrom this_mod con_name then+          do { field_env <- getRecFieldEnv+             ; traceTc "lookupCF" (ppr con_name $$ ppr (lookupNameEnv field_env con_name) $$ ppr field_env)+             ; return (lookupNameEnv field_env con_name `orElse` []) }+          else+          do { con <- tcLookupConLike con_name+             ; traceTc "lookupCF 2" (ppr con)+             ; return (conLikeFieldLabels con) } }++-----------------------------------------------+-- Used for record construction and pattern matching+-- When the -XDisambiguateRecordFields flag is on, take account of the+-- constructor name to disambiguate which field to use; it's just the+-- same as for instance decls+--+-- NB: Consider this:+--      module Foo where { data R = R { fld :: Int } }+--      module Odd where { import Foo; fld x = x { fld = 3 } }+-- Arguably this should work, because the reference to 'fld' is+-- unambiguous because there is only one field id 'fld' in scope.+-- But currently it's rejected.++lookupRecFieldOcc :: Maybe Name  -- Nothing    => just look it up as usual+                                 -- Just tycon => use tycon to disambiguate+                  -> SDoc -> RdrName+                  -> RnM Name+lookupRecFieldOcc parent doc rdr_name+  | Just tc_name <- parent+  = do { mb_name <- lookupSubBndrOcc True tc_name doc rdr_name+       ; case mb_name of+           Left err -> do { addErr err; return (mkUnboundNameRdr rdr_name) }+           Right n  -> return n }++  | otherwise+  = lookupGlobalOccRn rdr_name++lookupSubBndrOcc :: Bool+                 -> Name     -- Parent+                 -> SDoc+                 -> RdrName+                 -> RnM (Either MsgDoc Name)+-- Find all the things the rdr-name maps to+-- and pick the one with the right parent namep+lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name+  | Just n <- isExact_maybe rdr_name   -- This happens in derived code+  = do { n <- lookupExactOcc n+       ; return (Right n) }++  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name+  = do { n <- lookupOrig rdr_mod rdr_occ+       ; return (Right n) }++  | isUnboundName the_parent+        -- Avoid an error cascade from malformed decls:+        --   instance Int where { foo = e }+        -- We have already generated an error in rnLHsInstDecl+  = return (Right (mkUnboundNameRdr rdr_name))++  | otherwise+  = do { env <- getGlobalRdrEnv+       ; let gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)+                -- NB: lookupGlobalRdrEnv, not lookupGRE_RdrName!+                --     The latter does pickGREs, but we want to allow 'x'+                --     even if only 'M.x' is in scope+       ; traceRn "lookupSubBndrOcc"+            (vcat [ ppr the_parent, ppr rdr_name+                  , ppr gres, ppr (pick_gres rdr_name gres)])+       ; case pick_gres rdr_name gres of+            (gre:_) -> do { addUsedGRE warn_if_deprec gre+                            -- Add a usage; this is an *occurrence* site+                            -- Note [Usage for sub-bndrs]+                          ; return (Right (gre_name gre)) }+                 -- If there is more than one local GRE for the+                 -- same OccName 'f', that will be reported separately+                 -- as a duplicate top-level binding for 'f'+            [] -> do { ns <- lookupQualifiedNameGHCi rdr_name+                     ; case ns of+                         (n:_) -> return (Right n)  -- Unlikely to be more than one...?+                         [] -> return (Left (unknownSubordinateErr doc rdr_name))+    } }+  where+    -- If Parent = NoParent, just do a normal lookup+    -- If Parent = Parent p then find all GREs that+    --   (a) have parent p+    --   (b) for Unqual, are in scope qualified or unqualified+    --       for Qual, are in scope with that qualification+    pick_gres rdr_name gres+      | isUnqual rdr_name = filter right_parent gres+      | otherwise         = filter right_parent (pickGREs rdr_name gres)++    right_parent (GRE { gre_par = p })+      | ParentIs parent <- p               = parent == the_parent+      | FldParent { par_is = parent } <- p = parent == the_parent+      | otherwise                          = False++{-+Note [Family instance binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  data family F a+  data instance F T = X1 | X2++The 'data instance' decl has an *occurrence* of F (and T), and *binds*+X1 and X2.  (This is unlike a normal data type declaration which would+bind F too.)  So we want an AvailTC F [X1,X2].++Now consider a similar pair:+  class C a where+    data G a+  instance C S where+    data G S = Y1 | Y2++The 'data G S' *binds* Y1 and Y2, and has an *occurrence* of G.++But there is a small complication: in an instance decl, we don't use+qualified names on the LHS; instead we use the class to disambiguate.+Thus:+  module M where+    import Blib( G )+    class C a where+      data G a+    instance C S where+      data G S = Y1 | Y2+Even though there are two G's in scope (M.G and Blib.G), the occurrence+of 'G' in the 'instance C S' decl is unambiguous, because C has only+one associated type called G. This is exactly what happens for methods,+and it is only consistent to do the same thing for types. That's the+role of the function lookupTcdName; the (Maybe Name) give the class of+the encloseing instance decl, if any.++Note [Looking up Exact RdrNames]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Exact RdrNames are generated by Template Haskell.  See Note [Binders+in Template Haskell] in Convert.++For data types and classes have Exact system Names in the binding+positions for constructors, TyCons etc.  For example+    [d| data T = MkT Int |]+when we splice in and Convert to HsSyn RdrName, we'll get+    data (Exact (system Name "T")) = (Exact (system Name "MkT")) ...+These System names are generated by Convert.thRdrName++But, constructors and the like need External Names, not System Names!+So we do the following++ * In RnEnv.newTopSrcBinder we spot Exact RdrNames that wrap a+   non-External Name, and make an External name for it. This is+   the name that goes in the GlobalRdrEnv++ * When looking up an occurrence of an Exact name, done in+   RnEnv.lookupExactOcc, we find the Name with the right unique in the+   GlobalRdrEnv, and use the one from the envt -- it will be an+   External Name in the case of the data type/constructor above.++ * Exact names are also use for purely local binders generated+   by TH, such as    \x_33. x_33+   Both binder and occurrence are Exact RdrNames.  The occurrence+   gets looked up in the LocalRdrEnv by RnEnv.lookupOccRn, and+   misses, because lookupLocalRdrEnv always returns Nothing for+   an Exact Name.  Now we fall through to lookupExactOcc, which+   will find the Name is not in the GlobalRdrEnv, so we just use+   the Exact supplied Name.++Note [Splicing Exact names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the splice $(do { x <- newName "x"; return (VarE x) })+This will generate a (HsExpr RdrName) term that mentions the+Exact RdrName "x_56" (or whatever), but does not bind it.  So+when looking such Exact names we want to check that it's in scope,+otherwise the type checker will get confused.  To do this we need to+keep track of all the Names in scope, and the LocalRdrEnv does just that;+we consult it with RdrName.inLocalRdrEnvScope.++There is another wrinkle.  With TH and -XDataKinds, consider+   $( [d| data Nat = Zero+          data T = MkT (Proxy 'Zero)  |] )+After splicing, but before renaming we get this:+   data Nat_77{tc} = Zero_78{d}+   data T_79{tc} = MkT_80{d} (Proxy 'Zero_78{tc})  |] )+The occurrence of 'Zero in the data type for T has the right unique,+but it has a TcClsName name-space in its OccName.  (This is set by+the ctxt_ns argument of Convert.thRdrName.)  When we check that is+in scope in the GlobalRdrEnv, we need to look up the DataName namespace+too.  (An alternative would be to make the GlobalRdrEnv also have+a Name -> GRE mapping.)++Note [Template Haskell ambiguity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The GlobalRdrEnv invariant says that if+  occ -> [gre1, ..., gren]+then the gres have distinct Names (INVARIANT 1 of GlobalRdrEnv).+This is guaranteed by extendGlobalRdrEnvRn (the dups check in add_gre).++So how can we get multiple gres in lookupExactOcc_maybe?  Because in+TH we might use the same TH NameU in two different name spaces.+eg (Trac #7241):+   $(newName "Foo" >>= \o -> return [DataD [] o [] [RecC o []] [''Show]])+Here we generate a type constructor and data constructor with the same+unique, but differnt name spaces.++It'd be nicer to rule this out in extendGlobalRdrEnvRn, but that would+mean looking up the OccName in every name-space, just in case, and that+seems a bit brutal.  So it's just done here on lookup.  But we might+need to revisit that choice.++Note [Usage for sub-bndrs]+~~~~~~~~~~~~~~~~~~~~~~~~~~+If you have this+   import qualified M( C( f ) )+   instance M.C T where+     f x = x+then is the qualified import M.f used?  Obviously yes.+But the RdrName used in the instance decl is unqualified.  In effect,+we fill in the qualification by looking for f's whose class is M.C+But when adding to the UsedRdrNames we must make that qualification+explicit (saying "used  M.f"), otherwise we get "Redundant import of M.f".++So we make up a suitable (fake) RdrName.  But be careful+   import qualified M+   import M( C(f) )+   instance C T where+     f x = x+Here we want to record a use of 'f', not of 'M.f', otherwise+we'll miss the fact that the qualified import is redundant.++--------------------------------------------------+--              Occurrences+--------------------------------------------------+-}++getLookupOccRn :: RnM (Name -> Maybe Name)+getLookupOccRn+  = do local_env <- getLocalRdrEnv+       return (lookupLocalRdrOcc local_env . nameOccName)++mkUnboundNameRdr :: RdrName -> Name+mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr)++lookupLocatedOccRn :: Located RdrName -> RnM (Located Name)+lookupLocatedOccRn = wrapLocM lookupOccRn++lookupLocalOccRn_maybe :: RdrName -> RnM (Maybe Name)+-- Just look in the local environment+lookupLocalOccRn_maybe rdr_name+  = do { local_env <- getLocalRdrEnv+       ; return (lookupLocalRdrEnv local_env rdr_name) }++lookupLocalOccThLvl_maybe :: Name -> RnM (Maybe (TopLevelFlag, ThLevel))+-- Just look in the local environment+lookupLocalOccThLvl_maybe name+  = do { lcl_env <- getLclEnv+       ; return (lookupNameEnv (tcl_th_bndrs lcl_env) name) }++-- lookupOccRn looks up an occurrence of a RdrName+lookupOccRn :: RdrName -> RnM Name+lookupOccRn rdr_name+  = do { mb_name <- lookupOccRn_maybe rdr_name+       ; case mb_name of+           Just name -> return name+           Nothing   -> reportUnboundName rdr_name }++lookupKindOccRn :: RdrName -> RnM Name+-- Looking up a name occurring in a kind+lookupKindOccRn rdr_name+  | isVarOcc (rdrNameOcc rdr_name)  -- See Note [Promoted variables in types]+  = badVarInType rdr_name+  | otherwise+  = do { typeintype <- xoptM LangExt.TypeInType+       ; if | typeintype           -> lookupTypeOccRn rdr_name+      -- With -XNoTypeInType, treat any usage of * in kinds as in scope+      -- this is a dirty hack, but then again so was the old * kind.+            | is_star rdr_name     -> return starKindTyConName+            | is_uni_star rdr_name -> return unicodeStarKindTyConName+            | otherwise            -> lookupOccRn rdr_name }++-- lookupPromotedOccRn looks up an optionally promoted RdrName.+lookupTypeOccRn :: RdrName -> RnM Name+-- see Note [Demotion]+lookupTypeOccRn rdr_name+  | isVarOcc (rdrNameOcc rdr_name)  -- See Note [Promoted variables in types]+  = badVarInType rdr_name+  | otherwise+  = do { mb_name <- lookupOccRn_maybe rdr_name+       ; case mb_name of {+             Just name -> return name ;+             Nothing   -> do { dflags <- getDynFlags+                             ; lookup_demoted rdr_name dflags } } }++lookup_demoted :: RdrName -> DynFlags -> RnM Name+lookup_demoted rdr_name dflags+  | Just demoted_rdr <- demoteRdrName rdr_name+    -- Maybe it's the name of a *data* constructor+  = do { data_kinds <- xoptM LangExt.DataKinds+       ; if data_kinds+            then do { mb_demoted_name <- lookupOccRn_maybe demoted_rdr+                    ; case mb_demoted_name of+                        Nothing -> unboundNameX WL_Any rdr_name star_info+                        Just demoted_name ->+                          do { whenWOptM Opt_WarnUntickedPromotedConstructors $+                               addWarn+                                 (Reason Opt_WarnUntickedPromotedConstructors)+                                 (untickedPromConstrWarn demoted_name)+                             ; return demoted_name } }+            else do { -- We need to check if a data constructor of this name is+                      -- in scope to give good error messages. However, we do+                      -- not want to give an additional error if the data+                      -- constructor happens to be out of scope! See #13947.+                      mb_demoted_name <- discardErrs $+                                         lookupOccRn_maybe demoted_rdr+                    ; let suggestion | isJust mb_demoted_name = suggest_dk+                                     | otherwise              = star_info+                    ; unboundNameX WL_Any rdr_name suggestion } }++  | otherwise+  = reportUnboundName rdr_name++  where+    suggest_dk = text "A data constructor of that name is in scope; did you mean DataKinds?"+    untickedPromConstrWarn name =+      text "Unticked promoted constructor" <> colon <+> quotes (ppr name) <> dot+      $$+      hsep [ text "Use"+           , quotes (char '\'' <> ppr name)+           , text "instead of"+           , quotes (ppr name) <> dot ]++    star_info+      | is_star rdr_name || is_uni_star rdr_name+      = if xopt LangExt.TypeInType dflags+        then text "NB: With TypeInType, you must import" <+>+             ppr rdr_name <+> text "from Data.Kind"+        else empty++      | otherwise+      = empty++is_star, is_uni_star :: RdrName -> Bool+is_star     = (fsLit "*" ==) . occNameFS . rdrNameOcc+is_uni_star = (fsLit "★" ==) . occNameFS . rdrNameOcc++badVarInType :: RdrName -> RnM Name+badVarInType rdr_name+  = do { addErr (text "Illegal promoted term variable in a type:"+                 <+> ppr rdr_name)+       ; return (mkUnboundNameRdr rdr_name) }++{- Note [Promoted variables in types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (Trac #12686):+   x = True+   data Bad = Bad 'x++The parser treats the quote in 'x as saying "use the term+namespace", so we'll get (Bad x{v}), with 'x' in the+VarName namespace.  If we don't test for this, the renamer+will happily rename it to the x bound at top level, and then+the typecheck falls over because it doesn't have 'x' in scope+when kind-checking.++Note [Demotion]+~~~~~~~~~~~~~~~+When the user writes:+  data Nat = Zero | Succ Nat+  foo :: f Zero -> Int++'Zero' in the type signature of 'foo' is parsed as:+  HsTyVar ("Zero", TcClsName)++When the renamer hits this occurrence of 'Zero' it's going to realise+that it's not in scope. But because it is renaming a type, it knows+that 'Zero' might be a promoted data constructor, so it will demote+its namespace to DataName and do a second lookup.++The final result (after the renamer) will be:+  HsTyVar ("Zero", DataName)+-}++--              Use this version to get tracing+--+-- lookupOccRn_maybe, lookupOccRn_maybe' :: RdrName -> RnM (Maybe Name)+-- lookupOccRn_maybe rdr_name+--  = do { mb_res <- lookupOccRn_maybe' rdr_name+--       ; gbl_rdr_env   <- getGlobalRdrEnv+--       ; local_rdr_env <- getLocalRdrEnv+--       ; traceRn $ text "lookupOccRn_maybe" <+>+--           vcat [ ppr rdr_name <+> ppr (getUnique (rdrNameOcc rdr_name))+--                , ppr mb_res+--                , text "Lcl env" <+> ppr local_rdr_env+--                , text "Gbl env" <+> ppr [ (getUnique (nameOccName (gre_name (head gres'))),gres') | gres <- occEnvElts gbl_rdr_env+--                                         , let gres' = filter isLocalGRE gres, not (null gres') ] ]+--       ; return mb_res }++lookupOccRn_maybe :: RdrName -> RnM (Maybe Name)+-- lookupOccRn looks up an occurrence of a RdrName+lookupOccRn_maybe rdr_name+  = do { local_env <- getLocalRdrEnv+       ; case lookupLocalRdrEnv local_env rdr_name of {+          Just name -> return (Just name) ;+          Nothing   -> do+       ; lookupGlobalOccRn_maybe rdr_name } }++lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name)+-- Looks up a RdrName occurrence in the top-level+--   environment, including using lookupQualifiedNameGHCi+--   for the GHCi case+-- No filter function; does not report an error on failure+-- Uses addUsedRdrName to record use and deprecations+lookupGlobalOccRn_maybe rdr_name+  | Just n <- isExact_maybe rdr_name   -- This happens in derived code+  = do { n' <- lookupExactOcc n; return (Just n') }++  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name+  = do { n <- lookupOrig rdr_mod rdr_occ+       ; return (Just n) }++  | otherwise+  = do  { mb_gre <- lookupGreRn_maybe rdr_name+        ; case mb_gre of {+            Just gre -> return (Just (gre_name gre)) ;+            Nothing  ->+     do { ns <- lookupQualifiedNameGHCi rdr_name+                      -- This test is not expensive,+                      -- and only happens for failed lookups+       ; case ns of+           (n:_) -> return (Just n)  -- Unlikely to be more than one...?+           []    -> return Nothing } } }++lookupGlobalOccRn :: RdrName -> RnM Name+-- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global+-- environment.  Adds an error message if the RdrName is not in scope.+lookupGlobalOccRn rdr_name+  = do { mb_name <- lookupGlobalOccRn_maybe rdr_name+       ; case mb_name of+           Just n  -> return n+           Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name)+                         ; unboundName WL_Global rdr_name } }++lookupInfoOccRn :: RdrName -> RnM [Name]+-- lookupInfoOccRn is intended for use in GHCi's ":info" command+-- It finds all the GREs that RdrName could mean, not complaining+-- about ambiguity, but rather returning them all+-- C.f. Trac #9881+lookupInfoOccRn rdr_name+  | Just n <- isExact_maybe rdr_name   -- e.g. (->)+  = return [n]++  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name+  = do { n <- lookupOrig rdr_mod rdr_occ+       ; return [n] }++  | otherwise+  = do { rdr_env <- getGlobalRdrEnv+       ; let ns = map gre_name (lookupGRE_RdrName rdr_name rdr_env)+       ; qual_ns <- lookupQualifiedNameGHCi rdr_name+       ; return (ns ++ (qual_ns `minusList` ns)) }++-- | Like 'lookupOccRn_maybe', but with a more informative result if+-- the 'RdrName' happens to be a record selector:+--+--   * Nothing         -> name not in scope (no error reported)+--   * Just (Left x)   -> name uniquely refers to x,+--                        or there is a name clash (reported)+--   * Just (Right xs) -> name refers to one or more record selectors;+--                        if overload_ok was False, this list will be+--                        a singleton.+lookupOccRn_overloaded  :: Bool -> RdrName -> RnM (Maybe (Either Name [FieldOcc Name]))+lookupOccRn_overloaded overload_ok rdr_name+  = do { local_env <- getLocalRdrEnv+       ; case lookupLocalRdrEnv local_env rdr_name of {+          Just name -> return (Just (Left name)) ;+          Nothing   -> do+       { mb_name <- lookupGlobalOccRn_overloaded overload_ok rdr_name+       ; case mb_name of {+           Just name -> return (Just name) ;+           Nothing   -> do+       { ns <- lookupQualifiedNameGHCi rdr_name+                      -- This test is not expensive,+                      -- and only happens for failed lookups+       ; case ns of+           (n:_) -> return $ Just $ Left n  -- Unlikely to be more than one...?+           []    -> return Nothing  } } } } }++lookupGlobalOccRn_overloaded :: Bool -> RdrName -> RnM (Maybe (Either Name [FieldOcc Name]))+lookupGlobalOccRn_overloaded overload_ok rdr_name+  | Just n <- isExact_maybe rdr_name   -- This happens in derived code+  = do { n' <- lookupExactOcc n; return (Just (Left n')) }++  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name+  = do { n <- lookupOrig rdr_mod rdr_occ+       ; return (Just (Left n)) }++  | otherwise+  = do  { env <- getGlobalRdrEnv+        ; case lookupGRE_RdrName rdr_name env of+                []    -> return Nothing+                [gre] | isRecFldGRE gre+                         -> do { addUsedGRE True gre+                               ; let+                                   fld_occ :: FieldOcc Name+                                   fld_occ+                                     = FieldOcc (noLoc rdr_name) (gre_name gre)+                               ; return (Just (Right [fld_occ])) }+                      | otherwise+                         -> do { addUsedGRE True gre+                               ; return (Just (Left (gre_name gre))) }+                gres  | all isRecFldGRE gres && overload_ok+                            -- Don't record usage for ambiguous selectors+                            -- until we know which is meant+                         -> return+                             (Just (Right+                                     (map (FieldOcc (noLoc rdr_name) . gre_name)+                                           gres)))+                gres     -> do { addNameClashErrRn rdr_name gres+                               ; return (Just (Left (gre_name (head gres)))) } }+++--------------------------------------------------+--      Lookup in the Global RdrEnv of the module+--------------------------------------------------++lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt)+-- Look up the RdrName in the GlobalRdrEnv+--   Exactly one binding: records it as "used", return (Just gre)+--   No bindings:         return Nothing+--   Many bindings:       report "ambiguous", return an arbitrary (Just gre)+-- (This API is a bit strange; lookupGRERn2_maybe is simpler.+--  But it works and I don't want to fiddle too much.)+-- Uses addUsedRdrName to record use and deprecations+lookupGreRn_maybe rdr_name+  = do  { env <- getGlobalRdrEnv+        ; case lookupGRE_RdrName rdr_name env of+            []    -> return Nothing+            [gre] -> do { addUsedGRE True gre+                        ; return (Just gre) }+            gres  -> do { addNameClashErrRn rdr_name gres+                        ; traceRn "lookupGreRn:name clash"+                            (ppr rdr_name $$ ppr gres $$ ppr env)+                        ; return (Just (head gres)) } }++lookupGreRn2_maybe :: RdrName -> RnM (Maybe GlobalRdrElt)+-- Look up the RdrName in the GlobalRdrEnv+--   Exactly one binding: record it as "used",   return (Just gre)+--   No bindings:         report "not in scope", return Nothing+--   Many bindings:       report "ambiguous",    return Nothing+-- Uses addUsedRdrName to record use and deprecations+lookupGreRn2_maybe rdr_name+  = do  { env <- getGlobalRdrEnv+        ; case lookupGRE_RdrName rdr_name env of+            []    -> do { _ <- unboundName WL_Global rdr_name+                        ; return Nothing }+            [gre] -> do { addUsedGRE True gre+                        ; return (Just gre) }+            gres  -> do { addNameClashErrRn rdr_name gres+                        ; traceRn "lookupGreRn_maybe:name clash"+                            (ppr rdr_name $$ ppr gres $$ ppr env)+                        ; return Nothing } }++lookupGreAvailRn :: RdrName -> RnM (Name, AvailInfo)+-- Used in export lists+-- If not found or ambiguous, add error message, and fake with UnboundName+-- Uses addUsedRdrName to record use and deprecations+lookupGreAvailRn rdr_name+  = do  { mb_gre <- lookupGreRn2_maybe rdr_name+        ; case mb_gre of {+            Just gre -> return (gre_name gre, availFromGRE gre) ;+            Nothing  ->+    do  { traceRn "lookupGreAvailRn" (ppr rdr_name)+        ; let name = mkUnboundNameRdr rdr_name+        ; return (name, avail name) } } }++{-+*********************************************************+*                                                      *+                Deprecations+*                                                      *+*********************************************************++Note [Handling of deprecations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* We report deprecations at each *occurrence* of the deprecated thing+  (see Trac #5867)++* We do not report deprecations for locally-defined names. For a+  start, we may be exporting a deprecated thing. Also we may use a+  deprecated thing in the defn of another deprecated things.  We may+  even use a deprecated thing in the defn of a non-deprecated thing,+  when changing a module's interface.++* addUsedGREs: we do not report deprecations for sub-binders:+     - the ".." completion for records+     - the ".." in an export item 'T(..)'+     - the things exported by a module export 'module M'+-}++addUsedDataCons :: GlobalRdrEnv -> TyCon -> RnM ()+-- Remember use of in-scope data constructors (Trac #7969)+addUsedDataCons rdr_env tycon+  = addUsedGREs [ gre+                | dc <- tyConDataCons tycon+                , Just gre <- [lookupGRE_Name rdr_env (dataConName dc)] ]++addUsedGRE :: Bool -> GlobalRdrElt -> RnM ()+-- Called for both local and imported things+-- Add usage *and* warn if deprecated+addUsedGRE warn_if_deprec gre+  = do { when warn_if_deprec (warnIfDeprecated gre)+       ; unless (isLocalGRE gre) $+         do { env <- getGblEnv+            ; traceRn "addUsedGRE" (ppr gre)+            ; updMutVar (tcg_used_gres env) (gre :) } }++addUsedGREs :: [GlobalRdrElt] -> RnM ()+-- Record uses of any *imported* GREs+-- Used for recording used sub-bndrs+-- NB: no call to warnIfDeprecated; see Note [Handling of deprecations]+addUsedGREs gres+  | null imp_gres = return ()+  | otherwise     = do { env <- getGblEnv+                       ; traceRn "addUsedGREs" (ppr imp_gres)+                       ; updMutVar (tcg_used_gres env) (imp_gres ++) }+  where+    imp_gres = filterOut isLocalGRE gres++warnIfDeprecated :: GlobalRdrElt -> RnM ()+warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss })+  | (imp_spec : _) <- iss+  = do { dflags <- getDynFlags+       ; this_mod <- getModule+       ; when (wopt Opt_WarnWarningsDeprecations dflags &&+               not (nameIsLocalOrFrom this_mod name)) $+                   -- See Note [Handling of deprecations]+         do { iface <- loadInterfaceForName doc name+            ; case lookupImpDeprec iface gre of+                Just txt -> addWarn (Reason Opt_WarnWarningsDeprecations)+                                   (mk_msg imp_spec txt)+                Nothing  -> return () } }+  | otherwise+  = return ()+  where+    occ = greOccName gre+    name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name+    doc = text "The name" <+> quotes (ppr occ) <+> ptext (sLit "is mentioned explicitly")++    mk_msg imp_spec txt+      = sep [ sep [ text "In the use of"+                    <+> pprNonVarNameSpace (occNameSpace occ)+                    <+> quotes (ppr occ)+                  , parens imp_msg <> colon ]+            , pprWarningTxtForMsg txt ]+      where+        imp_mod  = importSpecModule imp_spec+        imp_msg  = text "imported from" <+> ppr imp_mod <> extra+        extra | imp_mod == moduleName name_mod = Outputable.empty+              | otherwise = text ", but defined in" <+> ppr name_mod++lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt+lookupImpDeprec iface gre+  = mi_warn_fn iface (greOccName gre) `mplus`  -- Bleat if the thing,+    case gre_par gre of                      -- or its parent, is warn'd+       ParentIs  p              -> mi_warn_fn iface (nameOccName p)+       FldParent { par_is = p } -> mi_warn_fn iface (nameOccName p)+       NoParent                 -> Nothing++{-+Note [Used names with interface not loaded]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's (just) possible to find a used+Name whose interface hasn't been loaded:++a) It might be a WiredInName; in that case we may not load+   its interface (although we could).++b) It might be GHC.Real.fromRational, or GHC.Num.fromInteger+   These are seen as "used" by the renamer (if -XRebindableSyntax)+   is on), but the typechecker may discard their uses+   if in fact the in-scope fromRational is GHC.Read.fromRational,+   (see tcPat.tcOverloadedLit), and the typechecker sees that the type+   is fixed, say, to GHC.Base.Float (see Inst.lookupSimpleInst).+   In that obscure case it won't force the interface in.++In both cases we simply don't permit deprecations;+this is, after all, wired-in stuff.+++*********************************************************+*                                                      *+                GHCi support+*                                                      *+*********************************************************++A qualified name on the command line can refer to any module at+all: we try to load the interface if we don't already have it, just+as if there was an "import qualified M" declaration for every+module.++If we fail we just return Nothing, rather than bleating+about "attempting to use module ‘D’ (./D.hs) which is not loaded"+which is what loadSrcInterface does.++Note [Safe Haskell and GHCi]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We DONT do this Safe Haskell as we need to check imports. We can+and should instead check the qualified import but at the moment+this requires some refactoring so leave as a TODO+-}++lookupQualifiedNameGHCi :: RdrName -> RnM [Name]+lookupQualifiedNameGHCi rdr_name+  = -- We want to behave as we would for a source file import here,+    -- and respect hiddenness of modules/packages, hence loadSrcInterface.+    do { dflags  <- getDynFlags+       ; is_ghci <- getIsGHCi+       ; go_for_it dflags is_ghci }++  where+    go_for_it dflags is_ghci+      | Just (mod,occ) <- isQual_maybe rdr_name+      , is_ghci+      , gopt Opt_ImplicitImportQualified dflags   -- Enables this GHCi behaviour+      , not (safeDirectImpsReq dflags)            -- See Note [Safe Haskell and GHCi]+      = do { res <- loadSrcInterface_maybe doc mod False Nothing+           ; case res of+                Succeeded iface+                  -> return [ name+                            | avail <- mi_exports iface+                            , name  <- availNames avail+                            , nameOccName name == occ ]++                _ -> -- Either we couldn't load the interface, or+                     -- we could but we didn't find the name in it+                     do { traceRn "lookupQualifiedNameGHCi" (ppr rdr_name)+                        ; return [] } }++      | otherwise+      = do { traceRn "lookupQualifiedNameGHCi: off" (ppr rdr_name)+           ; return [] }++    doc = text "Need to find" <+> ppr rdr_name++{-+Note [Looking up signature names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+lookupSigOccRn is used for type signatures and pragmas+Is this valid?+  module A+        import M( f )+        f :: Int -> Int+        f x = x+It's clear that the 'f' in the signature must refer to A.f+The Haskell98 report does not stipulate this, but it will!+So we must treat the 'f' in the signature in the same way+as the binding occurrence of 'f', using lookupBndrRn++However, consider this case:+        import M( f )+        f :: Int -> Int+        g x = x+We don't want to say 'f' is out of scope; instead, we want to+return the imported 'f', so that later on the reanamer will+correctly report "misplaced type sig".++Note [Signatures for top level things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+data HsSigCtxt = ... | TopSigCtxt NameSet | ....++* The NameSet says what is bound in this group of bindings.+  We can't use isLocalGRE from the GlobalRdrEnv, because of this:+       f x = x+       $( ...some TH splice... )+       f :: Int -> Int+  When we encounter the signature for 'f', the binding for 'f'+  will be in the GlobalRdrEnv, and will be a LocalDef. Yet the+  signature is mis-placed++* For type signatures the NameSet should be the names bound by the+  value bindings; for fixity declarations, the NameSet should also+  include class sigs and record selectors++      infix 3 `f`          -- Yes, ok+      f :: C a => a -> a   -- No, not ok+      class C a where+        f :: a -> a+-}++data HsSigCtxt+  = TopSigCtxt NameSet       -- At top level, binding these names+                             -- See Note [Signatures for top level things]+  | LocalBindCtxt NameSet    -- In a local binding, binding these names+  | ClsDeclCtxt   Name       -- Class decl for this class+  | InstDeclCtxt  NameSet    -- Instance decl whose user-written method+                             -- bindings are for these methods+  | HsBootCtxt NameSet       -- Top level of a hs-boot file, binding these names+  | RoleAnnotCtxt NameSet    -- A role annotation, with the names of all types+                             -- in the group++instance Outputable HsSigCtxt where+    ppr (TopSigCtxt ns) = text "TopSigCtxt" <+> ppr ns+    ppr (LocalBindCtxt ns) = text "LocalBindCtxt" <+> ppr ns+    ppr (ClsDeclCtxt n) = text "ClsDeclCtxt" <+> ppr n+    ppr (InstDeclCtxt ns) = text "InstDeclCtxt" <+> ppr ns+    ppr (HsBootCtxt ns) = text "HsBootCtxt" <+> ppr ns+    ppr (RoleAnnotCtxt ns) = text "RoleAnnotCtxt" <+> ppr ns++lookupSigOccRn :: HsSigCtxt+               -> Sig RdrName+               -> Located RdrName -> RnM (Located Name)+lookupSigOccRn ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig)++-- | Lookup a name in relation to the names in a 'HsSigCtxt'+lookupSigCtxtOccRn :: HsSigCtxt+                   -> SDoc         -- ^ description of thing we're looking up,+                                   -- like "type family"+                   -> Located RdrName -> RnM (Located Name)+lookupSigCtxtOccRn ctxt what+  = wrapLocM $ \ rdr_name ->+    do { mb_name <- lookupBindGroupOcc ctxt what rdr_name+       ; case mb_name of+           Left err   -> do { addErr err; return (mkUnboundNameRdr rdr_name) }+           Right name -> return name }++lookupBindGroupOcc :: HsSigCtxt+                   -> SDoc+                   -> RdrName -> RnM (Either MsgDoc Name)+-- Looks up the RdrName, expecting it to resolve to one of the+-- bound names passed in.  If not, return an appropriate error message+--+-- See Note [Looking up signature names]+lookupBindGroupOcc ctxt what rdr_name+  | Just n <- isExact_maybe rdr_name+  = lookupExactOcc_either n   -- allow for the possibility of missing Exacts;+                              -- see Note [dataTcOccs and Exact Names]+      -- Maybe we should check the side conditions+      -- but it's a pain, and Exact things only show+      -- up when you know what you are doing++  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name+  = do { n' <- lookupOrig rdr_mod rdr_occ+       ; return (Right n') }++  | otherwise+  = case ctxt of+      HsBootCtxt ns    -> lookup_top (`elemNameSet` ns)+      TopSigCtxt ns    -> lookup_top (`elemNameSet` ns)+      RoleAnnotCtxt ns -> lookup_top (`elemNameSet` ns)+      LocalBindCtxt ns -> lookup_group ns+      ClsDeclCtxt  cls -> lookup_cls_op cls+      InstDeclCtxt ns  -> lookup_top (`elemNameSet` ns)+  where+    lookup_cls_op cls+      = lookupSubBndrOcc True cls doc rdr_name+      where+        doc = text "method of class" <+> quotes (ppr cls)++    lookup_top keep_me+      = do { env <- getGlobalRdrEnv+           ; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)+           ; case filter (keep_me . gre_name) all_gres of+               [] | null all_gres -> bale_out_with Outputable.empty+                  | otherwise     -> bale_out_with local_msg+               (gre:_)            -> return (Right (gre_name gre)) }++    lookup_group bound_names  -- Look in the local envt (not top level)+      = do { local_env <- getLocalRdrEnv+           ; case lookupLocalRdrEnv local_env rdr_name of+               Just n+                 | n `elemNameSet` bound_names -> return (Right n)+                 | otherwise                   -> bale_out_with local_msg+               Nothing                         -> bale_out_with Outputable.empty }++    bale_out_with msg+        = return (Left (sep [ text "The" <+> what+                                <+> text "for" <+> quotes (ppr rdr_name)+                           , nest 2 $ text "lacks an accompanying binding"]+                       $$ nest 2 msg))++    local_msg = parens $ text "The"  <+> what <+> ptext (sLit "must be given where")+                           <+> quotes (ppr rdr_name) <+> text "is declared"+++---------------+lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [(RdrName, Name)]+-- GHC extension: look up both the tycon and data con or variable.+-- Used for top-level fixity signatures and deprecations.+-- Complain if neither is in scope.+-- See Note [Fixity signature lookup]+lookupLocalTcNames ctxt what rdr_name+  = do { mb_gres <- mapM lookup (dataTcOccs rdr_name)+       ; let (errs, names) = splitEithers mb_gres+       ; when (null names) $ addErr (head errs) -- Bleat about one only+       ; return names }+  where+    lookup rdr = do { name <- lookupBindGroupOcc ctxt what rdr+                    ; return (fmap ((,) rdr) name) }++dataTcOccs :: RdrName -> [RdrName]+-- Return both the given name and the same name promoted to the TcClsName+-- namespace.  This is useful when we aren't sure which we are looking at.+-- See also Note [dataTcOccs and Exact Names]+dataTcOccs rdr_name+  | isDataOcc occ || isVarOcc occ+  = [rdr_name, rdr_name_tc]+  | otherwise+  = [rdr_name]+  where+    occ = rdrNameOcc rdr_name+    rdr_name_tc = setRdrNameSpace rdr_name tcName++{-+Note [dataTcOccs and Exact Names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Exact RdrNames can occur in code generated by Template Haskell, and generally+those references are, well, exact. However, the TH `Name` type isn't expressive+enough to always track the correct namespace information, so we sometimes get+the right Unique but wrong namespace. Thus, we still have to do the double-lookup+for Exact RdrNames.++There is also an awkward situation for built-in syntax. Example in GHCi+   :info []+This parses as the Exact RdrName for nilDataCon, but we also want+the list type constructor.++Note that setRdrNameSpace on an Exact name requires the Name to be External,+which it always is for built in syntax.++*********************************************************+*                                                      *+                Fixities+*                                                      *+*********************************************************++Note [Fixity signature lookup]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A fixity declaration like++    infixr 2 ?++can refer to a value-level operator, e.g.:++    (?) :: String -> String -> String++or a type-level operator, like:++    data (?) a b = A a | B b++so we extend the lookup of the reader name '?' to the TcClsName namespace, as+well as the original namespace.++The extended lookup is also used in other places, like resolution of+deprecation declarations, and lookup of names in GHCi.+-}++--------------------------------+type MiniFixityEnv = FastStringEnv (Located Fixity)+        -- Mini fixity env for the names we're about+        -- to bind, in a single binding group+        --+        -- It is keyed by the *FastString*, not the *OccName*, because+        -- the single fixity decl       infix 3 T+        -- affects both the data constructor T and the type constrctor T+        --+        -- We keep the location so that if we find+        -- a duplicate, we can report it sensibly++--------------------------------+-- Used for nested fixity decls to bind names along with their fixities.+-- the fixities are given as a UFM from an OccName's FastString to a fixity decl++addLocalFixities :: MiniFixityEnv -> [Name] -> RnM a -> RnM a+addLocalFixities mini_fix_env names thing_inside+  = extendFixityEnv (mapMaybe find_fixity names) thing_inside+  where+    find_fixity name+      = case lookupFsEnv mini_fix_env (occNameFS occ) of+          Just (L _ fix) -> Just (name, FixItem occ fix)+          Nothing        -> Nothing+      where+        occ = nameOccName name++{-+--------------------------------+lookupFixity is a bit strange.++* Nested local fixity decls are put in the local fixity env, which we+  find with getFixtyEnv++* Imported fixities are found in the PIT++* Top-level fixity decls in this module may be for Names that are+    either  Global         (constructors, class operations)+    or      Local/Exported (everything else)+  (See notes with RnNames.getLocalDeclBinders for why we have this split.)+  We put them all in the local fixity environment+-}++lookupFixityRn :: Name -> RnM Fixity+lookupFixityRn name = lookupFixityRn' name (nameOccName name)++lookupFixityRn' :: Name -> OccName -> RnM Fixity+lookupFixityRn' name = fmap snd . lookupFixityRn_help' name++-- | 'lookupFixityRn_help' returns @(True, fixity)@ if it finds a 'Fixity'+-- in a local environment or from an interface file. Otherwise, it returns+-- @(False, fixity)@ (e.g., for unbound 'Name's or 'Name's without+-- user-supplied fixity declarations).+lookupFixityRn_help :: Name+                    -> RnM (Bool, Fixity)+lookupFixityRn_help name =+    lookupFixityRn_help' name (nameOccName name)++lookupFixityRn_help' :: Name+                     -> OccName+                     -> RnM (Bool, Fixity)+lookupFixityRn_help' name occ+  | isUnboundName name+  = return (False, Fixity NoSourceText minPrecedence InfixL)+    -- Minimise errors from ubound names; eg+    --    a>0 `foo` b>0+    -- where 'foo' is not in scope, should not give an error (Trac #7937)++  | otherwise+  = do { local_fix_env <- getFixityEnv+       ; case lookupNameEnv local_fix_env name of {+           Just (FixItem _ fix) -> return (True, fix) ;+           Nothing ->++    do { this_mod <- getModule+       ; if nameIsLocalOrFrom this_mod name+               -- Local (and interactive) names are all in the+               -- fixity env, and don't have entries in the HPT+         then return (False, defaultFixity)+         else lookup_imported } } }+  where+    lookup_imported+      -- For imported names, we have to get their fixities by doing a+      -- loadInterfaceForName, and consulting the Ifaces that comes back+      -- from that, because the interface file for the Name might not+      -- have been loaded yet.  Why not?  Suppose you import module A,+      -- which exports a function 'f', thus;+      --        module CurrentModule where+      --          import A( f )+      --        module A( f ) where+      --          import B( f )+      -- Then B isn't loaded right away (after all, it's possible that+      -- nothing from B will be used).  When we come across a use of+      -- 'f', we need to know its fixity, and it's then, and only+      -- then, that we load B.hi.  That is what's happening here.+      --+      -- loadInterfaceForName will find B.hi even if B is a hidden module,+      -- and that's what we want.+      = do { iface <- loadInterfaceForName doc name+           ; let mb_fix = mi_fix_fn iface occ+           ; let msg = case mb_fix of+                            Nothing ->+                                  text "looking up name" <+> ppr name+                              <+> text "in iface, but found no fixity for it."+                              <+> text "Using default fixity instead."+                            Just f ->+                                  text "looking up name in iface and found:"+                              <+> vcat [ppr name, ppr f]+           ; traceRn "lookupFixityRn_either:" msg+           ; return (maybe (False, defaultFixity) (\f -> (True, f)) mb_fix)  }++    doc = text "Checking fixity for" <+> ppr name++---------------+lookupTyFixityRn :: Located Name -> RnM Fixity+lookupTyFixityRn (L _ n) = lookupFixityRn n++-- | Look up the fixity of a (possibly ambiguous) occurrence of a record field+-- selector.  We use 'lookupFixityRn'' so that we can specifiy the 'OccName' as+-- the field label, which might be different to the 'OccName' of the selector+-- 'Name' if @DuplicateRecordFields@ is in use (Trac #1173). If there are+-- multiple possible selectors with different fixities, generate an error.+lookupFieldFixityRn :: AmbiguousFieldOcc Name -> RnM Fixity+lookupFieldFixityRn (Unambiguous (L _ rdr) n)+  = lookupFixityRn' n (rdrNameOcc rdr)+lookupFieldFixityRn (Ambiguous   (L _ rdr) _) = get_ambiguous_fixity rdr+  where+    get_ambiguous_fixity :: RdrName -> RnM Fixity+    get_ambiguous_fixity rdr_name = do+      traceRn "get_ambiguous_fixity" (ppr rdr_name)+      rdr_env <- getGlobalRdrEnv+      let elts =  lookupGRE_RdrName rdr_name rdr_env++      fixities <- groupBy ((==) `on` snd) . zip elts+                  <$> mapM lookup_gre_fixity elts++      case fixities of+        -- There should always be at least one fixity.+        -- Something's very wrong if there are no fixity candidates, so panic+        [] -> panic "get_ambiguous_fixity: no candidates for a given RdrName"+        [ (_, fix):_ ] -> return fix+        ambigs -> addErr (ambiguous_fixity_err rdr_name ambigs)+                  >> return (Fixity NoSourceText minPrecedence InfixL)++    lookup_gre_fixity gre = lookupFixityRn' (gre_name gre) (greOccName gre)++    ambiguous_fixity_err rn ambigs+      = vcat [ text "Ambiguous fixity for record field" <+> quotes (ppr rn)+             , hang (text "Conflicts: ") 2 . vcat .+               map format_ambig $ concat ambigs ]++    format_ambig (elt, fix) = hang (ppr fix)+                                 2 (pprNameProvenance elt)+++{- *********************************************************************+*                                                                      *+                        Role annotations+*                                                                      *+********************************************************************* -}++type RoleAnnotEnv = NameEnv (LRoleAnnotDecl Name)++mkRoleAnnotEnv :: [LRoleAnnotDecl Name] -> RoleAnnotEnv+mkRoleAnnotEnv role_annot_decls+ = mkNameEnv [ (name, ra_decl)+             | ra_decl <- role_annot_decls+             , let name = roleAnnotDeclName (unLoc ra_decl)+             , not (isUnboundName name) ]+       -- Some of the role annots will be unbound;+       -- we don't wish to include these++emptyRoleAnnotEnv :: RoleAnnotEnv+emptyRoleAnnotEnv = emptyNameEnv++lookupRoleAnnot :: RoleAnnotEnv -> Name -> Maybe (LRoleAnnotDecl Name)+lookupRoleAnnot = lookupNameEnv++getRoleAnnots :: [Name] -> RoleAnnotEnv -> ([LRoleAnnotDecl Name], RoleAnnotEnv)+getRoleAnnots bndrs role_env+  = ( mapMaybe (lookupRoleAnnot role_env) bndrs+    , delListFromNameEnv role_env bndrs )+++{-+************************************************************************+*                                                                      *+                        Rebindable names+        Dealing with rebindable syntax is driven by the+        Opt_RebindableSyntax dynamic flag.++        In "deriving" code we don't want to use rebindable syntax+        so we switch off the flag locally++*                                                                      *+************************************************************************++Haskell 98 says that when you say "3" you get the "fromInteger" from the+Standard Prelude, regardless of what is in scope.   However, to experiment+with having a language that is less coupled to the standard prelude, we're+trying a non-standard extension that instead gives you whatever "Prelude.fromInteger"+happens to be in scope.  Then you can+        import Prelude ()+        import MyPrelude as Prelude+to get the desired effect.++At the moment this just happens for+  * fromInteger, fromRational on literals (in expressions and patterns)+  * negate (in expressions)+  * minus  (arising from n+k patterns)+  * "do" notation++We store the relevant Name in the HsSyn tree, in+  * HsIntegral/HsFractional/HsIsString+  * NegApp+  * NPlusKPat+  * HsDo+respectively.  Initially, we just store the "standard" name (PrelNames.fromIntegralName,+fromRationalName etc), but the renamer changes this to the appropriate user+name if Opt_NoImplicitPrelude is on.  That is what lookupSyntaxName does.++We treat the original (standard) names as free-vars too, because the type checker+checks the type of the user thing against the type of the standard thing.+-}++lookupIfThenElse :: RnM (Maybe (SyntaxExpr Name), FreeVars)+-- Different to lookupSyntaxName because in the non-rebindable+-- case we desugar directly rather than calling an existing function+-- Hence the (Maybe (SyntaxExpr Name)) return type+lookupIfThenElse+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax+       ; if not rebindable_on+         then return (Nothing, emptyFVs)+         else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse"))+                 ; return ( Just (mkRnSyntaxExpr ite)+                          , unitFV ite ) } }++lookupSyntaxName' :: Name          -- ^ The standard name+                  -> RnM Name      -- ^ Possibly a non-standard name+lookupSyntaxName' std_name+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax+       ; if not rebindable_on then+           return std_name+         else+            -- Get the similarly named thing from the local environment+           lookupOccRn (mkRdrUnqual (nameOccName std_name)) }++lookupSyntaxName :: Name                                -- The standard name+                 -> RnM (SyntaxExpr Name, FreeVars)     -- Possibly a non-standard name+lookupSyntaxName std_name+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax+       ; if not rebindable_on then+           return (mkRnSyntaxExpr std_name, emptyFVs)+         else+            -- Get the similarly named thing from the local environment+           do { usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name))+              ; return (mkRnSyntaxExpr usr_name, unitFV usr_name) } }++lookupSyntaxNames :: [Name]                          -- Standard names+                  -> RnM ([HsExpr Name], FreeVars)   -- See comments with HsExpr.ReboundNames+   -- this works with CmdTop, which wants HsExprs, not SyntaxExprs+lookupSyntaxNames std_names+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax+       ; if not rebindable_on then+             return (map (HsVar . noLoc) std_names, emptyFVs)+        else+          do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names+             ; return (map (HsVar . noLoc) usr_names, mkFVs usr_names) } }++{-+*********************************************************+*                                                      *+\subsection{Binding}+*                                                      *+*********************************************************+-}++newLocalBndrRn :: Located RdrName -> RnM Name+-- Used for non-top-level binders.  These should+-- never be qualified.+newLocalBndrRn (L loc rdr_name)+  | Just name <- isExact_maybe rdr_name+  = return name -- This happens in code generated by Template Haskell+                -- See Note [Binders in Template Haskell] in Convert.hs+  | otherwise+  = do { unless (isUnqual rdr_name)+                (addErrAt loc (badQualBndrErr rdr_name))+       ; uniq <- newUnique+       ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }++newLocalBndrsRn :: [Located RdrName] -> RnM [Name]+newLocalBndrsRn = mapM newLocalBndrRn++---------------------+bindLocatedLocalsRn :: [Located RdrName]+                    -> ([Name] -> RnM a)+                    -> RnM a+bindLocatedLocalsRn rdr_names_w_loc enclosed_scope+  = do { checkDupRdrNames rdr_names_w_loc+       ; checkShadowedRdrNames rdr_names_w_loc++        -- Make fresh Names and extend the environment+       ; names <- newLocalBndrsRn rdr_names_w_loc+       ; bindLocalNames names (enclosed_scope names) }++bindLocalNames :: [Name] -> RnM a -> RnM a+bindLocalNames names enclosed_scope+  = do { lcl_env <- getLclEnv+       ; let th_level  = thLevel (tcl_th_ctxt lcl_env)+             th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env)+                           [ (n, (NotTopLevel, th_level)) | n <- names ]+             rdr_env'  = extendLocalRdrEnvList (tcl_rdr lcl_env) names+       ; setLclEnv (lcl_env { tcl_th_bndrs = th_bndrs'+                            , tcl_rdr      = rdr_env' })+                    enclosed_scope }++bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)+bindLocalNamesFV names enclosed_scope+  = do  { (result, fvs) <- bindLocalNames names enclosed_scope+        ; return (result, delFVs names fvs) }+++-------------------------------------+        -- binLocalsFVRn is the same as bindLocalsRn+        -- except that it deals with free vars+bindLocatedLocalsFV :: [Located RdrName]+                    -> ([Name] -> RnM (a,FreeVars)) -> RnM (a, FreeVars)+bindLocatedLocalsFV rdr_names enclosed_scope+  = bindLocatedLocalsRn rdr_names       $ \ names ->+    do (thing, fvs) <- enclosed_scope names+       return (thing, delFVs names fvs)++-------------------------------------++extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)+        -- This function is used only in rnSourceDecl on InstDecl+extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside++-------------------------------------+checkDupRdrNames :: [Located RdrName] -> RnM ()+-- Check for duplicated names in a binding group+checkDupRdrNames rdr_names_w_loc+  = mapM_ (dupNamesErr getLoc) dups+  where+    (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc++checkDupNames :: [Name] -> RnM ()+-- Check for duplicated names in a binding group+checkDupNames names = check_dup_names (filterOut isSystemName names)+                -- See Note [Binders in Template Haskell] in Convert++check_dup_names :: [Name] -> RnM ()+check_dup_names names+  = mapM_ (dupNamesErr nameSrcSpan) dups+  where+    (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names++---------------------+checkShadowedRdrNames :: [Located RdrName] -> RnM ()+checkShadowedRdrNames loc_rdr_names+  = do { envs <- getRdrEnvs+       ; checkShadowedOccs envs get_loc_occ filtered_rdrs }+  where+    filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names+                -- See Note [Binders in Template Haskell] in Convert+    get_loc_occ (L loc rdr) = (loc,rdrNameOcc rdr)++checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM ()+checkDupAndShadowedNames envs names+  = do { check_dup_names filtered_names+       ; checkShadowedOccs envs get_loc_occ filtered_names }+  where+    filtered_names = filterOut isSystemName names+                -- See Note [Binders in Template Haskell] in Convert+    get_loc_occ name = (nameSrcSpan name, nameOccName name)++-------------------------------------+checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv)+                  -> (a -> (SrcSpan, OccName))+                  -> [a] -> RnM ()+checkShadowedOccs (global_env,local_env) get_loc_occ ns+  = whenWOptM Opt_WarnNameShadowing $+    do  { traceRn "checkShadowedOccs:shadow" (ppr (map get_loc_occ ns))+        ; mapM_ check_shadow ns }+  where+    check_shadow n+        | startsWithUnderscore occ = return ()  -- Do not report shadowing for "_x"+                                                -- See Trac #3262+        | Just n <- mb_local = complain [text "bound at" <+> ppr (nameSrcLoc n)]+        | otherwise = do { gres' <- filterM is_shadowed_gre gres+                         ; complain (map pprNameProvenance gres') }+        where+          (loc,occ) = get_loc_occ n+          mb_local  = lookupLocalRdrOcc local_env occ+          gres      = lookupGRE_RdrName (mkRdrUnqual occ) global_env+                -- Make an Unqualified RdrName and look that up, so that+                -- we don't find any GREs that are in scope qualified-only++          complain []      = return ()+          complain pp_locs = addWarnAt (Reason Opt_WarnNameShadowing)+                                       loc+                                       (shadowedNameWarn occ pp_locs)++    is_shadowed_gre :: GlobalRdrElt -> RnM Bool+        -- Returns False for record selectors that are shadowed, when+        -- punning or wild-cards are on (cf Trac #2723)+    is_shadowed_gre gre | isRecFldGRE gre+        = do { dflags <- getDynFlags+             ; return $ not (xopt LangExt.RecordPuns dflags+                             || xopt LangExt.RecordWildCards dflags) }+    is_shadowed_gre _other = return True++{-+************************************************************************+*                                                                      *+               What to do when a lookup fails+*                                                                      *+************************************************************************+-}++data WhereLooking = WL_Any        -- Any binding+                  | WL_Global     -- Any top-level binding (local or imported)+                  | WL_LocalTop   -- Any top-level binding in this module++reportUnboundName :: RdrName -> RnM Name+reportUnboundName rdr = unboundName WL_Any rdr++unboundName :: WhereLooking -> RdrName -> RnM Name+unboundName wl rdr = unboundNameX wl rdr Outputable.empty++unboundNameX :: WhereLooking -> RdrName -> SDoc -> RnM Name+unboundNameX where_look rdr_name extra+  = do  { dflags <- getDynFlags+        ; let show_helpful_errors = gopt Opt_HelpfulErrors dflags+              what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))+              err = unknownNameErr what rdr_name $$ extra+        ; if not show_helpful_errors+          then addErr err+          else do { local_env  <- getLocalRdrEnv+                  ; global_env <- getGlobalRdrEnv+                  ; impInfo <- getImports+                  ; let suggestions = unknownNameSuggestions_ where_look+                                        dflags global_env local_env impInfo rdr_name+                  ; addErr (err $$ suggestions) }+        ; return (mkUnboundNameRdr rdr_name) }++unknownNameErr :: SDoc -> RdrName -> SDoc+unknownNameErr what rdr_name+  = vcat [ hang (text "Not in scope:")+              2 (what <+> quotes (ppr rdr_name))+         , extra ]+  where+    extra | rdr_name == forall_tv_RDR = perhapsForallMsg+          | otherwise                 = Outputable.empty++type HowInScope = Either SrcSpan ImpDeclSpec+     -- Left loc    =>  locally bound at loc+     -- Right ispec =>  imported as specified by ispec+++-- | Called from the typechecker (TcErrors) when we find an unbound variable+unknownNameSuggestions :: DynFlags+                       -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails+                       -> RdrName -> SDoc+unknownNameSuggestions = unknownNameSuggestions_ WL_Any++unknownNameSuggestions_ :: WhereLooking -> DynFlags+                       -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails+                       -> RdrName -> SDoc+unknownNameSuggestions_ where_look dflags global_env local_env imports tried_rdr_name =+    similarNameSuggestions where_look dflags global_env local_env tried_rdr_name $$+    importSuggestions dflags imports tried_rdr_name+++similarNameSuggestions :: WhereLooking -> DynFlags+                        -> GlobalRdrEnv -> LocalRdrEnv+                        -> RdrName -> SDoc+similarNameSuggestions where_look dflags global_env+                        local_env tried_rdr_name+  = case suggest of+      []  -> Outputable.empty+      [p] -> perhaps <+> pp_item p+      ps  -> sep [ perhaps <+> text "one of these:"+                 , nest 2 (pprWithCommas pp_item ps) ]+  where+    all_possibilities :: [(String, (RdrName, HowInScope))]+    all_possibilities+       =  [ (showPpr dflags r, (r, Left loc))+          | (r,loc) <- local_possibilities local_env ]+       ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ]++    suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities+    perhaps = text "Perhaps you meant"++    pp_item :: (RdrName, HowInScope) -> SDoc+    pp_item (rdr, Left loc) = pp_ns rdr <+> quotes (ppr rdr) <+> loc' -- Locally defined+        where loc' = case loc of+                     UnhelpfulSpan l -> parens (ppr l)+                     RealSrcSpan l -> parens (text "line" <+> int (srcSpanStartLine l))+    pp_item (rdr, Right is) = pp_ns rdr <+> quotes (ppr rdr) <+>   -- Imported+                              parens (text "imported from" <+> ppr (is_mod is))++    pp_ns :: RdrName -> SDoc+    pp_ns rdr | ns /= tried_ns = pprNameSpace ns+              | otherwise      = Outputable.empty+      where ns = rdrNameSpace rdr++    tried_occ     = rdrNameOcc tried_rdr_name+    tried_is_sym  = isSymOcc tried_occ+    tried_ns      = occNameSpace tried_occ+    tried_is_qual = isQual tried_rdr_name++    correct_name_space occ =  nameSpacesRelated (occNameSpace occ) tried_ns+                           && isSymOcc occ == tried_is_sym+        -- Treat operator and non-operators as non-matching+        -- This heuristic avoids things like+        --      Not in scope 'f'; perhaps you meant '+' (from Prelude)++    local_ok = case where_look of { WL_Any -> True; _ -> False }+    local_possibilities :: LocalRdrEnv -> [(RdrName, SrcSpan)]+    local_possibilities env+      | tried_is_qual = []+      | not local_ok  = []+      | otherwise     = [ (mkRdrUnqual occ, nameSrcSpan name)+                        | name <- localRdrEnvElts env+                        , let occ = nameOccName name+                        , correct_name_space occ]++    gre_ok :: GlobalRdrElt -> Bool+    gre_ok = case where_look of+                   WL_LocalTop -> isLocalGRE+                   _           -> \_ -> True++    global_possibilities :: GlobalRdrEnv -> [(RdrName, (RdrName, HowInScope))]+    global_possibilities global_env+      | tried_is_qual = [ (rdr_qual, (rdr_qual, how))+                        | gre <- globalRdrEnvElts global_env+                        , gre_ok gre+                        , let name = gre_name gre+                              occ  = nameOccName name+                        , correct_name_space occ+                        , (mod, how) <- quals_in_scope gre+                        , let rdr_qual = mkRdrQual mod occ ]++      | otherwise = [ (rdr_unqual, pair)+                    | gre <- globalRdrEnvElts global_env+                    , gre_ok gre+                    , let name = gre_name gre+                          occ  = nameOccName name+                          rdr_unqual = mkRdrUnqual occ+                    , correct_name_space occ+                    , pair <- case (unquals_in_scope gre, quals_only gre) of+                                (how:_, _)    -> [ (rdr_unqual, how) ]+                                ([],    pr:_) -> [ pr ]  -- See Note [Only-quals]+                                ([],    [])   -> [] ]++              -- Note [Only-quals]+              -- The second alternative returns those names with the same+              -- OccName as the one we tried, but live in *qualified* imports+              -- e.g. if you have:+              --+              -- > import qualified Data.Map as Map+              -- > foo :: Map+              --+              -- then we suggest @Map.Map@.++    --------------------+    unquals_in_scope :: GlobalRdrElt -> [HowInScope]+    unquals_in_scope (GRE { gre_name = n, gre_lcl = lcl, gre_imp = is })+      | lcl       = [ Left (nameSrcSpan n) ]+      | otherwise = [ Right ispec+                    | i <- is, let ispec = is_decl i+                    , not (is_qual ispec) ]++    --------------------+    quals_in_scope :: GlobalRdrElt -> [(ModuleName, HowInScope)]+    -- Ones for which the qualified version is in scope+    quals_in_scope (GRE { gre_name = n, gre_lcl = lcl, gre_imp = is })+      | lcl = case nameModule_maybe n of+                Nothing -> []+                Just m  -> [(moduleName m, Left (nameSrcSpan n))]+      | otherwise = [ (is_as ispec, Right ispec)+                    | i <- is, let ispec = is_decl i ]++    --------------------+    quals_only :: GlobalRdrElt -> [(RdrName, HowInScope)]+    -- Ones for which *only* the qualified version is in scope+    quals_only (GRE { gre_name = n, gre_imp = is })+      = [ (mkRdrQual (is_as ispec) (nameOccName n), Right ispec)+        | i <- is, let ispec = is_decl i, is_qual ispec ]++-- | Generate helpful suggestions if a qualified name Mod.foo is not in scope.+importSuggestions :: DynFlags -> ImportAvails -> RdrName -> SDoc+importSuggestions _dflags imports rdr_name+  | not (isQual rdr_name || isUnqual rdr_name) = Outputable.empty+  | null interesting_imports+  , Just name <- mod_name+  = hsep+      [ text "No module named"+      , quotes (ppr name)+      , text "is imported."+      ]+  | is_qualified+  , null helpful_imports+  , [(mod,_)] <- interesting_imports+  = hsep+      [ text "Module"+      , quotes (ppr mod)+      , text "does not export"+      , quotes (ppr occ_name) <> dot+      ]+  | is_qualified+  , null helpful_imports+  , mods <- map fst interesting_imports+  = hsep+      [ text "Neither"+      , quotedListWithNor (map ppr mods)+      , text "exports"+      , quotes (ppr occ_name) <> dot+      ]+  | [(mod,imv)] <- helpful_imports_non_hiding+  = fsep+      [ text "Perhaps you want to add"+      , quotes (ppr occ_name)+      , text "to the import list"+      , text "in the import of"+      , quotes (ppr mod)+      , parens (ppr (imv_span imv)) <> dot+      ]+  | not (null helpful_imports_non_hiding)+  = fsep+      [ text "Perhaps you want to add"+      , quotes (ppr occ_name)+      , text "to one of these import lists:"+      ]+    $$+    nest 2 (vcat+        [ quotes (ppr mod) <+> parens (ppr (imv_span imv))+        | (mod,imv) <- helpful_imports_non_hiding+        ])+  | [(mod,imv)] <- helpful_imports_hiding+  = fsep+      [ text "Perhaps you want to remove"+      , quotes (ppr occ_name)+      , text "from the explicit hiding list"+      , text "in the import of"+      , quotes (ppr mod)+      , parens (ppr (imv_span imv)) <> dot+      ]+  | not (null helpful_imports_hiding)+  = fsep+      [ text "Perhaps you want to remove"+      , quotes (ppr occ_name)+      , text "from the hiding clauses"+      , text "in one of these imports:"+      ]+    $$+    nest 2 (vcat+        [ quotes (ppr mod) <+> parens (ppr (imv_span imv))+        | (mod,imv) <- helpful_imports_hiding+        ])+  | otherwise+  = Outputable.empty+ where+  is_qualified = isQual rdr_name+  (mod_name, occ_name) = case rdr_name of+    Unqual occ_name        -> (Nothing, occ_name)+    Qual mod_name occ_name -> (Just mod_name, occ_name)+    _                      -> error "importSuggestions: dead code"+++  -- What import statements provide "Mod" at all+  -- or, if this is an unqualified name, are not qualified imports+  interesting_imports = [ (mod, imp)+    | (mod, mod_imports) <- moduleEnvToList (imp_mods imports)+    , Just imp <- return $ pick (importedByUser mod_imports)+    ]++  -- We want to keep only one for each original module; preferably one with an+  -- explicit import list (for no particularly good reason)+  pick :: [ImportedModsVal] -> Maybe ImportedModsVal+  pick = listToMaybe . sortBy (compare `on` prefer) . filter select+    where select imv = case mod_name of Just name -> imv_name imv == name+                                        Nothing   -> not (imv_qualified imv)+          prefer imv = (imv_is_hiding imv, imv_span imv)++  -- Which of these would export a 'foo'+  -- (all of these are restricted imports, because if they were not, we+  -- wouldn't have an out-of-scope error in the first place)+  helpful_imports = filter helpful interesting_imports+    where helpful (_,imv)+            = not . null $ lookupGlobalRdrEnv (imv_all_exports imv) occ_name++  -- Which of these do that because of an explicit hiding list resp. an+  -- explicit import list+  (helpful_imports_hiding, helpful_imports_non_hiding)+    = partition (imv_is_hiding . snd) helpful_imports++{-+************************************************************************+*                                                                      *+\subsection{Free variable manipulation}+*                                                                      *+************************************************************************+-}++-- A useful utility+addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars)+addFvRn fvs1 thing_inside = do { (res, fvs2) <- thing_inside+                               ; return (res, fvs1 `plusFV` fvs2) }++mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)+mapFvRn f xs = do stuff <- mapM f xs+                  case unzip stuff of+                      (ys, fvs_s) -> return (ys, plusFVs fvs_s)++mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars)+mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs)+mapMaybeFvRn f (Just x) = do { (y, fvs) <- f x; return (Just y, fvs) }++-- because some of the rename functions are CPSed:+-- maps the function across the list from left to right;+-- collects all the free vars into one set+mapFvRnCPS :: (a  -> (b   -> RnM c) -> RnM c)+           -> [a] -> ([b] -> RnM c) -> RnM c++mapFvRnCPS _ []     cont = cont []+mapFvRnCPS f (x:xs) cont = f x             $ \ x' ->+                           mapFvRnCPS f xs $ \ xs' ->+                           cont (x':xs')++{-+************************************************************************+*                                                                      *+\subsection{Envt utility functions}+*                                                                      *+************************************************************************+-}++warnUnusedTopBinds :: [GlobalRdrElt] -> RnM ()+warnUnusedTopBinds gres+    = whenWOptM Opt_WarnUnusedTopBinds+    $ do env <- getGblEnv+         let isBoot = tcg_src env == HsBootFile+         let noParent gre = case gre_par gre of+                            NoParent -> True+                            _        -> False+             -- Don't warn about unused bindings with parents in+             -- .hs-boot files, as you are sometimes required to give+             -- unused bindings (trac #3449).+             -- HOWEVER, in a signature file, you are never obligated to put a+             -- definition in the main text.  Thus, if you define something+             -- and forget to export it, we really DO want to warn.+             gres' = if isBoot then filter noParent gres+                               else                 gres+         warnUnusedGREs gres'++warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns+  :: [Name] -> FreeVars -> RnM ()+warnUnusedLocalBinds   = check_unused Opt_WarnUnusedLocalBinds+warnUnusedMatches      = check_unused Opt_WarnUnusedMatches+warnUnusedTypePatterns = check_unused Opt_WarnUnusedTypePatterns++check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM ()+check_unused flag bound_names used_names+  = whenWOptM flag (warnUnused flag (filterOut (`elemNameSet` used_names)+                                               bound_names))++-------------------------+--      Helpers+warnUnusedGREs :: [GlobalRdrElt] -> RnM ()+warnUnusedGREs gres = mapM_ warnUnusedGRE gres++warnUnused :: WarningFlag -> [Name] -> RnM ()+warnUnused flag names = do+    fld_env <- mkFieldEnv <$> getGlobalRdrEnv+    mapM_ (warnUnused1 flag fld_env) names++warnUnused1 :: WarningFlag -> NameEnv (FieldLabelString, Name) -> Name -> RnM ()+warnUnused1 flag fld_env name+  = when (reportable name occ) $+    addUnusedWarning flag+                     occ (nameSrcSpan name)+                     (text "Defined but not used")+  where+    occ = case lookupNameEnv fld_env name of+              Just (fl, _) -> mkVarOccFS fl+              Nothing      -> nameOccName name++warnUnusedGRE :: GlobalRdrElt -> RnM ()+warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is })+  | lcl       = do fld_env <- mkFieldEnv <$> getGlobalRdrEnv+                   warnUnused1 Opt_WarnUnusedTopBinds fld_env name+  | otherwise = when (reportable name occ) (mapM_ warn is)+  where+    occ = greOccName gre+    warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg+        where+           span = importSpecLoc spec+           pp_mod = quotes (ppr (importSpecModule spec))+           msg = text "Imported from" <+> pp_mod <+> ptext (sLit "but not used")++-- | Make a map from selector names to field labels and parent tycon+-- names, to be used when reporting unused record fields.+mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Name)+mkFieldEnv rdr_env = mkNameEnv [ (gre_name gre, (lbl, par_is (gre_par gre)))+                               | gres <- occEnvElts rdr_env+                               , gre <- gres+                               , Just lbl <- [greLabel gre]+                               ]++-- | Should we report the fact that this 'Name' is unused? The+-- 'OccName' may differ from 'nameOccName' due to+-- DuplicateRecordFields.+reportable :: Name -> OccName -> Bool+reportable name occ+  | isWiredInName name = False    -- Don't report unused wired-in names+                                  -- Otherwise we get a zillion warnings+                                  -- from Data.Tuple+  | otherwise = not (startsWithUnderscore occ)++addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM ()+addUnusedWarning flag occ span msg+  = addWarnAt (Reason flag) span $+    sep [msg <> colon,+         nest 2 $ pprNonVarNameSpace (occNameSpace occ)+                        <+> quotes (ppr occ)]++addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM ()+addNameClashErrRn rdr_name gres+  | all isLocalGRE gres && not (all isRecFldGRE gres)+               -- If there are two or more *local* defns, we'll have reported+  = return ()  -- that already, and we don't want an error cascade+  | otherwise+  = addErr (vcat [text "Ambiguous occurrence" <+> quotes (ppr rdr_name),+                  text "It could refer to" <+> vcat (msg1 : msgs)])+  where+    (np1:nps) = gres+    msg1 = ptext  (sLit "either") <+> mk_ref np1+    msgs = [text "    or" <+> mk_ref np | np <- nps]+    mk_ref gre = sep [nom <> comma, pprNameProvenance gre]+      where nom = case gre_par gre of+                    FldParent { par_lbl = Just lbl } -> text "the field" <+> quotes (ppr lbl)+                    _                                -> quotes (ppr (gre_name gre))++shadowedNameWarn :: OccName -> [SDoc] -> SDoc+shadowedNameWarn occ shadowed_locs+  = sep [text "This binding for" <+> quotes (ppr occ)+            <+> text "shadows the existing binding" <> plural shadowed_locs,+         nest 2 (vcat shadowed_locs)]++perhapsForallMsg :: SDoc+perhapsForallMsg+  = vcat [ text "Perhaps you intended to use ExplicitForAll or similar flag"+         , text "to enable explicit-forall syntax: forall <tvs>. <type>"]++unknownSubordinateErr :: SDoc -> RdrName -> SDoc+unknownSubordinateErr doc op    -- Doc is "method of class" or+                                -- "field of constructor"+  = quotes (ppr op) <+> text "is not a (visible)" <+> doc++badOrigBinding :: RdrName -> SDoc+badOrigBinding name+  = text "Illegal binding of built-in syntax:" <+> ppr (rdrNameOcc name)+        -- The rdrNameOcc is because we don't want to print Prelude.(,)++dupNamesErr :: Outputable n => (n -> SrcSpan) -> [n] -> RnM ()+dupNamesErr get_loc names+  = addErrAt big_loc $+    vcat [text "Conflicting definitions for" <+> quotes (ppr (head names)),+          locations]+  where+    locs      = map get_loc names+    big_loc   = foldr1 combineSrcSpans locs+    locations = text "Bound at:" <+> vcat (map ppr (sort locs))++kindSigErr :: Outputable a => a -> SDoc+kindSigErr thing+  = hang (text "Illegal kind signature for" <+> quotes (ppr thing))+       2 (text "Perhaps you intended to use KindSignatures")++badQualBndrErr :: RdrName -> SDoc+badQualBndrErr rdr_name+  = text "Qualified name in binding position:" <+> ppr rdr_name++opDeclErr :: RdrName -> SDoc+opDeclErr n+  = hang (text "Illegal declaration of a type or class operator" <+> quotes (ppr n))+       2 (text "Use TypeOperators to declare operators in type and declarations")++checkTupSize :: Int -> RnM ()+checkTupSize tup_size+  | tup_size <= mAX_TUPLE_SIZE+  = return ()+  | otherwise+  = addErr (sep [text "A" <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"),+                 nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)),+                 nest 2 (text "Workaround: use nested tuples or define a data type")])++{-+************************************************************************+*                                                                      *+\subsection{Contexts for renaming errors}+*                                                                      *+************************************************************************+-}++-- AZ:TODO: Change these all to be Name instead of RdrName.+--          Merge TcType.UserTypeContext in to it.+data HsDocContext+  = TypeSigCtx SDoc+  | PatCtx+  | SpecInstSigCtx+  | DefaultDeclCtx+  | ForeignDeclCtx (Located RdrName)+  | DerivDeclCtx+  | RuleCtx FastString+  | TyDataCtx (Located RdrName)+  | TySynCtx (Located RdrName)+  | TyFamilyCtx (Located RdrName)+  | FamPatCtx (Located RdrName)    -- The patterns of a type/data family instance+  | ConDeclCtx [Located Name]+  | ClassDeclCtx (Located RdrName)+  | ExprWithTySigCtx+  | TypBrCtx+  | HsTypeCtx+  | GHCiCtx+  | SpliceTypeCtx (LHsType RdrName)+  | ClassInstanceCtx+  | VectDeclCtx (Located RdrName)+  | GenericCtx SDoc   -- Maybe we want to use this more!++withHsDocContext :: HsDocContext -> SDoc -> SDoc+withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt++inHsDocContext :: HsDocContext -> SDoc+inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt++pprHsDocContext :: HsDocContext -> SDoc+pprHsDocContext (GenericCtx doc)      = doc+pprHsDocContext (TypeSigCtx doc)      = text "the type signature for" <+> doc+pprHsDocContext PatCtx                = text "a pattern type-signature"+pprHsDocContext SpecInstSigCtx        = text "a SPECIALISE instance pragma"+pprHsDocContext DefaultDeclCtx        = text "a `default' declaration"+pprHsDocContext DerivDeclCtx          = text "a deriving declaration"+pprHsDocContext (RuleCtx name)        = text "the transformation rule" <+> ftext name+pprHsDocContext (TyDataCtx tycon)     = text "the data type declaration for" <+> quotes (ppr tycon)+pprHsDocContext (FamPatCtx tycon)     = text "a type pattern of family instance for" <+> quotes (ppr tycon)+pprHsDocContext (TySynCtx name)       = text "the declaration for type synonym" <+> quotes (ppr name)+pprHsDocContext (TyFamilyCtx name)    = text "the declaration for type family" <+> quotes (ppr name)+pprHsDocContext (ClassDeclCtx name)   = text "the declaration for class" <+> quotes (ppr name)+pprHsDocContext ExprWithTySigCtx      = text "an expression type signature"+pprHsDocContext TypBrCtx              = text "a Template-Haskell quoted type"+pprHsDocContext HsTypeCtx             = text "a type argument"+pprHsDocContext GHCiCtx               = text "GHCi input"+pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty)+pprHsDocContext ClassInstanceCtx      = text "TcSplice.reifyInstances"++pprHsDocContext (ForeignDeclCtx name)+   = text "the foreign declaration for" <+> quotes (ppr name)+pprHsDocContext (ConDeclCtx [name])+   = text "the definition of data constructor" <+> quotes (ppr name)+pprHsDocContext (ConDeclCtx names)+   = text "the definition of data constructors" <+> interpp'SP names+pprHsDocContext (VectDeclCtx tycon)+   = text "the VECTORISE pragma for type constructor" <+> quotes (ppr tycon)
+ rename/RnExpr.hs view
@@ -0,0 +1,2064 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[RnExpr]{Renaming of expressions}++Basically dependency analysis.++Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes.  In+general, all of these functions return a renamed thing, and a set of+free variables.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiWayIf #-}++module RnExpr (+        rnLExpr, rnExpr, rnStmts+   ) where++#include "HsVersions.h"++import RnBinds   ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,+                   rnMatchGroup, rnGRHS, makeMiniFixityEnv)+import HsSyn+import TcRnMonad+import Module           ( getModule )+import RnEnv+import RnSplice         ( rnBracket, rnSpliceExpr, checkThLocalName )+import RnTypes+import RnPat+import DynFlags+import PrelNames++import BasicTypes+import Name+import NameSet+import RdrName+import UniqSet+import Data.List+import Util+import ListSetOps       ( removeDups )+import ErrUtils+import Outputable+import SrcLoc+import FastString+import Control.Monad+import TysWiredIn       ( nilDataConName )+import qualified GHC.LanguageExtensions as LangExt++import Data.Ord+import Data.Array++{-+************************************************************************+*                                                                      *+\subsubsection{Expressions}+*                                                                      *+************************************************************************+-}++rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars)+rnExprs ls = rnExprs' ls emptyUniqSet+ where+  rnExprs' [] acc = return ([], acc)+  rnExprs' (expr:exprs) acc =+   do { (expr', fvExpr) <- rnLExpr expr+        -- Now we do a "seq" on the free vars because typically it's small+        -- or empty, especially in very long lists of constants+      ; let  acc' = acc `plusFV` fvExpr+      ; (exprs', fvExprs) <- acc' `seq` rnExprs' exprs acc'+      ; return (expr':exprs', fvExprs) }++-- Variables. We look up the variable and return the resulting name.++rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)+rnLExpr = wrapLocFstM rnExpr++rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)++finishHsVar :: Located Name -> RnM (HsExpr Name, FreeVars)+-- Separated from rnExpr because it's also used+-- when renaming infix expressions+finishHsVar (L l name)+ = do { this_mod <- getModule+      ; when (nameIsLocalOrFrom this_mod name) $+        checkThLocalName name+      ; return (HsVar (L l name), unitFV name) }++rnUnboundVar :: RdrName -> RnM (HsExpr Name, FreeVars)+rnUnboundVar v+ = do { if isUnqual v+        then -- Treat this as a "hole"+             -- Do not fail right now; instead, return HsUnboundVar+             -- and let the type checker report the error+             do { let occ = rdrNameOcc v+                ; uv <- if startsWithUnderscore occ+                        then return (TrueExprHole occ)+                        else OutOfScope occ <$> getGlobalRdrEnv+                ; return (HsUnboundVar uv, emptyFVs) }++        else -- Fail immediately (qualified name)+             do { n <- reportUnboundName v+                ; return (HsVar (noLoc n), emptyFVs) } }++rnExpr (HsVar (L l v))+  = do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields+       ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v+       ; case mb_name of {+           Nothing -> rnUnboundVar v ;+           Just (Left name)+              | name == nilDataConName -- Treat [] as an ExplicitList, so that+                                       -- OverloadedLists works correctly+              -> rnExpr (ExplicitList placeHolderType Nothing [])++              | otherwise+              -> finishHsVar (L l name) ;+            Just (Right [f@(FieldOcc (L _ fn) s)]) ->+                      return (HsRecFld (ambiguousFieldOcc (FieldOcc (L l fn) s))+                             , unitFV (selectorFieldOcc f)) ;+           Just (Right fs@(_:_:_)) -> return (HsRecFld (Ambiguous (L l v)+                                                        PlaceHolder)+                                             , mkFVs (map selectorFieldOcc fs));+           Just (Right [])         -> panic "runExpr/HsVar" } }++rnExpr (HsIPVar v)+  = return (HsIPVar v, emptyFVs)++rnExpr (HsOverLabel _ v)+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax+       ; if rebindable_on+         then do { fromLabel <- lookupOccRn (mkVarUnqual (fsLit "fromLabel"))+                 ; return (HsOverLabel (Just fromLabel) v, unitFV fromLabel) }+         else return (HsOverLabel Nothing v, emptyFVs) }++rnExpr (HsLit lit@(HsString src s))+  = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings+       ; if opt_OverloadedStrings then+            rnExpr (HsOverLit (mkHsIsString src s placeHolderType))+         else do {+            ; rnLit lit+            ; return (HsLit lit, emptyFVs) } }++rnExpr (HsLit lit)+  = do { rnLit lit+       ; return (HsLit lit, emptyFVs) }++rnExpr (HsOverLit lit)+  = do { (lit', fvs) <- rnOverLit lit+       ; return (HsOverLit lit', fvs) }++rnExpr (HsApp fun arg)+  = do { (fun',fvFun) <- rnLExpr fun+       ; (arg',fvArg) <- rnLExpr arg+       ; return (HsApp fun' arg', fvFun `plusFV` fvArg) }++rnExpr (HsAppType fun arg)+  = do { (fun',fvFun) <- rnLExpr fun+       ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg+       ; return (HsAppType fun' arg', fvFun `plusFV` fvArg) }++rnExpr (OpApp e1 op  _ e2)+  = do  { (e1', fv_e1) <- rnLExpr e1+        ; (e2', fv_e2) <- rnLExpr e2+        ; (op', fv_op) <- rnLExpr op++        -- Deal with fixity+        -- When renaming code synthesised from "deriving" declarations+        -- we used to avoid fixity stuff, but we can't easily tell any+        -- more, so I've removed the test.  Adding HsPars in TcGenDeriv+        -- should prevent bad things happening.+        ; fixity <- case op' of+              L _ (HsVar (L _ n)) -> lookupFixityRn n+              L _ (HsRecFld f)    -> lookupFieldFixityRn f+              _ -> return (Fixity NoSourceText minPrecedence InfixL)+                   -- c.f. lookupFixity for unbound++        ; final_e <- mkOpAppRn e1' op' fixity e2'+        ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }++rnExpr (NegApp e _)+  = do { (e', fv_e)         <- rnLExpr e+       ; (neg_name, fv_neg) <- lookupSyntaxName negateName+       ; final_e            <- mkNegAppRn e' neg_name+       ; return (final_e, fv_e `plusFV` fv_neg) }++------------------------------------------+-- Template Haskell extensions+-- Don't ifdef-GHCI them because we want to fail gracefully+-- (not with an rnExpr crash) in a stage-1 compiler.+rnExpr e@(HsBracket br_body) = rnBracket e br_body++rnExpr (HsSpliceE splice) = rnSpliceExpr splice++---------------------------------------------+--      Sections+-- See Note [Parsing sections] in Parser.y+rnExpr (HsPar (L loc (section@(SectionL {}))))+  = do  { (section', fvs) <- rnSection section+        ; return (HsPar (L loc section'), fvs) }++rnExpr (HsPar (L loc (section@(SectionR {}))))+  = do  { (section', fvs) <- rnSection section+        ; return (HsPar (L loc section'), fvs) }++rnExpr (HsPar e)+  = do  { (e', fvs_e) <- rnLExpr e+        ; return (HsPar e', fvs_e) }++rnExpr expr@(SectionL {})+  = do  { addErr (sectionErr expr); rnSection expr }+rnExpr expr@(SectionR {})+  = do  { addErr (sectionErr expr); rnSection expr }++---------------------------------------------+rnExpr (HsCoreAnn src ann expr)+  = do { (expr', fvs_expr) <- rnLExpr expr+       ; return (HsCoreAnn src ann expr', fvs_expr) }++rnExpr (HsSCC src lbl expr)+  = do { (expr', fvs_expr) <- rnLExpr expr+       ; return (HsSCC src lbl expr', fvs_expr) }+rnExpr (HsTickPragma src info srcInfo expr)+  = do { (expr', fvs_expr) <- rnLExpr expr+       ; return (HsTickPragma src info srcInfo expr', fvs_expr) }++rnExpr (HsLam matches)+  = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches+       ; return (HsLam matches', fvMatch) }++rnExpr (HsLamCase matches)+  = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches+       ; return (HsLamCase matches', fvs_ms) }++rnExpr (HsCase expr matches)+  = do { (new_expr, e_fvs) <- rnLExpr expr+       ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches+       ; return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) }++rnExpr (HsLet (L l binds) expr)+  = rnLocalBindsAndThen binds $ \binds' _ -> do+      { (expr',fvExpr) <- rnLExpr expr+      ; return (HsLet (L l binds') expr', fvExpr) }++rnExpr (HsDo do_or_lc (L l stmts) _)+  = do  { ((stmts', _), fvs) <-+           rnStmtsWithPostProcessing do_or_lc rnLExpr+             postProcessStmtsForApplicativeDo stmts+             (\ _ -> return ((), emptyFVs))+        ; return ( HsDo do_or_lc (L l stmts') placeHolderType, fvs ) }++rnExpr (ExplicitList _ _  exps)+  = do  { opt_OverloadedLists <- xoptM LangExt.OverloadedLists+        ; (exps', fvs) <- rnExprs exps+        ; if opt_OverloadedLists+           then do {+            ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName+            ; return (ExplicitList placeHolderType (Just from_list_n_name) exps'+                     , fvs `plusFV` fvs') }+           else+            return  (ExplicitList placeHolderType Nothing exps', fvs) }++rnExpr (ExplicitPArr _ exps)+  = do { (exps', fvs) <- rnExprs exps+       ; return  (ExplicitPArr placeHolderType exps', fvs) }++rnExpr (ExplicitTuple tup_args boxity)+  = do { checkTupleSection tup_args+       ; checkTupSize (length tup_args)+       ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args+       ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }+  where+    rnTupArg (L l (Present e)) = do { (e',fvs) <- rnLExpr e+                                    ; return (L l (Present e'), fvs) }+    rnTupArg (L l (Missing _)) = return (L l (Missing placeHolderType)+                                        , emptyFVs)++rnExpr (ExplicitSum alt arity expr _)+  = do { (expr', fvs) <- rnLExpr expr+       ; return (ExplicitSum alt arity expr' PlaceHolder, fvs) }++rnExpr (RecordCon { rcon_con_name = con_id+                  , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })+  = do { con_lname@(L _ con_name) <- lookupLocatedOccRn con_id+       ; (flds, fvs)   <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds+       ; (flds', fvss) <- mapAndUnzipM rn_field flds+       ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }+       ; return (RecordCon { rcon_con_name = con_lname, rcon_flds = rec_binds'+                           , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder }+                , fvs `plusFV` plusFVs fvss `addOneFV` con_name) }+  where+    mk_hs_var l n = HsVar (L l n)+    rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)+                            ; return (L l (fld { hsRecFieldArg = arg' }), fvs) }++rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })+  = do  { (expr', fvExpr) <- rnLExpr expr+        ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds+        ; return (RecordUpd { rupd_expr = expr', rupd_flds = rbinds'+                            , rupd_cons    = PlaceHolder, rupd_in_tys = PlaceHolder+                            , rupd_out_tys = PlaceHolder, rupd_wrap   = PlaceHolder }+                 , fvExpr `plusFV` fvRbinds) }++rnExpr (ExprWithTySig expr pty)+  = do  { (pty', fvTy)    <- rnHsSigWcType ExprWithTySigCtx pty+        ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $+                             rnLExpr expr+        ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }++rnExpr (HsIf _ p b1 b2)+  = do { (p', fvP) <- rnLExpr p+       ; (b1', fvB1) <- rnLExpr b1+       ; (b2', fvB2) <- rnLExpr b2+       ; (mb_ite, fvITE) <- lookupIfThenElse+       ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }++rnExpr (HsMultiIf _ty alts)+  = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts+       -- ; return (HsMultiIf ty alts', fvs) }+       ; return (HsMultiIf placeHolderType alts', fvs) }++rnExpr (ArithSeq _ _ seq)+  = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists+       ; (new_seq, fvs) <- rnArithSeq seq+       ; if opt_OverloadedLists+           then do {+            ; (from_list_name, fvs') <- lookupSyntaxName fromListName+            ; return (ArithSeq noPostTcExpr (Just from_list_name) new_seq, fvs `plusFV` fvs') }+           else+            return (ArithSeq noPostTcExpr Nothing new_seq, fvs) }++rnExpr (PArrSeq _ seq)+  = do { (new_seq, fvs) <- rnArithSeq seq+       ; return (PArrSeq noPostTcExpr new_seq, fvs) }++{-+These three are pattern syntax appearing in expressions.+Since all the symbols are reservedops we can simply reject them.+We return a (bogus) EWildPat in each case.+-}++rnExpr EWildPat        = return (hsHoleExpr, emptyFVs)   -- "_" is just a hole+rnExpr e@(EAsPat {})+  = do { opt_TypeApplications <- xoptM LangExt.TypeApplications+       ; let msg | opt_TypeApplications+                    = "Type application syntax requires a space before '@'"+                 | otherwise+                    = "Did you mean to enable TypeApplications?"+       ; patSynErr e (text msg)+       }+rnExpr e@(EViewPat {}) = patSynErr e empty+rnExpr e@(ELazyPat {}) = patSynErr e empty++{-+************************************************************************+*                                                                      *+        Static values+*                                                                      *+************************************************************************++For the static form we check that the free variables are all top-level+value bindings. This is done by checking that the name is external or+wired-in. See the Notes about the NameSorts in Name.hs.+-}++rnExpr e@(HsStatic _ expr) = do+    (expr',fvExpr) <- rnLExpr expr+    stage <- getStage+    case stage of+      Splice _ -> addErr $ sep+             [ text "static forms cannot be used in splices:"+             , nest 2 $ ppr e+             ]+      _ -> return ()+    mod <- getModule+    let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr+    return (HsStatic fvExpr' expr', fvExpr)++{-+************************************************************************+*                                                                      *+        Arrow notation+*                                                                      *+************************************************************************+-}++rnExpr (HsProc pat body)+  = newArrowScope $+    rnPat ProcExpr pat $ \ pat' -> do+      { (body',fvBody) <- rnCmdTop body+      ; return (HsProc pat' body', fvBody) }++-- Ideally, these would be done in parsing, but to keep parsing simple, we do it here.+rnExpr e@(HsArrApp {})  = arrowFail e+rnExpr e@(HsArrForm {}) = arrowFail e++rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)+        -- HsWrap++hsHoleExpr :: HsExpr id+hsHoleExpr = HsUnboundVar (TrueExprHole (mkVarOcc "_"))++arrowFail :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)+arrowFail e+  = do { addErr (vcat [ text "Arrow command found where an expression was expected:"+                      , nest 2 (ppr e) ])+         -- Return a place-holder hole, so that we can carry on+         -- to report other errors+       ; return (hsHoleExpr, emptyFVs) }++----------------------+-- See Note [Parsing sections] in Parser.y+rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)+rnSection section@(SectionR op expr)+  = do  { (op', fvs_op)     <- rnLExpr op+        ; (expr', fvs_expr) <- rnLExpr expr+        ; checkSectionPrec InfixR section op' expr'+        ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }++rnSection section@(SectionL expr op)+  = do  { (expr', fvs_expr) <- rnLExpr expr+        ; (op', fvs_op)     <- rnLExpr op+        ; checkSectionPrec InfixL section op' expr'+        ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }++rnSection other = pprPanic "rnSection" (ppr other)++{-+************************************************************************+*                                                                      *+        Arrow commands+*                                                                      *+************************************************************************+-}++rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)+rnCmdArgs [] = return ([], emptyFVs)+rnCmdArgs (arg:args)+  = do { (arg',fvArg) <- rnCmdTop arg+       ; (args',fvArgs) <- rnCmdArgs args+       ; return (arg':args', fvArg `plusFV` fvArgs) }++rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)+rnCmdTop = wrapLocFstM rnCmdTop'+ where+  rnCmdTop' (HsCmdTop cmd _ _ _)+   = do { (cmd', fvCmd) <- rnLCmd cmd+        ; let cmd_names = [arrAName, composeAName, firstAName] +++                          nameSetElemsStable (methodNamesCmd (unLoc cmd'))+        -- Generate the rebindable syntax for the monad+        ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names++        ; return (HsCmdTop cmd' placeHolderType placeHolderType+                  (cmd_names `zip` cmd_names'),+                  fvCmd `plusFV` cmd_fvs) }++rnLCmd :: LHsCmd RdrName -> RnM (LHsCmd Name, FreeVars)+rnLCmd = wrapLocFstM rnCmd++rnCmd :: HsCmd RdrName -> RnM (HsCmd Name, FreeVars)++rnCmd (HsCmdArrApp arrow arg _ ho rtl)+  = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow)+       ; (arg',fvArg) <- rnLExpr arg+       ; return (HsCmdArrApp arrow' arg' placeHolderType ho rtl,+                 fvArrow `plusFV` fvArg) }+  where+    select_arrow_scope tc = case ho of+        HsHigherOrderApp -> tc+        HsFirstOrderApp  -> escapeArrowScope tc+        -- See Note [Escaping the arrow scope] in TcRnTypes+        -- Before renaming 'arrow', use the environment of the enclosing+        -- proc for the (-<) case.+        -- Local bindings, inside the enclosing proc, are not in scope+        -- inside 'arrow'.  In the higher-order case (-<<), they are.++-- infix form+rnCmd (HsCmdArrForm op _ (Just _) [arg1, arg2])+  = do { (op',fv_op) <- escapeArrowScope (rnLExpr op)+       ; let L _ (HsVar (L _ op_name)) = op'+       ; (arg1',fv_arg1) <- rnCmdTop arg1+       ; (arg2',fv_arg2) <- rnCmdTop arg2+        -- Deal with fixity+       ; fixity <- lookupFixityRn op_name+       ; final_e <- mkOpFormRn arg1' op' fixity arg2'+       ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) }++rnCmd (HsCmdArrForm op f fixity cmds)+  = do { (op',fvOp) <- escapeArrowScope (rnLExpr op)+       ; (cmds',fvCmds) <- rnCmdArgs cmds+       ; return (HsCmdArrForm op' f fixity cmds', fvOp `plusFV` fvCmds) }++rnCmd (HsCmdApp fun arg)+  = do { (fun',fvFun) <- rnLCmd  fun+       ; (arg',fvArg) <- rnLExpr arg+       ; return (HsCmdApp fun' arg', fvFun `plusFV` fvArg) }++rnCmd (HsCmdLam matches)+  = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches+       ; return (HsCmdLam matches', fvMatch) }++rnCmd (HsCmdPar e)+  = do  { (e', fvs_e) <- rnLCmd e+        ; return (HsCmdPar e', fvs_e) }++rnCmd (HsCmdCase expr matches)+  = do { (new_expr, e_fvs) <- rnLExpr expr+       ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches+       ; return (HsCmdCase new_expr new_matches, e_fvs `plusFV` ms_fvs) }++rnCmd (HsCmdIf _ p b1 b2)+  = do { (p', fvP) <- rnLExpr p+       ; (b1', fvB1) <- rnLCmd b1+       ; (b2', fvB2) <- rnLCmd b2+       ; (mb_ite, fvITE) <- lookupIfThenElse+       ; return (HsCmdIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }++rnCmd (HsCmdLet (L l binds) cmd)+  = rnLocalBindsAndThen binds $ \ binds' _ -> do+      { (cmd',fvExpr) <- rnLCmd cmd+      ; return (HsCmdLet (L l binds') cmd', fvExpr) }++rnCmd (HsCmdDo (L l stmts) _)+  = do  { ((stmts', _), fvs) <-+            rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs))+        ; return ( HsCmdDo (L l stmts') placeHolderType, fvs ) }++rnCmd cmd@(HsCmdWrap {}) = pprPanic "rnCmd" (ppr cmd)++---------------------------------------------------+type CmdNeeds = FreeVars        -- Only inhabitants are+                                --      appAName, choiceAName, loopAName++-- find what methods the Cmd needs (loop, choice, apply)+methodNamesLCmd :: LHsCmd Name -> CmdNeeds+methodNamesLCmd = methodNamesCmd . unLoc++methodNamesCmd :: HsCmd Name -> CmdNeeds++methodNamesCmd (HsCmdArrApp _arrow _arg _ HsFirstOrderApp _rtl)+  = emptyFVs+methodNamesCmd (HsCmdArrApp _arrow _arg _ HsHigherOrderApp _rtl)+  = unitFV appAName+methodNamesCmd (HsCmdArrForm {}) = emptyFVs+methodNamesCmd (HsCmdWrap _ cmd) = methodNamesCmd cmd++methodNamesCmd (HsCmdPar c) = methodNamesLCmd c++methodNamesCmd (HsCmdIf _ _ c1 c2)+  = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName++methodNamesCmd (HsCmdLet _ c)          = methodNamesLCmd c+methodNamesCmd (HsCmdDo (L _ stmts) _) = methodNamesStmts stmts+methodNamesCmd (HsCmdApp c _)          = methodNamesLCmd c+methodNamesCmd (HsCmdLam match)        = methodNamesMatch match++methodNamesCmd (HsCmdCase _ matches)+  = methodNamesMatch matches `addOneFV` choiceAName++--methodNamesCmd _ = emptyFVs+   -- Other forms can't occur in commands, but it's not convenient+   -- to error here so we just do what's convenient.+   -- The type checker will complain later++---------------------------------------------------+methodNamesMatch :: MatchGroup Name (LHsCmd Name) -> FreeVars+methodNamesMatch (MG { mg_alts = L _ ms })+  = plusFVs (map do_one ms)+ where+    do_one (L _ (Match _ _ _ grhss)) = methodNamesGRHSs grhss++-------------------------------------------------+-- gaw 2004+methodNamesGRHSs :: GRHSs Name (LHsCmd Name) -> FreeVars+methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)++-------------------------------------------------++methodNamesGRHS :: Located (GRHS Name (LHsCmd Name)) -> CmdNeeds+methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs++---------------------------------------------------+methodNamesStmts :: [Located (StmtLR Name Name (LHsCmd Name))] -> FreeVars+methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)++---------------------------------------------------+methodNamesLStmt :: Located (StmtLR Name Name (LHsCmd Name)) -> FreeVars+methodNamesLStmt = methodNamesStmt . unLoc++methodNamesStmt :: StmtLR Name Name (LHsCmd Name) -> FreeVars+methodNamesStmt (LastStmt cmd _ _)               = methodNamesLCmd cmd+methodNamesStmt (BodyStmt cmd _ _ _)             = methodNamesLCmd cmd+methodNamesStmt (BindStmt _ cmd _ _ _)           = methodNamesLCmd cmd+methodNamesStmt (RecStmt { recS_stmts = stmts }) =+  methodNamesStmts stmts `addOneFV` loopAName+methodNamesStmt (LetStmt {})                     = emptyFVs+methodNamesStmt (ParStmt {})                     = emptyFVs+methodNamesStmt (TransStmt {})                   = emptyFVs+methodNamesStmt ApplicativeStmt{}            = emptyFVs+   -- ParStmt and TransStmt can't occur in commands, but it's not+   -- convenient to error here so we just do what's convenient++{-+************************************************************************+*                                                                      *+        Arithmetic sequences+*                                                                      *+************************************************************************+-}++rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)+rnArithSeq (From expr)+ = do { (expr', fvExpr) <- rnLExpr expr+      ; return (From expr', fvExpr) }++rnArithSeq (FromThen expr1 expr2)+ = do { (expr1', fvExpr1) <- rnLExpr expr1+      ; (expr2', fvExpr2) <- rnLExpr expr2+      ; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) }++rnArithSeq (FromTo expr1 expr2)+ = do { (expr1', fvExpr1) <- rnLExpr expr1+      ; (expr2', fvExpr2) <- rnLExpr expr2+      ; return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) }++rnArithSeq (FromThenTo expr1 expr2 expr3)+ = do { (expr1', fvExpr1) <- rnLExpr expr1+      ; (expr2', fvExpr2) <- rnLExpr expr2+      ; (expr3', fvExpr3) <- rnLExpr expr3+      ; return (FromThenTo expr1' expr2' expr3',+                plusFVs [fvExpr1, fvExpr2, fvExpr3]) }++{-+************************************************************************+*                                                                      *+\subsubsection{@Stmt@s: in @do@ expressions}+*                                                                      *+************************************************************************+-}++{-+Note [Deterministic ApplicativeDo and RecursiveDo desugaring]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Both ApplicativeDo and RecursiveDo need to create tuples not+present in the source text.++For ApplicativeDo we create:++  (a,b,c) <- (\c b a -> (a,b,c)) <$>++For RecursiveDo we create:++  mfix (\ ~(a,b,c) -> do ...; return (a',b',c'))++The order of the components in those tuples needs to be stable+across recompilations, otherwise they can get optimized differently+and we end up with incompatible binaries.+To get a stable order we use nameSetElemsStable.+See Note [Deterministic UniqFM] to learn more about nondeterminism.+-}++-- | Rename some Stmts+rnStmts :: Outputable (body RdrName)+        => HsStmtContext Name+        -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))+           -- ^ How to rename the body of each statement (e.g. rnLExpr)+        -> [LStmt RdrName (Located (body RdrName))]+           -- ^ Statements+        -> ([Name] -> RnM (thing, FreeVars))+           -- ^ if these statements scope over something, this renames it+           -- and returns the result.+        -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars)+rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts++-- | like 'rnStmts' but applies a post-processing step to the renamed Stmts+rnStmtsWithPostProcessing+        :: Outputable (body RdrName)+        => HsStmtContext Name+        -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))+           -- ^ How to rename the body of each statement (e.g. rnLExpr)+        -> (HsStmtContext Name+              -> [(LStmt Name (Located (body Name)), FreeVars)]+              -> RnM ([LStmt Name (Located (body Name))], FreeVars))+           -- ^ postprocess the statements+        -> [LStmt RdrName (Located (body RdrName))]+           -- ^ Statements+        -> ([Name] -> RnM (thing, FreeVars))+           -- ^ if these statements scope over something, this renames it+           -- and returns the result.+        -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars)+rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside+ = do { ((stmts', thing), fvs) <-+          rnStmtsWithFreeVars ctxt rnBody stmts thing_inside+      ; (pp_stmts, fvs') <- ppStmts ctxt stmts'+      ; return ((pp_stmts, thing), fvs `plusFV` fvs')+      }++-- | maybe rearrange statements according to the ApplicativeDo transformation+postProcessStmtsForApplicativeDo+  :: HsStmtContext Name+  -> [(ExprLStmt Name, FreeVars)]+  -> RnM ([ExprLStmt Name], FreeVars)+postProcessStmtsForApplicativeDo ctxt stmts+  = do {+       -- rearrange the statements using ApplicativeStmt if+       -- -XApplicativeDo is on.  Also strip out the FreeVars attached+       -- to each Stmt body.+         ado_is_on <- xoptM LangExt.ApplicativeDo+       ; let is_do_expr | DoExpr <- ctxt = True+                        | otherwise = False+       ; if ado_is_on && is_do_expr+            then rearrangeForApplicativeDo ctxt stmts+            else noPostProcessStmts ctxt stmts }++-- | strip the FreeVars annotations from statements+noPostProcessStmts+  :: HsStmtContext Name+  -> [(LStmt Name (Located (body Name)), FreeVars)]+  -> RnM ([LStmt Name (Located (body Name))], FreeVars)+noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet)+++rnStmtsWithFreeVars :: Outputable (body RdrName)+        => HsStmtContext Name+        -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))+        -> [LStmt RdrName (Located (body RdrName))]+        -> ([Name] -> RnM (thing, FreeVars))+        -> RnM ( ([(LStmt Name (Located (body Name)), FreeVars)], thing)+               , FreeVars)+-- Each Stmt body is annotated with its FreeVars, so that+-- we can rearrange statements for ApplicativeDo.+--+-- Variables bound by the Stmts, and mentioned in thing_inside,+-- do not appear in the result FreeVars++rnStmtsWithFreeVars ctxt _ [] thing_inside+  = do { checkEmptyStmts ctxt+       ; (thing, fvs) <- thing_inside []+       ; return (([], thing), fvs) }++rnStmtsWithFreeVars MDoExpr rnBody stmts thing_inside    -- Deal with mdo+  = -- Behave like do { rec { ...all but last... }; last }+    do { ((stmts1, (stmts2, thing)), fvs)+           <- rnStmt MDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ ->+              do { last_stmt' <- checkLastStmt MDoExpr last_stmt+                 ; rnStmt MDoExpr rnBody last_stmt' thing_inside }+        ; return (((stmts1 ++ stmts2), thing), fvs) }+  where+    Just (all_but_last, last_stmt) = snocView stmts++rnStmtsWithFreeVars ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside+  | null lstmts+  = setSrcSpan loc $+    do { lstmt' <- checkLastStmt ctxt lstmt+       ; rnStmt ctxt rnBody lstmt' thing_inside }++  | otherwise+  = do { ((stmts1, (stmts2, thing)), fvs)+            <- setSrcSpan loc                         $+               do { checkStmt ctxt lstmt+                  ; rnStmt ctxt rnBody lstmt    $ \ bndrs1 ->+                    rnStmtsWithFreeVars ctxt rnBody lstmts  $ \ bndrs2 ->+                    thing_inside (bndrs1 ++ bndrs2) }+        ; return (((stmts1 ++ stmts2), thing), fvs) }++----------------------++{-+Note [Failing pattern matches in Stmts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Many things desugar to HsStmts including monadic things like `do` and `mdo`+statements, pattern guards, and list comprehensions (see 'HsStmtContext' for an+exhaustive list). How we deal with pattern match failure is context-dependent.++ * In the case of list comprehensions and pattern guards we don't need any 'fail'+   function; the desugarer ignores the fail function field of 'BindStmt' entirely.+ * In the case of monadic contexts (e.g. monad comprehensions, do, and mdo+   expressions) we want pattern match failure to be desugared to the appropriate+   'fail' function (either that of Monad or MonadFail, depending on whether+   -XMonadFailDesugaring is enabled.)++At one point we failed to make this distinction, leading to #11216.+-}++rnStmt :: Outputable (body RdrName)+       => HsStmtContext Name+       -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))+          -- ^ How to rename the body of the statement+       -> LStmt RdrName (Located (body RdrName))+          -- ^ The statement+       -> ([Name] -> RnM (thing, FreeVars))+          -- ^ Rename the stuff that this statement scopes over+       -> RnM ( ([(LStmt Name (Located (body Name)), FreeVars)], thing)+              , FreeVars)+-- Variables bound by the Stmt, and mentioned in thing_inside,+-- do not appear in the result FreeVars++rnStmt ctxt rnBody (L loc (LastStmt body noret _)) thing_inside+  = do  { (body', fv_expr) <- rnBody body+        ; (ret_op, fvs1)   <- lookupStmtName ctxt returnMName+        ; (thing,  fvs3)   <- thing_inside []+        ; return (([(L loc (LastStmt body' noret ret_op), fv_expr)], thing),+                  fv_expr `plusFV` fvs1 `plusFV` fvs3) }++rnStmt ctxt rnBody (L loc (BodyStmt body _ _ _)) thing_inside+  = do  { (body', fv_expr) <- rnBody body+        ; (then_op, fvs1)  <- lookupStmtName ctxt thenMName+        ; (guard_op, fvs2) <- if isListCompExpr ctxt+                              then lookupStmtName ctxt guardMName+                              else return (noSyntaxExpr, emptyFVs)+                              -- Only list/parr/monad comprehensions use 'guard'+                              -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ]+                              -- Here "gd" is a guard+        ; (thing, fvs3)    <- thing_inside []+        ; return (([(L loc (BodyStmt body'+                     then_op guard_op placeHolderType), fv_expr)], thing),+                  fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }++rnStmt ctxt rnBody (L loc (BindStmt pat body _ _ _)) thing_inside+  = do  { (body', fv_expr) <- rnBody body+                -- The binders do not scope over the expression+        ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName++        ; xMonadFailEnabled <- fmap (xopt LangExt.MonadFailDesugaring) getDynFlags+        ; let getFailFunction+                -- If the pattern is irrefutible (e.g.: wildcard, tuple,+                -- ~pat, etc.) we should not need to fail.+                | isIrrefutableHsPat pat+                                    = return (noSyntaxExpr, emptyFVs)+                -- For non-monadic contexts (e.g. guard patterns, list+                -- comprehensions, etc.) we should not need to fail.+                -- See Note [Failing pattern matches in Stmts]+                | not (isMonadFailStmtContext ctxt)+                                    = return (noSyntaxExpr, emptyFVs)+                | xMonadFailEnabled = lookupSyntaxName failMName+                | otherwise         = lookupSyntaxName failMName_preMFP+        ; (fail_op, fvs2) <- getFailFunction++        ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do+        { (thing, fvs3) <- thing_inside (collectPatBinders pat')+        ; return (( [( L loc (BindStmt pat' body' bind_op fail_op PlaceHolder)+                     , fv_expr )]+                  , thing),+                  fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}+       -- fv_expr shouldn't really be filtered by the rnPatsAndThen+        -- but it does not matter because the names are unique++rnStmt _ _ (L loc (LetStmt (L l binds))) thing_inside+  = do  { rnLocalBindsAndThen binds $ \binds' bind_fvs -> do+        { (thing, fvs) <- thing_inside (collectLocalBinders binds')+        ; return (([(L loc (LetStmt (L l binds')), bind_fvs)], thing), fvs) }  }++rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside+  = do  { (return_op, fvs1)  <- lookupStmtName ctxt returnMName+        ; (mfix_op,   fvs2)  <- lookupStmtName ctxt mfixName+        ; (bind_op,   fvs3)  <- lookupStmtName ctxt bindMName+        ; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn  = return_op+                                                , recS_mfix_fn = mfix_op+                                                , recS_bind_fn = bind_op }++        -- Step1: Bring all the binders of the mdo into scope+        -- (Remember that this also removes the binders from the+        -- finally-returned free-vars.)+        -- And rename each individual stmt, making a+        -- singleton segment.  At this stage the FwdRefs field+        -- isn't finished: it's empty for all except a BindStmt+        -- for which it's the fwd refs within the bind itself+        -- (This set may not be empty, because we're in a recursive+        -- context.)+        ; rnRecStmtsAndThen rnBody rec_stmts   $ \ segs -> do+        { let bndrs = nameSetElemsStable $+                        foldr (unionNameSet . (\(ds,_,_,_) -> ds))+                              emptyNameSet+                              segs+          -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]+        ; (thing, fvs_later) <- thing_inside bndrs+        ; let (rec_stmts', fvs) = segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later+        -- We aren't going to try to group RecStmts with+        -- ApplicativeDo, so attaching empty FVs is fine.+        ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing)+                 , fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }++rnStmt ctxt _ (L loc (ParStmt segs _ _ _)) thing_inside+  = do  { (mzip_op, fvs1)   <- lookupStmtNamePoly ctxt mzipName+        ; (bind_op, fvs2)   <- lookupStmtName ctxt bindMName+        ; (return_op, fvs3) <- lookupStmtName ctxt returnMName+        ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside+        ; return ( ([(L loc (ParStmt segs' mzip_op bind_op placeHolderType), fvs4)], thing)+                 , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }++rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form+                              , trS_using = using })) thing_inside+  = do { -- Rename the 'using' expression in the context before the transform is begun+         (using', fvs1) <- rnLExpr using++         -- Rename the stmts and the 'by' expression+         -- Keep track of the variables mentioned in the 'by' expression+       ; ((stmts', (by', used_bndrs, thing)), fvs2)+             <- rnStmts (TransStmtCtxt ctxt) rnLExpr stmts $ \ bndrs ->+                do { (by',   fvs_by) <- mapMaybeFvRn rnLExpr by+                   ; (thing, fvs_thing) <- thing_inside bndrs+                   ; let fvs = fvs_by `plusFV` fvs_thing+                         used_bndrs = filter (`elemNameSet` fvs) bndrs+                         -- The paper (Fig 5) has a bug here; we must treat any free variable+                         -- of the "thing inside", **or of the by-expression**, as used+                   ; return ((by', used_bndrs, thing), fvs) }++       -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions+       ; (return_op, fvs3) <- lookupStmtName ctxt returnMName+       ; (bind_op,   fvs4) <- lookupStmtName ctxt bindMName+       ; (fmap_op,   fvs5) <- case form of+                                ThenForm -> return (noExpr, emptyFVs)+                                _        -> lookupStmtNamePoly ctxt fmapName++       ; let all_fvs  = fvs1 `plusFV` fvs2 `plusFV` fvs3+                             `plusFV` fvs4 `plusFV` fvs5+             bndr_map = used_bndrs `zip` used_bndrs+             -- See Note [TransStmt binder map] in HsExpr++       ; traceRn "rnStmt: implicitly rebound these used binders:" (ppr bndr_map)+       ; return (([(L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map+                                    , trS_by = by', trS_using = using', trS_form = form+                                    , trS_ret = return_op, trS_bind = bind_op+                                    , trS_bind_arg_ty = PlaceHolder+                                    , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) }++rnStmt _ _ (L _ ApplicativeStmt{}) _ =+  panic "rnStmt: ApplicativeStmt"++rnParallelStmts :: forall thing. HsStmtContext Name+                -> SyntaxExpr Name+                -> [ParStmtBlock RdrName RdrName]+                -> ([Name] -> RnM (thing, FreeVars))+                -> RnM (([ParStmtBlock Name Name], thing), FreeVars)+-- Note [Renaming parallel Stmts]+rnParallelStmts ctxt return_op segs thing_inside+  = do { orig_lcl_env <- getLocalRdrEnv+       ; rn_segs orig_lcl_env [] segs }+  where+    rn_segs :: LocalRdrEnv+            -> [Name] -> [ParStmtBlock RdrName RdrName]+            -> RnM (([ParStmtBlock Name Name], thing), FreeVars)+    rn_segs _ bndrs_so_far []+      = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far+           ; mapM_ dupErr dups+           ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')+           ; return (([], thing), fvs) }++    rn_segs env bndrs_so_far (ParStmtBlock stmts _ _ : segs)+      = do { ((stmts', (used_bndrs, segs', thing)), fvs)+                    <- rnStmts ctxt rnLExpr stmts $ \ bndrs ->+                       setLocalRdrEnv env       $ do+                       { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs+                       ; let used_bndrs = filter (`elemNameSet` fvs) bndrs+                       ; return ((used_bndrs, segs', thing), fvs) }++           ; let seg' = ParStmtBlock stmts' used_bndrs return_op+           ; return ((seg':segs', thing), fvs) }++    cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2+    dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:"+                    <+> quotes (ppr (head vs)))++lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr Name, FreeVars)+-- Like lookupSyntaxName, but respects contexts+lookupStmtName ctxt n+  | rebindableContext ctxt+  = lookupSyntaxName n+  | otherwise+  = return (mkRnSyntaxExpr n, emptyFVs)++lookupStmtNamePoly :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars)+lookupStmtNamePoly ctxt name+  | rebindableContext ctxt+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax+       ; if rebindable_on+         then do { fm <- lookupOccRn (nameRdrName name)+                 ; return (HsVar (noLoc fm), unitFV fm) }+         else not_rebindable }+  | otherwise+  = not_rebindable+  where+    not_rebindable = return (HsVar (noLoc name), emptyFVs)++-- | Is this a context where we respect RebindableSyntax?+-- but ListComp/PArrComp are never rebindable+-- Neither is ArrowExpr, which has its own desugarer in DsArrows+rebindableContext :: HsStmtContext Name -> Bool+rebindableContext ctxt = case ctxt of+  ListComp        -> False+  PArrComp        -> False+  ArrowExpr       -> False+  PatGuard {}     -> False++  DoExpr          -> True+  MDoExpr         -> True+  MonadComp       -> True+  GhciStmtCtxt    -> True   -- I suppose?++  ParStmtCtxt   c -> rebindableContext c     -- Look inside to+  TransStmtCtxt c -> rebindableContext c     -- the parent context++{-+Note [Renaming parallel Stmts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Renaming parallel statements is painful.  Given, say+     [ a+c | a <- as, bs <- bss+           | c <- bs, a <- ds ]+Note that+  (a) In order to report "Defined but not used" about 'bs', we must+      rename each group of Stmts with a thing_inside whose FreeVars+      include at least {a,c}++  (b) We want to report that 'a' is illegally bound in both branches++  (c) The 'bs' in the second group must obviously not be captured by+      the binding in the first group++To satisfy (a) we nest the segements.+To satisfy (b) we check for duplicates just before thing_inside.+To satisfy (c) we reset the LocalRdrEnv each time.++************************************************************************+*                                                                      *+\subsubsection{mdo expressions}+*                                                                      *+************************************************************************+-}++type FwdRefs = NameSet+type Segment stmts = (Defs,+                      Uses,     -- May include defs+                      FwdRefs,  -- A subset of uses that are+                                --   (a) used before they are bound in this segment, or+                                --   (b) used here, and bound in subsequent segments+                      stmts)    -- Either Stmt or [Stmt]+++-- wrapper that does both the left- and right-hand sides+rnRecStmtsAndThen :: Outputable (body RdrName) =>+                     (Located (body RdrName)+                  -> RnM (Located (body Name), FreeVars))+                  -> [LStmt RdrName (Located (body RdrName))]+                         -- assumes that the FreeVars returned includes+                         -- the FreeVars of the Segments+                  -> ([Segment (LStmt Name (Located (body Name)))]+                      -> RnM (a, FreeVars))+                  -> RnM (a, FreeVars)+rnRecStmtsAndThen rnBody s cont+  = do  { -- (A) Make the mini fixity env for all of the stmts+          fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)++          -- (B) Do the LHSes+        ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s++          --    ...bring them and their fixities into scope+        ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)+              -- Fake uses of variables introduced implicitly (warning suppression, see #4404)+              implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv)+        ; bindLocalNamesFV bound_names $+          addLocalFixities fix_env bound_names $ do++          -- (C) do the right-hand-sides and thing-inside+        { segs <- rn_rec_stmts rnBody bound_names new_lhs_and_fv+        ; (res, fvs) <- cont segs+        ; warnUnusedLocalBinds bound_names (fvs `unionNameSet` implicit_uses)+        ; return (res, fvs) }}++-- get all the fixity decls in any Let stmt+collectRecStmtsFixities :: [LStmtLR RdrName RdrName body] -> [LFixitySig RdrName]+collectRecStmtsFixities l =+    foldr (\ s -> \acc -> case s of+            (L _ (LetStmt (L _ (HsValBinds (ValBindsIn _ sigs))))) ->+                foldr (\ sig -> \ acc -> case sig of+                                           (L loc (FixSig s)) -> (L loc s) : acc+                                           _ -> acc) acc sigs+            _ -> acc) [] l++-- left-hand sides++rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv+                -> LStmt RdrName body+                   -- rename LHS, and return its FVs+                   -- Warning: we will only need the FreeVars below in the case of a BindStmt,+                   -- so we don't bother to compute it accurately in the other cases+                -> RnM [(LStmtLR Name RdrName body, FreeVars)]++rn_rec_stmt_lhs _ (L loc (BodyStmt body a b c))+  = return [(L loc (BodyStmt body a b c), emptyFVs)]++rn_rec_stmt_lhs _ (L loc (LastStmt body noret a))+  = return [(L loc (LastStmt body noret a), emptyFVs)]++rn_rec_stmt_lhs fix_env (L loc (BindStmt pat body a b t))+  = do+      -- should the ctxt be MDo instead?+      (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat+      return [(L loc (BindStmt pat' body a b t),+               fv_pat)]++rn_rec_stmt_lhs _ (L _ (LetStmt (L _ binds@(HsIPBinds _))))+  = failWith (badIpBinds (text "an mdo expression") binds)++rn_rec_stmt_lhs fix_env (L loc (LetStmt (L l(HsValBinds binds))))+    = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds+         return [(L loc (LetStmt (L l (HsValBinds binds'))),+                 -- Warning: this is bogus; see function invariant+                 emptyFVs+                 )]++-- XXX Do we need to do something with the return and mfix names?+rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts }))  -- Flatten Rec inside Rec+    = rn_rec_stmts_lhs fix_env stmts++rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {}))       -- Syntactically illegal in mdo+  = pprPanic "rn_rec_stmt" (ppr stmt)++rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {}))     -- Syntactically illegal in mdo+  = pprPanic "rn_rec_stmt" (ppr stmt)++rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet+  = pprPanic "rn_rec_stmt" (ppr stmt)++rn_rec_stmt_lhs _ (L _ (LetStmt (L _ EmptyLocalBinds)))+  = panic "rn_rec_stmt LetStmt EmptyLocalBinds"++rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv+                 -> [LStmt RdrName body]+                 -> RnM [(LStmtLR Name RdrName body, FreeVars)]+rn_rec_stmts_lhs fix_env stmts+  = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts+       ; let boundNames = collectLStmtsBinders (map fst ls)+            -- First do error checking: we need to check for dups here because we+            -- don't bind all of the variables from the Stmt at once+            -- with bindLocatedLocals.+       ; checkDupNames boundNames+       ; return ls }+++-- right-hand-sides++rn_rec_stmt :: (Outputable (body RdrName)) =>+               (Located (body RdrName) -> RnM (Located (body Name), FreeVars))+            -> [Name]+            -> (LStmtLR Name RdrName (Located (body RdrName)), FreeVars)+            -> RnM [Segment (LStmt Name (Located (body Name)))]+        -- Rename a Stmt that is inside a RecStmt (or mdo)+        -- Assumes all binders are already in scope+        -- Turns each stmt into a singleton Stmt+rn_rec_stmt rnBody _ (L loc (LastStmt body noret _), _)+  = do  { (body', fv_expr) <- rnBody body+        ; (ret_op, fvs1)   <- lookupSyntaxName returnMName+        ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,+                   L loc (LastStmt body' noret ret_op))] }++rn_rec_stmt rnBody _ (L loc (BodyStmt body _ _ _), _)+  = do { (body', fvs) <- rnBody body+       ; (then_op, fvs1) <- lookupSyntaxName thenMName+       ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,+                 L loc (BodyStmt body' then_op noSyntaxExpr placeHolderType))] }++rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _ _), fv_pat)+  = do { (body', fv_expr) <- rnBody body+       ; (bind_op, fvs1) <- lookupSyntaxName bindMName++       ; xMonadFailEnabled <- fmap (xopt LangExt.MonadFailDesugaring) getDynFlags+       ; let failFunction | xMonadFailEnabled = failMName+                          | otherwise         = failMName_preMFP+       ; (fail_op, fvs2) <- lookupSyntaxName failFunction++       ; let bndrs = mkNameSet (collectPatBinders pat')+             fvs   = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2+       ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,+                  L loc (BindStmt pat' body' bind_op fail_op PlaceHolder))] }++rn_rec_stmt _ _ (L _ (LetStmt (L _ binds@(HsIPBinds _))), _)+  = failWith (badIpBinds (text "an mdo expression") binds)++rn_rec_stmt _ all_bndrs (L loc (LetStmt (L l (HsValBinds binds'))), _)+  = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds'+           -- fixities and unused are handled above in rnRecStmtsAndThen+       ; let fvs = allUses du_binds+       ; return [(duDefs du_binds, fvs, emptyNameSet,+                 L loc (LetStmt (L l (HsValBinds binds'))))] }++-- no RecStmt case because they get flattened above when doing the LHSes+rn_rec_stmt _ _ stmt@(L _ (RecStmt {}), _)+  = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)++rn_rec_stmt _ _ stmt@(L _ (ParStmt {}), _)       -- Syntactically illegal in mdo+  = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)++rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _)     -- Syntactically illegal in mdo+  = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)++rn_rec_stmt _ _ (L _ (LetStmt (L _ EmptyLocalBinds)), _)+  = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"++rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _)+  = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt)++rn_rec_stmts :: Outputable (body RdrName) =>+                (Located (body RdrName) -> RnM (Located (body Name), FreeVars))+             -> [Name]+             -> [(LStmtLR Name RdrName (Located (body RdrName)), FreeVars)]+             -> RnM [Segment (LStmt Name (Located (body Name)))]+rn_rec_stmts rnBody bndrs stmts+  = do { segs_s <- mapM (rn_rec_stmt rnBody bndrs) stmts+       ; return (concat segs_s) }++---------------------------------------------+segmentRecStmts :: SrcSpan -> HsStmtContext Name+                -> Stmt Name body+                -> [Segment (LStmt Name body)] -> FreeVars+                -> ([LStmt Name body], FreeVars)++segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later+  | null segs+  = ([], fvs_later)++  | MDoExpr <- ctxt+  = segsToStmts empty_rec_stmt grouped_segs fvs_later+               -- Step 4: Turn the segments into Stmts+                --         Use RecStmt when and only when there are fwd refs+                --         Also gather up the uses from the end towards the+                --         start, so we can tell the RecStmt which things are+                --         used 'after' the RecStmt++  | otherwise+  = ([ L loc $+       empty_rec_stmt { recS_stmts = ss+                      , recS_later_ids = nameSetElemsStable+                                           (defs `intersectNameSet` fvs_later)+                      , recS_rec_ids   = nameSetElemsStable+                                           (defs `intersectNameSet` uses) }]+          -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]+    , uses `plusFV` fvs_later)++  where+    (defs_s, uses_s, _, ss) = unzip4 segs+    defs = plusFVs defs_s+    uses = plusFVs uses_s++                -- Step 2: Fill in the fwd refs.+                --         The segments are all singletons, but their fwd-ref+                --         field mentions all the things used by the segment+                --         that are bound after their use+    segs_w_fwd_refs = addFwdRefs segs++                -- Step 3: Group together the segments to make bigger segments+                --         Invariant: in the result, no segment uses a variable+                --                    bound in a later segment+    grouped_segs = glomSegments ctxt segs_w_fwd_refs++----------------------------+addFwdRefs :: [Segment a] -> [Segment a]+-- So far the segments only have forward refs *within* the Stmt+--      (which happens for bind:  x <- ...x...)+-- This function adds the cross-seg fwd ref info++addFwdRefs segs+  = fst (foldr mk_seg ([], emptyNameSet) segs)+  where+    mk_seg (defs, uses, fwds, stmts) (segs, later_defs)+        = (new_seg : segs, all_defs)+        where+          new_seg = (defs, uses, new_fwds, stmts)+          all_defs = later_defs `unionNameSet` defs+          new_fwds = fwds `unionNameSet` (uses `intersectNameSet` later_defs)+                -- Add the downstream fwd refs here++{-+Note [Segmenting mdo]+~~~~~~~~~~~~~~~~~~~~~+NB. June 7 2012: We only glom segments that appear in an explicit mdo;+and leave those found in "do rec"'s intact.  See+http://ghc.haskell.org/trac/ghc/ticket/4148 for the discussion+leading to this design choice.  Hence the test in segmentRecStmts.++Note [Glomming segments]+~~~~~~~~~~~~~~~~~~~~~~~~+Glomming the singleton segments of an mdo into minimal recursive groups.++At first I thought this was just strongly connected components, but+there's an important constraint: the order of the stmts must not change.++Consider+     mdo { x <- ...y...+           p <- z+           y <- ...x...+           q <- x+           z <- y+           r <- x }++Here, the first stmt mention 'y', which is bound in the third.+But that means that the innocent second stmt (p <- z) gets caught+up in the recursion.  And that in turn means that the binding for+'z' has to be included... and so on.++Start at the tail { r <- x }+Now add the next one { z <- y ; r <- x }+Now add one more     { q <- x ; z <- y ; r <- x }+Now one more... but this time we have to group a bunch into rec+     { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }+Now one more, which we can add on without a rec+     { p <- z ;+       rec { y <- ...x... ; q <- x ; z <- y } ;+       r <- x }+Finally we add the last one; since it mentions y we have to+glom it together with the first two groups+     { rec { x <- ...y...; p <- z ; y <- ...x... ;+             q <- x ; z <- y } ;+       r <- x }+-}++glomSegments :: HsStmtContext Name+             -> [Segment (LStmt Name body)]+             -> [Segment [LStmt Name body]]  -- Each segment has a non-empty list of Stmts+-- See Note [Glomming segments]++glomSegments _ [] = []+glomSegments ctxt ((defs,uses,fwds,stmt) : segs)+        -- Actually stmts will always be a singleton+  = (seg_defs, seg_uses, seg_fwds, seg_stmts)  : others+  where+    segs'            = glomSegments ctxt segs+    (extras, others) = grab uses segs'+    (ds, us, fs, ss) = unzip4 extras++    seg_defs  = plusFVs ds `plusFV` defs+    seg_uses  = plusFVs us `plusFV` uses+    seg_fwds  = plusFVs fs `plusFV` fwds+    seg_stmts = stmt : concat ss++    grab :: NameSet             -- The client+         -> [Segment a]+         -> ([Segment a],       -- Needed by the 'client'+             [Segment a])       -- Not needed by the client+        -- The result is simply a split of the input+    grab uses dus+        = (reverse yeses, reverse noes)+        where+          (noes, yeses)           = span not_needed (reverse dus)+          not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)++----------------------------------------------------+segsToStmts :: Stmt Name body                   -- A RecStmt with the SyntaxOps filled in+            -> [Segment [LStmt Name body]]      -- Each Segment has a non-empty list of Stmts+            -> FreeVars                         -- Free vars used 'later'+            -> ([LStmt Name body], FreeVars)++segsToStmts _ [] fvs_later = ([], fvs_later)+segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later+  = ASSERT( not (null ss) )+    (new_stmt : later_stmts, later_uses `plusFV` uses)+  where+    (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later+    new_stmt | non_rec   = head ss+             | otherwise = L (getLoc (head ss)) rec_stmt+    rec_stmt = empty_rec_stmt { recS_stmts     = ss+                              , recS_later_ids = nameSetElemsStable used_later+                              , recS_rec_ids   = nameSetElemsStable fwds }+          -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]+    non_rec    = isSingleton ss && isEmptyNameSet fwds+    used_later = defs `intersectNameSet` later_uses+                                -- The ones needed after the RecStmt++{-+************************************************************************+*                                                                      *+ApplicativeDo+*                                                                      *+************************************************************************++Note [ApplicativeDo]++= Example =++For a sequence of statements++ do+     x <- A+     y <- B x+     z <- C+     return (f x y z)++We want to transform this to++  (\(x,y) z -> f x y z) <$> (do x <- A; y <- B x; return (x,y)) <*> C++It would be easy to notice that "y <- B x" and "z <- C" are+independent and do something like this:++ do+     x <- A+     (y,z) <- (,) <$> B x <*> C+     return (f x y z)++But this isn't enough! A and C were also independent, and this+transformation loses the ability to do A and C in parallel.++The algorithm works by first splitting the sequence of statements into+independent "segments", and a separate "tail" (the final statement). In+our example above, the segements would be++     [ x <- A+     , y <- B x ]++     [ z <- C ]++and the tail is:++     return (f x y z)++Then we take these segments and make an Applicative expression from them:++     (\(x,y) z -> return (f x y z))+       <$> do { x <- A; y <- B x; return (x,y) }+       <*> C++Finally, we recursively apply the transformation to each segment, to+discover any nested parallelism.++= Syntax & spec =++  expr ::= ... | do {stmt_1; ..; stmt_n} expr | ...++  stmt ::= pat <- expr+         | (arg_1 | ... | arg_n)  -- applicative composition, n>=1+         | ...                    -- other kinds of statement (e.g. let)++  arg ::= pat <- expr+        | {stmt_1; ..; stmt_n} {var_1..var_n}++(note that in the actual implementation,the expr in a do statement is+represented by a LastStmt as the final stmt, this is just a+representational issue and may change later.)++== Transformation to introduce applicative stmts ==++ado {} tail = tail+ado {pat <- expr} {return expr'} = (mkArg(pat <- expr)); return expr'+ado {one} tail = one : tail+ado stmts tail+  | n == 1 = ado before (ado after tail)+    where (before,after) = split(stmts_1)+  | n > 1  = (mkArg(stmts_1) | ... | mkArg(stmts_n)); tail+  where+    {stmts_1 .. stmts_n} = segments(stmts)++segments(stmts) =+  -- divide stmts into segments with no interdependencies++mkArg({pat <- expr}) = (pat <- expr)+mkArg({stmt_1; ...; stmt_n}) =+  {stmt_1; ...; stmt_n} {vars(stmt_1) u .. u vars(stmt_n)}++split({stmt_1; ..; stmt_n) =+  ({stmt_1; ..; stmt_i}, {stmt_i+1; ..; stmt_n})+  -- 1 <= i <= n+  -- i is a good place to insert a bind++== Desugaring for do ==++dsDo {} expr = expr++dsDo {pat <- rhs; stmts} expr =+   rhs >>= \pat -> dsDo stmts expr++dsDo {(arg_1 | ... | arg_n)} (return expr) =+  (\argpat (arg_1) .. argpat(arg_n) -> expr)+     <$> argexpr(arg_1)+     <*> ...+     <*> argexpr(arg_n)++dsDo {(arg_1 | ... | arg_n); stmts} expr =+  join (\argpat (arg_1) .. argpat(arg_n) -> dsDo stmts expr)+     <$> argexpr(arg_1)+     <*> ...+     <*> argexpr(arg_n)++-}++-- | The 'Name's of @return@ and @pure@. These may not be 'returnName' and+-- 'pureName' due to @RebindableSyntax@.+data MonadNames = MonadNames { return_name, pure_name :: Name }++-- | rearrange a list of statements using ApplicativeDoStmt.  See+-- Note [ApplicativeDo].+rearrangeForApplicativeDo+  :: HsStmtContext Name+  -> [(ExprLStmt Name, FreeVars)]+  -> RnM ([ExprLStmt Name], FreeVars)++rearrangeForApplicativeDo _ [] = return ([], emptyNameSet)+rearrangeForApplicativeDo _ [(one,_)] = return ([one], emptyNameSet)+rearrangeForApplicativeDo ctxt stmts0 = do+  optimal_ado <- goptM Opt_OptimalApplicativeDo+  let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts+                | otherwise = mkStmtTreeHeuristic stmts+  return_name <- lookupSyntaxName' returnMName+  pure_name   <- lookupSyntaxName' pureAName+  let monad_names = MonadNames { return_name = return_name+                               , pure_name   = pure_name }+  stmtTreeToStmts monad_names ctxt stmt_tree [last] last_fvs+  where+    (stmts,(last,last_fvs)) = findLast stmts0+    findLast [] = error "findLast"+    findLast [last] = ([],last)+    findLast (x:xs) = (x:rest,last) where (rest,last) = findLast xs++-- | A tree of statements using a mixture of applicative and bind constructs.+data StmtTree a+  = StmtTreeOne a+  | StmtTreeBind (StmtTree a) (StmtTree a)+  | StmtTreeApplicative [StmtTree a]++flattenStmtTree :: StmtTree a -> [a]+flattenStmtTree t = go t []+ where+  go (StmtTreeOne a) as = a : as+  go (StmtTreeBind l r) as = go l (go r as)+  go (StmtTreeApplicative ts) as = foldr go as ts++type ExprStmtTree = StmtTree (ExprLStmt Name, FreeVars)+type Cost = Int++-- | Turn a sequence of statements into an ExprStmtTree using a+-- heuristic algorithm.  /O(n^2)/+mkStmtTreeHeuristic :: [(ExprLStmt Name, FreeVars)] -> ExprStmtTree+mkStmtTreeHeuristic [one] = StmtTreeOne one+mkStmtTreeHeuristic stmts =+  case segments stmts of+    [one] -> split one+    segs -> StmtTreeApplicative (map split segs)+ where+  split [one] = StmtTreeOne one+  split stmts =+    StmtTreeBind (mkStmtTreeHeuristic before) (mkStmtTreeHeuristic after)+    where (before, after) = splitSegment stmts++-- | Turn a sequence of statements into an ExprStmtTree optimally,+-- using dynamic programming.  /O(n^3)/+mkStmtTreeOptimal :: [(ExprLStmt Name, FreeVars)] -> ExprStmtTree+mkStmtTreeOptimal stmts =+  ASSERT(not (null stmts)) -- the empty case is handled by the caller;+                           -- we don't support empty StmtTrees.+  fst (arr ! (0,n))+  where+    n = length stmts - 1+    stmt_arr = listArray (0,n) stmts++    -- lazy cache of optimal trees for subsequences of the input+    arr :: Array (Int,Int) (ExprStmtTree, Cost)+    arr = array ((0,0),(n,n))+             [ ((lo,hi), tree lo hi)+             | lo <- [0..n]+             , hi <- [lo..n] ]++    -- compute the optimal tree for the sequence [lo..hi]+    tree lo hi+      | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1)+      | otherwise =+         case segments [ stmt_arr ! i | i <- [lo..hi] ] of+           [] -> panic "mkStmtTree"+           [_one] -> split lo hi+           segs -> (StmtTreeApplicative trees, maximum costs)+             where+               bounds = scanl (\(_,hi) a -> (hi+1, hi + length a)) (0,lo-1) segs+               (trees,costs) = unzip (map (uncurry split) (tail bounds))++    -- find the best place to split the segment [lo..hi]+    split :: Int -> Int -> (ExprStmtTree, Cost)+    split lo hi+      | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1)+      | otherwise = (StmtTreeBind before after, c1+c2)+        where+         -- As per the paper, for a sequence s1...sn, we want to find+         -- the split with the minimum cost, where the cost is the+         -- sum of the cost of the left and right subsequences.+         --+         -- As an optimisation (also in the paper) if the cost of+         -- s1..s(n-1) is different from the cost of s2..sn, we know+         -- that the optimal solution is the lower of the two.  Only+         -- in the case that these two have the same cost do we need+         -- to do the exhaustive search.+         --+         ((before,c1),(after,c2))+           | hi - lo == 1+           = ((StmtTreeOne (stmt_arr ! lo), 1),+              (StmtTreeOne (stmt_arr ! hi), 1))+           | left_cost < right_cost+           = ((left,left_cost), (StmtTreeOne (stmt_arr ! hi), 1))+           | otherwise -- left_cost > right_cost+           = ((StmtTreeOne (stmt_arr ! lo), 1), (right,right_cost))+           | otherwise = minimumBy (comparing cost) alternatives+           where+             (left, left_cost) = arr ! (lo,hi-1)+             (right, right_cost) = arr ! (lo+1,hi)+             cost ((_,c1),(_,c2)) = c1 + c2+             alternatives = [ (arr ! (lo,k), arr ! (k+1,hi))+                            | k <- [lo .. hi-1] ]+++-- | Turn the ExprStmtTree back into a sequence of statements, using+-- ApplicativeStmt where necessary.+stmtTreeToStmts+  :: MonadNames+  -> HsStmtContext Name+  -> ExprStmtTree+  -> [ExprLStmt Name]             -- ^ the "tail"+  -> FreeVars                     -- ^ free variables of the tail+  -> RnM ( [ExprLStmt Name]       -- ( output statements,+         , FreeVars )             -- , things we needed++-- If we have a single bind, and we can do it without a join, transform+-- to an ApplicativeStmt.  This corresponds to the rule+--   dsBlock [pat <- rhs] (return expr) = expr <$> rhs+-- In the spec, but we do it here rather than in the desugarer,+-- because we need the typechecker to typecheck the <$> form rather than+-- the bind form, which would give rise to a Monad constraint.+stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt pat rhs _ _ _),_))+                tail _tail_fvs+  | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail+  -- See Note [ApplicativeDo and strict patterns]+  = mkApplicativeStmt ctxt [ApplicativeArgOne pat rhs] False tail'++stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =+  return (s : tail, emptyNameSet)++stmtTreeToStmts monad_names ctxt (StmtTreeBind before after) tail tail_fvs = do+  (stmts1, fvs1) <- stmtTreeToStmts monad_names ctxt after tail tail_fvs+  let tail1_fvs = unionNameSets (tail_fvs : map snd (flattenStmtTree after))+  (stmts2, fvs2) <- stmtTreeToStmts monad_names ctxt before stmts1 tail1_fvs+  return (stmts2, fvs1 `plusFV` fvs2)++stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do+   pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees+   let (stmts', fvss) = unzip pairs+   let (need_join, tail') = needJoin monad_names tail+   (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail'+   return (stmts, unionNameSets (fvs:fvss))+ where+   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt pat exp _ _ _), _)) =+     return (ApplicativeArgOne pat exp, emptyFVs)+   stmtTreeArg ctxt tail_fvs tree = do+     let stmts = flattenStmtTree tree+         pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)+                     `intersectNameSet` tail_fvs+         pvars = nameSetElemsStable pvarset+           -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]+         pat = mkBigLHsVarPatTup pvars+         tup = mkBigLHsVarTup pvars+     (stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset+     (mb_ret, fvs1) <-+        if | L _ ApplicativeStmt{} <- last stmts' ->+             return (unLoc tup, emptyNameSet)+           | otherwise -> do+             (ret,fvs) <- lookupStmtNamePoly ctxt returnMName+             return (HsApp (noLoc ret) tup, fvs)+     return ( ApplicativeArgMany stmts' mb_ret pat+            , fvs1 `plusFV` fvs2)+++-- | Divide a sequence of statements into segments, where no segment+-- depends on any variables defined by a statement in another segment.+segments+  :: [(ExprLStmt Name, FreeVars)]+  -> [[(ExprLStmt Name, FreeVars)]]+segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)+  where+    allvars = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)++    -- We would rather not have a segment that just has LetStmts in+    -- it, so combine those with an adjacent segment where possible.+    merge [] = []+    merge (seg : segs)+       = case rest of+          [] -> [(seg,all_lets)]+          ((s,s_lets):ss) | all_lets || s_lets+               -> (seg ++ s, all_lets && s_lets) : ss+          _otherwise -> (seg,all_lets) : rest+      where+        rest = merge segs+        all_lets = all (isLetStmt . fst) seg++    -- walk splits the statement sequence into segments, traversing+    -- the sequence from the back to the front, and keeping track of+    -- the set of free variables of the current segment.  Whenever+    -- this set of free variables is empty, we have a complete segment.+    walk :: [(ExprLStmt Name, FreeVars)] -> [[(ExprLStmt Name, FreeVars)]]+    walk [] = []+    walk ((stmt,fvs) : stmts) = ((stmt,fvs) : seg) : walk rest+      where (seg,rest) = chunter fvs' stmts+            (_, fvs') = stmtRefs stmt fvs++    chunter _ [] = ([], [])+    chunter vars ((stmt,fvs) : rest)+       | not (isEmptyNameSet vars)+       || isStrictPatternBind stmt+           -- See Note [ApplicativeDo and strict patterns]+       = ((stmt,fvs) : chunk, rest')+       where (chunk,rest') = chunter vars' rest+             (pvars, evars) = stmtRefs stmt fvs+             vars' = (vars `minusNameSet` pvars) `unionNameSet` evars+    chunter _ rest = ([], rest)++    stmtRefs stmt fvs+      | isLetStmt stmt = (pvars, fvs' `minusNameSet` pvars)+      | otherwise      = (pvars, fvs')+      where fvs' = fvs `intersectNameSet` allvars+            pvars = mkNameSet (collectStmtBinders (unLoc stmt))++    isStrictPatternBind :: ExprLStmt Name -> Bool+    isStrictPatternBind (L _ (BindStmt pat _ _ _ _)) = isStrictPattern pat+    isStrictPatternBind _ = False++{-+Note [ApplicativeDo and strict patterns]++A strict pattern match is really a dependency.  For example,++do+  (x,y) <- A+  z <- B+  return C++The pattern (_,_) must be matched strictly before we do B.  If we+allowed this to be transformed into++  (\(x,y) -> \z -> C) <$> A <*> B++then it could be lazier than the standard desuraging using >>=.  See #13875+for more examples.++Thus, whenever we have a strict pattern match, we treat it as a+dependency between that statement and the following one.  The+dependency prevents those two statements from being performed "in+parallel" in an ApplicativeStmt, but doesn't otherwise affect what we+can do with the rest of the statements in the same "do" expression.+-}++isStrictPattern :: LPat id -> Bool+isStrictPattern (L _ pat) =+  case pat of+    WildPat{} -> False+    VarPat{}  -> False+    LazyPat{} -> False+    AsPat _ p -> isStrictPattern p+    ParPat p  -> isStrictPattern p+    ViewPat _ p _ -> isStrictPattern p+    SigPatIn p _ -> isStrictPattern p+    SigPatOut p _ -> isStrictPattern p+    BangPat{} -> True+    TuplePat{} -> True+    SumPat{} -> True+    PArrPat{} -> True+    ConPatIn{} -> True+    ConPatOut{} -> True+    LitPat{} -> True+    NPat{} -> True+    NPlusKPat{} -> True+    SplicePat{} -> True+    _otherwise -> panic "isStrictPattern"++isLetStmt :: LStmt a b -> Bool+isLetStmt (L _ LetStmt{}) = True+isLetStmt _ = False++-- | Find a "good" place to insert a bind in an indivisible segment.+-- This is the only place where we use heuristics.  The current+-- heuristic is to peel off the first group of independent statements+-- and put the bind after those.+splitSegment+  :: [(ExprLStmt Name, FreeVars)]+  -> ( [(ExprLStmt Name, FreeVars)]+     , [(ExprLStmt Name, FreeVars)] )+splitSegment [one,two] = ([one],[two])+  -- there is no choice when there are only two statements; this just saves+  -- some work in a common case.+splitSegment stmts+  | Just (lets,binds,rest) <- slurpIndependentStmts stmts+  =  if not (null lets)+       then (lets, binds++rest)+       else (lets++binds, rest)+  | otherwise+  = case stmts of+      (x:xs) -> ([x],xs)+      _other -> (stmts,[])++slurpIndependentStmts+   :: [(LStmt Name (Located (body Name)), FreeVars)]+   -> Maybe ( [(LStmt Name (Located (body Name)), FreeVars)] -- LetStmts+            , [(LStmt Name (Located (body Name)), FreeVars)] -- BindStmts+            , [(LStmt Name (Located (body Name)), FreeVars)] )+slurpIndependentStmts stmts = go [] [] emptyNameSet stmts+ where+  -- If we encounter a BindStmt that doesn't depend on a previous BindStmt+  -- in this group, then add it to the group.+  go lets indep bndrs ((L loc (BindStmt pat body bind_op fail_op ty), fvs) : rest)+    | isEmptyNameSet (bndrs `intersectNameSet` fvs)+    = go lets ((L loc (BindStmt pat body bind_op fail_op ty), fvs) : indep)+         bndrs' rest+    where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat)+  -- If we encounter a LetStmt that doesn't depend on a BindStmt in this+  -- group, then move it to the beginning, so that it doesn't interfere with+  -- grouping more BindStmts.+  -- TODO: perhaps we shouldn't do this if there are any strict bindings,+  -- because we might be moving evaluation earlier.+  go lets indep bndrs ((L loc (LetStmt binds), fvs) : rest)+    | isEmptyNameSet (bndrs `intersectNameSet` fvs)+    = go ((L loc (LetStmt binds), fvs) : lets) indep bndrs rest+  go _ []  _ _ = Nothing+  go _ [_] _ _ = Nothing+  go lets indep _ stmts = Just (reverse lets, reverse indep, stmts)++-- | Build an ApplicativeStmt, and strip the "return" from the tail+-- if necessary.+--+-- For example, if we start with+--   do x <- E1; y <- E2; return (f x y)+-- then we get+--   do (E1[x] | E2[y]); f x y+--+-- the LastStmt in this case has the return removed, but we set the+-- flag on the LastStmt to indicate this, so that we can print out the+-- original statement correctly in error messages.  It is easier to do+-- it this way rather than try to ignore the return later in both the+-- typechecker and the desugarer (I tried it that way first!).+mkApplicativeStmt+  :: HsStmtContext Name+  -> [ApplicativeArg Name Name]         -- ^ The args+  -> Bool                               -- ^ True <=> need a join+  -> [ExprLStmt Name]        -- ^ The body statements+  -> RnM ([ExprLStmt Name], FreeVars)+mkApplicativeStmt ctxt args need_join body_stmts+  = do { (fmap_op, fvs1) <- lookupStmtName ctxt fmapName+       ; (ap_op, fvs2) <- lookupStmtName ctxt apAName+       ; (mb_join, fvs3) <-+           if need_join then+             do { (join_op, fvs) <- lookupStmtName ctxt joinMName+                ; return (Just join_op, fvs) }+           else+             return (Nothing, emptyNameSet)+       ; let applicative_stmt = noLoc $ ApplicativeStmt+               (zip (fmap_op : repeat ap_op) args)+               mb_join+               placeHolderType+       ; return ( applicative_stmt : body_stmts+                , fvs1 `plusFV` fvs2 `plusFV` fvs3) }++-- | Given the statements following an ApplicativeStmt, determine whether+-- we need a @join@ or not, and remove the @return@ if necessary.+needJoin :: MonadNames+         -> [ExprLStmt Name]+         -> (Bool, [ExprLStmt Name])+needJoin _monad_names [] = (False, [])  -- we're in an ApplicativeArg+needJoin monad_names  [L loc (LastStmt e _ t)]+ | Just arg <- isReturnApp monad_names e =+       (False, [L loc (LastStmt arg True t)])+needJoin _monad_names stmts = (True, stmts)++-- | @Just e@, if the expression is @return e@ or @return $ e@,+-- otherwise @Nothing@+isReturnApp :: MonadNames+            -> LHsExpr Name+            -> Maybe (LHsExpr Name)+isReturnApp monad_names (L _ (HsPar expr)) = isReturnApp monad_names expr+isReturnApp monad_names (L _ e) = case e of+  OpApp l op _ r | is_return l, is_dollar op -> Just r+  HsApp f arg    | is_return f               -> Just arg+  _otherwise -> Nothing+ where+  is_var f (L _ (HsPar e)) = is_var f e+  is_var f (L _ (HsAppType e _)) = is_var f e+  is_var f (L _ (HsVar (L _ r))) = f r+       -- TODO: I don't know how to get this right for rebindable syntax+  is_var _ _ = False++  is_return = is_var (\n -> n == return_name monad_names+                         || n == pure_name monad_names)+  is_dollar = is_var (`hasKey` dollarIdKey)++{-+************************************************************************+*                                                                      *+\subsubsection{Errors}+*                                                                      *+************************************************************************+-}++checkEmptyStmts :: HsStmtContext Name -> RnM ()+-- We've seen an empty sequence of Stmts... is that ok?+checkEmptyStmts ctxt+  = unless (okEmpty ctxt) (addErr (emptyErr ctxt))++okEmpty :: HsStmtContext a -> Bool+okEmpty (PatGuard {}) = True+okEmpty _             = False++emptyErr :: HsStmtContext Name -> SDoc+emptyErr (ParStmtCtxt {})   = text "Empty statement group in parallel comprehension"+emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or 'then'"+emptyErr ctxt               = text "Empty" <+> pprStmtContext ctxt++----------------------+checkLastStmt :: Outputable (body RdrName) => HsStmtContext Name+              -> LStmt RdrName (Located (body RdrName))+              -> RnM (LStmt RdrName (Located (body RdrName)))+checkLastStmt ctxt lstmt@(L loc stmt)+  = case ctxt of+      ListComp  -> check_comp+      MonadComp -> check_comp+      PArrComp  -> check_comp+      ArrowExpr -> check_do+      DoExpr    -> check_do+      MDoExpr   -> check_do+      _         -> check_other+  where+    check_do    -- Expect BodyStmt, and change it to LastStmt+      = case stmt of+          BodyStmt e _ _ _ -> return (L loc (mkLastStmt e))+          LastStmt {}      -> return lstmt   -- "Deriving" clauses may generate a+                                             -- LastStmt directly (unlike the parser)+          _                -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }+    last_error = (text "The last statement in" <+> pprAStmtContext ctxt+                  <+> text "must be an expression")++    check_comp  -- Expect LastStmt; this should be enforced by the parser!+      = case stmt of+          LastStmt {} -> return lstmt+          _           -> pprPanic "checkLastStmt" (ppr lstmt)++    check_other -- Behave just as if this wasn't the last stmt+      = do { checkStmt ctxt lstmt; return lstmt }++-- Checking when a particular Stmt is ok+checkStmt :: HsStmtContext Name+          -> LStmt RdrName (Located (body RdrName))+          -> RnM ()+checkStmt ctxt (L _ stmt)+  = do { dflags <- getDynFlags+       ; case okStmt dflags ctxt stmt of+           IsValid        -> return ()+           NotValid extra -> addErr (msg $$ extra) }+  where+   msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> ptext (sLit "statement")+             , text "in" <+> pprAStmtContext ctxt ]++pprStmtCat :: Stmt a body -> SDoc+pprStmtCat (TransStmt {})     = text "transform"+pprStmtCat (LastStmt {})      = text "return expression"+pprStmtCat (BodyStmt {})      = text "body"+pprStmtCat (BindStmt {})      = text "binding"+pprStmtCat (LetStmt {})       = text "let"+pprStmtCat (RecStmt {})       = text "rec"+pprStmtCat (ParStmt {})       = text "parallel"+pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt"++------------+emptyInvalid :: Validity  -- Payload is the empty document+emptyInvalid = NotValid Outputable.empty++okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt+   :: DynFlags -> HsStmtContext Name+   -> Stmt RdrName (Located (body RdrName)) -> Validity+-- Return Nothing if OK, (Just extra) if not ok+-- The "extra" is an SDoc that is appended to an generic error message++okStmt dflags ctxt stmt+  = case ctxt of+      PatGuard {}        -> okPatGuardStmt stmt+      ParStmtCtxt ctxt   -> okParStmt  dflags ctxt stmt+      DoExpr             -> okDoStmt   dflags ctxt stmt+      MDoExpr            -> okDoStmt   dflags ctxt stmt+      ArrowExpr          -> okDoStmt   dflags ctxt stmt+      GhciStmtCtxt       -> okDoStmt   dflags ctxt stmt+      ListComp           -> okCompStmt dflags ctxt stmt+      MonadComp          -> okCompStmt dflags ctxt stmt+      PArrComp           -> okPArrStmt dflags ctxt stmt+      TransStmtCtxt ctxt -> okStmt dflags ctxt stmt++-------------+okPatGuardStmt :: Stmt RdrName (Located (body RdrName)) -> Validity+okPatGuardStmt stmt+  = case stmt of+      BodyStmt {} -> IsValid+      BindStmt {} -> IsValid+      LetStmt {}  -> IsValid+      _           -> emptyInvalid++-------------+okParStmt dflags ctxt stmt+  = case stmt of+      LetStmt (L _ (HsIPBinds {})) -> emptyInvalid+      _                            -> okStmt dflags ctxt stmt++----------------+okDoStmt dflags ctxt stmt+  = case stmt of+       RecStmt {}+         | LangExt.RecursiveDo `xopt` dflags -> IsValid+         | ArrowExpr <- ctxt -> IsValid    -- Arrows allows 'rec'+         | otherwise         -> NotValid (text "Use RecursiveDo")+       BindStmt {} -> IsValid+       LetStmt {}  -> IsValid+       BodyStmt {} -> IsValid+       _           -> emptyInvalid++----------------+okCompStmt dflags _ stmt+  = case stmt of+       BindStmt {} -> IsValid+       LetStmt {}  -> IsValid+       BodyStmt {} -> IsValid+       ParStmt {}+         | LangExt.ParallelListComp `xopt` dflags -> IsValid+         | otherwise -> NotValid (text "Use ParallelListComp")+       TransStmt {}+         | LangExt.TransformListComp `xopt` dflags -> IsValid+         | otherwise -> NotValid (text "Use TransformListComp")+       RecStmt {}  -> emptyInvalid+       LastStmt {} -> emptyInvalid  -- Should not happen (dealt with by checkLastStmt)+       ApplicativeStmt {} -> emptyInvalid++----------------+okPArrStmt dflags _ stmt+  = case stmt of+       BindStmt {} -> IsValid+       LetStmt {}  -> IsValid+       BodyStmt {} -> IsValid+       ParStmt {}+         | LangExt.ParallelListComp `xopt` dflags -> IsValid+         | otherwise -> NotValid (text "Use ParallelListComp")+       TransStmt {} -> emptyInvalid+       RecStmt {}   -> emptyInvalid+       LastStmt {}  -> emptyInvalid  -- Should not happen (dealt with by checkLastStmt)+       ApplicativeStmt {} -> emptyInvalid++---------+checkTupleSection :: [LHsTupArg RdrName] -> RnM ()+checkTupleSection args+  = do  { tuple_section <- xoptM LangExt.TupleSections+        ; checkErr (all tupArgPresent args || tuple_section) msg }+  where+    msg = text "Illegal tuple section: use TupleSections"++---------+sectionErr :: HsExpr RdrName -> SDoc+sectionErr expr+  = hang (text "A section must be enclosed in parentheses")+       2 (text "thus:" <+> (parens (ppr expr)))++patSynErr :: HsExpr RdrName -> SDoc -> RnM (HsExpr Name, FreeVars)+patSynErr e explanation = do { addErr (sep [text "Pattern syntax in expression context:",+                                nest 4 (ppr e)] $$+                                  explanation)+                 ; return (EWildPat, emptyFVs) }++badIpBinds :: Outputable a => SDoc -> a -> SDoc+badIpBinds what binds+  = hang (text "Implicit-parameter bindings illegal in" <+> what)+         2 (ppr binds)
+ rename/RnExpr.hs-boot view
@@ -0,0 +1,18 @@+module RnExpr where+import HsSyn+import Name       ( Name )+import NameSet    ( FreeVars )+import RdrName    ( RdrName )+import TcRnTypes+import SrcLoc     ( Located )+import Outputable ( Outputable )++rnLExpr :: LHsExpr RdrName+        -> RnM (LHsExpr Name, FreeVars)++rnStmts :: --forall thing body.+           Outputable (body RdrName) => HsStmtContext Name+        -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))+        -> [LStmt RdrName (Located (body RdrName))]+        -> ([Name] -> RnM (thing, FreeVars))+        -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars)
+ rename/RnHsDoc.hs view
@@ -0,0 +1,23 @@++module RnHsDoc ( rnHsDoc, rnLHsDoc, rnMbLHsDoc ) where++import TcRnTypes+import HsSyn+import SrcLoc+++rnMbLHsDoc :: Maybe LHsDocString -> RnM (Maybe LHsDocString)+rnMbLHsDoc mb_doc = case mb_doc of+  Just doc -> do+    doc' <- rnLHsDoc doc+    return (Just doc')+  Nothing -> return Nothing++rnLHsDoc :: LHsDocString -> RnM LHsDocString+rnLHsDoc (L pos doc) = do+  doc' <- rnHsDoc doc+  return (L pos doc')++rnHsDoc :: HsDocString -> RnM HsDocString+rnHsDoc (HsDocString s) = return (HsDocString s)+
+ rename/RnNames.hs view
@@ -0,0 +1,1627 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[RnNames]{Extracting imported and top-level names in scope}+-}++{-# LANGUAGE CPP, NondecreasingIndentation, MultiWayIf, NamedFieldPuns #-}++module RnNames (+        rnImports, getLocalNonValBinders, newRecordSelector,+        extendGlobalRdrEnvRn,+        gresFromAvails,+        calculateAvails,+        reportUnusedNames,+        checkConName,+        mkChildEnv,+        findChildren,+        dodgyMsg+    ) where++#include "HsVersions.h"++import DynFlags+import HsSyn+import TcEnv+import RnEnv+import LoadIface        ( loadSrcInterface )+import TcRnMonad+import PrelNames+import Module+import Name+import NameEnv+import NameSet+import Avail+import FieldLabel+import HscTypes+import RdrName+import RdrHsSyn        ( setRdrNameSpace )+import Outputable+import Maybes+import SrcLoc+import BasicTypes      ( TopLevelFlag(..), StringLiteral(..) )+import Util+import FastString+import FastStringEnv+import Id+import Type+import PatSyn+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Data.Either      ( partitionEithers, isRight, rights )+-- import qualified Data.Foldable as Foldable+import Data.Map         ( Map )+import qualified Data.Map as Map+import Data.Ord         ( comparing )+import Data.List        ( partition, (\\), find, sortBy )+import qualified Data.Set as S+-- import qualified Data.Set as Set+import System.FilePath  ((</>))++import System.IO++{-+************************************************************************+*                                                                      *+\subsection{rnImports}+*                                                                      *+************************************************************************++Note [Tracking Trust Transitively]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we import a package as well as checking that the direct imports are safe+according to the rules outlined in the Note [HscMain . Safe Haskell Trust Check]+we must also check that these rules hold transitively for all dependent modules+and packages. Doing this without caching any trust information would be very+slow as we would need to touch all packages and interface files a module depends+on. To avoid this we make use of the property that if a modules Safe Haskell+mode changes, this triggers a recompilation from that module in the dependcy+graph. So we can just worry mostly about direct imports.++There is one trust property that can change for a package though without+recompliation being triggered: package trust. So we must check that all+packages a module tranitively depends on to be trusted are still trusted when+we are compiling this module (as due to recompilation avoidance some modules+below may not be considered trusted any more without recompilation being+triggered).++We handle this by augmenting the existing transitive list of packages a module M+depends on with a bool for each package that says if it must be trusted when the+module M is being checked for trust. This list of trust required packages for a+single import is gathered in the rnImportDecl function and stored in an+ImportAvails data structure. The union of these trust required packages for all+imports is done by the rnImports function using the combine function which calls+the plusImportAvails function that is a union operation for the ImportAvails+type. This gives us in an ImportAvails structure all packages required to be+trusted for the module we are currently compiling. Checking that these packages+are still trusted (and that direct imports are trusted) is done in+HscMain.checkSafeImports.++See the note below, [Trust Own Package] for a corner case in this method and+how its handled.+++Note [Trust Own Package]+~~~~~~~~~~~~~~~~~~~~~~~~+There is a corner case of package trust checking that the usual transitive check+doesn't cover. (For how the usual check operates see the Note [Tracking Trust+Transitively] below). The case is when you import a -XSafe module M and M+imports a -XTrustworthy module N. If N resides in a different package than M,+then the usual check works as M will record a package dependency on N's package+and mark it as required to be trusted. If N resides in the same package as M+though, then importing M should require its own package be trusted due to N+(since M is -XSafe so doesn't create this requirement by itself). The usual+check fails as a module doesn't record a package dependency of its own package.+So instead we now have a bool field in a modules interface file that simply+states if the module requires its own package to be trusted. This field avoids+us having to load all interface files that the module depends on to see if one+is trustworthy.+++Note [Trust Transitive Property]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+So there is an interesting design question in regards to transitive trust+checking. Say I have a module B compiled with -XSafe. B is dependent on a bunch+of modules and packages, some packages it requires to be trusted as its using+-XTrustworthy modules from them. Now if I have a module A that doesn't use safe+haskell at all and simply imports B, should A inherit all the the trust+requirements from B? Should A now also require that a package p is trusted since+B required it?++We currently say no but saying yes also makes sense. The difference is, if a+module M that doesn't use Safe Haskell imports a module N that does, should all+the trusted package requirements be dropped since M didn't declare that it cares+about Safe Haskell (so -XSafe is more strongly associated with the module doing+the importing) or should it be done still since the author of the module N that+uses Safe Haskell said they cared (so -XSafe is more strongly associated with+the module that was compiled that used it).++Going with yes is a simpler semantics we think and harder for the user to stuff+up but it does mean that Safe Haskell will affect users who don't care about+Safe Haskell as they might grab a package from Cabal which uses safe haskell (say+network) and that packages imports -XTrustworthy modules from another package+(say bytestring), so requires that package is trusted. The user may now get+compilation errors in code that doesn't do anything with Safe Haskell simply+because they are using the network package. They will have to call 'ghc-pkg+trust network' to get everything working. Due to this invasive nature of going+with yes we have gone with no for now.+-}++-- | Process Import Decls.  See 'rnImportDecl' for a description of what+-- the return types represent.+-- Note: Do the non SOURCE ones first, so that we get a helpful warning+-- for SOURCE ones that are unnecessary+rnImports :: [LImportDecl RdrName]+          -> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails, AnyHpcUsage)+rnImports imports = do+    tcg_env <- getGblEnv+    -- NB: want an identity module here, because it's OK for a signature+    -- module to import from its implementor+    let this_mod = tcg_mod tcg_env+    let (source, ordinary) = partition is_source_import imports+        is_source_import d = ideclSource (unLoc d)+    stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary+    stuff2 <- mapAndReportM (rnImportDecl this_mod) source+    -- Safe Haskell: See Note [Tracking Trust Transitively]+    let (decls, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2)+    return (decls, rdr_env, imp_avails, hpc_usage)++  where+    combine :: [(LImportDecl Name,  GlobalRdrEnv, ImportAvails, AnyHpcUsage)]+            -> ([LImportDecl Name], GlobalRdrEnv, ImportAvails, AnyHpcUsage)+    combine = foldr plus ([], emptyGlobalRdrEnv, emptyImportAvails, False)++    plus (decl,  gbl_env1, imp_avails1,hpc_usage1)+         (decls, gbl_env2, imp_avails2,hpc_usage2)+      = ( decl:decls,+          gbl_env1 `plusGlobalRdrEnv` gbl_env2,+          imp_avails1 `plusImportAvails` imp_avails2,+          hpc_usage1 || hpc_usage2 )++-- | Given a located import declaration @decl@ from @this_mod@,+-- calculate the following pieces of information:+--+--  1. An updated 'LImportDecl', where all unresolved 'RdrName' in+--     the entity lists have been resolved into 'Name's,+--+--  2. A 'GlobalRdrEnv' representing the new identifiers that were+--     brought into scope (taking into account module qualification+--     and hiding),+--+--  3. 'ImportAvails' summarizing the identifiers that were imported+--     by this declaration, and+--+--  4. A boolean 'AnyHpcUsage' which is true if the imported module+--     used HPC.+rnImportDecl  :: Module -> LImportDecl RdrName+              -> RnM (LImportDecl Name, GlobalRdrEnv, ImportAvails, AnyHpcUsage)+rnImportDecl this_mod+             (L loc decl@(ImportDecl { ideclName = loc_imp_mod_name, ideclPkgQual = mb_pkg+                                     , ideclSource = want_boot, ideclSafe = mod_safe+                                     , ideclQualified = qual_only, ideclImplicit = implicit+                                     , ideclAs = as_mod, ideclHiding = imp_details }))+  = setSrcSpan loc $ do++    when (isJust mb_pkg) $ do+        pkg_imports <- xoptM LangExt.PackageImports+        when (not pkg_imports) $ addErr packageImportErr++    -- If there's an error in loadInterface, (e.g. interface+    -- file not found) we get lots of spurious errors from 'filterImports'+    let imp_mod_name = unLoc loc_imp_mod_name+        doc = ppr imp_mod_name <+> text "is directly imported"++    -- Check for self-import, which confuses the typechecker (Trac #9032)+    -- ghc --make rejects self-import cycles already, but batch-mode may not+    -- at least not until TcIface.tcHiBootIface, which is too late to avoid+    -- typechecker crashes.  (Indirect self imports are not caught until+    -- TcIface, see #10337 tracking how to make this error better.)+    --+    -- Originally, we also allowed 'import {-# SOURCE #-} M', but this+    -- caused bug #10182: in one-shot mode, we should never load an hs-boot+    -- file for the module we are compiling into the EPS.  In principle,+    -- it should be possible to support this mode of use, but we would have to+    -- extend Provenance to support a local definition in a qualified location.+    -- For now, we don't support it, but see #10336+    when (imp_mod_name == moduleName this_mod &&+          (case mb_pkg of  -- If we have import "<pkg>" M, then we should+                           -- check that "<pkg>" is "this" (which is magic)+                           -- or the name of this_mod's package.  Yurgh!+                           -- c.f. GHC.findModule, and Trac #9997+             Nothing         -> True+             Just (StringLiteral _ pkg_fs) -> pkg_fs == fsLit "this" ||+                            fsToUnitId pkg_fs == moduleUnitId this_mod))+         (addErr (text "A module cannot import itself:" <+> ppr imp_mod_name))++    -- Check for a missing import list (Opt_WarnMissingImportList also+    -- checks for T(..) items but that is done in checkDodgyImport below)+    case imp_details of+        Just (False, _) -> return () -- Explicit import list+        _  | implicit   -> return () -- Do not bleat for implicit imports+           | qual_only  -> return ()+           | otherwise  -> whenWOptM Opt_WarnMissingImportList $+                           addWarn (Reason Opt_WarnMissingImportList)+                                   (missingImportListWarn imp_mod_name)++    iface <- loadSrcInterface doc imp_mod_name want_boot (fmap sl_fs mb_pkg)++    -- Compiler sanity check: if the import didn't say+    -- {-# SOURCE #-} we should not get a hi-boot file+    WARN( not want_boot && mi_boot iface, ppr imp_mod_name ) do++    -- Issue a user warning for a redundant {- SOURCE -} import+    -- NB that we arrange to read all the ordinary imports before+    -- any of the {- SOURCE -} imports.+    --+    -- in --make and GHCi, the compilation manager checks for this,+    -- and indeed we shouldn't do it here because the existence of+    -- the non-boot module depends on the compilation order, which+    -- is not deterministic.  The hs-boot test can show this up.+    dflags <- getDynFlags+    warnIf NoReason+           (want_boot && not (mi_boot iface) && isOneShot (ghcMode dflags))+           (warnRedundantSourceImport imp_mod_name)+    when (mod_safe && not (safeImportsOn dflags)) $+        addErr (text "safe import can't be used as Safe Haskell isn't on!"+                $+$ ptext (sLit $ "please enable Safe Haskell through either "+                                   ++ "Safe, Trustworthy or Unsafe"))++    let+        qual_mod_name = fmap unLoc as_mod `orElse` imp_mod_name+        imp_spec  = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only,+                                  is_dloc = loc, is_as = qual_mod_name }++    -- filter the imports according to the import declaration+    (new_imp_details, gres) <- filterImports iface imp_spec imp_details++    -- for certain error messages, we’d like to know what could be imported+    -- here, if everything were imported+    potential_gres <- mkGlobalRdrEnv . snd <$> filterImports iface imp_spec Nothing++    let gbl_env = mkGlobalRdrEnv gres++        is_hiding | Just (True,_) <- imp_details = True+                  | otherwise                    = False++        -- should the import be safe?+        mod_safe' = mod_safe+                    || (not implicit && safeDirectImpsReq dflags)+                    || (implicit && safeImplicitImpsReq dflags)++    let imv = ImportedModsVal+            { imv_name        = qual_mod_name+            , imv_span        = loc+            , imv_is_safe     = mod_safe'+            , imv_is_hiding   = is_hiding+            , imv_all_exports = potential_gres+            , imv_qualified   = qual_only+            }+        imports = calculateAvails dflags iface mod_safe' want_boot (ImportedByUser imv)++    -- Complain if we import a deprecated module+    whenWOptM Opt_WarnWarningsDeprecations (+       case (mi_warns iface) of+          WarnAll txt -> addWarn (Reason Opt_WarnWarningsDeprecations)+                                (moduleWarn imp_mod_name txt)+          _           -> return ()+     )++    let new_imp_decl = L loc (decl { ideclSafe = mod_safe'+                                   , ideclHiding = new_imp_details })++    return (new_imp_decl, gbl_env, imports, mi_hpc iface)++-- | Calculate the 'ImportAvails' induced by an import of a particular+-- interface, but without 'imp_mods'.+calculateAvails :: DynFlags+                -> ModIface+                -> IsSafeImport+                -> IsBootInterface+                -> ImportedBy+                -> ImportAvails+calculateAvails dflags iface mod_safe' want_boot imported_by =+  let imp_mod    = mi_module iface+      imp_sem_mod= mi_semantic_module iface+      orph_iface = mi_orphan iface+      has_finsts = mi_finsts iface+      deps       = mi_deps iface+      trust      = getSafeMode $ mi_trust iface+      trust_pkg  = mi_trust_pkg iface++      -- If the module exports anything defined in this module, just+      -- ignore it.  Reason: otherwise it looks as if there are two+      -- local definition sites for the thing, and an error gets+      -- reported.  Easiest thing is just to filter them out up+      -- front. This situation only arises if a module imports+      -- itself, or another module that imported it.  (Necessarily,+      -- this invoves a loop.)+      --+      -- We do this *after* filterImports, so that if you say+      --      module A where+      --         import B( AType )+      --         type AType = ...+      --+      --      module B( AType ) where+      --         import {-# SOURCE #-} A( AType )+      --+      -- then you won't get a 'B does not export AType' message.+++      -- Compute new transitive dependencies+      --+      -- 'dep_orphs' and 'dep_finsts' do NOT include the imported module+      -- itself, but we DO need to include this module in 'imp_orphs' and+      -- 'imp_finsts' if it defines an orphan or instance family; thus the+      -- orph_iface/has_iface tests.++      orphans | orph_iface = ASSERT2( not (imp_sem_mod `elem` dep_orphs deps), ppr imp_sem_mod <+> ppr (dep_orphs deps) )+                             imp_sem_mod : dep_orphs deps+              | otherwise  = dep_orphs deps++      finsts | has_finsts = ASSERT2( not (imp_sem_mod `elem` dep_finsts deps), ppr imp_sem_mod <+> ppr (dep_orphs deps) )+                            imp_sem_mod : dep_finsts deps+             | otherwise  = dep_finsts deps++      pkg = moduleUnitId (mi_module iface)+      ipkg = toInstalledUnitId pkg++      -- Does this import mean we now require our own pkg+      -- to be trusted? See Note [Trust Own Package]+      ptrust = trust == Sf_Trustworthy || trust_pkg++      (dependent_mods, dependent_pkgs, pkg_trust_req)+         | pkg == thisPackage dflags =+            -- Imported module is from the home package+            -- Take its dependent modules and add imp_mod itself+            -- Take its dependent packages unchanged+            --+            -- NB: (dep_mods deps) might include a hi-boot file+            -- for the module being compiled, CM. Do *not* filter+            -- this out (as we used to), because when we've+            -- finished dealing with the direct imports we want to+            -- know if any of them depended on CM.hi-boot, in+            -- which case we should do the hi-boot consistency+            -- check.  See LoadIface.loadHiBootInterface+            ((moduleName imp_mod,want_boot):dep_mods deps,dep_pkgs deps,ptrust)++         | otherwise =+            -- Imported module is from another package+            -- Dump the dependent modules+            -- Add the package imp_mod comes from to the dependent packages+            ASSERT2( not (ipkg `elem` (map fst $ dep_pkgs deps))+                   , ppr ipkg <+> ppr (dep_pkgs deps) )+            ([], (ipkg, False) : dep_pkgs deps, False)++  in ImportAvails {+          imp_mods       = unitModuleEnv (mi_module iface) [imported_by],+          imp_orphs      = orphans,+          imp_finsts     = finsts,+          imp_dep_mods   = mkModDeps dependent_mods,+          imp_dep_pkgs   = S.fromList . map fst $ dependent_pkgs,+          -- Add in the imported modules trusted package+          -- requirements. ONLY do this though if we import the+          -- module as a safe import.+          -- See Note [Tracking Trust Transitively]+          -- and Note [Trust Transitive Property]+          imp_trust_pkgs = if mod_safe'+                               then S.fromList . map fst $ filter snd dependent_pkgs+                               else S.empty,+          -- Do we require our own pkg to be trusted?+          -- See Note [Trust Own Package]+          imp_trust_own_pkg = pkg_trust_req+     }+++warnRedundantSourceImport :: ModuleName -> SDoc+warnRedundantSourceImport mod_name+  = text "Unnecessary {-# SOURCE #-} in the import of module"+          <+> quotes (ppr mod_name)++{-+************************************************************************+*                                                                      *+\subsection{importsFromLocalDecls}+*                                                                      *+************************************************************************++From the top-level declarations of this module produce+        * the lexical environment+        * the ImportAvails+created by its bindings.++Note [Top-level Names in Template Haskell decl quotes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also: Note [Interactively-bound Ids in GHCi] in HscTypes+          Note [Looking up Exact RdrNames] in RnEnv++Consider a Template Haskell declaration quotation like this:+      module M where+        f x = h [d| f = 3 |]+When renaming the declarations inside [d| ...|], we treat the+top level binders specially in two ways++1.  We give them an Internal Name, not (as usual) an External one.+    This is done by RnEnv.newTopSrcBinder.++2.  We make them *shadow* the outer bindings.+    See Note [GlobalRdrEnv shadowing]++3. We find out whether we are inside a [d| ... |] by testing the TH+   stage. This is a slight hack, because the stage field was really+   meant for the type checker, and here we are not interested in the+   fields of Brack, hence the error thunks in thRnBrack.+-}++extendGlobalRdrEnvRn :: [AvailInfo]+                     -> MiniFixityEnv+                     -> RnM (TcGblEnv, TcLclEnv)+-- Updates both the GlobalRdrEnv and the FixityEnv+-- We return a new TcLclEnv only because we might have to+-- delete some bindings from it;+-- see Note [Top-level Names in Template Haskell decl quotes]++extendGlobalRdrEnvRn avails new_fixities+  = do  { (gbl_env, lcl_env) <- getEnvs+        ; stage <- getStage+        ; isGHCi <- getIsGHCi+        ; let rdr_env  = tcg_rdr_env gbl_env+              fix_env  = tcg_fix_env gbl_env+              th_bndrs = tcl_th_bndrs lcl_env+              th_lvl   = thLevel stage++              -- Delete new_occs from global and local envs+              -- If we are in a TemplateHaskell decl bracket,+              --    we are going to shadow them+              -- See Note [GlobalRdrEnv shadowing]+              inBracket = isBrackStage stage++              lcl_env_TH = lcl_env { tcl_rdr = delLocalRdrEnvList (tcl_rdr lcl_env) new_occs }+                           -- See Note [GlobalRdrEnv shadowing]++              lcl_env2 | inBracket = lcl_env_TH+                       | otherwise = lcl_env++              -- Deal with shadowing: see Note [GlobalRdrEnv shadowing]+              want_shadowing = isGHCi || inBracket+              rdr_env1 | want_shadowing = shadowNames rdr_env new_names+                       | otherwise      = rdr_env++              lcl_env3 = lcl_env2 { tcl_th_bndrs = extendNameEnvList th_bndrs+                                                       [ (n, (TopLevel, th_lvl))+                                                       | n <- new_names ] }++        ; rdr_env2 <- foldlM add_gre rdr_env1 new_gres++        ; let fix_env' = foldl extend_fix_env fix_env new_gres+              gbl_env' = gbl_env { tcg_rdr_env = rdr_env2, tcg_fix_env = fix_env' }++        ; traceRn "extendGlobalRdrEnvRn 2" (pprGlobalRdrEnv True rdr_env2)+        ; return (gbl_env', lcl_env3) }+  where+    new_names = concatMap availNames avails+    new_occs  = map nameOccName new_names++    -- If there is a fixity decl for the gre, add it to the fixity env+    extend_fix_env fix_env gre+      | Just (L _ fi) <- lookupFsEnv new_fixities (occNameFS occ)+      = extendNameEnv fix_env name (FixItem occ fi)+      | otherwise+      = fix_env+      where+        name = gre_name gre+        occ  = greOccName gre++    new_gres :: [GlobalRdrElt]  -- New LocalDef GREs, derived from avails+    new_gres = concatMap localGREsFromAvail avails++    add_gre :: GlobalRdrEnv -> GlobalRdrElt -> RnM GlobalRdrEnv+    -- Extend the GlobalRdrEnv with a LocalDef GRE+    -- If there is already a LocalDef GRE with the same OccName,+    --    report an error and discard the new GRE+    -- This establishes INVARIANT 1 of GlobalRdrEnvs+    add_gre env gre+      | not (null dups)    -- Same OccName defined twice+      = do { addDupDeclErr (gre : dups); return env }++      | otherwise+      = return (extendGlobalRdrEnv env gre)+      where+        name = gre_name gre+        occ  = nameOccName name+        dups = filter isLocalGRE (lookupGlobalRdrEnv env occ)+++{- *********************************************************************+*                                                                      *+    getLocalDeclBindersd@ returns the names for an HsDecl+             It's used for source code.++        *** See Note [The Naming story] in HsDecls ****+*                                                                      *+********************************************************************* -}++getLocalNonValBinders :: MiniFixityEnv -> HsGroup RdrName+    -> RnM ((TcGblEnv, TcLclEnv), NameSet)+-- Get all the top-level binders bound the group *except*+-- for value bindings, which are treated separately+-- Specifically we return AvailInfo for+--      * type decls (incl constructors and record selectors)+--      * class decls (including class ops)+--      * associated types+--      * foreign imports+--      * value signatures (in hs-boot files only)++getLocalNonValBinders fixity_env+     (HsGroup { hs_valds  = binds,+                hs_tyclds = tycl_decls,+                hs_fords  = foreign_decls })+  = do  { -- Process all type/class decls *except* family instances+        ; let inst_decls = tycl_decls >>= group_instds+        ; overload_ok <- xoptM LangExt.DuplicateRecordFields+        ; (tc_avails, tc_fldss)+            <- fmap unzip $ mapM (new_tc overload_ok)+                                 (tyClGroupTyClDecls tycl_decls)+        ; traceRn "getLocalNonValBinders 1" (ppr tc_avails)+        ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env+        ; setEnvs envs $ do {+            -- Bring these things into scope first+            -- See Note [Looking up family names in family instances]++          -- Process all family instances+          -- to bring new data constructors into scope+        ; (nti_availss, nti_fldss) <- mapAndUnzipM (new_assoc overload_ok)+                                                   inst_decls++          -- Finish off with value binders:+          --    foreign decls and pattern synonyms for an ordinary module+          --    type sigs in case of a hs-boot file only+        ; is_boot <- tcIsHsBootOrSig+        ; let val_bndrs | is_boot   = hs_boot_sig_bndrs+                        | otherwise = for_hs_bndrs+        ; val_avails <- mapM new_simple val_bndrs++        ; let avails    = concat nti_availss ++ val_avails+              new_bndrs = availsToNameSetWithSelectors avails `unionNameSet`+                          availsToNameSetWithSelectors tc_avails+              flds      = concat nti_fldss ++ concat tc_fldss+        ; traceRn "getLocalNonValBinders 2" (ppr avails)+        ; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn avails fixity_env++        -- Extend tcg_field_env with new fields (this used to be the+        -- work of extendRecordFieldEnv)+        ; let field_env = extendNameEnvList (tcg_field_env tcg_env) flds+              envs      = (tcg_env { tcg_field_env = field_env }, tcl_env)++        ; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env])+        ; return (envs, new_bndrs) } }+  where+    ValBindsIn _val_binds val_sigs = binds++    for_hs_bndrs :: [Located RdrName]+    for_hs_bndrs = hsForeignDeclsBinders foreign_decls++    -- In a hs-boot file, the value binders come from the+    --  *signatures*, and there should be no foreign binders+    hs_boot_sig_bndrs = [ L decl_loc (unLoc n)+                        | L decl_loc (TypeSig ns _) <- val_sigs, n <- ns]++      -- the SrcSpan attached to the input should be the span of the+      -- declaration, not just the name+    new_simple :: Located RdrName -> RnM AvailInfo+    new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name+                            ; return (avail nm) }++    new_tc :: Bool -> LTyClDecl RdrName+           -> RnM (AvailInfo, [(Name, [FieldLabel])])+    new_tc overload_ok tc_decl -- NOT for type/data instances+        = do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl+             ; names@(main_name : sub_names) <- mapM newTopSrcBinder bndrs+             ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds+             ; let fld_env = case unLoc tc_decl of+                     DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds'+                     _                            -> []+             ; return (AvailTC main_name names flds', fld_env) }+++    -- Calculate the mapping from constructor names to fields, which+    -- will go in tcg_field_env. It's convenient to do this here where+    -- we are working with a single datatype definition.+    mk_fld_env :: HsDataDefn RdrName -> [Name] -> [FieldLabel] -> [(Name, [FieldLabel])]+    mk_fld_env d names flds = concatMap find_con_flds (dd_cons d)+      where+        find_con_flds (L _ (ConDeclH98 { con_name    = L _ rdr+                                       , con_details = RecCon cdflds }))+            = [( find_con_name rdr+               , concatMap find_con_decl_flds (unLoc cdflds) )]+        find_con_flds (L _ (ConDeclGADT+                              { con_names = rdrs+                              , con_type = (HsIB { hsib_body = res_ty})}))+            = map (\ (L _ rdr) -> ( find_con_name rdr+                                  , concatMap find_con_decl_flds cdflds))+                  rdrs+            where+              (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty+              cdflds = case tau of+                 L _ (HsFunTy+                      (L _ (HsAppsTy+                        [L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _) -> flds+                 L _ (HsFunTy (L _ (HsRecTy flds)) _) -> flds+                 _                                    -> []+        find_con_flds _ = []++        find_con_name rdr+          = expectJust "getLocalNonValBinders/find_con_name" $+              find (\ n -> nameOccName n == rdrNameOcc rdr) names+        find_con_decl_flds (L _ x)+          = map find_con_decl_fld (cd_fld_names x)+        find_con_decl_fld  (L _ (FieldOcc (L _ rdr) _))+          = expectJust "getLocalNonValBinders/find_con_decl_fld" $+              find (\ fl -> flLabel fl == lbl) flds+          where lbl = occNameFS (rdrNameOcc rdr)++    new_assoc :: Bool -> LInstDecl RdrName+              -> RnM ([AvailInfo], [(Name, [FieldLabel])])+    new_assoc _ (L _ (TyFamInstD {})) = return ([], [])+      -- type instances don't bind new names++    new_assoc overload_ok (L _ (DataFamInstD d))+      = do { (avail, flds) <- new_di overload_ok Nothing d+           ; return ([avail], flds) }+    new_assoc overload_ok (L _ (ClsInstD (ClsInstDecl { cid_poly_ty = inst_ty+                                                      , cid_datafam_insts = adts })))+      | Just (L loc cls_rdr) <- getLHsInstDeclClass_maybe inst_ty+      = do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr+           ; (avails, fldss)+                    <- mapAndUnzipM (new_loc_di overload_ok (Just cls_nm)) adts+           ; return (avails, concat fldss) }+      | otherwise+      = return ([], [])    -- Do not crash on ill-formed instances+                           -- Eg   instance !Show Int   Trac #3811c++    new_di :: Bool -> Maybe Name -> DataFamInstDecl RdrName+                   -> RnM (AvailInfo, [(Name, [FieldLabel])])+    new_di overload_ok mb_cls ti_decl+        = do { main_name <- lookupFamInstName mb_cls (dfid_tycon ti_decl)+             ; let (bndrs, flds) = hsDataFamInstBinders ti_decl+             ; sub_names <- mapM newTopSrcBinder bndrs+             ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds+             ; let avail    = AvailTC (unLoc main_name) sub_names flds'+                                  -- main_name is not bound here!+                   fld_env  = mk_fld_env (dfid_defn ti_decl) sub_names flds'+             ; return (avail, fld_env) }++    new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl RdrName+                   -> RnM (AvailInfo, [(Name, [FieldLabel])])+    new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d++newRecordSelector :: Bool -> [Name] -> LFieldOcc RdrName -> RnM FieldLabel+newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!"+newRecordSelector overload_ok (dc:_) (L loc (FieldOcc (L _ fld) _))+  = do { selName <- newTopSrcBinder $ L loc $ field+       ; return $ qualFieldLbl { flSelector = selName } }+  where+    fieldOccName = occNameFS $ rdrNameOcc fld+    qualFieldLbl = mkFieldLabelOccs fieldOccName (nameOccName dc) overload_ok+    field | isExact fld = fld+              -- use an Exact RdrName as is to preserve the bindings+              -- of an already renamer-resolved field and its use+              -- sites. This is needed to correctly support record+              -- selectors in Template Haskell. See Note [Binders in+              -- Template Haskell] in Convert.hs and Note [Looking up+              -- Exact RdrNames] in RnEnv.hs.+          | otherwise   = mkRdrUnqual (flSelector qualFieldLbl)++{-+Note [Looking up family names in family instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++  module M where+    type family T a :: *+    type instance M.T Int = Bool++We might think that we can simply use 'lookupOccRn' when processing the type+instance to look up 'M.T'.  Alas, we can't!  The type family declaration is in+the *same* HsGroup as the type instance declaration.  Hence, as we are+currently collecting the binders declared in that HsGroup, these binders will+not have been added to the global environment yet.++Solution is simple: process the type family declarations first, extend+the environment, and then process the type instances.+++************************************************************************+*                                                                      *+\subsection{Filtering imports}+*                                                                      *+************************************************************************++@filterImports@ takes the @ExportEnv@ telling what the imported module makes+available, and filters it through the import spec (if any).++Note [Dealing with imports]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+For import M( ies ), we take the mi_exports of M, and make+   imp_occ_env :: OccEnv (Name, AvailInfo, Maybe Name)+One entry for each Name that M exports; the AvailInfo is the+AvailInfo exported from M that exports that Name.++The situation is made more complicated by associated types. E.g.+   module M where+     class    C a    where { data T a }+     instance C Int  where { data T Int = T1 | T2 }+     instance C Bool where { data T Int = T3 }+Then M's export_avails are (recall the AvailTC invariant from Avails.hs)+  C(C,T), T(T,T1,T2,T3)+Notice that T appears *twice*, once as a child and once as a parent. From+this list we construt a raw list including+   T -> (T, T( T1, T2, T3 ), Nothing)+   T -> (C, C( C, T ),       Nothing)+and we combine these (in function 'combine' in 'imp_occ_env' in+'filterImports') to get+   T  -> (T,  T(T,T1,T2,T3), Just C)++So the overall imp_occ_env is+   C  -> (C,  C(C,T),        Nothing)+   T  -> (T,  T(T,T1,T2,T3), Just C)+   T1 -> (T1, T(T,T1,T2,T3), Nothing)   -- similarly T2,T3++If we say+   import M( T(T1,T2) )+then we get *two* Avails:  C(T), T(T1,T2)++Note that the imp_occ_env will have entries for data constructors too,+although we never look up data constructors.+-}++filterImports+    :: ModIface+    -> ImpDeclSpec                     -- The span for the entire import decl+    -> Maybe (Bool, Located [LIE RdrName])    -- Import spec; True => hiding+    -> RnM (Maybe (Bool, Located [LIE Name]), -- Import spec w/ Names+            [GlobalRdrElt])                   -- Same again, but in GRE form+filterImports iface decl_spec Nothing+  = return (Nothing, gresFromAvails (Just imp_spec) (mi_exports iface))+  where+    imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll }+++filterImports iface decl_spec (Just (want_hiding, L l import_items))+  = do  -- check for errors, convert RdrNames to Names+        items1 <- mapM lookup_lie import_items++        let items2 :: [(LIE Name, AvailInfo)]+            items2 = concat items1+                -- NB the AvailInfo may have duplicates, and several items+                --    for the same parent; e.g N(x) and N(y)++            names  = availsToNameSet (map snd items2)+            keep n = not (n `elemNameSet` names)+            pruned_avails = filterAvails keep all_avails+            hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll }++            gres | want_hiding = gresFromAvails (Just hiding_spec) pruned_avails+                 | otherwise   = concatMap (gresFromIE decl_spec) items2++        return (Just (want_hiding, L l (map fst items2)), gres)+  where+    all_avails = mi_exports iface++        -- See Note [Dealing with imports]+    imp_occ_env :: OccEnv (Name,        -- the name+                           AvailInfo,   -- the export item providing the name+                           Maybe Name)  -- the parent of associated types+    imp_occ_env = mkOccEnv_C combine [ (nameOccName n, (n, a, Nothing))+                                     | a <- all_avails, n <- availNames a]+      where+        -- See Note [Dealing with imports]+        -- 'combine' is only called for associated data types which appear+        -- twice in the all_avails. In the example, we combine+        --    T(T,T1,T2,T3) and C(C,T)  to give   (T, T(T,T1,T2,T3), Just C)+        -- NB: the AvailTC can have fields as well as data constructors (Trac #12127)+        combine (name1, a1@(AvailTC p1 _ _), mp1)+                (name2, a2@(AvailTC p2 _ _), mp2)+          = ASSERT2( name1 == name2 && isNothing mp1 && isNothing mp2+                   , ppr name1 <+> ppr name2 <+> ppr mp1 <+> ppr mp2 )+            if p1 == name1 then (name1, a1, Just p2)+                           else (name1, a2, Just p1)+        combine x y = pprPanic "filterImports/combine" (ppr x $$ ppr y)++    lookup_name :: RdrName -> IELookupM (Name, AvailInfo, Maybe Name)+    lookup_name rdr | isQual rdr              = failLookupWith (QualImportError rdr)+                    | Just succ <- mb_success = return succ+                    | otherwise               = failLookupWith BadImport+      where+        mb_success = lookupOccEnv imp_occ_env (rdrNameOcc rdr)++    lookup_lie :: LIE RdrName -> TcRn [(LIE Name, AvailInfo)]+    lookup_lie (L loc ieRdr)+        = do (stuff, warns) <- setSrcSpan loc $+                               liftM (fromMaybe ([],[])) $+                               run_lookup (lookup_ie ieRdr)+             mapM_ emit_warning warns+             return [ (L loc ie, avail) | (ie,avail) <- stuff ]+        where+            -- Warn when importing T(..) if T was exported abstractly+            emit_warning (DodgyImport n) = whenWOptM Opt_WarnDodgyImports $+              addWarn (Reason Opt_WarnDodgyImports) (dodgyImportWarn n)+            emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $+              addWarn (Reason Opt_WarnMissingImportList) (missingImportListItem ieRdr)+            emit_warning BadImportW = whenWOptM Opt_WarnDodgyImports $+              addWarn (Reason Opt_WarnDodgyImports) (lookup_err_msg BadImport)++            run_lookup :: IELookupM a -> TcRn (Maybe a)+            run_lookup m = case m of+              Failed err -> addErr (lookup_err_msg err) >> return Nothing+              Succeeded a -> return (Just a)++            lookup_err_msg err = case err of+              BadImport -> badImportItemErr iface decl_spec ieRdr all_avails+              IllegalImport -> illegalImportItemErr+              QualImportError rdr -> qualImportItemErr rdr++        -- For each import item, we convert its RdrNames to Names,+        -- and at the same time construct an AvailInfo corresponding+        -- to what is actually imported by this item.+        -- Returns Nothing on error.+        -- We return a list here, because in the case of an import+        -- item like C, if we are hiding, then C refers to *both* a+        -- type/class and a data constructor.  Moreover, when we import+        -- data constructors of an associated family, we need separate+        -- AvailInfos for the data constructors and the family (as they have+        -- different parents).  See Note [Dealing with imports]+    lookup_ie :: IE RdrName -> IELookupM ([(IE Name, AvailInfo)], [IELookupWarning])+    lookup_ie ie = handle_bad_import $ do+      case ie of+        IEVar (L l n) -> do+            (name, avail, _) <- lookup_name $ ieWrappedName n+            return ([(IEVar (L l (replaceWrappedName n name)),+                                                  trimAvail avail name)], [])++        IEThingAll (L l tc) -> do+            (name, avail, mb_parent) <- lookup_name $ ieWrappedName tc+            let warns = case avail of+                          Avail {}                     -- e.g. f(..)+                            -> [DodgyImport $ ieWrappedName tc]++                          AvailTC _ subs fs+                            | null (drop 1 subs) && null fs -- e.g. T(..) where T is a synonym+                            -> [DodgyImport $ ieWrappedName tc]++                            | not (is_qual decl_spec)  -- e.g. import M( T(..) )+                            -> [MissingImportList]++                            | otherwise+                            -> []++                renamed_ie = IEThingAll (L l (replaceWrappedName tc name))+                sub_avails = case avail of+                               Avail {}              -> []+                               AvailTC name2 subs fs -> [(renamed_ie, AvailTC name2 (subs \\ [name]) fs)]+            case mb_parent of+              Nothing     -> return ([(renamed_ie, avail)], warns)+                             -- non-associated ty/cls+              Just parent -> return ((renamed_ie, AvailTC parent [name] []) : sub_avails, warns)+                             -- associated type++        IEThingAbs (L l tc')+            | want_hiding   -- hiding ( C )+                       -- Here the 'C' can be a data constructor+                       --  *or* a type/class, or even both+            -> let tc = ieWrappedName tc'+                   tc_name = lookup_name tc+                   dc_name = lookup_name (setRdrNameSpace tc srcDataName)+               in+               case catIELookupM [ tc_name, dc_name ] of+                 []    -> failLookupWith BadImport+                 names -> return ([mkIEThingAbs tc' l name | name <- names], [])+            | otherwise+            -> do nameAvail <- lookup_name (ieWrappedName tc')+                  return ([mkIEThingAbs tc' l nameAvail]+                         , [])++        IEThingWith (L l rdr_tc) wc rdr_ns' rdr_fs ->+          ASSERT2(null rdr_fs, ppr rdr_fs) do+           (name, AvailTC _ ns subflds, mb_parent)+                                         <- lookup_name (ieWrappedName rdr_tc)++           -- Look up the children in the sub-names of the parent+           let subnames = case ns of   -- The tc is first in ns,+                            [] -> []   -- if it is there at all+                                       -- See the AvailTC Invariant in Avail.hs+                            (n1:ns1) | n1 == name -> ns1+                                     | otherwise  -> ns+               rdr_ns = map ieLWrappedName rdr_ns'+           case lookupChildren (map Left subnames ++ map Right subflds) rdr_ns of+             Nothing                      -> failLookupWith BadImport+             Just (childnames, childflds) ->+               case mb_parent of+                 -- non-associated ty/cls+                 Nothing+                   -> return ([(IEThingWith (L l name') wc childnames'+                                                           childflds,+                               AvailTC name (name:map unLoc childnames) (map unLoc childflds))],+                              [])+                   where name' = replaceWrappedName rdr_tc name+                         childnames' = map to_ie_post_rn childnames+                         -- childnames' = postrn_ies childnames+                 -- associated ty+                 Just parent+                   -> return ([(IEThingWith (L l name') wc childnames'+                                                           childflds,+                                AvailTC name (map unLoc childnames) (map unLoc childflds)),+                               (IEThingWith (L l name') wc childnames'+                                                           childflds,+                                AvailTC parent [name] [])],+                              [])+                   where name' = replaceWrappedName rdr_tc name+                         childnames' = map to_ie_post_rn childnames++        _other -> failLookupWith IllegalImport+        -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed+        -- all errors.++      where+        mkIEThingAbs tc l (n, av, Nothing    )+          = (IEThingAbs (L l (replaceWrappedName tc n)), trimAvail av n)+        mkIEThingAbs tc l (n, _,  Just parent)+          = (IEThingAbs (L l (replaceWrappedName tc n)), AvailTC parent [n] [])++        handle_bad_import m = catchIELookup m $ \err -> case err of+          BadImport | want_hiding -> return ([], [BadImportW])+          _                       -> failLookupWith err++type IELookupM = MaybeErr IELookupError++data IELookupWarning+  = BadImportW+  | MissingImportList+  | DodgyImport RdrName+  -- NB. use the RdrName for reporting a "dodgy" import++data IELookupError+  = QualImportError RdrName+  | BadImport+  | IllegalImport++failLookupWith :: IELookupError -> IELookupM a+failLookupWith err = Failed err++catchIELookup :: IELookupM a -> (IELookupError -> IELookupM a) -> IELookupM a+catchIELookup m h = case m of+  Succeeded r -> return r+  Failed err  -> h err++catIELookupM :: [IELookupM a] -> [a]+catIELookupM ms = [ a | Succeeded a <- ms ]++{-+************************************************************************+*                                                                      *+\subsection{Import/Export Utils}+*                                                                      *+************************************************************************+-}++-- | Given an import\/export spec, construct the appropriate 'GlobalRdrElt's.+gresFromIE :: ImpDeclSpec -> (LIE Name, AvailInfo) -> [GlobalRdrElt]+gresFromIE decl_spec (L loc ie, avail)+  = gresFromAvail prov_fn avail+  where+    is_explicit = case ie of+                    IEThingAll (L _ name) -> \n -> n == ieWrappedName name+                    _                     -> \_ -> True+    prov_fn name+      = Just (ImpSpec { is_decl = decl_spec, is_item = item_spec })+      where+        item_spec = ImpSome { is_explicit = is_explicit name, is_iloc = loc }+++{-+Note [Children for duplicate record fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the module++    {-# LANGUAGE DuplicateRecordFields #-}+    module M (F(foo, MkFInt, MkFBool)) where+      data family F a+      data instance F Int = MkFInt { foo :: Int }+      data instance F Bool = MkFBool { foo :: Bool }++The `foo` in the export list refers to *both* selectors! For this+reason, lookupChildren builds an environment that maps the FastString+to a list of items, rather than a single item.+-}++mkChildEnv :: [GlobalRdrElt] -> NameEnv [GlobalRdrElt]+mkChildEnv gres = foldr add emptyNameEnv gres+  where+    add gre env = case gre_par gre of+        FldParent p _  -> extendNameEnv_Acc (:) singleton env p gre+        ParentIs  p    -> extendNameEnv_Acc (:) singleton env p gre+        NoParent       -> env++findChildren :: NameEnv [a] -> Name -> [a]+findChildren env n = lookupNameEnv env n `orElse` []++lookupChildren :: [Either Name FieldLabel] -> [Located RdrName]+               -> Maybe ([Located Name], [Located FieldLabel])+-- (lookupChildren all_kids rdr_items) maps each rdr_item to its+-- corresponding Name all_kids, if the former exists+-- The matching is done by FastString, not OccName, so that+--    Cls( meth, AssocTy )+-- will correctly find AssocTy among the all_kids of Cls, even though+-- the RdrName for AssocTy may have a (bogus) DataName namespace+-- (Really the rdr_items should be FastStrings in the first place.)+lookupChildren all_kids rdr_items+  = do xs <- mapM doOne rdr_items+       return (fmap concat (partitionEithers xs))+  where+    doOne (L l r) = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc) r of+      Just [Left n]            -> Just (Left (L l n))+      Just rs | all isRight rs -> Just (Right (map (L l) (rights rs)))+      _                        -> Nothing++    -- See Note [Children for duplicate record fields]+    kid_env = extendFsEnvList_C (++) emptyFsEnv+                      [(either (occNameFS . nameOccName) flLabel x, [x]) | x <- all_kids]++++-------------------------------++{-+*********************************************************+*                                                       *+\subsection{Unused names}+*                                                       *+*********************************************************+-}++reportUnusedNames :: Maybe (Located [LIE RdrName])  -- Export list+                  -> TcGblEnv -> RnM ()+reportUnusedNames _export_decls gbl_env+  = do  { traceRn "RUN" (ppr (tcg_dus gbl_env))+        ; warnUnusedImportDecls gbl_env+        ; warnUnusedTopBinds unused_locals+        ; warnMissingSignatures gbl_env }+  where+    used_names :: NameSet+    used_names = findUses (tcg_dus gbl_env) emptyNameSet+    -- NB: currently, if f x = g, we only treat 'g' as used if 'f' is used+    -- Hence findUses++    -- Collect the defined names from the in-scope environment+    defined_names :: [GlobalRdrElt]+    defined_names = globalRdrEnvElts (tcg_rdr_env gbl_env)++    -- Note that defined_and_used, defined_but_not_used+    -- are both [GRE]; that's why we need defined_and_used+    -- rather than just used_names+    _defined_and_used, defined_but_not_used :: [GlobalRdrElt]+    (_defined_and_used, defined_but_not_used)+        = partition (gre_is_used used_names) defined_names++    kids_env = mkChildEnv defined_names+    -- This is done in mkExports too; duplicated work++    gre_is_used :: NameSet -> GlobalRdrElt -> Bool+    gre_is_used used_names (GRE {gre_name = name})+        = name `elemNameSet` used_names+          || any (\ gre -> gre_name gre `elemNameSet` used_names) (findChildren kids_env name)+                -- A use of C implies a use of T,+                -- if C was brought into scope by T(..) or T(C)++    -- Filter out the ones that are+    --  (a) defined in this module, and+    --  (b) not defined by a 'deriving' clause+    -- The latter have an Internal Name, so we can filter them out easily+    unused_locals :: [GlobalRdrElt]+    unused_locals = filter is_unused_local defined_but_not_used+    is_unused_local :: GlobalRdrElt -> Bool+    is_unused_local gre = isLocalGRE gre && isExternalName (gre_name gre)++{-+*********************************************************+*                                                       *+\subsection{Unused imports}+*                                                       *+*********************************************************++This code finds which import declarations are unused.  The+specification and implementation notes are here:+  http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/UnusedImports+-}++type ImportDeclUsage+   = ( LImportDecl Name   -- The import declaration+     , [AvailInfo]        -- What *is* used (normalised)+     , [Name] )           -- What is imported but *not* used++warnUnusedImportDecls :: TcGblEnv -> RnM ()+warnUnusedImportDecls gbl_env+  = do { uses <- readMutVar (tcg_used_gres gbl_env)+       ; let user_imports = filterOut (ideclImplicit . unLoc) (tcg_rn_imports gbl_env)+                            -- This whole function deals only with *user* imports+                            -- both for warning about unnecessary ones, and for+                            -- deciding the minimal ones+             rdr_env = tcg_rdr_env gbl_env+             fld_env = mkFieldEnv rdr_env++       ; let usage :: [ImportDeclUsage]+             usage = findImportUsage user_imports uses++       ; traceRn "warnUnusedImportDecls" $+                       (vcat [ text "Uses:" <+> ppr uses+                       , text "Import usage" <+> ppr usage])+       ; whenWOptM Opt_WarnUnusedImports $+         mapM_ (warnUnusedImport Opt_WarnUnusedImports fld_env) usage++       ; whenGOptM Opt_D_dump_minimal_imports $+         printMinimalImports usage }++-- | Warn the user about top level binders that lack type signatures.+-- Called /after/ type inference, so that we can report the+-- inferred type of the function+warnMissingSignatures :: TcGblEnv -> RnM ()+warnMissingSignatures gbl_env+  = do { let exports = availsToNameSet (tcg_exports gbl_env)+             sig_ns  = tcg_sigs gbl_env+               -- We use sig_ns to exclude top-level bindings that are generated by GHC+             binds    = collectHsBindsBinders $ tcg_binds gbl_env+             pat_syns = tcg_patsyns gbl_env++         -- Warn about missing signatures+         -- Do this only when we we have a type to offer+       ; warn_missing_sigs  <- woptM Opt_WarnMissingSignatures+       ; warn_only_exported <- woptM Opt_WarnMissingExportedSignatures+       ; warn_pat_syns      <- woptM Opt_WarnMissingPatternSynonymSignatures++       ; let add_sig_warns+               | warn_only_exported = add_warns Opt_WarnMissingExportedSignatures+               | warn_missing_sigs  = add_warns Opt_WarnMissingSignatures+               | warn_pat_syns      = add_warns Opt_WarnMissingPatternSynonymSignatures+               | otherwise          = return ()++             add_warns flag+                = when warn_pat_syns+                       (mapM_ add_pat_syn_warn pat_syns) >>+                  when (warn_missing_sigs || warn_only_exported)+                       (mapM_ add_bind_warn binds)+                where+                  add_pat_syn_warn p+                    = add_warn name $+                      hang (text "Pattern synonym with no type signature:")+                         2 (text "pattern" <+> pprPrefixName name <+> dcolon <+> pp_ty)+                    where+                      name  = patSynName p+                      pp_ty = pprPatSynType p++                  add_bind_warn id+                    = do { env <- tcInitTidyEnv     -- Why not use emptyTidyEnv?+                         ; let name    = idName id+                               (_, ty) = tidyOpenType env (idType id)+                               ty_msg  = pprSigmaType ty+                         ; add_warn name $+                           hang (text "Top-level binding with no type signature:")+                              2 (pprPrefixName name <+> dcolon <+> ty_msg) }++                  add_warn name msg+                    = when (name `elemNameSet` sig_ns && export_check name)+                           (addWarnAt (Reason flag) (getSrcSpan name) msg)++                  export_check name+                    = not warn_only_exported || name `elemNameSet` exports++       ; add_sig_warns }++{-+Note [The ImportMap]+~~~~~~~~~~~~~~~~~~~~+The ImportMap is a short-lived intermediate data struture records, for+each import declaration, what stuff brought into scope by that+declaration is actually used in the module.++The SrcLoc is the location of the END of a particular 'import'+declaration.  Why *END*?  Because we don't want to get confused+by the implicit Prelude import. Consider (Trac #7476) the module+    import Foo( foo )+    main = print foo+There is an implicit 'import Prelude(print)', and it gets a SrcSpan+of line 1:1 (just the point, not a span). If we use the *START* of+the SrcSpan to identify the import decl, we'll confuse the implicit+import Prelude with the explicit 'import Foo'.  So we use the END.+It's just a cheap hack; we could equally well use the Span too.++The AvailInfos are the things imported from that decl (just a list,+not normalised).+-}++type ImportMap = Map SrcLoc [AvailInfo]  -- See [The ImportMap]++findImportUsage :: [LImportDecl Name]+                -> [GlobalRdrElt]+                -> [ImportDeclUsage]++findImportUsage imports used_gres+  = map unused_decl imports+  where+    import_usage :: ImportMap+    import_usage+      = foldr extendImportMap Map.empty used_gres++    unused_decl decl@(L loc (ImportDecl { ideclHiding = imps }))+      = (decl, nubAvails used_avails, nameSetElemsStable unused_imps)+      where+        used_avails = Map.lookup (srcSpanEnd loc) import_usage `orElse` []+                      -- srcSpanEnd: see Note [The ImportMap]+        used_names   = availsToNameSetWithSelectors used_avails+        used_parents = mkNameSet [n | AvailTC n _ _ <- used_avails]++        unused_imps   -- Not trivial; see eg Trac #7454+          = case imps of+              Just (False, L _ imp_ies) ->+                                 foldr (add_unused . unLoc) emptyNameSet imp_ies+              _other -> emptyNameSet -- No explicit import list => no unused-name list++        add_unused :: IE Name -> NameSet -> NameSet+        add_unused (IEVar (L _ n))      acc+                                       = add_unused_name (ieWrappedName n) acc+        add_unused (IEThingAbs (L _ n)) acc+                                       = add_unused_name (ieWrappedName n) acc+        add_unused (IEThingAll (L _ n)) acc+                                       = add_unused_all  (ieWrappedName n) acc+        add_unused (IEThingWith (L _ p) wc ns fs) acc =+          add_wc_all (add_unused_with (ieWrappedName p) xs acc)+          where xs = map (ieWrappedName . unLoc) ns+                          ++ map (flSelector . unLoc) fs+                add_wc_all = case wc of+                            NoIEWildcard -> id+                            IEWildcard _ -> add_unused_all (ieWrappedName p)+        add_unused _ acc = acc++        add_unused_name n acc+          | n `elemNameSet` used_names = acc+          | otherwise                  = acc `extendNameSet` n+        add_unused_all n acc+          | n `elemNameSet` used_names   = acc+          | n `elemNameSet` used_parents = acc+          | otherwise                    = acc `extendNameSet` n+        add_unused_with p ns acc+          | all (`elemNameSet` acc1) ns = add_unused_name p acc1+          | otherwise = acc1+          where+            acc1 = foldr add_unused_name acc ns+       -- If you use 'signum' from Num, then the user may well have+       -- imported Num(signum).  We don't want to complain that+       -- Num is not itself mentioned.  Hence the two cases in add_unused_with.++extendImportMap :: GlobalRdrElt -> ImportMap -> ImportMap+-- For each of a list of used GREs, find all the import decls that brought+-- it into scope; choose one of them (bestImport), and record+-- the RdrName in that import decl's entry in the ImportMap+extendImportMap gre imp_map+   = add_imp gre (bestImport (gre_imp gre)) imp_map+  where+    add_imp :: GlobalRdrElt -> ImportSpec -> ImportMap -> ImportMap+    add_imp gre (ImpSpec { is_decl = imp_decl_spec }) imp_map+      = Map.insertWith add decl_loc [avail] imp_map+      where+        add _ avails = avail : avails -- add is really just a specialised (++)+        decl_loc = srcSpanEnd (is_dloc imp_decl_spec)+                   -- For srcSpanEnd see Note [The ImportMap]+        avail    = availFromGRE gre++warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Name)+                 -> ImportDeclUsage -> RnM ()+warnUnusedImport flag fld_env (L loc decl, used, unused)+  | Just (False,L _ []) <- ideclHiding decl+                = return ()            -- Do not warn for 'import M()'++  | Just (True, L _ hides) <- ideclHiding decl+  , not (null hides)+  , pRELUDE_NAME == unLoc (ideclName decl)+                = return ()            -- Note [Do not warn about Prelude hiding]+  | null used   = addWarnAt (Reason flag) loc msg1 -- Nothing used; drop entire decl+  | null unused = return ()            -- Everything imported is used; nop+  | otherwise   = addWarnAt (Reason flag) loc msg2 -- Some imports are unused+  where+    msg1 = vcat [pp_herald <+> quotes pp_mod <+> pp_not_used,+                 nest 2 (text "except perhaps to import instances from"+                                   <+> quotes pp_mod),+                 text "To import instances alone, use:"+                                   <+> text "import" <+> pp_mod <> parens Outputable.empty ]+    msg2 = sep [pp_herald <+> quotes sort_unused,+                    text "from module" <+> quotes pp_mod <+> pp_not_used]+    pp_herald  = text "The" <+> pp_qual <+> text "import of"+    pp_qual+      | ideclQualified decl = text "qualified"+      | otherwise           = Outputable.empty+    pp_mod      = ppr (unLoc (ideclName decl))+    pp_not_used = text "is redundant"++    ppr_possible_field n = case lookupNameEnv fld_env n of+                               Just (fld, p) -> ppr p <> parens (ppr fld)+                               Nothing  -> ppr n++    -- Print unused names in a deterministic (lexicographic) order+    sort_unused = pprWithCommas ppr_possible_field $+                    sortBy (comparing nameOccName) unused++{-+Note [Do not warn about Prelude hiding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do not warn about+   import Prelude hiding( x, y )+because even if nothing else from Prelude is used, it may be essential to hide+x,y to avoid name-shadowing warnings.  Example (Trac #9061)+   import Prelude hiding( log )+   f x = log where log = ()++++Note [Printing minimal imports]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To print the minimal imports we walk over the user-supplied import+decls, and simply trim their import lists.  NB that++  * We do *not* change the 'qualified' or 'as' parts!++  * We do not disard a decl altogether; we might need instances+    from it.  Instead we just trim to an empty import list+-}++printMinimalImports :: [ImportDeclUsage] -> RnM ()+-- See Note [Printing minimal imports]+printMinimalImports imports_w_usage+  = do { imports' <- mapM mk_minimal imports_w_usage+       ; this_mod <- getModule+       ; dflags   <- getDynFlags+       ; liftIO $+         do { h <- openFile (mkFilename dflags this_mod) WriteMode+            ; printForUser dflags h neverQualify (vcat (map ppr imports')) }+              -- The neverQualify is important.  We are printing Names+              -- but they are in the context of an 'import' decl, and+              -- we never qualify things inside there+              -- E.g.   import Blag( f, b )+              -- not    import Blag( Blag.f, Blag.g )!+       }+  where+    mkFilename dflags this_mod+      | Just d <- dumpDir dflags = d </> basefn+      | otherwise                = basefn+      where+        basefn = moduleNameString (moduleName this_mod) ++ ".imports"++    mk_minimal (L l decl, used, unused)+      | null unused+      , Just (False, _) <- ideclHiding decl+      = return (L l decl)+      | otherwise+      = do { let ImportDecl { ideclName    = L _ mod_name+                            , ideclSource  = is_boot+                            , ideclPkgQual = mb_pkg } = decl+           ; iface <- loadSrcInterface doc mod_name is_boot (fmap sl_fs mb_pkg)+           ; let lies = map (L l) (concatMap (to_ie iface) used)+           ; return (L l (decl { ideclHiding = Just (False, L l lies) })) }+      where+        doc = text "Compute minimal imports for" <+> ppr decl++    to_ie :: ModIface -> AvailInfo -> [IE Name]+    -- The main trick here is that if we're importing all the constructors+    -- we want to say "T(..)", but if we're importing only a subset we want+    -- to say "T(A,B,C)".  So we have to find out what the module exports.+    to_ie _ (Avail n)+       = [IEVar (to_ie_post_rn $ noLoc n)]+    to_ie _ (AvailTC n [m] [])+       | n==m = [IEThingAbs (to_ie_post_rn $ noLoc n)]+    to_ie iface (AvailTC n ns fs)+      = case [(xs,gs) |  AvailTC x xs gs <- mi_exports iface+                 , x == n+                 , x `elem` xs    -- Note [Partial export]+                 ] of+           [xs] | all_used xs -> [IEThingAll (to_ie_post_rn $ noLoc n)]+                | otherwise   ->+                   [IEThingWith (to_ie_post_rn $ noLoc n) NoIEWildcard+                                (map (to_ie_post_rn . noLoc) (filter (/= n) ns))+                                (map noLoc fs)]+                                          -- Note [Overloaded field import]+           _other | all_non_overloaded fs+                              -> map (IEVar . to_ie_post_rn_var . noLoc) $ ns+                                 ++ map flSelector fs+                  | otherwise ->+                      [IEThingWith (to_ie_post_rn $ noLoc n) NoIEWildcard+                                (map (to_ie_post_rn . noLoc) (filter (/= n) ns))+                                (map noLoc fs)]+        where++          fld_lbls = map flLabel fs++          all_used (avail_occs, avail_flds)+              = all (`elem` ns) avail_occs+                    && all (`elem` fld_lbls) (map flLabel avail_flds)++          all_non_overloaded = all (not . flIsOverloaded)++to_ie_post_rn_var :: (HasOccName name) => Located name -> LIEWrappedName name+to_ie_post_rn_var (L l n)+  | isDataOcc $ occName n = L l (IEPattern (L l n))+  | otherwise             = L l (IEName    (L l n))+++to_ie_post_rn :: (HasOccName name) => Located name -> LIEWrappedName name+to_ie_post_rn (L l n)+  | isTcOcc occ && isSymOcc occ = L l (IEType (L l n))+  | otherwise                   = L l (IEName (L l n))+  where occ = occName n++{-+Note [Partial export]+~~~~~~~~~~~~~~~~~~~~~+Suppose we have++   module A( op ) where+     class C a where+       op :: a -> a++   module B where+   import A+   f = ..op...++Then the minimal import for module B is+   import A( op )+not+   import A( C( op ) )+which we would usually generate if C was exported from B.  Hence+the (x `elem` xs) test when deciding what to generate.+++Note [Overloaded field import]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+On the other hand, if we have++    {-# LANGUAGE DuplicateRecordFields #-}+    module A where+      data T = MkT { foo :: Int }++    module B where+      import A+      f = ...foo...++then the minimal import for module B must be+    import A ( T(foo) )+because when DuplicateRecordFields is enabled, field selectors are+not in scope without their enclosing datatype.+++************************************************************************+*                                                                      *+\subsection{Errors}+*                                                                      *+************************************************************************+-}++qualImportItemErr :: RdrName -> SDoc+qualImportItemErr rdr+  = hang (text "Illegal qualified name in import item:")+       2 (ppr rdr)++badImportItemErrStd :: ModIface -> ImpDeclSpec -> IE RdrName -> SDoc+badImportItemErrStd iface decl_spec ie+  = sep [text "Module", quotes (ppr (is_mod decl_spec)), source_import,+         text "does not export", quotes (ppr ie)]+  where+    source_import | mi_boot iface = text "(hi-boot interface)"+                  | otherwise     = Outputable.empty++badImportItemErrDataCon :: OccName -> ModIface -> ImpDeclSpec -> IE RdrName -> SDoc+badImportItemErrDataCon dataType_occ iface decl_spec ie+  = vcat [ text "In module"+             <+> quotes (ppr (is_mod decl_spec))+             <+> source_import <> colon+         , nest 2 $ quotes datacon+             <+> text "is a data constructor of"+             <+> quotes dataType+         , text "To import it use"+         , nest 2 $ text "import"+             <+> ppr (is_mod decl_spec)+             <> parens_sp (dataType <> parens_sp datacon)+         , text "or"+         , nest 2 $ text "import"+             <+> ppr (is_mod decl_spec)+             <> parens_sp (dataType <> text "(..)")+         ]+  where+    datacon_occ = rdrNameOcc $ ieName ie+    datacon = parenSymOcc datacon_occ (ppr datacon_occ)+    dataType = parenSymOcc dataType_occ (ppr dataType_occ)+    source_import | mi_boot iface = text "(hi-boot interface)"+                  | otherwise     = Outputable.empty+    parens_sp d = parens (space <> d <> space)  -- T( f,g )++badImportItemErr :: ModIface -> ImpDeclSpec -> IE RdrName -> [AvailInfo] -> SDoc+badImportItemErr iface decl_spec ie avails+  = case find checkIfDataCon avails of+      Just con -> badImportItemErrDataCon (availOccName con) iface decl_spec ie+      Nothing  -> badImportItemErrStd iface decl_spec ie+  where+    checkIfDataCon (AvailTC _ ns _) =+      case find (\n -> importedFS == nameOccNameFS n) ns of+        Just n  -> isDataConName n+        Nothing -> False+    checkIfDataCon _ = False+    availOccName = nameOccName . availName+    nameOccNameFS = occNameFS . nameOccName+    importedFS = occNameFS . rdrNameOcc $ ieName ie++illegalImportItemErr :: SDoc+illegalImportItemErr = text "Illegal import item"++dodgyImportWarn :: RdrName -> SDoc+dodgyImportWarn item = dodgyMsg (text "import") item++dodgyMsg :: (OutputableBndr n, HasOccName n) => SDoc -> n -> SDoc+dodgyMsg kind tc+  = sep [ text "The" <+> kind <+> ptext (sLit "item")+                     <+> quotes (ppr (IEThingAll (noLoc (IEName $ noLoc tc))))+                <+> text "suggests that",+          quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,",+          text "but it has none" ]+++addDupDeclErr :: [GlobalRdrElt] -> TcRn ()+addDupDeclErr [] = panic "addDupDeclErr: empty list"+addDupDeclErr gres@(gre : _)+  = addErrAt (getSrcSpan (last sorted_names)) $+    -- Report the error at the later location+    vcat [text "Multiple declarations of" <+>+             quotes (ppr (nameOccName name)),+             -- NB. print the OccName, not the Name, because the+             -- latter might not be in scope in the RdrEnv and so will+             -- be printed qualified.+          text "Declared at:" <+>+                   vcat (map (ppr . nameSrcLoc) sorted_names)]+  where+    name = gre_name gre+    sorted_names = sortWith nameSrcLoc (map gre_name gres)++++missingImportListWarn :: ModuleName -> SDoc+missingImportListWarn mod+  = text "The module" <+> quotes (ppr mod) <+> ptext (sLit "does not have an explicit import list")++missingImportListItem :: IE RdrName -> SDoc+missingImportListItem ie+  = text "The import item" <+> quotes (ppr ie) <+> ptext (sLit "does not have an explicit import list")++moduleWarn :: ModuleName -> WarningTxt -> SDoc+moduleWarn mod (WarningTxt _ txt)+  = sep [ text "Module" <+> quotes (ppr mod) <> ptext (sLit ":"),+          nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ]+moduleWarn mod (DeprecatedTxt _ txt)+  = sep [ text "Module" <+> quotes (ppr mod)+                                <+> text "is deprecated:",+          nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ]++packageImportErr :: SDoc+packageImportErr+  = text "Package-qualified imports are not enabled; use PackageImports"++-- This data decl will parse OK+--      data T = a Int+-- treating "a" as the constructor.+-- It is really hard to make the parser spot this malformation.+-- So the renamer has to check that the constructor is legal+--+-- We can get an operator as the constructor, even in the prefix form:+--      data T = :% Int Int+-- from interface files, which always print in prefix form++checkConName :: RdrName -> TcRn ()+checkConName name = checkErr (isRdrDataCon name) (badDataCon name)++badDataCon :: RdrName -> SDoc+badDataCon name+   = hsep [text "Illegal data constructor name", quotes (ppr name)]
+ rename/RnPat.hs view
@@ -0,0 +1,861 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[RnPat]{Renaming of patterns}++Basically dependency analysis.++Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes.  In+general, all of these functions return a renamed thing, and a set of+free variables.+-}++{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}++module RnPat (-- main entry points+              rnPat, rnPats, rnBindPat, rnPatAndThen,++              NameMaker, applyNameMaker,     -- a utility for making names:+              localRecNameMaker, topRecNameMaker,  --   sometimes we want to make local names,+                                             --   sometimes we want to make top (qualified) names.+              isTopRecNameMaker,++              rnHsRecFields, HsRecFieldContext(..),+              rnHsRecUpdFields,++              -- CpsRn monad+              CpsRn, liftCps,++              -- Literals+              rnLit, rnOverLit,++             -- Pattern Error messages that are also used elsewhere+             checkTupSize, patSigErr+             ) where++-- ENH: thin imports to only what is necessary for patterns++import {-# SOURCE #-} RnExpr ( rnLExpr )+import {-# SOURCE #-} RnSplice ( rnSplicePat )++#include "HsVersions.h"++import HsSyn+import TcRnMonad+import TcHsSyn             ( hsOverLitName )+import RnEnv+import RnTypes+import PrelNames+import TyCon               ( tyConName )+import ConLike+import Type                ( TyThing(..) )+import Name+import NameSet+import RdrName+import BasicTypes+import Util+import ListSetOps          ( removeDups )+import Outputable+import SrcLoc+import Literal             ( inCharRange )+import TysWiredIn          ( nilDataCon )+import DataCon+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad       ( when, liftM, ap, unless )+import Data.Ratio++{-+*********************************************************+*                                                      *+        The CpsRn Monad+*                                                      *+*********************************************************++Note [CpsRn monad]+~~~~~~~~~~~~~~~~~~+The CpsRn monad uses continuation-passing style to support this+style of programming:++        do { ...+           ; ns <- bindNames rs+           ; ...blah... }++   where rs::[RdrName], ns::[Name]++The idea is that '...blah...'+  a) sees the bindings of ns+  b) returns the free variables it mentions+     so that bindNames can report unused ones++In particular,+    mapM rnPatAndThen [p1, p2, p3]+has a *left-to-right* scoping: it makes the binders in+p1 scope over p2,p3.+-}++newtype CpsRn b = CpsRn { unCpsRn :: forall r. (b -> RnM (r, FreeVars))+                                            -> RnM (r, FreeVars) }+        -- See Note [CpsRn monad]++instance Functor CpsRn where+    fmap = liftM++instance Applicative CpsRn where+    pure x = CpsRn (\k -> k x)+    (<*>) = ap++instance Monad CpsRn where+  (CpsRn m) >>= mk = CpsRn (\k -> m (\v -> unCpsRn (mk v) k))++runCps :: CpsRn a -> RnM (a, FreeVars)+runCps (CpsRn m) = m (\r -> return (r, emptyFVs))++liftCps :: RnM a -> CpsRn a+liftCps rn_thing = CpsRn (\k -> rn_thing >>= k)++liftCpsFV :: RnM (a, FreeVars) -> CpsRn a+liftCpsFV rn_thing = CpsRn (\k -> do { (v,fvs1) <- rn_thing+                                     ; (r,fvs2) <- k v+                                     ; return (r, fvs1 `plusFV` fvs2) })++wrapSrcSpanCps :: (a -> CpsRn b) -> Located a -> CpsRn (Located b)+-- Set the location, and also wrap it around the value returned+wrapSrcSpanCps fn (L loc a)+  = CpsRn (\k -> setSrcSpan loc $+                 unCpsRn (fn a) $ \v ->+                 k (L loc v))++lookupConCps :: Located RdrName -> CpsRn (Located Name)+lookupConCps con_rdr+  = CpsRn (\k -> do { con_name <- lookupLocatedOccRn con_rdr+                    ; (r, fvs) <- k con_name+                    ; return (r, addOneFV fvs (unLoc con_name)) })+    -- We add the constructor name to the free vars+    -- See Note [Patterns are uses]++{-+Note [Patterns are uses]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  module Foo( f, g ) where+  data T = T1 | T2++  f T1 = True+  f T2 = False++  g _ = T1++Arguably we should report T2 as unused, even though it appears in a+pattern, because it never occurs in a constructed position.  See+Trac #7336.+However, implementing this in the face of pattern synonyms would be+less straightforward, since given two pattern synonyms++  pattern P1 <- P2+  pattern P2 <- ()++we need to observe the dependency between P1 and P2 so that type+checking can be done in the correct order (just like for value+bindings). Dependencies between bindings is analyzed in the renamer,+where we don't know yet whether P2 is a constructor or a pattern+synonym. So for now, we do report conid occurrences in patterns as+uses.++*********************************************************+*                                                      *+        Name makers+*                                                      *+*********************************************************++Externally abstract type of name makers,+which is how you go from a RdrName to a Name+-}++data NameMaker+  = LamMk       -- Lambdas+      Bool      -- True <=> report unused bindings+                --   (even if True, the warning only comes out+                --    if -Wunused-matches is on)++  | LetMk       -- Let bindings, incl top level+                -- Do *not* check for unused bindings+      TopLevelFlag+      MiniFixityEnv++topRecNameMaker :: MiniFixityEnv -> NameMaker+topRecNameMaker fix_env = LetMk TopLevel fix_env++isTopRecNameMaker :: NameMaker -> Bool+isTopRecNameMaker (LetMk TopLevel _) = True+isTopRecNameMaker _ = False++localRecNameMaker :: MiniFixityEnv -> NameMaker+localRecNameMaker fix_env = LetMk NotTopLevel fix_env++matchNameMaker :: HsMatchContext a -> NameMaker+matchNameMaker ctxt = LamMk report_unused+  where+    -- Do not report unused names in interactive contexts+    -- i.e. when you type 'x <- e' at the GHCi prompt+    report_unused = case ctxt of+                      StmtCtxt GhciStmtCtxt -> False+                      -- also, don't warn in pattern quotes, as there+                      -- is no RHS where the variables can be used!+                      ThPatQuote            -> False+                      _                     -> True++rnHsSigCps :: LHsSigWcType RdrName -> CpsRn (LHsSigWcType Name)+rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped PatCtx sig)++newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name)+newPatLName name_maker rdr_name@(L loc _)+  = do { name <- newPatName name_maker rdr_name+       ; return (L loc name) }++newPatName :: NameMaker -> Located RdrName -> CpsRn Name+newPatName (LamMk report_unused) rdr_name+  = CpsRn (\ thing_inside ->+        do { name <- newLocalBndrRn rdr_name+           ; (res, fvs) <- bindLocalNames [name] (thing_inside name)+           ; when report_unused $ warnUnusedMatches [name] fvs+           ; return (res, name `delFV` fvs) })++newPatName (LetMk is_top fix_env) rdr_name+  = CpsRn (\ thing_inside ->+        do { name <- case is_top of+                       NotTopLevel -> newLocalBndrRn rdr_name+                       TopLevel    -> newTopSrcBinder rdr_name+           ; bindLocalNames [name] $       -- Do *not* use bindLocalNameFV here+                                        -- See Note [View pattern usage]+             addLocalFixities fix_env [name] $+             thing_inside name })++    -- Note: the bindLocalNames is somewhat suspicious+    --       because it binds a top-level name as a local name.+    --       however, this binding seems to work, and it only exists for+    --       the duration of the patterns and the continuation;+    --       then the top-level name is added to the global env+    --       before going on to the RHSes (see RnSource.hs).++{-+Note [View pattern usage]+~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  let (r, (r -> x)) = x in ...+Here the pattern binds 'r', and then uses it *only* in the view pattern.+We want to "see" this use, and in let-bindings we collect all uses and+report unused variables at the binding level. So we must use bindLocalNames+here, *not* bindLocalNameFV.  Trac #3943.+++Note [Don't report shadowing for pattern synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There is one special context where a pattern doesn't introduce any new binders -+pattern synonym declarations. Therefore we don't check to see if pattern+variables shadow existing identifiers as they are never bound to anything+and have no scope.++Without this check, there would be quite a cryptic warning that the `x`+in the RHS of the pattern synonym declaration shadowed the top level `x`.++```+x :: ()+x = ()++pattern P x = Just x+```++See #12615 for some more examples.++*********************************************************+*                                                      *+        External entry points+*                                                      *+*********************************************************++There are various entry points to renaming patterns, depending on+ (1) whether the names created should be top-level names or local names+ (2) whether the scope of the names is entirely given in a continuation+     (e.g., in a case or lambda, but not in a let or at the top-level,+      because of the way mutually recursive bindings are handled)+ (3) whether the a type signature in the pattern can bind+        lexically-scoped type variables (for unpacking existential+        type vars in data constructors)+ (4) whether we do duplicate and unused variable checking+ (5) whether there are fixity declarations associated with the names+     bound by the patterns that need to be brought into scope with them.++ Rather than burdening the clients of this module with all of these choices,+ we export the three points in this design space that we actually need:+-}++-- ----------- Entry point 1: rnPats -------------------+-- Binds local names; the scope of the bindings is entirely in the thing_inside+--   * allows type sigs to bind type vars+--   * local namemaker+--   * unused and duplicate checking+--   * no fixities+rnPats :: HsMatchContext Name -- for error messages+       -> [LPat RdrName]+       -> ([LPat Name] -> RnM (a, FreeVars))+       -> RnM (a, FreeVars)+rnPats ctxt pats thing_inside+  = do  { envs_before <- getRdrEnvs++          -- (1) rename the patterns, bringing into scope all of the term variables+          -- (2) then do the thing inside.+        ; unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do+        { -- Check for duplicated and shadowed names+          -- Must do this *after* renaming the patterns+          -- See Note [Collect binders only after renaming] in HsUtils+          -- Because we don't bind the vars all at once, we can't+          --    check incrementally for duplicates;+          -- Nor can we check incrementally for shadowing, else we'll+          --    complain *twice* about duplicates e.g. f (x,x) = ...+          --+          -- See note [Don't report shadowing for pattern synonyms]+        ; unless (isPatSynCtxt ctxt)+              (addErrCtxt doc_pat $+                checkDupAndShadowedNames envs_before $+                collectPatsBinders pats')+        ; thing_inside pats' } }+  where+    doc_pat = text "In" <+> pprMatchContext ctxt++rnPat :: HsMatchContext Name -- for error messages+      -> LPat RdrName+      -> (LPat Name -> RnM (a, FreeVars))+      -> RnM (a, FreeVars)     -- Variables bound by pattern do not+                               -- appear in the result FreeVars+rnPat ctxt pat thing_inside+  = rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat')++applyNameMaker :: NameMaker -> Located RdrName -> RnM (Located Name)+applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatLName mk rdr)+                           ; return n }++-- ----------- Entry point 2: rnBindPat -------------------+-- Binds local names; in a recursive scope that involves other bound vars+--      e.g let { (x, Just y) = e1; ... } in ...+--   * does NOT allows type sig to bind type vars+--   * local namemaker+--   * no unused and duplicate checking+--   * fixities might be coming in+rnBindPat :: NameMaker+          -> LPat RdrName+          -> RnM (LPat Name, FreeVars)+   -- Returned FreeVars are the free variables of the pattern,+   -- of course excluding variables bound by this pattern++rnBindPat name_maker pat = runCps (rnLPatAndThen name_maker pat)++{-+*********************************************************+*                                                      *+        The main event+*                                                      *+*********************************************************+-}++-- ----------- Entry point 3: rnLPatAndThen -------------------+-- General version: parametrized by how you make new names++rnLPatsAndThen :: NameMaker -> [LPat RdrName] -> CpsRn [LPat Name]+rnLPatsAndThen mk = mapM (rnLPatAndThen mk)+  -- Despite the map, the monad ensures that each pattern binds+  -- variables that may be mentioned in subsequent patterns in the list++--------------------+-- The workhorse+rnLPatAndThen :: NameMaker -> LPat RdrName -> CpsRn (LPat Name)+rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat++rnPatAndThen :: NameMaker -> Pat RdrName -> CpsRn (Pat Name)+rnPatAndThen _  (WildPat _)   = return (WildPat placeHolderType)+rnPatAndThen mk (ParPat pat)  = do { pat' <- rnLPatAndThen mk pat; return (ParPat pat') }+rnPatAndThen mk (LazyPat pat) = do { pat' <- rnLPatAndThen mk pat; return (LazyPat pat') }+rnPatAndThen mk (BangPat pat) = do { pat' <- rnLPatAndThen mk pat; return (BangPat pat') }+rnPatAndThen mk (VarPat (L l rdr)) = do { loc <- liftCps getSrcSpanM+                                        ; name <- newPatName mk (L loc rdr)+                                        ; return (VarPat (L l name)) }+     -- we need to bind pattern variables for view pattern expressions+     -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)++rnPatAndThen mk (SigPatIn pat sig)+  -- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is+  -- important to rename its type signature _before_ renaming the rest of the+  -- pattern, so that type variables are first bound by the _outermost_ pattern+  -- type signature they occur in. This keeps the type checker happy when+  -- pattern type signatures happen to be nested (#7827)+  --+  -- f ((Just (x :: a) :: Maybe a)+  -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~^       `a' is first bound here+  -- ~~~~~~~~~~~~~~~^                   the same `a' then used here+  = do { sig' <- rnHsSigCps sig+       ; pat' <- rnLPatAndThen mk pat+       ; return (SigPatIn pat' sig') }++rnPatAndThen mk (LitPat lit)+  | HsString src s <- lit+  = do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings)+       ; if ovlStr+         then rnPatAndThen mk+                           (mkNPat (noLoc (mkHsIsString src s placeHolderType))+                                      Nothing)+         else normal_lit }+  | otherwise = normal_lit+  where+    normal_lit = do { liftCps (rnLit lit); return (LitPat lit) }++rnPatAndThen _ (NPat (L l lit) mb_neg _eq _)+  = do { lit'    <- liftCpsFV $ rnOverLit lit+       ; mb_neg' <- liftCpsFV $ case mb_neg of+                      Nothing -> return (Nothing, emptyFVs)+                      Just _  -> do { (neg, fvs) <- lookupSyntaxName negateName+                                    ; return (Just neg, fvs) }+       ; eq' <- liftCpsFV $ lookupSyntaxName eqName+       ; return (NPat (L l lit') mb_neg' eq' placeHolderType) }++rnPatAndThen mk (NPlusKPat rdr (L l lit) _ _ _ _)+  = do { new_name <- newPatName mk rdr+       ; lit'  <- liftCpsFV $ rnOverLit lit+       ; minus <- liftCpsFV $ lookupSyntaxName minusName+       ; ge    <- liftCpsFV $ lookupSyntaxName geName+       ; return (NPlusKPat (L (nameSrcSpan new_name) new_name)+                           (L l lit') lit' ge minus placeHolderType) }+                -- The Report says that n+k patterns must be in Integral++rnPatAndThen mk (AsPat rdr pat)+  = do { new_name <- newPatLName mk rdr+       ; pat' <- rnLPatAndThen mk pat+       ; return (AsPat new_name pat') }++rnPatAndThen mk p@(ViewPat expr pat _ty)+  = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns+                      ; checkErr vp_flag (badViewPat p) }+         -- Because of the way we're arranging the recursive calls,+         -- this will be in the right context+       ; expr' <- liftCpsFV $ rnLExpr expr+       ; pat' <- rnLPatAndThen mk pat+       -- Note: at this point the PreTcType in ty can only be a placeHolder+       -- ; return (ViewPat expr' pat' ty) }+       ; return (ViewPat expr' pat' placeHolderType) }++rnPatAndThen mk (ConPatIn con stuff)+   -- rnConPatAndThen takes care of reconstructing the pattern+   -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on.+  = case unLoc con == nameRdrName (dataConName nilDataCon) of+      True    -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists+                    ; if ol_flag then rnPatAndThen mk (ListPat [] placeHolderType Nothing)+                                 else rnConPatAndThen mk con stuff}+      False   -> rnConPatAndThen mk con stuff++rnPatAndThen mk (ListPat pats _ _)+  = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists+       ; pats' <- rnLPatsAndThen mk pats+       ; case opt_OverloadedLists of+          True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName+                     ; return (ListPat pats' placeHolderType+                                       (Just (placeHolderType, to_list_name)))}+          False -> return (ListPat pats' placeHolderType Nothing) }++rnPatAndThen mk (PArrPat pats _)+  = do { pats' <- rnLPatsAndThen mk pats+       ; return (PArrPat pats' placeHolderType) }++rnPatAndThen mk (TuplePat pats boxed _)+  = do { liftCps $ checkTupSize (length pats)+       ; pats' <- rnLPatsAndThen mk pats+       ; return (TuplePat pats' boxed []) }++rnPatAndThen mk (SumPat pat alt arity _)+  = do { pat <- rnLPatAndThen mk pat+       ; return (SumPat pat alt arity PlaceHolder)+       }++-- If a splice has been run already, just rename the result.+rnPatAndThen mk (SplicePat (HsSpliced mfs (HsSplicedPat pat)))+  = SplicePat . HsSpliced mfs . HsSplicedPat <$> rnPatAndThen mk pat++rnPatAndThen mk (SplicePat splice)+  = do { eith <- liftCpsFV $ rnSplicePat splice+       ; case eith of   -- See Note [rnSplicePat] in RnSplice+           Left  not_yet_renamed -> rnPatAndThen mk not_yet_renamed+           Right already_renamed -> return already_renamed }++rnPatAndThen _ pat = pprPanic "rnLPatAndThen" (ppr pat)+++--------------------+rnConPatAndThen :: NameMaker+                -> Located RdrName          -- the constructor+                -> HsConPatDetails RdrName+                -> CpsRn (Pat Name)++rnConPatAndThen mk con (PrefixCon pats)+  = do  { con' <- lookupConCps con+        ; pats' <- rnLPatsAndThen mk pats+        ; return (ConPatIn con' (PrefixCon pats')) }++rnConPatAndThen mk con (InfixCon pat1 pat2)+  = do  { con' <- lookupConCps con+        ; pat1' <- rnLPatAndThen mk pat1+        ; pat2' <- rnLPatAndThen mk pat2+        ; fixity <- liftCps $ lookupFixityRn (unLoc con')+        ; liftCps $ mkConOpPatRn con' fixity pat1' pat2' }++rnConPatAndThen mk con (RecCon rpats)+  = do  { con' <- lookupConCps con+        ; rpats' <- rnHsRecPatsAndThen mk con' rpats+        ; return (ConPatIn con' (RecCon rpats')) }++--------------------+rnHsRecPatsAndThen :: NameMaker+                   -> Located Name      -- Constructor+                   -> HsRecFields RdrName (LPat RdrName)+                   -> CpsRn (HsRecFields Name (LPat Name))+rnHsRecPatsAndThen mk (L _ con) hs_rec_fields@(HsRecFields { rec_dotdot = dd })+  = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat+                                            hs_rec_fields+       ; flds' <- mapM rn_field (flds `zip` [1..])+       ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }+  where+    mkVarPat l n = VarPat (L l n)+    rn_field (L l fld, n') = do { arg' <- rnLPatAndThen (nested_mk dd mk n')+                                                        (hsRecFieldArg fld)+                                ; return (L l (fld { hsRecFieldArg = arg' })) }++        -- Suppress unused-match reporting for fields introduced by ".."+    nested_mk Nothing  mk                    _  = mk+    nested_mk (Just _) mk@(LetMk {})         _  = mk+    nested_mk (Just n) (LamMk report_unused) n' = LamMk (report_unused && (n' <= n))++{-+************************************************************************+*                                                                      *+        Record fields+*                                                                      *+************************************************************************+-}++data HsRecFieldContext+  = HsRecFieldCon Name+  | HsRecFieldPat Name+  | HsRecFieldUpd++rnHsRecFields+    :: forall arg.+       HsRecFieldContext+    -> (SrcSpan -> RdrName -> arg)+         -- When punning, use this to build a new field+    -> HsRecFields RdrName (Located arg)+    -> RnM ([LHsRecField Name (Located arg)], FreeVars)++-- This surprisingly complicated pass+--   a) looks up the field name (possibly using disambiguation)+--   b) fills in puns and dot-dot stuff+-- When we we've finished, we've renamed the LHS, but not the RHS,+-- of each x=e binding+--+-- This is used for record construction and pattern-matching, but not updates.++rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })+  = do { pun_ok      <- xoptM LangExt.RecordPuns+       ; disambig_ok <- xoptM LangExt.DisambiguateRecordFields+       ; parent <- check_disambiguation disambig_ok mb_con+       ; flds1  <- mapM (rn_fld pun_ok parent) flds+       ; mapM_ (addErr . dupFieldErr ctxt) dup_flds+       ; dotdot_flds <- rn_dotdot dotdot mb_con flds1+       ; let all_flds | null dotdot_flds = flds1+                      | otherwise        = flds1 ++ dotdot_flds+       ; return (all_flds, mkFVs (getFieldIds all_flds)) }+  where+    mb_con = case ctxt of+                HsRecFieldCon con | not (isUnboundName con) -> Just con+                HsRecFieldPat con | not (isUnboundName con) -> Just con+                _ {- update or isUnboundName con -}         -> Nothing+           -- The unbound name test is because if the constructor+           -- isn't in scope the constructor lookup will add an error+           -- add an error, but still return an unbound name.+           -- We don't want that to screw up the dot-dot fill-in stuff.++    doc = case mb_con of+            Nothing  -> text "constructor field name"+            Just con -> text "field of constructor" <+> quotes (ppr con)++    rn_fld :: Bool -> Maybe Name -> LHsRecField RdrName (Located arg)+           -> RnM (LHsRecField Name (Located arg))+    rn_fld pun_ok parent (L l (HsRecField { hsRecFieldLbl+                                              = L loc (FieldOcc (L ll lbl) _)+                                          , hsRecFieldArg = arg+                                          , hsRecPun      = pun }))+      = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent doc lbl+           ; arg' <- if pun+                     then do { checkErr pun_ok (badPun (L loc lbl))+                               -- Discard any module qualifier (#11662)+                             ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)+                             ; return (L loc (mk_arg loc arg_rdr)) }+                     else return arg+           ; return (L l (HsRecField { hsRecFieldLbl+                                         = L loc (FieldOcc (L ll lbl) sel)+                                     , hsRecFieldArg = arg'+                                     , hsRecPun      = pun })) }++    rn_dotdot :: Maybe Int      -- See Note [DotDot fields] in HsPat+              -> Maybe Name     -- The constructor (Nothing for an+                                --    out of scope constructor)+              -> [LHsRecField Name (Located arg)] -- Explicit fields+              -> RnM [LHsRecField Name (Located arg)]   -- Filled in .. fields+    rn_dotdot Nothing _mb_con _flds     -- No ".." at all+      = return []+    rn_dotdot (Just {}) Nothing _flds   -- Constructor out of scope+      = return []+    rn_dotdot (Just n) (Just con) flds -- ".." on record construction / pat match+      = ASSERT( n == length flds )+        do { loc <- getSrcSpanM -- Rather approximate+           ; dd_flag <- xoptM LangExt.RecordWildCards+           ; checkErr dd_flag (needFlagDotDot ctxt)+           ; (rdr_env, lcl_env) <- getRdrEnvs+           ; con_fields <- lookupConstructorFields con+           ; when (null con_fields) (addErr (badDotDotCon con))+           ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldLbls flds)++                   -- For constructor uses (but not patterns)+                   -- the arg should be in scope locally;+                   -- i.e. not top level or imported+                   -- Eg.  data R = R { x,y :: Int }+                   --      f x = R { .. }   -- Should expand to R {x=x}, not R{x=x,y=y}+                 arg_in_scope lbl = mkRdrUnqual lbl `elemLocalRdrEnv` lcl_env++                 (dot_dot_fields, dot_dot_gres)+                        = unzip [ (fl, gre)+                                | fl <- con_fields+                                , let lbl = mkVarOccFS (flLabel fl)+                                , not (lbl `elemOccSet` present_flds)+                                , Just gre <- [lookupGRE_FieldLabel rdr_env fl]+                                              -- Check selector is in scope+                                , case ctxt of+                                    HsRecFieldCon {} -> arg_in_scope lbl+                                    _other           -> True ]++           ; addUsedGREs dot_dot_gres+           ; return [ L loc (HsRecField+                        { hsRecFieldLbl = L loc (FieldOcc (L loc arg_rdr) sel)+                        , hsRecFieldArg = L loc (mk_arg loc arg_rdr)+                        , hsRecPun      = False })+                    | fl <- dot_dot_fields+                    , let sel     = flSelector fl+                    , let arg_rdr = mkVarUnqual (flLabel fl) ] }++    check_disambiguation :: Bool -> Maybe Name -> RnM (Maybe Name)+    -- When disambiguation is on, return name of parent tycon.+    check_disambiguation disambig_ok mb_con+      | disambig_ok, Just con <- mb_con+      = do { env <- getGlobalRdrEnv; return (find_tycon env con) }+      | otherwise = return Nothing++    find_tycon :: GlobalRdrEnv -> Name {- DataCon -} -> Maybe Name {- TyCon -}+    -- Return the parent *type constructor* of the data constructor+    -- (that is, the parent of the data constructor),+    -- or 'Nothing' if it is a pattern synonym or not in scope.+    -- That's the parent to use for looking up record fields.+    find_tycon env con_name+      | Just (AConLike (RealDataCon dc)) <- wiredInNameTyThing_maybe con_name+      = Just (tyConName (dataConTyCon dc))+        -- Special case for [], which is built-in syntax+        -- and not in the GlobalRdrEnv (Trac #8448)++      | Just gre <- lookupGRE_Name env con_name+      = case gre_par gre of+          ParentIs p -> Just p+          _          -> Nothing   -- Can happen if the con_name+                                  -- is for a pattern synonym++      | otherwise = Nothing+        -- Data constructor not lexically in scope at all+        -- See Note [Disambiguation and Template Haskell]++    dup_flds :: [[RdrName]]+        -- Each list represents a RdrName that occurred more than once+        -- (the list contains all occurrences)+        -- Each list in dup_fields is non-empty+    (_, dup_flds) = removeDups compare (getFieldLbls flds)+++{- Note [Disambiguation and Template Haskell]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (Trac #12130)+   module Foo where+     import M+     b = $(funny)++   module M(funny) where+     data T = MkT { x :: Int }+     funny :: Q Exp+     funny = [| MkT { x = 3 } |]++When we splice, neither T nor MkT are lexically in scope, so find_tycon will+fail.  But there is no need for disambiguation anyway, so we just return Nothing+-}++rnHsRecUpdFields+    :: [LHsRecUpdField RdrName]+    -> RnM ([LHsRecUpdField Name], FreeVars)+rnHsRecUpdFields flds+  = do { pun_ok        <- xoptM LangExt.RecordPuns+       ; overload_ok   <- xoptM LangExt.DuplicateRecordFields+       ; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok overload_ok) flds+       ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_flds++       -- Check for an empty record update  e {}+       -- NB: don't complain about e { .. }, because rn_dotdot has done that already+       ; when (null flds) $ addErr emptyUpdateErr++       ; return (flds1, plusFVs fvss) }+  where+    doc = text "constructor field name"++    rn_fld :: Bool -> Bool -> LHsRecUpdField RdrName -> RnM (LHsRecUpdField Name, FreeVars)+    rn_fld pun_ok overload_ok (L l (HsRecField { hsRecFieldLbl = L loc f+                                               , hsRecFieldArg = arg+                                               , hsRecPun      = pun }))+      = do { let lbl = rdrNameAmbiguousFieldOcc f+           ; sel <- setSrcSpan loc $+                      -- Defer renaming of overloaded fields to the typechecker+                      -- See Note [Disambiguating record fields] in TcExpr+                      if overload_ok+                          then do { mb <- lookupGlobalOccRn_overloaded overload_ok lbl+                                  ; case mb of+                                      Nothing -> do { addErr (unknownSubordinateErr doc lbl)+                                                    ; return (Right []) }+                                      Just r  -> return r }+                          else fmap Left $ lookupGlobalOccRn lbl+           ; arg' <- if pun+                     then do { checkErr pun_ok (badPun (L loc lbl))+                               -- Discard any module qualifier (#11662)+                             ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)+                             ; return (L loc (HsVar (L loc arg_rdr))) }+                     else return arg+           ; (arg'', fvs) <- rnLExpr arg'++           ; let fvs' = case sel of+                          Left sel_name -> fvs `addOneFV` sel_name+                          Right [FieldOcc _ sel_name] -> fvs `addOneFV` sel_name+                          Right _       -> fvs+                 lbl' = case sel of+                          Left sel_name ->+                                     L loc (Unambiguous (L loc lbl) sel_name)+                          Right [FieldOcc lbl sel_name] ->+                                     L loc (Unambiguous lbl sel_name)+                          Right _ -> L loc (Ambiguous   (L loc lbl) PlaceHolder)++           ; return (L l (HsRecField { hsRecFieldLbl = lbl'+                                     , hsRecFieldArg = arg''+                                     , hsRecPun      = pun }), fvs') }++    dup_flds :: [[RdrName]]+        -- Each list represents a RdrName that occurred more than once+        -- (the list contains all occurrences)+        -- Each list in dup_fields is non-empty+    (_, dup_flds) = removeDups compare (getFieldUpdLbls flds)++++getFieldIds :: [LHsRecField Name arg] -> [Name]+getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds++getFieldLbls :: [LHsRecField id arg] -> [RdrName]+getFieldLbls flds+  = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds++getFieldUpdLbls :: [LHsRecUpdField id] -> [RdrName]+getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds++needFlagDotDot :: HsRecFieldContext -> SDoc+needFlagDotDot ctxt = vcat [text "Illegal `..' in record" <+> pprRFC ctxt,+                            text "Use RecordWildCards to permit this"]++badDotDotCon :: Name -> SDoc+badDotDotCon con+  = vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con)+         , nest 2 (text "The constructor has no labelled fields") ]++emptyUpdateErr :: SDoc+emptyUpdateErr = text "Empty record update"++badPun :: Located RdrName -> SDoc+badPun fld = vcat [text "Illegal use of punning for field" <+> quotes (ppr fld),+                   text "Use NamedFieldPuns to permit this"]++dupFieldErr :: HsRecFieldContext -> [RdrName] -> SDoc+dupFieldErr ctxt dups+  = hsep [text "duplicate field name",+          quotes (ppr (head dups)),+          text "in record", pprRFC ctxt]++pprRFC :: HsRecFieldContext -> SDoc+pprRFC (HsRecFieldCon {}) = text "construction"+pprRFC (HsRecFieldPat {}) = text "pattern"+pprRFC (HsRecFieldUpd {}) = text "update"++{-+************************************************************************+*                                                                      *+\subsubsection{Literals}+*                                                                      *+************************************************************************++When literals occur we have to make sure+that the types and classes they involve+are made available.+-}++rnLit :: HsLit -> RnM ()+rnLit (HsChar _ c) = checkErr (inCharRange c) (bogusCharError c)+rnLit _ = return ()++-- Turn a Fractional-looking literal which happens to be an integer into an+-- Integer-looking literal.+generalizeOverLitVal :: OverLitVal -> OverLitVal+generalizeOverLitVal (HsFractional (FL {fl_text=src,fl_value=val}))+    | denominator val == 1 = HsIntegral (SourceText src) (numerator val)+generalizeOverLitVal lit = lit++rnOverLit :: HsOverLit t -> RnM (HsOverLit Name, FreeVars)+rnOverLit origLit+  = do  { opt_NumDecimals <- xoptM LangExt.NumDecimals+        ; let { lit@(OverLit {ol_val=val})+            | opt_NumDecimals = origLit {ol_val = generalizeOverLitVal (ol_val origLit)}+            | otherwise       = origLit+          }+        ; let std_name = hsOverLitName val+        ; (SyntaxExpr { syn_expr = from_thing_name }, fvs)+            <- lookupSyntaxName std_name+        ; let rebindable = case from_thing_name of+                                HsVar (L _ v) -> v /= std_name+                                _             -> panic "rnOverLit"+        ; return (lit { ol_witness = from_thing_name+                      , ol_rebindable = rebindable+                      , ol_type = placeHolderType }, fvs) }++{-+************************************************************************+*                                                                      *+\subsubsection{Errors}+*                                                                      *+************************************************************************+-}++patSigErr :: Outputable a => a -> SDoc+patSigErr ty+  =  (text "Illegal signature in pattern:" <+> ppr ty)+        $$ nest 4 (text "Use ScopedTypeVariables to permit it")++bogusCharError :: Char -> SDoc+bogusCharError c+  = text "character literal out of range: '\\" <> char c  <> char '\''++badViewPat :: Pat RdrName -> SDoc+badViewPat pat = vcat [text "Illegal view pattern: " <+> ppr pat,+                       text "Use ViewPatterns to enable view patterns"]
+ rename/RnSource.hs view
@@ -0,0 +1,2285 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[RnSource]{Main pass of renamer}+-}++{-# LANGUAGE CPP, ScopedTypeVariables #-}++module RnSource (+        rnSrcDecls, addTcgDUs, findSplice+    ) where++#include "HsVersions.h"++import {-# SOURCE #-} RnExpr( rnLExpr )+import {-# SOURCE #-} RnSplice ( rnSpliceDecl, rnTopSpliceDecls )++import HsSyn+import FieldLabel+import RdrName+import RnTypes+import RnBinds+import RnEnv+import RnNames+import RnHsDoc          ( rnHsDoc, rnMbLHsDoc )+import TcAnnotations    ( annCtxt )+import TcRnMonad++import ForeignCall      ( CCallTarget(..) )+import Module+import HscTypes         ( Warnings(..), plusWarns )+import Class            ( FunDep )+import PrelNames        ( applicativeClassName, pureAName, thenAName+                        , monadClassName, returnMName, thenMName+                        , monadFailClassName, failMName, failMName_preMFP+                        , semigroupClassName, sappendName+                        , monoidClassName, mappendName+                        )+import Name+import NameSet+import NameEnv+import Avail+import Outputable+import Bag+import BasicTypes       ( DerivStrategy, RuleName, pprRuleName )+import FastString+import SrcLoc+import DynFlags+import Util             ( debugIsOn, lengthExceeds, partitionWith )+import HscTypes         ( HscEnv, hsc_dflags )+import ListSetOps       ( findDupsEq, removeDups, equivClasses )+import Digraph          ( SCC, flattenSCC, flattenSCCs+                        , stronglyConnCompFromEdgedVerticesUniq )+import UniqSet+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Control.Arrow ( first )+import Data.List ( sortBy, mapAccumL )+import Data.Maybe ( isJust )+import qualified Data.Set as Set ( difference, fromList, toList, null )++{- | @rnSourceDecl@ "renames" declarations.+It simultaneously performs dependency analysis and precedence parsing.+It also does the following error checks:++* Checks that tyvars are used properly. This includes checking+  for undefined tyvars, and tyvars in contexts that are ambiguous.+  (Some of this checking has now been moved to module @TcMonoType@,+  since we don't have functional dependency information at this point.)++* Checks that all variable occurrences are defined.++* Checks the @(..)@ etc constraints in the export list.++Brings the binders of the group into scope in the appropriate places;+does NOT assume that anything is in scope already+-}+rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)+-- Rename a top-level HsGroup; used for normal source files *and* hs-boot files+rnSrcDecls group@(HsGroup { hs_valds   = val_decls,+                            hs_splcds  = splice_decls,+                            hs_tyclds  = tycl_decls,+                            hs_derivds = deriv_decls,+                            hs_fixds   = fix_decls,+                            hs_warnds  = warn_decls,+                            hs_annds   = ann_decls,+                            hs_fords   = foreign_decls,+                            hs_defds   = default_decls,+                            hs_ruleds  = rule_decls,+                            hs_vects   = vect_decls,+                            hs_docs    = docs })+ = do {+   -- (A) Process the fixity declarations, creating a mapping from+   --     FastStrings to FixItems.+   --     Also checks for duplicates.+   local_fix_env <- makeMiniFixityEnv fix_decls ;++   -- (B) Bring top level binders (and their fixities) into scope,+   --     *except* for the value bindings, which get done in step (D)+   --     with collectHsIdBinders. However *do* include+   --+   --        * Class ops, data constructors, and record fields,+   --          because they do not have value declarations.+   --          Aso step (C) depends on datacons and record fields+   --+   --        * For hs-boot files, include the value signatures+   --          Again, they have no value declarations+   --+   (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ;+++   setEnvs tc_envs $ do {++   failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations++   -- (D1) Bring pattern synonyms into scope.+   --      Need to do this before (D2) because rnTopBindsLHS+   --      looks up those pattern synonyms (Trac #9889)++   extendPatSynEnv val_decls local_fix_env $ \pat_syn_bndrs -> do {++   -- (D2) Rename the left-hand sides of the value bindings.+   --     This depends on everything from (B) being in scope,+   --     and on (C) for resolving record wild cards.+   --     It uses the fixity env from (A) to bind fixities for view patterns.+   new_lhs <- rnTopBindsLHS local_fix_env val_decls ;++   -- Bind the LHSes (and their fixities) in the global rdr environment+   let { id_bndrs = collectHsIdBinders new_lhs } ;  -- Excludes pattern-synonym binders+                                                    -- They are already in scope+   traceRn "rnSrcDecls" (ppr id_bndrs) ;+   tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ;+   traceRn "D2" (ppr (tcg_rdr_env (fst tc_envs)));+   setEnvs tc_envs $ do {++   --  Now everything is in scope, as the remaining renaming assumes.++   -- (E) Rename type and class decls+   --     (note that value LHSes need to be in scope for default methods)+   --+   -- You might think that we could build proper def/use information+   -- for type and class declarations, but they can be involved+   -- in mutual recursion across modules, and we only do the SCC+   -- analysis for them in the type checker.+   -- So we content ourselves with gathering uses only; that+   -- means we'll only report a declaration as unused if it isn't+   -- mentioned at all.  Ah well.+   traceRn "Start rnTyClDecls" (ppr tycl_decls) ;+   (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;++   -- (F) Rename Value declarations right-hand sides+   traceRn "Start rnmono" empty ;+   let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ;+   is_boot <- tcIsHsBootOrSig ;+   (rn_val_decls, bind_dus) <- if is_boot+    -- For an hs-boot, use tc_bndrs (which collects how we're renamed+    -- signatures), since val_bndr_set is empty (there are no x = ...+    -- bindings in an hs-boot.)+    then rnTopBindsBoot tc_bndrs new_lhs+    else rnValBindsRHS (TopSigCtxt val_bndr_set) new_lhs ;+   traceRn "finish rnmono" (ppr rn_val_decls) ;++   -- (G) Rename Fixity and deprecations++   -- Rename fixity declarations and error if we try to+   -- fix something from another module (duplicates were checked in (A))+   let { all_bndrs = tc_bndrs `unionNameSet` val_bndr_set } ;+   rn_fix_decls <- rnSrcFixityDecls all_bndrs fix_decls ;++   -- Rename deprec decls;+   -- check for duplicates and ensure that deprecated things are defined locally+   -- at the moment, we don't keep these around past renaming+   rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ;++   -- (H) Rename Everything else++   (rn_rule_decls,    src_fvs2) <- setXOptM LangExt.ScopedTypeVariables $+                                   rnList rnHsRuleDecls rule_decls ;+                           -- Inside RULES, scoped type variables are on+   (rn_vect_decls,    src_fvs3) <- rnList rnHsVectDecl    vect_decls ;+   (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ;+   (rn_ann_decls,     src_fvs5) <- rnList rnAnnDecl       ann_decls ;+   (rn_default_decls, src_fvs6) <- rnList rnDefaultDecl   default_decls ;+   (rn_deriv_decls,   src_fvs7) <- rnList rnSrcDerivDecl  deriv_decls ;+   (rn_splice_decls,  src_fvs8) <- rnList rnSpliceDecl    splice_decls ;+      -- Haddock docs; no free vars+   rn_docs <- mapM (wrapLocM rnDocDecl) docs ;++   last_tcg_env <- getGblEnv ;+   -- (I) Compute the results and return+   let {rn_group = HsGroup { hs_valds   = rn_val_decls,+                             hs_splcds  = rn_splice_decls,+                             hs_tyclds  = rn_tycl_decls,+                             hs_derivds = rn_deriv_decls,+                             hs_fixds   = rn_fix_decls,+                             hs_warnds  = [], -- warns are returned in the tcg_env+                                             -- (see below) not in the HsGroup+                             hs_fords  = rn_foreign_decls,+                             hs_annds  = rn_ann_decls,+                             hs_defds  = rn_default_decls,+                             hs_ruleds = rn_rule_decls,+                             hs_vects  = rn_vect_decls,+                             hs_docs   = rn_docs } ;++        tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ;+        other_def  = (Just (mkNameSet tcf_bndrs), emptyNameSet) ;+        other_fvs  = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, src_fvs5,+                              src_fvs6, src_fvs7, src_fvs8] ;+                -- It is tiresome to gather the binders from type and class decls++        src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;+                -- Instance decls may have occurrences of things bound in bind_dus+                -- so we must put other_fvs last++        final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus)+                        in -- we return the deprecs in the env, not in the HsGroup above+                        tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };+       } ;+   traceRn "last" (ppr (tcg_rdr_env final_tcg_env)) ;+   traceRn "finish rnSrc" (ppr rn_group) ;+   traceRn "finish Dus" (ppr src_dus ) ;+   return (final_tcg_env, rn_group)+                    }}}}++addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv+-- This function could be defined lower down in the module hierarchy,+-- but there doesn't seem anywhere very logical to put it.+addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }++rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)+rnList f xs = mapFvRn (wrapLocFstM f) xs++{-+*********************************************************+*                                                       *+        HsDoc stuff+*                                                       *+*********************************************************+-}++rnDocDecl :: DocDecl -> RnM DocDecl+rnDocDecl (DocCommentNext doc) = do+  rn_doc <- rnHsDoc doc+  return (DocCommentNext rn_doc)+rnDocDecl (DocCommentPrev doc) = do+  rn_doc <- rnHsDoc doc+  return (DocCommentPrev rn_doc)+rnDocDecl (DocCommentNamed str doc) = do+  rn_doc <- rnHsDoc doc+  return (DocCommentNamed str rn_doc)+rnDocDecl (DocGroup lev doc) = do+  rn_doc <- rnHsDoc doc+  return (DocGroup lev rn_doc)++{-+*********************************************************+*                                                       *+        Source-code fixity declarations+*                                                       *+*********************************************************+-}++rnSrcFixityDecls :: NameSet -> [LFixitySig RdrName] -> RnM [LFixitySig Name]+-- Rename the fixity decls, so we can put+-- the renamed decls in the renamed syntax tree+-- Errors if the thing being fixed is not defined locally.+--+-- The returned FixitySigs are not actually used for anything,+-- except perhaps the GHCi API+rnSrcFixityDecls bndr_set fix_decls+  = do fix_decls <- mapM rn_decl fix_decls+       return (concat fix_decls)+  where+    sig_ctxt = TopSigCtxt bndr_set++    rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name]+        -- GHC extension: look up both the tycon and data con+        -- for con-like things; hence returning a list+        -- If neither are in scope, report an error; otherwise+        -- return a fixity sig for each (slightly odd)+    rn_decl (L loc (FixitySig fnames fixity))+      = do names <- mapM lookup_one fnames+           return [ L loc (FixitySig name fixity)+                  | name <- names ]++    lookup_one :: Located RdrName -> RnM [Located Name]+    lookup_one (L name_loc rdr_name)+      = setSrcSpan name_loc $+                    -- this lookup will fail if the definition isn't local+        do names <- lookupLocalTcNames sig_ctxt what rdr_name+           return [ L name_loc name | (_, name) <- names ]+    what = text "fixity signature"++{-+*********************************************************+*                                                       *+        Source-code deprecations declarations+*                                                       *+*********************************************************++Check that the deprecated names are defined, are defined locally, and+that there are no duplicate deprecations.++It's only imported deprecations, dealt with in RnIfaces, that we+gather them together.+-}++-- checks that the deprecations are defined locally, and that there are no duplicates+rnSrcWarnDecls :: NameSet -> [LWarnDecls RdrName] -> RnM Warnings+rnSrcWarnDecls _ []+  = return NoWarnings++rnSrcWarnDecls bndr_set decls'+  = do { -- check for duplicates+       ; mapM_ (\ dups -> let (L loc rdr:lrdr':_) = dups+                          in addErrAt loc (dupWarnDecl lrdr' rdr))+               warn_rdr_dups+       ; pairs_s <- mapM (addLocM rn_deprec) decls+       ; return (WarnSome ((concat pairs_s))) }+ where+   decls = concatMap (\(L _ d) -> wd_warnings d) decls'++   sig_ctxt = TopSigCtxt bndr_set++   rn_deprec (Warning rdr_names txt)+       -- ensures that the names are defined locally+     = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)+                                rdr_names+          ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] }++   what = text "deprecation"++   warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning ns _)) -> ns)+                                               decls++findDupRdrNames :: [Located RdrName] -> [[Located RdrName]]+findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))++-- look for duplicates among the OccNames;+-- we check that the names are defined above+-- invt: the lists returned by findDupsEq always have at least two elements++dupWarnDecl :: Located RdrName -> RdrName -> SDoc+-- Located RdrName -> DeprecDecl RdrName -> SDoc+dupWarnDecl (L loc _) rdr_name+  = vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name),+          text "also at " <+> ppr loc]++{-+*********************************************************+*                                                      *+\subsection{Annotation declarations}+*                                                      *+*********************************************************+-}++rnAnnDecl :: AnnDecl RdrName -> RnM (AnnDecl Name, FreeVars)+rnAnnDecl ann@(HsAnnotation s provenance expr)+  = addErrCtxt (annCtxt ann) $+    do { (provenance', provenance_fvs) <- rnAnnProvenance provenance+       ; (expr', expr_fvs) <- setStage (Splice Untyped) $+                              rnLExpr expr+       ; return (HsAnnotation s provenance' expr',+                 provenance_fvs `plusFV` expr_fvs) }++rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars)+rnAnnProvenance provenance = do+    provenance' <- traverse lookupTopBndrRn provenance+    return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))++{-+*********************************************************+*                                                      *+\subsection{Default declarations}+*                                                      *+*********************************************************+-}++rnDefaultDecl :: DefaultDecl RdrName -> RnM (DefaultDecl Name, FreeVars)+rnDefaultDecl (DefaultDecl tys)+  = do { (tys', fvs) <- rnLHsTypes doc_str tys+       ; return (DefaultDecl tys', fvs) }+  where+    doc_str = DefaultDeclCtx++{-+*********************************************************+*                                                      *+\subsection{Foreign declarations}+*                                                      *+*********************************************************+-}++rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars)+rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })+  = do { topEnv :: HscEnv <- getTopEnv+       ; name' <- lookupLocatedTopBndrRn name+       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty++        -- Mark any PackageTarget style imports as coming from the current package+       ; let unitId = thisPackage $ hsc_dflags topEnv+             spec'      = patchForeignImport unitId spec++       ; return (ForeignImport { fd_name = name', fd_sig_ty = ty'+                               , fd_co = noForeignImportCoercionYet+                               , fd_fi = spec' }, fvs) }++rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })+  = do { name' <- lookupLocatedOccRn name+       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty+       ; return (ForeignExport { fd_name = name', fd_sig_ty = ty'+                               , fd_co = noForeignExportCoercionYet+                               , fd_fe = spec }+                , fvs `addOneFV` unLoc name') }+        -- NB: a foreign export is an *occurrence site* for name, so+        --     we add it to the free-variable list.  It might, for example,+        --     be imported from another module++-- | For Windows DLLs we need to know what packages imported symbols are from+--      to generate correct calls. Imported symbols are tagged with the current+--      package, so if they get inlined across a package boundry we'll still+--      know where they're from.+--+patchForeignImport :: UnitId -> ForeignImport -> ForeignImport+patchForeignImport unitId (CImport cconv safety fs spec src)+        = CImport cconv safety fs (patchCImportSpec unitId spec) src++patchCImportSpec :: UnitId -> CImportSpec -> CImportSpec+patchCImportSpec unitId spec+ = case spec of+        CFunction callTarget    -> CFunction $ patchCCallTarget unitId callTarget+        _                       -> spec++patchCCallTarget :: UnitId -> CCallTarget -> CCallTarget+patchCCallTarget unitId callTarget =+  case callTarget of+  StaticTarget src label Nothing isFun+                              -> StaticTarget src label (Just unitId) isFun+  _                           -> callTarget++{-+*********************************************************+*                                                      *+\subsection{Instance declarations}+*                                                      *+*********************************************************+-}++rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)+rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })+  = do { (tfi', fvs) <- rnTyFamInstDecl Nothing tfi+       ; return (TyFamInstD { tfid_inst = tfi' }, fvs) }++rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })+  = do { (dfi', fvs) <- rnDataFamInstDecl Nothing dfi+       ; return (DataFamInstD { dfid_inst = dfi' }, fvs) }++rnSrcInstDecl (ClsInstD { cid_inst = cid })+  = do { (cid', fvs) <- rnClsInstDecl cid+       ; return (ClsInstD { cid_inst = cid' }, fvs) }++-- | Warn about non-canonical typeclass instance declarations+--+-- A "non-canonical" instance definition can occur for instances of a+-- class which redundantly defines an operation its superclass+-- provides as well (c.f. `return`/`pure`). In such cases, a canonical+-- instance is one where the subclass inherits its method+-- implementation from its superclass instance (usually the subclass+-- has a default method implementation to that effect). Consequently,+-- a non-canonical instance occurs when this is not the case.+--+-- See also descriptions of 'checkCanonicalMonadInstances' and+-- 'checkCanonicalMonoidInstances'+checkCanonicalInstances :: Name -> LHsSigType Name -> LHsBinds Name -> RnM ()+checkCanonicalInstances cls poly_ty mbinds = do+    whenWOptM Opt_WarnNonCanonicalMonadInstances+        checkCanonicalMonadInstances++    whenWOptM Opt_WarnNonCanonicalMonadFailInstances+        checkCanonicalMonadFailInstances++    whenWOptM Opt_WarnNonCanonicalMonoidInstances+        checkCanonicalMonoidInstances++  where+    -- | Warn about unsound/non-canonical 'Applicative'/'Monad' instance+    -- declarations. Specifically, the following conditions are verified:+    --+    -- In 'Monad' instances declarations:+    --+    --  * If 'return' is overridden it must be canonical (i.e. @return = pure@)+    --  * If '(>>)' is overridden it must be canonical (i.e. @(>>) = (*>)@)+    --+    -- In 'Applicative' instance declarations:+    --+    --  * Warn if 'pure' is defined backwards (i.e. @pure = return@).+    --  * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@).+    --+    checkCanonicalMonadInstances+      | cls == applicativeClassName  = do+          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do+              case mbind of+                  FunBind { fun_id = L _ name, fun_matches = mg }+                      | name == pureAName, isAliasMG mg == Just returnMName+                      -> addWarnNonCanonicalMethod1+                            Opt_WarnNonCanonicalMonadInstances "pure" "return"++                      | name == thenAName, isAliasMG mg == Just thenMName+                      -> addWarnNonCanonicalMethod1+                            Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)"++                  _ -> return ()++      | cls == monadClassName  = do+          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do+              case mbind of+                  FunBind { fun_id = L _ name, fun_matches = mg }+                      | name == returnMName, isAliasMG mg /= Just pureAName+                      -> addWarnNonCanonicalMethod2+                            Opt_WarnNonCanonicalMonadInstances "return" "pure"++                      | name == thenMName, isAliasMG mg /= Just thenAName+                      -> addWarnNonCanonicalMethod2+                            Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)"++                  _ -> return ()++      | otherwise = return ()++    -- | Warn about unsound/non-canonical 'Monad'/'MonadFail' instance+    -- declarations. Specifically, the following conditions are verified:+    --+    -- In 'Monad' instances declarations:+    --+    --  * If 'fail' is overridden it must be canonical+    --    (i.e. @fail = Control.Monad.Fail.fail@)+    --+    -- In 'MonadFail' instance declarations:+    --+    --  * Warn if 'fail' is defined backwards+    --    (i.e. @fail = Control.Monad.fail@).+    --+    checkCanonicalMonadFailInstances+      | cls == monadFailClassName  = do+          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do+              case mbind of+                  FunBind { fun_id = L _ name, fun_matches = mg }+                      | name == failMName, isAliasMG mg == Just failMName_preMFP+                      -> addWarnNonCanonicalMethod1+                            Opt_WarnNonCanonicalMonadFailInstances "fail"+                            "Control.Monad.fail"++                  _ -> return ()++      | cls == monadClassName  = do+          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do+              case mbind of+                  FunBind { fun_id = L _ name, fun_matches = mg }+                      | name == failMName_preMFP, isAliasMG mg /= Just failMName+                      -> addWarnNonCanonicalMethod2+                            Opt_WarnNonCanonicalMonadFailInstances "fail"+                            "Control.Monad.Fail.fail"+                  _ -> return ()++      | otherwise = return ()++    -- | Check whether Monoid(mappend) is defined in terms of+    -- Semigroup((<>)) (and not the other way round). Specifically,+    -- the following conditions are verified:+    --+    -- In 'Monoid' instances declarations:+    --+    --  * If 'mappend' is overridden it must be canonical+    --    (i.e. @mappend = (<>)@)+    --+    -- In 'Semigroup' instance declarations:+    --+    --  * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@).+    --+    checkCanonicalMonoidInstances+      | cls == semigroupClassName  = do+          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do+              case mbind of+                  FunBind { fun_id = L _ name, fun_matches = mg }+                      | name == sappendName, isAliasMG mg == Just mappendName+                      -> addWarnNonCanonicalMethod1+                            Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend"++                  _ -> return ()++      | cls == monoidClassName  = do+          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do+              case mbind of+                  FunBind { fun_id = L _ name, fun_matches = mg }+                      | name == mappendName, isAliasMG mg /= Just sappendName+                      -> addWarnNonCanonicalMethod2NoDefault+                            Opt_WarnNonCanonicalMonoidInstances "mappend" "(<>)"++                  _ -> return ()++      | otherwise = return ()++    -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\"+    -- binding, and return @Just rhsName@ if this is the case+    isAliasMG :: MatchGroup Name (LHsExpr Name) -> Maybe Name+    isAliasMG MG {mg_alts = L _ [L _ (Match { m_pats = [], m_grhss = grhss })]}+        | GRHSs [L _ (GRHS [] body)] lbinds <- grhss+        , L _ EmptyLocalBinds <- lbinds+        , L _ (HsVar (L _ rhsName)) <- body  = Just rhsName+    isAliasMG _ = Nothing++    -- got "lhs = rhs" but expected something different+    addWarnNonCanonicalMethod1 flag lhs rhs = do+        addWarn (Reason flag) $ vcat+                       [ text "Noncanonical" <+>+                         quotes (text (lhs ++ " = " ++ rhs)) <+>+                         text "definition detected"+                       , instDeclCtxt1 poly_ty+                       , text "Move definition from" <+>+                         quotes (text rhs) <+>+                         text "to" <+> quotes (text lhs)+                       ]++    -- expected "lhs = rhs" but got something else+    addWarnNonCanonicalMethod2 flag lhs rhs = do+        addWarn (Reason flag) $ vcat+                       [ text "Noncanonical" <+>+                         quotes (text lhs) <+>+                         text "definition detected"+                       , instDeclCtxt1 poly_ty+                       , text "Either remove definition for" <+>+                         quotes (text lhs) <+> text "or define as" <+>+                         quotes (text (lhs ++ " = " ++ rhs))+                       ]++    -- like above, but method has no default impl+    addWarnNonCanonicalMethod2NoDefault flag lhs rhs = do+        addWarn (Reason flag) $ vcat+                       [ text "Noncanonical" <+>+                         quotes (text lhs) <+>+                         text "definition detected"+                       , instDeclCtxt1 poly_ty+                       , text "Define as" <+>+                         quotes (text (lhs ++ " = " ++ rhs))+                       ]++    -- stolen from TcInstDcls+    instDeclCtxt1 :: LHsSigType Name -> SDoc+    instDeclCtxt1 hs_inst_ty+      = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))++    inst_decl_ctxt :: SDoc -> SDoc+    inst_decl_ctxt doc = hang (text "in the instance declaration for")+                         2 (quotes doc <> text ".")+++rnClsInstDecl :: ClsInstDecl RdrName -> RnM (ClsInstDecl Name, FreeVars)+rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds+                           , cid_sigs = uprags, cid_tyfam_insts = ats+                           , cid_overlap_mode = oflag+                           , cid_datafam_insts = adts })+  = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "an instance declaration") inst_ty+       ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'+       ; let cls = case hsTyGetAppHead_maybe head_ty' of+                     Nothing -> mkUnboundName (mkTcOccFS (fsLit "<class>"))+                     Just (L _ cls, _) -> cls+                     -- rnLHsInstType has added an error message+                     -- if hsTyGetAppHead_maybe fails++          -- Rename the bindings+          -- The typechecker (not the renamer) checks that all+          -- the bindings are for the right class+          -- (Slightly strangely) when scoped type variables are on, the+          -- forall-d tyvars scope over the method bindings too+       ; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags++       ; checkCanonicalInstances cls inst_ty' mbinds'++       -- Rename the associated types, and type signatures+       -- Both need to have the instance type variables in scope+       ; traceRn "rnSrcInstDecl" (ppr inst_ty' $$ ppr ktv_names)+       ; ((ats', adts'), more_fvs)+             <- extendTyVarEnvFVRn ktv_names $+                do { (ats',  at_fvs)  <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats+                   ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts+                   ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) }++       ; let all_fvs = meth_fvs `plusFV` more_fvs+                                `plusFV` inst_fvs+       ; return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = mbinds'+                             , cid_sigs = uprags', cid_tyfam_insts = ats'+                             , cid_overlap_mode = oflag+                             , cid_datafam_insts = adts' },+                 all_fvs) }+             -- We return the renamed associated data type declarations so+             -- that they can be entered into the list of type declarations+             -- for the binding group, but we also keep a copy in the instance.+             -- The latter is needed for well-formedness checks in the type+             -- checker (eg, to ensure that all ATs of the instance actually+             -- receive a declaration).+             -- NB: Even the copies in the instance declaration carry copies of+             --     the instance context after renaming.  This is a bit+             --     strange, but should not matter (and it would be more work+             --     to remove the context).++rnFamInstDecl :: HsDocContext+              -> Maybe (Name, [Name])   -- Nothing => not associated+                                        -- Just (cls,tvs) => associated,+                                        --   and gives class and tyvars of the+                                        --   parent instance delc+              -> Located RdrName+              -> HsTyPats RdrName+              -> rhs+              -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))+              -> RnM (Located Name, HsTyPats Name, rhs', FreeVars)+rnFamInstDecl doc mb_cls tycon (HsIB { hsib_body = pats }) payload rnPayload+  = do { tycon'   <- lookupFamInstName (fmap fst mb_cls) tycon+       ; let loc = case pats of+                     []             -> pprPanic "rnFamInstDecl" (ppr tycon)+                     (L loc _ : []) -> loc+                     (L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps))++       ; pat_kity_vars_with_dups <- extractHsTysRdrTyVarsDups pats+             -- Use the "...Dups" form because it's needed+             -- below to report unsed binder on the LHS+       ; var_names <- mapM (newTyVarNameRn mb_cls . L loc . unLoc) $+                      freeKiTyVarsAllVars $+                      rmDupsInRdrTyVars pat_kity_vars_with_dups++             -- All the free vars of the family patterns+             -- with a sensible binding location+       ; ((pats', payload'), fvs)+              <- bindLocalNamesFV var_names $+                 do { (pats', pat_fvs) <- rnLHsTypes (FamPatCtx tycon) pats+                    ; (payload', rhs_fvs) <- rnPayload doc payload++                       -- Report unused binders on the LHS+                       -- See Note [Unused type variables in family instances]+                    ; let groups :: [[Located RdrName]]+                          groups = equivClasses cmpLocated $+                                   freeKiTyVarsAllVars pat_kity_vars_with_dups+                    ; tv_nms_dups <- mapM (lookupOccRn . unLoc) $+                                     [ tv | (tv:_:_) <- groups ]+                          -- Add to the used variables+                          --  a) any variables that appear *more than once* on the LHS+                          --     e.g.   F a Int a = Bool+                          --  b) for associated instances, the variables+                          --     of the instance decl.  See+                          --     Note [Unused type variables in family instances]+                    ; let tv_nms_used = extendNameSetList rhs_fvs $+                                        inst_tvs ++ tv_nms_dups+                          inst_tvs = case mb_cls of+                                       Nothing            -> []+                                       Just (_, inst_tvs) -> inst_tvs+                    ; warnUnusedTypePatterns var_names tv_nms_used++                         -- See Note [Renaming associated types]+                    ; let bad_tvs = case mb_cls of+                                      Nothing           -> []+                                      Just (_,cls_tkvs) -> filter is_bad cls_tkvs+                          var_name_set = mkNameSet var_names++                          is_bad cls_tkv = cls_tkv `elemNameSet` rhs_fvs+                                        && not (cls_tkv `elemNameSet` var_name_set)+                    ; unless (null bad_tvs) (badAssocRhs bad_tvs)++                    ; return ((pats', payload'), rhs_fvs `plusFV` pat_fvs) }++       ; let anon_wcs = concatMap collectAnonWildCards pats'+             all_ibs  = anon_wcs ++ var_names+                        -- all_ibs: include anonymous wildcards in the implicit+                        -- binders In a type pattern they behave just like any+                        -- other type variable except for being anoymous.  See+                        -- Note [Wildcards in family instances]+             all_fvs  = fvs `addOneFV` unLoc tycon'++       ; return (tycon',+                 HsIB { hsib_body = pats'+                      , hsib_vars = all_ibs+                      , hsib_closed = True },+                 payload',+                 all_fvs) }+             -- type instance => use, hence addOneFV++rnTyFamInstDecl :: Maybe (Name, [Name])+                -> TyFamInstDecl RdrName+                -> RnM (TyFamInstDecl Name, FreeVars)+rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = L loc eqn })+  = do { (eqn', fvs) <- rnTyFamInstEqn mb_cls eqn+       ; return (TyFamInstDecl { tfid_eqn = L loc eqn'+                               , tfid_fvs = fvs }, fvs) }++rnTyFamInstEqn :: Maybe (Name, [Name])+               -> TyFamInstEqn RdrName+               -> RnM (TyFamInstEqn Name, FreeVars)+rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon+                                , tfe_pats  = pats+                                , tfe_fixity = fixity+                                , tfe_rhs   = rhs })+  = do { (tycon', pats', rhs', fvs) <-+           rnFamInstDecl (TySynCtx tycon) mb_cls tycon pats rhs rnTySyn+       ; return (TyFamEqn { tfe_tycon = tycon'+                          , tfe_pats  = pats'+                          , tfe_fixity = fixity+                          , tfe_rhs   = rhs' }, fvs) }++rnTyFamDefltEqn :: Name+                -> TyFamDefltEqn RdrName+                -> RnM (TyFamDefltEqn Name, FreeVars)+rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon+                              , tfe_pats  = tyvars+                              , tfe_fixity = fixity+                              , tfe_rhs   = rhs })+  = bindHsQTyVars ctx Nothing (Just cls) [] tyvars $ \ tyvars' _ ->+    do { tycon'      <- lookupFamInstName (Just cls) tycon+       ; (rhs', fvs) <- rnLHsType ctx rhs+       ; return (TyFamEqn { tfe_tycon = tycon'+                          , tfe_pats  = tyvars'+                          , tfe_fixity = fixity+                          , tfe_rhs   = rhs' }, fvs) }+  where+    ctx = TyFamilyCtx tycon++rnDataFamInstDecl :: Maybe (Name, [Name])+                  -> DataFamInstDecl RdrName+                  -> RnM (DataFamInstDecl Name, FreeVars)+rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon+                                          , dfid_pats  = pats+                                          , dfid_fixity = fixity+                                          , dfid_defn  = defn })+  = do { (tycon', pats', (defn', _), fvs) <-+           rnFamInstDecl (TyDataCtx tycon) mb_cls tycon pats defn rnDataDefn+       ; return (DataFamInstDecl { dfid_tycon = tycon'+                                 , dfid_pats  = pats'+                                 , dfid_fixity = fixity+                                 , dfid_defn  = defn'+                                 , dfid_fvs   = fvs }, fvs) }++-- Renaming of the associated types in instances.++-- Rename associated type family decl in class+rnATDecls :: Name      -- Class+          -> [LFamilyDecl RdrName]+          -> RnM ([LFamilyDecl Name], FreeVars)+rnATDecls cls at_decls+  = rnList (rnFamDecl (Just cls)) at_decls++rnATInstDecls :: (Maybe (Name, [Name]) ->    -- The function that renames+                  decl RdrName ->            -- an instance. rnTyFamInstDecl+                  RnM (decl Name, FreeVars)) -- or rnDataFamInstDecl+              -> Name      -- Class+              -> [Name]+              -> [Located (decl RdrName)]+              -> RnM ([Located (decl Name)], FreeVars)+-- Used for data and type family defaults in a class decl+-- and the family instance declarations in an instance+--+-- NB: We allow duplicate associated-type decls;+--     See Note [Associated type instances] in TcInstDcls+rnATInstDecls rnFun cls tv_ns at_insts+  = rnList (rnFun (Just (cls, tv_ns))) at_insts+    -- See Note [Renaming associated types]++{- Note [Wildcards in family instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Wild cards can be used in type/data family instance declarations to indicate+that the name of a type variable doesn't matter. Each wild card will be+replaced with a new unique type variable. For instance:++    type family F a b :: *+    type instance F Int _ = Int++is the same as++    type family F a b :: *+    type instance F Int b = Int++This is implemented as follows: during renaming anonymous wild cards+'_' are given freshly generated names. These names are collected after+renaming (rnFamInstDecl) and used to make new type variables during+type checking (tc_fam_ty_pats). One should not confuse these wild+cards with the ones from partial type signatures. The latter generate+fresh meta-variables whereas the former generate fresh skolems.++Note [Unused type variables in family instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When the flag -fwarn-unused-type-patterns is on, the compiler reports+warnings about unused type variables in type-family instances. A+tpye variable is considered used (i.e. cannot be turned into a wildcard)+when++ * it occurs on the RHS of the family instance+   e.g.   type instance F a b = a    -- a is used on the RHS++ * it occurs multiple times in the patterns on the LHS+   e.g.   type instance F a a = Int  -- a appears more than once on LHS++ * it is one of the instance-decl variables, for associated types+   e.g.   instance C (a,b) where+            type T (a,b) = a+   Here the type pattern in the type instance must be the same as that+   for the class instance, so+            type T (a,_) = a+   would be rejected.  So we should not complain about an unused variable b++As usual, the warnings are not reported for for type variables with names+beginning with an underscore.++Extra-constraints wild cards are not supported in type/data family+instance declarations.++Relevant tickets: #3699, #10586, #10982 and #11451.++Note [Renaming associated types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Check that the RHS of the decl mentions only type variables+bound on the LHS.  For example, this is not ok+   class C a b where+      type F a x :: *+   instance C (p,q) r where+      type F (p,q) x = (x, r)   -- BAD: mentions 'r'+c.f. Trac #5515++The same thing applies to kind variables, of course (Trac #7938, #9574):+   class Funct f where+      type Codomain f :: *+   instance Funct ('KProxy :: KProxy o) where+      type Codomain 'KProxy = NatTr (Proxy :: o -> *)+Here 'o' is mentioned on the RHS of the Codomain function, but+not on the LHS.++All this applies only for *instance* declarations.  In *class*+declarations there is no RHS to worry about, and the class variables+can all be in scope (Trac #5862):+    class Category (x :: k -> k -> *) where+      type Ob x :: k -> Constraint+      id :: Ob x a => x a a+      (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c+Here 'k' is in scope in the kind signature, just like 'x'.+-}+++{-+*********************************************************+*                                                      *+\subsection{Stand-alone deriving declarations}+*                                                      *+*********************************************************+-}++rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)+rnSrcDerivDecl (DerivDecl ty deriv_strat overlap)+  = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving+       ; deriv_strats_ok     <- xoptM LangExt.DerivingStrategies+       ; unless standalone_deriv_ok (addErr standaloneDerivErr)+       ; failIfTc (isJust deriv_strat && not deriv_strats_ok) $+           illegalDerivStrategyErr $ fmap unLoc deriv_strat+       ; (ty', fvs) <- rnLHsInstType (text "In a deriving declaration") ty+       ; return (DerivDecl ty' deriv_strat overlap, fvs) }++standaloneDerivErr :: SDoc+standaloneDerivErr+  = hang (text "Illegal standalone deriving declaration")+       2 (text "Use StandaloneDeriving to enable this extension")++{-+*********************************************************+*                                                      *+\subsection{Rules}+*                                                      *+*********************************************************+-}++rnHsRuleDecls :: RuleDecls RdrName -> RnM (RuleDecls Name, FreeVars)+rnHsRuleDecls (HsRules src rules)+  = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules+       ; return (HsRules src rn_rules,fvs) }++rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)+rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)+  = do { let rdr_names_w_loc = map get_var vars+       ; checkDupRdrNames rdr_names_w_loc+       ; checkShadowedRdrNames rdr_names_w_loc+       ; names <- newLocalBndrsRn rdr_names_w_loc+       ; bindHsRuleVars (snd $ unLoc rule_name) vars names $ \ vars' ->+    do { (lhs', fv_lhs') <- rnLExpr lhs+       ; (rhs', fv_rhs') <- rnLExpr rhs+       ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs'+       ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',+                 fv_lhs' `plusFV` fv_rhs') } }+  where+    get_var (L _ (RuleBndrSig v _)) = v+    get_var (L _ (RuleBndr v)) = v++bindHsRuleVars :: RuleName -> [LRuleBndr RdrName] -> [Name]+               -> ([LRuleBndr Name] -> RnM (a, FreeVars))+               -> RnM (a, FreeVars)+bindHsRuleVars rule_name vars names thing_inside+  = go vars names $ \ vars' ->+    bindLocalNamesFV names (thing_inside vars')+  where+    doc = RuleCtx rule_name++    go (L l (RuleBndr (L loc _)) : vars) (n : ns) thing_inside+      = go vars ns $ \ vars' ->+        thing_inside (L l (RuleBndr (L loc n)) : vars')++    go (L l (RuleBndrSig (L loc _) bsig) : vars) (n : ns) thing_inside+      = rnHsSigWcTypeScoped doc bsig $ \ bsig' ->+        go vars ns $ \ vars' ->+        thing_inside (L l (RuleBndrSig (L loc n) bsig') : vars')++    go [] [] thing_inside = thing_inside []+    go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)++{-+Note [Rule LHS validity checking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Check the shape of a transformation rule LHS.  Currently we only allow+LHSs of the form @(f e1 .. en)@, where @f@ is not one of the+@forall@'d variables.++We used restrict the form of the 'ei' to prevent you writing rules+with LHSs with a complicated desugaring (and hence unlikely to match);+(e.g. a case expression is not allowed: too elaborate.)++But there are legitimate non-trivial args ei, like sections and+lambdas.  So it seems simmpler not to check at all, and that is why+check_e is commented out.+-}++checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM ()+checkValidRule rule_name ids lhs' fv_lhs'+  = do  {       -- Check for the form of the LHS+          case (validRuleLhs ids lhs') of+                Nothing  -> return ()+                Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)++                -- Check that LHS vars are all bound+        ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]+        ; mapM_ (addErr . badRuleVar rule_name) bad_vars }++validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)+-- Nothing => OK+-- Just e  => Not ok, and e is the offending sub-expression+validRuleLhs foralls lhs+  = checkl lhs+  where+    checkl (L _ e) = check e++    check (OpApp e1 op _ e2)              = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2+    check (HsApp e1 e2)                   = checkl e1 `mplus` checkl_e e2+    check (HsAppType e _)                 = checkl e+    check (HsVar (L _ v)) | v `notElem` foralls = Nothing+    check other                           = Just other  -- Failure++        -- Check an argument+    checkl_e (L _ _e) = Nothing         -- Was (check_e e); see Note [Rule LHS validity checking]++{-      Commented out; see Note [Rule LHS validity checking] above+    check_e (HsVar v)     = Nothing+    check_e (HsPar e)     = checkl_e e+    check_e (HsLit e)     = Nothing+    check_e (HsOverLit e) = Nothing++    check_e (OpApp e1 op _ e2)   = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2+    check_e (HsApp e1 e2)        = checkl_e e1 `mplus` checkl_e e2+    check_e (NegApp e _)         = checkl_e e+    check_e (ExplicitList _ es)  = checkl_es es+    check_e other                = Just other   -- Fails++    checkl_es es = foldr (mplus . checkl_e) Nothing es+-}++badRuleVar :: FastString -> Name -> SDoc+badRuleVar name var+  = sep [text "Rule" <+> doubleQuotes (ftext name) <> colon,+         text "Forall'd variable" <+> quotes (ppr var) <+>+                text "does not appear on left hand side"]++badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc+badRuleLhsErr name lhs bad_e+  = sep [text "Rule" <+> pprRuleName name <> colon,+         nest 4 (vcat [err,+                       text "in left-hand side:" <+> ppr lhs])]+    $$+    text "LHS must be of form (f e1 .. en) where f is not forall'd"+  where+    err = case bad_e of+            HsUnboundVar uv -> text "Not in scope:" <+> ppr uv+            _ -> text "Illegal expression:" <+> ppr bad_e++{-+*********************************************************+*                                                      *+\subsection{Vectorisation declarations}+*                                                      *+*********************************************************+-}++rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, FreeVars)+-- FIXME: For the moment, the right-hand side is restricted to be a variable as we cannot properly+--        typecheck a complex right-hand side without invoking 'vectType' from the vectoriser.+rnHsVectDecl (HsVect s var rhs@(L _ (HsVar _)))+  = do { var' <- lookupLocatedOccRn var+       ; (rhs', fv_rhs) <- rnLExpr rhs+       ; return (HsVect s var' rhs', fv_rhs `addOneFV` unLoc var')+       }+rnHsVectDecl (HsVect _ _var _rhs)+  = failWith $ vcat+               [ text "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma"+               , text "must be an identifier"+               ]+rnHsVectDecl (HsNoVect s var)+  = do { var' <- lookupLocatedTopBndrRn var           -- only applies to local (not imported) names+       ; return (HsNoVect s var', unitFV (unLoc var'))+       }+rnHsVectDecl (HsVectTypeIn s isScalar tycon Nothing)+  = do { tycon' <- lookupLocatedOccRn tycon+       ; return (HsVectTypeIn s isScalar tycon' Nothing, unitFV (unLoc tycon'))+       }+rnHsVectDecl (HsVectTypeIn s isScalar tycon (Just rhs_tycon))+  = do { tycon'     <- lookupLocatedOccRn tycon+       ; rhs_tycon' <- lookupLocatedOccRn rhs_tycon+       ; return ( HsVectTypeIn s isScalar tycon' (Just rhs_tycon')+                , mkFVs [unLoc tycon', unLoc rhs_tycon'])+       }+rnHsVectDecl (HsVectTypeOut _ _ _)+  = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'"+rnHsVectDecl (HsVectClassIn s cls)+  = do { cls' <- lookupLocatedOccRn cls+       ; return (HsVectClassIn s cls', unitFV (unLoc cls'))+       }+rnHsVectDecl (HsVectClassOut _)+  = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'"+rnHsVectDecl (HsVectInstIn instTy)+  = do { (instTy', fvs) <- rnLHsInstType (text "a VECTORISE pragma") instTy+       ; return (HsVectInstIn instTy', fvs)+       }+rnHsVectDecl (HsVectInstOut _)+  = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'"++{- **************************************************************+         *                                                      *+      Renaming type, class, instance and role declarations+*                                                               *+*****************************************************************++@rnTyDecl@ uses the `global name function' to create a new type+declaration in which local names have been replaced by their original+names, reporting any unknown names.++Renaming type variables is a pain. Because they now contain uniques,+it is necessary to pass in an association list which maps a parsed+tyvar to its @Name@ representation.+In some cases (type signatures of values),+it is even necessary to go over the type first+in order to get the set of tyvars used by it, make an assoc list,+and then go over it again to rename the tyvars!+However, we can also do some scoping checks at the same time.++Note [Dependency analysis of type, class, and instance decls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A TyClGroup represents a strongly connected components of+type/class/instance decls, together with the role annotations for the+type/class declarations.  The renamer uses strongly connected+comoponent analysis to build these groups.  We do this for a number of+reasons:++* Improve kind error messages. Consider++     data T f a = MkT f a+     data S f a = MkS f (T f a)++  This has a kind error, but the error message is better if you+  check T first, (fixing its kind) and *then* S.  If you do kind+  inference together, you might get an error reported in S, which+  is jolly confusing.  See Trac #4875+++* Increase kind polymorphism.  See TcTyClsDecls+  Note [Grouping of type and class declarations]++Why do the instance declarations participate?  At least two reasons++* Consider (Trac #11348)++     type family F a+     type instance F Int = Bool++     data R = MkR (F Int)++     type Foo = 'MkR 'True++  For Foo to kind-check we need to know that (F Int) ~ Bool.  But we won't+  know that unless we've looked at the type instance declaration for F+  before kind-checking Foo.++* Another example is this (Trac #3990).++     data family Complex a+     data instance Complex Double = CD {-# UNPACK #-} !Double+                                       {-# UNPACK #-} !Double++     data T = T {-# UNPACK #-} !(Complex Double)++  Here, to generate the right kind of unpacked implementation for T,+  we must have access to the 'data instance' declaration.++* Things become more complicated when we introduce transitive+  dependencies through imported definitions, like in this scenario:++      A.hs+        type family Closed (t :: Type) :: Type where+          Closed t = Open t++        type family Open (t :: Type) :: Type++      B.hs+        data Q where+          Q :: Closed Bool -> Q++        type instance Open Int = Bool++        type S = 'Q 'True++  Somehow, we must ensure that the instance Open Int = Bool is checked before+  the type synonym S. While we know that S depends upon 'Q depends upon Closed,+  we have no idea that Closed depends upon Open!++  To accomodate for these situations, we ensure that an instance is checked+  before every @TyClDecl@ on which it does not depend. That's to say, instances+  are checked as early as possible in @tcTyAndClassDecls@.++------------------------------------+So much for WHY.  What about HOW?  It's pretty easy:++(1) Rename the type/class, instance, and role declarations+    individually++(2) Do strongly-connected component analysis of the type/class decls,+    We'll make a TyClGroup for each SCC++    In this step we treat a reference to a (promoted) data constructor+    K as a dependency on its parent type.  Thus+        data T = K1 | K2+        data S = MkS (Proxy 'K1)+    Here S depends on 'K1 and hence on its parent T.++    In this step we ignore instances; see+    Note [No dependencies on data instances]++(3) Attach roles to the appropriate SCC++(4) Attach instances to the appropriate SCC.+    We add an instance decl to SCC when:+      all its free types/classes are bound in this SCC or earlier ones++(5) We make an initial TyClGroup, with empty group_tyclds, for any+    (orphan) instances that affect only imported types/classes++Steps (3) and (4) are done by the (mapAccumL mk_group) call.++Note [No dependencies on data instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this+   data family D a+   data instance D Int = D1+   data S = MkS (Proxy 'D1)++Here the declaration of S depends on the /data instance/ declaration+for 'D Int'.  That makes things a lot more complicated, especially+if the data instance is an associated type of an enclosing class instance.+(And the class instance might have several associated type instances+with different dependency structure!)++Ugh.  For now we simply don't allow promotion of data constructors for+data instances.  See Note [AFamDataCon: not promoting data family+constructors] in TcEnv+-}+++rnTyClDecls :: [TyClGroup RdrName]+            -> RnM ([TyClGroup Name], FreeVars)+-- Rename the declarations and do dependency analysis on them+rnTyClDecls tycl_ds+  = do { -- Rename the type/class, instance, and role declaraations+         tycls_w_fvs <- mapM (wrapLocFstM rnTyClDecl)+                             (tyClGroupTyClDecls tycl_ds)+       ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs)++       ; instds_w_fvs <- mapM (wrapLocFstM rnSrcInstDecl) (tyClGroupInstDecls tycl_ds)+       ; role_annots  <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds)++       ; tycls_w_fvs <- addBootDeps tycls_w_fvs+                      -- TBD must add_boot_deps to instds_w_fvs?++       -- Do SCC analysis on the type/class decls+       ; rdr_env <- getGlobalRdrEnv+       ; let tycl_sccs = depAnalTyClDecls rdr_env tycls_w_fvs+             role_annot_env = mkRoleAnnotEnv role_annots++             inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs+             (init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map++             first_group+               | null init_inst_ds = []+               | otherwise = [TyClGroup { group_tyclds = []+                                        , group_roles  = []+                                        , group_instds = init_inst_ds }]++             ((final_inst_ds, orphan_roles), groups)+                = mapAccumL mk_group (rest_inst_ds, role_annot_env) tycl_sccs+++             all_fvs = plusFV (foldr (plusFV . snd) emptyFVs tycls_w_fvs)+                              (foldr (plusFV . snd) emptyFVs instds_w_fvs)++             all_groups = first_group ++ groups++       ; ASSERT2( null final_inst_ds,  ppr instds_w_fvs $$ ppr inst_ds_map+                                       $$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds  )+         mapM_ orphanRoleAnnotErr (nameEnvElts orphan_roles)++       ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups)+       ; return (all_groups, all_fvs) }+  where+    mk_group :: (InstDeclFreeVarsMap, RoleAnnotEnv)+             -> SCC (LTyClDecl Name)+             -> ( (InstDeclFreeVarsMap, RoleAnnotEnv)+                , TyClGroup Name )+    mk_group (inst_map, role_env) scc+      = ((inst_map', role_env'), group)+      where+        tycl_ds              = flattenSCC scc+        bndrs                = map (tcdName . unLoc) tycl_ds+        (inst_ds, inst_map') = getInsts      bndrs inst_map+        (roles,   role_env') = getRoleAnnots bndrs role_env+        group = TyClGroup { group_tyclds = tycl_ds+                          , group_roles  = roles+                          , group_instds = inst_ds }+++depAnalTyClDecls :: GlobalRdrEnv+                 -> [(LTyClDecl Name, FreeVars)]+                 -> [SCC (LTyClDecl Name)]+-- See Note [Dependency analysis of type, class, and instance decls]+depAnalTyClDecls rdr_env ds_w_fvs+  = stronglyConnCompFromEdgedVerticesUniq edges+  where+    edges = [ (d, tcdName (unLoc d), map (getParent rdr_env) (nonDetEltsUniqSet fvs))+            | (d, fvs) <- ds_w_fvs ]+            -- It's OK to use nonDetEltsUFM here as+            -- stronglyConnCompFromEdgedVertices is still deterministic+            -- even if the edges are in nondeterministic order as explained+            -- in Note [Deterministic SCC] in Digraph.++toParents :: GlobalRdrEnv -> NameSet -> NameSet+toParents rdr_env ns+  = nonDetFoldUniqSet add emptyNameSet ns+  -- It's OK to use nonDetFoldUFM because we immediately forget the+  -- ordering by creating a set+  where+    add n s = extendNameSet s (getParent rdr_env n)++getParent :: GlobalRdrEnv -> Name -> Name+getParent rdr_env n+  = case lookupGRE_Name rdr_env n of+      Just gre -> case gre_par gre of+                    ParentIs  { par_is = p } -> p+                    FldParent { par_is = p } -> p+                    _                        -> n+      Nothing -> n+++{- Note [Extra dependencies from .hs-boot files]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This is a long story, so buckle in.++**Dependencies via hs-boot files are not obvious.** Consider the following case:++A.hs-boot+  module A where+    data A1++B.hs+  module B where+    import {-# SOURCE #-} A+    type B1 = A1++A.hs+  module A where+    import B+    data A2 = MkA2 B1+    data A1 = MkA1 A2++Here A2 is really recursive (via B1), but we won't see that easily when+doing dependency analysis when compiling A.hs.  When we look at A2,+we see that its free variables are simply B1, but without (recursively) digging+into the definition of B1 will we see that it actually refers to A1 via an+hs-boot file.++**Recursive declarations, even those broken by an hs-boot file, need to+be type-checked together.**  Whenever we refer to a declaration via+an hs-boot file, we must be careful not to force the TyThing too early:+ala Note [Tying the knot] if we force the TyThing before we have+defined it ourselves in the local type environment, GHC will error.++Conservatively, then, it would make sense that we to typecheck A1+and A2 from the previous example together, because the two types are+truly mutually recursive through B1.++If we are being clever, we might observe that while kind-checking+A2, we don't actually need to force the TyThing for A1: B1+independently records its kind, so there is no need to go "deeper".+But then we are in an uncomfortable situation where we have+constructed a TyThing for A2 before we have checked A1, and we+have to be absolutely certain we don't force it too deeply until+we get around to kind checking A1, which could be for a very long+time.++Indeed, with datatype promotion, we may very well need to look+at the type of MkA2 before we have kind-checked A1: consider,++    data T = MkT (Proxy 'MkA2)++To promote MkA2, we need to lift its type to the kind level.+We never tested this, but it seems likely A1 would get poked+at this point.++**Here's what we do instead.**  So it is expedient for us to+make sure A1 and A2 are kind checked together in a loop.+To ensure that our dependency analysis can catch this,+we add a dependency:++  - from every local declaration+  - to everything that comes from this module's .hs-boot file+    (this is gotten from sb_tcs in the SelfBootInfo).++In this case, we'll add an edges++  - from A1 to A2 (but that edge is there already)+  - from A2 to A1 (which is new)++Well, not quite *every* declaration. Imagine module A+above had another datatype declaration:++  data A3 = A3 Int++Even though A3 has a dependency (on Int), all its dependencies are from things+that live on other packages. Since we don't have mutual dependencies across+packages, it is safe not to add the dependencies on the .hs-boot stuff to A2.++Hence function nameIsHomePackageImport.++Note that this is fairly conservative: it essentially implies that+EVERY type declaration in this modules hs-boot file will be kind-checked+together in one giant loop (and furthermore makes every other type+in the module depend on this loop).  This is perhaps less than ideal, because+the larger a recursive group, the less polymorphism available (we+cannot infer a type to be polymorphically instantiated while we+are inferring its kind), but no one has hollered about this (yet!)+-}++addBootDeps :: [(LTyClDecl Name, FreeVars)] -> RnM [(LTyClDecl Name, FreeVars)]+-- See Note [Extra dependencies from .hs-boot files]+addBootDeps ds_w_fvs+  = do { tcg_env <- getGblEnv+       ; let this_mod  = tcg_mod tcg_env+             boot_info = tcg_self_boot tcg_env++             add_boot_deps :: [(LTyClDecl Name, FreeVars)] -> [(LTyClDecl Name, FreeVars)]+             add_boot_deps ds_w_fvs+               = case boot_info of+                     SelfBoot { sb_tcs = tcs } | not (isEmptyNameSet tcs)+                        -> map (add_one tcs) ds_w_fvs+                     _  -> ds_w_fvs++             add_one :: NameSet -> (LTyClDecl Name, FreeVars) -> (LTyClDecl Name, FreeVars)+             add_one tcs pr@(decl,fvs)+                | has_local_imports fvs = (decl, fvs `plusFV` tcs)+                | otherwise             = pr++             has_local_imports fvs+                 = nameSetAny (nameIsHomePackageImport this_mod) fvs+       ; return (add_boot_deps ds_w_fvs) }++++{- ******************************************************+*                                                       *+       Role annotations+*                                                       *+****************************************************** -}++-- | Renames role annotations, returning them as the values in a NameEnv+-- and checks for duplicate role annotations.+-- It is quite convenient to do both of these in the same place.+-- See also Note [Role annotations in the renamer]+rnRoleAnnots :: NameSet+             -> [LRoleAnnotDecl RdrName]+             -> RnM [LRoleAnnotDecl Name]+rnRoleAnnots tc_names role_annots+  = do {  -- Check for duplicates *before* renaming, to avoid+          -- lumping together all the unboundNames+         let (no_dups, dup_annots) = removeDups role_annots_cmp role_annots+             role_annots_cmp (L _ annot1) (L _ annot2)+               = roleAnnotDeclName annot1 `compare` roleAnnotDeclName annot2+       ; mapM_ dupRoleAnnotErr dup_annots+       ; mapM (wrapLocM rn_role_annot1) no_dups }+  where+    rn_role_annot1 (RoleAnnotDecl tycon roles)+      = do {  -- the name is an *occurrence*, but look it up only in the+              -- decls defined in this group (see #10263)+             tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names)+                                          (text "role annotation")+                                          tycon+           ; return $ RoleAnnotDecl tycon' roles }++dupRoleAnnotErr :: [LRoleAnnotDecl RdrName] -> RnM ()+dupRoleAnnotErr [] = panic "dupRoleAnnotErr"+dupRoleAnnotErr list+  = addErrAt loc $+    hang (text "Duplicate role annotations for" <+>+          quotes (ppr $ roleAnnotDeclName first_decl) <> colon)+       2 (vcat $ map pp_role_annot sorted_list)+    where+      sorted_list = sortBy cmp_annot list+      (L loc first_decl : _) = sorted_list++      pp_role_annot (L loc decl) = hang (ppr decl)+                                      4 (text "-- written at" <+> ppr loc)++      cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2++orphanRoleAnnotErr :: LRoleAnnotDecl Name -> RnM ()+orphanRoleAnnotErr (L loc decl)+  = addErrAt loc $+    hang (text "Role annotation for a type previously declared:")+       2 (ppr decl) $$+    parens (text "The role annotation must be given where" <+>+            quotes (ppr $ roleAnnotDeclName decl) <+>+            text "is declared.")+++{- Note [Role annotations in the renamer]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must ensure that a type's role annotation is put in the same group as the+proper type declaration. This is because role annotations are needed during+type-checking when creating the type's TyCon. So, rnRoleAnnots builds a+NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that+type, if any. Then, this map can be used to add the role annotations to the+groups after dependency analysis.++This process checks for duplicate role annotations, where we must be careful+to do the check *before* renaming to avoid calling all unbound names duplicates+of one another.++The renaming process, as usual, might identify and report errors for unbound+names. We exclude the annotations for unbound names in the annotation+environment to avoid spurious errors for orphaned annotations.++We then (in rnTyClDecls) do a check for orphan role annotations (role+annotations without an accompanying type decl). The check works by folding+over components (of type [[Either (TyClDecl Name) (InstDecl Name)]]), selecting+out the relevant role declarations for each group, as well as diminishing the+annotation environment. After the fold is complete, anything left over in the+name environment must be an orphan, and errors are generated.++An earlier version of this algorithm short-cut the orphan check by renaming+only with names declared in this module. But, this check is insufficient in+the case of staged module compilation (Template Haskell, GHCi).+See #8485. With the new lookup process (which includes types declared in other+modules), we get better error messages, too.+-}+++{- ******************************************************+*                                                       *+       Dependency info for instances+*                                                       *+****************************************************** -}++----------------------------------------------------------+-- | 'InstDeclFreeVarsMap is an association of an+--   @InstDecl@ with @FreeVars@. The @FreeVars@ are+--   the tycon names that are both+--     a) free in the instance declaration+--     b) bound by this group of type/class/instance decls+type InstDeclFreeVarsMap = [(LInstDecl Name, FreeVars)]++-- | Construct an @InstDeclFreeVarsMap@ by eliminating any @Name@s from the+--   @FreeVars@ which are *not* the binders of a @TyClDecl@.+mkInstDeclFreeVarsMap :: GlobalRdrEnv+                      -> NameSet+                      -> [(LInstDecl Name, FreeVars)]+                      -> InstDeclFreeVarsMap+mkInstDeclFreeVarsMap rdr_env tycl_bndrs inst_ds_fvs+  = [ (inst_decl, toParents rdr_env fvs `intersectFVs` tycl_bndrs)+    | (inst_decl, fvs) <- inst_ds_fvs ]++-- | Get the @LInstDecl@s which have empty @FreeVars@ sets, and the+--   @InstDeclFreeVarsMap@ with these entries removed.+-- We call (getInsts tcs instd_map) when we've completed the declarations+-- for 'tcs'.  The call returns (inst_decls, instd_map'), where+--   inst_decls are the instance declarations all of+--              whose free vars are now defined+--   instd_map' is the inst-decl map with 'tcs' removed from+--               the free-var set+getInsts :: [Name] -> InstDeclFreeVarsMap -> ([LInstDecl Name], InstDeclFreeVarsMap)+getInsts bndrs inst_decl_map+  = partitionWith pick_me inst_decl_map+  where+    pick_me :: (LInstDecl Name, FreeVars)+            -> Either (LInstDecl Name) (LInstDecl Name, FreeVars)+    pick_me (decl, fvs)+      | isEmptyNameSet depleted_fvs = Left decl+      | otherwise                   = Right (decl, depleted_fvs)+      where+        depleted_fvs = delFVs bndrs fvs++{- ******************************************************+*                                                       *+         Renaming a type or class declaration+*                                                       *+****************************************************** -}++rnTyClDecl :: TyClDecl RdrName+           -> RnM (TyClDecl Name, FreeVars)++-- All flavours of type family declarations ("type family", "newtype family",+-- and "data family"), both top level and (for an associated type)+-- in a class decl+rnTyClDecl (FamDecl { tcdFam = decl })+  = do { (decl', fvs) <- rnFamDecl Nothing decl+       ; return (FamDecl decl', fvs) }++rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,+                      tcdFixity = fixity, tcdRhs = rhs })+  = do { tycon' <- lookupLocatedTopBndrRn tycon+       ; kvs <- freeKiTyVarsKindVars <$> extractHsTyRdrTyVars rhs+       ; let doc = TySynCtx tycon+       ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs)+       ; ((tyvars', rhs'), fvs) <- bindHsQTyVars doc Nothing Nothing kvs tyvars $+                                    \ tyvars' _ ->+                                    do { (rhs', fvs) <- rnTySyn doc rhs+                                       ; return ((tyvars', rhs'), fvs) }+       ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'+                         , tcdFixity = fixity+                         , tcdRhs = rhs', tcdFVs = fvs }, fvs) }++-- "data", "newtype" declarations+-- both top level and (for an associated type) in an instance decl+rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars,+                       tcdFixity = fixity, tcdDataDefn = defn })+  = do { tycon' <- lookupLocatedTopBndrRn tycon+       ; kvs <- extractDataDefnKindVars defn+       ; let doc = TyDataCtx tycon+       ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs)+       ; ((tyvars', defn', no_kvs), fvs)+           <- bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' dep_vars ->+              do { ((defn', kind_sig_fvs), fvs) <- rnDataDefn doc defn+                 ; let sig_tvs         = filterNameSet isTyVarName kind_sig_fvs+                       unbound_sig_tvs = sig_tvs `minusNameSet` dep_vars+                 ; return ((tyvars', defn', isEmptyNameSet unbound_sig_tvs), fvs) }+          -- See Note [Complete user-supplied kind signatures] in HsDecls+       ; typeintype <- xoptM LangExt.TypeInType+       ; let cusk = hsTvbAllKinded tyvars' &&+                    (not typeintype || no_kvs)+       ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars'+                          , tcdFixity = fixity+                          , tcdDataDefn = defn', tcdDataCusk = cusk+                          , tcdFVs = fvs }, fvs) }++rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,+                        tcdTyVars = tyvars, tcdFixity = fixity,+                        tcdFDs = fds, tcdSigs = sigs,+                        tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,+                        tcdDocs = docs})+  = do  { lcls' <- lookupLocatedTopBndrRn lcls+        ; let cls' = unLoc lcls'+              kvs = []  -- No scoped kind vars except those in+                        -- kind signatures on the tyvars++        -- Tyvars scope over superclass context and method signatures+        ; ((tyvars', context', fds', ats'), stuff_fvs)+            <- bindHsQTyVars cls_doc Nothing Nothing kvs tyvars $ \ tyvars' _ -> do+                  -- Checks for distinct tyvars+             { (context', cxt_fvs) <- rnContext cls_doc context+             ; fds'  <- rnFds fds+                         -- The fundeps have no free variables+             ; (ats', fv_ats) <- rnATDecls cls' ats+             ; let fvs = cxt_fvs     `plusFV`+                         fv_ats+             ; return ((tyvars', context', fds', ats'), fvs) }++        ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltEqn cls') at_defs++        -- No need to check for duplicate associated type decls+        -- since that is done by RnNames.extendGlobalRdrEnvRn++        -- Check the signatures+        -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).+        ; let sig_rdr_names_w_locs = [op | L _ (ClassOpSig False ops _) <- sigs+                                         , op <- ops]+        ; checkDupRdrNames sig_rdr_names_w_locs+                -- Typechecker is responsible for checking that we only+                -- give default-method bindings for things in this class.+                -- The renamer *could* check this for class decls, but can't+                -- for instance decls.++        -- The newLocals call is tiresome: given a generic class decl+        --      class C a where+        --        op :: a -> a+        --        op {| x+y |} (Inl a) = ...+        --        op {| x+y |} (Inr b) = ...+        --        op {| a*b |} (a*b)   = ...+        -- we want to name both "x" tyvars with the same unique, so that they are+        -- easy to group together in the typechecker.+        ; (mbinds', sigs', meth_fvs)+            <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs+                -- No need to check for duplicate method signatures+                -- since that is done by RnNames.extendGlobalRdrEnvRn+                -- and the methods are already in scope++  -- Haddock docs+        ; docs' <- mapM (wrapLocM rnDocDecl) docs++        ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs+        ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',+                              tcdTyVars = tyvars', tcdFixity = fixity,+                              tcdFDs = fds', tcdSigs = sigs',+                              tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',+                              tcdDocs = docs', tcdFVs = all_fvs },+                  all_fvs ) }+  where+    cls_doc  = ClassDeclCtx lcls++-- "type" and "type instance" declarations+rnTySyn :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)+rnTySyn doc rhs = rnLHsType doc rhs++rnDataDefn :: HsDocContext -> HsDataDefn RdrName+           -> RnM ((HsDataDefn Name, NameSet), FreeVars)+                -- the NameSet includes all Names free in the kind signature+                -- See Note [Complete user-supplied kind signatures]+rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType+                           , dd_ctxt = context, dd_cons = condecls+                           , dd_kindSig = m_sig, dd_derivs = derivs })+  = do  { checkTc (h98_style || null (unLoc context))+                  (badGadtStupidTheta doc)++        ; (m_sig', sig_fvs) <- case m_sig of+             Just sig -> first Just <$> rnLHsKind doc sig+             Nothing  -> return (Nothing, emptyFVs)+        ; (context', fvs1) <- rnContext doc context+        ; (derivs',  fvs3) <- rn_derivs derivs++        -- For the constructor declarations, drop the LocalRdrEnv+        -- in the GADT case, where the type variables in the declaration+        -- do not scope over the constructor signatures+        -- data T a where { T1 :: forall b. b-> b }+        ; let { zap_lcl_env | h98_style = \ thing -> thing+                            | otherwise = setLocalRdrEnv emptyLocalRdrEnv }+        ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls+           -- No need to check for duplicate constructor decls+           -- since that is done by RnNames.extendGlobalRdrEnvRn++        ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`+                        con_fvs `plusFV` sig_fvs+        ; return (( HsDataDefn { dd_ND = new_or_data, dd_cType = cType+                               , dd_ctxt = context', dd_kindSig = m_sig'+                               , dd_cons = condecls'+                               , dd_derivs = derivs' }+                  , sig_fvs )+                 , all_fvs )+        }+  where+    h98_style = case condecls of  -- Note [Stupid theta]+                     L _ (ConDeclGADT {}) : _  -> False+                     _                         -> True++    rn_derivs (L loc ds)+      = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies+           ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok)+               multipleDerivClausesErr+           ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause deriv_strats_ok doc) ds+           ; return (L loc ds', fvs) }++rnLHsDerivingClause :: Bool -> HsDocContext -> LHsDerivingClause RdrName+                    -> RnM (LHsDerivingClause Name, FreeVars)+rnLHsDerivingClause deriv_strats_ok doc+                (L loc (HsDerivingClause { deriv_clause_strategy = dcs+                                         , deriv_clause_tys = L loc' dct }))+  = do { failIfTc (isJust dcs && not deriv_strats_ok) $+           illegalDerivStrategyErr $ fmap unLoc dcs+       ; (dct', fvs) <- mapFvRn (rnHsSigType doc) dct+       ; return ( L loc (HsDerivingClause { deriv_clause_strategy = dcs+                                          , deriv_clause_tys = L loc' dct' })+                , fvs ) }++badGadtStupidTheta :: HsDocContext -> SDoc+badGadtStupidTheta _+  = vcat [text "No context is allowed on a GADT-style data declaration",+          text "(You can put a context on each constructor, though.)"]++illegalDerivStrategyErr :: Maybe DerivStrategy -> SDoc+illegalDerivStrategyErr ds+  = vcat [ text "Illegal deriving strategy" <> colon <+> maybe empty ppr ds+         , text "Use DerivingStrategies to enable this extension" ]++multipleDerivClausesErr :: SDoc+multipleDerivClausesErr+  = vcat [ text "Illegal use of multiple, consecutive deriving clauses"+         , text "Use DerivingStrategies to allow this" ]++rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested+                        --             inside an *class decl* for cls+                        --             used for associated types+          -> FamilyDecl RdrName+          -> RnM (FamilyDecl Name, FreeVars)+rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars+                             , fdFixity = fixity+                             , fdInfo = info, fdResultSig = res_sig+                             , fdInjectivityAnn = injectivity })+  = do { tycon' <- lookupLocatedTopBndrRn tycon+       ; kvs <- extractRdrKindSigVars res_sig+       ; ((tyvars', res_sig', injectivity'), fv1) <-+            bindHsQTyVars doc Nothing mb_cls kvs tyvars $+            \ tyvars'@(HsQTvs { hsq_implicit = rn_kvs }) _ ->+            do { let rn_sig = rnFamResultSig doc rn_kvs+               ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig+               ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')+                                          injectivity+               ; return ( (tyvars', res_sig', injectivity') , fv_kind ) }+       ; (info', fv2) <- rn_info info+       ; return (FamilyDecl { fdLName = tycon', fdTyVars = tyvars'+                            , fdFixity = fixity+                            , fdInfo = info', fdResultSig = res_sig'+                            , fdInjectivityAnn = injectivity' }+                , fv1 `plusFV` fv2) }+  where+     doc = TyFamilyCtx tycon++     ----------------------+     rn_info (ClosedTypeFamily (Just eqns))+       = do { (eqns', fvs) <- rnList (rnTyFamInstEqn Nothing) eqns+                                                    -- no class context,+            ; return (ClosedTypeFamily (Just eqns'), fvs) }+     rn_info (ClosedTypeFamily Nothing)+       = return (ClosedTypeFamily Nothing, emptyFVs)+     rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs)+     rn_info DataFamily     = return (DataFamily, emptyFVs)++rnFamResultSig :: HsDocContext+               -> [Name]   -- kind variables already in scope+               -> FamilyResultSig RdrName+               -> RnM (FamilyResultSig Name, FreeVars)+rnFamResultSig _ _ NoSig+   = return (NoSig, emptyFVs)+rnFamResultSig doc _ (KindSig kind)+   = do { (rndKind, ftvs) <- rnLHsKind doc kind+        ;  return (KindSig rndKind, ftvs) }+rnFamResultSig doc kv_names (TyVarSig tvbndr)+   = do { -- `TyVarSig` tells us that user named the result of a type family by+          -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to+          -- be sure that the supplied result name is not identical to an+          -- already in-scope type variable from an enclosing class.+          --+          --  Example of disallowed declaration:+          --         class C a b where+          --            type F b = a | a -> b+          rdr_env <- getLocalRdrEnv+       ;  let resName = hsLTyVarName tvbndr+       ;  when (resName `elemLocalRdrEnv` rdr_env) $+          addErrAt (getLoc tvbndr) $+                     (hsep [ text "Type variable", quotes (ppr resName) <> comma+                           , text "naming a type family result,"+                           ] $$+                      text "shadows an already bound type variable")++       ; bindLHsTyVarBndr doc Nothing -- this might be a lie, but it's used for+                                      -- scoping checks that are irrelevant here+                          (mkNameSet kv_names) emptyNameSet+                                       -- use of emptyNameSet here avoids+                                       -- redundant duplicate errors+                          tvbndr $ \ _ _ tvbndr' ->+         return (TyVarSig tvbndr', unitFV (hsLTyVarName tvbndr')) }++-- Note [Renaming injectivity annotation]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- During renaming of injectivity annotation we have to make several checks to+-- make sure that it is well-formed.  At the moment injectivity annotation+-- consists of a single injectivity condition, so the terms "injectivity+-- annotation" and "injectivity condition" might be used interchangeably.  See+-- Note [Injectivity annotation] for a detailed discussion of currently allowed+-- injectivity annotations.+--+-- Checking LHS is simple because the only type variable allowed on the LHS of+-- injectivity condition is the variable naming the result in type family head.+-- Example of disallowed annotation:+--+--     type family Foo a b = r | b -> a+--+-- Verifying RHS of injectivity consists of checking that:+--+--  1. only variables defined in type family head appear on the RHS (kind+--     variables are also allowed).  Example of disallowed annotation:+--+--        type family Foo a = r | r -> b+--+--  2. for associated types the result variable does not shadow any of type+--     class variables. Example of disallowed annotation:+--+--        class Foo a b where+--           type F a = b | b -> a+--+-- Breaking any of these assumptions results in an error.++-- | Rename injectivity annotation. Note that injectivity annotation is just the+-- part after the "|".  Everything that appears before it is renamed in+-- rnFamDecl.+rnInjectivityAnn :: LHsQTyVars Name            -- ^ Type variables declared in+                                               --   type family head+                 -> LFamilyResultSig Name      -- ^ Result signature+                 -> LInjectivityAnn RdrName    -- ^ Injectivity annotation+                 -> RnM (LInjectivityAnn Name)+rnInjectivityAnn tvBndrs (L _ (TyVarSig resTv))+                 (L srcSpan (InjectivityAnn injFrom injTo))+ = do+   { (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors)+          <- askNoErrs $+             bindLocalNames [hsLTyVarName resTv] $+             -- The return type variable scopes over the injectivity annotation+             -- e.g.   type family F a = (r::*) | r -> a+             do { injFrom' <- rnLTyVar injFrom+                ; injTo'   <- mapM rnLTyVar injTo+                ; return $ L srcSpan (InjectivityAnn injFrom' injTo') }++   ; let tvNames  = Set.fromList $ hsAllLTyVarNames tvBndrs+         resName  = hsLTyVarName resTv+         -- See Note [Renaming injectivity annotation]+         lhsValid = EQ == (stableNameCmp resName (unLoc injFrom'))+         rhsValid = Set.fromList (map unLoc injTo') `Set.difference` tvNames++   -- if renaming of type variables ended with errors (eg. there were+   -- not-in-scope variables) don't check the validity of injectivity+   -- annotation. This gives better error messages.+   ; when (noRnErrors && not lhsValid) $+        addErrAt (getLoc injFrom)+              ( vcat [ text $ "Incorrect type variable on the LHS of "+                           ++ "injectivity condition"+              , nest 5+              ( vcat [ text "Expected :" <+> ppr resName+                     , text "Actual   :" <+> ppr injFrom ])])++   ; when (noRnErrors && not (Set.null rhsValid)) $+      do { let errorVars = Set.toList rhsValid+         ; addErrAt srcSpan $ ( hsep+                        [ text "Unknown type variable" <> plural errorVars+                        , text "on the RHS of injectivity condition:"+                        , interpp'SP errorVars ] ) }++   ; return injDecl' }++-- We can only hit this case when the user writes injectivity annotation without+-- naming the result:+--+--   type family F a | result -> a+--   type family F a :: * | result -> a+--+-- So we rename injectivity annotation like we normally would except that+-- this time we expect "result" to be reported not in scope by rnLTyVar.+rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) =+   setSrcSpan srcSpan $ do+   (injDecl', _) <- askNoErrs $ do+     injFrom' <- rnLTyVar injFrom+     injTo'   <- mapM rnLTyVar injTo+     return $ L srcSpan (InjectivityAnn injFrom' injTo')+   return $ injDecl'++{-+Note [Stupid theta]+~~~~~~~~~~~~~~~~~~~+Trac #3850 complains about a regression wrt 6.10 for+     data Show a => T a+There is no reason not to allow the stupid theta if there are no data+constructors.  It's still stupid, but does no harm, and I don't want+to cause programs to break unnecessarily (notably HList).  So if there+are no data constructors we allow h98_style = True+-}+++{- *****************************************************+*                                                      *+     Support code for type/data declarations+*                                                      *+***************************************************** -}++---------------+badAssocRhs :: [Name] -> RnM ()+badAssocRhs ns+  = addErr (hang (text "The RHS of an associated type declaration mentions"+                  <+> pprWithCommas (quotes . ppr) ns)+               2 (text "All such variables must be bound on the LHS"))++-----------------+rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)+rnConDecls = mapFvRn (wrapLocFstM rnConDecl)++rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars)+rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs+                           , con_cxt = mcxt, con_details = details+                           , con_doc = mb_doc })+  = do  { _ <- addLocM checkConName name+        ; new_name     <- lookupLocatedTopBndrRn name+        ; let doc = ConDeclCtx [new_name]+        ; mb_doc'      <- rnMbLHsDoc mb_doc+        ; (kvs, qtvs') <- get_con_qtvs (hsConDeclArgTys details)++        ; bindHsQTyVars doc (Just $ inHsDocContext doc) Nothing kvs qtvs' $+          \new_tyvars _ -> do+        { (new_context, fvs1) <- case mcxt of+                             Nothing   -> return (Nothing,emptyFVs)+                             Just lcxt -> do { (lctx',fvs) <- rnContext doc lcxt+                                             ; return (Just lctx',fvs) }+        ; (new_details, fvs2) <- rnConDeclDetails (unLoc new_name) doc details+        ; let (new_details',fvs3) = (new_details,emptyFVs)+        ; traceRn "rnConDecl" (ppr name <+> vcat+             [ text "free_kvs:" <+> ppr kvs+             , text "qtvs:" <+> ppr qtvs+             , text "qtvs':" <+> ppr qtvs' ])+        ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3+              new_tyvars' = case qtvs of+                Nothing -> Nothing+                Just _ -> Just new_tyvars+        ; return (decl { con_name = new_name, con_qvars = new_tyvars'+                       , con_cxt = new_context, con_details = new_details'+                       , con_doc = mb_doc' },+                  all_fvs) }}+ where+    cxt = maybe [] unLoc mcxt+    get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys)++    get_con_qtvs :: [LHsType RdrName]+                 -> RnM ([Located RdrName], LHsQTyVars RdrName)+    get_con_qtvs arg_tys+      | Just tvs <- qtvs   -- data T = forall a. MkT (a -> a)+      = do { free_vars <- get_rdr_tvs arg_tys+           ; return (freeKiTyVarsKindVars free_vars, tvs) }+      | otherwise  -- data T = MkT (a -> a)+      = return ([], mkHsQTvs [])++rnConDecl decl@(ConDeclGADT { con_names = names, con_type = ty+                            , con_doc = mb_doc })+  = do  { mapM_ (addLocM checkConName) names+        ; new_names    <- mapM lookupLocatedTopBndrRn names+        ; let doc = ConDeclCtx new_names+        ; mb_doc'      <- rnMbLHsDoc mb_doc++        ; (ty', fvs) <- rnHsSigType doc ty+        ; traceRn "rnConDecl" (ppr names <+> vcat+             [ text "fvs:" <+> ppr fvs ])+        ; return (decl { con_names = new_names, con_type = ty'+                       , con_doc = mb_doc' },+                  fvs) }++rnConDeclDetails+   :: Name+   -> HsDocContext+   -> HsConDetails (LHsType RdrName) (Located [LConDeclField RdrName])+   -> RnM (HsConDetails (LHsType Name) (Located [LConDeclField Name]), FreeVars)+rnConDeclDetails _ doc (PrefixCon tys)+  = do { (new_tys, fvs) <- rnLHsTypes doc tys+       ; return (PrefixCon new_tys, fvs) }++rnConDeclDetails _ doc (InfixCon ty1 ty2)+  = do { (new_ty1, fvs1) <- rnLHsType doc ty1+       ; (new_ty2, fvs2) <- rnLHsType doc ty2+       ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }++rnConDeclDetails con doc (RecCon (L l fields))+  = do  { fls <- lookupConstructorFields con+        ; (new_fields, fvs) <- rnConDeclFields doc fls fields+                -- No need to check for duplicate fields+                -- since that is done by RnNames.extendGlobalRdrEnvRn+        ; return (RecCon (L l new_fields), fvs) }++-------------------------------------------------++-- | Brings pattern synonym names and also pattern synonym selectors+-- from record pattern synonyms into scope.+extendPatSynEnv :: HsValBinds RdrName -> MiniFixityEnv+                -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a+extendPatSynEnv val_decls local_fix_env thing = do {+     names_with_fls <- new_ps val_decls+   ; let pat_syn_bndrs = concat [ name: map flSelector fields+                                | (name, fields) <- names_with_fls ]+   ; let avails = map avail pat_syn_bndrs+   ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env++   ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls+         final_gbl_env = gbl_env { tcg_field_env = field_env' }+   ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }+  where+    new_ps :: HsValBinds RdrName -> TcM [(Name, [FieldLabel])]+    new_ps (ValBindsIn binds _) = foldrBagM new_ps' [] binds+    new_ps _ = panic "new_ps"++    new_ps' :: LHsBindLR RdrName RdrName+            -> [(Name, [FieldLabel])]+            -> TcM [(Name, [FieldLabel])]+    new_ps' bind names+      | L bind_loc (PatSynBind (PSB { psb_id = L _ n+                                    , psb_args = RecordPatSyn as })) <- bind+      = do+          bnd_name <- newTopSrcBinder (L bind_loc n)+          let rnames = map recordPatSynSelectorId as+              mkFieldOcc :: Located RdrName -> LFieldOcc RdrName+              mkFieldOcc (L l name) = L l (FieldOcc (L l name) PlaceHolder)+              field_occs =  map mkFieldOcc rnames+          flds     <- mapM (newRecordSelector False [bnd_name]) field_occs+          return ((bnd_name, flds): names)+      | L bind_loc (PatSynBind (PSB { psb_id = L _ n})) <- bind+      = do+        bnd_name <- newTopSrcBinder (L bind_loc n)+        return ((bnd_name, []): names)+      | otherwise+      = return names++{-+*********************************************************+*                                                      *+\subsection{Support code to rename types}+*                                                      *+*********************************************************+-}++rnFds :: [Located (FunDep (Located RdrName))]+  -> RnM [Located (FunDep (Located Name))]+rnFds fds+  = mapM (wrapLocM rn_fds) fds+  where+    rn_fds (tys1, tys2)+      = do { tys1' <- rnHsTyVars tys1+           ; tys2' <- rnHsTyVars tys2+           ; return (tys1', tys2') }++rnHsTyVars :: [Located RdrName] -> RnM [Located Name]+rnHsTyVars tvs  = mapM rnHsTyVar tvs++rnHsTyVar :: Located RdrName -> RnM (Located Name)+rnHsTyVar (L l tyvar) = do+  tyvar' <- lookupOccRn tyvar+  return (L l tyvar')++{-+*********************************************************+*                                                      *+        findSplice+*                                                      *+*********************************************************++This code marches down the declarations, looking for the first+Template Haskell splice.  As it does so it+        a) groups the declarations into a HsGroup+        b) runs any top-level quasi-quotes+-}++findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))+findSplice ds = addl emptyRdrGroup ds++addl :: HsGroup RdrName -> [LHsDecl RdrName]+     -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))+-- This stuff reverses the declarations (again) but it doesn't matter+addl gp []           = return (gp, Nothing)+addl gp (L l d : ds) = add gp l d ds+++add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName]+    -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))++-- #10047: Declaration QuasiQuoters are expanded immediately, without+--         causing a group split+add gp _ (SpliceD (SpliceDecl (L _ qq@HsQuasiQuote{}) _)) ds+  = do { (ds', _) <- rnTopSpliceDecls qq+       ; addl gp (ds' ++ ds)+       }++add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds+  = do { -- We've found a top-level splice.  If it is an *implicit* one+         -- (i.e. a naked top level expression)+         case flag of+           ExplicitSplice -> return ()+           ImplicitSplice -> do { th_on <- xoptM LangExt.TemplateHaskell+                                ; unless th_on $ setSrcSpan loc $+                                  failWith badImplicitSplice }++       ; return (gp, Just (splice, ds)) }+  where+    badImplicitSplice = text "Parse error: module header, import declaration"+                     $$ text "or top-level declaration expected."++-- Class declarations: pull out the fixity signatures to the top+add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds+  | isClassDecl d+  = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in+    addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds+  | otherwise+  = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds++-- Signatures: fixity sigs go a different place than all others+add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds+  = addl (gp {hs_fixds = L l f : ts}) ds+add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds+  = addl (gp {hs_valds = add_sig (L l d) ts}) ds++-- Value declarations: use add_bind+add gp@(HsGroup {hs_valds  = ts}) l (ValD d) ds+  = addl (gp { hs_valds = add_bind (L l d) ts }) ds++-- Role annotations: added to the TyClGroup+add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD d) ds+  = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds++-- NB instance declarations go into TyClGroups. We throw them into the first+-- group, just as we do for the TyClD case. The renamer will go on to group+-- and order them later.+add gp@(HsGroup {hs_tyclds = ts})  l (InstD d) ds+  = addl (gp { hs_tyclds = add_instd (L l d) ts }) ds++-- The rest are routine+add gp@(HsGroup {hs_derivds = ts})  l (DerivD d) ds+  = addl (gp { hs_derivds = L l d : ts }) ds+add gp@(HsGroup {hs_defds  = ts})  l (DefD d) ds+  = addl (gp { hs_defds = L l d : ts }) ds+add gp@(HsGroup {hs_fords  = ts}) l (ForD d) ds+  = addl (gp { hs_fords = L l d : ts }) ds+add gp@(HsGroup {hs_warnds  = ts})  l (WarningD d) ds+  = addl (gp { hs_warnds = L l d : ts }) ds+add gp@(HsGroup {hs_annds  = ts}) l (AnnD d) ds+  = addl (gp { hs_annds = L l d : ts }) ds+add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds+  = addl (gp { hs_ruleds = L l d : ts }) ds+add gp@(HsGroup {hs_vects  = ts}) l (VectD d) ds+  = addl (gp { hs_vects = L l d : ts }) ds+add gp l (DocD d) ds+  = addl (gp { hs_docs = (L l d) : (hs_docs gp) })  ds++add_tycld :: LTyClDecl a -> [TyClGroup a] -> [TyClGroup a]+add_tycld d []       = [TyClGroup { group_tyclds = [d]+                                  , group_roles = []+                                  , group_instds = []+                                  }+                       ]+add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)+  = ds { group_tyclds = d : tyclds } : dss++add_instd :: LInstDecl a -> [TyClGroup a] -> [TyClGroup a]+add_instd d []       = [TyClGroup { group_tyclds = []+                                  , group_roles = []+                                  , group_instds = [d]+                                  }+                       ]+add_instd d (ds@(TyClGroup { group_instds = instds }):dss)+  = ds { group_instds = d : instds } : dss++add_role_annot :: LRoleAnnotDecl a -> [TyClGroup a] -> [TyClGroup a]+add_role_annot d [] = [TyClGroup { group_tyclds = []+                                 , group_roles = [d]+                                 , group_instds = []+                                 }+                      ]+add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)+  = tycls { group_roles = d : roles } : rest++add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a+add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs+add_bind _ (ValBindsOut {})     = panic "RdrHsSyn:add_bind"++add_sig :: LSig a -> HsValBinds a -> HsValBinds a+add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)+add_sig _ (ValBindsOut {})     = panic "RdrHsSyn:add_sig"
+ rename/RnSplice.hs view
@@ -0,0 +1,866 @@+{-# LANGUAGE CPP #-}++module RnSplice (+        rnTopSpliceDecls,+        rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl,+        rnBracket,+        checkThLocalName+        , traceSplice, SpliceInfo(..)+  ) where++#include "HsVersions.h"++import Name+import NameSet+import HsSyn+import RdrName+import TcRnMonad+import Kind++import RnEnv+import RnSource         ( rnSrcDecls, findSplice )+import RnPat            ( rnPat )+import BasicTypes       ( TopLevelFlag, isTopLevel, SourceText(..) )+import Outputable+import Module+import SrcLoc+import RnTypes          ( rnLHsType )++import Control.Monad    ( unless, when )++import {-# SOURCE #-} RnExpr   ( rnLExpr )++import TcEnv            ( checkWellStaged )+import THNames          ( liftName )++import DynFlags+import FastString+import ErrUtils         ( dumpIfSet_dyn_printer )+import TcEnv            ( tcMetaTy )+import Hooks+import Var              ( Id )+import THNames          ( quoteExpName, quotePatName, quoteDecName, quoteTypeName+                        , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, )++import {-# SOURCE #-} TcExpr   ( tcPolyExpr )+import {-# SOURCE #-} TcSplice+    ( runMetaD+    , runMetaE+    , runMetaP+    , runMetaT+    , runRemoteModFinalizers+    , tcTopSpliceExpr+    )++import GHCi.RemoteTypes ( ForeignRef )+import qualified Language.Haskell.TH as TH (Q)++import qualified GHC.LanguageExtensions as LangExt++{-+************************************************************************+*                                                                      *+        Template Haskell brackets+*                                                                      *+************************************************************************+-}++rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars)+rnBracket e br_body+  = addErrCtxt (quotationCtxtDoc br_body) $+    do { -- Check that -XTemplateHaskellQuotes is enabled and available+         thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes+       ; unless thQuotesEnabled $+           failWith ( vcat+                      [ text "Syntax error on" <+> ppr e+                      , text ("Perhaps you intended to use TemplateHaskell"+                              ++ " or TemplateHaskellQuotes") ] )++         -- Check for nested brackets+       ; cur_stage <- getStage+       ; case cur_stage of+           { Splice Typed   -> checkTc (isTypedBracket br_body)+                                       illegalUntypedBracket+           ; Splice Untyped -> checkTc (not (isTypedBracket br_body))+                                       illegalTypedBracket+           ; RunSplice _    ->+               -- See Note [RunSplice ThLevel] in "TcRnTypes".+               pprPanic "rnBracket: Renaming bracket when running a splice"+                        (ppr e)+           ; Comp           -> return ()+           ; Brack {}       -> failWithTc illegalBracket+           }++         -- Brackets are desugared to code that mentions the TH package+       ; recordThUse++       ; case isTypedBracket br_body of+            True  -> do { traceRn "Renaming typed TH bracket" empty+                        ; (body', fvs_e) <-+                          setStage (Brack cur_stage RnPendingTyped) $+                                   rn_bracket cur_stage br_body+                        ; return (HsBracket body', fvs_e) }++            False -> do { traceRn "Renaming untyped TH bracket" empty+                        ; ps_var <- newMutVar []+                        ; (body', fvs_e) <-+                          setStage (Brack cur_stage (RnPendingUntyped ps_var)) $+                                   rn_bracket cur_stage br_body+                        ; pendings <- readMutVar ps_var+                        ; return (HsRnBracketOut body' pendings, fvs_e) }+       }++rn_bracket :: ThStage -> HsBracket RdrName -> RnM (HsBracket Name, FreeVars)+rn_bracket outer_stage br@(VarBr flg rdr_name)+  = do { name <- lookupOccRn rdr_name+       ; this_mod <- getModule++       ; when (flg && nameIsLocalOrFrom this_mod name) $+             -- Type variables can be quoted in TH. See #5721.+                 do { mb_bind_lvl <- lookupLocalOccThLvl_maybe name+                    ; case mb_bind_lvl of+                        { Nothing -> return ()      -- Can happen for data constructors,+                                                    -- but nothing needs to be done for them++                        ; Just (top_lvl, bind_lvl)  -- See Note [Quoting names]+                             | isTopLevel top_lvl+                             -> when (isExternalName name) (keepAlive name)+                             | otherwise+                             -> do { traceRn "rn_bracket VarBr"+                                      (ppr name <+> ppr bind_lvl+                                                <+> ppr outer_stage)+                                   ; checkTc (thLevel outer_stage + 1 == bind_lvl)+                                             (quotedNameStageErr br) }+                        }+                    }+       ; return (VarBr flg name, unitFV name) }++rn_bracket _ (ExpBr e) = do { (e', fvs) <- rnLExpr e+                            ; return (ExpBr e', fvs) }++rn_bracket _ (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)++rn_bracket _ (TypBr t) = do { (t', fvs) <- rnLHsType TypBrCtx t+                            ; return (TypBr t', fvs) }++rn_bracket _ (DecBrL decls)+  = do { group <- groupDecls decls+       ; gbl_env  <- getGblEnv+       ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }+                          -- The emptyDUs is so that we just collect uses for this+                          -- group alone in the call to rnSrcDecls below+       ; (tcg_env, group') <- setGblEnv new_gbl_env $+                              rnSrcDecls group++              -- Discard the tcg_env; it contains only extra info about fixity+        ; traceRn "rn_bracket dec" (ppr (tcg_dus tcg_env) $$+                   ppr (duUses (tcg_dus tcg_env)))+        ; return (DecBrG group', duUses (tcg_dus tcg_env)) }+  where+    groupDecls :: [LHsDecl RdrName] -> RnM (HsGroup RdrName)+    groupDecls decls+      = do { (group, mb_splice) <- findSplice decls+           ; case mb_splice of+           { Nothing -> return group+           ; Just (splice, rest) ->+               do { group' <- groupDecls rest+                  ; let group'' = appendGroups group group'+                  ; return group'' { hs_splcds = noLoc splice : hs_splcds group' }+                  }+           }}++rn_bracket _ (DecBrG _) = panic "rn_bracket: unexpected DecBrG"++rn_bracket _ (TExpBr e) = do { (e', fvs) <- rnLExpr e+                             ; return (TExpBr e', fvs) }++quotationCtxtDoc :: HsBracket RdrName -> SDoc+quotationCtxtDoc br_body+  = hang (text "In the Template Haskell quotation")+         2 (ppr br_body)++illegalBracket :: SDoc+illegalBracket =+    text "Template Haskell brackets cannot be nested" <+>+    text "(without intervening splices)"++illegalTypedBracket :: SDoc+illegalTypedBracket =+    text "Typed brackets may only appear in typed splices."++illegalUntypedBracket :: SDoc+illegalUntypedBracket =+    text "Untyped brackets may only appear in untyped splices."++quotedNameStageErr :: HsBracket RdrName -> SDoc+quotedNameStageErr br+  = sep [ text "Stage error: the non-top-level quoted name" <+> ppr br+        , text "must be used at the same stage at which it is bound" ]+++{-+*********************************************************+*                                                      *+                Splices+*                                                      *+*********************************************************++Note [Free variables of typed splices]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider renaming this:+        f = ...+        h = ...$(thing "f")...++where the splice is a *typed* splice.  The splice can expand into+literally anything, so when we do dependency analysis we must assume+that it might mention 'f'.  So we simply treat all locally-defined+names as mentioned by any splice.  This is terribly brutal, but I+don't see what else to do.  For example, it'll mean that every+locally-defined thing will appear to be used, so no unused-binding+warnings.  But if we miss the dependency, then we might typecheck 'h'+before 'f', and that will crash the type checker because 'f' isn't in+scope.++Currently, I'm not treating a splice as also mentioning every import,+which is a bit inconsistent -- but there are a lot of them.  We might+thereby get some bogus unused-import warnings, but we won't crash the+type checker.  Not very satisfactory really.++Note [Renamer errors]+~~~~~~~~~~~~~~~~~~~~~+It's important to wrap renamer calls in checkNoErrs, because the+renamer does not fail for out of scope variables etc. Instead it+returns a bogus term/type, so that it can report more than one error.+We don't want the type checker to see these bogus unbound variables.+-}++rnSpliceGen :: (HsSplice Name -> RnM (a, FreeVars))     -- Outside brackets, run splice+            -> (HsSplice Name -> (PendingRnSplice, a))  -- Inside brackets, make it pending+            -> HsSplice RdrName+            -> RnM (a, FreeVars)+rnSpliceGen run_splice pend_splice splice+  = addErrCtxt (spliceCtxt splice) $ do+    { stage <- getStage+    ; case stage of+        Brack pop_stage RnPendingTyped+          -> do { checkTc is_typed_splice illegalUntypedSplice+                ; (splice', fvs) <- setStage pop_stage $+                                    rnSplice splice+                ; let (_pending_splice, result) = pend_splice splice'+                ; return (result, fvs) }++        Brack pop_stage (RnPendingUntyped ps_var)+          -> do { checkTc (not is_typed_splice) illegalTypedSplice+                ; (splice', fvs) <- setStage pop_stage $+                                    rnSplice splice+                ; let (pending_splice, result) = pend_splice splice'+                ; ps <- readMutVar ps_var+                ; writeMutVar ps_var (pending_splice : ps)+                ; return (result, fvs) }++        _ ->  do { (splice', fvs1) <- checkNoErrs $+                                      setStage (Splice splice_type) $+                                      rnSplice splice+                   -- checkNoErrs: don't attempt to run the splice if+                   -- renaming it failed; otherwise we get a cascade of+                   -- errors from e.g. unbound variables+                 ; (result, fvs2) <- run_splice splice'+                 ; return (result, fvs1 `plusFV` fvs2) } }+   where+     is_typed_splice = isTypedSplice splice+     splice_type = if is_typed_splice+                   then Typed+                   else Untyped++------------------++-- | Returns the result of running a splice and the modFinalizers collected+-- during the execution.+--+-- See Note [Delaying modFinalizers in untyped splices].+runRnSplice :: UntypedSpliceFlavour+            -> (LHsExpr Id -> TcRn res)+            -> (res -> SDoc)    -- How to pretty-print res+                                -- Usually just ppr, but not for [Decl]+            -> HsSplice Name    -- Always untyped+            -> TcRn (res, [ForeignRef (TH.Q ())])+runRnSplice flavour run_meta ppr_res splice+  = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice)++       ; let the_expr = case splice' of+                  HsUntypedSplice _ _ e   ->  e+                  HsQuasiQuote _ q qs str -> mkQuasiQuoteExpr flavour q qs str+                  HsTypedSplice {}        -> pprPanic "runRnSplice" (ppr splice)+                  HsSpliced {}            -> pprPanic "runRnSplice" (ppr splice)++             -- Typecheck the expression+       ; meta_exp_ty   <- tcMetaTy meta_ty_name+       ; zonked_q_expr <- tcTopSpliceExpr Untyped $+                          tcPolyExpr the_expr meta_exp_ty++             -- Run the expression+       ; mod_finalizers_ref <- newTcRef []+       ; result <- setStage (RunSplice mod_finalizers_ref) $+                     run_meta zonked_q_expr+       ; mod_finalizers <- readTcRef mod_finalizers_ref+       ; traceSplice (SpliceInfo { spliceDescription = what+                                 , spliceIsDecl      = is_decl+                                 , spliceSource      = Just the_expr+                                 , spliceGenerated   = ppr_res result })++       ; return (result, mod_finalizers) }++  where+    meta_ty_name = case flavour of+                       UntypedExpSplice  -> expQTyConName+                       UntypedPatSplice  -> patQTyConName+                       UntypedTypeSplice -> typeQTyConName+                       UntypedDeclSplice -> decsQTyConName+    what = case flavour of+                  UntypedExpSplice  -> "expression"+                  UntypedPatSplice  -> "pattern"+                  UntypedTypeSplice -> "type"+                  UntypedDeclSplice -> "declarations"+    is_decl = case flavour of+                 UntypedDeclSplice -> True+                 _                 -> False++------------------+makePending :: UntypedSpliceFlavour+            -> HsSplice Name+            -> PendingRnSplice+makePending flavour (HsUntypedSplice _ n e)+  = PendingRnSplice flavour n e+makePending flavour (HsQuasiQuote n quoter q_span quote)+  = PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter q_span quote)+makePending _ splice@(HsTypedSplice {})+  = pprPanic "makePending" (ppr splice)+makePending _ splice@(HsSpliced {})+  = pprPanic "makePending" (ppr splice)++------------------+mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString -> LHsExpr Name+-- Return the expression (quoter "...quote...")+-- which is what we must run in a quasi-quote+mkQuasiQuoteExpr flavour quoter q_span quote+  = L q_span $ HsApp (L q_span $+                      HsApp (L q_span (HsVar (L q_span quote_selector)))+                            quoterExpr)+                     quoteExpr+  where+    quoterExpr = L q_span $! HsVar $! (L q_span quoter)+    quoteExpr  = L q_span $! HsLit $! HsString NoSourceText quote+    quote_selector = case flavour of+                       UntypedExpSplice  -> quoteExpName+                       UntypedPatSplice  -> quotePatName+                       UntypedTypeSplice -> quoteTypeName+                       UntypedDeclSplice -> quoteDecName++---------------------+rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)+-- Not exported...used for all+rnSplice (HsTypedSplice hasParen splice_name expr)+  = do  { checkTH expr "Template Haskell typed splice"+        ; loc  <- getSrcSpanM+        ; n' <- newLocalBndrRn (L loc splice_name)+        ; (expr', fvs) <- rnLExpr expr+        ; return (HsTypedSplice hasParen n' expr', fvs) }++rnSplice (HsUntypedSplice hasParen splice_name expr)+  = do  { checkTH expr "Template Haskell untyped splice"+        ; loc  <- getSrcSpanM+        ; n' <- newLocalBndrRn (L loc splice_name)+        ; (expr', fvs) <- rnLExpr expr+        ; return (HsUntypedSplice hasParen n' expr', fvs) }++rnSplice (HsQuasiQuote splice_name quoter q_loc quote)+  = do  { checkTH quoter "Template Haskell quasi-quote"+        ; loc  <- getSrcSpanM+        ; splice_name' <- newLocalBndrRn (L loc splice_name)++          -- Rename the quoter; akin to the HsVar case of rnExpr+        ; quoter' <- lookupOccRn quoter+        ; this_mod <- getModule+        ; when (nameIsLocalOrFrom this_mod quoter') $+          checkThLocalName quoter'++        ; return (HsQuasiQuote splice_name' quoter' q_loc quote, unitFV quoter') }++rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice)++---------------------+rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars)+rnSpliceExpr splice+  = rnSpliceGen run_expr_splice pend_expr_splice splice+  where+    pend_expr_splice :: HsSplice Name -> (PendingRnSplice, HsExpr Name)+    pend_expr_splice rn_splice+        = (makePending UntypedExpSplice rn_splice, HsSpliceE rn_splice)++    run_expr_splice :: HsSplice Name -> RnM (HsExpr Name, FreeVars)+    run_expr_splice rn_splice+      | isTypedSplice rn_splice   -- Run it later, in the type checker+      = do {  -- Ugh!  See Note [Splices] above+             traceRn "rnSpliceExpr: typed expression splice" empty+           ; lcl_rdr <- getLocalRdrEnv+           ; gbl_rdr <- getGlobalRdrEnv+           ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr+                                                     , isLocalGRE gre]+                 lcl_names = mkNameSet (localRdrEnvElts lcl_rdr)++           ; return (HsSpliceE rn_splice, lcl_names `plusFV` gbl_names) }++      | otherwise  -- Run it here, see Note [Running splices in the Renamer]+      = do { traceRn "rnSpliceExpr: untyped expression splice" empty+           ; (rn_expr, mod_finalizers) <-+                runRnSplice UntypedExpSplice runMetaE ppr rn_splice+           ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr)+             -- See Note [Delaying modFinalizers in untyped splices].+           ; return ( HsPar $ HsSpliceE+                            . HsSpliced (ThModFinalizers mod_finalizers)+                            . HsSplicedExpr <$>+                            lexpr3+                    , fvs)+           }++{- Note [Running splices in the Renamer]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Splices used to be run in the typechecker, which led to (Trac #4364). Since the+renamer must decide which expressions depend on which others, and it cannot+reliably do this for arbitrary splices, we used to conservatively say that+splices depend on all other expressions in scope. Unfortunately, this led to+the problem of cyclic type declarations seen in (Trac #4364). Instead, by+running splices in the renamer, we side-step the problem of determining+dependencies: by the time the dependency analysis happens, any splices have+already been run, and expression dependencies can be determined as usual.++However, see (Trac #9813), for an example where we would like to run splices+*after* performing dependency analysis (that is, after renaming). It would be+desirable to typecheck "non-splicy" expressions (those expressions that do not+contain splices directly or via dependence on an expression that does) before+"splicy" expressions, such that types/expressions within the same declaration+group would be available to `reify` calls, for example consider the following:++> module M where+>   data D = C+>   f = 1+>   g = $(mapM reify ['f, 'D, ''C] ...)++Compilation of this example fails since D/C/f are not in the type environment+and thus cannot be reified as they have not been typechecked by the time the+splice is renamed and thus run.++These requirements are at odds: we do not want to run splices in the renamer as+we wish to first determine dependencies and typecheck certain expressions,+making them available to reify, but cannot accurately determine dependencies+without running splices in the renamer!++Indeed, the conclusion of (Trac #9813) was that it is not worth the complexity+to try and+ a) implement and maintain the code for renaming/typechecking non-splicy+    expressions before splicy expressions,+ b) explain to TH users which expressions are/not available to reify at any+    given point.++-}++{- Note [Delaying modFinalizers in untyped splices]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When splices run in the renamer, 'reify' does not have access to the local+type environment (Trac #11832, [1]).++For instance, in++> let x = e in $(reify (mkName "x") >>= runIO . print >> [| return () |])++'reify' cannot find @x@, because the local type environment is not yet+populated. To address this, we allow 'reify' execution to be deferred with+'addModFinalizer'.++> let x = e in $(do addModFinalizer (reify (mkName "x") >>= runIO . print)+                    [| return () |]+                )++The finalizer is run with the local type environment when type checking is+complete.++Since the local type environment is not available in the renamer, we annotate+the tree at the splice point [2] with @HsSpliceE (HsSpliced finalizers e)@ where+@e@ is the result of splicing and @finalizers@ are the finalizers that have been+collected during evaluation of the splice [3]. In our example,++> HsLet+>   (x = e)+>   (HsSpliceE $ HsSpliced [reify (mkName "x") >>= runIO . print]+>                          (HsSplicedExpr $ return ())+>   )++When the typechecker finds the annotation, it inserts the finalizers in the+global environment and exposes the current local environment to them [4, 5, 6].++> addModFinalizersWithLclEnv [reify (mkName "x") >>= runIO . print]++References:++[1] https://ghc.haskell.org/trac/ghc/wiki/TemplateHaskell/Reify+[2] 'rnSpliceExpr'+[3] 'TcSplice.qAddModFinalizer'+[4] 'TcExpr.tcExpr' ('HsSpliceE' ('HsSpliced' ...))+[5] 'TcHsType.tc_hs_type' ('HsSpliceTy' ('HsSpliced' ...))+[6] 'TcPat.tc_pat' ('SplicePat' ('HsSpliced' ...))++-}++----------------------+rnSpliceType :: HsSplice RdrName -> PostTc Name Kind+             -> RnM (HsType Name, FreeVars)+rnSpliceType splice k+  = rnSpliceGen run_type_splice pend_type_splice splice+  where+    pend_type_splice rn_splice+       = (makePending UntypedTypeSplice rn_splice, HsSpliceTy rn_splice k)++    run_type_splice rn_splice+      = do { traceRn "rnSpliceType: untyped type splice" empty+           ; (hs_ty2, mod_finalizers) <-+                runRnSplice UntypedTypeSplice runMetaT ppr rn_splice+           ; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2+                                 ; checkNoErrs $ rnLHsType doc hs_ty2 }+                                    -- checkNoErrs: see Note [Renamer errors]+             -- See Note [Delaying modFinalizers in untyped splices].+           ; return ( HsParTy $ flip HsSpliceTy k+                              . HsSpliced (ThModFinalizers mod_finalizers)+                              . HsSplicedTy <$>+                              hs_ty3+                    , fvs+                    ) }+              -- Wrap the result of the splice in parens so that we don't+              -- lose the outermost location set by runQuasiQuote (#7918)++{- Note [Partial Type Splices]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Partial Type Signatures are partially supported in TH type splices: only+anonymous wild cards are allowed.++  -- ToDo: SLPJ says: I don't understand all this++Normally, named wild cards are collected before renaming a (partial) type+signature. However, TH type splices are run during renaming, i.e. after the+initial traversal, leading to out of scope errors for named wild cards. We+can't just extend the initial traversal to collect the named wild cards in TH+type splices, as we'd need to expand them, which is supposed to happen only+once, during renaming.++Similarly, the extra-constraints wild card is handled right before renaming+too, and is therefore also not supported in a TH type splice. Another reason+to forbid extra-constraints wild cards in TH type splices is that a single+signature can contain many TH type splices, whereas it mustn't contain more+than one extra-constraints wild card. Enforcing would this be hard the way+things are currently organised.++Anonymous wild cards pose no problem, because they start out without names and+are given names during renaming. These names are collected right after+renaming. The names generated for anonymous wild cards in TH type splices will+thus be collected as well.++For more details about renaming wild cards, see RnTypes.rnHsSigWcType++Note that partial type signatures are fully supported in TH declaration+splices, e.g.:++     [d| foo :: _ => _+         foo x y = x == y |]++This is because in this case, the partial type signature can be treated as a+whole signature, instead of as an arbitrary type.++-}+++----------------------+-- | Rename a splice pattern. See Note [rnSplicePat]+rnSplicePat :: HsSplice RdrName -> RnM ( Either (Pat RdrName) (Pat Name)+                                       , FreeVars)+rnSplicePat splice+  = rnSpliceGen run_pat_splice pend_pat_splice splice+  where+    pend_pat_splice rn_splice+      = (makePending UntypedPatSplice rn_splice, Right (SplicePat rn_splice))++    run_pat_splice rn_splice+      = do { traceRn "rnSplicePat: untyped pattern splice" empty+           ; (pat, mod_finalizers) <-+                runRnSplice UntypedPatSplice runMetaP ppr rn_splice+             -- See Note [Delaying modFinalizers in untyped splices].+           ; return ( Left $ ParPat $ SplicePat+                                    . HsSpliced (ThModFinalizers mod_finalizers)+                                    . HsSplicedPat <$>+                                    pat+                    , emptyFVs+                    ) }+              -- Wrap the result of the quasi-quoter in parens so that we don't+              -- lose the outermost location set by runQuasiQuote (#7918)++----------------------+rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars)+rnSpliceDecl (SpliceDecl (L loc splice) flg)+  = rnSpliceGen run_decl_splice pend_decl_splice splice+  where+    pend_decl_splice rn_splice+       = (makePending UntypedDeclSplice rn_splice, SpliceDecl (L loc rn_splice) flg)++    run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice)++rnTopSpliceDecls :: HsSplice RdrName -> RnM ([LHsDecl RdrName], FreeVars)+-- Declaration splice at the very top level of the module+rnTopSpliceDecls splice+   = do  { (rn_splice, fvs) <- checkNoErrs $+                               setStage (Splice Untyped) $+                               rnSplice splice+           -- As always, be sure to checkNoErrs above lest we end up with+           -- holes making it to typechecking, hence #12584.+         ; traceRn "rnTopSpliceDecls: untyped declaration splice" empty+         ; (decls, mod_finalizers) <-+              runRnSplice UntypedDeclSplice runMetaD ppr_decls rn_splice+         ; add_mod_finalizers_now mod_finalizers+         ; return (decls,fvs) }+   where+     ppr_decls :: [LHsDecl RdrName] -> SDoc+     ppr_decls ds = vcat (map ppr ds)++     -- Adds finalizers to the global environment instead of delaying them+     -- to the type checker.+     --+     -- Declaration splices do not have an interesting local environment so+     -- there is no point in delaying them.+     --+     -- See Note [Delaying modFinalizers in untyped splices].+     add_mod_finalizers_now :: [ForeignRef (TH.Q ())] -> TcRn ()+     add_mod_finalizers_now []             = return ()+     add_mod_finalizers_now mod_finalizers = do+       th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv+       updTcRef th_modfinalizers_var $ \fins ->+         runRemoteModFinalizers (ThModFinalizers mod_finalizers) : fins+++{-+Note [rnSplicePat]+~~~~~~~~~~~~~~~~~~+Renaming a pattern splice is a bit tricky, because we need the variables+bound in the pattern to be in scope in the RHS of the pattern. This scope+management is effectively done by using continuation-passing style in+RnPat, through the CpsRn monad. We don't wish to be in that monad here+(it would create import cycles and generally conflict with renaming other+splices), so we really want to return a (Pat RdrName) -- the result of+running the splice -- which can then be further renamed in RnPat, in+the CpsRn monad.++The problem is that if we're renaming a splice within a bracket, we+*don't* want to run the splice now. We really do just want to rename+it to an HsSplice Name. Of course, then we can't know what variables+are bound within the splice. So we accept any unbound variables and+rename them again when the bracket is spliced in.  If a variable is brought+into scope by a pattern splice all is fine.  If it is not then an error is+reported.++In any case, when we're done in rnSplicePat, we'll either have a+Pat RdrName (the result of running a top-level splice) or a Pat Name+(the renamed nested splice). Thus, the awkward return type of+rnSplicePat.+-}++spliceCtxt :: HsSplice RdrName -> SDoc+spliceCtxt splice+  = hang (text "In the" <+> what) 2 (ppr splice)+  where+    what = case splice of+             HsUntypedSplice {} -> text "untyped splice:"+             HsTypedSplice   {} -> text "typed splice:"+             HsQuasiQuote    {} -> text "quasi-quotation:"+             HsSpliced       {} -> text "spliced expression:"++-- | The splice data to be logged+data SpliceInfo+  = SpliceInfo+    { spliceDescription   :: String+    , spliceSource        :: Maybe (LHsExpr Name)  -- Nothing <=> top-level decls+                                                   --        added by addTopDecls+    , spliceIsDecl        :: Bool    -- True <=> put the generate code in a file+                                     --          when -dth-dec-file is on+    , spliceGenerated     :: SDoc+    }+        -- Note that 'spliceSource' is *renamed* but not *typechecked*+        -- Reason (a) less typechecking crap+        --        (b) data constructors after type checking have been+        --            changed to their *wrappers*, and that makes them+        --            print always fully qualified++-- | outputs splice information for 2 flags which have different output formats:+-- `-ddump-splices` and `-dth-dec-file`+traceSplice :: SpliceInfo -> TcM ()+traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src+                        , spliceGenerated = gen, spliceIsDecl = is_decl })+  = do { loc <- case mb_src of+                   Nothing        -> getSrcSpanM+                   Just (L loc _) -> return loc+       ; traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc)++       ; when is_decl $  -- Raw material for -dth-dec-file+         do { dflags <- getDynFlags+            ; liftIO $ dumpIfSet_dyn_printer alwaysQualify dflags Opt_D_th_dec_file+                                             (spliceCodeDoc loc) } }+  where+    -- `-ddump-splices`+    spliceDebugDoc :: SrcSpan -> SDoc+    spliceDebugDoc loc+      = let code = case mb_src of+                     Nothing -> ending+                     Just e  -> nest 2 (ppr e) : ending+            ending = [ text "======>", nest 2 gen ]+        in  hang (ppr loc <> colon <+> text "Splicing" <+> text sd)+               2 (sep code)++    -- `-dth-dec-file`+    spliceCodeDoc :: SrcSpan -> SDoc+    spliceCodeDoc loc+      = vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd+             , gen ]++illegalTypedSplice :: SDoc+illegalTypedSplice = text "Typed splices may not appear in untyped brackets"++illegalUntypedSplice :: SDoc+illegalUntypedSplice = text "Untyped splices may not appear in typed brackets"++checkThLocalName :: Name -> RnM ()+checkThLocalName name+  | isUnboundName name   -- Do not report two errors for+  = return ()            --   $(not_in_scope args)++  | otherwise+  = do  { traceRn "checkThLocalName" (ppr name)+        ; mb_local_use <- getStageAndBindLevel name+        ; case mb_local_use of {+             Nothing -> return () ;  -- Not a locally-bound thing+             Just (top_lvl, bind_lvl, use_stage) ->+    do  { let use_lvl = thLevel use_stage+        ; checkWellStaged (quotes (ppr name)) bind_lvl use_lvl+        ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl+                                               <+> ppr use_stage+                                               <+> ppr use_lvl)+        ; checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name } } }++--------------------------------------+checkCrossStageLifting :: TopLevelFlag -> ThLevel -> ThStage -> ThLevel+                       -> Name -> TcM ()+-- We are inside brackets, and (use_lvl > bind_lvl)+-- Now we must check whether there's a cross-stage lift to do+-- Examples   \x -> [| x |]+--            [| map |]+--+-- This code is similar to checkCrossStageLifting in TcExpr, but+-- this is only run on *untyped* brackets.++checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name+  | Brack _ (RnPendingUntyped ps_var) <- use_stage   -- Only for untyped brackets+  , use_lvl > bind_lvl                               -- Cross-stage condition+  = check_cross_stage_lifting top_lvl name ps_var+  | otherwise+  = return ()++check_cross_stage_lifting :: TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM ()+check_cross_stage_lifting top_lvl name ps_var+  | isTopLevel top_lvl+        -- Top-level identifiers in this module,+        -- (which have External Names)+        -- are just like the imported case:+        -- no need for the 'lifting' treatment+        -- E.g.  this is fine:+        --   f x = x+        --   g y = [| f 3 |]+  = when (isExternalName name) (keepAlive name)+    -- See Note [Keeping things alive for Template Haskell]++  | otherwise+  =     -- Nested identifiers, such as 'x' in+        -- E.g. \x -> [| h x |]+        -- We must behave as if the reference to x was+        --      h $(lift x)+        -- We use 'x' itself as the SplicePointName, used by+        -- the desugarer to stitch it all back together.+        -- If 'x' occurs many times we may get many identical+        -- bindings of the same SplicePointName, but that doesn't+        -- matter, although it's a mite untidy.+    do  { traceRn "checkCrossStageLifting" (ppr name)++          -- Construct the (lift x) expression+        ; let lift_expr   = nlHsApp (nlHsVar liftName) (nlHsVar name)+              pend_splice = PendingRnSplice UntypedExpSplice name lift_expr++          -- Update the pending splices+        ; ps <- readMutVar ps_var+        ; writeMutVar ps_var (pend_splice : ps) }++{-+Note [Keeping things alive for Template Haskell]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  f x = x+1+  g y = [| f 3 |]++Here 'f' is referred to from inside the bracket, which turns into data+and mentions only f's *name*, not 'f' itself. So we need some other+way to keep 'f' alive, lest it get dropped as dead code.  That's what+keepAlive does. It puts it in the keep-alive set, which subsequently+ensures that 'f' stays as a top level binding.++This must be done by the renamer, not the type checker (as of old),+because the type checker doesn't typecheck the body of untyped+brackets (Trac #8540).++A thing can have a bind_lvl of outerLevel, but have an internal name:+   foo = [d| op = 3+             bop = op + 1 |]+Here the bind_lvl of 'op' is (bogusly) outerLevel, even though it is+bound inside a bracket.  That is because we don't even even record+binding levels for top-level things; the binding levels are in the+LocalRdrEnv.++So the occurrence of 'op' in the rhs of 'bop' looks a bit like a+cross-stage thing, but it isn't really.  And in fact we never need+to do anything here for top-level bound things, so all is fine, if+a bit hacky.++For these chaps (which have Internal Names) we don't want to put+them in the keep-alive set.++Note [Quoting names]+~~~~~~~~~~~~~~~~~~~~+A quoted name 'n is a bit like a quoted expression [| n |], except that we+have no cross-stage lifting (c.f. TcExpr.thBrackId).  So, after incrementing+the use-level to account for the brackets, the cases are:++        bind > use                      Error+        bind = use+1                    OK+        bind < use+                Imported things         OK+                Top-level things        OK+                Non-top-level           Error++where 'use' is the binding level of the 'n quote. (So inside the implied+bracket the level would be use+1.)++Examples:++  f 'map        -- OK; also for top-level defns of this module++  \x. f 'x      -- Not ok (bind = 1, use = 1)+                -- (whereas \x. f [| x |] might have been ok, by+                --                               cross-stage lifting++  \y. [| \x. $(f 'y) |] -- Not ok (bind =1, use = 1)++  [| \x. $(f 'x) |]     -- OK (bind = 2, use = 1)+-}
+ rename/RnSplice.hs-boot view
@@ -0,0 +1,17 @@+module RnSplice where++import HsSyn+import TcRnMonad+import RdrName+import Name+import NameSet+import Kind+++rnSpliceType :: HsSplice RdrName   -> PostTc Name Kind+             -> RnM (HsType Name, FreeVars)+rnSplicePat  :: HsSplice RdrName   -> RnM ( Either (Pat RdrName) (Pat Name)+                                          , FreeVars )+rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars)++rnTopSpliceDecls :: HsSplice RdrName -> RnM ([LHsDecl RdrName], FreeVars)
+ rename/RnTypes.hs view
@@ -0,0 +1,1741 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[RnSource]{Main pass of renamer}+-}++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}++module RnTypes (+        -- Type related stuff+        rnHsType, rnLHsType, rnLHsTypes, rnContext,+        rnHsKind, rnLHsKind,+        rnHsSigType, rnHsWcType,+        rnHsSigWcType, rnHsSigWcTypeScoped,+        rnLHsInstType,+        newTyVarNameRn, collectAnonWildCards,+        rnConDeclFields,+        rnLTyVar,++        -- Precence related stuff+        mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,+        checkPrecMatch, checkSectionPrec,++        -- Binding related stuff+        bindLHsTyVarBndr,+        bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames,+        extractFilteredRdrTyVars,+        extractHsTyRdrTyVars, extractHsTysRdrTyVars,+        extractHsTysRdrTyVarsDups, rmDupsInRdrTyVars,+        extractRdrKindSigVars, extractDataDefnKindVars,+        freeKiTyVarsAllVars, freeKiTyVarsKindVars, freeKiTyVarsTypeVars+  ) where++import {-# SOURCE #-} RnSplice( rnSpliceType )++import DynFlags+import HsSyn+import RnHsDoc          ( rnLHsDoc, rnMbLHsDoc )+import RnEnv+import TcRnMonad+import RdrName+import PrelNames+import TysPrim          ( funTyConName )+import TysWiredIn       ( starKindTyConName, unicodeStarKindTyConName )+import Name+import SrcLoc+import NameSet+import FieldLabel++import Util+import BasicTypes       ( compareFixity, funTyFixity, negateFixity,+                          Fixity(..), FixityDirection(..), LexicalFixity(..) )+import Outputable+import FastString+import Maybes+import qualified GHC.LanguageExtensions as LangExt++import Data.List        ( nubBy, partition )+import Control.Monad    ( unless, when )++#include "HsVersions.h"++{-+These type renamers are in a separate module, rather than in (say) RnSource,+to break several loop.++*********************************************************+*                                                       *+           HsSigWcType (i.e with wildcards)+*                                                       *+*********************************************************+-}++rnHsSigWcType :: HsDocContext -> LHsSigWcType RdrName+            -> RnM (LHsSigWcType Name, FreeVars)+rnHsSigWcType doc sig_ty+  = rn_hs_sig_wc_type True doc sig_ty $ \sig_ty' ->+    return (sig_ty', emptyFVs)++rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType RdrName+                    -> (LHsSigWcType Name -> RnM (a, FreeVars))+                    -> RnM (a, FreeVars)+-- Used for+--   - Signatures on binders in a RULE+--   - Pattern type signatures+-- Wildcards are allowed+-- type signatures on binders only allowed with ScopedTypeVariables+rnHsSigWcTypeScoped ctx sig_ty thing_inside+  = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables+       ; checkErr ty_sig_okay (unexpectedTypeSigErr sig_ty)+       ; rn_hs_sig_wc_type False ctx sig_ty thing_inside+       }+    -- False: for pattern type sigs and rules we /do/ want+    --        to bring those type variables into scope+    -- e.g  \ (x :: forall a. a-> b) -> e+    -- Here we do bring 'b' into scope++rn_hs_sig_wc_type :: Bool   -- see rnImplicitBndrs+                  -> HsDocContext+                  -> LHsSigWcType RdrName+                  -> (LHsSigWcType Name -> RnM (a, FreeVars))+                  -> RnM (a, FreeVars)+-- rn_hs_sig_wc_type is used for source-language type signatures+rn_hs_sig_wc_type no_implicit_if_forall ctxt+                  (HsWC { hswc_body = HsIB { hsib_body = hs_ty }})+                  thing_inside+  = do { free_vars <- extractFilteredRdrTyVars hs_ty+       ; (tv_rdrs, nwc_rdrs) <- partition_nwcs free_vars+       ; rnImplicitBndrs no_implicit_if_forall tv_rdrs hs_ty $ \ vars ->+    do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty+       ; let sig_ty' = HsWC { hswc_wcs = wcs, hswc_body = ib_ty' }+             ib_ty'  = mk_implicit_bndrs vars hs_ty' fvs1+       ; (res, fvs2) <- thing_inside sig_ty'+       ; return (res, fvs1 `plusFV` fvs2) } }++rnHsWcType :: HsDocContext -> LHsWcType RdrName -> RnM (LHsWcType Name, FreeVars)+rnHsWcType ctxt (HsWC { hswc_body = hs_ty })+  = do { free_vars <- extractFilteredRdrTyVars hs_ty+       ; (_, nwc_rdrs) <- partition_nwcs free_vars+       ; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty+       ; let sig_ty' = HsWC { hswc_wcs = wcs, hswc_body = hs_ty' }+       ; return (sig_ty', fvs) }++rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType RdrName+         -> RnM ([Name], LHsType Name, FreeVars)+rnWcBody ctxt nwc_rdrs hs_ty+  = do { nwcs <- mapM newLocalBndrRn nwc_rdrs+       ; let env = RTKE { rtke_level = TypeLevel+                        , rtke_what  = RnTypeBody+                        , rtke_nwcs  = mkNameSet nwcs+                        , rtke_ctxt  = ctxt }+       ; (hs_ty', fvs) <- bindLocalNamesFV nwcs $+                          rn_lty env hs_ty+       ; let awcs = collectAnonWildCards hs_ty'+       ; return (nwcs ++ awcs, hs_ty', fvs) }+  where+    rn_lty env (L loc hs_ty)+      = setSrcSpan loc $+        do { (hs_ty', fvs) <- rn_ty env hs_ty+           ; return (L loc hs_ty', fvs) }++    rn_ty :: RnTyKiEnv -> HsType RdrName -> RnM (HsType Name, FreeVars)+    -- A lot of faff just to allow the extra-constraints wildcard to appear+    rn_ty env hs_ty@(HsForAllTy { hst_bndrs = tvs, hst_body = hs_body })+      = bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty)+                           Nothing [] tvs $ \ _ tvs' _ _ ->+        do { (hs_body', fvs) <- rn_lty env hs_body+           ; return (HsForAllTy { hst_bndrs = tvs', hst_body = hs_body' }, fvs) }++    rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt, hst_body = hs_ty })+      | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt+      , L lx (HsWildCardTy wc) <- ignoreParens hs_ctxt_last+      = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1+           ; wc' <- setSrcSpan lx $+                    do { checkExtraConstraintWildCard env wc+                       ; rnAnonWildCard wc }+           ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy wc')]+           ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty+           ; return (HsQualTy { hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' }+                    , fvs1 `plusFV` fvs2) }++      | otherwise+      = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt+           ; (hs_ty', fvs2)   <- rnLHsTyKi env hs_ty+           ; return (HsQualTy { hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' }+                    , fvs1 `plusFV` fvs2) }++    rn_ty env hs_ty = rnHsTyKi env hs_ty++    rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint })+++checkExtraConstraintWildCard :: RnTyKiEnv -> HsWildCardInfo RdrName+                             -> RnM ()+-- Rename the extra-constraint spot in a type signature+--    (blah, _) => type+-- Check that extra-constraints are allowed at all, and+-- if so that it's an anonymous wildcard+checkExtraConstraintWildCard env wc+  = checkWildCard env mb_bad+  where+    mb_bad | not (extraConstraintWildCardsAllowed env)+           = Just (text "Extra-constraint wildcard" <+> quotes (ppr wc)+                   <+> text "not allowed")+           | otherwise+           = Nothing++extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool+extraConstraintWildCardsAllowed env+  = case rtke_ctxt env of+      TypeSigCtx {}       -> True+      ExprWithTySigCtx {} -> True+      _                   -> False++-- | Finds free type and kind variables in a type,+--     without duplicates, and+--     without variables that are already in scope in LocalRdrEnv+--   NB: this includes named wildcards, which look like perfectly+--       ordinary type variables at this point+extractFilteredRdrTyVars :: LHsType RdrName -> RnM FreeKiTyVars+extractFilteredRdrTyVars hs_ty+  = do { rdr_env <- getLocalRdrEnv+       ; filterInScope rdr_env <$> extractHsTyRdrTyVars hs_ty }++-- | When the NamedWildCards extension is enabled, partition_nwcs+-- removes type variables that start with an underscore from the+-- FreeKiTyVars in the argument and returns them in a separate list.+-- When the extension is disabled, the function returns the argument+-- and empty list.  See Note [Renaming named wild cards]+partition_nwcs :: FreeKiTyVars -> RnM (FreeKiTyVars, [Located RdrName])+partition_nwcs free_vars@(FKTV { fktv_tys = tys })+  = do { wildcards_enabled <- fmap (xopt LangExt.NamedWildCards) getDynFlags+       ; let (nwcs, no_nwcs) | wildcards_enabled = partition is_wildcard tys+                             | otherwise         = ([], tys)+             free_vars' = free_vars { fktv_tys = no_nwcs }+       ; return (free_vars', nwcs) }+  where+     is_wildcard :: Located RdrName -> Bool+     is_wildcard rdr = startsWithUnderscore (rdrNameOcc (unLoc rdr))++{- Note [Renaming named wild cards]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Identifiers starting with an underscore are always parsed as type variables.+It is only here in the renamer that we give the special treatment.+See Note [The wildcard story for types] in HsTypes.++It's easy!  When we collect the implicitly bound type variables, ready+to bring them into scope, and NamedWildCards is on, we partition the+variables into the ones that start with an underscore (the named+wildcards) and the rest. Then we just add them to the hswc_wcs field+of the HsWildCardBndrs structure, and we are done.+++*********************************************************+*                                                       *+           HsSigtype (i.e. no wildcards)+*                                                       *+****************************************************** -}++rnHsSigType :: HsDocContext -> LHsSigType RdrName+            -> RnM (LHsSigType Name, FreeVars)+-- Used for source-language type signatures+-- that cannot have wildcards+rnHsSigType ctx (HsIB { hsib_body = hs_ty })+  = do { vars <- extractFilteredRdrTyVars hs_ty+       ; rnImplicitBndrs True vars hs_ty $ \ vars ->+    do { (body', fvs) <- rnLHsType ctx hs_ty+       ; return ( mk_implicit_bndrs vars body' fvs, fvs ) } }++rnImplicitBndrs :: Bool    -- True <=> no implicit quantification+                           --          if type is headed by a forall+                           -- E.g.  f :: forall a. a->b+                           -- Do not quantify over 'b' too.+                -> FreeKiTyVars+                -> LHsType RdrName+                -> ([Name] -> RnM (a, FreeVars))+                -> RnM (a, FreeVars)+rnImplicitBndrs no_implicit_if_forall free_vars hs_ty@(L loc _) thing_inside+  = do { let real_tv_rdrs  -- Implicit quantification only if+                           -- there is no explicit forall+               | no_implicit_if_forall+               , L _ (HsForAllTy {}) <- hs_ty = []+               | otherwise                    = freeKiTyVarsTypeVars free_vars+             real_rdrs = freeKiTyVarsKindVars free_vars ++ real_tv_rdrs+       ; traceRn "rnSigType" (ppr hs_ty $$ ppr free_vars $$+                                        ppr real_rdrs)++       ; traceRn "" (text "rnSigType2" <+> ppr hs_ty $$ ppr free_vars $$+                                        ppr real_rdrs)+       ; vars <- mapM (newLocalBndrRn . L loc . unLoc) real_rdrs+       ; bindLocalNamesFV vars $+         thing_inside vars }++rnLHsInstType :: SDoc -> LHsSigType RdrName -> RnM (LHsSigType Name, FreeVars)+-- Rename the type in an instance or standalone deriving decl+-- The 'doc_str' is "an instance declaration" or "a VECTORISE pragma"+rnLHsInstType doc_str inst_ty+  | Just cls <- getLHsInstDeclClass_maybe inst_ty+  , isTcOcc (rdrNameOcc (unLoc cls))+         -- The guards check that the instance type looks like+         --   blah => C ty1 .. tyn+  = do { let full_doc = doc_str <+> text "for" <+> quotes (ppr cls)+       ; rnHsSigType (GenericCtx full_doc) inst_ty }++  | otherwise  -- The instance is malformed, but we'd still like+               -- to make progress rather than failing outright, so+               -- we report more errors.  So we rename it anyway.+  = do { addErrAt (getLoc (hsSigType inst_ty)) $+         text "Malformed instance:" <+> ppr inst_ty+       ; rnHsSigType (GenericCtx doc_str) inst_ty }++mk_implicit_bndrs :: [Name]      -- implicitly bound+                  -> a           -- payload+                  -> FreeVars    -- FreeVars of payload+                  -> HsImplicitBndrs Name a+mk_implicit_bndrs vars body fvs+  = HsIB { hsib_vars = vars+         , hsib_body = body+         , hsib_closed = nameSetAll (not . isTyVarName) (vars `delFVs` fvs) }+++{- ******************************************************+*                                                       *+           LHsType and HsType+*                                                       *+****************************************************** -}++{-+rnHsType is here because we call it from loadInstDecl, and I didn't+want a gratuitous knot.++Note [Context quantification]+-----------------------------+Variables in type signatures are implicitly quantified+when (1) they are in a type signature not beginning+with "forall" or (2) in any qualified type T => R.+We are phasing out (2) since it leads to inconsistencies+(Trac #4426):++data A = A (a -> a)           is an error+data A = A (Eq a => a -> a)   binds "a"+data A = A (Eq a => a -> b)   binds "a" and "b"+data A = A (() => a -> b)     binds "a" and "b"+f :: forall a. a -> b         is an error+f :: forall a. () => a -> b   is an error+f :: forall a. a -> (() => b) binds "a" and "b"++This situation is now considered to be an error. See rnHsTyKi for case+HsForAllTy Qualified.++Note [Dealing with *]+~~~~~~~~~~~~~~~~~~~~~+As a legacy from the days when types and kinds were different, we use+the type * to mean what we now call GHC.Types.Type. The problem is that+* should associate just like an identifier, *not* a symbol.+Running example: the user has written++  T (Int, Bool) b + c * d++At this point, we have a bunch of stretches of types++  [[T, (Int, Bool), b], [c], [d]]++these are the [[LHsType Name]] and a bunch of operators++  [GHC.TypeLits.+, GHC.Types.*]++Note that the * is GHC.Types.*. So, we want to rearrange to have++  [[T, (Int, Bool), b], [c, *, d]]++and++  [GHC.TypeLits.+]++as our lists. We can then do normal fixity resolution on these. The fixities+must come along for the ride just so that the list stays in sync with the+operators.++Note [QualTy in kinds]+~~~~~~~~~~~~~~~~~~~~~~+I was wondering whether QualTy could occur only at TypeLevel.  But no,+we can have a qualified type in a kind too. Here is an example:++  type family F a where+    F Bool = Nat+    F Nat  = Type++  type family G a where+    G Type = Type -> Type+    G ()   = Nat++  data X :: forall k1 k2. (F k1 ~ G k2) => k1 -> k2 -> Type where+    MkX :: X 'True '()++See that k1 becomes Bool and k2 becomes (), so the equality is+satisfied. If I write MkX :: X 'True 'False, compilation fails with a+suitable message:++  MkX :: X 'True '()+    • Couldn't match kind ‘G Bool’ with ‘Nat’+      Expected kind: G Bool+        Actual kind: F Bool++However: in a kind, the constraints in the QualTy must all be+equalities; or at least, any kinds with a class constraint are+uninhabited.+-}++data RnTyKiEnv+  = RTKE { rtke_ctxt  :: HsDocContext+         , rtke_level :: TypeOrKind  -- Am I renaming a type or a kind?+         , rtke_what  :: RnTyKiWhat  -- And within that what am I renaming?+         , rtke_nwcs  :: NameSet     -- These are the in-scope named wildcards+    }++data RnTyKiWhat = RnTypeBody+                | RnTopConstraint   -- Top-level context of HsSigWcTypes+                | RnConstraint      -- All other constraints++instance Outputable RnTyKiEnv where+  ppr (RTKE { rtke_level = lev, rtke_what = what+            , rtke_nwcs = wcs, rtke_ctxt = ctxt })+    = text "RTKE"+      <+> braces (sep [ ppr lev, ppr what, ppr wcs+                      , pprHsDocContext ctxt ])++instance Outputable RnTyKiWhat where+  ppr RnTypeBody      = text "RnTypeBody"+  ppr RnTopConstraint = text "RnTopConstraint"+  ppr RnConstraint    = text "RnConstraint"++mkTyKiEnv :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv+mkTyKiEnv cxt level what+ = RTKE { rtke_level = level, rtke_nwcs = emptyNameSet+        , rtke_what = what, rtke_ctxt = cxt }++isRnKindLevel :: RnTyKiEnv -> Bool+isRnKindLevel (RTKE { rtke_level = KindLevel }) = True+isRnKindLevel _                                 = False++--------------+rnLHsType  :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)+rnLHsType ctxt ty = rnLHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty++rnLHsTypes :: HsDocContext -> [LHsType RdrName] -> RnM ([LHsType Name], FreeVars)+rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys++rnHsType  :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)+rnHsType ctxt ty = rnHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty++rnLHsKind  :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars)+rnLHsKind ctxt kind = rnLHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind++rnHsKind  :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name, FreeVars)+rnHsKind ctxt kind = rnHsTyKi  (mkTyKiEnv ctxt KindLevel RnTypeBody) kind++--------------+rnTyKiContext :: RnTyKiEnv -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)+rnTyKiContext env (L loc cxt)+  = do { traceRn "rncontext" (ppr cxt)+       ; let env' = env { rtke_what = RnConstraint }+       ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt+       ; return (L loc cxt', fvs) }++rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)+rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta++--------------+rnLHsTyKi  :: RnTyKiEnv -> LHsType RdrName -> RnM (LHsType Name, FreeVars)+rnLHsTyKi env (L loc ty)+  = setSrcSpan loc $+    do { (ty', fvs) <- rnHsTyKi env ty+       ; return (L loc ty', fvs) }++rnHsTyKi :: RnTyKiEnv -> HsType RdrName -> RnM (HsType Name, FreeVars)++rnHsTyKi env ty@(HsForAllTy { hst_bndrs = tyvars, hst_body  = tau })+  = do { checkTypeInType env ty+       ; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty)+                           Nothing [] tyvars $ \ _ tyvars' _ _ ->+    do { (tau',  fvs) <- rnLHsTyKi env tau+       ; return ( HsForAllTy { hst_bndrs = tyvars', hst_body =  tau' }+                , fvs) } }++rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau })+  = do { checkTypeInType env ty  -- See Note [QualTy in kinds]+       ; (ctxt', fvs1) <- rnTyKiContext env lctxt+       ; (tau',  fvs2) <- rnLHsTyKi env tau+       ; return (HsQualTy { hst_ctxt = ctxt', hst_body =  tau' }+                , fvs1 `plusFV` fvs2) }++rnHsTyKi env (HsTyVar ip (L loc rdr_name))+  = do { name <- rnTyVar env rdr_name+       ; return (HsTyVar ip (L loc name), unitFV name) }++rnHsTyKi env ty@(HsOpTy ty1 l_op ty2)+  = setSrcSpan (getLoc l_op) $+    do  { (l_op', fvs1) <- rnHsTyOp env ty l_op+        ; fix   <- lookupTyFixityRn l_op'+        ; (ty1', fvs2) <- rnLHsTyKi env ty1+        ; (ty2', fvs3) <- rnLHsTyKi env ty2+        ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2)+                               (unLoc l_op') fix ty1' ty2'+        ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) }++rnHsTyKi env (HsParTy ty)+  = do { (ty', fvs) <- rnLHsTyKi env ty+       ; return (HsParTy ty', fvs) }++rnHsTyKi env (HsBangTy b ty)+  = do { (ty', fvs) <- rnLHsTyKi env ty+       ; return (HsBangTy b ty', fvs) }++rnHsTyKi env ty@(HsRecTy flds)+  = do { let ctxt = rtke_ctxt env+       ; fls          <- get_fields ctxt+       ; (flds', fvs) <- rnConDeclFields ctxt fls flds+       ; return (HsRecTy flds', fvs) }+  where+    get_fields (ConDeclCtx names)+      = concatMapM (lookupConstructorFields . unLoc) names+    get_fields _+      = do { addErr (hang (text "Record syntax is illegal here:")+                                   2 (ppr ty))+           ; return [] }++rnHsTyKi env (HsFunTy ty1 ty2)+  = do { (ty1', fvs1) <- rnLHsTyKi env ty1+        -- Might find a for-all as the arg of a function type+       ; (ty2', fvs2) <- rnLHsTyKi env ty2+        -- Or as the result.  This happens when reading Prelude.hi+        -- when we find return :: forall m. Monad m -> forall a. a -> m a++        -- Check for fixity rearrangements+       ; res_ty <- mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'+       ; return (res_ty, fvs1 `plusFV` fvs2) }++rnHsTyKi env listTy@(HsListTy ty)+  = do { data_kinds <- xoptM LangExt.DataKinds+       ; when (not data_kinds && isRnKindLevel env)+              (addErr (dataKindsErr env listTy))+       ; (ty', fvs) <- rnLHsTyKi env ty+       ; return (HsListTy ty', fvs) }++rnHsTyKi env t@(HsKindSig ty k)+  = do { checkTypeInType env t+       ; kind_sigs_ok <- xoptM LangExt.KindSignatures+       ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty)+       ; (ty', fvs1) <- rnLHsTyKi env ty+       ; (k', fvs2)  <- rnLHsTyKi (env { rtke_level = KindLevel }) k+       ; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) }++rnHsTyKi env t@(HsPArrTy ty)+  = do { notInKinds env t+       ; (ty', fvs) <- rnLHsTyKi env ty+       ; return (HsPArrTy ty', fvs) }++-- Unboxed tuples are allowed to have poly-typed arguments.  These+-- sometimes crop up as a result of CPR worker-wrappering dictionaries.+rnHsTyKi env tupleTy@(HsTupleTy tup_con tys)+  = do { data_kinds <- xoptM LangExt.DataKinds+       ; when (not data_kinds && isRnKindLevel env)+              (addErr (dataKindsErr env tupleTy))+       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys+       ; return (HsTupleTy tup_con tys', fvs) }++rnHsTyKi env sumTy@(HsSumTy tys)+  = do { data_kinds <- xoptM LangExt.DataKinds+       ; when (not data_kinds && isRnKindLevel env)+              (addErr (dataKindsErr env sumTy))+       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys+       ; return (HsSumTy tys', fvs) }++-- Ensure that a type-level integer is nonnegative (#8306, #8412)+rnHsTyKi env tyLit@(HsTyLit t)+  = do { data_kinds <- xoptM LangExt.DataKinds+       ; unless data_kinds (addErr (dataKindsErr env tyLit))+       ; when (negLit t) (addErr negLitErr)+       ; checkTypeInType env tyLit+       ; return (HsTyLit t, emptyFVs) }+  where+    negLit (HsStrTy _ _) = False+    negLit (HsNumTy _ i) = i < 0+    negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit++rnHsTyKi env overall_ty@(HsAppsTy tys)+  = do { -- Step 1: Break up the HsAppsTy into symbols and non-symbol regions+         let (non_syms, syms) = splitHsAppsTy tys++             -- Step 2: rename the pieces+       ; (syms1, fvs1)      <- mapFvRn (rnHsTyOp env overall_ty) syms+       ; (non_syms1, fvs2)  <- (mapFvRn . mapFvRn) (rnLHsTyKi env) non_syms++             -- Step 3: deal with *. See Note [Dealing with *]+       ; let (non_syms2, syms2) = deal_with_star [] [] non_syms1 syms1++             -- Step 4: collapse the non-symbol regions with HsAppTy+       ; non_syms3 <- mapM deal_with_non_syms non_syms2++             -- Step 5: assemble the pieces, using mkHsOpTyRn+       ; L _ res_ty <- build_res_ty non_syms3 syms2++        -- all done. Phew.+       ; return (res_ty, fvs1 `plusFV` fvs2) }+  where+    -- See Note [Dealing with *]+    deal_with_star :: [[LHsType Name]] -> [Located Name]+                   -> [[LHsType Name]] -> [Located Name]+                   -> ([[LHsType Name]], [Located Name])+    deal_with_star acc1 acc2+                   (non_syms1 : non_syms2 : non_syms) (L loc star : ops)+      | star `hasKey` starKindTyConKey || star `hasKey` unicodeStarKindTyConKey+      = deal_with_star acc1 acc2+                       ((non_syms1 ++ L loc (HsTyVar NotPromoted (L loc star))+                            : non_syms2) : non_syms)+                       ops+    deal_with_star acc1 acc2 (non_syms1 : non_syms) (op1 : ops)+      = deal_with_star (non_syms1 : acc1) (op1 : acc2) non_syms ops+    deal_with_star acc1 acc2 [non_syms] []+      = (reverse (non_syms : acc1), reverse acc2)+    deal_with_star _ _ _ _+      = pprPanic "deal_with_star" (ppr overall_ty)++    -- collapse [LHsType Name] to LHsType Name by making applications+    -- monadic only for failure+    deal_with_non_syms :: [LHsType Name] -> RnM (LHsType Name)+    deal_with_non_syms (non_sym : non_syms) = return $ mkHsAppTys non_sym non_syms+    deal_with_non_syms []                   = failWith (emptyNonSymsErr overall_ty)++    -- assemble a right-biased OpTy for use in mkHsOpTyRn+    build_res_ty :: [LHsType Name] -> [Located Name] -> RnM (LHsType Name)+    build_res_ty (arg1 : args) (op1 : ops)+      = do { rhs <- build_res_ty args ops+           ; fix <- lookupTyFixityRn op1+           ; res <-+               mkHsOpTyRn (\t1 t2 -> HsOpTy t1 op1 t2) (unLoc op1) fix arg1 rhs+           ; let loc = combineSrcSpans (getLoc arg1) (getLoc rhs)+           ; return (L loc res)+           }+    build_res_ty [arg] [] = return arg+    build_res_ty _ _ = pprPanic "build_op_ty" (ppr overall_ty)++rnHsTyKi env (HsAppTy ty1 ty2)+  = do { (ty1', fvs1) <- rnLHsTyKi env ty1+       ; (ty2', fvs2) <- rnLHsTyKi env ty2+       ; return (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) }++rnHsTyKi env t@(HsIParamTy n ty)+  = do { notInKinds env t+       ; (ty', fvs) <- rnLHsTyKi env ty+       ; return (HsIParamTy n ty', fvs) }++rnHsTyKi env t@(HsEqTy ty1 ty2)+  = do { checkTypeInType env t+       ; (ty1', fvs1) <- rnLHsTyKi env ty1+       ; (ty2', fvs2) <- rnLHsTyKi env ty2+       ; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) }++rnHsTyKi _ (HsSpliceTy sp k)+  = rnSpliceType sp k++rnHsTyKi env (HsDocTy ty haddock_doc)+  = do { (ty', fvs) <- rnLHsTyKi env ty+       ; haddock_doc' <- rnLHsDoc haddock_doc+       ; return (HsDocTy ty' haddock_doc', fvs) }++rnHsTyKi _ (HsCoreTy ty)+  = return (HsCoreTy ty, emptyFVs)+    -- The emptyFVs probably isn't quite right+    -- but I don't think it matters++rnHsTyKi env ty@(HsExplicitListTy ip k tys)+  = do { checkTypeInType env ty+       ; data_kinds <- xoptM LangExt.DataKinds+       ; unless data_kinds (addErr (dataKindsErr env ty))+       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys+       ; return (HsExplicitListTy ip k tys', fvs) }++rnHsTyKi env ty@(HsExplicitTupleTy kis tys)+  = do { checkTypeInType env ty+       ; data_kinds <- xoptM LangExt.DataKinds+       ; unless data_kinds (addErr (dataKindsErr env ty))+       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys+       ; return (HsExplicitTupleTy kis tys', fvs) }++rnHsTyKi env (HsWildCardTy wc)+  = do { checkAnonWildCard env wc+       ; wc' <- rnAnonWildCard wc+       ; return (HsWildCardTy wc', emptyFVs) }+         -- emptyFVs: this occurrence does not refer to a+         --           user-written binding site, so don't treat+         --           it as a free variable++--------------+rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name+rnTyVar env rdr_name+  = do { name <- if   isRnKindLevel env+                 then lookupKindOccRn rdr_name+                 else lookupTypeOccRn rdr_name+       ; checkNamedWildCard env name+       ; return name }++rnLTyVar :: Located RdrName -> RnM (Located Name)+-- Called externally; does not deal with wildards+rnLTyVar (L loc rdr_name)+  = do { tyvar <- lookupTypeOccRn rdr_name+       ; return (L loc tyvar) }++--------------+rnHsTyOp :: Outputable a+         => RnTyKiEnv -> a -> Located RdrName -> RnM (Located Name, FreeVars)+rnHsTyOp env overall_ty (L loc op)+  = do { ops_ok <- xoptM LangExt.TypeOperators+       ; op' <- rnTyVar env op+       ; unless (ops_ok+                 || op' == starKindTyConName+                 || op' == unicodeStarKindTyConName+                 || op' `hasKey` eqTyConKey) $+           addErr (opTyErr op overall_ty)+       ; let l_op' = L loc op'+       ; return (l_op', unitFV op') }++--------------+notAllowed :: SDoc -> SDoc+notAllowed doc+  = text "Wildcard" <+> quotes doc <+> ptext (sLit "not allowed")++checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM ()+checkWildCard env (Just doc)+  = addErr $ vcat [doc, nest 2 (text "in" <+> pprHsDocContext (rtke_ctxt env))]+checkWildCard _ Nothing+  = return ()++checkAnonWildCard :: RnTyKiEnv -> HsWildCardInfo RdrName -> RnM ()+-- Report an error if an anonymoous wildcard is illegal here+checkAnonWildCard env wc+  = checkWildCard env mb_bad+  where+    mb_bad :: Maybe SDoc+    mb_bad | not (wildCardsAllowed env)+           = Just (notAllowed (ppr wc))+           | otherwise+           = case rtke_what env of+               RnTypeBody      -> Nothing+               RnConstraint    -> Just constraint_msg+               RnTopConstraint -> Just constraint_msg++    constraint_msg = hang (notAllowed (ppr wc) <+> text "in a constraint")+                        2 hint_msg+    hint_msg = vcat [ text "except as the last top-level constraint of a type signature"+                    , nest 2 (text "e.g  f :: (Eq a, _) => blah") ]++checkNamedWildCard :: RnTyKiEnv -> Name -> RnM ()+-- Report an error if a named wildcard is illegal here+checkNamedWildCard env name+  = checkWildCard env mb_bad+  where+    mb_bad | not (name `elemNameSet` rtke_nwcs env)+           = Nothing  -- Not a wildcard+           | not (wildCardsAllowed env)+           = Just (notAllowed (ppr name))+           | otherwise+           = case rtke_what env of+               RnTypeBody      -> Nothing   -- Allowed+               RnTopConstraint -> Nothing   -- Allowed+               RnConstraint    -> Just constraint_msg+    constraint_msg = notAllowed (ppr name) <+> text "in a constraint"++wildCardsAllowed :: RnTyKiEnv -> Bool+-- ^ In what contexts are wildcards permitted+wildCardsAllowed env+   = case rtke_ctxt env of+       TypeSigCtx {}       -> True+       TypBrCtx {}         -> True   -- Template Haskell quoted type+       SpliceTypeCtx {}    -> True   -- Result of a Template Haskell splice+       ExprWithTySigCtx {} -> True+       PatCtx {}           -> True+       RuleCtx {}          -> True+       FamPatCtx {}        -> True   -- Not named wildcards though+       GHCiCtx {}          -> True+       HsTypeCtx {}        -> True+       _                   -> False++rnAnonWildCard :: HsWildCardInfo RdrName -> RnM (HsWildCardInfo Name)+rnAnonWildCard (AnonWildCard _)+  = do { loc <- getSrcSpanM+       ; uniq <- newUnique+       ; let name = mkInternalName uniq (mkTyVarOcc "_") loc+       ; return (AnonWildCard (L loc name)) }++---------------+-- | Ensures either that we're in a type or that -XTypeInType is set+checkTypeInType :: Outputable ty+                => RnTyKiEnv+                -> ty      -- ^ type+                -> RnM ()+checkTypeInType env ty+  | isRnKindLevel env+  = do { type_in_type <- xoptM LangExt.TypeInType+       ; unless type_in_type $+         addErr (text "Illegal kind:" <+> ppr ty $$+                 text "Did you mean to enable TypeInType?") }+checkTypeInType _ _ = return ()++notInKinds :: Outputable ty+           => RnTyKiEnv+           -> ty+           -> RnM ()+notInKinds env ty+  | isRnKindLevel env+  = addErr (text "Illegal kind (even with TypeInType enabled):" <+> ppr ty)+notInKinds _ _ = return ()++{- *****************************************************+*                                                      *+          Binding type variables+*                                                      *+***************************************************** -}++bindSigTyVarsFV :: [Name]+                -> RnM (a, FreeVars)+                -> RnM (a, FreeVars)+-- Used just before renaming the defn of a function+-- with a separate type signature, to bring its tyvars into scope+-- With no -XScopedTypeVariables, this is a no-op+bindSigTyVarsFV tvs thing_inside+  = do  { scoped_tyvars <- xoptM LangExt.ScopedTypeVariables+        ; if not scoped_tyvars then+                thing_inside+          else+                bindLocalNamesFV tvs thing_inside }++-- | Simply bring a bunch of RdrNames into scope. No checking for+-- validity, at all. The binding location is taken from the location+-- on each name.+bindLRdrNames :: [Located RdrName]+              -> ([Name] -> RnM (a, FreeVars))+              -> RnM (a, FreeVars)+bindLRdrNames rdrs thing_inside+  = do { var_names <- mapM (newTyVarNameRn Nothing) rdrs+       ; bindLocalNamesFV var_names $+         thing_inside var_names }++---------------+bindHsQTyVars :: forall a b.+                 HsDocContext+              -> Maybe SDoc         -- if we are to check for unused tvs,+                                    -- a phrase like "in the type ..."+              -> Maybe a                 -- Just _  => an associated type decl+              -> [Located RdrName]       -- Kind variables from scope, in l-to-r+                                         -- order, but not from ...+              -> (LHsQTyVars RdrName)     -- ... these user-written tyvars+              -> (LHsQTyVars Name -> NameSet -> RnM (b, FreeVars))+                  -- also returns all names used in kind signatures, for the+                  -- TypeInType clause of Note [Complete user-supplied kind+                  -- signatures] in HsDecls+              -> RnM (b, FreeVars)+-- (a) Bring kind variables into scope+--     both (i)  passed in (kv_bndrs)+--     and  (ii) mentioned in the kinds of tv_bndrs+-- (b) Bring type variables into scope+bindHsQTyVars doc mb_in_doc mb_assoc kv_bndrs tv_bndrs thing_inside+  = do { bindLHsTyVarBndrs doc mb_in_doc+                           mb_assoc kv_bndrs (hsQTvExplicit tv_bndrs) $+         \ rn_kvs rn_bndrs dep_var_set all_dep_vars ->+         thing_inside (HsQTvs { hsq_implicit = rn_kvs+                              , hsq_explicit = rn_bndrs+                              , hsq_dependent = dep_var_set }) all_dep_vars }++bindLHsTyVarBndrs :: forall a b.+                     HsDocContext+                  -> Maybe SDoc         -- if we are to check for unused tvs,+                                        -- a phrase like "in the type ..."+                  -> Maybe a            -- Just _  => an associated type decl+                  -> [Located RdrName]  -- Unbound kind variables from scope,+                                        -- in l-to-r order, but not from ...+                  -> [LHsTyVarBndr RdrName]  -- ... these user-written tyvars+                  -> (   [Name]  -- all kv names+                      -> [LHsTyVarBndr Name]+                      -> NameSet -- which names, from the preceding list,+                                 -- are used dependently within that list+                                 -- See Note [Dependent LHsQTyVars] in TcHsType+                      -> NameSet -- all names used in kind signatures+                      -> RnM (b, FreeVars))+                  -> RnM (b, FreeVars)+bindLHsTyVarBndrs doc mb_in_doc mb_assoc kv_bndrs tv_bndrs thing_inside+  = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)+       ; go [] [] emptyNameSet emptyNameSet emptyNameSet tv_bndrs }+  where+    tv_names_w_loc = map hsLTyVarLocName tv_bndrs++    go :: [Name]                 -- kind-vars found (in reverse order)+       -> [LHsTyVarBndr Name]    -- already renamed (in reverse order)+       -> NameSet                -- kind vars already in scope (for dup checking)+       -> NameSet                -- type vars already in scope (for dup checking)+       -> NameSet                -- (all) variables used dependently+       -> [LHsTyVarBndr RdrName] -- still to be renamed, scoped+       -> RnM (b, FreeVars)+    go rn_kvs rn_tvs kv_names tv_names dep_vars (tv_bndr : tv_bndrs)+      = bindLHsTyVarBndr doc mb_assoc kv_names tv_names tv_bndr $+        \ kv_nms used_dependently tv_bndr' ->+        do { (b, fvs) <- go (reverse kv_nms ++ rn_kvs)+                            (tv_bndr' : rn_tvs)+                            (kv_names `extendNameSetList` kv_nms)+                            (tv_names `extendNameSet` hsLTyVarName tv_bndr')+                            (dep_vars `unionNameSet` used_dependently)+                            tv_bndrs+           ; warn_unused tv_bndr' fvs+           ; return (b, fvs) }++    go rn_kvs rn_tvs _kv_names tv_names dep_vars []+      = -- still need to deal with the kv_bndrs passed in originally+        bindImplicitKvs doc mb_assoc kv_bndrs tv_names $ \ kv_nms others ->+        do { let all_rn_kvs = reverse (reverse kv_nms ++ rn_kvs)+                 all_rn_tvs = reverse rn_tvs+           ; env <- getLocalRdrEnv+           ; let all_dep_vars = dep_vars `unionNameSet` others+                 exp_dep_vars -- variables in all_rn_tvs that are in dep_vars+                   = mkNameSet [ name+                               | v <- all_rn_tvs+                               , let name = hsLTyVarName v+                               , name `elemNameSet` all_dep_vars ]+           ; traceRn "bindHsTyVars" (ppr env $$+                                     ppr all_rn_kvs $$+                                     ppr all_rn_tvs $$+                                     ppr exp_dep_vars)+           ; thing_inside all_rn_kvs all_rn_tvs exp_dep_vars all_dep_vars }++    warn_unused tv_bndr fvs = case mb_in_doc of+      Just in_doc -> warnUnusedForAll in_doc tv_bndr fvs+      Nothing     -> return ()++bindLHsTyVarBndr :: HsDocContext+                 -> Maybe a   -- associated class+                 -> NameSet   -- kind vars already in scope+                 -> NameSet   -- type vars already in scope+                 -> LHsTyVarBndr RdrName+                 -> ([Name] -> NameSet -> LHsTyVarBndr Name -> RnM (b, FreeVars))+                   -- passed the newly-bound implicitly-declared kind vars,+                   -- any other names used in a kind+                   -- and the renamed LHsTyVarBndr+                 -> RnM (b, FreeVars)+bindLHsTyVarBndr doc mb_assoc kv_names tv_names hs_tv_bndr thing_inside+  = case hs_tv_bndr of+      L loc (UserTyVar lrdr@(L lv rdr)) ->+        do { check_dup loc rdr []+           ; nm <- newTyVarNameRn mb_assoc lrdr+           ; bindLocalNamesFV [nm] $+             thing_inside [] emptyNameSet (L loc (UserTyVar (L lv nm))) }+      L loc (KindedTyVar lrdr@(L lv rdr) kind) ->+        do { free_kvs <- freeKiTyVarsAllVars <$> extractHsTyRdrTyVars kind+           ; check_dup lv rdr (map unLoc free_kvs)++             -- check for -XKindSignatures+           ; sig_ok <- xoptM LangExt.KindSignatures+           ; unless sig_ok (badKindSigErr doc kind)++             -- deal with kind vars in the user-written kind+           ; bindImplicitKvs doc mb_assoc free_kvs tv_names $+             \ new_kv_nms other_kv_nms ->+             do { (kind', fvs1) <- rnLHsKind doc kind+                ; tv_nm  <- newTyVarNameRn mb_assoc lrdr+                ; (b, fvs2) <- bindLocalNamesFV [tv_nm] $+                               thing_inside new_kv_nms other_kv_nms+                                 (L loc (KindedTyVar (L lv tv_nm) kind'))+                ; return (b, fvs1 `plusFV` fvs2) }}+  where+      -- make sure that the RdrName isn't in the sets of+      -- names. We can't just check that it's not in scope at all+      -- because we might be inside an associated class.+    check_dup :: SrcSpan -> RdrName -> [RdrName] -> RnM ()+    check_dup loc rdr kindFreeVars+      = do { -- Disallow use of a type variable name in its+             -- kind signature (#11592).+             when (rdr `elem` kindFreeVars) $+             addErrAt loc (vcat [ ki_ty_self_err rdr+                                , pprHsDocContext doc ])++           ; m_name <- lookupLocalOccRn_maybe rdr+           ; whenIsJust m_name $ \name ->+        do { when (name `elemNameSet` kv_names) $+             addErrAt loc (vcat [ ki_ty_err_msg name+                                , pprHsDocContext doc ])+           ; when (name `elemNameSet` tv_names) $+             dupNamesErr getLoc [L loc name, L (nameSrcSpan name) name] }}++    ki_ty_err_msg n = text "Variable" <+> quotes (ppr n) <+>+                      text "used as a kind variable before being bound" $$+                      text "as a type variable. Perhaps reorder your variables?"++    ki_ty_self_err n = text "Variable" <+> quotes (ppr n) <+>+                       text "is used in the kind signature of its" $$+                       text "declaration as a type variable."+++bindImplicitKvs :: HsDocContext+                -> Maybe a+                -> [Located RdrName]  -- ^ kind var *occurrences*, from which+                                      -- intent to bind is inferred+                -> NameSet            -- ^ *type* variables, for type/kind+                                      -- misuse check for -XNoTypeInType+                -> ([Name] -> NameSet -> RnM (b, FreeVars))+                   -- ^ passed new kv_names, and any other names used in a kind+                -> RnM (b, FreeVars)+bindImplicitKvs _   _        []       _        thing_inside+  = thing_inside [] emptyNameSet+bindImplicitKvs doc mb_assoc free_kvs tv_names thing_inside+  = do { rdr_env <- getLocalRdrEnv+       ; let part_kvs lrdr@(L loc kv_rdr)+               = case lookupLocalRdrEnv rdr_env kv_rdr of+                   Just kv_name -> Left (L loc kv_name)+                   _            -> Right lrdr+             (bound_kvs, new_kvs) = partitionWith part_kvs free_kvs++          -- check whether we're mixing types & kinds illegally+       ; type_in_type <- xoptM LangExt.TypeInType+       ; unless type_in_type $+         mapM_ (check_tv_used_in_kind tv_names) bound_kvs++       ; poly_kinds <- xoptM LangExt.PolyKinds+       ; unless poly_kinds $+         addErr (badKindBndrs doc new_kvs)++          -- bind the vars and move on+       ; kv_nms <- mapM (newTyVarNameRn mb_assoc) new_kvs+       ; bindLocalNamesFV kv_nms $+         thing_inside kv_nms (mkNameSet (map unLoc bound_kvs)) }+  where+      -- check to see if the variables free in a kind are bound as type+      -- variables. Assume -XNoTypeInType.+    check_tv_used_in_kind :: NameSet       -- ^ *type* variables+                          -> Located Name  -- ^ renamed var used in kind+                          -> RnM ()+    check_tv_used_in_kind tv_names (L loc kv_name)+      = when (kv_name `elemNameSet` tv_names) $+        addErrAt loc (vcat [ text "Type variable" <+> quotes (ppr kv_name) <+>+                             text "used in a kind." $$+                             text "Did you mean to use TypeInType?"+                           , pprHsDocContext doc ])+++newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name+newTyVarNameRn mb_assoc (L loc rdr)+  = do { rdr_env <- getLocalRdrEnv+       ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of+           (Just _, Just n) -> return n+              -- Use the same Name as the parent class decl++           _                -> newLocalBndrRn (L loc rdr) }++---------------------+collectAnonWildCards :: LHsType Name -> [Name]+-- | Extract all wild cards from a type.+collectAnonWildCards lty = go lty+  where+    go (L _ ty) = case ty of+      HsWildCardTy (AnonWildCard (L _ wc)) -> [wc]+      HsAppsTy tys                 -> gos (mapMaybe (prefix_types_only . unLoc) tys)+      HsAppTy ty1 ty2              -> go ty1 `mappend` go ty2+      HsFunTy ty1 ty2              -> go ty1 `mappend` go ty2+      HsListTy ty                  -> go ty+      HsPArrTy ty                  -> go ty+      HsTupleTy _ tys              -> gos tys+      HsSumTy tys                  -> gos tys+      HsOpTy ty1 _ ty2             -> go ty1 `mappend` go ty2+      HsParTy ty                   -> go ty+      HsIParamTy _ ty              -> go ty+      HsEqTy ty1 ty2               -> go ty1 `mappend` go ty2+      HsKindSig ty kind            -> go ty `mappend` go kind+      HsDocTy ty _                 -> go ty+      HsBangTy _ ty                -> go ty+      HsRecTy flds                 -> gos $ map (cd_fld_type . unLoc) flds+      HsExplicitListTy _ _ tys     -> gos tys+      HsExplicitTupleTy _ tys      -> gos tys+      HsForAllTy { hst_bndrs = bndrs+                 , hst_body = ty } -> collectAnonWildCardsBndrs bndrs+                                      `mappend` go ty+      HsQualTy { hst_ctxt = L _ ctxt+               , hst_body = ty }  -> gos ctxt `mappend` go ty+      HsSpliceTy (HsSpliced _ (HsSplicedTy ty)) _ -> go $ L noSrcSpan ty+      HsSpliceTy{} -> mempty+      HsCoreTy{} -> mempty+      HsTyLit{} -> mempty+      HsTyVar{} -> mempty++    gos = mconcat . map go++    prefix_types_only (HsAppPrefix ty) = Just ty+    prefix_types_only (HsAppInfix _)   = Nothing++collectAnonWildCardsBndrs :: [LHsTyVarBndr Name] -> [Name]+collectAnonWildCardsBndrs ltvs = concatMap (go . unLoc) ltvs+  where+    go (UserTyVar _)      = []+    go (KindedTyVar _ ki) = collectAnonWildCards ki++{-+*********************************************************+*                                                       *+        ConDeclField+*                                                       *+*********************************************************++When renaming a ConDeclField, we have to find the FieldLabel+associated with each field.  But we already have all the FieldLabels+available (since they were brought into scope by+RnNames.getLocalNonValBinders), so we just take the list as an+argument, build a map and look them up.+-}++rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField RdrName]+                -> RnM ([LConDeclField Name], FreeVars)+-- Also called from RnSource+-- No wildcards can appear in record fields+rnConDeclFields ctxt fls fields+   = mapFvRn (rnField fl_env env) fields+  where+    env    = mkTyKiEnv ctxt TypeLevel RnTypeBody+    fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ]++rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField RdrName+        -> RnM (LConDeclField Name, FreeVars)+rnField fl_env env (L l (ConDeclField names ty haddock_doc))+  = do { let new_names = map (fmap lookupField) names+       ; (new_ty, fvs) <- rnLHsTyKi env ty+       ; new_haddock_doc <- rnMbLHsDoc haddock_doc+       ; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) }+  where+    lookupField :: FieldOcc RdrName -> FieldOcc Name+    lookupField (FieldOcc (L lr rdr) _) = FieldOcc (L lr rdr) (flSelector fl)+      where+        lbl = occNameFS $ rdrNameOcc rdr+        fl  = expectJust "rnField" $ lookupFsEnv fl_env lbl++{-+************************************************************************+*                                                                      *+        Fixities and precedence parsing+*                                                                      *+************************************************************************++@mkOpAppRn@ deals with operator fixities.  The argument expressions+are assumed to be already correctly arranged.  It needs the fixities+recorded in the OpApp nodes, because fixity info applies to the things+the programmer actually wrote, so you can't find it out from the Name.++Furthermore, the second argument is guaranteed not to be another+operator application.  Why? Because the parser parses all+operator applications left-associatively, EXCEPT negation, which+we need to handle specially.+Infix types are read in a *right-associative* way, so that+        a `op` b `op` c+is always read in as+        a `op` (b `op` c)++mkHsOpTyRn rearranges where necessary.  The two arguments+have already been renamed and rearranged.  It's made rather tiresome+by the presence of ->, which is a separate syntactic construct.+-}++---------------+-- Building (ty1 `op1` (ty21 `op2` ty22))+mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)+           -> Name -> Fixity -> LHsType Name -> LHsType Name+           -> RnM (HsType Name)++mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22))+  = do  { fix2 <- lookupTyFixityRn op2+        ; mk_hs_op_ty mk1 pp_op1 fix1 ty1+                      (\t1 t2 -> HsOpTy t1 op2 t2)+                      (unLoc op2) fix2 ty21 ty22 loc2 }++mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))+  = mk_hs_op_ty mk1 pp_op1 fix1 ty1+                HsFunTy funTyConName funTyFixity ty21 ty22 loc2++mkHsOpTyRn mk1 _ _ ty1 ty2              -- Default case, no rearrangment+  = return (mk1 ty1 ty2)++---------------+mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)+            -> Name -> Fixity -> LHsType Name+            -> (LHsType Name -> LHsType Name -> HsType Name)+            -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan+            -> RnM (HsType Name)+mk_hs_op_ty mk1 op1 fix1 ty1+            mk2 op2 fix2 ty21 ty22 loc2+  | nofix_error     = do { precParseErr (NormalOp op1,fix1) (NormalOp op2,fix2)+                         ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }+  | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))+  | otherwise       = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)+                           new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21+                         ; return (mk2 (noLoc new_ty) ty22) }+  where+    (nofix_error, associate_right) = compareFixity fix1 fix2+++---------------------------+mkOpAppRn :: LHsExpr Name                       -- Left operand; already rearranged+          -> LHsExpr Name -> Fixity             -- Operator and fixity+          -> LHsExpr Name                       -- Right operand (not an OpApp, but might+                                                -- be a NegApp)+          -> RnM (HsExpr Name)++-- (e11 `op1` e12) `op2` e2+mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2+  | nofix_error+  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)+       return (OpApp e1 op2 fix2 e2)++  | associate_right = do+    new_e <- mkOpAppRn e12 op2 fix2 e2+    return (OpApp e11 op1 fix1 (L loc' new_e))+  where+    loc'= combineLocs e12 e2+    (nofix_error, associate_right) = compareFixity fix1 fix2++---------------------------+--      (- neg_arg) `op` e2+mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2+  | nofix_error+  = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2)+       return (OpApp e1 op2 fix2 e2)++  | associate_right+  = do new_e <- mkOpAppRn neg_arg op2 fix2 e2+       return (NegApp (L loc' new_e) neg_name)+  where+    loc' = combineLocs neg_arg e2+    (nofix_error, associate_right) = compareFixity negateFixity fix2++---------------------------+--      e1 `op` - neg_arg+mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _))     -- NegApp can occur on the right+  | not associate_right                 -- We *want* right association+  = do precParseErr (get_op op1, fix1) (NegateOp, negateFixity)+       return (OpApp e1 op1 fix1 e2)+  where+    (_, associate_right) = compareFixity fix1 negateFixity++---------------------------+--      Default case+mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment+  = ASSERT2( right_op_ok fix (unLoc e2),+             ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2+    )+    return (OpApp e1 op fix e2)++----------------------------++-- | Name of an operator in an operator application or section+data OpName = NormalOp Name         -- ^ A normal identifier+            | NegateOp              -- ^ Prefix negation+            | UnboundOp UnboundVar  -- ^ An unbound indentifier+            | RecFldOp (AmbiguousFieldOcc Name)+              -- ^ A (possibly ambiguous) record field occurrence++instance Outputable OpName where+  ppr (NormalOp n)   = ppr n+  ppr NegateOp       = ppr negateName+  ppr (UnboundOp uv) = ppr uv+  ppr (RecFldOp fld) = ppr fld++get_op :: LHsExpr Name -> OpName+-- An unbound name could be either HsVar or HsUnboundVar+-- See RnExpr.rnUnboundVar+get_op (L _ (HsVar (L _ n)))   = NormalOp n+get_op (L _ (HsUnboundVar uv)) = UnboundOp uv+get_op (L _ (HsRecFld fld))    = RecFldOp fld+get_op other                   = pprPanic "get_op" (ppr other)++-- Parser left-associates everything, but+-- derived instances may have correctly-associated things to+-- in the right operand.  So we just check that the right operand is OK+right_op_ok :: Fixity -> HsExpr Name -> Bool+right_op_ok fix1 (OpApp _ _ fix2 _)+  = not error_please && associate_right+  where+    (error_please, associate_right) = compareFixity fix1 fix2+right_op_ok _ _+  = True++-- Parser initially makes negation bind more tightly than any other operator+-- And "deriving" code should respect this (use HsPar if not)+mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)+mkNegAppRn neg_arg neg_name+  = ASSERT( not_op_app (unLoc neg_arg) )+    return (NegApp neg_arg neg_name)++not_op_app :: HsExpr id -> Bool+not_op_app (OpApp _ _ _ _) = False+not_op_app _               = True++---------------------------+mkOpFormRn :: LHsCmdTop Name            -- Left operand; already rearranged+          -> LHsExpr Name -> Fixity     -- Operator and fixity+          -> LHsCmdTop Name             -- Right operand (not an infix)+          -> RnM (HsCmd Name)++-- (e11 `op1` e12) `op2` e2+mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 f (Just fix1)+                                     [a11,a12])) _ _ _))+        op2 fix2 a2+  | nofix_error+  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)+       return (HsCmdArrForm op2 f (Just fix2) [a1, a2])++  | associate_right+  = do new_c <- mkOpFormRn a12 op2 fix2 a2+       return (HsCmdArrForm op1 f (Just fix1)+               [a11, L loc (HsCmdTop (L loc new_c)+               placeHolderType placeHolderType [])])+        -- TODO: locs are wrong+  where+    (nofix_error, associate_right) = compareFixity fix1 fix2++--      Default case+mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment+  = return (HsCmdArrForm op Infix (Just fix) [arg1, arg2])+++--------------------------------------+mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name+             -> RnM (Pat Name)++mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2+  = do  { fix1 <- lookupFixityRn (unLoc op1)+        ; let (nofix_error, associate_right) = compareFixity fix1 fix2++        ; if nofix_error then do+                { precParseErr (NormalOp (unLoc op1),fix1)+                               (NormalOp (unLoc op2),fix2)+                ; return (ConPatIn op2 (InfixCon p1 p2)) }++          else if associate_right then do+                { new_p <- mkConOpPatRn op2 fix2 p12 p2+                ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right?+          else return (ConPatIn op2 (InfixCon p1 p2)) }++mkConOpPatRn op _ p1 p2                         -- Default case, no rearrangment+  = ASSERT( not_op_pat (unLoc p2) )+    return (ConPatIn op (InfixCon p1 p2))++not_op_pat :: Pat Name -> Bool+not_op_pat (ConPatIn _ (InfixCon _ _)) = False+not_op_pat _                           = True++--------------------------------------+checkPrecMatch :: Name -> MatchGroup Name body -> RnM ()+  -- Check precedence of a function binding written infix+  --   eg  a `op` b `C` c = ...+  -- See comments with rnExpr (OpApp ...) about "deriving"++checkPrecMatch op (MG { mg_alts = L _ ms })+  = mapM_ check ms+  where+    check (L _ (Match _ (L l1 p1 : L l2 p2 :_) _ _))+      = setSrcSpan (combineSrcSpans l1 l2) $+        do checkPrec op p1 False+           checkPrec op p2 True++    check _ = return ()+        -- This can happen.  Consider+        --      a `op` True = ...+        --      op          = ...+        -- The infix flag comes from the first binding of the group+        -- but the second eqn has no args (an error, but not discovered+        -- until the type checker).  So we don't want to crash on the+        -- second eqn.++checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()+checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do+    op_fix@(Fixity _ op_prec  op_dir) <- lookupFixityRn op+    op1_fix@(Fixity _ op1_prec op1_dir) <- lookupFixityRn (unLoc op1)+    let+        inf_ok = op1_prec > op_prec ||+                 (op1_prec == op_prec &&+                  (op1_dir == InfixR && op_dir == InfixR && right ||+                   op1_dir == InfixL && op_dir == InfixL && not right))++        info  = (NormalOp op,          op_fix)+        info1 = (NormalOp (unLoc op1), op1_fix)+        (infol, infor) = if right then (info, info1) else (info1, info)+    unless inf_ok (precParseErr infol infor)++checkPrec _ _ _+  = return ()++-- Check precedence of (arg op) or (op arg) respectively+-- If arg is itself an operator application, then either+--   (a) its precedence must be higher than that of op+--   (b) its precedency & associativity must be the same as that of op+checkSectionPrec :: FixityDirection -> HsExpr RdrName+        -> LHsExpr Name -> LHsExpr Name -> RnM ()+checkSectionPrec direction section op arg+  = case unLoc arg of+        OpApp _ op' fix _ -> go_for_it (get_op op') fix+        NegApp _ _        -> go_for_it NegateOp     negateFixity+        _                 -> return ()+  where+    op_name = get_op op+    go_for_it arg_op arg_fix@(Fixity _ arg_prec assoc) = do+          op_fix@(Fixity _ op_prec _) <- lookupFixityOp op_name+          unless (op_prec < arg_prec+                  || (op_prec == arg_prec && direction == assoc))+                 (sectionPrecErr (get_op op, op_fix)+                                 (arg_op, arg_fix) section)++-- | Look up the fixity for an operator name.  Be careful to use+-- 'lookupFieldFixityRn' for (possibly ambiguous) record fields+-- (see Trac #13132).+lookupFixityOp :: OpName -> RnM Fixity+lookupFixityOp (NormalOp n)  = lookupFixityRn n+lookupFixityOp NegateOp      = lookupFixityRn negateName+lookupFixityOp (UnboundOp u) = lookupFixityRn (mkUnboundName (unboundVarOcc u))+lookupFixityOp (RecFldOp f)  = lookupFieldFixityRn f+++-- Precedence-related error messages++precParseErr :: (OpName,Fixity) -> (OpName,Fixity) -> RnM ()+precParseErr op1@(n1,_) op2@(n2,_)+  | is_unbound n1 || is_unbound n2+  = return ()     -- Avoid error cascade+  | otherwise+  = addErr $ hang (text "Precedence parsing error")+      4 (hsep [text "cannot mix", ppr_opfix op1, ptext (sLit "and"),+               ppr_opfix op2,+               text "in the same infix expression"])++sectionPrecErr :: (OpName,Fixity) -> (OpName,Fixity) -> HsExpr RdrName -> RnM ()+sectionPrecErr op@(n1,_) arg_op@(n2,_) section+  | is_unbound n1 || is_unbound n2+  = return ()     -- Avoid error cascade+  | otherwise+  = addErr $ vcat [text "The operator" <+> ppr_opfix op <+> ptext (sLit "of a section"),+         nest 4 (sep [text "must have lower precedence than that of the operand,",+                      nest 2 (text "namely" <+> ppr_opfix arg_op)]),+         nest 4 (text "in the section:" <+> quotes (ppr section))]++is_unbound :: OpName -> Bool+is_unbound UnboundOp{} = True+is_unbound _           = False++ppr_opfix :: (OpName, Fixity) -> SDoc+ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)+   where+     pp_op | NegateOp <- op = text "prefix `-'"+           | otherwise      = quotes (ppr op)+++{- *****************************************************+*                                                      *+                 Errors+*                                                      *+***************************************************** -}++unexpectedTypeSigErr :: LHsSigWcType RdrName -> SDoc+unexpectedTypeSigErr ty+  = hang (text "Illegal type signature:" <+> quotes (ppr ty))+       2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables")++badKindBndrs :: HsDocContext -> [Located RdrName] -> SDoc+badKindBndrs doc kvs+  = withHsDocContext doc $+    hang (text "Unexpected kind variable" <> plural kvs+                 <+> pprQuotedList kvs)+       2 (text "Perhaps you intended to use PolyKinds")++badKindSigErr :: HsDocContext -> LHsType RdrName -> TcM ()+badKindSigErr doc (L loc ty)+  = setSrcSpan loc $ addErr $+    withHsDocContext doc $+    hang (text "Illegal kind signature:" <+> quotes (ppr ty))+       2 (text "Perhaps you intended to use KindSignatures")++dataKindsErr :: RnTyKiEnv -> HsType RdrName -> SDoc+dataKindsErr env thing+  = hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing))+       2 (text "Perhaps you intended to use DataKinds")+  where+    pp_what | isRnKindLevel env = text "kind"+            | otherwise          = text "type"++inTypeDoc :: HsType RdrName -> SDoc+inTypeDoc ty = text "In the type" <+> quotes (ppr ty)++warnUnusedForAll :: SDoc -> LHsTyVarBndr Name -> FreeVars -> TcM ()+warnUnusedForAll in_doc (L loc tv) used_names+  = whenWOptM Opt_WarnUnusedForalls $+    unless (hsTyVarName tv `elemNameSet` used_names) $+    addWarnAt (Reason Opt_WarnUnusedForalls) loc $+    vcat [ text "Unused quantified type variable" <+> quotes (ppr tv)+         , in_doc ]++opTyErr :: Outputable a => RdrName -> a -> SDoc+opTyErr op overall_ty+  = hang (text "Illegal operator" <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr overall_ty))+         2 extra+  where+    extra | op == dot_tv_RDR+          = perhapsForallMsg+          | otherwise+          = text "Use TypeOperators to allow operators in types"++emptyNonSymsErr :: HsType RdrName -> SDoc+emptyNonSymsErr overall_ty+  = text "Operator applied to too few arguments:" <+> ppr overall_ty++{-+************************************************************************+*                                                                      *+      Finding the free type variables of a (HsType RdrName)+*                                                                      *+************************************************************************+++Note [Kind and type-variable binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a type signature we may implicitly bind type variable and, more+recently, kind variables.  For example:+  *   f :: a -> a+      f = ...+    Here we need to find the free type variables of (a -> a),+    so that we know what to quantify++  *   class C (a :: k) where ...+    This binds 'k' in ..., as well as 'a'++  *   f (x :: a -> [a]) = ....+    Here we bind 'a' in ....++  *   f (x :: T a -> T (b :: k)) = ...+    Here we bind both 'a' and the kind variable 'k'++  *   type instance F (T (a :: Maybe k)) = ...a...k...+    Here we want to constrain the kind of 'a', and bind 'k'.++In general we want to walk over a type, and find+  * Its free type variables+  * The free kind variables of any kind signatures in the type++Hence we returns a pair (kind-vars, type vars)+See also Note [HsBSig binder lists] in HsTypes+-}++data FreeKiTyVars = FKTV { fktv_kis    :: [Located RdrName]+                         , fktv_tys    :: [Located RdrName] }++instance Outputable FreeKiTyVars where+  ppr (FKTV kis tys) = ppr (kis, tys)++emptyFKTV :: FreeKiTyVars+emptyFKTV = FKTV [] []++freeKiTyVarsAllVars :: FreeKiTyVars -> [Located RdrName]+freeKiTyVarsAllVars (FKTV tys kvs) = tys ++ kvs++freeKiTyVarsKindVars :: FreeKiTyVars -> [Located RdrName]+freeKiTyVarsKindVars = fktv_kis++freeKiTyVarsTypeVars :: FreeKiTyVars -> [Located RdrName]+freeKiTyVarsTypeVars = fktv_tys++filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars+filterInScope rdr_env (FKTV kis tys)+  = FKTV (filterOut in_scope kis)+         (filterOut in_scope tys)+  where+    in_scope         = inScope rdr_env . unLoc++inScope :: LocalRdrEnv -> RdrName -> Bool+inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env++extractHsTyRdrTyVars :: LHsType RdrName -> RnM FreeKiTyVars+-- extractHsTyRdrNames finds the free (kind, type) variables of a HsType+--                        or the free (sort, kind) variables of a HsKind+-- It's used when making the for-alls explicit.+-- Does not return any wildcards+-- When the same name occurs multiple times in the types, only the first+-- occurrence is returned.+-- See Note [Kind and type-variable binders]+extractHsTyRdrTyVars ty+  = do { FKTV kis tys <- extract_lty TypeLevel ty emptyFKTV+       ; return (FKTV (nubL kis)+                      (nubL tys)) }+++-- | Extracts free type and kind variables from types in a list.+-- When the same name occurs multiple times in the types, only the first+-- occurrence is returned and the rest is filtered out.+-- See Note [Kind and type-variable binders]+extractHsTysRdrTyVars :: [LHsType RdrName] -> RnM FreeKiTyVars+extractHsTysRdrTyVars tys+  = rmDupsInRdrTyVars <$> extractHsTysRdrTyVarsDups tys++-- | Extracts free type and kind variables from types in a list.+-- When the same name occurs multiple times in the types, all occurrences+-- are returned.+extractHsTysRdrTyVarsDups :: [LHsType RdrName] -> RnM FreeKiTyVars+extractHsTysRdrTyVarsDups tys+  = extract_ltys TypeLevel tys emptyFKTV++-- | Removes multiple occurrences of the same name from FreeKiTyVars.+rmDupsInRdrTyVars :: FreeKiTyVars -> FreeKiTyVars+rmDupsInRdrTyVars (FKTV kis tys)+  = FKTV (nubL kis) (nubL tys)++extractRdrKindSigVars :: LFamilyResultSig RdrName -> RnM [Located RdrName]+extractRdrKindSigVars (L _ resultSig)+    | KindSig k                        <- resultSig = kindRdrNameFromSig k+    | TyVarSig (L _ (KindedTyVar _ k)) <- resultSig = kindRdrNameFromSig k+    | otherwise = return []+    where kindRdrNameFromSig k = freeKiTyVarsAllVars <$> extractHsTyRdrTyVars k++extractDataDefnKindVars :: HsDataDefn RdrName -> RnM [Located RdrName]+-- Get the scoped kind variables mentioned free in the constructor decls+-- Eg    data T a = T1 (S (a :: k) | forall (b::k). T2 (S b)+-- Here k should scope over the whole definition+extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig+                                    , dd_cons = cons, dd_derivs = L _ derivs })+  = (nubL . freeKiTyVarsKindVars) <$>+    (extract_lctxt TypeLevel ctxt =<<+     extract_mb extract_lkind ksig =<<+     extract_sig_tys (concatMap (unLoc . deriv_clause_tys . unLoc) derivs) =<<+     foldrM (extract_con . unLoc) emptyFKTV cons)+  where+    extract_con (ConDeclGADT { }) acc = return acc+    extract_con (ConDeclH98 { con_qvars = qvs+                            , con_cxt = ctxt, con_details = details }) acc+      = extract_hs_tv_bndrs (maybe [] hsQTvExplicit qvs) acc =<<+        extract_mlctxt ctxt =<<+        extract_ltys TypeLevel (hsConDeclArgTys details) emptyFKTV++extract_mlctxt :: Maybe (LHsContext RdrName) -> FreeKiTyVars -> RnM FreeKiTyVars+extract_mlctxt Nothing     acc = return acc+extract_mlctxt (Just ctxt) acc = extract_lctxt TypeLevel ctxt acc++extract_lctxt :: TypeOrKind+              -> LHsContext RdrName -> FreeKiTyVars -> RnM FreeKiTyVars+extract_lctxt t_or_k ctxt = extract_ltys t_or_k (unLoc ctxt)++extract_sig_tys :: [LHsSigType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars+extract_sig_tys sig_tys acc+  = foldrM (\sig_ty acc -> extract_lty TypeLevel (hsSigType sig_ty) acc)+           acc sig_tys++extract_ltys :: TypeOrKind+             -> [LHsType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars+extract_ltys t_or_k tys acc = foldrM (extract_lty t_or_k) acc tys++extract_mb :: (a -> FreeKiTyVars -> RnM FreeKiTyVars)+           -> Maybe a -> FreeKiTyVars -> RnM FreeKiTyVars+extract_mb _ Nothing  acc = return acc+extract_mb f (Just x) acc = f x acc++extract_lkind :: LHsType RdrName -> FreeKiTyVars -> RnM FreeKiTyVars+extract_lkind = extract_lty KindLevel++extract_lty :: TypeOrKind -> LHsType RdrName -> FreeKiTyVars -> RnM FreeKiTyVars+extract_lty t_or_k (L _ ty) acc+  = case ty of+      HsTyVar _  ltv            -> extract_tv t_or_k ltv acc+      HsBangTy _ ty             -> extract_lty t_or_k ty acc+      HsRecTy flds              -> foldrM (extract_lty t_or_k+                                           . cd_fld_type . unLoc) acc+                                         flds+      HsAppsTy tys              -> extract_apps t_or_k tys acc+      HsAppTy ty1 ty2           -> extract_lty t_or_k ty1 =<<+                                   extract_lty t_or_k ty2 acc+      HsListTy ty               -> extract_lty t_or_k ty acc+      HsPArrTy ty               -> extract_lty t_or_k ty acc+      HsTupleTy _ tys           -> extract_ltys t_or_k tys acc+      HsSumTy tys               -> extract_ltys t_or_k tys acc+      HsFunTy ty1 ty2           -> extract_lty t_or_k ty1 =<<+                                   extract_lty t_or_k ty2 acc+      HsIParamTy _ ty           -> extract_lty t_or_k ty acc+      HsEqTy ty1 ty2            -> extract_lty t_or_k ty1 =<<+                                   extract_lty t_or_k ty2 acc+      HsOpTy ty1 tv ty2         -> extract_tv t_or_k tv =<<+                                   extract_lty t_or_k ty1 =<<+                                   extract_lty t_or_k ty2 acc+      HsParTy ty                -> extract_lty t_or_k ty acc+      HsCoreTy {}               -> return acc  -- The type is closed+      HsSpliceTy {}             -> return acc  -- Type splices mention no tvs+      HsDocTy ty _              -> extract_lty t_or_k ty acc+      HsExplicitListTy _ _ tys  -> extract_ltys t_or_k tys acc+      HsExplicitTupleTy _ tys   -> extract_ltys t_or_k tys acc+      HsTyLit _                 -> return acc+      HsKindSig ty ki           -> extract_lty t_or_k ty =<<+                                   extract_lkind ki acc+      HsForAllTy { hst_bndrs = tvs, hst_body = ty }+                                -> extract_hs_tv_bndrs tvs acc =<<+                                   extract_lty t_or_k ty emptyFKTV+      HsQualTy { hst_ctxt = ctxt, hst_body = ty }+                                -> extract_lctxt t_or_k ctxt   =<<+                                   extract_lty t_or_k ty acc+      -- We deal with these separately in rnLHsTypeWithWildCards+      HsWildCardTy {}           -> return acc++extract_apps :: TypeOrKind+             -> [LHsAppType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars+extract_apps t_or_k tys acc = foldrM (extract_app t_or_k) acc tys++extract_app :: TypeOrKind -> LHsAppType RdrName -> FreeKiTyVars+            -> RnM FreeKiTyVars+extract_app t_or_k (L _ (HsAppInfix tv))  acc = extract_tv t_or_k tv acc+extract_app t_or_k (L _ (HsAppPrefix ty)) acc = extract_lty t_or_k ty acc++extract_hs_tv_bndrs :: [LHsTyVarBndr RdrName] -> FreeKiTyVars+                    -> FreeKiTyVars -> RnM FreeKiTyVars+-- In (forall (a :: Maybe e). a -> b) we have+--     'a' is bound by the forall+--     'b' is a free type variable+--     'e' is a free kind variable+extract_hs_tv_bndrs tvs+                    (FKTV acc_kvs acc_tvs)+                           -- Note accumulator comes first+                    (FKTV body_kvs body_tvs)+  | null tvs+  = return $+    FKTV (body_kvs ++ acc_kvs) (body_tvs ++ acc_tvs)+  | otherwise+  = do { FKTV bndr_kvs _+           <- foldrM extract_lkind emptyFKTV [k | L _ (KindedTyVar _ k) <- tvs]++       ; let locals = map hsLTyVarName tvs+       ; return $+         FKTV (filterOut ((`elem` locals) . unLoc) (bndr_kvs ++ body_kvs)+                ++ acc_kvs)+              (filterOut ((`elem` locals) . unLoc)  body_tvs ++ acc_tvs) }++extract_tv :: TypeOrKind -> Located RdrName -> FreeKiTyVars -> RnM FreeKiTyVars+extract_tv t_or_k ltv@(L _ tv) acc+  | isRdrTyVar tv = case acc of+      FKTV kvs tvs+        |  isTypeLevel t_or_k+        -> do { when (ltv `elemRdr` kvs) $+                mixedVarsErr ltv+              ; return (FKTV kvs (ltv : tvs)) }+        |  otherwise+        -> do { when (ltv `elemRdr` tvs) $+                mixedVarsErr ltv+              ; return (FKTV (ltv : kvs) tvs) }+  | otherwise     = return acc+  where+    elemRdr x = any (eqLocated x)++mixedVarsErr :: Located RdrName -> RnM ()+mixedVarsErr (L loc tv)+  = do { typeintype <- xoptM LangExt.TypeInType+       ; unless typeintype $+         addErrAt loc $ text "Variable" <+> quotes (ppr tv) <+>+                        text "used as both a kind and a type" $$+                        text "Did you intend to use TypeInType?" }++-- just used in this module; seemed convenient here+nubL :: Eq a => [Located a] -> [Located a]+nubL = nubBy eqLocated
+ simplCore/CSE.hs view
@@ -0,0 +1,601 @@+{-+(c) The AQUA Project, Glasgow University, 1993-1998++\section{Common subexpression}+-}++{-# LANGUAGE CPP #-}++module CSE (cseProgram, cseOneExpr) where++#include "HsVersions.h"++import CoreSubst+import Var              ( Var )+import VarEnv           ( elemInScopeSet )+import Id               ( Id, idType, idInlineActivation, isDeadBinder+                        , zapIdOccInfo, zapIdUsageInfo, idInlinePragma+                        , isJoinId )+import CoreUtils        ( mkAltExpr, eqExpr+                        , exprIsLiteralString+                        , stripTicksE, stripTicksT, mkTicks )+import Type             ( tyConAppArgs )+import CoreSyn+import Outputable+import BasicTypes       ( TopLevelFlag(..), isTopLevel+                        , isAlwaysActive, isAnyInlinePragma )+import TrieMap+import Util             ( filterOut )+import Data.List        ( mapAccumL )++{-+                        Simple common sub-expression+                        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we see+        x1 = C a b+        x2 = C x1 b+we build up a reverse mapping:   C a b  -> x1+                                 C x1 b -> x2+and apply that to the rest of the program.++When we then see+        y1 = C a b+        y2 = C y1 b+we replace the C a b with x1.  But then we *dont* want to+add   x1 -> y1  to the mapping.  Rather, we want the reverse, y1 -> x1+so that a subsequent binding+        y2 = C y1 b+will get transformed to C x1 b, and then to x2.++So we carry an extra var->var substitution which we apply *before* looking up in the+reverse mapping.+++Note [Shadowing]+~~~~~~~~~~~~~~~~+We have to be careful about shadowing.+For example, consider+        f = \x -> let y = x+x in+                      h = \x -> x+x+                  in ...++Here we must *not* do CSE on the inner x+x!  The simplifier used to guarantee no+shadowing, but it doesn't any more (it proved too hard), so we clone as we go.+We can simply add clones to the substitution already described.+++Note [CSE for bindings]+~~~~~~~~~~~~~~~~~~~~~~~+Let-bindings have two cases, implemented by addBinding.++* SUBSTITUTE: applies when the RHS is a variable++     let x = y in ...(h x)....++  Here we want to extend the /substitution/ with x -> y, so that the+  (h x) in the body might CSE with an enclosing (let v = h y in ...).+  NB: the substitution maps InIds, so we extend the substitution with+      a binding for the original InId 'x'++  How can we have a variable on the RHS? Doesn't the simplifier inline them?++    - First, the original RHS might have been (g z) which has CSE'd+      with an enclosing (let y = g z in ...).  This is super-important.+      See Trac #5996:+         x1 = C a b+         x2 = C x1 b+         y1 = C a b+         y2 = C y1 b+      Here we CSE y1's rhs to 'x1', and then we must add (y1->x1) to+      the substitution so that we can CSE the binding for y2.++    - Second, we use addBinding for case expression scrutinees too;+      see Note [CSE for case expressions]++* EXTEND THE REVERSE MAPPING: applies in all other cases++     let x = h y in ...(h y)...++  Here we want to extend the /reverse mapping (cs_map)/ so that+  we CSE the (h y) call to x.++  Note that we use EXTEND even for a trivial expression, provided it+  is not a variable or literal. In particular this /includes/ type+  applications. This can be important (Trac #13156); e.g.+     case f @ Int of { r1 ->+     case f @ Int of { r2 -> ...+  Here we want to common-up the two uses of (f @ Int) so we can+  remove one of the case expressions.++  See also Note [Corner case for case expressions] for another+  reason not to use SUBSTITUTE for all trivial expressions.++Notice that+  - The SUBSTITUTE situation extends the substitution (cs_subst)+  - The EXTEND situation extends the reverse mapping (cs_map)++Notice also that in the SUBSTITUTE case we leave behind a binding+  x = y+even though we /also/ carry a substitution x -> y.  Can we just drop+the binding instead?  Well, not at top level! See SimplUtils+Note [Top level and postInlineUnconditionally]; and in any case CSE+applies only to the /bindings/ of the program, and we leave it to the+simplifier to propate effects to the RULES.  Finally, it doesn't seem+worth the effort to discard the nested bindings because the simplifier+will do it next.++Note [CSE for case expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  case scrut_expr of x { ...alts... }+This is very like a strict let-binding+  let !x = scrut_expr in ...+So we use (addBinding x scrut_expr) to process scrut_expr and x, and as a+result all the stuff under Note [CSE for bindings] applies directly.++For example:++* Trivial scrutinee+     f = \x -> case x of wild {+                 (a:as) -> case a of wild1 {+                             (p,q) -> ...(wild1:as)...++  Here, (wild1:as) is morally the same as (a:as) and hence equal to+  wild. But that's not quite obvious.  In the rest of the compiler we+  want to keep it as (wild1:as), but for CSE purpose that's a bad+  idea.++  By using addBinding we add the binding (wild1 -> a) to the substitution,+  which does exactly the right thing.++  (Notice this is exactly backwards to what the simplifier does, which+  is to try to replaces uses of 'a' with uses of 'wild1'.)++  This is the main reason that addBinding is called with a trivial rhs.++* Non-trivial scrutinee+     case (f x) of y { pat -> ...let y = f x in ... }++  By using addBinding we'll add (f x :-> y) to the cs_map, and+  thereby CSE the inner (f x) to y.++Note [CSE for INLINE and NOINLINE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are some subtle interactions of CSE with functions that the user+has marked as INLINE or NOINLINE. (Examples from Roman Leshchinskiy.)+Consider++        yes :: Int  {-# NOINLINE yes #-}+        yes = undefined++        no :: Int   {-# NOINLINE no #-}+        no = undefined++        foo :: Int -> Int -> Int  {-# NOINLINE foo #-}+        foo m n = n++        {-# RULES "foo/no" foo no = id #-}++        bar :: Int -> Int+        bar = foo yes++We do not expect the rule to fire.  But if we do CSE, then we risk+getting yes=no, and the rule does fire.  Actually, it won't because+NOINLINE means that 'yes' will never be inlined, not even if we have+yes=no.  So that's fine (now; perhaps in the olden days, yes=no would+have substituted even if 'yes' was NOINLINE).++But we do need to take care.  Consider++        {-# NOINLINE bar #-}+        bar = <rhs>     -- Same rhs as foo++        foo = <rhs>++If CSE produces+        foo = bar+then foo will never be inlined to <rhs> (when it should be, if <rhs>+is small).  The conclusion here is this:++   We should not add+       <rhs> :-> bar+  to the CSEnv if 'bar' has any constraints on when it can inline;+  that is, if its 'activation' not always active.  Otherwise we+  might replace <rhs> by 'bar', and then later be unable to see that it+  really was <rhs>.++Note that we do not (currently) do CSE on the unfolding stored inside+an Id, even if is a 'stable' unfolding.  That means that when an+unfolding happens, it is always faithful to what the stable unfolding+originally was.++Note [CSE for stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   {-# Unf = Stable (\pq. build blah) #-}+   foo = x++Here 'foo' has a stable unfolding, but its (optimised) RHS is trivial.+(Turns out that this actually happens for the enumFromTo method of+the Integer instance of Enum in GHC.Enum.)  Suppose moreover that foo's+stable unfolding originates from an INLINE or INLINEABLE pragma on foo.+Then we obviously do NOT want to extend the substitution with (foo->x),+because we promised to inline foo as what the user wrote.  See similar+SimplUtils Note [Stable unfoldings and postInlineUnconditionally].++Nor do we want to change the reverse mapping. Suppose we have++   {-# Unf = Stable (\pq. build blah) #-}+   foo = <expr>+   bar = <expr>++There could conceivably be merit in rewriting the RHS of bar:+   bar = foo+but now bar's inlining behaviour will change, and importing+modules might see that.  So it seems dodgy and we don't do it.++Stable unfoldings are also created during worker/wrapper when we decide+that a function's definition is so small that it should always inline.+In this case we still want to do CSE (#13340). Hence the use of+isAnyInlinePragma rather than isStableUnfolding.++Note [Corner case for case expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is another reason that we do not use SUBSTITUTE for+all trivial expressions. Consider+   case x |> co of (y::Array# Int) { ... }++We do not want to extend the substitution with (y -> x |> co); since y+is of unlifted type, this would destroy the let/app invariant if (x |>+co) was not ok-for-speculation.++But surely (x |> co) is ok-for-speculation, becasue it's a trivial+expression, and x's type is also unlifted, presumably.  Well, maybe+not if you are using unsafe casts.  I actually found a case where we+had+   (x :: HValue) |> (UnsafeCo :: HValue ~ Array# Int)++Note [CSE for join points?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must not be naive about join points in CSE:+   join j = e in+   if b then jump j else 1 + e+The expression (1 + jump j) is not good (see Note [Invariants on join points] in+CoreSyn). This seems to come up quite seldom, but it happens (first seen+compiling ppHtml in Haddock.Backends.Xhtml).++We could try and be careful by tracking which join points are still valid at+each subexpression, but since join points aren't allocated or shared, there's+less to gain by trying to CSE them.++Note [CSE for recursive bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  f = \x ... f....+  g = \y ... g ...+where the "..." are identical.  Could we CSE them?  In full generality+with mutual recursion it's quite hard; but for self-recursive bindings+(which are very common) it's rather easy:++* Maintain a separate cs_rec_map, that maps+      (\f. (\x. ...f...) ) -> f+  Note the \f in the domain of the mapping!++* When we come across the binding for 'g', look up (\g. (\y. ...g...))+  Bingo we get a hit.  So we can replace the 'g' binding with+     g = f++We can't use cs_map for this, because the key isn't an expression of+the program; it's a kind of synthetic key for recursive bindings.+++************************************************************************+*                                                                      *+\section{Common subexpression}+*                                                                      *+************************************************************************+-}++cseProgram :: CoreProgram -> CoreProgram+cseProgram binds = snd (mapAccumL (cseBind TopLevel) emptyCSEnv binds)++cseBind :: TopLevelFlag -> CSEnv -> CoreBind -> (CSEnv, CoreBind)+cseBind toplevel env (NonRec b e)+  = (env2, NonRec b2 e2)+  where+    (env1, b1)       = addBinder env b+    (env2, (b2, e2)) = cse_bind toplevel env1 (b,e) b1++cseBind _ env (Rec [(in_id, rhs)])+  | noCSE in_id+  = (env1, Rec [(out_id, rhs')])++  -- See Note [CSE for recursive bindings]+  | Just previous <- lookupCSRecEnv env out_id rhs''+  , let previous' = mkTicks ticks previous+  = (extendCSSubst env1 in_id previous', NonRec out_id previous')++  | otherwise+  = (extendCSRecEnv env1 out_id rhs'' id_expr', Rec [(zapped_id, rhs')])++  where+    (env1, [out_id]) = addRecBinders env [in_id]+    rhs'  = cseExpr env1 rhs+    rhs'' = stripTicksE tickishFloatable rhs'+    ticks = stripTicksT tickishFloatable rhs'+    id_expr'  = varToCoreExpr out_id+    zapped_id = zapIdUsageInfo out_id++cseBind toplevel env (Rec pairs)+  = (env2, Rec pairs')+  where+    (env1, bndrs1) = addRecBinders env (map fst pairs)+    (env2, pairs') = mapAccumL do_one env1 (zip pairs bndrs1)++    do_one env (pr, b1) = cse_bind toplevel env pr b1++cse_bind :: TopLevelFlag -> CSEnv -> (InId, InExpr) -> OutId -> (CSEnv, (OutId, OutExpr))+cse_bind toplevel env (in_id, in_rhs) out_id+  | isTopLevel toplevel, exprIsLiteralString in_rhs+      -- See Note [Take care with literal strings]+  = (env', (out_id, in_rhs))++  | otherwise+  = (env', (out_id', out_rhs))+  where+    out_rhs         = tryForCSE env in_rhs+    (env', out_id') = addBinding env in_id out_id out_rhs++addBinding :: CSEnv                      -- Includes InId->OutId cloning+           -> InVar                      -- Could be a let-bound type+           -> OutId -> OutExpr           -- Processed binding+           -> (CSEnv, OutId)             -- Final env, final bndr+-- Extend the CSE env with a mapping [rhs -> out-id]+-- unless we can instead just substitute [in-id -> rhs]+--+-- It's possible for the binder to be a type variable (see+-- Note [Type-let] in CoreSyn), in which case we can just substitute.+addBinding env in_id out_id rhs'+  | not (isId in_id) = (extendCSSubst env in_id rhs',     out_id)+  | noCSE in_id      = (env,                              out_id)+  | use_subst        = (extendCSSubst env in_id rhs',     out_id)+  | otherwise        = (extendCSEnv env rhs' id_expr', zapped_id)+  where+    id_expr'  = varToCoreExpr out_id+    zapped_id = zapIdUsageInfo out_id+       -- Putting the Id into the cs_map makes it possible that+       -- it'll become shared more than it is now, which would+       -- invalidate (the usage part of) its demand info.+       --    This caused Trac #100218.+       -- Easiest thing is to zap the usage info; subsequently+       -- performing late demand-analysis will restore it.  Don't zap+       -- the strictness info; it's not necessary to do so, and losing+       -- it is bad for performance if you don't do late demand+       -- analysis++    -- Should we use SUBSTITUTE or EXTEND?+    -- See Note [CSE for bindings]+    use_subst = case rhs' of+                   Var {} -> True+                   _      -> False++noCSE :: InId -> Bool+noCSE id =  not (isAlwaysActive (idInlineActivation id))+             -- See Note [CSE for INLINE and NOINLINE]+         || isAnyInlinePragma (idInlinePragma id)+             -- See Note [CSE for stable unfoldings]+         || isJoinId id+             -- See Note [CSE for join points?]+++{- Note [Take care with literal strings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this example:++  x = "foo"#+  y = "foo"#+  ...x...y...x...y....++We would normally turn this into:++  x = "foo"#+  y = x+  ...x...x...x...x....++But this breaks an invariant of Core, namely that the RHS of a top-level binding+of type Addr# must be a string literal, not another variable. See Note+[CoreSyn top-level string literals] in CoreSyn.++For this reason, we special case top-level bindings to literal strings and leave+the original RHS unmodified. This produces:++  x = "foo"#+  y = "foo"#+  ...x...x...x...x....++Now 'y' will be discarded as dead code, and we are done.++The net effect is that for the y-binding we want to+  - Use SUBSTITUTE, by extending the substitution with  y :-> x+  - but leave the original binding for y undisturbed++This is done by cse_bind.  I got it wrong the first time (Trac #13367).+-}++tryForCSE :: CSEnv -> InExpr -> OutExpr+tryForCSE env expr+  | Just e <- lookupCSEnv env expr'' = mkTicks ticks e+  | otherwise                        = expr'+    -- The varToCoreExpr is needed if we have+    --   case e of xco { ...case e of yco { ... } ... }+    -- Then CSE will substitute yco -> xco;+    -- but these are /coercion/ variables+  where+    expr'  = cseExpr env expr+    expr'' = stripTicksE tickishFloatable expr'+    ticks  = stripTicksT tickishFloatable expr'+    -- We don't want to lose the source notes when a common sub+    -- expression gets eliminated. Hence we push all (!) of them on+    -- top of the replaced sub-expression. This is probably not too+    -- useful in practice, but upholds our semantics.++cseOneExpr :: InExpr -> OutExpr+cseOneExpr = cseExpr emptyCSEnv++cseExpr :: CSEnv -> InExpr -> OutExpr+cseExpr env (Type t)              = Type (substTy (csEnvSubst env) t)+cseExpr env (Coercion c)          = Coercion (substCo (csEnvSubst env) c)+cseExpr _   (Lit lit)             = Lit lit+cseExpr env (Var v)               = lookupSubst env v+cseExpr env (App f a)             = App (cseExpr env f) (tryForCSE env a)+cseExpr env (Tick t e)            = Tick t (cseExpr env e)+cseExpr env (Cast e co)           = Cast (cseExpr env e) (substCo (csEnvSubst env) co)+cseExpr env (Lam b e)             = let (env', b') = addBinder env b+                                    in Lam b' (cseExpr env' e)+cseExpr env (Let bind e)          = let (env', bind') = cseBind NotTopLevel env bind+                                    in Let bind' (cseExpr env' e)+cseExpr env (Case e bndr ty alts) = cseCase env e bndr ty alts++cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr+cseCase env scrut bndr ty alts+  = Case scrut1 bndr3 ty' $+    combineAlts alt_env (map cse_alt alts)+  where+    ty' = substTy (csEnvSubst env) ty+    scrut1 = tryForCSE env scrut++    bndr1 = zapIdOccInfo bndr+      -- Zapping the OccInfo is needed because the extendCSEnv+      -- in cse_alt may mean that a dead case binder+      -- becomes alive, and Lint rejects that+    (env1, bndr2)    = addBinder env bndr1+    (alt_env, bndr3) = addBinding env1 bndr bndr2 scrut1+         -- addBinding: see Note [CSE for case expressions]++    con_target :: OutExpr+    con_target = lookupSubst alt_env bndr++    arg_tys :: [OutType]+    arg_tys = tyConAppArgs (idType bndr3)++    cse_alt (DataAlt con, args, rhs)+        | not (null args)+                -- Don't try CSE if there are no args; it just increases the number+                -- of live vars.  E.g.+                --      case x of { True -> ....True.... }+                -- Don't replace True by x!+                -- Hence the 'null args', which also deal with literals and DEFAULT+        = (DataAlt con, args', tryForCSE new_env rhs)+        where+          (env', args') = addBinders alt_env args+          new_env       = extendCSEnv env' con_expr con_target+          con_expr      = mkAltExpr (DataAlt con) args' arg_tys++    cse_alt (con, args, rhs)+        = (con, args', tryForCSE env' rhs)+        where+          (env', args') = addBinders alt_env args++combineAlts :: CSEnv -> [InAlt] -> [InAlt]+-- See Note [Combine case alternatives]+combineAlts env ((_,bndrs1,rhs1) : rest_alts)+  | all isDeadBinder bndrs1+  = (DEFAULT, [], rhs1) : filtered_alts+  where+    in_scope = substInScope (csEnvSubst env)+    filtered_alts = filterOut identical rest_alts+    identical (_con, bndrs, rhs) = all ok bndrs && eqExpr in_scope rhs1 rhs+    ok bndr = isDeadBinder bndr || not (bndr `elemInScopeSet` in_scope)++combineAlts _ alts = alts  -- Default case++{- Note [Combine case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+combineAlts is just a more heavyweight version of the use of+combineIdentialAlts in SimplUtils.prepareAlts.  The basic idea is+to transform++    DEFAULT -> e1+    K x     -> e1+    W y z   -> e2+===>+   DEFAULT -> e1+   W y z   -> e2++In the simplifier we use cheapEqExpr, because it is called a lot.+But here in CSE we use the full eqExpr.  After all, two alterantives usually+differ near the root, so it probably isn't expensive to compare the full+alternative.  It seems like the the same kind of thing that CSE is supposed+to be doing, which is why I put it here.++I acutally saw some examples in the wild, where some inlining made e1 too+big for cheapEqExpr to catch it.+++************************************************************************+*                                                                      *+\section{The CSE envt}+*                                                                      *+************************************************************************+-}++data CSEnv+  = CS { cs_subst :: Subst  -- Maps InBndrs to OutExprs+            -- The substitution variables to+            -- /trivial/ OutExprs, not arbitrary expressions++       , cs_map   :: CoreMap OutExpr   -- The reverse mapping+            -- Maps a OutExpr to a /trivial/ OutExpr+            -- The key of cs_map is stripped of all Ticks++       , cs_rec_map :: CoreMap OutExpr+            -- See Note [CSE for recursive bindings]+       }++emptyCSEnv :: CSEnv+emptyCSEnv = CS { cs_map = emptyCoreMap, cs_rec_map = emptyCoreMap+                , cs_subst = emptySubst }++lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr+lookupCSEnv (CS { cs_map = csmap }) expr+  = lookupCoreMap csmap expr++extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv+extendCSEnv cse expr triv_expr+  = cse { cs_map = extendCoreMap (cs_map cse) sexpr triv_expr }+  where+    sexpr = stripTicksE tickishFloatable expr++extendCSRecEnv :: CSEnv -> OutId -> OutExpr -> OutExpr -> CSEnv+-- See Note [CSE for recursive bindings]+extendCSRecEnv cse bndr expr triv_expr+  = cse { cs_rec_map = extendCoreMap (cs_rec_map cse) (Lam bndr expr) triv_expr }++lookupCSRecEnv :: CSEnv -> OutId -> OutExpr -> Maybe OutExpr+-- See Note [CSE for recursive bindings]+lookupCSRecEnv (CS { cs_rec_map = csmap }) bndr expr+  = lookupCoreMap csmap (Lam bndr expr)++csEnvSubst :: CSEnv -> Subst+csEnvSubst = cs_subst++lookupSubst :: CSEnv -> Id -> OutExpr+lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x++extendCSSubst :: CSEnv -> Id  -> CoreExpr -> CSEnv+extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs }++addBinder :: CSEnv -> Var -> (CSEnv, Var)+addBinder cse v = (cse { cs_subst = sub' }, v')+                where+                  (sub', v') = substBndr (cs_subst cse) v++addBinders :: CSEnv -> [Var] -> (CSEnv, [Var])+addBinders cse vs = (cse { cs_subst = sub' }, vs')+                where+                  (sub', vs') = substBndrs (cs_subst cse) vs++addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id])+addRecBinders cse vs = (cse { cs_subst = sub' }, vs')+                where+                  (sub', vs') = substRecBndrs (cs_subst cse) vs
+ simplCore/CallArity.hs view
@@ -0,0 +1,739 @@+--+-- Copyright (c) 2014 Joachim Breitner+--++module CallArity+    ( callArityAnalProgram+    , callArityRHS -- for testing+    ) where++import VarSet+import VarEnv+import DynFlags ( DynFlags )++import BasicTypes+import CoreSyn+import Id+import CoreArity ( typeArity )+import CoreUtils ( exprIsCheap, exprIsTrivial )+--import Outputable+import UnVarGraph+import Demand++import Control.Arrow ( first, second )+++{-+%************************************************************************+%*                                                                      *+              Call Arity Analyis+%*                                                                      *+%************************************************************************++Note [Call Arity: The goal]+~~~~~~~~~~~~~~~~~~~~~~~~~~~++The goal of this analysis is to find out if we can eta-expand a local function,+based on how it is being called. The motivating example is this code,+which comes up when we implement foldl using foldr, and do list fusion:++    let go = \x -> let d = case ... of+                              False -> go (x+1)+                              True  -> id+                   in \z -> d (x + z)+    in go 1 0++If we do not eta-expand `go` to have arity 2, we are going to allocate a lot of+partial function applications, which would be bad.++The function `go` has a type of arity two, but only one lambda is manifest.+Furthermore, an analysis that only looks at the RHS of go cannot be sufficient+to eta-expand go: If `go` is ever called with one argument (and the result used+multiple times), we would be doing the work in `...` multiple times.++So `callArityAnalProgram` looks at the whole let expression to figure out if+all calls are nice, i.e. have a high enough arity. It then stores the result in+the `calledArity` field of the `IdInfo` of `go`, which the next simplifier+phase will eta-expand.++The specification of the `calledArity` field is:++    No work will be lost if you eta-expand me to the arity in `calledArity`.++What we want to know for a variable+-----------------------------------++For every let-bound variable we'd like to know:+  1. A lower bound on the arity of all calls to the variable, and+  2. whether the variable is being called at most once or possible multiple+     times.++It is always ok to lower the arity, or pretend that there are multiple calls.+In particular, "Minimum arity 0 and possible called multiple times" is always+correct.+++What we want to know from an expression+---------------------------------------++In order to obtain that information for variables, we analyize expression and+obtain bits of information:++ I.  The arity analysis:+     For every variable, whether it is absent, or called,+     and if called, which what arity.++ II. The Co-Called analysis:+     For every two variables, whether there is a possibility that both are being+     called.+     We obtain as a special case: For every variables, whether there is a+     possibility that it is being called twice.++For efficiency reasons, we gather this information only for a set of+*interesting variables*, to avoid spending time on, e.g., variables from pattern matches.++The two analysis are not completely independent, as a higher arity can improve+the information about what variables are being called once or multiple times.++Note [Analysis I: The arity analyis]+------------------------------------++The arity analysis is quite straight forward: The information about an+expression is an+    VarEnv Arity+where absent variables are bound to Nothing and otherwise to a lower bound to+their arity.++When we analyize an expression, we analyize it with a given context arity.+Lambdas decrease and applications increase the incoming arity. Analysizing a+variable will put that arity in the environment. In lets or cases all the+results from the various subexpressions are lubed, which takes the point-wise+minimum (considering Nothing an infinity).+++Note [Analysis II: The Co-Called analysis]+------------------------------------------++The second part is more sophisticated. For reasons explained below, it is not+sufficient to simply know how often an expression evaluates a variable. Instead+we need to know which variables are possibly called together.++The data structure here is an undirected graph of variables, which is provided+by the abstract+    UnVarGraph++It is safe to return a larger graph, i.e. one with more edges. The worst case+(i.e. the least useful and always correct result) is the complete graph on all+free variables, which means that anything can be called together with anything+(including itself).++Notation for the following:+C(e)  is the co-called result for e.+G₁∪G₂ is the union of two graphs+fv    is the set of free variables (conveniently the domain of the arity analysis result)+S₁×S₂ is the complete bipartite graph { {a,b} | a ∈ S₁, b ∈ S₂ }+S²    is the complete graph on the set of variables S, S² = S×S+C'(e) is a variant for bound expression:+      If e is called at most once, or it is and stays a thunk (after the analysis),+      it is simply C(e). Otherwise, the expression can be called multiple times+      and we return (fv e)²++The interesting cases of the analysis:+ * Var v:+   No other variables are being called.+   Return {} (the empty graph)+ * Lambda v e, under arity 0:+   This means that e can be evaluated many times and we cannot get+   any useful co-call information.+   Return (fv e)²+ * Case alternatives alt₁,alt₂,...:+   Only one can be execuded, so+   Return (alt₁ ∪ alt₂ ∪...)+ * App e₁ e₂ (and analogously Case scrut alts), with non-trivial e₂:+   We get the results from both sides, with the argument evaluated at most once.+   Additionally, anything called by e₁ can possibly be called with anything+   from e₂.+   Return: C(e₁) ∪ C(e₂) ∪ (fv e₁) × (fv e₂)+ * App e₁ x:+   As this is already in A-normal form, CorePrep will not separately lambda+   bind (and hence share) x. So we conservatively assume multiple calls to x here+   Return: C(e₁) ∪ (fv e₁) × {x} ∪ {(x,x)}+ * Let v = rhs in body:+   In addition to the results from the subexpressions, add all co-calls from+   everything that the body calls together with v to everthing that is called+   by v.+   Return: C'(rhs) ∪ C(body) ∪ (fv rhs) × {v'| {v,v'} ∈ C(body)}+ * Letrec v₁ = rhs₁ ... vₙ = rhsₙ in body+   Tricky.+   We assume that it is really mutually recursive, i.e. that every variable+   calls one of the others, and that this is strongly connected (otherwise we+   return an over-approximation, so that's ok), see note [Recursion and fixpointing].++   Let V = {v₁,...vₙ}.+   Assume that the vs have been analysed with an incoming demand and+   cardinality consistent with the final result (this is the fixed-pointing).+   Again we can use the results from all subexpressions.+   In addition, for every variable vᵢ, we need to find out what it is called+   with (call this set Sᵢ). There are two cases:+    * If vᵢ is a function, we need to go through all right-hand-sides and bodies,+      and collect every variable that is called together with any variable from V:+      Sᵢ = {v' | j ∈ {1,...,n},      {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) }+    * If vᵢ is a thunk, then its rhs is evaluated only once, so we need to+      exclude it from this set:+      Sᵢ = {v' | j ∈ {1,...,n}, j≠i, {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) }+   Finally, combine all this:+   Return: C(body) ∪+           C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪+           (fv rhs₁) × S₁) ∪ ... ∪ (fv rhsₙ) × Sₙ)++Using the result: Eta-Expansion+-------------------------------++We use the result of these two analyses to decide whether we can eta-expand the+rhs of a let-bound variable.++If the variable is already a function (exprIsCheap), and all calls to the+variables have a higher arity than the current manifest arity (i.e. the number+of lambdas), expand.++If the variable is a thunk we must be careful: Eta-Expansion will prevent+sharing of work, so this is only safe if there is at most one call to the+function. Therefore, we check whether {v,v} ∈ G.++    Example:++        let n = case .. of .. -- A thunk!+        in n 0 + n 1++    vs.++        let n = case .. of ..+        in case .. of T -> n 0+                      F -> n 1++    We are only allowed to eta-expand `n` if it is going to be called at most+    once in the body of the outer let. So we need to know, for each variable+    individually, that it is going to be called at most once.+++Why the co-call graph?+----------------------++Why is it not sufficient to simply remember which variables are called once and+which are called multiple times? It would be in the previous example, but consider++        let n = case .. of ..+        in case .. of+            True -> let go = \y -> case .. of+                                     True -> go (y + n 1)+                                     False > n+                    in go 1+            False -> n++vs.++        let n = case .. of ..+        in case .. of+            True -> let go = \y -> case .. of+                                     True -> go (y+1)+                                     False > n+                    in go 1+            False -> n++In both cases, the body and the rhs of the inner let call n at most once.+But only in the second case that holds for the whole expression! The+crucial difference is that in the first case, the rhs of `go` can call+*both* `go` and `n`, and hence can call `n` multiple times as it recurses,+while in the second case find out that `go` and `n` are not called together.+++Why co-call information for functions?+--------------------------------------++Although for eta-expansion we need the information only for thunks, we still+need to know whether functions are being called once or multiple times, and+together with what other functions.++    Example:++        let n = case .. of ..+            f x = n (x+1)+        in f 1 + f 2++    vs.++        let n = case .. of ..+            f x = n (x+1)+        in case .. of T -> f 0+                      F -> f 1++    Here, the body of f calls n exactly once, but f itself is being called+    multiple times, so eta-expansion is not allowed.+++Note [Analysis type signature]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The work-hourse of the analysis is the function `callArityAnal`, with the+following type:++    type CallArityRes = (UnVarGraph, VarEnv Arity)+    callArityAnal ::+        Arity ->  -- The arity this expression is called with+        VarSet -> -- The set of interesting variables+        CoreExpr ->  -- The expression to analyse+        (CallArityRes, CoreExpr)++and the following specification:++  ((coCalls, callArityEnv), expr') = callArityEnv arity interestingIds expr++                            <=>++  Assume the expression `expr` is being passed `arity` arguments. Then it holds that+    * The domain of `callArityEnv` is a subset of `interestingIds`.+    * Any variable from `interestingIds` that is not mentioned in the `callArityEnv`+      is absent, i.e. not called at all.+    * Every call from `expr` to a variable bound to n in `callArityEnv` has at+      least n value arguments.+    * For two interesting variables `v1` and `v2`, they are not adjacent in `coCalls`,+      then in no execution of `expr` both are being called.+  Furthermore, expr' is expr with the callArity field of the `IdInfo` updated.+++Note [Which variables are interesting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The analysis would quickly become prohibitive expensive if we would analyse all+variables; for most variables we simply do not care about how often they are+called, i.e. variables bound in a pattern match. So interesting are variables that are+ * top-level or let bound+ * and possibly functions (typeArity > 0)++Note [Taking boring variables into account]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++If we decide that the variable bound in `let x = e1 in e2` is not interesting,+the analysis of `e2` will not report anything about `x`. To ensure that+`callArityBind` does still do the right thing we have to take that into account+everytime we would be lookup up `x` in the analysis result of `e2`.+  * Instead of calling lookupCallArityRes, we return (0, True), indicating+    that this variable might be called many times with no arguments.+  * Instead of checking `calledWith x`, we assume that everything can be called+    with it.+  * In the recursive case, when calclulating the `cross_calls`, if there is+    any boring variable in the recursive group, we ignore all co-call-results+    and directly go to a very conservative assumption.++The last point has the nice side effect that the relatively expensive+integration of co-call results in a recursive groups is often skipped. This+helped to avoid the compile time blowup in some real-world code with large+recursive groups (#10293).++Note [Recursion and fixpointing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++For a mutually recursive let, we begin by+ 1. analysing the body, using the same incoming arity as for the whole expression.+ 2. Then we iterate, memoizing for each of the bound variables the last+    analysis call, i.e. incoming arity, whether it is called once, and the CallArityRes.+ 3. We combine the analysis result from the body and the memoized results for+    the arguments (if already present).+ 4. For each variable, we find out the incoming arity and whether it is called+    once, based on the the current analysis result. If this differs from the+    memoized results, we re-analyse the rhs and update the memoized table.+ 5. If nothing had to be reanalyzed, we are done.+    Otherwise, repeat from step 3.+++Note [Thunks in recursive groups]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We never eta-expand a thunk in a recursive group, on the grounds that if it is+part of a recursive group, then it will be called multipe times.++This is not necessarily true, e.g.  it would be safe to eta-expand t2 (but not+t1) in the following code:++  let go x = t1+      t1 = if ... then t2 else ...+      t2 = if ... then go 1 else ...+  in go 0++Detecting this would require finding out what variables are only ever called+from thunks. While this is certainly possible, we yet have to see this to be+relevant in the wild.+++Note [Analysing top-level binds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We can eta-expand top-level-binds if they are not exported, as we see all calls+to them. The plan is as follows: Treat the top-level binds as nested lets around+a body representing “all external calls”, which returns a pessimistic+CallArityRes (the co-call graph is the complete graph, all arityies 0).++Note [Trimming arity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~++In the Call Arity papers, we are working on an untyped lambda calculus with no+other id annotations, where eta-expansion is always possible. But this is not+the case for Core!+ 1. We need to ensure the invariant+      callArity e <= typeArity (exprType e)+    for the same reasons that exprArity needs this invariant (see Note+    [exprArity invariant] in CoreArity).++    If we are not doing that, a too-high arity annotation will be stored with+    the id, confusing the simplifier later on.++ 2. Eta-expanding a right hand side might invalidate existing annotations. In+    particular, if an id has a strictness annotation of <...><...>b, then+    passing two arguments to it will definitely bottom out, so the simplifier+    will throw away additional parameters. This conflicts with Call Arity! So+    we ensure that we never eta-expand such a value beyond the number of+    arguments mentioned in the strictness signature.+    See #10176 for a real-world-example.++Note [What is a thunk]+~~~~~~~~~~~~~~~~~~~~~~++Originally, everything that is not in WHNF (`exprIsWHNF`) is considered a+thunk, not eta-expanded, to avoid losing any sharing. This is also how the+published papers on Call Arity describe it.++In practice, there are thunks that do a just little work, such as+pattern-matching on a variable, and the benefits of eta-expansion likely+oughtweigh the cost of doing that repeatedly. Therefore, this implementation of+Call Arity considers everything that is not cheap (`exprIsCheap`) as a thunk.+-}++-- Main entry point++callArityAnalProgram :: DynFlags -> CoreProgram -> CoreProgram+callArityAnalProgram _dflags binds = binds'+  where+    (_, binds') = callArityTopLvl [] emptyVarSet binds++-- See Note [Analysing top-level-binds]+callArityTopLvl :: [Var] -> VarSet -> [CoreBind] -> (CallArityRes, [CoreBind])+callArityTopLvl exported _ []+    = ( calledMultipleTimes $ (emptyUnVarGraph, mkVarEnv $ [(v, 0) | v <- exported])+      , [] )+callArityTopLvl exported int1 (b:bs)+    = (ae2, b':bs')+  where+    int2 = bindersOf b+    exported' = filter isExportedId int2 ++ exported+    int' = int1 `addInterestingBinds` b+    (ae1, bs') = callArityTopLvl exported' int' bs+    (ae2, b')  = callArityBind (boringBinds b) ae1 int1 b+++callArityRHS :: CoreExpr -> CoreExpr+callArityRHS = snd . callArityAnal 0 emptyVarSet++-- The main analysis function. See Note [Analysis type signature]+callArityAnal ::+    Arity ->  -- The arity this expression is called with+    VarSet -> -- The set of interesting variables+    CoreExpr ->  -- The expression to analyse+    (CallArityRes, CoreExpr)+        -- How this expression uses its interesting variables+        -- and the expression with IdInfo updated++-- The trivial base cases+callArityAnal _     _   e@(Lit _)+    = (emptyArityRes, e)+callArityAnal _     _   e@(Type _)+    = (emptyArityRes, e)+callArityAnal _     _   e@(Coercion _)+    = (emptyArityRes, e)+-- The transparent cases+callArityAnal arity int (Tick t e)+    = second (Tick t) $ callArityAnal arity int e+callArityAnal arity int (Cast e co)+    = second (\e -> Cast e co) $ callArityAnal arity int e++-- The interesting case: Variables, Lambdas, Lets, Applications, Cases+callArityAnal arity int e@(Var v)+    | v `elemVarSet` int+    = (unitArityRes v arity, e)+    | otherwise+    = (emptyArityRes, e)++-- Non-value lambdas are ignored+callArityAnal arity int (Lam v e) | not (isId v)+    = second (Lam v) $ callArityAnal arity (int `delVarSet` v) e++-- We have a lambda that may be called multiple times, so its free variables+-- can all be co-called.+callArityAnal 0     int (Lam v e)+    = (ae', Lam v e')+  where+    (ae, e') = callArityAnal 0 (int `delVarSet` v) e+    ae' = calledMultipleTimes ae+-- We have a lambda that we are calling. decrease arity.+callArityAnal arity int (Lam v e)+    = (ae, Lam v e')+  where+    (ae, e') = callArityAnal (arity - 1) (int `delVarSet` v) e++-- Application. Increase arity for the called expression, nothing to know about+-- the second+callArityAnal arity int (App e (Type t))+    = second (\e -> App e (Type t)) $ callArityAnal arity int e+callArityAnal arity int (App e1 e2)+    = (final_ae, App e1' e2')+  where+    (ae1, e1') = callArityAnal (arity + 1) int e1+    (ae2, e2') = callArityAnal 0           int e2+    -- If the argument is trivial (e.g. a variable), then it will _not_ be+    -- let-bound in the Core to STG transformation (CorePrep actually),+    -- so no sharing will happen here, and we have to assume many calls.+    ae2' | exprIsTrivial e2 = calledMultipleTimes ae2+         | otherwise        = ae2+    final_ae = ae1 `both` ae2'++-- Case expression.+callArityAnal arity int (Case scrut bndr ty alts)+    = -- pprTrace "callArityAnal:Case"+      --          (vcat [ppr scrut, ppr final_ae])+      (final_ae, Case scrut' bndr ty alts')+  where+    (alt_aes, alts') = unzip $ map go alts+    go (dc, bndrs, e) = let (ae, e') = callArityAnal arity int e+                        in  (ae, (dc, bndrs, e'))+    alt_ae = lubRess alt_aes+    (scrut_ae, scrut') = callArityAnal 0 int scrut+    final_ae = scrut_ae `both` alt_ae++-- For lets, use callArityBind+callArityAnal arity int (Let bind e)+  = -- pprTrace "callArityAnal:Let"+    --          (vcat [ppr v, ppr arity, ppr n, ppr final_ae ])+    (final_ae, Let bind' e')+  where+    int_body = int `addInterestingBinds` bind+    (ae_body, e') = callArityAnal arity int_body e+    (final_ae, bind') = callArityBind (boringBinds bind) ae_body int bind++-- Which bindings should we look at?+-- See Note [Which variables are interesting]+isInteresting :: Var -> Bool+isInteresting v = not $ null (typeArity (idType v))++interestingBinds :: CoreBind -> [Var]+interestingBinds = filter isInteresting . bindersOf++boringBinds :: CoreBind -> VarSet+boringBinds = mkVarSet . filter (not . isInteresting) . bindersOf++addInterestingBinds :: VarSet -> CoreBind -> VarSet+addInterestingBinds int bind+    = int `delVarSetList`    bindersOf bind -- Possible shadowing+          `extendVarSetList` interestingBinds bind++-- Used for both local and top-level binds+-- Second argument is the demand from the body+callArityBind :: VarSet -> CallArityRes -> VarSet -> CoreBind -> (CallArityRes, CoreBind)+-- Non-recursive let+callArityBind boring_vars ae_body int (NonRec v rhs)+  | otherwise+  = -- pprTrace "callArityBind:NonRec"+    --          (vcat [ppr v, ppr ae_body, ppr int, ppr ae_rhs, ppr safe_arity])+    (final_ae, NonRec v' rhs')+  where+    is_thunk = not (exprIsCheap rhs) -- see note [What is a thunk]+    -- If v is boring, we will not find it in ae_body, but always assume (0, False)+    boring = v `elemVarSet` boring_vars++    (arity, called_once)+        | boring    = (0, False) -- See Note [Taking boring variables into account]+        | otherwise = lookupCallArityRes ae_body v+    safe_arity | called_once = arity+               | is_thunk    = 0      -- A thunk! Do not eta-expand+               | otherwise   = arity++    -- See Note [Trimming arity]+    trimmed_arity = trimArity v safe_arity++    (ae_rhs, rhs') = callArityAnal trimmed_arity int rhs+++    ae_rhs'| called_once     = ae_rhs+           | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once+           | otherwise       = calledMultipleTimes ae_rhs++    called_by_v = domRes ae_rhs'+    called_with_v+        | boring    = domRes ae_body+        | otherwise = calledWith ae_body v `delUnVarSet` v+    final_ae = addCrossCoCalls called_by_v called_with_v $ ae_rhs' `lubRes` resDel v ae_body++    v' = v `setIdCallArity` trimmed_arity+++-- Recursive let. See Note [Recursion and fixpointing]+callArityBind boring_vars ae_body int b@(Rec binds)+  = -- (if length binds > 300 then+    -- pprTrace "callArityBind:Rec"+    --           (vcat [ppr (Rec binds'), ppr ae_body, ppr int, ppr ae_rhs]) else id) $+    (final_ae, Rec binds')+  where+    -- See Note [Taking boring variables into account]+    any_boring = any (`elemVarSet` boring_vars) [ i | (i, _) <- binds]++    int_body = int `addInterestingBinds` b+    (ae_rhs, binds') = fix initial_binds+    final_ae = bindersOf b `resDelList` ae_rhs++    initial_binds = [(i,Nothing,e) | (i,e) <- binds]++    fix :: [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)] -> (CallArityRes, [(Id, CoreExpr)])+    fix ann_binds+        | -- pprTrace "callArityBind:fix" (vcat [ppr ann_binds, ppr any_change, ppr ae]) $+          any_change+        = fix ann_binds'+        | otherwise+        = (ae, map (\(i, _, e) -> (i, e)) ann_binds')+      where+        aes_old = [ (i,ae) | (i, Just (_,_,ae), _) <- ann_binds ]+        ae = callArityRecEnv any_boring aes_old ae_body++        rerun (i, mbLastRun, rhs)+            | i `elemVarSet` int_body && not (i `elemUnVarSet` domRes ae)+            -- No call to this yet, so do nothing+            = (False, (i, Nothing, rhs))++            | Just (old_called_once, old_arity, _) <- mbLastRun+            , called_once == old_called_once+            , new_arity == old_arity+            -- No change, no need to re-analyze+            = (False, (i, mbLastRun, rhs))++            | otherwise+            -- We previously analyzed this with a different arity (or not at all)+            = let is_thunk = not (exprIsCheap rhs) -- see note [What is a thunk]++                  safe_arity | is_thunk    = 0  -- See Note [Thunks in recursive groups]+                             | otherwise   = new_arity++                  -- See Note [Trimming arity]+                  trimmed_arity = trimArity i safe_arity++                  (ae_rhs, rhs') = callArityAnal trimmed_arity int_body rhs++                  ae_rhs' | called_once     = ae_rhs+                          | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once+                          | otherwise       = calledMultipleTimes ae_rhs++              in (True, (i `setIdCallArity` trimmed_arity, Just (called_once, new_arity, ae_rhs'), rhs'))+          where+            -- See Note [Taking boring variables into account]+            (new_arity, called_once) | i `elemVarSet` boring_vars = (0, False)+                                     | otherwise                  = lookupCallArityRes ae i++        (changes, ann_binds') = unzip $ map rerun ann_binds+        any_change = or changes++-- Combining the results from body and rhs, (mutually) recursive case+-- See Note [Analysis II: The Co-Called analysis]+callArityRecEnv :: Bool -> [(Var, CallArityRes)] -> CallArityRes -> CallArityRes+callArityRecEnv any_boring ae_rhss ae_body+    = -- (if length ae_rhss > 300 then pprTrace "callArityRecEnv" (vcat [ppr ae_rhss, ppr ae_body, ppr ae_new]) else id) $+      ae_new+  where+    vars = map fst ae_rhss++    ae_combined = lubRess (map snd ae_rhss) `lubRes` ae_body++    cross_calls+        -- See Note [Taking boring variables into account]+        | any_boring          = completeGraph (domRes ae_combined)+        -- Also, calculating cross_calls is expensive. Simply be conservative+        -- if the mutually recursive group becomes too large.+        | length ae_rhss > 25 = completeGraph (domRes ae_combined)+        | otherwise           = unionUnVarGraphs $ map cross_call ae_rhss+    cross_call (v, ae_rhs) = completeBipartiteGraph called_by_v called_with_v+      where+        is_thunk = idCallArity v == 0+        -- What rhs are relevant as happening before (or after) calling v?+        --    If v is a thunk, everything from all the _other_ variables+        --    If v is not a thunk, everything can happen.+        ae_before_v | is_thunk  = lubRess (map snd $ filter ((/= v) . fst) ae_rhss) `lubRes` ae_body+                    | otherwise = ae_combined+        -- What do we want to know from these?+        -- Which calls can happen next to any recursive call.+        called_with_v+            = unionUnVarSets $ map (calledWith ae_before_v) vars+        called_by_v = domRes ae_rhs++    ae_new = first (cross_calls `unionUnVarGraph`) ae_combined++-- See Note [Trimming arity]+trimArity :: Id -> Arity -> Arity+trimArity v a = minimum [a, max_arity_by_type, max_arity_by_strsig]+  where+    max_arity_by_type = length (typeArity (idType v))+    max_arity_by_strsig+        | isBotRes result_info = length demands+        | otherwise = a++    (demands, result_info) = splitStrictSig (idStrictness v)++---------------------------------------+-- Functions related to CallArityRes --+---------------------------------------++-- Result type for the two analyses.+-- See Note [Analysis I: The arity analyis]+-- and Note [Analysis II: The Co-Called analysis]+type CallArityRes = (UnVarGraph, VarEnv Arity)++emptyArityRes :: CallArityRes+emptyArityRes = (emptyUnVarGraph, emptyVarEnv)++unitArityRes :: Var -> Arity -> CallArityRes+unitArityRes v arity = (emptyUnVarGraph, unitVarEnv v arity)++resDelList :: [Var] -> CallArityRes -> CallArityRes+resDelList vs ae = foldr resDel ae vs++resDel :: Var -> CallArityRes -> CallArityRes+resDel v (g, ae) = (g `delNode` v, ae `delVarEnv` v)++domRes :: CallArityRes -> UnVarSet+domRes (_, ae) = varEnvDom ae++-- In the result, find out the minimum arity and whether the variable is called+-- at most once.+lookupCallArityRes :: CallArityRes -> Var -> (Arity, Bool)+lookupCallArityRes (g, ae) v+    = case lookupVarEnv ae v of+        Just a -> (a, not (v `elemUnVarSet` (neighbors g v)))+        Nothing -> (0, False)++calledWith :: CallArityRes -> Var -> UnVarSet+calledWith (g, _) v = neighbors g v++addCrossCoCalls :: UnVarSet -> UnVarSet -> CallArityRes -> CallArityRes+addCrossCoCalls set1 set2 = first (completeBipartiteGraph set1 set2 `unionUnVarGraph`)++-- Replaces the co-call graph by a complete graph (i.e. no information)+calledMultipleTimes :: CallArityRes -> CallArityRes+calledMultipleTimes res = first (const (completeGraph (domRes res))) res++-- Used for application and cases+both :: CallArityRes -> CallArityRes -> CallArityRes+both r1 r2 = addCrossCoCalls (domRes r1) (domRes r2) $ r1 `lubRes` r2++-- Used when combining results from alternative cases; take the minimum+lubRes :: CallArityRes -> CallArityRes -> CallArityRes+lubRes (g1, ae1) (g2, ae2) = (g1 `unionUnVarGraph` g2, ae1 `lubArityEnv` ae2)++lubArityEnv :: VarEnv Arity -> VarEnv Arity -> VarEnv Arity+lubArityEnv = plusVarEnv_C min++lubRess :: [CallArityRes] -> CallArityRes+lubRess = foldl lubRes emptyArityRes
+ simplCore/CoreMonad.hs view
@@ -0,0 +1,814 @@+{-+(c) The AQUA Project, Glasgow University, 1993-1998++\section[CoreMonad]{The core pipeline monad}+-}++{-# LANGUAGE CPP #-}++module CoreMonad (+    -- * Configuration of the core-to-core passes+    CoreToDo(..), runWhen, runMaybe,+    SimplifierMode(..),+    FloatOutSwitches(..),+    pprPassDetails,++    -- * Plugins+    PluginPass, bindsOnlyPass,++    -- * Counting+    SimplCount, doSimplTick, doFreeSimplTick, simplCountN,+    pprSimplCount, plusSimplCount, zeroSimplCount,+    isZeroSimplCount, hasDetailedCounts, Tick(..),++    -- * The monad+    CoreM, runCoreM,++    -- ** Reading from the monad+    getHscEnv, getRuleBase, getModule,+    getDynFlags, getOrigNameCache, getPackageFamInstEnv,+    getVisibleOrphanMods,+    getPrintUnqualified, getSrcSpanM,++    -- ** Writing to the monad+    addSimplCount,++    -- ** Lifting into the monad+    liftIO, liftIOWithCount,+    liftIO1, liftIO2, liftIO3, liftIO4,++    -- ** Global initialization+    reinitializeGlobals,++    -- ** Dealing with annotations+    getAnnotations, getFirstAnnotations,++    -- ** Screen output+    putMsg, putMsgS, errorMsg, errorMsgS, warnMsg,+    fatalErrorMsg, fatalErrorMsgS,+    debugTraceMsg, debugTraceMsgS,+    dumpIfSet_dyn,++    -- * Getting 'Name's+    thNameToGhcName+  ) where++import Name( Name )+import TcRnMonad        ( initTcForLookup )+import CoreSyn+import HscTypes+import Module+import DynFlags+import BasicTypes       ( CompilerPhase(..) )+import Annotations++import IOEnv hiding     ( liftIO, failM, failWithM )+import qualified IOEnv  ( liftIO )+import TcEnv            ( lookupGlobal )+import Var+import Outputable+import FastString+import qualified ErrUtils as Err+import ErrUtils( Severity(..) )+import Maybes+import UniqSupply+import UniqFM       ( UniqFM, mapUFM, filterUFM )+import MonadUtils+import NameCache+import SrcLoc+import ListSetOps       ( runs )+import Data.List+import Data.Ord+import Data.Dynamic+import Data.IORef+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Map.Strict as MapStrict+import Data.Word+import Control.Monad+import Control.Applicative ( Alternative(..) )++import Prelude hiding   ( read )++import {-# SOURCE #-} TcSplice ( lookupThName_maybe )+import qualified Language.Haskell.TH as TH++{-+************************************************************************+*                                                                      *+              The CoreToDo type and related types+          Abstraction of core-to-core passes to run.+*                                                                      *+************************************************************************+-}++data CoreToDo           -- These are diff core-to-core passes,+                        -- which may be invoked in any order,+                        -- as many times as you like.++  = CoreDoSimplify      -- The core-to-core simplifier.+        Int                    -- Max iterations+        SimplifierMode+  | CoreDoPluginPass String PluginPass+  | CoreDoFloatInwards+  | CoreDoFloatOutwards FloatOutSwitches+  | CoreLiberateCase+  | CoreDoPrintCore+  | CoreDoStaticArgs+  | CoreDoCallArity+  | CoreDoStrictness+  | CoreDoWorkerWrapper+  | CoreDoSpecialising+  | CoreDoSpecConstr+  | CoreCSE+  | CoreDoRuleCheck CompilerPhase String   -- Check for non-application of rules+                                           -- matching this string+  | CoreDoVectorisation+  | CoreDoNothing                -- Useful when building up+  | CoreDoPasses [CoreToDo]      -- lists of these things++  | CoreDesugar    -- Right after desugaring, no simple optimisation yet!+  | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces+                       --                 Core output, and hence useful to pass to endPass++  | CoreTidy+  | CorePrep+  | CoreOccurAnal++instance Outputable CoreToDo where+  ppr (CoreDoSimplify _ _)     = text "Simplifier"+  ppr (CoreDoPluginPass s _)   = text "Core plugin: " <+> text s+  ppr CoreDoFloatInwards       = text "Float inwards"+  ppr (CoreDoFloatOutwards f)  = text "Float out" <> parens (ppr f)+  ppr CoreLiberateCase         = text "Liberate case"+  ppr CoreDoStaticArgs         = text "Static argument"+  ppr CoreDoCallArity          = text "Called arity analysis"+  ppr CoreDoStrictness         = text "Demand analysis"+  ppr CoreDoWorkerWrapper      = text "Worker Wrapper binds"+  ppr CoreDoSpecialising       = text "Specialise"+  ppr CoreDoSpecConstr         = text "SpecConstr"+  ppr CoreCSE                  = text "Common sub-expression"+  ppr CoreDoVectorisation      = text "Vectorisation"+  ppr CoreDesugar              = text "Desugar (before optimization)"+  ppr CoreDesugarOpt           = text "Desugar (after optimization)"+  ppr CoreTidy                 = text "Tidy Core"+  ppr CorePrep                 = text "CorePrep"+  ppr CoreOccurAnal            = text "Occurrence analysis"+  ppr CoreDoPrintCore          = text "Print core"+  ppr (CoreDoRuleCheck {})     = text "Rule check"+  ppr CoreDoNothing            = text "CoreDoNothing"+  ppr (CoreDoPasses passes)    = text "CoreDoPasses" <+> ppr passes++pprPassDetails :: CoreToDo -> SDoc+pprPassDetails (CoreDoSimplify n md) = vcat [ text "Max iterations =" <+> int n+                                            , ppr md ]+pprPassDetails _ = Outputable.empty++data SimplifierMode             -- See comments in SimplMonad+  = SimplMode+        { sm_names      :: [String] -- Name(s) of the phase+        , sm_phase      :: CompilerPhase+        , sm_rules      :: Bool     -- Whether RULES are enabled+        , sm_inline     :: Bool     -- Whether inlining is enabled+        , sm_case_case  :: Bool     -- Whether case-of-case is enabled+        , sm_eta_expand :: Bool     -- Whether eta-expansion is enabled+        }++instance Outputable SimplifierMode where+    ppr (SimplMode { sm_phase = p, sm_names = ss+                   , sm_rules = r, sm_inline = i+                   , sm_eta_expand = eta, sm_case_case = cc })+       = text "SimplMode" <+> braces (+         sep [ text "Phase =" <+> ppr p <+>+               brackets (text (concat $ intersperse "," ss)) <> comma+             , pp_flag i   (sLit "inline") <> comma+             , pp_flag r   (sLit "rules") <> comma+             , pp_flag eta (sLit "eta-expand") <> comma+             , pp_flag cc  (sLit "case-of-case") ])+         where+           pp_flag f s = ppUnless f (text "no") <+> ptext s++data FloatOutSwitches = FloatOutSwitches {+  floatOutLambdas   :: Maybe Int,  -- ^ Just n <=> float lambdas to top level, if+                                   -- doing so will abstract over n or fewer+                                   -- value variables+                                   -- Nothing <=> float all lambdas to top level,+                                   --             regardless of how many free variables+                                   -- Just 0 is the vanilla case: float a lambda+                                   --    iff it has no free vars++  floatOutConstants :: Bool,       -- ^ True <=> float constants to top level,+                                   --            even if they do not escape a lambda+  floatOutOverSatApps :: Bool,+                             -- ^ True <=> float out over-saturated applications+                             --            based on arity information.+                             -- See Note [Floating over-saturated applications]+                             -- in SetLevels+  floatToTopLevelOnly :: Bool      -- ^ Allow floating to the top level only.+  }+instance Outputable FloatOutSwitches where+    ppr = pprFloatOutSwitches++pprFloatOutSwitches :: FloatOutSwitches -> SDoc+pprFloatOutSwitches sw+  = text "FOS" <+> (braces $+     sep $ punctuate comma $+     [ text "Lam ="    <+> ppr (floatOutLambdas sw)+     , text "Consts =" <+> ppr (floatOutConstants sw)+     , text "OverSatApps ="   <+> ppr (floatOutOverSatApps sw) ])++-- The core-to-core pass ordering is derived from the DynFlags:+runWhen :: Bool -> CoreToDo -> CoreToDo+runWhen True  do_this = do_this+runWhen False _       = CoreDoNothing++runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo+runMaybe (Just x) f = f x+runMaybe Nothing  _ = CoreDoNothing++{-++************************************************************************+*                                                                      *+             Types for Plugins+*                                                                      *+************************************************************************+-}++-- | A description of the plugin pass itself+type PluginPass = ModGuts -> CoreM ModGuts++bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts+bindsOnlyPass pass guts+  = do { binds' <- pass (mg_binds guts)+       ; return (guts { mg_binds = binds' }) }++{-+************************************************************************+*                                                                      *+             Counting and logging+*                                                                      *+************************************************************************+-}++getVerboseSimplStats :: (Bool -> SDoc) -> SDoc+getVerboseSimplStats = sdocWithPprDebug          -- For now, anyway++zeroSimplCount     :: DynFlags -> SimplCount+isZeroSimplCount   :: SimplCount -> Bool+hasDetailedCounts  :: SimplCount -> Bool+pprSimplCount      :: SimplCount -> SDoc+doSimplTick        :: DynFlags -> Tick -> SimplCount -> SimplCount+doFreeSimplTick    ::             Tick -> SimplCount -> SimplCount+plusSimplCount     :: SimplCount -> SimplCount -> SimplCount++data SimplCount+   = VerySimplCount !Int        -- Used when don't want detailed stats++   | SimplCount {+        ticks   :: !Int,        -- Total ticks+        details :: !TickCounts, -- How many of each type++        n_log   :: !Int,        -- N+        log1    :: [Tick],      -- Last N events; <= opt_HistorySize,+                                --   most recent first+        log2    :: [Tick]       -- Last opt_HistorySize events before that+                                -- Having log1, log2 lets us accumulate the+                                -- recent history reasonably efficiently+     }++type TickCounts = Map Tick Int++simplCountN :: SimplCount -> Int+simplCountN (VerySimplCount n)         = n+simplCountN (SimplCount { ticks = n }) = n++zeroSimplCount dflags+                -- This is where we decide whether to do+                -- the VerySimpl version or the full-stats version+  | dopt Opt_D_dump_simpl_stats dflags+  = SimplCount {ticks = 0, details = Map.empty,+                n_log = 0, log1 = [], log2 = []}+  | otherwise+  = VerySimplCount 0++isZeroSimplCount (VerySimplCount n)         = n==0+isZeroSimplCount (SimplCount { ticks = n }) = n==0++hasDetailedCounts (VerySimplCount {}) = False+hasDetailedCounts (SimplCount {})     = True++doFreeSimplTick tick sc@SimplCount { details = dts }+  = sc { details = dts `addTick` tick }+doFreeSimplTick _ sc = sc++doSimplTick dflags tick+    sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 })+  | nl >= historySize dflags = sc1 { n_log = 1, log1 = [tick], log2 = l1 }+  | otherwise                = sc1 { n_log = nl+1, log1 = tick : l1 }+  where+    sc1 = sc { ticks = tks+1, details = dts `addTick` tick }++doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1)+++addTick :: TickCounts -> Tick -> TickCounts+addTick fm tick = MapStrict.insertWith (+) tick 1 fm++plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })+               sc2@(SimplCount { ticks = tks2, details = dts2 })+  = log_base { ticks = tks1 + tks2+             , details = MapStrict.unionWith (+) dts1 dts2 }+  where+        -- A hackish way of getting recent log info+    log_base | null (log1 sc2) = sc1    -- Nothing at all in sc2+             | null (log2 sc2) = sc2 { log2 = log1 sc1 }+             | otherwise       = sc2++plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)+plusSimplCount _                  _                  = panic "plusSimplCount"+       -- We use one or the other consistently++pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n+pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })+  = vcat [text "Total ticks:    " <+> int tks,+          blankLine,+          pprTickCounts dts,+          getVerboseSimplStats $ \dbg -> if dbg+          then+                vcat [blankLine,+                      text "Log (most recent first)",+                      nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]+          else Outputable.empty+    ]++pprTickCounts :: Map Tick Int -> SDoc+pprTickCounts counts+  = vcat (map pprTickGroup groups)+  where+    groups :: [[(Tick,Int)]]    -- Each group shares a comon tag+                                -- toList returns common tags adjacent+    groups = runs same_tag (Map.toList counts)+    same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2++pprTickGroup :: [(Tick, Int)] -> SDoc+pprTickGroup group@((tick1,_):_)+  = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1))+       2 (vcat [ int n <+> pprTickCts tick+                                    -- flip as we want largest first+               | (tick,n) <- sortBy (flip (comparing snd)) group])+pprTickGroup [] = panic "pprTickGroup"++data Tick+  = PreInlineUnconditionally    Id+  | PostInlineUnconditionally   Id++  | UnfoldingDone               Id+  | RuleFired                   FastString      -- Rule name++  | LetFloatFromLet+  | EtaExpansion                Id      -- LHS binder+  | EtaReduction                Id      -- Binder on outer lambda+  | BetaReduction               Id      -- Lambda binder+++  | CaseOfCase                  Id      -- Bndr on *inner* case+  | KnownBranch                 Id      -- Case binder+  | CaseMerge                   Id      -- Binder on outer case+  | AltMerge                    Id      -- Case binder+  | CaseElim                    Id      -- Case binder+  | CaseIdentity                Id      -- Case binder+  | FillInCaseDefault           Id      -- Case binder++  | BottomFound+  | SimplifierDone              -- Ticked at each iteration of the simplifier++instance Outputable Tick where+  ppr tick = text (tickString tick) <+> pprTickCts tick++instance Eq Tick where+  a == b = case a `cmpTick` b of+           EQ -> True+           _ -> False++instance Ord Tick where+  compare = cmpTick++tickToTag :: Tick -> Int+tickToTag (PreInlineUnconditionally _)  = 0+tickToTag (PostInlineUnconditionally _) = 1+tickToTag (UnfoldingDone _)             = 2+tickToTag (RuleFired _)                 = 3+tickToTag LetFloatFromLet               = 4+tickToTag (EtaExpansion _)              = 5+tickToTag (EtaReduction _)              = 6+tickToTag (BetaReduction _)             = 7+tickToTag (CaseOfCase _)                = 8+tickToTag (KnownBranch _)               = 9+tickToTag (CaseMerge _)                 = 10+tickToTag (CaseElim _)                  = 11+tickToTag (CaseIdentity _)              = 12+tickToTag (FillInCaseDefault _)         = 13+tickToTag BottomFound                   = 14+tickToTag SimplifierDone                = 16+tickToTag (AltMerge _)                  = 17++tickString :: Tick -> String+tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"+tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"+tickString (UnfoldingDone _)            = "UnfoldingDone"+tickString (RuleFired _)                = "RuleFired"+tickString LetFloatFromLet              = "LetFloatFromLet"+tickString (EtaExpansion _)             = "EtaExpansion"+tickString (EtaReduction _)             = "EtaReduction"+tickString (BetaReduction _)            = "BetaReduction"+tickString (CaseOfCase _)               = "CaseOfCase"+tickString (KnownBranch _)              = "KnownBranch"+tickString (CaseMerge _)                = "CaseMerge"+tickString (AltMerge _)                 = "AltMerge"+tickString (CaseElim _)                 = "CaseElim"+tickString (CaseIdentity _)             = "CaseIdentity"+tickString (FillInCaseDefault _)        = "FillInCaseDefault"+tickString BottomFound                  = "BottomFound"+tickString SimplifierDone               = "SimplifierDone"++pprTickCts :: Tick -> SDoc+pprTickCts (PreInlineUnconditionally v) = ppr v+pprTickCts (PostInlineUnconditionally v)= ppr v+pprTickCts (UnfoldingDone v)            = ppr v+pprTickCts (RuleFired v)                = ppr v+pprTickCts LetFloatFromLet              = Outputable.empty+pprTickCts (EtaExpansion v)             = ppr v+pprTickCts (EtaReduction v)             = ppr v+pprTickCts (BetaReduction v)            = ppr v+pprTickCts (CaseOfCase v)               = ppr v+pprTickCts (KnownBranch v)              = ppr v+pprTickCts (CaseMerge v)                = ppr v+pprTickCts (AltMerge v)                 = ppr v+pprTickCts (CaseElim v)                 = ppr v+pprTickCts (CaseIdentity v)             = ppr v+pprTickCts (FillInCaseDefault v)        = ppr v+pprTickCts _                            = Outputable.empty++cmpTick :: Tick -> Tick -> Ordering+cmpTick a b = case (tickToTag a `compare` tickToTag b) of+                GT -> GT+                EQ -> cmpEqTick a b+                LT -> LT++cmpEqTick :: Tick -> Tick -> Ordering+cmpEqTick (PreInlineUnconditionally a)  (PreInlineUnconditionally b)    = a `compare` b+cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b)   = a `compare` b+cmpEqTick (UnfoldingDone a)             (UnfoldingDone b)               = a `compare` b+cmpEqTick (RuleFired a)                 (RuleFired b)                   = a `compare` b+cmpEqTick (EtaExpansion a)              (EtaExpansion b)                = a `compare` b+cmpEqTick (EtaReduction a)              (EtaReduction b)                = a `compare` b+cmpEqTick (BetaReduction a)             (BetaReduction b)               = a `compare` b+cmpEqTick (CaseOfCase a)                (CaseOfCase b)                  = a `compare` b+cmpEqTick (KnownBranch a)               (KnownBranch b)                 = a `compare` b+cmpEqTick (CaseMerge a)                 (CaseMerge b)                   = a `compare` b+cmpEqTick (AltMerge a)                  (AltMerge b)                    = a `compare` b+cmpEqTick (CaseElim a)                  (CaseElim b)                    = a `compare` b+cmpEqTick (CaseIdentity a)              (CaseIdentity b)                = a `compare` b+cmpEqTick (FillInCaseDefault a)         (FillInCaseDefault b)           = a `compare` b+cmpEqTick _                             _                               = EQ++{-+************************************************************************+*                                                                      *+             Monad and carried data structure definitions+*                                                                      *+************************************************************************+-}++newtype CoreState = CoreState {+        cs_uniq_supply :: UniqSupply+}++data CoreReader = CoreReader {+        cr_hsc_env             :: HscEnv,+        cr_rule_base           :: RuleBase,+        cr_module              :: Module,+        cr_print_unqual        :: PrintUnqualified,+        cr_loc                 :: SrcSpan,   -- Use this for log/error messages so they+                                             -- are at least tagged with the right source file+        cr_visible_orphan_mods :: !ModuleSet+}++-- Note: CoreWriter used to be defined with data, rather than newtype.  If it+-- is defined that way again, the cw_simpl_count field, at least, must be+-- strict to avoid a space leak (Trac #7702).+newtype CoreWriter = CoreWriter {+        cw_simpl_count :: SimplCount+}++emptyWriter :: DynFlags -> CoreWriter+emptyWriter dflags = CoreWriter {+        cw_simpl_count = zeroSimplCount dflags+    }++plusWriter :: CoreWriter -> CoreWriter -> CoreWriter+plusWriter w1 w2 = CoreWriter {+        cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)+    }++type CoreIOEnv = IOEnv CoreReader++-- | The monad used by Core-to-Core passes to access common state, register simplification+-- statistics and so on+newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }++instance Functor CoreM where+    fmap = liftM++instance Monad CoreM where+    mx >>= f = CoreM $ \s -> do+            (x, s', w1) <- unCoreM mx s+            (y, s'', w2) <- unCoreM (f x) s'+            let w = w1 `plusWriter` w2+            return $ seq w (y, s'', w)+            -- forcing w before building the tuple avoids a space leak+            -- (Trac #7702)++instance Applicative CoreM where+    pure x = CoreM $ \s -> nop s x+    (<*>) = ap+    m *> k = m >>= \_ -> k++instance Alternative CoreM where+    empty   = CoreM (const Control.Applicative.empty)+    m <|> n = CoreM (\rs -> unCoreM m rs <|> unCoreM n rs)++instance MonadPlus CoreM++instance MonadUnique CoreM where+    getUniqueSupplyM = do+        us <- getS cs_uniq_supply+        let (us1, us2) = splitUniqSupply us+        modifyS (\s -> s { cs_uniq_supply = us2 })+        return us1++    getUniqueM = do+        us <- getS cs_uniq_supply+        let (u,us') = takeUniqFromSupply us+        modifyS (\s -> s { cs_uniq_supply = us' })+        return u++runCoreM :: HscEnv+         -> RuleBase+         -> UniqSupply+         -> Module+         -> ModuleSet+         -> PrintUnqualified+         -> SrcSpan+         -> CoreM a+         -> IO (a, SimplCount)+runCoreM hsc_env rule_base us mod orph_imps print_unqual loc m+  = liftM extract $ runIOEnv reader $ unCoreM m state+  where+    reader = CoreReader {+            cr_hsc_env = hsc_env,+            cr_rule_base = rule_base,+            cr_module = mod,+            cr_visible_orphan_mods = orph_imps,+            cr_print_unqual = print_unqual,+            cr_loc = loc+        }+    state = CoreState {+            cs_uniq_supply = us+        }++    extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)+    extract (value, _, writer) = (value, cw_simpl_count writer)++{-+************************************************************************+*                                                                      *+             Core combinators, not exported+*                                                                      *+************************************************************************+-}++nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)+nop s x = do+    r <- getEnv+    return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)++read :: (CoreReader -> a) -> CoreM a+read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))++getS :: (CoreState -> a) -> CoreM a+getS f = CoreM (\s -> nop s (f s))++modifyS :: (CoreState -> CoreState) -> CoreM ()+modifyS f = CoreM (\s -> nop (f s) ())++write :: CoreWriter -> CoreM ()+write w = CoreM (\s -> return ((), s, w))++-- \subsection{Lifting IO into the monad}++-- | Lift an 'IOEnv' operation into 'CoreM'+liftIOEnv :: CoreIOEnv a -> CoreM a+liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))++instance MonadIO CoreM where+    liftIO = liftIOEnv . IOEnv.liftIO++-- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'+liftIOWithCount :: IO (SimplCount, a) -> CoreM a+liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)++{-+************************************************************************+*                                                                      *+             Reader, writer and state accessors+*                                                                      *+************************************************************************+-}++getHscEnv :: CoreM HscEnv+getHscEnv = read cr_hsc_env++getRuleBase :: CoreM RuleBase+getRuleBase = read cr_rule_base++getVisibleOrphanMods :: CoreM ModuleSet+getVisibleOrphanMods = read cr_visible_orphan_mods++getPrintUnqualified :: CoreM PrintUnqualified+getPrintUnqualified = read cr_print_unqual++getSrcSpanM :: CoreM SrcSpan+getSrcSpanM = read cr_loc++addSimplCount :: SimplCount -> CoreM ()+addSimplCount count = write (CoreWriter { cw_simpl_count = count })++-- Convenience accessors for useful fields of HscEnv++instance HasDynFlags CoreM where+    getDynFlags = fmap hsc_dflags getHscEnv++instance HasModule CoreM where+    getModule = read cr_module++-- | The original name cache is the current mapping from 'Module' and+-- 'OccName' to a compiler-wide unique 'Name'+getOrigNameCache :: CoreM OrigNameCache+getOrigNameCache = do+    nameCacheRef <- fmap hsc_NC getHscEnv+    liftIO $ fmap nsNames $ readIORef nameCacheRef++getPackageFamInstEnv :: CoreM PackageFamInstEnv+getPackageFamInstEnv = do+    hsc_env <- getHscEnv+    eps <- liftIO $ hscEPS hsc_env+    return $ eps_fam_inst_env eps++{-# DEPRECATED reinitializeGlobals "It is not necessary to call reinitializeGlobals. Since GHC 8.2, this function is a no-op and will be removed in GHC 8.4" #-}+reinitializeGlobals :: CoreM ()+reinitializeGlobals = return ()++{-+************************************************************************+*                                                                      *+             Dealing with annotations+*                                                                      *+************************************************************************+-}++-- | Get all annotations of a given type. This happens lazily, that is+-- no deserialization will take place until the [a] is actually demanded and+-- the [a] can also be empty (the UniqFM is not filtered).+--+-- This should be done once at the start of a Core-to-Core pass that uses+-- annotations.+--+-- See Note [Annotations]+getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])+getAnnotations deserialize guts = do+     hsc_env <- getHscEnv+     ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)+     return (deserializeAnns deserialize ann_env)++-- | Get at most one annotation of a given type per Unique.+getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)+getFirstAnnotations deserialize guts+  = liftM (mapUFM head . filterUFM (not . null))+  $ getAnnotations deserialize guts++{-+Note [Annotations]+~~~~~~~~~~~~~~~~~~+A Core-to-Core pass that wants to make use of annotations calls+getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with+annotations of a specific type. This produces all annotations from interface+files read so far. However, annotations from interface files read during the+pass will not be visible until getAnnotations is called again. This is similar+to how rules work and probably isn't too bad.++The current implementation could be optimised a bit: when looking up+annotations for a thing from the HomePackageTable, we could search directly in+the module where the thing is defined rather than building one UniqFM which+contains all annotations we know of. This would work because annotations can+only be given to things defined in the same module. However, since we would+only want to deserialise every annotation once, we would have to build a cache+for every module in the HTP. In the end, it's probably not worth it as long as+we aren't using annotations heavily.++************************************************************************+*                                                                      *+                Direct screen output+*                                                                      *+************************************************************************+-}++msg :: Severity -> SDoc -> CoreM ()+msg sev doc+  = do { dflags <- getDynFlags+       ; loc    <- getSrcSpanM+       ; unqual <- getPrintUnqualified+       ; let sty = case sev of+                     SevError   -> err_sty+                     SevWarning -> err_sty+                     SevDump    -> dump_sty+                     _          -> user_sty+             err_sty  = mkErrStyle dflags unqual+             user_sty = mkUserStyle dflags unqual AllTheWay+             dump_sty = mkDumpStyle dflags unqual+       ; liftIO $ putLogMsg dflags NoReason sev loc sty doc }++-- | Output a String message to the screen+putMsgS :: String -> CoreM ()+putMsgS = putMsg . text++-- | Output a message to the screen+putMsg :: SDoc -> CoreM ()+putMsg = msg SevInfo++-- | Output an error to the screen. Does not cause the compiler to die.+errorMsgS :: String -> CoreM ()+errorMsgS = errorMsg . text++-- | Output an error to the screen. Does not cause the compiler to die.+errorMsg :: SDoc -> CoreM ()+errorMsg = msg SevError++warnMsg :: SDoc -> CoreM ()+warnMsg = msg SevWarning++-- | Output a fatal error to the screen. Does not cause the compiler to die.+fatalErrorMsgS :: String -> CoreM ()+fatalErrorMsgS = fatalErrorMsg . text++-- | Output a fatal error to the screen. Does not cause the compiler to die.+fatalErrorMsg :: SDoc -> CoreM ()+fatalErrorMsg = msg SevFatal++-- | Output a string debugging message at verbosity level of @-v@ or higher+debugTraceMsgS :: String -> CoreM ()+debugTraceMsgS = debugTraceMsg . text++-- | Outputs a debugging message at verbosity level of @-v@ or higher+debugTraceMsg :: SDoc -> CoreM ()+debugTraceMsg = msg SevDump++-- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher+dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM ()+dumpIfSet_dyn flag str doc+  = do { dflags <- getDynFlags+       ; unqual <- getPrintUnqualified+       ; when (dopt flag dflags) $ liftIO $+         Err.dumpSDoc dflags unqual flag str doc }++{-+************************************************************************+*                                                                      *+               Finding TyThings+*                                                                      *+************************************************************************+-}++instance MonadThings CoreM where+    lookupThing name = do { hsc_env <- getHscEnv+                          ; liftIO $ lookupGlobal hsc_env name }++{-+************************************************************************+*                                                                      *+               Template Haskell interoperability+*                                                                      *+************************************************************************+-}++-- | Attempt to convert a Template Haskell name to one that GHC can+-- understand. Original TH names such as those you get when you use+-- the @'foo@ syntax will be translated to their equivalent GHC name+-- exactly. Qualified or unqualified TH names will be dynamically bound+-- to names in the module being compiled, if possible. Exact TH names+-- will be bound to the name they represent, exactly.+thNameToGhcName :: TH.Name -> CoreM (Maybe Name)+thNameToGhcName th_name = do+    hsc_env <- getHscEnv+    liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
+ simplCore/FloatIn.hs view
@@ -0,0 +1,659 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++************************************************************************+*                                                                      *+\section[FloatIn]{Floating Inwards pass}+*                                                                      *+************************************************************************++The main purpose of @floatInwards@ is floating into branches of a+case, so that we don't allocate things, save them on the stack, and+then discover that they aren't needed in the chosen branch.+-}++{-# LANGUAGE CPP #-}++module FloatIn ( floatInwards ) where++#include "HsVersions.h"++import CoreSyn+import MkCore+import HscTypes         ( ModGuts(..) )+import CoreUtils        ( exprIsDupable, exprIsExpandable,+                          exprOkForSideEffects, mkTicks )+import CoreFVs+import CoreMonad        ( CoreM )+import Id               ( isOneShotBndr, idType, isJoinId, isJoinId_maybe )+import Var+import Type             ( isUnliftedType )+import VarSet+import Util+import DynFlags+import Outputable+import Data.List        ( mapAccumL )+import BasicTypes       ( RecFlag(..), isRec )++{-+Top-level interface function, @floatInwards@.  Note that we do not+actually float any bindings downwards from the top-level.+-}++floatInwards :: ModGuts -> CoreM ModGuts+floatInwards pgm@(ModGuts { mg_binds = binds })+  = do { dflags <- getDynFlags+       ; return (pgm { mg_binds = map (fi_top_bind dflags) binds }) }+  where+    fi_top_bind dflags (NonRec binder rhs)+      = NonRec binder (fiExpr dflags [] (freeVars rhs))+    fi_top_bind dflags (Rec pairs)+      = Rec [ (b, fiExpr dflags [] (freeVars rhs)) | (b, rhs) <- pairs ]+++{-+************************************************************************+*                                                                      *+\subsection{Mail from Andr\'e [edited]}+*                                                                      *+************************************************************************++{\em Will wrote: What??? I thought the idea was to float as far+inwards as possible, no matter what.  This is dropping all bindings+every time it sees a lambda of any kind.  Help! }++You are assuming we DO DO full laziness AFTER floating inwards!  We+have to [not float inside lambdas] if we don't.++If we indeed do full laziness after the floating inwards (we could+check the compilation flags for that) then I agree we could be more+aggressive and do float inwards past lambdas.++Actually we are not doing a proper full laziness (see below), which+was another reason for not floating inwards past a lambda.++This can easily be fixed.  The problem is that we float lets outwards,+but there are a few expressions which are not let bound, like case+scrutinees and case alternatives.  After floating inwards the+simplifier could decide to inline the let and the laziness would be+lost, e.g.++\begin{verbatim}+let a = expensive             ==> \b -> case expensive of ...+in \ b -> case a of ...+\end{verbatim}+The fix is+\begin{enumerate}+\item+to let bind the algebraic case scrutinees (done, I think) and+the case alternatives (except the ones with an+unboxed type)(not done, I think). This is best done in the+SetLevels.hs module, which tags things with their level numbers.+\item+do the full laziness pass (floating lets outwards).+\item+simplify. The simplifier inlines the (trivial) lets that were+ created but were not floated outwards.+\end{enumerate}++With the fix I think Will's suggestion that we can gain even more from+strictness by floating inwards past lambdas makes sense.++We still gain even without going past lambdas, as things may be+strict in the (new) context of a branch (where it was floated to) or+of a let rhs, e.g.+\begin{verbatim}+let a = something            case x of+in case x of                   alt1 -> case something of a -> a + a+     alt1 -> a + a      ==>    alt2 -> b+     alt2 -> b++let a = something           let b = case something of a -> a + a+in let b = a + a        ==> in (b,b)+in (b,b)+\end{verbatim}+Also, even if a is not found to be strict in the new context and is+still left as a let, if the branch is not taken (or b is not entered)+the closure for a is not built.++************************************************************************+*                                                                      *+\subsection{Main floating-inwards code}+*                                                                      *+************************************************************************+-}++type FreeVarSet  = DIdSet+type BoundVarSet = DIdSet++data FloatInBind = FB BoundVarSet FreeVarSet FloatBind+        -- The FreeVarSet is the free variables of the binding.  In the case+        -- of recursive bindings, the set doesn't include the bound+        -- variables.++type FloatInBinds = [FloatInBind]+        -- In reverse dependency order (innermost binder first)++fiExpr :: DynFlags+       -> FloatInBinds      -- Binds we're trying to drop+                            -- as far "inwards" as possible+       -> CoreExprWithFVs   -- Input expr+       -> CoreExpr          -- Result++fiExpr _ to_drop (_, AnnLit lit)     = ASSERT( null to_drop ) Lit lit+fiExpr _ to_drop (_, AnnType ty)     = ASSERT( null to_drop ) Type ty+fiExpr _ to_drop (_, AnnVar v)       = wrapFloats to_drop (Var v)+fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co)+fiExpr dflags to_drop (_, AnnCast expr (co_ann, co))+  = wrapFloats (drop_here ++ co_drop) $+    Cast (fiExpr dflags e_drop expr) co+  where+    [drop_here, e_drop, co_drop]+      = sepBindsByDropPoint dflags False+          [freeVarsOf expr, freeVarsOfAnn co_ann]+          (freeVarsOfType expr `unionDVarSet` freeVarsOfTypeAnn co_ann)+          to_drop++{-+Applications: we do float inside applications, mainly because we+need to get at all the arguments.  The next simplifier run will+pull out any silly ones.+-}++fiExpr dflags to_drop ann_expr@(_,AnnApp {})+  = mkTicks ticks $ wrapFloats drop_here $ wrapFloats extra_drop $+    mkApps (fiExpr dflags fun_drop ann_fun)+           (zipWith (fiExpr dflags) arg_drops ann_args)+  where+    (ann_fun, ann_args, ticks) = collectAnnArgsTicks tickishFloatable ann_expr+    (extra_fvs0, fun_fvs)+      | (_, AnnVar _) <- ann_fun = (freeVarsOf ann_fun, emptyDVarSet)+          -- Don't float the binding for f into f x y z; see Note [Join points]+          -- for why we *can't* do it when f is a join point. (If f isn't a+          -- join point, floating it in isn't especially harmful but it's+          -- useless since the simplifier will immediately float it back out.)+      | otherwise                = (emptyDVarSet, freeVarsOf ann_fun)+    (extra_fvs, arg_fvs) = mapAccumL mk_arg_fvs extra_fvs0 ann_args++    mk_arg_fvs :: FreeVarSet -> CoreExprWithFVs -> (FreeVarSet, FreeVarSet)+    mk_arg_fvs extra_fvs ann_arg+      | noFloatIntoRhs False NonRecursive ann_arg+      = (extra_fvs `unionDVarSet` freeVarsOf ann_arg, emptyDVarSet)+      | otherwise+      = (extra_fvs, freeVarsOf ann_arg)++    drop_here : extra_drop : fun_drop : arg_drops+      = sepBindsByDropPoint dflags False+          (extra_fvs : fun_fvs : arg_fvs)+          (freeVarsOfType ann_fun `unionDVarSet`+           mapUnionDVarSet freeVarsOfType ann_args)+          to_drop++{-+Note [Do not destroy the let/app invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Watch out for+   f (x +# y)+We don't want to float bindings into here+   f (case ... of { x -> x +# y })+because that might destroy the let/app invariant, which requires+unlifted function arguments to be ok-for-speculation.++Note [Join points]+~~~~~~~~~~~~~~~~~~+Generally, we don't need to worry about join points - there are places we're+not allowed to float them, but since they can't have occurrences in those+places, we're not tempted.++We do need to be careful about jumps, however:++  joinrec j x y z = ... in+  jump j a b c++Previous versions often floated the definition of a recursive function into its+only non-recursive occurrence. But for a join point, this is a disaster:++  (joinrec j x y z = ... in+  jump j) a b c -- wrong!++Every jump must be exact, so the jump to j must have three arguments. Hence+we're careful not to float into the target of a jump (though we can float into+the arguments just fine).++Note [Floating in past a lambda group]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* We must be careful about floating inside a value lambda.+  That risks losing laziness.+  The float-out pass might rescue us, but then again it might not.++* We must be careful about type lambdas too.  At one time we did, and+  there is no risk of duplicating work thereby, but we do need to be+  careful.  In particular, here is a bad case (it happened in the+  cichelli benchmark:+        let v = ...+        in let f = /\t -> \a -> ...+           ==>+        let f = /\t -> let v = ... in \a -> ...+  This is bad as now f is an updatable closure (update PAP)+  and has arity 0.++* Hack alert!  We only float in through one-shot lambdas,+  not (as you might guess) through lone big lambdas.+  Reason: we float *out* past big lambdas (see the test in the Lam+  case of FloatOut.floatExpr) and we don't want to float straight+  back in again.++  It *is* important to float into one-shot lambdas, however;+  see the remarks with noFloatIntoRhs.++So we treat lambda in groups, using the following rule:++ Float in if (a) there is at least one Id,+         and (b) there are no non-one-shot Ids++ Otherwise drop all the bindings outside the group.++This is what the 'go' function in the AnnLam case is doing.++(Join points are handled similarly: a join point is considered one-shot iff+it's non-recursive, so we float only into non-recursive join points.)++Urk! if all are tyvars, and we don't float in, we may miss an+      opportunity to float inside a nested case branch+-}++fiExpr dflags to_drop lam@(_, AnnLam _ _)+  | okToFloatInside bndrs       -- Float in+     -- NB: Must line up with noFloatIntoRhs (AnnLam...); see Trac #7088+  = mkLams bndrs (fiExpr dflags to_drop body)++  | otherwise           -- Dump it all here+  = wrapFloats to_drop (mkLams bndrs (fiExpr dflags [] body))++  where+    (bndrs, body) = collectAnnBndrs lam++{-+We don't float lets inwards past an SCC.+        ToDo: keep info on current cc, and when passing+        one, if it is not the same, annotate all lets in binds with current+        cc, change current cc to the new one and float binds into expr.+-}++fiExpr dflags to_drop (_, AnnTick tickish expr)+  | tickish `tickishScopesLike` SoftScope+  = Tick tickish (fiExpr dflags to_drop expr)++  | otherwise -- Wimp out for now - we could push values in+  = wrapFloats to_drop (Tick tickish (fiExpr dflags [] expr))++{-+For @Lets@, the possible ``drop points'' for the \tr{to_drop}+bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding,+or~(b2), in each of the RHSs of the pairs of a @Rec@.++Note that we do {\em weird things} with this let's binding.  Consider:+\begin{verbatim}+let+    w = ...+in {+    let v = ... w ...+    in ... v .. w ...+}+\end{verbatim}+Look at the inner \tr{let}.  As \tr{w} is used in both the bind and+body of the inner let, we could panic and leave \tr{w}'s binding where+it is.  But \tr{v} is floatable further into the body of the inner let, and+{\em then} \tr{w} will also be only in the body of that inner let.++So: rather than drop \tr{w}'s binding here, we add it onto the list of+things to drop in the outer let's body, and let nature take its+course.++Note [extra_fvs (1): avoid floating into RHS]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider let x=\y....t... in body.  We do not necessarily want to float+a binding for t into the RHS, because it'll immediately be floated out+again.  (It won't go inside the lambda else we risk losing work.)+In letrec, we need to be more careful still. We don't want to transform+        let x# = y# +# 1#+        in+        letrec f = \z. ...x#...f...+        in ...+into+        letrec f = let x# = y# +# 1# in \z. ...x#...f... in ...+because now we can't float the let out again, because a letrec+can't have unboxed bindings.++So we make "extra_fvs" which is the rhs_fvs of such bindings, and+arrange to dump bindings that bind extra_fvs before the entire let.++Note [extra_fvs (2): free variables of rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  let x{rule mentioning y} = rhs in body+Here y is not free in rhs or body; but we still want to dump bindings+that bind y outside the let.  So we augment extra_fvs with the+idRuleAndUnfoldingVars of x.  No need for type variables, hence not using+idFreeVars.+-}++fiExpr dflags to_drop (_,AnnLet bind body)+  = fiExpr dflags (after ++ new_float : before) body+           -- to_drop is in reverse dependency order+  where+    (before, new_float, after) = fiBind dflags to_drop bind body_fvs body_ty_fvs+    body_fvs    = freeVarsOf body+    body_ty_fvs = freeVarsOfType body++{-+For @Case@, the possible ``drop points'' for the \tr{to_drop}+bindings are: (a)~inside the scrutinee, (b)~inside one of the+alternatives/default [default FVs always {\em first}!].++Floating case expressions inward was added to fix Trac #5658: strict bindings+not floated in. In particular, this change allows array indexing operations,+which have a single DEFAULT alternative without any binders, to be floated+inward. SIMD primops for unpacking SIMD vectors into an unboxed tuple of unboxed+scalars also need to be floated inward, but unpacks have a single non-DEFAULT+alternative that binds the elements of the tuple. We now therefore also support+floating in cases with a single alternative that may bind values.+-}++fiExpr dflags to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)])+  | isUnliftedType (idType case_bndr)+  , exprOkForSideEffects (deAnnotate scrut)+      -- See PrimOp, Note [PrimOp can_fail and has_side_effects]+  = wrapFloats shared_binds $+    fiExpr dflags (case_float : rhs_binds) rhs+  where+    case_float = FB (mkDVarSet (case_bndr : alt_bndrs)) scrut_fvs+                    (FloatCase scrut' case_bndr con alt_bndrs)+    scrut' = fiExpr dflags scrut_binds scrut+    [shared_binds, scrut_binds, rhs_binds]+       = sepBindsByDropPoint dflags False+           [scrut_fvs, rhs_fvs]+           (freeVarsOfType scrut `unionDVarSet` rhs_ty_fvs)+           to_drop+    rhs_fvs    = freeVarsOf rhs `delDVarSetList` (case_bndr : alt_bndrs)+    rhs_ty_fvs = freeVarsOfType rhs `delDVarSetList` (case_bndr : alt_bndrs)+    scrut_fvs  = freeVarsOf scrut++fiExpr dflags to_drop (_, AnnCase scrut case_bndr ty alts)+  = wrapFloats drop_here1 $+    wrapFloats drop_here2 $+    Case (fiExpr dflags scrut_drops scrut) case_bndr ty+         (zipWith fi_alt alts_drops_s alts)+  where+        -- Float into the scrut and alts-considered-together just like App+    [drop_here1, scrut_drops, alts_drops]+       = sepBindsByDropPoint dflags False+           [scrut_fvs, all_alts_fvs]+           (freeVarsOfType scrut `unionDVarSet` all_alts_ty_fvs)+           to_drop++        -- Float into the alts with the is_case flag set+    (drop_here2 : alts_drops_s)+      = sepBindsByDropPoint dflags True alts_fvs all_alts_ty_fvs+                            alts_drops++    scrut_fvs       = freeVarsOf scrut+    alts_fvs        = map alt_fvs alts+    all_alts_fvs    = unionDVarSets alts_fvs+    alts_ty_fvs     = map alt_ty_fvs alts+    all_alts_ty_fvs = unionDVarSets alts_ty_fvs+    alt_fvs (_con, args, rhs)+      = foldl delDVarSet (freeVarsOf rhs)     (case_bndr:args)+    alt_ty_fvs (_con, args, rhs)+      = foldl delDVarSet (freeVarsOfType rhs) (case_bndr:args)+                                -- Delete case_bndr and args from free vars of rhs+                                -- to get free vars of alt++    fi_alt to_drop (con, args, rhs) = (con, args, fiExpr dflags to_drop rhs)++------------------+fiBind :: DynFlags+       -> FloatInBinds      -- Binds we're trying to drop+                            -- as far "inwards" as possible+       -> CoreBindWithFVs   -- Input binding+       -> DVarSet           -- Free in scope of binding+       -> DVarSet           -- Free in type of body of binding+       -> ( FloatInBinds    -- Land these before+          , FloatInBind     -- The binding itself+          , FloatInBinds)   -- Land these after++fiBind dflags to_drop (AnnNonRec id rhs) body_fvs body_ty_fvs+  = ( extra_binds ++ shared_binds          -- Land these before+                                           -- See Note [extra_fvs (1,2)]+    , FB (unitDVarSet id) rhs_fvs'         -- The new binding itself+          (FloatLet (NonRec id rhs'))+    , body_binds )                         -- Land these after++  where+    body_fvs2 = body_fvs `delDVarSet` id+    rhs_fvs   = freeVarsOf rhs++    rule_fvs = bndrRuleAndUnfoldingVarsDSet id        -- See Note [extra_fvs (2): free variables of rules]+    extra_fvs | noFloatIntoRhs (isJoinId id) NonRecursive rhs+              = rule_fvs `unionDVarSet` freeVarsOf rhs+              | otherwise+              = rule_fvs+        -- See Note [extra_fvs (1): avoid floating into RHS]+        -- No point in floating in only to float straight out again+        -- We *can't* float into ok-for-speculation unlifted RHSs+        -- But do float into join points++    [shared_binds, extra_binds, rhs_binds, body_binds]+        = sepBindsByDropPoint dflags False+            [extra_fvs, rhs_fvs, body_fvs2]+            (freeVarsOfType rhs `unionDVarSet` body_ty_fvs)+            to_drop++        -- Push rhs_binds into the right hand side of the binding+    rhs'     = fiRhs dflags rhs_binds id rhs+    rhs_fvs' = rhs_fvs `unionDVarSet` floatedBindsFVs rhs_binds `unionDVarSet` rule_fvs+                        -- Don't forget the rule_fvs; the binding mentions them!++fiBind dflags to_drop (AnnRec bindings) body_fvs body_ty_fvs+  = ( extra_binds ++ shared_binds+    , FB (mkDVarSet ids) rhs_fvs'+         (FloatLet (Rec (fi_bind rhss_binds bindings)))+    , body_binds )+  where+    (ids, rhss) = unzip bindings+    rhss_fvs = map freeVarsOf rhss++        -- See Note [extra_fvs (1,2)]+    rule_fvs = mapUnionDVarSet bndrRuleAndUnfoldingVarsDSet ids+    extra_fvs = rule_fvs `unionDVarSet`+                unionDVarSets [ freeVarsOf rhs | (bndr, rhs) <- bindings+                              , noFloatIntoRhs (isJoinId bndr) Recursive rhs ]++    (shared_binds:extra_binds:body_binds:rhss_binds)+        = sepBindsByDropPoint dflags False+            (extra_fvs:body_fvs:rhss_fvs)+            (body_ty_fvs `unionDVarSet` mapUnionDVarSet freeVarsOfType rhss)+            to_drop++    rhs_fvs' = unionDVarSets rhss_fvs `unionDVarSet`+               unionDVarSets (map floatedBindsFVs rhss_binds) `unionDVarSet`+               rule_fvs         -- Don't forget the rule variables!++    -- Push rhs_binds into the right hand side of the binding+    fi_bind :: [FloatInBinds]       -- one per "drop pt" conjured w/ fvs_of_rhss+            -> [(Id, CoreExprWithFVs)]+            -> [(Id, CoreExpr)]++    fi_bind to_drops pairs+      = [ (binder, fiRhs dflags to_drop binder rhs)+        | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]++------------------+fiRhs :: DynFlags -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr+fiRhs dflags to_drop bndr rhs+  | Just join_arity <- isJoinId_maybe bndr+  , let (bndrs, body) = collectNAnnBndrs join_arity rhs+  = mkLams bndrs (fiExpr dflags to_drop body)+  | otherwise+  = fiExpr dflags to_drop rhs++------------------+okToFloatInside :: [Var] -> Bool+okToFloatInside bndrs = all ok bndrs+  where+    ok b = not (isId b) || isOneShotBndr b+    -- Push the floats inside there are no non-one-shot value binders++noFloatIntoRhs :: Bool -> RecFlag -> CoreExprWithFVs -> Bool+-- ^ True if it's a bad idea to float bindings into this RHS+-- Preconditio:  rhs :: rhs_ty+noFloatIntoRhs is_join is_rec rhs@(_, rhs')+  |  is_join+  =  isRec is_rec -- Joins are one-shot iff non-recursive+  |  otherwise+  =  isUnliftedType rhs_ty+       -- See Note [Do not destroy the let/app invariant]+  || noFloatIntoExpr rhs'+  where+    rhs_ty = exprTypeFV rhs++noFloatIntoExpr :: CoreExprWithFVs' -> Bool+noFloatIntoExpr (AnnLam bndr e)+   = not (okToFloatInside (bndr:bndrs))+     -- NB: Must line up with fiExpr (AnnLam...); see Trac #7088+   where+     (bndrs, _) = collectAnnBndrs e+        -- IMPORTANT: don't say 'True' for a RHS with a one-shot lambda at the top.+        -- This makes a big difference for things like+        --      f x# = let x = I# x#+        --             in let j = \() -> ...x...+        --                in if <condition> then normal-path else j ()+        -- If x is used only in the error case join point, j, we must float the+        -- boxing constructor into it, else we box it every time which is very bad+        -- news indeed.++noFloatIntoExpr rhs = exprIsExpandable (deAnnotate' rhs)+       -- We'd just float right back out again...+       -- Should match the test in SimplEnv.doFloatFromRhs++{-+************************************************************************+*                                                                      *+\subsection{@sepBindsByDropPoint@}+*                                                                      *+************************************************************************++This is the crucial function.  The idea is: We have a wad of bindings+that we'd like to distribute inside a collection of {\em drop points};+insides the alternatives of a \tr{case} would be one example of some+drop points; the RHS and body of a non-recursive \tr{let} binding+would be another (2-element) collection.++So: We're given a list of sets-of-free-variables, one per drop point,+and a list of floating-inwards bindings.  If a binding can go into+only one drop point (without suddenly making something out-of-scope),+in it goes.  If a binding is used inside {\em multiple} drop points,+then it has to go in a you-must-drop-it-above-all-these-drop-points+point.++But, with coercions appearing in types, there is a complication: we+might be floating in a "strict let" -- that is, a case. Case expressions+mention their return type. We absolutely can't float a coercion binding+inward to the point that the type of the expression it's about to wrap+mentions the coercion. So we include the union of the sets of free variables+of the types of all the drop points involved. If any of the floaters+bind a coercion variable mentioned in any of the types, that binder must+be dropped right away.++We have to maintain the order on these drop-point-related lists.+-}++sepBindsByDropPoint+    :: DynFlags+    -> Bool             -- True <=> is case expression+    -> [FreeVarSet]         -- One set of FVs per drop point+    -> FreeVarSet           -- Vars free in all the types of the drop points+    -> FloatInBinds         -- Candidate floaters+    -> [FloatInBinds]      -- FIRST one is bindings which must not be floated+                            -- inside any drop point; the rest correspond+                            -- one-to-one with the input list of FV sets++-- Every input floater is returned somewhere in the result;+-- none are dropped, not even ones which don't seem to be+-- free in *any* of the drop-point fvs.  Why?  Because, for example,+-- a binding (let x = E in B) might have a specialised version of+-- x (say x') stored inside x, but x' isn't free in E or B.++type DropBox = (FreeVarSet, FloatInBinds)++sepBindsByDropPoint _ _is_case drop_pts _ty_fvs []+  = [] : [[] | _ <- drop_pts]   -- cut to the chase scene; it happens++sepBindsByDropPoint dflags is_case drop_pts ty_fvs floaters+  = go floaters (map (\fvs -> (fvs, [])) (emptyDVarSet : drop_pts))+  where+    go :: FloatInBinds -> [DropBox] -> [FloatInBinds]+        -- The *first* one in the argument list is the drop_here set+        -- The FloatInBinds in the lists are in the reverse of+        -- the normal FloatInBinds order; that is, they are the right way round!++    go [] drop_boxes = map (reverse . snd) drop_boxes++    go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) drop_boxes@(here_box : fork_boxes)+        = go binds new_boxes+        where+          -- "here" means the group of bindings dropped at the top of the fork++          (used_here : used_in_flags) = [ fvs `intersectsDVarSet` bndrs+                                        | (fvs, _) <- drop_boxes]+          used_in_ty = ty_fvs `intersectsDVarSet` bndrs++          drop_here = used_here || not can_push || used_in_ty++                -- For case expressions we duplicate the binding if it is+                -- reasonably small, and if it is not used in all the RHSs+                -- This is good for situations like+                --      let x = I# y in+                --      case e of+                --        C -> error x+                --        D -> error x+                --        E -> ...not mentioning x...++          n_alts      = length used_in_flags+          n_used_alts = count id used_in_flags -- returns number of Trues in list.++          can_push = n_used_alts == 1           -- Used in just one branch+                   || (is_case &&               -- We are looking at case alternatives+                       n_used_alts > 1 &&       -- It's used in more than one+                       n_used_alts < n_alts &&  -- ...but not all+                       floatIsDupable dflags bind) -- and we can duplicate the binding++          new_boxes | drop_here = (insert here_box : fork_boxes)+                    | otherwise = (here_box : new_fork_boxes)++          new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe fork_boxes used_in_flags++          insert :: DropBox -> DropBox+          insert (fvs,drops) = (fvs `unionDVarSet` bind_fvs, bind_w_fvs:drops)++          insert_maybe box True  = insert box+          insert_maybe box False = box++    go _ _ = panic "sepBindsByDropPoint/go"+++floatedBindsFVs :: FloatInBinds -> FreeVarSet+floatedBindsFVs binds = mapUnionDVarSet fbFVs binds++fbFVs :: FloatInBind -> DVarSet+fbFVs (FB _ fvs _) = fvs++wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr+-- Remember FloatInBinds is in *reverse* dependency order+wrapFloats []               e = e+wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e)++floatIsDupable :: DynFlags -> FloatBind -> Bool+floatIsDupable dflags (FloatCase scrut _ _ _) = exprIsDupable dflags scrut+floatIsDupable dflags (FloatLet (Rec prs))    = all (exprIsDupable dflags . snd) prs+floatIsDupable dflags (FloatLet (NonRec _ r)) = exprIsDupable dflags r
+ simplCore/FloatOut.hs view
@@ -0,0 +1,755 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[FloatOut]{Float bindings outwards (towards the top level)}++``Long-distance'' floating of bindings towards the top level.+-}++{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module FloatOut ( floatOutwards ) where++import CoreSyn+import CoreUtils+import MkCore+import CoreArity        ( etaExpand )+import CoreMonad        ( FloatOutSwitches(..) )++import DynFlags+import ErrUtils         ( dumpIfSet_dyn )+import Id               ( Id, idArity, idType, isBottomingId,+                          isJoinId, isJoinId_maybe )+import Var              ( Var )+import SetLevels+import UniqSupply       ( UniqSupply )+import Bag+import Util+import Maybes+import Outputable+import Type+import qualified Data.IntMap as M++import Data.List        ( partition )++#include "HsVersions.h"++{-+        -----------------+        Overall game plan+        -----------------++The Big Main Idea is:++        To float out sub-expressions that can thereby get outside+        a non-one-shot value lambda, and hence may be shared.+++To achieve this we may need to do two thing:++   a) Let-bind the sub-expression:++        f (g x)  ==>  let lvl = f (g x) in lvl++      Now we can float the binding for 'lvl'.++   b) More than that, we may need to abstract wrt a type variable++        \x -> ... /\a -> let v = ...a... in ....++      Here the binding for v mentions 'a' but not 'x'.  So we+      abstract wrt 'a', to give this binding for 'v':++            vp = /\a -> ...a...+            v  = vp a++      Now the binding for vp can float out unimpeded.+      I can't remember why this case seemed important enough to+      deal with, but I certainly found cases where important floats+      didn't happen if we did not abstract wrt tyvars.++With this in mind we can also achieve another goal: lambda lifting.+We can make an arbitrary (function) binding float to top level by+abstracting wrt *all* local variables, not just type variables, leaving+a binding that can be floated right to top level.  Whether or not this+happens is controlled by a flag.+++Random comments+~~~~~~~~~~~~~~~++At the moment we never float a binding out to between two adjacent+lambdas.  For example:++@+        \x y -> let t = x+x in ...+===>+        \x -> let t = x+x in \y -> ...+@+Reason: this is less efficient in the case where the original lambda+is never partially applied.++But there's a case I've seen where this might not be true.  Consider:+@+elEm2 x ys+  = elem' x ys+  where+    elem' _ []  = False+    elem' x (y:ys)      = x==y || elem' x ys+@+It turns out that this generates a subexpression of the form+@+        \deq x ys -> let eq = eqFromEqDict deq in ...+@+vwhich might usefully be separated to+@+        \deq -> let eq = eqFromEqDict deq in \xy -> ...+@+Well, maybe.  We don't do this at the moment.++Note [Join points]+~~~~~~~~~~~~~~~~~~+Every occurrence of a join point must be a tail call (see Note [Invariants on+join points] in CoreSyn), so we must be careful with how far we float them. The+mechanism for doing so is the *join ceiling*, detailed in Note [Join ceiling]+in SetLevels. For us, the significance is that a binder might be marked to be+dropped at the nearest boundary between tail calls and non-tail calls. For+example:++  (< join j = ... in+     let x = < ... > in+     case < ... > of+       A -> ...+       B -> ...+   >) < ... > < ... >++Here the join ceilings are marked with angle brackets. Either side of an+application is a join ceiling, as is the scrutinee position of a case+expression or the RHS of a let binding (but not a join point).++Why do we *want* do float join points at all? After all, they're never+allocated, so there's no sharing to be gained by floating them. However, the+other benefit of floating is making RHSes small, and this can have a significant+impact. In particular, stream fusion has been known to produce nested loops like+this:++  joinrec j1 x1 =+    joinrec j2 x2 =+      joinrec j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ...+      in jump j3 x2+    in jump j2 x1+  in jump j1 x++(Assume x1 and x2 do *not* occur free in j3.)++Here j1 and j2 are wholly superfluous---each of them merely forwards its+argument to j3. Since j3 only refers to x3, we can float j2 and j3 to make+everything one big mutual recursion:++  joinrec j1 x1 = jump j2 x1+          j2 x2 = jump j3 x2+          j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ...+  in jump j1 x++Now the simplifier will happily inline the trivial j1 and j2, leaving only j3.+Without floating, we're stuck with three loops instead of one.++************************************************************************+*                                                                      *+\subsection[floatOutwards]{@floatOutwards@: let-floating interface function}+*                                                                      *+************************************************************************+-}++floatOutwards :: FloatOutSwitches+              -> DynFlags+              -> UniqSupply+              -> CoreProgram -> IO CoreProgram++floatOutwards float_sws dflags us pgm+  = do {+        let { annotated_w_levels = setLevels float_sws pgm us ;+              (fss, binds_s')    = unzip (map floatTopBind annotated_w_levels)+            } ;++        dumpIfSet_dyn dflags Opt_D_verbose_core2core "Levels added:"+                  (vcat (map ppr annotated_w_levels));++        let { (tlets, ntlets, lams) = get_stats (sum_stats fss) };++        dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:"+                (hcat [ int tlets,  text " Lets floated to top level; ",+                        int ntlets, text " Lets floated elsewhere; from ",+                        int lams,   text " Lambda groups"]);++        return (bagToList (unionManyBags binds_s'))+    }++floatTopBind :: LevelledBind -> (FloatStats, Bag CoreBind)+floatTopBind bind+  = case (floatBind bind) of { (fs, floats, bind') ->+    let float_bag = flattenTopFloats floats+    in case bind' of+      -- bind' can't have unlifted values or join points, so can only be one+      -- value bind, rec or non-rec (see comment on floatBind)+      [Rec prs]    -> (fs, unitBag (Rec (addTopFloatPairs float_bag prs)))+      [NonRec b e] -> (fs, float_bag `snocBag` NonRec b e)+      _            -> pprPanic "floatTopBind" (ppr bind') }++{-+************************************************************************+*                                                                      *+\subsection[FloatOut-Bind]{Floating in a binding (the business end)}+*                                                                      *+************************************************************************+-}++floatBind :: LevelledBind -> (FloatStats, FloatBinds, [CoreBind])+  -- Returns a list with either+  --   * A single non-recursive binding (value or join point), or+  --   * The following, in order:+  --     * Zero or more non-rec unlifted bindings+  --     * One or both of:+  --       * A recursive group of join binds+  --       * A recursive group of value binds+  -- See Note [Floating out of Rec rhss] for why things get arranged this way.+floatBind (NonRec (TB var _) rhs)+  = case (floatRhs var rhs) of { (fs, rhs_floats, rhs') ->++        -- A tiresome hack:+        -- see Note [Bottoming floats: eta expansion] in SetLevels+    let rhs'' | isBottomingId var = etaExpand (idArity var) rhs'+              | otherwise         = rhs'++    in (fs, rhs_floats, [NonRec var rhs'']) }++floatBind (Rec pairs)+  = case floatList do_pair pairs of { (fs, rhs_floats, new_pairs) ->+    let (new_ul_pairss, new_other_pairss) = unzip new_pairs+        (new_join_pairs, new_l_pairs)     = partition (isJoinId . fst)+                                                      (concat new_other_pairss)+        -- Can't put the join points and the values in the same rec group+        new_rec_binds | null new_join_pairs = [ Rec new_l_pairs    ]+                      | null new_l_pairs    = [ Rec new_join_pairs ]+                      | otherwise           = [ Rec new_l_pairs+                                              , Rec new_join_pairs ]+        new_non_rec_binds = [ NonRec b e | (b, e) <- concat new_ul_pairss ]+    in+    (fs, rhs_floats, new_non_rec_binds ++ new_rec_binds) }+  where+    do_pair :: (LevelledBndr, LevelledExpr)+            -> (FloatStats, FloatBinds,+                ([(Id,CoreExpr)],  -- Non-recursive unlifted value bindings+                 [(Id,CoreExpr)])) -- Join points and lifted value bindings+    do_pair (TB name spec, rhs)+      | isTopLvl dest_lvl  -- See Note [floatBind for top level]+      = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') ->+        (fs, emptyFloats, ([], addTopFloatPairs (flattenTopFloats rhs_floats)+                                                [(name, rhs')]))}+      | otherwise         -- Note [Floating out of Rec rhss]+      = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') ->+        case (partitionByLevel dest_lvl rhs_floats) of { (rhs_floats', heres) ->+        case (splitRecFloats heres) of { (ul_pairs, pairs, case_heres) ->+        let pairs' = (name, installUnderLambdas case_heres rhs') : pairs in+        (fs, rhs_floats', (ul_pairs, pairs')) }}}+      where+        dest_lvl = floatSpecLevel spec++splitRecFloats :: Bag FloatBind+               -> ([(Id,CoreExpr)], -- Non-recursive unlifted value bindings+                   [(Id,CoreExpr)], -- Join points and lifted value bindings+                   Bag FloatBind)   -- A tail of further bindings+-- The "tail" begins with a case+-- See Note [Floating out of Rec rhss]+splitRecFloats fs+  = go [] [] (bagToList fs)+  where+    go ul_prs prs (FloatLet (NonRec b r) : fs) | isUnliftedType (idType b)+                                               , not (isJoinId b)+                                               = go ((b,r):ul_prs) prs fs+                                               | otherwise+                                               = go ul_prs ((b,r):prs) fs+    go ul_prs prs (FloatLet (Rec prs')   : fs) = go ul_prs (prs' ++ prs) fs+    go ul_prs prs fs                           = (reverse ul_prs, prs,+                                                  listToBag fs)+                                                   -- Order only matters for+                                                   -- non-rec++installUnderLambdas :: Bag FloatBind -> CoreExpr -> CoreExpr+-- Note [Floating out of Rec rhss]+installUnderLambdas floats e+  | isEmptyBag floats = e+  | otherwise         = go e+  where+    go (Lam b e)                 = Lam b (go e)+    go e                         = install floats e++---------------+floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b])+floatList _ [] = (zeroStats, emptyFloats, [])+floatList f (a:as) = case f a            of { (fs_a,  binds_a,  b)  ->+                     case floatList f as of { (fs_as, binds_as, bs) ->+                     (fs_a `add_stats` fs_as, binds_a `plusFloats`  binds_as, b:bs) }}++{-+Note [Floating out of Rec rhss]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider   Rec { f<1,0> = \xy. body }+From the body we may get some floats. The ones with level <1,0> must+stay here, since they may mention f.  Ideally we'd like to make them+part of the Rec block pairs -- but we can't if there are any+FloatCases involved.++Nor is it a good idea to dump them in the rhs, but outside the lambda+    f = case x of I# y -> \xy. body+because now f's arity might get worse, which is Not Good. (And if+there's an SCC around the RHS it might not get better again.+See Trac #5342.)++So, gruesomely, we split the floats into+ * the outer FloatLets, which can join the Rec, and+ * an inner batch starting in a FloatCase, which are then+   pushed *inside* the lambdas.+This loses full-laziness the rare situation where there is a+FloatCase and a Rec interacting.++If there are unlifted FloatLets (that *aren't* join points) among the floats,+we can't add them to the recursive group without angering Core Lint, but since+they must be ok-for-speculation, they can't actually be making any recursive+calls, so we can safely pull them out and keep them non-recursive.++(Why is something getting floated to <1,0> that doesn't make a recursive call?+The case that came up in testing was that f *and* the unlifted binding were+getting floated *to the same place*:++  \x<2,0> ->+    ... <3,0>+    letrec { f<F<2,0>> =+      ... let x'<F<2,0>> = x +# 1# in ...+    } in ...++Everything gets labeled "float to <2,0>" because it all depends on x, but this+makes f and x' look mutually recursive when they're not.++The test was shootout/k-nucleotide, as compiled using commit 47d5dd68 on the+wip/join-points branch.++TODO: This can probably be solved somehow in SetLevels. The difference between+"this *is at* level <2,0>" and "this *depends on* level <2,0>" is very+important.)++Note [floatBind for top level]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We may have a *nested* binding whose destination level is (FloatMe tOP_LEVEL), thus+         letrec { foo <0,0> = .... (let bar<0,0> = .. in ..) .... }+The binding for bar will be in the "tops" part of the floating binds,+and thus not partioned by floatBody.++We could perhaps get rid of the 'tops' component of the floating binds,+but this case works just as well.+++************************************************************************++\subsection[FloatOut-Expr]{Floating in expressions}+*                                                                      *+************************************************************************+-}++floatBody :: Level+          -> LevelledExpr+          -> (FloatStats, FloatBinds, CoreExpr)++floatBody lvl arg       -- Used rec rhss, and case-alternative rhss+  = case (floatExpr arg) of { (fsa, floats, arg') ->+    case (partitionByLevel lvl floats) of { (floats', heres) ->+        -- Dump bindings are bound here+    (fsa, floats', install heres arg') }}++-----------------++{- Note [Floating past breakpoints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We used to disallow floating out of breakpoint ticks (see #10052). However, I+think this is too restrictive.++Consider the case of an expression scoped over by a breakpoint tick,++  tick<...> (let x = ... in f x)++In this case it is completely legal to float out x, despite the fact that+breakpoint ticks are scoped,++  let x = ... in (tick<...>  f x)++The reason here is that we know that the breakpoint will still be hit when the+expression is entered since the tick still scopes over the RHS.++-}++floatExpr :: LevelledExpr+          -> (FloatStats, FloatBinds, CoreExpr)+floatExpr (Var v)   = (zeroStats, emptyFloats, Var v)+floatExpr (Type ty) = (zeroStats, emptyFloats, Type ty)+floatExpr (Coercion co) = (zeroStats, emptyFloats, Coercion co)+floatExpr (Lit lit) = (zeroStats, emptyFloats, Lit lit)++floatExpr (App e a)+  = case (atJoinCeiling $ floatExpr  e) of { (fse, floats_e, e') ->+    case (atJoinCeiling $ floatExpr  a) of { (fsa, floats_a, a') ->+    (fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }}++floatExpr lam@(Lam (TB _ lam_spec) _)+  = let (bndrs_w_lvls, body) = collectBinders lam+        bndrs                = [b | TB b _ <- bndrs_w_lvls]+        bndr_lvl             = asJoinCeilLvl (floatSpecLevel lam_spec)+        -- All the binders have the same level+        -- See SetLevels.lvlLamBndrs+        -- Use asJoinCeilLvl to make this the join ceiling+    in+    case (floatBody bndr_lvl body) of { (fs, floats, body') ->+    (add_to_stats fs floats, floats, mkLams bndrs body') }++floatExpr (Tick tickish expr)+  | tickish `tickishScopesLike` SoftScope -- not scoped, can just float+  = case (atJoinCeiling $ floatExpr expr)    of { (fs, floating_defns, expr') ->+    (fs, floating_defns, Tick tickish expr') }++  | not (tickishCounts tickish) || tickishCanSplit tickish+  = case (atJoinCeiling $ floatExpr expr)    of { (fs, floating_defns, expr') ->+    let -- Annotate bindings floated outwards past an scc expression+        -- with the cc.  We mark that cc as "duplicated", though.+        annotated_defns = wrapTick (mkNoCount tickish) floating_defns+    in+    (fs, annotated_defns, Tick tickish expr') }++  -- Note [Floating past breakpoints]+  | Breakpoint{} <- tickish+  = case (floatExpr expr)    of { (fs, floating_defns, expr') ->+    (fs, floating_defns, Tick tickish expr') }++  | otherwise+  = pprPanic "floatExpr tick" (ppr tickish)++floatExpr (Cast expr co)+  = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') ->+    (fs, floating_defns, Cast expr' co) }++floatExpr (Let bind body)+  = case bind_spec of+      FloatMe dest_lvl+        -> case (floatBind bind) of { (fsb, bind_floats, binds') ->+           case (floatExpr body) of { (fse, body_floats, body') ->+           let new_bind_floats = foldr plusFloats emptyFloats+                                   (map (unitLetFloat dest_lvl) binds') in+           ( add_stats fsb fse+           , bind_floats `plusFloats` new_bind_floats+                         `plusFloats` body_floats+           , body') }}++      StayPut bind_lvl  -- See Note [Avoiding unnecessary floating]+        -> case (floatBind bind)          of { (fsb, bind_floats, binds') ->+           case (floatBody bind_lvl body) of { (fse, body_floats, body') ->+           ( add_stats fsb fse+           , bind_floats `plusFloats` body_floats+           , foldr Let body' binds' ) }}+  where+    bind_spec = case bind of+                 NonRec (TB _ s) _     -> s+                 Rec ((TB _ s, _) : _) -> s+                 Rec []                -> panic "floatExpr:rec"++floatExpr (Case scrut (TB case_bndr case_spec) ty alts)+  = case case_spec of+      FloatMe dest_lvl  -- Case expression moves+        | [(con@(DataAlt {}), bndrs, rhs)] <- alts+        -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') ->+           case                 floatExpr rhs   of { (fsb, fdb, rhs') ->+           let+             float = unitCaseFloat dest_lvl scrut'+                          case_bndr con [b | TB b _ <- bndrs]+           in+           (add_stats fse fsb, fde `plusFloats` float `plusFloats` fdb, rhs') }}+        | otherwise+        -> pprPanic "Floating multi-case" (ppr alts)++      StayPut bind_lvl  -- Case expression stays put+        -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') ->+           case floatList (float_alt bind_lvl) alts of { (fsa, fda, alts')  ->+           (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts')+           }}+  where+    float_alt bind_lvl (con, bs, rhs)+        = case (floatBody bind_lvl rhs) of { (fs, rhs_floats, rhs') ->+          (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) }++floatRhs :: CoreBndr+         -> LevelledExpr+         -> (FloatStats, FloatBinds, CoreExpr)+floatRhs bndr rhs+  | Just join_arity <- isJoinId_maybe bndr+  , Just (bndrs, body) <- try_collect join_arity rhs []+  = case bndrs of+      []                -> floatExpr rhs+      (TB _ lam_spec):_ ->+        let lvl = floatSpecLevel lam_spec in+        case floatBody lvl body of { (fs, floats, body') ->+        (fs, floats, mkLams [b | TB b _ <- bndrs] body') }+  | otherwise+  = atJoinCeiling $ floatExpr rhs+  where+    try_collect 0 expr      acc = Just (reverse acc, expr)+    try_collect n (Lam b e) acc = try_collect (n-1) e (b:acc)+    try_collect _ _         _   = Nothing++{-+Note [Avoiding unnecessary floating]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general we want to avoid floating a let unnecessarily, because+it might worsen strictness:+    let+       x = ...(let y = e in y+y)....+Here y is demanded.  If we float it outside the lazy 'x=..' then+we'd have to zap its demand info, and it may never be restored.++So at a 'let' we leave the binding right where the are unless+the binding will escape a value lambda, e.g.++(\x -> let y = fac 100 in y)++That's what the partitionByMajorLevel does in the floatExpr (Let ...)+case.++Notice, though, that we must take care to drop any bindings+from the body of the let that depend on the staying-put bindings.++We used instead to do the partitionByMajorLevel on the RHS of an '=',+in floatRhs.  But that was quite tiresome.  We needed to test for+values or trival rhss, because (in particular) we don't want to insert+new bindings between the "=" and the "\".  E.g.+        f = \x -> let <bind> in <body>+We do not want+        f = let <bind> in \x -> <body>+(a) The simplifier will immediately float it further out, so we may+        as well do so right now; in general, keeping rhss as manifest+        values is good+(b) If a float-in pass follows immediately, it might add yet more+        bindings just after the '='.  And some of them might (correctly)+        be strict even though the 'let f' is lazy, because f, being a value,+        gets its demand-info zapped by the simplifier.+And even all that turned out to be very fragile, and broke+altogether when profiling got in the way.++So now we do the partition right at the (Let..) itself.++************************************************************************+*                                                                      *+\subsection{Utility bits for floating stats}+*                                                                      *+************************************************************************++I didn't implement this with unboxed numbers.  I don't want to be too+strict in this stuff, as it is rarely turned on.  (WDP 95/09)+-}++data FloatStats+  = FlS Int  -- Number of top-floats * lambda groups they've been past+        Int  -- Number of non-top-floats * lambda groups they've been past+        Int  -- Number of lambda (groups) seen++get_stats :: FloatStats -> (Int, Int, Int)+get_stats (FlS a b c) = (a, b, c)++zeroStats :: FloatStats+zeroStats = FlS 0 0 0++sum_stats :: [FloatStats] -> FloatStats+sum_stats xs = foldr add_stats zeroStats xs++add_stats :: FloatStats -> FloatStats -> FloatStats+add_stats (FlS a1 b1 c1) (FlS a2 b2 c2)+  = FlS (a1 + a2) (b1 + b2) (c1 + c2)++add_to_stats :: FloatStats -> FloatBinds -> FloatStats+add_to_stats (FlS a b c) (FB tops ceils others)+  = FlS (a + lengthBag tops)+        (b + lengthBag ceils + lengthBag (flattenMajor others))+        (c + 1)++{-+************************************************************************+*                                                                      *+\subsection{Utility bits for floating}+*                                                                      *+************************************************************************++Note [Representation of FloatBinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The FloatBinds types is somewhat important.  We can get very large numbers+of floating bindings, often all destined for the top level.  A typical example+is     x = [4,2,5,2,5, .... ]+Then we get lots of small expressions like (fromInteger 4), which all get+lifted to top level.++The trouble is that+  (a) we partition these floating bindings *at every binding site*+  (b) SetLevels introduces a new bindings site for every float+So we had better not look at each binding at each binding site!++That is why MajorEnv is represented as a finite map.++We keep the bindings destined for the *top* level separate, because+we float them out even if they don't escape a *value* lambda; see+partitionByMajorLevel.+-}++type FloatLet = CoreBind        -- INVARIANT: a FloatLet is always lifted+type MajorEnv = M.IntMap MinorEnv         -- Keyed by major level+type MinorEnv = M.IntMap (Bag FloatBind)  -- Keyed by minor level++data FloatBinds  = FB !(Bag FloatLet)           -- Destined for top level+                      !(Bag FloatBind)          -- Destined for join ceiling+                      !MajorEnv                 -- Other levels+     -- See Note [Representation of FloatBinds]++instance Outputable FloatBinds where+  ppr (FB fbs ceils defs)+      = text "FB" <+> (braces $ vcat+           [ text "tops ="     <+> ppr fbs+           , text "ceils ="    <+> ppr ceils+           , text "non-tops =" <+> ppr defs ])++flattenTopFloats :: FloatBinds -> Bag CoreBind+flattenTopFloats (FB tops ceils defs)+  = ASSERT2( isEmptyBag (flattenMajor defs), ppr defs )+    ASSERT2( isEmptyBag ceils, ppr ceils )+    tops++addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]+addTopFloatPairs float_bag prs+  = foldrBag add prs float_bag+  where+    add (NonRec b r) prs  = (b,r):prs+    add (Rec prs1)   prs2 = prs1 ++ prs2++flattenMajor :: MajorEnv -> Bag FloatBind+flattenMajor = M.foldr (unionBags . flattenMinor) emptyBag++flattenMinor :: MinorEnv -> Bag FloatBind+flattenMinor = M.foldr unionBags emptyBag++emptyFloats :: FloatBinds+emptyFloats = FB emptyBag emptyBag M.empty++unitCaseFloat :: Level -> CoreExpr -> Id -> AltCon -> [Var] -> FloatBinds+unitCaseFloat (Level major minor t) e b con bs+  | t == JoinCeilLvl+  = FB emptyBag floats M.empty+  | otherwise+  = FB emptyBag emptyBag (M.singleton major (M.singleton minor floats))+  where+    floats = unitBag (FloatCase e b con bs)++unitLetFloat :: Level -> FloatLet -> FloatBinds+unitLetFloat lvl@(Level major minor t) b+  | isTopLvl lvl     = FB (unitBag b) emptyBag M.empty+  | t == JoinCeilLvl = FB emptyBag floats M.empty+  | otherwise        = FB emptyBag emptyBag (M.singleton major+                                              (M.singleton minor floats))+  where+    floats = unitBag (FloatLet b)++plusFloats :: FloatBinds -> FloatBinds -> FloatBinds+plusFloats (FB t1 c1 l1) (FB t2 c2 l2)+  = FB (t1 `unionBags` t2) (c1 `unionBags` c2) (l1 `plusMajor` l2)++plusMajor :: MajorEnv -> MajorEnv -> MajorEnv+plusMajor = M.unionWith plusMinor++plusMinor :: MinorEnv -> MinorEnv -> MinorEnv+plusMinor = M.unionWith unionBags++install :: Bag FloatBind -> CoreExpr -> CoreExpr+install defn_groups expr+  = foldrBag wrapFloat expr defn_groups++partitionByLevel+        :: Level                -- Partitioning level+        -> FloatBinds           -- Defns to be divided into 2 piles...+        -> (FloatBinds,         -- Defns  with level strictly < partition level,+            Bag FloatBind)      -- The rest++{-+--       ---- partitionByMajorLevel ----+-- Float it if we escape a value lambda,+--     *or* if we get to the top level+--     *or* if it's a case-float and its minor level is < current+--+-- If we can get to the top level, say "yes" anyway. This means that+--      x = f e+-- transforms to+--    lvl = e+--    x = f lvl+-- which is as it should be++partitionByMajorLevel (Level major _) (FB tops defns)+  = (FB tops outer, heres `unionBags` flattenMajor inner)+  where+    (outer, mb_heres, inner) = M.splitLookup major defns+    heres = case mb_heres of+               Nothing -> emptyBag+               Just h  -> flattenMinor h+-}++partitionByLevel (Level major minor typ) (FB tops ceils defns)+  = (FB tops ceils' (outer_maj `plusMajor` M.singleton major outer_min),+     here_min `unionBags` here_ceil+              `unionBags` flattenMinor inner_min+              `unionBags` flattenMajor inner_maj)++  where+    (outer_maj, mb_here_maj, inner_maj) = M.splitLookup major defns+    (outer_min, mb_here_min, inner_min) = case mb_here_maj of+                                            Nothing -> (M.empty, Nothing, M.empty)+                                            Just min_defns -> M.splitLookup minor min_defns+    here_min = mb_here_min `orElse` emptyBag+    (here_ceil, ceils') | typ == JoinCeilLvl = (ceils, emptyBag)+                        | otherwise          = (emptyBag, ceils)++-- Like partitionByLevel, but instead split out the bindings that are marked+-- to float to the nearest join ceiling (see Note [Join points])+partitionAtJoinCeiling :: FloatBinds -> (FloatBinds, Bag FloatBind)+partitionAtJoinCeiling (FB tops ceils defs)+  = (FB tops emptyBag defs, ceils)++-- Perform some action at a join ceiling, i.e., don't let join points float out+-- (see Note [Join points])+atJoinCeiling :: (FloatStats, FloatBinds, CoreExpr)+              -> (FloatStats, FloatBinds, CoreExpr)+atJoinCeiling (fs, floats, expr')+  = (fs, floats', install ceils expr')+  where+    (floats', ceils) = partitionAtJoinCeiling floats++wrapTick :: Tickish Id -> FloatBinds -> FloatBinds+wrapTick t (FB tops ceils defns)+  = FB (mapBag wrap_bind tops) (wrap_defns ceils)+       (M.map (M.map wrap_defns) defns)+  where+    wrap_defns = mapBag wrap_one++    wrap_bind (NonRec binder rhs) = NonRec binder (maybe_tick rhs)+    wrap_bind (Rec pairs)         = Rec (mapSnd maybe_tick pairs)++    wrap_one (FloatLet bind)      = FloatLet (wrap_bind bind)+    wrap_one (FloatCase e b c bs) = FloatCase (maybe_tick e) b c bs++    maybe_tick e | exprIsHNF e = tickHNFArgs t e+                 | otherwise   = mkTick t e+      -- we don't need to wrap a tick around an HNF when we float it+      -- outside a tick: that is an invariant of the tick semantics+      -- Conversely, inlining of HNFs inside an SCC is allowed, and+      -- indeed the HNF we're floating here might well be inlined back+      -- again, and we don't want to end up with duplicate ticks.
+ simplCore/LiberateCase.hs view
@@ -0,0 +1,422 @@+{-+(c) The AQUA Project, Glasgow University, 1994-1998++\section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop}+-}++{-# LANGUAGE CPP #-}+module LiberateCase ( liberateCase ) where++#include "HsVersions.h"++import DynFlags+import CoreSyn+import CoreUnfold       ( couldBeSmallEnoughToInline )+import Id+import VarEnv+import Util             ( notNull )++{-+The liberate-case transformation+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This module walks over @Core@, and looks for @case@ on free variables.+The criterion is:+        if there is case on a free on the route to the recursive call,+        then the recursive call is replaced with an unfolding.++Example++   f = \ t -> case v of+                 V a b -> a : f t++=> the inner f is replaced.++   f = \ t -> case v of+                 V a b -> a : (letrec+                                f =  \ t -> case v of+                                               V a b -> a : f t+                               in f) t+(note the NEED for shadowing)++=> Simplify++  f = \ t -> case v of+                 V a b -> a : (letrec+                                f = \ t -> a : f t+                               in f t)++Better code, because 'a' is  free inside the inner letrec, rather+than needing projection from v.++Note that this deals with *free variables*.  SpecConstr deals with+*arguments* that are of known form.  E.g.++        last []     = error+        last (x:[]) = x+        last (x:xs) = last xs+++Note [Scrutinee with cast]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:+    f = \ t -> case (v `cast` co) of+                 V a b -> a : f t++Exactly the same optimisation (unrolling one call to f) will work here,+despite the cast.  See mk_alt_env in the Case branch of libCase.+++Note [Only functions!]+~~~~~~~~~~~~~~~~~~~~~~+Consider the following code++       f = g (case v of V a b -> a : t f)++where g is expensive. If we aren't careful, liberate case will turn this into++       f = g (case v of+               V a b -> a : t (letrec f = g (case v of V a b -> a : f t)+                                in f)+             )++Yikes! We evaluate g twice. This leads to a O(2^n) explosion+if g calls back to the same code recursively.++Solution: make sure that we only do the liberate-case thing on *functions*++To think about (Apr 94)+~~~~~~~~~~~~~~+Main worry: duplicating code excessively.  At the moment we duplicate+the entire binding group once at each recursive call.  But there may+be a group of recursive calls which share a common set of evaluated+free variables, in which case the duplication is a plain waste.++Another thing we could consider adding is some unfold-threshold thing,+so that we'll only duplicate if the size of the group rhss isn't too+big.++Data types+~~~~~~~~~~+The ``level'' of a binder tells how many+recursive defns lexically enclose the binding+A recursive defn "encloses" its RHS, not its+scope.  For example:+\begin{verbatim}+        letrec f = let g = ... in ...+        in+        let h = ...+        in ...+\end{verbatim}+Here, the level of @f@ is zero, the level of @g@ is one,+and the level of @h@ is zero (NB not one).+++************************************************************************+*                                                                      *+         Top-level code+*                                                                      *+************************************************************************+-}++liberateCase :: DynFlags -> CoreProgram -> CoreProgram+liberateCase dflags binds = do_prog (initEnv dflags) binds+  where+    do_prog _   [] = []+    do_prog env (bind:binds) = bind' : do_prog env' binds+                             where+                               (env', bind') = libCaseBind env bind++{-+************************************************************************+*                                                                      *+         Main payload+*                                                                      *+************************************************************************++Bindings+~~~~~~~~+-}++libCaseBind :: LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind)++libCaseBind env (NonRec binder rhs)+  = (addBinders env [binder], NonRec binder (libCase env rhs))++libCaseBind env (Rec pairs)+  = (env_body, Rec pairs')+  where+    binders = map fst pairs++    env_body = addBinders env binders++    pairs' = [(binder, libCase env_rhs rhs) | (binder,rhs) <- pairs]++        -- We extend the rec-env by binding each Id to its rhs, first+        -- processing the rhs with an *un-extended* environment, so+        -- that the same process doesn't occur for ever!+    env_rhs = addRecBinds env [ (localiseId binder, libCase env_body rhs)+                              | (binder, rhs) <- pairs+                              , rhs_small_enough binder rhs ]+        -- localiseID : see Note [Need to localiseId in libCaseBind]+++    rhs_small_enough id rhs     -- Note [Small enough]+        =  idArity id > 0       -- Note [Only functions!]+        && maybe True (\size -> couldBeSmallEnoughToInline (lc_dflags env) size rhs)+                      (bombOutSize env)++{-+Note [Need to localiseId in libCaseBind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The call to localiseId is needed for two subtle reasons+(a)  Reset the export flags on the binders so+        that we don't get name clashes on exported things if the+        local binding floats out to top level.  This is most unlikely+        to happen, since the whole point concerns free variables.+        But resetting the export flag is right regardless.++(b)  Make the name an Internal one.  External Names should never be+        nested; if it were floated to the top level, we'd get a name+        clash at code generation time.++Note [Small enough]+~~~~~~~~~~~~~~~~~~~+Consider+  \fv. letrec+         f = \x. BIG...(case fv of { (a,b) -> ...g.. })...+         g = \y. SMALL...f...+Then we *can* do liberate-case on g (small RHS) but not for f (too big).+But we can choose on a item-by-item basis, and that's what the+rhs_small_enough call in the comprehension for env_rhs does.++Expressions+~~~~~~~~~~~+-}++libCase :: LibCaseEnv+        -> CoreExpr+        -> CoreExpr++libCase env (Var v)             = libCaseApp env v []+libCase _   (Lit lit)           = Lit lit+libCase _   (Type ty)           = Type ty+libCase _   (Coercion co)       = Coercion co+libCase env e@(App {})          | let (fun, args) = collectArgs e+                                , Var v <- fun+                                = libCaseApp env v args+libCase env (App fun arg)       = App (libCase env fun) (libCase env arg)+libCase env (Tick tickish body) = Tick tickish (libCase env body)+libCase env (Cast e co)         = Cast (libCase env e) co++libCase env (Lam binder body)+  = Lam binder (libCase (addBinders env [binder]) body)++libCase env (Let bind body)+  = Let bind' (libCase env_body body)+  where+    (env_body, bind') = libCaseBind env bind++libCase env (Case scrut bndr ty alts)+  = Case (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts)+  where+    env_alts = addBinders (mk_alt_env scrut) [bndr]+    mk_alt_env (Var scrut_var) = addScrutedVar env scrut_var+    mk_alt_env (Cast scrut _)  = mk_alt_env scrut       -- Note [Scrutinee with cast]+    mk_alt_env _               = env++libCaseAlt :: LibCaseEnv -> (AltCon, [CoreBndr], CoreExpr)+                         -> (AltCon, [CoreBndr], CoreExpr)+libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)++{-+Ids+~~~++To unfold, we can't just wrap the id itself in its binding if it's a join point:++  jump j a b c  =>  (joinrec j x y z = ... in jump j) a b c -- wrong!!!++Every jump must provide all arguments, so we have to be careful to wrap the+whole jump instead:++  jump j a b c  =>  joinrec j x y z = ... in jump j a b c -- right++-}++libCaseApp :: LibCaseEnv -> Id -> [CoreExpr] -> CoreExpr+libCaseApp env v args+  | Just the_bind <- lookupRecId env v  -- It's a use of a recursive thing+  , notNull free_scruts                 -- with free vars scrutinised in RHS+  = Let the_bind expr'++  | otherwise+  = expr'++  where+    rec_id_level = lookupLevel env v+    free_scruts  = freeScruts env rec_id_level+    expr'        = mkApps (Var v) (map (libCase env) args)++freeScruts :: LibCaseEnv+           -> LibCaseLevel      -- Level of the recursive Id+           -> [Id]              -- Ids that are scrutinised between the binding+                                -- of the recursive Id and here+freeScruts env rec_bind_lvl+  = [v | (v, scrut_bind_lvl, scrut_at_lvl) <- lc_scruts env+       , scrut_bind_lvl <= rec_bind_lvl+       , scrut_at_lvl > rec_bind_lvl]+        -- Note [When to specialise]+        -- Note [Avoiding fruitless liberate-case]++{-+Note [When to specialise]+~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  f = \x. letrec g = \y. case x of+                           True  -> ... (f a) ...+                           False -> ... (g b) ...++We get the following levels+          f  0+          x  1+          g  1+          y  2++Then 'x' is being scrutinised at a deeper level than its binding, so+it's added to lc_sruts:  [(x,1)]++We do *not* want to specialise the call to 'f', because 'x' is not free+in 'f'.  So here the bind-level of 'x' (=1) is not <= the bind-level of 'f' (=0).++We *do* want to specialise the call to 'g', because 'x' is free in g.+Here the bind-level of 'x' (=1) is <= the bind-level of 'g' (=1).++Note [Avoiding fruitless liberate-case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider also:+  f = \x. case top_lvl_thing of+                I# _ -> let g = \y. ... g ...+                        in ...++Here, top_lvl_thing is scrutinised at a level (1) deeper than its+binding site (0).  Nevertheless, we do NOT want to specialise the call+to 'g' because all the structure in its free variables is already+visible at the definition site for g.  Hence, when considering specialising+an occurrence of 'g', we want to check that there's a scruted-var v st++   a) v's binding site is *outside* g+   b) v's scrutinisation site is *inside* g+++************************************************************************+*                                                                      *+        Utility functions+*                                                                      *+************************************************************************+-}++addBinders :: LibCaseEnv -> [CoreBndr] -> LibCaseEnv+addBinders env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env }) binders+  = env { lc_lvl_env = lvl_env' }+  where+    lvl_env' = extendVarEnvList lvl_env (binders `zip` repeat lvl)++addRecBinds :: LibCaseEnv -> [(Id,CoreExpr)] -> LibCaseEnv+addRecBinds env@(LibCaseEnv {lc_lvl = lvl, lc_lvl_env = lvl_env,+                             lc_rec_env = rec_env}) pairs+  = env { lc_lvl = lvl', lc_lvl_env = lvl_env', lc_rec_env = rec_env' }+  where+    lvl'     = lvl + 1+    lvl_env' = extendVarEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs]+    rec_env' = extendVarEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs]++addScrutedVar :: LibCaseEnv+              -> Id             -- This Id is being scrutinised by a case expression+              -> LibCaseEnv++addScrutedVar env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env,+                                lc_scruts = scruts }) scrut_var+  | bind_lvl < lvl+  = env { lc_scruts = scruts' }+        -- Add to scruts iff the scrut_var is being scrutinised at+        -- a deeper level than its defn++  | otherwise = env+  where+    scruts'  = (scrut_var, bind_lvl, lvl) : scruts+    bind_lvl = case lookupVarEnv lvl_env scrut_var of+                 Just lvl -> lvl+                 Nothing  -> topLevel++lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind+lookupRecId env id = lookupVarEnv (lc_rec_env env) id++lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel+lookupLevel env id+  = case lookupVarEnv (lc_lvl_env env) id of+      Just lvl -> lvl+      Nothing  -> topLevel++{-+************************************************************************+*                                                                      *+         The environment+*                                                                      *+************************************************************************+-}++type LibCaseLevel = Int++topLevel :: LibCaseLevel+topLevel = 0++data LibCaseEnv+  = LibCaseEnv {+        lc_dflags :: DynFlags,++        lc_lvl :: LibCaseLevel, -- Current level+                -- The level is incremented when (and only when) going+                -- inside the RHS of a (sufficiently small) recursive+                -- function.++        lc_lvl_env :: IdEnv LibCaseLevel,+                -- Binds all non-top-level in-scope Ids (top-level and+                -- imported things have a level of zero)++        lc_rec_env :: IdEnv CoreBind,+                -- Binds *only* recursively defined ids, to their own+                -- binding group, and *only* in their own RHSs++        lc_scruts :: [(Id, LibCaseLevel, LibCaseLevel)]+                -- Each of these Ids was scrutinised by an enclosing+                -- case expression, at a level deeper than its binding+                -- level.+                --+                -- The first LibCaseLevel is the *binding level* of+                --   the scrutinised Id,+                -- The second is the level *at which it was scrutinised*.+                --   (see Note [Avoiding fruitless liberate-case])+                -- The former is a bit redundant, since you could always+                -- look it up in lc_lvl_env, but it's just cached here+                --+                -- The order is insignificant; it's a bag really+                --+                -- There's one element per scrutinisation;+                --    in principle the same Id may appear multiple times,+                --    although that'd be unusual:+                --       case x of { (a,b) -> ....(case x of ...) .. }+        }++initEnv :: DynFlags -> LibCaseEnv+initEnv dflags+  = LibCaseEnv { lc_dflags = dflags,+                 lc_lvl = 0,+                 lc_lvl_env = emptyVarEnv,+                 lc_rec_env = emptyVarEnv,+                 lc_scruts = [] }++-- Bomb-out size for deciding if+-- potential liberatees are too big.+-- (passed in from cmd-line args)+bombOutSize :: LibCaseEnv -> Maybe Int+bombOutSize = liberateCaseThreshold . lc_dflags
+ simplCore/OccurAnal.hs view
@@ -0,0 +1,2772 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++************************************************************************+*                                                                      *+\section[OccurAnal]{Occurrence analysis pass}+*                                                                      *+************************************************************************++The occurrence analyser re-typechecks a core expression, returning a new+core expression with (hopefully) improved usage information.+-}++{-# LANGUAGE CPP, BangPatterns, MultiWayIf #-}++module OccurAnal (+        occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap+    ) where++#include "HsVersions.h"++import CoreSyn+import CoreFVs+import CoreUtils        ( exprIsTrivial, isDefaultAlt, isExpandableApp,+                          stripTicksTopE, mkTicks )+import Id+import IdInfo+import Name( localiseName )+import BasicTypes+import Module( Module )+import Coercion+import Type++import VarSet+import VarEnv+import Var+import Demand           ( argOneShots, argsOneShots )+import Digraph          ( SCC(..), Node+                        , stronglyConnCompFromEdgedVerticesUniq+                        , stronglyConnCompFromEdgedVerticesUniqR )+import Unique+import UniqFM+import UniqSet+import Util+import Outputable+import Data.List+import Control.Arrow    ( second )++{-+************************************************************************+*                                                                      *+    occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap+*                                                                      *+************************************************************************++Here's the externally-callable interface:+-}++occurAnalysePgm :: Module       -- Used only in debug output+                -> (Activation -> Bool)+                -> [CoreRule] -> [CoreVect] -> VarSet+                -> CoreProgram -> CoreProgram+occurAnalysePgm this_mod active_rule imp_rules vects vectVars binds+  | isEmptyDetails final_usage+  = occ_anald_binds++  | otherwise   -- See Note [Glomming]+  = WARN( True, hang (text "Glomming in" <+> ppr this_mod <> colon)+                   2 (ppr final_usage ) )+    occ_anald_glommed_binds+  where+    init_env = initOccEnv active_rule+    (final_usage, occ_anald_binds) = go init_env binds+    (_, occ_anald_glommed_binds)   = occAnalRecBind init_env TopLevel+                                                    imp_rule_edges+                                                    (flattenBinds occ_anald_binds)+                                                    initial_uds+          -- It's crucial to re-analyse the glommed-together bindings+          -- so that we establish the right loop breakers. Otherwise+          -- we can easily create an infinite loop (Trac #9583 is an example)++    initial_uds = addManyOccsSet emptyDetails+                            (rulesFreeVars imp_rules `unionVarSet`+                             vectsFreeVars vects `unionVarSet`+                             vectVars)+    -- The RULES and VECTORISE declarations keep things alive! (For VECTORISE declarations,+    -- we only get them *until* the vectoriser runs. Afterwards, these dependencies are+    -- reflected in 'vectors' — see Note [Vectorisation declarations and occurrences].)++    -- Note [Preventing loops due to imported functions rules]+    imp_rule_edges = foldr (plusVarEnv_C unionVarSet) emptyVarEnv+                            [ mapVarEnv (const maps_to) $+                                getUniqSet (exprFreeIds arg `delVarSetList` ru_bndrs imp_rule)+                            | imp_rule <- imp_rules+                            , not (isBuiltinRule imp_rule)  -- See Note [Plugin rules]+                            , let maps_to = exprFreeIds (ru_rhs imp_rule)+                                             `delVarSetList` ru_bndrs imp_rule+                            , arg <- ru_args imp_rule ]++    go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])+    go _ []+        = (initial_uds, [])+    go env (bind:binds)+        = (final_usage, bind' ++ binds')+        where+           (bs_usage, binds')   = go env binds+           (final_usage, bind') = occAnalBind env TopLevel imp_rule_edges bind+                                              bs_usage++occurAnalyseExpr :: CoreExpr -> CoreExpr+        -- Do occurrence analysis, and discard occurrence info returned+occurAnalyseExpr = occurAnalyseExpr' True -- do binder swap++occurAnalyseExpr_NoBinderSwap :: CoreExpr -> CoreExpr+occurAnalyseExpr_NoBinderSwap = occurAnalyseExpr' False -- do not do binder swap++occurAnalyseExpr' :: Bool -> CoreExpr -> CoreExpr+occurAnalyseExpr' enable_binder_swap expr+  = snd (occAnal env expr)+  where+    env = (initOccEnv all_active_rules) {occ_binder_swap = enable_binder_swap}+    -- To be conservative, we say that all inlines and rules are active+    all_active_rules = \_ -> True++{- Note [Plugin rules]+~~~~~~~~~~~~~~~~~~~~~~+Conal Elliott (Trac #11651) built a GHC plugin that added some+BuiltinRules (for imported Ids) to the mg_rules field of ModGuts, to+do some domain-specific transformations that could not be expressed+with an ordinary pattern-matching CoreRule.  But then we can't extract+the dependencies (in imp_rule_edges) from ru_rhs etc, because a+BuiltinRule doesn't have any of that stuff.++So we simply assume that BuiltinRules have no dependencies, and filter+them out from the imp_rule_edges comprehension.+-}++{-+************************************************************************+*                                                                      *+                Bindings+*                                                                      *+************************************************************************++Note [Recursive bindings: the grand plan]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we come across a binding group+  Rec { x1 = r1; ...; xn = rn }+we treat it like this (occAnalRecBind):++1. Occurrence-analyse each right hand side, and build a+   "Details" for each binding to capture the results.++   Wrap the details in a Node (details, node-id, dep-node-ids),+   where node-id is just the unique of the binder, and+   dep-node-ids lists all binders on which this binding depends.+   We'll call these the "scope edges".+   See Note [Forming the Rec groups].++   All this is done by makeNode.++2. Do SCC-analysis on these Nodes.  Each SCC will become a new Rec or+   NonRec.  The key property is that every free variable of a binding+   is accounted for by the scope edges, so that when we are done+   everything is still in scope.++3. For each Cyclic SCC of the scope-edge SCC-analysis in (2), we+   identify suitable loop-breakers to ensure that inlining terminates.+   This is done by occAnalRec.++4. To do so we form a new set of Nodes, with the same details, but+   different edges, the "loop-breaker nodes". The loop-breaker nodes+   have both more and fewer depedencies than the scope edges+   (see Note [Choosing loop breakers])++   More edges: if f calls g, and g has an active rule that mentions h+               then we add an edge from f -> h++   Fewer edges: we only include dependencies on active rules, on rule+                RHSs (not LHSs) and if there is an INLINE pragma only+                on the stable unfolding (and vice versa).  The scope+                edges must be much more inclusive.++5.  The "weak fvs" of a node are, by definition:+       the scope fvs - the loop-breaker fvs+    See Note [Weak loop breakers], and the nd_weak field of Details++6.  Having formed the loop-breaker nodes++Note [Dead code]+~~~~~~~~~~~~~~~~+Dropping dead code for a cyclic Strongly Connected Component is done+in a very simple way:++        the entire SCC is dropped if none of its binders are mentioned+        in the body; otherwise the whole thing is kept.++The key observation is that dead code elimination happens after+dependency analysis: so 'occAnalBind' processes SCCs instead of the+original term's binding groups.++Thus 'occAnalBind' does indeed drop 'f' in an example like++        letrec f = ...g...+               g = ...(...g...)...+        in+           ...g...++when 'g' no longer uses 'f' at all (eg 'f' does not occur in a RULE in+'g'). 'occAnalBind' first consumes 'CyclicSCC g' and then it consumes+'AcyclicSCC f', where 'body_usage' won't contain 'f'.++------------------------------------------------------------+Note [Forming Rec groups]+~~~~~~~~~~~~~~~~~~~~~~~~~+We put bindings {f = ef; g = eg } in a Rec group if "f uses g"+and "g uses f", no matter how indirectly.  We do a SCC analysis+with an edge f -> g if "f uses g".++More precisely, "f uses g" iff g should be in scope wherever f is.+That is, g is free in:+  a) the rhs 'ef'+  b) or the RHS of a rule for f (Note [Rules are extra RHSs])+  c) or the LHS or a rule for f (Note [Rule dependency info])++These conditions apply regardless of the activation of the RULE (eg it might be+inactive in this phase but become active later).  Once a Rec is broken up+it can never be put back together, so we must be conservative.++The principle is that, regardless of rule firings, every variable is+always in scope.++  * Note [Rules are extra RHSs]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~+    A RULE for 'f' is like an extra RHS for 'f'. That way the "parent"+    keeps the specialised "children" alive.  If the parent dies+    (because it isn't referenced any more), then the children will die+    too (unless they are already referenced directly).++    To that end, we build a Rec group for each cyclic strongly+    connected component,+        *treating f's rules as extra RHSs for 'f'*.+    More concretely, the SCC analysis runs on a graph with an edge+    from f -> g iff g is mentioned in+        (a) f's rhs+        (b) f's RULES+    These are rec_edges.++    Under (b) we include variables free in *either* LHS *or* RHS of+    the rule.  The former might seems silly, but see Note [Rule+    dependency info].  So in Example [eftInt], eftInt and eftIntFB+    will be put in the same Rec, even though their 'main' RHSs are+    both non-recursive.++  * Note [Rule dependency info]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~+    The VarSet in a RuleInfo is used for dependency analysis in the+    occurrence analyser.  We must track free vars in *both* lhs and rhs.+    Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind.+    Why both? Consider+        x = y+        RULE f x = v+4+    Then if we substitute y for x, we'd better do so in the+    rule's LHS too, so we'd better ensure the RULE appears to mention 'x'+    as well as 'v'++  * Note [Rules are visible in their own rec group]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    We want the rules for 'f' to be visible in f's right-hand side.+    And we'd like them to be visible in other functions in f's Rec+    group.  E.g. in Note [Specialisation rules] we want f' rule+    to be visible in both f's RHS, and fs's RHS.++    This means that we must simplify the RULEs first, before looking+    at any of the definitions.  This is done by Simplify.simplRecBind,+    when it calls addLetIdInfo.++------------------------------------------------------------+Note [Choosing loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Loop breaking is surprisingly subtle.  First read the section 4 of+"Secrets of the GHC inliner".  This describes our basic plan.+We avoid infinite inlinings by choosing loop breakers, and+ensuring that a loop breaker cuts each loop.++See also Note [Inlining and hs-boot files] in ToIface, which deals+with a closely related source of infinite loops.++Fundamentally, we do SCC analysis on a graph.  For each recursive+group we choose a loop breaker, delete all edges to that node,+re-analyse the SCC, and iterate.++But what is the graph?  NOT the same graph as was used for Note+[Forming Rec groups]!  In particular, a RULE is like an equation for+'f' that is *always* inlined if it is applicable.  We do *not* disable+rules for loop-breakers.  It's up to whoever makes the rules to make+sure that the rules themselves always terminate.  See Note [Rules for+recursive functions] in Simplify.hs++Hence, if+    f's RHS (or its INLINE template if it has one) mentions g, and+    g has a RULE that mentions h, and+    h has a RULE that mentions f++then we *must* choose f to be a loop breaker.  Example: see Note+[Specialisation rules].++In general, take the free variables of f's RHS, and augment it with+all the variables reachable by RULES from those starting points.  That+is the whole reason for computing rule_fv_env in occAnalBind.  (Of+course we only consider free vars that are also binders in this Rec+group.)  See also Note [Finding rule RHS free vars]++Note that when we compute this rule_fv_env, we only consider variables+free in the *RHS* of the rule, in contrast to the way we build the+Rec group in the first place (Note [Rule dependency info])++Note that if 'g' has RHS that mentions 'w', we should add w to+g's loop-breaker edges.  More concretely there is an edge from f -> g+iff+        (a) g is mentioned in f's RHS `xor` f's INLINE rhs+            (see Note [Inline rules])+        (b) or h is mentioned in f's RHS, and+            g appears in the RHS of an active RULE of h+            or a transitive sequence of active rules starting with h++Why "active rules"?  See Note [Finding rule RHS free vars]++Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is+chosen as a loop breaker, because their RHSs don't mention each other.+And indeed both can be inlined safely.++Note again that the edges of the graph we use for computing loop breakers+are not the same as the edges we use for computing the Rec blocks.+That's why we compute++- rec_edges          for the Rec block analysis+- loop_breaker_nodes for the loop breaker analysis++  * Note [Finding rule RHS free vars]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    Consider this real example from Data Parallel Haskell+         tagZero :: Array Int -> Array Tag+         {-# INLINE [1] tagZeroes #-}+         tagZero xs = pmap (\x -> fromBool (x==0)) xs++         {-# RULES "tagZero" [~1] forall xs n.+             pmap fromBool <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 [Weak loop breakers]+    ~~~~~~~~~~~~~~~~~~~~~~~~~+    There is a last nasty wrinkle.  Suppose we have++        Rec { f = f_rhs+              RULE f [] = g++              h = h_rhs+              g = h+              ...more...+        }++    Remember that we simplify the RULES before any RHS (see Note+    [Rules are visible in their own rec group] above).++    So we must *not* postInlineUnconditionally 'g', even though+    its RHS turns out to be trivial.  (I'm assuming that 'g' is+    not choosen as a loop breaker.)  Why not?  Because then we+    drop the binding for 'g', which leaves it out of scope in the+    RULE!++    Here's a somewhat different example of the same thing+        Rec { g = h+            ; h = ...f...+            ; f = f_rhs+              RULE f [] = g }+    Here the RULE is "below" g, but we *still* can't postInlineUnconditionally+    g, because the RULE for f is active throughout.  So the RHS of h+    might rewrite to     h = ...g...+    So g must remain in scope in the output program!++    We "solve" this by:++        Make g a "weak" loop breaker (OccInfo = IAmLoopBreaker True)+        iff g is a "missing free variable" of the Rec group++    A "missing free variable" x is one that is mentioned in an RHS or+    INLINE or RULE of a binding in the Rec group, but where the+    dependency on x may not show up in the loop_breaker_nodes (see+    note [Choosing loop breakers} above).++    A normal "strong" loop breaker has IAmLoopBreaker False.  So++                                    Inline  postInlineUnconditionally+   strong   IAmLoopBreaker False    no      no+   weak     IAmLoopBreaker True     yes     no+            other                   yes     yes++    The **sole** reason for this kind of loop breaker is so that+    postInlineUnconditionally does not fire.  Ugh.  (Typically it'll+    inline via the usual callSiteInline stuff, so it'll be dead in the+    next pass, so the main Ugh is the tiresome complication.)++Note [Rules for imported functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this+   f = /\a. B.g a+   RULE B.g Int = 1 + f Int+Note that+  * The RULE is for an imported function.+  * f is non-recursive+Now we+can get+   f Int --> B.g Int      Inlining f+         --> 1 + f Int    Firing RULE+and so the simplifier goes into an infinite loop. This+would not happen if the RULE was for a local function,+because we keep track of dependencies through rules.  But+that is pretty much impossible to do for imported Ids.  Suppose+f's definition had been+   f = /\a. C.h a+where (by some long and devious process), C.h eventually inlines to+B.g.  We could only spot such loops by exhaustively following+unfoldings of C.h etc, in case we reach B.g, and hence (via the RULE)+f.++Note that RULES for imported functions are important in practice; they+occur a lot in the libraries.++We regard this potential infinite loop as a *programmer* error.+It's up the programmer not to write silly rules like+     RULE f x = f x+and the example above is just a more complicated version.++Note [Preventing loops due to imported functions rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:+  import GHC.Base (foldr)++  {-# RULES "filterList" forall p. foldr (filterFB (:) p) [] = filter p #-}+  filter p xs = build (\c n -> foldr (filterFB c p) n xs)+  filterFB c p = ...++  f = filter p xs++Note that filter is not a loop-breaker, so what happens is:+  f =          filter p xs+    = {inline} build (\c n -> foldr (filterFB c p) n xs)+    = {inline} foldr (filterFB (:) p) [] xs+    = {RULE}   filter p xs++We are in an infinite loop.++A more elaborate example (that I actually saw in practice when I went to+mark GHC.List.filter as INLINABLE) is as follows. Say I have this module:+  {-# LANGUAGE RankNTypes #-}+  module GHCList where++  import Prelude hiding (filter)+  import GHC.Base (build)++  {-# INLINABLE filter #-}+  filter :: (a -> Bool) -> [a] -> [a]+  filter p [] = []+  filter p (x:xs) = if p x then x : filter p xs else filter p xs++  {-# NOINLINE [0] filterFB #-}+  filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b+  filterFB c p x r | p x       = x `c` r+                   | otherwise = r++  {-# RULES+  "filter"     [~1] forall p xs.  filter p xs = build (\c n -> foldr+  (filterFB c p) n xs)+  "filterList" [1]  forall p.     foldr (filterFB (:) p) [] = filter p+   #-}++Then (because RULES are applied inside INLINABLE unfoldings, but inlinings+are not), the unfolding given to "filter" in the interface file will be:+  filter p []     = []+  filter p (x:xs) = if p x then x : build (\c n -> foldr (filterFB c p) n xs)+                           else     build (\c n -> foldr (filterFB c p) n xs++Note that because this unfolding does not mention "filter", filter is not+marked as a strong loop breaker. Therefore at a use site in another module:+  filter p xs+    = {inline}+      case xs of []     -> []+                 (x:xs) -> if p x then x : build (\c n -> foldr (filterFB c p) n xs)+                                  else     build (\c n -> foldr (filterFB c p) n xs)++  build (\c n -> foldr (filterFB c p) n xs)+    = {inline} foldr (filterFB (:) p) [] xs+    = {RULE}   filter p xs++And we are in an infinite loop again, except that this time the loop is producing an+infinitely large *term* (an unrolling of filter) and so the simplifier finally+dies with "ticks exhausted"++Because of this problem, we make a small change in the occurrence analyser+designed to mark functions like "filter" as strong loop breakers on the basis that:+  1. The RHS of filter mentions the local function "filterFB"+  2. We have a rule which mentions "filterFB" on the LHS and "filter" on the RHS++So for each RULE for an *imported* function we are going to add+dependency edges between the *local* FVS of the rule LHS and the+*local* FVS of the rule RHS. We don't do anything special for RULES on+local functions because the standard occurrence analysis stuff is+pretty good at getting loop-breakerness correct there.++It is important to note that even with this extra hack we aren't always going to get+things right. For example, it might be that the rule LHS mentions an imported Id,+and another module has a RULE that can rewrite that imported Id to one of our local+Ids.++Note [Specialising imported functions] (referred to from Specialise)+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+BUT for *automatically-generated* rules, the programmer can't be+responsible for the "programmer error" in Note [Rules for imported+functions].  In paricular, consider specialising a recursive function+defined in another module.  If we specialise a recursive function B.g,+we get+         g_spec = .....(B.g Int).....+         RULE B.g Int = g_spec+Here, g_spec doesn't look recursive, but when the rule fires, it+becomes so.  And if B.g was mutually recursive, the loop might+not be as obvious as it is here.++To avoid this,+ * When specialising a function that is a loop breaker,+   give a NOINLINE pragma to the specialised function++Note [Glomming]+~~~~~~~~~~~~~~~+RULES for imported Ids can make something at the top refer to something at the bottom:+        f = \x -> B.g (q x)+        h = \y -> 3++        RULE:  B.g (q x) = h x++Applying this rule makes f refer to h, although f doesn't appear to+depend on h.  (And, as in Note [Rules for imported functions], the+dependency might be more indirect. For example, f might mention C.t+rather than B.g, where C.t eventually inlines to B.g.)++NOTICE that this cannot happen for rules whose head is a+locally-defined function, because we accurately track dependencies+through RULES.  It only happens for rules whose head is an imported+function (B.g in the example above).++Solution:+  - When simplifying, bring all top level identifiers into+    scope at the start, ignoring the Rec/NonRec structure, so+    that when 'h' pops up in f's rhs, we find it in the in-scope set+    (as the simplifier generally expects). This happens in simplTopBinds.++  - In the occurrence analyser, if there are any out-of-scope+    occurrences that pop out of the top, which will happen after+    firing the rule:      f = \x -> h x+                          h = \y -> 3+    then just glom all the bindings into a single Rec, so that+    the *next* iteration of the occurrence analyser will sort+    them all out.   This part happens in occurAnalysePgm.++------------------------------------------------------------+Note [Inline rules]+~~~~~~~~~~~~~~~~~~~+None of the above stuff about RULES applies to Inline Rules,+stored in a CoreUnfolding.  The unfolding, if any, is simplified+at the same time as the regular RHS of the function (ie *not* like+Note [Rules are visible in their own rec group]), so it should be+treated *exactly* like an extra RHS.++Or, rather, when computing loop-breaker edges,+  * If f has an INLINE pragma, and it is active, we treat the+    INLINE rhs as f's rhs+  * If it's inactive, we treat f as having no rhs+  * If it has no INLINE pragma, we look at f's actual rhs+++There is a danger that we'll be sub-optimal if we see this+     f = ...f...+     [INLINE f = ..no f...]+where f is recursive, but the INLINE is not. This can just about+happen with a sufficiently odd set of rules; eg++        foo :: Int -> Int+        {-# INLINE [1] foo #-}+        foo x = x+1++        bar :: Int -> Int+        {-# INLINE [1] bar #-}+        bar x = foo x + 1++        {-# RULES "foo" [~1] forall x. foo x = bar x #-}++Here the RULE makes bar recursive; but it's INLINE pragma remains+non-recursive. It's tempting to then say that 'bar' should not be+a loop breaker, but an attempt to do so goes wrong in two ways:+   a) We may get+         $df = ...$cfoo...+         $cfoo = ...$df....+         [INLINE $cfoo = ...no-$df...]+      But we want $cfoo to depend on $df explicitly so that we+      put the bindings in the right order to inline $df in $cfoo+      and perhaps break the loop altogether.  (Maybe this+   b)+++Example [eftInt]+~~~~~~~~~~~~~~~+Example (from GHC.Enum):++  eftInt :: Int# -> Int# -> [Int]+  eftInt x y = ...(non-recursive)...++  {-# INLINE [0] eftIntFB #-}+  eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r+  eftIntFB c n x y = ...(non-recursive)...++  {-# RULES+  "eftInt"  [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)+  "eftIntList"  [1] eftIntFB  (:) [] = eftInt+   #-}++Note [Specialisation rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this group, which is typical of what SpecConstr builds:++   fs a = ....f (C a)....+   f  x = ....f (C a)....+   {-# RULE f (C a) = fs a #-}++So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE).++But watch out!  If 'fs' is not chosen as a loop breaker, we may get an infinite loop:+  - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify+  - fs is inlined (say it's small)+  - now there's another opportunity to apply the RULE++This showed up when compiling Control.Concurrent.Chan.getChanContents.++------------------------------------------------------------+Note [Finding join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~+It's the occurrence analyser's job to find bindings that we can turn into join+points, but it doesn't perform that transformation right away. Rather, it marks+the eligible bindings as part of their occurrence data, leaving it to the+simplifier (or to simpleOptPgm) to actually change the binder's 'IdDetails'.+The simplifier then eta-expands the RHS if needed and then updates the+occurrence sites. Dividing the work this way means that the occurrence analyser+still only takes one pass, yet one can always tell the difference between a+function call and a jump by looking at the occurrence (because the same pass+changes the 'IdDetails' and propagates the binders to their occurrence sites).++To track potential join points, we use the 'occ_tail' field of OccInfo. A value+of `AlwaysTailCalled n` indicates that every occurrence of the variable is a+tail call with `n` arguments (counting both value and type arguments). Otherwise+'occ_tail' will be 'NoTailCallInfo'. The tail call info flows bottom-up with the+rest of 'OccInfo' until it goes on the binder.++Note [Rules and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Things get fiddly with rules. Suppose we have:++  let j :: Int -> Int+      j y = 2 * y+      k :: Int -> Int -> Int+      {-# RULES "SPEC k 0" k 0 = j #-}+      k x y = x + 2 * y+  in ...++Now suppose that both j and k appear only as saturated tail calls in the body.+Thus we would like to make them both join points. The rule complicates matters,+though, as its RHS has an unapplied occurrence of j. *However*, if we were to+eta-expand the rule, all would be well:++  {-# RULES "SPEC k 0" forall a. k 0 a = j a #-}++So conceivably we could notice that a potential join point would have an+"undersaturated" rule and account for it. This would mean we could make+something that's been specialised a join point, for instance. But local bindings+are rarely specialised, and being overly cautious about rules only+costs us anything when, for some `j`:++  * Before specialisation, `j` has non-tail calls, so it can't be a join point.+  * During specialisation, `j` gets specialised and thus acquires rules.+  * Sometime afterward, the non-tail calls to `j` disappear (as dead code, say),+    and so now `j` *could* become a join point.++This appears to be very rare in practice. TODO Perhaps we should gather+statistics to be sure.++Note [Excess polymorphism and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++In principle, if a function would be a join point except that it fails+the polymorphism rule (see Note [The polymorphism rule of join points] in+CoreSyn), it can still be made a join point with some effort. This is because+all tail calls must return the same type (they return to the same context!), and+thus if the return type depends on an argument, that argument must always be the+same.++For instance, consider:++  let f :: forall a. a -> Char -> [a]+      f @a x c = ... f @a x 'a' ...+  in ... f @Int 1 'b' ... f @Int 2 'c' ...++(where the calls are tail calls). `f` fails the polymorphism rule because its+return type is [a], where [a] is bound. But since the type argument is always+'Int', we can rewrite it as:++  let f' :: Int -> Char -> [Int]+      f' x c = ... f' x 'a' ...+  in ... f' 1 'b' ... f 2 'c' ...++and now we can make f' a join point:++  join f' :: Int -> Char -> [Int]+       f' x c = ... jump f' x 'a' ...+  in ... jump f' 1 'b' ... jump f' 2 'c' ...++It's not clear that this comes up often, however. TODO: Measure how often and+add this analysis if necessary.++------------------------------------------------------------+Note [Adjusting for lambdas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There's a bit of a dance we need to do after analysing a lambda expression or+a right-hand side. In particular, we need to++  a) call 'markAllInsideLam' *unless* the binding is for a thunk, a one-shot+     lambda, or a non-recursive join point; and+  b) call 'markAllNonTailCalled' *unless* the binding is for a join point.++Some examples, with how the free occurrences in e (assumed not to be a value+lambda) get marked:++                             inside lam    non-tail-called+  ------------------------------------------------------------+  let x = e                  No            Yes+  let f = \x -> e            Yes           Yes+  let f = \x{OneShot} -> e   No            Yes+  \x -> e                    Yes           Yes+  join j x = e               No            No+  joinrec j x = e            Yes           No++There are a few other caveats; most importantly, if we're marking a binding as+'AlwaysTailCalled', it's *going* to be a join point, so we treat it as one so+that the effect cascades properly. Consequently, at the time the RHS is+analysed, we won't know what adjustments to make; thus 'occAnalLamOrRhs' must+return the unadjusted 'UsageDetails', to be adjusted by 'adjustRhsUsage' once+join-point-hood has been decided.++Thus the overall sequence taking place in 'occAnalNonRecBind' and+'occAnalRecBind' is as follows:++  1. Call 'occAnalLamOrRhs' to find usage information for the RHS.+  2. Call 'tagNonRecBinder' or 'tagRecBinders', which decides whether to make+     the binding a join point.+  3. Call 'adjustRhsUsage' accordingly. (Done as part of 'tagRecBinders' when+     recursive.)++(In the recursive case, this logic is spread between 'makeNode' and+'occAnalRec'.)+-}++------------------------------------------------------------------+--                 occAnalBind+------------------------------------------------------------------++occAnalBind :: OccEnv           -- The incoming OccEnv+            -> TopLevelFlag+            -> ImpRuleEdges+            -> CoreBind+            -> UsageDetails             -- Usage details of scope+            -> (UsageDetails,           -- Of the whole let(rec)+                [CoreBind])++occAnalBind env lvl top_env (NonRec binder rhs) body_usage+  = occAnalNonRecBind env lvl top_env binder rhs body_usage+occAnalBind env lvl top_env (Rec pairs) body_usage+  = occAnalRecBind env lvl top_env pairs body_usage++-----------------+occAnalNonRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> Var -> CoreExpr+                  -> UsageDetails -> (UsageDetails, [CoreBind])+occAnalNonRecBind env lvl imp_rule_edges binder rhs body_usage+  | isTyVar binder      -- A type let; we don't gather usage info+  = (body_usage, [NonRec binder rhs])++  | not (binder `usedIn` body_usage)    -- It's not mentioned+  = (body_usage, [])++  | otherwise                   -- It's mentioned in the body+  = (body_usage' +++ rhs_usage', [NonRec tagged_binder rhs'])+  where+    (body_usage', tagged_binder) = tagNonRecBinder lvl body_usage binder+    mb_join_arity = willBeJoinId_maybe tagged_binder++    (bndrs, body) = collectBinders rhs++    (rhs_usage1, bndrs', body') = occAnalNonRecRhs env tagged_binder bndrs body+    rhs' = mkLams (markJoinOneShots mb_join_arity bndrs') body'+           -- For a /non-recursive/ join point we can mark all+           -- its join-lambda as one-shot; and it's a good idea to do so++    -- Unfoldings+    -- See Note [Unfoldings and join points]+    rhs_usage2 = case occAnalUnfolding env NonRecursive binder of+                   Just unf_usage -> rhs_usage1 +++ unf_usage+                   Nothing        -> rhs_usage1++    -- Rules+    -- See Note [Rules are extra RHSs] and Note [Rule dependency info]+    rules_w_uds = occAnalRules env mb_join_arity NonRecursive tagged_binder+    rhs_usage3 = rhs_usage2 +++ combineUsageDetailsList+                                  (map (\(_, l, r) -> l +++ r) rules_w_uds)+    rhs_usage4 = maybe rhs_usage3 (addManyOccsSet rhs_usage3) $+                 lookupVarEnv imp_rule_edges binder+       -- See Note [Preventing loops due to imported functions rules]++    -- Final adjustment+    rhs_usage' = adjustRhsUsage mb_join_arity NonRecursive bndrs' rhs_usage4++-----------------+occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)]+               -> UsageDetails -> (UsageDetails, [CoreBind])+occAnalRecBind env lvl imp_rule_edges pairs body_usage+  = foldr (occAnalRec lvl) (body_usage, []) sccs+        -- For a recursive group, we+        --      * occ-analyse all the RHSs+        --      * compute strongly-connected components+        --      * feed those components to occAnalRec+        -- See Note [Recursive bindings: the grand plan]+  where+    sccs :: [SCC Details]+    sccs = {-# SCC "occAnalBind.scc" #-}+           stronglyConnCompFromEdgedVerticesUniq nodes++    nodes :: [LetrecNode]+    nodes = {-# SCC "occAnalBind.assoc" #-}+            map (makeNode env imp_rule_edges bndr_set) pairs++    bndr_set = mkVarSet (map fst pairs)++{-+Note [Unfoldings and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We assume that anything in an unfolding occurs multiple times, since unfoldings+are often copied (that's the whole point!). But we still need to track tail+calls for the purpose of finding join points.+-}++-----------------------------+occAnalRec :: TopLevelFlag+           -> SCC Details+           -> (UsageDetails, [CoreBind])+           -> (UsageDetails, [CoreBind])++        -- The NonRec case is just like a Let (NonRec ...) above+occAnalRec lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs+                               , nd_uds = rhs_uds, nd_rhs_bndrs = rhs_bndrs }))+           (body_uds, binds)+  | not (bndr `usedIn` body_uds)+  = (body_uds, binds)           -- See Note [Dead code]++  | otherwise                   -- It's mentioned in the body+  = (body_uds' +++ rhs_uds',+     NonRec tagged_bndr rhs : binds)+  where+    (body_uds', tagged_bndr) = tagNonRecBinder lvl body_uds bndr+    rhs_uds' = adjustRhsUsage (willBeJoinId_maybe tagged_bndr) NonRecursive+                              rhs_bndrs rhs_uds++        -- The Rec case is the interesting one+        -- See Note [Recursive bindings: the grand plan]+        -- See Note [Loop breaking]+occAnalRec lvl (CyclicSCC details_s) (body_uds, binds)+  | not (any (`usedIn` body_uds) bndrs) -- NB: look at body_uds, not total_uds+  = (body_uds, binds)                   -- See Note [Dead code]++  | otherwise   -- At this point we always build a single Rec+  = -- pprTrace "occAnalRec" (vcat+    --  [ text "weak_fvs" <+> ppr weak_fvs+    --  , text "tagged details" <+> ppr tagged_details_s+    --  , text "lb nodes" <+> ppr loop_breaker_nodes])+    (final_uds, Rec pairs : binds)++  where+    bndrs    = map nd_bndr details_s+    bndr_set = mkVarSet bndrs++    ------------------------------+        -- See Note [Choosing loop breakers] for loop_breaker_nodes+    final_uds :: UsageDetails+    loop_breaker_nodes :: [LetrecNode]+    (final_uds, loop_breaker_nodes)+      = mkLoopBreakerNodes lvl bndr_set body_uds details_s++    ------------------------------+    weak_fvs :: VarSet+    weak_fvs = mapUnionVarSet nd_weak details_s++    ---------------------------+    -- Now reconstruct the cycle+    pairs :: [(Id,CoreExpr)]+    pairs | isEmptyVarSet weak_fvs = reOrderNodes   0 bndr_set weak_fvs loop_breaker_nodes []+          | otherwise              = loopBreakNodes 0 bndr_set weak_fvs loop_breaker_nodes []+          -- If weak_fvs is empty, the loop_breaker_nodes will include+          -- all the edges in the original scope edges [remember,+          -- weak_fvs is the difference between scope edges and+          -- lb-edges], so a fresh SCC computation would yield a+          -- single CyclicSCC result; and reOrderNodes deals with+          -- exactly that case+++------------------------------------------------------------------+--                 Loop breaking+------------------------------------------------------------------++type Binding = (Id,CoreExpr)++loopBreakNodes :: Int+               -> VarSet        -- All binders+               -> VarSet        -- Binders whose dependencies may be "missing"+                                -- See Note [Weak loop breakers]+               -> [LetrecNode]+               -> [Binding]             -- Append these to the end+               -> [Binding]+{-+loopBreakNodes is applied to the list of nodes for a cyclic strongly+connected component (there's guaranteed to be a cycle).  It returns+the same nodes, but+        a) in a better order,+        b) with some of the Ids having a IAmALoopBreaker pragma++The "loop-breaker" Ids are sufficient to break all cycles in the SCC.  This means+that the simplifier can guarantee not to loop provided it never records an inlining+for these no-inline guys.++Furthermore, the order of the binds is such that if we neglect dependencies+on the no-inline Ids then the binds are topologically sorted.  This means+that the simplifier will generally do a good job if it works from top bottom,+recording inlinings for any Ids which aren't marked as "no-inline" as it goes.+-}++-- Return the bindings sorted into a plausible order, and marked with loop breakers.+loopBreakNodes depth bndr_set weak_fvs nodes binds+  = go (stronglyConnCompFromEdgedVerticesUniqR nodes) binds+  where+    go []         binds = binds+    go (scc:sccs) binds = loop_break_scc scc (go sccs binds)++    loop_break_scc scc binds+      = case scc of+          AcyclicSCC node  -> mk_non_loop_breaker weak_fvs node : binds+          CyclicSCC nodes  -> reOrderNodes depth bndr_set weak_fvs nodes binds++----------------------------------+reOrderNodes :: Int -> VarSet -> VarSet -> [LetrecNode] -> [Binding] -> [Binding]+    -- Choose a loop breaker, mark it no-inline,+    -- and call loopBreakNodes on the rest+reOrderNodes _ _ _ []     _     = panic "reOrderNodes"+reOrderNodes _ _ _ [node] binds = mk_loop_breaker node : binds+reOrderNodes depth bndr_set weak_fvs (node : nodes) binds+  = -- pprTrace "reOrderNodes" (text "unchosen" <+> ppr unchosen $$+    --                           text "chosen" <+> ppr chosen_nodes) $+    loopBreakNodes new_depth bndr_set weak_fvs unchosen $+    (map mk_loop_breaker chosen_nodes ++ binds)+  where+    (chosen_nodes, unchosen) = chooseLoopBreaker approximate_lb+                                                 (nd_score (fstOf3 node))+                                                 [node] [] nodes++    approximate_lb = depth >= 2+    new_depth | approximate_lb = 0+              | otherwise      = depth+1+        -- After two iterations (d=0, d=1) give up+        -- and approximate, returning to d=0++mk_loop_breaker :: LetrecNode -> Binding+mk_loop_breaker (ND { nd_bndr = bndr, nd_rhs = rhs}, _, _)+  = (bndr `setIdOccInfo` strongLoopBreaker { occ_tail = tail_info }, rhs)+  where+    tail_info = tailCallInfo (idOccInfo bndr)++mk_non_loop_breaker :: VarSet -> LetrecNode -> Binding+-- See Note [Weak loop breakers]+mk_non_loop_breaker weak_fvs (ND { nd_bndr = bndr, nd_rhs = rhs}, _, _)+  | bndr `elemVarSet` weak_fvs = (setIdOccInfo bndr occ', rhs)+  | otherwise                  = (bndr, rhs)+  where+    occ' = weakLoopBreaker { occ_tail = tail_info }+    tail_info = tailCallInfo (idOccInfo bndr)++----------------------------------+chooseLoopBreaker :: Bool             -- True <=> Too many iterations,+                                      --          so approximate+                  -> NodeScore            -- Best score so far+                  -> [LetrecNode]       -- Nodes with this score+                  -> [LetrecNode]       -- Nodes with higher scores+                  -> [LetrecNode]       -- Unprocessed nodes+                  -> ([LetrecNode], [LetrecNode])+    -- This loop looks for the bind with the lowest score+    -- to pick as the loop  breaker.  The rest accumulate in+chooseLoopBreaker _ _ loop_nodes acc []+  = (loop_nodes, acc)        -- Done++    -- If approximate_loop_breaker is True, we pick *all*+    -- nodes with lowest score, else just one+    -- See Note [Complexity of loop breaking]+chooseLoopBreaker approx_lb loop_sc loop_nodes acc (node : nodes)+  | approx_lb+  , rank sc == rank loop_sc+  = chooseLoopBreaker approx_lb loop_sc (node : loop_nodes) acc nodes++  | sc `betterLB` loop_sc  -- Better score so pick this new one+  = chooseLoopBreaker approx_lb sc [node] (loop_nodes ++ acc) nodes++  | otherwise              -- Worse score so don't pick it+  = chooseLoopBreaker approx_lb loop_sc loop_nodes (node : acc) nodes+  where+    sc = nd_score (fstOf3 node)++{-+Note [Complexity of loop breaking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The loop-breaking algorithm knocks out one binder at a time, and+performs a new SCC analysis on the remaining binders.  That can+behave very badly in tightly-coupled groups of bindings; in the+worst case it can be (N**2)*log N, because it does a full SCC+on N, then N-1, then N-2 and so on.++To avoid this, we switch plans after 2 (or whatever) attempts:+  Plan A: pick one binder with the lowest score, make it+          a loop breaker, and try again+  Plan B: pick *all* binders with the lowest score, make them+          all loop breakers, and try again+Since there are only a small finite number of scores, this will+terminate in a constant number of iterations, rather than O(N)+iterations.++You might thing that it's very unlikely, but RULES make it much+more likely.  Here's a real example from Trac #1969:+  Rec { $dm = \d.\x. op d+        {-# RULES forall d. $dm Int d  = $s$dm1+                  forall d. $dm Bool d = $s$dm2 #-}++        dInt = MkD .... opInt ...+        dInt = MkD .... opBool ...+        opInt  = $dm dInt+        opBool = $dm dBool++        $s$dm1 = \x. op dInt+        $s$dm2 = \x. op dBool }+The RULES stuff means that we can't choose $dm as a loop breaker+(Note [Choosing loop breakers]), so we must choose at least (say)+opInt *and* opBool, and so on.  The number of loop breakders is+linear in the number of instance declarations.++Note [Loop breakers and INLINE/INLINABLE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Avoid choosing a function with an INLINE pramga as the loop breaker!+If such a function is mutually-recursive with a non-INLINE thing,+then the latter should be the loop-breaker.++It's vital to distinguish between INLINE and INLINABLE (the+Bool returned by hasStableCoreUnfolding_maybe).  If we start with+   Rec { {-# INLINABLE f #-}+         f x = ...f... }+and then worker/wrapper it through strictness analysis, we'll get+   Rec { {-# INLINABLE $wf #-}+         $wf p q = let x = (p,q) in ...f...++         {-# INLINE f #-}+         f x = case x of (p,q) -> $wf p q }++Now it is vital that we choose $wf as the loop breaker, so we can+inline 'f' in '$wf'.++Note [DFuns should not be loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's particularly bad to make a DFun into a loop breaker.  See+Note [How instance declarations are translated] in TcInstDcls++We give DFuns a higher score than ordinary CONLIKE things because+if there's a choice we want the DFun to be the non-loop breaker. Eg++rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC)++      $fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE)+      {-# DFUN #-}+      $fCT = /\a \$dC. MkD (T a) ((sc @ a $dC) |> blah) ($ctoF @ a $dC)+    }++Here 'sc' (the superclass) looks CONLIKE, but we'll never get to it+if we can't unravel the DFun first.++Note [Constructor applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's really really important to inline dictionaries.  Real+example (the Enum Ordering instance from GHC.Base):++     rec     f = \ x -> case d of (p,q,r) -> p x+             g = \ x -> case d of (p,q,r) -> q x+             d = (v, f, g)++Here, f and g occur just once; but we can't inline them into d.+On the other hand we *could* simplify those case expressions if+we didn't stupidly choose d as the loop breaker.+But we won't because constructor args are marked "Many".+Inlining dictionaries is really essential to unravelling+the loops in static numeric dictionaries, see GHC.Float.++Note [Closure conversion]+~~~~~~~~~~~~~~~~~~~~~~~~~+We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm.+The immediate motivation came from the result of a closure-conversion transformation+which generated code like this:++    data Clo a b = forall c. Clo (c -> a -> b) c++    ($:) :: Clo a b -> a -> b+    Clo f env $: x = f env x++    rec { plus = Clo plus1 ()++        ; plus1 _ n = Clo plus2 n++        ; plus2 Zero     n = n+        ; plus2 (Succ m) n = Succ (plus $: m $: n) }++If we inline 'plus' and 'plus1', everything unravels nicely.  But if+we choose 'plus1' as the loop breaker (which is entirely possible+otherwise), the loop does not unravel nicely.+++@occAnalUnfolding@ deals with the question of bindings where the Id is marked+by an INLINE pragma.  For these we record that anything which occurs+in its RHS occurs many times.  This pessimistically assumes that this+inlined binder also occurs many times in its scope, but if it doesn't+we'll catch it next time round.  At worst this costs an extra simplifier pass.+ToDo: try using the occurrence info for the inline'd binder.++[March 97] We do the same for atomic RHSs.  Reason: see notes with loopBreakSCC.+[June 98, SLPJ]  I've undone this change; I don't understand it.  See notes with loopBreakSCC.+++************************************************************************+*                                                                      *+                   Making nodes+*                                                                      *+************************************************************************+-}++type ImpRuleEdges = IdEnv IdSet     -- Mapping from FVs of imported RULE LHSs to RHS FVs++noImpRuleEdges :: ImpRuleEdges+noImpRuleEdges = emptyVarEnv++type LetrecNode = Node Unique Details  -- Node comes from Digraph+                                       -- The Unique key is gotten from the Id+data Details+  = ND { nd_bndr :: Id          -- Binder+       , nd_rhs  :: CoreExpr    -- RHS, already occ-analysed+       , nd_rhs_bndrs :: [CoreBndr] -- Outer lambdas of RHS+                                    -- INVARIANT: (nd_rhs_bndrs nd, _) ==+                                    --              collectBinders (nd_rhs nd)++       , nd_uds  :: UsageDetails  -- Usage from RHS, and RULES, and stable unfoldings+                                  -- ignoring phase (ie assuming all are active)+                                  -- See Note [Forming Rec groups]++       , nd_inl  :: IdSet       -- Free variables of+                                --   the stable unfolding (if present and active)+                                --   or the RHS (if not)+                                -- but excluding any RULES+                                -- This is the IdSet that may be used if the Id is inlined++       , nd_weak :: IdSet       -- Binders of this Rec that are mentioned in nd_uds+                                -- but are *not* in nd_inl.  These are the ones whose+                                -- dependencies might not be respected by loop_breaker_nodes+                                -- See Note [Weak loop breakers]++       , nd_active_rule_fvs :: IdSet   -- Free variables of the RHS of active RULES++       , nd_score :: NodeScore+  }++instance Outputable Details where+   ppr nd = text "ND" <> braces+             (sep [ text "bndr =" <+> ppr (nd_bndr nd)+                  , text "uds =" <+> ppr (nd_uds nd)+                  , text "inl =" <+> ppr (nd_inl nd)+                  , text "weak =" <+> ppr (nd_weak nd)+                  , text "rule =" <+> ppr (nd_active_rule_fvs nd)+             ])++-- The NodeScore is compared lexicographically;+--      e.g. lower rank wins regardless of size+type NodeScore = ( Int     -- Rank: lower => more likely to be picked as loop breaker+                 , Int     -- Size of rhs: higher => more likely to be picked as LB+                           -- Maxes out at maxExprSize; we just use it to prioritise+                           -- small functions+                 , Bool )  -- Was it a loop breaker before?+                           -- True => more likely to be picked+                           -- Note [Loop breakers, node scoring, and stability]++rank :: NodeScore -> Int+rank (r, _, _) = r++makeNode :: OccEnv -> ImpRuleEdges -> VarSet+         -> (Var, CoreExpr) -> LetrecNode+-- See Note [Recursive bindings: the grand plan]+makeNode env imp_rule_edges bndr_set (bndr, rhs)+  = (details, varUnique bndr, nonDetKeysUniqSet node_fvs)+    -- It's OK to use nonDetKeysUniqSet here as stronglyConnCompFromEdgedVerticesR+    -- is still deterministic with edges in nondeterministic order as+    -- explained in Note [Deterministic SCC] in Digraph.+  where+    details = ND { nd_bndr            = bndr+                 , nd_rhs             = rhs'+                 , nd_rhs_bndrs       = bndrs'+                 , nd_uds             = rhs_usage3+                 , nd_inl             = inl_fvs+                 , nd_weak            = node_fvs `minusVarSet` inl_fvs+                 , nd_active_rule_fvs = active_rule_fvs+                 , nd_score           = pprPanic "makeNodeDetails" (ppr bndr) }++    -- Constructing the edges for the main Rec computation+    -- See Note [Forming Rec groups]+    (bndrs, body) = collectBinders rhs+    (rhs_usage1, bndrs', body') = occAnalRecRhs env bndrs body+    rhs' = mkLams bndrs' body'+    rhs_usage2 = rhs_usage1 +++ all_rule_uds+                   -- Note [Rules are extra RHSs]+                   -- Note [Rule dependency info]+    rhs_usage3 = case mb_unf_uds of+                   Just unf_uds -> rhs_usage2 +++ unf_uds+                   Nothing      -> rhs_usage2+    node_fvs = udFreeVars bndr_set rhs_usage3++    -- Finding the free variables of the rules+    is_active = occ_rule_act env :: Activation -> Bool++    rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)]+    rules_w_uds = occAnalRules env (Just (length bndrs)) Recursive bndr++    rules_w_rhs_fvs :: [(Activation, VarSet)]    -- Find the RHS fvs+    rules_w_rhs_fvs = maybe id (\ids -> ((AlwaysActive, ids):))+                               (lookupVarEnv imp_rule_edges bndr)+      -- See Note [Preventing loops due to imported functions rules]+                      [ (ru_act rule, udFreeVars bndr_set rhs_uds)+                      | (rule, _, rhs_uds) <- rules_w_uds ]+    all_rule_uds = combineUsageDetailsList $+                     concatMap (\(_, l, r) -> [l, r]) rules_w_uds+    active_rule_fvs = unionVarSets [fvs | (a,fvs) <- rules_w_rhs_fvs+                                        , is_active a]++    -- Finding the usage details of the INLINE pragma (if any)+    mb_unf_uds = occAnalUnfolding env Recursive bndr++    -- Find the "nd_inl" free vars; for the loop-breaker phase+    inl_fvs = case mb_unf_uds of+                Nothing -> udFreeVars bndr_set rhs_usage1 -- No INLINE, use RHS+                Just unf_uds -> udFreeVars bndr_set unf_uds+                      -- We could check for an *active* INLINE (returning+                      -- emptyVarSet for an inactive one), but is_active+                      -- isn't the right thing (it tells about+                      -- RULE activation), so we'd need more plumbing++mkLoopBreakerNodes :: TopLevelFlag+                   -> VarSet+                   -> UsageDetails   -- for BODY of let+                   -> [Details]+                   -> (UsageDetails, -- adjusted+                       [LetrecNode])+-- Does four things+--   a) tag each binder with its occurrence info+--   b) add a NodeScore to each node+--   c) make a Node with the right dependency edges for+--      the loop-breaker SCC analysis+--   d) adjust each RHS's usage details according to+--      the binder's (new) shotness and join-point-hood+mkLoopBreakerNodes lvl bndr_set body_uds details_s+  = (final_uds, zipWith mk_lb_node details_s bndrs')+  where+    (final_uds, bndrs') = tagRecBinders lvl body_uds+                            [ (nd_bndr nd, nd_uds nd, nd_rhs_bndrs nd)+                            | nd <- details_s ]+    mk_lb_node nd@(ND { nd_bndr = bndr, nd_rhs = rhs, nd_inl = inl_fvs }) bndr'+      = (nd', varUnique bndr, nonDetKeysUniqSet lb_deps)+              -- It's OK to use nonDetKeysUniqSet here as+              -- stronglyConnCompFromEdgedVerticesR is still deterministic with edges+              -- in nondeterministic order as explained in+              -- Note [Deterministic SCC] in Digraph.+      where+        nd'     = nd { nd_bndr = bndr', nd_score = score }+        score   = nodeScore bndr bndr' rhs lb_deps+        lb_deps = extendFvs_ rule_fv_env inl_fvs++    rule_fv_env :: IdEnv IdSet+        -- Maps a variable f to the variables from this group+        --      mentioned in RHS of active rules for f+        -- Domain is *subset* of bound vars (others have no rule fvs)+    rule_fv_env = transClosureFV (mkVarEnv init_rule_fvs)+    init_rule_fvs   -- See Note [Finding rule RHS free vars]+      = [ (b, trimmed_rule_fvs)+        | ND { nd_bndr = b, nd_active_rule_fvs = rule_fvs } <- details_s+        , let trimmed_rule_fvs = rule_fvs `intersectVarSet` bndr_set+        , not (isEmptyVarSet trimmed_rule_fvs) ]+++------------------------------------------+nodeScore :: Id        -- Binder has old occ-info (just for loop-breaker-ness)+          -> Id        -- Binder with new occ-info+          -> CoreExpr  -- RHS+          -> VarSet    -- Loop-breaker dependencies+          -> NodeScore+nodeScore old_bndr new_bndr bind_rhs lb_deps+  | not (isId old_bndr)     -- A type or cercion variable is never a loop breaker+  = (100, 0, False)++  | old_bndr `elemVarSet` lb_deps  -- Self-recursive things are great loop breakers+  = (0, 0, True)                   -- See Note [Self-recursion and loop breakers]++  | exprIsTrivial rhs+  = mk_score 10  -- Practically certain to be inlined+    -- Used to have also: && not (isExportedId bndr)+    -- But I found this sometimes cost an extra iteration when we have+    --      rec { d = (a,b); a = ...df...; b = ...df...; df = d }+    -- where df is the exported dictionary. Then df makes a really+    -- bad choice for loop breaker++  | DFunUnfolding { df_args = args } <- id_unfolding+    -- Never choose a DFun as a loop breaker+    -- Note [DFuns should not be loop breakers]+  = (9, length args, is_lb)++    -- Data structures are more important than INLINE pragmas+    -- so that dictionary/method recursion unravels++  | CoreUnfolding { uf_guidance = UnfWhen {} } <- id_unfolding+  = mk_score 6++  | is_con_app rhs   -- Data types help with cases:+  = mk_score 5       -- Note [Constructor applications]++  | isStableUnfolding id_unfolding+  , can_unfold+  = mk_score 3++  | isOneOcc (idOccInfo new_bndr)+  = mk_score 2  -- Likely to be inlined++  | can_unfold  -- The Id has some kind of unfolding+  = mk_score 1++  | otherwise+  = (0, 0, is_lb)++  where+    mk_score :: Int -> NodeScore+    mk_score rank = (rank, rhs_size, is_lb)++    is_lb    = isStrongLoopBreaker (idOccInfo old_bndr)+    rhs      = case id_unfolding of+                 CoreUnfolding { uf_src = src, uf_tmpl = unf_rhs }+                    | isStableSource src+                    -> unf_rhs+                 _  -> bind_rhs+       -- 'bind_rhs' is irrelevant for inlining things with a stable unfolding+    rhs_size = case id_unfolding of+                 CoreUnfolding { uf_guidance = guidance }+                    | UnfIfGoodArgs { ug_size = size } <- guidance+                    -> size+                 _  -> cheapExprSize rhs++    can_unfold   = canUnfold id_unfolding+    id_unfolding = realIdUnfolding old_bndr+       -- realIdUnfolding: Ignore loop-breaker-ness here because+       -- that is what we are setting!++        -- Checking for a constructor application+        -- Cheap and cheerful; the simplifier moves casts out of the way+        -- The lambda case is important to spot x = /\a. C (f a)+        -- which comes up when C is a dictionary constructor and+        -- f is a default method.+        -- Example: the instance for Show (ST s a) in GHC.ST+        --+        -- However we *also* treat (\x. C p q) as a con-app-like thing,+        --      Note [Closure conversion]+    is_con_app (Var v)    = isConLikeId v+    is_con_app (App f _)  = is_con_app f+    is_con_app (Lam _ e)  = is_con_app e+    is_con_app (Tick _ e) = is_con_app e+    is_con_app _          = False++maxExprSize :: Int+maxExprSize = 20  -- Rather arbitrary++cheapExprSize :: CoreExpr -> Int+-- Maxes out at maxExprSize+cheapExprSize e+  = go 0 e+  where+    go n e | n >= maxExprSize = n+           | otherwise        = go1 n e++    go1 n (Var {})        = n+1+    go1 n (Lit {})        = n+1+    go1 n (Type {})       = n+    go1 n (Coercion {})   = n+    go1 n (Tick _ e)      = go1 n e+    go1 n (Cast e _)      = go1 n e+    go1 n (App f a)       = go (go1 n f) a+    go1 n (Lam b e)+      | isTyVar b         = go1 n e+      | otherwise         = go (n+1) e+    go1 n (Let b e)       = gos (go1 n e) (rhssOfBind b)+    go1 n (Case e _ _ as) = gos (go1 n e) (rhssOfAlts as)++    gos n [] = n+    gos n (e:es) | n >= maxExprSize = n+                 | otherwise        = gos (go1 n e) es++betterLB :: NodeScore -> NodeScore -> Bool+-- If  n1 `betterLB` n2  then choose n1 as the loop breaker+betterLB (rank1, size1, lb1) (rank2, size2, _)+  | rank1 < rank2 = True+  | rank1 > rank2 = False+  | size1 < size2 = False   -- Make the bigger n2 into the loop breaker+  | size1 > size2 = True+  | lb1           = True    -- Tie-break: if n1 was a loop breaker before, choose it+  | otherwise     = False   -- See Note [Loop breakers, node scoring, and stability]++{- Note [Self-recursion and loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have+   rec { f = ...f...g...+       ; g = .....f...   }+then 'f' has to be a loop breaker anyway, so we may as well choose it+right away, so that g can inline freely.++This is really just a cheap hack. Consider+   rec { f = ...g...+       ; g = ..f..h...+      ;  h = ...f....}+Here f or g are better loop breakers than h; but we might accidentally+choose h.  Finding the minimal set of loop breakers is hard.++Note [Loop breakers, node scoring, and stability]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To choose a loop breaker, we give a NodeScore to each node in the SCC,+and pick the one with the best score (according to 'betterLB').++We need to be jolly careful (Trac #12425, #12234) about the stability+of this choice. Suppose we have++    let rec { f = ...g...g...+            ; g = ...f...f... }+    in+    case x of+      True  -> ...f..+      False -> ..f...++In each iteration of the simplifier the occurrence analyser OccAnal+chooses a loop breaker. Suppose in iteration 1 it choose g as the loop+breaker. That means it is free to inline f.++Suppose that GHC decides to inline f in the branches of the case, but+(for some reason; eg it is not saturated) in the rhs of g. So we get++    let rec { f = ...g...g...+            ; g = ...f...f... }+    in+    case x of+      True  -> ...g...g.....+      False -> ..g..g....++Now suppose that, for some reason, in the next iteration the occurrence+analyser chooses f as the loop breaker, so it can freely inline g. And+again for some reason the simplifier inlines g at its calls in the case+branches, but not in the RHS of f. Then we get++    let rec { f = ...g...g...+            ; g = ...f...f... }+    in+    case x of+      True  -> ...(...f...f...)...(...f..f..).....+      False -> ..(...f...f...)...(..f..f...)....++You can see where this is going! Each iteration of the simplifier+doubles the number of calls to f or g. No wonder GHC is slow!++(In the particular example in comment:3 of #12425, f and g are the two+mutually recursive fmap instances for CondT and Result. They are both+marked INLINE which, oddly, is why they don't inline in each other's+RHS, because the call there is not saturated.)++The root cause is that we flip-flop on our choice of loop breaker. I+always thought it didn't matter, and indeed for any single iteration+to terminate, it doesn't matter. But when we iterate, it matters a+lot!!++So The Plan is this:+   If there is a tie, choose the node that+   was a loop breaker last time round++Hence the is_lb field of NodeScore++************************************************************************+*                                                                      *+                   Right hand sides+*                                                                      *+************************************************************************+-}++occAnalRhs :: OccEnv -> RecFlag -> Id -> [CoreBndr] -> CoreExpr+           -> (UsageDetails, [CoreBndr], CoreExpr)+              -- Returned usage details covers only the RHS,+              -- and *not* the RULE or INLINE template for the Id+occAnalRhs env Recursive _ bndrs body+  = occAnalRecRhs env bndrs body+occAnalRhs env NonRecursive id bndrs body+  = occAnalNonRecRhs env id bndrs body++occAnalRecRhs :: OccEnv -> [CoreBndr] -> CoreExpr    -- Rhs lambdas, body+           -> (UsageDetails, [CoreBndr], CoreExpr)+              -- Returned usage details covers only the RHS,+              -- and *not* the RULE or INLINE template for the Id+occAnalRecRhs env bndrs body = occAnalLamOrRhs (rhsCtxt env) bndrs body++occAnalNonRecRhs :: OccEnv+                 -> Id -> [CoreBndr] -> CoreExpr    -- Binder; rhs lams, body+                     -- Binder is already tagged with occurrence info+                 -> (UsageDetails, [CoreBndr], CoreExpr)+              -- Returned usage details covers only the RHS,+              -- and *not* the RULE or INLINE template for the Id+occAnalNonRecRhs env bndr bndrs body+  = occAnalLamOrRhs rhs_env bndrs body+  where+    -- See Note [Cascading inlines]+    env1 | certainly_inline = env+         | otherwise        = rhsCtxt env++    -- See Note [Sources of one-shot information]+    rhs_env = env1 { occ_one_shots = argOneShots dmd }++    certainly_inline -- See Note [Cascading inlines]+      = case idOccInfo bndr of+          OneOcc { occ_in_lam = in_lam, occ_one_br = one_br }+                                 -> not in_lam && one_br && active && not_stable+          _                      -> False++    dmd        = idDemandInfo bndr+    active     = isAlwaysActive (idInlineActivation bndr)+    not_stable = not (isStableUnfolding (idUnfolding bndr))++occAnalUnfolding :: OccEnv+                 -> RecFlag+                 -> Id+                 -> Maybe UsageDetails+                      -- Just the analysis, not a new unfolding. The unfolding+                      -- got analysed when it was created and we don't need to+                      -- update it.+occAnalUnfolding env rec_flag id+  = case realIdUnfolding id of -- ignore previous loop-breaker flag+      CoreUnfolding { uf_tmpl = rhs, uf_src = src }+        | not (isStableSource src)+        -> Nothing+        | otherwise+        -> Just $ markAllMany usage+        where+          (bndrs, body) = collectBinders rhs+          (usage, _, _) = occAnalRhs env rec_flag id bndrs body++      DFunUnfolding { df_bndrs = bndrs, df_args = args }+        -> Just $ zapDetails (delDetailsList usage bndrs)+        where+          usage = foldr (+++) emptyDetails (map (fst . occAnal env) args)++      _ -> Nothing++occAnalRules :: OccEnv+             -> Maybe JoinArity -- If the binder is (or MAY become) a join+                                -- point, what its join arity is (or WOULD+                                -- become). See Note [Rules and join points].+             -> RecFlag+             -> Id+             -> [(CoreRule,      -- Each (non-built-in) rule+                  UsageDetails,  -- Usage details for LHS+                  UsageDetails)] -- Usage details for RHS+occAnalRules env mb_expected_join_arity rec_flag id+  = [ (rule, lhs_uds, rhs_uds) | rule@Rule {} <- idCoreRules id+                               , let (lhs_uds, rhs_uds) = occ_anal_rule rule ]+  where+    occ_anal_rule (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })+      = (lhs_uds, final_rhs_uds)+      where+        lhs_uds = addManyOccsSet emptyDetails $+                    (exprsFreeVars args `delVarSetList` bndrs)+        (rhs_bndrs, rhs_body) = collectBinders rhs+        (rhs_uds, _, _) = occAnalRhs env rec_flag id rhs_bndrs rhs_body+                            -- Note [Rules are extra RHSs]+                            -- Note [Rule dependency info]+        final_rhs_uds = adjust_tail_info args $ markAllMany $+                          (rhs_uds `delDetailsList` bndrs)+    occ_anal_rule _+      = (emptyDetails, emptyDetails)++    adjust_tail_info args uds -- see Note [Rules and join points]+      = case mb_expected_join_arity of+          Just ar | args `lengthIs` ar -> uds+          _                            -> markAllNonTailCalled uds+{-+Note [Cascading inlines]+~~~~~~~~~~~~~~~~~~~~~~~~+By default we use an rhsCtxt for the RHS of a binding.  This tells the+occ anal n that it's looking at an RHS, which has an effect in+occAnalApp.  In particular, for constructor applications, it makes+the arguments appear to have NoOccInfo, so that we don't inline into+them. Thus    x = f y+              k = Just x+we do not want to inline x.++But there's a problem.  Consider+     x1 = a0 : []+     x2 = a1 : x1+     x3 = a2 : x2+     g  = f x3+First time round, it looks as if x1 and x2 occur as an arg of a+let-bound constructor ==> give them a many-occurrence.+But then x3 is inlined (unconditionally as it happens) and+next time round, x2 will be, and the next time round x1 will be+Result: multiple simplifier iterations.  Sigh.++So, when analysing the RHS of x3 we notice that x3 will itself+definitely inline the next time round, and so we analyse x3's rhs in+an ordinary context, not rhsCtxt.  Hence the "certainly_inline" stuff.++Annoyingly, we have to approximate SimplUtils.preInlineUnconditionally.+If we say "yes" when preInlineUnconditionally says "no" the simplifier iterates+indefinitely:+        x = f y+        k = Just x+inline ==>+        k = Just (f y)+float ==>+        x1 = f y+        k = Just x1++This is worse than the slow cascade, so we only want to say "certainly_inline"+if it really is certain.  Look at the note with preInlineUnconditionally+for the various clauses.+++************************************************************************+*                                                                      *+                Expressions+*                                                                      *+************************************************************************+-}++occAnal :: OccEnv+        -> CoreExpr+        -> (UsageDetails,       -- Gives info only about the "interesting" Ids+            CoreExpr)++occAnal _   expr@(Type _) = (emptyDetails,         expr)+occAnal _   expr@(Lit _)  = (emptyDetails,         expr)+occAnal env expr@(Var _)  = occAnalApp env (expr, [], [])+    -- At one stage, I gathered the idRuleVars for the variable here too,+    -- which in a way is the right thing to do.+    -- But that went wrong right after specialisation, when+    -- the *occurrences* of the overloaded function didn't have any+    -- rules in them, so the *specialised* versions looked as if they+    -- weren't used at all.++occAnal _ (Coercion co)+  = (addManyOccsSet emptyDetails (coVarsOfCo co), Coercion co)+        -- See Note [Gather occurrences of coercion variables]++{-+Note [Gather occurrences of coercion variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to gather info about what coercion variables appear, so that+we can sort them into the right place when doing dependency analysis.+-}++occAnal env (Tick tickish body)+  | tickish `tickishScopesLike` SoftScope+  = (markAllNonTailCalled usage, Tick tickish body')++  | Breakpoint _ ids <- tickish+  = (usage_lam +++ foldr addManyOccs emptyDetails ids, Tick tickish body')+    -- never substitute for any of the Ids in a Breakpoint++  | otherwise+  = (usage_lam, Tick tickish body')+  where+    !(usage,body') = occAnal env body+    -- for a non-soft tick scope, we can inline lambdas only+    usage_lam = markAllNonTailCalled (markAllInsideLam usage)+                  -- TODO There may be ways to make ticks and join points play+                  -- nicer together, but right now there are problems:+                  --   let j x = ... in tick<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.++occAnal env (Cast expr co)+  = case occAnal env expr of { (usage, expr') ->+    let usage1 = zapDetailsIf (isRhsEnv env) usage+        usage2 = addManyOccsSet usage1 (coVarsOfCo co)+          -- See Note [Gather occurrences of coercion variables]+    in (markAllNonTailCalled usage2, Cast expr' co)+        -- If we see let x = y `cast` co+        -- then mark y as 'Many' so that we don't+        -- immediately inline y again.+    }++occAnal env app@(App _ _)+  = occAnalApp env (collectArgsTicks tickishFloatable app)++-- Ignore type variables altogether+--   (a) occurrences inside type lambdas only not marked as InsideLam+--   (b) type variables not in environment++occAnal env (Lam x body)+  | isTyVar x+  = case occAnal env body of { (body_usage, body') ->+    (markAllNonTailCalled body_usage, Lam x body')+    }++-- For value lambdas we do a special hack.  Consider+--      (\x. \y. ...x...)+-- If we did nothing, x is used inside the \y, so would be marked+-- as dangerous to dup.  But in the common case where the abstraction+-- is applied to two arguments this is over-pessimistic.+-- So instead, we just mark each binder with its occurrence+-- info in the *body* of the multiple lambda.+-- Then, the simplifier is careful when partially applying lambdas.++occAnal env expr@(Lam _ _)+  = case occAnalLamOrRhs env binders body of { (usage, tagged_binders, body') ->+    let+        expr'       = mkLams tagged_binders body'+        usage1      = markAllNonTailCalled usage+        one_shot_gp = all isOneShotBndr tagged_binders+        final_usage | one_shot_gp = usage1+                    | otherwise   = markAllInsideLam usage1+    in+    (final_usage, expr') }+  where+    (binders, body) = collectBinders expr++occAnal env (Case scrut bndr ty alts)+  = case occ_anal_scrut scrut alts     of { (scrut_usage, scrut') ->+    case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts')   ->+    let+        alts_usage  = foldr combineAltsUsageDetails emptyDetails alts_usage_s+        (alts_usage1, tagged_bndr) = tag_case_bndr alts_usage bndr+        total_usage = markAllNonTailCalled scrut_usage +++ alts_usage1+                        -- Alts can have tail calls, but the scrutinee can't+    in+    total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}+  where+        -- Note [Case binder usage]+        -- ~~~~~~~~~~~~~~~~~~~~~~~~+        -- The case binder gets a usage of either "many" or "dead", never "one".+        -- Reason: we like to inline single occurrences, to eliminate a binding,+        -- but inlining a case binder *doesn't* eliminate a binding.+        -- We *don't* want to transform+        --      case x of w { (p,q) -> f w }+        -- into+        --      case x of w { (p,q) -> f (p,q) }+    tag_case_bndr usage bndr+      = (usage', setIdOccInfo bndr final_occ_info)+      where+        occ_info       = lookupDetails usage bndr+        usage'         = usage `delDetails` bndr+        final_occ_info = case occ_info of IAmDead -> IAmDead+                                          _       -> noOccInfo++    alt_env = mkAltEnv env scrut bndr+    occ_anal_alt = occAnalAlt alt_env++    occ_anal_scrut (Var v) (alt1 : other_alts)+        | not (null other_alts) || not (isDefaultAlt alt1)+        = (mkOneOcc env v True 0, Var v)+            -- The 'True' says that the variable occurs in an interesting+            -- context; the case has at least one non-default alternative+    occ_anal_scrut (Tick t e) alts+        | t `tickishScopesLike` SoftScope+          -- No reason to not look through all ticks here, but only+          -- for soft-scoped ticks we can do so without having to+          -- update returned occurance info (see occAnal)+        = second (Tick t) $ occ_anal_scrut e alts++    occ_anal_scrut scrut _alts+        = occAnal (vanillaCtxt env) scrut    -- No need for rhsCtxt++occAnal env (Let bind body)+  = case occAnal env body                of { (body_usage, body') ->+    case occAnalBind env NotTopLevel+                     noImpRuleEdges bind+                     body_usage          of { (final_usage, new_binds) ->+       (final_usage, mkLets new_binds body') }}++occAnalArgs :: OccEnv -> [CoreExpr] -> [OneShots] -> (UsageDetails, [CoreExpr])+occAnalArgs _ [] _+  = (emptyDetails, [])++occAnalArgs env (arg:args) one_shots+  | isTypeArg arg+  = case occAnalArgs env args one_shots of { (uds, args') ->+    (uds, arg:args') }++  | otherwise+  = case argCtxt env one_shots           of { (arg_env, one_shots') ->+    case occAnal arg_env arg             of { (uds1, arg') ->+    case occAnalArgs env args one_shots' of { (uds2, args') ->+    (uds1 +++ uds2, arg':args') }}}++{-+Applications are dealt with specially because we want+the "build hack" to work.++Note [Arguments of let-bound constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    f x = let y = expensive x in+          let z = (True,y) in+          (case z of {(p,q)->q}, case z of {(p,q)->q})+We feel free to duplicate the WHNF (True,y), but that means+that y may be duplicated thereby.++If we aren't careful we duplicate the (expensive x) call!+Constructors are rather like lambdas in this way.+-}++occAnalApp :: OccEnv+           -> (Expr CoreBndr, [Arg CoreBndr], [Tickish Id])+           -> (UsageDetails, Expr CoreBndr)+occAnalApp env (Var fun, args, ticks)+  | null ticks = (uds, mkApps (Var fun) args')+  | otherwise  = (uds, mkTicks ticks $ mkApps (Var fun) args')+  where+    uds = fun_uds +++ final_args_uds++    !(args_uds, args') = occAnalArgs env args one_shots+    !final_args_uds+       | isRhsEnv env && is_exp = markAllNonTailCalled $+                                  markAllInsideLam args_uds+       | otherwise              = markAllNonTailCalled args_uds+       -- We mark the free vars of the argument of a constructor or PAP+       -- as "inside-lambda", if it is the RHS of a let(rec).+       -- This means that nothing gets inlined into a constructor or PAP+       -- argument position, which is what we want.  Typically those+       -- constructor arguments are just variables, or trivial expressions.+       -- We use inside-lam because it's like eta-expanding the PAP.+       --+       -- This is the *whole point* of the isRhsEnv predicate+       -- See Note [Arguments of let-bound constructors]++    n_val_args = valArgCount args+    n_args     = length args+    fun_uds    = mkOneOcc env fun (n_val_args > 0) n_args+    is_exp     = isExpandableApp fun n_val_args+        -- See Note [CONLIKE pragma] in BasicTypes+        -- The definition of is_exp should match that in Simplify.prepareRhs++    one_shots  = argsOneShots (idStrictness fun) guaranteed_val_args+    guaranteed_val_args = n_val_args + length (takeWhile isOneShotInfo+                                                         (occ_one_shots env))+        -- See Note [Sources of one-shot information], bullet point A']++occAnalApp env (fun, args, ticks)+  = (markAllNonTailCalled (fun_uds +++ args_uds),+     mkTicks ticks $ mkApps fun' args')+  where+    !(fun_uds, fun') = occAnal (addAppCtxt env args) fun+        -- The addAppCtxt is a bit cunning.  One iteration of the simplifier+        -- often leaves behind beta redexs like+        --      (\x y -> e) a1 a2+        -- Here we would like to mark x,y as one-shot, and treat the whole+        -- thing much like a let.  We do this by pushing some True items+        -- onto the context stack.+    !(args_uds, args') = occAnalArgs env args []++zapDetailsIf :: Bool              -- If this is true+             -> UsageDetails      -- Then do zapDetails on this+             -> UsageDetails+zapDetailsIf True  uds = zapDetails uds+zapDetailsIf False uds = uds++{-+Note [Sources of one-shot information]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The occurrence analyser obtains one-shot-lambda information from two sources:++A:  Saturated applications:  eg   f e1 .. en++    In general, given a call (f e1 .. en) we can propagate one-shot info from+    f's strictness signature into e1 .. en, but /only/ if n is enough to+    saturate the strictness signature. A strictness signature like++          f :: C1(C1(L))LS++    means that *if f is applied to three arguments* then it will guarantee to+    call its first argument at most once, and to call the result of that at+    most once. But if f has fewer than three arguments, all bets are off; e.g.++          map (f (\x y. expensive) e2) xs++    Here the \x y abstraction may be called many times (once for each element of+    xs) so we should not mark x and y as one-shot. But if it was++          map (f (\x y. expensive) 3 2) xs++    then the first argument of f will be called at most once.++    The one-shot info, derived from f's strictness signature, is+    computed by 'argsOneShots', called in occAnalApp.++A': Non-obviously saturated applications: eg    build (f (\x y -> expensive))+    where f is as above.++    In this case, f is only manifestly applied to one argument, so it does not+    look saturated. So by the previous point, we should not use its strictness+    signature to learn about the one-shotness of \x y. But in this case we can:+    build is fully applied, so we may use its strictness signature; and from+    that we learn that build calls its argument with two arguments *at most once*.++    So there is really only one call to f, and it will have three arguments. In+    that sense, f is saturated, and we may proceed as described above.++    Hence the computation of 'guaranteed_val_args' in occAnalApp, using+    '(occ_one_shots env)'.  See also Trac #13227, comment:9++B:  Let-bindings:  eg   let f = \c. let ... in \n -> blah+                        in (build f, build f)++    Propagate one-shot info from the demanand-info on 'f' to the+    lambdas in its RHS (which may not be syntactically at the top)++    This information must have come from a previous run of the demanand+    analyser.++Previously, the demand analyser would *also* set the one-shot information, but+that code was buggy (see #11770), so doing it only in on place, namely here, is+saner.++Note [OneShots]+~~~~~~~~~~~~~~~+When analysing an expression, the occ_one_shots argument contains information+about how the function is being used. The length of the list indicates+how many arguments will eventually be passed to the analysed expression,+and the OneShotInfo indicates whether this application is once or multiple times.++Example:++ Context of f                occ_one_shots when analysing f++ f 1 2                       [OneShot, OneShot]+ map (f 1)                   [OneShot, NoOneShotInfo]+ build f                     [OneShot, OneShot]+ f 1 2 `seq` f 2 1           [NoOneShotInfo, OneShot]++Note [Binders in case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    case x of y { (a,b) -> f y }+We treat 'a', 'b' as dead, because they don't physically occur in the+case alternative.  (Indeed, a variable is dead iff it doesn't occur in+its scope in the output of OccAnal.)  It really helps to know when+binders are unused.  See esp the call to isDeadBinder in+Simplify.mkDupableAlt++In this example, though, the Simplifier will bring 'a' and 'b' back to+life, beause it binds 'y' to (a,b) (imagine got inlined and+scrutinised y).+-}++occAnalLamOrRhs :: OccEnv -> [CoreBndr] -> CoreExpr+                -> (UsageDetails, [CoreBndr], CoreExpr)+occAnalLamOrRhs env [] body+  = case occAnal env body of (body_usage, body') -> (body_usage, [], body')+      -- RHS of thunk or nullary join point+occAnalLamOrRhs env (bndr:bndrs) body+  | isTyVar bndr+  = -- Important: Keep the environment so that we don't inline into an RHS like+    --   \(@ x) -> C @x (f @x)+    -- (see the beginning of Note [Cascading inlines]).+    case occAnalLamOrRhs env bndrs body of+      (body_usage, bndrs', body') -> (body_usage, bndr:bndrs', body')+occAnalLamOrRhs env binders body+  = case occAnal env_body body of { (body_usage, body') ->+    let+        (final_usage, tagged_binders) = tagLamBinders body_usage binders'+                      -- Use binders' to put one-shot info on the lambdas+    in+    (final_usage, tagged_binders, body') }+  where+    (env_body, binders') = oneShotGroup env binders++occAnalAlt :: (OccEnv, Maybe (Id, CoreExpr))+           -> CoreAlt+           -> (UsageDetails, Alt IdWithOccInfo)+occAnalAlt (env, scrut_bind) (con, bndrs, rhs)+  = case occAnal env rhs of { (rhs_usage1, rhs1) ->+    let+        (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs+                                  -- See Note [Binders in case alternatives]+        (alt_usg', rhs2) =+          wrapAltRHS env scrut_bind alt_usg tagged_bndrs rhs1+    in+    (alt_usg', (con, tagged_bndrs, rhs2)) }++wrapAltRHS :: OccEnv+           -> Maybe (Id, CoreExpr)      -- proxy mapping generated by mkAltEnv+           -> UsageDetails              -- usage for entire alt (p -> rhs)+           -> [Var]                     -- alt binders+           -> CoreExpr                  -- alt RHS+           -> (UsageDetails, CoreExpr)+wrapAltRHS env (Just (scrut_var, let_rhs)) alt_usg bndrs alt_rhs+  | occ_binder_swap env+  , scrut_var `usedIn` alt_usg -- bndrs are not be present in alt_usg so this+                               -- handles condition (a) in Note [Binder swap]+  , not captured               -- See condition (b) in Note [Binder swap]+  = ( alt_usg' +++ let_rhs_usg+    , Let (NonRec tagged_scrut_var let_rhs') alt_rhs )+  where+    captured = any (`usedIn` let_rhs_usg) bndrs+    -- The rhs of the let may include coercion variables+    -- if the scrutinee was a cast, so we must gather their+    -- usage. See Note [Gather occurrences of coercion variables]+    (let_rhs_usg, let_rhs') = occAnal env let_rhs+    (alt_usg', [tagged_scrut_var]) = tagLamBinders alt_usg [scrut_var]++wrapAltRHS _ _ alt_usg _ alt_rhs+  = (alt_usg, alt_rhs)++{-+************************************************************************+*                                                                      *+                    OccEnv+*                                                                      *+************************************************************************+-}++data OccEnv+  = OccEnv { occ_encl       :: !OccEncl      -- Enclosing context information+           , occ_one_shots  :: !OneShots     -- See Note [OneShots]+           , occ_gbl_scrut  :: GlobalScruts+           , occ_rule_act   :: Activation -> Bool   -- Which rules are active+             -- See Note [Finding rule RHS free vars]+           , occ_binder_swap :: !Bool -- enable the binder_swap+             -- See CorePrep Note [Dead code in CorePrep]+    }++type GlobalScruts = IdSet   -- See Note [Binder swap on GlobalId scrutinees]++-----------------------------+-- OccEncl is used to control whether to inline into constructor arguments+-- For example:+--      x = (p,q)               -- Don't inline p or q+--      y = /\a -> (p a, q a)   -- Still don't inline p or q+--      z = f (p,q)             -- Do inline p,q; it may make a rule fire+-- So OccEncl tells enought about the context to know what to do when+-- we encounter a constructor application or PAP.++data OccEncl+  = OccRhs              -- RHS of let(rec), albeit perhaps inside a type lambda+                        -- Don't inline into constructor args here+  | OccVanilla          -- Argument of function, body of lambda, scruintee of case etc.+                        -- Do inline into constructor args here++instance Outputable OccEncl where+  ppr OccRhs     = text "occRhs"+  ppr OccVanilla = text "occVanilla"++-- See note [OneShots]+type OneShots = [OneShotInfo]++initOccEnv :: (Activation -> Bool) -> OccEnv+initOccEnv active_rule+  = OccEnv { occ_encl      = OccVanilla+           , occ_one_shots = []+           , occ_gbl_scrut = emptyVarSet+           , occ_rule_act  = active_rule+           , occ_binder_swap = True }++vanillaCtxt :: OccEnv -> OccEnv+vanillaCtxt env = env { occ_encl = OccVanilla, occ_one_shots = [] }++rhsCtxt :: OccEnv -> OccEnv+rhsCtxt env = env { occ_encl = OccRhs, occ_one_shots = [] }++argCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots])+argCtxt env []+  = (env { occ_encl = OccVanilla, occ_one_shots = [] }, [])+argCtxt env (one_shots:one_shots_s)+  = (env { occ_encl = OccVanilla, occ_one_shots = one_shots }, one_shots_s)++isRhsEnv :: OccEnv -> Bool+isRhsEnv (OccEnv { occ_encl = OccRhs })     = True+isRhsEnv (OccEnv { occ_encl = OccVanilla }) = False++oneShotGroup :: OccEnv -> [CoreBndr]+             -> ( OccEnv+                , [CoreBndr] )+        -- The result binders have one-shot-ness set that they might not have had originally.+        -- This happens in (build (\c n -> e)).  Here the occurrence analyser+        -- linearity context knows that c,n are one-shot, and it records that fact in+        -- the binder. This is useful to guide subsequent float-in/float-out tranformations++oneShotGroup env@(OccEnv { occ_one_shots = ctxt }) bndrs+  = go ctxt bndrs []+  where+    go ctxt [] rev_bndrs+      = ( env { occ_one_shots = ctxt, occ_encl = OccVanilla }+        , reverse rev_bndrs )++    go [] bndrs rev_bndrs+      = ( env { occ_one_shots = [], occ_encl = OccVanilla }+        , reverse rev_bndrs ++ bndrs )++    go ctxt@(one_shot : ctxt') (bndr : bndrs) rev_bndrs+      | isId bndr = go ctxt' bndrs (bndr': rev_bndrs)+      | otherwise = go ctxt  bndrs (bndr : rev_bndrs)+      where+        bndr' = updOneShotInfo bndr one_shot+               -- Use updOneShotInfo, not setOneShotInfo, as pre-existing+               -- one-shot info might be better than what we can infer, e.g.+               -- due to explicit use of the magic 'oneShot' function.+               -- See Note [The oneShot function]+++markJoinOneShots :: Maybe JoinArity -> [Var] -> [Var]+-- Mark the lambdas of a non-recursive join point as one-shot.+-- This is good to prevent gratuitous float-out etc+markJoinOneShots mb_join_arity bndrs+  = case mb_join_arity of+      Nothing -> bndrs+      Just n  -> go n bndrs+ where+   go 0 bndrs  = bndrs+   go _ []     = WARN( True, ppr mb_join_arity <+> ppr bndrs ) []+   go n (b:bs) = b' : go (n-1) bs+     where+       b' | isId b    = setOneShotLambda b+          | otherwise = b++addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv+addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args+  = env { occ_one_shots = replicate (valArgCount args) OneShotLam ++ ctxt }++transClosureFV :: UniqFM VarSet -> UniqFM VarSet+-- If (f,g), (g,h) are in the input, then (f,h) is in the output+--                                   as well as (f,g), (g,h)+transClosureFV env+  | no_change = env+  | otherwise = transClosureFV (listToUFM new_fv_list)+  where+    (no_change, new_fv_list) = mapAccumL bump True (nonDetUFMToList env)+      -- It's OK to use nonDetUFMToList here because we'll forget the+      -- ordering by creating a new set with listToUFM+    bump no_change (b,fvs)+      | no_change_here = (no_change, (b,fvs))+      | otherwise      = (False,     (b,new_fvs))+      where+        (new_fvs, no_change_here) = extendFvs env fvs++-------------+extendFvs_ :: UniqFM VarSet -> VarSet -> VarSet+extendFvs_ env s = fst (extendFvs env s)   -- Discard the Bool flag++extendFvs :: UniqFM VarSet -> VarSet -> (VarSet, Bool)+-- (extendFVs env s) returns+--     (s `union` env(s), env(s) `subset` s)+extendFvs env s+  | isNullUFM env+  = (s, True)+  | otherwise+  = (s `unionVarSet` extras, extras `subVarSet` s)+  where+    extras :: VarSet    -- env(s)+    extras = nonDetFoldUFM unionVarSet emptyVarSet $+      -- It's OK to use nonDetFoldUFM here because unionVarSet commutes+             intersectUFM_C (\x _ -> x) env (getUniqSet s)++{-+************************************************************************+*                                                                      *+                    Binder swap+*                                                                      *+************************************************************************++Note [Binder swap]+~~~~~~~~~~~~~~~~~~+We do these two transformations right here:++ (1)   case x of b { pi -> ri }+    ==>+      case x of b { pi -> let x=b in ri }++ (2)  case (x |> co) of b { pi -> ri }+    ==>+      case (x |> co) of b { pi -> let x = b |> sym co in ri }++    Why (2)?  See Note [Case of cast]++In both cases, in a particular alternative (pi -> ri), we only+add the binding if+  (a) x occurs free in (pi -> ri)+        (ie it occurs in ri, but is not bound in pi)+  (b) the pi does not bind b (or the free vars of co)+We need (a) and (b) for the inserted binding to be correct.++For the alternatives where we inject the binding, we can transfer+all x's OccInfo to b.  And that is the point.++Notice that+  * The deliberate shadowing of 'x'.+  * That (a) rapidly becomes false, so no bindings are injected.++The reason for doing these transformations here is because it allows+us to adjust the OccInfo for 'x' and 'b' as we go.++  * Suppose the only occurrences of 'x' are the scrutinee and in the+    ri; then this transformation makes it occur just once, and hence+    get inlined right away.++  * If we do this in the Simplifier, we don't know whether 'x' is used+    in ri, so we are forced to pessimistically zap b's OccInfo even+    though it is typically dead (ie neither it nor x appear in the+    ri).  There's nothing actually wrong with zapping it, except that+    it's kind of nice to know which variables are dead.  My nose+    tells me to keep this information as robustly as possible.++The Maybe (Id,CoreExpr) passed to occAnalAlt is the extra let-binding+{x=b}; it's Nothing if the binder-swap doesn't happen.++There is a danger though.  Consider+      let v = x +# y+      in case (f v) of w -> ...v...v...+And suppose that (f v) expands to just v.  Then we'd like to+use 'w' instead of 'v' in the alternative.  But it may be too+late; we may have substituted the (cheap) x+#y for v in the+same simplifier pass that reduced (f v) to v.++I think this is just too bad.  CSE will recover some of it.++Note [Case of cast]+~~~~~~~~~~~~~~~~~~~+Consider        case (x `cast` co) of b { I# ->+                ... (case (x `cast` co) of {...}) ...+We'd like to eliminate the inner case.  That is the motivation for+equation (2) in Note [Binder swap].  When we get to the inner case, we+inline x, cancel the casts, and away we go.++Note [Binder swap on GlobalId scrutinees]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When the scrutinee is a GlobalId we must take care in two ways++ i) In order to *know* whether 'x' occurs free in the RHS, we need its+    occurrence info. BUT, we don't gather occurrence info for+    GlobalIds.  That's the reason for the (small) occ_gbl_scrut env in+    OccEnv is for: it says "gather occurrence info for these".++ ii) We must call localiseId on 'x' first, in case it's a GlobalId, or+     has an External Name. See, for example, SimplEnv Note [Global Ids in+     the substitution].++Note [Zap case binders in proxy bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+From the original+     case x of cb(dead) { p -> ...x... }+we will get+     case x of cb(live) { p -> let x = cb in ...x... }++Core Lint never expects to find an *occurrence* of an Id marked+as Dead, so we must zap the OccInfo on cb before making the+binding x = cb.  See Trac #5028.++Historical note [no-case-of-case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We *used* to suppress the binder-swap in case expressions when+-fno-case-of-case is on.  Old remarks:+    "This happens in the first simplifier pass,+    and enhances full laziness.  Here's the bad case:+            f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )+    If we eliminate the inner case, we trap it inside the I# v -> arm,+    which might prevent some full laziness happening.  I've seen this+    in action in spectral/cichelli/Prog.hs:+             [(m,n) | m <- [1..max], n <- [1..max]]+    Hence the check for NoCaseOfCase."+However, now the full-laziness pass itself reverses the binder-swap, so this+check is no longer necessary.++Historical note [Suppressing the case binder-swap]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This old note describes a problem that is also fixed by doing the+binder-swap in OccAnal:++    There is another situation when it might make sense to suppress the+    case-expression binde-swap. If we have++        case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }+                       ...other cases .... }++    We'll perform the binder-swap for the outer case, giving++        case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }+                       ...other cases .... }++    But there is no point in doing it for the inner case, because w1 can't+    be inlined anyway.  Furthermore, doing the case-swapping involves+    zapping w2's occurrence info (see paragraphs that follow), and that+    forces us to bind w2 when doing case merging.  So we get++        case x of w1 { A -> let w2 = w1 in e1+                       B -> let w2 = w1 in e2+                       ...other cases .... }++    This is plain silly in the common case where w2 is dead.++    Even so, I can't see a good way to implement this idea.  I tried+    not doing the binder-swap if the scrutinee was already evaluated+    but that failed big-time:++            data T = MkT !Int++            case v of w  { MkT x ->+            case x of x1 { I# y1 ->+            case x of x2 { I# y2 -> ...++    Notice that because MkT is strict, x is marked "evaluated".  But to+    eliminate the last case, we must either make sure that x (as well as+    x1) has unfolding MkT y1.  The straightforward thing to do is to do+    the binder-swap.  So this whole note is a no-op.++It's fixed by doing the binder-swap in OccAnal because we can do the+binder-swap unconditionally and still get occurrence analysis+information right.+-}++mkAltEnv :: OccEnv -> CoreExpr -> Id -> (OccEnv, Maybe (Id, CoreExpr))+-- Does two things: a) makes the occ_one_shots = OccVanilla+--                  b) extends the GlobalScruts if possible+--                  c) returns a proxy mapping, binding the scrutinee+--                     to the case binder, if possible+mkAltEnv env@(OccEnv { occ_gbl_scrut = pe }) scrut case_bndr+  = case stripTicksTopE (const True) scrut of+      Var v           -> add_scrut v case_bndr'+      Cast (Var v) co -> add_scrut v (Cast case_bndr' (mkSymCo co))+                          -- See Note [Case of cast]+      _               -> (env { occ_encl = OccVanilla }, Nothing)++  where+    add_scrut v rhs = ( env { occ_encl = OccVanilla, occ_gbl_scrut = pe `extendVarSet` v }+                      , Just (localise v, rhs) )++    case_bndr' = Var (zapIdOccInfo case_bndr) -- See Note [Zap case binders in proxy bindings]+    localise scrut_var = mkLocalIdOrCoVar (localiseName (idName scrut_var)) (idType scrut_var)+        -- Localise the scrut_var before shadowing it; we're making a+        -- new binding for it, and it might have an External Name, or+        -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees]+        -- Also we don't want any INLINE or NOINLINE pragmas!++{-+************************************************************************+*                                                                      *+\subsection[OccurAnal-types]{OccEnv}+*                                                                      *+************************************************************************++Note [UsageDetails and zapping]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++On many occasions, we must modify all gathered occurrence data at once. For+instance, all occurrences underneath a (non-one-shot) lambda set the+'occ_in_lam' flag to become 'True'. We could use 'mapVarEnv' to do this, but+that takes O(n) time and we will do this often---in particular, there are many+places where tail calls are not allowed, and each of these causes all variables+to get marked with 'NoTailCallInfo'.++Instead of relying on `mapVarEnv`, then, we carry three 'IdEnv's around along+with the 'OccInfoEnv'. Each of these extra environments is a "zapped set"+recording which variables have been zapped in some way. Zapping all occurrence+info then simply means setting the corresponding zapped set to the whole+'OccInfoEnv', a fast O(1) operation.+-}++type OccInfoEnv = IdEnv OccInfo -- A finite map from ids to their usage+                -- INVARIANT: never IAmDead+                -- (Deadness is signalled by not being in the map at all)++type ZappedSet = OccInfoEnv -- Values are ignored++data UsageDetails+  = UD { ud_env       :: !OccInfoEnv+       , ud_z_many    :: ZappedSet   -- apply 'markMany' to these+       , ud_z_in_lam  :: ZappedSet   -- apply 'markInsideLam' to these+       , ud_z_no_tail :: ZappedSet } -- apply 'markNonTailCalled' to these+  -- INVARIANT: All three zapped sets are subsets of the OccInfoEnv++instance Outputable UsageDetails where+  ppr ud = ppr (ud_env (flattenUsageDetails ud))++-------------------+-- UsageDetails API++(+++), combineAltsUsageDetails+        :: UsageDetails -> UsageDetails -> UsageDetails+(+++) = combineUsageDetailsWith addOccInfo+combineAltsUsageDetails = combineUsageDetailsWith orOccInfo++combineUsageDetailsList :: [UsageDetails] -> UsageDetails+combineUsageDetailsList = foldl (+++) emptyDetails++mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails+mkOneOcc env id int_cxt arity+  | isLocalId id+  = singleton $ OneOcc { occ_in_lam  = False+                       , occ_one_br  = True+                       , occ_int_cxt = int_cxt+                       , occ_tail    = AlwaysTailCalled arity }+  | id `elemVarSet` occ_gbl_scrut env+  = singleton noOccInfo++  | otherwise+  = emptyDetails+  where+    singleton info = emptyDetails { ud_env = unitVarEnv id info }++addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails+addOneOcc ud id info+  = ud { ud_env = extendVarEnv_C plus_zapped (ud_env ud) id info }+      `alterZappedSets` (`delVarEnv` id)+  where+    plus_zapped old new = doZapping ud id old `addOccInfo` new++addManyOccsSet :: UsageDetails -> VarSet -> UsageDetails+addManyOccsSet usage id_set = nonDetFoldUniqSet addManyOccs usage id_set+  -- It's OK to use nonDetFoldUFM here because addManyOccs commutes++-- Add several occurrences, assumed not to be tail calls+addManyOccs :: Var -> UsageDetails -> UsageDetails+addManyOccs v u | isId v    = addOneOcc u v noOccInfo+                | otherwise = u+        -- Give a non-committal binder info (i.e noOccInfo) because+        --   a) Many copies of the specialised thing can appear+        --   b) We don't want to substitute a BIG expression inside a RULE+        --      even if that's the only occurrence of the thing+        --      (Same goes for INLINE.)++delDetails :: UsageDetails -> Id -> UsageDetails+delDetails ud bndr+  = ud `alterUsageDetails` (`delVarEnv` bndr)++delDetailsList :: UsageDetails -> [Id] -> UsageDetails+delDetailsList ud bndrs+  = ud `alterUsageDetails` (`delVarEnvList` bndrs)++emptyDetails :: UsageDetails+emptyDetails = UD { ud_env       = emptyVarEnv+                  , ud_z_many    = emptyVarEnv+                  , ud_z_in_lam  = emptyVarEnv+                  , ud_z_no_tail = emptyVarEnv }++isEmptyDetails :: UsageDetails -> Bool+isEmptyDetails = isEmptyVarEnv . ud_env++markAllMany, markAllInsideLam, markAllNonTailCalled, zapDetails+  :: UsageDetails -> UsageDetails+markAllMany          ud = ud { ud_z_many    = ud_env ud }+markAllInsideLam     ud = ud { ud_z_in_lam  = ud_env ud }+markAllNonTailCalled ud = ud { ud_z_no_tail = ud_env ud }++zapDetails = markAllMany . markAllNonTailCalled -- effectively sets to noOccInfo++lookupDetails :: UsageDetails -> Id -> OccInfo+lookupDetails ud id+  = case lookupVarEnv (ud_env ud) id of+      Just occ -> doZapping ud id occ+      Nothing  -> IAmDead++usedIn :: Id -> UsageDetails -> Bool+v `usedIn` ud = isExportedId v || v `elemVarEnv` ud_env ud++udFreeVars :: VarSet -> UsageDetails -> VarSet+-- Find the subset of bndrs that are mentioned in uds+udFreeVars bndrs ud = restrictUniqSetToUFM bndrs (ud_env ud)++-------------------+-- Auxiliary functions for UsageDetails implementation++combineUsageDetailsWith :: (OccInfo -> OccInfo -> OccInfo)+                        -> UsageDetails -> UsageDetails -> UsageDetails+combineUsageDetailsWith plus_occ_info ud1 ud2+  | isEmptyDetails ud1 = ud2+  | isEmptyDetails ud2 = ud1+  | otherwise+  = UD { ud_env       = plusVarEnv_C plus_occ_info (ud_env ud1) (ud_env ud2)+       , ud_z_many    = plusVarEnv (ud_z_many    ud1) (ud_z_many    ud2)+       , ud_z_in_lam  = plusVarEnv (ud_z_in_lam  ud1) (ud_z_in_lam  ud2)+       , ud_z_no_tail = plusVarEnv (ud_z_no_tail ud1) (ud_z_no_tail ud2) }++doZapping :: UsageDetails -> Var -> OccInfo -> OccInfo+doZapping ud var occ+  = doZappingByUnique ud (varUnique var) occ++doZappingByUnique :: UsageDetails -> Unique -> OccInfo -> OccInfo+doZappingByUnique ud uniq+  = (if | in_subset ud_z_many    -> markMany+        | in_subset ud_z_in_lam  -> markInsideLam+        | otherwise              -> id) .+    (if | in_subset ud_z_no_tail -> markNonTailCalled+        | otherwise              -> id)+  where+    in_subset field = uniq `elemVarEnvByKey` field ud++alterZappedSets :: UsageDetails -> (ZappedSet -> ZappedSet) -> UsageDetails+alterZappedSets ud f+  = ud { ud_z_many    = f (ud_z_many    ud)+       , ud_z_in_lam  = f (ud_z_in_lam  ud)+       , ud_z_no_tail = f (ud_z_no_tail ud) }++alterUsageDetails :: UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails+alterUsageDetails ud f+  = ud { ud_env = f (ud_env ud) }+      `alterZappedSets` f++flattenUsageDetails :: UsageDetails -> UsageDetails+flattenUsageDetails ud+  = ud { ud_env = mapUFM_Directly (doZappingByUnique ud) (ud_env ud) }+      `alterZappedSets` const emptyVarEnv++-------------------+-- See Note [Adjusting right-hand sides]+adjustRhsUsage :: Maybe JoinArity -> RecFlag+               -> [CoreBndr] -- Outer lambdas, AFTER occ anal+               -> UsageDetails -> UsageDetails+adjustRhsUsage mb_join_arity rec_flag bndrs usage+  = maybe_mark_lam (maybe_drop_tails usage)+  where+    maybe_mark_lam ud   | one_shot   = ud+                        | otherwise  = markAllInsideLam ud+    maybe_drop_tails ud | exact_join = ud+                        | otherwise  = markAllNonTailCalled ud++    one_shot = case mb_join_arity of+                 Just join_arity+                   | isRec rec_flag -> False+                   | otherwise      -> all isOneShotBndr (drop join_arity bndrs)+                 Nothing            -> all isOneShotBndr bndrs++    exact_join = case mb_join_arity of+                   Just join_arity -> join_arity == length bndrs+                   _               -> False++type IdWithOccInfo = Id++tagLamBinders :: UsageDetails          -- Of scope+              -> [Id]                  -- Binders+              -> (UsageDetails,        -- Details with binders removed+                 [IdWithOccInfo])    -- Tagged binders+-- Used for lambda and case binders+-- It copes with the fact that lambda bindings can have a+-- stable unfolding, used for join points+tagLamBinders usage binders = usage' `seq` (usage', bndrs')+  where+    (usage', bndrs') = mapAccumR tag_lam usage binders+    tag_lam usage bndr = (usage2, bndr')+      where+        occ    = lookupDetails usage bndr+        bndr'  = setBinderOcc (markNonTailCalled occ) bndr+                   -- Don't try to make an argument into a join point+        usage1 = usage `delDetails` bndr+        usage2 | isId bndr = addManyOccsSet usage1 (idUnfoldingVars bndr)+                               -- This is effectively the RHS of a+                               -- non-join-point binding, so it's okay to use+                               -- addManyOccsSet, which assumes no tail calls+               | otherwise = usage1++tagNonRecBinder :: TopLevelFlag           -- At top level?+                -> UsageDetails           -- Of scope+                -> CoreBndr               -- Binder+                -> (UsageDetails,         -- Details with binder removed+                    IdWithOccInfo)        -- Tagged binder++tagNonRecBinder lvl usage binder+ = let+     occ     = lookupDetails usage binder+     will_be_join = decideJoinPointHood lvl usage [binder]+     occ'    | will_be_join = occ -- must already be marked AlwaysTailCalled+             | otherwise    = markNonTailCalled occ+     binder' = setBinderOcc occ' binder+     usage'  = usage `delDetails` binder+   in+   usage' `seq` (usage', binder')++tagRecBinders :: TopLevelFlag           -- At top level?+              -> UsageDetails           -- Of body of let ONLY+              -> [(CoreBndr,            -- Binder+                   UsageDetails,        -- RHS usage details+                   [CoreBndr])]         -- Lambdas in new RHS+              -> (UsageDetails,         -- Adjusted details for whole scope,+                                        -- with binders removed+                  [IdWithOccInfo])      -- Tagged binders+-- Substantially more complicated than non-recursive case. Need to adjust RHS+-- details *before* tagging binders (because the tags depend on the RHSes).+tagRecBinders lvl body_uds triples+ = let+     (bndrs, rhs_udss, _) = unzip3 triples++     -- 1. Determine join-point-hood of whole group, as determined by+     --    the *unadjusted* usage details+     unadj_uds     = body_uds +++ combineUsageDetailsList rhs_udss+     will_be_joins = decideJoinPointHood lvl unadj_uds bndrs++     -- 2. Adjust usage details of each RHS, taking into account the+     --    join-point-hood decision+     rhs_udss' = map adjust triples+     adjust (bndr, rhs_uds, rhs_bndrs)+       = adjustRhsUsage mb_join_arity Recursive rhs_bndrs rhs_uds+       where+         -- Can't use willBeJoinId_maybe here because we haven't tagged the+         -- binder yet (the tag depends on these adjustments!)+         mb_join_arity+           | will_be_joins+           , let occ = lookupDetails unadj_uds bndr+           , AlwaysTailCalled arity <- tailCallInfo occ+           = Just arity+           | otherwise+           = ASSERT(not will_be_joins) -- Should be AlwaysTailCalled if we're+                                       -- making join points!+             Nothing++     -- 3. Compute final usage details from adjusted RHS details+     adj_uds   = body_uds +++ combineUsageDetailsList rhs_udss'++     -- 4. Tag each binder with its adjusted details modulo the+     --    join-point-hood decision+     occs      = map (lookupDetails adj_uds) bndrs+     occs'     | will_be_joins = occs+               | otherwise     = map markNonTailCalled occs+     bndrs'    = zipWith setBinderOcc occs' bndrs++     -- 5. Drop the binders from the adjusted details and return+     usage'    = adj_uds `delDetailsList` bndrs+   in+   (usage', bndrs')++setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr+setBinderOcc occ_info bndr+  | isTyVar bndr      = bndr+  | isExportedId bndr = if isManyOccs (idOccInfo bndr)+                          then bndr+                          else setIdOccInfo bndr noOccInfo+            -- Don't use local usage info for visible-elsewhere things+            -- BUT *do* erase any IAmALoopBreaker annotation, because we're+            -- about to re-generate it and it shouldn't be "sticky"++  | otherwise = setIdOccInfo bndr occ_info++-- | Decide whether some bindings should be made into join points or not.+-- Returns `False` if they can't be join points. Note that it's an+-- all-or-nothing decision, as if multiple binders are given, they're assumed to+-- be mutually recursive.+--+-- See Note [Invariants for join points] in CoreSyn.+decideJoinPointHood :: TopLevelFlag -> UsageDetails+                    -> [CoreBndr]+                    -> Bool+decideJoinPointHood TopLevel _ _+  = False+decideJoinPointHood NotTopLevel usage bndrs+  | isJoinId (head bndrs)+  = WARN(not all_ok, text "OccurAnal failed to rediscover join point(s):" <+>+                       ppr bndrs)+    all_ok+  | otherwise+  = all_ok+  where+    -- See Note [Invariants on join points]; invariants cited by number below.+    -- Invariant 2 is always satisfiable by the simplifier by eta expansion.+    all_ok = -- Invariant 3: Either all are join points or none are+             all ok bndrs++    ok bndr+      | -- Invariant 1: Only tail calls, all same join arity+        AlwaysTailCalled arity <- tailCallInfo (lookupDetails usage bndr)+      , -- Invariant 1 as applied to LHSes of rules+        all (ok_rule arity) (idCoreRules bndr)+        -- Invariant 4: Satisfies polymorphism rule+      , isValidJoinPointType arity (idType bndr)+      = True+      | otherwise+      = False++    ok_rule _ BuiltinRule{} = False -- only possible with plugin shenanigans+    ok_rule join_arity (Rule { ru_args = args })+      = length args == join_arity+        -- Invariant 1 as applied to LHSes of rules++willBeJoinId_maybe :: CoreBndr -> Maybe JoinArity+willBeJoinId_maybe bndr+  | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr)+  = Just arity+  | otherwise+  = isJoinId_maybe bndr++{-+************************************************************************+*                                                                      *+\subsection{Operations over OccInfo}+*                                                                      *+************************************************************************+-}++markMany, markInsideLam, markNonTailCalled :: OccInfo -> OccInfo++markMany IAmDead = IAmDead+markMany occ     = ManyOccs { occ_tail = occ_tail occ }++markInsideLam occ@(OneOcc {}) = occ { occ_in_lam = True }+markInsideLam occ             = occ++markNonTailCalled IAmDead = IAmDead+markNonTailCalled occ     = occ { occ_tail = NoTailCallInfo }++addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo++addOccInfo a1 a2  = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )+                    ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo`+                                          tailCallInfo a2 }+                                -- Both branches are at least One+                                -- (Argument is never IAmDead)++-- (orOccInfo orig new) is used+-- when combining occurrence info from branches of a case++orOccInfo (OneOcc { occ_in_lam = in_lam1, occ_int_cxt = int_cxt1+                  , occ_tail   = tail1 })+          (OneOcc { occ_in_lam = in_lam2, occ_int_cxt = int_cxt2+                  , occ_tail   = tail2 })+  = OneOcc { occ_in_lam  = in_lam1 || in_lam2+           , occ_one_br  = False -- False, because it occurs in both branches+           , occ_int_cxt = int_cxt1 && int_cxt2+           , occ_tail    = tail1 `andTailCallInfo` tail2 }+orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )+                  ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo`+                                        tailCallInfo a2 }++andTailCallInfo :: TailCallInfo -> TailCallInfo -> TailCallInfo+andTailCallInfo info@(AlwaysTailCalled arity1) (AlwaysTailCalled arity2)+  | arity1 == arity2 = info+andTailCallInfo _ _  = NoTailCallInfo
+ simplCore/SAT.hs view
@@ -0,0 +1,431 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++************************************************************************++               Static Argument Transformation pass++************************************************************************++May be seen as removing invariants from loops:+Arguments of recursive functions that do not change in recursive+calls are removed from the recursion, which is done locally+and only passes the arguments which effectively change.++Example:+map = /\ ab -> \f -> \xs -> case xs of+                 []       -> []+                 (a:b) -> f a : map f b++as map is recursively called with the same argument f (unmodified)+we transform it to++map = /\ ab -> \f -> \xs -> let map' ys = case ys of+                       []     -> []+                       (a:b) -> f a : map' b+                in map' xs++Notice that for a compiler that uses lambda lifting this is+useless as map' will be transformed back to what map was.++We could possibly do the same for big lambdas, but we don't as+they will eventually be removed in later stages of the compiler,+therefore there is no penalty in keeping them.++We only apply the SAT when the number of static args is > 2. This+produces few bad cases.  See+                should_transform+in saTransform.++Here are the headline nofib results:+                  Size    Allocs   Runtime+Min             +0.0%    -13.7%    -21.4%+Max             +0.1%     +0.0%     +5.4%+Geometric Mean  +0.0%     -0.2%     -6.9%++The previous patch, to fix polymorphic floatout demand signatures, is+essential to make this work well!+-}++{-# LANGUAGE CPP #-}+module SAT ( doStaticArgs ) where++import Var+import CoreSyn+import CoreUtils+import Type+import Coercion+import Id+import Name+import VarEnv+import UniqSupply+import Util+import UniqFM+import VarSet+import Unique+import UniqSet+import Outputable++import Data.List+import FastString++#include "HsVersions.h"++doStaticArgs :: UniqSupply -> CoreProgram -> CoreProgram+doStaticArgs us binds = snd $ mapAccumL sat_bind_threaded_us us binds+  where+    sat_bind_threaded_us us bind =+        let (us1, us2) = splitUniqSupply us+        in (us1, fst $ runSAT us2 (satBind bind emptyUniqSet))++-- We don't bother to SAT recursive groups since it can lead+-- to massive code expansion: see Andre Santos' thesis for details.+-- This means we only apply the actual SAT to Rec groups of one element,+-- but we want to recurse into the others anyway to discover other binds+satBind :: CoreBind -> IdSet -> SatM (CoreBind, IdSATInfo)+satBind (NonRec binder expr) interesting_ids = do+    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids+    return (NonRec binder expr', finalizeApp expr_app sat_info_expr)+satBind (Rec [(binder, rhs)]) interesting_ids = do+    let interesting_ids' = interesting_ids `addOneToUniqSet` binder+        (rhs_binders, rhs_body) = collectBinders rhs+    (rhs_body', sat_info_rhs_body) <- satTopLevelExpr rhs_body interesting_ids'+    let sat_info_rhs_from_args = unitVarEnv binder (bindersToSATInfo rhs_binders)+        sat_info_rhs' = mergeIdSATInfo sat_info_rhs_from_args sat_info_rhs_body++        shadowing = binder `elementOfUniqSet` interesting_ids+        sat_info_rhs'' = if shadowing+                        then sat_info_rhs' `delFromUFM` binder -- For safety+                        else sat_info_rhs'++    bind' <- saTransformMaybe binder (lookupUFM sat_info_rhs' binder)+                              rhs_binders rhs_body'+    return (bind', sat_info_rhs'')+satBind (Rec pairs) interesting_ids = do+    let (binders, rhss) = unzip pairs+    rhss_SATed <- mapM (\e -> satTopLevelExpr e interesting_ids) rhss+    let (rhss', sat_info_rhss') = unzip rhss_SATed+    return (Rec (zipEqual "satBind" binders rhss'), mergeIdSATInfos sat_info_rhss')++data App = VarApp Id | TypeApp Type | CoApp Coercion+data Staticness a = Static a | NotStatic++type IdAppInfo = (Id, SATInfo)++type SATInfo = [Staticness App]+type IdSATInfo = IdEnv SATInfo+emptyIdSATInfo :: IdSATInfo+emptyIdSATInfo = emptyUFM++{-+pprIdSATInfo id_sat_info = vcat (map pprIdAndSATInfo (Map.toList id_sat_info))+  where pprIdAndSATInfo (v, sat_info) = hang (ppr v <> colon) 4 (pprSATInfo sat_info)+-}++pprSATInfo :: SATInfo -> SDoc+pprSATInfo staticness = hcat $ map pprStaticness staticness++pprStaticness :: Staticness App -> SDoc+pprStaticness (Static (VarApp _))  = text "SV"+pprStaticness (Static (TypeApp _)) = text "ST"+pprStaticness (Static (CoApp _))   = text "SC"+pprStaticness NotStatic            = text "NS"+++mergeSATInfo :: SATInfo -> SATInfo -> SATInfo+mergeSATInfo l r = zipWith mergeSA l r+  where+    mergeSA NotStatic _ = NotStatic+    mergeSA _ NotStatic = NotStatic+    mergeSA (Static (VarApp v)) (Static (VarApp v'))+      | v == v'   = Static (VarApp v)+      | otherwise = NotStatic+    mergeSA (Static (TypeApp t)) (Static (TypeApp t'))+      | t `eqType` t' = Static (TypeApp t)+      | otherwise     = NotStatic+    mergeSA (Static (CoApp c)) (Static (CoApp c'))+      | c `eqCoercion` c' = Static (CoApp c)+      | otherwise             = NotStatic+    mergeSA _ _  = pprPanic "mergeSATInfo" $+                          text "Left:"+                       <> pprSATInfo l <> text ", "+                       <> text "Right:"+                       <> pprSATInfo r++mergeIdSATInfo :: IdSATInfo -> IdSATInfo -> IdSATInfo+mergeIdSATInfo = plusUFM_C mergeSATInfo++mergeIdSATInfos :: [IdSATInfo] -> IdSATInfo+mergeIdSATInfos = foldl' mergeIdSATInfo emptyIdSATInfo++bindersToSATInfo :: [Id] -> SATInfo+bindersToSATInfo vs = map (Static . binderToApp) vs+    where binderToApp v | isId v    = VarApp v+                        | isTyVar v = TypeApp $ mkTyVarTy v+                        | otherwise = CoApp $ mkCoVarCo v++finalizeApp :: Maybe IdAppInfo -> IdSATInfo -> IdSATInfo+finalizeApp Nothing id_sat_info = id_sat_info+finalizeApp (Just (v, sat_info')) id_sat_info =+    let sat_info'' = case lookupUFM id_sat_info v of+                        Nothing -> sat_info'+                        Just sat_info -> mergeSATInfo sat_info sat_info'+    in extendVarEnv id_sat_info v sat_info''++satTopLevelExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo)+satTopLevelExpr expr interesting_ids = do+    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids+    return (expr', finalizeApp expr_app sat_info_expr)++satExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo)+satExpr var@(Var v) interesting_ids = do+    let app_info = if v `elementOfUniqSet` interesting_ids+                   then Just (v, [])+                   else Nothing+    return (var, emptyIdSATInfo, app_info)++satExpr lit@(Lit _) _ = do+    return (lit, emptyIdSATInfo, Nothing)++satExpr (Lam binders body) interesting_ids = do+    (body', sat_info, this_app) <- satExpr body interesting_ids+    return (Lam binders body', finalizeApp this_app sat_info, Nothing)++satExpr (App fn arg) interesting_ids = do+    (fn', sat_info_fn, fn_app) <- satExpr fn interesting_ids+    let satRemainder = boring fn' sat_info_fn+    case fn_app of+        Nothing -> satRemainder Nothing+        Just (fn_id, fn_app_info) ->+            -- TODO: remove this use of append somehow (use a data structure with O(1) append but a left-to-right kind of interface)+            let satRemainderWithStaticness arg_staticness = satRemainder $ Just (fn_id, fn_app_info ++ [arg_staticness])+            in case arg of+                Type t     -> satRemainderWithStaticness $ Static (TypeApp t)+                Coercion c -> satRemainderWithStaticness $ Static (CoApp c)+                Var v      -> satRemainderWithStaticness $ Static (VarApp v)+                _          -> satRemainderWithStaticness $ NotStatic+  where+    boring :: CoreExpr -> IdSATInfo -> Maybe IdAppInfo -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo)+    boring fn' sat_info_fn app_info =+        do (arg', sat_info_arg, arg_app) <- satExpr arg interesting_ids+           let sat_info_arg' = finalizeApp arg_app sat_info_arg+               sat_info = mergeIdSATInfo sat_info_fn sat_info_arg'+           return (App fn' arg', sat_info, app_info)++satExpr (Case expr bndr ty alts) interesting_ids = do+    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids+    let sat_info_expr' = finalizeApp expr_app sat_info_expr++    zipped_alts' <- mapM satAlt alts+    let (alts', sat_infos_alts) = unzip zipped_alts'+    return (Case expr' bndr ty alts', mergeIdSATInfo sat_info_expr' (mergeIdSATInfos sat_infos_alts), Nothing)+  where+    satAlt (con, bndrs, expr) = do+        (expr', sat_info_expr) <- satTopLevelExpr expr interesting_ids+        return ((con, bndrs, expr'), sat_info_expr)++satExpr (Let bind body) interesting_ids = do+    (body', sat_info_body, body_app) <- satExpr body interesting_ids+    (bind', sat_info_bind) <- satBind bind interesting_ids+    return (Let bind' body', mergeIdSATInfo sat_info_body sat_info_bind, body_app)++satExpr (Tick tickish expr) interesting_ids = do+    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids+    return (Tick tickish expr', sat_info_expr, expr_app)++satExpr ty@(Type _) _ = do+    return (ty, emptyIdSATInfo, Nothing)++satExpr co@(Coercion _) _ = do+    return (co, emptyIdSATInfo, Nothing)++satExpr (Cast expr coercion) interesting_ids = do+    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids+    return (Cast expr' coercion, sat_info_expr, expr_app)++{-+************************************************************************++                Static Argument Transformation Monad++************************************************************************+-}++type SatM result = UniqSM result++runSAT :: UniqSupply -> SatM a -> a+runSAT = initUs_++newUnique :: SatM Unique+newUnique = getUniqueM++{-+************************************************************************++                Static Argument Transformation Monad++************************************************************************++To do the transformation, the game plan is to:++1. Create a small nonrecursive RHS that takes the+   original arguments to the function but discards+   the ones that are static and makes a call to the+   SATed version with the remainder. We intend that+   this will be inlined later, removing the overhead++2. Bind this nonrecursive RHS over the original body+   WITH THE SAME UNIQUE as the original body so that+   any recursive calls to the original now go via+   the small wrapper++3. Rebind the original function to a new one which contains+   our SATed function and just makes a call to it:+   we call the thing making this call the local body++Example: transform this++    map :: forall a b. (a->b) -> [a] -> [b]+    map = /\ab. \(f:a->b) (as:[a]) -> body[map]+to+    map :: forall a b. (a->b) -> [a] -> [b]+    map = /\ab. \(f:a->b) (as:[a]) ->+         letrec map' :: [a] -> [b]+                    -- The "worker function+                map' = \(as:[a]) ->+                         let map :: forall a' b'. (a -> b) -> [a] -> [b]+                                -- The "shadow function+                             map = /\a'b'. \(f':(a->b) (as:[a]).+                                   map' as+                         in body[map]+         in map' as++Note [Shadow binding]+~~~~~~~~~~~~~~~~~~~~~+The calls to the inner map inside body[map] should get inlined+by the local re-binding of 'map'.  We call this the "shadow binding".++But we can't use the original binder 'map' unchanged, because+it might be exported, in which case the shadow binding won't be+discarded as dead code after it is inlined.++So we use a hack: we make a new SysLocal binder with the *same* unique+as binder.  (Another alternative would be to reset the export flag.)++Note [Binder type capture]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Notice that in the inner map (the "shadow function"), the static arguments+are discarded -- it's as if they were underscores.  Instead, mentions+of these arguments (notably in the types of dynamic arguments) are bound+by the *outer* lambdas of the main function.  So we must make up fresh+names for the static arguments so that they do not capture variables+mentioned in the types of dynamic args.++In the map example, the shadow function must clone the static type+argument a,b, giving a',b', to ensure that in the \(as:[a]), the 'a'+is bound by the outer forall.  We clone f' too for consistency, but+that doesn't matter either way because static Id arguments aren't+mentioned in the shadow binding at all.++If we don't we get something like this:++[Exported]+[Arity 3]+GHC.Base.until =+  \ (@ a_aiK)+    (p_a6T :: a_aiK -> GHC.Types.Bool)+    (f_a6V :: a_aiK -> a_aiK)+    (x_a6X :: a_aiK) ->+    letrec {+      sat_worker_s1aU :: a_aiK -> a_aiK+      []+      sat_worker_s1aU =+        \ (x_a6X :: a_aiK) ->+          let {+            sat_shadow_r17 :: forall a_a3O.+                              (a_a3O -> GHC.Types.Bool) -> (a_a3O -> a_a3O) -> a_a3O -> a_a3O+            []+            sat_shadow_r17 =+              \ (@ a_aiK)+                (p_a6T :: a_aiK -> GHC.Types.Bool)+                (f_a6V :: a_aiK -> a_aiK)+                (x_a6X :: a_aiK) ->+                sat_worker_s1aU x_a6X } in+          case p_a6T x_a6X of wild_X3y [ALWAYS Dead Nothing] {+            GHC.Types.False -> GHC.Base.until @ a_aiK p_a6T f_a6V (f_a6V x_a6X);+            GHC.Types.True -> x_a6X+          }; } in+    sat_worker_s1aU x_a6X++Where sat_shadow has captured the type variables of x_a6X etc as it has a a_aiK+type argument. This is bad because it means the application sat_worker_s1aU x_a6X+is not well typed.+-}++saTransformMaybe :: Id -> Maybe SATInfo -> [Id] -> CoreExpr -> SatM CoreBind+saTransformMaybe binder maybe_arg_staticness rhs_binders rhs_body+  | Just arg_staticness <- maybe_arg_staticness+  , should_transform arg_staticness+  = saTransform binder arg_staticness rhs_binders rhs_body+  | otherwise+  = return (Rec [(binder, mkLams rhs_binders rhs_body)])+  where+    should_transform staticness = n_static_args > 1 -- THIS IS THE DECISION POINT+      where+        n_static_args = count isStaticValue staticness++saTransform :: Id -> SATInfo -> [Id] -> CoreExpr -> SatM CoreBind+saTransform binder arg_staticness rhs_binders rhs_body+  = do  { shadow_lam_bndrs <- mapM clone binders_w_staticness+        ; uniq             <- newUnique+        ; return (NonRec binder (mk_new_rhs uniq shadow_lam_bndrs)) }+  where+    -- Running example: foldr+    -- foldr \alpha \beta c n xs = e, for some e+    -- arg_staticness = [Static TypeApp, Static TypeApp, Static VarApp, Static VarApp, NonStatic]+    -- rhs_binders = [\alpha, \beta, c, n, xs]+    -- rhs_body = e++    binders_w_staticness = rhs_binders `zip` (arg_staticness ++ repeat NotStatic)+                                        -- Any extra args are assumed NotStatic++    non_static_args :: [Var]+            -- non_static_args = [xs]+            -- rhs_binders_without_type_capture = [\alpha', \beta', c, n, xs]+    non_static_args = [v | (v, NotStatic) <- binders_w_staticness]++    clone (bndr, NotStatic) = return bndr+    clone (bndr, _        ) = do { uniq <- newUnique+                                 ; return (setVarUnique bndr uniq) }++    -- new_rhs = \alpha beta c n xs ->+    --           let sat_worker = \xs -> let sat_shadow = \alpha' beta' c n xs ->+    --                                       sat_worker xs+    --                                   in e+    --           in sat_worker xs+    mk_new_rhs uniq shadow_lam_bndrs+        = mkLams rhs_binders $+          Let (Rec [(rec_body_bndr, rec_body)])+          local_body+        where+          local_body = mkVarApps (Var rec_body_bndr) non_static_args++          rec_body = mkLams non_static_args $+                     Let (NonRec shadow_bndr shadow_rhs) rhs_body++            -- See Note [Binder type capture]+          shadow_rhs = mkLams shadow_lam_bndrs local_body+            -- nonrec_rhs = \alpha' beta' c n xs -> sat_worker xs++          rec_body_bndr = mkSysLocal (fsLit "sat_worker") uniq (exprType rec_body)+            -- rec_body_bndr = sat_worker++            -- See Note [Shadow binding]; make a SysLocal+          shadow_bndr = mkSysLocal (occNameFS (getOccName binder))+                                   (idUnique binder)+                                   (exprType shadow_rhs)++isStaticValue :: Staticness App -> Bool+isStaticValue (Static (VarApp _)) = True+isStaticValue _                   = False
+ simplCore/SetLevels.hs view
@@ -0,0 +1,1643 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section{SetLevels}++                ***************************+                        Overview+                ***************************++1. We attach binding levels to Core bindings, in preparation for floating+   outwards (@FloatOut@).++2. We also let-ify many expressions (notably case scrutinees), so they+   will have a fighting chance of being floated sensible.++3. Note [Need for cloning during float-out]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+   We clone the binders of any floatable let-binding, so that when it is+   floated out it will be unique. Example+      (let x=2 in x) + (let x=3 in x)+   we must clone before floating so we get+      let x1=2 in+      let x2=3 in+      x1+x2++   NOTE: this can't be done using the uniqAway idea, because the variable+         must be unique in the whole program, not just its current scope,+         because two variables in different scopes may float out to the+         same top level place++   NOTE: Very tiresomely, we must apply this substitution to+         the rules stored inside a variable too.++   We do *not* clone top-level bindings, because some of them must not change,+   but we *do* clone bindings that are heading for the top level++4. Note [Binder-swap during float-out]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+   In the expression+        case x of wild { p -> ...wild... }+   we substitute x for wild in the RHS of the case alternatives:+        case x of wild { p -> ...x... }+   This means that a sub-expression involving x is not "trapped" inside the RHS.+   And it's not inconvenient because we already have a substitution.++  Note that this is EXACTLY BACKWARDS from the what the simplifier does.+  The simplifier tries to get rid of occurrences of x, in favour of wild,+  in the hope that there will only be one remaining occurrence of x, namely+  the scrutinee of the case, and we can inline it.+-}++{-# LANGUAGE CPP, MultiWayIf #-}+module SetLevels (+        setLevels,++        Level(..), LevelType(..), tOP_LEVEL, isJoinCeilLvl, asJoinCeilLvl,+        LevelledBind, LevelledExpr, LevelledBndr,+        FloatSpec(..), floatSpecLevel,++        incMinorLvl, ltMajLvl, ltLvl, isTopLvl+    ) where++#include "HsVersions.h"++import CoreSyn+import CoreMonad        ( FloatOutSwitches(..) )+import CoreUtils        ( exprType, exprIsHNF+                        , exprOkForSpeculation+                        , exprIsTopLevelBindable+                        , isExprLevPoly+                        , collectMakeStaticArgs+                        )+import CoreArity        ( exprBotStrictness_maybe )+import CoreFVs          -- all of it+import CoreSubst+import MkCore           ( sortQuantVars )++import Id+import IdInfo+import Var+import VarSet+import VarEnv+import Literal          ( litIsTrivial )+import Demand           ( StrictSig, isStrictDmd, splitStrictSig, increaseStrictSigArity )+import Name             ( getOccName, mkSystemVarName )+import OccName          ( occNameString )+import Type             ( isUnliftedType, Type, mkLamTypes, splitTyConApp_maybe )+import BasicTypes       ( Arity, RecFlag(..), isRec )+import DataCon          ( dataConOrigResTy )+import TysWiredIn+import UniqSupply+import Util+import Outputable+import FastString+import UniqDFM+import FV+import Data.Maybe+import Control.Monad    ( zipWithM )++{-+************************************************************************+*                                                                      *+\subsection{Level numbers}+*                                                                      *+************************************************************************+-}++type LevelledExpr = TaggedExpr FloatSpec+type LevelledBind = TaggedBind FloatSpec+type LevelledBndr = TaggedBndr FloatSpec++data Level = Level Int  -- Level number of enclosing lambdas+                   Int  -- Number of big-lambda and/or case expressions and/or+                        -- context boundaries between+                        -- here and the nearest enclosing lambda+                   LevelType -- Binder or join ceiling?+data LevelType = BndrLvl | JoinCeilLvl deriving (Eq)++data FloatSpec+  = FloatMe Level       -- Float to just inside the binding+                        --    tagged with this level+  | StayPut Level       -- Stay where it is; binding is+                        --     tagged with tihs level++floatSpecLevel :: FloatSpec -> Level+floatSpecLevel (FloatMe l) = l+floatSpecLevel (StayPut l) = l++{-+The {\em level number} on a (type-)lambda-bound variable is the+nesting depth of the (type-)lambda which binds it.  The outermost lambda+has level 1, so (Level 0 0) means that the variable is bound outside any lambda.++On an expression, it's the maximum level number of its free+(type-)variables.  On a let(rec)-bound variable, it's the level of its+RHS.  On a case-bound variable, it's the number of enclosing lambdas.++Top-level variables: level~0.  Those bound on the RHS of a top-level+definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown+as ``subscripts'')...+\begin{verbatim}+a_0 = let  b_? = ...  in+           x_1 = ... b ... in ...+\end{verbatim}++The main function @lvlExpr@ carries a ``context level'' (@le_ctxt_lvl@).+That's meant to be the level number of the enclosing binder in the+final (floated) program.  If the level number of a sub-expression is+less than that of the context, then it might be worth let-binding the+sub-expression so that it will indeed float.++If you can float to level @Level 0 0@ worth doing so because then your+allocation becomes static instead of dynamic.  We always start with+context @Level 0 0@.+++Note [FloatOut inside INLINE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+@InlineCtxt@ very similar to @Level 0 0@, but is used for one purpose:+to say "don't float anything out of here".  That's exactly what we+want for the body of an INLINE, where we don't want to float anything+out at all.  See notes with lvlMFE below.++But, check this out:++-- At one time I tried the effect of not float anything out of an InlineMe,+-- but it sometimes works badly.  For example, consider PrelArr.done.  It+-- has the form         __inline (\d. e)+-- where e doesn't mention d.  If we float this to+--      __inline (let x = e in \d. x)+-- things are bad.  The inliner doesn't even inline it because it doesn't look+-- like a head-normal form.  So it seems a lesser evil to let things float.+-- In SetLevels we do set the context to (Level 0 0) when we get to an InlineMe+-- which discourages floating out.++So the conclusion is: don't do any floating at all inside an InlineMe.+(In the above example, don't float the {x=e} out of the \d.)++One particular case is that of workers: we don't want to float the+call to the worker outside the wrapper, otherwise the worker might get+inlined into the floated expression, and an importing module won't see+the worker at all.++Note [Join ceiling]+~~~~~~~~~~~~~~~~~~~+Join points can't float very far; too far, and they can't remain join points+So, suppose we have:++  f x = (joinrec j y = ... x ... in jump j x) + 1++One may be tempted to float j out to the top of f's RHS, but then the jump+would not be a tail call. Thus we keep track of a level called the *join+ceiling* past which join points are not allowed to float.++The troublesome thing is that, unlike most levels to which something might+float, there is not necessarily an identifier to which the join ceiling is+attached. Fortunately, if something is to be floated to a join ceiling, it must+be dropped at the *nearest* join ceiling. Thus each level is marked as to+whether it is a join ceiling, so that FloatOut can tell which binders are being+floated to the nearest join ceiling and which to a particular binder (or set of+binders).+-}++instance Outputable FloatSpec where+  ppr (FloatMe l) = char 'F' <> ppr l+  ppr (StayPut l) = ppr l++tOP_LEVEL :: Level+tOP_LEVEL   = Level 0 0 BndrLvl++incMajorLvl :: Level -> Level+incMajorLvl (Level major _ _) = Level (major + 1) 0 BndrLvl++incMinorLvl :: Level -> Level+incMinorLvl (Level major minor _) = Level major (minor+1) BndrLvl++asJoinCeilLvl :: Level -> Level+asJoinCeilLvl (Level major minor _) = Level major minor JoinCeilLvl++maxLvl :: Level -> Level -> Level+maxLvl l1@(Level maj1 min1 _) l2@(Level maj2 min2 _)+  | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1+  | otherwise                                      = l2++ltLvl :: Level -> Level -> Bool+ltLvl (Level maj1 min1 _) (Level maj2 min2 _)+  = (maj1 < maj2) || (maj1 == maj2 && min1 < min2)++ltMajLvl :: Level -> Level -> Bool+    -- Tells if one level belongs to a difft *lambda* level to another+ltMajLvl (Level maj1 _ _) (Level maj2 _ _) = maj1 < maj2++isTopLvl :: Level -> Bool+isTopLvl (Level 0 0 _) = True+isTopLvl _             = False++isJoinCeilLvl :: Level -> Bool+isJoinCeilLvl (Level _ _ t) = t == JoinCeilLvl++instance Outputable Level where+  ppr (Level maj min typ)+    = hcat [ char '<', int maj, char ',', int min, char '>'+           , ppWhen (typ == JoinCeilLvl) (char 'C') ]++instance Eq Level where+  (Level maj1 min1 _) == (Level maj2 min2 _) = maj1 == maj2 && min1 == min2++{-+************************************************************************+*                                                                      *+\subsection{Main level-setting code}+*                                                                      *+************************************************************************+-}++setLevels :: FloatOutSwitches+          -> CoreProgram+          -> UniqSupply+          -> [LevelledBind]++setLevels float_lams binds us+  = initLvl us (do_them init_env binds)+  where+    init_env = initialEnv float_lams++    do_them :: LevelEnv -> [CoreBind] -> LvlM [LevelledBind]+    do_them _ [] = return []+    do_them env (b:bs)+      = do { (lvld_bind, env') <- lvlTopBind env b+           ; lvld_binds <- do_them env' bs+           ; return (lvld_bind : lvld_binds) }++lvlTopBind :: LevelEnv -> Bind Id -> LvlM (LevelledBind, LevelEnv)+lvlTopBind env (NonRec bndr rhs)+  = do { rhs' <- lvl_top env NonRecursive bndr rhs+       ; let (env', [bndr']) = substAndLvlBndrs NonRecursive env tOP_LEVEL [bndr]+       ; return (NonRec bndr' rhs', env') }++lvlTopBind env (Rec pairs)+  = do { let (env', bndrs') = substAndLvlBndrs Recursive env tOP_LEVEL+                                               (map fst pairs)+       ; rhss' <- mapM (\(b,r) -> lvl_top env' Recursive b r) pairs+       ; return (Rec (bndrs' `zip` rhss'), env') }++lvl_top :: LevelEnv -> RecFlag -> Id -> CoreExpr -> LvlM LevelledExpr+lvl_top env is_rec bndr rhs+  = lvlRhs env is_rec+           (isBottomingId bndr)+           Nothing  -- Not a join point+           (freeVars rhs)++{-+************************************************************************+*                                                                      *+\subsection{Setting expression levels}+*                                                                      *+************************************************************************++Note [Floating over-saturated applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we see (f x y), and (f x) is a redex (ie f's arity is 1),+we call (f x) an "over-saturated application"++Should we float out an over-sat app, if can escape a value lambda?+It is sometimes very beneficial (-7% runtime -4% alloc over nofib -O2).+But we don't want to do it for class selectors, because the work saved+is minimal, and the extra local thunks allocated cost money.++Arguably we could float even class-op applications if they were going to+top level -- but then they must be applied to a constant dictionary and+will almost certainly be optimised away anyway.+-}++lvlExpr :: LevelEnv             -- Context+        -> CoreExprWithFVs      -- Input expression+        -> LvlM LevelledExpr    -- Result expression++{-+The @le_ctxt_lvl@ is, roughly, the level of the innermost enclosing+binder.  Here's an example++        v = \x -> ...\y -> let r = case (..x..) of+                                        ..x..+                           in ..++When looking at the rhs of @r@, @le_ctxt_lvl@ will be 1 because that's+the level of @r@, even though it's inside a level-2 @\y@.  It's+important that @le_ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we+don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE+--- because it isn't a *maximal* free expression.++If there were another lambda in @r@'s rhs, it would get level-2 as well.+-}++lvlExpr env (_, AnnType ty)     = return (Type (CoreSubst.substTy (le_subst env) ty))+lvlExpr env (_, AnnCoercion co) = return (Coercion (substCo (le_subst env) co))+lvlExpr env (_, AnnVar v)       = return (lookupVar env v)+lvlExpr _   (_, AnnLit lit)     = return (Lit lit)++lvlExpr env (_, AnnCast expr (_, co)) = do+    expr' <- lvlNonTailExpr env expr+    return (Cast expr' (substCo (le_subst env) co))++lvlExpr env (_, AnnTick tickish expr) = do+    expr' <- lvlNonTailExpr env expr+    let tickish' = substTickish (le_subst env) tickish+    return (Tick tickish' expr')++lvlExpr env expr@(_, AnnApp _ _) = lvlApp env expr (collectAnnArgs expr)++-- We don't split adjacent lambdas.  That is, given+--      \x y -> (x+1,y)+-- we don't float to give+--      \x -> let v = x+1 in \y -> (v,y)+-- Why not?  Because partial applications are fairly rare, and splitting+-- lambdas makes them more expensive.++lvlExpr env expr@(_, AnnLam {})+  = do { new_body <- lvlNonTailMFE new_env True body+       ; return (mkLams new_bndrs new_body) }+  where+    (bndrs, body)        = collectAnnBndrs expr+    (env1, bndrs1)       = substBndrsSL NonRecursive env bndrs+    (new_env, new_bndrs) = lvlLamBndrs env1 (le_ctxt_lvl env) bndrs1+        -- At one time we called a special verion of collectBinders,+        -- which ignored coercions, because we don't want to split+        -- a lambda like this (\x -> coerce t (\s -> ...))+        -- This used to happen quite a bit in state-transformer programs,+        -- but not nearly so much now non-recursive newtypes are transparent.+        -- [See SetLevels rev 1.50 for a version with this approach.]++lvlExpr env (_, AnnLet bind body)+  = do { (bind', new_env) <- lvlBind env bind+       ; body' <- lvlExpr new_env body+           -- No point in going via lvlMFE here.  If the binding is alive+           -- (mentioned in body), and the whole let-expression doesn't+           -- float, then neither will the body+       ; return (Let bind' body') }++lvlExpr env (_, AnnCase scrut case_bndr ty alts)+  = do { scrut' <- lvlNonTailMFE env True scrut+       ; lvlCase env (freeVarsOf scrut) scrut' case_bndr ty alts }++lvlNonTailExpr :: LevelEnv             -- Context+               -> CoreExprWithFVs      -- Input expression+               -> LvlM LevelledExpr    -- Result expression+lvlNonTailExpr env expr+  = lvlExpr (placeJoinCeiling env) expr++-------------------------------------------+lvlApp :: LevelEnv+       -> CoreExprWithFVs+       -> (CoreExprWithFVs, [CoreExprWithFVs]) -- Input application+        -> LvlM LevelledExpr                   -- Result expression+lvlApp env orig_expr ((_,AnnVar fn), args)+  | floatOverSat env   -- See Note [Floating over-saturated applications]+  , arity > 0+  , arity < n_val_args+  , Nothing <- isClassOpId_maybe fn+  =  do { rargs' <- mapM (lvlNonTailMFE env False) rargs+        ; lapp'  <- lvlNonTailMFE env False lapp+        ; return (foldl App lapp' rargs') }++  | otherwise+  = do { args' <- zipWithM (lvlMFE env) stricts args+            -- Take account of argument strictness; see+            -- Note [Floating to the top]+       ; return (foldl App (lookupVar env fn) args') }+  where+    n_val_args = count (isValArg . deAnnotate) args+    arity      = idArity fn++    stricts :: [Bool]   -- True for strict argument+    stricts = case splitStrictSig (idStrictness fn) of+                (arg_ds, _) | not (arg_ds `lengthExceeds` n_val_args)+                            -> map isStrictDmd arg_ds ++ repeat False+                            | otherwise+                            -> repeat False++    -- Separate out the PAP that we are floating from the extra+    -- arguments, by traversing the spine until we have collected+    -- (n_val_args - arity) value arguments.+    (lapp, rargs) = left (n_val_args - arity) orig_expr []++    left 0 e               rargs = (e, rargs)+    left n (_, AnnApp f a) rargs+       | isValArg (deAnnotate a) = left (n-1) f (a:rargs)+       | otherwise               = left n     f (a:rargs)+    left _ _ _                   = panic "SetLevels.lvlExpr.left"++lvlApp env _ (fun, args)+  =  -- No PAPs that we can float: just carry on with the+     -- arguments and the function.+     do { args' <- mapM (lvlNonTailMFE env False) args+        ; fun'  <- lvlNonTailExpr env fun+        ; return (foldl App fun' args') }++-------------------------------------------+lvlCase :: LevelEnv             -- Level of in-scope names/tyvars+        -> DVarSet              -- Free vars of input scrutinee+        -> LevelledExpr         -- Processed scrutinee+        -> Id -> Type           -- Case binder and result type+        -> [CoreAltWithFVs]     -- Input alternatives+        -> LvlM LevelledExpr    -- Result expression+lvlCase env scrut_fvs scrut' case_bndr ty alts+  | [(con@(DataAlt {}), bs, body)] <- alts+  , exprOkForSpeculation scrut'   -- See Note [Check the output scrutinee for okForSpec]+  , not (isTopLvl dest_lvl)       -- Can't have top-level cases+  , not (floatTopLvlOnly env)     -- Can float anywhere+  =     -- See Note [Floating cases]+        -- Always float the case if possible+        -- Unlike lets we don't insist that it escapes a value lambda+    do { (env1, (case_bndr' : bs')) <- cloneCaseBndrs env dest_lvl (case_bndr : bs)+       ; let rhs_env = extendCaseBndrEnv env1 case_bndr scrut'+       ; body' <- lvlMFE rhs_env True body+       ; let alt' = (con, map (stayPut dest_lvl) bs', body')+       ; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty' [alt']) }++  | otherwise     -- Stays put+  = do { let (alts_env1, [case_bndr']) = substAndLvlBndrs NonRecursive env incd_lvl [case_bndr]+             alts_env = extendCaseBndrEnv alts_env1 case_bndr scrut'+       ; alts' <- mapM (lvl_alt alts_env) alts+       ; return (Case scrut' case_bndr' ty' alts') }+  where+    ty' = substTy (le_subst env) ty++    incd_lvl = incMinorLvl (le_ctxt_lvl env)+    dest_lvl = maxFvLevel (const True) env scrut_fvs+            -- Don't abstract over type variables, hence const True++    lvl_alt alts_env (con, bs, rhs)+      = do { rhs' <- lvlMFE new_env True rhs+           ; return (con, bs', rhs') }+      where+        (new_env, bs') = substAndLvlBndrs NonRecursive alts_env incd_lvl bs++{-+Note [Floating cases]+~~~~~~~~~~~~~~~~~~~~~+Consider this:+  data T a = MkT !a+  f :: T Int -> blah+  f x vs = case x of { MkT y ->+             let f vs = ...(case y of I# w -> e)...f..+             in f vs+Here we can float the (case y ...) out, because y is sure+to be evaluated, to give+  f x vs = case x of { MkT y ->+           caes y of I# w ->+             let f vs = ...(e)...f..+             in f vs++That saves unboxing it every time round the loop.  It's important in+some DPH stuff where we really want to avoid that repeated unboxing in+the inner loop.++Things to note+ * We can't float a case to top level+ * It's worth doing this float even if we don't float+   the case outside a value lambda.  Example+     case x of {+       MkT y -> (case y of I# w2 -> ..., case y of I# w2 -> ...)+   If we floated the cases out we could eliminate one of them.+ * We only do this with a single-alternative case++Note [Check the output scrutinee for okForSpec]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:+  case x of y {+    A -> ....(case y of alts)....+  }+Because of the binder-swap, the inner case will get substituted to+(case x of ..).  So when testing whether the scrutinee is+okForSpeculation we must be careful to test the *result* scrutinee ('x'+in this case), not the *input* one 'y'.  The latter *is* ok for+speculation here, but the former is not -- and indeed we can't float+the inner case out, at least not unless x is also evaluated at its+binding site.++That's why we apply exprOkForSpeculation to scrut' and not to scrut.+-}++lvlNonTailMFE :: LevelEnv             -- Level of in-scope names/tyvars+              -> Bool                 -- True <=> strict context [body of case+                                      --   or let]+              -> CoreExprWithFVs      -- input expression+              -> LvlM LevelledExpr    -- Result expression+lvlNonTailMFE env strict_ctxt ann_expr+  = lvlMFE (placeJoinCeiling env) strict_ctxt ann_expr++lvlMFE ::  LevelEnv             -- Level of in-scope names/tyvars+        -> Bool                 -- True <=> strict context [body of case or let]+        -> CoreExprWithFVs      -- input expression+        -> LvlM LevelledExpr    -- Result expression+-- lvlMFE is just like lvlExpr, except that it might let-bind+-- the expression, so that it can itself be floated.++lvlMFE env _ (_, AnnType ty)+  = return (Type (CoreSubst.substTy (le_subst env) ty))++-- No point in floating out an expression wrapped in a coercion or note+-- If we do we'll transform  lvl = e |> co+--                       to  lvl' = e; lvl = lvl' |> co+-- and then inline lvl.  Better just to float out the payload.+lvlMFE env strict_ctxt (_, AnnTick t e)+  = do { e' <- lvlMFE env strict_ctxt e+       ; return (Tick t e') }++lvlMFE env strict_ctxt (_, AnnCast e (_, co))+  = do  { e' <- lvlMFE env strict_ctxt e+        ; return (Cast e' (substCo (le_subst env) co)) }++lvlMFE env strict_ctxt e@(_, AnnCase {})+  | strict_ctxt       -- Don't share cases in a strict context+  = lvlExpr env e     -- See Note [Case MFEs]++lvlMFE env strict_ctxt ann_expr+  |  floatTopLvlOnly env && not (isTopLvl dest_lvl)+         -- Only floating to the top level is allowed.+  || anyDVarSet isJoinId fvs   -- If there is a free join, don't float+                               -- See Note [Free join points]+  || isExprLevPoly expr+         -- We can't let-bind levity polymorphic expressions+         -- See Note [Levity polymorphism invariants] in CoreSyn+  || notWorthFloating expr abs_vars+  || not float_me+  =     -- Don't float it out+    lvlExpr env ann_expr++  |  float_is_new_lam || exprIsTopLevelBindable expr expr_ty+         -- No wrapping needed if the type is lifted, or is a literal string+         -- or if we are wrapping it in one or more value lambdas+  = do { expr1 <- lvlFloatRhs abs_vars dest_lvl rhs_env NonRecursive+                              (isJust mb_bot_str)+                              join_arity_maybe+                              ann_expr+                  -- Treat the expr just like a right-hand side+       ; var <- newLvlVar expr1 join_arity_maybe is_mk_static+       ; let var2 = annotateBotStr var float_n_lams mb_bot_str+       ; return (Let (NonRec (TB var2 (FloatMe dest_lvl)) expr1)+                     (mkVarApps (Var var2) abs_vars)) }++  -- OK, so the float has an unlifted type (not top-level bindable)+  --     and no new value lambdas (float_is_new_lam is False)+  -- Try for the boxing strategy+  -- See Note [Floating MFEs of unlifted type]+  | escapes_value_lam+  , not expr_ok_for_spec -- Boxing/unboxing isn't worth it for cheap expressions+                         -- See Note [Test cheapness with exprOkForSpeculation]+  , Just (tc, _) <- splitTyConApp_maybe expr_ty+  , Just dc <- boxingDataCon_maybe tc+  , let dc_res_ty = dataConOrigResTy dc  -- No free type variables+        [bx_bndr, ubx_bndr] = mkTemplateLocals [dc_res_ty, expr_ty]+  = do { expr1 <- lvlExpr rhs_env ann_expr+       ; let l1r       = incMinorLvlFrom rhs_env+             float_rhs = mkLams abs_vars_w_lvls $+                         Case expr1 (stayPut l1r ubx_bndr) dc_res_ty+                             [(DEFAULT, [], mkConApp dc [Var ubx_bndr])]++       ; var <- newLvlVar float_rhs Nothing is_mk_static+       ; let l1u      = incMinorLvlFrom env+             use_expr = Case (mkVarApps (Var var) abs_vars)+                             (stayPut l1u bx_bndr) expr_ty+                             [(DataAlt dc, [stayPut l1u ubx_bndr], Var ubx_bndr)]+       ; return (Let (NonRec (TB var (FloatMe dest_lvl)) float_rhs)+                     use_expr) }++  | otherwise          -- e.g. do not float unboxed tuples+  = lvlExpr env ann_expr++  where+    expr         = deAnnotate ann_expr+    expr_ty      = exprType expr+    fvs          = freeVarsOf ann_expr+    is_bot       = isBottomThunk mb_bot_str+    is_function  = isFunction ann_expr+    mb_bot_str   = exprBotStrictness_maybe expr+                           -- See Note [Bottoming floats]+                           -- esp Bottoming floats (2)+    expr_ok_for_spec = exprOkForSpeculation expr+    dest_lvl     = destLevel env fvs is_function is_bot False+    abs_vars     = abstractVars dest_lvl env fvs++    -- float_is_new_lam: the floated thing will be a new value lambda+    -- replacing, say (g (x+4)) by (lvl x).  No work is saved, nor is+    -- allocation saved.  The benefit is to get it to the top level+    -- and hence out of the body of this function altogether, making+    -- it smaller and more inlinable+    float_is_new_lam = float_n_lams > 0+    float_n_lams     = count isId abs_vars++    (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars++    join_arity_maybe = Nothing++    is_mk_static = isJust (collectMakeStaticArgs expr)+        -- Yuk: See Note [Grand plan for static forms] in main/StaticPtrTable++        -- A decision to float entails let-binding this thing, and we only do+        -- that if we'll escape a value lambda, or will go to the top level.+    float_me = saves_work || saves_alloc || is_mk_static++    -- We can save work if we can move a redex outside a value lambda+    -- But if float_is_new_lam is True, then the redex is wrapped in a+    -- a new lambda, so no work is saved+    saves_work = escapes_value_lam && not float_is_new_lam++    escapes_value_lam = dest_lvl `ltMajLvl` (le_ctxt_lvl env)+                  -- See Note [Escaping a value lambda]++    -- See Note [Floating to the top]+    saves_alloc =  isTopLvl dest_lvl+                && floatConsts env+                && (not strict_ctxt || is_bot || exprIsHNF expr)++isBottomThunk :: Maybe (Arity, s) -> Bool+-- See Note [Bottoming floats] (2)+isBottomThunk (Just (0, _)) = True   -- Zero arity+isBottomThunk _             = False++{- Note [Floating to the top]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We are keen to float something to the top level, even if it does not+escape a value lambda (and hence save work), for two reasons:++  * Doing so makes the function smaller, by floating out+    bottoming expressions, or integer or string literals.  That in+    turn makes it easier to inline, with less duplication.++  * (Minor) Doing so may turn a dynamic allocation (done by machine+    instructions) into a static one. Minor because we are assuming+    we are not escaping a value lambda.++But do not so if:+     - the context is a strict, and+     - the expression is not a HNF, and+     - the expression is not bottoming++Exammples:++* Bottoming+      f x = case x of+              0 -> error <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.++* HNF+      f = case y of+            True  -> p:q+            False -> blah+  We may as well float the (p:q) so it becomes a static data structure.++* Case scrutinee+      f = case g True of ....+  Don't float (g True) to top level; then we have the admin of a+  top-level thunk to worry about, with zero gain.++* Case alternative+      h = case y of+             True  -> g True+             False -> False+  Don't float (g True) to the top level++* Arguments+     t = f (g True)+  If f is lazy, we /do/ float (g True) because then we can allocate+  the thunk statically rather than dynamically.  But if f is strict+  we don't (see the use of idStrictness in lvlApp).  It's not clear+  if this test is worth the bother: it's only about CAFs!++It's controlled by a flag (floatConsts), because doing this too+early loses opportunities for RULES which (needless to say) are+important in some nofib programs (gcd is an example).  [SPJ note:+I think this is obselete; the flag seems always on.]++Note [Floating join point bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Mostly we only float a join point if it can /stay/ a join point.  But+there is one exception: if it can go to the top level (Trac #13286).+Consider+  f x = joinrec j y n = <...j y' n'...>+        in jump j x 0++Here we may just as well produce+  j y n = <....j y' n'...>+  f x = j x 0++and now there is a chance that 'f' will be inlined at its call sites.+It shouldn't make a lot of difference, but thes tests+  perf/should_run/MethSharing+  simplCore/should_compile/spec-inline+and one nofib program, all improve if you do float to top, because+of the resulting inlining of f.  So ok, let's do it.++Note [Free join points]+~~~~~~~~~~~~~~~~~~~~~~~+We never float a MFE that has a free join-point variable.  You mght think+this can never occur.  After all, consider+     join j x = ...+     in ....(jump j x)....+How might we ever want to float that (jump j x)?+  * If it would escape a value lambda, thus+        join j x = ... in (\y. ...(jump j x)... )+    then 'j' isn't a valid join point in the first place.++But consider+     join j x = .... in+     joinrec j2 y =  ...(jump j x)...(a+b)....++Since j2 is recursive, it /is/ worth floating (a+b) out of the joinrec.+But it is emphatically /not/ good to float the (jump j x) out:+ (a) 'j' will stop being a join point+ (b) In any case, jumping to 'j' must be an exit of the j2 loop, so no+     work would be saved by floating it out of the \y.++Even if we floated 'j' to top level, (b) would still hold.++Bottom line: never float a MFE that has a free JoinId.++Note [Floating MFEs of unlifted type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+   case f x of (r::Int#) -> blah+we'd like to float (f x). But it's not trivial because it has type+Int#, and we don't want to evaluate it too early.  But we can instead+float a boxed version+   y = case f x of r -> I# r+and replace the original (f x) with+   case (case y of I# r -> r) of r -> blah++Being able to float unboxed expressions is sometimes important; see+Trac #12603.  I'm not sure how /often/ it is important, but it's+not hard to achieve.++We only do it for a fixed collection of types for which we have a+convenient boxing constructor (see boxingDataCon_maybe).  In+particular we /don't/ do it for unboxed tuples; it's better to float+the components of the tuple individually.++I did experiment with a form of boxing that works for any type, namely+wrapping in a function.  In our example++   let y = case f x of r -> \v. f x+   in case y void of r -> blah++It works fine, but it's 50% slower (based on some crude benchmarking).+I suppose we could do it for types not covered by boxingDataCon_maybe,+but it's more code and I'll wait to see if anyone wants it.++Note [Test cheapness with exprOkForSpeculation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don't want to float very cheap expressions by boxing and unboxing.+But we use exprOkForSpeculation for the test, not exprIsCheap.+Why?  Because it's important /not/ to transform+     f (a /# 3)+to+     f (case bx of I# a -> a /# 3)+and float bx = I# (a /# 3), because the application of f no+longer obeys the let/app invariant.  But (a /# 3) is ok-for-spec+due to a special hack that says division operators can't fail+when the denominator is definitely non-zero.  And yet that+same expression says False to exprIsCheap.  Simplest way to+guarantee the let/app invariant is to use the same function!++If an expression is okay for speculation, we could also float it out+*without* boxing and unboxing, since evaluating it early is okay.+However, it turned out to usually be better not to float such expressions,+since they tend to be extremely cheap things like (x +# 1#). Even the+cost of spilling the let-bound variable to the stack across a call may+exceed the cost of recomputing such an expression. (And we can't float+unlifted bindings to top-level.)++We could try to do something smarter here, and float out expensive yet+okay-for-speculation things, such as division by non-zero constants.+But I suspect it's a narrow target.++Note [Bottoming floats]+~~~~~~~~~~~~~~~~~~~~~~~+If we see+        f = \x. g (error "urk")+we'd like to float the call to error, to get+        lvl = error "urk"+        f = \x. g lvl++But, as ever, we need to be careful:++(1) We want to float a bottoming+    expression even if it has free variables:+        f = \x. g (let v = h x in error ("urk" ++ v))+    Then we'd like to abstract over 'x' can float the whole arg of g:+        lvl = \x. let v = h x in error ("urk" ++ v)+        f = \x. g (lvl x)+    To achieve this we pass is_bot to destLevel++(2) We do not do this for lambdas that return+    bottom.  Instead we treat the /body/ of such a function specially,+    via point (1).  For example:+        f = \x. ....(\y z. if x then error y else error z)....+    ===>+        lvl = \x z y. if b then error y else error z+        f = \x. ...(\y z. lvl x z y)...+    (There is no guarantee that we'll choose the perfect argument order.)++(3) If we have a /binding/ that returns bottom, we want to float it to top+    level, even if it has free vars (point (1)), and even it has lambdas.+    Example:+       ... let { v = \y. error (show x ++ show y) } in ...+    We want to abstract over x and float the whole thing to top:+       lvl = \xy. errror (show x ++ show y)+       ...let {v = lvl x} in ...++    Then of course we don't want to separately float the body (error ...)+    as /another/ MFE, so we tell lvlFloatRhs not to do that, via the is_bot+    argument.++See Maessen's paper 1999 "Bottom extraction: factoring error handling out+of functional programs" (unpublished I think).++When we do this, we set the strictness and arity of the new bottoming+Id, *immediately*, for three reasons:++  * To prevent the abstracted thing being immediately inlined back in again+    via preInlineUnconditionally.  The latter has a test for bottoming Ids+    to stop inlining them, so we'd better make sure it *is* a bottoming Id!++  * So that it's properly exposed as such in the interface file, even if+    this is all happening after strictness analysis.++  * In case we do CSE with the same expression that *is* marked bottom+        lvl          = error "urk"+          x{str=bot) = error "urk"+    Here we don't want to replace 'x' with 'lvl', else we may get Lint+    errors, e.g. via a case with empty alternatives:  (case x of {})+    Lint complains unless the scrutinee of such a case is clearly bottom.++    This was reported in Trac #11290.   But since the whole bottoming-float+    thing is based on the cheap-and-cheerful exprIsBottom, I'm not sure+    that it'll nail all such cases.++Note [Bottoming floats: eta expansion] c.f Note [Bottoming floats]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Tiresomely, though, the simplifier has an invariant that the manifest+arity of the RHS should be the same as the arity; but we can't call+etaExpand during SetLevels because it works over a decorated form of+CoreExpr.  So we do the eta expansion later, in FloatOut.++Note [Case MFEs]+~~~~~~~~~~~~~~~~+We don't float a case expression as an MFE from a strict context.  Why not?+Because in doing so we share a tiny bit of computation (the switch) but+in exchange we build a thunk, which is bad.  This case reduces allocation+by 7% in spectral/puzzle (a rather strange benchmark) and 1.2% in real/fem.+Doesn't change any other allocation at all.++We will make a separate decision for the scrutinees and alternatives.+-}++annotateBotStr :: Id -> Arity -> Maybe (Arity, StrictSig) -> Id+-- See Note [Bottoming floats] for why we want to add+-- bottoming information right now+--+-- n_extra are the number of extra value arguments added during floating+annotateBotStr id n_extra mb_str+  = case mb_str of+      Nothing           -> id+      Just (arity, sig) -> id `setIdArity`      (arity + n_extra)+                              `setIdStrictness` (increaseStrictSigArity n_extra sig)++notWorthFloating :: CoreExpr -> [Var] -> Bool+-- Returns True if the expression would be replaced by+-- something bigger than it is now.  For example:+--   abs_vars = tvars only:  return True if e is trivial,+--                           but False for anything bigger+--   abs_vars = [x] (an Id): return True for trivial, or an application (f x)+--                           but False for (f x x)+--+-- One big goal is that floating should be idempotent.  Eg if+-- we replace e with (lvl79 x y) and then run FloatOut again, don't want+-- to replace (lvl79 x y) with (lvl83 x y)!++notWorthFloating e abs_vars+  = go e (count isId abs_vars)+  where+    go (Var {}) n    = n >= 0+    go (Lit lit) n   = ASSERT( n==0 )+                       litIsTrivial lit   -- Note [Floating literals]+    go (Tick t e) n  = not (tickishIsCode t) && go e n+    go (Cast e _)  n = go e n+    go (App e arg) n+       | Type {}     <- arg = go e n+       | Coercion {} <- arg = go e n+       | n==0               = False+       | is_triv arg        = go e (n-1)+       | otherwise          = False+    go _ _                  = False++    is_triv (Lit {})              = True        -- Treat all literals as trivial+    is_triv (Var {})              = True        -- (ie not worth floating)+    is_triv (Cast e _)            = is_triv e+    is_triv (App e (Type {}))     = is_triv e+    is_triv (App e (Coercion {})) = is_triv e+    is_triv (Tick t e)            = not (tickishIsCode t) && is_triv e+    is_triv _                     = False++{-+Note [Floating literals]+~~~~~~~~~~~~~~~~~~~~~~~~+It's important to float Integer literals, so that they get shared,+rather than being allocated every time round the loop.+Hence the litIsTrivial.++Ditto literal strings (MachStr), which we'd like to float to top+level, which is now possible.+++Note [Escaping a value lambda]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to float even cheap expressions out of value lambdas,+because that saves allocation.  Consider+        f = \x.  .. (\y.e) ...+Then we'd like to avoid allocating the (\y.e) every time we call f,+(assuming e does not mention x). An example where this really makes a+difference is simplrun009.++Another reason it's good is because it makes SpecContr fire on functions.+Consider+        f = \x. ....(f (\y.e))....+After floating we get+        lvl = \y.e+        f = \x. ....(f lvl)...+and that is much easier for SpecConstr to generate a robust+specialisation for.++However, if we are wrapping the thing in extra value lambdas (in+abs_vars), then nothing is saved.  E.g.+        f = \xyz. ...(e1[y],e2)....+If we float+        lvl = \y. (e1[y],e2)+        f = \xyz. ...(lvl y)...+we have saved nothing: one pair will still be allocated for each+call of 'f'.  Hence the (not float_is_lam) in float_me.+++************************************************************************+*                                                                      *+\subsection{Bindings}+*                                                                      *+************************************************************************++The binding stuff works for top level too.+-}++lvlBind :: LevelEnv+        -> CoreBindWithFVs+        -> LvlM (LevelledBind, LevelEnv)++lvlBind env (AnnNonRec bndr rhs)+  | isTyVar bndr    -- Don't do anything for TyVar binders+                    --   (simplifier gets rid of them pronto)+  || isCoVar bndr   -- Difficult to fix up CoVar occurrences (see extendPolyLvlEnv)+                    -- so we will ignore this case for now+  || not (profitableFloat env dest_lvl)+  || (isTopLvl dest_lvl && isUnliftedType (idType bndr))+          -- We can't float an unlifted binding to top level, so we don't+          -- float it at all.  It's a bit brutal, but unlifted bindings+          -- aren't expensive either++  = -- No float+    do { rhs' <- lvlRhs env NonRecursive is_bot mb_join_arity rhs+       ; let  bind_lvl        = incMinorLvl (le_ctxt_lvl env)+              (env', [bndr']) = substAndLvlBndrs NonRecursive env bind_lvl [bndr]+       ; return (NonRec bndr' rhs', env') }++  -- Otherwise we are going to float+  | null abs_vars+  = do {  -- No type abstraction; clone existing binder+         rhs' <- lvlFloatRhs [] dest_lvl env NonRecursive+                             is_bot mb_join_arity rhs+       ; (env', [bndr']) <- cloneLetVars NonRecursive env dest_lvl [bndr]+       ; let bndr2 = annotateBotStr bndr' 0 mb_bot_str+       ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }++  | otherwise+  = do {  -- Yes, type abstraction; create a new binder, extend substitution, etc+         rhs' <- lvlFloatRhs abs_vars dest_lvl env NonRecursive+                             is_bot mb_join_arity rhs+       ; (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr]+       ; let bndr2 = annotateBotStr bndr' n_extra mb_bot_str+       ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }++  where+    rhs_fvs    = freeVarsOf rhs+    bind_fvs   = rhs_fvs `unionDVarSet` dIdFreeVars bndr+    abs_vars   = abstractVars dest_lvl env bind_fvs+    dest_lvl   = destLevel env bind_fvs (isFunction rhs) is_bot is_join++    mb_bot_str = exprBotStrictness_maybe (deAnnotate rhs)+    is_bot     = isJust mb_bot_str+        -- NB: not isBottomThunk!  See Note [Bottoming floats] point (3)++    n_extra    = count isId abs_vars+    mb_join_arity = isJoinId_maybe bndr+    is_join       = isJust mb_join_arity++lvlBind env (AnnRec pairs)+  |  floatTopLvlOnly env && not (isTopLvl dest_lvl)+         -- Only floating to the top level is allowed.+  || not (profitableFloat env dest_lvl)+  = do { let bind_lvl       = incMinorLvl (le_ctxt_lvl env)+             (env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs+             lvl_rhs (b,r)  = lvlRhs env' Recursive is_bot (isJoinId_maybe b) r+       ; rhss' <- mapM lvl_rhs pairs+       ; return (Rec (bndrs' `zip` rhss'), env') }++  | null abs_vars+  = do { (new_env, new_bndrs) <- cloneLetVars Recursive env dest_lvl bndrs+       ; new_rhss <- mapM (do_rhs new_env) pairs+       ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss)+                , new_env) }++-- ToDo: when enabling the floatLambda stuff,+--       I think we want to stop doing this+  | [(bndr,rhs)] <- pairs+  , count isId abs_vars > 1+  = do  -- Special case for self recursion where there are+        -- several variables carried around: build a local loop:+        --      poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars+        -- This just makes the closures a bit smaller.  If we don't do+        -- this, allocation rises significantly on some programs+        --+        -- We could elaborate it for the case where there are several+        -- mutually functions, but it's quite a bit more complicated+        --+        -- This all seems a bit ad hoc -- sigh+    let (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars+        rhs_lvl = le_ctxt_lvl rhs_env++    (rhs_env', [new_bndr]) <- cloneLetVars Recursive rhs_env rhs_lvl [bndr]+    let+        (lam_bndrs, rhs_body)   = collectAnnBndrs rhs+        (body_env1, lam_bndrs1) = substBndrsSL NonRecursive rhs_env' lam_bndrs+        (body_env2, lam_bndrs2) = lvlLamBndrs body_env1 rhs_lvl lam_bndrs1+    new_rhs_body <- lvlRhs body_env2 Recursive is_bot (get_join bndr) rhs_body+    (poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env abs_vars [bndr]+    return (Rec [(TB poly_bndr (FloatMe dest_lvl)+                 , mkLams abs_vars_w_lvls $+                   mkLams lam_bndrs2 $+                   Let (Rec [( TB new_bndr (StayPut rhs_lvl)+                             , mkLams lam_bndrs2 new_rhs_body)])+                       (mkVarApps (Var new_bndr) lam_bndrs1))]+           , poly_env)++  | otherwise  -- Non-null abs_vars+  = do { (new_env, new_bndrs) <- newPolyBndrs dest_lvl env abs_vars bndrs+       ; new_rhss <- mapM (do_rhs new_env) pairs+       ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss)+                , new_env) }++  where+    (bndrs,rhss) = unzip pairs+    is_join  = isJoinId (head bndrs)+                -- bndrs is always non-empty and if one is a join they all are+                -- Both are checked by Lint+    is_fun   = all isFunction rhss+    is_bot   = False  -- It's odd to have an unconditionally divergent+                      -- function in a Rec, and we don't much care what+                      -- happens to it.  False is simple!++    do_rhs env (bndr,rhs) = lvlFloatRhs abs_vars dest_lvl env Recursive+                                        is_bot (get_join bndr)+                                        rhs++    get_join bndr | need_zap  = Nothing+                  | otherwise = isJoinId_maybe bndr+    need_zap = dest_lvl `ltLvl` joinCeilingLevel env++        -- Finding the free vars of the binding group is annoying+    bind_fvs = ((unionDVarSets [ freeVarsOf rhs | (_, rhs) <- pairs])+                `unionDVarSet`+                (fvDVarSet $ unionsFV [ idFVs bndr+                                      | (bndr, (_,_)) <- pairs]))+               `delDVarSetList`+                bndrs++    dest_lvl = destLevel env bind_fvs is_fun is_bot is_join+    abs_vars = abstractVars dest_lvl env bind_fvs++profitableFloat :: LevelEnv -> Level -> Bool+profitableFloat env dest_lvl+  =  (dest_lvl `ltMajLvl` le_ctxt_lvl env)  -- Escapes a value lambda+  || isTopLvl dest_lvl                      -- Going all the way to top level+++----------------------------------------------------+-- Three help functions for the type-abstraction case++lvlRhs :: LevelEnv+       -> RecFlag+       -> Bool               -- Is this a bottoming function+       -> Maybe JoinArity+       -> CoreExprWithFVs+       -> LvlM LevelledExpr+lvlRhs env rec_flag is_bot mb_join_arity expr+  = lvlFloatRhs [] (le_ctxt_lvl env) env+                rec_flag is_bot mb_join_arity expr++lvlFloatRhs :: [OutVar] -> Level -> LevelEnv -> RecFlag+            -> Bool   -- Binding is for a bottoming function+            -> Maybe JoinArity+            -> CoreExprWithFVs+            -> LvlM (Expr LevelledBndr)+-- Ignores the le_ctxt_lvl in env; treats dest_lvl as the baseline+lvlFloatRhs abs_vars dest_lvl env rec is_bot mb_join_arity rhs+  = do { body' <- if not is_bot  -- See Note [Floating from a RHS]+                     && any isId bndrs+                  then lvlMFE  body_env True body+                  else lvlExpr body_env      body+       ; return (mkLams bndrs' body') }+  where+    (bndrs, body)     | Just join_arity <- mb_join_arity+                      = collectNAnnBndrs join_arity rhs+                      | otherwise+                      = collectAnnBndrs rhs+    (env1, bndrs1)    = substBndrsSL NonRecursive env bndrs+    all_bndrs         = abs_vars ++ bndrs1+    (body_env, bndrs') | Just _ <- mb_join_arity+                      = lvlJoinBndrs env1 dest_lvl rec all_bndrs+                      | otherwise+                      = case lvlLamBndrs env1 dest_lvl all_bndrs of+                          (env2, bndrs') -> (placeJoinCeiling env2, bndrs')+        -- The important thing here is that we call lvlLamBndrs on+        -- all these binders at once (abs_vars and bndrs), so they+        -- all get the same major level.  Otherwise we create stupid+        -- let-bindings inside, joyfully thinking they can float; but+        -- in the end they don't because we never float bindings in+        -- between lambdas++{- Note [Floating from a RHS]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When float the RHS of a let-binding, we don't always want to apply+lvlMFE to the body of a lambda, as we usually do, because the entire+binding body is already going to the right place (dest_lvl).++A particular example is the top level.  Consider+   concat = /\ a -> foldr ..a.. (++) []+We don't want to float the body of the lambda to get+   lvl    = /\ a -> foldr ..a.. (++) []+   concat = /\ a -> lvl a+That would be stupid.++Previously this was avoided in a much nastier way, by testing strict_ctxt+in float_me in lvlMFE.  But that wasn't even right because it would fail+to float out the error sub-expression in+    f = \x. case x of+              True  -> error ("blah" ++ show x)+              False -> ...++But we must be careful:++* If we had+    f = \x -> factorial 20+  we /would/ want to float that (factorial 20) out!  Functions are treated+  differently: see the use of isFunction in the calls to destLevel. If+  there are only type lambdas, then destLevel will say "go to top, and+  abstract over the free tyvars" and we don't want that here.++* But if we had+    f = \x -> error (...x....)+  we would NOT want to float the bottoming expression out to give+    lvl = \x -> error (...x...)+    f = \x -> lvl x++Conclusion: use lvlMFE if there are+  * any value lambdas in the original function, and+  * this is not a bottoming function (the is_bot argument)+Use lvlExpr otherwise.  A little subtle, and I got it wrong at least twice+(e.g. Trac #13369).+-}++{-+************************************************************************+*                                                                      *+\subsection{Deciding floatability}+*                                                                      *+************************************************************************+-}++substAndLvlBndrs :: RecFlag -> LevelEnv -> Level -> [InVar] -> (LevelEnv, [LevelledBndr])+substAndLvlBndrs is_rec env lvl bndrs+  = lvlBndrs subst_env lvl subst_bndrs+  where+    (subst_env, subst_bndrs) = substBndrsSL is_rec env bndrs++substBndrsSL :: RecFlag -> LevelEnv -> [InVar] -> (LevelEnv, [OutVar])+-- So named only to avoid the name clash with CoreSubst.substBndrs+substBndrsSL is_rec env@(LE { le_subst = subst, le_env = id_env }) bndrs+  = ( env { le_subst    = subst'+          , le_env      = foldl add_id  id_env (bndrs `zip` bndrs') }+    , bndrs')+  where+    (subst', bndrs') = case is_rec of+                         NonRecursive -> substBndrs    subst bndrs+                         Recursive    -> substRecBndrs subst bndrs++lvlLamBndrs :: LevelEnv -> Level -> [OutVar] -> (LevelEnv, [LevelledBndr])+-- Compute the levels for the binders of a lambda group+lvlLamBndrs env lvl bndrs+  = lvlBndrs env new_lvl bndrs+  where+    new_lvl | any is_major bndrs = incMajorLvl lvl+            | otherwise          = incMinorLvl lvl++    is_major bndr = isId bndr && not (isProbablyOneShotLambda bndr)+       -- The "probably" part says "don't float things out of a+       -- probable one-shot lambda"+       -- See Note [Computing one-shot info] in Demand.hs++lvlJoinBndrs :: LevelEnv -> Level -> RecFlag -> [OutVar]+             -> (LevelEnv, [LevelledBndr])+lvlJoinBndrs env lvl rec bndrs+  = lvlBndrs env new_lvl bndrs+  where+    new_lvl | isRec rec = incMajorLvl lvl+            | otherwise = incMinorLvl lvl+      -- Non-recursive join points are one-shot; recursive ones are not++lvlBndrs :: LevelEnv -> Level -> [CoreBndr] -> (LevelEnv, [LevelledBndr])+-- The binders returned are exactly the same as the ones passed,+-- apart from applying the substitution, but they are now paired+-- with a (StayPut level)+--+-- The returned envt has le_ctxt_lvl updated to the new_lvl+--+-- All the new binders get the same level, because+-- any floating binding is either going to float past+-- all or none.  We never separate binders.+lvlBndrs env@(LE { le_lvl_env = lvl_env }) new_lvl bndrs+  = ( env { le_ctxt_lvl = new_lvl+          , le_join_ceil = new_lvl+          , le_lvl_env  = addLvls new_lvl lvl_env bndrs }+    , map (stayPut new_lvl) bndrs)++stayPut :: Level -> OutVar -> LevelledBndr+stayPut new_lvl bndr = TB bndr (StayPut new_lvl)++  -- Destination level is the max Id level of the expression+  -- (We'll abstract the type variables, if any.)+destLevel :: LevelEnv -> DVarSet+          -> Bool   -- True <=> is function+          -> Bool   -- True <=> is bottom+          -> Bool   -- True <=> is a join point+          -> Level+-- INVARIANT: if is_join=True then result >= join_ceiling+destLevel env fvs is_function is_bot is_join+  | isTopLvl max_fv_id_level  -- Float even joins if they get to top level+                              -- See Note [Floating join point bindings]+  = tOP_LEVEL++  | is_join  -- Never float a join point past the join ceiling+             -- See Note [Join points] in FloatOut+  = if max_fv_id_level `ltLvl` join_ceiling+    then join_ceiling+    else max_fv_id_level++  | is_bot              -- Send bottoming bindings to the top+  = tOP_LEVEL           -- regardless; see Note [Bottoming floats]+                        -- Esp Bottoming floats (1)++  | Just n_args <- floatLams env+  , n_args > 0  -- n=0 case handled uniformly by the 'otherwise' case+  , is_function+  , countFreeIds fvs <= n_args+  = tOP_LEVEL   -- Send functions to top level; see+                -- the comments with isFunction++  | otherwise = max_fv_id_level+  where+    max_fv_id_level = maxFvLevel isId env fvs -- Max over Ids only; the tyvars+                                              -- will be abstracted+    join_ceiling = joinCeilingLevel env++isFunction :: CoreExprWithFVs -> Bool+-- The idea here is that we want to float *functions* to+-- the top level.  This saves no work, but+--      (a) it can make the host function body a lot smaller,+--              and hence inlinable.+--      (b) it can also save allocation when the function is recursive:+--          h = \x -> letrec f = \y -> ...f...y...x...+--                    in f x+--     becomes+--          f = \x y -> ...(f x)...y...x...+--          h = \x -> f x x+--     No allocation for f now.+-- We may only want to do this if there are sufficiently few free+-- variables.  We certainly only want to do it for values, and not for+-- constructors.  So the simple thing is just to look for lambdas+isFunction (_, AnnLam b e) | isId b    = True+                           | otherwise = isFunction e+-- isFunction (_, AnnTick _ e)         = isFunction e  -- dubious+isFunction _                           = False++countFreeIds :: DVarSet -> Int+countFreeIds = nonDetFoldUDFM add 0+  -- It's OK to use nonDetFoldUDFM here because we're just counting things.+  where+    add :: Var -> Int -> Int+    add v n | isId v    = n+1+            | otherwise = n++{-+************************************************************************+*                                                                      *+\subsection{Free-To-Level Monad}+*                                                                      *+************************************************************************+-}++data LevelEnv+  = LE { le_switches :: FloatOutSwitches+       , le_ctxt_lvl :: Level           -- The current level+       , le_lvl_env  :: VarEnv Level    -- Domain is *post-cloned* TyVars and Ids+       , le_join_ceil:: Level           -- Highest level to which joins float+                                        -- Invariant: always >= le_ctxt_lvl++       -- See Note [le_subst and le_env]+       , le_subst    :: Subst           -- Domain is pre-cloned TyVars and Ids+                                        -- The Id -> CoreExpr in the Subst is ignored+                                        -- (since we want to substitute a LevelledExpr for+                                        -- an Id via le_env) but we do use the Co/TyVar substs+       , le_env      :: IdEnv ([OutVar], LevelledExpr)  -- Domain is pre-cloned Ids+    }++{- Note [le_subst and le_env]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We clone let- and case-bound variables so that they are still distinct+when floated out; hence the le_subst/le_env.  (see point 3 of the+module overview comment).  We also use these envs when making a+variable polymorphic because we want to float it out past a big+lambda.++The le_subst and le_env always implement the same mapping,+     in_x :->  out_x a b+where out_x is an OutVar, and a,b are its arguments (when+we perform abstraction at the same time as floating).++  le_subst maps to CoreExpr+  le_env   maps to LevelledExpr++Since the range is always a variable or application, there is never+any difference between the two, but sadly the types differ.  The+le_subst is used when substituting in a variable's IdInfo; the le_env+when we find a Var.++In addition the le_env records a [OutVar] of variables free in the+OutExpr/LevelledExpr, just so we don't have to call freeVars+repeatedly.  This list is always non-empty, and the first element is+out_x++The domain of the both envs is *pre-cloned* Ids, though++The domain of the le_lvl_env is the *post-cloned* Ids+-}++initialEnv :: FloatOutSwitches -> LevelEnv+initialEnv float_lams+  = LE { le_switches = float_lams+       , le_ctxt_lvl = tOP_LEVEL+       , le_join_ceil = panic "initialEnv"+       , le_lvl_env = emptyVarEnv+       , le_subst = emptySubst+       , le_env = emptyVarEnv }++addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level+addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl++addLvls :: Level -> VarEnv Level -> [OutVar] -> VarEnv Level+addLvls dest_lvl env vs = foldl (addLvl dest_lvl) env vs++floatLams :: LevelEnv -> Maybe Int+floatLams le = floatOutLambdas (le_switches le)++floatConsts :: LevelEnv -> Bool+floatConsts le = floatOutConstants (le_switches le)++floatOverSat :: LevelEnv -> Bool+floatOverSat le = floatOutOverSatApps (le_switches le)++floatTopLvlOnly :: LevelEnv -> Bool+floatTopLvlOnly le = floatToTopLevelOnly (le_switches le)++incMinorLvlFrom :: LevelEnv -> Level+incMinorLvlFrom env = incMinorLvl (le_ctxt_lvl env)++-- extendCaseBndrEnv adds the mapping case-bndr->scrut-var if it can+-- See Note [Binder-swap during float-out]+extendCaseBndrEnv :: LevelEnv+                  -> Id                 -- Pre-cloned case binder+                  -> Expr LevelledBndr  -- Post-cloned scrutinee+                  -> LevelEnv+extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env })+                  case_bndr (Var scrut_var)+  = le { le_subst   = extendSubstWithVar subst case_bndr scrut_var+       , le_env     = add_id id_env (case_bndr, scrut_var) }+extendCaseBndrEnv env _ _ = env++-- See Note [Join ceiling]+placeJoinCeiling :: LevelEnv -> LevelEnv+placeJoinCeiling le@(LE { le_ctxt_lvl = lvl })+  = le { le_ctxt_lvl = lvl', le_join_ceil = lvl' }+  where+    lvl' = asJoinCeilLvl (incMinorLvl lvl)++maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level+maxFvLevel max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) var_set+  = foldDVarSet max_in tOP_LEVEL var_set+  where+    max_in in_var lvl+       = foldr max_out lvl (case lookupVarEnv id_env in_var of+                                Just (abs_vars, _) -> abs_vars+                                Nothing            -> [in_var])++    max_out out_var lvl+        | max_me out_var = case lookupVarEnv lvl_env out_var of+                                Just lvl' -> maxLvl lvl' lvl+                                Nothing   -> lvl+        | otherwise = lvl       -- Ignore some vars depending on max_me++lookupVar :: LevelEnv -> Id -> LevelledExpr+lookupVar le v = case lookupVarEnv (le_env le) v of+                    Just (_, expr) -> expr+                    _              -> Var v++-- Level to which join points are allowed to float (boundary of current tail+-- context). See Note [Join ceiling]+joinCeilingLevel :: LevelEnv -> Level+joinCeilingLevel = le_join_ceil++abstractVars :: Level -> LevelEnv -> DVarSet -> [OutVar]+        -- Find the variables in fvs, free vars of the target expression,+        -- whose level is greater than the destination level+        -- These are the ones we are going to abstract out+        --+        -- Note that to get reproducible builds, the variables need to be+        -- abstracted in deterministic order, not dependent on the values of+        -- Uniques. This is achieved by using DVarSets, deterministic free+        -- variable computation and deterministic sort.+        -- See Note [Unique Determinism] in Unique for explanation of why+        -- Uniques are not deterministic.+abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs+  =  -- NB: sortQuantVars might not put duplicates next to each other+    map zap $ sortQuantVars $ uniq+    [out_var | out_fv  <- dVarSetElems (substDVarSet subst in_fvs)+             , out_var <- dVarSetElems (close out_fv)+             , abstract_me out_var ]+        -- NB: it's important to call abstract_me only on the OutIds the+        -- come from substDVarSet (not on fv, which is an InId)+  where+    uniq :: [Var] -> [Var]+        -- Remove duplicates, preserving order+    uniq = dVarSetElems . mkDVarSet++    abstract_me v = case lookupVarEnv lvl_env v of+                        Just lvl -> dest_lvl `ltLvl` lvl+                        Nothing  -> False++        -- We are going to lambda-abstract, so nuke any IdInfo,+        -- and add the tyvars of the Id (if necessary)+    zap v | isId v = WARN( isStableUnfolding (idUnfolding v) ||+                           not (isEmptyRuleInfo (idSpecialisation v)),+                           text "absVarsOf: discarding info on" <+> ppr v )+                     setIdInfo v vanillaIdInfo+          | otherwise = v++    close :: Var -> DVarSet  -- Close over variables free in the type+                             -- Result includes the input variable itself+    close v = foldDVarSet (unionDVarSet . close)+                          (unitDVarSet v)+                          (fvDVarSet $ varTypeTyCoFVs v)++type LvlM result = UniqSM result++initLvl :: UniqSupply -> UniqSM a -> a+initLvl = initUs_++newPolyBndrs :: Level -> LevelEnv -> [OutVar] -> [InId]+             -> LvlM (LevelEnv, [OutId])+-- The envt is extended to bind the new bndrs to dest_lvl, but+-- the le_ctxt_lvl is unaffected+newPolyBndrs dest_lvl+             env@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env })+             abs_vars bndrs+ = ASSERT( all (not . isCoVar) bndrs )   -- What would we add to the CoSubst in this case. No easy answer.+   do { uniqs <- getUniquesM+      ; let new_bndrs = zipWith mk_poly_bndr bndrs uniqs+            bndr_prs  = bndrs `zip` new_bndrs+            env' = env { le_lvl_env = addLvls dest_lvl lvl_env new_bndrs+                       , le_subst   = foldl add_subst subst   bndr_prs+                       , le_env     = foldl add_id    id_env  bndr_prs }+      ; return (env', new_bndrs) }+  where+    add_subst env (v, v') = extendIdSubst env v (mkVarApps (Var v') abs_vars)+    add_id    env (v, v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars)++    mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $         -- Note [transferPolyIdInfo] in Id.hs+                             transfer_join_info bndr $+                             mkSysLocalOrCoVar (mkFastString str) uniq poly_ty+                           where+                             str     = "poly_" ++ occNameString (getOccName bndr)+                             poly_ty = mkLamTypes abs_vars (CoreSubst.substTy subst (idType bndr))++    -- If we are floating a join point to top level, it stops being+    -- a join point.  Otherwise it continues to be a join point,+    -- but we may need to adjust its arity+    dest_is_top = isTopLvl dest_lvl+    transfer_join_info bndr new_bndr+      | Just join_arity <- isJoinId_maybe bndr+      , not dest_is_top+      = new_bndr `asJoinId` join_arity + length abs_vars+      | otherwise+      = new_bndr++newLvlVar :: LevelledExpr        -- The RHS of the new binding+          -> Maybe JoinArity     -- Its join arity, if it is a join point+          -> Bool                -- True <=> the RHS looks like (makeStatic ...)+          -> LvlM Id+newLvlVar lvld_rhs join_arity_maybe is_mk_static+  = do { uniq <- getUniqueM+       ; return (add_join_info (mk_id uniq rhs_ty))+       }+  where+    add_join_info var = var `asJoinId_maybe` join_arity_maybe+    de_tagged_rhs = deTagExpr lvld_rhs+    rhs_ty        = exprType de_tagged_rhs++    mk_id uniq rhs_ty+      -- See Note [Grand plan for static forms] in StaticPtrTable.+      | is_mk_static+      = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr"))+                            rhs_ty+      | otherwise+      = mkLocalIdOrCoVar (mkSystemVarName uniq (mkFastString "lvl")) rhs_ty++cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var])+cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })+               new_lvl vs+  = do { us <- getUniqueSupplyM+       ; let (subst', vs') = cloneBndrs subst us vs+             env' = env { le_ctxt_lvl  = new_lvl+                        , le_join_ceil = new_lvl+                        , le_lvl_env   = addLvls new_lvl lvl_env vs'+                        , le_subst     = subst'+                        , le_env       = foldl add_id id_env (vs `zip` vs') }++       ; return (env', vs') }++cloneLetVars :: RecFlag -> LevelEnv -> Level -> [InVar]+             -> LvlM (LevelEnv, [OutVar])+-- See Note [Need for cloning during float-out]+-- Works for Ids bound by let(rec)+-- The dest_lvl is attributed to the binders in the new env,+-- but cloneVars doesn't affect the le_ctxt_lvl of the incoming env+cloneLetVars is_rec+          env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })+          dest_lvl vs+  = do { us <- getUniqueSupplyM+       ; let vs1  = map zap vs+                      -- See Note [Zapping the demand info]+             (subst', vs2) = case is_rec of+                               NonRecursive -> cloneBndrs      subst us vs1+                               Recursive    -> cloneRecIdBndrs subst us vs1+             prs  = vs `zip` vs2+             env' = env { le_lvl_env = addLvls dest_lvl lvl_env vs2+                        , le_subst   = subst'+                        , le_env     = foldl add_id id_env prs }++       ; return (env', vs2) }+  where+    zap :: Var -> Var+    zap v | isId v    = zap_join (zapIdDemandInfo v)+          | otherwise = v++    zap_join | isTopLvl dest_lvl = zapJoinId+             | otherwise         = \v -> v++add_id :: IdEnv ([Var], LevelledExpr) -> (Var, Var) -> IdEnv ([Var], LevelledExpr)+add_id id_env (v, v1)+  | isTyVar v = delVarEnv    id_env v+  | otherwise = extendVarEnv id_env v ([v1], ASSERT(not (isCoVar v1)) Var v1)++{-+Note [Zapping the demand info]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+VERY IMPORTANT: we must zap the demand info if the thing is going to+float out, because it may be less demanded than at its original+binding site.  Eg+   f :: Int -> Int+   f x = let v = 3*4 in v+x+Here v is strict; but if we float v to top level, it isn't any more.++Similarly, if we're floating a join point, it won't be one anymore, so we zap+join point information as well.+-}
+ simplCore/SimplCore.hs view
@@ -0,0 +1,1061 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[SimplCore]{Driver for simplifying @Core@ programs}+-}++{-# LANGUAGE CPP #-}++module SimplCore ( core2core, simplifyExpr ) where++#include "HsVersions.h"++import DynFlags+import CoreSyn+import HscTypes+import CSE              ( cseProgram )+import Rules            ( mkRuleBase, unionRuleBase,+                          extendRuleBaseList, ruleCheckProgram, addRuleInfo, )+import PprCore          ( pprCoreBindings, pprCoreExpr )+import OccurAnal        ( occurAnalysePgm, occurAnalyseExpr )+import IdInfo+import CoreStats        ( coreBindsSize, coreBindsStats, exprSize )+import CoreUtils        ( mkTicks, stripTicksTop )+import CoreLint         ( endPass, lintPassResult, dumpPassResult,+                          lintAnnots )+import Simplify         ( simplTopBinds, simplExpr, simplRules )+import SimplUtils       ( simplEnvForGHCi, activeRule )+import SimplEnv+import SimplMonad+import CoreMonad+import qualified ErrUtils as Err+import FloatIn          ( floatInwards )+import FloatOut         ( floatOutwards )+import FamInstEnv+import Id+import ErrUtils         ( withTiming )+import BasicTypes       ( CompilerPhase(..), isDefaultInlinePragma )+import VarSet+import VarEnv+import LiberateCase     ( liberateCase )+import SAT              ( doStaticArgs )+import Specialise       ( specProgram)+import SpecConstr       ( specConstrProgram)+import DmdAnal          ( dmdAnalProgram )+import CallArity        ( callArityAnalProgram )+import WorkWrap         ( wwTopBinds )+import Vectorise        ( vectorise )+import SrcLoc+import Util+import Module++import Maybes+import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )+import UniqFM+import Outputable+import Control.Monad+import qualified GHC.LanguageExtensions as LangExt++#ifdef GHCI+import DynamicLoading   ( loadPlugins )+import Plugins          ( installCoreToDos )+#else+import DynamicLoading   ( pluginError )+#endif++{-+************************************************************************+*                                                                      *+\subsection{The driver for the simplifier}+*                                                                      *+************************************************************************+-}++core2core :: HscEnv -> ModGuts -> IO ModGuts+core2core hsc_env guts@(ModGuts { mg_module  = mod+                                , mg_loc     = loc+                                , mg_deps    = deps+                                , mg_rdr_env = rdr_env })+  = do { us <- mkSplitUniqSupply 's'+       -- make sure all plugins are loaded++       ; let builtin_passes = getCoreToDo dflags+             orph_mods = mkModuleSet (mod : dep_orphs deps)+       ;+       ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod+                                    orph_mods print_unqual loc $+                           do { all_passes <- addPluginPasses builtin_passes+                              ; runCorePasses all_passes guts }++       ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats+             "Grand total simplifier statistics"+             (pprSimplCount stats)++       ; return guts2 }+  where+    dflags         = hsc_dflags hsc_env+    home_pkg_rules = hptRules hsc_env (dep_mods deps)+    hpt_rule_base  = mkRuleBase home_pkg_rules+    print_unqual   = mkPrintUnqualified dflags rdr_env+    -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.+    -- This is very convienent for the users of the monad (e.g. plugins do not have to+    -- consume the ModGuts to find the module) but somewhat ugly because mg_module may+    -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which+    -- would mean our cached value would go out of date.++{-+************************************************************************+*                                                                      *+           Generating the main optimisation pipeline+*                                                                      *+************************************************************************+-}++getCoreToDo :: DynFlags -> [CoreToDo]+getCoreToDo dflags+  = flatten_todos core_todo+  where+    opt_level     = optLevel           dflags+    phases        = simplPhases        dflags+    max_iter      = maxSimplIterations dflags+    rule_check    = ruleCheck          dflags+    call_arity    = gopt Opt_CallArity                    dflags+    strictness    = gopt Opt_Strictness                   dflags+    full_laziness = gopt Opt_FullLaziness                 dflags+    do_specialise = gopt Opt_Specialise                   dflags+    do_float_in   = gopt Opt_FloatIn                      dflags+    cse           = gopt Opt_CSE                          dflags+    spec_constr   = gopt Opt_SpecConstr                   dflags+    liberate_case = gopt Opt_LiberateCase                 dflags+    late_dmd_anal = gopt Opt_LateDmdAnal                  dflags+    static_args   = gopt Opt_StaticArgumentTransformation dflags+    rules_on      = gopt Opt_EnableRewriteRules           dflags+    eta_expand_on = gopt Opt_DoLambdaEtaExpansion         dflags+    ww_on         = gopt Opt_WorkerWrapper                dflags+    vectorise_on  = gopt Opt_Vectorise                    dflags+    static_ptrs   = xopt LangExt.StaticPointers           dflags++    maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)++    maybe_strictness_before phase+      = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness++    base_mode = SimplMode { sm_phase      = panic "base_mode"+                          , sm_names      = []+                          , sm_rules      = rules_on+                          , sm_eta_expand = eta_expand_on+                          , sm_inline     = True+                          , sm_case_case  = True }++    simpl_phase phase names iter+      = CoreDoPasses+      $   [ maybe_strictness_before phase+          , CoreDoSimplify iter+                (base_mode { sm_phase = Phase phase+                           , sm_names = names })++          , maybe_rule_check (Phase phase) ]++          -- Vectorisation can introduce a fair few common sub expressions involving+          --  DPH primitives. For example, see the Reverse test from dph-examples.+          --  We need to eliminate these common sub expressions before their definitions+          --  are inlined in phase 2. The CSE introduces lots of  v1 = v2 bindings,+          --  so we also run simpl_gently to inline them.+      ++  (if vectorise_on && phase == 3+            then [CoreCSE, simpl_gently]+            else [])++    vectorisation+      = runWhen vectorise_on $+          CoreDoPasses [ simpl_gently, CoreDoVectorisation ]++                -- By default, we have 2 phases before phase 0.++                -- Want to run with inline phase 2 after the specialiser to give+                -- maximum chance for fusion to work before we inline build/augment+                -- in phase 1.  This made a difference in 'ansi' where an+                -- overloaded function wasn't inlined till too late.++                -- Need phase 1 so that build/augment get+                -- inlined.  I found that spectral/hartel/genfft lost some useful+                -- strictness in the function sumcode' if augment is not inlined+                -- before strictness analysis runs+    simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter+                                | phase <- [phases, phases-1 .. 1] ]+++        -- initial simplify: mk specialiser happy: minimum effort please+    simpl_gently = CoreDoSimplify max_iter+                       (base_mode { sm_phase = InitialPhase+                                  , sm_names = ["Gentle"]+                                  , sm_rules = rules_on   -- Note [RULEs enabled in SimplGently]+                                  , sm_inline = not vectorise_on+                                              -- See Note [Inline in InitialPhase]+                                  , sm_case_case = False })+                          -- Don't do case-of-case transformations.+                          -- This makes full laziness work better++    strictness_pass = if ww_on+                       then [CoreDoStrictness,CoreDoWorkerWrapper]+                       else [CoreDoStrictness]+++    -- New demand analyser+    demand_analyser = (CoreDoPasses (+                           strictness_pass +++                           [simpl_phase 0 ["post-worker-wrapper"] max_iter]+                           ))++    -- Static forms are moved to the top level with the FloatOut pass.+    -- See Note [Grand plan for static forms] in StaticPtrTable.+    static_ptrs_float_outwards =+      runWhen static_ptrs $ CoreDoPasses+        [ simpl_gently -- Float Out can't handle type lets (sometimes created+                       -- by simpleOptPgm via mkParallelBindings)+        , CoreDoFloatOutwards FloatOutSwitches+          { floatOutLambdas   = Just 0+          , floatOutConstants = True+          , floatOutOverSatApps = False+          , floatToTopLevelOnly = True+          }+        ]++    core_todo =+     if opt_level == 0 then+       [ vectorisation,+         static_ptrs_float_outwards,+         CoreDoSimplify max_iter+             (base_mode { sm_phase = Phase 0+                        , sm_names = ["Non-opt simplification"] })+       ]++     else {- opt_level >= 1 -} [++    -- We want to do the static argument transform before full laziness as it+    -- may expose extra opportunities to float things outwards. However, to fix+    -- up the output of the transformation we need at do at least one simplify+    -- after this before anything else+        runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),++        -- We run vectorisation here for now, but we might also try to run+        -- it later+        vectorisation,++        -- initial simplify: mk specialiser happy: minimum effort please+        simpl_gently,++        -- Specialisation is best done before full laziness+        -- so that overloaded functions have all their dictionary lambdas manifest+        runWhen do_specialise CoreDoSpecialising,++        if full_laziness then+           CoreDoFloatOutwards FloatOutSwitches {+                                 floatOutLambdas   = Just 0,+                                 floatOutConstants = True,+                                 floatOutOverSatApps = False,+                                 floatToTopLevelOnly = False }+                -- Was: gentleFloatOutSwitches+                --+                -- I have no idea why, but not floating constants to+                -- top level is very bad in some cases.+                --+                -- Notably: p_ident in spectral/rewrite+                --          Changing from "gentle" to "constantsOnly"+                --          improved rewrite's allocation by 19%, and+                --          made 0.0% difference to any other nofib+                --          benchmark+                --+                -- Not doing floatOutOverSatApps yet, we'll do+                -- that later on when we've had a chance to get more+                -- accurate arity information.  In fact it makes no+                -- difference at all to performance if we do it here,+                -- but maybe we save some unnecessary to-and-fro in+                -- the simplifier.+        else+           -- Even with full laziness turned off, we still need to float static+           -- forms to the top level. See Note [Grand plan for static forms] in+           -- StaticPtrTable.+           static_ptrs_float_outwards,++        simpl_phases,++                -- Phase 0: allow all Ids to be inlined now+                -- This gets foldr inlined before strictness analysis++                -- At least 3 iterations because otherwise we land up with+                -- huge dead expressions because of an infelicity in the+                -- simpifier.+                --      let k = BIG in foldr k z xs+                -- ==>  let k = BIG in letrec go = \xs -> ...(k x).... in go xs+                -- ==>  let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs+                -- Don't stop now!+        simpl_phase 0 ["main"] (max max_iter 3),++        runWhen do_float_in CoreDoFloatInwards,+            -- Run float-inwards immediately before the strictness analyser+            -- Doing so pushes bindings nearer their use site and hence makes+            -- them more likely to be strict. These bindings might only show+            -- up after the inlining from simplification.  Example in fulsom,+            -- Csg.calc, where an arg of timesDouble thereby becomes strict.++        runWhen call_arity $ CoreDoPasses+            [ CoreDoCallArity+            , simpl_phase 0 ["post-call-arity"] max_iter+            ],++        runWhen strictness demand_analyser,++        runWhen full_laziness $+           CoreDoFloatOutwards FloatOutSwitches {+                                 floatOutLambdas     = floatLamArgs dflags,+                                 floatOutConstants   = True,+                                 floatOutOverSatApps = True,+                                 floatToTopLevelOnly = False },+                -- nofib/spectral/hartel/wang doubles in speed if you+                -- do full laziness late in the day.  It only happens+                -- after fusion and other stuff, so the early pass doesn't+                -- catch it.  For the record, the redex is+                --        f_el22 (f_el21 r_midblock)+++        runWhen cse CoreCSE,+                -- We want CSE to follow the final full-laziness pass, because it may+                -- succeed in commoning up things floated out by full laziness.+                -- CSE used to rely on the no-shadowing invariant, but it doesn't any more++        runWhen do_float_in CoreDoFloatInwards,++        maybe_rule_check (Phase 0),++                -- Case-liberation for -O2.  This should be after+                -- strictness analysis and the simplification which follows it.+        runWhen liberate_case (CoreDoPasses [+            CoreLiberateCase,+            simpl_phase 0 ["post-liberate-case"] max_iter+            ]),         -- Run the simplifier after LiberateCase to vastly+                        -- reduce the possibility of shadowing+                        -- Reason: see Note [Shadowing] in SpecConstr.hs++        runWhen spec_constr CoreDoSpecConstr,++        maybe_rule_check (Phase 0),++        -- Final clean-up simplification:+        simpl_phase 0 ["final"] max_iter,++        runWhen late_dmd_anal $ CoreDoPasses (+            strictness_pass +++            [simpl_phase 0 ["post-late-ww"] max_iter]+          ),++        -- Final run of the demand_analyser, ensures that one-shot thunks are+        -- really really one-shot thunks. Only needed if the demand analyser+        -- has run at all. See Note [Final Demand Analyser run] in DmdAnal+        -- It is EXTREMELY IMPORTANT to run this pass, otherwise execution+        -- can become /exponentially/ more expensive. See Trac #11731, #12996.+        runWhen (strictness || late_dmd_anal) CoreDoStrictness,++        maybe_rule_check (Phase 0)+     ]++    -- Remove 'CoreDoNothing' and flatten 'CoreDoPasses' for clarity.+    flatten_todos [] = []+    flatten_todos (CoreDoNothing : rest) = flatten_todos rest+    flatten_todos (CoreDoPasses passes : rest) =+      flatten_todos passes ++ flatten_todos rest+    flatten_todos (todo : rest) = todo : flatten_todos rest++-- Loading plugins++addPluginPasses :: [CoreToDo] -> CoreM [CoreToDo]+#ifndef GHCI+addPluginPasses builtin_passes+  = do { dflags <- getDynFlags+       ; let pluginMods = pluginModNames dflags+       ; unless (null pluginMods) (pluginError pluginMods)+       ; return builtin_passes }+#else+addPluginPasses builtin_passes+  = do { hsc_env <- getHscEnv+       ; named_plugins <- liftIO (loadPlugins hsc_env)+       ; foldM query_plug builtin_passes named_plugins }+  where+    query_plug todos (_, plug, options) = installCoreToDos plug options todos+#endif++{- Note [Inline in InitialPhase]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In GHC 8 and earlier we did not inline anything in the InitialPhase. But that is+confusing for users because when they say INLINE they expect the function to inline+right away.++So now we do inlining immediately, even in the InitialPhase, assuming that the+Id's Activation allows it.++This is a surprisingly big deal. Compiler performance improved a lot+when I made this change:++   perf/compiler/T5837.run            T5837 [stat too good] (normal)+   perf/compiler/parsing001.run       parsing001 [stat too good] (normal)+   perf/compiler/T12234.run           T12234 [stat too good] (optasm)+   perf/compiler/T9020.run            T9020 [stat too good] (optasm)+   perf/compiler/T3064.run            T3064 [stat too good] (normal)+   perf/compiler/T9961.run            T9961 [stat too good] (normal)+   perf/compiler/T13056.run           T13056 [stat too good] (optasm)+   perf/compiler/T9872d.run           T9872d [stat too good] (normal)+   perf/compiler/T783.run             T783 [stat too good] (normal)+   perf/compiler/T12227.run           T12227 [stat too good] (normal)+   perf/should_run/lazy-bs-alloc.run  lazy-bs-alloc [stat too good] (normal)+   perf/compiler/T1969.run            T1969 [stat too good] (normal)+   perf/compiler/T9872a.run           T9872a [stat too good] (normal)+   perf/compiler/T9872c.run           T9872c [stat too good] (normal)+   perf/compiler/T9872b.run           T9872b [stat too good] (normal)+   perf/compiler/T9872d.run           T9872d [stat too good] (normal)++Note [RULEs enabled in SimplGently]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+RULES are enabled when doing "gentle" simplification.  Two reasons:++  * We really want the class-op cancellation to happen:+        op (df d1 d2) --> $cop3 d1 d2+    because this breaks the mutual recursion between 'op' and 'df'++  * I wanted the RULE+        lift String ===> ...+    to work in Template Haskell when simplifying+    splices, so we get simpler code for literal strings++But watch out: list fusion can prevent floating.  So use phase control+to switch off those rules until after floating.++************************************************************************+*                                                                      *+                  The CoreToDo interpreter+*                                                                      *+************************************************************************+-}++runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts+runCorePasses passes guts+  = foldM do_pass guts passes+  where+    do_pass guts CoreDoNothing = return guts+    do_pass guts (CoreDoPasses ps) = runCorePasses ps guts+    do_pass guts pass+       = withTiming getDynFlags+                    (ppr pass <+> brackets (ppr mod))+                    (const ()) $ do+            { guts' <- lintAnnots (ppr pass) (doCorePass pass) guts+            ; endPass pass (mg_binds guts') (mg_rules guts')+            ; return guts' }++    mod = mg_module guts++doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts+doCorePass pass@(CoreDoSimplify {})  = {-# SCC "Simplify" #-}+                                       simplifyPgm pass++doCorePass CoreCSE                   = {-# SCC "CommonSubExpr" #-}+                                       doPass cseProgram++doCorePass CoreLiberateCase          = {-# SCC "LiberateCase" #-}+                                       doPassD liberateCase++doCorePass CoreDoFloatInwards        = {-# SCC "FloatInwards" #-}+                                       floatInwards++doCorePass (CoreDoFloatOutwards f)   = {-# SCC "FloatOutwards" #-}+                                       doPassDUM (floatOutwards f)++doCorePass CoreDoStaticArgs          = {-# SCC "StaticArgs" #-}+                                       doPassU doStaticArgs++doCorePass CoreDoCallArity           = {-# SCC "CallArity" #-}+                                       doPassD callArityAnalProgram++doCorePass CoreDoStrictness          = {-# SCC "NewStranal" #-}+                                       doPassDFM dmdAnalProgram++doCorePass CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}+                                       doPassDFU wwTopBinds++doCorePass CoreDoSpecialising        = {-# SCC "Specialise" #-}+                                       specProgram++doCorePass CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}+                                       specConstrProgram++doCorePass CoreDoVectorisation       = {-# SCC "Vectorise" #-}+                                       vectorise++doCorePass CoreDoPrintCore              = observe   printCore+doCorePass (CoreDoRuleCheck phase pat)  = ruleCheckPass phase pat+doCorePass CoreDoNothing                = return+doCorePass (CoreDoPasses passes)        = runCorePasses passes++#ifdef GHCI+doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass+#endif++doCorePass pass = pprPanic "doCorePass" (ppr pass)++{-+************************************************************************+*                                                                      *+\subsection{Core pass combinators}+*                                                                      *+************************************************************************+-}++printCore :: DynFlags -> CoreProgram -> IO ()+printCore dflags binds+    = Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds)++ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts+ruleCheckPass current_phase pat guts =+    withTiming getDynFlags+               (text "RuleCheck"<+>brackets (ppr $ mg_module guts))+               (const ()) $ do+    { rb <- getRuleBase+    ; dflags <- getDynFlags+    ; vis_orphs <- getVisibleOrphanMods+    ; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan+                   (defaultDumpStyle dflags)+                   (ruleCheckProgram current_phase pat+                      (RuleEnv rb vis_orphs) (mg_binds guts))+    ; return guts }++doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts+doPassDUM do_pass = doPassM $ \binds -> do+    dflags <- getDynFlags+    us     <- getUniqueSupplyM+    liftIO $ do_pass dflags us binds++doPassDM :: (DynFlags -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts+doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))++doPassD :: (DynFlags -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts+doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)++doPassDU :: (DynFlags -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts+doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)++doPassU :: (UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts+doPassU do_pass = doPassDU (const do_pass)++doPassDFM :: (DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts+doPassDFM do_pass guts = do+    dflags <- getDynFlags+    p_fam_env <- getPackageFamInstEnv+    let fam_envs = (p_fam_env, mg_fam_inst_env guts)+    doPassM (liftIO . do_pass dflags fam_envs) guts++doPassDFU :: (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts+doPassDFU do_pass guts = do+    dflags <- getDynFlags+    us     <- getUniqueSupplyM+    p_fam_env <- getPackageFamInstEnv+    let fam_envs = (p_fam_env, mg_fam_inst_env guts)+    doPass (do_pass dflags fam_envs us) guts++-- Most passes return no stats and don't change rules: these combinators+-- let us lift them to the full blown ModGuts+CoreM world+doPassM :: Monad m => (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts+doPassM bind_f guts = do+    binds' <- bind_f (mg_binds guts)+    return (guts { mg_binds = binds' })++doPass :: (CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts+doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }++-- Observer passes just peek; don't modify the bindings at all+observe :: (DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts+observe do_pass = doPassM $ \binds -> do+    dflags <- getDynFlags+    _ <- liftIO $ do_pass dflags binds+    return binds++{-+************************************************************************+*                                                                      *+        Gentle simplification+*                                                                      *+************************************************************************+-}++simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do+             -> CoreExpr+             -> IO CoreExpr+-- simplifyExpr is called by the driver to simplify an+-- expression typed in at the interactive prompt+--+-- Also used by Template Haskell+simplifyExpr dflags expr+  = withTiming (pure dflags) (text "Simplify [expr]") (const ()) $+    do  {+        ; us <-  mkSplitUniqSupply 's'++        ; let sz = exprSize expr++        ; (expr', counts) <- initSmpl dflags emptyRuleEnv+                               emptyFamInstEnvs us sz+                               (simplExprGently (simplEnvForGHCi dflags) expr)++        ; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags)+                  "Simplifier statistics" (pprSimplCount counts)++        ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"+                        (pprCoreExpr expr')++        ; return expr'+        }++simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr+-- Simplifies an expression+--      does occurrence analysis, then simplification+--      and repeats (twice currently) because one pass+--      alone leaves tons of crud.+-- Used (a) for user expressions typed in at the interactive prompt+--      (b) the LHS and RHS of a RULE+--      (c) Template Haskell splices+--+-- The name 'Gently' suggests that the SimplifierMode is SimplGently,+-- and in fact that is so.... but the 'Gently' in simplExprGently doesn't+-- enforce that; it just simplifies the expression twice++-- It's important that simplExprGently does eta reduction; see+-- Note [Simplifying the left-hand side of a RULE] above.  The+-- simplifier does indeed do eta reduction (it's in Simplify.completeLam)+-- but only if -O is on.++simplExprGently env expr = do+    expr1 <- simplExpr env (occurAnalyseExpr expr)+    simplExpr env (occurAnalyseExpr expr1)++{-+************************************************************************+*                                                                      *+\subsection{The driver for the simplifier}+*                                                                      *+************************************************************************+-}++simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts+simplifyPgm pass guts+  = do { hsc_env <- getHscEnv+       ; us <- getUniqueSupplyM+       ; rb <- getRuleBase+       ; liftIOWithCount $+         simplifyPgmIO pass hsc_env us rb guts }++simplifyPgmIO :: CoreToDo+              -> HscEnv+              -> UniqSupply+              -> RuleBase+              -> ModGuts+              -> IO (SimplCount, ModGuts)  -- New bindings++simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)+              hsc_env us hpt_rule_base+              guts@(ModGuts { mg_module = this_mod+                            , mg_rdr_env = rdr_env+                            , mg_deps = deps+                            , mg_binds = binds, mg_rules = rules+                            , mg_fam_inst_env = fam_inst_env })+  = do { (termination_msg, it_count, counts_out, guts')+           <- do_iteration us 1 [] binds rules++        ; Err.dumpIfSet dflags (dopt Opt_D_verbose_core2core dflags &&+                                dopt Opt_D_dump_simpl_stats  dflags)+                  "Simplifier statistics for following pass"+                  (vcat [text termination_msg <+> text "after" <+> ppr it_count+                                              <+> text "iterations",+                         blankLine,+                         pprSimplCount counts_out])++        ; return (counts_out, guts')+    }+  where+    dflags       = hsc_dflags hsc_env+    print_unqual = mkPrintUnqualified dflags rdr_env+    simpl_env    = mkSimplEnv mode+    active_rule  = activeRule simpl_env++    do_iteration :: UniqSupply+                 -> Int          -- Counts iterations+                 -> [SimplCount] -- Counts from earlier iterations, reversed+                 -> CoreProgram  -- Bindings in+                 -> [CoreRule]   -- and orphan rules+                 -> IO (String, Int, SimplCount, ModGuts)++    do_iteration us iteration_no counts_so_far binds rules+        -- iteration_no is the number of the iteration we are+        -- about to begin, with '1' for the first+      | iteration_no > max_iterations   -- Stop if we've run out of iterations+      = WARN( debugIsOn && (max_iterations > 2)+            , hang (text "Simplifier bailing out after" <+> int max_iterations+                    <+> text "iterations"+                    <+> (brackets $ hsep $ punctuate comma $+                         map (int . simplCountN) (reverse counts_so_far)))+                 2 (text "Size =" <+> ppr (coreBindsStats binds)))++                -- Subtract 1 from iteration_no to get the+                -- number of iterations we actually completed+        return ( "Simplifier baled out", iteration_no - 1+               , totalise counts_so_far+               , guts { mg_binds = binds, mg_rules = rules } )++      -- Try and force thunks off the binds; significantly reduces+      -- space usage, especially with -O.  JRS, 000620.+      | let sz = coreBindsSize binds+      , () <- sz `seq` ()     -- Force it+      = do {+                -- Occurrence analysis+           let {   -- Note [Vectorisation declarations and occurrences]+                   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+                   -- During the 'InitialPhase' (i.e., before vectorisation), we need to make sure+                   -- that the right-hand sides of vectorisation declarations are taken into+                   -- account during occurrence analysis. After the 'InitialPhase', we need to ensure+                   -- that the binders representing variable vectorisation declarations are kept alive.+                   -- (In contrast to automatically vectorised variables, their unvectorised versions+                   -- don't depend on them.)+                 vectVars = mkVarSet $+                              catMaybes [ fmap snd $ lookupDVarEnv (vectInfoVar (mg_vect_info guts)) bndr+                                        | Vect bndr _ <- mg_vect_decls guts]+                              +++                              catMaybes [ fmap snd $ lookupDVarEnv (vectInfoVar (mg_vect_info guts)) bndr+                                        | bndr <- bindersOfBinds binds]+                                        -- FIXME: This second comprehensions is only needed as long as we+                                        --        have vectorised bindings where we get "Could NOT call+                                        --        vectorised from original version".+              ;  (maybeVects, maybeVectVars)+                   = case sm_phase mode of+                       InitialPhase -> (mg_vect_decls guts, vectVars)+                       _            -> ([], vectVars)+               ; tagged_binds = {-# SCC "OccAnal" #-}+                     occurAnalysePgm this_mod active_rule rules+                                     maybeVects maybeVectVars binds+               } ;+           Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"+                     (pprCoreBindings tagged_binds);++                -- Get any new rules, and extend the rule base+                -- See Note [Overall plumbing for rules] in Rules.hs+                -- We need to do this regularly, because simplification can+                -- poke on IdInfo thunks, which in turn brings in new rules+                -- behind the scenes.  Otherwise there's a danger we'll simply+                -- miss the rules for Ids hidden inside imported inlinings+           eps <- hscEPS hsc_env ;+           let  { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)+                ; rule_base2 = extendRuleBaseList rule_base1 rules+                ; fam_envs = (eps_fam_inst_env eps, fam_inst_env)+                ; vis_orphs = this_mod : dep_orphs deps } ;++                -- Simplify the program+           ((binds1, rules1), counts1) <-+             initSmpl dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs us1 sz $+               do { env1 <- {-# SCC "SimplTopBinds" #-}+                            simplTopBinds simpl_env tagged_binds++                      -- Apply the substitution to rules defined in this module+                      -- for imported Ids.  Eg  RULE map my_f = blah+                      -- If we have a substitution my_f :-> other_f, we'd better+                      -- apply it to the rule to, or it'll never match+                  ; rules1 <- simplRules env1 Nothing rules++                  ; return (getFloatBinds env1, rules1) } ;++                -- Stop if nothing happened; don't dump output+           if isZeroSimplCount counts1 then+                return ( "Simplifier reached fixed point", iteration_no+                       , totalise (counts1 : counts_so_far)  -- Include "free" ticks+                       , guts { mg_binds = binds1, mg_rules = rules1 } )+           else do {+                -- Short out indirections+                -- We do this *after* at least one run of the simplifier+                -- because indirection-shorting uses the export flag on *occurrences*+                -- and that isn't guaranteed to be ok until after the first run propagates+                -- stuff from the binding site to its occurrences+                --+                -- ToDo: alas, this means that indirection-shorting does not happen at all+                --       if the simplifier does nothing (not common, I know, but unsavoury)+           let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;++                -- Dump the result of this iteration+           dump_end_iteration dflags print_unqual iteration_no counts1 binds2 rules1 ;+           lintPassResult hsc_env pass binds2 ;++                -- Loop+           do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1+           } }+      | otherwise = panic "do_iteration"+      where+        (us1, us2) = splitUniqSupply us++        -- Remember the counts_so_far are reversed+        totalise :: [SimplCount] -> SimplCount+        totalise = foldr (\c acc -> acc `plusSimplCount` c)+                         (zeroSimplCount dflags)++simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO"++-------------------+dump_end_iteration :: DynFlags -> PrintUnqualified -> Int+                   -> SimplCount -> CoreProgram -> [CoreRule] -> IO ()+dump_end_iteration dflags print_unqual iteration_no counts binds rules+  = dumpPassResult dflags print_unqual mb_flag hdr pp_counts binds rules+  where+    mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_iterations+            | otherwise                               = Nothing+            -- Show details if Opt_D_dump_simpl_iterations is on++    hdr = text "Simplifier iteration=" <> int iteration_no+    pp_counts = vcat [ text "---- Simplifier counts for" <+> hdr+                     , pprSimplCount counts+                     , text "---- End of simplifier counts for" <+> hdr ]++{-+************************************************************************+*                                                                      *+                Shorting out indirections+*                                                                      *+************************************************************************++If we have this:++        x_local = <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 [Transferring IdInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to propagage any useful IdInfo on x_local to x_exported.++STRICTNESS: if we have done strictness analysis, we want the strictness info on+x_local to transfer to x_exported.  Hence the copyIdInfo call.++RULES: we want to *add* any RULES for x_local to x_exported.+++Note [Messing up the exported Id's RULES]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must be careful about discarding (obviously) or even merging the+RULES on the exported Id. The example that went bad on me at one stage+was this one:++    iterate :: (a -> a) -> a -> [a]+        [Exported]+    iterate = iterateList++    iterateFB c f x = x `c` iterateFB c f (f x)+    iterateList f x =  x : iterateList f (f x)+        [Not exported]++    {-# RULES+    "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)+    "iterateFB"                 iterateFB (:) = iterateList+     #-}++This got shorted out to:++    iterateList :: (a -> a) -> a -> [a]+    iterateList = iterate++    iterateFB c f x = x `c` iterateFB c f (f x)+    iterate f x =  x : iterate f (f x)++    {-# RULES+    "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)+    "iterateFB"                 iterateFB (:) = iterate+     #-}++And now we get an infinite loop in the rule system+        iterate f x -> build (\cn -> iterateFB c f x)+                    -> iterateFB (:) f x+                    -> iterate f x++Old "solution":+        use rule switching-off pragmas to get rid+        of iterateList in the first place++But in principle the user *might* want rules that only apply to the Id+he says.  And inline pragmas are similar+   {-# NOINLINE f #-}+   f = local+   local = <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 elminate a binding that's mentioned in the+unfolding for something.++Note [Indirection zapping and ticks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Unfortunately this is another place where we need a special case for+ticks. The following happens quite regularly:++        x_local = <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 that this might increase the ticks scoping+over the execution of x_local, so we can only do this for floatable+ticks. More often than not, other references will be unfoldings of+x_exported, and therefore carry the tick anyway.+-}++type IndEnv = IdEnv (Id, [Tickish Var]) -- Maps local_id -> exported_id, ticks++shortOutIndirections :: CoreProgram -> CoreProgram+shortOutIndirections binds+  | isEmptyVarEnv ind_env = binds+  | no_need_to_flatten    = binds'                      -- See Note [Rules and indirect-zapping]+  | otherwise             = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff+  where+    ind_env            = makeIndEnv binds+    -- These exported Ids are the subjects  of the indirection-elimination+    exp_ids            = map fst $ nonDetEltsUFM ind_env+      -- It's OK to use nonDetEltsUFM here because we forget the ordering+      -- by immediately converting to a set or check if all the elements+      -- satisfy a predicate.+    exp_id_set         = mkVarSet exp_ids+    no_need_to_flatten = all (null . ruleInfoRules . idSpecialisation) exp_ids+    binds'             = concatMap zap binds++    zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]+    zap (Rec pairs)       = [Rec (concatMap zapPair pairs)]++    zapPair (bndr, rhs)+        | bndr `elemVarSet` exp_id_set = []+        | Just (exp_id, ticks) <- lookupVarEnv ind_env bndr+                                       = [(transferIdInfo exp_id bndr,+                                           mkTicks ticks rhs),+                                          (bndr, Var exp_id)]+        | otherwise                    = [(bndr,rhs)]++makeIndEnv :: [CoreBind] -> IndEnv+makeIndEnv binds+  = foldr add_bind emptyVarEnv binds+  where+    add_bind :: CoreBind -> IndEnv -> IndEnv+    add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env+    add_bind (Rec pairs)              env = foldr add_pair env pairs++    add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv+    add_pair (exported_id, exported) env+        | (ticks, Var local_id) <- stripTicksTop tickishFloatable exported+        , shortMeOut env exported_id local_id+        = extendVarEnv env local_id (exported_id, ticks)+    add_pair _ env = env++-----------------+shortMeOut :: IndEnv -> Id -> Id -> Bool+shortMeOut ind_env exported_id local_id+-- The if-then-else stuff is just so I can get a pprTrace to see+-- how often I don't get shorting out because of IdInfo stuff+  = if isExportedId exported_id &&              -- Only if this is exported++       isLocalId local_id &&                    -- Only if this one is defined in this+                                                --      module, so that we *can* change its+                                                --      binding to be the exported thing!++       not (isExportedId local_id) &&           -- Only if this one is not itself exported,+                                                --      since the transformation will nuke it++       not (local_id `elemVarEnv` ind_env)      -- Only if not already substituted for+    then+        if hasShortableIdInfo exported_id+        then True       -- See Note [Messing up the exported Id's IdInfo]+        else WARN( True, text "Not shorting out:" <+> ppr exported_id )+             False+    else+        False++-----------------+hasShortableIdInfo :: Id -> Bool+-- True if there is no user-attached IdInfo on exported_id,+-- so we can safely discard it+-- See Note [Messing up the exported Id's IdInfo]+hasShortableIdInfo id+  =  isEmptyRuleInfo (ruleInfo info)+  && isDefaultInlinePragma (inlinePragInfo info)+  && not (isStableUnfolding (unfoldingInfo info))+  where+     info = idInfo id++-----------------+transferIdInfo :: Id -> Id -> Id+-- See Note [Transferring IdInfo]+-- If we have+--      lcl_id = e; exp_id = lcl_id+-- and lcl_id has useful IdInfo, we don't want to discard it by going+--      gbl_id = e; lcl_id = gbl_id+-- Instead, transfer IdInfo from lcl_id to exp_id+-- Overwriting, rather than merging, seems to work ok.+transferIdInfo exported_id local_id+  = modifyIdInfo transfer exported_id+  where+    local_info = idInfo local_id+    transfer exp_info = exp_info `setStrictnessInfo`    strictnessInfo local_info+                                 `setUnfoldingInfo`     unfoldingInfo local_info+                                 `setInlinePragInfo`    inlinePragInfo local_info+                                 `setRuleInfo`          addRuleInfo (ruleInfo exp_info) new_info+    new_info = setRuleInfoHead (idName exported_id)+                               (ruleInfo local_info)+        -- Remember to set the function-name field of the+        -- rules as we transfer them from one function to another
+ simplCore/SimplEnv.hs view
@@ -0,0 +1,838 @@+{-+(c) The AQUA Project, Glasgow University, 1993-1998++\section[SimplMonad]{The simplifier Monad}+-}++{-# LANGUAGE CPP #-}++module SimplEnv (+        -- * The simplifier mode+        setMode, getMode, updMode,++        -- * Environments+        SimplEnv(..), StaticEnv, pprSimplEnv,   -- Temp not abstract+        mkSimplEnv, extendIdSubst,+        SimplEnv.extendTvSubst, SimplEnv.extendCvSubst,+        zapSubstEnv, setSubstEnv,+        getInScope, setInScopeAndZapFloats,+        setInScopeSet, modifyInScope, addNewInScopeIds,+        getSimplRules,++        -- * Substitution results+        SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope,+        isJoinIdInEnv_maybe,++        -- * Simplifying 'Id' binders+        simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs,+        simplBinder, simplBinders,+        substTy, substTyVar, getTCvSubst,+        substCo, substCoVar,++        -- * Floats+        Floats, emptyFloats, isEmptyFloats,+        addNonRec, addFloats, extendFloats,+        wrapFloats, setFloats, zapFloats, addRecFloats, mapFloats,+        doFloatFromRhs, getFloatBinds,++        JoinFloats, emptyJoinFloats, isEmptyJoinFloats,+        wrapJoinFloats, zapJoinFloats, restoreJoinFloats, getJoinFloatBinds,+    ) where++#include "HsVersions.h"++import SimplMonad+import CoreMonad                ( SimplifierMode(..) )+import CoreSyn+import CoreUtils+import Var+import VarEnv+import VarSet+import OrdList+import Id+import MkCore                   ( mkWildValBinder )+import TysWiredIn+import qualified Type+import Type hiding              ( substTy, substTyVar, substTyVarBndr )+import qualified Coercion+import Coercion hiding          ( substCo, substCoVar, substCoVarBndr )+import BasicTypes+import MonadUtils+import Outputable+import Util+import UniqFM                   ( pprUniqFM )++import Data.List++{-+************************************************************************+*                                                                      *+\subsubsection{The @SimplEnv@ type}+*                                                                      *+************************************************************************+-}++data SimplEnv+  = SimplEnv {+     ----------- Static part of the environment -----------+     -- Static in the sense of lexically scoped,+     -- wrt the original expression++        seMode      :: SimplifierMode,++        -- The current substitution+        seTvSubst   :: TvSubstEnv,      -- InTyVar |--> OutType+        seCvSubst   :: CvSubstEnv,      -- InCoVar |--> OutCoercion+        seIdSubst   :: SimplIdSubst,    -- InId    |--> OutExpr++     ----------- Dynamic part of the environment -----------+     -- Dynamic in the sense of describing the setup where+     -- the expression finally ends up++        -- The current set of in-scope variables+        -- They are all OutVars, and all bound in this module+        seInScope   :: InScopeSet,      -- OutVars only+                -- Includes all variables bound by seFloats+        seFloats    :: Floats,+                -- See Note [Simplifier floats]+        seJoinFloats :: JoinFloats+                -- Handled separately; they don't go very far+    }++type StaticEnv = SimplEnv       -- Just the static part is relevant++pprSimplEnv :: SimplEnv -> SDoc+-- Used for debugging; selective+pprSimplEnv env+  = vcat [text "TvSubst:" <+> ppr (seTvSubst env),+          text "CvSubst:" <+> ppr (seCvSubst env),+          text "IdSubst:" <+> id_subst_doc,+          text "InScope:" <+> in_scope_vars_doc+    ]+  where+   id_subst_doc = pprUniqFM ppr_id_subst (seIdSubst env)+   ppr_id_subst (m_ar, sr) = arity_part <+> ppr sr+     where arity_part = case m_ar of Just ar -> brackets $+                                                  text "join" <+> int ar+                                     Nothing -> empty++   in_scope_vars_doc = pprVarSet (getInScopeVars (seInScope env))+                                 (vcat . map ppr_one)+   ppr_one v | isId v = ppr v <+> ppr (idUnfolding v)+             | otherwise = ppr v++type SimplIdSubst = IdEnv (Maybe JoinArity, SimplSR) -- IdId |--> OutExpr+        -- See Note [Extending the Subst] in CoreSubst+        -- See Note [Join arity in SimplIdSubst]++-- | A substitution result.+data SimplSR+  = DoneEx OutExpr              -- Completed term+  | DoneId OutId                -- Completed term variable+  | ContEx TvSubstEnv           -- A suspended substitution+           CvSubstEnv+           SimplIdSubst+           InExpr++instance Outputable SimplSR where+  ppr (DoneEx e) = text "DoneEx" <+> ppr e+  ppr (DoneId v) = text "DoneId" <+> ppr v+  ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-,+                                ppr (filter_env tv), ppr (filter_env id) -}]+        -- where+        -- fvs = exprFreeVars e+        -- filter_env env = filterVarEnv_Directly keep env+        -- keep uniq _ = uniq `elemUFM_Directly` fvs++{-+Note [SimplEnv invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~+seInScope:+        The in-scope part of Subst includes *all* in-scope TyVars and Ids+        The elements of the set may have better IdInfo than the+        occurrences of in-scope Ids, and (more important) they will+        have a correctly-substituted type.  So we use a lookup in this+        set to replace occurrences++        The Ids in the InScopeSet are replete with their Rules,+        and as we gather info about the unfolding of an Id, we replace+        it in the in-scope set.++        The in-scope set is actually a mapping OutVar -> OutVar, and+        in case expressions we sometimes bind++seIdSubst:+        The substitution is *apply-once* only, because InIds and OutIds+        can overlap.+        For example, we generally omit mappings+                a77 -> a77+        from the substitution, when we decide not to clone a77, but it's quite+        legitimate to put the mapping in the substitution anyway.++        Furthermore, consider+                let x = case k of I# x77 -> ... in+                let y = case k of I# x77 -> ... in ...+        and suppose the body is strict in both x and y.  Then the simplifier+        will pull the first (case k) to the top; so the second (case k) will+        cancel out, mapping x77 to, well, x77!  But one is an in-Id and the+        other is an out-Id.++        Of course, the substitution *must* applied! Things in its domain+        simply aren't necessarily bound in the result.++* substId adds a binding (DoneId new_id) to the substitution if+        the Id's unique has changed++  Note, though that the substitution isn't necessarily extended+  if the type of the Id changes.  Why not?  Because of the next point:++* We *always, always* finish by looking up in the in-scope set+  any variable that doesn't get a DoneEx or DoneVar hit in the substitution.+  Reason: so that we never finish up with a "old" Id in the result.+  An old Id might point to an old unfolding and so on... which gives a space+  leak.++  [The DoneEx and DoneVar hits map to "new" stuff.]++* It follows that substExpr must not do a no-op if the substitution is empty.+  substType is free to do so, however.++* When we come to a let-binding (say) we generate new IdInfo, including an+  unfolding, attach it to the binder, and add this newly adorned binder to+  the in-scope set.  So all subsequent occurrences of the binder will get+  mapped to the full-adorned binder, which is also the one put in the+  binding site.++* The in-scope "set" usually maps x->x; we use it simply for its domain.+  But sometimes we have two in-scope Ids that are synomyms, and should+  map to the same target:  x->x, y->x.  Notably:+        case y of x { ... }+  That's why the "set" is actually a VarEnv Var++Note [Join arity in SimplIdSubst]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We have to remember which incoming variables are join points (the occurrences+may not be marked correctly yet; we're in change of propagating the change if+OccurAnal makes something a join point). Normally the in-scope set is where we+keep the latest information, but the in-scope set tracks only OutVars; if a+binding is unconditionally inlined, it never makes it into the in-scope set,+and we need to know at the occurrence site that the variable is a join point so+that we know to drop the context. Thus we remember which join points we're+substituting. Clumsily, finding whether an InVar is a join variable may require+looking in both the substitution *and* the in-scope set (see+'isJoinIdInEnv_maybe').+-}++mkSimplEnv :: SimplifierMode -> SimplEnv+mkSimplEnv mode+  = SimplEnv { seMode = mode+             , seInScope = init_in_scope+             , seFloats = emptyFloats+             , seJoinFloats = emptyJoinFloats+             , seTvSubst = emptyVarEnv+             , seCvSubst = emptyVarEnv+             , seIdSubst = emptyVarEnv }+        -- The top level "enclosing CC" is "SUBSUMED".++init_in_scope :: InScopeSet+init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder unitTy))+              -- See Note [WildCard binders]++{-+Note [WildCard binders]+~~~~~~~~~~~~~~~~~~~~~~~+The program to be simplified may have wild binders+    case e of wild { p -> ... }+We want to *rename* them away, so that there are no+occurrences of 'wild-id' (with wildCardKey).  The easy+way to do that is to start of with a representative+Id in the in-scope set++There can be be *occurrences* of wild-id.  For example,+MkCore.mkCoreApp transforms+   e (a /# b)   -->   case (a /# b) of wild { DEFAULT -> e wild }+This is ok provided 'wild' isn't free in 'e', and that's the delicate+thing. Generally, you want to run the simplifier to get rid of the+wild-ids before doing much else.++It's a very dark corner of GHC.  Maybe it should be cleaned up.+-}++getMode :: SimplEnv -> SimplifierMode+getMode env = seMode env++setMode :: SimplifierMode -> SimplEnv -> SimplEnv+setMode mode env = env { seMode = mode }++updMode :: (SimplifierMode -> SimplifierMode) -> SimplEnv -> SimplEnv+updMode upd env = env { seMode = upd (seMode env) }++---------------------+extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv+extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res+  = ASSERT2( isId var && not (isCoVar var), ppr var )+    env { seIdSubst = extendVarEnv subst var (isJoinId_maybe var, res) }++extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv+extendTvSubst env@(SimplEnv {seTvSubst = tsubst}) var res+  = ASSERT( isTyVar var )+    env {seTvSubst = extendVarEnv tsubst var res}++extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv+extendCvSubst env@(SimplEnv {seCvSubst = csubst}) var co+  = ASSERT( isCoVar var )+    env {seCvSubst = extendVarEnv csubst var co}++---------------------+getInScope :: SimplEnv -> InScopeSet+getInScope env = seInScope env++setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv+setInScopeSet env in_scope = env {seInScope = in_scope}++setInScopeAndZapFloats :: SimplEnv -> SimplEnv -> SimplEnv+-- Set the in-scope set, and *zap* the floats+setInScopeAndZapFloats env env_with_scope+  = env { seInScope    = seInScope env_with_scope,+          seFloats     = emptyFloats,+          seJoinFloats = emptyJoinFloats }++setFloats :: SimplEnv -> SimplEnv -> SimplEnv+-- Set the in-scope set *and* the floats+setFloats env env_with_floats+  = env { seInScope    = seInScope env_with_floats,+          seFloats     = seFloats  env_with_floats,+          seJoinFloats = seJoinFloats env_with_floats }++restoreJoinFloats :: SimplEnv -> SimplEnv -> SimplEnv+-- Put back floats previously zapped+-- Unlike 'setFloats', does *not* update the in-scope set, since the right-hand+-- env is assumed to be *older*+restoreJoinFloats env old_env+  = env { seJoinFloats = seJoinFloats old_env }++addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv+        -- The new Ids are guaranteed to be freshly allocated+addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs+  = env { seInScope = in_scope `extendInScopeSetList` vs,+          seIdSubst = id_subst `delVarEnvList` vs }+        -- Why delete?  Consider+        --      let x = a*b in (x, \x -> x+3)+        -- We add [x |-> a*b] to the substitution, but we must+        -- _delete_ it from the substitution when going inside+        -- the (\x -> ...)!++modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv+-- The variable should already be in scope, but+-- replace the existing version with this new one+-- which has more information+modifyInScope env@(SimplEnv {seInScope = in_scope}) v+  = env {seInScope = extendInScopeSet in_scope v}++---------------------+zapSubstEnv :: SimplEnv -> SimplEnv+zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}++setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv+setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }++mkContEx :: SimplEnv -> InExpr -> SimplSR+mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e++{-+************************************************************************+*                                                                      *+\subsection{Floats}+*                                                                      *+************************************************************************++Note [Simplifier floats]+~~~~~~~~~~~~~~~~~~~~~~~~~+The Floats is a bunch of bindings, classified by a FloatFlag.++* All of them satisfy the let/app invariant++Examples++  NonRec x (y:ys)       FltLifted+  Rec [(x,rhs)]         FltLifted++  NonRec x* (p:q)       FltOKSpec   -- RHS is WHNF.  Question: why not FltLifted?+  NonRec x# (y +# 3)    FltOkSpec   -- Unboxed, but ok-for-spec'n++  NonRec x* (f y)       FltCareful  -- Strict binding; might fail or diverge++Can't happen:+  NonRec x# (a /# b)    -- Might fail; does not satisfy let/app+  NonRec x# (f y)       -- Might diverge; does not satisfy let/app+-}++data Floats = Floats (OrdList OutBind) FloatFlag+        -- See Note [Simplifier floats]++type JoinFloats = OrdList OutBind++data FloatFlag+  = FltLifted   -- All bindings are lifted and lazy *or*+                --     consist of a single primitive string literal+                --  Hence ok to float to top level, or recursive++  | FltOkSpec   -- All bindings are FltLifted *or*+                --      strict (perhaps because unlifted,+                --      perhaps because of a strict binder),+                --        *and* ok-for-speculation+                --  Hence ok to float out of the RHS+                --  of a lazy non-recursive let binding+                --  (but not to top level, or into a rec group)++  | FltCareful  -- At least one binding is strict (or unlifted)+                --      and not guaranteed cheap+                --      Do not float these bindings out of a lazy let++instance Outputable Floats where+  ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds)++instance Outputable FloatFlag where+  ppr FltLifted = text "FltLifted"+  ppr FltOkSpec = text "FltOkSpec"+  ppr FltCareful = text "FltCareful"++andFF :: FloatFlag -> FloatFlag -> FloatFlag+andFF FltCareful _          = FltCareful+andFF FltOkSpec  FltCareful = FltCareful+andFF FltOkSpec  _          = FltOkSpec+andFF FltLifted  flt        = flt++doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool+-- If you change this function look also at FloatIn.noFloatFromRhs+doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff})+  =  not (isNilOL fs) && want_to_float && can_float+  where+     want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs+                     -- See Note [Float when cheap or expandable]+     can_float = case ff of+                   FltLifted  -> True+                   FltOkSpec  -> isNotTopLevel lvl && isNonRec rec+                   FltCareful -> isNotTopLevel lvl && isNonRec rec && str++{-+Note [Float when cheap or expandable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to float a let from a let if the residual RHS is+   a) cheap, such as (\x. blah)+   b) expandable, such as (f b) if f is CONLIKE+But there are+  - cheap things that are not expandable (eg \x. expensive)+  - expandable things that are not cheap (eg (f b) where b is CONLIKE)+so we must take the 'or' of the two.+-}++emptyFloats :: Floats+emptyFloats = Floats nilOL FltLifted++emptyJoinFloats :: JoinFloats+emptyJoinFloats = nilOL++unitFloat :: OutBind -> Floats+-- This key function constructs a singleton float with the right form+unitFloat bind = ASSERT(all (not . isJoinId) (bindersOf bind))+                 Floats (unitOL bind) (flag bind)+  where+    flag (Rec {})                = FltLifted+    flag (NonRec bndr rhs)+      | not (isStrictId bndr)    = FltLifted+      | exprIsLiteralString rhs  = FltLifted+          -- String literals can be floated freely.+          -- See Note [CoreSyn top-level string ltierals] in CoreSyn.+      | exprOkForSpeculation rhs = FltOkSpec  -- Unlifted, and lifted but ok-for-spec (eg HNF)+      | otherwise                = ASSERT2( not (isUnliftedType (idType bndr)), ppr bndr )+                                   FltCareful+      -- Unlifted binders can only be let-bound if exprOkForSpeculation holds++unitJoinFloat :: OutBind -> JoinFloats+unitJoinFloat bind = ASSERT(all isJoinId (bindersOf bind))+                     unitOL bind++addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv+-- Add a non-recursive binding and extend the in-scope set+-- The latter is important; the binder may already be in the+-- in-scope set (although it might also have been created with newId)+-- but it may now have more IdInfo+addNonRec env id rhs+  = id `seq`   -- This seq forces the Id, and hence its IdInfo,+               -- and hence any inner substitutions+    env { seFloats = floats',+          seJoinFloats = jfloats',+          seInScope = extendInScopeSet (seInScope env) id }+  where+    bind = NonRec id rhs++    floats'  | isJoinId id = seFloats env+             | otherwise   = seFloats env `addFlts` unitFloat bind+    jfloats' | isJoinId id = seJoinFloats env `addJoinFlts` unitJoinFloat bind+             | otherwise   = seJoinFloats env++extendFloats :: SimplEnv -> OutBind -> SimplEnv+-- Add these bindings to the floats, and extend the in-scope env too+extendFloats env bind+  = ASSERT(all (not . isJoinId) (bindersOf bind))+    env { seFloats  = floats',+          seJoinFloats = jfloats',+          seInScope = extendInScopeSetList (seInScope env) bndrs }+  where+    bndrs = bindersOf bind++    floats'  | isJoinBind bind = seFloats env+             | otherwise       = seFloats env `addFlts` unitFloat bind+    jfloats' | isJoinBind bind = seJoinFloats env `addJoinFlts`+                                   unitJoinFloat bind+             | otherwise       = seJoinFloats env++addFloats :: SimplEnv -> SimplEnv -> SimplEnv+-- Add the floats for env2 to env1;+-- *plus* the in-scope set for env2, which is bigger+-- than that for env1+addFloats env1 env2+  = env1 {seFloats = seFloats env1 `addFlts` seFloats env2,+          seJoinFloats = seJoinFloats env1 `addJoinFlts` seJoinFloats env2,+          seInScope = seInScope env2 }++addFlts :: Floats -> Floats -> Floats+addFlts (Floats bs1 l1) (Floats bs2 l2)+  = Floats (bs1 `appOL` bs2) (l1 `andFF` l2)++addJoinFlts :: JoinFloats -> JoinFloats -> JoinFloats+addJoinFlts = appOL++zapFloats :: SimplEnv -> SimplEnv+zapFloats env = env { seFloats = emptyFloats+                    , seJoinFloats = emptyJoinFloats }++zapJoinFloats :: SimplEnv -> SimplEnv+zapJoinFloats env = env { seJoinFloats = emptyJoinFloats }++addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv+-- Flattens the floats from env2 into a single Rec group,+-- prepends the floats from env1, and puts the result back in env2+-- This is all very specific to the way recursive bindings are+-- handled; see Simplify.simplRecBind+addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff+                                 ,seJoinFloats = jbs })+  = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) )+    env2 {seFloats = seFloats env1 `addFlts` floats'+         ,seJoinFloats = seJoinFloats env1 `addJoinFlts` jfloats'}+  where+    floats'  | isNilOL bs  = emptyFloats+             | otherwise   = unitFloat (Rec (flattenBinds (fromOL bs)))+    jfloats' | isNilOL jbs = emptyJoinFloats+             | otherwise   = unitJoinFloat (Rec (flattenBinds (fromOL jbs)))++wrapFloats :: SimplEnv -> OutExpr -> OutExpr+-- Wrap the floats around the expression; they should all+-- satisfy the let/app invariant, so mkLets should do the job just fine+wrapFloats env@(SimplEnv {seFloats = Floats bs _}) body+  = foldrOL Let (wrapJoinFloats env body) bs+      -- Note: Always safe to put the joins on the inside since the values+      -- can't refer to them++wrapJoinFloats :: SimplEnv -> OutExpr -> OutExpr+wrapJoinFloats (SimplEnv {seJoinFloats = jbs}) body+  = foldrOL Let body jbs++getFloatBinds :: SimplEnv -> [CoreBind]+getFloatBinds env@(SimplEnv {seFloats = Floats bs _})+  = fromOL bs ++ getJoinFloatBinds env++getJoinFloatBinds :: SimplEnv -> [CoreBind]+getJoinFloatBinds (SimplEnv {seJoinFloats = jbs})+  = fromOL jbs++isEmptyFloats :: SimplEnv -> Bool+isEmptyFloats env@(SimplEnv {seFloats = Floats bs _})+  = isNilOL bs && isEmptyJoinFloats env++isEmptyJoinFloats :: SimplEnv -> Bool+isEmptyJoinFloats (SimplEnv {seJoinFloats = jbs})+  = isNilOL jbs++mapFloats :: SimplEnv -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> SimplEnv+mapFloats env@SimplEnv { seFloats = Floats fs ff, seJoinFloats = jfs } fun+   = env { seFloats = Floats (mapOL app fs) ff+         , seJoinFloats = mapOL app jfs }+   where+    app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e'+    app (Rec bs)     = Rec (map fun bs)++{-+************************************************************************+*                                                                      *+                Substitution of Vars+*                                                                      *+************************************************************************++Note [Global Ids in the substitution]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We look up even a global (eg imported) Id in the substitution. Consider+   case X.g_34 of b { (a,b) ->  ... case X.g_34 of { (p,q) -> ...} ... }+The binder-swap in the occurrence analyser will add a binding+for a LocalId version of g (with the same unique though):+   case X.g_34 of b { (a,b) ->  let g_34 = b in+                                ... case X.g_34 of { (p,q) -> ...} ... }+So we want to look up the inner X.g_34 in the substitution, where we'll+find that it has been substituted by b.  (Or conceivably cloned.)+-}++substId :: SimplEnv -> InId -> SimplSR+-- Returns DoneEx only on a non-Var expression+substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v+  = case snd <$> lookupVarEnv ids v of  -- Note [Global Ids in the substitution]+        Nothing               -> DoneId (refineFromInScope in_scope v)+        Just (DoneId v)       -> DoneId (refineFromInScope in_scope v)+        Just (DoneEx (Var v)) -> DoneId (refineFromInScope in_scope v)+        Just res              -> res    -- DoneEx non-var, or ContEx++        -- Get the most up-to-date thing from the in-scope set+        -- Even though it isn't in the substitution, it may be in+        -- the in-scope set with better IdInfo++isJoinIdInEnv_maybe :: SimplEnv -> InId -> Maybe JoinArity+isJoinIdInEnv_maybe (SimplEnv { seInScope = inScope, seIdSubst = ids }) v+  | not (isLocalId v)                         = Nothing+  | Just (m_ar, _) <- lookupVarEnv ids v      = m_ar+  | Just v'        <- lookupInScope inScope v = isJoinId_maybe v'+  | otherwise                                 = WARN( True , ppr v )+                                                isJoinId_maybe v++refineFromInScope :: InScopeSet -> Var -> Var+refineFromInScope in_scope v+  | isLocalId v = case lookupInScope in_scope v of+                  Just v' -> v'+                  Nothing -> WARN( True, ppr v ) v  -- This is an error!+  | otherwise = v++lookupRecBndr :: SimplEnv -> InId -> OutId+-- Look up an Id which has been put into the envt by simplRecBndrs,+-- but where we have not yet done its RHS+lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v+  = case lookupVarEnv ids v of+        Just (_, DoneId v) -> v+        Just _ -> pprPanic "lookupRecBndr" (ppr v)+        Nothing -> refineFromInScope in_scope v++{-+************************************************************************+*                                                                      *+\section{Substituting an Id binder}+*                                                                      *+************************************************************************+++These functions are in the monad only so that they can be made strict via seq.+-}++simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])+simplBinders  env bndrs = mapAccumLM simplBinder  env bndrs++-------------+simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)+-- Used for lambda and case-bound variables+-- Clone Id if necessary, substitute type+-- Return with IdInfo already substituted, but (fragile) occurrence info zapped+-- The substitution is extended only if the variable is cloned, because+-- we *don't* need to use it to track occurrence info.+simplBinder env bndr+  | isTyVar bndr  = do  { let (env', tv) = substTyVarBndr env bndr+                        ; seqTyVar tv `seq` return (env', tv) }+  | otherwise     = do  { let (env', id) = substIdBndr Nothing env bndr+                        ; seqId id `seq` return (env', id) }++---------------+simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)+-- A non-recursive let binder+simplNonRecBndr env id+  = do  { let (env1, id1) = substIdBndr Nothing env id+        ; seqId id1 `seq` return (env1, id1) }++---------------+simplNonRecJoinBndr :: SimplEnv -> OutType -> InBndr+                    -> SimplM (SimplEnv, OutBndr)+-- A non-recursive let binder for a join point; context being pushed inward may+-- change the type+simplNonRecJoinBndr env res_ty id+  = do  { let (env1, id1) = substIdBndr (Just res_ty) env id+        ; seqId id1 `seq` return (env1, id1) }++---------------+simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv+-- Recursive let binders+simplRecBndrs env@(SimplEnv {}) ids+  = ASSERT(all (not . isJoinId) ids)+    do  { let (env1, ids1) = mapAccumL (substIdBndr Nothing) env ids+        ; seqIds ids1 `seq` return env1 }++---------------+simplRecJoinBndrs :: SimplEnv -> OutType -> [InBndr] -> SimplM SimplEnv+-- Recursive let binders for join points; context being pushed inward may+-- change types+simplRecJoinBndrs env@(SimplEnv {}) res_ty ids+  = ASSERT(all isJoinId ids)+    do  { let (env1, ids1) = mapAccumL (substIdBndr (Just res_ty)) env ids+        ; seqIds ids1 `seq` return env1 }++---------------+substIdBndr :: Maybe OutType -> SimplEnv -> InBndr -> (SimplEnv, OutBndr)+-- Might be a coercion variable+substIdBndr new_res_ty env bndr+  | isCoVar bndr  = substCoVarBndr env bndr+  | otherwise     = substNonCoVarIdBndr new_res_ty env bndr++---------------+substNonCoVarIdBndr+   :: Maybe OutType -- New result type, if a join binder+   -> SimplEnv+   -> InBndr    -- Env and binder to transform+   -> (SimplEnv, OutBndr)+-- Clone Id if necessary, substitute its type+-- Return an Id with its+--      * Type substituted+--      * UnfoldingInfo, Rules, WorkerInfo zapped+--      * Fragile OccInfo (only) zapped: Note [Robust OccInfo]+--      * Robust info, retained especially arity and demand info,+--         so that they are available to occurrences that occur in an+--         earlier binding of a letrec+--+-- For the robust info, see Note [Arity robustness]+--+-- Augment the substitution  if the unique changed+-- Extend the in-scope set with the new Id+--+-- Similar to CoreSubst.substIdBndr, except that+--      the type of id_subst differs+--      all fragile info is zapped+substNonCoVarIdBndr new_res_ty+                    env@(SimplEnv { seInScope = in_scope+                                  , seIdSubst = id_subst })+                    old_id+  = ASSERT2( not (isCoVar old_id), ppr old_id )+    (env { seInScope = in_scope `extendInScopeSet` new_id,+           seIdSubst = new_subst }, new_id)+  where+    id1    = uniqAway in_scope old_id+    id2    = substIdType env id1+    id3    | Just res_ty <- new_res_ty+           = id2 `setIdType` setJoinResTy (idJoinArity id2) res_ty (idType id2)+           | otherwise+           = id2+    new_id = zapFragileIdInfo id3       -- Zaps rules, worker-info, unfolding+                                        -- and fragile OccInfo++        -- Extend the substitution if the unique has changed,+        -- or there's some useful occurrence information+        -- See the notes with substTyVarBndr for the delSubstEnv+    new_subst | new_id /= old_id+              = extendVarEnv id_subst old_id+                             (isJoinId_maybe new_id, DoneId new_id)+              | otherwise+              = delVarEnv id_subst old_id++------------------------------------+seqTyVar :: TyVar -> ()+seqTyVar b = b `seq` ()++seqId :: Id -> ()+seqId id = seqType (idType id)  `seq`+           idInfo id            `seq`+           ()++seqIds :: [Id] -> ()+seqIds []       = ()+seqIds (id:ids) = seqId id `seq` seqIds ids++{-+Note [Arity robustness]+~~~~~~~~~~~~~~~~~~~~~~~+We *do* transfer the arity from from the in_id of a let binding to the+out_id.  This is important, so that the arity of an Id is visible in+its own RHS.  For example:+        f = \x. ....g (\y. f y)....+We can eta-reduce the arg to g, because f is a value.  But that+needs to be visible.++This interacts with the 'state hack' too:+        f :: Bool -> IO Int+        f = \x. case x of+                  True  -> f y+                  False -> \s -> ...+Can we eta-expand f?  Only if we see that f has arity 1, and then we+take advantage of the 'state hack' on the result of+(f y) :: State# -> (State#, Int) to expand the arity one more.++There is a disadvantage though.  Making the arity visible in the RHS+allows us to eta-reduce+        f = \x -> f x+to+        f = f+which technically is not sound.   This is very much a corner case, so+I'm not worried about it.  Another idea is to ensure that f's arity+never decreases; its arity started as 1, and we should never eta-reduce+below that.+++Note [Robust OccInfo]+~~~~~~~~~~~~~~~~~~~~~+It's important that we *do* retain the loop-breaker OccInfo, because+that's what stops the Id getting inlined infinitely, in the body of+the letrec.+-}+++{-+************************************************************************+*                                                                      *+                Impedance matching to type substitution+*                                                                      *+************************************************************************+-}++getTCvSubst :: SimplEnv -> TCvSubst+getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env+                      , seCvSubst = cv_env })+  = mkTCvSubst in_scope (tv_env, cv_env)++substTy :: SimplEnv -> Type -> Type+substTy env ty = Type.substTy (getTCvSubst env) ty++substTyVar :: SimplEnv -> TyVar -> Type+substTyVar env tv = Type.substTyVar (getTCvSubst env) tv++substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)+substTyVarBndr env tv+  = case Type.substTyVarBndr (getTCvSubst env) tv of+        (TCvSubst in_scope' tv_env' cv_env', tv')+           -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, tv')++substCoVar :: SimplEnv -> CoVar -> Coercion+substCoVar env tv = Coercion.substCoVar (getTCvSubst env) tv++substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar)+substCoVarBndr env cv+  = case Coercion.substCoVarBndr (getTCvSubst env) cv of+        (TCvSubst in_scope' tv_env' cv_env', cv')+           -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv')++substCo :: SimplEnv -> Coercion -> Coercion+substCo env co = Coercion.substCo (getTCvSubst env) co++------------------+substIdType :: SimplEnv -> Id -> Id+substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) id+  |  (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env)+  || noFreeVarsOfType old_ty+  = id+  | otherwise = Id.setIdType id (Type.substTy (TCvSubst in_scope tv_env cv_env) old_ty)+                -- The tyCoVarsOfType is cheaper than it looks+                -- because we cache the free tyvars of the type+                -- in a Note in the id's type itself+  where+    old_ty = idType id
+ simplCore/SimplMonad.hs view
@@ -0,0 +1,218 @@+{-+(c) The AQUA Project, Glasgow University, 1993-1998++\section[SimplMonad]{The simplifier Monad}+-}++module SimplMonad (+        -- The monad+        SimplM,+        initSmpl, traceSmpl,+        getSimplRules, getFamEnvs,++        -- Unique supply+        MonadUnique(..), newId,++        -- Counting+        SimplCount, tick, freeTick, checkedTick,+        getSimplCount, zeroSimplCount, pprSimplCount,+        plusSimplCount, isZeroSimplCount+    ) where++import Id               ( Id, mkSysLocalOrCoVar )+import Type             ( Type )+import FamInstEnv       ( FamInstEnv )+import CoreSyn          ( RuleEnv(..) )+import UniqSupply+import DynFlags+import CoreMonad+import Outputable+import FastString+import MonadUtils+import ErrUtils+import BasicTypes          ( IntWithInf, treatZeroAsInf, mkIntWithInf )+import Control.Monad       ( when, liftM, ap )++{-+************************************************************************+*                                                                      *+\subsection{Monad plumbing}+*                                                                      *+************************************************************************++For the simplifier monad, we want to {\em thread} a unique supply and a counter.+(Command-line switches move around through the explicitly-passed SimplEnv.)+-}++newtype SimplM result+  =  SM  { unSM :: SimplTopEnv  -- Envt that does not change much+                -> UniqSupply   -- We thread the unique supply because+                                -- constantly splitting it is rather expensive+                -> SimplCount+                -> IO (result, UniqSupply, SimplCount)}+  -- we only need IO here for dump output++data SimplTopEnv+  = STE { st_flags     :: DynFlags+        , st_max_ticks :: IntWithInf  -- Max #ticks in this simplifier run+        , st_rules     :: RuleEnv+        , st_fams      :: (FamInstEnv, FamInstEnv) }++initSmpl :: DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv)+         -> UniqSupply          -- No init count; set to 0+         -> Int                 -- Size of the bindings, used to limit+                                -- the number of ticks we allow+         -> SimplM a+         -> IO (a, SimplCount)++initSmpl dflags rules fam_envs us size m+  = do (result, _, count) <- unSM m env us (zeroSimplCount dflags)+       return (result, count)+  where+    env = STE { st_flags = dflags, st_rules = rules+              , st_max_ticks = computeMaxTicks dflags size+              , st_fams = fam_envs }++computeMaxTicks :: DynFlags -> Int -> IntWithInf+-- Compute the max simplifier ticks as+--     (base-size + pgm-size) * magic-multiplier * tick-factor/100+-- where+--    magic-multiplier is a constant that gives reasonable results+--    base-size is a constant to deal with size-zero programs+computeMaxTicks dflags size+  = treatZeroAsInf $+    fromInteger ((toInteger (size + base_size)+                  * toInteger (tick_factor * magic_multiplier))+          `div` 100)+  where+    tick_factor      = simplTickFactor dflags+    base_size        = 100+    magic_multiplier = 40+        -- MAGIC NUMBER, multiplies the simplTickFactor+        -- We can afford to be generous; this is really+        -- just checking for loops, and shouldn't usually fire+        -- A figure of 20 was too small: see Trac #5539.++{-# INLINE thenSmpl #-}+{-# INLINE thenSmpl_ #-}+{-# INLINE returnSmpl #-}+++instance Functor SimplM where+    fmap = liftM++instance Applicative SimplM where+    pure  = returnSmpl+    (<*>) = ap+    (*>)  = thenSmpl_++instance Monad SimplM where+   (>>)   = (*>)+   (>>=)  = thenSmpl++returnSmpl :: a -> SimplM a+returnSmpl e = SM (\_st_env us sc -> return (e, us, sc))++thenSmpl  :: SimplM a -> (a -> SimplM b) -> SimplM b+thenSmpl_ :: SimplM a -> SimplM b -> SimplM b++thenSmpl m k+  = SM $ \st_env us0 sc0 -> do+      (m_result, us1, sc1) <- unSM m st_env us0 sc0+      unSM (k m_result) st_env us1 sc1++thenSmpl_ m k+  = SM $ \st_env us0 sc0 -> do+      (_, us1, sc1) <- unSM m st_env us0 sc0+      unSM k st_env us1 sc1++-- TODO: this specializing is not allowed+-- {-# SPECIALIZE mapM         :: (a -> SimplM b) -> [a] -> SimplM [b] #-}+-- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-}+-- {-# SPECIALIZE mapAccumLM   :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-}++traceSmpl :: String -> SDoc -> SimplM ()+traceSmpl herald doc+  = do { dflags <- getDynFlags+       ; when (dopt Opt_D_dump_simpl_trace dflags) $ liftIO $+         printOutputForUser dflags alwaysQualify $+         hang (text herald) 2 doc }++{-+************************************************************************+*                                                                      *+\subsection{The unique supply}+*                                                                      *+************************************************************************+-}++instance MonadUnique SimplM where+    getUniqueSupplyM+       = SM (\_st_env us sc -> case splitUniqSupply us of+                                (us1, us2) -> return (us1, us2, sc))++    getUniqueM+       = SM (\_st_env us sc -> case takeUniqFromSupply us of+                                (u, us') -> return (u, us', sc))++    getUniquesM+        = SM (\_st_env us sc -> case splitUniqSupply us of+                                (us1, us2) -> return (uniqsFromSupply us1, us2, sc))++instance HasDynFlags SimplM where+    getDynFlags = SM (\st_env us sc -> return (st_flags st_env, us, sc))++instance MonadIO SimplM where+    liftIO m = SM $ \_ us sc -> do+      x <- m+      return (x, us, sc)++getSimplRules :: SimplM RuleEnv+getSimplRules = SM (\st_env us sc -> return (st_rules st_env, us, sc))++getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)+getFamEnvs = SM (\st_env us sc -> return (st_fams st_env, us, sc))++newId :: FastString -> Type -> SimplM Id+newId fs ty = do uniq <- getUniqueM+                 return (mkSysLocalOrCoVar fs uniq ty)++{-+************************************************************************+*                                                                      *+\subsection{Counting up what we've done}+*                                                                      *+************************************************************************+-}++getSimplCount :: SimplM SimplCount+getSimplCount = SM (\_st_env us sc -> return (sc, us, sc))++tick :: Tick -> SimplM ()+tick t = SM (\st_env us sc -> let sc' = doSimplTick (st_flags st_env) t sc+                              in sc' `seq` return ((), us, sc'))++checkedTick :: Tick -> SimplM ()+-- Try to take a tick, but fail if too many+checkedTick t+  = SM (\st_env us sc -> if st_max_ticks st_env <= mkIntWithInf (simplCountN sc)+                         then pprPanic "Simplifier ticks exhausted" (msg sc)+                         else let sc' = doSimplTick (st_flags st_env) t sc+                              in sc' `seq` return ((), us, sc'))+  where+    msg sc = vcat [ text "When trying" <+> ppr t+                  , text "To increase the limit, use -fsimpl-tick-factor=N (default 100)"+                  , text "If you need to do this, let GHC HQ know, and what factor you needed"+                  , pp_details sc+                  , pprSimplCount sc ]+    pp_details sc+      | hasDetailedCounts sc = empty+      | otherwise = text "To see detailed counts use -ddump-simpl-stats"+++freeTick :: Tick -> SimplM ()+-- Record a tick, but don't add to the total tick count, which is+-- used to decide when nothing further has happened+freeTick t+   = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc+                           in sc' `seq` return ((), us, sc'))
+ simplCore/SimplUtils.hs view
@@ -0,0 +1,2048 @@+{-+(c) The AQUA Project, Glasgow University, 1993-1998++\section[SimplUtils]{The simplifier utilities}+-}++{-# LANGUAGE CPP #-}++module SimplUtils (+        -- Rebuilding+        mkLam, mkCase, prepareAlts, tryEtaExpandRhs,++        -- Inlining,+        preInlineUnconditionally, postInlineUnconditionally,+        activeUnfolding, activeRule,+        getUnfoldingInRuleMatch,+        simplEnvForGHCi, updModeForStableUnfoldings, updModeForRules,++        -- The continuation type+        SimplCont(..), DupFlag(..),+        isSimplified,+        contIsDupable, contResultType, contHoleType,+        contIsTrivial, contArgs,+        countArgs,+        mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg,+        interestingCallContext,++        -- ArgInfo+        ArgInfo(..), ArgSpec(..), mkArgInfo,+        addValArgTo, addCastTo, addTyArgTo,+        argInfoExpr, argInfoAppArgs, pushSimplifiedArgs,++        abstractFloats+    ) where++#include "HsVersions.h"++import SimplEnv+import CoreMonad        ( SimplifierMode(..), Tick(..) )+import DynFlags+import CoreSyn+import qualified CoreSubst+import PprCore+import CoreFVs+import CoreUtils+import CoreArity+import CoreUnfold+import Name+import Id+import IdInfo+import Var+import Demand+import SimplMonad+import Type     hiding( substTy )+import Coercion hiding( substCo )+import DataCon          ( dataConWorkId )+import VarEnv+import VarSet+import BasicTypes+import Util+import MonadUtils+import Outputable+import Pair+import PrelRules+import Literal++import Control.Monad    ( when )+import Data.List        ( sortBy )++{-+************************************************************************+*                                                                      *+                The SimplCont and DupFlag types+*                                                                      *+************************************************************************++A SimplCont allows the simplifier to traverse the expression in a+zipper-like fashion.  The SimplCont represents the rest of the expression,+"above" the point of interest.++You can also think of a SimplCont as an "evaluation context", using+that term in the way it is used for operational semantics. This is the+way I usually think of it, For example you'll often see a syntax for+evaluation context looking like+        C ::= []  |  C e   |  case C of alts  |  C `cast` co+That's the kind of thing we are doing here, and I use that syntax in+the comments.+++Key points:+  * A SimplCont describes a *strict* context (just like+    evaluation contexts do).  E.g. Just [] is not a SimplCont++  * A SimplCont describes a context that *does not* bind+    any variables.  E.g. \x. [] is not a SimplCont+-}++data SimplCont+  = Stop                -- An empty context, or <hole>+        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            -- <hole> `cast` co+        OutCoercion             -- The coercion simplified+                                -- Invariant: never an identity coercion+        SimplCont++  | ApplyToVal {        -- <hole> arg+        sc_dup  :: DupFlag,          -- See Note [DupFlag invariants]+        sc_arg  :: InExpr,           -- The argument,+        sc_env  :: StaticEnv,        --     and its static env+        sc_cont :: SimplCont }++  | ApplyToTy {         -- <hole> ty+        sc_arg_ty  :: OutType,     -- Argument type+        sc_hole_ty :: OutType,     -- Type of the function, presumably (forall a. blah)+                                   -- See Note [The hole type in ApplyToTy]+        sc_cont    :: SimplCont }++  | Select {           -- case <hole> of alts+        sc_dup  :: DupFlag,                 -- See Note [DupFlag invariants]+        sc_bndr :: InId,                    -- case binder+        sc_alts :: [InAlt],                 -- Alternatives+        sc_env  ::  StaticEnv,              --   and their static environment+        sc_cont :: SimplCont }++  -- The two strict forms have no DupFlag, because we never duplicate them+  | StrictBind                  -- (\x* \xs. e) <hole>+        InId [InBndr]           -- let x* = <hole> in e+        InExpr StaticEnv        --      is a special case+        SimplCont++  | StrictArg           -- f e1 ..en <hole>+        ArgInfo         -- Specifies f, e1..en, Whether f has rules, etc+                        --     plus strictness flags for *further* args+        CallCtxt        -- Whether *this* argument position is interesting+        SimplCont++  | TickIt+        (Tickish Id)    -- Tick tickish <hole>+        SimplCont++data DupFlag = NoDup       -- Unsimplified, might be big+             | Simplified  -- Simplified+             | OkToDup     -- Simplified and small++isSimplified :: DupFlag -> Bool+isSimplified NoDup = False+isSimplified _     = True       -- Invariant: the subst-env is empty++perhapsSubstTy :: DupFlag -> StaticEnv -> Type -> Type+perhapsSubstTy dup env ty+  | isSimplified dup = ty+  | otherwise        = substTy env ty++{-+Note [DupFlag invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~+In both (ApplyToVal dup _ env k)+   and  (Select dup _ _ env k)+the following invariants hold++  (a) if dup = OkToDup, then continuation k is also ok-to-dup+  (b) if dup = OkToDup or Simplified, the subst-env is empty+      (and and hence no need to re-simplify)+-}++instance Outputable DupFlag where+  ppr OkToDup    = text "ok"+  ppr NoDup      = text "nodup"+  ppr Simplified = text "simpl"++instance Outputable SimplCont where+  ppr (Stop ty interesting) = text "Stop" <> brackets (ppr interesting) <+> ppr ty+  ppr (CastIt co cont  )    = (text "CastIt" <+> pprOptCo co) $$ ppr cont+  ppr (TickIt t cont)       = (text "TickIt" <+> ppr t) $$ ppr cont+  ppr (ApplyToTy  { sc_arg_ty = ty, sc_cont = cont })+    = (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont+  ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont })+    = (text "ApplyToVal" <+> ppr dup <+> pprParendExpr arg)+                                        $$ ppr cont+  ppr (StrictBind b _ _ _ cont)       = (text "StrictBind" <+> ppr b) $$ ppr cont+  ppr (StrictArg ai _ cont)           = (text "StrictArg" <+> ppr (ai_fun ai)) $$ ppr cont+  ppr (Select { sc_dup = dup, sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont })+    = (text "Select" <+> ppr dup <+> ppr bndr) $$+       ifPprDebug (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont+++{- Note [The hole type in ApplyToTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The sc_hole_ty field of ApplyToTy records the type of the "hole" in the+continuation.  It is absolutely necessary to compute contHoleType, but it is+not used for anything else (and hence may not be evaluated).++Why is it necessary for contHoleType?  Consider the continuation+     ApplyToType Int (Stop Int)+corresponding to+     (<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_type  :: OutType,    -- Type of (f a1 ... an)++        ai_rules :: FunRules,   -- Rules for this function++        ai_encl :: Bool,        -- Flag saying whether this function+                                -- or an enclosing one has rules (recursively)+                                --      True => be keener to inline in all args++        ai_strs :: [Bool],      -- Strictness of remaining arguments+                                --   Usually infinite, but if it is finite it guarantees+                                --   that the function diverges after being given+                                --   that number of args+        ai_discs :: [Int]       -- Discounts for remaining arguments; non-zero => be keener to inline+                                --   Always infinite+    }++data ArgSpec+  = ValArg OutExpr                    -- Apply to this (coercion or value); c.f. ApplyToVal+  | TyArg { as_arg_ty  :: OutType     -- Apply to this type; c.f. ApplyToTy+          , as_hole_ty :: OutType }   -- Type of the function (presumably forall a. blah)+  | CastBy OutCoercion                -- Cast by this; c.f. CastIt++instance Outputable ArgSpec where+  ppr (ValArg e)                 = text "ValArg" <+> ppr e+  ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty+  ppr (CastBy c)                 = text "CastBy" <+> ppr c++addValArgTo :: ArgInfo -> OutExpr -> ArgInfo+addValArgTo ai arg = ai { ai_args = ValArg arg : ai_args ai+                        , ai_type = applyTypeToArg (ai_type ai) arg+                        , ai_rules = decRules (ai_rules ai) }++addTyArgTo :: ArgInfo -> OutType -> ArgInfo+addTyArgTo ai arg_ty = ai { ai_args = arg_spec : ai_args ai+                          , ai_type = piResultTy poly_fun_ty arg_ty+                          , ai_rules = decRules (ai_rules ai) }+  where+    poly_fun_ty = ai_type ai+    arg_spec    = TyArg { as_arg_ty = arg_ty, as_hole_ty = poly_fun_ty }++addCastTo :: ArgInfo -> OutCoercion -> ArgInfo+addCastTo ai co = ai { ai_args = CastBy co : ai_args ai+                     , ai_type = pSnd (coercionKind co) }++argInfoAppArgs :: [ArgSpec] -> [OutExpr]+argInfoAppArgs []                              = []+argInfoAppArgs (CastBy {}                : _)  = []  -- Stop at a cast+argInfoAppArgs (ValArg e                 : as) = e       : argInfoAppArgs as+argInfoAppArgs (TyArg { as_arg_ty = ty } : as) = Type ty : argInfoAppArgs as++pushSimplifiedArgs :: SimplEnv -> [ArgSpec] -> SimplCont -> SimplCont+pushSimplifiedArgs _env []           k = k+pushSimplifiedArgs env  (arg : args) k+  = case arg of+      TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }+               -> ApplyToTy  { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = rest }+      ValArg e -> ApplyToVal { sc_arg = e, sc_env = env, sc_dup = Simplified, sc_cont = rest }+      CastBy c -> CastIt c rest+  where+    rest = pushSimplifiedArgs env args k+           -- The env has an empty SubstEnv++argInfoExpr :: OutId -> [ArgSpec] -> OutExpr+-- NB: the [ArgSpec] is reversed so that the first arg+-- in the list is the last one in the application+argInfoExpr fun rev_args+  = go rev_args+  where+    go []                              = Var fun+    go (ValArg a                 : as) = go as `App` a+    go (TyArg { as_arg_ty = ty } : as) = go as `App` Type ty+    go (CastBy co                : as) = mkCast (go as) co+++type FunRules = Maybe (Int, [CoreRule]) -- Remaining rules for this function+     -- Nothing => No rules+     -- Just (n, rules) => some rules, requiring at least n more type/value args++decRules :: FunRules -> FunRules+decRules (Just (n, rules)) = Just (n-1, rules)+decRules Nothing           = Nothing++mkFunRules :: [CoreRule] -> FunRules+mkFunRules [] = Nothing+mkFunRules rs = Just (n_required, rs)+  where+    n_required = maximum (map ruleArity rs)++{-+************************************************************************+*                                                                      *+                Functions on SimplCont+*                                                                      *+************************************************************************+-}++mkBoringStop :: OutType -> SimplCont+mkBoringStop ty = Stop ty BoringCtxt++mkRhsStop :: OutType -> SimplCont       -- See Note [RHS of lets] in CoreUnfold+mkRhsStop ty = Stop ty RhsCtxt++mkLazyArgStop :: OutType -> CallCtxt -> SimplCont+mkLazyArgStop ty cci = Stop ty cci++-------------------+contIsRhsOrArg :: SimplCont -> Bool+contIsRhsOrArg (Stop {})       = True+contIsRhsOrArg (StrictBind {}) = True+contIsRhsOrArg (StrictArg {})  = True+contIsRhsOrArg _               = False++contIsRhs :: SimplCont -> Bool+contIsRhs (Stop _ RhsCtxt) = True+contIsRhs _                = False++-------------------+contIsDupable :: SimplCont -> Bool+contIsDupable (Stop {})                         = True+contIsDupable (ApplyToTy  { sc_cont = k })      = contIsDupable k+contIsDupable (ApplyToVal { sc_dup = OkToDup }) = True -- See Note [DupFlag invariants]+contIsDupable (Select { sc_dup = OkToDup })     = True -- ...ditto...+contIsDupable (CastIt _ k)                      = contIsDupable k+contIsDupable _                                 = False++-------------------+contIsTrivial :: SimplCont -> Bool+contIsTrivial (Stop {})                                         = True+contIsTrivial (ApplyToTy { sc_cont = k })                       = contIsTrivial k+contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k+contIsTrivial (CastIt _ k)                                      = contIsTrivial k+contIsTrivial _                                                 = False++-------------------+contResultType :: SimplCont -> OutType+contResultType (Stop ty _)                  = ty+contResultType (CastIt _ k)                 = contResultType k+contResultType (StrictBind _ _ _ _ k)       = contResultType k+contResultType (StrictArg _ _ k)            = contResultType k+contResultType (Select { sc_cont = k })     = contResultType k+contResultType (ApplyToTy  { sc_cont = k }) = contResultType k+contResultType (ApplyToVal { sc_cont = k }) = contResultType k+contResultType (TickIt _ k)                 = contResultType k++contHoleType :: SimplCont -> OutType+contHoleType (Stop ty _)                      = ty+contHoleType (TickIt _ k)                     = contHoleType k+contHoleType (CastIt co _)                    = pFst (coercionKind co)+contHoleType (StrictBind b _ _ se _)          = substTy se (idType b)+contHoleType (StrictArg ai _ _)               = funArgTy (ai_type ai)+contHoleType (ApplyToTy  { sc_hole_ty = ty }) = ty  -- See Note [The hole type in ApplyToTy]+contHoleType (ApplyToVal { sc_arg = e, sc_env = se, sc_dup = dup, sc_cont = k })+  = mkFunTy (perhapsSubstTy dup se (exprType e))+            (contHoleType k)+contHoleType (Select { sc_dup = d, sc_bndr =  b, sc_env = se })+  = perhapsSubstTy d se (idType b)++-------------------+countArgs :: SimplCont -> Int+-- Count all arguments, including types, coercions, and other values+countArgs (ApplyToTy  { sc_cont = cont }) = 1 + countArgs cont+countArgs (ApplyToVal { sc_cont = cont }) = 1 + countArgs cont+countArgs _                               = 0++contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont)+-- Summarises value args, discards type args and coercions+-- The returned continuation of the call is only used to+-- answer questions like "are you interesting?"+contArgs cont+  | lone cont = (True, [], cont)+  | otherwise = go [] cont+  where+    lone (ApplyToTy  {}) = False  -- See Note [Lone variables] in CoreUnfold+    lone (ApplyToVal {}) = False+    lone (CastIt {})     = False+    lone _               = True++    go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k })+                                        = go (is_interesting arg se : args) k+    go args (ApplyToTy { sc_cont = k }) = go args k+    go args (CastIt _ k)                = go args k+    go args k                           = (False, reverse args, k)++    is_interesting arg se = interestingArg se arg+                   -- Do *not* use short-cutting substitution here+                   -- because we want to get as much IdInfo as possible+++-------------------+mkArgInfo :: Id+          -> [CoreRule] -- Rules for function+          -> Int        -- Number of value args+          -> SimplCont  -- Context of the call+          -> ArgInfo++mkArgInfo fun rules n_val_args call_cont+  | n_val_args < idArity fun            -- Note [Unsaturated functions]+  = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty+            , ai_rules = fun_rules, ai_encl = False+            , ai_strs = vanilla_stricts+            , ai_discs = vanilla_discounts }+  | otherwise+  = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty+            , ai_rules = fun_rules+            , ai_encl = interestingArgContext rules call_cont+            , ai_strs  = add_type_str fun_ty arg_stricts+            , ai_discs = arg_discounts }+  where+    fun_ty = idType fun++    fun_rules = mkFunRules rules++    vanilla_discounts, arg_discounts :: [Int]+    vanilla_discounts = repeat 0+    arg_discounts = case idUnfolding fun of+                        CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_args = discounts}}+                              -> discounts ++ vanilla_discounts+                        _     -> vanilla_discounts++    vanilla_stricts, arg_stricts :: [Bool]+    vanilla_stricts  = repeat False++    arg_stricts+      = case splitStrictSig (idStrictness fun) of+          (demands, result_info)+                | not (demands `lengthExceeds` n_val_args)+                ->      -- Enough args, use the strictness given.+                        -- For bottoming functions we used to pretend that the arg+                        -- is lazy, so that we don't treat the arg as an+                        -- interesting context.  This avoids substituting+                        -- top-level bindings for (say) strings into+                        -- calls to error.  But now we are more careful about+                        -- inlining lone variables, so its ok (see SimplUtils.analyseCont)+                   if isBotRes result_info then+                        map isStrictDmd demands         -- Finite => result is bottom+                   else+                        map isStrictDmd demands ++ vanilla_stricts+               | otherwise+               -> WARN( True, text "More demands than arity" <+> ppr fun <+> ppr (idArity fun)+                                <+> ppr n_val_args <+> ppr demands )+                   vanilla_stricts      -- Not enough args, or no strictness++    add_type_str :: Type -> [Bool] -> [Bool]+    -- If the function arg types are strict, record that in the 'strictness bits'+    -- No need to instantiate because unboxed types (which dominate the strict+    -- types) can't instantiate type variables.+    -- add_type_str is done repeatedly (for each call); might be better+    -- once-for-all in the function+    -- But beware primops/datacons with no strictness++    add_type_str+      = go+      where+        go _ [] = []+        go fun_ty strs            -- Look through foralls+            | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty       -- Includes coercions+            = go fun_ty' strs+        go fun_ty (str:strs)      -- Add strict-type info+            | Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty+            = (str || Just False == isLiftedType_maybe arg_ty) : go fun_ty' strs+               -- If the type is levity-polymorphic, we can't know whether it's+               -- strict. isLiftedType_maybe will return Just False only when+               -- we're sure the type is unlifted.+        go _ strs+            = strs++{- Note [Unsaturated functions]+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (test eyeball/inline4)+        x = a:as+        y = f x+where f has arity 2.  Then we do not want to inline 'x', because+it'll just be floated out again.  Even if f has lots of discounts+on its first argument -- it must be saturated for these to kick in+-}+++{-+************************************************************************+*                                                                      *+        Interesting arguments+*                                                                      *+************************************************************************++Note [Interesting call context]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to avoid inlining an expression where there can't possibly be+any gain, such as in an argument position.  Hence, if the continuation+is interesting (eg. a case scrutinee, application etc.) then we+inline, otherwise we don't.++Previously some_benefit used to return True only if the variable was+applied to some value arguments.  This didn't work:++        let x = _coerce_ (T Int) Int (I# 3) in+        case _coerce_ Int (T Int) x of+                I# y -> ....++we want to inline x, but can't see that it's a constructor in a case+scrutinee position, and some_benefit is False.++Another example:++dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)++....  case dMonadST _@_ x0 of (a,b,c) -> ....++we'd really like to inline dMonadST here, but we *don't* want to+inline if the case expression is just++        case x of y { DEFAULT -> ... }++since we can just eliminate this case instead (x is in WHNF).  Similar+applies when x is bound to a lambda expression.  Hence+contIsInteresting looks for case expressions with just a single+default case.+-}++interestingCallContext :: SimplCont -> CallCtxt+-- See Note [Interesting call context]+interestingCallContext cont+  = interesting cont+  where+    interesting (Select {})     = CaseCtxt+    interesting (ApplyToVal {}) = ValAppCtxt+        -- Can happen if we have (f Int |> co) y+        -- If f has an INLINE prag we need to give it some+        -- motivation to inline. See Note [Cast then apply]+        -- in CoreUnfold++    interesting (StrictArg _ BoringCtxt _)  = RhsCtxt+    interesting (StrictArg _ cci _)         = cci+    interesting (StrictBind {})             = BoringCtxt+    interesting (Stop _ cci)                = cci+    interesting (TickIt _ k)                = interesting k+    interesting (ApplyToTy { sc_cont = k }) = interesting k+    interesting (CastIt _ k)                = interesting k+        -- If this call is the arg of a strict function, the context+        -- is a bit interesting.  If we inline here, we may get useful+        -- evaluation information to avoid repeated evals: e.g.+        --      x + (y * z)+        -- Here the contIsInteresting makes the '*' keener to inline,+        -- which in turn exposes a constructor which makes the '+' inline.+        -- Assuming that +,* aren't small enough to inline regardless.+        --+        -- It's also very important to inline in a strict context for things+        -- like+        --              foldr k z (f x)+        -- Here, the context of (f x) is strict, and if f's unfolding is+        -- a build it's *great* to inline it here.  So we must ensure that+        -- the context for (f x) is not totally uninteresting.++interestingArgContext :: [CoreRule] -> SimplCont -> Bool+-- If the argument has form (f x y), where x,y are boring,+-- and f is marked INLINE, then we don't want to inline f.+-- But if the context of the argument is+--      g (f x y)+-- where g has rules, then we *do* want to inline f, in case it+-- exposes a rule that might fire.  Similarly, if the context is+--      h (g (f x x))+-- where h has rules, then we do want to inline f; hence the+-- call_cont argument to interestingArgContext+--+-- The ai-rules flag makes this happen; if it's+-- set, the inliner gets just enough keener to inline f+-- regardless of how boring f's arguments are, if it's marked INLINE+--+-- The alternative would be to *always* inline an INLINE function,+-- regardless of how boring its context is; but that seems overkill+-- For example, it'd mean that wrapper functions were always inlined+--+-- The call_cont passed to interestingArgContext is the context of+-- the call itself, e.g. g <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 _ cci _) = interesting cci+    go (StrictBind {})     = False      -- ??+    go (CastIt _ c)        = go c+    go (Stop _ cci)        = interesting cci+    go (TickIt _ c)        = go c++    interesting RuleArgCtxt = True+    interesting _           = False+++{- Note [Interesting arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+An argument is interesting if it deserves a discount for unfoldings+with a discount in that argument position.  The idea is to avoid+unfolding a function that is applied only to variables that have no+unfolding (i.e. they are probably lambda bound): f x y z There is+little point in inlining f here.++Generally, *values* (like (C a b) and (\x.e)) deserve discounts.  But+we must look through lets, eg (let x = e in C a b), because the let will+float, exposing the value, if we inline.  That makes it different to+exprIsHNF.++Before 2009 we said it was interesting if the argument had *any* structure+at all; i.e. (hasSomeUnfolding v).  But does too much inlining; see Trac #3016.++But we don't regard (f x y) as interesting, unless f is unsaturated.+If it's saturated and f hasn't inlined, then it's probably not going+to now!++Note [Conlike is interesting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+        f d = ...((*) d x y)...+        ... f (df d')...+where df is con-like. Then we'd really like to inline 'f' so that the+rule for (*) (df d) can fire.  To do this+  a) we give a discount for being an argument of a class-op (eg (*) d)+  b) we say that a con-like argument (eg (df d)) is interesting+-}++interestingArg :: SimplEnv -> CoreExpr -> ArgSummary+-- See Note [Interesting arguments]+interestingArg env e = go env 0 e+  where+    -- n is # value args to which the expression is applied+    go env n (Var v)+       | SimplEnv { seIdSubst = ids, seInScope = in_scope } <- env+       = case snd <$> lookupVarEnv ids v of+           Nothing                     -> go_var n (refineFromInScope in_scope v)+           Just (DoneId v')            -> go_var n (refineFromInScope in_scope v')+           Just (DoneEx e)             -> go (zapSubstEnv env)             n e+           Just (ContEx tvs cvs ids e) -> go (setSubstEnv env tvs cvs ids) n e++    go _   _ (Lit {})          = ValueArg+    go _   _ (Type _)          = TrivArg+    go _   _ (Coercion _)      = TrivArg+    go env n (App fn (Type _)) = go env n fn+    go env n (App fn _)        = go env (n+1) fn+    go env n (Tick _ a)        = go env n a+    go env n (Cast e _)        = go env n e+    go env n (Lam v e)+       | isTyVar v             = go env n e+       | n>0                   = NonTrivArg     -- (\x.b) e   is NonTriv+       | otherwise             = ValueArg+    go _ _ (Case {})           = NonTrivArg+    go env n (Let b e)         = case go env' n e of+                                   ValueArg -> ValueArg+                                   _        -> NonTrivArg+                               where+                                 env' = env `addNewInScopeIds` bindersOf b++    go_var n v+       | isConLikeId v     = ValueArg   -- Experimenting with 'conlike' rather that+                                        --    data constructors here+       | idArity v > n     = ValueArg   -- Catches (eg) primops with arity but no unfolding+       | n > 0             = NonTrivArg -- Saturated or unknown call+       | conlike_unfolding = ValueArg   -- n==0; look for an interesting unfolding+                                        -- See Note [Conlike is interesting]+       | otherwise         = TrivArg    -- n==0, no useful unfolding+       where+         conlike_unfolding = isConLikeUnfolding (idUnfolding v)++{-+************************************************************************+*                                                                      *+                  SimplifierMode+*                                                                      *+************************************************************************++The SimplifierMode controls several switches; see its definition in+CoreMonad+        sm_rules      :: Bool     -- Whether RULES are enabled+        sm_inline     :: Bool     -- Whether inlining is enabled+        sm_case_case  :: Bool     -- Whether case-of-case is enabled+        sm_eta_expand :: Bool     -- Whether eta-expansion is enabled+-}++simplEnvForGHCi :: DynFlags -> SimplEnv+simplEnvForGHCi dflags+  = mkSimplEnv $ SimplMode { sm_names = ["GHCi"]+                           , sm_phase = InitialPhase+                           , sm_rules = rules_on+                           , sm_inline = False+                           , sm_eta_expand = eta_expand_on+                           , sm_case_case = True }+  where+    rules_on      = gopt Opt_EnableRewriteRules   dflags+    eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags+   -- Do not do any inlining, in case we expose some unboxed+   -- tuple stuff that confuses the bytecode interpreter++updModeForStableUnfoldings :: Activation -> SimplifierMode -> SimplifierMode+-- See Note [Simplifying inside stable unfoldings]+updModeForStableUnfoldings inline_rule_act current_mode+  = current_mode { sm_phase      = phaseFromActivation inline_rule_act+                 , sm_inline     = True+                 , sm_eta_expand = False }+                     -- sm_eta_expand: see Note [No eta expansion in stable unfoldings]+       -- For sm_rules, just inherit; sm_rules might be "off"+       -- because of -fno-enable-rewrite-rules+  where+    phaseFromActivation (ActiveAfter _ n) = Phase n+    phaseFromActivation _                 = InitialPhase++updModeForRules :: SimplifierMode -> SimplifierMode+-- See Note [Simplifying rules]+updModeForRules current_mode+  = current_mode { sm_phase  = InitialPhase+                 , sm_inline = False+                 , sm_rules  = False+                 , sm_eta_expand = False }++{- Note [Simplifying rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When simplifying a rule LHS, refrain from /any/ inlining or applying+of other RULES.++Doing anything to the LHS is plain confusing, because it means that what the+rule matches is not what the user wrote. c.f. Trac #10595, and #10528.+Moreover, inlining (or applying rules) on rule LHSs risks introducing+Ticks into the LHS, which makes matching trickier. Trac #10665, #10745.++Doing this to either side confounds tools like HERMIT, which seek to reason+about and apply the RULES as originally written. See Trac #10829.++Note [No eta expansion in stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have a stable unfolding++  f :: Ord a => a -> IO ()+  -- Unfolding template+  --    = /\a \(d:Ord a) (x:a). bla++we do not want to eta-expand to++  f :: Ord a => a -> IO ()+  -- Unfolding template+  --    = (/\a \(d:Ord a) (x:a) (eta:State#). bla eta) |> co++because not specialisation of the overloading doesn't work properly+(see Note [Specialisation shape] in Specialise), Trac #9509.++So we disable eta-expansion in stable unfoldings.++Note [Inlining in gentle mode]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Something is inlined if+   (i)   the sm_inline flag is on, AND+   (ii)  the thing has an INLINE pragma, AND+   (iii) the thing is inlinable in the earliest phase.++Example of why (iii) is important:+  {-# INLINE [~1] g #-}+  g = ...++  {-# INLINE f #-}+  f x = g (g x)++If we were to inline g into f's inlining, then an importing module would+never be able to do+        f e --> g (g e) ---> RULE fires+because the stable unfolding for f has had g inlined into it.++On the other hand, it is bad not to do ANY inlining into an+stable unfolding, because then recursive knots in instance declarations+don't get unravelled.++However, *sometimes* SimplGently must do no call-site inlining at all+(hence sm_inline = False).  Before full laziness we must be careful+not to inline wrappers, because doing so inhibits floating+    e.g. ...(case f x of ...)...+    ==> ...(case (case x of I# x# -> fw x#) of ...)...+    ==> ...(case x of I# x# -> case fw x# of ...)...+and now the redex (f x) isn't floatable any more.++The no-inlining thing is also important for Template Haskell.  You might be+compiling in one-shot mode with -O2; but when TH compiles a splice before+running it, we don't want to use -O2.  Indeed, we don't want to inline+anything, because the byte-code interpreter might get confused about+unboxed tuples and suchlike.++Note [Simplifying inside stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must take care with simplification inside stable unfoldings (which come from+INLINE pragmas).++First, consider the following example+        let f = \pq -> BIG+        in+        let g = \y -> f y y+            {-# INLINE g #-}+        in ...g...g...g...g...g...+Now, if that's the ONLY occurrence of f, it might be inlined inside g,+and thence copied multiple times when g is inlined. HENCE we treat+any occurrence in a stable unfolding as a multiple occurrence, not a single+one; see OccurAnal.addRuleUsage.++Second, we do want *do* to some modest rules/inlining stuff in stable+unfoldings, partly to eliminate senseless crap, and partly to break+the recursive knots generated by instance declarations.++However, suppose we have+        {-# INLINE <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 an stable unfolding, set the phase+  to the phase in which the stable unfolding first becomes active+  -------------------------------------------------------------++That ensures that++  a) Rules/inlinings that *cease* being active before p will+     not apply to the stable unfolding, consistent with it being+     inlined in its *original* form in phase p.++  b) Rules/inlinings that only become active *after* p will+     not apply to the stable unfolding, again to be consistent with+     inlining the *original* rhs in phase p.++For example,+        {-# INLINE f #-}+        f x = ...g...++        {-# NOINLINE [1] g #-}+        g y = ...++        {-# RULE h g = ... #-}+Here we must not inline g into f's RHS, even when we get to phase 0,+because when f is later inlined into some other module we want the+rule for h to fire.++Similarly, consider+        {-# INLINE f #-}+        f x = ...g...++        g y = ...+and suppose that there are auto-generated specialisations and a strictness+wrapper for g.  The specialisations get activation AlwaysActive, and the+strictness wrapper get activation (ActiveAfter 0).  So the strictness+wrepper fails the test and won't be inlined into f's stable unfolding. That+means f can inline, expose the specialised call to g, so the specialisation+rules can fire.++A note about wrappers+~~~~~~~~~~~~~~~~~~~~~+It's also important not to inline a worker back into a wrapper.+A wrapper looks like+        wraper = inline_me (\x -> ...worker... )+Normally, the inline_me prevents the worker getting inlined into+the wrapper (initially, the worker's only call site!).  But,+if the wrapper is sure to be called, the strictness analyser will+mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf+continuation.+-}++activeUnfolding :: SimplEnv -> Id -> Bool+activeUnfolding env id+  | isCompulsoryUnfolding (realIdUnfolding id)+  = True   -- Even sm_inline can't override compulsory unfoldings+  | otherwise+  = isActive (sm_phase mode) (idInlineActivation id)+  && sm_inline mode+      -- `or` isStableUnfolding (realIdUnfolding id)+      -- Inline things when+      --  (a) they are active+      --  (b) sm_inline says so, except that for stable unfoldings+      --                         (ie pragmas) we inline anyway+  where+    mode = getMode env++getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv+-- When matching in RULE, we want to "look through" an unfolding+-- (to see a constructor) if *rules* are on, even if *inlinings*+-- are not.  A notable example is DFuns, which really we want to+-- match in rules like (op dfun) in gentle mode. Another example+-- is 'otherwise' which we want exprIsConApp_maybe to be able to+-- see very early on+getUnfoldingInRuleMatch env+  = (in_scope, id_unf)+  where+    in_scope = seInScope env+    mode = getMode env+    id_unf id | unf_is_active id = idUnfolding id+              | otherwise        = NoUnfolding+    unf_is_active id+     | not (sm_rules mode) = -- active_unfolding_minimal id+                             isStableUnfolding (realIdUnfolding id)+        -- Do we even need to test this?  I think this InScopeEnv+        -- is only consulted if activeRule returns True, which+        -- never happens if sm_rules is False+     | otherwise           = isActive (sm_phase mode) (idInlineActivation id)++----------------------+activeRule :: SimplEnv -> Activation -> Bool+-- Nothing => No rules at all+activeRule env+  | not (sm_rules mode) = \_ -> False     -- Rewriting is off+  | otherwise           = isActive (sm_phase mode)+  where+    mode = getMode env++{-+************************************************************************+*                                                                      *+                  preInlineUnconditionally+*                                                                      *+************************************************************************++preInlineUnconditionally+~~~~~~~~~~~~~~~~~~~~~~~~+@preInlineUnconditionally@ examines a bndr to see if it is used just+once in a completely safe way, so that it is safe to discard the+binding inline its RHS at the (unique) usage site, REGARDLESS of how+big the RHS might be.  If this is the case we don't simplify the RHS+first, but just inline it un-simplified.++This is much better than first simplifying a perhaps-huge RHS and then+inlining and re-simplifying it.  Indeed, it can be at least quadratically+better.  Consider++        x1 = e1+        x2 = e2[x1]+        x3 = e3[x2]+        ...etc...+        xN = eN[xN-1]++We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc.+This can happen with cascades of functions too:++        f1 = \x1.e1+        f2 = \xs.e2[f1]+        f3 = \xs.e3[f3]+        ...etc...++THE MAIN INVARIANT is this:++        ----  preInlineUnconditionally invariant -----+   IF preInlineUnconditionally chooses to inline x = <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 occurrenc of x.+++Even RHSs labelled InlineMe aren't caught here, because there might be+no benefit from inlining at the call site.++[Sept 01] Don't unconditionally inline a top-level thing, because that+can simply make a static thing into something built dynamically.  E.g.+        x = (a,b)+        main = \s -> h x++[Remember that we treat \s as a one-shot lambda.]  No point in+inlining x unless there is something interesting about the call site.++But watch out: if you aren't careful, some useful foldr/build fusion+can be lost (most notably in spectral/hartel/parstof) because the+foldr didn't see the build.  Doing the dynamic allocation isn't a big+deal, in fact, but losing the fusion can be.  But the right thing here+seems to be to do a callSiteInline based on the fact that there is+something interesting about the call site (it's strict).  Hmm.  That+seems a bit fragile.++Conclusion: inline top level things gaily until Phase 0 (the last+phase), at which point don't.++Note [pre/postInlineUnconditionally in gentle mode]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Even in gentle mode we want to do preInlineUnconditionally.  The+reason is that too little clean-up happens if you don't inline+use-once things.  Also a bit of inlining is *good* for full laziness;+it can expose constant sub-expressions.  Example in+spectral/mandel/Mandel.hs, where the mandelset function gets a useful+let-float if you inline windowToViewport++However, as usual for Gentle mode, do not inline things that are+inactive in the intial stages.  See Note [Gentle mode].++Note [Stable unfoldings and preInlineUnconditionally]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Surprisingly, do not pre-inline-unconditionally Ids with INLINE pragmas!+Example++   {-# INLINE f #-}+   f :: Eq a => a -> a+   f x = ...++   fInt :: Int -> Int+   fInt = f Int dEqInt++   ...fInt...fInt...fInt...++Here f occurs just once, in the RHS of fInt. But if we inline it there+it might make fInt look big, and we'll lose the opportunity to inline f+at each of fInt's call sites.  The INLINE pragma will only inline when+the application is saturated for exactly this reason; and we don't+want PreInlineUnconditionally to second-guess it.  A live example is+Trac #3736.+    c.f. Note [Stable unfoldings and postInlineUnconditionally]++Note [Top-level bottoming Ids]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Don't inline top-level Ids that are bottoming, even if they are used just+once, because FloatOut has gone to some trouble to extract them out.+Inlining them won't make the program run faster!++Note [Do not inline CoVars unconditionally]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Coercion variables appear inside coercions, and the RHS of a let-binding+is a term (not a coercion) so we can't necessarily inline the latter in+the former.+-}++preInlineUnconditionally :: DynFlags -> SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool+-- Precondition: rhs satisfies the let/app invariant+-- See Note [CoreSyn let/app invariant] in CoreSyn+-- Reason: we don't want to inline single uses, or discard dead bindings,+--         for unlifted, side-effect-ful bindings+preInlineUnconditionally dflags env top_lvl bndr rhs+  | not active                               = False+  | isStableUnfolding (idUnfolding bndr)     = False -- Note [Stable unfoldings and preInlineUnconditionally]+  | isTopLevel top_lvl && isBottomingId bndr = False -- Note [Top-level bottoming Ids]+  | not (gopt Opt_SimplPreInlining dflags)   = False+  | isCoVar bndr                             = False -- Note [Do not inline CoVars unconditionally]+  | otherwise = case idOccInfo bndr of+                  IAmDead                    -> True -- Happens in ((\x.1) v)+                  occ@OneOcc { occ_one_br = True }+                                             -> try_once (occ_in_lam occ)+                                                         (occ_int_cxt occ)+                  _                          -> False+  where+    mode = getMode env+    active = isActive (sm_phase mode) act+             -- See Note [pre/postInlineUnconditionally in gentle mode]+    act = idInlineActivation bndr+    try_once in_lam int_cxt     -- There's one textual occurrence+        | not in_lam = isNotTopLevel top_lvl || early_phase+        | otherwise  = int_cxt && canInlineInLam rhs++-- Be very careful before inlining inside a lambda, because (a) we must not+-- invalidate occurrence information, and (b) we want to avoid pushing a+-- single allocation (here) into multiple allocations (inside lambda).+-- Inlining a *function* with a single *saturated* call would be ok, mind you.+--      || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok)+--      where+--              is_cheap = exprIsCheap rhs+--              ok = is_cheap && int_cxt++        --      int_cxt         The context isn't totally boring+        -- E.g. let f = \ab.BIG in \y. map f xs+        --      Don't want to substitute for f, because then we allocate+        --      its closure every time the \y is called+        -- But: let f = \ab.BIG in \y. map (f y) xs+        --      Now we do want to substitute for f, even though it's not+        --      saturated, because we're going to allocate a closure for+        --      (f y) every time round the loop anyhow.++        -- canInlineInLam => free vars of rhs are (Once in_lam) or Many,+        -- so substituting rhs inside a lambda doesn't change the occ info.+        -- Sadly, not quite the same as exprIsHNF.+    canInlineInLam (Lit _)    = True+    canInlineInLam (Lam b e)  = isRuntimeVar b || canInlineInLam e+    canInlineInLam (Tick t e) = not (tickishIsCode t) && canInlineInLam e+    canInlineInLam _          = False+      -- not ticks.  Counting ticks cannot be duplicated, and non-counting+      -- ticks around a Lam will disappear anyway.++    early_phase = case sm_phase mode of+                    Phase 0 -> False+                    _       -> True+-- If we don't have this early_phase test, consider+--      x = length [1,2,3]+-- The full laziness pass carefully floats all the cons cells to+-- top level, and preInlineUnconditionally floats them all back in.+-- Result is (a) static allocation replaced by dynamic allocation+--           (b) many simplifier iterations because this tickles+--               a related problem; only one inlining per pass+--+-- On the other hand, I have seen cases where top-level fusion is+-- lost if we don't inline top level thing (e.g. string constants)+-- Hence the test for phase zero (which is the phase for all the final+-- simplifications).  Until phase zero we take no special notice of+-- top level things, but then we become more leery about inlining+-- them.++{-+************************************************************************+*                                                                      *+                  postInlineUnconditionally+*                                                                      *+************************************************************************++postInlineUnconditionally+~~~~~~~~~~~~~~~~~~~~~~~~~+@postInlineUnconditionally@ decides whether to unconditionally inline+a thing based on the form of its RHS; in particular if it has a+trivial RHS.  If so, we can inline and discard the binding altogether.++NB: a loop breaker has must_keep_binding = True and non-loop-breakers+only have *forward* references. Hence, it's safe to discard the binding++NOTE: This isn't our last opportunity to inline.  We're at the binding+site right now, and we'll get another opportunity when we get to the+occurrence(s)++Note that we do this unconditional inlining only for trival RHSs.+Don't inline even WHNFs inside lambdas; doing so may simply increase+allocation when the function is called. This isn't the last chance; see+NOTE above.++NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?+Because we don't even want to inline them into the RHS of constructor+arguments. See NOTE above++NB: At one time even NOINLINE was ignored here: if the rhs is trivial+it's best to inline it anyway.  We often get a=E; b=a from desugaring,+with both a and b marked NOINLINE.  But that seems incompatible with+our new view that inlining is like a RULE, so I'm sticking to the 'active'+story for now.+-}++postInlineUnconditionally+    :: DynFlags -> SimplEnv -> TopLevelFlag+    -> OutId            -- The binder (an InId would be fine too)+                        --            (*not* a CoVar)+    -> OccInfo          -- From the InId+    -> OutExpr+    -> Unfolding+    -> Bool+-- Precondition: rhs satisfies the let/app invariant+-- See Note [CoreSyn let/app invariant] in CoreSyn+-- Reason: we don't want to inline single uses, or discard dead bindings,+--         for unlifted, side-effect-ful bindings+postInlineUnconditionally dflags env top_lvl bndr occ_info rhs unfolding+  | not active                  = False+  | isWeakLoopBreaker occ_info  = False -- If it's a loop-breaker of any kind, don't inline+                                        -- because it might be referred to "earlier"+  | isStableUnfolding unfolding = False -- Note [Stable unfoldings and postInlineUnconditionally]+  | isTopLevel top_lvl          = False -- Note [Top level and postInlineUnconditionally]+  | exprIsTrivial rhs           = True+  | otherwise+  = case occ_info of+        -- The point of examining occ_info here is that for *non-values*+        -- that occur outside a lambda, the call-site inliner won't have+        -- a chance (because it doesn't know that the thing+        -- only occurs once).   The pre-inliner won't have gotten+        -- it either, if the thing occurs in more than one branch+        -- So the main target is things like+        --      let x = f y in+        --      case v of+        --         True  -> case x of ...+        --         False -> case x of ...+        -- This is very important in practice; e.g. wheel-seive1 doubles+        -- in allocation if you miss this out+      OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt }+               -- OneOcc => no code-duplication issue+        ->     smallEnoughToInline dflags unfolding     -- Small enough to dup+                        -- ToDo: consider discount on smallEnoughToInline if int_cxt is true+                        --+                        -- NB: Do NOT inline arbitrarily big things, even if one_br is True+                        -- Reason: doing so risks exponential behaviour.  We simplify a big+                        --         expression, inline it, and simplify it again.  But if the+                        --         very same thing happens in the big expression, we get+                        --         exponential cost!+                        -- PRINCIPLE: when we've already simplified an expression once,+                        -- make sure that we only inline it if it's reasonably small.++           && (not in_lam ||+                        -- Outside a lambda, we want to be reasonably aggressive+                        -- about inlining into multiple branches of case+                        -- e.g. let x = <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))+                        -- isCheap => acceptable work duplication; in_lam may be true+                        -- int_cxt to prevent us inlining inside a lambda without some+                        -- good reason.  See the notes on int_cxt in preInlineUnconditionally++      IAmDead -> True   -- This happens; for example, the case_bndr during case of+                        -- known constructor:  case (a,b) of x { (p,q) -> ... }+                        -- Here x isn't mentioned in the RHS, so we don't want to+                        -- create the (dead) let-binding  let x = (a,b) in ...++      _ -> False++-- Here's an example that we don't handle well:+--      let f = if b then Left (\x.BIG) else Right (\y.BIG)+--      in \y. ....case f of {...} ....+-- Here f is used just once, and duplicating the case work is fine (exprIsCheap).+-- But+--  - We can't preInlineUnconditionally because that woud invalidate+--    the occ info for b.+--  - We can't postInlineUnconditionally because the RHS is big, and+--    that risks exponential behaviour+--  - We can't call-site inline, because the rhs is big+-- Alas!++  where+    active = isActive (sm_phase (getMode env)) (idInlineActivation bndr)+        -- See Note [pre/postInlineUnconditionally in gentle mode]++{-+Note [Top level and postInlineUnconditionally]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don't do postInlineUnconditionally for top-level things (even for+ones that are trivial):++  * Doing so will inline top-level error expressions that have been+    carefully floated out by FloatOut.  More generally, it might+    replace static allocation with dynamic.++  * Even for trivial expressions there's a problem.  Consider+      {-# RULE "foo" forall (xs::[T]). reverse xs = ruggle xs #-}+      blah xs = reverse xs+      ruggle = sort+    In one simplifier pass we might fire the rule, getting+      blah xs = ruggle xs+    but in *that* simplifier pass we must not do postInlineUnconditionally+    on 'ruggle' because then we'll have an unbound occurrence of 'ruggle'++    If the rhs is trivial it'll be inlined by callSiteInline, and then+    the binding will be dead and discarded by the next use of OccurAnal++  * There is less point, because the main goal is to get rid of local+    bindings used in multiple case branches.++  * The inliner should inline trivial things at call sites anyway.++  * The Id might be exported.  We could check for that separately,+    but since we aren't going to postInlineUnconditionally /any/+    top-level bindings, we don't need to test.++Note [Stable unfoldings and postInlineUnconditionally]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Do not do postInlineUnconditionally if the Id has an stable unfolding,+otherwise we lose the unfolding.  Example++     -- f has stable unfolding with rhs (e |> co)+     --   where 'e' is big+     f = e |> co++Then there's a danger we'll optimise to++     f' = e+     f = f' |> co++and now postInlineUnconditionally, losing the stable unfolding on f.  Now f'+won't inline because 'e' is too big.++    c.f. Note [Stable unfoldings and preInlineUnconditionally]+++************************************************************************+*                                                                      *+        Rebuilding a lambda+*                                                                      *+************************************************************************+-}++mkLam :: SimplEnv -> [OutBndr] -> OutExpr -> SimplCont -> SimplM OutExpr+-- mkLam tries three things+--      a) eta reduction, if that gives a trivial expression+--      b) eta expansion [only if there are some value lambdas]++mkLam _env [] body _cont+  = return body+mkLam env bndrs body cont+  = do { dflags <- getDynFlags+       ; mkLam' dflags bndrs body }+  where+    mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr+    mkLam' dflags bndrs (Cast body co)+      | not (any bad bndrs)+        -- Note [Casts and lambdas]+      = do { lam <- mkLam' dflags bndrs body+           ; return (mkCast lam (mkPiCos Representational bndrs co)) }+      where+        co_vars  = tyCoVarsOfCo co+        bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars++    mkLam' dflags bndrs body@(Lam {})+      = mkLam' dflags (bndrs ++ bndrs1) body1+      where+        (bndrs1, body1) = collectBinders body++    mkLam' dflags bndrs (Tick t expr)+      | tickishFloatable t+      = mkTick t <$> mkLam' dflags bndrs expr++    mkLam' dflags bndrs body+      | gopt Opt_DoEtaReduction dflags+      , Just etad_lam <- tryEtaReduce bndrs body+      = do { tick (EtaReduction (head bndrs))+           ; return etad_lam }++      | not (contIsRhs cont)   -- See Note [Eta-expanding lambdas]+      , sm_eta_expand (getMode env)+      , any isRuntimeVar bndrs+      , let body_arity = exprEtaExpandArity dflags body+      , body_arity > 0+      = do { tick (EtaExpansion (head bndrs))+           ; let res = mkLams bndrs (etaExpand body_arity body)+           ; traceSmpl "eta expand" (vcat [text "before" <+> ppr (mkLams bndrs body)+                                          , text "after" <+> ppr res])+           ; return res }++      | otherwise+      = return (mkLams bndrs body)++{-+Note [Eta expanding lambdas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general we *do* want to eta-expand lambdas. Consider+   f (\x -> case x of (a,b) -> \s -> blah)+where 's' is a state token, and hence can be eta expanded.  This+showed up in the code for GHc.IO.Handle.Text.hPutChar, a rather+important function!++The eta-expansion will never happen unless we do it now.  (Well, it's+possible that CorePrep will do it, but CorePrep only has a half-baked+eta-expander that can't deal with casts.  So it's much better to do it+here.)++However, when the lambda is let-bound, as the RHS of a let, we have a+better eta-expander (in the form of tryEtaExpandRhs), so we don't+bother to try expansion in mkLam in that case; hence the contIsRhs+guard.++NB: We check the SimplEnv (sm_eta_expand), not DynFlags.+    See Note [No eta expansion in stable unfoldings]++Note [Casts and lambdas]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider+        (\x. (\y. e) `cast` g1) `cast` g2+There is a danger here that the two lambdas look separated, and the+full laziness pass might float an expression to between the two.++So this equation in mkLam' floats the g1 out, thus:+        (\x. e `cast` g1)  -->  (\x.e) `cast` (tx -> g1)+where x:tx.++In general, this floats casts outside lambdas, where (I hope) they+might meet and cancel with some other cast:+        \x. e `cast` co   ===>   (\x. e) `cast` (tx -> co)+        /\a. e `cast` co  ===>   (/\a. e) `cast` (/\a. co)+        /\g. e `cast` co  ===>   (/\g. e) `cast` (/\g. co)+                          (if not (g `in` co))++Notice that it works regardless of 'e'.  Originally it worked only+if 'e' was itself a lambda, but in some cases that resulted in+fruitless iteration in the simplifier.  A good example was when+compiling Text.ParserCombinators.ReadPrec, where we had a definition+like    (\x. Get `cast` g)+where Get is a constructor with nonzero arity.  Then mkLam eta-expanded+the Get, and the next iteration eta-reduced it, and then eta-expanded+it again.++Note also the side condition for the case of coercion binders.+It does not make sense to transform+        /\g. e `cast` g  ==>  (/\g.e) `cast` (/\g.g)+because the latter is not well-kinded.++************************************************************************+*                                                                      *+              Eta expansion+*                                                                      *+************************************************************************+-}++tryEtaExpandRhs :: SimplEnv -> RecFlag -> OutId -> OutExpr+                -> SimplM (Arity, OutExpr)+-- See Note [Eta-expanding at let bindings]+tryEtaExpandRhs env is_rec bndr rhs+  = do { dflags <- getDynFlags+       ; (new_arity, new_rhs) <- try_expand dflags++       ; WARN( new_arity < old_id_arity,+               (text "Arity decrease:" <+> (ppr bndr <+> ppr old_id_arity+                <+> ppr old_arity <+> ppr new_arity) $$ ppr new_rhs) )+                        -- Note [Arity decrease] in Simplify+         return (new_arity, new_rhs) }+  where+    try_expand dflags+      | exprIsTrivial rhs+      = return (exprArity rhs, rhs)++      | sm_eta_expand (getMode env)      -- Provided eta-expansion is on+      , let new_arity1 = findRhsArity dflags bndr rhs old_arity+            new_arity2 = idCallArity bndr+            new_arity  = max new_arity1 new_arity2+      , new_arity > old_arity      -- And the current manifest arity isn't enough+      = if is_rec == Recursive && isJoinId bndr+           then WARN(True, text "Can't eta-expand recursive join point:" <+>+                             ppr bndr)+                return (old_arity, rhs)+           else do { tick (EtaExpansion bndr)+                   ; return (new_arity, etaExpand new_arity rhs) }+      | otherwise+      = return (old_arity, rhs)++    old_arity    = exprArity rhs -- See Note [Do not expand eta-expand PAPs]+    old_id_arity = idArity bndr++{-+Note [Eta-expanding at let bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We now eta expand at let-bindings, which is where the payoff comes.+The most significant thing is that we can do a simple arity analysis+(in CoreArity.findRhsArity), which we can't do for free-floating lambdas++One useful consequence of not eta-expanding lambdas is this example:+   genMap :: C a => ...+   {-# INLINE genMap #-}+   genMap f xs = ...++   myMap :: D a => ...+   {-# INLINE myMap #-}+   myMap = genMap++Notice that 'genMap' should only inline if applied to two arguments.+In the stable unfolding for myMap we'll have the unfolding+    (\d -> genMap Int (..d..))+We do not want to eta-expand to+    (\d f xs -> genMap Int (..d..) f xs)+because then 'genMap' will inline, and it really shouldn't: at least+as far as the programmer is concerned, it's not applied to two+arguments!++Note [Do not eta-expand PAPs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to have old_arity = manifestArity rhs, which meant that we+would eta-expand even PAPs.  But this gives no particular advantage,+and can lead to a massive blow-up in code size, exhibited by Trac #9020.+Suppose we have a PAP+    foo :: IO ()+    foo = returnIO ()+Then we can eta-expand do+    foo = (\eta. (returnIO () |> sym g) eta) |> g+where+    g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #)++But there is really no point in doing this, and it generates masses of+coercions and whatnot that eventually disappear again. For T9020, GHC+allocated 6.6G beore, and 0.8G afterwards; and residency dropped from+1.8G to 45M.++But note that this won't eta-expand, say+  f = \g -> map g+Does it matter not eta-expanding such functions?  I'm not sure.  Perhaps+strictness analysis will have less to bite on?+++************************************************************************+*                                                                      *+\subsection{Floating lets out of big lambdas}+*                                                                      *+************************************************************************++Note [Floating and type abstraction]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:+        x = /\a. C e1 e2+We'd like to float this to+        y1 = /\a. e1+        y2 = /\a. e2+        x  = /\a. C (y1 a) (y2 a)+for the usual reasons: we want to inline x rather vigorously.++You may think that this kind of thing is rare.  But in some programs it is+common.  For example, if you do closure conversion you might get:++        data a :-> b = forall e. (e -> a -> b) :$ e++        f_cc :: forall a. a :-> a+        f_cc = /\a. (\e. id a) :$ ()++Now we really want to inline that f_cc thing so that the+construction of the closure goes away.++So I have elaborated simplLazyBind to understand right-hand sides that look+like+        /\ a1..an. body++and treat them specially. The real work is done in SimplUtils.abstractFloats,+but there is quite a bit of plumbing in simplLazyBind as well.++The same transformation is good when there are lets in the body:++        /\abc -> let(rec) x = e in b+   ==>+        let(rec) x' = /\abc -> let x = x' a b c in e+        in+        /\abc -> let x = x' a b c in b++This is good because it can turn things like:++        let f = /\a -> letrec g = ... g ... in g+into+        letrec g' = /\a -> ... g' a ...+        in+        let f = /\ a -> g' a++which is better.  In effect, it means that big lambdas don't impede+let-floating.++This optimisation is CRUCIAL in eliminating the junk introduced by+desugaring mutually recursive definitions.  Don't eliminate it lightly!++[May 1999]  If we do this transformation *regardless* then we can+end up with some pretty silly stuff.  For example,++        let+            st = /\ s -> let { x1=r1 ; x2=r2 } in ...+        in ..+becomes+        let y1 = /\s -> r1+            y2 = /\s -> r2+            st = /\s -> ...[y1 s/x1, y2 s/x2]+        in ..++Unless the "..." is a WHNF there is really no point in doing this.+Indeed it can make things worse.  Suppose x1 is used strictly,+and is of the form++        x1* = case f y of { (a,b) -> e }++If we abstract this wrt the tyvar we then can't do the case inline+as we would normally do.++That's why the whole transformation is part of the same process that+floats let-bindings and constructor arguments out of RHSs.  In particular,+it is guarded by the doFloatFromRhs call in simplLazyBind.++Note [Which type variables to abstract over]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Abstract only over the type variables free in the rhs wrt which the+new binding is abstracted.  Note that++  * The naive approach of abstracting wrt the+    tyvars free in the Id's /type/ fails. Consider:+        /\ a b -> let t :: (a,b) = (e1, e2)+                      x :: a     = fst t+                  in ...+    Here, b isn't free in x's type, but we must nevertheless+    abstract wrt b as well, because t's type mentions b.+    Since t is floated too, we'd end up with the bogus:+         poly_t = /\ a b -> (e1, e2)+         poly_x = /\ a   -> fst (poly_t a *b*)++  * We must do closeOverKinds.  Example (Trac #10934):+       f = /\k (f:k->*) (a:k). let t = AccFailure @ (f a) in ...+    Here we want to float 't', but we must remember to abstract over+    'k' as well, even though it is not explicitly mentioned in the RHS,+    otherwise we get+       t = /\ (f:k->*) (a:k). AccFailure @ (f a)+    which is obviously bogus.+-}++abstractFloats :: [OutTyVar] -> SimplEnv -> OutExpr -> SimplM ([OutBind], OutExpr)+abstractFloats main_tvs body_env body+  = ASSERT( notNull body_floats )+    do  { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats+        ; return (float_binds, CoreSubst.substExpr (text "abstract_floats1") subst body) }+  where+    main_tv_set = mkVarSet main_tvs+    body_floats = getFloatBinds body_env+    empty_subst = CoreSubst.mkEmptySubst (seInScope body_env)++    abstract :: CoreSubst.Subst -> OutBind -> SimplM (CoreSubst.Subst, OutBind)+    abstract subst (NonRec id rhs)+      = do { (poly_id, poly_app) <- mk_poly tvs_here id+           ; let poly_rhs = mkLams tvs_here rhs'+                 subst'   = CoreSubst.extendIdSubst subst id poly_app+           ; return (subst', (NonRec poly_id poly_rhs)) }+      where+        rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs++        -- tvs_here: see Note [Which type variables to abstract over]+        tvs_here = toposortTyVars $+                   filter (`elemVarSet` main_tv_set) $+                   closeOverKindsList $+                   exprSomeFreeVarsList isTyVar rhs'++    abstract subst (Rec prs)+       = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly tvs_here) ids+            ; let subst' = CoreSubst.extendSubstList subst (ids `zip` poly_apps)+                  poly_rhss = [mkLams tvs_here (CoreSubst.substExpr (text "abstract_floats3") subst' rhs)+                              | rhs <- rhss]+            ; return (subst', Rec (poly_ids `zip` poly_rhss)) }+       where+         (ids,rhss) = unzip prs+                -- For a recursive group, it's a bit of a pain to work out the minimal+                -- set of tyvars over which to abstract:+                --      /\ a b c.  let x = ...a... in+                --                 letrec { p = ...x...q...+                --                          q = .....p...b... } in+                --                 ...+                -- Since 'x' is abstracted over 'a', the {p,q} group must be abstracted+                -- over 'a' (because x is replaced by (poly_x a)) as well as 'b'.+                -- Since it's a pain, we just use the whole set, which is always safe+                --+                -- If you ever want to be more selective, remember this bizarre case too:+                --      x::a = x+                -- Here, we must abstract 'x' over 'a'.+         tvs_here = toposortTyVars main_tvs++    mk_poly tvs_here var+      = do { uniq <- getUniqueM+           ; let  poly_name = setNameUnique (idName var) uniq           -- Keep same name+                  poly_ty   = mkInvForAllTys tvs_here (idType var) -- But new type of course+                  poly_id   = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in Id.hs+                              mkLocalIdOrCoVar poly_name poly_ty+           ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) }+                -- In the olden days, it was crucial to copy the occInfo of the original var,+                -- because we were looking at occurrence-analysed but as yet unsimplified code!+                -- In particular, we mustn't lose the loop breakers.  BUT NOW we are looking+                -- at already simplified code, so it doesn't matter+                --+                -- It's even right to retain single-occurrence or dead-var info:+                -- Suppose we started with  /\a -> let x = E in B+                -- where x occurs once in B. Then we transform to:+                --      let x' = /\a -> E in /\a -> let x* = x' a in B+                -- where x* has an INLINE prag on it.  Now, once x* is inlined,+                -- the occurrences of x' will be just the occurrences originally+                -- pinned on x.++{-+Note [Abstract over coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If a coercion variable (g :: a ~ Int) is free in the RHS, then so is the+type variable a.  Rather than sort this mess out, we simply bale out and abstract+wrt all the type variables if any of them are coercion variables.+++Historical note: if you use let-bindings instead of a substitution, beware of this:++                -- Suppose we start with:+                --+                --      x = /\ a -> let g = G in E+                --+                -- Then we'll float to get+                --+                --      x = let poly_g = /\ a -> G+                --          in /\ a -> let g = poly_g a in E+                --+                -- But now the occurrence analyser will see just one occurrence+                -- of poly_g, not inside a lambda, so the simplifier will+                -- PreInlineUnconditionally poly_g back into g!  Badk to square 1!+                -- (I used to think that the "don't inline lone occurrences" stuff+                --  would stop this happening, but since it's the *only* occurrence,+                --  PreInlineUnconditionally kicks in first!)+                --+                -- Solution: put an INLINE note on g's RHS, so that poly_g seems+                --           to appear many times.  (NB: mkInlineMe eliminates+                --           such notes on trivial RHSs, so do it manually.)++************************************************************************+*                                                                      *+                prepareAlts+*                                                                      *+************************************************************************++prepareAlts tries these things:++1.  Eliminate alternatives that cannot match, including the+    DEFAULT alternative.++2.  If the DEFAULT alternative can match only one possible constructor,+    then make that constructor explicit.+    e.g.+        case e of x { DEFAULT -> rhs }+     ===>+        case e of x { (a,b) -> rhs }+    where the type is a single constructor type.  This gives better code+    when rhs also scrutinises x or e.++3. Returns a list of the constructors that cannot holds in the+   DEFAULT alternative (if there is one)++Here "cannot match" includes knowledge from GADTs++It's a good idea to do this stuff before simplifying the alternatives, to+avoid simplifying alternatives we know can't happen, and to come up with+the list of constructors that are handled, to put into the IdInfo of the+case binder, for use when simplifying the alternatives.++Eliminating the default alternative in (1) isn't so obvious, but it can+happen:++data Colour = Red | Green | Blue++f x = case x of+        Red -> ..+        Green -> ..+        DEFAULT -> h x++h y = case y of+        Blue -> ..+        DEFAULT -> [ case y of ... ]++If we inline h into f, the default case of the inlined h can't happen.+If we don't notice this, we may end up filtering out *all* the cases+of the inner case y, which give us nowhere to go!+-}++prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt])+-- The returned alternatives can be empty, none are possible+prepareAlts scrut case_bndr' alts+  | Just (tc, tys) <- splitTyConApp_maybe (varType case_bndr')+           -- Case binder is needed just for its type. Note that as an+           --   OutId, it has maximum information; this is important.+           --   Test simpl013 is an example+  = do { us <- getUniquesM+       ; let (idcs1, alts1)       = filterAlts tc tys imposs_cons alts+             (yes2,  alts2)       = refineDefaultAlt us tc tys idcs1 alts1+             (yes3, idcs3, alts3) = combineIdenticalAlts idcs1 alts2+             -- "idcs" stands for "impossible default data constructors"+             -- i.e. the constructors that can't match the default case+       ; when yes2 $ tick (FillInCaseDefault case_bndr')+       ; when yes3 $ tick (AltMerge case_bndr')+       ; return (idcs3, alts3) }++  | otherwise  -- Not a data type, so nothing interesting happens+  = return ([], alts)+  where+    imposs_cons = case scrut of+                    Var v -> otherCons (idUnfolding v)+                    _     -> []+++{-+************************************************************************+*                                                                      *+                mkCase+*                                                                      *+************************************************************************++mkCase tries these things++1.  Merge Nested Cases++       case e of b {             ==>   case e of b {+         p1 -> rhs1                      p1 -> rhs1+         ...                             ...+         pm -> rhsm                      pm -> rhsm+         _  -> case b of b' {            pn -> let b'=b in rhsn+                     pn -> rhsn          ...+                     ...                 po -> let b'=b in rhso+                     po -> rhso          _  -> let b'=b in rhsd+                     _  -> rhsd+       }++    which merges two cases in one case when -- the default alternative of+    the outer case scrutises the same variable as the outer case. This+    transformation is called Case Merging.  It avoids that the same+    variable is scrutinised multiple times.++2.  Eliminate Identity Case++        case e of               ===> e+                True  -> True;+                False -> False++    and similar friends.++3.  Scrutinee Constant Folding++     case x op# k# of _ {  ===> case x of _ {+        a1# -> e1                  (a1# inv_op# k#) -> e1+        a2# -> e2                  (a2# inv_op# k#) -> e2+        ...                        ...+        DEFAULT -> ed              DEFAULT -> ed++     where (x op# k#) inv_op# k# == x++    And similarly for commuted arguments and for some unary operations.++    The purpose of this transformation is not only to avoid an arithmetic+    operation at runtime but to allow other transformations to apply in cascade.++    Example with the "Merge Nested Cases" optimization (from #12877):++          main = case t of t0+             0##     -> ...+             DEFAULT -> case t0 `minusWord#` 1## of t1+                0##    -> ...+                DEFAUT -> case t1 `minusWord#` 1## of t2+                   0##     -> ...+                   DEFAULT -> case t2 `minusWord#` 1## of _+                      0##     -> ...+                      DEFAULT -> ...++      becomes:++          main = case t of _+          0##     -> ...+          1##     -> ...+          2##     -> ...+          3##     -> ...+          DEFAULT -> ...++-}++mkCase, mkCase1, mkCase2, mkCase3+   :: DynFlags+   -> OutExpr -> OutId+   -> OutType -> [OutAlt]               -- Alternatives in standard (increasing) order+   -> SimplM OutExpr++--------------------------------------------------+--      1. Merge Nested Cases+--------------------------------------------------++mkCase dflags scrut outer_bndr alts_ty ((DEFAULT, _, deflt_rhs) : outer_alts)+  | gopt Opt_CaseMerge dflags+  , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts)+       <- stripTicksTop tickishFloatable deflt_rhs+  , inner_scrut_var == outer_bndr+  = do  { tick (CaseMerge outer_bndr)++        ; let wrap_alt (con, args, rhs) = ASSERT( outer_bndr `notElem` args )+                                          (con, args, wrap_rhs rhs)+                -- Simplifier's no-shadowing invariant should ensure+                -- that outer_bndr is not shadowed by the inner patterns+              wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs+                -- The let is OK even for unboxed binders,++              wrapped_alts | isDeadBinder inner_bndr = inner_alts+                           | otherwise               = map wrap_alt inner_alts++              merged_alts = mergeAlts outer_alts wrapped_alts+                -- NB: mergeAlts gives priority to the left+                --      case x of+                --        A -> e1+                --        DEFAULT -> case x of+                --                      A -> e2+                --                      B -> e3+                -- When we merge, we must ensure that e1 takes+                -- precedence over e2 as the value for A!++        ; fmap (mkTicks ticks) $+          mkCase1 dflags scrut outer_bndr alts_ty merged_alts+        }+        -- Warning: don't call mkCase recursively!+        -- Firstly, there's no point, because inner alts have already had+        -- mkCase applied to them, so they won't have a case in their default+        -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr+        -- in munge_rhs may put a case into the DEFAULT branch!++mkCase dflags scrut bndr alts_ty alts = mkCase1 dflags scrut bndr alts_ty alts++--------------------------------------------------+--      2. Eliminate Identity Case+--------------------------------------------------++mkCase1 _dflags scrut case_bndr _ alts@((_,_,rhs1) : _)      -- Identity case+  | all identity_alt alts+  = do { tick (CaseIdentity case_bndr)+       ; return (mkTicks ticks $ re_cast scrut rhs1) }+  where+    ticks = concatMap (stripTicksT tickishFloatable . thdOf3) (tail alts)+    identity_alt (con, args, rhs) = check_eq rhs con args++    check_eq (Cast rhs co) con args        -- See Note [RHS casts]+      = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args+    check_eq (Tick t e) alt args+      = tickishFloatable t && check_eq e alt args++    check_eq (Lit lit) (LitAlt lit') _     = lit == lit'+    check_eq (Var v) _ _  | v == case_bndr = True+    check_eq (Var v)   (DataAlt con) args+      | null arg_tys, null args            = v == dataConWorkId con+                                             -- Optimisation only+    check_eq rhs        (DataAlt con) args = cheapEqExpr' tickishFloatable rhs $+                                             mkConApp2 con arg_tys args+    check_eq _          _             _    = False++    arg_tys = tyConAppArgs (idType case_bndr)++        -- Note [RHS casts]+        -- ~~~~~~~~~~~~~~~~+        -- We've seen this:+        --      case e of x { _ -> x `cast` c }+        -- And we definitely want to eliminate this case, to give+        --      e `cast` c+        -- So we throw away the cast from the RHS, and reconstruct+        -- it at the other end.  All the RHS casts must be the same+        -- if (all identity_alt alts) holds.+        --+        -- Don't worry about nested casts, because the simplifier combines them++    re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co+    re_cast scrut _             = scrut++mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts++--------------------------------------------------+--      2. Scrutinee Constant Folding+--------------------------------------------------++mkCase2 dflags scrut bndr alts_ty alts+  | gopt Opt_CaseFolding dflags+  , Just (scrut',f) <- caseRules dflags scrut+  = mkCase3 dflags scrut' bndr alts_ty (new_alts f)+  | otherwise+  = mkCase3 dflags scrut bndr alts_ty alts+  where+    -- We need to keep the correct association between the scrutinee and its+    -- binder if the latter isn't dead. Hence we wrap rhs of alternatives with+    -- "let bndr = ... in":+    --+    --     case v + 10 of y        =====> case v of y+    --        20      -> e1                 10      -> let y = 20     in e1+    --        DEFAULT -> e2                 DEFAULT -> let y = v + 10 in e2+    --+    -- Other transformations give: =====> case v of y'+    --                                      10      -> let y = 20      in e1+    --                                      DEFAULT -> let y = y' + 10 in e2+    --+    wrap_rhs l rhs+      | isDeadBinder bndr = rhs+      | otherwise         = Let (NonRec bndr l) rhs++    -- We need to re-sort the alternatives to preserve the #case_invariants#+    new_alts f = sortBy cmpAlt (map (mapAlt f) alts)++    mapAlt f alt@(c,bs,e) = case c of+      DEFAULT          -> (c, bs, wrap_rhs scrut e)+      LitAlt l+        | isLitValue l -> (LitAlt (mapLitValue dflags f l),+                           bs, wrap_rhs (Lit l) e)+      _ -> pprPanic "Unexpected alternative (mkCase2)" (ppr alt)++--------------------------------------------------+--      Catch-all+--------------------------------------------------+mkCase3 _dflags scrut bndr alts_ty alts+  = return (Case scrut bndr alts_ty alts)++{-+Note [Dead binders]+~~~~~~~~~~~~~~~~~~~~+Note that dead-ness is maintained by the simplifier, so that it is+accurate after simplification as well as before.+++Note [Cascading case merge]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Case merging should cascade in one sweep, because it+happens bottom-up++      case e of a {+        DEFAULT -> case a of b+                      DEFAULT -> case b of c {+                                     DEFAULT -> e+                                     A -> ea+                      B -> eb+        C -> ec+==>+      case e of a {+        DEFAULT -> case a of b+                      DEFAULT -> let c = b in e+                      A -> let c = b in ea+                      B -> eb+        C -> ec+==>+      case e of a {+        DEFAULT -> let b = a in let c = b in e+        A -> let b = a in let c = b in ea+        B -> let b = a in eb+        C -> ec+++However here's a tricky case that we still don't catch, and I don't+see how to catch it in one pass:++  case x of c1 { I# a1 ->+  case a1 of c2 ->+    0 -> ...+    DEFAULT -> case x of c3 { I# a2 ->+               case a2 of ...++After occurrence analysis (and its binder-swap) we get this++  case x of c1 { I# a1 ->+  let x = c1 in         -- Binder-swap addition+  case a1 of c2 ->+    0 -> ...+    DEFAULT -> case x of c3 { I# a2 ->+               case a2 of ...++When we simplify the inner case x, we'll see that+x=c1=I# a1.  So we'll bind a2 to a1, and get++  case x of c1 { I# a1 ->+  case a1 of c2 ->+    0 -> ...+    DEFAULT -> case a1 of ...++This is corect, but we can't do a case merge in this sweep+because c2 /= a1.  Reason: the binding c1=I# a1 went inwards+without getting changed to c1=I# c2.++I don't think this is worth fixing, even if I knew how. It'll+all come out in the next pass anyway.+-}
+ simplCore/Simplify.hs view
@@ -0,0 +1,3461 @@+{-+(c) The AQUA Project, Glasgow University, 1993-1998++\section[Simplify]{The main module of the simplifier}+-}++{-# LANGUAGE CPP #-}++module Simplify ( simplTopBinds, simplExpr, simplRules ) where++#include "HsVersions.h"++import DynFlags+import SimplMonad+import Type hiding      ( substTy, substTyVar, extendTvSubst, extendCvSubst )+import SimplEnv+import SimplUtils+import OccurAnal        ( occurAnalyseExpr )+import FamInstEnv       ( FamInstEnv )+import Literal          ( litIsLifted ) --, mkMachInt ) -- temporalily commented out. See #8326+import Id+import MkId             ( seqId )+import MkCore           ( mkImpossibleExpr, castBottomExpr )+import IdInfo+import Name             ( Name, mkSystemVarName, isExternalName, getOccFS )+import Coercion hiding  ( substCo, substCoVar )+import OptCoercion      ( optCoercion )+import FamInstEnv       ( topNormaliseType_maybe )+import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness, dataConRepArgTys )+--import TyCon            ( isEnumerationTyCon ) -- temporalily commented out. See #8326+import CoreMonad        ( Tick(..), SimplifierMode(..) )+import CoreSyn+import Demand           ( StrictSig(..), dmdTypeDepth, isStrictDmd )+import PprCore          ( pprCoreExpr )+import CoreUnfold+import CoreUtils+import CoreArity+import CoreOpt          ( pushCoTyArg, pushCoValArg+                        , joinPointBinding_maybe, joinPointBindings_maybe )+--import PrimOp           ( tagToEnumKey ) -- temporalily commented out. See #8326+import Rules            ( mkRuleInfo, lookupRule, getRules )+--import TysPrim          ( intPrimTy ) -- temporalily commented out. See #8326+import BasicTypes       ( TopLevelFlag(..), isNotTopLevel, isTopLevel,+                          RecFlag(..) )+import MonadUtils       ( foldlM, mapAccumLM, liftIO )+import Maybes           ( isJust, fromJust, orElse )+--import Unique           ( hasKey ) -- temporalily commented out. See #8326+import Control.Monad+import Outputable+import FastString+import Pair+import Util+import ErrUtils+import Module          ( moduleName, pprModuleName )++{-+The guts of the simplifier is in this module, but the driver loop for+the simplifier is in SimplCore.hs.+++-----------------------------------------+        *** IMPORTANT NOTE ***+-----------------------------------------+The simplifier used to guarantee that the output had no shadowing, but+it does not do so any more.   (Actually, it never did!)  The reason is+documented with simplifyArgs.+++-----------------------------------------+        *** IMPORTANT NOTE ***+-----------------------------------------+Many parts of the simplifier return a bunch of "floats" as well as an+expression. This is wrapped as a datatype SimplUtils.FloatsWith.++All "floats" are let-binds, not case-binds, but some non-rec lets may+be unlifted (with RHS ok-for-speculation).++++-----------------------------------------+        ORGANISATION OF FUNCTIONS+-----------------------------------------+simplTopBinds+  - simplify all top-level binders+  - for NonRec, call simplRecOrTopPair+  - for Rec,    call simplRecBind+++        ------------------------------+simplExpr (applied lambda)      ==> simplNonRecBind+simplExpr (Let (NonRec ...) ..) ==> simplNonRecBind+simplExpr (Let (Rec ...)    ..) ==> simplify binders; simplRecBind++        ------------------------------+simplRecBind    [binders already simplfied]+  - use simplRecOrTopPair on each pair in turn++simplRecOrTopPair [binder already simplified]+  Used for: recursive bindings (top level and nested)+            top-level non-recursive bindings+  Returns:+  - check for PreInlineUnconditionally+  - simplLazyBind++simplNonRecBind+  Used for: non-top-level non-recursive bindings+            beta reductions (which amount to the same thing)+  Because it can deal with strict arts, it takes a+        "thing-inside" and returns an expression++  - check for PreInlineUnconditionally+  - simplify binder, including its IdInfo+  - if strict binding+        simplStrictArg+        mkAtomicArgs+        completeNonRecX+    else+        simplLazyBind+        addFloats++simplNonRecX:   [given a *simplified* RHS, but an *unsimplified* binder]+  Used for: binding case-binder and constr args in a known-constructor case+  - check for PreInLineUnconditionally+  - simplify binder+  - completeNonRecX++        ------------------------------+simplLazyBind:  [binder already simplified, RHS not]+  Used for: recursive bindings (top level and nested)+            top-level non-recursive bindings+            non-top-level, but *lazy* non-recursive bindings+        [must not be strict or unboxed]+  Returns floats + an augmented environment, not an expression+  - substituteIdInfo and add result to in-scope+        [so that rules are available in rec rhs]+  - simplify rhs+  - mkAtomicArgs+  - float if exposes constructor or PAP+  - completeBind+++completeNonRecX:        [binder and rhs both simplified]+  - if the the thing needs case binding (unlifted and not ok-for-spec)+        build a Case+   else+        completeBind+        addFloats++completeBind:   [given a simplified RHS]+        [used for both rec and non-rec bindings, top level and not]+  - try PostInlineUnconditionally+  - add unfolding [this is the only place we add an unfolding]+  - add arity++++Right hand sides and arguments+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In many ways we want to treat+        (a) the right hand side of a let(rec), and+        (b) a function argument+in the same way.  But not always!  In particular, we would+like to leave these arguments exactly as they are, so they+will match a RULE more easily.++        f (g x, h x)+        g (+ x)++It's harder to make the rule match if we ANF-ise the constructor,+or eta-expand the PAP:++        f (let { a = g x; b = h x } in (a,b))+        g (\y. + x y)++On the other hand if we see the let-defns++        p = (g x, h x)+        q = + x++then we *do* want to ANF-ise and eta-expand, so that p and q+can be safely inlined.++Even floating lets out is a bit dubious.  For let RHS's we float lets+out if that exposes a value, so that the value can be inlined more vigorously.+For example++        r = let x = e in (x,x)++Here, if we float the let out we'll expose a nice constructor. We did experiments+that showed this to be a generally good thing.  But it was a bad thing to float+lets out unconditionally, because that meant they got allocated more often.++For function arguments, there's less reason to expose a constructor (it won't+get inlined).  Just possibly it might make a rule match, but I'm pretty skeptical.+So for the moment we don't float lets out of function arguments either.+++Eta expansion+~~~~~~~~~~~~~~+For eta expansion, we want to catch things like++        case e of (a,b) -> \x -> case a of (p,q) -> \y -> r++If the \x was on the RHS of a let, we'd eta expand to bring the two+lambdas together.  And in general that's a good thing to do.  Perhaps+we should eta expand wherever we find a (value) lambda?  Then the eta+expansion at a let RHS can concentrate solely on the PAP case.+++Case-of-case and join points+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we perform the case-of-case transform (or otherwise push continuations+inward), we want to treat join points specially. Since they're always+tail-called and we want to maintain this invariant, we can do this (for any+evaluation context E):++  E[join j = e+    in case ... of+         A -> jump j 1+         B -> jump j 2+         C -> f 3]++    -->++  join j = E[e]+  in case ... of+       A -> jump j 1+       B -> jump j 2+       C -> E[f 3]++As is evident from the example, there are two components to this behavior:++  1. When entering the RHS of a join point, copy the context inside.+  2. When a join point is invoked, discard the outer context.++Clearly we need to be very careful here to remain consistent---neither part is+optional!++************************************************************************+*                                                                      *+\subsection{Bindings}+*                                                                      *+************************************************************************+-}++simplTopBinds :: SimplEnv -> [InBind] -> SimplM SimplEnv++simplTopBinds env0 binds0+  = do  {       -- Put all the top-level binders into scope at the start+                -- so that if a transformation rule has unexpectedly brought+                -- anything into scope, then we don't get a complaint about that.+                -- It's rather as if the top-level binders were imported.+                -- See note [Glomming] in OccurAnal.+        ; env1 <- simplRecBndrs env0 (bindersOfBinds binds0)+        ; env2 <- simpl_binds env1 binds0+        ; freeTick SimplifierDone+        ; return env2 }+  where+        -- We need to track the zapped top-level binders, because+        -- they should have their fragile IdInfo zapped (notably occurrence info)+        -- That's why we run down binds and bndrs' simultaneously.+        --+    simpl_binds :: SimplEnv -> [InBind] -> SimplM SimplEnv+    simpl_binds env []           = return env+    simpl_binds env (bind:binds) = do { env' <- simpl_bind env bind+                                      ; simpl_binds env' binds }++    simpl_bind env (Rec pairs)  = simplRecBind env TopLevel Nothing pairs+    simpl_bind env (NonRec b r) = do { (env', b') <- addBndrRules env b (lookupRecBndr env b)+                                     ; simplRecOrTopPair env' TopLevel+                                                         NonRecursive Nothing+                                                         b b' r }++{-+************************************************************************+*                                                                      *+\subsection{Lazy bindings}+*                                                                      *+************************************************************************++simplRecBind is used for+        * recursive bindings only+-}++simplRecBind :: SimplEnv -> TopLevelFlag -> Maybe SimplCont+             -> [(InId, InExpr)]+             -> SimplM SimplEnv+simplRecBind env0 top_lvl mb_cont pairs0+  = do  { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0+        ; env1 <- go (zapFloats env_with_info) triples+        ; return (env0 `addRecFloats` env1) }+        -- addFloats adds the floats from env1,+        -- _and_ updates env0 with the in-scope set from env1+  where+    add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr))+        -- Add the (substituted) rules to the binder+    add_rules env (bndr, rhs)+        = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr)+             ; return (env', (bndr, bndr', rhs)) }++    go env [] = return env++    go env ((old_bndr, new_bndr, rhs) : pairs)+        = do { env' <- simplRecOrTopPair env top_lvl Recursive mb_cont+                                         old_bndr new_bndr rhs+             ; go env' pairs }++{-+simplOrTopPair is used for+        * recursive bindings (whether top level or not)+        * top-level non-recursive bindings++It assumes the binder has already been simplified, but not its IdInfo.+-}++simplRecOrTopPair :: SimplEnv+                  -> TopLevelFlag -> RecFlag -> Maybe SimplCont+                  -> InId -> OutBndr -> InExpr  -- Binder and rhs+                  -> SimplM SimplEnv    -- Returns an env that includes the binding++simplRecOrTopPair env top_lvl is_rec mb_cont old_bndr new_bndr rhs+  = do { dflags <- getDynFlags+       ; trace_bind dflags $+           if preInlineUnconditionally dflags env top_lvl old_bndr rhs+                    -- Check for unconditional inline+           then do tick (PreInlineUnconditionally old_bndr)+                   return (extendIdSubst env old_bndr (mkContEx env rhs))+           else simplBind env top_lvl is_rec mb_cont old_bndr new_bndr rhs env }+  where+    trace_bind dflags thing_inside+      | not (dopt Opt_D_verbose_core2core dflags)+      = thing_inside+      | otherwise+      = pprTrace "SimplBind" (ppr old_bndr) thing_inside+        -- trace_bind emits a trace for each top-level binding, which+        -- helps to locate the tracing for inlining and rule firing++{-+simplBind is used for+  * [simplRecOrTopPair] recursive bindings (whether top level or not)+  * [simplRecOrTopPair] top-level non-recursive bindings+  * [simplNonRecE]      non-top-level *lazy* non-recursive bindings++Nota bene:+    1. It assumes that the binder is *already* simplified,+       and is in scope, and its IdInfo too, except unfolding++    2. It assumes that the binder type is lifted.++    3. It does not check for pre-inline-unconditionally;+       that should have been done already.+-}++simplBind :: SimplEnv+          -> TopLevelFlag -> RecFlag -> Maybe SimplCont+          -> InId -> OutId      -- Binder, both pre-and post simpl+                                -- The OutId has IdInfo, except arity, unfolding+                                -- Ids only, no TyVars+          -> InExpr -> SimplEnv -- The RHS and its environment+          -> SimplM SimplEnv+simplBind env top_lvl is_rec mb_cont bndr bndr1 rhs rhs_se+  | ASSERT( isId bndr1 )+    isJoinId bndr1+  = ASSERT(isNotTopLevel top_lvl && isJust mb_cont)+    simplJoinBind env is_rec (fromJust mb_cont) bndr bndr1 rhs rhs_se+  | otherwise+  = simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se++simplLazyBind :: SimplEnv+              -> TopLevelFlag -> RecFlag+              -> InId -> OutId          -- Binder, both pre-and post simpl+                                        -- The OutId has IdInfo, except arity, unfolding+                                        -- Ids only, no TyVars+              -> InExpr -> SimplEnv     -- The RHS and its environment+              -> SimplM SimplEnv+-- Precondition: rhs obeys the let/app invariant+-- NOT used for JoinIds+simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se+  = ASSERT( isId bndr )+    ASSERT2( not (isJoinId bndr), ppr bndr )+    -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $+    do  { let   rhs_env     = rhs_se `setInScopeAndZapFloats` env+                (tvs, body) = case collectTyAndValBinders rhs of+                                (tvs, [], body)+                                  | surely_not_lam body -> (tvs, body)+                                _                       -> ([], rhs)++                surely_not_lam (Lam {})     = False+                surely_not_lam (Tick t e)+                  | not (tickishFloatable t) = surely_not_lam e+                   -- eta-reduction could float+                surely_not_lam _            = True+                        -- Do not do the "abstract tyyvar" thing if there's+                        -- a lambda inside, because it defeats eta-reduction+                        --    f = /\a. \x. g a x+                        -- should eta-reduce.+++        ; (body_env, tvs') <- simplBinders rhs_env tvs+                -- See Note [Floating and type abstraction] in SimplUtils++        -- Simplify the RHS+        ; let   rhs_cont = mkRhsStop (substTy body_env (exprType body))+        ; (body_env0, body0) <- simplExprF body_env body rhs_cont+        ; let body1     = wrapJoinFloats body_env0 body0+              body_env1 = body_env0 `restoreJoinFloats` body_env++        -- ANF-ise a constructor or PAP rhs+        ; (body_env2, body2) <- prepareRhs top_lvl body_env1 bndr1 body1++        ; (env', rhs')+            <-  if not (doFloatFromRhs top_lvl is_rec False body2 body_env2)+                then                            -- No floating, revert to body1+                     do { rhs' <- mkLam env tvs' (wrapFloats body_env1 body1) rhs_cont+                        ; return (env, rhs') }++                else if null tvs then           -- Simple floating+                     do { tick LetFloatFromLet+                        ; return (addFloats env body_env2, body2) }++                else                            -- Do type-abstraction first+                     do { tick LetFloatFromLet+                        ; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2+                        ; rhs' <- mkLam env tvs' body3 rhs_cont+                        ; env' <- foldlM (addPolyBind top_lvl) env poly_binds+                        ; return (env', rhs') }++        ; completeBind env' top_lvl is_rec Nothing bndr bndr1 rhs' }++simplJoinBind :: SimplEnv+              -> RecFlag+              -> SimplCont+              -> InId -> OutId          -- Binder, both pre-and post simpl+                                        -- The OutId has IdInfo, except arity,+                                        --   unfolding+              -> InExpr -> SimplEnv     -- The RHS and its environment+              -> SimplM SimplEnv+simplJoinBind env is_rec cont bndr bndr1 rhs rhs_se+  = -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$+    --                           ppr rhs $$ ppr (seIdSubst rhs_se)) $+    do  { let rhs_env = rhs_se `setInScopeAndZapFloats` env++        -- Simplify the RHS+        ; rhs' <- simplJoinRhs rhs_env bndr rhs cont+        ; completeBind env NotTopLevel is_rec (Just cont) bndr bndr1 rhs' }++{-+A specialised variant of simplNonRec used when the RHS is already simplified,+notably in knownCon.  It uses case-binding where necessary.+-}++simplNonRecX :: SimplEnv+             -> InId            -- Old binder+             -> OutExpr         -- Simplified RHS+             -> SimplM SimplEnv+-- Precondition: rhs satisfies the let/app invariant+simplNonRecX env bndr new_rhs+  | isDeadBinder bndr   -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }+  = return env    --  Here c is dead, and we avoid creating+                  --   the binding c = (a,b)++  | Coercion co <- new_rhs+  = return (extendCvSubst env bndr co)++  | otherwise+  = do  { (env', bndr') <- simplBinder env bndr+        ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs }+                -- simplNonRecX is only used for NotTopLevel things++completeNonRecX :: TopLevelFlag -> SimplEnv+                -> Bool+                -> InId                 -- Old binder+                -> OutId                -- New binder+                -> OutExpr              -- Simplified RHS+                -> SimplM SimplEnv+-- Precondition: rhs satisfies the let/app invariant+--               See Note [CoreSyn let/app invariant] in CoreSyn++completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs+  = ASSERT(not (isJoinId new_bndr))+    do  { (env1, rhs1) <- prepareRhs top_lvl (zapFloats env) new_bndr new_rhs+        ; (env2, rhs2) <-+                if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1+                then do { tick LetFloatFromLet+                        ; return (addFloats env env1, rhs1) }   -- Add the floats to the main env+                else return (env, wrapFloats env1 rhs1)         -- Wrap the floats around the RHS+        ; completeBind env2 NotTopLevel NonRecursive Nothing+                       old_bndr new_bndr rhs2 }++{- No, no, no!  Do not try preInlineUnconditionally in completeNonRecX+   Doing so risks exponential behaviour, because new_rhs has been simplified once already+   In the cases described by the folowing commment, postInlineUnconditionally will+   catch many of the relevant cases.+        -- This happens; for example, the case_bndr during case of+        -- known constructor:  case (a,b) of x { (p,q) -> ... }+        -- Here x isn't mentioned in the RHS, so we don't want to+        -- create the (dead) let-binding  let x = (a,b) in ...+        --+        -- Similarly, single occurrences can be inlined vigourously+        -- e.g.  case (f x, g y) of (a,b) -> ....+        -- If a,b occur once we can avoid constructing the let binding for them.++   Furthermore in the case-binding case preInlineUnconditionally risks extra thunks+        -- Consider     case I# (quotInt# x y) of+        --                I# v -> let w = J# v in ...+        -- If we gaily inline (quotInt# x y) for v, we end up building an+        -- extra thunk:+        --                let w = J# (quotInt# x y) in ...+        -- because quotInt# can fail.++  | preInlineUnconditionally env NotTopLevel bndr new_rhs+  = thing_inside (extendIdSubst env bndr (DoneEx new_rhs))+-}++----------------------------------+{- Note [Avoiding exponential behaviour]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+One way in which we can get exponential behaviour is if we simplify a+big expression, and the re-simplify it -- and then this happens in a+deeply-nested way.  So we must be jolly careful about re-simplifying+an expression.  That is why completeNonRecX does not try+preInlineUnconditionally.++Example:+  f BIG, where f has a RULE+Then+ * We simplify BIG before trying the rule; but the rule does not fire+ * We inline f = \x. x True+ * So if we did preInlineUnconditionally we'd re-simplify (BIG True)++However, if BIG has /not/ already been simplified, we'd /like/ to+simplify BIG True; maybe good things happen.  That is why++* simplLam has+    - a case for (isSimplified dup), which goes via simplNonRecX, and+    - a case for the un-simplified case, which goes via simplNonRecE++* We go to some efforts to avoid unnecessarily simplifying ApplyToVal,+  in at least two places+    - In simplCast/addCoerce, where we check for isReflCo+    - In rebuildCall we avoid simplifying arguments before we have to+      (see Note [Trying rewrite rules])++Note [prepareRhs]+~~~~~~~~~~~~~~~~~~~~+prepareRhs takes a putative RHS, checks whether it's a PAP or+constructor application and, if so, converts it to ANF, so that the+resulting thing can be inlined more easily.  Thus+        x = (f a, g b)+becomes+        t1 = f a+        t2 = g b+        x = (t1,t2)++We also want to deal well cases like this+        v = (f e1 `cast` co) e2+Here we want to make e1,e2 trivial and get+        x1 = e1; x2 = e2; v = (f x1 `cast` co) v2+That's what the 'go' loop in prepareRhs does+-}++prepareRhs :: TopLevelFlag -> SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr)+-- Adds new floats to the env iff that allows us to return a good RHS+-- See Note [prepareRhs]+prepareRhs top_lvl env id (Cast rhs co)    -- Note [Float coercions]+  | Pair ty1 _ty2 <- coercionKind co       -- Do *not* do this if rhs has an unlifted type+  , not (isUnliftedType ty1)            -- see Note [Float coercions (unlifted)]+  = do  { (env', rhs') <- makeTrivialWithInfo top_lvl env (getOccFS id) sanitised_info rhs+        ; return (env', Cast rhs' co) }+  where+    sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info+                                   `setDemandInfo` demandInfo info+    info = idInfo id++prepareRhs top_lvl env0 id rhs0+  = do  { (_is_exp, env1, rhs1) <- go 0 env0 rhs0+        ; return (env1, rhs1) }+  where+    go n_val_args env (Cast rhs co)+        = do { (is_exp, env', rhs') <- go n_val_args env rhs+             ; return (is_exp, env', Cast rhs' co) }+    go n_val_args env (App fun (Type ty))+        = do { (is_exp, env', rhs') <- go n_val_args env fun+             ; return (is_exp, env', App rhs' (Type ty)) }+    go n_val_args env (App fun arg)+        = do { (is_exp, env', fun') <- go (n_val_args+1) env fun+             ; case is_exp of+                True -> do { (env'', arg') <- makeTrivial top_lvl env' (getOccFS id) arg+                           ; return (True, env'', App fun' arg') }+                False -> return (False, env, App fun arg) }+    go n_val_args env (Var fun)+        = return (is_exp, env, Var fun)+        where+          is_exp = isExpandableApp fun n_val_args   -- The fun a constructor or PAP+                        -- See Note [CONLIKE pragma] in BasicTypes+                        -- The definition of is_exp should match that in+                        -- OccurAnal.occAnalApp++    go n_val_args env (Tick t rhs)+        -- We want to be able to float bindings past this+        -- tick. Non-scoping ticks don't care.+        | tickishScoped t == NoScope+        = do { (is_exp, env', rhs') <- go n_val_args env rhs+             ; return (is_exp, env', Tick t rhs') }+        -- On the other hand, for scoping ticks we need to be able to+        -- copy them on the floats, which in turn is only allowed if+        -- we can obtain non-counting ticks.+        | not (tickishCounts t) || tickishCanSplit t+        = do { (is_exp, env', rhs') <- go n_val_args (zapFloats env) rhs+             ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr)+                   floats' = seFloats $ env `addFloats` mapFloats env' tickIt+             ; return (is_exp, env' { seFloats = floats' }, Tick t rhs') }++    go _ env other+        = return (False, env, other)++{-+Note [Float coercions]+~~~~~~~~~~~~~~~~~~~~~~+When we find the binding+        x = e `cast` co+we'd like to transform it to+        x' = e+        x = x `cast` co         -- A trivial binding+There's a chance that e will be a constructor application or function, or something+like that, so moving the coercion to the usage site may well cancel the coercions+and lead to further optimisation.  Example:++     data family T a :: *+     data instance T Int = T Int++     foo :: Int -> Int -> Int+     foo m n = ...+        where+          x = T m+          go 0 = 0+          go n = case x of { T m -> go (n-m) }+                -- This case should optimise++Note [Preserve strictness when floating coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the Note [Float coercions] transformation, keep the strictness info.+Eg+        f = e `cast` co    -- f has strictness SSL+When we transform to+        f' = e             -- f' also has strictness SSL+        f = f' `cast` co   -- f still has strictness SSL++Its not wrong to drop it on the floor, but better to keep it.++Note [Float coercions (unlifted)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+BUT don't do [Float coercions] if 'e' has an unlifted type.+This *can* happen:++     foo :: Int = (error (# Int,Int #) "urk")+                  `cast` CoUnsafe (# Int,Int #) Int++If do the makeTrivial thing to the error call, we'll get+    foo = case error (# Int,Int #) "urk" of v -> v `cast` ...+But 'v' isn't in scope!++These strange casts can happen as a result of case-of-case+        bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of+                (# p,q #) -> p+q+-}++makeTrivialArg :: SimplEnv -> ArgSpec -> SimplM (SimplEnv, ArgSpec)+makeTrivialArg env (ValArg e) = do+    { (env', e') <- makeTrivial NotTopLevel env (fsLit "arg") e+    ; return (env', ValArg e') }+makeTrivialArg env arg        = return (env, arg)  -- CastBy, TyArg++makeTrivial :: TopLevelFlag -> SimplEnv+            -> FastString  -- ^ a "friendly name" to build the new binder from+            -> OutExpr -> SimplM (SimplEnv, OutExpr)+-- Binds the expression to a variable, if it's not trivial, returning the variable+makeTrivial top_lvl env context expr =+    makeTrivialWithInfo top_lvl env context vanillaIdInfo expr++makeTrivialWithInfo :: TopLevelFlag -> SimplEnv+                    -> FastString+                    -- ^ a "friendly name" to build the new binder from+                    -> IdInfo -> OutExpr -> SimplM (SimplEnv, OutExpr)+-- Propagate strictness and demand info to the new binder+-- Note [Preserve strictness when floating coercions]+-- Returned SimplEnv has same substitution as incoming one+makeTrivialWithInfo top_lvl env context info expr+  | exprIsTrivial expr                          -- Already trivial+  || not (bindingOk top_lvl expr expr_ty)       -- Cannot trivialise+                                                --   See Note [Cannot trivialise]+  = return (env, expr)+  | otherwise           -- See Note [Take care] below+  = do  { uniq <- getUniqueM+        ; let name = mkSystemVarName uniq context+              var = mkLocalIdOrCoVarWithInfo name expr_ty info+        ; env'  <- completeNonRecX top_lvl env False var var expr+        ; expr' <- simplVar env' var+        ; return (env', expr') }+        -- The simplVar is needed because we're constructing a new binding+        --     a = rhs+        -- And if rhs is of form (rhs1 |> co), then we might get+        --     a1 = rhs1+        --     a = a1 |> co+        -- and now a's RHS is trivial and can be substituted out, and that+        -- is what completeNonRecX will do+        -- To put it another way, it's as if we'd simplified+        --    let var = e in var+  where+    expr_ty = exprType expr++bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool+-- True iff we can have a binding of this expression at this level+-- Precondition: the type is the type of the expression+bindingOk top_lvl expr expr_ty+  | isTopLevel top_lvl = exprIsTopLevelBindable expr expr_ty+  | otherwise          = True++{-+Note [Cannot trivialise]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider tih+   f :: Int -> Addr#++   foo :: Bar+   foo = Bar (f 3)++Then we can't ANF-ise foo, even though we'd like to, because+we can't make a top-level binding for the Addr# (f 3). And if+so we don't want to turn it into+   foo = let x = f 3 in Bar x+because we'll just end up inlining x back, and that makes the+simplifier loop.  Better not to ANF-ise it at all.++Literal strings are an exception.++   foo = Ptr "blob"#++We want to turn this into:++   foo1 = "blob"#+   foo = Ptr foo1++See Note [CoreSyn top-level string literals] in CoreSyn.++************************************************************************+*                                                                      *+\subsection{Completing a lazy binding}+*                                                                      *+************************************************************************++completeBind+  * deals only with Ids, not TyVars+  * takes an already-simplified binder and RHS+  * is used for both recursive and non-recursive bindings+  * is used for both top-level and non-top-level bindings++It does the following:+  - tries discarding a dead binding+  - tries PostInlineUnconditionally+  - add unfolding [this is the only place we add an unfolding]+  - add arity++It does *not* attempt to do let-to-case.  Why?  Because it is used for+  - top-level bindings (when let-to-case is impossible)+  - many situations where the "rhs" is known to be a WHNF+                (so let-to-case is inappropriate).++Nor does it do the atomic-argument thing+-}++completeBind :: SimplEnv+             -> TopLevelFlag            -- Flag stuck into unfolding+             -> RecFlag                 -- Recursive binding?+             -> Maybe SimplCont         -- Required only for join point+             -> InId                    -- Old binder+             -> OutId -> OutExpr        -- New binder and RHS+             -> SimplM SimplEnv+-- completeBind may choose to do its work+--      * by extending the substitution (e.g. let x = y in ...)+--      * or by adding to the floats in the envt+--+-- Precondition: rhs obeys the let/app invariant+completeBind env top_lvl is_rec mb_cont old_bndr new_bndr new_rhs+ | isCoVar old_bndr+ = case new_rhs of+     Coercion co -> return (extendCvSubst env old_bndr co)+     _           -> return (addNonRec env new_bndr new_rhs)++ | otherwise+ = ASSERT( isId new_bndr )+   do { let old_info = idInfo old_bndr+            old_unf  = unfoldingInfo old_info+            occ_info = occInfo old_info++        -- Do eta-expansion on the RHS of the binding+        -- See Note [Eta-expanding at let bindings] in SimplUtils+      ; (new_arity, final_rhs) <- if isJoinId new_bndr+                                    then return (manifestArity new_rhs, new_rhs)+                                         -- Note [Don't eta-expand join points]+                                    else tryEtaExpandRhs env is_rec+                                                         new_bndr new_rhs++        -- Simplify the unfolding+      ; new_unfolding <- simplLetUnfolding env top_lvl mb_cont old_bndr+                                           final_rhs old_unf++      ; dflags <- getDynFlags+      ; if postInlineUnconditionally dflags env top_lvl new_bndr occ_info+                                     final_rhs new_unfolding++                        -- Inline and discard the binding+        then do  { tick (PostInlineUnconditionally old_bndr)+                 ; return (extendIdSubst env old_bndr (DoneEx final_rhs)) }+                -- Use the substitution to make quite, quite sure that the+                -- substitution will happen, since we are going to discard the binding+        else+   do { let info1 = idInfo new_bndr `setArityInfo` new_arity++              -- Unfolding info: Note [Setting the new unfolding]+            info2 = info1 `setUnfoldingInfo` new_unfolding++              -- Demand info: Note [Setting the demand info]+              --+              -- We also have to nuke demand info if for some reason+              -- eta-expansion *reduces* the arity of the binding to less+              -- than that of the strictness sig. This can happen: see Note [Arity decrease].+            info3 | isEvaldUnfolding new_unfolding+                    || (case strictnessInfo info2 of+                          StrictSig dmd_ty -> new_arity < dmdTypeDepth dmd_ty)+                  = zapDemandInfo info2 `orElse` info2+                  | otherwise+                  = info2++              -- Zap call arity info. We have used it by now (via+              -- `tryEtaExpandRhs`), and the simplifier can invalidate this+              -- information, leading to broken code later (e.g. #13479)+            info4 = zapCallArityInfo info3++            final_id = new_bndr `setIdInfo` info4++      ; -- pprTrace "Binding" (ppr final_id <+> ppr new_unfolding) $+        return (addNonRec env final_id final_rhs) } }+                -- The addNonRec adds it to the in-scope set too++------------------------------+addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM SimplEnv+-- Add a new binding to the environment, complete with its unfolding+-- but *do not* do postInlineUnconditionally, because we have already+-- processed some of the scope of the binding+-- We still want the unfolding though.  Consider+--      let+--            x = /\a. let y = ... in Just y+--      in body+-- Then we float the y-binding out (via abstractFloats and addPolyBind)+-- but 'x' may well then be inlined in 'body' in which case we'd like the+-- opportunity to inline 'y' too.+--+-- INVARIANT: the arity is correct on the incoming binders++addPolyBind top_lvl env (NonRec poly_id rhs)+  = do  { unfolding <- simplLetUnfolding env top_lvl Nothing poly_id rhs+                                         noUnfolding+                        -- Assumes that poly_id did not have an INLINE prag+                        -- which is perhaps wrong.  ToDo: think about this+        ; let final_id = setIdInfo poly_id $+                         idInfo poly_id `setUnfoldingInfo` unfolding++        ; return (addNonRec env final_id rhs) }++addPolyBind _ env bind@(Rec _)+  = return (extendFloats env bind)+        -- Hack: letrecs are more awkward, so we extend "by steam"+        -- without adding unfoldings etc.  At worst this leads to+        -- more simplifier iterations++{- Note [Arity decrease]+~~~~~~~~~~~~~~~~~~~~~~~~+Generally speaking the arity of a binding should not decrease.  But it *can*+legitimately happen because of RULES.  Eg+        f = g Int+where g has arity 2, will have arity 2.  But if there's a rewrite rule+        g Int --> h+where h has arity 1, then f's arity will decrease.  Here's a real-life example,+which is in the output of Specialise:++     Rec {+        $dm {Arity 2} = \d.\x. op d+        {-# RULES forall d. $dm Int d = $s$dm #-}++        dInt = MkD .... opInt ...+        opInt {Arity 1} = $dm dInt++        $s$dm {Arity 0} = \x. op dInt }++Here opInt has arity 1; but when we apply the rule its arity drops to 0.+That's why Specialise goes to a little trouble to pin the right arity+on specialised functions too.++Note [Setting the demand info]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the unfolding is a value, the demand info may+go pear-shaped, so we nuke it.  Example:+     let x = (a,b) in+     case x of (p,q) -> h p q x+Here x is certainly demanded. But after we've nuked+the case, we'll get just+     let x = (a,b) in h a b x+and now x is not demanded (I'm assuming h is lazy)+This really happens.  Similarly+     let f = \x -> e in ...f..f...+After inlining f at some of its call sites the original binding may+(for example) be no longer strictly demanded.+The solution here is a bit ad hoc...++Note [Don't eta-expand join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Similarly to CPR (see Note [Don't CPR join points] in WorkWrap), a join point+stands well to gain from its outer binding's eta-expansion, and eta-expanding a+join point is fraught with issues like how to deal with a cast:++    let join $j1 :: IO ()+             $j1 = ...+             $j2 :: Int -> IO ()+             $j2 n = if n > 0 then $j1+                              else ...++    =>++    let join $j1 :: IO ()+             $j1 = (\eta -> ...)+                     `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ())+                                 ~  IO ()+             $j2 :: Int -> IO ()+             $j2 n = (\eta -> if n > 0 then $j1+                                       else ...)+                     `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ())+                                 ~  IO ()++The cast here can't be pushed inside the lambda (since it's not casting to a+function type), so the lambda has to stay, but it can't because it contains a+reference to a join point. In fact, $j2 can't be eta-expanded at all. Rather+than try and detect this situation (and whatever other situations crop up!), we+don't bother; again, any surrounding eta-expansion will improve these join+points anyway, since an outer cast can *always* be pushed inside. By the time+CorePrep comes around, the code is very likely to look more like this:++    let join $j1 :: State# RealWorld -> (# State# RealWorld, ())+             $j1 = (...) eta+             $j2 :: Int -> State# RealWorld -> (# State# RealWorld, ())+             $j2 = if n > 0 then $j1+                            else (...) eta++************************************************************************+*                                                                      *+\subsection[Simplify-simplExpr]{The main function: simplExpr}+*                                                                      *+************************************************************************++The reason for this OutExprStuff stuff is that we want to float *after*+simplifying a RHS, not before.  If we do so naively we get quadratic+behaviour as things float out.++To see why it's important to do it after, consider this (real) example:++        let t = f x+        in fst t+==>+        let t = let a = e1+                    b = e2+                in (a,b)+        in fst t+==>+        let a = e1+            b = e2+            t = (a,b)+        in+        a       -- Can't inline a this round, cos it appears twice+==>+        e1++Each of the ==> steps is a round of simplification.  We'd save a+whole round if we float first.  This can cascade.  Consider++        let f = g d+        in \x -> ...f...+==>+        let f = let d1 = ..d.. in \y -> e+        in \x -> ...f...+==>+        let d1 = ..d..+        in \x -> ...(\y ->e)...++Only in this second round can the \y be applied, and it+might do the same again.+-}++simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr+simplExpr env (Type ty)+  = do { ty' <- simplType env ty  -- See Note [Avoiding space leaks in OutType]+       ; return (Type ty') }++simplExpr env expr+  = simplExprC env expr (mkBoringStop expr_out_ty)+  where+    expr_out_ty :: OutType+    expr_out_ty = substTy env (exprType expr)+    -- NB: Since 'expr' is term-valued, not (Type ty), this call+    --     to exprType will succeed.  exprType fails on (Type ty).++simplExprC :: SimplEnv+           -> InExpr     -- A term-valued expression, never (Type ty)+           -> SimplCont+           -> SimplM OutExpr+        -- Simplify an expression, given a continuation+simplExprC env expr cont+  = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seFloats env) ) $+    do  { (env', expr') <- simplExprF (zapFloats env) expr cont+        ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $+          -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $+          -- pprTrace "simplExprC ret4" (ppr (seFloats env')) $+          return (wrapFloats env' expr') }++--------------------------------------------------+simplExprF :: SimplEnv+           -> InExpr     -- A term-valued expression, never (Type ty)+           -> SimplCont+           -> SimplM (SimplEnv, OutExpr)++simplExprF env e cont+  = -- pprTrace "simplExprF" (vcat+--      [ ppr e+--      , text "cont =" <+> ppr cont+--      , text "inscope =" <+> ppr (seInScope env)+--      , text "tvsubst =" <+> ppr (seTvSubst env)+--      , text "idsubst =" <+> ppr (seIdSubst env)+--      , text "cvsubst =" <+> ppr (seCvSubst env)+--      {- , ppr (seFloats env) -}+--      ]) $+    simplExprF1 env e cont++simplExprF1 :: SimplEnv -> InExpr -> SimplCont+            -> SimplM (SimplEnv, OutExpr)++simplExprF1 _ (Type ty) _+  = pprPanic "simplExprF: type" (ppr ty)+    -- simplExprF does only with term-valued expressions+    -- The (Type ty) case is handled separately by simplExpr+    -- and by the other callers of simplExprF++simplExprF1 env (Var v)        cont = simplIdF env v cont+simplExprF1 env (Lit lit)      cont = rebuild env (Lit lit) cont+simplExprF1 env (Tick t expr)  cont = simplTick env t expr cont+simplExprF1 env (Cast body co) cont = simplCast env body co cont+simplExprF1 env (Coercion co)  cont = simplCoercionF env co cont++simplExprF1 env (App fun arg) cont+  = case arg of+      Type ty -> do { -- The argument type will (almost) certainly be used+                      -- in the output program, so just force it now.+                      -- See Note [Avoiding space leaks in OutType]+                      arg' <- simplType env ty++                      -- But use substTy, not simplType, to avoid forcing+                      -- the hole type; it will likely not be needed.+                      -- See Note [The hole type in ApplyToTy]+                    ; let hole' = substTy env (exprType fun)++                    ; simplExprF env fun $+                      ApplyToTy { sc_arg_ty  = arg'+                                , sc_hole_ty = hole'+                                , sc_cont    = cont } }+      _       -> simplExprF env fun $+                 ApplyToVal { sc_arg = arg, sc_env = env+                            , sc_dup = NoDup, sc_cont = cont }++simplExprF1 env expr@(Lam {}) cont+  = simplLam env zapped_bndrs body cont+        -- The main issue here is under-saturated lambdas+        --   (\x1. \x2. e) arg1+        -- Here x1 might have "occurs-once" occ-info, because occ-info+        -- is computed assuming that a group of lambdas is applied+        -- all at once.  If there are too few args, we must zap the+        -- occ-info, UNLESS the remaining binders are one-shot+  where+    (bndrs, body) = collectBinders expr+    zapped_bndrs | need_to_zap = map zap bndrs+                 | otherwise   = bndrs++    need_to_zap = any zappable_bndr (drop n_args bndrs)+    n_args = countArgs cont+        -- NB: countArgs counts all the args (incl type args)+        -- and likewise drop counts all binders (incl type lambdas)++    zappable_bndr b = isId b && not (isOneShotBndr b)+    zap b | isTyVar b = b+          | otherwise = zapLamIdInfo b++simplExprF1 env (Case scrut bndr _ alts) cont+  = simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr+                                 , sc_alts = alts+                                 , sc_env = env, sc_cont = cont })++simplExprF1 env (Let (Rec pairs) body) cont+  = simplRecE env pairs body cont++simplExprF1 env (Let (NonRec bndr rhs) body) cont+  | Type ty <- rhs    -- First deal with type lets (let a = Type ty in e)+  = ASSERT( isTyVar bndr )+    do { ty' <- simplType env ty+       ; simplExprF (extendTvSubst env bndr ty') body cont }++  | otherwise+  = simplNonRecE env bndr (rhs, env) ([], body) cont++{- Note [Avoiding space leaks in OutType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Since the simplifier is run for multiple iterations, we need to ensure+that any thunks in the output of one simplifier iteration are forced+by the evaluation of the next simplifier iteration. Otherwise we may+retain multiple copies of the Core program and leak a terrible amount+of memory (as in #13426).++The simplifier is naturally strict in the entire "Expr part" of the+input Core program, because any expression may contain binders, which+we must find in order to extend the SimplEnv accordingly. But types+do not contain binders and so it is tempting to write things like++    simplExpr env (Type ty) = return (Type (substTy env ty))   -- Bad!++This is Bad because the result includes a thunk (substTy env ty) which+retains a reference to the whole simplifier environment; and the next+simplifier iteration will not force this thunk either, because the+line above is not strict in ty.++So instead our strategy is for the simplifier to fully evaluate+OutTypes when it emits them into the output Core program, for example++    simplExpr env (Type ty) = do { ty' <- simplType env ty     -- Good+                                 ; return (Type ty') }++where the only difference from above is that simplType calls seqType+on the result of substTy.++However, SimplCont can also contain OutTypes and it's not necessarily+a good idea to force types on the way in to SimplCont, because they+may end up not being used and forcing them could be a lot of wasted+work. T5631 is a good example of this.++- For ApplyToTy's sc_arg_ty, we force the type on the way in because+  the type will almost certainly appear as a type argument in the+  output program.++- For the hole types in Stop and ApplyToTy, we force the type when we+  emit it into the output program, after obtaining it from+  contResultType. (The hole type in ApplyToTy is only directly used+  to form the result type in a new Stop continuation.)+-}++---------------------------------+-- Simplify a join point, adding the context.+-- Context goes *inside* the lambdas. IOW, if the join point has arity n, we do:+--   \x1 .. xn -> e => \x1 .. xn -> E[e]+-- Note that we need the arity of the join point, since e may be a lambda+-- (though this is unlikely). See Note [Case-of-case and join points].+simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont+             -> SimplM OutExpr+simplJoinRhs env bndr expr cont+  | Just arity <- isJoinId_maybe bndr+  =  do { let (join_bndrs, join_body) = collectNBinders arity expr+        ; (env', join_bndrs') <- simplLamBndrs env join_bndrs+        ; join_body' <- simplExprC env' join_body cont+        ; return $ mkLams join_bndrs' join_body' }++  | otherwise+  = pprPanic "simplJoinRhs" (ppr bndr)++---------------------------------+simplType :: SimplEnv -> InType -> SimplM OutType+        -- Kept monadic just so we can do the seqType+        -- See Note [Avoiding space leaks in OutType]+simplType env ty+  = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $+    seqType new_ty `seq` return new_ty+  where+    new_ty = substTy env ty++---------------------------------+simplCoercionF :: SimplEnv -> InCoercion -> SimplCont+               -> SimplM (SimplEnv, OutExpr)+simplCoercionF env co cont+  = do { co' <- simplCoercion env co+       ; rebuild env (Coercion co') cont }++simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion+simplCoercion env co+  = let opt_co = optCoercion (getTCvSubst env) co+    in seqCo opt_co `seq` return opt_co++-----------------------------------+-- | Push a TickIt context outwards past applications and cases, as+-- long as this is a non-scoping tick, to let case and application+-- optimisations apply.++simplTick :: SimplEnv -> Tickish Id -> InExpr -> SimplCont+          -> SimplM (SimplEnv, OutExpr)+simplTick env tickish expr cont+  -- A scoped tick turns into a continuation, so that we can spot+  -- (scc t (\x . e)) in simplLam and eliminate the scc.  If we didn't do+  -- it this way, then it would take two passes of the simplifier to+  -- reduce ((scc t (\x . e)) e').+  -- NB, don't do this with counting ticks, because if the expr is+  -- bottom, then rebuildCall will discard the continuation.++-- XXX: we cannot do this, because the simplifier assumes that+-- the context can be pushed into a case with a single branch. e.g.+--    scc<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 { (env', expr') <- simplExprF env expr cont+       ; return (env', mkTick tickish expr')+       }++  -- Push tick inside if the context looks like this will allow us to+  -- do a case-of-case - see Note [case-of-scc-of-case]+  | Select {} <- cont, Just expr' <- push_tick_inside+  = simplExprF env expr' cont++  -- We don't want to move the tick, but we might still want to allow+  -- floats to pass through with appropriate wrapping (or not, see+  -- wrap_floats below)+  --- | not (tickishCounts tickish) || tickishCanSplit tickish+  -- = wrap_floats++  | otherwise+  = no_floating_past_tick++ where++  -- Try to push tick inside a case, see Note [case-of-scc-of-case].+  push_tick_inside =+    case expr0 of+      Case scrut bndr ty alts+             -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts)+      _other -> Nothing+   where (ticks, expr0) = stripTicksTop movable (Tick tickish expr)+         movable t      = not (tickishCounts t) ||+                          t `tickishScopesLike` NoScope ||+                          tickishCanSplit t+         tickScrut e    = foldr mkTick e ticks+         -- Alternatives get annotated with all ticks that scope in some way,+         -- but we don't want to count entries.+         tickAlt (c,bs,e) = (c,bs, foldr mkTick e ts_scope)+         ts_scope         = map mkNoCount $+                            filter (not . (`tickishScopesLike` NoScope)) ticks++  no_floating_past_tick =+    do { let (inc,outc) = splitCont cont+       ; (env', expr') <- simplExprF (zapFloats env) expr inc+       ; let tickish' = simplTickish env tickish+       ; (env'', expr'') <- rebuild (zapFloats env')+                                    (wrapFloats env' expr')+                                    (TickIt tickish' outc)+       ; return (addFloats env env'', expr'')+       }++-- Alternative version that wraps outgoing floats with the tick.  This+-- results in ticks being duplicated, as we don't make any attempt to+-- eliminate the tick if we re-inline the binding (because the tick+-- semantics allows unrestricted inlining of HNFs), so I'm not doing+-- this any more.  FloatOut will catch any real opportunities for+-- floating.+--+--  wrap_floats =+--    do { let (inc,outc) = splitCont cont+--       ; (env', expr') <- simplExprF (zapFloats env) expr inc+--       ; let tickish' = simplTickish env tickish+--       ; let wrap_float (b,rhs) = (zapIdStrictness (setIdArity b 0),+--                                   mkTick (mkNoCount tickish') rhs)+--              -- when wrapping a float with mkTick, we better zap the Id's+--              -- strictness info and arity, because it might be wrong now.+--       ; let env'' = addFloats env (mapFloats env' wrap_float)+--       ; rebuild env'' expr' (TickIt tickish' outc)+--       }+++  simplTickish env tickish+    | Breakpoint n ids <- tickish+          = Breakpoint n (map (getDoneId . substId env) ids)+    | otherwise = tickish++  -- Push type application and coercion inside a tick+  splitCont :: SimplCont -> (SimplCont, SimplCont)+  splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc)+    where (inc,outc) = splitCont tail+  splitCont (CastIt co c) = (CastIt co inc, outc)+    where (inc,outc) = splitCont c+  splitCont other = (mkBoringStop (contHoleType other), other)++  getDoneId (DoneId id) = id+  getDoneId (DoneEx e)  = getIdFromTrivialExpr e -- Note [substTickish] in CoreSubst+  getDoneId other = pprPanic "getDoneId" (ppr other)++-- Note [case-of-scc-of-case]+-- It's pretty important to be able to transform case-of-case when+-- there's an SCC in the way.  For example, the following comes up+-- in nofib/real/compress/Encode.hs:+--+--        case scctick<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 (SimplEnv, OutExpr)+-- At this point the substitution in the SimplEnv should be irrelevant+-- only the in-scope set and floats should matter+rebuild env expr cont+  = case cont of+      Stop {}          -> return (env, expr)+      TickIt t cont    -> rebuild env (mkTick t expr) cont+      CastIt co cont   -> rebuild env (mkCast expr co) cont+                       -- NB: mkCast implements the (Coercion co |> g) optimisation++      Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }+        -> rebuildCase (se `setFloats` env) expr bndr alts cont++      StrictArg info _ cont         -> rebuildCall env (info `addValArgTo` expr) cont+      StrictBind b bs body se cont  -> do { env' <- simplNonRecX (se `setFloats` env) b expr+                                               -- expr satisfies let/app since it started life+                                               -- in a call to simplNonRecE+                                          ; simplLam env' bs body cont }++      ApplyToTy  { sc_arg_ty = ty, sc_cont = cont}+        -> rebuild env (App expr (Type ty)) cont++      ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag, sc_cont = cont}+        -- See Note [Avoid redundant simplification]+        | isSimplified dup_flag+        -> rebuild env (App expr arg) cont++        | otherwise+        -> do { arg' <- simplExpr (se `setInScopeAndZapFloats` env) arg+              ; rebuild env (App expr arg') cont }+++{-+************************************************************************+*                                                                      *+\subsection{Lambdas}+*                                                                      *+************************************************************************+-}++simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont+          -> SimplM (SimplEnv, OutExpr)+simplCast env body co0 cont0+  = do  { co1   <- simplCoercion env co0+        ; cont1 <- addCoerce co1 cont0+        ; simplExprF env body cont1 }+  where+       addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont+       addCoerce co1 (CastIt co2 cont)+         = addCoerce (mkTransCo co1 co2) cont++       addCoerce co cont@(ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })+         | Just (arg_ty', co') <- pushCoTyArg co arg_ty+         = do { tail' <- addCoerce co' tail+              ; return (cont { sc_arg_ty = arg_ty', sc_cont = tail' }) }++       addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se+                                , sc_dup = dup, sc_cont = tail })+         | Just (co1, co2) <- pushCoValArg co+         , Pair _ new_ty <- coercionKind co1+         , not (isTypeLevPoly new_ty)  -- without this check, we get a lev-poly arg+                                       -- See Note [Levity polymorphism invariants] in CoreSyn+                                       -- test: typecheck/should_run/EtaExpandLevPoly+         = do { tail' <- addCoerce co2 tail+              ; if isReflCo co1+                then return (cont { sc_cont = tail' })+                     -- Avoid simplifying if possible;+                     -- See Note [Avoiding exponential behaviour]+                else do+              { (dup', arg_se', arg') <- simplArg env dup arg_se arg+                   -- When we build the ApplyTo we can't mix the OutCoercion+                   -- 'co' with the InExpr 'arg', so we simplify+                   -- to make it all consistent.  It's a bit messy.+                   -- But it isn't a common case.+                   -- Example of use: Trac #995+              ; return (ApplyToVal { sc_arg  = mkCast arg' co1+                                   , sc_env  = arg_se'+                                   , sc_dup  = dup'+                                   , sc_cont = tail' }) } }++       addCoerce co cont+         | isReflexiveCo co = return cont+         | otherwise        = return (CastIt co cont)+                -- It's worth checking isReflexiveCo.+                -- For example, in the initial form of a worker+                -- we may find  (coerce T (coerce S (\x.e))) y+                -- and we'd like it to simplify to e[y/x] in one round+                -- of simplification++simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr+         -> SimplM (DupFlag, StaticEnv, OutExpr)+simplArg env dup_flag arg_env arg+  | isSimplified dup_flag+  = return (dup_flag, arg_env, arg)+  | otherwise+  = do { arg' <- simplExpr (arg_env `setInScopeAndZapFloats` env) arg+       ; return (Simplified, zapSubstEnv arg_env, arg') }++{-+************************************************************************+*                                                                      *+\subsection{Lambdas}+*                                                                      *+************************************************************************++Note [Zap unfolding when beta-reducing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Lambda-bound variables can have stable unfoldings, such as+   $j = \x. \b{Unf=Just x}. e+See Note [Case binders and join points] below; the unfolding for lets+us optimise e better.  However when we beta-reduce it we want to+revert to using the actual value, otherwise we can end up in the+stupid situation of+          let x = blah in+          let b{Unf=Just x} = y+          in ...b...+Here it'd be far better to drop the unfolding and use the actual RHS.+-}++simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont+         -> SimplM (SimplEnv, OutExpr)++simplLam env [] body cont = simplExprF env body cont++        -- Beta reduction++simplLam env (bndr:bndrs) body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })+  = do { tick (BetaReduction bndr)+       ; simplLam (extendTvSubst env bndr arg_ty) bndrs body cont }++simplLam env (bndr:bndrs) body (ApplyToVal { sc_arg = arg, sc_env = arg_se+                                           , sc_cont = cont, sc_dup = dup })+  | isSimplified dup  -- Don't re-simplify if we've simplified it once+                      -- See Note [Avoiding exponential behaviour]+  = do  { tick (BetaReduction bndr)+        ; env' <- simplNonRecX env zapped_bndr arg+        ; simplLam env' bndrs body cont }++  | otherwise+  = do  { tick (BetaReduction bndr)+        ; simplNonRecE env zapped_bndr (arg, arg_se) (bndrs, body) cont }+  where+    zapped_bndr  -- See Note [Zap unfolding when beta-reducing]+      | isId bndr, isStableUnfolding (realIdUnfolding bndr)+                  = setIdUnfolding bndr NoUnfolding+      | otherwise = bndr++      -- discard a non-counting tick on a lambda.  This may change the+      -- cost attribution slightly (moving the allocation of the+      -- lambda elsewhere), but we don't care: optimisation changes+      -- cost attribution all the time.+simplLam env bndrs body (TickIt tickish cont)+  | not (tickishCounts tickish)+  = simplLam env bndrs body cont++        -- Not enough args, so there are real lambdas left to put in the result+simplLam env bndrs body cont+  = do  { (env', bndrs') <- simplLamBndrs env bndrs+        ; body' <- simplExpr env' body+        ; new_lam <- mkLam env bndrs' body' cont+        ; rebuild env' new_lam cont }++simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])+simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs++-------------+simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)+-- Used for lambda binders.  These sometimes have unfoldings added by+-- the worker/wrapper pass that must be preserved, because they can't+-- be reconstructed from context.  For example:+--      f x = case x of (a,b) -> fw a b x+--      fw a b x{=(a,b)} = ...+-- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.+simplLamBndr env bndr+  | isId bndr && isFragileUnfolding old_unf   -- Special case+  = do { (env1, bndr1) <- simplBinder env bndr+       ; unf'          <- simplUnfolding env1 NotTopLevel Nothing bndr old_unf+       ; let bndr2 = bndr1 `setIdUnfolding` unf'+       ; return (modifyInScope env1 bndr2, bndr2) }++  | otherwise+  = simplBinder env bndr                -- Normal case+  where+    old_unf = idUnfolding bndr++------------------+simplNonRecE :: SimplEnv+             -> InId                    -- The binder, always an Id+                                        -- Can be a join point+             -> (InExpr, SimplEnv)      -- Rhs of binding (or arg of lambda)+             -> ([InBndr], InExpr)      -- Body of the let/lambda+                                        --      \xs.e+             -> SimplCont+             -> SimplM (SimplEnv, OutExpr)++-- simplNonRecE is used for+--  * non-top-level non-recursive lets in expressions+--  * beta reduction+--+-- It deals with strict bindings, via the StrictBind continuation,+-- which may abort the whole process+--+-- Precondition: rhs satisfies the let/app invariant+--               Note [CoreSyn let/app invariant] in CoreSyn+--+-- The "body" of the binding comes as a pair of ([InId],InExpr)+-- representing a lambda; so we recurse back to simplLam+-- Why?  Because of the binder-occ-info-zapping done before+--       the call to simplLam in simplExprF (Lam ...)++simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont+  = ASSERT( isId bndr )+    do dflags <- getDynFlags+       case () of+         _ | preInlineUnconditionally dflags env NotTopLevel bndr rhs+           -> do { tick (PreInlineUnconditionally bndr)+                 ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $+                  simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }++           | isStrictId bndr          -- Includes coercions+           -> simplExprF (rhs_se `setFloats` env) rhs+                         (StrictBind bndr bndrs body env cont)++           | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs+           -> do { let cont_dup_res_ty = resultTypeOfDupableCont (getMode env)+                                           [bndr'] cont+                 ; (env1, bndr1) <- simplNonRecJoinBndr env+                                                        cont_dup_res_ty bndr'+                 ; (env2, bndr2) <- addBndrRules env1 bndr' bndr1+                 ; (env3, cont_dup, cont_nodup)+                     <- prepareLetCont (zapJoinFloats env2) [bndr'] cont+                 ; MASSERT2(cont_dup_res_ty `eqType` contResultType cont_dup,+                     ppr cont_dup_res_ty $$ blankLine $$+                     ppr cont $$ blankLine $$+                     ppr cont_dup $$ blankLine $$+                     ppr cont_nodup)+                 ; env4 <- simplJoinBind env3 NonRecursive cont_dup bndr' bndr2+                                         rhs' rhs_se+                 ; (env5, expr) <- simplLam env4 bndrs body cont_dup+                 ; rebuild (env5 `restoreJoinFloats` env2)+                           (wrapJoinFloats env5 expr) cont_nodup }++           | otherwise+           -> ASSERT( not (isTyVar bndr) )+              do { (env1, bndr1) <- simplNonRecBndr env bndr+                 ; (env2, bndr2) <- addBndrRules env1 bndr bndr1+                 ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se+                 ; simplLam env3 bndrs body cont }++------------------+simplRecE :: SimplEnv+          -> [(InId, InExpr)]+          -> InExpr+          -> SimplCont+          -> SimplM (SimplEnv, OutExpr)++-- simplRecE is used for+--  * non-top-level recursive lets in expressions+simplRecE env pairs body cont+  | Just pairs' <- joinPointBindings_maybe pairs+  = do  { let bndrs' = map fst pairs'+              cont_dup_res_ty = resultTypeOfDupableCont (getMode env)+                                                        bndrs' cont+        ; env1 <- simplRecJoinBndrs env cont_dup_res_ty bndrs'+                -- NB: bndrs' don't have unfoldings or rules+                -- We add them as we go down+        ; (env2, cont_dup, cont_nodup) <- prepareLetCont (zapJoinFloats env1)+                                                         bndrs' cont+        ; MASSERT2(cont_dup_res_ty `eqType` contResultType cont_dup,+            ppr cont_dup_res_ty $$ blankLine $$+            ppr cont $$ blankLine $$+            ppr cont_dup $$ blankLine $$+            ppr cont_nodup)+        ; env3 <- simplRecBind env2 NotTopLevel (Just cont_dup) pairs'+        ; (env4, expr) <- simplExprF env3 body cont_dup+        ; rebuild (env4 `restoreJoinFloats` env1)+                  (wrapJoinFloats env4 expr) cont_nodup }+  | otherwise+  = do  { let bndrs = map fst pairs+        ; MASSERT(all (not . isJoinId) bndrs)+        ; env1 <- simplRecBndrs env bndrs+                -- NB: bndrs' don't have unfoldings or rules+                -- We add them as we go down+        ; env2 <- simplRecBind env1 NotTopLevel Nothing pairs+        ; simplExprF env2 body cont }+++{-+************************************************************************+*                                                                      *+                     Variables+*                                                                      *+************************************************************************+-}++simplVar :: SimplEnv -> InVar -> SimplM OutExpr+-- Look up an InVar in the environment+simplVar env var+  | isTyVar var = return (Type (substTyVar env var))+  | isCoVar var = return (Coercion (substCoVar env var))+  | otherwise+  = case substId env var of+        DoneId var1          -> return (Var var1)+        DoneEx e             -> return e+        ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e++simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr)+simplIdF env var cont+  = case substId env var of+        DoneEx e             -> simplExprF (zapSubstEnv env) e trimmed_cont+        ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont+                                  -- Don't trim; haven't already simplified+                                  -- the join, so the cont was never copied+        DoneId var1          -> completeCall env var1 trimmed_cont+                -- Note [zapSubstEnv]+                -- The template is already simplified, so don't re-substitute.+                -- This is VITAL.  Consider+                --      let x = e in+                --      let y = \z -> ...x... in+                --      \ x -> ...y...+                -- We'll clone the inner \x, adding x->x' in the id_subst+                -- Then when we inline y, we must *not* replace x by x' in+                -- the inlined copy!!+  where+    trimmed_cont | Just arity <- isJoinIdInEnv_maybe env var+                 = trim_cont arity cont+                 | otherwise+                 = cont++    -- Drop outer context from join point invocation+    -- Note [Case-of-case and join points]+    trim_cont 0 cont@(Stop {})+      = cont+    trim_cont 0 cont+      = mkBoringStop (contResultType cont)+    trim_cont n cont@(ApplyToVal { sc_cont = k })+      = cont { sc_cont = trim_cont (n-1) k }+    trim_cont n cont@(ApplyToTy { sc_cont = k })+      = cont { sc_cont = trim_cont (n-1) k } -- join arity counts types!+    trim_cont _ cont+      = pprPanic "completeCall" $ ppr var $$ ppr cont++---------------------------------------------------------+--      Dealing with a call site++completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplEnv, OutExpr)+completeCall env var cont+  = do  {   ------------- Try inlining ----------------+          dflags <- getDynFlags+        ; let  (lone_variable, arg_infos, call_cont) = contArgs cont+               n_val_args = length arg_infos+               interesting_cont = interestingCallContext call_cont+               unfolding    = activeUnfolding env var+               maybe_inline = callSiteInline dflags var unfolding+                                             lone_variable arg_infos interesting_cont+        ; case maybe_inline of+            Just expr      -- There is an inlining!+              ->  do { checkedTick (UnfoldingDone var)+                     ; dump_inline dflags expr cont+                     ; simplExprF (zapSubstEnv env) expr cont }++            ; Nothing -> do { rule_base <- getSimplRules+                            ; let info = mkArgInfo var (getRules rule_base var)+                                                   n_val_args call_cont+                            ; rebuildCall env info cont }+    }+  where+    dump_inline dflags unfolding cont+      | not (dopt Opt_D_dump_inlinings dflags) = return ()+      | not (dopt Opt_D_verbose_core2core dflags)+      = when (isExternalName (idName var)) $+            liftIO $ printOutputForUser dflags alwaysQualify $+                sep [text "Inlining done:", nest 4 (ppr var)]+      | otherwise+      = liftIO $ printOutputForUser dflags alwaysQualify $+           sep [text "Inlining done: " <> ppr var,+                nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),+                              text "Cont:  " <+> ppr cont])]++rebuildCall :: SimplEnv+            -> ArgInfo+            -> SimplCont+            -> SimplM (SimplEnv, OutExpr)+-- We decided not to inline, so+--    - simplify the arguments+--    - try rewrite rules+--    - and rebuild++---------- Bottoming applications --------------+rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) cont+  -- When we run out of strictness args, it means+  -- that the call is definitely bottom; see SimplUtils.mkArgInfo+  -- Then we want to discard the entire strict continuation.  E.g.+  --    * case (error "hello") of { ... }+  --    * (error "Hello") arg+  --    * f (error "Hello") where f is strict+  --    etc+  -- Then, especially in the first of these cases, we'd like to discard+  -- the continuation, leaving just the bottoming expression.  But the+  -- type might not be right, so we may have to add a coerce.+  | not (contIsTrivial cont)     -- Only do this if there is a non-trivial+                                 -- continuation to discard, else we do it+                                 -- again and again!+  = seqType cont_ty `seq`        -- See Note [Avoiding space leaks in OutType]+    return (env, castBottomExpr res cont_ty)+  where+    res     = argInfoExpr fun rev_args+    cont_ty = contResultType cont++---------- Try rewrite RULES --------------+-- See Note [Trying rewrite rules]+rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args+                              , ai_rules = Just (nr_wanted, rules) }) cont+  | nr_wanted == 0 || no_more_args+  , let info' = info { ai_rules = Nothing }+  = -- We've accumulated a simplified call in <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_cont = cont })+  = rebuildCall env (addTyArgTo info arg_ty) cont++rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty+                              , ai_strs = str:strs, ai_discs = disc:discs })+            (ApplyToVal { sc_arg = arg, sc_env = arg_se+                        , sc_dup = dup_flag, sc_cont = cont })+  | isSimplified dup_flag     -- See Note [Avoid redundant simplification]+  = rebuildCall env (addValArgTo info' arg) cont++  | str                 -- Strict argument+  = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $+    simplExprF (arg_se `setFloats` env) arg+               (StrictArg info' cci_strict cont)+                -- Note [Shadowing]++  | otherwise                           -- Lazy argument+        -- DO NOT float anything outside, hence simplExprC+        -- There is no benefit (unlike in a let-binding), and we'd+        -- have to be very careful about bogus strictness through+        -- floating a demanded let.+  = do  { arg' <- simplExprC (arg_se `setInScopeAndZapFloats` env) arg+                             (mkLazyArgStop arg_ty cci_lazy)+        ; rebuildCall env (addValArgTo info' arg') cont }+  where+    info'  = info { ai_strs = strs, ai_discs = discs }+    arg_ty = funArgTy fun_ty++    -- Use this for lazy arguments+    cci_lazy | encl_rules = RuleArgCtxt+             | disc > 0   = DiscArgCtxt  -- Be keener here+             | otherwise  = BoringCtxt   -- Nothing interesting++    -- ..and this for strict arguments+    cci_strict | encl_rules = RuleArgCtxt+               | disc > 0   = DiscArgCtxt+               | otherwise  = RhsCtxt+      -- Why RhsCtxt?  if we see f (g x) (h x), and f is strict, we+      -- want to be a bit more eager to inline g, because it may+      -- expose an eval (on x perhaps) that can be eliminated or+      -- shared. I saw this in nofib 'boyer2', RewriteFuns.onewayunify1+      -- It's worth an 18% improvement in allocation for this+      -- particular benchmark; 5% on 'mate' and 1.3% on 'multiplier'++---------- No further useful info, revert to generic rebuild ------------+rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont+  = rebuild env (argInfoExpr fun rev_args) cont++{- Note [Trying rewrite rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider an application (f e1 e2 e3) where the e1,e2,e3 are not yet+simplified.  We want to simplify enough arguments to allow the rules+to apply, but it's more efficient to avoid simplifying e2,e3 if e1 alone+is sufficient.  Example: class ops+   (+) dNumInt e2 e3+If we rewrite ((+) dNumInt) to plusInt, we can take advantage of the+latter's strictness when simplifying e2, e3.  Moreover, suppose we have+  RULE  f Int = \x. x True++Then given (f Int e1) we rewrite to+   (\x. x True) e1+without simpifying e1.  Now we can inline x into its unique call site,+and absorb the True into it all in the same pass.  If we simplified+e1 first, we couldn't do that; see Note [Avoiding exponential behaviour].++So we try to apply rules if either+  (a) no_more_args: we've run out of argument that the rules can "see"+  (b) nr_wanted: none of the rules wants any more arguments+++Note [RULES apply to simplified arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's very desirable to try RULES once the arguments have been simplified, because+doing so ensures that rule cascades work in one pass.  Consider+   {-# RULES g (h x) = k x+             f (k x) = x #-}+   ...f (g (h x))...+Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If+we match f's rules against the un-simplified RHS, it won't match.  This+makes a particularly big difference when superclass selectors are involved:+        op ($p1 ($p2 (df d)))+We want all this to unravel in one sweep.++Note [Avoid redundant simplification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Because RULES apply to simplified arguments, there's a danger of repeatedly+simplifying already-simplified arguments.  An important example is that of+        (>>=) d e1 e2+Here e1, e2 are simplified before the rule is applied, but don't really+participate in the rule firing. So we mark them as Simplified to avoid+re-simplifying them.++Note [Shadowing]+~~~~~~~~~~~~~~~~+This part of the simplifier may break the no-shadowing invariant+Consider+        f (...(\a -> e)...) (case y of (a,b) -> e')+where f is strict in its second arg+If we simplify the innermost one first we get (...(\a -> e)...)+Simplifying the second arg makes us float the case out, so we end up with+        case y of (a,b) -> f (...(\a -> e)...) e'+So the output does not have the no-shadowing invariant.  However, there is+no danger of getting name-capture, because when the first arg was simplified+we used an in-scope set that at least mentioned all the variables free in its+static environment, and that is enough.++We can't just do innermost first, or we'd end up with a dual problem:+        case x of (a,b) -> f e (...(\a -> e')...)++I spent hours trying to recover the no-shadowing invariant, but I just could+not think of an elegant way to do it.  The simplifier is already knee-deep in+continuations.  We have to keep the right in-scope set around; AND we have+to get the effect that finding (error "foo") in a strict arg position will+discard the entire application and replace it with (error "foo").  Getting+all this at once is TOO HARD!+++************************************************************************+*                                                                      *+                Rewrite rules+*                                                                      *+************************************************************************+-}++tryRules :: SimplEnv -> [CoreRule]+         -> Id -> [ArgSpec]+         -> SimplCont+         -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))++tryRules env rules fn args call_cont+  | null rules+  = return Nothing+{- Disabled until we fix #8326+  | fn `hasKey` tagToEnumKey   -- See Note [Optimising tagToEnum#]+  , [_type_arg, val_arg] <- args+  , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont+  , isDeadBinder bndr+  = do { dflags <- getDynFlags+       ; let enum_to_tag :: CoreAlt -> CoreAlt+                -- Takes   K -> e  into   tagK# -> e+                -- where tagK# is the tag of constructor K+             enum_to_tag (DataAlt con, [], rhs)+               = ASSERT( isEnumerationTyCon (dataConTyCon con) )+                (LitAlt tag, [], rhs)+              where+                tag = mkMachInt dflags (toInteger (dataConTag con - fIRST_TAG))+             enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt)++             new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts+             new_bndr = setIdType bndr intPrimTy+                 -- The binder is dead, but should have the right type+      ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) }+-}+  | otherwise+  = do { dflags <- getDynFlags+       ; case lookupRule dflags (getUnfoldingInRuleMatch env) (activeRule env)+                         fn (argInfoAppArgs args) rules of {+           Nothing ->+             do { nodump dflags  -- This ensures that an empty file is written+                ; return Nothing } ;  -- No rule matches+           Just (rule, rule_rhs) ->+             do { checkedTick (RuleFired (ruleName rule))+                ; let cont' = pushSimplifiedArgs zapped_env+                                                 (drop (ruleArity rule) args)+                                                 call_cont+                              -- (ruleArity rule) says how+                              -- many args the rule consumed++                      occ_anald_rhs = occurAnalyseExpr rule_rhs+                          -- See Note [Occurrence-analyse after rule firing]+                ; dump dflags rule rule_rhs+                ; return (Just (zapped_env, occ_anald_rhs, cont')) }}}+                     -- The occ_anald_rhs and cont' are all Out things+                     -- hence zapping the environment+  where+    zapped_env = zapSubstEnv env  -- See Note [zapSubstEnv]++    printRuleModule rule =+      parens+        (maybe (text "BUILTIN") (pprModuleName . moduleName) (ruleModule rule))++    dump dflags rule rule_rhs+      | dopt Opt_D_dump_rule_rewrites dflags+      = log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat+          [ text "Rule:" <+> ftext (ruleName rule)+          , text "Module:" <+>  printRuleModule rule+          , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args))+          , text "After: " <+> pprCoreExpr rule_rhs+          , text "Cont:  " <+> ppr call_cont ]++      | dopt Opt_D_dump_rule_firings dflags+      = log_rule dflags Opt_D_dump_rule_firings "Rule fired:" $+          ftext (ruleName rule)+            <+> printRuleModule rule++      | otherwise+      = return ()++    nodump dflags+      | dopt Opt_D_dump_rule_rewrites dflags+      = liftIO $ dumpSDoc dflags alwaysQualify Opt_D_dump_rule_rewrites "" empty++      | dopt Opt_D_dump_rule_firings dflags+      = liftIO $ dumpSDoc dflags alwaysQualify Opt_D_dump_rule_firings "" empty++      | otherwise+      = return ()++    log_rule dflags flag hdr details+      = liftIO . dumpSDoc dflags alwaysQualify flag "" $+                   sep [text hdr, nest 4 details]++trySeqRules :: SimplEnv+            -> OutExpr -> InExpr   -- Scrutinee and RHS+            -> SimplCont+            -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))+-- See Note [User-defined RULES for seq]+trySeqRules in_env scrut rhs cont+  = do { rule_base <- getSimplRules+       ; tryRules in_env (getRules rule_base seqId) seqId out_args rule_cont }+  where+    no_cast_scrut = drop_casts scrut+    scrut_ty  = exprType no_cast_scrut+    seq_id_ty = idType seqId+    rhs_ty    = substTy in_env (exprType rhs)+    out_args  = [ TyArg { as_arg_ty  = scrut_ty+                        , as_hole_ty = seq_id_ty }+                , TyArg { as_arg_ty  = rhs_ty+                       , as_hole_ty  = piResultTy seq_id_ty scrut_ty }+                , ValArg no_cast_scrut]+    rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs+                           , sc_env = in_env, sc_cont = cont }+    -- Lazily evaluated, so we don't do most of this++    drop_casts (Cast e _) = drop_casts e+    drop_casts e          = e++{- Note [User-defined RULES for seq]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given+   case (scrut |> co) of _ -> rhs+look for rules that match the expression+   seq @t1 @t2 scrut+where scrut :: t1+      rhs   :: t2++If you find a match, rewrite it, and apply to 'rhs'.++Notice that we can simply drop casts on the fly here, which+makes it more likely that a rule will match.++See Note [User-defined RULES for seq] in MkId.++Note [Occurrence-analyse after rule firing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+After firing a rule, we occurrence-analyse the instantiated RHS before+simplifying it.  Usually this doesn't make much difference, but it can+be huge.  Here's an example (simplCore/should_compile/T7785)++  map f (map f (map f xs)++= -- Use build/fold form of map, twice+  map f (build (\cn. foldr (mapFB c f) n+                           (build (\cn. foldr (mapFB c f) n xs))))++= -- Apply fold/build rule+  map f (build (\cn. (\cn. foldr (mapFB c f) n xs) (mapFB c f) n))++= -- Beta-reduce+  -- Alas we have no occurrence-analysed, so we don't know+  -- that c is used exactly once+  map f (build (\cn. let c1 = mapFB c f in+                     foldr (mapFB c1 f) n xs))++= -- Use mapFB rule:   mapFB (mapFB c f) g = mapFB c (f.g)+  -- We can do this because (mapFB c n) is a PAP and hence expandable+  map f (build (\cn. let c1 = mapFB c n in+                     foldr (mapFB c (f.f)) n x))++This is not too bad.  But now do the same with the outer map, and+we get another use of mapFB, and t can interact with /both/ remaining+mapFB calls in the above expression.  This is stupid because actually+that 'c1' binding is dead.  The outer map introduces another c2. If+there is a deep stack of maps we get lots of dead bindings, and lots+of redundant work as we repeatedly simplify the result of firing rules.++The easy thing to do is simply to occurrence analyse the result of+the rule firing.  Note that this occ-anals not only the RHS of the+rule, but also the function arguments, which by now are OutExprs.+E.g.+      RULE f (g x) = x+1++Call   f (g BIG)  -->   (\x. x+1) BIG++The rule binders are lambda-bound and applied to the OutExpr arguments+(here BIG) which lack all internal occurrence info.++Is this inefficient?  Not really: we are about to walk over the result+of the rule firing to simplify it, so occurrence analysis is at most+a constant factor.++Possible improvement: occ-anal the rules when putting them in the+database; and in the simplifier just occ-anal the OutExpr arguments.+But that's more complicated and the rule RHS is usually tiny; so I'm+just doing the simple thing.++Historical note: previously we did occ-anal the rules in Rule.hs,+but failed to occ-anal the OutExpr arguments, which led to the+nasty performance problem described above.+++Note [Optimising tagToEnum#]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have an enumeration data type:++  data Foo = A | B | C++Then we want to transform++   case tagToEnum# x of   ==>    case x of+     A -> e1                       DEFAULT -> e1+     B -> e2                       1#      -> e2+     C -> e3                       2#      -> e3++thereby getting rid of the tagToEnum# altogether.  If there was a DEFAULT+alternative we retain it (remember it comes first).  If not the case must+be exhaustive, and we reflect that in the transformed version by adding+a DEFAULT.  Otherwise Lint complains that the new case is not exhaustive.+See #8317.++Note [Rules for recursive functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+You might think that we shouldn't apply rules for a loop breaker:+doing so might give rise to an infinite loop, because a RULE is+rather like an extra equation for the function:+     RULE:           f (g x) y = x+y+     Eqn:            f a     y = a-y++But it's too drastic to disable rules for loop breakers.+Even the foldr/build rule would be disabled, because foldr+is recursive, and hence a loop breaker:+     foldr k z (build g) = g k z+So it's up to the programmer: rules can cause divergence+++************************************************************************+*                                                                      *+                Rebuilding a case expression+*                                                                      *+************************************************************************++Note [Case elimination]+~~~~~~~~~~~~~~~~~~~~~~~+The case-elimination transformation discards redundant case expressions.+Start with a simple situation:++        case x# of      ===>   let y# = x# in e+          y# -> e++(when x#, y# are of primitive type, of course).  We can't (in general)+do this for algebraic cases, because we might turn bottom into+non-bottom!++The code in SimplUtils.prepareAlts has the effect of generalise this+idea to look for a case where we're scrutinising a variable, and we+know that only the default case can match.  For example:++        case x of+          0#      -> ...+          DEFAULT -> ...(case x of+                         0#      -> ...+                         DEFAULT -> ...) ...++Here the inner case is first trimmed to have only one alternative, the+DEFAULT, after which it's an instance of the previous case.  This+really only shows up in eliminating error-checking code.++Note that SimplUtils.mkCase combines identical RHSs.  So++        case e of       ===> case e of DEFAULT -> r+           True  -> r+           False -> r++Now again the case may be elminated by the CaseElim transformation.+This includes things like (==# a# b#)::Bool so that we simplify+      case ==# a# b# of { True -> x; False -> x }+to just+      x+This particular example shows up in default methods for+comparison operations (e.g. in (>=) for Int.Int32)++Note [Case elimination: lifted case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+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...++        (a) 'e' is already evaluated (it may so if e is a variable)+            Specifically we check (exprIsHNF e).  In this case+            we can just allocate the WHNF directly with a let.+or+        (b) 'x' is not used at all and e is ok-for-speculation+             The ok-for-spec bit checks that we don't lose any+             exceptions or divergence.++             NB: it'd be *sound* to switch from case to let if the+             scrutinee was not yet WHNF but was guaranteed to+             converge; but sticking with case means we won't build a+             thunk++or+        (c) 'x' is used strictly in the body, and 'e' is a variable+            Then we can just substitute 'e' for 'x' in the body.+            See Note [Eliminating redundant seqs]++For (b), the "not used at all" test is important.  Consider+   case (case a ># b of { True -> (p,q); False -> (q,p) }) of+     r -> blah+The scrutinee is ok-for-speculation (it looks inside cases), but we do+not want to transform to+   let r = case a ># b of { True -> (p,q); False -> (q,p) }+   in blah+because that builds an unnecessary thunk.++Note [Eliminating redundant seqs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have this:+   case x of r { _ -> ..r.. }+where 'r' is used strictly in (..r..), the case is effectively a 'seq'+on 'x', but since 'r' is used strictly anyway, we can safely transform to+   (...x...)++Note that this can change the error behaviour.  For example, we might+transform+    case x of { _ -> error "bad" }+    --> error "bad"+which is might be puzzling if 'x' currently lambda-bound, but later gets+let-bound to (error "good").++Nevertheless, the paper "A semantics for imprecise exceptions" allows+this transformation. If you want to fix the evaluation order, use+'pseq'.  See Trac #8900 for an example where the loss of this+transformation bit us in practice.++See also Note [Empty case alternatives] in CoreSyn.++Just for reference, the original code (added Jan 13) looked like this:+     || case_bndr_evald_next rhs++    case_bndr_evald_next :: CoreExpr -> Bool+      -- See Note [Case binder next]+    case_bndr_evald_next (Var v)         = v == case_bndr+    case_bndr_evald_next (Cast e _)      = case_bndr_evald_next e+    case_bndr_evald_next (App e _)       = case_bndr_evald_next e+    case_bndr_evald_next (Case e _ _ _)  = case_bndr_evald_next e+    case_bndr_evald_next _               = False++(This came up when fixing Trac #7542. See also Note [Eta reduction of+an eval'd function] in CoreUtils.)+++Note [Case elimination: unlifted case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   case a +# b of r -> ...r...+Then we do case-elimination (to make a let) followed by inlining,+to get+        .....(a +# b)....+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.++This really isn't a big deal I think. The let can be+++Further notes about case elimination+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:       test :: Integer -> IO ()+                test = print++Turns out that this compiles to:+    Print.test+      = \ eta :: Integer+          eta1 :: Void# ->+          case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->+          case hPutStr stdout+                 (PrelNum.jtos eta ($w[] @ Char))+                 eta1+          of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s  }}++Notice the strange '<' which has no effect at all. This is a funny one.+It started like this:++f x y = if x < 0 then jtos x+          else if y==0 then "" else jtos x++At a particular call site we have (f v 1).  So we inline to get++        if v < 0 then jtos x+        else if 1==0 then "" else jtos x++Now simplify the 1==0 conditional:++        if v<0 then jtos v else jtos v++Now common-up the two branches of the case:++        case (v<0) of DEFAULT -> jtos v++Why don't we drop the case?  Because it's strict in v.  It's technically+wrong to drop even unnecessary evaluations, and in practice they+may be a result of 'seq' so we *definitely* don't want to drop those.+I don't really know how to improve this situation.+-}++---------------------------------------------------------+--      Eliminate the case if possible++rebuildCase, reallyRebuildCase+   :: SimplEnv+   -> OutExpr          -- Scrutinee+   -> InId             -- Case binder+   -> [InAlt]          -- Alternatives (inceasing order)+   -> SimplCont+   -> SimplM (SimplEnv, OutExpr)++--------------------------------------------------+--      1. Eliminate the case if there's a known constructor+--------------------------------------------------++rebuildCase env scrut case_bndr alts cont+  | Lit lit <- scrut    -- No need for same treatment as constructors+                        -- because literals are inlined more vigorously+  , not (litIsLifted lit)+  = do  { tick (KnownBranch case_bndr)+        ; case findAlt (LitAlt lit) alts of+            Nothing           -> missingAlt env case_bndr alts cont+            Just (_, bs, rhs) -> simple_rhs bs rhs }++  | Just (con, ty_args, other_args) <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut+        -- Works when the scrutinee is a variable with a known unfolding+        -- as well as when it's an explicit constructor application+  = do  { tick (KnownBranch case_bndr)+        ; case findAlt (DataAlt con) alts of+            Nothing  -> missingAlt env case_bndr alts cont+            Just (DEFAULT, bs, rhs) -> simple_rhs bs rhs+            Just (_, bs, rhs)       -> knownCon env scrut con ty_args other_args+                                                case_bndr bs rhs cont+        }+  where+    simple_rhs bs rhs = ASSERT( null bs )+                        do { env' <- simplNonRecX env case_bndr scrut+                               -- scrut is a constructor application,+                               -- hence satisfies let/app invariant+                           ; simplExprF env' rhs cont }+++--------------------------------------------------+--      2. Eliminate the case if scrutinee is evaluated+--------------------------------------------------++rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont+  -- See if we can get rid of the case altogether+  -- See Note [Case elimination]+  -- mkCase made sure that if all the alternatives are equal,+  -- then there is now only one (DEFAULT) rhs++  -- 2a.  Dropping the case altogether, if+  --      a) it binds nothing (so it's really just a 'seq')+  --      b) evaluating the scrutinee has no side effects+  | is_plain_seq+  , exprOkForSideEffects scrut+          -- The entire case is dead, so we can drop it+          -- if the scrutinee converges without having imperative+          -- side effects or raising a Haskell exception+          -- See Note [PrimOp can_fail and has_side_effects] in PrimOp+   = simplExprF env rhs cont++  -- 2b.  Turn the case into a let, if+  --      a) it binds only the case-binder+  --      b) unlifted case: the scrutinee is ok-for-speculation+  --           lifted case: the scrutinee is in HNF (or will later be demanded)+  | all_dead_bndrs+  , if is_unlifted+    then exprOkForSpeculation scrut  -- See Note [Case elimination: unlifted case]+    else exprIsHNF scrut             -- See Note [Case elimination: lifted case]+      || scrut_is_demanded_var scrut+  = do { tick (CaseElim case_bndr)+       ; env' <- simplNonRecX env case_bndr scrut+       ; simplExprF env' rhs cont }++  -- 2c. Try the seq rules if+  --     a) it binds only the case binder+  --     b) a rule for seq applies+  -- See Note [User-defined RULES for seq] in MkId+  | is_plain_seq+  = do { mb_rule <- trySeqRules env scrut rhs cont+       ; case mb_rule of+           Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont'+           Nothing                      -> reallyRebuildCase env scrut case_bndr alts cont }+  where+    is_unlifted        = isUnliftedType (idType case_bndr)+    all_dead_bndrs     = all isDeadBinder bndrs       -- bndrs are [InId]+    is_plain_seq       = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect++    scrut_is_demanded_var :: CoreExpr -> Bool+            -- See Note [Eliminating redundant seqs]+    scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s+    scrut_is_demanded_var (Var _)    = isStrictDmd (idDemandInfo case_bndr)+    scrut_is_demanded_var _          = False+++rebuildCase env scrut case_bndr alts cont+  = reallyRebuildCase env scrut case_bndr alts cont++--------------------------------------------------+--      3. Catch-all case+--------------------------------------------------++reallyRebuildCase env scrut case_bndr alts cont+  = do  {       -- Prepare the continuation;+                -- The new subst_env is in place+          (env', dup_cont, nodup_cont) <- prepareCaseCont (zapJoinFloats env)+                                                          alts cont++        -- Simplify the alternatives+        ; (scrut', case_bndr', alts') <- simplAlts env' scrut case_bndr alts dup_cont++        ; dflags <- getDynFlags+        ; let alts_ty' = contResultType dup_cont+        -- See Note [Avoiding space leaks in OutType]+        ; case_expr <- seqType alts_ty' `seq`+                       mkCase dflags scrut' case_bndr' alts_ty' alts'++        -- Notice that rebuild gets the in-scope set from env', not alt_env+        -- (which in any case is only build in simplAlts)+        -- The case binder *not* scope over the whole returned case-expression+        ; rebuild (env' `restoreJoinFloats` env)+                  (wrapJoinFloats env' case_expr) nodup_cont }++{-+simplCaseBinder checks whether the scrutinee is a variable, v.  If so,+try to eliminate uses of v in the RHSs in favour of case_bndr; that+way, there's a chance that v will now only be used once, and hence+inlined.++Historical note: we use to do the "case binder swap" in the Simplifier+so there were additional complications if the scrutinee was a variable.+Now the binder-swap stuff is done in the occurrence analyer; see+OccurAnal Note [Binder swap].++Note [knownCon occ info]+~~~~~~~~~~~~~~~~~~~~~~~~+If the case binder is not dead, then neither are the pattern bound+variables:+        case <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 (Trac #13468). So if++    data Void+    type instance F Bool = Void++then we'd like to transform+        case (x :: F Bool) of { _ -> error "urk" }+===>+        case (x |> co) of (x' :: Void) of {}++Nota Bene: we used to have a built-in rule for 'seq' that dropped+casts, so that+    case (x |> co) of { _ -> blah }+dropped the cast; in order to imporove the chances of trySeqRules+firing.  But that works in the /opposite/ direction to Note [Improving+seq] so there's a danger of flip/flopping.  Better to make trySeqRules+insensitive to the cast, which is now is.++The need for [Improving seq] showed up in Roman's experiments.  Example:+  foo :: F Int -> Int -> Int+  foo t n = t `seq` bar n+     where+       bar 0 = 0+       bar n = bar (n - case t of TI i -> i)+Here we'd like to avoid repeated evaluating t inside the loop, by+taking advantage of the `seq`.++At one point I did transformation in LiberateCase, but it's more+robust here.  (Otherwise, there's a danger that we'll simply drop the+'seq' altogether, before LiberateCase gets to see it.)+-}++simplAlts :: SimplEnv+          -> OutExpr+          -> InId                       -- Case binder+          -> [InAlt]                    -- Non-empty+          -> SimplCont+          -> SimplM (OutExpr, OutId, [OutAlt])  -- Includes the continuation+-- Like simplExpr, this just returns the simplified alternatives;+-- it does not return an environment+-- The returned alternatives can be empty, none are possible++simplAlts env scrut case_bndr alts cont'+  = do  { let env0 = zapFloats env++        ; (env1, case_bndr1) <- simplBinder env0 case_bndr+        ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding+              env2       = modifyInScope env1 case_bndr2+              -- See Note [Case binder evaluated-ness]++        ; fam_envs <- getFamEnvs+        ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut+                                                       case_bndr case_bndr2 alts++        ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts+          -- NB: it's possible that the returned in_alts is empty: this is handled+          -- by the caller (rebuildCase) in the missingAlt function++        ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts+        ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $+          return (scrut', case_bndr', alts') }+++------------------------------------+improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv+           -> OutExpr -> InId -> OutId -> [InAlt]+           -> SimplM (SimplEnv, OutExpr, OutId)+-- Note [Improving seq]+improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]+  | Just (co, ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1)+  = do { case_bndr2 <- newId (fsLit "nt") ty2+        ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCo co)+              env2 = extendIdSubst env case_bndr rhs+        ; return (env2, scrut `Cast` co, case_bndr2) }++improveSeq _ env scrut _ case_bndr1 _+  = return (env, scrut, case_bndr1)+++------------------------------------+simplAlt :: SimplEnv+         -> Maybe OutExpr  -- The scrutinee+         -> [AltCon]       -- These constructors can't be present when+                           -- matching the DEFAULT alternative+         -> OutId          -- The case binder+         -> SimplCont+         -> InAlt+         -> SimplM OutAlt++simplAlt env _ imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)+  = ASSERT( null bndrs )+    do  { let env' = addBinderUnfolding env case_bndr'+                                        (mkOtherCon imposs_deflt_cons)+                -- Record the constructors that the case-binder *can't* be.+        ; rhs' <- simplExprC env' rhs cont'+        ; return (DEFAULT, [], rhs') }++simplAlt env scrut' _ case_bndr' cont' (LitAlt lit, bndrs, rhs)+  = ASSERT( null bndrs )+    do  { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit)+        ; rhs' <- simplExprC env' rhs cont'+        ; return (LitAlt lit, [], rhs') }++simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs)+  = do  {       -- Deal with the pattern-bound variables+                -- Mark the ones that are in ! positions in the+                -- data constructor as certainly-evaluated.+                -- NB: simplLamBinders preserves this eval info+        ; let vs_with_evals = add_evals (dataConRepStrictness con)+        ; (env', vs') <- simplLamBndrs env vs_with_evals++                -- Bind the case-binder to (con args)+        ; let inst_tys' = tyConAppArgs (idType case_bndr')+              con_app :: OutExpr+              con_app   = mkConApp2 con inst_tys' vs'++        ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app+        ; rhs' <- simplExprC env'' rhs cont'+        ; return (DataAlt con, vs', rhs') }+  where+        -- add_evals records the evaluated-ness of the bound variables of+        -- a case pattern.  This is *important*.  Consider+        --      data T = T !Int !Int+        --+        --      case x of { T a b -> T (a+1) b }+        --+        -- We really must record that b is already evaluated so that we don't+        -- go and re-evaluate it when constructing the result.+        -- See Note [Data-con worker strictness] in MkId.hs+    add_evals the_strs+        = go vs the_strs+        where+          go [] [] = []+          go (v:vs') strs | isTyVar v = v : go vs' strs+          go (v:vs') (str:strs) = zap str v : go vs' strs+          go _ _ = pprPanic "cat_evals"+                    (ppr con $$+                     ppr vs  $$+                     ppr_with_length the_strs $$+                     ppr_with_length (dataConRepArgTys con) $$+                     ppr_with_length (dataConRepStrictness con))+            where+              ppr_with_length list+                = ppr list <+> parens (text "length =" <+> ppr (length list))+                                    -- NB: If this panic triggers, note that+                                    -- NoStrictnessMark doesn't print!++          zap str v = setCaseBndrEvald str $ -- Add eval'dness info+                      zapIdOccInfo v         -- And kill occ info;+                                             -- see Note [Case alternative occ info]++addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv+addAltUnfoldings env scrut case_bndr con_app+  = do { dflags <- getDynFlags+       ; let con_app_unf = mkSimpleUnfolding dflags con_app+             env1 = addBinderUnfolding env case_bndr con_app_unf++             -- See Note [Add unfolding for scrutinee]+             env2 = case scrut of+                      Just (Var v)           -> addBinderUnfolding env1 v con_app_unf+                      Just (Cast (Var v) co) -> addBinderUnfolding env1 v $+                                                mkSimpleUnfolding dflags (Cast con_app (mkSymCo co))+                      _                      -> env1++       ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app])+       ; return env2 }++addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv+addBinderUnfolding env bndr unf+  | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf+  = WARN( not (eqType (idType bndr) (exprType tmpl)),+          ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl) )+    modifyInScope env (bndr `setIdUnfolding` unf)++  | otherwise+  = modifyInScope env (bndr `setIdUnfolding` unf)++zapBndrOccInfo :: Bool -> Id -> Id+-- Consider  case e of b { (a,b) -> ... }+-- Then if we bind b to (a,b) in "...", and b is not dead,+-- then we must zap the deadness info on a,b+zapBndrOccInfo keep_occ_info pat_id+  | keep_occ_info = pat_id+  | otherwise     = zapIdOccInfo pat_id++{- Note [Case binder evaluated-ness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We pin on a (OtherCon []) unfolding to the case-binder of a Case,+even though it'll be over-ridden in every case alternative with a more+informative unfolding.  Why?  Because suppose a later, less clever, pass+simply replaces all occurrences of the case binder with the binder itself;+then Lint may complain about the let/app invariant.  Example+    case e of b { DEFAULT -> let v = reallyUnsafePtrEq# b y in ....+                ; K       -> blah }++The let/app invariant requires that y is evaluated in the call to+reallyUnsafePtrEq#, which it is.  But we still want that to be true if we+propagate binders to occurrences.++This showed up in Trac #13027.++Note [Add unfolding for scrutinee]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general it's unlikely that a variable scrutinee will appear+in the case alternatives   case x of { ...x unlikely to appear... }+because the binder-swap in OccAnal has got rid of all such occcurrences+See Note [Binder swap] in OccAnal.++BUT it is still VERY IMPORTANT to add a suitable unfolding for a+variable scrutinee, in simplAlt.  Here's why+   case x of y+     (a,b) -> case b of c+                I# v -> ...(f y)...+There is no occurrence of 'b' in the (...(f y)...).  But y gets+the unfolding (a,b), and *that* mentions b.  If f has a RULE+    RULE f (p, I# q) = ...+we want that rule to match, so we must extend the in-scope env with a+suitable unfolding for 'y'.  It's *essential* for rule matching; but+it's also good for case-elimintation -- suppose that 'f' was inlined+and did multi-level case analysis, then we'd solve it in one+simplifier sweep instead of two.++Exactly the same issue arises in SpecConstr;+see Note [Add scrutinee to ValueEnv too] in SpecConstr++HOWEVER, given+  case x of y { Just a -> r1; Nothing -> r2 }+we do not want to add the unfolding x -> y to 'x', which might seem cool,+since 'y' itself has different unfoldings in r1 and r2.  Reason: if we+did that, we'd have to zap y's deadness info and that is a very useful+piece of information.++So instead we add the unfolding x -> Just a, and x -> Nothing in the+respective RHSs.+++************************************************************************+*                                                                      *+\subsection{Known constructor}+*                                                                      *+************************************************************************++We are a bit careful with occurrence info.  Here's an example++        (\x* -> case x of (a*, b) -> f a) (h v, e)++where the * means "occurs once".  This effectively becomes+        case (h v, e) of (a*, b) -> f a)+and then+        let a* = h v; b = e in f a+and then+        f (h v)++All this should happen in one sweep.+-}++knownCon :: SimplEnv+         -> OutExpr                             -- The scrutinee+         -> DataCon -> [OutType] -> [OutExpr]   -- The scrutinee (in pieces)+         -> InId -> [InBndr] -> InExpr          -- The alternative+         -> SimplCont+         -> SimplM (SimplEnv, OutExpr)++knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont+  = do  { env'  <- bind_args env bs dc_args+        ; env'' <- bind_case_bndr env'+        ; simplExprF env'' rhs cont }+  where+    zap_occ = zapBndrOccInfo (isDeadBinder bndr)    -- bndr is an InId++                  -- Ugh!+    bind_args env' [] _  = return env'++    bind_args env' (b:bs') (Type ty : args)+      = ASSERT( isTyVar b )+        bind_args (extendTvSubst env' b ty) bs' args++    bind_args env' (b:bs') (Coercion co : args)+      = ASSERT( isCoVar b )+        bind_args (extendCvSubst env' b co) bs' args++    bind_args env' (b:bs') (arg : args)+      = ASSERT( isId b )+        do { let b' = zap_occ b+             -- Note that the binder might be "dead", because it doesn't+             -- occur in the RHS; and simplNonRecX may therefore discard+             -- it via postInlineUnconditionally.+             -- Nevertheless we must keep it if the case-binder is alive,+             -- because it may be used in the con_app.  See Note [knownCon occ info]+           ; env'' <- simplNonRecX env' b' arg  -- arg satisfies let/app invariant+           ; bind_args env'' bs' args }++    bind_args _ _ _ =+      pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$+                             text "scrut:" <+> ppr scrut++       -- It's useful to bind bndr to scrut, rather than to a fresh+       -- binding      x = Con arg1 .. argn+       -- because very often the scrut is a variable, so we avoid+       -- creating, and then subsequently eliminating, a let-binding+       -- BUT, if scrut is a not a variable, we must be careful+       -- about duplicating the arg redexes; in that case, make+       -- a new con-app from the args+    bind_case_bndr env+      | isDeadBinder bndr   = return env+      | exprIsTrivial scrut = return (extendIdSubst env bndr (DoneEx scrut))+      | otherwise           = do { dc_args <- mapM (simplVar env) bs+                                         -- dc_ty_args are aready OutTypes,+                                         -- but bs are InBndrs+                                 ; let con_app = Var (dataConWorkId dc)+                                                 `mkTyApps` dc_ty_args+                                                 `mkApps`   dc_args+                                 ; simplNonRecX env bndr con_app }++-------------------+missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExpr)+                -- This isn't strictly an error, although it is unusual.+                -- It's possible that the simplifier might "see" that+                -- an inner case has no accessible alternatives before+                -- it "sees" that the entire branch of an outer case is+                -- inaccessible.  So we simply put an error case here instead.+missingAlt env case_bndr _ cont+  = WARN( True, text "missingAlt" <+> ppr case_bndr )+    -- See Note [Avoiding space leaks in OutType]+    let cont_ty = contResultType cont+    in seqType cont_ty `seq` return (env, mkImpossibleExpr cont_ty)++{-+************************************************************************+*                                                                      *+\subsection{Duplicating continuations}+*                                                                      *+************************************************************************+-}++prepareCaseCont :: SimplEnv+                -> [InAlt] -> SimplCont+                -> SimplM (SimplEnv,+                           SimplCont,   -- Dupable part+                           SimplCont)   -- Non-dupable part+-- We are considering+--     K[case _ of { p1 -> r1; ...; pn -> rn }]+-- where K is some enclosing continuation for the case+-- Goal: split K into two pieces Kdup,Knodup so that+--       a) Kdup can be duplicated+--       b) Knodup[Kdup[e]] = K[e]+-- The idea is that we'll transform thus:+--          Knodup[ (case _ of { p1 -> Kdup[r1]; ...; pn -> Kdup[rn] }+--+-- We may also return some extra value bindings in SimplEnv (that scope over+-- the entire continuation) as well as some join points (thus must *not* float+-- past the continuation!).+-- Hence, the full story is this:+--     K[case _ of { p1 -> r1; ...; pn -> rn }] ==>+--     F_v[Knodup[F_j[ (case _ of { p1 -> Kdup[r1]; ...; pn -> Kdup[rn] }) ]]]+-- Here F_v represents some values that got floated out and F_j represents some+-- join points that got floated out.+--+-- When case-of-case is off, just make the entire continuation non-dupable++prepareCaseCont env alts cont+  | not (sm_case_case (getMode env))+  = return (env, mkBoringStop (contHoleType cont), cont)+  | not (altsWouldDup alts)+  = return (env, cont, mkBoringStop (contResultType cont))+  | otherwise+  = mkDupableCont env cont++prepareLetCont :: SimplEnv+               -> [InBndr] -> SimplCont+               -> SimplM (SimplEnv,+                          SimplCont,   -- Dupable part+                          SimplCont)   -- Non-dupable part++-- Similar to prepareCaseCont, only for+--     K[let { j1 = r1; ...; jn -> rn } in _]+-- If the js are join points, this will turn into+--     Knodup[join { j1 = Kdup[r1]; ...; jn = Kdup[rn] } in Kdup[_]].+--+-- When case-of-case is off and it's a join binding, just make the entire+-- continuation non-dupable. This is necessary because otherwise+--     case (join j = ... in case e of { A -> jump j 1; ... }) of { B -> ... }+-- becomes+--     join j = case ... of { B -> ... } in+--     case (case e of { A -> jump j 1; ... }) of { B -> ... },+-- and the reference to j is invalid.++prepareLetCont env bndrs cont+  | not (isJoinId (head bndrs))+  = return (env, cont, mkBoringStop (contResultType cont))+  | not (sm_case_case (getMode env))+  = return (env, mkBoringStop (contHoleType cont), cont)+  | otherwise+  = mkDupableCont env cont++-- Predict the result type of the dupable cont returned by prepareLetCont (= the+-- hole type of the non-dupable part). Ugly, but sadly necessary so that we can+-- know what the new type of a recursive join point will be before we start+-- simplifying it.+resultTypeOfDupableCont :: SimplifierMode+                        -> [InBndr]+                        -> SimplCont+                        -> OutType   -- INVARIANT: Result type of dupable cont+                                     -- returned by prepareLetCont+-- IMPORTANT: This must be kept in sync with mkDupableCont!+resultTypeOfDupableCont mode bndrs cont+  | not (any isJoinId bndrs)   = contResultType cont+  | not (sm_case_case mode)    = contHoleType   cont+  | otherwise                  = go cont+  where+    go cont | contIsDupable cont = contResultType cont+    go (Stop {}) = panic "typeOfDupableCont" -- Handled by previous eqn+    go (CastIt _  cont)     = go cont+    go cont@(TickIt {})     = contHoleType cont+    go cont@(StrictBind {}) = contHoleType cont+    go (StrictArg _ _ cont) = go cont+    go cont@(ApplyToTy  {}) = go (sc_cont cont)+    go cont@(ApplyToVal {}) = go (sc_cont cont)+    go (Select { sc_alts = alts, sc_cont = cont })+      | not (sm_case_case mode) = contHoleType cont+      | not (altsWouldDup alts) = contResultType cont+      | otherwise               = go cont++altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative+altsWouldDup []  = False        -- See Note [Bottom alternatives]+altsWouldDup [_] = False+altsWouldDup (alt:alts)+  | is_bot_alt alt = altsWouldDup alts+  | otherwise      = not (all is_bot_alt alts)+  where+    is_bot_alt (_,_,rhs) = exprIsBottom rhs++{-+Note [Bottom alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~+When we have+     case (case x of { A -> error .. ; B -> e; C -> error ..)+       of alts+then we can just duplicate those alts because the A and C cases+will disappear immediately.  This is more direct than creating+join points and inlining them away.  See Trac #4930.+-}++mkDupableCont :: SimplEnv -> SimplCont+              -> SimplM (SimplEnv, SimplCont, SimplCont)++mkDupableCont env cont+  | contIsDupable cont+  = return (env, cont, mkBoringStop (contResultType cont))++mkDupableCont _   (Stop {}) = panic "mkDupableCont"     -- Handled by previous eqn++mkDupableCont env (CastIt ty cont)+  = do  { (env', dup, nodup) <- mkDupableCont env cont+        ; return (env', CastIt ty dup, nodup) }++-- Duplicating ticks for now, not sure if this is good or not+mkDupableCont env cont@(TickIt{})+  = return (env, mkBoringStop (contHoleType cont), cont)++mkDupableCont env cont@(StrictBind {})+  =  return (env, mkBoringStop (contHoleType cont), cont)+        -- See Note [Duplicating StrictBind]++mkDupableCont env (StrictArg info cci cont)+        -- See Note [Duplicating StrictArg]+  = do { (env', dup, nodup) <- mkDupableCont env cont+       ; (env'', args')     <- mapAccumLM makeTrivialArg env' (ai_args info)+       ; return (env'', StrictArg (info { ai_args = args' }) cci dup, nodup) }++mkDupableCont env cont@(ApplyToTy { sc_cont = tail })+  = do  { (env', dup_cont, nodup_cont) <- mkDupableCont env tail+        ; return (env', cont { sc_cont = dup_cont }, nodup_cont ) }++mkDupableCont env (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se, sc_cont = cont })+  =     -- e.g.         [...hole...] (...arg...)+        --      ==>+        --              let a = ...arg...+        --              in [...hole...] a+    do  { (env', dup_cont, nodup_cont) <- mkDupableCont env cont+        ; (_, se', arg') <- simplArg env' dup se arg+        ; (env'', arg'') <- makeTrivial NotTopLevel env' (fsLit "karg") arg'+        ; let app_cont = ApplyToVal { sc_arg = arg'', sc_env = se'+                                    , sc_dup = OkToDup, sc_cont = dup_cont }+        ; return (env'', app_cont, nodup_cont) }++mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts+                          , sc_env = se, sc_cont = cont })+  =     -- e.g.         (case [...hole...] of { pi -> ei })+        --      ===>+        --              let ji = \xij -> ei+        --              in case [...hole...] of { pi -> ji xij }+    do  { tick (CaseOfCase case_bndr)+        ; (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont+                -- NB: We call prepareCaseCont here.  If there is only one+                -- alternative, then dup_cont may be big, but that's ok+                -- because we push it into the single alternative, and then+                -- use mkDupableAlt to turn that simplified alternative into+                -- a join point if it's too big to duplicate.+                -- And this is important: see Note [Fusing case continuations]++        ; let alt_env = se `setInScopeAndZapFloats` env'++        ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr+        ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' dup_cont) alts+        -- Safe to say that there are no handled-cons for the DEFAULT case+                -- NB: simplBinder does not zap deadness occ-info, so+                -- a dead case_bndr' will still advertise its deadness+                -- This is really important because in+                --      case e of b { (# p,q #) -> ... }+                -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),+                -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.+                -- In the new alts we build, we have the new case binder, so it must retain+                -- its deadness.+        -- NB: we don't use alt_env further; it has the substEnv for+        --     the alternatives, and we don't want that++        ; (env'', alts'') <- mkDupableAlts env' case_bndr' alts'+        ; return (env'',  -- Note [Duplicated env]+                  Select { sc_dup = OkToDup+                         , sc_bndr = case_bndr', sc_alts = alts''+                         , sc_env = zapSubstEnv env''+                         , sc_cont = mkBoringStop (contHoleType nodup_cont) },+                  nodup_cont) }+++mkDupableAlts :: SimplEnv -> OutId -> [InAlt]+              -> SimplM (SimplEnv, [InAlt])+-- Absorbs the continuation into the new alternatives++mkDupableAlts env case_bndr' the_alts+  = go env the_alts+  where+    go env0 [] = return (env0, [])+    go env0 (alt:alts)+        = do { (env1, alt') <- mkDupableAlt env0 case_bndr' alt+             ; (env2, alts') <- go env1 alts+             ; return (env2, alt' : alts' ) }++mkDupableAlt :: SimplEnv -> OutId -> (AltCon, [CoreBndr], CoreExpr)+              -> SimplM (SimplEnv, (AltCon, [CoreBndr], CoreExpr))+mkDupableAlt env case_bndr (con, bndrs', rhs') = do+  dflags <- getDynFlags+  if exprIsDupable dflags rhs'  -- Note [Small alternative rhs]+   then return (env, (con, bndrs', rhs'))+   else+    do  { let rhs_ty'  = exprType rhs'+              scrut_ty = idType case_bndr+              case_bndr_w_unf+                = case con of+                      DEFAULT    -> case_bndr+                      DataAlt dc -> setIdUnfolding case_bndr unf+                          where+                                 -- See Note [Case binders and join points]+                             unf = mkInlineUnfolding rhs+                             rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs'++                      LitAlt {} -> WARN( True, text "mkDupableAlt"+                                                <+> ppr case_bndr <+> ppr con )+                                   case_bndr+                           -- The case binder is alive but trivial, so why has+                           -- it not been substituted away?++              final_bndrs'+                | isDeadBinder case_bndr = filter abstract_over bndrs'+                | otherwise              = bndrs' ++ [case_bndr_w_unf]++              abstract_over bndr+                  | isTyVar bndr = True -- Abstract over all type variables just in case+                  | otherwise    = not (isDeadBinder bndr)+                        -- The deadness info on the new Ids is preserved by simplBinders+              final_args    -- Note [Join point abstraction]+                = varsToCoreExprs final_bndrs'++        ; join_bndr <- newId (fsLit "$j") (mkLamTypes final_bndrs' rhs_ty')+                -- Note [Funky mkLamTypes]++        ; let   -- We make the lambdas into one-shot-lambdas.  The+                -- join point is sure to be applied at most once, and doing so+                -- prevents the body of the join point being floated out by+                -- the full laziness pass+                really_final_bndrs     = map one_shot final_bndrs'+                one_shot v | isId v    = setOneShotLambda v+                           | otherwise = v+                join_rhs   = mkLams really_final_bndrs rhs'+                arity      = length (filter (not . isTyVar) final_bndrs')+                join_arity = length final_bndrs'+                final_join_bndr = (join_bndr `setIdArity` arity)+                                    `asJoinId` join_arity+                join_call  = mkApps (Var final_join_bndr) final_args+                final_join_bind = NonRec final_join_bndr join_rhs++        ; env' <- addPolyBind NotTopLevel env final_join_bind+        ; return (env', (con, bndrs', join_call)) }+                -- See Note [Duplicated env]++{-+Note [Fusing case continuations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's important to fuse two successive case continuations when the+first has one alternative.  That's why we call prepareCaseCont here.+Consider this, which arises from thunk splitting (see Note [Thunk+splitting] in WorkWrap):++      let+        x* = case (case v of {pn -> rn}) of+               I# a -> I# a+      in body++The simplifier will find+    (Var v) with continuation+            Select (pn -> rn) (+            Select [I# a -> I# a] (+            StrictBind body Stop++So we'll call mkDupableCont on+   Select [I# a -> I# a] (StrictBind body Stop)+There is just one alternative in the first Select, so we want to+simplify the rhs (I# a) with continuation (StricgtBind body Stop)+Supposing that body is big, we end up with+          let $j a = <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 Trac #4957 a fuller example.++Note [Case binders and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this+   case (case .. ) of c {+     I# c# -> ....c....++If we make a join point with c but not c# we get+  $j = \c -> ....c....++But if later inlining scrutinises the c, thus++  $j = \c -> ... case c of { I# y -> ... } ...++we won't see that 'c' has already been scrutinised.  This actually+happens in the 'tabulate' function in wave4main, and makes a significant+difference to allocation.++An alternative plan is this:++   $j = \c# -> let c = I# c# in ...c....++but that is bad if 'c' is *not* later scrutinised.++So instead we do both: we pass 'c' and 'c#' , and record in c's inlining+(a stable unfolding) that it's really I# c#, thus++   $j = \c# -> \c[=I# c#] -> ...c....++Absence analysis may later discard 'c'.++NB: take great care when doing strictness analysis;+    see Note [Lambda-bound unfoldings] in DmdAnal.++Also note that we can still end up passing stuff that isn't used.  Before+strictness analysis we have+   let $j x y c{=(x,y)} = (h c, ...)+   in ...+After strictness analysis we see that h is strict, we end up with+   let $j x y c{=(x,y)} = ($wh x y, ...)+and c is unused.++Note [Duplicated env]+~~~~~~~~~~~~~~~~~~~~~+Some of the alternatives are simplified, but have not been turned into a join point+So they *must* have an zapped subst-env.  So we can't use completeNonRecX to+bind the join point, because it might to do PostInlineUnconditionally, and+we'd lose that when zapping the subst-env.  We could have a per-alt subst-env,+but zapping it (as we do in mkDupableCont, the Select case) is safe, and+at worst delays the join-point inlining.++Note [Small alternative rhs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is worth checking for a small RHS because otherwise we+get extra let bindings that may cause an extra iteration of the simplifier to+inline back in place.  Quite often the rhs is just a variable or constructor.+The Ord instance of Maybe in PrelMaybe.hs, for example, took several extra+iterations because the version with the let bindings looked big, and so wasn't+inlined, but after the join points had been inlined it looked smaller, and so+was inlined.++NB: we have to check the size of rhs', not rhs.+Duplicating a small InAlt might invalidate occurrence information+However, if it *is* dupable, we return the *un* simplified alternative,+because otherwise we'd need to pair it up with an empty subst-env....+but we only have one env shared between all the alts.+(Remember we must zap the subst-env before re-simplifying something).+Rather than do this we simply agree to re-simplify the original (small) thing later.++Note [Funky mkLamTypes]+~~~~~~~~~~~~~~~~~~~~~~+Notice the funky mkLamTypes.  If the constructor has existentials+it's possible that the join point will be abstracted over+type variables as well as term variables.+ Example:  Suppose we have+        data T = forall t.  C [t]+ Then faced with+        case (case e of ...) of+            C t xs::[t] -> rhs+ We get the join point+        let j :: forall t. [t] -> ...+            j = /\t \xs::[t] -> rhs+        in+        case (case e of ...) of+            C t xs::[t] -> j t xs++Note [Join point abstraction]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~++NB: This note is now historical. Now that "join point" is not a fuzzy concept+but a formal syntactic construct (as distinguished by the JoinId constructor of+IdDetails), each of these concerns is handled separately, with no need for a+vestigial extra argument.++Join points always have at least one value argument,+for several reasons++* If we try to lift a primitive-typed something out+  for let-binding-purposes, we will *caseify* it (!),+  with potentially-disastrous strictness results.  So+  instead we turn it into a function: \v -> e+  where v::Void#.  The value passed to this function is void,+  which generates (almost) no code.++* CPR.  We used to say "&& isUnliftedType rhs_ty'" here, but now+  we make the join point into a function whenever used_bndrs'+  is empty.  This makes the join-point more CPR friendly.+  Consider:       let j = if .. then I# 3 else I# 4+                  in case .. of { A -> j; B -> j; C -> ... }++  Now CPR doesn't w/w j because it's a thunk, so+  that means that the enclosing function can't w/w either,+  which is a lose.  Here's the example that happened in practice:+          kgmod :: Int -> Int -> Int+          kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0+                      then 78+                      else 5++* Let-no-escape.  We want a join point to turn into a let-no-escape+  so that it is implemented as a jump, and one of the conditions+  for LNE is that it's not updatable.  In CoreToStg, see+  Note [What is a non-escaping let]++* Floating.  Since a join point will be entered once, no sharing is+  gained by floating out, but something might be lost by doing+  so because it might be allocated.++I have seen a case alternative like this:+        True -> \v -> ...+It's a bit silly to add the realWorld dummy arg in this case, making+        $j = \s v -> ...+           True -> $j s+(the \v alone is enough to make CPR happy) but I think it's rare++There's a slight infelicity here: we pass the overall+case_bndr to all the join points if it's used in *any* RHS,+because we don't know its usage in each RHS separately+++Note [Duplicating StrictArg]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The original plan had (where E is a big argument)+e.g.    f E [..hole..]+        ==>     let $j = \a -> f E a+                in $j [..hole..]++But this is terrible! Here's an example:+        && E (case x of { T -> F; F -> T })+Now, && is strict so we end up simplifying the case with++an ArgOf continuation.  If we let-bind it, we get+        let $j = \v -> && E v+        in simplExpr (case x of { T -> F; F -> T })+                     (ArgOf (\r -> $j r)+And after simplifying more we get+        let $j = \v -> && E v+        in case x of { T -> $j F; F -> $j T }+Which is a Very Bad Thing++What we do now is this+        f E [..hole..]+        ==>     let a = E+                in f a [..hole..]+Now if the thing in the hole is a case expression (which is when+we'll call mkDupableCont), we'll push the function call into the+branches, which is what we want.  Now RULES for f may fire, and+call-pattern specialisation.  Here's an example from Trac #3116+     go (n+1) (case l of+                 1  -> bs'+                 _  -> Chunk p fpc (o+1) (l-1) bs')+If we can push the call for 'go' inside the case, we get+call-pattern specialisation for 'go', which is *crucial* for+this program.++Here is the (&&) example:+        && E (case x of { T -> F; F -> T })+  ==>   let a = E in+        case x of { T -> && a F; F -> && a T }+Much better!++Notice that+  * Arguments to f *after* the strict one are handled by+    the ApplyToVal case of mkDupableCont.  Eg+        f [..hole..] E++  * We can only do the let-binding of E because the function+    part of a StrictArg continuation is an explicit syntax+    tree.  In earlier versions we represented it as a function+    (CoreExpr -> CoreEpxr) which we couldn't take apart.++Do *not* duplicate StrictBind and StritArg continuations.  We gain+nothing by propagating them into the expressions, and we do lose a+lot.++The desire not to duplicate is the entire reason that+mkDupableCont returns a pair of continuations.++Note [Duplicating StrictBind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Unlike StrictArg, there doesn't seem anything to gain from+duplicating a StrictBind continuation, so we don't.+++************************************************************************+*                                                                      *+                    Unfoldings+*                                                                      *+************************************************************************+-}++simplLetUnfolding :: SimplEnv-> TopLevelFlag+                  -> Maybe SimplCont+                  -> InId+                  -> OutExpr+                  -> Unfolding -> SimplM Unfolding+simplLetUnfolding env top_lvl cont_mb id new_rhs unf+  | isStableUnfolding unf+  = simplUnfolding env top_lvl cont_mb id unf+  | otherwise+  = is_bottoming `seq`  -- See Note [Force bottoming field]+    do { dflags <- getDynFlags+       ; return (mkUnfolding dflags InlineRhs is_top_lvl is_bottoming new_rhs) }+            -- We make an  unfolding *even for loop-breakers*.+            -- Reason: (a) It might be useful to know that they are WHNF+            --         (b) In TidyPgm we currently assume that, if we want to+            --             expose the unfolding then indeed we *have* an unfolding+            --             to expose.  (We could instead use the RHS, but currently+            --             we don't.)  The simple thing is always to have one.+  where+    is_top_lvl   = isTopLevel top_lvl+    is_bottoming = isBottomingId id++simplUnfolding :: SimplEnv -> TopLevelFlag+               -> Maybe SimplCont  -- Just k => a join point with continuation k+               -> InId+               -> Unfolding -> SimplM Unfolding+-- Note [Setting the new unfolding]+simplUnfolding env top_lvl mb_cont id unf+  = case unf of+      NoUnfolding -> return unf+      BootUnfolding -> return unf+      OtherCon {} -> return unf++      DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }+        -> do { (env', bndrs') <- simplBinders rule_env bndrs+              ; args' <- mapM (simplExpr env') args+              ; return (mkDFunUnfolding bndrs' con args') }++      CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide }+        | isStableSource src+        -> do { expr' <- case mb_cont of+                           Just cont -> simplJoinRhs rule_env id expr cont+                           Nothing   -> simplExpr rule_env expr+              ; case guide of+                  UnfWhen { ug_arity = arity, ug_unsat_ok = sat_ok }  -- Happens for INLINE things+                     -> let guide' = UnfWhen { ug_arity = arity, ug_unsat_ok = sat_ok+                                             , ug_boring_ok = inlineBoringOk expr' }+                        -- Refresh the boring-ok flag, in case expr'+                        -- has got small. This happens, notably in the inlinings+                        -- for dfuns for single-method classes; see+                        -- Note [Single-method classes] in TcInstDcls.+                        -- A test case is Trac #4138+                        in return (mkCoreUnfolding src is_top_lvl expr' guide')+                            -- See Note [Top-level flag on inline rules] in CoreUnfold++                  _other              -- Happens for INLINABLE things+                     -> is_bottoming `seq` -- See Note [Force bottoming field]+                        do { dflags <- getDynFlags+                           ; return (mkUnfolding dflags src is_top_lvl is_bottoming expr') } }+                -- If the guidance is UnfIfGoodArgs, this is an INLINABLE+                -- unfolding, and we need to make sure the guidance is kept up+                -- to date with respect to any changes in the unfolding.++        | otherwise -> return noUnfolding   -- Discard unstable unfoldings+  where+    is_top_lvl   = isTopLevel top_lvl+    is_bottoming = isBottomingId id+    act          = idInlineActivation id+    rule_env     = updMode (updModeForStableUnfoldings act) env+         -- See Note [Simplifying inside stable unfoldings] in SimplUtils++{-+Note [Force bottoming field]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to force bottoming, or the new unfolding holds+on to the old unfolding (which is part of the id).++Note [Setting the new unfolding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* If there's an INLINE pragma, we simplify the RHS gently.  Maybe we+  should do nothing at all, but simplifying gently might get rid of+  more crap.++* If not, we make an unfolding from the new RHS.  But *only* for+  non-loop-breakers. Making loop breakers not have an unfolding at all+  means that we can avoid tests in exprIsConApp, for example.  This is+  important: if exprIsConApp says 'yes' for a recursive thing, then we+  can get into an infinite loop++If there's an stable unfolding on a loop breaker (which happens for+INLINABLE), we hang on to the inlining.  It's pretty dodgy, but the+user did say 'INLINE'.  May need to revisit this choice.++************************************************************************+*                                                                      *+                    Rules+*                                                                      *+************************************************************************++Note [Rules in a letrec]+~~~~~~~~~~~~~~~~~~~~~~~~+After creating fresh binders for the binders of a letrec, we+substitute the RULES and add them back onto the binders; this is done+*before* processing any of the RHSs.  This is important.  Manuel found+cases where he really, really wanted a RULE for a recursive function+to apply in that function's own right-hand side.++See Note [Forming Rec groups] in OccurAnal+-}++addBndrRules :: SimplEnv -> InBndr -> OutBndr -> SimplM (SimplEnv, OutBndr)+-- Rules are added back into the bin+addBndrRules env in_id out_id+  | null old_rules+  = return (env, out_id)+  | otherwise+  = do { new_rules <- simplRules env (Just (idName out_id)) old_rules+       ; let final_id  = out_id `setIdSpecialisation` mkRuleInfo new_rules+       ; return (modifyInScope env final_id, final_id) }+  where+    old_rules = ruleInfoRules (idSpecialisation in_id)++simplRules :: SimplEnv -> Maybe Name -> [CoreRule] -> SimplM [CoreRule]+simplRules env mb_new_nm rules+  = mapM simpl_rule rules+  where+    simpl_rule rule@(BuiltinRule {})+      = return rule++    simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args+                          , ru_fn = fn_name, ru_rhs = rhs })+      = do { (env', bndrs') <- simplBinders env bndrs+           ; let rhs_ty = substTy env' (exprType rhs)+                 rule_cont = mkBoringStop rhs_ty+                 rule_env  = updMode updModeForRules env'+           ; args' <- mapM (simplExpr rule_env) args+           ; rhs'  <- simplExprC rule_env rhs rule_cont+           ; return (rule { ru_bndrs = bndrs'+                          , ru_fn    = mb_new_nm `orElse` fn_name+                          , ru_args  = args'+                          , ru_rhs   = rhs' }) }
+ simplStg/RepType.hs view
@@ -0,0 +1,365 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}++module RepType+  (+    -- * Code generator views onto Types+    UnaryType, NvUnaryType, isNvUnaryType,+    unwrapType,++    -- * Predicates on types+    isVoidTy,++    -- * Type representation for the code generator+    typePrimRep, typePrimRep1,+    runtimeRepPrimRep, typePrimRepArgs,+    PrimRep(..), primRepToType,+    countFunRepArgs, countConRepArgs, tyConPrimRep, tyConPrimRep1,++    -- * Unboxed sum representation type+    ubxSumRepType, layoutUbxSum, typeSlotTy, SlotTy (..),+    slotPrimRep, primRepSlot+  ) where++#include "HsVersions.h"++import BasicTypes (Arity, RepArity)+import DataCon+import Outputable+import PrelNames+import Coercion+import TyCon+import TyCoRep+import Type+import Util+import TysPrim+import {-# SOURCE #-} TysWiredIn ( anyTypeOfKind )++import Data.List (foldl', sort)+import qualified Data.IntSet as IS++{- **********************************************************************+*                                                                       *+                Representation types+*                                                                       *+********************************************************************** -}++type NvUnaryType = Type+type UnaryType   = Type+     -- Both are always a value type; i.e. its kind is TYPE rr+     -- for some rr; moreover the rr is never a variable.+     --+     --   NvUnaryType : never an unboxed tuple or sum, or void+     --+     --   UnaryType   : never an unboxed tuple or sum;+     --                 can be Void# or (# #)++isNvUnaryType :: Type -> Bool+isNvUnaryType ty+  | [_] <- typePrimRep ty+  = True+  | otherwise+  = False++-- INVARIANT: the result list is never empty.+typePrimRepArgs :: Type -> [PrimRep]+typePrimRepArgs ty+  | [] <- reps+  = [VoidRep]+  | otherwise+  = reps+  where+    reps = typePrimRep ty++-- | Gets rid of the stuff that prevents us from understanding the+-- runtime representation of a type. Including:+--   1. Casts+--   2. Newtypes+--   3. Foralls+--   4. Synonyms+-- But not type/data families, because we don't have the envs to hand.+unwrapType :: Type -> Type+unwrapType ty+  | Just (_, unwrapped)+      <- topNormaliseTypeX stepper mappend inner_ty+  = unwrapped+  | otherwise+  = inner_ty+  where+    inner_ty = go ty++    go t | Just t' <- coreView t = go t'+    go (ForAllTy _ t)            = go t+    go (CastTy t _)              = go t+    go t                         = t++     -- cf. Coercion.unwrapNewTypeStepper+    stepper rec_nts tc tys+      | Just (ty', _) <- instNewTyCon_maybe tc tys+      = case checkRecTc rec_nts tc of+          Just rec_nts' -> NS_Step rec_nts' (go ty') ()+          Nothing       -> NS_Abort   -- infinite newtypes+      | otherwise+      = NS_Done++countFunRepArgs :: Arity -> Type -> RepArity+countFunRepArgs 0 _+  = 0+countFunRepArgs n ty+  | FunTy arg res <- unwrapType ty+  = length (typePrimRepArgs arg) + countFunRepArgs (n - 1) res+  | otherwise+  = pprPanic "countFunRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty))++countConRepArgs :: DataCon -> RepArity+countConRepArgs dc = go (dataConRepArity dc) (dataConRepType dc)+  where+    go :: Arity -> Type -> RepArity+    go 0 _+      = 0+    go n ty+      | FunTy arg res <- unwrapType ty+      = length (typePrimRep arg) + go (n - 1) res+      | otherwise+      = pprPanic "countConRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty))++-- | True if the type has zero width.+isVoidTy :: Type -> Bool+isVoidTy = null . typePrimRep+++{- **********************************************************************+*                                                                       *+                Unboxed sums+ See Note [Translating unboxed sums to unboxed tuples] in UnariseStg.hs+*                                                                       *+********************************************************************** -}++type SortedSlotTys = [SlotTy]++-- | Given the arguments of a sum type constructor application,+--   return the unboxed sum rep type.+--+-- E.g.+--+--   (# Int# | Maybe Int | (# Int#, Float# #) #)+--+-- We call `ubxSumRepType [ [IntRep], [LiftedRep], [IntRep, FloatRep] ]`,+-- which returns [WordSlot, PtrSlot, WordSlot, FloatSlot]+--+-- INVARIANT: Result slots are sorted (via Ord SlotTy), except that at the head+-- of the list we have the slot for the tag.+ubxSumRepType :: [[PrimRep]] -> [SlotTy]+ubxSumRepType constrs0+  -- These first two cases never classify an actual unboxed sum, which always+  -- has at least two disjuncts. But it could happen if a user writes, e.g.,+  -- forall (a :: TYPE (SumRep [IntRep])). ...+  -- which could never be instantiated. We still don't want to panic.+  | length constrs0 < 2+  = [WordSlot]++  | otherwise+  = let+      combine_alts :: [SortedSlotTys]  -- slots of constructors+                   -> SortedSlotTys    -- final slots+      combine_alts constrs = foldl' merge [] constrs++      merge :: SortedSlotTys -> SortedSlotTys -> SortedSlotTys+      merge existing_slots []+        = existing_slots+      merge [] needed_slots+        = needed_slots+      merge (es : ess) (s : ss)+        | Just s' <- s `fitsIn` es+        = -- found a slot, use it+          s' : merge ess ss+        | s < es+        = -- we need a new slot and this is the right place for it+          s : merge (es : ess) ss+        | otherwise+        = -- keep searching for a slot+          es : merge ess (s : ss)++      -- Nesting unboxed tuples and sums is OK, so we need to flatten first.+      rep :: [PrimRep] -> SortedSlotTys+      rep ty = sort (map primRepSlot ty)++      sumRep = WordSlot : combine_alts (map rep constrs0)+               -- WordSlot: for the tag of the sum+    in+      sumRep++layoutUbxSum :: SortedSlotTys -- Layout of sum. Does not include tag.+                              -- We assume that they are in increasing order+             -> [SlotTy]      -- Slot types of things we want to map to locations in the+                              -- sum layout+             -> [Int]         -- Where to map 'things' in the sum layout+layoutUbxSum sum_slots0 arg_slots0 =+    go arg_slots0 IS.empty+  where+    go :: [SlotTy] -> IS.IntSet -> [Int]+    go [] _+      = []+    go (arg : args) used+      = let slot_idx = findSlot arg 0 sum_slots0 used+         in slot_idx : go args (IS.insert slot_idx used)++    findSlot :: SlotTy -> Int -> SortedSlotTys -> IS.IntSet -> Int+    findSlot arg slot_idx (slot : slots) useds+      | not (IS.member slot_idx useds)+      , Just slot == arg `fitsIn` slot+      = slot_idx+      | otherwise+      = findSlot arg (slot_idx + 1) slots useds+    findSlot _ _ [] _+      = pprPanic "findSlot" (text "Can't find slot" $$ ppr sum_slots0 $$ ppr arg_slots0)++--------------------------------------------------------------------------------++-- We have 3 kinds of slots:+--+--   - Pointer slot: Only shared between actual pointers to Haskell heap (i.e.+--     boxed objects)+--+--   - Word slots: Shared between IntRep, WordRep, Int64Rep, Word64Rep, AddrRep.+--+--   - Float slots: Shared between floating point types.+--+--   - Void slots: Shared between void types. Not used in sums.+data SlotTy = PtrSlot | WordSlot | Word64Slot | FloatSlot | DoubleSlot+  deriving (Eq, Ord)+    -- Constructor order is important! If slot A could fit into slot B+    -- then slot A must occur first.  E.g.  FloatSlot before DoubleSlot+    --+    -- We are assuming that WordSlot is smaller than or equal to Word64Slot+    -- (would not be true on a 128-bit machine)++instance Outputable SlotTy where+  ppr PtrSlot    = text "PtrSlot"+  ppr Word64Slot = text "Word64Slot"+  ppr WordSlot   = text "WordSlot"+  ppr DoubleSlot = text "DoubleSlot"+  ppr FloatSlot  = text "FloatSlot"++typeSlotTy :: UnaryType -> Maybe SlotTy+typeSlotTy ty+  | isVoidTy ty+  = Nothing+  | otherwise+  = Just (primRepSlot (typePrimRep1 ty))++primRepSlot :: PrimRep -> SlotTy+primRepSlot VoidRep     = pprPanic "primRepSlot" (text "No slot for VoidRep")+primRepSlot LiftedRep   = PtrSlot+primRepSlot UnliftedRep = PtrSlot+primRepSlot IntRep      = WordSlot+primRepSlot WordRep     = WordSlot+primRepSlot Int64Rep    = Word64Slot+primRepSlot Word64Rep   = Word64Slot+primRepSlot AddrRep     = WordSlot+primRepSlot FloatRep    = FloatSlot+primRepSlot DoubleRep   = DoubleSlot+primRepSlot VecRep{}    = pprPanic "primRepSlot" (text "No slot for VecRep")++slotPrimRep :: SlotTy -> PrimRep+slotPrimRep PtrSlot     = LiftedRep   -- choice between lifted & unlifted seems arbitrary+slotPrimRep Word64Slot  = Word64Rep+slotPrimRep WordSlot    = WordRep+slotPrimRep DoubleSlot  = DoubleRep+slotPrimRep FloatSlot   = FloatRep++-- | Returns the bigger type if one fits into the other. (commutative)+fitsIn :: SlotTy -> SlotTy -> Maybe SlotTy+fitsIn ty1 ty2+  | isWordSlot ty1 && isWordSlot ty2+  = Just (max ty1 ty2)+  | isFloatSlot ty1 && isFloatSlot ty2+  = Just (max ty1 ty2)+  | isPtrSlot ty1 && isPtrSlot ty2+  = Just PtrSlot+  | otherwise+  = Nothing+  where+    isPtrSlot PtrSlot = True+    isPtrSlot _       = False++    isWordSlot Word64Slot = True+    isWordSlot WordSlot   = True+    isWordSlot _          = False++    isFloatSlot DoubleSlot = True+    isFloatSlot FloatSlot  = True+    isFloatSlot _          = False+++{- **********************************************************************+*                                                                       *+                   PrimRep+*                                                                       *+********************************************************************** -}++-- | Discovers the primitive representation of a 'Type'. Returns+-- a list of 'PrimRep': it's a list because of the possibility of+-- no runtime representation (void) or multiple (unboxed tuple/sum)+typePrimRep :: HasDebugCallStack => Type -> [PrimRep]+typePrimRep ty = kindPrimRep (text "typePrimRep" <+>+                              parens (ppr ty <+> dcolon <+> ppr (typeKind ty)))+                             (typeKind ty)++-- | Like 'typePrimRep', but assumes that there is precisely one 'PrimRep' output;+-- an empty list of PrimReps becomes a VoidRep+typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimRep+typePrimRep1 ty = case typePrimRep ty of+  []    -> VoidRep+  [rep] -> rep+  _     -> pprPanic "typePrimRep1" (ppr ty $$ ppr (typePrimRep ty))++-- | Find the runtime representation of a 'TyCon'. Defined here to+-- avoid module loops. Returns a list of the register shapes necessary.+tyConPrimRep :: HasDebugCallStack => TyCon -> [PrimRep]+tyConPrimRep tc+  = kindPrimRep (text "kindRep tc" <+> ppr tc $$ ppr res_kind)+                res_kind+  where+    res_kind = tyConResKind tc++-- | Like 'tyConPrimRep', but assumed that there is precisely zero or+-- one 'PrimRep' output+tyConPrimRep1 :: HasDebugCallStack => TyCon -> PrimRep+tyConPrimRep1 tc = case tyConPrimRep tc of+  []    -> VoidRep+  [rep] -> rep+  _     -> pprPanic "tyConPrimRep1" (ppr tc $$ ppr (tyConPrimRep tc))++-- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's+-- of values of types of this kind.+kindPrimRep :: HasDebugCallStack => SDoc -> Kind -> [PrimRep]+kindPrimRep doc ki+  | Just ki' <- coreView ki+  = kindPrimRep doc ki'+kindPrimRep doc (TyConApp typ [runtime_rep])+  = ASSERT( typ `hasKey` tYPETyConKey )+    runtimeRepPrimRep doc runtime_rep+kindPrimRep doc ki+  = pprPanic "kindPrimRep" (ppr ki $$ doc)++  -- TODO (RAE): Remove:+  -- WARN( True, text "kindPrimRep defaulting to LiftedRep on" <+> ppr ki $$ doc )+  -- [LiftedRep]  -- this can happen legitimately for, e.g., Any++-- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that+-- it encodes.+runtimeRepPrimRep :: HasDebugCallStack => SDoc -> Type -> [PrimRep]+runtimeRepPrimRep doc rr_ty+  | Just rr_ty' <- coreView rr_ty+  = runtimeRepPrimRep doc rr_ty'+  | TyConApp rr_dc args <- rr_ty+  , RuntimeRep fun <- tyConRuntimeRepInfo rr_dc+  = fun args+  | otherwise+  = pprPanic "runtimeRepPrimRep" (doc $$ ppr rr_ty)++-- | Convert a PrimRep back to a Type. Used only in the unariser to give types+-- to fresh Ids. Really, only the type's representation matters.+primRepToType :: PrimRep -> Type+primRepToType = anyTypeOfKind . tYPE . primRepToRuntimeRep
+ simplStg/SimplStg.hs view
@@ -0,0 +1,117 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998++\section[SimplStg]{Driver for simplifying @STG@ programs}+-}++{-# LANGUAGE CPP #-}++module SimplStg ( stg2stg ) where++#include "HsVersions.h"++import StgSyn++import CostCentre       ( CollectedCCs )+import SCCfinal         ( stgMassageForProfiling )+import StgLint          ( lintStgTopBindings )+import StgStats         ( showStgStats )+import UnariseStg       ( unarise )+import StgCse           ( stgCse )++import DynFlags+import Module           ( Module )+import ErrUtils+import SrcLoc+import UniqSupply       ( mkSplitUniqSupply, splitUniqSupply )+import Outputable+import Control.Monad++stg2stg :: DynFlags                  -- includes spec of what stg-to-stg passes to do+        -> Module                    -- module name (profiling only)+        -> [StgTopBinding]           -- input...+        -> IO ( [StgTopBinding]      -- output program...+              , CollectedCCs)        -- cost centre information (declared and used)++stg2stg dflags module_name binds+  = do  { showPass dflags "Stg2Stg"+        ; us <- mkSplitUniqSupply 'g'++        ; when (dopt Opt_D_verbose_stg2stg dflags)+               (putLogMsg dflags NoReason SevDump noSrcSpan+                  (defaultDumpStyle dflags) (text "VERBOSE STG-TO-STG:"))++        ; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds++                -- Do the main business!+        ; let (us0, us1) = splitUniqSupply us'+        ; (processed_binds, _, cost_centres)+                <- foldM do_stg_pass (binds', us0, ccs) (getStgToDo dflags)++        ; dumpIfSet_dyn dflags Opt_D_dump_stg "Pre unarise:"+                        (pprStgTopBindings processed_binds)++        ; let un_binds = unarise us1 processed_binds++        ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:"+                        (pprStgTopBindings un_binds)++        ; return (un_binds, cost_centres)+   }++  where+    stg_linter = if gopt Opt_DoStgLinting dflags+                 then lintStgTopBindings+                 else ( \ _whodunnit binds -> binds )++    -------------------------------------------+    do_stg_pass (binds, us, ccs) to_do+      = case to_do of+          D_stg_stats ->+             trace (showStgStats binds)+             end_pass us "StgStats" ccs binds++          StgDoMassageForProfiling ->+             {-# SCC "ProfMassage" #-}+             let+                 (us1, us2) = splitUniqSupply us+                 (collected_CCs, binds3)+                   = stgMassageForProfiling dflags module_name us1 binds+             in+             end_pass us2 "ProfMassage" collected_CCs binds3++          StgCSE ->+             {-# SCC "StgCse" #-}+             let+                 binds' = stgCse binds+             in+             end_pass us "StgCse" ccs binds'++    end_pass us2 what ccs binds2+      = do -- report verbosely, if required+           dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what+              (vcat (map ppr binds2))+           let linted_binds = stg_linter what binds2+           return (linted_binds, us2, ccs)+            -- return: processed binds+            --         UniqueSupply for the next guy to use+            --         cost-centres to be declared/registered (specialised)+            --         add to description of what's happened (reverse order)++-- -----------------------------------------------------------------------------+-- StgToDo:  abstraction of stg-to-stg passes to run.++-- | Optional Stg-to-Stg passes.+data StgToDo+  = StgCSE+  | StgDoMassageForProfiling  -- should be (next to) last+  | D_stg_stats++-- | Which optional Stg-to-Stg passes to run. Depends on flags, ways etc.+getStgToDo :: DynFlags -> [StgToDo]+getStgToDo dflags+  = [ StgCSE                   | gopt Opt_StgCSE dflags] +++    [ StgDoMassageForProfiling | WayProf `elem` ways dflags] +++    [ D_stg_stats              | stg_stats ]+  where+        stg_stats = gopt Opt_StgStats dflags
+ simplStg/StgCse.hs view
@@ -0,0 +1,430 @@+{-# LANGUAGE TypeFamilies #-}++{-|+Note [CSE for Stg]+~~~~~~~~~~~~~~~~~~+This module implements a simple common subexpression elimination pass for STG.+This is useful because there are expressions that we want to common up (because+they are operational equivalent), but that we cannot common up in Core, because+their types differ.+This was original reported as #9291.++There are two types of common code occurrences that we aim for, see+note [Case 1: CSEing allocated closures] and+note [Case 2: CSEing case binders] below.+++Note [Case 1: CSEing allocated closures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The fist kind of CSE opportunity we aim for is generated by this Haskell code:++    bar :: a -> (Either Int a, Either Bool a)+    bar x = (Right x, Right x)++which produces this Core:++    bar :: forall a. a -> (Either Int a, Either Bool a)+    bar @a x = (Right @Int @a x, Right @Bool @a x)++where the two components of the tuple are differnt terms, and cannot be+commoned up (easily). On the STG level we have++    bar [x] = let c1 = Right [x]+                  c2 = Right [x]+              in (c1,c2)++and now it is obvious that we can write++    bar [x] = let c1 = Right [x]+              in (c1,c1)++instead.+++Note [Case 2: CSEing case binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The second kind of CSE opportunity we aim for is more interesting, and+came up in #9291 and #5344: The Haskell code++    foo :: Either Int a -> Either Bool a+    foo (Right x) = Right x+    foo _         = Left False++produces this Core++    foo :: forall a. Either Int a -> Either Bool a+    foo @a e = case e of b { Left n -> …+                           , Right x -> Right @Bool @a x }++where we cannot CSE `Right @Bool @a x` with the case binder `b` as they have+different types. But in STG we have++    foo [e] = case e of b { Left [n] -> …+                          , Right [x] -> Right [x] }++and nothing stops us from transforming that to++    foo [e] = case e of b { Left [n] -> …+                          , Right [x] -> b}++-}+module StgCse (stgCse) where++import DataCon+import Id+import StgSyn+import Outputable+import VarEnv+import CoreSyn (AltCon(..))+import Data.List (mapAccumL)+import Data.Maybe (fromMaybe)+import TrieMap+import NameEnv+import Control.Monad( (>=>) )++--------------+-- The Trie --+--------------++-- A lookup trie for data constructor applications, i.e.+-- keys of type `(DataCon, [StgArg])`, following the patterns in TrieMap.++data StgArgMap a = SAM+    { sam_var :: DVarEnv a+    , sam_lit :: LiteralMap a+    }++instance TrieMap StgArgMap where+    type Key StgArgMap = StgArg+    emptyTM  = SAM { sam_var = emptyTM+                   , sam_lit = emptyTM }+    lookupTM (StgVarArg var) = sam_var >.> lkDFreeVar var+    lookupTM (StgLitArg lit) = sam_lit >.> lookupTM lit+    alterTM  (StgVarArg var) f m = m { sam_var = sam_var m |> xtDFreeVar var f }+    alterTM  (StgLitArg lit) f m = m { sam_lit = sam_lit m |> alterTM lit f }+    foldTM k m = foldTM k (sam_var m) . foldTM k (sam_lit m)+    mapTM f (SAM {sam_var = varm, sam_lit = litm}) =+        SAM { sam_var = mapTM f varm, sam_lit = mapTM f litm }++newtype ConAppMap a = CAM { un_cam :: DNameEnv (ListMap StgArgMap a) }++instance TrieMap ConAppMap where+    type Key ConAppMap = (DataCon, [StgArg])+    emptyTM  = CAM emptyTM+    lookupTM (dataCon, args) = un_cam >.> lkDNamed dataCon >=> lookupTM args+    alterTM  (dataCon, args) f m =+        m { un_cam = un_cam m |> xtDNamed dataCon |>> alterTM args f }+    foldTM k = un_cam >.> foldTM (foldTM k)+    mapTM f  = un_cam >.> mapTM (mapTM f) >.> CAM++-----------------+-- The CSE Env --+-----------------++-- | The CSE environment. See note [CseEnv Example]+data CseEnv = CseEnv+    { ce_conAppMap :: ConAppMap OutId+        -- ^ The main component of the environment is the trie that maps+        --   data constructor applications (with their `OutId` arguments)+        --   to an in-scope name that can be used instead.+        --   This name is always either a let-bound variable or a case binder.+    , ce_subst     :: IdEnv OutId+        -- ^ This substitution is applied to the code as we traverse it.+        --   Entries have one of two reasons:+        --+        --   * The input might have shadowing (see Note [Shadowing]), so we have+        --     to rename some binders as we traverse the tree.+        --   * If we remove `let x = Con z` because  `let y = Con z` is in scope,+        --     we note this here as x ↦ y.+    , ce_bndrMap     :: IdEnv OutId+        --   If we come across a case expression case x as b of … with a trivial+        --   binder, we add b ↦ x to this.+        --   This map is *only* used when looking something up in the ce_conAppMap.+        --   See Note [Trivial case scrutinee]+    , ce_in_scope  :: InScopeSet+        -- ^ The third component is an in-scope set, to rename away any+        --   shadowing binders+    }++{-|+Note [CseEnv Example]+~~~~~~~~~~~~~~~~~~~~~+The following tables shows how the CseEnvironment changes as code is traversed,+as well as the changes to that code.++  InExpr                         OutExpr+     conAppMap                   subst          in_scope+  ───────────────────────────────────────────────────────────+  -- empty                       {}             {}+  case … as a of {Con x y ->     case … as a of {Con x y ->+  -- Con x y ↦ a                 {}             {a,x,y}+  let b = Con x y                (removed)+  -- Con x y ↦ a                 b↦a            {a,x,y,b}+  let c = Bar a                  let c = Bar a+  -- Con x y ↦ a, Bar a ↦ c      b↦a            {a,x,y,b,c}+  let c = some expression        let c' = some expression+  -- Con x y ↦ a, Bar a ↦ c      b↦a, c↦c',     {a,x,y,b,c,c'}+  let d = Bar b                  (removed)+  -- Con x y ↦ a, Bar a ↦ c      b↦a, c↦c', d↦c {a,x,y,b,c,c',d}+  (a, b, c d)                    (a, a, c' c)+-}++initEnv :: InScopeSet -> CseEnv+initEnv in_scope = CseEnv+    { ce_conAppMap = emptyTM+    , ce_subst     = emptyVarEnv+    , ce_bndrMap   = emptyVarEnv+    , ce_in_scope  = in_scope+    }++envLookup :: DataCon -> [OutStgArg] -> CseEnv -> Maybe OutId+envLookup dataCon args env = lookupTM (dataCon, args') (ce_conAppMap env)+  where args' = map go args -- See Note [Trivial case scrutinee]+        go (StgVarArg v  ) = StgVarArg (fromMaybe v $ lookupVarEnv (ce_bndrMap env) v)+        go (StgLitArg lit) = StgLitArg lit++addDataCon :: OutId -> DataCon -> [OutStgArg] -> CseEnv -> CseEnv+-- do not bother with nullary data constructors, they are static anyways+addDataCon _ _ [] env = env+addDataCon bndr dataCon args env = env { ce_conAppMap = new_env }+  where+    new_env = insertTM (dataCon, args) bndr (ce_conAppMap env)++forgetCse :: CseEnv -> CseEnv+forgetCse env = env { ce_conAppMap = emptyTM }+    -- See note [Free variables of an StgClosure]++addSubst :: OutId -> OutId -> CseEnv -> CseEnv+addSubst from to env+    = env { ce_subst = extendVarEnv (ce_subst env) from to }++addTrivCaseBndr :: OutId -> OutId -> CseEnv -> CseEnv+addTrivCaseBndr from to env+    = env { ce_bndrMap = extendVarEnv (ce_bndrMap env) from to }++substArgs :: CseEnv -> [InStgArg] -> [OutStgArg]+substArgs env = map (substArg env)++substArg :: CseEnv -> InStgArg -> OutStgArg+substArg env (StgVarArg from) = StgVarArg (substVar env from)+substArg _   (StgLitArg lit)  = StgLitArg lit++substVars :: CseEnv -> [InId] -> [OutId]+substVars env = map (substVar env)++substVar :: CseEnv -> InId -> OutId+substVar env id = fromMaybe id $ lookupVarEnv (ce_subst env) id++-- Functions to enter binders++-- This is much simpler than the requivalent code in CoreSubst:+--  * We do not substitute type variables, and+--  * There is nothing relevant in IdInfo at this stage+--    that needs substitutions.+-- Therefore, no special treatment for a recursive group is required.++substBndr :: CseEnv -> InId -> (CseEnv, OutId)+substBndr env old_id+  = (new_env, new_id)+  where+    new_id = uniqAway (ce_in_scope env) old_id+    no_change = new_id == old_id+    env' = env { ce_in_scope = ce_in_scope env `extendInScopeSet` new_id }+    new_env | no_change = env' { ce_subst = extendVarEnv (ce_subst env) old_id new_id }+            | otherwise = env'++substBndrs :: CseEnv -> [InVar] -> (CseEnv, [OutVar])+substBndrs env bndrs = mapAccumL substBndr env bndrs++substPairs :: CseEnv -> [(InVar, a)] -> (CseEnv, [(OutVar, a)])+substPairs env bndrs = mapAccumL go env bndrs+  where go env (id, x) = let (env', id') = substBndr env id+                         in (env', (id', x))++-- Main entry point++stgCse :: [InStgTopBinding] -> [OutStgTopBinding]+stgCse binds = snd $ mapAccumL stgCseTopLvl emptyInScopeSet binds++-- Top level bindings.+--+-- We do not CSE these, as top-level closures are allocated statically anyways.+-- Also, they might be exported.+-- But we still have to collect the set of in-scope variables, otherwise+-- uniqAway might shadow a top-level closure.++stgCseTopLvl :: InScopeSet -> InStgTopBinding -> (InScopeSet, OutStgTopBinding)+stgCseTopLvl in_scope t@(StgTopStringLit _ _) = (in_scope, t)+stgCseTopLvl in_scope (StgTopLifted (StgNonRec bndr rhs))+    = (in_scope'+      , StgTopLifted (StgNonRec bndr (stgCseTopLvlRhs in_scope rhs)))+  where in_scope' = in_scope `extendInScopeSet` bndr++stgCseTopLvl in_scope (StgTopLifted (StgRec eqs))+    = ( in_scope'+      , StgTopLifted (StgRec [ (bndr, stgCseTopLvlRhs in_scope' rhs) | (bndr, rhs) <- eqs ]))+  where in_scope' = in_scope `extendInScopeSetList` [ bndr | (bndr, _) <- eqs ]++stgCseTopLvlRhs :: InScopeSet -> InStgRhs -> OutStgRhs+stgCseTopLvlRhs in_scope (StgRhsClosure ccs info occs upd args body)+    = let body' = stgCseExpr (initEnv in_scope) body+      in  StgRhsClosure ccs info occs upd args body'+stgCseTopLvlRhs _ (StgRhsCon ccs dataCon args)+    = StgRhsCon ccs dataCon args++------------------------------+-- The actual AST traversal --+------------------------------++-- Trivial cases+stgCseExpr :: CseEnv -> InStgExpr -> OutStgExpr+stgCseExpr env (StgApp fun args)+    = StgApp fun' args'+  where fun' = substVar env fun+        args' = substArgs env args+stgCseExpr _ (StgLit lit)+    = StgLit lit+stgCseExpr env (StgOpApp op args tys)+    = StgOpApp op args' tys+  where args' = substArgs env args+stgCseExpr _ (StgLam _ _)+    = pprPanic "stgCseExp" (text "StgLam")+stgCseExpr env (StgTick tick body)+    = let body' = stgCseExpr env body+      in StgTick tick body'+stgCseExpr env (StgCase scrut bndr ty alts)+    = StgCase scrut' bndr' ty alts'+  where+    scrut' = stgCseExpr env scrut+    (env1, bndr') = substBndr env bndr+    env2 | StgApp trivial_scrut [] <- scrut' = addTrivCaseBndr bndr trivial_scrut env1+                 -- See Note [Trivial case scrutinee]+         | otherwise                         = env1+    alts' = map (stgCseAlt env2 bndr') alts+++-- A constructor application.+-- To be removed by a variable use when found in the CSE environment+stgCseExpr env (StgConApp dataCon args tys)+    | Just bndr' <- envLookup dataCon args' env+    = StgApp bndr' []+    | otherwise+    = StgConApp dataCon args' tys+  where args' = substArgs env args++-- Let bindings+-- The binding might be removed due to CSE (we do not want trivial bindings on+-- the STG level), so use the smart constructor `mkStgLet` to remove the binding+-- if empty.+stgCseExpr env (StgLet binds body)+    = let (binds', env') = stgCseBind env binds+          body' = stgCseExpr env' body+      in mkStgLet StgLet binds' body'+stgCseExpr env (StgLetNoEscape binds body)+    = let (binds', env') = stgCseBind env binds+          body' = stgCseExpr env' body+      in mkStgLet StgLetNoEscape binds' body'++-- Case alternatives+-- Extend the CSE environment+stgCseAlt :: CseEnv -> OutId -> InStgAlt -> OutStgAlt+stgCseAlt env case_bndr (DataAlt dataCon, args, rhs)+    = let (env1, args') = substBndrs env args+          env2 = addDataCon case_bndr dataCon (map StgVarArg args') env1+            -- see note [Case 2: CSEing case binders]+          rhs' = stgCseExpr env2 rhs+      in (DataAlt dataCon, args', rhs')+stgCseAlt env _ (altCon, args, rhs)+    = let (env1, args') = substBndrs env args+          rhs' = stgCseExpr env1 rhs+      in (altCon, args', rhs')++-- Bindings+stgCseBind :: CseEnv -> InStgBinding -> (Maybe OutStgBinding, CseEnv)+stgCseBind env (StgNonRec b e)+    = let (env1, b') = substBndr env b+      in case stgCseRhs env1 b' e of+        (Nothing,      env2) -> (Nothing,                env2)+        (Just (b2,e'), env2) -> (Just (StgNonRec b2 e'), env2)+stgCseBind env (StgRec pairs)+    = let (env1, pairs1) = substPairs env pairs+      in case stgCsePairs env1 pairs1 of+        ([],     env2) -> (Nothing, env2)+        (pairs2, env2) -> (Just (StgRec pairs2), env2)++stgCsePairs :: CseEnv -> [(OutId, InStgRhs)] -> ([(OutId, OutStgRhs)], CseEnv)+stgCsePairs env [] = ([], env)+stgCsePairs env0 ((b,e):pairs)+  = let (pairMB, env1) = stgCseRhs env0 b e+        (pairs', env2) = stgCsePairs env1 pairs+    in (pairMB `mbCons` pairs', env2)+  where+    mbCons = maybe id (:)++-- The RHS of a binding.+-- If it is an constructor application, either short-cut it or extend the environment+stgCseRhs :: CseEnv -> OutId -> InStgRhs -> (Maybe (OutId, OutStgRhs), CseEnv)+stgCseRhs env bndr (StgRhsCon ccs dataCon args)+    | Just other_bndr <- envLookup dataCon args' env+    = let env' = addSubst bndr other_bndr env+      in (Nothing, env')+    | otherwise+    = let env' = addDataCon bndr dataCon args' env+            -- see note [Case 1: CSEing allocated closures]+          pair = (bndr, StgRhsCon ccs dataCon args')+      in (Just pair, env')+  where args' = substArgs env args+stgCseRhs env bndr (StgRhsClosure ccs info occs upd args body)+    = let (env1, args') = substBndrs env args+          env2 = forgetCse env1 -- See note [Free variables of an StgClosure]+          body' = stgCseExpr env2 body+      in (Just (substVar env bndr, StgRhsClosure ccs info occs' upd args' body'), env)+  where occs' = substVars env occs++-- Utilities++-- | This function short-cuts let-bindings that are now obsolete+mkStgLet :: (a -> b -> b) -> Maybe a -> b -> b+mkStgLet _      Nothing      body = body+mkStgLet stgLet (Just binds) body = stgLet binds body+++{-+Note [Trivial case scrutinee]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We wnat to be able to handle nested reconstruction of constructors as in++    nested :: Either Int (Either Int a) -> Either Bool (Either Bool a)+    nested (Right (Right v)) = Right (Right v)+    nested _ = Left True++So if we come across++    case x of r1+      Right a -> case a of r2+              Right b -> let v = Right b+                         in Right v++we first replace v with r2. Next we want to replace Right r2 with r1. But the+ce_conAppMap contains Right a!++Therefore, we add r1 ↦ x to ce_bndrMap when analysing the outer case, and use+this subsitution before looking Right r2 up in ce_conAppMap, and everything+works out.++Note [Free variables of an StgClosure]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+StgClosures (function and thunks) have an explicit list of free variables:++foo [x] =+    let not_a_free_var = Left [x]+    let a_free_var = Right [x]+    let closure = \[x a_free_var] -> \[y] -> bar y (Left [x]) a_free_var+    in closure++If we were to CSE `Left [x]` in the body of `closure` with `not_a_free_var`,+then the list of free variables would be wrong, so for now, we do not CSE+across such a closure, simply because I (Joachim) was not sure about possible+knock-on effects. If deemed safe and worth the slight code complication of+re-calculating this list during or after this pass, this can surely be done.+-}
+ simplStg/StgStats.hs view
@@ -0,0 +1,175 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[StgStats]{Gathers statistical information about programs}+++The program gather statistics about+\begin{enumerate}+\item number of boxed cases+\item number of unboxed cases+\item number of let-no-escapes+\item number of non-updatable lets+\item number of updatable lets+\item number of applications+\item number of primitive applications+\item number of closures (does not include lets bound to constructors)+\item number of free variables in closures+%\item number of top-level functions+%\item number of top-level CAFs+\item number of constructors+\end{enumerate}+-}++{-# LANGUAGE CPP #-}++module StgStats ( showStgStats ) where++#include "HsVersions.h"++import StgSyn++import Id (Id)+import Panic++import Data.Map (Map)+import qualified Data.Map as Map++data CounterType+  = Literals+  | Applications+  | ConstructorApps+  | PrimitiveApps+  | LetNoEscapes+  | StgCases+  | FreeVariables+  | ConstructorBinds Bool{-True<=>top-level-}+  | ReEntrantBinds   Bool{-ditto-}+  | SingleEntryBinds Bool{-ditto-}+  | UpdatableBinds   Bool{-ditto-}+  deriving (Eq, Ord)++type Count      = Int+type StatEnv    = Map CounterType Count++emptySE :: StatEnv+emptySE = Map.empty++combineSE :: StatEnv -> StatEnv -> StatEnv+combineSE = Map.unionWith (+)++combineSEs :: [StatEnv] -> StatEnv+combineSEs = foldr combineSE emptySE++countOne :: CounterType -> StatEnv+countOne c = Map.singleton c 1++countN :: CounterType -> Int -> StatEnv+countN = Map.singleton++{-+************************************************************************+*                                                                      *+\subsection{Top-level list of bindings (a ``program'')}+*                                                                      *+************************************************************************+-}++showStgStats :: [StgTopBinding] -> String++showStgStats prog+  = "STG Statistics:\n\n"+    ++ concat (map showc (Map.toList (gatherStgStats prog)))+  where+    showc (x,n) = (showString (s x) . shows n) "\n"++    s Literals                = "Literals                   "+    s Applications            = "Applications               "+    s ConstructorApps         = "ConstructorApps            "+    s PrimitiveApps           = "PrimitiveApps              "+    s LetNoEscapes            = "LetNoEscapes               "+    s StgCases                = "StgCases                   "+    s FreeVariables           = "FreeVariables              "+    s (ConstructorBinds True) = "ConstructorBinds_Top       "+    s (ReEntrantBinds True)   = "ReEntrantBinds_Top         "+    s (SingleEntryBinds True) = "SingleEntryBinds_Top       "+    s (UpdatableBinds True)   = "UpdatableBinds_Top         "+    s (ConstructorBinds _)    = "ConstructorBinds_Nested    "+    s (ReEntrantBinds _)      = "ReEntrantBindsBinds_Nested "+    s (SingleEntryBinds _)    = "SingleEntryBinds_Nested    "+    s (UpdatableBinds _)      = "UpdatableBinds_Nested      "++gatherStgStats :: [StgTopBinding] -> StatEnv+gatherStgStats binds = combineSEs (map statTopBinding binds)++{-+************************************************************************+*                                                                      *+\subsection{Bindings}+*                                                                      *+************************************************************************+-}++statTopBinding :: StgTopBinding -> StatEnv+statTopBinding (StgTopStringLit _ _) = countOne Literals+statTopBinding (StgTopLifted bind) = statBinding True bind++statBinding :: Bool -- True <=> top-level; False <=> nested+            -> StgBinding+            -> StatEnv++statBinding top (StgNonRec b rhs)+  = statRhs top (b, rhs)++statBinding top (StgRec pairs)+  = combineSEs (map (statRhs top) pairs)++statRhs :: Bool -> (Id, StgRhs) -> StatEnv++statRhs top (_, StgRhsCon _ _ _)+  = countOne (ConstructorBinds top)++statRhs top (_, StgRhsClosure _ _ fv u _ body)+  = statExpr body                       `combineSE`+    countN FreeVariables (length fv)    `combineSE`+    countOne (+      case u of+        ReEntrant   -> ReEntrantBinds   top+        Updatable   -> UpdatableBinds   top+        SingleEntry -> SingleEntryBinds top+    )++{-+************************************************************************+*                                                                      *+\subsection{Expressions}+*                                                                      *+************************************************************************+-}++statExpr :: StgExpr -> StatEnv++statExpr (StgApp _ _)     = countOne Applications+statExpr (StgLit _)       = countOne Literals+statExpr (StgConApp _ _ _)= countOne ConstructorApps+statExpr (StgOpApp _ _ _) = countOne PrimitiveApps+statExpr (StgTick _ e)    = statExpr e++statExpr (StgLetNoEscape binds body)+  = statBinding False{-not top-level-} binds    `combineSE`+    statExpr body                               `combineSE`+    countOne LetNoEscapes++statExpr (StgLet binds body)+  = statBinding False{-not top-level-} binds    `combineSE`+    statExpr body++statExpr (StgCase expr _ _ alts)+  = statExpr expr       `combineSE`+    stat_alts alts      `combineSE`+    countOne StgCases+  where+    stat_alts alts+        = combineSEs (map statExpr [ e | (_,_,e) <- alts ])++statExpr (StgLam {}) = panic "statExpr StgLam"
+ simplStg/UnariseStg.hs view
@@ -0,0 +1,761 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-2012++Note [Unarisation]+~~~~~~~~~~~~~~~~~~+The idea of this pass is to translate away *all* unboxed-tuple and unboxed-sum+binders. So for example:++  f (x :: (# Int, Bool #)) = f x + f (# 1, True #)++  ==>++  f (x1 :: Int) (x2 :: Bool) = f x1 x2 + f 1 True++It is important that we do this at the STG level and NOT at the Core level+because it would be very hard to make this pass Core-type-preserving. In this+example the type of 'f' changes, for example.++STG fed to the code generators *must* be unarised because the code generators do+not support unboxed tuple and unboxed sum binders natively.++In more detail: (see next note for unboxed sums)++Suppose that a variable x : (# t1, t2 #).++  * At the binding site for x, make up fresh vars  x1:t1, x2:t2++  * Extend the UnariseEnv   x :-> MultiVal [x1,x2]++  * Replace the binding with a curried binding for x1,x2++       Lambda:   \x.e                ==>   \x1 x2. e+       Case alt: MkT a b x c d -> e  ==>   MkT a b x1 x2 c d -> e++  * Replace argument occurrences with a sequence of args via a lookup in+    UnariseEnv++       f a b x c d   ==>   f a b x1 x2 c d++  * Replace tail-call occurrences with an unboxed tuple via a lookup in+    UnariseEnv++       x  ==>  (# x1, x2 #)++    So, for example++       f x = x    ==>   f x1 x2 = (# x1, x2 #)++  * We /always/ eliminate a case expression when++       - It scrutinises an unboxed tuple or unboxed sum++       - The scrutinee is a variable (or when it is an explicit tuple, but the+         simplifier eliminates those)++    The case alternative (there can be only one) can be one of these two+    things:++      - An unboxed tuple pattern. e.g.++          case v of x { (# x1, x2, x3 #) -> ... }++        Scrutinee has to be in form `(# t1, t2, t3 #)` so we just extend the+        environment with++          x :-> MultiVal [t1,t2,t3]+          x1 :-> UnaryVal t1, x2 :-> UnaryVal t2, x3 :-> UnaryVal t3++      - A DEFAULT alternative. Just the same, without the bindings for x1,x2,x3++By the end of this pass, we only have unboxed tuples in return positions.+Unboxed sums are completely eliminated, see next note.++Note [Translating unboxed sums to unboxed tuples]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Unarise also eliminates unboxed sum binders, and translates unboxed sums in+return positions to unboxed tuples. We want to overlap fields of a sum when+translating it to a tuple to have efficient memory layout. When translating a+sum pattern to a tuple pattern, we need to translate it so that binders of sum+alternatives will be mapped to right arguments after the term translation. So+translation of sum DataCon applications to tuple DataCon applications and+translation of sum patterns to tuple patterns need to be in sync.++These translations work like this. Suppose we have++  (# x1 | | ... #) :: (# t1 | t2 | ... #)++remember that t1, t2 ... can be sums and tuples too. So we first generate+layouts of those. Then we "merge" layouts of each alternative, which gives us a+sum layout with best overlapping possible.++Layout of a flat type 'ty1' is just [ty1].+Layout of a tuple is just concatenation of layouts of its fields.++For layout of a sum type,++  - We first get layouts of all alternatives.+  - We sort these layouts based on their "slot types".+  - We merge all the alternatives.++For example, say we have (# (# Int#, Char #) | (# Int#, Int# #) | Int# #)++  - Layouts of alternatives: [ [Word, Ptr], [Word, Word], [Word] ]+  - Sorted: [ [Ptr, Word], [Word, Word], [Word] ]+  - Merge all alternatives together: [ Ptr, Word, Word ]++We add a slot for the tag to the first position. So our tuple type is++  (# Tag#, Any, Word#, Word# #)+  (we use Any for pointer slots)++Now, any term of this sum type needs to generate a tuple of this type instead.+The translation works by simply putting arguments to first slots that they fit+in. Suppose we had++  (# (# 42#, 'c' #) | | #)++42# fits in Word#, 'c' fits in Any, so we generate this application:++  (# 1#, 'c', 42#, rubbish #)++Another example using the same type: (# | (# 2#, 3# #) | #). 2# fits in Word#,+3# fits in Word #, so we get:++  (# 2#, rubbish, 2#, 3# #).++Note [Types in StgConApp]+~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have this unboxed sum term:++  (# 123 | #)++What will be the unboxed tuple representation? We can't tell without knowing the+type of this term. For example, these are all valid tuples for this:++  (# 1#, 123 #)          -- when type is (# Int | String #)+  (# 1#, 123, rubbish #) -- when type is (# Int | Float# #)+  (# 1#, 123, rubbish, rubbish #)+                         -- when type is (# Int | (# Int, Int, Int #) #)++So we pass type arguments of the DataCon's TyCon in StgConApp to decide what+layout to use. Note that unlifted values can't be let-bound, so we don't need+types in StgRhsCon.++Note [UnariseEnv can map to literals]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To avoid redundant case expressions when unarising unboxed sums, UnariseEnv+needs to map variables to literals too. Suppose we have this Core:++  f (# x | #)++  ==> (CorePrep)++  case (# x | #) of y {+    _ -> f y+  }++  ==> (MultiVal)++  case (# 1#, x #) of [x1, x2] {+    _ -> f x1 x2+  }++To eliminate this case expression we need to map x1 to 1# in UnariseEnv:++  x1 :-> UnaryVal 1#, x2 :-> UnaryVal x++so that `f x1 x2` becomes `f 1# x`.++Note [Unarisation and arity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Because of unarisation, the arity that will be recorded in the generated info+table for an Id may be larger than the idArity. Instead we record what we call+the RepArity, which is the Arity taking into account any expanded arguments, and+corresponds to the number of (possibly-void) *registers* arguments will arrive+in.++Note [Post-unarisation invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+STG programs after unarisation have these invariants:++  * No unboxed sums at all.++  * No unboxed tuple binders. Tuples only appear in return position.++  * DataCon applications (StgRhsCon and StgConApp) don't have void arguments.+    This means that it's safe to wrap `StgArg`s of DataCon applications with+    `StgCmmEnv.NonVoid`, for example.++  * Alt binders (binders in patterns) are always non-void.+-}++{-# LANGUAGE CPP, TupleSections #-}++module UnariseStg (unarise) where++#include "HsVersions.h"++import BasicTypes+import CoreSyn+import DataCon+import FastString (FastString, mkFastString)+import Id+import Literal (Literal (..))+import MkCore (aBSENT_ERROR_ID)+import MkId (voidPrimId, voidArgId)+import MonadUtils (mapAccumLM)+import Outputable+import RepType+import StgSyn+import Type+import TysPrim (intPrimTy)+import TysWiredIn+import UniqSupply+import Util+import VarEnv++import Data.Bifunctor (second)+import Data.Maybe (mapMaybe)+import qualified Data.IntMap as IM++--------------------------------------------------------------------------------++-- | A mapping from binders to the Ids they were expanded/renamed to.+--+--   x :-> MultiVal [a,b,c] in rho+--+-- iff  x's typePrimRep is not a singleton, or equivalently+--      x's type is an unboxed tuple, sum or void.+--+--    x :-> UnaryVal x'+--+-- iff x's RepType is UnaryRep or equivalently+--     x's type is not unboxed tuple, sum or void.+--+-- So+--     x :-> MultiVal [a] in rho+-- means x is represented by singleton tuple.+--+--     x :-> MultiVal [] in rho+-- means x is void.+--+-- INVARIANT: OutStgArgs in the range only have NvUnaryTypes+--            (i.e. no unboxed tuples, sums or voids)+--+type UnariseEnv = VarEnv UnariseVal++data UnariseVal+  = MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void).+  | UnaryVal OutStgArg   -- See NOTE [Renaming during unarisation].++instance Outputable UnariseVal where+  ppr (MultiVal args) = text "MultiVal" <+> ppr args+  ppr (UnaryVal arg)   = text "UnaryVal" <+> ppr arg++-- | Extend the environment, checking the UnariseEnv invariant.+extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv+extendRho rho x (MultiVal args)+  = ASSERT(all (isNvUnaryType . stgArgType) args)+    extendVarEnv rho x (MultiVal args)+extendRho rho x (UnaryVal val)+  = ASSERT(isNvUnaryType (stgArgType val))+    extendVarEnv rho x (UnaryVal val)++--------------------------------------------------------------------------------++unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding]+unarise us binds = initUs_ us (mapM (unariseTopBinding emptyVarEnv) binds)++unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding+unariseTopBinding rho (StgTopLifted bind)+  = StgTopLifted <$> unariseBinding rho bind+unariseTopBinding _ bind@StgTopStringLit{} = return bind++unariseBinding :: UnariseEnv -> StgBinding -> UniqSM StgBinding+unariseBinding rho (StgNonRec x rhs)+  = StgNonRec x <$> unariseRhs rho rhs+unariseBinding rho (StgRec xrhss)+  = StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho rhs) xrhss++unariseRhs :: UnariseEnv -> StgRhs -> UniqSM StgRhs+unariseRhs rho (StgRhsClosure ccs b_info fvs update_flag args expr)+  = do (rho', args1) <- unariseFunArgBinders rho args+       expr' <- unariseExpr rho' expr+       let fvs' = unariseFreeVars rho fvs+       return (StgRhsClosure ccs b_info fvs' update_flag args1 expr')++unariseRhs rho (StgRhsCon ccs con args)+  = ASSERT(not (isUnboxedTupleCon con || isUnboxedSumCon con))+    return (StgRhsCon ccs con (unariseConArgs rho args))++--------------------------------------------------------------------------------++unariseExpr :: UnariseEnv -> StgExpr -> UniqSM StgExpr++unariseExpr rho e@(StgApp f [])+  = case lookupVarEnv rho f of+      Just (MultiVal args)  -- Including empty tuples+        -> return (mkTuple args)+      Just (UnaryVal (StgVarArg f'))+        -> return (StgApp f' [])+      Just (UnaryVal (StgLitArg f'))+        -> return (StgLit f')+      Nothing+        -> return e++unariseExpr rho e@(StgApp f args)+  = return (StgApp f' (unariseFunArgs rho args))+  where+    f' = case lookupVarEnv rho f of+           Just (UnaryVal (StgVarArg f')) -> f'+           Nothing -> f+           err -> pprPanic "unariseExpr - app2" (ppr e $$ ppr err)+               -- Can't happen because 'args' is non-empty, and+               -- a tuple or sum cannot be applied to anything++unariseExpr _ (StgLit l)+  = return (StgLit l)++unariseExpr rho (StgConApp dc args ty_args)+  | Just args' <- unariseMulti_maybe rho dc args ty_args+  = return (mkTuple args')++  | otherwise+  , let args' = unariseConArgs rho args+  = return (StgConApp dc args' (map stgArgType args'))++unariseExpr rho (StgOpApp op args ty)+  = return (StgOpApp op (unariseFunArgs rho args) ty)++unariseExpr _ e@StgLam{}+  = pprPanic "unariseExpr: found lambda" (ppr e)++unariseExpr rho (StgCase scrut bndr alt_ty alts)+  -- a tuple/sum binders in the scrutinee can always be eliminated+  | StgApp v [] <- scrut+  , Just (MultiVal xs) <- lookupVarEnv rho v+  = elimCase rho xs bndr alt_ty alts++  -- Handle strict lets for tuples and sums:+  --   case (# a,b #) of r -> rhs+  -- and analogously for sums+  | StgConApp dc args ty_args <- scrut+  , Just args' <- unariseMulti_maybe rho dc args ty_args+  = elimCase rho args' bndr alt_ty alts++  -- general case+  | otherwise+  = do scrut' <- unariseExpr rho scrut+       alts'  <- unariseAlts rho alt_ty bndr alts+       return (StgCase scrut' bndr alt_ty alts')+                       -- bndr will be dead after unarise++unariseExpr rho (StgLet bind e)+  = StgLet <$> unariseBinding rho bind <*> unariseExpr rho e++unariseExpr rho (StgLetNoEscape bind e)+  = StgLetNoEscape <$> unariseBinding rho bind <*> unariseExpr rho e++unariseExpr rho (StgTick tick e)+  = StgTick tick <$> unariseExpr rho e++-- Doesn't return void args.+unariseMulti_maybe :: UnariseEnv -> DataCon -> [InStgArg] -> [Type] -> Maybe [OutStgArg]+unariseMulti_maybe rho dc args ty_args+  | isUnboxedTupleCon dc+  = Just (unariseConArgs rho args)++  | isUnboxedSumCon dc+  , let args1 = ASSERT(isSingleton args) (unariseConArgs rho args)+  = Just (mkUbxSum dc ty_args args1)++  | otherwise+  = Nothing++--------------------------------------------------------------------------------++elimCase :: UnariseEnv+         -> [OutStgArg] -- non-void args+         -> InId -> AltType -> [InStgAlt] -> UniqSM OutStgExpr++elimCase rho args bndr (MultiValAlt _) [(_, bndrs, rhs)]+  = do let rho1 = extendRho rho bndr (MultiVal args)+           rho2+             | isUnboxedTupleBndr bndr+             = mapTupleIdBinders bndrs args rho1+             | otherwise+             = ASSERT(isUnboxedSumBndr bndr)+               if null bndrs then rho1+                             else mapSumIdBinders bndrs args rho1++       unariseExpr rho2 rhs++elimCase rho args bndr (MultiValAlt _) alts+  | isUnboxedSumBndr bndr+  = do let (tag_arg : real_args) = args+       tag_bndr <- mkId (mkFastString "tag") tagTy+          -- this won't be used but we need a binder anyway+       let rho1 = extendRho rho bndr (MultiVal args)+           scrut' = case tag_arg of+                      StgVarArg v     -> StgApp v []+                      StgLitArg l     -> StgLit l++       alts' <- unariseSumAlts rho1 real_args alts+       return (StgCase scrut' tag_bndr tagAltTy alts')++elimCase _ args bndr alt_ty alts+  = pprPanic "elimCase - unhandled case"+      (ppr args <+> ppr bndr <+> ppr alt_ty $$ ppr alts)++--------------------------------------------------------------------------------++unariseAlts :: UnariseEnv -> AltType -> InId -> [StgAlt] -> UniqSM [StgAlt]+unariseAlts rho (MultiValAlt n) bndr [(DEFAULT, [], e)]+  | isUnboxedTupleBndr bndr+  = do (rho', ys) <- unariseConArgBinder rho bndr+       e' <- unariseExpr rho' e+       return [(DataAlt (tupleDataCon Unboxed n), ys, e')]++unariseAlts rho (MultiValAlt n) bndr [(DataAlt _, ys, e)]+  | isUnboxedTupleBndr bndr+  = do (rho', ys1) <- unariseConArgBinders rho ys+       MASSERT(n == length ys1)+       let rho'' = extendRho rho' bndr (MultiVal (map StgVarArg ys1))+       e' <- unariseExpr rho'' e+       return [(DataAlt (tupleDataCon Unboxed n), ys1, e')]++unariseAlts _ (MultiValAlt _) bndr alts+  | isUnboxedTupleBndr bndr+  = pprPanic "unariseExpr: strange multi val alts" (ppr alts)++-- In this case we don't need to scrutinize the tag bit+unariseAlts rho (MultiValAlt _) bndr [(DEFAULT, _, rhs)]+  | isUnboxedSumBndr bndr+  = do (rho_sum_bndrs, sum_bndrs) <- unariseConArgBinder rho bndr+       rhs' <- unariseExpr rho_sum_bndrs rhs+       return [(DataAlt (tupleDataCon Unboxed (length sum_bndrs)), sum_bndrs, rhs')]++unariseAlts rho (MultiValAlt _) bndr alts+  | isUnboxedSumBndr bndr+  = do (rho_sum_bndrs, scrt_bndrs@(tag_bndr : real_bndrs)) <- unariseConArgBinder rho bndr+       alts' <- unariseSumAlts rho_sum_bndrs (map StgVarArg real_bndrs) alts+       let inner_case = StgCase (StgApp tag_bndr []) tag_bndr tagAltTy alts'+       return [ (DataAlt (tupleDataCon Unboxed (length scrt_bndrs)),+                 scrt_bndrs,+                 inner_case) ]++unariseAlts rho _ _ alts+  = mapM (\alt -> unariseAlt rho alt) alts++unariseAlt :: UnariseEnv -> StgAlt -> UniqSM StgAlt+unariseAlt rho (con, xs, e)+  = do (rho', xs') <- unariseConArgBinders rho xs+       (con, xs',) <$> unariseExpr rho' e++--------------------------------------------------------------------------------++-- | Make alternatives that match on the tag of a sum+-- (i.e. generate LitAlts for the tag)+unariseSumAlts :: UnariseEnv+               -> [StgArg] -- sum components _excluding_ the tag bit.+               -> [StgAlt] -- original alternative with sum LHS+               -> UniqSM [StgAlt]+unariseSumAlts env args alts+  = do alts' <- mapM (unariseSumAlt env args) alts+       return (mkDefaultLitAlt alts')++unariseSumAlt :: UnariseEnv+              -> [StgArg] -- sum components _excluding_ the tag bit.+              -> StgAlt   -- original alternative with sum LHS+              -> UniqSM StgAlt+unariseSumAlt rho _ (DEFAULT, _, e)+  = ( DEFAULT, [], ) <$> unariseExpr rho e++unariseSumAlt rho args (DataAlt sumCon, bs, e)+  = do let rho' = mapSumIdBinders bs args rho+       e' <- unariseExpr rho' e+       return ( LitAlt (MachInt (fromIntegral (dataConTag sumCon))), [], e' )++unariseSumAlt _ scrt alt+  = pprPanic "unariseSumAlt" (ppr scrt $$ ppr alt)++--------------------------------------------------------------------------------++mapTupleIdBinders+  :: [InId]       -- Un-processed binders of a tuple alternative.+                  -- Can have void binders.+  -> [OutStgArg]  -- Arguments that form the tuple (after unarisation).+                  -- Can't have void args.+  -> UnariseEnv+  -> UnariseEnv+mapTupleIdBinders ids args0 rho0+  = ASSERT(not (any (isVoidTy . stgArgType) args0))+    let+      ids_unarised :: [(Id, [PrimRep])]+      ids_unarised = map (\id -> (id, typePrimRep (idType id))) ids++      map_ids :: UnariseEnv -> [(Id, [PrimRep])] -> [StgArg] -> UnariseEnv+      map_ids rho [] _  = rho+      map_ids rho ((x, x_reps) : xs) args =+        let+          x_arity = length x_reps+          (x_args, args') =+            ASSERT(args `lengthAtLeast` x_arity)+            splitAt x_arity args++          rho'+            | x_arity == 1+            = ASSERT(x_args `lengthIs` 1)+              extendRho rho x (UnaryVal (head x_args))+            | otherwise+            = extendRho rho x (MultiVal x_args)+        in+          map_ids rho' xs args'+    in+      map_ids rho0 ids_unarised args0++mapSumIdBinders+  :: [InId]      -- Binder of a sum alternative (remember that sum patterns+                 -- only have one binder, so this list should be a singleton)+  -> [OutStgArg] -- Arguments that form the sum (NOT including the tag).+                 -- Can't have void args.+  -> UnariseEnv+  -> UnariseEnv++mapSumIdBinders [id] args rho0+  = ASSERT(not (any (isVoidTy . stgArgType) args))+    let+      arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args+      id_slots  = map primRepSlot $ typePrimRep (idType id)+      layout1   = layoutUbxSum arg_slots id_slots+    in+      if isMultiValBndr id+        then extendRho rho0 id (MultiVal [ args !! i | i <- layout1 ])+        else ASSERT(layout1 `lengthIs` 1)+             extendRho rho0 id (UnaryVal (args !! head layout1))++mapSumIdBinders ids sum_args _+  = pprPanic "mapSumIdBinders" (ppr ids $$ ppr sum_args)++-- | Build a unboxed sum term from arguments of an alternative.+--+-- Example, for (# x | #) :: (# (# #) | Int #) we call+--+--   mkUbxSum (# _ | #) [ (# #), Int ] [ voidPrimId ]+--+-- which returns+--+--   [ 1#, rubbish ]+--+mkUbxSum+  :: DataCon      -- Sum data con+  -> [Type]       -- Type arguments of the sum data con+  -> [OutStgArg]  -- Actual arguments of the alternative.+  -> [OutStgArg]  -- Final tuple arguments+mkUbxSum dc ty_args args0+  = let+      (_ : sum_slots) = ubxSumRepType (map typePrimRep ty_args)+        -- drop tag slot++      tag = dataConTag dc++      layout'  = layoutUbxSum sum_slots (mapMaybe (typeSlotTy . stgArgType) args0)+      tag_arg  = StgLitArg (MachInt (fromIntegral tag))+      arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0)++      mkTupArgs :: Int -> [SlotTy] -> IM.IntMap StgArg -> [StgArg]+      mkTupArgs _ [] _+        = []+      mkTupArgs arg_idx (slot : slots_left) arg_map+        | Just stg_arg <- IM.lookup arg_idx arg_map+        = stg_arg : mkTupArgs (arg_idx + 1) slots_left arg_map+        | otherwise+        = slotRubbishArg slot : mkTupArgs (arg_idx + 1) slots_left arg_map++      slotRubbishArg :: SlotTy -> StgArg+      slotRubbishArg PtrSlot    = StgVarArg aBSENT_ERROR_ID+      slotRubbishArg WordSlot   = StgLitArg (MachWord 0)+      slotRubbishArg Word64Slot = StgLitArg (MachWord64 0)+      slotRubbishArg FloatSlot  = StgLitArg (MachFloat 0)+      slotRubbishArg DoubleSlot = StgLitArg (MachDouble 0)+    in+      tag_arg : mkTupArgs 0 sum_slots arg_idxs++--------------------------------------------------------------------------------++{-+For arguments (StgArg) and binders (Id) we have two kind of unarisation:++  - When unarising function arg binders and arguments, we don't want to remove+    void binders and arguments. For example,++      f :: (# (# #), (# #) #) -> Void# -> RealWorld# -> ...+      f x y z = <body>++    Here after unarise we should still get a function with arity 3. Similarly+    in the call site we shouldn't remove void arguments:++      f (# (# #), (# #) #) voidId rw++    When unarising <body>, we extend the environment with these binders:++      x :-> MultiVal [], y :-> MultiVal [], z :-> MultiVal []++    Because their rep types are `MultiRep []` (aka. void). This means that when+    we see `x` in a function argument position, we actually replace it with a+    void argument. When we see it in a DataCon argument position, we just get+    rid of it, because DataCon applications in STG are always saturated.++  - When unarising case alternative binders we remove void binders, but we+    still update the environment the same way, because those binders may be+    used in the RHS. Example:++      case x of y {+        (# x1, x2, x3 #) -> <RHS>+      }++    We know that y can't be void, because we don't scrutinize voids, so x will+    be unarised to some number of arguments, and those arguments will have at+    least one non-void thing. So in the rho we will have something like:++      x :-> MultiVal [xu1, xu2]++    Now, after we eliminate void binders in the pattern, we get exactly the same+    number of binders, and extend rho again with these:++      x1 :-> UnaryVal xu1+      x2 :-> MultiVal [] -- x2 is void+      x3 :-> UnaryVal xu2++    Now when we see x2 in a function argument position or in return position, we+    generate void#. In constructor argument position, we just remove it.++So in short, when we have a void id,++  - We keep it if it's a lambda argument binder or+                       in argument position of an application.++  - We remove it if it's a DataCon field binder or+                         in argument position of a DataCon application.+-}++--------------------------------------------------------------------------------++-- | MultiVal a function argument. Never returns an empty list.+unariseFunArg :: UnariseEnv -> StgArg -> [StgArg]+unariseFunArg rho (StgVarArg x) =+  case lookupVarEnv rho x of+    Just (MultiVal [])  -> [voidArg]   -- NB: do not remove void args+    Just (MultiVal as)  -> as+    Just (UnaryVal arg) -> [arg]+    Nothing             -> [StgVarArg x]+unariseFunArg _ arg = [arg]++unariseFunArgs :: UnariseEnv -> [StgArg] -> [StgArg]+unariseFunArgs = concatMap . unariseFunArg++unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])+unariseFunArgBinders rho xs = second concat <$> mapAccumLM unariseFunArgBinder rho xs++unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])+-- Result list of binders is never empty+unariseFunArgBinder rho x  =+  case typePrimRep (idType x) of+    []   -> return (extendRho rho x (MultiVal []), [voidArgId])+                           -- NB: do not remove void binders+    [_]  -> return (rho, [x])+    reps -> do+      xs <- mkIds (mkFastString "us") (map primRepToType reps)+      return (extendRho rho x (MultiVal (map StgVarArg xs)), xs)++--------------------------------------------------------------------------------++-- | MultiVal a DataCon argument. Returns an empty list when argument is void.+unariseConArg :: UnariseEnv -> InStgArg -> [OutStgArg]+unariseConArg rho (StgVarArg x) =+  case lookupVarEnv rho x of+    Just (UnaryVal arg) -> [arg]+    Just (MultiVal as) -> as      -- 'as' can be empty+    Nothing+      | isVoidTy (idType x) -> [] -- e.g. C realWorld#+                                  -- Here realWorld# is not in the envt, but+                                  -- is a void, and so should be eliminated+      | otherwise -> [StgVarArg x]+unariseConArg _ arg = [arg]       -- We have no void literals++unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]+unariseConArgs = concatMap . unariseConArg++unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])+unariseConArgBinders rho xs = second concat <$> mapAccumLM unariseConArgBinder rho xs++unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])+unariseConArgBinder rho x =+  case typePrimRep (idType x) of+    [_]  -> return (rho, [x])+    reps -> do+      xs <- mkIds (mkFastString "us") (map primRepToType reps)+      return (extendRho rho x (MultiVal (map StgVarArg xs)), xs)++unariseFreeVars :: UnariseEnv -> [InId] -> [OutId]+unariseFreeVars rho fvs+ = [ v | fv <- fvs, StgVarArg v <- unariseFreeVar rho fv ]+   -- Notice that we filter out any StgLitArgs+   -- e.g.   case e of (x :: (# Int | Bool #))+   --           (# v | #) ->  ... let {g = \y. ..x...} in ...+   --           (# | w #) -> ...+   --     Here 'x' is free in g's closure, and the env will have+   --       x :-> [1, v]+   --     we want to capture 'v', but not 1, in the free vars++unariseFreeVar :: UnariseEnv -> Id -> [StgArg]+unariseFreeVar rho x =+  case lookupVarEnv rho x of+    Just (MultiVal args) -> args+    Just (UnaryVal arg)  -> [arg]+    Nothing              -> [StgVarArg x]++--------------------------------------------------------------------------------++mkIds :: FastString -> [UnaryType] -> UniqSM [Id]+mkIds fs tys = mapM (mkId fs) tys++mkId :: FastString -> UnaryType -> UniqSM Id+mkId = mkSysLocalOrCoVarM++isMultiValBndr :: Id -> Bool+isMultiValBndr id+  | [_] <- typePrimRep (idType id)+  = False+  | otherwise+  = True++isUnboxedSumBndr :: Id -> Bool+isUnboxedSumBndr = isUnboxedSumType . idType++isUnboxedTupleBndr :: Id -> Bool+isUnboxedTupleBndr = isUnboxedTupleType . idType++mkTuple :: [StgArg] -> StgExpr+mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) args (map stgArgType args)++tagAltTy :: AltType+tagAltTy = PrimAlt IntRep++tagTy :: Type+tagTy = intPrimTy++voidArg :: StgArg+voidArg = StgVarArg voidPrimId++mkDefaultLitAlt :: [StgAlt] -> [StgAlt]+-- We have an exhauseive list of literal alternatives+--    1# -> e1+--    2# -> e2+-- Since they are exhaustive, we can replace one with DEFAULT, to avoid+-- generating a final test. Remember, the DEFAULT comes first if it exists.+mkDefaultLitAlt [] = pprPanic "elimUbxSumExpr.mkDefaultAlt" (text "Empty alts")+mkDefaultLitAlt alts@((DEFAULT, _, _) : _) = alts+mkDefaultLitAlt ((LitAlt{}, [], rhs) : alts) = (DEFAULT, [], rhs) : alts+mkDefaultLitAlt alts = pprPanic "mkDefaultLitAlt" (text "Not a lit alt:" <+> ppr alts)
+ specialise/Rules.hs view
@@ -0,0 +1,1256 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[CoreRules]{Transformation rules}+-}++{-# LANGUAGE CPP #-}++-- | Functions for collecting together and applying rewrite rules to a module.+-- The 'CoreRule' datatype itself is declared elsewhere.+module Rules (+        -- ** Constructing+        emptyRuleBase, mkRuleBase, extendRuleBaseList,+        unionRuleBase, pprRuleBase,++        -- ** Checking rule applications+        ruleCheckProgram,++        -- ** Manipulating 'RuleInfo' rules+        mkRuleInfo, extendRuleInfo, addRuleInfo,+        addIdSpecialisations,++        -- * Misc. CoreRule helpers+        rulesOfBinds, getRules, pprRulesForUser,++        lookupRule, mkRule, roughTopNames+    ) where++#include "HsVersions.h"++import CoreSyn          -- All of it+import Module           ( Module, ModuleSet, elemModuleSet )+import CoreSubst+import CoreOpt          ( exprIsLambda_maybe )+import CoreFVs          ( exprFreeVars, exprsFreeVars, bindFreeVars+                        , rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList )+import CoreUtils        ( exprType, eqExpr, mkTick, mkTicks,+                          stripTicksTopT, stripTicksTopE,+                          isJoinBind )+import PprCore          ( pprRules )+import Type             ( Type, substTy, mkTCvSubst )+import TcType           ( tcSplitTyConApp_maybe )+import TysWiredIn       ( anyTypeOfKind )+import Coercion+import CoreTidy         ( tidyRules )+import Id+import IdInfo           ( RuleInfo( RuleInfo ) )+import Var+import VarEnv+import VarSet+import Name             ( Name, NamedThing(..), nameIsLocalOrFrom )+import NameSet+import NameEnv+import UniqFM+import Unify            ( ruleMatchTyKiX )+import BasicTypes       ( Activation, CompilerPhase, isActive, pprRuleName )+import DynFlags         ( DynFlags )+import Outputable+import FastString+import Maybes+import Bag+import Util+import Data.List+import Data.Ord+import Control.Monad    ( guard )++{-+Note [Overall plumbing for rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* After the desugarer:+   - The ModGuts initially contains mg_rules :: [CoreRule] of+     locally-declared rules for imported Ids.+   - Locally-declared rules for locally-declared Ids are attached to+     the IdInfo for that Id.  See Note [Attach rules to local ids] in+     DsBinds++* TidyPgm strips off all the rules from local Ids and adds them to+  mg_rules, so that the ModGuts has *all* the locally-declared rules.++* The HomePackageTable contains a ModDetails for each home package+  module.  Each contains md_rules :: [CoreRule] of rules declared in+  that module.  The HomePackageTable grows as ghc --make does its+  up-sweep.  In batch mode (ghc -c), the HPT is empty; all imported modules+  are treated by the "external" route, discussed next, regardless of+  which package they come from.++* The ExternalPackageState has a single eps_rule_base :: RuleBase for+  Ids in other packages.  This RuleBase simply grow monotonically, as+  ghc --make compiles one module after another.++  During simplification, interface files may get demand-loaded,+  as the simplifier explores the unfoldings for Ids it has in+  its hand.  (Via an unsafePerformIO; the EPS is really a cache.)+  That in turn may make the EPS rule-base grow.  In contrast, the+  HPT never grows in this way.++* The result of all this is that during Core-to-Core optimisation+  there are four sources of rules:++    (a) Rules in the IdInfo of the Id they are a rule for.  These are+        easy: fast to look up, and if you apply a substitution then+        it'll be applied to the IdInfo as a matter of course.++    (b) Rules declared in this module for imported Ids, kept in the+        ModGuts. If you do a substitution, you'd better apply the+        substitution to these.  There are seldom many of these.++    (c) Rules declared in the HomePackageTable.  These never change.++    (d) Rules in the ExternalPackageTable. These can grow in response+        to lazy demand-loading of interfaces.++* At the moment (c) is carried in a reader-monad way by the CoreMonad.+  The HomePackageTable doesn't have a single RuleBase because technically+  we should only be able to "see" rules "below" this module; so we+  generate a RuleBase for (c) by combing rules from all the modules+  "below" us.  That's why we can't just select the home-package RuleBase+  from HscEnv.++  [NB: we are inconsistent here.  We should do the same for external+  packages, but we don't.  Same for type-class instances.]++* So in the outer simplifier loop, we combine (b-d) into a single+  RuleBase, reading+     (b) from the ModGuts,+     (c) from the CoreMonad, and+     (d) from its mutable variable+  [Of coures this means that we won't see new EPS rules that come in+  during a single simplifier iteration, but that probably does not+  matter.]+++************************************************************************+*                                                                      *+\subsection[specialisation-IdInfo]{Specialisation info about an @Id@}+*                                                                      *+************************************************************************++A @CoreRule@ holds details of one rule for an @Id@, which+includes its specialisations.++For example, if a rule for @f@ contains the mapping:+\begin{verbatim}+        forall a b d. [Type (List a), Type b, Var d]  ===>  f' a b+\end{verbatim}+then when we find an application of f to matching types, we simply replace+it by the matching RHS:+\begin{verbatim}+        f (List Int) Bool dict ===>  f' Int Bool+\end{verbatim}+All the stuff about how many dictionaries to discard, and what types+to apply the specialised function to, are handled by the fact that the+Rule contains a template for the result of the specialisation.++There is one more exciting case, which is dealt with in exactly the same+way.  If the specialised value is unboxed then it is lifted at its+definition site and unlifted at its uses.  For example:++        pi :: forall a. Num a => a++might have a specialisation++        [Int#] ===>  (case pi' of Lift pi# -> pi#)++where pi' :: Lift Int# is the specialised version of pi.+-}++mkRule :: Module -> Bool -> Bool -> RuleName -> Activation+       -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule+-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being+-- compiled. See also 'CoreSyn.CoreRule'+mkRule this_mod is_auto is_local name act fn bndrs args rhs+  = Rule { ru_name = name, ru_fn = fn, ru_act = act,+           ru_bndrs = bndrs, ru_args = args,+           ru_rhs = rhs,+           ru_rough = roughTopNames args,+           ru_origin = this_mod,+           ru_orphan = orph,+           ru_auto = is_auto, ru_local = is_local }+  where+        -- Compute orphanhood.  See Note [Orphans] in InstEnv+        -- A rule is an orphan only if none of the variables+        -- mentioned on its left-hand side are locally defined+    lhs_names = extendNameSet (exprsOrphNames args) fn++        -- Since rules get eventually attached to one of the free names+        -- from the definition when compiling the ABI hash, we should make+        -- it deterministic. This chooses the one with minimal OccName+        -- as opposed to uniq value.+    local_lhs_names = filterNameSet (nameIsLocalOrFrom this_mod) lhs_names+    orph = chooseOrphanAnchor local_lhs_names++--------------+roughTopNames :: [CoreExpr] -> [Maybe Name]+-- ^ Find the \"top\" free names of several expressions.+-- Such names are either:+--+-- 1. The function finally being applied to in an application chain+--    (if that name is a GlobalId: see "Var#globalvslocal"), or+--+-- 2. The 'TyCon' if the expression is a 'Type'+--+-- This is used for the fast-match-check for rules;+--      if the top names don't match, the rest can't+roughTopNames args = map roughTopName args++roughTopName :: CoreExpr -> Maybe Name+roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of+                               Just (tc,_) -> Just (getName tc)+                               Nothing     -> Nothing+roughTopName (Coercion _) = Nothing+roughTopName (App f _) = roughTopName f+roughTopName (Var f)   | isGlobalId f   -- Note [Care with roughTopName]+                       , isDataConWorkId f || idArity f > 0+                       = Just (idName f)+roughTopName (Tick t e) | tickishFloatable t+                        = roughTopName e+roughTopName _ = Nothing++ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool+-- ^ @ruleCantMatch tpl actual@ returns True only if @actual@+-- definitely can't match @tpl@ by instantiating @tpl@.+-- It's only a one-way match; unlike instance matching we+-- don't consider unification.+--+-- Notice that [_$_]+--      @ruleCantMatch [Nothing] [Just n2] = False@+--      Reason: a template variable can be instantiated by a constant+-- Also:+--      @ruleCantMatch [Just n1] [Nothing] = False@+--      Reason: a local variable @v@ in the actuals might [_$_]++ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as+ruleCantMatch (_       : ts) (_       : as) = ruleCantMatch ts as+ruleCantMatch _              _              = False++{-+Note [Care with roughTopName]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this+    module M where { x = a:b }+    module N where { ...f x...+                     RULE f (p:q) = ... }+You'd expect the rule to match, because the matcher can+look through the unfolding of 'x'.  So we must avoid roughTopName+returning 'M.x' for the call (f x), or else it'll say "can't match"+and we won't even try!!++However, suppose we have+         RULE g (M.h x) = ...+         foo = ...(g (M.k v))....+where k is a *function* exported by M.  We never really match+functions (lambdas) except by name, so in this case it seems like+a good idea to treat 'M.k' as a roughTopName of the call.+-}++pprRulesForUser :: DynFlags -> [CoreRule] -> SDoc+-- (a) tidy the rules+-- (b) sort them into order based on the rule name+-- (c) suppress uniques (unless -dppr-debug is on)+-- This combination makes the output stable so we can use in testing+-- It's here rather than in PprCore because it calls tidyRules+pprRulesForUser dflags rules+  = withPprStyle (defaultUserStyle dflags) $+    pprRules $+    sortBy (comparing ruleName) $+    tidyRules emptyTidyEnv rules++{-+************************************************************************+*                                                                      *+                RuleInfo: the rules in an IdInfo+*                                                                      *+************************************************************************+-}++-- | Make a 'RuleInfo' containing a number of 'CoreRule's, suitable+-- for putting into an 'IdInfo'+mkRuleInfo :: [CoreRule] -> RuleInfo+mkRuleInfo rules = RuleInfo rules (rulesFreeVarsDSet rules)++extendRuleInfo :: RuleInfo -> [CoreRule] -> RuleInfo+extendRuleInfo (RuleInfo rs1 fvs1) rs2+  = RuleInfo (rs2 ++ rs1) (rulesFreeVarsDSet rs2 `unionDVarSet` fvs1)++addRuleInfo :: RuleInfo -> RuleInfo -> RuleInfo+addRuleInfo (RuleInfo rs1 fvs1) (RuleInfo rs2 fvs2)+  = RuleInfo (rs1 ++ rs2) (fvs1 `unionDVarSet` fvs2)++addIdSpecialisations :: Id -> [CoreRule] -> Id+addIdSpecialisations id []+  = id+addIdSpecialisations id rules+  = setIdSpecialisation id $+    extendRuleInfo (idSpecialisation id) rules++-- | Gather all the rules for locally bound identifiers from the supplied bindings+rulesOfBinds :: [CoreBind] -> [CoreRule]+rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds++getRules :: RuleEnv -> Id -> [CoreRule]+-- See Note [Where rules are found]+getRules (RuleEnv { re_base = rule_base, re_visible_orphs = orphs }) fn+  = idCoreRules fn ++ filter (ruleIsVisible orphs) imp_rules+  where+    imp_rules = lookupNameEnv rule_base (idName fn) `orElse` []++ruleIsVisible :: ModuleSet -> CoreRule -> Bool+ruleIsVisible _ BuiltinRule{} = True+ruleIsVisible vis_orphs Rule { ru_orphan = orph, ru_origin = origin }+    = notOrphan orph || origin `elemModuleSet` vis_orphs++{-+Note [Where rules are found]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The rules for an Id come from two places:+  (a) the ones it is born with, stored inside the Id iself (idCoreRules fn),+  (b) rules added in other modules, stored in the global RuleBase (imp_rules)++It's tempting to think that+     - LocalIds have only (a)+     - non-LocalIds have only (b)++but that isn't quite right:++     - PrimOps and ClassOps are born with a bunch of rules inside the Id,+       even when they are imported++     - The rules in PrelRules.builtinRules should be active even+       in the module defining the Id (when it's a LocalId), but+       the rules are kept in the global RuleBase+++************************************************************************+*                                                                      *+                RuleBase+*                                                                      *+************************************************************************+-}++-- RuleBase itself is defined in CoreSyn, along with CoreRule++emptyRuleBase :: RuleBase+emptyRuleBase = emptyNameEnv++mkRuleBase :: [CoreRule] -> RuleBase+mkRuleBase rules = extendRuleBaseList emptyRuleBase rules++extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase+extendRuleBaseList rule_base new_guys+  = foldl extendRuleBase rule_base new_guys++unionRuleBase :: RuleBase -> RuleBase -> RuleBase+unionRuleBase rb1 rb2 = plusNameEnv_C (++) rb1 rb2++extendRuleBase :: RuleBase -> CoreRule -> RuleBase+extendRuleBase rule_base rule+  = extendNameEnv_Acc (:) singleton rule_base (ruleIdName rule) rule++pprRuleBase :: RuleBase -> SDoc+pprRuleBase rules = pprUFM rules $ \rss ->+  vcat [ pprRules (tidyRules emptyTidyEnv rs)+       | rs <- rss ]++{-+************************************************************************+*                                                                      *+                        Matching+*                                                                      *+************************************************************************+-}++-- | The main rule matching function. Attempts to apply all (active)+-- supplied rules to this instance of an application in a given+-- context, returning the rule applied and the resulting expression if+-- successful.+lookupRule :: DynFlags -> InScopeEnv+           -> (Activation -> Bool)      -- When rule is active+           -> Id -> [CoreExpr]+           -> [CoreRule] -> Maybe (CoreRule, CoreExpr)++-- See Note [Extra args in rule matching]+-- See comments on matchRule+lookupRule dflags in_scope is_active fn args rules+  = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $+    case go [] rules of+        []     -> Nothing+        (m:ms) -> Just (findBest (fn,args') m ms)+  where+    rough_args = map roughTopName args++    -- Strip ticks from arguments, see note [Tick annotations in RULE+    -- matching]. We only collect ticks if a rule actually matches -+    -- this matters for performance tests.+    args' = map (stripTicksTopE tickishFloatable) args+    ticks = concatMap (stripTicksTopT tickishFloatable) args++    go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)]+    go ms [] = ms+    go ms (r:rs)+      | Just e <- matchRule dflags in_scope is_active fn args' rough_args r+      = go ((r,mkTicks ticks e):ms) rs+      | otherwise+      = -- pprTrace "match failed" (ppr r $$ ppr args $$+        --   ppr [ (arg_id, unfoldingTemplate unf)+        --       | Var arg_id <- args+        --       , let unf = idUnfolding arg_id+        --       , isCheapUnfolding unf] )+        go ms rs++findBest :: (Id, [CoreExpr])+         -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr)+-- All these pairs matched the expression+-- Return the pair the the most specific rule+-- The (fn,args) is just for overlap reporting++findBest _      (rule,ans)   [] = (rule,ans)+findBest target (rule1,ans1) ((rule2,ans2):prs)+  | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs+  | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs+  | debugIsOn = let pp_rule rule = sdocWithPprDebug $ \dbg -> if dbg+                        then ppr rule+                        else doubleQuotes (ftext (ruleName rule))+                in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)"+                         (vcat [ sdocWithPprDebug $ \dbg -> if dbg+                                   then text "Expression to match:" <+> ppr fn+                                        <+> sep (map ppr args)+                                   else empty+                               , text "Rule 1:" <+> pp_rule rule1+                               , text "Rule 2:" <+> pp_rule rule2]) $+                findBest target (rule1,ans1) prs+  | otherwise = findBest target (rule1,ans1) prs+  where+    (fn,args) = target++isMoreSpecific :: CoreRule -> CoreRule -> Bool+-- This tests if one rule is more specific than another+-- We take the view that a BuiltinRule is less specific than+-- anything else, because we want user-define rules to "win"+-- In particular, class ops have a built-in rule, but we+-- any user-specific rules to win+--   eg (Trac #4397)+--      truncate :: (RealFrac a, Integral b) => a -> b+--      {-# RULES "truncate/Double->Int" truncate = double2Int #-}+--      double2Int :: Double -> Int+--   We want the specific RULE to beat the built-in class-op rule+isMoreSpecific (BuiltinRule {}) _                = False+isMoreSpecific (Rule {})        (BuiltinRule {}) = True+isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 })+               (Rule { ru_bndrs = bndrs2, ru_args = args2, ru_name = rule_name2 })+  = isJust (matchN (in_scope, id_unfolding_fun) rule_name2 bndrs2 args2 args1)+  where+   id_unfolding_fun _ = NoUnfolding     -- Don't expand in templates+   in_scope = mkInScopeSet (mkVarSet bndrs1)+        -- Actually we should probably include the free vars+        -- of rule1's args, but I can't be bothered++noBlackList :: Activation -> Bool+noBlackList _ = False           -- Nothing is black listed++{-+Note [Extra args in rule matching]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we find a matching rule, we return (Just (rule, rhs)),+but the rule firing has only consumed as many of the input args+as the ruleArity says.  It's up to the caller to keep track+of any left-over args.  E.g. if you call+        lookupRule ... f [e1, e2, e3]+and it returns Just (r, rhs), where r has ruleArity 2+then the real rewrite is+        f e1 e2 e3 ==> rhs e3++You might think it'd be cleaner for lookupRule to deal with the+leftover arguments, by applying 'rhs' to them, but the main call+in the Simplifier works better as it is.  Reason: the 'args' passed+to lookupRule are the result of a lazy substitution+-}++------------------------------------+matchRule :: DynFlags -> InScopeEnv -> (Activation -> Bool)+          -> Id -> [CoreExpr] -> [Maybe Name]+          -> CoreRule -> Maybe CoreExpr++-- If (matchRule rule args) returns Just (name,rhs)+-- then (f args) matches the rule, and the corresponding+-- rewritten RHS is rhs+--+-- The returned expression is occurrence-analysed+--+--      Example+--+-- The rule+--      forall f g x. map f (map g x) ==> map (f . g) x+-- is stored+--      CoreRule "map/map"+--               [f,g,x]                -- tpl_vars+--               [f,map g x]            -- tpl_args+--               map (f.g) x)           -- rhs+--+-- Then the call: matchRule the_rule [e1,map e2 e3]+--        = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3)+--+-- Any 'surplus' arguments in the input are simply put on the end+-- of the output.++matchRule dflags rule_env _is_active fn args _rough_args+          (BuiltinRule { ru_try = match_fn })+-- Built-in rules can't be switched off, it seems+  = case match_fn dflags rule_env fn args of+        Nothing   -> Nothing+        Just expr -> Just expr++matchRule _ in_scope is_active _ args rough_args+          (Rule { ru_name = rule_name, ru_act = act, ru_rough = tpl_tops+                , ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs })+  | not (is_active act)               = Nothing+  | ruleCantMatch tpl_tops rough_args = Nothing+  | otherwise+  = case matchN in_scope rule_name tpl_vars tpl_args args of+        Nothing                        -> Nothing+        Just (bind_wrapper, tpl_vals) -> Just (bind_wrapper $+                                               rule_fn `mkApps` tpl_vals)+  where+    rule_fn = mkLams tpl_vars rhs++---------------------------------------+matchN  :: InScopeEnv+        -> RuleName -> [Var] -> [CoreExpr]+        -> [CoreExpr]           -- ^ Target; can have more elements than the template+        -> Maybe (BindWrapper,  -- Floated bindings; see Note [Matching lets]+                  [CoreExpr])+-- For a given match template and context, find bindings to wrap around+-- the entire result and what should be substituted for each template variable.+-- Fail if there are two few actual arguments from the target to match the template++matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es+  = do  { subst <- go init_menv emptyRuleSubst tmpl_es target_es+        ; let (_, matched_es) = mapAccumL lookup_tmpl subst tmpl_vars+        ; return (rs_binds subst, matched_es) }+  where+    init_rn_env = mkRnEnv2 (extendInScopeSetList in_scope tmpl_vars)+                  -- See Note [Template binders]++    init_menv = RV { rv_tmpls = mkVarSet tmpl_vars, rv_lcl = init_rn_env+                   , rv_fltR = mkEmptySubst (rnInScopeSet init_rn_env)+                   , rv_unf = id_unf }++    go _    subst []     _      = Just subst+    go _    _     _      []     = Nothing       -- Fail if too few actual args+    go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e+                                     ; go menv subst1 ts es }++    lookup_tmpl :: RuleSubst -> Var -> (RuleSubst, CoreExpr)+    lookup_tmpl rs@(RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) tmpl_var+        | isId tmpl_var+        = case lookupVarEnv id_subst tmpl_var of+             Just e -> (rs, e)+             Nothing | Just refl_co <- isReflCoVar_maybe tmpl_var+                     , let co_expr = Coercion refl_co+                     -> (rs { rs_id_subst = extendVarEnv id_subst tmpl_var co_expr }, co_expr)+                     | otherwise+                     -> unbound tmpl_var+        | otherwise+        = case lookupVarEnv tv_subst tmpl_var of+             Just ty -> (rs, Type ty)+             Nothing -> (rs { rs_tv_subst = extendVarEnv tv_subst tmpl_var fake_ty }, Type fake_ty)+                        -- See Note [Unbound RULE binders]+        where+          fake_ty = anyTypeOfKind kind+          cv_subst = to_co_env id_subst+          kind = Type.substTy (mkTCvSubst in_scope (tv_subst, cv_subst))+                              (tyVarKind tmpl_var)++          to_co_env env = nonDetFoldUFM_Directly to_co emptyVarEnv env+            -- It's OK to use nonDetFoldUFM_Directly because we forget the+            -- order immediately by creating a new env+          to_co uniq expr env+            | Just co <- exprToCoercion_maybe expr+            = extendVarEnv_Directly env uniq co++            | otherwise+            = env++    unbound var = pprPanic "Template variable unbound in rewrite rule" $+                  vcat [ text "Variable:" <+> ppr var+                       , text "Rule" <+> pprRuleName rule_name+                       , text "Rule bndrs:" <+> ppr tmpl_vars+                       , text "LHS args:" <+> ppr tmpl_es+                       , text "Actual args:" <+> ppr target_es ]++{- Note [Unbound RULE binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It can be the case that the binder in a rule is not actually+bound on the LHS:++* Type variables.  Type synonyms with phantom args can give rise to+  unbound template type variables.  Consider this (Trac #10689,+  simplCore/should_compile/T10689):++    type Foo a b = b++    f :: Eq a => a -> Bool+    f x = x==x++    {-# RULES "foo" forall (x :: Foo a Char). f x = True #-}+    finkle = f 'c'++  The rule looks like+    forall (a::*) (d::Eq Char) (x :: Foo a Char).+         f (Foo a Char) d x = True++  Matching the rule won't bind 'a', and legitimately so.  We fudge by+  pretending that 'a' is bound to (Any :: *).++* Coercion variables.  On the LHS of a RULE for a local binder+  we might have+    RULE forall (c :: a~b). f (x |> c) = e+  Now, if that binding is inlined, so that a=b=Int, we'd get+    RULE forall (c :: Int~Int). f (x |> c) = e+  and now when we simpilfy the LHS (Simplify.simplRule) we+  optCoercion will turn that 'c' into Refl:+    RULE forall (c :: Int~Int). f (x |> <Int>) = e+  and then perhaps drop it altogether.  Now 'c' is unbound.++  It's tricky to be sure this never happens, so instead I+  say it's OK to have an unbound coercion binder in a RULE+  provided its type is (c :: t~t).  Then, when the RULE+  fires we can substitute <t> for c.++  This actually happened (in a RULE for a local function)+  in Trac #13410, and also in test T10602.+++Note [Template binders]+~~~~~~~~~~~~~~~~~~~~~~~+Consider the following match (example 1):+        Template:  forall x.  f x+        Target:               f (x+1)+This should succeed, because the template variable 'x' has nothing to+do with the 'x' in the target.++Likewise this one (example 2):+        Template:  forall x. f (\x.x)+        Target:              f (\y.y)++We achieve this simply by:+  * Adding forall'd template binders to the in-scope set++This works even if the template binder are already in scope+(in the target) because++  * The RuleSubst rs_tv_subst, rs_id_subst maps LHS template vars to+    the target world.  It is not applied recursively.++  * Having the template vars in the in-scope set ensures that in+    example 2 above, the (\x.x) is cloned to (\x'. x').++In the past we used rnBndrL to clone the template variables if+they were already in scope.  But (a) that's not necessary and (b)+it complicate the fancy footwork for Note [Unbound template type variables]+++************************************************************************+*                                                                      *+                   The main matcher+*                                                                      *+********************************************************************* -}++-- * The domain of the TvSubstEnv and IdSubstEnv are the template+--   variables passed into the match.+--+-- * The BindWrapper in a RuleSubst are the bindings floated out+--   from nested matches; see the Let case of match, below+--+data RuleMatchEnv+  = RV { rv_tmpls :: VarSet          -- Template variables+       , rv_lcl   :: RnEnv2          -- Renamings for *local bindings*+                                     --   (lambda/case)+       , rv_fltR  :: Subst           -- Renamings for floated let-bindings+                                     --   domain disjoint from envR of rv_lcl+                                     -- See Note [Matching lets]+       , rv_unf :: IdUnfoldingFun+       }++rvInScopeEnv :: RuleMatchEnv -> InScopeEnv+rvInScopeEnv renv = (rnInScopeSet (rv_lcl renv), rv_unf renv)++data RuleSubst = RS { rs_tv_subst :: TvSubstEnv   -- Range is the+                    , rs_id_subst :: IdSubstEnv   --   template variables+                    , rs_binds    :: BindWrapper  -- Floated bindings+                    , rs_bndrs    :: VarSet       -- Variables bound by floated lets+                    }++type BindWrapper = CoreExpr -> CoreExpr+  -- See Notes [Matching lets] and [Matching cases]+  -- we represent the floated bindings as a core-to-core function++emptyRuleSubst :: RuleSubst+emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv+                    , rs_binds = \e -> e, rs_bndrs = emptyVarSet }++--      At one stage I tried to match even if there are more+--      template args than real args.++--      I now think this is probably a bad idea.+--      Should the template (map f xs) match (map g)?  I think not.+--      For a start, in general eta expansion wastes work.+--      SLPJ July 99+++match :: RuleMatchEnv+      -> RuleSubst+      -> CoreExpr               -- Template+      -> CoreExpr               -- Target+      -> Maybe RuleSubst++-- We look through certain ticks. See note [Tick annotations in RULE matching]+match renv subst e1 (Tick t e2)+  | tickishFloatable t+  = match renv subst' e1 e2+  where subst' = subst { rs_binds = rs_binds subst . mkTick t }+match _ _ e@Tick{} _+  = pprPanic "Tick in rule" (ppr e)++-- See the notes with Unify.match, which matches types+-- Everything is very similar for terms++-- Interesting examples:+-- Consider matching+--      \x->f      against    \f->f+-- When we meet the lambdas we must remember to rename f to f' in the+-- second expression.  The RnEnv2 does that.+--+-- Consider matching+--      forall a. \b->b    against   \a->3+-- We must rename the \a.  Otherwise when we meet the lambdas we+-- might substitute [a/b] in the template, and then erroneously+-- succeed in matching what looks like the template variable 'a' against 3.++-- The Var case follows closely what happens in Unify.match+match renv subst (Var v1)    e2 = match_var renv subst v1 e2++match renv subst e1 (Var v2)      -- Note [Expanding variables]+  | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables]+  , Just e2' <- expandUnfolding_maybe (rv_unf renv v2')+  = match (renv { rv_lcl = nukeRnEnvR rn_env }) subst e1 e2'+  where+    v2'    = lookupRnInScope rn_env v2+    rn_env = rv_lcl renv+        -- Notice that we look up v2 in the in-scope set+        -- See Note [Lookup in-scope]+        -- No need to apply any renaming first (hence no rnOccR)+        -- because of the not-inRnEnvR++match renv subst e1 (Let bind e2)+  | -- pprTrace "match:Let" (vcat [ppr bind, ppr $ okToFloat (rv_lcl renv) (bindFreeVars bind)]) $+    not (isJoinBind bind) -- can't float join point out of argument position+  , okToFloat (rv_lcl renv) (bindFreeVars bind) -- See Note [Matching lets]+  = match (renv { rv_fltR = flt_subst' })+          (subst { rs_binds = rs_binds subst . Let bind'+                 , rs_bndrs = extendVarSetList (rs_bndrs subst) new_bndrs })+          e1 e2+  where+    flt_subst = addInScopeSet (rv_fltR renv) (rs_bndrs subst)+    (flt_subst', bind') = substBind flt_subst bind+    new_bndrs = bindersOf bind'++{- Disabled: see Note [Matching cases] below+match renv (tv_subst, id_subst, binds) e1+      (Case scrut case_bndr ty [(con, alt_bndrs, rhs)])+  | exprOkForSpeculation scrut  -- See Note [Matching cases]+  , okToFloat rn_env bndrs (exprFreeVars scrut)+  = match (renv { me_env = rn_env' })+          (tv_subst, id_subst, binds . case_wrap)+          e1 rhs+  where+    rn_env   = me_env renv+    rn_env'  = extendRnInScopeList rn_env bndrs+    bndrs    = case_bndr : alt_bndrs+    case_wrap rhs' = Case scrut case_bndr ty [(con, alt_bndrs, rhs')]+-}++match _ subst (Lit lit1) (Lit lit2)+  | lit1 == lit2+  = Just subst++match renv subst (App f1 a1) (App f2 a2)+  = do  { subst' <- match renv subst f1 f2+        ; match renv subst' a1 a2 }++match renv subst (Lam x1 e1) e2+  | Just (x2, e2, ts) <- exprIsLambda_maybe (rvInScopeEnv renv) e2+  = let renv' = renv { rv_lcl = rnBndr2 (rv_lcl renv) x1 x2+                     , rv_fltR = delBndr (rv_fltR renv) x2 }+        subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts }+    in  match renv' subst' e1 e2++match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)+  = do  { subst1 <- match_ty renv subst ty1 ty2+        ; subst2 <- match renv subst1 e1 e2+        ; let renv' = rnMatchBndr2 renv subst x1 x2+        ; match_alts renv' subst2 alts1 alts2   -- Alts are both sorted+        }++match renv subst (Type ty1) (Type ty2)+  = match_ty renv subst ty1 ty2+match renv subst (Coercion co1) (Coercion co2)+  = match_co renv subst co1 co2++match renv subst (Cast e1 co1) (Cast e2 co2)+  = do  { subst1 <- match_co renv subst co1 co2+        ; match renv subst1 e1 e2 }++-- Everything else fails+match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $+                    Nothing++-------------+match_co :: RuleMatchEnv+         -> RuleSubst+         -> Coercion+         -> Coercion+         -> Maybe RuleSubst+match_co renv subst co1 co2+  | Just cv <- getCoVar_maybe co1+  = match_var renv subst cv (Coercion co2)+  | Just (ty1, r1) <- isReflCo_maybe co1+  = do { (ty2, r2) <- isReflCo_maybe co2+       ; guard (r1 == r2)+       ; match_ty renv subst ty1 ty2 }+match_co renv subst co1 co2+  | Just (tc1, cos1) <- splitTyConAppCo_maybe co1+  = case splitTyConAppCo_maybe co2 of+      Just (tc2, cos2)+        |  tc1 == tc2+        -> match_cos renv subst cos1 cos2+      _ -> Nothing+match_co renv subst co1 co2+  | Just (arg1, res1) <- splitFunCo_maybe co1+  = case splitFunCo_maybe co2 of+      Just (arg2, res2)+        -> match_cos renv subst [arg1, res1] [arg2, res2]+      _ -> Nothing+match_co _ _ _co1 _co2+    -- Currently just deals with CoVarCo, TyConAppCo and Refl+#ifdef DEBUG+  = pprTrace "match_co: needs more cases" (ppr _co1 $$ ppr _co2) Nothing+#else+  = Nothing+#endif++match_cos :: RuleMatchEnv+         -> RuleSubst+         -> [Coercion]+         -> [Coercion]+         -> Maybe RuleSubst+match_cos renv subst (co1:cos1) (co2:cos2) =+  do { subst' <- match_co renv subst co1 co2+     ; match_cos renv subst' cos1 cos2 }+match_cos _ subst [] [] = Just subst+match_cos _ _ cos1 cos2 = pprTrace "match_cos: not same length" (ppr cos1 $$ ppr cos2) Nothing++-------------+rnMatchBndr2 :: RuleMatchEnv -> RuleSubst -> Var -> Var -> RuleMatchEnv+rnMatchBndr2 renv subst x1 x2+  = renv { rv_lcl  = rnBndr2 rn_env x1 x2+         , rv_fltR = delBndr (rv_fltR renv) x2 }+  where+    rn_env = addRnInScopeSet (rv_lcl renv) (rs_bndrs subst)+    -- Typically this is a no-op, but it may matter if+    -- there are some floated let-bindings++------------------------------------------+match_alts :: RuleMatchEnv+           -> RuleSubst+           -> [CoreAlt]         -- Template+           -> [CoreAlt]         -- Target+           -> Maybe RuleSubst+match_alts _ subst [] []+  = return subst+match_alts renv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2)+  | c1 == c2+  = do  { subst1 <- match renv' subst r1 r2+        ; match_alts renv subst1 alts1 alts2 }+  where+    renv' = foldl mb renv (vs1 `zip` vs2)+    mb renv (v1,v2) = rnMatchBndr2 renv subst v1 v2++match_alts _ _ _ _+  = Nothing++------------------------------------------+okToFloat :: RnEnv2 -> VarSet -> Bool+okToFloat rn_env bind_fvs+  = allVarSet not_captured bind_fvs+  where+    not_captured fv = not (inRnEnvR rn_env fv)++------------------------------------------+match_var :: RuleMatchEnv+          -> RuleSubst+          -> Var                -- Template+          -> CoreExpr        -- Target+          -> Maybe RuleSubst+match_var renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env, rv_fltR = flt_env })+          subst v1 e2+  | v1' `elemVarSet` tmpls+  = match_tmpl_var renv subst v1' e2++  | otherwise   -- v1' is not a template variable; check for an exact match with e2+  = case e2 of  -- Remember, envR of rn_env is disjoint from rv_fltR+       Var v2 | v1' == rnOccR rn_env v2+              -> Just subst++              | Var v2' <- lookupIdSubst (text "match_var") flt_env v2+              , v1' == v2'+              -> Just subst++       _ -> Nothing++  where+    v1' = rnOccL rn_env v1+        -- If the template is+        --      forall x. f x (\x -> x) = ...+        -- Then the x inside the lambda isn't the+        -- template x, so we must rename first!++------------------------------------------+match_tmpl_var :: RuleMatchEnv+               -> RuleSubst+               -> Var                -- Template+               -> CoreExpr              -- Target+               -> Maybe RuleSubst++match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env })+               subst@(RS { rs_id_subst = id_subst, rs_bndrs = let_bndrs })+               v1' e2+  | any (inRnEnvR rn_env) (exprFreeVarsList e2)+  = Nothing     -- Occurs check failure+                -- e.g. match forall a. (\x-> a x) against (\y. y y)++  | Just e1' <- lookupVarEnv id_subst v1'+  = if eqExpr (rnInScopeSet rn_env) e1' e2'+    then Just subst+    else Nothing++  | otherwise+  =             -- Note [Matching variable types]+                -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+                -- However, we must match the *types*; e.g.+                --   forall (c::Char->Int) (x::Char).+                --      f (c x) = "RULE FIRED"+                -- We must only match on args that have the right type+                -- It's actually quite difficult to come up with an example that shows+                -- you need type matching, esp since matching is left-to-right, so type+                -- args get matched first.  But it's possible (e.g. simplrun008) and+                -- this is the Right Thing to do+    do { subst' <- match_ty renv subst (idType v1') (exprType e2)+       ; return (subst' { rs_id_subst = id_subst' }) }+  where+    -- e2' is the result of applying flt_env to e2+    e2' | isEmptyVarSet let_bndrs = e2+        | otherwise = substExpr (text "match_tmpl_var") flt_env e2++    id_subst' = extendVarEnv (rs_id_subst subst) v1' e2'+         -- No further renaming to do on e2',+         -- because no free var of e2' is in the rnEnvR of the envt++------------------------------------------+match_ty :: RuleMatchEnv+         -> RuleSubst+         -> Type                -- Template+         -> Type                -- Target+         -> Maybe RuleSubst+-- Matching Core types: use the matcher in TcType.+-- Notice that we treat newtypes as opaque.  For example, suppose+-- we have a specialised version of a function at a newtype, say+--      newtype T = MkT Int+-- We only want to replace (f T) with f', not (f Int).++match_ty renv subst ty1 ty2+  = do  { tv_subst'+            <- Unify.ruleMatchTyKiX (rv_tmpls renv) (rv_lcl renv) tv_subst ty1 ty2+        ; return (subst { rs_tv_subst = tv_subst' }) }+  where+    tv_subst = rs_tv_subst subst++{-+Note [Expanding variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is another Very Important rule: if the term being matched is a+variable, we expand it so long as its unfolding is "expandable". (Its+occurrence information is not necessarily up to date, so we don't use+it.)  By "expandable" we mean a WHNF or a "constructor-like" application.+This is the key reason for "constructor-like" Ids.  If we have+     {-# NOINLINE [1] CONLIKE g #-}+     {-# RULE f (g x) = h x #-}+then in the term+   let v = g 3 in ....(f v)....+we want to make the rule fire, to replace (f v) with (h 3).++Note [Do not expand locally-bound variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Do *not* expand locally-bound variables, else there's a worry that the+unfolding might mention variables that are themselves renamed.+Example+          case x of y { (p,q) -> ...y... }+Don't expand 'y' to (p,q) because p,q might themselves have been+renamed.  Essentially we only expand unfoldings that are "outside"+the entire match.++Hence, (a) the guard (not (isLocallyBoundR v2))+       (b) when we expand we nuke the renaming envt (nukeRnEnvR).++Note [Tick annotations in RULE matching]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We used to unconditionally look through Notes in both template and+expression being matched. This is actually illegal for counting or+cost-centre-scoped ticks, because we have no place to put them without+changing entry counts and/or costs. So now we just fail the match in+these cases.++On the other hand, where we are allowed to insert new cost into the+tick scope, we can float them upwards to the rule application site.++cf Note [Notes in call patterns] in SpecConstr++Note [Matching lets]+~~~~~~~~~~~~~~~~~~~~+Matching a let-expression.  Consider+        RULE forall x.  f (g x) = <rhs>+and target expression+        f (let { w=R } in g E))+Then we'd like the rule to match, to generate+        let { w=R } in (\x. <rhs>) E+In effect, we want to float the let-binding outward, to enable+the match to happen.  This is the WHOLE REASON for accumulating+bindings in the RuleSubst++We can only do this if the free variables of R are not bound by the+part of the target expression outside the let binding; e.g.+        f (\v. let w = v+1 in g E)+Here we obviously cannot float the let-binding for w.  Hence the+use of okToFloat.++There are a couple of tricky points.+  (a) What if floating the binding captures a variable?+        f (let v = x+1 in v) v+      --> NOT!+        let v = x+1 in f (x+1) v++  (b) What if two non-nested let bindings bind the same variable?+        f (let v = e1 in b1) (let v = e2 in b2)+      --> NOT!+        let v = e1 in let v = e2 in (f b2 b2)+      See testsuite test "RuleFloatLet".++Our cunning plan is this:+  * Along with the growing substitution for template variables+    we maintain a growing set of floated let-bindings (rs_binds)+    plus the set of variables thus bound.++  * The RnEnv2 in the MatchEnv binds only the local binders+    in the term (lambdas, case)++  * When we encounter a let in the term to be matched, we+    check that does not mention any locally bound (lambda, case)+    variables.  If so we fail++  * We use CoreSubst.substBind to freshen the binding, using an+    in-scope set that is the original in-scope variables plus the+    rs_bndrs (currently floated let-bindings).  So in (a) above+    we'll freshen the 'v' binding; in (b) above we'll freshen+    the *second* 'v' binding.++  * We apply that freshening substitution, in a lexically-scoped+    way to the term, although lazily; this is the rv_fltR field.+++Note [Matching cases]+~~~~~~~~~~~~~~~~~~~~~+{- NOTE: This idea is currently disabled.  It really only works if+         the primops involved are OkForSpeculation, and, since+         they have side effects readIntOfAddr and touch are not.+         Maybe we'll get back to this later .  -}++Consider+   f (case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) ->+      case touch# fp s# of { _ ->+      I# n# } } )+This happened in a tight loop generated by stream fusion that+Roman encountered.  We'd like to treat this just like the let+case, because the primops concerned are ok-for-speculation.+That is, we'd like to behave as if it had been+   case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) ->+   case touch# fp s# of { _ ->+   f (I# n# } } )++Note [Lookup in-scope]+~~~~~~~~~~~~~~~~~~~~~~+Consider this example+        foo :: Int -> Maybe Int -> Int+        foo 0 (Just n) = n+        foo m (Just n) = foo (m-n) (Just n)++SpecConstr sees this fragment:++        case w_smT of wild_Xf [Just A] {+          Data.Maybe.Nothing -> lvl_smf;+          Data.Maybe.Just n_acT [Just S(L)] ->+            case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] ->+            \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf+            }};++and correctly generates the rule++        RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int#+                                          sc_snn :: GHC.Prim.Int#}+          \$wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr))+          = \$s\$wfoo_sno y_amr sc_snn ;]++BUT we must ensure that this rule matches in the original function!+Note that the call to \$wfoo is+            \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf++During matching we expand wild_Xf to (Just n_acT).  But then we must also+expand n_acT to (I# y_amr).  And we can only do that if we look up n_acT+in the in-scope set, because in wild_Xf's unfolding it won't have an unfolding+at all.++That is why the 'lookupRnInScope' call in the (Var v2) case of 'match'+is so important.+++************************************************************************+*                                                                      *+                   Rule-check the program+*                                                                      *+************************************************************************++   We want to know what sites have rules that could have fired but didn't.+   This pass runs over the tree (without changing it) and reports such.+-}++-- | Report partial matches for rules beginning with the specified+-- string for the purposes of error reporting+ruleCheckProgram :: CompilerPhase               -- ^ Rule activation test+                 -> String                      -- ^ Rule pattern+                 -> RuleEnv                     -- ^ Database of rules+                 -> CoreProgram                 -- ^ Bindings to check in+                 -> SDoc                        -- ^ Resulting check message+ruleCheckProgram phase rule_pat rule_base binds+  | isEmptyBag results+  = text "Rule check results: no rule application sites"+  | otherwise+  = vcat [text "Rule check results:",+          line,+          vcat [ p $$ line | p <- bagToList results ]+         ]+  where+    env = RuleCheckEnv { rc_is_active = isActive phase+                       , rc_id_unf    = idUnfolding     -- Not quite right+                                                        -- Should use activeUnfolding+                       , rc_pattern   = rule_pat+                       , rc_rule_base = rule_base }+    results = unionManyBags (map (ruleCheckBind env) binds)+    line = text (replicate 20 '-')++data RuleCheckEnv = RuleCheckEnv {+    rc_is_active :: Activation -> Bool,+    rc_id_unf  :: IdUnfoldingFun,+    rc_pattern :: String,+    rc_rule_base :: RuleEnv+}++ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc+   -- The Bag returned has one SDoc for each call site found+ruleCheckBind env (NonRec _ r) = ruleCheck env r+ruleCheckBind env (Rec prs)    = unionManyBags [ruleCheck env r | (_,r) <- prs]++ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc+ruleCheck _   (Var _)       = emptyBag+ruleCheck _   (Lit _)       = emptyBag+ruleCheck _   (Type _)      = emptyBag+ruleCheck _   (Coercion _)  = emptyBag+ruleCheck env (App f a)     = ruleCheckApp env (App f a) []+ruleCheck env (Tick _ e)  = ruleCheck env e+ruleCheck env (Cast e _)    = ruleCheck env e+ruleCheck env (Let bd e)    = ruleCheckBind env bd `unionBags` ruleCheck env e+ruleCheck env (Lam _ e)     = ruleCheck env e+ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags`+                                unionManyBags [ruleCheck env r | (_,_,r) <- as]++ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc+ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)+ruleCheckApp env (Var f) as   = ruleCheckFun env f as+ruleCheckApp env other _      = ruleCheck env other++ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc+-- Produce a report for all rules matching the predicate+-- saying why it doesn't match the specified application++ruleCheckFun env fn args+  | null name_match_rules = emptyBag+  | otherwise             = unitBag (ruleAppCheck_help env fn args name_match_rules)+  where+    name_match_rules = filter match (getRules (rc_rule_base env) fn)+    match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule)++ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc+ruleAppCheck_help env fn args rules+  =     -- The rules match the pattern, so we want to print something+    vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),+          vcat (map check_rule rules)]+  where+    n_args = length args+    i_args = args `zip` [1::Int ..]+    rough_args = map roughTopName args++    check_rule rule = sdocWithDynFlags $ \dflags ->+                      rule_herald rule <> colon <+> rule_info dflags rule++    rule_herald (BuiltinRule { ru_name = name })+        = text "Builtin rule" <+> doubleQuotes (ftext name)+    rule_herald (Rule { ru_name = name })+        = text "Rule" <+> doubleQuotes (ftext name)++    rule_info dflags rule+        | Just _ <- matchRule dflags (emptyInScopeSet, rc_id_unf env)+                              noBlackList fn args rough_args rule+        = text "matches (which is very peculiar!)"++    rule_info _ (BuiltinRule {}) = text "does not match"++    rule_info _ (Rule { ru_act = act,+                        ru_bndrs = rule_bndrs, ru_args = rule_args})+        | not (rc_is_active env act)  = text "active only in later phase"+        | n_args < n_rule_args        = text "too few arguments"+        | n_mismatches == n_rule_args = text "no arguments match"+        | n_mismatches == 0           = text "all arguments match (considered individually), but rule as a whole does not"+        | otherwise                   = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)"+        where+          n_rule_args  = length rule_args+          n_mismatches = length mismatches+          mismatches   = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,+                              not (isJust (match_fn rule_arg arg))]++          lhs_fvs = exprsFreeVars rule_args     -- Includes template tyvars+          match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg+                where+                  in_scope = mkInScopeSet (lhs_fvs `unionVarSet` exprFreeVars arg)+                  renv = RV { rv_lcl   = mkRnEnv2 in_scope+                            , rv_tmpls = mkVarSet rule_bndrs+                            , rv_fltR  = mkEmptySubst in_scope+                            , rv_unf   = rc_id_unf env }
+ specialise/SpecConstr.hs view
@@ -0,0 +1,2256 @@+{-+ToDo [Oct 2013]+~~~~~~~~~~~~~~~+1. Nuke ForceSpecConstr for good (it is subsumed by GHC.Types.SPEC in ghc-prim)+2. Nuke NoSpecConstr+++(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[SpecConstr]{Specialise over constructors}+-}++{-# LANGUAGE CPP #-}++module SpecConstr(+        specConstrProgram,+        SpecConstrAnnotation(..)+    ) where++#include "HsVersions.h"++import CoreSyn+import CoreSubst+import CoreUtils+import CoreUnfold       ( couldBeSmallEnoughToInline )+import CoreFVs          ( exprsFreeVarsList )+import CoreMonad+import Literal          ( litIsLifted )+import HscTypes         ( ModGuts(..) )+import WwLib            ( isWorkerSmallEnough, mkWorkerArgs )+import DataCon+import Coercion         hiding( substCo )+import Rules+import Type             hiding ( substTy )+import TyCon            ( tyConName )+import Id+import PprCore          ( pprParendExpr )+import MkCore           ( mkImpossibleExpr )+import Var+import VarEnv+import VarSet+import Name+import BasicTypes+import DynFlags         ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen )+                        , gopt, hasPprDebug )+import Maybes           ( orElse, catMaybes, isJust, isNothing )+import Demand+import GHC.Serialized   ( deserializeWithData )+import Util+import Pair+import UniqSupply+import Outputable+import FastString+import UniqFM+import MonadUtils+import Control.Monad    ( zipWithM )+import Data.List+import PrelNames        ( specTyConName )+import Module++-- See Note [Forcing specialisation]++import TyCon ( TyCon )+import GHC.Exts( SpecConstrAnnotation(..) )+import Data.Ord( comparing )++{-+-----------------------------------------------------+                        Game plan+-----------------------------------------------------++Consider+        drop n []     = []+        drop 0 xs     = []+        drop n (x:xs) = drop (n-1) xs++After the first time round, we could pass n unboxed.  This happens in+numerical code too.  Here's what it looks like in Core:++        drop n xs = case xs of+                      []     -> []+                      (y:ys) -> case n of+                                  I# n# -> case n# of+                                             0 -> []+                                             _ -> drop (I# (n# -# 1#)) xs++Notice that the recursive call has an explicit constructor as argument.+Noticing this, we can make a specialised version of drop++        RULE: drop (I# n#) xs ==> drop' n# xs++        drop' n# xs = let n = I# n# in ...orig RHS...++Now the simplifier will apply the specialisation in the rhs of drop', giving++        drop' n# xs = case xs of+                      []     -> []+                      (y:ys) -> case n# of+                                  0 -> []+                                  _ -> drop' (n# -# 1#) xs++Much better!++We'd also like to catch cases where a parameter is carried along unchanged,+but evaluated each time round the loop:++        f i n = if i>0 || i>n then i else f (i*2) n++Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.+In Core, by the time we've w/wd (f is strict in i) we get++        f i# n = case i# ># 0 of+                   False -> I# i#+                   True  -> case n of { I# n# ->+                            case i# ># n# of+                                False -> I# i#+                                True  -> f (i# *# 2#) n++At the call to f, we see that the argument, n is known to be (I# n#),+and n is evaluated elsewhere in the body of f, so we can play the same+trick as above.+++Note [Reboxing]+~~~~~~~~~~~~~~~+We must be careful not to allocate the same constructor twice.  Consider+        f p = (...(case p of (a,b) -> e)...p...,+               ...let t = (r,s) in ...t...(f t)...)+At the recursive call to f, we can see that t is a pair.  But we do NOT want+to make a specialised copy:+        f' a b = let p = (a,b) in (..., ...)+because now t is allocated by the caller, then r and s are passed to the+recursive call, which allocates the (r,s) pair again.++This happens if+  (a) the argument p is used in other than a case-scrutinisation way.+  (b) the argument to the call is not a 'fresh' tuple; you have to+        look into its unfolding to see that it's a tuple++Hence the "OR" part of Note [Good arguments] below.++ALTERNATIVE 2: pass both boxed and unboxed versions.  This no longer saves+allocation, but does perhaps save evals. In the RULE we'd have+something like++  f (I# x#) = f' (I# x#) x#++If at the call site the (I# x) was an unfolding, then we'd have to+rely on CSE to eliminate the duplicate allocation.... This alternative+doesn't look attractive enough to pursue.++ALTERNATIVE 3: ignore the reboxing problem.  The trouble is that+the conservative reboxing story prevents many useful functions from being+specialised.  Example:+        foo :: Maybe Int -> Int -> Int+        foo   (Just m) 0 = 0+        foo x@(Just m) n = foo x (n-m)+Here the use of 'x' will clearly not require boxing in the specialised function.++The strictness analyser has the same problem, in fact.  Example:+        f p@(a,b) = ...+If we pass just 'a' and 'b' to the worker, it might need to rebox the+pair to create (a,b).  A more sophisticated analysis might figure out+precisely the cases in which this could happen, but the strictness+analyser does no such analysis; it just passes 'a' and 'b', and hopes+for the best.++So my current choice is to make SpecConstr similarly aggressive, and+ignore the bad potential of reboxing.+++Note [Good arguments]+~~~~~~~~~~~~~~~~~~~~~+So we look for++* A self-recursive function.  Ignore mutual recursion for now,+  because it's less common, and the code is simpler for self-recursion.++* EITHER++   a) At a recursive call, one or more parameters is an explicit+      constructor application+        AND+      That same parameter is scrutinised by a case somewhere in+      the RHS of the function++  OR++    b) At a recursive call, one or more parameters has an unfolding+       that is an explicit constructor application+        AND+      That same parameter is scrutinised by a case somewhere in+      the RHS of the function+        AND+      Those are the only uses of the parameter (see Note [Reboxing])+++What to abstract over+~~~~~~~~~~~~~~~~~~~~~+There's a bit of a complication with type arguments.  If the call+site looks like++        f p = ...f ((:) [a] x xs)...++then our specialised function look like++        f_spec x xs = let p = (:) [a] x xs in ....as before....++This only makes sense if either+  a) the type variable 'a' is in scope at the top of f, or+  b) the type variable 'a' is an argument to f (and hence fs)++Actually, (a) may hold for value arguments too, in which case+we may not want to pass them.  Suppose 'x' is in scope at f's+defn, but xs is not.  Then we'd like++        f_spec xs = let p = (:) [a] x xs in ....as before....++Similarly (b) may hold too.  If x is already an argument at the+call, no need to pass it again.++Finally, if 'a' is not in scope at the call site, we could abstract+it as we do the term variables:++        f_spec a x xs = let p = (:) [a] x xs in ...as before...++So the grand plan is:++        * abstract the call site to a constructor-only pattern+          e.g.  C x (D (f p) (g q))  ==>  C s1 (D s2 s3)++        * Find the free variables of the abstracted pattern++        * Pass these variables, less any that are in scope at+          the fn defn.  But see Note [Shadowing] below.+++NOTICE that we only abstract over variables that are not in scope,+so we're in no danger of shadowing variables used in "higher up"+in f_spec's RHS.+++Note [Shadowing]+~~~~~~~~~~~~~~~~+In this pass we gather up usage information that may mention variables+that are bound between the usage site and the definition site; or (more+seriously) may be bound to something different at the definition site.+For example:++        f x = letrec g y v = let x = ...+                             in ...(g (a,b) x)...++Since 'x' is in scope at the call site, we may make a rewrite rule that+looks like+        RULE forall a,b. g (a,b) x = ...+But this rule will never match, because it's really a different 'x' at+the call site -- and that difference will be manifest by the time the+simplifier gets to it.  [A worry: the simplifier doesn't *guarantee*+no-shadowing, so perhaps it may not be distinct?]++Anyway, the rule isn't actually wrong, it's just not useful.  One possibility+is to run deShadowBinds before running SpecConstr, but instead we run the+simplifier.  That gives the simplest possible program for SpecConstr to+chew on; and it virtually guarantees no shadowing.++Note [Specialising for constant parameters]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This one is about specialising on a *constant* (but not necessarily+constructor) argument++    foo :: Int -> (Int -> Int) -> Int+    foo 0 f = 0+    foo m f = foo (f m) (+1)++It produces++    lvl_rmV :: GHC.Base.Int -> GHC.Base.Int+    lvl_rmV =+      \ (ds_dlk :: GHC.Base.Int) ->+        case ds_dlk of wild_alH { GHC.Base.I# x_alG ->+        GHC.Base.I# (GHC.Prim.+# x_alG 1)++    T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->+    GHC.Prim.Int#+    T.$wfoo =+      \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->+        case ww_sme of ds_Xlw {+          __DEFAULT ->+        case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->+        T.$wfoo ww1_Xmz lvl_rmV+        };+          0 -> 0+        }++The recursive call has lvl_rmV as its argument, so we could create a specialised copy+with that argument baked in; that is, not passed at all.   Now it can perhaps be inlined.++When is this worth it?  Call the constant 'lvl'+- If 'lvl' has an unfolding that is a constructor, see if the corresponding+  parameter is scrutinised anywhere in the body.++- If 'lvl' has an unfolding that is a inlinable function, see if the corresponding+  parameter is applied (...to enough arguments...?)++  Also do this is if the function has RULES?++Also++Note [Specialising for lambda parameters]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    foo :: Int -> (Int -> Int) -> Int+    foo 0 f = 0+    foo m f = foo (f m) (\n -> n-m)++This is subtly different from the previous one in that we get an+explicit lambda as the argument:++    T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->+    GHC.Prim.Int#+    T.$wfoo =+      \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->+        case ww_sm8 of ds_Xlr {+          __DEFAULT ->+        case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->+        T.$wfoo+          ww1_Xmq+          (\ (n_ad3 :: GHC.Base.Int) ->+             case n_ad3 of wild_alB { GHC.Base.I# x_alA ->+             GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)+             })+        };+          0 -> 0+        }++I wonder if SpecConstr couldn't be extended to handle this? After all,+lambda is a sort of constructor for functions and perhaps it already+has most of the necessary machinery?++Furthermore, there's an immediate win, because you don't need to allocate the lambda+at the call site; and if perchance it's called in the recursive call, then you+may avoid allocating it altogether.  Just like for constructors.++Looks cool, but probably rare...but it might be easy to implement.+++Note [SpecConstr for casts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    data family T a :: *+    data instance T Int = T Int++    foo n = ...+       where+         go (T 0) = 0+         go (T n) = go (T (n-1))++The recursive call ends up looking like+        go (T (I# ...) `cast` g)+So we want to spot the constructor application inside the cast.+That's why we have the Cast case in argToPat++Note [Local recursive groups]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For a *local* recursive group, we can see all the calls to the+function, so we seed the specialisation loop from the calls in the+body, not from the calls in the RHS.  Consider:++  bar m n = foo n (n,n) (n,n) (n,n) (n,n)+   where+     foo n p q r s+       | n == 0    = m+       | n > 3000  = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s }+       | n > 2000  = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s }+       | n > 1000  = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s }+       | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) }++If we start with the RHSs of 'foo', we get lots and lots of specialisations,+most of which are not needed.  But if we start with the (single) call+in the rhs of 'bar' we get exactly one fully-specialised copy, and all+the recursive calls go to this fully-specialised copy. Indeed, the original+function is later collected as dead code.  This is very important in+specialising the loops arising from stream fusion, for example in NDP where+we were getting literally hundreds of (mostly unused) specialisations of+a local function.++In a case like the above we end up never calling the original un-specialised+function.  (Although we still leave its code around just in case.)++However, if we find any boring calls in the body, including *unsaturated*+ones, such as+      letrec foo x y = ....foo...+      in map foo xs+then we will end up calling the un-specialised function, so then we *should*+use the calls in the un-specialised RHS as seeds.  We call these+"boring call patterns", and callsToPats reports if it finds any of these.++Note [Seeding top-level recursive groups]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This seeding is done in the binding for seed_calls in specRec.++1. If all the bindings in a top-level recursive group are local (not+   exported), then all the calls are in the rest of the top-level+   bindings.  This means we can specialise with those call patterns+   ONLY, and NOT with the RHSs of the recursive group (exactly like+   Note [Local recursive groups])++2. But if any of the bindings are exported, the function may be called+   with any old arguments, so (for lack of anything better) we specialise+   based on+     (a) the call patterns in the RHS+     (b) the call patterns in the rest of the top-level bindings+   NB: before Apr 15 we used (a) only, but Dimitrios had an example+       where (b) was crucial, so I added that.+       Adding (b) also improved nofib allocation results:+                  multiplier: 4%   better+                  minimax:    2.8% better++Actually in case (2), instead of using the calls from the RHS, it+would be better to specialise in the importing module.  We'd need to+add an INLINABLE pragma to the function, and then it can be+specialised in the importing scope, just as is done for type classes+in Specialise.specImports. This remains to be done (#10346).++Note [Top-level recursive groups]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To get the call usage information from "the rest of the top level+bindings" (c.f. Note [Seeding top-level recursive groups]), we work+backwards through the top-level bindings so we see the usage before we+get to the binding of the function.  Before we can collect the usage+though, we go through all the bindings and add them to the+environment. This is necessary because usage is only tracked for+functions in the environment.  These two passes are called+   'go' and 'goEnv'+in specConstrProgram.  (Looks a bit revolting to me.)++Note [Do not specialise diverging functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Specialising a function that just diverges is a waste of code.+Furthermore, it broke GHC (simpl014) thus:+   {-# STR Sb #-}+   f = \x. case x of (a,b) -> f x+If we specialise f we get+   f = \x. case x of (a,b) -> fspec a b+But fspec doesn't have decent strictness info.  As it happened,+(f x) :: IO t, so the state hack applied and we eta expanded fspec,+and hence f.  But now f's strictness is less than its arity, which+breaks an invariant.+++Note [Forcing specialisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+With stream fusion and in other similar cases, we want to fully+specialise some (but not necessarily all!) loops regardless of their+size and the number of specialisations.++We allow a library to do this, in one of two ways (one which is+deprecated):++  1) Add a parameter of type GHC.Types.SPEC (from ghc-prim) to the loop body.++  2) (Deprecated) Annotate a type with ForceSpecConstr from GHC.Exts,+     and then add *that* type as a parameter to the loop body++The reason #2 is deprecated is because it requires GHCi, which isn't+available for things like a cross compiler using stage1.++Here's a (simplified) example from the `vector` package. You may bring+the special 'force specialization' type into scope by saying:++  import GHC.Types (SPEC(..))++or by defining your own type (again, deprecated):++  data SPEC = SPEC | SPEC2+  {-# ANN type SPEC ForceSpecConstr #-}++(Note this is the exact same definition of GHC.Types.SPEC, just+without the annotation.)++After that, you say:++  foldl :: (a -> b -> a) -> a -> Stream b -> a+  {-# INLINE foldl #-}+  foldl f z (Stream step s _) = foldl_loop SPEC z s+    where+      foldl_loop !sPEC z s = case step s of+                              Yield x s' -> foldl_loop sPEC (f z x) s'+                              Skip       -> foldl_loop sPEC z s'+                              Done       -> z++SpecConstr will spot the SPEC parameter and always fully specialise+foldl_loop. Note that++  * We have to prevent the SPEC argument from being removed by+    w/w which is why (a) SPEC is a sum type, and (b) we have to seq on+    the SPEC argument.++  * And lastly, the SPEC argument is ultimately eliminated by+    SpecConstr itself so there is no runtime overhead.++This is all quite ugly; we ought to come up with a better design.++ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set+sc_force to True when calling specLoop. This flag does four things:+  * Ignore specConstrThreshold, to specialise functions of arbitrary size+        (see scTopBind)+  * Ignore specConstrCount, to make arbitrary numbers of specialisations+        (see specialise)+  * Specialise even for arguments that are not scrutinised in the loop+        (see argToPat; Trac #4488)+  * Only specialise on recursive types a finite number of times+        (see is_too_recursive; Trac #5550; Note [Limit recursive specialisation])++This flag is inherited for nested non-recursive bindings (which are likely to+be join points and hence should be fully specialised) but reset for nested+recursive bindings.++What alternatives did I consider? Annotating the loop itself doesn't+work because (a) it is local and (b) it will be w/w'ed and having+w/w propagating annotations somehow doesn't seem like a good idea. The+types of the loop arguments really seem to be the most persistent+thing.++Annotating the types that make up the loop state doesn't work,+either, because (a) it would prevent us from using types like Either+or tuples here, (b) we don't want to restrict the set of types that+can be used in Stream states and (c) some types are fixed by the user+(e.g., the accumulator here) but we still want to specialise as much+as possible.++Alternatives to ForceSpecConstr+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Instead of giving the loop an extra argument of type SPEC, we+also considered *wrapping* arguments in SPEC, thus+  data SPEC a = SPEC a | SPEC2++  loop = \arg -> case arg of+                     SPEC state ->+                        case state of (x,y) -> ... loop (SPEC (x',y')) ...+                        S2 -> error ...+The idea is that a SPEC argument says "specialise this argument+regardless of whether the function case-analyses it".  But this+doesn't work well:+  * SPEC must still be a sum type, else the strictness analyser+    eliminates it+  * But that means that 'loop' won't be strict in its real payload+This loss of strictness in turn screws up specialisation, because+we may end up with calls like+   loop (SPEC (case z of (p,q) -> (q,p)))+Without the SPEC, if 'loop' were strict, the case would move out+and we'd see loop applied to a pair. But if 'loop' isn't strict+this doesn't look like a specialisable call.++Note [Limit recursive specialisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is possible for ForceSpecConstr to cause an infinite loop of specialisation.+Because there is no limit on the number of specialisations, a recursive call with+a recursive constructor as an argument (for example, list cons) will generate+a specialisation for that constructor. If the resulting specialisation also+contains a recursive call with the constructor, this could proceed indefinitely.++For example, if ForceSpecConstr is on:+  loop :: [Int] -> [Int] -> [Int]+  loop z []         = z+  loop z (x:xs)     = loop (x:z) xs+this example will create a specialisation for the pattern+  loop (a:b) c      = loop' a b c++  loop' a b []      = (a:b)+  loop' a b (x:xs)  = loop (x:(a:b)) xs+and a new pattern is found:+  loop (a:(b:c)) d  = loop'' a b c d+which can continue indefinitely.++Roman's suggestion to fix this was to stop after a couple of times on recursive types,+but still specialising on non-recursive types as much as possible.++To implement this, we count the number of times we have gone round the+"specialise recursively" loop ('go' in 'specRec').  Once have gone round+more than N times (controlled by -fspec-constr-recursive=N) we check++  - If sc_force is off, and sc_count is (Just max) then we don't+    need to do anything: trim_pats will limit the number of specs++  - Otherwise check if any function has now got more than (sc_count env)+    specialisations.  If sc_count is "no limit" then we arbitrarily+    choose 10 as the limit (ugh).++See Trac #5550.   Also Trac #13623, where this test had become over-agressive,+and we lost a wonderful specialisation that we really wanted!++Note [NoSpecConstr]+~~~~~~~~~~~~~~~~~~~+The ignoreDataCon stuff allows you to say+    {-# ANN type T NoSpecConstr #-}+to mean "don't specialise on arguments of this type".  It was added+before we had ForceSpecConstr.  Lacking ForceSpecConstr we specialised+regardless of size; and then we needed a way to turn that *off*.  Now+that we have ForceSpecConstr, this NoSpecConstr is probably redundant.+(Used only for PArray.)++-----------------------------------------------------+                Stuff not yet handled+-----------------------------------------------------++Here are notes arising from Roman's work that I don't want to lose.++Example 1+~~~~~~~~~+    data T a = T !a++    foo :: Int -> T Int -> Int+    foo 0 t = 0+    foo x t | even x    = case t of { T n -> foo (x-n) t }+            | otherwise = foo (x-1) t++SpecConstr does no specialisation, because the second recursive call+looks like a boxed use of the argument.  A pity.++    $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#+    $wfoo_sFw =+      \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->+         case ww_sFo of ds_Xw6 [Just L] {+           __DEFAULT ->+                case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {+                  __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;+                  0 ->+                    case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->+                    case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->+                    $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy+                    } } };+           0 -> 0++Example 2+~~~~~~~~~+    data a :*: b = !a :*: !b+    data T a = T !a++    foo :: (Int :*: T Int) -> Int+    foo (0 :*: t) = 0+    foo (x :*: t) | even x    = case t of { T n -> foo ((x-n) :*: t) }+                  | otherwise = foo ((x-1) :*: t)++Very similar to the previous one, except that the parameters are now in+a strict tuple. Before SpecConstr, we have++    $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#+    $wfoo_sG3 =+      \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T+    GHC.Base.Int) ->+        case ww_sFU of ds_Xws [Just L] {+          __DEFAULT ->+        case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {+          __DEFAULT ->+            case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->+            $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2             -- $wfoo1+            };+          0 ->+            case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->+            case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->+            $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB        -- $wfoo2+            } } };+          0 -> 0 }++We get two specialisations:+"SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}+                  Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)+                  = Foo.$s$wfoo1 a_sFB sc_sGC ;+"SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}+                  Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))+                  = Foo.$s$wfoo y_aFp sc_sGC ;++But perhaps the first one isn't good.  After all, we know that tpl_B2 is+a T (I# x) really, because T is strict and Int has one constructor.  (We can't+unbox the strict fields, because T is polymorphic!)++************************************************************************+*                                                                      *+\subsection{Top level wrapper stuff}+*                                                                      *+************************************************************************+-}++specConstrProgram :: ModGuts -> CoreM ModGuts+specConstrProgram guts+  = do+      dflags <- getDynFlags+      us     <- getUniqueSupplyM+      annos  <- getFirstAnnotations deserializeWithData guts+      this_mod <- getModule+      let binds' = reverse $ fst $ initUs us $ do+                    -- Note [Top-level recursive groups]+                    (env, binds) <- goEnv (initScEnv dflags this_mod annos)+                                          (mg_binds guts)+                        -- binds is identical to (mg_binds guts), except that the+                        -- binders on the LHS have been replaced by extendBndr+                        --   (SPJ this seems like overkill; I don't think the binders+                        --    will change at all; and we don't substitute in the RHSs anyway!!)+                    go env nullUsage (reverse binds)++      return (guts { mg_binds = binds' })+  where+    -- See Note [Top-level recursive groups]+    goEnv env []            = return (env, [])+    goEnv env (bind:binds)  = do (env', bind')   <- scTopBindEnv env bind+                                 (env'', binds') <- goEnv env' binds+                                 return (env'', bind' : binds')++    -- Arg list of bindings is in reverse order+    go _   _   []           = return []+    go env usg (bind:binds) = do (usg', bind') <- scTopBind env usg bind+                                 binds' <- go env usg' binds+                                 return (bind' : binds')++{-+************************************************************************+*                                                                      *+\subsection{Environment: goes downwards}+*                                                                      *+************************************************************************++Note [Work-free values only in environment]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The sc_vals field keeps track of in-scope value bindings, so+that if we come across (case x of Just y ->...) we can reduce the+case from knowing that x is bound to a pair.++But only *work-free* values are ok here. For example if the envt had+    x -> Just (expensive v)+then we do NOT want to expand to+     let y = expensive v in ...+because the x-binding still exists and we've now duplicated (expensive v).++This seldom happens because let-bound constructor applications are+ANF-ised, but it can happen as a result of on-the-fly transformations in+SpecConstr itself.  Here is Trac #7865:++        let {+          a'_shr =+            case xs_af8 of _ {+              [] -> acc_af6;+              : ds_dgt [Dmd=<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 case remInt# x 2# of+             __DEFAULT -> case x of+                            __DEFAULT -> f (+# wild_Xp 1#) (I# x)+                            1000000# -> ...+             0# -> case x of+                     __DEFAULT -> f (+# wild_Xp 1#) y+                    1000000#   -> y++Not good!  We build an (I# x) box every time around the loop.+SpecConstr (as described in the paper) does not specialise f, despite+the call (f ... (I# x)) because 'y' is not scrutinied in the body.+But it is much better to specialise f for the case where the argument+is of form (I# x); then we build the box only when returning y, which+is on the cold path.++Another example:++   f x = ...(g x)....++Here 'x' is not scrutinised in f's body; but if we did specialise 'f'+then the call (g x) might allow 'g' to be specialised in turn.++So sc_keen controls whether or not we take account of whether argument is+scrutinised in the body.  True <=> ignore that, and speicalise whenever+the function is applied to a data constructor.+-}++data ScEnv = SCE { sc_dflags    :: DynFlags,+                   sc_module    :: !Module,+                   sc_size      :: Maybe Int,   -- Size threshold+                                                -- Nothing => no limit++                   sc_count     :: Maybe Int,   -- Max # of specialisations for any one fn+                                                -- Nothing => no limit+                                                -- See Note [Avoiding exponential blowup]++                   sc_recursive :: Int,         -- Max # of specialisations over recursive type.+                                                -- Stops ForceSpecConstr from diverging.++                   sc_keen     :: Bool,         -- Specialise on arguments that are known+                                                -- constructors, even if they are not+                                                -- scrutinised in the body.  See+                                                -- Note [Making SpecConstr keener]++                   sc_force     :: Bool,        -- Force specialisation?+                                                -- See Note [Forcing specialisation]++                   sc_subst     :: Subst,       -- Current substitution+                                                -- Maps InIds to OutExprs++                   sc_how_bound :: HowBoundEnv,+                        -- Binds interesting non-top-level variables+                        -- Domain is OutVars (*after* applying the substitution)++                   sc_vals      :: ValueEnv,+                        -- Domain is OutIds (*after* applying the substitution)+                        -- Used even for top-level bindings (but not imported ones)+                        -- The range of the ValueEnv is *work-free* values+                        -- such as (\x. blah), or (Just v)+                        -- but NOT (Just (expensive v))+                        -- See Note [Work-free values only in environment]++                   sc_annotations :: UniqFM SpecConstrAnnotation+             }++---------------------+type HowBoundEnv = VarEnv HowBound      -- Domain is OutVars++---------------------+type ValueEnv = IdEnv Value             -- Domain is OutIds+data Value    = ConVal AltCon [CoreArg] -- _Saturated_ constructors+                                        --   The AltCon is never DEFAULT+              | LambdaVal               -- Inlinable lambdas or PAPs++instance Outputable Value where+   ppr (ConVal con args) = ppr con <+> interpp'SP args+   ppr LambdaVal         = text "<Lambda>"++---------------------+initScEnv :: DynFlags -> Module -> UniqFM SpecConstrAnnotation -> ScEnv+initScEnv dflags this_mod anns+  = SCE { sc_dflags      = dflags,+          sc_module      = this_mod,+          sc_size        = specConstrThreshold dflags,+          sc_count       = specConstrCount     dflags,+          sc_recursive   = specConstrRecursive dflags,+          sc_keen        = gopt Opt_SpecConstrKeen dflags,+          sc_force       = False,+          sc_subst       = emptySubst,+          sc_how_bound   = emptyVarEnv,+          sc_vals        = emptyVarEnv,+          sc_annotations = anns }++data HowBound = RecFun  -- These are the recursive functions for which+                        -- we seek interesting call patterns++              | RecArg  -- These are those functions' arguments, or their sub-components;+                        -- we gather occurrence information for these++instance Outputable HowBound where+  ppr RecFun = text "RecFun"+  ppr RecArg = text "RecArg"++scForce :: ScEnv -> Bool -> ScEnv+scForce env b = env { sc_force = b }++lookupHowBound :: ScEnv -> Id -> Maybe HowBound+lookupHowBound env id = lookupVarEnv (sc_how_bound env) id++scSubstId :: ScEnv -> Id -> CoreExpr+scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v++scSubstTy :: ScEnv -> Type -> Type+scSubstTy env ty = substTy (sc_subst env) ty++scSubstCo :: ScEnv -> Coercion -> Coercion+scSubstCo env co = substCo (sc_subst env) co++zapScSubst :: ScEnv -> ScEnv+zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }++extendScInScope :: ScEnv -> [Var] -> ScEnv+        -- Bring the quantified variables into scope+extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }++        -- Extend the substitution+extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv+extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }++extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv+extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }++extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv+extendHowBound env bndrs how_bound+  = env { sc_how_bound = extendVarEnvList (sc_how_bound env)+                            [(bndr,how_bound) | bndr <- bndrs] }++extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])+extendBndrsWith how_bound env bndrs+  = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')+  where+    (subst', bndrs') = substBndrs (sc_subst env) bndrs+    hb_env' = sc_how_bound env `extendVarEnvList`+                    [(bndr,how_bound) | bndr <- bndrs']++extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)+extendBndrWith how_bound env bndr+  = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')+  where+    (subst', bndr') = substBndr (sc_subst env) bndr+    hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound++extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])+extendRecBndrs env bndrs  = (env { sc_subst = subst' }, bndrs')+                      where+                        (subst', bndrs') = substRecBndrs (sc_subst env) bndrs++extendBndr :: ScEnv -> Var -> (ScEnv, Var)+extendBndr  env bndr  = (env { sc_subst = subst' }, bndr')+                      where+                        (subst', bndr') = substBndr (sc_subst env) bndr++extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv+extendValEnv env _  Nothing   = env+extendValEnv env id (Just cv)+ | valueIsWorkFree cv      -- Don't duplicate work!!  Trac #7865+ = env { sc_vals = extendVarEnv (sc_vals env) id cv }+extendValEnv env _ _ = env++extendCaseBndrs :: ScEnv -> OutExpr -> OutId -> AltCon -> [Var] -> (ScEnv, [Var])+-- When we encounter+--      case scrut of b+--          C x y -> ...+-- we want to bind b, to (C x y)+-- NB1: Extends only the sc_vals part of the envt+-- NB2: Kill the dead-ness info on the pattern binders x,y, since+--      they are potentially made alive by the [b -> C x y] binding+extendCaseBndrs env scrut case_bndr con alt_bndrs+   = (env2, alt_bndrs')+ where+   live_case_bndr = not (isDeadBinder case_bndr)+   env1 | Var v <- stripTicksTopE (const True) scrut+                         = extendValEnv env v cval+        | otherwise      = env  -- See Note [Add scrutinee to ValueEnv too]+   env2 | live_case_bndr = extendValEnv env1 case_bndr cval+        | otherwise      = env1++   alt_bndrs' | case scrut of { Var {} -> True; _ -> live_case_bndr }+              = map zap alt_bndrs+              | otherwise+              = alt_bndrs++   cval = case con of+                DEFAULT    -> Nothing+                LitAlt {}  -> Just (ConVal con [])+                DataAlt {} -> Just (ConVal con vanilla_args)+                      where+                        vanilla_args = map Type (tyConAppArgs (idType case_bndr)) +++                                       varsToCoreExprs alt_bndrs++   zap v | isTyVar v = v                -- See NB2 above+         | otherwise = zapIdOccInfo v+++decreaseSpecCount :: ScEnv -> Int -> ScEnv+-- See Note [Avoiding exponential blowup]+decreaseSpecCount env n_specs+  = env { sc_count = case sc_count env of+                       Nothing -> Nothing+                       Just n  -> Just (n `div` (n_specs + 1)) }+        -- The "+1" takes account of the original function;+        -- See Note [Avoiding exponential blowup]++---------------------------------------------------+-- See Note [Forcing specialisation]+ignoreType    :: ScEnv -> Type   -> Bool+ignoreDataCon  :: ScEnv -> DataCon -> Bool+forceSpecBndr :: ScEnv -> Var    -> Bool++ignoreDataCon env dc = ignoreTyCon env (dataConTyCon dc)++ignoreType env ty+  = case tyConAppTyCon_maybe ty of+      Just tycon -> ignoreTyCon env tycon+      _          -> False++ignoreTyCon :: ScEnv -> TyCon -> Bool+ignoreTyCon env tycon+  = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr++forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var++forceSpecFunTy :: ScEnv -> Type -> Bool+forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys++forceSpecArgTy :: ScEnv -> Type -> Bool+forceSpecArgTy env ty+  | Just ty' <- coreView ty = forceSpecArgTy env ty'++forceSpecArgTy env ty+  | Just (tycon, tys) <- splitTyConApp_maybe ty+  , tycon /= funTyCon+      = tyConName tycon == specTyConName+        || lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr+        || any (forceSpecArgTy env) tys++forceSpecArgTy _ _ = False++{-+Note [Add scrutinee to ValueEnv too]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:+   case x of y+     (a,b) -> case b of c+                I# v -> ...(f y)...+By the time we get to the call (f y), the ValueEnv+will have a binding for y, and for c+    y -> (a,b)+    c -> I# v+BUT that's not enough!  Looking at the call (f y) we+see that y is pair (a,b), but we also need to know what 'b' is.+So in extendCaseBndrs we must *also* add the binding+   b -> I# v+else we lose a useful specialisation for f.  This is necessary even+though the simplifier has systematically replaced uses of 'x' with 'y'+and 'b' with 'c' in the code.  The use of 'b' in the ValueEnv came+from outside the case.  See Trac #4908 for the live example.++Note [Avoiding exponential blowup]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The sc_count field of the ScEnv says how many times we are prepared to+duplicate a single function.  But we must take care with recursive+specialisations.  Consider++        let $j1 = let $j2 = let $j3 = ...+                            in+                            ...$j3...+                  in+                  ...$j2...+        in+        ...$j1...++If we specialise $j1 then in each specialisation (as well as the original)+we can specialise $j2, and similarly $j3.  Even if we make just *one*+specialisation of each, because we also have the original we'll get 2^n+copies of $j3, which is not good.++So when recursively specialising we divide the sc_count by the number of+copies we are making at this level, including the original.+++************************************************************************+*                                                                      *+\subsection{Usage information: flows upwards}+*                                                                      *+************************************************************************+-}++data ScUsage+   = SCU {+        scu_calls :: CallEnv,           -- Calls+                                        -- The functions are a subset of the+                                        --      RecFuns in the ScEnv++        scu_occs :: !(IdEnv ArgOcc)     -- Information on argument occurrences+     }                                  -- The domain is OutIds++type CallEnv = IdEnv [Call]+data Call = Call Id [CoreArg] ValueEnv+        -- The arguments of the call, together with the+        -- env giving the constructor bindings at the call site+        -- We keep the function mainly for debug output++instance Outputable ScUsage where+  ppr (SCU { scu_calls = calls, scu_occs = occs })+    = text "SCU" <+> braces (sep [ ptext (sLit "calls =") <+> ppr calls+                                         , text "occs =" <+> ppr occs ])++instance Outputable Call where+  ppr (Call fn args _) = ppr fn <+> fsep (map pprParendExpr args)++nullUsage :: ScUsage+nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }++combineCalls :: CallEnv -> CallEnv -> CallEnv+combineCalls = plusVarEnv_C (++)+  where+--    plus cs ds | length res > 1+--               = pprTrace "combineCalls" (vcat [ text "cs:" <+> ppr cs+--                                               , text "ds:" <+> ppr ds])+--                 res+--               | otherwise = res+--       where+--          res = cs ++ ds++combineUsage :: ScUsage -> ScUsage -> ScUsage+combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),+                           scu_occs  = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }++combineUsages :: [ScUsage] -> ScUsage+combineUsages [] = nullUsage+combineUsages us = foldr1 combineUsage us++lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])+lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs+  = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},+     [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])++data ArgOcc = NoOcc     -- Doesn't occur at all; or a type argument+            | UnkOcc    -- Used in some unknown way++            | ScrutOcc  -- See Note [ScrutOcc]+                 (DataConEnv [ArgOcc])   -- How the sub-components are used++type DataConEnv a = UniqFM a     -- Keyed by DataCon++{- Note  [ScrutOcc]+~~~~~~~~~~~~~~~~~~~+An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,+is *only* taken apart or applied.++  Functions, literal: ScrutOcc emptyUFM+  Data constructors:  ScrutOcc subs,++where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,+The domain of the UniqFM is the Unique of the data constructor++The [ArgOcc] is the occurrences of the *pattern-bound* components+of the data structure.  E.g.+        data T a = forall b. MkT a b (b->a)+A pattern binds b, x::a, y::b, z::b->a, but not 'a'!++-}++instance Outputable ArgOcc where+  ppr (ScrutOcc xs) = text "scrut-occ" <> ppr xs+  ppr UnkOcc        = text "unk-occ"+  ppr NoOcc         = text "no-occ"++evalScrutOcc :: ArgOcc+evalScrutOcc = ScrutOcc emptyUFM++-- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so+-- that if the thing is scrutinised anywhere then we get to see that+-- in the overall result, even if it's also used in a boxed way+-- This might be too aggressive; see Note [Reboxing] Alternative 3+combineOcc :: ArgOcc -> ArgOcc -> ArgOcc+combineOcc NoOcc         occ           = occ+combineOcc occ           NoOcc         = occ+combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)+combineOcc UnkOcc        (ScrutOcc ys) = ScrutOcc ys+combineOcc (ScrutOcc xs) UnkOcc        = ScrutOcc xs+combineOcc UnkOcc        UnkOcc        = UnkOcc++combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]+combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys++setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage+-- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee+-- is a variable, and an interesting variable+setScrutOcc env usg (Cast e _) occ      = setScrutOcc env usg e occ+setScrutOcc env usg (Tick _ e) occ      = setScrutOcc env usg e occ+setScrutOcc env usg (Var v)    occ+  | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }+  | otherwise                           = usg+setScrutOcc _env usg _other _occ        -- Catch-all+  = usg++{-+************************************************************************+*                                                                      *+\subsection{The main recursive function}+*                                                                      *+************************************************************************++The main recursive function gathers up usage information, and+creates specialised versions of functions.+-}++scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)+        -- The unique supply is needed when we invent+        -- a new name for the specialised function and its args++scExpr env e = scExpr' env e++scExpr' env (Var v)      = case scSubstId env v of+                            Var v' -> return (mkVarUsage env v' [], Var v')+                            e'     -> scExpr (zapScSubst env) e'++scExpr' env (Type t)     = return (nullUsage, Type (scSubstTy env t))+scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c))+scExpr' _   e@(Lit {})   = return (nullUsage, e)+scExpr' env (Tick t e)   = do (usg, e') <- scExpr env e+                              return (usg, Tick t e')+scExpr' env (Cast e co)  = do (usg, e') <- scExpr env e+                              return (usg, mkCast e' (scSubstCo env co))+                              -- Important to use mkCast here+                              -- See Note [SpecConstr call patterns]+scExpr' env e@(App _ _)  = scApp env (collectArgs e)+scExpr' env (Lam b e)    = do let (env', b') = extendBndr env b+                              (usg, e') <- scExpr env' e+                              return (usg, Lam b' e')++scExpr' env (Case scrut b ty alts)+  = do  { (scrut_usg, scrut') <- scExpr env scrut+        ; case isValue (sc_vals env) scrut' of+                Just (ConVal con args) -> sc_con_app con args scrut'+                _other                 -> sc_vanilla scrut_usg scrut'+        }+  where+    sc_con_app con args scrut'  -- Known constructor; simplify+     = do { let (_, bs, rhs) = findAlt con alts+                                  `orElse` (DEFAULT, [], mkImpossibleExpr ty)+                alt_env'     = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)+          ; scExpr alt_env' rhs }++    sc_vanilla scrut_usg scrut' -- Normal case+     = do { let (alt_env,b') = extendBndrWith RecArg env b+                        -- Record RecArg for the components++          ; (alt_usgs, alt_occs, alts')+                <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts++          ; let scrut_occ  = foldr combineOcc NoOcc alt_occs+                scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ+                -- The combined usage of the scrutinee is given+                -- by scrut_occ, which is passed to scScrut, which+                -- in turn treats a bare-variable scrutinee specially++          ; return (foldr combineUsage scrut_usg' alt_usgs,+                    Case scrut' b' (scSubstTy env ty) alts') }++    sc_alt env scrut' b' (con,bs,rhs)+     = do { let (env1, bs1) = extendBndrsWith RecArg env bs+                (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1+          ; (usg, rhs') <- scExpr env2 rhs+          ; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2)+                scrut_occ = case con of+                               DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)+                               _          -> ScrutOcc emptyUFM+          ; return (usg', b_occ `combineOcc` scrut_occ, (con, bs2, rhs')) }++scExpr' env (Let (NonRec bndr rhs) body)+  | isTyVar bndr        -- Type-lets may be created by doBeta+  = scExpr' (extendScSubst env bndr rhs) body++  | otherwise+  = do  { let (body_env, bndr') = extendBndr env bndr+        ; rhs_info  <- scRecRhs env (bndr',rhs)++        ; let body_env2 = extendHowBound body_env [bndr'] RecFun+                           -- Note [Local let bindings]+              rhs'      = ri_new_rhs rhs_info+              body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs')++        ; (body_usg, body') <- scExpr body_env3 body++          -- NB: For non-recursive bindings we inherit sc_force flag from+          -- the parent function (see Note [Forcing specialisation])+        ; (spec_usg, specs) <- specNonRec env body_usg rhs_info++        ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }+                    `combineUsage` spec_usg,  -- Note [spec_usg includes rhs_usg]+                  mkLets [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs] body')+        }+++-- A *local* recursive group: see Note [Local recursive groups]+scExpr' env (Let (Rec prs) body)+  = do  { let (bndrs,rhss)      = unzip prs+              (rhs_env1,bndrs') = extendRecBndrs env bndrs+              rhs_env2          = extendHowBound rhs_env1 bndrs' RecFun+              force_spec        = any (forceSpecBndr env) bndrs'+                -- Note [Forcing specialisation]++        ; rhs_infos <- mapM (scRecRhs rhs_env2) (bndrs' `zip` rhss)+        ; (body_usg, body')     <- scExpr rhs_env2 body++        -- NB: start specLoop from body_usg+        ; (spec_usg, specs) <- specRec NotTopLevel (scForce rhs_env2 force_spec)+                                       body_usg rhs_infos+                -- Do not unconditionally generate specialisations from rhs_usgs+                -- Instead use them only if we find an unspecialised call+                -- See Note [Local recursive groups]++        ; let all_usg = spec_usg `combineUsage` body_usg  -- Note [spec_usg includes rhs_usg]+              bind'   = Rec (concat (zipWith ruleInfoBinds rhs_infos specs))++        ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },+                  Let bind' body') }++{-+Note [Local let bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~+It is not uncommon to find this++   let $j = \x. <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 _ usage _+  | pprTrace "scTopBind_usage" (ppr (scu_calls usage)) False+  = error "false"+-}++scTopBind env body_usage (Rec prs)+  | Just threshold <- sc_size env+  , not force_spec+  , not (all (couldBeSmallEnoughToInline (sc_dflags env) threshold) rhss)+                -- No specialisation+  = -- pprTrace "scTopBind: nospec" (ppr bndrs) $+    do  { (rhs_usgs, rhss')   <- mapAndUnzipM (scExpr env) rhss+        ; return (body_usage `combineUsage` combineUsages rhs_usgs, Rec (bndrs `zip` rhss')) }++  | otherwise   -- Do specialisation+  = do  { rhs_infos <- mapM (scRecRhs env) prs++        ; (spec_usage, specs) <- specRec TopLevel (scForce env force_spec)+                                         body_usage rhs_infos++        ; return (body_usage `combineUsage` spec_usage,+                  Rec (concat (zipWith ruleInfoBinds rhs_infos specs))) }+  where+    (bndrs,rhss) = unzip prs+    force_spec   = any (forceSpecBndr env) bndrs+      -- Note [Forcing specialisation]++scTopBind env usage (NonRec bndr rhs)   -- Oddly, we don't seem to specialise top-level non-rec functions+  = do  { (rhs_usg', rhs') <- scExpr env rhs+        ; return (usage `combineUsage` rhs_usg', NonRec bndr rhs') }++----------------------+scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM RhsInfo+scRecRhs env (bndr,rhs)+  = do  { let (arg_bndrs,body)       = collectBinders rhs+              (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs+        ; (body_usg, body')         <- scExpr body_env body+        ; let (rhs_usg, arg_occs)    = lookupOccs body_usg arg_bndrs'+        ; return (RI { ri_rhs_usg = rhs_usg+                     , ri_fn = bndr, ri_new_rhs = mkLams arg_bndrs' body'+                     , ri_lam_bndrs = arg_bndrs, ri_lam_body = body+                     , ri_arg_occs = arg_occs }) }+                -- The arg_occs says how the visible,+                -- lambda-bound binders of the RHS are used+                -- (including the TyVar binders)+                -- Two pats are the same if they match both ways++----------------------+ruleInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]+ruleInfoBinds (RI { ri_fn = fn, ri_new_rhs = new_rhs })+              (SI { si_specs = specs })+  = [(id,rhs) | OS { os_id = id, os_rhs = rhs } <- specs] +++              -- First the specialised bindings++    [(fn `addIdSpecialisations` rules, new_rhs)]+              -- And now the original binding+  where+    rules = [r | OS { os_rule = r } <- specs]++{-+************************************************************************+*                                                                      *+                The specialiser itself+*                                                                      *+************************************************************************+-}++data RhsInfo+  = RI { ri_fn :: OutId                 -- The binder+       , ri_new_rhs :: OutExpr          -- The specialised RHS (in current envt)+       , ri_rhs_usg :: ScUsage          -- Usage info from specialising RHS++       , ri_lam_bndrs :: [InVar]       -- The *original* RHS (\xs.body)+       , ri_lam_body  :: InExpr        --   Note [Specialise original body]+       , ri_arg_occs  :: [ArgOcc]      -- Info on how the xs occur in body+    }++data SpecInfo       -- Info about specialisations for a particular Id+  = SI { si_specs :: [OneSpec]          -- The specialisations we have generated++       , si_n_specs :: Int              -- Length of si_specs; used for numbering them++       , si_mb_unspec :: Maybe ScUsage  -- Just cs  => we have not yet used calls in the+       }                                --             from calls in the *original* RHS as+                                        --             seeds for new specialisations;+                                        --             if you decide to do so, here is the+                                        --             RHS usage (which has not yet been+                                        --             unleashed)+                                        -- Nothing => we have+                                        -- See Note [Local recursive groups]+                                        -- See Note [spec_usg includes rhs_usg]++        -- One specialisation: Rule plus definition+data OneSpec =+  OS { os_pat  :: CallPat    -- Call pattern that generated this specialisation+     , os_rule :: CoreRule   -- Rule connecting original id with the specialisation+     , os_id   :: OutId      -- Spec id+     , os_rhs  :: OutExpr }  -- Spec rhs++noSpecInfo :: SpecInfo+noSpecInfo = SI { si_specs = [], si_n_specs = 0, si_mb_unspec = Nothing }++----------------------+specNonRec :: ScEnv+           -> ScUsage         -- Body usage+           -> RhsInfo         -- Structure info usage info for un-specialised RHS+           -> UniqSM (ScUsage, SpecInfo)       -- Usage from RHSs (specialised and not)+                                               --     plus details of specialisations++specNonRec env body_usg rhs_info+  = specialise env (scu_calls body_usg) rhs_info+               (noSpecInfo { si_mb_unspec = Just (ri_rhs_usg rhs_info) })++----------------------+specRec :: TopLevelFlag -> ScEnv+        -> ScUsage                         -- Body usage+        -> [RhsInfo]                       -- Structure info and usage info for un-specialised RHSs+        -> UniqSM (ScUsage, [SpecInfo])    -- Usage from all RHSs (specialised and not)+                                           --     plus details of specialisations++specRec top_lvl env body_usg rhs_infos+  = go 1 seed_calls nullUsage init_spec_infos+  where+    (seed_calls, init_spec_infos)    -- Note [Seeding top-level recursive groups]+       | isTopLevel top_lvl+       , any (isExportedId . ri_fn) rhs_infos   -- Seed from body and RHSs+       = (all_calls,     [noSpecInfo | _ <- rhs_infos])+       | otherwise                              -- Seed from body only+       = (calls_in_body, [noSpecInfo { si_mb_unspec = Just (ri_rhs_usg ri) }+                         | ri <- rhs_infos])++    calls_in_body = scu_calls body_usg+    calls_in_rhss = foldr (combineCalls . scu_calls . ri_rhs_usg) emptyVarEnv rhs_infos+    all_calls = calls_in_rhss `combineCalls` calls_in_body++    -- Loop, specialising, until you get no new specialisations+    go :: Int   -- Which iteration of the "until no new specialisations"+                -- loop we are on; first iteration is 1+       -> CallEnv   -- Seed calls+                    -- Two accumulating parameters:+       -> ScUsage      -- Usage from earlier specialisations+       -> [SpecInfo]   -- Details of specialisations so far+       -> UniqSM (ScUsage, [SpecInfo])+    go n_iter seed_calls usg_so_far spec_infos+      | isEmptyVarEnv seed_calls+      = -- pprTrace "specRec1" (vcat [ ppr (map ri_fn rhs_infos)+        --                           , ppr seed_calls+        --                           , ppr body_usg ]) $+        return (usg_so_far, spec_infos)++      -- Limit recursive specialisation+      -- See Note [Limit recursive specialisation]+      | n_iter > sc_recursive env  -- Too many iterations of the 'go' loop+      , sc_force env || isNothing (sc_count env)+           -- If both of these are false, the sc_count+           -- threshold will prevent non-termination+      , any ((> the_limit) . si_n_specs) spec_infos+      = -- pprTrace "specRec2" (ppr (map (map os_pat . si_specs) spec_infos)) $+        return (usg_so_far, spec_infos)++      | otherwise+      = do  { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos+            ; let (extra_usg_s, new_spec_infos) = unzip specs_w_usg+                  extra_usg = combineUsages extra_usg_s+                  all_usg   = usg_so_far `combineUsage` extra_usg+            ; go (n_iter + 1) (scu_calls extra_usg) all_usg new_spec_infos }++    -- See Note [Limit recursive specialisation]+    the_limit = case sc_count env of+                  Nothing  -> 10    -- Ugh!+                  Just max -> max+++----------------------+specialise+   :: ScEnv+   -> CallEnv                     -- Info on newly-discovered calls to this function+   -> RhsInfo+   -> SpecInfo                    -- Original RHS plus patterns dealt with+   -> UniqSM (ScUsage, SpecInfo)  -- New specialised versions and their usage++-- See Note [spec_usg includes rhs_usg]++-- Note: this only generates *specialised* bindings+-- The original binding is added by ruleInfoBinds+--+-- Note: the rhs here is the optimised version of the original rhs+-- So when we make a specialised copy of the RHS, we're starting+-- from an RHS whose nested functions have been optimised already.++specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs+                              , ri_lam_body = body, ri_arg_occs = arg_occs })+               spec_info@(SI { si_specs = specs, si_n_specs = spec_count+                             , si_mb_unspec = mb_unspec })+  | isBottomingId fn      -- Note [Do not specialise diverging functions]+                          -- and do not generate specialisation seeds from its RHS+  = -- pprTrace "specialise bot" (ppr fn) $+    return (nullUsage, spec_info)++  | isNeverActive (idInlineActivation fn) -- See Note [Transfer activation]+    || null arg_bndrs                     -- Only specialise functions+  = -- pprTrace "specialise inactive" (ppr fn) $+    case mb_unspec of    -- Behave as if there was a single, boring call+      Just rhs_usg -> return (rhs_usg, spec_info { si_mb_unspec = Nothing })+                         -- See Note [spec_usg includes rhs_usg]+      Nothing      -> return (nullUsage, spec_info)++  | Just all_calls <- lookupVarEnv bind_calls fn+  = -- pprTrace "specialise entry {" (ppr fn <+> ppr all_calls) $+    do  { (boring_call, new_pats) <- callsToNewPats env fn spec_info arg_occs all_calls++        ; let n_pats = length new_pats+--        ; if (not (null new_pats) || isJust mb_unspec) then+--            pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int n_pats <+> text "good patterns"+--                                        , text "mb_unspec" <+> ppr (isJust mb_unspec)+--                                        , text "arg_occs" <+> ppr arg_occs+--                                        , text "good pats" <+> ppr new_pats])  $+--               return ()+--          else return ()++        ; let spec_env = decreaseSpecCount env n_pats+        ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body)+                                                 (new_pats `zip` [spec_count..])+                -- See Note [Specialise original body]++        ; let spec_usg = combineUsages spec_usgs++              -- If there were any boring calls among the seeds (= all_calls), then those+              -- calls will call the un-specialised function.  So we should use the seeds+              -- from the _unspecialised_ function's RHS, which are in mb_unspec, by returning+              -- then in new_usg.+              (new_usg, mb_unspec')+                  = case mb_unspec of+                      Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)+                      _                          -> (spec_usg,                      mb_unspec)++--        ; pprTrace "specialise return }"+--             (vcat [ ppr fn+--                   , text "boring_call:" <+> ppr boring_call+--                   , text "new calls:" <+> ppr (scu_calls new_usg)]) $+--          return ()++          ; return (new_usg, SI { si_specs = new_specs ++ specs+                                , si_n_specs = spec_count + n_pats+                                , si_mb_unspec = mb_unspec' }) }++  | otherwise  -- No new seeds, so return nullUsage+  = return (nullUsage, spec_info)+++++---------------------+spec_one :: ScEnv+         -> OutId       -- Function+         -> [InVar]     -- Lambda-binders of RHS; should match patterns+         -> InExpr      -- Body of the original function+         -> (CallPat, Int)+         -> UniqSM (ScUsage, OneSpec)   -- Rule and binding++-- spec_one creates a specialised copy of the function, together+-- with a rule for using it.  I'm very proud of how short this+-- function is, considering what it does :-).++{-+  Example++     In-scope: a, x::a+     f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...+          [c::*, v::(b,c) are presumably bound by the (...) part]+  ==>+     f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->+                  (...entire body of f...) [b -> (b,c),+                                            y -> ((:) (a,(b,c)) (x,v) hw)]++     RULE:  forall b::* c::*,           -- Note, *not* forall a, x+                   v::(b,c),+                   hw::[(a,(b,c))] .++            f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw+-}++spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)+  = do  { spec_uniq <- getUniqueM+        ; let spec_env   = extendScSubstList (extendScInScope env qvars)+                                             (arg_bndrs `zip` pats)+              fn_name    = idName fn+              fn_loc     = nameSrcSpan fn_name+              fn_occ     = nameOccName fn_name+              spec_occ   = mkSpecOcc fn_occ+              -- We use fn_occ rather than fn in the rule_name string+              -- as we don't want the uniq to end up in the rule, and+              -- hence in the ABI, as that can cause spurious ABI+              -- changes (#4012).+              rule_name  = mkFastString ("SC:" ++ occNameString fn_occ ++ show rule_number)+              spec_name  = mkInternalName spec_uniq spec_occ fn_loc+--      ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn+--                              <+> ppr pats <+> text "-->" <+> ppr spec_name) $+--        return ()++        -- Specialise the body+        ; (spec_usg, spec_body) <- scExpr spec_env body++--      ; pprTrace "done spec_one}" (ppr fn) $+--        return ()++                -- And build the results+        ; let (spec_lam_args, spec_call_args) = mkWorkerArgs (sc_dflags env)+                                                             qvars body_ty+                -- Usual w/w hack to avoid generating+                -- a spec_rhs of unlifted type and no args++              spec_lam_args_str = handOutStrictnessInformation (fst (splitStrictSig spec_str)) spec_lam_args+                -- Annotate the variables with the strictness information from+                -- the function (see Note [Strictness information in worker binders])++              spec_join_arity | isJoinId fn = Just (length spec_lam_args)+                              | otherwise   = Nothing+              spec_id    = mkLocalIdOrCoVar spec_name+                                            (mkLamTypes spec_lam_args body_ty)+                             -- See Note [Transfer strictness]+                             `setIdStrictness` spec_str+                             `setIdArity` count isId spec_lam_args+                             `asJoinId_maybe` spec_join_arity+              spec_str   = calcSpecStrictness fn spec_lam_args pats+++                -- Conditionally use result of new worker-wrapper transform+              spec_rhs   = mkLams spec_lam_args_str spec_body+              body_ty    = exprType spec_body+              rule_rhs   = mkVarApps (Var spec_id) spec_call_args+              inline_act = idInlineActivation fn+              this_mod   = sc_module spec_env+              rule       = mkRule this_mod True {- Auto -} True {- Local -}+                                  rule_name inline_act fn_name qvars pats rule_rhs+                           -- See Note [Transfer activation]+        ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule+                               , os_id = spec_id+                               , os_rhs = spec_rhs }) }+++-- See Note [Strictness information in worker binders]+handOutStrictnessInformation :: [Demand] -> [Var] -> [Var]+handOutStrictnessInformation = go+  where+    go _ [] = []+    go [] vs = vs+    go (d:dmds) (v:vs) | isId v = setIdDemandInfo v d : go dmds vs+    go dmds (v:vs) = v : go dmds vs++calcSpecStrictness :: Id                     -- The original function+                   -> [Var] -> [CoreExpr]    -- Call pattern+                   -> StrictSig              -- Strictness of specialised thing+-- See Note [Transfer strictness]+calcSpecStrictness fn qvars pats+  = mkClosedStrictSig spec_dmds topRes+  where+    spec_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]+    StrictSig (DmdType _ dmds _) = idStrictness fn++    dmd_env = go emptyVarEnv dmds pats++    go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv+    go env ds (Type {} : pats)     = go env ds pats+    go env ds (Coercion {} : pats) = go env ds pats+    go env (d:ds) (pat : pats)     = go (go_one env d pat) ds pats+    go env _      _                = env++    go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv+    go_one env d   (Var v) = extendVarEnv_C bothDmd env v d+    go_one env d e+           | Just ds <- splitProdDmd_maybe d  -- NB: d does not have to be strict+           , (Var _, args) <- collectArgs e = go env ds args+    go_one env _         _ = env++{-+Note [spec_usg includes rhs_usg]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In calls to 'specialise', the returned ScUsage must include the rhs_usg in+the passed-in SpecInfo, unless there are no calls at all to the function.++The caller can, indeed must, assume this.  He should not combine in rhs_usg+himself, or he'll get rhs_usg twice -- and that can lead to an exponential+blowup of duplicates in the CallEnv.  This is what gave rise to the massive+performace loss in Trac #8852.++Note [Specialise original body]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The RhsInfo for a binding keeps the *original* body of the binding.  We+must specialise that, *not* the result of applying specExpr to the RHS+(which is also kept in RhsInfo). Otherwise we end up specialising a+specialised RHS, and that can lead directly to exponential behaviour.++Note [Transfer activation]+~~~~~~~~~~~~~~~~~~~~~~~~~~+  This note is for SpecConstr, but exactly the same thing+  happens in the overloading specialiser; see+  Note [Auto-specialisation and RULES] in Specialise.++In which phase should the specialise-constructor rules be active?+Originally I made them always-active, but Manuel found that this+defeated some clever user-written rules.  Then I made them active only+in Phase 0; after all, currently, the specConstr transformation is+only run after the simplifier has reached Phase 0, but that meant+that specialisations didn't fire inside wrappers; see test+simplCore/should_compile/spec-inline.++So now I just use the inline-activation of the parent Id, as the+activation for the specialiation RULE, just like the main specialiser;++This in turn means there is no point in specialising NOINLINE things,+so we test for that.++Note [Transfer strictness]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We must transfer strictness information from the original function to+the specialised one.  Suppose, for example++  f has strictness     SS+        and a RULE     f (a:as) b = f_spec a as b++Now we want f_spec to have strictness  LLS, otherwise we'll use call-by-need+when calling f_spec instead of call-by-value.  And that can result in+unbounded worsening in space (cf the classic foldl vs foldl')++See Trac #3437 for a good example.++The function calcSpecStrictness performs the calculation.++Note [Strictness information in worker binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++After having calculated the strictness annotation for the worker (see Note+[Transfer strictness] above), we also want to have this information attached to+the worker’s arguments, for the benefit of later passes. The function+handOutStrictnessInformation decomposes the strictness annotation calculated by+calcSpecStrictness and attaches them to the variables.++************************************************************************+*                                                                      *+\subsection{Argument analysis}+*                                                                      *+************************************************************************++This code deals with analysing call-site arguments to see whether+they are constructor applications.++Note [Free type variables of the qvar types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a call (f @a x True), that we want to specialise, what variables should+we quantify over.  Clearly over 'a' and 'x', but what about any type variables+free in x's type?  In fact we don't need to worry about them because (f @a)+can only be a well-typed application if its type is compatible with x, so any+variables free in x's type must be free in (f @a), and hence either be gathered+via 'a' itself, or be in scope at f's defn.  Hence we just take+  (exprsFreeVars pats).++BUT phantom type synonyms can mess this reasoning up,+  eg   x::T b   with  type T b = Int+So we apply expandTypeSynonyms to the bound Ids.+See Trac # 5458.  Yuk.++Note [SpecConstr call patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A "call patterns" that we collect is going to become the LHS of a RULE.+It's important that it doesn't have+     e |> Refl+or+    e |> g1 |> g2+because both of these will be optimised by Simplify.simplRule. In the+former case such optimisation benign, because the rule will match more+terms; but in the latter we may lose a binding of 'g1' or 'g2', and+end up with a rule LHS that doesn't bind the template variables+(Trac #10602).++The simplifier eliminates such things, but SpecConstr itself constructs+new terms by substituting.  So the 'mkCast' in the Cast case of scExpr+is very important!++Note [Choosing patterns]+~~~~~~~~~~~~~~~~~~~~~~~~+If we get lots of patterns we may not want to make a specialisation+for each of them (code bloat), so we choose as follows, implemented+by trim_pats.++* The flag -fspec-constr-count-N sets the sc_count field+  of the ScEnv to (Just n).  This limits the total number+  of specialisations for a given function to N.++* -fno-spec-constr-count sets the sc_count field to Nothing,+  which switches of the limit.++* The ghastly ForceSpecConstr trick also switches of the limit+  for a particular function++* Otherwise we sort the patterns to choose the most general+  ones first; more general => more widely applicable.+-}++type CallPat = ([Var], [CoreExpr])      -- Quantified variables and arguments+                                        -- See Note [SpecConstr call patterns]++callsToNewPats :: ScEnv -> Id+               -> SpecInfo+               -> [ArgOcc] -> [Call]+               -> UniqSM (Bool, [CallPat])+        -- Result has no duplicate patterns,+        -- nor ones mentioned in done_pats+        -- Bool indicates that there was at least one boring pattern+callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls+  = do  { mb_pats <- mapM (callToPats env bndr_occs) calls++        ; let have_boring_call = any isNothing mb_pats++              good_pats :: [CallPat]+              good_pats = catMaybes mb_pats++              -- Remove patterns we have already done+              new_pats = filterOut is_done good_pats+              is_done p = any (samePat p . os_pat) done_specs++              -- Remove duplicates+              non_dups = nubBy samePat new_pats++              -- Remove ones that have too many worker variables+              small_pats = filterOut too_big non_dups+              too_big (vars,_) = not (isWorkerSmallEnough (sc_dflags env) vars)+                  -- We are about to construct w/w pair in 'spec_one'.+                  -- Omit specialisation leading to high arity workers.+                  -- See Note [Limit w/w arity] in WwLib++                -- Discard specialisations if there are too many of them+              trimmed_pats = trim_pats env fn spec_info small_pats++--        ; pprTrace "callsToPats" (vcat [ text "calls:" <+> ppr calls+--                                       , text "good_pats:" <+> ppr good_pats ]) $+--          return ()++        ; return (have_boring_call, trimmed_pats) }+++trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> [CallPat]+-- See Note [Choosing patterns]+trim_pats env fn (SI { si_n_specs = done_spec_count }) pats+  | sc_force env+    || isNothing mb_scc+    || n_remaining >= n_pats+  = pats          -- No need to trim++  | otherwise+  = emit_trace $  -- Need to trim, so keep the best ones+    take n_remaining sorted_pats++  where+    n_pats         = length pats+    spec_count'    = n_pats + done_spec_count+    n_remaining    = max_specs - done_spec_count+    mb_scc         = sc_count env+    Just max_specs = mb_scc++    sorted_pats = map fst $+                  sortBy (comparing snd) $+                  [(pat, pat_cons pat) | pat <- pats]+     -- Sort in order of increasing number of constructors+     -- (i.e. decreasing generality) and pick the initial+     -- segment of this list++    pat_cons :: CallPat -> Int+    -- How many data consturorst of literals are in+    -- the patten.  More data-cons => less general+    pat_cons (qs, ps) = foldr ((+) . n_cons) 0 ps+       where+          q_set = mkVarSet qs+          n_cons (Var v) | v `elemVarSet` q_set = 0+                         | otherwise            = 1+          n_cons (Cast e _)  = n_cons e+          n_cons (App e1 e2) = n_cons e1 + n_cons e2+          n_cons (Lit {})    = 1+          n_cons _           = 0++    emit_trace result+       | debugIsOn || hasPprDebug (sc_dflags env)+         -- Suppress this scary message for ordinary users!  Trac #5125+       = pprTrace "SpecConstr" msg result+       | otherwise+       = result+    msg = vcat [ sep [ text "Function" <+> quotes (ppr fn)+                     , nest 2 (text "has" <+>+                               speakNOf spec_count' (text "call pattern") <> comma <+>+                               text "but the limit is" <+> int max_specs) ]+               , text "Use -fspec-constr-count=n to set the bound"+               , text "Discarding:" <+> ppr (drop n_remaining sorted_pats) ]+++callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)+        -- The [Var] is the variables to quantify over in the rule+        --      Type variables come first, since they may scope+        --      over the following term variables+        -- The [CoreExpr] are the argument patterns for the rule+callToPats env bndr_occs (Call _ args con_env)+  | length args < length bndr_occs      -- Check saturated+  = return Nothing+  | otherwise+  = do  { let in_scope      = substInScope (sc_subst env)+        ; (interesting, pats) <- argsToPats env in_scope con_env args bndr_occs+        ; let pat_fvs       = exprsFreeVarsList pats+                -- To get determinism we need the list of free variables in+                -- deterministic order. Otherwise we end up creating+                -- lambdas with different argument orders. See+                -- determinism/simplCore/should_compile/spec-inline-determ.hs+                -- for an example. For explanation of determinism+                -- considerations See Note [Unique Determinism] in Unique.+              in_scope_vars = getInScopeVars in_scope+              qvars         = filterOut (`elemVarSet` in_scope_vars) pat_fvs+                -- Quantify over variables that are not in scope+                -- at the call site+                -- See Note [Free type variables of the qvar types]+                -- See Note [Shadowing] at the top++              (ktvs, ids)   = partition isTyVar qvars+              qvars'        = toposortTyVars ktvs ++ map sanitise ids+                -- Order into kind variables, type variables, term variables+                -- The kind of a type variable may mention a kind variable+                -- and the type of a term variable may mention a type variable++              sanitise id   = id `setIdType` expandTypeSynonyms (idType id)+                -- See Note [Free type variables of the qvar types]++        ; -- pprTrace "callToPats"  (ppr args $$ ppr bndr_occs) $+          if interesting+          then return (Just (qvars', pats))+          else return Nothing }++    -- argToPat takes an actual argument, and returns an abstracted+    -- version, consisting of just the "constructor skeleton" of the+    -- argument, with non-constructor sub-expression replaced by new+    -- placeholder variables.  For example:+    --    C a (D (f x) (g y))  ==>  C p1 (D p2 p3)++argToPat :: ScEnv+         -> InScopeSet                  -- What's in scope at the fn defn site+         -> ValueEnv                    -- ValueEnv at the call site+         -> CoreArg                     -- A call arg (or component thereof)+         -> ArgOcc+         -> UniqSM (Bool, CoreArg)++-- Returns (interesting, pat),+-- where pat is the pattern derived from the argument+--            interesting=True if the pattern is non-trivial (not a variable or type)+-- E.g.         x:xs         --> (True, x:xs)+--              f xs         --> (False, w)        where w is a fresh wildcard+--              (f xs, 'c')  --> (True, (w, 'c'))  where w is a fresh wildcard+--              \x. x+y      --> (True, \x. x+y)+--              lvl7         --> (True, lvl7)      if lvl7 is bound+--                                                 somewhere further out++argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ+  = return (False, arg)++argToPat env in_scope val_env (Tick _ arg) arg_occ+  = argToPat env in_scope val_env arg arg_occ+        -- Note [Notes in call patterns]+        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+        -- Ignore Notes.  In particular, we want to ignore any InlineMe notes+        -- Perhaps we should not ignore profiling notes, but I'm going to+        -- ride roughshod over them all for now.+        --- See Note [Notes in RULE matching] in Rules++argToPat env in_scope val_env (Let _ arg) arg_occ+  = argToPat env in_scope val_env arg arg_occ+        -- See Note [Matching lets] in Rule.hs+        -- Look through let expressions+        -- e.g.         f (let v = rhs in (v,w))+        -- Here we can specialise for f (v,w)+        -- because the rule-matcher will look through the let.++{- Disabled; see Note [Matching cases] in Rule.hs+argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ+  | exprOkForSpeculation scrut  -- See Note [Matching cases] in Rule.hhs+  = argToPat env in_scope val_env rhs arg_occ+-}++argToPat env in_scope val_env (Cast arg co) arg_occ+  | not (ignoreType env ty2)+  = do  { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ+        ; if not interesting then+                wildCardPat ty2+          else do+        { -- Make a wild-card pattern for the coercion+          uniq <- getUniqueM+        ; let co_name = mkSysTvName uniq (fsLit "sg")+              co_var  = mkCoVar co_name (mkCoercionType Representational ty1 ty2)+        ; return (interesting, Cast arg' (mkCoVarCo co_var)) } }+  where+    Pair ty1 ty2 = coercionKind co++++{-      Disabling lambda specialisation for now+        It's fragile, and the spec_loop can be infinite+argToPat in_scope val_env arg arg_occ+  | is_value_lam arg+  = return (True, arg)+  where+    is_value_lam (Lam v e)         -- Spot a value lambda, even if+        | isId v       = True      -- it is inside a type lambda+        | otherwise    = is_value_lam e+    is_value_lam other = False+-}++  -- Check for a constructor application+  -- NB: this *precedes* the Var case, so that we catch nullary constrs+argToPat env in_scope val_env arg arg_occ+  | Just (ConVal (DataAlt dc) args) <- isValue val_env arg+  , not (ignoreDataCon env dc)        -- See Note [NoSpecConstr]+  , Just arg_occs <- mb_scrut dc+  = do  { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args+        ; (_, args') <- argsToPats env in_scope val_env rest_args arg_occs+        ; return (True,+                  mkConApp dc (ty_args ++ args')) }+  where+    mb_scrut dc = case arg_occ of+                    ScrutOcc bs | Just occs <- lookupUFM bs dc+                                -> Just (occs)  -- See Note [Reboxing]+                    _other      | sc_force env || sc_keen env+                                -> Just (repeat UnkOcc)+                                | otherwise+                                -> Nothing++  -- Check if the argument is a variable that+  --    (a) is used in an interesting way in the function body+  --    (b) we know what its value is+  -- In that case it counts as "interesting"+argToPat env in_scope val_env (Var v) arg_occ+  | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)+    is_value,                                                            -- (b)+       -- Ignoring sc_keen here to avoid gratuitously incurring Note [Reboxing]+       -- So sc_keen focused just on f (I# x), where we have freshly-allocated+       -- box that we can eliminate in the caller+    not (ignoreType env (varType v))+  = return (True, Var v)+  where+    is_value+        | isLocalId v = v `elemInScopeSet` in_scope+                        && isJust (lookupVarEnv val_env v)+                -- Local variables have values in val_env+        | otherwise   = isValueUnfolding (idUnfolding v)+                -- Imports have unfoldings++--      I'm really not sure what this comment means+--      And by not wild-carding we tend to get forall'd+--      variables that are in scope, which in turn can+--      expose the weakness in let-matching+--      See Note [Matching lets] in Rules++  -- Check for a variable bound inside the function.+  -- Don't make a wild-card, because we may usefully share+  --    e.g.  f a = let x = ... in f (x,x)+  -- NB: this case follows the lambda and con-app cases!!+-- argToPat _in_scope _val_env (Var v) _arg_occ+--   = return (False, Var v)+        -- SLPJ : disabling this to avoid proliferation of versions+        -- also works badly when thinking about seeding the loop+        -- from the body of the let+        --       f x y = letrec g z = ... in g (x,y)+        -- We don't want to specialise for that *particular* x,y++  -- The default case: make a wild-card+  -- We use this for coercions too+argToPat _env _in_scope _val_env arg _arg_occ+  = wildCardPat (exprType arg)++wildCardPat :: Type -> UniqSM (Bool, CoreArg)+wildCardPat ty+  = do { uniq <- getUniqueM+       ; let id = mkSysLocalOrCoVar (fsLit "sc") uniq ty+       ; return (False, varToCoreExpr id) }++argsToPats :: ScEnv -> InScopeSet -> ValueEnv+           -> [CoreArg] -> [ArgOcc]  -- Should be same length+           -> UniqSM (Bool, [CoreArg])+argsToPats env in_scope val_env args occs+  = do { stuff <- zipWithM (argToPat env in_scope val_env) args occs+       ; let (interesting_s, args') = unzip stuff+       ; return (or interesting_s, args') }++isValue :: ValueEnv -> CoreExpr -> Maybe Value+isValue _env (Lit lit)+  | litIsLifted lit = Nothing+  | otherwise       = Just (ConVal (LitAlt lit) [])++isValue env (Var v)+  | Just cval <- lookupVarEnv env v+  = Just cval  -- You might think we could look in the idUnfolding here+               -- but that doesn't take account of which branch of a+               -- case we are in, which is the whole point++  | not (isLocalId v) && isCheapUnfolding unf+  = isValue env (unfoldingTemplate unf)+  where+    unf = idUnfolding v+        -- However we do want to consult the unfolding+        -- as well, for let-bound constructors!++isValue env (Lam b e)+  | isTyVar b = case isValue env e of+                  Just _  -> Just LambdaVal+                  Nothing -> Nothing+  | otherwise = Just LambdaVal++isValue env (Tick t e)+  | not (tickishIsCode t)+  = isValue env e++isValue _env expr       -- Maybe it's a constructor application+  | (Var fun, args, _) <- collectArgsTicks (not . tickishIsCode) expr+  = case isDataConWorkId_maybe fun of++        Just con | args `lengthAtLeast` dataConRepArity con+                -- Check saturated; might be > because the+                --                  arity excludes type args+                -> Just (ConVal (DataAlt con) args)++        _other | valArgCount args < idArity fun+                -- Under-applied function+               -> Just LambdaVal        -- Partial application++        _other -> Nothing++isValue _env _expr = Nothing++valueIsWorkFree :: Value -> Bool+valueIsWorkFree LambdaVal       = True+valueIsWorkFree (ConVal _ args) = all exprIsWorkFree args++samePat :: CallPat -> CallPat -> Bool+samePat (vs1, as1) (vs2, as2)+  = all2 same as1 as2+  where+    same (Var v1) (Var v2)+        | v1 `elem` vs1 = v2 `elem` vs2+        | v2 `elem` vs2 = False+        | otherwise     = v1 == v2++    same (Lit l1)    (Lit l2)    = l1==l2+    same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2++    same (Type {}) (Type {}) = True     -- Note [Ignore type differences]+    same (Coercion {}) (Coercion {}) = True+    same (Tick _ e1) e2 = same e1 e2  -- Ignore casts and notes+    same (Cast e1 _) e2 = same e1 e2+    same e1 (Tick _ e2) = same e1 e2+    same e1 (Cast e2 _) = same e1 e2++    same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)+                 False  -- Let, lambda, case should not occur+    bad (Case {}) = True+    bad (Let {})  = True+    bad (Lam {})  = True+    bad _other    = False++{-+Note [Ignore type differences]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do not want to generate specialisations where the call patterns+differ only in their type arguments!  Not only is it utterly useless,+but it also means that (with polymorphic recursion) we can generate+an infinite number of specialisations. Example is Data.Sequence.adjustTree,+I think.+-}
+ specialise/Specialise.hs view
@@ -0,0 +1,2456 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998++\section[Specialise]{Stamping out overloading, and (optionally) polymorphism}+-}++{-# LANGUAGE CPP #-}+module Specialise ( specProgram, specUnfolding ) where++#include "HsVersions.h"++import Id+import TcType hiding( substTy )+import Type   hiding( substTy, extendTvSubstList )+import Module( Module, HasModule(..) )+import Coercion( Coercion )+import CoreMonad+import qualified CoreSubst+import CoreUnfold+import Var              ( isLocalVar )+import VarSet+import VarEnv+import CoreSyn+import Rules+import CoreOpt          ( collectBindersPushingCo )+import CoreUtils        ( exprIsTrivial, applyTypeToArgs, mkCast )+import CoreFVs+import FV               ( InterestingVarFun )+import CoreArity        ( etaExpandToJoinPointRule )+import UniqSupply+import Name+import MkId             ( voidArgId, voidPrimId )+import Maybes           ( catMaybes, isJust )+import MonadUtils       ( foldlM )+import BasicTypes+import HscTypes+import Bag+import DynFlags+import Util+import Outputable+import FastString+import State+import UniqDFM++import Control.Monad+#if __GLASGOW_HASKELL__ > 710+import qualified Control.Monad.Fail as MonadFail+#endif++{-+************************************************************************+*                                                                      *+\subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]}+*                                                                      *+************************************************************************++These notes describe how we implement specialisation to eliminate+overloading.++The specialisation pass works on Core+syntax, complete with all the explicit dictionary application,+abstraction and construction as added by the type checker.  The+existing type checker remains largely as it is.++One important thought: the {\em types} passed to an overloaded+function, and the {\em dictionaries} passed are mutually redundant.+If the same function is applied to the same type(s) then it is sure to+be applied to the same dictionary(s)---or rather to the same {\em+values}.  (The arguments might look different but they will evaluate+to the same value.)++Second important thought: we know that we can make progress by+treating dictionary arguments as static and worth specialising on.  So+we can do without binding-time analysis, and instead specialise on+dictionary arguments and no others.++The basic idea+~~~~~~~~~~~~~~+Suppose we have++        let f = <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 recusion for non-overloaded functions which we+specialise, but the recursive call should get specialised to the+same recursive version.+++Polymorphism 1+~~~~~~~~~~~~~~++All this is crystal clear when the function is applied to *constant+types*; that is, types which have no type variables inside.  But what if+it is applied to non-constant types?  Suppose we find a call of f at type+t1/t2.  There are two possibilities:++(a) The free type variables of t1, t2 are in scope at the definition point+of f.  In this case there's no problem, we proceed just as before.  A common+example is as follows.  Here's the Haskell:++        g y = let f x = x+x+              in f y + f y++After typechecking we have++        g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x+                                in +.sel a d (f a d y) (f a d y)++Notice that the call to f is at type type "a"; a non-constant type.+Both calls to f are at the same type, so we can specialise to give:++        g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x+                                in +.sel a d (f@a y) (f@a y)+++(b) The other case is when the type variables in the instance types+are *not* in scope at the definition point of f.  The example we are+working with above is a good case.  There are two instances of (+.sel a d),+but "a" is not in scope at the definition of +.sel.  Can we do anything?+Yes, we can "common them up", a sort of limited common sub-expression deal.+This would give:++        g a (d::Num a) (y::a) = let +.sel@a = +.sel a d+                                    f@a (x::a) = +.sel@a x x+                                in +.sel@a (f@a y) (f@a y)++This can save work, and can't be spotted by the type checker, because+the two instances of +.sel weren't originally at the same type.++Further notes on (b)++* There are quite a few variations here.  For example, the defn of+  +.sel could be floated ouside the \y, to attempt to gain laziness.+  It certainly mustn't be floated outside the \d because the d has to+  be in scope too.++* We don't want to inline f_rhs in this case, because+that will duplicate code.  Just commoning up the call is the point.++* Nothing gets added to +.sel's IdInfo.++* Don't bother unless the equivalence class has more than one item!++Not clear whether this is all worth it.  It is of course OK to+simply discard call-instances when passing a big lambda.++Polymorphism 2 -- Overloading+~~~~~~~~~~~~~~+Consider a function whose most general type is++        f :: forall a b. Ord a => [a] -> b -> b++There is really no point in making a version of g at Int/Int and another+at Int/Bool, because it's only instantiating the type variable "a" which+buys us any efficiency. Since g is completely polymorphic in b there+ain't much point in making separate versions of g for the different+b types.++That suggests that we should identify which of g's type variables+are constrained (like "a") and which are unconstrained (like "b").+Then when taking equivalence classes in STEP 2, we ignore the type args+corresponding to unconstrained type variable.  In STEP 3 we make+polymorphic versions.  Thus:++        f@t1/ = /\b -> <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 occuring in a program.+specProgram :: ModGuts -> CoreM ModGuts+specProgram guts@(ModGuts { mg_module = this_mod+                          , mg_rules = local_rules+                          , mg_binds = binds })+  = do { dflags <- getDynFlags++             -- Specialise the bindings of this module+       ; (binds', uds) <- runSpecM dflags this_mod (go binds)++             -- Specialise imported functions+       ; hpt_rules <- getRuleBase+       ; let rule_base = extendRuleBaseList hpt_rules local_rules+       ; (new_rules, spec_binds) <- specImports dflags this_mod top_env emptyVarSet+                                                [] rule_base uds++       ; let final_binds+               | null spec_binds = binds'+               | otherwise       = Rec (flattenBinds spec_binds) : binds'+                   -- Note [Glom the bindings if imported functions are specialised]++       ; return (guts { mg_binds = final_binds+                      , mg_rules = new_rules ++ local_rules }) }+  where+        -- We need to start with a Subst that knows all the things+        -- that are in scope, so that the substitution engine doesn't+        -- accidentally re-use a unique that's already in use+        -- Easiest thing is to do it all at once, as if all the top-level+        -- decls were mutually recursive+    top_env = SE { se_subst = CoreSubst.mkEmptySubst $ mkInScopeSet $ mkVarSet $+                              bindersOfBinds binds+                 , se_interesting = emptyVarSet }++    go []           = return ([], emptyUDs)+    go (bind:binds) = do (binds', uds) <- go binds+                         (bind', uds') <- specBind top_env bind uds+                         return (bind' ++ binds', uds')++{-+Note [Wrap bindings returned by specImports]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+'specImports' returns a set of specialized bindings. However, these are lacking+necessary floated dictionary bindings, which are returned by+UsageDetails(ud_binds). These dictionaries need to be brought into scope with+'wrapDictBinds' before the bindings returned by 'specImports' can be used. See,+for instance, the 'specImports' call in 'specProgram'.+++Note [Disabling cross-module specialisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Since GHC 7.10 we have performed specialisation of INLINABLE bindings living+in modules outside of the current module. This can sometimes uncover user code+which explodes in size when aggressively optimized. The+-fno-cross-module-specialise option was introduced to allow users to being+bitten by such instances to revert to the pre-7.10 behavior.++See Trac #10491+-}++-- | Specialise a set of calls to imported bindings+specImports :: DynFlags+            -> Module+            -> SpecEnv          -- Passed in so that all top-level Ids are in scope+            -> VarSet           -- Don't specialise these ones+                                -- See Note [Avoiding recursive specialisation]+            -> [Id]             -- Stack of imported functions being specialised+            -> RuleBase         -- Rules from this module and the home package+                                -- (but not external packages, which can change)+            -> UsageDetails     -- Calls for imported things, and floating bindings+            -> CoreM ( [CoreRule]   -- New rules+                     , [CoreBind] ) -- Specialised bindings+                                    -- See Note [Wrapping bindings returned by specImports]+specImports dflags this_mod top_env done callers rule_base+            (MkUD { ud_binds = dict_binds, ud_calls = calls })+  -- See Note [Disabling cross-module specialisation]+  | not $ gopt Opt_CrossModuleSpecialise dflags+  = return ([], [])++  | otherwise+  = do { let import_calls = dVarEnvElts calls+       ; (rules, spec_binds) <- go rule_base import_calls++             -- Don't forget to wrap the specialized bindings with+             -- bindings for the needed dictionaries.+             -- See Note [Wrap bindings returned by specImports]+       ; let spec_binds' = wrapDictBinds dict_binds spec_binds++       ; return (rules, spec_binds') }+  where+    go :: RuleBase -> [CallInfoSet] -> CoreM ([CoreRule], [CoreBind])+    go _ [] = return ([], [])+    go rb (cis@(CIS fn _) : other_calls)+      = do { let ok_calls = filterCalls cis dict_binds+                     -- Drop calls that (directly or indirectly) refer to fn+                     -- See Note [Avoiding loops]+--           ; debugTraceMsg (text "specImport" <+> vcat [ ppr fn+--                                                       , text "calls" <+> ppr cis+--                                                       , text "ud_binds =" <+> ppr dict_binds+--                                                       , text "dump set =" <+> ppr dump_set+--                                                       , text "filtered calls =" <+> ppr ok_calls ])+           ; (rules1, spec_binds1) <- specImport dflags this_mod top_env+                                                 done callers rb fn ok_calls++           ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls+           ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) }++specImport :: DynFlags+           -> Module+           -> SpecEnv               -- Passed in so that all top-level Ids are in scope+           -> VarSet                -- Don't specialise these+                                    -- See Note [Avoiding recursive specialisation]+           -> [Id]                  -- Stack of imported functions being specialised+           -> RuleBase              -- Rules from this module+           -> Id -> [CallInfo]      -- Imported function and calls for it+           -> CoreM ( [CoreRule]    -- New rules+                    , [CoreBind] )  -- Specialised bindings+specImport dflags this_mod top_env done callers rb fn calls_for_fn+  | fn `elemVarSet` done+  = return ([], [])     -- No warning.  This actually happens all the time+                        -- when specialising a recursive function, because+                        -- the RHS of the specialised function contains a recursive+                        -- call to the original function++  | null calls_for_fn   -- We filtered out all the calls in deleteCallsMentioning+  = return ([], [])++  | wantSpecImport dflags unfolding+  , Just rhs <- maybeUnfoldingTemplate unfolding+  = do {     -- Get rules from the external package state+             -- We keep doing this in case we "page-fault in"+             -- more rules as we go along+       ; hsc_env <- getHscEnv+       ; eps <- liftIO $ hscEPS hsc_env+       ; vis_orphs <- getVisibleOrphanMods+       ; let full_rb = unionRuleBase rb (eps_rule_base eps)+             rules_for_fn = getRules (RuleEnv full_rb vis_orphs) fn++       ; (rules1, spec_pairs, uds)+             <- -- pprTrace "specImport1" (vcat [ppr fn, ppr calls_for_fn, ppr rhs]) $+                runSpecM dflags this_mod $+                specCalls (Just this_mod) top_env rules_for_fn calls_for_fn fn rhs+       ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs]+             -- After the rules kick in we may get recursion, but+             -- we rely on a global GlomBinds to sort that out later+             -- See Note [Glom the bindings if imported functions are specialised]++              -- Now specialise any cascaded calls+       ; (rules2, spec_binds2) <- -- pprTrace "specImport 2" (ppr fn $$ ppr rules1 $$ ppr spec_binds1) $+                                  specImports dflags this_mod top_env+                                              (extendVarSet done fn)+                                              (fn:callers)+                                              (extendRuleBaseList rb rules1)+                                              uds++       ; let final_binds = spec_binds2 ++ spec_binds1++       ; return (rules2 ++ rules1, final_binds) }++  |  warnMissingSpecs dflags callers+  = do { warnMsg (vcat [ hang (text "Could not specialise imported function" <+> quotes (ppr fn))+                            2 (vcat [ text "when specialising" <+> quotes (ppr caller)+                                    | caller <- callers])+                      , ifPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn))+                      , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ])+       ; return ([], []) }++  | otherwise+  = return ([], [])+  where+    unfolding = realIdUnfolding fn   -- We want to see the unfolding even for loop breakers++warnMissingSpecs :: DynFlags -> [Id] -> Bool+-- See Note [Warning about missed specialisations]+warnMissingSpecs dflags callers+  | wopt Opt_WarnAllMissedSpecs dflags = True+  | not (wopt Opt_WarnMissedSpecs dflags) = False+  | null callers                       = False+  | otherwise                          = all has_inline_prag callers+  where+    has_inline_prag id = isAnyInlinePragma (idInlinePragma id)++wantSpecImport :: DynFlags -> Unfolding -> Bool+-- See Note [Specialise imported INLINABLE things]+wantSpecImport dflags unf+ = case unf of+     NoUnfolding      -> False+     BootUnfolding    -> False+     OtherCon {}      -> False+     DFunUnfolding {} -> True+     CoreUnfolding { uf_src = src, uf_guidance = _guidance }+       | gopt Opt_SpecialiseAggressively dflags -> True+       | isStableSource src -> True+               -- Specialise even INLINE things; it hasn't inlined yet,+               -- so perhaps it never will.  Moreover it may have calls+               -- inside it that we want to specialise+       | otherwise -> False    -- Stable, not INLINE, hence INLINABLE++{- Note [Warning about missed specialisations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose+ * In module Lib, you carefully mark a function 'foo' INLINABLE+ * Import Lib(foo) into another module M+ * Call 'foo' at some specialised type in M+Then you jolly well expect it to be specialised in M.  But what if+'foo' calls another function 'Lib.bar'.  Then you'd like 'bar' to be+specialised too.  But if 'bar' is not marked INLINABLE it may well+not be specialised.  The warning Opt_WarnMissedSpecs warns about this.++It's more noisy to warning about a missed specialisation opportunity+for /every/ overloaded imported function, but sometimes useful. That+is what Opt_WarnAllMissedSpecs does.++ToDo: warn about missed opportunities for local functions.++Note [Specialise imported INLINABLE things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What imported functions do we specialise?  The basic set is+ * DFuns and things with INLINABLE pragmas.+but with -fspecialise-aggressively we add+ * Anything with an unfolding template++Trac #8874 has a good example of why we want to auto-specialise DFuns.++We have the -fspecialise-aggressively flag (usually off), because we+risk lots of orphan modules from over-vigorous specialisation.+However it's not a big deal: anything non-recursive with an+unfolding-template will probably have been inlined already.++Note [Glom the bindings if imported functions are specialised]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have an imported, *recursive*, INLINABLE function+   f :: Eq a => a -> a+   f = /\a \d x. ...(f a d)...+In the module being compiled we have+   g x = f (x::Int)+Now we'll make a specialised function+   f_spec :: Int -> Int+   f_spec = \x -> ...(f Int dInt)...+   {-# RULE  f Int _ = f_spec #-}+   g = \x. f Int dInt x+Note that f_spec doesn't look recursive+After rewriting with the RULE, we get+   f_spec = \x -> ...(f_spec)...+BUT since f_spec was non-recursive before it'll *stay* non-recursive.+The occurrence analyser never turns a NonRec into a Rec.  So we must+make sure that f_spec is recursive.  Easiest thing is to make all+the specialisations for imported bindings recursive.+++Note [Avoiding recursive specialisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we specialise 'f' we may find new overloaded calls to 'g', 'h' in+'f's RHS.  So we want to specialise g,h.  But we don't want to+specialise f any more!  It's possible that f's RHS might have a+recursive yet-more-specialised call, so we'd diverge in that case.+And if the call is to the same type, one specialisation is enough.+Avoiding this recursive specialisation loop is the reason for the+'done' VarSet passed to specImports and specImport.++************************************************************************+*                                                                      *+\subsubsection{@specExpr@: the main function}+*                                                                      *+************************************************************************+-}++data SpecEnv+  = SE { se_subst :: CoreSubst.Subst+             -- We carry a substitution down:+             -- a) we must clone any binding that might float outwards,+             --    to avoid name clashes+             -- b) we carry a type substitution to use when analysing+             --    the RHS of specialised bindings (no type-let!)+++       , se_interesting :: VarSet+             -- Dict Ids that we know something about+             -- and hence may be worth specialising against+             -- See Note [Interesting dictionary arguments]+     }++specVar :: SpecEnv -> Id -> CoreExpr+specVar env v = CoreSubst.lookupIdSubst (text "specVar") (se_subst env) v++specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)++---------------- First the easy cases --------------------+specExpr env (Type ty)     = return (Type     (substTy env ty), emptyUDs)+specExpr env (Coercion co) = return (Coercion (substCo env co), emptyUDs)+specExpr env (Var v)       = return (specVar env v, emptyUDs)+specExpr _   (Lit lit)     = return (Lit lit,       emptyUDs)+specExpr env (Cast e co)+  = do { (e', uds) <- specExpr env e+       ; return ((mkCast e' (substCo env co)), uds) }+specExpr env (Tick tickish body)+  = do { (body', uds) <- specExpr env body+       ; return (Tick (specTickish env tickish) body', uds) }++---------------- Applications might generate a call instance --------------------+specExpr env expr@(App {})+  = go expr []+  where+    go (App fun arg) args = do (arg', uds_arg) <- specExpr env arg+                               (fun', uds_app) <- go fun (arg':args)+                               return (App fun' arg', uds_arg `plusUDs` uds_app)++    go (Var f)       args = case specVar env f of+                                Var f' -> return (Var f', mkCallUDs env f' args)+                                e'     -> return (e', emptyUDs) -- I don't expect this!+    go other         _    = specExpr env other++---------------- Lambda/case require dumping of usage details --------------------+specExpr env e@(Lam _ _) = do+    (body', uds) <- specExpr env' body+    let (free_uds, dumped_dbs) = dumpUDs bndrs' uds+    return (mkLams bndrs' (wrapDictBindsE dumped_dbs body'), free_uds)+  where+    (bndrs, body) = collectBinders e+    (env', bndrs') = substBndrs env bndrs+        -- More efficient to collect a group of binders together all at once+        -- and we don't want to split a lambda group with dumped bindings++specExpr env (Case scrut case_bndr ty alts)+  = do { (scrut', scrut_uds) <- specExpr env scrut+       ; (scrut'', case_bndr', alts', alts_uds)+             <- specCase env scrut' case_bndr alts+       ; return (Case scrut'' case_bndr' (substTy env ty) alts'+                , scrut_uds `plusUDs` alts_uds) }++---------------- Finally, let is the interesting case --------------------+specExpr env (Let bind body)+  = do { -- Clone binders+         (rhs_env, body_env, bind') <- cloneBindSM env bind++         -- Deal with the body+       ; (body', body_uds) <- specExpr body_env body++        -- Deal with the bindings+      ; (binds', uds) <- specBind rhs_env bind' body_uds++        -- All done+      ; return (foldr Let body' binds', uds) }++specTickish :: SpecEnv -> Tickish Id -> Tickish Id+specTickish env (Breakpoint ix ids)+  = Breakpoint ix [ id' | id <- ids, Var id' <- [specVar env id]]+  -- drop vars from the list if they have a non-variable substitution.+  -- should never happen, but it's harmless to drop them anyway.+specTickish _ other_tickish = other_tickish++specCase :: SpecEnv+         -> CoreExpr            -- Scrutinee, already done+         -> Id -> [CoreAlt]+         -> SpecM ( CoreExpr    -- New scrutinee+                  , Id+                  , [CoreAlt]+                  , UsageDetails)+specCase env scrut' case_bndr [(con, args, rhs)]+  | isDictId case_bndr           -- See Note [Floating dictionaries out of cases]+  , interestingDict env scrut'+  , not (isDeadBinder case_bndr && null sc_args')+  = do { (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args')++       ; let sc_rhss = [ Case (Var case_bndr_flt) case_bndr' (idType sc_arg')+                              [(con, args', Var sc_arg')]+                       | sc_arg' <- sc_args' ]++             -- Extend the substitution for RHS to map the *original* binders+             -- to their floated verions.+             mb_sc_flts :: [Maybe DictId]+             mb_sc_flts = map (lookupVarEnv clone_env) args'+             clone_env  = zipVarEnv sc_args' sc_args_flt+             subst_prs  = (case_bndr, Var case_bndr_flt)+                        : [ (arg, Var sc_flt)+                          | (arg, Just sc_flt) <- args `zip` mb_sc_flts ]+             env_rhs' = env_rhs { se_subst = CoreSubst.extendIdSubstList (se_subst env_rhs) subst_prs+                                , se_interesting = se_interesting env_rhs `extendVarSetList`+                                                   (case_bndr_flt : sc_args_flt) }++       ; (rhs', rhs_uds)   <- specExpr env_rhs' rhs+       ; let scrut_bind    = mkDB (NonRec case_bndr_flt scrut')+             case_bndr_set = unitVarSet case_bndr_flt+             sc_binds      = [(NonRec sc_arg_flt sc_rhs, case_bndr_set)+                             | (sc_arg_flt, sc_rhs) <- sc_args_flt `zip` sc_rhss ]+             flt_binds     = scrut_bind : sc_binds+             (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds+             all_uds = flt_binds `addDictBinds` free_uds+             alt'    = (con, args', wrapDictBindsE dumped_dbs rhs')+       ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) }+  where+    (env_rhs, (case_bndr':args')) = substBndrs env (case_bndr:args)+    sc_args' = filter is_flt_sc_arg args'++    clone_me bndr = do { uniq <- getUniqueM+                       ; return (mkUserLocalOrCoVar occ uniq ty loc) }+       where+         name = idName bndr+         ty   = idType bndr+         occ  = nameOccName name+         loc  = getSrcSpan name++    arg_set = mkVarSet args'+    is_flt_sc_arg var =  isId var+                      && not (isDeadBinder var)+                      && isDictTy var_ty+                      && not (tyCoVarsOfType var_ty `intersectsVarSet` arg_set)+       where+         var_ty = idType var+++specCase env scrut case_bndr alts+  = do { (alts', uds_alts) <- mapAndCombineSM spec_alt alts+       ; return (scrut, case_bndr', alts', uds_alts) }+  where+    (env_alt, case_bndr') = substBndr env case_bndr+    spec_alt (con, args, rhs) = do+          (rhs', uds) <- specExpr env_rhs rhs+          let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds+          return ((con, args', wrapDictBindsE dumped_dbs rhs'), free_uds)+        where+          (env_rhs, args') = substBndrs env_alt args++{-+Note [Floating dictionaries out of cases]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   g = \d. case d of { MkD sc ... -> ...(f sc)... }+Naively we can't float d2's binding out of the case expression,+because 'sc' is bound by the case, and that in turn means we can't+specialise f, which seems a pity.++So we invert the case, by floating out a binding+for 'sc_flt' thus:+    sc_flt = case d of { MkD sc ... -> sc }+Now we can float the call instance for 'f'.  Indeed this is just+what'll happen if 'sc' was originally bound with a let binding,+but case is more efficient, and necessary with equalities. So it's+good to work with both.++You might think that this won't make any difference, because the+call instance will only get nuked by the \d.  BUT if 'g' itself is+specialised, then transitively we should be able to specialise f.++In general, given+   case e of cb { MkD sc ... -> ...(f sc)... }+we transform to+   let cb_flt = e+       sc_flt = case cb_flt of { MkD sc ... -> sc }+   in+   case cb_flt of bg { MkD sc ... -> ....(f sc_flt)... }++The "_flt" things are the floated binds; we use the current substitution+to substitute sc -> sc_flt in the RHS++************************************************************************+*                                                                      *+                     Dealing with a binding+*                                                                      *+************************************************************************+-}++specBind :: SpecEnv                     -- Use this for RHSs+         -> CoreBind                    -- Binders are already cloned by cloneBindSM,+                                        -- but RHSs are un-processed+         -> UsageDetails                -- Info on how the scope of the binding+         -> SpecM ([CoreBind],          -- New bindings+                   UsageDetails)        -- And info to pass upstream++-- Returned UsageDetails:+--    No calls for binders of this bind+specBind rhs_env (NonRec fn rhs) body_uds+  = do { (rhs', rhs_uds) <- specExpr rhs_env rhs+       ; (fn', spec_defns, body_uds1) <- specDefn rhs_env body_uds fn rhs++       ; let pairs = spec_defns ++ [(fn', rhs')]+                        -- fn' mentions the spec_defns in its rules,+                        -- so put the latter first++             combined_uds = body_uds1 `plusUDs` rhs_uds++             (free_uds, dump_dbs, float_all) = dumpBindUDs [fn] combined_uds++             final_binds :: [DictBind]+             -- See Note [From non-recursive to recursive]+             final_binds+               | not (isEmptyBag dump_dbs)+               , not (null spec_defns)+               = [recWithDumpedDicts pairs dump_dbs]+               | otherwise+               = [mkDB $ NonRec b r | (b,r) <- pairs]+                 ++ bagToList dump_dbs++       ; if float_all then+             -- Rather than discard the calls mentioning the bound variables+             -- we float this (dictionary) binding along with the others+              return ([], free_uds `snocDictBinds` final_binds)+         else+             -- No call in final_uds mentions bound variables,+             -- so we can just leave the binding here+              return (map fst final_binds, free_uds) }+++specBind rhs_env (Rec pairs) body_uds+       -- Note [Specialising a recursive group]+  = do { let (bndrs,rhss) = unzip pairs+       ; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rhs_env) rhss+       ; let scope_uds = body_uds `plusUDs` rhs_uds+                       -- Includes binds and calls arising from rhss++       ; (bndrs1, spec_defns1, uds1) <- specDefns rhs_env scope_uds pairs++       ; (bndrs3, spec_defns3, uds3)+             <- if null spec_defns1  -- Common case: no specialisation+                then return (bndrs1, [], uds1)+                else do {            -- Specialisation occurred; do it again+                          (bndrs2, spec_defns2, uds2)+                              <- specDefns rhs_env uds1 (bndrs1 `zip` rhss)+                        ; return (bndrs2, spec_defns2 ++ spec_defns1, uds2) }++       ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs uds3+             final_bind = recWithDumpedDicts (spec_defns3 ++ zip bndrs3 rhss')+                                             dumped_dbs++       ; if float_all then+              return ([], final_uds `snocDictBind` final_bind)+         else+              return ([fst final_bind], final_uds) }+++---------------------------+specDefns :: SpecEnv+          -> UsageDetails               -- Info on how it is used in its scope+          -> [(OutId,InExpr)]           -- The things being bound and their un-processed RHS+          -> SpecM ([OutId],            -- Original Ids with RULES added+                    [(OutId,OutExpr)],  -- Extra, specialised bindings+                    UsageDetails)       -- Stuff to fling upwards from the specialised versions++-- Specialise a list of bindings (the contents of a Rec), but flowing usages+-- upwards binding by binding.  Example: { f = ...g ...; g = ...f .... }+-- Then if the input CallDetails has a specialised call for 'g', whose specialisation+-- in turn generates a specialised call for 'f', we catch that in this one sweep.+-- But not vice versa (it's a fixpoint problem).++specDefns _env uds []+  = return ([], [], uds)+specDefns env uds ((bndr,rhs):pairs)+  = do { (bndrs1, spec_defns1, uds1) <- specDefns env uds pairs+       ; (bndr1, spec_defns2, uds2)  <- specDefn env uds1 bndr rhs+       ; return (bndr1 : bndrs1, spec_defns1 ++ spec_defns2, uds2) }++---------------------------+specDefn :: SpecEnv+         -> UsageDetails                -- Info on how it is used in its scope+         -> OutId -> InExpr             -- The thing being bound and its un-processed RHS+         -> SpecM (Id,                  -- Original Id with added RULES+                   [(Id,CoreExpr)],     -- Extra, specialised bindings+                   UsageDetails)        -- Stuff to fling upwards from the specialised versions++specDefn env body_uds fn rhs+  = do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds+             rules_for_me = idCoreRules fn+       ; (rules, spec_defns, spec_uds) <- specCalls Nothing env rules_for_me+                                                    calls_for_me fn rhs+       ; return ( fn `addIdSpecialisations` rules+                , spec_defns+                , body_uds_without_me `plusUDs` spec_uds) }+                -- It's important that the `plusUDs` is this way+                -- round, because body_uds_without_me may bind+                -- dictionaries that are used in calls_for_me passed+                -- to specDefn.  So the dictionary bindings in+                -- spec_uds may mention dictionaries bound in+                -- body_uds_without_me++---------------------------+specCalls :: Maybe Module      -- Just this_mod  =>  specialising imported fn+                               -- Nothing        =>  specialising local fn+          -> SpecEnv+          -> [CoreRule]        -- Existing RULES for the fn+          -> [CallInfo]+          -> OutId -> InExpr+          -> SpecM SpecInfo    -- New rules, specialised bindings, and usage details++-- This function checks existing rules, and does not create+-- duplicate ones. So the caller does not need to do this filtering.+-- See 'already_covered'++type SpecInfo = ( [CoreRule]       -- Specialisation rules+                , [(Id,CoreExpr)]  -- Specialised definition+                , UsageDetails )   -- Usage details from specialised RHSs++specCalls mb_mod env existing_rules calls_for_me fn rhs+        -- The first case is the interesting one+  |  rhs_tyvars `lengthIs`      n_tyvars -- Rhs of fn's defn has right number of big lambdas+  && rhs_bndrs1 `lengthAtLeast` n_dicts -- and enough dict args+  && notNull calls_for_me               -- And there are some calls to specialise+  && not (isNeverActive (idInlineActivation fn))+        -- Don't specialise NOINLINE things+        -- See Note [Auto-specialisation and RULES]++--   && not (certainlyWillInline (idUnfolding fn))      -- And it's not small+--      See Note [Inline specialisation] for why we do not+--      switch off specialisation for inline functions++  = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $+    foldlM spec_call ([], [], emptyUDs) calls_for_me++  | otherwise   -- No calls or RHS doesn't fit our preconceptions+  = WARN( not (exprIsTrivial rhs) && notNull calls_for_me,+          text "Missed specialisation opportunity for"+                                 <+> ppr fn $$ _trace_doc )+          -- Note [Specialisation shape]+    -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $+    return ([], [], emptyUDs)+  where+    _trace_doc = sep [ ppr rhs_tyvars, ppr n_tyvars+                     , ppr rhs_bndrs, ppr n_dicts+                     , ppr (idInlineActivation fn) ]++    fn_type                 = idType fn+    fn_arity                = idArity fn+    fn_unf                  = realIdUnfolding fn  -- Ignore loop-breaker-ness here+    (tyvars, theta, _)      = tcSplitSigmaTy fn_type+    n_tyvars                = length tyvars+    n_dicts                 = length theta+    inl_prag                = idInlinePragma fn+    inl_act                 = inlinePragmaActivation inl_prag+    is_local                = isLocalId fn++        -- Figure out whether the function has an INLINE pragma+        -- See Note [Inline specialisations]++    (rhs_bndrs, rhs_body)      = collectBindersPushingCo rhs+                                 -- See Note [Account for casts in binding]+    (rhs_tyvars, rhs_bndrs1)   = span isTyVar rhs_bndrs+    (rhs_dict_ids, rhs_bndrs2) = splitAt n_dicts rhs_bndrs1+    body                       = mkLams rhs_bndrs2 rhs_body+                                 -- Glue back on the non-dict lambdas++    in_scope = CoreSubst.substInScope (se_subst env)++    already_covered :: DynFlags -> [CoreRule] -> [CoreExpr] -> Bool+    already_covered dflags new_rules args      -- Note [Specialisations already covered]+       = isJust (lookupRule dflags (in_scope, realIdUnfolding)+                            (const True) fn args+                            (new_rules ++ existing_rules))+         -- NB: we look both in the new_rules (generated by this invocation+         --     of specCalls), and in existing_rules (passed in to specCalls)++    mk_ty_args :: [Maybe Type] -> [TyVar] -> [CoreExpr]+    mk_ty_args [] poly_tvs+      = ASSERT( null poly_tvs ) []+    mk_ty_args (Nothing : call_ts) (poly_tv : poly_tvs)+      = Type (mkTyVarTy poly_tv) : mk_ty_args call_ts poly_tvs+    mk_ty_args (Just ty : call_ts) poly_tvs+      = Type ty : mk_ty_args call_ts poly_tvs+    mk_ty_args (Nothing : _) [] = panic "mk_ty_args"++    ----------------------------------------------------------+        -- Specialise to one particular call pattern+    spec_call :: SpecInfo                         -- Accumulating parameter+              -> CallInfo                         -- Call instance+              -> SpecM SpecInfo+    spec_call spec_acc@(rules_acc, pairs_acc, uds_acc)+              (CI { ci_key = CallKey call_ts, ci_args = call_ds })+      = ASSERT( call_ts `lengthIs` n_tyvars  && call_ds `lengthIs` n_dicts )++        -- Suppose f's defn is  f = /\ a b c -> \ d1 d2 -> rhs+        -- Suppose the call is for f [Just t1, Nothing, Just t3] [dx1, dx2]++        -- Construct the new binding+        --      f1 = SUBST[a->t1,c->t3, d1->d1', d2->d2'] (/\ b -> rhs)+        -- PLUS the rule+        --      RULE "SPEC f" forall b d1' d2'. f b d1' d2' = f1 b+        --      In the rule, d1' and d2' are just wildcards, not used in the RHS+        -- PLUS the usage-details+        --      { d1' = dx1; d2' = dx2 }+        -- where d1', d2' are cloned versions of d1,d2, with the type substitution+        -- applied.  These auxiliary bindings just avoid duplication of dx1, dx2+        --+        -- Note that the substitution is applied to the whole thing.+        -- This is convenient, but just slightly fragile.  Notably:+        --      * There had better be no name clashes in a/b/c+        do { let+                -- poly_tyvars = [b] in the example above+                -- spec_tyvars = [a,c]+                -- ty_args     = [t1,b,t3]+                spec_tv_binds = [(tv,ty) | (tv, Just ty) <- rhs_tyvars `zip` call_ts]+                env1          = extendTvSubstList env spec_tv_binds+                (rhs_env, poly_tyvars) = substBndrs env1+                                            [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts]++             -- Clone rhs_dicts, including instantiating their types+           ; inst_dict_ids <- mapM (newDictBndr rhs_env) rhs_dict_ids+           ; let (rhs_env2, dx_binds, spec_dict_args)+                            = bindAuxiliaryDicts rhs_env rhs_dict_ids call_ds inst_dict_ids+                 ty_args    = mk_ty_args call_ts poly_tyvars+                 ev_args    = map varToCoreExpr inst_dict_ids  -- ev_args, ev_bndrs:+                 ev_bndrs   = exprsFreeIdsList ev_args         -- See Note [Evidence foralls]+                 rule_args  = ty_args     ++ ev_args+                 rule_bndrs = poly_tyvars ++ ev_bndrs++           ; dflags <- getDynFlags+           ; if already_covered dflags rules_acc rule_args+             then return spec_acc+             else -- pprTrace "spec_call" (vcat [ ppr _call_info, ppr fn, ppr rhs_dict_ids+                  --                           , text "rhs_env2" <+> ppr (se_subst rhs_env2)+                  --                           , ppr dx_binds ]) $+                  do+           {    -- Figure out the type of the specialised function+             let body_ty = applyTypeToArgs rhs fn_type rule_args+                 (lam_args, app_args)           -- Add a dummy argument if body_ty is unlifted+                   | isUnliftedType body_ty     -- C.f. WwLib.mkWorkerArgs+                   , not (isJoinId fn)+                   = (poly_tyvars ++ [voidArgId], poly_tyvars ++ [voidPrimId])+                   | otherwise = (poly_tyvars, poly_tyvars)+                 spec_id_ty = mkLamTypes lam_args body_ty+                 join_arity_change = length app_args - length rule_args+                 spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn+                                 = Just (orig_join_arity + join_arity_change)+                                 | otherwise+                                 = Nothing++           ; spec_f <- newSpecIdSM fn spec_id_ty spec_join_arity+           ; (spec_rhs, rhs_uds) <- specExpr rhs_env2 (mkLams lam_args body)+           ; this_mod <- getModule+           ; let+                -- The rule to put in the function's specialisation is:+                --      forall b, d1',d2'.  f t1 b t3 d1' d2' = f1 b+                herald = case mb_mod of+                           Nothing        -- Specialising local fn+                               -> text "SPEC"+                           Just this_mod  -- Specialising imoprted fn+                               -> text "SPEC/" <> ppr this_mod++                rule_name = mkFastString $ showSDoc dflags $+                            herald <+> ftext (occNameFS (getOccName fn))+                                   <+> hsep (map ppr_call_key_ty call_ts)+                            -- This name ends up in interface files, so use occNameString.+                            -- Otherwise uniques end up there, making builds+                            -- less deterministic (See #4012 comment:61 ff)++                rule_wout_eta = mkRule+                                  this_mod+                                  True {- Auto generated -}+                                  is_local+                                  rule_name+                                  inl_act       -- Note [Auto-specialisation and RULES]+                                  (idName fn)+                                  rule_bndrs+                                  rule_args+                                  (mkVarApps (Var spec_f) app_args)++                spec_rule+                  = case isJoinId_maybe fn of+                      Just join_arity -> etaExpandToJoinPointRule join_arity+                                                                  rule_wout_eta+                      Nothing -> rule_wout_eta++                -- Add the { d1' = dx1; d2' = dx2 } usage stuff+                spec_uds = foldr consDictBind rhs_uds dx_binds++                --------------------------------------+                -- Add a suitable unfolding if the spec_inl_prag says so+                -- See Note [Inline specialisations]+                (spec_inl_prag, spec_unf)+                  | not is_local && isStrongLoopBreaker (idOccInfo fn)+                  = (neverInlinePragma, noUnfolding)+                        -- See Note [Specialising imported functions] in OccurAnal++                  | InlinePragma { inl_inline = Inlinable } <- inl_prag+                  = (inl_prag { inl_inline = EmptyInlineSpec }, noUnfolding)++                  | otherwise+                  = (inl_prag, specUnfolding poly_tyvars spec_app+                                             arity_decrease fn_unf)++                arity_decrease = length spec_dict_args+                spec_app e = (e `mkApps` ty_args) `mkApps` spec_dict_args++                --------------------------------------+                -- Adding arity information just propagates it a bit faster+                --      See Note [Arity decrease] in Simplify+                -- Copy InlinePragma information from the parent Id.+                -- So if f has INLINE[1] so does spec_f+                spec_f_w_arity = spec_f `setIdArity`      max 0 (fn_arity - n_dicts)+                                        `setInlinePragma` spec_inl_prag+                                        `setIdUnfolding`  spec_unf+                                        `asJoinId_maybe`  spec_join_arity++           ; return ( spec_rule                  : rules_acc+                    , (spec_f_w_arity, spec_rhs) : pairs_acc+                    , spec_uds           `plusUDs` uds_acc+                    ) } }++{- Note [Account for casts in binding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f :: Eq a => a -> IO ()+   {-# INLINABLE f+       StableUnf = (/\a \(d:Eq a) (x:a). blah) |> g+     #-}+   f = ...++In f's stable unfolding we have done some modest simplification which+has pushed the cast to the outside.  (I wonder if this is the Right+Thing, but it's what happens now; see SimplUtils Note [Casts and+lambdas].)  Now that stable unfolding must be specialised, so we want+to push the cast back inside. It would be terrible if the cast+defeated specialisation!  Hence the use of collectBindersPushingCo.++Note [Evidence foralls]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose (Trac #12212) that we are specialising+   f :: forall a b. (Num a, F a ~ F b) => blah+with a=b=Int. Then the RULE will be something like+   RULE forall (d:Num Int) (g :: F Int ~ F Int).+        f Int Int d g = f_spec+But both varToCoreExpr (when constructing the LHS args), and the+simplifier (when simplifying the LHS args), will transform to+   RULE forall (d:Num Int) (g :: F Int ~ F Int).+        f Int Int d <F 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.+-}++bindAuxiliaryDicts+        :: SpecEnv+        -> [DictId] -> [CoreExpr]   -- Original dict bndrs, and the witnessing expressions+        -> [DictId]                 -- A cloned dict-id for each dict arg+        -> (SpecEnv,                -- Substitute for all orig_dicts+            [DictBind],             -- Auxiliary dict bindings+            [CoreExpr])             -- Witnessing expressions (all trivial)+-- Bind any dictionary arguments to fresh names, to preserve sharing+bindAuxiliaryDicts env@(SE { se_subst = subst, se_interesting = interesting })+                   orig_dict_ids call_ds inst_dict_ids+  = (env', dx_binds, spec_dict_args)+  where+    (dx_binds, spec_dict_args) = go call_ds inst_dict_ids+    env' = env { se_subst = subst `CoreSubst.extendSubstList`+                                     (orig_dict_ids `zip` spec_dict_args)+                                  `CoreSubst.extendInScopeList` dx_ids+               , se_interesting = interesting `unionVarSet` interesting_dicts }++    dx_ids = [dx_id | (NonRec dx_id _, _) <- dx_binds]+    interesting_dicts = mkVarSet [ dx_id | (NonRec dx_id dx, _) <- dx_binds+                                 , interestingDict env dx ]+                  -- See Note [Make the new dictionaries interesting]++    go :: [CoreExpr] -> [CoreBndr] -> ([DictBind], [CoreExpr])+    go [] _  = ([], [])+    go (dx:dxs) (dx_id:dx_ids)+      | exprIsTrivial dx = (dx_binds,                          dx        : args)+      | otherwise        = (mkDB (NonRec dx_id dx) : dx_binds, Var dx_id : args)+      where+        (dx_binds, args) = go dxs dx_ids+             -- In the first case extend the substitution but not bindings;+             -- in the latter extend the bindings but not the substitution.+             -- For the former, note that we bind the *original* dict in the substitution,+             -- overriding any d->dx_id binding put there by substBndrs+    go _ _ = pprPanic "bindAuxiliaryDicts" (ppr orig_dict_ids $$ ppr call_ds $$ ppr inst_dict_ids)++{-+Note [Make the new dictionaries interesting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Important!  We're going to substitute dx_id1 for d+and we want it to look "interesting", else we won't gather *any*+consequential calls. E.g.+    f d = ...g d....+If we specialise f for a call (f (dfun dNumInt)), we'll get+a consequent call (g d') with an auxiliary definition+    d' = df dNumInt+We want that consequent call to look interesting+++Note [From non-recursive to recursive]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Even in the non-recursive case, if any dict-binds depend on 'fn' we might+have built a recursive knot++      f a d x = <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]+~~~~~~~~~~~~~~~~~~~~~+When specialising /dictionary functions/ we must be very careful to+avoid building loops. Here is an example that bit us badly: Trac #3591++     class Eq a => C a+     instance Eq [a] => C [a]++This translates to+     dfun :: Eq [a] -> C [a]+     dfun a d = MkD a d (meth d)++     d4 :: Eq [T] = <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'++--------------+Here's another example, this time for an imported dfun, so the call+to filterCalls is in specImports (Trac #13429). Suppose we have+  class Monoid v => C v a where ...++We start with a call+   f @ [Integer] @ Integer $fC[]Integer++Specialising call to 'f' gives dict bindings+   $dMonoid_1 :: Monoid [Integer]+   $dMonoid_1 = M.$p1C @ [Integer] $fC[]Integer++   $dC_1 :: C [Integer] (Node [Integer] Integer)+   $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1++...plus a recursive call to+   f @ [Integer] @ (Node [Integer] Integer) $dC_1++Specialising that call gives+   $dMonoid_2  :: Monoid [Integer]+   $dMonoid_2  = M.$p1C @ [Integer] $dC_1++   $dC_2 :: C [Integer] (Node [Integer] Integer)+   $dC_2 = M.$fCvNode @ [Integer] $dMonoid_2++Now we have two calls to the imported function+  M.$fCvNode :: Monoid v => C v a+  M.$fCvNode @v @a m = C m some_fun++But we must /not/ use the call (M.$fCvNode @ [Integer] $dMonoid_2)+for specialisation, else we get:++  $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1+  $dMonoid_2 = M.$p1C @ [Integer] $dC_1+  $s$fCvNode = C $dMonoid_2 ...+    RULE M.$fCvNode [Integer] _ _ = $s$fCvNode++Now use the rule to rewrite the call in the RHS of $dC_1+and we get a loop!++--------------+Here's yet another example++  class C a where { foo,bar :: [a] -> [a] }++  instance C Int where+     foo x = r_bar x+     bar xs = reverse xs++  r_bar :: C a => [a] -> [a]+  r_bar xs = bar (xs ++ xs)++That translates to:++    r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs)++    Rec { $fCInt :: C Int = MkC foo_help reverse+          foo_help (xs::[Int]) = r_bar Int $fCInt xs }++The call (r_bar $fCInt) mentions $fCInt,+                        which mentions foo_help,+                        which mentions r_bar+But we DO want to specialise r_bar at Int:++    Rec { $fCInt :: C Int = MkC foo_help reverse+          foo_help (xs::[Int]) = r_bar Int $fCInt xs++          r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs)+            RULE r_bar Int _ = r_bar_Int++          r_bar_Int xs = bar Int $fCInt (xs ++ xs)+           }++Note that, because of its RULE, r_bar joins the recursive+group.  (In this case it'll unravel a short moment later.)+++Note [Specialising a recursive group]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    let rec { f x = ...g x'...+            ; g y = ...f y'.... }+    in f 'a'+Here we specialise 'f' at Char; but that is very likely to lead to+a specialisation of 'g' at Char.  We must do the latter, else the+whole point of specialisation is lost.++But we do not want to keep iterating to a fixpoint, because in the+presence of polymorphic recursion we might generate an infinite number+of specialisations.++So we use the following heuristic:+  * Arrange the rec block in dependency order, so far as possible+    (the occurrence analyser already does this)++  * Specialise it much like a sequence of lets++  * Then go through the block a second time, feeding call-info from+    the RHSs back in the bottom, as it were++In effect, the ordering maxmimises the effectiveness of each sweep,+and we do just two sweeps.   This should catch almost every case of+monomorphic recursion -- the exception could be a very knotted-up+recursion with multiple cycles tied up together.++This plan is implemented in the Rec case of specBindItself.++Note [Specialisations already covered]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We obviously don't want to generate two specialisations for the same+argument pattern.  There are two wrinkles++1. We do the already-covered test in specDefn, not when we generate+the CallInfo in mkCallUDs.  We used to test in the latter place, but+we now iterate the specialiser somewhat, and the Id at the call site+might therefore not have all the RULES that we can see in specDefn++2. What about two specialisations where the second is an *instance*+of the first?  If the more specific one shows up first, we'll generate+specialisations for both.  If the *less* specific one shows up first,+we *don't* currently generate a specialisation for the more specific+one.  (See the call to lookupRule in already_covered.)  Reasons:+  (a) lookupRule doesn't say which matches are exact (bad reason)+  (b) if the earlier specialisation is user-provided, it's+      far from clear that we should auto-specialise further++Note [Auto-specialisation and RULES]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:+   g :: Num a => a -> a+   g = ...++   f :: (Int -> Int) -> Int+   f w = ...+   {-# RULE f g = 0 #-}++Suppose that auto-specialisation makes a specialised version of+g::Int->Int That version won't appear in the LHS of the RULE for f.+So if the specialisation rule fires too early, the rule for f may+never fire.++It might be possible to add new rules, to "complete" the rewrite system.+Thus when adding+        RULE forall d. g Int d = g_spec+also add+        RULE f g_spec = 0++But that's a bit complicated.  For now we ask the programmer's help,+by *copying the INLINE activation pragma* to the auto-specialised+rule.  So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule+will also not be active until phase 2.  And that's what programmers+should jolly well do anyway, even aside from specialisation, to ensure+that g doesn't inline too early.++This in turn means that the RULE would never fire for a NOINLINE+thing so not much point in generating a specialisation at all.++Note [Specialisation shape]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We only specialise a function if it has visible top-level lambdas+corresponding to its overloading.  E.g. if+        f :: forall a. Eq a => ....+then its body must look like+        f = /\a. \d. ...++Reason: when specialising the body for a call (f ty dexp), we want to+substitute dexp for d, and pick up specialised calls in the body of f.++This doesn't always work.  One example I came across was this:+        newtype Gen a = MkGen{ unGen :: Int -> a }++        choose :: Eq a => a -> Gen a+        choose n = MkGen (\r -> n)++        oneof = choose (1::Int)++It's a silly exapmle, but we get+        choose = /\a. g `cast` co+where choose doesn't have any dict arguments.  Thus far I have not+tried to fix this (wait till there's a real example).++Mind you, then 'choose' will be inlined (since RHS is trivial) so+it doesn't matter.  This comes up with single-method classes++   class C a where { op :: a -> a }+   instance C a => C [a] where ....+==>+   $fCList :: C a => C [a]+   $fCList = $copList |> (...coercion>...)+   ....(uses of $fCList at particular types)...++So we suppress the WARN if the rhs is trivial.++Note [Inline specialisations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is what we do with the InlinePragma of the original function+  * Activation/RuleMatchInfo: both transferred to the+                              specialised function+  * InlineSpec:+       (a) An INLINE pragma is transferred+       (b) An INLINABLE pragma is *not* transferred++Why (a): transfer INLINE pragmas? The point of INLINE was precisely to+specialise the function at its call site, and arguably that's not so+important for the specialised copies.  BUT *pragma-directed*+specialisation now takes place in the typechecker/desugarer, with+manually specified INLINEs.  The specialisation here is automatic.+It'd be very odd if a function marked INLINE was specialised (because+of some local use), and then forever after (including importing+modules) the specialised version wasn't INLINEd.  After all, the+programmer said INLINE!++You might wonder why we specialise INLINE functions at all.  After+all they should be inlined, right?  Two reasons:++ * Even INLINE functions are sometimes not inlined, when they aren't+   applied to interesting arguments.  But perhaps the type arguments+   alone are enough to specialise (even though the args are too boring+   to trigger inlining), and it's certainly better to call the+   specialised version.++ * The RHS of an INLINE function might call another overloaded function,+   and we'd like to generate a specialised version of that function too.+   This actually happens a lot. Consider+      replicateM_ :: (Monad m) => Int -> m a -> m ()+      {-# INLINABLE replicateM_ #-}+      replicateM_ d x ma = ...+   The strictness analyser may transform to+      replicateM_ :: (Monad m) => Int -> m a -> m ()+      {-# INLINE replicateM_ #-}+      replicateM_ d x ma = case x of I# x' -> $wreplicateM_ d x' ma++      $wreplicateM_ :: (Monad m) => Int# -> m a -> m ()+      {-# INLINABLE $wreplicateM_ #-}+      $wreplicateM_ = ...+   Now an importing module has a specialised call to replicateM_, say+   (replicateM_ dMonadIO).  We certainly want to specialise $wreplicateM_!+   This particular example had a huge effect on the call to replicateM_+   in nofib/shootout/n-body.++Why (b): discard INLINABLE pragmas? See Trac #4874 for persuasive examples.+Suppose we have+    {-# INLINABLE f #-}+    f :: Ord a => [a] -> Int+    f xs = letrec f' = ...f'... in f'+Then, when f is specialised and optimised we might get+    wgo :: [Int] -> Int#+    wgo = ...wgo...+    f_spec :: [Int] -> Int+    f_spec xs = case wgo xs of { r -> I# r }+and we clearly want to inline f_spec at call sites.  But if we still+have the big, un-optimised of f (albeit specialised) captured in an+INLINABLE pragma for f_spec, we won't get that optimisation.++So we simply drop INLINABLE pragmas when specialising. It's not really+a complete solution; ignoring specialisation for now, INLINABLE functions+don't get properly strictness analysed, for example. But it works well+for examples involving specialisation, which is the dominant use of+INLINABLE.  See Trac #4874.+++************************************************************************+*                                                                      *+\subsubsection{UsageDetails and suchlike}+*                                                                      *+************************************************************************+-}++data UsageDetails+  = MkUD {+      ud_binds :: !(Bag DictBind),+               -- See Note [Floated dictionary bindings]+               -- The order is important;+               -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1+               -- (Remember, Bags preserve order in GHC.)++      ud_calls :: !CallDetails++      -- INVARIANT: suppose bs = bindersOf ud_binds+      -- Then 'calls' may *mention* 'bs',+      -- but there should be no calls *for* bs+    }++-- | A 'DictBind' is a binding along with a cached set containing its free+-- variables (both type variables and dictionaries)+type DictBind = (CoreBind, VarSet)++{- Note [Floated dictionary bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We float out dictionary bindings for the reasons described under+"Dictionary floating" above.  But not /just/ dictionary bindings.+Consider++   f :: Eq a => blah+   f a d = rhs++   $c== :: T -> T -> Bool+   $c== x y = ...++   $df :: Eq T+   $df = Eq $c== ...++   gurgle = ...(f @T $df)...++We gather the call info for (f @T $df), and we don't want to drop it+when we come across the binding for $df.  So we add $df to the floats+and continue.  But then we have to add $c== to the floats, and so on.+These all float above the binding for 'f', and and now we can+successfullly specialise 'f'.++So the DictBinds in (ud_binds :: Bag DictBind) may contain+non-dictionary bindings too.+-}++instance Outputable UsageDetails where+  ppr (MkUD { ud_binds = dbs, ud_calls = calls })+        = text "MkUD" <+> braces (sep (punctuate comma+                [text "binds" <+> equals <+> ppr dbs,+                 text "calls" <+> equals <+> ppr calls]))++emptyUDs :: UsageDetails+emptyUDs = MkUD { ud_binds = emptyBag, ud_calls = emptyDVarEnv }++------------------------------------------------------------+type CallDetails  = DIdEnv CallInfoSet+  -- The order of specialized binds and rules depends on how we linearize+  -- CallDetails, so to get determinism we must use a deterministic set here.+  -- See Note [Deterministic UniqFM] in UniqDFM++data CallInfoSet = CIS Id (Bag CallInfo)+  -- The list of types and dictionaries is guaranteed to+  -- match the type of f+  -- The Bag may contain duplicate calls (i.e. f @T and another f @T)+  -- These dups are eliminated by already_covered in specCalls++data CallInfo+  = CI { ci_key  :: CallKey     -- Type arguments+       , ci_args :: [DictExpr]  -- Dictionary arguments+       , ci_fvs  :: VarSet      -- Free vars of the ci_key and ci_args+                                -- call (including tyvars)+                                -- [*not* include the main id itself, of course]+    }++newtype CallKey   = CallKey [Maybe Type]+  -- Nothing => unconstrained type argument++type DictExpr = CoreExpr++ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet+ciSetFilter p (CIS id a) = CIS id (filterBag p a)++instance Outputable CallInfoSet where+  ppr (CIS fn map) = hang (text "CIS" <+> ppr fn)+                        2 (ppr map)++pprCallInfo :: Id -> CallInfo -> SDoc+pprCallInfo fn (CI { ci_key = key })+  = ppr fn <+> ppr key++ppr_call_key_ty :: Maybe Type -> SDoc+ppr_call_key_ty Nothing   = char '_'+ppr_call_key_ty (Just ty) = char '@' <+> pprParendType ty++instance Outputable CallKey where+  ppr (CallKey ts) = brackets (fsep (map ppr_call_key_ty ts))++instance Outputable CallInfo where+  ppr (CI { ci_key = key, ci_args = args, ci_fvs = fvs })+    = text "CI" <> braces (hsep [ ppr key, ppr args, ppr fvs ])++unionCalls :: CallDetails -> CallDetails -> CallDetails+unionCalls c1 c2 = plusDVarEnv_C unionCallInfoSet c1 c2++unionCallInfoSet :: CallInfoSet -> CallInfoSet -> CallInfoSet+unionCallInfoSet (CIS f calls1) (CIS _ calls2) =+  CIS f (calls1 `unionBags` calls2)++callDetailsFVs :: CallDetails -> VarSet+callDetailsFVs calls =+  nonDetFoldUDFM (unionVarSet . callInfoFVs) emptyVarSet calls+  -- It's OK to use nonDetFoldUDFM here because we forget the ordering+  -- immediately by converting to a nondeterministic set.++callInfoFVs :: CallInfoSet -> VarSet+callInfoFVs (CIS _ call_info) =+  foldrBag (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info++------------------------------------------------------------+singleCall :: Id -> [Maybe Type] -> [DictExpr] -> UsageDetails+singleCall id tys dicts+  = MkUD {ud_binds = emptyBag,+          ud_calls = unitDVarEnv id $ CIS id $+                     unitBag (CI { ci_key = CallKey tys+                                 , ci_args = dicts+                                 , ci_fvs  = call_fvs }) }+  where+    call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs+    tys_fvs  = tyCoVarsOfTypes (catMaybes tys)+        -- The type args (tys) are guaranteed to be part of the dictionary+        -- types, because they are just the constrained types,+        -- and the dictionary is therefore sure to be bound+        -- inside the binding for any type variables free in the type;+        -- hence it's safe to neglect tyvars free in tys when making+        -- the free-var set for this call+        -- BUT I don't trust this reasoning; play safe and include tys_fvs+        --+        -- We don't include the 'id' itself.++mkCallUDs, mkCallUDs' :: SpecEnv -> Id -> [CoreExpr] -> UsageDetails+mkCallUDs env f args+  = -- pprTrace "mkCallUDs" (vcat [ ppr f, ppr args, ppr res ])+    res+  where+    res = mkCallUDs' env f args++mkCallUDs' env f args+  | not (want_calls_for f)  -- Imported from elsewhere+  || null theta             -- Not overloaded+  = emptyUDs++  |  not (all type_determines_value theta)+  || not (spec_tys `lengthIs` n_tyvars)+  || not ( dicts   `lengthIs` n_dicts)+  || not (any (interestingDict env) dicts)    -- Note [Interesting dictionary arguments]+  -- See also Note [Specialisations already covered]+  = -- pprTrace "mkCallUDs: discarding" _trace_doc+    emptyUDs    -- Not overloaded, or no specialisation wanted++  | otherwise+  = -- pprTrace "mkCallUDs: keeping" _trace_doc+    singleCall f spec_tys dicts+  where+    _trace_doc = vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts+                      , ppr (map (interestingDict env) dicts)]+    (tyvars, theta, _)      = tcSplitSigmaTy (idType f)+    constrained_tyvars      = tyCoVarsOfTypes theta+    n_tyvars                = length tyvars+    n_dicts                 = length theta++    spec_tys = [mk_spec_ty tv ty | (tv, ty) <- tyvars `type_zip` args]+    dicts    = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)]++    -- ignores Coercion arguments+    type_zip :: [TyVar] -> [CoreExpr] -> [(TyVar, Type)]+    type_zip tvs      (Coercion _ : args) = type_zip tvs args+    type_zip (tv:tvs) (Type ty : args)    = (tv, ty) : type_zip tvs args+    type_zip _        _                   = []++    mk_spec_ty tyvar ty+        | tyvar `elemVarSet` constrained_tyvars = Just ty+        | otherwise                             = Nothing++    want_calls_for f = isLocalId f || isJust (maybeUnfoldingTemplate (realIdUnfolding f))+         -- For imported things, we gather call instances if+         -- there is an unfolding that we could in principle specialise+         -- We might still decide not to use it (consulting dflags)+         -- in specImports+         -- Use 'realIdUnfolding' to ignore the loop-breaker flag!++    type_determines_value pred    -- See Note [Type determines value]+        = case classifyPredType pred of+            ClassPred cls _ -> not (isIPClass cls)  -- Superclasses can't be IPs+            EqPred {}       -> True+            IrredPred {}    -> True   -- Things like (D []) where D is a+                                      -- Constraint-ranged family; Trac #7785++{-+Note [Type determines value]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Only specialise if all overloading is on non-IP *class* params,+because these are the ones whose *type* determines their *value*.  In+parrticular, with implicit params, the type args *don't* say what the+value of the implicit param is!  See Trac #7101++However, consider+         type family D (v::*->*) :: Constraint+         type instance D [] = ()+         f :: D v => v Char -> Int+If we see a call (f "foo"), we'll pass a "dictionary"+  () |> (g :: () ~ D [])+and it's good to specialise f at this dictionary.++So the question is: can an implicit parameter "hide inside" a+type-family constraint like (D a).  Well, no.  We don't allow+        type instance D Maybe = ?x:Int+Hence the IrredPred case in type_determines_value.+See Trac #7785.++Note [Interesting dictionary arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this+         \a.\d:Eq a.  let f = ... in ...(f d)...+There really is not much point in specialising f wrt the dictionary d,+because the code for the specialised f is not improved at all, because+d is lambda-bound.  We simply get junk specialisations.++What is "interesting"?  Just that it has *some* structure.  But what about+variables?++ * A variable might be imported, in which case its unfolding+   will tell us whether it has useful structure++ * Local variables are cloned on the way down (to avoid clashes when+   we float dictionaries), and cloning drops the unfolding+   (cloneIdBndr).  Moreover, we make up some new bindings, and it's a+   nuisance to give them unfoldings.  So we keep track of the+   "interesting" dictionaries as a VarSet in SpecEnv.+   We have to take care to put any new interesting dictionary+   bindings in the set.++We accidentally lost accurate tracking of local variables for a long+time, because cloned variables don't have unfoldings. But makes a+massive difference in a few cases, eg Trac #5113. For nofib as a+whole it's only a small win: 2.2% improvement in allocation for ansi,+1.2% for bspt, but mostly 0.0!  Average 0.1% increase in binary size.+-}++interestingDict :: SpecEnv -> CoreExpr -> Bool+-- A dictionary argument is interesting if it has *some* structure+-- NB: "dictionary" arguments include constraints of all sorts,+--     including equality constraints; hence the Coercion case+interestingDict env (Var v) =  hasSomeUnfolding (idUnfolding v)+                            || isDataConWorkId v+                            || v `elemVarSet` se_interesting env+interestingDict _ (Type _)                = False+interestingDict _ (Coercion _)            = False+interestingDict env (App fn (Type _))     = interestingDict env fn+interestingDict env (App fn (Coercion _)) = interestingDict env fn+interestingDict env (Tick _ a)            = interestingDict env a+interestingDict env (Cast e _)            = interestingDict env e+interestingDict _ _                       = True++plusUDs :: UsageDetails -> UsageDetails -> UsageDetails+plusUDs (MkUD {ud_binds = db1, ud_calls = calls1})+        (MkUD {ud_binds = db2, ud_calls = calls2})+  = MkUD { ud_binds = db1    `unionBags`   db2+         , ud_calls = calls1 `unionCalls`  calls2 }++-----------------------------+_dictBindBndrs :: Bag DictBind -> [Id]+_dictBindBndrs dbs = foldrBag ((++) . bindersOf . fst) [] dbs++-- | Construct a 'DictBind' from a 'CoreBind'+mkDB :: CoreBind -> DictBind+mkDB bind = (bind, bind_fvs bind)++-- | Identify the free variables of a 'CoreBind'+bind_fvs :: CoreBind -> VarSet+bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs)+bind_fvs (Rec prs)         = foldl delVarSet rhs_fvs bndrs+                           where+                             bndrs = map fst prs+                             rhs_fvs = unionVarSets (map pair_fvs prs)++pair_fvs :: (Id, CoreExpr) -> VarSet+pair_fvs (bndr, rhs) = exprSomeFreeVars interesting rhs+                       `unionVarSet` idFreeVars bndr+        -- idFreeVars: don't forget variables mentioned in+        -- the rules of the bndr.  C.f. OccAnal.addRuleUsage+        -- Also tyvars mentioned in its type; they may not appear+        -- in the RHS+        --      type T a = Int+        --      x :: T a = 3+  where+    interesting :: InterestingVarFun+    interesting v = isLocalVar v || (isId v && isDFunId v)+        -- Very important: include DFunIds /even/ if it is imported+        -- Reason: See Note [Avoiding loops], the second exmaple+        --         involving an imported dfun.  We must know whether+        --         a dictionary binding depends on an imported dfun,+        --         in case we try to specialise that imported dfun+        --         Trac #13429 illustrates++-- | Flatten a set of "dumped" 'DictBind's, and some other binding+-- pairs, into a single recursive binding.+recWithDumpedDicts :: [(Id,CoreExpr)] -> Bag DictBind ->DictBind+recWithDumpedDicts pairs dbs+  = (Rec bindings, fvs)+  where+    (bindings, fvs) = foldrBag add+                               ([], emptyVarSet)+                               (dbs `snocBag` mkDB (Rec pairs))+    add (NonRec b r, fvs') (pairs, fvs) =+      ((b,r) : pairs, fvs `unionVarSet` fvs')+    add (Rec prs1,   fvs') (pairs, fvs) =+      (prs1 ++ pairs, fvs `unionVarSet` fvs')++snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails+-- Add ud_binds to the tail end of the bindings in uds+snocDictBinds uds dbs+  = uds { ud_binds = ud_binds uds `unionBags` listToBag dbs }++consDictBind :: DictBind -> UsageDetails -> UsageDetails+consDictBind bind uds = uds { ud_binds = bind `consBag` ud_binds uds }++addDictBinds :: [DictBind] -> UsageDetails -> UsageDetails+addDictBinds binds uds = uds { ud_binds = listToBag binds `unionBags` ud_binds uds }++snocDictBind :: UsageDetails -> DictBind -> UsageDetails+snocDictBind uds bind = uds { ud_binds = ud_binds uds `snocBag` bind }++wrapDictBinds :: Bag DictBind -> [CoreBind] -> [CoreBind]+wrapDictBinds dbs binds+  = foldrBag add binds dbs+  where+    add (bind,_) binds = bind : binds++wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr+wrapDictBindsE dbs expr+  = foldrBag add expr dbs+  where+    add (bind,_) expr = Let bind expr++----------------------+dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind)+-- Used at a lambda or case binder; just dump anything mentioning the binder+dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })+  | null bndrs = (uds, emptyBag)  -- Common in case alternatives+  | otherwise  = -- pprTrace "dumpUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $+                 (free_uds, dump_dbs)+  where+    free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls }+    bndr_set = mkVarSet bndrs+    (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set+    free_calls = deleteCallsMentioning dump_set $   -- Drop calls mentioning bndr_set on the floor+                 deleteCallsFor bndrs orig_calls    -- Discard calls for bndr_set; there should be+                                                    -- no calls for any of the dicts in dump_dbs++dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool)+-- Used at a let(rec) binding.+-- We return a boolean indicating whether the binding itself is mentioned+-- is mentioned, directly or indirectly, by any of the ud_calls; in that+-- case we want to float the binding itself;+-- See Note [Floated dictionary bindings]+dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })+  = -- pprTrace "dumpBindUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $+    (free_uds, dump_dbs, float_all)+  where+    free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls }+    bndr_set = mkVarSet bndrs+    (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set+    free_calls = deleteCallsFor bndrs orig_calls+    float_all = dump_set `intersectsVarSet` callDetailsFVs free_calls++callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo])+callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })+  = -- pprTrace ("callsForMe")+    --          (vcat [ppr fn,+    --                 text "Orig dbs ="     <+> ppr (_dictBindBndrs orig_dbs),+    --                 text "Orig calls ="   <+> ppr orig_calls,+    --                 text "Dep set ="      <+> ppr dep_set,+    --                 text "Calls for me =" <+> ppr calls_for_me]) $+    (uds_without_me, calls_for_me)+  where+    uds_without_me = MkUD { ud_binds = orig_dbs+                          , ud_calls = delDVarEnv orig_calls fn }+    calls_for_me = case lookupDVarEnv orig_calls fn of+                        Nothing -> []+                        Just cis -> filterCalls cis orig_dbs+         -- filterCalls: drop calls that (directly or indirectly)+         -- refer to fn.  See Note [Avoiding loops]++----------------------+filterCalls :: CallInfoSet -> Bag DictBind -> [CallInfo]+-- See Note [Avoiding loops]+filterCalls (CIS fn call_bag) dbs+  = filter ok_call (bagToList call_bag)+  where+    dump_set = foldlBag go (unitVarSet fn) dbs+      -- This dump-set could also be computed by splitDictBinds+      --   (_,_,dump_set) = splitDictBinds dbs {fn}+      -- But this variant is shorter++    go so_far (db,fvs) | fvs `intersectsVarSet` so_far+                       = extendVarSetList so_far (bindersOf db)+                       | otherwise = so_far++    ok_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` dump_set)++----------------------+splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet)+-- splitDictBinds dbs bndrs returns+--   (free_dbs, dump_dbs, dump_set)+-- where+--   * dump_dbs depends, transitively on bndrs+--   * free_dbs does not depend on bndrs+--   * dump_set = bndrs `union` bndrs(dump_dbs)+splitDictBinds dbs bndr_set+   = foldlBag split_db (emptyBag, emptyBag, bndr_set) dbs+                -- Important that it's foldl not foldr;+                -- we're accumulating the set of dumped ids in dump_set+   where+    split_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs)+        | dump_idset `intersectsVarSet` fvs     -- Dump it+        = (free_dbs, dump_dbs `snocBag` db,+           extendVarSetList dump_idset (bindersOf bind))++        | otherwise     -- Don't dump it+        = (free_dbs `snocBag` db, dump_dbs, dump_idset)+++----------------------+deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails+-- Remove calls *mentioning* bs in any way+deleteCallsMentioning bs calls+  = mapDVarEnv (ciSetFilter keep_call) calls+  where+    keep_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` bs)++deleteCallsFor :: [Id] -> CallDetails -> CallDetails+-- Remove calls *for* bs+deleteCallsFor bs calls = delDVarEnvList calls bs++{-+************************************************************************+*                                                                      *+\subsubsection{Boring helper functions}+*                                                                      *+************************************************************************+-}++newtype SpecM a = SpecM (State SpecState a)++data SpecState = SpecState {+                     spec_uniq_supply :: UniqSupply,+                     spec_module :: Module,+                     spec_dflags :: DynFlags+                 }++instance Functor SpecM where+    fmap = liftM++instance Applicative SpecM where+    pure x = SpecM $ return x+    (<*>) = ap++instance Monad SpecM where+    SpecM x >>= f = SpecM $ do y <- x+                               case f y of+                                   SpecM z ->+                                       z+    fail str = SpecM $ fail str++#if __GLASGOW_HASKELL__ > 710+instance MonadFail.MonadFail SpecM where+    fail str = SpecM $ fail str+#endif++instance MonadUnique SpecM where+    getUniqueSupplyM+        = SpecM $ do st <- get+                     let (us1, us2) = splitUniqSupply $ spec_uniq_supply st+                     put $ st { spec_uniq_supply = us2 }+                     return us1++    getUniqueM+        = SpecM $ do st <- get+                     let (u,us') = takeUniqFromSupply $ spec_uniq_supply st+                     put $ st { spec_uniq_supply = us' }+                     return u++instance HasDynFlags SpecM where+    getDynFlags = SpecM $ liftM spec_dflags get++instance HasModule SpecM where+    getModule = SpecM $ liftM spec_module get++runSpecM :: DynFlags -> Module -> SpecM a -> CoreM a+runSpecM dflags this_mod (SpecM spec)+    = do us <- getUniqueSupplyM+         let initialState = SpecState {+                                spec_uniq_supply = us,+                                spec_module = this_mod,+                                spec_dflags = dflags+                            }+         return $ evalState spec initialState++mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)+mapAndCombineSM _ []     = return ([], emptyUDs)+mapAndCombineSM f (x:xs) = do (y, uds1) <- f x+                              (ys, uds2) <- mapAndCombineSM f xs+                              return (y:ys, uds1 `plusUDs` uds2)++extendTvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv+extendTvSubstList env tv_binds+  = env { se_subst = CoreSubst.extendTvSubstList (se_subst env) tv_binds }++substTy :: SpecEnv -> Type -> Type+substTy env ty = CoreSubst.substTy (se_subst env) ty++substCo :: SpecEnv -> Coercion -> Coercion+substCo env co = CoreSubst.substCo (se_subst env) co++substBndr :: SpecEnv -> CoreBndr -> (SpecEnv, CoreBndr)+substBndr env bs = case CoreSubst.substBndr (se_subst env) bs of+                      (subst', bs') -> (env { se_subst = subst' }, bs')++substBndrs :: SpecEnv -> [CoreBndr] -> (SpecEnv, [CoreBndr])+substBndrs env bs = case CoreSubst.substBndrs (se_subst env) bs of+                      (subst', bs') -> (env { se_subst = subst' }, bs')++cloneBindSM :: SpecEnv -> CoreBind -> SpecM (SpecEnv, SpecEnv, CoreBind)+-- Clone the binders of the bind; return new bind with the cloned binders+-- Return the substitution to use for RHSs, and the one to use for the body+cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (NonRec bndr rhs)+  = do { us <- getUniqueSupplyM+       ; let (subst', bndr') = CoreSubst.cloneIdBndr subst us bndr+             interesting' | interestingDict env rhs+                          = interesting `extendVarSet` bndr'+                          | otherwise = interesting+       ; return (env, env { se_subst = subst', se_interesting = interesting' }+                , NonRec bndr' rhs) }++cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (Rec pairs)+  = do { us <- getUniqueSupplyM+       ; let (subst', bndrs') = CoreSubst.cloneRecIdBndrs subst us (map fst pairs)+             env' = env { se_subst = subst'+                        , se_interesting = interesting `extendVarSetList`+                                           [ v | (v,r) <- pairs, interestingDict env r ] }+       ; return (env', env', Rec (bndrs' `zip` map snd pairs)) }++newDictBndr :: SpecEnv -> CoreBndr -> SpecM CoreBndr+-- Make up completely fresh binders for the dictionaries+-- Their bindings are going to float outwards+newDictBndr env b = do { uniq <- getUniqueM+                       ; let n   = idName b+                             ty' = substTy env (idType b)+                       ; return (mkUserLocalOrCoVar (nameOccName n) uniq ty' (getSrcSpan n)) }++newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id+    -- Give the new Id a similar occurrence name to the old one+newSpecIdSM old_id new_ty join_arity_maybe+  = do  { uniq <- getUniqueM+        ; let name    = idName old_id+              new_occ = mkSpecOcc (nameOccName name)+              new_id  = mkUserLocalOrCoVar new_occ uniq new_ty (getSrcSpan name)+                          `asJoinId_maybe` join_arity_maybe+        ; return new_id }++{-+                Old (but interesting) stuff about unboxed bindings+                ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++What should we do when a value is specialised to a *strict* unboxed value?++        map_*_* f (x:xs) = let h = f x+                               t = map f xs+                           in h:t++Could convert let to case:++        map_*_Int# f (x:xs) = case f x of h# ->+                              let t = map f xs+                              in h#:t++This may be undesirable since it forces evaluation here, but the value+may not be used in all branches of the body. In the general case this+transformation is impossible since the mutual recursion in a letrec+cannot be expressed as a case.++There is also a problem with top-level unboxed values, since our+implementation cannot handle unboxed values at the top level.++Solution: Lift the binding of the unboxed value and extract it when it+is used:++        map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#+                                  t = map f xs+                              in case h of+                                 _Lift h# -> h#:t++Now give it to the simplifier and the _Lifting will be optimised away.++The benefit is that we have given the specialised "unboxed" values a+very simple lifted semantics and then leave it up to the simplifier to+optimise it --- knowing that the overheads will be removed in nearly+all cases.++In particular, the value will only be evaluated in the branches of the+program which use it, rather than being forced at the point where the+value is bound. For example:++        filtermap_*_* p f (x:xs)+          = let h = f x+                t = ...+            in case p x of+                True  -> h:t+                False -> t+   ==>+        filtermap_*_Int# p f (x:xs)+          = let h = case (f x) of h# -> _Lift h#+                t = ...+            in case p x of+                True  -> case h of _Lift h#+                           -> h#:t+                False -> t++The binding for h can still be inlined in the one branch and the+_Lifting eliminated.+++Question: When won't the _Lifting be eliminated?++Answer: When they at the top-level (where it is necessary) or when+inlining would duplicate work (or possibly code depending on+options). However, the _Lifting will still be eliminated if the+strictness analyser deems the lifted binding strict.+-}
+ stgSyn/CoreToStg.hs view
@@ -0,0 +1,1025 @@+{-# LANGUAGE CPP #-}++--+-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998+--++--------------------------------------------------------------+-- Converting Core to STG Syntax+--------------------------------------------------------------++-- And, as we have the info in hand, we may convert some lets to+-- let-no-escapes.++module CoreToStg ( coreToStg, coreExprToStg ) where++#include "HsVersions.h"++import CoreSyn+import CoreUtils        ( exprType, findDefault, isJoinBind )+import CoreArity        ( manifestArity )+import StgSyn++import Type+import RepType+import TyCon+import MkId             ( coercionTokenId )+import Id+import IdInfo+import DataCon+import CostCentre       ( noCCS )+import VarEnv+import Module+import Name             ( isExternalName, nameOccName )+import OccName          ( occNameFS )+import BasicTypes       ( Arity )+import TysWiredIn       ( unboxedUnitDataCon )+import Literal+import Outputable+import MonadUtils+import FastString+import Util+import DynFlags+import ForeignCall+import Demand           ( isUsedOnce )+import PrimOp           ( PrimCall(..) )+import UniqFM++import Data.Maybe    (isJust, fromMaybe)+import Control.Monad (liftM, ap)++-- Note [Live vs free]+-- ~~~~~~~~~~~~~~~~~~~+--+-- The two are not the same. Liveness is an operational property rather+-- than a semantic one. A variable is live at a particular execution+-- point if it can be referred to directly again. In particular, a dead+-- variable's stack slot (if it has one):+--+--           - should be stubbed to avoid space leaks, and+--           - may be reused for something else.+--+-- There ought to be a better way to say this. Here are some examples:+--+--         let v = [q] \[x] -> e+--         in+--         ...v...  (but no q's)+--+-- Just after the `in', v is live, but q is dead. If the whole of that+-- let expression was enclosed in a case expression, thus:+--+--         case (let v = [q] \[x] -> e in ...v...) of+--                 alts[...q...]+--+-- (ie `alts' mention `q'), then `q' is live even after the `in'; because+-- we'll return later to the `alts' and need it.+--+-- Let-no-escapes make this a bit more interesting:+--+--         let-no-escape v = [q] \ [x] -> e+--         in+--         ...v...+--+-- Here, `q' is still live at the `in', because `v' is represented not by+-- a closure but by the current stack state.  In other words, if `v' is+-- live then so is `q'. Furthermore, if `e' mentions an enclosing+-- let-no-escaped variable, then its free variables are also live if `v' is.++-- Note [What are these SRTs all about?]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Consider the Core program,+--+--     fibs = go 1 1+--       where go a b = let c = a + c+--                      in c : go b c+--     add x = map (\y -> x*y) fibs+--+-- In this case we have a CAF, 'fibs', which is quite large after evaluation and+-- has only one possible user, 'add'. Consequently, we want to ensure that when+-- all references to 'add' die we can garbage collect any bit of 'fibs' that we+-- have evaluated.+--+-- However, how do we know whether there are any references to 'fibs' still+-- around? Afterall, the only reference to it is buried in the code generated+-- for 'add'. The answer is that we record the CAFs referred to by a definition+-- in its info table, namely a part of it known as the Static Reference Table+-- (SRT).+--+-- Since SRTs are so common, we use a special compact encoding for them in: we+-- produce one table containing a list of CAFs in a module and then include a+-- bitmap in each info table describing which entries of this table the closure+-- references.+--+-- See also: Commentary/Rts/Storage/GC/CAFs on the GHC Wiki.++-- Note [Collecting live CAF info]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- In this pass we also collect information on which CAFs are live.+--+-- A top-level Id has CafInfo, which is+--+--         - MayHaveCafRefs, if it may refer indirectly to+--           one or more CAFs, or+--         - NoCafRefs if it definitely doesn't+--+-- The CafInfo has already been calculated during the CoreTidy pass.+--+-- During CoreToStg, we then pin onto each binding and case expression, a+-- list of Ids which represents the "live" CAFs at that point.  The meaning+-- of "live" here is the same as for live variables, see above (which is+-- why it's convenient to collect CAF information here rather than elsewhere).+--+-- The later SRT pass takes these lists of Ids and uses them to construct+-- the actual nested SRTs, and replaces the lists of Ids with (offset,length)+-- pairs.++-- Note [What is a non-escaping let]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- NB: Nowadays this is recognized by the occurrence analyser by turning a+-- "non-escaping let" into a join point. The following is then an operational+-- account of join points.+--+-- Consider:+--+--     let x = fvs \ args -> e+--     in+--         if ... then x else+--            if ... then x else ...+--+-- `x' is used twice (so we probably can't unfold it), but when it is+-- entered, the stack is deeper than it was when the definition of `x'+-- happened.  Specifically, if instead of allocating a closure for `x',+-- we saved all `x's fvs on the stack, and remembered the stack depth at+-- that moment, then whenever we enter `x' we can simply set the stack+-- pointer(s) to these remembered (compile-time-fixed) values, and jump+-- to the code for `x'.+--+-- All of this is provided x is:+--   1. non-updatable;+--   2. guaranteed to be entered before the stack retreats -- ie x is not+--      buried in a heap-allocated closure, or passed as an argument to+--      something;+--   3. all the enters have exactly the right number of arguments,+--      no more no less;+--   4. all the enters are tail calls; that is, they return to the+--      caller enclosing the definition of `x'.+--+-- Under these circumstances we say that `x' is non-escaping.+--+-- An example of when (4) does not hold:+--+--     let x = ...+--     in case x of ...alts...+--+-- Here, `x' is certainly entered only when the stack is deeper than when+-- `x' is defined, but here it must return to ...alts... So we can't just+-- adjust the stack down to `x''s recalled points, because that would lost+-- alts' context.+--+-- Things can get a little more complicated.  Consider:+--+--     let y = ...+--     in let x = fvs \ args -> ...y...+--     in ...x...+--+-- Now, if `x' is used in a non-escaping way in ...x..., and `y' is used in a+-- non-escaping way in ...y..., then `y' is non-escaping.+--+-- `x' can even be recursive!  Eg:+--+--     letrec x = [y] \ [v] -> if v then x True else ...+--     in+--         ...(x b)...++-- --------------------------------------------------------------+-- Setting variable info: top-level, binds, RHSs+-- --------------------------------------------------------------++coreToStg :: DynFlags -> Module -> CoreProgram -> [StgTopBinding]+coreToStg dflags this_mod pgm+  = pgm'+  where (_, _, pgm') = coreTopBindsToStg dflags this_mod emptyVarEnv pgm++coreExprToStg :: CoreExpr -> StgExpr+coreExprToStg expr+  = new_expr where (new_expr,_) = initCts emptyVarEnv (coreToStgExpr expr)+++coreTopBindsToStg+    :: DynFlags+    -> Module+    -> IdEnv HowBound           -- environment for the bindings+    -> CoreProgram+    -> (IdEnv HowBound, FreeVarsInfo, [StgTopBinding])++coreTopBindsToStg _      _        env [] = (env, emptyFVInfo, [])+coreTopBindsToStg dflags this_mod env (b:bs)+  = (env2, fvs2, b':bs')+  where+        -- Notice the mutually-recursive "knot" here:+        --   env accumulates down the list of binds,+        --   fvs accumulates upwards+        (env1, fvs2, b' ) = coreTopBindToStg dflags this_mod env fvs1 b+        (env2, fvs1, bs') = coreTopBindsToStg dflags this_mod env1 bs++coreTopBindToStg+        :: DynFlags+        -> Module+        -> IdEnv HowBound+        -> FreeVarsInfo         -- Info about the body+        -> CoreBind+        -> (IdEnv HowBound, FreeVarsInfo, StgTopBinding)++coreTopBindToStg _ _ env body_fvs (NonRec id (Lit (MachStr str)))+  -- top-level string literal+  = let+        env' = extendVarEnv env id how_bound+        how_bound = LetBound TopLet 0+    in (env', body_fvs, StgTopStringLit id str)++coreTopBindToStg dflags this_mod env body_fvs (NonRec id rhs)+  = let+        env'      = extendVarEnv env id how_bound+        how_bound = LetBound TopLet $! manifestArity rhs++        (stg_rhs, fvs') =+            initCts env $ do+              (stg_rhs, fvs') <- coreToTopStgRhs dflags this_mod body_fvs (id,rhs)+              return (stg_rhs, fvs')++        bind = StgTopLifted $ StgNonRec id stg_rhs+    in+    ASSERT2(consistentCafInfo id bind, ppr id )+      -- NB: previously the assertion printed 'rhs' and 'bind'+      --     as well as 'id', but that led to a black hole+      --     where printing the assertion error tripped the+      --     assertion again!+    (env', fvs' `unionFVInfo` body_fvs, bind)++coreTopBindToStg dflags this_mod env body_fvs (Rec pairs)+  = ASSERT( not (null pairs) )+    let+        binders = map fst pairs++        extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)+                     | (b, rhs) <- pairs ]+        env' = extendVarEnvList env extra_env'++        (stg_rhss, fvs')+          = initCts env' $ do+               (stg_rhss, fvss') <- mapAndUnzipM (coreToTopStgRhs dflags this_mod body_fvs) pairs+               let fvs' = unionFVInfos fvss'+               return (stg_rhss, fvs')++        bind = StgTopLifted $ StgRec (zip binders stg_rhss)+    in+    ASSERT2(consistentCafInfo (head binders) bind, ppr binders)+    (env', fvs' `unionFVInfo` body_fvs, bind)+++-- Assertion helper: this checks that the CafInfo on the Id matches+-- what CoreToStg has figured out about the binding's SRT.  The+-- CafInfo will be exact in all cases except when CorePrep has+-- floated out a binding, in which case it will be approximate.+consistentCafInfo :: Id -> GenStgTopBinding Var Id -> Bool+consistentCafInfo id bind+  = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy )+    safe+  where+    safe  = id_marked_caffy || not binding_is_caffy+    exact = id_marked_caffy == binding_is_caffy+    id_marked_caffy  = mayHaveCafRefs (idCafInfo id)+    binding_is_caffy = topStgBindHasCafRefs bind+    is_sat_thing = occNameFS (nameOccName (idName id)) == fsLit "sat"++coreToTopStgRhs+        :: DynFlags+        -> Module+        -> FreeVarsInfo         -- Free var info for the scope of the binding+        -> (Id,CoreExpr)+        -> CtsM (StgRhs, FreeVarsInfo)++coreToTopStgRhs dflags this_mod scope_fv_info (bndr, rhs)+  = do { (new_rhs, rhs_fvs) <- coreToStgExpr rhs++       ; let stg_rhs   = mkTopStgRhs dflags this_mod rhs_fvs bndr bndr_info new_rhs+             stg_arity = stgRhsArity stg_rhs+       ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,+                 rhs_fvs) }+  where+    bndr_info = lookupFVInfo scope_fv_info bndr++        -- It's vital that the arity on a top-level Id matches+        -- the arity of the generated STG binding, else an importing+        -- module will use the wrong calling convention+        --      (Trac #2844 was an example where this happened)+        -- NB1: we can't move the assertion further out without+        --      blocking the "knot" tied in coreTopBindsToStg+        -- NB2: the arity check is only needed for Ids with External+        --      Names, because they are externally visible.  The CorePrep+        --      pass introduces "sat" things with Local Names and does+        --      not bother to set their Arity info, so don't fail for those+    arity_ok stg_arity+       | isExternalName (idName bndr) = id_arity == stg_arity+       | otherwise                    = True+    id_arity  = idArity bndr+    mk_arity_msg stg_arity+        = vcat [ppr bndr,+                text "Id arity:" <+> ppr id_arity,+                text "STG arity:" <+> ppr stg_arity]++mkTopStgRhs :: DynFlags -> Module -> FreeVarsInfo+            -> Id -> StgBinderInfo -> StgExpr+            -> StgRhs++mkTopStgRhs dflags this_mod = mkStgRhs' con_updateable+        -- Dynamic StgConApps are updatable+  where con_updateable con args = isDllConApp dflags this_mod con args++-- ---------------------------------------------------------------------------+-- Expressions+-- ---------------------------------------------------------------------------++coreToStgExpr+        :: CoreExpr+        -> CtsM (StgExpr,       -- Decorated STG expr+                 FreeVarsInfo)  -- Its free vars (NB free, not live)++-- The second and third components can be derived in a simple bottom up pass, not+-- dependent on any decisions about which variables will be let-no-escaped or+-- not.  The first component, that is, the decorated expression, may then depend+-- on these components, but it in turn is not scrutinised as the basis for any+-- decisions.  Hence no black holes.++-- No LitInteger's should be left by the time this is called. CorePrep+-- should have converted them all to a real core representation.+coreToStgExpr (Lit (LitInteger {})) = panic "coreToStgExpr: LitInteger"+coreToStgExpr (Lit l)      = return (StgLit l, emptyFVInfo)+coreToStgExpr (Var v)      = coreToStgApp Nothing v               [] []+coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId [] []++coreToStgExpr expr@(App _ _)+  = coreToStgApp Nothing f args ticks+  where+    (f, args, ticks) = myCollectArgs expr++coreToStgExpr expr@(Lam _ _)+  = let+        (args, body) = myCollectBinders expr+        args'        = filterStgBinders args+    in+    extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do+    (body, body_fvs) <- coreToStgExpr body+    let+        fvs             = args' `minusFVBinders` body_fvs+        result_expr | null args' = body+                    | otherwise  = StgLam args' body++    return (result_expr, fvs)++coreToStgExpr (Tick tick expr)+  = do case tick of+         HpcTick{}    -> return ()+         ProfNote{}   -> return ()+         SourceNote{} -> return ()+         Breakpoint{} -> panic "coreToStgExpr: breakpoint should not happen"+       (expr2, fvs) <- coreToStgExpr expr+       return (StgTick tick expr2, fvs)++coreToStgExpr (Cast expr _)+  = coreToStgExpr expr++-- Cases require a little more real work.++coreToStgExpr (Case scrut _ _ [])+  = coreToStgExpr scrut+    -- See Note [Empty case alternatives] in CoreSyn If the case+    -- alternatives are empty, the scrutinee must diverge or raise an+    -- exception, so we can just dive into it.+    --+    -- Of course this may seg-fault if the scrutinee *does* return.  A+    -- belt-and-braces approach would be to move this case into the+    -- code generator, and put a return point anyway that calls a+    -- runtime system error function.+++coreToStgExpr (Case scrut bndr _ alts) = do+    (alts2, alts_fvs)+       <- extendVarEnvCts [(bndr, LambdaBound)] $ do+            (alts2, fvs_s) <- mapAndUnzipM vars_alt alts+            return ( alts2,+                     unionFVInfos fvs_s )+    let+        -- Determine whether the default binder is dead or not+        -- This helps the code generator to avoid generating an assignment+        -- for the case binder (is extremely rare cases) ToDo: remove.+        bndr' | bndr `elementOfFVInfo` alts_fvs = bndr+              | otherwise                       = bndr `setIdOccInfo` IAmDead++        -- Don't consider the default binder as being 'live in alts',+        -- since this is from the point of view of the case expr, where+        -- the default binder is not free.+        alts_fvs_wo_bndr  = bndr `minusFVBinder` alts_fvs++        -- We tell the scrutinee that everything+        -- live in the alts is live in it, too.+    (scrut2, scrut_fvs) <- coreToStgExpr scrut++    return (+      StgCase scrut2 bndr' (mkStgAltType bndr alts) alts2,+      scrut_fvs `unionFVInfo` alts_fvs_wo_bndr+      )+  where+    vars_alt (con, binders, rhs)+      | DataAlt c <- con, c == unboxedUnitDataCon+      = -- This case is a bit smelly.+        -- See Note [Nullary unboxed tuple] in Type.hs+        -- where a nullary tuple is mapped to (State# World#)+        ASSERT( null binders )+        do { (rhs2, rhs_fvs) <- coreToStgExpr rhs+           ; return ((DEFAULT, [], rhs2), rhs_fvs) }+      | otherwise+      = let     -- Remove type variables+            binders' = filterStgBinders binders+        in+        extendVarEnvCts [(b, LambdaBound) | b <- binders'] $ do+        (rhs2, rhs_fvs) <- coreToStgExpr rhs+        return ( (con, binders', rhs2),+                 binders' `minusFVBinders` rhs_fvs )++coreToStgExpr (Let bind body) = do+    coreToStgLet bind body++coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e)++mkStgAltType :: Id -> [CoreAlt] -> AltType+mkStgAltType bndr alts+  | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty+  = MultiValAlt (length prim_reps)  -- always use MultiValAlt for unboxed tuples++  | otherwise+  = case prim_reps of+      [LiftedRep] -> case tyConAppTyCon_maybe (unwrapType bndr_ty) of+        Just tc+          | isAbstractTyCon tc -> look_for_better_tycon+          | isAlgTyCon tc      -> AlgAlt tc+          | otherwise          -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )+                                  PolyAlt+        Nothing                -> PolyAlt+      [unlifted] -> PrimAlt unlifted+      not_unary  -> MultiValAlt (length not_unary)+  where+   bndr_ty   = idType bndr+   prim_reps = typePrimRep bndr_ty++   _is_poly_alt_tycon tc+        =  isFunTyCon tc+        || isPrimTyCon tc   -- "Any" is lifted but primitive+        || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict+                            -- function application where argument has a+                            -- type-family type++   -- Sometimes, the TyCon is a AbstractTyCon which may not have any+   -- constructors inside it.  Then we may get a better TyCon by+   -- grabbing the one from a constructor alternative+   -- if one exists.+   look_for_better_tycon+        | ((DataAlt con, _, _) : _) <- data_alts =+                AlgAlt (dataConTyCon con)+        | otherwise =+                ASSERT(null data_alts)+                PolyAlt+        where+                (data_alts, _deflt) = findDefault alts++-- ---------------------------------------------------------------------------+-- Applications+-- ---------------------------------------------------------------------------++coreToStgApp+         :: Maybe UpdateFlag            -- Just upd <=> this application is+                                        -- the rhs of a thunk binding+                                        --      x = [...] \upd [] -> the_app+                                        -- with specified update flag+        -> Id                           -- Function+        -> [CoreArg]                    -- Arguments+        -> [Tickish Id]                 -- Debug ticks+        -> CtsM (StgExpr, FreeVarsInfo)+++coreToStgApp _ f args ticks = do+    (args', args_fvs, ticks') <- coreToStgArgs args+    how_bound <- lookupVarCts f++    let+        n_val_args       = valArgCount args+        not_letrec_bound = not (isLetBound how_bound)+        fun_fvs = singletonFVInfo f how_bound fun_occ+            -- e.g. (f :: a -> int) (x :: a)+            -- Here the free variables are "f", "x" AND the type variable "a"+            -- coreToStgArgs will deal with the arguments recursively++        -- Mostly, the arity info of a function is in the fn's IdInfo+        -- But new bindings introduced by CoreSat may not have no+        -- arity info; it would do us no good anyway.  For example:+        --      let f = \ab -> e in f+        -- No point in having correct arity info for f!+        -- Hence the hasArity stuff below.+        -- NB: f_arity is only consulted for LetBound things+        f_arity   = stgArity f how_bound+        saturated = f_arity <= n_val_args++        fun_occ+         | not_letrec_bound         = noBinderInfo      -- Uninteresting variable+         | f_arity > 0 && saturated = stgSatOcc -- Saturated or over-saturated function call+         | otherwise                = stgUnsatOcc       -- Unsaturated function or thunk++        res_ty = exprType (mkApps (Var f) args)+        app = case idDetails f of+                DataConWorkId dc+                  | saturated    -> StgConApp dc args'+                                      (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty)))++                -- Some primitive operator that might be implemented as a library call.+                PrimOpId op      -> ASSERT( saturated )+                                    StgOpApp (StgPrimOp op) args' res_ty++                -- A call to some primitive Cmm function.+                FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True)+                                          PrimCallConv _))+                                 -> ASSERT( saturated )+                                    StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty++                -- A regular foreign call.+                FCallId call     -> ASSERT( saturated )+                                    StgOpApp (StgFCallOp call (idUnique f)) args' res_ty++                TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,args')+                _other           -> StgApp f args'+        fvs = fun_fvs  `unionFVInfo` args_fvs++        tapp = foldr StgTick app (ticks ++ ticks')++    -- Forcing these fixes a leak in the code generator, noticed while+    -- profiling for trac #4367+    app `seq` fvs `seq` return (+        tapp,+        fvs+     )++++-- ---------------------------------------------------------------------------+-- Argument lists+-- This is the guy that turns applications into A-normal form+-- ---------------------------------------------------------------------------++coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], FreeVarsInfo, [Tickish Id])+coreToStgArgs []+  = return ([], emptyFVInfo, [])++coreToStgArgs (Type _ : args) = do     -- Type argument+    (args', fvs, ts) <- coreToStgArgs args+    return (args', fvs, ts)++coreToStgArgs (Coercion _ : args)  -- Coercion argument; replace with place holder+  = do { (args', fvs, ts) <- coreToStgArgs args+       ; return (StgVarArg coercionTokenId : args', fvs, ts) }++coreToStgArgs (Tick t e : args)+  = ASSERT( not (tickishIsCode t) )+    do { (args', fvs, ts) <- coreToStgArgs (e : args)+       ; return (args', fvs, t:ts) }++coreToStgArgs (arg : args) = do         -- Non-type argument+    (stg_args, args_fvs, ticks) <- coreToStgArgs args+    (arg', arg_fvs) <- coreToStgExpr arg+    let+        fvs = args_fvs `unionFVInfo` arg_fvs++        (aticks, arg'') = stripStgTicksTop tickishFloatable arg'+        stg_arg = case arg'' of+                       StgApp v []        -> StgVarArg v+                       StgConApp con [] _ -> StgVarArg (dataConWorkId con)+                       StgLit lit         -> StgLitArg lit+                       _                  -> pprPanic "coreToStgArgs" (ppr arg)++        -- WARNING: what if we have an argument like (v `cast` co)+        --          where 'co' changes the representation type?+        --          (This really only happens if co is unsafe.)+        -- Then all the getArgAmode stuff in CgBindery will set the+        -- cg_rep of the CgIdInfo based on the type of v, rather+        -- than the type of 'co'.+        -- This matters particularly when the function is a primop+        -- or foreign call.+        -- Wanted: a better solution than this hacky warning+    let+        arg_ty = exprType arg+        stg_arg_ty = stgArgType stg_arg+        bad_args = (isUnliftedType arg_ty && not (isUnliftedType stg_arg_ty))+                || (typePrimRep arg_ty /= typePrimRep stg_arg_ty)+        -- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted),+        -- and pass it to a function expecting an HValue (arg_ty).  This is ok because+        -- we can treat an unlifted value as lifted.  But the other way round+        -- we complain.+        -- We also want to check if a pointer is cast to a non-ptr etc++    WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg )+     return (stg_arg : stg_args, fvs, ticks ++ aticks)+++-- ---------------------------------------------------------------------------+-- The magic for lets:+-- ---------------------------------------------------------------------------++coreToStgLet+         :: CoreBind    -- bindings+         -> CoreExpr    -- body+         -> CtsM (StgExpr,      -- new let+                  FreeVarsInfo) -- variables free in the whole let++coreToStgLet bind body = do+    (bind2, bind_fvs,+     body2, body_fvs)+       <- mfix $ \ ~(_, _, _, rec_body_fvs) -> do++          ( bind2, bind_fvs, env_ext)+                <- vars_bind rec_body_fvs bind++          -- Do the body+          extendVarEnvCts env_ext $ do+             (body2, body_fvs) <- coreToStgExpr body++             return (bind2, bind_fvs,+                     body2, body_fvs)+++        -- Compute the new let-expression+    let+        new_let | isJoinBind bind = StgLetNoEscape bind2 body2+                | otherwise       = StgLet bind2 body2++        free_in_whole_let+          = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)++    return (+        new_let,+        free_in_whole_let+      )+  where+    binders        = bindersOf bind++    mk_binding binder rhs+        = (binder, LetBound NestedLet (manifestArity rhs))++    vars_bind :: FreeVarsInfo           -- Free var info for body of binding+              -> CoreBind+              -> CtsM (StgBinding,+                       FreeVarsInfo,+                       [(Id, HowBound)])  -- extension to environment+++    vars_bind body_fvs (NonRec binder rhs) = do+        (rhs2, bind_fvs) <- coreToStgRhs body_fvs (binder,rhs)+        let+            env_ext_item = mk_binding binder rhs++        return (StgNonRec binder rhs2,+                bind_fvs, [env_ext_item])+++    vars_bind body_fvs (Rec pairs)+      = mfix $ \ ~(_, rec_rhs_fvs, _) ->+           let+                rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs+                binders = map fst pairs+                env_ext = [ mk_binding b rhs+                          | (b,rhs) <- pairs ]+           in+           extendVarEnvCts env_ext $ do+              (rhss2, fvss)+                     <- mapAndUnzipM (coreToStgRhs rec_scope_fvs) pairs+              let+                        bind_fvs = unionFVInfos fvss++              return (StgRec (binders `zip` rhss2),+                      bind_fvs, env_ext)++coreToStgRhs :: FreeVarsInfo      -- Free var info for the scope of the binding+             -> (Id,CoreExpr)+             -> CtsM (StgRhs, FreeVarsInfo)++coreToStgRhs scope_fv_info (bndr, rhs) = do+    (new_rhs, rhs_fvs) <- coreToStgExpr rhs+    return (mkStgRhs rhs_fvs bndr bndr_info new_rhs, rhs_fvs)+  where+    bndr_info = lookupFVInfo scope_fv_info bndr++mkStgRhs :: FreeVarsInfo -> Id -> StgBinderInfo -> StgExpr -> StgRhs+mkStgRhs = mkStgRhs' con_updateable+  where con_updateable _ _ = False++mkStgRhs' :: (DataCon -> [StgArg] -> Bool)+            -> FreeVarsInfo -> Id -> StgBinderInfo -> StgExpr -> StgRhs+mkStgRhs' con_updateable rhs_fvs bndr binder_info rhs+  | StgLam bndrs body <- rhs+  = StgRhsClosure noCCS binder_info+                   (getFVs rhs_fvs)+                   ReEntrant+                   bndrs body+  | isJoinId bndr -- must be nullary join point+  = ASSERT(idJoinArity bndr == 0)+    StgRhsClosure noCCS binder_info+                   (getFVs rhs_fvs)+                   ReEntrant -- ignored for LNE+                   [] rhs+  | StgConApp con args _ <- unticked_rhs+  , not (con_updateable con args)+  = -- CorePrep does this right, but just to make sure+    ASSERT2( not (isUnboxedTupleCon con || isUnboxedSumCon con)+           , ppr bndr $$ ppr con $$ ppr args)+    StgRhsCon noCCS con args+  | otherwise+  = StgRhsClosure noCCS binder_info+                   (getFVs rhs_fvs)+                   upd_flag [] rhs+ where++    (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs++    upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry+             | otherwise                      = Updatable++  {-+    SDM: disabled.  Eval/Apply can't handle functions with arity zero very+    well; and making these into simple non-updatable thunks breaks other+    assumptions (namely that they will be entered only once).++    upd_flag | isPAP env rhs  = ReEntrant+             | otherwise      = Updatable++-- Detect thunks which will reduce immediately to PAPs, and make them+-- non-updatable.  This has several advantages:+--+--         - the non-updatable thunk behaves exactly like the PAP,+--+--         - the thunk is more efficient to enter, because it is+--           specialised to the task.+--+--         - we save one update frame, one stg_update_PAP, one update+--           and lots of PAP_enters.+--+--         - in the case where the thunk is top-level, we save building+--           a black hole and furthermore the thunk isn't considered to+--           be a CAF any more, so it doesn't appear in any SRTs.+--+-- We do it here, because the arity information is accurate, and we need+-- to do it before the SRT pass to save the SRT entries associated with+-- any top-level PAPs.++isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args+                              where+                                 arity = stgArity f (lookupBinding env f)+isPAP env _               = False++-}++{- ToDo:+          upd = if isOnceDem dem+                    then (if isNotTop toplev+                            then SingleEntry    -- HA!  Paydirt for "dem"+                            else+                     (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $+                     Updatable)+                else Updatable+        -- For now we forbid SingleEntry CAFs; they tickle the+        -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,+        -- and I don't understand why.  There's only one SE_CAF (well,+        -- only one that tickled a great gaping bug in an earlier attempt+        -- at ClosureInfo.getEntryConvention) in the whole of nofib,+        -- specifically Main.lvl6 in spectral/cryptarithm2.+        -- So no great loss.  KSW 2000-07.+-}++-- ---------------------------------------------------------------------------+-- A monad for the core-to-STG pass+-- ---------------------------------------------------------------------------++-- There's a lot of stuff to pass around, so we use this CtsM+-- ("core-to-STG monad") monad to help.  All the stuff here is only passed+-- *down*.++newtype CtsM a = CtsM+    { unCtsM :: IdEnv HowBound+             -> a+    }++data HowBound+  = ImportBound         -- Used only as a response to lookupBinding; never+                        -- exists in the range of the (IdEnv HowBound)++  | LetBound            -- A let(rec) in this module+        LetInfo         -- Whether top level or nested+        Arity           -- Its arity (local Ids don't have arity info at this point)++  | LambdaBound         -- Used for both lambda and case+  deriving (Eq)++data LetInfo+  = TopLet              -- top level things+  | NestedLet+  deriving (Eq)++isLetBound :: HowBound -> Bool+isLetBound (LetBound _ _) = True+isLetBound _              = False++topLevelBound :: HowBound -> Bool+topLevelBound ImportBound         = True+topLevelBound (LetBound TopLet _) = True+topLevelBound _                   = False++-- For a let(rec)-bound variable, x, we record LiveInfo, the set of+-- variables that are live if x is live.  This LiveInfo comprises+--         (a) dynamic live variables (ones with a non-top-level binding)+--         (b) static live variabes (CAFs or things that refer to CAFs)+--+-- For "normal" variables (a) is just x alone.  If x is a let-no-escaped+-- variable then x is represented by a code pointer and a stack pointer+-- (well, one for each stack).  So all of the variables needed in the+-- execution of x are live if x is, and are therefore recorded in the+-- LetBound constructor; x itself *is* included.+--+-- The set of dynamic live variables is guaranteed ot have no further+-- let-no-escaped variables in it.++-- The std monad functions:++initCts :: IdEnv HowBound -> CtsM a -> a+initCts env m = unCtsM m env++++{-# INLINE thenCts #-}+{-# INLINE returnCts #-}++returnCts :: a -> CtsM a+returnCts e = CtsM $ \_ -> e++thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b+thenCts m k = CtsM $ \env+  -> unCtsM (k (unCtsM m env)) env++instance Functor CtsM where+    fmap = liftM++instance Applicative CtsM where+    pure = returnCts+    (<*>) = ap++instance Monad CtsM where+    (>>=)  = thenCts++instance MonadFix CtsM where+    mfix expr = CtsM $ \env ->+                       let result = unCtsM (expr result) env+                       in  result++-- Functions specific to this monad:++extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a+extendVarEnvCts ids_w_howbound expr+   =    CtsM $   \env+   -> unCtsM expr (extendVarEnvList env ids_w_howbound)++lookupVarCts :: Id -> CtsM HowBound+lookupVarCts v = CtsM $ \env -> lookupBinding env v++lookupBinding :: IdEnv HowBound -> Id -> HowBound+lookupBinding env v = case lookupVarEnv env v of+                        Just xx -> xx+                        Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound+++-- ---------------------------------------------------------------------------+-- Free variable information+-- ---------------------------------------------------------------------------++type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo)+        -- The Var is so we can gather up the free variables+        -- as a set.+        --+        -- The HowBound info just saves repeated lookups;+        -- we look up just once when we encounter the occurrence.+        -- INVARIANT: Any ImportBound Ids are HaveCafRef Ids+        --            Imported Ids without CAF refs are simply+        --            not put in the FreeVarsInfo for an expression.+        --            See singletonFVInfo and freeVarsToLiveVars+        --+        -- StgBinderInfo records how it occurs; notably, we+        -- are interested in whether it only occurs in saturated+        -- applications, because then we don't need to build a+        -- curried version.+        -- If f is mapped to noBinderInfo, that means+        -- that f *is* mentioned (else it wouldn't be in the+        -- IdEnv at all), but perhaps in an unsaturated applications.+        --+        -- All case/lambda-bound things are also mapped to+        -- noBinderInfo, since we aren't interested in their+        -- occurrence info.+        --+        -- For ILX we track free var info for type variables too;+        -- hence VarEnv not IdEnv++emptyFVInfo :: FreeVarsInfo+emptyFVInfo = emptyVarEnv++singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo+-- Don't record non-CAF imports at all, to keep free-var sets small+singletonFVInfo id ImportBound info+   | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound, info)+   | otherwise                     = emptyVarEnv+singletonFVInfo id how_bound info  = unitVarEnv id (id, how_bound, info)++unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo+unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2++unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo+unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs++minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo+minusFVBinders vs fv = foldr minusFVBinder fv vs++minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo+minusFVBinder v fv = fv `delVarEnv` v+        -- When removing a binder, remember to add its type variables+        -- c.f. CoreFVs.delBinderFV++elementOfFVInfo :: Id -> FreeVarsInfo -> Bool+elementOfFVInfo id fvs = isJust (lookupVarEnv fvs id)++lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo+-- Find how the given Id is used.+-- Externally visible things may be used any old how+lookupFVInfo fvs id+  | isExternalName (idName id) = noBinderInfo+  | otherwise = case lookupVarEnv fvs id of+                        Nothing         -> noBinderInfo+                        Just (_,_,info) -> info++-- Non-top-level things only, both type variables and ids+getFVs :: FreeVarsInfo -> [Var]+getFVs fvs = [id | (id, how_bound, _) <- nonDetEltsUFM fvs,+  -- It's OK to use nonDetEltsUFM here because we're not aiming for+  -- bit-for-bit determinism.+  -- See Note [Unique Determinism and code generation]+                    not (topLevelBound how_bound) ]++plusFVInfo :: (Var, HowBound, StgBinderInfo)+           -> (Var, HowBound, StgBinderInfo)+           -> (Var, HowBound, StgBinderInfo)+plusFVInfo (id1,hb1,info1) (id2,hb2,info2)+  = ASSERT(id1 == id2 && hb1 == hb2)+    (id1, hb1, combineStgBinderInfo info1 info2)++-- Misc.++filterStgBinders :: [Var] -> [Var]+filterStgBinders bndrs = filter isId bndrs++myCollectBinders :: Expr Var -> ([Var], Expr Var)+myCollectBinders expr+  = go [] expr+  where+    go bs (Lam b e)          = go (b:bs) e+    go bs (Cast e _)         = go bs e+    go bs e                  = (reverse bs, e)++myCollectArgs :: CoreExpr -> (Id, [CoreArg], [Tickish Id])+        -- We assume that we only have variables+        -- in the function position by now+myCollectArgs expr+  = go expr [] []+  where+    go (Var v)          as ts = (v, as, ts)+    go (App f a)        as ts = go f (a:as) ts+    go (Tick t e)       as ts = ASSERT( all isTypeArg as )+                                go e as (t:ts) -- ticks can appear in type apps+    go (Cast e _)       as ts = go e as ts+    go (Lam b e)        as ts+       | isTyVar b            = go e as ts -- Note [Collect args]+    go _                _  _  = pprPanic "CoreToStg.myCollectArgs" (ppr expr)++-- Note [Collect args]+-- ~~~~~~~~~~~~~~~~~~~+--+-- This big-lambda case occurred following a rather obscure eta expansion.+-- It all seems a bit yukky to me.++stgArity :: Id -> HowBound -> Arity+stgArity _ (LetBound _ arity) = arity+stgArity f ImportBound        = idArity f+stgArity _ LambdaBound        = 0
+ stgSyn/StgLint.hs view
@@ -0,0 +1,537 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998++\section[StgLint]{A ``lint'' pass to check for Stg correctness}+-}++{-# LANGUAGE CPP #-}++module StgLint ( lintStgTopBindings ) where++import StgSyn++import Bag              ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )+import Id               ( Id, idType, isLocalId )+import VarSet+import DataCon+import CoreSyn          ( AltCon(..) )+import PrimOp           ( primOpType )+import Literal          ( literalType )+import Maybes+import Name             ( getSrcLoc )+import ErrUtils         ( MsgDoc, Severity(..), mkLocMessage )+import Type+import RepType+import TyCon+import Util+import SrcLoc+import Outputable+import Control.Monad++#include "HsVersions.h"++{-+Checks for+        (a) *some* type errors+        (b) locally-defined variables used but not defined+++Note: unless -dverbose-stg is on, display of lint errors will result+in "panic: bOGUS_LVs".++WARNING:+~~~~~~~~++This module has suffered bit-rot; it is likely to yield lint errors+for Stg code that is currently perfectly acceptable for code+generation.  Solution: don't use it!  (KSW 2000-05).+++************************************************************************+*                                                                      *+\subsection{``lint'' for various constructs}+*                                                                      *+************************************************************************++@lintStgTopBindings@ is the top-level interface function.+-}++lintStgTopBindings :: String -> [StgTopBinding] -> [StgTopBinding]++lintStgTopBindings whodunnit binds+  = {-# SCC "StgLint" #-}+    case (initL (lint_binds binds)) of+      Nothing  -> binds+      Just msg -> pprPanic "" (vcat [+                        text "*** Stg Lint ErrMsgs: in" <+>+                              text whodunnit <+> text "***",+                        msg,+                        text "*** Offending Program ***",+                        pprStgTopBindings binds,+                        text "*** End of Offense ***"])+  where+    lint_binds :: [StgTopBinding] -> LintM ()++    lint_binds [] = return ()+    lint_binds (bind:binds) = do+        binders <- lint_bind bind+        addInScopeVars binders $+            lint_binds binds++    lint_bind (StgTopLifted bind) = lintStgBinds bind+    lint_bind (StgTopStringLit v _) = return [v]++lintStgArg :: StgArg -> LintM (Maybe Type)+lintStgArg (StgLitArg lit) = return (Just (literalType lit))+lintStgArg (StgVarArg v)   = lintStgVar v++lintStgVar :: Id -> LintM (Maybe Kind)+lintStgVar v = do checkInScope v+                  return (Just (idType v))++lintStgBinds :: StgBinding -> LintM [Id] -- Returns the binders+lintStgBinds (StgNonRec binder rhs) = do+    lint_binds_help (binder,rhs)+    return [binder]++lintStgBinds (StgRec pairs)+  = addInScopeVars binders $ do+        mapM_ lint_binds_help pairs+        return binders+  where+    binders = [b | (b,_) <- pairs]++lint_binds_help :: (Id, StgRhs) -> LintM ()+lint_binds_help (binder, rhs)+  = addLoc (RhsOf binder) $ do+        -- Check the rhs+        _maybe_rhs_ty <- lintStgRhs rhs++        -- Check binder doesn't have unlifted type+        checkL (not (isUnliftedType binder_ty))+               (mkUnliftedTyMsg binder rhs)++        -- Check match to RHS type+        -- Actually we *can't* check the RHS type, because+        -- unsafeCoerce means it really might not match at all+        -- notably;  eg x::Int = (error @Bool "urk") |> unsafeCoerce...+        -- case maybe_rhs_ty of+        --  Nothing     -> return ()+        --    Just rhs_ty -> checkTys binder_ty+        --                          rhs_ty+        ---                         (mkRhsMsg binder rhs_ty)++        return ()+  where+    binder_ty = idType binder++lintStgRhs :: StgRhs -> LintM (Maybe Type)   -- Just ty => type is exact++lintStgRhs (StgRhsClosure _ _ _ _ [] expr)+  = lintStgExpr expr++lintStgRhs (StgRhsClosure _ _ _ _ binders expr)+  = addLoc (LambdaBodyOf binders) $+      addInScopeVars binders $ runMaybeT $ do+        body_ty <- MaybeT $ lintStgExpr expr+        return (mkFunTys (map idType binders) body_ty)++lintStgRhs rhs@(StgRhsCon _ con args) = do+    -- TODO: Check arg_tys+    when (isUnboxedTupleCon con || isUnboxedSumCon con) $+      addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$+               ppr rhs)+    runMaybeT $ do+      arg_tys <- mapM (MaybeT . lintStgArg) args+      MaybeT $ checkFunApp con_ty arg_tys (mkRhsConMsg con_ty arg_tys)+  where+    con_ty = dataConRepType con++lintStgExpr :: StgExpr -> LintM (Maybe Type) -- Just ty => type is exact++lintStgExpr (StgLit l) = return (Just (literalType l))++lintStgExpr e@(StgApp fun args) = runMaybeT $ do+    fun_ty <- MaybeT $ lintStgVar fun+    arg_tys <- mapM (MaybeT . lintStgArg) args+    MaybeT $ checkFunApp fun_ty arg_tys (mkFunAppMsg fun_ty arg_tys e)++lintStgExpr e@(StgConApp con args _arg_tys) = runMaybeT $ do+    -- TODO: Check arg_tys+    arg_tys <- mapM (MaybeT . lintStgArg) args+    MaybeT $ checkFunApp con_ty arg_tys (mkFunAppMsg con_ty arg_tys e)+  where+    con_ty = dataConRepType con++lintStgExpr e@(StgOpApp (StgPrimOp op) args _) = runMaybeT $ do+    arg_tys <- mapM (MaybeT . lintStgArg) args+    MaybeT $ checkFunApp op_ty arg_tys (mkFunAppMsg op_ty arg_tys e)+  where+    op_ty = primOpType op++lintStgExpr (StgOpApp _ args res_ty) = runMaybeT $ do+        -- We don't have enough type information to check+        -- the application for StgFCallOp and StgPrimCallOp; ToDo+    _maybe_arg_tys <- mapM (MaybeT . lintStgArg) args+    return res_ty++lintStgExpr (StgLam bndrs _) = do+    addErrL (text "Unexpected StgLam" <+> ppr bndrs)+    return Nothing++lintStgExpr (StgLet binds body) = do+    binders <- lintStgBinds binds+    addLoc (BodyOfLetRec binders) $+      addInScopeVars binders $+        lintStgExpr body++lintStgExpr (StgLetNoEscape binds body) = do+    binders <- lintStgBinds binds+    addLoc (BodyOfLetRec binders) $+      addInScopeVars binders $+        lintStgExpr body++lintStgExpr (StgTick _ expr) = lintStgExpr expr++lintStgExpr (StgCase scrut bndr alts_type alts) = runMaybeT $ do+    _ <- MaybeT $ lintStgExpr scrut++    in_scope <- MaybeT $ liftM Just $+     case alts_type of+        AlgAlt tc     -> check_bndr (tyConPrimRep tc) >> return True+        PrimAlt rep   -> check_bndr [rep]             >> return True+        MultiValAlt _ -> return False -- Binder is always dead in this case+        PolyAlt       -> return True++    MaybeT $ addInScopeVars [bndr | in_scope] $+             lintStgAlts alts scrut_ty+  where+    scrut_ty        = idType bndr+    scrut_reps      = typePrimRep scrut_ty+    check_bndr reps = checkL (scrut_reps == reps) bad_bndr+                  where+                     bad_bndr = mkDefltMsg bndr reps++lintStgAlts :: [StgAlt]+            -> Type               -- Type of scrutinee+            -> LintM (Maybe Type) -- Just ty => type is accurage++lintStgAlts alts scrut_ty = do+    maybe_result_tys <- mapM (lintAlt scrut_ty) alts++    -- Check the result types+    case catMaybes (maybe_result_tys) of+      []             -> return Nothing++      (first_ty:_tys) -> do -- mapM_ check tys+                           return (Just first_ty)+        where+          -- check ty = checkTys first_ty ty (mkCaseAltMsg alts)+          -- We can't check that the alternatives have the+          -- same type, because they don't, with unsafeCoerce#++lintAlt :: Type -> (AltCon, [Id], StgExpr) -> LintM (Maybe Type)+lintAlt _ (DEFAULT, _, rhs)+ = lintStgExpr rhs++lintAlt scrut_ty (LitAlt lit, _, rhs) = do+   checkTys (literalType lit) scrut_ty (mkAltMsg1 scrut_ty)+   lintStgExpr rhs++lintAlt scrut_ty (DataAlt con, args, rhs) = do+    case splitTyConApp_maybe scrut_ty of+      Just (tycon, tys_applied) | isAlgTyCon tycon &&+                                  not (isNewTyCon tycon) -> do+         let+           cons    = tyConDataCons tycon+           arg_tys = dataConInstArgTys con tys_applied+                -- This does not work for existential constructors++         checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con)+         checkL (length args == dataConRepArity con) (mkAlgAltMsg3 con args)+         when (isVanillaDataCon con) $+           mapM_ check (zipEqual "lintAlgAlt:stg" arg_tys args)+         return ()+      _ ->+         addErrL (mkAltMsg1 scrut_ty)++    addInScopeVars args $+         lintStgExpr rhs+  where+    check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)++    -- elem: yes, the elem-list here can sometimes be long-ish,+    -- but as it's use-once, probably not worth doing anything different+    -- We give it its own copy, so it isn't overloaded.+    elem _ []       = False+    elem x (y:ys)   = x==y || elem x ys++{-+************************************************************************+*                                                                      *+\subsection[lint-monad]{The Lint monad}+*                                                                      *+************************************************************************+-}++newtype LintM a = LintM+    { unLintM :: [LintLocInfo]      -- Locations+              -> IdSet              -- Local vars in scope+              -> Bag MsgDoc        -- Error messages so far+              -> (a, Bag MsgDoc)   -- Result and error messages (if any)+    }++data LintLocInfo+  = RhsOf Id            -- The variable bound+  | LambdaBodyOf [Id]   -- The lambda-binder+  | BodyOfLetRec [Id]   -- One of the binders++dumpLoc :: LintLocInfo -> (SrcSpan, SDoc)+dumpLoc (RhsOf v) =+  (srcLocSpan (getSrcLoc v), text " [RHS of " <> pp_binders [v] <> char ']' )+dumpLoc (LambdaBodyOf bs) =+  (srcLocSpan (getSrcLoc (head bs)), text " [in body of lambda with binders " <> pp_binders bs <> char ']' )++dumpLoc (BodyOfLetRec bs) =+  (srcLocSpan (getSrcLoc (head bs)), text " [in body of letrec with binders " <> pp_binders bs <> char ']' )+++pp_binders :: [Id] -> SDoc+pp_binders bs+  = sep (punctuate comma (map pp_binder bs))+  where+    pp_binder b+      = hsep [ppr b, dcolon, ppr (idType b)]++initL :: LintM a -> Maybe MsgDoc+initL (LintM m)+  = case (m [] emptyVarSet emptyBag) of { (_, errs) ->+    if isEmptyBag errs then+        Nothing+    else+        Just (vcat (punctuate blankLine (bagToList errs)))+    }++instance Functor LintM where+      fmap = liftM++instance Applicative LintM where+      pure a = LintM $ \_loc _scope errs -> (a, errs)+      (<*>) = ap+      (*>)  = thenL_++instance Monad LintM where+    (>>=) = thenL+    (>>)  = (*>)++thenL :: LintM a -> (a -> LintM b) -> LintM b+thenL m k = LintM $ \loc scope errs+  -> case unLintM m loc scope errs of+      (r, errs') -> unLintM (k r) loc scope errs'++thenL_ :: LintM a -> LintM b -> LintM b+thenL_ m k = LintM $ \loc scope errs+  -> case unLintM m loc scope errs of+      (_, errs') -> unLintM k loc scope errs'++checkL :: Bool -> MsgDoc -> LintM ()+checkL True  _   = return ()+checkL False msg = addErrL msg++addErrL :: MsgDoc -> LintM ()+addErrL msg = LintM $ \loc _scope errs -> ((), addErr errs msg loc)++addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc+addErr errs_so_far msg locs+  = errs_so_far `snocBag` mk_msg locs+  where+    mk_msg (loc:_) = let (l,hdr) = dumpLoc loc+                     in  mkLocMessage SevWarning l (hdr $$ msg)+    mk_msg []      = msg++addLoc :: LintLocInfo -> LintM a -> LintM a+addLoc extra_loc m = LintM $ \loc scope errs+   -> unLintM m (extra_loc:loc) scope errs++addInScopeVars :: [Id] -> LintM a -> LintM a+addInScopeVars ids m = LintM $ \loc scope errs+ -> let+        new_set = mkVarSet ids+    in unLintM m loc (scope `unionVarSet` new_set) errs++{-+Checking function applications: we only check that the type has the+right *number* of arrows, we don't actually compare the types.  This+is because we can't expect the types to be equal - the type+applications and type lambdas that we use to calculate accurate types+have long since disappeared.+-}++checkFunApp :: Type                 -- The function type+            -> [Type]               -- The arg type(s)+            -> MsgDoc               -- Error message+            -> LintM (Maybe Type)   -- Just ty => result type is accurate++checkFunApp fun_ty arg_tys msg+ = do { case mb_msg of+          Just msg -> addErrL msg+          Nothing  -> return ()+      ; return mb_ty }+ where+  (mb_ty, mb_msg) = cfa True fun_ty arg_tys++  cfa :: Bool -> Type -> [Type] -> (Maybe Type          -- Accurate result?+                                   , Maybe MsgDoc)      -- Errors?++  cfa accurate fun_ty []      -- Args have run out; that's fine+      = (if accurate then Just fun_ty else Nothing, Nothing)++  cfa accurate fun_ty arg_tys@(arg_ty':arg_tys')+      | Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty+      = if accurate && not (arg_ty `stgEqType` arg_ty')+        then (Nothing, Just msg)       -- Arg type mismatch+        else cfa accurate res_ty arg_tys'++      | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty+      = cfa False fun_ty' arg_tys++      | Just (tc,tc_args) <- splitTyConApp_maybe fun_ty+      , isNewTyCon tc+      = if length tc_args < tyConArity tc+        then WARN( True, text "cfa: unsaturated newtype" <+> ppr fun_ty $$ msg )+             (Nothing, Nothing)   -- This is odd, but I've seen it+        else cfa False (newTyConInstRhs tc tc_args) arg_tys++      | Just tc <- tyConAppTyCon_maybe fun_ty+      , not (isTypeFamilyTyCon tc)      -- Definite error+      = (Nothing, Just msg)             -- Too many args++      | otherwise+      = (Nothing, Nothing)++stgEqType :: Type -> Type -> Bool+-- Compare types, but crudely because we have discarded+-- both casts and type applications, so types might look+-- different but be the same.  So reply "True" if in doubt.+-- "False" means that the types are definitely different.+--+-- Fundamentally this is a losing battle because of unsafeCoerce++stgEqType orig_ty1 orig_ty2+  = gos orig_ty1 orig_ty2+  where+    gos :: Type -> Type -> Bool+    gos ty1   ty2+        -- These have no prim rep+      | isRuntimeRepKindedTy ty1 && isRuntimeRepKindedTy ty2+      = True++        -- We have a unary type+      | [_] <- reps1, [_] <- reps2+      = go ty1 ty2++        -- In the case of a tuple just compare prim reps+      | otherwise+      = reps1 == reps2+      where+        reps1 = typePrimRep ty1+        reps2 = typePrimRep ty2++    go :: UnaryType -> UnaryType -> Bool+    go ty1 ty2+      | Just (tc1, tc_args1) <- splitTyConApp_maybe ty1+      , Just (tc2, tc_args2) <- splitTyConApp_maybe ty2+      , let res = if tc1 == tc2+                  then equalLength tc_args1 tc_args2+                       && and (zipWith gos tc_args1 tc_args2)+                  else  -- TyCons don't match; but don't bleat if either is a+                        -- family TyCon because a coercion might have made it+                        -- equal to something else+                    (isFamilyTyCon tc1 || isFamilyTyCon tc2)+      = if res then True+        else+        pprTrace "stgEqType: unequal" (vcat [ppr ty1, ppr ty2])+        False++      | otherwise = True  -- Conservatively say "fine".+                          -- Type variables in particular++checkInScope :: Id -> LintM ()+checkInScope id = LintM $ \loc scope errs+ -> if isLocalId id && not (id `elemVarSet` scope) then+        ((), addErr errs (hsep [ppr id, text "is out of scope"]) loc)+    else+        ((), errs)++checkTys :: Type -> Type -> MsgDoc -> LintM ()+checkTys ty1 ty2 msg = LintM $ \loc _scope errs+  -> if (ty1 `stgEqType` ty2)+     then ((), errs)+     else ((), addErr errs msg loc)++_mkCaseAltMsg :: [StgAlt] -> MsgDoc+_mkCaseAltMsg _alts+  = ($$) (text "In some case alternatives, type of alternatives not all same:")+            (Outputable.empty) -- LATER: ppr alts++mkDefltMsg :: Id -> [PrimRep] -> MsgDoc+mkDefltMsg bndr reps+  = ($$) (text "Binder of a case expression doesn't match representation of scrutinee:")+         (ppr bndr $$ ppr (idType bndr) $$ ppr reps)++mkFunAppMsg :: Type -> [Type] -> StgExpr -> MsgDoc+mkFunAppMsg fun_ty arg_tys expr+  = vcat [text "In a function application, function type doesn't match arg types:",+              hang (text "Function type:") 4 (ppr fun_ty),+              hang (text "Arg types:") 4 (vcat (map (ppr) arg_tys)),+              hang (text "Expression:") 4 (ppr expr)]++mkRhsConMsg :: Type -> [Type] -> MsgDoc+mkRhsConMsg fun_ty arg_tys+  = vcat [text "In a RHS constructor application, con type doesn't match arg types:",+              hang (text "Constructor type:") 4 (ppr fun_ty),+              hang (text "Arg types:") 4 (vcat (map (ppr) arg_tys))]++mkAltMsg1 :: Type -> MsgDoc+mkAltMsg1 ty+  = ($$) (text "In a case expression, type of scrutinee does not match patterns")+         (ppr ty)++mkAlgAltMsg2 :: Type -> DataCon -> MsgDoc+mkAlgAltMsg2 ty con+  = vcat [+        text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",+        ppr ty,+        ppr con+    ]++mkAlgAltMsg3 :: DataCon -> [Id] -> MsgDoc+mkAlgAltMsg3 con alts+  = vcat [+        text "In some algebraic case alternative, number of arguments doesn't match constructor:",+        ppr con,+        ppr alts+    ]++mkAlgAltMsg4 :: Type -> Id -> MsgDoc+mkAlgAltMsg4 ty arg+  = vcat [+        text "In some algebraic case alternative, type of argument doesn't match data constructor:",+        ppr ty,+        ppr arg+    ]++_mkRhsMsg :: Id -> Type -> MsgDoc+_mkRhsMsg binder ty+  = vcat [hsep [text "The type of this binder doesn't match the type of its RHS:",+                     ppr binder],+              hsep [text "Binder's type:", ppr (idType binder)],+              hsep [text "Rhs type:", ppr ty]+             ]++mkUnliftedTyMsg :: Id -> StgRhs -> SDoc+mkUnliftedTyMsg binder rhs+  = (text "Let(rec) binder" <+> quotes (ppr binder) <+>+     text "has unlifted type" <+> quotes (ppr (idType binder)))+    $$+    (text "RHS:" <+> ppr rhs)
+ stgSyn/StgSyn.hs view
@@ -0,0 +1,820 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[StgSyn]{Shared term graph (STG) syntax for spineless-tagless code generation}++This data type represents programs just before code generation (conversion to+@Cmm@): basically, what we have is a stylised form of @CoreSyntax@, the style+being one that happens to be ideally suited to spineless tagless code+generation.+-}++{-# LANGUAGE CPP #-}++module StgSyn (+        GenStgArg(..),++        GenStgTopBinding(..), GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),+        GenStgAlt, AltType(..),++        UpdateFlag(..), isUpdatable,++        StgBinderInfo,+        noBinderInfo, stgSatOcc, stgUnsatOcc, satCallsOnly,+        combineStgBinderInfo,++        -- a set of synonyms for the most common (only :-) parameterisation+        StgArg,+        StgTopBinding, StgBinding, StgExpr, StgRhs, StgAlt,++        -- a set of synonyms to distinguish in- and out variants+        InStgArg,  InStgTopBinding,  InStgBinding,  InStgExpr,  InStgRhs,  InStgAlt,+        OutStgArg, OutStgTopBinding, OutStgBinding, OutStgExpr, OutStgRhs, OutStgAlt,++        -- StgOp+        StgOp(..),++        -- utils+        topStgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity,+        isDllConApp,+        stgArgType,+        stripStgTicksTop,++        pprStgBinding, pprStgTopBindings+    ) where++#include "HsVersions.h"++import CoreSyn     ( AltCon, Tickish )+import CostCentre  ( CostCentreStack )+import Data.ByteString ( ByteString )+import Data.List   ( intersperse )+import DataCon+import DynFlags+import FastString+import ForeignCall ( ForeignCall )+import Id+import IdInfo      ( mayHaveCafRefs )+import Literal     ( Literal, literalType )+import Module      ( Module )+import Outputable+import Packages    ( isDllName )+import Platform+import PprCore     ( {- instances -} )+import PrimOp      ( PrimOp, PrimCall )+import TyCon       ( PrimRep(..), TyCon )+import Type        ( Type )+import RepType     ( typePrimRep1 )+import Unique      ( Unique )+import Util++{-+************************************************************************+*                                                                      *+\subsection{@GenStgBinding@}+*                                                                      *+************************************************************************++As usual, expressions are interesting; other things are boring. Here+are the boring things [except note the @GenStgRhs@], parameterised+with respect to binder and occurrence information (just as in+@CoreSyn@):+-}++-- | A top-level binding.+data GenStgTopBinding bndr occ+-- See Note [CoreSyn top-level string literals]+  = StgTopLifted (GenStgBinding bndr occ)+  | StgTopStringLit bndr ByteString++data GenStgBinding bndr occ+  = StgNonRec bndr (GenStgRhs bndr occ)+  | StgRec    [(bndr, GenStgRhs bndr occ)]++{-+************************************************************************+*                                                                      *+\subsection{@GenStgArg@}+*                                                                      *+************************************************************************+-}++data GenStgArg occ+  = StgVarArg  occ+  | StgLitArg  Literal++-- | Does this constructor application refer to+-- anything in a different *Windows* DLL?+-- If so, we can't allocate it statically+isDllConApp :: DynFlags -> Module -> DataCon -> [StgArg] -> Bool+isDllConApp dflags this_mod con args+ | platformOS (targetPlatform dflags) == OSMinGW32+    = isDllName dflags this_mod (dataConName con) || any is_dll_arg args+ | otherwise = False+  where+    -- NB: typePrimRep1 is legit because any free variables won't have+    -- unlifted type (there are no unlifted things at top level)+    is_dll_arg :: StgArg -> Bool+    is_dll_arg (StgVarArg v) =  isAddrRep (typePrimRep1 (idType v))+                             && isDllName dflags this_mod (idName v)+    is_dll_arg _             = False++-- True of machine addresses; these are the things that don't+-- work across DLLs. The key point here is that VoidRep comes+-- out False, so that a top level nullary GADT constructor is+-- False for isDllConApp+--    data T a where+--      T1 :: T Int+-- gives+--    T1 :: forall a. (a~Int) -> T a+-- and hence the top-level binding+--    $WT1 :: T Int+--    $WT1 = T1 Int (Coercion (Refl Int))+-- The coercion argument here gets VoidRep+isAddrRep :: PrimRep -> Bool+isAddrRep AddrRep     = True+isAddrRep LiftedRep   = True+isAddrRep UnliftedRep = True+isAddrRep _           = False++-- | Type of an @StgArg@+--+-- Very half baked because we have lost the type arguments.+stgArgType :: StgArg -> Type+stgArgType (StgVarArg v)   = idType v+stgArgType (StgLitArg lit) = literalType lit+++-- | Strip ticks of a given type from an STG expression+stripStgTicksTop :: (Tickish Id -> Bool) -> StgExpr -> ([Tickish Id], StgExpr)+stripStgTicksTop p = go []+   where go ts (StgTick t e) | p t = go (t:ts) e+         go ts other               = (reverse ts, other)+++{-+************************************************************************+*                                                                      *+\subsection{STG expressions}+*                                                                      *+************************************************************************++The @GenStgExpr@ data type is parameterised on binder and occurrence+info, as before.++************************************************************************+*                                                                      *+\subsubsection{@GenStgExpr@ application}+*                                                                      *+************************************************************************++An application is of a function to a list of atoms [not expressions].+Operationally, we want to push the arguments on the stack and call the+function. (If the arguments were expressions, we would have to build+their closures first.)++There is no constructor for a lone variable; it would appear as+@StgApp var []@.+-}++data GenStgExpr bndr occ+  = StgApp+        occ             -- function+        [GenStgArg occ] -- arguments; may be empty++{-+************************************************************************+*                                                                      *+\subsubsection{@StgConApp@ and @StgPrimApp@---saturated applications}+*                                                                      *+************************************************************************++There are specialised forms of application, for constructors,+primitives, and literals.+-}++  | StgLit      Literal++        -- StgConApp is vital for returning unboxed tuples or sums+        -- which can't be let-bound first+  | StgConApp   DataCon+                [GenStgArg occ] -- Saturated+                [Type]          -- See Note [Types in StgConApp] in UnariseStg++  | StgOpApp    StgOp           -- Primitive op or foreign call+                [GenStgArg occ] -- Saturated.+                Type            -- Result type+                                -- We need to know this so that we can+                                -- assign result registers++{-+************************************************************************+*                                                                      *+\subsubsection{@StgLam@}+*                                                                      *+************************************************************************++StgLam is used *only* during CoreToStg's work. Before CoreToStg has+finished it encodes (\x -> e) as (let f = \x -> e in f)+-}++  | StgLam+        [bndr]+        StgExpr    -- Body of lambda++{-+************************************************************************+*                                                                      *+\subsubsection{@GenStgExpr@: case-expressions}+*                                                                      *+************************************************************************++This has the same boxed/unboxed business as Core case expressions.+-}++  | StgCase+        (GenStgExpr bndr occ)+                    -- the thing to examine++        bndr        -- binds the result of evaluating the scrutinee++        AltType++        [GenStgAlt bndr occ]+                    -- The DEFAULT case is always *first*+                    -- if it is there at all++{-+************************************************************************+*                                                                      *+\subsubsection{@GenStgExpr@: @let(rec)@-expressions}+*                                                                      *+************************************************************************++The various forms of let(rec)-expression encode most of the+interesting things we want to do.+\begin{enumerate}+\item+\begin{verbatim}+let-closure x = [free-vars] [args] expr+in e+\end{verbatim}+is equivalent to+\begin{verbatim}+let x = (\free-vars -> \args -> expr) free-vars+\end{verbatim}+\tr{args} may be empty (and is for most closures).  It isn't under+circumstances like this:+\begin{verbatim}+let x = (\y -> y+z)+\end{verbatim}+This gets mangled to+\begin{verbatim}+let-closure x = [z] [y] (y+z)+\end{verbatim}+The idea is that we compile code for @(y+z)@ in an environment in which+@z@ is bound to an offset from \tr{Node}, and @y@ is bound to an+offset from the stack pointer.++(A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)++\item+\begin{verbatim}+let-constructor x = Constructor [args]+in e+\end{verbatim}++(A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)++\item+Letrec-expressions are essentially the same deal as+let-closure/let-constructor, so we use a common structure and+distinguish between them with an @is_recursive@ boolean flag.++\item+\begin{verbatim}+let-unboxed u = an arbitrary arithmetic expression in unboxed values+in e+\end{verbatim}+All the stuff on the RHS must be fully evaluated.+No function calls either!++(We've backed away from this toward case-expressions with+suitably-magical alts ...)++\item+~[Advanced stuff here! Not to start with, but makes pattern matching+generate more efficient code.]++\begin{verbatim}+let-escapes-not fail = expr+in e'+\end{verbatim}+Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,+or pass it to another function. All @e'@ will ever do is tail-call @fail@.+Rather than build a closure for @fail@, all we need do is to record the stack+level at the moment of the @let-escapes-not@; then entering @fail@ is just+a matter of adjusting the stack pointer back down to that point and entering+the code for it.++Another example:+\begin{verbatim}+f x y = let z = huge-expression in+        if y==1 then z else+        if y==2 then z else+        1+\end{verbatim}++(A let-escapes-not is an @StgLetNoEscape@.)++\item+We may eventually want:+\begin{verbatim}+let-literal x = Literal+in e+\end{verbatim}+\end{enumerate}++And so the code for let(rec)-things:+-}++  | StgLet+        (GenStgBinding bndr occ)    -- right hand sides (see below)+        (GenStgExpr bndr occ)       -- body++  | StgLetNoEscape+        (GenStgBinding bndr occ)    -- right hand sides (see below)+        (GenStgExpr bndr occ)       -- body++{-+%************************************************************************+%*                                                                      *+\subsubsection{@GenStgExpr@: @hpc@, @scc@ and other debug annotations}+%*                                                                      *+%************************************************************************++Finally for @hpc@ expressions we introduce a new STG construct.+-}++  | StgTick+    (Tickish bndr)+    (GenStgExpr bndr occ)       -- sub expression++-- END of GenStgExpr++{-+************************************************************************+*                                                                      *+\subsection{STG right-hand sides}+*                                                                      *+************************************************************************++Here's the rest of the interesting stuff for @StgLet@s; the first+flavour is for closures:+-}++data GenStgRhs bndr occ+  = StgRhsClosure+        CostCentreStack         -- CCS to be attached (default is CurrentCCS)+        StgBinderInfo           -- Info about how this binder is used (see below)+        [occ]                   -- non-global free vars; a list, rather than+                                -- a set, because order is important+        !UpdateFlag             -- ReEntrant | Updatable | SingleEntry+        [bndr]                  -- arguments; if empty, then not a function;+                                -- as above, order is important.+        (GenStgExpr bndr occ)   -- body++{-+An example may be in order.  Consider:+\begin{verbatim}+let t = \x -> \y -> ... x ... y ... p ... q in e+\end{verbatim}+Pulling out the free vars and stylising somewhat, we get the equivalent:+\begin{verbatim}+let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q+\end{verbatim}+Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are+offsets from @Node@ into the closure, and the code ptr for the closure+will be exactly that in parentheses above.++The second flavour of right-hand-side is for constructors (simple but important):+-}++  | StgRhsCon+        CostCentreStack  -- CCS to be attached (default is CurrentCCS).+                         -- Top-level (static) ones will end up with+                         -- DontCareCCS, because we don't count static+                         -- data in heap profiles, and we don't set CCCS+                         -- from static closure.+        DataCon          -- Constructor. Never an unboxed tuple or sum, as those+                         -- are not allocated.+        [GenStgArg occ]  -- Args++stgRhsArity :: StgRhs -> Int+stgRhsArity (StgRhsClosure _ _ _ _ bndrs _)+  = ASSERT( all isId bndrs ) length bndrs+  -- The arity never includes type parameters, but they should have gone by now+stgRhsArity (StgRhsCon _ _ _) = 0++-- Note [CAF consistency]+-- ~~~~~~~~~~~~~~~~~~~~~~+--+-- `topStgBindHasCafRefs` is only used by an assert (`consistentCafInfo` in+-- `CoreToStg`) to make sure CAF-ness predicted by `TidyPgm` is consistent with+-- reality.+--+-- Specifically, if the RHS mentions any Id that itself is marked+-- `MayHaveCafRefs`; or if the binding is a top-level updateable thunk; then the+-- `Id` for the binding should be marked `MayHaveCafRefs`. The potential trouble+-- is that `TidyPgm` computed the CAF info on the `Id` but some transformations+-- have taken place since then.++topStgBindHasCafRefs :: GenStgTopBinding bndr Id -> Bool+topStgBindHasCafRefs (StgTopLifted (StgNonRec _ rhs))+  = topRhsHasCafRefs rhs+topStgBindHasCafRefs (StgTopLifted (StgRec binds))+  = any topRhsHasCafRefs (map snd binds)+topStgBindHasCafRefs StgTopStringLit{}+  = False++topRhsHasCafRefs :: GenStgRhs bndr Id -> Bool+topRhsHasCafRefs (StgRhsClosure _ _ _ upd _ body)+  = -- See Note [CAF consistency]+    isUpdatable upd || exprHasCafRefs body+topRhsHasCafRefs (StgRhsCon _ _ args)+  = any stgArgHasCafRefs args++exprHasCafRefs :: GenStgExpr bndr Id -> Bool+exprHasCafRefs (StgApp f args)+  = stgIdHasCafRefs f || any stgArgHasCafRefs args+exprHasCafRefs StgLit{}+  = False+exprHasCafRefs (StgConApp _ args _)+  = any stgArgHasCafRefs args+exprHasCafRefs (StgOpApp _ args _)+  = any stgArgHasCafRefs args+exprHasCafRefs (StgLam _ body)+  = exprHasCafRefs body+exprHasCafRefs (StgCase scrt _ _ alts)+  = exprHasCafRefs scrt || any altHasCafRefs alts+exprHasCafRefs (StgLet bind body)+  = bindHasCafRefs bind || exprHasCafRefs body+exprHasCafRefs (StgLetNoEscape bind body)+  = bindHasCafRefs bind || exprHasCafRefs body+exprHasCafRefs (StgTick _ expr)+  = exprHasCafRefs expr++bindHasCafRefs :: GenStgBinding bndr Id -> Bool+bindHasCafRefs (StgNonRec _ rhs)+  = rhsHasCafRefs rhs+bindHasCafRefs (StgRec binds)+  = any rhsHasCafRefs (map snd binds)++rhsHasCafRefs :: GenStgRhs bndr Id -> Bool+rhsHasCafRefs (StgRhsClosure _ _ _ _ _ body)+  = exprHasCafRefs body+rhsHasCafRefs (StgRhsCon _ _ args)+  = any stgArgHasCafRefs args++altHasCafRefs :: GenStgAlt bndr Id -> Bool+altHasCafRefs (_, _, rhs) = exprHasCafRefs rhs++stgArgHasCafRefs :: GenStgArg Id -> Bool+stgArgHasCafRefs (StgVarArg id)+  = stgIdHasCafRefs id+stgArgHasCafRefs _+  = False++stgIdHasCafRefs :: Id -> Bool+stgIdHasCafRefs id =+  -- We are looking for occurrences of an Id that is bound at top level, and may+  -- have CAF refs. At this point (after TidyPgm) top-level Ids (whether+  -- imported or defined in this module) are GlobalIds, so the test is easy.+  isGlobalId id && mayHaveCafRefs (idCafInfo id)++-- Here's the @StgBinderInfo@ type, and its combining op:++data StgBinderInfo+  = NoStgBinderInfo+  | SatCallsOnly        -- All occurrences are *saturated* *function* calls+                        -- This means we don't need to build an info table and+                        -- slow entry code for the thing+                        -- Thunks never get this value++noBinderInfo, stgUnsatOcc, stgSatOcc :: StgBinderInfo+noBinderInfo = NoStgBinderInfo+stgUnsatOcc  = NoStgBinderInfo+stgSatOcc    = SatCallsOnly++satCallsOnly :: StgBinderInfo -> Bool+satCallsOnly SatCallsOnly    = True+satCallsOnly NoStgBinderInfo = False++combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo+combineStgBinderInfo SatCallsOnly SatCallsOnly = SatCallsOnly+combineStgBinderInfo _            _            = NoStgBinderInfo++--------------+pp_binder_info :: StgBinderInfo -> SDoc+pp_binder_info NoStgBinderInfo = empty+pp_binder_info SatCallsOnly    = text "sat-only"++{-+************************************************************************+*                                                                      *+\subsection[Stg-case-alternatives]{STG case alternatives}+*                                                                      *+************************************************************************++Very like in @CoreSyntax@ (except no type-world stuff).++The type constructor is guaranteed not to be abstract; that is, we can+see its representation. This is important because the code generator+uses it to determine return conventions etc. But it's not trivial+where there's a module loop involved, because some versions of a type+constructor might not have all the constructors visible. So+mkStgAlgAlts (in CoreToStg) ensures that it gets the TyCon from the+constructors or literals (which are guaranteed to have the Real McCoy)+rather than from the scrutinee type.+-}++type GenStgAlt bndr occ+  = (AltCon,            -- alts: data constructor,+     [bndr],            -- constructor's parameters,+     GenStgExpr bndr occ)       -- ...right-hand side.++data AltType+  = PolyAlt             -- Polymorphic (a lifted type variable)+  | MultiValAlt Int     -- Multi value of this arity (unboxed tuple or sum)+                        -- the arity could indeed be 1 for unary unboxed tuple+  | AlgAlt      TyCon   -- Algebraic data type; the AltCons will be DataAlts+  | PrimAlt     PrimRep -- Primitive data type; the AltCons (if any) will be LitAlts++{-+************************************************************************+*                                                                      *+\subsection[Stg]{The Plain STG parameterisation}+*                                                                      *+************************************************************************++This happens to be the only one we use at the moment.+-}++type StgTopBinding = GenStgTopBinding Id Id+type StgBinding  = GenStgBinding  Id Id+type StgArg      = GenStgArg      Id+type StgExpr     = GenStgExpr     Id Id+type StgRhs      = GenStgRhs      Id Id+type StgAlt      = GenStgAlt      Id Id++{- Many passes apply a substitution, and it's very handy to have type+   synonyms to remind us whether or not the substitution has been applied.+   See CoreSyn for precedence in Core land+-}++type InStgTopBinding  = StgTopBinding+type InStgBinding     = StgBinding+type InStgArg         = StgArg+type InStgExpr        = StgExpr+type InStgRhs         = StgRhs+type InStgAlt         = StgAlt+type OutStgTopBinding = StgTopBinding+type OutStgBinding    = StgBinding+type OutStgArg        = StgArg+type OutStgExpr       = StgExpr+type OutStgRhs        = StgRhs+type OutStgAlt        = StgAlt++{-++************************************************************************+*                                                                      *+\subsubsection[UpdateFlag-datatype]{@UpdateFlag@}+*                                                                      *+************************************************************************++This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.++A @ReEntrant@ closure may be entered multiple times, but should not be+updated or blackholed. An @Updatable@ closure should be updated after+evaluation (and may be blackholed during evaluation). A @SingleEntry@+closure will only be entered once, and so need not be updated but may+safely be blackholed.+-}++data UpdateFlag = ReEntrant | Updatable | SingleEntry++instance Outputable UpdateFlag where+    ppr u = char $ case u of+                       ReEntrant   -> 'r'+                       Updatable   -> 'u'+                       SingleEntry -> 's'++isUpdatable :: UpdateFlag -> Bool+isUpdatable ReEntrant   = False+isUpdatable SingleEntry = False+isUpdatable Updatable   = True++{-+************************************************************************+*                                                                      *+\subsubsection{StgOp}+*                                                                      *+************************************************************************++An StgOp allows us to group together PrimOps and ForeignCalls.+It's quite useful to move these around together, notably+in StgOpApp and COpStmt.+-}++data StgOp+  = StgPrimOp  PrimOp++  | StgPrimCallOp PrimCall++  | StgFCallOp ForeignCall Unique+        -- The Unique is occasionally needed by the C pretty-printer+        -- (which lacks a unique supply), notably when generating a+        -- typedef for foreign-export-dynamic++{-+************************************************************************+*                                                                      *+\subsection[Stg-pretty-printing]{Pretty-printing}+*                                                                      *+************************************************************************++Robin Popplestone asked for semi-colon separators on STG binds; here's+hoping he likes terminators instead...  Ditto for case alternatives.+-}++pprGenStgTopBinding :: (OutputableBndr bndr, Outputable bdee, Ord bdee)+                 => GenStgTopBinding bndr bdee -> SDoc++pprGenStgTopBinding (StgTopStringLit bndr str)+  = hang (hsep [pprBndr LetBind bndr, equals])+        4 (pprHsBytes str <> semi)+pprGenStgTopBinding (StgTopLifted bind)+  = pprGenStgBinding bind++pprGenStgBinding :: (OutputableBndr bndr, Outputable bdee, Ord bdee)+                 => GenStgBinding bndr bdee -> SDoc++pprGenStgBinding (StgNonRec bndr rhs)+  = hang (hsep [pprBndr LetBind bndr, equals])+        4 (ppr rhs <> semi)++pprGenStgBinding (StgRec pairs)+  = vcat $ ifPprDebug (text "{- StgRec (begin) -}") :+           map (ppr_bind) pairs ++ [ifPprDebug (text "{- StgRec (end) -}")]+  where+    ppr_bind (bndr, expr)+      = hang (hsep [pprBndr LetBind bndr, equals])+             4 (ppr expr <> semi)++pprStgBinding :: StgBinding -> SDoc+pprStgBinding  bind  = pprGenStgBinding bind++pprStgTopBindings :: [StgTopBinding] -> SDoc+pprStgTopBindings binds+  = vcat $ intersperse blankLine (map pprGenStgTopBinding binds)++instance (Outputable bdee) => Outputable (GenStgArg bdee) where+    ppr = pprStgArg++instance (OutputableBndr bndr, Outputable bdee, Ord bdee)+                => Outputable (GenStgTopBinding bndr bdee) where+    ppr = pprGenStgTopBinding++instance (OutputableBndr bndr, Outputable bdee, Ord bdee)+                => Outputable (GenStgBinding bndr bdee) where+    ppr = pprGenStgBinding++instance (OutputableBndr bndr, Outputable bdee, Ord bdee)+                => Outputable (GenStgExpr bndr bdee) where+    ppr = pprStgExpr++instance (OutputableBndr bndr, Outputable bdee, Ord bdee)+                => Outputable (GenStgRhs bndr bdee) where+    ppr rhs = pprStgRhs rhs++pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc+pprStgArg (StgVarArg var) = ppr var+pprStgArg (StgLitArg con) = ppr con++pprStgExpr :: (OutputableBndr bndr, Outputable bdee, Ord bdee)+           => GenStgExpr bndr bdee -> SDoc+-- special case+pprStgExpr (StgLit lit)     = ppr lit++-- general case+pprStgExpr (StgApp func args)+  = hang (ppr func) 4 (sep (map (ppr) args))++pprStgExpr (StgConApp con args _)+  = hsep [ ppr con, brackets (interppSP args) ]++pprStgExpr (StgOpApp op args _)+  = hsep [ pprStgOp op, brackets (interppSP args)]++pprStgExpr (StgLam bndrs body)+  = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) bndrs)+            <+> text "->",+         pprStgExpr body ]+  where ppr_list = brackets . fsep . punctuate comma++-- special case: let v = <very specific thing>+--               in+--               let ...+--               in+--               ...+--+-- Very special!  Suspicious! (SLPJ)++{-+pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))+                        expr@(StgLet _ _))+  = ($$)+      (hang (hcat [text "let { ", ppr bndr, ptext (sLit " = "),+                          ppr cc,+                          pp_binder_info bi,+                          text " [", ifPprDebug (interppSP free_vars), ptext (sLit "] \\"),+                          ppr upd_flag, text " [",+                          interppSP args, char ']'])+            8 (sep [hsep [ppr rhs, text "} in"]]))+      (ppr expr)+-}++-- special case: let ... in let ...++pprStgExpr (StgLet bind expr@(StgLet _ _))+  = ($$)+      (sep [hang (text "let {")+                2 (hsep [pprGenStgBinding bind, text "} in"])])+      (ppr expr)++-- general case+pprStgExpr (StgLet bind expr)+  = sep [hang (text "let {") 2 (pprGenStgBinding bind),+           hang (text "} in ") 2 (ppr expr)]++pprStgExpr (StgLetNoEscape bind expr)+  = sep [hang (text "let-no-escape {")+                2 (pprGenStgBinding bind),+           hang (text "} in ")+                2 (ppr expr)]++pprStgExpr (StgTick tickish expr)+  = sdocWithDynFlags $ \dflags ->+    if gopt Opt_SuppressTicks dflags+    then pprStgExpr expr+    else sep [ ppr tickish, pprStgExpr expr ]+++pprStgExpr (StgCase expr bndr alt_type alts)+  = sep [sep [text "case",+           nest 4 (hsep [pprStgExpr expr,+             ifPprDebug (dcolon <+> ppr alt_type)]),+           text "of", pprBndr CaseBind bndr, char '{'],+           nest 2 (vcat (map pprStgAlt alts)),+           char '}']++pprStgAlt :: (OutputableBndr bndr, Outputable occ, Ord occ)+          => GenStgAlt bndr occ -> SDoc+pprStgAlt (con, params, expr)+  = hang (hsep [ppr con, sep (map (pprBndr CasePatBind) params), text "->"])+         4 (ppr expr <> semi)++pprStgOp :: StgOp -> SDoc+pprStgOp (StgPrimOp  op)   = ppr op+pprStgOp (StgPrimCallOp op)= ppr op+pprStgOp (StgFCallOp op _) = ppr op++instance Outputable AltType where+  ppr PolyAlt         = text "Polymorphic"+  ppr (MultiValAlt n) = text "MultiAlt" <+> ppr n+  ppr (AlgAlt tc)     = text "Alg"    <+> ppr tc+  ppr (PrimAlt tc)    = text "Prim"   <+> ppr tc++pprStgRhs :: (OutputableBndr bndr, Outputable bdee, Ord bdee)+          => GenStgRhs bndr bdee -> SDoc++-- special case+pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func []))+  = hsep [ ppr cc,+           pp_binder_info bi,+           brackets (ifPprDebug (ppr free_var)),+           text " \\", ppr upd_flag, ptext (sLit " [] "), ppr func ]++-- general case+pprStgRhs (StgRhsClosure cc bi free_vars upd_flag args body)+  = sdocWithDynFlags $ \dflags ->+    hang (hsep [if gopt Opt_SccProfilingOn dflags then ppr cc else empty,+                pp_binder_info bi,+                ifPprDebug (brackets (interppSP free_vars)),+                char '\\' <> ppr upd_flag, brackets (interppSP args)])+         4 (ppr body)++pprStgRhs (StgRhsCon cc con args)+  = hcat [ ppr cc,+           space, ppr con, text "! ", brackets (interppSP args)]
+ stranal/DmdAnal.hs view
@@ -0,0 +1,1482 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998+++                        -----------------+                        A demand analysis+                        -----------------+-}++{-# LANGUAGE CPP #-}++module DmdAnal ( dmdAnalProgram ) where++#include "HsVersions.h"++import DynFlags+import WwLib            ( findTypeShape, deepSplitProductType_maybe )+import Demand   -- All of it+import CoreSyn+import CoreSeq          ( seqBinds )+import Outputable+import VarEnv+import BasicTypes+import Data.List+import DataCon+import Id+import CoreUtils        ( exprIsHNF, exprType, exprIsTrivial )+import TyCon+import Type+import Coercion         ( Coercion, coVarsOfCo )+import FamInstEnv+import Util+import Maybes           ( isJust )+import TysWiredIn+import TysPrim          ( realWorldStatePrimTy )+import ErrUtils         ( dumpIfSet_dyn )+import Name             ( getName, stableNameCmp )+import Data.Function    ( on )+import UniqSet++{-+************************************************************************+*                                                                      *+\subsection{Top level stuff}+*                                                                      *+************************************************************************+-}++dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram+dmdAnalProgram dflags fam_envs binds+  = do {+        let { binds_plus_dmds = do_prog binds } ;+        dumpIfSet_dyn dflags Opt_D_dump_str_signatures+                      "Strictness signatures" $+            dumpStrSig binds_plus_dmds ;+        -- See Note [Stamp out space leaks in demand analysis]+        seqBinds binds_plus_dmds `seq` return binds_plus_dmds+    }+  where+    do_prog :: CoreProgram -> CoreProgram+    do_prog binds = snd $ mapAccumL dmdAnalTopBind (emptyAnalEnv dflags fam_envs) binds++-- Analyse a (group of) top-level binding(s)+dmdAnalTopBind :: AnalEnv+               -> CoreBind+               -> (AnalEnv, CoreBind)+dmdAnalTopBind sigs (NonRec id rhs)+  = (extendAnalEnv TopLevel sigs id2 (idStrictness id2), NonRec id2 rhs2)+  where+    ( _, _,   rhs1) = dmdAnalRhsLetDown TopLevel Nothing sigs             id rhs+    ( _, id2, rhs2) = dmdAnalRhsLetDown TopLevel Nothing (nonVirgin sigs) id rhs1+        -- Do two passes to improve CPR information+        -- See Note [CPR for thunks]+        -- See Note [Optimistic CPR in the "virgin" case]+        -- See Note [Initial CPR for strict binders]++dmdAnalTopBind sigs (Rec pairs)+  = (sigs', Rec pairs')+  where+    (sigs', _, pairs')  = dmdFix TopLevel sigs pairs+                -- We get two iterations automatically+                -- c.f. the NonRec case above++{- Note [Stamp out space leaks in demand analysis]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The demand analysis pass outputs a new copy of the Core program in+which binders have been annotated with demand and strictness+information. It's tiresome to ensure that this information is fully+evaluated everywhere that we produce it, so we just run a single+seqBinds over the output before returning it, to ensure that there are+no references holding on to the input Core program.++This is particularly important when we are doing late demand analysis,+since we don't do a seqBinds at any point thereafter. Hence code+generation would hold on to an extra copy of the Core program, via+unforced thunks in demand or strictness information; and it is the+most memory-intensive part of the compilation process, so this added+seqBinds makes a big difference in peak memory usage.+-}+++{-+************************************************************************+*                                                                      *+\subsection{The analyser itself}+*                                                                      *+************************************************************************++Note [Ensure demand is strict]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's important not to analyse e with a lazy demand because+a) When we encounter   case s of (a,b) ->+        we demand s with U(d1d2)... but if the overall demand is lazy+        that is wrong, and we'd need to reduce the demand on s,+        which is inconvenient+b) More important, consider+        f (let x = R in x+x), where f is lazy+   We still want to mark x as demanded, because it will be when we+   enter the let.  If we analyse f's arg with a Lazy demand, we'll+   just mark x as Lazy+c) The application rule wouldn't be right either+   Evaluating (f x) in a L demand does *not* cause+   evaluation of f in a C(L) demand!+-}++-- If e is complicated enough to become a thunk, its contents will be evaluated+-- at most once, so oneify it.+dmdTransformThunkDmd :: CoreExpr -> Demand -> Demand+dmdTransformThunkDmd e+  | exprIsTrivial e = id+  | otherwise       = oneifyDmd++-- Do not process absent demands+-- Otherwise act like in a normal demand analysis+-- See ↦* relation in the Cardinality Analysis paper+dmdAnalStar :: AnalEnv+            -> Demand   -- This one takes a *Demand*+            -> CoreExpr -> (BothDmdArg, CoreExpr)+dmdAnalStar env dmd e+  | (defer_and_use, cd) <- toCleanDmd dmd (exprType e)+  , (dmd_ty, e')        <- dmdAnal env cd e+  = (postProcessDmdType defer_and_use dmd_ty, e')++-- Main Demand Analsysis machinery+dmdAnal, dmdAnal' :: AnalEnv+        -> CleanDemand         -- The main one takes a *CleanDemand*+        -> CoreExpr -> (DmdType, CoreExpr)++-- The CleanDemand is always strict and not absent+--    See Note [Ensure demand is strict]++dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $+                  dmdAnal' env d e++dmdAnal' _ _ (Lit lit)     = (nopDmdType, Lit lit)+dmdAnal' _ _ (Type ty)     = (nopDmdType, Type ty)      -- Doesn't happen, in fact+dmdAnal' _ _ (Coercion co)+  = (unitDmdType (coercionDmdEnv co), Coercion co)++dmdAnal' env dmd (Var var)+  = (dmdTransform env var dmd, Var var)++dmdAnal' env dmd (Cast e co)+  = (dmd_ty `bothDmdType` mkBothDmdArg (coercionDmdEnv co), Cast e' co)+  where+    (dmd_ty, e') = dmdAnal env dmd e++{-       ----- I don't get this, so commenting out -------+    to_co        = pSnd (coercionKind co)+    dmd'+      | Just tc <- tyConAppTyCon_maybe to_co+      , isRecursiveTyCon tc = cleanEvalDmd+      | otherwise           = dmd+        -- This coerce usually arises from a recursive+        -- newtype, and we don't want to look inside them+        -- for exactly the same reason that we don't look+        -- inside recursive products -- we might not reach+        -- a fixpoint.  So revert to a vanilla Eval demand+-}++dmdAnal' env dmd (Tick t e)+  = (dmd_ty, Tick t e')+  where+    (dmd_ty, e') = dmdAnal env dmd e++dmdAnal' env dmd (App fun (Type ty))+  = (fun_ty, App fun' (Type ty))+  where+    (fun_ty, fun') = dmdAnal env dmd fun++-- Lots of the other code is there to make this+-- beautiful, compositional, application rule :-)+dmdAnal' env dmd (App fun arg)+  = -- This case handles value arguments (type args handled above)+    -- Crucially, coercions /are/ handled here, because they are+    -- value arguments (Trac #10288)+    let+        call_dmd          = mkCallDmd dmd+        (fun_ty, fun')    = dmdAnal env call_dmd fun+        (arg_dmd, res_ty) = splitDmdTy fun_ty+        (arg_ty, arg')    = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg+    in+--    pprTrace "dmdAnal:app" (vcat+--         [ text "dmd =" <+> ppr dmd+--         , text "expr =" <+> ppr (App fun arg)+--         , text "fun dmd_ty =" <+> ppr fun_ty+--         , text "arg dmd =" <+> ppr arg_dmd+--         , text "arg dmd_ty =" <+> ppr arg_ty+--         , text "res dmd_ty =" <+> ppr res_ty+--         , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ])+    (res_ty `bothDmdType` arg_ty, App fun' arg')++-- this is an anonymous lambda, since @dmdAnalRhsLetDown@ uses @collectBinders@+dmdAnal' env dmd (Lam var body)+  | isTyVar var+  = let+        (body_ty, body') = dmdAnal env dmd body+    in+    (body_ty, Lam var body')++  | otherwise+  = let (body_dmd, defer_and_use) = peelCallDmd dmd+          -- body_dmd: a demand to analyze the body++        env'             = extendSigsWithLam env var+        (body_ty, body') = dmdAnal env' body_dmd body+        (lam_ty, var')   = annotateLamIdBndr env notArgOfDfun body_ty var+    in+    (postProcessUnsat defer_and_use lam_ty, Lam var' body')++dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)])+  -- Only one alternative with a product constructor+  | let tycon = dataConTyCon dc+  , isJust (isDataProductTyCon_maybe tycon)+  , Just rec_tc' <- checkRecTc (ae_rec_tc env) tycon+  = let+        env_w_tc                 = env { ae_rec_tc = rec_tc' }+        env_alt                  = extendEnvForProdAlt env_w_tc scrut case_bndr dc bndrs+        (rhs_ty, rhs')           = dmdAnal env_alt dmd rhs+        (alt_ty1, dmds)          = findBndrsDmds env rhs_ty bndrs+        (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr+        id_dmds                  = addCaseBndrDmd case_bndr_dmd dmds+        alt_ty3 | io_hack_reqd scrut dc bndrs = deferAfterIO alt_ty2+                | otherwise                   = alt_ty2++        -- Compute demand on the scrutinee+        -- See Note [Demand on scrutinee of a product case]+        scrut_dmd          = mkProdDmd (addDataConStrictness dc id_dmds)+        (scrut_ty, scrut') = dmdAnal env scrut_dmd scrut+        res_ty             = alt_ty3 `bothDmdType` toBothDmdArg scrut_ty+        case_bndr'         = setIdDemandInfo case_bndr case_bndr_dmd+        bndrs'             = setBndrsDemandInfo bndrs id_dmds+    in+--    pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut+--                                   , text "dmd" <+> ppr dmd+--                                   , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr')+--                                   , text "scrut_dmd" <+> ppr scrut_dmd+--                                   , text "scrut_ty" <+> ppr scrut_ty+--                                   , text "alt_ty" <+> ppr alt_ty2+--                                   , text "res_ty" <+> ppr res_ty ]) $+    (res_ty, Case scrut' case_bndr' ty [(DataAlt dc, bndrs', rhs')])++dmdAnal' env dmd (Case scrut case_bndr ty alts)+  = let      -- Case expression with multiple alternatives+        (alt_tys, alts')     = mapAndUnzip (dmdAnalAlt env dmd case_bndr) alts+        (scrut_ty, scrut')   = dmdAnal env cleanEvalDmd scrut+        (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr+                               -- NB: Base case is botDmdType, for empty case alternatives+                               --     This is a unit for lubDmdType, and the right result+                               --     when there really are no alternatives+        res_ty               = alt_ty `bothDmdType` toBothDmdArg scrut_ty+    in+--    pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut+--                                   , text "scrut_ty" <+> ppr scrut_ty+--                                   , text "alt_tys" <+> ppr alt_tys+--                                   , text "alt_ty" <+> ppr alt_ty+--                                   , text "res_ty" <+> ppr res_ty ]) $+    (res_ty, Case scrut' case_bndr' ty alts')++-- Let bindings can be processed in two ways:+-- Down (RHS before body) or Up (body before RHS).+-- The following case handle the up variant.+--+-- It is very simple. For  let x = rhs in body+--   * Demand-analyse 'body' in the current environment+--   * Find the demand, 'rhs_dmd' placed on 'x' by 'body'+--   * Demand-analyse 'rhs' in 'rhs_dmd'+--+-- This is used for a non-recursive local let without manifest lambdas.+-- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”.+dmdAnal' env dmd (Let (NonRec id rhs) body)+  | useLetUp id rhs+  , Nothing <- unpackTrivial rhs+      -- dmdAnalRhsLetDown treats trivial right hand sides specially+      -- so if we have a trival right hand side, fall through to that.+  = (final_ty, Let (NonRec id' rhs') body')+  where+    (body_ty, body')   = dmdAnal env dmd body+    (body_ty', id_dmd) = findBndrDmd env notArgOfDfun body_ty id+    id'                = setIdDemandInfo id id_dmd++    (rhs_ty, rhs')     = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs+    final_ty           = body_ty' `bothDmdType` rhs_ty++dmdAnal' env dmd (Let (NonRec id rhs) body)+  = (body_ty2, Let (NonRec id2 rhs') body')+  where+    (lazy_fv, id1, rhs') = dmdAnalRhsLetDown NotTopLevel Nothing env id rhs+    env1                 = extendAnalEnv NotTopLevel env id1 (idStrictness id1)+    (body_ty, body')     = dmdAnal env1 dmd body+    (body_ty1, id2)      = annotateBndr env body_ty id1+    body_ty2             = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleasheable free variables]++        -- If the actual demand is better than the vanilla call+        -- demand, you might think that we might do better to re-analyse+        -- the RHS with the stronger demand.+        -- But (a) That seldom happens, because it means that *every* path in+        --         the body of the let has to use that stronger demand+        -- (b) It often happens temporarily in when fixpointing, because+        --     the recursive function at first seems to place a massive demand.+        --     But we don't want to go to extra work when the function will+        --     probably iterate to something less demanding.+        -- In practice, all the times the actual demand on id2 is more than+        -- the vanilla call demand seem to be due to (b).  So we don't+        -- bother to re-analyse the RHS.++dmdAnal' env dmd (Let (Rec pairs) body)+  = let+        (env', lazy_fv, pairs') = dmdFix NotTopLevel env pairs+        (body_ty, body')        = dmdAnal env' dmd body+        body_ty1                = deleteFVs body_ty (map fst pairs)+        body_ty2                = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleasheable free variables]+    in+    body_ty2 `seq`+    (body_ty2,  Let (Rec pairs') body')++io_hack_reqd :: CoreExpr -> DataCon -> [Var] -> Bool+-- See Note [IO hack in the demand analyser]+io_hack_reqd scrut con bndrs+  | (bndr:_) <- bndrs+  , con == tupleDataCon Unboxed 2+  , idType bndr `eqType` realWorldStatePrimTy+  , (fun, _) <- collectArgs scrut+  = case fun of+      Var f -> not (isPrimOpId f)+      _     -> True+  | otherwise+  = False++dmdAnalAlt :: AnalEnv -> CleanDemand -> Id -> Alt Var -> (DmdType, Alt Var)+dmdAnalAlt env dmd case_bndr (con,bndrs,rhs)+  | null bndrs    -- Literals, DEFAULT, and nullary constructors+  , (rhs_ty, rhs') <- dmdAnal env dmd rhs+  = (rhs_ty, (con, [], rhs'))++  | otherwise     -- Non-nullary data constructors+  , (rhs_ty, rhs') <- dmdAnal env dmd rhs+  , (alt_ty, dmds) <- findBndrsDmds env rhs_ty bndrs+  , let case_bndr_dmd = findIdDemand alt_ty case_bndr+        id_dmds       = addCaseBndrDmd case_bndr_dmd dmds+  = (alt_ty, (con, setBndrsDemandInfo bndrs id_dmds, rhs'))+++{- Note [IO hack in the demand analyser]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There's a hack here for I/O operations.  Consider++     case foo x s of { (# s', r #) -> y }++Is this strict in 'y'? Often not! If foo x s performs some observable action+(including raising an exception with raiseIO#, modifying a mutable variable, or+even ending the program normally), then we must not force 'y' (which may fail+to terminate) until we have performed foo x s.++Hackish solution: spot the IO-like situation and add a virtual branch,+as if we had+     case foo x s of+        (# s, r #) -> y+        other      -> return ()+So the 'y' isn't necessarily going to be evaluated++A more complete example (Trac #148, #1592) where this shows up is:+     do { let len = <expensive> ;+        ; when (...) (exitWith ExitSuccess)+        ; print len }++However, consider+  f x s = case getMaskingState# s of+            (# s, r #) ->+          case x of I# x2 -> ...++Here it is terribly sad to make 'f' lazy in 's'.  After all,+getMaskingState# is not going to diverge or throw an exception!  This+situation actually arises in GHC.IO.Handle.Internals.wantReadableHandle+(on an MVar not an Int), and made a material difference.++So if the scrutinee is a primop call, we *don't* apply the+state hack:+  - If is a simple, terminating one like getMaskingState,+    applying the hack is over-conservative.+  - If the primop is raise# then it returns bottom, so+    the case alternatives are already discarded.+  - If the primop can raise a non-IO exception, like+    divide by zero or seg-fault (eg writing an array+    out of bounds) then we don't mind evaluating 'x' first.++Note [Demand on the scrutinee of a product case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When figuring out the demand on the scrutinee of a product case,+we use the demands of the case alternative, i.e. id_dmds.+But note that these include the demand on the case binder;+see Note [Demand on case-alternative binders] in Demand.hs.+This is crucial. Example:+   f x = case x of y { (a,b) -> k y a }+If we just take scrut_demand = U(L,A), then we won't pass x to the+worker, so the worker will rebuild+     x = (a, absent-error)+and that'll crash.++Note [Aggregated demand for cardinality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We use different strategies for strictness and usage/cardinality to+"unleash" demands captured on free variables by bindings. Let us+consider the example:++f1 y = let {-# NOINLINE h #-}+           h = y+       in  (h, h)++We are interested in obtaining cardinality demand U1 on |y|, as it is+used only in a thunk, and, therefore, is not going to be updated any+more. Therefore, the demand on |y|, captured and unleashed by usage of+|h| is U1. However, if we unleash this demand every time |h| is used,+and then sum up the effects, the ultimate demand on |y| will be U1 ++U1 = U. In order to avoid it, we *first* collect the aggregate demand+on |h| in the body of let-expression, and only then apply the demand+transformer:++transf[x](U) = {y |-> U1}++so the resulting demand on |y| is U1.++The situation is, however, different for strictness, where this+aggregating approach exhibits worse results because of the nature of+|both| operation for strictness. Consider the example:++f y c =+  let h x = y |seq| x+   in case of+        True  -> h True+        False -> y++It is clear that |f| is strict in |y|, however, the suggested analysis+will infer from the body of |let| that |h| is used lazily (as it is+used in one branch only), therefore lazy demand will be put on its+free variable |y|. Conversely, if the demand on |h| is unleashed right+on the spot, we will get the desired result, namely, that |f| is+strict in |y|.+++************************************************************************+*                                                                      *+                    Demand transformer+*                                                                      *+************************************************************************+-}++dmdTransform :: AnalEnv         -- The strictness environment+             -> Id              -- The function+             -> CleanDemand     -- The demand on the function+             -> DmdType         -- The demand type of the function in this context+        -- Returned DmdEnv includes the demand on+        -- this function plus demand on its free variables++dmdTransform env var dmd+  | isDataConWorkId var                          -- Data constructor+  = dmdTransformDataConSig (idArity var) (idStrictness var) dmd++  | gopt Opt_DmdTxDictSel (ae_dflags env),+    Just _ <- isClassOpId_maybe var -- Dictionary component selector+  = dmdTransformDictSelSig (idStrictness var) dmd++  | isGlobalId var                               -- Imported function+  = let res = dmdTransformSig (idStrictness var) dmd in+--    pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res])+    res++  | Just (sig, top_lvl) <- lookupSigEnv env var  -- Local letrec bound thing+  , let fn_ty = dmdTransformSig sig dmd+  = -- pprTrace "dmdTransform" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $+    if isTopLevel top_lvl+    then fn_ty   -- Don't record top level things+    else addVarDmd fn_ty var (mkOnceUsedDmd dmd)++  | otherwise                                    -- Local non-letrec-bound thing+  = unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd))++{-+************************************************************************+*                                                                      *+\subsection{Bindings}+*                                                                      *+************************************************************************+-}++-- Recursive bindings+dmdFix :: TopLevelFlag+       -> AnalEnv                            -- Does not include bindings for this binding+       -> [(Id,CoreExpr)]+       -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with stricness info++dmdFix top_lvl env orig_pairs+  = loop 1 initial_pairs+  where+    bndrs = map fst orig_pairs++    -- See Note [Initialising strictness]+    initial_pairs | ae_virgin env = [(setIdStrictness id botSig, rhs) | (id, rhs) <- orig_pairs ]++                  | otherwise     = orig_pairs++    -- If fixed-point iteration does not yield a result we use this instead+    -- See Note [Safe abortion in the fixed-point iteration]+    abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)])+    abort = (env, lazy_fv', zapped_pairs)+      where (lazy_fv, pairs') = step True (zapIdStrictness orig_pairs)+            -- Note [Lazy and unleasheable free variables]+            non_lazy_fvs = plusVarEnvList $ map (strictSigDmdEnv . idStrictness . fst) pairs'+            lazy_fv'     = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs+            zapped_pairs = zapIdStrictness pairs'++    -- The fixed-point varies the idStrictness field of the binders, and terminates if that+    -- annotation does not change any more.+    loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)])+    loop n pairs+      | found_fixpoint = (final_anal_env, lazy_fv, pairs')+      | n == 10        = abort+      | otherwise      = loop (n+1) pairs'+      where+        found_fixpoint    = map (idStrictness . fst) pairs' == map (idStrictness . fst) pairs+        first_round       = n == 1+        (lazy_fv, pairs') = step first_round pairs+        final_anal_env    = extendAnalEnvs top_lvl env (map fst pairs')++    step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)])+    step first_round pairs = (lazy_fv, pairs')+      where+        -- In all but the first iteration, delete the virgin flag+        start_env | first_round = env+                  | otherwise   = nonVirgin env++        start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyDmdEnv)++        ((_,lazy_fv), pairs') = mapAccumL my_downRhs start pairs+                -- mapAccumL: Use the new signature to do the next pair+                -- The occurrence analyser has arranged them in a good order+                -- so this can significantly reduce the number of iterations needed++        my_downRhs (env, lazy_fv) (id,rhs)+          = ((env', lazy_fv'), (id', rhs'))+          where+            (lazy_fv1, id', rhs') = dmdAnalRhsLetDown top_lvl (Just bndrs) env id rhs+            lazy_fv'              = plusVarEnv_C bothDmd lazy_fv lazy_fv1+            env'                  = extendAnalEnv top_lvl env id (idStrictness id')+++    zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]+    zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ]++{-+Note [Safe abortion in the fixed-point iteration]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Fixed-point iteration may fail to terminate. But we cannot simply give up and+return the environment and code unchanged! We still need to do one additional+round, for two reasons:++ * To get information on used free variables (both lazy and strict!)+   (see Note [Lazy and unleasheable free variables])+ * To ensure that all expressions have been traversed at least once, and any left-over+   strictness annotations have been updated.++This final iteration does not add the variables to the strictness signature+environment, which effectively assigns them 'nopSig' (see "getStrictness")++-}++-- Trivial RHS+-- See Note [Demand analysis for trivial right-hand sides]+dmdAnalTrivialRhs ::+    AnalEnv -> Id -> CoreExpr -> Var ->+    (DmdEnv, Id, CoreExpr)+dmdAnalTrivialRhs env id rhs fn+  = (fn_fv, set_idStrictness env id fn_str, rhs)+  where+    fn_str = getStrictness env fn+    fn_fv | isLocalId fn = unitVarEnv fn topDmd+          | otherwise    = emptyDmdEnv+    -- Note [Remember to demand the function itself]+    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    -- fn_fv: don't forget to produce a demand for fn itself+    -- Lacking this caused Trac #9128+    -- The demand is very conservative (topDmd), but that doesn't+    -- matter; trivial bindings are usually inlined, so it only+    -- kicks in for top-level bindings and NOINLINE bindings++-- Let bindings can be processed in two ways:+-- Down (RHS before body) or Up (body before RHS).+-- dmdAnalRhsLetDown implements the Down variant:+--  * assuming a demand of <L,U>+--  * looking at the definition+--  * determining a strictness signature+--+-- It is used for toplevel definition, recursive definitions and local+-- non-recursive definitions that have manifest lambdas.+-- Local non-recursive definitions without a lambda are handled with LetUp.+--+-- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”.+dmdAnalRhsLetDown :: TopLevelFlag+           -> Maybe [Id]   -- Just bs <=> recursive, Nothing <=> non-recursive+           -> AnalEnv -> Id -> CoreExpr+           -> (DmdEnv, Id, CoreExpr)+-- Process the RHS of the binding, add the strictness signature+-- to the Id, and augment the environment with the signature as well.+dmdAnalRhsLetDown top_lvl rec_flag env id rhs+  | Just fn <- unpackTrivial rhs   -- See Note [Demand analysis for trivial right-hand sides]+  = dmdAnalTrivialRhs env id rhs fn++  | otherwise+  = (lazy_fv, id', mkLams bndrs' body')+  where+    (bndrs, body)    = collectBinders rhs+    env_body         = foldl extendSigsWithLam env bndrs+    (body_ty, body') = dmdAnal env_body body_dmd body+    body_ty'         = removeDmdTyArgs body_ty -- zap possible deep CPR info+    (DmdType rhs_fv rhs_dmds rhs_res, bndrs')+                     = annotateLamBndrs env (isDFunId id) body_ty' bndrs+    sig_ty           = mkStrictSig (mkDmdType sig_fv rhs_dmds rhs_res')+    id'              = set_idStrictness env id sig_ty+        -- See Note [NOINLINE and strictness]++    -- See Note [Product demands for function body]+    body_dmd = case deepSplitProductType_maybe (ae_fam_envs env) (exprType body) of+                 Nothing            -> cleanEvalDmd+                 Just (dc, _, _, _) -> cleanEvalProdDmd (dataConRepArity dc)++    -- See Note [Aggregated demand for cardinality]+    rhs_fv1 = case rec_flag of+                Just bs -> reuseEnv (delVarEnvList rhs_fv bs)+                Nothing -> rhs_fv++    -- See Note [Lazy and unleashable free variables]+    (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1++    rhs_res'  = trimCPRInfo trim_all trim_sums rhs_res+    trim_all  = is_thunk && not_strict+    trim_sums = not (isTopLevel top_lvl) -- See Note [CPR for sum types]++    -- See Note [CPR for thunks]+    is_thunk = not (exprIsHNF rhs) && not (isJoinId id)+    not_strict+       =  isTopLevel top_lvl  -- Top level and recursive things don't+       || isJust rec_flag     -- get their demandInfo set at all+       || not (isStrictDmd (idDemandInfo id) || ae_virgin env)+          -- See Note [Optimistic CPR in the "virgin" case]++unpackTrivial :: CoreExpr -> Maybe Id+-- Returns (Just v) if the arg is really equal to v, modulo+-- casts, type applications etc+-- See Note [Demand analysis for trivial right-hand sides]+unpackTrivial (Var v)                 = Just v+unpackTrivial (Cast e _)              = unpackTrivial e+unpackTrivial (Lam v e) | isTyVar v   = unpackTrivial e+unpackTrivial (App e a) | isTypeArg a = unpackTrivial e+unpackTrivial _                       = Nothing++-- | If given the RHS of a let-binding, this 'useLetUp' determines+-- whether we should process the binding up (body before rhs) or+-- down (rhs before body).+--+-- We use LetDown if there is a chance to get a useful strictness signature.+-- This is the case when there are manifest value lambdas or the binding is a+-- join point (hence always acts like a function, not a value).+useLetUp :: Var -> CoreExpr -> Bool+useLetUp f _         | isJoinId f = False+useLetUp f (Lam v e) | isTyVar v  = useLetUp f e+useLetUp _ (Lam _ _)              = False+useLetUp _ _                      = True+++{-+Note [Demand analysis for trivial right-hand sides]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+        foo = plusInt |> co+where plusInt is an arity-2 function with known strictness.  Clearly+we want plusInt's strictness to propagate to foo!  But because it has+no manifest lambdas, it won't do so automatically, and indeed 'co' might+have type (Int->Int->Int) ~ T, so we *can't* eta-expand.  So we have a+special case for right-hand sides that are "trivial", namely variables,+casts, type applications, and the like.++Note that this can mean that 'foo' has an arity that is smaller than that+indicated by its demand info.  e.g. if co :: (Int->Int->Int) ~ T, then+foo's arity will be zero (see Note [exprArity invariant] in CoreArity),+but its demand signature will be that of plusInt. A small example is the+test case of Trac #8963.+++Note [Product demands for function body]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This example comes from shootout/binary_trees:++    Main.check' = \ b z ds. case z of z' { I# ip ->+                                case ds_d13s of+                                  Main.Nil -> z'+                                  Main.Node s14k s14l s14m ->+                                    Main.check' (not b)+                                      (Main.check' b+                                         (case b {+                                            False -> I# (-# s14h s14k);+                                            True  -> I# (+# s14h s14k)+                                          })+                                         s14l)+                                     s14m   }   }   }++Here we *really* want to unbox z, even though it appears to be used boxed in+the Nil case.  Partly the Nil case is not a hot path.  But more specifically,+the whole function gets the CPR property if we do.++So for the demand on the body of a RHS we use a product demand if it's+a product type.++************************************************************************+*                                                                      *+\subsection{Strictness signatures and types}+*                                                                      *+************************************************************************+-}++unitDmdType :: DmdEnv -> DmdType+unitDmdType dmd_env = DmdType dmd_env [] topRes++coercionDmdEnv :: Coercion -> DmdEnv+coercionDmdEnv co = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCo co)+                    -- The VarSet from coVarsOfCo is really a VarEnv Var++addVarDmd :: DmdType -> Var -> Demand -> DmdType+addVarDmd (DmdType fv ds res) var dmd+  = DmdType (extendVarEnv_C bothDmd fv var dmd) ds res++addLazyFVs :: DmdType -> DmdEnv -> DmdType+addLazyFVs dmd_ty lazy_fvs+  = dmd_ty `bothDmdType` mkBothDmdArg lazy_fvs+        -- Using bothDmdType (rather than just both'ing the envs)+        -- is vital.  Consider+        --      let f = \x -> (x,y)+        --      in  error (f 3)+        -- Here, y is treated as a lazy-fv of f, but we must `bothDmd` that L+        -- demand with the bottom coming up from 'error'+        --+        -- I got a loop in the fixpointer without this, due to an interaction+        -- with the lazy_fv filtering in dmdAnalRhsLetDown.  Roughly, it was+        --      letrec f n x+        --          = letrec g y = x `fatbar`+        --                         letrec h z = z + ...g...+        --                         in h (f (n-1) x)+        --      in ...+        -- In the initial iteration for f, f=Bot+        -- Suppose h is found to be strict in z, but the occurrence of g in its RHS+        -- is lazy.  Now consider the fixpoint iteration for g, esp the demands it+        -- places on its free variables.  Suppose it places none.  Then the+        --      x `fatbar` ...call to h...+        -- will give a x->V demand for x.  That turns into a L demand for x,+        -- which floats out of the defn for h.  Without the modifyEnv, that+        -- L demand doesn't get both'd with the Bot coming up from the inner+        -- call to f.  So we just get an L demand for x for g.++{-+Note [Do not strictify the argument dictionaries of a dfun]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The typechecker can tie recursive knots involving dfuns, so we do the+conservative thing and refrain from strictifying a dfun's argument+dictionaries.+-}++setBndrsDemandInfo :: [Var] -> [Demand] -> [Var]+setBndrsDemandInfo (b:bs) (d:ds)+  | isTyVar b = b : setBndrsDemandInfo bs (d:ds)+  | otherwise = setIdDemandInfo b d : setBndrsDemandInfo bs ds+setBndrsDemandInfo [] ds = ASSERT( null ds ) []+setBndrsDemandInfo bs _  = pprPanic "setBndrsDemandInfo" (ppr bs)++annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var)+-- The returned env has the var deleted+-- The returned var is annotated with demand info+-- according to the result demand of the provided demand type+-- No effect on the argument demands+annotateBndr env dmd_ty var+  | isId var  = (dmd_ty', setIdDemandInfo var dmd)+  | otherwise = (dmd_ty, var)+  where+    (dmd_ty', dmd) = findBndrDmd env False dmd_ty var++annotateLamBndrs :: AnalEnv -> DFunFlag -> DmdType -> [Var] -> (DmdType, [Var])+annotateLamBndrs env args_of_dfun ty bndrs = mapAccumR annotate ty bndrs+  where+    annotate dmd_ty bndr+      | isId bndr = annotateLamIdBndr env args_of_dfun dmd_ty bndr+      | otherwise = (dmd_ty, bndr)++annotateLamIdBndr :: AnalEnv+                  -> DFunFlag   -- is this lambda at the top of the RHS of a dfun?+                  -> DmdType    -- Demand type of body+                  -> Id         -- Lambda binder+                  -> (DmdType,  -- Demand type of lambda+                      Id)       -- and binder annotated with demand++annotateLamIdBndr env arg_of_dfun dmd_ty id+-- For lambdas we add the demand to the argument demands+-- Only called for Ids+  = ASSERT( isId id )+    -- pprTrace "annLamBndr" (vcat [ppr id, ppr _dmd_ty]) $+    (final_ty, setIdDemandInfo id dmd)+  where+      -- Watch out!  See note [Lambda-bound unfoldings]+    final_ty = case maybeUnfoldingTemplate (idUnfolding id) of+                 Nothing  -> main_ty+                 Just unf -> main_ty `bothDmdType` unf_ty+                          where+                             (unf_ty, _) = dmdAnalStar env dmd unf++    main_ty = addDemand dmd dmd_ty'+    (dmd_ty', dmd) = findBndrDmd env arg_of_dfun dmd_ty id++deleteFVs :: DmdType -> [Var] -> DmdType+deleteFVs (DmdType fvs dmds res) bndrs+  = DmdType (delVarEnvList fvs bndrs) dmds res++{-+Note [CPR for sum types]+~~~~~~~~~~~~~~~~~~~~~~~~+At the moment we do not do CPR for let-bindings that+   * non-top level+   * bind a sum type+Reason: I found that in some benchmarks we were losing let-no-escapes,+which messed it all up.  Example+   let j = \x. ....+   in case y of+        True  -> j False+        False -> j True+If we w/w this we get+   let j' = \x. ....+   in case y of+        True  -> case j' False of { (# a #) -> Just a }+        False -> case j' True of { (# a #) -> Just a }+Notice that j' is not a let-no-escape any more.++However this means in turn that the *enclosing* function+may be CPR'd (via the returned Justs).  But in the case of+sums, there may be Nothing alternatives; and that messes+up the sum-type CPR.++Conclusion: only do this for products.  It's still not+guaranteed OK for products, but sums definitely lose sometimes.++Note [CPR for thunks]+~~~~~~~~~~~~~~~~~~~~~+If the rhs is a thunk, we usually forget the CPR info, because+it is presumably shared (else it would have been inlined, and+so we'd lose sharing if w/w'd it into a function).  E.g.++        let r = case expensive of+                  (a,b) -> (b,a)+        in ...++If we marked r as having the CPR property, then we'd w/w into++        let $wr = \() -> case expensive of+                            (a,b) -> (# b, a #)+            r = case $wr () of+                  (# b,a #) -> (b,a)+        in ...++But now r is a thunk, which won't be inlined, so we are no further ahead.+But consider++        f x = let r = case expensive of (a,b) -> (b,a)+              in if foo r then r else (x,x)++Does f have the CPR property?  Well, no.++However, if the strictness analyser has figured out (in a previous+iteration) that it's strict, then we DON'T need to forget the CPR info.+Instead we can retain the CPR info and do the thunk-splitting transform+(see WorkWrap.splitThunk).++This made a big difference to PrelBase.modInt, which had something like+        modInt = \ x -> let r = ... -> I# v in+                        ...body strict in r...+r's RHS isn't a value yet; but modInt returns r in various branches, so+if r doesn't have the CPR property then neither does modInt+Another case I found in practice (in Complex.magnitude), looks like this:+                let k = if ... then I# a else I# b+                in ... body strict in k ....+(For this example, it doesn't matter whether k is returned as part of+the overall result; but it does matter that k's RHS has the CPR property.)+Left to itself, the simplifier will make a join point thus:+                let $j k = ...body strict in k...+                if ... then $j (I# a) else $j (I# b)+With thunk-splitting, we get instead+                let $j x = let k = I#x in ...body strict in k...+                in if ... then $j a else $j b+This is much better; there's a good chance the I# won't get allocated.++The difficulty with this is that we need the strictness type to+look at the body... but we now need the body to calculate the demand+on the variable, so we can decide whether its strictness type should+have a CPR in it or not.  Simple solution:+        a) use strictness info from the previous iteration+        b) make sure we do at least 2 iterations, by doing a second+           round for top-level non-recs.  Top level recs will get at+           least 2 iterations except for totally-bottom functions+           which aren't very interesting anyway.++NB: strictly_demanded is never true of a top-level Id, or of a recursive Id.++Note [Optimistic CPR in the "virgin" case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Demand and strictness info are initialized by top elements. However,+this prevents from inferring a CPR property in the first pass of the+analyser, so we keep an explicit flag ae_virgin in the AnalEnv+datatype.++We can't start with 'not-demanded' (i.e., top) because then consider+        f x = let+                  t = ... I# x+              in+              if ... then t else I# y else f x'++In the first iteration we'd have no demand info for x, so assume+not-demanded; then we'd get TopRes for f's CPR info.  Next iteration+we'd see that t was demanded, and so give it the CPR property, but by+now f has TopRes, so it will stay TopRes.  Instead, by checking the+ae_virgin flag at the first time round, we say 'yes t is demanded' the+first time.++However, this does mean that for non-recursive bindings we must+iterate twice to be sure of not getting over-optimistic CPR info,+in the case where t turns out to be not-demanded.  This is handled+by dmdAnalTopBind.+++Note [NOINLINE and strictness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The strictness analyser used to have a HACK which ensured that NOINLNE+things were not strictness-analysed.  The reason was unsafePerformIO.+Left to itself, the strictness analyser would discover this strictness+for unsafePerformIO:+        unsafePerformIO:  C(U(AV))+But then consider this sub-expression+        unsafePerformIO (\s -> let r = f x in+                               case writeIORef v r s of (# s1, _ #) ->+                               (# s1, r #)+The strictness analyser will now find that r is sure to be eval'd,+and may then hoist it out.  This makes tests/lib/should_run/memo002+deadlock.++Solving this by making all NOINLINE things have no strictness info is overkill.+In particular, it's overkill for runST, which is perfectly respectable.+Consider+        f x = runST (return x)+This should be strict in x.++So the new plan is to define unsafePerformIO using the 'lazy' combinator:++        unsafePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)++Remember, 'lazy' is a wired-in identity-function Id, of type a->a, which is+magically NON-STRICT, and is inlined after strictness analysis.  So+unsafePerformIO will look non-strict, and that's what we want.++Now we don't need the hack in the strictness analyser.  HOWEVER, this+decision does mean that even a NOINLINE function is not entirely+opaque: some aspect of its implementation leaks out, notably its+strictness.  For example, if you have a function implemented by an+error stub, but which has RULES, you may want it not to be eliminated+in favour of error!++Note [Lazy and unleasheable free variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We put the strict and once-used FVs in the DmdType of the Id, so+that at its call sites we unleash demands on its strict fvs.+An example is 'roll' in imaginary/wheel-sieve2+Something like this:+        roll x = letrec+                     go y = if ... then roll (x-1) else x+1+                 in+                 go ms+We want to see that roll is strict in x, which is because+go is called.   So we put the DmdEnv for x in go's DmdType.++Another example:++        f :: Int -> Int -> Int+        f x y = let t = x+1+            h z = if z==0 then t else+                  if z==1 then x+1 else+                  x + h (z-1)+        in h y++Calling h does indeed evaluate x, but we can only see+that if we unleash a demand on x at the call site for t.++Incidentally, here's a place where lambda-lifting h would+lose the cigar --- we couldn't see the joint strictness in t/x++        ON THE OTHER HAND++We don't want to put *all* the fv's from the RHS into the+DmdType. Because++ * it makes the strictness signatures larger, and hence slows down fixpointing++and++ * it is useless information at the call site anyways:+   For lazy, used-many times fv's we will never get any better result than+   that, no matter how good the actual demand on the function at the call site+   is (unless it is always absent, but then the whole binder is useless).++Therefore we exclude lazy multiple-used fv's from the environment in the+DmdType.++But now the signature lies! (Missing variables are assumed to be absent.) To+make up for this, the code that analyses the binding keeps the demand on those+variable separate (usually called "lazy_fv") and adds it to the demand of the+whole binding later.++What if we decide _not_ to store a strictness signature for a binding at all, as+we do when aborting a fixed-point iteration? The we risk losing the information+that the strict variables are being used. In that case, we take all free variables+mentioned in the (unsound) strictness signature, conservatively approximate the+demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix".+++Note [Lambda-bound unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We allow a lambda-bound variable to carry an unfolding, a facility that is used+exclusively for join points; see Note [Case binders and join points].  If so,+we must be careful to demand-analyse the RHS of the unfolding!  Example+   \x. \y{=Just x}. <body>+Then if <body> uses 'y', then transitively it uses 'x', and we must not+forget that fact, otherwise we might make 'x' absent when it isn't.+++************************************************************************+*                                                                      *+\subsection{Strictness signatures}+*                                                                      *+************************************************************************+-}++type DFunFlag = Bool  -- indicates if the lambda being considered is in the+                      -- sequence of lambdas at the top of the RHS of a dfun+notArgOfDfun :: DFunFlag+notArgOfDfun = False++data AnalEnv+  = AE { ae_dflags :: DynFlags+       , ae_sigs   :: SigEnv+       , ae_virgin :: Bool    -- True on first iteration only+                              -- See Note [Initialising strictness]+       , ae_rec_tc :: RecTcChecker+       , ae_fam_envs :: FamInstEnvs+ }++        -- We use the se_env to tell us whether to+        -- record info about a variable in the DmdEnv+        -- We do so if it's a LocalId, but not top-level+        --+        -- The DmdEnv gives the demand on the free vars of the function+        -- when it is given enough args to satisfy the strictness signature++type SigEnv = VarEnv (StrictSig, TopLevelFlag)++instance Outputable AnalEnv where+  ppr (AE { ae_sigs = env, ae_virgin = virgin })+    = text "AE" <+> braces (vcat+         [ text "ae_virgin =" <+> ppr virgin+         , text "ae_sigs =" <+> ppr env ])++emptyAnalEnv :: DynFlags -> FamInstEnvs -> AnalEnv+emptyAnalEnv dflags fam_envs+    = AE { ae_dflags = dflags+         , ae_sigs = emptySigEnv+         , ae_virgin = True+         , ae_rec_tc = initRecTc+         , ae_fam_envs = fam_envs+         }++emptySigEnv :: SigEnv+emptySigEnv = emptyVarEnv++-- | Extend an environment with the strictness IDs attached to the id+extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv+extendAnalEnvs top_lvl env vars+  = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars }++extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv+extendSigEnvs top_lvl sigs vars+  = extendVarEnvList sigs [ (var, (idStrictness var, top_lvl)) | var <- vars]++extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv+extendAnalEnv top_lvl env var sig+  = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig }++extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv+extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl)++lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag)+lookupSigEnv env id = lookupVarEnv (ae_sigs env) id++getStrictness :: AnalEnv -> Id -> StrictSig+getStrictness env fn+  | isGlobalId fn                        = idStrictness fn+  | Just (sig, _) <- lookupSigEnv env fn = sig+  | otherwise                            = nopSig++nonVirgin :: AnalEnv -> AnalEnv+nonVirgin env = env { ae_virgin = False }++extendSigsWithLam :: AnalEnv -> Id -> AnalEnv+-- Extend the AnalEnv when we meet a lambda binder+extendSigsWithLam env id+  | isId id+  , isStrictDmd (idDemandInfo id) || ae_virgin env+       -- See Note [Optimistic CPR in the "virgin" case]+       -- See Note [Initial CPR for strict binders]+  , Just (dc,_,_,_) <- deepSplitProductType_maybe (ae_fam_envs env) $ idType id+  = extendAnalEnv NotTopLevel env id (cprProdSig (dataConRepArity dc))++  | otherwise+  = env++extendEnvForProdAlt :: AnalEnv -> CoreExpr -> Id -> DataCon -> [Var] -> AnalEnv+-- See Note [CPR in a product case alternative]+extendEnvForProdAlt env scrut case_bndr dc bndrs+  = foldl do_con_arg env1 ids_w_strs+  where+    env1 = extendAnalEnv NotTopLevel env case_bndr case_bndr_sig++    ids_w_strs    = filter isId bndrs `zip` dataConRepStrictness dc+    case_bndr_sig = cprProdSig (dataConRepArity dc)+    fam_envs      = ae_fam_envs env++    do_con_arg env (id, str)+       | let is_strict = isStrictDmd (idDemandInfo id) || isMarkedStrict str+       , ae_virgin env || (is_var_scrut && is_strict)  -- See Note [CPR in a product case alternative]+       , Just (dc,_,_,_) <- deepSplitProductType_maybe fam_envs $ idType id+       = extendAnalEnv NotTopLevel env id (cprProdSig (dataConRepArity dc))+       | otherwise+       = env++    is_var_scrut = is_var scrut+    is_var (Cast e _) = is_var e+    is_var (Var v)    = isLocalId v+    is_var _          = False++addDataConStrictness :: DataCon -> [Demand] -> [Demand]+-- See Note [Add demands for strict constructors]+addDataConStrictness con ds+  = ASSERT2( equalLength strs ds, ppr con $$ ppr strs $$ ppr ds )+    zipWith add ds strs+  where+    strs = dataConRepStrictness con+    add dmd str | isMarkedStrict str+                , not (isAbsDmd dmd) = dmd `bothDmd` seqDmd+                | otherwise          = dmd++findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Demand])+-- Return the demands on the Ids in the [Var]+findBndrsDmds env dmd_ty bndrs+  = go dmd_ty bndrs+  where+    go dmd_ty []  = (dmd_ty, [])+    go dmd_ty (b:bs)+      | isId b    = let (dmd_ty1, dmds) = go dmd_ty bs+                        (dmd_ty2, dmd)  = findBndrDmd env False dmd_ty1 b+                    in (dmd_ty2, dmd : dmds)+      | otherwise = go dmd_ty bs++findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand)+-- See Note [Trimming a demand to a type] in Demand.hs+findBndrDmd env arg_of_dfun dmd_ty id+  = (dmd_ty', dmd')+  where+    dmd' = killUsageDemand (ae_dflags env) $+           strictify $+           trimToType starting_dmd (findTypeShape fam_envs id_ty)++    (dmd_ty', starting_dmd) = peelFV dmd_ty id++    id_ty = idType id++    strictify dmd+      | gopt Opt_DictsStrict (ae_dflags env)+             -- We never want to strictify a recursive let. At the moment+             -- annotateBndr is only call for non-recursive lets; if that+             -- changes, we need a RecFlag parameter and another guard here.+      , not arg_of_dfun -- See Note [Do not strictify the argument dictionaries of a dfun]+      = strictifyDictDmd id_ty dmd+      | otherwise+      = dmd++    fam_envs = ae_fam_envs env++set_idStrictness :: AnalEnv -> Id -> StrictSig -> Id+set_idStrictness env id sig+  = setIdStrictness id (killUsageSig (ae_dflags env) sig)++dumpStrSig :: CoreProgram -> SDoc+dumpStrSig binds = vcat (map printId ids)+  where+  ids = sortBy (stableNameCmp `on` getName) (concatMap getIds binds)+  getIds (NonRec i _) = [ i ]+  getIds (Rec bs)     = map fst bs+  printId id | isExportedId id = ppr id <> colon <+> pprIfaceStrictSig (idStrictness id)+             | otherwise       = empty++{- Note [CPR in a product case alternative]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a case alternative for a product type, we want to give some of the+binders the CPR property.  Specifically++ * The case binder; inside the alternative, the case binder always has+   the CPR property, meaning that a case on it will successfully cancel.+   Example:+        f True  x = case x of y { I# x' -> if x' ==# 3+                                           then y+                                           else I# 8 }+        f False x = I# 3++   By giving 'y' the CPR property, we ensure that 'f' does too, so we get+        f b x = case fw b x of { r -> I# r }+        fw True  x = case x of y { I# x' -> if x' ==# 3 then x' else 8 }+        fw False x = 3++   Of course there is the usual risk of re-boxing: we have 'x' available+   boxed and unboxed, but we return the unboxed version for the wrapper to+   box.  If the wrapper doesn't cancel with its caller, we'll end up+   re-boxing something that we did have available in boxed form.++ * Any strict binders with product type, can use+   Note [Initial CPR for strict binders].  But we can go a little+   further. Consider++      data T = MkT !Int Int++      f2 (MkT x y) | y>0       = f2 (MkT x (y-1))+                   | otherwise = x++   For $wf2 we are going to unbox the MkT *and*, since it is strict, the+   first argument of the MkT; see Note [Add demands for strict constructors].+   But then we don't want box it up again when returning it!  We want+   'f2' to have the CPR property, so we give 'x' the CPR property.++ * It's a bit delicate because if this case is scrutinising something other+   than an argument the original function, we really don't have the unboxed+   version available.  E.g+      g v = case foo v of+              MkT x y | y>0       -> ...+                      | otherwise -> x+   Here we don't have the unboxed 'x' available.  Hence the+   is_var_scrut test when making use of the strictness annotation.+   Slightly ad-hoc, because even if the scrutinee *is* a variable it+   might not be a onre of the arguments to the original function, or a+   sub-component thereof.  But it's simple, and nothing terrible+   happens if we get it wrong.  e.g. Trac #10694.++Note [Add demands for strict constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this program (due to Roman):++    data X a = X !a++    foo :: X Int -> Int -> Int+    foo (X a) n = go 0+     where+       go i | i < n     = a + go (i+1)+            | otherwise = 0++We want the worker for 'foo' too look like this:++    $wfoo :: Int# -> Int# -> Int#++with the first argument unboxed, so that it is not eval'd each time+around the 'go' loop (which would otherwise happen, since 'foo' is not+strict in 'a').  It is sound for the wrapper to pass an unboxed arg+because X is strict, so its argument must be evaluated.  And if we+*don't* pass an unboxed argument, we can't even repair it by adding a+`seq` thus:++    foo (X a) n = a `seq` go 0++because the seq is discarded (very early) since X is strict!++We achieve the effect using addDataConStrictness.  It is called at a+case expression, such as the pattern match on (X a) in the example+above.  After computing how 'a' is used in the alternatives, we add an+extra 'seqDmd' to it.  The case alternative isn't itself strict in the+sub-components, but simply evaluating the scrutinee to HNF does force+those sub-components.++If the argument is not used at all in the alternative (i.e. it is+Absent), then *don't* add a 'seqDmd'.  If we do, it makes it look used+and hence it'll be passed to the worker when it doesn't need to be.+Hence the isAbsDmd test in addDataConStrictness.++There is the usual danger of reboxing, which as usual we ignore. But+if X is monomorphic, and has an UNPACK pragma, then this optimisation+is even more important.  We don't want the wrapper to rebox an unboxed+argument, and pass an Int to $wfoo!+++Note [Initial CPR for strict binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+CPR is initialized for a lambda binder in an optimistic manner, i.e,+if the binder is used strictly and at least some of its components as+a product are used, which is checked by the value of the absence+demand.++If the binder is marked demanded with a strict demand, then give it a+CPR signature. Here's a concrete example ('f1' in test T10482a),+assuming h is strict:++  f1 :: Int -> Int+  f1 x = case h x of+          A -> x+          B -> f1 (x-1)+          C -> x+1++If we notice that 'x' is used strictly, we can give it the CPR+property; and hence f1 gets the CPR property too.  It's sound (doesn't+change strictness) to give it the CPR property because by the time 'x'+is returned (case A above), it'll have been evaluated (by the wrapper+of 'h' in the example).++Moreover, if f itself is strict in x, then we'll pass x unboxed to+f1, and so the boxed version *won't* be available; in that case it's+very helpful to give 'x' the CPR property.++Note that++  * We only want to do this for something that definitely+    has product type, else we may get over-optimistic CPR results+    (e.g. from \x -> x!).++  * See Note [CPR examples]++Note [CPR examples]+~~~~~~~~~~~~~~~~~~~~+Here are some examples (stranal/should_compile/T10482a) of the+usefulness of Note [CPR in a product case alternative].  The main+point: all of these functions can have the CPR property.++    ------- f1 -----------+    -- x is used strictly by h, so it'll be available+    -- unboxed before it is returned in the True branch++    f1 :: Int -> Int+    f1 x = case h x x of+            True  -> x+            False -> f1 (x-1)+++    ------- f2 -----------+    -- x is a strict field of MkT2, so we'll pass it unboxed+    -- to $wf2, so it's available unboxed.  This depends on+    -- the case expression analysing (a subcomponent of) one+    -- of the original arguments to the function, so it's+    -- a bit more delicate.++    data T2 = MkT2 !Int Int++    f2 :: T2 -> Int+    f2 (MkT2 x y) | y>0       = f2 (MkT2 x (y-1))+                  | otherwise = x+++    ------- f3 -----------+    -- h is strict in x, so x will be unboxed before it+    -- is rerturned in the otherwise case.++    data T3 = MkT3 Int Int++    f1 :: T3 -> Int+    f1 (MkT3 x y) | h x y     = f3 (MkT3 x (y-1))+                  | otherwise = x+++    ------- f4 -----------+    -- Just like f2, but MkT4 can't unbox its strict+    -- argument automatically, as f2 can++    data family Foo a+    newtype instance Foo Int = Foo Int++    data T4 a = MkT4 !(Foo a) Int++    f4 :: T4 Int -> Int+    f4 (MkT4 x@(Foo v) y) | y>0       = f4 (MkT4 x (y-1))+                          | otherwise = v+++Note [Initialising strictness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See section 9.2 (Finding fixpoints) of the paper.++Our basic plan is to initialise the strictness of each Id in a+recursive group to "bottom", and find a fixpoint from there.  However,+this group B might be inside an *enclosing* recursive group A, in+which case we'll do the entire fixpoint shebang on for each iteration+of A. This can be illustrated by the following example:++Example:++  f [] = []+  f (x:xs) = let g []     = f xs+                 g (y:ys) = y+1 : g ys+              in g (h x)++At each iteration of the fixpoint for f, the analyser has to find a+fixpoint for the enclosed function g. In the meantime, the demand+values for g at each iteration for f are *greater* than those we+encountered in the previous iteration for f. Therefore, we can begin+the fixpoint for g not with the bottom value but rather with the+result of the previous analysis. I.e., when beginning the fixpoint+process for g, we can start from the demand signature computed for g+previously and attached to the binding occurrence of g.++To speed things up, we initialise each iteration of A (the enclosing+one) from the result of the last one, which is neatly recorded in each+binder.  That way we make use of earlier iterations of the fixpoint+algorithm. (Cunning plan.)++But on the *first* iteration we want to *ignore* the current strictness+of the Id, and start from "bottom".  Nowadays the Id can have a current+strictness, because interface files record strictness for nested bindings.+To know when we are in the first iteration, we look at the ae_virgin+field of the AnalEnv.+++Note [Final Demand Analyser run]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Some of the information that the demand analyser determines is not always+preserved by the simplifier.  For example, the simplifier will happily rewrite+  \y [Demand=1*U] let x = y in x + x+to+  \y [Demand=1*U] y + y+which is quite a lie.++The once-used information is (currently) only used by the code+generator, though.  So:++ * We zap the used-once info in the worker-wrapper;+   see Note [Zapping Used Once info in WorkWrap] in WorkWrap. If it's+   not reliable, it's better not to have it at all.++ * Just before TidyCore, we add a pass of the demand analyser,+      but WITHOUT subsequent worker/wrapper and simplifier,+   right before TidyCore.  See SimplCore.getCoreToDo.++   This way, correct information finds its way into the module interface+   (strictness signatures!) and the code generator (single-entry thunks!)++Note that, in contrast, the single-call information (C1(..)) /can/ be+relied upon, as the simplifier tends to be very careful about not+duplicating actual function calls.++Also see #11731.+-}
+ stranal/WorkWrap.hs view
@@ -0,0 +1,661 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998++\section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser}+-}++{-# LANGUAGE CPP #-}+module WorkWrap ( wwTopBinds ) where++import CoreSyn+import CoreUnfold       ( certainlyWillInline, mkWwInlineRule, mkWorkerUnfolding )+import CoreUtils        ( exprType, exprIsHNF )+import CoreFVs          ( exprFreeVars )+import Var+import Id+import IdInfo+import Type+import UniqSupply+import BasicTypes+import DynFlags+import Demand+import WwLib+import Util+import Outputable+import FamInstEnv+import MonadUtils++#include "HsVersions.h"++{-+We take Core bindings whose binders have:++\begin{enumerate}++\item Strictness attached (by the front-end of the strictness+analyser), and / or++\item Constructed Product Result information attached by the CPR+analysis pass.++\end{enumerate}++and we return some ``plain'' bindings which have been+worker/wrapper-ified, meaning:++\begin{enumerate}++\item Functions have been split into workers and wrappers where+appropriate.  If a function has both strictness and CPR properties+then only one worker/wrapper doing both transformations is produced;++\item Binders' @IdInfos@ have been updated to reflect the existence of+these workers/wrappers (this is where we get STRICTNESS and CPR pragma+info for exported values).+\end{enumerate}+-}++wwTopBinds :: DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram++wwTopBinds dflags fam_envs us top_binds+  = initUs_ us $ do+    top_binds' <- mapM (wwBind dflags fam_envs) top_binds+    return (concat top_binds')++{-+************************************************************************+*                                                                      *+\subsection[wwBind-wwExpr]{@wwBind@ and @wwExpr@}+*                                                                      *+************************************************************************++@wwBind@ works on a binding, trying each \tr{(binder, expr)} pair in+turn.  Non-recursive case first, then recursive...+-}++wwBind  :: DynFlags+        -> FamInstEnvs+        -> CoreBind+        -> UniqSM [CoreBind]    -- returns a WwBinding intermediate form;+                                -- the caller will convert to Expr/Binding,+                                -- as appropriate.++wwBind dflags fam_envs (NonRec binder rhs) = do+    new_rhs <- wwExpr dflags fam_envs rhs+    new_pairs <- tryWW dflags fam_envs NonRecursive binder new_rhs+    return [NonRec b e | (b,e) <- new_pairs]+      -- Generated bindings must be non-recursive+      -- because the original binding was.++wwBind dflags fam_envs (Rec pairs)+  = return . Rec <$> concatMapM do_one pairs+  where+    do_one (binder, rhs) = do new_rhs <- wwExpr dflags fam_envs rhs+                              tryWW dflags fam_envs Recursive binder new_rhs++{-+@wwExpr@ basically just walks the tree, looking for appropriate+annotations that can be used. Remember it is @wwBind@ that does the+matching by looking for strict arguments of the correct type.+@wwExpr@ is a version that just returns the ``Plain'' Tree.+-}++wwExpr :: DynFlags -> FamInstEnvs -> CoreExpr -> UniqSM CoreExpr++wwExpr _      _ e@(Type {}) = return e+wwExpr _      _ e@(Coercion {}) = return e+wwExpr _      _ e@(Lit  {}) = return e+wwExpr _      _ e@(Var  {}) = return e++wwExpr dflags fam_envs (Lam binder expr)+  = Lam new_binder <$> wwExpr dflags fam_envs expr+  where new_binder | isId binder = zapIdUsedOnceInfo binder+                   | otherwise   = binder+  -- See Note [Zapping Used Once info in WorkWrap]++wwExpr dflags fam_envs (App f a)+  = App <$> wwExpr dflags fam_envs f <*> wwExpr dflags fam_envs a++wwExpr dflags fam_envs (Tick note expr)+  = Tick note <$> wwExpr dflags fam_envs expr++wwExpr dflags fam_envs (Cast expr co) = do+    new_expr <- wwExpr dflags fam_envs expr+    return (Cast new_expr co)++wwExpr dflags fam_envs (Let bind expr)+  = mkLets <$> wwBind dflags fam_envs bind <*> wwExpr dflags fam_envs expr++wwExpr dflags fam_envs (Case expr binder ty alts) = do+    new_expr <- wwExpr dflags fam_envs expr+    new_alts <- mapM ww_alt alts+    let new_binder = zapIdUsedOnceInfo binder+      -- See Note [Zapping Used Once info in WorkWrap]+    return (Case new_expr new_binder ty new_alts)+  where+    ww_alt (con, binders, rhs) = do+        new_rhs <- wwExpr dflags fam_envs rhs+        let new_binders = [ if isId b then zapIdUsedOnceInfo b else b+                          | b <- binders ]+           -- See Note [Zapping Used Once info in WorkWrap]+        return (con, new_binders, new_rhs)++{-+************************************************************************+*                                                                      *+\subsection[tryWW]{@tryWW@: attempt a worker/wrapper pair}+*                                                                      *+************************************************************************++@tryWW@ just accumulates arguments, converts strictness info from the+front-end into the proper form, then calls @mkWwBodies@ to do+the business.++The only reason this is monadised is for the unique supply.++Note [Don't w/w INLINE things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's very important to refrain from w/w-ing an INLINE function (ie one+with a stable unfolding) because the wrapper will then overwrite the+old stable unfolding with the wrapper code.++Furthermore, if the programmer has marked something as INLINE,+we may lose by w/w'ing it.++If the strictness analyser is run twice, this test also prevents+wrappers (which are INLINEd) from being re-done.  (You can end up with+several liked-named Ids bouncing around at the same time---absolute+mischief.)++Notice that we refrain from w/w'ing an INLINE function even if it is+in a recursive group.  It might not be the loop breaker.  (We could+test for loop-breaker-hood, but I'm not sure that ever matters.)++Note [Worker-wrapper for INLINABLE functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have+  {-# INLINABLE f #-}+  f :: Ord a => [a] -> Int -> a+  f x y = ....f....++where f is strict in y, we might get a more efficient loop by w/w'ing+f.  But that would make a new unfolding which would overwrite the old+one! So the function would no longer be ININABLE, and in particular+will not be specialised at call sites in other modules.++This comes in practice (Trac #6056).++Solution: do the w/w for strictness analysis, but transfer the Stable+unfolding to the *worker*.  So we will get something like this:++  {-# INLINE[0] f #-}+  f :: Ord a => [a] -> Int -> a+  f d x y = case y of I# y' -> fw d x y'++  {-# INLINABLE[0] fw #-}+  fw :: Ord a => [a] -> Int# -> a+  fw d x y' = let y = I# y' in ...f...++How do we "transfer the unfolding"? Easy: by using the old one, wrapped+in work_fn! See CoreUnfold.mkWorkerUnfolding.++Note [Worker-wrapper for NOINLINE functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to disable worker/wrapper for NOINLINE things, but it turns out+this can cause unnecessary reboxing of values. Consider++  {-# NOINLINE f #-}+  f :: Int -> a+  f x = error (show x)++  g :: Bool -> Bool -> Int -> Int+  g True  True  p = f p+  g False True  p = p + 1+  g b     False p = g b True p++the strictness analysis will discover f and g are strict, but because f+has no wrapper, the worker for g will rebox p. So we get++  $wg x y p# =+    let p = I# p# in  -- Yikes! Reboxing!+    case x of+      False ->+        case y of+          False -> $wg False True p#+          True -> +# p# 1#+      True ->+        case y of+          False -> $wg True True p#+          True -> case f p of { }++  g x y p = case p of (I# p#) -> $wg x y p#++Now, in this case the reboxing will float into the True branch, an so+the allocation will only happen on the error path. But it won't float+inwards if there are multiple branches that call (f p), so the reboxing+will happen on every call of g. Disaster.++Solution: do worker/wrapper even on NOINLINE things; but move the+NOINLINE pragma to the worker.++(See Trac #13143 for a real-world example.)++Note [Activation for workers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Follows on from Note [Worker-wrapper for INLINABLE functions]++It is *vital* that if the worker gets an INLINABLE pragma (from the+original function), then the worker has the same phase activation as+the wrapper (or later).  That is necessary to allow the wrapper to+inline into the worker's unfolding: see SimplUtils+Note [Simplifying inside stable unfoldings].++If the original is NOINLINE, it's important that the work inherit the+original activation. Consider++  {-# NOINLINE expensive #-}+  expensive x = x + 1++  f y = let z = expensive y in ...++If expensive's worker inherits the wrapper's activation, we'll get++  {-# NOINLINE[0] $wexpensive #-}+  $wexpensive x = x + 1+  {-# INLINE[0] expensive #-}+  expensive x = $wexpensive x++  f y = let z = expensive y in ...++and $wexpensive will be immediately inlined into expensive, followed by+expensive into f. This effectively removes the original NOINLINE!++Otherwise, nothing is lost by giving the worker the same activation as the+wrapper, because the worker won't have any chance of inlining until the+wrapper does; there's no point in giving it an earlier activation.++Note [Don't w/w inline small non-loop-breaker things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general, we refrain from w/w-ing *small* functions, which are not+loop breakers, because they'll inline anyway.  But we must take care:+it may look small now, but get to be big later after other inlining+has happened.  So we take the precaution of adding an INLINE pragma to+any such functions.++I made this change when I observed a big function at the end of+compilation with a useful strictness signature but no w-w.  (It was+small during demand analysis, we refrained from w/w, and then got big+when something was inlined in its rhs.) When I measured it on nofib,+it didn't make much difference; just a few percent improved allocation+on one benchmark (bspt/Euclid.space).  But nothing got worse.++There is an infelicity though.  We may get something like+      f = g val+==>+      g x = case gw x of r -> I# r++      f {- InlineStable, Template = g val -}+      f = case gw x of r -> I# r++The code for f duplicates that for g, without any real benefit. It+won't really be executed, because calls to f will go via the inlining.++Note [Don't CPR join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~++There's no point in doing CPR on a join point. If the whole function is getting+CPR'd, then the case expression around the worker function will get pushed into+the join point by the simplifier, which will have the same effect that CPR would+have - the result will be returned in an unboxed tuple.++  f z = let join j x y = (x+1, y+1)+        in case z of A -> j 1 2+                     B -> j 2 3++  =>++  f z = case $wf z of (# a, b #) -> (a, b)+  $wf z = case (let join j x y = (x+1, y+1)+                in case z of A -> j 1 2+                             B -> j 2 3) of (a, b) -> (# a, b #)++  =>++  f z = case $wf z of (# a, b #) -> (a, b)+  $wf z = let join j x y = (# x+1, y+1 #)+          in case z of A -> j 1 2+                       B -> j 2 3++Doing CPR on a join point would be tricky anyway, as the worker could not be+a join point because it would not be tail-called. However, doing the *argument*+part of W/W still works for join points, since the wrapper body will make a tail+call:++  f z = let join j x y = x + y+        in ...++  =>++  f z = let join $wj x# y# = x# +# y#+                 j x y = case x of I# x# ->+                         case y of I# y# ->+                         $wj x# y#+        in ...++Note [Wrapper activation]+~~~~~~~~~~~~~~~~~~~~~~~~~+When should the wrapper inlining be active?  It must not be active+earlier than the current Activation of the Id (eg it might have a+NOINLINE pragma).  But in fact strictness analysis happens fairly+late in the pipeline, and we want to prioritise specialisations over+strictness.  Eg if we have+  module Foo where+    f :: Num a => a -> Int -> a+    f n 0 = n              -- Strict in the Int, hence wrapper+    f n x = f (n+n) (x-1)++    g :: Int -> Int+    g x = f x x            -- Provokes a specialisation for f++  module Bar where+    import Foo++    h :: Int -> Int+    h x = f 3 x++Then we want the specialisation for 'f' to kick in before the wrapper does.++Now in fact the 'gentle' simplification pass encourages this, by+having rules on, but inlinings off.  But that's kind of lucky. It seems+more robust to give the wrapper an Activation of (ActiveAfter 0),+so that it becomes active in an importing module at the same time that+it appears in the first place in the defining module.++At one stage I tried making the wrapper inlining always-active, and+that had a very bad effect on nofib/imaginary/x2n1; a wrapper was+inlined before the specialisation fired.+-}++tryWW   :: DynFlags+        -> FamInstEnvs+        -> RecFlag+        -> Id                           -- The fn binder+        -> CoreExpr                     -- The bound rhs; its innards+                                        --   are already ww'd+        -> UniqSM [(Id, CoreExpr)]      -- either *one* or *two* pairs;+                                        -- if one, then no worker (only+                                        -- the orig "wrapper" lives on);+                                        -- if two, then a worker and a+                                        -- wrapper.+tryWW dflags fam_envs is_rec fn_id rhs+  -- See Note [Worker-wrapper for NOINLINE functions]++  | Just stable_unf <- certainlyWillInline dflags fn_info+  = return [ (fn_id `setIdUnfolding` stable_unf, rhs) ]+        -- See Note [Don't w/w INLINE things]+        -- See Note [Don't w/w inline small non-loop-breaker things]++  | is_fun+  = splitFun dflags fam_envs new_fn_id fn_info wrap_dmds res_info rhs++  | is_thunk                                   -- See Note [Thunk splitting]+  = splitThunk dflags fam_envs is_rec new_fn_id rhs++  | otherwise+  = return [ (new_fn_id, rhs) ]++  where+    fn_info      = idInfo fn_id+    (wrap_dmds, res_info) = splitStrictSig (strictnessInfo fn_info)++    new_fn_id = zapIdUsedOnceInfo (zapIdUsageEnvInfo fn_id)+        -- See Note [Zapping DmdEnv after Demand Analyzer] and+        -- See Note [Zapping Used Once info in WorkWrap]++    is_fun    = notNull wrap_dmds || isJoinId fn_id+    is_thunk  = not is_fun && not (exprIsHNF rhs) && not (isJoinId fn_id)+                           && not (isUnliftedType (idType fn_id))++{-+Note [Zapping DmdEnv after Demand Analyzer]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the worker-wrapper pass we zap the DmdEnv.  Why?+ (a) it is never used again+ (b) it wastes space+ (c) it becomes incorrect as things are cloned, because+     we don't push the substitution into it++Why here?+ * Because we don’t want to do it in the Demand Analyzer, as we never know+   there when we are doing the last pass.+ * We want them to be still there at the end of DmdAnal, so that+   -ddump-str-anal contains them.+ * We don’t want a second pass just for that.+ * WorkWrap looks at all bindings anyway.++We also need to do it in TidyCore.tidyLetBndr to clean up after the+final, worker/wrapper-less run of the demand analyser (see+Note [Final Demand Analyser run] in DmdAnal).++Note [Zapping Used Once info in WorkWrap]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the worker-wrapper pass we zap the used once info in demands and in+strictness signatures.++Why?+ * The simplifier may happen to transform code in a way that invalidates the+   data (see #11731 for an example).+ * It is not used in later passes, up to code generation.++So as the data is useless and possibly wrong, we want to remove it. The most+convenient place to do that is the worker wrapper phase, as it runs after every+run of the demand analyser besides the very last one (which is the one where we+want to _keep_ the info for the code generator).++We do not do it in the demand analyser for the same reasons outlined in+Note [Zapping DmdEnv after Demand Analyzer] above.+-}+++---------------------+splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> DmdResult -> CoreExpr+         -> UniqSM [(Id, CoreExpr)]+splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs+  = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) ) do+    -- The arity should match the signature+    stuff <- mkWwBodies dflags fam_envs rhs_fvs mb_join_arity fun_ty+                        wrap_dmds use_res_info+    case stuff of+      Just (work_demands, join_arity, wrap_fn, work_fn) -> do+        work_uniq <- getUniqueM+        let work_rhs = work_fn rhs+            work_inline = inl_inline inl_prag+            work_act = case work_inline of+              -- See Note [Activation for workers]+              NoInline -> inl_act inl_prag+              _        -> wrap_act+            work_prag = InlinePragma { inl_src = SourceText "{-# INLINE"+                                     , inl_inline = work_inline+                                     , inl_sat    = Nothing+                                     , inl_act    = work_act+                                     , inl_rule   = FunLike }+              -- idl_inline: copy from fn_id; see Note [Worker-wrapper for INLINABLE functions]+              -- idl_act: see Note [Activation for workers]+              -- inl_rule: it does not make sense for workers to be constructorlike.+            work_join_arity | isJoinId fn_id = Just join_arity+                            | otherwise      = Nothing+              -- worker is join point iff wrapper is join point+              -- (see Note [Don't CPR join points])+            work_id  = mkWorkerId work_uniq fn_id (exprType work_rhs)+                        `setIdOccInfo` occInfo fn_info+                                -- Copy over occurrence info from parent+                                -- Notably whether it's a loop breaker+                                -- Doesn't matter much, since we will simplify next, but+                                -- seems right-er to do so++                        `setInlinePragma` work_prag++                        `setIdUnfolding` mkWorkerUnfolding dflags work_fn (unfoldingInfo fn_info)+                                -- See Note [Worker-wrapper for INLINABLE functions]++                        `setIdStrictness` mkClosedStrictSig work_demands work_res_info+                                -- Even though we may not be at top level,+                                -- it's ok to give it an empty DmdEnv++                        `setIdDemandInfo` worker_demand++                        `setIdArity` work_arity+                                -- Set the arity so that the Core Lint check that the+                                -- arity is consistent with the demand type goes+                                -- through+                        `asJoinId_maybe` work_join_arity++            work_arity = length work_demands++            -- See Note [Demand on the Worker]+            single_call = saturatedByOneShots arity (demandInfo fn_info)+            worker_demand | single_call = mkWorkerDemand work_arity+                          | otherwise   = topDmd+++            wrap_act  = ActiveAfter NoSourceText 0+            wrap_rhs  = wrap_fn work_id+            wrap_prag = InlinePragma { inl_src = SourceText "{-# INLINE"+                                     , inl_inline = Inline+                                     , inl_sat    = Nothing+                                     , inl_act    = wrap_act+                                     , inl_rule   = rule_match_info }+                -- See Note [Wrapper activation]+                -- The RuleMatchInfo is (and must be) unaffected++            wrap_id   = fn_id `setIdUnfolding`  mkWwInlineRule wrap_rhs arity+                              `setInlinePragma` wrap_prag+                              `setIdOccInfo`    noOccInfo+                                -- Zap any loop-breaker-ness, to avoid bleating from Lint+                                -- about a loop breaker with an INLINE rule++++        return $ [(work_id, work_rhs), (wrap_id, wrap_rhs)]+            -- Worker first, because wrapper mentions it++      Nothing -> return [(fn_id, rhs)]+  where+    mb_join_arity   = isJoinId_maybe fn_id+    rhs_fvs         = exprFreeVars rhs+    fun_ty          = idType fn_id+    inl_prag        = inlinePragInfo fn_info+    rule_match_info = inlinePragmaRuleMatchInfo inl_prag+    arity           = arityInfo fn_info+                    -- The arity is set by the simplifier using exprEtaExpandArity+                    -- So it may be more than the number of top-level-visible lambdas++    use_res_info  | isJoinId fn_id = topRes -- Note [Don't CPR join points]+                  | otherwise      = res_info+    work_res_info | isJoinId fn_id = res_info -- Worker remains CPR-able+                  | otherwise+                  = case returnsCPR_maybe res_info of+                       Just _  -> topRes    -- Cpr stuff done by wrapper; kill it here+                       Nothing -> res_info  -- Preserve exception/divergence+++{-+Note [Demand on the worker]+~~~~~~~~~~~~~~~~~~~~~~~~~~~++If the original function is called once, according to its demand info, then+so is the worker. This is important so that the occurrence analyser can+attach OneShot annotations to the worker’s lambda binders.+++Example:++  -- Original function+  f [Demand=<L,1*C1(U)>] :: (a,a) -> a+  f = \p -> ...++  -- Wrapper+  f [Demand=<L,1*C1(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 = \a b -> ...++We need to check whether the original function is called once, with+sufficiently many arguments. This is done using saturatedByOneShots, which+takes the arity of the original function (resp. the wrapper) and the demand on+the original function.++The demand on the worker is then calculated using mkWorkerDemand, and always of+the form [Demand=<L,1*(C1(...(C1(U))))>]+++Note [Do not split void functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this rather common form of binding:+        $j = \x:Void# -> ...no use of x...++Since x is not used it'll be marked as absent.  But there is no point+in w/w-ing because we'll simply add (\y:Void#), see WwLib.mkWorerArgs.++If x has a more interesting type (eg Int, or Int#), there *is* a point+in w/w so that we don't pass the argument at all.++Note [Thunk splitting]+~~~~~~~~~~~~~~~~~~~~~~+Suppose x is used strictly (never mind whether it has the CPR+property).++      let+        x* = x-rhs+      in body++splitThunk transforms like this:++      let+        x* = case x-rhs of { I# a -> I# a }+      in body++Now simplifier will transform to++      case x-rhs of+        I# a -> let x* = I# a+                in body++which is what we want. Now suppose x-rhs is itself a case:++        x-rhs = case e of { T -> I# a; F -> I# b }++The join point will abstract over a, rather than over (which is+what would have happened before) which is fine.++Notice that x certainly has the CPR property now!++In fact, splitThunk uses the function argument w/w splitting+function, so that if x's demand is deeper (say U(U(L,L),L))+then the splitting will go deeper too.+-}++-- See Note [Thunk splitting]+-- splitThunk converts the *non-recursive* binding+--      x = e+-- into+--      x = let x = e+--          in case x of+--               I# y -> let x = I# y in x }+-- See comments above. Is it not beautifully short?+-- Moreover, it works just as well when there are+-- several binders, and if the binders are lifted+-- E.g.     x = e+--     -->  x = let x = e in+--              case x of (a,b) -> let x = (a,b)  in x++splitThunk :: DynFlags -> FamInstEnvs -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)]+splitThunk dflags fam_envs is_rec fn_id rhs+  = ASSERT(not (isJoinId fn_id))+    do { (useful,_, wrap_fn, work_fn) <- mkWWstr dflags fam_envs [fn_id]+       ; let res = [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ]+       ; if useful then ASSERT2( isNonRec is_rec, ppr fn_id ) -- The thunk must be non-recursive+                   return res+                   else return [(fn_id, rhs)] }
+ stranal/WwLib.hs view
@@ -0,0 +1,952 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998++\section[WwLib]{A library for the ``worker\/wrapper'' back-end to the strictness analyser}+-}++{-# LANGUAGE CPP #-}++module WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs+             , deepSplitProductType_maybe, findTypeShape+             , isWorkerSmallEnough+ ) where++#include "HsVersions.h"++import CoreSyn+import CoreUtils        ( exprType, mkCast )+import Id+import IdInfo           ( JoinArity, vanillaIdInfo )+import DataCon+import Demand+import MkCore           ( mkRuntimeErrorApp, aBSENT_ERROR_ID, mkCoreUbxTup+                        , mkCoreApp, mkCoreLet )+import MkId             ( voidArgId, voidPrimId )+import TysPrim          ( voidPrimTy )+import TysWiredIn       ( tupleDataCon )+import VarEnv           ( mkInScopeSet )+import VarSet           ( VarSet )+import Type+import RepType          ( isVoidTy )+import Coercion+import FamInstEnv+import BasicTypes       ( Boxity(..) )+import Literal          ( absentLiteralOf )+import TyCon+import UniqSupply+import Unique+import Maybes+import Util+import Outputable+import DynFlags+import FastString+import ListSetOps++{-+************************************************************************+*                                                                      *+\subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}+*                                                                      *+************************************************************************++Here's an example.  The original function is:++\begin{verbatim}+g :: forall a . Int -> [a] -> a++g = \/\ a -> \ x ys ->+        case x of+          0 -> head ys+          _ -> head (tail ys)+\end{verbatim}++From this, we want to produce:+\begin{verbatim}+-- wrapper (an unfolding)+g :: forall a . Int -> [a] -> a++g = \/\ a -> \ x ys ->+        case x of+          I# x# -> $wg a x# ys+            -- call the worker; don't forget the type args!++-- worker+$wg :: forall a . Int# -> [a] -> a++$wg = \/\ a -> \ x# ys ->+        let+            x = I# x#+        in+            case x of               -- note: body of g moved intact+              0 -> head ys+              _ -> head (tail ys)+\end{verbatim}++Something we have to be careful about:  Here's an example:++\begin{verbatim}+-- "f" strictness: U(P)U(P)+f (I# a) (I# b) = a +# b++g = f   -- "g" strictness same as "f"+\end{verbatim}++\tr{f} will get a worker all nice and friendly-like; that's good.+{\em But we don't want a worker for \tr{g}}, even though it has the+same strictness as \tr{f}.  Doing so could break laziness, at best.++Consequently, we insist that the number of strictness-info items is+exactly the same as the number of lambda-bound arguments.  (This is+probably slightly paranoid, but OK in practice.)  If it isn't the+same, we ``revise'' the strictness info, so that we won't propagate+the unusable strictness-info into the interfaces.+++************************************************************************+*                                                                      *+\subsection{The worker wrapper core}+*                                                                      *+************************************************************************++@mkWwBodies@ is called when doing the worker\/wrapper split inside a module.+-}++type WwResult+  = ([Demand],              -- Demands for worker (value) args+     JoinArity,             -- Number of worker (type OR value) args+     Id -> CoreExpr,        -- Wrapper body, lacking only the worker Id+     CoreExpr -> CoreExpr)  -- Worker body, lacking the original function rhs++mkWwBodies :: DynFlags+           -> FamInstEnvs+           -> VarSet         -- Free vars of RHS+                             -- See Note [Freshen WW arguments]+           -> Maybe JoinArity -- Just ar <=> is join point with join arity ar+           -> Type           -- Type of original function+           -> [Demand]       -- Strictness of original function+           -> DmdResult      -- Info about function result+           -> UniqSM (Maybe WwResult)++-- wrap_fn_args E       = \x y -> E+-- work_fn_args E       = E x y++-- wrap_fn_str E        = case x of { (a,b) ->+--                        case a of { (a1,a2) ->+--                        E a1 a2 b y }}+-- work_fn_str E        = \a2 a2 b y ->+--                        let a = (a1,a2) in+--                        let x = (a,b) in+--                        E++mkWwBodies dflags fam_envs rhs_fvs mb_join_arity fun_ty demands res_info+  = do  { let empty_subst = mkEmptyTCvSubst (mkInScopeSet rhs_fvs)+                -- See Note [Freshen WW arguments]++        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs empty_subst fun_ty demands+        ; (useful1, work_args, wrap_fn_str, work_fn_str) <- mkWWstr dflags fam_envs wrap_args++        -- Do CPR w/w.  See Note [Always do CPR w/w]+        ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty)+              <- mkWWcpr (gopt Opt_CprAnal dflags) fam_envs res_ty res_info++        ; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args cpr_res_ty+              worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v]+              wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var+              worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args++        ; if isWorkerSmallEnough dflags work_args+             && not (too_many_args_for_join_point wrap_args)+             && (useful1 && not only_one_void_argument || useful2)+          then return (Just (worker_args_dmds, length work_call_args,+                       wrapper_body, worker_body))+          else return Nothing+        }+        -- We use an INLINE unconditionally, even if the wrapper turns out to be+        -- something trivial like+        --      fw = ...+        --      f = __inline__ (coerce T fw)+        -- The point is to propagate the coerce to f's call sites, so even though+        -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent+        -- fw from being inlined into f's RHS+  where+    -- Note [Do not split void functions]+    only_one_void_argument+      | [d] <- demands+      , Just (arg_ty1, _) <- splitFunTy_maybe fun_ty+      , isAbsDmd d && isVoidTy arg_ty1+      = True+      | otherwise+      = False++    -- Note [Join points returning functions]+    too_many_args_for_join_point wrap_args+      | Just join_arity <- mb_join_arity+      , wrap_args `lengthExceeds` join_arity+      = WARN(True, text "Unable to worker/wrapper join point with arity " <+>+                     int join_arity <+> text "but" <+>+                     int (length wrap_args) <+> text "args")+        True+      | otherwise+      = False++-- See Note [Limit w/w arity]+isWorkerSmallEnough :: DynFlags -> [Var] -> Bool+isWorkerSmallEnough dflags vars = count isId vars <= maxWorkerArgs dflags+    -- We count only Free variables (isId) to skip Type, Kind+    -- variables which have no runtime representation.++{-+Note [Always do CPR w/w]+~~~~~~~~~~~~~~~~~~~~~~~~+At one time we refrained from doing CPR w/w for thunks, on the grounds that+we might duplicate work.  But that is already handled by the demand analyser,+which doesn't give the CPR proprety if w/w might waste work: see+Note [CPR for thunks] in DmdAnal.++And if something *has* been given the CPR property and we don't w/w, it's+a disaster, because then the enclosing function might say it has the CPR+property, but now doesn't and there a cascade of disaster.  A good example+is Trac #5920.++Note [Limit w/w arity]+~~~~~~~~~~~~~~~~~~~~~~~~+Guard against high worker arity as it generates a lot of stack traffic.+A simplified example is Trac #11565#comment:6++Current strategy is very simple: don't perform w/w transformation at all+if the result produces a wrapper with arity higher than -fmax-worker-args=.++It is a bit all or nothing, consider++        f (x,y) (a,b,c,d,e ... , z) = rhs++Currently we will remove all w/w ness entirely. But actually we could+w/w on the (x,y) pair... it's the huge product that is the problem.++Could we instead refrain from w/w on an arg-by-arg basis? Yes, that'd+solve f. But we can get a lot of args from deeply-nested products:++        g (a, (b, (c, (d, ...)))) = rhs++This is harder to spot on an arg-by-arg basis. Previously mkWwStr was+given some "fuel" saying how many arguments it could add; when we ran+out of fuel it would stop w/wing.+Still not very clever because it had a left-right bias.++************************************************************************+*                                                                      *+\subsection{Making wrapper args}+*                                                                      *+************************************************************************++During worker-wrapper stuff we may end up with an unlifted thing+which we want to let-bind without losing laziness.  So we+add a void argument.  E.g.++        f = /\a -> \x y z -> E::Int#    -- E does not mention x,y,z+==>+        fw = /\ a -> \void -> E+        f  = /\ a -> \x y z -> fw realworld++We use the state-token type which generates no code.+-}++mkWorkerArgs :: DynFlags -> [Var]+             -> Type    -- Type of body+             -> ([Var], -- Lambda bound args+                 [Var]) -- Args at call site+mkWorkerArgs dflags args res_ty+    | any isId args || not needsAValueLambda+    = (args, args)+    | otherwise+    = (args ++ [voidArgId], args ++ [voidPrimId])+    where+      needsAValueLambda =+        isUnliftedType res_ty+        || not (gopt Opt_FunToThunk dflags)+           -- see Note [Protecting the last value argument]++{-+Note [Protecting the last value argument]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the user writes (\_ -> E), they might be intentionally disallowing+the sharing of E. Since absence analysis and worker-wrapper are keen+to remove such unused arguments, we add in a void argument to prevent+the function from becoming a thunk.++The user can avoid adding the void argument with the -ffun-to-thunk+flag. However, this can create sharing, which may be bad in two ways. 1) It can+create a space leak. 2) It can prevent inlining *under a lambda*. If w/w+removes the last argument from a function f, then f now looks like a thunk, and+so f can't be inlined *under a lambda*.++Note [Join points and beta-redexes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Originally, the worker would invoke the original function by calling it with+arguments, thus producing a beta-redex for the simplifier to munch away:++  \x y z -> e => (\x y z -> e) wx wy wz++Now that we have special rules about join points, however, this is Not Good if+the original function is itself a join point, as then it may contain invocations+of other join points:++  join j1 x = ...+  join j2 y = if y == 0 then 0 else j1 y++  =>++  join j1 x = ...+  join $wj2 y# = let wy = I# y# in (\y -> if y == 0 then 0 else jump j1 y) wy+  join j2 y = case y of I# y# -> jump $wj2 y#++There can't be an intervening lambda between a join point's declaration and its+occurrences, so $wj2 here is wrong. But of course, this is easy enough to fix:++  ...+  let join $wj2 y# = let wy = I# y# in let y = wy in if y == 0 then 0 else j1 y+  ...++Hence we simply do the beta-reduction here. (This would be harder if we had to+worry about hygiene, but luckily wy is freshly generated.)++Note [Join points returning functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++It is crucial that the arity of a join point depends on its *callers,* not its+own syntax. What this means is that a join point can have "extra lambdas":++f :: Int -> Int -> (Int, Int) -> Int+f x y = join j (z, w) = \(u, v) -> ...+        in jump j (x, y)++Typically this happens with functions that are seen as computing functions,+rather than being curried. (The real-life example was GraphOps.addConflicts.)++When we create the wrapper, it *must* be in "eta-contracted" form so that the+jump has the right number of arguments:++f x y = join $wj z' w' = \u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ...+             j (z, w)  = jump $wj z w++(See Note [Join points and beta-redexes] for where the lets come from.) If j+were a function, we would instead say++f x y = let $wj = \z' w' u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ...+            j (z, w) (u, v) = $wj z w u v++Notice that the worker ends up with the same lambdas; it's only the wrapper we+have to be concerned about.++FIXME Currently the functionality to produce "eta-contracted" wrappers is+unimplemented; we simply give up.++************************************************************************+*                                                                      *+\subsection{Coercion stuff}+*                                                                      *+************************************************************************++We really want to "look through" coerces.+Reason: I've seen this situation:++        let f = coerce T (\s -> E)+        in \x -> case x of+                    p -> coerce T' f+                    q -> \s -> E2+                    r -> coerce T' f++If only we w/w'd f, we'd get+        let f = coerce T (\s -> fw s)+            fw = \s -> E+        in ...++Now we'll inline f to get++        let fw = \s -> E+        in \x -> case x of+                    p -> fw+                    q -> \s -> E2+                    r -> fw++Now we'll see that fw has arity 1, and will arity expand+the \x to get what we want.+-}++-- mkWWargs just does eta expansion+-- is driven off the function type and arity.+-- It chomps bites off foralls, arrows, newtypes+-- and keeps repeating that until it's satisfied the supplied arity++mkWWargs :: TCvSubst            -- Freshening substitution to apply to the type+                                --   See Note [Freshen WW arguments]+         -> Type                -- The type of the function+         -> [Demand]     -- Demands and one-shot info for value arguments+         -> UniqSM  ([Var],            -- Wrapper args+                     CoreExpr -> CoreExpr,      -- Wrapper fn+                     CoreExpr -> CoreExpr,      -- Worker fn+                     Type)                      -- Type of wrapper body++mkWWargs subst fun_ty demands+  | null demands+  = return ([], id, id, substTy subst fun_ty)++  | (dmd:demands') <- demands+  , Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty+  = do  { uniq <- getUniqueM+        ; let arg_ty' = substTy subst arg_ty+              id = mk_wrap_arg uniq arg_ty' dmd+        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)+              <- mkWWargs subst fun_ty' demands'+        ; return (id : wrap_args,+                  Lam id . wrap_fn_args,+                  apply_or_bind_then work_fn_args (varToCoreExpr id),+                  res_ty) }++  | Just (tv, fun_ty') <- splitForAllTy_maybe fun_ty+  = do  { uniq <- getUniqueM+        ; let (subst', tv') = cloneTyVarBndr subst tv uniq+                -- See Note [Freshen WW arguments]+        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)+             <- mkWWargs subst' fun_ty' demands+        ; return (tv' : wrap_args,+                  Lam tv' . wrap_fn_args,+                  apply_or_bind_then work_fn_args (mkTyArg (mkTyVarTy tv')),+                  res_ty) }++  | Just (co, rep_ty) <- topNormaliseNewType_maybe fun_ty+        -- The newtype case is for when the function has+        -- a newtype after the arrow (rare)+        --+        -- It's also important when we have a function returning (say) a pair+        -- wrapped in a  newtype, at least if CPR analysis can look+        -- through such newtypes, which it probably can since they are+        -- simply coerces.++  = do { (wrap_args, wrap_fn_args, work_fn_args, res_ty)+            <-  mkWWargs subst rep_ty demands+       ; let co' = substCo subst co+       ; return (wrap_args,+                  \e -> Cast (wrap_fn_args e) (mkSymCo co'),+                  \e -> work_fn_args (Cast e co'),+                  res_ty) }++  | otherwise+  = WARN( True, ppr fun_ty )                    -- Should not happen: if there is a demand+    return ([], id, id, substTy subst fun_ty)   -- then there should be a function arrow+  where+    -- See Note [Join points and beta-redexes]+    apply_or_bind_then k arg (Lam bndr body)+      = mkCoreLet (NonRec bndr arg) (k body)    -- Important that arg is fresh!+    apply_or_bind_then k arg fun+      = k $ mkCoreApp (text "mkWWargs") fun arg+applyToVars :: [Var] -> CoreExpr -> CoreExpr+applyToVars vars fn = mkVarApps fn vars++mk_wrap_arg :: Unique -> Type -> Demand -> Id+mk_wrap_arg uniq ty dmd+  = mkSysLocalOrCoVar (fsLit "w") uniq ty+       `setIdDemandInfo` dmd++{- Note [Freshen WW arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Wen we do a worker/wrapper split, we must not in-scope names as the arguments+of the worker, else we'll get name capture.  E.g.++   -- y1 is in scope from further out+   f x = ..y1..++If we accidentally choose y1 as a worker argument disaster results:++   fww y1 y2 = let x = (y1,y2) in ...y1...++To avoid this:++  * We use a fresh unique for both type-variable and term-variable binders+    Originally we lacked this freshness for type variables, and that led+    to the very obscure Trac #12562.  (A type variable in the worker shadowed+    an outer term-variable binding.)++  * Because of this cloning we have to substitute in the type/kind of the+    new binders.  That's why we carry the TCvSubst through mkWWargs.++    So we need a decent in-scope set, just in case that type/kind+    itself has foralls.  We get this from the free vars of the RHS of the+    function since those are the only variables that might be captured.+    It's a lazy thunk, which will only be poked if the type/kind has a forall.++    Another tricky case was when f :: forall a. a -> forall a. a->a+    (i.e. with shadowing), and then the worker used the same 'a' twice.++************************************************************************+*                                                                      *+\subsection{Strictness stuff}+*                                                                      *+************************************************************************+-}++mkWWstr :: DynFlags+        -> FamInstEnvs+        -> [Var]                                -- Wrapper args; have their demand info on them+                                                --  *Includes type variables*+        -> UniqSM (Bool,                        -- Is this useful+                   [Var],                       -- Worker args+                   CoreExpr -> CoreExpr,        -- Wrapper body, lacking the worker call+                                                -- and without its lambdas+                                                -- This fn adds the unboxing++                   CoreExpr -> CoreExpr)        -- Worker body, lacking the original body of the function,+                                                -- and lacking its lambdas.+                                                -- This fn does the reboxing+mkWWstr _ _ []+  = return (False, [], nop_fn, nop_fn)++mkWWstr dflags fam_envs (arg : args) = do+    (useful1, args1, wrap_fn1, work_fn1) <- mkWWstr_one dflags fam_envs arg+    (useful2, args2, wrap_fn2, work_fn2) <- mkWWstr dflags fam_envs args+    return (useful1 || useful2, args1 ++ args2, wrap_fn1 . wrap_fn2, work_fn1 . work_fn2)++{-+Note [Unpacking arguments with product and polymorphic demands]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The argument is unpacked in a case if it has a product type and has a+strict *and* used demand put on it. I.e., arguments, with demands such+as the following ones:++   <S,U(U, L)>+   <S(L,S),U>++will be unpacked, but++   <S,U> or <B,U>++will not, because the pieces aren't used. This is quite important otherwise+we end up unpacking massive tuples passed to the bottoming function. Example:++        f :: ((Int,Int) -> String) -> (Int,Int) -> a+        f g pr = error (g pr)++        main = print (f fst (1, error "no"))++Does 'main' print "error 1" or "error no"?  We don't really want 'f'+to unbox its second argument.  This actually happened in GHC's onwn+source code, in Packages.applyPackageFlag, which ended up un-boxing+the enormous DynFlags tuple, and being strict in the+as-yet-un-filled-in pkgState files.+-}++----------------------+-- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn)+--   *  wrap_fn assumes wrap_arg is in scope,+--        brings into scope work_args (via cases)+--   * work_fn assumes work_args are in scope, a+--        brings into scope wrap_arg (via lets)+mkWWstr_one :: DynFlags -> FamInstEnvs -> Var+    -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)+mkWWstr_one dflags fam_envs arg+  | isTyVar arg+  = return (False, [arg],  nop_fn, nop_fn)++  -- See Note [Worker-wrapper for bottoming functions]+  | isAbsDmd dmd+  , Just work_fn <- mk_absent_let dflags arg+     -- Absent case.  We can't always handle absence for arbitrary+     -- unlifted types, so we need to choose just the cases we can+     --- (that's what mk_absent_let does)+  = return (True, [], nop_fn, work_fn)++  -- See Note [Worthy functions for Worker-Wrapper split]+  | isSeqDmd dmd  -- `seq` demand; evaluate in wrapper in the hope+                  -- of dropping seqs in the worker+  = let arg_w_unf = arg `setIdUnfolding` evaldUnfolding+          -- Tell the worker arg that it's sure to be evaluated+          -- so that internal seqs can be dropped+    in return (True, [arg_w_unf], mk_seq_case arg, nop_fn)+                -- Pass the arg, anyway, even if it is in theory discarded+                -- Consider+                --      f x y = x `seq` y+                -- x gets a (Eval (Poly Abs)) demand, but if we fail to pass it to the worker+                -- we ABSOLUTELY MUST record that x is evaluated in the wrapper.+                -- Something like:+                --      f x y = x `seq` fw y+                --      fw y = let x{Evald} = error "oops" in (x `seq` y)+                -- If we don't pin on the "Evald" flag, the seq doesn't disappear, and+                -- we end up evaluating the absent thunk.+                -- But the Evald flag is pretty weird, and I worry that it might disappear+                -- during simplification, so for now I've just nuked this whole case++  | isStrictDmd dmd+  , Just cs <- splitProdDmd_maybe dmd+      -- See Note [Unpacking arguments with product and polymorphic demands]+  , Just (data_con, inst_tys, inst_con_arg_tys, co)+             <- deepSplitProductType_maybe fam_envs (idType arg)+  , cs `equalLength` inst_con_arg_tys+      -- See Note [mkWWstr and unsafeCoerce]+  = do { (uniq1:uniqs) <- getUniquesM+        ; let   unpk_args = zipWith3 mk_ww_arg uniqs inst_con_arg_tys cs+                unbox_fn  = mkUnpackCase (Var arg) co uniq1+                                         data_con unpk_args+                rebox_fn  = Let (NonRec arg con_app)+                con_app   = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co+         ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs unpk_args+         ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }+                           -- Don't pass the arg, rebox instead++  | otherwise   -- Other cases+  = return (False, [arg], nop_fn, nop_fn)++  where+    dmd = idDemandInfo arg+    mk_ww_arg uniq ty sub_dmd = setIdDemandInfo (mk_ww_local uniq ty) sub_dmd++----------------------+nop_fn :: CoreExpr -> CoreExpr+nop_fn body = body++{-+Note [mkWWstr and unsafeCoerce]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+By using unsafeCoerce, it is possible to make the number of demands fail to+match the number of constructor arguments; this happened in Trac #8037.+If so, the worker/wrapper split doesn't work right and we get a Core Lint+bug.  The fix here is simply to decline to do w/w if that happens.++Note [Record evaluated-ness in worker/wrapper]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++   data T = MkT !Int Int++   f :: T -> T+   f x = e++and f's is strict, and has the CPR property.  The we are going to generate+this w/w split++   f x = case x of+           MkT x1 x2 -> case $wf x1 x2 of+                           (# r1, r2 #) -> MkT r1 r2++   $wfw x1 x2 = let x = MkT x1 x2 in+                case e of+                  MkT r1 r2 -> (# r1, r2 #)++Note that++* In the worker $wf, inside 'e' we can be sure that x1 will be+  evaluated (it came from unpacking the argument MkT.  But that's no+  immediately apparent in $wf++* In the wrapper 'f', which we'll inline at call sites, we can be sure+  that 'r1' has been evaluated (because it came from unpacking the result+  MkT.  But that is not immediately apparent from the wrapper code.++Missing these facts isn't unsound, but it loses possible future+opportunities for optimisation.++Solution: use setCaseBndrEvald when creating+ (A) The arg binders x1,x2 in mkWstr_one+         See Trac #13077, test T13077+ (B) The result binders r1,r2 in mkWWcpr_help+         See Trace #13077, test T13077a+         And Trac #13027 comment:20, item (4)+to record that the relevant binder is evaluated.+++************************************************************************+*                                                                      *+         Type scrutiny that is specific to demand analysis+*                                                                      *+************************************************************************++Note [Do not unpack class dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have+   f :: Ord a => [a] -> Int -> a+   {-# INLINABLE f #-}+and we worker/wrapper f, we'll get a worker with an INLINABLE pragma+(see Note [Worker-wrapper for INLINABLE functions] in WorkWrap), which+can still be specialised by the type-class specialiser, something like+   fw :: Ord a => [a] -> Int# -> a++BUT if f is strict in the Ord dictionary, we might unpack it, to get+   fw :: (a->a->Bool) -> [a] -> Int# -> a+and the type-class specialiser can't specialise that.  An example is+Trac #6056.++Moreover, dictionaries can have a lot of fields, so unpacking them can+increase closure sizes.++Conclusion: don't unpack dictionaries.+-}++deepSplitProductType_maybe+    :: FamInstEnvs -> Type+    -> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)+-- If    deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co)+-- then  dc @ tys (args::arg_tys) :: rep_ty+--       co :: ty ~ rep_ty+-- Why do we return the strictness of the data-con arguments?+-- Answer: see Note [Record evaluated-ness in worker/wrapper]+deepSplitProductType_maybe fam_envs ty+  | let (co, ty1) = topNormaliseType_maybe fam_envs ty+                    `orElse` (mkRepReflCo ty, ty)+  , Just (tc, tc_args) <- splitTyConApp_maybe ty1+  , Just con <- isDataProductTyCon_maybe tc+  , not (isClassTyCon tc)  -- See Note [Do not unpack class dictionaries]+  , let arg_tys = dataConInstArgTys con tc_args+        strict_marks = dataConRepStrictness con+  = Just (con, tc_args, zipEqual "dspt" arg_tys strict_marks, co)+deepSplitProductType_maybe _ _ = Nothing++deepSplitCprType_maybe+    :: FamInstEnvs -> ConTag -> Type+    -> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)+-- If    deepSplitCprType_maybe n ty = Just (dc, tys, arg_tys, co)+-- then  dc @ tys (args::arg_tys) :: rep_ty+--       co :: ty ~ rep_ty+-- Why do we return the strictness of the data-con arguments?+-- Answer: see Note [Record evaluated-ness in worker/wrapper]+deepSplitCprType_maybe fam_envs con_tag ty+  | let (co, ty1) = topNormaliseType_maybe fam_envs ty+                    `orElse` (mkRepReflCo ty, ty)+  , Just (tc, tc_args) <- splitTyConApp_maybe ty1+  , isDataTyCon tc+  , let cons = tyConDataCons tc+  , cons `lengthAtLeast` con_tag -- This might not be true if we import the+                                 -- type constructor via a .hs-bool file (#8743)+  , let con = cons `getNth` (con_tag - fIRST_TAG)+        arg_tys = dataConInstArgTys con tc_args+        strict_marks = dataConRepStrictness con+  = Just (con, tc_args, zipEqual "dsct" arg_tys strict_marks, co)+deepSplitCprType_maybe _ _ _ = Nothing++findTypeShape :: FamInstEnvs -> Type -> TypeShape+-- Uncover the arrow and product shape of a type+-- The data type TypeShape is defined in Demand+-- See Note [Trimming a demand to a type] in Demand+findTypeShape fam_envs ty+  | Just (tc, tc_args)  <- splitTyConApp_maybe ty+  , Just con <- isDataProductTyCon_maybe tc+  = TsProd (map (findTypeShape fam_envs) $ dataConInstArgTys con tc_args)++  | Just (_, res) <- splitFunTy_maybe ty+  = TsFun (findTypeShape fam_envs res)++  | Just (_, ty') <- splitForAllTy_maybe ty+  = findTypeShape fam_envs ty'++  | Just (_, ty') <- topNormaliseType_maybe fam_envs ty+  = findTypeShape fam_envs ty'++  | otherwise+  = TsUnk++{-+************************************************************************+*                                                                      *+\subsection{CPR stuff}+*                                                                      *+************************************************************************+++@mkWWcpr@ takes the worker/wrapper pair produced from the strictness+info and adds in the CPR transformation.  The worker returns an+unboxed tuple containing non-CPR components.  The wrapper takes this+tuple and re-produces the correct structured output.++The non-CPR results appear ordered in the unboxed tuple as if by a+left-to-right traversal of the result structure.+-}++mkWWcpr :: Bool+        -> FamInstEnvs+        -> Type                              -- function body type+        -> DmdResult                         -- CPR analysis results+        -> UniqSM (Bool,                     -- Is w/w'ing useful?+                   CoreExpr -> CoreExpr,     -- New wrapper+                   CoreExpr -> CoreExpr,     -- New worker+                   Type)                     -- Type of worker's body++mkWWcpr opt_CprAnal fam_envs body_ty res+    -- CPR explicitly turned off (or in -O0)+  | not opt_CprAnal = return (False, id, id, body_ty)+    -- CPR is turned on by default for -O and O2+  | otherwise+  = case returnsCPR_maybe res of+       Nothing      -> return (False, id, id, body_ty)  -- No CPR info+       Just con_tag | Just stuff <- deepSplitCprType_maybe fam_envs con_tag body_ty+                    -> mkWWcpr_help stuff+                    |  otherwise+                       -- See Note [non-algebraic or open body type warning]+                    -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )+                       return (False, id, id, body_ty)++mkWWcpr_help :: (DataCon, [Type], [(Type,StrictnessMark)], Coercion)+             -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)++mkWWcpr_help (data_con, inst_tys, arg_tys, co)+  | [arg1@(arg_ty1, _)] <- arg_tys+  , isUnliftedType arg_ty1+        -- Special case when there is a single result of unlifted type+        --+        -- Wrapper:     case (..call worker..) of x -> C x+        -- Worker:      case (   ..body..    ) of C x -> x+  = do { (work_uniq : arg_uniq : _) <- getUniquesM+       ; let arg       = mk_ww_local arg_uniq arg1+             con_app   = mkConApp2 data_con inst_tys [arg] `mkCast` mkSymCo co++       ; return ( True+                , \ wkr_call -> Case wkr_call arg (exprType con_app) [(DEFAULT, [], con_app)]+                , \ body     -> mkUnpackCase body co work_uniq data_con [arg] (varToCoreExpr arg)+                                -- varToCoreExpr important here: arg can be a coercion+                                -- Lacking this caused Trac #10658+                , arg_ty1 ) }++  | otherwise   -- The general case+        -- Wrapper: case (..call worker..) of (# a, b #) -> C a b+        -- Worker:  case (   ...body...  ) of C a b -> (# a, b #)+  = do { (work_uniq : wild_uniq : uniqs) <- getUniquesM+       ; let wrap_wild   = mk_ww_local wild_uniq (ubx_tup_ty,MarkedStrict)+             args        = zipWith mk_ww_local uniqs arg_tys+             ubx_tup_ty  = exprType ubx_tup_app+             ubx_tup_app = mkCoreUbxTup (map fst arg_tys) (map varToCoreExpr args)+             con_app     = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co++       ; return (True+                , \ wkr_call -> Case wkr_call wrap_wild (exprType con_app)  [(DataAlt (tupleDataCon Unboxed (length arg_tys)), args, con_app)]+                , \ body     -> mkUnpackCase body co work_uniq data_con args ubx_tup_app+                , ubx_tup_ty ) }++mkUnpackCase ::  CoreExpr -> Coercion -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr+-- (mkUnpackCase e co uniq Con args body)+--      returns+-- case e |> co of bndr { Con args -> body }++mkUnpackCase (Tick tickish e) co uniq con args body   -- See Note [Profiling and unpacking]+  = Tick tickish (mkUnpackCase e co uniq con args body)+mkUnpackCase scrut co uniq boxing_con unpk_args body+  = Case casted_scrut bndr (exprType body)+         [(DataAlt boxing_con, unpk_args, body)]+  where+    casted_scrut = scrut `mkCast` co+    bndr = mk_ww_local uniq (exprType casted_scrut, MarkedStrict)++{-+Note [non-algebraic or open body type warning]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++There are a few cases where the W/W transformation is told that something+returns a constructor, but the type at hand doesn't really match this. One+real-world example involves unsafeCoerce:+  foo = IO a+  foo = unsafeCoerce c_exit+  foreign import ccall "c_exit" c_exit :: IO ()+Here CPR will tell you that `foo` returns a () constructor for sure, but trying+to create a worker/wrapper for type `a` obviously fails.+(This was a real example until ee8e792  in libraries/base.)++It does not seem feasible to avoid all such cases already in the analyser (and+after all, the analysis is not really wrong), so we simply do nothing here in+mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch+other cases where something went avoidably wrong.+++Note [Profiling and unpacking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the original function looked like+        f = \ x -> {-# SCC "foo" #-} E++then we want the CPR'd worker to look like+        \ x -> {-# SCC "foo" #-} (case E of I# x -> x)+and definitely not+        \ x -> case ({-# SCC "foo" #-} E) of I# x -> x)++This transform doesn't move work or allocation+from one cost centre to another.++Later [SDM]: presumably this is because we want the simplifier to+eliminate the case, and the scc would get in the way?  I'm ok with+including the case itself in the cost centre, since it is morally+part of the function (post transformation) anyway.+++************************************************************************+*                                                                      *+\subsection{Utilities}+*                                                                      *+************************************************************************++Note [Absent errors]+~~~~~~~~~~~~~~~~~~~~+We make a new binding for Ids that are marked absent, thus+   let x = absentError "x :: Int"+The idea is that this binding will never be used; but if it+buggily is used we'll get a runtime error message.++Coping with absence for *unlifted* types is important; see, for+example, Trac #4306.  For these we find a suitable literal,+using Literal.absentLiteralOf.  We don't have literals for+every primitive type, so the function is partial.++    [I did try the experiment of using an error thunk for unlifted+    things too, relying on the simplifier to drop it as dead code,+    by making absentError+      (a) *not* be a bottoming Id,+      (b) be "ok for speculation"+    But that relies on the simplifier finding that it really+    is dead code, which is fragile, and indeed failed when+    profiling is on, which disables various optimisations.  So+    using a literal will do.]+-}++mk_absent_let :: DynFlags -> Id -> Maybe (CoreExpr -> CoreExpr)+mk_absent_let dflags arg+  | not (isUnliftedType arg_ty)+  = Just (Let (NonRec lifted_arg abs_rhs))+  | Just tc <- tyConAppTyCon_maybe arg_ty+  , Just lit <- absentLiteralOf tc+  = Just (Let (NonRec arg (Lit lit)))+  | arg_ty `eqType` voidPrimTy+  = Just (Let (NonRec arg (Var voidPrimId)))+  | otherwise+  = WARN( True, text "No absent value for" <+> ppr arg_ty )+    Nothing+  where+    arg_ty     = idType arg+    abs_rhs    = mkRuntimeErrorApp aBSENT_ERROR_ID arg_ty msg+    lifted_arg = arg `setIdStrictness` exnSig+              -- Note in strictness signature that this is bottoming+              -- (for the sake of the "empty case scrutinee not known to+              -- diverge for sure lint" warning)+    msg        = showSDoc (gopt_set dflags Opt_SuppressUniques)+                          (ppr arg <+> ppr (idType arg))+              -- We need to suppress uniques here because otherwise they'd+              -- end up in the generated code as strings. This is bad for+              -- determinism, because with different uniques the strings+              -- will have different lengths and hence different costs for+              -- the inliner leading to different inlining.+              -- See also Note [Unique Determinism] in Unique++mk_seq_case :: Id -> CoreExpr -> CoreExpr+mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) (exprType body) [(DEFAULT, [], body)]++sanitiseCaseBndr :: Id -> Id+-- The argument we are scrutinising has the right type to be+-- a case binder, so it's convenient to re-use it for that purpose.+-- But we *must* throw away all its IdInfo.  In particular, the argument+-- will have demand info on it, and that demand info may be incorrect for+-- the case binder.  e.g.       case ww_arg of ww_arg { I# x -> ... }+-- Quite likely ww_arg isn't used in '...'.  The case may get discarded+-- if the case binder says "I'm demanded".  This happened in a situation+-- like         (x+y) `seq` ....+sanitiseCaseBndr id = id `setIdInfo` vanillaIdInfo++mk_ww_local :: Unique -> (Type, StrictnessMark) -> Id+-- The StrictnessMark comes form the data constructor and says+-- whether this field is strict+-- See Note [Record evaluated-ness in worker/wrapper]+mk_ww_local uniq (ty,str)+  = setCaseBndrEvald str $+    mkSysLocalOrCoVar (fsLit "ww") uniq ty
+ typecheck/FamInst.hs view
@@ -0,0 +1,918 @@+-- The @FamInst@ type: family instance heads++{-# LANGUAGE CPP, GADTs #-}++module FamInst (+        FamInstEnvs, tcGetFamInstEnvs,+        checkFamInstConsistency, tcExtendLocalFamInstEnv,+        tcLookupDataFamInst, tcLookupDataFamInst_maybe,+        tcInstNewTyCon_maybe, tcTopNormaliseNewTypeTF_maybe,+        checkRecFamInstConsistency,+        newFamInst,++        -- * Injectivity+        makeInjectivityErrors, injTyVarsOfType, injTyVarsOfTypes+    ) where++import HscTypes+import FamInstEnv+import InstEnv( roughMatchTcs )+import Coercion+import TcEvidence+import LoadIface+import TcRnMonad+import SrcLoc+import TyCon+import TcType+import CoAxiom+import DynFlags+import Module+import Outputable+import Util+import RdrName+import DataCon ( dataConName )+import Maybes+import Type+import TyCoRep+import TcMType+import Name+import Pair+import Panic+import VarSet+import Bag( Bag, unionBags, unitBag )+import Control.Monad+import Unique+import NameEnv+import Data.Set (Set)+import qualified Data.Set as Set+import Data.List++#include "HsVersions.h"++{-++Note [The type family instance consistency story]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++To preserve type safety we must ensure that for any given module, all+the type family instances used either in that module or in any module+it directly or indirectly imports are consistent. For example, consider++  module F where+    type family F a++  module A where+    import F( F )+    type instance F Int = Bool+    f :: F Int -> Bool+    f x = x++  module B where+    import F( F )+    type instance F Int = Char+    g :: Char -> F Int+    g x = x++  module Bad where+    import A( f )+    import B( g )+    bad :: Char -> Int+    bad c = f (g c)++Even though module Bad never mentions the type family F at all, by+combining the functions f and g that were type checked in contradictory+type family instance environments, the function bad is able to coerce+from one type to another. So when we type check Bad we must verify that+the type family instances defined in module A are consistent with those+defined in module B.++How do we ensure that we maintain the necessary consistency?++* Call a module which defines at least one type family instance a+"family instance module". This flag `mi_finsts` is recorded in the+interface file.++* For every module we calculate the set of all of its direct and+indirect dependencies that are family instance modules. This list+`dep_finsts` is also recorded in the interface file so we can compute+this list for a module from the lists for its direct dependencies.++* When type checking a module M we check consistency of all the type+family instances that are either provided by its `dep_finsts` or+defined in the module M itself. This is a pairwise check, i.e., for+every pair of instances we must check that they are consistent.++- For family instances coming from `dep_finsts`, this is checked in+checkFamInstConsistency, called from tcRnImports, and in+checkRecFamInstConsistency, called from tcTyClGroup. See Note+[Checking family instance consistency] for details on this check (and+in particular how we avoid having to do all these checks for every+module we compile).++- That leaves checking the family instances defined in M itself+against instances defined in either M or its `dep_finsts`. This is+checked in `tcExtendLocalFamInstEnv'.++There are two subtle points in this scheme which have not been+addressed yet.++* We have checked consistency of the family instances *defined* by M+or its imports, but this is not by definition the same thing as the+family instances *used* by M or its imports.  Specifically, we need to+ensure when we use a type family instance while compiling M that this+instance was really defined from either M or one of its imports,+rather than being an instance that we happened to know about from+reading an interface file in the course of compiling an unrelated+module. Otherwise, we'll end up with no record of the fact that M+depends on this family instance and type safety will be compromised.+See #13102.++* It can also happen that M uses a function defined in another module+which is not transitively imported by M. Examples include the+desugaring of various overloaded constructs, and references inserted+by Template Haskell splices. If that function's definition makes use+of type family instances which are not checked against those visible+from M, type safety can again be compromised. See #13251.++* When a module C imports a boot module B.hs-boot, we check that C's+type family instances are compatible with those visible from+B.hs-boot. However, C will eventually be linked against a different+module B.hs, which might define additional type family instances which+are inconsistent with C's. This can also lead to loss of type safety.+See #9562.++-}++{-+************************************************************************+*                                                                      *+                 Making a FamInst+*                                                                      *+************************************************************************+-}++-- All type variables in a FamInst must be fresh. This function+-- creates the fresh variables and applies the necessary substitution+-- It is defined here to avoid a dependency from FamInstEnv on the monad+-- code.++newFamInst :: FamFlavor -> CoAxiom Unbranched -> TcRnIf gbl lcl FamInst+-- Freshen the type variables of the FamInst branches+-- Called from the vectoriser monad too, hence the rather general type+newFamInst flavor axiom@(CoAxiom { co_ax_tc = fam_tc })+  = ASSERT2( tyCoVarsOfTypes lhs `subVarSet` tcv_set, text "lhs" <+> pp_ax )+    ASSERT2( tyCoVarsOfType  rhs `subVarSet` tcv_set, text "rhs" <+> pp_ax )+    ASSERT2( lhs_kind `eqType` rhs_kind, text "kind" <+> pp_ax $$ ppr lhs_kind $$ ppr rhs_kind )+    do { (subst, tvs') <- freshenTyVarBndrs tvs+       ; (subst, cvs') <- freshenCoVarBndrsX subst cvs+       ; return (FamInst { fi_fam      = tyConName fam_tc+                         , fi_flavor   = flavor+                         , fi_tcs      = roughMatchTcs lhs+                         , fi_tvs      = tvs'+                         , fi_cvs      = cvs'+                         , fi_tys      = substTys subst lhs+                         , fi_rhs      = substTy  subst rhs+                         , fi_axiom    = axiom }) }+  where+    lhs_kind = typeKind (mkTyConApp fam_tc lhs)+    rhs_kind = typeKind rhs+    tcv_set  = mkVarSet (tvs ++ cvs)+    pp_ax    = pprCoAxiom axiom+    CoAxBranch { cab_tvs = tvs+               , cab_cvs = cvs+               , cab_lhs = lhs+               , cab_rhs = rhs } = coAxiomSingleBranch axiom+++{-+************************************************************************+*                                                                      *+        Optimised overlap checking for family instances+*                                                                      *+************************************************************************++Note [Checking family instance consistency]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For any two family instance modules that we import directly or indirectly, we+check whether the instances in the two modules are consistent, *unless* we can+be certain that the instances of the two modules have already been checked for+consistency during the compilation of modules that we import.++Why do we need to check?  Consider+   module X1 where                module X2 where+    data T1                         data T2+    type instance F T1 b = Int      type instance F a T2 = Char+    f1 :: F T1 a -> Int             f2 :: Char -> F a T2+    f1 x = x                        f2 x = x++Now if we import both X1 and X2 we could make (f2 . f1) :: Int -> Char.+Notice that neither instance is an orphan.++How do we know which pairs of modules have already been checked? For each+module M we directly import, we look up the family instance modules that M+imports (directly or indirectly), say F1, ..., FN. For any two modules+among M, F1, ..., FN, we know that the family instances defined in those+two modules are consistent--because we checked that when we compiled M.++For every other pair of family instance modules we import (directly or+indirectly), we check that they are consistent now. (So that we can be+certain that the modules in our `HscTypes.dep_finsts' are consistent.)++There is some fancy footwork regarding hs-boot module loops, see+Note [Don't check hs-boot type family instances too early]+-}++-- The optimisation of overlap tests is based on determining pairs of modules+-- whose family instances need to be checked for consistency.+--+data ModulePair = ModulePair Module Module+                  -- Invariant: first Module < second Module+                  -- use the smart constructor++-- | Smart constructor that establishes the invariant+modulePair :: Module -> Module -> ModulePair+modulePair a b+  | a < b = ModulePair a b+  | otherwise = ModulePair b a++instance Eq ModulePair where+  (ModulePair a1 b1) == (ModulePair a2 b2) = a1 == a2 && b1 == b2++instance Ord ModulePair where+  (ModulePair a1 b1) `compare` (ModulePair a2 b2) =+    nonDetCmpModule a1 a2 `thenCmp`+    nonDetCmpModule b1 b2+    -- See Note [ModulePairSet determinism and performance]++instance Outputable ModulePair where+  ppr (ModulePair m1 m2) = angleBrackets (ppr m1 <> comma <+> ppr m2)++-- Fast, nondeterministic comparison on Module. Don't use when the ordering+-- can change the ABI. See Note [ModulePairSet determinism and performance]+nonDetCmpModule :: Module -> Module -> Ordering+nonDetCmpModule a b =+  nonDetCmpUnique (getUnique $ moduleUnitId a) (getUnique $ moduleUnitId b)+  `thenCmp`+  nonDetCmpUnique (getUnique $ moduleName a) (getUnique $ moduleName b)++type ModulePairSet = Set ModulePair+{-+Note [ModulePairSet determinism and performance]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The size of ModulePairSet is quadratic in the number of modules.+The Ord instance for Module uses string comparison which is linear in the+length of ModuleNames and UnitIds. This adds up to a significant cost, see+#12191.++To get reasonable performance ModulePairSet uses nondeterministic ordering+on Module based on Uniques. It doesn't affect the ABI, because it only+determines the order the modules are checked for family instance consistency.+See Note [Unique Determinism] in Unique+-}++listToSet :: [ModulePair] -> ModulePairSet+listToSet l = Set.fromList l++-- | Check family instance consistency, given:+--+-- 1. The list of all modules transitively imported by us+--    which define a family instance (these are the ones+--    we have to check for consistency), and+--+-- 2. The list of modules which we directly imported+--    (these specify the sets of family instance defining+--    modules which are already known to be consistent).+--+-- See Note [Checking family instance consistency] for more+-- details, and Note [The type family instance consistency story]+-- for the big picture.+--+-- This function doesn't check ALL instances for consistency,+-- only ones that aren't involved in recursive knot-tying+-- loops; see Note [Don't check hs-boot type family instances too early].+-- It returns a modified 'TcGblEnv' that has saved the+-- instances that need to be checked later; use 'checkRecFamInstConsistency'+-- to check those.+checkFamInstConsistency :: [Module] -> [Module] -> TcM TcGblEnv+checkFamInstConsistency famInstMods directlyImpMods+  = do { dflags     <- getDynFlags+       ; (eps, hpt) <- getEpsAndHpt+       ; let { -- Fetch the iface of a given module.  Must succeed as+               -- all directly imported modules must already have been loaded.+               modIface mod =+                 case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of+                   Nothing    -> panicDoc "FamInst.checkFamInstConsistency"+                                          (ppr mod $$ pprHPT hpt)+                   Just iface -> iface++               -- Which modules were checked for consistency when we compiled+               -- `mod`? Itself and its dep_finsts.+             ; modConsistent mod = mod : (dep_finsts . mi_deps . modIface $ mod)++             ; hmiModule     = mi_module . hm_iface+             ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv+                               . md_fam_insts . hm_details+             ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi)+                                           | hmi <- eltsHpt hpt]+             ; groups        = map modConsistent directlyImpMods+             ; okPairs       = listToSet $ concatMap allPairs groups+                 -- instances of okPairs are consistent+             ; criticalPairs = listToSet $ allPairs famInstMods+                 -- all pairs that we need to consider+             ; toCheckPairs  =+                 Set.elems $ criticalPairs `Set.difference` okPairs+                 -- the difference gives us the pairs we need to check now+                 -- See Note [ModulePairSet determinism and performance]+             }++       ; pending_checks <- mapM (check hpt_fam_insts) toCheckPairs+       ; tcg_env <- getGblEnv+       ; return tcg_env { tcg_pending_fam_checks+                           = foldl' (plusNameEnv_C (++)) emptyNameEnv pending_checks }+       }+  where+    allPairs []     = []+    allPairs (m:ms) = map (modulePair m) ms ++ allPairs ms++    check hpt_fam_insts (ModulePair m1 m2)+      = do { env1' <- getFamInsts hpt_fam_insts m1+           ; env2' <- getFamInsts hpt_fam_insts m2+           -- We're checking each element of env1 against env2.+           -- The cost of that is dominated by the size of env1, because+           -- for each instance in env1 we look it up in the type family+           -- environment env2, and lookup is cheap.+           -- The code below ensures that env1 is the smaller environment.+           ; let sizeE1 = famInstEnvSize env1'+                 sizeE2 = famInstEnvSize env2'+                 (env1, env2) = if sizeE1 < sizeE2 then (env1', env2')+                                                   else (env2', env1')+           -- Note [Don't check hs-boot type family instances too early]+           -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+           -- Family instance consistency checking involves checking that+           -- the family instances of our imported modules are consistent with+           -- one another; this might lead you to think that this process+           -- has nothing to do with the module we are about to typecheck.+           -- Not so!  Consider the following case:+           --+           --   -- A.hs-boot+           --   type family F a+           --+           --   -- B.hs+           --   import {-# SOURCE #-} A+           --   type instance F Int = Bool+           --+           --   -- A.hs+           --   import B+           --   type family F a+           --+           -- When typechecking A, we are NOT allowed to poke the TyThing+           -- for for F until we have typechecked the family.  Thus, we+           -- can't do consistency checking for the instance in B+           -- (checkFamInstConsistency is called during renaming).+           -- Failing to defer the consistency check lead to #11062.+           --+           -- Additionally, we should also defer consistency checking when+           -- type from the hs-boot file of the current module occurs on+           -- the left hand side, as we will poke its TyThing when checking+           -- for overlap.+           --+           --   -- F.hs+           --   type family F a+           --+           --   -- A.hs-boot+           --   import F+           --   data T+           --+           --   -- B.hs+           --   import {-# SOURCE #-} A+           --   import F+           --   type instance F T = Int+           --+           --   -- A.hs+           --   import B+           --   data T = MkT+           --+           -- However, this is not yet done; see #13981.+           --+           -- Note that it is NOT necessary to defer for occurrences in the+           -- RHS (e.g., type instance F Int = T, in the above example),+           -- since that never participates in consistency checking+           -- in any nontrivial way.+           --+           -- Why don't we defer ALL of the checks to later?  Well, many+           -- instances aren't involved in the recursive loop at all.  So+           -- we might as well check them immediately; and there isn't+           -- a good time to check them later in any case: every time+           -- we finish kind-checking a type declaration and add it to+           -- a context, we *then* consistency check all of the instances+           -- which mentioned that type.  We DO want to check instances+           -- as quickly as possible, so that we aren't typechecking+           -- values with inconsistent axioms in scope.+           --+           -- See also Note [Tying the knot] and Note [Type-checking inside the knot]+           -- for why we are doing this at all.+           ; this_mod <- getModule+                    -- NB: == this_mod only holds if there's an hs-boot file;+                    -- otherwise we cannot possible see instances for families+                    -- defined by the module we are compiling in imports.+           ; let shouldCheckNow = ((/= this_mod) . nameModule . fi_fam)+                 (check_now, check_later) =+                    partition shouldCheckNow (famInstEnvElts env1)+           ; mapM_ (checkForConflicts (emptyFamInstEnv, env2))           check_now+           ; mapM_ (checkForInjectivityConflicts (emptyFamInstEnv,env2)) check_now+           ; let check_later_map =+                    extendNameEnvList_C (++) emptyNameEnv+                        [(fi_fam finst, [finst]) | finst <- check_later]+           ; return (mapNameEnv (\xs -> [(xs, env2)]) check_later_map)+ }++-- | Given a 'TyCon' that has been incorporated into the type+-- environment (the knot is tied), if it is a type family, check+-- that all deferred instances for it are consistent.+-- See Note [Don't check hs-boot type family instances too early]+checkRecFamInstConsistency :: TyCon -> TcM ()+checkRecFamInstConsistency tc = do+   tcg_env <- getGblEnv+   let checkConsistency tc+        | isFamilyTyCon tc+        , Just pairs <- lookupNameEnv (tcg_pending_fam_checks tcg_env)+                                      (tyConName tc)+        = forM_ pairs $ \(check_now, env2) -> do+            mapM_ (checkForConflicts (emptyFamInstEnv, env2))           check_now+            mapM_ (checkForInjectivityConflicts (emptyFamInstEnv,env2)) check_now+        | otherwise+        = return ()+   checkConsistency tc+++getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv+getFamInsts hpt_fam_insts mod+  | Just env <- lookupModuleEnv hpt_fam_insts mod = return env+  | otherwise = do { _ <- initIfaceTcRn (loadSysInterface doc mod)+                   ; eps <- getEps+                   ; return (expectJust "checkFamInstConsistency" $+                             lookupModuleEnv (eps_mod_fam_inst_env eps) mod) }+  where+    doc = ppr mod <+> text "is a family-instance module"++{-+************************************************************************+*                                                                      *+        Lookup+*                                                                      *+************************************************************************++-}++-- | If @co :: T ts ~ rep_ty@ then:+--+-- > instNewTyCon_maybe T ts = Just (rep_ty, co)+--+-- Checks for a newtype, and for being saturated+-- Just like Coercion.instNewTyCon_maybe, but returns a TcCoercion+tcInstNewTyCon_maybe :: TyCon -> [TcType] -> Maybe (TcType, TcCoercion)+tcInstNewTyCon_maybe = instNewTyCon_maybe++-- | Like 'tcLookupDataFamInst_maybe', but returns the arguments back if+-- there is no data family to unwrap.+-- Returns a Representational coercion+tcLookupDataFamInst :: FamInstEnvs -> TyCon -> [TcType]+                    -> (TyCon, [TcType], Coercion)+tcLookupDataFamInst fam_inst_envs tc tc_args+  | Just (rep_tc, rep_args, co)+      <- tcLookupDataFamInst_maybe fam_inst_envs tc tc_args+  = (rep_tc, rep_args, co)+  | otherwise+  = (tc, tc_args, mkRepReflCo (mkTyConApp tc tc_args))++tcLookupDataFamInst_maybe :: FamInstEnvs -> TyCon -> [TcType]+                          -> Maybe (TyCon, [TcType], Coercion)+-- ^ Converts a data family type (eg F [a]) to its representation type (eg FList a)+-- and returns a coercion between the two: co :: F [a] ~R FList a.+tcLookupDataFamInst_maybe fam_inst_envs tc tc_args+  | isDataFamilyTyCon tc+  , match : _ <- lookupFamInstEnv fam_inst_envs tc tc_args+  , FamInstMatch { fim_instance = rep_fam@(FamInst { fi_axiom = ax+                                                   , fi_cvs   = cvs })+                 , fim_tys      = rep_args+                 , fim_cos      = rep_cos } <- match+  , let rep_tc = dataFamInstRepTyCon rep_fam+        co     = mkUnbranchedAxInstCo Representational ax rep_args+                                      (mkCoVarCos cvs)+  = ASSERT( null rep_cos ) -- See Note [Constrained family instances] in FamInstEnv+    Just (rep_tc, rep_args, co)++  | otherwise+  = Nothing++-- | 'tcTopNormaliseNewTypeTF_maybe' gets rid of top-level newtypes,+-- potentially looking through newtype /instances/.+--+-- It is only used by the type inference engine (specifically, when+-- solving representational equality), and hence it is careful to unwrap+-- only if the relevant data constructor is in scope.  That's why+-- it get a GlobalRdrEnv argument.+--+-- It is careful not to unwrap data/newtype instances if it can't+-- continue unwrapping.  Such care is necessary for proper error+-- messages.+--+-- It does not look through type families.+-- It does not normalise arguments to a tycon.+--+-- If the result is Just (rep_ty, (co, gres), rep_ty), then+--    co : ty ~R rep_ty+--    gres are the GREs for the data constructors that+--                          had to be in scope+tcTopNormaliseNewTypeTF_maybe :: FamInstEnvs+                              -> GlobalRdrEnv+                              -> Type+                              -> Maybe ((Bag GlobalRdrElt, TcCoercion), Type)+tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty+-- cf. FamInstEnv.topNormaliseType_maybe and Coercion.topNormaliseNewType_maybe+  = topNormaliseTypeX stepper plus ty+  where+    plus :: (Bag GlobalRdrElt, TcCoercion) -> (Bag GlobalRdrElt, TcCoercion)+         -> (Bag GlobalRdrElt, TcCoercion)+    plus (gres1, co1) (gres2, co2) = ( gres1 `unionBags` gres2+                                     , co1 `mkTransCo` co2 )++    stepper :: NormaliseStepper (Bag GlobalRdrElt, TcCoercion)+    stepper = unwrap_newtype `composeSteppers` unwrap_newtype_instance++    -- For newtype instances we take a double step or nothing, so that+    -- we don't return the representation type of the newtype instance,+    -- which would lead to terrible error messages+    unwrap_newtype_instance rec_nts tc tys+      | Just (tc', tys', co) <- tcLookupDataFamInst_maybe faminsts tc tys+      = mapStepResult (\(gres, co1) -> (gres, co `mkTransCo` co1)) $+        unwrap_newtype rec_nts tc' tys'+      | otherwise = NS_Done++    unwrap_newtype rec_nts tc tys+      | Just con <- newTyConDataCon_maybe tc+      , Just gre <- lookupGRE_Name rdr_env (dataConName con)+           -- This is where we check that the+           -- data constructor is in scope+      = mapStepResult (\co -> (unitBag gre, co)) $+        unwrapNewTypeStepper rec_nts tc tys++      | otherwise+      = NS_Done++{-+************************************************************************+*                                                                      *+        Extending the family instance environment+*                                                                      *+************************************************************************+-}++-- Add new locally-defined family instances, checking consistency with+-- previous locally-defined family instances as well as all instances+-- available from imported modules. This requires loading all of our+-- imports that define family instances (if we haven't loaded them already).+tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a++-- If we weren't actually given any instances to add, then we don't want+-- to go to the bother of loading family instance module dependencies.+tcExtendLocalFamInstEnv [] thing_inside = thing_inside++-- Otherwise proceed...+tcExtendLocalFamInstEnv fam_insts thing_inside+ = do { env <- getGblEnv+      ; let this_mod = tcg_mod env+            imports = tcg_imports env++            -- Optimization: If we're only defining type family instances+            -- for type families *defined in the home package*, then we+            -- only have to load interface files that belong to the home+            -- package. The reason is that there's no recursion between+            -- packages, so modules in other packages can't possibly define+            -- instances for our type families.+            --+            -- (Within the home package, we could import a module M that+            -- imports us via an hs-boot file, and thereby defines an+            -- instance of a type family defined in this module. So we can't+            -- apply the same logic to avoid reading any interface files at+            -- all, when we define an instances for type family defined in+            -- the current module.)+            home_fams_only = all (nameIsHomePackage this_mod . fi_fam) fam_insts+            want_module mod+              | mod == this_mod = False+              | home_fams_only  = moduleUnitId mod == moduleUnitId this_mod+              | otherwise       = True+      ; loadModuleInterfaces (text "Loading family-instance modules")+                             (filter want_module (imp_finsts imports))+      ; (inst_env', fam_insts') <- foldlM addLocalFamInst+                                       (tcg_fam_inst_env env, tcg_fam_insts env)+                                       fam_insts+      ; let env' = env { tcg_fam_insts    = fam_insts'+                       , tcg_fam_inst_env = inst_env' }+      ; setGblEnv env' thing_inside+      }++-- Check that the proposed new instance is OK,+-- and then add it to the home inst env+-- This must be lazy in the fam_inst arguments, see Note [Lazy axiom match]+-- in FamInstEnv.hs+addLocalFamInst :: (FamInstEnv,[FamInst])+                -> FamInst+                -> TcM (FamInstEnv, [FamInst])+addLocalFamInst (home_fie, my_fis) fam_inst+        -- home_fie includes home package and this module+        -- my_fies is just the ones from this module+  = do { traceTc "addLocalFamInst" (ppr fam_inst)++           -- Unlike the case of class instances, don't override existing+           -- instances in GHCi; it's unsound. See #7102.++       ; mod <- getModule+       ; traceTc "alfi" (ppr mod)++           -- Fetch imported instances, so that we report+           -- overlaps correctly.+           -- Really we ought to only check consistency with+           -- those instances which are transitively imported+           -- by the current module, rather than every instance+           -- we've ever seen. Fixing this is part of #13102.+       ; eps <- getEps+       ; let inst_envs = (eps_fam_inst_env eps, home_fie)+             home_fie' = extendFamInstEnv home_fie fam_inst++           -- Check for conflicting instance decls and injectivity violations+       ; no_conflict    <- checkForConflicts            inst_envs fam_inst+       ; injectivity_ok <- checkForInjectivityConflicts inst_envs fam_inst++       ; if no_conflict && injectivity_ok then+            return (home_fie', fam_inst : my_fis)+         else+            return (home_fie,  my_fis) }++{-+************************************************************************+*                                                                      *+        Checking an instance against conflicts with an instance env+*                                                                      *+************************************************************************++Check whether a single family instance conflicts with those in two instance+environments (one for the EPS and one for the HPT).+-}++checkForConflicts :: FamInstEnvs -> FamInst -> TcM Bool+checkForConflicts inst_envs fam_inst+  = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst+             no_conflicts = null conflicts+       ; traceTc "checkForConflicts" $+         vcat [ ppr (map fim_instance conflicts)+              , ppr fam_inst+              -- , ppr inst_envs+         ]+       ; unless no_conflicts $ conflictInstErr fam_inst conflicts+       ; return no_conflicts }++-- | Check whether a new open type family equation can be added without+-- violating injectivity annotation supplied by the user. Returns True when+-- this is possible and False if adding this equation would violate injectivity+-- annotation.+checkForInjectivityConflicts :: FamInstEnvs -> FamInst -> TcM Bool+checkForInjectivityConflicts instEnvs famInst+    | isTypeFamilyTyCon tycon+    -- type family is injective in at least one argument+    , Injective inj <- familyTyConInjectivityInfo tycon = do+    { let axiom = coAxiomSingleBranch fi_ax+          conflicts = lookupFamInstEnvInjectivityConflicts inj instEnvs famInst+          -- see Note [Verifying injectivity annotation] in FamInstEnv+          errs = makeInjectivityErrors fi_ax axiom inj conflicts+    ; mapM_ (\(err, span) -> setSrcSpan span $ addErr err) errs+    ; return (null errs)+    }++    -- if there was no injectivity annotation or tycon does not represent a+    -- type family we report no conflicts+    | otherwise = return True+    where tycon = famInstTyCon famInst+          fi_ax = fi_axiom famInst++-- | Build a list of injectivity errors together with their source locations.+makeInjectivityErrors+   :: CoAxiom br   -- ^ Type family for which we generate errors+   -> CoAxBranch   -- ^ Currently checked equation (represented by axiom)+   -> [Bool]       -- ^ Injectivity annotation+   -> [CoAxBranch] -- ^ List of injectivity conflicts+   -> [(SDoc, SrcSpan)]+makeInjectivityErrors fi_ax axiom inj conflicts+  = ASSERT2( any id inj, text "No injective type variables" )+    let lhs             = coAxBranchLHS axiom+        rhs             = coAxBranchRHS axiom++        are_conflicts   = not $ null conflicts+        unused_inj_tvs  = unusedInjTvsInRHS (coAxiomTyCon fi_ax) inj lhs rhs+        inj_tvs_unused  = not $ and (isEmptyVarSet <$> unused_inj_tvs)+        tf_headed       = isTFHeaded rhs+        bare_variables  = bareTvInRHSViolated lhs rhs+        wrong_bare_rhs  = not $ null bare_variables++        err_builder herald eqns+                        = ( hang herald+                               2 (vcat (map (pprCoAxBranch fi_ax) eqns))+                          , coAxBranchSpan (head eqns) )+        errorIf p f     = if p then [f err_builder axiom] else []+     in    errorIf are_conflicts  (conflictInjInstErr     conflicts     )+        ++ errorIf inj_tvs_unused (unusedInjectiveVarsErr unused_inj_tvs)+        ++ errorIf tf_headed       tfHeadedErr+        ++ errorIf wrong_bare_rhs (bareVariableInRHSErr   bare_variables)+++-- | Return a list of type variables that the function is injective in and that+-- do not appear on injective positions in the RHS of a family instance+-- declaration. The returned Pair includes invisible vars followed by visible ones+unusedInjTvsInRHS :: TyCon -> [Bool] -> [Type] -> Type -> Pair TyVarSet+-- INVARIANT: [Bool] list contains at least one True value+-- See Note [Verifying injectivity annotation]. This function implements fourth+-- check described there.+-- In theory, instead of implementing this whole check in this way, we could+-- attempt to unify equation with itself.  We would reject exactly the same+-- equations but this method gives us more precise error messages by returning+-- precise names of variables that are not mentioned in the RHS.+unusedInjTvsInRHS tycon injList lhs rhs =+  (`minusVarSet` injRhsVars) <$> injLHSVars+    where+      -- set of type and kind variables in which type family is injective+      (invis_pairs, vis_pairs)+        = partitionInvisibles tycon snd (zipEqual "unusedInjTvsInRHS" injList lhs)+      invis_lhs = uncurry filterByList $ unzip invis_pairs+      vis_lhs   = uncurry filterByList $ unzip vis_pairs++      invis_vars = tyCoVarsOfTypes invis_lhs+      Pair invis_vars' vis_vars = splitVisVarsOfTypes vis_lhs+      injLHSVars+        = Pair (invis_vars `minusVarSet` vis_vars `unionVarSet` invis_vars')+               vis_vars++      -- set of type variables appearing in the RHS on an injective position.+      -- For all returned variables we assume their associated kind variables+      -- also appear in the RHS.+      injRhsVars = injTyVarsOfType rhs++injTyVarsOfType :: TcTauType -> TcTyVarSet+-- Collect all type variables that are either arguments to a type+--   constructor or to /injective/ type families.+-- Determining the overall type determines thes variables+--+-- E.g.   Suppose F is injective in its second arg, but not its first+--        then injVarOfType (Either a (F [b] (a,c))) = {a,c}+--        Determining the overall type determines a,c but not b.+injTyVarsOfType (TyVarTy v)+  = unitVarSet v `unionVarSet` injTyVarsOfType (tyVarKind v)+injTyVarsOfType (TyConApp tc tys)+  | isTypeFamilyTyCon tc+   = case familyTyConInjectivityInfo tc of+        NotInjective  -> emptyVarSet+        Injective inj -> injTyVarsOfTypes (filterByList inj tys)+  | otherwise+  = injTyVarsOfTypes tys+injTyVarsOfType (LitTy {})+  = emptyVarSet+injTyVarsOfType (FunTy arg res)+  = injTyVarsOfType arg `unionVarSet` injTyVarsOfType res+injTyVarsOfType (AppTy fun arg)+  = injTyVarsOfType fun `unionVarSet` injTyVarsOfType arg+-- No forall types in the RHS of a type family+injTyVarsOfType (CastTy ty _)   = injTyVarsOfType ty+injTyVarsOfType (CoercionTy {}) = emptyVarSet+injTyVarsOfType (ForAllTy {})    =+    panic "unusedInjTvsInRHS.injTyVarsOfType"++injTyVarsOfTypes :: [Type] -> VarSet+injTyVarsOfTypes tys = mapUnionVarSet injTyVarsOfType tys++-- | Is type headed by a type family application?+isTFHeaded :: Type -> Bool+-- See Note [Verifying injectivity annotation]. This function implements third+-- check described there.+isTFHeaded ty | Just ty' <- coreView ty+              = isTFHeaded ty'+isTFHeaded ty | (TyConApp tc args) <- ty+              , isTypeFamilyTyCon tc+              = tyConArity tc == length args+isTFHeaded _  = False+++-- | If a RHS is a bare type variable return a set of LHS patterns that are not+-- bare type variables.+bareTvInRHSViolated :: [Type] -> Type -> [Type]+-- See Note [Verifying injectivity annotation]. This function implements second+-- check described there.+bareTvInRHSViolated pats rhs | isTyVarTy rhs+   = filter (not . isTyVarTy) pats+bareTvInRHSViolated _ _ = []+++conflictInstErr :: FamInst -> [FamInstMatch] -> TcRn ()+conflictInstErr fam_inst conflictingMatch+  | (FamInstMatch { fim_instance = confInst }) : _ <- conflictingMatch+  = let (err, span) = makeFamInstsErr+                            (text "Conflicting family instance declarations:")+                            [fam_inst, confInst]+    in setSrcSpan span $ addErr err+  | otherwise+  = panic "conflictInstErr"++-- | Type of functions that use error message and a list of axioms to build full+-- error message (with a source location) for injective type families.+type InjErrorBuilder = SDoc -> [CoAxBranch] -> (SDoc, SrcSpan)++-- | Build injecivity error herald common to all injectivity errors.+injectivityErrorHerald :: Bool -> SDoc+injectivityErrorHerald isSingular =+  text "Type family equation" <> s isSingular <+> text "violate" <>+  s (not isSingular) <+> text "injectivity annotation" <>+  if isSingular then dot else colon+  -- Above is an ugly hack.  We want this: "sentence. herald:" (note the dot and+  -- colon).  But if herald is empty we want "sentence:" (note the colon).  We+  -- can't test herald for emptiness so we rely on the fact that herald is empty+  -- only when isSingular is False.  If herald is non empty it must end with a+  -- colon.+    where+      s False = text "s"+      s True  = empty++-- | Build error message for a pair of equations violating an injectivity+-- annotation.+conflictInjInstErr :: [CoAxBranch] -> InjErrorBuilder -> CoAxBranch+                   -> (SDoc, SrcSpan)+conflictInjInstErr conflictingEqns errorBuilder tyfamEqn+  | confEqn : _ <- conflictingEqns+  = errorBuilder (injectivityErrorHerald False) [confEqn, tyfamEqn]+  | otherwise+  = panic "conflictInjInstErr"++-- | Build error message for equation with injective type variables unused in+-- the RHS.+unusedInjectiveVarsErr :: Pair TyVarSet -> InjErrorBuilder -> CoAxBranch+                       -> (SDoc, SrcSpan)+unusedInjectiveVarsErr (Pair invis_vars vis_vars) errorBuilder tyfamEqn+  = errorBuilder (injectivityErrorHerald True $$ msg)+                 [tyfamEqn]+    where+      tvs = invis_vars `unionVarSet` vis_vars+      has_types = not $ isEmptyVarSet vis_vars+      has_kinds = not $ isEmptyVarSet invis_vars++      doc = sep [ what <+> text "variable" <>+                  pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . toposortTyVars)+                , text "cannot be inferred from the right-hand side." ]+      what = case (has_types, has_kinds) of+               (True, True)   -> text "Type and kind"+               (True, False)  -> text "Type"+               (False, True)  -> text "Kind"+               (False, False) -> pprPanic "mkUnusedInjectiveVarsErr" $ ppr tvs+      print_kinds_info = ppWhen has_kinds ppSuggestExplicitKinds+      msg = doc $$ print_kinds_info $$+            text "In the type family equation:"++-- | Build error message for equation that has a type family call at the top+-- level of RHS+tfHeadedErr :: InjErrorBuilder -> CoAxBranch+            -> (SDoc, SrcSpan)+tfHeadedErr errorBuilder famInst+  = errorBuilder (injectivityErrorHerald True $$+                  text "RHS of injective type family equation cannot" <+>+                  text "be a type family:") [famInst]++-- | Build error message for equation that has a bare type variable in the RHS+-- but LHS pattern is not a bare type variable.+bareVariableInRHSErr :: [Type] -> InjErrorBuilder -> CoAxBranch+                     -> (SDoc, SrcSpan)+bareVariableInRHSErr tys errorBuilder famInst+  = errorBuilder (injectivityErrorHerald True $$+                  text "RHS of injective type family equation is a bare" <+>+                  text "type variable" $$+                  text "but these LHS type and kind patterns are not bare" <+>+                  text "variables:" <+> pprQuotedList tys) [famInst]+++makeFamInstsErr :: SDoc -> [FamInst] -> (SDoc, SrcSpan)+makeFamInstsErr herald insts+  = ASSERT( not (null insts) )+    ( hang herald+         2 (vcat [ pprCoAxBranchHdr (famInstAxiom fi) 0+                 | fi <- sorted ])+    , srcSpan )+ where+   getSpan = getSrcLoc . famInstAxiom+   sorted  = sortWith getSpan insts+   fi1     = head sorted+   srcSpan = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1))+   -- The sortWith just arranges that instances are dislayed in order+   -- of source location, which reduced wobbling in error messages,+   -- and is better for users++tcGetFamInstEnvs :: TcM FamInstEnvs+-- Gets both the external-package inst-env+-- and the home-pkg inst env (includes module being compiled)+tcGetFamInstEnvs+  = do { eps <- getEps; env <- getGblEnv+       ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) }
+ typecheck/FunDeps.hs view
@@ -0,0 +1,666 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 2000+++FunDeps - functional dependencies++It's better to read it as: "if we know these, then we're going to know these"+-}++{-# LANGUAGE CPP #-}++module FunDeps (+        FunDepEqn(..), pprEquation,+        improveFromInstEnv, improveFromAnother,+        checkInstCoverage, checkFunDeps,+        pprFundeps+    ) where++#include "HsVersions.h"++import Name+import Var+import Class+import Type+import TcType( transSuperClasses )+import CoAxiom( TypeEqn )+import Unify+import FamInst( injTyVarsOfTypes )+import InstEnv+import VarSet+import VarEnv+import Outputable+import ErrUtils( Validity(..), allValid )+import SrcLoc+import Util++import Pair             ( Pair(..) )+import Data.List        ( nubBy )+import Data.Maybe+import Data.Foldable    ( fold )++{-+************************************************************************+*                                                                      *+\subsection{Generate equations from functional dependencies}+*                                                                      *+************************************************************************+++Each functional dependency with one variable in the RHS is responsible+for generating a single equality. For instance:+     class C a b | a -> b+The constraints ([Wanted] C Int Bool) and [Wanted] C Int alpha+will generate the following FunDepEqn+     FDEqn { fd_qtvs = []+           , fd_eqs  = [Pair Bool alpha]+           , fd_pred1 = C Int Bool+           , fd_pred2 = C Int alpha+           , fd_loc = ... }+However notice that a functional dependency may have more than one variable+in the RHS which will create more than one pair of types in fd_eqs. Example:+     class C a b c | a -> b c+     [Wanted] C Int alpha alpha+     [Wanted] C Int Bool beta+Will generate:+     FDEqn { fd_qtvs = []+           , fd_eqs  = [Pair Bool alpha, Pair alpha beta]+           , fd_pred1 = C Int Bool+           , fd_pred2 = C Int alpha+           , fd_loc = ... }++INVARIANT: Corresponding types aren't already equal+That is, there exists at least one non-identity equality in FDEqs.++Assume:+       class C a b c | a -> b c+       instance C Int x x+And:   [Wanted] C Int Bool alpha+We will /match/ the LHS of fundep equations, producing a matching substitution+and create equations for the RHS sides. In our last example we'd have generated:+      ({x}, [fd1,fd2])+where+       fd1 = FDEq 1 Bool x+       fd2 = FDEq 2 alpha x+To ``execute'' the equation, make fresh type variable for each tyvar in the set,+instantiate the two types with these fresh variables, and then unify or generate+a new constraint. In the above example we would generate a new unification+variable 'beta' for x and produce the following constraints:+     [Wanted] (Bool ~ beta)+     [Wanted] (alpha ~ beta)++Notice the subtle difference between the above class declaration and:+       class C a b c | a -> b, a -> c+where we would generate:+      ({x},[fd1]),({x},[fd2])+This means that the template variable would be instantiated to different+unification variables when producing the FD constraints.++Finally, the position parameters will help us rewrite the wanted constraint ``on the spot''+-}++data FunDepEqn loc+  = FDEqn { fd_qtvs :: [TyVar]   -- Instantiate these type and kind vars+                                 --   to fresh unification vars,+                                 -- Non-empty only for FunDepEqns arising from instance decls++          , fd_eqs   :: [TypeEqn]  -- Make these pairs of types equal+          , fd_pred1 :: PredType   -- The FunDepEqn arose from+          , fd_pred2 :: PredType   --  combining these two constraints+          , fd_loc   :: loc  }++{-+Given a bunch of predicates that must hold, such as++        C Int t1, C Int t2, C Bool t3, ?x::t4, ?x::t5++improve figures out what extra equations must hold.+For example, if we have++        class C a b | a->b where ...++then improve will return++        [(t1,t2), (t4,t5)]++NOTA BENE:++  * improve does not iterate.  It's possible that when we make+    t1=t2, for example, that will in turn trigger a new equation.+    This would happen if we also had+        C t1 t7, C t2 t8+    If t1=t2, we also get t7=t8.++    improve does *not* do this extra step.  It relies on the caller+    doing so.++  * The equations unify types that are not already equal.  So there+    is no effect iff the result of improve is empty+-}++instFD :: FunDep TyVar -> [TyVar] -> [Type] -> FunDep Type+-- (instFD fd tvs tys) returns fd instantiated with (tvs -> tys)+instFD (ls,rs) tvs tys+  = (map lookup ls, map lookup rs)+  where+    env       = zipVarEnv tvs tys+    lookup tv = lookupVarEnv_NF env tv++zipAndComputeFDEqs :: (Type -> Type -> Bool) -- Discard this FDEq if true+                   -> [Type] -> [Type]+                   -> [TypeEqn]+-- Create a list of (Type,Type) pairs from two lists of types,+-- making sure that the types are not already equal+zipAndComputeFDEqs discard (ty1:tys1) (ty2:tys2)+ | discard ty1 ty2 = zipAndComputeFDEqs discard tys1 tys2+ | otherwise       = Pair ty1 ty2 : zipAndComputeFDEqs discard tys1 tys2+zipAndComputeFDEqs _ _ _ = []++-- Improve a class constraint from another class constraint+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+improveFromAnother :: loc+                   -> PredType -- Template item (usually given, or inert)+                   -> PredType -- Workitem [that can be improved]+                   -> [FunDepEqn loc]+-- Post: FDEqs always oriented from the other to the workitem+--       Equations have empty quantified variables+improveFromAnother loc pred1 pred2+  | Just (cls1, tys1) <- getClassPredTys_maybe pred1+  , Just (cls2, tys2) <- getClassPredTys_maybe pred2+  , cls1 == cls2+  = [ FDEqn { fd_qtvs = [], fd_eqs = eqs, fd_pred1 = pred1, fd_pred2 = pred2, fd_loc = loc }+    | let (cls_tvs, cls_fds) = classTvsFds cls1+    , fd <- cls_fds+    , let (ltys1, rs1) = instFD fd cls_tvs tys1+          (ltys2, rs2) = instFD fd cls_tvs tys2+    , eqTypes ltys1 ltys2               -- The LHSs match+    , let eqs = zipAndComputeFDEqs eqType rs1 rs2+    , not (null eqs) ]++improveFromAnother _ _ _ = []+++-- Improve a class constraint from instance declarations+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++instance Outputable (FunDepEqn a) where+  ppr = pprEquation++pprEquation :: FunDepEqn a -> SDoc+pprEquation (FDEqn { fd_qtvs = qtvs, fd_eqs = pairs })+  = vcat [text "forall" <+> braces (pprWithCommas ppr qtvs),+          nest 2 (vcat [ ppr t1 <+> text "~" <+> ppr t2+                       | Pair t1 t2 <- pairs])]++improveFromInstEnv :: InstEnvs+                   -> (PredType -> SrcSpan -> loc)+                   -> PredType+                   -> [FunDepEqn loc] -- Needs to be a FunDepEqn because+                                      -- of quantified variables+-- Post: Equations oriented from the template (matching instance) to the workitem!+improveFromInstEnv inst_env mk_loc pred+  | Just (cls, tys) <- ASSERT2( isClassPred pred, ppr pred )+                       getClassPredTys_maybe pred+  , let (cls_tvs, cls_fds) = classTvsFds cls+        instances          = classInstances inst_env cls+        rough_tcs          = roughMatchTcs tys+  = [ FDEqn { fd_qtvs = meta_tvs, fd_eqs = eqs+            , fd_pred1 = p_inst, fd_pred2 = pred+            , fd_loc = mk_loc p_inst (getSrcSpan (is_dfun ispec)) }+    | fd <- cls_fds             -- Iterate through the fundeps first,+                                -- because there often are none!+    , let trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs+                -- Trim the rough_tcs based on the head of the fundep.+                -- Remember that instanceCantMatch treats both arguments+                -- symmetrically, so it's ok to trim the rough_tcs,+                -- rather than trimming each inst_tcs in turn+    , ispec <- instances+    , (meta_tvs, eqs) <- improveClsFD cls_tvs fd ispec+                                      tys trimmed_tcs -- NB: orientation+    , let p_inst = mkClassPred cls (is_tys ispec)+    ]+improveFromInstEnv _ _ _ = []+++improveClsFD :: [TyVar] -> FunDep TyVar    -- One functional dependency from the class+             -> ClsInst                    -- An instance template+             -> [Type] -> [Maybe Name]     -- Arguments of this (C tys) predicate+             -> [([TyCoVar], [TypeEqn])]   -- Empty or singleton++improveClsFD clas_tvs fd+             (ClsInst { is_tvs = qtvs, is_tys = tys_inst, is_tcs = rough_tcs_inst })+             tys_actual rough_tcs_actual++-- Compare instance      {a,b}    C sx sp sy sq+--         with wanted     [W] C tx tp ty tq+--         for fundep (x,y -> p,q)  from class  (C x p y q)+-- If (sx,sy) unifies with (tx,ty), take the subst S++-- 'qtvs' are the quantified type variables, the ones which an be instantiated+-- to make the types match.  For example, given+--      class C a b | a->b where ...+--      instance C (Maybe x) (Tree x) where ..+--+-- and a wanted constraint of form (C (Maybe t1) t2),+-- then we will call checkClsFD with+--+--      is_qtvs = {x}, is_tys = [Maybe x,  Tree x]+--                     tys_actual = [Maybe t1, t2]+--+-- We can instantiate x to t1, and then we want to force+--      (Tree x) [t1/x]  ~   t2++  | instanceCantMatch rough_tcs_inst rough_tcs_actual+  = []          -- Filter out ones that can't possibly match,++  | otherwise+  = ASSERT2( length tys_inst == length tys_actual     &&+             length tys_inst == length clas_tvs+            , ppr tys_inst <+> ppr tys_actual )++    case tcMatchTyKis ltys1 ltys2 of+        Nothing  -> []+        Just subst | isJust (tcMatchTyKisX subst rtys1 rtys2)+                        -- Don't include any equations that already hold.+                        -- Reason: then we know if any actual improvement has happened,+                        --         in which case we need to iterate the solver+                        -- In making this check we must taking account of the fact that any+                        -- qtvs that aren't already instantiated can be instantiated to anything+                        -- at all+                        -- NB: We can't do this 'is-useful-equation' check element-wise+                        --     because of:+                        --           class C a b c | a -> b c+                        --           instance C Int x x+                        --           [Wanted] C Int alpha Int+                        -- We would get that  x -> alpha  (isJust) and x -> Int (isJust)+                        -- so we would produce no FDs, which is clearly wrong.+                  -> []++                  | null fdeqs+                  -> []++                  | otherwise+                  -> [(meta_tvs, fdeqs)]+                        -- We could avoid this substTy stuff by producing the eqn+                        -- (qtvs, ls1++rs1, ls2++rs2)+                        -- which will re-do the ls1/ls2 unification when the equation is+                        -- executed.  What we're doing instead is recording the partial+                        -- work of the ls1/ls2 unification leaving a smaller unification problem+                  where+                    rtys1' = map (substTyUnchecked subst) rtys1++                    fdeqs = zipAndComputeFDEqs (\_ _ -> False) rtys1' rtys2+                        -- Don't discard anything!+                        -- We could discard equal types but it's an overkill to call+                        -- eqType again, since we know for sure that /at least one/+                        -- equation in there is useful)++                    meta_tvs = [ setVarType tv (substTyUnchecked subst (varType tv))+                               | tv <- qtvs, tv `notElemTCvSubst` subst ]+                        -- meta_tvs are the quantified type variables+                        -- that have not been substituted out+                        --+                        -- Eg.  class C a b | a -> b+                        --      instance C Int [y]+                        -- Given constraint C Int z+                        -- we generate the equation+                        --      ({y}, [y], z)+                        --+                        -- But note (a) we get them from the dfun_id, so they are *in order*+                        --              because the kind variables may be mentioned in the+                        --              type variabes' kinds+                        --          (b) we must apply 'subst' to the kinds, in case we have+                        --              matched out a kind variable, but not a type variable+                        --              whose kind mentions that kind variable!+                        --          Trac #6015, #6068+  where+    (ltys1, rtys1) = instFD fd clas_tvs tys_inst+    (ltys2, rtys2) = instFD fd clas_tvs tys_actual++{-+%************************************************************************+%*                                                                      *+        The Coverage condition for instance declarations+*                                                                      *+************************************************************************++Note [Coverage condition]+~~~~~~~~~~~~~~~~~~~~~~~~~+Example+      class C a b | a -> b+      instance theta => C t1 t2++For the coverage condition, we check+   (normal)    fv(t2) `subset` fv(t1)+   (liberal)   fv(t2) `subset` oclose(fv(t1), theta)++The liberal version  ensures the self-consistency of the instance, but+it does not guarantee termination. Example:++   class Mul a b c | a b -> c where+        (.*.) :: a -> b -> c++   instance Mul Int Int Int where (.*.) = (*)+   instance Mul Int Float Float where x .*. y = fromIntegral x * y+   instance Mul a b c => Mul a [b] [c] where x .*. v = map (x.*.) v++In the third instance, it's not the case that fv([c]) `subset` fv(a,[b]).+But it is the case that fv([c]) `subset` oclose( theta, fv(a,[b]) )++But it is a mistake to accept the instance because then this defn:+        f = \ b x y -> if b then x .*. [y] else y+makes instance inference go into a loop, because it requires the constraint+        Mul a [b] b+-}++checkInstCoverage :: Bool   -- Be liberal+                  -> Class -> [PredType] -> [Type]+                  -> Validity+-- "be_liberal" flag says whether to use "liberal" coverage of+--              See Note [Coverage Condition] below+--+-- Return values+--    Nothing  => no problems+--    Just msg => coverage problem described by msg++checkInstCoverage be_liberal clas theta inst_taus+  = allValid (map fundep_ok fds)+  where+    (tyvars, fds) = classTvsFds clas+    fundep_ok fd+       | and (isEmptyVarSet <$> undetermined_tvs) = IsValid+       | otherwise                                = NotValid msg+       where+         (ls,rs) = instFD fd tyvars inst_taus+         ls_tvs = tyCoVarsOfTypes ls+         rs_tvs = splitVisVarsOfTypes rs++         undetermined_tvs | be_liberal = liberal_undet_tvs+                          | otherwise  = conserv_undet_tvs++         closed_ls_tvs = oclose theta ls_tvs+         liberal_undet_tvs = (`minusVarSet` closed_ls_tvs) <$> rs_tvs+         conserv_undet_tvs = (`minusVarSet` ls_tvs)        <$> rs_tvs++         undet_set = fold undetermined_tvs++         msg = vcat [ -- text "ls_tvs" <+> ppr ls_tvs+                      -- , text "closed ls_tvs" <+> ppr (closeOverKinds ls_tvs)+                      -- , text "theta" <+> ppr theta+                      -- , text "oclose" <+> ppr (oclose theta (closeOverKinds ls_tvs))+                      -- , text "rs_tvs" <+> ppr rs_tvs+                      sep [ text "The"+                            <+> ppWhen be_liberal (text "liberal")+                            <+> text "coverage condition fails in class"+                            <+> quotes (ppr clas)+                          , nest 2 $ text "for functional dependency:"+                            <+> quotes (pprFunDep fd) ]+                    , sep [ text "Reason: lhs type"<>plural ls <+> pprQuotedList ls+                          , nest 2 $+                            (if isSingleton ls+                             then text "does not"+                             else text "do not jointly")+                            <+> text "determine rhs type"<>plural rs+                            <+> pprQuotedList rs ]+                    , text "Un-determined variable" <> pluralVarSet undet_set <> colon+                            <+> pprVarSet undet_set (pprWithCommas ppr)+                    , ppWhen (isEmptyVarSet $ pSnd undetermined_tvs) $+                      ppSuggestExplicitKinds+                    , ppWhen (not be_liberal &&+                              and (isEmptyVarSet <$> liberal_undet_tvs)) $+                      text "Using UndecidableInstances might help" ]++{- Note [Closing over kinds in coverage]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have a fundep  (a::k) -> b+Then if 'a' is instantiated to (x y), where x:k2->*, y:k2,+then fixing x really fixes k2 as well, and so k2 should be added to+the lhs tyvars in the fundep check.++Example (Trac #8391), using liberal coverage+      data Foo a = ...  -- Foo :: forall k. k -> *+      class Bar a b | a -> b+      instance Bar a (Foo a)++    In the instance decl, (a:k) does fix (Foo k a), but only if we notice+    that (a:k) fixes k.  Trac #10109 is another example.++Here is a more subtle example, from HList-0.4.0.0 (Trac #10564)++  class HasFieldM (l :: k) r (v :: Maybe *)+        | l r -> v where ...+  class HasFieldM1 (b :: Maybe [*]) (l :: k) r v+        | b l r -> v where ...+  class HMemberM (e1 :: k) (l :: [k]) (r :: Maybe [k])+        | e1 l -> r++  data Label :: k -> *+  type family LabelsOf (a :: [*]) ::  *++  instance (HMemberM (Label {k} (l::k)) (LabelsOf xs) b,+            HasFieldM1 b l (r xs) v)+         => HasFieldM l (r xs) v where++Is the instance OK? Does {l,r,xs} determine v?  Well:++  * From the instance constraint HMemberM (Label k l) (LabelsOf xs) b,+    plus the fundep "| el l -> r" in class HMameberM,+    we get {l,k,xs} -> b++  * Note the 'k'!! We must call closeOverKinds on the seed set+    ls_tvs = {l,r,xs}, BEFORE doing oclose, else the {l,k,xs}->b+    fundep won't fire.  This was the reason for #10564.++  * So starting from seeds {l,r,xs,k} we do oclose to get+    first {l,r,xs,k,b}, via the HMemberM constraint, and then+    {l,r,xs,k,b,v}, via the HasFieldM1 constraint.++  * And that fixes v.++However, we must closeOverKinds whenever augmenting the seed set+in oclose!  Consider Trac #10109:++  data Succ a   -- Succ :: forall k. k -> *+  class Add (a :: k1) (b :: k2) (ab :: k3) | a b -> ab+  instance (Add a b ab) => Add (Succ {k1} (a :: k1))+                               b+                               (Succ {k3} (ab :: k3})++We start with seed set {a:k1,b:k2} and closeOverKinds to {a,k1,b,k2}.+Now use the fundep to extend to {a,k1,b,k2,ab}.  But we need to+closeOverKinds *again* now to {a,k1,b,k2,ab,k3}, so that we fix all+the variables free in (Succ {k3} ab).++Bottom line:+  * closeOverKinds on initial seeds (done automatically+    by tyCoVarsOfTypes in checkInstCoverage)+  * and closeOverKinds whenever extending those seeds (in oclose)++Note [The liberal coverage condition]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(oclose preds tvs) closes the set of type variables tvs,+wrt functional dependencies in preds.  The result is a superset+of the argument set.  For example, if we have+        class C a b | a->b where ...+then+        oclose [C (x,y) z, C (x,p) q] {x,y} = {x,y,z}+because if we know x and y then that fixes z.++We also use equality predicates in the predicates; if we have an+assumption `t1 ~ t2`, then we use the fact that if we know `t1` we+also know `t2` and the other way.+  eg    oclose [C (x,y) z, a ~ x] {a,y} = {a,y,z,x}++oclose is used (only) when checking the coverage condition for+an instance declaration++Note [Equality superclasses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+  class (a ~ [b]) => C a b++Remember from Note [The equality types story] in TysPrim, that+  * (a ~~ b) is a superclass of (a ~ b)+  * (a ~# b) is a superclass of (a ~~ b)++So when oclose expands superclasses we'll get a (a ~# [b]) superclass.+But that's an EqPred not a ClassPred, and we jolly well do want to+account for the mutual functional dependencies implied by (t1 ~# t2).+Hence the EqPred handling in oclose.  See Trac #10778.++Note [Care with type functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (Trac #12803)+  class C x y | x -> y+  type family F a b+  type family G c d = r | r -> d++Now consider+  oclose (C (F a b) (G c d)) {a,b}++Knowing {a,b} fixes (F a b) regardless of the injectivity of F.+But knowing (G c d) fixes only {d}, because G is only injective+in its second parameter.++Hence the tyCoVarsOfTypes/injTyVarsOfTypes dance in tv_fds.+-}++oclose :: [PredType] -> TyCoVarSet -> TyCoVarSet+-- See Note [The liberal coverage condition]+oclose preds fixed_tvs+  | null tv_fds = fixed_tvs -- Fast escape hatch for common case.+  | otherwise   = fixVarSet extend fixed_tvs+  where+    extend fixed_tvs = foldl add fixed_tvs tv_fds+       where+          add fixed_tvs (ls,rs)+            | ls `subVarSet` fixed_tvs = fixed_tvs `unionVarSet` closeOverKinds rs+            | otherwise                = fixed_tvs+            -- closeOverKinds: see Note [Closing over kinds in coverage]++    tv_fds  :: [(TyCoVarSet,TyCoVarSet)]+    tv_fds  = [ (tyCoVarsOfTypes ls, injTyVarsOfTypes rs)+                  -- See Note [Care with type functions]+              | pred <- preds+              , pred' <- pred : transSuperClasses pred+                   -- Look for fundeps in superclasses too+              , (ls, rs) <- determined pred' ]++    determined :: PredType -> [([Type],[Type])]+    determined pred+       = case classifyPredType pred of+            EqPred NomEq t1 t2 -> [([t1],[t2]), ([t2],[t1])]+               -- See Note [Equality superclasses]+            ClassPred cls tys  -> [ instFD fd cls_tvs tys+                                  | let (cls_tvs, cls_fds) = classTvsFds cls+                                  , fd <- cls_fds ]+            _ -> []+++{- *********************************************************************+*                                                                      *+        Check that a new instance decl is OK wrt fundeps+*                                                                      *+************************************************************************++Here is the bad case:+        class C a b | a->b where ...+        instance C Int Bool where ...+        instance C Int Char where ...++The point is that a->b, so Int in the first parameter must uniquely+determine the second.  In general, given the same class decl, and given++        instance C s1 s2 where ...+        instance C t1 t2 where ...++Then the criterion is: if U=unify(s1,t1) then U(s2) = U(t2).++Matters are a little more complicated if there are free variables in+the s2/t2.++        class D a b c | a -> b+        instance D a b => D [(a,a)] [b] Int+        instance D a b => D [a]     [b] Bool++The instance decls don't overlap, because the third parameter keeps+them separate.  But we want to make sure that given any constraint+        D s1 s2 s3+if s1 matches++Note [Bogus consistency check]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In checkFunDeps we check that a new ClsInst is consistent with all the+ClsInsts in the environment.++The bogus aspect is discussed in Trac #10675. Currenty it if the two+types are *contradicatory*, using (isNothing . tcUnifyTys).  But all+the papers say we should check if the two types are *equal* thus+   not (substTys subst rtys1 `eqTypes` substTys subst rtys2)+For now I'm leaving the bogus form because that's the way it has+been for years.+-}++checkFunDeps :: InstEnvs -> ClsInst -> [ClsInst]+-- The Consistency Check.+-- Check whether adding DFunId would break functional-dependency constraints+-- Used only for instance decls defined in the module being compiled+-- Returns a list of the ClsInst in InstEnvs that are inconsistent+-- with the proposed new ClsInst+checkFunDeps inst_envs (ClsInst { is_tvs = qtvs1, is_cls = cls+                                , is_tys = tys1, is_tcs = rough_tcs1 })+  | null fds+  = []+  | otherwise+  = nubBy eq_inst $+    [ ispec | ispec <- cls_insts+            , fd    <- fds+            , is_inconsistent fd ispec ]+  where+    cls_insts      = classInstances inst_envs cls+    (cls_tvs, fds) = classTvsFds cls+    qtv_set1       = mkVarSet qtvs1++    is_inconsistent fd (ClsInst { is_tvs = qtvs2, is_tys = tys2, is_tcs = rough_tcs2 })+      | instanceCantMatch trimmed_tcs rough_tcs2+      = False+      | otherwise+      = case tcUnifyTyKis bind_fn ltys1 ltys2 of+          Nothing         -> False+          Just subst+            -> isNothing $   -- Bogus legacy test (Trac #10675)+                             -- See Note [Bogus consistency check]+               tcUnifyTyKis bind_fn (substTysUnchecked subst rtys1) (substTysUnchecked subst rtys2)++      where+        trimmed_tcs    = trimRoughMatchTcs cls_tvs fd rough_tcs1+        (ltys1, rtys1) = instFD fd cls_tvs tys1+        (ltys2, rtys2) = instFD fd cls_tvs tys2+        qtv_set2       = mkVarSet qtvs2+        bind_fn tv | tv `elemVarSet` qtv_set1 = BindMe+                   | tv `elemVarSet` qtv_set2 = BindMe+                   | otherwise                = Skolem++    eq_inst i1 i2 = instanceDFunId i1 == instanceDFunId i2+        -- An single instance may appear twice in the un-nubbed conflict list+        -- because it may conflict with more than one fundep.  E.g.+        --      class C a b c | a -> b, a -> c+        --      instance C Int Bool Bool+        --      instance C Int Char Char+        -- The second instance conflicts with the first by *both* fundeps++trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [Maybe Name] -> [Maybe Name]+-- Computing rough_tcs for a particular fundep+--     class C a b c | a -> b where ...+-- For each instance .... => C ta tb tc+-- we want to match only on the type ta; so our+-- rough-match thing must similarly be filtered.+-- Hence, we Nothing-ise the tb and tc types right here+--+-- Result list is same length as input list, just with more Nothings+trimRoughMatchTcs clas_tvs (ltvs, _) mb_tcs+  = zipWith select clas_tvs mb_tcs+  where+    select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc+                         | otherwise           = Nothing
+ typecheck/Inst.hs view
@@ -0,0 +1,830 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++The @Inst@ type: dictionaries or method instances+-}++{-# LANGUAGE CPP, MultiWayIf, TupleSections #-}++module Inst (+       deeplySkolemise,+       topInstantiate, topInstantiateInferred, deeplyInstantiate,+       instCall, instDFunType, instStupidTheta,+       newWanted, newWanteds,++       tcInstBinders, tcInstBindersX, tcInstBinderX,++       newOverloadedLit, mkOverLit,++       newClsInst,+       tcGetInsts, tcGetInstEnvs, getOverlapFlag,+       tcExtendLocalInstEnv,+       instCallConstraints, newMethodFromName,+       tcSyntaxName,++       -- Simple functions over evidence variables+       tyCoVarsOfWC,+       tyCoVarsOfCt, tyCoVarsOfCts,+    ) where++#include "HsVersions.h"++import {-# SOURCE #-}   TcExpr( tcPolyExpr, tcSyntaxOp )+import {-# SOURCE #-}   TcUnify( unifyType, unifyKind, noThing )++import BasicTypes ( SourceText(..) )+import FastString+import HsSyn+import TcHsSyn+import TcRnMonad+import TcEnv+import TcEvidence+import InstEnv+import TysWiredIn  ( heqDataCon, coercibleDataCon )+import CoreSyn     ( isOrphan )+import FunDeps+import TcMType+import Type+import TyCoRep     ( TyBinder(..) )+import TcType+import HscTypes+import Class( Class )+import MkId( mkDictFunId )+import Id+import Name+import Var      ( EvVar, mkTyVar, tyVarName, TyVarBndr(..) )+import DataCon+import TyCon+import VarEnv+import PrelNames+import SrcLoc+import DynFlags+import Util+import Outputable+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad( unless )++{-+************************************************************************+*                                                                      *+                Creating and emittind constraints+*                                                                      *+************************************************************************+-}++newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId)+-- Used when Name is the wired-in name for a wired-in class method,+-- so the caller knows its type for sure, which should be of form+--    forall a. C a => <blah>+-- newMethodFromName is supposed to instantiate just the outer+-- type variable and constraint++newMethodFromName origin name inst_ty+  = do { id <- tcLookupId name+              -- Use tcLookupId not tcLookupGlobalId; the method is almost+              -- always a class op, but with -XRebindableSyntax GHC is+              -- meant to find whatever thing is in scope, and that may+              -- be an ordinary function.++       ; let ty = piResultTy (idType id) inst_ty+             (theta, _caller_knows_this) = tcSplitPhiTy ty+       ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta )+                 instCall origin [inst_ty] theta++       ; return (mkHsWrap wrap (HsVar (noLoc id))) }++{-+************************************************************************+*                                                                      *+        Deep instantiation and skolemisation+*                                                                      *+************************************************************************++Note [Deep skolemisation]+~~~~~~~~~~~~~~~~~~~~~~~~~+deeplySkolemise decomposes and skolemises a type, returning a type+with all its arrows visible (ie not buried under foralls)++Examples:++  deeplySkolemise (Int -> forall a. Ord a => blah)+    =  ( wp, [a], [d:Ord a], Int -> blah )+    where wp = \x:Int. /\a. \(d:Ord a). <hole> x++  deeplySkolemise  (forall a. Ord a => Maybe a -> forall b. Eq b => blah)+    =  ( wp, [a,b], [d1:Ord a,d2:Eq b], Maybe a -> blah )+    where wp = /\a.\(d1:Ord a).\(x:Maybe a)./\b.\(d2:Ord b). <hole> x++In general,+  if      deeplySkolemise ty = (wrap, tvs, evs, rho)+    and   e :: rho+  then    wrap e :: ty+    and   'wrap' binds tvs, evs++ToDo: this eta-abstraction plays fast and loose with termination,+      because it can introduce extra lambdas.  Maybe add a `seq` to+      fix this+-}++deeplySkolemise :: TcSigmaType+                -> TcM ( HsWrapper+                       , [(Name,TyVar)]     -- All skolemised variables+                       , [EvVar]            -- All "given"s+                       , TcRhoType )++deeplySkolemise ty+  = go init_subst ty+  where+    init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))++    go subst ty+      | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty+      = do { let arg_tys' = substTys subst arg_tys+           ; ids1           <- newSysLocalIds (fsLit "dk") arg_tys'+           ; (subst', tvs1) <- tcInstSkolTyVarsX subst tvs+           ; ev_vars1       <- newEvVars (substTheta subst' theta)+           ; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty'+           ; let tv_prs1 = map tyVarName tvs `zip` tvs1+           ; return ( mkWpLams ids1+                      <.> mkWpTyLams tvs1+                      <.> mkWpLams ev_vars1+                      <.> wrap+                      <.> mkWpEvVarApps ids1+                    , tv_prs1  ++ tvs_prs2+                    , ev_vars1 ++ ev_vars2+                    , mkFunTys arg_tys' rho ) }++      | otherwise+      = return (idHsWrapper, [], [], substTy subst ty)+        -- substTy is a quick no-op on an empty substitution++-- | Instantiate all outer type variables+-- and any context. Never looks through arrows.+topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)+-- if    topInstantiate ty = (wrap, rho)+-- and   e :: ty+-- then  wrap e :: rho  (that is, wrap :: ty "->" rho)+topInstantiate = top_instantiate True++-- | Instantiate all outer 'Inferred' binders+-- and any context. Never looks through arrows or specified type variables.+-- Used for visible type application.+topInstantiateInferred :: CtOrigin -> TcSigmaType+                       -> TcM (HsWrapper, TcSigmaType)+-- if    topInstantiate ty = (wrap, rho)+-- and   e :: ty+-- then  wrap e :: rho+topInstantiateInferred = top_instantiate False++top_instantiate :: Bool   -- True  <=> instantiate *all* variables+                          -- False <=> instantiate only the inferred ones+                -> CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)+top_instantiate inst_all orig ty+  | not (null binders && null theta)+  = do { let (inst_bndrs, leave_bndrs) = span should_inst binders+             (inst_theta, leave_theta)+               | null leave_bndrs = (theta, [])+               | otherwise        = ([], theta)+             in_scope    = mkInScopeSet (tyCoVarsOfType ty)+             empty_subst = mkEmptyTCvSubst in_scope+             inst_tvs    = binderVars inst_bndrs+       ; (subst, inst_tvs') <- mapAccumLM newMetaTyVarX empty_subst inst_tvs+       ; let inst_theta' = substTheta subst inst_theta+             sigma'      = substTy subst (mkForAllTys leave_bndrs $+                                          mkFunTys leave_theta rho)++       ; wrap1 <- instCall orig (mkTyVarTys inst_tvs') inst_theta'+       ; traceTc "Instantiating"+                 (vcat [ text "all tyvars?" <+> ppr inst_all+                       , text "origin" <+> pprCtOrigin orig+                       , text "type" <+> ppr ty+                       , text "theta" <+> ppr theta+                       , text "leave_bndrs" <+> ppr leave_bndrs+                       , text "with" <+> ppr inst_tvs'+                       , text "theta:" <+>  ppr inst_theta' ])++       ; (wrap2, rho2) <-+           if null leave_bndrs++         -- account for types like forall a. Num a => forall b. Ord b => ...+           then top_instantiate inst_all orig sigma'++         -- but don't loop if there were any un-inst'able tyvars+           else return (idHsWrapper, sigma')++       ; return (wrap2 <.> wrap1, rho2) }++  | otherwise = return (idHsWrapper, ty)+  where+    (binders, phi) = tcSplitForAllTyVarBndrs ty+    (theta, rho)   = tcSplitPhiTy phi++    should_inst bndr+      | inst_all  = True+      | otherwise = binderArgFlag bndr == Inferred++deeplyInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)+--   Int -> forall a. a -> a  ==>  (\x:Int. [] x alpha) :: Int -> alpha+-- In general if+-- if    deeplyInstantiate ty = (wrap, rho)+-- and   e :: ty+-- then  wrap e :: rho+-- That is, wrap :: ty ~> rho+--+-- If you don't need the HsWrapper returned from this function, consider+-- using tcSplitNestedSigmaTys in TcType, which is a pure alternative that+-- only computes the returned TcRhoType.++deeplyInstantiate orig ty =+  deeply_instantiate orig+                     (mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)))+                     ty++deeply_instantiate :: CtOrigin+                   -> TCvSubst+                   -> TcSigmaType -> TcM (HsWrapper, TcRhoType)+-- Internal function to deeply instantiate that builds on an existing subst.+-- It extends the input substitution and applies the final subtitution to+-- the types on return.  See #12549.++deeply_instantiate orig subst ty+  | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty+  = do { (subst', tvs') <- newMetaTyVarsX subst tvs+       ; ids1  <- newSysLocalIds (fsLit "di") (substTys subst' arg_tys)+       ; let theta' = substTheta subst' theta+       ; wrap1 <- instCall orig (mkTyVarTys tvs') theta'+       ; traceTc "Instantiating (deeply)" (vcat [ text "origin" <+> pprCtOrigin orig+                                                , text "type" <+> ppr ty+                                                , text "with" <+> ppr tvs'+                                                , text "args:" <+> ppr ids1+                                                , text "theta:" <+>  ppr theta'+                                                , text "subst:" <+> ppr subst'])+       ; (wrap2, rho2) <- deeply_instantiate orig subst' rho+       ; return (mkWpLams ids1+                    <.> wrap2+                    <.> wrap1+                    <.> mkWpEvVarApps ids1,+                 mkFunTys arg_tys rho2) }++  | otherwise+  = do { let ty' = substTy subst ty+       ; traceTc "deeply_instantiate final subst"+                 (vcat [ text "origin:"   <+> pprCtOrigin orig+                       , text "type:"     <+> ppr ty+                       , text "new type:" <+> ppr ty'+                       , text "subst:"    <+> ppr subst ])+      ; return (idHsWrapper, ty') }++{-+************************************************************************+*                                                                      *+            Instantiating a call+*                                                                      *+************************************************************************++Note [Handling boxed equality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The solver deals entirely in terms of unboxed (primitive) equality.+There should never be a boxed Wanted equality. Ever. But, what if+we are calling `foo :: forall a. (F a ~ Bool) => ...`? That equality+is boxed, so naive treatment here would emit a boxed Wanted equality.++So we simply check for this case and make the right boxing of evidence.++-}++----------------+instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper+-- Instantiate the constraints of a call+--      (instCall o tys theta)+-- (a) Makes fresh dictionaries as necessary for the constraints (theta)+-- (b) Throws these dictionaries into the LIE+-- (c) Returns an HsWrapper ([.] tys dicts)++instCall orig tys theta+  = do  { dict_app <- instCallConstraints orig theta+        ; return (dict_app <.> mkWpTyApps tys) }++----------------+instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper+-- Instantiates the TcTheta, puts all constraints thereby generated+-- into the LIE, and returns a HsWrapper to enclose the call site.++instCallConstraints orig preds+  | null preds+  = return idHsWrapper+  | otherwise+  = do { evs <- mapM go preds+       ; traceTc "instCallConstraints" (ppr evs)+       ; return (mkWpEvApps evs) }+  where+    go pred+     | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1+     = do  { co <- unifyType noThing ty1 ty2+           ; return (EvCoercion co) }++       -- Try short-cut #2+     | Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred+     , tc `hasKey` heqTyConKey+     = do { co <- unifyType noThing ty1 ty2+          ; return (EvDFunApp (dataConWrapId heqDataCon) args [EvCoercion co]) }++     | otherwise+     = emitWanted orig pred++instDFunType :: DFunId -> [DFunInstType]+             -> TcM ( [TcType]      -- instantiated argument types+                    , TcThetaType ) -- instantiated constraint+-- See Note [DFunInstType: instantiating types] in InstEnv+instDFunType dfun_id dfun_inst_tys+  = do { (subst, inst_tys) <- go emptyTCvSubst dfun_tvs dfun_inst_tys+       ; return (inst_tys, substTheta subst dfun_theta) }+  where+    (dfun_tvs, dfun_theta, _) = tcSplitSigmaTy (idType dfun_id)++    go :: TCvSubst -> [TyVar] -> [DFunInstType] -> TcM (TCvSubst, [TcType])+    go subst [] [] = return (subst, [])+    go subst (tv:tvs) (Just ty : mb_tys)+      = do { (subst', tys) <- go (extendTvSubstAndInScope subst tv ty)+                                 tvs+                                 mb_tys+           ; return (subst', ty : tys) }+    go subst (tv:tvs) (Nothing : mb_tys)+      = do { (subst', tv') <- newMetaTyVarX subst tv+           ; (subst'', tys) <- go subst' tvs mb_tys+           ; return (subst'', mkTyVarTy tv' : tys) }+    go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr dfun_inst_tys)++----------------+instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()+-- Similar to instCall, but only emit the constraints in the LIE+-- Used exclusively for the 'stupid theta' of a data constructor+instStupidTheta orig theta+  = do  { _co <- instCallConstraints orig theta -- Discard the coercion+        ; return () }++{-+************************************************************************+*                                                                      *+         Instantiating Kinds+*                                                                      *+************************************************************************++-}++---------------------------+-- | This is used to instantiate binders when type-checking *types* only.+-- See also Note [Bidirectional type checking]+tcInstBinders :: [TyBinder] -> TcM (TCvSubst, [TcType])+tcInstBinders = tcInstBindersX emptyTCvSubst Nothing++-- | This is used to instantiate binders when type-checking *types* only.+-- The @VarEnv Kind@ gives some known instantiations.+-- See also Note [Bidirectional type checking]+tcInstBindersX :: TCvSubst -> Maybe (VarEnv Kind)+               -> [TyBinder] -> TcM (TCvSubst, [TcType])+tcInstBindersX subst mb_kind_info bndrs+  = do { (subst, args) <- mapAccumLM (tcInstBinderX mb_kind_info) subst bndrs+       ; traceTc "instantiating tybinders:"+           (vcat $ zipWith (\bndr arg -> ppr bndr <+> text ":=" <+> ppr arg)+                           bndrs args)+       ; return (subst, args) }++-- | Used only in *types*+tcInstBinderX :: Maybe (VarEnv Kind)+              -> TCvSubst -> TyBinder -> TcM (TCvSubst, TcType)+tcInstBinderX mb_kind_info subst (Named (TvBndr tv _))+  = case lookup_tv tv of+      Just ki -> return (extendTvSubstAndInScope subst tv ki, ki)+      Nothing -> do { (subst', tv') <- newMetaTyVarX subst tv+                    ; return (subst', mkTyVarTy tv') }+  where+    lookup_tv tv = do { env <- mb_kind_info   -- `Maybe` monad+                      ; lookupVarEnv env tv }+++tcInstBinderX _ subst (Anon ty)+     -- This is the *only* constraint currently handled in types.+  | Just (mk, role, k1, k2) <- get_pred_tys_maybe substed_ty+  = do { let origin = TypeEqOrigin { uo_actual   = k1+                                   , uo_expected = k2+                                   , uo_thing    = Nothing }+       ; co <- case role of+                 Nominal          -> unifyKind noThing k1 k2+                 Representational -> emitWantedEq origin KindLevel role k1 k2+                 Phantom          -> pprPanic "tcInstBinderX Phantom" (ppr ty)+       ; arg' <- mk co k1 k2+       ; return (subst, arg') }++  | isPredTy substed_ty+  = do { let (env, tidy_ty) = tidyOpenType emptyTidyEnv substed_ty+       ; addErrTcM (env, text "Illegal constraint in a type:" <+> ppr tidy_ty)++         -- just invent a new variable so that we can continue+       ; u <- newUnique+       ; let name = mkSysTvName u (fsLit "dict")+       ; return (subst, mkTyVarTy $ mkTyVar name substed_ty) }+++  | otherwise+  = do { tv_ty <- newFlexiTyVarTy substed_ty+       ; return (subst, tv_ty) }++  where+    substed_ty = substTy subst ty++      -- handle boxed equality constraints, because it's so easy+    get_pred_tys_maybe ty+      | Just (r, k1, k2) <- getEqPredTys_maybe ty+      = Just (\co _ _ -> return $ mkCoercionTy co, r, k1, k2)+      | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty+      = if | tc `hasKey` heqTyConKey+             -> Just (mkHEqBoxTy, Nominal, k1, k2)+           | otherwise+             -> Nothing+      | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty+      = if | tc `hasKey` eqTyConKey+             -> Just (mkEqBoxTy, Nominal, k1, k2)+           | tc `hasKey` coercibleTyConKey+             -> Just (mkCoercibleBoxTy, Representational, k1, k2)+           | otherwise+             -> Nothing+      | otherwise+      = Nothing++-------------------------------+-- | This takes @a ~# b@ and returns @a ~~ b@.+mkHEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type+-- monadic just for convenience with mkEqBoxTy+mkHEqBoxTy co ty1 ty2+  = return $+    mkTyConApp (promoteDataCon heqDataCon) [k1, k2, ty1, ty2, mkCoercionTy co]+  where k1 = typeKind ty1+        k2 = typeKind ty2++-- | This takes @a ~# b@ and returns @a ~ b@.+mkEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type+mkEqBoxTy co ty1 ty2+  = do { eq_tc <- tcLookupTyCon eqTyConName+       ; let [datacon] = tyConDataCons eq_tc+       ; hetero <- mkHEqBoxTy co ty1 ty2+       ; return $ mkTyConApp (promoteDataCon datacon) [k, ty1, ty2, hetero] }+  where k = typeKind ty1++-- | This takes @a ~R# b@ and returns @Coercible a b@.+mkCoercibleBoxTy :: TcCoercion -> Type -> Type -> TcM Type+-- monadic just for convenience with mkEqBoxTy+mkCoercibleBoxTy co ty1 ty2+  = do { return $+         mkTyConApp (promoteDataCon coercibleDataCon)+                    [k, ty1, ty2, mkCoercionTy co] }+  where k = typeKind ty1++{-+************************************************************************+*                                                                      *+                Literals+*                                                                      *+************************************************************************++-}++{-+In newOverloadedLit we convert directly to an Int or Integer if we+know that's what we want.  This may save some time, by not+temporarily generating overloaded literals, but it won't catch all+cases (the rest are caught in lookupInst).++-}++newOverloadedLit :: HsOverLit Name+                 -> ExpRhoType+                 -> TcM (HsOverLit TcId)+newOverloadedLit+  lit@(OverLit { ol_val = val, ol_rebindable = rebindable }) res_ty+  | not rebindable+    -- all built-in overloaded lits are tau-types, so we can just+    -- tauify the ExpType+  = do { res_ty <- expTypeToType res_ty+       ; dflags <- getDynFlags+       ; case shortCutLit dflags val res_ty of+        -- Do not generate a LitInst for rebindable syntax.+        -- Reason: If we do, tcSimplify will call lookupInst, which+        --         will call tcSyntaxName, which does unification,+        --         which tcSimplify doesn't like+           Just expr -> return (lit { ol_witness = expr, ol_type = res_ty+                                    , ol_rebindable = False })+           Nothing   -> newNonTrivialOverloadedLit orig lit+                                                   (mkCheckExpType res_ty) }++  | otherwise+  = newNonTrivialOverloadedLit orig lit res_ty+  where+    orig = LiteralOrigin lit++-- Does not handle things that 'shortCutLit' can handle. See also+-- newOverloadedLit in TcUnify+newNonTrivialOverloadedLit :: CtOrigin+                           -> HsOverLit Name+                           -> ExpRhoType+                           -> TcM (HsOverLit TcId)+newNonTrivialOverloadedLit orig+  lit@(OverLit { ol_val = val, ol_witness = HsVar (L _ meth_name)+               , ol_rebindable = rebindable }) res_ty+  = do  { hs_lit <- mkOverLit val+        ; let lit_ty = hsLitType hs_lit+        ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name)+                                      [synKnownType lit_ty] res_ty $+                      \_ -> return ()+        ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit]+        ; res_ty <- readExpType res_ty+        ; return (lit { ol_witness = witness+                      , ol_type = res_ty+                      , ol_rebindable = rebindable }) }+newNonTrivialOverloadedLit _ lit _+  = pprPanic "newNonTrivialOverloadedLit" (ppr lit)++------------+mkOverLit :: OverLitVal -> TcM HsLit+mkOverLit (HsIntegral src i)+  = do  { integer_ty <- tcMetaTy integerTyConName+        ; return (HsInteger src i integer_ty) }++mkOverLit (HsFractional r)+  = do  { rat_ty <- tcMetaTy rationalTyConName+        ; return (HsRat r rat_ty) }++mkOverLit (HsIsString src s) = return (HsString src s)++{-+************************************************************************+*                                                                      *+                Re-mappable syntax++     Used only for arrow syntax -- find a way to nuke this+*                                                                      *+************************************************************************++Suppose we are doing the -XRebindableSyntax thing, and we encounter+a do-expression.  We have to find (>>) in the current environment, which is+done by the rename. Then we have to check that it has the same type as+Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had+this:++  (>>) :: HB m n mn => m a -> n b -> mn b++So the idea is to generate a local binding for (>>), thus:++        let then72 :: forall a b. m a -> m b -> m b+            then72 = ...something involving the user's (>>)...+        in+        ...the do-expression...++Now the do-expression can proceed using then72, which has exactly+the expected type.++In fact tcSyntaxName just generates the RHS for then72, because we only+want an actual binding in the do-expression case. For literals, we can+just use the expression inline.+-}++tcSyntaxName :: CtOrigin+             -> TcType                  -- Type to instantiate it at+             -> (Name, HsExpr Name)     -- (Standard name, user name)+             -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)+-- USED ONLY FOR CmdTop (sigh) ***+-- See Note [CmdSyntaxTable] in HsExpr++tcSyntaxName orig ty (std_nm, HsVar (L _ user_nm))+  | std_nm == user_nm+  = do rhs <- newMethodFromName orig std_nm ty+       return (std_nm, rhs)++tcSyntaxName orig ty (std_nm, user_nm_expr) = do+    std_id <- tcLookupId std_nm+    let+        -- C.f. newMethodAtLoc+        ([tv], _, tau) = tcSplitSigmaTy (idType std_id)+        sigma1         = substTyWith [tv] [ty] tau+        -- Actually, the "tau-type" might be a sigma-type in the+        -- case of locally-polymorphic methods.++    addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do++        -- Check that the user-supplied thing has the+        -- same type as the standard one.+        -- Tiresome jiggling because tcCheckSigma takes a located expression+     span <- getSrcSpanM+     expr <- tcPolyExpr (L span user_nm_expr) sigma1+     return (std_nm, unLoc expr)++syntaxNameCtxt :: HsExpr Name -> CtOrigin -> Type -> TidyEnv+               -> TcRn (TidyEnv, SDoc)+syntaxNameCtxt name orig ty tidy_env+  = do { inst_loc <- getCtLocM orig (Just TypeLevel)+       ; let msg = vcat [ text "When checking that" <+> quotes (ppr name)+                          <+> text "(needed by a syntactic construct)"+                        , nest 2 (text "has the required type:"+                                  <+> ppr (tidyType tidy_env ty))+                        , nest 2 (pprCtLoc inst_loc) ]+       ; return (tidy_env, msg) }++{-+************************************************************************+*                                                                      *+                Instances+*                                                                      *+************************************************************************+-}++getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag+-- Construct the OverlapFlag from the global module flags,+-- but if the overlap_mode argument is (Just m),+--     set the OverlapMode to 'm'+getOverlapFlag overlap_mode+  = do  { dflags <- getDynFlags+        ; let overlap_ok    = xopt LangExt.OverlappingInstances dflags+              incoherent_ok = xopt LangExt.IncoherentInstances  dflags+              use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags+                                  , overlapMode   = x }+              default_oflag | incoherent_ok = use (Incoherent NoSourceText)+                            | overlap_ok    = use (Overlaps NoSourceText)+                            | otherwise     = use (NoOverlap NoSourceText)++              final_oflag = setOverlapModeMaybe default_oflag overlap_mode+        ; return final_oflag }++tcGetInsts :: TcM [ClsInst]+-- Gets the local class instances.+tcGetInsts = fmap tcg_insts getGblEnv++newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType+           -> Class -> [Type] -> TcM ClsInst+newClsInst overlap_mode dfun_name tvs theta clas tys+  = do { (subst, tvs') <- freshenTyVarBndrs tvs+             -- Be sure to freshen those type variables,+             -- so they are sure not to appear in any lookup+       ; let tys' = substTys subst tys++             dfun = mkDictFunId dfun_name tvs theta clas tys+             -- The dfun uses the original 'tvs' because+             -- (a) they don't need to be fresh+             -- (b) they may be mentioned in the ib_binds field of+             --     an InstInfo, and in TcEnv.pprInstInfoDetails it's+             --     helpful to use the same names++       ; oflag <- getOverlapFlag overlap_mode+       ; let inst = mkLocalInstance dfun oflag tvs' clas tys'+       ; warnIf (Reason Opt_WarnOrphans)+                (isOrphan (is_orphan inst))+                (instOrphWarn inst)+       ; return inst }++instOrphWarn :: ClsInst -> SDoc+instOrphWarn inst+  = hang (text "Orphan instance:") 2 (pprInstanceHdr inst)+    $$ text "To avoid this"+    $$ nest 4 (vcat possibilities)+  where+    possibilities =+      text "move the instance declaration to the module of the class or of the type, or" :+      text "wrap the type with a newtype and declare the instance on the new type." :+      []++tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a+  -- Add new locally-defined instances+tcExtendLocalInstEnv dfuns thing_inside+ = do { traceDFuns dfuns+      ; env <- getGblEnv+      ; (inst_env', cls_insts') <- foldlM addLocalInst+                                          (tcg_inst_env env, tcg_insts env)+                                          dfuns+      ; let env' = env { tcg_insts    = cls_insts'+                       , tcg_inst_env = inst_env' }+      ; setGblEnv env' thing_inside }++addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst])+-- Check that the proposed new instance is OK,+-- and then add it to the home inst env+-- If overwrite_inst, then we can overwrite a direct match+addLocalInst (home_ie, my_insts) ispec+   = do {+             -- Load imported instances, so that we report+             -- duplicates correctly++             -- 'matches'  are existing instance declarations that are less+             --            specific than the new one+             -- 'dups'     are those 'matches' that are equal to the new one+         ; isGHCi <- getIsGHCi+         ; eps    <- getEps+         ; tcg_env <- getGblEnv++           -- In GHCi, we *override* any identical instances+           -- that are also defined in the interactive context+           -- See Note [Override identical instances in GHCi]+         ; let home_ie'+                 | isGHCi    = deleteFromInstEnv home_ie ispec+                 | otherwise = home_ie++               global_ie = eps_inst_env eps+               inst_envs = InstEnvs { ie_global  = global_ie+                                    , ie_local   = home_ie'+                                    , ie_visible = tcVisibleOrphanMods tcg_env }++             -- Check for inconsistent functional dependencies+         ; let inconsistent_ispecs = checkFunDeps inst_envs ispec+         ; unless (null inconsistent_ispecs) $+           funDepErr ispec inconsistent_ispecs++             -- Check for duplicate instance decls.+         ; let (_tvs, cls, tys) = instanceHead ispec+               (matches, _, _)  = lookupInstEnv False inst_envs cls tys+               dups             = filter (identicalClsInstHead ispec) (map fst matches)+         ; unless (null dups) $+           dupInstErr ispec (head dups)++         ; return (extendInstEnv home_ie' ispec, ispec : my_insts) }++{-+Note [Signature files and type class instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Instances in signature files do not have an effect when compiling:+when you compile a signature against an implementation, you will+see the instances WHETHER OR NOT the instance is declared in+the file (this is because the signatures go in the EPS and we+can't filter them out easily.)  This is also why we cannot+place the instance in the hi file: it would show up as a duplicate,+and we don't have instance reexports anyway.++However, you might find them useful when typechecking against+a signature: the instance is a way of indicating to GHC that+some instance exists, in case downstream code uses it.++Implementing this is a little tricky.  Consider the following+situation (sigof03):++ module A where+     instance C T where ...++ module ASig where+     instance C T++When compiling ASig, A.hi is loaded, which brings its instances+into the EPS.  When we process the instance declaration in ASig,+we should ignore it for the purpose of doing a duplicate check,+since it's not actually a duplicate. But don't skip the check+entirely, we still want this to fail (tcfail221):++ module ASig where+     instance C T+     instance C T++Note that in some situations, the interface containing the type+class instances may not have been loaded yet at all.  The usual+situation when A imports another module which provides the+instances (sigof02m):++ module A(module B) where+     import B++See also Note [Signature lazy interface loading].  We can't+rely on this, however, since sometimes we'll have spurious+type class instances in the EPS, see #9422 (sigof02dm)++************************************************************************+*                                                                      *+        Errors and tracing+*                                                                      *+************************************************************************+-}++traceDFuns :: [ClsInst] -> TcRn ()+traceDFuns ispecs+  = traceTc "Adding instances:" (vcat (map pp ispecs))+  where+    pp ispec = hang (ppr (instanceDFunId ispec) <+> colon)+                  2 (ppr ispec)+        -- Print the dfun name itself too++funDepErr :: ClsInst -> [ClsInst] -> TcRn ()+funDepErr ispec ispecs+  = addClsInstsErr (text "Functional dependencies conflict between instance declarations:")+                    (ispec : ispecs)++dupInstErr :: ClsInst -> ClsInst -> TcRn ()+dupInstErr ispec dup_ispec+  = addClsInstsErr (text "Duplicate instance declarations:")+                    [ispec, dup_ispec]++addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()+addClsInstsErr herald ispecs+  = setSrcSpan (getSrcSpan (head sorted)) $+    addErr (hang herald 2 (pprInstances sorted))+ where+   sorted = sortWith getSrcLoc ispecs+   -- The sortWith just arranges that instances are dislayed in order+   -- of source location, which reduced wobbling in error messages,+   -- and is better for users
+ typecheck/TcAnnotations.hs view
@@ -0,0 +1,74 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1993-1998++\section[TcAnnotations]{Typechecking annotations}+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}++module TcAnnotations ( tcAnnotations, annCtxt ) where++import {-# SOURCE #-} TcSplice ( runAnnotation )+import Module+import DynFlags+import Control.Monad ( when )++import HsSyn+import Annotations+import Name+import TcRnMonad+import SrcLoc+import Outputable++-- Some platforms don't support the external interpreter, and+-- compilation on those platforms shouldn't fail just due to+-- annotations+#ifndef GHCI+tcAnnotations :: [LAnnDecl Name] -> TcM [Annotation]+tcAnnotations anns = do+  dflags <- getDynFlags+  case gopt Opt_ExternalInterpreter dflags of+    True  -> tcAnnotations' anns+    False -> warnAnns anns+warnAnns :: [LAnnDecl Name] -> TcM [Annotation]+--- No GHCI; emit a warning (not an error) and ignore. cf Trac #4268+warnAnns [] = return []+warnAnns anns@(L loc _ : _)+  = do { setSrcSpan loc $ addWarnTc NoReason $+             (text "Ignoring ANN annotation" <> plural anns <> comma+             <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi")+       ; return [] }+#else+tcAnnotations :: [LAnnDecl Name] -> TcM [Annotation]+tcAnnotations = tcAnnotations'+#endif++tcAnnotations' :: [LAnnDecl Name] -> TcM [Annotation]+tcAnnotations' anns = mapM tcAnnotation anns++tcAnnotation :: LAnnDecl Name -> TcM Annotation+tcAnnotation (L loc ann@(HsAnnotation _ provenance expr)) = do+    -- Work out what the full target of this annotation was+    mod <- getModule+    let target = annProvenanceToTarget mod provenance++    -- Run that annotation and construct the full Annotation data structure+    setSrcSpan loc $ addErrCtxt (annCtxt ann) $ do+      -- See #10826 -- Annotations allow one to bypass Safe Haskell.+      dflags <- getDynFlags+      when (safeLanguageOn dflags) $ failWithTc safeHsErr+      runAnnotation target expr+    where+      safeHsErr = vcat [ text "Annotations are not compatible with Safe Haskell."+                  , text "See https://ghc.haskell.org/trac/ghc/ticket/10826" ]++annProvenanceToTarget :: Module -> AnnProvenance Name -> AnnTarget Name+annProvenanceToTarget _   (ValueAnnProvenance (L _ name)) = NamedTarget name+annProvenanceToTarget _   (TypeAnnProvenance (L _ name))  = NamedTarget name+annProvenanceToTarget mod ModuleAnnProvenance             = ModuleTarget mod++annCtxt :: (OutputableBndrId id) => AnnDecl id -> SDoc+annCtxt ann+  = hang (text "In the annotation:") 2 (ppr ann)
+ typecheck/TcArrows.hs view
@@ -0,0 +1,427 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++Typecheck arrow notation+-}++{-# LANGUAGE RankNTypes, TupleSections #-}++module TcArrows ( tcProc ) where++import {-# SOURCE #-}   TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcPolyExpr )++import HsSyn+import TcMatches+import TcHsSyn( hsLPatType )+import TcType+import TcMType+import TcBinds+import TcPat+import TcUnify+import TcRnMonad+import TcEnv+import TcEvidence+import Id( mkLocalId )+import Inst+import Name+import TysWiredIn+import VarSet+import TysPrim+import BasicTypes( Arity )+import SrcLoc+import Outputable+import Util++import Control.Monad++{-+Note [Arrow overview]+~~~~~~~~~~~~~~~~~~~~~+Here's a summary of arrows and how they typecheck.  First, here's+a cut-down syntax:++  expr ::= ....+        |  proc pat cmd++  cmd ::= cmd exp                    -- Arrow application+       |  \pat -> cmd                -- Arrow abstraction+       |  (| exp cmd1 ... cmdn |)    -- Arrow form, n>=0+       |  ... -- If, case in the usual way++  cmd_type ::= carg_type --> type++  carg_type ::= ()+             |  (type, carg_type)++Note that+ * The 'exp' in an arrow form can mention only+   "arrow-local" variables++ * An "arrow-local" variable is bound by an enclosing+   cmd binding form (eg arrow abstraction)++ * A cmd_type is here written with a funny arrow "-->",+   The bit on the left is a carg_type (command argument type)+   which itself is a nested tuple, finishing with ()++ * The arrow-tail operator (e1 -< e2) means+       (| e1 <<< arr snd |) e2+++************************************************************************+*                                                                      *+                Proc+*                                                                      *+************************************************************************+-}++tcProc :: InPat Name -> LHsCmdTop Name          -- proc pat -> expr+       -> ExpRhoType                            -- Expected type of whole proc expression+       -> TcM (OutPat TcId, LHsCmdTop TcId, TcCoercion)++tcProc pat cmd exp_ty+  = newArrowScope $+    do  { exp_ty <- expTypeToType exp_ty  -- no higher-rank stuff with arrows+        ; (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty+        ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1+        ; let cmd_env = CmdEnv { cmd_arr = arr_ty }+        ; (pat', cmd') <- tcPat ProcExpr pat (mkCheckExpType arg_ty) $+                          tcCmdTop cmd_env cmd (unitTy, res_ty)+        ; let res_co = mkTcTransCo co+                         (mkTcAppCo co1 (mkTcNomReflCo res_ty))+        ; return (pat', cmd', res_co) }++{-+************************************************************************+*                                                                      *+                Commands+*                                                                      *+************************************************************************+-}++-- See Note [Arrow overview]+type CmdType    = (CmdArgType, TcTauType)    -- cmd_type+type CmdArgType = TcTauType                  -- carg_type, a nested tuple++data CmdEnv+  = CmdEnv {+        cmd_arr :: TcType -- arrow type constructor, of kind *->*->*+    }++mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType+mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2]++---------------------------------------+tcCmdTop :: CmdEnv+         -> LHsCmdTop Name+         -> CmdType+         -> TcM (LHsCmdTop TcId)++tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) cmd_ty@(cmd_stk, res_ty)+  = setSrcSpan loc $+    do  { cmd'   <- tcCmd env cmd cmd_ty+        ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names+        ; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') }+----------------------------------------+tcCmd  :: CmdEnv -> LHsCmd Name -> CmdType -> TcM (LHsCmd TcId)+        -- The main recursive function+tcCmd env (L loc cmd) res_ty+  = setSrcSpan loc $ do+        { cmd' <- tc_cmd env cmd res_ty+        ; return (L loc cmd') }++tc_cmd :: CmdEnv -> HsCmd Name  -> CmdType -> TcM (HsCmd TcId)+tc_cmd env (HsCmdPar cmd) res_ty+  = do  { cmd' <- tcCmd env cmd res_ty+        ; return (HsCmdPar cmd') }++tc_cmd env (HsCmdLet (L l binds) (L body_loc body)) res_ty+  = do  { (binds', body') <- tcLocalBinds binds         $+                             setSrcSpan body_loc        $+                             tc_cmd env body res_ty+        ; return (HsCmdLet (L l binds') (L body_loc body')) }++tc_cmd env in_cmd@(HsCmdCase scrut matches) (stk, res_ty)+  = addErrCtxt (cmdCtxt in_cmd) $ do+      (scrut', scrut_ty) <- tcInferRho scrut+      matches' <- tcMatchesCase match_ctxt scrut_ty matches (mkCheckExpType res_ty)+      return (HsCmdCase scrut' matches')+  where+    match_ctxt = MC { mc_what = CaseAlt,+                      mc_body = mc_body }+    mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty'+                              ; tcCmd env body (stk, res_ty') }++tc_cmd env (HsCmdIf Nothing pred b1 b2) res_ty    -- Ordinary 'if'+  = do  { pred' <- tcMonoExpr pred (mkCheckExpType boolTy)+        ; b1'   <- tcCmd env b1 res_ty+        ; b2'   <- tcCmd env b2 res_ty+        ; return (HsCmdIf Nothing pred' b1' b2')+    }++tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if+  = do  { pred_ty <- newOpenFlexiTyVarTy+        -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r+        -- because we're going to apply it to the environment, not+        -- the return value.+        ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar]+        ; let r_ty = mkTyVarTy r_tv+        ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty))+                  (text "Predicate type of `ifThenElse' depends on result type")+        ; (pred', fun')+            <- tcSyntaxOp IfOrigin fun (map synKnownType [pred_ty, r_ty, r_ty])+                                       (mkCheckExpType r_ty) $ \ _ ->+               tcMonoExpr pred (mkCheckExpType pred_ty)++        ; b1'   <- tcCmd env b1 res_ty+        ; b2'   <- tcCmd env b2 res_ty+        ; return (HsCmdIf (Just fun') pred' b1' b2')+    }++-------------------------------------------+--              Arrow application+--          (f -< a)   or   (f -<< a)+--+--   D   |- fun :: a t1 t2+--   D,G |- arg :: t1+--  ------------------------+--   D;G |-a  fun -< arg :: stk --> t2+--+--   D,G |- fun :: a t1 t2+--   D,G |- arg :: t1+--  ------------------------+--   D;G |-a  fun -<< arg :: stk --> t2+--+-- (plus -<< requires ArrowApply)++tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty)+  = addErrCtxt (cmdCtxt cmd)    $+    do  { arg_ty <- newOpenFlexiTyVarTy+        ; let fun_ty = mkCmdArrTy env arg_ty res_ty+        ; fun' <- select_arrow_scope (tcMonoExpr fun (mkCheckExpType fun_ty))++        ; arg' <- tcMonoExpr arg (mkCheckExpType arg_ty)++        ; return (HsCmdArrApp fun' arg' fun_ty ho_app lr) }+  where+       -- Before type-checking f, use the environment of the enclosing+       -- proc for the (-<) case.+       -- Local bindings, inside the enclosing proc, are not in scope+       -- inside f.  In the higher-order case (-<<), they are.+       -- See Note [Escaping the arrow scope] in TcRnTypes+    select_arrow_scope tc = case ho_app of+        HsHigherOrderApp -> tc+        HsFirstOrderApp  -> escapeArrowScope tc++-------------------------------------------+--              Command application+--+-- D,G |-  exp : t+-- D;G |-a cmd : (t,stk) --> res+-- -----------------------------+-- D;G |-a cmd exp : stk --> res++tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty)+  = addErrCtxt (cmdCtxt cmd)    $+    do  { arg_ty <- newOpenFlexiTyVarTy+        ; fun'   <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty)+        ; arg'   <- tcMonoExpr arg (mkCheckExpType arg_ty)+        ; return (HsCmdApp fun' arg') }++-------------------------------------------+--              Lambda+--+-- D;G,x:t |-a cmd : stk --> res+-- ------------------------------+-- D;G |-a (\x.cmd) : (t,stk) --> res++tc_cmd env+       (HsCmdLam (MG { mg_alts = L l [L mtch_loc+                                   (match@(Match _ pats _maybe_rhs_sig grhss))],+                       mg_origin = origin }))+       (cmd_stk, res_ty)+  = addErrCtxt (pprMatchInCtxt match)        $+    do  { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk++                -- Check the patterns, and the GRHSs inside+        ; (pats', grhss') <- setSrcSpan mtch_loc                                 $+                             tcPats LambdaExpr pats (map mkCheckExpType arg_tys) $+                             tc_grhss grhss cmd_stk' (mkCheckExpType res_ty)++        ; let match' = L mtch_loc (Match LambdaExpr pats' Nothing grhss')+              arg_tys = map hsLPatType pats'+              cmd' = HsCmdLam (MG { mg_alts = L l [match'], mg_arg_tys = arg_tys+                                  , mg_res_ty = res_ty, mg_origin = origin })+        ; return (mkHsCmdWrap (mkWpCastN co) cmd') }+  where+    n_pats     = length pats+    match_ctxt = (LambdaExpr :: HsMatchContext Name)    -- Maybe KappaExpr?+    pg_ctxt    = PatGuard match_ctxt++    tc_grhss (GRHSs grhss (L l binds)) stk_ty res_ty+        = do { (binds', grhss') <- tcLocalBinds binds $+                                   mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss+             ; return (GRHSs grhss' (L l binds')) }++    tc_grhs stk_ty res_ty (GRHS guards body)+        = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $+                                  \ res_ty -> tcCmd env body+                                                (stk_ty, checkingExpType "tc_grhs" res_ty)+             ; return (GRHS guards' rhs') }++-------------------------------------------+--              Do notation++tc_cmd env (HsCmdDo (L l stmts) _) (cmd_stk, res_ty)+  = do  { co <- unifyType noThing unitTy cmd_stk  -- Expecting empty argument stack+        ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty+        ; return (mkHsCmdWrap (mkWpCastN co) (HsCmdDo (L l stmts') res_ty)) }+++-----------------------------------------------------------------+--      Arrow ``forms''       (| e c1 .. cn |)+--+--      D; G |-a1 c1 : stk1 --> r1+--      ...+--      D; G |-an cn : stkn --> rn+--      D |-  e :: forall e. a1 (e, stk1) t1+--                                ...+--                        -> an (e, stkn) tn+--                        -> a  (e, stk) t+--      e \not\in (stk, stk1, ..., stkm, t, t1, ..., tn)+--      ----------------------------------------------+--      D; G |-a  (| e c1 ... cn |)  :  stk --> t++tc_cmd env cmd@(HsCmdArrForm expr f fixity cmd_args) (cmd_stk, res_ty)+  = addErrCtxt (cmdCtxt cmd)    $+    do  { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args+                              -- We use alphaTyVar for 'w'+        ; let e_ty = mkInvForAllTy alphaTyVar $+                     mkFunTys cmd_tys $+                     mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty+        ; expr' <- tcPolyExpr expr e_ty+        ; return (HsCmdArrForm expr' f fixity cmd_args') }++  where+    tc_cmd_arg :: LHsCmdTop Name -> TcM (LHsCmdTop TcId, TcType)+    tc_cmd_arg cmd+       = do { arr_ty <- newFlexiTyVarTy arrowTyConKind+            ; stk_ty <- newFlexiTyVarTy liftedTypeKind+            ; res_ty <- newFlexiTyVarTy liftedTypeKind+            ; let env' = env { cmd_arr = arr_ty }+            ; cmd' <- tcCmdTop env' cmd (stk_ty, res_ty)+            ; return (cmd',  mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) }++-----------------------------------------------------------------+--              Base case for illegal commands+-- This is where expressions that aren't commands get rejected++tc_cmd _ cmd _+  = failWithTc (vcat [text "The expression", nest 2 (ppr cmd),+                      text "was found where an arrow command was expected"])+++matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcType], TcType)+matchExpectedCmdArgs 0 ty+  = return (mkTcNomReflCo ty, [], ty)+matchExpectedCmdArgs n ty+  = do { (co1, [ty1, ty2]) <- matchExpectedTyConApp pairTyCon ty+       ; (co2, tys, res_ty) <- matchExpectedCmdArgs (n-1) ty2+       ; return (mkTcTyConAppCo Nominal pairTyCon [co1, co2], ty1:tys, res_ty) }++{-+************************************************************************+*                                                                      *+                Stmts+*                                                                      *+************************************************************************+-}++--------------------------------+--      Mdo-notation+-- The distinctive features here are+--      (a) RecStmts, and+--      (b) no rebindable syntax++tcArrDoStmt :: CmdEnv -> TcCmdStmtChecker+tcArrDoStmt env _ (LastStmt rhs noret _) res_ty thing_inside+  = do  { rhs' <- tcCmd env rhs (unitTy, res_ty)+        ; thing <- thing_inside (panic "tcArrDoStmt")+        ; return (LastStmt rhs' noret noSyntaxExpr, thing) }++tcArrDoStmt env _ (BodyStmt rhs _ _ _) res_ty thing_inside+  = do  { (rhs', elt_ty) <- tc_arr_rhs env rhs+        ; thing          <- thing_inside res_ty+        ; return (BodyStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) }++tcArrDoStmt env ctxt (BindStmt pat rhs _ _ _) res_ty thing_inside+  = do  { (rhs', pat_ty) <- tc_arr_rhs env rhs+        ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $+                            thing_inside res_ty+        ; return (mkTcBindStmt pat' rhs', thing) }++tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names+                            , recS_rec_ids = rec_names }) res_ty thing_inside+  = do  { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names+        ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind+        ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys+        ; tcExtendIdEnv tup_ids $ do+        { (stmts', tup_rets)+                <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty   $ \ _res_ty' ->+                        -- ToDo: res_ty not really right+                   zipWithM tcCheckId tup_names (map mkCheckExpType tup_elt_tys)++        ; thing <- thing_inside res_ty+                -- NB:  The rec_ids for the recursive things+                --      already scope over this part. This binding may shadow+                --      some of them with polymorphic things with the same Name+                --      (see note [RecStmt] in HsExpr)++        ; let rec_ids = takeList rec_names tup_ids+        ; later_ids <- tcLookupLocalIds later_names++        ; let rec_rets = takeList rec_names tup_rets+        ; let ret_table = zip tup_ids tup_rets+        ; let later_rets = [r | i <- later_ids, (j, r) <- ret_table, i == j]++        ; return (emptyRecStmtId { recS_stmts = stmts'+                                 , recS_later_ids = later_ids+                                 , recS_later_rets = later_rets+                                 , recS_rec_ids = rec_ids+                                 , recS_rec_rets = rec_rets+                                 , recS_ret_ty = res_ty }, thing)+        }}++tcArrDoStmt _ _ stmt _ _+  = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt)++tc_arr_rhs :: CmdEnv -> LHsCmd Name -> TcM (LHsCmd TcId, TcType)+tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind+                        ; rhs' <- tcCmd env rhs (unitTy, ty)+                        ; return (rhs', ty) }++{-+************************************************************************+*                                                                      *+                Helpers+*                                                                      *+************************************************************************+-}++mkPairTy :: Type -> Type -> Type+mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2]++arrowTyConKind :: Kind          --  *->*->*+arrowTyConKind = mkFunTys [liftedTypeKind, liftedTypeKind] liftedTypeKind++{-+************************************************************************+*                                                                      *+                Errors+*                                                                      *+************************************************************************+-}++cmdCtxt :: HsCmd Name -> SDoc+cmdCtxt cmd = text "In the command:" <+> ppr cmd
+ typecheck/TcBackpack.hs view
@@ -0,0 +1,903 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+module TcBackpack (+    findExtraSigImports',+    findExtraSigImports,+    implicitRequirements',+    implicitRequirements,+    checkUnitId,+    tcRnCheckUnitId,+    tcRnMergeSignatures,+    mergeSignatures,+    tcRnInstantiateSignature,+    instantiateSignature,+) where++import BasicTypes (defaultFixity)+import Packages+import TcRnExports+import DynFlags+import HsSyn+import RdrName+import TcRnMonad+import TcTyDecls+import InstEnv+import FamInstEnv+import Inst+import TcIface+import TcMType+import TcType+import TcSimplify+import LoadIface+import RnNames+import ErrUtils+import Id+import Module+import Name+import NameEnv+import NameSet+import Avail+import SrcLoc+import HscTypes+import Outputable+import Type+import FastString+import RnEnv+import Maybes+import TcEnv+import Var+import IfaceSyn+import PrelNames+import qualified Data.Map as Map++import Finder+import UniqDSet+import NameShape+import TcErrors+import TcUnify+import RnModIface+import Util++import Control.Monad+import Data.List (find, foldl')++import {-# SOURCE #-} TcRnDriver++#include "HsVersions.h"++fixityMisMatch :: TyThing -> Fixity -> Fixity -> SDoc+fixityMisMatch real_thing real_fixity sig_fixity =+    vcat [ppr real_thing <+> text "has conflicting fixities in the module",+          text "and its hsig file",+          text "Main module:" <+> ppr_fix real_fixity,+          text "Hsig file:" <+> ppr_fix sig_fixity]+  where+    ppr_fix f =+        ppr f <+>+        (if f == defaultFixity+            then parens (text "default")+            else empty)++checkHsigDeclM :: ModIface -> TyThing -> TyThing -> TcRn ()+checkHsigDeclM sig_iface sig_thing real_thing = do+    let name = getName real_thing+    -- TODO: Distinguish between signature merging and signature+    -- implementation cases.+    checkBootDeclM False sig_thing real_thing+    real_fixity <- lookupFixityRn name+    let sig_fixity = case mi_fix_fn sig_iface (occName name) of+                        Nothing -> defaultFixity+                        Just f -> f+    when (real_fixity /= sig_fixity) $+      addErrAt (nameSrcSpan name)+        (fixityMisMatch real_thing real_fixity sig_fixity)++-- | Given a 'ModDetails' of an instantiated signature (note that the+-- 'ModDetails' must be knot-tied consistently with the actual implementation)+-- and a 'GlobalRdrEnv' constructed from the implementor of this interface,+-- verify that the actual implementation actually matches the original+-- interface.+--+-- Note that it is already assumed that the implementation *exports*+-- a sufficient set of entities, since otherwise the renaming and then+-- typechecking of the signature 'ModIface' would have failed.+checkHsigIface :: TcGblEnv -> GlobalRdrEnv -> ModIface -> ModDetails -> TcRn ()+checkHsigIface tcg_env gr sig_iface+  ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts,+               md_types = sig_type_env, md_exports = sig_exports   } = do+    traceTc "checkHsigIface" $ vcat+        [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ]+    mapM_ check_export (map availName sig_exports)+    unless (null sig_fam_insts) $+        panic ("TcRnDriver.checkHsigIface: Cannot handle family " +++               "instances in hsig files yet...")+    -- Delete instances so we don't look them up when+    -- checking instance satisfiability+    -- TODO: this should not be necessary+    tcg_env <- getGblEnv+    setGblEnv tcg_env { tcg_inst_env = emptyInstEnv,+                        tcg_fam_inst_env = emptyFamInstEnv,+                        tcg_insts = [],+                        tcg_fam_insts = [] } $ do+    mapM_ check_inst sig_insts+    failIfErrsM+  where+    -- NB: the Names in sig_type_env are bogus.  Let's say we have H.hsig+    -- in package p that defines T; and we implement with himpl:H.  Then the+    -- Name is p[himpl:H]:H.T, NOT himplH:H.T.  That's OK but we just+    -- have to look up the right name.+    sig_type_occ_env = mkOccEnv+                     . map (\t -> (nameOccName (getName t), t))+                     $ nameEnvElts sig_type_env+    dfun_names = map getName sig_insts+    check_export name+      -- Skip instances, we'll check them later+      -- TODO: Actually this should never happen, because DFuns are+      -- never exported...+      | name `elem` dfun_names = return ()+      -- See if we can find the type directly in the hsig ModDetails+      -- TODO: need to special case wired in names+      | Just sig_thing <- lookupOccEnv sig_type_occ_env (nameOccName name) = do+        -- NB: We use tcLookupImported_maybe because we want to EXCLUDE+        -- tcg_env (TODO: but maybe this isn't relevant anymore).+        r <- tcLookupImported_maybe name+        case r of+          Failed err -> addErr err+          Succeeded real_thing -> checkHsigDeclM sig_iface sig_thing real_thing++      -- The hsig did NOT define this function; that means it must+      -- be a reexport.  In this case, make sure the 'Name' of the+      -- reexport matches the 'Name exported here.+      | [GRE { gre_name = name' }] <- lookupGlobalRdrEnv gr (nameOccName name) =+        when (name /= name') $ do+            -- See Note [Error reporting bad reexport]+            -- TODO: Actually this error swizzle doesn't work+            let p (L _ ie) = name `elem` ieNames ie+                loc = case tcg_rn_exports tcg_env of+                       Just es | Just e <- find p es+                         -- TODO: maybe we can be a little more+                         -- precise here and use the Located+                         -- info for the *specific* name we matched.+                         -> getLoc e+                       _ -> nameSrcSpan name+            dflags <- getDynFlags+            addErrAt loc+                (badReexportedBootThing dflags False name name')+      -- This should actually never happen, but whatever...+      | otherwise =+        addErrAt (nameSrcSpan name)+            (missingBootThing False name "exported by")++-- Note [Error reporting bad reexport]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- NB: You want to be a bit careful about what location you report on reexports.+-- If the name was declared in the hsig file, 'nameSrcSpan name' is indeed the+-- correct source location.  However, if it was *reexported*, obviously the name+-- is not going to have the right location.  In this case, we need to grovel in+-- tcg_rn_exports to figure out where the reexport came from.++++-- | Checks if a 'ClsInst' is "defined". In general, for hsig files we can't+-- assume that the implementing file actually implemented the instances (they+-- may be reexported from elsewhere).  Where should we look for the instances?+-- We do the same as we would otherwise: consult the EPS.  This isn't perfect+-- (we might conclude the module exports an instance when it doesn't, see+-- #9422), but we will never refuse to compile something.+check_inst :: ClsInst -> TcM ()+check_inst sig_inst = do+    -- TODO: This could be very well generalized to support instance+    -- declarations in boot files.+    tcg_env <- getGblEnv+    -- NB: Have to tug on the interface, not necessarily+    -- tugged... but it didn't work?+    mapM_ tcLookupImported_maybe (nameSetElemsStable (orphNamesOfClsInst sig_inst))+    -- Based off of 'simplifyDeriv'+    let ty = idType (instanceDFunId sig_inst)+        skol_info = InstSkol+        -- Based off of tcSplitDFunTy+        (tvs, theta, pred) =+           case tcSplitForAllTys ty of { (tvs, rho)   ->+           case splitFunTys rho     of { (theta, pred) ->+           (tvs, theta, pred) }}+        origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst+    (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize+    (cts, tclvl) <- pushTcLevelM $ do+       wanted <- newWanted origin+                           (Just TypeLevel)+                           (substTy skol_subst pred)+       givens <- forM theta $ \given -> do+           loc <- getCtLocM origin (Just TypeLevel)+           let given_pred = substTy skol_subst given+           new_ev <- newEvVar given_pred+           return CtGiven { ctev_pred = given_pred+                          -- Doesn't matter, make something up+                          , ctev_evar = new_ev+                          , ctev_loc = loc+                          }+       return $ wanted : givens+    unsolved <- simplifyWantedsTcM cts++    (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved+    reportAllUnsolved (mkImplicWC implic)++-- | Return this list of requirement interfaces that need to be merged+-- to form @mod_name@, or @[]@ if this is not a requirement.+requirementMerges :: DynFlags -> ModuleName -> [IndefModule]+requirementMerges dflags mod_name =+    fromMaybe [] (Map.lookup mod_name (requirementContext (pkgState dflags)))++-- | For a module @modname@ of type 'HscSource', determine the list+-- of extra "imports" of other requirements which should be considered part of+-- the import of the requirement, because it transitively depends on those+-- requirements by imports of modules from other packages.  The situation+-- is something like this:+--+--      unit p where+--          signature A+--          signature B+--              import A+--+--      unit q where+--          dependency p[A=<A>,B=<B>]+--          signature A+--          signature B+--+-- Although q's B does not directly import A, we still have to make sure we+-- process A first, because the merging process will cause B to indirectly+-- import A.  This function finds the TRANSITIVE closure of all such imports+-- we need to make.+findExtraSigImports' :: HscEnv+                     -> HscSource+                     -> ModuleName+                     -> IO (UniqDSet ModuleName)+findExtraSigImports' hsc_env HsigFile modname =+    fmap unionManyUniqDSets (forM reqs $ \(IndefModule iuid mod_name) ->+        (initIfaceLoad hsc_env+            . withException+            $ moduleFreeHolesPrecise (text "findExtraSigImports")+                (mkModule (IndefiniteUnitId iuid) mod_name)))+  where+    reqs = requirementMerges (hsc_dflags hsc_env) modname++findExtraSigImports' _ _ _ = return emptyUniqDSet++-- | 'findExtraSigImports', but in a convenient form for "GhcMake" and+-- "TcRnDriver".+findExtraSigImports :: HscEnv -> HscSource -> ModuleName+                    -> IO [(Maybe FastString, Located ModuleName)]+findExtraSigImports hsc_env hsc_src modname = do+    extra_requirements <- findExtraSigImports' hsc_env hsc_src modname+    return [ (Nothing, noLoc mod_name)+           | mod_name <- uniqDSetToList extra_requirements ]++-- A version of 'implicitRequirements'' which is more friendly+-- for "GhcMake" and "TcRnDriver".+implicitRequirements :: HscEnv+                     -> [(Maybe FastString, Located ModuleName)]+                     -> IO [(Maybe FastString, Located ModuleName)]+implicitRequirements hsc_env normal_imports+  = do mns <- implicitRequirements' hsc_env normal_imports+       return [ (Nothing, noLoc mn) | mn <- mns ]++-- Given a list of 'import M' statements in a module, figure out+-- any extra implicit requirement imports they may have.  For+-- example, if they 'import M' and M resolves to p[A=<B>], then+-- they actually also import the local requirement B.+implicitRequirements' :: HscEnv+                     -> [(Maybe FastString, Located ModuleName)]+                     -> IO [ModuleName]+implicitRequirements' hsc_env normal_imports+  = fmap concat $+    forM normal_imports $ \(mb_pkg, L _ imp) -> do+        found <- findImportedModule hsc_env imp mb_pkg+        case found of+            Found _ mod | thisPackage dflags /= moduleUnitId mod ->+                return (uniqDSetToList (moduleFreeHoles mod))+            _ -> return []+  where dflags = hsc_dflags hsc_env++-- | Given a 'UnitId', make sure it is well typed.  This is because+-- unit IDs come from Cabal, which does not know if things are well-typed or+-- not; a component may have been filled with implementations for the holes+-- that don't actually fulfill the requirements.+--+-- INVARIANT: the UnitId is NOT a InstalledUnitId+checkUnitId :: UnitId -> TcM ()+checkUnitId uid = do+    case splitUnitIdInsts uid of+      (_, Just indef) ->+        let insts = indefUnitIdInsts indef in+        forM_ insts $ \(mod_name, mod) ->+            -- NB: direct hole instantiations are well-typed by construction+            -- (because we FORCE things to be merged in), so don't check them+            when (not (isHoleModule mod)) $ do+                checkUnitId (moduleUnitId mod)+                _ <- mod `checkImplements` IndefModule indef mod_name+                return ()+      _ -> return () -- if it's hashed, must be well-typed++-- | Top-level driver for signature instantiation (run when compiling+-- an @hsig@ file.)+tcRnCheckUnitId ::+    HscEnv -> UnitId ->+    IO (Messages, Maybe ())+tcRnCheckUnitId hsc_env uid =+   withTiming (pure dflags)+              (text "Check unit id" <+> ppr uid)+              (const ()) $+   initTc hsc_env+          HsigFile -- bogus+          False+          mAIN -- bogus+          (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus+    $ checkUnitId uid+  where+   dflags = hsc_dflags hsc_env+   loc_str = "Command line argument: -unit-id " ++ showSDoc dflags (ppr uid)++-- TODO: Maybe lcl_iface0 should be pre-renamed to the right thing? Unclear...++-- | Top-level driver for signature merging (run after typechecking+-- an @hsig@ file).+tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface+                    -> IO (Messages, Maybe TcGblEnv)+tcRnMergeSignatures hsc_env hpm orig_tcg_env iface =+  withTiming (pure dflags)+             (text "Signature merging" <+> brackets (ppr this_mod))+             (const ()) $+  initTc hsc_env HsigFile False this_mod real_loc $+    mergeSignatures hpm orig_tcg_env iface+ where+  dflags   = hsc_dflags hsc_env+  this_mod = mi_module iface+  real_loc = tcg_top_loc orig_tcg_env++thinModIface :: [AvailInfo] -> ModIface -> ModIface+thinModIface avails iface =+    iface {+        mi_exports = avails,+        -- mi_fixities = ...,+        -- mi_warns = ...,+        -- mi_anns = ...,+        -- TODO: The use of nameOccName here is a bit dodgy, because+        -- perhaps there might be two IfaceTopBndr that are the same+        -- OccName but different Name.  Requires better understanding+        -- of invariants here.+        mi_decls = exported_decls ++ non_exported_decls ++ dfun_decls+        -- mi_insts = ...,+        -- mi_fam_insts = ...,+    }+  where+    decl_pred occs decl = nameOccName (ifName decl) `elemOccSet` occs+    filter_decls occs = filter (decl_pred occs . snd) (mi_decls iface)++    exported_occs = mkOccSet [ occName n+                             | a <- avails+                             , n <- availNames a ]+    exported_decls = filter_decls exported_occs++    non_exported_occs = mkOccSet [ occName n+                                 | (_, d) <- exported_decls+                                 , n <- ifaceDeclNeverExportedRefs d ]+    non_exported_decls = filter_decls non_exported_occs++    dfun_pred IfaceId{ ifIdDetails = IfDFunId } = True+    dfun_pred _ = False+    dfun_decls = filter (dfun_pred . snd) (mi_decls iface)++-- | The list of 'Name's of *non-exported* 'IfaceDecl's which this+-- 'IfaceDecl' may refer to.  A non-exported 'IfaceDecl' should be kept+-- after thinning if an *exported* 'IfaceDecl' (or 'mi_insts', perhaps)+-- refers to it; we can't decide to keep it by looking at the exports+-- of a module after thinning.  Keep this synchronized with+-- 'rnIfaceDecl'.+ifaceDeclNeverExportedRefs :: IfaceDecl -> [Name]+ifaceDeclNeverExportedRefs d@IfaceFamily{} =+    case ifFamFlav d of+        IfaceClosedSynFamilyTyCon (Just (n, _))+            -> [n]+        _   -> []+ifaceDeclNeverExportedRefs _ = []+++-- Note [Blank hsigs for all requirements]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- One invariant that a client of GHC must uphold is that there+-- must be an hsig file for every requirement (according to+-- @-this-unit-id@); this ensures that for every interface+-- file (hi), there is a source file (hsig), which helps grease+-- the wheels of recompilation avoidance which assumes that+-- source files always exist.++{-+inheritedSigPvpWarning :: WarningTxt+inheritedSigPvpWarning =+    WarningTxt (noLoc NoSourceText) [noLoc (StringLiteral NoSourceText (fsLit msg))]+  where+    msg = "Inherited requirements from non-signature libraries (libraries " +++          "with modules) should not be used, as this mode of use is not " +++          "compatible with PVP-style version bounds.  Instead, copy the " +++          "declaration to the local hsig file or move the signature to a " +++          "library of its own and add that library as a dependency."+-}++-- Note [Handling never-exported TyThings under Backpack]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--   DEFINITION: A "never-exported TyThing" is a TyThing whose 'Name' will+--   never be mentioned in the export list of a module (mi_avails).+--   Unlike implicit TyThings (Note [Implicit TyThings]), non-exported+--   TyThings DO have a standalone IfaceDecl declaration in their+--   interface file.+--+-- Originally, Backpack was designed under the assumption that anything+-- you could declare in a module could also be exported; thus, merging+-- the export lists of two signatures is just merging the declarations+-- of two signatures writ small.  Of course, in GHC Haskell, there are a+-- few important things which are not explicitly exported but still can+-- be used:  in particular, dictionary functions for instances, Typeable+-- TyCon bindings, and coercion axioms for type families also count.+--+-- When handling these non-exported things, there two primary things+-- we need to watch out for:+--+--  * Signature matching/merging is done by comparing each+--    of the exported entities of a signature and a module.  These exported+--    entities may refer to non-exported TyThings which must be tested for+--    consistency.  For example, an instance (ClsInst) will refer to a+--    non-exported DFunId.  In this case, 'checkBootDeclM' directly compares the+--    embedded 'DFunId' in 'is_dfun'.+--+--    For this to work at all, we must ensure that pointers in 'is_dfun' refer+--    to DISTINCT 'DFunId's, even though the 'Name's (may) be the same.+--    Unfortunately, this is the OPPOSITE of how we treat most other references+--    to 'Name's, so this case needs to be handled specially.+--+--    The details are in the documentation for 'typecheckIfacesForMerging'.+--    and the Note [Resolving never-exported Names in TcIface].+--+--  * When we rename modules and signatures, we use the export lists to+--    decide how the declarations should be renamed.  However, this+--    means we don't get any guidance for how to rename non-exported+--    entities.  Fortunately, we only need to rename these entities+--    *consistently*, so that 'typecheckIfacesForMerging' can wire them+--    up as needed.+--+--    The details are in Note [rnIfaceNeverExported] in 'RnModIface'.+--+-- The root cause for all of these complications is the fact that these+-- logically "implicit" entities are defined indirectly in an interface+-- file.  #13151 gives a proposal to make these *truly* implicit.++merge_msg :: ModuleName -> [IndefModule] -> SDoc+merge_msg mod_name [] =+    text "while checking the local signature" <+> ppr mod_name <+>+    text "for consistency"+merge_msg mod_name reqs =+  hang (text "while merging the signatures from" <> colon)+   2 (vcat [ bullet <+> ppr req | req <- reqs ] $$+      bullet <+> text "...and the local signature for" <+> ppr mod_name)++-- | Given a local 'ModIface', merge all inherited requirements+-- from 'requirementMerges' into this signature, producing+-- a final 'TcGblEnv' that matches the local signature and+-- all required signatures.+mergeSignatures :: HsParsedModule -> TcGblEnv -> ModIface -> TcRn TcGblEnv+mergeSignatures+  (HsParsedModule { hpm_module = L loc (HsModule { hsmodExports = mb_exports }),+                    hpm_src_files = src_files })+  orig_tcg_env lcl_iface0 = setSrcSpan loc $ do+    -- The lcl_iface0 is the ModIface for the local hsig+    -- file, which is guaranteed to exist, see+    -- Note [Blank hsigs for all requirements]+    hsc_env <- getTopEnv+    dflags  <- getDynFlags+    tcg_env <- getGblEnv+    let outer_mod = tcg_mod tcg_env+        inner_mod = tcg_semantic_mod tcg_env+        mod_name = moduleName (tcg_mod tcg_env)++    -- STEP 1: Figure out all of the external signature interfaces+    -- we are going to merge in.+    let reqs = requirementMerges dflags mod_name++    addErrCtxt (merge_msg mod_name reqs) $ do++    -- STEP 2: Read in the RAW forms of all of these interfaces+    ireq_ifaces0 <- forM reqs $ \(IndefModule iuid mod_name) ->+        let m = mkModule (IndefiniteUnitId iuid) mod_name+            im = fst (splitModuleInsts m)+        in fmap fst+         . withException+         $ findAndReadIface (text "mergeSignatures") im m False++    -- STEP 3: Get the unrenamed exports of all these interfaces,+    -- thin it according to the export list, and do shaping on them.+    let extend_ns nsubst as = liftIO $ extendNameShape hsc_env nsubst as+        -- This function gets run on every inherited interface, and+        -- it's responsible for:+        --+        --  1. Merging the exports of the interface into @nsubst@,+        --  2. Adding these exports to the "OK to import" set (@oks@)+        --  if they came from a package with no exposed modules+        --  (this means we won't report a PVP error in this case), and+        --  3. Thinning the interface according to an explicit export+        --  list.+        --+        gen_subst (nsubst,oks,ifaces) (imod@(IndefModule iuid _), ireq_iface) = do+            let insts = indefUnitIdInsts iuid+            as1 <- tcRnModExports insts ireq_iface+            let inst_uid = fst (splitUnitIdInsts (IndefiniteUnitId iuid))+                pkg = getInstalledPackageDetails dflags inst_uid+                -- Setup the import spec correctly, so that when we apply+                -- IEModuleContents we pick up EVERYTHING+                ispec = ImpSpec+                            ImpDeclSpec{+                                is_mod  = mod_name,+                                is_as   = mod_name,+                                is_qual = False,+                                is_dloc = loc+                            } ImpAll+                rdr_env = mkGlobalRdrEnv (gresFromAvails (Just ispec) as1)+            (thinned_iface, as2) <- case mb_exports of+                    Just (L loc _)+                      | null (exposedModules pkg) -> setSrcSpan loc $ do+                        -- Suppress missing errors; we'll pick em up+                        -- when we test exports on the final thing+                        (msgs, mb_r) <- tryTc $+                            setGblEnv tcg_env {+                                tcg_rdr_env = rdr_env+                            } $ exports_from_avail mb_exports rdr_env+                                    (tcg_imports tcg_env) (tcg_semantic_mod tcg_env)+                        case mb_r of+                            Just (_, as2) -> return (thinModIface as2 ireq_iface, as2)+                            Nothing -> addMessages msgs >> failM+                    _ -> return (ireq_iface, as1)+            let oks' | null (exposedModules pkg)+                     = extendOccSetList oks (exportOccs as2)+                     | otherwise+                     = oks+            mb_r <- extend_ns nsubst as2+            case mb_r of+                Left err -> failWithTc err+                Right nsubst' -> return (nsubst',oks',(imod, thinned_iface):ifaces)+        nsubst0 = mkNameShape (moduleName inner_mod) (mi_exports lcl_iface0)+        ok_to_use0 = mkOccSet (exportOccs (mi_exports lcl_iface0))+    -- Process each interface, getting the thinned interfaces as well as+    -- the final, full set of exports @nsubst@ and the exports which are+    -- "ok to use" (we won't attach 'inheritedSigPvpWarning' to them.)+    (nsubst, ok_to_use, rev_thinned_ifaces)+        <- foldM gen_subst (nsubst0, ok_to_use0, []) (zip reqs ireq_ifaces0)+    let thinned_ifaces = reverse rev_thinned_ifaces+        exports        = nameShapeExports nsubst+        rdr_env        = mkGlobalRdrEnv (gresFromAvails Nothing exports)+        _warn_occs     = filter (not . (`elemOccSet` ok_to_use)) (exportOccs exports)+        warns          = NoWarnings+        {-+        -- TODO: Warnings are transitive, but this is not what we want here:+        -- if a module reexports an entity from a signature, that should be OK.+        -- Not supported in current warning framework+        warns | null warn_occs = NoWarnings+              | otherwise = WarnSome $ map (\o -> (o, inheritedSigPvpWarning)) warn_occs+        -}+    setGblEnv tcg_env {+        -- The top-level GlobalRdrEnv is quite interesting.  It consists+        -- of two components:+        --  1. First, we reuse the GlobalRdrEnv of the local signature.+        --     This is very useful, because it means that if we have+        --     to print a message involving some entity that the local+        --     signature imported, we'll qualify it accordingly.+        --  2. Second, we need to add all of the declarations we are+        --     going to merge in (as they need to be in scope for the+        --     final test of the export list.)+        tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env orig_tcg_env,+        -- Inherit imports from the local signature, so that module+        -- rexports are picked up correctly+        tcg_imports = tcg_imports orig_tcg_env,+        tcg_exports = exports,+        tcg_dus     = usesOnly (availsToNameSetWithSelectors exports),+        tcg_warns   = warns+        } $ do+    tcg_env <- getGblEnv++    -- Make sure we didn't refer to anything that doesn't actually exist+    -- pprTrace "mergeSignatures: exports_from_avail" (ppr exports) $ return ()+    (mb_lies, _) <- exports_from_avail mb_exports rdr_env+                        (tcg_imports tcg_env) (tcg_semantic_mod tcg_env)++    -- If you tried to explicitly export an identifier that has a warning+    -- attached to it, that's probably a mistake.  Warn about it.+    case mb_lies of+      Nothing -> return ()+      Just lies ->+        forM_ (concatMap (\(L loc x) -> map (L loc) (ieNames x)) lies) $ \(L loc n) ->+          setSrcSpan loc $+            unless (nameOccName n `elemOccSet` ok_to_use) $+                addWarn NoReason $ vcat [+                    text "Exported identifier" <+> quotes (ppr n) <+> text "will cause warnings if used.",+                    parens (text "To suppress this warning, remove" <+> quotes (ppr n) <+> text "from the export list of this signature.")+                    ]++    failIfErrsM++    -- STEP 4: Rename the interfaces+    ext_ifaces <- forM thinned_ifaces $ \((IndefModule iuid _), ireq_iface) ->+        tcRnModIface (indefUnitIdInsts iuid) (Just nsubst) ireq_iface+    lcl_iface <- tcRnModIface (thisUnitIdInsts dflags) (Just nsubst) lcl_iface0+    let ifaces = lcl_iface : ext_ifaces++    -- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env+    let fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f)+                            | (occ, f) <- concatMap mi_fixities ifaces+                            , rdr_elt <- lookupGlobalRdrEnv rdr_env occ ]++    -- STEP 5: Typecheck the interfaces+    let type_env_var = tcg_type_env_var tcg_env++    -- typecheckIfacesForMerging does two things:+    --      1. It merges the all of the ifaces together, and typechecks the+    --      result to type_env.+    --      2. It typechecks each iface individually, but with their 'Name's+    --      resolving to the merged type_env from (1).+    -- See typecheckIfacesForMerging for more details.+    (type_env, detailss) <- initIfaceTcRn $+                            typecheckIfacesForMerging inner_mod ifaces type_env_var+    let infos = zip ifaces detailss++    -- Test for cycles+    checkSynCycles (thisPackage dflags) (typeEnvTyCons type_env) []++    -- NB on type_env: it contains NO dfuns.  DFuns are recorded inside+    -- detailss, and given a Name that doesn't correspond to anything real.  See+    -- also Note [Signature merging DFuns]++    -- Add the merged type_env to TcGblEnv, so that it gets serialized+    -- out when we finally write out the interface.+    --+    -- NB: Why do we set tcg_tcs/tcg_patsyns/tcg_type_env directly,+    -- rather than use tcExtendGlobalEnv (the normal method to add newly+    -- defined types to TcGblEnv?)  tcExtendGlobalEnv adds these+    -- TyThings to 'tcg_type_env_var', which is consulted when+    -- we read in interfaces to tie the knot.  But *these TyThings themselves+    -- come from interface*, so that would result in deadlock.  Don't+    -- update it!+    setGblEnv tcg_env {+        tcg_tcs = typeEnvTyCons type_env,+        tcg_patsyns = typeEnvPatSyns type_env,+        tcg_type_env = type_env,+        tcg_fix_env = fix_env+        } $ do+    tcg_env <- getGblEnv++    -- STEP 6: Check for compatibility/merge things+    tcg_env <- (\x -> foldM x tcg_env infos)+             $ \tcg_env (iface, details) -> do++        let check_export name+              | Just sig_thing <- lookupTypeEnv (md_types details) name+              = case lookupTypeEnv type_env (getName sig_thing) of+                  Just thing -> checkHsigDeclM iface sig_thing thing+                  Nothing -> panic "mergeSignatures: check_export"+              -- Oops! We're looking for this export but it's+              -- not actually in the type environment of the signature's+              -- ModDetails.+              --+              -- NB: This case happens because the we're iterating+              -- over the union of all exports, so some interfaces+              -- won't have everything.  Note that md_exports is nonsense+              -- (it's the same as exports); maybe we should fix this+              -- eventually.+              | otherwise+              = return ()+        mapM_ check_export (map availName exports)++        -- Note [Signature merging instances]+        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+        -- Merge instances into the global environment.  The algorithm here is+        -- dumb and simple: if an instance has exactly the same DFun type+        -- (tested by 'memberInstEnv') as an existing instance, we drop it;+        -- otherwise, we add it even, even if this would cause overlap.+        --+        -- Why don't we deduplicate instances with identical heads?  There's no+        -- good choice if they have premises:+        --+        --      instance K1 a => K (T a)+        --      instance K2 a => K (T a)+        --+        -- Why not eagerly error in this case?  The overlapping head does not+        -- necessarily mean that the instances are unimplementable: in fact,+        -- they may be implemented without overlap (if, for example, the+        -- implementing module has 'instance K (T a)'; both are implemented in+        -- this case.)  The implements test just checks that the wanteds are+        -- derivable assuming the givens.+        --+        -- Still, overlapping instances with hypotheses like above are going+        -- to be a bad deal, because instance resolution when we're typechecking+        -- against the merged signature is going to have a bad time when+        -- there are overlapping heads like this: we never backtrack, so it+        -- may be difficult to see that a wanted is derivable.  For now,+        -- we hope that we get lucky / the overlapping instances never+        -- get used, but it is not a very good situation to be in.+        --+        let merge_inst (insts, inst_env) inst+                | memberInstEnv inst_env inst -- test DFun Type equality+                = (insts, inst_env)+                | otherwise+                -- NB: is_dfun_name inst is still nonsense here,+                -- see Note [Signature merging DFuns]+                = (inst:insts, extendInstEnv inst_env inst)+            (insts, inst_env) = foldl' merge_inst+                                    (tcg_insts tcg_env, tcg_inst_env tcg_env)+                                    (md_insts details)+            -- This is a HACK to prevent calculateAvails from including imp_mod+            -- in the listing.  We don't want it because a module is NOT+            -- supposed to include itself in its dep_orphs/dep_finsts.  See #13214+            iface' = iface { mi_orphan = False, mi_finsts = False }+            avails = plusImportAvails (tcg_imports tcg_env) $+                        calculateAvails dflags iface' False False ImportedBySystem+        return tcg_env {+            tcg_inst_env = inst_env,+            tcg_insts    = insts,+            tcg_imports  = avails,+            tcg_merged   =+                if outer_mod == mi_module iface+                    -- Don't add ourselves!+                    then tcg_merged tcg_env+                    else (mi_module iface, mi_mod_hash iface) : tcg_merged tcg_env+            }++    -- Note [Signature merging DFuns]+    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    -- Once we know all of instances which will be defined by this merged+    -- signature, we go through each of the DFuns and rename them with a fresh,+    -- new, unique DFun Name, and add these DFuns to tcg_type_env (thus fixing+    -- up the "bogus" names that were setup in 'typecheckIfacesForMerging'.+    --+    -- We can't do this fixup earlier, because we need a way to identify each+    -- source DFun (from each of the signatures we are merging in) so that+    -- when we have a ClsInst, we can pull up the correct DFun to check if+    -- the types match.+    --+    -- See also Note [rnIfaceNeverExported] in RnModIface+    dfun_insts <- forM (tcg_insts tcg_env) $ \inst -> do+        n <- newDFunName (is_cls inst) (is_tys inst) (nameSrcSpan (is_dfun_name inst))+        let dfun = setVarName (is_dfun inst) n+        return (dfun, inst { is_dfun_name = n, is_dfun = dfun })+    tcg_env <- return tcg_env {+            tcg_insts = map snd dfun_insts,+            tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) (map fst dfun_insts)+        }++    addDependentFiles src_files++    return tcg_env++-- | Top-level driver for signature instantiation (run when compiling+-- an @hsig@ file.)+tcRnInstantiateSignature ::+    HscEnv -> Module -> RealSrcSpan ->+    IO (Messages, Maybe TcGblEnv)+tcRnInstantiateSignature hsc_env this_mod real_loc =+   withTiming (pure dflags)+              (text "Signature instantiation"<+>brackets (ppr this_mod))+              (const ()) $+   initTc hsc_env HsigFile False this_mod real_loc $ instantiateSignature+  where+   dflags = hsc_dflags hsc_env++exportOccs :: [AvailInfo] -> [OccName]+exportOccs = concatMap (map occName . availNames)++impl_msg :: Module -> IndefModule -> SDoc+impl_msg impl_mod (IndefModule req_uid req_mod_name) =+  text "while checking that" <+> ppr impl_mod <+>+  text "implements signature" <+> ppr req_mod_name <+>+  text "in" <+> ppr req_uid++-- | Check if module implements a signature.  (The signature is+-- always un-hashed, which is why its components are specified+-- explicitly.)+checkImplements :: Module -> IndefModule -> TcRn TcGblEnv+checkImplements impl_mod req_mod@(IndefModule uid mod_name) =+  addErrCtxt (impl_msg impl_mod req_mod) $ do+    let insts = indefUnitIdInsts uid++    -- STEP 1: Load the implementing interface, and make a RdrEnv+    -- for its exports.  Also, add its 'ImportAvails' to 'tcg_imports',+    -- so that we treat all orphan instances it provides as visible+    -- when we verify that all instances are checked (see #12945), and so that+    -- when we eventually write out the interface we record appropriate+    -- dependency information.+    impl_iface <- initIfaceTcRn $+        loadSysInterface (text "checkImplements 1") impl_mod+    let impl_gr = mkGlobalRdrEnv+                    (gresFromAvails Nothing (mi_exports impl_iface))+        nsubst = mkNameShape (moduleName impl_mod) (mi_exports impl_iface)++    -- Load all the orphans, so the subsequent 'checkHsigIface' sees+    -- all the instances it needs to+    loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)")+                         (dep_orphs (mi_deps impl_iface))++    dflags <- getDynFlags+    let avails = calculateAvails dflags+                    impl_iface False{- safe -} False{- boot -} ImportedBySystem+        fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f)+                            | (occ, f) <- mi_fixities impl_iface+                            , rdr_elt <- lookupGlobalRdrEnv impl_gr occ ]+    updGblEnv (\tcg_env -> tcg_env {+        -- Setting tcg_rdr_env to treat all exported entities from+        -- the implementing module as in scope improves error messages,+        -- as it reduces the amount of qualification we need.  Unfortunately,+        -- we still end up qualifying references to external modules+        -- (see bkpfail07 for an example); we'd need to record more+        -- information in ModIface to solve this.+        tcg_rdr_env = tcg_rdr_env tcg_env `plusGlobalRdrEnv` impl_gr,+        tcg_imports = tcg_imports tcg_env `plusImportAvails` avails,+        -- This is here so that when we call 'lookupFixityRn' for something+        -- directly implemented by the module, we grab the right thing+        tcg_fix_env = fix_env+        }) $ do++    -- STEP 2: Load the *unrenamed, uninstantiated* interface for+    -- the ORIGINAL signature.  We are going to eventually rename it,+    -- but we must proceed slowly, because it is NOT known if the+    -- instantiation is correct.+    let sig_mod = mkModule (IndefiniteUnitId uid) mod_name+        isig_mod = fst (splitModuleInsts sig_mod)+    mb_isig_iface <- findAndReadIface (text "checkImplements 2") isig_mod sig_mod False+    isig_iface <- case mb_isig_iface of+        Succeeded (iface, _) -> return iface+        Failed err -> failWithTc $+            hang (text "Could not find hi interface for signature" <+>+                  quotes (ppr isig_mod) <> colon) 4 err++    -- STEP 3: Check that the implementing interface exports everything+    -- we need.  (Notice we IGNORE the Modules in the AvailInfos.)+    forM_ (exportOccs (mi_exports isig_iface)) $ \occ ->+        case lookupGlobalRdrEnv impl_gr occ of+            [] -> addErr $ quotes (ppr occ)+                    <+> text "is exported by the hsig file, but not"+                    <+> text "exported by the implementing module"+                    <+> quotes (ppr impl_mod)+            _ -> return ()+    failIfErrsM++    -- STEP 4: Now that the export is complete, rename the interface...+    sig_iface <- tcRnModIface insts (Just nsubst) isig_iface++    -- STEP 5: ...and typecheck it.  (Note that in both cases, the nsubst+    -- lets us determine how top-level identifiers should be handled.)+    sig_details <- initIfaceTcRn $ typecheckIfaceForInstantiate nsubst sig_iface++    -- STEP 6: Check that it's sufficient+    tcg_env <- getGblEnv+    checkHsigIface tcg_env impl_gr sig_iface sig_details++    -- STEP 7: Return the updated 'TcGblEnv' with the signature exports,+    -- so we write them out.+    return tcg_env {+        tcg_exports = mi_exports sig_iface+        }++-- | Given 'tcg_mod', instantiate a 'ModIface' from the indefinite+-- library to use the actual implementations of the relevant entities,+-- checking that the implementation matches the signature.+instantiateSignature :: TcRn TcGblEnv+instantiateSignature = do+    tcg_env <- getGblEnv+    dflags <- getDynFlags+    let outer_mod = tcg_mod tcg_env+        inner_mod = tcg_semantic_mod tcg_env+    -- TODO: setup the local RdrEnv so the error messages look a little better.+    -- But this information isn't stored anywhere. Should we RETYPECHECK+    -- the local one just to get the information?  Hmm...+    MASSERT( moduleUnitId outer_mod == thisPackage dflags )+    inner_mod `checkImplements`+        IndefModule+            (newIndefUnitId (thisComponentId dflags)+                            (thisUnitIdInsts dflags))+            (moduleName outer_mod)
+ typecheck/TcBinds.hs view
@@ -0,0 +1,1730 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[TcBinds]{TcBinds}+-}++{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}++module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,+                 tcHsBootSigs, tcPolyCheck,+                 tcVectDecls, addTypecheckedBinds,+                 chooseInferredQuantifiers,+                 badBootDeclErr ) where++import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )+import {-# SOURCE #-} TcExpr  ( tcMonoExpr )+import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl+                               , tcPatSynBuilderBind )+import CoreSyn (Tickish (..))+import CostCentre (mkUserCC)+import DynFlags+import FastString+import HsSyn+import HscTypes( isHsBootOrSig )+import TcSigs+import TcRnMonad+import TcEnv+import TcUnify+import TcSimplify+import TcEvidence+import TcHsType+import TcPat+import TcMType+import FamInstEnv( normaliseType )+import FamInst( tcGetFamInstEnvs )+import TyCon+import TcType+import Type( mkStrLitTy, tidyOpenType, mkTyVarBinder, splitTyConApp_maybe)+import TysPrim+import TysWiredIn( cTupleTyConName )+import Id+import Var+import VarSet+import VarEnv( TidyEnv )+import Module+import Name+import NameSet+import NameEnv+import SrcLoc+import Bag+import ListSetOps+import ErrUtils+import Digraph+import Maybes+import Util+import BasicTypes+import Outputable+import PrelNames( ipClassName )+import TcValidity (checkValidType)+import Unique (getUnique)+import UniqFM+import UniqSet+import qualified GHC.LanguageExtensions as LangExt+import ConLike++import Control.Monad++#include "HsVersions.h"++{- *********************************************************************+*                                                                      *+               A useful helper function+*                                                                      *+********************************************************************* -}++addTypecheckedBinds :: TcGblEnv -> [LHsBinds Id] -> TcGblEnv+addTypecheckedBinds tcg_env binds+  | isHsBootOrSig (tcg_src tcg_env) = tcg_env+    -- Do not add the code for record-selector bindings+    -- when compiling hs-boot files+  | otherwise = tcg_env { tcg_binds = foldr unionBags+                                            (tcg_binds tcg_env)+                                            binds }++{-+************************************************************************+*                                                                      *+\subsection{Type-checking bindings}+*                                                                      *+************************************************************************++@tcBindsAndThen@ typechecks a @HsBinds@.  The "and then" part is because+it needs to know something about the {\em usage} of the things bound,+so that it can create specialisations of them.  So @tcBindsAndThen@+takes a function which, given an extended environment, E, typechecks+the scope of the bindings returning a typechecked thing and (most+important) an LIE.  It is this LIE which is then used as the basis for+specialising the things bound.++@tcBindsAndThen@ also takes a "combiner" which glues together the+bindings and the "thing" to make a new "thing".++The real work is done by @tcBindWithSigsAndThen@.++Recursive and non-recursive binds are handled in essentially the same+way: because of uniques there are no scoping issues left.  The only+difference is that non-recursive bindings can bind primitive values.++Even for non-recursive binding groups we add typings for each binder+to the LVE for the following reason.  When each individual binding is+checked the type of its LHS is unified with that of its RHS; and+type-checking the LHS of course requires that the binder is in scope.++At the top-level the LIE is sure to contain nothing but constant+dictionaries, which we resolve at the module level.++Note [Polymorphic recursion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The game plan for polymorphic recursion in the code above is++        * Bind any variable for which we have a type signature+          to an Id with a polymorphic type.  Then when type-checking+          the RHSs we'll make a full polymorphic call.++This fine, but if you aren't a bit careful you end up with a horrendous+amount of partial application and (worse) a huge space leak. For example:++        f :: Eq a => [a] -> [a]+        f xs = ...f...++If we don't take care, after typechecking we get++        f = /\a -> \d::Eq a -> let f' = f a d+                               in+                               \ys:[a] -> ...f'...++Notice the the stupid construction of (f a d), which is of course+identical to the function we're executing.  In this case, the+polymorphic recursion isn't being used (but that's a very common case).+This can lead to a massive space leak, from the following top-level defn+(post-typechecking)++        ff :: [Int] -> [Int]+        ff = f Int dEqInt++Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but+f' is another thunk which evaluates to the same thing... and you end+up with a chain of identical values all hung onto by the CAF ff.++        ff = f Int dEqInt++           = let f' = f Int dEqInt in \ys. ...f'...++           = let f' = let f' = f Int dEqInt in \ys. ...f'...+                      in \ys. ...f'...++Etc.++NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...),+which would make the space leak go away in this case++Solution: when typechecking the RHSs we always have in hand the+*monomorphic* Ids for each binding.  So we just need to make sure that+if (Method f a d) shows up in the constraints emerging from (...f...)+we just use the monomorphic Id.  We achieve this by adding monomorphic Ids+to the "givens" when simplifying constraints.  That's what the "lies_avail"+is doing.++Then we get++        f = /\a -> \d::Eq a -> letrec+                                 fm = \ys:[a] -> ...fm...+                               in+                               fm+-}++tcTopBinds :: [(RecFlag, LHsBinds Name)] -> [LSig Name] -> TcM (TcGblEnv, TcLclEnv)+-- The TcGblEnv contains the new tcg_binds and tcg_spects+-- The TcLclEnv has an extended type envt for the new bindings+tcTopBinds binds sigs+  = do  { -- Pattern synonym bindings populate the global environment+          (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $+            do { gbl <- getGblEnv+               ; lcl <- getLclEnv+               ; return (gbl, lcl) }+        ; specs <- tcImpPrags sigs   -- SPECIALISE prags for imported Ids++        ; complete_matches <- setEnvs (tcg_env, tcl_env) $ tcCompleteSigs sigs+        ; traceTc "complete_matches" (ppr binds $$ ppr sigs)+        ; traceTc "complete_matches" (ppr complete_matches)++        ; let { tcg_env' = tcg_env { tcg_imp_specs+                                      = specs ++ tcg_imp_specs tcg_env+                                   , tcg_complete_matches+                                      = complete_matches+                                          ++ tcg_complete_matches tcg_env }+                           `addTypecheckedBinds` map snd binds' }++        ; return (tcg_env', tcl_env) }+        -- The top level bindings are flattened into a giant+        -- implicitly-mutually-recursive LHsBinds+++-- Note [Typechecking Complete Matches]+-- Much like when a user bundled a pattern synonym, the result types of+-- all the constructors in the match pragma must be consistent.+--+-- If we allowed pragmas with inconsistent types then it would be+-- impossible to ever match every constructor in the list and so+-- the pragma would be useless.++++++-- This is only used in `tcCompleteSig`. We fold over all the conlikes,+-- this accumulator keeps track of the first `ConLike` with a concrete+-- return type. After fixing the return type, all other constructors with+-- a fixed return type must agree with this.+--+-- The fields of `Fixed` cache the first conlike and its return type so+-- that that we can compare all the other conlikes to it. The conlike is+-- stored for error messages.+--+-- `Nothing` in the case that the type is fixed by a type signature+data CompleteSigType = AcceptAny | Fixed (Maybe ConLike) TyCon++tcCompleteSigs  :: [LSig Name] -> TcM [CompleteMatch]+tcCompleteSigs sigs =+  let+      doOne :: Sig Name -> TcM (Maybe CompleteMatch)+      doOne c@(CompleteMatchSig _ lns mtc)+        = fmap Just $ do+           addErrCtxt (text "In" <+> ppr c) $+            case mtc of+              Nothing -> infer_complete_match+              Just tc -> check_complete_match tc+        where++          checkCLTypes acc = foldM checkCLType (acc, []) (unLoc lns)++          infer_complete_match = do+            (res, cls) <- checkCLTypes AcceptAny+            case res of+              AcceptAny -> failWithTc ambiguousError+              Fixed _ tc  -> return $ mkMatch cls tc++          check_complete_match tc_name = do+            ty_con <- tcLookupLocatedTyCon tc_name+            (_, cls) <- checkCLTypes (Fixed Nothing ty_con)+            return $ mkMatch cls ty_con++          mkMatch :: [ConLike] -> TyCon -> CompleteMatch+          mkMatch cls ty_con = CompleteMatch {+            completeMatchConLikes = map conLikeName cls,+            completeMatchTyCon = tyConName ty_con+            }+      doOne _ = return Nothing++      ambiguousError :: SDoc+      ambiguousError =+        text "A type signature must be provided for a set of polymorphic"+          <+> text "pattern synonyms."+++      -- See note [Typechecking Complete Matches]+      checkCLType :: (CompleteSigType, [ConLike]) -> Located Name+                  -> TcM (CompleteSigType, [ConLike])+      checkCLType (cst, cs) n = do+        cl <- addLocM tcLookupConLike n+        let   (_,_,_,_,_,_, res_ty) = conLikeFullSig cl+              res_ty_con = fst <$> splitTyConApp_maybe res_ty+        case (cst, res_ty_con) of+          (AcceptAny, Nothing) -> return (AcceptAny, cl:cs)+          (AcceptAny, Just tc) -> return (Fixed (Just cl) tc, cl:cs)+          (Fixed mfcl tc, Nothing)  -> return (Fixed mfcl tc, cl:cs)+          (Fixed mfcl tc, Just tc') ->+            if tc == tc'+              then return (Fixed mfcl tc, cl:cs)+              else case mfcl of+                     Nothing ->+                      addErrCtxt (text "In" <+> ppr cl) $+                        failWithTc typeSigErrMsg+                     Just cl -> failWithTc (errMsg cl)+             where+              typeSigErrMsg :: SDoc+              typeSigErrMsg =+                text "Couldn't match expected type"+                      <+> quotes (ppr tc)+                      <+> text "with"+                      <+> quotes (ppr tc')++              errMsg :: ConLike -> SDoc+              errMsg fcl =+                text "Cannot form a group of complete patterns from patterns"+                  <+> quotes (ppr fcl) <+> text "and" <+> quotes (ppr cl)+                  <+> text "as they match different type constructors"+                  <+> parens (quotes (ppr tc)+                               <+> text "resp."+                               <+> quotes (ppr tc'))+  in  mapMaybeM (addLocM doOne) sigs++tcRecSelBinds :: HsValBinds Name -> TcM TcGblEnv+tcRecSelBinds (ValBindsOut binds sigs)+  = tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $+    do { (rec_sel_binds, tcg_env) <- discardWarnings $+                                     tcValBinds TopLevel binds sigs getGblEnv+       ; let tcg_env' = tcg_env `addTypecheckedBinds` map snd rec_sel_binds+       ; return tcg_env' }+tcRecSelBinds (ValBindsIn {}) = panic "tcRecSelBinds"++tcHsBootSigs :: [(RecFlag, LHsBinds Name)] -> [LSig Name] -> TcM [Id]+-- A hs-boot file has only one BindGroup, and it only has type+-- signatures in it.  The renamer checked all this+tcHsBootSigs binds sigs+  = do  { checkTc (null binds) badBootDeclErr+        ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }+  where+    tc_boot_sig (TypeSig lnames hs_ty) = mapM f lnames+      where+        f (L _ name)+          = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty+               ; return (mkVanillaGlobal name sigma_ty) }+        -- Notice that we make GlobalIds, not LocalIds+    tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)++badBootDeclErr :: MsgDoc+badBootDeclErr = text "Illegal declarations in an hs-boot file"++------------------------+tcLocalBinds :: HsLocalBinds Name -> TcM thing+             -> TcM (HsLocalBinds TcId, thing)++tcLocalBinds EmptyLocalBinds thing_inside+  = do  { thing <- thing_inside+        ; return (EmptyLocalBinds, thing) }++tcLocalBinds (HsValBinds (ValBindsOut binds sigs)) thing_inside+  = do  { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside+        ; return (HsValBinds (ValBindsOut binds' sigs), thing) }+tcLocalBinds (HsValBinds (ValBindsIn {})) _ = panic "tcLocalBinds"++tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside+  = do  { ipClass <- tcLookupClass ipClassName+        ; (given_ips, ip_binds') <-+            mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds++        -- If the binding binds ?x = E, we  must now+        -- discharge any ?x constraints in expr_lie+        -- See Note [Implicit parameter untouchables]+        ; (ev_binds, result) <- checkConstraints (IPSkol ips)+                                  [] given_ips thing_inside++        ; return (HsIPBinds (IPBinds ip_binds' ev_binds), result) }+  where+    ips = [ip | L _ (IPBind (Left (L _ ip)) _) <- ip_binds]++        -- I wonder if we should do these one at at time+        -- Consider     ?x = 4+        --              ?y = ?x + 1+    tc_ip_bind ipClass (IPBind (Left (L _ ip)) expr)+       = do { ty <- newOpenFlexiTyVarTy+            ; let p = mkStrLitTy $ hsIPNameFS ip+            ; ip_id <- newDict ipClass [ p, ty ]+            ; expr' <- tcMonoExpr expr (mkCheckExpType ty)+            ; let d = toDict ipClass p ty `fmap` expr'+            ; return (ip_id, (IPBind (Right ip_id) d)) }+    tc_ip_bind _ (IPBind (Right {}) _) = panic "tc_ip_bind"++    -- Coerces a `t` into a dictionry for `IP "x" t`.+    -- co : t -> IP "x" t+    toDict ipClass x ty = HsWrap $ mkWpCastR $+                          wrapIP $ mkClassPred ipClass [x,ty]++{- Note [Implicit parameter untouchables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We add the type variables in the types of the implicit parameters+as untouchables, not so much because we really must not unify them,+but rather because we otherwise end up with constraints like this+    Num alpha, Implic { wanted = alpha ~ Int }+The constraint solver solves alpha~Int by unification, but then+doesn't float that solved constraint out (it's not an unsolved+wanted).  Result disaster: the (Num alpha) is again solved, this+time by defaulting.  No no no.++However [Oct 10] this is all handled automatically by the+untouchable-range idea.+-}++tcValBinds :: TopLevelFlag+           -> [(RecFlag, LHsBinds Name)] -> [LSig Name]+           -> TcM thing+           -> TcM ([(RecFlag, LHsBinds TcId)], thing)++tcValBinds top_lvl binds sigs thing_inside+  = do  { let patsyns = getPatSynBinds binds++            -- Typecheck the signature+        ; (poly_ids, sig_fn) <- tcAddPatSynPlaceholders patsyns $+                                tcTySigs sigs++        ; let prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds)++                -- Extend the envt right away with all the Ids+                -- declared with complete type signatures+                -- Do not extend the TcIdBinderStack; instead+                -- we extend it on a per-rhs basis in tcExtendForRhs+        ; tcExtendSigIds top_lvl poly_ids $ do+            { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do+                   { thing <- thing_inside+                     -- See Note [Pattern synonym builders don't yield dependencies]+                     --     in RnBinds+                   ; patsyn_builders <- mapM tcPatSynBuilderBind patsyns+                   ; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ]+                   ; return (extra_binds, thing) }+            ; return (binds' ++ extra_binds', thing) }}++------------------------+tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv+             -> [(RecFlag, LHsBinds Name)] -> TcM thing+             -> TcM ([(RecFlag, LHsBinds TcId)], thing)+-- Typecheck a whole lot of value bindings,+-- one strongly-connected component at a time+-- Here a "strongly connected component" has the strightforward+-- meaning of a group of bindings that mention each other,+-- ignoring type signatures (that part comes later)++tcBindGroups _ _ _ [] thing_inside+  = do  { thing <- thing_inside+        ; return ([], thing) }++tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside+  = do  { -- See Note [Closed binder groups]+          type_env <- getLclTypeEnv+        ; let closed = isClosedBndrGroup type_env (snd group)+        ; (group', (groups', thing))+                <- tc_group top_lvl sig_fn prag_fn group closed $+                   tcBindGroups top_lvl sig_fn prag_fn groups thing_inside+        ; return (group' ++ groups', thing) }++-- Note [Closed binder groups]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+--  A mutually recursive group is "closed" if all of the free variables of+--  the bindings are closed. For example+--+-- >  h = \x -> let f = ...g...+-- >                g = ....f...x...+-- >             in ...+--+-- Here @g@ is not closed because it mentions @x@; and hence neither is @f@+-- closed.+--+-- So we need to compute closed-ness on each strongly connected components,+-- before we sub-divide it based on what type signatures it has.+--++------------------------+tc_group :: forall thing.+            TopLevelFlag -> TcSigFun -> TcPragEnv+         -> (RecFlag, LHsBinds Name) -> IsGroupClosed -> TcM thing+         -> TcM ([(RecFlag, LHsBinds TcId)], thing)++-- Typecheck one strongly-connected component of the original program.+-- We get a list of groups back, because there may+-- be specialisations etc as well++tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) closed thing_inside+        -- A single non-recursive binding+        -- We want to keep non-recursive things non-recursive+        -- so that we desugar unlifted bindings correctly+  = do { let bind = case bagToList binds of+                 [bind] -> bind+                 []     -> panic "tc_group: empty list of binds"+                 _      -> panic "tc_group: NonRecursive binds is not a singleton bag"+       ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind closed+                                     thing_inside+       ; return ( [(NonRecursive, bind')], thing) }++tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside+  =     -- To maximise polymorphism, we do a new+        -- strongly-connected-component analysis, this time omitting+        -- any references to variables with type signatures.+        -- (This used to be optional, but isn't now.)+        -- See Note [Polymorphic recursion] in HsBinds.+    do  { traceTc "tc_group rec" (pprLHsBinds binds)+        ; when hasPatSyn $ recursivePatSynErr binds+        ; (binds1, thing) <- go sccs+        ; return ([(Recursive, binds1)], thing) }+                -- Rec them all together+  where+    hasPatSyn = anyBag (isPatSyn . unLoc) binds+    isPatSyn PatSynBind{} = True+    isPatSyn _ = False++    sccs :: [SCC (LHsBind Name)]+    sccs = stronglyConnCompFromEdgedVerticesUniq (mkEdges sig_fn binds)++    go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, thing)+    go (scc:sccs) = do  { (binds1, ids1) <- tc_scc scc+                        ; (binds2, thing) <- tcExtendLetEnv top_lvl sig_fn+                                                            closed ids1 $+                                             go sccs+                        ; return (binds1 `unionBags` binds2, thing) }+    go []         = do  { thing <- thing_inside; return (emptyBag, thing) }++    tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]+    tc_scc (CyclicSCC binds) = tc_sub_group Recursive    binds++    tc_sub_group rec_tc binds =+      tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds++recursivePatSynErr :: OutputableBndr name => LHsBinds name -> TcM a+recursivePatSynErr binds+  = failWithTc $+    hang (text "Recursive pattern synonym definition with following bindings:")+       2 (vcat $ map pprLBind . bagToList $ binds)+  where+    pprLoc loc  = parens (text "defined at" <+> ppr loc)+    pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) <+>+                            pprLoc loc++tc_single :: forall thing.+            TopLevelFlag -> TcSigFun -> TcPragEnv+          -> LHsBind Name -> IsGroupClosed -> TcM thing+          -> TcM (LHsBinds TcId, thing)+tc_single _top_lvl sig_fn _prag_fn+          (L _ (PatSynBind psb@PSB{ psb_id = L _ name }))+          _ thing_inside+  = do { (aux_binds, tcg_env) <- tc_pat_syn_decl+       ; thing <- setGblEnv tcg_env thing_inside+       ; return (aux_binds, thing)+       }+  where+    tc_pat_syn_decl :: TcM (LHsBinds TcId, TcGblEnv)+    tc_pat_syn_decl = case sig_fn name of+        Nothing                 -> tcInferPatSynDecl psb+        Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi+        Just                 _  -> panic "tc_single"++tc_single top_lvl sig_fn prag_fn lbind closed thing_inside+  = do { (binds1, ids) <- tcPolyBinds sig_fn prag_fn+                                      NonRecursive NonRecursive+                                      closed+                                      [lbind]+       ; thing <- tcExtendLetEnv top_lvl sig_fn closed ids thing_inside+       ; return (binds1, thing) }++------------------------+type BKey = Int -- Just number off the bindings++mkEdges :: TcSigFun -> LHsBinds Name -> [Node BKey (LHsBind Name)]+-- See Note [Polymorphic recursion] in HsBinds.+mkEdges sig_fn binds+  = [ (bind, key, [key | n <- nonDetEltsUniqSet (bind_fvs (unLoc bind)),+                         Just key <- [lookupNameEnv key_map n], no_sig n ])+    | (bind, key) <- keyd_binds+    ]+    -- It's OK to use nonDetEltsUFM here as stronglyConnCompFromEdgedVertices+    -- is still deterministic even if the edges are in nondeterministic order+    -- as explained in Note [Deterministic SCC] in Digraph.+  where+    no_sig :: Name -> Bool+    no_sig n = not (hasCompleteSig sig_fn n)++    keyd_binds = bagToList binds `zip` [0::BKey ..]++    key_map :: NameEnv BKey     -- Which binding it comes from+    key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds+                                     , bndr <- collectHsBindBinders bind ]++------------------------+tcPolyBinds :: TcSigFun -> TcPragEnv+            -> RecFlag         -- Whether the group is really recursive+            -> RecFlag         -- Whether it's recursive after breaking+                               -- dependencies based on type signatures+            -> IsGroupClosed   -- Whether the group is closed+            -> [LHsBind Name]  -- None are PatSynBind+            -> TcM (LHsBinds TcId, [TcId])++-- Typechecks a single bunch of values bindings all together,+-- and generalises them.  The bunch may be only part of a recursive+-- group, because we use type signatures to maximise polymorphism+--+-- Returns a list because the input may be a single non-recursive binding,+-- in which case the dependency order of the resulting bindings is+-- important.+--+-- Knows nothing about the scope of the bindings+-- None of the bindings are pattern synonyms++tcPolyBinds sig_fn prag_fn rec_group rec_tc closed bind_list+  = setSrcSpan loc                              $+    recoverM (recoveryCode binder_names sig_fn) $ do+        -- Set up main recover; take advantage of any type sigs++    { traceTc "------------------------------------------------" Outputable.empty+    ; traceTc "Bindings for {" (ppr binder_names)+    ; dflags   <- getDynFlags+    ; let plan = decideGeneralisationPlan dflags bind_list closed sig_fn+    ; traceTc "Generalisation plan" (ppr plan)+    ; result@(_, poly_ids) <- case plan of+         NoGen              -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list+         InferGen mn        -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list+         CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind++    ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group+                                            , vcat [ppr id <+> ppr (idType id) | id <- poly_ids]+                                          ])++    ; return result }+  where+    binder_names = collectHsBindListBinders bind_list+    loc = foldr1 combineSrcSpans (map getLoc bind_list)+         -- The mbinds have been dependency analysed and+         -- may no longer be adjacent; so find the narrowest+         -- span that includes them all++--------------+-- If typechecking the binds fails, then return with each+-- signature-less binder given type (forall a.a), to minimise+-- subsequent error messages+recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds TcId, [Id])+recoveryCode binder_names sig_fn+  = do  { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)+        ; let poly_ids = map mk_dummy binder_names+        ; return (emptyBag, poly_ids) }+  where+    mk_dummy name+      | Just sig <- sig_fn name+      , Just poly_id <- completeSigPolyId_maybe sig+      = poly_id+      | otherwise+      = mkLocalId name forall_a_a++forall_a_a :: TcType+forall_a_a = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] openAlphaTy++{- *********************************************************************+*                                                                      *+                         tcPolyNoGen+*                                                                      *+********************************************************************* -}++tcPolyNoGen     -- No generalisation whatsoever+  :: RecFlag       -- Whether it's recursive after breaking+                   -- dependencies based on type signatures+  -> TcPragEnv -> TcSigFun+  -> [LHsBind Name]+  -> TcM (LHsBinds TcId, [TcId])++tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list+  = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn+                                             (LetGblBndr prag_fn)+                                             bind_list+       ; mono_ids' <- mapM tc_mono_info mono_infos+       ; return (binds', mono_ids') }+  where+    tc_mono_info (MBI { mbi_poly_name = name, mbi_mono_id = mono_id })+      = do { _specs <- tcSpecPrags mono_id (lookupPragEnv prag_fn name)+           ; return mono_id }+           -- NB: tcPrags generates error messages for+           --     specialisation pragmas for non-overloaded sigs+           -- Indeed that is why we call it here!+           -- So we can safely ignore _specs+++{- *********************************************************************+*                                                                      *+                         tcPolyCheck+*                                                                      *+********************************************************************* -}++tcPolyCheck :: TcPragEnv+            -> TcIdSigInfo     -- Must be a complete signature+            -> LHsBind Name    -- Must be a FunBind+            -> TcM (LHsBinds TcId, [TcId])+-- There is just one binding,+--   it is a Funbind+--   it has a complete type signature,+tcPolyCheck prag_fn+            (CompleteSig { sig_bndr  = poly_id+                         , sig_ctxt  = ctxt+                         , sig_loc   = sig_loc })+            (L loc (FunBind { fun_id = L nm_loc name+                            , fun_matches = matches }))+  = setSrcSpan sig_loc $+    do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc)+       ; (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id+                -- See Note [Instantiate sig with fresh variables]++       ; mono_name <- newNameAt (nameOccName name) nm_loc+       ; ev_vars   <- newEvVars theta+       ; let mono_id   = mkLocalId mono_name tau+             skol_info = SigSkol ctxt (idType poly_id) tv_prs+             skol_tvs  = map snd tv_prs++       ; (ev_binds, (co_fn, matches'))+            <- checkConstraints skol_info skol_tvs ev_vars $+               tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel]  $+               tcExtendTyVarEnv2 tv_prs $+               setSrcSpan loc           $+               tcMatchesFun (L nm_loc mono_name) matches (mkCheckExpType tau)++       ; let prag_sigs = lookupPragEnv prag_fn name+       ; spec_prags <- tcSpecPrags poly_id prag_sigs+       ; poly_id    <- addInlinePrags poly_id prag_sigs++       ; mod <- getModule+       ; let bind' = FunBind { fun_id      = L nm_loc mono_id+                             , fun_matches = matches'+                             , fun_co_fn   = co_fn+                             , bind_fvs    = placeHolderNamesTc+                             , fun_tick    = funBindTicks nm_loc mono_id mod prag_sigs }++             abs_bind = L loc $ AbsBindsSig+                        { abs_sig_export  = poly_id+                        , abs_tvs         = skol_tvs+                        , abs_ev_vars     = ev_vars+                        , abs_sig_prags   = SpecPrags spec_prags+                        , abs_sig_ev_bind = ev_binds+                        , abs_sig_bind    = L loc bind' }++       ; return (unitBag abs_bind, [poly_id]) }++tcPolyCheck _prag_fn sig bind+  = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind)++funBindTicks :: SrcSpan -> TcId -> Module -> [LSig Name] -> [Tickish TcId]+funBindTicks loc fun_id mod sigs+  | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ cc_name) <- sigs ]+      -- this can only be a singleton list, as duplicate pragmas are rejected+      -- by the renamer+  , let cc_str+          | Just cc_str <- mb_cc_str+          = sl_fs $ unLoc cc_str+          | otherwise+          = getOccFS (Var.varName fun_id)+        cc_name = moduleNameFS (moduleName mod) `appendFS` consFS '.' cc_str+        cc = mkUserCC cc_name mod loc (getUnique fun_id)+  = [ProfNote cc True True]+  | otherwise+  = []++{- Note [Instantiate sig with fresh variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's vital to instantiate a type signature with fresh variables.+For example:+      type T = forall a. [a] -> [a]+      f :: T;+      f = g where { g :: T; g = <rhs> }++ We must not use the same 'a' from the defn of T at both places!!+(Instantiation is only necessary because of type synonyms.  Otherwise,+it's all cool; each signature has distinct type variables from the renamer.)+-}+++{- *********************************************************************+*                                                                      *+                         tcPolyInfer+*                                                                      *+********************************************************************* -}++tcPolyInfer+  :: RecFlag       -- Whether it's recursive after breaking+                   -- dependencies based on type signatures+  -> TcPragEnv -> TcSigFun+  -> Bool         -- True <=> apply the monomorphism restriction+  -> [LHsBind Name]+  -> TcM (LHsBinds TcId, [TcId])+tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list+  = do { (tclvl, wanted, (binds', mono_infos))+             <- pushLevelAndCaptureConstraints  $+                tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list++       ; let name_taus  = [ (mbi_poly_name info, idType (mbi_mono_id info))+                          | info <- mono_infos ]+             sigs       = [ sig | MBI { mbi_sig = Just sig } <- mono_infos ]+             infer_mode = if mono then ApplyMR else NoRestrictions++       ; mapM_ (checkOverloadedSig mono) sigs++       ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted)+       ; (qtvs, givens, ev_binds)+                 <- simplifyInfer tclvl infer_mode sigs name_taus wanted++       ; let inferred_theta = map evVarPred givens+       ; exports <- checkNoErrs $+                    mapM (mkExport prag_fn qtvs inferred_theta) mono_infos++       ; loc <- getSrcSpanM+       ; let poly_ids = map abe_poly exports+             abs_bind = L loc $+                        AbsBinds { abs_tvs = qtvs+                                 , abs_ev_vars = givens, abs_ev_binds = [ev_binds]+                                 , abs_exports = exports, abs_binds = binds' }++       ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids))+       ; return (unitBag abs_bind, poly_ids) }+         -- poly_ids are guaranteed zonked by mkExport++--------------+mkExport :: TcPragEnv+         -> [TyVar] -> TcThetaType      -- Both already zonked+         -> MonoBindInfo+         -> TcM (ABExport Id)+-- Only called for generalisation plan InferGen, not by CheckGen or NoGen+--+-- mkExport generates exports with+--      zonked type variables,+--      zonked poly_ids+-- The former is just because no further unifications will change+-- the quantified type variables, so we can fix their final form+-- right now.+-- The latter is needed because the poly_ids are used to extend the+-- type environment; see the invariant on TcEnv.tcExtendIdEnv++-- Pre-condition: the qtvs and theta are already zonked++mkExport prag_fn qtvs theta+         mono_info@(MBI { mbi_poly_name = poly_name+                        , mbi_sig       = mb_sig+                        , mbi_mono_id   = mono_id })+  = do  { mono_ty <- zonkTcType (idType mono_id)+        ; poly_id <- mkInferredPolyId qtvs theta poly_name mb_sig mono_ty++        -- NB: poly_id has a zonked type+        ; poly_id <- addInlinePrags poly_id prag_sigs+        ; spec_prags <- tcSpecPrags poly_id prag_sigs+                -- tcPrags requires a zonked poly_id++        -- See Note [Impedance matching]+        -- NB: we have already done checkValidType, including an ambiguity check,+        --     on the type; either when we checked the sig or in mkInferredPolyId+        ; let poly_ty     = idType poly_id+              sel_poly_ty = mkInfSigmaTy qtvs theta mono_ty+                -- This type is just going into tcSubType,+                -- so Inferred vs. Specified doesn't matter++        ; wrap <- if sel_poly_ty `eqType` poly_ty  -- NB: eqType ignores visibility+                  then return idHsWrapper  -- Fast path; also avoids complaint when we infer+                                           -- an ambiguouse type and have AllowAmbiguousType+                                           -- e..g infer  x :: forall a. F a -> Int+                  else addErrCtxtM (mk_impedance_match_msg mono_info sel_poly_ty poly_ty) $+                       tcSubType_NC sig_ctxt sel_poly_ty poly_ty++        ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSignatures+        ; when warn_missing_sigs $+              localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig++        ; return (ABE { abe_wrap = wrap+                        -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty)+                      , abe_poly = poly_id+                      , abe_mono = mono_id+                      , abe_prags = SpecPrags spec_prags}) }+  where+    prag_sigs = lookupPragEnv prag_fn poly_name+    sig_ctxt  = InfSigCtxt poly_name++mkInferredPolyId :: [TyVar] -> TcThetaType+                 -> Name -> Maybe TcIdSigInst -> TcType+                 -> TcM TcId+mkInferredPolyId qtvs inferred_theta poly_name mb_sig_inst mono_ty+  | Just (TISI { sig_inst_sig = sig })  <- mb_sig_inst+  , CompleteSig { sig_bndr = poly_id } <- sig+  = return poly_id++  | otherwise  -- Either no type sig or partial type sig+  = checkNoErrs $  -- The checkNoErrs ensures that if the type is ambiguous+                   -- we don't carry on to the impedance matching, and generate+                   -- a duplicate ambiguity error.  There is a similar+                   -- checkNoErrs for complete type signatures too.+    do { fam_envs <- tcGetFamInstEnvs+       ; let (_co, mono_ty') = normaliseType fam_envs Nominal mono_ty+               -- Unification may not have normalised the type,+               -- (see Note [Lazy flattening] in TcFlatten) so do it+               -- here to make it as uncomplicated as possible.+               -- Example: f :: [F Int] -> Bool+               -- should be rewritten to f :: [Char] -> Bool, if possible+               --+               -- We can discard the coercion _co, because we'll reconstruct+               -- it in the call to tcSubType below++       ; (binders, theta') <- chooseInferredQuantifiers inferred_theta+                                (tyCoVarsOfType mono_ty') qtvs mb_sig_inst++       ; let inferred_poly_ty = mkForAllTys binders (mkPhiTy theta' mono_ty')++       ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr theta'+                                          , ppr inferred_poly_ty])+       ; addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $+         checkValidType (InfSigCtxt poly_name) inferred_poly_ty+         -- See Note [Validity of inferred types]++       ; return (mkLocalIdOrCoVar poly_name inferred_poly_ty) }+++chooseInferredQuantifiers :: TcThetaType   -- inferred+                          -> TcTyVarSet    -- tvs free in tau type+                          -> [TcTyVar]     -- inferred quantified tvs+                          -> Maybe TcIdSigInst+                          -> TcM ([TyVarBinder], TcThetaType)+chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing+  = -- No type signature (partial or complete) for this binder,+    do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs)+                        -- Include kind variables!  Trac #7916+             my_theta = pickCapturedPreds free_tvs inferred_theta+             binders  = [ mkTyVarBinder Inferred tv+                        | tv <- qtvs+                        , tv `elemVarSet` free_tvs ]+       ; return (binders, my_theta) }++chooseInferredQuantifiers inferred_theta tau_tvs qtvs+                          (Just (TISI { sig_inst_sig   = sig  -- Always PartialSig+                                      , sig_inst_wcx   = wcx+                                      , sig_inst_theta = annotated_theta+                                      , sig_inst_skols = annotated_tvs }))+  | Nothing <- wcx+  = do { annotated_theta <- zonkTcTypes annotated_theta+       ; let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta+                                        `unionVarSet` tau_tvs)+       ; traceTc "ciq" (vcat [ ppr sig, ppr annotated_theta, ppr free_tvs])+       ; psig_qtvs <- mk_psig_qtvs annotated_tvs+       ; return (mk_final_qtvs psig_qtvs free_tvs, annotated_theta) }++  | Just wc_var <- wcx+  = do { annotated_theta <- zonkTcTypes annotated_theta+       ; let free_tvs = closeOverKinds (growThetaTyVars inferred_theta seed_tvs)+                          -- growThetaVars just like the no-type-sig case+                          -- Omitting this caused #12844+             seed_tvs = tyCoVarsOfTypes annotated_theta  -- These are put there+                        `unionVarSet` tau_tvs            --       by the user++       ; psig_qtvs <- mk_psig_qtvs annotated_tvs+       ; let my_qtvs  = mk_final_qtvs psig_qtvs free_tvs+             keep_me  = psig_qtvs `unionVarSet` free_tvs+             my_theta = pickCapturedPreds keep_me inferred_theta++       -- Report the inferred constraints for an extra-constraints wildcard/hole as+       -- an error message, unless the PartialTypeSignatures flag is enabled. In this+       -- case, the extra inferred constraints are accepted without complaining.+       -- NB: inferred_theta already includes all the annotated constraints+             inferred_diff = [ pred+                             | pred <- my_theta+                             , all (not . (`eqType` pred)) annotated_theta ]+       ; ctuple <- mk_ctuple inferred_diff+       ; writeMetaTyVar wc_var ctuple+       ; traceTc "completeTheta" $+            vcat [ ppr sig+                 , ppr annotated_theta, ppr inferred_theta+                 , ppr inferred_diff ]++       ; return (my_qtvs, my_theta) }++  | otherwise  -- A complete type signature is dealt with in mkInferredPolyId+  = pprPanic "chooseInferredQuantifiers" (ppr sig)++  where+    mk_final_qtvs psig_qtvs free_tvs+      = [ mkTyVarBinder vis tv+        | tv <- qtvs -- Pulling from qtvs maintains original order+        , tv `elemVarSet` keep_me+        , let vis | tv `elemVarSet` psig_qtvs = Specified+                  | otherwise                 = Inferred ]+      where+        keep_me = free_tvs `unionVarSet` psig_qtvs++    mk_ctuple [pred] = return pred+    mk_ctuple preds  = do { tc <- tcLookupTyCon (cTupleTyConName (length preds))+                          ; return (mkTyConApp tc preds) }++    mk_psig_qtvs :: [(Name,TcTyVar)] -> TcM TcTyVarSet+    mk_psig_qtvs annotated_tvs+       = do { psig_qtvs <- mapM (zonkTcTyVarToTyVar . snd) annotated_tvs+            ; return (mkVarSet psig_qtvs) }++mk_impedance_match_msg :: MonoBindInfo+                       -> TcType -> TcType+                       -> TidyEnv -> TcM (TidyEnv, SDoc)+-- This is a rare but rather awkward error messages+mk_impedance_match_msg (MBI { mbi_poly_name = name, mbi_sig = mb_sig })+                       inf_ty sig_ty tidy_env+ = do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env  inf_ty+      ; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty+      ; let msg = vcat [ text "When checking that the inferred type"+                       , nest 2 $ ppr name <+> dcolon <+> ppr inf_ty+                       , text "is as general as its" <+> what <+> text "signature"+                       , nest 2 $ ppr name <+> dcolon <+> ppr sig_ty ]+      ; return (tidy_env2, msg) }+  where+    what = case mb_sig of+             Nothing                     -> text "inferred"+             Just sig | isPartialSig sig -> text "(partial)"+                      | otherwise        -> empty+++mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)+mk_inf_msg poly_name poly_ty tidy_env+ = do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty+      ; let msg = vcat [ text "When checking the inferred type"+                       , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ]+      ; return (tidy_env1, msg) }+++-- | Warn the user about polymorphic local binders that lack type signatures.+localSigWarn :: WarningFlag -> Id -> Maybe TcIdSigInst -> TcM ()+localSigWarn flag id mb_sig+  | Just _ <- mb_sig               = return ()+  | not (isSigmaTy (idType id))    = return ()+  | otherwise                      = warnMissingSignatures flag msg id+  where+    msg = text "Polymorphic local binding with no type signature:"++warnMissingSignatures :: WarningFlag -> SDoc -> Id -> TcM ()+warnMissingSignatures flag msg id+  = do  { env0 <- tcInitTidyEnv+        ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)+        ; addWarnTcM (Reason flag) (env1, mk_msg tidy_ty) }+  where+    mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]++checkOverloadedSig :: Bool -> TcIdSigInst -> TcM ()+-- Example:+--   f :: Eq a => a -> a+--   K f = e+-- The MR applies, but the signature is overloaded, and it's+-- best to complain about this directly+-- c.f Trac #11339+checkOverloadedSig monomorphism_restriction_applies sig+  | not (null (sig_inst_theta sig))+  , monomorphism_restriction_applies+  , let orig_sig = sig_inst_sig sig+  = setSrcSpan (sig_loc orig_sig) $+    failWith $+    hang (text "Overloaded signature conflicts with monomorphism restriction")+       2 (ppr orig_sig)+  | otherwise+  = return ()++{- Note [Partial type signatures and generalisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If /any/ of the signatures in the gropu is a partial type signature+   f :: _ -> Int+then we *always* use the InferGen plan, and hence tcPolyInfer.+We do this even for a local binding with -XMonoLocalBinds, when+we normally use NoGen.++Reasons:+  * The TcSigInfo for 'f' has a unification variable for the '_',+    whose TcLevel is one level deeper than the current level.+    (See pushTcLevelM in tcTySig.)  But NoGen doesn't increase+    the TcLevel like InferGen, so we lose the level invariant.++  * The signature might be   f :: forall a. _ -> a+    so it really is polymorphic.  It's not clear what it would+    mean to use NoGen on this, and indeed the ASSERT in tcLhs,+    in the (Just sig) case, checks that if there is a signature+    then we are using LetLclBndr, and hence a nested AbsBinds with+    increased TcLevel++It might be possible to fix these difficulties somehow, but there+doesn't seem much point.  Indeed, adding a partial type signature is a+way to get per-binding inferred generalisation.++We apply the MR if /all/ of the partial signatures lack a context.+In particular (Trac #11016):+   f2 :: (?loc :: Int) => _+   f2 = ?loc+It's stupid to apply the MR here.  This test includes an extra-constraints+wildcard; that is, we don't apply the MR if you write+   f3 :: _ => blah++Note [Validity of inferred types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to check inferred type for validity, in case it uses language+extensions that are not turned on.  The principle is that if the user+simply adds the inferred type to the program source, it'll compile fine.+See #8883.++Examples that might fail:+ - the type might be ambiguous++ - an inferred theta that requires type equalities e.g. (F a ~ G b)+                                or multi-parameter type classes+ - an inferred type that includes unboxed tuples+++Note [Impedance matching]+~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f 0 x = x+   f n x = g [] (not x)++   g [] y = f 10 y+   g _  y = f 9  y++After typechecking we'll get+  f_mono_ty :: a -> Bool -> Bool+  g_mono_ty :: [b] -> Bool -> Bool+with constraints+  (Eq a, Num a)++Note that f is polymorphic in 'a' and g in 'b'; and these are not linked.+The types we really want for f and g are+   f :: forall a. (Eq a, Num a) => a -> Bool -> Bool+   g :: forall b. [b] -> Bool -> Bool++We can get these by "impedance matching":+   tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool)+   tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono)++   f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f+   g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g++Suppose the shared quantified tyvars are qtvs and constraints theta.+Then we want to check that+     forall qtvs. theta => f_mono_ty   is more polymorphic than   f's polytype+and the proof is the impedance matcher.++Notice that the impedance matcher may do defaulting.  See Trac #7173.++It also cleverly does an ambiguity check; for example, rejecting+   f :: F a -> F a+where F is a non-injective type function.+-}++{- *********************************************************************+*                                                                      *+                         Vectorisation+*                                                                      *+********************************************************************* -}++tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId])+tcVectDecls decls+  = do { decls' <- mapM (wrapLocM tcVect) decls+       ; let ids  = [lvectDeclName decl | decl <- decls', not $ lvectInstDecl decl]+             dups = findDupsEq (==) ids+       ; mapM_ reportVectDups dups+       ; traceTcConstraints "End of tcVectDecls"+       ; return decls'+       }+  where+    reportVectDups (first:_second:_more)+      = addErrAt (getSrcSpan first) $+          text "Duplicate vectorisation declarations for" <+> ppr first+    reportVectDups _ = return ()++--------------+tcVect :: VectDecl Name -> TcM (VectDecl TcId)+-- FIXME: We can't typecheck the expression of a vectorisation declaration against the vectorised+--   type of the original definition as this requires internals of the vectoriser not available+--   during type checking.  Instead, constrain the rhs of a vectorisation declaration to be a single+--   identifier (this is checked in 'rnHsVectDecl').  Fix this by enabling the use of 'vectType'+--   from the vectoriser here.+tcVect (HsVect s name rhs)+  = addErrCtxt (vectCtxt name) $+    do { var <- wrapLocM tcLookupId name+       ; let L rhs_loc (HsVar (L lv rhs_var_name)) = rhs+       ; rhs_id <- tcLookupId rhs_var_name+       ; return $ HsVect s var (L rhs_loc (HsVar (L lv rhs_id)))+       }++tcVect (HsNoVect s name)+  = addErrCtxt (vectCtxt name) $+    do { var <- wrapLocM tcLookupId name+       ; return $ HsNoVect s var+       }+tcVect (HsVectTypeIn _ isScalar lname rhs_name)+  = addErrCtxt (vectCtxt lname) $+    do { tycon <- tcLookupLocatedTyCon lname+       ; checkTc (   not isScalar             -- either    we have a non-SCALAR declaration+                 || isJust rhs_name           -- or        we explicitly provide a vectorised type+                 || tyConArity tycon == 0     -- otherwise the type constructor must be nullary+                 )+                 scalarTyConMustBeNullary++       ; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name+       ; return $ HsVectTypeOut isScalar tycon rhs_tycon+       }+tcVect (HsVectTypeOut _ _ _)+  = panic "TcBinds.tcVect: Unexpected 'HsVectTypeOut'"+tcVect (HsVectClassIn _ lname)+  = addErrCtxt (vectCtxt lname) $+    do { cls <- tcLookupLocatedClass lname+       ; return $ HsVectClassOut cls+       }+tcVect (HsVectClassOut _)+  = panic "TcBinds.tcVect: Unexpected 'HsVectClassOut'"+tcVect (HsVectInstIn linstTy)+  = addErrCtxt (vectCtxt linstTy) $+    do { (cls, tys) <- tcHsVectInst linstTy+       ; inst       <- tcLookupInstance cls tys+       ; return $ HsVectInstOut inst+       }+tcVect (HsVectInstOut _)+  = panic "TcBinds.tcVect: Unexpected 'HsVectInstOut'"++vectCtxt :: Outputable thing => thing -> SDoc+vectCtxt thing = text "When checking the vectorisation declaration for" <+> ppr thing++scalarTyConMustBeNullary :: MsgDoc+scalarTyConMustBeNullary = text "VECTORISE SCALAR type constructor must be nullary"++{-+Note [SPECIALISE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~+There is no point in a SPECIALISE pragma for a non-overloaded function:+   reverse :: [a] -> [a]+   {-# SPECIALISE reverse :: [Int] -> [Int] #-}++But SPECIALISE INLINE *can* make sense for GADTS:+   data Arr e where+     ArrInt :: !Int -> ByteArray# -> Arr Int+     ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)++   (!:) :: Arr e -> Int -> e+   {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}+   {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}+   (ArrInt _ ba)     !: (I# i) = I# (indexIntArray# ba i)+   (ArrPair _ a1 a2) !: i      = (a1 !: i, a2 !: i)++When (!:) is specialised it becomes non-recursive, and can usefully+be inlined.  Scary!  So we only warn for SPECIALISE *without* INLINE+for a non-overloaded function.++************************************************************************+*                                                                      *+                         tcMonoBinds+*                                                                      *+************************************************************************++@tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.+The signatures have been dealt with already.+-}++data MonoBindInfo = MBI { mbi_poly_name :: Name+                        , mbi_sig       :: Maybe TcIdSigInst+                        , mbi_mono_id   :: TcId }++tcMonoBinds :: RecFlag  -- Whether the binding is recursive for typechecking purposes+                        -- i.e. the binders are mentioned in their RHSs, and+                        --      we are not rescued by a type signature+            -> TcSigFun -> LetBndrSpec+            -> [LHsBind Name]+            -> TcM (LHsBinds TcId, [MonoBindInfo])+tcMonoBinds is_rec sig_fn no_gen+           [ L b_loc (FunBind { fun_id = L nm_loc name,+                                fun_matches = matches, bind_fvs = fvs })]+                             -- Single function binding,+  | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS+  , Nothing <- sig_fn name   -- ...with no type signature+  =     -- Note [Single function non-recursive binding special-case]+        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+        -- In this very special case we infer the type of the+        -- right hand side first (it may have a higher-rank type)+        -- and *then* make the monomorphic Id for the LHS+        -- e.g.         f = \(x::forall a. a->a) -> <body>+        --      We want to infer a higher-rank type for f+    setSrcSpan b_loc    $+    do  { ((co_fn, matches'), rhs_ty)+            <- tcInferInst $ \ exp_ty ->+                  -- tcInferInst: see TcUnify,+                  -- Note [Deep instantiation of InferResult]+               tcExtendIdBndrs [TcIdBndr_ExpType name exp_ty NotTopLevel] $+                  -- We extend the error context even for a non-recursive+                  -- function so that in type error messages we show the+                  -- type of the thing whose rhs we are type checking+               tcMatchesFun (L nm_loc name) matches exp_ty++        ; mono_id <- newLetBndr no_gen name rhs_ty+        ; return (unitBag $ L b_loc $+                     FunBind { fun_id = L nm_loc mono_id,+                               fun_matches = matches', bind_fvs = fvs,+                               fun_co_fn = co_fn, fun_tick = [] },+                  [MBI { mbi_poly_name = name+                       , mbi_sig       = Nothing+                       , mbi_mono_id   = mono_id }]) }++tcMonoBinds _ sig_fn no_gen binds+  = do  { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds++        -- Bring the monomorphic Ids, into scope for the RHSs+        ; let mono_infos = getMonoBindInfo tc_binds+              rhs_id_env = [ (name, mono_id)+                           | MBI { mbi_poly_name = name+                                 , mbi_sig       = mb_sig+                                 , mbi_mono_id   = mono_id } <- mono_infos+                           , case mb_sig of+                               Just sig -> isPartialSig sig+                               Nothing  -> True ]+                -- A monomorphic binding for each term variable that lacks+                -- a complete type sig.  (Ones with a sig are already in scope.)++        ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)+                                       | (n,id) <- rhs_id_env]+        ; binds' <- tcExtendRecIds rhs_id_env $+                    mapM (wrapLocM tcRhs) tc_binds++        ; return (listToBag binds', mono_infos) }+++------------------------+-- tcLhs typechecks the LHS of the bindings, to construct the environment in which+-- we typecheck the RHSs.  Basically what we are doing is this: for each binder:+--      if there's a signature for it, use the instantiated signature type+--      otherwise invent a type variable+-- You see that quite directly in the FunBind case.+--+-- But there's a complication for pattern bindings:+--      data T = MkT (forall a. a->a)+--      MkT f = e+-- Here we can guess a type variable for the entire LHS (which will be refined to T)+-- but we want to get (f::forall a. a->a) as the RHS environment.+-- The simplest way to do this is to typecheck the pattern, and then look up the+-- bound mono-ids.  Then we want to retain the typechecked pattern to avoid re-doing+-- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't++data TcMonoBind         -- Half completed; LHS done, RHS not done+  = TcFunBind  MonoBindInfo  SrcSpan (MatchGroup Name (LHsExpr Name))+  | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name (LHsExpr Name)) TcSigmaType++tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind+-- Only called with plan InferGen (LetBndrSpec = LetLclBndr)+--                    or NoGen    (LetBndrSpec = LetGblBndr)+-- CheckGen is used only for functions with a complete type signature,+--          and tcPolyCheck doesn't use tcMonoBinds at all++tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_matches = matches })+  | Just (TcIdSig sig) <- sig_fn name+  = -- There is a type signature.+    -- It must be partial; if complete we'd be in tcPolyCheck!+    --    e.g.   f :: _ -> _+    --           f x = ...g...+    --           Just g = ...f...+    -- Hence always typechecked with InferGen+    do { mono_info <- tcLhsSigId no_gen (name, sig)+       ; return (TcFunBind mono_info nm_loc matches) }++  | otherwise  -- No type signature+  = do { mono_ty <- newOpenFlexiTyVarTy+       ; mono_id <- newLetBndr no_gen name mono_ty+       ; let mono_info = MBI { mbi_poly_name = name+                             , mbi_sig       = Nothing+                             , mbi_mono_id   = mono_id }+       ; return (TcFunBind mono_info nm_loc matches) }++tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })+  = -- See Note [Typechecking pattern bindings]+    do  { sig_mbis <- mapM (tcLhsSigId no_gen) sig_names++        ; let inst_sig_fun = lookupNameEnv $ mkNameEnv $+                             [ (mbi_poly_name mbi, mbi_mono_id mbi)+                             | mbi <- sig_mbis ]++            -- See Note [Existentials in pattern bindings]+        ; ((pat', nosig_mbis), pat_ty)+            <- addErrCtxt (patMonoBindsCtxt pat grhss) $+               tcInferNoInst $ \ exp_ty ->+               tcLetPat inst_sig_fun no_gen pat exp_ty $+               mapM lookup_info nosig_names++        ; let mbis = sig_mbis ++ nosig_mbis++        ; traceTc "tcLhs" (vcat [ ppr id <+> dcolon <+> ppr (idType id)+                                | mbi <- mbis, let id = mbi_mono_id mbi ]+                           $$ ppr no_gen)++        ; return (TcPatBind mbis pat' grhss pat_ty) }+  where+    bndr_names = collectPatBinders pat+    (nosig_names, sig_names) = partitionWith find_sig bndr_names++    find_sig :: Name -> Either Name (Name, TcIdSigInfo)+    find_sig name = case sig_fn name of+                      Just (TcIdSig sig) -> Right (name, sig)+                      _                  -> Left name++      -- After typechecking the pattern, look up the binder+      -- names that lack a signature, which the pattern has brought+      -- into scope.+    lookup_info :: Name -> TcM MonoBindInfo+    lookup_info name+      = do { mono_id <- tcLookupId name+           ; return (MBI { mbi_poly_name = name+                         , mbi_sig       = Nothing+                         , mbi_mono_id   = mono_id }) }++tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)+        -- AbsBind, VarBind impossible++-------------------+tcLhsSigId :: LetBndrSpec -> (Name, TcIdSigInfo) -> TcM MonoBindInfo+tcLhsSigId no_gen (name, sig)+  = do { inst_sig <- tcInstSig sig+       ; mono_id <- newSigLetBndr no_gen name inst_sig+       ; return (MBI { mbi_poly_name = name+                     , mbi_sig       = Just inst_sig+                     , mbi_mono_id   = mono_id }) }++------------+newSigLetBndr :: LetBndrSpec -> Name -> TcIdSigInst -> TcM TcId+newSigLetBndr (LetGblBndr prags) name (TISI { sig_inst_sig = id_sig })+  | CompleteSig { sig_bndr = poly_id } <- id_sig+  = addInlinePrags poly_id (lookupPragEnv prags name)+newSigLetBndr no_gen name (TISI { sig_inst_tau = tau })+  = newLetBndr no_gen name tau++-------------------+tcRhs :: TcMonoBind -> TcM (HsBind TcId)+tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })+                 loc matches)+  = tcExtendIdBinderStackForRhs [info]  $+    tcExtendTyVarEnvForRhs mb_sig       $+    do  { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))+        ; (co_fn, matches') <- tcMatchesFun (L loc (idName mono_id))+                                 matches (mkCheckExpType $ idType mono_id)+        ; return ( FunBind { fun_id = L loc mono_id+                           , fun_matches = matches'+                           , fun_co_fn = co_fn+                           , bind_fvs = placeHolderNamesTc+                           , fun_tick = [] } ) }++tcRhs (TcPatBind infos pat' grhss pat_ty)+  = -- When we are doing pattern bindings we *don't* bring any scoped+    -- type variables into scope unlike function bindings+    -- Wny not?  They are not completely rigid.+    -- That's why we have the special case for a single FunBind in tcMonoBinds+    tcExtendIdBinderStackForRhs infos        $+    do  { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)+        ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $+                    tcGRHSsPat grhss pat_ty+        ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'+                           , pat_rhs_ty = pat_ty+                           , bind_fvs = placeHolderNamesTc+                           , pat_ticks = ([],[]) } )}++tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a+tcExtendTyVarEnvForRhs Nothing thing_inside+  = thing_inside+tcExtendTyVarEnvForRhs (Just sig) thing_inside+  = tcExtendTyVarEnvFromSig sig thing_inside++tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a+tcExtendTyVarEnvFromSig sig_inst thing_inside+  | TISI { sig_inst_skols = skol_prs, sig_inst_wcs = wcs } <- sig_inst+  = tcExtendTyVarEnv2 wcs $+    tcExtendTyVarEnv2 skol_prs $+    thing_inside++tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a+-- Extend the TcIdBinderStack for the RHS of the binding, with+-- the monomorphic Id.  That way, if we have, say+--     f = \x -> blah+-- and something goes wrong in 'blah', we get a "relevant binding"+-- looking like  f :: alpha -> beta+-- This applies if 'f' has a type signature too:+--    f :: forall a. [a] -> [a]+--    f x = True+-- We can't unify True with [a], and a relevant binding is f :: [a] -> [a]+-- If we had the *polymorphic* version of f in the TcIdBinderStack, it+-- would not be reported as relevant, because its type is closed+tcExtendIdBinderStackForRhs infos thing_inside+  = tcExtendIdBndrs [ TcIdBndr mono_id NotTopLevel+                    | MBI { mbi_mono_id = mono_id } <- infos ]+                    thing_inside+    -- NotTopLevel: it's a monomorphic binding++---------------------+getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]+getMonoBindInfo tc_binds+  = foldr (get_info . unLoc) [] tc_binds+  where+    get_info (TcFunBind info _ _)    rest = info : rest+    get_info (TcPatBind infos _ _ _) rest = infos ++ rest+++{- Note [Typechecking pattern bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Look at:+   - typecheck/should_compile/ExPat+   - Trac #12427, typecheck/should_compile/T12427{a,b}++  data T where+    MkT :: Integral a => a -> Int -> T++and suppose t :: T.  Which of these pattern bindings are ok?++  E1. let { MkT p _ = t } in <body>++  E2. let { MkT _ q = t } in <body>++  E3. let { MkT (toInteger -> r) _ = t } in <body>++* (E1) is clearly wrong because the existential 'a' escapes.+  What type could 'p' possibly have?++* (E2) is fine, despite the existential pattern, because+  q::Int, and nothing escapes.++* Even (E3) is fine.  The existential pattern binds a dictionary+  for (Integral a) which the view pattern can use to convert the+  a-valued field to an Integer, so r :: Integer.++An easy way to see all three is to imagine the desugaring.+For (E2) it would look like+    let q = case t of MkT _ q' -> q'+    in <body>+++We typecheck pattern bindings as follows.  First tcLhs does this:++  1. Take each type signature q :: ty, partial or complete, and+     instantiate it (with tcLhsSigId) to get a MonoBindInfo.  This+     gives us a fresh "mono_id" qm :: instantiate(ty), where qm has+     a fresh name.++     Any fresh unification variables in instantiate(ty) born here, not+     deep under implications as would happen if we allocated them when+     we encountered q during tcPat.++  2. Build a little environment mapping "q" -> "qm" for those Ids+     with signatures (inst_sig_fun)++  3. Invoke tcLetPat to typecheck the pattern.++     - We pass in the current TcLevel.  This is captured by+       TcPat.tcLetPat, and put into the pc_lvl field of PatCtxt, in+       PatEnv.++     - When tcPat finds an existential constructor, it binds fresh+       type variables and dictionaries as usual, increments the TcLevel,+       and emits an implication constraint.++     - When we come to a binder (TcPat.tcPatBndr), it looks it up+       in the little environment (the pc_sig_fn field of PatCtxt).++         Success => There was a type signature, so just use it,+                    checking compatibility with the expected type.++         Failure => No type sigature.+             Infer case: (happens only outside any constructor pattern)+                         use a unification variable+                         at the outer level pc_lvl++             Check case: use promoteTcType to promote the type+                         to the outer level pc_lvl.  This is the+                         place where we emit a constraint that'll blow+                         up if existential capture takes place++       Result: the type of the binder is always at pc_lvl. This is+       crucial.++  4. Throughout, when we are making up an Id for the pattern-bound variables+     (newLetBndr), we have two cases:++     - If we are generalising (generalisation plan is InferGen or+       CheckGen), then the let_bndr_spec will be LetLclBndr.  In that case+       we want to bind a cloned, local version of the variable, with the+       type given by the pattern context, *not* by the signature (even if+       there is one; see Trac #7268). The mkExport part of the+       generalisation step will do the checking and impedance matching+       against the signature.++     - If for some some reason we are not generalising (plan = NoGen), the+       LetBndrSpec will be LetGblBndr.  In that case we must bind the+       global version of the Id, and do so with precisely the type given+       in the signature.  (Then we unify with the type from the pattern+       context type.)+++And that's it!  The implication constraints check for the skolem+escape.  It's quite simple and neat, and more expressive than before+e.g. GHC 8.0 rejects (E2) and (E3).++Example for (E1), starting at level 1.  We generate+     p :: beta:1, with constraints (forall:3 a. Integral a => a ~ beta)+The (a~beta) can't float (because of the 'a'), nor be solved (because+beta is untouchable.)++Example for (E2), we generate+     q :: beta:1, with constraint (forall:3 a. Integral a => Int ~ beta)+The beta is untoucable, but floats out of the constraint and can+be solved absolutely fine.++************************************************************************+*                                                                      *+                Generalisation+*                                                                      *+********************************************************************* -}++data GeneralisationPlan+  = NoGen               -- No generalisation, no AbsBinds++  | InferGen            -- Implicit generalisation; there is an AbsBinds+       Bool             --   True <=> apply the MR; generalise only unconstrained type vars++  | CheckGen (LHsBind Name) TcIdSigInfo+                        -- One FunBind with a signature+                        -- Explicit generalisation; there is an AbsBindsSig++-- A consequence of the no-AbsBinds choice (NoGen) is that there is+-- no "polymorphic Id" and "monmomorphic Id"; there is just the one++instance Outputable GeneralisationPlan where+  ppr NoGen          = text "NoGen"+  ppr (InferGen b)   = text "InferGen" <+> ppr b+  ppr (CheckGen _ s) = text "CheckGen" <+> ppr s++decideGeneralisationPlan+   :: DynFlags -> [LHsBind Name] -> IsGroupClosed -> TcSigFun+   -> GeneralisationPlan+decideGeneralisationPlan dflags lbinds closed sig_fn+  | has_partial_sigs                         = InferGen (and partial_sig_mrs)+  | Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig+  | do_not_generalise closed                 = NoGen+  | otherwise                                = InferGen mono_restriction+  where+    binds = map unLoc lbinds++    partial_sig_mrs :: [Bool]+    -- One for each parital signature (so empty => no partial sigs)+    -- The Bool is True if the signature has no constraint context+    --      so we should apply the MR+    -- See Note [Partial type signatures and generalisation]+    partial_sig_mrs+      = [ null theta+        | TcIdSig (PartialSig { psig_hs_ty = hs_ty })+            <- mapMaybe sig_fn (collectHsBindListBinders lbinds)+        , let (_, L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ]++    has_partial_sigs   = not (null partial_sig_mrs)++    mono_restriction  = xopt LangExt.MonomorphismRestriction dflags+                     && any restricted binds++    do_not_generalise (IsGroupClosed _ True) = False+        -- The 'True' means that all of the group's+        -- free vars have ClosedTypeId=True; so we can ignore+        -- -XMonoLocalBinds, and generalise anyway+    do_not_generalise _ = xopt LangExt.MonoLocalBinds dflags++    -- With OutsideIn, all nested bindings are monomorphic+    -- except a single function binding with a signature+    one_funbind_with_sig+      | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds+      , Just (TcIdSig sig) <- sig_fn (unLoc v)+      = Just (lbind, sig)+      | otherwise+      = Nothing++    -- The Haskell 98 monomorphism restriction+    restricted (PatBind {})                              = True+    restricted (VarBind { var_id = v })                  = no_sig v+    restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m+                                                           && no_sig (unLoc v)+    restricted (PatSynBind {}) = panic "isRestrictedGroup/unrestricted PatSynBind"+    restricted (AbsBinds {}) = panic "isRestrictedGroup/unrestricted AbsBinds"+    restricted (AbsBindsSig {}) = panic "isRestrictedGroup/unrestricted AbsBindsSig"++    restricted_match (MG { mg_alts = L _ (L _ (Match _ [] _ _) : _ )}) = True+    restricted_match _                                                 = False+        -- No args => like a pattern binding+        -- Some args => a function binding++    no_sig n = not (hasCompleteSig sig_fn n)++isClosedBndrGroup :: TcTypeEnv -> Bag (LHsBind Name) -> IsGroupClosed+isClosedBndrGroup type_env binds+  = IsGroupClosed fv_env type_closed+  where+    type_closed = allUFM (nameSetAll is_closed_type_id) fv_env++    fv_env :: NameEnv NameSet+    fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds++    bindFvs :: HsBindLR Name idR -> [(Name, NameSet)]+    bindFvs (FunBind { fun_id = L _ f, bind_fvs = fvs })+       = let open_fvs = filterNameSet (not . is_closed) fvs+         in [(f, open_fvs)]+    bindFvs (PatBind { pat_lhs = pat, bind_fvs = fvs })+       = let open_fvs = filterNameSet (not . is_closed) fvs+         in [(b, open_fvs) | b <- collectPatBinders pat]+    bindFvs _+       = []++    is_closed :: Name -> ClosedTypeId+    is_closed name+      | Just thing <- lookupNameEnv type_env name+      = case thing of+          AGlobal {}                     -> True+          ATcId { tct_info = ClosedLet } -> True+          _                              -> False++      | otherwise+      = True  -- The free-var set for a top level binding mentions+++    is_closed_type_id :: Name -> Bool+    -- We're already removed Global and ClosedLet Ids+    is_closed_type_id name+      | Just thing <- lookupNameEnv type_env name+      = case thing of+          ATcId { tct_info = NonClosedLet _ cl } -> cl+          ATcId { tct_info = NotLetBound }       -> False+          ATyVar {}                              -> False+               -- In-scope type variables are not closed!+          _ -> pprPanic "is_closed_id" (ppr name)++      | otherwise+      = True   -- The free-var set for a top level binding mentions+               -- imported things too, so that we can report unused imports+               -- These won't be in the local type env.+               -- Ditto class method etc from the current module+++{- *********************************************************************+*                                                                      *+               Error contexts and messages+*                                                                      *+********************************************************************* -}++-- This one is called on LHS, when pat and grhss are both Name+-- and on RHS, when pat is TcId and grhss is still Name+patMonoBindsCtxt :: (OutputableBndrId id, Outputable body)+                 => LPat id -> GRHSs Name body -> SDoc+patMonoBindsCtxt pat grhss+  = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss)
+ typecheck/TcCanonical.hs view
@@ -0,0 +1,1949 @@+{-# LANGUAGE CPP #-}++module TcCanonical(+     canonicalize,+     unifyDerived,+     makeSuperClasses, maybeSym,+     StopOrContinue(..), stopWith, continueWith+  ) where++#include "HsVersions.h"++import TcRnTypes+import TcUnify( swapOverTyVars, metaTyVarUpdateOK )+import TcType+import Type+import TcFlatten+import TcSMonad+import TcEvidence+import Class+import TyCon+import TyCoRep   -- cleverly decomposes types, good for completeness checking+import Coercion+import FamInstEnv ( FamInstEnvs )+import FamInst ( tcTopNormaliseNewTypeTF_maybe )+import Var+import VarEnv( mkInScopeSet )+import VarSet( extendVarSetList )+import Outputable+import DynFlags( DynFlags )+import NameSet+import RdrName++import Pair+import Util+import Bag+import MonadUtils+import Control.Monad+import Data.Maybe ( isJust )+import Data.List  ( zip4, foldl' )+import BasicTypes++import Data.Bifunctor ( bimap )++{-+************************************************************************+*                                                                      *+*                      The Canonicaliser                               *+*                                                                      *+************************************************************************++Note [Canonicalization]+~~~~~~~~~~~~~~~~~~~~~~~++Canonicalization converts a simple constraint to a canonical form. It is+unary (i.e. treats individual constraints one at a time).++Constraints originating from user-written code come into being as+CNonCanonicals (except for CHoleCans, arising from holes). We know nothing+about these constraints. So, first:++     Classify CNonCanoncal constraints, depending on whether they+     are equalities, class predicates, or other.++Then proceed depending on the shape of the constraint. Generally speaking,+each constraint gets flattened and then decomposed into one of several forms+(see type Ct in TcRnTypes).++When an already-canonicalized constraint gets kicked out of the inert set,+it must be recanonicalized. But we know a bit about its shape from the+last time through, so we can skip the classification step.++-}++-- Top-level canonicalization+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++canonicalize :: Ct -> TcS (StopOrContinue Ct)+canonicalize ct@(CNonCanonical { cc_ev = ev })+  = do { traceTcS "canonicalize (non-canonical)" (ppr ct)+       ; {-# SCC "canEvVar" #-}+         canEvNC ev }++canonicalize (CDictCan { cc_ev = ev, cc_class  = cls+                       , cc_tyargs = xis, cc_pend_sc = pend_sc })+  = {-# SCC "canClass" #-}+    canClass ev cls xis pend_sc++canonicalize (CTyEqCan { cc_ev = ev+                       , cc_tyvar  = tv+                       , cc_rhs    = xi+                       , cc_eq_rel = eq_rel })+  = {-# SCC "canEqLeafTyVarEq" #-}+    canEqNC ev eq_rel (mkTyVarTy tv) xi+      -- NB: Don't use canEqTyVar because that expects flattened types,+      -- and tv and xi may not be flat w.r.t. an updated inert set++canonicalize (CFunEqCan { cc_ev = ev+                        , cc_fun    = fn+                        , cc_tyargs = xis1+                        , cc_fsk    = fsk })+  = {-# SCC "canEqLeafFunEq" #-}+    canCFunEqCan ev fn xis1 fsk++canonicalize (CIrredEvCan { cc_ev = ev })+  = canIrred ev+canonicalize (CHoleCan { cc_ev = ev, cc_hole = hole })+  = canHole ev hole++canEvNC :: CtEvidence -> TcS (StopOrContinue Ct)+-- Called only for non-canonical EvVars+canEvNC ev+  = case classifyPredType (ctEvPred ev) of+      ClassPred cls tys     -> do traceTcS "canEvNC:cls" (ppr cls <+> ppr tys)+                                  canClassNC ev cls tys+      EqPred eq_rel ty1 ty2 -> do traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2)+                                  canEqNC    ev eq_rel ty1 ty2+      IrredPred {}          -> do traceTcS "canEvNC:irred" (ppr (ctEvPred ev))+                                  canIrred   ev+{-+************************************************************************+*                                                                      *+*                      Class Canonicalization+*                                                                      *+************************************************************************+-}++canClassNC :: CtEvidence -> Class -> [Type] -> TcS (StopOrContinue Ct)+-- "NC" means "non-canonical"; that is, we have got here+-- from a NonCanonical constrataint, not from a CDictCan+-- Precondition: EvVar is class evidence+canClassNC ev cls tys+  | isGiven ev  -- See Note [Eagerly expand given superclasses]+  = do { sc_cts <- mkStrictSuperClasses ev cls tys+       ; emitWork sc_cts+       ; canClass ev cls tys False }+  | otherwise+  = canClass ev cls tys (has_scs cls)+  where+    has_scs cls = not (null (classSCTheta cls))++canClass :: CtEvidence+         -> Class -> [Type]+         -> Bool            -- True <=> un-explored superclasses+         -> TcS (StopOrContinue Ct)+-- Precondition: EvVar is class evidence++canClass ev cls tys pend_sc+  =   -- all classes do *nominal* matching+    ASSERT2( ctEvRole ev == Nominal, ppr ev $$ ppr cls $$ ppr tys )+    do { (xis, cos) <- flattenManyNom ev tys+       ; let co = mkTcTyConAppCo Nominal (classTyCon cls) cos+             xi = mkClassPred cls xis+             mk_ct new_ev = CDictCan { cc_ev = new_ev+                                     , cc_tyargs = xis+                                     , cc_class = cls+                                     , cc_pend_sc = pend_sc }+       ; mb <- rewriteEvidence ev xi co+       ; traceTcS "canClass" (vcat [ ppr ev+                                   , ppr xi, ppr mb ])+       ; return (fmap mk_ct mb) }++{- Note [The superclass story]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to add superclass constraints for two reasons:++* For givens [G], they give us a route to to proof.  E.g.+    f :: Ord a => a -> Bool+    f x = x == x+  We get a Wanted (Eq a), which can only be solved from the superclass+  of the Given (Ord a).++* For wanteds [W], and deriveds [WD], [D], they may give useful+  functional dependencies.  E.g.+     class C a b | a -> b where ...+     class C a b => D a b where ...+  Now a [W] constraint (D Int beta) has (C Int beta) as a superclass+  and that might tell us about beta, via C's fundeps.  We can get this+  by generating a [D] (C Int beta) constraint.  It's derived because+  we don't actually have to cough up any evidence for it; it's only there+  to generate fundep equalities.++See Note [Why adding superclasses can help].++For these reasons we want to generate superclass constraints for both+Givens and Wanteds. But:++* (Minor) they are often not needed, so generating them aggressively+  is a waste of time.++* (Major) if we want recursive superclasses, there would be an infinite+  number of them.  Here is a real-life example (Trac #10318);++     class (Frac (Frac a) ~ Frac a,+            Fractional (Frac a),+            IntegralDomain (Frac a))+         => IntegralDomain a where+      type Frac a :: *++  Notice that IntegralDomain has an associated type Frac, and one+  of IntegralDomain's superclasses is another IntegralDomain constraint.++So here's the plan:++1. Eagerly generate superclasses for given (but not wanted)+   constraints; see Note [Eagerly expand given superclasses].+   This is done in canClassNC, when we take a non-canonical constraint+   and cannonicalise it.++   However stop if you encounter the same class twice.  That is,+   expand eagerly, but have a conservative termination condition: see+   Note [Expanding superclasses] in TcType.++2. Solve the wanteds as usual, but do no further expansion of+   superclasses for canonical CDictCans in solveSimpleGivens or+   solveSimpleWanteds; Note [Danger of adding superclasses during solving]++   However, /do/ continue to eagerly expand superlasses for /given/+   non-canonical constraints (canClassNC does this).  As Trac #12175+   showed, a type-family application can expand to a class constraint,+   and we want to see its superclasses for just the same reason as+   Note [Eagerly expand given superclasses].++3. If we have any remaining unsolved wanteds+        (see Note [When superclasses help] in TcRnTypes)+   try harder: take both the Givens and Wanteds, and expand+   superclasses again.  This may succeed in generating (a finite+   number of) extra Givens, and extra Deriveds. Both may help the+   proof.  This is done in TcSimplify.expandSuperClasses.++4. Go round to (2) again.  This loop (2,3,4) is implemented+   in TcSimplify.simpl_loop.++The cc_pend_sc flag in a CDictCan records whether the superclasses of+this constraint have been expanded.  Specifically, in Step 3 we only+expand superclasses for constraints with cc_pend_sc set to true (i.e.+isPendingScDict holds).++Why do we do this?  Two reasons:++* To avoid repeated work, by repeatedly expanding the superclasses of+  same constraint,++* To terminate the above loop, at least in the -XNoRecursiveSuperClasses+  case.  If there are recursive superclasses we could, in principle,+  expand forever, always encountering new constraints.++When we take a CNonCanonical or CIrredCan, but end up classifying it+as a CDictCan, we set the cc_pend_sc flag to False.++Note [Eagerly expand given superclasses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In step (1) of Note [The superclass story], why do we eagerly expand+Given superclasses by one layer?  Mainly because of some very obscure+cases like this:++   instance Bad a => Eq (T a)++   f :: (Ord (T a)) => blah+   f x = ....needs Eq (T a), Ord (T a)....++Here if we can't satisfy (Eq (T a)) from the givens we'll use the+instance declaration; but then we are stuck with (Bad a).  Sigh.+This is really a case of non-confluent proofs, but to stop our users+complaining we expand one layer in advance.++Note [Instance and Given overlap] in TcInteract.++We also want to do this if we have++   f :: F (T a) => blah++where+   type instance F (T a) = Ord (T a)++So we may need to do a little work on the givens to expose the+class that has the superclasses.  That's why the superclass+expansion for Givens happens in canClassNC.++Note [Why adding superclasses can help]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Examples of how adding superclasses can help:++    --- Example 1+        class C a b | a -> b+    Suppose we want to solve+         [G] C a b+         [W] C a beta+    Then adding [D] beta~b will let us solve it.++    -- Example 2 (similar but using a type-equality superclass)+        class (F a ~ b) => C a b+    And try to sllve:+         [G] C a b+         [W] C a beta+    Follow the superclass rules to add+         [G] F a ~ b+         [D] F a ~ beta+    Now we we get [D] beta ~ b, and can solve that.++    -- Example (tcfail138)+      class L a b | a -> b+      class (G a, L a b) => C a b++      instance C a b' => G (Maybe a)+      instance C a b  => C (Maybe a) a+      instance L (Maybe a) a++    When solving the superclasses of the (C (Maybe a) a) instance, we get+      [G] C a b, and hance by superclasses, [G] G a, [G] L a b+      [W] G (Maybe a)+    Use the instance decl to get+      [W] C a beta+    Generate its derived superclass+      [D] L a beta.  Now using fundeps, combine with [G] L a b to get+      [D] beta ~ b+    which is what we want.++Note [Danger of adding superclasses during solving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here's a serious, but now out-dated example, from Trac #4497:++   class Num (RealOf t) => Normed t+   type family RealOf x++Assume the generated wanted constraint is:+   [W] RealOf e ~ e+   [W] Normed e++If we were to be adding the superclasses during simplification we'd get:+   [W] RealOf e ~ e+   [W] Normed e+   [D] RealOf e ~ fuv+   [D] Num fuv+==>+   e := fuv, Num fuv, Normed fuv, RealOf fuv ~ fuv++While looks exactly like our original constraint. If we add the+superclass of (Normed fuv) again we'd loop.  By adding superclasses+definitely only once, during canonicalisation, this situation can't+happen.++Mind you, now that Wanteds cannot rewrite Derived, I think this particular+situation can't happen.+  -}++makeSuperClasses :: [Ct] -> TcS [Ct]+-- Returns strict superclasses, transitively, see Note [The superclasses story]+-- See Note [The superclass story]+-- The loop-breaking here follows Note [Expanding superclasses] in TcType+-- Specifically, for an incoming (C t) constraint, we return all of (C t)'s+--    superclasses, up to /and including/ the first repetition of C+--+-- Example:  class D a => C a+--           class C [a] => D a+-- makeSuperClasses (C x) will return (D x, C [x])+--+-- NB: the incoming constraints have had their cc_pend_sc flag already+--     flipped to False, by isPendingScDict, so we are /obliged/ to at+--     least produce the immediate superclasses+makeSuperClasses cts = concatMapM go cts+  where+    go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })+          = mkStrictSuperClasses ev cls tys+    go ct = pprPanic "makeSuperClasses" (ppr ct)++mkStrictSuperClasses :: CtEvidence -> Class -> [Type] -> TcS [Ct]+-- Return constraints for the strict superclasses of (c tys)+mkStrictSuperClasses ev cls tys+  = mk_strict_superclasses (unitNameSet (className cls)) ev cls tys++mk_superclasses :: NameSet -> CtEvidence -> TcS [Ct]+-- Return this constraint, plus its superclasses, if any+mk_superclasses rec_clss ev+  | ClassPred cls tys <- classifyPredType (ctEvPred ev)+  = mk_superclasses_of rec_clss ev cls tys++  | otherwise   -- Superclass is not a class predicate+  = return [mkNonCanonical ev]++mk_superclasses_of :: NameSet -> CtEvidence -> Class -> [Type] -> TcS [Ct]+-- Always return this class constraint,+-- and expand its superclasses+mk_superclasses_of rec_clss ev cls tys+  | loop_found = do { traceTcS "mk_superclasses_of: loop" (ppr cls <+> ppr tys)+                    ; return [this_ct] }  -- cc_pend_sc of this_ct = True+  | otherwise  = do { traceTcS "mk_superclasses_of" (vcat [ ppr cls <+> ppr tys+                                                          , ppr (isCTupleClass cls)+                                                          , ppr rec_clss+                                                          ])+                    ; sc_cts <- mk_strict_superclasses rec_clss' ev cls tys+                    ; return (this_ct : sc_cts) }+                                   -- cc_pend_sc of this_ct = False+  where+    cls_nm     = className cls+    loop_found = not (isCTupleClass cls) && cls_nm `elemNameSet` rec_clss+                 -- Tuples never contribute to recursion, and can be nested+    rec_clss'  = rec_clss `extendNameSet` cls_nm+    this_ct    = CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys+                          , cc_pend_sc = loop_found }+                 -- NB: If there is a loop, we cut off, so we have not+                 --     added the superclasses, hence cc_pend_sc = True++mk_strict_superclasses :: NameSet -> CtEvidence -> Class -> [Type] -> TcS [Ct]+-- Always return the immediate superclasses of (cls tys);+-- and expand their superclasses, provided none of them are in rec_clss+-- nor are repeated+mk_strict_superclasses rec_clss ev cls tys+  | CtGiven { ctev_evar = evar, ctev_loc = loc } <- ev+  = do { sc_evs <- newGivenEvVars (mk_given_loc loc)+                                  (mkEvScSelectors (EvId evar) cls tys)+       ; concatMapM (mk_superclasses rec_clss) sc_evs }++  | all noFreeVarsOfType tys+  = return [] -- Wanteds with no variables yield no deriveds.+              -- See Note [Improvement from Ground Wanteds]++  | otherwise -- Wanted/Derived case, just add Derived superclasses+              -- that can lead to improvement.+  = do { let loc = ctEvLoc ev+       ; sc_evs <- mapM (newDerivedNC loc) (immSuperClasses cls tys)+       ; concatMapM (mk_superclasses rec_clss) sc_evs }+  where+    size = sizeTypes tys+    mk_given_loc loc+       | isCTupleClass cls+       = loc   -- For tuple predicates, just take them apart, without+               -- adding their (large) size into the chain.  When we+               -- get down to a base predicate, we'll include its size.+               -- Trac #10335++       | GivenOrigin skol_info <- ctLocOrigin loc+         -- See Note [Solving superclass constraints] in TcInstDcls+         -- for explantation of this transformation for givens+       = case skol_info of+            InstSkol -> loc { ctl_origin = GivenOrigin (InstSC size) }+            InstSC n -> loc { ctl_origin = GivenOrigin (InstSC (n `max` size)) }+            _        -> loc++       | otherwise  -- Probably doesn't happen, since this function+       = loc        -- is only used for Givens, but does no harm+++{-+************************************************************************+*                                                                      *+*                      Irreducibles canonicalization+*                                                                      *+************************************************************************+-}++canIrred :: CtEvidence -> TcS (StopOrContinue Ct)+-- Precondition: ty not a tuple and no other evidence form+canIrred old_ev+  = do { let old_ty = ctEvPred old_ev+       ; traceTcS "can_pred" (text "IrredPred = " <+> ppr old_ty)+       ; (xi,co) <- flatten FM_FlattenAll old_ev old_ty -- co :: xi ~ old_ty+       ; rewriteEvidence old_ev xi co `andWhenContinue` \ new_ev ->+    do { -- Re-classify, in case flattening has improved its shape+       ; case classifyPredType (ctEvPred new_ev) of+           ClassPred cls tys     -> canClassNC new_ev cls tys+           EqPred eq_rel ty1 ty2 -> canEqNC new_ev eq_rel ty1 ty2+           _                     -> continueWith $+                                    CIrredEvCan { cc_ev = new_ev } } }++canHole :: CtEvidence -> Hole -> TcS (StopOrContinue Ct)+canHole ev hole+  = do { let ty = ctEvPred ev+       ; (xi,co) <- flatten FM_SubstOnly ev ty -- co :: xi ~ ty+       ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev ->+    do { emitInsoluble (CHoleCan { cc_ev = new_ev+                                 , cc_hole = hole })+       ; stopWith new_ev "Emit insoluble hole" } }++{-+************************************************************************+*                                                                      *+*        Equalities+*                                                                      *+************************************************************************++Note [Canonicalising equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In order to canonicalise an equality, we look at the structure of the+two types at hand, looking for similarities. A difficulty is that the+types may look dissimilar before flattening but similar after flattening.+However, we don't just want to jump in and flatten right away, because+this might be wasted effort. So, after looking for similarities and failing,+we flatten and then try again. Of course, we don't want to loop, so we+track whether or not we've already flattened.++It is conceivable to do a better job at tracking whether or not a type+is flattened, but this is left as future work. (Mar '15)+++Note [FunTy and decomposing tycon applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When can_eq_nc' attempts to decompose a tycon application we haven't yet zonked.+This means that we may very well have a FunTy containing a type of some unknown+kind. For instance, we may have,++    FunTy (a :: k) Int++Where k is a unification variable. tcRepSplitTyConApp_maybe panics in the event+that it sees such a type as it cannot determine the RuntimeReps which the (->)+is applied to. Consequently, it is vital that we instead use+tcRepSplitTyConApp_maybe', which simply returns Nothing in such a case.++When this happens can_eq_nc' will fail to decompose, zonk, and try again.+Zonking should fill the variable k, meaning that decomposition will succeed the+second time around.+-}++canEqNC :: CtEvidence -> EqRel -> Type -> Type -> TcS (StopOrContinue Ct)+canEqNC ev eq_rel ty1 ty2+  = do { result <- zonk_eq_types ty1 ty2+       ; case result of+           Left (Pair ty1' ty2') -> can_eq_nc False ev eq_rel ty1' ty1 ty2' ty2+           Right ty              -> canEqReflexive ev eq_rel ty }++can_eq_nc+   :: Bool            -- True => both types are flat+   -> CtEvidence+   -> EqRel+   -> Type -> Type    -- LHS, after and before type-synonym expansion, resp+   -> Type -> Type    -- RHS, after and before type-synonym expansion, resp+   -> TcS (StopOrContinue Ct)+can_eq_nc flat ev eq_rel ty1 ps_ty1 ty2 ps_ty2+  = do { traceTcS "can_eq_nc" $+         vcat [ ppr flat, ppr ev, ppr eq_rel, ppr ty1, ppr ps_ty1, ppr ty2, ppr ps_ty2 ]+       ; rdr_env <- getGlobalRdrEnvTcS+       ; fam_insts <- getFamInstEnvs+       ; can_eq_nc' flat rdr_env fam_insts ev eq_rel ty1 ps_ty1 ty2 ps_ty2 }++can_eq_nc'+   :: Bool           -- True => both input types are flattened+   -> GlobalRdrEnv   -- needed to see which newtypes are in scope+   -> FamInstEnvs    -- needed to unwrap data instances+   -> CtEvidence+   -> EqRel+   -> Type -> Type    -- LHS, after and before type-synonym expansion, resp+   -> Type -> Type    -- RHS, after and before type-synonym expansion, resp+   -> TcS (StopOrContinue Ct)++-- Expand synonyms first; see Note [Type synonyms and canonicalization]+can_eq_nc' flat _rdr_env _envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2+  | Just ty1' <- tcView ty1 = can_eq_nc flat ev eq_rel ty1' ps_ty1 ty2  ps_ty2+  | Just ty2' <- tcView ty2 = can_eq_nc flat ev eq_rel ty1  ps_ty1 ty2' ps_ty2++-- need to check for reflexivity in the ReprEq case.+-- See Note [Eager reflexivity check]+-- Check only when flat because the zonk_eq_types check in canEqNC takes+-- care of the non-flat case.+can_eq_nc' True _rdr_env _envs ev ReprEq ty1 _ ty2 _+  | ty1 `tcEqType` ty2+  = canEqReflexive ev ReprEq ty1++-- When working with ReprEq, unwrap newtypes.+can_eq_nc' _flat rdr_env envs ev ReprEq ty1 _ ty2 ps_ty2+  | Just stuff1 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty1+  = can_eq_newtype_nc ev NotSwapped ty1 stuff1 ty2 ps_ty2+can_eq_nc' _flat rdr_env envs ev ReprEq ty1 ps_ty1 ty2 _+  | Just stuff2 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2+  = can_eq_newtype_nc ev IsSwapped  ty2 stuff2 ty1 ps_ty1++-- Then, get rid of casts+can_eq_nc' flat _rdr_env _envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2+  = canEqCast flat ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2+can_eq_nc' flat _rdr_env _envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _+  = canEqCast flat ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1++----------------------+-- Otherwise try to decompose+----------------------++-- Literals+can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _+ | l1 == l2+  = do { setEqIfWanted ev (mkReflCo (eqRelRole eq_rel) ty1)+       ; stopWith ev "Equal LitTy" }++-- Try to decompose type constructor applications+-- Including FunTy (s -> t)+can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1 _ ty2 _+    --- See Note [FunTy and decomposing type constructor applications].+  | Just (tc1, tys1) <- tcRepSplitTyConApp_maybe' ty1+  , Just (tc2, tys2) <- tcRepSplitTyConApp_maybe' ty2+  , not (isTypeFamilyTyCon tc1)+  , not (isTypeFamilyTyCon tc2)+  = canTyConApp ev eq_rel tc1 tys1 tc2 tys2++can_eq_nc' _flat _rdr_env _envs ev eq_rel+           s1@(ForAllTy {}) _ s2@(ForAllTy {}) _+  = can_eq_nc_forall ev eq_rel s1 s2++-- See Note [Canonicalising type applications] about why we require flat types+can_eq_nc' True _rdr_env _envs ev eq_rel (AppTy t1 s1) _ ty2 _+  | Just (t2, s2) <- tcSplitAppTy_maybe ty2+  = can_eq_app ev eq_rel t1 s1 t2 s2+can_eq_nc' True _rdr_env _envs ev eq_rel ty1 _ (AppTy t2 s2) _+  | Just (t1, s1) <- tcSplitAppTy_maybe ty1+  = can_eq_app ev eq_rel t1 s1 t2 s2++-- No similarity in type structure detected. Flatten and try again.+can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2+  = do { (xi1, co1) <- flatten FM_FlattenAll ev ps_ty1+       ; (xi2, co2) <- flatten FM_FlattenAll ev ps_ty2+       ; rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2+         `andWhenContinue` \ new_ev ->+         can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 }++-- Type variable on LHS or RHS are last.+-- NB: pattern match on True: we want only flat types sent to canEqTyVar.+-- See also Note [No top-level newtypes on RHS of representational equalities]+can_eq_nc' True _rdr_env _envs ev eq_rel (TyVarTy tv1) ps_ty1 ty2 ps_ty2+  = canEqTyVar ev eq_rel NotSwapped tv1 ps_ty1 ty2 ps_ty2+can_eq_nc' True _rdr_env _envs ev eq_rel ty1 ps_ty1 (TyVarTy tv2) ps_ty2+  = canEqTyVar ev eq_rel IsSwapped tv2 ps_ty2 ty1 ps_ty1++-- We've flattened and the types don't match. Give up.+can_eq_nc' True _rdr_env _envs ev _eq_rel _ ps_ty1 _ ps_ty2+  = do { traceTcS "can_eq_nc' catch-all case" (ppr ps_ty1 $$ ppr ps_ty2)+       ; canEqHardFailure ev ps_ty1 ps_ty2 }++---------------------------------+can_eq_nc_forall :: CtEvidence -> EqRel+                 -> Type -> Type    -- LHS and RHS+                 -> TcS (StopOrContinue Ct)+-- (forall as. phi1) ~ (forall bs. phi2)+-- Check for length match of as, bs+-- Then build an implication constraint: forall as. phi1 ~ phi2[as/bs]+-- But remember also to unify the kinds of as and bs+--  (this is the 'go' loop), and actually substitute phi2[as |> cos / bs]+-- Remember also that we might have forall z (a:z). blah+--  so we must proceed one binder at a time (Trac #13879)++can_eq_nc_forall ev eq_rel s1 s2+ | CtWanted { ctev_loc = loc, ctev_dest = orig_dest } <- ev+ = do { let free_tvs1 = tyCoVarsOfType s1+            free_tvs2 = tyCoVarsOfType s2+            (bndrs1, phi1) = tcSplitForAllTyVarBndrs s1+            (bndrs2, phi2) = tcSplitForAllTyVarBndrs s2+      ; if not (equalLength bndrs1 bndrs2)+        then do { traceTcS "Forall failure" $+                     vcat [ ppr s1, ppr s2, ppr bndrs1, ppr bndrs2+                          , ppr (map binderArgFlag bndrs1)+                          , ppr (map binderArgFlag bndrs2) ]+                ; canEqHardFailure ev s1 s2 }+        else+   do { traceTcS "Creating implication for polytype equality" $ ppr ev+      ; let empty_subst1 = mkEmptyTCvSubst $ mkInScopeSet free_tvs1+      ; (subst1, skol_tvs) <- tcInstSkolTyVarsX empty_subst1 $+                              binderVars bndrs1++      ; let skol_info = UnifyForAllSkol phi1+            phi1' = substTy subst1 phi1++            -- Unify the kinds, extend the substitution+            go (skol_tv:skol_tvs) subst (bndr2:bndrs2)+              = do { let tv2 = binderVar bndr2+                   ; kind_co <- unifyWanted loc Nominal+                                            (tyVarKind skol_tv)+                                            (substTy subst (tyVarKind tv2))+                   ; let subst' = extendTvSubst subst tv2+                                       (mkCastTy (mkTyVarTy skol_tv) kind_co)+                   ; co <- go skol_tvs subst' bndrs2+                   ; return (mkForAllCo skol_tv kind_co co) }++            -- Done: unify phi1 ~ phi2+            go [] subst bndrs2+              = ASSERT( null bndrs2 )+                unifyWanted loc (eqRelRole eq_rel)+                            phi1' (substTy subst phi2)++            go _ _ _ = panic "cna_eq_nc_forall"  -- case (s:ss) []++            empty_subst2 = mkEmptyTCvSubst $ mkInScopeSet $+                           free_tvs2 `extendVarSetList` skol_tvs++      ; (implic, _ev_binds, all_co) <- buildImplication skol_info skol_tvs [] $+                                       go skol_tvs empty_subst2 bndrs2+           -- We have nowhere to put these bindings+           -- but TcSimplify.setImplicationStatus+           -- checks that we don't actually use them+           -- when skol_info = UnifyForAllSkol++      ; updWorkListTcS (extendWorkListImplic implic)+      ; setWantedEq orig_dest all_co+      ; stopWith ev "Deferred polytype equality" } }++ | otherwise+ = do { traceTcS "Omitting decomposition of given polytype equality" $+        pprEq s1 s2    -- See Note [Do not decompose given polytype equalities]+      ; stopWith ev "Discard given polytype equality" }++---------------------------------+-- | Compare types for equality, while zonking as necessary. Gives up+-- as soon as it finds that two types are not equal.+-- This is quite handy when some unification has made two+-- types in an inert wanted to be equal. We can discover the equality without+-- flattening, which is sometimes very expensive (in the case of type functions).+-- In particular, this function makes a ~20% improvement in test case+-- perf/compiler/T5030.+--+-- Returns either the (partially zonked) types in the case of+-- inequality, or the one type in the case of equality. canEqReflexive is+-- a good next step in the 'Right' case. Returning 'Left' is always safe.+--+-- NB: This does *not* look through type synonyms. In fact, it treats type+-- synonyms as rigid constructors. In the future, it might be convenient+-- to look at only those arguments of type synonyms that actually appear+-- in the synonym RHS. But we're not there yet.+zonk_eq_types :: TcType -> TcType -> TcS (Either (Pair TcType) TcType)+zonk_eq_types = go+  where+    go (TyVarTy tv1) (TyVarTy tv2) = tyvar_tyvar tv1 tv2+    go (TyVarTy tv1) ty2           = tyvar NotSwapped tv1 ty2+    go ty1 (TyVarTy tv2)           = tyvar IsSwapped  tv2 ty1++    -- We handle FunTys explicitly here despite the fact that they could also be+    -- treated as an application. Why? Well, for one it's cheaper to just look+    -- at two types (the argument and result types) than four (the argument,+    -- result, and their RuntimeReps). Also, we haven't completely zonked yet,+    -- so we may run into an unzonked type variable while trying to compute the+    -- RuntimeReps of the argument and result types. This can be observed in+    -- testcase tc269.+    go ty1 ty2+      | Just (arg1, res1) <- split1+      , Just (arg2, res2) <- split2+      = do { res_a <- go arg1 arg2+           ; res_b <- go res1 res2+           ; return $ combine_rev mkFunTy res_b res_a+           }+      | isJust split1 || isJust split2+      = bale_out ty1 ty2+      where+        split1 = tcSplitFunTy_maybe ty1+        split2 = tcSplitFunTy_maybe ty2++    go ty1 ty2+      | Just (tc1, tys1) <- tcRepSplitTyConApp_maybe ty1+      , Just (tc2, tys2) <- tcRepSplitTyConApp_maybe ty2+      = if tc1 == tc2 && tys1 `equalLength` tys2+          -- Crucial to check for equal-length args, because+          -- we cannot assume that the two args to 'go' have+          -- the same kind.  E.g go (Proxy *      (Maybe Int))+          --                        (Proxy (*->*) Maybe)+          -- We'll call (go (Maybe Int) Maybe)+          -- See Trac #13083+        then tycon tc1 tys1 tys2+        else bale_out ty1 ty2++    go ty1 ty2+      | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1+      , Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2+      = do { res_a <- go ty1a ty2a+           ; res_b <- go ty1b ty2b+           ; return $ combine_rev mkAppTy res_b res_a }++    go ty1@(LitTy lit1) (LitTy lit2)+      | lit1 == lit2+      = return (Right ty1)++    go ty1 ty2 = bale_out ty1 ty2+      -- We don't handle more complex forms here++    bale_out ty1 ty2 = return $ Left (Pair ty1 ty2)++    tyvar :: SwapFlag -> TcTyVar -> TcType+          -> TcS (Either (Pair TcType) TcType)+      -- Try to do as little as possible, as anything we do here is redundant+      -- with flattening. In particular, no need to zonk kinds. That's why+      -- we don't use the already-defined zonking functions+    tyvar swapped tv ty+      = case tcTyVarDetails tv of+          MetaTv { mtv_ref = ref }+            -> do { cts <- readTcRef ref+                  ; case cts of+                      Flexi        -> give_up+                      Indirect ty' -> unSwap swapped go ty' ty }+          _ -> give_up+      where+        give_up = return $ Left $ unSwap swapped Pair (mkTyVarTy tv) ty++    tyvar_tyvar tv1 tv2+      | tv1 == tv2 = return (Right (mkTyVarTy tv1))+      | otherwise  = do { (ty1', progress1) <- quick_zonk tv1+                        ; (ty2', progress2) <- quick_zonk tv2+                        ; if progress1 || progress2+                          then go ty1' ty2'+                          else return $ Left (Pair (TyVarTy tv1) (TyVarTy tv2)) }++    quick_zonk tv = case tcTyVarDetails tv of+      MetaTv { mtv_ref = ref }+        -> do { cts <- readTcRef ref+              ; case cts of+                  Flexi        -> return (TyVarTy tv, False)+                  Indirect ty' -> return (ty', True) }+      _ -> return (TyVarTy tv, False)++      -- This happens for type families, too. But recall that failure+      -- here just means to try harder, so it's OK if the type function+      -- isn't injective.+    tycon :: TyCon -> [TcType] -> [TcType]+          -> TcS (Either (Pair TcType) TcType)+    tycon tc tys1 tys2+      = do { results <- zipWithM go tys1 tys2+           ; return $ case combine_results results of+               Left tys  -> Left (mkTyConApp tc <$> tys)+               Right tys -> Right (mkTyConApp tc tys) }++    combine_results :: [Either (Pair TcType) TcType]+                    -> Either (Pair [TcType]) [TcType]+    combine_results = bimap (fmap reverse) reverse .+                      foldl' (combine_rev (:)) (Right [])++      -- combine (in reverse) a new result onto an already-combined result+    combine_rev :: (a -> b -> c)+                -> Either (Pair b) b+                -> Either (Pair a) a+                -> Either (Pair c) c+    combine_rev f (Left list) (Left elt) = Left (f <$> elt     <*> list)+    combine_rev f (Left list) (Right ty) = Left (f <$> pure ty <*> list)+    combine_rev f (Right tys) (Left elt) = Left (f <$> elt     <*> pure tys)+    combine_rev f (Right tys) (Right ty) = Right (f ty tys)++{-+Note [Newtypes can blow the stack]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++  newtype X = MkX (Int -> X)+  newtype Y = MkY (Int -> Y)++and now wish to prove++  [W] X ~R Y++This Wanted will loop, expanding out the newtypes ever deeper looking+for a solid match or a solid discrepancy. Indeed, there is something+appropriate to this looping, because X and Y *do* have the same representation,+in the limit -- they're both (Fix ((->) Int)). However, no finitely-sized+coercion will ever witness it. This loop won't actually cause GHC to hang,+though, because we check our depth when unwrapping newtypes.++Note [Eager reflexivity check]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++  newtype X = MkX (Int -> X)++and++  [W] X ~R X++Naively, we would start unwrapping X and end up in a loop. Instead,+we do this eager reflexivity check. This is necessary only for representational+equality because the flattener technology deals with the similar case+(recursive type families) for nominal equality.++Note that this check does not catch all cases, but it will catch the cases+we're most worried about, types like X above that are actually inhabited.++Here's another place where this reflexivity check is key:+Consider trying to prove (f a) ~R (f a). The AppTys in there can't+be decomposed, because representational equality isn't congruent with respect+to AppTy. So, when canonicalising the equality above, we get stuck and+would normally produce a CIrredEvCan. However, we really do want to+be able to solve (f a) ~R (f a). So, in the representational case only,+we do a reflexivity check.++(This would be sound in the nominal case, but unnecessary, and I [Richard+E.] am worried that it would slow down the common case.)+-}++------------------------+-- | We're able to unwrap a newtype. Update the bits accordingly.+can_eq_newtype_nc :: CtEvidence           -- ^ :: ty1 ~ ty2+                  -> SwapFlag+                  -> TcType                                    -- ^ ty1+                  -> ((Bag GlobalRdrElt, TcCoercion), TcType)  -- ^ :: ty1 ~ ty1'+                  -> TcType               -- ^ ty2+                  -> TcType               -- ^ ty2, with type synonyms+                  -> TcS (StopOrContinue Ct)+can_eq_newtype_nc ev swapped ty1 ((gres, co), ty1') ty2 ps_ty2+  = do { traceTcS "can_eq_newtype_nc" $+         vcat [ ppr ev, ppr swapped, ppr co, ppr gres, ppr ty1', ppr ty2 ]++         -- check for blowing our stack:+         -- See Note [Newtypes can blow the stack]+       ; checkReductionDepth (ctEvLoc ev) ty1+       ; addUsedGREs (bagToList gres)+           -- we have actually used the newtype constructor here, so+           -- make sure we don't warn about importing it!++       ; rewriteEqEvidence ev swapped ty1' ps_ty2+                           (mkTcSymCo co) (mkTcReflCo Representational ps_ty2)+         `andWhenContinue` \ new_ev ->+         can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 }++---------+-- ^ Decompose a type application.+-- All input types must be flat. See Note [Canonicalising type applications]+can_eq_app :: CtEvidence       -- :: s1 t1 ~r s2 t2+           -> EqRel            -- r+           -> Xi -> Xi         -- s1 t1+           -> Xi -> Xi         -- s2 t2+           -> TcS (StopOrContinue Ct)++-- AppTys only decompose for nominal equality, so this case just leads+-- to an irreducible constraint; see typecheck/should_compile/T10494+-- See Note [Decomposing equality], note {4}+can_eq_app ev ReprEq _ _ _ _+  = do { traceTcS "failing to decompose representational AppTy equality" (ppr ev)+       ; continueWith (CIrredEvCan { cc_ev = ev }) }+          -- no need to call canEqFailure, because that flattens, and the+          -- types involved here are already flat++can_eq_app ev NomEq s1 t1 s2 t2+  | CtDerived { ctev_loc = loc } <- ev+  = do { unifyDeriveds loc [Nominal, Nominal] [s1, t1] [s2, t2]+       ; stopWith ev "Decomposed [D] AppTy" }+  | CtWanted { ctev_dest = dest, ctev_loc = loc } <- ev+  = do { co_s <- unifyWanted loc Nominal s1 s2+       ; co_t <- unifyWanted loc Nominal t1 t2+       ; let co = mkAppCo co_s co_t+       ; setWantedEq dest co+       ; stopWith ev "Decomposed [W] AppTy" }+  | CtGiven { ctev_evar = evar, ctev_loc = loc } <- ev+  = do { let co   = mkTcCoVarCo evar+             co_s = mkTcLRCo CLeft  co+             co_t = mkTcLRCo CRight co+       ; evar_s <- newGivenEvVar loc ( mkTcEqPredLikeEv ev s1 s2+                                     , EvCoercion co_s )+       ; evar_t <- newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2+                                     , EvCoercion co_t )+       ; emitWorkNC [evar_t]+       ; canEqNC evar_s NomEq s1 s2 }+  | otherwise  -- Can't happen+  = error "can_eq_app"++-----------------------+-- | Break apart an equality over a casted type+-- looking like   (ty1 |> co1) ~ ty2   (modulo a swap-flag)+canEqCast :: Bool         -- are both types flat?+          -> CtEvidence+          -> EqRel+          -> SwapFlag+          -> TcType -> Coercion   -- LHS (res. RHS), ty1 |> co1+          -> TcType -> TcType     -- RHS (res. LHS), ty2 both normal and pretty+          -> TcS (StopOrContinue Ct)+canEqCast flat ev eq_rel swapped ty1 co1 ty2 ps_ty2+  = do { traceTcS "Decomposing cast" (vcat [ ppr ev+                                           , ppr ty1 <+> text "|>" <+> ppr co1+                                           , ppr ps_ty2 ])+       ; rewriteEqEvidence ev swapped ty1 ps_ty2+                           (mkTcReflCo role ty1+                              `mkTcCoherenceRightCo` co1)+                           (mkTcReflCo role ps_ty2)+         `andWhenContinue` \ new_ev ->+         can_eq_nc flat new_ev eq_rel ty1 ty1 ty2 ps_ty2 }+  where+    role = eqRelRole eq_rel++------------------------+canTyConApp :: CtEvidence -> EqRel+            -> TyCon -> [TcType]+            -> TyCon -> [TcType]+            -> TcS (StopOrContinue Ct)+-- See Note [Decomposing TyConApps]+canTyConApp ev eq_rel tc1 tys1 tc2 tys2+  | tc1 == tc2+  , length tys1 == length tys2+  = do { inerts <- getTcSInerts+       ; if can_decompose inerts+         then do { traceTcS "canTyConApp"+                       (ppr ev $$ ppr eq_rel $$ ppr tc1 $$ ppr tys1 $$ ppr tys2)+                 ; canDecomposableTyConAppOK ev eq_rel tc1 tys1 tys2+                 ; stopWith ev "Decomposed TyConApp" }+         else canEqFailure ev eq_rel ty1 ty2 }++  -- See Note [Skolem abstract data] (at tyConSkolem)+  | tyConSkolem tc1 || tyConSkolem tc2+  = do { traceTcS "canTyConApp: skolem abstract" (ppr tc1 $$ ppr tc2)+       ; continueWith (CIrredEvCan { cc_ev = ev }) }++  -- Fail straight away for better error messages+  -- See Note [Use canEqFailure in canDecomposableTyConApp]+  | eq_rel == ReprEq && not (isGenerativeTyCon tc1 Representational &&+                             isGenerativeTyCon tc2 Representational)+  = canEqFailure ev eq_rel ty1 ty2+  | otherwise+  = canEqHardFailure ev ty1 ty2+  where+    ty1 = mkTyConApp tc1 tys1+    ty2 = mkTyConApp tc2 tys2++    loc  = ctEvLoc ev+    pred = ctEvPred ev++     -- See Note [Decomposing equality]+    can_decompose inerts+      =  isInjectiveTyCon tc1 (eqRelRole eq_rel)+      || (ctEvFlavour ev /= Given && isEmptyBag (matchableGivens loc pred inerts))++{-+Note [Use canEqFailure in canDecomposableTyConApp]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must use canEqFailure, not canEqHardFailure here, because there is+the possibility of success if working with a representational equality.+Here is one case:++  type family TF a where TF Char = Bool+  data family DF a+  newtype instance DF Bool = MkDF Int++Suppose we are canonicalising (Int ~R DF (TF a)), where we don't yet+know `a`. This is *not* a hard failure, because we might soon learn+that `a` is, in fact, Char, and then the equality succeeds.++Here is another case:++  [G] Age ~R Int++where Age's constructor is not in scope. We don't want to report+an "inaccessible code" error in the context of this Given!++For example, see typecheck/should_compile/T10493, repeated here:++  import Data.Ord (Down)  -- no constructor++  foo :: Coercible (Down Int) Int => Down Int -> Int+  foo = coerce++That should compile, but only because we use canEqFailure and not+canEqHardFailure.++Note [Decomposing equality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have a constraint (of any flavour and role) that looks like+T tys1 ~ T tys2, what can we conclude about tys1 and tys2? The answer,+of course, is "it depends". This Note spells it all out.++In this Note, "decomposition" refers to taking the constraint+  [fl] (T tys1 ~X T tys2)+(for some flavour fl and some role X) and replacing it with+  [fls'] (tys1 ~Xs' tys2)+where that notation indicates a list of new constraints, where the+new constraints may have different flavours and different roles.++The key property to consider is injectivity. When decomposing a Given the+decomposition is sound if and only if T is injective in all of its type+arguments. When decomposing a Wanted, the decomposition is sound (assuming the+correct roles in the produced equality constraints), but it may be a guess --+that is, an unforced decision by the constraint solver. Decomposing Wanteds+over injective TyCons does not entail guessing. But sometimes we want to+decompose a Wanted even when the TyCon involved is not injective! (See below.)++So, in broad strokes, we want this rule:++(*) Decompose a constraint (T tys1 ~X T tys2) if and only if T is injective+at role X.++Pursuing the details requires exploring three axes:+* Flavour: Given vs. Derived vs. Wanted+* Role: Nominal vs. Representational+* TyCon species: datatype vs. newtype vs. data family vs. type family vs. type variable++(So a type variable isn't a TyCon, but it's convenient to put the AppTy case+in the same table.)++Right away, we can say that Derived behaves just as Wanted for the purposes+of decomposition. The difference between Derived and Wanted is the handling of+evidence. Since decomposition in these cases isn't a matter of soundness but of+guessing, we want the same behavior regardless of evidence.++Here is a table (discussion following) detailing where decomposition of+   (T s1 ... sn) ~r (T t1 .. tn)+is allowed.  The first four lines (Data types ... type family) refer+to TyConApps with various TyCons T; the last line is for AppTy, where+there is presumably a type variable at the head, so it's actually+   (s s1 ... sn) ~r (t t1 .. tn)++NOMINAL               GIVEN                       WANTED++Datatype               YES                         YES+Newtype                YES                         YES+Data family            YES                         YES+Type family            YES, in injective args{1}   YES, in injective args{1}+Type variable          YES                         YES++REPRESENTATIONAL      GIVEN                       WANTED++Datatype               YES                         YES+Newtype                NO{2}                      MAYBE{2}+Data family            NO{3}                      MAYBE{3}+Type family             NO                          NO+Type variable          NO{4}                       NO{4}++{1}: Type families can be injective in some, but not all, of their arguments,+so we want to do partial decomposition. This is quite different than the way+other decomposition is done, where the decomposed equalities replace the original+one. We thus proceed much like we do with superclasses: emitting new Givens+when "decomposing" a partially-injective type family Given and new Deriveds+when "decomposing" a partially-injective type family Wanted. (As of the time of+writing, 13 June 2015, the implementation of injective type families has not+been merged, but it should be soon. Please delete this parenthetical if the+implementation is indeed merged.)++{2}: See Note [Decomposing newtypes at representational role]++{3}: Because of the possibility of newtype instances, we must treat+data families like newtypes. See also Note [Decomposing newtypes at+representational role]. See #10534 and test case+typecheck/should_fail/T10534.++{4}: Because type variables can stand in for newtypes, we conservatively do not+decompose AppTys over representational equality.++In the implementation of can_eq_nc and friends, we don't directly pattern+match using lines like in the tables above, as those tables don't cover+all cases (what about PrimTyCon? tuples?). Instead we just ask about injectivity,+boiling the tables above down to rule (*). The exceptions to rule (*) are for+injective type families, which are handled separately from other decompositions,+and the MAYBE entries above.++Note [Decomposing newtypes at representational role]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This note discusses the 'newtype' line in the REPRESENTATIONAL table+in Note [Decomposing equality]. (At nominal role, newtypes are fully+decomposable.)++Here is a representative example of why representational equality over+newtypes is tricky:++  newtype Nt a = Mk Bool         -- NB: a is not used in the RHS,+  type role Nt representational  -- but the user gives it an R role anyway++If we have [W] Nt alpha ~R Nt beta, we *don't* want to decompose to+[W] alpha ~R beta, because it's possible that alpha and beta aren't+representationally equal. Here's another example.++  newtype Nt a = MkNt (Id a)+  type family Id a where Id a = a++  [W] Nt Int ~R Nt Age++Because of its use of a type family, Nt's parameter will get inferred to have+a nominal role. Thus, decomposing the wanted will yield [W] Int ~N Age, which+is unsatisfiable. Unwrapping, though, leads to a solution.++Conclusion:+ * Unwrap newtypes before attempting to decompose them.+   This is done in can_eq_nc'.++It all comes from the fact that newtypes aren't necessarily injective+w.r.t. representational equality.++Furthermore, as explained in Note [NthCo and newtypes] in TyCoRep, we can't use+NthCo on representational coercions over newtypes. NthCo comes into play+only when decomposing givens.++Conclusion:+ * Do not decompose [G] N s ~R N t++Is it sensible to decompose *Wanted* constraints over newtypes?  Yes!+It's the only way we could ever prove (IO Int ~R IO Age), recalling+that IO is a newtype.++However we must be careful.  Consider++  type role Nt representational++  [G] Nt a ~R Nt b       (1)+  [W] NT alpha ~R Nt b   (2)+  [W] alpha ~ a          (3)++If we focus on (3) first, we'll substitute in (2), and now it's+identical to the given (1), so we succeed.  But if we focus on (2)+first, and decompose it, we'll get (alpha ~R b), which is not soluble.+This is exactly like the question of overlapping Givens for class+constraints: see Note [Instance and Given overlap] in TcInteract.++Conclusion:+  * Decompose [W] N s ~R N t  iff there no given constraint that could+    later solve it.+-}++canDecomposableTyConAppOK :: CtEvidence -> EqRel+                          -> TyCon -> [TcType] -> [TcType]+                          -> TcS ()+-- Precondition: tys1 and tys2 are the same length, hence "OK"+canDecomposableTyConAppOK ev eq_rel tc tys1 tys2+  = case ev of+     CtDerived {}+        -> unifyDeriveds loc tc_roles tys1 tys2++     CtWanted { ctev_dest = dest }+        -> do { cos <- zipWith4M unifyWanted new_locs tc_roles tys1 tys2+              ; setWantedEq dest (mkTyConAppCo role tc cos) }++     CtGiven { ctev_evar = evar }+        -> do { let ev_co = mkCoVarCo evar+              ; given_evs <- newGivenEvVars loc $+                             [ ( mkPrimEqPredRole r ty1 ty2+                               , EvCoercion (mkNthCo i ev_co) )+                             | (r, ty1, ty2, i) <- zip4 tc_roles tys1 tys2 [0..]+                             , r /= Phantom+                             , not (isCoercionTy ty1) && not (isCoercionTy ty2) ]+              ; emitWorkNC given_evs }+  where+    loc        = ctEvLoc ev+    role       = eqRelRole eq_rel+    tc_roles   = tyConRolesX role tc++      -- the following makes a better distinction between "kind" and "type"+      -- in error messages+    bndrs      = tyConBinders tc+    kind_loc   = toKindLoc loc+    is_kinds   = map isNamedTyConBinder bndrs+    new_locs | Just KindLevel <- ctLocTypeOrKind_maybe loc+             = repeat loc+             | otherwise+             = map (\is_kind -> if is_kind then kind_loc else loc) is_kinds+++-- | Call when canonicalizing an equality fails, but if the equality is+-- representational, there is some hope for the future.+-- Examples in Note [Use canEqFailure in canDecomposableTyConApp]+canEqFailure :: CtEvidence -> EqRel+             -> TcType -> TcType -> TcS (StopOrContinue Ct)+canEqFailure ev NomEq ty1 ty2+  = canEqHardFailure ev ty1 ty2+canEqFailure ev ReprEq ty1 ty2+  = do { (xi1, co1) <- flatten FM_FlattenAll ev ty1+       ; (xi2, co2) <- flatten FM_FlattenAll ev ty2+            -- We must flatten the types before putting them in the+            -- inert set, so that we are sure to kick them out when+            -- new equalities become available+       ; traceTcS "canEqFailure with ReprEq" $+         vcat [ ppr ev, ppr ty1, ppr ty2, ppr xi1, ppr xi2 ]+       ; rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2+         `andWhenContinue` \ new_ev ->+         continueWith (CIrredEvCan { cc_ev = new_ev }) }++-- | Call when canonicalizing an equality fails with utterly no hope.+canEqHardFailure :: CtEvidence+                 -> TcType -> TcType -> TcS (StopOrContinue Ct)+-- See Note [Make sure that insolubles are fully rewritten]+canEqHardFailure ev ty1 ty2+  = do { (s1, co1) <- flatten FM_SubstOnly ev ty1+       ; (s2, co2) <- flatten FM_SubstOnly ev ty2+       ; rewriteEqEvidence ev NotSwapped s1 s2 co1 co2+         `andWhenContinue` \ new_ev ->+    do { emitInsoluble (mkNonCanonical new_ev)+       ; stopWith new_ev "Definitely not equal" }}++{-+Note [Decomposing TyConApps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we see (T s1 t1 ~ T s2 t2), then we can just decompose to+  (s1 ~ s2, t1 ~ t2)+and push those back into the work list.  But if+  s1 = K k1    s2 = K k2+then we will just decomopose s1~s2, and it might be better to+do so on the spot.  An important special case is where s1=s2,+and we get just Refl.++So canDecomposableTyCon is a fast-path decomposition that uses+unifyWanted etc to short-cut that work.++Note [Canonicalising type applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given (s1 t1) ~ ty2, how should we proceed?+The simple things is to see if ty2 is of form (s2 t2), and+decompose.  By this time s1 and s2 can't be saturated type+function applications, because those have been dealt with+by an earlier equation in can_eq_nc, so it is always sound to+decompose.++However, over-eager decomposition gives bad error messages+for things like+   a b ~ Maybe c+   e f ~ p -> q+Suppose (in the first example) we already know a~Array.  Then if we+decompose the application eagerly, yielding+   a ~ Maybe+   b ~ c+we get an error        "Can't match Array ~ Maybe",+but we'd prefer to get "Can't match Array b ~ Maybe c".++So instead can_eq_wanted_app flattens the LHS and RHS, in the hope of+replacing (a b) by (Array b), before using try_decompose_app to+decompose it.++Note [Make sure that insolubles are fully rewritten]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When an equality fails, we still want to rewrite the equality+all the way down, so that it accurately reflects+ (a) the mutable reference substitution in force at start of solving+ (b) any ty-binds in force at this point in solving+See Note [Kick out insolubles] in TcSMonad.+And if we don't do this there is a bad danger that+TcSimplify.applyTyVarDefaulting will find a variable+that has in fact been substituted.++Note [Do not decompose Given polytype equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider [G] (forall a. t1 ~ forall a. t2).  Can we decompose this?+No -- what would the evidence look like?  So instead we simply discard+this given evidence.+++Note [Combining insoluble constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As this point we have an insoluble constraint, like Int~Bool.++ * If it is Wanted, delete it from the cache, so that subsequent+   Int~Bool constraints give rise to separate error messages++ * But if it is Derived, DO NOT delete from cache.  A class constraint+   may get kicked out of the inert set, and then have its functional+   dependency Derived constraints generated a second time. In that+   case we don't want to get two (or more) error messages by+   generating two (or more) insoluble fundep constraints from the same+   class constraint.++Note [No top-level newtypes on RHS of representational equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we're in this situation:++ work item:  [W] c1 : a ~R b+     inert:  [G] c2 : b ~R Id a++where+  newtype Id a = Id a++We want to make sure canEqTyVar sees [W] a ~R a, after b is flattened+and the Id newtype is unwrapped. This is assured by requiring only flat+types in canEqTyVar *and* having the newtype-unwrapping check above+the tyvar check in can_eq_nc.++Note [Occurs check error]+~~~~~~~~~~~~~~~~~~~~~~~~~+If we have an occurs check error, are we necessarily hosed? Say our+tyvar is tv1 and the type it appears in is xi2. Because xi2 is function+free, then if we're computing w.r.t. nominal equality, then, yes, we're+hosed. Nothing good can come from (a ~ [a]). If we're computing w.r.t.+representational equality, this is a little subtler. Once again, (a ~R [a])+is a bad thing, but (a ~R N a) for a newtype N might be just fine. This+means also that (a ~ b a) might be fine, because `b` might become a newtype.++So, we must check: does tv1 appear in xi2 under any type constructor that+is generative w.r.t. representational equality? That's what isTyVarUnderDatatype+does. (The other name I considered, isTyVarUnderTyConGenerativeWrtReprEq was+a bit verbose. And the shorter name gets the point across.)++See also #10715, which induced this addition.++Note [No derived kind equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we're working with a heterogeneous derived equality++  [D] (t1 :: k1) ~ (t2 :: k2)++we want to homogenise to establish the kind invariant on CTyEqCans.+But we can't emit [D] k1 ~ k2 because we wouldn't then be able to+use the evidence in the homogenised types. So we emit a wanted+constraint, because we do really need the evidence here.++Thus: no derived kind equalities.++-}++canCFunEqCan :: CtEvidence+             -> TyCon -> [TcType]   -- LHS+             -> TcTyVar             -- RHS+             -> TcS (StopOrContinue Ct)+-- ^ Canonicalise a CFunEqCan.  We know that+--     the arg types are already flat,+-- and the RHS is a fsk, which we must *not* substitute.+-- So just substitute in the LHS+canCFunEqCan ev fn tys fsk+  = do { (tys', cos) <- flattenManyNom ev tys+                        -- cos :: tys' ~ tys+       ; let lhs_co  = mkTcTyConAppCo Nominal fn cos+                        -- :: F tys' ~ F tys+             new_lhs = mkTyConApp fn tys'+             fsk_ty  = mkTyVarTy fsk+       ; rewriteEqEvidence ev NotSwapped new_lhs fsk_ty+                           lhs_co (mkTcNomReflCo fsk_ty)+         `andWhenContinue` \ ev' ->+    do { extendFlatCache fn tys' (ctEvCoercion ev', fsk_ty, ctEvFlavour ev')+       ; continueWith (CFunEqCan { cc_ev = ev', cc_fun = fn+                                 , cc_tyargs = tys', cc_fsk = fsk }) } }++---------------------+canEqTyVar :: CtEvidence          -- ev :: lhs ~ rhs+           -> EqRel -> SwapFlag+           -> TcTyVar -> TcType   -- lhs: already flat, not a cast+           -> TcType -> TcType    -- rhs: already flat, not a cast+           -> TcS (StopOrContinue Ct)+canEqTyVar ev eq_rel swapped tv1 ps_ty1 (TyVarTy tv2) _+  | tv1 == tv2+  = canEqReflexive ev eq_rel ps_ty1++  | swapOverTyVars tv1 tv2+  = do { traceTcS "canEqTyVar" (ppr tv1 $$ ppr tv2 $$ ppr swapped)+         -- FM_Avoid commented out: see Note [Lazy flattening] in TcFlatten+         -- let fmode = FE { fe_ev = ev, fe_mode = FM_Avoid tv1' True }+         -- Flatten the RHS less vigorously, to avoid gratuitous flattening+         -- True <=> xi2 should not itself be a type-function application+       ; dflags <- getDynFlags+       ; canEqTyVar2 dflags ev eq_rel (flipSwap swapped) tv2 ps_ty1 }++canEqTyVar ev eq_rel swapped tv1 _ _ ps_ty2+  = do { dflags <- getDynFlags+       ; canEqTyVar2 dflags ev eq_rel swapped tv1 ps_ty2 }++canEqTyVar2 :: DynFlags+            -> CtEvidence   -- lhs ~ rhs (or, if swapped, orhs ~ olhs)+            -> EqRel+            -> SwapFlag+            -> TcTyVar      -- lhs, flat+            -> TcType       -- rhs, flat+            -> TcS (StopOrContinue Ct)+-- LHS is an inert type variable,+-- and RHS is fully rewritten, but with type synonyms+-- preserved as much as possible++canEqTyVar2 dflags ev eq_rel swapped tv1 xi2+  | Just xi2' <- metaTyVarUpdateOK dflags tv1 xi2  -- No occurs check+     -- Must do the occurs check even on tyvar/tyvar+     -- equalities, in case have  x ~ (y :: ..x...)+     -- Trac #12593+  = rewriteEqEvidence ev swapped xi1 xi2' co1 co2+    `andWhenContinue` \ new_ev ->+    homogeniseRhsKind new_ev eq_rel xi1 xi2' $ \new_new_ev xi2'' ->+    CTyEqCan { cc_ev = new_new_ev, cc_tyvar = tv1+             , cc_rhs = xi2'', cc_eq_rel = eq_rel }++  | otherwise  -- For some reason (occurs check, or forall) we can't unify+               -- We must not use it for further rewriting!+  = do { traceTcS "canEqTyVar2 can't unify" (ppr tv1 $$ ppr xi2)+       ; rewriteEqEvidence ev swapped xi1 xi2 co1 co2+         `andWhenContinue` \ new_ev ->+         if isInsolubleOccursCheck eq_rel tv1 xi2+         then do { emitInsoluble (mkNonCanonical new_ev)+             -- If we have a ~ [a], it is not canonical, and in particular+             -- we don't want to rewrite existing inerts with it, otherwise+             -- we'd risk divergence in the constraint solver+                 ; stopWith new_ev "Occurs check" }++             -- A representational equality with an occurs-check problem isn't+             -- insoluble! For example:+             --   a ~R b a+             -- We might learn that b is the newtype Id.+             -- But, the occurs-check certainly prevents the equality from being+             -- canonical, and we might loop if we were to use it in rewriting.+         else do { traceTcS "Possibly-soluble occurs check"+                           (ppr xi1 $$ ppr xi2)+                 ; continueWith (CIrredEvCan { cc_ev = new_ev }) } }+  where+    role = eqRelRole eq_rel+    xi1  = mkTyVarTy tv1+    co1  = mkTcReflCo role xi1+    co2  = mkTcReflCo role xi2++-- | Solve a reflexive equality constraint+canEqReflexive :: CtEvidence    -- ty ~ ty+               -> EqRel+               -> TcType        -- ty+               -> TcS (StopOrContinue Ct)   -- always Stop+canEqReflexive ev eq_rel ty+  = do { setEvBindIfWanted ev (EvCoercion $+                               mkTcReflCo (eqRelRole eq_rel) ty)+       ; stopWith ev "Solved by reflexivity" }++-- See Note [Equalities with incompatible kinds]+homogeniseRhsKind :: CtEvidence -- ^ the evidence to homogenise+                  -> EqRel+                  -> TcType              -- ^ original LHS+                  -> Xi                  -- ^ original RHS+                  -> (CtEvidence -> Xi -> Ct)+                           -- ^ how to build the homogenised constraint;+                           -- the 'Xi' is the new RHS+                  -> TcS (StopOrContinue Ct)+homogeniseRhsKind ev eq_rel lhs rhs build_ct+  | k1 `tcEqType` k2+  = continueWith (build_ct ev rhs)++  | CtGiven { ctev_evar = evar } <- ev+    -- tm :: (lhs :: k1) ~ (rhs :: k2)+  = do { kind_ev_id <- newBoundEvVarId kind_pty+                                       (EvCoercion $+                                        mkTcKindCo $ mkTcCoVarCo evar)+           -- kind_ev_id :: (k1 :: *) ~# (k2 :: *)+       ; let kind_ev = CtGiven { ctev_pred = kind_pty+                               , ctev_evar = kind_ev_id+                               , ctev_loc  = kind_loc }+             homo_co = mkSymCo $ mkCoVarCo kind_ev_id+             rhs'    = mkCastTy rhs homo_co+       ; traceTcS "Hetero equality gives rise to given kind equality"+           (ppr kind_ev_id <+> dcolon <+> ppr kind_pty)+       ; emitWorkNC [kind_ev]+       ; type_ev <- newGivenEvVar loc+                      ( mkTcEqPredLikeEv ev lhs rhs'+                      , EvCoercion $+                        mkTcCoherenceRightCo (mkTcCoVarCo evar) homo_co )+          -- type_ev :: (lhs :: k1) ~ ((rhs |> sym kind_ev_id) :: k1)+       ; continueWith (build_ct type_ev rhs') }++  | otherwise   -- Wanted and Derived. See Note [No derived kind equalities]+    -- evar :: (lhs :: k1) ~ (rhs :: k2)+  = do { kind_co <- emitNewWantedEq kind_loc Nominal k1 k2+             -- kind_ev :: (k1 :: *) ~ (k2 :: *)+       ; traceTcS "Hetero equality gives rise to wanted kind equality" $+           ppr (kind_co)+       ; let homo_co   = mkSymCo kind_co+           -- homo_co :: k2 ~ k1+             rhs'      = mkCastTy rhs homo_co+       ; case ev of+           CtGiven {} -> panic "homogeniseRhsKind"+           CtDerived {} -> continueWith (build_ct (ev { ctev_pred = homo_pred })+                                                  rhs')+             where homo_pred = mkTcEqPredLikeEv ev lhs rhs'+           CtWanted { ctev_dest = dest } -> do+             { (type_ev, hole_co) <- newWantedEq loc role lhs rhs'+                  -- type_ev :: (lhs :: k1) ~ (rhs |> sym kind_co :: k1)+             ; setWantedEq dest+                           (hole_co `mkTransCo`+                            (mkReflCo role rhs+                             `mkCoherenceLeftCo` homo_co))++                -- dest := hole ; <rhs> |> homo_co :: (lhs :: k1) ~ (rhs :: k2)+             ; continueWith (build_ct type_ev rhs') }}++  where+    k1 = typeKind lhs+    k2 = typeKind rhs++    kind_pty = mkHeteroPrimEqPred liftedTypeKind liftedTypeKind k1 k2+    kind_loc = mkKindLoc lhs rhs loc++    loc  = ctev_loc ev+    role = eqRelRole eq_rel++{-+Note [Canonical orientation for tyvar/tyvar equality constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we have a ~ b where both 'a' and 'b' are TcTyVars, which way+round should be oriented in the CTyEqCan?  The rules, implemented by+canEqTyVarTyVar, are these++ * If either is a flatten-meta-variables, it goes on the left.++ * Put a meta-tyvar on the left if possible+       alpha[3] ~ r++ * If both are meta-tyvars, put the more touchable one (deepest level+   number) on the left, so there is the best chance of unifying it+        alpha[3] ~ beta[2]++ * If both are meta-tyvars and both at the same level, put a SigTv+   on the right if possible+        alpha[2] ~ beta[2](sig-tv)+   That way, when we unify alpha := beta, we don't lose the SigTv flag.++ * Put a meta-tv with a System Name on the left if possible so it+   gets eliminated (improves error messages)++ * If one is a flatten-skolem, put it on the left so that it is+   substituted out  Note [Elminate flat-skols]+        fsk ~ a++Note [Avoid unnecessary swaps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we swap without actually improving matters, we can get an infnite loop.+Consider+    work item:  a ~ b+   inert item:  b ~ c+We canonicalise the work-time to (a ~ c).  If we then swap it before+aeding to the inert set, we'll add (c ~ a), and therefore kick out the+inert guy, so we get+   new work item:  b ~ c+   inert item:     c ~ a+And now the cycle just repeats++Note [Eliminate flat-skols]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have  [G] Num (F [a])+then we flatten to+     [G] Num fsk+     [G] F [a] ~ fsk+where fsk is a flatten-skolem (FlatSkol). Suppose we have+      type instance F [a] = a+then we'll reduce the second constraint to+     [G] a ~ fsk+and then replace all uses of 'a' with fsk.  That's bad because+in error messages intead of saying 'a' we'll say (F [a]).  In all+places, including those where the programmer wrote 'a' in the first+place.  Very confusing!  See Trac #7862.++Solution: re-orient a~fsk to fsk~a, so that we preferentially eliminate+the fsk.++Note [Equalities with incompatible kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+canEqLeaf is about to make a CTyEqCan or CFunEqCan; but both have the+invariant that LHS and RHS satisfy the kind invariants for CTyEqCan,+CFunEqCan.  What if we try to unify two things with incompatible+kinds?++eg    a ~ b  where a::*, b::*->*+or    a ~ b  where a::*, b::k, k is a kind variable++The CTyEqCan compatKind invariant is important.  If we make a CTyEqCan+for a~b, then we might well *substitute* 'b' for 'a', and that might make+a well-kinded type ill-kinded; and that is bad (eg typeKind can crash, see+Trac #7696).++So instead for these ill-kinded equalities we homogenise the RHS of the+equality, emitting new constraints as necessary.++Note [Type synonyms and canonicalization]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We treat type synonym applications as xi types, that is, they do not+count as type function applications.  However, we do need to be a bit+careful with type synonyms: like type functions they may not be+generative or injective.  However, unlike type functions, they are+parametric, so there is no problem in expanding them whenever we see+them, since we do not need to know anything about their arguments in+order to expand them; this is what justifies not having to treat them+as specially as type function applications.  The thing that causes+some subtleties is that we prefer to leave type synonym applications+*unexpanded* whenever possible, in order to generate better error+messages.++If we encounter an equality constraint with type synonym applications+on both sides, or a type synonym application on one side and some sort+of type application on the other, we simply must expand out the type+synonyms in order to continue decomposing the equality constraint into+primitive equality constraints.  For example, suppose we have++  type F a = [Int]++and we encounter the equality++  F a ~ [b]++In order to continue we must expand F a into [Int], giving us the+equality++  [Int] ~ [b]++which we can then decompose into the more primitive equality+constraint++  Int ~ b.++However, if we encounter an equality constraint with a type synonym+application on one side and a variable on the other side, we should+NOT (necessarily) expand the type synonym, since for the purpose of+good error messages we want to leave type synonyms unexpanded as much+as possible.  Hence the ps_ty1, ps_ty2 argument passed to canEqTyVar.++-}++{-+************************************************************************+*                                                                      *+                  Evidence transformation+*                                                                      *+************************************************************************+-}++data StopOrContinue a+  = ContinueWith a    -- The constraint was not solved, although it may have+                      --   been rewritten++  | Stop CtEvidence   -- The (rewritten) constraint was solved+         SDoc         -- Tells how it was solved+                      -- Any new sub-goals have been put on the work list++instance Functor StopOrContinue where+  fmap f (ContinueWith x) = ContinueWith (f x)+  fmap _ (Stop ev s)      = Stop ev s++instance Outputable a => Outputable (StopOrContinue a) where+  ppr (Stop ev s)      = text "Stop" <> parens s <+> ppr ev+  ppr (ContinueWith w) = text "ContinueWith" <+> ppr w++continueWith :: a -> TcS (StopOrContinue a)+continueWith = return . ContinueWith++stopWith :: CtEvidence -> String -> TcS (StopOrContinue a)+stopWith ev s = return (Stop ev (text s))++andWhenContinue :: TcS (StopOrContinue a)+                -> (a -> TcS (StopOrContinue b))+                -> TcS (StopOrContinue b)+andWhenContinue tcs1 tcs2+  = do { r <- tcs1+       ; case r of+           Stop ev s       -> return (Stop ev s)+           ContinueWith ct -> tcs2 ct }+infixr 0 `andWhenContinue`    -- allow chaining with ($)++rewriteEvidence :: CtEvidence   -- old evidence+                -> TcPredType   -- new predicate+                -> TcCoercion   -- Of type :: new predicate ~ <type of old evidence>+                -> TcS (StopOrContinue CtEvidence)+-- Returns Just new_ev iff either (i)  'co' is reflexivity+--                             or (ii) 'co' is not reflexivity, and 'new_pred' not cached+-- In either case, there is nothing new to do with new_ev+{-+     rewriteEvidence old_ev new_pred co+Main purpose: create new evidence for new_pred;+              unless new_pred is cached already+* Returns a new_ev : new_pred, with same wanted/given/derived flag as old_ev+* If old_ev was wanted, create a binding for old_ev, in terms of new_ev+* If old_ev was given, AND not cached, create a binding for new_ev, in terms of old_ev+* Returns Nothing if new_ev is already cached++        Old evidence    New predicate is               Return new evidence+        flavour                                        of same flavor+        -------------------------------------------------------------------+        Wanted          Already solved or in inert     Nothing+        or Derived      Not                            Just new_evidence++        Given           Already in inert               Nothing+                        Not                            Just new_evidence++Note [Rewriting with Refl]+~~~~~~~~~~~~~~~~~~~~~~~~~~+If the coercion is just reflexivity then you may re-use the same+variable.  But be careful!  Although the coercion is Refl, new_pred+may reflect the result of unification alpha := ty, so new_pred might+not _look_ the same as old_pred, and it's vital to proceed from now on+using new_pred.++qThe flattener preserves type synonyms, so they should appear in new_pred+as well as in old_pred; that is important for good error messages.+ -}+++rewriteEvidence old_ev@(CtDerived {}) new_pred _co+  = -- If derived, don't even look at the coercion.+    -- This is very important, DO NOT re-order the equations for+    -- rewriteEvidence to put the isTcReflCo test first!+    -- Why?  Because for *Derived* constraints, c, the coercion, which+    -- was produced by flattening, may contain suspended calls to+    -- (ctEvTerm c), which fails for Derived constraints.+    -- (Getting this wrong caused Trac #7384.)+    continueWith (old_ev { ctev_pred = new_pred })++rewriteEvidence old_ev new_pred co+  | isTcReflCo co -- See Note [Rewriting with Refl]+  = continueWith (old_ev { ctev_pred = new_pred })++rewriteEvidence ev@(CtGiven { ctev_evar = old_evar , ctev_loc = loc }) new_pred co+  = do { new_ev <- newGivenEvVar loc (new_pred, new_tm)+       ; continueWith new_ev }+  where+    -- mkEvCast optimises ReflCo+    new_tm = mkEvCast (EvId old_evar) (tcDowngradeRole Representational+                                                       (ctEvRole ev)+                                                       (mkTcSymCo co))++rewriteEvidence ev@(CtWanted { ctev_dest = dest+                             , ctev_loc = loc }) new_pred co+  = do { mb_new_ev <- newWanted loc new_pred+       ; MASSERT( tcCoercionRole co == ctEvRole ev )+       ; setWantedEvTerm dest+                   (mkEvCast (getEvTerm mb_new_ev)+                             (tcDowngradeRole Representational (ctEvRole ev) co))+       ; case mb_new_ev of+            Fresh  new_ev -> continueWith new_ev+            Cached _      -> stopWith ev "Cached wanted" }+++rewriteEqEvidence :: CtEvidence         -- Old evidence :: olhs ~ orhs (not swapped)+                                        --              or orhs ~ olhs (swapped)+                  -> SwapFlag+                  -> TcType -> TcType   -- New predicate  nlhs ~ nrhs+                                        -- Should be zonked, because we use typeKind on nlhs/nrhs+                  -> TcCoercion         -- lhs_co, of type :: nlhs ~ olhs+                  -> TcCoercion         -- rhs_co, of type :: nrhs ~ orhs+                  -> TcS (StopOrContinue CtEvidence)  -- Of type nlhs ~ nrhs+-- For (rewriteEqEvidence (Given g olhs orhs) False nlhs nrhs lhs_co rhs_co)+-- we generate+-- If not swapped+--      g1 : nlhs ~ nrhs = lhs_co ; g ; sym rhs_co+-- If 'swapped'+--      g1 : nlhs ~ nrhs = lhs_co ; Sym g ; sym rhs_co+--+-- For (Wanted w) we do the dual thing.+-- New  w1 : nlhs ~ nrhs+-- If not swapped+--      w : olhs ~ orhs = sym lhs_co ; w1 ; rhs_co+-- If swapped+--      w : orhs ~ olhs = sym rhs_co ; sym w1 ; lhs_co+--+-- It's all a form of rewwriteEvidence, specialised for equalities+rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co+  | CtDerived {} <- old_ev  -- Don't force the evidence for a Derived+  = continueWith (old_ev { ctev_pred = new_pred })++  | NotSwapped <- swapped+  , isTcReflCo lhs_co      -- See Note [Rewriting with Refl]+  , isTcReflCo rhs_co+  = continueWith (old_ev { ctev_pred = new_pred })++  | CtGiven { ctev_evar = old_evar } <- old_ev+  = do { let new_tm = EvCoercion (lhs_co+                                  `mkTcTransCo` maybeSym swapped (mkTcCoVarCo old_evar)+                                  `mkTcTransCo` mkTcSymCo rhs_co)+       ; new_ev <- newGivenEvVar loc' (new_pred, new_tm)+       ; continueWith new_ev }++  | CtWanted { ctev_dest = dest } <- old_ev+  = do { (new_ev, hole_co) <- newWantedEq loc' (ctEvRole old_ev) nlhs nrhs+       ; let co = maybeSym swapped $+                  mkSymCo lhs_co+                  `mkTransCo` hole_co+                  `mkTransCo` rhs_co+       ; setWantedEq dest co+       ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co])+       ; continueWith new_ev }++  | otherwise+  = panic "rewriteEvidence"+  where+    new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs++      -- equality is like a type class. Bumping the depth is necessary because+      -- of recursive newtypes, where "reducing" a newtype can actually make+      -- it bigger. See Note [Newtypes can blow the stack].+    loc      = ctEvLoc old_ev+    loc'     = bumpCtLocDepth loc++{- Note [unifyWanted and unifyDerived]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When decomposing equalities we often create new wanted constraints for+(s ~ t).  But what if s=t?  Then it'd be faster to return Refl right away.+Similar remarks apply for Derived.++Rather than making an equality test (which traverses the structure of the+type, perhaps fruitlessly, unifyWanted traverses the common structure, and+bales out when it finds a difference by creating a new Wanted constraint.+But where it succeeds in finding common structure, it just builds a coercion+to reflect it.+-}++unifyWanted :: CtLoc -> Role+            -> TcType -> TcType -> TcS Coercion+-- Return coercion witnessing the equality of the two types,+-- emitting new work equalities where necessary to achieve that+-- Very good short-cut when the two types are equal, or nearly so+-- See Note [unifyWanted and unifyDerived]+-- The returned coercion's role matches the input parameter+unifyWanted loc Phantom ty1 ty2+  = do { kind_co <- unifyWanted loc Nominal (typeKind ty1) (typeKind ty2)+       ; return (mkPhantomCo kind_co ty1 ty2) }++unifyWanted loc role orig_ty1 orig_ty2+  = go orig_ty1 orig_ty2+  where+    go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2+    go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2'++    go (FunTy s1 t1) (FunTy s2 t2)+      = do { co_s <- unifyWanted loc role s1 s2+           ; co_t <- unifyWanted loc role t1 t2+           ; return (mkFunCo role co_s co_t) }+    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)+      | tc1 == tc2, tys1 `equalLength` tys2+      , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality+      = do { cos <- zipWith3M (unifyWanted loc)+                              (tyConRolesX role tc1) tys1 tys2+           ; return (mkTyConAppCo role tc1 cos) }++    go ty1@(TyVarTy tv) ty2+      = do { mb_ty <- isFilledMetaTyVar_maybe tv+           ; case mb_ty of+                Just ty1' -> go ty1' ty2+                Nothing   -> bale_out ty1 ty2}+    go ty1 ty2@(TyVarTy tv)+      = do { mb_ty <- isFilledMetaTyVar_maybe tv+           ; case mb_ty of+                Just ty2' -> go ty1 ty2'+                Nothing   -> bale_out ty1 ty2 }++    go ty1@(CoercionTy {}) (CoercionTy {})+      = return (mkReflCo role ty1) -- we just don't care about coercions!++    go ty1 ty2 = bale_out ty1 ty2++    bale_out ty1 ty2+       | ty1 `tcEqType` ty2 = return (mkTcReflCo role ty1)+        -- Check for equality; e.g. a ~ a, or (m a) ~ (m a)+       | otherwise = emitNewWantedEq loc role orig_ty1 orig_ty2++unifyDeriveds :: CtLoc -> [Role] -> [TcType] -> [TcType] -> TcS ()+-- See Note [unifyWanted and unifyDerived]+unifyDeriveds loc roles tys1 tys2 = zipWith3M_ (unify_derived loc) roles tys1 tys2++unifyDerived :: CtLoc -> Role -> Pair TcType -> TcS ()+-- See Note [unifyWanted and unifyDerived]+unifyDerived loc role (Pair ty1 ty2) = unify_derived loc role ty1 ty2++unify_derived :: CtLoc -> Role -> TcType -> TcType -> TcS ()+-- Create new Derived and put it in the work list+-- Should do nothing if the two types are equal+-- See Note [unifyWanted and unifyDerived]+unify_derived _   Phantom _        _        = return ()+unify_derived loc role    orig_ty1 orig_ty2+  = go orig_ty1 orig_ty2+  where+    go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2+    go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2'++    go (FunTy s1 t1) (FunTy s2 t2)+      = do { unify_derived loc role s1 s2+           ; unify_derived loc role t1 t2 }+    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)+      | tc1 == tc2, tys1 `equalLength` tys2+      , isInjectiveTyCon tc1 role+      = unifyDeriveds loc (tyConRolesX role tc1) tys1 tys2+    go ty1@(TyVarTy tv) ty2+      = do { mb_ty <- isFilledMetaTyVar_maybe tv+           ; case mb_ty of+                Just ty1' -> go ty1' ty2+                Nothing   -> bale_out ty1 ty2 }+    go ty1 ty2@(TyVarTy tv)+      = do { mb_ty <- isFilledMetaTyVar_maybe tv+           ; case mb_ty of+                Just ty2' -> go ty1 ty2'+                Nothing   -> bale_out ty1 ty2 }+    go ty1 ty2 = bale_out ty1 ty2++    bale_out ty1 ty2+       | ty1 `tcEqType` ty2 = return ()+        -- Check for equality; e.g. a ~ a, or (m a) ~ (m a)+       | otherwise = emitNewDerivedEq loc role orig_ty1 orig_ty2++maybeSym :: SwapFlag -> TcCoercion -> TcCoercion+maybeSym IsSwapped  co = mkTcSymCo co+maybeSym NotSwapped co = co
+ typecheck/TcClassDcl.hs view
@@ -0,0 +1,524 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Typechecking class declarations+-}++{-# LANGUAGE CPP #-}++module TcClassDcl ( tcClassSigs, tcClassDecl2,+                    findMethodBind, instantiateMethod,+                    tcClassMinimalDef,+                    HsSigFun, mkHsSigFun,+                    tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr,+                    tcATDefault+                  ) where++#include "HsVersions.h"++import HsSyn+import TcEnv+import TcSigs+import TcEvidence ( idHsWrapper )+import TcBinds+import TcUnify+import TcHsType+import TcMType+import Type     ( getClassPredTys_maybe, piResultTys )+import TcType+import TcRnMonad+import DriverPhases (HscSource(..))+import BuildTyCl( TcMethInfo )+import Class+import Coercion ( pprCoAxiom )+import DynFlags+import FamInst+import FamInstEnv+import Id+import Name+import NameEnv+import NameSet+import Var+import VarEnv+import Outputable+import SrcLoc+import TyCon+import Maybes+import BasicTypes+import Bag+import FastString+import BooleanFormula+import Util++import Control.Monad+import Data.List ( mapAccumL, partition )++{-+Dictionary handling+~~~~~~~~~~~~~~~~~~~+Every class implicitly declares a new data type, corresponding to dictionaries+of that class. So, for example:++        class (D a) => C a where+          op1 :: a -> a+          op2 :: forall b. Ord b => a -> b -> b++would implicitly declare++        data CDict a = CDict (D a)+                             (a -> a)+                             (forall b. Ord b => a -> b -> b)++(We could use a record decl, but that means changing more of the existing apparatus.+One step at at time!)++For classes with just one superclass+method, we use a newtype decl instead:++        class C a where+          op :: forallb. a -> b -> b++generates++        newtype CDict a = CDict (forall b. a -> b -> b)++Now DictTy in Type is just a form of type synomym:+        DictTy c t = TyConTy CDict `AppTy` t++Death to "ExpandingDicts".+++************************************************************************+*                                                                      *+                Type-checking the class op signatures+*                                                                      *+************************************************************************+-}++illegalHsigDefaultMethod :: Name -> SDoc+illegalHsigDefaultMethod n =+    text "Illegal default method(s) in class definition of" <+> ppr n <+> text "in hsig file"++tcClassSigs :: Name                -- Name of the class+            -> [LSig Name]+            -> LHsBinds Name+            -> TcM [TcMethInfo]    -- Exactly one for each method+tcClassSigs clas sigs def_methods+  = do { traceTc "tcClassSigs 1" (ppr clas)++       ; gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs+       ; let gen_dm_env :: NameEnv (SrcSpan, Type)+             gen_dm_env = mkNameEnv gen_dm_prs++       ; op_info <- concat <$> mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs++       ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ]+       ; sequence_ [ failWithTc (badMethodErr clas n)+                   | n <- dm_bind_names, not (n `elemNameSet` op_names) ]+                   -- Value binding for non class-method (ie no TypeSig)++       ; tcg_env <- getGblEnv+       ; if tcg_src tcg_env == HsigFile+            then+               -- Error if we have value bindings+               -- (Generic signatures without value bindings indicate+               -- that a default of this form is expected to be+               -- provided.)+               when (not (null def_methods)) $+                failWithTc (illegalHsigDefaultMethod clas)+            else+               -- Error for each generic signature without value binding+               sequence_ [ failWithTc (badGenericMethod clas n)+                         | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ]++       ; traceTc "tcClassSigs 2" (ppr clas)+       ; return op_info }+  where+    vanilla_sigs = [L loc (nm,ty) | L loc (ClassOpSig False nm ty) <- sigs]+    gen_sigs     = [L loc (nm,ty) | L loc (ClassOpSig True  nm ty) <- sigs]+    dm_bind_names :: [Name]     -- These ones have a value binding in the class decl+    dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]++    tc_sig :: NameEnv (SrcSpan, Type) -> ([Located Name], LHsSigType Name)+           -> TcM [TcMethInfo]+    tc_sig gen_dm_env (op_names, op_hs_ty)+      = do { traceTc "ClsSig 1" (ppr op_names)+           ; op_ty <- tcClassSigType op_names op_hs_ty   -- Class tyvars already in scope+           ; traceTc "ClsSig 2" (ppr op_names)+           ; return [ (op_name, op_ty, f op_name) | L _ op_name <- op_names ] }+           where+             f nm | Just lty <- lookupNameEnv gen_dm_env nm = Just (GenericDM lty)+                  | nm `elem` dm_bind_names                 = Just VanillaDM+                  | otherwise                               = Nothing++    tc_gen_sig (op_names, gen_hs_ty)+      = do { gen_op_ty <- tcClassSigType op_names gen_hs_ty+           ; return [ (op_name, (loc, gen_op_ty)) | L loc op_name <- op_names ] }++{-+************************************************************************+*                                                                      *+                Class Declarations+*                                                                      *+************************************************************************+-}++tcClassDecl2 :: LTyClDecl Name          -- The class declaration+             -> TcM (LHsBinds Id)++tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs,+                                tcdMeths = default_binds}))+  = recoverM (return emptyLHsBinds)     $+    setSrcSpan (getLoc class_name)      $+    do  { clas <- tcLookupLocatedClass class_name++        -- We make a separate binding for each default method.+        -- At one time I used a single AbsBinds for all of them, thus+        -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }+        -- But that desugars into+        --      ds = \d -> (..., ..., ...)+        --      dm1 = \d -> case ds d of (a,b,c) -> a+        -- And since ds is big, it doesn't get inlined, so we don't get good+        -- default methods.  Better to make separate AbsBinds for each+        ; let (tyvars, _, _, op_items) = classBigSig clas+              prag_fn     = mkPragEnv sigs default_binds+              sig_fn      = mkHsSigFun sigs+              clas_tyvars = snd (tcSuperSkolTyVars tyvars)+              pred        = mkClassPred clas (mkTyVarTys clas_tyvars)+        ; this_dict <- newEvVar pred++        ; let tc_item = tcDefMeth clas clas_tyvars this_dict+                                  default_binds sig_fn prag_fn+        ; dm_binds <- tcExtendTyVarEnv clas_tyvars $+                      mapM tc_item op_items++        ; return (unionManyBags dm_binds) }++tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)++tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name+          -> HsSigFun -> TcPragEnv -> ClassOpItem+          -> TcM (LHsBinds TcId)+-- Generate code for default methods+-- This is incompatible with Hugs, which expects a polymorphic+-- default method for every class op, regardless of whether or not+-- the programmer supplied an explicit default decl for the class.+-- (If necessary we can fix that, but we don't have a convenient Id to hand.)++tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing)+  = do { -- No default method+         mapM_ (addLocM (badDmPrag sel_id))+               (lookupPragEnv prag_fn (idName sel_id))+       ; return emptyBag }++tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn+          (sel_id, Just (dm_name, dm_spec))+  | Just (L bind_loc dm_bind, bndr_loc, prags) <- findMethodBind sel_name binds_in prag_fn+  = do { -- First look up the default method; it should be there!+         -- It can be the orinary default method+         -- or the generic-default method.  E.g of the latter+         --      class C a where+         --        op :: a -> a -> Bool+         --        default op :: Eq a => a -> a -> Bool+         --        op x y = x==y+         -- The default method we generate is+         --    $gm :: (C a, Eq a) => a -> a -> Bool+         --    $gm x y = x==y++         global_dm_id  <- tcLookupId dm_name+       ; global_dm_id  <- addInlinePrags global_dm_id prags+       ; local_dm_name <- newNameAt (getOccName sel_name) bndr_loc+            -- Base the local_dm_name on the selector name, because+            -- type errors from tcInstanceMethodBody come from here++       ; spec_prags <- discardConstraints $+                       tcSpecPrags global_dm_id prags+       ; warnTc NoReason+                (not (null spec_prags))+                (text "Ignoring SPECIALISE pragmas on default method"+                 <+> quotes (ppr sel_name))++       ; let hs_ty = hs_sig_fn sel_name+                     `orElse` pprPanic "tc_dm" (ppr sel_name)+             -- We need the HsType so that we can bring the right+             -- type variables into scope+             --+             -- Eg.   class C a where+             --          op :: forall b. Eq b => a -> [b] -> a+             --          gen_op :: a -> a+             --          generic gen_op :: D a => a -> a+             -- The "local_dm_ty" is precisely the type in the above+             -- type signatures, ie with no "forall a. C a =>" prefix++             local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars)++             lm_bind     = dm_bind { fun_id = L bind_loc local_dm_name }+                             -- Substitute the local_meth_name for the binder+                             -- NB: the binding is always a FunBind++             warn_redundant = case dm_spec of+                                GenericDM {} -> True+                                VanillaDM    -> False+                -- For GenericDM, warn if the user specifies a signature+                -- with redundant constraints; but not for VanillaDM, where+                -- the default method may well be 'error' or something++             ctxt = FunSigCtxt sel_name warn_redundant++       ; let local_dm_id = mkLocalId local_dm_name local_dm_ty+             local_dm_sig = CompleteSig { sig_bndr = local_dm_id+                                        , sig_ctxt  = ctxt+                                        , sig_loc   = getLoc (hsSigType hs_ty) }++       ; (ev_binds, (tc_bind, _))+               <- checkConstraints (ClsSkol clas) tyvars [this_dict] $+                  tcPolyCheck no_prag_fn local_dm_sig+                              (L bind_loc lm_bind)++       ; let export = ABE { abe_poly   = global_dm_id+                           , abe_mono  = local_dm_id+                           , abe_wrap  = idHsWrapper+                           , abe_prags = IsDefaultMethod }+             full_bind = AbsBinds { abs_tvs      = tyvars+                                  , abs_ev_vars  = [this_dict]+                                  , abs_exports  = [export]+                                  , abs_ev_binds = [ev_binds]+                                  , abs_binds    = tc_bind }++       ; return (unitBag (L bind_loc full_bind)) }++  | otherwise = pprPanic "tcDefMeth" (ppr sel_id)+  where+    sel_name = idName sel_id+    no_prag_fn = emptyPragEnv   -- No pragmas for local_meth_id;+                                -- they are all for meth_id++---------------+tcClassMinimalDef :: Name -> [LSig Name] -> [TcMethInfo] -> TcM ClassMinimalDef+tcClassMinimalDef _clas sigs op_info+  = case findMinimalDef sigs of+      Nothing -> return defMindef+      Just mindef -> do+        -- Warn if the given mindef does not imply the default one+        -- That is, the given mindef should at least ensure that the+        -- class ops without default methods are required, since we+        -- have no way to fill them in otherwise+        tcg_env <- getGblEnv+        -- However, only do this test when it's not an hsig file,+        -- since you can't write a default implementation.+        when (tcg_src tcg_env /= HsigFile) $+            whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $+                       (\bf -> addWarnTc NoReason (warningMinimalDefIncomplete bf))+        return mindef+  where+    -- By default require all methods without a default implementation+    defMindef :: ClassMinimalDef+    defMindef = mkAnd [ noLoc (mkVar name)+                      | (name, _, Nothing) <- op_info ]++instantiateMethod :: Class -> Id -> [TcType] -> TcType+-- Take a class operation, say+--      op :: forall ab. C a => forall c. Ix c => (b,c) -> a+-- Instantiate it at [ty1,ty2]+-- Return the "local method type":+--      forall c. Ix x => (ty2,c) -> ty1+instantiateMethod clas sel_id inst_tys+  = ASSERT( ok_first_pred ) local_meth_ty+  where+    rho_ty = piResultTys (idType sel_id) inst_tys+    (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty+                `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)++    ok_first_pred = case getClassPredTys_maybe first_pred of+                      Just (clas1, _tys) -> clas == clas1+                      Nothing -> False+              -- The first predicate should be of form (C a b)+              -- where C is the class in question+++---------------------------+type HsSigFun = Name -> Maybe (LHsSigType Name)++mkHsSigFun :: [LSig Name] -> HsSigFun+mkHsSigFun sigs = lookupNameEnv env+  where+    env = mkHsSigEnv get_classop_sig sigs++    get_classop_sig :: LSig Name -> Maybe ([Located Name], LHsSigType Name)+    get_classop_sig  (L _ (ClassOpSig _ ns hs_ty)) = Just (ns, hs_ty)+    get_classop_sig  _                             = Nothing++---------------------------+findMethodBind  :: Name                 -- Selector+                -> LHsBinds Name        -- A group of bindings+                -> TcPragEnv+                -> Maybe (LHsBind Name, SrcSpan, [LSig Name])+                -- Returns the binding, the binding+                -- site of the method binder, and any inline or+                -- specialisation pragmas+findMethodBind sel_name binds prag_fn+  = foldlBag mplus Nothing (mapBag f binds)+  where+    prags    = lookupPragEnv prag_fn sel_name++    f bind@(L _ (FunBind { fun_id = L bndr_loc op_name }))+      | op_name == sel_name+             = Just (bind, bndr_loc, prags)+    f _other = Nothing++---------------------------+findMinimalDef :: [LSig Name] -> Maybe ClassMinimalDef+findMinimalDef = firstJusts . map toMinimalDef+  where+    toMinimalDef :: LSig Name -> Maybe ClassMinimalDef+    toMinimalDef (L _ (MinimalSig _ (L _ bf))) = Just (fmap unLoc bf)+    toMinimalDef _                             = Nothing++{-+Note [Polymorphic methods]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    class Foo a where+        op :: forall b. Ord b => a -> b -> b -> b+    instance Foo c => Foo [c] where+        op = e++When typechecking the binding 'op = e', we'll have a meth_id for op+whose type is+      op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b++So tcPolyBinds must be capable of dealing with nested polytypes;+and so it is. See TcBinds.tcMonoBinds (with type-sig case).++Note [Silly default-method bind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we pass the default method binding to the type checker, it must+look like    op2 = e+not          $dmop2 = e+otherwise the "$dm" stuff comes out error messages.  But we want the+"$dm" to come out in the interface file.  So we typecheck the former,+and wrap it in a let, thus+          $dmop2 = let op2 = e in op2+This makes the error messages right.+++************************************************************************+*                                                                      *+                Error messages+*                                                                      *+************************************************************************+-}++tcMkDeclCtxt :: TyClDecl Name -> SDoc+tcMkDeclCtxt decl = hsep [text "In the", pprTyClDeclFlavour decl,+                      text "declaration for", quotes (ppr (tcdName decl))]++tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a+tcAddDeclCtxt decl thing_inside+  = addErrCtxt (tcMkDeclCtxt decl) thing_inside++badMethodErr :: Outputable a => a -> Name -> SDoc+badMethodErr clas op+  = hsep [text "Class", quotes (ppr clas),+          text "does not have a method", quotes (ppr op)]++badGenericMethod :: Outputable a => a -> Name -> SDoc+badGenericMethod clas op+  = hsep [text "Class", quotes (ppr clas),+          text "has a generic-default signature without a binding", quotes (ppr op)]++{-+badGenericInstanceType :: LHsBinds Name -> SDoc+badGenericInstanceType binds+  = vcat [text "Illegal type pattern in the generic bindings",+          nest 2 (ppr binds)]++missingGenericInstances :: [Name] -> SDoc+missingGenericInstances missing+  = text "Missing type patterns for" <+> pprQuotedList missing++dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc+dupGenericInsts tc_inst_infos+  = vcat [text "More than one type pattern for a single generic type constructor:",+          nest 2 (vcat (map ppr_inst_ty tc_inst_infos)),+          text "All the type patterns for a generic type constructor must be identical"+    ]+  where+    ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)+-}+badDmPrag :: Id -> Sig Name -> TcM ()+badDmPrag sel_id prag+  = addErrTc (text "The" <+> hsSigDoc prag <+> ptext (sLit "for default method")+              <+> quotes (ppr sel_id)+              <+> text "lacks an accompanying binding")++warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc+warningMinimalDefIncomplete mindef+  = vcat [ text "The MINIMAL pragma does not require:"+         , nest 2 (pprBooleanFormulaNice mindef)+         , text "but there is no default implementation." ]++tcATDefault :: Bool -- If a warning should be emitted when a default instance+                    -- definition is not provided by the user+            -> SrcSpan+            -> TCvSubst+            -> NameSet+            -> ClassATItem+            -> TcM [FamInst]+-- ^ Construct default instances for any associated types that+-- aren't given a user definition+-- Returns [] or singleton+tcATDefault emit_warn loc inst_subst defined_ats (ATI fam_tc defs)+  -- User supplied instances ==> everything is OK+  | tyConName fam_tc `elemNameSet` defined_ats+  = return []++  -- No user instance, have defaults ==> instantiate them+   -- Example:   class C a where { type F a b :: *; type F a b = () }+   --            instance C [x]+   -- Then we want to generate the decl:   type F [x] b = ()+  | Just (rhs_ty, _loc) <- defs+  = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst+                                            (tyConTyVars fam_tc)+             rhs'     = substTyUnchecked subst' rhs_ty+             tcv' = tyCoVarsOfTypesList pat_tys'+             (tv', cv') = partition isTyVar tcv'+             tvs'     = toposortTyVars tv'+             cvs'     = toposortTyVars cv'+       ; rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) pat_tys'+       ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' cvs'+                                     fam_tc pat_tys' rhs'+           -- NB: no validity check. We check validity of default instances+           -- in the class definition. Because type instance arguments cannot+           -- be type family applications and cannot be polytypes, the+           -- validity check is redundant.++       ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty+                                              , pprCoAxiom axiom ])+       ; fam_inst <- newFamInst SynFamilyInst axiom+       ; return [fam_inst] }++   -- No defaults ==> generate a warning+  | otherwise  -- defs = Nothing+  = do { when emit_warn $ warnMissingAT (tyConName fam_tc)+       ; return [] }+  where+    subst_tv subst tc_tv+      | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv+      = (subst, ty)+      | otherwise+      = (extendTvSubst subst tc_tv ty', ty')+      where+        ty' = mkTyVarTy (updateTyVarKind (substTyUnchecked subst) tc_tv)++warnMissingAT :: Name -> TcM ()+warnMissingAT name+  = do { warn <- woptM Opt_WarnMissingMethods+       ; traceTc "warn" (ppr name <+> ppr warn)+       ; hsc_src <- fmap tcg_src getGblEnv+       -- Warn only if -Wmissing-methods AND not a signature+       ; warnTc (Reason Opt_WarnMissingMethods) (warn && hsc_src /= HsigFile)+                (text "No explicit" <+> text "associated type"+                    <+> text "or default declaration for     "+                    <+> quotes (ppr name)) }
+ typecheck/TcDefaults.hs view
@@ -0,0 +1,104 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1993-1998++\section[TcDefaults]{Typechecking \tr{default} declarations}+-}++module TcDefaults ( tcDefaults ) where++import HsSyn+import Name+import Class+import TcRnMonad+import TcEnv+import TcHsType+import TcHsSyn+import TcSimplify+import TcValidity+import TcType+import PrelNames+import SrcLoc+import Outputable+import FastString+import qualified GHC.LanguageExtensions as LangExt++tcDefaults :: [LDefaultDecl Name]+           -> TcM (Maybe [Type])    -- Defaulting types to heave+                                    -- into Tc monad for later use+                                    -- in Disambig.++tcDefaults []+  = getDeclaredDefaultTys       -- No default declaration, so get the+                                -- default types from the envt;+                                -- i.e. use the current ones+                                -- (the caller will put them back there)+        -- It's important not to return defaultDefaultTys here (which+        -- we used to do) because in a TH program, tcDefaults [] is called+        -- repeatedly, once for each group of declarations between top-level+        -- splices.  We don't want to carefully set the default types in+        -- one group, only for the next group to ignore them and install+        -- defaultDefaultTys++tcDefaults [L _ (DefaultDecl [])]+  = return (Just [])            -- Default declaration specifying no types++tcDefaults [L locn (DefaultDecl mono_tys)]+  = setSrcSpan locn                     $+    addErrCtxt defaultDeclCtxt          $+    do  { ovl_str   <- xoptM LangExt.OverloadedStrings+        ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules+        ; num_class    <- tcLookupClass numClassName+        ; deflt_str <- if ovl_str+                       then mapM tcLookupClass [isStringClassName]+                       else return []+        ; deflt_interactive <- if ext_deflt+                               then mapM tcLookupClass interactiveClassNames+                               else return []+        ; let deflt_clss = num_class : deflt_str ++ deflt_interactive++        ; tau_tys <- mapAndReportM (tc_default_ty deflt_clss) mono_tys++        ; return (Just tau_tys) }++tcDefaults decls@(L locn (DefaultDecl _) : _)+  = setSrcSpan locn $+    failWithTc (dupDefaultDeclErr decls)+++tc_default_ty :: [Class] -> LHsType Name -> TcM Type+tc_default_ty deflt_clss hs_ty+ = do   { (ty, _kind) <- solveEqualities $+                         tcLHsType hs_ty+        ; ty <- zonkTcTypeToType emptyZonkEnv ty   -- establish Type invariants+        ; checkValidType DefaultDeclCtxt ty++        -- Check that the type is an instance of at least one of the deflt_clss+        ; oks <- mapM (check_instance ty) deflt_clss+        ; checkTc (or oks) (badDefaultTy ty deflt_clss)+        ; return ty }++check_instance :: Type -> Class -> TcM Bool+  -- Check that ty is an instance of cls+  -- We only care about whether it worked or not; return a boolean+check_instance ty cls+  = do  { (_, success) <- discardErrs $+                          askNoErrs $+                          simplifyDefault [mkClassPred cls [ty]]+        ; return success }++defaultDeclCtxt :: SDoc+defaultDeclCtxt = text "When checking the types in a default declaration"++dupDefaultDeclErr :: [Located (DefaultDecl Name)] -> SDoc+dupDefaultDeclErr (L _ (DefaultDecl _) : dup_things)+  = hang (text "Multiple default declarations")+       2 (vcat (map pp dup_things))+  where+    pp (L locn (DefaultDecl _)) = text "here was another default declaration" <+> ppr locn+dupDefaultDeclErr [] = panic "dupDefaultDeclErr []"++badDefaultTy :: Type -> [Class] -> SDoc+badDefaultTy ty deflt_clss+  = hang (text "The default type" <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of"))+       2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss))
+ typecheck/TcDeriv.hs view
@@ -0,0 +1,1843 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Handles @deriving@ clauses on @data@ declarations.+-}++{-# LANGUAGE CPP #-}++module TcDeriv ( tcDeriving, DerivInfo(..), mkDerivInfos ) where++#include "HsVersions.h"++import HsSyn+import DynFlags++import TcRnMonad+import FamInst+import TcDerivInfer+import TcDerivUtils+import TcValidity( allDistinctTyVars )+import TcClassDcl( tcATDefault, tcMkDeclCtxt )+import TcEnv+import TcGenDeriv                       -- Deriv stuff+import InstEnv+import Inst+import FamInstEnv+import TcHsType+import TcMType++import RnNames( extendGlobalRdrEnvRn )+import RnBinds+import RnEnv+import RnSource   ( addTcgDUs )+import Avail++import Unify( tcUnifyTy )+import BasicTypes ( DerivStrategy(..) )+import Class+import Type+import ErrUtils+import DataCon+import Maybes+import RdrName+import Name+import NameSet+import TyCon+import TcType+import Var+import VarEnv+import VarSet+import PrelNames+import SrcLoc+import Util+import Outputable+import FastString+import Bag+import Pair+import FV (fvVarList, unionFV, mkFVs)+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Data.List++{-+************************************************************************+*                                                                      *+                Overview+*                                                                      *+************************************************************************++Overall plan+~~~~~~~~~~~~+1.  Convert the decls (i.e. data/newtype deriving clauses,+    plus standalone deriving) to [EarlyDerivSpec]++2.  Infer the missing contexts for the InferTheta's++3.  Add the derived bindings, generating InstInfos+-}++data EarlyDerivSpec = InferTheta (DerivSpec [ThetaOrigin])+                    | GivenTheta (DerivSpec ThetaType)+        -- InferTheta ds => the context for the instance should be inferred+        --      In this case ds_theta is the list of all the sets of+        --      constraints needed, such as (Eq [a], Eq a), together with a+        --      suitable CtLoc to get good error messages.+        --      The inference process is to reduce this to a+        --      simpler form (e.g. Eq a)+        --+        -- GivenTheta ds => the exact context for the instance is supplied+        --                  by the programmer; it is ds_theta+        -- See Note [Inferring the instance context] in TcDerivInfer++earlyDSLoc :: EarlyDerivSpec -> SrcSpan+earlyDSLoc (InferTheta spec) = ds_loc spec+earlyDSLoc (GivenTheta spec) = ds_loc spec++splitEarlyDerivSpec :: [EarlyDerivSpec]+                    -> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType])+splitEarlyDerivSpec [] = ([],[])+splitEarlyDerivSpec (InferTheta spec : specs) =+    case splitEarlyDerivSpec specs of (is, gs) -> (spec : is, gs)+splitEarlyDerivSpec (GivenTheta spec : specs) =+    case splitEarlyDerivSpec specs of (is, gs) -> (is, spec : gs)++instance Outputable EarlyDerivSpec where+  ppr (InferTheta spec) = ppr spec <+> text "(Infer)"+  ppr (GivenTheta spec) = ppr spec <+> text "(Given)"++{-+Note [Data decl contexts]+~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++        data (RealFloat a) => Complex a = !a :+ !a deriving( Read )++We will need an instance decl like:++        instance (Read a, RealFloat a) => Read (Complex a) where+          ...++The RealFloat in the context is because the read method for Complex is bound+to construct a Complex, and doing that requires that the argument type is+in RealFloat.++But this ain't true for Show, Eq, Ord, etc, since they don't construct+a Complex; they only take them apart.++Our approach: identify the offending classes, and add the data type+context to the instance decl.  The "offending classes" are++        Read, Enum?++FURTHER NOTE ADDED March 2002.  In fact, Haskell98 now requires that+pattern matching against a constructor from a data type with a context+gives rise to the constraints for that context -- or at least the thinned+version.  So now all classes are "offending".++Note [Newtype deriving]+~~~~~~~~~~~~~~~~~~~~~~~+Consider this:+    class C a b+    instance C [a] Char+    newtype T = T Char deriving( C [a] )++Notice the free 'a' in the deriving.  We have to fill this out to+    newtype T = T Char deriving( forall a. C [a] )++And then translate it to:+    instance C [a] Char => C [a] T where ...+++Note [Newtype deriving superclasses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(See also Trac #1220 for an interesting exchange on newtype+deriving and superclasses.)++The 'tys' here come from the partial application in the deriving+clause. The last arg is the new instance type.++We must pass the superclasses; the newtype might be an instance+of them in a different way than the representation type+E.g.            newtype Foo a = Foo a deriving( Show, Num, Eq )+Then the Show instance is not done via Coercible; it shows+        Foo 3 as "Foo 3"+The Num instance is derived via Coercible, but the Show superclass+dictionary must the Show instance for Foo, *not* the Show dictionary+gotten from the Num dictionary. So we must build a whole new dictionary+not just use the Num one.  The instance we want is something like:+     instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where+        (+) = ((+)@a)+        ...etc...+There may be a coercion needed which we get from the tycon for the newtype+when the dict is constructed in TcInstDcls.tcInstDecl2+++Note [Unused constructors and deriving clauses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See Trac #3221.  Consider+   data T = T1 | T2 deriving( Show )+Are T1 and T2 unused?  Well, no: the deriving clause expands to mention+both of them.  So we gather defs/uses from deriving just like anything else.++-}++-- | Stuff needed to process a datatype's `deriving` clauses+data DerivInfo = DerivInfo { di_rep_tc  :: TyCon+                             -- ^ The data tycon for normal datatypes,+                             -- or the *representation* tycon for data families+                           , di_clauses :: [LHsDerivingClause Name]+                           , di_ctxt    :: SDoc -- ^ error context+                           }++-- | Extract `deriving` clauses of proper data type (skips data families)+mkDerivInfos :: [LTyClDecl Name] -> TcM [DerivInfo]+mkDerivInfos decls = concatMapM (mk_deriv . unLoc) decls+  where++    mk_deriv decl@(DataDecl { tcdLName = L _ data_name+                            , tcdDataDefn =+                                HsDataDefn { dd_derivs = L _ clauses } })+      = do { tycon <- tcLookupTyCon data_name+           ; return [DerivInfo { di_rep_tc = tycon, di_clauses = clauses+                               , di_ctxt = tcMkDeclCtxt decl }] }+    mk_deriv _ = return []++{-++************************************************************************+*                                                                      *+\subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}+*                                                                      *+************************************************************************+-}++tcDeriving  :: [DerivInfo]       -- All `deriving` clauses+            -> [LDerivDecl Name] -- All stand-alone deriving declarations+            -> TcM (TcGblEnv, Bag (InstInfo Name), HsValBinds Name)+tcDeriving deriv_infos deriv_decls+  = recoverM (do { g <- getGblEnv+                 ; return (g, emptyBag, emptyValBindsOut)}) $+    do  {       -- Fish the "deriving"-related information out of the TcEnv+                -- And make the necessary "equations".+          is_boot <- tcIsHsBootOrSig+        ; traceTc "tcDeriving" (ppr is_boot)++        ; early_specs <- makeDerivSpecs is_boot deriv_infos deriv_decls+        ; traceTc "tcDeriving 1" (ppr early_specs)++        ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs+        ; insts1 <- mapM genInst given_specs+        ; insts2 <- mapM genInst infer_specs++        ; dflags <- getDynFlags++        ; let (_, deriv_stuff, maybe_fvs) = unzip3 (insts1 ++ insts2)+        ; loc <- getSrcSpanM+        ; let (binds, famInsts) = genAuxBinds dflags loc+                                    (unionManyBags deriv_stuff)++        ; let mk_inst_infos1 = map fstOf3 insts1+        ; inst_infos1 <- apply_inst_infos mk_inst_infos1 given_specs++          -- We must put all the derived type family instances (from both+          -- infer_specs and given_specs) in the local instance environment+          -- before proceeding, or else simplifyInstanceContexts might+          -- get stuck if it has to reason about any of those family instances.+          -- See Note [Staging of tcDeriving]+        ; tcExtendLocalFamInstEnv (bagToList famInsts) $+          -- NB: only call tcExtendLocalFamInstEnv once, as it performs+          -- validity checking for all of the family instances you give it.+          -- If the family instances have errors, calling it twice will result+          -- in duplicate error messages!++     do {+        -- the stand-alone derived instances (@inst_infos1@) are used when+        -- inferring the contexts for "deriving" clauses' instances+        -- (@infer_specs@)+        ; final_specs <- extendLocalInstEnv (map iSpec inst_infos1) $+                         simplifyInstanceContexts infer_specs++        ; let mk_inst_infos2 = map fstOf3 insts2+        ; inst_infos2 <- apply_inst_infos mk_inst_infos2 final_specs+        ; let inst_infos = inst_infos1 ++ inst_infos2++        ; (inst_info, rn_binds, rn_dus) <-+            renameDeriv is_boot inst_infos binds++        ; unless (isEmptyBag inst_info) $+             liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"+                        (ddump_deriving inst_info rn_binds famInsts))++        ; gbl_env <- tcExtendLocalInstEnv (map iSpec (bagToList inst_info))+                                          getGblEnv+        ; let all_dus = rn_dus `plusDU` usesOnly (NameSet.mkFVs $ catMaybes maybe_fvs)+        ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) } }+  where+    ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name+                   -> Bag FamInst             -- ^ Rep type family instances+                   -> SDoc+    ddump_deriving inst_infos extra_binds repFamInsts+      =    hang (text "Derived class instances:")+              2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos))+                 $$ ppr extra_binds)+        $$ hangP "Derived type family instances:"+             (vcat (map pprRepTy (bagToList repFamInsts)))++    hangP s x = text "" $$ hang (ptext (sLit s)) 2 x++    -- Apply the suspended computations given by genInst calls.+    -- See Note [Staging of tcDeriving]+    apply_inst_infos :: [ThetaType -> TcM (InstInfo RdrName)]+                     -> [DerivSpec ThetaType] -> TcM [InstInfo RdrName]+    apply_inst_infos = zipWithM (\f ds -> f (ds_theta ds))++-- Prints the representable type family instance+pprRepTy :: FamInst -> SDoc+pprRepTy fi@(FamInst { fi_tys = lhs })+  = text "type" <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+>+      equals <+> ppr rhs+  where rhs = famInstRHS fi++renameDeriv :: Bool+            -> [InstInfo RdrName]+            -> Bag (LHsBind RdrName, LSig RdrName)+            -> TcM (Bag (InstInfo Name), HsValBinds Name, DefUses)+renameDeriv is_boot inst_infos bagBinds+  | is_boot     -- If we are compiling a hs-boot file, don't generate any derived bindings+                -- The inst-info bindings will all be empty, but it's easier to+                -- just use rn_inst_info to change the type appropriately+  = do  { (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos+        ; return ( listToBag rn_inst_infos+                 , emptyValBindsOut, usesOnly (plusFVs fvs)) }++  | otherwise+  = discardWarnings $+    -- Discard warnings about unused bindings etc+    setXOptM LangExt.EmptyCase $+    -- Derived decls (for empty types) can have+    --    case x of {}+    setXOptM LangExt.ScopedTypeVariables $+    setXOptM LangExt.KindSignatures $+    -- Derived decls (for newtype-deriving) can use ScopedTypeVariables &+    -- KindSignatures+    unsetXOptM LangExt.RebindableSyntax $+    -- See Note [Avoid RebindableSyntax when deriving]+    do  {+        -- Bring the extra deriving stuff into scope+        -- before renaming the instances themselves+        ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos))+        ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds+        ; let aux_val_binds = ValBindsIn aux_binds (bagToList aux_sigs)+        ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds+        ; let bndrs = collectHsValBinders rn_aux_lhs+        ; envs <- extendGlobalRdrEnvRn (map avail bndrs) emptyFsEnv ;+        ; setEnvs envs $+    do  { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs)) rn_aux_lhs+        ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos+        ; return (listToBag rn_inst_infos, rn_aux,+                  dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }++  where+    rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars)+    rn_inst_info+      inst_info@(InstInfo { iSpec = inst+                          , iBinds = InstBindings+                            { ib_binds = binds+                            , ib_tyvars = tyvars+                            , ib_pragmas = sigs+                            , ib_extensions = exts -- Only for type-checking+                            , ib_derived = sa } })+        =  ASSERT( null sigs )+           bindLocalNamesFV tyvars $+           do { (rn_binds,_, fvs) <- rnMethodBinds False (is_cls_nm inst) [] binds []+              ; let binds' = InstBindings { ib_binds = rn_binds+                                          , ib_tyvars = tyvars+                                          , ib_pragmas = []+                                          , ib_extensions = exts+                                          , ib_derived = sa }+              ; return (inst_info { iBinds = binds' }, fvs) }++{-+Note [Newtype deriving and unused constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (see Trac #1954):++  module Bug(P) where+  newtype P a = MkP (IO a) deriving Monad++If you compile with -Wunused-binds you do not expect the warning+"Defined but not used: data constructor MkP". Yet the newtype deriving+code does not explicitly mention MkP, but it should behave as if you+had written+  instance Monad P where+     return x = MkP (return x)+     ...etc...++So we want to signal a user of the data constructor 'MkP'.+This is the reason behind the (Maybe Name) part of the return type+of genInst.++Note [Staging of tcDeriving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here's a tricky corner case for deriving (adapted from Trac #2721):++    class C a where+      type T a+      foo :: a -> T a++    instance C Int where+      type T Int = Int+      foo = id++    newtype N = N Int deriving C++This will produce an instance something like this:++    instance C N where+      type T N = T Int+      foo = coerce (foo :: Int -> T Int) :: N -> T N++We must be careful in order to typecheck this code. When determining the+context for the instance (in simplifyInstanceContexts), we need to determine+that T N and T Int have the same representation, but to do that, the T N+instance must be in the local family instance environment. Otherwise, GHC+would be unable to conclude that T Int is representationally equivalent to+T Int, and simplifyInstanceContexts would get stuck.++Previously, tcDeriving would defer adding any derived type family instances to+the instance environment until the very end, which meant that+simplifyInstanceContexts would get called without all the type family instances+it needed in the environment in order to properly simplify instance like+the C N instance above.++To avoid this scenario, we carefully structure the order of events in+tcDeriving. We first call genInst on the standalone derived instance specs and+the instance specs obtained from deriving clauses. Note that the return type of+genInst is a triple:++    TcM (ThetaType -> TcM (InstInfo RdrName), BagDerivStuff, Maybe Name)++The type family instances are in the BagDerivStuff. The first field of the+triple is a suspended computation which, given an instance context, produces+the rest of the instance. The fact that it is suspended is important, because+right now, we don't have ThetaTypes for the instances that use deriving clauses+(only the standalone-derived ones).++Now we can can collect the type family instances and extend the local instance+environment. At this point, it is safe to run simplifyInstanceContexts on the+deriving-clause instance specs, which gives us the ThetaTypes for the+deriving-clause instances. Now we can feed all the ThetaTypes to the+suspended computations and obtain our InstInfos, at which point+tcDeriving is done.++An alternative design would be to split up genInst so that the+family instances are generated separately from the InstInfos. But this would+require carving up a lot of the GHC deriving internals to accommodate the+change. On the other hand, we can keep all of the InstInfo and type family+instance logic together in genInst simply by converting genInst to+continuation-returning style, so we opt for that route.++Note [Why we don't pass rep_tc into deriveTyData]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Down in the bowels of mkEqnHelp, we need to convert the fam_tc back into+the rep_tc by means of a lookup. And yet we have the rep_tc right here!+Why look it up again? Answer: it's just easier this way.+We drop some number of arguments from the end of the datatype definition+in deriveTyData. The arguments are dropped from the fam_tc.+This action may drop a *different* number of arguments+passed to the rep_tc, depending on how many free variables, etc., the+dropped patterns have.++Also, this technique carries over the kind substitution from deriveTyData+nicely.++Note [Avoid RebindableSyntax when deriving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The RebindableSyntax extension interacts awkwardly with the derivation of+any stock class whose methods require the use of string literals. The Show+class is a simple example (see Trac #12688):++  {-# LANGUAGE RebindableSyntax, OverloadedStrings #-}+  newtype Text = Text String+  fromString :: String -> Text+  fromString = Text++  data Foo = Foo deriving Show++This will generate code to the effect of:++  instance Show Foo where+    showsPrec _ Foo = showString "Foo"++But because RebindableSyntax and OverloadedStrings are enabled, the "Foo"+string literal is now of type Text, not String, which showString doesn't+accept! This causes the generated Show instance to fail to typecheck.++To avoid this kind of scenario, we simply turn off RebindableSyntax entirely+in derived code.++************************************************************************+*                                                                      *+                From HsSyn to DerivSpec+*                                                                      *+************************************************************************++@makeDerivSpecs@ fishes around to find the info about needed derived instances.+-}++makeDerivSpecs :: Bool+               -> [DerivInfo]+               -> [LDerivDecl Name]+               -> TcM [EarlyDerivSpec]+makeDerivSpecs is_boot deriv_infos deriv_decls+  = do  { eqns1 <- concatMapM (recoverM (return []) . deriveDerivInfo)  deriv_infos+        ; eqns2 <- concatMapM (recoverM (return []) . deriveStandalone) deriv_decls+        ; let eqns = eqns1 ++ eqns2++        ; if is_boot then   -- No 'deriving' at all in hs-boot files+              do { unless (null eqns) (add_deriv_err (head eqns))+                 ; return [] }+          else return eqns }+  where+    add_deriv_err eqn+       = setSrcSpan (earlyDSLoc eqn) $+         addErr (hang (text "Deriving not permitted in hs-boot file")+                    2 (text "Use an instance declaration instead"))++------------------------------------------------------------------+-- | Process a `deriving` clause+deriveDerivInfo :: DerivInfo -> TcM [EarlyDerivSpec]+deriveDerivInfo (DerivInfo { di_rep_tc = rep_tc, di_clauses = clauses+                           , di_ctxt = err_ctxt })+  = addErrCtxt err_ctxt $+    concatMapM (deriveForClause . unLoc) clauses+  where+    tvs = tyConTyVars rep_tc+    (tc, tys) = case tyConFamInstSig_maybe rep_tc of+                        -- data family:+                  Just (fam_tc, pats, _) -> (fam_tc, pats)+      -- NB: deriveTyData wants the *user-specified*+      -- name. See Note [Why we don't pass rep_tc into deriveTyData]++                  _ -> (rep_tc, mkTyVarTys tvs)     -- datatype++    deriveForClause :: HsDerivingClause Name -> TcM [EarlyDerivSpec]+    deriveForClause (HsDerivingClause { deriv_clause_strategy = dcs+                                      , deriv_clause_tys      = L _ preds })+      = concatMapM (deriveTyData tvs tc tys (fmap unLoc dcs)) preds++------------------------------------------------------------------+deriveStandalone :: LDerivDecl Name -> TcM [EarlyDerivSpec]+-- Standalone deriving declarations+--  e.g.   deriving instance Show a => Show (T a)+-- Rather like tcLocalInstDecl+deriveStandalone (L loc (DerivDecl deriv_ty deriv_strat' overlap_mode))+  = setSrcSpan loc                   $+    addErrCtxt (standaloneCtxt deriv_ty)  $+    do { traceTc "Standalone deriving decl for" (ppr deriv_ty)+       ; let deriv_strat = fmap unLoc deriv_strat'+       ; traceTc "Deriving strategy (standalone deriving)" $+           vcat [ppr deriv_strat, ppr deriv_ty]+       ; (tvs, theta, cls, inst_tys) <- tcHsClsInstType TcType.InstDeclCtxt deriv_ty+       ; traceTc "Standalone deriving;" $ vcat+              [ text "tvs:" <+> ppr tvs+              , text "theta:" <+> ppr theta+              , text "cls:" <+> ppr cls+              , text "tys:" <+> ppr inst_tys ]+                -- C.f. TcInstDcls.tcLocalInstDecl1+       ; checkTc (not (null inst_tys)) derivingNullaryErr++       ; let cls_tys = take (length inst_tys - 1) inst_tys+             inst_ty = last inst_tys+       ; traceTc "Standalone deriving:" $ vcat+              [ text "class:" <+> ppr cls+              , text "class types:" <+> ppr cls_tys+              , text "type:" <+> ppr inst_ty ]++       ; let bale_out msg = failWithTc (derivingThingErr False cls cls_tys+                              inst_ty deriv_strat msg)++       ; case tcSplitTyConApp_maybe inst_ty of+           Just (tc, tc_args)+              | className cls == typeableClassName+              -> do warnUselessTypeable+                    return []++              | isUnboxedTupleTyCon tc+              -> bale_out $ unboxedTyConErr "tuple"++              | isUnboxedSumTyCon tc+              -> bale_out $ unboxedTyConErr "sum"++              | isAlgTyCon tc || isDataFamilyTyCon tc  -- All other classes+              -> do { spec <- mkEqnHelp (fmap unLoc overlap_mode)+                                        tvs cls cls_tys tc tc_args+                                        (Just theta) deriv_strat+                    ; return [spec] }++           _  -> -- Complain about functions, primitive types, etc,+                 bale_out $+                 text "The last argument of the instance must be a data or newtype application"+        }++warnUselessTypeable :: TcM ()+warnUselessTypeable+  = do { warn <- woptM Opt_WarnDerivingTypeable+       ; when warn $ addWarnTc (Reason Opt_WarnDerivingTypeable)+                   $ text "Deriving" <+> quotes (ppr typeableClassName) <+>+                     text "has no effect: all types now auto-derive Typeable" }++------------------------------------------------------------------+deriveTyData :: [TyVar] -> TyCon -> [Type]   -- LHS of data or data instance+                                             --   Can be a data instance, hence [Type] args+             -> Maybe DerivStrategy          -- The optional deriving strategy+             -> LHsSigType Name              -- The deriving predicate+             -> TcM [EarlyDerivSpec]+-- The deriving clause of a data or newtype declaration+-- I.e. not standalone deriving+deriveTyData tvs tc tc_args deriv_strat deriv_pred+  = setSrcSpan (getLoc (hsSigType deriv_pred)) $  -- Use loc of the 'deriving' item+    do  { (deriv_tvs, cls, cls_tys, cls_arg_kinds)+                <- tcExtendTyVarEnv tvs $+                   tcHsDeriv deriv_pred+                -- Deriving preds may (now) mention+                -- the type variables for the type constructor, hence tcExtendTyVarenv+                -- The "deriv_pred" is a LHsType to take account of the fact that for+                -- newtype deriving we allow deriving (forall a. C [a]).++                -- Typeable is special, because Typeable :: forall k. k -> Constraint+                -- so the argument kind 'k' is not decomposable by splitKindFunTys+                -- as is the case for all other derivable type classes+        ; when (length cls_arg_kinds /= 1) $+            failWithTc (nonUnaryErr deriv_pred)+        ; let [cls_arg_kind] = cls_arg_kinds+        ; if className cls == typeableClassName+          then do warnUselessTypeable+                  return []+          else++     do {  -- Given data T a b c = ... deriving( C d ),+           -- we want to drop type variables from T so that (C d (T a)) is well-kinded+          let (arg_kinds, _)  = splitFunTys cls_arg_kind+              n_args_to_drop  = length arg_kinds+              n_args_to_keep  = tyConArity tc - n_args_to_drop+              (tc_args_to_keep, args_to_drop)+                              = splitAt n_args_to_keep tc_args+              inst_ty_kind    = typeKind (mkTyConApp tc tc_args_to_keep)++              -- Match up the kinds, and apply the resulting kind substitution+              -- to the types.  See Note [Unify kinds in deriving]+              -- We are assuming the tycon tyvars and the class tyvars are distinct+              mb_match        = tcUnifyTy inst_ty_kind cls_arg_kind+              enough_args     = n_args_to_keep >= 0++        -- Check that the result really is well-kinded+        ; checkTc (enough_args && isJust mb_match)+                  (derivingKindErr tc cls cls_tys cls_arg_kind enough_args)++        ; let Just kind_subst = mb_match+              ki_subst_range  = getTCvSubstRangeFVs kind_subst+              all_tkvs        = toposortTyVars $+                                fvVarList $ unionFV+                                  (tyCoFVsOfTypes tc_args_to_keep)+                                  (FV.mkFVs deriv_tvs)+              -- See Note [Unification of two kind variables in deriving]+              unmapped_tkvs   = filter (\v -> v `notElemTCvSubst` kind_subst+                                      && not (v `elemVarSet` ki_subst_range))+                                       all_tkvs+              (subst, _)      = mapAccumL substTyVarBndr+                                          kind_subst unmapped_tkvs+              final_tc_args   = substTys subst tc_args_to_keep+              final_cls_tys   = substTys subst cls_tys+              tkvs            = tyCoVarsOfTypesWellScoped $+                                final_cls_tys ++ final_tc_args++        ; traceTc "Deriving strategy (deriving clause)" $+            vcat [ppr deriv_strat, ppr deriv_pred]++        ; traceTc "derivTyData1" (vcat [ pprTyVars tvs, ppr tc, ppr tc_args+                                       , ppr deriv_pred+                                       , pprTyVars (tyCoVarsOfTypesList tc_args)+                                       , ppr n_args_to_keep, ppr n_args_to_drop+                                       , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match+                                       , ppr final_tc_args, ppr final_cls_tys ])++        ; traceTc "derivTyData2" (vcat [ ppr tkvs ])++        ; checkTc (allDistinctTyVars (mkVarSet tkvs) args_to_drop)     -- (a, b, c)+                  (derivingEtaErr cls final_cls_tys (mkTyConApp tc final_tc_args))+                -- Check that+                --  (a) The args to drop are all type variables; eg reject:+                --              data instance T a Int = .... deriving( Monad )+                --  (b) The args to drop are all *distinct* type variables; eg reject:+                --              class C (a :: * -> * -> *) where ...+                --              data instance T a a = ... deriving( C )+                --  (c) The type class args, or remaining tycon args,+                --      do not mention any of the dropped type variables+                --              newtype T a s = ... deriving( ST s )+                --              newtype instance K a a = ... deriving( Monad )+                --+                -- It is vital that the implementation of allDistinctTyVars+                -- expand any type synonyms.+                -- See Note [Eta-reducing type synonyms]++        ; spec <- mkEqnHelp Nothing tkvs+                            cls final_cls_tys tc final_tc_args+                            Nothing deriv_strat+        ; traceTc "derivTyData" (ppr spec)+        ; return [spec] } }+++{-+Note [Unify kinds in deriving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (Trac #8534)+    data T a b = MkT a deriving( Functor )+    -- where Functor :: (*->*) -> Constraint++So T :: forall k. * -> k -> *.   We want to get+    instance Functor (T * (a:*)) where ...+Notice the '*' argument to T.++Moreover, as well as instantiating T's kind arguments, we may need to instantiate+C's kind args.  Consider (Trac #8865):+  newtype T a b = MkT (Either a b) deriving( Category )+where+  Category :: forall k. (k -> k -> *) -> Constraint+We need to generate the instance+  instance Category * (Either a) where ...+Notice the '*' argument to Category.++So we need to+ * drop arguments from (T a b) to match the number of+   arrows in the (last argument of the) class;+ * and then *unify* kind of the remaining type against the+   expected kind, to figure out how to instantiate C's and T's+   kind arguments.++In the two examples,+ * we unify   kind-of( T k (a:k) ) ~ kind-of( Functor )+         i.e.      (k -> *) ~ (* -> *)   to find k:=*.+         yielding  k:=*++ * we unify   kind-of( Either ) ~ kind-of( Category )+         i.e.      (* -> * -> *)  ~ (k -> k -> k)+         yielding  k:=*++Now we get a kind substitution.  We then need to:++  1. Remove the substituted-out kind variables from the quantified kind vars++  2. Apply the substitution to the kinds of quantified *type* vars+     (and extend the substitution to reflect this change)++  3. Apply that extended substitution to the non-dropped args (types and+     kinds) of the type and class++Forgetting step (2) caused Trac #8893:+  data V a = V [a] deriving Functor+  data P (x::k->*) (a:k) = P (x a) deriving Functor+  data C (x::k->*) (a:k) = C (V (P x a)) deriving Functor++When deriving Functor for P, we unify k to *, but we then want+an instance   $df :: forall (x:*->*). Functor x => Functor (P * (x:*->*))+and similarly for C.  Notice the modified kind of x, both at binding+and occurrence sites.++This can lead to some surprising results when *visible* kind binder is+unified (in contrast to the above examples, in which only non-visible kind+binders were considered). Consider this example from Trac #11732:++    data T k (a :: k) = MkT deriving Functor++Since unification yields k:=*, this results in a generated instance of:++    instance Functor (T *) where ...++which looks odd at first glance, since one might expect the instance head+to be of the form Functor (T k). Indeed, one could envision an alternative+generated instance of:++    instance (k ~ *) => Functor (T k) where++But this does not typecheck as the result of a -XTypeInType design decision:+kind equalities are not allowed to be bound in types, only terms. But in+essence, the two instance declarations are entirely equivalent, since even+though (T k) matches any kind k, the only possibly value for k is *, since+anything else is ill-typed. As a result, we can just as comfortably use (T *).++Another way of thinking about is: deriving clauses often infer constraints.+For example:++    data S a = S a deriving Eq++infers an (Eq a) constraint in the derived instance. By analogy, when we+are deriving Functor, we might infer an equality constraint (e.g., k ~ *).+The only distinction is that GHC instantiates equality constraints directly+during the deriving process.++Another quirk of this design choice manifests when typeclasses have visible+kind parameters. Consider this code (also from Trac #11732):++    class Cat k (cat :: k -> k -> *) where+      catId   :: cat a a+      catComp :: cat b c -> cat a b -> cat a c++    instance Cat * (->) where+      catId   = id+      catComp = (.)++    newtype Fun a b = Fun (a -> b) deriving (Cat k)++Even though we requested an derived instance of the form (Cat k Fun), the+kind unification will actually generate (Cat * Fun) (i.e., the same thing as if+the user wrote deriving (Cat *)).++Note [Unification of two kind variables in deriving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As a special case of the Note above, it is possible to derive an instance of+a poly-kinded typeclass for a poly-kinded datatype. For example:++    class Category (cat :: k -> k -> *) where+    newtype T (c :: k -> k -> *) a b = MkT (c a b) deriving Category++This case is suprisingly tricky. To see why, let's write out what instance GHC+will attempt to derive (using -fprint-explicit-kinds syntax):++    instance Category k1 (T k2 c) where ...++GHC will attempt to unify k1 and k2, which produces a substitution (kind_subst)+that looks like [k2 :-> k1]. Importantly, we need to apply this substitution to+the type variable binder for c, since its kind is (k2 -> k2 -> *).++We used to accomplish this by doing the following:++    unmapped_tkvs = filter (`notElemTCvSubst` kind_subst) all_tkvs+    (subst, _)    = mapAccumL substTyVarBndr kind_subst unmapped_tkvs++Where all_tkvs contains all kind variables in the class and instance types (in+this case, all_tkvs = [k1,k2]). But since kind_subst only has one mapping,+this results in unmapped_tkvs being [k1], and as a consequence, k1 gets mapped+to another kind variable in subst! That is, subst = [k2 :-> k1, k1 :-> k_new].+This is bad, because applying that substitution yields the following instance:++   instance Category k_new (T k1 c) where ...++In other words, keeping k1 in unmapped_tvks taints the substitution, resulting+in an ill-kinded instance (this caused Trac #11837).++To prevent this, we need to filter out any variable from all_tkvs which either++1. Appears in the domain of kind_subst. notElemTCvSubst checks this.+2. Appears in the range of kind_subst. To do this, we compute the free+   variable set of the range of kind_subst with getTCvSubstRangeFVs, and check+   if a kind variable appears in that set.++Note [Eta-reducing type synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+One can instantiate a type in a data family instance with a type synonym that+mentions other type variables:++  type Const a b = a+  data family Fam (f :: * -> *) (a :: *)+  newtype instance Fam f (Const a f) = Fam (f a) deriving Functor++With -XTypeInType, it is also possible to define kind synonyms, and they can+mention other types in a datatype declaration. For example,++  type Const a b = a+  newtype T f (a :: Const * f) = T (f a) deriving Functor++When deriving, we need to perform eta-reduction analysis to ensure that none of+the eta-reduced type variables are mentioned elsewhere in the declaration. But+we need to be careful, because if we don't expand through the Const type+synonym, we will mistakenly believe that f is an eta-reduced type variable and+fail to derive Functor, even though the code above is correct (see Trac #11416,+where this was first noticed). For this reason, we expand the type synonyms in+the eta-reduced types before doing any analysis.+-}++mkEqnHelp :: Maybe OverlapMode+          -> [TyVar]+          -> Class -> [Type]+          -> TyCon -> [Type]+          -> DerivContext       -- Just    => context supplied (standalone deriving)+                                -- Nothing => context inferred (deriving on data decl)+          -> Maybe DerivStrategy+          -> TcRn EarlyDerivSpec+-- Make the EarlyDerivSpec for an instance+--      forall tvs. theta => cls (tys ++ [ty])+-- where the 'theta' is optional (that's the Maybe part)+-- Assumes that this declaration is well-kinded++mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta deriv_strat+  = do {      -- Find the instance of a data family+              -- Note [Looking up family instances for deriving]+         fam_envs <- tcGetFamInstEnvs+       ; let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tycon tc_args+              -- If it's still a data family, the lookup failed; i.e no instance exists+       ; when (isDataFamilyTyCon rep_tc)+              (bale_out (text "No family instance for" <+> quotes (pprTypeApp tycon tc_args)))++       ; dflags <- getDynFlags+       ; if isDataTyCon rep_tc then+            mkDataTypeEqn dflags overlap_mode tvs cls cls_tys+                          tycon tc_args rep_tc rep_tc_args mtheta deriv_strat+         else+            mkNewTypeEqn dflags overlap_mode tvs cls cls_tys+                         tycon tc_args rep_tc rep_tc_args mtheta deriv_strat }+  where+     bale_out msg = failWithTc (derivingThingErr False cls cls_tys+                      (mkTyConApp tycon tc_args) deriv_strat msg)++{-+Note [Looking up family instances for deriving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+tcLookupFamInstExact is an auxiliary lookup wrapper which requires+that looked-up family instances exist.  If called with a vanilla+tycon, the old type application is simply returned.++If we have+  data instance F () = ... deriving Eq+  data instance F () = ... deriving Eq+then tcLookupFamInstExact will be confused by the two matches;+but that can't happen because tcInstDecls1 doesn't call tcDeriving+if there are any overlaps.++There are two other things that might go wrong with the lookup.+First, we might see a standalone deriving clause+   deriving Eq (F ())+when there is no data instance F () in scope.++Note that it's OK to have+  data instance F [a] = ...+  deriving Eq (F [(a,b)])+where the match is not exact; the same holds for ordinary data types+with standalone deriving declarations.++Note [Deriving, type families, and partial applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When there are no type families, it's quite easy:++    newtype S a = MkS [a]+    -- :CoS :: S  ~ []  -- Eta-reduced++    instance Eq [a] => Eq (S a)         -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a)+    instance Monad [] => Monad S        -- by coercion sym (Monad :CoS)  : Monad [] ~ Monad S++When type familes are involved it's trickier:++    data family T a b+    newtype instance T Int a = MkT [a] deriving( Eq, Monad )+    -- :RT is the representation type for (T Int a)+    --  :Co:RT    :: :RT ~ []          -- Eta-reduced!+    --  :CoF:RT a :: T Int a ~ :RT a   -- Also eta-reduced!++    instance Eq [a] => Eq (T Int a)     -- easy by coercion+       -- d1 :: Eq [a]+       -- d2 :: Eq (T Int a) = d1 |> Eq (sym (:Co:RT a ; :coF:RT a))++    instance Monad [] => Monad (T Int)  -- only if we can eta reduce???+       -- d1 :: Monad []+       -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT))++Note the need for the eta-reduced rule axioms.  After all, we can+write it out+    instance Monad [] => Monad (T Int)  -- only if we can eta reduce???+      return x = MkT [x]+      ... etc ...++See Note [Eta reduction for data families] in FamInstEnv++%************************************************************************+%*                                                                      *+                Deriving data types+*                                                                      *+************************************************************************+-}++mkDataTypeEqn :: DynFlags+              -> Maybe OverlapMode+              -> [TyVar]                -- Universally quantified type variables in the instance+              -> Class                  -- Class for which we need to derive an instance+              -> [Type]                 -- Other parameters to the class except the last+              -> TyCon                  -- Type constructor for which the instance is requested+                                        --    (last parameter to the type class)+              -> [Type]                 -- Parameters to the type constructor+              -> TyCon                  -- rep of the above (for type families)+              -> [Type]                 -- rep of the above+              -> DerivContext        -- Context of the instance, for standalone deriving+              -> Maybe DerivStrategy    -- 'Just' if user requests a particular+                                        -- deriving strategy.+                                        -- Otherwise, 'Nothing'.+              -> TcRn EarlyDerivSpec    -- Return 'Nothing' if error++mkDataTypeEqn dflags overlap_mode tvs cls cls_tys+              tycon tc_args rep_tc rep_tc_args mtheta deriv_strat+  = case deriv_strat of+      Just StockStrategy    -> mk_eqn_stock dflags mtheta cls cls_tys rep_tc+                                go_for_it bale_out+      Just AnyclassStrategy -> mk_eqn_anyclass dflags go_for_it bale_out+      -- GeneralizedNewtypeDeriving makes no sense for non-newtypes+      Just NewtypeStrategy  -> bale_out gndNonNewtypeErr+      -- Lacking a user-requested deriving strategy, we will try to pick+      -- between the stock or anyclass strategies+      Nothing -> mk_eqn_no_mechanism dflags tycon mtheta cls cls_tys rep_tc+                   go_for_it bale_out+  where+    go_for_it    = mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args+                     rep_tc rep_tc_args mtheta (isJust deriv_strat)+    bale_out msg = failWithTc (derivingThingErr False cls cls_tys+                     (mkTyConApp tycon tc_args) deriv_strat msg)++mk_data_eqn :: Maybe OverlapMode -> [TyVar] -> Class -> [Type]+            -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext+            -> Bool -- True if an explicit deriving strategy keyword was+                    -- provided+            -> DerivSpecMechanism -- How GHC should proceed attempting to+                                  -- derive this instance, determined in+                                  -- mkDataTypeEqn/mkNewTypeEqn+            -> TcM EarlyDerivSpec+mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args+            mtheta strat_used mechanism+  = do doDerivInstErrorChecks1 cls cls_tys tycon tc_args rep_tc mtheta+                               strat_used mechanism+       loc                  <- getSrcSpanM+       dfun_name            <- newDFunName' cls tycon+       case mtheta of+        Nothing -> -- Infer context+          do { (inferred_constraints, tvs', inst_tys')+                 <- inferConstraints tvs cls cls_tys inst_ty+                                     rep_tc rep_tc_args mechanism+             ; return $ InferTheta $ DS+                   { ds_loc = loc+                   , ds_name = dfun_name, ds_tvs = tvs'+                   , ds_cls = cls, ds_tys = inst_tys'+                   , ds_tc = rep_tc+                   , ds_theta = inferred_constraints+                   , ds_overlap = overlap_mode+                   , ds_mechanism = mechanism } }++        Just theta -> do -- Specified context+            return $ GivenTheta $ DS+                   { ds_loc = loc+                   , ds_name = dfun_name, ds_tvs = tvs+                   , ds_cls = cls, ds_tys = inst_tys+                   , ds_tc = rep_tc+                   , ds_theta = theta+                   , ds_overlap = overlap_mode+                   , ds_mechanism = mechanism }+  where+    inst_ty  = mkTyConApp tycon tc_args+    inst_tys = cls_tys ++ [inst_ty]++mk_eqn_stock :: DynFlags -> DerivContext -> Class -> [Type] -> TyCon+             -> (DerivSpecMechanism -> TcRn EarlyDerivSpec)+             -> (SDoc -> TcRn EarlyDerivSpec)+             -> TcRn EarlyDerivSpec+mk_eqn_stock dflags mtheta cls cls_tys rep_tc go_for_it bale_out+  = case checkSideConditions dflags mtheta cls cls_tys rep_tc of+        CanDerive               -> mk_eqn_stock' cls go_for_it+        DerivableClassError msg -> bale_out msg+        _                       -> bale_out (nonStdErr cls)++mk_eqn_stock' :: Class -> (DerivSpecMechanism -> TcRn EarlyDerivSpec)+                -> TcRn EarlyDerivSpec+mk_eqn_stock' cls go_for_it+  = go_for_it $ case hasStockDeriving cls of+        Just gen_fn -> DerivSpecStock gen_fn+        Nothing ->+          pprPanic "mk_eqn_stock': Not a stock class!" (ppr cls)++mk_eqn_anyclass :: DynFlags+                -> (DerivSpecMechanism -> TcRn EarlyDerivSpec)+                -> (SDoc -> TcRn EarlyDerivSpec)+                -> TcRn EarlyDerivSpec+mk_eqn_anyclass dflags go_for_it bale_out+  = case canDeriveAnyClass dflags of+        IsValid      -> go_for_it DerivSpecAnyClass+        NotValid msg -> bale_out msg++mk_eqn_no_mechanism :: DynFlags -> TyCon -> DerivContext+                    -> Class -> [Type] -> TyCon+                    -> (DerivSpecMechanism -> TcRn EarlyDerivSpec)+                    -> (SDoc -> TcRn EarlyDerivSpec)+                    -> TcRn EarlyDerivSpec+mk_eqn_no_mechanism dflags tc mtheta cls cls_tys rep_tc go_for_it bale_out+  = case checkSideConditions dflags mtheta cls cls_tys rep_tc of+        -- NB: pass the *representation* tycon to checkSideConditions+        NonDerivableClass   msg -> bale_out (dac_error msg)+        DerivableClassError msg -> bale_out msg+        CanDerive               -> mk_eqn_stock' cls go_for_it+        DerivableViaInstance    -> go_for_it DerivSpecAnyClass+  where+    -- See Note [Deriving instances for classes themselves]+    dac_error msg+      | isClassTyCon rep_tc+      = quotes (ppr tc) <+> text "is a type class,"+                        <+> text "and can only have a derived instance"+                        $+$ text "if DeriveAnyClass is enabled"+      | otherwise+      = nonStdErr cls $$ msg++{-+************************************************************************+*                                                                      *+                Deriving newtypes+*                                                                      *+************************************************************************+-}++mkNewTypeEqn :: DynFlags -> Maybe OverlapMode -> [TyVar] -> Class+             -> [Type] -> TyCon -> [Type] -> TyCon -> [Type]+             -> DerivContext -> Maybe DerivStrategy+             -> TcRn EarlyDerivSpec+mkNewTypeEqn dflags overlap_mode tvs+             cls cls_tys tycon tc_args rep_tycon rep_tc_args+             mtheta deriv_strat+-- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...+  = ASSERT( length cls_tys + 1 == classArity cls )+    case deriv_strat of+      Just StockStrategy    -> mk_eqn_stock dflags mtheta cls cls_tys rep_tycon+                                 go_for_it_other bale_out+      Just AnyclassStrategy -> mk_eqn_anyclass dflags go_for_it_other bale_out+      Just NewtypeStrategy  ->+        -- Since the user explicitly asked for GeneralizedNewtypeDeriving, we+        -- don't need to perform all of the checks we normally would, such as+        -- if the class being derived is known to produce ill-roled coercions+        -- (e.g., Traversable), since we can just derive the instance and let+        -- it error if need be.+        -- See Note [Determining whether newtype-deriving is appropriate]+        if coercion_looks_sensible && newtype_deriving+          then go_for_it_gnd+          else bale_out (cant_derive_err $$+                         if newtype_deriving then empty else suggest_gnd)+      Nothing+        | might_derive_via_coercible+          && ((newtype_deriving && not deriveAnyClass)+               || std_class_via_coercible cls)+       -> go_for_it_gnd+        | otherwise+       -> case checkSideConditions dflags mtheta cls cls_tys rep_tycon of+            DerivableClassError msg+              -- There's a particular corner case where+              --+              -- 1. -XGeneralizedNewtypeDeriving and -XDeriveAnyClass are both+              --    enabled at the same time+              -- 2. We're deriving a particular stock derivable class+              --    (such as Functor)+              --+              -- and the previous cases won't catch it. This fixes the bug+              -- reported in Trac #10598.+              | might_derive_via_coercible && newtype_deriving+             -> go_for_it_gnd+              -- Otherwise, throw an error for a stock class+              | might_derive_via_coercible && not newtype_deriving+             -> bale_out (msg $$ suggest_gnd)+              | otherwise+             -> bale_out msg++            -- Must use newtype deriving or DeriveAnyClass+            NonDerivableClass _msg+              -- Too hard, even with newtype deriving+              | newtype_deriving           -> bale_out cant_derive_err+              -- Try newtype deriving!+              -- Here we suggest GeneralizedNewtypeDeriving even in cases where+              -- it may not be applicable. See Trac #9600.+              | otherwise                  -> bale_out (non_std $$ suggest_gnd)++            -- DerivableViaInstance+            DerivableViaInstance -> do+              -- If both DeriveAnyClass and GeneralizedNewtypeDeriving are+              -- enabled, we take the diplomatic approach of defaulting to+              -- DeriveAnyClass, but emitting a warning about the choice.+              -- See Note [Deriving strategies]+              when (newtype_deriving && deriveAnyClass) $+                addWarnTc NoReason $ sep+                  [ text "Both DeriveAnyClass and"+                    <+> text "GeneralizedNewtypeDeriving are enabled"+                  , text "Defaulting to the DeriveAnyClass strategy"+                    <+> text "for instantiating" <+> ppr cls ]+              go_for_it_other DerivSpecAnyClass+            -- CanDerive+            CanDerive -> mk_eqn_stock' cls go_for_it_other+  where+        newtype_deriving  = xopt LangExt.GeneralizedNewtypeDeriving dflags+        deriveAnyClass    = xopt LangExt.DeriveAnyClass             dflags+        go_for_it_gnd     = do+          traceTc "newtype deriving:" $+            ppr tycon <+> ppr rep_tys <+> ppr all_thetas+          let mechanism = DerivSpecNewtype rep_inst_ty+          doDerivInstErrorChecks1 cls cls_tys tycon tc_args rep_tycon mtheta+                                  strat_used mechanism+          dfun_name <- newDFunName' cls tycon+          loc <- getSrcSpanM+          case mtheta of+           Just theta -> return $ GivenTheta $ DS+               { ds_loc = loc+               , ds_name = dfun_name, ds_tvs = tvs+               , ds_cls = cls, ds_tys = inst_tys+               , ds_tc = rep_tycon+               , ds_theta = theta+               , ds_overlap = overlap_mode+               , ds_mechanism = mechanism }+           Nothing -> return $ InferTheta $ DS+               { ds_loc = loc+               , ds_name = dfun_name, ds_tvs = tvs+               , ds_cls = cls, ds_tys = inst_tys+               , ds_tc = rep_tycon+               , ds_theta = all_thetas+               , ds_overlap = overlap_mode+               , ds_mechanism = mechanism }+        go_for_it_other = mk_data_eqn overlap_mode tvs cls cls_tys tycon+                            tc_args rep_tycon rep_tc_args mtheta strat_used+        bale_out    = bale_out' newtype_deriving+        bale_out' b = failWithTc . derivingThingErr b cls cls_tys inst_ty+                                                    deriv_strat++        strat_used  = isJust deriv_strat+        non_std     = nonStdErr cls+        suggest_gnd = text "Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension"++        -- Here is the plan for newtype derivings.  We see+        --        newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)+        -- where t is a type,+        --       ak+1...an is a suffix of a1..an, and are all tyvars+        --       ak+1...an do not occur free in t, nor in the s1..sm+        --       (C s1 ... sm) is a  *partial applications* of class C+        --                      with the last parameter missing+        --       (T a1 .. ak) matches the kind of C's last argument+        --              (and hence so does t)+        -- The latter kind-check has been done by deriveTyData already,+        -- and tc_args are already trimmed+        --+        -- We generate the instance+        --       instance forall ({a1..ak} u fvs(s1..sm)).+        --                C s1 .. sm t => C s1 .. sm (T a1...ak)+        -- where T a1...ap is the partial application of+        --       the LHS of the correct kind and p >= k+        --+        --      NB: the variables below are:+        --              tc_tvs = [a1, ..., an]+        --              tyvars_to_keep = [a1, ..., ak]+        --              rep_ty = t ak .. an+        --              deriv_tvs = fvs(s1..sm) \ tc_tvs+        --              tys = [s1, ..., sm]+        --              rep_fn' = t+        --+        -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )+        -- We generate the instance+        --      instance Monad (ST s) => Monad (T s) where++        nt_eta_arity = newTyConEtadArity rep_tycon+                -- For newtype T a b = MkT (S a a b), the TyCon machinery already+                -- eta-reduces the representation type, so we know that+                --      T a ~ S a a+                -- That's convenient here, because we may have to apply+                -- it to fewer than its original complement of arguments++        -- Note [Newtype representation]+        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+        -- Need newTyConRhs (*not* a recursive representation finder)+        -- to get the representation type. For example+        --      newtype B = MkB Int+        --      newtype A = MkA B deriving( Num )+        -- We want the Num instance of B, *not* the Num instance of Int,+        -- when making the Num instance of A!+        rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args+        rep_tys     = cls_tys ++ [rep_inst_ty]+        rep_pred    = mkClassPred cls rep_tys+        rep_pred_o  = mkPredOrigin DerivOrigin TypeLevel rep_pred+                -- rep_pred is the representation dictionary, from where+                -- we are gong to get all the methods for the newtype+                -- dictionary++        -- Next we figure out what superclass dictionaries to use+        -- See Note [Newtype deriving superclasses] above+        sc_preds   :: [PredOrigin]+        cls_tyvars = classTyVars cls+        inst_ty    = mkTyConApp tycon tc_args+        inst_tys   = cls_tys ++ [inst_ty]+        sc_preds   = map (mkPredOrigin DerivOrigin TypeLevel) $+                     substTheta (zipTvSubst cls_tyvars inst_tys) $+                     classSCTheta cls++        -- Next we collect constraints for the class methods+        -- If there are no methods, we don't need any constraints+        -- Otherwise we need (C rep_ty), for the representation methods,+        -- and constraints to coerce each individual method+        meth_preds :: [PredOrigin]+        meths = classMethods cls+        meth_preds | null meths = [] -- No methods => no constraints+                                     -- (Trac #12814)+                   | otherwise = rep_pred_o : coercible_constraints+        coercible_constraints+          = [ mkPredOrigin (DerivOriginCoerce meth t1 t2) TypeLevel+                           (mkReprPrimEqPred t1 t2)+            | meth <- meths+            , let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs+                                         inst_tys rep_inst_ty meth ]++        all_thetas :: [ThetaOrigin]+        all_thetas = [mkThetaOriginFromPreds $ meth_preds ++ sc_preds]++        -------------------------------------------------------------------+        --  Figuring out whether we can only do this newtype-deriving thing++        -- See Note [Determining whether newtype-deriving is appropriate]+        might_derive_via_coercible+           =  not (non_coercible_class cls)+           && coercion_looks_sensible+--         && not (isRecursiveTyCon tycon)      -- Note [Recursive newtypes]+        coercion_looks_sensible+           =  eta_ok+              -- Check (a) from Note [GND and associated type families]+           && ats_ok+              -- Check (b) from Note [GND and associated type families]+           && isNothing at_without_last_cls_tv++        -- Check that eta reduction is OK+        eta_ok = nt_eta_arity <= length rep_tc_args+                -- The newtype can be eta-reduced to match the number+                --     of type argument actually supplied+                --        newtype T a b = MkT (S [a] b) deriving( Monad )+                --     Here the 'b' must be the same in the rep type (S [a] b)+                --     And the [a] must not mention 'b'.  That's all handled+                --     by nt_eta_rity.++        (adf_tcs, atf_tcs) = partition isDataFamilyTyCon at_tcs+        ats_ok             = null adf_tcs+               -- We cannot newtype-derive data family instances++        at_without_last_cls_tv+          = find (\tc -> last_cls_tv `notElem` tyConTyVars tc) atf_tcs+        at_tcs = classATs cls+        last_cls_tv = ASSERT( notNull cls_tyvars )+                      last cls_tyvars++        cant_derive_err+           = vcat [ ppUnless eta_ok eta_msg+                  , ppUnless ats_ok ats_msg+                  , maybe empty at_tv_msg+                          at_without_last_cls_tv]+        eta_msg   = text "cannot eta-reduce the representation type enough"+        ats_msg   = text "the class has associated data types"+        at_tv_msg at_tc = hang+          (text "the associated type" <+> quotes (ppr at_tc)+           <+> text "is not parameterized over the last type variable")+          2 (text "of the class" <+> quotes (ppr cls))++{-+Note [Recursive newtypes]+~~~~~~~~~~~~~~~~~~~~~~~~~+Newtype deriving works fine, even if the newtype is recursive.+e.g.    newtype S1 = S1 [T1 ()]+        newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )+Remember, too, that type families are currently (conservatively) given+a recursive flag, so this also allows newtype deriving to work+for type famillies.++We used to exclude recursive types, because we had a rather simple+minded way of generating the instance decl:+   newtype A = MkA [A]+   instance Eq [A] => Eq A      -- Makes typechecker loop!+But now we require a simple context, so it's ok.++Note [Determining whether newtype-deriving is appropriate]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we see+  newtype NT = MkNT Foo+    deriving C+we have to decide how to perform the deriving. Do we do newtype deriving,+or do we do normal deriving? In general, we prefer to do newtype deriving+wherever possible. So, we try newtype deriving unless there's a glaring+reason not to.++"Glaring reasons not to" include trying to derive a class for which a+coercion-based instance doesn't make sense. These classes are listed in+the definition of non_coercible_class. They include Show (since it must+show the name of the datatype) and Traversable (since a coercion-based+Traversable instance is ill-roled).++However, non_coercible_class is ignored if the user explicitly requests+to derive an instance with GeneralizedNewtypeDeriving using the newtype+deriving strategy. In such a scenario, GHC will unquestioningly try to+derive the instance via coercions (even if the final generated code is+ill-roled!). See Note [Deriving strategies].++Note that newtype deriving might fail, even after we commit to it. This+is because the derived instance uses `coerce`, which must satisfy its+`Coercible` constraint. This is different than other deriving scenarios,+where we're sure that the resulting instance will type-check.++Note [GND and associated type families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's possible to use GeneralizedNewtypeDeriving (GND) to derive instances for+classes with associated type families. A general recipe is:++    class C x y z where+      type T y z x+      op :: x -> [y] -> z++    newtype N a = MkN <rep-type> deriving( C )++    =====>++    instance C x y <rep-type> => C x y (N a) where+      type T y (N a) x = T y <rep-type> x+      op = coerce (op :: x -> [y] -> <rep-type>)++However, we must watch out for three things:++(a) The class must not contain any data families. If it did, we'd have to+    generate a fresh data constructor name for the derived data family+    instance, and it's not clear how to do this.++(b) Each associated type family's type variables must mention the last type+    variable of the class. As an example, you wouldn't be able to use GND to+    derive an instance of this class:++      class C a b where+        type T a++    But you would be able to derive an instance of this class:++      class C a b where+        type T b++    The difference is that in the latter T mentions the last parameter of C+    (i.e., it mentions b), but the former T does not. If you tried, e.g.,++      newtype Foo x = Foo x deriving (C a)++    with the former definition of C, you'd end up with something like this:++      instance C a (Foo x) where+        type T a = T ???++    This T family instance doesn't mention the newtype (or its representation+    type) at all, so we disallow such constructions with GND.++(c) UndecidableInstances might need to be enabled. Here's a case where it is+    most definitely necessary:++      class C a where+        type T a+      newtype Loop = Loop MkLoop deriving C++      =====>++      instance C Loop where+        type T Loop = T Loop++    Obviously, T Loop would send the typechecker into a loop. Unfortunately,+    you might even need UndecidableInstances even in cases where the+    typechecker would be guaranteed to terminate. For example:++      instance C Int where+        type C Int = Int+      newtype MyInt = MyInt Int deriving C++      =====>++      instance C MyInt where+        type T MyInt = T Int++    GHC's termination checker isn't sophisticated enough to conclude that the+    definition of T MyInt terminates, so UndecidableInstances is required.++************************************************************************+*                                                                      *+\subsection[TcDeriv-normal-binds]{Bindings for the various classes}+*                                                                      *+************************************************************************++After all the trouble to figure out the required context for the+derived instance declarations, all that's left is to chug along to+produce them.  They will then be shoved into @tcInstDecls2@, which+will do all its usual business.++There are lots of possibilities for code to generate.  Here are+various general remarks.++PRINCIPLES:+\begin{itemize}+\item+We want derived instances of @Eq@ and @Ord@ (both v common) to be+``you-couldn't-do-better-by-hand'' efficient.++\item+Deriving @Show@---also pretty common--- should also be reasonable good code.++\item+Deriving for the other classes isn't that common or that big a deal.+\end{itemize}++PRAGMATICS:++\begin{itemize}+\item+Deriving @Ord@ is done mostly with the 1.3 @compare@ method.++\item+Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.++\item+We {\em normally} generate code only for the non-defaulted methods;+there are some exceptions for @Eq@ and (especially) @Ord@...++\item+Sometimes we use a @_con2tag_<tycon>@ function, which returns a data+constructor's numeric (@Int#@) tag.  These are generated by+@gen_tag_n_con_binds@, and the heuristic for deciding if one of+these is around is given by @hasCon2TagFun@.++The examples under the different sections below will make this+clearer.++\item+Much less often (really just for deriving @Ix@), we use a+@_tag2con_<tycon>@ function.  See the examples.++\item+We use the renamer!!!  Reason: we're supposed to be+producing @LHsBinds Name@ for the methods, but that means+producing correctly-uniquified code on the fly.  This is entirely+possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.+So, instead, we produce @MonoBinds RdrName@ then heave 'em through+the renamer.  What a great hack!+\end{itemize}+-}++-- Generate the InstInfo for the required instance paired with the+--   *representation* tycon for that instance,+-- plus any auxiliary bindings required+--+-- Representation tycons differ from the tycon in the instance signature in+-- case of instances for indexed families.+--+genInst :: DerivSpec theta+        -> TcM (ThetaType -> TcM (InstInfo RdrName), BagDerivStuff, Maybe Name)+-- We must use continuation-returning style here to get the order in which we+-- typecheck family instances and derived instances right.+-- See Note [Staging of tcDeriving]+genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon+                 , ds_mechanism = mechanism, ds_tys = tys+                 , ds_cls = clas, ds_loc = loc })+  = do (meth_binds, deriv_stuff) <- genDerivStuff mechanism loc clas+                                      rep_tycon tys tvs+       let mk_inst_info theta = do+             inst_spec <- newDerivClsInst theta spec+             doDerivInstErrorChecks2 clas inst_spec mechanism+             traceTc "newder" (ppr inst_spec)+             return $ InstInfo+                       { iSpec   = inst_spec+                       , iBinds  = InstBindings+                                     { ib_binds = meth_binds+                                     , ib_tyvars = map Var.varName tvs+                                     , ib_pragmas = []+                                     , ib_extensions = extensions+                                     , ib_derived = True } }+       return (mk_inst_info, deriv_stuff, unusedConName)+  where+    unusedConName :: Maybe Name+    unusedConName+      | isDerivSpecNewtype mechanism+        -- See Note [Newtype deriving and unused constructors]+      = Just $ getName $ head $ tyConDataCons rep_tycon+      | otherwise+      = Nothing++    extensions :: [LangExt.Extension]+    extensions+      | isDerivSpecNewtype mechanism+        -- Both these flags are needed for higher-rank uses of coerce+        -- See Note [Newtype-deriving instances] in TcGenDeriv+      = [LangExt.ImpredicativeTypes, LangExt.RankNTypes]+      | otherwise+      = []++doDerivInstErrorChecks1 :: Class -> [Type] -> TyCon -> [Type] -> TyCon+                        -> DerivContext -> Bool -> DerivSpecMechanism+                        -> TcM ()+doDerivInstErrorChecks1 cls cls_tys tc tc_args rep_tc mtheta+                        strat_used mechanism = do+    -- For standalone deriving (mtheta /= Nothing),+    -- check that all the data constructors are in scope...+    rdr_env <- getGlobalRdrEnv+    let data_con_names = map dataConName (tyConDataCons rep_tc)+        hidden_data_cons = not (isWiredInName (tyConName rep_tc)) &&+                           (isAbstractTyCon rep_tc ||+                            any not_in_scope data_con_names)+        not_in_scope dc  = isNothing (lookupGRE_Name rdr_env dc)++    addUsedDataCons rdr_env rep_tc+    -- ...however, we don't perform this check if we're using DeriveAnyClass,+    -- since it doesn't generate any code that requires use of a data+    -- constructor.+    unless (anyclass_strategy || isNothing mtheta || not hidden_data_cons) $+           bale_out $ derivingHiddenErr tc+  where+    anyclass_strategy = isDerivSpecAnyClass mechanism++    bale_out msg = failWithTc (derivingThingErrMechanism cls cls_tys+                     (mkTyConApp tc tc_args) strat_used mechanism msg)++doDerivInstErrorChecks2 :: Class -> ClsInst -> DerivSpecMechanism -> TcM ()+doDerivInstErrorChecks2 clas clas_inst mechanism+  = do { traceTc "doDerivInstErrorChecks2" (ppr clas_inst)+       ; dflags <- getDynFlags+         -- Check for Generic instances that are derived with an exotic+         -- deriving strategy like DAC+         -- See Note [Deriving strategies]+       ; when (exotic_mechanism && className clas `elem` genericClassNames) $+         do { failIfTc (safeLanguageOn dflags) gen_inst_err+            ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } }+  where+    exotic_mechanism = case mechanism of+      DerivSpecStock{} -> False+      _                -> True++    gen_inst_err = hang (text ("Generic instances can only be derived in "+                            ++ "Safe Haskell using the stock strategy.") $+$+                         text "In the following instance:")+                      2 (pprInstanceHdr clas_inst)++genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class+              -> TyCon -> [Type] -> [TyVar]+              -> TcM (LHsBinds RdrName, BagDerivStuff)+genDerivStuff mechanism loc clas tycon inst_tys tyvars+  = case mechanism of+      -- See Note [Bindings for Generalised Newtype Deriving]+      DerivSpecNewtype rhs_ty -> gen_Newtype_binds loc clas tyvars+                                                   inst_tys rhs_ty++      -- Try a stock deriver+      DerivSpecStock gen_fn -> gen_fn loc tycon inst_tys++      -- If there isn't a stock deriver, our last resort is -XDeriveAnyClass+      -- (since -XGeneralizedNewtypeDeriving fell through).+      DerivSpecAnyClass -> do+        let mini_env   = mkVarEnv (classTyVars clas `zip` inst_tys)+            mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env+        dflags <- getDynFlags+        tyfam_insts <-+          -- canDeriveAnyClass should ensure that this code can't be reached+          -- unless -XDeriveAnyClass is enabled.+          ASSERT2( isValid (canDeriveAnyClass dflags)+                 , ppr "genDerivStuff: bad derived class" <+> ppr clas )+          mapM (tcATDefault False loc mini_subst emptyNameSet)+               (classATItems clas)+        return ( emptyBag -- No method bindings are needed...+               , listToBag (map DerivFamInst (concat tyfam_insts))+               -- ...but we may need to generate binding for associated type+               -- family default instances.+               -- See Note [DeriveAnyClass and default family instances]+               )++{-+Note [Bindings for Generalised Newtype Deriving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  class Eq a => C a where+     f :: a -> a+  newtype N a = MkN [a] deriving( C )+  instance Eq (N a) where ...++The 'deriving C' clause generates, in effect+  instance (C [a], Eq a) => C (N a) where+     f = coerce (f :: [a] -> [a])++This generates a cast for each method, but allows the superclasse to+be worked out in the usual way.  In this case the superclass (Eq (N+a)) will be solved by the explicit Eq (N a) instance.  We do *not*+create the superclasses by casting the superclass dictionaries for the+representation type.++See the paper "Safe zero-cost coercions for Haskell".++Note [DeriveAnyClass and default family instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When a class has a associated type family with a default instance, e.g.:++  class C a where+    type T a+    type T a = Char++then there are a couple of scenarios in which a user would expect T a to+default to Char. One is when an instance declaration for C is given without+an implementation for T:++  instance C Int++Another scenario in which this can occur is when the -XDeriveAnyClass extension+is used:++  data Example = Example deriving (C, Generic)++In the latter case, we must take care to check if C has any associated type+families with default instances, because -XDeriveAnyClass will never provide+an implementation for them. We "fill in" the default instances using the+tcATDefault function from TcClsDcl (which is also used in TcInstDcls to handle+the empty instance declaration case).++Note [Deriving strategies]+~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC has a notion of deriving strategies, which allow the user to explicitly+request which approach to use when deriving an instance (enabled with the+-XDerivingStrategies language extension). For more information, refer to the+original Trac ticket (#10598) or the associated wiki page:+https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DerivingStrategies++A deriving strategy can be specified in a deriving clause:++    newtype Foo = MkFoo Bar+      deriving newtype C++Or in a standalone deriving declaration:++    deriving anyclass instance C Foo++-XDerivingStrategies also allows the use of multiple deriving clauses per data+declaration so that a user can derive some instance with one deriving strategy+and other instances with another deriving strategy. For example:++    newtype Baz = Baz Quux+      deriving          (Eq, Ord)+      deriving stock    (Read, Show)+      deriving newtype  (Num, Floating)+      deriving anyclass C++Currently, the deriving strategies are:++* stock: Have GHC implement a "standard" instance for a data type, if possible+  (e.g., Eq, Ord, Generic, Data, Functor, etc.)++* anyclass: Use -XDeriveAnyClass++* newtype: Use -XGeneralizedNewtypeDeriving++If an explicit deriving strategy is not given, GHC has an algorithm it uses to+determine which strategy it will actually use. The algorithm is quite long,+so it lives in the Haskell wiki at+https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DerivingStrategies+("The deriving strategy resolution algorithm" section).++Internally, GHC uses the DerivStrategy datatype to denote a user-requested+deriving strategy, and it uses the DerivSpecMechanism datatype to denote what+GHC will use to derive the instance after taking the above steps. In other+words, GHC will always settle on a DerivSpecMechnism, even if the user did not+ask for a particular DerivStrategy (using the algorithm linked to above).++Note [Deriving instances for classes themselves]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Much of the code in TcDeriv assumes that deriving only works on data types.+But this assumption doesn't hold true for DeriveAnyClass, since it's perfectly+reasonable to do something like this:++  {-# LANGUAGE DeriveAnyClass #-}+  class C1 (a :: Constraint) where+  class C2 where+  deriving instance C1 C2+    -- This is equivalent to `instance C1 C2`++If DeriveAnyClass isn't enabled in the code above (i.e., it defaults to stock+deriving), we throw a special error message indicating that DeriveAnyClass is+the only way to go. We don't bother throwing this error if an explicit 'stock'+or 'newtype' keyword is used, since both options have their own perfectly+sensible error messages in the case of the above code (as C1 isn't a stock+derivable class, and C2 isn't a newtype).++************************************************************************+*                                                                      *+\subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}+*                                                                      *+************************************************************************+-}++nonUnaryErr :: LHsSigType Name -> SDoc+nonUnaryErr ct = quotes (ppr ct)+  <+> text "is not a unary constraint, as expected by a deriving clause"++nonStdErr :: Class -> SDoc+nonStdErr cls =+      quotes (ppr cls)+  <+> text "is not a stock derivable class (Eq, Show, etc.)"++gndNonNewtypeErr :: SDoc+gndNonNewtypeErr =+  text "GeneralizedNewtypeDeriving cannot be used on non-newtypes"++derivingNullaryErr :: MsgDoc+derivingNullaryErr = text "Cannot derive instances for nullary classes"++derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> MsgDoc+derivingKindErr tc cls cls_tys cls_kind enough_args+  = sep [ hang (text "Cannot derive well-kinded instance of form"+                      <+> quotes (pprClassPred cls cls_tys+                                    <+> parens (ppr tc <+> text "...")))+               2 gen1_suggestion+        , nest 2 (text "Class" <+> quotes (ppr cls)+                      <+> text "expects an argument of kind"+                      <+> quotes (pprKind cls_kind))+        ]+  where+    gen1_suggestion | cls `hasKey` gen1ClassKey && enough_args+                    = text "(Perhaps you intended to use PolyKinds)"+                    | otherwise = Outputable.empty++derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc+derivingEtaErr cls cls_tys inst_ty+  = sep [text "Cannot eta-reduce to an instance of form",+         nest 2 (text "instance (...) =>"+                <+> pprClassPred cls (cls_tys ++ [inst_ty]))]++derivingThingErr :: Bool -> Class -> [Type] -> Type -> Maybe DerivStrategy+                 -> MsgDoc -> MsgDoc+derivingThingErr newtype_deriving clas tys ty deriv_strat why+  = derivingThingErr' newtype_deriving clas tys ty (isJust deriv_strat)+                      (maybe empty ppr deriv_strat) why++derivingThingErrMechanism :: Class -> [Type] -> Type+                          -> Bool -- True if an explicit deriving strategy+                                  -- keyword was provided+                          -> DerivSpecMechanism+                          -> MsgDoc -> MsgDoc+derivingThingErrMechanism clas tys ty strat_used mechanism why+  = derivingThingErr' (isDerivSpecNewtype mechanism) clas tys ty strat_used+                      (ppr mechanism) why++derivingThingErr' :: Bool -> Class -> [Type] -> Type -> Bool -> MsgDoc+                  -> MsgDoc -> MsgDoc+derivingThingErr' newtype_deriving clas tys ty strat_used strat_msg why+  = sep [(hang (text "Can't make a derived instance of")+             2 (quotes (ppr pred) <+> via_mechanism)+          $$ nest 2 extra) <> colon,+         nest 2 why]+  where+    extra | not strat_used, newtype_deriving+          = text "(even with cunning GeneralizedNewtypeDeriving)"+          | otherwise = empty+    pred = mkClassPred clas (tys ++ [ty])+    via_mechanism | strat_used+                  = text "with the" <+> strat_msg <+> text "strategy"+                  | otherwise+                  = empty++derivingHiddenErr :: TyCon -> SDoc+derivingHiddenErr tc+  = hang (text "The data constructors of" <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope"))+       2 (text "so you cannot derive an instance for it")++standaloneCtxt :: LHsSigType Name -> SDoc+standaloneCtxt ty = hang (text "In the stand-alone deriving instance for")+                       2 (quotes (ppr ty))++unboxedTyConErr :: String -> MsgDoc+unboxedTyConErr thing =+  text "The last argument of the instance cannot be an unboxed" <+> text thing
+ typecheck/TcDerivInfer.hs view
@@ -0,0 +1,876 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Functions for inferring (and simplifying) the context for derived instances.+-}++{-# LANGUAGE CPP #-}++module TcDerivInfer (inferConstraints, simplifyInstanceContexts) where++#include "HsVersions.h"++import Bag+import BasicTypes+import Class+import DataCon+-- import DynFlags+import ErrUtils+import Inst+import Outputable+import PrelNames+import TcDerivUtils+import TcEnv+-- import TcErrors (reportAllUnsolved)+import TcGenFunctor+import TcGenGenerics+import TcMType+import TcRnMonad+import TcType+import TyCon+import Type+import TcSimplify+import TcValidity (validDerivPred)+import TcUnify (buildImplicationFor)+import Unify (tcUnifyTy)+import Util+import Var+import VarEnv+import VarSet++import Control.Monad+import Data.List+import Data.Maybe++----------------------++inferConstraints :: [TyVar] -> Class -> [TcType] -> TcType+                 -> TyCon -> [TcType] -> DerivSpecMechanism+                 -> TcM ([ThetaOrigin], [TyVar], [TcType])+-- inferConstraints figures out the constraints needed for the+-- instance declaration generated by a 'deriving' clause on a+-- data type declaration. It also returns the new in-scope type+-- variables and instance types, in case they were changed due to+-- the presence of functor-like constraints.+-- See Note [Inferring the instance context]++-- e.g. inferConstraints+--        C Int (T [a])    -- Class and inst_tys+--        :RTList a        -- Rep tycon and its arg tys+-- where T [a] ~R :RTList a+--+-- Generate a sufficiently large set of constraints that typechecking the+-- generated method definitions should succeed.   This set will be simplified+-- before being used in the instance declaration+inferConstraints tvs main_cls cls_tys inst_ty+                 rep_tc rep_tc_args+                 mechanism+  | is_generic && not is_anyclass     -- Generic constraints are easy+  = return ([], tvs, inst_tys)++  | is_generic1 && not is_anyclass    -- Generic1 needs Functor+  = ASSERT( length rep_tc_tvs > 0 )   -- See Note [Getting base classes]+    ASSERT( length cls_tys   == 1 )   -- Generic1 has a single kind variable+    do { functorClass <- tcLookupClass functorClassName+       ; con_arg_constraints (get_gen1_constraints functorClass) }++  | otherwise  -- The others are a bit more complicated+  = -- See the comment with all_rep_tc_args for an explanation of+    -- this assertion+    ASSERT2( equalLength rep_tc_tvs all_rep_tc_args+           , ppr main_cls <+> ppr rep_tc+             $$ ppr rep_tc_tvs $$ ppr all_rep_tc_args )+      do { (arg_constraints, tvs', inst_tys') <- infer_constraints+         ; traceTc "inferConstraints" $ vcat+                [ ppr main_cls <+> ppr inst_tys'+                , ppr arg_constraints+                ]+         ; return (stupid_constraints ++ extra_constraints+                    ++ sc_constraints ++ arg_constraints+                  , tvs', inst_tys') }+  where+    is_anyclass = isDerivSpecAnyClass mechanism+    infer_constraints+      | is_anyclass = inferConstraintsDAC main_cls tvs inst_tys+      | otherwise   = con_arg_constraints get_std_constrained_tys++    tc_binders = tyConBinders rep_tc+    choose_level bndr+      | isNamedTyConBinder bndr = KindLevel+      | otherwise               = TypeLevel+    t_or_ks = map choose_level tc_binders ++ repeat TypeLevel+       -- want to report *kind* errors when possible++       -- Constraints arising from the arguments of each constructor+    con_arg_constraints :: (CtOrigin -> TypeOrKind+                                     -> Type+                                     -> [([PredOrigin], Maybe TCvSubst)])+                        -> TcM ([ThetaOrigin], [TyVar], [TcType])+    con_arg_constraints get_arg_constraints+      = let (predss, mbSubsts) = unzip+              [ preds_and_mbSubst+              | data_con <- tyConDataCons rep_tc+              , (arg_n, arg_t_or_k, arg_ty)+                  <- zip3 [1..] t_or_ks $+                     dataConInstOrigArgTys data_con all_rep_tc_args+                -- No constraints for unlifted types+                -- See Note [Deriving and unboxed types]+              , not (isUnliftedType arg_ty)+              , let orig = DerivOriginDC data_con arg_n+              , preds_and_mbSubst <- get_arg_constraints orig arg_t_or_k arg_ty+              ]+            preds = concat predss+            -- If the constraints require a subtype to be of kind (* -> *)+            -- (which is the case for functor-like constraints), then we+            -- explicitly unify the subtype's kinds with (* -> *).+            -- See Note [Inferring the instance context]+            subst        = foldl' composeTCvSubst+                                  emptyTCvSubst (catMaybes mbSubsts)+            unmapped_tvs = filter (\v -> v `notElemTCvSubst` subst+                                      && not (v `isInScope` subst)) tvs+            (subst', _)  = mapAccumL substTyVarBndr subst unmapped_tvs+            preds'       = map (substPredOrigin subst') preds+            inst_tys'    = substTys subst' inst_tys+            tvs'         = tyCoVarsOfTypesWellScoped inst_tys'+        in return ([mkThetaOriginFromPreds preds'], tvs', inst_tys')++    is_generic  = main_cls `hasKey` genClassKey+    is_generic1 = main_cls `hasKey` gen1ClassKey+    -- is_functor_like: see Note [Inferring the instance context]+    is_functor_like = typeKind inst_ty `tcEqKind` typeToTypeKind+                   || is_generic1++    get_gen1_constraints :: Class -> CtOrigin -> TypeOrKind -> Type+                         -> [([PredOrigin], Maybe TCvSubst)]+    get_gen1_constraints functor_cls orig t_or_k ty+       = mk_functor_like_constraints orig t_or_k functor_cls $+         get_gen1_constrained_tys last_tv ty++    get_std_constrained_tys :: CtOrigin -> TypeOrKind -> Type+                            -> [([PredOrigin], Maybe TCvSubst)]+    get_std_constrained_tys orig t_or_k ty+        | is_functor_like = mk_functor_like_constraints orig t_or_k main_cls $+                            deepSubtypesContaining last_tv ty+        | otherwise       = [( [mk_cls_pred orig t_or_k main_cls ty]+                             , Nothing )]++    mk_functor_like_constraints :: CtOrigin -> TypeOrKind+                                -> Class -> [Type]+                                -> [([PredOrigin], Maybe TCvSubst)]+    -- 'cls' is usually main_cls (Functor or Traversable etc), but if+    -- main_cls = Generic1, then 'cls' can be Functor; see get_gen1_constraints+    --+    -- For each type, generate two constraints, [cls ty, kind(ty) ~ (*->*)],+    -- and a kind substitution that results from unifying kind(ty) with * -> *.+    -- If the unification is successful, it will ensure that the resulting+    -- instance is well kinded. If not, the second constraint will result+    -- in an error message which points out the kind mismatch.+    -- See Note [Inferring the instance context]+    mk_functor_like_constraints orig t_or_k cls+       = map $ \ty -> let ki = typeKind ty in+                      ( [ mk_cls_pred orig t_or_k cls ty+                        , mkPredOrigin orig KindLevel+                            (mkPrimEqPred ki typeToTypeKind) ]+                      , tcUnifyTy ki typeToTypeKind+                      )++    rep_tc_tvs      = tyConTyVars rep_tc+    last_tv         = last rep_tc_tvs+    -- When we first gather up the constraints to solve, most of them contain+    -- rep_tc_tvs, i.e., the type variables from the derived datatype's type+    -- constructor. We don't want these type variables to appear in the final+    -- instance declaration, so we must substitute each type variable with its+    -- counterpart in the derived instance. rep_tc_args lists each of these+    -- counterpart types in the same order as the type variables.+    all_rep_tc_args = rep_tc_args ++ map mkTyVarTy+                                     (drop (length rep_tc_args) rep_tc_tvs)++        -- Constraints arising from superclasses+        -- See Note [Superclasses of derived instance]+    cls_tvs  = classTyVars main_cls+    inst_tys = cls_tys ++ [inst_ty]+    sc_constraints = ASSERT2( equalLength cls_tvs inst_tys, ppr main_cls <+> ppr rep_tc)+                     [ mkThetaOrigin DerivOrigin TypeLevel [] [] $+                       substTheta cls_subst (classSCTheta main_cls) ]+    cls_subst = ASSERT( equalLength cls_tvs inst_tys )+                zipTvSubst cls_tvs inst_tys++        -- Stupid constraints+    stupid_constraints = [ mkThetaOrigin DerivOrigin TypeLevel [] [] $+                           substTheta tc_subst (tyConStupidTheta rep_tc) ]+    tc_subst = -- See the comment with all_rep_tc_args for an explanation of+               -- this assertion+               ASSERT( equalLength rep_tc_tvs all_rep_tc_args )+               zipTvSubst rep_tc_tvs all_rep_tc_args++        -- Extra Data constraints+        -- The Data class (only) requires that for+        --    instance (...) => Data (T t1 t2)+        -- IF   t1:*, t2:*+        -- THEN (Data t1, Data t2) are among the (...) constraints+        -- Reason: when the IF holds, we generate a method+        --             dataCast2 f = gcast2 f+        --         and we need the Data constraints to typecheck the method+    extra_constraints = [mkThetaOriginFromPreds constrs]+      where+        constrs+          | main_cls `hasKey` dataClassKey+          , all (isLiftedTypeKind . typeKind) rep_tc_args+          = [ mk_cls_pred DerivOrigin t_or_k main_cls ty+            | (t_or_k, ty) <- zip t_or_ks rep_tc_args]+          | otherwise+          = []++    mk_cls_pred orig t_or_k cls ty   -- Don't forget to apply to cls_tys' too+       = mkPredOrigin orig t_or_k (mkClassPred cls (cls_tys' ++ [ty]))+    cls_tys' | is_generic1 = [] -- In the awkward Generic1 case, cls_tys'+                                -- should be empty, since we are applying the+                                -- class Functor.+             | otherwise   = cls_tys++typeToTypeKind :: Kind+typeToTypeKind = liftedTypeKind `mkFunTy` liftedTypeKind++-- | Like 'inferConstraints', but used only in the case of @DeriveAnyClass@,+-- which gathers its constraints based on the type signatures of the class's+-- methods instead of the types of the data constructor's field.+--+-- See Note [Gathering and simplifying constraints for DeriveAnyClass]+-- for an explanation of how these constraints are used to determine the+-- derived instance context.+inferConstraintsDAC :: Class -> [TyVar] -> [TcType]+                    -> TcM ([ThetaOrigin], [TyVar], [TcType])+inferConstraintsDAC cls tvs inst_tys+  = do { let gen_dms = [ (sel_id, dm_ty)+                       | (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ]++       ; theta_origins <- pushTcLevelM_ (mapM do_one_meth gen_dms)+            -- Yuk: the pushTcLevel is to match the one wrapping the call+            --      to mk_wanteds in simplifyDeriv.  If we omit this, the+            --      unification variables will wrongly be untouchable.++       ; return (theta_origins, tvs, inst_tys) }+  where+    cls_tvs = classTyVars cls+    empty_subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet tvs))++    do_one_meth :: (Id, Type) -> TcM ThetaOrigin+      -- (Id,Type) are the selector Id and the generic default method type+      -- NB: the latter is /not/ quantified over the class variables+      -- See Note [Gathering and simplifying constraints for DeriveAnyClass]+    do_one_meth (sel_id, gen_dm_ty)+      = do { let (sel_tvs, _cls_pred, meth_ty) = tcSplitMethodTy (varType sel_id)+                 meth_ty' = substTyWith sel_tvs inst_tys meth_ty+                 (meth_tvs, meth_theta, meth_tau) = tcSplitNestedSigmaTys meth_ty'++                 gen_dm_ty' = substTyWith cls_tvs inst_tys gen_dm_ty+                 (dm_tvs, dm_theta, dm_tau) = tcSplitNestedSigmaTys gen_dm_ty'++           ; (subst, _meta_tvs) <- pushTcLevelM_ $+                                   newMetaTyVarsX empty_subst dm_tvs+                -- Yuk: the pushTcLevel is to match the one in mk_wanteds+                --      simplifyDeriv.  If we don't, the unification variables+                --      will bogusly be untouchable.+           ; let dm_theta' = substTheta subst dm_theta+                 tau_eq    = mkPrimEqPred meth_tau (substTy subst dm_tau)+           ; return (mkThetaOrigin DerivOrigin TypeLevel+                                   meth_tvs meth_theta (tau_eq:dm_theta')) }++{- Note [Inferring the instance context]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are two sorts of 'deriving':++  * InferTheta: the deriving clause for a data type+      data T a = T1 a deriving( Eq )+    Here we must infer an instance context,+    and generate instance declaration+      instance Eq a => Eq (T a) where ...++  * CheckTheta: standalone deriving+      deriving instance Eq a => Eq (T a)+    Here we only need to fill in the bindings;+    the instance context is user-supplied++For a deriving clause (InferTheta) we must figure out the+instance context (inferConstraints). Suppose we are inferring+the instance context for+    C t1 .. tn (T s1 .. sm)+There are two cases++  * (T s1 .. sm) :: *         (the normal case)+    Then we behave like Eq and guess (C t1 .. tn t)+    for each data constructor arg of type t.  More+    details below.++  * (T s1 .. sm) :: * -> *    (the functor-like case)+    Then we behave like Functor.++In both cases we produce a bunch of un-simplified constraints+and them simplify them in simplifyInstanceContexts; see+Note [Simplifying the instance context].++In the functor-like case, we may need to unify some kind variables with * in+order for the generated instance to be well-kinded. An example from+Trac #10524:++  newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1)+    = Compose (f (g a)) deriving Functor++Earlier in the deriving pipeline, GHC unifies the kind of Compose f g+(k1 -> *) with the kind of Functor's argument (* -> *), so k1 := *. But this+alone isn't enough, since k2 wasn't unified with *:++  instance (Functor (f :: k2 -> *), Functor (g :: * -> k2)) =>+    Functor (Compose f g) where ...++The two Functor constraints are ill-kinded. To ensure this doesn't happen, we:++  1. Collect all of a datatype's subtypes which require functor-like+     constraints.+  2. For each subtype, create a substitution by unifying the subtype's kind+     with (* -> *).+  3. Compose all the substitutions into one, then apply that substitution to+     all of the in-scope type variables and the instance types.++Note [Getting base classes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Functor and Typeable are defined in package 'base', and that is not available+when compiling 'ghc-prim'.  So we must be careful that 'deriving' for stuff in+ghc-prim does not use Functor or Typeable implicitly via these lookups.++Note [Deriving and unboxed types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have some special hacks to support things like+   data T = MkT Int# deriving ( Show )++Specifically, we use TcGenDeriv.box to box the Int# into an Int+(which we know how to show), and append a '#'. Parenthesis are not required+for unboxed values (`MkT -3#` is a valid expression).++Note [Superclasses of derived instance]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general, a derived instance decl needs the superclasses of the derived+class too.  So if we have+        data T a = ...deriving( Ord )+then the initial context for Ord (T a) should include Eq (T a).  Often this is+redundant; we'll also generate an Ord constraint for each constructor argument,+and that will probably generate enough constraints to make the Eq (T a) constraint+be satisfied too.  But not always; consider:++ data S a = S+ instance Eq (S a)+ instance Ord (S a)++ data T a = MkT (S a) deriving( Ord )+ instance Num a => Eq (T a)++The derived instance for (Ord (T a)) must have a (Num a) constraint!+Similarly consider:+        data T a = MkT deriving( Data )+Here there *is* no argument field, but we must nevertheless generate+a context for the Data instances:+        instance Typeable a => Data (T a) where ...+++************************************************************************+*                                                                      *+         Finding the fixed point of deriving equations+*                                                                      *+************************************************************************++Note [Simplifying the instance context]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++        data T a b = C1 (Foo a) (Bar b)+                   | C2 Int (T b a)+                   | C3 (T a a)+                   deriving (Eq)++We want to come up with an instance declaration of the form++        instance (Ping a, Pong b, ...) => Eq (T a b) where+                x == y = ...++It is pretty easy, albeit tedious, to fill in the code "...".  The+trick is to figure out what the context for the instance decl is,+namely Ping, Pong and friends.++Let's call the context reqd for the T instance of class C at types+(a,b, ...)  C (T a b).  Thus:++        Eq (T a b) = (Ping a, Pong b, ...)++Now we can get a (recursive) equation from the data decl.  This part+is done by inferConstraints.++        Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1+                   u Eq (T b a) u Eq Int        -- From C2+                   u Eq (T a a)                 -- From C3+++Foo and Bar may have explicit instances for Eq, in which case we can+just substitute for them.  Alternatively, either or both may have+their Eq instances given by deriving clauses, in which case they+form part of the system of equations.++Now all we need do is simplify and solve the equations, iterating to+find the least fixpoint.  This is done by simplifyInstanceConstraints.+Notice that the order of the arguments can+switch around, as here in the recursive calls to T.++Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.++We start with:++        Eq (T a b) = {}         -- The empty set++Next iteration:+        Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1+                   u Eq (T b a) u Eq Int        -- From C2+                   u Eq (T a a)                 -- From C3++        After simplification:+                   = Eq a u Ping b u {} u {} u {}+                   = Eq a u Ping b++Next iteration:++        Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1+                   u Eq (T b a) u Eq Int        -- From C2+                   u Eq (T a a)                 -- From C3++        After simplification:+                   = Eq a u Ping b+                   u (Eq b u Ping a)+                   u (Eq a u Ping a)++                   = Eq a u Ping b u Eq b u Ping a++The next iteration gives the same result, so this is the fixpoint.  We+need to make a canonical form of the RHS to ensure convergence.  We do+this by simplifying the RHS to a form in which++        - the classes constrain only tyvars+        - the list is sorted by tyvar (major key) and then class (minor key)+        - no duplicates, of course++Note [Deterministic simplifyInstanceContexts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Canonicalisation uses nonDetCmpType which is nondeterministic. Sorting+with nonDetCmpType puts the returned lists in a nondeterministic order.+If we were to return them, we'd get class constraints in+nondeterministic order.++Consider:++  data ADT a b = Z a b deriving Eq++The generated code could be either:++  instance (Eq a, Eq b) => Eq (Z a b) where++Or:++  instance (Eq b, Eq a) => Eq (Z a b) where++To prevent the order from being nondeterministic we only+canonicalize when comparing and return them in the same order as+simplifyDeriv returned them.+See also Note [nonDetCmpType nondeterminism]+-}+++simplifyInstanceContexts :: [DerivSpec [ThetaOrigin]]+                         -> TcM [DerivSpec ThetaType]+-- Used only for deriving clauses (InferTheta)+-- not for standalone deriving+-- See Note [Simplifying the instance context]++simplifyInstanceContexts [] = return []++simplifyInstanceContexts infer_specs+  = do  { traceTc "simplifyInstanceContexts" $ vcat (map pprDerivSpec infer_specs)+        ; iterate_deriv 1 initial_solutions }+  where+    ------------------------------------------------------------------+        -- The initial solutions for the equations claim that each+        -- instance has an empty context; this solution is certainly+        -- in canonical form.+    initial_solutions :: [ThetaType]+    initial_solutions = [ [] | _ <- infer_specs ]++    ------------------------------------------------------------------+        -- iterate_deriv calculates the next batch of solutions,+        -- compares it with the current one; finishes if they are the+        -- same, otherwise recurses with the new solutions.+        -- It fails if any iteration fails+    iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec ThetaType]+    iterate_deriv n current_solns+      | n > 20  -- Looks as if we are in an infinite loop+                -- This can happen if we have -XUndecidableInstances+                -- (See TcSimplify.tcSimplifyDeriv.)+      = pprPanic "solveDerivEqns: probable loop"+                 (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns)+      | otherwise+      = do {      -- Extend the inst info from the explicit instance decls+                  -- with the current set of solutions, and simplify each RHS+             inst_specs <- zipWithM newDerivClsInst current_solns infer_specs+           ; new_solns <- checkNoErrs $+                          extendLocalInstEnv inst_specs $+                          mapM gen_soln infer_specs++           ; if (current_solns `eqSolution` new_solns) then+                return [ spec { ds_theta = soln }+                       | (spec, soln) <- zip infer_specs current_solns ]+             else+                iterate_deriv (n+1) new_solns }++    eqSolution a b = eqListBy (eqListBy eqType) (canSolution a) (canSolution b)+       -- Canonicalise for comparison+       -- See Note [Deterministic simplifyInstanceContexts]+    canSolution = map (sortBy nonDetCmpType)+    ------------------------------------------------------------------+    gen_soln :: DerivSpec [ThetaOrigin] -> TcM ThetaType+    gen_soln (DS { ds_loc = loc, ds_tvs = tyvars+                 , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })+      = setSrcSpan loc  $+        addErrCtxt (derivInstCtxt the_pred) $+        do { theta <- simplifyDeriv the_pred tyvars deriv_rhs+                -- checkValidInstance tyvars theta clas inst_tys+                -- Not necessary; see Note [Exotic derived instance contexts]++           ; traceTc "TcDeriv" (ppr deriv_rhs $$ ppr theta)+                -- Claim: the result instance declaration is guaranteed valid+                -- Hence no need to call:+                --   checkValidInstance tyvars theta clas inst_tys+           ; return theta }+      where+        the_pred = mkClassPred clas inst_tys++derivInstCtxt :: PredType -> MsgDoc+derivInstCtxt pred+  = text "When deriving the instance for" <+> parens (ppr pred)++{-+***********************************************************************************+*                                                                                 *+*            Simplify derived constraints+*                                                                                 *+***********************************************************************************+-}++-- | Given @instance (wanted) => C inst_ty@, simplify 'wanted' as much+-- as possible. Fail if not possible.+simplifyDeriv :: PredType -- ^ @C inst_ty@, head of the instance we are+                          -- deriving.  Only used for SkolemInfo.+              -> [TyVar]  -- ^ The tyvars bound by @inst_ty@.+              -> [ThetaOrigin] -- ^ Given and wanted constraints+              -> TcM ThetaType -- ^ Needed constraints (after simplification),+                               -- i.e. @['PredType']@.+simplifyDeriv pred tvs thetas+  = do { (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize+                -- The constraint solving machinery+                -- expects *TcTyVars* not TyVars.+                -- We use *non-overlappable* (vanilla) skolems+                -- See Note [Overlap and deriving]++       ; let skol_set  = mkVarSet tvs_skols+             skol_info = DerivSkol pred+             doc = text "deriving" <+> parens (ppr pred)++             mk_given_ev :: PredType -> TcM EvVar+             mk_given_ev given =+               let given_pred = substTy skol_subst given+               in newEvVar given_pred++             mk_wanted_ct :: PredOrigin -> TcM CtEvidence+             mk_wanted_ct (PredOrigin wanted o t_or_k)+               = newWanted o (Just t_or_k) (substTyUnchecked skol_subst wanted)++             -- Create the implications we need to solve. For stock and newtype+             -- deriving, these implication constraints will be simple class+             -- constraints like (C a, Ord b).+             -- But with DeriveAnyClass, we make an implication constraint.+             -- See Note [Gathering and simplifying constraints for DeriveAnyClass]+             mk_wanteds :: ThetaOrigin -> TcM WantedConstraints+             mk_wanteds (ThetaOrigin { to_tvs            = local_skols+                                     , to_givens         = givens+                                     , to_wanted_origins = wanteds })+               | null local_skols, null givens+               = do { wanted_cts <- mapM mk_wanted_ct wanteds+                    ; return (mkSimpleWC wanted_cts) }+               | otherwise+               = do { given_evs <- mapM mk_given_ev givens+                    ; (wanted_cts, tclvl) <- pushTcLevelM $+                                             mapM mk_wanted_ct wanteds+                    ; (implic, _) <- buildImplicationFor tclvl skol_info local_skols+                                                   given_evs (mkSimpleWC wanted_cts)+                    ; pure (mkImplicWC implic) }++       -- See [STEP DAC BUILD]+       -- Generate the implication constraints constraints to solve with the+       -- skolemized variables+       ; (wanteds, tclvl) <- pushTcLevelM $ mapM mk_wanteds thetas++       ; traceTc "simplifyDeriv inputs" $+         vcat [ pprTyVars tvs $$ ppr thetas $$ ppr wanteds, doc ]++       -- See [STEP DAC SOLVE]+       -- Simplify the constraints+       ; solved_implics <- runTcSDeriveds $ solveWantedsAndDrop+                                          $ unionsWC wanteds++       -- See [STEP DAC HOIST]+       -- Split the resulting constraints into bad and good constraints,+       -- building an @unsolved :: WantedConstraints@ representing all+       -- the constraints we can't just shunt to the predicates.+       -- See Note [Exotic derived instance contexts]+       ; let residual_simple = approximateWC True solved_implics+             (bad, good) = partitionBagWith get_good residual_simple++             get_good :: Ct -> Either Ct PredType+             get_good ct | validDerivPred skol_set p+                         , isWantedCt ct+                         = Right p+                          -- TODO: This is wrong+                          -- NB re 'isWantedCt': residual_wanted may contain+                          -- unsolved CtDerived and we stick them into the+                          -- bad set so that reportUnsolved may decide what+                          -- to do with them+                         | otherwise+                         = Left ct+                           where p = ctPred ct++       ; traceTc "simplifyDeriv outputs" $+         vcat [ ppr tvs_skols, ppr residual_simple, ppr good, ppr bad ]++       -- Return the good unsolved constraints (unskolemizing on the way out.)+       ; let min_theta = mkMinimalBySCs (bagToList good)+             -- An important property of mkMinimalBySCs (used above) is that in+             -- addition to removing constraints that are made redundant by+             -- superclass relationships, it also removes _duplicate_+             -- constraints.+             -- See Note [Gathering and simplifying constraints for+             --           DeriveAnyClass]+             subst_skol = zipTvSubst tvs_skols $ mkTyVarTys tvs+                          -- The reverse substitution (sigh)++       -- See [STEP DAC RESIDUAL]+       ; min_theta_vars <- mapM newEvVar min_theta+       ; (leftover_implic, _) <- buildImplicationFor tclvl skol_info tvs_skols+                                   min_theta_vars solved_implics+       -- This call to simplifyTop is purely for error reporting+       -- See Note [Error reporting for deriving clauses]+       -- See also Note [Exotic derived instance contexts], which are caught+       -- in this line of code.+       ; simplifyTopImplic leftover_implic++       ; return (substTheta subst_skol min_theta) }++{-+Note [Overlap and deriving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider some overlapping instances:+  data Show a => Show [a] where ..+  data Show [Char] where ...++Now a data type with deriving:+  data T a = MkT [a] deriving( Show )++We want to get the derived instance+  instance Show [a] => Show (T a) where...+and NOT+  instance Show a => Show (T a) where...+so that the (Show (T Char)) instance does the Right Thing++It's very like the situation when we're inferring the type+of a function+   f x = show [x]+and we want to infer+   f :: Show [a] => a -> String++BOTTOM LINE: use vanilla, non-overlappable skolems when inferring+             the context for the derived instance.+             Hence tcInstSkolTyVars not tcInstSuperSkolTyVars++Note [Gathering and simplifying constraints for DeriveAnyClass]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+DeriveAnyClass works quite differently from stock and newtype deriving in+the way it gathers and simplifies constraints to be used in a derived+instance's context. Stock and newtype deriving gather constraints by looking+at the data constructors of the data type for which we are deriving an+instance. But DeriveAnyClass doesn't need to know about a data type's+definition at all!++To see why, consider this example of DeriveAnyClass:++  class Foo a where+    bar :: forall b. Ix b => a -> b -> String+    default bar :: (Show a, Ix c) => a -> c -> String+    bar x y = show x ++ show (range (y,y))++    baz :: Eq a => a -> a -> Bool+    default baz :: (Ord a, Show a) => a -> a -> Bool+    baz x y = compare x y == EQ++Because 'bar' and 'baz' have default signatures, this generates a top-level+definition for these generic default methods++  $gdm_bar :: forall a. Foo a+           => forall c. (Show a, Ix c)+           => a -> c -> String+  $gdm_bar x y = show x ++ show (range (y,y))++(and similarly for baz).  Now consider a 'deriving' clause+  data Maybe s = ... deriving Foo++This derives an instance of the form:+  instance (CX) => Foo (Maybe s) where+    bar = $gdm_bar+    baz = $gdm_baz++Now it is GHC's job to fill in a suitable instance context (CX).  If+GHC were typechecking the binding+   bar = $gdm bar+it would+   * skolemise the expected type of bar+   * instantiate the type of $dm_bar with meta-type variables+   * build an implication constraint++[STEP DAC BUILD]+So that's what we do.  We build the constraint (call it C1)++   forall b. Ix b => (Show (Maybe s), Ix cc,+                      Maybe s -> b -> String+                          ~ Maybe s -> cc -> String)++The 'cc' is a unification variable that comes from instantiating+$dm_bar's type.  The equality constraint comes from marrying up+the instantiated type of $dm_bar with the specified type of bar.+Notice that the type variables from the instance, 's' in this case,+are global to this constraint.++Similarly for 'baz', givng the constraint C2++   forall. Eq (Maybe s) => (Ord a, Show a,+                            Maybe s -> Maybe s -> Bool+                                ~ Maybe s -> Maybe s -> Bool)++In this case baz has no local quantification, so the implication+constraint has no local skolems and there are no unificaiton+variables.++[STEP DAC SOLVE]+We can combine these two implication constraints into a single+constraint (C1, C2), and simplify, unifying cc:=b, to get:++   forall b. Ix b => Show a+   /\+   forall. Eq (Maybe s) => (Ord a, Show a)++[STEP DAC HOIST]+Let's call that (C1', C2').  Now we need to hoist the unsolved+constraints out of the implications to become our candidate for+(CX). That is done by approximateWC, which will return:++  (Show a, Ord a, Show a)++Now we can use mkMinimalBySCs to remove superclasses and duplicates, giving++  (Show a, Ord a)++And that's what GHC uses for CX.++[STEP DAC RESIDUAL]+In this case we have solved all the leftover constraints, but what if+we don't?  Simple!  We just form the final residual constraint++   forall s. CX => (C1',C2')++and simplify that. In simple cases it'll succeed easily, because CX+literally contains the constraints in C1', C2', but if there is anything+more complicated it will be reported in a civilised way.++Note [Error reporting for deriving clauses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A suprisingly tricky aspect of deriving to get right is reporting sensible+error messages. In particular, if simplifyDeriv reaches a constraint that it+cannot solve, which might include:++1. Insoluble constraints+2. "Exotic" constraints (See Note [Exotic derived instance contexts])++Then we report an error immediately in simplifyDeriv.++Another possible choice is to punt and let another part of the typechecker+(e.g., simplifyInstanceContexts) catch the errors. But this tends to lead+to worse error messages, so we do it directly in simplifyDeriv.++simplifyDeriv checks for errors in a clever way. If the deriving machinery+infers the context (Foo a)--that is, if this instance is to be generated:++  instance Foo a => ...++Then we form an implication of the form:++  forall a. Foo a => <residual_wanted_constraints>++And pass it to the simplifier. If the context (Foo a) is enough to discharge+all the constraints in <residual_wanted_constraints>, then everything is+hunky-dory. But if <residual_wanted_constraints> contains, say, an insoluble+constraint, then (Foo a) won't be able to solve it, causing GHC to error.++Note [Exotic derived instance contexts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a 'derived' instance declaration, we *infer* the context.  It's a+bit unclear what rules we should apply for this; the Haskell report is+silent.  Obviously, constraints like (Eq a) are fine, but what about+        data T f a = MkT (f a) deriving( Eq )+where we'd get an Eq (f a) constraint.  That's probably fine too.++One could go further: consider+        data T a b c = MkT (Foo a b c) deriving( Eq )+        instance (C Int a, Eq b, Eq c) => Eq (Foo a b c)++Notice that this instance (just) satisfies the Paterson termination+conditions.  Then we *could* derive an instance decl like this:++        instance (C Int a, Eq b, Eq c) => Eq (T a b c)+even though there is no instance for (C Int a), because there just+*might* be an instance for, say, (C Int Bool) at a site where we+need the equality instance for T's.++However, this seems pretty exotic, and it's quite tricky to allow+this, and yet give sensible error messages in the (much more common)+case where we really want that instance decl for C.++So for now we simply require that the derived instance context+should have only type-variable constraints.++Here is another example:+        data Fix f = In (f (Fix f)) deriving( Eq )+Here, if we are prepared to allow -XUndecidableInstances we+could derive the instance+        instance Eq (f (Fix f)) => Eq (Fix f)+but this is so delicate that I don't think it should happen inside+'deriving'. If you want this, write it yourself!++NB: if you want to lift this condition, make sure you still meet the+termination conditions!  If not, the deriving mechanism generates+larger and larger constraints.  Example:+  data Succ a = S a+  data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show++Note the lack of a Show instance for Succ.  First we'll generate+  instance (Show (Succ a), Show a) => Show (Seq a)+and then+  instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a)+and so on.  Instead we want to complain of no instance for (Show (Succ a)).++The bottom line+~~~~~~~~~~~~~~~+Allow constraints which consist only of type variables, with no repeats.+-}
+ typecheck/TcDerivUtils.hs view
@@ -0,0 +1,669 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Error-checking and other utilities for @deriving@ clauses or declarations.+-}++{-# LANGUAGE ImplicitParams #-}++module TcDerivUtils (+        DerivSpec(..), pprDerivSpec,+        DerivSpecMechanism(..), isDerivSpecStock,+        isDerivSpecNewtype, isDerivSpecAnyClass,+        DerivContext, DerivStatus(..),+        PredOrigin(..), ThetaOrigin(..), mkPredOrigin,+        mkThetaOrigin, mkThetaOriginFromPreds, substPredOrigin,+        checkSideConditions, hasStockDeriving,+        canDeriveAnyClass,+        std_class_via_coercible, non_coercible_class,+        newDerivClsInst, extendLocalInstEnv+    ) where++import Bag+import BasicTypes+import Class+import DataCon+import DynFlags+import ErrUtils+import HscTypes (lookupFixity, mi_fix)+import HsSyn+import Inst+import InstEnv+import LoadIface (loadInterfaceForName)+import Module (getModule)+import Name+import Outputable+import PrelNames+import RdrName+import SrcLoc+import TcGenDeriv+import TcGenFunctor+import TcGenGenerics+import TcRnMonad+import TcType+import THNames (liftClassKey)+import TyCon+import Type+import Util+import VarSet++import qualified GHC.LanguageExtensions as LangExt+import ListSetOps (assocMaybe)++data DerivSpec theta = DS { ds_loc       :: SrcSpan+                          , ds_name      :: Name         -- DFun name+                          , ds_tvs       :: [TyVar]+                          , ds_theta     :: theta+                          , ds_cls       :: Class+                          , ds_tys       :: [Type]+                          , ds_tc        :: TyCon+                          , ds_overlap   :: Maybe OverlapMode+                          , ds_mechanism :: DerivSpecMechanism }+        -- This spec implies a dfun declaration of the form+        --       df :: forall tvs. theta => C tys+        -- The Name is the name for the DFun we'll build+        -- The tyvars bind all the variables in the theta+        -- For type families, the tycon in+        --       in ds_tys is the *family* tycon+        --       in ds_tc is the *representation* type+        -- For non-family tycons, both are the same++        -- the theta is either the given and final theta, in standalone deriving,+        -- or the not-yet-simplified list of constraints together with their origin++        -- ds_mechanism specifies the means by which GHC derives the instance.+        -- See Note [Deriving strategies] in TcDeriv++{-+Example:++     newtype instance T [a] = MkT (Tree a) deriving( C s )+==>+     axiom T [a] = :RTList a+     axiom :RTList a = Tree a++     DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]]+        , ds_tc = :RTList, ds_mechanism = DerivSpecNewtype (Tree a) }+-}++pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc+pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, ds_cls = c,+                   ds_tys = tys, ds_theta = rhs, ds_mechanism = mech })+  = hang (text "DerivSpec")+       2 (vcat [ text "ds_loc       =" <+> ppr l+               , text "ds_name      =" <+> ppr n+               , text "ds_tvs       =" <+> ppr tvs+               , text "ds_cls       =" <+> ppr c+               , text "ds_tys       =" <+> ppr tys+               , text "ds_theta     =" <+> ppr rhs+               , text "ds_mechanism =" <+> ppr mech ])++instance Outputable theta => Outputable (DerivSpec theta) where+  ppr = pprDerivSpec++-- What action to take in order to derive a class instance.+-- See Note [Deriving strategies] in TcDeriv+-- NB: DerivSpecMechanism is purely local to this module+data DerivSpecMechanism+  = DerivSpecStock   -- "Standard" classes+      (SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds RdrName, BagDerivStuff))++  | DerivSpecNewtype -- -XGeneralizedNewtypeDeriving+      Type -- ^ The newtype rep type++  | DerivSpecAnyClass -- -XDeriveAnyClass++isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass+  :: DerivSpecMechanism -> Bool+isDerivSpecStock (DerivSpecStock{}) = True+isDerivSpecStock _                  = False++isDerivSpecNewtype (DerivSpecNewtype{}) = True+isDerivSpecNewtype _                    = False++isDerivSpecAnyClass (DerivSpecAnyClass{}) = True+isDerivSpecAnyClass _                     = False++-- A DerivSpecMechanism can be losslessly converted to a DerivStrategy.+mechanismToStrategy :: DerivSpecMechanism -> DerivStrategy+mechanismToStrategy (DerivSpecStock{})    = StockStrategy+mechanismToStrategy (DerivSpecNewtype{})  = NewtypeStrategy+mechanismToStrategy (DerivSpecAnyClass{}) = AnyclassStrategy++instance Outputable DerivSpecMechanism where+  ppr = ppr . mechanismToStrategy++type DerivContext = Maybe ThetaType+   -- Nothing    <=> Vanilla deriving; infer the context of the instance decl+   -- Just theta <=> Standalone deriving: context supplied by programmer++data DerivStatus = CanDerive                 -- Stock class, can derive+                 | DerivableClassError SDoc  -- Stock class, but can't do it+                 | DerivableViaInstance      -- See Note [Deriving any class]+                 | NonDerivableClass SDoc    -- Non-stock class++-- A stock class is one either defined in the Haskell report or for which GHC+-- otherwise knows how to generate code for (possibly requiring the use of a+-- language extension), such as Eq, Ord, Ix, Data, Generic, etc.++-- | A 'PredType' annotated with the origin of the constraint 'CtOrigin',+-- and whether or the constraint deals in types or kinds.+data PredOrigin = PredOrigin PredType CtOrigin TypeOrKind++-- | A list of wanted 'PredOrigin' constraints ('to_wanted_origins') alongside+-- any corresponding given constraints ('to_givens') and locally quantified+-- type variables ('to_tvs').+--+-- In most cases, 'to_givens' will be empty, as most deriving mechanisms (e.g.,+-- stock and newtype deriving) do not require given constraints. The exception+-- is @DeriveAnyClass@, which can involve given constraints. For example,+-- if you tried to derive an instance for the following class using+-- @DeriveAnyClass@:+--+-- @+-- class Foo a where+--   bar :: a -> b -> String+--   default bar :: (Show a, Ix b) => a -> b -> String+--   bar = show+--+--   baz :: Eq a => a -> a -> Bool+--   default baz :: Ord a => a -> a -> Bool+--   baz x y = compare x y == EQ+-- @+--+-- Then it would generate two 'ThetaOrigin's, one for each method:+--+-- @+-- [ ThetaOrigin { to_tvs            = [b]+--               , to_givens         = []+--               , to_wanted_origins = [Show a, Ix b] }+-- , ThetaOrigin { to_tvs            = []+--               , to_givens         = [Eq a]+--               , to_wanted_origins = [Ord a] }+-- ]+-- @+data ThetaOrigin+  = ThetaOrigin { to_tvs            :: [TyVar]+                , to_givens         :: ThetaType+                , to_wanted_origins :: [PredOrigin] }++instance Outputable PredOrigin where+  ppr (PredOrigin ty _ _) = ppr ty -- The origin is not so interesting when debugging++instance Outputable ThetaOrigin where+  ppr (ThetaOrigin { to_tvs = tvs+                   , to_givens = givens+                   , to_wanted_origins = wanted_origins })+    = hang (text "ThetaOrigin")+         2 (vcat [ text "to_tvs            =" <+> ppr tvs+                 , text "to_givens         =" <+> ppr givens+                 , text "to_wanted_origins =" <+> ppr wanted_origins ])++mkPredOrigin :: CtOrigin -> TypeOrKind -> PredType -> PredOrigin+mkPredOrigin origin t_or_k pred = PredOrigin pred origin t_or_k++mkThetaOrigin :: CtOrigin -> TypeOrKind -> [TyVar] -> ThetaType -> ThetaType+              -> ThetaOrigin+mkThetaOrigin origin t_or_k tvs givens+  = ThetaOrigin tvs givens . map (mkPredOrigin origin t_or_k)++-- A common case where the ThetaOrigin only contains wanted constraints, with+-- no givens or locally scoped type variables.+mkThetaOriginFromPreds :: [PredOrigin] -> ThetaOrigin+mkThetaOriginFromPreds = ThetaOrigin [] []++substPredOrigin :: HasCallStack => TCvSubst -> PredOrigin -> PredOrigin+substPredOrigin subst (PredOrigin pred origin t_or_k)+  = PredOrigin (substTy subst pred) origin t_or_k++{-+************************************************************************+*                                                                      *+                Class deriving diagnostics+*                                                                      *+************************************************************************++Only certain blessed classes can be used in a deriving clause (without the+assistance of GeneralizedNewtypeDeriving or DeriveAnyClass). These classes+are listed below in the definition of hasStockDeriving. The sideConditions+function determines the criteria that needs to be met in order for a particular+class to be able to be derived successfully.++A class might be able to be used in a deriving clause if -XDeriveAnyClass+is willing to support it. The canDeriveAnyClass function checks if this is the+case.+-}++hasStockDeriving :: Class+                   -> Maybe (SrcSpan+                             -> TyCon+                             -> [Type]+                             -> TcM (LHsBinds RdrName, BagDerivStuff))+hasStockDeriving clas+  = assocMaybe gen_list (getUnique clas)+  where+    gen_list :: [(Unique, SrcSpan+                          -> TyCon+                          -> [Type]+                          -> TcM (LHsBinds RdrName, BagDerivStuff))]+    gen_list = [ (eqClassKey,          simpleM gen_Eq_binds)+               , (ordClassKey,         simpleM gen_Ord_binds)+               , (enumClassKey,        simpleM gen_Enum_binds)+               , (boundedClassKey,     simple gen_Bounded_binds)+               , (ixClassKey,          simpleM gen_Ix_binds)+               , (showClassKey,        with_fix_env gen_Show_binds)+               , (readClassKey,        with_fix_env gen_Read_binds)+               , (dataClassKey,        simpleM gen_Data_binds)+               , (functorClassKey,     simple gen_Functor_binds)+               , (foldableClassKey,    simple gen_Foldable_binds)+               , (traversableClassKey, simple gen_Traversable_binds)+               , (liftClassKey,        simple gen_Lift_binds)+               , (genClassKey,         generic (gen_Generic_binds Gen0))+               , (gen1ClassKey,        generic (gen_Generic_binds Gen1)) ]++    simple gen_fn loc tc _+      = return (gen_fn loc tc)++    simpleM gen_fn loc tc _+      = gen_fn loc tc++    with_fix_env gen_fn loc tc _+      = do { fix_env <- getDataConFixityFun tc+           ; return (gen_fn fix_env loc tc) }++    generic gen_fn _ tc inst_tys+      = do { (binds, faminst) <- gen_fn tc inst_tys+           ; return (binds, unitBag (DerivFamInst faminst)) }++getDataConFixityFun :: TyCon -> TcM (Name -> Fixity)+-- If the TyCon is locally defined, we want the local fixity env;+-- but if it is imported (which happens for standalone deriving)+-- we need to get the fixity env from the interface file+-- c.f. RnEnv.lookupFixity, and Trac #9830+getDataConFixityFun tc+  = do { this_mod <- getModule+       ; if nameIsLocalOrFrom this_mod name+         then do { fix_env <- getFixityEnv+                 ; return (lookupFixity fix_env) }+         else do { iface <- loadInterfaceForName doc name+                            -- Should already be loaded!+                 ; return (mi_fix iface . nameOccName) } }+  where+    name = tyConName tc+    doc = text "Data con fixities for" <+> ppr name++------------------------------------------------------------------+-- Check side conditions that dis-allow derivability for particular classes+-- This is *apart* from the newtype-deriving mechanism+--+-- Here we get the representation tycon in case of family instances as it has+-- the data constructors - but we need to be careful to fall back to the+-- family tycon (with indexes) in error messages.++checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType]+                    -> TyCon -- tycon+                    -> DerivStatus+checkSideConditions dflags mtheta cls cls_tys rep_tc+  | Just cond <- sideConditions mtheta cls+  = case (cond dflags rep_tc) of+        NotValid err -> DerivableClassError err  -- Class-specific error+        IsValid  | null (filterOutInvisibleTypes (classTyCon cls) cls_tys)+                   -> CanDerive+                   -- All stock derivable classes are unary in the sense that+                   -- there should be not types in cls_tys (i.e., no type args+                   -- other than last). Note that cls_types can contain+                   -- invisible types as well (e.g., for Generic1, which is+                   -- poly-kinded), so make sure those are not counted.+                 | otherwise -> DerivableClassError (classArgsErr cls cls_tys)+                   -- e.g. deriving( Eq s )++  | NotValid err <- canDeriveAnyClass dflags+  = NonDerivableClass err  -- DeriveAnyClass does not work++  | otherwise+  = DerivableViaInstance   -- DeriveAnyClass should work++classArgsErr :: Class -> [Type] -> SDoc+classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> text "is not a class"++-- Side conditions (whether the datatype must have at least one constructor,+-- required language extensions, etc.) for using GHC's stock deriving+-- mechanism on certain classes (as opposed to classes that require+-- GeneralizedNewtypeDeriving or DeriveAnyClass). Returns Nothing for a+-- class for which stock deriving isn't possible.+sideConditions :: DerivContext -> Class -> Maybe Condition+sideConditions mtheta cls+  | cls_key == eqClassKey          = Just (cond_std `andCond` cond_args cls)+  | cls_key == ordClassKey         = Just (cond_std `andCond` cond_args cls)+  | cls_key == showClassKey        = Just (cond_std `andCond` cond_args cls)+  | cls_key == readClassKey        = Just (cond_std `andCond` cond_args cls)+  | cls_key == enumClassKey        = Just (cond_std `andCond` cond_isEnumeration)+  | cls_key == ixClassKey          = Just (cond_std `andCond` cond_enumOrProduct cls)+  | cls_key == boundedClassKey     = Just (cond_std `andCond` cond_enumOrProduct cls)+  | cls_key == dataClassKey        = Just (checkFlag LangExt.DeriveDataTypeable `andCond`+                                           cond_std `andCond`+                                           cond_args cls)+  | cls_key == functorClassKey     = Just (checkFlag LangExt.DeriveFunctor `andCond`+                                           cond_vanilla `andCond`+                                           cond_functorOK True False)+  | cls_key == foldableClassKey    = Just (checkFlag LangExt.DeriveFoldable `andCond`+                                           cond_vanilla `andCond`+                                           cond_functorOK False True)+                                           -- Functor/Fold/Trav works ok+                                           -- for rank-n types+  | cls_key == traversableClassKey = Just (checkFlag LangExt.DeriveTraversable `andCond`+                                           cond_vanilla `andCond`+                                           cond_functorOK False False)+  | cls_key == genClassKey         = Just (checkFlag LangExt.DeriveGeneric `andCond`+                                           cond_vanilla `andCond`+                                           cond_RepresentableOk)+  | cls_key == gen1ClassKey        = Just (checkFlag LangExt.DeriveGeneric `andCond`+                                           cond_vanilla `andCond`+                                           cond_Representable1Ok)+  | cls_key == liftClassKey        = Just (checkFlag LangExt.DeriveLift `andCond`+                                           cond_vanilla `andCond`+                                           cond_args cls)+  | otherwise                      = Nothing+  where+    cls_key = getUnique cls+    cond_std     = cond_stdOK mtheta False  -- Vanilla data constructors, at least one,+                                            --    and monotype arguments+    cond_vanilla = cond_stdOK mtheta True   -- Vanilla data constructors but+                                            --   allow no data cons or polytype arguments++canDeriveAnyClass :: DynFlags -> Validity+-- IsValid: we can (try to) derive it via an empty instance declaration+-- NotValid s:  we can't, reason s+canDeriveAnyClass dflags+  | not (xopt LangExt.DeriveAnyClass dflags)+  = NotValid (text "Try enabling DeriveAnyClass")+  | otherwise+  = IsValid   -- OK!++type Condition = DynFlags -> TyCon -> Validity+        -- TyCon is the *representation* tycon if the data type is an indexed one+        -- Nothing => OK++orCond :: Condition -> Condition -> Condition+orCond c1 c2 dflags tc+  = case (c1 dflags tc, c2 dflags tc) of+     (IsValid,    _)          -> IsValid    -- c1 succeeds+     (_,          IsValid)    -> IsValid    -- c21 succeeds+     (NotValid x, NotValid y) -> NotValid (x $$ text "  or" $$ y)+                                            -- Both fail++andCond :: Condition -> Condition -> Condition+andCond c1 c2 dflags tc = c1 dflags tc `andValid` c2 dflags tc++cond_stdOK :: DerivContext -- Says whether this is standalone deriving or not;+                           --     if standalone, we just say "yes, go for it"+           -> Bool         -- True <=> permissive: allow higher rank+                           --          args and no data constructors+           -> Condition+cond_stdOK (Just _) _ _ _+  = IsValid     -- Don't check these conservative conditions for+                -- standalone deriving; just generate the code+                -- and let the typechecker handle the result+cond_stdOK Nothing permissive _ rep_tc+  | null data_cons+  , not permissive      = NotValid (no_cons_why rep_tc $$ suggestion)+  | not (null con_whys) = NotValid (vcat con_whys $$ suggestion)+  | otherwise           = IsValid+  where+    suggestion = text "Possible fix: use a standalone deriving declaration instead"+    data_cons  = tyConDataCons rep_tc+    con_whys   = getInvalids (map check_con data_cons)++    check_con :: DataCon -> Validity+    check_con con+      | not (null eq_spec)+      = bad "is a GADT"+      | not (null ex_tvs)+      = bad "has existential type variables in its type"+      | not (null theta)+      = bad "has constraints in its type"+      | not (permissive || all isTauTy (dataConOrigArgTys con))+      = bad "has a higher-rank type"+      | otherwise+      = IsValid+      where+        (_, ex_tvs, eq_spec, theta, _, _) = dataConFullSig con+        bad msg = NotValid (badCon con (text msg))++no_cons_why :: TyCon -> SDoc+no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>+                     text "must have at least one data constructor"++cond_RepresentableOk :: Condition+cond_RepresentableOk _ tc = canDoGenerics tc++cond_Representable1Ok :: Condition+cond_Representable1Ok _ tc = canDoGenerics1 tc++cond_enumOrProduct :: Class -> Condition+cond_enumOrProduct cls = cond_isEnumeration `orCond`+                         (cond_isProduct `andCond` cond_args cls)++cond_args :: Class -> Condition+-- For some classes (eg Eq, Ord) we allow unlifted arg types+-- by generating specialised code.  For others (eg Data) we don't.+cond_args cls _ tc+  = case bad_args of+      []     -> IsValid+      (ty:_) -> NotValid (hang (text "Don't know how to derive" <+> quotes (ppr cls))+                             2 (text "for type" <+> quotes (ppr ty)))+  where+    bad_args = [ arg_ty | con <- tyConDataCons tc+                        , arg_ty <- dataConOrigArgTys con+                        , isUnliftedType arg_ty+                        , not (ok_ty arg_ty) ]++    cls_key = classKey cls+    ok_ty arg_ty+     | cls_key == eqClassKey   = check_in arg_ty ordOpTbl+     | cls_key == ordClassKey  = check_in arg_ty ordOpTbl+     | cls_key == showClassKey = check_in arg_ty boxConTbl+     | cls_key == liftClassKey = check_in arg_ty litConTbl+     | otherwise               = False    -- Read, Ix etc++    check_in :: Type -> [(Type,a)] -> Bool+    check_in arg_ty tbl = any (eqType arg_ty . fst) tbl+++cond_isEnumeration :: Condition+cond_isEnumeration _ rep_tc+  | isEnumerationTyCon rep_tc = IsValid+  | otherwise                 = NotValid why+  where+    why = sep [ quotes (pprSourceTyCon rep_tc) <+>+                  text "must be an enumeration type"+              , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ]+                  -- See Note [Enumeration types] in TyCon++cond_isProduct :: Condition+cond_isProduct _ rep_tc+  | isProductTyCon rep_tc = IsValid+  | otherwise             = NotValid why+  where+    why = quotes (pprSourceTyCon rep_tc) <+>+          text "must have precisely one constructor"++cond_functorOK :: Bool -> Bool -> Condition+-- OK for Functor/Foldable/Traversable class+-- Currently: (a) at least one argument+--            (b) don't use argument contravariantly+--            (c) don't use argument in the wrong place, e.g. data T a = T (X a a)+--            (d) optionally: don't use function types+--            (e) no "stupid context" on data type+cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ rep_tc+  | null tc_tvs+  = NotValid (text "Data type" <+> quotes (ppr rep_tc)+              <+> text "must have some type parameters")++  | not (null bad_stupid_theta)+  = NotValid (text "Data type" <+> quotes (ppr rep_tc)+              <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta)++  | otherwise+  = allValid (map check_con data_cons)+  where+    tc_tvs            = tyConTyVars rep_tc+    Just (_, last_tv) = snocView tc_tvs+    bad_stupid_theta  = filter is_bad (tyConStupidTheta rep_tc)+    is_bad pred       = last_tv `elemVarSet` tyCoVarsOfType pred++    data_cons = tyConDataCons rep_tc+    check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con)++    check_universal :: DataCon -> Validity+    check_universal con+      | allowExQuantifiedLastTyVar+      = IsValid -- See Note [DeriveFoldable with ExistentialQuantification]+                -- in TcGenFunctor+      | Just tv <- getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con)))+      , tv `elem` dataConUnivTyVars con+      , not (tv `elemVarSet` tyCoVarsOfTypes (dataConTheta con))+      = IsValid   -- See Note [Check that the type variable is truly universal]+      | otherwise+      = NotValid (badCon con existential)++    ft_check :: DataCon -> FFoldType Validity+    ft_check con = FT { ft_triv = IsValid, ft_var = IsValid+                      , ft_co_var = NotValid (badCon con covariant)+                      , ft_fun = \x y -> if allowFunctions then x `andValid` y+                                                           else NotValid (badCon con functions)+                      , ft_tup = \_ xs  -> allValid xs+                      , ft_ty_app = \_ x   -> x+                      , ft_bad_app = NotValid (badCon con wrong_arg)+                      , ft_forall = \_ x   -> x }++    existential = text "must be truly polymorphic in the last argument of the data type"+    covariant   = text "must not use the type variable in a function argument"+    functions   = text "must not contain function types"+    wrong_arg   = text "must use the type variable only as the last argument of a data type"++checkFlag :: LangExt.Extension -> Condition+checkFlag flag dflags _+  | xopt flag dflags = IsValid+  | otherwise        = NotValid why+  where+    why = text "You need " <> text flag_str+          <+> text "to derive an instance for this class"+    flag_str = case [ flagSpecName f | f <- xFlags , flagSpecFlag f == flag ] of+                 [s]   -> s+                 other -> pprPanic "checkFlag" (ppr other)++std_class_via_coercible :: Class -> Bool+-- These standard classes can be derived for a newtype+-- using the coercible trick *even if no -XGeneralizedNewtypeDeriving+-- because giving so gives the same results as generating the boilerplate+std_class_via_coercible clas+  = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]+        -- Not Read/Show because they respect the type+        -- Not Enum, because newtypes are never in Enum+++non_coercible_class :: Class -> Bool+-- *Never* derive Read, Show, Typeable, Data, Generic, Generic1, Lift+-- by Coercible, even with -XGeneralizedNewtypeDeriving+-- Also, avoid Traversable, as the Coercible-derived instance and the "normal"-derived+-- instance behave differently if there's a non-lawful Applicative out there.+-- Besides, with roles, Coercible-deriving Traversable is ill-roled.+non_coercible_class cls+  = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey+                         , genClassKey, gen1ClassKey, typeableClassKey+                         , traversableClassKey, liftClassKey ])++badCon :: DataCon -> SDoc -> SDoc+badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg++------------------------------------------------------------------++newDerivClsInst :: ThetaType -> DerivSpec theta -> TcM ClsInst+newDerivClsInst theta (DS { ds_name = dfun_name, ds_overlap = overlap_mode+                          , ds_tvs = tvs, ds_cls = clas, ds_tys = tys })+  = newClsInst overlap_mode dfun_name tvs theta clas tys++extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a+-- Add new locally-defined instances; don't bother to check+-- for functional dependency errors -- that'll happen in TcInstDcls+extendLocalInstEnv dfuns thing_inside+ = do { env <- getGblEnv+      ; let  inst_env' = extendInstEnvList (tcg_inst_env env) dfuns+             env'      = env { tcg_inst_env = inst_env' }+      ; setGblEnv env' thing_inside }++{-+Note [Deriving any class]+~~~~~~~~~~~~~~~~~~~~~~~~~+Classic uses of a deriving clause, or a standalone-deriving declaration, are+for:+  * a stock class like Eq or Show, for which GHC knows how to generate+    the instance code+  * a newtype, via the mechanism enabled by GeneralizedNewtypeDeriving++The DeriveAnyClass extension adds a third way to derive instances, based on+empty instance declarations.++The canonical use case is in combination with GHC.Generics and default method+signatures. These allow us to have instance declarations being empty, but still+useful, e.g.++  data T a = ...blah..blah... deriving( Generic )+  instance C a => C (T a)  -- No 'where' clause++where C is some "random" user-defined class.++This boilerplate code can be replaced by the more compact++  data T a = ...blah..blah... deriving( Generic, C )++if DeriveAnyClass is enabled.++This is not restricted to Generics; any class can be derived, simply giving+rise to an empty instance.++Unfortunately, it is not clear how to determine the context (when using a+deriving clause; in standalone deriving, the user provides the context).+GHC uses the same heuristic for figuring out the class context that it uses for+Eq in the case of *-kinded classes, and for Functor in the case of+* -> *-kinded classes. That may not be optimal or even wrong. But in such+cases, standalone deriving can still be used.++Note [Check that the type variable is truly universal]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For Functor and Traversable instances, we must check that the *last argument*+of the type constructor is used truly universally quantified.  Example++   data T a b where+     T1 :: a -> b -> T a b      -- Fine! Vanilla H-98+     T2 :: b -> c -> T a b      -- Fine! Existential c, but we can still map over 'b'+     T3 :: b -> T Int b         -- Fine! Constraint 'a', but 'b' is still polymorphic+     T4 :: Ord b => b -> T a b  -- No!  'b' is constrained+     T5 :: b -> T b b           -- No!  'b' is constrained+     T6 :: T a (b,b)            -- No!  'b' is constrained++Notice that only the first of these constructors is vanilla H-98. We only+need to take care about the last argument (b in this case).  See Trac #8678.+Eg. for T1-T3 we can write++     fmap f (T1 a b) = T1 a (f b)+     fmap f (T2 b c) = T2 (f b) c+     fmap f (T3 x)   = T3 (f x)++We need not perform these checks for Foldable instances, however, since+functions in Foldable can only consume existentially quantified type variables,+rather than produce them (as is the case in Functor and Traversable functions.)+As a result, T can have a derived Foldable instance:++    foldr f z (T1 a b) = f b z+    foldr f z (T2 b c) = f b z+    foldr f z (T3 x)   = f x z+    foldr f z (T4 x)   = f x z+    foldr f z (T5 x)   = f x z+    foldr _ z T6       = z++See Note [DeriveFoldable with ExistentialQuantification] in TcGenFunctor.+-}
+ typecheck/TcEnv.hs view
@@ -0,0 +1,1023 @@+-- (c) The University of Glasgow 2006+{-# LANGUAGE CPP, FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an+                                       -- orphan+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]+                                      -- in module PlaceHolder++module TcEnv(+        TyThing(..), TcTyThing(..), TcId,++        -- Instance environment, and InstInfo type+        InstInfo(..), iDFunId, pprInstInfoDetails,+        simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon,+        InstBindings(..),++        -- Global environment+        tcExtendGlobalEnv, tcExtendTyConEnv,+        tcExtendGlobalEnvImplicit, setGlobalTypeEnv,+        tcExtendGlobalValEnv,+        tcLookupLocatedGlobal, tcLookupGlobal,+        tcLookupTyCon, tcLookupClass,+        tcLookupDataCon, tcLookupPatSyn, tcLookupConLike,+        tcLookupLocatedGlobalId, tcLookupLocatedTyCon,+        tcLookupLocatedClass, tcLookupAxiom,+        lookupGlobal,++        -- Local environment+        tcExtendKindEnv, tcExtendKindEnvList,+        tcExtendTyVarEnv, tcExtendTyVarEnv2,+        tcExtendLetEnv, tcExtendSigIds, tcExtendRecIds,+        tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,+        tcExtendIdBndrs, tcExtendLocalTypeEnv,+        isTypeClosedLetBndr,++        tcLookup, tcLookupLocated, tcLookupLocalIds,+        tcLookupId, tcLookupTyVar,+        tcLookupLcl_maybe,+        getInLocalScope,+        wrongThingErr, pprBinders,++        tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders,+        getTypeSigNames,+        tcExtendRecEnv,         -- For knot-tying++        -- Instances+        tcLookupInstance, tcGetInstEnvs,++        -- Rules+        tcExtendRules,++        -- Defaults+        tcGetDefaultTys,++        -- Global type variables+        tcGetGlobalTyCoVars,++        -- Template Haskell stuff+        checkWellStaged, tcMetaTy, thLevel,+        topIdLvl, isBrackStage,++        -- New Ids+        newDFunName, newDFunName', newFamInstTyConName,+        newFamInstAxiomName,+        mkStableIdFromString, mkStableIdFromName,+        mkWrapperName+  ) where++#include "HsVersions.h"++import HsSyn+import IfaceEnv+import TcRnMonad+import TcMType+import TcType+import LoadIface+import PrelNames+import TysWiredIn+import Id+import Var+import VarSet+import RdrName+import InstEnv+import DataCon ( DataCon )+import PatSyn  ( PatSyn )+import ConLike+import TyCon+import CoAxiom+import Class+import Name+import NameSet+import NameEnv+import VarEnv+import HscTypes+import DynFlags+import SrcLoc+import BasicTypes hiding( SuccessFlag(..) )+import Module+import Outputable+import Encoding+import FastString+import ListSetOps+import Util+import Maybes( MaybeErr(..), orElse )+import qualified GHC.LanguageExtensions as LangExt++import Data.IORef+import Data.List+++{- *********************************************************************+*                                                                      *+            An IO interface to looking up globals+*                                                                      *+********************************************************************* -}++lookupGlobal :: HscEnv -> Name -> IO TyThing+-- An IO version, used outside the typechecker+-- It's more complicated than it looks, because it may+-- need to suck in an interface file+lookupGlobal hsc_env name+  = initTcForLookup hsc_env (tcLookupGlobal name)+    -- This initTcForLookup stuff is massive overkill+    -- but that's how it is right now, and at least+    -- this function localises it++{-+************************************************************************+*                                                                      *+*                      tcLookupGlobal                                  *+*                                                                      *+************************************************************************++Using the Located versions (eg. tcLookupLocatedGlobal) is preferred,+unless you know that the SrcSpan in the monad is already set to the+span of the Name.+-}+++tcLookupLocatedGlobal :: Located Name -> TcM TyThing+-- c.f. IfaceEnvEnv.tcIfaceGlobal+tcLookupLocatedGlobal name+  = addLocM tcLookupGlobal name++tcLookupGlobal :: Name -> TcM TyThing+-- The Name is almost always an ExternalName, but not always+-- In GHCi, we may make command-line bindings (ghci> let x = True)+-- that bind a GlobalId, but with an InternalName+tcLookupGlobal name+  = do  {    -- Try local envt+          env <- getGblEnv+        ; case lookupNameEnv (tcg_type_env env) name of {+                Just thing -> return thing ;+                Nothing    ->++                -- Should it have been in the local envt?+                -- (NB: use semantic mod here, since names never use+                -- identity module, see Note [Identity versus semantic module].)+          if nameIsLocalOrFrom (tcg_semantic_mod env) name+          then notFound name  -- Internal names can happen in GHCi+          else++           -- Try home package table and external package table+    do  { mb_thing <- tcLookupImported_maybe name+        ; case mb_thing of+            Succeeded thing -> return thing+            Failed msg      -> failWithTc msg+        }}}++tcLookupDataCon :: Name -> TcM DataCon+tcLookupDataCon name = do+    thing <- tcLookupGlobal name+    case thing of+        AConLike (RealDataCon con) -> return con+        _                          -> wrongThingErr "data constructor" (AGlobal thing) name++tcLookupPatSyn :: Name -> TcM PatSyn+tcLookupPatSyn name = do+    thing <- tcLookupGlobal name+    case thing of+        AConLike (PatSynCon ps) -> return ps+        _                       -> wrongThingErr "pattern synonym" (AGlobal thing) name++tcLookupConLike :: Name -> TcM ConLike+tcLookupConLike name = do+    thing <- tcLookupGlobal name+    case thing of+        AConLike cl -> return cl+        _           -> wrongThingErr "constructor-like thing" (AGlobal thing) name++tcLookupClass :: Name -> TcM Class+tcLookupClass name = do+    thing <- tcLookupGlobal name+    case thing of+        ATyCon tc | Just cls <- tyConClass_maybe tc -> return cls+        _                                           -> wrongThingErr "class" (AGlobal thing) name++tcLookupTyCon :: Name -> TcM TyCon+tcLookupTyCon name = do+    thing <- tcLookupGlobal name+    case thing of+        ATyCon tc -> return tc+        _         -> wrongThingErr "type constructor" (AGlobal thing) name++tcLookupAxiom :: Name -> TcM (CoAxiom Branched)+tcLookupAxiom name = do+    thing <- tcLookupGlobal name+    case thing of+        ACoAxiom ax -> return ax+        _           -> wrongThingErr "axiom" (AGlobal thing) name++tcLookupLocatedGlobalId :: Located Name -> TcM Id+tcLookupLocatedGlobalId = addLocM tcLookupId++tcLookupLocatedClass :: Located Name -> TcM Class+tcLookupLocatedClass = addLocM tcLookupClass++tcLookupLocatedTyCon :: Located Name -> TcM TyCon+tcLookupLocatedTyCon = addLocM tcLookupTyCon++-- Find the instance that exactly matches a type class application.  The class arguments must be precisely+-- the same as in the instance declaration (modulo renaming & casts).+--+tcLookupInstance :: Class -> [Type] -> TcM ClsInst+tcLookupInstance cls tys+  = do { instEnv <- tcGetInstEnvs+       ; case lookupUniqueInstEnv instEnv cls tys of+           Left err             -> failWithTc $ text "Couldn't match instance:" <+> err+           Right (inst, tys)+             | uniqueTyVars tys -> return inst+             | otherwise        -> failWithTc errNotExact+       }+  where+    errNotExact = text "Not an exact match (i.e., some variables get instantiated)"++    uniqueTyVars tys = all isTyVarTy tys+                    && hasNoDups (map (getTyVar "tcLookupInstance") tys)++tcGetInstEnvs :: TcM InstEnvs+-- Gets both the external-package inst-env+-- and the home-pkg inst env (includes module being compiled)+tcGetInstEnvs = do { eps <- getEps+                   ; env <- getGblEnv+                   ; return (InstEnvs { ie_global  = eps_inst_env eps+                                      , ie_local   = tcg_inst_env env+                                      , ie_visible = tcVisibleOrphanMods env }) }++instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where+    lookupThing = tcLookupGlobal++{-+************************************************************************+*                                                                      *+                Extending the global environment+*                                                                      *+************************************************************************+-}++setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv+-- Use this to update the global type env+-- It updates both  * the normal tcg_type_env field+--                  * the tcg_type_env_var field seen by interface files+setGlobalTypeEnv tcg_env new_type_env+  = do  {     -- Sync the type-envt variable seen by interface files+           writeMutVar (tcg_type_env_var tcg_env) new_type_env+         ; return (tcg_env { tcg_type_env = new_type_env }) }+++tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r+  -- Just extend the global environment with some TyThings+  -- Do not extend tcg_tcs etc+tcExtendGlobalEnvImplicit things thing_inside+   = do { tcg_env <- getGblEnv+        ; let ge'  = extendTypeEnvList (tcg_type_env tcg_env) things+        ; tcg_env' <- setGlobalTypeEnv tcg_env ge'+        ; setGblEnv tcg_env' thing_inside }++tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r+  -- Given a mixture of Ids, TyCons, Classes, all defined in the+  -- module being compiled, extend the global environment+tcExtendGlobalEnv things thing_inside+  = do { env <- getGblEnv+       ; let env' = env { tcg_tcs = [tc | ATyCon tc <- things] ++ tcg_tcs env,+                          tcg_patsyns = [ps | AConLike (PatSynCon ps) <- things] ++ tcg_patsyns env }+       ; setGblEnv env' $+            tcExtendGlobalEnvImplicit things thing_inside+       }++tcExtendTyConEnv :: [TyCon] -> TcM r -> TcM r+  -- Given a mixture of Ids, TyCons, Classes, all defined in the+  -- module being compiled, extend the global environment+tcExtendTyConEnv tycons thing_inside+  = do { env <- getGblEnv+       ; let env' = env { tcg_tcs = tycons ++ tcg_tcs env }+       ; setGblEnv env' $+         tcExtendGlobalEnvImplicit (map ATyCon tycons) thing_inside+       }++tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a+  -- Same deal as tcExtendGlobalEnv, but for Ids+tcExtendGlobalValEnv ids thing_inside+  = tcExtendGlobalEnvImplicit [AnId id | id <- ids] thing_inside++tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r+-- Extend the global environments for the type/class knot tying game+-- Just like tcExtendGlobalEnv, except the argument is a list of pairs+tcExtendRecEnv gbl_stuff thing_inside+ = do  { tcg_env <- getGblEnv+       ; let ge' = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff+       ; tcg_env' <- setGlobalTypeEnv tcg_env ge'+       ; setGblEnv tcg_env' thing_inside }++{-+************************************************************************+*                                                                      *+\subsection{The local environment}+*                                                                      *+************************************************************************+-}++tcLookupLocated :: Located Name -> TcM TcTyThing+tcLookupLocated = addLocM tcLookup++tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing)+tcLookupLcl_maybe name+  = do { local_env <- getLclTypeEnv+       ; return (lookupNameEnv local_env name) }++tcLookup :: Name -> TcM TcTyThing+tcLookup name = do+    local_env <- getLclTypeEnv+    case lookupNameEnv local_env name of+        Just thing -> return thing+        Nothing    -> AGlobal <$> tcLookupGlobal name++tcLookupTyVar :: Name -> TcM TcTyVar+tcLookupTyVar name+  = do { thing <- tcLookup name+       ; case thing of+           ATyVar _ tv -> return tv+           _           -> pprPanic "tcLookupTyVar" (ppr name) }++tcLookupId :: Name -> TcM Id+-- Used when we aren't interested in the binding level, nor refinement.+-- The "no refinement" part means that we return the un-refined Id regardless+--+-- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId)+tcLookupId name = do+    thing <- tcLookup name+    case thing of+        ATcId { tct_id = id} -> return id+        AGlobal (AnId id)    -> return id+        _                    -> pprPanic "tcLookupId" (ppr name)++tcLookupLocalIds :: [Name] -> TcM [TcId]+-- We expect the variables to all be bound, and all at+-- the same level as the lookup.  Only used in one place...+tcLookupLocalIds ns+  = do { env <- getLclEnv+       ; return (map (lookup (tcl_env env)) ns) }+  where+    lookup lenv name+        = case lookupNameEnv lenv name of+                Just (ATcId { tct_id = id }) ->  id+                _ -> pprPanic "tcLookupLocalIds" (ppr name)++getInLocalScope :: TcM (Name -> Bool)+getInLocalScope = do { lcl_env <- getLclTypeEnv+                     ; return (`elemNameEnv` lcl_env) }++tcExtendKindEnvList :: [(Name, TcTyThing)] -> TcM r -> TcM r+-- Used only during kind checking, for TcThings that are+--      ATcTyCon or APromotionErr+-- No need to update the global tyvars, or tcl_th_bndrs, or tcl_rdr+tcExtendKindEnvList things thing_inside+  = do { traceTc "txExtendKindEnvList" (ppr things)+       ; updLclEnv upd_env thing_inside }+  where+    upd_env env = env { tcl_env = extendNameEnvList (tcl_env env) things }++tcExtendKindEnv :: NameEnv TcTyThing -> TcM r -> TcM r+-- A variant of tcExtendKindEvnList+tcExtendKindEnv extra_env thing_inside+  = do { traceTc "txExtendKindEnv" (ppr extra_env)+       ; updLclEnv upd_env thing_inside }+  where+    upd_env env = env { tcl_env = tcl_env env `plusNameEnv` extra_env }++-----------------------+-- Scoped type and kind variables+tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r+tcExtendTyVarEnv tvs thing_inside+  = tcExtendTyVarEnv2 [(tyVarName tv, tv) | tv <- tvs] thing_inside++tcExtendTyVarEnv2 :: [(Name,TcTyVar)] -> TcM r -> TcM r+tcExtendTyVarEnv2 binds thing_inside+  -- this should be used only for explicitly mentioned scoped variables.+  -- thus, no coercion variables+  = do { tc_extend_local_env NotTopLevel+                    [(name, ATyVar name tv) | (name, tv) <- binds] $+         do { env <- getLclEnv+            ; let env' = env { tcl_tidy = add_tidy_tvs (tcl_tidy env) }+            ; setLclEnv env' thing_inside }}+  where+    add_tidy_tvs env = foldl add env binds++    -- We initialise the "tidy-env", used for tidying types before printing,+    -- by building a reverse map from the in-scope type variables to the+    -- OccName that the programmer originally used for them+    add :: TidyEnv -> (Name, TcTyVar) -> TidyEnv+    add (env,subst) (name, tyvar)+        = ASSERT( isTyVar tyvar )+          case tidyOccName env (nameOccName name) of+            (env', occ') ->  (env', extendVarEnv subst tyvar tyvar')+                where+                  tyvar' = setTyVarName tyvar name'+                  name'  = tidyNameOcc name occ'++isTypeClosedLetBndr :: Id -> Bool+-- See Note [Bindings with closed types] in TcRnTypes+isTypeClosedLetBndr = noFreeVarsOfType . idType++tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a+-- Used for binding the recurive uses of Ids in a binding+-- both top-level value bindings and and nested let/where-bindings+-- Does not extend the TcIdBinderStack+tcExtendRecIds pairs thing_inside+  = tc_extend_local_env NotTopLevel+          [ (name, ATcId { tct_id   = let_id+                         , tct_info = NonClosedLet emptyNameSet False })+          | (name, let_id) <- pairs ] $+    thing_inside++tcExtendSigIds :: TopLevelFlag -> [TcId] -> TcM a -> TcM a+-- Used for binding the Ids that have a complete user type signature+-- Does not extend the TcIdBinderStack+tcExtendSigIds top_lvl sig_ids thing_inside+  = tc_extend_local_env top_lvl+          [ (idName id, ATcId { tct_id   = id+                              , tct_info = info })+          | id <- sig_ids+          , let closed = isTypeClosedLetBndr id+                info   = NonClosedLet emptyNameSet closed ]+     thing_inside+++tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed+                  -> [TcId] -> TcM a -> TcM a+-- Used for both top-level value bindings and and nested let/where-bindings+-- Adds to the TcIdBinderStack too+tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed)+               ids thing_inside+  = tcExtendIdBndrs [TcIdBndr id top_lvl | id <- ids] $+    tc_extend_local_env top_lvl+          [ (idName id, ATcId { tct_id   = id+                              , tct_info = mk_tct_info id })+          | id <- ids ]+    thing_inside+  where+    mk_tct_info id+      | type_closed && isEmptyNameSet rhs_fvs = ClosedLet+      | otherwise                             = NonClosedLet rhs_fvs type_closed+      where+        name        = idName id+        rhs_fvs     = lookupNameEnv fvs name `orElse` emptyNameSet+        type_closed = isTypeClosedLetBndr id &&+                      (fv_type_closed || hasCompleteSig sig_fn name)++tcExtendIdEnv :: [TcId] -> TcM a -> TcM a+-- For lambda-bound and case-bound Ids+-- Extends the the TcIdBinderStack as well+tcExtendIdEnv ids thing_inside+  = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside++tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a+-- Exactly like tcExtendIdEnv2, but for a single (name,id) pair+tcExtendIdEnv1 name id thing_inside+  = tcExtendIdEnv2 [(name,id)] thing_inside++tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a+tcExtendIdEnv2 names_w_ids thing_inside+  = tcExtendIdBndrs [ TcIdBndr mono_id NotTopLevel+                    | (_,mono_id) <- names_w_ids ] $+    tc_extend_local_env NotTopLevel+            [ (name, ATcId { tct_id = id+                           , tct_info    = NotLetBound })+            | (name,id) <- names_w_ids]+    thing_inside++tc_extend_local_env :: TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a+tc_extend_local_env top_lvl extra_env thing_inside+-- Precondition: the argument list extra_env has TcTyThings+--               that ATcId or ATyVar, but nothing else+--+-- Invariant: the ATcIds are fully zonked. Reasons:+--      (a) The kinds of the forall'd type variables are defaulted+--          (see Kind.defaultKind, done in zonkQuantifiedTyVar)+--      (b) There are no via-Indirect occurrences of the bound variables+--          in the types, because instantiation does not look through such things+--      (c) The call to tyCoVarsOfTypes is ok without looking through refs++-- The second argument of type TyVarSet is a set of type variables+-- that are bound together with extra_env and should not be regarded+-- as free in the types of extra_env.+  = do  { traceTc "env2" (ppr extra_env)+        ; env0 <- getLclEnv+        ; env1 <- tcExtendLocalTypeEnv env0 extra_env+        ; stage <- getStage+        ; let env2 = extend_local_env (top_lvl, thLevel stage) extra_env env1+        ; setLclEnv env2 thing_inside }+  where+    extend_local_env :: (TopLevelFlag, ThLevel) -> [(Name, TcTyThing)] -> TcLclEnv -> TcLclEnv+    -- Extend the local LocalRdrEnv and Template Haskell staging env simultaneously+    -- Reason for extending LocalRdrEnv: after running a TH splice we need+    -- to do renaming.+    extend_local_env thlvl pairs env@(TcLclEnv { tcl_rdr = rdr_env+                                               , tcl_th_bndrs = th_bndrs })+      = env { tcl_rdr      = extendLocalRdrEnvList rdr_env+                                [ n | (n, _) <- pairs, isInternalName n ]+                                -- The LocalRdrEnv contains only non-top-level names+                                -- (GlobalRdrEnv handles the top level)+            , tcl_th_bndrs = extendNameEnvList th_bndrs  -- We only track Ids in tcl_th_bndrs+                                 [(n, thlvl) | (n, ATcId {}) <- pairs] }++tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcM TcLclEnv+tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things+  | isEmptyVarSet extra_tvs+  = return (lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things })+  | otherwise+  = do { global_tvs <- readMutVar (tcl_tyvars lcl_env)+       ; new_g_var  <- newMutVar (global_tvs `unionVarSet` extra_tvs)+       ; return (lcl_env { tcl_tyvars = new_g_var+                         , tcl_env = extendNameEnvList lcl_type_env tc_ty_things } ) }+  where+    extra_tvs = foldr get_tvs emptyVarSet tc_ty_things++    get_tvs (_, ATcId { tct_id = id, tct_info = closed }) tvs+      = case closed of+          ClosedLet ->+            ASSERT2( isEmptyVarSet id_tvs, ppr id $$ ppr (idType id) ) tvs+          _           ->+            tvs `unionVarSet` id_tvs+        where id_tvs = tyCoVarsOfType (idType id)++    get_tvs (_, ATyVar _ tv) tvs          -- See Note [Global TyVars]+      = tvs `unionVarSet` tyCoVarsOfType (tyVarKind tv) `extendVarSet` tv++    get_tvs (_, ATcTyCon tc) tvs = tvs `unionVarSet` tyCoVarsOfType (tyConKind tc)++    get_tvs (_, AGlobal {})       tvs = tvs+    get_tvs (_, APromotionErr {}) tvs = tvs++        -- Note [Global TyVars]+        -- It's important to add the in-scope tyvars to the global tyvar set+        -- as well.  Consider+        --      f (_::r) = let g y = y::r in ...+        -- Here, g mustn't be generalised.  This is also important during+        -- class and instance decls, when we mustn't generalise the class tyvars+        -- when typechecking the methods.+        --+        -- Nor must we generalise g over any kind variables free in r's kind++-------------------------------------------------------------+-- Extending the TcIdBinderStack, used only for error messages++tcExtendIdBndrs :: [TcIdBinder] -> TcM a -> TcM a+tcExtendIdBndrs bndrs thing_inside+  = do { traceTc "tcExtendIdBndrs" (ppr bndrs)+       ; updLclEnv (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env })+                   thing_inside }+++{- *********************************************************************+*                                                                      *+             Adding placeholders+*                                                                      *+********************************************************************* -}++tcAddDataFamConPlaceholders :: [LInstDecl Name] -> TcM a -> TcM a+-- See Note [AFamDataCon: not promoting data family constructors]+tcAddDataFamConPlaceholders inst_decls thing_inside+  = tcExtendKindEnvList [ (con, APromotionErr FamDataConPE)+                        | lid <- inst_decls, con <- get_cons lid ]+      thing_inside+      -- Note [AFamDataCon: not promoting data family constructors]+  where+    -- get_cons extracts the *constructor* bindings of the declaration+    get_cons :: LInstDecl Name -> [Name]+    get_cons (L _ (TyFamInstD {}))                     = []+    get_cons (L _ (DataFamInstD { dfid_inst = fid }))  = get_fi_cons fid+    get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } }))+      = concatMap (get_fi_cons . unLoc) fids++    get_fi_cons :: DataFamInstDecl Name -> [Name]+    get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } })+      = map unLoc $ concatMap (getConNames . unLoc) cons+++tcAddPatSynPlaceholders :: [PatSynBind Name Name] -> TcM a -> TcM a+-- See Note [Don't promote pattern synonyms]+tcAddPatSynPlaceholders pat_syns thing_inside+  = tcExtendKindEnvList [ (name, APromotionErr PatSynPE)+                        | PSB{ psb_id = L _ name } <- pat_syns ]+       thing_inside++getTypeSigNames :: [LSig Name] -> NameSet+-- Get the names that have a user type sig+getTypeSigNames sigs+  = foldr get_type_sig emptyNameSet sigs+  where+    get_type_sig :: LSig Name -> NameSet -> NameSet+    get_type_sig sig ns =+      case sig of+        L _ (TypeSig names _) -> extendNameSetList ns (map unLoc names)+        L _ (PatSynSig names _) -> extendNameSetList ns (map unLoc names)+        _ -> ns+++{- Note [AFamDataCon: not promoting data family constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  data family T a+  data instance T Int = MkT+  data Proxy (a :: k)+  data S = MkS (Proxy 'MkT)++Is it ok to use the promoted data family instance constructor 'MkT' in+the data declaration for S (where both declarations live in the same module)?+No, we don't allow this. It *might* make sense, but at least it would mean that+we'd have to interleave typechecking instances and data types, whereas at+present we do data types *then* instances.++So to check for this we put in the TcLclEnv a binding for all the family+constructors, bound to AFamDataCon, so that if we trip over 'MkT' when+type checking 'S' we'll produce a decent error message.++Trac #12088 describes this limitation. Of course, when MkT and S live in+different modules then all is well.++Note [Don't promote pattern synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We never promote pattern synonyms.++Consider this (Trac #11265):+  pattern A = True+  instance Eq A+We want a civilised error message from the occurrence of 'A'+in the instance, yet 'A' really has not yet been type checked.++Similarly (Trac #9161)+  {-# LANGUAGE PatternSynonyms, DataKinds #-}+  pattern A = ()+  b :: A+  b = undefined+Here, the type signature for b mentions A.  But A is a pattern+synonym, which is typechecked as part of a group of bindings (for very+good reasons; a view pattern in the RHS may mention a value binding).+It is entirely reasonable to reject this, but to do so we need A to be+in the kind environment when kind-checking the signature for B.++Hence tcAddPatSynPlaceholers adds a binding+    A -> APromotionErr PatSynPE+to the environment. Then TcHsType.tcTyVar will find A in the kind+environment, and will give a 'wrongThingErr' as a result.  But the+lookup of A won't fail.+++************************************************************************+*                                                                      *+\subsection{Rules}+*                                                                      *+************************************************************************+-}++tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a+        -- Just pop the new rules into the EPS and envt resp+        -- All the rules come from an interface file, not source+        -- Nevertheless, some may be for this module, if we read+        -- its interface instead of its source code+tcExtendRules lcl_rules thing_inside+ = do { env <- getGblEnv+      ; let+          env' = env { tcg_rules = lcl_rules ++ tcg_rules env }+      ; setGblEnv env' thing_inside }++{-+************************************************************************+*                                                                      *+                Meta level+*                                                                      *+************************************************************************+-}++checkWellStaged :: SDoc         -- What the stage check is for+                -> ThLevel      -- Binding level (increases inside brackets)+                -> ThLevel      -- Use stage+                -> TcM ()       -- Fail if badly staged, adding an error+checkWellStaged pp_thing bind_lvl use_lvl+  | use_lvl >= bind_lvl         -- OK! Used later than bound+  = return ()                   -- E.g.  \x -> [| $(f x) |]++  | bind_lvl == outerLevel      -- GHC restriction on top level splices+  = stageRestrictionError pp_thing++  | otherwise                   -- Badly staged+  = failWithTc $                -- E.g.  \x -> $(f x)+    text "Stage error:" <+> pp_thing <+>+        hsep   [text "is bound at stage" <+> ppr bind_lvl,+                text "but used at stage" <+> ppr use_lvl]++stageRestrictionError :: SDoc -> TcM a+stageRestrictionError pp_thing+  = failWithTc $+    sep [ text "GHC stage restriction:"+        , nest 2 (vcat [ pp_thing <+> text "is used in a top-level splice, quasi-quote, or annotation,"+                       , text "and must be imported, not defined locally"])]++topIdLvl :: Id -> ThLevel+-- Globals may either be imported, or may be from an earlier "chunk"+-- (separated by declaration splices) of this module.  The former+--  *can* be used inside a top-level splice, but the latter cannot.+-- Hence we give the former impLevel, but the latter topLevel+-- E.g. this is bad:+--      x = [| foo |]+--      $( f x )+-- By the time we are prcessing the $(f x), the binding for "x"+-- will be in the global env, not the local one.+topIdLvl id | isLocalId id = outerLevel+            | otherwise    = impLevel++tcMetaTy :: Name -> TcM Type+-- Given the name of a Template Haskell data type,+-- return the type+-- E.g. given the name "Expr" return the type "Expr"+tcMetaTy tc_name = do+    t <- tcLookupTyCon tc_name+    return (mkTyConApp t [])++isBrackStage :: ThStage -> Bool+isBrackStage (Brack {}) = True+isBrackStage _other     = False++{-+************************************************************************+*                                                                      *+                 getDefaultTys+*                                                                      *+************************************************************************+-}++tcGetDefaultTys :: TcM ([Type], -- Default types+                        (Bool,  -- True <=> Use overloaded strings+                         Bool)) -- True <=> Use extended defaulting rules+tcGetDefaultTys+  = do  { dflags <- getDynFlags+        ; let ovl_strings = xopt LangExt.OverloadedStrings dflags+              extended_defaults = xopt LangExt.ExtendedDefaultRules dflags+                                        -- See also Trac #1974+              flags = (ovl_strings, extended_defaults)++        ; mb_defaults <- getDeclaredDefaultTys+        ; case mb_defaults of {+           Just tys -> return (tys, flags) ;+                                -- User-supplied defaults+           Nothing  -> do++        -- No use-supplied default+        -- Use [Integer, Double], plus modifications+        { integer_ty <- tcMetaTy integerTyConName+        ; list_ty <- tcMetaTy listTyConName+        ; checkWiredInTyCon doubleTyCon+        ; let deflt_tys = opt_deflt extended_defaults [unitTy, list_ty]+                          -- Note [Extended defaults]+                          ++ [integer_ty, doubleTy]+                          ++ opt_deflt ovl_strings [stringTy]+        ; return (deflt_tys, flags) } } }+  where+    opt_deflt True  xs = xs+    opt_deflt False _  = []++{-+Note [Extended defaults]+~~~~~~~~~~~~~~~~~~~~~+In interative mode (or with -XExtendedDefaultRules) we add () as the first type we+try when defaulting.  This has very little real impact, except in the following case.+Consider:+        Text.Printf.printf "hello"+This has type (forall a. IO a); it prints "hello", and returns 'undefined'.  We don't+want the GHCi repl loop to try to print that 'undefined'.  The neatest thing is to+default the 'a' to (), rather than to Integer (which is what would otherwise happen;+and then GHCi doesn't attempt to print the ().  So in interactive mode, we add+() to the list of defaulting types.  See Trac #1200.++Additonally, the list type [] is added as a default specialization for+Traversable and Foldable. As such the default default list now has types of+varying kinds, e.g. ([] :: * -> *)  and (Integer :: *).++************************************************************************+*                                                                      *+\subsection{The InstInfo type}+*                                                                      *+************************************************************************++The InstInfo type summarises the information in an instance declaration++    instance c => k (t tvs) where b++It is used just for *local* instance decls (not ones from interface files).+But local instance decls includes+        - derived ones+        - generic ones+as well as explicit user written ones.+-}++data InstInfo a+  = InstInfo+      { iSpec   :: ClsInst          -- Includes the dfun id+      , iBinds  :: InstBindings a+      }++iDFunId :: InstInfo a -> DFunId+iDFunId info = instanceDFunId (iSpec info)++data InstBindings a+  = InstBindings+      { ib_tyvars  :: [Name]   -- Names of the tyvars from the instance head+                               -- that are lexically in scope in the bindings+                               -- Must correspond 1-1 with the forall'd tyvars+                               -- of the dfun Id.  When typechecking, we are+                               -- going to extend the typechecker's envt with+                               --     ib_tyvars -> dfun_forall_tyvars++      , ib_binds   :: LHsBinds a    -- Bindings for the instance methods++      , ib_pragmas :: [LSig a]      -- User pragmas recorded for generating+                                    -- specialised instances++      , ib_extensions :: [LangExt.Extension] -- Any extra extensions that should+                                             -- be enabled when type-checking+                                             -- this instance; needed for+                                             -- GeneralizedNewtypeDeriving++      , ib_derived :: Bool+           -- True <=> This code was generated by GHC from a deriving clause+           --          or standalone deriving declaration+           --          Used only to improve error messages+      }++instance (OutputableBndrId a) => Outputable (InstInfo a) where+    ppr = pprInstInfoDetails++pprInstInfoDetails :: (OutputableBndrId a) => InstInfo a -> SDoc+pprInstInfoDetails info+   = hang (pprInstanceHdr (iSpec info) <+> text "where")+        2 (details (iBinds info))+  where+    details (InstBindings { ib_binds = b }) = pprLHsBinds b++simpleInstInfoClsTy :: InstInfo a -> (Class, Type)+simpleInstInfoClsTy info = case instanceHead (iSpec info) of+                           (_, cls, [ty]) -> (cls, ty)+                           _ -> panic "simpleInstInfoClsTy"++simpleInstInfoTy :: InstInfo a -> Type+simpleInstInfoTy info = snd (simpleInstInfoClsTy info)++simpleInstInfoTyCon :: InstInfo a -> TyCon+  -- Gets the type constructor for a simple instance declaration,+  -- i.e. one of the form       instance (...) => C (T a b c) where ...+simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)++-- | Make a name for the dict fun for an instance decl.  It's an *external*+-- name, like other top-level names, and hence must be made with+-- newGlobalBinder.+newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name+newDFunName clas tys loc+  = do  { is_boot <- tcIsHsBootOrSig+        ; mod     <- getModule+        ; let info_string = occNameString (getOccName clas) +++                            concatMap (occNameString.getDFunTyKey) tys+        ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot)+        ; newGlobalBinder mod dfun_occ loc }++-- | Special case of 'newDFunName' to generate dict fun name for a single TyCon.+newDFunName' :: Class -> TyCon -> TcM Name+newDFunName' clas tycon        -- Just a simple wrapper+  = do { loc <- getSrcSpanM     -- The location of the instance decl,+                                -- not of the tycon+       ; newDFunName clas [mkTyConApp tycon []] loc }+       -- The type passed to newDFunName is only used to generate+       -- a suitable string; hence the empty type arg list++{-+Make a name for the representation tycon of a family instance.  It's an+*external* name, like other top-level names, and hence must be made with+newGlobalBinder.+-}++newFamInstTyConName :: Located Name -> [Type] -> TcM Name+newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys]++newFamInstAxiomName :: Located Name -> [[Type]] -> TcM Name+newFamInstAxiomName (L loc name) branches+  = mk_fam_inst_name mkInstTyCoOcc loc name branches++mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name+mk_fam_inst_name adaptOcc loc tc_name tyss+  = do  { mod   <- getModule+        ; let info_string = occNameString (getOccName tc_name) +++                            intercalate "|" ty_strings+        ; occ   <- chooseUniqueOccTc (mkInstTyTcOcc info_string)+        ; newGlobalBinder mod (adaptOcc occ) loc }+  where+    ty_strings = map (concatMap (occNameString . getDFunTyKey)) tyss++{-+Stable names used for foreign exports and annotations.+For stable names, the name must be unique (see #1533).  If the+same thing has several stable Ids based on it, the+top-level bindings generated must not have the same name.+Hence we create an External name (doesn't change), and we+append a Unique to the string right here.+-}++mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId+mkStableIdFromString str sig_ty loc occ_wrapper = do+    uniq <- newUnique+    mod <- getModule+    name <- mkWrapperName "stable" str+    let occ = mkVarOccFS name :: OccName+        gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name+        id  = mkExportedVanillaId gnm sig_ty :: Id+    return id++mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId+mkStableIdFromName nm = mkStableIdFromString (getOccString nm)++mkWrapperName :: (MonadIO m, HasDynFlags m, HasModule m)+              => String -> String -> m FastString+mkWrapperName what nameBase+    = do dflags <- getDynFlags+         thisMod <- getModule+         let -- Note [Generating fresh names for ccall wrapper]+             wrapperRef = nextWrapperNum dflags+             pkg = unitIdString  (moduleUnitId thisMod)+             mod = moduleNameString (moduleName      thisMod)+         wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env ->+             let num = lookupWithDefaultModuleEnv mod_env 0 thisMod+                 mod_env' = extendModuleEnv mod_env thisMod (num+1)+             in (mod_env', num)+         let components = [what, show wrapperNum, pkg, mod, nameBase]+         return $ mkFastString $ zEncodeString $ intercalate ":" components++{-+Note [Generating fresh names for FFI wrappers]++We used to use a unique, rather than nextWrapperNum, to distinguish+between FFI wrapper functions. However, the wrapper names that we+generate are external names. This means that if a call to them ends up+in an unfolding, then we can't alpha-rename them, and thus if the+unique randomly changes from one compile to another then we get a+spurious ABI change (#4012).++The wrapper counter has to be per-module, not global, so that the number we end+up using is not dependent on the modules compiled before the current one.+-}++{-+************************************************************************+*                                                                      *+\subsection{Errors}+*                                                                      *+************************************************************************+-}++pprBinders :: [Name] -> SDoc+-- Used in error messages+-- Use quotes for a single one; they look a bit "busy" for several+pprBinders [bndr] = quotes (ppr bndr)+pprBinders bndrs  = pprWithCommas ppr bndrs++notFound :: Name -> TcM TyThing+notFound name+  = do { lcl_env <- getLclEnv+       ; let stage = tcl_th_ctxt lcl_env+       ; case stage of   -- See Note [Out of scope might be a staging error]+           Splice {}+             | isUnboundName name -> failM  -- If the name really isn't in scope+                                            -- don't report it again (Trac #11941)+             | otherwise -> stageRestrictionError (quotes (ppr name))+           _ -> failWithTc $+                vcat[text "GHC internal error:" <+> quotes (ppr name) <+>+                     text "is not in scope during type checking, but it passed the renamer",+                     text "tcl_env of environment:" <+> ppr (tcl_env lcl_env)]+                       -- Take care: printing the whole gbl env can+                       -- cause an infinite loop, in the case where we+                       -- are in the middle of a recursive TyCon/Class group;+                       -- so let's just not print it!  Getting a loop here is+                       -- very unhelpful, because it hides one compiler bug with another+       }++wrongThingErr :: String -> TcTyThing -> Name -> TcM a+-- It's important that this only calls pprTcTyThingCategory, which in+-- turn does not look at the details of the TcTyThing.+-- See Note [Placeholder PatSyn kinds] in TcBinds+wrongThingErr expected thing name+  = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>+                text "used as a" <+> text expected)++{- Note [Out of scope might be a staging error]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  x = 3+  data T = MkT $(foo x)++where 'foo' is imported from somewhere.++This is really a staging error, because we can't run code involving 'x'.+But in fact the type checker processes types first, so 'x' won't even be+in the type envt when we look for it in $(foo x).  So inside splices we+report something missing from the type env as a staging error.+See Trac #5752 and #5795.+-}
+ typecheck/TcEnv.hs-boot view
@@ -0,0 +1,6 @@+{-+>module TcEnv where+>import TcRnTypes+>+>tcExtendIdEnv :: [TcId] -> TcM a -> TcM a+-}
+ typecheck/TcErrors.hs view
@@ -0,0 +1,2843 @@+{-# LANGUAGE CPP, ScopedTypeVariables #-}++module TcErrors(+       reportUnsolved, reportAllUnsolved, warnAllUnsolved,+       warnDefaulting,++       solverDepthErrorTcS+  ) where++#include "HsVersions.h"++import TcRnTypes+import TcRnMonad+import TcMType+import TcUnify( occCheckForErrors, OccCheckResult(..) )+import TcType+import RnEnv( unknownNameSuggestions )+import Type+import TyCoRep+import Kind+import Unify            ( tcMatchTys )+import Module+import FamInst+import FamInstEnv       ( flattenTys )+import Inst+import InstEnv+import TyCon+import Class+import DataCon+import TcEvidence+import HsExpr  ( UnboundVar(..) )+import HsBinds ( PatSynBind(..) )+import Name+import RdrName ( lookupGlobalRdrEnv, lookupGRE_Name, GlobalRdrEnv+               , mkRdrUnqual, isLocalGRE, greSrcSpan )+import PrelNames ( typeableClassName, hasKey, liftedRepDataConKey )+import Id+import Var+import VarSet+import VarEnv+import NameSet+import Bag+import ErrUtils         ( ErrMsg, errDoc, pprLocErrMsg )+import BasicTypes+import ConLike          ( ConLike(..) )+import Util+import FastString+import Outputable+import SrcLoc+import DynFlags+import ListSetOps       ( equivClasses )+import Maybes+import qualified GHC.LanguageExtensions as LangExt+import FV ( fvVarList, unionFV )++import Control.Monad    ( when )+import Data.List        ( partition, mapAccumL, nub, sortBy, unfoldr )+import qualified Data.Set as Set++#if __GLASGOW_HASKELL__ > 710+import Data.Semigroup   ( Semigroup )+import qualified Data.Semigroup as Semigroup+#endif+++{-+************************************************************************+*                                                                      *+\section{Errors and contexts}+*                                                                      *+************************************************************************++ToDo: for these error messages, should we note the location as coming+from the insts, or just whatever seems to be around in the monad just+now?++Note [Deferring coercion errors to runtime]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+While developing, sometimes it is desirable to allow compilation to succeed even+if there are type errors in the code. Consider the following case:++  module Main where++  a :: Int+  a = 'a'++  main = print "b"++Even though `a` is ill-typed, it is not used in the end, so if all that we're+interested in is `main` it is handy to be able to ignore the problems in `a`.++Since we treat type equalities as evidence, this is relatively simple. Whenever+we run into a type mismatch in TcUnify, we normally just emit an error. But it+is always safe to defer the mismatch to the main constraint solver. If we do+that, `a` will get transformed into++  co :: Int ~ Char+  co = ...++  a :: Int+  a = 'a' `cast` co++The constraint solver would realize that `co` is an insoluble constraint, and+emit an error with `reportUnsolved`. But we can also replace the right-hand side+of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program+to compile, and it will run fine unless we evaluate `a`. This is what+`deferErrorsToRuntime` does.++It does this by keeping track of which errors correspond to which coercion+in TcErrors. TcErrors.reportTidyWanteds does not print the errors+and does not fail if -fdefer-type-errors is on, so that we can continue+compilation. The errors are turned into warnings in `reportUnsolved`.+-}++-- | Report unsolved goals as errors or warnings. We may also turn some into+-- deferred run-time errors if `-fdefer-type-errors` is on.+reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)+reportUnsolved wanted+  = do { binds_var <- newTcEvBinds+       ; defer_errors <- goptM Opt_DeferTypeErrors+       ; warn_errors <- woptM Opt_WarnDeferredTypeErrors -- implement #10283+       ; let type_errors | not defer_errors = TypeError+                         | warn_errors      = TypeWarn+                         | otherwise        = TypeDefer++       ; defer_holes <- goptM Opt_DeferTypedHoles+       ; warn_holes  <- woptM Opt_WarnTypedHoles+       ; let expr_holes | not defer_holes = HoleError+                        | warn_holes      = HoleWarn+                        | otherwise       = HoleDefer++       ; partial_sigs      <- xoptM LangExt.PartialTypeSignatures+       ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures+       ; let type_holes | not partial_sigs  = HoleError+                        | warn_partial_sigs = HoleWarn+                        | otherwise         = HoleDefer++       ; defer_out_of_scope <- goptM Opt_DeferOutOfScopeVariables+       ; warn_out_of_scope <- woptM Opt_WarnDeferredOutOfScopeVariables+       ; let out_of_scope_holes | not defer_out_of_scope = HoleError+                                | warn_out_of_scope      = HoleWarn+                                | otherwise              = HoleDefer++       ; report_unsolved binds_var False type_errors expr_holes+          type_holes out_of_scope_holes wanted++       ; ev_binds <- getTcEvBindsMap binds_var+       ; return (evBindMapBinds ev_binds)}++-- | Report *all* unsolved goals as errors, even if -fdefer-type-errors is on+-- However, do not make any evidence bindings, because we don't+-- have any convenient place to put them.+-- See Note [Deferring coercion errors to runtime]+-- Used by solveEqualities for kind equalities+--      (see Note [Fail fast on kind errors] in TcSimplify]+-- and for simplifyDefault.+reportAllUnsolved :: WantedConstraints -> TcM ()+reportAllUnsolved wanted+  = do { ev_binds <- newTcEvBinds+       ; report_unsolved ev_binds False TypeError+                         HoleError HoleError HoleError wanted }++-- | Report all unsolved goals as warnings (but without deferring any errors to+-- run-time). See Note [Safe Haskell Overlapping Instances Implementation] in+-- TcSimplify+warnAllUnsolved :: WantedConstraints -> TcM ()+warnAllUnsolved wanted+  = do { ev_binds <- newTcEvBinds+       ; report_unsolved ev_binds True TypeWarn+                         HoleWarn HoleWarn HoleWarn wanted }++-- | Report unsolved goals as errors or warnings.+report_unsolved :: EvBindsVar        -- cec_binds+                -> Bool              -- Errors as warnings+                -> TypeErrorChoice   -- Deferred type errors+                -> HoleChoice        -- Expression holes+                -> HoleChoice        -- Type holes+                -> HoleChoice        -- Out of scope holes+                -> WantedConstraints -> TcM ()+report_unsolved mb_binds_var err_as_warn type_errors expr_holes+    type_holes out_of_scope_holes wanted+  | isEmptyWC wanted+  = return ()+  | otherwise+  = do { traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted)++       ; wanted <- zonkWC wanted   -- Zonk to reveal all information+       ; env0 <- tcInitTidyEnv+            -- If we are deferring we are going to need /all/ evidence around,+            -- including the evidence produced by unflattening (zonkWC)+       ; let tidy_env = tidyFreeTyCoVars env0 free_tvs+             free_tvs = tyCoVarsOfWCList wanted++       ; traceTc "reportUnsolved (after zonking):" $+         vcat [ text "Free tyvars:" <+> pprTyVars free_tvs+              , text "Wanted:" <+> ppr wanted ]++       ; warn_redundant <- woptM Opt_WarnRedundantConstraints+       ; let err_ctxt = CEC { cec_encl  = []+                            , cec_tidy  = tidy_env+                            , cec_defer_type_errors = type_errors+                            , cec_errors_as_warns = err_as_warn+                            , cec_expr_holes = expr_holes+                            , cec_type_holes = type_holes+                            , cec_out_of_scope_holes = out_of_scope_holes+                            , cec_suppress = False -- See Note [Suppressing error messages]+                            , cec_warn_redundant = warn_redundant+                            , cec_binds    = mb_binds_var }++       ; tc_lvl <- getTcLevel+       ; reportWanteds err_ctxt tc_lvl wanted }++--------------------------------------------+--      Internal functions+--------------------------------------------++-- | An error Report collects messages categorised by their importance.+-- See Note [Error report] for details.+data Report+  = Report { report_important :: [SDoc]+           , report_relevant_bindings :: [SDoc]+           }++instance Outputable Report where   -- Debugging only+  ppr (Report { report_important = imp, report_relevant_bindings = rel })+    = vcat [ text "important:" <+> vcat imp+           , text "relevant:"  <+> vcat rel ]++{- Note [Error report]+The idea is that error msgs are divided into three parts: the main msg, the+context block (\"In the second argument of ...\"), and the relevant bindings+block, which are displayed in that order, with a mark to divide them.  The+idea is that the main msg ('report_important') varies depending on the error+in question, but context and relevant bindings are always the same, which+should simplify visual parsing.++The context is added when the the Report is passed off to 'mkErrorReport'.+Unfortunately, unlike the context, the relevant bindings are added in+multiple places so they have to be in the Report.+-}++#if __GLASGOW_HASKELL__ > 710+instance Semigroup Report where+    Report a1 b1 <> Report a2 b2 = Report (a1 ++ a2) (b1 ++ b2)+#endif++instance Monoid Report where+    mempty = Report [] []+    mappend (Report a1 b1) (Report a2 b2) = Report (a1 ++ a2) (b1 ++ b2)++-- | Put a doc into the important msgs block.+important :: SDoc -> Report+important doc = mempty { report_important = [doc] }++-- | Put a doc into the relevant bindings block.+relevant_bindings :: SDoc -> Report+relevant_bindings doc = mempty { report_relevant_bindings = [doc] }++data TypeErrorChoice   -- What to do for type errors found by the type checker+  = TypeError     -- A type error aborts compilation with an error message+  | TypeWarn      -- A type error is deferred to runtime, plus a compile-time warning+  | TypeDefer     -- A type error is deferred to runtime; no error or warning at compile time++data HoleChoice+  = HoleError     -- A hole is a compile-time error+  | HoleWarn      -- Defer to runtime, emit a compile-time warning+  | HoleDefer     -- Defer to runtime, no warning++instance Outputable HoleChoice where+  ppr HoleError = text "HoleError"+  ppr HoleWarn  = text "HoleWarn"+  ppr HoleDefer = text "HoleDefer"++instance Outputable TypeErrorChoice  where+  ppr TypeError = text "TypeError"+  ppr TypeWarn  = text "TypeWarn"+  ppr TypeDefer = text "TypeDefer"++data ReportErrCtxt+    = CEC { cec_encl :: [Implication]  -- Enclosing implications+                                       --   (innermost first)+                                       -- ic_skols and givens are tidied, rest are not+          , cec_tidy  :: TidyEnv++          , cec_binds :: EvBindsVar    -- Make some errors (depending on cec_defer)+                                       -- into warnings, and emit evidence bindings+                                       -- into 'cec_binds' for unsolved constraints++          , cec_errors_as_warns :: Bool   -- Turn all errors into warnings+                                          -- (except for Holes, which are+                                          -- controlled by cec_type_holes and+                                          -- cec_expr_holes)+          , cec_defer_type_errors :: TypeErrorChoice -- Defer type errors until runtime++          -- cec_expr_holes is a union of:+          --   cec_type_holes - a set of typed holes: '_', '_a', '_foo'+          --   cec_out_of_scope_holes - a set of variables which are+          --                            out of scope: 'x', 'y', 'bar'+          , cec_expr_holes :: HoleChoice           -- Holes in expressions+          , cec_type_holes :: HoleChoice           -- Holes in types+          , cec_out_of_scope_holes :: HoleChoice   -- Out of scope holes++          , cec_warn_redundant :: Bool    -- True <=> -Wredundant-constraints++          , cec_suppress :: Bool    -- True <=> More important errors have occurred,+                                    --          so create bindings if need be, but+                                    --          don't issue any more errors/warnings+                                    -- See Note [Suppressing error messages]+      }++instance Outputable ReportErrCtxt where+  ppr (CEC { cec_binds              = bvar+           , cec_errors_as_warns    = ew+           , cec_defer_type_errors  = dte+           , cec_expr_holes         = eh+           , cec_type_holes         = th+           , cec_out_of_scope_holes = osh+           , cec_warn_redundant     = wr+           , cec_suppress           = sup })+    = text "CEC" <+> braces (vcat+         [ text "cec_binds"              <+> equals <+> ppr bvar+         , text "cec_errors_as_warns"    <+> equals <+> ppr ew+         , text "cec_defer_type_errors"  <+> equals <+> ppr dte+         , text "cec_expr_holes"         <+> equals <+> ppr eh+         , text "cec_type_holes"         <+> equals <+> ppr th+         , text "cec_out_of_scope_holes" <+> equals <+> ppr osh+         , text "cec_warn_redundant"     <+> equals <+> ppr wr+         , text "cec_suppress"           <+> equals <+> ppr sup ])++{-+Note [Suppressing error messages]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The cec_suppress flag says "don't report any errors".  Instead, just create+evidence bindings (as usual).  It's used when more important errors have occurred.++Specifically (see reportWanteds)+  * If there are insoluble Givens, then we are in unreachable code and all bets+    are off.  So don't report any further errors.+  * If there are any insolubles (eg Int~Bool), here or in a nested implication,+    then suppress errors from the simple constraints here.  Sometimes the+    simple-constraint errors are a knock-on effect of the insolubles.+-}++reportImplic :: ReportErrCtxt -> Implication -> TcM ()+reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given+                                 , ic_wanted = wanted, ic_binds = evb+                                 , ic_status = status, ic_info = info+                                 , ic_env = tcl_env, ic_tclvl = tc_lvl })+  | BracketSkol <- info+  , not insoluble+  = return ()        -- For Template Haskell brackets report only+                     -- definite errors. The whole thing will be re-checked+                     -- later when we plug it in, and meanwhile there may+                     -- certainly be un-satisfied constraints++  | otherwise+  = do { traceTc "reportImplic" (ppr implic')+       ; reportWanteds ctxt' tc_lvl wanted+       ; when (cec_warn_redundant ctxt) $+         warnRedundantConstraints ctxt' tcl_env info' dead_givens }+  where+    insoluble    = isInsolubleStatus status+    (env1, tvs') = mapAccumL tidyTyCoVarBndr (cec_tidy ctxt) tvs+    info'        = tidySkolemInfo env1 info+    implic' = implic { ic_skols = tvs'+                     , ic_given = map (tidyEvVar env1) given+                     , ic_info  = info' }+    ctxt' = ctxt { cec_tidy     = env1+                 , cec_encl     = implic' : cec_encl ctxt++                 , cec_suppress = insoluble || cec_suppress ctxt+                      -- Suppress inessential errors if there+                      -- are are insolubles anywhere in the+                      -- tree rooted here, or we've come across+                      -- a suppress-worthy constraint higher up (Trac #11541)++                 , cec_binds    = evb }++    dead_givens = case status of+                    IC_Solved { ics_dead = dead } -> dead+                    _                             -> []++warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [EvVar] -> TcM ()+-- See Note [Tracking redundant constraints] in TcSimplify+warnRedundantConstraints ctxt env info ev_vars+ | null redundant_evs+ = return ()++ | SigSkol {} <- info+ = setLclEnv env $  -- We want to add "In the type signature for f"+                    -- to the error context, which is a bit tiresome+   addErrCtxt (text "In" <+> ppr info) $+   do { env <- getLclEnv+      ; msg <- mkErrorReport ctxt env (important doc)+      ; reportWarning (Reason Opt_WarnRedundantConstraints) msg }++ | otherwise  -- But for InstSkol there already *is* a surrounding+              -- "In the instance declaration for Eq [a]" context+              -- and we don't want to say it twice. Seems a bit ad-hoc+ = do { msg <- mkErrorReport ctxt env (important doc)+      ; reportWarning (Reason Opt_WarnRedundantConstraints) msg }+ where+   doc = text "Redundant constraint" <> plural redundant_evs <> colon+         <+> pprEvVarTheta redundant_evs++   redundant_evs = case info of -- See Note [Redundant constraints in instance decls]+                     InstSkol -> filterOut improving ev_vars+                     _        -> ev_vars++   improving ev_var = any isImprovementPred $+                      transSuperClasses (idType ev_var)++{- Note [Redundant constraints in instance decls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For instance declarations, we don't report unused givens if+they can give rise to improvement.  Example (Trac #10100):+    class Add a b ab | a b -> ab, a ab -> b+    instance Add Zero b b+    instance Add a b ab => Add (Succ a) b (Succ ab)+The context (Add a b ab) for the instance is clearly unused in terms+of evidence, since the dictionary has no feilds.  But it is still+needed!  With the context, a wanted constraint+   Add (Succ Zero) beta (Succ Zero)+we will reduce to (Add Zero beta Zero), and thence we get beta := Zero.+But without the context we won't find beta := Zero.++This only matters in instance declarations..+-}++reportWanteds :: ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM ()+reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_insol = insols, wc_impl = implics })+  = do { traceTc "reportWanteds" (vcat [ text "Simples =" <+> ppr simples+                                       , text "Insols =" <+> ppr insols+                                       , text "Suppress =" <+> ppr (cec_suppress ctxt)])+       ; let tidy_cts = bagToList (mapBag (tidyCt env) (insols `unionBags` simples))++         -- First deal with things that are utterly wrong+         -- Like Int ~ Bool (incl nullary TyCons)+         -- or  Int ~ t a   (AppTy on one side)+         -- These /ones/ are not suppressed by the incoming context+       ; let ctxt_for_insols = ctxt { cec_suppress = False }+       ; (ctxt1, cts1) <- tryReporters ctxt_for_insols report1 tidy_cts++         -- Now all the other constraints.  We suppress errors here if+         -- any of the first batch failed, or if the enclosing context+         -- says to suppress+       ; let ctxt2 = ctxt { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 }+       ; (_, leftovers) <- tryReporters ctxt2 report2 cts1+       ; MASSERT2( null leftovers, ppr leftovers )++            -- All the Derived ones have been filtered out of simples+            -- by the constraint solver. This is ok; we don't want+            -- to report unsolved Derived goals as errors+            -- See Note [Do not report derived but soluble errors]++     ; mapBagM_ (reportImplic ctxt2) implics }+            -- NB ctxt1: don't suppress inner insolubles if there's only a+            -- wanted insoluble here; but do suppress inner insolubles+            -- if there's a *given* insoluble here (= inaccessible code)+ where+    env = cec_tidy ctxt++    -- report1: ones that should *not* be suppresed by+    --          an insoluble somewhere else in the tree+    -- It's crucial that anything that is considered insoluble+    -- (see TcRnTypes.trulyInsoluble) is caught here, otherwise+    -- we might suppress its error message, and proceed on past+    -- type checking to get a Lint error later+    report1 = [ ("custom_error", is_user_type_error,+                                                  True, mkUserTypeErrorReporter)+              , given_eq_spec+              , ("insoluble2",   utterly_wrong,   True, mkGroupReporter mkEqErr)+              , ("skolem eq1",   very_wrong,      True, mkSkolReporter)+              , ("skolem eq2",   skolem_eq,       True, mkSkolReporter)+              , ("non-tv eq",    non_tv_eq,       True, mkSkolReporter)+              , ("Out of scope", is_out_of_scope, True, mkHoleReporter)+              , ("Holes",        is_hole,         False, mkHoleReporter)++                  -- The only remaining equalities are alpha ~ ty,+                  -- where alpha is untouchable; and representational equalities+              , ("Other eqs",    is_equality,     False, mkGroupReporter mkEqErr) ]++    -- report2: we suppress these if there are insolubles elsewhere in the tree+    report2 = [ ("Implicit params", is_ip,           False, mkGroupReporter mkIPErr)+              , ("Irreds",          is_irred,        False, mkGroupReporter mkIrredErr)+              , ("Dicts",           is_dict,         False, mkGroupReporter mkDictErr) ]++    -- rigid_nom_eq, rigid_nom_tv_eq,+    is_hole, is_dict,+      is_equality, is_ip, is_irred :: Ct -> PredTree -> Bool++    is_given_eq ct pred+       | EqPred {} <- pred = arisesFromGivens ct+       | otherwise         = False+       -- I think all given residuals are equalities++    -- Things like (Int ~N Bool)+    utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2+    utterly_wrong _ _                      = False++    -- Things like (a ~N Int)+    very_wrong _ (EqPred NomEq ty1 ty2) = isSkolemTy tc_lvl ty1 && isRigidTy ty2+    very_wrong _ _                      = False++    -- Things like (a ~N b) or (a  ~N  F Bool)+    skolem_eq _ (EqPred NomEq ty1 _) = isSkolemTy tc_lvl ty1+    skolem_eq _ _                    = False++    -- Things like (F a  ~N  Int)+    non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1)+    non_tv_eq _ _                    = False++    is_out_of_scope ct _ = isOutOfScopeCt ct+    is_hole         ct _ = isHoleCt ct++    is_user_type_error ct _ = isUserTypeErrorCt ct++    is_equality _ (EqPred {}) = True+    is_equality _ _           = False++    is_dict _ (ClassPred {}) = True+    is_dict _ _              = False++    is_ip _ (ClassPred cls _) = isIPClass cls+    is_ip _ _                 = False++    is_irred _ (IrredPred {}) = True+    is_irred _ _              = False++    given_eq_spec = case find_gadt_match (cec_encl ctxt) of+       Just imp -> ("insoluble1a", is_given_eq, True,  mkGivenErrorReporter imp)+       Nothing  -> ("insoluble1b", is_given_eq, False, ignoreErrorReporter)+                  -- False means don't suppress subsequent errors+                  -- Reason: we don't report all given errors+                  --         (see mkGivenErrorReporter), and we should only suppress+                  --         subsequent errors if we actually report this one!+                  --         Trac #13446 is an example++    find_gadt_match [] = Nothing+    find_gadt_match (implic : implics)+      | PatSkol {} <- ic_info implic+      , not (ic_no_eqs implic)+      = Just implic+      | otherwise+      = find_gadt_match implics++---------------+isSkolemTy :: TcLevel -> Type -> Bool+-- The type is a skolem tyvar+isSkolemTy tc_lvl ty+  | Just tv <- getTyVar_maybe ty+  =  isSkolemTyVar tv+  || (isSigTyVar tv && isTouchableMetaTyVar tc_lvl tv)+     -- The last case is for touchable SigTvs+     -- we postpone untouchables to a latter test (too obscure)++  | otherwise+  = False++isTyFun_maybe :: Type -> Maybe TyCon+isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of+                      Just (tc,_) | isTypeFamilyTyCon tc -> Just tc+                      _ -> Nothing++--------------------------------------------+--      Reporters+--------------------------------------------++type Reporter+  = ReportErrCtxt -> [Ct] -> TcM ()+type ReporterSpec+  = ( String                     -- Name+    , Ct -> PredTree -> Bool     -- Pick these ones+    , Bool                       -- True <=> suppress subsequent reporters+    , Reporter)                  -- The reporter itself++mkSkolReporter :: Reporter+-- Suppress duplicates with either the same LHS, or same location+mkSkolReporter ctxt cts+  = mapM_ (reportGroup mkEqErr ctxt) (group cts)+  where+     group [] = []+     group (ct:cts) = (ct : yeses) : group noes+        where+          (yeses, noes) = partition (group_with ct) cts++     group_with ct1 ct2+       | EQ <- cmp_loc ct1 ct2 = True+       | eq_lhs_type   ct1 ct2 = True+       | otherwise             = False++mkHoleReporter :: Reporter+-- Reports errors one at a time+mkHoleReporter ctxt+  = mapM_ $ \ct -> do { err <- mkHoleError ctxt ct+                      ; maybeReportHoleError ctxt ct err+                      ; maybeAddDeferredHoleBinding ctxt err ct }++mkUserTypeErrorReporter :: Reporter+mkUserTypeErrorReporter ctxt+  = mapM_ $ \ct -> do { err <- mkUserTypeError ctxt ct+                      ; maybeReportError ctxt err+                      ; addDeferredBinding ctxt err ct }++mkUserTypeError :: ReportErrCtxt -> Ct -> TcM ErrMsg+mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct+                        $ important+                        $ pprUserTypeErrorTy+                        $ case getUserTypeErrorMsg ct of+                            Just msg -> msg+                            Nothing  -> pprPanic "mkUserTypeError" (ppr ct)+++mkGivenErrorReporter :: Implication -> Reporter+-- See Note [Given errors]+mkGivenErrorReporter implic ctxt cts+  = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct+       ; dflags <- getDynFlags+       ; let ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (ic_env implic))+                   -- For given constraints we overwrite the env (and hence src-loc)+                  -- with one from the implication.  See Note [Inaccessible code]++             inaccessible_msg = hang (text "Inaccessible code in")+                                   2 (ppr (ic_info implic))+             report = important inaccessible_msg `mappend`+                      relevant_bindings binds_msg++       ; err <- mkEqErr_help dflags ctxt report ct'+                             Nothing ty1 ty2++       ; traceTc "mkGivenErrorRporter" (ppr ct)+       ; maybeReportError ctxt err }+  where+    (ct : _ )  = cts    -- Never empty+    (ty1, ty2) = getEqPredTys (ctPred ct)++ignoreErrorReporter :: Reporter+-- Discard Given errors that don't come from+-- a pattern match; maybe we should warn instead?ignoreErrorReporter ctxt cts+ignoreErrorReporter ctxt cts+  = do { traceTc "mkGivenErrorRporter no" (ppr cts $$ ppr (cec_encl ctxt))+       ; return () }+++{- Note [Given errors]+~~~~~~~~~~~~~~~~~~~~~~+Given constraints represent things for which we have (or will have)+evidence, so they aren't errors.  But if a Given constraint is+insoluble, this code is inaccessible, and we might want to at least+warn about that.  A classic case is++   data T a where+     T1 :: T Int+     T2 :: T a+     T3 :: T Bool++   f :: T Int -> Bool+   f T1 = ...+   f T2 = ...+   f T3 = ...  -- We want to report this case as inaccessible++We'd like to point out that the T3 match is inaccessible. It+will have a Given constraint [G] Int ~ Bool.++But we don't want to report ALL insoluble Given constraints.  See Trac+#12466 for a long discussion on.  For example, if we aren't careful+we'll complain about+   f :: ((Int ~ Bool) => a -> a) -> Int+which arguably is OK.  It's more debatable for+   g :: (Int ~ Bool) => Int -> Int+but it's tricky to distinguish these cases to we don't report+either.++The bottom line is this: find_gadt_match looks for an encosing+pattern match which binds some equality constraints.  If we+find one, we report the insoluble Given.+-}++mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)+                             -- Make error message for a group+                -> Reporter  -- Deal with lots of constraints+-- Group together errors from same location,+-- and report only the first (to avoid a cascade)+mkGroupReporter mk_err ctxt cts+  = mapM_ (reportGroup mk_err ctxt) (equivClasses cmp_loc cts)++eq_lhs_type :: Ct -> Ct -> Bool+eq_lhs_type ct1 ct2+  = case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of+       (EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) ->+         (eq_rel1 == eq_rel2) && (ty1 `eqType` ty2)+       _ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2)++cmp_loc :: Ct -> Ct -> Ordering+cmp_loc ct1 ct2 = ctLocSpan (ctLoc ct1) `compare` ctLocSpan (ctLoc ct2)++reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt+            -> [Ct] -> TcM ()+reportGroup mk_err ctxt cts =+  case partition isMonadFailInstanceMissing cts of+        -- Only warn about missing MonadFail constraint when+        -- there are no other missing constraints!+        (monadFailCts, []) ->+            do { err <- mk_err ctxt monadFailCts+               ; reportWarning (Reason Opt_WarnMissingMonadFailInstances) err }++        (_, cts') -> do { err <- mk_err ctxt cts'+                        ; maybeReportError ctxt err+                            -- But see Note [Always warn with -fdefer-type-errors]+                        ; traceTc "reportGroup" (ppr cts')+                        ; mapM_ (addDeferredBinding ctxt err) cts' }+                            -- Add deferred bindings for all+                            -- Redundant if we are going to abort compilation,+                            -- but that's hard to know for sure, and if we don't+                            -- abort, we need bindings for all (e.g. Trac #12156)+  where+    isMonadFailInstanceMissing ct =+        case ctLocOrigin (ctLoc ct) of+            FailablePattern _pat -> True+            _otherwise           -> False++maybeReportHoleError :: ReportErrCtxt -> Ct -> ErrMsg -> TcM ()+maybeReportHoleError ctxt ct err+  -- When -XPartialTypeSignatures is on, warnings (instead of errors) are+  -- generated for holes in partial type signatures.+  -- Unless -fwarn_partial_type_signatures is not on,+  -- in which case the messages are discarded.+  | isTypeHoleCt ct+  = -- For partial type signatures, generate warnings only, and do that+    -- only if -fwarn_partial_type_signatures is on+    case cec_type_holes ctxt of+       HoleError -> reportError err+       HoleWarn  -> reportWarning (Reason Opt_WarnPartialTypeSignatures) err+       HoleDefer -> return ()++  -- Always report an error for out-of-scope variables+  -- Unless -fdefer-out-of-scope-variables is on,+  -- in which case the messages are discarded.+  -- See Trac #12170, #12406+  | isOutOfScopeCt ct+  = -- If deferring, report a warning only if -Wout-of-scope-variables is on+    case cec_out_of_scope_holes ctxt of+      HoleError -> reportError err+      HoleWarn  ->+        reportWarning (Reason Opt_WarnDeferredOutOfScopeVariables) err+      HoleDefer -> return ()++  -- Otherwise this is a typed hole in an expression,+  -- but not for an out-of-scope variable+  | otherwise+  = -- If deferring, report a warning only if -Wtyped-holes is on+    case cec_expr_holes ctxt of+       HoleError -> reportError err+       HoleWarn  -> reportWarning (Reason Opt_WarnTypedHoles) err+       HoleDefer -> return ()++maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM ()+-- Report the error and/or make a deferred binding for it+maybeReportError ctxt err+  | cec_suppress ctxt    -- Some worse error has occurred;+  = return ()            -- so suppress this error/warning++  | cec_errors_as_warns ctxt+  = reportWarning NoReason err++  | otherwise+  = case cec_defer_type_errors ctxt of+      TypeDefer -> return ()+      TypeWarn  -> reportWarning (Reason Opt_WarnDeferredTypeErrors) err+      TypeError -> reportError err++addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()+-- See Note [Deferring coercion errors to runtime]+addDeferredBinding ctxt err ct+  | CtWanted { ctev_pred = pred, ctev_dest = dest } <- ctEvidence ct+    -- Only add deferred bindings for Wanted constraints+  = do { dflags <- getDynFlags+       ; let err_msg = pprLocErrMsg err+             err_fs  = mkFastString $ showSDoc dflags $+                       err_msg $$ text "(deferred type error)"+             err_tm  = EvDelayedError pred err_fs+             ev_binds_var = cec_binds ctxt++       ; case dest of+           EvVarDest evar+             -> addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm+           HoleDest hole+             -> do { -- See Note [Deferred errors for coercion holes]+                     evar <- newEvVar pred+                   ; addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm+                   ; fillCoercionHole hole (mkTcCoVarCo evar) }}++  | otherwise   -- Do not set any evidence for Given/Derived+  = return ()++maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()+maybeAddDeferredHoleBinding ctxt err ct+  | isExprHoleCt ct+  = addDeferredBinding ctxt err ct  -- Only add bindings for holes in expressions+  | otherwise                       -- not for holes in partial type signatures+  = return ()++tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct])+-- Use the first reporter in the list whose predicate says True+tryReporters ctxt reporters cts+  = do { traceTc "tryReporters {" (ppr cts)+       ; (ctxt', cts') <- go ctxt reporters cts+       ; traceTc "tryReporters }" (ppr cts')+       ; return (ctxt', cts') }+  where+    go ctxt [] cts+      = return (ctxt, cts)++    go ctxt (r : rs) cts+      = do { (ctxt', cts') <- tryReporter ctxt r cts+           ; go ctxt' rs cts' }+                -- Carry on with the rest, because we must make+                -- deferred bindings for them if we have -fdefer-type-errors+                -- But suppress their error messages++tryReporter :: ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct])+tryReporter ctxt (str, keep_me,  suppress_after, reporter) cts+  | null yeses = return (ctxt, cts)+  | otherwise  = do { traceTc "tryReporter{ " (text str <+> ppr yeses)+                    ; reporter ctxt yeses+                    ; let ctxt' = ctxt { cec_suppress = suppress_after || cec_suppress ctxt }+                    ; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after)+                    ; return (ctxt', nos) }+  where+    (yeses, nos) = partition (\ct -> keep_me ct (classifyPredType (ctPred ct))) cts+++pprArising :: CtOrigin -> SDoc+-- Used for the main, top-level error message+-- We've done special processing for TypeEq, KindEq, Given+pprArising (TypeEqOrigin {}) = empty+pprArising (KindEqOrigin {}) = empty+pprArising (GivenOrigin {})  = empty+pprArising orig              = pprCtOrigin orig++-- Add the "arising from..." part to a message about bunch of dicts+addArising :: CtOrigin -> SDoc -> SDoc+addArising orig msg = hang msg 2 (pprArising orig)++pprWithArising :: [Ct] -> (CtLoc, SDoc)+-- Print something like+--    (Eq a) arising from a use of x at y+--    (Show a) arising from a use of p at q+-- Also return a location for the error message+-- Works for Wanted/Derived only+pprWithArising []+  = panic "pprWithArising"+pprWithArising (ct:cts)+  | null cts+  = (loc, addArising (ctLocOrigin loc)+                     (pprTheta [ctPred ct]))+  | otherwise+  = (loc, vcat (map ppr_one (ct:cts)))+  where+    loc = ctLoc ct+    ppr_one ct' = hang (parens (pprType (ctPred ct')))+                     2 (pprCtLoc (ctLoc ct'))++mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM ErrMsg+mkErrorMsgFromCt ctxt ct report+  = mkErrorReport ctxt (ctLocEnv (ctLoc ct)) report++mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg+mkErrorReport ctxt tcl_env (Report important relevant_bindings)+  = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)+       ; mkErrDocAt (RealSrcSpan (tcl_loc tcl_env))+            (errDoc important [context] relevant_bindings)+       }++type UserGiven = Implication++getUserGivens :: ReportErrCtxt -> [UserGiven]+-- One item for each enclosing implication+getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics++getUserGivensFromImplics :: [Implication] -> [UserGiven]+getUserGivensFromImplics implics+  = reverse (filterOut (null . ic_given) implics)++{-+Note [Always warn with -fdefer-type-errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When -fdefer-type-errors is on we warn about *all* type errors, even+if cec_suppress is on.  This can lead to a lot more warnings than you+would get errors without -fdefer-type-errors, but if we suppress any of+them you might get a runtime error that wasn't warned about at compile+time.++This is an easy design choice to change; just flip the order of the+first two equations for maybeReportError++To be consistent, we should also report multiple warnings from a single+location in mkGroupReporter, when -fdefer-type-errors is on.  But that+is perhaps a bit *over*-consistent! Again, an easy choice to change.++With #10283, you can now opt out of deferred type error warnings.++Note [Deferred errors for coercion holes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we need to defer a type error where the destination for the evidence+is a coercion hole. We can't just put the error in the hole, because we can't+make an erroneous coercion. (Remember that coercions are erased for runtime.)+Instead, we invent a new EvVar, bind it to an error and then make a coercion+from that EvVar, filling the hole with that coercion. Because coercions'+types are unlifted, the error is guaranteed to be hit before we get to the+coercion.++Note [Do not report derived but soluble errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The wc_simples include Derived constraints that have not been solved, but are+not insoluble (in that case they'd be in wc_insols).  We do not want to report+these as errors:++* Superclass constraints. If we have an unsolved [W] Ord a, we'll also have+  an unsolved [D] Eq a, and we do not want to report that; it's just noise.++* Functional dependencies.  For givens, consider+      class C a b | a -> b+      data T a where+         MkT :: C a d => [d] -> T a+      f :: C a b => T a -> F Int+      f (MkT xs) = length xs+  Then we get a [D] b~d.  But there *is* a legitimate call to+  f, namely   f (MkT [True]) :: T Bool, in which b=d.  So we should+  not reject the program.++  For wanteds, something similar+      data T a where+        MkT :: C Int b => a -> b -> T a+      g :: C Int c => c -> ()+      f :: T a -> ()+      f (MkT x y) = g x+  Here we get [G] C Int b, [W] C Int a, hence [D] a~b.+  But again f (MkT True True) is a legitimate call.++(We leave the Deriveds in wc_simple until reportErrors, so that we don't lose+derived superclasses between iterations of the solver.)++For functional dependencies, here is a real example,+stripped off from libraries/utf8-string/Codec/Binary/UTF8/Generic.hs++  class C a b | a -> b+  g :: C a b => a -> b -> ()+  f :: C a b => a -> b -> ()+  f xa xb =+      let loop = g xa+      in loop xb++We will first try to infer a type for loop, and we will succeed:+    C a b' => b' -> ()+Subsequently, we will type check (loop xb) and all is good. But,+recall that we have to solve a final implication constraint:+    C a b => (C a b' => .... cts from body of loop .... ))+And now we have a problem as we will generate an equality b ~ b' and fail to+solve it.+++************************************************************************+*                                                                      *+                Irreducible predicate errors+*                                                                      *+************************************************************************+-}++mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg+mkIrredErr ctxt cts+  = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1+       ; let orig = ctOrigin ct1+             msg  = couldNotDeduce (getUserGivens ctxt) (map ctPred cts, orig)+       ; mkErrorMsgFromCt ctxt ct1 $+            important msg `mappend` relevant_bindings binds_msg }+  where+    (ct1:_) = cts++----------------+mkHoleError :: ReportErrCtxt -> Ct -> TcM ErrMsg+mkHoleError _ctxt ct@(CHoleCan { cc_hole = ExprHole (OutOfScope occ rdr_env0) })+  -- Out-of-scope variables, like 'a', where 'a' isn't bound; suggest possible+  -- in-scope variables in the message, and note inaccessible exact matches+  = do { dflags   <- getDynFlags+       ; imp_info <- getImports+       ; let suggs_msg = unknownNameSuggestions dflags rdr_env0+                                                (tcl_rdr lcl_env) imp_info rdr+       ; rdr_env     <- getGlobalRdrEnv+       ; splice_locs <- getTopLevelSpliceLocs+       ; let match_msgs = mk_match_msgs rdr_env splice_locs+       ; mkErrDocAt (RealSrcSpan err_loc) $+                    errDoc [out_of_scope_msg] [] (match_msgs ++ [suggs_msg]) }++  where+    rdr         = mkRdrUnqual occ+    ct_loc      = ctLoc ct+    lcl_env     = ctLocEnv ct_loc+    err_loc     = tcl_loc lcl_env+    hole_ty     = ctEvPred (ctEvidence ct)+    boring_type = isTyVarTy hole_ty++    out_of_scope_msg -- Print v :: ty only if the type has structure+      | boring_type = hang herald 2 (ppr occ)+      | otherwise   = hang herald 2 (pp_with_type occ hole_ty)++    herald | isDataOcc occ = text "Data constructor not in scope:"+           | otherwise     = text "Variable not in scope:"++    -- Indicate if the out-of-scope variable exactly (and unambiguously) matches+    -- a top-level binding in a later inter-splice group; see Note [OutOfScope+    -- exact matches]+    mk_match_msgs rdr_env splice_locs+      = let gres = filter isLocalGRE (lookupGlobalRdrEnv rdr_env occ)+        in case gres of+             [gre]+               |  RealSrcSpan bind_loc <- greSrcSpan gre+                  -- Find splice between the unbound variable and the match; use+                  -- lookupLE, not lookupLT, since match could be in the splice+               ,  Just th_loc <- Set.lookupLE bind_loc splice_locs+               ,  err_loc < th_loc+               -> [mk_bind_scope_msg bind_loc th_loc]+             _ -> []++    mk_bind_scope_msg bind_loc th_loc+      | is_th_bind+      = hang (quotes (ppr occ) <+> parens (text "splice on" <+> th_rng))+           2 (text "is not in scope before line" <+> int th_start_ln)+      | otherwise+      = hang (quotes (ppr occ) <+> bind_rng <+> text "is not in scope")+           2 (text "before the splice on" <+> th_rng)+      where+        bind_rng = parens (text "line" <+> int bind_ln)+        th_rng+          | th_start_ln == th_end_ln = single+          | otherwise                = multi+        single = text "line"  <+> int th_start_ln+        multi  = text "lines" <+> int th_start_ln <> text "-" <> int th_end_ln+        bind_ln     = srcSpanStartLine bind_loc+        th_start_ln = srcSpanStartLine th_loc+        th_end_ln   = srcSpanEndLine   th_loc+        is_th_bind = th_loc `containsSpan` bind_loc++mkHoleError ctxt ct@(CHoleCan { cc_hole = hole })+  -- Explicit holes, like "_" or "_f"+  = do { (ctxt, binds_msg, ct) <- relevantBindings False ctxt ct+               -- The 'False' means "don't filter the bindings"; see Trac #8191++       ; show_hole_constraints <- goptM Opt_ShowHoleConstraints+       ; let constraints_msg+               | isExprHoleCt ct, show_hole_constraints+                  = givenConstraintsMsg ctxt+               | otherwise = empty++       ; mkErrorMsgFromCt ctxt ct $+            important hole_msg `mappend`+            relevant_bindings (binds_msg $$ constraints_msg) }++  where+    occ     = holeOcc hole+    hole_ty = ctEvPred (ctEvidence ct)+    tyvars  = tyCoVarsOfTypeList hole_ty++    hole_msg = case hole of+      ExprHole {} -> vcat [ hang (text "Found hole:")+                               2 (pp_with_type occ hole_ty)+                          , tyvars_msg, expr_hole_hint ]+      TypeHole {} -> vcat [ hang (text "Found type wildcard" <+>+                                  quotes (ppr occ))+                               2 (text "standing for" <+>+                                  quotes (pprType hole_ty))+                          , tyvars_msg, type_hole_hint ]++    tyvars_msg = ppUnless (null tyvars) $+                 text "Where:" <+> vcat (map loc_msg tyvars)++    type_hole_hint+         | HoleError <- cec_type_holes ctxt+         = text "To use the inferred type, enable PartialTypeSignatures"+         | otherwise+         = empty++    expr_hole_hint                       -- Give hint for, say,   f x = _x+         | lengthFS (occNameFS occ) > 1  -- Don't give this hint for plain "_"+         = text "Or perhaps" <+> quotes (ppr occ)+           <+> text "is mis-spelled, or not in scope"+         | otherwise+         = empty++    loc_msg tv+       | isTyVar tv+       = case tcTyVarDetails tv of+           MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable"+           _         -> extraTyVarInfo ctxt tv+       | otherwise+       = sdocWithDynFlags $ \dflags ->+         if gopt Opt_PrintExplicitCoercions dflags+         then quotes (ppr tv) <+> text "is a coercion variable"+         else empty++mkHoleError _ ct = pprPanic "mkHoleError" (ppr ct)+++-- See Note [Constraints include ...]+givenConstraintsMsg :: ReportErrCtxt -> SDoc+givenConstraintsMsg ctxt =+    let constraints :: [(Type, RealSrcSpan)]+        constraints =+          do { Implic{ ic_given = given, ic_env = env } <- cec_encl ctxt+             ; constraint <- given+             ; return (varType constraint, tcl_loc env) }++        pprConstraint (constraint, loc) =+          ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc))++    in ppUnless (null constraints) $+         hang (text "Constraints include")+            2 (vcat $ map pprConstraint constraints)++pp_with_type :: OccName -> Type -> SDoc+pp_with_type occ ty = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType ty)++----------------+mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg+mkIPErr ctxt cts+  = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1+       ; let orig    = ctOrigin ct1+             preds   = map ctPred cts+             givens  = getUserGivens ctxt+             msg | null givens+                 = addArising orig $+                   sep [ text "Unbound implicit parameter" <> plural cts+                       , nest 2 (pprTheta preds) ]+                 | otherwise+                 = couldNotDeduce givens (preds, orig)++       ; mkErrorMsgFromCt ctxt ct1 $+            important msg `mappend` relevant_bindings binds_msg }+  where+    (ct1:_) = cts++{-+Note [Constraints include ...]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+'givenConstraintsMsg' returns the "Constraints include ..." message enabled by+-fshow-hole-constraints. For example, the following hole:++    foo :: (Eq a, Show a) => a -> String+    foo x = _++would generate the message:++    Constraints include+      Eq a (from foo.hs:1:1-36)+      Show a (from foo.hs:1:1-36)++Constraints are displayed in order from innermost (closest to the hole) to+outermost. There's currently no filtering or elimination of duplicates.+++Note [OutOfScope exact matches]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When constructing an out-of-scope error message, we not only generate a list of+possible in-scope alternatives but also search for an exact, unambiguous match+in a later inter-splice group.  If we find such a match, we report its presence+(and indirectly, its scope) in the message.  For example, if a module A contains+the following declarations,++   foo :: Int+   foo = x++   $(return [])  -- Empty top-level splice++   x :: Int+   x = 23++we will issue an error similar to++   A.hs:6:7: error:+       • Variable not in scope: x :: Int+       • ‘x’ (line 11) is not in scope before the splice on line 8++By providing information about the match, we hope to clarify why declaring a+variable after a top-level splice but using it before the splice generates an+out-of-scope error (a situation which is often confusing to Haskell newcomers).++Note that if we find multiple exact matches to the out-of-scope variable+(hereafter referred to as x), we report nothing.  Such matches can only be+duplicate record fields, as the presence of any other duplicate top-level+declarations would have already halted compilation.  But if these record fields+are declared in a later inter-splice group, then so too are their corresponding+types.  Thus, these types must not occur in the inter-splice group containing x+(any unknown types would have already been reported), and so the matches to the+record fields are most likely coincidental.++One oddity of the exact match portion of the error message is that we specify+where the match to x is NOT in scope.  Why not simply state where the match IS+in scope?  It most cases, this would be just as easy and perhaps a little+clearer for the user.  But now consider the following example:++    {-# LANGUAGE TemplateHaskell #-}++    module A where++    import Language.Haskell.TH+    import Language.Haskell.TH.Syntax++    foo = x++    $(do -------------------------------------------------+        ds <- [d| ok1 = x+                |]+        addTopDecls ds+        return [])++    bar = $(do+            ds <- [d| x = 23+                      ok2 = x+                    |]+            addTopDecls ds+            litE $ stringL "hello")++    $(return []) -----------------------------------------++    ok3 = x++Here, x is out-of-scope in the declaration of foo, and so we report++    A.hs:8:7: error:+        • Variable not in scope: x+        • ‘x’ (line 16) is not in scope before the splice on lines 10-14++If we instead reported where x IS in scope, we would have to state that it is in+scope after the second top-level splice as well as among all the top-level+declarations added by both calls to addTopDecls.  But doing so would not only+add complexity to the code but also overwhelm the user with unneeded+information.++The logic which determines where x is not in scope is straightforward: it simply+finds the last top-level splice which occurs after x but before (or at) the+match to x (assuming such a splice exists).  In most cases, the check that the+splice occurs after x acts only as a sanity check.  For example, when the match+to x is a non-TH top-level declaration and a splice S occurs before the match,+then x must precede S; otherwise, it would be in scope.  But when dealing with+addTopDecls, this check serves a practical purpose.  Consider the following+declarations:++    $(do+        ds <- [d| ok = x+                  x = 23+                |]+        addTopDecls ds+        return [])++    foo = x++In this case, x is not in scope in the declaration for foo.  Since x occurs+AFTER the splice containing the match, the logic does not find any splices after+x but before or at its match, and so we report nothing about x's scope.  If we+had not checked whether x occurs before the splice, we would have instead+reported that x is not in scope before the splice.  While correct, such an error+message is more likely to confuse than to enlighten.+-}++{-+************************************************************************+*                                                                      *+                Equality errors+*                                                                      *+************************************************************************++Note [Inaccessible code]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   data T a where+     T1 :: T a+     T2 :: T Bool++   f :: (a ~ Int) => T a -> Int+   f T1 = 3+   f T2 = 4   -- Unreachable code++Here the second equation is unreachable. The original constraint+(a~Int) from the signature gets rewritten by the pattern-match to+(Bool~Int), so the danger is that we report the error as coming from+the *signature* (Trac #7293).  So, for Given errors we replace the+env (and hence src-loc) on its CtLoc with that from the immediately+enclosing implication.++Note [Error messages for untouchables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (Trac #9109)+  data G a where { GBool :: G Bool }+  foo x = case x of GBool -> True++Here we can't solve (t ~ Bool), where t is the untouchable result+meta-var 't', because of the (a ~ Bool) from the pattern match.+So we infer the type+   f :: forall a t. G a -> t+making the meta-var 't' into a skolem.  So when we come to report+the unsolved (t ~ Bool), t won't look like an untouchable meta-var+any more.  So we don't assert that it is.+-}++mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg+-- Don't have multiple equality errors from the same location+-- E.g.   (Int,Bool) ~ (Bool,Int)   one error will do!+mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct+mkEqErr _ [] = panic "mkEqErr"++mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg+mkEqErr1 ctxt ct   -- Wanted or derived;+                   -- givens handled in mkGivenErrorReporter+  = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct+       ; rdr_env <- getGlobalRdrEnv+       ; fam_envs <- tcGetFamInstEnvs+       ; exp_syns <- goptM Opt_PrintExpandedSynonyms+       ; let (keep_going, is_oriented, wanted_msg)+                           = mk_wanted_extra (ctLoc ct) exp_syns+             coercible_msg = case ctEqRel ct of+               NomEq  -> empty+               ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2+       ; dflags <- getDynFlags+       ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct))+       ; let report = mconcat [important wanted_msg, important coercible_msg,+                               relevant_bindings binds_msg]+       ; if keep_going+         then mkEqErr_help dflags ctxt report ct is_oriented ty1 ty2+         else mkErrorMsgFromCt ctxt ct report }+  where+    (ty1, ty2) = getEqPredTys (ctPred ct)++       -- If the types in the error message are the same as the types+       -- we are unifying, don't add the extra expected/actual message+    mk_wanted_extra :: CtLoc -> Bool -> (Bool, Maybe SwapFlag, SDoc)+    mk_wanted_extra loc expandSyns+      = case ctLocOrigin loc of+          orig@TypeEqOrigin {} -> mkExpectedActualMsg ty1 ty2 orig+                                                      t_or_k expandSyns+            where+              t_or_k = ctLocTypeOrKind_maybe loc++          KindEqOrigin cty1 mb_cty2 sub_o sub_t_or_k+            -> (True, Nothing, msg1 $$ msg2)+            where+              sub_what = case sub_t_or_k of Just KindLevel -> text "kinds"+                                            _              -> text "types"+              msg1 = sdocWithDynFlags $ \dflags ->+                     case mb_cty2 of+                       Just cty2+                         |  gopt Opt_PrintExplicitCoercions dflags+                         || not (cty1 `pickyEqType` cty2)+                         -> hang (text "When matching" <+> sub_what)+                               2 (vcat [ ppr cty1 <+> dcolon <+>+                                         ppr (typeKind cty1)+                                       , ppr cty2 <+> dcolon <+>+                                         ppr (typeKind cty2) ])+                       _ -> text "When matching the kind of" <+> quotes (ppr cty1)+              msg2 = case sub_o of+                       TypeEqOrigin {}+                         | Just cty2 <- mb_cty2 ->+                         thdOf3 (mkExpectedActualMsg cty1 cty2 sub_o sub_t_or_k+                                                     expandSyns)+                       _ -> empty+          _ -> (True, Nothing, empty)++-- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint+-- is left over.+mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs+                       -> TcType -> TcType -> SDoc+mkCoercibleExplanation rdr_env fam_envs ty1 ty2+  | Just (tc, tys) <- tcSplitTyConApp_maybe ty1+  , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys+  , Just msg <- coercible_msg_for_tycon rep_tc+  = msg+  | Just (tc, tys) <- splitTyConApp_maybe ty2+  , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys+  , Just msg <- coercible_msg_for_tycon rep_tc+  = msg+  | Just (s1, _) <- tcSplitAppTy_maybe ty1+  , Just (s2, _) <- tcSplitAppTy_maybe ty2+  , s1 `eqType` s2+  , has_unknown_roles s1+  = hang (text "NB: We cannot know what roles the parameters to" <+>+          quotes (ppr s1) <+> text "have;")+       2 (text "we must assume that the role is nominal")+  | otherwise+  = empty+  where+    coercible_msg_for_tycon tc+        | isAbstractTyCon tc+        = Just $ hsep [ text "NB: The type constructor"+                      , quotes (pprSourceTyCon tc)+                      , text "is abstract" ]+        | isNewTyCon tc+        , [data_con] <- tyConDataCons tc+        , let dc_name = dataConName data_con+        , isNothing (lookupGRE_Name rdr_env dc_name)+        = Just $ hang (text "The data constructor" <+> quotes (ppr dc_name))+                    2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc)+                           , text "is not in scope" ])+        | otherwise = Nothing++    has_unknown_roles ty+      | Just (tc, tys) <- tcSplitTyConApp_maybe ty+      = length tys >= tyConArity tc  -- oversaturated tycon+      | Just (s, _) <- tcSplitAppTy_maybe ty+      = has_unknown_roles s+      | isTyVarTy ty+      = True+      | otherwise+      = False++{-+-- | Make a listing of role signatures for all the parameterised tycons+-- used in the provided types+++-- SLPJ Jun 15: I could not convince myself that these hints were really+-- useful.  Maybe they are, but I think we need more work to make them+-- actually helpful.+mkRoleSigs :: Type -> Type -> SDoc+mkRoleSigs ty1 ty2+  = ppUnless (null role_sigs) $+    hang (text "Relevant role signatures:")+       2 (vcat role_sigs)+  where+    tcs = nameEnvElts $ tyConsOfType ty1 `plusNameEnv` tyConsOfType ty2+    role_sigs = mapMaybe ppr_role_sig tcs++    ppr_role_sig tc+      | null roles  -- if there are no parameters, don't bother printing+      = Nothing+      | isBuiltInSyntax (tyConName tc)  -- don't print roles for (->), etc.+      = Nothing+      | otherwise+      = Just $ hsep $ [text "type role", ppr tc] ++ map ppr roles+      where+        roles = tyConRoles tc+-}++mkEqErr_help :: DynFlags -> ReportErrCtxt -> Report+             -> Ct+             -> Maybe SwapFlag   -- Nothing <=> not sure+             -> TcType -> TcType -> TcM ErrMsg+mkEqErr_help dflags ctxt report ct oriented ty1 ty2+  | Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2+  | Just tv2 <- tcGetTyVar_maybe ty2 = mkTyVarEqErr dflags ctxt report ct swapped  tv2 ty1+  | otherwise                        = reportEqErr ctxt report ct oriented ty1 ty2+  where+    swapped = fmap flipSwap oriented++reportEqErr :: ReportErrCtxt -> Report+            -> Ct+            -> Maybe SwapFlag   -- Nothing <=> not sure+            -> TcType -> TcType -> TcM ErrMsg+reportEqErr ctxt report ct oriented ty1 ty2+  = mkErrorMsgFromCt ctxt ct (mconcat [misMatch, report, eqInfo])+  where misMatch = important $ misMatchOrCND ctxt ct oriented ty1 ty2+        eqInfo = important $ mkEqInfoMsg ct ty1 ty2++mkTyVarEqErr :: DynFlags -> ReportErrCtxt -> Report -> Ct+             -> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg+-- tv1 and ty2 are already tidied+mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2+  | isUserSkolem ctxt tv1   -- ty2 won't be a meta-tyvar, or else the thing would+                            -- be oriented the other way round;+                            -- see TcCanonical.canEqTyVarTyVar+  || isSigTyVar tv1 && not (isTyVarTy ty2)+  || ctEqRel ct == ReprEq && not insoluble_occurs_check+     -- the cases below don't really apply to ReprEq (except occurs check)+  = mkErrorMsgFromCt ctxt ct $ mconcat+        [ important $ misMatchOrCND ctxt ct oriented ty1 ty2+        , important $ extraTyVarEqInfo ctxt tv1 ty2+        , report+        ]++  | OC_Occurs <- occ_check_expand+    -- We report an "occurs check" even for  a ~ F t a, where F is a type+    -- function; it's not insouble (because in principle F could reduce)+    -- but we have certainly been unable to solve it+    -- See Note [Occurs check error] in TcCanonical+  = do { let main_msg = addArising (ctOrigin ct) $+                        hang (text "Occurs check: cannot construct the infinite" <+> what <> colon)+                              2 (sep [ppr ty1, char '~', ppr ty2])++             extra2 = important $ mkEqInfoMsg ct ty1 ty2++             interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $+                                  filter isTyVar $+                                  fvVarList $+                                  tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2+             extra3 = relevant_bindings $+                      ppWhen (not (null interesting_tyvars)) $+                      hang (text "Type variable kinds:") 2 $+                      vcat (map (tyvar_binding . tidyTyVarOcc (cec_tidy ctxt))+                                interesting_tyvars)++             tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)+       ; mkErrorMsgFromCt ctxt ct $+         mconcat [important main_msg, extra2, extra3, report] }++  | OC_Bad <- occ_check_expand+  = do { let msg = vcat [ text "Cannot instantiate unification variable"+                          <+> quotes (ppr tv1)+                        , hang (text "with a" <+> what <+> text "involving foralls:") 2 (ppr ty2)+                        , nest 2 (text "GHC doesn't yet support impredicative polymorphism") ]+       -- Unlike the other reports, this discards the old 'report_important'+       -- instead of augmenting it.  This is because the details are not likely+       -- to be helpful since this is just an unimplemented feature.+       ; mkErrorMsgFromCt ctxt ct $ report { report_important = [msg] } }++  -- If the immediately-enclosing implication has 'tv' a skolem, and+  -- we know by now its an InferSkol kind of skolem, then presumably+  -- it started life as a SigTv, else it'd have been unified, given+  -- that there's no occurs-check or forall problem+  | (implic:_) <- cec_encl ctxt+  , Implic { ic_skols = skols } <- implic+  , tv1 `elem` skols+  = mkErrorMsgFromCt ctxt ct $ mconcat+        [ important $ misMatchMsg ct oriented ty1 ty2+        , important $ extraTyVarEqInfo ctxt tv1 ty2+        , report+        ]++  -- Check for skolem escape+  | (implic:_) <- cec_encl ctxt   -- Get the innermost context+  , Implic { ic_env = env, ic_skols = skols, ic_info = skol_info } <- implic+  , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols+  , not (null esc_skols)+  = do { let msg = important $ misMatchMsg ct oriented ty1 ty2+             esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols+                             <+> pprQuotedList esc_skols+                           , text "would escape" <+>+                             if isSingleton esc_skols then text "its scope"+                                                      else text "their scope" ]+             tv_extra = important $+                        vcat [ nest 2 $ esc_doc+                             , sep [ (if isSingleton esc_skols+                                      then text "This (rigid, skolem)" <+>+                                           what <+> text "variable is"+                                      else text "These (rigid, skolem)" <+>+                                           what <+> text "variables are")+                               <+> text "bound by"+                             , nest 2 $ ppr skol_info+                             , nest 2 $ text "at" <+> ppr (tcl_loc env) ] ]+       ; mkErrorMsgFromCt ctxt ct (mconcat [msg, tv_extra, report]) }++  -- Nastiest case: attempt to unify an untouchable variable+  -- So tv is a meta tyvar (or started that way before we+  -- generalised it).  So presumably it is an *untouchable*+  -- meta tyvar or a SigTv, else it'd have been unified+  -- See Note [Error messages for untouchables]+  | (implic:_) <- cec_encl ctxt   -- Get the innermost context+  , Implic { ic_env = env, ic_given = given+           , ic_tclvl = lvl, ic_info = skol_info } <- implic+  = ASSERT2( not (isTouchableMetaTyVar lvl tv1)+           , ppr tv1 )  -- See Note [Error messages for untouchables]+    do { let msg = important $ misMatchMsg ct oriented ty1 ty2+             tclvl_extra = important $+                  nest 2 $+                  sep [ quotes (ppr tv1) <+> text "is untouchable"+                      , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given+                      , nest 2 $ text "bound by" <+> ppr skol_info+                      , nest 2 $ text "at" <+> ppr (tcl_loc env) ]+             tv_extra = important $ extraTyVarEqInfo ctxt tv1 ty2+             add_sig  = important $ suggestAddSig ctxt ty1 ty2+       ; mkErrorMsgFromCt ctxt ct $ mconcat+            [msg, tclvl_extra, tv_extra, add_sig, report] }++  | otherwise+  = reportEqErr ctxt report ct oriented (mkTyVarTy tv1) ty2+        -- This *can* happen (Trac #6123, and test T2627b)+        -- Consider an ambiguous top-level constraint (a ~ F a)+        -- Not an occurs check, because F is a type function.+  where+    ty1 = mkTyVarTy tv1+    occ_check_expand       = occCheckForErrors dflags tv1 ty2+    insoluble_occurs_check = isInsolubleOccursCheck (ctEqRel ct) tv1 ty2++    what = case ctLocTypeOrKind_maybe (ctLoc ct) of+      Just KindLevel -> text "kind"+      _              -> text "type"++mkEqInfoMsg :: Ct -> TcType -> TcType -> SDoc+-- Report (a) ambiguity if either side is a type function application+--            e.g. F a0 ~ Int+--        (b) warning about injectivity if both sides are the same+--            type function application   F a ~ F b+--            See Note [Non-injective type functions]+--        (c) warning about -fprint-explicit-kinds if that might be helpful+mkEqInfoMsg ct ty1 ty2+  = tyfun_msg $$ ambig_msg $$ invis_msg+  where+    mb_fun1 = isTyFun_maybe ty1+    mb_fun2 = isTyFun_maybe ty2++    ambig_msg | isJust mb_fun1 || isJust mb_fun2+              = snd (mkAmbigMsg False ct)+              | otherwise = empty++    -- better to check the exp/act types in the CtOrigin than the actual+    -- mismatched types for suggestion about -fprint-explicit-kinds+    (act_ty, exp_ty) = case ctOrigin ct of+      TypeEqOrigin { uo_actual = act+                   , uo_expected = exp } -> (act, exp)+      _                                  -> (ty1, ty2)++    invis_msg | Just vis <- tcEqTypeVis act_ty exp_ty+              , not vis+              = ppSuggestExplicitKinds+              | otherwise+              = empty++    tyfun_msg | Just tc1 <- mb_fun1+              , Just tc2 <- mb_fun2+              , tc1 == tc2+              = text "NB:" <+> quotes (ppr tc1)+                <+> text "is a type function, and may not be injective"+              | otherwise = empty++isUserSkolem :: ReportErrCtxt -> TcTyVar -> Bool+-- See Note [Reporting occurs-check errors]+isUserSkolem ctxt tv+  = isSkolemTyVar tv && any is_user_skol_tv (cec_encl ctxt)+  where+    is_user_skol_tv (Implic { ic_skols = sks, ic_info = skol_info })+      = tv `elem` sks && is_user_skol_info skol_info++    is_user_skol_info (InferSkol {}) = False+    is_user_skol_info _ = True++misMatchOrCND :: ReportErrCtxt -> Ct+              -> Maybe SwapFlag -> TcType -> TcType -> SDoc+-- If oriented then ty1 is actual, ty2 is expected+misMatchOrCND ctxt ct oriented ty1 ty2+  | null givens ||+    (isRigidTy ty1 && isRigidTy ty2) ||+    isGivenCt ct+       -- If the equality is unconditionally insoluble+       -- or there is no context, don't report the context+  = misMatchMsg ct oriented ty1 ty2+  | otherwise+  = couldNotDeduce givens ([eq_pred], orig)+  where+    ev      = ctEvidence ct+    eq_pred = ctEvPred ev+    orig    = ctEvOrigin ev+    givens  = [ given | given <- getUserGivens ctxt, not (ic_no_eqs given)]+              -- Keep only UserGivens that have some equalities++couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc+couldNotDeduce givens (wanteds, orig)+  = vcat [ addArising orig (text "Could not deduce:" <+> pprTheta wanteds)+         , vcat (pp_givens givens)]++pp_givens :: [UserGiven] -> [SDoc]+pp_givens givens+   = case givens of+         []     -> []+         (g:gs) ->      ppr_given (text "from the context:") g+                 : map (ppr_given (text "or from:")) gs+    where+       ppr_given herald (Implic { ic_given = gs, ic_info = skol_info+                                , ic_env = env })+           = hang (herald <+> pprEvVarTheta gs)+                2 (sep [ text "bound by" <+> ppr skol_info+                       , text "at" <+> ppr (tcl_loc env) ])++extraTyVarEqInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc+-- Add on extra info about skolem constants+-- NB: The types themselves are already tidied+extraTyVarEqInfo ctxt tv1 ty2+  = extraTyVarInfo ctxt tv1 $$ ty_extra ty2+  where+    ty_extra ty = case tcGetTyVar_maybe ty of+                    Just tv -> extraTyVarInfo ctxt tv+                    Nothing -> empty++extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> SDoc+extraTyVarInfo ctxt tv+  = ASSERT2( isTyVar tv, ppr tv )+    case tcTyVarDetails tv of+          SkolemTv {}   -> pprSkol implics tv+          FlatSkol {}   -> pp_tv <+> text "is a flattening type variable"+          RuntimeUnk {} -> pp_tv <+> text "is an interactive-debugger skolem"+          MetaTv {}     -> empty+  where+    implics = cec_encl ctxt+    pp_tv = quotes (ppr tv)++suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> SDoc+-- See Note [Suggest adding a type signature]+suggestAddSig ctxt ty1 ty2+  | null inferred_bndrs+  = empty+  | [bndr] <- inferred_bndrs+  = text "Possible fix: add a type signature for" <+> quotes (ppr bndr)+  | otherwise+  = text "Possible fix: add type signatures for some or all of" <+> (ppr inferred_bndrs)+  where+    inferred_bndrs = nub (get_inf ty1 ++ get_inf ty2)+    get_inf ty | Just tv <- tcGetTyVar_maybe ty+               , isSkolemTyVar tv+               , InferSkol prs <- ic_info (getSkolemInfo (cec_encl ctxt) tv)+               = map fst prs+               | otherwise+               = []++--------------------+misMatchMsg :: Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc+-- Types are already tidy+-- If oriented then ty1 is actual, ty2 is expected+misMatchMsg ct oriented ty1 ty2+  | Just NotSwapped <- oriented+  = misMatchMsg ct (Just IsSwapped) ty2 ty1++  -- These next two cases are when we're about to report, e.g., that+  -- 'LiftedRep doesn't match 'VoidRep. Much better just to say+  -- lifted vs. unlifted+  | Just (tc1, []) <- splitTyConApp_maybe ty1+  , tc1 `hasKey` liftedRepDataConKey+  = lifted_vs_unlifted++  | Just (tc2, []) <- splitTyConApp_maybe ty2+  , tc2 `hasKey` liftedRepDataConKey+  = lifted_vs_unlifted++  | otherwise  -- So now we have Nothing or (Just IsSwapped)+               -- For some reason we treat Nothing like IsSwapped+  = addArising orig $+    sep [ text herald1 <+> quotes (ppr ty1)+        , nest padding $+          text herald2 <+> quotes (ppr ty2)+        , sameOccExtra ty2 ty1 ]+  where+    herald1 = conc [ "Couldn't match"+                   , if is_repr     then "representation of" else ""+                   , if is_oriented then "expected"          else ""+                   , what ]+    herald2 = conc [ "with"+                   , if is_repr     then "that of"           else ""+                   , if is_oriented then ("actual " ++ what) else "" ]+    padding = length herald1 - length herald2++    is_repr = case ctEqRel ct of { ReprEq -> True; NomEq -> False }+    is_oriented = isJust oriented++    orig = ctOrigin ct+    what = case ctLocTypeOrKind_maybe (ctLoc ct) of+      Just KindLevel -> "kind"+      _              -> "type"++    conc :: [String] -> String+    conc = foldr1 add_space++    add_space :: String -> String -> String+    add_space s1 s2 | null s1   = s2+                    | null s2   = s1+                    | otherwise = s1 ++ (' ' : s2)++    lifted_vs_unlifted+      = addArising orig $+        text "Couldn't match a lifted type with an unlifted type"++mkExpectedActualMsg :: Type -> Type -> CtOrigin -> Maybe TypeOrKind -> Bool+                    -> (Bool, Maybe SwapFlag, SDoc)+-- NotSwapped means (actual, expected), IsSwapped is the reverse+-- First return val is whether or not to print a herald above this msg+mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act+                                          , uo_expected = exp+                                          , uo_thing = maybe_thing })+                    m_level printExpanded+  | KindLevel <- level, occurs_check_error       = (True, Nothing, empty)+  | isUnliftedTypeKind act, isLiftedTypeKind exp = (False, Nothing, msg2)+  | isLiftedTypeKind act, isUnliftedTypeKind exp = (False, Nothing, msg3)+  | isLiftedTypeKind exp && not (isConstraintKind exp)+                                                 = (False, Nothing, msg4)+  | Just msg <- num_args_msg                     = (False, Nothing, msg $$ msg1)+  | KindLevel <- level, Just th <- maybe_thing   = (False, Nothing, msg5 th)+  | act `pickyEqType` ty1, exp `pickyEqType` ty2 = (True, Just NotSwapped, empty)+  | exp `pickyEqType` ty1, act `pickyEqType` ty2 = (True, Just IsSwapped, empty)+  | otherwise                                    = (True, Nothing, msg1)+  where+    level = m_level `orElse` TypeLevel++    occurs_check_error+      | Just act_tv <- tcGetTyVar_maybe act+      , act_tv `elemVarSet` tyCoVarsOfType exp+      = True+      | Just exp_tv <- tcGetTyVar_maybe exp+      , exp_tv `elemVarSet` tyCoVarsOfType act+      = True+      | otherwise+      = False++    sort = case level of+      TypeLevel -> text "type"+      KindLevel -> text "kind"++    msg1 = case level of+      KindLevel+        | Just th <- maybe_thing+        -> msg5 th++      _ | not (act `pickyEqType` exp)+        -> vcat [ text "Expected" <+> sort <> colon <+> ppr exp+                , text "  Actual" <+> sort <> colon <+> ppr act+                , if printExpanded then expandedTys else empty ]++        | otherwise+        -> empty++    thing_msg = case maybe_thing of+                  Just thing -> \_ -> quotes (ppr thing) <+> text "is"+                  Nothing    -> \vowel -> text "got a" <>+                                          if vowel then char 'n' else empty+    msg2 = sep [ text "Expecting a lifted type, but"+               , thing_msg True, text "unlifted" ]+    msg3 = sep [ text "Expecting an unlifted type, but"+               , thing_msg False, text "lifted" ]+    msg4 = maybe_num_args_msg $$+           sep [ text "Expected a type, but"+               , maybe (text "found something with kind")+                       (\thing -> quotes (ppr thing) <+> text "has kind")+                       maybe_thing+               , quotes (ppr act) ]++    msg5 th = hang (text "Expected" <+> kind_desc <> comma)+                 2 (text "but" <+> quotes (ppr th) <+> text "has kind" <+>+                    quotes (ppr act))+      where+        kind_desc | isConstraintKind exp = text "a constraint"+                  | otherwise            = text "kind" <+> quotes (ppr exp)++    num_args_msg = case level of+      TypeLevel -> Nothing+      KindLevel+        -> let n_act = count_args act+               n_exp = count_args exp in+           case n_act - n_exp of+             n | n /= 0+               , Just thing <- maybe_thing+               , case errorThingNumArgs_maybe thing of+                   Nothing           -> n > 0+                   Just num_act_args -> num_act_args >= -n+                     -- don't report to strip off args that aren't there+               -> Just $ text "Expecting" <+> speakN (abs n) <+>+                         more_or_fewer <+> quotes (ppr thing)+               where+                 more_or_fewer+                  | n < 0     = text "fewer arguments to"+                  | n == 1    = text "more argument to"+                  | otherwise = text "more arguments to"  -- n > 1+             _ -> Nothing++    maybe_num_args_msg = case num_args_msg of+      Nothing -> empty+      Just m  -> m++    count_args ty = count isVisibleBinder $ fst $ splitPiTys ty++    expandedTys =+      ppUnless (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act) $ vcat+        [ text "Type synonyms expanded:"+        , text "Expected type:" <+> ppr expTy1+        , text "  Actual type:" <+> ppr expTy2+        ]++    (expTy1, expTy2) = expandSynonymsToMatch exp act++mkExpectedActualMsg _ _ _ _ _ = panic "mkExpectedAcutalMsg"++{-+Note [Expanding type synonyms to make types similar]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++In type error messages, if -fprint-expanded-types is used, we want to expand+type synonyms to make expected and found types as similar as possible, but we+shouldn't expand types too much to make type messages even more verbose and+harder to understand. The whole point here is to make the difference in expected+and found types clearer.++`expandSynonymsToMatch` does this, it takes two types, and expands type synonyms+only as much as necessary. Given two types t1 and t2:++  * If they're already same, it just returns the types.++  * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are+    type constructors), it expands C1 and C2 if they're different type synonyms.+    Then it recursively does the same thing on expanded types. If C1 and C2 are+    same, then it applies the same procedure to arguments of C1 and arguments of+    C2 to make them as similar as possible.++    Most important thing here is to keep number of synonym expansions at+    minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is `T (T5, T3,+    Bool)` where T5 = T4, T4 = T3, ..., T1 = X, it returns `T (T3, T3, Int)` and+    `T (T3, T3, Bool)`.++  * Otherwise types don't have same shapes and so the difference is clearly+    visible. It doesn't do any expansions and show these types.++Note that we only expand top-layer type synonyms. Only when top-layer+constructors are the same we start expanding inner type synonyms.++Suppose top-layer type synonyms of t1 and t2 can expand N and M times,+respectively. If their type-synonym-expanded forms will meet at some point (i.e.+will have same shapes according to `sameShapes` function), it's possible to find+where they meet in O(N+M) top-layer type synonym expansions and O(min(N,M))+comparisons. We first collect all the top-layer expansions of t1 and t2 in two+lists, then drop the prefix of the longer list so that they have same lengths.+Then we search through both lists in parallel, and return the first pair of+types that have same shapes. Inner types of these two types with same shapes+are then expanded using the same algorithm.++In case they don't meet, we return the last pair of types in the lists, which+has top-layer type synonyms completely expanded. (in this case the inner types+are not expanded at all, as the current form already shows the type error)+-}++-- | Expand type synonyms in given types only enough to make them as similar as+-- possible. Returned types are the same in terms of used type synonyms.+--+-- To expand all synonyms, see 'Type.expandTypeSynonyms'.+--+-- See `ExpandSynsFail` tests in tests testsuite/tests/typecheck/should_fail for+-- some examples of how this should work.+expandSynonymsToMatch :: Type -> Type -> (Type, Type)+expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret)+  where+    (ty1_ret, ty2_ret) = go ty1 ty2++    -- | Returns (type synonym expanded version of first type,+    --            type synonym expanded version of second type)+    go :: Type -> Type -> (Type, Type)+    go t1 t2+      | t1 `pickyEqType` t2 =+        -- Types are same, nothing to do+        (t1, t2)++    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)+      | tc1 == tc2 =+        -- Type constructors are same. They may be synonyms, but we don't+        -- expand further.+        let (tys1', tys2') =+              unzip (zipWith (\ty1 ty2 -> go ty1 ty2) tys1 tys2)+         in (TyConApp tc1 tys1', TyConApp tc2 tys2')++    go (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) =+      let (t1_1', t2_1') = go t1_1 t2_1+          (t1_2', t2_2') = go t1_2 t2_2+       in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2')++    go (FunTy t1_1 t1_2) (FunTy t2_1 t2_2) =+      let (t1_1', t2_1') = go t1_1 t2_1+          (t1_2', t2_2') = go t1_2 t2_2+       in (mkFunTy t1_1' t1_2', mkFunTy t2_1' t2_2')++    go (ForAllTy b1 t1) (ForAllTy b2 t2) =+      -- NOTE: We may have a bug here, but we just can't reproduce it easily.+      -- See D1016 comments for details and our attempts at producing a test+      -- case. Short version: We probably need RnEnv2 to really get this right.+      let (t1', t2') = go t1 t2+       in (ForAllTy b1 t1', ForAllTy b2 t2')++    go (CastTy ty1 _) ty2 = go ty1 ty2+    go ty1 (CastTy ty2 _) = go ty1 ty2++    go t1 t2 =+      -- See Note [Expanding type synonyms to make types similar] for how this+      -- works+      let+        t1_exp_tys = t1 : tyExpansions t1+        t2_exp_tys = t2 : tyExpansions t2+        t1_exps    = length t1_exp_tys+        t2_exps    = length t2_exp_tys+        dif        = abs (t1_exps - t2_exps)+      in+        followExpansions $+          zipEqual "expandSynonymsToMatch.go"+            (if t1_exps > t2_exps then drop dif t1_exp_tys else t1_exp_tys)+            (if t2_exps > t1_exps then drop dif t2_exp_tys else t2_exp_tys)++    -- | Expand the top layer type synonyms repeatedly, collect expansions in a+    -- list. The list does not include the original type.+    --+    -- Example, if you have:+    --+    --   type T10 = T9+    --   type T9  = T8+    --   ...+    --   type T0  = Int+    --+    -- `tyExpansions T10` returns [T9, T8, T7, ... Int]+    --+    -- This only expands the top layer, so if you have:+    --+    --   type M a = Maybe a+    --+    -- `tyExpansions (M T10)` returns [Maybe T10] (T10 is not expanded)+    tyExpansions :: Type -> [Type]+    tyExpansions = unfoldr (\t -> (\x -> (x, x)) `fmap` tcView t)++    -- | Drop the type pairs until types in a pair look alike (i.e. the outer+    -- constructors are the same).+    followExpansions :: [(Type, Type)] -> (Type, Type)+    followExpansions [] = pprPanic "followExpansions" empty+    followExpansions [(t1, t2)]+      | sameShapes t1 t2 = go t1 t2 -- expand subtrees+      | otherwise        = (t1, t2) -- the difference is already visible+    followExpansions ((t1, t2) : tss)+      -- Traverse subtrees when the outer shapes are the same+      | sameShapes t1 t2 = go t1 t2+      -- Otherwise follow the expansions until they look alike+      | otherwise = followExpansions tss++    sameShapes :: Type -> Type -> Bool+    sameShapes AppTy{}          AppTy{}          = True+    sameShapes (TyConApp tc1 _) (TyConApp tc2 _) = tc1 == tc2+    sameShapes (FunTy {})       (FunTy {})       = True+    sameShapes (ForAllTy {})    (ForAllTy {})    = True+    sameShapes (CastTy ty1 _)   ty2              = sameShapes ty1 ty2+    sameShapes ty1              (CastTy ty2 _)   = sameShapes ty1 ty2+    sameShapes _                _                = False++sameOccExtra :: TcType -> TcType -> SDoc+-- See Note [Disambiguating (X ~ X) errors]+sameOccExtra ty1 ty2+  | Just (tc1, _) <- tcSplitTyConApp_maybe ty1+  , Just (tc2, _) <- tcSplitTyConApp_maybe ty2+  , let n1 = tyConName tc1+        n2 = tyConName tc2+        same_occ = nameOccName n1                   == nameOccName n2+        same_pkg = moduleUnitId (nameModule n1) == moduleUnitId (nameModule n2)+  , n1 /= n2   -- Different Names+  , same_occ   -- but same OccName+  = text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2)+  | otherwise+  = empty+  where+    ppr_from same_pkg nm+      | isGoodSrcSpan loc+      = hang (quotes (ppr nm) <+> text "is defined at")+           2 (ppr loc)+      | otherwise  -- Imported things have an UnhelpfulSrcSpan+      = hang (quotes (ppr nm))+           2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod))+                  , ppUnless (same_pkg || pkg == mainUnitId) $+                    nest 4 $ text "in package" <+> quotes (ppr pkg) ])+       where+         pkg = moduleUnitId mod+         mod = nameModule nm+         loc = nameSrcSpan nm++{-+Note [Suggest adding a type signature]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The OutsideIn algorithm rejects GADT programs that don't have a principal+type, and indeed some that do.  Example:+   data T a where+     MkT :: Int -> T Int++   f (MkT n) = n++Does this have type f :: T a -> a, or f :: T a -> Int?+The error that shows up tends to be an attempt to unify an+untouchable type variable.  So suggestAddSig sees if the offending+type variable is bound by an *inferred* signature, and suggests+adding a declared signature instead.++This initially came up in Trac #8968, concerning pattern synonyms.++Note [Disambiguating (X ~ X) errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See Trac #8278++Note [Reporting occurs-check errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given (a ~ [a]), if 'a' is a rigid type variable bound by a user-supplied+type signature, then the best thing is to report that we can't unify+a with [a], because a is a skolem variable.  That avoids the confusing+"occur-check" error message.++But nowadays when inferring the type of a function with no type signature,+even if there are errors inside, we still generalise its signature and+carry on. For example+   f x = x:x+Here we will infer something like+   f :: forall a. a -> [a]+with a deferred error of (a ~ [a]).  So in the deferred unsolved constraint+'a' is now a skolem, but not one bound by the programmer in the context!+Here we really should report an occurs check.++So isUserSkolem distinguishes the two.++Note [Non-injective type functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's very confusing to get a message like+     Couldn't match expected type `Depend s'+            against inferred type `Depend s1'+so mkTyFunInfoMsg adds:+       NB: `Depend' is type function, and hence may not be injective++Warn of loopy local equalities that were dropped.+++************************************************************************+*                                                                      *+                 Type-class errors+*                                                                      *+************************************************************************+-}++mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg+mkDictErr ctxt cts+  = ASSERT( not (null cts) )+    do { inst_envs <- tcGetInstEnvs+       ; let (ct1:_) = cts  -- ct1 just for its location+             min_cts = elim_superclasses cts+             lookups = map (lookup_cls_inst inst_envs) min_cts+             (no_inst_cts, overlap_cts) = partition is_no_inst lookups++       -- Report definite no-instance errors,+       -- or (iff there are none) overlap errors+       -- But we report only one of them (hence 'head') because they all+       -- have the same source-location origin, to try avoid a cascade+       -- of error from one location+       ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))+       ; mkErrorMsgFromCt ctxt ct1 (important err) }+  where+    no_givens = null (getUserGivens ctxt)++    is_no_inst (ct, (matches, unifiers, _))+      =  no_givens+      && null matches+      && (null unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct))++    lookup_cls_inst inst_envs ct+                -- Note [Flattening in error message generation]+      = (ct, lookupInstEnv True inst_envs clas (flattenTys emptyInScopeSet tys))+      where+        (clas, tys) = getClassPredTys (ctPred ct)+++    -- When simplifying [W] Ord (Set a), we need+    --    [W] Eq a, [W] Ord a+    -- but we really only want to report the latter+    elim_superclasses cts+      = filter (\ct -> any (eqType (ctPred ct)) min_preds) cts+      where+        min_preds = mkMinimalBySCs (map ctPred cts)++mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult)+            -> TcM (ReportErrCtxt, SDoc)+-- Report an overlap error if this class constraint results+-- from an overlap (returning Left clas), otherwise return (Right pred)+mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_overlapped))+  | null matches  -- No matches but perhaps several unifiers+  = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct+       ; candidate_insts <- get_candidate_instances+       ; return (ctxt, cannot_resolve_msg ct candidate_insts binds_msg) }++  | null unsafe_overlapped   -- Some matches => overlap errors+  = return (ctxt, overlap_msg)++  | otherwise+  = return (ctxt, safe_haskell_msg)+  where+    orig          = ctOrigin ct+    pred          = ctPred ct+    (clas, tys)   = getClassPredTys pred+    ispecs        = [ispec | (ispec, _) <- matches]+    unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped]+    useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics)+         -- useful_givens are the enclosing implications with non-empty givens,+         -- modulo the horrid discardProvCtxtGivens++    get_candidate_instances :: TcM [ClsInst]+    -- See Note [Report candidate instances]+    get_candidate_instances+      | [ty] <- tys   -- Only try for single-parameter classes+      = do { instEnvs <- tcGetInstEnvs+           ; return (filter (is_candidate_inst ty)+                            (classInstances instEnvs clas)) }+      | otherwise = return []++    is_candidate_inst ty inst -- See Note [Report candidate instances]+      | [other_ty] <- is_tys inst+      , Just (tc1, _) <- tcSplitTyConApp_maybe ty+      , Just (tc2, _) <- tcSplitTyConApp_maybe other_ty+      = let n1 = tyConName tc1+            n2 = tyConName tc2+            different_names = n1 /= n2+            same_occ_names = nameOccName n1 == nameOccName n2+        in different_names && same_occ_names+      | otherwise = False++    cannot_resolve_msg :: Ct -> [ClsInst] -> SDoc -> SDoc+    cannot_resolve_msg ct candidate_insts binds_msg+      = vcat [ no_inst_msg+             , nest 2 extra_note+             , vcat (pp_givens useful_givens)+             , mb_patsyn_prov `orElse` empty+             , ppWhen (has_ambig_tvs && not (null unifiers && null useful_givens))+               (vcat [ ppUnless lead_with_ambig ambig_msg, binds_msg, potential_msg ])++             , ppWhen (isNothing mb_patsyn_prov) $+                   -- Don't suggest fixes for the provided context of a pattern+                   -- synonym; the right fix is to bind more in the pattern+               show_fixes (ctxtFixes has_ambig_tvs pred implics+                           ++ drv_fixes)+             , ppWhen (not (null candidate_insts))+               (hang (text "There are instances for similar types:")+                   2 (vcat (map ppr candidate_insts))) ]+                   -- See Note [Report candidate instances]+      where+        orig = ctOrigin ct+        -- See Note [Highlighting ambiguous type variables]+        lead_with_ambig = has_ambig_tvs && not (any isRuntimeUnkSkol ambig_tvs)+                        && not (null unifiers) && null useful_givens++        (has_ambig_tvs, ambig_msg) = mkAmbigMsg lead_with_ambig ct+        ambig_tvs = uncurry (++) (getAmbigTkvs ct)++        no_inst_msg+          | lead_with_ambig+          = ambig_msg <+> pprArising orig+              $$ text "prevents the constraint" <+>  quotes (pprParendType pred)+              <+> text "from being solved."++          | null useful_givens+          = addArising orig $ text "No instance for"+            <+> pprParendType pred++          | otherwise+          = addArising orig $ text "Could not deduce"+            <+> pprParendType pred++        potential_msg+          = ppWhen (not (null unifiers) && want_potential orig) $+            sdocWithDynFlags $ \dflags ->+            getPprStyle $ \sty ->+            pprPotentials dflags sty potential_hdr unifiers++        potential_hdr+          = vcat [ ppWhen lead_with_ambig $+                     text "Probable fix: use a type annotation to specify what"+                     <+> pprQuotedList ambig_tvs <+> text "should be."+                 , text "These potential instance" <> plural unifiers+                   <+> text "exist:"]++        mb_patsyn_prov :: Maybe SDoc+        mb_patsyn_prov+          | not lead_with_ambig+          , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig+          = Just (vcat [ text "In other words, a successful match on the pattern"+                       , nest 2 $ ppr pat+                       , text "does not provide the constraint" <+> pprParendType pred ])+          | otherwise = Nothing++    -- Report "potential instances" only when the constraint arises+    -- directly from the user's use of an overloaded function+    want_potential (TypeEqOrigin {}) = False+    want_potential _                 = True++    extra_note | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys)+               = text "(maybe you haven't applied a function to enough arguments?)"+               | className clas == typeableClassName  -- Avoid mysterious "No instance for (Typeable T)+               , [_,ty] <- tys                        -- Look for (Typeable (k->*) (T k))+               , Just (tc,_) <- tcSplitTyConApp_maybe ty+               , not (isTypeFamilyTyCon tc)+               = hang (text "GHC can't yet do polykinded")+                    2 (text "Typeable" <+>+                       parens (ppr ty <+> dcolon <+> ppr (typeKind ty)))+               | otherwise+               = empty++    drv_fixes = case orig of+                   DerivOrigin      -> [drv_fix]+                   DerivOriginDC {} -> [drv_fix]+                   DerivOriginCoerce {} -> [drv_fix]+                   _                -> []++    drv_fix = hang (text "use a standalone 'deriving instance' declaration,")+                 2 (text "so you can specify the instance context yourself")++    -- Normal overlap error+    overlap_msg+      = ASSERT( not (null matches) )+        vcat [  addArising orig (text "Overlapping instances for"+                                <+> pprType (mkClassPred clas tys))++             ,  ppUnless (null matching_givens) $+                  sep [text "Matching givens (or their superclasses):"+                      , nest 2 (vcat matching_givens)]++             ,  sdocWithDynFlags $ \dflags ->+                getPprStyle $ \sty ->+                pprPotentials dflags sty (text "Matching instances:") $+                ispecs ++ unifiers++             ,  ppWhen (null matching_givens && isSingleton matches && null unifiers) $+                -- Intuitively, some given matched the wanted in their+                -- flattened or rewritten (from given equalities) form+                -- but the matcher can't figure that out because the+                -- constraints are non-flat and non-rewritten so we+                -- simply report back the whole given+                -- context. Accelerate Smart.hs showed this problem.+                  sep [ text "There exists a (perhaps superclass) match:"+                      , nest 2 (vcat (pp_givens useful_givens))]++             ,  ppWhen (isSingleton matches) $+                parens (vcat [ text "The choice depends on the instantiation of" <+>+                                  quotes (pprWithCommas ppr (tyCoVarsOfTypesList tys))+                             , ppWhen (null (matching_givens)) $+                               vcat [ text "To pick the first instance above, use IncoherentInstances"+                                    , text "when compiling the other instance declarations"]+                        ])]++    matching_givens = mapMaybe matchable useful_givens++    matchable (Implic { ic_given = evvars, ic_info = skol_info, ic_env = env })+      = case ev_vars_matching of+             [] -> Nothing+             _  -> Just $ hang (pprTheta ev_vars_matching)+                            2 (sep [ text "bound by" <+> ppr skol_info+                                   , text "at" <+> ppr (tcl_loc env) ])+        where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)+              ev_var_matches ty = case getClassPredTys_maybe ty of+                 Just (clas', tys')+                   | clas' == clas+                   , Just _ <- tcMatchTys tys tys'+                   -> True+                   | otherwise+                   -> any ev_var_matches (immSuperClasses clas' tys')+                 Nothing -> False++    -- Overlap error because of Safe Haskell (first+    -- match should be the most specific match)+    safe_haskell_msg+     = ASSERT( length matches == 1 && not (null unsafe_ispecs) )+       vcat [ addArising orig (text "Unsafe overlapping instances for"+                       <+> pprType (mkClassPred clas tys))+            , sep [text "The matching instance is:",+                   nest 2 (pprInstance $ head ispecs)]+            , vcat [ text "It is compiled in a Safe module and as such can only"+                   , text "overlap instances from the same module, however it"+                   , text "overlaps the following instances from different" <+>+                     text "modules:"+                   , nest 2 (vcat [pprInstances $ unsafe_ispecs])+                   ]+            ]+++ctxtFixes :: Bool -> PredType -> [Implication] -> [SDoc]+ctxtFixes has_ambig_tvs pred implics+  | not has_ambig_tvs+  , isTyVarClassPred pred+  , (skol:skols) <- usefulContext implics pred+  , let what | null skols+             , SigSkol (PatSynCtxt {}) _ _ <- skol+             = text "\"required\""+             | otherwise+             = empty+  = [sep [ text "add" <+> pprParendType pred+           <+> text "to the" <+> what <+> text "context of"+         , nest 2 $ ppr_skol skol $$+                    vcat [ text "or" <+> ppr_skol skol+                         | skol <- skols ] ] ]+  | otherwise = []+  where+    ppr_skol (PatSkol (RealDataCon dc) _) = text "the data constructor" <+> quotes (ppr dc)+    ppr_skol (PatSkol (PatSynCon ps)   _) = text "the pattern synonym"  <+> quotes (ppr ps)+    ppr_skol skol_info = ppr skol_info++discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven]+discardProvCtxtGivens orig givens  -- See Note [discardProvCtxtGivens]+  | ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig+  = filterOut (discard name) givens+  | otherwise+  = givens+  where+    discard n (Implic { ic_info = SigSkol (PatSynCtxt n') _ _ }) = n == n'+    discard _ _                                                  = False++usefulContext :: [Implication] -> PredType -> [SkolemInfo]+-- usefulContext picks out the implications whose context+-- the programmer might plausibly augment to solve 'pred'+usefulContext implics pred+  = go implics+  where+    pred_tvs = tyCoVarsOfType pred+    go [] = []+    go (ic : ics)+       | implausible ic = rest+       | otherwise      = ic_info ic : rest+       where+          -- Stop when the context binds a variable free in the predicate+          rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = []+               | otherwise                                 = go ics++    implausible ic+      | null (ic_skols ic)            = True+      | implausible_info (ic_info ic) = True+      | otherwise                     = False++    implausible_info (SigSkol (InfSigCtxt {}) _ _) = True+    implausible_info _                             = False+    -- Do not suggest adding constraints to an *inferred* type signature++{- Note [Report candidate instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have an unsolved (Num Int), where `Int` is not the Prelude Int,+but comes from some other module, then it may be helpful to point out+that there are some similarly named instances elsewhere.  So we get+something like+    No instance for (Num Int) arising from the literal ‘3’+    There are instances for similar types:+      instance Num GHC.Types.Int -- Defined in ‘GHC.Num’+Discussion in Trac #9611.++Note [Highlighting ambiguous type variables]+~-------------------------------------------+When we encounter ambiguous type variables (i.e. type variables+that remain metavariables after type inference), we need a few more+conditions before we can reason that *ambiguity* prevents constraints+from being solved:+  - We can't have any givens, as encountering a typeclass error+    with given constraints just means we couldn't deduce+    a solution satisfying those constraints and as such couldn't+    bind the type variable to a known type.+  - If we don't have any unifiers, we don't even have potential+    instances from which an ambiguity could arise.+  - Lastly, I don't want to mess with error reporting for+    unknown runtime types so we just fall back to the old message there.+Once these conditions are satisfied, we can safely say that ambiguity prevents+the constraint from being solved.++Note [discardProvCtxtGivens]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+In most situations we call all enclosing implications "useful". There is one+exception, and that is when the constraint that causes the error is from the+"provided" context of a pattern synonym declaration:++  pattern Pat :: (Num a, Eq a) => Show a   => a -> Maybe a+             --  required      => provided => type+  pattern Pat x <- (Just x, 4)++When checking the pattern RHS we must check that it does actually bind all+the claimed "provided" constraints; in this case, does the pattern (Just x, 4)+bind the (Show a) constraint.  Answer: no!++But the implication we generate for this will look like+   forall a. (Num a, Eq a) => [W] Show a+because when checking the pattern we must make the required+constraints available, since they are needed to match the pattern (in+this case the literal '4' needs (Num a, Eq a)).++BUT we don't want to suggest adding (Show a) to the "required" constraints+of the pattern synonym, thus:+  pattern Pat :: (Num a, Eq a, Show a) => Show a => a -> Maybe a+It would then typecheck but it's silly.  We want the /pattern/ to bind+the alleged "provided" constraints, Show a.++So we suppress that Implication in discardProvCtxtGivens.  It's+painfully ad-hoc but the truth is that adding it to the "required"+constraints would work.  Suprressing it solves two problems.  First,+we never tell the user that we could not deduce a "provided"+constraint from the "required" context. Second, we never give a+possible fix that suggests to add a "provided" constraint to the+"required" context.++For example, without this distinction the above code gives a bad error+message (showing both problems):++  error: Could not deduce (Show a) ... from the context: (Eq a)+         ... Possible fix: add (Show a) to the context of+         the signature for pattern synonym `Pat' ...++-}++show_fixes :: [SDoc] -> SDoc+show_fixes []     = empty+show_fixes (f:fs) = sep [ text "Possible fix:"+                        , nest 2 (vcat (f : map (text "or" <+>) fs))]++pprPotentials :: DynFlags -> PprStyle -> SDoc -> [ClsInst] -> SDoc+-- See Note [Displaying potential instances]+pprPotentials dflags sty herald insts+  | null insts+  = empty++  | null show_these+  = hang herald+       2 (vcat [ not_in_scope_msg empty+               , flag_hint ])++  | otherwise+  = hang herald+       2 (vcat [ pprInstances show_these+               , ppWhen (n_in_scope_hidden > 0) $+                 text "...plus"+                   <+> speakNOf n_in_scope_hidden (text "other")+               , not_in_scope_msg (text "...plus")+               , flag_hint ])+  where+    n_show = 3 :: Int+    show_potentials = gopt Opt_PrintPotentialInstances dflags++    (in_scope, not_in_scope) = partition inst_in_scope insts+    sorted = sortBy fuzzyClsInstCmp in_scope+    show_these | show_potentials = sorted+               | otherwise       = take n_show sorted+    n_in_scope_hidden = length sorted - length show_these++       -- "in scope" means that all the type constructors+       -- are lexically in scope; these instances are likely+       -- to be more useful+    inst_in_scope :: ClsInst -> Bool+    inst_in_scope cls_inst = nameSetAll name_in_scope $+                             orphNamesOfTypes (is_tys cls_inst)++    name_in_scope name+      | isBuiltInSyntax name+      = True -- E.g. (->)+      | Just mod <- nameModule_maybe name+      = qual_in_scope (qualName sty mod (nameOccName name))+      | otherwise+      = True++    qual_in_scope :: QualifyName -> Bool+    qual_in_scope NameUnqual    = True+    qual_in_scope (NameQual {}) = True+    qual_in_scope _             = False++    not_in_scope_msg herald+      | null not_in_scope+      = empty+      | otherwise+      = hang (herald <+> speakNOf (length not_in_scope) (text "instance")+                     <+> text "involving out-of-scope types")+           2 (ppWhen show_potentials (pprInstances not_in_scope))++    flag_hint = ppUnless (show_potentials || length show_these == length insts) $+                text "(use -fprint-potential-instances to see them all)"++{- Note [Displaying potential instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When showing a list of instances for+  - overlapping instances (show ones that match)+  - no such instance (show ones that could match)+we want to give it a bit of structure.  Here's the plan++* Say that an instance is "in scope" if all of the+  type constructors it mentions are lexically in scope.+  These are the ones most likely to be useful to the programmer.++* Show at most n_show in-scope instances,+  and summarise the rest ("plus 3 others")++* Summarise the not-in-scope instances ("plus 4 not in scope")++* Add the flag -fshow-potential-instances which replaces the+  summary with the full list+-}++{-+Note [Flattening in error message generation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (C (Maybe (F x))), where F is a type function, and we have+instances+                C (Maybe Int) and C (Maybe a)+Since (F x) might turn into Int, this is an overlap situation, and+indeed (because of flattening) the main solver will have refrained+from solving.  But by the time we get to error message generation, we've+un-flattened the constraint.  So we must *re*-flatten it before looking+up in the instance environment, lest we only report one matching+instance when in fact there are two.++Re-flattening is pretty easy, because we don't need to keep track of+evidence.  We don't re-use the code in TcCanonical because that's in+the TcS monad, and we are in TcM here.++Note [Suggest -fprint-explicit-kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It can be terribly confusing to get an error message like (Trac #9171)+    Couldn't match expected type ‘GetParam Base (GetParam Base Int)’+                with actual type ‘GetParam Base (GetParam Base Int)’+The reason may be that the kinds don't match up.  Typically you'll get+more useful information, but not when it's as a result of ambiguity.+This test suggests -fprint-explicit-kinds when all the ambiguous type+variables are kind variables.+-}++mkAmbigMsg :: Bool -- True when message has to be at beginning of sentence+           -> Ct -> (Bool, SDoc)+mkAmbigMsg prepend_msg ct+  | null ambig_kvs && null ambig_tvs = (False, empty)+  | otherwise                        = (True,  msg)+  where+    (ambig_kvs, ambig_tvs) = getAmbigTkvs ct++    msg |  any isRuntimeUnkSkol ambig_kvs  -- See Note [Runtime skolems]+        || any isRuntimeUnkSkol ambig_tvs+        = vcat [ text "Cannot resolve unknown runtime type"+                 <> plural ambig_tvs <+> pprQuotedList ambig_tvs+               , text "Use :print or :force to determine these types"]++        | not (null ambig_tvs)+        = pp_ambig (text "type") ambig_tvs++        | otherwise  -- All ambiguous kind variabes; suggest -fprint-explicit-kinds+                     -- See Note [Suggest -fprint-explicit-kinds]+        = vcat [ pp_ambig (text "kind") ambig_kvs+               , ppSuggestExplicitKinds ]++    pp_ambig what tkvs+      | prepend_msg -- "Ambiguous type variable 't0'"+      = text "Ambiguous" <+> what <+> text "variable"+        <> plural tkvs <+> pprQuotedList tkvs++      | otherwise -- "The type variable 't0' is ambiguous"+      = text "The" <+> what <+> text "variable" <> plural tkvs+        <+> pprQuotedList tkvs <+> is_or_are tkvs <+> text "ambiguous"++    is_or_are [_] = text "is"+    is_or_are _   = text "are"++pprSkol :: [Implication] -> TcTyVar -> SDoc+pprSkol implics tv+  = case skol_info of+      UnkSkol -> quotes (ppr tv) <+> text "is an unknown type variable"+      _       -> ppr_rigid (pprSkolInfo skol_info)+  where+    Implic { ic_info = skol_info } = getSkolemInfo implics tv+    ppr_rigid pp_info+       = hang (quotes (ppr tv) <+> text "is a rigid type variable bound by")+            2 (sep [ pp_info+                   , text "at" <+> ppr (getSrcSpan tv) ])++getAmbigTkvs :: Ct -> ([Var],[Var])+getAmbigTkvs ct+  = partition (`elemVarSet` dep_tkv_set) ambig_tkvs+  where+    tkvs       = tyCoVarsOfCtList ct+    ambig_tkvs = filter isAmbiguousTyVar tkvs+    dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs)++getSkolemInfo :: [Implication] -> TcTyVar -> Implication+-- Get the skolem info for a type variable+-- from the implication constraint that binds it+getSkolemInfo [] tv+  = pprPanic "No skolem info:" (ppr tv)++getSkolemInfo (implic:implics) tv+  | tv `elem` ic_skols implic = implic+  | otherwise                 = getSkolemInfo implics tv++-----------------------+-- relevantBindings looks at the value environment and finds values whose+-- types mention any of the offending type variables.  It has to be+-- careful to zonk the Id's type first, so it has to be in the monad.+-- We must be careful to pass it a zonked type variable, too.+--+-- We always remove closed top-level bindings, though,+-- since they are never relevant (cf Trac #8233)++relevantBindings :: Bool  -- True <=> filter by tyvar; False <=> no filtering+                          -- See Trac #8191+                 -> ReportErrCtxt -> Ct+                 -> TcM (ReportErrCtxt, SDoc, Ct)+-- Also returns the zonked and tidied CtOrigin of the constraint+relevantBindings want_filtering ctxt ct+  = do { dflags <- getDynFlags+       ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc)+       ; let ct_tvs = tyCoVarsOfCt ct `unionVarSet` extra_tvs++             -- For *kind* errors, report the relevant bindings of the+             -- enclosing *type* equality, because that's more useful for the programmer+             extra_tvs = case tidy_orig of+                             KindEqOrigin t1 m_t2 _ _ -> tyCoVarsOfTypes $+                                                         t1 : maybeToList m_t2+                             _                        -> emptyVarSet+       ; traceTc "relevantBindings" $+           vcat [ ppr ct+                , pprCtOrigin (ctLocOrigin loc)+                , ppr ct_tvs+                , pprWithCommas id [ ppr id <+> dcolon <+> ppr (idType id)+                                   | TcIdBndr id _ <- tcl_bndrs lcl_env ]+                , pprWithCommas id+                    [ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ]++       ; (tidy_env', docs, discards)+              <- go dflags env1 ct_tvs (maxRelevantBinds dflags)+                    emptyVarSet [] False+                    (remove_shadowing $ tcl_bndrs lcl_env)+         -- tcl_bndrs has the innermost bindings first,+         -- which are probably the most relevant ones++       ; let doc = ppUnless (null docs) $+                   hang (text "Relevant bindings include")+                      2 (vcat docs $$ ppWhen discards discardMsg)++             -- Put a zonked, tidied CtOrigin into the Ct+             loc'  = setCtLocOrigin loc tidy_orig+             ct'   = setCtLoc ct loc'+             ctxt' = ctxt { cec_tidy = tidy_env' }++       ; return (ctxt', doc, ct') }+  where+    ev      = ctEvidence ct+    loc     = ctEvLoc ev+    lcl_env = ctLocEnv loc++    run_out :: Maybe Int -> Bool+    run_out Nothing = False+    run_out (Just n) = n <= 0++    dec_max :: Maybe Int -> Maybe Int+    dec_max = fmap (\n -> n - 1)++    ---- fixes #12177+    ---- builds up a list of bindings whose OccName has not been seen before+    remove_shadowing :: [TcIdBinder] -> [TcIdBinder]+    remove_shadowing bindings = reverse $ fst $ foldl+      (\(bindingAcc, seenNames) binding ->+        if (occName binding) `elemOccSet` seenNames -- if we've seen it+          then (bindingAcc, seenNames)              -- skip it+          else (binding:bindingAcc, extendOccSet seenNames (occName binding)))+      ([], emptyOccSet) bindings++    go :: DynFlags -> TidyEnv -> TcTyVarSet -> Maybe Int -> TcTyVarSet -> [SDoc]+       -> Bool                          -- True <=> some filtered out due to lack of fuel+       -> [TcIdBinder]+       -> TcM (TidyEnv, [SDoc], Bool)   -- The bool says if we filtered any out+                                        -- because of lack of fuel+    go _ tidy_env _ _ _ docs discards []+      = return (tidy_env, reverse docs, discards)+    go dflags tidy_env ct_tvs n_left tvs_seen docs discards (tc_bndr : tc_bndrs)+      = case tc_bndr of+          TcIdBndr id top_lvl -> go2 (idName id) (idType id) top_lvl+          TcIdBndr_ExpType name et top_lvl ->+            do { mb_ty <- readExpType_maybe et+                   -- et really should be filled in by now. But there's a chance+                   -- it hasn't, if, say, we're reporting a kind error en route to+                   -- checking a term. See test indexed-types/should_fail/T8129+                   -- Or we are reporting errors from the ambiguity check on+                   -- a local type signature+               ; case mb_ty of+                   Just ty -> go2 name ty top_lvl+                   Nothing -> discard_it  -- No info; discard+               }+      where+        discard_it = go dflags tidy_env ct_tvs n_left tvs_seen docs+                        discards tc_bndrs+        go2 id_name id_type top_lvl+          = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env id_type+               ; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty)+               ; let id_tvs = tyCoVarsOfType tidy_ty+                     doc = sep [ pprPrefixOcc id_name <+> dcolon <+> ppr tidy_ty+                               , nest 2 (parens (text "bound at"+                                    <+> ppr (getSrcLoc id_name)))]+                     new_seen = tvs_seen `unionVarSet` id_tvs++               ; if (want_filtering && not (hasPprDebug dflags)+                                    && id_tvs `disjointVarSet` ct_tvs)+                          -- We want to filter out this binding anyway+                          -- so discard it silently+                 then discard_it++                 else if isTopLevel top_lvl && not (isNothing n_left)+                          -- It's a top-level binding and we have not specified+                          -- -fno-max-relevant-bindings, so discard it silently+                 then discard_it++                 else if run_out n_left && id_tvs `subVarSet` tvs_seen+                          -- We've run out of n_left fuel and this binding only+                          -- mentions already-seen type variables, so discard it+                 then go dflags tidy_env ct_tvs n_left tvs_seen docs+                         True      -- Record that we have now discarded something+                         tc_bndrs++                          -- Keep this binding, decrement fuel+                 else go dflags tidy_env' ct_tvs (dec_max n_left) new_seen+                         (doc:docs) discards tc_bndrs }++discardMsg :: SDoc+discardMsg = text "(Some bindings suppressed;" <+>+             text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)"++-----------------------+warnDefaulting :: [Ct] -> Type -> TcM ()+warnDefaulting wanteds default_ty+  = do { warn_default <- woptM Opt_WarnTypeDefaults+       ; env0 <- tcInitTidyEnv+       ; let tidy_env = tidyFreeTyCoVars env0 $+                        tyCoVarsOfCtsList (listToBag wanteds)+             tidy_wanteds = map (tidyCt tidy_env) wanteds+             (loc, ppr_wanteds) = pprWithArising tidy_wanteds+             warn_msg =+                hang (hsep [ text "Defaulting the following"+                           , text "constraint" <> plural tidy_wanteds+                           , text "to type"+                           , quotes (ppr default_ty) ])+                     2+                     ppr_wanteds+       ; setCtLocM loc $ warnTc (Reason Opt_WarnTypeDefaults) warn_default warn_msg }++{-+Note [Runtime skolems]+~~~~~~~~~~~~~~~~~~~~~~+We want to give a reasonably helpful error message for ambiguity+arising from *runtime* skolems in the debugger.  These+are created by in RtClosureInspect.zonkRTTIType.++************************************************************************+*                                                                      *+                 Error from the canonicaliser+         These ones are called *during* constraint simplification+*                                                                      *+************************************************************************+-}++solverDepthErrorTcS :: CtLoc -> TcType -> TcM a+solverDepthErrorTcS loc ty+  = setCtLocM loc $+    do { ty <- zonkTcType ty+       ; env0 <- tcInitTidyEnv+       ; let tidy_env     = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty)+             tidy_ty      = tidyType tidy_env ty+             msg+               = vcat [ text "Reduction stack overflow; size =" <+> ppr depth+                      , hang (text "When simplifying the following type:")+                           2 (ppr tidy_ty)+                      , note ]+       ; failWithTcM (tidy_env, msg) }+  where+    depth = ctLocDepth loc+    note = vcat+      [ text "Use -freduction-depth=0 to disable this check"+      , text "(any upper bound you could choose might fail unpredictably with"+      , text " minor updates to GHC, so disabling the check is recommended if"+      , text " you're sure that type checking should terminate)" ]
+ typecheck/TcEvidence.hs view
@@ -0,0 +1,946 @@+-- (c) The University of Glasgow 2006++{-# LANGUAGE CPP, DeriveDataTypeable #-}++module TcEvidence (++  -- HsWrapper+  HsWrapper(..),+  (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams,+  mkWpLams, mkWpLet, mkWpCastN, mkWpCastR, collectHsWrapBinders,+  mkWpFun, mkWpFuns, idHsWrapper, isIdHsWrapper, pprHsWrapper,++  -- Evidence bindings+  TcEvBinds(..), EvBindsVar(..),+  EvBindMap(..), emptyEvBindMap, extendEvBinds,+  lookupEvBind, evBindMapBinds, foldEvBindMap, isEmptyEvBindMap,+  EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind,+  sccEvBinds, evBindVar,+  EvTerm(..), mkEvCast, evVarsOfTerm, mkEvScSelectors,+  EvLit(..), evTermCoercion,+  EvCallStack(..),+  EvTypeable(..),++  -- TcCoercion+  TcCoercion, TcCoercionR, TcCoercionN, TcCoercionP, CoercionHole,+  Role(..), LeftOrRight(..), pickLR,+  mkTcReflCo, mkTcNomReflCo, mkTcRepReflCo,+  mkTcTyConAppCo, mkTcAppCo, mkTcFunCo,+  mkTcAxInstCo, mkTcUnbranchedAxInstCo, mkTcForAllCo, mkTcForAllCos,+  mkTcSymCo, mkTcTransCo, mkTcNthCo, mkTcLRCo, mkTcSubCo, maybeTcSubCo,+  tcDowngradeRole,+  mkTcAxiomRuleCo, mkTcCoherenceLeftCo, mkTcCoherenceRightCo, mkTcPhantomCo,+  mkTcKindCo,+  tcCoercionKind, coVarsOfTcCo,+  mkTcCoVarCo,+  isTcReflCo,+  tcCoercionRole,+  unwrapIP, wrapIP+  ) where+#include "HsVersions.h"++import Var+import CoAxiom+import Coercion+import PprCore ()   -- Instance OutputableBndr TyVar+import TcType+import Type+import TyCon+import Class( Class )+import PrelNames+import DynFlags   ( gopt, GeneralFlag(Opt_PrintTypecheckerElaboration) )+import VarEnv+import VarSet+import Name+import Pair++import Util+import Bag+import Digraph+import qualified Data.Data as Data+import Outputable+import FastString+import SrcLoc+import Data.IORef( IORef )+import UniqSet++{-+Note [TcCoercions]+~~~~~~~~~~~~~~~~~~+| TcCoercions are a hack used by the typechecker. Normally,+Coercions have free variables of type (a ~# b): we call these+CoVars. However, the type checker passes around equality evidence+(boxed up) at type (a ~ b).++An TcCoercion is simply a Coercion whose free variables have may be either+boxed or unboxed. After we are done with typechecking the desugarer finds the+boxed free variables, unboxes them, and creates a resulting real Coercion with+kosher free variables.++-}++type TcCoercion  = Coercion+type TcCoercionN = CoercionN    -- A Nominal          coercion ~N+type TcCoercionR = CoercionR    -- A Representational coercion ~R+type TcCoercionP = CoercionP    -- a phantom coercion++mkTcReflCo             :: Role -> TcType -> TcCoercion+mkTcSymCo              :: TcCoercion -> TcCoercion+mkTcTransCo            :: TcCoercion -> TcCoercion -> TcCoercion+mkTcNomReflCo          :: TcType -> TcCoercionN+mkTcRepReflCo          :: TcType -> TcCoercionR+mkTcTyConAppCo         :: Role -> TyCon -> [TcCoercion] -> TcCoercion+mkTcAppCo              :: TcCoercion -> TcCoercionN -> TcCoercion+mkTcFunCo              :: Role -> TcCoercion -> TcCoercion -> TcCoercion+mkTcAxInstCo           :: Role -> CoAxiom br -> BranchIndex+                       -> [TcType] -> [TcCoercion] -> TcCoercion+mkTcUnbranchedAxInstCo :: CoAxiom Unbranched -> [TcType]+                       -> [TcCoercion] -> TcCoercionR+mkTcForAllCo           :: TyVar -> TcCoercionN -> TcCoercion -> TcCoercion+mkTcForAllCos          :: [(TyVar, TcCoercionN)] -> TcCoercion -> TcCoercion+mkTcNthCo              :: Int -> TcCoercion -> TcCoercion+mkTcLRCo               :: LeftOrRight -> TcCoercion -> TcCoercion+mkTcSubCo              :: TcCoercionN -> TcCoercionR+maybeTcSubCo           :: EqRel -> TcCoercion -> TcCoercion+tcDowngradeRole        :: Role -> Role -> TcCoercion -> TcCoercion+mkTcAxiomRuleCo        :: CoAxiomRule -> [TcCoercion] -> TcCoercionR+mkTcCoherenceLeftCo    :: TcCoercion -> TcCoercionN -> TcCoercion+mkTcCoherenceRightCo   :: TcCoercion -> TcCoercionN -> TcCoercion+mkTcPhantomCo          :: TcCoercionN -> TcType -> TcType -> TcCoercionP+mkTcKindCo             :: TcCoercion -> TcCoercionN+mkTcCoVarCo            :: CoVar -> TcCoercion++tcCoercionKind         :: TcCoercion -> Pair TcType+tcCoercionRole         :: TcCoercion -> Role+coVarsOfTcCo           :: TcCoercion -> TcTyCoVarSet+isTcReflCo             :: TcCoercion -> Bool++mkTcReflCo             = mkReflCo+mkTcSymCo              = mkSymCo+mkTcTransCo            = mkTransCo+mkTcNomReflCo          = mkNomReflCo+mkTcRepReflCo          = mkRepReflCo+mkTcTyConAppCo         = mkTyConAppCo+mkTcAppCo              = mkAppCo+mkTcFunCo              = mkFunCo+mkTcAxInstCo           = mkAxInstCo+mkTcUnbranchedAxInstCo = mkUnbranchedAxInstCo Representational+mkTcForAllCo           = mkForAllCo+mkTcForAllCos          = mkForAllCos+mkTcNthCo              = mkNthCo+mkTcLRCo               = mkLRCo+mkTcSubCo              = mkSubCo+maybeTcSubCo           = maybeSubCo+tcDowngradeRole        = downgradeRole+mkTcAxiomRuleCo        = mkAxiomRuleCo+mkTcCoherenceLeftCo    = mkCoherenceLeftCo+mkTcCoherenceRightCo   = mkCoherenceRightCo+mkTcPhantomCo          = mkPhantomCo+mkTcKindCo             = mkKindCo+mkTcCoVarCo            = mkCoVarCo++tcCoercionKind         = coercionKind+tcCoercionRole         = coercionRole+coVarsOfTcCo           = coVarsOfCo+isTcReflCo             = isReflCo+++{-+%************************************************************************+%*                                                                      *+                  HsWrapper+*                                                                      *+************************************************************************+-}++data HsWrapper+  = WpHole                      -- The identity coercion++  | WpCompose HsWrapper HsWrapper+       -- (wrap1 `WpCompose` wrap2)[e] = wrap1[ wrap2[ e ]]+       --+       -- Hence  (\a. []) `WpCompose` (\b. []) = (\a b. [])+       -- But    ([] a)   `WpCompose` ([] b)   = ([] b a)++  | WpFun HsWrapper HsWrapper TcType SDoc+       -- (WpFun wrap1 wrap2 t1)[e] = \(x:t1). wrap2[ e wrap1[x] ]+       -- So note that if  wrap1 :: exp_arg <= act_arg+       --                  wrap2 :: act_res <= exp_res+       --           then   WpFun wrap1 wrap2 : (act_arg -> arg_res) <= (exp_arg -> exp_res)+       -- This isn't the same as for mkFunCo, but it has to be this way+       -- because we can't use 'sym' to flip around these HsWrappers+       -- The TcType is the "from" type of the first wrapper+       -- The SDoc explains the circumstances under which we have created this+       -- WpFun, in case we run afoul of levity polymorphism restrictions in+       -- the desugarer. See Note [Levity polymorphism checking] in DsMonad++  | WpCast TcCoercionR        -- A cast:  [] `cast` co+                              -- Guaranteed not the identity coercion+                              -- At role Representational++        -- Evidence abstraction and application+        -- (both dictionaries and coercions)+  | WpEvLam EvVar               -- \d. []       the 'd' is an evidence variable+  | WpEvApp EvTerm              -- [] d         the 'd' is evidence for a constraint+        -- Kind and Type abstraction and application+  | WpTyLam TyVar       -- \a. []  the 'a' is a type/kind variable (not coercion var)+  | WpTyApp KindOrType  -- [] t    the 't' is a type (not coercion)+++  | WpLet TcEvBinds             -- Non-empty (or possibly non-empty) evidence bindings,+                                -- so that the identity coercion is always exactly WpHole++-- Cannot derive Data instance because SDoc is not Data (it stores a function).+-- So we do it manually:+instance Data.Data HsWrapper where+  gfoldl _ z WpHole             = z WpHole+  gfoldl k z (WpCompose a1 a2)  = z WpCompose `k` a1 `k` a2+  gfoldl k z (WpFun a1 a2 a3 _) = z wpFunEmpty `k` a1 `k` a2 `k` a3+  gfoldl k z (WpCast a1)        = z WpCast `k` a1+  gfoldl k z (WpEvLam a1)       = z WpEvLam `k` a1+  gfoldl k z (WpEvApp a1)       = z WpEvApp `k` a1+  gfoldl k z (WpTyLam a1)       = z WpTyLam `k` a1+  gfoldl k z (WpTyApp a1)       = z WpTyApp `k` a1+  gfoldl k z (WpLet a1)         = z WpLet `k` a1++  gunfold k z c = case Data.constrIndex c of+                    1 -> z WpHole+                    2 -> k (k (z WpCompose))+                    3 -> k (k (k (z wpFunEmpty)))+                    4 -> k (z WpCast)+                    5 -> k (z WpEvLam)+                    6 -> k (z WpEvApp)+                    7 -> k (z WpTyLam)+                    8 -> k (z WpTyApp)+                    _ -> k (z WpLet)++  toConstr WpHole          = wpHole_constr+  toConstr (WpCompose _ _) = wpCompose_constr+  toConstr (WpFun _ _ _ _) = wpFun_constr+  toConstr (WpCast _)      = wpCast_constr+  toConstr (WpEvLam _)     = wpEvLam_constr+  toConstr (WpEvApp _)     = wpEvApp_constr+  toConstr (WpTyLam _)     = wpTyLam_constr+  toConstr (WpTyApp _)     = wpTyApp_constr+  toConstr (WpLet _)       = wpLet_constr++  dataTypeOf _ = hsWrapper_dataType++hsWrapper_dataType :: Data.DataType+hsWrapper_dataType+  = Data.mkDataType "HsWrapper"+      [ wpHole_constr, wpCompose_constr, wpFun_constr, wpCast_constr+      , wpEvLam_constr, wpEvApp_constr, wpTyLam_constr, wpTyApp_constr+      , wpLet_constr]++wpHole_constr, wpCompose_constr, wpFun_constr, wpCast_constr, wpEvLam_constr,+  wpEvApp_constr, wpTyLam_constr, wpTyApp_constr, wpLet_constr :: Data.Constr+wpHole_constr    = mkHsWrapperConstr "WpHole"+wpCompose_constr = mkHsWrapperConstr "WpCompose"+wpFun_constr     = mkHsWrapperConstr "WpFun"+wpCast_constr    = mkHsWrapperConstr "WpCast"+wpEvLam_constr   = mkHsWrapperConstr "WpEvLam"+wpEvApp_constr   = mkHsWrapperConstr "WpEvApp"+wpTyLam_constr   = mkHsWrapperConstr "WpTyLam"+wpTyApp_constr   = mkHsWrapperConstr "WpTyApp"+wpLet_constr     = mkHsWrapperConstr "WpLet"++mkHsWrapperConstr :: String -> Data.Constr+mkHsWrapperConstr name = Data.mkConstr hsWrapper_dataType name [] Data.Prefix++wpFunEmpty :: HsWrapper -> HsWrapper -> TcType -> HsWrapper+wpFunEmpty c1 c2 t1 = WpFun c1 c2 t1 empty++(<.>) :: HsWrapper -> HsWrapper -> HsWrapper+WpHole <.> c = c+c <.> WpHole = c+c1 <.> c2    = c1 `WpCompose` c2++mkWpFun :: HsWrapper -> HsWrapper+        -> TcType    -- the "from" type of the first wrapper+        -> TcType    -- either type of the second wrapper (used only when the+                     -- second wrapper is the identity)+        -> SDoc      -- what caused you to want a WpFun? Something like "When converting ..."+        -> HsWrapper+mkWpFun WpHole       WpHole       _  _  _ = WpHole+mkWpFun WpHole       (WpCast co2) t1 _  _ = WpCast (mkTcFunCo Representational (mkTcRepReflCo t1) co2)+mkWpFun (WpCast co1) WpHole       _  t2 _ = WpCast (mkTcFunCo Representational (mkTcSymCo co1) (mkTcRepReflCo t2))+mkWpFun (WpCast co1) (WpCast co2) _  _  _ = WpCast (mkTcFunCo Representational (mkTcSymCo co1) co2)+mkWpFun co1          co2          t1 _  d = WpFun co1 co2 t1 d++-- | @mkWpFuns [(ty1, wrap1), (ty2, wrap2)] ty_res wrap_res@,+-- where @wrap1 :: ty1 "->" ty1'@ and @wrap2 :: ty2 "->" ty2'@,+-- @wrap3 :: ty3 "->" ty3'@ and @ty_res@ is /either/ @ty3@ or @ty3'@,+-- gives a wrapper @(ty1' -> ty2' -> ty3) "->" (ty1 -> ty2 -> ty3')@.+-- Notice that the result wrapper goes the other way round to all+-- the others. This is a result of sub-typing contravariance.+-- The SDoc is a description of what you were doing when you called mkWpFuns.+mkWpFuns :: [(TcType, HsWrapper)] -> TcType -> HsWrapper -> SDoc -> HsWrapper+mkWpFuns args res_ty res_wrap doc = snd $ go args res_ty res_wrap+  where+    go [] res_ty res_wrap = (res_ty, res_wrap)+    go ((arg_ty, arg_wrap) : args) res_ty res_wrap+      = let (tail_ty, tail_wrap) = go args res_ty res_wrap in+        (arg_ty `mkFunTy` tail_ty, mkWpFun arg_wrap tail_wrap arg_ty tail_ty doc)++mkWpCastR :: TcCoercionR -> HsWrapper+mkWpCastR co+  | isTcReflCo co = WpHole+  | otherwise     = ASSERT2(tcCoercionRole co == Representational, ppr co)+                    WpCast co++mkWpCastN :: TcCoercionN -> HsWrapper+mkWpCastN co+  | isTcReflCo co = WpHole+  | otherwise     = ASSERT2(tcCoercionRole co == Nominal, ppr co)+                    WpCast (mkTcSubCo co)+    -- The mkTcSubCo converts Nominal to Representational++mkWpTyApps :: [Type] -> HsWrapper+mkWpTyApps tys = mk_co_app_fn WpTyApp tys++mkWpEvApps :: [EvTerm] -> HsWrapper+mkWpEvApps args = mk_co_app_fn WpEvApp args++mkWpEvVarApps :: [EvVar] -> HsWrapper+mkWpEvVarApps vs = mk_co_app_fn WpEvApp (map EvId vs)++mkWpTyLams :: [TyVar] -> HsWrapper+mkWpTyLams ids = mk_co_lam_fn WpTyLam ids++mkWpLams :: [Var] -> HsWrapper+mkWpLams ids = mk_co_lam_fn WpEvLam ids++mkWpLet :: TcEvBinds -> HsWrapper+-- This no-op is a quite a common case+mkWpLet (EvBinds b) | isEmptyBag b = WpHole+mkWpLet ev_binds                   = WpLet ev_binds++mk_co_lam_fn :: (a -> HsWrapper) -> [a] -> HsWrapper+mk_co_lam_fn f as = foldr (\x wrap -> f x <.> wrap) WpHole as++mk_co_app_fn :: (a -> HsWrapper) -> [a] -> HsWrapper+-- For applications, the *first* argument must+-- come *last* in the composition sequence+mk_co_app_fn f as = foldr (\x wrap -> wrap <.> f x) WpHole as++idHsWrapper :: HsWrapper+idHsWrapper = WpHole++isIdHsWrapper :: HsWrapper -> Bool+isIdHsWrapper WpHole = True+isIdHsWrapper _      = False++collectHsWrapBinders :: HsWrapper -> ([Var], HsWrapper)+-- Collect the outer lambda binders of a HsWrapper,+-- stopping as soon as you get to a non-lambda binder+collectHsWrapBinders wrap = go wrap []+  where+    -- go w ws = collectHsWrapBinders (w <.> w1 <.> ... <.> wn)+    go :: HsWrapper -> [HsWrapper] -> ([Var], HsWrapper)+    go (WpEvLam v)       wraps = add_lam v (gos wraps)+    go (WpTyLam v)       wraps = add_lam v (gos wraps)+    go (WpCompose w1 w2) wraps = go w1 (w2:wraps)+    go wrap              wraps = ([], foldl (<.>) wrap wraps)++    gos []     = ([], WpHole)+    gos (w:ws) = go w ws++    add_lam v (vs,w) = (v:vs, w)++{-+************************************************************************+*                                                                      *+                  Evidence bindings+*                                                                      *+************************************************************************+-}++data TcEvBinds+  = TcEvBinds           -- Mutable evidence bindings+       EvBindsVar       -- Mutable because they are updated "later"+                        --    when an implication constraint is solved++  | EvBinds             -- Immutable after zonking+       (Bag EvBind)++data EvBindsVar+  = EvBindsVar {+      ebv_uniq :: Unique,+         -- The Unique is for debug printing only++      ebv_binds :: IORef EvBindMap,+      -- The main payload: the value-level evidence bindings+      --     (dictionaries etc)++      ebv_tcvs :: IORef CoVarSet+      -- The free coercion vars of the (rhss of) the coercion bindings+      --+      -- Coercions don't actually have bindings+      -- because we plug them in-place (via a mutable+      -- variable); but we keep their free variables+      -- so that we can report unused given constraints+      -- See Note [Tracking redundant constraints] in TcSimplify+    }++instance Data.Data TcEvBinds where+  -- Placeholder; we can't travers into TcEvBinds+  toConstr _   = abstractConstr "TcEvBinds"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = Data.mkNoRepType "TcEvBinds"++-----------------+newtype EvBindMap+  = EvBindMap {+       ev_bind_varenv :: DVarEnv EvBind+    }       -- Map from evidence variables to evidence terms+            -- We use @DVarEnv@ here to get deterministic ordering when we+            -- turn it into a Bag.+            -- If we don't do that, when we generate let bindings for+            -- dictionaries in dsTcEvBinds they will be generated in random+            -- order.+            --+            -- For example:+            --+            -- let $dEq = GHC.Classes.$fEqInt in+            -- let $$dNum = GHC.Num.$fNumInt in ...+            --+            -- vs+            --+            -- let $dNum = GHC.Num.$fNumInt in+            -- let $dEq = GHC.Classes.$fEqInt in ...+            --+            -- See Note [Deterministic UniqFM] in UniqDFM for explanation why+            -- @UniqFM@ can lead to nondeterministic order.++emptyEvBindMap :: EvBindMap+emptyEvBindMap = EvBindMap { ev_bind_varenv = emptyDVarEnv }++extendEvBinds :: EvBindMap -> EvBind -> EvBindMap+extendEvBinds bs ev_bind+  = EvBindMap { ev_bind_varenv = extendDVarEnv (ev_bind_varenv bs)+                                               (eb_lhs ev_bind)+                                               ev_bind }++isEmptyEvBindMap :: EvBindMap -> Bool+isEmptyEvBindMap (EvBindMap m) = isEmptyDVarEnv m++lookupEvBind :: EvBindMap -> EvVar -> Maybe EvBind+lookupEvBind bs = lookupDVarEnv (ev_bind_varenv bs)++evBindMapBinds :: EvBindMap -> Bag EvBind+evBindMapBinds = foldEvBindMap consBag emptyBag++foldEvBindMap :: (EvBind -> a -> a) -> a -> EvBindMap -> a+foldEvBindMap k z bs = foldDVarEnv k z (ev_bind_varenv bs)++instance Outputable EvBindMap where+  ppr (EvBindMap m) = ppr m++-----------------+-- All evidence is bound by EvBinds; no side effects+data EvBind+  = EvBind { eb_lhs      :: EvVar+           , eb_rhs      :: EvTerm+           , eb_is_given :: Bool  -- True <=> given+                 -- See Note [Tracking redundant constraints] in TcSimplify+    }++evBindVar :: EvBind -> EvVar+evBindVar = eb_lhs++mkWantedEvBind :: EvVar -> EvTerm -> EvBind+mkWantedEvBind ev tm = EvBind { eb_is_given = False, eb_lhs = ev, eb_rhs = tm }+++mkGivenEvBind :: EvVar -> EvTerm -> EvBind+mkGivenEvBind ev tm = EvBind { eb_is_given = True, eb_lhs = ev, eb_rhs = tm }++data EvTerm+  = EvId EvId                    -- Any sort of evidence Id, including coercions++  | EvCoercion TcCoercion        -- coercion bindings+                                 -- See Note [Coercion evidence terms]++  | EvCast EvTerm TcCoercionR    -- d |> co++  | EvDFunApp DFunId             -- Dictionary instance application+       [Type] [EvTerm]++  | EvDelayedError Type FastString  -- Used with Opt_DeferTypeErrors+                               -- See Note [Deferring coercion errors to runtime]+                               -- in TcSimplify++  | EvSuperClass EvTerm Int      -- n'th superclass. Used for both equalities and+                                 -- dictionaries, even though the former have no+                                 -- selector Id.  We count up from _0_++  | EvLit EvLit       -- Dictionary for KnownNat and KnownSymbol classes.+                      -- Note [KnownNat & KnownSymbol and EvLit]++  | EvCallStack EvCallStack      -- Dictionary for CallStack implicit parameters++  | EvTypeable Type EvTypeable   -- Dictionary for (Typeable ty)++  | EvSelector Id [Type] [EvTerm] -- Selector id plus the types at which it+                                  -- should be instantiated, used for HasField+                                  -- dictionaries; see Note [HasField instances]+                                  -- in TcInterface++  deriving Data.Data+++-- | Instructions on how to make a 'Typeable' dictionary.+-- See Note [Typeable evidence terms]+data EvTypeable+  = EvTypeableTyCon TyCon [EvTerm]+    -- ^ Dictionary for @Typeable T@ where @T@ is a type constructor with all of+    -- its kind variables saturated. The @[EvTerm]@ is @Typeable@ evidence for+    -- the applied kinds..++  | EvTypeableTyApp EvTerm EvTerm+    -- ^ Dictionary for @Typeable (s t)@,+    -- given a dictionaries for @s@ and @t@.++  | EvTypeableTrFun EvTerm EvTerm+    -- ^ Dictionary for @Typeable (s -> t)@,+    -- given a dictionaries for @s@ and @t@.++  | EvTypeableTyLit EvTerm+    -- ^ Dictionary for a type literal,+    -- e.g. @Typeable "foo"@ or @Typeable 3@+    -- The 'EvTerm' is evidence of, e.g., @KnownNat 3@+    -- (see Trac #10348)+  deriving Data.Data++data EvLit+  = EvNum Integer+  | EvStr FastString+    deriving Data.Data++-- | Evidence for @CallStack@ implicit parameters.+data EvCallStack+  -- See Note [Overview of implicit CallStacks]+  = EvCsEmpty+  | EvCsPushCall Name RealSrcSpan EvTerm+    -- ^ @EvCsPushCall name loc stk@ represents a call to @name@, occurring at+    -- @loc@, in a calling context @stk@.+  deriving Data.Data++{-+Note [Typeable evidence terms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The EvTypeable data type looks isomorphic to Type, but the EvTerms+inside can be EvIds.  Eg+    f :: forall a. Typeable a => a -> TypeRep+    f x = typeRep (undefined :: Proxy [a])+Here for the (Typeable [a]) dictionary passed to typeRep we make+evidence+    dl :: Typeable [a] = EvTypeable [a]+                            (EvTypeableTyApp (EvTypeableTyCon []) (EvId d))+where+    d :: Typable a+is the lambda-bound dictionary passed into f.++Note [Coercion evidence terms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A "coercion evidence term" takes one of these forms+   co_tm ::= EvId v           where v :: t1 ~# t2+           | EvCoercion co+           | EvCast co_tm co++We do quite often need to get a TcCoercion from an EvTerm; see+'evTermCoercion'.++INVARIANT: The evidence for any constraint with type (t1 ~# t2) is+a coercion evidence term.  Consider for example+    [G] d :: F Int a+If we have+    ax7 a :: F Int a ~ (a ~ Bool)+then we do NOT generate the constraint+    [G] (d |> ax7 a) :: a ~ Bool+because that does not satisfy the invariant (d is not a coercion variable).+Instead we make a binding+    g1 :: a~Bool = g |> ax7 a+and the constraint+    [G] g1 :: a~Bool+See Trac [7238] and Note [Bind new Givens immediately] in TcRnTypes++Note [EvBinds/EvTerm]+~~~~~~~~~~~~~~~~~~~~~+How evidence is created and updated. Bindings for dictionaries,+and coercions and implicit parameters are carried around in TcEvBinds+which during constraint generation and simplification is always of the+form (TcEvBinds ref). After constraint simplification is finished it+will be transformed to t an (EvBinds ev_bag).++Evidence for coercions *SHOULD* be filled in using the TcEvBinds+However, all EvVars that correspond to *wanted* coercion terms in+an EvBind must be mutable variables so that they can be readily+inlined (by zonking) after constraint simplification is finished.++Conclusion: a new wanted coercion variable should be made mutable.+[Notice though that evidence variables that bind coercion terms+ from super classes will be "given" and hence rigid]+++Note [KnownNat & KnownSymbol and EvLit]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A part of the type-level literals implementation are the classes+"KnownNat" and "KnownSymbol", which provide a "smart" constructor for+defining singleton values.  Here is the key stuff from GHC.TypeLits++  class KnownNat (n :: Nat) where+    natSing :: SNat n++  newtype SNat (n :: Nat) = SNat Integer++Conceptually, this class has infinitely many instances:++  instance KnownNat 0       where natSing = SNat 0+  instance KnownNat 1       where natSing = SNat 1+  instance KnownNat 2       where natSing = SNat 2+  ...++In practice, we solve `KnownNat` predicates in the type-checker+(see typecheck/TcInteract.hs) because we can't have infinitely many instances.+The evidence (aka "dictionary") for `KnownNat` is of the form `EvLit (EvNum n)`.++We make the following assumptions about dictionaries in GHC:+  1. The "dictionary" for classes with a single method---like `KnownNat`---is+     a newtype for the type of the method, so using a evidence amounts+     to a coercion, and+  2. Newtypes use the same representation as their definition types.++So, the evidence for `KnownNat` is just a value of the representation type,+wrapped in two newtype constructors: one to make it into a `SNat` value,+and another to make it into a `KnownNat` dictionary.++Also note that `natSing` and `SNat` are never actually exposed from the+library---they are just an implementation detail.  Instead, users see+a more convenient function, defined in terms of `natSing`:++  natVal :: KnownNat n => proxy n -> Integer++The reason we don't use this directly in the class is that it is simpler+and more efficient to pass around an integer rather than an entier function,+especially when the `KnowNat` evidence is packaged up in an existential.++The story for kind `Symbol` is analogous:+  * class KnownSymbol+  * newtype SSymbol+  * Evidence: EvLit (EvStr n)+++Note [Overview of implicit CallStacks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(See https://ghc.haskell.org/trac/ghc/wiki/ExplicitCallStack/ImplicitLocations)++The goal of CallStack evidence terms is to reify locations+in the program source as runtime values, without any support+from the RTS. We accomplish this by assigning a special meaning+to constraints of type GHC.Stack.Types.HasCallStack, an alias++  type HasCallStack = (?callStack :: CallStack)++Implicit parameters of type GHC.Stack.Types.CallStack (the name is not+important) are solved in three steps:++1. Occurrences of CallStack IPs are solved directly from the given IP,+   just like a regular IP. For example, the occurrence of `?stk` in++     error :: (?stk :: CallStack) => String -> a+     error s = raise (ErrorCall (s ++ prettyCallStack ?stk))++   will be solved for the `?stk` in `error`s context as before.++2. In a function call, instead of simply passing the given IP, we first+   append the current call-site to it. For example, consider a+   call to the callstack-aware `error` above.++     undefined :: (?stk :: CallStack) => a+     undefined = error "undefined!"++   Here we want to take the given `?stk` and append the current+   call-site, before passing it to `error`. In essence, we want to+   rewrite `error "undefined!"` to++     let ?stk = pushCallStack <error's location> ?stk+     in error "undefined!"++   We achieve this effect by emitting a NEW wanted++     [W] d :: IP "stk" CallStack++   from which we build the evidence term++     EvCsPushCall "error" <error's location> (EvId d)++   that we use to solve the call to `error`. The new wanted `d` will+   then be solved per rule (1), ie as a regular IP.++   (see TcInteract.interactDict)++3. We default any insoluble CallStacks to the empty CallStack. Suppose+   `undefined` did not request a CallStack, ie++     undefinedNoStk :: a+     undefinedNoStk = error "undefined!"++   Under the usual IP rules, the new wanted from rule (2) would be+   insoluble as there's no given IP from which to solve it, so we+   would get an "unbound implicit parameter" error.++   We don't ever want to emit an insoluble CallStack IP, so we add a+   defaulting pass to default any remaining wanted CallStacks to the+   empty CallStack with the evidence term++     EvCsEmpty++   (see TcSimplify.simpl_top and TcSimplify.defaultCallStacks)++This provides a lightweight mechanism for building up call-stacks+explicitly, but is notably limited by the fact that the stack will+stop at the first function whose type does not include a CallStack IP.+For example, using the above definition of `undefined`:++  head :: [a] -> a+  head []    = undefined+  head (x:_) = x++  g = head []++the resulting CallStack will include the call to `undefined` in `head`+and the call to `error` in `undefined`, but *not* the call to `head`+in `g`, because `head` did not explicitly request a CallStack.+++Important Details:+- GHC should NEVER report an insoluble CallStack constraint.++- GHC should NEVER infer a CallStack constraint unless one was requested+  with a partial type signature (See TcType.pickQuantifiablePreds).++- A CallStack (defined in GHC.Stack.Types) is a [(String, SrcLoc)],+  where the String is the name of the binder that is used at the+  SrcLoc. SrcLoc is also defined in GHC.Stack.Types and contains the+  package/module/file name, as well as the full source-span. Both+  CallStack and SrcLoc are kept abstract so only GHC can construct new+  values.++- We will automatically solve any wanted CallStack regardless of the+  name of the IP, i.e.++    f = show (?stk :: CallStack)+    g = show (?loc :: CallStack)++  are both valid. However, we will only push new SrcLocs onto existing+  CallStacks when the IP names match, e.g. in++    head :: (?loc :: CallStack) => [a] -> a+    head [] = error (show (?stk :: CallStack))++  the printed CallStack will NOT include head's call-site. This reflects the+  standard scoping rules of implicit-parameters.++- An EvCallStack term desugars to a CoreExpr of type `IP "some str" CallStack`.+  The desugarer will need to unwrap the IP newtype before pushing a new+  call-site onto a given stack (See DsBinds.dsEvCallStack)++- When we emit a new wanted CallStack from rule (2) we set its origin to+  `IPOccOrigin ip_name` instead of the original `OccurrenceOf func`+  (see TcInteract.interactDict).++  This is a bit shady, but is how we ensure that the new wanted is+  solved like a regular IP.++-}++mkEvCast :: EvTerm -> TcCoercion -> EvTerm+mkEvCast ev lco+  | ASSERT2(tcCoercionRole lco == Representational, (vcat [text "Coercion of wrong role passed to mkEvCast:", ppr ev, ppr lco]))+    isTcReflCo lco = ev+  | otherwise      = EvCast ev lco++mkEvScSelectors :: EvTerm -> Class -> [TcType] -> [(TcPredType, EvTerm)]+mkEvScSelectors ev cls tys+   = zipWith mk_pr (immSuperClasses cls tys) [0..]+  where+    mk_pr pred i = (pred, EvSuperClass ev i)++emptyTcEvBinds :: TcEvBinds+emptyTcEvBinds = EvBinds emptyBag++isEmptyTcEvBinds :: TcEvBinds -> Bool+isEmptyTcEvBinds (EvBinds b)    = isEmptyBag b+isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds"+++evTermCoercion :: EvTerm -> TcCoercion+-- Applied only to EvTerms of type (s~t)+-- See Note [Coercion evidence terms]+evTermCoercion (EvId v)        = mkCoVarCo v+evTermCoercion (EvCoercion co) = co+evTermCoercion (EvCast tm co)  = mkCoCast (evTermCoercion tm) co+evTermCoercion tm = pprPanic "evTermCoercion" (ppr tm)++evVarsOfTerm :: EvTerm -> VarSet+evVarsOfTerm (EvId v)             = unitVarSet v+evVarsOfTerm (EvCoercion co)      = coVarsOfCo co+evVarsOfTerm (EvDFunApp _ _ evs)  = mapUnionVarSet evVarsOfTerm evs+evVarsOfTerm (EvSuperClass v _)   = evVarsOfTerm v+evVarsOfTerm (EvCast tm co)       = evVarsOfTerm tm `unionVarSet` coVarsOfCo co+evVarsOfTerm (EvDelayedError _ _) = emptyVarSet+evVarsOfTerm (EvLit _)            = emptyVarSet+evVarsOfTerm (EvCallStack cs)     = evVarsOfCallStack cs+evVarsOfTerm (EvTypeable _ ev)    = evVarsOfTypeable ev+evVarsOfTerm (EvSelector _ _ evs) = mapUnionVarSet evVarsOfTerm evs++evVarsOfTerms :: [EvTerm] -> VarSet+evVarsOfTerms = mapUnionVarSet evVarsOfTerm++-- | Do SCC analysis on a bag of 'EvBind's.+sccEvBinds :: Bag EvBind -> [SCC EvBind]+sccEvBinds bs = stronglyConnCompFromEdgedVerticesUniq edges+  where+    edges :: [(EvBind, EvVar, [EvVar])]+    edges = foldrBag ((:) . mk_node) [] bs++    mk_node :: EvBind -> (EvBind, EvVar, [EvVar])+    mk_node b@(EvBind { eb_lhs = var, eb_rhs = term })+      = (b, var, nonDetEltsUniqSet (evVarsOfTerm term `unionVarSet`+                                coVarsOfType (varType var)))+      -- It's OK to use nonDetEltsUniqSet here as stronglyConnCompFromEdgedVertices+      -- is still deterministic even if the edges are in nondeterministic order+      -- as explained in Note [Deterministic SCC] in Digraph.++evVarsOfCallStack :: EvCallStack -> VarSet+evVarsOfCallStack cs = case cs of+  EvCsEmpty -> emptyVarSet+  EvCsPushCall _ _ tm -> evVarsOfTerm tm++evVarsOfTypeable :: EvTypeable -> VarSet+evVarsOfTypeable ev =+  case ev of+    EvTypeableTyCon _ e   -> mapUnionVarSet evVarsOfTerm e+    EvTypeableTyApp e1 e2 -> evVarsOfTerms [e1,e2]+    EvTypeableTrFun e1 e2 -> evVarsOfTerms [e1,e2]+    EvTypeableTyLit e     -> evVarsOfTerm e++{-+************************************************************************+*                                                                      *+                  Pretty printing+*                                                                      *+************************************************************************+-}++instance Outputable HsWrapper where+  ppr co_fn = pprHsWrapper co_fn (no_parens (text "<>"))++pprHsWrapper :: HsWrapper -> (Bool -> SDoc) -> SDoc+-- With -fprint-typechecker-elaboration, print the wrapper+--   otherwise just print what's inside+-- The pp_thing_inside function takes Bool to say whether+--    it's in a position that needs parens for a non-atomic thing+pprHsWrapper wrap pp_thing_inside+  = sdocWithDynFlags $ \ dflags ->+    if gopt Opt_PrintTypecheckerElaboration dflags+    then help pp_thing_inside wrap False+    else pp_thing_inside False+  where+    help :: (Bool -> SDoc) -> HsWrapper -> Bool -> SDoc+    -- True  <=> appears in function application position+    -- False <=> appears as body of let or lambda+    help it WpHole             = it+    help it (WpCompose f1 f2)  = help (help it f2) f1+    help it (WpFun f1 f2 t1 _) = add_parens $ text "\\(x" <> dcolon <> ppr t1 <> text ")." <+>+                                              help (\_ -> it True <+> help (\_ -> text "x") f1 True) f2 False+    help it (WpCast co)   = add_parens $ sep [it False, nest 2 (text "|>"+                                              <+> pprParendCo co)]+    help it (WpEvApp id)  = no_parens  $ sep [it True, nest 2 (ppr id)]+    help it (WpTyApp ty)  = no_parens  $ sep [it True, text "@" <+> pprParendType ty]+    help it (WpEvLam id)  = add_parens $ sep [ text "\\" <> pp_bndr id, it False]+    help it (WpTyLam tv)  = add_parens $ sep [text "/\\" <> pp_bndr tv, it False]+    help it (WpLet binds) = add_parens $ sep [text "let" <+> braces (ppr binds), it False]++    pp_bndr v = pprBndr LambdaBind v <> dot++add_parens, no_parens :: SDoc -> Bool -> SDoc+add_parens d True  = parens d+add_parens d False = d+no_parens d _ = d++instance Outputable TcEvBinds where+  ppr (TcEvBinds v) = ppr v+  ppr (EvBinds bs)  = text "EvBinds" <> braces (vcat (map ppr (bagToList bs)))++instance Outputable EvBindsVar where+  ppr (EvBindsVar { ebv_uniq = u })+     = text "EvBindsVar" <> angleBrackets (ppr u)++instance Uniquable EvBindsVar where+  getUnique (EvBindsVar { ebv_uniq = u }) = u++instance Outputable EvBind where+  ppr (EvBind { eb_lhs = v, eb_rhs = e, eb_is_given = is_given })+     = sep [ pp_gw <+> ppr v+           , nest 2 $ equals <+> ppr e ]+     where+       pp_gw = brackets (if is_given then char 'G' else char 'W')+   -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing++instance Outputable EvTerm where+  ppr (EvId v)              = ppr v+  ppr (EvCast v co)         = ppr v <+> (text "`cast`") <+> pprParendCo co+  ppr (EvCoercion co)       = text "CO" <+> ppr co+  ppr (EvSuperClass d n)    = text "sc" <> parens (ppr (d,n))+  ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ]+  ppr (EvLit l)             = ppr l+  ppr (EvCallStack cs)      = ppr cs+  ppr (EvDelayedError ty msg) =     text "error"+                                <+> sep [ char '@' <> ppr ty, ppr msg ]+  ppr (EvTypeable ty ev)      = ppr ev <+> dcolon <+> text "Typeable" <+> ppr ty+  ppr (EvSelector sel tys ts) = ppr sel <+> sep [ char '@' <> ppr tys, ppr ts]++instance Outputable EvLit where+  ppr (EvNum n) = integer n+  ppr (EvStr s) = text (show s)++instance Outputable EvCallStack where+  ppr EvCsEmpty+    = text "[]"+  ppr (EvCsPushCall name loc tm)+    = ppr (name,loc) <+> text ":" <+> ppr tm++instance Outputable EvTypeable where+  ppr (EvTypeableTyCon ts _)  = text "TyCon" <+> ppr ts+  ppr (EvTypeableTyApp t1 t2) = parens (ppr t1 <+> ppr t2)+  ppr (EvTypeableTrFun t1 t2) = parens (ppr t1 <+> arrow <+> ppr t2)+  ppr (EvTypeableTyLit t1)    = text "TyLit" <> ppr t1+++----------------------------------------------------------------------+-- Helper functions for dealing with IP newtype-dictionaries+----------------------------------------------------------------------++-- | Create a 'Coercion' that unwraps an implicit-parameter or+-- overloaded-label dictionary to expose the underlying value. We+-- expect the 'Type' to have the form `IP sym ty` or `IsLabel sym ty`,+-- and return a 'Coercion' `co :: IP sym ty ~ ty` or+-- `co :: IsLabel sym ty ~ Proxy# sym -> ty`.  See also+-- Note [Type-checking overloaded labels] in TcExpr.+unwrapIP :: Type -> CoercionR+unwrapIP ty =+  case unwrapNewTyCon_maybe tc of+    Just (_,_,ax) -> mkUnbranchedAxInstCo Representational ax tys []+    Nothing       -> pprPanic "unwrapIP" $+                       text "The dictionary for" <+> quotes (ppr tc)+                         <+> text "is not a newtype!"+  where+  (tc, tys) = splitTyConApp ty++-- | Create a 'Coercion' that wraps a value in an implicit-parameter+-- dictionary. See 'unwrapIP'.+wrapIP :: Type -> CoercionR+wrapIP ty = mkSymCo (unwrapIP ty)
+ typecheck/TcExpr.hs view
@@ -0,0 +1,2727 @@+{-+%+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[TcExpr]{Typecheck an expression}+-}++{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}++module TcExpr ( tcPolyExpr, tcMonoExpr, tcMonoExprNC,+                tcInferSigma, tcInferSigmaNC, tcInferRho, tcInferRhoNC,+                tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,+                tcCheckId,+                addExprErrCtxt,+                getFixedTyVars ) where++#include "HsVersions.h"++import {-# SOURCE #-}   TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )+import THNames( liftStringName, liftName )++import HsSyn+import TcHsSyn+import TcRnMonad+import TcUnify+import BasicTypes+import Inst+import TcBinds          ( chooseInferredQuantifiers, tcLocalBinds )+import TcSigs           ( tcUserTypeSig, tcInstSig )+import TcSimplify       ( simplifyInfer, InferMode(..) )+import FamInst          ( tcGetFamInstEnvs, tcLookupDataFamInst )+import FamInstEnv       ( FamInstEnvs )+import RnEnv            ( addUsedGRE, addNameClashErrRn+                        , unknownSubordinateErr )+import TcEnv+import TcArrows+import TcMatches+import TcHsType+import TcPatSyn( tcPatSynBuilderOcc, nonBidirectionalErr )+import TcPat+import TcMType+import TcType+import DsMonad+import Id+import IdInfo+import ConLike+import DataCon+import PatSyn+import Name+import NameEnv+import NameSet+import RdrName+import TyCon+import Type+import TcEvidence+import VarSet+import TysWiredIn+import TysPrim( intPrimTy )+import PrimOp( tagToEnumKey )+import PrelNames+import DynFlags+import SrcLoc+import Util+import VarEnv  ( emptyTidyEnv )+import ListSetOps+import Maybes+import Outputable+import FastString+import Control.Monad+import Class(classTyCon)+import UniqSet ( nonDetEltsUniqSet )+import qualified GHC.LanguageExtensions as LangExt++import Data.Function+import Data.List+import Data.Either+import qualified Data.Set as Set++{-+************************************************************************+*                                                                      *+\subsection{Main wrappers}+*                                                                      *+************************************************************************+-}++tcPolyExpr, tcPolyExprNC+  :: LHsExpr Name        -- Expression to type check+  -> TcSigmaType         -- Expected type (could be a polytype)+  -> TcM (LHsExpr TcId)  -- Generalised expr with expected type++-- tcPolyExpr is a convenient place (frequent but not too frequent)+-- place to add context information.+-- The NC version does not do so, usually because the caller wants+-- to do so himself.++tcPolyExpr   expr res_ty = tc_poly_expr expr (mkCheckExpType res_ty)+tcPolyExprNC expr res_ty = tc_poly_expr_nc expr (mkCheckExpType res_ty)++-- these versions take an ExpType+tc_poly_expr, tc_poly_expr_nc :: LHsExpr Name -> ExpSigmaType -> TcM (LHsExpr TcId)+tc_poly_expr expr res_ty+  = addExprErrCtxt expr $+    do { traceTc "tcPolyExpr" (ppr res_ty); tc_poly_expr_nc expr res_ty }++tc_poly_expr_nc (L loc expr) res_ty+  = do { traceTc "tcPolyExprNC" (ppr res_ty)+       ; (wrap, expr')+           <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty ->+              setSrcSpan loc $+                -- NB: setSrcSpan *after* skolemising, so we get better+                -- skolem locations+              tcExpr expr res_ty+       ; return $ L loc (mkHsWrap wrap expr') }++---------------+tcMonoExpr, tcMonoExprNC+    :: LHsExpr Name      -- Expression to type check+    -> ExpRhoType        -- Expected type+                         -- Definitely no foralls at the top+    -> TcM (LHsExpr TcId)++tcMonoExpr expr res_ty+  = addErrCtxt (exprCtxt expr) $+    tcMonoExprNC expr res_ty++tcMonoExprNC (L loc expr) res_ty+  = setSrcSpan loc $+    do  { expr' <- tcExpr expr res_ty+        ; return (L loc expr') }++---------------+tcInferSigma, tcInferSigmaNC :: LHsExpr Name -> TcM ( LHsExpr TcId+                                                    , TcSigmaType )+-- Infer a *sigma*-type.+tcInferSigma expr = addErrCtxt (exprCtxt expr) (tcInferSigmaNC expr)++tcInferSigmaNC (L loc expr)+  = setSrcSpan loc $+    do { (expr', sigma) <- tcInferNoInst (tcExpr expr)+       ; return (L loc expr', sigma) }++tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)+-- Infer a *rho*-type. The return type is always (shallowly) instantiated.+tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr)++tcInferRhoNC expr+  = do { (expr', sigma) <- tcInferSigmaNC expr+       ; (wrap, rho) <- topInstantiate (lexprCtOrigin expr) sigma+       ; return (mkLHsWrap wrap expr', rho) }+++{-+************************************************************************+*                                                                      *+        tcExpr: the main expression typechecker+*                                                                      *+************************************************************************++NB: The res_ty is always deeply skolemised.+-}++tcExpr :: HsExpr Name -> ExpRhoType -> TcM (HsExpr TcId)+tcExpr (HsVar (L _ name)) res_ty = tcCheckId name res_ty+tcExpr (HsUnboundVar uv)  res_ty = tcUnboundId uv res_ty++tcExpr e@(HsApp {})     res_ty = tcApp1 e res_ty+tcExpr e@(HsAppType {}) res_ty = tcApp1 e res_ty++tcExpr e@(HsLit lit) res_ty = do { let lit_ty = hsLitType lit+                                 ; tcWrapResult e (HsLit lit) lit_ty res_ty }++tcExpr (HsPar expr)   res_ty = do { expr' <- tcMonoExprNC expr res_ty+                                  ; return (HsPar expr') }++tcExpr (HsSCC src lbl expr) res_ty+  = do { expr' <- tcMonoExpr expr res_ty+       ; return (HsSCC src lbl expr') }++tcExpr (HsTickPragma src info srcInfo expr) res_ty+  = do { expr' <- tcMonoExpr expr res_ty+       ; return (HsTickPragma src info srcInfo expr') }++tcExpr (HsCoreAnn src lbl expr) res_ty+  = do  { expr' <- tcMonoExpr expr res_ty+        ; return (HsCoreAnn src lbl expr') }++tcExpr (HsOverLit lit) res_ty+  = do  { lit' <- newOverloadedLit lit res_ty+        ; return (HsOverLit lit') }++tcExpr (NegApp expr neg_expr) res_ty+  = do  { (expr', neg_expr')+            <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $+               \[arg_ty] ->+               tcMonoExpr expr (mkCheckExpType arg_ty)+        ; return (NegApp expr' neg_expr') }++tcExpr e@(HsIPVar x) res_ty+  = do {   {- Implicit parameters must have a *tau-type* not a+              type scheme.  We enforce this by creating a fresh+              type variable as its type.  (Because res_ty may not+              be a tau-type.) -}+         ip_ty <- newOpenFlexiTyVarTy+       ; let ip_name = mkStrLitTy (hsIPNameFS x)+       ; ipClass <- tcLookupClass ipClassName+       ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty])+       ; tcWrapResult e (fromDict ipClass ip_name ip_ty (HsVar (noLoc ip_var)))+                      ip_ty res_ty }+  where+  -- Coerces a dictionary for `IP "x" t` into `t`.+  fromDict ipClass x ty = HsWrap $ mkWpCastR $+                          unwrapIP $ mkClassPred ipClass [x,ty]+  origin = IPOccOrigin x++tcExpr e@(HsOverLabel mb_fromLabel l) res_ty+  = do { -- See Note [Type-checking overloaded labels]+         loc <- getSrcSpanM+       ; case mb_fromLabel of+           Just fromLabel -> tcExpr (applyFromLabel loc fromLabel) res_ty+           Nothing -> do { isLabelClass <- tcLookupClass isLabelClassName+                         ; alpha <- newFlexiTyVarTy liftedTypeKind+                         ; let pred = mkClassPred isLabelClass [lbl, alpha]+                         ; loc <- getSrcSpanM+                         ; var <- emitWantedEvVar origin pred+                         ; tcWrapResult e (fromDict pred (HsVar (L loc var)))+                                        alpha res_ty } }+  where+  -- Coerces a dictionary for `IsLabel "x" t` into `t`,+  -- or `HasField "x" r a into `r -> a`.+  fromDict pred = HsWrap $ mkWpCastR $ unwrapIP pred+  origin = OverLabelOrigin l+  lbl = mkStrLitTy l++  applyFromLabel loc fromLabel =+    L loc (HsVar (L loc fromLabel)) `HsAppType`+      mkEmptyWildCardBndrs (L loc (HsTyLit (HsStrTy NoSourceText l)))++tcExpr (HsLam match) res_ty+  = do  { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty+        ; return (mkHsWrap wrap (HsLam match')) }+  where+    match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody }+    herald = sep [ text "The lambda expression" <+>+                   quotes (pprSetDepth (PartWay 1) $+                           pprMatches match),+                        -- The pprSetDepth makes the abstraction print briefly+                   text "has"]++tcExpr e@(HsLamCase matches) res_ty+  = do { (matches', wrap)+           <- tcMatchLambda msg match_ctxt matches res_ty+           -- The laziness annotation is because we don't want to fail here+           -- if there are multiple arguments+       ; return (mkHsWrap wrap $ HsLamCase matches') }+  where+    msg = sep [ text "The function" <+> quotes (ppr e)+              , text "requires"]+    match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }++tcExpr e@(ExprWithTySig expr sig_ty) res_ty+  = do { let loc = getLoc (hsSigWcType sig_ty)+       ; sig_info <- checkNoErrs $  -- Avoid error cascade+                     tcUserTypeSig loc sig_ty Nothing+       ; (expr', poly_ty) <- tcExprSig expr sig_info+       ; let expr'' = ExprWithTySigOut expr' sig_ty+       ; tcWrapResult e expr'' poly_ty res_ty }++{-+Note [Type-checking overloaded labels]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Recall that we have++  module GHC.OverloadedLabels where+    class IsLabel (x :: Symbol) a where+      fromLabel :: a++We translate `#foo` to `fromLabel @"foo"`, where we use++ * the in-scope `fromLabel` if `RebindableSyntax` is enabled; or if not+ * `GHC.OverloadedLabels.fromLabel`.++In the `RebindableSyntax` case, the renamer will have filled in the+first field of `HsOverLabel` with the `fromLabel` function to use, and+we simply apply it to the appropriate visible type argument.++In the `OverloadedLabels` case, when we see an overloaded label like+`#foo`, we generate a fresh variable `alpha` for the type and emit an+`IsLabel "foo" alpha` constraint.  Because the `IsLabel` class has a+single method, it is represented by a newtype, so we can coerce+`IsLabel "foo" alpha` to `alpha` (just like for implicit parameters).++-}+++{-+************************************************************************+*                                                                      *+                Infix operators and sections+*                                                                      *+************************************************************************++Note [Left sections]+~~~~~~~~~~~~~~~~~~~~+Left sections, like (4 *), are equivalent to+        \ x -> (*) 4 x,+or, if PostfixOperators is enabled, just+        (*) 4+With PostfixOperators we don't actually require the function to take+two arguments at all.  For example, (x `not`) means (not x); you get+postfix operators!  Not Haskell 98, but it's less work and kind of+useful.++Note [Typing rule for ($)]+~~~~~~~~~~~~~~~~~~~~~~~~~~+People write+   runST $ blah+so much, where+   runST :: (forall s. ST s a) -> a+that I have finally given in and written a special type-checking+rule just for saturated applications of ($).+  * Infer the type of the first argument+  * Decompose it; should be of form (arg2_ty -> res_ty),+       where arg2_ty might be a polytype+  * Use arg2_ty to typecheck arg2++Note [Typing rule for seq]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to allow+       x `seq` (# p,q #)+which suggests this type for seq:+   seq :: forall (a:*) (b:Open). a -> b -> b,+with (b:Open) meaning that be can be instantiated with an unboxed+tuple.  The trouble is that this might accept a partially-applied+'seq', and I'm just not certain that would work.  I'm only sure it's+only going to work when it's fully applied, so it turns into+    case x of _ -> (# p,q #)++So it seems more uniform to treat 'seq' as if it was a language+construct.++See also Note [seqId magic] in MkId+-}++tcExpr expr@(OpApp arg1 op fix arg2) res_ty+  | (L loc (HsVar (L lv op_name))) <- op+  , op_name `hasKey` seqIdKey           -- Note [Typing rule for seq]+  = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind+       ; let arg2_exp_ty = res_ty+       ; arg1' <- tcArg op arg1 arg1_ty 1+       ; arg2' <- addErrCtxt (funAppCtxt op arg2 2) $+                  tc_poly_expr_nc arg2 arg2_exp_ty+       ; arg2_ty <- readExpType arg2_exp_ty+       ; op_id <- tcLookupId op_name+       ; let op' = L loc (HsWrap (mkWpTyApps [arg1_ty, arg2_ty])+                                 (HsVar (L lv op_id)))+       ; return $ OpApp arg1' op' fix arg2' }++  | (L loc (HsVar (L lv op_name))) <- op+  , op_name `hasKey` dollarIdKey        -- Note [Typing rule for ($)]+  = do { traceTc "Application rule" (ppr op)+       ; (arg1', arg1_ty) <- tcInferSigma arg1++       ; let doc   = text "The first argument of ($) takes"+             orig1 = lexprCtOrigin arg1+       ; (wrap_arg1, [arg2_sigma], op_res_ty) <-+           matchActualFunTys doc orig1 (Just arg1) 1 arg1_ty++         -- We have (arg1 $ arg2)+         -- So: arg1_ty = arg2_ty -> op_res_ty+         -- where arg2_sigma maybe polymorphic; that's the point++       ; arg2'  <- tcArg op arg2 arg2_sigma 2++       -- Make sure that the argument type has kind '*'+       --   ($) :: forall (r:RuntimeRep) (a:*) (b:TYPE r). (a->b) -> a -> b+       -- Eg we do not want to allow  (D#  $  4.0#)   Trac #5570+       --    (which gives a seg fault)+       --+       -- The *result* type can have any kind (Trac #8739),+       -- so we don't need to check anything for that+       ; _ <- unifyKind (Just arg2_sigma) (typeKind arg2_sigma) liftedTypeKind+           -- ignore the evidence. arg2_sigma must have type * or #,+           -- because we know arg2_sigma -> or_res_ty is well-kinded+           -- (because otherwise matchActualFunTys would fail)+           -- There's no possibility here of, say, a kind family reducing to *.++       ; wrap_res <- tcSubTypeHR orig1 (Just expr) op_res_ty res_ty+                       -- op_res -> res++       ; op_id  <- tcLookupId op_name+       ; res_ty <- readExpType res_ty+       ; let op' = L loc (HsWrap (mkWpTyApps [ getRuntimeRep "tcExpr ($)" res_ty+                                             , arg2_sigma+                                             , res_ty])+                                 (HsVar (L lv op_id)))+             -- arg1' :: arg1_ty+             -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty)+             -- wrap_res :: op_res_ty "->" res_ty+             -- op' :: (a2_ty -> res_ty) -> a2_ty -> res_ty++             -- wrap1 :: arg1_ty "->" (arg2_sigma -> res_ty)+             wrap1 = mkWpFun idHsWrapper wrap_res arg2_sigma res_ty doc+                     <.> wrap_arg1+             doc = text "When looking at the argument to ($)"++       ; return (OpApp (mkLHsWrap wrap1 arg1') op' fix arg2') }++  | (L loc (HsRecFld (Ambiguous lbl _))) <- op+  , Just sig_ty <- obviousSig (unLoc arg1)+    -- See Note [Disambiguating record fields]+  = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty+       ; sel_name <- disambiguateSelector lbl sig_tc_ty+       ; let op' = L loc (HsRecFld (Unambiguous lbl sel_name))+       ; tcExpr (OpApp arg1 op' fix arg2) res_ty+       }++  | otherwise+  = do { traceTc "Non Application rule" (ppr op)+       ; (wrap, op', [Left arg1', Left arg2'])+           <- tcApp (Just $ mk_op_msg op)+                     op [Left arg1, Left arg2] res_ty+       ; return (mkHsWrap wrap $ OpApp arg1' op' fix arg2') }++-- Right sections, equivalent to \ x -> x `op` expr, or+--      \ x -> op x expr++tcExpr expr@(SectionR op arg2) res_ty+  = do { (op', op_ty) <- tcInferFun op+       ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty)+                  <- matchActualFunTys (mk_op_msg op) fn_orig (Just op) 2 op_ty+       ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr)+                                 (mkFunTy arg1_ty op_res_ty) res_ty+       ; arg2' <- tcArg op arg2 arg2_ty 2+       ; return ( mkHsWrap wrap_res $+                  SectionR (mkLHsWrap wrap_fun op') arg2' ) }+  where+    fn_orig = lexprCtOrigin op+    -- It's important to use the origin of 'op', so that call-stacks+    -- come out right; they are driven by the OccurrenceOf CtOrigin+    -- See Trac #13285++tcExpr expr@(SectionL arg1 op) res_ty+  = do { (op', op_ty) <- tcInferFun op+       ; dflags <- getDynFlags      -- Note [Left sections]+       ; let n_reqd_args | xopt LangExt.PostfixOperators dflags = 1+                         | otherwise                            = 2++       ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty)+           <- matchActualFunTys (mk_op_msg op) fn_orig (Just op)+                                n_reqd_args op_ty+       ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr)+                                 (mkFunTys arg_tys op_res_ty) res_ty+       ; arg1' <- tcArg op arg1 arg1_ty 1+       ; return ( mkHsWrap wrap_res $+                  SectionL arg1' (mkLHsWrap wrap_fn op') ) }+  where+    fn_orig = lexprCtOrigin op+    -- It's important to use the origin of 'op', so that call-stacks+    -- come out right; they are driven by the OccurrenceOf CtOrigin+    -- See Trac #13285++tcExpr expr@(ExplicitTuple tup_args boxity) res_ty+  | all tupArgPresent tup_args+  = do { let arity  = length tup_args+             tup_tc = tupleTyCon boxity arity+       ; res_ty <- expTypeToType res_ty+       ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty+                           -- Unboxed tuples have RuntimeRep vars, which we+                           -- don't care about here+                           -- See Note [Unboxed tuple RuntimeRep vars] in TyCon+       ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys+                                       Boxed   -> arg_tys+       ; tup_args1 <- tcTupArgs tup_args arg_tys'+       ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }++  | otherwise+  = -- The tup_args are a mixture of Present and Missing (for tuple sections)+    do { let arity = length tup_args++       ; arg_tys <- case boxity of+           { Boxed   -> newFlexiTyVarTys arity liftedTypeKind+           ; Unboxed -> replicateM arity newOpenFlexiTyVarTy }+       ; let actual_res_ty+                 = mkFunTys [ty | (ty, (L _ (Missing _))) <- arg_tys `zip` tup_args]+                            (mkTupleTy boxity arg_tys)++       ; wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "ExpTuple")+                             (Just expr)+                             actual_res_ty res_ty++       -- Handle tuple sections where+       ; tup_args1 <- tcTupArgs tup_args arg_tys++       ; return $ mkHsWrap wrap (ExplicitTuple tup_args1 boxity) }++tcExpr (ExplicitSum alt arity expr _) res_ty+  = do { let sum_tc = sumTyCon arity+       ; res_ty <- expTypeToType res_ty+       ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty+       ; -- Drop levity vars, we don't care about them here+         let arg_tys' = drop arity arg_tys+       ; expr' <- tcPolyExpr expr (arg_tys' `getNth` (alt - 1))+       ; return $ mkHsWrapCo coi (ExplicitSum alt arity expr' arg_tys') }++tcExpr (ExplicitList _ witness exprs) res_ty+  = case witness of+      Nothing   -> do  { res_ty <- expTypeToType res_ty+                       ; (coi, elt_ty) <- matchExpectedListTy res_ty+                       ; exprs' <- mapM (tc_elt elt_ty) exprs+                       ; return $+                         mkHsWrapCo coi $ ExplicitList elt_ty Nothing exprs' }++      Just fln -> do { ((exprs', elt_ty), fln')+                         <- tcSyntaxOp ListOrigin fln+                                       [synKnownType intTy, SynList] res_ty $+                            \ [elt_ty] ->+                            do { exprs' <-+                                    mapM (tc_elt elt_ty) exprs+                               ; return (exprs', elt_ty) }++                     ; return $ ExplicitList elt_ty (Just fln') exprs' }+     where tc_elt elt_ty expr = tcPolyExpr expr elt_ty++tcExpr (ExplicitPArr _ exprs) res_ty    -- maybe empty+  = do  { res_ty <- expTypeToType res_ty+        ; (coi, elt_ty) <- matchExpectedPArrTy res_ty+        ; exprs' <- mapM (tc_elt elt_ty) exprs+        ; return $+          mkHsWrapCo coi $ ExplicitPArr elt_ty exprs' }+  where+    tc_elt elt_ty expr = tcPolyExpr expr elt_ty++{-+************************************************************************+*                                                                      *+                Let, case, if, do+*                                                                      *+************************************************************************+-}++tcExpr (HsLet (L l binds) expr) res_ty+  = do  { (binds', expr') <- tcLocalBinds binds $+                             tcMonoExpr expr res_ty+        ; return (HsLet (L l binds') expr') }++tcExpr (HsCase scrut matches) res_ty+  = do  {  -- We used to typecheck the case alternatives first.+           -- The case patterns tend to give good type info to use+           -- when typechecking the scrutinee.  For example+           --   case (map f) of+           --     (x:xs) -> ...+           -- will report that map is applied to too few arguments+           --+           -- But now, in the GADT world, we need to typecheck the scrutinee+           -- first, to get type info that may be refined in the case alternatives+          (scrut', scrut_ty) <- tcInferRho scrut++        ; traceTc "HsCase" (ppr scrut_ty)+        ; matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty+        ; return (HsCase scrut' matches') }+ where+    match_ctxt = MC { mc_what = CaseAlt,+                      mc_body = tcBody }++tcExpr (HsIf Nothing pred b1 b2) res_ty    -- Ordinary 'if'+  = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy)+       ; res_ty <- tauifyExpType res_ty+           -- Just like Note [Case branches must never infer a non-tau type]+           -- in TcMatches (See #10619)++       ; b1' <- tcMonoExpr b1 res_ty+       ; b2' <- tcMonoExpr b2 res_ty+       ; return (HsIf Nothing pred' b1' b2') }++tcExpr (HsIf (Just fun) pred b1 b2) res_ty+  = do { ((pred', b1', b2'), fun')+           <- tcSyntaxOp IfOrigin fun [SynAny, SynAny, SynAny] res_ty $+              \ [pred_ty, b1_ty, b2_ty] ->+              do { pred' <- tcPolyExpr pred pred_ty+                 ; b1'   <- tcPolyExpr b1   b1_ty+                 ; b2'   <- tcPolyExpr b2   b2_ty+                 ; return (pred', b1', b2') }+       ; return (HsIf (Just fun') pred' b1' b2') }++tcExpr (HsMultiIf _ alts) res_ty+  = do { res_ty <- if isSingleton alts+                   then return res_ty+                   else tauifyExpType res_ty+             -- Just like TcMatches+             -- Note [Case branches must never infer a non-tau type]++       ; alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts+       ; res_ty <- readExpType res_ty+       ; return (HsMultiIf res_ty alts') }+  where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }++tcExpr (HsDo do_or_lc stmts _) res_ty+  = do { expr' <- tcDoStmts do_or_lc stmts res_ty+       ; return expr' }++tcExpr (HsProc pat cmd) res_ty+  = do  { (pat', cmd', coi) <- tcProc pat cmd res_ty+        ; return $ mkHsWrapCo coi (HsProc pat' cmd') }++-- Typechecks the static form and wraps it with a call to 'fromStaticPtr'.+-- See Note [Grand plan for static forms] in StaticPtrTable for an overview.+tcExpr (HsStatic fvs expr) res_ty+  = do  { res_ty          <- expTypeToType res_ty+        ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty+        ; (expr', lie)    <- captureConstraints $+            addErrCtxt (hang (text "In the body of a static form:")+                             2 (ppr expr)+                       ) $+            tcPolyExprNC expr expr_ty+        -- Check that the free variables of the static form are closed.+        -- It's OK to use nonDetEltsUniqSet here as the only side effects of+        -- checkClosedInStaticForm are error messages.+        ; mapM_ checkClosedInStaticForm $ nonDetEltsUniqSet fvs++        -- Require the type of the argument to be Typeable.+        -- The evidence is not used, but asking the constraint ensures that+        -- the current implementation is as restrictive as future versions+        -- of the StaticPointers extension.+        ; typeableClass <- tcLookupClass typeableClassName+        ; _ <- emitWantedEvVar StaticOrigin $+                  mkTyConApp (classTyCon typeableClass)+                             [liftedTypeKind, expr_ty]+        -- Insert the constraints of the static form in a global list for later+        -- validation.+        ; emitStaticConstraints lie++        -- Wrap the static form with the 'fromStaticPtr' call.+        ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName p_ty+        ; let wrap = mkWpTyApps [expr_ty]+        ; loc <- getSrcSpanM+        ; return $ mkHsWrapCo co $ HsApp (L loc $ mkHsWrap wrap fromStaticPtr)+                                         (L loc (HsStatic fvs expr'))+        }++{-+************************************************************************+*                                                                      *+                Record construction and update+*                                                                      *+************************************************************************+-}++tcExpr expr@(RecordCon { rcon_con_name = L loc con_name+                       , rcon_flds = rbinds }) res_ty+  = do  { con_like <- tcLookupConLike con_name++        -- Check for missing fields+        ; checkMissingFields con_like rbinds++        ; (con_expr, con_sigma) <- tcInferId con_name+        ; (con_wrap, con_tau) <-+            topInstantiate (OccurrenceOf con_name) con_sigma+              -- a shallow instantiation should really be enough for+              -- a data constructor.+        ; let arity = conLikeArity con_like+              Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau+        ; case conLikeWrapId_maybe con_like of+               Nothing -> nonBidirectionalErr (conLikeName con_like)+               Just con_id -> do {+                  res_wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "RecordCon")+                                          (Just expr) actual_res_ty res_ty+                ; rbinds' <- tcRecordBinds con_like arg_tys rbinds+                ; return $+                  mkHsWrap res_wrap $+                  RecordCon { rcon_con_name = L loc con_id+                            , rcon_con_expr = mkHsWrap con_wrap con_expr+                            , rcon_con_like = con_like+                            , rcon_flds = rbinds' } } }++{-+Note [Type of a record update]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The main complication with RecordUpd is that we need to explicitly+handle the *non-updated* fields.  Consider:++        data T a b c = MkT1 { fa :: a, fb :: (b,c) }+                     | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c }+                     | MkT3 { fd :: a }++        upd :: T a b c -> (b',c) -> T a b' c+        upd t x = t { fb = x}++The result type should be (T a b' c)+not (T a b c),   because 'b' *is not* mentioned in a non-updated field+not (T a b' c'), because 'c' *is*     mentioned in a non-updated field+NB that it's not good enough to look at just one constructor; we must+look at them all; cf Trac #3219++After all, upd should be equivalent to:+        upd t x = case t of+                        MkT1 p q -> MkT1 p x+                        MkT2 a b -> MkT2 p b+                        MkT3 d   -> error ...++So we need to give a completely fresh type to the result record,+and then constrain it by the fields that are *not* updated ("p" above).+We call these the "fixed" type variables, and compute them in getFixedTyVars.++Note that because MkT3 doesn't contain all the fields being updated,+its RHS is simply an error, so it doesn't impose any type constraints.+Hence the use of 'relevant_cont'.++Note [Implicit type sharing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We also take into account any "implicit" non-update fields.  For example+        data T a b where { MkT { f::a } :: T a a; ... }+So the "real" type of MkT is: forall ab. (a~b) => a -> T a b++Then consider+        upd t x = t { f=x }+We infer the type+        upd :: T a b -> a -> T a b+        upd (t::T a b) (x::a)+           = case t of { MkT (co:a~b) (_:a) -> MkT co x }+We can't give it the more general type+        upd :: T a b -> c -> T c b++Note [Criteria for update]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to allow update for existentials etc, provided the updated+field isn't part of the existential. For example, this should be ok.+  data T a where { MkT { f1::a, f2::b->b } :: T a }+  f :: T a -> b -> T b+  f t b = t { f1=b }++The criterion we use is this:++  The types of the updated fields+  mention only the universally-quantified type variables+  of the data constructor++NB: this is not (quite) the same as being a "naughty" record selector+(See Note [Naughty record selectors]) in TcTyClsDecls), at least+in the case of GADTs. Consider+   data T a where { MkT :: { f :: a } :: T [a] }+Then f is not "naughty" because it has a well-typed record selector.+But we don't allow updates for 'f'.  (One could consider trying to+allow this, but it makes my head hurt.  Badly.  And no one has asked+for it.)++In principle one could go further, and allow+  g :: T a -> T a+  g t = t { f2 = \x -> x }+because the expression is polymorphic...but that seems a bridge too far.++Note [Data family example]+~~~~~~~~~~~~~~~~~~~~~~~~~~+    data instance T (a,b) = MkT { x::a, y::b }+  --->+    data :TP a b = MkT { a::a, y::b }+    coTP a b :: T (a,b) ~ :TP a b++Suppose r :: T (t1,t2), e :: t3+Then  r { x=e } :: T (t3,t1)+  --->+      case r |> co1 of+        MkT x y -> MkT e y |> co2+      where co1 :: T (t1,t2) ~ :TP t1 t2+            co2 :: :TP t3 t2 ~ T (t3,t2)+The wrapping with co2 is done by the constructor wrapper for MkT++Outgoing invariants+~~~~~~~~~~~~~~~~~~~+In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):++  * cons are the data constructors to be updated++  * in_inst_tys, out_inst_tys have same length, and instantiate the+        *representation* tycon of the data cons.  In Note [Data+        family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]++Note [Mixed Record Field Updates]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following pattern synonym.++  data MyRec = MyRec { foo :: Int, qux :: String }++  pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2}++This allows updates such as the following++  updater :: MyRec -> MyRec+  updater a = a {f1 = 1 }++It would also make sense to allow the following update (which we reject).++  updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two"++This leads to confusing behaviour when the selectors in fact refer the same+field.++  updater a = a {f1 = 1, foo = 2} ==? ???++For this reason, we reject a mixture of pattern synonym and normal record+selectors in the same update block. Although of course we still allow the+following.++  updater a = (a {f1 = 1}) {foo = 2}++  > updater (MyRec 0 "str")+  MyRec 2 "str"++-}++tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty+  = ASSERT( notNull rbnds )+    do  { -- STEP -2: typecheck the record_expr, the record to be updated+          (record_expr', record_rho) <- tcInferRho record_expr++        -- STEP -1  See Note [Disambiguating record fields]+        -- After this we know that rbinds is unambiguous+        ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty+        ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds+              upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds+              sel_ids      = map selectorAmbiguousFieldOcc upd_flds+        -- STEP 0+        -- Check that the field names are really field names+        -- and they are all field names for proper records or+        -- all field names for pattern synonyms.+        ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)+                         | fld <- rbinds,+                           -- Excludes class ops+                           let L loc sel_id = hsRecUpdFieldId (unLoc fld),+                           not (isRecordSelector sel_id),+                           let fld_name = idName sel_id ]+        ; unless (null bad_guys) (sequence bad_guys >> failM)+        -- See note [Mixed Record Selectors]+        ; let (data_sels, pat_syn_sels) =+                partition isDataConRecordSelector sel_ids+        ; MASSERT( all isPatSynRecordSelector pat_syn_sels )+        ; checkTc ( null data_sels || null pat_syn_sels )+                  ( mixedSelectors data_sels pat_syn_sels )++        -- STEP 1+        -- Figure out the tycon and data cons from the first field name+        ; let   -- It's OK to use the non-tc splitters here (for a selector)+              sel_id : _  = sel_ids++              mtycon :: Maybe TyCon+              mtycon = case idDetails sel_id of+                          RecSelId (RecSelData tycon) _ -> Just tycon+                          _ -> Nothing++              con_likes :: [ConLike]+              con_likes = case idDetails sel_id of+                             RecSelId (RecSelData tc) _+                                -> map RealDataCon (tyConDataCons tc)+                             RecSelId (RecSelPatSyn ps) _+                                -> [PatSynCon ps]+                             _  -> panic "tcRecordUpd"+                -- NB: for a data type family, the tycon is the instance tycon++              relevant_cons = conLikesWithFields con_likes upd_fld_occs+                -- A constructor is only relevant to this process if+                -- it contains *all* the fields that are being updated+                -- Other ones will cause a runtime error if they occur++        -- Step 2+        -- Check that at least one constructor has all the named fields+        -- i.e. has an empty set of bad fields returned by badFields+        ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes)++        -- Take apart a representative constructor+        ; let con1 = ASSERT( not (null relevant_cons) ) head relevant_cons+              (con1_tvs, _, _, _prov_theta, req_theta, con1_arg_tys, _)+                 = conLikeFullSig con1+              con1_flds   = map flLabel $ conLikeFieldLabels con1+              con1_tv_tys = mkTyVarTys con1_tvs+              con1_res_ty = case mtycon of+                              Just tc -> mkFamilyTyConApp tc con1_tv_tys+                              Nothing -> conLikeResTy con1 con1_tv_tys++        -- Check that we're not dealing with a unidirectional pattern+        -- synonym+        ; unless (isJust $ conLikeWrapId_maybe con1)+                  (nonBidirectionalErr (conLikeName con1))++        -- STEP 3    Note [Criteria for update]+        -- Check that each updated field is polymorphic; that is, its type+        -- mentions only the universally-quantified variables of the data con+        ; let flds1_w_tys  = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys+              bad_upd_flds = filter bad_fld flds1_w_tys+              con1_tv_set  = mkVarSet con1_tvs+              bad_fld (fld, ty) = fld `elem` upd_fld_occs &&+                                      not (tyCoVarsOfType ty `subVarSet` con1_tv_set)+        ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds)++        -- STEP 4  Note [Type of a record update]+        -- Figure out types for the scrutinee and result+        -- Both are of form (T a b c), with fresh type variables, but with+        -- common variables where the scrutinee and result must have the same type+        -- These are variables that appear in *any* arg of *any* of the+        -- relevant constructors *except* in the updated fields+        --+        ; let fixed_tvs = getFixedTyVars upd_fld_occs con1_tvs relevant_cons+              is_fixed_tv tv = tv `elemVarSet` fixed_tvs++              mk_inst_ty :: TCvSubst -> (TyVar, TcType) -> TcM (TCvSubst, TcType)+              -- Deals with instantiation of kind variables+              --   c.f. TcMType.newMetaTyVars+              mk_inst_ty subst (tv, result_inst_ty)+                | is_fixed_tv tv   -- Same as result type+                = return (extendTvSubst subst tv result_inst_ty, result_inst_ty)+                | otherwise        -- Fresh type, of correct kind+                = do { (subst', new_tv) <- newMetaTyVarX subst tv+                     ; return (subst', mkTyVarTy new_tv) }++        ; (result_subst, con1_tvs') <- newMetaTyVars con1_tvs+        ; let result_inst_tys = mkTyVarTys con1_tvs'+              init_subst = mkEmptyTCvSubst (getTCvInScope result_subst)++        ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty init_subst+                                                      (con1_tvs `zip` result_inst_tys)++        ; let rec_res_ty    = TcType.substTy result_subst con1_res_ty+              scrut_ty      = TcType.substTy scrut_subst  con1_res_ty+              con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys++        ; wrap_res <- tcSubTypeHR (exprCtOrigin expr)+                                  (Just expr) rec_res_ty res_ty+        ; co_scrut <- unifyType (Just record_expr) record_rho scrut_ty+                -- NB: normal unification is OK here (as opposed to subsumption),+                -- because for this to work out, both record_rho and scrut_ty have+                -- to be normal datatypes -- no contravariant stuff can go on++        -- STEP 5+        -- Typecheck the bindings+        ; rbinds'      <- tcRecordUpd con1 con1_arg_tys' rbinds++        -- STEP 6: Deal with the stupid theta+        ; let theta' = substThetaUnchecked scrut_subst (conLikeStupidTheta con1)+        ; instStupidTheta RecordUpdOrigin theta'++        -- Step 7: make a cast for the scrutinee, in the+        --         case that it's from a data family+        ; let fam_co :: HsWrapper   -- RepT t1 .. tn ~R scrut_ty+              fam_co | Just tycon <- mtycon+                     , Just co_con <- tyConFamilyCoercion_maybe tycon+                     = mkWpCastR (mkTcUnbranchedAxInstCo co_con scrut_inst_tys [])+                     | otherwise+                     = idHsWrapper++        -- Step 8: Check that the req constraints are satisfied+        -- For normal data constructors req_theta is empty but we must do+        -- this check for pattern synonyms.+        ; let req_theta' = substThetaUnchecked scrut_subst req_theta+        ; req_wrap <- instCallConstraints RecordUpdOrigin req_theta'++        -- Phew!+        ; return $+          mkHsWrap wrap_res $+          RecordUpd { rupd_expr = mkLHsWrap fam_co (mkLHsWrapCo co_scrut record_expr')+                    , rupd_flds = rbinds'+                    , rupd_cons = relevant_cons, rupd_in_tys = scrut_inst_tys+                    , rupd_out_tys = result_inst_tys, rupd_wrap = req_wrap } }++tcExpr (HsRecFld f) res_ty+    = tcCheckRecSelId f res_ty++{-+************************************************************************+*                                                                      *+        Arithmetic sequences                    e.g. [a,b..]+        and their parallel-array counterparts   e.g. [: a,b.. :]++*                                                                      *+************************************************************************+-}++tcExpr (ArithSeq _ witness seq) res_ty+  = tcArithSeq witness seq res_ty++tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty+  = do  { res_ty <- expTypeToType res_ty+        ; (coi, elt_ty) <- matchExpectedPArrTy res_ty+        ; expr1' <- tcPolyExpr expr1 elt_ty+        ; expr2' <- tcPolyExpr expr2 elt_ty+        ; enumFromToP <- initDsTc $ dsDPHBuiltin enumFromToPVar+        ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)+                                 (idName enumFromToP) elt_ty+        ; return $+          mkHsWrapCo coi $ PArrSeq enum_from_to (FromTo expr1' expr2') }++tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty+  = do  { res_ty <- expTypeToType res_ty+        ; (coi, elt_ty) <- matchExpectedPArrTy res_ty+        ; expr1' <- tcPolyExpr expr1 elt_ty+        ; expr2' <- tcPolyExpr expr2 elt_ty+        ; expr3' <- tcPolyExpr expr3 elt_ty+        ; enumFromThenToP <- initDsTc $ dsDPHBuiltin enumFromThenToPVar+        ; eft <- newMethodFromName (PArrSeqOrigin seq)+                      (idName enumFromThenToP) elt_ty        -- !!!FIXME: chak+        ; return $+          mkHsWrapCo coi $+          PArrSeq eft (FromThenTo expr1' expr2' expr3') }++tcExpr (PArrSeq _ _) _+  = panic "TcExpr.tcExpr: Infinite parallel array!"+    -- the parser shouldn't have generated it and the renamer shouldn't have+    -- let it through++{-+************************************************************************+*                                                                      *+                Template Haskell+*                                                                      *+************************************************************************+-}++-- HsSpliced is an annotation produced by 'RnSplice.rnSpliceExpr'.+-- Here we get rid of it and add the finalizers to the global environment.+--+-- See Note [Delaying modFinalizers in untyped splices] in RnSplice.+tcExpr (HsSpliceE (HsSpliced mod_finalizers (HsSplicedExpr expr)))+       res_ty+  = do addModFinalizersWithLclEnv mod_finalizers+       tcExpr expr res_ty+tcExpr (HsSpliceE splice)        res_ty+  = tcSpliceExpr splice res_ty+tcExpr (HsBracket brack)         res_ty+  = tcTypedBracket   brack res_ty+tcExpr (HsRnBracketOut brack ps) res_ty+  = tcUntypedBracket brack ps res_ty++{-+************************************************************************+*                                                                      *+                Catch-all+*                                                                      *+************************************************************************+-}++tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)+  -- Include ArrForm, ArrApp, which shouldn't appear at all+  -- Also HsTcBracketOut, HsQuasiQuoteE++{-+************************************************************************+*                                                                      *+                Arithmetic sequences [a..b] etc+*                                                                      *+************************************************************************+-}++tcArithSeq :: Maybe (SyntaxExpr Name) -> ArithSeqInfo Name -> ExpRhoType+           -> TcM (HsExpr TcId)++tcArithSeq witness seq@(From expr) res_ty+  = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty+       ; expr' <- tcPolyExpr expr elt_ty+       ; enum_from <- newMethodFromName (ArithSeqOrigin seq)+                              enumFromName elt_ty+       ; return $ mkHsWrap wrap $+         ArithSeq enum_from wit' (From expr') }++tcArithSeq witness seq@(FromThen expr1 expr2) res_ty+  = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty+       ; expr1' <- tcPolyExpr expr1 elt_ty+       ; expr2' <- tcPolyExpr expr2 elt_ty+       ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)+                              enumFromThenName elt_ty+       ; return $ mkHsWrap wrap $+         ArithSeq enum_from_then wit' (FromThen expr1' expr2') }++tcArithSeq witness seq@(FromTo expr1 expr2) res_ty+  = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty+       ; expr1' <- tcPolyExpr expr1 elt_ty+       ; expr2' <- tcPolyExpr expr2 elt_ty+       ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)+                              enumFromToName elt_ty+       ; return $ mkHsWrap wrap $+         ArithSeq enum_from_to wit' (FromTo expr1' expr2') }++tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty+  = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty+        ; expr1' <- tcPolyExpr expr1 elt_ty+        ; expr2' <- tcPolyExpr expr2 elt_ty+        ; expr3' <- tcPolyExpr expr3 elt_ty+        ; eft <- newMethodFromName (ArithSeqOrigin seq)+                              enumFromThenToName elt_ty+        ; return $ mkHsWrap wrap $+          ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') }++-----------------+arithSeqEltType :: Maybe (SyntaxExpr Name) -> ExpRhoType+                -> TcM (HsWrapper, TcType, Maybe (SyntaxExpr Id))+arithSeqEltType Nothing res_ty+  = do { res_ty <- expTypeToType res_ty+       ; (coi, elt_ty) <- matchExpectedListTy res_ty+       ; return (mkWpCastN coi, elt_ty, Nothing) }+arithSeqEltType (Just fl) res_ty+  = do { (elt_ty, fl')+           <- tcSyntaxOp ListOrigin fl [SynList] res_ty $+              \ [elt_ty] -> return elt_ty+       ; return (idHsWrapper, elt_ty, Just fl') }++{-+************************************************************************+*                                                                      *+                Applications+*                                                                      *+************************************************************************+-}++type LHsExprArgIn  = Either (LHsExpr Name) (LHsWcType Name)+type LHsExprArgOut = Either (LHsExpr TcId) (LHsWcType Name)+   -- Left e   => argument expression+   -- Right ty => visible type application++tcApp1 :: HsExpr Name  -- either HsApp or HsAppType+       -> ExpRhoType -> TcM (HsExpr TcId)+tcApp1 e res_ty+  = do { (wrap, fun, args) <- tcApp Nothing (noLoc e) [] res_ty+       ; return (mkHsWrap wrap $ unLoc $ foldl mk_hs_app fun args) }+  where+    mk_hs_app f (Left a)  = mkHsApp f a+    mk_hs_app f (Right a) = mkHsAppTypeOut f a++tcApp :: Maybe SDoc  -- like "The function `f' is applied to"+                     -- or leave out to get exactly that message+      -> LHsExpr Name -> [LHsExprArgIn] -- Function and args+      -> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut])+           -- (wrap, fun, args). For an ordinary function application,+           -- these should be assembled as (wrap (fun args)).+           -- But OpApp is slightly different, so that's why the caller+           -- must assemble++tcApp m_herald orig_fun orig_args res_ty+  = go orig_fun orig_args+  where+    go :: LHsExpr Name -> [LHsExprArgIn]+       -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut])+    go (L _ (HsPar e))       args = go e  args+    go (L _ (HsApp e1 e2))   args = go e1 (Left e2:args)+    go (L _ (HsAppType e t)) args = go e  (Right t:args)++    go (L loc (HsVar (L _ fun))) args+      | fun `hasKey` tagToEnumKey+      , count isLeft args == 1+      = do { (wrap, expr, args) <- tcTagToEnum loc fun args res_ty+           ; return (wrap, expr, args) }++      | fun `hasKey` seqIdKey+      , count isLeft args == 2+      = do { (wrap, expr, args) <- tcSeq loc fun args res_ty+           ; return (wrap, expr, args) }++    go (L loc (HsRecFld (Ambiguous lbl _))) args@(Left (L _ arg) : _)+      | Just sig_ty <- obviousSig arg+      = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty+           ; sel_name  <- disambiguateSelector lbl sig_tc_ty+           ; go (L loc (HsRecFld (Unambiguous lbl sel_name))) args }++    go fun args+      = do {   -- Type-check the function+           ; (fun1, fun_sigma) <- tcInferFun fun+           ; let orig = lexprCtOrigin fun++           ; (wrap_fun, args1, actual_res_ty)+               <- tcArgs fun fun_sigma orig args+                         (m_herald `orElse` mk_app_msg fun)++                -- this is just like tcWrapResult, but the types don't line+                -- up to call that function+           ; wrap_res <- addFunResCtxt True (unLoc fun) actual_res_ty res_ty $+                         tcSubTypeDS_NC_O orig GenSigCtxt+                           (Just $ foldl mk_hs_app fun args)+                           actual_res_ty res_ty++           ; return (wrap_res, mkLHsWrap wrap_fun fun1, args1) }++    mk_hs_app f (Left a)  = mkHsApp f a+    mk_hs_app f (Right a) = mkHsAppType f a++mk_app_msg :: LHsExpr Name -> SDoc+mk_app_msg fun = sep [ text "The function" <+> quotes (ppr fun)+                     , text "is applied to"]++mk_op_msg :: LHsExpr Name -> SDoc+mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes"++----------------+tcInferFun :: LHsExpr Name -> TcM (LHsExpr TcId, TcSigmaType)+-- Infer type of a function+tcInferFun (L loc (HsVar (L _ name)))+  = do { (fun, ty) <- setSrcSpan loc (tcInferId name)+               -- Don't wrap a context around a plain Id+       ; return (L loc fun, ty) }++tcInferFun (L loc (HsRecFld f))+  = do { (fun, ty) <- setSrcSpan loc (tcInferRecSelId f)+               -- Don't wrap a context around a plain Id+       ; return (L loc fun, ty) }++tcInferFun fun+  = tcInferSigma fun+      -- NB: tcInferSigma; see TcUnify+      -- Note [Deep instantiation of InferResult]+++----------------+-- | Type-check the arguments to a function, possibly including visible type+-- applications+tcArgs :: LHsExpr Name   -- ^ The function itself (for err msgs only)+       -> TcSigmaType    -- ^ the (uninstantiated) type of the function+       -> CtOrigin       -- ^ the origin for the function's type+       -> [LHsExprArgIn] -- ^ the args+       -> SDoc           -- ^ the herald for matchActualFunTys+       -> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)+          -- ^ (a wrapper for the function, the tc'd args, result type)+tcArgs fun orig_fun_ty fun_orig orig_args herald+  = go [] 1 orig_fun_ty orig_args+  where+    orig_arity = length orig_args++    go _ _ fun_ty [] = return (idHsWrapper, [], fun_ty)++    go acc_args n fun_ty (Right hs_ty_arg:args)+      = do { (wrap1, upsilon_ty) <- topInstantiateInferred fun_orig fun_ty+               -- wrap1 :: fun_ty "->" upsilon_ty+           ; case tcSplitForAllTy_maybe upsilon_ty of+               Just (tvb, inner_ty) ->+                 do { let tv   = binderVar tvb+                          vis  = binderArgFlag tvb+                          kind = tyVarKind tv+                    ; MASSERT2( vis == Specified+                        , (vcat [ ppr fun_ty, ppr upsilon_ty, ppr tvb+                                , ppr inner_ty, pprTyVar tv+                                , ppr vis ]) )+                    ; ty_arg <- tcHsTypeApp hs_ty_arg kind+                    ; let insted_ty = substTyWithUnchecked [tv] [ty_arg] inner_ty+                    ; (inner_wrap, args', res_ty)+                        <- go acc_args (n+1) insted_ty args+                   -- inner_wrap :: insted_ty "->" (map typeOf args') -> res_ty+                    ; let inst_wrap = mkWpTyApps [ty_arg]+                    ; return ( inner_wrap <.> inst_wrap <.> wrap1+                             , Right hs_ty_arg : args'+                             , res_ty ) }+               _ -> ty_app_err upsilon_ty hs_ty_arg }++    go acc_args n fun_ty (Left arg : args)+      = do { (wrap, [arg_ty], res_ty)+               <- matchActualFunTysPart herald fun_orig (Just fun) 1 fun_ty+                                        acc_args orig_arity+               -- wrap :: fun_ty "->" arg_ty -> res_ty+           ; arg' <- tcArg fun arg arg_ty n+           ; (inner_wrap, args', inner_res_ty)+               <- go (arg_ty : acc_args) (n+1) res_ty args+               -- inner_wrap :: res_ty "->" (map typeOf args') -> inner_res_ty+           ; return ( mkWpFun idHsWrapper inner_wrap arg_ty res_ty doc <.> wrap+                    , Left arg' : args'+                    , inner_res_ty ) }+      where+        doc = text "When checking the" <+> speakNth n <+>+              text "argument to" <+> quotes (ppr fun)++    ty_app_err ty arg+      = do { (_, ty) <- zonkTidyTcType emptyTidyEnv ty+           ; failWith $+               text "Cannot apply expression of type" <+> quotes (ppr ty) $$+               text "to a visible type argument" <+> quotes (ppr arg) }++----------------+tcArg :: LHsExpr Name                    -- The function (for error messages)+      -> LHsExpr Name                    -- Actual arguments+      -> TcRhoType                       -- expected arg type+      -> Int                             -- # of argument+      -> TcM (LHsExpr TcId)             -- Resulting argument+tcArg fun arg ty arg_no = addErrCtxt (funAppCtxt fun arg arg_no) $+                          tcPolyExprNC arg ty++----------------+tcTupArgs :: [LHsTupArg Name] -> [TcSigmaType] -> TcM [LHsTupArg TcId]+tcTupArgs args tys+  = ASSERT( equalLength args tys ) mapM go (args `zip` tys)+  where+    go (L l (Missing {}),   arg_ty) = return (L l (Missing arg_ty))+    go (L l (Present expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty+                                         ; return (L l (Present expr')) }++---------------------------+-- See TcType.SyntaxOpType also for commentary+tcSyntaxOp :: CtOrigin+           -> SyntaxExpr Name+           -> [SyntaxOpType]           -- ^ shape of syntax operator arguments+           -> ExpRhoType               -- ^ overall result type+           -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments+           -> TcM (a, SyntaxExpr TcId)+-- ^ Typecheck a syntax operator+-- The operator is always a variable at this stage (i.e. renamer output)+tcSyntaxOp orig expr arg_tys res_ty+  = tcSyntaxOpGen orig expr arg_tys (SynType res_ty)++-- | Slightly more general version of 'tcSyntaxOp' that allows the caller+-- to specify the shape of the result of the syntax operator+tcSyntaxOpGen :: CtOrigin+              -> SyntaxExpr Name+              -> [SyntaxOpType]+              -> SyntaxOpType+              -> ([TcSigmaType] -> TcM a)+              -> TcM (a, SyntaxExpr TcId)+tcSyntaxOpGen orig (SyntaxExpr { syn_expr = HsVar (L _ op) })+              arg_tys res_ty thing_inside+  = do { (expr, sigma) <- tcInferId op+       ; (result, expr_wrap, arg_wraps, res_wrap)+           <- tcSynArgA orig sigma arg_tys res_ty $+              thing_inside+       ; return (result, SyntaxExpr { syn_expr      = mkHsWrap expr_wrap expr+                                    , syn_arg_wraps = arg_wraps+                                    , syn_res_wrap  = res_wrap }) }++tcSyntaxOpGen _ other _ _ _ = pprPanic "tcSyntaxOp" (ppr other)++{-+Note [tcSynArg]+~~~~~~~~~~~~~~~+Because of the rich structure of SyntaxOpType, we must do the+contra-/covariant thing when working down arrows, to get the+instantiation vs. skolemisation decisions correct (and, more+obviously, the orientation of the HsWrappers). We thus have+two tcSynArgs.+-}++-- works on "expected" types, skolemising where necessary+-- See Note [tcSynArg]+tcSynArgE :: CtOrigin+          -> TcSigmaType+          -> SyntaxOpType                -- ^ shape it is expected to have+          -> ([TcSigmaType] -> TcM a)    -- ^ check the arguments+          -> TcM (a, HsWrapper)+           -- ^ returns a wrapper :: (type of right shape) "->" (type passed in)+tcSynArgE orig sigma_ty syn_ty thing_inside+  = do { (skol_wrap, (result, ty_wrapper))+           <- tcSkolemise GenSigCtxt sigma_ty $ \ _ rho_ty ->+              go rho_ty syn_ty+       ; return (result, skol_wrap <.> ty_wrapper) }+    where+    go rho_ty SynAny+      = do { result <- thing_inside [rho_ty]+           ; return (result, idHsWrapper) }++    go rho_ty SynRho   -- same as SynAny, because we skolemise eagerly+      = do { result <- thing_inside [rho_ty]+           ; return (result, idHsWrapper) }++    go rho_ty SynList+      = do { (list_co, elt_ty) <- matchExpectedListTy rho_ty+           ; result <- thing_inside [elt_ty]+           ; return (result, mkWpCastN list_co) }++    go rho_ty (SynFun arg_shape res_shape)+      = do { ( ( ( (result, arg_ty, res_ty)+                 , res_wrapper )                   -- :: res_ty_out "->" res_ty+               , arg_wrapper1, [], arg_wrapper2 )  -- :: arg_ty "->" arg_ty_out+             , match_wrapper )         -- :: (arg_ty -> res_ty) "->" rho_ty+               <- matchExpectedFunTys herald 1 (mkCheckExpType rho_ty) $+                  \ [arg_ty] res_ty ->+                  do { arg_tc_ty <- expTypeToType arg_ty+                     ; res_tc_ty <- expTypeToType res_ty++                         -- another nested arrow is too much for now,+                         -- but I bet we'll never need this+                     ; MASSERT2( case arg_shape of+                                   SynFun {} -> False;+                                   _         -> True+                               , text "Too many nested arrows in SyntaxOpType" $$+                                 pprCtOrigin orig )++                     ; tcSynArgA orig arg_tc_ty [] arg_shape $+                       \ arg_results ->+                       tcSynArgE orig res_tc_ty res_shape $+                       \ res_results ->+                       do { result <- thing_inside (arg_results ++ res_results)+                          ; return (result, arg_tc_ty, res_tc_ty) }}++           ; return ( result+                    , match_wrapper <.>+                      mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper+                              arg_ty res_ty doc ) }+      where+        herald = text "This rebindable syntax expects a function with"+        doc = text "When checking a rebindable syntax operator arising from" <+> ppr orig++    go rho_ty (SynType the_ty)+      = do { wrap   <- tcSubTypeET orig GenSigCtxt the_ty rho_ty+           ; result <- thing_inside []+           ; return (result, wrap) }++-- works on "actual" types, instantiating where necessary+-- See Note [tcSynArg]+tcSynArgA :: CtOrigin+          -> TcSigmaType+          -> [SyntaxOpType]              -- ^ argument shapes+          -> SyntaxOpType                -- ^ result shape+          -> ([TcSigmaType] -> TcM a)    -- ^ check the arguments+          -> TcM (a, HsWrapper, [HsWrapper], HsWrapper)+            -- ^ returns a wrapper to be applied to the original function,+            -- wrappers to be applied to arguments+            -- and a wrapper to be applied to the overall expression+tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside+  = do { (match_wrapper, arg_tys, res_ty)+           <- matchActualFunTys herald orig noThing (length arg_shapes) sigma_ty+              -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty)+       ; ((result, res_wrapper), arg_wrappers)+           <- tc_syn_args_e arg_tys arg_shapes $ \ arg_results ->+              tc_syn_arg    res_ty  res_shape  $ \ res_results ->+              thing_inside (arg_results ++ res_results)+       ; return (result, match_wrapper, arg_wrappers, res_wrapper) }+  where+    herald = text "This rebindable syntax expects a function with"++    tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType]+                  -> ([TcSigmaType] -> TcM a)+                  -> TcM (a, [HsWrapper])+                    -- the wrappers are for arguments+    tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside+      = do { ((result, arg_wraps), arg_wrap)+               <- tcSynArgE     orig arg_ty  arg_shape  $ \ arg1_results ->+                  tc_syn_args_e      arg_tys arg_shapes $ \ args_results ->+                  thing_inside (arg1_results ++ args_results)+           ; return (result, arg_wrap : arg_wraps) }+    tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside []++    tc_syn_arg :: TcSigmaType -> SyntaxOpType+               -> ([TcSigmaType] -> TcM a)+               -> TcM (a, HsWrapper)+                  -- the wrapper applies to the overall result+    tc_syn_arg res_ty SynAny thing_inside+      = do { result <- thing_inside [res_ty]+           ; return (result, idHsWrapper) }+    tc_syn_arg res_ty SynRho thing_inside+      = do { (inst_wrap, rho_ty) <- deeplyInstantiate orig res_ty+               -- inst_wrap :: res_ty "->" rho_ty+           ; result <- thing_inside [rho_ty]+           ; return (result, inst_wrap) }+    tc_syn_arg res_ty SynList thing_inside+      = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty+               -- inst_wrap :: res_ty "->" rho_ty+           ; (list_co, elt_ty)   <- matchExpectedListTy rho_ty+               -- list_co :: [elt_ty] ~N rho_ty+           ; result <- thing_inside [elt_ty]+           ; return (result, mkWpCastN (mkTcSymCo list_co) <.> inst_wrap) }+    tc_syn_arg _ (SynFun {}) _+      = pprPanic "tcSynArgA hits a SynFun" (ppr orig)+    tc_syn_arg res_ty (SynType the_ty) thing_inside+      = do { wrap   <- tcSubTypeO orig GenSigCtxt res_ty the_ty+           ; result <- thing_inside []+           ; return (result, wrap) }++{-+Note [Push result type in]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Unify with expected result before type-checking the args so that the+info from res_ty percolates to args.  This is when we might detect a+too-few args situation.  (One can think of cases when the opposite+order would give a better error message.)+experimenting with putting this first.++Here's an example where it actually makes a real difference++   class C t a b | t a -> b+   instance C Char a Bool++   data P t a = forall b. (C t a b) => MkP b+   data Q t   = MkQ (forall a. P t a)++   f1, f2 :: Q Char;+   f1 = MkQ (MkP True)+   f2 = MkQ (MkP True :: forall a. P Char a)++With the change, f1 will type-check, because the 'Char' info from+the signature is propagated into MkQ's argument. With the check+in the other order, the extra signature in f2 is reqd.++************************************************************************+*                                                                      *+                Expressions with a type signature+                        expr :: type+*                                                                      *+********************************************************************* -}++tcExprSig :: LHsExpr Name -> TcIdSigInfo -> TcM (LHsExpr TcId, TcType)+tcExprSig expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc })+  = setSrcSpan loc $   -- Sets the location for the implication constraint+    do { (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id+       ; given <- newEvVars theta+       ; let skol_info = SigSkol ExprSigCtxt (idType poly_id) tv_prs+             skol_tvs  = map snd tv_prs+       ; (ev_binds, expr') <- checkConstraints skol_info skol_tvs given $+                              tcExtendTyVarEnv2 tv_prs $+                              tcPolyExprNC expr tau++       ; let poly_wrap = mkWpTyLams   skol_tvs+                         <.> mkWpLams given+                         <.> mkWpLet  ev_binds+       ; return (mkLHsWrap poly_wrap expr', idType poly_id) }++tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc })+  = setSrcSpan loc $   -- Sets the location for the implication constraint+    do { (tclvl, wanted, (expr', sig_inst))+             <- pushLevelAndCaptureConstraints  $+                do { sig_inst <- tcInstSig sig+                   ; expr' <- tcExtendTyVarEnv2 (sig_inst_skols sig_inst) $+                              tcExtendTyVarEnv2 (sig_inst_wcs   sig_inst) $+                              tcPolyExprNC expr (sig_inst_tau sig_inst)+                   ; return (expr', sig_inst) }+       -- See Note [Partial expression signatures]+       ; let tau = sig_inst_tau sig_inst+             infer_mode | null (sig_inst_theta sig_inst)+                        , isNothing (sig_inst_wcx sig_inst)+                        = ApplyMR+                        | otherwise+                        = NoRestrictions+       ; (qtvs, givens, ev_binds)+                 <- simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted+       ; tau <- zonkTcType tau+       ; let inferred_theta = map evVarPred givens+             tau_tvs        = tyCoVarsOfType tau+       ; (binders, my_theta) <- chooseInferredQuantifiers inferred_theta+                                   tau_tvs qtvs (Just sig_inst)+       ; let inferred_sigma = mkInfSigmaTy qtvs inferred_theta tau+             my_sigma       = mkForAllTys binders (mkPhiTy  my_theta tau)+       ; wrap <- if inferred_sigma `eqType` my_sigma -- NB: eqType ignores vis.+                 then return idHsWrapper  -- Fast path; also avoids complaint when we infer+                                          -- an ambiguouse type and have AllowAmbiguousType+                                          -- e..g infer  x :: forall a. F a -> Int+                 else tcSubType_NC ExprSigCtxt inferred_sigma my_sigma++       ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma)+       ; let poly_wrap = wrap+                         <.> mkWpTyLams qtvs+                         <.> mkWpLams givens+                         <.> mkWpLet  ev_binds+       ; return (mkLHsWrap poly_wrap expr', my_sigma) }+++{- Note [Partial expression signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Partial type signatures on expressions are easy to get wrong.  But+here is a guiding principile+    e :: ty+should behave like+    let x :: ty+        x = e+    in x++So for partial signatures we apply the MR if no context is given.  So+   e :: IO _          apply the MR+   e :: _ => IO _     do not apply the MR+just like in TcBinds.decideGeneralisationPlan++This makes a difference (Trac #11670):+   peek :: Ptr a -> IO CLong+   peek ptr = peekElemOff undefined 0 :: _+from (peekElemOff undefined 0) we get+          type: IO w+   constraints: Storable w++We must NOT try to generalise over 'w' because the signature specifies+no constraints so we'll complain about not being able to solve+Storable w.  Instead, don't generalise; then _ gets instantiated to+CLong, as it should.+-}++{- *********************************************************************+*                                                                      *+                 tcInferId+*                                                                      *+********************************************************************* -}++tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr TcId)+tcCheckId name res_ty+  = do { (expr, actual_res_ty) <- tcInferId name+       ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])+       ; addFunResCtxt False (HsVar (noLoc name)) actual_res_ty res_ty $+         tcWrapResultO (OccurrenceOf name)  expr actual_res_ty res_ty }++tcCheckRecSelId :: AmbiguousFieldOcc Name -> ExpRhoType -> TcM (HsExpr TcId)+tcCheckRecSelId f@(Unambiguous (L _ lbl) _) res_ty+  = do { (expr, actual_res_ty) <- tcInferRecSelId f+       ; addFunResCtxt False (HsRecFld f) actual_res_ty res_ty $+         tcWrapResultO (OccurrenceOfRecSel lbl) expr actual_res_ty res_ty }+tcCheckRecSelId (Ambiguous lbl _) res_ty+  = case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of+      Nothing       -> ambiguousSelector lbl+      Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg+                          ; tcCheckRecSelId (Unambiguous lbl sel_name) res_ty }++------------------------+tcInferRecSelId :: AmbiguousFieldOcc Name -> TcM (HsExpr TcId, TcRhoType)+tcInferRecSelId (Unambiguous (L _ lbl) sel)+  = do { (expr', ty) <- tc_infer_id lbl sel+       ; return (expr', ty) }+tcInferRecSelId (Ambiguous lbl _)+  = ambiguousSelector lbl++------------------------+tcInferId :: Name -> TcM (HsExpr TcId, TcSigmaType)+-- Look up an occurrence of an Id+-- Do not instantiate its type+tcInferId id_name+  | id_name `hasKey` tagToEnumKey+  = failWithTc (text "tagToEnum# must appear applied to one argument")+        -- tcApp catches the case (tagToEnum# arg)++  | id_name `hasKey` assertIdKey+  = do { dflags <- getDynFlags+       ; if gopt Opt_IgnoreAsserts dflags+         then tc_infer_id (nameRdrName id_name) id_name+         else tc_infer_assert id_name }++  | otherwise+  = do { (expr, ty) <- tc_infer_id (nameRdrName id_name) id_name+       ; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty)+       ; return (expr, ty) }++tc_infer_assert :: Name -> TcM (HsExpr TcId, TcSigmaType)+-- Deal with an occurrence of 'assert'+-- See Note [Adding the implicit parameter to 'assert']+tc_infer_assert assert_name+  = do { assert_error_id <- tcLookupId assertErrorName+       ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name)+                                          (idType assert_error_id)+       ; return (mkHsWrap wrap (HsVar (noLoc assert_error_id)), id_rho)+       }++tc_infer_id :: RdrName -> Name -> TcM (HsExpr TcId, TcSigmaType)+tc_infer_id lbl id_name+ = do { thing <- tcLookup id_name+      ; case thing of+             ATcId { tct_id = id }+               -> do { check_naughty id        -- Note [Local record selectors]+                     ; checkThLocalId id+                     ; return_id id }++             AGlobal (AnId id)+               -> do { check_naughty id+                     ; return_id id }+                    -- A global cannot possibly be ill-staged+                    -- nor does it need the 'lifting' treatment+                    -- hence no checkTh stuff here++             AGlobal (AConLike cl) -> case cl of+                 RealDataCon con -> return_data_con con+                 PatSynCon ps    -> tcPatSynBuilderOcc ps++             _ -> failWithTc $+                  ppr thing <+> text "used where a value identifier was expected" }+  where+    return_id id = return (HsVar (noLoc id), idType id)++    return_data_con con+       -- For data constructors, must perform the stupid-theta check+      | null stupid_theta+      = return (HsConLikeOut (RealDataCon con), con_ty)++      | otherwise+       -- See Note [Instantiating stupid theta]+      = do { let (tvs, theta, rho) = tcSplitSigmaTy con_ty+           ; (subst, tvs') <- newMetaTyVars tvs+           ; let tys'   = mkTyVarTys tvs'+                 theta' = substTheta subst theta+                 rho'   = substTy subst rho+           ; wrap <- instCall (OccurrenceOf id_name) tys' theta'+           ; addDataConStupidTheta con tys'+           ; return (mkHsWrap wrap (HsConLikeOut (RealDataCon con)), rho') }++      where+        con_ty         = dataConUserType con+        stupid_theta   = dataConStupidTheta con++    check_naughty id+      | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl)+      | otherwise                  = return ()+++tcUnboundId :: UnboundVar -> ExpRhoType -> TcM (HsExpr TcId)+-- Typecheck an occurrence of an unbound Id+--+-- Some of these started life as a true expression hole "_".+-- Others might simply be variables that accidentally have no binding site+--+-- We turn all of them into HsVar, since HsUnboundVar can't contain an+-- Id; and indeed the evidence for the CHoleCan does bind it, so it's+-- not unbound any more!+tcUnboundId unbound res_ty+ = do { ty <- newOpenFlexiTyVarTy  -- Allow Int# etc (Trac #12531)+      ; let occ = unboundVarOcc unbound+      ; name <- newSysName occ+      ; let ev = mkLocalId name ty+      ; loc <- getCtLocM HoleOrigin Nothing+      ; let can = CHoleCan { cc_ev = CtWanted { ctev_pred = ty+                                              , ctev_dest = EvVarDest ev+                                              , ctev_nosh = WDeriv+                                              , ctev_loc  = loc}+                           , cc_hole = ExprHole unbound }+      ; emitInsoluble can+      ; tcWrapResultO (UnboundOccurrenceOf occ) (HsVar (noLoc ev)) ty res_ty }+++{-+Note [Adding the implicit parameter to 'assert']+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The typechecker transforms (assert e1 e2) to (assertError e1 e2).+This isn't really the Right Thing because there's no way to "undo"+if you want to see the original source code in the typechecker+output.  We'll have fix this in due course, when we care more about+being able to reconstruct the exact original program.++Note [tagToEnum#]+~~~~~~~~~~~~~~~~~+Nasty check to ensure that tagToEnum# is applied to a type that is an+enumeration TyCon.  Unification may refine the type later, but this+check won't see that, alas.  It's crude, because it relies on our+knowing *now* that the type is ok, which in turn relies on the+eager-unification part of the type checker pushing enough information+here.  In theory the Right Thing to do is to have a new form of+constraint but I definitely cannot face that!  And it works ok as-is.++Here's are two cases that should fail+        f :: forall a. a+        f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable++        g :: Int+        g = tagToEnum# 0        -- Int is not an enumeration++When data type families are involved it's a bit more complicated.+     data family F a+     data instance F [Int] = A | B | C+Then we want to generate something like+     tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int]+Usually that coercion is hidden inside the wrappers for+constructors of F [Int] but here we have to do it explicitly.++It's all grotesquely complicated.++Note [Instantiating stupid theta]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Normally, when we infer the type of an Id, we don't instantiate,+because we wish to allow for visible type application later on.+But if a datacon has a stupid theta, we're a bit stuck. We need+to emit the stupid theta constraints with instantiated types. It's+difficult to defer this to the lazy instantiation, because a stupid+theta has no spot to put it in a type. So we just instantiate eagerly+in this case. Thus, users cannot use visible type application with+a data constructor sporting a stupid theta. I won't feel so bad for+the users that complain.++-}++tcSeq :: SrcSpan -> Name -> [LHsExprArgIn]+      -> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut])+-- (seq e1 e2) :: res_ty+-- We need a special typing rule because res_ty can be unboxed+-- See Note [Typing rule for seq]+tcSeq loc fun_name args res_ty+  = do  { fun <- tcLookupId fun_name+        ; (arg1_ty, args1) <- case args of+            (Right hs_ty_arg1 : args1)+              -> do { ty_arg1 <- tcHsTypeApp hs_ty_arg1 liftedTypeKind+                    ; return (ty_arg1, args1) }++            _ -> do { arg_ty1 <- newFlexiTyVarTy liftedTypeKind+                    ; return (arg_ty1, args) }++        ; (arg1, arg2, arg2_exp_ty) <- case args1 of+            [Right hs_ty_arg2, Left term_arg1, Left term_arg2]+              -> do { arg2_kind <- newOpenTypeKind+                    ; ty_arg2 <- tcHsTypeApp hs_ty_arg2 arg2_kind+                                   -- see Note [Typing rule for seq]+                    ; _ <- tcSubTypeDS (OccurrenceOf fun_name) GenSigCtxt ty_arg2 res_ty+                    ; return (term_arg1, term_arg2, mkCheckExpType ty_arg2) }+            [Left term_arg1, Left term_arg2]+              -> return (term_arg1, term_arg2, res_ty)+            _ -> too_many_args "seq" args++        ; arg1' <- tcMonoExpr arg1 (mkCheckExpType arg1_ty)+        ; arg2' <- tcMonoExpr arg2 arg2_exp_ty+        ; res_ty <- readExpType res_ty  -- by now, it's surely filled in+        ; let fun'    = L loc (HsWrap ty_args (HsVar (L loc fun)))+              ty_args = WpTyApp res_ty <.> WpTyApp arg1_ty+        ; return (idHsWrapper, fun', [Left arg1', Left arg2']) }++tcTagToEnum :: SrcSpan -> Name -> [LHsExprArgIn] -> ExpRhoType+            -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut])+-- tagToEnum# :: forall a. Int# -> a+-- See Note [tagToEnum#]   Urgh!+tcTagToEnum loc fun_name args res_ty+  = do { fun <- tcLookupId fun_name++       ; arg <- case args of+           [Right hs_ty_arg, Left term_arg]+             -> do { ty_arg <- tcHsTypeApp hs_ty_arg liftedTypeKind+                   ; _ <- tcSubTypeDS (OccurrenceOf fun_name) GenSigCtxt ty_arg res_ty+                     -- other than influencing res_ty, we just+                     -- don't care about a type arg passed in.+                     -- So drop the evidence.+                   ; return term_arg }+           [Left term_arg] -> do { _ <- expTypeToType res_ty+                                 ; return term_arg }+           _          -> too_many_args "tagToEnum#" args++       ; res_ty <- readExpType res_ty+       ; ty'    <- zonkTcType res_ty++       -- Check that the type is algebraic+       ; let mb_tc_app = tcSplitTyConApp_maybe ty'+             Just (tc, tc_args) = mb_tc_app+       ; checkTc (isJust mb_tc_app)+                 (mk_error ty' doc1)++       -- Look through any type family+       ; fam_envs <- tcGetFamInstEnvs+       ; let (rep_tc, rep_args, coi)+               = tcLookupDataFamInst fam_envs tc tc_args+            -- coi :: tc tc_args ~R rep_tc rep_args++       ; checkTc (isEnumerationTyCon rep_tc)+                 (mk_error ty' doc2)++       ; arg' <- tcMonoExpr arg (mkCheckExpType intPrimTy)+       ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar (L loc fun)))+             rep_ty = mkTyConApp rep_tc rep_args++       ; return (mkWpCastR (mkTcSymCo coi), fun', [Left arg']) }+                 -- coi is a Representational coercion+  where+    doc1 = vcat [ text "Specify the type by giving a type signature"+                , text "e.g. (tagToEnum# x) :: Bool" ]+    doc2 = text "Result type must be an enumeration type"++    mk_error :: TcType -> SDoc -> SDoc+    mk_error ty what+      = hang (text "Bad call to tagToEnum#"+               <+> text "at type" <+> ppr ty)+           2 what++too_many_args :: String -> [LHsExprArgIn] -> TcM a+too_many_args fun args+  = failWith $+    hang (text "Too many type arguments to" <+> text fun <> colon)+       2 (sep (map pp args))+  where+    pp (Left e)                             = ppr e+    pp (Right (HsWC { hswc_body = L _ t })) = pprParendHsType t+++{-+************************************************************************+*                                                                      *+                 Template Haskell checks+*                                                                      *+************************************************************************+-}++checkThLocalId :: Id -> TcM ()+checkThLocalId id+  = do  { mb_local_use <- getStageAndBindLevel (idName id)+        ; case mb_local_use of+             Just (top_lvl, bind_lvl, use_stage)+                | thLevel use_stage > bind_lvl+                , isNotTopLevel top_lvl+                -> checkCrossStageLifting id use_stage+             _  -> return ()   -- Not a locally-bound thing, or+                               -- no cross-stage link+    }++--------------------------------------+checkCrossStageLifting :: Id -> ThStage -> TcM ()+-- If we are inside typed brackets, and (use_lvl > bind_lvl)+-- we must check whether there's a cross-stage lift to do+-- Examples   \x -> [|| x ||]+--            [|| map ||]+-- There is no error-checking to do, because the renamer did that+--+-- This is similar to checkCrossStageLifting in RnSplice, but+-- this code is applied to *typed* brackets.++checkCrossStageLifting id (Brack _ (TcPending ps_var lie_var))+  =     -- Nested identifiers, such as 'x' in+        -- E.g. \x -> [|| h x ||]+        -- We must behave as if the reference to x was+        --      h $(lift x)+        -- We use 'x' itself as the splice proxy, used by+        -- the desugarer to stitch it all back together.+        -- If 'x' occurs many times we may get many identical+        -- bindings of the same splice proxy, but that doesn't+        -- matter, although it's a mite untidy.+    do  { let id_ty = idType id+        ; checkTc (isTauTy id_ty) (polySpliceErr id)+               -- If x is polymorphic, its occurrence sites might+               -- have different instantiations, so we can't use plain+               -- 'x' as the splice proxy name.  I don't know how to+               -- solve this, and it's probably unimportant, so I'm+               -- just going to flag an error for now++        ; lift <- if isStringTy id_ty then+                     do { sid <- tcLookupId THNames.liftStringName+                                     -- See Note [Lifting strings]+                        ; return (HsVar (noLoc sid)) }+                  else+                     setConstraintVar lie_var   $+                          -- Put the 'lift' constraint into the right LIE+                     newMethodFromName (OccurrenceOf (idName id))+                                       THNames.liftName id_ty++                   -- Update the pending splices+        ; ps <- readMutVar ps_var+        ; let pending_splice = PendingTcSplice (idName id) (nlHsApp (noLoc lift) (nlHsVar id))+        ; writeMutVar ps_var (pending_splice : ps)++        ; return () }++checkCrossStageLifting _ _ = return ()++polySpliceErr :: Id -> SDoc+polySpliceErr id+  = text "Can't splice the polymorphic local variable" <+> quotes (ppr id)++{-+Note [Lifting strings]+~~~~~~~~~~~~~~~~~~~~~~+If we see $(... [| s |] ...) where s::String, we don't want to+generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc.+So this conditional short-circuits the lifting mechanism to generate+(liftString "xy") in that case.  I didn't want to use overlapping instances+for the Lift class in TH.Syntax, because that can lead to overlapping-instance+errors in a polymorphic situation.++If this check fails (which isn't impossible) we get another chance; see+Note [Converting strings] in Convert.hs++Local record selectors+~~~~~~~~~~~~~~~~~~~~~~+Record selectors for TyCons in this module are ordinary local bindings,+which show up as ATcIds rather than AGlobals.  So we need to check for+naughtiness in both branches.  c.f. TcTyClsBindings.mkAuxBinds.+++************************************************************************+*                                                                      *+\subsection{Record bindings}+*                                                                      *+************************************************************************+-}++getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet+-- These tyvars must not change across the updates+getFixedTyVars upd_fld_occs univ_tvs cons+      = mkVarSet [tv1 | con <- cons+                      , let (u_tvs, _, eqspec, prov_theta+                             , req_theta, arg_tys, _)+                              = conLikeFullSig con+                            theta = eqSpecPreds eqspec+                                     ++ prov_theta+                                     ++ req_theta+                            flds = conLikeFieldLabels con+                            fixed_tvs = exactTyCoVarsOfTypes fixed_tys+                                    -- fixed_tys: See Note [Type of a record update]+                                        `unionVarSet` tyCoVarsOfTypes theta+                                    -- Universally-quantified tyvars that+                                    -- appear in any of the *implicit*+                                    -- arguments to the constructor are fixed+                                    -- See Note [Implicit type sharing]++                            fixed_tys = [ty | (fl, ty) <- zip flds arg_tys+                                            , not (flLabel fl `elem` upd_fld_occs)]+                      , (tv1,tv) <- univ_tvs `zip` u_tvs+                      , tv `elemVarSet` fixed_tvs ]++{-+Note [Disambiguating record fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When the -XDuplicateRecordFields extension is used, and the renamer+encounters a record selector or update that it cannot immediately+disambiguate (because it involves fields that belong to multiple+datatypes), it will defer resolution of the ambiguity to the+typechecker.  In this case, the `Ambiguous` constructor of+`AmbiguousFieldOcc` is used.++Consider the following definitions:++        data S = MkS { foo :: Int }+        data T = MkT { foo :: Int, bar :: Int }+        data U = MkU { bar :: Int, baz :: Int }++When the renamer sees `foo` as a selector or an update, it will not+know which parent datatype is in use.++For selectors, there are two possible ways to disambiguate:++1. Check if the pushed-in type is a function whose domain is a+   datatype, for example:++       f s = (foo :: S -> Int) s++       g :: T -> Int+       g = foo++    This is checked by `tcCheckRecSelId` when checking `HsRecFld foo`.++2. Check if the selector is applied to an argument that has a type+   signature, for example:++       h = foo (s :: S)++    This is checked by `tcApp`.+++Updates are slightly more complex.  The `disambiguateRecordBinds`+function tries to determine the parent datatype in three ways:++1. Check for types that have all the fields being updated. For example:++        f x = x { foo = 3, bar = 2 }++   Here `f` must be updating `T` because neither `S` nor `U` have+   both fields. This may also discover that no possible type exists.+   For example the following will be rejected:++        f' x = x { foo = 3, baz = 3 }++2. Use the type being pushed in, if it is already a TyConApp. The+   following are valid updates to `T`:++        g :: T -> T+        g x = x { foo = 3 }++        g' x = x { foo = 3 } :: T++3. Use the type signature of the record expression, if it exists and+   is a TyConApp. Thus this is valid update to `T`:++        h x = (x :: T) { foo = 3 }+++Note that we do not look up the types of variables being updated, and+no constraint-solving is performed, so for example the following will+be rejected as ambiguous:++     let bad (s :: S) = foo s++     let r :: T+         r = blah+     in r { foo = 3 }++     \r. (r { foo = 3 },  r :: T )++We could add further tests, of a more heuristic nature. For example,+rather than looking for an explicit signature, we could try to infer+the type of the argument to a selector or the record expression being+updated, in case we are lucky enough to get a TyConApp straight+away. However, it might be hard for programmers to predict whether a+particular update is sufficiently obvious for the signature to be+omitted. Moreover, this might change the behaviour of typechecker in+non-obvious ways.++See also Note [HsRecField and HsRecUpdField] in HsPat.+-}++-- Given a RdrName that refers to multiple record fields, and the type+-- of its argument, try to determine the name of the selector that is+-- meant.+disambiguateSelector :: Located RdrName -> Type -> TcM Name+disambiguateSelector lr@(L _ rdr) parent_type+ = do { fam_inst_envs <- tcGetFamInstEnvs+      ; case tyConOf fam_inst_envs parent_type of+          Nothing -> ambiguousSelector lr+          Just p  ->+            do { xs <- lookupParents rdr+               ; let parent = RecSelData p+               ; case lookup parent xs of+                   Just gre -> do { addUsedGRE True gre+                                  ; return (gre_name gre) }+                   Nothing  -> failWithTc (fieldNotInType parent rdr) } }++-- This field name really is ambiguous, so add a suitable "ambiguous+-- occurrence" error, then give up.+ambiguousSelector :: Located RdrName -> TcM a+ambiguousSelector (L _ rdr)+  = do { env <- getGlobalRdrEnv+       ; let gres = lookupGRE_RdrName rdr env+       ; setErrCtxt [] $ addNameClashErrRn rdr gres+       ; failM }++-- Disambiguate the fields in a record update.+-- See Note [Disambiguating record fields]+disambiguateRecordBinds :: LHsExpr Name -> TcRhoType+                        -> [LHsRecUpdField Name] -> ExpRhoType+                        -> TcM [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)]+disambiguateRecordBinds record_expr record_rho rbnds res_ty+    -- Are all the fields unambiguous?+  = case mapM isUnambiguous rbnds of+                     -- If so, just skip to looking up the Ids+                     -- Always the case if DuplicateRecordFields is off+      Just rbnds' -> mapM lookupSelector rbnds'+      Nothing     -> -- If not, try to identify a single parent+        do { fam_inst_envs <- tcGetFamInstEnvs+             -- Look up the possible parents for each field+           ; rbnds_with_parents <- getUpdFieldsParents+           ; let possible_parents = map (map fst . snd) rbnds_with_parents+             -- Identify a single parent+           ; p <- identifyParent fam_inst_envs possible_parents+             -- Pick the right selector with that parent for each field+           ; checkNoErrs $ mapM (pickParent p) rbnds_with_parents }+  where+    -- Extract the selector name of a field update if it is unambiguous+    isUnambiguous :: LHsRecUpdField Name -> Maybe (LHsRecUpdField Name, Name)+    isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of+                        Unambiguous _ sel_name -> Just (x, sel_name)+                        Ambiguous{}            -> Nothing++    -- Look up the possible parents and selector GREs for each field+    getUpdFieldsParents :: TcM [(LHsRecUpdField Name+                                , [(RecSelParent, GlobalRdrElt)])]+    getUpdFieldsParents+      = fmap (zip rbnds) $ mapM+          (lookupParents . unLoc . hsRecUpdFieldRdr . unLoc)+          rbnds++    -- Given a the lists of possible parents for each field,+    -- identify a single parent+    identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent+    identifyParent fam_inst_envs possible_parents+      = case foldr1 intersect possible_parents of+        -- No parents for all fields: record update is ill-typed+        []  -> failWithTc (noPossibleParents rbnds)++        -- Exactly one datatype with all the fields: use that+        [p] -> return p++        -- Multiple possible parents: try harder to disambiguate+        -- Can we get a parent TyCon from the pushed-in type?+        _:_ | Just p <- tyConOfET fam_inst_envs res_ty -> return (RecSelData p)++        -- Does the expression being updated have a type signature?+        -- If so, try to extract a parent TyCon from it+            | Just {} <- obviousSig (unLoc record_expr)+            , Just tc <- tyConOf fam_inst_envs record_rho+            -> return (RecSelData tc)++        -- Nothing else we can try...+        _ -> failWithTc badOverloadedUpdate++    -- Make a field unambiguous by choosing the given parent.+    -- Emits an error if the field cannot have that parent,+    -- e.g. if the user writes+    --     r { x = e } :: T+    -- where T does not have field x.+    pickParent :: RecSelParent+               -> (LHsRecUpdField Name, [(RecSelParent, GlobalRdrElt)])+               -> TcM (LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name))+    pickParent p (upd, xs)+      = case lookup p xs of+                      -- Phew! The parent is valid for this field.+                      -- Previously ambiguous fields must be marked as+                      -- used now that we know which one is meant, but+                      -- unambiguous ones shouldn't be recorded again+                      -- (giving duplicate deprecation warnings).+          Just gre -> do { unless (null (tail xs)) $ do+                             let L loc _ = hsRecFieldLbl (unLoc upd)+                             setSrcSpan loc $ addUsedGRE True gre+                         ; lookupSelector (upd, gre_name gre) }+                      -- The field doesn't belong to this parent, so report+                      -- an error but keep going through all the fields+          Nothing  -> do { addErrTc (fieldNotInType p+                                      (unLoc (hsRecUpdFieldRdr (unLoc upd))))+                         ; lookupSelector (upd, gre_name (snd (head xs))) }++    -- Given a (field update, selector name) pair, look up the+    -- selector to give a field update with an unambiguous Id+    lookupSelector :: (LHsRecUpdField Name, Name)+                   -> TcM (LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name))+    lookupSelector (L l upd, n)+      = do { i <- tcLookupId n+           ; let L loc af = hsRecFieldLbl upd+                 lbl      = rdrNameAmbiguousFieldOcc af+           ; return $ L l upd { hsRecFieldLbl+                                  = L loc (Unambiguous (L loc lbl) i) } }+++-- Extract the outermost TyCon of a type, if there is one; for+-- data families this is the representation tycon (because that's+-- where the fields live).+tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon+tyConOf fam_inst_envs ty0+  = case tcSplitTyConApp_maybe ty of+      Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys))+      Nothing        -> Nothing+  where+    (_, _, ty) = tcSplitSigmaTy ty0++-- Variant of tyConOf that works for ExpTypes+tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon+tyConOfET fam_inst_envs ty0 = tyConOf fam_inst_envs =<< checkingExpType_maybe ty0++-- For an ambiguous record field, find all the candidate record+-- selectors (as GlobalRdrElts) and their parents.+lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)]+lookupParents rdr+  = do { env <- getGlobalRdrEnv+       ; let gres = lookupGRE_RdrName rdr env+       ; mapM lookupParent gres }+  where+    lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt)+    lookupParent gre = do { id <- tcLookupId (gre_name gre)+                          ; if isRecordSelector id+                              then return (recordSelectorTyCon id, gre)+                              else failWithTc (notSelector (gre_name gre)) }++-- A type signature on the argument of an ambiguous record selector or+-- the record expression in an update must be "obvious", i.e. the+-- outermost constructor ignoring parentheses.+obviousSig :: HsExpr Name -> Maybe (LHsSigWcType Name)+obviousSig (ExprWithTySig _ ty) = Just ty+obviousSig (HsPar p)            = obviousSig (unLoc p)+obviousSig _                    = Nothing+++{-+Game plan for record bindings+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+1. Find the TyCon for the bindings, from the first field label.++2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.++For each binding field = value++3. Instantiate the field type (from the field label) using the type+   envt from step 2.++4  Type check the value using tcArg, passing the field type as+   the expected argument type.++This extends OK when the field types are universally quantified.+-}++tcRecordBinds+        :: ConLike+        -> [TcType]     -- Expected type for each field+        -> HsRecordBinds Name+        -> TcM (HsRecordBinds TcId)++tcRecordBinds con_like arg_tys (HsRecFields rbinds dd)+  = do  { mb_binds <- mapM do_bind rbinds+        ; return (HsRecFields (catMaybes mb_binds) dd) }+  where+    fields = map flLabel $ conLikeFieldLabels con_like+    flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys++    do_bind :: LHsRecField Name (LHsExpr Name)+            -> TcM (Maybe (LHsRecField TcId (LHsExpr TcId)))+    do_bind (L l fld@(HsRecField { hsRecFieldLbl = f+                                 , hsRecFieldArg = rhs }))++      = do { mb <- tcRecordField con_like flds_w_tys f rhs+           ; case mb of+               Nothing         -> return Nothing+               Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f'+                                                          , hsRecFieldArg = rhs' }))) }++tcRecordUpd+        :: ConLike+        -> [TcType]     -- Expected type for each field+        -> [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)]+        -> TcM [LHsRecUpdField TcId]++tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds+  where+    flds_w_tys = zipEqual "tcRecordUpd" (map flLabel $ conLikeFieldLabels con_like) arg_tys++    do_bind :: LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name) -> TcM (Maybe (LHsRecUpdField TcId))+    do_bind (L l fld@(HsRecField { hsRecFieldLbl = L loc af+                                 , hsRecFieldArg = rhs }))+      = do { let lbl = rdrNameAmbiguousFieldOcc af+                 sel_id = selectorAmbiguousFieldOcc af+                 f = L loc (FieldOcc (L loc lbl) (idName sel_id))+           ; mb <- tcRecordField con_like flds_w_tys f rhs+           ; case mb of+               Nothing         -> return Nothing+               Just (f', rhs') ->+                 return (Just+                         (L l (fld { hsRecFieldLbl+                                      = L loc (Unambiguous (L loc lbl)+                                               (selectorFieldOcc (unLoc f')))+                                   , hsRecFieldArg = rhs' }))) }++tcRecordField :: ConLike -> Assoc FieldLabelString Type -> LFieldOcc Name -> LHsExpr Name+              -> TcM (Maybe (LFieldOcc Id, LHsExpr Id))+tcRecordField con_like flds_w_tys (L loc (FieldOcc lbl sel_name)) rhs+  | Just field_ty <- assocMaybe flds_w_tys field_lbl+      = addErrCtxt (fieldCtxt field_lbl) $+        do { rhs' <- tcPolyExprNC rhs field_ty+           ; let field_id = mkUserLocal (nameOccName sel_name)+                                        (nameUnique sel_name)+                                        field_ty loc+                -- Yuk: the field_id has the *unique* of the selector Id+                --          (so we can find it easily)+                --      but is a LocalId with the appropriate type of the RHS+                --          (so the desugarer knows the type of local binder to make)+           ; return (Just (L loc (FieldOcc lbl field_id), rhs')) }+      | otherwise+      = do { addErrTc (badFieldCon con_like field_lbl)+           ; return Nothing }+  where+        field_lbl = occNameFS $ rdrNameOcc (unLoc lbl)+++checkMissingFields ::  ConLike -> HsRecordBinds Name -> TcM ()+checkMissingFields con_like rbinds+  | null field_labels   -- Not declared as a record;+                        -- But C{} is still valid if no strict fields+  = if any isBanged field_strs then+        -- Illegal if any arg is strict+        addErrTc (missingStrictFields con_like [])+    else+        return ()++  | otherwise = do              -- A record+    unless (null missing_s_fields)+           (addErrTc (missingStrictFields con_like missing_s_fields))++    warn <- woptM Opt_WarnMissingFields+    unless (not (warn && notNull missing_ns_fields))+           (warnTc (Reason Opt_WarnMissingFields) True+               (missingFields con_like missing_ns_fields))++  where+    missing_s_fields+        = [ flLabel fl | (fl, str) <- field_info,+                 isBanged str,+                 not (fl `elemField` field_names_used)+          ]+    missing_ns_fields+        = [ flLabel fl | (fl, str) <- field_info,+                 not (isBanged str),+                 not (fl `elemField` field_names_used)+          ]++    field_names_used = hsRecFields rbinds+    field_labels     = conLikeFieldLabels con_like++    field_info = zipEqual "missingFields"+                          field_labels+                          field_strs++    field_strs = conLikeImplBangs con_like++    fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds++{-+************************************************************************+*                                                                      *+\subsection{Errors and contexts}+*                                                                      *+************************************************************************++Boring and alphabetical:+-}++addExprErrCtxt :: LHsExpr Name -> TcM a -> TcM a+addExprErrCtxt expr = addErrCtxt (exprCtxt expr)++exprCtxt :: LHsExpr Name -> SDoc+exprCtxt expr+  = hang (text "In the expression:") 2 (ppr expr)++fieldCtxt :: FieldLabelString -> SDoc+fieldCtxt field_name+  = text "In the" <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")++addFunResCtxt :: Bool  -- There is at least one argument+              -> HsExpr Name -> TcType -> ExpRhoType+              -> TcM a -> TcM a+-- When we have a mis-match in the return type of a function+-- try to give a helpful message about too many/few arguments+--+-- Used for naked variables too; but with has_args = False+addFunResCtxt has_args fun fun_res_ty env_ty+  = addLandmarkErrCtxtM (\env -> (env, ) <$> mk_msg)+      -- NB: use a landmark error context, so that an empty context+      -- doesn't suppress some more useful context+  where+    mk_msg+      = do { mb_env_ty <- readExpType_maybe env_ty+                     -- by the time the message is rendered, the ExpType+                     -- will be filled in (except if we're debugging)+           ; fun_res' <- zonkTcType fun_res_ty+           ; env'     <- case mb_env_ty of+                           Just env_ty -> zonkTcType env_ty+                           Nothing     ->+                             do { dumping <- doptM Opt_D_dump_tc_trace+                                ; MASSERT( dumping )+                                ; newFlexiTyVarTy liftedTypeKind }+           ; let (_, _, fun_tau) = tcSplitSigmaTy fun_res'+                 (_, _, env_tau) = tcSplitSigmaTy env'+                 (args_fun, res_fun) = tcSplitFunTys fun_tau+                 (args_env, res_env) = tcSplitFunTys env_tau+                 n_fun = length args_fun+                 n_env = length args_env+                 info  | n_fun == n_env = Outputable.empty+                       | n_fun > n_env+                       , not_fun res_env+                       = text "Probable cause:" <+> quotes (ppr fun)+                         <+> text "is applied to too few arguments"++                       | has_args+                       , not_fun res_fun+                       = text "Possible cause:" <+> quotes (ppr fun)+                         <+> text "is applied to too many arguments"++                       | otherwise+                       = Outputable.empty  -- Never suggest that a naked variable is                                         -- applied to too many args!+           ; return info }+      where+        not_fun ty   -- ty is definitely not an arrow type,+                     -- and cannot conceivably become one+          = case tcSplitTyConApp_maybe ty of+              Just (tc, _) -> isAlgTyCon tc+              Nothing      -> False++badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc+badFieldTypes prs+  = hang (text "Record update for insufficiently polymorphic field"+                         <> plural prs <> colon)+       2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])++badFieldsUpd+  :: [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)] -- Field names that don't belong to a single datacon+  -> [ConLike] -- Data cons of the type which the first field name belongs to+  -> SDoc+badFieldsUpd rbinds data_cons+  = hang (text "No constructor has all these fields:")+       2 (pprQuotedList conflictingFields)+          -- See Note [Finding the conflicting fields]+  where+    -- A (preferably small) set of fields such that no constructor contains+    -- all of them.  See Note [Finding the conflicting fields]+    conflictingFields = case nonMembers of+        -- nonMember belongs to a different type.+        (nonMember, _) : _ -> [aMember, nonMember]+        [] -> let+            -- All of rbinds belong to one type. In this case, repeatedly add+            -- a field to the set until no constructor contains the set.++            -- Each field, together with a list indicating which constructors+            -- have all the fields so far.+            growingSets :: [(FieldLabelString, [Bool])]+            growingSets = scanl1 combine membership+            combine (_, setMem) (field, fldMem)+              = (field, zipWith (&&) setMem fldMem)+            in+            -- Fields that don't change the membership status of the set+            -- are redundant and can be dropped.+            map (fst . head) $ groupBy ((==) `on` snd) growingSets++    aMember = ASSERT( not (null members) ) fst (head members)+    (members, nonMembers) = partition (or . snd) membership++    -- For each field, which constructors contain the field?+    membership :: [(FieldLabelString, [Bool])]+    membership = sortMembership $+        map (\fld -> (fld, map (Set.member fld) fieldLabelSets)) $+          map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) rbinds++    fieldLabelSets :: [Set.Set FieldLabelString]+    fieldLabelSets = map (Set.fromList . map flLabel . conLikeFieldLabels) data_cons++    -- Sort in order of increasing number of True, so that a smaller+    -- conflicting set can be found.+    sortMembership =+      map snd .+      sortBy (compare `on` fst) .+      map (\ item@(_, membershipRow) -> (countTrue membershipRow, item))++    countTrue = count id++{-+Note [Finding the conflicting fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+  data A = A {a0, a1 :: Int}+         | B {b0, b1 :: Int}+and we see a record update+  x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 }+Then we'd like to find the smallest subset of fields that no+constructor has all of.  Here, say, {a0,b0}, or {a0,b1}, etc.+We don't really want to report that no constructor has all of+{a0,a1,b0,b1}, because when there are hundreds of fields it's+hard to see what was really wrong.++We may need more than two fields, though; eg+  data T = A { x,y :: Int, v::Int }+          | B { y,z :: Int, v::Int }+          | C { z,x :: Int, v::Int }+with update+   r { x=e1, y=e2, z=e3 }, we++Finding the smallest subset is hard, so the code here makes+a decent stab, no more.  See Trac #7989.+-}++naughtyRecordSel :: RdrName -> SDoc+naughtyRecordSel sel_id+  = text "Cannot use record selector" <+> quotes (ppr sel_id) <+>+    text "as a function due to escaped type variables" $$+    text "Probable fix: use pattern-matching syntax instead"++notSelector :: Name -> SDoc+notSelector field+  = hsep [quotes (ppr field), text "is not a record selector"]++mixedSelectors :: [Id] -> [Id] -> SDoc+mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_)+  = ptext+      (sLit "Cannot use a mixture of pattern synonym and record selectors") $$+    text "Record selectors defined by"+      <+> quotes (ppr (tyConName rep_dc))+      <> text ":"+      <+> pprWithCommas ppr data_sels $$+    text "Pattern synonym selectors defined by"+      <+> quotes (ppr (patSynName rep_ps))+      <> text ":"+      <+> pprWithCommas ppr pat_syn_sels+  where+    RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id+    RecSelData rep_dc = recordSelectorTyCon dc_rep_id+mixedSelectors _ _ = panic "TcExpr: mixedSelectors emptylists"+++missingStrictFields :: ConLike -> [FieldLabelString] -> SDoc+missingStrictFields con fields+  = header <> rest+  where+    rest | null fields = Outputable.empty  -- Happens for non-record constructors+                                           -- with strict fields+         | otherwise   = colon <+> pprWithCommas ppr fields++    header = text "Constructor" <+> quotes (ppr con) <+>+             text "does not have the required strict field(s)"++missingFields :: ConLike -> [FieldLabelString] -> SDoc+missingFields con fields+  = text "Fields of" <+> quotes (ppr con) <+> ptext (sLit "not initialised:")+        <+> pprWithCommas ppr fields++-- callCtxt fun args = text "In the call" <+> parens (ppr (foldl mkHsApp fun args))++noPossibleParents :: [LHsRecUpdField Name] -> SDoc+noPossibleParents rbinds+  = hang (text "No type has all these fields:")+       2 (pprQuotedList fields)+  where+    fields = map (hsRecFieldLbl . unLoc) rbinds++badOverloadedUpdate :: SDoc+badOverloadedUpdate = text "Record update is ambiguous, and requires a type signature"++fieldNotInType :: RecSelParent -> RdrName -> SDoc+fieldNotInType p rdr+  = unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr++{-+************************************************************************+*                                                                      *+\subsection{Static Pointers}+*                                                                      *+************************************************************************+-}++-- | A data type to describe why a variable is not closed.+data NotClosedReason = NotLetBoundReason+                     | NotTypeClosed VarSet+                     | NotClosed Name NotClosedReason++-- | Checks if the given name is closed and emits an error if not.+--+-- See Note [Not-closed error messages].+checkClosedInStaticForm :: Name -> TcM ()+checkClosedInStaticForm name = do+    type_env <- getLclTypeEnv+    case checkClosed type_env name of+      Nothing -> return ()+      Just reason -> addErrTc $ explain name reason+  where+    -- See Note [Checking closedness].+    checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason+    checkClosed type_env n = checkLoop type_env (unitNameSet n) n++    checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason+    checkLoop type_env visited n = do+      -- The @visited@ set is an accumulating parameter that contains the set of+      -- visited nodes, so we avoid repeating cycles in the traversal.+      case lookupNameEnv type_env n of+        Just (ATcId { tct_id = tcid, tct_info = info }) -> case info of+          ClosedLet   -> Nothing+          NotLetBound -> Just NotLetBoundReason+          NonClosedLet fvs type_closed -> listToMaybe $+            -- Look for a non-closed variable in fvs+            [ NotClosed n' reason+            | n' <- nameSetElemsStable fvs+            , not (elemNameSet n' visited)+            , Just reason <- [checkLoop type_env (extendNameSet visited n') n']+            ] +++            if type_closed then+              []+            else+              -- We consider non-let-bound variables easier to figure out than+              -- non-closed types, so we report non-closed types to the user+              -- only if we cannot spot the former.+              [ NotTypeClosed $ tyCoVarsOfType (idType tcid) ]+        -- The binding is closed.+        _ -> Nothing++    -- Converts a reason into a human-readable sentence.+    --+    -- @explain name reason@ starts with+    --+    -- "<name> is used in a static form but it is not closed because it"+    --+    -- and then follows a list of causes. For each id in the path, the text+    --+    -- "uses <id> which"+    --+    -- is appended, yielding something like+    --+    -- "uses <id> which uses <id1> which uses <id2> which"+    --+    -- until the end of the path is reached, which is reported as either+    --+    -- "is not let-bound"+    --+    -- when the final node is not let-bound, or+    --+    -- "has a non-closed type because it contains the type variables:+    -- v1, v2, v3"+    --+    -- when the final node has a non-closed type.+    --+    explain :: Name -> NotClosedReason -> SDoc+    explain name reason =+      quotes (ppr name) <+> text "is used in a static form but it is not closed"+                        <+> text "because it"+                        $$+                        sep (causes reason)++    causes :: NotClosedReason -> [SDoc]+    causes NotLetBoundReason = [text "is not let-bound."]+    causes (NotTypeClosed vs) =+      [ text "has a non-closed type because it contains the"+      , text "type variables:" <+>+        pprVarSet vs (hsep . punctuate comma . map (quotes . ppr))+      ]+    causes (NotClosed n reason) =+      let msg = text "uses" <+> quotes (ppr n) <+> text "which"+       in case reason of+            NotClosed _ _ -> msg : causes reason+            _   -> let (xs0, xs1) = splitAt 1 $ causes reason+                    in fmap (msg <+>) xs0 ++ xs1++-- Note [Not-closed error messages]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- When variables in a static form are not closed, we go through the trouble+-- of explaining why they aren't.+--+-- Thus, the following program+--+-- > {-# LANGUAGE StaticPointers #-}+-- > module M where+-- >+-- > f x = static g+-- >   where+-- >     g = h+-- >     h = x+--+-- produces the error+--+--    'g' is used in a static form but it is not closed because it+--    uses 'h' which uses 'x' which is not let-bound.+--+-- And a program like+--+-- > {-# LANGUAGE StaticPointers #-}+-- > module M where+-- >+-- > import Data.Typeable+-- > import GHC.StaticPtr+-- >+-- > f :: Typeable a => a -> StaticPtr TypeRep+-- > f x = const (static (g undefined)) (h x)+-- >   where+-- >     g = h+-- >     h = typeOf+--+-- produces the error+--+--    'g' is used in a static form but it is not closed because it+--    uses 'h' which has a non-closed type because it contains the+--    type variables: 'a'+--++-- Note [Checking closedness]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- @checkClosed@ checks if a binding is closed and returns a reason if it is+-- not.+--+-- The bindings define a graph where the nodes are ids, and there is an edge+-- from @id1@ to @id2@ if the rhs of @id1@ contains @id2@ among its free+-- variables.+--+-- When @n@ is not closed, it has to exist in the graph some node reachable+-- from @n@ that it is not a let-bound variable or that it has a non-closed+-- type. Thus, the "reason" is a path from @n@ to this offending node.+--+-- When @n@ is not closed, we traverse the graph reachable from @n@ to build+-- the reason.+--
+ typecheck/TcExpr.hs-boot view
@@ -0,0 +1,40 @@+module TcExpr where+import HsSyn    ( HsExpr, LHsExpr, SyntaxExpr )+import Name     ( Name )+import TcType   ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType )+import TcRnTypes( TcM, TcId, CtOrigin )++tcPolyExpr ::+          LHsExpr Name+       -> TcSigmaType+       -> TcM (LHsExpr TcId)++tcMonoExpr, tcMonoExprNC ::+          LHsExpr Name+       -> ExpRhoType+       -> TcM (LHsExpr TcId)++tcInferSigma, tcInferSigmaNC ::+          LHsExpr Name+       -> TcM (LHsExpr TcId, TcSigmaType)++tcInferRho ::+          LHsExpr Name+       -> TcM (LHsExpr TcId, TcRhoType)++tcSyntaxOp :: CtOrigin+           -> SyntaxExpr Name+           -> [SyntaxOpType]           -- ^ shape of syntax operator arguments+           -> ExpType                  -- ^ overall result type+           -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments+           -> TcM (a, SyntaxExpr TcId)++tcSyntaxOpGen :: CtOrigin+              -> SyntaxExpr Name+              -> [SyntaxOpType]+              -> SyntaxOpType+              -> ([TcSigmaType] -> TcM a)+              -> TcM (a, SyntaxExpr TcId)+++tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr TcId)
+ typecheck/TcFlatten.hs view
@@ -0,0 +1,1647 @@+{-# LANGUAGE CPP, ViewPatterns #-}++module TcFlatten(+   FlattenMode(..),+   flatten, flattenManyNom,++   unflatten,+ ) where++#include "HsVersions.h"++import TcRnTypes+import TcType+import Type+import TcUnify( occCheckExpand )+import TcEvidence+import TyCon+import TyCoRep   -- performs delicate algorithm on types+import Coercion+import Var+import VarEnv+import Outputable+import TcSMonad as TcS+import BasicTypes( SwapFlag(..) )++import Util+import Bag+import Pair+import Control.Monad+import MonadUtils ( zipWithAndUnzipM )+import GHC.Exts ( inline )++import Control.Arrow ( first )++{-+Note [The flattening story]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* A CFunEqCan is either of form+     [G] <F xis> : F xis ~ fsk   -- fsk is a FlatSkol+     [W]       x : F xis ~ fmv   -- fmv is a unification variable,+                                 -- but untouchable,+                                 -- with MetaInfo = FlatMetaTv+  where+     x is the witness variable+     fsk/fmv is a flatten skolem+     xis are function-free+  CFunEqCans are always [Wanted], or [Given], never [Derived]++  fmv untouchable just means that in a CTyVarEq, say,+       fmv ~ Int+  we do NOT unify fmv.++* KEY INSIGHTS:++   - A given flatten-skolem, fsk, is known a-priori to be equal to+     F xis (the LHS), with <F xis> evidence++   - A unification flatten-skolem, fmv, stands for the as-yet-unknown+     type to which (F xis) will eventually reduce++* Inert set invariant: if F xis1 ~ fsk1, F xis2 ~ fsk2+                       then xis1 /= xis2+  i.e. at most one CFunEqCan with a particular LHS++* Each canonical [G], [W], or [WD] CFunEqCan x : F xis ~ fsk/fmv+  has its own distinct evidence variable x and flatten-skolem fsk/fmv.+  Why? We make a fresh fsk/fmv when the constraint is born;+  and we never rewrite the RHS of a CFunEqCan.++  In contrast a [D] CFunEqCan shares its fmv with its partner [W],+  but does not "own" it.  If we reduce a [D] F Int ~ fmv, where+  say type instance F Int = ty, then we don't discharge fmv := ty.+  Rather we simply generate [D] fmv ~ ty++* Function applications can occur in the RHS of a CTyEqCan.  No reason+  not allow this, and it reduces the amount of flattening that must occur.++* Flattening a type (F xis):+    - If we are flattening in a Wanted/Derived constraint+      then create new [W] x : F xis ~ fmv+      else create new [G] x : F xis ~ fsk+      with fresh evidence variable x and flatten-skolem fsk/fmv++    - Add it to the work list++    - Replace (F xis) with fsk/fmv in the type you are flattening++    - You can also add the CFunEqCan to the "flat cache", which+      simply keeps track of all the function applications you+      have flattened.++    - If (F xis) is in the cache already, just+      use its fsk/fmv and evidence x, and emit nothing.++    - No need to substitute in the flat-cache. It's not the end+      of the world if we start with, say (F alpha ~ fmv1) and+      (F Int ~ fmv2) and then find alpha := Int.  Athat will+      simply give rise to fmv1 := fmv2 via [Interacting rule] below++* Canonicalising a CFunEqCan [G/W] x : F xis ~ fsk/fmv+    - Flatten xis (to substitute any tyvars; there are already no functions)+                  cos :: xis ~ flat_xis+    - New wanted  x2 :: F flat_xis ~ fsk/fmv+    - Add new wanted to flat cache+    - Discharge x = F cos ; x2++* Unification flatten-skolems, fmv, ONLY get unified when either+    a) The CFunEqCan takes a step, using an axiom+    b) During un-flattening+  They are never unified in any other form of equality.+  For example [W] ffmv ~ Int  is stuck; it does not unify with fmv.++* We *never* substitute in the RHS (i.e. the fsk/fmv) of a CFunEqCan.+  That would destroy the invariant about the shape of a CFunEqCan,+  and it would risk wanted/wanted interactions. The only way we+  learn information about fsk is when the CFunEqCan takes a step.++  However we *do* substitute in the LHS of a CFunEqCan (else it+  would never get to fire!)++* [Interacting rule]+    (inert)     [W] x1 : F tys ~ fmv1+    (work item) [W] x2 : F tys ~ fmv2+  Just solve one from the other:+    x2 := x1+    fmv2 := fmv1+  This just unites the two fsks into one.+  Always solve given from wanted if poss.++* For top-level reductions, see Note [Top-level reductions for type functions]+  in TcInteract+++Why given-fsks, alone, doesn't work+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Could we get away with only flatten meta-tyvars, with no flatten-skolems? No.++  [W] w : alpha ~ [F alpha Int]++---> flatten+  w = ...w'...+  [W] w' : alpha ~ [fsk]+  [G] <F alpha Int> : F alpha Int ~ fsk++--> unify (no occurs check)+  alpha := [fsk]++But since fsk = F alpha Int, this is really an occurs check error.  If+that is all we know about alpha, we will succeed in constraint+solving, producing a program with an infinite type.++Even if we did finally get (g : fsk ~ Bool) by solving (F alpha Int ~ fsk)+using axiom, zonking would not see it, so (x::alpha) sitting in the+tree will get zonked to an infinite type.  (Zonking always only does+refl stuff.)++Why flatten-meta-vars, alone doesn't work+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Look at Simple13, with unification-fmvs only++  [G] g : a ~ [F a]++---> Flatten given+  g' = g;[x]+  [G] g'  : a ~ [fmv]+  [W] x : F a ~ fmv++--> subst a in x+  g' = g;[x]+  x = F g' ; x2+  [W] x2 : F [fmv] ~ fmv++And now we have an evidence cycle between g' and x!++If we used a given instead (ie current story)++  [G] g : a ~ [F a]++---> Flatten given+  g' = g;[x]+  [G] g'  : a ~ [fsk]+  [G] <F a> : F a ~ fsk++---> Substitute for a+  [G] g'  : a ~ [fsk]+  [G] F (sym g'); <F a> : F [fsk] ~ fsk+++Why is it right to treat fmv's differently to ordinary unification vars?+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  f :: forall a. a -> a -> Bool+  g :: F Int -> F Int -> Bool++Consider+  f (x:Int) (y:Bool)+This gives alpha~Int, alpha~Bool.  There is an inconsistency,+but really only one error.  SherLoc may tell you which location+is most likely, based on other occurrences of alpha.++Consider+  g (x:Int) (y:Bool)+Here we get (F Int ~ Int, F Int ~ Bool), which flattens to+  (fmv ~ Int, fmv ~ Bool)+But there are really TWO separate errors.++  ** We must not complain about Int~Bool. **++Moreover these two errors could arise in entirely unrelated parts of+the code.  (In the alpha case, there must be *some* connection (eg+v:alpha in common envt).)++Note [Unflattening can force the solver to iterate]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Look at Trac #10340:+   type family Any :: *   -- No instances+   get :: MonadState s m => m s+   instance MonadState s (State s) where ...++   foo :: State Any Any+   foo = get++For 'foo' we instantiate 'get' at types mm ss+   [WD] MonadState ss mm, [WD] mm ss ~ State Any Any+Flatten, and decompose+   [WD] MonadState ss mm, [WD] Any ~ fmv+   [WD] mm ~ State fmv, [WD] fmv ~ ss+Unify mm := State fmv:+   [WD] MonadState ss (State fmv)+   [WD] Any ~ fmv, [WD] fmv ~ ss+Now we are stuck; the instance does not match!!  So unflatten:+   fmv := Any+   ss := Any    (*)+   [WD] MonadState Any (State Any)++The unification (*) represents progress, so we must do a second+round of solving; this time it succeeds. This is done by the 'go'+loop in solveSimpleWanteds.++This story does not feel right but it's the best I can do; and the+iteration only happens in pretty obscure circumstances.+++************************************************************************+*                                                                      *+*                  Examples+     Here is a long series of examples I had to work through+*                                                                      *+************************************************************************++Simple20+~~~~~~~~+axiom F [a] = [F a]++ [G] F [a] ~ a+-->+ [G] fsk ~ a+ [G] [F a] ~ fsk  (nc)+-->+ [G] F a ~ fsk2+ [G] fsk ~ [fsk2]+ [G] fsk ~ a+-->+ [G] F a ~ fsk2+ [G] a ~ [fsk2]+ [G] fsk ~ a++----------------------------------------+indexed-types/should_compile/T44984++  [W] H (F Bool) ~ H alpha+  [W] alpha ~ F Bool+-->+  F Bool  ~ fmv0+  H fmv0  ~ fmv1+  H alpha ~ fmv2++  fmv1 ~ fmv2+  fmv0 ~ alpha++flatten+~~~~~~~+  fmv0  := F Bool+  fmv1  := H (F Bool)+  fmv2  := H alpha+  alpha := F Bool+plus+  fmv1 ~ fmv2++But these two are equal under the above assumptions.+Solve by Refl.+++--- under plan B, namely solve fmv1:=fmv2 eagerly ---+  [W] H (F Bool) ~ H alpha+  [W] alpha ~ F Bool+-->+  F Bool  ~ fmv0+  H fmv0  ~ fmv1+  H alpha ~ fmv2++  fmv1 ~ fmv2+  fmv0 ~ alpha+-->+  F Bool  ~ fmv0+  H fmv0  ~ fmv1+  H alpha ~ fmv2    fmv2 := fmv1++  fmv0 ~ alpha++flatten+  fmv0 := F Bool+  fmv1 := H fmv0 = H (F Bool)+  retain   H alpha ~ fmv2+    because fmv2 has been filled+  alpha := F Bool+++----------------------------+indexed-types/should_failt/T4179++after solving+  [W] fmv_1 ~ fmv_2+  [W] A3 (FCon x)           ~ fmv_1    (CFunEqCan)+  [W] A3 (x (aoa -> fmv_2)) ~ fmv_2    (CFunEqCan)++----------------------------------------+indexed-types/should_fail/T7729a++a)  [W]   BasePrimMonad (Rand m) ~ m1+b)  [W]   tt m1 ~ BasePrimMonad (Rand m)++--->  process (b) first+    BasePrimMonad (Ramd m) ~ fmv_atH+    fmv_atH ~ tt m1++--->  now process (a)+    m1 ~ s_atH ~ tt m1    -- An obscure occurs check+++----------------------------------------+typecheck/TcTypeNatSimple++Original constraint+  [W] x + y ~ x + alpha  (non-canonical)+==>+  [W] x + y     ~ fmv1   (CFunEqCan)+  [W] x + alpha ~ fmv2   (CFuneqCan)+  [W] fmv1 ~ fmv2        (CTyEqCan)++(sigh)++----------------------------------------+indexed-types/should_fail/GADTwrong1++  [G] Const a ~ ()+==> flatten+  [G] fsk ~ ()+  work item: Const a ~ fsk+==> fire top rule+  [G] fsk ~ ()+  work item fsk ~ ()++Surely the work item should rewrite to () ~ ()?  Well, maybe not;+it'a very special case.  More generally, our givens look like+F a ~ Int, where (F a) is not reducible.+++----------------------------------------+indexed_types/should_fail/T8227:++Why using a different can-rewrite rule in CFunEqCan heads+does not work.++Assuming NOT rewriting wanteds with wanteds++   Inert: [W] fsk_aBh ~ fmv_aBk -> fmv_aBk+          [W] fmv_aBk ~ fsk_aBh++          [G] Scalar fsk_aBg ~ fsk_aBh+          [G] V a ~ f_aBg++   Worklist includes  [W] Scalar fmv_aBi ~ fmv_aBk+   fmv_aBi, fmv_aBk are flatten unification variables++   Work item: [W] V fsk_aBh ~ fmv_aBi++Note that the inert wanteds are cyclic, because we do not rewrite+wanteds with wanteds.+++Then we go into a loop when normalise the work-item, because we+use rewriteOrSame on the argument of V.++Conclusion: Don't make canRewrite context specific; instead use+[W] a ~ ty to rewrite a wanted iff 'a' is a unification variable.+++----------------------------------------++Here is a somewhat similar case:++   type family G a :: *++   blah :: (G a ~ Bool, Eq (G a)) => a -> a+   blah = error "urk"++   foo x = blah x++For foo we get+   [W] Eq (G a), G a ~ Bool+Flattening+   [W] G a ~ fmv, Eq fmv, fmv ~ Bool+We can't simplify away the Eq Bool unless we substitute for fmv.+Maybe that doesn't matter: we would still be left with unsolved+G a ~ Bool.++--------------------------+Trac #9318 has a very simple program leading to++  [W] F Int ~ Int+  [W] F Int ~ Bool++We don't want to get "Error Int~Bool".  But if fmv's can rewrite+wanteds, we will++  [W] fmv ~ Int+  [W] fmv ~ Bool+--->+  [W] Int ~ Bool+++************************************************************************+*                                                                      *+*                FlattenEnv & FlatM+*             The flattening environment & monad+*                                                                      *+************************************************************************++-}++type FlatWorkListRef = TcRef [Ct]  -- See Note [The flattening work list]++data FlattenEnv+  = FE { fe_mode    :: FlattenMode+       , fe_loc     :: CtLoc              -- See Note [Flattener CtLoc]+       , fe_flavour :: CtFlavour+       , fe_eq_rel  :: EqRel              -- See Note [Flattener EqRels]+       , fe_work    :: FlatWorkListRef }  -- See Note [The flattening work list]++data FlattenMode  -- Postcondition for all three: inert wrt the type substitution+  = FM_FlattenAll          -- Postcondition: function-free+  | FM_SubstOnly           -- See Note [Flattening under a forall]++--  | FM_Avoid TcTyVar Bool  -- See Note [Lazy flattening]+--                           -- Postcondition:+--                           --  * tyvar is only mentioned in result under a rigid path+--                           --    e.g.   [a] is ok, but F a won't happen+--                           --  * If flat_top is True, top level is not a function application+--                           --   (but under type constructors is ok e.g. [F a])++instance Outputable FlattenMode where+  ppr FM_FlattenAll = text "FM_FlattenAll"+  ppr FM_SubstOnly  = text "FM_SubstOnly"++eqFlattenMode :: FlattenMode -> FlattenMode -> Bool+eqFlattenMode FM_FlattenAll FM_FlattenAll = True+eqFlattenMode FM_SubstOnly  FM_SubstOnly  = True+--  FM_Avoid tv1 b1 `eq` FM_Avoid tv2 b2 = tv1 == tv2 && b1 == b2+eqFlattenMode _  _ = False++mkFlattenEnv :: FlattenMode -> CtEvidence -> FlatWorkListRef -> FlattenEnv+mkFlattenEnv fm ctev ref = FE { fe_mode    = fm+                              , fe_loc     = ctEvLoc ctev+                              , fe_flavour = ctEvFlavour ctev+                              , fe_eq_rel  = ctEvEqRel ctev+                              , fe_work    = ref }++-- | The 'FlatM' monad is a wrapper around 'TcS' with the following+-- extra capabilities: (1) it offers access to a 'FlattenEnv';+-- and (2) it maintains the flattening worklist.+-- See Note [The flattening work list].+newtype FlatM a+  = FlatM { runFlatM :: FlattenEnv -> TcS a }++instance Monad FlatM where+  m >>= k  = FlatM $ \env ->+             do { a  <- runFlatM m env+                ; runFlatM (k a) env }++instance Functor FlatM where+  fmap = liftM++instance Applicative FlatM where+  pure x = FlatM $ const (pure x)+  (<*>) = ap++liftTcS :: TcS a -> FlatM a+liftTcS thing_inside+  = FlatM $ const thing_inside++emitFlatWork :: Ct -> FlatM ()+-- See Note [The flattening work list]+emitFlatWork ct = FlatM $ \env -> updTcRef (fe_work env) (ct :)++runFlatten :: FlattenMode -> CtEvidence -> FlatM a -> TcS a+-- Run thing_inside (which does flattening), and put all+-- the work it generates onto the main work list+-- See Note [The flattening work list]+-- NB: The returned evidence is always the same as the original, but with+-- perhaps a new CtLoc+runFlatten mode ev thing_inside+  = do { flat_ref <- newTcRef []+       ; let fmode = mkFlattenEnv mode ev flat_ref+       ; res <- runFlatM thing_inside fmode+       ; new_flats <- readTcRef flat_ref+       ; updWorkListTcS (add_flats new_flats)+       ; return res }+  where+    add_flats new_flats wl+      = wl { wl_funeqs = add_funeqs new_flats (wl_funeqs wl) }++    add_funeqs []     wl = wl+    add_funeqs (f:fs) wl = add_funeqs fs (f:wl)+      -- add_funeqs fs ws = reverse fs ++ ws+      -- e.g. add_funeqs [f1,f2,f3] [w1,w2,w3,w4]+      --        = [f3,f2,f1,w1,w2,w3,w4]++traceFlat :: String -> SDoc -> FlatM ()+traceFlat herald doc = liftTcS $ traceTcS herald doc++getFlatEnvField :: (FlattenEnv -> a) -> FlatM a+getFlatEnvField accessor+  = FlatM $ \env -> return (accessor env)++getEqRel :: FlatM EqRel+getEqRel = getFlatEnvField fe_eq_rel++getRole :: FlatM Role+getRole = eqRelRole <$> getEqRel++getFlavour :: FlatM CtFlavour+getFlavour = getFlatEnvField fe_flavour++getFlavourRole :: FlatM CtFlavourRole+getFlavourRole+  = do { flavour <- getFlavour+       ; eq_rel <- getEqRel+       ; return (flavour, eq_rel) }++getMode :: FlatM FlattenMode+getMode = getFlatEnvField fe_mode++getLoc :: FlatM CtLoc+getLoc = getFlatEnvField fe_loc++checkStackDepth :: Type -> FlatM ()+checkStackDepth ty+  = do { loc <- getLoc+       ; liftTcS $ checkReductionDepth loc ty }++-- | Change the 'EqRel' in a 'FlatM'.+setEqRel :: EqRel -> FlatM a -> FlatM a+setEqRel new_eq_rel thing_inside+  = FlatM $ \env ->+    if new_eq_rel == fe_eq_rel env+    then runFlatM thing_inside env+    else runFlatM thing_inside (env { fe_eq_rel = new_eq_rel })++-- | Change the 'FlattenMode' in a 'FlattenEnv'.+setMode :: FlattenMode -> FlatM a -> FlatM a+setMode new_mode thing_inside+  = FlatM $ \env ->+    if new_mode `eqFlattenMode` fe_mode env+    then runFlatM thing_inside env+    else runFlatM thing_inside (env { fe_mode = new_mode })++-- | Use when flattening kinds/kind coercions. See+-- Note [No derived kind equalities] in TcCanonical+flattenKinds :: FlatM a -> FlatM a+flattenKinds thing_inside+  = FlatM $ \env ->+    let kind_flav = case fe_flavour env of+                      Given -> Given+                      _     -> Wanted WDeriv+    in+    runFlatM thing_inside (env { fe_eq_rel = NomEq, fe_flavour = kind_flav })++bumpDepth :: FlatM a -> FlatM a+bumpDepth (FlatM thing_inside)+  = FlatM $ \env -> do { let env' = env { fe_loc = bumpCtLocDepth (fe_loc env) }+                       ; thing_inside env' }++{-+Note [The flattening work list]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The "flattening work list", held in the fe_work field of FlattenEnv,+is a list of CFunEqCans generated during flattening.  The key idea+is this.  Consider flattening (Eq (F (G Int) (H Bool)):+  * The flattener recursively calls itself on sub-terms before building+    the main term, so it will encounter the terms in order+              G Int+              H Bool+              F (G Int) (H Bool)+    flattening to sub-goals+              w1: G Int ~ fuv0+              w2: H Bool ~ fuv1+              w3: F fuv0 fuv1 ~ fuv2++  * Processing w3 first is BAD, because we can't reduce i t,so it'll+    get put into the inert set, and later kicked out when w1, w2 are+    solved.  In Trac #9872 this led to inert sets containing hundreds+    of suspended calls.++  * So we want to process w1, w2 first.++  * So you might think that we should just use a FIFO deque for the work-list,+    so that putting adding goals in order w1,w2,w3 would mean we processed+    w1 first.++  * BUT suppose we have 'type instance G Int = H Char'.  Then processing+    w1 leads to a new goal+                w4: H Char ~ fuv0+    We do NOT want to put that on the far end of a deque!  Instead we want+    to put it at the *front* of the work-list so that we continue to work+    on it.++So the work-list structure is this:++  * The wl_funeqs (in TcS) is a LIFO stack; we push new goals (such as w4) on+    top (extendWorkListFunEq), and take new work from the top+    (selectWorkItem).++  * When flattening, emitFlatWork pushes new flattening goals (like+    w1,w2,w3) onto the flattening work list, fe_work, another+    push-down stack.++  * When we finish flattening, we *reverse* the fe_work stack+    onto the wl_funeqs stack (which brings w1 to the top).++The function runFlatten initialises the fe_work stack, and reverses+it onto wl_fun_eqs at the end.++Note [Flattener EqRels]+~~~~~~~~~~~~~~~~~~~~~~~+When flattening, we need to know which equality relation -- nominal+or representation -- we should be respecting. The only difference is+that we rewrite variables by representational equalities when fe_eq_rel+is ReprEq, and that we unwrap newtypes when flattening w.r.t.+representational equality.++Note [Flattener CtLoc]+~~~~~~~~~~~~~~~~~~~~~~+The flattener does eager type-family reduction.+Type families might loop, and we+don't want GHC to do so. A natural solution is to have a bounded depth+to these processes. A central difficulty is that such a solution isn't+quite compositional. For example, say it takes F Int 10 steps to get to Bool.+How many steps does it take to get from F Int -> F Int to Bool -> Bool?+10? 20? What about getting from Const Char (F Int) to Char? 11? 1? Hard to+know and hard to track. So, we punt, essentially. We store a CtLoc in+the FlattenEnv and just update the environment when recurring. In the+TyConApp case, where there may be multiple type families to flatten,+we just copy the current CtLoc into each branch. If any branch hits the+stack limit, then the whole thing fails.++A consequence of this is that setting the stack limits appropriately+will be essentially impossible. So, the official recommendation if a+stack limit is hit is to disable the check entirely. Otherwise, there+will be baffling, unpredictable errors.++Note [Lazy flattening]+~~~~~~~~~~~~~~~~~~~~~~+The idea of FM_Avoid mode is to flatten less aggressively.  If we have+       a ~ [F Int]+there seems to be no great merit in lifting out (F Int).  But if it was+       a ~ [G a Int]+then we *do* want to lift it out, in case (G a Int) reduces to Bool, say,+which gets rid of the occurs-check problem.  (For the flat_top Bool, see+comments above and at call sites.)++HOWEVER, the lazy flattening actually seems to make type inference go+*slower*, not faster.  perf/compiler/T3064 is a case in point; it gets+*dramatically* worse with FM_Avoid.  I think it may be because+floating the types out means we normalise them, and that often makes+them smaller and perhaps allows more re-use of previously solved+goals.  But to be honest I'm not absolutely certain, so I am leaving+FM_Avoid in the code base.  What I'm removing is the unique place+where it is *used*, namely in TcCanonical.canEqTyVar.++See also Note [Conservative unification check] in TcUnify, which gives+other examples where lazy flattening caused problems.++Bottom line: FM_Avoid is unused for now (Nov 14).+Note: T5321Fun got faster when I disabled FM_Avoid+      T5837 did too, but it's pathalogical anyway++Note [Phantoms in the flattener]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++data Proxy p = Proxy++and we're flattening (Proxy ty) w.r.t. ReprEq. Then, we know that `ty`+is really irrelevant -- it will be ignored when solving for representational+equality later on. So, we omit flattening `ty` entirely. This may+violate the expectation of "xi"s for a bit, but the canonicaliser will+soon throw out the phantoms when decomposing a TyConApp. (Or, the+canonicaliser will emit an insoluble, in which case the unflattened version+yields a better error message anyway.)++-}++{- *********************************************************************+*                                                                      *+*      Externally callable flattening functions                        *+*                                                                      *+*  They are all wrapped in runFlatten, so their                        *+*  flattening work gets put into the work list                         *+*                                                                      *+********************************************************************* -}++flatten :: FlattenMode -> CtEvidence -> TcType+        -> TcS (Xi, TcCoercion)+flatten mode ev ty+  = do { traceTcS "flatten {" (ppr mode <+> ppr ty)+       ; (ty', co) <- runFlatten mode ev (flatten_one ty)+       ; traceTcS "flatten }" (ppr ty')+       ; return (ty', co) }++flattenManyNom :: CtEvidence -> [TcType] -> TcS ([Xi], [TcCoercion])+-- Externally-callable, hence runFlatten+-- Flatten a bunch of types all at once; in fact they are+-- always the arguments of a saturated type-family, so+--      ctEvFlavour ev = Nominal+-- and we want to flatten all at nominal role+flattenManyNom ev tys+  = do { traceTcS "flatten_many {" (vcat (map ppr tys))+       ; (tys', cos) <- runFlatten FM_FlattenAll ev (flatten_many_nom tys)+       ; traceTcS "flatten }" (vcat (map ppr tys'))+       ; return (tys', cos) }+++{- *********************************************************************+*                                                                      *+*           The main flattening functions+*                                                                      *+********************************************************************* -}++{- Note [Flattening]+~~~~~~~~~~~~~~~~~~~~+  flatten ty  ==>   (xi, co)+    where+      xi has no type functions, unless they appear under ForAlls+         has no skolems that are mapped in the inert set+         has no filled-in metavariables+      co :: xi ~ ty++Note that it is flatten's job to flatten *every type function it sees*.+flatten is only called on *arguments* to type functions, by canEqGiven.++Flattening also:+  * zonks, removing any metavariables, and+  * applies the substitution embodied in the inert set++Because flattening zonks and the returned coercion ("co" above) is also+zonked, it's possible that (co :: xi ~ ty) isn't quite true. So, instead,+we can rely on these facts:+  (F1) typeKind(xi) succeeds and returns a fully zonked kind+  (F2) co :: xi ~ zonk(ty)+Note that the left-hand type of co is *always* precisely xi. The right-hand+type may or may not be ty, however: if ty has unzonked filled-in metavariables,+then the right-hand type of co will be the zonked version of ty.+It is for this reason that we+occasionally have to explicitly zonk, when (co :: xi ~ ty) is important+even before we zonk the whole program. For example, see the FTRNotFollowed+case in flattenTyVar.++Why have these invariants on flattening? Really, they're both to ensure+invariant (F1), which is a Good Thing because we sometimes use typeKind+during canonicalisation, and we want this kind to be zonked (e.g., see+TcCanonical.homogeniseRhsKind). Invariant (F2) is needed solely to support+(F1). It is relied on in one place:++ - The FTRNotFollowed case in flattenTyVar. Here, we have a tyvar+ that cannot be reduced any further (that is, no equality over the tyvar+ is in the inert set such that the inert equality can rewrite the constraint+ at hand, and it is not a filled-in metavariable).+ But its kind might still not be flat,+ if it mentions a type family or a variable that can be rewritten. Flattened+ types have flattened kinds (see below), so we must flatten the kind. Here is+ an example:++   let kappa be a filled-in metavariable such that kappa := k.+   [G] co :: k ~ Type++   We are flattening+     a :: kappa+   where a is a skolem.++ We end up in the FTRNotFollowed case, but we need to flatten the kind kappa.+ Flattening kappa yields (Type, kind_co), where kind_co :: Type ~ k. Note that the+ right-hand type of kind_co is *not* kappa, because (F1) tells us it's zonk(kappa),+ which is k. Now, we return (a |> sym kind_co). If we are to uphold (F1), then+ the right-hand type of (sym kind_co) had better be fully zonked. In other words,+ the left-hand type of kind_co needs to be zonked... which is precisely what (F2)+ guarantees.++In order to support (F2), we require that ctEvCoercion, when called on a+zonked CtEvidence, always returns a zonked coercion. See Note [Given in+ctEvCoercion]. This requirement comes into play in flatten_tyvar2. (I suppose+we could move the logic from ctEvCoercion to flatten_tyvar2, but it's much+easier to do in ctEvCoercion.)++Flattening a type also means flattening its kind. In the case of a type+variable whose kind mentions a type family, this might mean that the result+of flattening has a cast in it.++Recall that in comments we use alpha[flat = ty] to represent a+flattening skolem variable alpha which has been generated to stand in+for ty.++----- Example of flattening a constraint: ------+  flatten (List (F (G Int)))  ==>  (xi, cc)+    where+      xi  = List alpha+      cc  = { G Int ~ beta[flat = G Int],+              F beta ~ alpha[flat = F beta] }+Here+  * alpha and beta are 'flattening skolem variables'.+  * All the constraints in cc are 'given', and all their coercion terms+    are the identity.++NB: Flattening Skolems only occur in canonical constraints, which+are never zonked, so we don't need to worry about zonking doing+accidental unflattening.++Note that we prefer to leave type synonyms unexpanded when possible,+so when the flattener encounters one, it first asks whether its+transitive expansion contains any type function applications.  If so,+it expands the synonym and proceeds; if not, it simply returns the+unexpanded synonym.++Note [flatten_many performance]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In programs with lots of type-level evaluation, flatten_many becomes+part of a tight loop. For example, see test perf/compiler/T9872a, which+calls flatten_many a whopping 7,106,808 times. It is thus important+that flatten_many be efficient.++Performance testing showed that the current implementation is indeed+efficient. It's critically important that zipWithAndUnzipM be+specialized to TcS, and it's also quite helpful to actually `inline`+it. On test T9872a, here are the allocation stats (Dec 16, 2014):++ * Unspecialized, uninlined:     8,472,613,440 bytes allocated in the heap+ * Specialized, uninlined:       6,639,253,488 bytes allocated in the heap+ * Specialized, inlined:         6,281,539,792 bytes allocated in the heap++To improve performance even further, flatten_many_nom is split off+from flatten_many, as nominal equality is the common case. This would+be natural to write using mapAndUnzipM, but even inlined, that function+is not as performant as a hand-written loop.++ * mapAndUnzipM, inlined:        7,463,047,432 bytes allocated in the heap+ * hand-written recursion:       5,848,602,848 bytes allocated in the heap++If you make any change here, pay close attention to the T9872{a,b,c} tests+and T5321Fun.++If we need to make this yet more performant, a possible way forward is to+duplicate the flattener code for the nominal case, and make that case+faster. This doesn't seem quite worth it, yet.+-}++flatten_many :: [Role] -> [Type] -> FlatM ([Xi], [Coercion])+-- Coercions :: Xi ~ Type, at roles given+-- Returns True iff (no flattening happened)+-- NB: The EvVar inside the 'fe_ev :: CtEvidence' is unused,+--     we merely want (a) Given/Solved/Derived/Wanted info+--                    (b) the GivenLoc/WantedLoc for when we create new evidence+flatten_many roles tys+-- See Note [flatten_many performance]+  = inline zipWithAndUnzipM go roles tys+  where+    go Nominal          ty = setEqRel NomEq  $ flatten_one ty+    go Representational ty = setEqRel ReprEq $ flatten_one ty+    go Phantom          ty = -- See Note [Phantoms in the flattener]+                             do { ty <- liftTcS $ zonkTcType ty+                                ; return ( ty, mkReflCo Phantom ty ) }++-- | Like 'flatten_many', but assumes that every role is nominal.+flatten_many_nom :: [Type] -> FlatM ([Xi], [Coercion])+flatten_many_nom [] = return ([], [])+-- See Note [flatten_many performance]+flatten_many_nom (ty:tys)+  = do { (xi, co) <- flatten_one ty+       ; (xis, cos) <- flatten_many_nom tys+       ; return (xi:xis, co:cos) }+------------------+flatten_one :: TcType -> FlatM (Xi, Coercion)+-- Flatten a type to get rid of type function applications, returning+-- the new type-function-free type, and a collection of new equality+-- constraints.  See Note [Flattening] for more detail.+--+-- Postcondition: Coercion :: Xi ~ TcType+-- The role on the result coercion matches the EqRel in the FlattenEnv++flatten_one xi@(LitTy {})+  = do { role <- getRole+       ; return (xi, mkReflCo role xi) }++flatten_one (TyVarTy tv)+  = flattenTyVar tv++flatten_one (AppTy ty1 ty2)+  = do { (xi1,co1) <- flatten_one ty1+       ; eq_rel <- getEqRel+       ; case (eq_rel, nextRole xi1) of+           (NomEq,  _)                -> flatten_rhs xi1 co1 NomEq+           (ReprEq, Nominal)          -> flatten_rhs xi1 co1 NomEq+           (ReprEq, Representational) -> flatten_rhs xi1 co1 ReprEq+           (ReprEq, Phantom)          -> -- See Note [Phantoms in the flattener]+             do { ty2 <- liftTcS $ zonkTcType ty2+                ; return ( mkAppTy xi1 ty2+                         , mkAppCo co1 (mkNomReflCo ty2)) } }+  where+    flatten_rhs xi1 co1 eq_rel2+      = do { (xi2,co2) <- setEqRel eq_rel2 $ flatten_one ty2+           ; role1 <- getRole+           ; let role2 = eqRelRole eq_rel2+           ; traceFlat "flatten/appty"+                       (ppr ty1 $$ ppr ty2 $$ ppr xi1 $$+                        ppr xi2 $$ ppr role1 $$ ppr role2)++           ; return ( mkAppTy xi1 xi2+                    , mkTransAppCo role1 co1 xi1 ty1+                                   role2 co2 xi2 ty2+                                   role1 ) }  -- output should match fmode++flatten_one (TyConApp tc tys)+  -- Expand type synonyms that mention type families+  -- on the RHS; see Note [Flattening synonyms]+  | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys+  , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys'+  = do { mode <- getMode+       ; case mode of+           FM_FlattenAll | not (isFamFreeTyCon tc)+                         -> flatten_one expanded_ty+           _             -> flatten_ty_con_app tc tys }++  -- Otherwise, it's a type function application, and we have to+  -- flatten it away as well, and generate a new given equality constraint+  -- between the application and a newly generated flattening skolem variable.+  | isTypeFamilyTyCon tc+  = flatten_fam_app tc tys++  -- For * a normal data type application+  --     * data family application+  -- we just recursively flatten the arguments.+  | otherwise+-- FM_Avoid stuff commented out; see Note [Lazy flattening]+--  , let fmode' = case fmode of  -- Switch off the flat_top bit in FM_Avoid+--                   FE { fe_mode = FM_Avoid tv _ }+--                     -> fmode { fe_mode = FM_Avoid tv False }+--                   _ -> fmode+  = flatten_ty_con_app tc tys++flatten_one (FunTy ty1 ty2)+  = do { (xi1,co1) <- flatten_one ty1+       ; (xi2,co2) <- flatten_one ty2+       ; role <- getRole+       ; return (mkFunTy xi1 xi2, mkFunCo role co1 co2) }++flatten_one ty@(ForAllTy {})+-- TODO (RAE): This is inadequate, as it doesn't flatten the kind of+-- the bound tyvar. Doing so will require carrying around a substitution+-- and the usual substTyVarBndr-like silliness. Argh.++-- We allow for-alls when, but only when, no type function+-- applications inside the forall involve the bound type variables.+  = do { let (bndrs, rho) = splitForAllTyVarBndrs ty+             tvs          = binderVars bndrs+       ; (rho', co) <- setMode FM_SubstOnly $ flatten_one rho+                         -- Substitute only under a forall+                         -- See Note [Flattening under a forall]+       ; return (mkForAllTys bndrs rho', mkHomoForAllCos tvs co) }++flatten_one (CastTy ty g)+  = do { (xi, co) <- flatten_one ty+       ; (g', _) <- flatten_co g++       ; return (mkCastTy xi g', castCoercionKind co g' g) }++flatten_one (CoercionTy co) = first mkCoercionTy <$> flatten_co co++-- | "Flatten" a coercion. Really, just flatten the types that it coerces+-- between and then use transitivity. See Note [Flattening coercions]+flatten_co :: Coercion -> FlatM (Coercion, Coercion)+flatten_co co+  = do { co <- liftTcS $ zonkCo co  -- see Note [Zonking when flattening a coercion]+       ; let (Pair ty1 ty2, role) = coercionKindRole co+       ; (co1, co2) <- flattenKinds $+                       do { (_, co1) <- flatten_one ty1+                          ; (_, co2) <- flatten_one ty2+                          ; return (co1, co2) }+       ; let co' = downgradeRole role Nominal co1 `mkTransCo`+                   co `mkTransCo`+                   mkSymCo (downgradeRole role Nominal co2)+             -- kco :: (ty1' ~r ty2') ~N (ty1 ~r ty2)+             kco = mkTyConAppCo Nominal (equalityTyCon role)+                     [ mkKindCo co1, mkKindCo co2, co1, co2 ]+       ; traceFlat "flatten_co" (vcat [ ppr co, ppr co1, ppr co2, ppr co' ])+       ; env_role <- getRole+       ; return (co', mkProofIrrelCo env_role kco co' co) }++flatten_ty_con_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion)+flatten_ty_con_app tc tys+  = do { eq_rel <- getEqRel+       ; let role = eqRelRole eq_rel+       ; (xis, cos) <- case eq_rel of+                         NomEq  -> flatten_many_nom tys+                         ReprEq -> flatten_many (tyConRolesRepresentational tc) tys+       ; return (mkTyConApp tc xis, mkTyConAppCo role tc cos) }++{-+Note [Flattening coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Because a flattened type has a flattened kind, we also must "flatten"+coercions as we walk through a type. Otherwise, the "from" type of+the coercion might not match the (now flattened) kind of the type+that it's casting. flatten_co does the work, taking a coercion of+type (ty1 ~ ty2) and flattening it to have type (fty1 ~ fty2),+where flatten(ty1) = fty1 and flatten(ty2) = fty2.++In other words:++  If  r1 is a role+      co :: s ~r1 t+      flatten_co co = (fco, kco)+      r2 is the role in the FlatM++  then+      fco :: fs ~r1 ft+      fs, ft are flattened types+      kco :: fco ~r2 co++The second return value of flatten_co is always a ProofIrrelCo. As+such, it doesn't contain any information the caller doesn't have and+might not be necessary in whatever comes next.++Note that a flattened coercion might have unzonked metavariables or+type functions in it -- but its *kind* will not. Instead of just flattening+the kinds and using mkTransCo, we could actually flatten the coercion+structurally. But doing so seems harder than simply flattening the types.++Note [Zonking when flattening a coercion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The first step in flatten_co (see Note [Flattening coercions]) is to+zonk the input. This is necessary because we want to ensure the following+invariants (c.f. the invariants (F1) and (F2) in Note [Flattening])+  If+    (co', kco) <- flatten_co co+  Then+    (FC1) coercionKind(co') succeeds and produces a fully zonked pair of kinds+    (FC2) kco :: co' ~ zonk(co)+We must zonk to ensure (1). This is because fco is built by using mkTransCo+to build up on the input co. But if the only action that happens during+flattening ty1 and ty2 is to zonk metavariables, the coercions returned+(co1 and co2) will be reflexive. The mkTransCo calls will drop the reflexive+coercions and co' will be the same as co -- with unzonked kinds.++These invariants are necessary to uphold (F1) and (F2) in the CastTy and+CoercionTy cases.++We zonk right at the beginning to avoid duplicating work when flattening the+ty1 and ty2.++Note [Flattening synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Not expanding synonyms aggressively improves error messages, and+keeps types smaller. But we need to take care.++Suppose+   type T a = a -> a+and we want to flatten the type (T (F a)).  Then we can safely flatten+the (F a) to a skolem, and return (T fsk).  We don't need to expand the+synonym.  This works because TcTyConAppCo can deal with synonyms+(unlike TyConAppCo), see Note [TcCoercions] in TcEvidence.++But (Trac #8979) for+   type T a = (F a, a)    where F is a type function+we must expand the synonym in (say) T Int, to expose the type function+to the flattener.+++Note [Flattening under a forall]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Under a forall, we+  (a) MUST apply the inert substitution+  (b) MUST NOT flatten type family applications+Hence FMSubstOnly.++For (a) consider   c ~ a, a ~ T (forall b. (b, [c]))+If we don't apply the c~a substitution to the second constraint+we won't see the occurs-check error.++For (b) consider  (a ~ forall b. F a b), we don't want to flatten+to     (a ~ forall b.fsk, F a b ~ fsk)+because now the 'b' has escaped its scope.  We'd have to flatten to+       (a ~ forall b. fsk b, forall b. F a b ~ fsk b)+and we have not begun to think about how to make that work!++************************************************************************+*                                                                      *+             Flattening a type-family application+*                                                                      *+************************************************************************+-}++flatten_fam_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion)+  --   flatten_fam_app            can be over-saturated+  --   flatten_exact_fam_app       is exactly saturated+  --   flatten_exact_fam_app_fully lifts out the application to top level+  -- Postcondition: Coercion :: Xi ~ F tys+flatten_fam_app tc tys  -- Can be over-saturated+    = ASSERT2( tyConArity tc <= length tys+             , ppr tc $$ ppr (tyConArity tc) $$ ppr tys)+                 -- Type functions are saturated+                 -- The type function might be *over* saturated+                 -- in which case the remaining arguments should+                 -- be dealt with by AppTys+      do { let (tys1, tys_rest) = splitAt (tyConArity tc) tys+         ; (xi1, co1) <- flatten_exact_fam_app tc tys1+               -- co1 :: xi1 ~ F tys1++               -- all Nominal roles b/c the tycon is oversaturated+         ; (xis_rest, cos_rest) <- flatten_many (repeat Nominal) tys_rest+               -- cos_res :: xis_rest ~ tys_rest++         ; return ( mkAppTys xi1 xis_rest   -- NB mkAppTys: rhs_xi might not be a type variable+                                            --    cf Trac #5655+                  , mkAppCos co1 cos_rest+                            -- (rhs_xi :: F xis) ; (F cos :: F xis ~ F tys)+                  ) }++flatten_exact_fam_app, flatten_exact_fam_app_fully ::+  TyCon -> [TcType] -> FlatM (Xi, Coercion)++flatten_exact_fam_app tc tys+  = do { mode <- getMode+       ; role <- getRole+       ; case mode of+               -- These roles are always going to be Nominal for now,+               -- but not if #8177 is implemented+           FM_SubstOnly -> do { let roles = tyConRolesX role tc+                              ; (xis, cos) <- flatten_many roles tys+                              ; return ( mkTyConApp tc xis+                                       , mkTyConAppCo role tc cos ) }++           FM_FlattenAll -> flatten_exact_fam_app_fully tc tys }++--       FM_Avoid tv flat_top ->+--         do { (xis, cos) <- flatten_many fmode roles tys+--            ; if flat_top || tv `elemVarSet` tyCoVarsOfTypes xis+--              then flatten_exact_fam_app_fully fmode tc tys+--              else return ( mkTyConApp tc xis+--                          , mkTcTyConAppCo (feRole fmode) tc cos ) }++flatten_exact_fam_app_fully tc tys+  -- See Note [Reduce type family applications eagerly]+  = try_to_reduce tc tys False id $+    do { -- First, flatten the arguments+       ; (xis, cos) <- setEqRel NomEq    $+                       flatten_many_nom tys+       ; eq_rel   <- getEqRel+       ; cur_flav <- getFlavour+       ; let role   = eqRelRole eq_rel+             ret_co = mkTyConAppCo role tc cos+              -- ret_co :: F xis ~ F tys++        -- Now, look in the cache+       ; mb_ct <- liftTcS $ lookupFlatCache tc xis+       ; case mb_ct of+           Just (co, rhs_ty, flav)  -- co :: F xis ~ fsk+                -- flav is [G] or [WD]+                -- See Note [Type family equations] in TcSMonad+             | (NotSwapped, _) <- flav `funEqCanDischargeF` cur_flav+             ->  -- Usable hit in the flat-cache+                do { traceFlat "flatten/flat-cache hit" $ (ppr tc <+> ppr xis $$ ppr rhs_ty)+                   ; (fsk_xi, fsk_co) <- flatten_one rhs_ty+                          -- The fsk may already have been unified, so flatten it+                          -- fsk_co :: fsk_xi ~ fsk+                   ; return ( fsk_xi+                            , fsk_co `mkTransCo`+                              maybeSubCo eq_rel (mkSymCo co) `mkTransCo`+                              ret_co ) }+                                    -- :: fsk_xi ~ F xis++           -- Try to reduce the family application right now+           -- See Note [Reduce type family applications eagerly]+           _ -> try_to_reduce tc xis True (`mkTransCo` ret_co) $+                do { loc <- getLoc+                   ; (ev, co, fsk) <- liftTcS $ newFlattenSkolem cur_flav loc tc xis++                   -- The new constraint (F xis ~ fsk) is not necessarily inert+                   -- (e.g. the LHS may be a redex) so we must put it in the work list+                   ; let ct = CFunEqCan { cc_ev     = ev+                                        , cc_fun    = tc+                                        , cc_tyargs = xis+                                        , cc_fsk    = fsk }+                   ; emitFlatWork ct++                   ; traceFlat "flatten/flat-cache miss" $+                         (ppr tc <+> ppr xis $$ ppr fsk $$ ppr ev)++                   -- NB: fsk's kind is already flattend because+                   --     the xis are flattened+                   ; return (mkTyVarTy fsk, maybeSubCo eq_rel (mkSymCo co)+                                            `mkTransCo` ret_co ) }+        }++  where+    try_to_reduce :: TyCon   -- F, family tycon+                  -> [Type]  -- args, not necessarily flattened+                  -> Bool    -- add to the flat cache?+                  -> (   Coercion     -- :: xi ~ F args+                      -> Coercion )   -- what to return from outer function+                  -> FlatM (Xi, Coercion)  -- continuation upon failure+                  -> FlatM (Xi, Coercion)+    try_to_reduce tc tys cache update_co k+      = do { checkStackDepth (mkTyConApp tc tys)+           ; mb_match <- liftTcS $ matchFam tc tys+           ; case mb_match of+               Just (norm_co, norm_ty)+                 -> do { traceFlat "Eager T.F. reduction success" $+                         vcat [ ppr tc, ppr tys, ppr norm_ty+                              , ppr norm_co <+> dcolon+                                            <+> ppr (coercionKind norm_co)+                              , ppr cache]+                       ; (xi, final_co) <- bumpDepth $ flatten_one norm_ty+                       ; eq_rel <- getEqRel+                       ; let co = maybeSubCo eq_rel norm_co+                                  `mkTransCo` mkSymCo final_co+                       ; flavour <- getFlavour+                           -- NB: only extend cache with nominal equalities+                       ; when (cache && eq_rel == NomEq) $+                         liftTcS $+                         extendFlatCache tc tys ( co, xi, flavour )+                       ; return ( xi, update_co $ mkSymCo co ) }+               Nothing -> k }++{- Note [Reduce type family applications eagerly]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we come across a type-family application like (Append (Cons x Nil) t),+then, rather than flattening to a skolem etc, we may as well just reduce+it on the spot to (Cons x t).  This saves a lot of intermediate steps.+Examples that are helped are tests T9872, and T5321Fun.++Performance testing indicates that it's best to try this *twice*, once+before flattening arguments and once after flattening arguments.+Adding the extra reduction attempt before flattening arguments cut+the allocation amounts for the T9872{a,b,c} tests by half.++An example of where the early reduction appears helpful:++  type family Last x where+    Last '[x]     = x+    Last (h ': t) = Last t++  workitem: (x ~ Last '[1,2,3,4,5,6])++Flattening the argument never gets us anywhere, but trying to flatten+it at every step is quadratic in the length of the list. Reducing more+eagerly makes simplifying the right-hand type linear in its length.++Testing also indicated that the early reduction should *not* use the+flat-cache, but that the later reduction *should*. (Although the+effect was not large.)  Hence the Bool argument to try_to_reduce.  To+me (SLPJ) this seems odd; I get that eager reduction usually succeeds;+and if don't use the cache for eager reduction, we will miss most of+the opportunities for using it at all.  More exploration would be good+here.++At the end, once we've got a flat rhs, we extend the flatten-cache to record+the result. Doing so can save lots of work when the same redex shows up more+than once. Note that we record the link from the redex all the way to its+*final* value, not just the single step reduction. Interestingly, using the+flat-cache for the first reduction resulted in an increase in allocations+of about 3% for the four T9872x tests. However, using the flat-cache in+the later reduction is a similar gain. I (Richard E) don't currently (Dec '14)+have any knowledge as to *why* these facts are true.++************************************************************************+*                                                                      *+             Flattening a type variable+*                                                                      *+********************************************************************* -}++-- | The result of flattening a tyvar "one step".+data FlattenTvResult+  = FTRNotFollowed+      -- ^ The inert set doesn't make the tyvar equal to anything else++  | FTRFollowed TcType Coercion+      -- ^ The tyvar flattens to a not-necessarily flat other type.+      -- co :: new type ~r old type, where the role is determined by+      -- the FlattenEnv++flattenTyVar :: TyVar -> FlatM (Xi, Coercion)+flattenTyVar tv+  = do { mb_yes <- flatten_tyvar1 tv+       ; case mb_yes of+           FTRFollowed ty1 co1  -- Recur+             -> do { (ty2, co2) <- flatten_one ty1+                   -- ; traceFlat "flattenTyVar2" (ppr tv $$ ppr ty2)+                   ; return (ty2, co2 `mkTransCo` co1) }++           FTRNotFollowed   -- Done+             -> do { let orig_kind = tyVarKind tv+                   ; (_new_kind, kind_co) <- setMode FM_SubstOnly $+                                             flattenKinds $+                                             flatten_one orig_kind+                     ; let Pair _ zonked_kind = coercionKind kind_co+             -- NB: kind_co :: _new_kind ~ zonked_kind+             -- But zonked_kind is not necessarily the same as orig_kind+             -- because that may have filled-in metavars.+             -- Moreover the returned Xi type must be well-kinded+             -- (e.g. in canEqTyVarTyVar we use getCastedTyVar_maybe)+             -- If you remove it, then e.g. dependent/should_fail/T11407 panics+             -- See also Note [Flattening]+             -- An alternative would to use (zonkTcType orig_kind),+             -- but some simple measurements suggest that's a little slower+                    ; let tv'    = setTyVarKind tv zonked_kind+                          tv_ty' = mkTyVarTy tv'+                          ty'    = tv_ty' `mkCastTy` mkSymCo kind_co++                    ; role <- getRole+                    ; return (ty', mkReflCo role tv_ty'+                                   `mkCoherenceLeftCo` mkSymCo kind_co) } }++flatten_tyvar1 :: TcTyVar -> FlatM FlattenTvResult+-- "Flattening" a type variable means to apply the substitution to it+-- Specifically, look up the tyvar in+--   * the internal MetaTyVar box+--   * the inerts+-- See also the documentation for FlattenTvResult++flatten_tyvar1 tv+  | not (isTcTyVar tv)             -- Happens when flatten under a (forall a. ty)+  = return FTRNotFollowed+          -- So ty contains references to the non-TcTyVar a++  | otherwise+  = do { mb_ty <- liftTcS $ isFilledMetaTyVar_maybe tv+       ; role <- getRole+       ; case mb_ty of+           Just ty -> do { traceFlat "Following filled tyvar" (ppr tv <+> equals <+> ppr ty)+                         ; return (FTRFollowed ty (mkReflCo role ty)) } ;+           Nothing -> do { traceFlat "Unfilled tyvar" (ppr tv)+                         ; fr <- getFlavourRole+                         ; flatten_tyvar2 tv fr } }++flatten_tyvar2 :: TcTyVar -> CtFlavourRole -> FlatM FlattenTvResult+-- The tyvar is not a filled-in meta-tyvar+-- Try in the inert equalities+-- See Definition [Applying a generalised substitution] in TcSMonad+-- See Note [Stability of flattening] in TcSMonad++flatten_tyvar2 tv fr@(_, eq_rel)+  = do { ieqs <- liftTcS $ getInertEqs+       ; mode <- getMode+       ; case lookupDVarEnv ieqs tv of+           Just (ct:_)   -- If the first doesn't work,+                         -- the subsequent ones won't either+             | CTyEqCan { cc_ev = ctev, cc_tyvar = tv, cc_rhs = rhs_ty } <- ct+             , let ct_fr = ctEvFlavourRole ctev+             , ct_fr `eqCanRewriteFR` fr  -- This is THE key call of eqCanRewriteFR+             ->  do { traceFlat "Following inert tyvar" (ppr mode <+> ppr tv <+> equals <+> ppr rhs_ty $$ ppr ctev)+                    ; let rewrite_co1 = mkSymCo (ctEvCoercion ctev)+                          rewrite_co  = case (ctEvEqRel ctev, eq_rel) of+                            (ReprEq, _rel)  -> ASSERT( _rel == ReprEq )+                                    -- if this ASSERT fails, then+                                    -- eqCanRewriteFR answered incorrectly+                                               rewrite_co1+                            (NomEq, NomEq)  -> rewrite_co1+                            (NomEq, ReprEq) -> mkSubCo rewrite_co1++                    ; return (FTRFollowed rhs_ty rewrite_co) }+                    -- NB: ct is Derived then fmode must be also, hence+                    -- we are not going to touch the returned coercion+                    -- so ctEvCoercion is fine.++           _other -> return FTRNotFollowed }++{-+Note [An alternative story for the inert substitution]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(This entire note is just background, left here in case we ever want+ to return the the previous state of affairs)++We used (GHC 7.8) to have this story for the inert substitution inert_eqs++ * 'a' is not in fvs(ty)+ * They are *inert* in the weaker sense that there is no infinite chain of+   (i1 `eqCanRewrite` i2), (i2 `eqCanRewrite` i3), etc++This means that flattening must be recursive, but it does allow+  [G] a ~ [b]+  [G] b ~ Maybe c++This avoids "saturating" the Givens, which can save a modest amount of work.+It is easy to implement, in TcInteract.kick_out, by only kicking out an inert+only if (a) the work item can rewrite the inert AND+        (b) the inert cannot rewrite the work item++This is significantly harder to think about. It can save a LOT of work+in occurs-check cases, but we don't care about them much.  Trac #5837+is an example; all the constraints here are Givens++             [G] a ~ TF (a,Int)+    -->+    work     TF (a,Int) ~ fsk+    inert    fsk ~ a++    --->+    work     fsk ~ (TF a, TF Int)+    inert    fsk ~ a++    --->+    work     a ~ (TF a, TF Int)+    inert    fsk ~ a++    ---> (attempting to flatten (TF a) so that it does not mention a+    work     TF a ~ fsk2+    inert    a ~ (fsk2, TF Int)+    inert    fsk ~ (fsk2, TF Int)++    ---> (substitute for a)+    work     TF (fsk2, TF Int) ~ fsk2+    inert    a ~ (fsk2, TF Int)+    inert    fsk ~ (fsk2, TF Int)++    ---> (top-level reduction, re-orient)+    work     fsk2 ~ (TF fsk2, TF Int)+    inert    a ~ (fsk2, TF Int)+    inert    fsk ~ (fsk2, TF Int)++    ---> (attempt to flatten (TF fsk2) to get rid of fsk2+    work     TF fsk2 ~ fsk3+    work     fsk2 ~ (fsk3, TF Int)+    inert    a   ~ (fsk2, TF Int)+    inert    fsk ~ (fsk2, TF Int)++    --->+    work     TF fsk2 ~ fsk3+    inert    fsk2 ~ (fsk3, TF Int)+    inert    a   ~ ((fsk3, TF Int), TF Int)+    inert    fsk ~ ((fsk3, TF Int), TF Int)++Because the incoming given rewrites all the inert givens, we get more and+more duplication in the inert set.  But this really only happens in pathalogical+casee, so we don't care.+++************************************************************************+*                                                                      *+             Unflattening+*                                                                      *+************************************************************************++An unflattening example:+    [W] F a ~ alpha+flattens to+    [W] F a ~ fmv   (CFunEqCan)+    [W] fmv ~ alpha (CTyEqCan)+We must solve both!+-}++unflatten :: Cts -> Cts -> TcS Cts+unflatten tv_eqs funeqs+ = do { tclvl    <- getTcLevel++      ; traceTcS "Unflattening" $ braces $+        vcat [ text "Funeqs =" <+> pprCts funeqs+             , text "Tv eqs =" <+> pprCts tv_eqs ]++         -- Step 1: unflatten the CFunEqCans, except if that causes an occurs check+         -- Occurs check: consider  [W] alpha ~ [F alpha]+         --                 ==> (flatten) [W] F alpha ~ fmv, [W] alpha ~ [fmv]+         --                 ==> (unify)   [W] F [fmv] ~ fmv+         -- See Note [Unflatten using funeqs first]+      ; funeqs <- foldrBagM unflatten_funeq emptyCts funeqs+      ; traceTcS "Unflattening 1" $ braces (pprCts funeqs)++          -- Step 2: unify the tv_eqs, if possible+      ; tv_eqs  <- foldrBagM (unflatten_eq tclvl) emptyCts tv_eqs+      ; traceTcS "Unflattening 2" $ braces (pprCts tv_eqs)++          -- Step 3: fill any remaining fmvs with fresh unification variables+      ; funeqs <- mapBagM finalise_funeq funeqs+      ; traceTcS "Unflattening 3" $ braces (pprCts funeqs)++          -- Step 4: remove any tv_eqs that look like ty ~ ty+      ; tv_eqs <- foldrBagM finalise_eq emptyCts tv_eqs++      ; let all_flat = tv_eqs `andCts` funeqs+      ; traceTcS "Unflattening done" $ braces (pprCts all_flat)++          -- Step 5: zonk the result+          -- Motivation: makes them nice and ready for the next step+          --             (see TcInteract.solveSimpleWanteds)+      ; zonkSimples all_flat }+  where+    ----------------+    unflatten_funeq :: Ct -> Cts -> TcS Cts+    unflatten_funeq ct@(CFunEqCan { cc_fun = tc, cc_tyargs = xis+                                  , cc_fsk = fmv, cc_ev = ev }) rest+      = do {   -- fmv should be an un-filled flatten meta-tv;+               -- we now fix its final value by filling it, being careful+               -- to observe the occurs check.  Zonking will eliminate it+               -- altogether in due course+             rhs' <- zonkTcType (mkTyConApp tc xis)+           ; case occCheckExpand fmv rhs' of+               Just rhs''    -- Normal case: fill the tyvar+                 -> do { setReflEvidence ev NomEq rhs''+                       ; unflattenFmv fmv rhs''+                       ; return rest }++               Nothing ->  -- Occurs check+                          return (ct `consCts` rest) }++    unflatten_funeq other_ct _+      = pprPanic "unflatten_funeq" (ppr other_ct)++    ----------------+    finalise_funeq :: Ct -> TcS Ct+    finalise_funeq (CFunEqCan { cc_fsk = fmv, cc_ev = ev })+      = do { demoteUnfilledFmv fmv+           ; return (mkNonCanonical ev) }+    finalise_funeq ct = pprPanic "finalise_funeq" (ppr ct)++    ----------------+    unflatten_eq :: TcLevel -> Ct -> Cts -> TcS Cts+    unflatten_eq tclvl ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv+                                    , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest+      | isFmvTyVar tv   -- Previously these fmvs were untouchable,+                        -- but now they are touchable+                        -- NB: unlike unflattenFmv, filling a fmv here /does/+                        --     bump the unification count; it is "improvement"+                        -- Note [Unflattening can force the solver to iterate]+      = ASSERT2( tyVarKind tv `eqType` typeKind rhs, ppr ct )+           -- CTyEqCan invariant should ensure this is true+        do { is_filled <- isFilledMetaTyVar tv+           ; elim <- case is_filled of+               False -> do { traceTcS "unflatten_eq 2" (ppr ct)+                           ; tryFill      ev eq_rel       tv rhs }+               True  -> do { traceTcS "unflatten_eq 2" (ppr ct)+                           ; try_fill_rhs ev eq_rel tclvl tv rhs }+           ; if elim then return rest+                     else return (ct `consCts` rest) }++      | otherwise+      = return (ct `consCts` rest)++    unflatten_eq _ ct _ = pprPanic "unflatten_irred" (ppr ct)++    ----------------+    try_fill_rhs ev eq_rel tclvl lhs_tv rhs+         -- Constraint is lhs_tv ~ rhs_tv,+         -- and lhs_tv is filled, so try RHS+      | Just (rhs_tv, co) <- getCastedTyVar_maybe rhs+                             -- co :: kind(rhs_tv) ~ kind(lhs_tv)+      , isFmvTyVar rhs_tv || (isTouchableMetaTyVar tclvl rhs_tv+                              && not (isSigTyVar rhs_tv))+                              -- LHS is a filled fmv, and so is a type+                              -- family application, which a SigTv should+                              -- not unify with+      = do { is_filled <- isFilledMetaTyVar rhs_tv+           ; if is_filled then return False+             else tryFill ev eq_rel rhs_tv+                          (mkTyVarTy lhs_tv `mkCastTy` mkSymCo co) }++      | otherwise+      = return False++    ----------------+    finalise_eq :: Ct -> Cts -> TcS Cts+    finalise_eq (CTyEqCan { cc_ev = ev, cc_tyvar = tv+                          , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest+      | isFmvTyVar tv+      = do { ty1 <- zonkTcTyVar tv+           ; rhs' <- zonkTcType rhs+           ; if ty1 `tcEqType` rhs'+             then do { setReflEvidence ev eq_rel rhs'+                     ; return rest }+             else return (mkNonCanonical ev `consCts` rest) }++      | otherwise+      = return (mkNonCanonical ev `consCts` rest)++    finalise_eq ct _ = pprPanic "finalise_irred" (ppr ct)++tryFill :: CtEvidence -> EqRel -> TcTyVar -> TcType -> TcS Bool+-- (tryFill tv rhs ev) assumes 'tv' is an /un-filled/ MetaTv+-- If tv does not appear in 'rhs', it set tv := rhs,+-- binds the evidence (which should be a CtWanted) to Refl<rhs>+-- and return True.  Otherwise returns False+tryFill ev eq_rel tv rhs+  = ASSERT2( not (isGiven ev), ppr ev )+    do { rhs' <- zonkTcType rhs+       ; case tcGetTyVar_maybe rhs' of {+            Just tv' | tv == tv' -> do { setReflEvidence ev eq_rel rhs+                                       ; return True } ;+            _other ->+    do { case occCheckExpand tv rhs' of+           Just rhs''    -- Normal case: fill the tyvar+             -> do { setReflEvidence ev eq_rel rhs''+                   ; unifyTyVar tv rhs''+                   ; return True }++           Nothing ->  -- Occurs check+                      return False } } }++setReflEvidence :: CtEvidence -> EqRel -> TcType -> TcS ()+setReflEvidence ev eq_rel rhs+  = setEvBindIfWanted ev (EvCoercion refl_co)+  where+    refl_co = mkTcReflCo (eqRelRole eq_rel) rhs++{-+Note [Unflatten using funeqs first]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    [W] G a ~ Int+    [W] F (G a) ~ G a++do not want to end up with+    [W] F Int ~ Int+because that might actually hold!  Better to end up with the two above+unsolved constraints.  The flat form will be++    G a ~ fmv1     (CFunEqCan)+    F fmv1 ~ fmv2  (CFunEqCan)+    fmv1 ~ Int     (CTyEqCan)+    fmv1 ~ fmv2    (CTyEqCan)++Flatten using the fun-eqs first.+-}
+ typecheck/TcForeign.hs view
@@ -0,0 +1,562 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1998++\section[TcForeign]{Typechecking \tr{foreign} declarations}++A foreign declaration is used to either give an externally+implemented function a Haskell type (and calling interface) or+give a Haskell function an external calling interface. Either way,+the range of argument and result types these functions can accommodate+is restricted to what the outside world understands (read C), and this+module checks to see if a foreign declaration has got a legal type.+-}++{-# LANGUAGE CPP #-}++module TcForeign+        ( tcForeignImports+        , tcForeignExports++        -- Low-level exports for hooks+        , isForeignImport, isForeignExport+        , tcFImport, tcFExport+        , tcForeignImports'+        , tcCheckFIType, checkCTarget, checkForeignArgs, checkForeignRes+        , normaliseFfiType+        , nonIOok, mustBeIO+        , checkSafe, noCheckSafe+        , tcForeignExports'+        , tcCheckFEType+        ) where++#include "HsVersions.h"++import HsSyn++import TcRnMonad+import TcHsType+import TcExpr+import TcEnv++import FamInst+import FamInstEnv+import Coercion+import Type+import ForeignCall+import ErrUtils+import Id+import Name+import RdrName+import DataCon+import TyCon+import TcType+import PrelNames+import DynFlags+import Outputable+import Platform+import SrcLoc+import Bag+import Hooks+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Data.Maybe++-- Defines a binding+isForeignImport :: LForeignDecl name -> Bool+isForeignImport (L _ (ForeignImport {})) = True+isForeignImport _                        = False++-- Exports a binding+isForeignExport :: LForeignDecl name -> Bool+isForeignExport (L _ (ForeignExport {})) = True+isForeignExport _                        = False++{-+Note [Don't recur in normaliseFfiType']+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+normaliseFfiType' is the workhorse for normalising a type used in a foreign+declaration. If we have++newtype Age = MkAge Int++we want to see that Age -> IO () is the same as Int -> IO (). But, we don't+need to recur on any type parameters, because no paramaterized types (with+interesting parameters) are marshalable! The full list of marshalable types+is in the body of boxedMarshalableTyCon in TcType. The only members of that+list not at kind * are Ptr, FunPtr, and StablePtr, all of which get marshaled+the same way regardless of type parameter. So, no need to recur into+parameters.++Similarly, we don't need to look in AppTy's, because nothing headed by+an AppTy will be marshalable.++Note [FFI type roles]+~~~~~~~~~~~~~~~~~~~~~+The 'go' helper function within normaliseFfiType' always produces+representational coercions. But, in the "children_only" case, we need to+use these coercions in a TyConAppCo. Accordingly, the roles on the coercions+must be twiddled to match the expectation of the enclosing TyCon. However,+we cannot easily go from an R coercion to an N one, so we forbid N roles+on FFI type constructors. Currently, only two such type constructors exist:+IO and FunPtr. Thus, this is not an onerous burden.++If we ever want to lift this restriction, we would need to make 'go' take+the target role as a parameter. This wouldn't be hard, but it's a complication+not yet necessary and so is not yet implemented.+-}++-- normaliseFfiType takes the type from an FFI declaration, and+-- evaluates any type synonyms, type functions, and newtypes. However,+-- we are only allowed to look through newtypes if the constructor is+-- in scope.  We return a bag of all the newtype constructors thus found.+-- Always returns a Representational coercion+normaliseFfiType :: Type -> TcM (Coercion, Type, Bag GlobalRdrElt)+normaliseFfiType ty+    = do fam_envs <- tcGetFamInstEnvs+         normaliseFfiType' fam_envs ty++normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)+normaliseFfiType' env ty0 = go initRecTc ty0+  where+    go :: RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)+    go rec_nts ty+      | Just ty' <- tcView ty     -- Expand synonyms+      = go rec_nts ty'++      | Just (tc, tys) <- splitTyConApp_maybe ty+      = go_tc_app rec_nts tc tys++      | (bndrs, inner_ty) <- splitForAllTyVarBndrs ty+      , not (null bndrs)+      = do (coi, nty1, gres1) <- go rec_nts inner_ty+           return ( mkHomoForAllCos (binderVars bndrs) coi+                  , mkForAllTys bndrs nty1, gres1 )++      | otherwise -- see Note [Don't recur in normaliseFfiType']+      = return (mkRepReflCo ty, ty, emptyBag)++    go_tc_app :: RecTcChecker -> TyCon -> [Type]+              -> TcM (Coercion, Type, Bag GlobalRdrElt)+    go_tc_app rec_nts tc tys+        -- We don't want to look through the IO newtype, even if it is+        -- in scope, so we have a special case for it:+        | tc_key `elem` [ioTyConKey, funPtrTyConKey, funTyConKey]+                  -- These *must not* have nominal roles on their parameters!+                  -- See Note [FFI type roles]+        = children_only++        | isNewTyCon tc         -- Expand newtypes+        , Just rec_nts' <- checkRecTc rec_nts tc+                   -- See Note [Expanding newtypes] in TyCon.hs+                   -- We can't just use isRecursiveTyCon; sometimes recursion is ok:+                   --     newtype T = T (Ptr T)+                   --   Here, we don't reject the type for being recursive.+                   -- If this is a recursive newtype then it will normally+                   -- be rejected later as not being a valid FFI type.+        = do { rdr_env <- getGlobalRdrEnv+             ; case checkNewtypeFFI rdr_env tc of+                 Nothing  -> nothing+                 Just gre -> do { (co', ty', gres) <- go rec_nts' nt_rhs+                                ; return (mkTransCo nt_co co', ty', gre `consBag` gres) } }++        | isFamilyTyCon tc              -- Expand open tycons+        , (co, ty) <- normaliseTcApp env Representational tc tys+        , not (isReflexiveCo co)+        = do (co', ty', gres) <- go rec_nts ty+             return (mkTransCo co co', ty', gres)++        | otherwise+        = nothing -- see Note [Don't recur in normaliseFfiType']+        where+          tc_key = getUnique tc+          children_only+            = do xs <- mapM (go rec_nts) tys+                 let (cos, tys', gres) = unzip3 xs+                        -- the (repeat Representational) is because 'go' always+                        -- returns R coercions+                     cos' = zipWith3 downgradeRole (tyConRoles tc)+                                     (repeat Representational) cos+                 return ( mkTyConAppCo Representational tc cos'+                        , mkTyConApp tc tys', unionManyBags gres)+          nt_co  = mkUnbranchedAxInstCo Representational (newTyConCo tc) tys []+          nt_rhs = newTyConInstRhs tc tys++          ty      = mkTyConApp tc tys+          nothing = return (mkRepReflCo ty, ty, emptyBag)++checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt+checkNewtypeFFI rdr_env tc+  | Just con <- tyConSingleDataCon_maybe tc+  , Just gre <- lookupGRE_Name rdr_env (dataConName con)+  = Just gre    -- See Note [Newtype constructor usage in foreign declarations]+  | otherwise+  = Nothing++{-+Note [Newtype constructor usage in foreign declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC automatically "unwraps" newtype constructors in foreign import/export+declarations.  In effect that means that a newtype data constructor is+used even though it is not mentioned expclitly in the source, so we don't+want to report it as "defined but not used" or "imported but not used".+eg     newtype D = MkD Int+       foreign import foo :: D -> IO ()+Here 'MkD' us used.  See Trac #7408.++GHC also expands type functions during this process, so it's not enough+just to look at the free variables of the declaration.+eg     type instance F Bool = D+       foreign import bar :: F Bool -> IO ()+Here again 'MkD' is used.++So we really have wait until the type checker to decide what is used.+That's why tcForeignImports and tecForeignExports return a (Bag GRE)+for the newtype constructors they see. Then TcRnDriver can add them+to the module's usages.+++************************************************************************+*                                                                      *+\subsection{Imports}+*                                                                      *+************************************************************************+-}++tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt)+tcForeignImports decls+  = getHooked tcForeignImportsHook tcForeignImports' >>= ($ decls)++tcForeignImports' :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt)+-- For the (Bag GlobalRdrElt) result,+-- see Note [Newtype constructor usage in foreign declarations]+tcForeignImports' decls+  = do { (ids, decls, gres) <- mapAndUnzip3M tcFImport $+                               filter isForeignImport decls+       ; return (ids, decls, unionManyBags gres) }++tcFImport :: LForeignDecl Name -> TcM (Id, LForeignDecl Id, Bag GlobalRdrElt)+tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty+                                    , fd_fi = imp_decl }))+  = setSrcSpan dloc $ addErrCtxt (foreignDeclCtxt fo)  $+    do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty+       ; (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty+       ; let+           -- Drop the foralls before inspecting the+           -- structure of the foreign type.+             (bndrs, res_ty)   = tcSplitPiTys norm_sig_ty+             arg_tys           = mapMaybe binderRelevantType_maybe bndrs+             id                = mkLocalId nm sig_ty+                 -- Use a LocalId to obey the invariant that locally-defined+                 -- things are LocalIds.  However, it does not need zonking,+                 -- (so TcHsSyn.zonkForeignExports ignores it).++       ; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl+          -- Can't use sig_ty here because sig_ty :: Type and+          -- we need HsType Id hence the undefined+       ; let fi_decl = ForeignImport { fd_name = L nloc id+                                     , fd_sig_ty = undefined+                                     , fd_co = mkSymCo norm_co+                                     , fd_fi = imp_decl' }+       ; return (id, L dloc fi_decl, gres) }+tcFImport d = pprPanic "tcFImport" (ppr d)++-- ------------ Checking types for foreign import ----------------------++tcCheckFIType :: [Type] -> Type -> ForeignImport -> TcM ForeignImport++tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh l@(CLabel _) src)+  -- Foreign import label+  = do checkCg checkCOrAsmOrLlvmOrInterp+       -- NB check res_ty not sig_ty!+       --    In case sig_ty is (forall a. ForeignPtr a)+       check (isFFILabelTy (mkFunTys arg_tys res_ty)) (illegalForeignTyErr Outputable.empty)+       cconv' <- checkCConv cconv+       return (CImport (L lc cconv') safety mh l src)++tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh CWrapper src) = do+        -- Foreign wrapper (former f.e.d.)+        -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid+        -- foreign type.  For legacy reasons ft -> IO (Ptr ft) is accepted, too.+        -- The use of the latter form is DEPRECATED, though.+    checkCg checkCOrAsmOrLlvmOrInterp+    cconv' <- checkCConv cconv+    case arg_tys of+        [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys+                        checkForeignRes nonIOok  checkSafe isFFIExportResultTy res1_ty+                        checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty+                  where+                     (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty+        _ -> addErrTc (illegalForeignTyErr Outputable.empty (text "One argument expected"))+    return (CImport (L lc cconv') safety mh CWrapper src)++tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh+                                            (CFunction target) src)+  | isDynamicTarget target = do -- Foreign import dynamic+      checkCg checkCOrAsmOrLlvmOrInterp+      cconv' <- checkCConv cconv+      case arg_tys of           -- The first arg must be Ptr or FunPtr+        []                ->+          addErrTc (illegalForeignTyErr Outputable.empty (text "At least one argument expected"))+        (arg1_ty:arg_tys) -> do+          dflags <- getDynFlags+          let curried_res_ty = mkFunTys arg_tys res_ty+          check (isFFIDynTy curried_res_ty arg1_ty)+                (illegalForeignTyErr argument)+          checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys+          checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty+      return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src+  | cconv == PrimCallConv = do+      dflags <- getDynFlags+      checkTc (xopt LangExt.GHCForeignImportPrim dflags)+              (text "Use GHCForeignImportPrim to allow `foreign import prim'.")+      checkCg checkCOrAsmOrLlvmOrInterp+      checkCTarget target+      checkTc (playSafe safety)+              (text "The safe/unsafe annotation should not be used with `foreign import prim'.")+      checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys+      -- prim import result is more liberal, allows (#,,#)+      checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty+      return idecl+  | otherwise = do              -- Normal foreign import+      checkCg checkCOrAsmOrLlvmOrInterp+      cconv' <- checkCConv cconv+      checkCTarget target+      dflags <- getDynFlags+      checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys+      checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty+      checkMissingAmpersand dflags arg_tys res_ty+      case target of+          StaticTarget _ _ _ False+           | not (null arg_tys) ->+              addErrTc (text "`value' imports cannot have function types")+          _ -> return ()+      return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src+++-- This makes a convenient place to check+-- that the C identifier is valid for C+checkCTarget :: CCallTarget -> TcM ()+checkCTarget (StaticTarget _ str _ _) = do+    checkCg checkCOrAsmOrLlvmOrInterp+    checkTc (isCLabelString str) (badCName str)++checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"+++checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()+checkMissingAmpersand dflags arg_tys res_ty+  | null arg_tys && isFunPtrTy res_ty &&+    wopt Opt_WarnDodgyForeignImports dflags+  = addWarn (Reason Opt_WarnDodgyForeignImports)+        (text "possible missing & in foreign import of FunPtr")+  | otherwise+  = return ()++{-+************************************************************************+*                                                                      *+\subsection{Exports}+*                                                                      *+************************************************************************+-}++tcForeignExports :: [LForeignDecl Name]+                 -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt)+tcForeignExports decls =+  getHooked tcForeignExportsHook tcForeignExports' >>= ($ decls)++tcForeignExports' :: [LForeignDecl Name]+                 -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt)+-- For the (Bag GlobalRdrElt) result,+-- see Note [Newtype constructor usage in foreign declarations]+tcForeignExports' decls+  = foldlM combine (emptyLHsBinds, [], emptyBag) (filter isForeignExport decls)+  where+   combine (binds, fs, gres1) (L loc fe) = do+       (b, f, gres2) <- setSrcSpan loc (tcFExport fe)+       return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2)++tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id, Bag GlobalRdrElt)+tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spec })+  = addErrCtxt (foreignDeclCtxt fo) $ do++    sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty+    rhs <- tcPolyExpr (nlHsVar nm) sig_ty++    (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty++    spec' <- tcCheckFEType norm_sig_ty spec++           -- we're exporting a function, but at a type possibly more+           -- constrained than its declared/inferred type. Hence the need+           -- to create a local binding which will call the exported function+           -- at a particular type (and, maybe, overloading).+++    -- We need to give a name to the new top-level binding that+    -- is *stable* (i.e. the compiler won't change it later),+    -- because this name will be referred to by the C code stub.+    id  <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc+    return ( mkVarBind id rhs+           , ForeignExport { fd_name = L loc id+                           , fd_sig_ty = undefined+                           , fd_co = norm_co, fd_fe = spec' }+           , gres)+tcFExport d = pprPanic "tcFExport" (ppr d)++-- ------------ Checking argument types for foreign export ----------------------++tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport+tcCheckFEType sig_ty (CExport (L l (CExportStatic esrc str cconv)) src) = do+    checkCg checkCOrAsmOrLlvm+    checkTc (isCLabelString str) (badCName str)+    cconv' <- checkCConv cconv+    checkForeignArgs isFFIExternalTy arg_tys+    checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty+    return (CExport (L l (CExportStatic esrc str cconv')) src)+  where+      -- Drop the foralls before inspecting n+      -- the structure of the foreign type.+    (bndrs, res_ty) = tcSplitPiTys sig_ty+    arg_tys         = mapMaybe binderRelevantType_maybe bndrs++{-+************************************************************************+*                                                                      *+\subsection{Miscellaneous}+*                                                                      *+************************************************************************+-}++------------ Checking argument types for foreign import ----------------------+checkForeignArgs :: (Type -> Validity) -> [Type] -> TcM ()+checkForeignArgs pred tys = mapM_ go tys+  where+    go ty = check (pred ty) (illegalForeignTyErr argument)++------------ Checking result types for foreign calls ----------------------+-- | Check that the type has the form+--    (IO t) or (t) , and that t satisfies the given predicate.+-- When calling this function, any newtype wrappers (should) have been+-- already dealt with by normaliseFfiType.+--+-- We also check that the Safe Haskell condition of FFI imports having+-- results in the IO monad holds.+--+checkForeignRes :: Bool -> Bool -> (Type -> Validity) -> Type -> TcM ()+checkForeignRes non_io_result_ok check_safe pred_res_ty ty+  | Just (_, res_ty) <- tcSplitIOType_maybe ty+  =     -- Got an IO result type, that's always fine!+     check (pred_res_ty res_ty) (illegalForeignTyErr result)++  -- Case for non-IO result type with FFI Import+  | not non_io_result_ok+  = addErrTc $ illegalForeignTyErr result (text "IO result type expected")++  | otherwise+  = do { dflags <- getDynFlags+       ; case pred_res_ty ty of+                -- Handle normal typecheck fail, we want to handle this first and+                -- only report safe haskell errors if the normal type check is OK.+           NotValid msg -> addErrTc $ illegalForeignTyErr result msg++           -- handle safe infer fail+           _ | check_safe && safeInferOn dflags+               -> recordUnsafeInfer emptyBag++           -- handle safe language typecheck fail+           _ | check_safe && safeLanguageOn dflags+               -> addErrTc (illegalForeignTyErr result safeHsErr)++           -- success! non-IO return is fine+           _ -> return () }+  where+    safeHsErr =+      text "Safe Haskell is on, all FFI imports must be in the IO monad"++nonIOok, mustBeIO :: Bool+nonIOok  = True+mustBeIO = False++checkSafe, noCheckSafe :: Bool+checkSafe   = True+noCheckSafe = False++-- Checking a supported backend is in use++checkCOrAsmOrLlvm :: HscTarget -> Validity+checkCOrAsmOrLlvm HscC    = IsValid+checkCOrAsmOrLlvm HscAsm  = IsValid+checkCOrAsmOrLlvm HscLlvm = IsValid+checkCOrAsmOrLlvm _+  = NotValid (text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)")++checkCOrAsmOrLlvmOrInterp :: HscTarget -> Validity+checkCOrAsmOrLlvmOrInterp HscC           = IsValid+checkCOrAsmOrLlvmOrInterp HscAsm         = IsValid+checkCOrAsmOrLlvmOrInterp HscLlvm        = IsValid+checkCOrAsmOrLlvmOrInterp HscInterpreted = IsValid+checkCOrAsmOrLlvmOrInterp _+  = NotValid (text "requires interpreted, unregisterised, llvm or native code generation")++checkCg :: (HscTarget -> Validity) -> TcM ()+checkCg check = do+    dflags <- getDynFlags+    let target = hscTarget dflags+    case target of+      HscNothing -> return ()+      _ ->+        case check target of+          IsValid      -> return ()+          NotValid err -> addErrTc (text "Illegal foreign declaration:" <+> err)++-- Calling conventions++checkCConv :: CCallConv -> TcM CCallConv+checkCConv CCallConv    = return CCallConv+checkCConv CApiConv     = return CApiConv+checkCConv StdCallConv  = do dflags <- getDynFlags+                             let platform = targetPlatform dflags+                             if platformArch platform == ArchX86+                                 then return StdCallConv+                                 else do -- This is a warning, not an error. see #3336+                                         when (wopt Opt_WarnUnsupportedCallingConventions dflags) $+                                             addWarnTc (Reason Opt_WarnUnsupportedCallingConventions)+                                                 (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall")+                                         return CCallConv+checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'")+                             return PrimCallConv+checkCConv JavaScriptCallConv = do dflags <- getDynFlags+                                   if platformArch (targetPlatform dflags) == ArchJavaScript+                                       then return JavaScriptCallConv+                                       else do addErrTc (text "The `javascript' calling convention is unsupported on this platform")+                                               return JavaScriptCallConv++-- Warnings++check :: Validity -> (MsgDoc -> MsgDoc) -> TcM ()+check IsValid _             = return ()+check (NotValid doc) err_fn = addErrTc (err_fn doc)++illegalForeignTyErr :: SDoc -> SDoc -> SDoc+illegalForeignTyErr arg_or_res extra+  = hang msg 2 extra+  where+    msg = hsep [ text "Unacceptable", arg_or_res+               , text "type in foreign declaration:"]++-- Used for 'arg_or_res' argument to illegalForeignTyErr+argument, result :: SDoc+argument = text "argument"+result   = text "result"++badCName :: CLabelString -> MsgDoc+badCName target+  = sep [quotes (ppr target) <+> text "is not a valid C identifier"]++foreignDeclCtxt :: ForeignDecl Name -> SDoc+foreignDeclCtxt fo+  = hang (text "When checking declaration:")+       2 (ppr fo)
+ typecheck/TcGenDeriv.hs view
@@ -0,0 +1,2155 @@+{-+    %+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++TcGenDeriv: Generating derived instance declarations++This module is nominally ``subordinate'' to @TcDeriv@, which is the+``official'' interface to deriving-related things.++This is where we do all the grimy bindings' generation.+-}++{-# LANGUAGE CPP, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}++module TcGenDeriv (+        BagDerivStuff, DerivStuff(..),++        gen_Eq_binds,+        gen_Ord_binds,+        gen_Enum_binds,+        gen_Bounded_binds,+        gen_Ix_binds,+        gen_Show_binds,+        gen_Read_binds,+        gen_Data_binds,+        gen_Lift_binds,+        gen_Newtype_binds,+        mkCoerceClassMethEqn,+        genAuxBinds,+        ordOpTbl, boxConTbl, litConTbl,+        mkRdrFunBind, error_Expr+    ) where++#include "HsVersions.h"++import TcRnMonad+import HsSyn+import RdrName+import BasicTypes+import DataCon+import Name+import Fingerprint+import Encoding++import DynFlags+import PrelInfo+import FamInst+import FamInstEnv+import PrelNames+import THNames+import Module ( moduleName, moduleNameString+              , moduleUnitId, unitIdString )+import MkId ( coerceId )+import PrimOp+import SrcLoc+import TyCon+import TcEnv+import TcType+import TcValidity ( checkValidTyFamEqn )+import TysPrim+import TysWiredIn+import Type+import Class+import VarSet+import VarEnv+import Util+import Var+import Outputable+import Lexeme+import FastString+import Pair+import Bag++import Data.List  ( partition, intersperse )++type BagDerivStuff = Bag DerivStuff++data AuxBindSpec+  = DerivCon2Tag TyCon  -- The con2Tag for given TyCon+  | DerivTag2Con TyCon  -- ...ditto tag2Con+  | DerivMaxTag  TyCon  -- ...and maxTag+  deriving( Eq )+  -- All these generate ZERO-BASED tag operations+  -- I.e first constructor has tag 0++data DerivStuff     -- Please add this auxiliary stuff+  = DerivAuxBind AuxBindSpec++  -- Generics and DeriveAnyClass+  | DerivFamInst FamInst               -- New type family instances++  -- New top-level auxiliary bindings+  | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB+++{-+************************************************************************+*                                                                      *+                Eq instances+*                                                                      *+************************************************************************++Here are the heuristics for the code we generate for @Eq@. Let's+assume we have a data type with some (possibly zero) nullary data+constructors and some ordinary, non-nullary ones (the rest, also+possibly zero of them).  Here's an example, with both \tr{N}ullary and+\tr{O}rdinary data cons.++  data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...++* For the ordinary constructors (if any), we emit clauses to do The+  Usual Thing, e.g.,:++    (==) (O1 a1 b1)    (O1 a2 b2)    = a1 == a2 && b1 == b2+    (==) (O2 a1)       (O2 a2)       = a1 == a2+    (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2++  Note: if we're comparing unlifted things, e.g., if 'a1' and+  'a2' are Float#s, then we have to generate+       case (a1 `eqFloat#` a2) of r -> r+  for that particular test.++* If there are a lot of (more than en) nullary constructors, we emit a+  catch-all clause of the form:++      (==) a b  = case (con2tag_Foo a) of { a# ->+                  case (con2tag_Foo b) of { b# ->+                  case (a# ==# b#)     of {+                    r -> r }}}++  If con2tag gets inlined this leads to join point stuff, so+  it's better to use regular pattern matching if there aren't too+  many nullary constructors.  "Ten" is arbitrary, of course++* If there aren't any nullary constructors, we emit a simpler+  catch-all:++     (==) a b  = False++* For the @(/=)@ method, we normally just use the default method.+  If the type is an enumeration type, we could/may/should? generate+  special code that calls @con2tag_Foo@, much like for @(==)@ shown+  above.++We thought about doing this: If we're also deriving 'Ord' for this+tycon, we generate:+  instance ... Eq (Foo ...) where+    (==) a b  = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}+    (/=) a b  = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }+However, that requires that (Ord <whatever>) was put in the context+for the instance decl, which it probably wasn't, so the decls+produced don't get through the typechecker.+-}++gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff)+gen_Eq_binds loc tycon = do+    dflags <- getDynFlags+    return (method_binds dflags, aux_binds)+  where+    all_cons = tyConDataCons tycon+    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons++    -- If there are ten or more (arbitrary number) nullary constructors,+    -- use the con2tag stuff.  For small types it's better to use+    -- ordinary pattern matching.+    (tag_match_cons, pat_match_cons)+       | nullary_cons `lengthExceeds` 10 = (nullary_cons, non_nullary_cons)+       | otherwise                       = ([],           all_cons)++    no_tag_match_cons = null tag_match_cons++    fall_through_eqn dflags+      | no_tag_match_cons   -- All constructors have arguments+      = case pat_match_cons of+          []  -> []   -- No constructors; no fall-though case+          [_] -> []   -- One constructor; no fall-though case+          _   ->      -- Two or more constructors; add fall-through of+                      --       (==) _ _ = False+                 [([nlWildPat, nlWildPat], false_Expr)]++      | otherwise -- One or more tag_match cons; add fall-through of+                  -- extract tags compare for equality+      = [([a_Pat, b_Pat],+         untag_Expr dflags tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]+                    (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]++    aux_binds | no_tag_match_cons = emptyBag+              | otherwise         = unitBag $ DerivAuxBind $ DerivCon2Tag tycon++    method_binds dflags = listToBag+      [ eq_bind dflags+      , ne_bind+      ]+    eq_bind dflags = mk_FunBind loc eq_RDR (map pats_etc pat_match_cons+                                            ++ fall_through_eqn dflags)+    ne_bind = mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (+                        nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))++    ------------------------------------------------------------------+    pats_etc data_con+      = let+            con1_pat = nlParPat $ nlConVarPat data_con_RDR as_needed+            con2_pat = nlParPat $ nlConVarPat data_con_RDR bs_needed++            data_con_RDR = getRdrName data_con+            con_arity   = length tys_needed+            as_needed   = take con_arity as_RDRs+            bs_needed   = take con_arity bs_RDRs+            tys_needed  = dataConOrigArgTys data_con+        in+        ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)+      where+        nested_eq_expr []  [] [] = true_Expr+        nested_eq_expr tys as bs+          = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)+          where+            nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))++{-+************************************************************************+*                                                                      *+        Ord instances+*                                                                      *+************************************************************************++Note [Generating Ord instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose constructors are K1..Kn, and some are nullary.+The general form we generate is:++* Do case on first argument+        case a of+          K1 ... -> rhs_1+          K2 ... -> rhs_2+          ...+          Kn ... -> rhs_n+          _ -> nullary_rhs++* To make rhs_i+     If i = 1, 2, n-1, n, generate a single case.+        rhs_2    case b of+                   K1 {}  -> LT+                   K2 ... -> ...eq_rhs(K2)...+                   _      -> GT++     Otherwise do a tag compare against the bigger range+     (because this is the one most likely to succeed)+        rhs_3    case tag b of tb ->+                 if 3 <# tg then GT+                 else case b of+                         K3 ... -> ...eq_rhs(K3)....+                         _      -> LT++* To make eq_rhs(K), which knows that+    a = K a1 .. av+    b = K b1 .. bv+  we just want to compare (a1,b1) then (a2,b2) etc.+  Take care on the last field to tail-call into comparing av,bv++* To make nullary_rhs generate this+     case con2tag a of a# ->+     case con2tag b of ->+     a# `compare` b#++Several special cases:++* Two or fewer nullary constructors: don't generate nullary_rhs++* Be careful about unlifted comparisons.  When comparing unboxed+  values we can't call the overloaded functions.+  See function unliftedOrdOp++Note [Game plan for deriving Ord]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's a bad idea to define only 'compare', and build the other binary+comparisons on top of it; see Trac #2130, #4019.  Reason: we don't+want to laboriously make a three-way comparison, only to extract a+binary result, something like this:+     (>) (I# x) (I# y) = case <# x y of+                            True -> False+                            False -> case ==# x y of+                                       True  -> False+                                       False -> True++This being said, we can get away with generating full code only for+'compare' and '<' thus saving us generation of other three operators.+Other operators can be cheaply expressed through '<':+a <= b = not $ b < a+a > b = b < a+a >= b = not $ a < b++So for sufficiently small types (few constructors, or all nullary)+we generate all methods; for large ones we just use 'compare'.++-}++data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT++------------+ordMethRdr :: OrdOp -> RdrName+ordMethRdr op+  = case op of+       OrdCompare -> compare_RDR+       OrdLT      -> lt_RDR+       OrdLE      -> le_RDR+       OrdGE      -> ge_RDR+       OrdGT      -> gt_RDR++------------+ltResult :: OrdOp -> LHsExpr RdrName+-- Knowing a<b, what is the result for a `op` b?+ltResult OrdCompare = ltTag_Expr+ltResult OrdLT      = true_Expr+ltResult OrdLE      = true_Expr+ltResult OrdGE      = false_Expr+ltResult OrdGT      = false_Expr++------------+eqResult :: OrdOp -> LHsExpr RdrName+-- Knowing a=b, what is the result for a `op` b?+eqResult OrdCompare = eqTag_Expr+eqResult OrdLT      = false_Expr+eqResult OrdLE      = true_Expr+eqResult OrdGE      = true_Expr+eqResult OrdGT      = false_Expr++------------+gtResult :: OrdOp -> LHsExpr RdrName+-- Knowing a>b, what is the result for a `op` b?+gtResult OrdCompare = gtTag_Expr+gtResult OrdLT      = false_Expr+gtResult OrdLE      = false_Expr+gtResult OrdGE      = true_Expr+gtResult OrdGT      = true_Expr++------------+gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff)+gen_Ord_binds loc tycon = do+    dflags <- getDynFlags+    return $ if null tycon_data_cons -- No data-cons => invoke bale-out case+      then ( unitBag $ mk_FunBind loc compare_RDR []+           , emptyBag)+      else ( unitBag (mkOrdOp dflags OrdCompare) `unionBags` other_ops dflags+           , aux_binds)+  where+    aux_binds | single_con_type = emptyBag+              | otherwise       = unitBag $ DerivAuxBind $ DerivCon2Tag tycon++        -- Note [Game plan for deriving Ord]+    other_ops dflags+      | (last_tag - first_tag) <= 2     -- 1-3 constructors+        || null non_nullary_cons        -- Or it's an enumeration+      = listToBag [mkOrdOp dflags OrdLT, lE, gT, gE]+      | otherwise+      = emptyBag++    negate_expr = nlHsApp (nlHsVar not_RDR)+    lE = mk_easy_FunBind loc le_RDR [a_Pat, b_Pat] $+        negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr)+    gT = mk_easy_FunBind loc gt_RDR [a_Pat, b_Pat] $+        nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr+    gE = mk_easy_FunBind loc ge_RDR [a_Pat, b_Pat] $+        negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) a_Expr) b_Expr)++    get_tag con = dataConTag con - fIRST_TAG+        -- We want *zero-based* tags, because that's what+        -- con2Tag returns (generated by untag_Expr)!++    tycon_data_cons = tyConDataCons tycon+    single_con_type = isSingleton tycon_data_cons+    (first_con : _) = tycon_data_cons+    (last_con : _)  = reverse tycon_data_cons+    first_tag       = get_tag first_con+    last_tag        = get_tag last_con++    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons+++    mkOrdOp :: DynFlags -> OrdOp -> LHsBind RdrName+    -- Returns a binding   op a b = ... compares a and b according to op ....+    mkOrdOp dflags op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat]+                                        (mkOrdOpRhs dflags op)++    mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr RdrName+    mkOrdOpRhs dflags op       -- RHS for comparing 'a' and 'b' according to op+      | length nullary_cons <= 2  -- Two nullary or fewer, so use cases+      = nlHsCase (nlHsVar a_RDR) $+        map (mkOrdOpAlt dflags op) tycon_data_cons+        -- i.e.  case a of { C1 x y -> case b of C1 x y -> ....compare x,y...+        --                   C2 x   -> case b of C2 x -> ....comopare x.... }++      | null non_nullary_cons    -- All nullary, so go straight to comparing tags+      = mkTagCmp dflags op++      | otherwise                -- Mixed nullary and non-nullary+      = nlHsCase (nlHsVar a_RDR) $+        (map (mkOrdOpAlt dflags op) non_nullary_cons+         ++ [mkHsCaseAlt nlWildPat (mkTagCmp dflags op)])+++    mkOrdOpAlt :: DynFlags -> OrdOp -> DataCon+                  -> LMatch RdrName (LHsExpr RdrName)+    -- Make the alternative  (Ki a1 a2 .. av ->+    mkOrdOpAlt dflags op data_con+      = mkHsCaseAlt (nlConVarPat data_con_RDR as_needed)+                    (mkInnerRhs dflags op data_con)+      where+        as_needed    = take (dataConSourceArity data_con) as_RDRs+        data_con_RDR = getRdrName data_con++    mkInnerRhs dflags op data_con+      | single_con_type+      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ]++      | tag == first_tag+      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con+                                 , mkHsCaseAlt nlWildPat (ltResult op) ]+      | tag == last_tag+      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con+                                 , mkHsCaseAlt nlWildPat (gtResult op) ]++      | tag == first_tag + 1+      = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat first_con)+                                             (gtResult op)+                                 , mkInnerEqAlt op data_con+                                 , mkHsCaseAlt nlWildPat (ltResult op) ]+      | tag == last_tag - 1+      = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat last_con)+                                             (ltResult op)+                                 , mkInnerEqAlt op data_con+                                 , mkHsCaseAlt nlWildPat (gtResult op) ]++      | tag > last_tag `div` 2  -- lower range is larger+      = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $+        nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)+               (gtResult op) $  -- Definitely GT+        nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con+                                 , mkHsCaseAlt nlWildPat (ltResult op) ]++      | otherwise               -- upper range is larger+      = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $+        nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)+               (ltResult op) $  -- Definitely LT+        nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con+                                 , mkHsCaseAlt nlWildPat (gtResult op) ]+      where+        tag     = get_tag data_con+        tag_lit = noLoc (HsLit (HsIntPrim NoSourceText (toInteger tag)))++    mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)+    -- First argument 'a' known to be built with K+    -- Returns a case alternative  Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...)+    mkInnerEqAlt op data_con+      = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $+        mkCompareFields tycon op (dataConOrigArgTys data_con)+      where+        data_con_RDR = getRdrName data_con+        bs_needed    = take (dataConSourceArity data_con) bs_RDRs++    mkTagCmp :: DynFlags -> OrdOp -> LHsExpr RdrName+    -- Both constructors known to be nullary+    -- genreates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#+    mkTagCmp dflags op =+      untag_Expr dflags tycon[(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $+        unliftedOrdOp tycon intPrimTy op ah_RDR bh_RDR++mkCompareFields :: TyCon -> OrdOp -> [Type] -> LHsExpr RdrName+-- Generates nested comparisons for (a1,a2...) against (b1,b2,...)+-- where the ai,bi have the given types+mkCompareFields tycon op tys+  = go tys as_RDRs bs_RDRs+  where+    go []   _      _          = eqResult op+    go [ty] (a:_)  (b:_)+      | isUnliftedType ty     = unliftedOrdOp tycon ty op a b+      | otherwise             = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b)+    go (ty:tys) (a:as) (b:bs) = mk_compare ty a b+                                  (ltResult op)+                                  (go tys as bs)+                                  (gtResult op)+    go _ _ _ = panic "mkCompareFields"++    -- (mk_compare ty a b) generates+    --    (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })+    -- but with suitable special cases for+    mk_compare ty a b lt eq gt+      | isUnliftedType ty+      = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt+      | otherwise+      = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr))+          [mkHsCaseAlt (nlNullaryConPat ltTag_RDR) lt,+           mkHsCaseAlt (nlNullaryConPat eqTag_RDR) eq,+           mkHsCaseAlt (nlNullaryConPat gtTag_RDR) gt]+      where+        a_expr = nlHsVar a+        b_expr = nlHsVar b+        (lt_op, _, eq_op, _, _) = primOrdOps "Ord" tycon ty++unliftedOrdOp :: TyCon -> Type -> OrdOp -> RdrName -> RdrName -> LHsExpr RdrName+unliftedOrdOp tycon ty op a b+  = case op of+       OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr+                                     ltTag_Expr eqTag_Expr gtTag_Expr+       OrdLT      -> wrap lt_op+       OrdLE      -> wrap le_op+       OrdGE      -> wrap ge_op+       OrdGT      -> wrap gt_op+  where+   (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" tycon ty+   wrap prim_op = genPrimOpApp a_expr prim_op b_expr+   a_expr = nlHsVar a+   b_expr = nlHsVar b++unliftedCompare :: RdrName -> RdrName+                -> LHsExpr RdrName -> LHsExpr RdrName   -- What to cmpare+                -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName  -- Three results+                -> LHsExpr RdrName+-- Return (if a < b then lt else if a == b then eq else gt)+unliftedCompare lt_op eq_op a_expr b_expr lt eq gt+  = nlHsIf (ascribeBool $ genPrimOpApp a_expr lt_op b_expr) lt $+                        -- Test (<) first, not (==), because the latter+                        -- is true less often, so putting it first would+                        -- mean more tests (dynamically)+        nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt+  where+    ascribeBool e = nlExprWithTySig e boolTy++nlConWildPat :: DataCon -> LPat RdrName+-- The pattern (K {})+nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con))+                                   (RecCon (HsRecFields { rec_flds = []+                                                        , rec_dotdot = Nothing })))++{-+************************************************************************+*                                                                      *+        Enum instances+*                                                                      *+************************************************************************++@Enum@ can only be derived for enumeration types.  For a type+\begin{verbatim}+data Foo ... = N1 | N2 | ... | Nn+\end{verbatim}++we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a+@maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).++\begin{verbatim}+instance ... Enum (Foo ...) where+    succ x   = toEnum (1 + fromEnum x)+    pred x   = toEnum (fromEnum x - 1)++    toEnum i = tag2con_Foo i++    enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]++    -- or, really...+    enumFrom a+      = case con2tag_Foo a of+          a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)++   enumFromThen a b+     = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]++    -- or, really...+    enumFromThen a b+      = case con2tag_Foo a of { a# ->+        case con2tag_Foo b of { b# ->+        map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)+        }}+\end{verbatim}++For @enumFromTo@ and @enumFromThenTo@, we use the default methods.+-}++gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff)+gen_Enum_binds loc tycon = do+    dflags <- getDynFlags+    return (method_binds dflags, aux_binds)+  where+    method_binds dflags = listToBag+      [ succ_enum      dflags+      , pred_enum      dflags+      , to_enum        dflags+      , enum_from      dflags+      , enum_from_then dflags+      , from_enum      dflags+      ]+    aux_binds = listToBag $ map DerivAuxBind+                  [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]++    occ_nm = getOccString tycon++    succ_enum dflags+      = mk_easy_FunBind loc succ_RDR [a_Pat] $+        untag_Expr dflags tycon [(a_RDR, ah_RDR)] $+        nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR dflags tycon),+                               nlHsVarApps intDataCon_RDR [ah_RDR]])+             (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")+             (nlHsApp (nlHsVar (tag2con_RDR dflags tycon))+                    (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],+                                        nlHsIntLit 1]))++    pred_enum dflags+      = mk_easy_FunBind loc pred_RDR [a_Pat] $+        untag_Expr dflags tycon [(a_RDR, ah_RDR)] $+        nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,+                               nlHsVarApps intDataCon_RDR [ah_RDR]])+             (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")+             (nlHsApp (nlHsVar (tag2con_RDR dflags tycon))+                           (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],+                                           nlHsLit (HsInt NoSourceText (-1))]))++    to_enum dflags+      = mk_easy_FunBind loc toEnum_RDR [a_Pat] $+        nlHsIf (nlHsApps and_RDR+                [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],+                 nlHsApps le_RDR [ nlHsVar a_RDR+                                 , nlHsVar (maxtag_RDR dflags tycon)]])+             (nlHsVarApps (tag2con_RDR dflags tycon) [a_RDR])+             (illegal_toEnum_tag occ_nm (maxtag_RDR dflags tycon))++    enum_from dflags+      = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $+          untag_Expr dflags tycon [(a_RDR, ah_RDR)] $+          nlHsApps map_RDR+                [nlHsVar (tag2con_RDR dflags tycon),+                 nlHsPar (enum_from_to_Expr+                            (nlHsVarApps intDataCon_RDR [ah_RDR])+                            (nlHsVar (maxtag_RDR dflags tycon)))]++    enum_from_then dflags+      = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $+          untag_Expr dflags tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $+          nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $+            nlHsPar (enum_from_then_to_Expr+                    (nlHsVarApps intDataCon_RDR [ah_RDR])+                    (nlHsVarApps intDataCon_RDR [bh_RDR])+                    (nlHsIf  (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],+                                               nlHsVarApps intDataCon_RDR [bh_RDR]])+                           (nlHsIntLit 0)+                           (nlHsVar (maxtag_RDR dflags tycon))+                           ))++    from_enum dflags+      = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $+          untag_Expr dflags tycon [(a_RDR, ah_RDR)] $+          (nlHsVarApps intDataCon_RDR [ah_RDR])++{-+************************************************************************+*                                                                      *+        Bounded instances+*                                                                      *+************************************************************************+-}++gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)+gen_Bounded_binds loc tycon+  | isEnumerationTyCon tycon+  = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)+  | otherwise+  = ASSERT(isSingleton data_cons)+    (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)+  where+    data_cons = tyConDataCons tycon++    ----- enum-flavored: ---------------------------+    min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)+    max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)++    data_con_1     = head data_cons+    data_con_N     = last data_cons+    data_con_1_RDR = getRdrName data_con_1+    data_con_N_RDR = getRdrName data_con_N++    ----- single-constructor-flavored: -------------+    arity          = dataConSourceArity data_con_1++    min_bound_1con = mkHsVarBind loc minBound_RDR $+                     nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)+    max_bound_1con = mkHsVarBind loc maxBound_RDR $+                     nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)++{-+************************************************************************+*                                                                      *+        Ix instances+*                                                                      *+************************************************************************++Deriving @Ix@ is only possible for enumeration types and+single-constructor types.  We deal with them in turn.++For an enumeration type, e.g.,+\begin{verbatim}+    data Foo ... = N1 | N2 | ... | Nn+\end{verbatim}+things go not too differently from @Enum@:+\begin{verbatim}+instance ... Ix (Foo ...) where+    range (a, b)+      = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]++    -- or, really...+    range (a, b)+      = case (con2tag_Foo a) of { a# ->+        case (con2tag_Foo b) of { b# ->+        map tag2con_Foo (enumFromTo (I# a#) (I# b#))+        }}++    -- Generate code for unsafeIndex, because using index leads+    -- to lots of redundant range tests+    unsafeIndex c@(a, b) d+      = case (con2tag_Foo d -# con2tag_Foo a) of+               r# -> I# r#++    inRange (a, b) c+      = let+            p_tag = con2tag_Foo c+        in+        p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b++    -- or, really...+    inRange (a, b) c+      = case (con2tag_Foo a)   of { a_tag ->+        case (con2tag_Foo b)   of { b_tag ->+        case (con2tag_Foo c)   of { c_tag ->+        if (c_tag >=# a_tag) then+          c_tag <=# b_tag+        else+          False+        }}}+\end{verbatim}+(modulo suitable case-ification to handle the unlifted tags)++For a single-constructor type (NB: this includes all tuples), e.g.,+\begin{verbatim}+    data Foo ... = MkFoo a b Int Double c c+\end{verbatim}+we follow the scheme given in Figure~19 of the Haskell~1.2 report+(p.~147).+-}++gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff)++gen_Ix_binds loc tycon = do+    dflags <- getDynFlags+    return $ if isEnumerationTyCon tycon+      then (enum_ixes dflags, listToBag $ map DerivAuxBind+                   [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])+      else (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))+  where+    --------------------------------------------------------------+    enum_ixes dflags = listToBag+      [ enum_range   dflags+      , enum_index   dflags+      , enum_inRange dflags+      ]++    enum_range dflags+      = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $+          untag_Expr dflags tycon [(a_RDR, ah_RDR)] $+          untag_Expr dflags tycon [(b_RDR, bh_RDR)] $+          nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $+              nlHsPar (enum_from_to_Expr+                        (nlHsVarApps intDataCon_RDR [ah_RDR])+                        (nlHsVarApps intDataCon_RDR [bh_RDR]))++    enum_index dflags+      = mk_easy_FunBind loc unsafeIndex_RDR+                [noLoc (AsPat (noLoc c_RDR)+                           (nlTuplePat [a_Pat, nlWildPat] Boxed)),+                                d_Pat] (+           untag_Expr dflags tycon [(a_RDR, ah_RDR)] (+           untag_Expr dflags tycon [(d_RDR, dh_RDR)] (+           let+                rhs = nlHsVarApps intDataCon_RDR [c_RDR]+           in+           nlHsCase+             (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))+             [mkHsCaseAlt (nlVarPat c_RDR) rhs]+           ))+        )++    -- This produces something like `(ch >= ah) && (ch <= bh)`+    enum_inRange dflags+      = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $+          untag_Expr dflags tycon [(a_RDR, ah_RDR)] (+          untag_Expr dflags tycon [(b_RDR, bh_RDR)] (+          untag_Expr dflags tycon [(c_RDR, ch_RDR)] (+          -- This used to use `if`, which interacts badly with RebindableSyntax.+          -- See #11396.+          nlHsApps and_RDR+              [ genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)+              , genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR)+              ]+          )))++    --------------------------------------------------------------+    single_con_ixes+      = listToBag [single_con_range, single_con_index, single_con_inRange]++    data_con+      = case tyConSingleDataCon_maybe tycon of -- just checking...+          Nothing -> panic "get_Ix_binds"+          Just dc -> dc++    con_arity    = dataConSourceArity data_con+    data_con_RDR = getRdrName data_con++    as_needed = take con_arity as_RDRs+    bs_needed = take con_arity bs_RDRs+    cs_needed = take con_arity cs_RDRs++    con_pat  xs  = nlConVarPat data_con_RDR xs+    con_expr     = nlHsVarApps data_con_RDR cs_needed++    --------------------------------------------------------------+    single_con_range+      = mk_easy_FunBind loc range_RDR+          [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $+        noLoc (mkHsComp ListComp stmts con_expr)+      where+        stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed++        mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)+                                 (nlHsApp (nlHsVar range_RDR)+                                          (mkLHsVarTuple [a,b]))++    ----------------+    single_con_index+      = mk_easy_FunBind loc unsafeIndex_RDR+                [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,+                 con_pat cs_needed]+        -- We need to reverse the order we consider the components in+        -- so that+        --     range (l,u) !! index (l,u) i == i   -- when i is in range+        -- (from http://haskell.org/onlinereport/ix.html) holds.+                (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))+      where+        -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)+        mk_index []        = nlHsIntLit 0+        mk_index [(l,u,i)] = mk_one l u i+        mk_index ((l,u,i) : rest)+          = genOpApp (+                mk_one l u i+            ) plus_RDR (+                genOpApp (+                    (nlHsApp (nlHsVar unsafeRangeSize_RDR)+                             (mkLHsVarTuple [l,u]))+                ) times_RDR (mk_index rest)+           )+        mk_one l u i+          = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i]++    ------------------+    single_con_inRange+      = mk_easy_FunBind loc inRange_RDR+                [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,+                 con_pat cs_needed] $+          if con_arity == 0+             -- If the product type has no fields, inRange is trivially true+             -- (see Trac #12853).+             then true_Expr+             else foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range+                    as_needed bs_needed cs_needed)+      where+        in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]++{-+************************************************************************+*                                                                      *+        Read instances+*                                                                      *+************************************************************************++Example++  infix 4 %%+  data T = Int %% Int+         | T1 { f1 :: Int }+         | T2 T++instance Read T where+  readPrec =+    parens+    ( prec 4 (+        do x <- ReadP.step Read.readPrec+           expectP (Symbol "%%")+           y <- ReadP.step Read.readPrec+           return (x %% y))+      ++++      prec (appPrec+1) (+        -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok+        -- Record construction binds even more tightly than application+        do expectP (Ident "T1")+           expectP (Punc '{')+           expectP (Ident "f1")+           expectP (Punc '=')+           x          <- ReadP.reset Read.readPrec+           expectP (Punc '}')+           return (T1 { f1 = x }))+      ++++      prec appPrec (+        do expectP (Ident "T2")+           x <- ReadP.step Read.readPrec+           return (T2 x))+    )++  readListPrec = readListPrecDefault+  readList     = readListDefault+++Note [Use expectP]+~~~~~~~~~~~~~~~~~~+Note that we use+   expectP (Ident "T1")+rather than+   Ident "T1" <- lexP+The latter desugares to inline code for matching the Ident and the+string, and this can be very voluminous. The former is much more+compact.  Cf Trac #7258, although that also concerned non-linearity in+the occurrence analyser, a separate issue.++Note [Read for empty data types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What should we get for this?  (Trac #7931)+   data Emp deriving( Read )   -- No data constructors++Here we want+  read "[]" :: [Emp]   to succeed, returning []+So we do NOT want+   instance Read Emp where+     readPrec = error "urk"+Rather we want+   instance Read Emp where+     readPred = pfail   -- Same as choose []++Because 'pfail' allows the parser to backtrack, but 'error' doesn't.+These instances are also useful for Read (Either Int Emp), where+we want to be able to parse (Left 3) just fine.+-}++gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)++gen_Read_binds get_fixity loc tycon+  = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)+  where+    -----------------------------------------------------------------------+    default_readlist+        = mkHsVarBind loc readList_RDR     (nlHsVar readListDefault_RDR)++    default_readlistprec+        = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)+    -----------------------------------------------------------------------++    data_cons = tyConDataCons tycon+    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons++    read_prec = mkHsVarBind loc readPrec_RDR+                              (nlHsApp (nlHsVar parens_RDR) read_cons)++    read_cons | null data_cons = nlHsVar pfail_RDR  -- See Note [Read for empty data types]+              | otherwise      = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)+    read_non_nullary_cons = map read_non_nullary_con non_nullary_cons++    read_nullary_cons+      = case nullary_cons of+            []    -> []+            [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])]+            _     -> [nlHsApp (nlHsVar choose_RDR)+                              (nlList (map mk_pair nullary_cons))]+        -- NB For operators the parens around (:=:) are matched by the+        -- enclosing "parens" call, so here we must match the naked+        -- data_con_str con++    match_con con | isSym con_str = [symbol_pat con_str]+                  | otherwise     = ident_h_pat  con_str+                  where+                    con_str = data_con_str con+        -- For nullary constructors we must match Ident s for normal constrs+        -- and   Symbol s   for operators++    mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)),+                                  result_expr con []]++    read_non_nullary_con data_con+      | is_infix  = mk_parser infix_prec  infix_stmts  body+      | is_record = mk_parser record_prec record_stmts body+--              Using these two lines instead allows the derived+--              read for infix and record bindings to read the prefix form+--      | is_infix  = mk_alt prefix_parser (mk_parser infix_prec  infix_stmts  body)+--      | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)+      | otherwise = prefix_parser+      where+        body = result_expr data_con as_needed+        con_str = data_con_str data_con++        prefix_parser = mk_parser prefix_prec prefix_stmts body++        read_prefix_con+            | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"]+            | otherwise     = ident_h_pat con_str++        read_infix_con+            | isSym con_str = [symbol_pat con_str]+            | otherwise     = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"]++        prefix_stmts            -- T a b c+          = read_prefix_con ++ read_args++        infix_stmts             -- a %% b, or  a `T` b+          = [read_a1]+            ++ read_infix_con+            ++ [read_a2]++        record_stmts            -- T { f1 = a, f2 = b }+          = read_prefix_con+            ++ [read_punc "{"]+            ++ concat (intersperse [read_punc ","] field_stmts)+            ++ [read_punc "}"]++        field_stmts  = zipWithEqual "lbl_stmts" read_field labels as_needed++        con_arity    = dataConSourceArity data_con+        labels       = map flLabel $ dataConFieldLabels data_con+        dc_nm        = getName data_con+        is_infix     = dataConIsInfix data_con+        is_record    = length labels > 0+        as_needed    = take con_arity as_RDRs+        read_args    = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)+        (read_a1:read_a2:_) = read_args++        prefix_prec = appPrecedence+        infix_prec  = getPrecedence get_fixity dc_nm+        record_prec = appPrecedence + 1 -- Record construction binds even more tightly+                                        -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})++    ------------------------------------------------------------------------+    --          Helpers+    ------------------------------------------------------------------------+    mk_alt e1 e2       = genOpApp e1 alt_RDR e2                         -- e1 +++ e2+    mk_parser p ss b   = nlHsApps prec_RDR [nlHsIntLit p                -- prec p (do { ss ; b })+                                           , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])]+    con_app con as     = nlHsVarApps (getRdrName con) as                -- con as+    result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)++    -- For constructors and field labels ending in '#', we hackily+    -- let the lexer generate two tokens, and look for both in sequence+    -- Thus [Ident "I"; Symbol "#"].  See Trac #5041+    ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ]+                  | otherwise                    = [ ident_pat s ]++    bindLex pat  = noLoc (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat))  -- expectP p+                   -- See Note [Use expectP]+    ident_pat  s = bindLex $ nlHsApps ident_RDR  [nlHsLit (mkHsString s)]  -- expectP (Ident "foo")+    symbol_pat s = bindLex $ nlHsApps symbol_RDR [nlHsLit (mkHsString s)]  -- expectP (Symbol ">>")+    read_punc c  = bindLex $ nlHsApps punc_RDR   [nlHsLit (mkHsString c)]  -- expectP (Punc "<")++    data_con_str con = occNameString (getOccName con)++    read_arg a ty = ASSERT( not (isUnliftedType ty) )+                    noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))++    read_field lbl a = read_lbl lbl +++                       [read_punc "=",+                        noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]++        -- When reading field labels we might encounter+        --      a  = 3+        --      _a = 3+        -- or   (#) = 4+        -- Note the parens!+    read_lbl lbl | isSym lbl_str+                 = [read_punc "(", symbol_pat lbl_str, read_punc ")"]+                 | otherwise+                 = ident_h_pat lbl_str+                 where+                   lbl_str = unpackFS lbl++{-+************************************************************************+*                                                                      *+        Show instances+*                                                                      *+************************************************************************++Example++    infixr 5 :^:++    data Tree a =  Leaf a  |  Tree a :^: Tree a++    instance (Show a) => Show (Tree a) where++        showsPrec d (Leaf m) = showParen (d > app_prec) showStr+          where+             showStr = showString "Leaf " . showsPrec (app_prec+1) m++        showsPrec d (u :^: v) = showParen (d > up_prec) showStr+          where+             showStr = showsPrec (up_prec+1) u .+                       showString " :^: "      .+                       showsPrec (up_prec+1) v+                -- Note: right-associativity of :^: ignored++    up_prec  = 5    -- Precedence of :^:+    app_prec = 10   -- Application has precedence one more than+                    -- the most tightly-binding operator+-}++gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)++gen_Show_binds get_fixity loc tycon+  = (listToBag [shows_prec, show_list], emptyBag)+  where+    -----------------------------------------------------------------------+    show_list = mkHsVarBind loc showList_RDR+                  (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))+    -----------------------------------------------------------------------+    data_cons = tyConDataCons tycon+    shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc data_cons)+    comma_space = nlHsVar showCommaSpace_RDR++    pats_etc data_con+      | nullary_con =  -- skip the showParen junk...+         ASSERT(null bs_needed)+         ([nlWildPat, con_pat], mk_showString_app op_con_str)+      | otherwise   =+         ([a_Pat, con_pat],+          showParen_Expr (genOpApp a_Expr ge_RDR+                              (nlHsLit (HsInt NoSourceText con_prec_plus_one)))+                         (nlHsPar (nested_compose_Expr show_thingies)))+        where+             data_con_RDR  = getRdrName data_con+             con_arity     = dataConSourceArity data_con+             bs_needed     = take con_arity bs_RDRs+             arg_tys       = dataConOrigArgTys data_con         -- Correspond 1-1 with bs_needed+             con_pat       = nlConVarPat data_con_RDR bs_needed+             nullary_con   = con_arity == 0+             labels        = map flLabel $ dataConFieldLabels data_con+             lab_fields    = length labels+             record_syntax = lab_fields > 0++             dc_nm          = getName data_con+             dc_occ_nm      = getOccName data_con+             con_str        = occNameString dc_occ_nm+             op_con_str     = wrapOpParens con_str+             backquote_str  = wrapOpBackquotes con_str++             show_thingies+                | is_infix      = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]+                | record_syntax = mk_showString_app (op_con_str ++ " {") :+                                  show_record_args ++ [mk_showString_app "}"]+                | otherwise     = mk_showString_app (op_con_str ++ " ") : show_prefix_args++             show_label l = mk_showString_app (nm ++ " = ")+                        -- Note the spaces around the "=" sign.  If we+                        -- don't have them then we get Foo { x=-1 } and+                        -- the "=-" parses as a single lexeme.  Only the+                        -- space after the '=' is necessary, but it+                        -- seems tidier to have them both sides.+                 where+                   nm       = wrapOpParens (unpackFS l)++             show_args               = zipWith show_arg bs_needed arg_tys+             (show_arg1:show_arg2:_) = show_args+             show_prefix_args        = intersperse (nlHsVar showSpace_RDR) show_args++                -- Assumption for record syntax: no of fields == no of+                -- labelled fields (and in same order)+             show_record_args = concat $+                                intersperse [comma_space] $+                                [ [show_label lbl, arg]+                                | (lbl,arg) <- zipEqual "gen_Show_binds"+                                                        labels show_args ]++             show_arg :: RdrName -> Type -> LHsExpr RdrName+             show_arg b arg_ty+               | isUnliftedType arg_ty+               -- See Note [Deriving and unboxed types] in TcDeriv+               = nlHsApps compose_RDR [mk_shows_app boxed_arg,+                                       mk_showString_app postfixMod]+               | otherwise+               = mk_showsPrec_app arg_prec arg+                 where+                   arg        = nlHsVar b+                   boxed_arg  = box "Show" tycon arg arg_ty+                   postfixMod = assoc_ty_id "Show" tycon postfixModTbl arg_ty++                -- Fixity stuff+             is_infix = dataConIsInfix data_con+             con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm+             arg_prec | record_syntax = 0  -- Record fields don't need parens+                      | otherwise     = con_prec_plus_one++wrapOpParens :: String -> String+wrapOpParens s | isSym s   = '(' : s ++ ")"+               | otherwise = s++wrapOpBackquotes :: String -> String+wrapOpBackquotes s | isSym s   = s+                   | otherwise = '`' : s ++ "`"++isSym :: String -> Bool+isSym ""      = False+isSym (c : _) = startsVarSym c || startsConSym c++-- | showString :: String -> ShowS+mk_showString_app :: String -> LHsExpr RdrName+mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))++-- | showsPrec :: Show a => Int -> a -> ShowS+mk_showsPrec_app :: Integer -> LHsExpr RdrName -> LHsExpr RdrName+mk_showsPrec_app p x+  = nlHsApps showsPrec_RDR [nlHsLit (HsInt NoSourceText p), x]++-- | shows :: Show a => a -> ShowS+mk_shows_app :: LHsExpr RdrName -> LHsExpr RdrName+mk_shows_app x = nlHsApp (nlHsVar shows_RDR) x++getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer+getPrec is_infix get_fixity nm+  | not is_infix   = appPrecedence+  | otherwise      = getPrecedence get_fixity nm++appPrecedence :: Integer+appPrecedence = fromIntegral maxPrecedence + 1+  -- One more than the precedence of the most+  -- tightly-binding operator++getPrecedence :: (Name -> Fixity) -> Name -> Integer+getPrecedence get_fixity nm+   = case get_fixity nm of+        Fixity _ x _assoc -> fromIntegral x+          -- NB: the Report says that associativity is not taken+          --     into account for either Read or Show; hence we+          --     ignore associativity here++{-+************************************************************************+*                                                                      *+        Data instances+*                                                                      *+************************************************************************++From the data type++  data T a b = T1 a b | T2++we generate++  $cT1 = mkDataCon $dT "T1" Prefix+  $cT2 = mkDataCon $dT "T2" Prefix+  $dT  = mkDataType "Module.T" [] [$con_T1, $con_T2]+  -- the [] is for field labels.++  instance (Data a, Data b) => Data (T a b) where+    gfoldl k z (T1 a b) = z T `k` a `k` b+    gfoldl k z T2           = z T2+    -- ToDo: add gmapT,Q,M, gfoldr++    gunfold k z c = case conIndex c of+                        I# 1# -> k (k (z T1))+                        I# 2# -> z T2++    toConstr (T1 _ _) = $cT1+    toConstr T2       = $cT2++    dataTypeOf _ = $dT++    dataCast1 = gcast1   -- If T :: * -> *+    dataCast2 = gcast2   -- if T :: * -> * -> *+-}++gen_Data_binds :: SrcSpan+               -> TyCon                 -- For data families, this is the+                                        --  *representation* TyCon+               -> TcM (LHsBinds RdrName,    -- The method bindings+                       BagDerivStuff)       -- Auxiliary bindings+gen_Data_binds loc rep_tc+  = do { dflags  <- getDynFlags++       -- Make unique names for the data type and constructor+       -- auxiliary bindings.  Start with the name of the TyCon/DataCon+       -- but that might not be unique: see Trac #12245.+       ; dt_occ  <- chooseUniqueOccTc (mkDataTOcc (getOccName rep_tc))+       ; dc_occs <- mapM (chooseUniqueOccTc . mkDataCOcc . getOccName)+                         (tyConDataCons rep_tc)+       ; let dt_rdr  = mkRdrUnqual dt_occ+             dc_rdrs = map mkRdrUnqual dc_occs++       -- OK, now do the work+       ; return (gen_data dflags dt_rdr dc_rdrs loc rep_tc) }++gen_data :: DynFlags -> RdrName -> [RdrName]+         -> SrcSpan -> TyCon+         -> (LHsBinds RdrName,    -- The method bindings+             BagDerivStuff)       -- Auxiliary bindings+gen_data dflags data_type_name constr_names loc rep_tc+  = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]+     `unionBags` gcast_binds,+                -- Auxiliary definitions: the data type and constructors+     listToBag ( genDataTyCon+               : zipWith genDataDataCon data_cons constr_names ) )+  where+    data_cons  = tyConDataCons rep_tc+    n_cons     = length data_cons+    one_constr = n_cons == 1+    genDataTyCon :: DerivStuff+    genDataTyCon        --  $dT+      = DerivHsBind (mkHsVarBind loc data_type_name rhs,+                     L loc (TypeSig [L loc data_type_name] sig_ty))++    sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR)+    rhs    = nlHsVar mkDataType_RDR+             `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc)))+             `nlHsApp` nlList (map nlHsVar constr_names)++    genDataDataCon :: DataCon -> RdrName -> DerivStuff+    genDataDataCon dc constr_name       --  $cT1 etc+      = DerivHsBind (mkHsVarBind loc constr_name rhs,+                     L loc (TypeSig [L loc constr_name] sig_ty))+      where+        sig_ty   = mkLHsSigWcType (nlHsTyVar constr_RDR)+        rhs      = nlHsApps mkConstr_RDR constr_args++        constr_args+           = [ -- nlHsIntLit (toInteger (dataConTag dc)),   -- Tag+               nlHsVar (data_type_name)                     -- DataType+             , nlHsLit (mkHsString (occNameString dc_occ))  -- String name+             , nlList  labels                               -- Field labels+             , nlHsVar fixity ]                             -- Fixity++        labels   = map (nlHsLit . mkHsString . unpackFS . flLabel)+                       (dataConFieldLabels dc)+        dc_occ   = getOccName dc+        is_infix = isDataSymOcc dc_occ+        fixity | is_infix  = infix_RDR+               | otherwise = prefix_RDR++        ------------ gfoldl+    gfoldl_bind = mk_HRFunBind 2 loc gfoldl_RDR (map gfoldl_eqn data_cons)++    gfoldl_eqn con+      = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],+                       foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)+                   where+                     con_name ::  RdrName+                     con_name = getRdrName con+                     as_needed = take (dataConSourceArity con) as_RDRs+                     mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))++        ------------ gunfold+    gunfold_bind = mk_HRFunBind 2 loc+                     gunfold_RDR+                     [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],+                       gunfold_rhs)]++    gunfold_rhs+        | one_constr = mk_unfold_rhs (head data_cons)   -- No need for case+        | otherwise  = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)+                                (map gunfold_alt data_cons)++    gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)+    mk_unfold_rhs dc = foldr nlHsApp+                           (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))+                           (replicate (dataConSourceArity dc) (nlHsVar k_RDR))++    mk_unfold_pat dc    -- Last one is a wild-pat, to avoid+                        -- redundant test, and annoying warning+      | tag-fIRST_TAG == n_cons-1 = nlWildPat   -- Last constructor+      | otherwise = nlConPat intDataCon_RDR+                             [nlLitPat (HsIntPrim NoSourceText (toInteger tag))]+      where+        tag = dataConTag dc++        ------------ toConstr+    toCon_bind = mk_FunBind loc toConstr_RDR (zipWith to_con_eqn data_cons constr_names)+    to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name)++        ------------ dataTypeOf+    dataTypeOf_bind = mk_easy_FunBind+                        loc+                        dataTypeOf_RDR+                        [nlWildPat]+                        (nlHsVar data_type_name)++        ------------ gcast1/2+        -- Make the binding    dataCast1 x = gcast1 x  -- if T :: * -> *+        --               or    dataCast2 x = gcast2 s  -- if T :: * -> * -> *+        -- (or nothing if T has neither of these two types)++        -- But care is needed for data families:+        -- If we have   data family D a+        --              data instance D (a,b,c) = A | B deriving( Data )+        -- and we want  instance ... => Data (D [(a,b,c)]) where ...+        -- then we need     dataCast1 x = gcast1 x+        -- because D :: * -> *+        -- even though rep_tc has kind * -> * -> * -> *+        -- Hence looking for the kind of fam_tc not rep_tc+        -- See Trac #4896+    tycon_kind = case tyConFamInst_maybe rep_tc of+                    Just (fam_tc, _) -> tyConKind fam_tc+                    Nothing          -> tyConKind rep_tc+    gcast_binds | tycon_kind `tcEqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR+                | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR+                | otherwise                 = emptyBag+    mk_gcast dataCast_RDR gcast_RDR+      = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]+                                 (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))+++kind1, kind2 :: Kind+kind1 = liftedTypeKind `mkFunTy` liftedTypeKind+kind2 = liftedTypeKind `mkFunTy` kind1++gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,+    mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,+    dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,+    constr_RDR, dataType_RDR,+    eqChar_RDR  , ltChar_RDR  , geChar_RDR  , gtChar_RDR  , leChar_RDR  ,+    eqInt_RDR   , ltInt_RDR   , geInt_RDR   , gtInt_RDR   , leInt_RDR   ,+    eqWord_RDR  , ltWord_RDR  , geWord_RDR  , gtWord_RDR  , leWord_RDR  ,+    eqAddr_RDR  , ltAddr_RDR  , geAddr_RDR  , gtAddr_RDR  , leAddr_RDR  ,+    eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,+    eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR :: RdrName+gfoldl_RDR     = varQual_RDR  gENERICS (fsLit "gfoldl")+gunfold_RDR    = varQual_RDR  gENERICS (fsLit "gunfold")+toConstr_RDR   = varQual_RDR  gENERICS (fsLit "toConstr")+dataTypeOf_RDR = varQual_RDR  gENERICS (fsLit "dataTypeOf")+dataCast1_RDR  = varQual_RDR  gENERICS (fsLit "dataCast1")+dataCast2_RDR  = varQual_RDR  gENERICS (fsLit "dataCast2")+gcast1_RDR     = varQual_RDR  tYPEABLE (fsLit "gcast1")+gcast2_RDR     = varQual_RDR  tYPEABLE (fsLit "gcast2")+mkConstr_RDR   = varQual_RDR  gENERICS (fsLit "mkConstr")+constr_RDR     = tcQual_RDR   gENERICS (fsLit "Constr")+mkDataType_RDR = varQual_RDR  gENERICS (fsLit "mkDataType")+dataType_RDR   = tcQual_RDR   gENERICS (fsLit "DataType")+conIndex_RDR   = varQual_RDR  gENERICS (fsLit "constrIndex")+prefix_RDR     = dataQual_RDR gENERICS (fsLit "Prefix")+infix_RDR      = dataQual_RDR gENERICS (fsLit "Infix")++eqChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqChar#")+ltChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltChar#")+leChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "leChar#")+gtChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtChar#")+geChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "geChar#")++eqInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "==#")+ltInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "<#" )+leInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "<=#")+gtInt_RDR      = varQual_RDR  gHC_PRIM (fsLit ">#" )+geInt_RDR      = varQual_RDR  gHC_PRIM (fsLit ">=#")++eqWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqWord#")+ltWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltWord#")+leWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "leWord#")+gtWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtWord#")+geWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "geWord#")++eqAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqAddr#")+ltAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltAddr#")+leAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "leAddr#")+gtAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtAddr#")+geAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "geAddr#")++eqFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "eqFloat#")+ltFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "ltFloat#")+leFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "leFloat#")+gtFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "gtFloat#")+geFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "geFloat#")++eqDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit "==##")+ltDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit "<##" )+leDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit "<=##")+gtDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit ">##" )+geDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit ">=##")++{-+************************************************************************+*                                                                      *+                        Lift instances+*                                                                      *+************************************************************************++Example:++    data Foo a = Foo a | a :^: a deriving Lift++    ==>++    instance (Lift a) => Lift (Foo a) where+        lift (Foo a)+          = appE+              (conE+                (mkNameG_d "package-name" "ModuleName" "Foo"))+              (lift a)+        lift (u :^: v)+          = infixApp+              (lift u)+              (conE+                (mkNameG_d "package-name" "ModuleName" ":^:"))+              (lift v)++Note that (mkNameG_d "package-name" "ModuleName" "Foo") is equivalent to what+'Foo would be when using the -XTemplateHaskell extension. To make sure that+-XDeriveLift can be used on stage-1 compilers, however, we explicitly invoke+makeG_d.+-}++gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)+gen_Lift_binds loc tycon+  | null data_cons = (unitBag (L loc $ mkFunBind (L loc lift_RDR)+                       [mkMatch (mkPrefixFunRhs (L loc lift_RDR))+                                        [nlWildPat] errorMsg_Expr+                                        (noLoc emptyLocalBinds)])+                     , emptyBag)+  | otherwise = (unitBag lift_bind, emptyBag)+  where+    errorMsg_Expr = nlHsVar error_RDR `nlHsApp` nlHsLit+        (mkHsString $ "Can't lift value of empty datatype " ++ tycon_str)++    lift_bind = mk_FunBind loc lift_RDR (map pats_etc data_cons)+    data_cons = tyConDataCons tycon+    tycon_str = occNameString . nameOccName . tyConName $ tycon++    pats_etc data_con+      = ([con_pat], lift_Expr)+       where+            con_pat      = nlConVarPat data_con_RDR as_needed+            data_con_RDR = getRdrName data_con+            con_arity    = dataConSourceArity data_con+            as_needed    = take con_arity as_RDRs+            lifted_as    = zipWithEqual "mk_lift_app" mk_lift_app+                             tys_needed as_needed+            tycon_name   = tyConName tycon+            is_infix     = dataConIsInfix data_con+            tys_needed   = dataConOrigArgTys data_con++            mk_lift_app ty a+              | not (isUnliftedType ty) = nlHsApp (nlHsVar lift_RDR)+                                                  (nlHsVar a)+              | otherwise = nlHsApp (nlHsVar litE_RDR)+                              (primLitOp (mkBoxExp (nlHsVar a)))+              where (primLitOp, mkBoxExp) = primLitOps "Lift" tycon ty++            pkg_name = unitIdString . moduleUnitId+                     . nameModule $ tycon_name+            mod_name = moduleNameString . moduleName . nameModule $ tycon_name+            con_name = occNameString . nameOccName . dataConName $ data_con++            conE_Expr = nlHsApp (nlHsVar conE_RDR)+                                (nlHsApps mkNameG_dRDR+                                  (map (nlHsLit . mkHsString)+                                    [pkg_name, mod_name, con_name]))++            lift_Expr+              | is_infix  = nlHsApps infixApp_RDR [a1, conE_Expr, a2]+              | otherwise = foldl mk_appE_app conE_Expr lifted_as+            (a1:a2:_) = lifted_as++mk_appE_app :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName+mk_appE_app a b = nlHsApps appE_RDR [a, b]++{-+************************************************************************+*                                                                      *+                     Newtype-deriving instances+*                                                                      *+************************************************************************++Note [Newtype-deriving instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We take every method in the original instance and `coerce` it to fit+into the derived instance. We need a type annotation on the argument+to `coerce` to make it obvious what instantiation of the method we're+coercing from.  So from, say,+  class C a b where+    op :: a -> [b] -> Int++  newtype T x = MkT <rep-ty>++  instance C a <rep-ty> => C a (T x) where+    op = coerce @ (a -> [<rep-ty>] -> Int)+                @ (a -> [T x]      -> Int)+                op++Notice that we give the 'coerce' two explicitly-visible type arguments+to say how it should be instantiated.  Recall++  coerce :: Coeercible a b => a -> b++By giving it explicit type arguments we deal with the case where+'op' has a higher rank type, and so we must instantiate 'coerce' with+a polytype.  E.g.+   class C a where op :: forall b. a -> b -> b+   newtype T x = MkT <rep-ty>+   instance C <rep-ty> => C (T x) where+     op = coerce @ (forall b. <rep-ty> -> b -> b)+                 @ (forall b. T x -> b -> b)+                op++The type checker checks this code, and it currently requires+-XImpredicativeTypes to permit that polymorphic type instantiation,+so we have to switch that flag on locally in TcDeriv.genInst.++See #8503 for more discussion.++Note [Newtype-deriving trickiness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (Trac #12768):+  class C a where { op :: D a => a -> a }++  instance C a  => C [a] where { op = opList }++  opList :: (C a, D [a]) => [a] -> [a]+  opList = ...++Now suppose we try GND on this:+  newtype N a = MkN [a] deriving( C )++The GND is expecting to get an implementation of op for N by+coercing opList, thus:++  instance C a => C (N a) where { op = opN }++  opN :: (C a, D (N a)) => N a -> N a+  opN = coerce @(D [a]   => [a] -> [a])+               @(D (N a) => [N a] -> [N a]+               opList++But there is no reason to suppose that (D [a]) and (D (N a))+are inter-coercible; these instances might completely different.+So GHC rightly rejects this code.+-}++gen_Newtype_binds :: SrcSpan+                  -> Class   -- the class being derived+                  -> [TyVar] -- the tvs in the instance head (this includes+                             -- the tvs from both the class types and the+                             -- newtype itself)+                  -> [Type]  -- instance head parameters (incl. newtype)+                  -> Type    -- the representation type+                  -> TcM (LHsBinds RdrName, BagDerivStuff)+-- See Note [Newtype-deriving instances]+gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty+  = do let ats = classATs cls+       atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats )+                    mapM mk_atf_inst ats+       return ( listToBag $ map mk_bind (classMethods cls)+              , listToBag $ map DerivFamInst atf_insts )+  where+    coerce_RDR = getRdrName coerceId++    mk_bind :: Id -> LHsBind RdrName+    mk_bind meth_id+      = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch+                                          (mkPrefixFunRhs (L loc meth_RDR))+                                          [] rhs_expr]+      where+        Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id++        meth_RDR = getRdrName meth_id++        rhs_expr = nlHsVar coerce_RDR `nlHsAppType` from_ty+                                      `nlHsAppType` to_ty+                                      `nlHsApp`     nlHsVar meth_RDR++    mk_atf_inst :: TyCon -> TcM FamInst+    mk_atf_inst fam_tc = do+        rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc))+                                           rep_lhs_tys+        let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' rep_cvs'+                                    fam_tc rep_lhs_tys rep_rhs_ty+        -- Check (c) from Note [GND and associated type families] in TcDeriv+        checkValidTyFamEqn (Just (cls, cls_tvs, lhs_env)) fam_tc rep_tvs'+                           rep_cvs' rep_lhs_tys rep_rhs_ty loc+        newFamInst SynFamilyInst axiom+      where+        cls_tvs     = classTyVars cls+        in_scope    = mkInScopeSet $ mkVarSet inst_tvs+        lhs_env     = zipTyEnv cls_tvs inst_tys+        lhs_subst   = mkTvSubst in_scope lhs_env+        rhs_env     = zipTyEnv cls_tvs $ changeLast inst_tys rhs_ty+        rhs_subst   = mkTvSubst in_scope rhs_env+        fam_tvs     = tyConTyVars fam_tc+        rep_lhs_tys = substTyVars lhs_subst fam_tvs+        rep_rhs_tys = substTyVars rhs_subst fam_tvs+        rep_rhs_ty  = mkTyConApp fam_tc rep_rhs_tys+        rep_tcvs    = tyCoVarsOfTypesList rep_lhs_tys+        (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs+        rep_tvs'    = toposortTyVars rep_tvs+        rep_cvs'    = toposortTyVars rep_cvs++nlHsAppType :: LHsExpr RdrName -> Type -> LHsExpr RdrName+nlHsAppType e s = noLoc (e `HsAppType` hs_ty)+  where+    hs_ty = mkHsWildCardBndrs $ nlHsParTy (typeToLHsType s)++nlExprWithTySig :: LHsExpr RdrName -> Type -> LHsExpr RdrName+nlExprWithTySig e s = noLoc (e `ExprWithTySig` hs_ty)+  where+    hs_ty = mkLHsSigWcType (typeToLHsType s)++mkCoerceClassMethEqn :: Class   -- the class being derived+                     -> [TyVar] -- the tvs in the instance head (this includes+                                -- the tvs from both the class types and the+                                -- newtype itself)+                     -> [Type]  -- instance head parameters (incl. newtype)+                     -> Type    -- the representation type+                     -> Id      -- the method to look at+                     -> Pair Type+-- See Note [Newtype-deriving instances]+-- See also Note [Newtype-deriving trickiness]+-- The pair is the (from_type, to_type), where to_type is+-- the type of the method we are tyrying to get+mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty id+  = Pair (substTy rhs_subst user_meth_ty)+         (substTy lhs_subst user_meth_ty)+  where+    cls_tvs = classTyVars cls+    in_scope = mkInScopeSet $ mkVarSet inst_tvs+    lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs inst_tys)+    rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast inst_tys rhs_ty))+    (_class_tvs, _class_constraint, user_meth_ty)+      = tcSplitMethodTy (varType id)++{-+************************************************************************+*                                                                      *+\subsection{Generating extra binds (@con2tag@ and @tag2con@)}+*                                                                      *+************************************************************************++\begin{verbatim}+data Foo ... = ...++con2tag_Foo :: Foo ... -> Int#+tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#+maxtag_Foo  :: Int              -- ditto (NB: not unlifted)+\end{verbatim}++The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)+fiddling around.+-}++genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec+                  -> (LHsBind RdrName, LSig RdrName)+genAuxBindSpec dflags loc (DerivCon2Tag tycon)+  = (mk_FunBind loc rdr_name eqns,+     L loc (TypeSig [L loc rdr_name] sig_ty))+  where+    rdr_name = con2tag_RDR dflags tycon++    sig_ty = mkLHsSigWcType $ L loc $ HsCoreTy $+             mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $+             mkParentType tycon `mkFunTy` intPrimTy++    lots_of_constructors = tyConFamilySize tycon > 8+                        -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS+                        -- but we don't do vectored returns any more.++    eqns | lots_of_constructors = [get_tag_eqn]+         | otherwise = map mk_eqn (tyConDataCons tycon)++    get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)++    mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName)+    mk_eqn con = ([nlWildConPat con],+                  nlHsLit (HsIntPrim NoSourceText+                                    (toInteger ((dataConTag con) - fIRST_TAG))))++genAuxBindSpec dflags loc (DerivTag2Con tycon)+  = (mk_FunBind loc rdr_name+        [([nlConVarPat intDataCon_RDR [a_RDR]],+           nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],+     L loc (TypeSig [L loc rdr_name] sig_ty))+  where+    sig_ty = mkLHsSigWcType $ L loc $+             HsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $+             intTy `mkFunTy` mkParentType tycon++    rdr_name = tag2con_RDR dflags tycon++genAuxBindSpec dflags loc (DerivMaxTag tycon)+  = (mkHsVarBind loc rdr_name rhs,+     L loc (TypeSig [L loc rdr_name] sig_ty))+  where+    rdr_name = maxtag_RDR dflags tycon+    sig_ty = mkLHsSigWcType (L loc (HsCoreTy intTy))+    rhs = nlHsApp (nlHsVar intDataCon_RDR)+                  (nlHsLit (HsIntPrim NoSourceText max_tag))+    max_tag =  case (tyConDataCons tycon) of+                 data_cons -> toInteger ((length data_cons) - fIRST_TAG)++type SeparateBagsDerivStuff =+  -- AuxBinds and SYB bindings+  ( Bag (LHsBind RdrName, LSig RdrName)+  -- Extra family instances (used by Generic and DeriveAnyClass)+  , Bag (FamInst) )++genAuxBinds :: DynFlags -> SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff+genAuxBinds dflags loc b = genAuxBinds' b2 where+  (b1,b2) = partitionBagWith splitDerivAuxBind b+  splitDerivAuxBind (DerivAuxBind x) = Left x+  splitDerivAuxBind  x               = Right x++  rm_dups = foldrBag dup_check emptyBag+  dup_check a b = if anyBag (== a) b then b else consBag a b++  genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff+  genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec dflags loc) (rm_dups b1)+                            , emptyBag )+  f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff+  f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before+  f (DerivHsBind  b) = add1 b+  f (DerivFamInst t) = add2 t++  add1 x (a,b) = (x `consBag` a,b)+  add2 x (a,b) = (a,x `consBag` b)++mkParentType :: TyCon -> Type+-- Turn the representation tycon of a family into+-- a use of its family constructor+mkParentType tc+  = case tyConFamInst_maybe tc of+       Nothing  -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))+       Just (fam_tc,tys) -> mkTyConApp fam_tc tys++{-+************************************************************************+*                                                                      *+\subsection{Utility bits for generating bindings}+*                                                                      *+************************************************************************+-}++mk_FunBind :: SrcSpan -> RdrName+           -> [([LPat RdrName], LHsExpr RdrName)]+           -> LHsBind RdrName+mk_FunBind = mk_HRFunBind 0   -- by using mk_FunBind and not mk_HRFunBind,+                              -- the caller says that the Void case needs no+                              -- patterns++-- | This variant of 'mk_FunBind' puts an 'Arity' number of wildcards before+-- the "=" in the empty-data-decl case. This is necessary if the function+-- has a higher-rank type, like foldl. (See deriving/should_compile/T4302)+mk_HRFunBind :: Arity -> SrcSpan -> RdrName+             -> [([LPat RdrName], LHsExpr RdrName)]+             -> LHsBind RdrName+mk_HRFunBind arity loc fun pats_and_exprs+  = mkHRRdrFunBind arity (L loc fun) matches+  where+    matches = [mkMatch (mkPrefixFunRhs (L loc fun)) p e+                               (noLoc emptyLocalBinds)+              | (p,e) <-pats_and_exprs]++mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName+mkRdrFunBind = mkHRRdrFunBind 0++mkHRRdrFunBind :: Arity -> Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName+mkHRRdrFunBind arity fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')+ where+   -- Catch-all eqn looks like+   --     fmap = error "Void fmap"+   -- It's needed if there no data cons at all,+   -- which can happen with -XEmptyDataDecls+   -- See Trac #4302+   matches' = if null matches+              then [mkMatch (mkPrefixFunRhs fun)+                            (replicate arity nlWildPat)+                            (error_Expr str) (noLoc emptyLocalBinds)]+              else matches+   str = "Void " ++ occNameString (rdrNameOcc fun_rdr)++box ::         String           -- The class involved+            -> TyCon            -- The tycon involved+            -> LHsExpr RdrName  -- The argument+            -> Type             -- The argument type+            -> LHsExpr RdrName  -- Boxed version of the arg+-- See Note [Deriving and unboxed types] in TcDeriv+box cls_str tycon arg arg_ty = nlHsApp (nlHsVar box_con) arg+  where+    box_con = assoc_ty_id cls_str tycon boxConTbl arg_ty++---------------------+primOrdOps :: String    -- The class involved+           -> TyCon     -- The tycon involved+           -> Type      -- The type+           -> (RdrName, RdrName, RdrName, RdrName, RdrName)  -- (lt,le,eq,ge,gt)+-- See Note [Deriving and unboxed types] in TcDeriv+primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty++primLitOps :: String -- The class involved+           -> TyCon  -- The tycon involved+           -> Type   -- The type+           -> ( LHsExpr RdrName -> LHsExpr RdrName -- Constructs a Q Exp value+              , LHsExpr RdrName -> LHsExpr RdrName -- Constructs a boxed value+              )+primLitOps str tycon ty = ( assoc_ty_id str tycon litConTbl ty+                          , \v -> nlHsVar boxRDR `nlHsApp` v+                          )+  where+    boxRDR+      | ty `eqType` addrPrimTy = unpackCString_RDR+      | otherwise = assoc_ty_id str tycon boxConTbl ty++ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]+ordOpTbl+ =  [(charPrimTy  , (ltChar_RDR  , leChar_RDR  , eqChar_RDR  , geChar_RDR  , gtChar_RDR  ))+    ,(intPrimTy   , (ltInt_RDR   , leInt_RDR   , eqInt_RDR   , geInt_RDR   , gtInt_RDR   ))+    ,(wordPrimTy  , (ltWord_RDR  , leWord_RDR  , eqWord_RDR  , geWord_RDR  , gtWord_RDR  ))+    ,(addrPrimTy  , (ltAddr_RDR  , leAddr_RDR  , eqAddr_RDR  , geAddr_RDR  , gtAddr_RDR  ))+    ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR , eqFloat_RDR , geFloat_RDR , gtFloat_RDR ))+    ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR, eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ]++boxConTbl :: [(Type, RdrName)]+boxConTbl+  = [(charPrimTy  , getRdrName charDataCon  )+    ,(intPrimTy   , getRdrName intDataCon   )+    ,(wordPrimTy  , getRdrName wordDataCon  )+    ,(floatPrimTy , getRdrName floatDataCon )+    ,(doublePrimTy, getRdrName doubleDataCon)+    ]++-- | A table of postfix modifiers for unboxed values.+postfixModTbl :: [(Type, String)]+postfixModTbl+  = [(charPrimTy  , "#" )+    ,(intPrimTy   , "#" )+    ,(wordPrimTy  , "##")+    ,(floatPrimTy , "#" )+    ,(doublePrimTy, "##")+    ]++litConTbl :: [(Type, LHsExpr RdrName -> LHsExpr RdrName)]+litConTbl+  = [(charPrimTy  , nlHsApp (nlHsVar charPrimL_RDR))+    ,(intPrimTy   , nlHsApp (nlHsVar intPrimL_RDR)+                      . nlHsApp (nlHsVar toInteger_RDR))+    ,(wordPrimTy  , nlHsApp (nlHsVar wordPrimL_RDR)+                      . nlHsApp (nlHsVar toInteger_RDR))+    ,(addrPrimTy  , nlHsApp (nlHsVar stringPrimL_RDR)+                      . nlHsApp (nlHsApp+                          (nlHsVar map_RDR)+                          (compose_RDR `nlHsApps`+                            [ nlHsVar fromIntegral_RDR+                            , nlHsVar fromEnum_RDR+                            ])))+    ,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR)+                      . nlHsApp (nlHsVar toRational_RDR))+    ,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR)+                      . nlHsApp (nlHsVar toRational_RDR))+    ]++-- | Lookup `Type` in an association list.+assoc_ty_id :: String           -- The class involved+            -> TyCon            -- The tycon involved+            -> [(Type,a)]       -- The table+            -> Type             -- The type+            -> a                -- The result of the lookup+assoc_ty_id cls_str _ tbl ty+  | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>+                                              text "for primitive type" <+> ppr ty)+  | otherwise = head res+  where+    res = [id | (ty',id) <- tbl, ty `eqType` ty']++-----------------------------------------------------------------------++and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName+and_Expr a b = genOpApp a and_RDR    b++-----------------------------------------------------------------------++eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName+eq_Expr tycon ty a b+    | not (isUnliftedType ty) = genOpApp a eq_RDR b+    | otherwise               = genPrimOpApp a prim_eq b+ where+   (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty++untag_Expr :: DynFlags -> TyCon -> [( RdrName,  RdrName)]+              -> LHsExpr RdrName -> LHsExpr RdrName+untag_Expr _ _ [] expr = expr+untag_Expr dflags tycon ((untag_this, put_tag_here) : more) expr+  = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR dflags tycon)+                                   [untag_this])) {-of-}+      [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr dflags tycon more expr)]++enum_from_to_Expr+        :: LHsExpr RdrName -> LHsExpr RdrName+        -> LHsExpr RdrName+enum_from_then_to_Expr+        :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName+        -> LHsExpr RdrName++enum_from_to_Expr      f   t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2+enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2++showParen_Expr+        :: LHsExpr RdrName -> LHsExpr RdrName+        -> LHsExpr RdrName++showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2++nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName++nested_compose_Expr []  = panic "nested_compose_expr"   -- Arg is always non-empty+nested_compose_Expr [e] = parenify e+nested_compose_Expr (e:es)+  = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)++-- impossible_Expr is used in case RHSs that should never happen.+-- We generate these to keep the desugarer from complaining that they *might* happen!+error_Expr :: String -> LHsExpr RdrName+error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))++-- illegal_Expr is used when signalling error conditions in the RHS of a derived+-- method. It is currently only used by Enum.{succ,pred}+illegal_Expr :: String -> String -> String -> LHsExpr RdrName+illegal_Expr meth tp msg =+   nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))++-- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you+-- to include the value of a_RDR in the error string.+illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName+illegal_toEnum_tag tp maxtag =+   nlHsApp (nlHsVar error_RDR)+           (nlHsApp (nlHsApp (nlHsVar append_RDR)+                       (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))+                    (nlHsApp (nlHsApp (nlHsApp+                           (nlHsVar showsPrec_RDR)+                           (nlHsIntLit 0))+                           (nlHsVar a_RDR))+                           (nlHsApp (nlHsApp+                               (nlHsVar append_RDR)+                               (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))+                               (nlHsApp (nlHsApp (nlHsApp+                                        (nlHsVar showsPrec_RDR)+                                        (nlHsIntLit 0))+                                        (nlHsVar maxtag))+                                        (nlHsLit (mkHsString ")"))))))++parenify :: LHsExpr RdrName -> LHsExpr RdrName+parenify e@(L _ (HsVar _)) = e+parenify e                 = mkHsPar e++-- genOpApp wraps brackets round the operator application, so that the+-- renamer won't subsequently try to re-associate it.+genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName+genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)++genPrimOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName+genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2))++a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR+    :: RdrName+a_RDR           = mkVarUnqual (fsLit "a")+b_RDR           = mkVarUnqual (fsLit "b")+c_RDR           = mkVarUnqual (fsLit "c")+d_RDR           = mkVarUnqual (fsLit "d")+f_RDR           = mkVarUnqual (fsLit "f")+k_RDR           = mkVarUnqual (fsLit "k")+z_RDR           = mkVarUnqual (fsLit "z")+ah_RDR          = mkVarUnqual (fsLit "a#")+bh_RDR          = mkVarUnqual (fsLit "b#")+ch_RDR          = mkVarUnqual (fsLit "c#")+dh_RDR          = mkVarUnqual (fsLit "d#")++as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]+as_RDRs         = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]+bs_RDRs         = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]+cs_RDRs         = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]++a_Expr, b_Expr, c_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr,+    true_Expr :: LHsExpr RdrName+a_Expr          = nlHsVar a_RDR+b_Expr          = nlHsVar b_RDR+c_Expr          = nlHsVar c_RDR+ltTag_Expr      = nlHsVar ltTag_RDR+eqTag_Expr      = nlHsVar eqTag_RDR+gtTag_Expr      = nlHsVar gtTag_RDR+false_Expr      = nlHsVar false_RDR+true_Expr       = nlHsVar true_RDR++a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat RdrName+a_Pat           = nlVarPat a_RDR+b_Pat           = nlVarPat b_RDR+c_Pat           = nlVarPat c_RDR+d_Pat           = nlVarPat d_RDR+k_Pat           = nlVarPat k_RDR+z_Pat           = nlVarPat z_RDR++minusInt_RDR, tagToEnum_RDR :: RdrName+minusInt_RDR  = getRdrName (primOpId IntSubOp   )+tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)++con2tag_RDR, tag2con_RDR, maxtag_RDR :: DynFlags -> TyCon -> RdrName+-- Generates Orig s RdrName, for the binding positions+con2tag_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkCon2TagOcc+tag2con_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkTag2ConOcc+maxtag_RDR  dflags tycon = mk_tc_deriv_name dflags tycon mkMaxTagOcc++mk_tc_deriv_name :: DynFlags -> TyCon -> (OccName -> OccName) -> RdrName+mk_tc_deriv_name dflags tycon occ_fun =+   mkAuxBinderName dflags (tyConName tycon) occ_fun++mkAuxBinderName :: DynFlags -> Name -> (OccName -> OccName) -> RdrName+-- ^ Make a top-level binder name for an auxiliary binding for a parent name+-- See Note [Auxiliary binders]+mkAuxBinderName dflags parent occ_fun+  = mkRdrUnqual (occ_fun stable_parent_occ)+  where+    stable_parent_occ = mkOccName (occNameSpace parent_occ) stable_string+    stable_string+      | hasPprDebug dflags = parent_stable+      | otherwise          = parent_stable_hash+    parent_stable = nameStableString parent+    parent_stable_hash =+      let Fingerprint high low = fingerprintString parent_stable+      in toBase62 high ++ toBase62Padded low+      -- See Note [Base 62 encoding 128-bit integers] in Encoding+    parent_occ  = nameOccName parent+++{-+Note [Auxiliary binders]+~~~~~~~~~~~~~~~~~~~~~~~~+We often want to make a top-level auxiliary binding.  E.g. for comparison we haev++  instance Ord T where+    compare a b = $con2tag a `compare` $con2tag b++  $con2tag :: T -> Int+  $con2tag = ...code....++Of course these top-level bindings should all have distinct name, and we are+generating RdrNames here.  We can't just use the TyCon or DataCon to distinguish+because with standalone deriving two imported TyCons might both be called T!+(See Trac #7947.)++So we use package name, module name and the name of the parent+(T in this example) as part of the OccName we generate for the new binding.+To make the symbol names short we take a base62 hash of the full name.++In the past we used the *unique* from the parent, but that's not stable across+recompilations as uniques are nondeterministic.+-}
+ typecheck/TcGenFunctor.hs view
@@ -0,0 +1,1023 @@+{-+(c) The University of Glasgow 2011+++The deriving code for the Functor, Foldable, and Traversable classes+(equivalent to the code in TcGenDeriv, for other classes)+-}++{-# LANGUAGE ScopedTypeVariables #-}++module TcGenFunctor (+        FFoldType(..), functorLikeTraverse,+        deepSubtypesContaining, foldDataConArgs,++        gen_Functor_binds, gen_Foldable_binds, gen_Traversable_binds+    ) where++import Bag+import DataCon+import FastString+import HsSyn+import Panic+import PrelNames+import RdrName+import SrcLoc+import State+import TcGenDeriv+import TcType+import TyCon+import TyCoRep+import Type+import Util+import Var+import VarSet++import Data.Maybe (catMaybes, isJust)++{-+************************************************************************+*                                                                      *+                        Functor instances++ see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html++*                                                                      *+************************************************************************++For the data type:++  data T a = T1 Int a | T2 (T a)++We generate the instance:++  instance Functor T where+      fmap f (T1 b1 a) = T1 b1 (f a)+      fmap f (T2 ta)   = T2 (fmap f ta)++Notice that we don't simply apply 'fmap' to the constructor arguments.+Rather+  - Do nothing to an argument whose type doesn't mention 'a'+  - Apply 'f' to an argument of type 'a'+  - Apply 'fmap f' to other arguments+That's why we have to recurse deeply into the constructor argument types,+rather than just one level, as we typically do.++What about types with more than one type parameter?  In general, we only+derive Functor for the last position:++  data S a b = S1 [b] | S2 (a, T a b)+  instance Functor (S a) where+    fmap f (S1 bs)    = S1 (fmap f bs)+    fmap f (S2 (p,q)) = S2 (a, fmap f q)++However, we have special cases for+         - tuples+         - functions++More formally, we write the derivation of fmap code over type variable+'a for type 'b as ($fmap 'a 'b).  In this general notation the derived+instance for T is:++  instance Functor T where+      fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)+      fmap f (T2 x1)    = T2 ($(fmap 'a '(T a)) x1)++  $(fmap 'a 'b)          =  \x -> x     -- when b does not contain a+  $(fmap 'a 'a)          =  f+  $(fmap 'a '(b1,b2))    =  \x -> case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)+  $(fmap 'a '(T b1 b2))  =  fmap $(fmap 'a 'b2)   -- when a only occurs in the last parameter, b2+  $(fmap 'a '(b -> c))   =  \x b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))++For functions, the type parameter 'a can occur in a contravariant position,+which means we need to derive a function like:++  cofmap :: (a -> b) -> (f b -> f a)++This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:++  $(cofmap 'a 'b)          =  \x -> x     -- when b does not contain a+  $(cofmap 'a 'a)          =  error "type variable in contravariant position"+  $(cofmap 'a '(b1,b2))    =  \x -> case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)+  $(cofmap 'a '[b])        =  map $(cofmap 'a 'b)+  $(cofmap 'a '(T b1 b2))  =  fmap $(cofmap 'a 'b2)   -- when a only occurs in the last parameter, b2+  $(cofmap 'a '(b -> c))   =  \x b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))++Note that the code produced by $(fmap _ _) is always a higher order function,+with type `(a -> b) -> (g a -> g b)` for some g. When we need to do pattern+matching on the type, this means create a lambda function (see the (,) case above).+The resulting code for fmap can look a bit weird, for example:++  data X a = X (a,Int)+  -- generated instance+  instance Functor X where+      fmap f (X x) = (\y -> case y of (x1,x2) -> X (f x1, (\z -> z) x2)) x++The optimizer should be able to simplify this code by simple inlining.++An older version of the deriving code tried to avoid these applied+lambda functions by producing a meta level function. But the function to+be mapped, `f`, is a function on the code level, not on the meta level,+so it was eta expanded to `\x -> [| f $x |]`. This resulted in too much eta expansion.+It is better to produce too many lambdas than to eta expand, see ticket #7436.+-}++gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)+gen_Functor_binds loc tycon+  = (listToBag [fmap_bind, replace_bind], emptyBag)+  where+    data_cons = tyConDataCons tycon+    fmap_name = L loc fmap_RDR+    fmap_bind = mkRdrFunBind fmap_name fmap_eqns+    fmap_match_ctxt = mkPrefixFunRhs fmap_name++    fmap_eqn con = flip evalState bs_RDRs $+                     match_for_con fmap_match_ctxt [f_Pat] con =<< parts+      where+        parts = sequence $ foldDataConArgs ft_fmap con++    fmap_eqns+         | null data_cons = [mkSimpleMatch fmap_match_ctxt+                                           [nlWildPat, nlWildPat]+                                           (error_Expr "Void fmap")]+         | otherwise      = map fmap_eqn data_cons++    ft_fmap :: FFoldType (State [RdrName] (LHsExpr RdrName))+    ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x+                   -- fmap f = \x -> x+                 , ft_var  = return f_Expr+                   -- fmap f = f+                 , ft_fun  = \g h -> do+                     gg <- g+                     hh <- h+                     mkSimpleLam2 $ \x b -> return $+                       nlHsApp hh (nlHsApp x (nlHsApp gg b))+                   -- fmap f = \x b -> h (x (g b))+                 , ft_tup = \t gs -> do+                     gg <- sequence gs+                     mkSimpleLam $ mkSimpleTupleCase (match_for_con CaseAlt) t gg+                   -- fmap f = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)+                 , ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g+                   -- fmap f = fmap g+                 , ft_forall = \_ g -> g+                 , ft_bad_app = panic "in other argument"+                 , ft_co_var = panic "contravariant" }++    -- See Note [deriving <$]+    replace_name = L loc replace_RDR+    replace_bind = mkRdrFunBind replace_name replace_eqns+    replace_match_ctxt = mkPrefixFunRhs replace_name++    replace_eqn con = flip evalState bs_RDRs $+        match_for_con replace_match_ctxt [z_Pat] con =<< parts+      where+        parts = traverse (fmap replace) $ foldDataConArgs ft_replace con++    replace_eqns+         | null data_cons = [mkSimpleMatch replace_match_ctxt+                                           [nlWildPat, nlWildPat]+                                           (error_Expr "Void <$")]+         | otherwise      = map replace_eqn data_cons++    ft_replace :: FFoldType (State [RdrName] Replacer)+    ft_replace = FT { ft_triv = fmap Nested $ mkSimpleLam $ \x -> return x+                   -- (p <$) = \x -> x+                 , ft_var  = fmap Immediate $ mkSimpleLam $ \_ -> return z_Expr+                   -- (p <$) = const p+                 , ft_fun  = \g h -> do+                     gg <- replace <$> g+                     hh <- replace <$> h+                     fmap Nested $ mkSimpleLam2 $ \x b -> return $+                       nlHsApp hh (nlHsApp x (nlHsApp gg b))+                   -- (<$) p = \x b -> h (x (g b))+                 , ft_tup = \t gs -> do+                     gg <- traverse (fmap replace) gs+                     fmap Nested . mkSimpleLam $+                          mkSimpleTupleCase (match_for_con CaseAlt) t gg+                   -- (p <$) = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)+                 , ft_ty_app = \_ gm -> do+                       g <- gm+                       case g of+                         Nested g' -> pure . Nested $+                                          nlHsApp fmap_Expr $ g'+                         Immediate _ -> pure . Nested $+                                          nlHsApp replace_Expr z_Expr+                   -- (p <$) = fmap (p <$)+                 , ft_forall = \_ g -> g+                 , ft_bad_app = panic "in other argument"+                 , ft_co_var = panic "contravariant" }++    -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...+    match_for_con :: HsMatchContext RdrName+                  -> [LPat RdrName] -> DataCon -> [LHsExpr RdrName]+                  -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))+    match_for_con ctxt = mkSimpleConMatch ctxt $+        \con_name xs -> return $ nlHsApps con_name xs  -- Con x1 x2 ..++-- See Note [deriving <$]+data Replacer = Immediate {replace :: LHsExpr RdrName}+              | Nested {replace :: LHsExpr RdrName}++{- Note [deriving <$]+   ~~~~~~~~~~~~~~~~~~++We derive the definition of <$. Allowing this to take the default definition+can lead to memory leaks: mapping over a structure with a constant function can+fill the result structure with trivial thunks that retain the values from the+original structure. The simplifier seems to handle this all right for simple+types, but not for recursive ones. Consider++data Tree a = Bin !(Tree a) a !(Tree a) | Tip deriving Functor++-- fmap _ Tip = Tip+-- fmap f (Bin l v r) = Bin (fmap f l) (f v) (fmap f r)++Using the default definition of <$, we get (<$) x = fmap (\_ -> x) and that+simplifies no further. Why is that? `fmap` is defined recursively, so GHC+cannot inline it. The static argument transformation would turn the definition+into a non-recursive one++-- fmap f = go where+--   go Tip = Tip+--   go (Bin l v r) = Bin (go l) (f v) (go r)++which GHC could inline, producing an efficient definion of `<$`. But there are+several problems. First, GHC does not perform the static argument transformation+by default, even with -O2. Second, even when it does perform the static argument+transformation, it does so only when there are at least two static arguments,+which is not the case for fmap. Finally, when the type in question is+non-regular, such as++data Nesty a = Z a | S (Nesty a) (Nest (a, a))++the function argument is no longer (entirely) static, so the static argument+transformation will do nothing for us.++Applying the default definition of `<$` will produce a tree full of thunks that+look like ((\_ -> x) x0), which represents unnecessary thunk allocation and+also retention of the previous value, potentially leaking memory. Instead, we+derive <$ separately. Two aspects are different from fmap: the case of the+sought type variable (ft_var) and the case of a type application (ft_ty_app).+The interesting one is ft_ty_app. We have to distinguish two cases: the+"immediate" case where the type argument *is* the sought type variable, and+the "nested" case where the type argument *contains* the sought type variable.++The immediate case:++Suppose we have++data Imm a = Imm (F ... a)++Then we want to define++x <$ Imm q = Imm (x <$ q)++The nested case:++Suppose we have++data Nes a = Nes (F ... (G a))++Then we want to define++x <$ Nes q = Nes (fmap (x <$) q)++We use the Replacer type to tag whether the expression derived for applying+<$ to the last type variable was the ft_var case (immediate) or one of the+others (letting ft_forall pass through as usual).++We could, but do not, give tuples special treatment to improve efficiency+in some cases. Suppose we have++data Nest a = Z a | S (Nest (a,a))++The optimal definition would be++x <$ Z _ = Z x+x <$ S t = S ((x, x) <$ t)++which produces a result with maximal internal sharing. The reason we do not+attempt to treat this case specially is that we have no way to give+user-provided tuple-like types similar treatment. If the user changed the+definition to++data Pair a = Pair a a+data Nest a = Z a | S (Nest (Pair a))++they would experience a surprising degradation in performance. -}+++{-+Utility functions related to Functor deriving.++Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.+This function works like a fold: it makes a value of type 'a' in a bottom up way.+-}++-- Generic traversal for Functor deriving+-- See Note [FFoldType and functorLikeTraverse]+data FFoldType a      -- Describes how to fold over a Type in a functor like way+   = FT { ft_triv    :: a+          -- ^ Does not contain variable+        , ft_var     :: a+          -- ^ The variable itself+        , ft_co_var  :: a+          -- ^ The variable itself, contravariantly+        , ft_fun     :: a -> a -> a+          -- ^ Function type+        , ft_tup     :: TyCon -> [a] -> a+          -- ^ Tuple type+        , ft_ty_app  :: Type -> a -> a+          -- ^ Type app, variable only in last argument+        , ft_bad_app :: a+          -- ^ Type app, variable other than in last argument+        , ft_forall  :: TcTyVar -> a -> a+          -- ^ Forall type+     }++functorLikeTraverse :: forall a.+                       TyVar         -- ^ Variable to look for+                    -> FFoldType a   -- ^ How to fold+                    -> Type          -- ^ Type to process+                    -> a+functorLikeTraverse var (FT { ft_triv = caseTrivial,     ft_var = caseVar+                            , ft_co_var = caseCoVar,     ft_fun = caseFun+                            , ft_tup = caseTuple,        ft_ty_app = caseTyApp+                            , ft_bad_app = caseWrongArg, ft_forall = caseForAll })+                    ty+  = fst (go False ty)+  where+    go :: Bool        -- Covariant or contravariant context+       -> Type+       -> (a, Bool)   -- (result of type a, does type contain var)++    go co ty | Just ty' <- tcView ty = go co ty'+    go co (TyVarTy    v) | v == var = (if co then caseCoVar else caseVar,True)+    go co (FunTy x y)  | isPredTy x = go co y+                       | xc || yc   = (caseFun xr yr,True)+        where (xr,xc) = go (not co) x+              (yr,yc) = go co       y+    go co (AppTy    x y) | xc = (caseWrongArg,   True)+                         | yc = (caseTyApp x yr, True)+        where (_, xc) = go co x+              (yr,yc) = go co y+    go co ty@(TyConApp con args)+       | not (or xcs)     = (caseTrivial, False)   -- Variable does not occur+       -- At this point we know that xrs, xcs is not empty,+       -- and at least one xr is True+       | isTupleTyCon con = (caseTuple con xrs, True)+       | or (init xcs)    = (caseWrongArg, True)         -- T (..var..)    ty+       | Just (fun_ty, _) <- splitAppTy_maybe ty         -- T (..no var..) ty+                          = (caseTyApp fun_ty (last xrs), True)+       | otherwise        = (caseWrongArg, True)   -- Non-decomposable (eg type function)+       where+         -- When folding over an unboxed tuple, we must explicitly drop the+         -- runtime rep arguments, or else GHC will generate twice as many+         -- variables in a unboxed tuple pattern match and expression as it+         -- actually needs. See Trac #12399+         (xrs,xcs) = unzip (map (go co) (dropRuntimeRepArgs args))+    go co (ForAllTy (TvBndr v vis) x)+       | isVisibleArgFlag vis = panic "unexpected visible binder"+       | v /= var && xc       = (caseForAll v xr,True)+       where (xr,xc) = go co x++    go _ _ = (caseTrivial,False)++-- Return all syntactic subterms of ty that contain var somewhere+-- These are the things that should appear in instance constraints+deepSubtypesContaining :: TyVar -> Type -> [TcType]+deepSubtypesContaining tv+  = functorLikeTraverse tv+        (FT { ft_triv = []+            , ft_var = []+            , ft_fun = (++)+            , ft_tup = \_ xs -> concat xs+            , ft_ty_app = (:)+            , ft_bad_app = panic "in other argument"+            , ft_co_var = panic "contravariant"+            , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs })+++foldDataConArgs :: FFoldType a -> DataCon -> [a]+-- Fold over the arguments of the datacon+foldDataConArgs ft con+  = map foldArg (dataConOrigArgTys con)+  where+    foldArg+      = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of+             Just tv -> functorLikeTraverse tv ft+             Nothing -> const (ft_triv ft)+    -- If we are deriving Foldable for a GADT, there is a chance that the last+    -- type variable in the data type isn't actually a type variable at all.+    -- (for example, this can happen if the last type variable is refined to+    -- be a concrete type such as Int). If the last type variable is refined+    -- to be a specific type, then getTyVar_maybe will return Nothing.+    -- See Note [DeriveFoldable with ExistentialQuantification]+    --+    -- The kind checks have ensured the last type parameter is of kind *.++-- Make a HsLam using a fresh variable from a State monad+mkSimpleLam :: (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))+            -> State [RdrName] (LHsExpr RdrName)+-- (mkSimpleLam fn) returns (\x. fn(x))+mkSimpleLam lam = do+    (n:names) <- get+    put names+    body <- lam (nlHsVar n)+    return (mkHsLam [nlVarPat n] body)++mkSimpleLam2 :: (LHsExpr RdrName -> LHsExpr RdrName+             -> State [RdrName] (LHsExpr RdrName))+             -> State [RdrName] (LHsExpr RdrName)+mkSimpleLam2 lam = do+    (n1:n2:names) <- get+    put names+    body <- lam (nlHsVar n1) (nlHsVar n2)+    return (mkHsLam [nlVarPat n1,nlVarPat n2] body)++-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"+--+-- @mkSimpleConMatch fold extra_pats con insides@ produces a match clause in+-- which the LHS pattern-matches on @extra_pats@, followed by a match on the+-- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@+-- and its arguments, applying an expression (from @insides@) to each of the+-- respective arguments of @con@.+mkSimpleConMatch :: Monad m => HsMatchContext RdrName+                 -> (RdrName -> [LHsExpr RdrName] -> m (LHsExpr RdrName))+                 -> [LPat RdrName]+                 -> DataCon+                 -> [LHsExpr RdrName]+                 -> m (LMatch RdrName (LHsExpr RdrName))+mkSimpleConMatch ctxt fold extra_pats con insides = do+    let con_name = getRdrName con+    let vars_needed = takeList insides as_RDRs+    let bare_pat = nlConVarPat con_name vars_needed+    let pat = if null vars_needed+          then bare_pat+          else nlParPat bare_pat+    rhs <- fold con_name (zipWith nlHsApp insides (map nlHsVar vars_needed))+    return $ mkMatch ctxt (extra_pats ++ [pat]) rhs+                     (noLoc emptyLocalBinds)++-- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)"+--+-- @mkSimpleConMatch2 fold extra_pats con insides@ behaves very similarly to+-- 'mkSimpleConMatch', with two key differences:+--+-- 1. @insides@ is a @[Maybe (LHsExpr RdrName)]@ instead of a+--    @[LHsExpr RdrName]@. This is because it filters out the expressions+--    corresponding to arguments whose types do not mention the last type+--    variable in a derived 'Foldable' or 'Traversable' instance (i.e., the+--    'Nothing' elements of @insides@).+--+-- 2. @fold@ takes an expression as its first argument instead of a+--    constructor name. This is because it uses a specialized+--    constructor function expression that only takes as many parameters as+--    there are argument types that mention the last type variable.+--+-- See Note [Generated code for DeriveFoldable and DeriveTraversable]+mkSimpleConMatch2 :: Monad m+                  => HsMatchContext RdrName+                  -> (LHsExpr RdrName -> [LHsExpr RdrName]+                                      -> m (LHsExpr RdrName))+                  -> [LPat RdrName]+                  -> DataCon+                  -> [Maybe (LHsExpr RdrName)]+                  -> m (LMatch RdrName (LHsExpr RdrName))+mkSimpleConMatch2 ctxt fold extra_pats con insides = do+    let con_name = getRdrName con+        vars_needed = takeList insides as_RDRs+        pat = nlConVarPat con_name vars_needed+        -- Make sure to zip BEFORE invoking catMaybes. We want the variable+        -- indicies in each expression to match up with the argument indices+        -- in con_expr (defined below).+        exps = catMaybes $ zipWith (\i v -> (`nlHsApp` v) <$> i)+                                   insides (map nlHsVar vars_needed)+        -- An element of argTysTyVarInfo is True if the constructor argument+        -- with the same index has a type which mentions the last type+        -- variable.+        argTysTyVarInfo = map isJust insides+        (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_RDRs++        con_expr+          | null asWithTyVar = nlHsApps con_name $ map nlHsVar asWithoutTyVar+          | otherwise =+              let bs   = filterByList  argTysTyVarInfo bs_RDRs+                  vars = filterByLists argTysTyVarInfo+                                       (map nlHsVar bs_RDRs)+                                       (map nlHsVar as_RDRs)+              in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars)++    rhs <- fold con_expr exps+    return $ mkMatch ctxt (extra_pats ++ [pat]) rhs+                     (noLoc emptyLocalBinds)++-- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"+mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [a]+                                 -> m (LMatch RdrName (LHsExpr RdrName)))+                  -> TyCon -> [a] -> LHsExpr RdrName -> m (LHsExpr RdrName)+mkSimpleTupleCase match_for_con tc insides x+  = do { let data_con = tyConSingleDataCon tc+       ; match <- match_for_con [] data_con insides+       ; return $ nlHsCase x [match] }++{-+************************************************************************+*                                                                      *+                        Foldable instances++ see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html++*                                                                      *+************************************************************************++Deriving Foldable instances works the same way as Functor instances,+only Foldable instances are not possible for function types at all.+Given (data T a = T a a (T a) deriving Foldable), we get:++  instance Foldable T where+      foldr f z (T x1 x2 x3) =+        $(foldr 'a 'a) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a '(T a)) x3 z ) )++-XDeriveFoldable is different from -XDeriveFunctor in that it filters out+arguments to the constructor that would produce useless code in a Foldable+instance. For example, the following datatype:++  data Foo a = Foo Int a Int deriving Foldable++would have the following generated Foldable instance:++  instance Foldable Foo where+    foldr f z (Foo x1 x2 x3) = $(foldr 'a 'a) x2++since neither of the two Int arguments are folded over.++The cases are:++  $(foldr 'a 'a)         =  f+  $(foldr 'a '(b1,b2))   =  \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )+  $(foldr 'a '(T b1 b2)) =  \x z -> foldr $(foldr 'a 'b2) z x  -- when a only occurs in the last parameter, b2++Note that the arguments to the real foldr function are the wrong way around,+since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).++One can envision a case for types that don't contain the last type variable:++  $(foldr 'a 'b)         =  \x z -> z     -- when b does not contain a++But this case will never materialize, since the aforementioned filtering+removes all such types from consideration.+See Note [Generated code for DeriveFoldable and DeriveTraversable].++Foldable instances differ from Functor and Traversable instances in that+Foldable instances can be derived for data types in which the last type+variable is existentially quantified. In particular, if the last type variable+is refined to a more specific type in a GADT:++  data GADT a where+      G :: a ~ Int => a -> G Int++then the deriving machinery does not attempt to check that the type a contains+Int, since it is not syntactically equal to a type variable. That is, the+derived Foldable instance for GADT is:++  instance Foldable GADT where+      foldr _ z (GADT _) = z++See Note [DeriveFoldable with ExistentialQuantification].++-}++gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)+gen_Foldable_binds loc tycon+  = (listToBag [foldr_bind, foldMap_bind], emptyBag)+  where+    data_cons = tyConDataCons tycon++    foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns+    eqns = map foldr_eqn data_cons+    foldr_eqn con+      = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs+      where+        parts = sequence $ foldDataConArgs ft_foldr con++    foldMap_bind = mkRdrFunBind (L loc foldMap_RDR) (map foldMap_eqn data_cons)+    foldMap_eqn con+      = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs+      where+        parts = sequence $ foldDataConArgs ft_foldMap con++    -- Yields 'Just' an expression if we're folding over a type that mentions+    -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.+    -- See Note [FFoldType and functorLikeTraverse]+    ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName)))+    ft_foldr+      = FT { ft_triv    = return Nothing+             -- foldr f = \x z -> z+           , ft_var     = return $ Just f_Expr+             -- foldr f = f+           , ft_tup     = \t g -> do+               gg  <- sequence g+               lam <- mkSimpleLam2 $ \x z ->+                 mkSimpleTupleCase (match_foldr z) t gg x+               return (Just lam)+             -- foldr f = (\x z -> case x of ...)+           , ft_ty_app  = \_ g -> do+               gg <- g+               mapM (\gg' -> mkSimpleLam2 $ \x z -> return $+                 nlHsApps foldable_foldr_RDR [gg',z,x]) gg+             -- foldr f = (\x z -> foldr g z x)+           , ft_forall  = \_ g -> g+           , ft_co_var  = panic "contravariant"+           , ft_fun     = panic "function"+           , ft_bad_app = panic "in other argument" }++    match_foldr :: LHsExpr RdrName+                -> [LPat RdrName]+                -> DataCon+                -> [Maybe (LHsExpr RdrName)]+                -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))+    match_foldr z = mkSimpleConMatch2 LambdaExpr $ \_ xs -> return (mkFoldr xs)+      where+        -- g1 v1 (g2 v2 (.. z))+        mkFoldr :: [LHsExpr RdrName] -> LHsExpr RdrName+        mkFoldr = foldr nlHsApp z++    -- See Note [FFoldType and functorLikeTraverse]+    ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName)))+    ft_foldMap+      = FT { ft_triv = return Nothing+             -- foldMap f = \x -> mempty+           , ft_var  = return (Just f_Expr)+             -- foldMap f = f+           , ft_tup  = \t g -> do+               gg  <- sequence g+               lam <- mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg+               return (Just lam)+             -- foldMap f = \x -> case x of (..,)+           , ft_ty_app = \_ g -> fmap (nlHsApp foldMap_Expr) <$> g+             -- foldMap f = foldMap g+           , ft_forall = \_ g -> g+           , ft_co_var = panic "contravariant"+           , ft_fun = panic "function"+           , ft_bad_app = panic "in other argument" }++    match_foldMap :: [LPat RdrName]+                  -> DataCon+                  -> [Maybe (LHsExpr RdrName)]+                  -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))+    match_foldMap = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkFoldMap xs)+      where+        -- mappend v1 (mappend v2 ..)+        mkFoldMap :: [LHsExpr RdrName] -> LHsExpr RdrName+        mkFoldMap [] = mempty_Expr+        mkFoldMap xs = foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs++{-+************************************************************************+*                                                                      *+                        Traversable instances++ see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html+*                                                                      *+************************************************************************++Again, Traversable is much like Functor and Foldable.++The cases are:++  $(traverse 'a 'a)          =  f+  $(traverse 'a '(b1,b2))    =  \x -> case x of (x1,x2) ->+     liftA2 (,) ($(traverse 'a 'b1) x1) ($(traverse 'a 'b2) x2)+  $(traverse 'a '(T b1 b2))  =  traverse $(traverse 'a 'b2)  -- when a only occurs in the last parameter, b2++Like -XDeriveFoldable, -XDeriveTraversable filters out arguments whose types+do not mention the last type parameter. Therefore, the following datatype:++  data Foo a = Foo Int a Int++would have the following derived Traversable instance:++  instance Traversable Foo where+    traverse f (Foo x1 x2 x3) =+      fmap (\b2 -> Foo x1 b2 x3) ( $(traverse 'a 'a) x2 )++since the two Int arguments do not produce any effects in a traversal.++One can envision a case for types that do not mention the last type parameter:++  $(traverse 'a 'b)          =  pure     -- when b does not contain a++But this case will never materialize, since the aforementioned filtering+removes all such types from consideration.+See Note [Generated code for DeriveFoldable and DeriveTraversable].+-}++gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)+gen_Traversable_binds loc tycon+  = (unitBag traverse_bind, emptyBag)+  where+    data_cons = tyConDataCons tycon++    traverse_bind = mkRdrFunBind (L loc traverse_RDR) eqns+    eqns = map traverse_eqn data_cons+    traverse_eqn con+      = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs+      where+        parts = sequence $ foldDataConArgs ft_trav con++    -- Yields 'Just' an expression if we're folding over a type that mentions+    -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.+    -- See Note [FFoldType and functorLikeTraverse]+    ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName)))+    ft_trav+      = FT { ft_triv    = return Nothing+             -- traverse f = pure x+           , ft_var     = return (Just f_Expr)+             -- traverse f = f x+           , ft_tup     = \t gs -> do+               gg  <- sequence gs+               lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg+               return (Just lam)+             -- traverse f = \x -> case x of (a1,a2,..) ->+             --                           liftA2 (,,) (g1 a1) (g2 a2) <*> ..+           , ft_ty_app  = \_ g -> fmap (nlHsApp traverse_Expr) <$> g+             -- traverse f = traverse g+           , ft_forall  = \_ g -> g+           , ft_co_var  = panic "contravariant"+           , ft_fun     = panic "function"+           , ft_bad_app = panic "in other argument" }++    -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1)+    --                    (g2 a2) <*> ...+    match_for_con :: [LPat RdrName]+                  -> DataCon+                  -> [Maybe (LHsExpr RdrName)]+                  -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))+    match_for_con = mkSimpleConMatch2 CaseAlt $+                                             \con xs -> return (mkApCon con xs)+      where+        -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> ..+        mkApCon :: LHsExpr RdrName -> [LHsExpr RdrName] -> LHsExpr RdrName+        mkApCon con [] = nlHsApps pure_RDR [con]+        mkApCon con [x] = nlHsApps fmap_RDR [con,x]+        mkApCon con (x1:x2:xs) =+            foldl appAp (nlHsApps liftA2_RDR [con,x1,x2]) xs+          where appAp x y = nlHsApps ap_RDR [x,y]++-----------------------------------------------------------------------++f_Expr, z_Expr, fmap_Expr, replace_Expr, mempty_Expr, foldMap_Expr,+    traverse_Expr :: LHsExpr RdrName+f_Expr        = nlHsVar f_RDR+z_Expr        = nlHsVar z_RDR+fmap_Expr     = nlHsVar fmap_RDR+replace_Expr  = nlHsVar replace_RDR+mempty_Expr   = nlHsVar mempty_RDR+foldMap_Expr  = nlHsVar foldMap_RDR+traverse_Expr = nlHsVar traverse_RDR++f_RDR, z_RDR :: RdrName+f_RDR = mkVarUnqual (fsLit "f")+z_RDR = mkVarUnqual (fsLit "z")++as_RDRs, bs_RDRs :: [RdrName]+as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]+bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]++f_Pat, z_Pat :: LPat RdrName+f_Pat = nlVarPat f_RDR+z_Pat = nlVarPat z_RDR++{-+Note [DeriveFoldable with ExistentialQuantification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Functor and Traversable instances can only be derived for data types whose+last type parameter is truly universally polymorphic. For example:++  data T a b where+    T1 ::                 b   -> T a b   -- YES, b is unconstrained+    T2 :: Ord b   =>      b   -> T a b   -- NO, b is constrained by (Ord b)+    T3 :: b ~ Int =>      b   -> T a b   -- NO, b is constrained by (b ~ Int)+    T4 ::                 Int -> T a Int -- NO, this is just like T3+    T5 :: Ord a   => a -> b   -> T a b   -- YES, b is unconstrained, even+                                         -- though a is existential+    T6 ::                 Int -> T Int b -- YES, b is unconstrained++For Foldable instances, however, we can completely lift the constraint that+the last type parameter be truly universally polymorphic. This means that T+(as defined above) can have a derived Foldable instance:++  instance Foldable (T a) where+    foldr f z (T1 b)   = f b z+    foldr f z (T2 b)   = f b z+    foldr f z (T3 b)   = f b z+    foldr f z (T4 b)   = z+    foldr f z (T5 a b) = f b z+    foldr f z (T6 a)   = z++    foldMap f (T1 b)   = f b+    foldMap f (T2 b)   = f b+    foldMap f (T3 b)   = f b+    foldMap f (T4 b)   = mempty+    foldMap f (T5 a b) = f b+    foldMap f (T6 a)   = mempty++In a Foldable instance, it is safe to fold over an occurrence of the last type+parameter that is not truly universally polymorphic. However, there is a bit+of subtlety in determining what is actually an occurrence of a type parameter.+T3 and T4, as defined above, provide one example:++  data T a b where+    ...+    T3 :: b ~ Int => b   -> T a b+    T4 ::            Int -> T a Int+    ...++  instance Foldable (T a) where+    ...+    foldr f z (T3 b) = f b z+    foldr f z (T4 b) = z+    ...+    foldMap f (T3 b) = f b+    foldMap f (T4 b) = mempty+    ...++Notice that the argument of T3 is folded over, whereas the argument of T4 is+not. This is because we only fold over constructor arguments that+syntactically mention the universally quantified type parameter of that+particular data constructor. See foldDataConArgs for how this is implemented.++As another example, consider the following data type. The argument of each+constructor has the same type as the last type parameter:++  data E a where+    E1 :: (a ~ Int) => a   -> E a+    E2 ::              Int -> E Int+    E3 :: (a ~ Int) => a   -> E Int+    E4 :: (a ~ Int) => Int -> E a++Only E1's argument is an occurrence of a universally quantified type variable+that is syntactically equivalent to the last type parameter, so only E1's+argument will be be folded over in a derived Foldable instance.++See Trac #10447 for the original discussion on this feature. Also see+https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor+for a more in-depth explanation.++Note [FFoldType and functorLikeTraverse]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Deriving Functor, Foldable, and Traversable all require generating expressions+which perform an operation on each argument of a data constructor depending+on the argument's type. In particular, a generated operation can be different+depending on whether the type mentions the last type variable of the datatype+(e.g., if you have data T a = MkT a Int, then a generated foldr expression would+fold over the first argument of MkT, but not the second).++This pattern is abstracted with the FFoldType datatype, which provides hooks+for the user to specify how a constructor argument should be folded when it+has a type with a particular "shape". The shapes are as follows (assume that+a is the last type variable in a given datatype):++* ft_triv:    The type does not mention the last type variable at all.+              Examples: Int, b++* ft_var:     The type is syntactically equal to the last type variable.+              Moreover, the type appears in a covariant position (see+              the Deriving Functor instances section of the user's guide+              for an in-depth explanation of covariance vs. contravariance).+              Example: a (covariantly)++* ft_co_var:  The type is syntactically equal to the last type variable.+              Moreover, the type appears in a contravariant position.+              Example: a (contravariantly)++* ft_fun:     A function type which mentions the last type variable in+              the argument position, result position or both.+              Examples: a -> Int, Int -> a, Maybe a -> [a]++* ft_tup:     A tuple type which mentions the last type variable in at least+              one of its fields. The TyCon argument of ft_tup represents the+              particular tuple's type constructor.+              Examples: (a, Int), (Maybe a, [a], Either a Int), (# Int, a #)++* ft_ty_app:  A type is being applied to the last type parameter, where the+              applied type does not mention the last type parameter (if it+              did, it would fall under ft_bad_app). The Type argument to+              ft_ty_app represents the applied type.++              Note that functions, tuples, and foralls are distinct cases+              and take precedence of ft_ty_app. (For example, (Int -> a) would+              fall under (ft_fun Int a), not (ft_ty_app ((->) Int) a).+              Examples: Maybe a, Either b a++* ft_bad_app: A type application uses the last type parameter in a position+              other than the last argument. This case is singled out because+              Functor, Foldable, and Traversable instances cannot be derived+              for datatypes containing arguments with such types.+              Examples: Either a Int, Const a b++* ft_forall:  A forall'd type mentions the last type parameter on its right-+              hand side (and is not quantified on the left-hand side). This+              case is present mostly for plumbing purposes.+              Example: forall b. Either b a++If FFoldType describes a strategy for folding subcomponents of a Type, then+functorLikeTraverse is the function that applies that strategy to the entirety+of a Type, returning the final folded-up result.++foldDataConArgs applies functorLikeTraverse to every argument type of a+constructor, returning a list of the fold results. This makes foldDataConArgs+a natural way to generate the subexpressions in a generated fmap, foldr,+foldMap, or traverse definition (the subexpressions must then be combined in+a method-specific fashion to form the final generated expression).++Deriving Generic1 also does validity checking by looking for the last type+variable in certain positions of a constructor's argument types, so it also+uses foldDataConArgs. See Note [degenerate use of FFoldType] in TcGenGenerics.++Note [Generated code for DeriveFoldable and DeriveTraversable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We adapt the algorithms for -XDeriveFoldable and -XDeriveTraversable based on+that of -XDeriveFunctor. However, there an important difference between deriving+the former two typeclasses and the latter one, which is best illustrated by the+following scenario:++  data WithInt a = WithInt a Int# deriving (Functor, Foldable, Traversable)++The generated code for the Functor instance is straightforward:++  instance Functor WithInt where+    fmap f (WithInt a i) = WithInt (f a) i++But if we use too similar of a strategy for deriving the Foldable and+Traversable instances, we end up with this code:++  instance Foldable WithInt where+    foldMap f (WithInt a i) = f a <> mempty++  instance Traversable WithInt where+    traverse f (WithInt a i) = fmap WithInt (f a) <*> pure i++This is unsatisfying for two reasons:++1. The Traversable instance doesn't typecheck! Int# is of kind #, but pure+   expects an argument whose type is of kind *. This effectively prevents+   Traversable from being derived for any datatype with an unlifted argument+   type (Trac #11174).++2. The generated code contains superfluous expressions. By the Monoid laws,+   we can reduce (f a <> mempty) to (f a), and by the Applicative laws, we can+   reduce (fmap WithInt (f a) <*> pure i) to (fmap (\b -> WithInt b i) (f a)).++We can fix both of these issues by incorporating a slight twist to the usual+algorithm that we use for -XDeriveFunctor. The differences can be summarized+as follows:++1. In the generated expression, we only fold over arguments whose types+   mention the last type parameter. Any other argument types will simply+   produce useless 'mempty's or 'pure's, so they can be safely ignored.++2. In the case of -XDeriveTraversable, instead of applying ConName,+   we apply (\b_i ... b_k -> ConName a_1 ... a_n), where++   * ConName has n arguments+   * {b_i, ..., b_k} is a subset of {a_1, ..., a_n} whose indices correspond+     to the arguments whose types mention the last type parameter. As a+     consequence, taking the difference of {a_1, ..., a_n} and+     {b_i, ..., b_k} yields the all the argument values of ConName whose types+     do not mention the last type parameter. Note that [i, ..., k] is a+     strictly increasing—but not necessarily consecutive—integer sequence.++     For example, the datatype++       data Foo a = Foo Int a Int a++     would generate the following Traversable instance:++       instance Traversable Foo where+         traverse f (Foo a1 a2 a3 a4) =+           fmap (\b2 b4 -> Foo a1 b2 a3 b4) (f a2) <*> f a4++Technically, this approach would also work for -XDeriveFunctor as well, but we+decide not to do so because:++1. There's not much benefit to generating, e.g., ((\b -> WithInt b i) (f a))+   instead of (WithInt (f a) i).++2. There would be certain datatypes for which the above strategy would+   generate Functor code that would fail to typecheck. For example:++     data Bar f a = Bar (forall f. Functor f => f a) deriving Functor++   With the conventional algorithm, it would generate something like:++     fmap f (Bar a) = Bar (fmap f a)++   which typechecks. But with the strategy mentioned above, it would generate:++     fmap f (Bar a) = (\b -> Bar b) (fmap f a)++   which does not typecheck, since GHC cannot unify the rank-2 type variables+   in the types of b and (fmap f a).+-}
+ typecheck/TcGenGenerics.hs view
@@ -0,0 +1,1010 @@+{-+(c) The University of Glasgow 2011+++The deriving code for the Generic class+(equivalent to the code in TcGenDeriv, for other classes)+-}++{-# LANGUAGE CPP, ScopedTypeVariables, TupleSections #-}+{-# LANGUAGE FlexibleContexts #-}++module TcGenGenerics (canDoGenerics, canDoGenerics1,+                      GenericKind(..),+                      gen_Generic_binds, get_gen1_constrained_tys) where++import HsSyn+import Type+import TcType+import TcGenDeriv+import TcGenFunctor+import DataCon+import TyCon+import FamInstEnv       ( FamInst, FamFlavor(..), mkSingleCoAxiom )+import FamInst+import Module           ( moduleName, moduleNameFS+                        , moduleUnitId, unitIdFS, getModule )+import IfaceEnv         ( newGlobalBinder )+import Name      hiding ( varName )+import RdrName+import BasicTypes+import TysPrim+import TysWiredIn+import PrelNames+import TcEnv+import TcRnMonad+import HscTypes+import ErrUtils( Validity(..), andValid )+import SrcLoc+import Bag+import VarEnv+import VarSet (elemVarSet)+import Outputable+import FastString+import Util++import Control.Monad (mplus)+import Data.List (zip4, partition)+import Data.Maybe (isJust)++#include "HsVersions.h"++{-+************************************************************************+*                                                                      *+\subsection{Bindings for the new generic deriving mechanism}+*                                                                      *+************************************************************************++For the generic representation we need to generate:+\begin{itemize}+\item A Generic instance+\item A Rep type instance+\item Many auxiliary datatypes and instances for them (for the meta-information)+\end{itemize}+-}++gen_Generic_binds :: GenericKind -> TyCon -> [Type]+                 -> TcM (LHsBinds RdrName, FamInst)+gen_Generic_binds gk tc inst_tys = do+  repTyInsts <- tc_mkRepFamInsts gk tc inst_tys+  return (mkBindsRep gk tc, repTyInsts)++{-+************************************************************************+*                                                                      *+\subsection{Generating representation types}+*                                                                      *+************************************************************************+-}++get_gen1_constrained_tys :: TyVar -> Type -> [Type]+-- called by TcDeriv.inferConstraints; generates a list of types, each of which+-- must be a Functor in order for the Generic1 instance to work.+get_gen1_constrained_tys argVar+  = argTyFold argVar $ ArgTyAlg { ata_rec0 = const []+                                , ata_par1 = [], ata_rec1 = const []+                                , ata_comp = (:) }++{-++Note [Requirements for deriving Generic and Rep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++In the following, T, Tfun, and Targ are "meta-variables" ranging over type+expressions.++(Generic T) and (Rep T) are derivable for some type expression T if the+following constraints are satisfied.++  (a) D is a type constructor *value*. In other words, D is either a type+      constructor or it is equivalent to the head of a data family instance (up to+      alpha-renaming).++  (b) D cannot have a "stupid context".++  (c) The right-hand side of D cannot include existential types, universally+      quantified types, or "exotic" unlifted types. An exotic unlifted type+      is one which is not listed in the definition of allowedUnliftedTy+      (i.e., one for which we have no representation type).+      See Note [Generics and unlifted types]++  (d) T :: *.++(Generic1 T) and (Rep1 T) are derivable for some type expression T if the+following constraints are satisfied.++  (a),(b),(c) As above.++  (d) T must expect arguments, and its last parameter must have kind *.++      We use `a' to denote the parameter of D that corresponds to the last+      parameter of T.++  (e) For any type-level application (Tfun Targ) in the right-hand side of D+      where the head of Tfun is not a tuple constructor:++      (b1) `a' must not occur in Tfun.++      (b2) If `a' occurs in Targ, then Tfun :: * -> *.++-}++canDoGenerics :: TyCon -> Validity+-- canDoGenerics determines if Generic/Rep can be derived.+--+-- Check (a) from Note [Requirements for deriving Generic and Rep] is taken+-- care of because canDoGenerics is applied to rep tycons.+--+-- It returns IsValid if deriving is possible. It returns (NotValid reason)+-- if not.+canDoGenerics tc+  = mergeErrors (+          -- Check (b) from Note [Requirements for deriving Generic and Rep].+              (if (not (null (tyConStupidTheta tc)))+                then (NotValid (tc_name <+> text "must not have a datatype context"))+                else IsValid)+          -- See comment below+            : (map bad_con (tyConDataCons tc)))+  where+    -- The tc can be a representation tycon. When we want to display it to the+    -- user (in an error message) we should print its parent+    tc_name = ppr $ case tyConFamInst_maybe tc of+        Just (ptc, _) -> ptc+        _             -> tc++        -- Check (c) from Note [Requirements for deriving Generic and Rep].+        --+        -- If any of the constructors has an exotic unlifted type as argument,+        -- then we can't build the embedding-projection pair, because+        -- it relies on instantiating *polymorphic* sum and product types+        -- at the argument types of the constructors+    bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc))+                  then (NotValid (ppr dc <+> text+                    "must not have exotic unlifted or polymorphic arguments"))+                  else (if (not (isVanillaDataCon dc))+                          then (NotValid (ppr dc <+> text "must be a vanilla data constructor"))+                          else IsValid)++        -- Nor can we do the job if it's an existential data constructor,+        -- Nor if the args are polymorphic types (I don't think)+    bad_arg_type ty = (isUnliftedType ty && not (allowedUnliftedTy ty))+                      || not (isTauTy ty)++-- Returns True the Type argument is an unlifted type which has a+-- corresponding generic representation type. For example,+-- (allowedUnliftedTy Int#) would return True since there is the UInt+-- representation type.+allowedUnliftedTy :: Type -> Bool+allowedUnliftedTy = isJust . unboxedRepRDRs++mergeErrors :: [Validity] -> Validity+mergeErrors []             = IsValid+mergeErrors (NotValid s:t) = case mergeErrors t of+  IsValid     -> NotValid s+  NotValid s' -> NotValid (s <> text ", and" $$ s')+mergeErrors (IsValid : t) = mergeErrors t++-- A datatype used only inside of canDoGenerics1. It's the result of analysing+-- a type term.+data Check_for_CanDoGenerics1 = CCDG1+  { _ccdg1_hasParam :: Bool       -- does the parameter of interest occurs in+                                  -- this type?+  , _ccdg1_errors   :: Validity   -- errors generated by this type+  }++{-++Note [degenerate use of FFoldType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We use foldDataConArgs here only for its ability to treat tuples+specially. foldDataConArgs also tracks covariance (though it assumes all+higher-order type parameters are covariant) and has hooks for special handling+of functions and polytypes, but we do *not* use those.++The key issue is that Generic1 deriving currently offers no sophisticated+support for functions. For example, we cannot handle++  data F a = F ((a -> Int) -> Int)++even though a is occurring covariantly.++In fact, our rule is harsh: a is simply not allowed to occur within the first+argument of (->). We treat (->) the same as any other non-tuple tycon.++Unfortunately, this means we have to track "the parameter occurs in this type"+explicitly, even though foldDataConArgs is also doing this internally.++-}++-- canDoGenerics1 determines if a Generic1/Rep1 can be derived.+--+-- Checks (a) through (c) from Note [Requirements for deriving Generic and Rep]+-- are taken care of by the call to canDoGenerics.+--+-- It returns IsValid if deriving is possible. It returns (NotValid reason)+-- if not.+canDoGenerics1 :: TyCon -> Validity+canDoGenerics1 rep_tc =+  canDoGenerics rep_tc `andValid` additionalChecks+  where+    additionalChecks+        -- check (d) from Note [Requirements for deriving Generic and Rep]+      | null (tyConTyVars rep_tc) = NotValid $+          text "Data type" <+> quotes (ppr rep_tc)+      <+> text "must have some type parameters"++      | otherwise = mergeErrors $ concatMap check_con data_cons++    data_cons = tyConDataCons rep_tc+    check_con con = case check_vanilla con of+      j@(NotValid {}) -> [j]+      IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con++    bad :: DataCon -> SDoc -> SDoc+    bad con msg = text "Constructor" <+> quotes (ppr con) <+> msg++    check_vanilla :: DataCon -> Validity+    check_vanilla con | isVanillaDataCon con = IsValid+                      | otherwise            = NotValid (bad con existential)++    bmzero      = CCDG1 False IsValid+    bmbad con s = CCDG1 True $ NotValid $ bad con s+    bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (m1 `andValid` m2)++    -- check (e) from Note [Requirements for deriving Generic and Rep]+    -- See also Note [degenerate use of FFoldType]+    ft_check :: DataCon -> FFoldType Check_for_CanDoGenerics1+    ft_check con = FT+      { ft_triv = bmzero++      , ft_var = caseVar, ft_co_var = caseVar++      -- (component_0,component_1,...,component_n)+      , ft_tup = \_ components -> if any _ccdg1_hasParam (init components)+                                  then bmbad con wrong_arg+                                  else foldr bmplus bmzero components++      -- (dom -> rng), where the head of ty is not a tuple tycon+      , ft_fun = \dom rng -> -- cf #8516+          if _ccdg1_hasParam dom+          then bmbad con wrong_arg+          else bmplus dom rng++      -- (ty arg), where head of ty is neither (->) nor a tuple constructor and+      -- the parameter of interest does not occur in ty+      , ft_ty_app = \_ arg -> arg++      , ft_bad_app = bmbad con wrong_arg+      , ft_forall  = \_ body -> body -- polytypes are handled elsewhere+      }+      where+        caseVar = CCDG1 True IsValid+++    existential = text "must not have existential arguments"+    wrong_arg   = text "applies a type to an argument involving the last parameter"+               $$ text "but the applied type is not of kind * -> *"++{-+************************************************************************+*                                                                      *+\subsection{Generating the RHS of a generic default method}+*                                                                      *+************************************************************************+-}++type US = Int   -- Local unique supply, just a plain Int+type Alt = (LPat RdrName, LHsExpr RdrName)++-- GenericKind serves to mark if a datatype derives Generic (Gen0) or+-- Generic1 (Gen1).+data GenericKind = Gen0 | Gen1++-- as above, but with a payload of the TyCon's name for "the" parameter+data GenericKind_ = Gen0_ | Gen1_ TyVar++-- as above, but using a single datacon's name for "the" parameter+data GenericKind_DC = Gen0_DC | Gen1_DC TyVar++forgetArgVar :: GenericKind_DC -> GenericKind+forgetArgVar Gen0_DC   = Gen0+forgetArgVar Gen1_DC{} = Gen1++-- When working only within a single datacon, "the" parameter's name should+-- match that datacon's name for it.+gk2gkDC :: GenericKind_ -> DataCon -> GenericKind_DC+gk2gkDC Gen0_   _ = Gen0_DC+gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d+++-- Bindings for the Generic instance+mkBindsRep :: GenericKind -> TyCon -> LHsBinds RdrName+mkBindsRep gk tycon =+    unitBag (mkRdrFunBind (L loc from01_RDR) [from_eqn])+  `unionBags`+    unitBag (mkRdrFunBind (L loc to01_RDR) [to_eqn])+      where+        -- The topmost M1 (the datatype metadata) has the exact same type+        -- across all cases of a from/to definition, and can be factored out+        -- to save some allocations during typechecking.+        -- See Note [Generics compilation speed tricks]+        from_eqn = mkHsCaseAlt x_Pat $ mkM1_E+                                       $ nlHsPar $ nlHsCase x_Expr from_matches+        to_eqn   = mkHsCaseAlt (mkM1_P x_Pat) $ nlHsCase x_Expr to_matches++        from_matches  = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts]+        to_matches    = [mkHsCaseAlt pat rhs | (pat,rhs) <- to_alts  ]+        loc           = srcLocSpan (getSrcLoc tycon)+        datacons      = tyConDataCons tycon++        (from01_RDR, to01_RDR) = case gk of+                                   Gen0 -> (from_RDR,  to_RDR)+                                   Gen1 -> (from1_RDR, to1_RDR)++        -- Recurse over the sum first+        from_alts, to_alts :: [Alt]+        (from_alts, to_alts) = mkSum gk_ (1 :: US) tycon datacons+          where gk_ = case gk of+                  Gen0 -> Gen0_+                  Gen1 -> ASSERT(length tyvars >= 1)+                          Gen1_ (last tyvars)+                    where tyvars = tyConTyVars tycon++--------------------------------------------------------------------------------+-- The type synonym instance and synonym+--       type instance Rep (D a b) = Rep_D a b+--       type Rep_D a b = ...representation type for D ...+--------------------------------------------------------------------------------++tc_mkRepFamInsts :: GenericKind   -- Gen0 or Gen1+                 -> TyCon         -- The type to generate representation for+                 -> [Type]        -- The type(s) to which Generic(1) is applied+                                  -- in the generated instance+                 -> TcM FamInst   -- Generated representation0 coercion+tc_mkRepFamInsts gk tycon inst_tys =+       -- Consider the example input tycon `D`, where data D a b = D_ a+       -- Also consider `R:DInt`, where { data family D x y :: * -> *+       --                               ; data instance D Int a b = D_ a }+  do { -- `rep` = GHC.Generics.Rep or GHC.Generics.Rep1 (type family)+       fam_tc <- case gk of+         Gen0 -> tcLookupTyCon repTyConName+         Gen1 -> tcLookupTyCon rep1TyConName++     ; fam_envs <- tcGetFamInstEnvs++     ; let -- If the derived instance is+           --   instance Generic (Foo x)+           -- then:+           --   `arg_ki` = *, `inst_ty` = Foo x :: *+           --+           -- If the derived instance is+           --   instance Generic1 (Bar x :: k -> *)+           -- then:+           --   `arg_k` = k, `inst_ty` = Bar x :: k -> *+           (arg_ki, inst_ty) = case (gk, inst_tys) of+             (Gen0, [inst_t])        -> (liftedTypeKind, inst_t)+             (Gen1, [arg_k, inst_t]) -> (arg_k,          inst_t)+             _ -> pprPanic "tc_mkRepFamInsts" (ppr inst_tys)++     ; let mbFamInst         = tyConFamInst_maybe tycon+           -- If we're examining a data family instance, we grab the parent+           -- TyCon (ptc) and use it to determine the type arguments+           -- (inst_args) for the data family *instance*'s type variables.+           ptc               = maybe tycon fst mbFamInst+           (_, inst_args, _) = tcLookupDataFamInst fam_envs ptc $ snd+                                 $ tcSplitTyConApp inst_ty++     ; let -- `tyvars` = [a,b]+           (tyvars, gk_) = case gk of+             Gen0 -> (all_tyvars, Gen0_)+             Gen1 -> ASSERT(not $ null all_tyvars)+                     (init all_tyvars, Gen1_ $ last all_tyvars)+             where all_tyvars = tyConTyVars tycon++       -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *+     ; repTy <- tc_mkRepTy gk_ tycon arg_ki++       -- `rep_name` is a name we generate for the synonym+     ; mod <- getModule+     ; loc <- getSrcSpanM+     ; let tc_occ  = nameOccName (tyConName tycon)+           rep_occ = case gk of Gen0 -> mkGenR tc_occ; Gen1 -> mkGen1R tc_occ+     ; rep_name <- newGlobalBinder mod rep_occ loc++       -- We make sure to substitute the tyvars with their user-supplied+       -- type arguments before generating the Rep/Rep1 instance, since some+       -- of the tyvars might have been instantiated when deriving.+       -- See Note [Generating a correctly typed Rep instance].+     ; let env        = zipTyEnv tyvars inst_args+           in_scope   = mkInScopeSet (tyCoVarsOfTypes inst_tys)+           subst      = mkTvSubst in_scope env+           repTy'     = substTy  subst repTy+           tcv'       = tyCoVarsOfTypeList inst_ty+           (tv', cv') = partition isTyVar tcv'+           tvs'       = toposortTyVars tv'+           cvs'       = toposortTyVars cv'+           axiom      = mkSingleCoAxiom Nominal rep_name tvs' cvs'+                                        fam_tc inst_tys repTy'++     ; newFamInst SynFamilyInst axiom  }++--------------------------------------------------------------------------------+-- Type representation+--------------------------------------------------------------------------------++-- | See documentation of 'argTyFold'; that function uses the fields of this+-- type to interpret the structure of a type when that type is considered as an+-- argument to a constructor that is being represented with 'Rep1'.+data ArgTyAlg a = ArgTyAlg+  { ata_rec0 :: (Type -> a)+  , ata_par1 :: a, ata_rec1 :: (Type -> a)+  , ata_comp :: (Type -> a -> a)+  }++-- | @argTyFold@ implements a generalised and safer variant of the @arg@+-- function from Figure 3 in <http://dreixel.net/research/pdf/gdmh.pdf>. @arg@+-- is conceptually equivalent to:+--+-- > arg t = case t of+-- >   _ | isTyVar t         -> if (t == argVar) then Par1 else Par0 t+-- >   App f [t'] |+-- >     representable1 f &&+-- >     t' == argVar        -> Rec1 f+-- >   App f [t'] |+-- >     representable1 f &&+-- >     t' has tyvars       -> f :.: (arg t')+-- >   _                     -> Rec0 t+--+-- where @argVar@ is the last type variable in the data type declaration we are+-- finding the representation for.+--+-- @argTyFold@ is more general than @arg@ because it uses 'ArgTyAlg' to+-- abstract out the concrete invocations of @Par0@, @Rec0@, @Par1@, @Rec1@, and+-- @:.:@.+--+-- @argTyFold@ is safer than @arg@ because @arg@ would lead to a GHC panic for+-- some data types. The problematic case is when @t@ is an application of a+-- non-representable type @f@ to @argVar@: @App f [argVar]@ is caught by the+-- @_@ pattern, and ends up represented as @Rec0 t@. This type occurs /free/ in+-- the RHS of the eventual @Rep1@ instance, which is therefore ill-formed. Some+-- representable1 checks have been relaxed, and others were moved to+-- @canDoGenerics1@.+argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a+argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0,+                            ata_par1 = mkPar1, ata_rec1 = mkRec1,+                            ata_comp = mkComp}) =+  -- mkRec0 is the default; use it if there is no interesting structure+  -- (e.g. occurrences of parameters or recursive occurrences)+  \t -> maybe (mkRec0 t) id $ go t where+  go :: Type -> -- type to fold through+        Maybe a -- the result (e.g. representation type), unless it's trivial+  go t = isParam `mplus` isApp where++    isParam = do -- handles parameters+      t' <- getTyVar_maybe t+      Just $ if t' == argVar then mkPar1 -- moreover, it is "the" parameter+             else mkRec0 t -- NB mkRec0 instead of the conventional mkPar0++    isApp = do -- handles applications+      (phi, beta) <- tcSplitAppTy_maybe t++      let interesting = argVar `elemVarSet` exactTyCoVarsOfType beta++      -- Does it have no interesting structure to represent?+      if not interesting then Nothing+        else -- Is the argument the parameter? Special case for mkRec1.+          if Just argVar == getTyVar_maybe beta then Just $ mkRec1 phi+            else mkComp phi `fmap` go beta -- It must be a composition.+++tc_mkRepTy ::  -- Gen0_ or Gen1_, for Rep or Rep1+               GenericKind_+              -- The type to generate representation for+            -> TyCon+              -- The kind of the representation type's argument+              -- See Note [Handling kinds in a Rep instance]+            -> Kind+               -- Generated representation0 type+            -> TcM Type+tc_mkRepTy gk_ tycon k =+  do+    d1      <- tcLookupTyCon d1TyConName+    c1      <- tcLookupTyCon c1TyConName+    s1      <- tcLookupTyCon s1TyConName+    rec0    <- tcLookupTyCon rec0TyConName+    rec1    <- tcLookupTyCon rec1TyConName+    par1    <- tcLookupTyCon par1TyConName+    u1      <- tcLookupTyCon u1TyConName+    v1      <- tcLookupTyCon v1TyConName+    plus    <- tcLookupTyCon sumTyConName+    times   <- tcLookupTyCon prodTyConName+    comp    <- tcLookupTyCon compTyConName+    uAddr   <- tcLookupTyCon uAddrTyConName+    uChar   <- tcLookupTyCon uCharTyConName+    uDouble <- tcLookupTyCon uDoubleTyConName+    uFloat  <- tcLookupTyCon uFloatTyConName+    uInt    <- tcLookupTyCon uIntTyConName+    uWord   <- tcLookupTyCon uWordTyConName++    let tcLookupPromDataCon = fmap promoteDataCon . tcLookupDataCon++    md         <- tcLookupPromDataCon metaDataDataConName+    mc         <- tcLookupPromDataCon metaConsDataConName+    ms         <- tcLookupPromDataCon metaSelDataConName+    pPrefix    <- tcLookupPromDataCon prefixIDataConName+    pInfix     <- tcLookupPromDataCon infixIDataConName+    pLA        <- tcLookupPromDataCon leftAssociativeDataConName+    pRA        <- tcLookupPromDataCon rightAssociativeDataConName+    pNA        <- tcLookupPromDataCon notAssociativeDataConName+    pSUpk      <- tcLookupPromDataCon sourceUnpackDataConName+    pSNUpk     <- tcLookupPromDataCon sourceNoUnpackDataConName+    pNSUpkness <- tcLookupPromDataCon noSourceUnpackednessDataConName+    pSLzy      <- tcLookupPromDataCon sourceLazyDataConName+    pSStr      <- tcLookupPromDataCon sourceStrictDataConName+    pNSStrness <- tcLookupPromDataCon noSourceStrictnessDataConName+    pDLzy      <- tcLookupPromDataCon decidedLazyDataConName+    pDStr      <- tcLookupPromDataCon decidedStrictDataConName+    pDUpk      <- tcLookupPromDataCon decidedUnpackDataConName++    fix_env <- getFixityEnv++    let mkSum' a b = mkTyConApp plus  [k,a,b]+        mkProd a b = mkTyConApp times [k,a,b]+        mkRec0 a   = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k a+        mkRec1 a   = mkTyConApp rec1  [k,a]+        mkPar1     = mkTyConTy  par1+        mkD    a   = mkTyConApp d1 [ k, metaDataTy, sumP (tyConDataCons a) ]+        mkC      a = mkTyConApp c1 [ k+                                   , metaConsTy a+                                   , prod (dataConInstOrigArgTys a+                                            . mkTyVarTys . tyConTyVars $ tycon)+                                          (dataConSrcBangs    a)+                                          (dataConImplBangs   a)+                                          (dataConFieldLabels a)]+        mkS mlbl su ss ib a = mkTyConApp s1 [k, metaSelTy mlbl su ss ib, a]++        -- Sums and products are done in the same way for both Rep and Rep1+        sumP [] = mkTyConApp v1 [k]+        sumP l  = foldBal mkSum' . map mkC  $ l+        -- The Bool is True if this constructor has labelled fields+        prod :: [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type+        prod [] _  _  _  = mkTyConApp u1 [k]+        prod l  sb ib fl = foldBal mkProd+                                   [ ASSERT(null fl || length fl > j)+                                     arg t sb' ib' (if null fl+                                                       then Nothing+                                                       else Just (fl !! j))+                                   | (t,sb',ib',j) <- zip4 l sb ib [0..] ]++        arg :: Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type+        arg t (HsSrcBang _ su ss) ib fl = mkS fl su ss ib $ case gk_ of+            -- Here we previously used Par0 if t was a type variable, but we+            -- realized that we can't always guarantee that we are wrapping-up+            -- all type variables in Par0. So we decided to stop using Par0+            -- altogether, and use Rec0 all the time.+                      Gen0_        -> mkRec0 t+                      Gen1_ argVar -> argPar argVar t+          where+            -- Builds argument representation for Rep1 (more complicated due to+            -- the presence of composition).+            argPar argVar = argTyFold argVar $ ArgTyAlg+              {ata_rec0 = mkRec0, ata_par1 = mkPar1,+               ata_rec1 = mkRec1, ata_comp = mkComp comp k}++        tyConName_user = case tyConFamInst_maybe tycon of+                           Just (ptycon, _) -> tyConName ptycon+                           Nothing          -> tyConName tycon++        dtName  = mkStrLitTy . occNameFS . nameOccName $ tyConName_user+        mdName  = mkStrLitTy . moduleNameFS . moduleName+                . nameModule . tyConName $ tycon+        pkgName = mkStrLitTy . unitIdFS . moduleUnitId+                . nameModule . tyConName $ tycon+        isNT    = mkTyConTy $ if isNewTyCon tycon+                              then promotedTrueDataCon+                              else promotedFalseDataCon++        ctName = mkStrLitTy . occNameFS . nameOccName . dataConName+        ctFix c+            | dataConIsInfix c+            = case lookupFixity fix_env (dataConName c) of+                   Fixity _ n InfixL -> buildFix n pLA+                   Fixity _ n InfixR -> buildFix n pRA+                   Fixity _ n InfixN -> buildFix n pNA+            | otherwise = mkTyConTy pPrefix+        buildFix n assoc = mkTyConApp pInfix [ mkTyConTy assoc+                                             , mkNumLitTy (fromIntegral n)]++        isRec c = mkTyConTy $ if length (dataConFieldLabels c) > 0+                              then promotedTrueDataCon+                              else promotedFalseDataCon++        selName = mkStrLitTy . flLabel++        mbSel Nothing  = mkTyConApp promotedNothingDataCon [typeSymbolKind]+        mbSel (Just s) = mkTyConApp promotedJustDataCon+                                    [typeSymbolKind, selName s]++        metaDataTy   = mkTyConApp md [dtName, mdName, pkgName, isNT]+        metaConsTy c = mkTyConApp mc [ctName c, ctFix c, isRec c]+        metaSelTy mlbl su ss ib =+            mkTyConApp ms [mbSel mlbl, pSUpkness, pSStrness, pDStrness]+          where+            pSUpkness = mkTyConTy $ case su of+                                         SrcUnpack   -> pSUpk+                                         SrcNoUnpack -> pSNUpk+                                         NoSrcUnpack -> pNSUpkness++            pSStrness = mkTyConTy $ case ss of+                                         SrcLazy     -> pSLzy+                                         SrcStrict   -> pSStr+                                         NoSrcStrict -> pNSStrness++            pDStrness = mkTyConTy $ case ib of+                                         HsLazy      -> pDLzy+                                         HsStrict    -> pDStr+                                         HsUnpack{}  -> pDUpk++    return (mkD tycon)++mkComp :: TyCon -> Kind -> Type -> Type -> Type+mkComp comp k f g+  | k1_first  = mkTyConApp comp  [k,liftedTypeKind,f,g]+  | otherwise = mkTyConApp comp  [liftedTypeKind,k,f,g]+  where+    -- Which of these is the case?+    --     newtype (:.:) {k1} {k2} (f :: k2->*) (g :: k1->k2) (p :: k1) = ...+    -- or  newtype (:.:) {k2} {k1} (f :: k2->*) (g :: k1->k2) (p :: k1) = ...+    -- We want to instantiate with k1=k, and k2=*+    --    Reason for k2=*: see Note [Handling kinds in a Rep instance]+    -- But we need to know which way round!+    k1_first = k_first == p_kind_var+    [k_first,_,_,_,p] = tyConTyVars comp+    Just p_kind_var = getTyVar_maybe (tyVarKind p)++-- Given the TyCons for each URec-related type synonym, check to see if the+-- given type is an unlifted type that generics understands. If so, return+-- its representation type. Otherwise, return Rec0.+-- See Note [Generics and unlifted types]+mkBoxTy :: TyCon -- UAddr+        -> TyCon -- UChar+        -> TyCon -- UDouble+        -> TyCon -- UFloat+        -> TyCon -- UInt+        -> TyCon -- UWord+        -> TyCon -- Rec0+        -> Kind  -- What to instantiate Rec0's kind variable with+        -> Type+        -> Type+mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k ty+  | ty `eqType` addrPrimTy   = mkTyConApp uAddr   [k]+  | ty `eqType` charPrimTy   = mkTyConApp uChar   [k]+  | ty `eqType` doublePrimTy = mkTyConApp uDouble [k]+  | ty `eqType` floatPrimTy  = mkTyConApp uFloat  [k]+  | ty `eqType` intPrimTy    = mkTyConApp uInt    [k]+  | ty `eqType` wordPrimTy   = mkTyConApp uWord   [k]+  | otherwise                = mkTyConApp rec0    [k,ty]++--------------------------------------------------------------------------------+-- Dealing with sums+--------------------------------------------------------------------------------++mkSum :: GenericKind_ -- Generic or Generic1?+      -> US          -- Base for generating unique names+      -> TyCon       -- The type constructor+      -> [DataCon]   -- The data constructors+      -> ([Alt],     -- Alternatives for the T->Trep "from" function+          [Alt])     -- Alternatives for the Trep->T "to" function++-- Datatype without any constructors+mkSum _ _ tycon [] = ([from_alt], [to_alt])+  where+    from_alt = (nlWildPat, makeError errMsgFrom)+    to_alt   = (nlWildPat, makeError errMsgTo)+               -- These M1s are meta-information for the datatype+    makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s))+    tyConStr   = occNameString (nameOccName (tyConName tycon))+    errMsgFrom = "No generic representation for empty datatype " ++ tyConStr+    errMsgTo   = "No values for empty datatype " ++ tyConStr++-- Datatype with at least one constructor+mkSum gk_ us _ datacons =+  -- switch the payload of gk_ to be datacon-centric instead of tycon-centric+ unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) d+           | (d,i) <- zip datacons [1..] ]++-- Build the sum for a particular constructor+mk1Sum :: GenericKind_DC -- Generic or Generic1?+       -> US        -- Base for generating unique names+       -> Int       -- The index of this constructor+       -> Int       -- Total number of constructors+       -> DataCon   -- The data constructor+       -> (Alt,     -- Alternative for the T->Trep "from" function+           Alt)     -- Alternative for the Trep->T "to" function+mk1Sum gk_ us i n datacon = (from_alt, to_alt)+  where+    gk = forgetArgVar gk_++    -- Existentials already excluded+    argTys = dataConOrigArgTys datacon+    n_args = dataConSourceArity datacon++    datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) argTys+    datacon_vars = map fst datacon_varTys+    us'          = us + n_args++    datacon_rdr  = getRdrName datacon++    from_alt     = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)+    from_alt_rhs = genLR_E i n (mkProd_E gk_ us' datacon_varTys)++    to_alt     = ( genLR_P i n (mkProd_P gk us' datacon_varTys)+                 , to_alt_rhs+                 ) -- These M1s are meta-information for the datatype+    to_alt_rhs = case gk_ of+      Gen0_DC        -> nlHsVarApps datacon_rdr datacon_vars+      Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys+        where+          argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where+            converter = argTyFold argVar $ ArgTyAlg+              {ata_rec0 = nlHsVar . unboxRepRDR,+               ata_par1 = nlHsVar unPar1_RDR,+               ata_rec1 = const $ nlHsVar unRec1_RDR,+               ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv)+                                    `nlHsCompose` nlHsVar unComp1_RDR}+++-- Generates the L1/R1 sum pattern+genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName+genLR_P i n p+  | n == 0       = error "impossible"+  | n == 1       = p+  | i <= div n 2 = nlParPat $ nlConPat l1DataCon_RDR [genLR_P i     (div n 2) p]+  | otherwise    = nlParPat $ nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m)     p]+                     where m = div n 2++-- Generates the L1/R1 sum expression+genLR_E :: Int -> Int -> LHsExpr RdrName -> LHsExpr RdrName+genLR_E i n e+  | n == 0       = error "impossible"+  | n == 1       = e+  | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp`+                                            nlHsPar (genLR_E i     (div n 2) e)+  | otherwise    = nlHsVar r1DataCon_RDR `nlHsApp`+                                            nlHsPar (genLR_E (i-m) (n-m)     e)+                     where m = div n 2++--------------------------------------------------------------------------------+-- Dealing with products+--------------------------------------------------------------------------------++-- Build a product expression+mkProd_E :: GenericKind_DC    -- Generic or Generic1?+         -> US                -- Base for unique names+         -> [(RdrName, Type)] -- List of variables matched on the lhs and their types+         -> LHsExpr RdrName   -- Resulting product expression+mkProd_E _   _ []     = mkM1_E (nlHsVar u1DataCon_RDR)+mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars)+                     -- These M1s are meta-information for the constructor+  where+    appVars = map (wrapArg_E gk_) varTys+    prod a b = prodDataCon_RDR `nlHsApps` [a,b]++wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr RdrName+wrapArg_E Gen0_DC          (var, ty) = mkM1_E $+                            boxRepRDR ty `nlHsVarApps` [var]+                         -- This M1 is meta-information for the selector+wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $+                            converter ty `nlHsApp` nlHsVar var+                         -- This M1 is meta-information for the selector+  where converter = argTyFold argVar $ ArgTyAlg+          {ata_rec0 = nlHsVar . boxRepRDR,+           ata_par1 = nlHsVar par1DataCon_RDR,+           ata_rec1 = const $ nlHsVar rec1DataCon_RDR,+           ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose`+                                  (nlHsVar fmap_RDR `nlHsApp` cnv)}++boxRepRDR :: Type -> RdrName+boxRepRDR = maybe k1DataCon_RDR fst . unboxedRepRDRs++unboxRepRDR :: Type -> RdrName+unboxRepRDR = maybe unK1_RDR snd . unboxedRepRDRs++-- Retrieve the RDRs associated with each URec data family instance+-- constructor. See Note [Generics and unlifted types]+unboxedRepRDRs :: Type -> Maybe (RdrName, RdrName)+unboxedRepRDRs ty+  | ty `eqType` addrPrimTy   = Just (uAddrDataCon_RDR,   uAddrHash_RDR)+  | ty `eqType` charPrimTy   = Just (uCharDataCon_RDR,   uCharHash_RDR)+  | ty `eqType` doublePrimTy = Just (uDoubleDataCon_RDR, uDoubleHash_RDR)+  | ty `eqType` floatPrimTy  = Just (uFloatDataCon_RDR,  uFloatHash_RDR)+  | ty `eqType` intPrimTy    = Just (uIntDataCon_RDR,    uIntHash_RDR)+  | ty `eqType` wordPrimTy   = Just (uWordDataCon_RDR,   uWordHash_RDR)+  | otherwise          = Nothing++-- Build a product pattern+mkProd_P :: GenericKind       -- Gen0 or Gen1+         -> US                -- Base for unique names+         -> [(RdrName, Type)] -- List of variables to match,+                              --   along with their types+         -> LPat RdrName      -- Resulting product pattern+mkProd_P _  _ []     = mkM1_P (nlNullaryConPat u1DataCon_RDR)+mkProd_P gk _ varTys = mkM1_P (foldBal prod appVars)+                     -- These M1s are meta-information for the constructor+  where+    appVars = unzipWith (wrapArg_P gk) varTys+    prod a b = nlParPat $ prodDataCon_RDR `nlConPat` [a,b]++wrapArg_P :: GenericKind -> RdrName -> Type -> LPat RdrName+wrapArg_P Gen0 v ty = mkM1_P (nlParPat $ boxRepRDR ty `nlConVarPat` [v])+                   -- This M1 is meta-information for the selector+wrapArg_P Gen1 v _  = nlParPat $ m1DataCon_RDR `nlConVarPat` [v]++mkGenericLocal :: US -> RdrName+mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))++x_RDR :: RdrName+x_RDR = mkVarUnqual (fsLit "x")++x_Expr :: LHsExpr RdrName+x_Expr = nlHsVar x_RDR++x_Pat :: LPat RdrName+x_Pat = nlVarPat x_RDR++mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName+mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e++mkM1_P :: LPat RdrName -> LPat RdrName+mkM1_P p = nlParPat $ m1DataCon_RDR `nlConPat` [p]++nlHsCompose :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName+nlHsCompose x y = compose_RDR `nlHsApps` [x, y]++-- | Variant of foldr1 for producing balanced lists+foldBal :: (a -> a -> a) -> [a] -> a+foldBal op = foldBal' op (error "foldBal: empty list")++foldBal' :: (a -> a -> a) -> a -> [a] -> a+foldBal' _  x []  = x+foldBal' _  _ [y] = y+foldBal' op x l   = let (a,b) = splitAt (length l `div` 2) l+                    in foldBal' op x a `op` foldBal' op x b++{-+Note [Generics and unlifted types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Normally, all constants are marked with K1/Rec0. The exception to this rule is+when a data constructor has an unlifted argument (e.g., Int#, Char#, etc.). In+that case, we must use a data family instance of URec (from GHC.Generics) to+mark it. As a result, before we can generate K1 or unK1, we must first check+to see if the type is actually one of the unlifted types for which URec has a+data family instance; if so, we generate that instead.++See wiki:Commentary/Compiler/GenericDeriving#Handlingunliftedtypes for more+details on why URec is implemented the way it is.++Note [Generating a correctly typed Rep instance]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+tc_mkRepTy derives the RHS of the Rep(1) type family instance when deriving+Generic(1). That is, it derives the ellipsis in the following:++    instance Generic Foo where+      type Rep Foo = ...++However, tc_mkRepTy only has knowledge of the *TyCon* of the type for which+a Generic(1) instance is being derived, not the fully instantiated type. As a+result, tc_mkRepTy builds the most generalized Rep(1) instance possible using+the type variables it learns from the TyCon (i.e., it uses tyConTyVars). This+can cause problems when the instance has instantiated type variables+(see Trac #11732). As an example:++    data T a = MkT a+    deriving instance Generic (T Int)+    ==>+    instance Generic (T Int) where+      type Rep (T Int) = (... (Rec0 a)) -- wrong!++-XStandaloneDeriving is one way for the type variables to become instantiated.+Another way is when Generic1 is being derived for a datatype with a visible+kind binder, e.g.,++   data P k (a :: k) = MkP k deriving Generic1+   ==>+   instance Generic1 (P *) where+     type Rep1 (P *) = (... (Rec0 k)) -- wrong!++See Note [Unify kinds in deriving] in TcDeriv.++In any such scenario, we must prevent a discrepancy between the LHS and RHS of+a Rep(1) instance. To do so, we create a type variable substitution that maps+the tyConTyVars of the TyCon to their counterparts in the fully instantiated+type. (For example, using T above as example, you'd map a :-> Int.) We then+apply the substitution to the RHS before generating the instance.++Note [Handling kinds in a Rep instance]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Because Generic1 is poly-kinded, the representation types were generalized to+be kind-polymorphic as well. As a result, tc_mkRepTy must explicitly apply+the kind of the instance being derived to all the representation type+constructors. For instance, if you have++    data Empty (a :: k) = Empty deriving Generic1++Then the generated code is now approximately (with -fprint-explicit-kinds+syntax):++    instance Generic1 k (Empty k) where+      type Rep1 k (Empty k) = U1 k++Most representation types have only one kind variable, making them easy to deal+with. The only non-trivial case is (:.:), which is only used in Generic1+instances:++    newtype (:.:) (f :: k2 -> *) (g :: k1 -> k2) (p :: k1) =+        Comp1 { unComp1 :: f (g p) }++Here, we do something a bit counter-intuitive: we make k1 be the kind of the+instance being derived, and we always make k2 be *. Why *? It's because+the code that GHC generates using (:.:) is always of the form x :.: Rec1 y+for some types x and y. In other words, the second type to which (:.:) is+applied always has kind k -> *, for some kind k, so k2 cannot possibly be+anything other than * in a generated Generic1 instance.++Note [Generics compilation speed tricks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Deriving Generic(1) is known to have a large constant factor during+compilation, which contributes to noticeable compilation slowdowns when+deriving Generic(1) for large datatypes (see Trac #5642).++To ease the pain, there is a trick one can play when generating definitions for+to(1) and from(1). If you have a datatype like:++  data Letter = A | B | C | D++then a naïve Generic instance for Letter would be:++  instance Generic Letter where+    type Rep Letter = D1 ('MetaData ...) ...++    to (M1 (L1 (L1 (M1 U1)))) = A+    to (M1 (L1 (R1 (M1 U1)))) = B+    to (M1 (R1 (L1 (M1 U1)))) = C+    to (M1 (R1 (R1 (M1 U1)))) = D++    from A = M1 (L1 (L1 (M1 U1)))+    from B = M1 (L1 (R1 (M1 U1)))+    from C = M1 (R1 (L1 (M1 U1)))+    from D = M1 (R1 (R1 (M1 U1)))++Notice that in every LHS pattern-match of the 'to' definition, and in every RHS+expression in the 'from' definition, the topmost constructor is M1. This+corresponds to the datatype-specific metadata (the D1 in the Rep Letter+instance). But this is wasteful from a typechecking perspective, since this+definition requires GHC to typecheck an application of M1 in every single case,+leading to an O(n) increase in the number of coercions the typechecker has to+solve, which in turn increases allocations and degrades compilation speed.++Luckily, since the topmost M1 has the exact same type across every case, we can+factor it out reduce the typechecker's burden:++  instance Generic Letter where+    type Rep Letter = D1 ('MetaData ...) ...++    to (M1 x) = case x of+      L1 (L1 (M1 U1)) -> A+      L1 (R1 (M1 U1)) -> B+      R1 (L1 (M1 U1)) -> C+      R1 (R1 (M1 U1)) -> D++    from x = M1 (case x of+      A -> L1 (L1 (M1 U1))+      B -> L1 (R1 (M1 U1))+      C -> R1 (L1 (M1 U1))+      D -> R1 (R1 (M1 U1)))++A simple change, but one that pays off, since it goes turns an O(n) amount of+coercions to an O(1) amount.+-}
+ typecheck/TcHsSyn.hs view
@@ -0,0 +1,1700 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1996-1998+++TcHsSyn: Specialisations of the @HsSyn@ syntax for the typechecker++This module is an extension of @HsSyn@ syntax, for use in the type+checker.+-}++{-# LANGUAGE CPP, TupleSections #-}++module TcHsSyn (+        -- * Extracting types from HsSyn+        hsLitType, hsLPatType, hsPatType,++        -- * Other HsSyn functions+        mkHsDictLet, mkHsApp,+        mkHsAppTy, mkHsCaseAlt,+        nlHsIntLit,+        shortCutLit, hsOverLitName,+        conLikeResTy,++        -- * re-exported from TcMonad+        TcId, TcIdSet,++        -- * Zonking+        -- | For a description of "zonking", see Note [What is zonking?]+        -- in TcMType+        zonkTopDecls, zonkTopExpr, zonkTopLExpr,+        zonkTopBndrs, zonkTyBndrsX,+        zonkTyVarBindersX, zonkTyVarBinderX,+        emptyZonkEnv, mkEmptyZonkEnv,+        zonkTcTypeToType, zonkTcTypeToTypes, zonkTyVarOcc,+        zonkCoToCo, zonkSigType,+        zonkEvBinds,+  ) where++#include "HsVersions.h"++import HsSyn+import Id+import IdInfo+import TcRnMonad+import PrelNames+import TcType+import TcMType+import TcEvidence+import TysPrim+import TyCon   ( isUnboxedTupleTyCon )+import TysWiredIn+import Type+import Coercion+import ConLike+import DataCon+import HscTypes+import Name+import NameEnv+import Var+import VarEnv+import DynFlags+import Literal+import BasicTypes+import Maybes+import SrcLoc+import Bag+import Outputable+import Util+import UniqFM++import Control.Monad+import Data.List  ( partition )+import Control.Arrow ( second )++{-+************************************************************************+*                                                                      *+       Extracting the type from HsSyn+*                                                                      *+************************************************************************++-}++hsLPatType :: OutPat Id -> Type+hsLPatType (L _ pat) = hsPatType pat++hsPatType :: Pat Id -> Type+hsPatType (ParPat pat)                = hsLPatType pat+hsPatType (WildPat ty)                = ty+hsPatType (VarPat (L _ var))          = idType var+hsPatType (BangPat pat)               = hsLPatType pat+hsPatType (LazyPat pat)               = hsLPatType pat+hsPatType (LitPat lit)                = hsLitType lit+hsPatType (AsPat var _)               = idType (unLoc var)+hsPatType (ViewPat _ _ ty)            = ty+hsPatType (ListPat _ ty Nothing)      = mkListTy ty+hsPatType (ListPat _ _ (Just (ty,_))) = ty+hsPatType (PArrPat _ ty)              = mkPArrTy ty+hsPatType (TuplePat _ bx tys)         = mkTupleTy bx tys+hsPatType (SumPat _ _ _ tys)          = mkSumTy tys+hsPatType (ConPatOut { pat_con = L _ con, pat_arg_tys = tys })+                                      = conLikeResTy con tys+hsPatType (SigPatOut _ ty)            = ty+hsPatType (NPat _ _ _ ty)             = ty+hsPatType (NPlusKPat _ _ _ _ _ ty)    = ty+hsPatType (CoPat _ _ ty)              = ty+hsPatType p                           = pprPanic "hsPatType" (ppr p)++hsLitType :: HsLit -> TcType+hsLitType (HsChar _ _)       = charTy+hsLitType (HsCharPrim _ _)   = charPrimTy+hsLitType (HsString _ _)     = stringTy+hsLitType (HsStringPrim _ _) = addrPrimTy+hsLitType (HsInt _ _)        = intTy+hsLitType (HsIntPrim _ _)    = intPrimTy+hsLitType (HsWordPrim _ _)   = wordPrimTy+hsLitType (HsInt64Prim _ _)  = int64PrimTy+hsLitType (HsWord64Prim _ _) = word64PrimTy+hsLitType (HsInteger _ _ ty) = ty+hsLitType (HsRat _ ty)       = ty+hsLitType (HsFloatPrim _)    = floatPrimTy+hsLitType (HsDoublePrim _)   = doublePrimTy++-- Overloaded literals. Here mainly because it uses isIntTy etc++shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr TcId)+shortCutLit dflags (HsIntegral src i) ty+  | isIntTy ty  && inIntRange  dflags i = Just (HsLit (HsInt src i))+  | isWordTy ty && inWordRange dflags i+                                   = Just (mkLit wordDataCon (HsWordPrim src i))+  | isIntegerTy ty = Just (HsLit (HsInteger src i ty))+  | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit i)) ty+        -- The 'otherwise' case is important+        -- Consider (3 :: Float).  Syntactically it looks like an IntLit,+        -- so we'll call shortCutIntLit, but of course it's a float+        -- This can make a big difference for programs with a lot of+        -- literals, compiled without -O++shortCutLit _ (HsFractional f) ty+  | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim f))+  | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f))+  | otherwise     = Nothing++shortCutLit _ (HsIsString src s) ty+  | isStringTy ty = Just (HsLit (HsString src s))+  | otherwise     = Nothing++mkLit :: DataCon -> HsLit -> HsExpr Id+mkLit con lit = HsApp (nlHsDataCon con) (nlHsLit lit)++------------------------------+hsOverLitName :: OverLitVal -> Name+-- Get the canonical 'fromX' name for a particular OverLitVal+hsOverLitName (HsIntegral {})   = fromIntegerName+hsOverLitName (HsFractional {}) = fromRationalName+hsOverLitName (HsIsString {})   = fromStringName++{-+************************************************************************+*                                                                      *+\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}+*                                                                      *+************************************************************************++The rest of the zonking is done *after* typechecking.+The main zonking pass runs over the bindings++ a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc+ b) convert unbound TcTyVar to Void+ c) convert each TcId to an Id by zonking its type++The type variables are converted by binding mutable tyvars to immutable ones+and then zonking as normal.++The Ids are converted by binding them in the normal Tc envt; that+way we maintain sharing; eg an Id is zonked at its binding site and they+all occurrences of that Id point to the common zonked copy++It's all pretty boring stuff, because HsSyn is such a large type, and+the environment manipulation is tiresome.+-}++-- Confused by zonking? See Note [What is zonking?] in TcMType.+type UnboundTyVarZonker = TcTyVar -> TcM Type+        -- How to zonk an unbound type variable+        -- The TcTyVar is+        --     (a) a MetaTv+        --     (b) Flexi and+        --     (c) its kind is already zonked+        -- Note [Zonking the LHS of a RULE]++-- | A ZonkEnv carries around several bits.+-- The UnboundTyVarZonker just zaps unbouned meta-tyvars to Any (as+-- defined in zonkTypeZapping), except on the LHS of rules. See+-- Note [Zonking the LHS of a RULE].+--+-- The (TyCoVarEnv TyVar) and is just an optimisation: when binding a+-- tyvar or covar, we zonk the kind right away and add a mapping to+-- the env. This prevents re-zonking the kind at every occurrence. But+-- this is *just* an optimisation.+--+-- The final (IdEnv Var) optimises zonking for Ids. It is+-- knot-tied. We must be careful never to put coercion variables+-- (which are Ids, after all) in the knot-tied env, because coercions+-- can appear in types, and we sometimes inspect a zonked type in this+-- module.+--+-- Confused by zonking? See Note [What is zonking?] in TcMType.+data ZonkEnv+  = ZonkEnv+      UnboundTyVarZonker+      (TyCoVarEnv TyVar)+      (IdEnv      Var)         -- What variables are in scope+        -- Maps an Id or EvVar to its zonked version; both have the same Name+        -- Note that all evidence (coercion variables as well as dictionaries)+        --      are kept in the ZonkEnv+        -- Only *type* abstraction is done by side effect+        -- Is only consulted lazily; hence knot-tying++instance Outputable ZonkEnv where+  ppr (ZonkEnv _ _ty_env var_env) = pprUFM var_env (vcat . map ppr)+++-- The EvBinds have to already be zonked, but that's usually the case.+emptyZonkEnv :: ZonkEnv+emptyZonkEnv = mkEmptyZonkEnv zonkTypeZapping++mkEmptyZonkEnv :: UnboundTyVarZonker -> ZonkEnv+mkEmptyZonkEnv zonker = ZonkEnv zonker emptyVarEnv emptyVarEnv++-- | Extend the knot-tied environment.+extendIdZonkEnvRec :: ZonkEnv -> [Var] -> ZonkEnv+extendIdZonkEnvRec (ZonkEnv zonk_ty ty_env id_env) ids+    -- NB: Don't look at the var to decide which env't to put it in. That+    -- would end up knot-tying all the env'ts.+  = ZonkEnv zonk_ty ty_env (extendVarEnvList id_env [(id,id) | id <- ids])+  -- Given coercion variables will actually end up here. That's OK though:+  -- coercion variables are never looked up in the knot-tied env't, so zonking+  -- them simply doesn't get optimised. No one gets hurt. An improvement (?)+  -- would be to do SCC analysis in zonkEvBinds and then only knot-tie the+  -- recursive groups. But perhaps the time it takes to do the analysis is+  -- more than the savings.++extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv+extendZonkEnv (ZonkEnv zonk_ty tyco_env id_env) vars+  = ZonkEnv zonk_ty (extendVarEnvList tyco_env [(tv,tv) | tv <- tycovars])+                    (extendVarEnvList id_env   [(id,id) | id <- ids])+  where (tycovars, ids) = partition isTyCoVar vars++extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv+extendIdZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) id+  = ZonkEnv zonk_ty ty_env (extendVarEnv id_env id id)++extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv+extendTyZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) tv+  = ZonkEnv zonk_ty (extendVarEnv ty_env tv tv) id_env++setZonkType :: ZonkEnv -> UnboundTyVarZonker -> ZonkEnv+setZonkType (ZonkEnv _ ty_env id_env) zonk_ty+  = ZonkEnv zonk_ty ty_env id_env++zonkEnvIds :: ZonkEnv -> TypeEnv+zonkEnvIds (ZonkEnv _ _ id_env) =+  mkNameEnv [(getName id, AnId id) | id <- nonDetEltsUFM id_env]+  -- It's OK to use nonDetEltsUFM here because we forget the ordering+  -- immediately by creating a TypeEnv++zonkIdOcc :: ZonkEnv -> TcId -> Id+-- Ids defined in this module should be in the envt;+-- ignore others.  (Actually, data constructors are also+-- not LocalVars, even when locally defined, but that is fine.)+-- (Also foreign-imported things aren't currently in the ZonkEnv;+--  that's ok because they don't need zonking.)+--+-- Actually, Template Haskell works in 'chunks' of declarations, and+-- an earlier chunk won't be in the 'env' that the zonking phase+-- carries around.  Instead it'll be in the tcg_gbl_env, already fully+-- zonked.  There's no point in looking it up there (except for error+-- checking), and it's not conveniently to hand; hence the simple+-- 'orElse' case in the LocalVar branch.+--+-- Even without template splices, in module Main, the checking of+-- 'main' is done as a separate chunk.+zonkIdOcc (ZonkEnv _zonk_ty _ty_env id_env) id+  | isLocalVar id = lookupVarEnv id_env id `orElse`+                    id+  | otherwise     = id++zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]+zonkIdOccs env ids = map (zonkIdOcc env) ids++-- zonkIdBndr is used *after* typechecking to get the Id's type+-- to its final form.  The TyVarEnv give+zonkIdBndr :: ZonkEnv -> TcId -> TcM Id+zonkIdBndr env v+  = do ty' <- zonkTcTypeToType env (idType v)+       ensureNotLevPoly ty'+         (text "In the type of binder" <+> quotes (ppr v))++       return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdType v ty'))++zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]+zonkIdBndrs env ids = mapM (zonkIdBndr env) ids++zonkTopBndrs :: [TcId] -> TcM [Id]+zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids++zonkFieldOcc :: ZonkEnv -> FieldOcc TcId -> TcM (FieldOcc Id)+zonkFieldOcc env (FieldOcc lbl sel) = fmap (FieldOcc lbl) $ zonkIdBndr env sel++zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])+zonkEvBndrsX = mapAccumLM zonkEvBndrX++zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)+-- Works for dictionaries and coercions+zonkEvBndrX env var+  = do { var' <- zonkEvBndr env var+       ; return (extendZonkEnv env [var'], var') }++zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar+-- Works for dictionaries and coercions+-- Does not extend the ZonkEnv+zonkEvBndr env var+  = do { let var_ty = varType var+       ; ty <-+           {-# SCC "zonkEvBndr_zonkTcTypeToType" #-}+           zonkTcTypeToType env var_ty+       ; return (setVarType var ty) }++zonkEvVarOcc :: ZonkEnv -> EvVar -> TcM EvTerm+zonkEvVarOcc env v+  | isCoVar v+  = EvCoercion <$> zonkCoVarOcc env v+  | otherwise+  = return (EvId $ zonkIdOcc env v)++zonkTyBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TyVar])+zonkTyBndrsX = mapAccumLM zonkTyBndrX++zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar)+-- This guarantees to return a TyVar (not a TcTyVar)+-- then we add it to the envt, so all occurrences are replaced+zonkTyBndrX env tv+  = ASSERT( isImmutableTyVar tv )+    do { ki <- zonkTcTypeToType env (tyVarKind tv)+               -- Internal names tidy up better, for iface files.+       ; let tv' = mkTyVar (tyVarName tv) ki+       ; return (extendTyZonkEnv1 env tv', tv') }++zonkTyVarBindersX :: ZonkEnv -> [TyVarBndr TcTyVar vis]+                             -> TcM (ZonkEnv, [TyVarBndr TyVar vis])+zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX++zonkTyVarBinderX :: ZonkEnv -> TyVarBndr TcTyVar vis+                            -> TcM (ZonkEnv, TyVarBndr TyVar vis)+-- Takes a TcTyVar and guarantees to return a TyVar+zonkTyVarBinderX env (TvBndr tv vis)+  = do { (env', tv') <- zonkTyBndrX env tv+       ; return (env', TvBndr tv' vis) }++zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)+zonkTopExpr e = zonkExpr emptyZonkEnv e++zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)+zonkTopLExpr e = zonkLExpr emptyZonkEnv e++zonkTopDecls :: Bag EvBind+             -> LHsBinds TcId+             -> [LRuleDecl TcId] -> [LVectDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId]+             -> TcM (TypeEnv,+                     Bag EvBind,+                     LHsBinds Id,+                     [LForeignDecl Id],+                     [LTcSpecPrag],+                     [LRuleDecl    Id],+                     [LVectDecl    Id])+zonkTopDecls ev_binds binds rules vects imp_specs fords+  = do  { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds+        ; (env2, binds') <- zonkRecMonoBinds env1 binds+                        -- Top level is implicitly recursive+        ; rules' <- zonkRules env2 rules+        ; vects' <- zonkVects env2 vects+        ; specs' <- zonkLTcSpecPrags env2 imp_specs+        ; fords' <- zonkForeignExports env2 fords+        ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules', vects') }++---------------------------------------------+zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)+zonkLocalBinds env EmptyLocalBinds+  = return (env, EmptyLocalBinds)++zonkLocalBinds _ (HsValBinds (ValBindsIn {}))+  = panic "zonkLocalBinds" -- Not in typechecker output++zonkLocalBinds env (HsValBinds (ValBindsOut binds sigs))+  = do  { (env1, new_binds) <- go env binds+        ; return (env1, HsValBinds (ValBindsOut new_binds sigs)) }+  where+    go env []+      = return (env, [])+    go env ((r,b):bs)+      = do { (env1, b')  <- zonkRecMonoBinds env b+           ; (env2, bs') <- go env1 bs+           ; return (env2, (r,b'):bs') }++zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) = do+    new_binds <- mapM (wrapLocM zonk_ip_bind) binds+    let+        env1 = extendIdZonkEnvRec env [ n | L _ (IPBind (Right n) _) <- new_binds]+    (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds+    return (env2, HsIPBinds (IPBinds new_binds new_dict_binds))+  where+    zonk_ip_bind (IPBind n e)+        = do n' <- mapIPNameTc (zonkIdBndr env) n+             e' <- zonkLExpr env e+             return (IPBind n' e')++---------------------------------------------+zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)+zonkRecMonoBinds env binds+ = fixM (\ ~(_, new_binds) -> do+        { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds)+        ; binds' <- zonkMonoBinds env1 binds+        ; return (env1, binds') })++---------------------------------------------+zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)+zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds++zonk_lbind :: ZonkEnv -> LHsBind TcId -> TcM (LHsBind Id)+zonk_lbind env = wrapLocM (zonk_bind env)++zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)+zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})+  = do  { (_env, new_pat) <- zonkPat env pat            -- Env already extended+        ; new_grhss <- zonkGRHSs env zonkLExpr grhss+        ; new_ty    <- zonkTcTypeToType env ty+        ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) }++zonk_bind env (VarBind { var_id = var, var_rhs = expr, var_inline = inl })+  = do { new_var  <- zonkIdBndr env var+       ; new_expr <- zonkLExpr env expr+       ; return (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl }) }++zonk_bind env bind@(FunBind { fun_id = L loc var, fun_matches = ms+                            , fun_co_fn = co_fn })+  = do { new_var <- zonkIdBndr env var+       ; (env1, new_co_fn) <- zonkCoFn env co_fn+       ; new_ms <- zonkMatchGroup env1 zonkLExpr ms+       ; return (bind { fun_id = L loc new_var, fun_matches = new_ms+                      , fun_co_fn = new_co_fn }) }++zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs+                        , abs_ev_binds = ev_binds+                        , abs_exports = exports+                        , abs_binds = val_binds })+  = ASSERT( all isImmutableTyVar tyvars )+    do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars+       ; (env1, new_evs) <- zonkEvBndrsX env0 evs+       ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds+       ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->+         do { let env3 = extendIdZonkEnvRec env2+                           (collectHsBindsBinders new_val_binds)+            ; new_val_binds <- zonkMonoBinds env3 val_binds+            ; new_exports   <- mapM (zonkExport env3) exports+            ; return (new_val_binds, new_exports) }+       ; return (AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs+                          , abs_ev_binds = new_ev_binds+                          , abs_exports = new_exports, abs_binds = new_val_bind }) }+  where+    zonkExport env (ABE{ abe_wrap = wrap+                       , abe_poly = poly_id+                       , abe_mono = mono_id, abe_prags = prags })+        = do new_poly_id <- zonkIdBndr env poly_id+             (_, new_wrap) <- zonkCoFn env wrap+             new_prags <- zonkSpecPrags env prags+             return (ABE{ abe_wrap = new_wrap+                        , abe_poly = new_poly_id+                        , abe_mono = zonkIdOcc env mono_id+                        , abe_prags = new_prags })++zonk_bind env outer_bind@(AbsBindsSig { abs_tvs         = tyvars+                                      , abs_ev_vars     = evs+                                      , abs_sig_export  = poly+                                      , abs_sig_prags   = prags+                                      , abs_sig_ev_bind = ev_bind+                                      , abs_sig_bind    = lbind })+  | L bind_loc bind@(FunBind { fun_id      = L loc local+                             , fun_matches = ms+                             , fun_co_fn   = co_fn }) <- lbind+  = ASSERT( all isImmutableTyVar tyvars )+    do { (env0, new_tyvars)  <- zonkTyBndrsX env  tyvars+       ; (env1, new_evs)     <- zonkEvBndrsX env0 evs+       ; (env2, new_ev_bind) <- zonkTcEvBinds env1 ev_bind+           -- Inline zonk_bind (FunBind ...) because we wish to skip+           -- the check for representation-polymorphic binders. The+           -- local binder in the FunBind in an AbsBindsSig is never actually+           -- bound in Core -- indeed, that's the whole point of AbsBindsSig.+           -- just calling zonk_bind causes #11405.+       ; new_local           <- updateVarTypeM (zonkTcTypeToType env2) local+       ; (env3, new_co_fn)   <- zonkCoFn env2 co_fn+       ; new_ms              <- zonkMatchGroup env3 zonkLExpr ms+           -- If there is a representation polymorphism problem, it will+           -- be caught here:+       ; new_poly_id         <- zonkIdBndr env2 poly+       ; new_prags           <- zonkSpecPrags env2 prags+       ; let new_val_bind = L bind_loc (bind { fun_id      = L loc new_local+                                             , fun_matches = new_ms+                                             , fun_co_fn   = new_co_fn })+       ; return (AbsBindsSig { abs_tvs         = new_tyvars+                             , abs_ev_vars     = new_evs+                             , abs_sig_export  = new_poly_id+                             , abs_sig_prags   = new_prags+                             , abs_sig_ev_bind = new_ev_bind+                             , abs_sig_bind    = new_val_bind  }) }++  | otherwise+  = pprPanic "zonk_bind" (ppr outer_bind)++zonk_bind env (PatSynBind bind@(PSB { psb_id = L loc id+                                    , psb_args = details+                                    , psb_def = lpat+                                    , psb_dir = dir }))+  = do { id' <- zonkIdBndr env id+       ; details' <- zonkPatSynDetails env details+       ; (env1, lpat') <- zonkPat env lpat+       ; (_env2, dir') <- zonkPatSynDir env1 dir+       ; return $ PatSynBind $+                  bind { psb_id = L loc id'+                       , psb_args = details'+                       , psb_def = lpat'+                       , psb_dir = dir' } }++zonkPatSynDetails :: ZonkEnv+                  -> HsPatSynDetails (Located TcId)+                  -> TcM (HsPatSynDetails (Located Id))+zonkPatSynDetails env = traverse (wrapLocM $ zonkIdBndr env)++zonkPatSynDir :: ZonkEnv -> HsPatSynDir TcId -> TcM (ZonkEnv, HsPatSynDir Id)+zonkPatSynDir env Unidirectional = return (env, Unidirectional)+zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional)+zonkPatSynDir env (ExplicitBidirectional mg) = do+    mg' <- zonkMatchGroup env zonkLExpr mg+    return (env, ExplicitBidirectional mg')++zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags+zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod+zonkSpecPrags env (SpecPrags ps)  = do { ps' <- zonkLTcSpecPrags env ps+                                       ; return (SpecPrags ps') }++zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]+zonkLTcSpecPrags env ps+  = mapM zonk_prag ps+  where+    zonk_prag (L loc (SpecPrag id co_fn inl))+        = do { (_, co_fn') <- zonkCoFn env co_fn+             ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }++{-+************************************************************************+*                                                                      *+\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}+*                                                                      *+************************************************************************+-}++zonkMatchGroup :: ZonkEnv+               -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))+               -> MatchGroup TcId (Located (body TcId)) -> TcM (MatchGroup Id (Located (body Id)))+zonkMatchGroup env zBody (MG { mg_alts = L l ms, mg_arg_tys = arg_tys+                             , mg_res_ty = res_ty, mg_origin = origin })+  = do  { ms' <- mapM (zonkMatch env zBody) ms+        ; arg_tys' <- zonkTcTypeToTypes env arg_tys+        ; res_ty'  <- zonkTcTypeToType env res_ty+        ; return (MG { mg_alts = L l ms', mg_arg_tys = arg_tys'+                     , mg_res_ty = res_ty', mg_origin = origin }) }++zonkMatch :: ZonkEnv+          -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))+          -> LMatch TcId (Located (body TcId)) -> TcM (LMatch Id (Located (body Id)))+zonkMatch env zBody (L loc (Match mf pats _ grhss))+  = do  { (env1, new_pats) <- zonkPats env pats+        ; new_grhss <- zonkGRHSs env1 zBody grhss+        ; return (L loc (Match mf new_pats Nothing new_grhss)) }++-------------------------------------------------------------------------+zonkGRHSs :: ZonkEnv+          -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))+          -> GRHSs TcId (Located (body TcId)) -> TcM (GRHSs Id (Located (body Id)))++zonkGRHSs env zBody (GRHSs grhss (L l binds)) = do+    (new_env, new_binds) <- zonkLocalBinds env binds+    let+        zonk_grhs (GRHS guarded rhs)+          = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded+               new_rhs <- zBody env2 rhs+               return (GRHS new_guarded new_rhs)+    new_grhss <- mapM (wrapLocM zonk_grhs) grhss+    return (GRHSs new_grhss (L l new_binds))++{-+************************************************************************+*                                                                      *+\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}+*                                                                      *+************************************************************************+-}++zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]+zonkLExpr  :: ZonkEnv -> LHsExpr TcId   -> TcM (LHsExpr Id)+zonkExpr   :: ZonkEnv -> HsExpr TcId    -> TcM (HsExpr Id)++zonkLExprs env exprs = mapM (zonkLExpr env) exprs+zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr++zonkExpr env (HsVar (L l id))+  = ASSERT2( isNothing (isDataConId_maybe id), ppr id )+    return (HsVar (L l (zonkIdOcc env id)))++zonkExpr _ e@(HsConLikeOut {}) = return e++zonkExpr _ (HsIPVar id)+  = return (HsIPVar id)++zonkExpr _ e@HsOverLabel{} = return e++zonkExpr env (HsLit (HsRat f ty))+  = do new_ty <- zonkTcTypeToType env ty+       return (HsLit (HsRat f new_ty))++zonkExpr _ (HsLit lit)+  = return (HsLit lit)++zonkExpr env (HsOverLit lit)+  = do  { lit' <- zonkOverLit env lit+        ; return (HsOverLit lit') }++zonkExpr env (HsLam matches)+  = do new_matches <- zonkMatchGroup env zonkLExpr matches+       return (HsLam new_matches)++zonkExpr env (HsLamCase matches)+  = do new_matches <- zonkMatchGroup env zonkLExpr matches+       return (HsLamCase new_matches)++zonkExpr env (HsApp e1 e2)+  = do new_e1 <- zonkLExpr env e1+       new_e2 <- zonkLExpr env e2+       return (HsApp new_e1 new_e2)++zonkExpr env (HsAppTypeOut e t)+  = do new_e <- zonkLExpr env e+       return (HsAppTypeOut new_e t)+       -- NB: the type is an HsType; can't zonk that!++zonkExpr _ e@(HsRnBracketOut _ _)+  = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)++zonkExpr env (HsTcBracketOut body bs)+  = do bs' <- mapM zonk_b bs+       return (HsTcBracketOut body bs')+  where+    zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e+                                      return (PendingTcSplice n e')++zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen+                           return (HsSpliceE s)++zonkExpr env (OpApp e1 op fixity e2)+  = do new_e1 <- zonkLExpr env e1+       new_op <- zonkLExpr env op+       new_e2 <- zonkLExpr env e2+       return (OpApp new_e1 new_op fixity new_e2)++zonkExpr env (NegApp expr op)+  = do (env', new_op) <- zonkSyntaxExpr env op+       new_expr <- zonkLExpr env' expr+       return (NegApp new_expr new_op)++zonkExpr env (HsPar e)+  = do new_e <- zonkLExpr env e+       return (HsPar new_e)++zonkExpr env (SectionL expr op)+  = do new_expr <- zonkLExpr env expr+       new_op   <- zonkLExpr env op+       return (SectionL new_expr new_op)++zonkExpr env (SectionR op expr)+  = do new_op   <- zonkLExpr env op+       new_expr <- zonkLExpr env expr+       return (SectionR new_op new_expr)++zonkExpr env (ExplicitTuple tup_args boxed)+  = do { new_tup_args <- mapM zonk_tup_arg tup_args+       ; return (ExplicitTuple new_tup_args boxed) }+  where+    zonk_tup_arg (L l (Present e)) = do { e' <- zonkLExpr env e+                                        ; return (L l (Present e')) }+    zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToType env t+                                        ; return (L l (Missing t')) }++zonkExpr env (ExplicitSum alt arity expr args)+  = do new_args <- mapM (zonkTcTypeToType env) args+       new_expr <- zonkLExpr env expr+       return (ExplicitSum alt arity new_expr new_args)++zonkExpr env (HsCase expr ms)+  = do new_expr <- zonkLExpr env expr+       new_ms <- zonkMatchGroup env zonkLExpr ms+       return (HsCase new_expr new_ms)++zonkExpr env (HsIf Nothing e1 e2 e3)+  = do new_e1 <- zonkLExpr env e1+       new_e2 <- zonkLExpr env e2+       new_e3 <- zonkLExpr env e3+       return (HsIf Nothing new_e1 new_e2 new_e3)++zonkExpr env (HsIf (Just fun) e1 e2 e3)+  = do (env1, new_fun) <- zonkSyntaxExpr env fun+       new_e1 <- zonkLExpr env1 e1+       new_e2 <- zonkLExpr env1 e2+       new_e3 <- zonkLExpr env1 e3+       return (HsIf (Just new_fun) new_e1 new_e2 new_e3)++zonkExpr env (HsMultiIf ty alts)+  = do { alts' <- mapM (wrapLocM zonk_alt) alts+       ; ty'   <- zonkTcTypeToType env ty+       ; return $ HsMultiIf ty' alts' }+  where zonk_alt (GRHS guard expr)+          = do { (env', guard') <- zonkStmts env zonkLExpr guard+               ; expr'          <- zonkLExpr env' expr+               ; return $ GRHS guard' expr' }++zonkExpr env (HsLet (L l binds) expr)+  = do (new_env, new_binds) <- zonkLocalBinds env binds+       new_expr <- zonkLExpr new_env expr+       return (HsLet (L l new_binds) new_expr)++zonkExpr env (HsDo do_or_lc (L l stmts) ty)+  = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts+       new_ty <- zonkTcTypeToType env ty+       return (HsDo do_or_lc (L l new_stmts) new_ty)++zonkExpr env (ExplicitList ty wit exprs)+  = do (env1, new_wit) <- zonkWit env wit+       new_ty <- zonkTcTypeToType env1 ty+       new_exprs <- zonkLExprs env1 exprs+       return (ExplicitList new_ty new_wit new_exprs)+   where zonkWit env Nothing    = return (env, Nothing)+         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln++zonkExpr env (ExplicitPArr ty exprs)+  = do new_ty <- zonkTcTypeToType env ty+       new_exprs <- zonkLExprs env exprs+       return (ExplicitPArr new_ty new_exprs)++zonkExpr env expr@(RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds })+  = do  { new_con_expr <- zonkExpr env con_expr+        ; new_rbinds   <- zonkRecFields env rbinds+        ; return (expr { rcon_con_expr = new_con_expr+                       , rcon_flds = new_rbinds }) }++zonkExpr env (RecordUpd { rupd_expr = expr, rupd_flds = rbinds+                        , rupd_cons = cons, rupd_in_tys = in_tys+                        , rupd_out_tys = out_tys, rupd_wrap = req_wrap })+  = do  { new_expr    <- zonkLExpr env expr+        ; new_in_tys  <- mapM (zonkTcTypeToType env) in_tys+        ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys+        ; new_rbinds  <- zonkRecUpdFields env rbinds+        ; (_, new_recwrap) <- zonkCoFn env req_wrap+        ; return (RecordUpd { rupd_expr = new_expr, rupd_flds =  new_rbinds+                            , rupd_cons = cons, rupd_in_tys = new_in_tys+                            , rupd_out_tys = new_out_tys, rupd_wrap = new_recwrap }) }++zonkExpr env (ExprWithTySigOut e ty)+  = do { e' <- zonkLExpr env e+       ; return (ExprWithTySigOut e' ty) }++zonkExpr env (ArithSeq expr wit info)+  = do (env1, new_wit) <- zonkWit env wit+       new_expr <- zonkExpr env expr+       new_info <- zonkArithSeq env1 info+       return (ArithSeq new_expr new_wit new_info)+   where zonkWit env Nothing    = return (env, Nothing)+         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln++zonkExpr env (PArrSeq expr info)+  = do new_expr <- zonkExpr env expr+       new_info <- zonkArithSeq env info+       return (PArrSeq new_expr new_info)++zonkExpr env (HsSCC src lbl expr)+  = do new_expr <- zonkLExpr env expr+       return (HsSCC src lbl new_expr)++zonkExpr env (HsTickPragma src info srcInfo expr)+  = do new_expr <- zonkLExpr env expr+       return (HsTickPragma src info srcInfo new_expr)++-- hdaume: core annotations+zonkExpr env (HsCoreAnn src lbl expr)+  = do new_expr <- zonkLExpr env expr+       return (HsCoreAnn src lbl new_expr)++-- arrow notation extensions+zonkExpr env (HsProc pat body)+  = do  { (env1, new_pat) <- zonkPat env pat+        ; new_body <- zonkCmdTop env1 body+        ; return (HsProc new_pat new_body) }++-- StaticPointers extension+zonkExpr env (HsStatic fvs expr)+  = HsStatic fvs <$> zonkLExpr env expr++zonkExpr env (HsWrap co_fn expr)+  = do (env1, new_co_fn) <- zonkCoFn env co_fn+       new_expr <- zonkExpr env1 expr+       return (HsWrap new_co_fn new_expr)++zonkExpr _ e@(HsUnboundVar {}) = return e++zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)++-------------------------------------------------------------------------+{-+Note [Skolems in zonkSyntaxExpr]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider rebindable syntax with something like++  (>>=) :: (forall x. blah) -> (forall y. blah') -> blah''++The x and y become skolems that are in scope when type-checking the+arguments to the bind. This means that we must extend the ZonkEnv with+these skolems when zonking the arguments to the bind. But the skolems+are different between the two arguments, and so we should theoretically+carry around different environments to use for the different arguments.++However, this becomes a logistical nightmare, especially in dealing with+the more exotic Stmt forms. So, we simplify by making the critical+assumption that the uniques of the skolems are different. (This assumption+is justified by the use of newUnique in TcMType.instSkolTyCoVarX.)+Now, we can safely just extend one environment.+-}++-- See Note [Skolems in zonkSyntaxExpr]+zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr TcId+               -> TcM (ZonkEnv, SyntaxExpr Id)+zonkSyntaxExpr env (SyntaxExpr { syn_expr      = expr+                               , syn_arg_wraps = arg_wraps+                               , syn_res_wrap  = res_wrap })+  = do { (env0, res_wrap')  <- zonkCoFn env res_wrap+       ; expr'              <- zonkExpr env0 expr+       ; (env1, arg_wraps') <- mapAccumLM zonkCoFn env0 arg_wraps+       ; return (env1, SyntaxExpr { syn_expr      = expr'+                                  , syn_arg_wraps = arg_wraps'+                                  , syn_res_wrap  = res_wrap' }) }++-------------------------------------------------------------------------++zonkLCmd  :: ZonkEnv -> LHsCmd TcId   -> TcM (LHsCmd Id)+zonkCmd   :: ZonkEnv -> HsCmd TcId    -> TcM (HsCmd Id)++zonkLCmd  env cmd  = wrapLocM (zonkCmd env) cmd++zonkCmd env (HsCmdWrap w cmd)+  = do { (env1, w') <- zonkCoFn env w+       ; cmd' <- zonkCmd env1 cmd+       ; return (HsCmdWrap w' cmd') }+zonkCmd env (HsCmdArrApp e1 e2 ty ho rl)+  = do new_e1 <- zonkLExpr env e1+       new_e2 <- zonkLExpr env e2+       new_ty <- zonkTcTypeToType env ty+       return (HsCmdArrApp new_e1 new_e2 new_ty ho rl)++zonkCmd env (HsCmdArrForm op f fixity args)+  = do new_op <- zonkLExpr env op+       new_args <- mapM (zonkCmdTop env) args+       return (HsCmdArrForm new_op f fixity new_args)++zonkCmd env (HsCmdApp c e)+  = do new_c <- zonkLCmd env c+       new_e <- zonkLExpr env e+       return (HsCmdApp new_c new_e)++zonkCmd env (HsCmdLam matches)+  = do new_matches <- zonkMatchGroup env zonkLCmd matches+       return (HsCmdLam new_matches)++zonkCmd env (HsCmdPar c)+  = do new_c <- zonkLCmd env c+       return (HsCmdPar new_c)++zonkCmd env (HsCmdCase expr ms)+  = do new_expr <- zonkLExpr env expr+       new_ms <- zonkMatchGroup env zonkLCmd ms+       return (HsCmdCase new_expr new_ms)++zonkCmd env (HsCmdIf eCond ePred cThen cElse)+  = do { (env1, new_eCond) <- zonkWit env eCond+       ; new_ePred <- zonkLExpr env1 ePred+       ; new_cThen <- zonkLCmd env1 cThen+       ; new_cElse <- zonkLCmd env1 cElse+       ; return (HsCmdIf new_eCond new_ePred new_cThen new_cElse) }+  where+    zonkWit env Nothing  = return (env, Nothing)+    zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w++zonkCmd env (HsCmdLet (L l binds) cmd)+  = do (new_env, new_binds) <- zonkLocalBinds env binds+       new_cmd <- zonkLCmd new_env cmd+       return (HsCmdLet (L l new_binds) new_cmd)++zonkCmd env (HsCmdDo (L l stmts) ty)+  = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts+       new_ty <- zonkTcTypeToType env ty+       return (HsCmdDo (L l new_stmts) new_ty)++++++zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)+zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd++zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id)+zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)+  = do new_cmd <- zonkLCmd env cmd+       new_stack_tys <- zonkTcTypeToType env stack_tys+       new_ty <- zonkTcTypeToType env ty+       new_ids <- mapSndM (zonkExpr env) ids++       MASSERT( isLiftedTypeKind (typeKind new_stack_tys) )+         -- desugarer assumes that this is not levity polymorphic...+         -- but indeed it should always be lifted due to the typing+         -- rules for arrows++       return (HsCmdTop new_cmd new_stack_tys new_ty new_ids)++-------------------------------------------------------------------------+zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)+zonkCoFn env WpHole   = return (env, WpHole)+zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1+                                    ; (env2, c2') <- zonkCoFn env1 c2+                                    ; return (env2, WpCompose c1' c2') }+zonkCoFn env (WpFun c1 c2 t1 d) = do { (env1, c1') <- zonkCoFn env c1+                                     ; (env2, c2') <- zonkCoFn env1 c2+                                     ; t1'         <- zonkTcTypeToType env2 t1+                                     ; return (env2, WpFun c1' c2' t1' d) }+zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co+                              ; return (env, WpCast co') }+zonkCoFn env (WpEvLam ev)   = do { (env', ev') <- zonkEvBndrX env ev+                                 ; return (env', WpEvLam ev') }+zonkCoFn env (WpEvApp arg)  = do { arg' <- zonkEvTerm env arg+                                 ; return (env, WpEvApp arg') }+zonkCoFn env (WpTyLam tv)   = ASSERT( isImmutableTyVar tv )+                              do { (env', tv') <- zonkTyBndrX env tv+                                 ; return (env', WpTyLam tv') }+zonkCoFn env (WpTyApp ty)   = do { ty' <- zonkTcTypeToType env ty+                                 ; return (env, WpTyApp ty') }+zonkCoFn env (WpLet bs)     = do { (env1, bs') <- zonkTcEvBinds env bs+                                 ; return (env1, WpLet bs') }++-------------------------------------------------------------------------+zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)+zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty })+  = do  { ty' <- zonkTcTypeToType env ty+        ; e' <- zonkExpr env e+        ; return (lit { ol_witness = e', ol_type = ty' }) }++-------------------------------------------------------------------------+zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)++zonkArithSeq env (From e)+  = do new_e <- zonkLExpr env e+       return (From new_e)++zonkArithSeq env (FromThen e1 e2)+  = do new_e1 <- zonkLExpr env e1+       new_e2 <- zonkLExpr env e2+       return (FromThen new_e1 new_e2)++zonkArithSeq env (FromTo e1 e2)+  = do new_e1 <- zonkLExpr env e1+       new_e2 <- zonkLExpr env e2+       return (FromTo new_e1 new_e2)++zonkArithSeq env (FromThenTo e1 e2 e3)+  = do new_e1 <- zonkLExpr env e1+       new_e2 <- zonkLExpr env e2+       new_e3 <- zonkLExpr env e3+       return (FromThenTo new_e1 new_e2 new_e3)+++-------------------------------------------------------------------------+zonkStmts :: ZonkEnv+          -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))+          -> [LStmt TcId (Located (body TcId))] -> TcM (ZonkEnv, [LStmt Id (Located (body Id))])+zonkStmts env _ []     = return (env, [])+zonkStmts env zBody (s:ss) = do { (env1, s')  <- wrapLocSndM (zonkStmt env zBody) s+                                ; (env2, ss') <- zonkStmts env1 zBody ss+                                ; return (env2, s' : ss') }++zonkStmt :: ZonkEnv+         -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))+         -> Stmt TcId (Located (body TcId)) -> TcM (ZonkEnv, Stmt Id (Located (body Id)))+zonkStmt env _ (ParStmt stmts_w_bndrs mzip_op bind_op bind_ty)+  = do { (env1, new_bind_op) <- zonkSyntaxExpr env bind_op+       ; new_bind_ty <- zonkTcTypeToType env1 bind_ty+       ; new_stmts_w_bndrs <- mapM (zonk_branch env1) stmts_w_bndrs+       ; let new_binders = [b | ParStmtBlock _ bs _ <- new_stmts_w_bndrs, b <- bs]+             env2 = extendIdZonkEnvRec env1 new_binders+       ; new_mzip <- zonkExpr env2 mzip_op+       ; return (env2, ParStmt new_stmts_w_bndrs new_mzip new_bind_op new_bind_ty) }+  where+    zonk_branch env1 (ParStmtBlock stmts bndrs return_op)+       = do { (env2, new_stmts)  <- zonkStmts env1 zonkLExpr stmts+            ; (env3, new_return) <- zonkSyntaxExpr env2 return_op+            ; return (ParStmtBlock new_stmts (zonkIdOccs env3 bndrs) new_return) }++zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs+                            , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id+                            , recS_bind_fn = bind_id, recS_bind_ty = bind_ty+                            , recS_later_rets = later_rets, recS_rec_rets = rec_rets+                            , recS_ret_ty = ret_ty })+  = do { (env1, new_bind_id) <- zonkSyntaxExpr env bind_id+       ; (env2, new_mfix_id) <- zonkSyntaxExpr env1 mfix_id+       ; (env3, new_ret_id)  <- zonkSyntaxExpr env2 ret_id+       ; new_bind_ty <- zonkTcTypeToType env3 bind_ty+       ; new_rvs <- zonkIdBndrs env3 rvs+       ; new_lvs <- zonkIdBndrs env3 lvs+       ; new_ret_ty  <- zonkTcTypeToType env3 ret_ty+       ; let env4 = extendIdZonkEnvRec env3 new_rvs+       ; (env5, new_segStmts) <- zonkStmts env4 zBody segStmts+        -- Zonk the ret-expressions in an envt that+        -- has the polymorphic bindings in the envt+       ; new_later_rets <- mapM (zonkExpr env5) later_rets+       ; new_rec_rets <- mapM (zonkExpr env5) rec_rets+       ; return (extendIdZonkEnvRec env3 new_lvs,     -- Only the lvs are needed+                 RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs+                         , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id+                         , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id+                         , recS_bind_ty = new_bind_ty+                         , recS_later_rets = new_later_rets+                         , recS_rec_rets = new_rec_rets, recS_ret_ty = new_ret_ty }) }++zonkStmt env zBody (BodyStmt body then_op guard_op ty)+  = do (env1, new_then_op)  <- zonkSyntaxExpr env then_op+       (env2, new_guard_op) <- zonkSyntaxExpr env1 guard_op+       new_body <- zBody env2 body+       new_ty   <- zonkTcTypeToType env2 ty+       return (env2, BodyStmt new_body new_then_op new_guard_op new_ty)++zonkStmt env zBody (LastStmt body noret ret_op)+  = do (env1, new_ret) <- zonkSyntaxExpr env ret_op+       new_body <- zBody env1 body+       return (env, LastStmt new_body noret new_ret)++zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap+                          , trS_by = by, trS_form = form, trS_using = using+                          , trS_ret = return_op, trS_bind = bind_op+                          , trS_bind_arg_ty = bind_arg_ty+                          , trS_fmap = liftM_op })+  = do {+    ; (env1, bind_op') <- zonkSyntaxExpr env bind_op+    ; bind_arg_ty' <- zonkTcTypeToType env1 bind_arg_ty+    ; (env2, stmts') <- zonkStmts env1 zonkLExpr stmts+    ; by'        <- fmapMaybeM (zonkLExpr env2) by+    ; using'     <- zonkLExpr env2 using++    ; (env3, return_op') <- zonkSyntaxExpr env2 return_op+    ; binderMap' <- mapM (zonkBinderMapEntry env3) binderMap+    ; liftM_op'  <- zonkExpr env3 liftM_op+    ; let env3' = extendIdZonkEnvRec env3 (map snd binderMap')+    ; return (env3', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap'+                               , trS_by = by', trS_form = form, trS_using = using'+                               , trS_ret = return_op', trS_bind = bind_op'+                               , trS_bind_arg_ty = bind_arg_ty'+                               , trS_fmap = liftM_op' }) }+  where+    zonkBinderMapEntry env  (oldBinder, newBinder) = do+        let oldBinder' = zonkIdOcc env oldBinder+        newBinder' <- zonkIdBndr env newBinder+        return (oldBinder', newBinder')++zonkStmt env _ (LetStmt (L l binds))+  = do (env1, new_binds) <- zonkLocalBinds env binds+       return (env1, LetStmt (L l new_binds))++zonkStmt env zBody (BindStmt pat body bind_op fail_op bind_ty)+  = do  { (env1, new_bind) <- zonkSyntaxExpr env bind_op+        ; new_bind_ty <- zonkTcTypeToType env1 bind_ty+        ; new_body <- zBody env1 body+        ; (env2, new_pat) <- zonkPat env1 pat+        ; (_, new_fail) <- zonkSyntaxExpr env1 fail_op+        ; return (env2, BindStmt new_pat new_body new_bind new_fail new_bind_ty) }++-- Scopes: join > ops (in reverse order) > pats (in forward order)+--              > rest of stmts+zonkStmt env _zBody (ApplicativeStmt args mb_join body_ty)+  = do  { (env1, new_mb_join)   <- zonk_join env mb_join+        ; (env2, new_args)      <- zonk_args env1 args+        ; new_body_ty           <- zonkTcTypeToType env2 body_ty+        ; return (env2, ApplicativeStmt new_args new_mb_join new_body_ty) }+  where+    zonk_join env Nothing  = return (env, Nothing)+    zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j++    get_pat (_, ApplicativeArgOne pat _)    = pat+    get_pat (_, ApplicativeArgMany _ _ pat) = pat++    replace_pat pat (op, ApplicativeArgOne _ a)+      = (op, ApplicativeArgOne pat a)+    replace_pat pat (op, ApplicativeArgMany a b _)+      = (op, ApplicativeArgMany a b pat)++    zonk_args env args+      = do { (env1, new_args_rev) <- zonk_args_rev env (reverse args)+           ; (env2, new_pats)     <- zonkPats env1 (map get_pat args)+           ; return (env2, zipWith replace_pat new_pats (reverse new_args_rev)) }++     -- these need to go backward, because if any operators are higher-rank,+     -- later operators may introduce skolems that are in scope for earlier+     -- arguments+    zonk_args_rev env ((op, arg) : args)+      = do { (env1, new_op)         <- zonkSyntaxExpr env op+           ; new_arg                <- zonk_arg env1 arg+           ; (env2, new_args)       <- zonk_args_rev env1 args+           ; return (env2, (new_op, new_arg) : new_args) }+    zonk_args_rev env [] = return (env, [])++    zonk_arg env (ApplicativeArgOne pat expr)+      = do { new_expr <- zonkLExpr env expr+           ; return (ApplicativeArgOne pat new_expr) }+    zonk_arg env (ApplicativeArgMany stmts ret pat)+      = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts+           ; new_ret           <- zonkExpr env1 ret+           ; return (ApplicativeArgMany new_stmts new_ret pat) }++-------------------------------------------------------------------------+zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId)+zonkRecFields env (HsRecFields flds dd)+  = do  { flds' <- mapM zonk_rbind flds+        ; return (HsRecFields flds' dd) }+  where+    zonk_rbind (L l fld)+      = do { new_id   <- wrapLocM (zonkFieldOcc env) (hsRecFieldLbl fld)+           ; new_expr <- zonkLExpr env (hsRecFieldArg fld)+           ; return (L l (fld { hsRecFieldLbl = new_id+                              , hsRecFieldArg = new_expr })) }++zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField TcId] -> TcM [LHsRecUpdField TcId]+zonkRecUpdFields env = mapM zonk_rbind+  where+    zonk_rbind (L l fld)+      = do { new_id   <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld)+           ; new_expr <- zonkLExpr env (hsRecFieldArg fld)+           ; return (L l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id+                              , hsRecFieldArg = new_expr })) }++-------------------------------------------------------------------------+mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a+            -> TcM (Either (Located HsIPName) b)+mapIPNameTc _ (Left x)  = return (Left x)+mapIPNameTc f (Right x) = do r <- f x+                             return (Right r)++{-+************************************************************************+*                                                                      *+\subsection[BackSubst-Pats]{Patterns}+*                                                                      *+************************************************************************+-}++zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id)+-- Extend the environment as we go, because it's possible for one+-- pattern to bind something that is used in another (inside or+-- to the right)+zonkPat env pat = wrapLocSndM (zonk_pat env) pat++zonk_pat :: ZonkEnv -> Pat TcId -> TcM (ZonkEnv, Pat Id)+zonk_pat env (ParPat p)+  = do  { (env', p') <- zonkPat env p+        ; return (env', ParPat p') }++zonk_pat env (WildPat ty)+  = do  { ty' <- zonkTcTypeToType env ty+        ; ensureNotLevPoly ty'+            (text "In a wildcard pattern")+        ; return (env, WildPat ty') }++zonk_pat env (VarPat (L l v))+  = do  { v' <- zonkIdBndr env v+        ; return (extendIdZonkEnv1 env v', VarPat (L l v')) }++zonk_pat env (LazyPat pat)+  = do  { (env', pat') <- zonkPat env pat+        ; return (env',  LazyPat pat') }++zonk_pat env (BangPat pat)+  = do  { (env', pat') <- zonkPat env pat+        ; return (env',  BangPat pat') }++zonk_pat env (AsPat (L loc v) pat)+  = do  { v' <- zonkIdBndr env v+        ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat+        ; return (env', AsPat (L loc v') pat') }++zonk_pat env (ViewPat expr pat ty)+  = do  { expr' <- zonkLExpr env expr+        ; (env', pat') <- zonkPat env pat+        ; ty' <- zonkTcTypeToType env ty+        ; return (env', ViewPat expr' pat' ty') }++zonk_pat env (ListPat pats ty Nothing)+  = do  { ty' <- zonkTcTypeToType env ty+        ; (env', pats') <- zonkPats env pats+        ; return (env', ListPat pats' ty' Nothing) }++zonk_pat env (ListPat pats ty (Just (ty2,wit)))+  = do  { (env', wit') <- zonkSyntaxExpr env wit+        ; ty2' <- zonkTcTypeToType env' ty2+        ; ty' <- zonkTcTypeToType env' ty+        ; (env'', pats') <- zonkPats env' pats+        ; return (env'', ListPat pats' ty' (Just (ty2',wit'))) }++zonk_pat env (PArrPat pats ty)+  = do  { ty' <- zonkTcTypeToType env ty+        ; (env', pats') <- zonkPats env pats+        ; return (env', PArrPat pats' ty') }++zonk_pat env (TuplePat pats boxed tys)+  = do  { tys' <- mapM (zonkTcTypeToType env) tys+        ; (env', pats') <- zonkPats env pats+        ; return (env', TuplePat pats' boxed tys') }++zonk_pat env (SumPat pat alt arity tys)+  = do  { tys' <- mapM (zonkTcTypeToType env) tys+        ; (env', pat') <- zonkPat env pat+        ; return (env', SumPat pat' alt arity tys') }++zonk_pat env p@(ConPatOut { pat_arg_tys = tys, pat_tvs = tyvars+                          , pat_dicts = evs, pat_binds = binds+                          , pat_args = args, pat_wrap = wrapper+                          , pat_con = L _ con })+  = ASSERT( all isImmutableTyVar tyvars )+    do  { new_tys <- mapM (zonkTcTypeToType env) tys++          -- an unboxed tuple pattern (but only an unboxed tuple pattern)+          -- might have levity-polymorphic arguments. Check for this badness.+        ; case con of+            RealDataCon dc+              | isUnboxedTupleTyCon (dataConTyCon dc)+              -> mapM_ (checkForLevPoly doc) (dropRuntimeRepArgs new_tys)+            _ -> return ()++        ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars+          -- Must zonk the existential variables, because their+          -- /kind/ need potential zonking.+          -- cf typecheck/should_compile/tc221.hs+        ; (env1, new_evs) <- zonkEvBndrsX env0 evs+        ; (env2, new_binds) <- zonkTcEvBinds env1 binds+        ; (env3, new_wrapper) <- zonkCoFn env2 wrapper+        ; (env', new_args) <- zonkConStuff env3 args+        ; return (env', p { pat_arg_tys = new_tys,+                            pat_tvs = new_tyvars,+                            pat_dicts = new_evs,+                            pat_binds = new_binds,+                            pat_args = new_args,+                            pat_wrap = new_wrapper}) }+  where+    doc = text "In the type of an element of an unboxed tuple pattern:" $$ ppr p++zonk_pat env (LitPat lit) = return (env, LitPat lit)++zonk_pat env (SigPatOut pat ty)+  = do  { ty' <- zonkTcTypeToType env ty+        ; (env', pat') <- zonkPat env pat+        ; return (env', SigPatOut pat' ty') }++zonk_pat env (NPat (L l lit) mb_neg eq_expr ty)+  = do  { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr+        ; (env2, mb_neg') <- case mb_neg of+            Nothing -> return (env1, Nothing)+            Just n  -> second Just <$> zonkSyntaxExpr env1 n++        ; lit' <- zonkOverLit env2 lit+        ; ty' <- zonkTcTypeToType env2 ty+        ; return (env2, NPat (L l lit') mb_neg' eq_expr' ty') }++zonk_pat env (NPlusKPat (L loc n) (L l lit1) lit2 e1 e2 ty)+  = do  { (env1, e1') <- zonkSyntaxExpr env  e1+        ; (env2, e2') <- zonkSyntaxExpr env1 e2+        ; n' <- zonkIdBndr env2 n+        ; lit1' <- zonkOverLit env2 lit1+        ; lit2' <- zonkOverLit env2 lit2+        ; ty' <- zonkTcTypeToType env2 ty+        ; return (extendIdZonkEnv1 env2 n',+                  NPlusKPat (L loc n') (L l lit1') lit2' e1' e2' ty') }++zonk_pat env (CoPat co_fn pat ty)+  = do { (env', co_fn') <- zonkCoFn env co_fn+       ; (env'', pat') <- zonkPat env' (noLoc pat)+       ; ty' <- zonkTcTypeToType env'' ty+       ; return (env'', CoPat co_fn' (unLoc pat') ty') }++zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat)++---------------------------+zonkConStuff :: ZonkEnv+             -> HsConDetails (OutPat TcId) (HsRecFields id (OutPat TcId))+             -> TcM (ZonkEnv,+                     HsConDetails (OutPat Id) (HsRecFields id (OutPat Id)))+zonkConStuff env (PrefixCon pats)+  = do  { (env', pats') <- zonkPats env pats+        ; return (env', PrefixCon pats') }++zonkConStuff env (InfixCon p1 p2)+  = do  { (env1, p1') <- zonkPat env  p1+        ; (env', p2') <- zonkPat env1 p2+        ; return (env', InfixCon p1' p2') }++zonkConStuff env (RecCon (HsRecFields rpats dd))+  = do  { (env', pats') <- zonkPats env (map (hsRecFieldArg . unLoc) rpats)+        ; let rpats' = zipWith (\(L l rp) p' -> L l (rp { hsRecFieldArg = p' }))+                               rpats pats'+        ; return (env', RecCon (HsRecFields rpats' dd)) }+        -- Field selectors have declared types; hence no zonking++---------------------------+zonkPats :: ZonkEnv -> [OutPat TcId] -> TcM (ZonkEnv, [OutPat Id])+zonkPats env []         = return (env, [])+zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat+                             ; (env', pats') <- zonkPats env1 pats+                             ; return (env', pat':pats') }++{-+************************************************************************+*                                                                      *+\subsection[BackSubst-Foreign]{Foreign exports}+*                                                                      *+************************************************************************+-}++zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]+zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls++zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)+zonkForeignExport env (ForeignExport { fd_name = i, fd_co = co, fd_fe = spec })+  = return (ForeignExport { fd_name = fmap (zonkIdOcc env) i+                          , fd_sig_ty = undefined, fd_co = co+                          , fd_fe = spec })+zonkForeignExport _ for_imp+  = return for_imp     -- Foreign imports don't need zonking++zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]+zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs++zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)+zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)+  = do { (env_inside, new_bndrs) <- mapAccumLM zonk_bndr env vars++       ; let env_lhs = setZonkType env_inside zonkTvSkolemising+              -- See Note [Zonking the LHS of a RULE]++       ; new_lhs <- zonkLExpr env_lhs    lhs+       ; new_rhs <- zonkLExpr env_inside rhs++       ; return (HsRule name act new_bndrs new_lhs fv_lhs new_rhs fv_rhs) }+  where+   zonk_bndr env (L l (RuleBndr (L loc v)))+      = do { (env', v') <- zonk_it env v+           ; return (env', L l (RuleBndr (L loc v'))) }+   zonk_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_bndr RuleBndrSig"++   zonk_it env v+     | isId v     = do { v' <- zonkIdBndr env v+                       ; return (extendIdZonkEnvRec env [v'], v') }+     | otherwise  = ASSERT( isImmutableTyVar v)+                    zonkTyBndrX env v+                    -- DV: used to be return (env,v) but that is plain+                    -- wrong because we may need to go inside the kind+                    -- of v and zonk there!++zonkVects :: ZonkEnv -> [LVectDecl TcId] -> TcM [LVectDecl Id]+zonkVects env = mapM (wrapLocM (zonkVect env))++zonkVect :: ZonkEnv -> VectDecl TcId -> TcM (VectDecl Id)+zonkVect env (HsVect s v e)+  = do { v' <- wrapLocM (zonkIdBndr env) v+       ; e' <- zonkLExpr env e+       ; return $ HsVect s v' e'+       }+zonkVect env (HsNoVect s v)+  = do { v' <- wrapLocM (zonkIdBndr env) v+       ; return $ HsNoVect s v'+       }+zonkVect _env (HsVectTypeOut s t rt)+  = return $ HsVectTypeOut s t rt+zonkVect _ (HsVectTypeIn _ _ _ _) = panic "TcHsSyn.zonkVect: HsVectTypeIn"+zonkVect _env (HsVectClassOut c)+  = return $ HsVectClassOut c+zonkVect _ (HsVectClassIn _ _) = panic "TcHsSyn.zonkVect: HsVectClassIn"+zonkVect _env (HsVectInstOut i)+  = return $ HsVectInstOut i+zonkVect _ (HsVectInstIn _) = panic "TcHsSyn.zonkVect: HsVectInstIn"++{-+************************************************************************+*                                                                      *+              Constraints and evidence+*                                                                      *+************************************************************************+-}++zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm+zonkEvTerm env (EvId v)           = ASSERT2( isId v, ppr v )+                                    zonkEvVarOcc env v+zonkEvTerm env (EvCoercion co)    = do { co' <- zonkCoToCo env co+                                       ; return (EvCoercion co') }+zonkEvTerm env (EvCast tm co)     = do { tm' <- zonkEvTerm env tm+                                       ; co' <- zonkCoToCo env co+                                       ; return (mkEvCast tm' co') }+zonkEvTerm _   (EvLit l)          = return (EvLit l)++zonkEvTerm env (EvTypeable ty ev) =+  do { ev' <- zonkEvTypeable env ev+     ; ty' <- zonkTcTypeToType env ty+     ; return (EvTypeable ty' ev') }+zonkEvTerm env (EvCallStack cs)+  = case cs of+      EvCsEmpty -> return (EvCallStack cs)+      EvCsPushCall n l tm -> do { tm' <- zonkEvTerm env tm+                                ; return (EvCallStack (EvCsPushCall n l tm')) }++zonkEvTerm env (EvSuperClass d n) = do { d' <- zonkEvTerm env d+                                       ; return (EvSuperClass d' n) }+zonkEvTerm env (EvDFunApp df tys tms)+  = do { tys' <- zonkTcTypeToTypes env tys+       ; tms' <- mapM (zonkEvTerm env) tms+       ; return (EvDFunApp (zonkIdOcc env df) tys' tms') }+zonkEvTerm env (EvDelayedError ty msg)+  = do { ty' <- zonkTcTypeToType env ty+       ; return (EvDelayedError ty' msg) }+zonkEvTerm env (EvSelector sel_id tys tms)+  = do { sel_id' <- zonkIdBndr env sel_id+       ; tys'    <- zonkTcTypeToTypes env tys+       ; tms' <- mapM (zonkEvTerm env) tms+       ; return (EvSelector sel_id' tys' tms') }++zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable+zonkEvTypeable env (EvTypeableTyCon tycon e)+  = do { e'  <- mapM (zonkEvTerm env) e+       ; return $ EvTypeableTyCon tycon e' }+zonkEvTypeable env (EvTypeableTyApp t1 t2)+  = do { t1' <- zonkEvTerm env t1+       ; t2' <- zonkEvTerm env t2+       ; return (EvTypeableTyApp t1' t2') }+zonkEvTypeable env (EvTypeableTrFun t1 t2)+  = do { t1' <- zonkEvTerm env t1+       ; t2' <- zonkEvTerm env t2+       ; return (EvTypeableTrFun t1' t2') }+zonkEvTypeable env (EvTypeableTyLit t1)+  = do { t1' <- zonkEvTerm env t1+       ; return (EvTypeableTyLit t1') }++zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds])+zonkTcEvBinds_s env bs = do { (env, bs') <- mapAccumLM zonk_tc_ev_binds env bs+                            ; return (env, [EvBinds (unionManyBags bs')]) }++zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)+zonkTcEvBinds env bs = do { (env', bs') <- zonk_tc_ev_binds env bs+                          ; return (env', EvBinds bs') }++zonk_tc_ev_binds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, Bag EvBind)+zonk_tc_ev_binds env (TcEvBinds var) = zonkEvBindsVar env var+zonk_tc_ev_binds env (EvBinds bs)    = zonkEvBinds env bs++zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind)+zonkEvBindsVar env (EvBindsVar { ebv_binds = ref })+  = do { bs <- readMutVar ref+       ; zonkEvBinds env (evBindMapBinds bs) }++zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)+zonkEvBinds env binds+  = {-# SCC "zonkEvBinds" #-}+    fixM (\ ~( _, new_binds) -> do+         { let env1 = extendIdZonkEnvRec env (collect_ev_bndrs new_binds)+         ; binds' <- mapBagM (zonkEvBind env1) binds+         ; return (env1, binds') })+  where+    collect_ev_bndrs :: Bag EvBind -> [EvVar]+    collect_ev_bndrs = foldrBag add []+    add (EvBind { eb_lhs = var }) vars = var : vars++zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind+zonkEvBind env bind@(EvBind { eb_lhs = var, eb_rhs = term })+  = do { var'  <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var++         -- Optimise the common case of Refl coercions+         -- See Note [Optimise coercion zonking]+         -- This has a very big effect on some programs (eg Trac #5030)++       ; term' <- case getEqPredTys_maybe (idType var') of+           Just (r, ty1, ty2) | ty1 `eqType` ty2+                  -> return (EvCoercion (mkTcReflCo r ty1))+           _other -> zonkEvTerm env term++       ; return (bind { eb_lhs = var', eb_rhs = term' }) }++{-+************************************************************************+*                                                                      *+                         Zonking types+*                                                                      *+************************************************************************++Note [Zonking mutable unbound type or kind variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In zonkTypeZapping, we zonk mutable but unbound type or kind variables to an+arbitrary type. We know if they are unbound even though we don't carry an+environment, because at the binding site for a variable we bind the mutable+var to a fresh immutable one.  So the mutable store plays the role of an+environment.  If we come across a mutable variable that isn't so bound, it+must be completely free. We zonk the expected kind to make sure we don't get+some unbound meta variable as the kind.++Note that since we have kind polymorphism, zonk_unbound_tyvar will handle both+type and kind variables. Consider the following datatype:++  data Phantom a = Phantom Int++The type of Phantom is (forall (k : *). forall (a : k). Int). Both `a` and+`k` are unbound variables. We want to zonk this to+(forall (k : Any *). forall (a : Any (Any *)). Int).++Note [Optimise coercion zonking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When optimising evidence binds we may come across situations where+a coercion looks like+      cv = ReflCo ty+or    cv1 = cv2+where the type 'ty' is big.  In such cases it is a waste of time to zonk both+  * The variable on the LHS+  * The coercion on the RHS+Rather, we can zonk the variable, and if its type is (ty ~ ty), we can just+use Refl on the right, ignoring the actual coercion on the RHS.++This can have a very big effect, because the constraint solver sometimes does go+to a lot of effort to prove Refl!  (Eg when solving  10+3 = 10+3; cf Trac #5030)++-}++zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType+zonkTyVarOcc env@(ZonkEnv zonk_unbound_tyvar tv_env _) tv+  | isTcTyVar tv+  = case tcTyVarDetails tv of+         SkolemTv {}    -> lookup_in_env+         RuntimeUnk {}  -> lookup_in_env+         FlatSkol ty    -> zonkTcTypeToType env ty+         MetaTv { mtv_ref = ref }+           -> do { cts <- readMutVar ref+                 ; case cts of+                      Flexi -> do { kind <- {-# SCC "zonkKind1" #-}+                                            zonkTcTypeToType env (tyVarKind tv)+                                  ; zonk_unbound_tyvar (setTyVarKind tv kind) }+                      Indirect ty -> do { zty <- zonkTcTypeToType env ty+                                        -- Small optimisation: shortern-out indirect steps+                                        -- so that the old type may be more easily collected.+                                        ; writeMutVar ref (Indirect zty)+                                        ; return zty } }+  | otherwise+  = lookup_in_env+  where+    lookup_in_env    -- Look up in the env just as we do for Ids+      = case lookupVarEnv tv_env tv of+          Nothing  -> mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToType env) tv+          Just tv' -> return (mkTyVarTy tv')++zonkCoVarOcc :: ZonkEnv -> CoVar -> TcM Coercion+zonkCoVarOcc env@(ZonkEnv _ tyco_env _) cv+  | Just cv' <- lookupVarEnv tyco_env cv  -- don't look in the knot-tied env+  = return $ mkCoVarCo cv'+  | otherwise+  = mkCoVarCo <$> updateVarTypeM (zonkTcTypeToType env) cv++zonkCoHole :: ZonkEnv -> CoercionHole+           -> Role -> Type -> Type  -- these are all redundant with+                                    -- the details in the hole,+                                    -- unzonked+           -> TcM Coercion+zonkCoHole env h r t1 t2+  = do { contents <- unpackCoercionHole_maybe h+       ; case contents of+           Just co -> do { co <- zonkCoToCo env co+                         ; checkCoercionHole co h r t1 t2 }++              -- This next case should happen only in the presence of+              -- (undeferred) type errors. Originally, I put in a panic+              -- here, but that caused too many uses of `failIfErrsM`.+           Nothing -> do { traceTc "Zonking unfilled coercion hole" (ppr h)+                         ; when debugIsOn $+                           whenNoErrs $+                           MASSERT2( False+                                   , text "Type-correct unfilled coercion hole"+                                     <+> ppr h )+                         ; t1 <- zonkTcTypeToType env t1+                         ; t2 <- zonkTcTypeToType env t2+                         ; return $ mkHoleCo h r t1 t2 } }++zonk_tycomapper :: TyCoMapper ZonkEnv TcM+zonk_tycomapper = TyCoMapper+  { tcm_smart = True   -- Establish type invariants+                       -- See Note [Type-checking inside the knot] in TcHsType+  , tcm_tyvar = zonkTyVarOcc+  , tcm_covar = zonkCoVarOcc+  , tcm_hole  = zonkCoHole+  , tcm_tybinder = \env tv _vis -> zonkTyBndrX env tv }++-- Confused by zonking? See Note [What is zonking?] in TcMType.+zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type+zonkTcTypeToType = mapType zonk_tycomapper++zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type]+zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys++zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion+zonkCoToCo = mapCoercion zonk_tycomapper++zonkSigType :: TcType -> TcM Type+-- Zonk the type obtained from a user type signature+-- We want to turn any quantified (forall'd) variables into TyVars+-- but we may find some free TcTyVars, and we want to leave them+-- completely alone.  They may even have unification variables inside+-- e.g.  f (x::a) = ...(e :: a -> a)....+-- The type sig for 'e' mentions a free 'a' which will be a+-- unification SigTv variable.+zonkSigType = zonkTcTypeToType (mkEmptyZonkEnv zonk_unbound_tv)+  where+    zonk_unbound_tv :: UnboundTyVarZonker+    zonk_unbound_tv tv = return (mkTyVarTy tv)++zonkTvSkolemising :: UnboundTyVarZonker+-- This variant is used for the LHS of rules+-- See Note [Zonking the LHS of a RULE].+zonkTvSkolemising tv+  = do { let tv' = mkTyVar (tyVarName tv) (tyVarKind tv)+                  -- NB: the kind of tv is already zonked+             ty = mkTyVarTy tv'+                  -- Make a proper TyVar (remember we+                  -- are now done with type checking)+       ; writeMetaTyVar tv ty+       ; return ty }++zonkTypeZapping :: UnboundTyVarZonker+-- This variant is used for everything except the LHS of rules+-- It zaps unbound type variables to Any, except for RuntimeRep+-- vars which it zonks to LiftedRep+-- Works on both types and kinds+zonkTypeZapping tv+  = do { let ty | isRuntimeRepVar tv = liftedRepTy+                | otherwise          = anyTypeOfKind (tyVarKind tv)+       ; writeMetaTyVar tv ty+       ; return ty }++---------------------------------------+{- Note [Zonking the LHS of a RULE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also DsBinds Note [Free tyvars on rule LHS]++We need to gather the type variables mentioned on the LHS so we can+quantify over them.  Example:+  data T a = C++  foo :: T a -> Int+  foo C = 1++  {-# RULES "myrule"  foo C = 1 #-}++After type checking the LHS becomes (foo alpha (C alpha)) and we do+not want to zap the unbound meta-tyvar 'alpha' to Any, because that+limits the applicability of the rule.  Instead, we want to quantify+over it!++We do this in two stages.++* During zonking, we skolemise the TcTyVar 'alpha' to TyVar 'a'.  We+  do this by using zonkTvSkolemising as the UnboundTyVarZonker in the+  ZonkEnv.  (This is in fact the whole reason that the ZonkEnv has a+  UnboundTyVarZonker.)++* In DsBinds, we quantify over it.  See DsBinds+  Note [Free tyvars on rule LHS]++Quantifying here is awkward because (a) the data type is big and (b)+finding the free type vars of an expression is necessarily monadic+operation. (consider /\a -> f @ b, where b is side-effected to a)+-}
+ typecheck/TcHsType.hs view
@@ -0,0 +1,2161 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[TcMonoType]{Typechecking user-specified @MonoTypes@}+-}++{-# LANGUAGE CPP, TupleSections, MultiWayIf, RankNTypes #-}++module TcHsType (+        -- Type signatures+        kcHsSigType, tcClassSigType,+        tcHsSigType, tcHsSigWcType,+        tcHsPartialSigType,+        funsSigCtxt, addSigCtxt, pprSigCtxt,++        tcHsClsInstType,+        tcHsDeriv, tcHsVectInst,+        tcHsTypeApp,+        UserTypeCtxt(..),+        tcImplicitTKBndrs, tcImplicitTKBndrsType, tcExplicitTKBndrs,++                -- Type checking type and class decls+        kcLookupTcTyCon, kcTyClTyVars, tcTyClTyVars,+        tcDataKindSig,++        -- Kind-checking types+        -- No kind generalisation, no checkValidType+        tcWildCardBinders,+        kcHsTyVarBndrs,+        tcHsLiftedType,   tcHsOpenType,+        tcHsLiftedTypeNC, tcHsOpenTypeNC,+        tcLHsType, tcCheckLHsType,+        tcHsContext, tcLHsPredType, tcInferApps, tcInferArgs,+        solveEqualities, -- useful re-export++        kindGeneralize,++        -- Sort-checking kinds+        tcLHsKindSig,++        -- Pattern type signatures+        tcHsPatSigType, tcPatSig, funAppCtxt+   ) where++#include "HsVersions.h"++import HsSyn+import TcRnMonad+import TcEvidence+import TcEnv+import TcMType+import TcValidity+import TcUnify+import TcIface+import TcSimplify ( solveEqualities )+import TcType+import TcHsSyn( zonkSigType )+import Inst   ( tcInstBindersX, tcInstBinderX )+import Type+import Kind+import RdrName( lookupLocalRdrOcc )+import Var+import VarSet+import TyCon+import ConLike+import DataCon+import Class+import Name+import NameEnv+import NameSet+import VarEnv+import TysWiredIn+import BasicTypes+import SrcLoc+import Constants ( mAX_CTUPLE_SIZE )+import ErrUtils( MsgDoc )+import Unique+import Util+import UniqSupply+import Outputable+import FastString+import PrelNames hiding ( wildCardName )+import qualified GHC.LanguageExtensions as LangExt++import Maybes+import Data.List ( partition, zipWith4 )+import Control.Monad++{-+        ----------------------------+                General notes+        ----------------------------++Unlike with expressions, type-checking types both does some checking and+desugars at the same time. This is necessary because we often want to perform+equality checks on the types right away, and it would be incredibly painful+to do this on un-desugared types. Luckily, desugared types are close enough+to HsTypes to make the error messages sane.++During type-checking, we perform as little validity checking as possible.+This is because some type-checking is done in a mutually-recursive knot, and+if we look too closely at the tycons, we'll loop. This is why we always must+use mkNakedTyConApp and mkNakedAppTys, etc., which never look at a tycon.+The mkNamed... functions don't uphold Type invariants, but zonkTcTypeToType+will repair this for us. Note that zonkTcType *is* safe within a knot, and+can be done repeatedly with no ill effect: it just squeezes out metavariables.++Generally, after type-checking, you will want to do validity checking, say+with TcValidity.checkValidType.++Validity checking+~~~~~~~~~~~~~~~~~+Some of the validity check could in principle be done by the kind checker,+but not all:++- During desugaring, we normalise by expanding type synonyms.  Only+  after this step can we check things like type-synonym saturation+  e.g.  type T k = k Int+        type S a = a+  Then (T S) is ok, because T is saturated; (T S) expands to (S Int);+  and then S is saturated.  This is a GHC extension.++- Similarly, also a GHC extension, we look through synonyms before complaining+  about the form of a class or instance declaration++- Ambiguity checks involve functional dependencies, and it's easier to wait+  until knots have been resolved before poking into them++Also, in a mutually recursive group of types, we can't look at the TyCon until we've+finished building the loop.  So to keep things simple, we postpone most validity+checking until step (3).++Knot tying+~~~~~~~~~~+During step (1) we might fault in a TyCon defined in another module, and it might+(via a loop) refer back to a TyCon defined in this module. So when we tie a big+knot around type declarations with ARecThing, so that the fault-in code can get+the TyCon being defined.++%************************************************************************+%*                                                                      *+              Check types AND do validity checking+*                                                                      *+************************************************************************+-}++funsSigCtxt :: [Located Name] -> UserTypeCtxt+-- Returns FunSigCtxt, with no redundant-context-reporting,+-- form a list of located names+funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 False+funsSigCtxt []              = panic "funSigCtxt"++addSigCtxt :: UserTypeCtxt -> LHsType Name -> TcM a -> TcM a+addSigCtxt ctxt hs_ty thing_inside+  = setSrcSpan (getLoc hs_ty) $+    addErrCtxt (pprSigCtxt ctxt hs_ty) $+    thing_inside++pprSigCtxt :: UserTypeCtxt -> LHsType Name -> SDoc+-- (pprSigCtxt ctxt <extra> <type>)+-- prints    In the type signature for 'f':+--              f :: <type>+-- The <extra> is either empty or "the ambiguity check for"+pprSigCtxt ctxt hs_ty+  | Just n <- isSigMaybe ctxt+  = hang (text "In the type signature:")+       2 (pprPrefixOcc n <+> dcolon <+> ppr hs_ty)++  | otherwise+  = hang (text "In" <+> pprUserTypeCtxt ctxt <> colon)+       2 (ppr hs_ty)++tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType Name -> TcM Type+-- This one is used when we have a LHsSigWcType, but in+-- a place where wildards aren't allowed. The renamer has+-- already checked this, so we can simply ignore it.+tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty)++kcHsSigType :: [Located Name] -> LHsSigType Name -> TcM ()+kcHsSigType names (HsIB { hsib_body = hs_ty+                        , hsib_vars = sig_vars })+  = addSigCtxt (funsSigCtxt names) hs_ty $+    discardResult $+    tcImplicitTKBndrsType sig_vars $+    tc_lhs_type typeLevelMode hs_ty liftedTypeKind++tcClassSigType :: [Located Name] -> LHsSigType Name -> TcM Type+-- Does not do validity checking; this must be done outside+-- the recursive class declaration "knot"+tcClassSigType names sig_ty+  = addSigCtxt (funsSigCtxt names) (hsSigType sig_ty) $+    tc_hs_sig_type_and_gen sig_ty liftedTypeKind++tcHsSigType :: UserTypeCtxt -> LHsSigType Name -> TcM Type+-- Does validity checking+tcHsSigType ctxt sig_ty+  = addSigCtxt ctxt (hsSigType sig_ty) $+    do { kind <- case expectedKindInCtxt ctxt of+                    AnythingKind -> newMetaKindVar+                    TheKind k    -> return k+                    OpenKind     -> newOpenTypeKind+              -- The kind is checked by checkValidType, and isn't necessarily+              -- of kind * in a Template Haskell quote eg [t| Maybe |]++          -- Generalise here: see Note [Kind generalisation]+       ; do_kind_gen <- decideKindGeneralisationPlan sig_ty+       ; ty <- if do_kind_gen+               then tc_hs_sig_type_and_gen sig_ty kind+               else tc_hs_sig_type         sig_ty kind >>= zonkTcType++       ; checkValidType ctxt ty+       ; return ty }++tc_hs_sig_type_and_gen :: LHsSigType Name -> Kind -> TcM Type+-- Kind-checks/desugars an 'LHsSigType',+--   solve equalities,+--   and then kind-generalizes.+-- This will never emit constraints, as it uses solveEqualities interally.+-- No validity checking, but it does zonk en route to generalization+tc_hs_sig_type_and_gen hs_ty kind+  = do { ty <- solveEqualities $+               tc_hs_sig_type hs_ty kind+         -- NB the call to solveEqualities, which unifies all those+         --    kind variables floating about, immediately prior to+         --    kind generalisation+       ; kindGeneralizeType ty }++tc_hs_sig_type :: LHsSigType Name -> Kind -> TcM Type+-- Kind-check/desugar a 'LHsSigType', but does not solve+-- the equalities that arise from doing so; instead it may+-- emit kind-equality constraints into the monad+-- No zonking or validity checking+tc_hs_sig_type (HsIB { hsib_vars = sig_vars+                     , hsib_body = hs_ty }) kind+  = do { (tkvs, ty) <- tcImplicitTKBndrsType sig_vars $+                       tc_lhs_type typeLevelMode hs_ty kind+       ; return (mkSpecForAllTys tkvs ty) }++-----------------+tcHsDeriv :: LHsSigType Name -> TcM ([TyVar], Class, [Type], [Kind])+-- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause+-- Returns the C, [ty1, ty2, and the kinds of C's remaining arguments+-- E.g.    class C (a::*) (b::k->k)+--         data T a b = ... deriving( C Int )+--    returns ([k], C, [k, Int], [k->k])+tcHsDeriv hs_ty+  = do { cls_kind <- newMetaKindVar+                    -- always safe to kind-generalize, because there+                    -- can be no covars in an outer scope+       ; ty <- checkNoErrs $+                 -- avoid redundant error report with "illegal deriving", below+               tc_hs_sig_type_and_gen hs_ty cls_kind+       ; cls_kind <- zonkTcType cls_kind+       ; let (tvs, pred) = splitForAllTys ty+       ; let (args, _) = splitFunTys cls_kind+       ; case getClassPredTys_maybe pred of+           Just (cls, tys) -> return (tvs, cls, tys, args)+           Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) }++tcHsClsInstType :: UserTypeCtxt    -- InstDeclCtxt or SpecInstCtxt+                -> LHsSigType Name+                -> TcM ([TyVar], ThetaType, Class, [Type])+-- Like tcHsSigType, but for a class instance declaration+tcHsClsInstType user_ctxt hs_inst_ty+  = setSrcSpan (getLoc (hsSigType hs_inst_ty)) $+    do { inst_ty <- tc_hs_sig_type_and_gen hs_inst_ty constraintKind+       ; checkValidInstance user_ctxt hs_inst_ty inst_ty }++-- Used for 'VECTORISE [SCALAR] instance' declarations+tcHsVectInst :: LHsSigType Name -> TcM (Class, [Type])+tcHsVectInst ty+  | Just (L _ cls_name, tys) <- hsTyGetAppHead_maybe (hsSigType ty)+    -- Ignoring the binders looks pretty dodgy to me+  = do { (cls, cls_kind) <- tcClass cls_name+       ; (applied_class, _res_kind)+           <- tcInferApps typeLevelMode cls_name (mkClassPred cls []) cls_kind tys+       ; case tcSplitTyConApp_maybe applied_class of+           Just (_tc, args) -> ASSERT( _tc == classTyCon cls )+                               return (cls, args)+           _ -> failWithTc (text "Too many arguments passed to" <+> ppr cls_name) }+  | otherwise+  = failWithTc $ text "Malformed instance type"++----------------------------------------------+-- | Type-check a visible type application+tcHsTypeApp :: LHsWcType Name -> Kind -> TcM Type+tcHsTypeApp wc_ty kind+  | HsWC { hswc_wcs = sig_wcs, hswc_body = hs_ty } <- wc_ty+  = do { ty <- tcWildCardBindersX newWildTyVar sig_wcs $ \ _ ->+               tcCheckLHsType hs_ty kind+       ; ty <- zonkTcType ty+       ; checkValidType TypeAppCtxt ty+       ; return ty }+        -- NB: we don't call emitWildcardHoleConstraints here, because+        -- we want any holes in visible type applications to be used+        -- without fuss. No errors, warnings, extensions, etc.++{-+************************************************************************+*                                                                      *+            The main kind checker: no validity checks here+*                                                                      *+************************************************************************++        First a couple of simple wrappers for kcHsType+-}++---------------------------+tcHsOpenType, tcHsLiftedType,+  tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType Name -> TcM TcType+-- Used for type signatures+-- Do not do validity checking+tcHsOpenType ty   = addTypeCtxt ty $ tcHsOpenTypeNC ty+tcHsLiftedType ty = addTypeCtxt ty $ tcHsLiftedTypeNC ty++tcHsOpenTypeNC   ty = do { ek <- newOpenTypeKind+                         ; tc_lhs_type typeLevelMode ty ek }+tcHsLiftedTypeNC ty = tc_lhs_type typeLevelMode ty liftedTypeKind++-- Like tcHsType, but takes an expected kind+tcCheckLHsType :: LHsType Name -> Kind -> TcM Type+tcCheckLHsType hs_ty exp_kind+  = addTypeCtxt hs_ty $+    tc_lhs_type typeLevelMode hs_ty exp_kind++tcLHsType :: LHsType Name -> TcM (TcType, TcKind)+-- Called from outside: set the context+tcLHsType ty = addTypeCtxt ty (tc_infer_lhs_type typeLevelMode ty)++---------------------------+-- | Should we generalise the kind of this type signature?+-- We *should* generalise if the type is closed+-- or if NoMonoLocalBinds is set. Otherwise, nope.+-- See Note [Kind generalisation plan]+decideKindGeneralisationPlan :: LHsSigType Name -> TcM Bool+decideKindGeneralisationPlan sig_ty@(HsIB { hsib_closed = closed })+  = do { mono_locals <- xoptM LangExt.MonoLocalBinds+       ; let should_gen = not mono_locals || closed+       ; traceTc "decideKindGeneralisationPlan"+           (ppr sig_ty $$ text "should gen?" <+> ppr should_gen)+       ; return should_gen }++{- Note [Kind generalisation plan]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When should we do kind-generalisation for user-written type signature?+Answer: we use the same rule as for value bindings:++ * We always kind-generalise if the type signature is closed+ * Additionally, we attempt to generalise if we have NoMonoLocalBinds++Trac #13337 shows the problem if we kind-generalise an open type (i.e.+one that mentions in-scope tpe variable+  foo :: forall k (a :: k) proxy. (Typeable k, Typeable a)+      => proxy a -> String+  foo _ = case eqT :: Maybe (k :~: Type) of+            Nothing   -> ...+            Just Refl -> case eqT :: Maybe (a :~: Int) of ...++In the expression type sig on the last line, we have (a :: k)+but (Int :: Type).  Since (:~:) is kind-homogeneous, this requires+k ~ *, which is true in the Refl branch of the outer case.++That equality will be solved if we allow it to float out to the+implication constraint for the Refl match, bnot not if we aggressively+attempt to solve all equalities the moment they occur; that is, when+checking (Maybe (a :~: Int)).   (NB: solveEqualities fails unless it+solves all the kind equalities, which is the right thing at top level.)++So here the right thing is simply not to do kind generalisation!++************************************************************************+*                                                                      *+      Type-checking modes+*                                                                      *+************************************************************************++The kind-checker is parameterised by a TcTyMode, which contains some+information about where we're checking a type.++The renamer issues errors about what it can. All errors issued here must+concern things that the renamer can't handle.++-}++-- | Info about the context in which we're checking a type. Currently,+-- differentiates only between types and kinds, but this will likely+-- grow, at least to include the distinction between patterns and+-- not-patterns.+newtype TcTyMode+  = TcTyMode { mode_level :: TypeOrKind  -- True <=> type, False <=> kind+             }++typeLevelMode :: TcTyMode+typeLevelMode = TcTyMode { mode_level = TypeLevel }++kindLevelMode :: TcTyMode+kindLevelMode = TcTyMode { mode_level = KindLevel }++-- switch to kind level+kindLevel :: TcTyMode -> TcTyMode+kindLevel mode = mode { mode_level = KindLevel }++instance Outputable TcTyMode where+  ppr = ppr . mode_level++{-+Note [Bidirectional type checking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In expressions, whenever we see a polymorphic identifier, say `id`, we are+free to instantiate it with metavariables, knowing that we can always+re-generalize with type-lambdas when necessary. For example:++  rank2 :: (forall a. a -> a) -> ()+  x = rank2 id++When checking the body of `x`, we can instantiate `id` with a metavariable.+Then, when we're checking the application of `rank2`, we notice that we really+need a polymorphic `id`, and then re-generalize over the unconstrained+metavariable.++In types, however, we're not so lucky, because *we cannot re-generalize*!+There is no lambda. So, we must be careful only to instantiate at the last+possible moment, when we're sure we're never going to want the lost polymorphism+again. This is done in calls to tcInstBinders and tcInstBindersX.++To implement this behavior, we use bidirectional type checking, where we+explicitly think about whether we know the kind of the type we're checking+or not. Note that there is a difference between not knowing a kind and+knowing a metavariable kind: the metavariables are TauTvs, and cannot become+forall-quantified kinds. Previously (before dependent types), there were+no higher-rank kinds, and so we could instantiate early and be sure that+no types would have polymorphic kinds, and so we could always assume that+the kind of a type was a fresh metavariable. Not so anymore, thus the+need for two algorithms.++For HsType forms that can never be kind-polymorphic, we implement only the+"down" direction, where we safely assume a metavariable kind. For HsType forms+that *can* be kind-polymorphic, we implement just the "up" (functions with+"infer" in their name) version, as we gain nothing by also implementing the+"down" version.++Note [Future-proofing the type checker]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As discussed in Note [Bidirectional type checking], each HsType form is+handled in *either* tc_infer_hs_type *or* tc_hs_type. These functions+are mutually recursive, so that either one can work for any type former.+But, we want to make sure that our pattern-matches are complete. So,+we have a bunch of repetitive code just so that we get warnings if we're+missing any patterns.+-}++------------------------------------------+-- | Check and desugar a type, returning the core type and its+-- possibly-polymorphic kind. Much like 'tcInferRho' at the expression+-- level.+tc_infer_lhs_type :: TcTyMode -> LHsType Name -> TcM (TcType, TcKind)+tc_infer_lhs_type mode (L span ty)+  = setSrcSpan span $+    do { (ty', kind) <- tc_infer_hs_type mode ty+       ; return (ty', kind) }++-- | Infer the kind of a type and desugar. This is the "up" type-checker,+-- as described in Note [Bidirectional type checking]+tc_infer_hs_type :: TcTyMode -> HsType Name -> TcM (TcType, TcKind)+tc_infer_hs_type mode (HsTyVar _ (L _ tv)) = tcTyVar mode tv+tc_infer_hs_type mode (HsAppTy ty1 ty2)+  = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2]+       ; (fun_ty', fun_kind) <- tc_infer_lhs_type mode fun_ty+       ; fun_kind' <- zonkTcType fun_kind+       ; tcInferApps mode fun_ty fun_ty' fun_kind' arg_tys }+tc_infer_hs_type mode (HsParTy t)     = tc_infer_lhs_type mode t+tc_infer_hs_type mode (HsOpTy lhs (L _ op) rhs)+  | not (op `hasKey` funTyConKey)+  = do { (op', op_kind) <- tcTyVar mode op+       ; op_kind' <- zonkTcType op_kind+       ; tcInferApps mode op op' op_kind' [lhs, rhs] }+tc_infer_hs_type mode (HsKindSig ty sig)+  = do { sig' <- tc_lhs_kind (kindLevel mode) sig+       ; ty' <- tc_lhs_type mode ty sig'+       ; return (ty', sig') }+-- HsSpliced is an annotation produced by 'RnSplice.rnSpliceType' to communicate+-- the splice location to the typechecker. Here we skip over it in order to have+-- the same kind inferred for a given expression whether it was produced from+-- splices or not.+--+-- See Note [Delaying modFinalizers in untyped splices].+tc_infer_hs_type mode (HsSpliceTy (HsSpliced _ (HsSplicedTy ty)) _)+  = tc_infer_hs_type mode ty+tc_infer_hs_type mode (HsDocTy ty _) = tc_infer_lhs_type mode ty+tc_infer_hs_type _    (HsCoreTy ty)  = return (ty, typeKind ty)+tc_infer_hs_type mode other_ty+  = do { kv <- newMetaKindVar+       ; ty' <- tc_hs_type mode other_ty kv+       ; return (ty', kv) }++------------------------------------------+tc_lhs_type :: TcTyMode -> LHsType Name -> TcKind -> TcM TcType+tc_lhs_type mode (L span ty) exp_kind+  = setSrcSpan span $+    do { ty' <- tc_hs_type mode ty exp_kind+       ; return ty' }++------------------------------------------+tc_fun_type :: TcTyMode -> LHsType Name -> LHsType Name -> TcKind -> TcM TcType+tc_fun_type mode ty1 ty2 exp_kind = case mode_level mode of+  TypeLevel ->+    do { arg_k <- newOpenTypeKind+       ; res_k <- newOpenTypeKind+       ; ty1' <- tc_lhs_type mode ty1 arg_k+       ; ty2' <- tc_lhs_type mode ty2 res_k+       ; checkExpectedKind (mkFunTy ty1' ty2') liftedTypeKind exp_kind }+  KindLevel ->  -- no representation polymorphism in kinds. yet.+    do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind+       ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind+       ; checkExpectedKind (mkFunTy ty1' ty2') liftedTypeKind exp_kind }++------------------------------------------+-- See also Note [Bidirectional type checking]+tc_hs_type :: TcTyMode -> HsType Name -> TcKind -> TcM TcType+tc_hs_type mode (HsParTy ty)   exp_kind = tc_lhs_type mode ty exp_kind+tc_hs_type mode (HsDocTy ty _) exp_kind = tc_lhs_type mode ty exp_kind+tc_hs_type _ ty@(HsBangTy {}) _+    -- While top-level bangs at this point are eliminated (eg !(Maybe Int)),+    -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of+    -- bangs are invalid, so fail. (#7210)+    = failWithTc (text "Unexpected strictness annotation:" <+> ppr ty)+tc_hs_type _ ty@(HsRecTy _)      _+      -- Record types (which only show up temporarily in constructor+      -- signatures) should have been removed by now+    = failWithTc (text "Record syntax is illegal here:" <+> ppr ty)++-- HsSpliced is an annotation produced by 'RnSplice.rnSpliceType'.+-- Here we get rid of it and add the finalizers to the global environment+-- while capturing the local environment.+--+-- See Note [Delaying modFinalizers in untyped splices].+tc_hs_type mode (HsSpliceTy (HsSpliced mod_finalizers (HsSplicedTy ty))+                            _+                )+           exp_kind+  = do addModFinalizersWithLclEnv mod_finalizers+       tc_hs_type mode ty exp_kind++-- This should never happen; type splices are expanded by the renamer+tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind+  = failWithTc (text "Unexpected type splice:" <+> ppr ty)++---------- Functions and applications+tc_hs_type mode (HsFunTy ty1 ty2) exp_kind+  = tc_fun_type mode ty1 ty2 exp_kind++tc_hs_type mode (HsOpTy ty1 (L _ op) ty2) exp_kind+  | op `hasKey` funTyConKey+  = tc_fun_type mode ty1 ty2 exp_kind++--------- Foralls+tc_hs_type mode (HsForAllTy { hst_bndrs = hs_tvs, hst_body = ty }) exp_kind+  = fmap fst $+    tcExplicitTKBndrs hs_tvs $ \ tvs' ->+    -- Do not kind-generalise here!  See Note [Kind generalisation]+    -- Why exp_kind?  See Note [Body kind of HsForAllTy]+    do { ty' <- tc_lhs_type mode ty exp_kind+       ; let bound_vars = allBoundVariables ty'+             bndrs      = mkTyVarBinders Specified tvs'+       ; return (mkForAllTys bndrs ty', bound_vars) }++tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) exp_kind+  | null (unLoc ctxt)+  = tc_lhs_type mode ty exp_kind++  | otherwise+  = do { ctxt' <- tc_hs_context mode ctxt++         -- See Note [Body kind of a HsQualTy]+       ; ty' <- if isConstraintKind exp_kind+                then tc_lhs_type mode ty constraintKind+                else do { ek <- newOpenTypeKind+                                -- The body kind (result of the function)+                                -- can be * or #, hence newOpenTypeKind+                        ; ty <- tc_lhs_type mode ty ek+                        ; checkExpectedKind ty liftedTypeKind exp_kind }++       ; return (mkPhiTy ctxt' ty') }++--------- Lists, arrays, and tuples+tc_hs_type mode (HsListTy elt_ty) exp_kind+  = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind+       ; checkWiredInTyCon listTyCon+       ; checkExpectedKind (mkListTy tau_ty) liftedTypeKind exp_kind }++tc_hs_type mode (HsPArrTy elt_ty) exp_kind+  = do { MASSERT( isTypeLevel (mode_level mode) )+       ; tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind+       ; checkWiredInTyCon parrTyCon+       ; checkExpectedKind (mkPArrTy tau_ty) liftedTypeKind exp_kind }++-- See Note [Distinguishing tuple kinds] in HsTypes+-- See Note [Inferring tuple kinds]+tc_hs_type mode (HsTupleTy HsBoxedOrConstraintTuple hs_tys) exp_kind+     -- (NB: not zonking before looking at exp_k, to avoid left-right bias)+  | Just tup_sort <- tupKindSort_maybe exp_kind+  = traceTc "tc_hs_type tuple" (ppr hs_tys) >>+    tc_tuple mode tup_sort hs_tys exp_kind+  | otherwise+  = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys)+       ; (tys, kinds) <- mapAndUnzipM (tc_infer_lhs_type mode) hs_tys+       ; kinds <- mapM zonkTcType kinds+           -- Infer each arg type separately, because errors can be+           -- confusing if we give them a shared kind.  Eg Trac #7410+           -- (Either Int, Int), we do not want to get an error saying+           -- "the second argument of a tuple should have kind *->*"++       ; let (arg_kind, tup_sort)+               = case [ (k,s) | k <- kinds+                              , Just s <- [tupKindSort_maybe k] ] of+                    ((k,s) : _) -> (k,s)+                    [] -> (liftedTypeKind, BoxedTuple)+         -- In the [] case, it's not clear what the kind is, so guess *++       ; tys' <- sequence [ setSrcSpan loc $+                            checkExpectedKind ty kind arg_kind+                          | ((L loc _),ty,kind) <- zip3 hs_tys tys kinds ]++       ; finish_tuple tup_sort tys' (map (const arg_kind) tys') exp_kind }+++tc_hs_type mode (HsTupleTy hs_tup_sort tys) exp_kind+  = tc_tuple mode tup_sort tys exp_kind+  where+    tup_sort = case hs_tup_sort of  -- Fourth case dealt with above+                  HsUnboxedTuple    -> UnboxedTuple+                  HsBoxedTuple      -> BoxedTuple+                  HsConstraintTuple -> ConstraintTuple+                  _                 -> panic "tc_hs_type HsTupleTy"++tc_hs_type mode (HsSumTy hs_tys) exp_kind+  = do { let arity = length hs_tys+       ; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys+       ; tau_tys   <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds+       ; let arg_reps = map (getRuntimeRepFromKind "tc_hs_type HsSumTy") arg_kinds+             arg_tys  = arg_reps ++ tau_tys+       ; checkExpectedKind (mkTyConApp (sumTyCon arity) arg_tys)+                           (unboxedSumKind arg_reps)+                           exp_kind+       }++--------- Promoted lists and tuples+tc_hs_type mode (HsExplicitListTy _ _k tys) exp_kind+  = do { tks <- mapM (tc_infer_lhs_type mode) tys+       ; (taus', kind) <- unifyKinds tks+       ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus')+       ; checkExpectedKind ty (mkListTy kind) exp_kind }+  where+    mk_cons k a b = mkTyConApp (promoteDataCon consDataCon) [k, a, b]+    mk_nil  k     = mkTyConApp (promoteDataCon nilDataCon) [k]++tc_hs_type mode (HsExplicitTupleTy _ tys) exp_kind+  -- using newMetaKindVar means that we force instantiations of any polykinded+  -- types. At first, I just used tc_infer_lhs_type, but that led to #11255.+  = do { ks   <- replicateM arity newMetaKindVar+       ; taus <- zipWithM (tc_lhs_type mode) tys ks+       ; let kind_con   = tupleTyCon           Boxed arity+             ty_con     = promotedTupleDataCon Boxed arity+             tup_k      = mkTyConApp kind_con ks+       ; checkExpectedKind (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind }+  where+    arity = length tys++--------- Constraint types+tc_hs_type mode (HsIParamTy (L _ n) ty) exp_kind+  = do { MASSERT( isTypeLevel (mode_level mode) )+       ; ty' <- tc_lhs_type mode ty liftedTypeKind+       ; let n' = mkStrLitTy $ hsIPNameFS n+       ; ipClass <- tcLookupClass ipClassName+       ; checkExpectedKind (mkClassPred ipClass [n',ty'])+           constraintKind exp_kind }++tc_hs_type mode (HsEqTy ty1 ty2) exp_kind+  = do { (ty1', kind1) <- tc_infer_lhs_type mode ty1+       ; (ty2', kind2) <- tc_infer_lhs_type mode ty2+       ; ty2'' <- checkExpectedKind ty2' kind2 kind1+       ; eq_tc <- tcLookupTyCon eqTyConName+       ; let ty' = mkNakedTyConApp eq_tc [kind1, ty1', ty2'']+       ; checkExpectedKind ty' constraintKind exp_kind }++--------- Literals+tc_hs_type _ (HsTyLit (HsNumTy _ n)) exp_kind+  = do { checkWiredInTyCon typeNatKindCon+       ; checkExpectedKind (mkNumLitTy n) typeNatKind exp_kind }++tc_hs_type _ (HsTyLit (HsStrTy _ s)) exp_kind+  = do { checkWiredInTyCon typeSymbolKindCon+       ; checkExpectedKind (mkStrLitTy s) typeSymbolKind exp_kind }++--------- Potentially kind-polymorphic types: call the "up" checker+-- See Note [Future-proofing the type checker]+tc_hs_type mode ty@(HsTyVar {})   ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(HsAppTy {})   ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(HsOpTy {})    ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(HsKindSig {}) ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(HsCoreTy {})  ek = tc_infer_hs_type_ek mode ty ek++tc_hs_type _ (HsWildCardTy wc) exp_kind+  = do { wc_tv <- tcWildCardOcc wc exp_kind+       ; return (mkTyVarTy wc_tv) }++-- disposed of by renamer+tc_hs_type _ ty@(HsAppsTy {}) _+  = pprPanic "tc_hs_tyep HsAppsTy" (ppr ty)++tcWildCardOcc :: HsWildCardInfo Name -> Kind -> TcM TcTyVar+tcWildCardOcc wc_info exp_kind+  = do { wc_tv <- tcLookupTyVar (wildCardName wc_info)+          -- The wildcard's kind should be an un-filled-in meta tyvar+       ; let Just wc_kind_var = tcGetTyVar_maybe (tyVarKind wc_tv)+       ; writeMetaTyVar wc_kind_var exp_kind+       ; return wc_tv }++---------------------------+-- | Call 'tc_infer_hs_type' and check its result against an expected kind.+tc_infer_hs_type_ek :: TcTyMode -> HsType Name -> TcKind -> TcM TcType+tc_infer_hs_type_ek mode ty ek+  = do { (ty', k) <- tc_infer_hs_type mode ty+       ; checkExpectedKind ty' k ek }++---------------------------+tupKindSort_maybe :: TcKind -> Maybe TupleSort+tupKindSort_maybe k+  | Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k'+  | Just k'      <- tcView k            = tupKindSort_maybe k'+  | isConstraintKind k = Just ConstraintTuple+  | isLiftedTypeKind k = Just BoxedTuple+  | otherwise          = Nothing++tc_tuple :: TcTyMode -> TupleSort -> [LHsType Name] -> TcKind -> TcM TcType+tc_tuple mode tup_sort tys exp_kind+  = do { arg_kinds <- case tup_sort of+           BoxedTuple      -> return (nOfThem arity liftedTypeKind)+           UnboxedTuple    -> mapM (\_ -> newOpenTypeKind) tys+           ConstraintTuple -> return (nOfThem arity constraintKind)+       ; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds+       ; finish_tuple tup_sort tau_tys arg_kinds exp_kind }+  where+    arity   = length tys++finish_tuple :: TupleSort+             -> [TcType]    -- ^ argument types+             -> [TcKind]    -- ^ of these kinds+             -> TcKind      -- ^ expected kind of the whole tuple+             -> TcM TcType+finish_tuple tup_sort tau_tys tau_kinds exp_kind+  = do { traceTc "finish_tuple" (ppr res_kind $$ ppr tau_kinds $$ ppr exp_kind)+       ; let arg_tys  = case tup_sort of+                   -- See also Note [Unboxed tuple RuntimeRep vars] in TyCon+                 UnboxedTuple    -> tau_reps ++ tau_tys+                 BoxedTuple      -> tau_tys+                 ConstraintTuple -> tau_tys+       ; tycon <- case tup_sort of+           ConstraintTuple+             | arity > mAX_CTUPLE_SIZE+                         -> failWith (bigConstraintTuple arity)+             | otherwise -> tcLookupTyCon (cTupleTyConName arity)+           BoxedTuple    -> do { let tc = tupleTyCon Boxed arity+                               ; checkWiredInTyCon tc+                               ; return tc }+           UnboxedTuple  -> return (tupleTyCon Unboxed arity)+       ; checkExpectedKind (mkTyConApp tycon arg_tys) res_kind exp_kind }+  where+    arity = length tau_tys+    tau_reps = map (getRuntimeRepFromKind "finish_tuple") tau_kinds+    res_kind = case tup_sort of+                 UnboxedTuple    -> unboxedTupleKind tau_reps+                 BoxedTuple      -> liftedTypeKind+                 ConstraintTuple -> constraintKind++bigConstraintTuple :: Arity -> MsgDoc+bigConstraintTuple arity+  = hang (text "Constraint tuple arity too large:" <+> int arity+          <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE))+       2 (text "Instead, use a nested tuple")++---------------------------+-- | Apply a type of a given kind to a list of arguments. This instantiates+-- invisible parameters as necessary. However, it does *not* necessarily+-- apply all the arguments, if the kind runs out of binders.+-- Never calls 'matchExpectedFunKind'; when the kind runs out of binders,+-- this stops processing.+-- This takes an optional @VarEnv Kind@ which maps kind variables to kinds.+-- These kinds should be used to instantiate invisible kind variables;+-- they come from an enclosing class for an associated type/data family.+-- This version will instantiate all invisible arguments left over after+-- the visible ones. Used only when typechecking type/data family patterns+-- (where we need to instantiate all remaining invisible parameters; for+-- example, consider @type family F :: k where F = Int; F = Maybe@. We+-- need to instantiate the @k@.)+tcInferArgs :: Outputable fun+            => fun                      -- ^ the function+            -> [TyConBinder]            -- ^ function kind's binders+            -> Maybe (VarEnv Kind)      -- ^ possibly, kind info (see above)+            -> [LHsType Name]           -- ^ args+            -> TcM (TCvSubst, [TyBinder], [TcType], [LHsType Name], Int)+               -- ^ (instantiating subst, un-insted leftover binders,+               --   typechecked args, untypechecked args, n)+tcInferArgs fun tc_binders mb_kind_info args+  = do { let binders = tyConBindersTyBinders tc_binders  -- UGH!+       ; (subst, leftover_binders, args', leftovers, n)+           <- tc_infer_args typeLevelMode fun binders mb_kind_info args 1+        -- now, we need to instantiate any remaining invisible arguments+       ; let (invis_bndrs, other_binders) = break isVisibleBinder leftover_binders+       ; (subst', invis_args)+           <- tcInstBindersX subst mb_kind_info invis_bndrs+       ; return ( subst'+                , other_binders+                , args' `chkAppend` invis_args+                , leftovers, n ) }++-- | See comments for 'tcInferArgs'. But this version does not instantiate+-- any remaining invisible arguments.+tc_infer_args :: Outputable fun+              => TcTyMode+              -> fun                      -- ^ the function+              -> [TyBinder]               -- ^ function kind's binders (zonked)+              -> Maybe (VarEnv Kind)      -- ^ possibly, kind info (see above)+              -> [LHsType Name]           -- ^ args+              -> Int                      -- ^ number to start arg counter at+              -> TcM (TCvSubst, [TyBinder], [TcType], [LHsType Name], Int)+tc_infer_args mode orig_ty binders mb_kind_info orig_args n0+  = go emptyTCvSubst binders orig_args n0 []+  where+    go subst binders []   n acc+      = return ( subst, binders, reverse acc, [], n )+    -- when we call this when checking type family patterns, we really+    -- do want to instantiate all invisible arguments. During other+    -- typechecking, we don't.++    go subst (binder:binders) all_args@(arg:args) n acc+      | isInvisibleBinder binder+      = do { traceTc "tc_infer_args (invis)" (ppr binder)+           ; (subst', arg') <- tcInstBinderX mb_kind_info subst binder+           ; go subst' binders all_args n (arg' : acc) }++      | otherwise+      = do { traceTc "tc_infer_args (vis)" (ppr binder $$ ppr arg)+           ; arg' <- addErrCtxt (funAppCtxt orig_ty arg n) $+                     tc_lhs_type mode arg (substTyUnchecked subst $+                                           tyBinderType binder)+           ; let subst' = extendTvSubstBinder subst binder arg'+           ; go subst' binders args (n+1) (arg' : acc) }++    go subst [] all_args n acc+      = return (subst, [], reverse acc, all_args, n)++-- | Applies a type to a list of arguments.+-- Always consumes all the arguments, using 'matchExpectedFunKind' as+-- necessary. If you wish to apply a type to a list of HsTypes, this is+-- your function.+-- Used for type-checking types only.+tcInferApps :: Outputable fun+            => TcTyMode+            -> fun                  -- ^ Function (for printing only)+            -> TcType               -- ^ Function (could be knot-tied)+            -> TcKind               -- ^ Function kind (zonked)+            -> [LHsType Name]       -- ^ Args+            -> TcM (TcType, TcKind) -- ^ (f args, result kind)+tcInferApps mode orig_ty ty ki args = go ty ki args 1+  where+    go fun fun_kind []   _ = return (fun, fun_kind)+    go fun fun_kind args n+      | let (binders, res_kind) = splitPiTys fun_kind+      , not (null binders)+      = do { (subst, leftover_binders, args', leftover_args, n')+                <- tc_infer_args mode orig_ty binders Nothing args n+           ; let fun_kind' = substTyUnchecked subst $+                             mkPiTys leftover_binders res_kind+           ; go (mkNakedAppTys fun args') fun_kind' leftover_args n' }++    go fun fun_kind all_args@(arg:args) n+      = do { (co, arg_k, res_k) <- matchExpectedFunKind (length all_args)+                                                        fun fun_kind+           ; arg' <- addErrCtxt (funAppCtxt orig_ty arg n) $+                     tc_lhs_type mode arg arg_k+           ; go (mkNakedAppTy (fun `mkNakedCastTy` co) arg')+                res_k args (n+1) }++--------------------------+checkExpectedKind :: TcType               -- the type whose kind we're checking+                  -> TcKind               -- the known kind of that type, k+                  -> TcKind               -- the expected kind, exp_kind+                  -> TcM TcType    -- a possibly-inst'ed, casted type :: exp_kind+-- Instantiate a kind (if necessary) and then call unifyType+--      (checkExpectedKind ty act_kind exp_kind)+-- checks that the actual kind act_kind is compatible+--      with the expected kind exp_kind+checkExpectedKind ty act_kind exp_kind+ = do { (ty', act_kind') <- instantiate ty act_kind exp_kind+      ; let origin = TypeEqOrigin { uo_actual   = act_kind'+                                  , uo_expected = exp_kind+                                  , uo_thing    = Just $ mkTypeErrorThing ty'+                                  }+      ; co_k <- uType origin KindLevel act_kind' exp_kind+      ; traceTc "checkExpectedKind" (vcat [ ppr act_kind+                                          , ppr exp_kind+                                          , ppr co_k ])+      ; let result_ty = ty' `mkNakedCastTy` co_k+      ; return result_ty }+  where+    -- we need to make sure that both kinds have the same number of implicit+    -- foralls out front. If the actual kind has more, instantiate accordingly.+    -- Otherwise, just pass the type & kind through -- the errors are caught+    -- in unifyType.+    instantiate :: TcType    -- the type+                -> TcKind    -- of this kind+                -> TcKind   -- but expected to be of this one+                -> TcM ( TcType   -- the inst'ed type+                       , TcKind ) -- its new kind+    instantiate ty act_ki exp_ki+      = let (exp_bndrs, _) = splitPiTysInvisible exp_ki in+        instantiateTyN (length exp_bndrs) ty act_ki++-- | Instantiate a type to have at most @n@ invisible arguments.+instantiateTyN :: Int    -- ^ @n@+               -> TcType -- ^ the type+               -> TcKind -- ^ its kind+               -> TcM (TcType, TcKind)   -- ^ The inst'ed type with kind+instantiateTyN n ty ki+  = let (bndrs, inner_ki)            = splitPiTysInvisible ki+        num_to_inst                  = length bndrs - n+           -- NB: splitAt is forgiving with invalid numbers+        (inst_bndrs, leftover_bndrs) = splitAt num_to_inst bndrs+        empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ki))+    in+    if num_to_inst <= 0 then return (ty, ki) else+    do { (subst, inst_args) <- tcInstBindersX empty_subst Nothing inst_bndrs+       ; let rebuilt_ki = mkPiTys leftover_bndrs inner_ki+             ki'        = substTy subst rebuilt_ki+       ; traceTc "instantiateTyN" (vcat [ ppr ty <+> dcolon <+> ppr ki+                                        , ppr subst+                                        , ppr rebuilt_ki+                                        , ppr ki' ])+       ; return (mkNakedAppTys ty inst_args, ki') }++---------------------------+tcHsContext :: LHsContext Name -> TcM [PredType]+tcHsContext = tc_hs_context typeLevelMode++tcLHsPredType :: LHsType Name -> TcM PredType+tcLHsPredType = tc_lhs_pred typeLevelMode++tc_hs_context :: TcTyMode -> LHsContext Name -> TcM [PredType]+tc_hs_context mode ctxt = mapM (tc_lhs_pred mode) (unLoc ctxt)++tc_lhs_pred :: TcTyMode -> LHsType Name -> TcM PredType+tc_lhs_pred mode pred = tc_lhs_type mode pred constraintKind++---------------------------+tcTyVar :: TcTyMode -> Name -> TcM (TcType, TcKind)+-- See Note [Type checking recursive type and class declarations]+-- in TcTyClsDecls+tcTyVar mode name         -- Could be a tyvar, a tycon, or a datacon+  = do { traceTc "lk1" (ppr name)+       ; thing <- tcLookup name+       ; case thing of+           ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv)++           ATcTyCon tc_tc -> do { -- See Note [GADT kind self-reference]+                                  unless+                                    (isTypeLevel (mode_level mode))+                                    (promotionErr name TyConPE)+                                ; check_tc tc_tc+                                ; tc <- get_loopy_tc name tc_tc+                                ; handle_tyfams tc tc_tc }+                             -- mkNakedTyConApp: see Note [Type-checking inside the knot]+                 -- NB: we really should check if we're at the kind level+                 -- and if the tycon is promotable if -XNoTypeInType is set.+                 -- But this is a terribly large amount of work! Not worth it.++           AGlobal (ATyCon tc)+             -> do { check_tc tc+                   ; handle_tyfams tc tc }++           AGlobal (AConLike (RealDataCon dc))+             -> do { data_kinds <- xoptM LangExt.DataKinds+                   ; unless (data_kinds || specialPromotedDc dc) $+                       promotionErr name NoDataKindsDC+                   ; type_in_type <- xoptM LangExt.TypeInType+                   ; unless ( type_in_type ||+                              ( isTypeLevel (mode_level mode) &&+                                isLegacyPromotableDataCon dc ) ||+                              ( isKindLevel (mode_level mode) &&+                                specialPromotedDc dc ) ) $+                       promotionErr name NoTypeInTypeDC+                   ; let tc = promoteDataCon dc+                   ; return (mkNakedTyConApp tc [], tyConKind tc) }++           APromotionErr err -> promotionErr name err++           _  -> wrongThingErr "type" thing name }+  where+    check_tc :: TyCon -> TcM ()+    check_tc tc = do { type_in_type <- xoptM LangExt.TypeInType+                     ; data_kinds   <- xoptM LangExt.DataKinds+                     ; unless (isTypeLevel (mode_level mode) ||+                               data_kinds ||+                               isKindTyCon tc) $+                       promotionErr name NoDataKindsTC+                     ; unless (isTypeLevel (mode_level mode) ||+                               type_in_type ||+                               isLegacyPromotableTyCon tc) $+                       promotionErr name NoTypeInTypeTC }++    -- if we are type-checking a type family tycon, we must instantiate+    -- any invisible arguments right away. Otherwise, we get #11246+    handle_tyfams :: TyCon   -- the tycon to instantiate (might be loopy)+                  -> TyCon   -- a non-loopy version of the tycon+                  -> TcM (TcType, TcKind)+    handle_tyfams tc tc_tc+      | mightBeUnsaturatedTyCon tc_tc+      = do { traceTc "tcTyVar2a" (ppr tc_tc $$ ppr tc_kind)+           ; return (ty, tc_kind) }++      | otherwise+      = do { (tc_ty, kind) <- instantiateTyN 0 ty tc_kind+           -- tc and tc_ty must not be traced here, because that would+           -- force the evaluation of a potentially knot-tied variable (tc),+           -- and the typechecker would hang, as per #11708+           ; traceTc "tcTyVar2b" (vcat [ ppr tc_tc <+> dcolon <+> ppr tc_kind+                                       , ppr kind ])+           ; return (tc_ty, kind) }+      where+        ty      = mkNakedTyConApp tc []+        tc_kind = tyConKind tc_tc++    get_loopy_tc :: Name -> TyCon -> TcM TyCon+    -- Return the knot-tied global TyCon if there is one+    -- Otherwise the local TcTyCon; we must be doing kind checking+    -- but we still want to return a TyCon of some sort to use in+    -- error messages+    get_loopy_tc name tc_tc+      = do { env <- getGblEnv+           ; case lookupNameEnv (tcg_type_env env) name of+                Just (ATyCon tc) -> return tc+                _                -> do { traceTc "lk1 (loopy)" (ppr name)+                                       ; return tc_tc } }++tcClass :: Name -> TcM (Class, TcKind)+tcClass cls     -- Must be a class+  = do { thing <- tcLookup cls+       ; case thing of+           ATcTyCon tc -> return (aThingErr "tcClass" cls, tyConKind tc)+           AGlobal (ATyCon tc)+             | Just cls <- tyConClass_maybe tc+             -> return (cls, tyConKind tc)+           _ -> wrongThingErr "class" thing cls }+++aThingErr :: String -> Name -> b+-- The type checker for types is sometimes called simply to+-- do *kind* checking; and in that case it ignores the type+-- returned. Which is a good thing since it may not be available yet!+aThingErr str x = pprPanic "AThing evaluated unexpectedly" (text str <+> ppr x)++{-+Note [Type-checking inside the knot]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we are checking the argument types of a data constructor.  We+must zonk the types before making the DataCon, because once built we+can't change it.  So we must traverse the type.++BUT the parent TyCon is knot-tied, so we can't look at it yet.++So we must be careful not to use "smart constructors" for types that+look at the TyCon or Class involved.++  * Hence the use of mkNakedXXX functions. These do *not* enforce+    the invariants (for example that we use (FunTy s t) rather+    than (TyConApp (->) [s,t])).++  * The zonking functions establish invariants (even zonkTcType, a change from+    previous behaviour). So we must never inspect the result of a+    zonk that might mention a knot-tied TyCon. This is generally OK+    because we zonk *kinds* while kind-checking types. And the TyCons+    in kinds shouldn't be knot-tied, because they come from a previous+    mutually recursive group.++  * TcHsSyn.zonkTcTypeToType also can safely check/establish+    invariants.++This is horribly delicate.  I hate it.  A good example of how+delicate it is can be seen in Trac #7903.++Note [GADT kind self-reference]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++A promoted type cannot be used in the body of that type's declaration.+Trac #11554 shows this example, which made GHC loop:++  import Data.Kind+  data P (x :: k) = Q+  data A :: Type where+    B :: forall (a :: A). P a -> A++In order to check the constructor B, we need to have the promoted type A, but in+order to get that promoted type, B must first be checked. To prevent looping, a+TyConPE promotion error is given when tcTyVar checks an ATcTyCon in kind mode.+Any ATcTyCon is a TyCon being defined in the current recursive group (see data+type decl for TcTyThing), and all such TyCons are illegal in kinds.++Trac #11962 proposes checking the head of a data declaration separately from+its constructors. This would allow the example above to pass.++Note [Body kind of a HsForAllTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The body of a forall is usually a type, but in principle+there's no reason to prohibit *unlifted* types.+In fact, GHC can itself construct a function with an+unboxed tuple inside a for-all (via CPR analyis; see+typecheck/should_compile/tc170).++Moreover in instance heads we get forall-types with+kind Constraint.++It's tempting to check that the body kind is either * or #. But this is+wrong. For example:++  class C a b+  newtype N = Mk Foo deriving (C a)++We're doing newtype-deriving for C. But notice how `a` isn't in scope in+the predicate `C a`. So we quantify, yielding `forall a. C a` even though+`C a` has kind `* -> Constraint`. The `forall a. C a` is a bit cheeky, but+convenient. Bottom line: don't check for * or # here.++Note [Body kind of a HsQualTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If ctxt is non-empty, the HsQualTy really is a /function/, so the+kind of the result really is '*', and in that case the kind of the+body-type can be lifted or unlifted.++However, consider+    instance Eq a => Eq [a] where ...+or+    f :: (Eq a => Eq [a]) => blah+Here both body-kind of the HsQualTy is Constraint rather than *.+Rather crudely we tell the difference by looking at exp_kind. It's+very convenient to typecheck instance types like any other HsSigType.++Admittedly the '(Eq a => Eq [a]) => blah' case is erroneous, but it's+better to reject in checkValidType.  If we say that the body kind+should be '*' we risk getting TWO error messages, one saying that Eq+[a] doens't have kind '*', and one saying that we need a Constraint to+the left of the outer (=>).++How do we figure out the right body kind?  Well, it's a bit of a+kludge: I just look at the expected kind.  If it's Constraint, we+must be in this instance situation context. It's a kludge because it+wouldn't work if any unification was involved to compute that result+kind -- but it isn't.  (The true way might be to use the 'mode'+parameter, but that seemed like a sledgehammer to crack a nut.)++Note [Inferring tuple kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple,+we try to figure out whether it's a tuple of kind * or Constraint.+  Step 1: look at the expected kind+  Step 2: infer argument kinds++If after Step 2 it's not clear from the arguments that it's+Constraint, then it must be *.  Once having decided that we re-check+the Check the arguments again to give good error messages+in eg. `(Maybe, Maybe)`++Note that we will still fail to infer the correct kind in this case:++  type T a = ((a,a), D a)+  type family D :: Constraint -> Constraint++While kind checking T, we do not yet know the kind of D, so we will default the+kind of T to * -> *. It works if we annotate `a` with kind `Constraint`.++Note [Desugaring types]+~~~~~~~~~~~~~~~~~~~~~~~+The type desugarer is phase 2 of dealing with HsTypes.  Specifically:++  * It transforms from HsType to Type++  * It zonks any kinds.  The returned type should have no mutable kind+    or type variables (hence returning Type not TcType):+      - any unconstrained kind variables are defaulted to (Any *) just+        as in TcHsSyn.+      - there are no mutable type variables because we are+        kind-checking a type+    Reason: the returned type may be put in a TyCon or DataCon where+    it will never subsequently be zonked.++You might worry about nested scopes:+        ..a:kappa in scope..+            let f :: forall b. T '[a,b] -> Int+In this case, f's type could have a mutable kind variable kappa in it;+and we might then default it to (Any *) when dealing with f's type+signature.  But we don't expect this to happen because we can't get a+lexically scoped type variable with a mutable kind variable in it.  A+delicate point, this.  If it becomes an issue we might need to+distinguish top-level from nested uses.++Moreover+  * it cannot fail,+  * it does no unifications+  * it does no validity checking, except for structural matters, such as+        (a) spurious ! annotations.+        (b) a class used as a type++Note [Kind of a type splice]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider these terms, each with TH type splice inside:+     [| e1 :: Maybe $(..blah..) |]+     [| e2 :: $(..blah..) |]+When kind-checking the type signature, we'll kind-check the splice+$(..blah..); we want to give it a kind that can fit in any context,+as if $(..blah..) :: forall k. k.++In the e1 example, the context of the splice fixes kappa to *.  But+in the e2 example, we'll desugar the type, zonking the kind unification+variables as we go.  When we encounter the unconstrained kappa, we+want to default it to '*', not to (Any *).+++Help functions for type applications+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-}++addTypeCtxt :: LHsType Name -> TcM a -> TcM a+        -- Wrap a context around only if we want to show that contexts.+        -- Omit invisble ones and ones user's won't grok+addTypeCtxt (L _ ty) thing+  = addErrCtxt doc thing+  where+    doc = text "In the type" <+> quotes (ppr ty)++{-+************************************************************************+*                                                                      *+                Type-variable binders+%*                                                                      *+%************************************************************************++Note [Scope-check inferred kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++  data SameKind :: k -> k -> *+  foo :: forall a (b :: Proxy a) (c :: Proxy d). SameKind b c++d has no binding site. So it gets bound implicitly, at the top. The+problem is that d's kind mentions `a`. So it's all ill-scoped.++The way we check for this is to gather all variables *bound* in a+type variable's scope. The type variable's kind should not mention+any of these variables. That is, d's kind can't mention a, b, or c.+We can't just check to make sure that d's kind is in scope, because+we might be about to kindGeneralize.++A little messy, but it works.++Note [Dependent LHsQTyVars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We track (in the renamer) which explicitly bound variables in a+LHsQTyVars are manifestly dependent; only precisely these variables+may be used within the LHsQTyVars. We must do this so that kcHsTyVarBndrs+can produce the right TyConBinders, and tell Anon vs. Named. Earlier,+I thought it would work simply to do a free-variable check during+kcHsTyVarBndrs, but this is bogus, because there may be unsolved+equalities about. And we don't want to eagerly solve the equalities,+because we may get further information after kcHsTyVarBndrs is called.+(Recall that kcHsTyVarBndrs is usually called from getInitialKind.+The only other case is in kcConDecl.) This is what implements the rule+that all variables intended to be dependent must be manifestly so.++Sidenote: It's quite possible that later, we'll consider (t -> s)+as a degenerate case of some (pi (x :: t) -> s) and then this will+all get more permissive.++-}++tcWildCardBinders :: [Name]+                  -> ([(Name, TcTyVar)] -> TcM a)+                  -> TcM a+tcWildCardBinders = tcWildCardBindersX new_tv+  where+    new_tv name = do { kind <- newMetaKindVar+                     ; newSkolemTyVar name kind }++tcWildCardBindersX :: (Name -> TcM TcTyVar)+                   -> [Name]+                   -> ([(Name, TcTyVar)] -> TcM a)+                   -> TcM a+tcWildCardBindersX new_wc wc_names thing_inside+  = do { wcs <- mapM new_wc wc_names+       ; let wc_prs = wc_names `zip` wcs+       ; tcExtendTyVarEnv2 wc_prs $+         thing_inside wc_prs }++-- | Kind-check a 'LHsQTyVars'. If the decl under consideration has a complete,+-- user-supplied kind signature (CUSK), generalise the result.+-- Used in 'getInitialKind' (for tycon kinds and other kinds)+-- and in kind-checking (but not for tycon kinds, which are checked with+-- tcTyClDecls). See also Note [Complete user-supplied kind signatures] in+-- HsDecls.+--+-- This function does not do telescope checking.+kcHsTyVarBndrs :: Name    -- ^ of the thing being checked+               -> Bool    -- ^ True <=> the TyCon being kind-checked can be unsaturated+               -> Bool    -- ^ True <=> the decl being checked has a CUSK+               -> Bool    -- ^ True <=> the decl is an open type/data family+               -> Bool    -- ^ True <=> all the hsq_implicit are *kind* vars+                          -- (will give these kind * if -XNoTypeInType)+               -> LHsQTyVars Name+               -> TcM (Kind, r)     -- ^ The result kind, possibly with other info+               -> TcM (TcTyCon, r)  -- ^ A suitably-kinded TcTyCon+kcHsTyVarBndrs name unsat cusk open_fam all_kind_vars+  (HsQTvs { hsq_implicit = kv_ns, hsq_explicit = hs_tvs+          , hsq_dependent = dep_names }) thing_inside+  | cusk+  = do { kv_kinds <- mk_kv_kinds+       ; lvl <- getTcLevel+       ; let scoped_kvs = zipWith (mk_skolem_tv lvl) kv_ns kv_kinds+       ; tcExtendTyVarEnv2 (kv_ns `zip` scoped_kvs) $+    do { (tc_binders, res_kind, stuff) <- solveEqualities $+                                          bind_telescope hs_tvs thing_inside++           -- Now, because we're in a CUSK, quantify over the mentioned+           -- kind vars, in dependency order.+       ; tc_binders  <- mapM zonkTcTyVarBinder tc_binders+       ; res_kind <- zonkTcType res_kind+       ; let tc_tvs = binderVars tc_binders+             qkvs   = tyCoVarsOfTypeWellScoped (mkTyConKind tc_binders res_kind)+                   -- the visibility of tvs doesn't matter here; we just+                   -- want the free variables not to include the tvs++          -- If there are any meta-tvs left, the user has+          -- lied about having a CUSK. Error.+       ; let (meta_tvs, good_tvs) = partition isMetaTyVar qkvs+       ; when (not (null meta_tvs)) $+         report_non_cusk_tvs (qkvs ++ tc_tvs)++          -- If any of the scoped_kvs aren't actually mentioned in a binder's+          -- kind (or the return kind), then we're in the CUSK case from+          -- Note [Free-floating kind vars]+       ; let all_tc_tvs        = good_tvs ++ tc_tvs+             all_mentioned_tvs = mapUnionVarSet (tyCoVarsOfType . tyVarKind)+                                                all_tc_tvs+                                 `unionVarSet` tyCoVarsOfType res_kind+             unmentioned_kvs   = filterOut (`elemVarSet` all_mentioned_tvs)+                                           scoped_kvs+       ; reportFloatingKvs name all_tc_tvs unmentioned_kvs++       ; let final_binders = map (mkNamedTyConBinder Specified) good_tvs+                            ++ tc_binders+             tycon = mkTcTyCon name final_binders res_kind+                               unsat (scoped_kvs ++ tc_tvs)+                           -- the tvs contain the binders already+                           -- in scope from an enclosing class, but+                           -- re-adding tvs to the env't doesn't cause+                           -- harm+       ; return (tycon, stuff) }}++  | otherwise+  = do { kv_kinds <- mk_kv_kinds+       ; scoped_kvs <- zipWithM newSigTyVar kv_ns kv_kinds+                     -- the names must line up in splitTelescopeTvs+       ; (binders, res_kind, stuff)+           <- tcExtendTyVarEnv2 (kv_ns `zip` scoped_kvs) $+              bind_telescope hs_tvs thing_inside+       ; let   -- NB: Don't add scoped_kvs to tyConTyVars, because they+               -- must remain lined up with the binders+             tycon = mkTcTyCon name binders res_kind unsat+                               (scoped_kvs ++ binderVars binders)+       ; return (tycon, stuff) }+  where+      -- if -XNoTypeInType and we know all the implicits are kind vars,+      -- just give the kind *. This prevents test+      -- dependent/should_fail/KindLevelsB from compiling, as it should+    mk_kv_kinds :: TcM [Kind]+    mk_kv_kinds = do { typeintype <- xoptM LangExt.TypeInType+                     ; if not typeintype && all_kind_vars+                       then return (map (const liftedTypeKind) kv_ns)+                       else mapM (const newMetaKindVar) kv_ns }++      -- there may be dependency between the explicit "ty" vars. So, we have+      -- to handle them one at a time.+    bind_telescope :: [LHsTyVarBndr Name]+                   -> TcM (Kind, r)+                   -> TcM ([TyConBinder], TcKind, r)+    bind_telescope [] thing+      = do { (res_kind, stuff) <- thing+           ; return ([], res_kind, stuff) }+    bind_telescope (L _ hs_tv : hs_tvs) thing+      = do { tv_pair@(tv, _) <- kc_hs_tv hs_tv+               -- NB: Bring all tvs into scope, even non-dependent ones,+               -- as they're needed in type synonyms, data constructors, etc.+           ; (binders, res_kind, stuff) <- bind_unless_scoped tv_pair $+                                           bind_telescope hs_tvs $+                                           thing+                  -- See Note [Dependent LHsQTyVars]+           ; let new_binder | hsTyVarName hs_tv `elemNameSet` dep_names+                            = mkNamedTyConBinder Required tv+                            | otherwise+                            = mkAnonTyConBinder tv+           ; return ( new_binder : binders+                    , res_kind, stuff ) }++    -- | Bind the tyvar in the env't unless the bool is True+    bind_unless_scoped :: (TcTyVar, Bool) -> TcM a -> TcM a+    bind_unless_scoped (_, True)   thing_inside = thing_inside+    bind_unless_scoped (tv, False) thing_inside+      = tcExtendTyVarEnv [tv] thing_inside++    kc_hs_tv :: HsTyVarBndr Name -> TcM (TcTyVar, Bool)+    kc_hs_tv (UserTyVar (L _ name))+      = do { tv_pair@(tv, scoped) <- tcHsTyVarName Nothing name++              -- Open type/data families default their variables to kind *.+           ; when (open_fam && not scoped) $ -- (don't default class tyvars)+             discardResult $ unifyKind (Just (mkTyVarTy tv)) liftedTypeKind+                                                             (tyVarKind tv)++           ; return tv_pair }++    kc_hs_tv (KindedTyVar (L _ name) lhs_kind)+      = do { kind <- tcLHsKindSig lhs_kind+           ; tcHsTyVarName (Just kind) name }++    report_non_cusk_tvs all_tvs+      = do { all_tvs <- mapM zonkTyCoVarKind all_tvs+           ; let (_, tidy_tvs)         = tidyOpenTyCoVars emptyTidyEnv all_tvs+                 (meta_tvs, other_tvs) = partition isMetaTyVar tidy_tvs++           ; addErr $+             vcat [ text "You have written a *complete user-suppled kind signature*,"+                  , hang (text "but the following variable" <> plural meta_tvs <+>+                          isOrAre meta_tvs <+> text "undetermined:")+                       2 (vcat (map pp_tv meta_tvs))+                  , text "Perhaps add a kind signature."+                  , hang (text "Inferred kinds of user-written variables:")+                       2 (vcat (map pp_tv other_tvs)) ] }+      where+        pp_tv tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)+++tcImplicitTKBndrs :: [Name]+                  -> TcM (a, TyVarSet)   -- vars are bound somewhere in the scope+                                         -- see Note [Scope-check inferred kinds]+                  -> TcM ([TcTyVar], a)+tcImplicitTKBndrs = tcImplicitTKBndrsX (tcHsTyVarName Nothing)++-- | Convenient specialization+tcImplicitTKBndrsType :: [Name]+                      -> TcM Type+                      -> TcM ([TcTyVar], Type)+tcImplicitTKBndrsType var_ns thing_inside+  = tcImplicitTKBndrs var_ns $+    do { res_ty <- thing_inside+       ; return (res_ty, allBoundVariables res_ty) }++-- this more general variant is needed in tcHsPatSigType.+-- See Note [Pattern signature binders]+tcImplicitTKBndrsX :: (Name -> TcM (TcTyVar, Bool))  -- new_tv function+                   -> [Name]+                   -> TcM (a, TyVarSet)+                   -> TcM ([TcTyVar], a)+-- Returned TcTyVars have the supplied Names,+-- but may be in different order to the original [Name]+--   (because of sorting to respect dependency)+-- Returned TcTyVars have zonked kinds+tcImplicitTKBndrsX new_tv var_ns thing_inside+  = do { tkvs_pairs <- mapM new_tv var_ns+       ; let must_scope_tkvs = [ tkv | (tkv, False) <- tkvs_pairs ]+             tkvs            = map fst tkvs_pairs+       ; (result, bound_tvs) <- tcExtendTyVarEnv must_scope_tkvs $+                                thing_inside++         -- Check that the implicitly-bound kind variable+         -- really can go at the beginning.+         -- e.g.   forall (a :: k) (b :: *). ...(forces k :: b)...+       ; tkvs <- mapM zonkTyCoVarKind tkvs+                 -- NB: /not/ zonkTcTyVarToTyVar. tcImplicitTKBndrsX+                 -- guarantees to return TcTyVars with the same Names+                 -- as the var_ns.  See [Pattern signature binders]++       ; let extra = text "NB: Implicitly-bound variables always come" <+>+                     text "before other ones."+       ; checkValidInferredKinds tkvs bound_tvs extra++       ; let final_tvs = toposortTyVars tkvs+       ; traceTc "tcImplicitTKBndrs" (ppr var_ns $$ ppr final_tvs)++       ; return (final_tvs, result) }++tcExplicitTKBndrs :: [LHsTyVarBndr Name]+                  -> ([TyVar] -> TcM (a, TyVarSet))+                        -- ^ Thing inside returns the set of variables bound+                        -- in the scope. See Note [Scope-check inferred kinds]+                  -> TcM (a, TyVarSet)  -- ^ returns augmented bound vars+-- No cloning: returned TyVars have the same Name as the incoming LHsTyVarBndrs+tcExplicitTKBndrs orig_hs_tvs thing_inside+  = tcExplicitTKBndrsX newSkolemTyVar orig_hs_tvs thing_inside++tcExplicitTKBndrsX :: (Name -> Kind -> TcM TyVar)+                   -> [LHsTyVarBndr Name]+                   -> ([TyVar] -> TcM (a, TyVarSet))+                        -- ^ Thing inside returns the set of variables bound+                        -- in the scope. See Note [Scope-check inferred kinds]+                   -> TcM (a, TyVarSet)  -- ^ returns augmented bound vars+tcExplicitTKBndrsX new_tv orig_hs_tvs thing_inside+  = go orig_hs_tvs $ \ tvs ->+    do { (result, bound_tvs) <- thing_inside tvs++         -- Issue an error if the ordering is bogus.+         -- See Note [Bad telescopes] in TcValidity.+       ; tvs <- checkZonkValidTelescope (interppSP orig_hs_tvs) tvs empty+       ; checkValidInferredKinds tvs bound_tvs empty++       ; traceTc "tcExplicitTKBndrs" $+           vcat [ text "Hs vars:" <+> ppr orig_hs_tvs+                , text "tvs:" <+> sep (map pprTyVar tvs) ]++       ; return (result, bound_tvs `unionVarSet` mkVarSet tvs)+       }+  where+    go [] thing = thing []+    go (L _ hs_tv : hs_tvs) thing+      = do { tv <- tcHsTyVarBndr new_tv hs_tv+           ; tcExtendTyVarEnv [tv] $+             go hs_tvs $ \ tvs ->+             thing (tv : tvs) }++tcHsTyVarBndr :: (Name -> Kind -> TcM TyVar)+              -> HsTyVarBndr Name -> TcM TcTyVar+-- Return a SkolemTv TcTyVar, initialised with a kind variable.+-- Typically the Kind inside the HsTyVarBndr will be a tyvar+-- with a mutable kind in it.+-- NB: These variables must not be in scope. This function+-- is not appropriate for use with associated types, for example.+--+-- Returned TcTyVar has the same name; no cloning+--+-- See also Note [Associated type tyvar names] in Class+--+tcHsTyVarBndr new_tv (UserTyVar (L _ name))+  = do { kind <- newMetaKindVar+       ; new_tv name kind }++tcHsTyVarBndr new_tv (KindedTyVar (L _ name) kind)+  = do { kind <- tcLHsKindSig kind+       ; new_tv name kind }++newWildTyVar :: Name -> TcM TcTyVar+-- ^ New unification variable for a wildcard+newWildTyVar _name+  = do { kind <- newMetaKindVar+       ; uniq <- newUnique+       ; details <- newMetaDetails TauTv+       ; let name = mkSysTvName uniq (fsLit "w")+       ; return (mkTcTyVar name kind details) }++-- | Produce a tyvar of the given name (with the kind provided, or+-- otherwise a meta-var kind). If+-- the name is already in scope, return the scoped variable, checking+-- to make sure the known kind matches any kind provided. The+-- second return value says whether the variable is in scope (True)+-- or not (False). (Use this for associated types, for example.)+tcHsTyVarName :: Maybe Kind -> Name -> TcM (TcTyVar, Bool)+tcHsTyVarName m_kind name+  = do { mb_tv <- tcLookupLcl_maybe name+       ; case mb_tv of+           Just (ATyVar _ tv)+             -> do { whenIsJust m_kind $ \ kind ->+                     discardResult $+                     unifyKind (Just (mkTyVarTy tv)) kind (tyVarKind tv)+                   ; return (tv, True) }+           _ -> do { kind <- case m_kind of+                               Just kind -> return kind+                               Nothing   -> newMetaKindVar+                   ; tv <- newSkolemTyVar name kind+                   ; return (tv, False) }}++-- makes a new skolem tv+newSkolemTyVar :: Name -> Kind -> TcM TcTyVar+newSkolemTyVar name kind = do { lvl <- getTcLevel+                              ; return (mk_skolem_tv lvl name kind) }++mk_skolem_tv :: TcLevel -> Name -> Kind -> TcTyVar+mk_skolem_tv lvl n k = mkTcTyVar n k (SkolemTv lvl False)++------------------+kindGeneralizeType :: Type -> TcM Type+-- Result is zonked+kindGeneralizeType ty+  = do { kvs <- kindGeneralize ty+       ; ty <- zonkSigType (mkInvForAllTys kvs ty)+       ; return ty  }++kindGeneralize :: TcType -> TcM [KindVar]+-- Quantify the free kind variables of a kind or type+-- In the latter case the type is closed, so it has no free+-- type variables.  So in both cases, all the free vars are kind vars+kindGeneralize kind_or_type+  = do { kvs <- zonkTcTypeAndFV kind_or_type+       ; let dvs = DV { dv_kvs = kvs, dv_tvs = emptyDVarSet }+       ; gbl_tvs <- tcGetGlobalTyCoVars -- Already zonked+       ; quantifyZonkedTyVars gbl_tvs dvs }++{-+Note [Kind generalisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We do kind generalisation only at the outer level of a type signature.+For example, consider+  T :: forall k. k -> *+  f :: (forall a. T a -> Int) -> Int+When kind-checking f's type signature we generalise the kind at+the outermost level, thus:+  f1 :: forall k. (forall (a:k). T k a -> Int) -> Int  -- YES!+and *not* at the inner forall:+  f2 :: (forall k. forall (a:k). T k a -> Int) -> Int  -- NO!+Reason: same as for HM inference on value level declarations,+we want to infer the most general type.  The f2 type signature+would be *less applicable* than f1, because it requires a more+polymorphic argument.++NB: There are no explicit kind variables written in f's signature.+When there are, the renamer adds these kind variables to the list of+variables bound by the forall, so you can indeed have a type that's+higher-rank in its kind. But only by explicit request.++Note [Kinds of quantified type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+tcTyVarBndrsGen quantifies over a specified list of type variables,+*and* over the kind variables mentioned in the kinds of those tyvars.++Note that we must zonk those kinds (obviously) but less obviously, we+must return type variables whose kinds are zonked too. Example+    (a :: k7)  where  k7 := k9 -> k9+We must return+    [k9, a:k9->k9]+and NOT+    [k9, a:k7]+Reason: we're going to turn this into a for-all type,+   forall k9. forall (a:k7). blah+which the type checker will then instantiate, and instantiate does not+look through unification variables!++Hence using zonked_kinds when forming tvs'.++Note [Free-floating kind vars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++  data T = MkT (forall (a :: k). Proxy a)+  -- from test ghci/scripts/T7873++This is not an existential datatype, but a higher-rank one. Note that+the forall to the right of MkT. Also consider++  data S a = MkS (Proxy (a :: k))++According to the rules around implicitly-bound kind variables, those+k's scope over the whole declarations. The renamer grabs it and adds it+to the hsq_implicits field of the HsQTyVars of the tycon. So it must+be in scope during type-checking, but we want to reject T while accepting+S.++Why reject T? Because the kind variable isn't fixed by anything. For+a variable like k to be implicit, it needs to be mentioned in the kind+of a tycon tyvar. But it isn't.++Why accept S? Because kind inference tells us that a has kind k, so it's+all OK.++Our approach depends on whether or not the datatype has a CUSK.++Non-CUSK: In the first pass (kcTyClTyVars) we just bring+k into scope. In the second pass (tcTyClTyVars),+we check to make sure that k has been unified with some other variable+(or generalized over, making k into a skolem). If it hasn't been, then+it must be a free-floating kind var. Error.++CUSK: When we determine the tycon's final, never-to-be-changed kind+in kcHsTyVarBndrs, we check to make sure all implicitly-bound kind+vars are indeed mentioned in a kind somewhere. If not, error.++-}++--------------------+-- getInitialKind has made a suitably-shaped kind for the type or class+-- Look it up in the local environment. This is used only for tycons+-- that we're currently type-checking, so we're sure to find a TcTyCon.+kcLookupTcTyCon :: Name -> TcM TcTyCon+kcLookupTcTyCon nm+  = do { tc_ty_thing <- tcLookup nm+       ; return $ case tc_ty_thing of+           ATcTyCon tc -> tc+           _           -> pprPanic "kcLookupTcTyCon" (ppr tc_ty_thing) }++-----------------------+-- | Bring tycon tyvars into scope. This is used during the "kind-checking"+-- pass in TcTyClsDecls. (Never in getInitialKind, never in the+-- "type-checking"/desugaring pass.)+-- Never emits constraints, though the thing_inside might.+kcTyClTyVars :: Name -> TcM a -> TcM a+kcTyClTyVars tycon_name thing_inside+  = do { tycon <- kcLookupTcTyCon tycon_name+       ; tcExtendTyVarEnv (tcTyConScopedTyVars tycon) $ thing_inside }++tcTyClTyVars :: Name+             -> ([TyConBinder] -> Kind -> TcM a) -> TcM a+-- ^ Used for the type variables of a type or class decl+-- on the second full pass (type-checking/desugaring) in TcTyClDecls.+-- This is *not* used in the initial-kind run, nor in the "kind-checking" pass.+-- Accordingly, everything passed to the continuation is fully zonked.+--+-- (tcTyClTyVars T [a,b] thing_inside)+--   where T : forall k1 k2 (a:k1 -> *) (b:k1). k2 -> *+--   calls thing_inside with arguments+--      [k1,k2,a,b] [k1:*, k2:*, Anon (k1 -> *), Anon k1] (k2 -> *)+--   having also extended the type environment with bindings+--   for k1,k2,a,b+--+-- Never emits constraints.+--+-- The LHsTyVarBndrs is always user-written, and the full, generalised+-- kind of the tycon is available in the local env.+tcTyClTyVars tycon_name thing_inside+  = do { tycon <- kcLookupTcTyCon tycon_name++       ; let scoped_tvs = tcTyConScopedTyVars tycon+               -- these are all zonked:+             binders    = tyConBinders tycon+             res_kind   = tyConResKind tycon++          -- See Note [Free-floating kind vars]+       ; zonked_scoped_tvs <- mapM zonkTcTyVarToTyVar scoped_tvs+       ; let still_sig_tvs = filter isSigTyVar zonked_scoped_tvs+       ; checkNoErrs $ reportFloatingKvs tycon_name+                                         zonked_scoped_tvs still_sig_tvs++          -- Add the *unzonked* tyvars to the env't, because those+          -- are the ones mentioned in the source.+       ; tcExtendTyVarEnv scoped_tvs $+         thing_inside binders res_kind }++-----------------------------------+tcDataKindSig :: Kind -> TcM ([TyConBinder], Kind)+-- GADT decls can have a (perhaps partial) kind signature+--      e.g.  data T :: * -> * -> * where ...+-- This function makes up suitable (kinded) type variables for+-- the argument kinds, and checks that the result kind is indeed *.+-- We use it also to make up argument type variables for for data instances.+-- Never emits constraints.+-- Returns the new TyVars, the extracted TyBinders, and the new, reduced+-- result kind (which should always be Type or a synonym thereof)+tcDataKindSig kind+  = do  { checkTc (isLiftedTypeKind res_kind) (badKindSig kind)+        ; span <- getSrcSpanM+        ; us   <- newUniqueSupply+        ; rdr_env <- getLocalRdrEnv+        ; let uniqs = uniqsFromSupply us+              occs  = [ occ | str <- allNameStrings+                            , let occ = mkOccName tvName str+                            , isNothing (lookupLocalRdrOcc rdr_env occ) ]+                 -- Note [Avoid name clashes for associated data types]++    -- NB: Use the tv from a binder if there is one. Otherwise,+    -- we end up inventing a new Unique for it, and any other tv+    -- that mentions the first ends up with the wrong kind.+              extra_bndrs = zipWith4 mkTyBinderTyConBinder+                              tv_bndrs (repeat span) uniqs occs++        ; return (extra_bndrs, res_kind) }+  where+    (tv_bndrs, res_kind) = splitPiTys kind++badKindSig :: Kind -> SDoc+badKindSig kind+ = hang (text "Kind signature on data type declaration has non-* return kind")+        2 (ppr kind)++{-+Note [Avoid name clashes for associated data types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider    class C a b where+               data D b :: * -> *+When typechecking the decl for D, we'll invent an extra type variable+for D, to fill out its kind.  Ideally we don't want this type variable+to be 'a', because when pretty printing we'll get+            class C a b where+               data D b a0+(NB: the tidying happens in the conversion to IfaceSyn, which happens+as part of pretty-printing a TyThing.)++That's why we look in the LocalRdrEnv to see what's in scope. This is+important only to get nice-looking output when doing ":info C" in GHCi.+It isn't essential for correctness.+++************************************************************************+*                                                                      *+             Partial signatures and pattern signatures+*                                                                      *+************************************************************************++-}++tcHsPartialSigType+  :: UserTypeCtxt+  -> LHsSigWcType Name        -- The type signature+  -> TcM ( [(Name, TcTyVar)]  -- Wildcards+         , Maybe TcTyVar      -- Extra-constraints wildcard+         , [TcTyVar]          -- Implicitly and explicitly bound type variables+         , TcThetaType        -- Theta part+         , TcType )           -- Tau part+tcHsPartialSigType ctxt sig_ty+  | HsWC { hswc_wcs  = sig_wcs,         hswc_body = ib_ty } <- sig_ty+  , HsIB { hsib_vars = implicit_hs_tvs, hsib_body = hs_ty } <- ib_ty+  , (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTy hs_ty+  = addSigCtxt ctxt hs_ty $+    do { (implicit_tvs, (wcs, wcx, explicit_tvs, theta, tau))+            <- tcWildCardBindersX newWildTyVar sig_wcs        $ \ wcs ->+               tcImplicitTKBndrsX new_implicit_tv implicit_hs_tvs $+               tcExplicitTKBndrsX newSigTyVar explicit_hs_tvs $ \ explicit_tvs ->+               do {   -- Instantiate the type-class context; but if there+                      -- is an extra-constraints wildcard, just discard it here+                    (theta, wcx) <- tcPartialContext hs_ctxt++                  ; tau <- tcHsOpenType hs_tau++                  ; let bound_tvs = unionVarSets [ allBoundVariables tau+                                                 , mkVarSet explicit_tvs+                                                 , mkVarSet (map snd wcs) ]++                  ; return ( (wcs, wcx, explicit_tvs, theta, tau)+                           , bound_tvs) }++        ; emitWildCardHoleConstraints wcs++        ; explicit_tvs <- mapM zonkTyCoVarKind explicit_tvs+        ; let all_tvs = implicit_tvs ++ explicit_tvs+                        -- The implicit_tvs alraedy have zonked kinds++        ; theta   <- mapM zonkTcType theta+        ; tau     <- zonkTcType tau+        ; checkValidType ctxt (mkSpecForAllTys all_tvs $ mkPhiTy theta tau)++        ; traceTc "tcHsPartialSigType" (ppr all_tvs)+        ; return (wcs, wcx, all_tvs, theta, tau) }+  where+    new_implicit_tv name = do { kind <- newMetaKindVar+                              ; tv <- newSigTyVar name kind+                              ; return (tv, False) }++tcPartialContext :: HsContext Name -> TcM (TcThetaType, Maybe TcTyVar)+tcPartialContext hs_theta+  | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta+  , L _ (HsWildCardTy wc) <- ignoreParens hs_ctxt_last+  = do { wc_tv <- tcWildCardOcc wc constraintKind+       ; theta <- mapM tcLHsPredType hs_theta1+       ; return (theta, Just wc_tv) }+  | otherwise+  = do { theta <- mapM tcLHsPredType hs_theta+       ; return (theta, Nothing) }++tcHsPatSigType :: UserTypeCtxt+               -> LHsSigWcType Name           -- The type signature+               -> TcM ( [(Name, TcTyVar)]     -- Wildcards+                      , [(Name, TcTyVar)]     -- The new bit of type environment, binding+                                              -- the scoped type variables+                      , TcType)       -- The type+-- Used for type-checking type signatures in+-- (a) patterns           e.g  f (x::Int) = e+-- (b) RULE forall bndrs  e.g. forall (x::Int). f x = x+--+-- This may emit constraints++tcHsPatSigType ctxt sig_ty+  | HsWC { hswc_wcs = sig_wcs,   hswc_body = ib_ty } <- sig_ty+  , HsIB { hsib_vars = sig_vars, hsib_body = hs_ty } <- ib_ty+  = addSigCtxt ctxt hs_ty $+    do { (implicit_tvs, (wcs, sig_ty))+            <- tcWildCardBindersX newWildTyVar    sig_wcs  $ \ wcs ->+               tcImplicitTKBndrsX new_implicit_tv sig_vars $+               do { sig_ty <- tcHsOpenType hs_ty+                  ; return ((wcs, sig_ty), allBoundVariables sig_ty) }++        ; emitWildCardHoleConstraints wcs++        ; sig_ty <- zonkTcType sig_ty+        ; checkValidType ctxt sig_ty++        ; tv_pairs <- mapM mk_tv_pair implicit_tvs++        ; traceTc "tcHsPatSigType" (ppr sig_vars)+        ; return (wcs, tv_pairs, sig_ty) }+  where+    new_implicit_tv name = do { kind <- newMetaKindVar+                              ; tv <- new_tv name kind+                              ; return (tv, False) }+       -- "False" means that these tyvars aren't yet in scope+    new_tv = case ctxt of+               RuleSigCtxt {} -> newSkolemTyVar+               _              -> newSigTyVar+      -- See Note [Pattern signature binders]+      -- See Note [Unifying SigTvs]++    mk_tv_pair tv = do { tv' <- zonkTcTyVarToTyVar tv+                       ; return (tyVarName tv, tv') }+         -- The Name is one of sig_vars, the lexically scoped name+         -- But if it's a SigTyVar, it might have been unified+         -- with an existing in-scope skolem, so we must zonk+         -- here.  See Note [Pattern signature binders]++tcPatSig :: Bool                    -- True <=> pattern binding+         -> LHsSigWcType Name+         -> ExpSigmaType+         -> TcM (TcType,            -- The type to use for "inside" the signature+                 [(Name,TcTyVar)],  -- The new bit of type environment, binding+                                    -- the scoped type variables+                 [(Name,TcTyVar)],  -- The wildcards+                 HsWrapper)         -- Coercion due to unification with actual ty+                                    -- Of shape:  res_ty ~ sig_ty+tcPatSig in_pat_bind sig res_ty+ = do  { (sig_wcs, sig_tvs, sig_ty) <- tcHsPatSigType PatSigCtxt sig+        -- sig_tvs are the type variables free in 'sig',+        -- and not already in scope. These are the ones+        -- that should be brought into scope++        ; if null sig_tvs then do {+                -- Just do the subsumption check and return+                  wrap <- addErrCtxtM (mk_msg sig_ty) $+                          tcSubTypeET PatSigOrigin PatSigCtxt res_ty sig_ty+                ; return (sig_ty, [], sig_wcs, wrap)+        } else do+                -- Type signature binds at least one scoped type variable++                -- A pattern binding cannot bind scoped type variables+                -- It is more convenient to make the test here+                -- than in the renamer+        { when in_pat_bind (addErr (patBindSigErr sig_tvs))++                -- Check that all newly-in-scope tyvars are in fact+                -- constrained by the pattern.  This catches tiresome+                -- cases like+                --      type T a = Int+                --      f :: Int -> Int+                --      f (x :: T a) = ...+                -- Here 'a' doesn't get a binding.  Sigh+        ; let bad_tvs = [ tv | (_,tv) <- sig_tvs+                             , not (tv `elemVarSet` exactTyCoVarsOfType sig_ty) ]+        ; checkTc (null bad_tvs) (badPatSigTvs sig_ty bad_tvs)++        -- Now do a subsumption check of the pattern signature against res_ty+        ; wrap <- addErrCtxtM (mk_msg sig_ty) $+                  tcSubTypeET PatSigOrigin PatSigCtxt res_ty sig_ty++        -- Phew!+        ; return (sig_ty, sig_tvs, sig_wcs, wrap)+        } }+  where+    mk_msg sig_ty tidy_env+       = do { (tidy_env, sig_ty) <- zonkTidyTcType tidy_env sig_ty+            ; res_ty <- readExpType res_ty   -- should be filled in by now+            ; (tidy_env, res_ty) <- zonkTidyTcType tidy_env res_ty+            ; let msg = vcat [ hang (text "When checking that the pattern signature:")+                                  4 (ppr sig_ty)+                             , nest 2 (hang (text "fits the type of its context:")+                                          2 (ppr res_ty)) ]+            ; return (tidy_env, msg) }++patBindSigErr :: [(Name,TcTyVar)] -> SDoc+patBindSigErr sig_tvs+  = hang (text "You cannot bind scoped type variable" <> plural sig_tvs+          <+> pprQuotedList (map fst sig_tvs))+       2 (text "in a pattern binding signature")++{- Note [Pattern signature binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   data T = forall a. T a (a->Int)+   f (T x (f :: b->Int)) = blah++Here+ * The pattern (T p1 p2) creates a *skolem* type variable 'a_sk',+   It must be a skolem so that that it retains its identity, and+   TcErrors.getSkolemInfo can thereby find the binding site for the skolem.++ * The type signature pattern (f :: b->Int) makes a fresh meta-tyvar b_sig+   (a SigTv), and binds "b" :-> b_sig in the envt++ * Then unification makes b_sig := a_sk+   That's why we must make b_sig a MetaTv (albeit a SigTv),+   not a SkolemTv, so that it can unify to a_sk.++ * Finally, in 'blah' we must have the envt "b" :-> a_sk.  The pair+   ("b" :-> a_sk) is returned by tcHsPatSigType, constructed by+   mk_tv_pair in that funcion.++Another example (Trac #13881):+   fl :: forall (l :: [a]). Sing l -> Sing l+   fl (SNil :: Sing (l :: [y])) = SNil+When we reach the pattern signature, 'l' is in scope from the+outer 'forall':+   "a" :-> a_sk :: *+   "l" :-> l_sk :: [a_sk]+We make up a fresh meta-SigTv, y_sig, for 'y', and kind-check+the pattern signature+   Sing (l :: [y])+That unifies y_sig := a_sk.  We return from tcHsPatSigType with+the pair ("y" :-> a_sk).++For RULE binders, though, things are a bit different (yuk).+  RULE "foo" forall (x::a) (y::[a]).  f x y = ...+Here this really is the binding site of the type variable so we'd like+to use a skolem, so that we get a complaint if we unify two of them+together.++Note [Unifying SigTvs]+~~~~~~~~~~~~~~~~~~~~~~+ALAS we have no decent way of avoiding two SigTvs getting unified.+Consider+  f (x::(a,b)) (y::c)) = [fst x, y]+Here we'd really like to complain that 'a' and 'c' are unified. But+for the reasons above we can't make a,b,c into skolems, so they+are just SigTvs that can unify.  And indeed, this would be ok,+  f x (y::c) = case x of+                 (x1 :: a1, True) -> [x,y]+                 (x1 :: a2, False) -> [x,y,y]+Here the type of x's first component is called 'a1' in one branch and+'a2' in the other.  We could try insisting on the same OccName, but+they definitely won't have the sane lexical Name.++I think we could solve this by recording in a SigTv a list of all the+in-scope variables that it should not unify with, but it's fiddly.+++************************************************************************+*                                                                      *+        Checking kinds+*                                                                      *+************************************************************************++-}++unifyKinds :: [(TcType, TcKind)] -> TcM ([TcType], TcKind)+unifyKinds act_kinds+  = do { kind <- newMetaKindVar+       ; let check (ty, act_kind) = checkExpectedKind ty act_kind kind+       ; tys' <- mapM check act_kinds+       ; return (tys', kind) }++{-+************************************************************************+*                                                                      *+        Sort checking kinds+*                                                                      *+************************************************************************++tcLHsKindSig converts a user-written kind to an internal, sort-checked kind.+It does sort checking and desugaring at the same time, in one single pass.+-}++tcLHsKindSig :: LHsKind Name -> TcM Kind+tcLHsKindSig hs_kind+  = do { kind <- tc_lhs_kind kindLevelMode hs_kind+       ; zonkTcType kind }+         -- This zonk is very important in the case of higher rank kinds+         -- E.g. Trac #13879    f :: forall (p :: forall z (y::z). <blah>).+         --                          <more blah>+         --      When instanting p's kind at occurrences of p in <more blah>+         --      it's crucial that the kind we instantiate is fully zonked,+         --      else we may fail to substitute properly++tc_lhs_kind :: TcTyMode -> LHsKind Name -> TcM Kind+tc_lhs_kind mode k+  = addErrCtxt (text "In the kind" <+> quotes (ppr k)) $+    tc_lhs_type (kindLevel mode) k liftedTypeKind++promotionErr :: Name -> PromotionErr -> TcM a+promotionErr name err+  = failWithTc (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here")+                   2 (parens reason))+  where+    reason = case err of+               FamDataConPE   -> text "it comes from a data family instance"+               NoDataKindsTC  -> text "Perhaps you intended to use DataKinds"+               NoDataKindsDC  -> text "Perhaps you intended to use DataKinds"+               NoTypeInTypeTC -> text "Perhaps you intended to use TypeInType"+               NoTypeInTypeDC -> text "Perhaps you intended to use TypeInType"+               PatSynPE       -> text "Pattern synonyms cannot be promoted"+               _ -> text "it is defined and used in the same recursive group"++{-+************************************************************************+*                                                                      *+                Scoped type variables+*                                                                      *+************************************************************************+-}++badPatSigTvs :: TcType -> [TyVar] -> SDoc+badPatSigTvs sig_ty bad_tvs+  = vcat [ fsep [text "The type variable" <> plural bad_tvs,+                 quotes (pprWithCommas ppr bad_tvs),+                 text "should be bound by the pattern signature" <+> quotes (ppr sig_ty),+                 text "but are actually discarded by a type synonym" ]+         , text "To fix this, expand the type synonym"+         , text "[Note: I hope to lift this restriction in due course]" ]++{-+************************************************************************+*                                                                      *+          Error messages and such+*                                                                      *+************************************************************************+-}++-- | Make an appropriate message for an error in a function argument.+-- Used for both expressions and types.+funAppCtxt :: (Outputable fun, Outputable arg) => fun -> arg -> Int -> SDoc+funAppCtxt fun arg arg_no+  = hang (hsep [ text "In the", speakNth arg_no, ptext (sLit "argument of"),+                    quotes (ppr fun) <> text ", namely"])+       2 (quotes (ppr arg))++-- See Note [Free-floating kind vars]+reportFloatingKvs :: Name        -- of the tycon+                  -> [TcTyVar]   -- all tyvars, not necessarily zonked+                  -> [TcTyVar]   -- floating tyvars+                  -> TcM ()+reportFloatingKvs tycon_name all_tvs bad_tvs+  = unless (null bad_tvs) $  -- don't bother zonking if there's no error+    do { all_tvs <- mapM zonkTcTyVarToTyVar all_tvs+       ; bad_tvs <- mapM zonkTcTyVarToTyVar bad_tvs+       ; let (tidy_env, tidy_all_tvs) = tidyOpenTyCoVars emptyTidyEnv all_tvs+             tidy_bad_tvs             = map (tidyTyVarOcc tidy_env) bad_tvs+       ; typeintype <- xoptM LangExt.TypeInType+       ; mapM_ (report typeintype tidy_all_tvs) tidy_bad_tvs }+  where+    report typeintype tidy_all_tvs tidy_bad_tv+      = addErr $+        vcat [ text "Kind variable" <+> quotes (ppr tidy_bad_tv) <+>+               text "is implicitly bound in datatype"+             , quotes (ppr tycon_name) <> comma <+>+               text "but does not appear as the kind of any"+             , text "of its type variables. Perhaps you meant"+             , text "to bind it" <+> ppWhen (not typeintype)+                                            (text "(with TypeInType)") <+>+                                 text "explicitly somewhere?"+             , ppWhen (not (null tidy_all_tvs)) $+                 hang (text "Type variables with inferred kinds:")+                 2 (ppr_tv_bndrs tidy_all_tvs) ]++    ppr_tv_bndrs tvs = sep (map pp_tv tvs)+    pp_tv tv         = parens (ppr tv <+> dcolon <+> ppr (tyVarKind tv))
+ typecheck/TcInstDcls.hs view
@@ -0,0 +1,1840 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++TcInstDecls: Typechecking instance declarations+-}++{-# LANGUAGE CPP #-}++module TcInstDcls ( tcInstDecls1, tcInstDeclsDeriv, tcInstDecls2 ) where++#include "HsVersions.h"++import HsSyn+import TcBinds+import TcTyClsDecls+import TcClassDcl( tcClassDecl2, tcATDefault,+                   HsSigFun, mkHsSigFun,+                   findMethodBind, instantiateMethod )+import TcSigs+import TcRnMonad+import TcValidity+import TcHsSyn    ( zonkTyBndrsX, emptyZonkEnv+                  , zonkTcTypeToTypes, zonkTcTypeToType )+import TcMType+import TcType+import BuildTyCl+import Inst+import InstEnv+import FamInst+import FamInstEnv+import TcDeriv+import TcEnv+import TcHsType+import TcUnify+import CoreSyn    ( Expr(..), mkApps, mkVarApps, mkLams )+import MkCore     ( nO_METHOD_BINDING_ERROR_ID )+import CoreUnfold ( mkInlineUnfoldingWithArity, mkDFunUnfolding )+import Type+import TcEvidence+import TyCon+import CoAxiom+import DataCon+import ConLike+import Class+import Var+import VarEnv+import VarSet+import PrelNames  ( typeableClassName, genericClassNames+                  , knownNatClassName, knownSymbolClassName )+import Bag+import BasicTypes+import DynFlags+import ErrUtils+import FastString+import Id+import MkId+import Name+import NameSet+import Outputable+import SrcLoc+import Util+import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice )+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Maybes+++{-+Typechecking instance declarations is done in two passes. The first+pass, made by @tcInstDecls1@, collects information to be used in the+second pass.++This pre-processed info includes the as-yet-unprocessed bindings+inside the instance declaration.  These are type-checked in the second+pass, when the class-instance envs and GVE contain all the info from+all the instance and value decls.  Indeed that's the reason we need+two passes over the instance decls.+++Note [How instance declarations are translated]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is how we translate instance declarations into Core++Running example:+        class C a where+           op1, op2 :: Ix b => a -> b -> b+           op2 = <dm-rhs>++        instance C a => C [a]+           {-# INLINE [2] op1 #-}+           op1 = <rhs>+===>+        -- Method selectors+        op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b+        op1 = ...+        op2 = ...++        -- Default methods get the 'self' dictionary as argument+        -- so they can call other methods at the same type+        -- Default methods get the same type as their method selector+        $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b+        $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). <dm-rhs>+               -- NB: type variables 'a' and 'b' are *both* in scope in <dm-rhs>+               -- Note [Tricky type variable scoping]++        -- A top-level definition for each instance method+        -- Here op1_i, op2_i are the "instance method Ids"+        -- The INLINE pragma comes from the user pragma+        {-# INLINE [2] op1_i #-}  -- From the instance decl bindings+        op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b+        op1_i = /\a. \(d:C a).+               let this :: C [a]+                   this = df_i a d+                     -- Note [Subtle interaction of recursion and overlap]++                   local_op1 :: forall b. Ix b => [a] -> b -> b+                   local_op1 = <rhs>+                     -- Source code; run the type checker on this+                     -- NB: Type variable 'a' (but not 'b') is in scope in <rhs>+                     -- Note [Tricky type variable scoping]++               in local_op1 a d++        op2_i = /\a \d:C a. $dmop2 [a] (df_i a d)++        -- The dictionary function itself+        {-# NOINLINE CONLIKE df_i #-}   -- Never inline dictionary functions+        df_i :: forall a. C a -> C [a]+        df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d)+                -- But see Note [Default methods in instances]+                -- We can't apply the type checker to the default-method call++        -- Use a RULE to short-circuit applications of the class ops+        {-# RULE "op1@C[a]" forall a, d:C a.+                            op1 [a] (df_i d) = op1_i a d #-}++Note [Instances and loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* Note that df_i may be mutually recursive with both op1_i and op2_i.+  It's crucial that df_i is not chosen as the loop breaker, even+  though op1_i has a (user-specified) INLINE pragma.++* Instead the idea is to inline df_i into op1_i, which may then select+  methods from the MkC record, and thereby break the recursion with+  df_i, leaving a *self*-recursive op1_i.  (If op1_i doesn't call op at+  the same type, it won't mention df_i, so there won't be recursion in+  the first place.)++* If op1_i is marked INLINE by the user there's a danger that we won't+  inline df_i in it, and that in turn means that (since it'll be a+  loop-breaker because df_i isn't), op1_i will ironically never be+  inlined.  But this is OK: the recursion breaking happens by way of+  a RULE (the magic ClassOp rule above), and RULES work inside InlineRule+  unfoldings. See Note [RULEs enabled in SimplGently] in SimplUtils++Note [ClassOp/DFun selection]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+One thing we see a lot is stuff like+    op2 (df d1 d2)+where 'op2' is a ClassOp and 'df' is DFun.  Now, we could inline *both*+'op2' and 'df' to get+     case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of+       MkD _ op2 _ _ _ -> op2+And that will reduce to ($cop2 d1 d2) which is what we wanted.++But it's tricky to make this work in practice, because it requires us to+inline both 'op2' and 'df'.  But neither is keen to inline without having+seen the other's result; and it's very easy to get code bloat (from the+big intermediate) if you inline a bit too much.++Instead we use a cunning trick.+ * We arrange that 'df' and 'op2' NEVER inline.++ * We arrange that 'df' is ALWAYS defined in the sylised form+      df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ...++ * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..])+   that lists its methods.++ * We make CoreUnfold.exprIsConApp_maybe spot a DFunUnfolding and return+   a suitable constructor application -- inlining df "on the fly" as it+   were.++ * ClassOp rules: We give the ClassOp 'op2' a BuiltinRule that+   extracts the right piece iff its argument satisfies+   exprIsConApp_maybe.  This is done in MkId mkDictSelId++ * We make 'df' CONLIKE, so that shared uses still match; eg+      let d = df d1 d2+      in ...(op2 d)...(op1 d)...++Note [Single-method classes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the class has just one method (or, more accurately, just one element+of {superclasses + methods}), then we use a different strategy.++   class C a where op :: a -> a+   instance C a => C [a] where op = <blah>++We translate the class decl into a newtype, which just gives a+top-level axiom. The "constructor" MkC expands to a cast, as does the+class-op selector.++   axiom Co:C a :: C a ~ (a->a)++   op :: forall a. C a -> (a -> a)+   op a d = d |> (Co:C a)++   MkC :: forall a. (a->a) -> C a+   MkC = /\a.\op. op |> (sym Co:C a)++The clever RULE stuff doesn't work now, because ($df a d) isn't+a constructor application, so exprIsConApp_maybe won't return+Just <blah>.++Instead, we simply rely on the fact that casts are cheap:++   $df :: forall a. C a => C [a]+   {-# INLINE df #-}  -- NB: INLINE this+   $df = /\a. \d. MkC [a] ($cop_list a d)+       = $cop_list |> forall a. C a -> (sym (Co:C [a]))++   $cop_list :: forall a. C a => [a] -> [a]+   $cop_list = <blah>++So if we see+   (op ($df a d))+we'll inline 'op' and '$df', since both are simply casts, and+good things happen.++Why do we use this different strategy?  Because otherwise we+end up with non-inlined dictionaries that look like+    $df = $cop |> blah+which adds an extra indirection to every use, which seems stupid.  See+Trac #4138 for an example (although the regression reported there+wasn't due to the indirection).++There is an awkward wrinkle though: we want to be very+careful when we have+    instance C a => C [a] where+      {-# INLINE op #-}+      op = ...+then we'll get an INLINE pragma on $cop_list but it's important that+$cop_list only inlines when it's applied to *two* arguments (the+dictionary and the list argument).  So we must not eta-expand $df+above.  We ensure that this doesn't happen by putting an INLINE+pragma on the dfun itself; after all, it ends up being just a cast.++There is one more dark corner to the INLINE story, even more deeply+buried.  Consider this (Trac #3772):++    class DeepSeq a => C a where+      gen :: Int -> a++    instance C a => C [a] where+      gen n = ...++    class DeepSeq a where+      deepSeq :: a -> b -> b++    instance DeepSeq a => DeepSeq [a] where+      {-# INLINE deepSeq #-}+      deepSeq xs b = foldr deepSeq b xs++That gives rise to these defns:++    $cdeepSeq :: DeepSeq a -> [a] -> b -> b+    -- User INLINE( 3 args )!+    $cdeepSeq a (d:DS a) b (x:[a]) (y:b) = ...++    $fDeepSeq[] :: DeepSeq a -> DeepSeq [a]+    -- DFun (with auto INLINE pragma)+    $fDeepSeq[] a d = $cdeepSeq a d |> blah++    $cp1 a d :: C a => DeepSep [a]+    -- We don't want to eta-expand this, lest+    -- $cdeepSeq gets inlined in it!+    $cp1 a d = $fDeepSep[] a (scsel a d)++    $fC[] :: C a => C [a]+    -- Ordinary DFun+    $fC[] a d = MkC ($cp1 a d) ($cgen a d)++Here $cp1 is the code that generates the superclass for C [a].  The+issue is this: we must not eta-expand $cp1 either, or else $fDeepSeq[]+and then $cdeepSeq will inline there, which is definitely wrong.  Like+on the dfun, we solve this by adding an INLINE pragma to $cp1.++Note [Subtle interaction of recursion and overlap]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this+  class C a where { op1,op2 :: a -> a }+  instance C a => C [a] where+    op1 x = op2 x ++ op2 x+    op2 x = ...+  instance C [Int] where+    ...++When type-checking the C [a] instance, we need a C [a] dictionary (for+the call of op2).  If we look up in the instance environment, we find+an overlap.  And in *general* the right thing is to complain (see Note+[Overlapping instances] in InstEnv).  But in *this* case it's wrong to+complain, because we just want to delegate to the op2 of this same+instance.++Why is this justified?  Because we generate a (C [a]) constraint in+a context in which 'a' cannot be instantiated to anything that matches+other overlapping instances, or else we would not be executing this+version of op1 in the first place.++It might even be a bit disguised:++  nullFail :: C [a] => [a] -> [a]+  nullFail x = op2 x ++ op2 x++  instance C a => C [a] where+    op1 x = nullFail x++Precisely this is used in package 'regex-base', module Context.hs.+See the overlapping instances for RegexContext, and the fact that they+call 'nullFail' just like the example above.  The DoCon package also+does the same thing; it shows up in module Fraction.hs.++Conclusion: when typechecking the methods in a C [a] instance, we want to+treat the 'a' as an *existential* type variable, in the sense described+by Note [Binding when looking up instances].  That is why isOverlappableTyVar+responds True to an InstSkol, which is the kind of skolem we use in+tcInstDecl2.+++Note [Tricky type variable scoping]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In our example+        class C a where+           op1, op2 :: Ix b => a -> b -> b+           op2 = <dm-rhs>++        instance C a => C [a]+           {-# INLINE [2] op1 #-}+           op1 = <rhs>++note that 'a' and 'b' are *both* in scope in <dm-rhs>, but only 'a' is+in scope in <rhs>.  In particular, we must make sure that 'b' is in+scope when typechecking <dm-rhs>.  This is achieved by subFunTys,+which brings appropriate tyvars into scope. This happens for both+<dm-rhs> and for <rhs>, but that doesn't matter: the *renamer* will have+complained if 'b' is mentioned in <rhs>.++++************************************************************************+*                                                                      *+\subsection{Extracting instance decls}+*                                                                      *+************************************************************************++Gather up the instance declarations from their various sources+-}++tcInstDecls1    -- Deal with both source-code and imported instance decls+   :: [LInstDecl Name]          -- Source code instance decls+   -> TcM (TcGblEnv,            -- The full inst env+           [InstInfo Name],     -- Source-code instance decls to process;+                                -- contains all dfuns for this module+           [DerivInfo])         -- From data family instances++tcInstDecls1 inst_decls+  = do {    -- Do class and family instance declarations+       ; stuff <- mapAndRecoverM tcLocalInstDecl inst_decls++       ; let (local_infos_s, fam_insts_s, datafam_deriv_infos) = unzip3 stuff+             fam_insts   = concat fam_insts_s+             local_infos = concat local_infos_s++       ; gbl_env <- addClsInsts local_infos $+                    addFamInsts fam_insts   $+                    getGblEnv++       ; return ( gbl_env+                , local_infos+                , concat datafam_deriv_infos ) }++-- | Use DerivInfo for data family instances (produced by tcInstDecls1),+--   datatype declarations (TyClDecl), and standalone deriving declarations+--   (DerivDecl) to check and process all derived class instances.+tcInstDeclsDeriv+  :: [DerivInfo]+  -> [LTyClDecl Name]+  -> [LDerivDecl Name]+  -> TcM (TcGblEnv, [InstInfo Name], HsValBinds Name)+tcInstDeclsDeriv datafam_deriv_infos tyclds derivds+  = do th_stage <- getStage -- See Note [Deriving inside TH brackets]+       if isBrackStage th_stage+       then do { gbl_env <- getGblEnv+               ; return (gbl_env, bagToList emptyBag, emptyValBindsOut) }+       else do { data_deriv_infos <- mkDerivInfos tyclds+               ; let deriv_infos = datafam_deriv_infos ++ data_deriv_infos+               ; (tcg_env, info_bag, valbinds) <- tcDeriving deriv_infos derivds+               ; return (tcg_env, bagToList info_bag, valbinds) }++addClsInsts :: [InstInfo Name] -> TcM a -> TcM a+addClsInsts infos thing_inside+  = tcExtendLocalInstEnv (map iSpec infos) thing_inside++addFamInsts :: [FamInst] -> TcM a -> TcM a+-- Extend (a) the family instance envt+--        (b) the type envt with stuff from data type decls+addFamInsts fam_insts thing_inside+  = tcExtendLocalFamInstEnv fam_insts $+    tcExtendGlobalEnv axioms $+    tcExtendTyConEnv data_rep_tycons  $+    do { traceTc "addFamInsts" (pprFamInsts fam_insts)+       ; tcg_env <- tcAddImplicits data_rep_tycons+                    -- Does not add its axiom; that comes from+                    -- adding the 'axioms' above+       ; setGblEnv tcg_env thing_inside }+  where+    axioms = map (ACoAxiom . toBranchedAxiom . famInstAxiom) fam_insts+    data_rep_tycons = famInstsRepTyCons fam_insts+      -- The representation tycons for 'data instances' declarations++{-+Note [Deriving inside TH brackets]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given a declaration bracket+  [d| data T = A | B deriving( Show ) |]++there is really no point in generating the derived code for deriving(+Show) and then type-checking it. This will happen at the call site+anyway, and the type check should never fail!  Moreover (Trac #6005)+the scoping of the generated code inside the bracket does not seem to+work out.++The easy solution is simply not to generate the derived instances at+all.  (A less brutal solution would be to generate them with no+bindings.)  This will become moot when we shift to the new TH plan, so+the brutal solution will do.+-}++tcLocalInstDecl :: LInstDecl Name+                -> TcM ([InstInfo Name], [FamInst], [DerivInfo])+        -- A source-file instance declaration+        -- Type-check all the stuff before the "where"+        --+        -- We check for respectable instance type, and context+tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl }))+  = do { fam_inst <- tcTyFamInstDecl Nothing (L loc decl)+       ; return ([], [fam_inst], []) }++tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl }))+  = do { (fam_inst, m_deriv_info) <- tcDataFamInstDecl Nothing (L loc decl)+       ; return ([], [fam_inst], maybeToList m_deriv_info) }++tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl }))+  = do { (insts, fam_insts, deriv_infos) <- tcClsInstDecl (L loc decl)+       ; return (insts, fam_insts, deriv_infos) }++tcClsInstDecl :: LClsInstDecl Name+              -> TcM ([InstInfo Name], [FamInst], [DerivInfo])+-- The returned DerivInfos are for any associated data families+tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds+                                  , cid_sigs = uprags, cid_tyfam_insts = ats+                                  , cid_overlap_mode = overlap_mode+                                  , cid_datafam_insts = adts }))+  = setSrcSpan loc                      $+    addErrCtxt (instDeclCtxt1 poly_ty)  $+    do  { (tyvars, theta, clas, inst_tys) <- tcHsClsInstType InstDeclCtxt poly_ty+        ; let mini_env   = mkVarEnv (classTyVars clas `zip` inst_tys)+              mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env+              mb_info    = Just (clas, tyvars, mini_env)++        -- Next, process any associated types.+        ; traceTc "tcLocalInstDecl" (ppr poly_ty)+        ; tyfam_insts0  <- tcExtendTyVarEnv tyvars $+                           mapAndRecoverM (tcTyFamInstDecl mb_info) ats+        ; datafam_stuff <- tcExtendTyVarEnv tyvars $+                           mapAndRecoverM (tcDataFamInstDecl mb_info) adts+        ; let (datafam_insts, m_deriv_infos) = unzip datafam_stuff+              deriv_infos                    = catMaybes m_deriv_infos++        -- Check for missing associated types and build them+        -- from their defaults (if available)+        ; let defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats)+                            `unionNameSet`+                            mkNameSet (map (unLoc . dfid_tycon . unLoc) adts)+        ; tyfam_insts1 <- mapM (tcATDefault True loc mini_subst defined_ats)+                               (classATItems clas)++        -- Finally, construct the Core representation of the instance.+        -- (This no longer includes the associated types.)+        ; dfun_name <- newDFunName clas inst_tys (getLoc (hsSigType poly_ty))+                -- Dfun location is that of instance *header*++        ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name tyvars theta+                              clas inst_tys++        ; let inst_info = InstInfo { iSpec  = ispec+                                   , iBinds = InstBindings+                                     { ib_binds = binds+                                     , ib_tyvars = map Var.varName tyvars -- Scope over bindings+                                     , ib_pragmas = uprags+                                     , ib_extensions = []+                                     , ib_derived = False } }++        ; doClsInstErrorChecks inst_info++        ; return ( [inst_info], tyfam_insts0 ++ concat tyfam_insts1 ++ datafam_insts+                 , deriv_infos ) }+++doClsInstErrorChecks :: InstInfo Name -> TcM ()+doClsInstErrorChecks inst_info+ = do { traceTc "doClsInstErrorChecks" (ppr ispec)+      ; dflags <- getDynFlags+      ; is_boot <- tcIsHsBootOrSig++         -- In hs-boot files there should be no bindings+      ; failIfTc (is_boot && not no_binds) badBootDeclErr++         -- If not in an hs-boot file, abstract classes cannot have+         -- instances declared+      ; failIfTc (not is_boot && isAbstractClass clas) abstractClassInstErr++         -- Handwritten instances of any rejected+         -- class is always forbidden+         -- #12837+      ; failIfTc (clas_nm `elem` rejectedClassNames) clas_err++         -- Check for hand-written Generic instances (disallowed in Safe Haskell)+      ; when (clas_nm `elem` genericClassNames) $+        do { failIfTc (safeLanguageOn dflags) gen_inst_err+           ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) }+  }+  where+    ispec    = iSpec inst_info+    binds    = iBinds inst_info+    no_binds = isEmptyLHsBinds (ib_binds binds) && null (ib_pragmas binds)+    clas_nm  = is_cls_nm ispec+    clas     = is_cls ispec++    gen_inst_err = hang (text ("Generic instances can only be "+                            ++ "derived in Safe Haskell.") $+$+                         text "Replace the following instance:")+                      2 (pprInstanceHdr ispec)++    abstractClassInstErr =+        text "Cannot define instance for abstract class" <+> quotes (ppr clas_nm)++    -- Report an error or a warning for certain class instances.+    -- If we are working on an .hs-boot file, we just report a warning,+    -- and ignore the instance.  We do this, to give users a chance to fix+    -- their code.+    rejectedClassNames = [ typeableClassName+                         , knownNatClassName+                         , knownSymbolClassName ]+    clas_err = text "Class" <+> quotes (ppr clas_nm)+                    <+> text "does not support user-specified instances"++{-+************************************************************************+*                                                                      *+               Type checking family instances+*                                                                      *+************************************************************************++Family instances are somewhat of a hybrid.  They are processed together with+class instance heads, but can contain data constructors and hence they share a+lot of kinding and type checking code with ordinary algebraic data types (and+GADTs).+-}++tcFamInstDeclCombined :: Maybe ClsInstInfo+                      -> Located Name -> TcM TyCon+tcFamInstDeclCombined mb_clsinfo fam_tc_lname+  = do { -- Type family instances require -XTypeFamilies+         -- and can't (currently) be in an hs-boot file+       ; traceTc "tcFamInstDecl" (ppr fam_tc_lname)+       ; type_families <- xoptM LangExt.TypeFamilies+       ; is_boot <- tcIsHsBootOrSig   -- Are we compiling an hs-boot file?+       ; checkTc type_families $ badFamInstDecl fam_tc_lname+       ; checkTc (not is_boot) $ badBootFamInstDeclErr++       -- Look up the family TyCon and check for validity including+       -- check that toplevel type instances are not for associated types.+       ; fam_tc <- tcLookupLocatedTyCon fam_tc_lname+       ; when (isNothing mb_clsinfo &&   -- Not in a class decl+               isTyConAssoc fam_tc)      -- but an associated type+              (addErr $ assocInClassErr fam_tc_lname)++       ; return fam_tc }++tcTyFamInstDecl :: Maybe ClsInstInfo+                -> LTyFamInstDecl Name -> TcM FamInst+  -- "type instance"+tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))+  = setSrcSpan loc           $+    tcAddTyFamInstCtxt decl  $+    do { let fam_lname = tfe_tycon (unLoc eqn)+       ; fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_lname++         -- (0) Check it's an open type family+       ; checkTc (isFamilyTyCon fam_tc)         (notFamily fam_tc)+       ; checkTc (isTypeFamilyTyCon fam_tc)     (wrongKindOfFamily fam_tc)+       ; checkTc (isOpenTypeFamilyTyCon fam_tc) (notOpenFamily fam_tc)++         -- (1) do the work of verifying the synonym group+       ; co_ax_branch <- tcTyFamInstEqn (famTyConShape fam_tc) mb_clsinfo eqn++         -- (2) check for validity+       ; checkValidCoAxBranch mb_clsinfo fam_tc co_ax_branch++         -- (3) construct coercion axiom+       ; rep_tc_name <- newFamInstAxiomName fam_lname [coAxBranchLHS co_ax_branch]+       ; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch+       ; newFamInst SynFamilyInst axiom }++tcDataFamInstDecl :: Maybe ClsInstInfo+                  -> LDataFamInstDecl Name -> TcM (FamInst, Maybe DerivInfo)+  -- "newtype instance" and "data instance"+tcDataFamInstDecl mb_clsinfo+    (L loc decl@(DataFamInstDecl+       { dfid_pats = pats+       , dfid_tycon = fam_tc_name+       , dfid_defn = defn@HsDataDefn { dd_ND = new_or_data, dd_cType = cType+                                     , dd_ctxt = ctxt, dd_cons = cons+                                     , dd_derivs = derivs } }))+  = setSrcSpan loc             $+    tcAddDataFamInstCtxt decl  $+    do { fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_tc_name++         -- Check that the family declaration is for the right kind+       ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)+       ; checkTc (isDataFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)++         -- Kind check type patterns+       ; tcFamTyPats (famTyConShape fam_tc) mb_clsinfo pats+                     (kcDataDefn (unLoc fam_tc_name) pats defn) $+             \tvs pats res_kind ->+    do { stupid_theta <- solveEqualities $ tcHsContext ctxt++            -- Zonk the patterns etc into the Type world+       ; (ze, tvs')    <- zonkTyBndrsX emptyZonkEnv tvs+       ; pats'         <- zonkTcTypeToTypes ze pats+       ; res_kind'     <- zonkTcTypeToType  ze res_kind+       ; stupid_theta' <- zonkTcTypeToTypes ze stupid_theta++       ; gadt_syntax <- dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta' cons++         -- Construct representation tycon+       ; rep_tc_name <- newFamInstTyConName fam_tc_name pats'+       ; axiom_name  <- newFamInstAxiomName fam_tc_name [pats']++       ; let (eta_pats, etad_tvs) = eta_reduce pats'+             eta_tvs              = filterOut (`elem` etad_tvs) tvs'+             full_tvs             = eta_tvs ++ etad_tvs+                 -- Put the eta-removed tyvars at the end+                 -- Remember, tvs' is in arbitrary order (except kind vars are+                 -- first, so there is no reason to suppose that the etad_tvs+                 -- (obtained from the pats) are at the end (Trac #11148)+             orig_res_ty          = mkTyConApp fam_tc pats'++       ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) ->+           do { let ty_binders = mkTyConBindersPreferAnon full_tvs liftedTypeKind+              ; data_cons <- tcConDecls rec_rep_tc+                                        (ty_binders, orig_res_ty) cons+              ; tc_rhs <- case new_or_data of+                     DataType -> return (mkDataTyConRhs data_cons)+                     NewType  -> ASSERT( not (null data_cons) )+                                 mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons)+              -- freshen tyvars+              ; let axiom  = mkSingleCoAxiom Representational+                                             axiom_name eta_tvs [] fam_tc eta_pats+                                             (mkTyConApp rep_tc (mkTyVarTys eta_tvs))+                    parent = DataFamInstTyCon axiom fam_tc pats'+++                      -- NB: Use the full_tvs from the pats. See bullet toward+                      -- the end of Note [Data type families] in TyCon+                    rep_tc   = mkAlgTyCon rep_tc_name+                                          ty_binders liftedTypeKind+                                          (map (const Nominal) full_tvs)+                                          (fmap unLoc cType) stupid_theta+                                          tc_rhs parent+                                          gadt_syntax+                 -- We always assume that indexed types are recursive.  Why?+                 -- (1) Due to their open nature, we can never be sure that a+                 -- further instance might not introduce a new recursive+                 -- dependency.  (2) They are always valid loop breakers as+                 -- they involve a coercion.+              ; return (rep_tc, axiom) }++         -- Remember to check validity; no recursion to worry about here+         -- Check that left-hand sides are ok (mono-types, no type families,+         -- consistent instantiations, etc)+       ; checkValidFamPats mb_clsinfo fam_tc tvs' [] pats'++         -- Result kind must be '*' (otherwise, we have too few patterns)+       ; checkTc (isLiftedTypeKind res_kind') $+         tooFewParmsErr (tyConArity fam_tc)++       ; checkValidTyCon rep_tc++       ; let m_deriv_info = case derivs of+               L _ []    -> Nothing+               L _ preds ->+                 Just $ DerivInfo { di_rep_tc  = rep_tc+                                  , di_clauses = preds+                                  , di_ctxt    = tcMkDataFamInstCtxt decl }++       ; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom+       ; return (fam_inst, m_deriv_info) } }+  where+    eta_reduce :: [Type] -> ([Type], [TyVar])+    -- See Note [Eta reduction for data families] in FamInstEnv+    -- Splits the incoming patterns into two: the [TyVar]+    -- are the patterns that can be eta-reduced away.+    -- e.g.     T [a] Int a d c   ==>  (T [a] Int a, [d,c])+    --+    -- NB: quadratic algorithm, but types are small here+    eta_reduce pats+      = go (reverse pats) []+    go (pat:pats) etad_tvs+      | Just tv <- getTyVar_maybe pat+      , not (tv `elemVarSet` tyCoVarsOfTypes pats)+      = go pats (tv : etad_tvs)+    go pats etad_tvs = (reverse pats, etad_tvs)+++{- *********************************************************************+*                                                                      *+      Type-checking instance declarations, pass 2+*                                                                      *+********************************************************************* -}++tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]+             -> TcM (LHsBinds Id)+-- (a) From each class declaration,+--      generate any default-method bindings+-- (b) From each instance decl+--      generate the dfun binding++tcInstDecls2 tycl_decls inst_decls+  = do  { -- (a) Default methods from class decls+          let class_decls = filter (isClassDecl . unLoc) tycl_decls+        ; dm_binds_s <- mapM tcClassDecl2 class_decls+        ; let dm_binds = unionManyBags dm_binds_s++          -- (b) instance declarations+        ; let dm_ids = collectHsBindsBinders dm_binds+              -- Add the default method Ids (again)+              -- (they were arready added in TcTyDecls.tcAddImplicits)+              -- See Note [Default methods in the type environment]+        ; inst_binds_s <- tcExtendGlobalValEnv dm_ids $+                          mapM tcInstDecl2 inst_decls++          -- Done+        ; return (dm_binds `unionBags` unionManyBags inst_binds_s) }++{- Note [Default methods in the type environment]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The default method Ids are already in the type environment (see Note+[Default method Ids and Template Haskell] in TcTyDcls), BUT they+don't have their InlinePragmas yet.  Usually that would not matter,+because the simplifier propagates information from binding site to+use.  But, unusually, when compiling instance decls we *copy* the+INLINE pragma from the default method to the method for that+particular operation (see Note [INLINE and default methods] below).++So right here in tcInstDecls2 we must re-extend the type envt with+the default method Ids replete with their INLINE pragmas.  Urk.+-}++tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)+            -- Returns a binding for the dfun+tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })+  = recoverM (return emptyLHsBinds)             $+    setSrcSpan loc                              $+    addErrCtxt (instDeclCtxt2 (idType dfun_id)) $+    do {  -- Instantiate the instance decl with skolem constants+       ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType dfun_id+       ; dfun_ev_vars <- newEvVars dfun_theta+                     -- We instantiate the dfun_id with superSkolems.+                     -- See Note [Subtle interaction of recursion and overlap]+                     -- and Note [Binding when looking up instances]++       ; let (clas, inst_tys) = tcSplitDFunHead inst_head+             (class_tyvars, sc_theta, _, op_items) = classBigSig clas+             sc_theta' = substTheta (zipTvSubst class_tyvars inst_tys) sc_theta++       ; traceTc "tcInstDecl2" (vcat [ppr inst_tyvars, ppr inst_tys, ppr dfun_theta, ppr sc_theta'])++                      -- Deal with 'SPECIALISE instance' pragmas+                      -- See Note [SPECIALISE instance pragmas]+       ; spec_inst_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds++         -- Typecheck superclasses and methods+         -- See Note [Typechecking plan for instance declarations]+       ; dfun_ev_binds_var <- newTcEvBinds+       ; let dfun_ev_binds = TcEvBinds dfun_ev_binds_var+       ; ((sc_meth_ids, sc_meth_binds, sc_meth_implics), tclvl)+             <- pushTcLevelM $+                do { (sc_ids, sc_binds, sc_implics)+                        <- tcSuperClasses dfun_id clas inst_tyvars dfun_ev_vars+                                          inst_tys dfun_ev_binds+                                          sc_theta'++                      -- Typecheck the methods+                   ; (meth_ids, meth_binds, meth_implics)+                        <- tcMethods dfun_id clas inst_tyvars dfun_ev_vars+                                     inst_tys dfun_ev_binds spec_inst_info+                                     op_items ibinds++                   ; return ( sc_ids     ++          meth_ids+                            , sc_binds   `unionBags` meth_binds+                            , sc_implics `unionBags` meth_implics ) }++       ; env <- getLclEnv+       ; emitImplication $ Implic { ic_tclvl  = tclvl+                                  , ic_skols  = inst_tyvars+                                  , ic_no_eqs = False+                                  , ic_given  = dfun_ev_vars+                                  , ic_wanted = mkImplicWC sc_meth_implics+                                  , ic_status = IC_Unsolved+                                  , ic_binds  = dfun_ev_binds_var+                                  , ic_needed = emptyVarSet+                                  , ic_env    = env+                                  , ic_info   = InstSkol }++       -- Create the result bindings+       ; self_dict <- newDict clas inst_tys+       ; let class_tc      = classTyCon clas+             [dict_constr] = tyConDataCons class_tc+             dict_bind     = mkVarBind self_dict (L loc con_app_args)++                     -- We don't produce a binding for the dict_constr; instead we+                     -- rely on the simplifier to unfold this saturated application+                     -- We do this rather than generate an HsCon directly, because+                     -- it means that the special cases (e.g. dictionary with only one+                     -- member) are dealt with by the common MkId.mkDataConWrapId+                     -- code rather than needing to be repeated here.+                     --    con_app_tys  = MkD ty1 ty2+                     --    con_app_scs  = MkD ty1 ty2 sc1 sc2+                     --    con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2+             con_app_tys  = mkHsWrap (mkWpTyApps inst_tys)+                                     (HsConLikeOut (RealDataCon dict_constr))+                       -- NB: We *can* have covars in inst_tys, in the case of+                       -- promoted GADT constructors.++             con_app_args = foldl app_to_meth con_app_tys sc_meth_ids++             app_to_meth :: HsExpr Id -> Id -> HsExpr Id+             app_to_meth fun meth_id = L loc fun `HsApp` L loc (wrapId arg_wrapper meth_id)++             inst_tv_tys = mkTyVarTys inst_tyvars+             arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys++             is_newtype = isNewTyCon class_tc+             dfun_id_w_prags = addDFunPrags dfun_id sc_meth_ids+             dfun_spec_prags+                | is_newtype = SpecPrags []+                | otherwise  = SpecPrags spec_inst_prags+                    -- Newtype dfuns just inline unconditionally,+                    -- so don't attempt to specialise them++             export = ABE { abe_wrap = idHsWrapper+                          , abe_poly = dfun_id_w_prags+                          , abe_mono = self_dict+                          , abe_prags = dfun_spec_prags }+                          -- NB: see Note [SPECIALISE instance pragmas]+             main_bind = AbsBinds { abs_tvs = inst_tyvars+                                  , abs_ev_vars = dfun_ev_vars+                                  , abs_exports = [export]+                                  , abs_ev_binds = []+                                  , abs_binds = unitBag dict_bind }++       ; return (unitBag (L loc main_bind) `unionBags` sc_meth_binds)+       }+ where+   dfun_id = instanceDFunId ispec+   loc     = getSrcSpan dfun_id++addDFunPrags :: DFunId -> [Id] -> DFunId+-- DFuns need a special Unfolding and InlinePrag+--    See Note [ClassOp/DFun selection]+--    and Note [Single-method classes]+-- It's easiest to create those unfoldings right here, where+-- have all the pieces in hand, even though we are messing with+-- Core at this point, which the typechecker doesn't usually do+-- However we take care to build the unfolding using the TyVars from+-- the DFunId rather than from the skolem pieces that the typechecker+-- is messing with.+addDFunPrags dfun_id sc_meth_ids+ | is_newtype+  = dfun_id `setIdUnfolding`  mkInlineUnfoldingWithArity 0 con_app+            `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }+ | otherwise+ = dfun_id `setIdUnfolding`  mkDFunUnfolding dfun_bndrs dict_con dict_args+           `setInlinePragma` dfunInlinePragma+ where+   con_app    = mkLams dfun_bndrs $+                mkApps (Var (dataConWrapId dict_con)) dict_args+                 -- mkApps is OK because of the checkForLevPoly call in checkValidClass+                 -- See Note [Levity polymorphism checking] in DsMonad+   dict_args  = map Type inst_tys +++                [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids]++   (dfun_tvs, dfun_theta, clas, inst_tys) = tcSplitDFunTy (idType dfun_id)+   ev_ids      = mkTemplateLocalsNum 1                    dfun_theta+   dfun_bndrs  = dfun_tvs ++ ev_ids+   clas_tc     = classTyCon clas+   [dict_con]  = tyConDataCons clas_tc+   is_newtype  = isNewTyCon clas_tc++wrapId :: HsWrapper -> id -> HsExpr id+wrapId wrapper id = mkHsWrap wrapper (HsVar (noLoc id))++{- Note [Typechecking plan for instance declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For instance declarations we generate the following bindings and implication+constraints.  Example:++   instance Ord a => Ord [a] where compare = <compare-rhs>++generates this:++   Bindings:+      -- Method bindings+      $ccompare :: forall a. Ord a => a -> a -> Ordering+      $ccompare = /\a \(d:Ord a). let <meth-ev-binds> in ...++      -- Superclass bindings+      $cp1Ord :: forall a. Ord a => Eq [a]+      $cp1Ord = /\a \(d:Ord a). let <sc-ev-binds>+               in dfEqList (dw :: Eq a)++   Constraints:+      forall a. Ord a =>+                -- Method constraint+             (forall. (empty) => <constraints from compare-rhs>)+                -- Superclass constraint+          /\ (forall. (empty) => dw :: Eq a)++Notice that++ * Per-meth/sc implication.  There is one inner implication per+   superclass or method, with no skolem variables or givens.  The only+   reason for this one is to gather the evidence bindings privately+   for this superclass or method.  This implication is generated+   by checkInstConstraints.++ * Overall instance implication. There is an overall enclosing+   implication for the whole instance declaratation, with the expected+   skolems and givens.  We need this to get the correct "redundant+   constraint" warnings, gathering all the uses from all the methods+   and superclasses.  See TcSimplify Note [Tracking redundant+   constraints]++ * The given constraints in the outer implication may generate+   evidence, notably by superclass selection.  Since the method and+   superclass bindings are top-level, we want that evidence copied+   into *every* method or superclass definition.  (Some of it will+   be usused in some, but dead-code elimination will drop it.)++   We achieve this by putting the the evidence variable for the overall+   instance implication into the AbsBinds for each method/superclass.+   Hence the 'dfun_ev_binds' passed into tcMethods and tcSuperClasses.+   (And that in turn is why the abs_ev_binds field of AbBinds is a+   [TcEvBinds] rather than simply TcEvBinds.++   This is a bit of a hack, but works very nicely in practice.++ * Note that if a method has a locally-polymorphic binding, there will+   be yet another implication for that, generated by tcPolyCheck+   in tcMethodBody. E.g.+          class C a where+            foo :: forall b. Ord b => blah+++************************************************************************+*                                                                      *+      Type-checking superclasses+*                                                                      *+************************************************************************+-}++tcSuperClasses :: DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType]+               -> TcEvBinds+               -> TcThetaType+               -> TcM ([EvVar], LHsBinds Id, Bag Implication)+-- Make a new top-level function binding for each superclass,+-- something like+--    $Ordp1 :: forall a. Ord a => Eq [a]+--    $Ordp1 = /\a \(d:Ord a). dfunEqList a (sc_sel d)+--+-- See Note [Recursive superclasses] for why this is so hard!+-- In effect, we build a special-purpose solver for the first step+-- of solving each superclass constraint+tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta+  = do { (ids, binds, implics) <- mapAndUnzip3M tc_super (zip sc_theta [fIRST_TAG..])+       ; return (ids, listToBag binds, listToBag implics) }+  where+    loc = getSrcSpan dfun_id+    size = sizeTypes inst_tys+    tc_super (sc_pred, n)+      = do { (sc_implic, ev_binds_var, sc_ev_tm)+                <- checkInstConstraints $ emitWanted (ScOrigin size) sc_pred++           ; sc_top_name  <- newName (mkSuperDictAuxOcc n (getOccName cls))+           ; sc_ev_id     <- newEvVar sc_pred+           ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id sc_ev_tm+           ; let sc_top_ty = mkInvForAllTys tyvars (mkLamTypes dfun_evs sc_pred)+                 sc_top_id = mkLocalId sc_top_name sc_top_ty+                 export = ABE { abe_wrap = idHsWrapper+                              , abe_poly = sc_top_id+                              , abe_mono = sc_ev_id+                              , abe_prags = noSpecPrags }+                 local_ev_binds = TcEvBinds ev_binds_var+                 bind = AbsBinds { abs_tvs      = tyvars+                                 , abs_ev_vars  = dfun_evs+                                 , abs_exports  = [export]+                                 , abs_ev_binds = [dfun_ev_binds, local_ev_binds]+                                 , abs_binds    = emptyBag }+           ; return (sc_top_id, L loc bind, sc_implic) }++-------------------+checkInstConstraints :: TcM result+                     -> TcM (Implication, EvBindsVar, result)+-- See Note [Typechecking plan for instance declarations]+checkInstConstraints thing_inside+  = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints  $+                                    thing_inside++       ; ev_binds_var <- newTcEvBinds+       ; env <- getLclEnv+       ; let implic = Implic { ic_tclvl  = tclvl+                             , ic_skols  = []+                             , ic_no_eqs = False+                             , ic_given  = []+                             , ic_wanted = wanted+                             , ic_status = IC_Unsolved+                             , ic_binds  = ev_binds_var+                             , ic_needed = emptyVarSet+                             , ic_env    = env+                             , ic_info   = InstSkol }++       ; return (implic, ev_binds_var, result) }++{-+Note [Recursive superclasses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See Trac #3731, #4809, #5751, #5913, #6117, #6161, which all+describe somewhat more complicated situations, but ones+encountered in practice.++See also tests tcrun020, tcrun021, tcrun033, and Trac #11427.++----- THE PROBLEM --------+The problem is that it is all too easy to create a class whose+superclass is bottom when it should not be.++Consider the following (extreme) situation:+        class C a => D a where ...+        instance D [a] => D [a] where ...   (dfunD)+        instance C [a] => C [a] where ...   (dfunC)+Although this looks wrong (assume D [a] to prove D [a]), it is only a+more extreme case of what happens with recursive dictionaries, and it+can, just about, make sense because the methods do some work before+recursing.++To implement the dfunD we must generate code for the superclass C [a],+which we had better not get by superclass selection from the supplied+argument:+       dfunD :: forall a. D [a] -> D [a]+       dfunD = \d::D [a] -> MkD (scsel d) ..++Otherwise if we later encounter a situation where+we have a [Wanted] dw::D [a] we might solve it thus:+     dw := dfunD dw+Which is all fine except that now ** the superclass C is bottom **!++The instance we want is:+       dfunD :: forall a. D [a] -> D [a]+       dfunD = \d::D [a] -> MkD (dfunC (scsel d)) ...++----- THE SOLUTION --------+The basic solution is simple: be very careful about using superclass+selection to generate a superclass witness in a dictionary function+definition.  More precisely:++  Superclass Invariant: in every class dictionary,+                        every superclass dictionary field+                        is non-bottom++To achieve the Superclass Invariant, in a dfun definition we can+generate a guaranteed-non-bottom superclass witness from:+  (sc1) one of the dictionary arguments itself (all non-bottom)+  (sc2) an immediate superclass of a smaller dictionary+  (sc3) a call of a dfun (always returns a dictionary constructor)++The tricky case is (sc2).  We proceed by induction on the size of+the (type of) the dictionary, defined by TcValidity.sizeTypes.+Let's suppose we are building a dictionary of size 3, and+suppose the Superclass Invariant holds of smaller dictionaries.+Then if we have a smaller dictionary, its immediate superclasses+will be non-bottom by induction.++What does "we have a smaller dictionary" mean?  It might be+one of the arguments of the instance, or one of its superclasses.+Here is an example, taken from CmmExpr:+       class Ord r => UserOfRegs r a where ...+(i1)   instance UserOfRegs r a => UserOfRegs r (Maybe a) where+(i2)   instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where++For (i1) we can get the (Ord r) superclass by selection from (UserOfRegs r a),+since it is smaller than the thing we are building (UserOfRegs r (Maybe a).++But for (i2) that isn't the case, so we must add an explicit, and+perhaps surprising, (Ord r) argument to the instance declaration.++Here's another example from Trac #6161:++       class       Super a => Duper a  where ...+       class Duper (Fam a) => Foo a    where ...+(i3)   instance Foo a => Duper (Fam a) where ...+(i4)   instance              Foo Float where ...++It would be horribly wrong to define+   dfDuperFam :: Foo a -> Duper (Fam a)  -- from (i3)+   dfDuperFam d = MkDuper (sc_sel1 (sc_sel2 d)) ...++   dfFooFloat :: Foo Float               -- from (i4)+   dfFooFloat = MkFoo (dfDuperFam dfFooFloat) ...++Now the Super superclass of Duper is definitely bottom!++This won't happen because when processing (i3) we can use the+superclasses of (Foo a), which is smaller, namely Duper (Fam a).  But+that is *not* smaller than the target so we can't take *its*+superclasses.  As a result the program is rightly rejected, unless you+add (Super (Fam a)) to the context of (i3).++Note [Solving superclass constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+How do we ensure that every superclass witness is generated by+one of (sc1) (sc2) or (sc3) in Note [Recursive superclasses].+Answer:++  * Superclass "wanted" constraints have CtOrigin of (ScOrigin size)+    where 'size' is the size of the instance declaration. e.g.+          class C a => D a where...+          instance blah => D [a] where ...+    The wanted superclass constraint for C [a] has origin+    ScOrigin size, where size = size( D [a] ).++  * (sc1) When we rewrite such a wanted constraint, it retains its+    origin.  But if we apply an instance declaration, we can set the+    origin to (ScOrigin infinity), thus lifting any restrictions by+    making prohibitedSuperClassSolve return False.++  * (sc2) ScOrigin wanted constraints can't be solved from a+    superclass selection, except at a smaller type.  This test is+    implemented by TcInteract.prohibitedSuperClassSolve++  * The "given" constraints of an instance decl have CtOrigin+    GivenOrigin InstSkol.++  * When we make a superclass selection from InstSkol we use+    a SkolemInfo of (InstSC size), where 'size' is the size of+    the constraint whose superclass we are taking.  An similarly+    when taking the superclass of an InstSC.  This is implemented+    in TcCanonical.newSCWorkFromFlavored++Note [Silent superclass arguments] (historical interest only)+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+NB1: this note describes our *old* solution to the+     recursive-superclass problem. I'm keeping the Note+     for now, just as institutional memory.+     However, the code for silent superclass arguments+     was removed in late Dec 2014++NB2: the silent-superclass solution introduced new problems+     of its own, in the form of instance overlap.  Tests+     SilentParametersOverlapping, T5051, and T7862 are examples++NB3: the silent-superclass solution also generated tons of+     extra dictionaries.  For example, in monad-transformer+     code, when constructing a Monad dictionary you had to pass+     an Applicative dictionary; and to construct that you neede+     a Functor dictionary. Yet these extra dictionaries were+     often never used.  Test T3064 compiled *far* faster after+     silent superclasses were eliminated.++Our solution to this problem "silent superclass arguments".  We pass+to each dfun some ``silent superclass arguments’’, which are the+immediate superclasses of the dictionary we are trying to+construct. In our example:+       dfun :: forall a. C [a] -> D [a] -> D [a]+       dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ...+Notice the extra (dc :: C [a]) argument compared to the previous version.++This gives us:++     -----------------------------------------------------------+     DFun Superclass Invariant+     ~~~~~~~~~~~~~~~~~~~~~~~~+     In the body of a DFun, every superclass argument to the+     returned dictionary is+       either   * one of the arguments of the DFun,+       or       * constant, bound at top level+     -----------------------------------------------------------++This net effect is that it is safe to treat a dfun application as+wrapping a dictionary constructor around its arguments (in particular,+a dfun never picks superclasses from the arguments under the+dictionary constructor). No superclass is hidden inside a dfun+application.++The extra arguments required to satisfy the DFun Superclass Invariant+always come first, and are called the "silent" arguments.  You can+find out how many silent arguments there are using Id.dfunNSilent;+and then you can just drop that number of arguments to see the ones+that were in the original instance declaration.++DFun types are built (only) by MkId.mkDictFunId, so that is where we+decide what silent arguments are to be added.+-}++{-+************************************************************************+*                                                                      *+      Type-checking an instance method+*                                                                      *+************************************************************************++tcMethod+- Make the method bindings, as a [(NonRec, HsBinds)], one per method+- Remembering to use fresh Name (the instance method Name) as the binder+- Bring the instance method Ids into scope, for the benefit of tcInstSig+- Use sig_fn mapping instance method Name -> instance tyvars+- Ditto prag_fn+- Use tcValBinds to do the checking+-}++tcMethods :: DFunId -> Class+          -> [TcTyVar] -> [EvVar]+          -> [TcType]+          -> TcEvBinds+          -> ([Located TcSpecPrag], TcPragEnv)+          -> [ClassOpItem]+          -> InstBindings Name+          -> TcM ([Id], LHsBinds Id, Bag Implication)+        -- The returned inst_meth_ids all have types starting+        --      forall tvs. theta => ...+tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys+                  dfun_ev_binds (spec_inst_prags, prag_fn) op_items+                  (InstBindings { ib_binds      = binds+                                , ib_tyvars     = lexical_tvs+                                , ib_pragmas    = sigs+                                , ib_extensions = exts+                                , ib_derived    = is_derived })+  = tcExtendTyVarEnv2 (lexical_tvs `zip` tyvars) $+       -- The lexical_tvs scope over the 'where' part+    do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)+       ; checkMinimalDefinition+       ; (ids, binds, mb_implics) <- set_exts exts $+                                     mapAndUnzip3M tc_item op_items+       ; return (ids, listToBag binds, listToBag (catMaybes mb_implics)) }+  where+    set_exts :: [LangExt.Extension] -> TcM a -> TcM a+    set_exts es thing = foldr setXOptM thing es++    hs_sig_fn = mkHsSigFun sigs+    inst_loc  = getSrcSpan dfun_id++    ----------------------+    tc_item :: ClassOpItem -> TcM (Id, LHsBind Id, Maybe Implication)+    tc_item (sel_id, dm_info)+      | Just (user_bind, bndr_loc, prags) <- findMethodBind (idName sel_id) binds prag_fn+      = tcMethodBody clas tyvars dfun_ev_vars inst_tys+                              dfun_ev_binds is_derived hs_sig_fn+                              spec_inst_prags prags+                              sel_id user_bind bndr_loc+      | otherwise+      = do { traceTc "tc_def" (ppr sel_id)+           ; tc_default sel_id dm_info }++    ----------------------+    tc_default :: Id -> DefMethInfo -> TcM (TcId, LHsBind Id, Maybe Implication)++    tc_default sel_id (Just (dm_name, _))+      = do { (meth_bind, inline_prags) <- mkDefMethBind clas inst_tys sel_id dm_name+           ; tcMethodBody clas tyvars dfun_ev_vars inst_tys+                          dfun_ev_binds is_derived hs_sig_fn+                          spec_inst_prags inline_prags+                          sel_id meth_bind inst_loc }++    tc_default sel_id Nothing     -- No default method at all+      = do { traceTc "tc_def: warn" (ppr sel_id)+           ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars+                                       inst_tys sel_id+           ; dflags <- getDynFlags+           ; let meth_bind = mkVarBind meth_id $+                             mkLHsWrap lam_wrapper (error_rhs dflags)+           ; return (meth_id, meth_bind, Nothing) }+      where+        error_rhs dflags = L inst_loc $ HsApp error_fun (error_msg dflags)+        error_fun    = L inst_loc $+                       wrapId (mkWpTyApps+                                [ getRuntimeRep "tcInstanceMethods.tc_default" meth_tau+                                , meth_tau])+                              nO_METHOD_BINDING_ERROR_ID+        error_msg dflags = L inst_loc (HsLit (HsStringPrim NoSourceText+                                              (unsafeMkByteString (error_string dflags))))+        meth_tau     = funResultTy (piResultTys (idType sel_id) inst_tys)+        error_string dflags = showSDoc dflags+                              (hcat [ppr inst_loc, vbar, ppr sel_id ])+        lam_wrapper  = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars++    ----------------------+    -- Check if one of the minimal complete definitions is satisfied+    checkMinimalDefinition+      = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $+        warnUnsatisfiedMinimalDefinition++    methodExists meth = isJust (findMethodBind meth binds prag_fn)++------------------------+tcMethodBody :: Class -> [TcTyVar] -> [EvVar] -> [TcType]+             -> TcEvBinds -> Bool+             -> HsSigFun+             -> [LTcSpecPrag] -> [LSig Name]+             -> Id -> LHsBind Name -> SrcSpan+             -> TcM (TcId, LHsBind Id, Maybe Implication)+tcMethodBody clas tyvars dfun_ev_vars inst_tys+                     dfun_ev_binds is_derived+                     sig_fn spec_inst_prags prags+                     sel_id (L bind_loc meth_bind) bndr_loc+  = add_meth_ctxt $+    do { traceTc "tcMethodBody" (ppr sel_id <+> ppr (idType sel_id) $$ ppr bndr_loc)+       ; (global_meth_id, local_meth_id) <- setSrcSpan bndr_loc $+                                            mkMethIds clas tyvars dfun_ev_vars+                                                      inst_tys sel_id++       ; let lm_bind = meth_bind { fun_id = L bndr_loc (idName local_meth_id) }+                       -- Substitute the local_meth_name for the binder+                       -- NB: the binding is always a FunBind++            -- taking instance signature into account might change the type of+            -- the local_meth_id+       ; (meth_implic, ev_binds_var, tc_bind)+             <- checkInstConstraints $+                tcMethodBodyHelp sig_fn sel_id local_meth_id (L bind_loc lm_bind)++       ; global_meth_id <- addInlinePrags global_meth_id prags+       ; spec_prags     <- tcSpecPrags global_meth_id prags++        ; let specs  = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags+              export = ABE { abe_poly      = global_meth_id+                           , abe_mono      = local_meth_id+                           , abe_wrap      = idHsWrapper+                           , abe_prags     = specs }++              local_ev_binds = TcEvBinds ev_binds_var+              full_bind = AbsBinds { abs_tvs      = tyvars+                                   , abs_ev_vars  = dfun_ev_vars+                                   , abs_exports  = [export]+                                   , abs_ev_binds = [dfun_ev_binds, local_ev_binds]+                                   , abs_binds    = tc_bind }++        ; return (global_meth_id, L bind_loc full_bind, Just meth_implic) }+  where+        -- For instance decls that come from deriving clauses+        -- we want to print out the full source code if there's an error+        -- because otherwise the user won't see the code at all+    add_meth_ctxt thing+      | is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys) thing+      | otherwise  = thing++tcMethodBodyHelp :: HsSigFun -> Id -> TcId+                 -> LHsBind Name -> TcM (LHsBinds TcId)+tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind+  | Just hs_sig_ty <- hs_sig_fn sel_name+              -- There is a signature in the instance+              -- See Note [Instance method signatures]+  = do { let ctxt = FunSigCtxt sel_name True+       ; (sig_ty, hs_wrap)+             <- setSrcSpan (getLoc (hsSigType hs_sig_ty)) $+                do { inst_sigs <- xoptM LangExt.InstanceSigs+                   ; checkTc inst_sigs (misplacedInstSig sel_name hs_sig_ty)+                   ; sig_ty  <- tcHsSigType (FunSigCtxt sel_name False) hs_sig_ty+                   ; let local_meth_ty = idType local_meth_id+                   ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name sig_ty local_meth_ty) $+                                tcSubType_NC ctxt sig_ty local_meth_ty+                   ; return (sig_ty, hs_wrap) }++       ; inner_meth_name <- newName (nameOccName sel_name)+       ; let inner_meth_id  = mkLocalId inner_meth_name sig_ty+             inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id+                                          , sig_ctxt = ctxt+                                          , sig_loc  = getLoc (hsSigType hs_sig_ty) }+++       ; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind++       ; let export = ABE { abe_poly  = local_meth_id+                          , abe_mono  = inner_id+                          , abe_wrap  = hs_wrap+                          , abe_prags = noSpecPrags }++       ; return (unitBag $ L (getLoc meth_bind) $+                 AbsBinds { abs_tvs = [], abs_ev_vars = []+                          , abs_exports = [export]+                          , abs_binds = tc_bind, abs_ev_binds = [] }) }++  | otherwise  -- No instance signature+  = do { let ctxt = FunSigCtxt sel_name False+                    -- False <=> don't report redundant constraints+                    -- The signature is not under the users control!+             tc_sig = completeSigFromId ctxt local_meth_id+              -- Absent a type sig, there are no new scoped type variables here+              -- Only the ones from the instance decl itself, which are already+              -- in scope.  Example:+              --      class C a where { op :: forall b. Eq b => ... }+              --      instance C [c] where { op = <rhs> }+              -- In <rhs>, 'c' is scope but 'b' is not!++       ; (tc_bind, _) <- tcPolyCheck no_prag_fn tc_sig meth_bind+       ; return tc_bind }++  where+    sel_name   = idName sel_id+    no_prag_fn = emptyPragEnv   -- No pragmas for local_meth_id;+                                -- they are all for meth_id+++------------------------+mkMethIds :: Class -> [TcTyVar] -> [EvVar]+          -> [TcType] -> Id -> TcM (TcId, TcId)+             -- returns (poly_id, local_id), but ignoring any instance signature+             -- See Note [Instance method signatures]+mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id+  = do  { poly_meth_name  <- newName (mkClassOpAuxOcc sel_occ)+        ; local_meth_name <- newName sel_occ+                  -- Base the local_meth_name on the selector name, because+                  -- type errors from tcMethodBody come from here+        ; let poly_meth_id  = mkLocalId poly_meth_name  poly_meth_ty+              local_meth_id = mkLocalId local_meth_name local_meth_ty++        ; return (poly_meth_id, local_meth_id) }+  where+    sel_name      = idName sel_id+    sel_occ       = nameOccName sel_name+    local_meth_ty = instantiateMethod clas sel_id inst_tys+    poly_meth_ty  = mkSpecSigmaTy tyvars theta local_meth_ty+    theta         = map idType dfun_ev_vars++methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc)+methSigCtxt sel_name sig_ty meth_ty env0+  = do { (env1, sig_ty)  <- zonkTidyTcType env0 sig_ty+       ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty+       ; let msg = hang (text "When checking that instance signature for" <+> quotes (ppr sel_name))+                      2 (vcat [ text "is more general than its signature in the class"+                              , text "Instance sig:" <+> ppr sig_ty+                              , text "   Class sig:" <+> ppr meth_ty ])+       ; return (env2, msg) }++misplacedInstSig :: Name -> LHsSigType Name -> SDoc+misplacedInstSig name hs_ty+  = vcat [ hang (text "Illegal type signature in instance declaration:")+              2 (hang (pprPrefixName name)+                    2 (dcolon <+> ppr hs_ty))+         , text "(Use InstanceSigs to allow this)" ]++{- Note [Instance method signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+With -XInstanceSigs we allow the user to supply a signature for the+method in an instance declaration.  Here is an artificial example:++       data T a = MkT a+       instance Ord a => Ord (T a) where+         (>) :: forall b. b -> b -> Bool+         (>) = error "You can't compare Ts"++The instance signature can be *more* polymorphic than the instantiated+class method (in this case: Age -> Age -> Bool), but it cannot be less+polymorphic.  Moreover, if a signature is given, the implementation+code should match the signature, and type variables bound in the+singature should scope over the method body.++We achieve this by building a TcSigInfo for the method, whether or not+there is an instance method signature, and using that to typecheck+the declaration (in tcMethodBody).  That means, conveniently,+that the type variables bound in the signature will scope over the body.++What about the check that the instance method signature is more+polymorphic than the instantiated class method type?  We just do a+tcSubType call in tcMethodBodyHelp, and generate a nested AbsBind, like+this (for the example above++ AbsBind { abs_tvs = [a], abs_ev_vars = [d:Ord a]+         , abs_exports+             = ABExport { (>) :: forall a. Ord a => T a -> T a -> Bool+                        , gr_lcl :: T a -> T a -> Bool }+         , abs_binds+             = AbsBind { abs_tvs = [], abs_ev_vars = []+                       , abs_exports = ABExport { gr_lcl :: T a -> T a -> Bool+                                                , gr_inner :: forall b. b -> b -> Bool }+                       , abs_binds = AbsBind { abs_tvs = [b], abs_ev_vars = []+                                             , ..etc.. }+               } }++Wow!  Three nested AbsBinds!+ * The outer one abstracts over the tyvars and dicts for the instance+ * The middle one is only present if there is an instance signature,+   and does the impedance matching for that signature+ * The inner one is for the method binding itself against either the+   signature from the class, or the the instance signature.+-}++----------------------+mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags+        -- Adapt the 'SPECIALISE instance' pragmas to work for this method Id+        -- There are two sources:+        --   * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}+        --   * spec_prags_from_inst: derived from {-# SPECIALISE instance :: <blah> #-}+        --     These ones have the dfun inside, but [perhaps surprisingly]+        --     the correct wrapper.+        -- See Note [Handling SPECIALISE pragmas] in TcBinds+mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me+  = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst)+  where+    spec_prags_from_inst+       | isInlinePragma (idInlinePragma meth_id)+       = []  -- Do not inherit SPECIALISE from the instance if the+             -- method is marked INLINE, because then it'll be inlined+             -- and the specialisation would do nothing. (Indeed it'll provoke+             -- a warning from the desugarer+       | otherwise+       = [ L inst_loc (SpecPrag meth_id wrap inl)+         | L inst_loc (SpecPrag _       wrap inl) <- spec_inst_prags]+++mkDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name, [LSig Name])+-- The is a default method (vanailla or generic) defined in the class+-- So make a binding   op = $dmop @t1 @t2+-- where $dmop is the name of the default method in the class,+-- and t1,t2 are the instance types.+-- See Note [Default methods in instances] for why we use+-- visible type application here+mkDefMethBind clas inst_tys sel_id dm_name+  = do  { dflags <- getDynFlags+        ; dm_id <- tcLookupId dm_name+        ; let inline_prag = idInlinePragma dm_id+              inline_prags | isAnyInlinePragma inline_prag+                           = [noLoc (InlineSig fn inline_prag)]+                           | otherwise+                           = []+                 -- Copy the inline pragma (if any) from the default method+                 -- to this version. Note [INLINE and default methods]++              fn   = noLoc (idName sel_id)+              visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys+                                      , tyConBinderArgFlag tcb /= Inferred ]+              rhs  = foldl mk_vta (nlHsVar dm_name) visible_inst_tys+              bind = noLoc $ mkTopFunBind Generated fn $+                             [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs]++        ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"+                   (vcat [ppr clas <+> ppr inst_tys,+                          nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))++       ; return (bind, inline_prags) }+  where+    mk_vta :: LHsExpr Name -> Type -> LHsExpr Name+    mk_vta fun ty = noLoc (HsAppType fun (mkEmptyWildCardBndrs $ noLoc $ HsCoreTy ty))+       -- NB: use visible type application+       -- See Note [Default methods in instances]++----------------------+derivBindCtxt :: Id -> Class -> [Type ] -> SDoc+derivBindCtxt sel_id clas tys+   = vcat [ text "When typechecking the code for" <+> quotes (ppr sel_id)+          , nest 2 (text "in a derived instance for"+                    <+> quotes (pprClassPred clas tys) <> colon)+          , nest 2 $ text "To see the code I am typechecking, use -ddump-deriv" ]++warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM ()+warnUnsatisfiedMinimalDefinition mindef+  = do { warn <- woptM Opt_WarnMissingMethods+       ; warnTc (Reason Opt_WarnMissingMethods) warn message+       }+  where+    message = vcat [text "No explicit implementation for"+                   ,nest 2 $ pprBooleanFormulaNice mindef+                   ]++{-+Note [Export helper functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We arrange to export the "helper functions" of an instance declaration,+so that they are not subject to preInlineUnconditionally, even if their+RHS is trivial.  Reason: they are mentioned in the DFunUnfolding of+the dict fun as Ids, not as CoreExprs, so we can't substitute a+non-variable for them.++We could change this by making DFunUnfoldings have CoreExprs, but it+seems a bit simpler this way.++Note [Default methods in instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this++   class Baz v x where+      foo :: x -> x+      foo y = <blah>++   instance Baz Int Int++From the class decl we get++   $dmfoo :: forall v x. Baz v x => x -> x+   $dmfoo y = <blah>++Notice that the type is ambiguous.  So we use Visible Type Application+to disambiguate:++   $dBazIntInt = MkBaz fooIntInt+   fooIntInt = $dmfoo @Int @Int++Lacking VTA we'd get ambiguity errors involving the default method.  This applies+equally to vanilla default methods (Trac #1061) and generic default methods+(Trac #12220).++Historical note: before we had VTA we had to generate+post-type-checked code, which took a lot more code, and didn't work for+generic default methods.++Note [INLINE and default methods]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Default methods need special case.  They are supposed to behave rather like+macros.  For exmample++  class Foo a where+    op1, op2 :: Bool -> a -> a++    {-# INLINE op1 #-}+    op1 b x = op2 (not b) x++  instance Foo Int where+    -- op1 via default method+    op2 b x = <blah>++The instance declaration should behave++   just as if 'op1' had been defined with the+   code, and INLINE pragma, from its original+   definition.++That is, just as if you'd written++  instance Foo Int where+    op2 b x = <blah>++    {-# INLINE op1 #-}+    op1 b x = op2 (not b) x++So for the above example we generate:++  {-# INLINE $dmop1 #-}+  -- $dmop1 has an InlineCompulsory unfolding+  $dmop1 d b x = op2 d (not b) x++  $fFooInt = MkD $cop1 $cop2++  {-# INLINE $cop1 #-}+  $cop1 = $dmop1 $fFooInt++  $cop2 = <blah>++Note carefully:++* We *copy* any INLINE pragma from the default method $dmop1 to the+  instance $cop1.  Otherwise we'll just inline the former in the+  latter and stop, which isn't what the user expected++* Regardless of its pragma, we give the default method an+  unfolding with an InlineCompulsory source. That means+  that it'll be inlined at every use site, notably in+  each instance declaration, such as $cop1.  This inlining+  must happen even though+    a) $dmop1 is not saturated in $cop1+    b) $cop1 itself has an INLINE pragma++  It's vital that $dmop1 *is* inlined in this way, to allow the mutual+  recursion between $fooInt and $cop1 to be broken++* To communicate the need for an InlineCompulsory to the desugarer+  (which makes the Unfoldings), we use the IsDefaultMethod constructor+  in TcSpecPrags.+++************************************************************************+*                                                                      *+        Specialise instance pragmas+*                                                                      *+************************************************************************++Note [SPECIALISE instance pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++   instance (Ix a, Ix b) => Ix (a,b) where+     {-# SPECIALISE instance Ix (Int,Int) #-}+     range (x,y) = ...++We make a specialised version of the dictionary function, AND+specialised versions of each *method*.  Thus we should generate+something like this:++  $dfIxPair :: (Ix a, Ix b) => Ix (a,b)+  {-# DFUN [$crangePair, ...] #-}+  {-# SPECIALISE $dfIxPair :: Ix (Int,Int) #-}+  $dfIxPair da db = Ix ($crangePair da db) (...other methods...)++  $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]+  {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}+  $crange da db = <blah>++The SPECIALISE pragmas are acted upon by the desugarer, which generate++  dii :: Ix Int+  dii = ...++  $s$dfIxPair :: Ix ((Int,Int),(Int,Int))+  {-# DFUN [$crangePair di di, ...] #-}+  $s$dfIxPair = Ix ($crangePair di di) (...)++  {-# RULE forall (d1,d2:Ix Int). $dfIxPair Int Int d1 d2 = $s$dfIxPair #-}++  $s$crangePair :: ((Int,Int),(Int,Int)) -> [(Int,Int)]+  $c$crangePair = ...specialised RHS of $crangePair...++  {-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-}++Note that++  * The specialised dictionary $s$dfIxPair is very much needed, in case we+    call a function that takes a dictionary, but in a context where the+    specialised dictionary can be used.  See Trac #7797.++  * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because+    it still has a DFunUnfolding.  See Note [ClassOp/DFun selection]++  * A call (range ($dfIxPair Int Int d1 d2)) might simplify two ways:+       --> {ClassOp rule for range}     $crangePair Int Int d1 d2+       --> {SPEC rule for $crangePair}  $s$crangePair+    or thus:+       --> {SPEC rule for $dfIxPair}    range $s$dfIxPair+       --> {ClassOpRule for range}      $s$crangePair+    It doesn't matter which way.++  * We want to specialise the RHS of both $dfIxPair and $crangePair,+    but the SAME HsWrapper will do for both!  We can call tcSpecPrag+    just once, and pass the result (in spec_inst_info) to tcMethods.+-}++tcSpecInstPrags :: DFunId -> InstBindings Name+                -> TcM ([Located TcSpecPrag], TcPragEnv)+tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })+  = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $+                            filter isSpecInstLSig uprags+             -- The filter removes the pragmas for methods+       ; return (spec_inst_prags, mkPragEnv uprags binds) }++------------------------------+tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag+tcSpecInst dfun_id prag@(SpecInstSig _ hs_ty)+  = addErrCtxt (spec_ctxt prag) $+    do  { (tyvars, theta, clas, tys) <- tcHsClsInstType SpecInstCtxt hs_ty+        ; let spec_dfun_ty = mkDictFunTy tyvars theta clas tys+        ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty+        ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }+  where+    spec_ctxt prag = hang (text "In the SPECIALISE pragma") 2 (ppr prag)++tcSpecInst _  _ = panic "tcSpecInst"++{-+************************************************************************+*                                                                      *+\subsection{Error messages}+*                                                                      *+************************************************************************+-}++instDeclCtxt1 :: LHsSigType Name -> SDoc+instDeclCtxt1 hs_inst_ty+  = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))++instDeclCtxt2 :: Type -> SDoc+instDeclCtxt2 dfun_ty+  = inst_decl_ctxt (ppr (mkClassPred cls tys))+  where+    (_,_,cls,tys) = tcSplitDFunTy dfun_ty++inst_decl_ctxt :: SDoc -> SDoc+inst_decl_ctxt doc = hang (text "In the instance declaration for")+                        2 (quotes doc)++badBootFamInstDeclErr :: SDoc+badBootFamInstDeclErr+  = text "Illegal family instance in hs-boot file"++notFamily :: TyCon -> SDoc+notFamily tycon+  = vcat [ text "Illegal family instance for" <+> quotes (ppr tycon)+         , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")]++tooFewParmsErr :: Arity -> SDoc+tooFewParmsErr arity+  = text "Family instance has too few parameters; expected" <+>+    ppr arity++assocInClassErr :: Located Name -> SDoc+assocInClassErr name+ = text "Associated type" <+> quotes (ppr name) <+>+   text "must be inside a class instance"++badFamInstDecl :: Located Name -> SDoc+badFamInstDecl tc_name+  = vcat [ text "Illegal family instance for" <+>+           quotes (ppr tc_name)+         , nest 2 (parens $ text "Use TypeFamilies to allow indexed type families") ]++notOpenFamily :: TyCon -> SDoc+notOpenFamily tc+  = text "Illegal instance for closed family" <+> quotes (ppr tc)
+ typecheck/TcInstDcls.hs-boot view
@@ -0,0 +1,16 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++module TcInstDcls ( tcInstDecls1 ) where++import HsSyn+import TcRnTypes+import TcEnv( InstInfo )+import TcDeriv+import Name++-- We need this because of the mutual recursion+-- between TcTyClsDecls and TcInstDcls+tcInstDecls1 :: [LInstDecl Name] -> TcM (TcGblEnv, [InstInfo Name], [DerivInfo])
+ typecheck/TcInteract.hs view
@@ -0,0 +1,2665 @@+{-# LANGUAGE CPP #-}++module TcInteract (+     solveSimpleGivens,   -- Solves [Ct]+     solveSimpleWanteds,  -- Solves Cts++     solveCallStack,      -- for use in TcSimplify+  ) where++#include "HsVersions.h"++import BasicTypes ( SwapFlag(..), isSwapped,+                    infinity, IntWithInf, intGtLimit )+import HsTypes ( HsIPName(..) )+import TcCanonical+import TcFlatten+import TcUnify( canSolveByUnification )+import VarSet+import Type+import Kind( isConstraintKind )+import InstEnv( DFunInstType, lookupInstEnv, instanceDFunId )+import CoAxiom( sfInteractTop, sfInteractInert )++import TcMType (newMetaTyVars)++import Var+import TcType+import Name+import RdrName ( lookupGRE_FieldLabel )+import PrelNames ( knownNatClassName, knownSymbolClassName,+                   typeableClassName, coercibleTyConKey,+                   hasFieldClassName,+                   heqTyConKey, ipClassKey )+import TysWiredIn ( typeNatKind, typeSymbolKind, heqDataCon,+                    coercibleDataCon, constraintKindTyCon )+import TysPrim    ( eqPrimTyCon, eqReprPrimTyCon )+import Id( idType, isNaughtyRecordSelector )+import CoAxiom ( TypeEqn, CoAxiom(..), CoAxBranch(..), fromBranches )+import Class+import TyCon+import DataCon( dataConWrapId )+import FieldLabel+import FunDeps+import FamInst+import FamInstEnv+import Unify ( tcUnifyTyWithTFs )++import TcEvidence+import Outputable++import TcRnTypes+import TcSMonad+import Bag+import MonadUtils ( concatMapM )++import Data.List( partition, foldl', deleteFirstsBy )+import SrcLoc+import VarEnv++import Control.Monad+import Maybes( isJust )+import Pair (Pair(..))+import Unique( hasKey )+import DynFlags+import Util+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe++{-+**********************************************************************+*                                                                    *+*                      Main Interaction Solver                       *+*                                                                    *+**********************************************************************++Note [Basic Simplifier Plan]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+1. Pick an element from the WorkList if there exists one with depth+   less than our context-stack depth.++2. Run it down the 'stage' pipeline. Stages are:+      - canonicalization+      - inert reactions+      - spontaneous reactions+      - top-level intreactions+   Each stage returns a StopOrContinue and may have sideffected+   the inerts or worklist.++   The threading of the stages is as follows:+      - If (Stop) is returned by a stage then we start again from Step 1.+      - If (ContinueWith ct) is returned by a stage, we feed 'ct' on to+        the next stage in the pipeline.+4. If the element has survived (i.e. ContinueWith x) the last stage+   then we add him in the inerts and jump back to Step 1.++If in Step 1 no such element exists, we have exceeded our context-stack+depth and will simply fail.++Note [Unflatten after solving the simple wanteds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We unflatten after solving the wc_simples of an implication, and before attempting+to float. This means that++ * The fsk/fmv flatten-skolems only survive during solveSimples.  We don't+   need to worry about them across successive passes over the constraint tree.+   (E.g. we don't need the old ic_fsk field of an implication.++ * When floating an equality outwards, we don't need to worry about floating its+   associated flattening constraints.++ * Another tricky case becomes easy: Trac #4935+       type instance F True a b = a+       type instance F False a b = b++       [w] F c a b ~ gamma+       (c ~ True) => a ~ gamma+       (c ~ False) => b ~ gamma++   Obviously this is soluble with gamma := F c a b, and unflattening+   will do exactly that after solving the simple constraints and before+   attempting the implications.  Before, when we were not unflattening,+   we had to push Wanted funeqs in as new givens.  Yuk!++   Another example that becomes easy: indexed_types/should_fail/T7786+      [W] BuriedUnder sub k Empty ~ fsk+      [W] Intersect fsk inv ~ s+      [w] xxx[1] ~ s+      [W] forall[2] . (xxx[1] ~ Empty)+                   => Intersect (BuriedUnder sub k Empty) inv ~ Empty++Note [Running plugins on unflattened wanteds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There is an annoying mismatch between solveSimpleGivens and+solveSimpleWanteds, because the latter needs to fiddle with the inert+set, unflatten and zonk the wanteds.  It passes the zonked wanteds+to runTcPluginsWanteds, which produces a replacement set of wanteds,+some additional insolubles and a flag indicating whether to go round+the loop again.  If so, prepareInertsForImplications is used to remove+the previous wanteds (which will still be in the inert set).  Note+that prepareInertsForImplications will discard the insolubles, so we+must keep track of them separately.+-}++solveSimpleGivens :: [Ct] -> TcS ()+solveSimpleGivens givens+  | null givens  -- Shortcut for common case+  = return ()+  | otherwise+  = do { traceTcS "solveSimpleGivens {" (ppr givens)+       ; go givens+       ; traceTcS "End solveSimpleGivens }" empty }+  where+    go givens = do { solveSimples (listToBag givens)+                   ; new_givens <- runTcPluginsGiven+                   ; when (notNull new_givens) $+                     go new_givens }++solveSimpleWanteds :: Cts -> TcS WantedConstraints+-- NB: 'simples' may contain /derived/ equalities, floated+--     out from a nested implication. So don't discard deriveds!+solveSimpleWanteds simples+  = do { traceTcS "solveSimpleWanteds {" (ppr simples)+       ; dflags <- getDynFlags+       ; (n,wc) <- go 1 (solverIterations dflags) (emptyWC { wc_simple = simples })+       ; traceTcS "solveSimpleWanteds end }" $+             vcat [ text "iterations =" <+> ppr n+                  , text "residual =" <+> ppr wc ]+       ; return wc }+  where+    go :: Int -> IntWithInf -> WantedConstraints -> TcS (Int, WantedConstraints)+    go n limit wc+      | n `intGtLimit` limit+      = failTcS (hang (text "solveSimpleWanteds: too many iterations"+                       <+> parens (text "limit =" <+> ppr limit))+                    2 (vcat [ text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit"+                            , text "Simples =" <+> ppr simples+                            , text "WC ="      <+> ppr wc ]))++     | isEmptyBag (wc_simple wc)+     = return (n,wc)++     | otherwise+     = do { -- Solve+            (unif_count, wc1) <- solve_simple_wanteds wc++            -- Run plugins+          ; (rerun_plugin, wc2) <- runTcPluginsWanted wc1+             -- See Note [Running plugins on unflattened wanteds]++          ; if unif_count == 0 && not rerun_plugin+            then return (n, wc2)             -- Done+            else do { traceTcS "solveSimple going round again:" $+                      ppr unif_count $$ ppr rerun_plugin+                    ; go (n+1) limit wc2 } }      -- Loop+++solve_simple_wanteds :: WantedConstraints -> TcS (Int, WantedConstraints)+-- Try solving these constraints+-- Affects the unification state (of course) but not the inert set+solve_simple_wanteds (WC { wc_simple = simples1, wc_insol = insols1, wc_impl = implics1 })+  = nestTcS $+    do { solveSimples simples1+       ; (implics2, tv_eqs, fun_eqs, insols2, others) <- getUnsolvedInerts+       ; (unif_count, unflattened_eqs) <- reportUnifications $+                                          unflatten tv_eqs fun_eqs+            -- See Note [Unflatten after solving the simple wanteds]+       ; return ( unif_count+                , WC { wc_simple = others `andCts` unflattened_eqs+                     , wc_insol  = insols1 `andCts` insols2+                     , wc_impl   = implics1 `unionBags` implics2 }) }++{- Note [The solveSimpleWanteds loop]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Solving a bunch of simple constraints is done in a loop,+(the 'go' loop of 'solveSimpleWanteds'):+  1. Try to solve them; unflattening may lead to improvement that+     was not exploitable during solving+  2. Try the plugin+  3. If step 1 did improvement during unflattening; or if the plugin+     wants to run again, go back to step 1++Non-obviously, improvement can also take place during+the unflattening that takes place in step (1). See TcFlatten,+See Note [Unflattening can force the solver to iterate]+-}++-- The main solver loop implements Note [Basic Simplifier Plan]+---------------------------------------------------------------+solveSimples :: Cts -> TcS ()+-- Returns the final InertSet in TcS+-- Has no effect on work-list or residual-implications+-- The constraints are initially examined in left-to-right order++solveSimples cts+  = {-# SCC "solveSimples" #-}+    do { updWorkListTcS (\wl -> foldrBag extendWorkListCt wl cts)+       ; solve_loop }+  where+    solve_loop+      = {-# SCC "solve_loop" #-}+        do { sel <- selectNextWorkItem+           ; case sel of+              Nothing -> return ()+              Just ct -> do { runSolverPipeline thePipeline ct+                            ; solve_loop } }++-- | Extract the (inert) givens and invoke the plugins on them.+-- Remove solved givens from the inert set and emit insolubles, but+-- return new work produced so that 'solveSimpleGivens' can feed it back+-- into the main solver.+runTcPluginsGiven :: TcS [Ct]+runTcPluginsGiven+  = do { plugins <- getTcPlugins+       ; if null plugins then return [] else+    do { givens <- getInertGivens+       ; if null givens then return [] else+    do { p <- runTcPlugins plugins (givens,[],[])+       ; let (solved_givens, _, _) = pluginSolvedCts p+       ; updInertCans (removeInertCts solved_givens)+       ; mapM_ emitInsoluble (pluginBadCts p)+       ; return (pluginNewCts p) } } }++-- | Given a bag of (flattened, zonked) wanteds, invoke the plugins on+-- them and produce an updated bag of wanteds (possibly with some new+-- work) and a bag of insolubles.  The boolean indicates whether+-- 'solveSimpleWanteds' should feed the updated wanteds back into the+-- main solver.+runTcPluginsWanted :: WantedConstraints -> TcS (Bool, WantedConstraints)+runTcPluginsWanted wc@(WC { wc_simple = simples1, wc_insol = insols1, wc_impl = implics1 })+  | isEmptyBag simples1+  = return (False, wc)+  | otherwise+  = do { plugins <- getTcPlugins+       ; if null plugins then return (False, wc) else++    do { given <- getInertGivens+       ; simples1 <- zonkSimples simples1    -- Plugin requires zonked inputs+       ; let (wanted, derived) = partition isWantedCt (bagToList simples1)+       ; p <- runTcPlugins plugins (given, derived, wanted)+       ; let (_, _,                solved_wanted)   = pluginSolvedCts p+             (_, unsolved_derived, unsolved_wanted) = pluginInputCts p+             new_wanted                             = pluginNewCts p++-- SLPJ: I'm deeply suspicious of this+--       ; updInertCans (removeInertCts $ solved_givens ++ solved_deriveds)++       ; mapM_ setEv solved_wanted+       ; return ( notNull (pluginNewCts p)+                , WC { wc_simple = listToBag new_wanted `andCts` listToBag unsolved_wanted+                                                        `andCts` listToBag unsolved_derived+                     , wc_insol  = listToBag (pluginBadCts p) `andCts` insols1+                     , wc_impl   = implics1 } ) } }+  where+    setEv :: (EvTerm,Ct) -> TcS ()+    setEv (ev,ct) = case ctEvidence ct of+      CtWanted { ctev_dest = dest } -> setWantedEvTerm dest ev+      _ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!"++-- | A triple of (given, derived, wanted) constraints to pass to plugins+type SplitCts  = ([Ct], [Ct], [Ct])++-- | A solved triple of constraints, with evidence for wanteds+type SolvedCts = ([Ct], [Ct], [(EvTerm,Ct)])++-- | Represents collections of constraints generated by typechecker+-- plugins+data TcPluginProgress = TcPluginProgress+    { pluginInputCts  :: SplitCts+      -- ^ Original inputs to the plugins with solved/bad constraints+      -- removed, but otherwise unmodified+    , pluginSolvedCts :: SolvedCts+      -- ^ Constraints solved by plugins+    , pluginBadCts    :: [Ct]+      -- ^ Constraints reported as insoluble by plugins+    , pluginNewCts    :: [Ct]+      -- ^ New constraints emitted by plugins+    }++getTcPlugins :: TcS [TcPluginSolver]+getTcPlugins = do { tcg_env <- getGblEnv; return (tcg_tc_plugins tcg_env) }++-- | Starting from a triple of (given, derived, wanted) constraints,+-- invoke each of the typechecker plugins in turn and return+--+--  * the remaining unmodified constraints,+--  * constraints that have been solved,+--  * constraints that are insoluble, and+--  * new work.+--+-- Note that new work generated by one plugin will not be seen by+-- other plugins on this pass (but the main constraint solver will be+-- re-invoked and they will see it later).  There is no check that new+-- work differs from the original constraints supplied to the plugin:+-- the plugin itself should perform this check if necessary.+runTcPlugins :: [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress+runTcPlugins plugins all_cts+  = foldM do_plugin initialProgress plugins+  where+    do_plugin :: TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress+    do_plugin p solver = do+        result <- runTcPluginTcS (uncurry3 solver (pluginInputCts p))+        return $ progress p result++    progress :: TcPluginProgress -> TcPluginResult -> TcPluginProgress+    progress p (TcPluginContradiction bad_cts) =+       p { pluginInputCts = discard bad_cts (pluginInputCts p)+         , pluginBadCts   = bad_cts ++ pluginBadCts p+         }+    progress p (TcPluginOk solved_cts new_cts) =+      p { pluginInputCts  = discard (map snd solved_cts) (pluginInputCts p)+        , pluginSolvedCts = add solved_cts (pluginSolvedCts p)+        , pluginNewCts    = new_cts ++ pluginNewCts p+        }++    initialProgress = TcPluginProgress all_cts ([], [], []) [] []++    discard :: [Ct] -> SplitCts -> SplitCts+    discard cts (xs, ys, zs) =+        (xs `without` cts, ys `without` cts, zs `without` cts)++    without :: [Ct] -> [Ct] -> [Ct]+    without = deleteFirstsBy eqCt++    eqCt :: Ct -> Ct -> Bool+    eqCt c c' = ctFlavour c == ctFlavour c'+             && ctPred c `tcEqType` ctPred c'++    add :: [(EvTerm,Ct)] -> SolvedCts -> SolvedCts+    add xs scs = foldl' addOne scs xs++    addOne :: SolvedCts -> (EvTerm,Ct) -> SolvedCts+    addOne (givens, deriveds, wanteds) (ev,ct) = case ctEvidence ct of+      CtGiven  {} -> (ct:givens, deriveds, wanteds)+      CtDerived{} -> (givens, ct:deriveds, wanteds)+      CtWanted {} -> (givens, deriveds, (ev,ct):wanteds)+++type WorkItem = Ct+type SimplifierStage = WorkItem -> TcS (StopOrContinue Ct)++runSolverPipeline :: [(String,SimplifierStage)] -- The pipeline+                  -> WorkItem                   -- The work item+                  -> TcS ()+-- Run this item down the pipeline, leaving behind new work and inerts+runSolverPipeline pipeline workItem+  = do { wl <- getWorkList+       ; inerts <- getTcSInerts+       ; traceTcS "----------------------------- " empty+       ; traceTcS "Start solver pipeline {" $+                  vcat [ text "work item =" <+> ppr workItem+                       , text "inerts =" <+> ppr inerts+                       , text "rest of worklist =" <+> ppr wl ]++       ; bumpStepCountTcS    -- One step for each constraint processed+       ; final_res  <- run_pipeline pipeline (ContinueWith workItem)++       ; case final_res of+           Stop ev s       -> do { traceFireTcS ev s+                                 ; traceTcS "End solver pipeline (discharged) }" empty+                                 ; return () }+           ContinueWith ct -> do { addInertCan ct+                                 ; traceFireTcS (ctEvidence ct) (text "Kept as inert")+                                 ; traceTcS "End solver pipeline (kept as inert) }" $+                                            (text "final_item =" <+> ppr ct) }+       }+  where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue Ct+                     -> TcS (StopOrContinue Ct)+        run_pipeline [] res        = return res+        run_pipeline _ (Stop ev s) = return (Stop ev s)+        run_pipeline ((stg_name,stg):stgs) (ContinueWith ct)+          = do { traceTcS ("runStage " ++ stg_name ++ " {")+                          (text "workitem   = " <+> ppr ct)+               ; res <- stg ct+               ; traceTcS ("end stage " ++ stg_name ++ " }") empty+               ; run_pipeline stgs res }++{-+Example 1:+  Inert:   {c ~ d, F a ~ t, b ~ Int, a ~ ty} (all given)+  Reagent: a ~ [b] (given)++React with (c~d)     ==> IR (ContinueWith (a~[b]))  True    []+React with (F a ~ t) ==> IR (ContinueWith (a~[b]))  False   [F [b] ~ t]+React with (b ~ Int) ==> IR (ContinueWith (a~[Int]) True    []++Example 2:+  Inert:  {c ~w d, F a ~g t, b ~w Int, a ~w ty}+  Reagent: a ~w [b]++React with (c ~w d)   ==> IR (ContinueWith (a~[b]))  True    []+React with (F a ~g t) ==> IR (ContinueWith (a~[b]))  True    []    (can't rewrite given with wanted!)+etc.++Example 3:+  Inert:  {a ~ Int, F Int ~ b} (given)+  Reagent: F a ~ b (wanted)++React with (a ~ Int)   ==> IR (ContinueWith (F Int ~ b)) True []+React with (F Int ~ b) ==> IR Stop True []    -- after substituting we re-canonicalize and get nothing+-}++thePipeline :: [(String,SimplifierStage)]+thePipeline = [ ("canonicalization",        TcCanonical.canonicalize)+              , ("interact with inerts",    interactWithInertsStage)+              , ("top-level reactions",     topReactionsStage) ]++{-+*********************************************************************************+*                                                                               *+                       The interact-with-inert Stage+*                                                                               *+*********************************************************************************++Note [The Solver Invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We always add Givens first.  So you might think that the solver has+the invariant++   If the work-item is Given,+   then the inert item must Given++But this isn't quite true.  Suppose we have,+    c1: [W] beta ~ [alpha], c2 : [W] blah, c3 :[W] alpha ~ Int+After processing the first two, we get+     c1: [G] beta ~ [alpha], c2 : [W] blah+Now, c3 does not interact with the the given c1, so when we spontaneously+solve c3, we must re-react it with the inert set.  So we can attempt a+reaction between inert c2 [W] and work-item c3 [G].++It *is* true that [Solver Invariant]+   If the work-item is Given,+   AND there is a reaction+   then the inert item must Given+or, equivalently,+   If the work-item is Given,+   and the inert item is Wanted/Derived+   then there is no reaction+-}++-- Interaction result of  WorkItem <~> Ct++type StopNowFlag = Bool    -- True <=> stop after this interaction++interactWithInertsStage :: WorkItem -> TcS (StopOrContinue Ct)+-- Precondition: if the workitem is a CTyEqCan then it will not be able to+-- react with anything at this stage.++interactWithInertsStage wi+  = do { inerts <- getTcSInerts+       ; let ics = inert_cans inerts+       ; case wi of+             CTyEqCan    {} -> interactTyVarEq ics wi+             CFunEqCan   {} -> interactFunEq   ics wi+             CIrredEvCan {} -> interactIrred   ics wi+             CDictCan    {} -> interactDict    ics wi+             _ -> pprPanic "interactWithInerts" (ppr wi) }+                -- CHoleCan are put straight into inert_frozen, so never get here+                -- CNonCanonical have been canonicalised++data InteractResult+   = IRKeep      -- Keep the existing inert constraint in the inert set+   | IRReplace   -- Replace the existing inert constraint with the work item+   | IRDelete    -- Delete the existing inert constraint from the inert set++instance Outputable InteractResult where+  ppr IRKeep    = text "keep"+  ppr IRReplace = text "replace"+  ppr IRDelete  = text "delete"++solveOneFromTheOther :: CtEvidence  -- Inert+                     -> CtEvidence  -- WorkItem+                     -> TcS (InteractResult, StopNowFlag)+-- Preconditions:+-- 1) inert and work item represent evidence for the /same/ predicate+-- 2) ip/class/irred constraints only; not used for equalities+solveOneFromTheOther ev_i ev_w+  | isDerived ev_w         -- Work item is Derived; just discard it+  = return (IRKeep, True)++  | isDerived ev_i            -- The inert item is Derived, we can just throw it away,+  = return (IRDelete, False)  -- The ev_w is inert wrt earlier inert-set items,+                              -- so it's safe to continue on from this point++  | CtWanted { ctev_loc = loc_w } <- ev_w+  , prohibitedSuperClassSolve (ctEvLoc ev_i) loc_w+  = return (IRDelete, False)++  | CtWanted { ctev_dest = dest } <- ev_w+       -- Inert is Given or Wanted+  = do { setWantedEvTerm dest (ctEvTerm ev_i)+       ; return (IRKeep, True) }++  | CtWanted { ctev_loc = loc_i } <- ev_i   -- Work item is Given+  , prohibitedSuperClassSolve (ctEvLoc ev_w) loc_i+  = return (IRKeep, False)  -- Just discard the un-usable Given+                            -- This never actually happens because+                            -- Givens get processed first++  | CtWanted { ctev_dest = dest } <- ev_i+  = do { setWantedEvTerm dest (ctEvTerm ev_w)+       ; return (IRReplace, True) }++  -- So they are both Given+  -- See Note [Replacement vs keeping]+  | lvl_i == lvl_w+  = do { binds <- getTcEvBindsMap+       ; return (same_level_strategy binds, True) }++  | otherwise   -- Both are Given, levels differ+  = return (different_level_strategy, True)+  where+     pred  = ctEvPred ev_i+     loc_i = ctEvLoc ev_i+     loc_w = ctEvLoc ev_w+     lvl_i = ctLocLevel loc_i+     lvl_w = ctLocLevel loc_w++     different_level_strategy+       | isIPPred pred, lvl_w > lvl_i = IRReplace+       | lvl_w < lvl_i                = IRReplace+       | otherwise                    = IRKeep++     same_level_strategy binds        -- Both Given+       | GivenOrigin (InstSC s_i) <- ctLocOrigin loc_i+       = case ctLocOrigin loc_w of+            GivenOrigin (InstSC s_w) | s_w < s_i -> IRReplace+                                     | otherwise -> IRKeep+            _                                    -> IRReplace++       | GivenOrigin (InstSC {}) <- ctLocOrigin loc_w+       = IRKeep++       | has_binding binds ev_w+       , not (has_binding binds ev_i)+       = IRReplace++       | otherwise = IRKeep++     has_binding binds ev = isJust (lookupEvBind binds (ctEvId ev))++{-+Note [Replacement vs keeping]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we have two Given constraints both of type (C tys), say, which should+we keep?  More subtle than you might think!++  * Constraints come from different levels (different_level_strategy)++      - For implicit parameters we want to keep the innermost (deepest)+        one, so that it overrides the outer one.+        See Note [Shadowing of Implicit Parameters]++      - For everything else, we want to keep the outermost one.  Reason: that+        makes it more likely that the inner one will turn out to be unused,+        and can be reported as redundant.  See Note [Tracking redundant constraints]+        in TcSimplify.++        It transpires that using the outermost one is reponsible for an+        8% performance improvement in nofib cryptarithm2, compared to+        just rolling the dice.  I didn't investigate why.++  * Constraints coming from the same level (i.e. same implication)++       - Always get rid of InstSC ones if possible, since they are less+         useful for solving.  If both are InstSC, choose the one with+         the smallest TypeSize+         See Note [Solving superclass constraints] in TcInstDcls++       - Keep the one that has a non-trivial evidence binding.+            Example:  f :: (Eq a, Ord a) => blah+            then we may find [G] d3 :: Eq a+                             [G] d2 :: Eq a+              with bindings  d3 = sc_sel (d1::Ord a)+            We want to discard d2 in favour of the superclass selection from+            the Ord dictionary.+         Why? See Note [Tracking redundant constraints] in TcSimplify again.++  * Finally, when there is still a choice, use IRKeep rather than+    IRReplace, to avoid unnecessary munging of the inert set.++Doing the depth-check for implicit parameters, rather than making the work item+always override, is important.  Consider++    data T a where { T1 :: (?x::Int) => T Int; T2 :: T a }++    f :: (?x::a) => T a -> Int+    f T1 = ?x+    f T2 = 3++We have a [G] (?x::a) in the inert set, and at the pattern match on T1 we add+two new givens in the work-list:  [G] (?x::Int)+                                  [G] (a ~ Int)+Now consider these steps+  - process a~Int, kicking out (?x::a)+  - process (?x::Int), the inner given, adding to inert set+  - process (?x::a), the outer given, overriding the inner given+Wrong!  The depth-check ensures that the inner implicit parameter wins.+(Actually I think that the order in which the work-list is processed means+that this chain of events won't happen, but that's very fragile.)++*********************************************************************************+*                                                                               *+                   interactIrred+*                                                                               *+*********************************************************************************+-}++-- Two pieces of irreducible evidence: if their types are *exactly identical*+-- we can rewrite them. We can never improve using this:+-- if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not+-- mean that (ty1 ~ ty2)+interactIrred :: InertCans -> Ct -> TcS (StopOrContinue Ct)++interactIrred inerts workItem@(CIrredEvCan { cc_ev = ev_w })+  | let pred = ctEvPred ev_w+        (matching_irreds, others)+          = partitionBag (\ct -> ctPred ct `tcEqTypeNoKindCheck` pred)+                         (inert_irreds inerts)+  , (ct_i : rest) <- bagToList matching_irreds+  , let ctev_i = ctEvidence ct_i+  = ASSERT( null rest )+    do { (inert_effect, stop_now) <- solveOneFromTheOther ctev_i ev_w+       ; case inert_effect of+            IRKeep    -> return ()+            IRDelete  -> updInertIrreds (\_ -> others)+            IRReplace -> updInertIrreds (\_ -> others `snocCts` workItem)+                         -- These const upd's assume that solveOneFromTheOther+                         -- has no side effects on InertCans+       ; if stop_now then+            return (Stop ev_w (text "Irred equal" <+> parens (ppr inert_effect)))+       ; else+            continueWith workItem }++  | otherwise+  = continueWith workItem++interactIrred _ wi = pprPanic "interactIrred" (ppr wi)++{-+*********************************************************************************+*                                                                               *+                   interactDict+*                                                                               *+*********************************************************************************++Note [Solving from instances when interacting Dicts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we interact a [W] constraint with a [G] constraint that solves it, there is+a possibility that we could produce better code if instead we solved from a+top-level instance declaration (See #12791, #5835). For example:++    class M a b where m :: a -> b++    type C a b = (Num a, M a b)++    f :: C Int b => b -> Int -> Int+    f _ x = x + 1++The body of `f` requires a [W] `Num Int` instance. We could solve this+constraint from the givens because we have `C Int b` and that provides us a+solution for `Num Int`. This would let us produce core like the following+(with -O2):++    f :: forall b. C Int b => b -> Int -> Int+    f = \ (@ b) ($d(%,%) :: C Int b) _ (eta1 :: Int) ->+        + @ Int+          (GHC.Classes.$p1(%,%) @ (Num Int) @ (M Int b) $d(%,%))+          eta1+          A.f1++This is bad! We could do much better if we solved [W] `Num Int` directly from+the instance that we have in scope:++    f :: forall b. C Int b => b -> Int -> Int+    f = \ (@ b) _ _ (x :: Int) ->+        case x of { GHC.Types.I# x1 -> GHC.Types.I# (GHC.Prim.+# x1 1#) }++However, there is a reason why the solver does not simply try to solve such+constraints with top-level instances. If the solver finds a relevant instance+declaration in scope, that instance may require a context that can't be solved+for. A good example of this is:++    f :: Ord [a] => ...+    f x = ..Need Eq [a]...++If we have instance `Eq a => Eq [a]` in scope and we tried to use it, we would+be left with the obligation to solve the constraint Eq a, which we cannot. So we+must be conservative in our attempt to use an instance declaration to solve the+[W] constraint we're interested in. Our rule is that we try to solve all of the+instance's subgoals recursively all at once. Precisely: We only attempt to+solve constraints of the form `C1, ... Cm => C t1 ... t n`, where all the Ci are+themselves class constraints of the form `C1', ... Cm' => C' t1' ... tn'` and we+only succeed if the entire tree of constraints is solvable from instances.++An example that succeeds:++    class Eq a => C a b | b -> a where+      m :: b -> a++    f :: C [Int] b => b -> Bool+    f x = m x == []++We solve for `Eq [Int]`, which requires `Eq Int`, which we also have. This+produces the following core:++    f :: forall b. C [Int] b => b -> Bool+    f = \ (@ b) ($dC :: C [Int] b) (x :: b) ->+        GHC.Classes.$fEq[]_$s$c==+          (m @ [Int] @ b $dC x) (GHC.Types.[] @ Int)++An example that fails:++    class Eq a => C a b | b -> a where+      m :: b -> a++    f :: C [a] b => b -> Bool+    f x = m x == []++Which, because solving `Eq [a]` demands `Eq a` which we cannot solve, produces:++    f :: forall a b. C [a] b => b -> Bool+    f = \ (@ a) (@ b) ($dC :: C [a] b) (eta :: b) ->+        ==+          @ [a]+          (A.$p1C @ [a] @ b $dC)+          (m @ [a] @ b $dC eta)+          (GHC.Types.[] @ a)++This optimization relies on coherence of dictionaries to be correct. When we+cannot assume coherence because of IncoherentInstances then this optimization+can change the behavior of the user's code.++The following four modules produce a program whose output would change depending+on whether we apply this optimization when IncoherentInstances is in effect:++#########+    {-# LANGUAGE MultiParamTypeClasses #-}+    module A where++    class A a where+      int :: a -> Int++    class A a => C a b where+      m :: b -> a -> a++#########+    {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+    module B where++    import A++    instance A a where+      int _ = 1++    instance C a [b] where+      m _ = id++#########+    {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}+    {-# LANGUAGE IncoherentInstances #-}+    module C where++    import A++    instance A Int where+      int _ = 2++    instance C Int [Int] where+      m _ = id++    intC :: C Int a => a -> Int -> Int+    intC _ x = int x++#########+    module Main where++    import A+    import B+    import C++    main :: IO ()+    main = print (intC [] (0::Int))++The output of `main` if we avoid the optimization under the effect of+IncoherentInstances is `1`. If we were to do the optimization, the output of+`main` would be `2`.++It is important to emphasize that failure means that we don't produce more+efficient code, NOT that we fail to typecheck at all! This is purely an+an optimization: exactly the same programs should typecheck with or without this+procedure.++-}++interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct)+interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys })+  | isWanted ev_w+  , Just ip_name      <- isCallStackPred (ctPred workItem)+  , OccurrenceOf func <- ctLocOrigin (ctEvLoc ev_w)+  -- If we're given a CallStack constraint that arose from a function+  -- call, we need to push the current call-site onto the stack instead+  -- of solving it directly from a given.+  -- See Note [Overview of implicit CallStacks]+  = do { let loc = ctEvLoc ev_w++         -- First we emit a new constraint that will capture the+         -- given CallStack.+       ; let new_loc      = setCtLocOrigin loc (IPOccOrigin (HsIPName ip_name))+                            -- We change the origin to IPOccOrigin so+                            -- this rule does not fire again.+                            -- See Note [Overview of implicit CallStacks]++       ; mb_new <- newWantedEvVar new_loc (ctEvPred ev_w)+       ; emitWorkNC (freshGoals [mb_new])++         -- Then we solve the wanted by pushing the call-site onto the+         -- newly emitted CallStack.+       ; let ev_cs = EvCsPushCall func (ctLocSpan loc) (getEvTerm mb_new)+       ; solveCallStack ev_w ev_cs+       ; stopWith ev_w "Wanted CallStack IP" }+  | Just ctev_i <- lookupInertDict inerts cls tys+  = do+  { dflags <- getDynFlags+  -- See Note [Solving from instances when interacting Dicts]+  ; try_inst_res <- trySolveFromInstance dflags ev_w ctev_i+  ; case try_inst_res of+      Just evs -> do+        { flip mapM_ evs $ \(ev_t, ct_ev, cls, typ) -> do+          { setWantedEvBind (ctEvId ct_ev) ev_t+          ; addSolvedDict ct_ev cls typ }+        ; stopWith ev_w "interactDict/solved from instance" }+      -- We were unable to solve the [W] constraint from in-scope instances so+      -- we solve it from the solution in the inerts we just retrieved.+      Nothing ->  do+        { (inert_effect, stop_now) <- solveOneFromTheOther ctev_i ev_w+        ; case inert_effect of+            IRKeep    -> return ()+            IRDelete  -> updInertDicts $ \ ds -> delDict ds cls tys+            IRReplace -> updInertDicts $ \ ds -> addDict ds cls tys workItem+        ; if stop_now then+            return $ Stop ev_w (text "Dict equal" <+> parens (ppr inert_effect))+          else+            continueWith workItem } }+  | cls `hasKey` ipClassKey+  , isGiven ev_w+  = interactGivenIP inerts workItem++  | otherwise+  = do { addFunDepWork inerts ev_w cls+       ; continueWith workItem  }++interactDict _ wi = pprPanic "interactDict" (ppr wi)++-- See Note [Solving from instances when interacting Dicts]+trySolveFromInstance :: DynFlags+                     -> CtEvidence -- Work item+                     -> CtEvidence -- Inert we want to try to replace+                     -> TcS (Maybe [(EvTerm, CtEvidence, Class, [TcPredType])])+                     -- Everything we need to bind a solution for the work item+                     -- and add the solved Dict to the cache in the main solver.+trySolveFromInstance dflags ev_w ctev_i+  | isWanted ev_w+ && isGiven ctev_i+ -- We are about to solve a [W] constraint from a [G] constraint. We take+ -- a moment to see if we can get a better solution using an instance.+ -- Note that we only do this for the sake of performance. Exactly the same+ -- programs should typecheck regardless of whether we take this step or+ -- not. See Note [Solving from instances when interacting Dicts]+ && not (xopt LangExt.IncoherentInstances dflags)+ -- If IncoherentInstances is on then we cannot rely on coherence of proofs+ -- in order to justify this optimization: The proof provided by the+ -- [G] constraint's superclass may be different from the top-level proof.+ && gopt Opt_SolveConstantDicts dflags+ -- Enabled by the -fsolve-constant-dicts flag+  = runMaybeT $ try_solve_from_instance emptyDictMap ev_w++  | otherwise = return Nothing+  where+    -- This `CtLoc` is used only to check the well-staged condition of any+    -- candidate DFun. Our subgoals all have the same stage as our root+    -- [W] constraint so it is safe to use this while solving them.+    loc_w = ctEvLoc ev_w++    -- Use a local cache of solved dicts while emitting EvVars for new work+    -- We bail out of the entire computation if we need to emit an EvVar for+    -- a subgoal that isn't a ClassPred.+    new_wanted_cached :: DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew+    new_wanted_cached cache pty+      | ClassPred cls tys <- classifyPredType pty+      = lift $ case findDict cache cls tys of+          Just ctev -> return $ Cached (ctEvTerm ctev)+          Nothing -> Fresh <$> newWantedNC loc_w pty+      | otherwise = mzero++    -- MaybeT manages early failure if we find a subgoal that cannot be solved+    -- from instances.+    -- Why do we need a local cache here?+    -- 1. We can't use the global cache because it contains givens that+    --    we specifically don't want to use to solve.+    -- 2. We need to be able to handle recursive super classes. The+    --    cache ensures that we remember what we have already tried to+    --    solve to avoid looping.+    try_solve_from_instance+      :: DictMap CtEvidence -> CtEvidence+      -> MaybeT TcS [(EvTerm, CtEvidence, Class, [TcPredType])]+    try_solve_from_instance cache ev+      | ClassPred cls tys <- classifyPredType (ctEvPred ev) = do+      -- It is important that we add our goal to the cache before we solve!+      -- Otherwise we may end up in a loop while solving recursive dictionaries.+      { let cache' = addDict cache cls tys ev+      ; inst_res <- lift $ match_class_inst dflags cls tys loc_w+      ; case inst_res of+          GenInst { lir_new_theta = preds+                  , lir_mk_ev = mk_ev+                  , lir_safe_over = safeOverlap }+            | safeOverlap -> do+              -- emit work for subgoals but use our local cache so that we can+              -- solve recursive dictionaries.+              { evc_vs <- mapM (new_wanted_cached cache') preds+              ; subgoalBinds <- mapM (try_solve_from_instance cache')+                                     (freshGoals evc_vs)+              ; return $ (mk_ev (map getEvTerm evc_vs), ev, cls, preds)+                       : concat subgoalBinds }++            | otherwise -> mzero+          _ -> mzero }+      | otherwise = mzero++addFunDepWork :: InertCans -> CtEvidence -> Class -> TcS ()+-- Add derived constraints from type-class functional dependencies.+addFunDepWork inerts work_ev cls+  | isImprovable work_ev+  = mapBagM_ add_fds (findDictsByClass (inert_dicts inerts) cls)+               -- No need to check flavour; fundeps work between+               -- any pair of constraints, regardless of flavour+               -- Importantly we don't throw workitem back in the+               -- worklist because this can cause loops (see #5236)+  | otherwise+  = return ()+  where+    work_pred = ctEvPred work_ev+    work_loc  = ctEvLoc work_ev++    add_fds inert_ct+      | isImprovable inert_ev+      = emitFunDepDeriveds $+        improveFromAnother derived_loc inert_pred work_pred+               -- We don't really rewrite tys2, see below _rewritten_tys2, so that's ok+               -- NB: We do create FDs for given to report insoluble equations that arise+               -- from pairs of Givens, and also because of floating when we approximate+               -- implications. The relevant test is: typecheck/should_fail/FDsFromGivens.hs+      | otherwise+      = return ()+      where+        inert_ev   = ctEvidence inert_ct+        inert_pred = ctEvPred inert_ev+        inert_loc  = ctEvLoc inert_ev+        derived_loc = work_loc { ctl_depth  = ctl_depth work_loc `maxSubGoalDepth`+                                              ctl_depth inert_loc+                               , ctl_origin = FunDepOrigin1 work_pred  work_loc+                                                            inert_pred inert_loc }++{-+**********************************************************************+*                                                                    *+                   Implicit parameters+*                                                                    *+**********************************************************************+-}++interactGivenIP :: InertCans -> Ct -> TcS (StopOrContinue Ct)+-- Work item is Given (?x:ty)+-- See Note [Shadowing of Implicit Parameters]+interactGivenIP inerts workItem@(CDictCan { cc_ev = ev, cc_class = cls+                                          , cc_tyargs = tys@(ip_str:_) })+  = do { updInertCans $ \cans -> cans { inert_dicts = addDict filtered_dicts cls tys workItem }+       ; stopWith ev "Given IP" }+  where+    dicts           = inert_dicts inerts+    ip_dicts        = findDictsByClass dicts cls+    other_ip_dicts  = filterBag (not . is_this_ip) ip_dicts+    filtered_dicts  = addDictsByClass dicts cls other_ip_dicts++    -- Pick out any Given constraints for the same implicit parameter+    is_this_ip (CDictCan { cc_ev = ev, cc_tyargs = ip_str':_ })+       = isGiven ev && ip_str `tcEqType` ip_str'+    is_this_ip _ = False++interactGivenIP _ wi = pprPanic "interactGivenIP" (ppr wi)+++{- Note [Shadowing of Implicit Parameters]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following example:++f :: (?x :: Char) => Char+f = let ?x = 'a' in ?x++The "let ?x = ..." generates an implication constraint of the form:++?x :: Char => ?x :: Char++Furthermore, the signature for `f` also generates an implication+constraint, so we end up with the following nested implication:++?x :: Char => (?x :: Char => ?x :: Char)++Note that the wanted (?x :: Char) constraint may be solved in+two incompatible ways:  either by using the parameter from the+signature, or by using the local definition.  Our intention is+that the local definition should "shadow" the parameter of the+signature, and we implement this as follows: when we add a new+*given* implicit parameter to the inert set, it replaces any existing+givens for the same implicit parameter.++Similarly, consider+   f :: (?x::a) => Bool -> a++   g v = let ?x::Int = 3+         in (f v, let ?x::Bool = True in f v)++This should probably be well typed, with+   g :: Bool -> (Int, Bool)++So the inner binding for ?x::Bool *overrides* the outer one.++All this works for the normal cases but it has an odd side effect in+some pathological programs like this:+-- This is accepted, the second parameter shadows+f1 :: (?x :: Int, ?x :: Char) => Char+f1 = ?x++-- This is rejected, the second parameter shadows+f2 :: (?x :: Int, ?x :: Char) => Int+f2 = ?x++Both of these are actually wrong:  when we try to use either one,+we'll get two incompatible wnated constraints (?x :: Int, ?x :: Char),+which would lead to an error.++I can think of two ways to fix this:++  1. Simply disallow multiple constraints for the same implicit+    parameter---this is never useful, and it can be detected completely+    syntactically.++  2. Move the shadowing machinery to the location where we nest+     implications, and add some code here that will produce an+     error if we get multiple givens for the same implicit parameter.+++**********************************************************************+*                                                                    *+                   interactFunEq+*                                                                    *+**********************************************************************+-}++interactFunEq :: InertCans -> Ct -> TcS (StopOrContinue Ct)+-- Try interacting the work item with the inert set+interactFunEq inerts work_item@(CFunEqCan { cc_ev = ev, cc_fun = tc+                                          , cc_tyargs = args, cc_fsk = fsk })+  | Just inert_ct@(CFunEqCan { cc_ev = ev_i+                             , cc_fsk = fsk_i })+         <- findFunEq (inert_funeqs inerts) tc args+  , pr@(swap_flag, upgrade_flag) <- ev_i `funEqCanDischarge` ev+  = do { traceTcS "reactFunEq (rewrite inert item):" $+         vcat [ text "work_item =" <+> ppr work_item+              , text "inertItem=" <+> ppr ev_i+              , text "(swap_flag, upgrade)" <+> ppr pr ]+       ; if isSwapped swap_flag+         then do {   -- Rewrite inert using work-item+                   let work_item' | upgrade_flag = upgradeWanted work_item+                                  | otherwise    = work_item+                 ; updInertFunEqs $ \ feqs -> insertFunEq feqs tc args work_item'+                      -- Do the updInertFunEqs before the reactFunEq, so that+                      -- we don't kick out the inertItem as well as consuming it!+                 ; reactFunEq ev fsk ev_i fsk_i+                 ; stopWith ev "Work item rewrites inert" }+         else do {   -- Rewrite work-item using inert+                 ; when upgrade_flag $+                   updInertFunEqs $ \ feqs -> insertFunEq feqs tc args+                                                 (upgradeWanted inert_ct)+                 ; reactFunEq ev_i fsk_i ev fsk+                 ; stopWith ev "Inert rewrites work item" } }++  | otherwise   -- Try improvement+  = do { improveLocalFunEqs ev inerts tc args fsk+       ; continueWith work_item }++interactFunEq _ work_item = pprPanic "interactFunEq" (ppr work_item)++upgradeWanted :: Ct -> Ct+-- We are combining a [W] F tys ~ fmv1 and [D] F tys ~ fmv2+-- so upgrade the [W] to [WD] before putting it in the inert set+upgradeWanted ct = ct { cc_ev = upgrade_ev (cc_ev ct) }+  where+    upgrade_ev ev = ASSERT2( isWanted ev, ppr ct )+                    ev { ctev_nosh = WDeriv }++improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcTyVar+                   -> TcS ()+-- Generate derived improvement equalities, by comparing+-- the current work item with inert CFunEqs+-- E.g.   x + y ~ z,   x + y' ~ z   =>   [D] y ~ y'+--+-- See Note [FunDep and implicit parameter reactions]+improveLocalFunEqs work_ev inerts fam_tc args fsk+  | isGiven work_ev -- See Note [No FunEq improvement for Givens]+    || not (isImprovable work_ev)+  = return ()++  | not (null improvement_eqns)+  = do { traceTcS "interactFunEq improvements: " $+         vcat [ text "Eqns:" <+> ppr improvement_eqns+              , text "Candidates:" <+> ppr funeqs_for_tc+              , text "Inert eqs:" <+> ppr ieqs ]+       ; emitFunDepDeriveds improvement_eqns }++  | otherwise+  = return ()++  where+    ieqs          = inert_eqs inerts+    funeqs        = inert_funeqs inerts+    funeqs_for_tc = findFunEqsByTyCon funeqs fam_tc+    rhs           = lookupFlattenTyVar ieqs fsk+    work_loc      = ctEvLoc work_ev+    work_pred     = ctEvPred work_ev+    fam_inj_info  = familyTyConInjectivityInfo fam_tc++    --------------------+    improvement_eqns :: [FunDepEqn CtLoc]+    improvement_eqns+      | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc+      =    -- Try built-in families, notably for arithmethic+         concatMap (do_one_built_in ops) funeqs_for_tc++      | Injective injective_args <- fam_inj_info+      =    -- Try improvement from type families with injectivity annotations+        concatMap (do_one_injective injective_args) funeqs_for_tc++      | otherwise+      = []++    --------------------+    do_one_built_in ops (CFunEqCan { cc_tyargs = iargs, cc_fsk = ifsk, cc_ev = inert_ev })+      = mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs+                                             (lookupFlattenTyVar ieqs ifsk))++    do_one_built_in _ _ = pprPanic "interactFunEq 1" (ppr fam_tc)++    --------------------+    -- See Note [Type inference for type families with injectivity]+    do_one_injective inj_args (CFunEqCan { cc_tyargs = inert_args+                                         , cc_fsk = ifsk, cc_ev = inert_ev })+      | isImprovable inert_ev+      , rhs `tcEqType` lookupFlattenTyVar ieqs ifsk+      = mk_fd_eqns inert_ev $+            [ Pair arg iarg+            | (arg, iarg, True) <- zip3 args inert_args inj_args ]+      | otherwise+      = []++    do_one_injective _ _ = pprPanic "interactFunEq 2" (ppr fam_tc)++    --------------------+    mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn CtLoc]+    mk_fd_eqns inert_ev eqns+      | null eqns  = []+      | otherwise  = [ FDEqn { fd_qtvs = [], fd_eqs = eqns+                             , fd_pred1 = work_pred+                             , fd_pred2 = ctEvPred inert_ev+                             , fd_loc   = loc } ]+      where+        inert_loc = ctEvLoc inert_ev+        loc = inert_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth`+                                      ctl_depth work_loc }++-------------+reactFunEq :: CtEvidence -> TcTyVar    -- From this  :: F args1 ~ fsk1+           -> CtEvidence -> TcTyVar    -- Solve this :: F args2 ~ fsk2+           -> TcS ()+reactFunEq from_this fsk1 solve_this fsk2+  | CtGiven { ctev_evar = evar, ctev_loc = loc } <- solve_this+  = do { let fsk_eq_co = mkTcSymCo (mkTcCoVarCo evar) `mkTcTransCo`+                         ctEvCoercion from_this+                         -- :: fsk2 ~ fsk1+             fsk_eq_pred = mkTcEqPredLikeEv solve_this+                             (mkTyVarTy fsk2) (mkTyVarTy fsk1)++       ; new_ev <- newGivenEvVar loc (fsk_eq_pred, EvCoercion fsk_eq_co)+       ; emitWorkNC [new_ev] }++  | CtDerived { ctev_loc = loc } <- solve_this+  = do { traceTcS "reactFunEq (Derived)" (ppr from_this $$ ppr fsk1 $$+                                          ppr solve_this $$ ppr fsk2)+       ; emitNewDerivedEq loc Nominal (mkTyVarTy fsk1) (mkTyVarTy fsk2) }+              -- FunEqs are always at Nominal role++  | otherwise  -- Wanted+  = do { traceTcS "reactFunEq" (ppr from_this $$ ppr fsk1 $$+                                ppr solve_this $$ ppr fsk2)+       ; dischargeFmv solve_this fsk2 (ctEvCoercion from_this) (mkTyVarTy fsk1)+       ; traceTcS "reactFunEq done" (ppr from_this $$ ppr fsk1 $$+                                     ppr solve_this $$ ppr fsk2) }++{- Note [Type inference for type families with injectivity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have a type family with an injectivity annotation:+    type family F a b = r | r -> b++Then if we have two CFunEqCan constraints for F with the same RHS+   F s1 t1 ~ rhs+   F s2 t2 ~ rhs+then we can use the injectivity to get a new Derived constraint on+the injective argument+  [D] t1 ~ t2++That in turn can help GHC solve constraints that would otherwise require+guessing.  For example, consider the ambiguity check for+   f :: F Int b -> Int+We get the constraint+   [W] F Int b ~ F Int beta+where beta is a unification variable.  Injectivity lets us pick beta ~ b.++Injectivity information is also used at the call sites. For example:+   g = f True+gives rise to+   [W] F Int b ~ Bool+from which we can derive b.  This requires looking at the defining equations of+a type family, ie. finding equation with a matching RHS (Bool in this example)+and infering values of type variables (b in this example) from the LHS patterns+of the matching equation.  For closed type families we have to perform+additional apartness check for the selected equation to check that the selected+is guaranteed to fire for given LHS arguments.++These new constraints are simply *Derived* constraints; they have no evidence.+We could go further and offer evidence from decomposing injective type-function+applications, but that would require new evidence forms, and an extension to+FC, so we don't do that right now (Dec 14).++See also Note [Injective type families] in TyCon+++Note [Cache-caused loops]+~~~~~~~~~~~~~~~~~~~~~~~~~+It is very dangerous to cache a rewritten wanted family equation as 'solved' in our+solved cache (which is the default behaviour or xCtEvidence), because the interaction+may not be contributing towards a solution. Here is an example:++Initial inert set:+  [W] g1 : F a ~ beta1+Work item:+  [W] g2 : F a ~ beta2+The work item will react with the inert yielding the _same_ inert set plus:+    i)   Will set g2 := g1 `cast` g3+    ii)  Will add to our solved cache that [S] g2 : F a ~ beta2+    iii) Will emit [W] g3 : beta1 ~ beta2+Now, the g3 work item will be spontaneously solved to [G] g3 : beta1 ~ beta2+and then it will react the item in the inert ([W] g1 : F a ~ beta1). So it+will set+      g1 := g ; sym g3+and what is g? Well it would ideally be a new goal of type (F a ~ beta2) but+remember that we have this in our solved cache, and it is ... g2! In short we+created the evidence loop:++        g2 := g1 ; g3+        g3 := refl+        g1 := g2 ; sym g3++To avoid this situation we do not cache as solved any workitems (or inert)+which did not really made a 'step' towards proving some goal. Solved's are+just an optimization so we don't lose anything in terms of completeness of+solving.+++Note [Efficient Orientation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we are interacting two FunEqCans with the same LHS:+          (inert)  ci :: (F ty ~ xi_i)+          (work)   cw :: (F ty ~ xi_w)+We prefer to keep the inert (else we pass the work item on down+the pipeline, which is a bit silly).  If we keep the inert, we+will (a) discharge 'cw'+     (b) produce a new equality work-item (xi_w ~ xi_i)+Notice the orientation (xi_w ~ xi_i) NOT (xi_i ~ xi_w):+    new_work :: xi_w ~ xi_i+    cw := ci ; sym new_work+Why?  Consider the simplest case when xi1 is a type variable.  If+we generate xi1~xi2, porcessing that constraint will kick out 'ci'.+If we generate xi2~xi1, there is less chance of that happening.+Of course it can and should still happen if xi1=a, xi1=Int, say.+But we want to avoid it happening needlessly.++Similarly, if we *can't* keep the inert item (because inert is Wanted,+and work is Given, say), we prefer to orient the new equality (xi_i ~+xi_w).++Note [Carefully solve the right CFunEqCan]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+   ---- OLD COMMENT, NOW NOT NEEDED+   ---- because we now allow multiple+   ---- wanted FunEqs with the same head+Consider the constraints+  c1 :: F Int ~ a      -- Arising from an application line 5+  c2 :: F Int ~ Bool   -- Arising from an application line 10+Suppose that 'a' is a unification variable, arising only from+flattening.  So there is no error on line 5; it's just a flattening+variable.  But there is (or might be) an error on line 10.++Two ways to combine them, leaving either (Plan A)+  c1 :: F Int ~ a      -- Arising from an application line 5+  c3 :: a ~ Bool       -- Arising from an application line 10+or (Plan B)+  c2 :: F Int ~ Bool   -- Arising from an application line 10+  c4 :: a ~ Bool       -- Arising from an application line 5++Plan A will unify c3, leaving c1 :: F Int ~ Bool as an error+on the *totally innocent* line 5.  An example is test SimpleFail16+where the expected/actual message comes out backwards if we use+the wrong plan.++The second is the right thing to do.  Hence the isMetaTyVarTy+test when solving pairwise CFunEqCan.+++**********************************************************************+*                                                                    *+                   interactTyVarEq+*                                                                    *+**********************************************************************+-}++inertsCanDischarge :: InertCans -> TcTyVar -> TcType -> CtEvidence+                   -> Maybe ( CtEvidence  -- The evidence for the inert+                            , SwapFlag    -- Whether we need mkSymCo+                            , Bool)       -- True <=> keep a [D] version+                                          --          of the [WD] constraint+inertsCanDischarge inerts tv rhs ev+  | (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i }+                             <- findTyEqs inerts tv+                         , ev_i `eqCanDischarge` ev+                         , rhs_i `tcEqType` rhs ]+  =  -- Inert:     a ~ ty+     -- Work item: a ~ ty+    Just (ev_i, NotSwapped, keep_deriv ev_i)++  | Just tv_rhs <- getTyVar_maybe rhs+  , (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i }+                             <- findTyEqs inerts tv_rhs+                         , ev_i `eqCanDischarge` ev+                         , rhs_i `tcEqType` mkTyVarTy tv ]+  =  -- Inert:     a ~ b+     -- Work item: b ~ a+     Just (ev_i, IsSwapped, keep_deriv ev_i)++  | otherwise+  = Nothing++  where+    keep_deriv ev_i+      | Wanted WOnly  <- ctEvFlavour ev_i  -- inert is [W]+      , Wanted WDeriv <- ctEvFlavour ev    -- work item is [WD]+      = True   -- Keep a derived verison of the work item+      | otherwise+      = False  -- Work item is fully discharged++interactTyVarEq :: InertCans -> Ct -> TcS (StopOrContinue Ct)+-- CTyEqCans are always consumed, so always returns Stop+interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv+                                          , cc_rhs = rhs+                                          , cc_ev = ev+                                          , cc_eq_rel = eq_rel })+  | Just (ev_i, swapped, keep_deriv)+       <- inertsCanDischarge inerts tv rhs ev+  = do { setEvBindIfWanted ev $+         EvCoercion (maybeSym swapped $+                     tcDowngradeRole (eqRelRole eq_rel)+                                     (ctEvRole ev_i)+                                     (ctEvCoercion ev_i))++       ; let deriv_ev = CtDerived { ctev_pred = ctEvPred ev+                                  , ctev_loc  = ctEvLoc  ev }+       ; when keep_deriv $+         emitWork [workItem { cc_ev = deriv_ev }]+         -- As a Derived it might not be fully rewritten,+         -- so we emit it as new work++       ; stopWith ev "Solved from inert" }++  | ReprEq <- eq_rel   -- We never solve representational+  = unsolved_inert     -- equalities by unification++  | isGiven ev         -- See Note [Touchables and givens]+  = unsolved_inert++  | otherwise+  = do { tclvl <- getTcLevel+       ; if canSolveByUnification tclvl tv rhs+         then do { solveByUnification ev tv rhs+                 ; n_kicked <- kickOutAfterUnification tv+                 ; return (Stop ev (text "Solved by unification" <+> ppr_kicked n_kicked)) }++         else unsolved_inert }++  where+    unsolved_inert+      = do { traceTcS "Can't solve tyvar equality"+                (vcat [ text "LHS:" <+> ppr tv <+> dcolon <+> ppr (tyVarKind tv)+                      , ppWhen (isMetaTyVar tv) $+                        nest 4 (text "TcLevel of" <+> ppr tv+                                <+> text "is" <+> ppr (metaTyVarTcLevel tv))+                      , text "RHS:" <+> ppr rhs <+> dcolon <+> ppr (typeKind rhs) ])+           ; addInertEq workItem+           ; stopWith ev "Kept as inert" }++interactTyVarEq _ wi = pprPanic "interactTyVarEq" (ppr wi)++solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS ()+-- Solve with the identity coercion+-- Precondition: kind(xi) equals kind(tv)+-- Precondition: CtEvidence is Wanted or Derived+-- Precondition: CtEvidence is nominal+-- Returns: workItem where+--        workItem = the new Given constraint+--+-- NB: No need for an occurs check here, because solveByUnification always+--     arises from a CTyEqCan, a *canonical* constraint.  Its invariants+--     say that in (a ~ xi), the type variable a does not appear in xi.+--     See TcRnTypes.Ct invariants.+--+-- Post: tv is unified (by side effect) with xi;+--       we often write tv := xi+solveByUnification wd tv xi+  = do { let tv_ty = mkTyVarTy tv+       ; traceTcS "Sneaky unification:" $+                       vcat [text "Unifies:" <+> ppr tv <+> text ":=" <+> ppr xi,+                             text "Coercion:" <+> pprEq tv_ty xi,+                             text "Left Kind is:" <+> ppr (typeKind tv_ty),+                             text "Right Kind is:" <+> ppr (typeKind xi) ]++       ; unifyTyVar tv xi+       ; setEvBindIfWanted wd (EvCoercion (mkTcNomReflCo xi)) }++ppr_kicked :: Int -> SDoc+ppr_kicked 0 = empty+ppr_kicked n = parens (int n <+> text "kicked out")++{- Note [Avoid double unifications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The spontaneous solver has to return a given which mentions the unified unification+variable *on the left* of the equality. Here is what happens if not:+  Original wanted:  (a ~ alpha),  (alpha ~ Int)+We spontaneously solve the first wanted, without changing the order!+      given : a ~ alpha      [having unified alpha := a]+Now the second wanted comes along, but he cannot rewrite the given, so we simply continue.+At the end we spontaneously solve that guy, *reunifying*  [alpha := Int]++We avoid this problem by orienting the resulting given so that the unification+variable is on the left.  [Note that alternatively we could attempt to+enforce this at canonicalization]++See also Note [No touchables as FunEq RHS] in TcSMonad; avoiding+double unifications is the main reason we disallow touchable+unification variables as RHS of type family equations: F xis ~ alpha.+++************************************************************************+*                                                                      *+*          Functional dependencies, instantiation of equations+*                                                                      *+************************************************************************++When we spot an equality arising from a functional dependency,+we now use that equality (a "wanted") to rewrite the work-item+constraint right away.  This avoids two dangers++ Danger 1: If we send the original constraint on down the pipeline+           it may react with an instance declaration, and in delicate+           situations (when a Given overlaps with an instance) that+           may produce new insoluble goals: see Trac #4952++ Danger 2: If we don't rewrite the constraint, it may re-react+           with the same thing later, and produce the same equality+           again --> termination worries.++To achieve this required some refactoring of FunDeps.hs (nicer+now!).++Note [FunDep and implicit parameter reactions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Currently, our story of interacting two dictionaries (or a dictionary+and top-level instances) for functional dependencies, and implicit+parameters, is that we simply produce new Derived equalities.  So for example++        class D a b | a -> b where ...+    Inert:+        d1 :g D Int Bool+    WorkItem:+        d2 :w D Int alpha++    We generate the extra work item+        cv :d alpha ~ Bool+    where 'cv' is currently unused.  However, this new item can perhaps be+    spontaneously solved to become given and react with d2,+    discharging it in favour of a new constraint d2' thus:+        d2' :w D Int Bool+        d2 := d2' |> D Int cv+    Now d2' can be discharged from d1++We could be more aggressive and try to *immediately* solve the dictionary+using those extra equalities, but that requires those equalities to carry+evidence and derived do not carry evidence.++If that were the case with the same inert set and work item we might dischard+d2 directly:++        cv :w alpha ~ Bool+        d2 := d1 |> D Int cv++But in general it's a bit painful to figure out the necessary coercion,+so we just take the first approach. Here is a better example. Consider:+    class C a b c | a -> b+And:+     [Given]  d1 : C T Int Char+     [Wanted] d2 : C T beta Int+In this case, it's *not even possible* to solve the wanted immediately.+So we should simply output the functional dependency and add this guy+[but NOT its superclasses] back in the worklist. Even worse:+     [Given] d1 : C T Int beta+     [Wanted] d2: C T beta Int+Then it is solvable, but its very hard to detect this on the spot.++It's exactly the same with implicit parameters, except that the+"aggressive" approach would be much easier to implement.++Note [Weird fundeps]+~~~~~~~~~~~~~~~~~~~~+Consider   class Het a b | a -> b where+              het :: m (f c) -> a -> m b++           class GHet (a :: * -> *) (b :: * -> *) | a -> b+           instance            GHet (K a) (K [a])+           instance Het a b => GHet (K a) (K b)++The two instances don't actually conflict on their fundeps,+although it's pretty strange.  So they are both accepted. Now+try   [W] GHet (K Int) (K Bool)+This triggers fundeps from both instance decls;+      [D] K Bool ~ K [a]+      [D] K Bool ~ K beta+And there's a risk of complaining about Bool ~ [a].  But in fact+the Wanted matches the second instance, so we never get as far+as the fundeps.++Trac #7875 is a case in point.+-}++emitFunDepDeriveds :: [FunDepEqn CtLoc] -> TcS ()+-- See Note [FunDep and implicit parameter reactions]+emitFunDepDeriveds fd_eqns+  = mapM_ do_one_FDEqn fd_eqns+  where+    do_one_FDEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = loc })+     | null tvs  -- Common shortcut+     = do { traceTcS "emitFunDepDeriveds 1" (ppr (ctl_depth loc) $$ ppr eqs)+          ; mapM_ (unifyDerived loc Nominal) eqs }+     | otherwise+     = do { traceTcS "emitFunDepDeriveds 2" (ppr (ctl_depth loc) $$ ppr eqs)+          ; subst <- instFlexi tvs  -- Takes account of kind substitution+          ; mapM_ (do_one_eq loc subst) eqs }++    do_one_eq loc subst (Pair ty1 ty2)+       = unifyDerived loc Nominal $+         Pair (Type.substTyUnchecked subst ty1) (Type.substTyUnchecked subst ty2)++{-+**********************************************************************+*                                                                    *+                       The top-reaction Stage+*                                                                    *+**********************************************************************+-}++topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct)+topReactionsStage wi+ = do { tir <- doTopReact wi+      ; case tir of+          ContinueWith wi -> continueWith wi+          Stop ev s       -> return (Stop ev (text "Top react:" <+> s)) }++doTopReact :: WorkItem -> TcS (StopOrContinue Ct)+-- The work item does not react with the inert set, so try interaction with top-level+-- instances. Note:+--+--   (a) The place to add superclasses in not here in doTopReact stage.+--       Instead superclasses are added in the worklist as part of the+--       canonicalization process. See Note [Adding superclasses].++doTopReact work_item+  = do { traceTcS "doTopReact" (ppr work_item)+       ; case work_item of+           CDictCan {}  -> do { inerts <- getTcSInerts+                              ; doTopReactDict inerts work_item }+           CFunEqCan {} -> doTopReactFunEq work_item+           _  -> -- Any other work item does not react with any top-level equations+                 continueWith work_item  }+++--------------------+doTopReactFunEq :: Ct -> TcS (StopOrContinue Ct)+doTopReactFunEq work_item@(CFunEqCan { cc_ev = old_ev, cc_fun = fam_tc+                                     , cc_tyargs = args, cc_fsk = fsk })++  | fsk `elemVarSet` tyCoVarsOfTypes args+  = no_reduction    -- See Note [FunEq occurs-check principle]++  | otherwise  -- Note [Reduction for Derived CFunEqCans]+  = do { match_res <- matchFam fam_tc args+                           -- Look up in top-level instances, or built-in axiom+                           -- See Note [MATCHING-SYNONYMS]+       ; case match_res of+           Nothing         -> no_reduction+           Just match_info -> reduce_top_fun_eq old_ev fsk match_info }+  where+    no_reduction+      = do { improveTopFunEqs old_ev fam_tc args fsk+           ; continueWith work_item }++doTopReactFunEq w = pprPanic "doTopReactFunEq" (ppr w)++reduce_top_fun_eq :: CtEvidence -> TcTyVar -> (TcCoercion, TcType)+                  -> TcS (StopOrContinue Ct)+-- We have found an applicable top-level axiom: use it to reduce+-- Precondition: fsk is not free in rhs_ty+--               old_ev is not Derived+reduce_top_fun_eq old_ev fsk (ax_co, rhs_ty)+  | isDerived old_ev+  = do { emitNewDerivedEq loc Nominal (mkTyVarTy fsk) rhs_ty+       ; stopWith old_ev "Fun/Top (derived)" }++  | Just (tc, tc_args) <- tcSplitTyConApp_maybe rhs_ty+  , isTypeFamilyTyCon tc+  , tc_args `lengthIs` tyConArity tc    -- Short-cut+  = -- RHS is another type-family application+    -- Try shortcut; see Note [Top-level reductions for type functions]+    shortCutReduction old_ev fsk ax_co tc tc_args++  | isGiven old_ev  -- Not shortcut+  = do { let final_co = mkTcSymCo (ctEvCoercion old_ev) `mkTcTransCo` ax_co+              -- final_co :: fsk ~ rhs_ty+       ; new_ev <- newGivenEvVar deeper_loc (mkPrimEqPred (mkTyVarTy fsk) rhs_ty,+                                             EvCoercion final_co)+       ; emitWorkNC [new_ev] -- Non-cannonical; that will mean we flatten rhs_ty+       ; stopWith old_ev "Fun/Top (given)" }++  | otherwise   -- So old_ev is Wanted (cannot be Derived)+  = ASSERT2( not (fsk `elemVarSet` tyCoVarsOfType rhs_ty)+           , ppr old_ev $$ ppr rhs_ty )+           -- Guaranteed by Note [FunEq occurs-check principle]+    do { dischargeFmv old_ev fsk ax_co rhs_ty+       ; traceTcS "doTopReactFunEq" $+         vcat [ text "old_ev:" <+> ppr old_ev+              , nest 2 (text ":=") <+> ppr ax_co ]+       ; stopWith old_ev "Fun/Top (wanted)" }++  where+    loc = ctEvLoc old_ev+    deeper_loc = bumpCtLocDepth loc++improveTopFunEqs :: CtEvidence -> TyCon -> [TcType] -> TcTyVar -> TcS ()+-- See Note [FunDep and implicit parameter reactions]+improveTopFunEqs ev fam_tc args fsk+  | isGiven ev            -- See Note [No FunEq improvement for Givens]+    || not (isImprovable ev)+  = return ()++  | otherwise+  = do { ieqs <- getInertEqs+       ; fam_envs <- getFamInstEnvs+       ; eqns <- improve_top_fun_eqs fam_envs fam_tc args+                                    (lookupFlattenTyVar ieqs fsk)+       ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr fsk+                                          , ppr eqns ])+       ; mapM_ (unifyDerived loc Nominal) eqns }+  where+    loc = ctEvLoc ev++improve_top_fun_eqs :: FamInstEnvs+                    -> TyCon -> [TcType] -> TcType+                    -> TcS [TypeEqn]+improve_top_fun_eqs fam_envs fam_tc args rhs_ty+  | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc+  = return (sfInteractTop ops args rhs_ty)++  -- see Note [Type inference for type families with injectivity]+  | isOpenTypeFamilyTyCon fam_tc+  , Injective injective_args <- familyTyConInjectivityInfo fam_tc+  = -- it is possible to have several compatible equations in an open type+    -- family but we only want to derive equalities from one such equation.+    concatMapM (injImproveEqns injective_args) (take 1 $+      buildImprovementData (lookupFamInstEnvByTyCon fam_envs fam_tc)+                           fi_tvs fi_tys fi_rhs (const Nothing))++  | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe fam_tc+  , Injective injective_args <- familyTyConInjectivityInfo fam_tc+  = concatMapM (injImproveEqns injective_args) $+      buildImprovementData (fromBranches (co_ax_branches ax))+                           cab_tvs cab_lhs cab_rhs Just++  | otherwise+  = return []++  where+      buildImprovementData+          :: [a]                     -- axioms for a TF (FamInst or CoAxBranch)+          -> (a -> [TyVar])          -- get bound tyvars of an axiom+          -> (a -> [Type])           -- get LHS of an axiom+          -> (a -> Type)             -- get RHS of an axiom+          -> (a -> Maybe CoAxBranch) -- Just => apartness check required+          -> [( [Type], TCvSubst, [TyVar], Maybe CoAxBranch )]+             -- Result:+             -- ( [arguments of a matching axiom]+             -- , RHS-unifying substitution+             -- , axiom variables without substitution+             -- , Maybe matching axiom [Nothing - open TF, Just - closed TF ] )+      buildImprovementData axioms axiomTVs axiomLHS axiomRHS wrap =+          [ (ax_args, subst, unsubstTvs, wrap axiom)+          | axiom <- axioms+          , let ax_args = axiomLHS axiom+                ax_rhs  = axiomRHS axiom+                ax_tvs  = axiomTVs axiom+          , Just subst <- [tcUnifyTyWithTFs False ax_rhs rhs_ty]+          , let notInSubst tv = not (tv `elemVarEnv` getTvSubstEnv subst)+                unsubstTvs    = filter (notInSubst <&&> isTyVar) ax_tvs ]+                   -- The order of unsubstTvs is important; it must be+                   -- in telescope order e.g. (k:*) (a:k)++      injImproveEqns :: [Bool]+                     -> ([Type], TCvSubst, [TyCoVar], Maybe CoAxBranch)+                     -> TcS [TypeEqn]+      injImproveEqns inj_args (ax_args, subst, unsubstTvs, cabr)+        = do { subst <- instFlexiX subst unsubstTvs+                  -- If the current substitution bind [k -> *], and+                  -- one of the un-substituted tyvars is (a::k), we'd better+                  -- be sure to apply the current substitution to a's kind.+                  -- Hence instFlexiX.   Trac #13135 was an example.++             ; return [ Pair (substTyUnchecked subst ax_arg) arg+                        -- NB: the ax_arg part is on the left+                        -- see Note [Improvement orientation]+                      | case cabr of+                          Just cabr' -> apartnessCheck (substTys subst ax_args) cabr'+                          _          -> True+                      , (ax_arg, arg, True) <- zip3 ax_args args inj_args ] }+++shortCutReduction :: CtEvidence -> TcTyVar -> TcCoercion+                  -> TyCon -> [TcType] -> TcS (StopOrContinue Ct)+-- See Note [Top-level reductions for type functions]+shortCutReduction old_ev fsk ax_co fam_tc tc_args+  = ASSERT( ctEvEqRel old_ev == NomEq)+    do { (xis, cos) <- flattenManyNom old_ev tc_args+               -- ax_co :: F args ~ G tc_args+               -- cos   :: xis ~ tc_args+               -- old_ev :: F args ~ fsk+               -- G cos ; sym ax_co ; old_ev :: G xis ~ fsk++       ; new_ev <- case ctEvFlavour old_ev of+           Given -> newGivenEvVar deeper_loc+                         ( mkPrimEqPred (mkTyConApp fam_tc xis) (mkTyVarTy fsk)+                         , EvCoercion (mkTcTyConAppCo Nominal fam_tc cos+                                        `mkTcTransCo` mkTcSymCo ax_co+                                        `mkTcTransCo` ctEvCoercion old_ev) )++           Wanted {} ->+             do { (new_ev, new_co) <- newWantedEq deeper_loc Nominal+                                        (mkTyConApp fam_tc xis) (mkTyVarTy fsk)+                ; setWantedEq (ctev_dest old_ev) $+                     ax_co `mkTcTransCo` mkTcSymCo (mkTcTyConAppCo Nominal+                                                      fam_tc cos)+                           `mkTcTransCo` new_co+                ; return new_ev }++           Derived -> pprPanic "shortCutReduction" (ppr old_ev)++       ; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc+                                , cc_tyargs = xis, cc_fsk = fsk }+       ; updWorkListTcS (extendWorkListFunEq new_ct)+       ; stopWith old_ev "Fun/Top (shortcut)" }+  where+    deeper_loc = bumpCtLocDepth (ctEvLoc old_ev)++dischargeFmv :: CtEvidence -> TcTyVar -> TcCoercion -> TcType -> TcS ()+-- (dischargeFmv x fmv co ty)+--     [W] ev :: F tys ~ fmv+--         co :: F tys ~ xi+-- Precondition: fmv is not filled, and fmv `notElem` xi+--               ev is Wanted+--+-- Then set fmv := xi,+--      set ev  := co+--      kick out any inert things that are now rewritable+--+-- Does not evaluate 'co' if 'ev' is Derived+dischargeFmv ev@(CtWanted { ctev_dest = dest }) fmv co xi+  = ASSERT2( not (fmv `elemVarSet` tyCoVarsOfType xi), ppr ev $$ ppr fmv $$ ppr xi )+    do { setWantedEvTerm dest (EvCoercion co)+       ; unflattenFmv fmv xi+       ; n_kicked <- kickOutAfterUnification fmv+       ; traceTcS "dischargeFmv" (ppr fmv <+> equals <+> ppr xi $$ ppr_kicked n_kicked) }+dischargeFmv ev _ _ _ = pprPanic "dischargeFmv" (ppr ev)++{- Note [Top-level reductions for type functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+c.f. Note [The flattening story] in TcFlatten++Suppose we have a CFunEqCan  F tys ~ fmv/fsk, and a matching axiom.+Here is what we do, in four cases:++* Wanteds: general firing rule+    (work item) [W]        x : F tys ~ fmv+    instantiate axiom: ax_co : F tys ~ rhs++   Then:+      Discharge   fmv := rhs+      Discharge   x := ax_co ; sym x2+   This is *the* way that fmv's get unified; even though they are+   "untouchable".++   NB: Given Note [FunEq occurs-check principle], fmv does not appear+   in tys, and hence does not appear in the instantiated RHS.  So+   the unification can't make an infinite type.++* Wanteds: short cut firing rule+  Applies when the RHS of the axiom is another type-function application+      (work item)        [W] x : F tys ~ fmv+      instantiate axiom: ax_co : F tys ~ G rhs_tys++  It would be a waste to create yet another fmv for (G rhs_tys).+  Instead (shortCutReduction):+      - Flatten rhs_tys (cos : rhs_tys ~ rhs_xis)+      - Add G rhs_xis ~ fmv to flat cache  (note: the same old fmv)+      - New canonical wanted   [W] x2 : G rhs_xis ~ fmv  (CFunEqCan)+      - Discharge x := ax_co ; G cos ; x2++* Givens: general firing rule+      (work item)        [G] g : F tys ~ fsk+      instantiate axiom: ax_co : F tys ~ rhs++   Now add non-canonical given (since rhs is not flat)+      [G] (sym g ; ax_co) : fsk ~ rhs  (Non-canonical)++* Givens: short cut firing rule+  Applies when the RHS of the axiom is another type-function application+      (work item)        [G] g : F tys ~ fsk+      instantiate axiom: ax_co : F tys ~ G rhs_tys++  It would be a waste to create yet another fsk for (G rhs_tys).+  Instead (shortCutReduction):+     - Flatten rhs_tys: flat_cos : tys ~ flat_tys+     - Add new Canonical given+          [G] (sym (G flat_cos) ; co ; g) : G flat_tys ~ fsk   (CFunEqCan)++Note [FunEq occurs-check principle]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+I have spent a lot of time finding a good way to deal with+CFunEqCan constraints like+    F (fuv, a) ~ fuv+where flatten-skolem occurs on the LHS.  Now in principle we+might may progress by doing a reduction, but in practice its+hard to find examples where it is useful, and easy to find examples+where we fall into an infinite reduction loop.  A rule that works+very well is this:++  *** FunEq occurs-check principle ***++      Do not reduce a CFunEqCan+          F tys ~ fsk+      if fsk appears free in tys+      Instead we treat it as stuck.++Examples:++* Trac #5837 has [G] a ~ TF (a,Int), with an instance+    type instance TF (a,b) = (TF a, TF b)+  This readily loops when solving givens.  But with the FunEq occurs+  check principle, it rapidly gets stuck which is fine.++* Trac #12444 is a good example, explained in comment:2.  We have+    type instance F (Succ x) = Succ (F x)+    [W] alpha ~ Succ (F alpha)+  If we allow the reduction to happen, we get an infinite loop++Note [Cached solved FunEqs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+When trying to solve, say (FunExpensive big-type ~ ty), it's important+to see if we have reduced (FunExpensive big-type) before, lest we+simply repeat it.  Hence the lookup in inert_solved_funeqs.  Moreover+we must use `funEqCanDischarge` because both uses might (say) be Wanteds,+and we *still* want to save the re-computation.++Note [MATCHING-SYNONYMS]+~~~~~~~~~~~~~~~~~~~~~~~~+When trying to match a dictionary (D tau) to a top-level instance, or a+type family equation (F taus_1 ~ tau_2) to a top-level family instance,+we do *not* need to expand type synonyms because the matcher will do that for us.++Note [Improvement orientation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A very delicate point is the orientation of derived equalities+arising from injectivity improvement (Trac #12522).  Suppse we have+  type family F x = t | t -> x+  type instance F (a, Int) = (Int, G a)+where G is injective; and wanted constraints++  [W] TF (alpha, beta) ~ fuv+  [W] fuv ~ (Int, <some type>)++The injectivity will give rise to derived constraints++  [D] gamma1 ~ alpha+  [D] Int ~ beta++The fresh unification variable gamma1 comes from the fact that we+can only do "partial improvement" here; see Section 5.2 of+"Injective type families for Haskell" (HS'15).++Now, it's very important to orient the equations this way round,+so that the fresh unification variable will be eliminated in+favour of alpha.  If we instead had+   [D] alpha ~ gamma1+then we would unify alpha := gamma1; and kick out the wanted+constraint.  But when we grough it back in, it'd look like+   [W] TF (gamma1, beta) ~ fuv+and exactly the same thing would happen again!  Infnite loop.++This all sesms fragile, and it might seem more robust to avoid+introducing gamma1 in the first place, in the case where the+actual argument (alpha, beta) partly matches the improvement+template.  But that's a bit tricky, esp when we remember that the+kinds much match too; so it's easier to let the normal machinery+handle it.  Instead we are careful to orient the new derived+equality with the template on the left.  Delicate, but it works.++Note [No FunEq improvement for Givens]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don't do improvements (injectivity etc) for Givens. Why?++* It generates Derived constraints on skolems, which don't do us+  much good, except perhaps identify inaccessible branches.+  (They'd be perfectly valid though.)++* For type-nat stuff the derived constraints include type families;+  e.g.  (a < b), (b < c) ==> a < c If we generate a Derived for this,+  we'll generate a Derived/Wanted CFunEqCan; and, since the same+  InertCans (after solving Givens) are used for each iteration, that+  massively confused the unflattening step (TcFlatten.unflatten).++  In fact it led to some infinite loops:+     indexed-types/should_compile/T10806+     indexed-types/should_compile/T10507+     polykinds/T10742++Note [Reduction for Derived CFunEqCans]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+You may wonder if it's important to use top-level instances to+simplify [D] CFunEqCan's.  But it is.  Here's an example (T10226).++   type instance F    Int = Int+   type instance FInv Int = Int++Suppose we have to solve+    [WD] FInv (F alpha) ~ alpha+    [WD] F alpha ~ Int++  --> flatten+    [WD] F alpha ~ fuv0+    [WD] FInv fuv0 ~ fuv1  -- (A)+    [WD] fuv1 ~ alpha+    [WD] fuv0 ~ Int        -- (B)++  --> Rewwrite (A) with (B), splitting it+    [WD] F alpha ~ fuv0+    [W] FInv fuv0 ~ fuv1+    [D] FInv Int ~ fuv1    -- (C)+    [WD] fuv1 ~ alpha+    [WD] fuv0 ~ Int++  --> Reduce (C) with top-level instance+      **** This is the key step ***+    [WD] F alpha ~ fuv0+    [W] FInv fuv0 ~ fuv1+    [D] fuv1 ~ Int        -- (D)+    [WD] fuv1 ~ alpha     -- (E)+    [WD] fuv0 ~ Int++  --> Rewrite (D) with (E)+    [WD] F alpha ~ fuv0+    [W] FInv fuv0 ~ fuv1+    [D] alpha ~ Int       -- (F)+    [WD] fuv1 ~ alpha+    [WD] fuv0 ~ Int++  --> unify (F)  alpha := Int, and that solves it++Another example is indexed-types/should_compile/T10634+-}++{- *******************************************************************+*                                                                    *+         Top-level reaction for class constraints (CDictCan)+*                                                                    *+**********************************************************************-}++doTopReactDict :: InertSet -> Ct -> TcS (StopOrContinue Ct)+-- Try to use type-class instance declarations to simplify the constraint+doTopReactDict inerts work_item@(CDictCan { cc_ev = fl, cc_class = cls+                                          , cc_tyargs = xis })+  | isGiven fl   -- Never use instances for Given constraints+  = do { try_fundep_improvement+       ; continueWith work_item }++  | Just ev <- lookupSolvedDict inerts cls xis   -- Cached+  = do { setEvBindIfWanted fl (ctEvTerm ev)+       ; stopWith fl "Dict/Top (cached)" }++  | otherwise  -- Wanted or Derived, but not cached+   = do { dflags <- getDynFlags+        ; lkup_inst_res <- matchClassInst dflags inerts cls xis dict_loc+        ; case lkup_inst_res of+               GenInst { lir_new_theta = theta+                       , lir_mk_ev     = mk_ev+                       , lir_safe_over = s } ->+                 do { traceTcS "doTopReact/found instance for" $ ppr fl+                    ; checkReductionDepth deeper_loc dict_pred+                    ; unless s $ insertSafeOverlapFailureTcS work_item+                    ; if isDerived fl then finish_derived theta+                                      else finish_wanted  theta mk_ev }+               NoInstance ->+                 do { when (isImprovable fl) $+                      try_fundep_improvement+                    ; continueWith work_item } }+   where+     dict_pred   = mkClassPred cls xis+     dict_loc    = ctEvLoc fl+     dict_origin = ctLocOrigin dict_loc+     deeper_loc  = zap_origin (bumpCtLocDepth dict_loc)++     zap_origin loc  -- After applying an instance we can set ScOrigin to+                     -- infinity, so that prohibitedSuperClassSolve never fires+       | ScOrigin {} <- dict_origin+       = setCtLocOrigin loc (ScOrigin infinity)+       | otherwise+       = loc++     finish_wanted :: [TcPredType]+                   -> ([EvTerm] -> EvTerm) -> TcS (StopOrContinue Ct)+      -- Precondition: evidence term matches the predicate workItem+     finish_wanted theta mk_ev+        = do { addSolvedDict fl cls xis+             ; evc_vars <- mapM (newWanted deeper_loc) theta+             ; setWantedEvBind (ctEvId fl) (mk_ev (map getEvTerm evc_vars))+             ; emitWorkNC (freshGoals evc_vars)+             ; stopWith fl "Dict/Top (solved wanted)" }++     finish_derived theta  -- Use type-class instances for Deriveds, in the hope+       =                   -- of generating some improvements+                           -- C.f. Example 3 of Note [The improvement story]+                           -- It's easy because no evidence is involved+         do { emitNewDeriveds deeper_loc theta+            ; traceTcS "finish_derived" (ppr (ctl_depth deeper_loc))+            ; stopWith fl "Dict/Top (solved derived)" }++     -- We didn't solve it; so try functional dependencies with+     -- the instance environment, and return+     -- See also Note [Weird fundeps]+     try_fundep_improvement+        = do { traceTcS "try_fundeps" (ppr work_item)+             ; instEnvs <- getInstEnvs+             ; emitFunDepDeriveds $+               improveFromInstEnv instEnvs mk_ct_loc dict_pred }++     mk_ct_loc :: PredType   -- From instance decl+               -> SrcSpan    -- also from instance deol+               -> CtLoc+     mk_ct_loc inst_pred inst_loc+       = dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin+                                               inst_pred inst_loc }++doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w)+++{- *******************************************************************+*                                                                    *+                       Class lookup+*                                                                    *+**********************************************************************-}++-- | Indicates if Instance met the Safe Haskell overlapping instances safety+-- check.+--+-- See Note [Safe Haskell Overlapping Instances] in TcSimplify+-- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify+type SafeOverlapping = Bool++data LookupInstResult+  = NoInstance+  | GenInst { lir_new_theta :: [TcPredType]+            , lir_mk_ev     :: [EvTerm] -> EvTerm+            , lir_safe_over :: SafeOverlapping }++instance Outputable LookupInstResult where+  ppr NoInstance = text "NoInstance"+  ppr (GenInst { lir_new_theta = ev+               , lir_safe_over = s })+    = text "GenInst" <+> vcat [ppr ev, ss]+    where ss = text $ if s then "[safe]" else "[unsafe]"+++matchClassInst :: DynFlags -> InertSet -> Class -> [Type] -> CtLoc -> TcS LookupInstResult+matchClassInst dflags inerts clas tys loc+-- First check whether there is an in-scope Given that could+-- match this constraint.  In that case, do not use top-level+-- instances.  See Note [Instance and Given overlap]+  | not (xopt LangExt.IncoherentInstances dflags)+  , not (naturallyCoherentClass clas)+  , let matchable_givens = matchableGivens loc pred inerts+  , not (isEmptyBag matchable_givens)+  = do { traceTcS "Delaying instance application" $+           vcat [ text "Work item=" <+> pprClassPred clas tys+                , text "Potential matching givens:" <+> ppr matchable_givens ]+       ; return NoInstance }+  where+     pred = mkClassPred clas tys++matchClassInst dflags _ clas tys loc+ = do { traceTcS "matchClassInst" $ text "pred =" <+> ppr (mkClassPred clas tys) <+> char '{'+      ; res <- match_class_inst dflags clas tys loc+      ; traceTcS "} matchClassInst result" $ ppr res+      ; return res }++match_class_inst :: DynFlags -> Class -> [Type] -> CtLoc -> TcS LookupInstResult+match_class_inst dflags clas tys loc+  | cls_name == knownNatClassName     = matchKnownNat        clas tys+  | cls_name == knownSymbolClassName  = matchKnownSymbol     clas tys+  | isCTupleClass clas                = matchCTuple          clas tys+  | cls_name == typeableClassName     = matchTypeable        clas tys+  | clas `hasKey` heqTyConKey         = matchLiftedEquality       tys+  | clas `hasKey` coercibleTyConKey   = matchLiftedCoercible      tys+  | cls_name == hasFieldClassName     = matchHasField dflags clas tys loc+  | otherwise                         = matchInstEnv dflags clas tys loc+  where+    cls_name = className clas++{- Note [Instance and Given overlap]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Example, from the OutsideIn(X) paper:+       instance P x => Q [x]+       instance (x ~ y) => R y [x]++       wob :: forall a b. (Q [b], R b a) => a -> Int++       g :: forall a. Q [a] => [a] -> Int+       g x = wob x++From 'g' we get the impliation constraint:+            forall a. Q [a] => (Q [beta], R beta [a])+If we react (Q [beta]) with its top-level axiom, we end up with a+(P beta), which we have no way of discharging. On the other hand,+if we react R beta [a] with the top-level we get  (beta ~ a), which+is solvable and can help us rewrite (Q [beta]) to (Q [a]) which is+now solvable by the given Q [a].++The partial solution is that:+  In matchClassInst (and thus in topReact), we return a matching+  instance only when there is no Given in the inerts which is+  unifiable to this particular dictionary.++  We treat any meta-tyvar as "unifiable" for this purpose,+  *including* untouchable ones.  But not skolems like 'a' in+  the implication constraint above.++The end effect is that, much as we do for overlapping instances, we+delay choosing a class instance if there is a possibility of another+instance OR a given to match our constraint later on. This fixes+Trac #4981 and #5002.++Other notes:++* The check is done *first*, so that it also covers classes+  with built-in instance solving, such as+     - constraint tuples+     - natural numbers+     - Typeable++* The given-overlap problem is arguably not easy to appear in practice+  due to our aggressive prioritization of equality solving over other+  constraints, but it is possible. I've added a test case in+  typecheck/should-compile/GivenOverlapping.hs++* Another "live" example is Trac #10195; another is #10177.++* We ignore the overlap problem if -XIncoherentInstances is in force:+  see Trac #6002 for a worked-out example where this makes a+  difference.++* Moreover notice that our goals here are different than the goals of+  the top-level overlapping checks. There we are interested in+  validating the following principle:++      If we inline a function f at a site where the same global+      instance environment is available as the instance environment at+      the definition site of f then we should get the same behaviour.++  But for the Given Overlap check our goal is just related to completeness of+  constraint solving.++* The solution is only a partial one.  Consider the above example with+       g :: forall a. Q [a] => [a] -> Int+       g x = let v = wob x+             in v+  and suppose we have -XNoMonoLocalBinds, so that we attempt to find the most+  general type for 'v'.  When generalising v's type we'll simplify its+  Q [alpha] constraint, but we don't have Q [a] in the 'givens', so we+  will use the instance declaration after all. Trac #11948 was a case+  in point.++All of this is disgustingly delicate, so to discourage people from writing+simplifiable class givens, we warn about signatures that contain them;#+see TcValidity Note [Simplifiable given constraints].+-}+++{- *******************************************************************+*                                                                    *+                Class lookup in the instance environment+*                                                                    *+**********************************************************************-}++matchInstEnv :: DynFlags -> Class -> [Type] -> CtLoc -> TcS LookupInstResult+matchInstEnv dflags clas tys loc+   = do { instEnvs <- getInstEnvs+        ; let safeOverlapCheck = safeHaskell dflags `elem` [Sf_Safe, Sf_Trustworthy]+              (matches, unify, unsafeOverlaps) = lookupInstEnv True instEnvs clas tys+              safeHaskFail = safeOverlapCheck && not (null unsafeOverlaps)+        ; case (matches, unify, safeHaskFail) of++            -- Nothing matches+            ([], _, _)+                -> do { traceTcS "matchClass not matching" $+                        vcat [ text "dict" <+> ppr pred ]+                      ; return NoInstance }++            -- A single match (& no safe haskell failure)+            ([(ispec, inst_tys)], [], False)+                -> do   { let dfun_id = instanceDFunId ispec+                        ; traceTcS "matchClass success" $+                          vcat [text "dict" <+> ppr pred,+                                text "witness" <+> ppr dfun_id+                                               <+> ppr (idType dfun_id) ]+                                  -- Record that this dfun is needed+                        ; match_one (null unsafeOverlaps) dfun_id inst_tys }++            -- More than one matches (or Safe Haskell fail!). Defer any+            -- reactions of a multitude until we learn more about the reagent+            (matches, _, _)+                -> do   { traceTcS "matchClass multiple matches, deferring choice" $+                          vcat [text "dict" <+> ppr pred,+                                text "matches" <+> ppr matches]+                        ; return NoInstance } }+   where+     pred = mkClassPred clas tys++     match_one :: SafeOverlapping -> DFunId -> [DFunInstType] -> TcS LookupInstResult+                  -- See Note [DFunInstType: instantiating types] in InstEnv+     match_one so dfun_id mb_inst_tys+       = do { checkWellStagedDFun pred dfun_id loc+            ; (tys, theta) <- instDFunType dfun_id mb_inst_tys+            ; return $ GenInst { lir_new_theta = theta+                               , lir_mk_ev     = EvDFunApp dfun_id tys+                               , lir_safe_over = so } }+++{- ********************************************************************+*                                                                     *+                   Class lookup for CTuples+*                                                                     *+***********************************************************************-}++matchCTuple :: Class -> [Type] -> TcS LookupInstResult+matchCTuple clas tys   -- (isCTupleClass clas) holds+  = return (GenInst { lir_new_theta = tys+                    , lir_mk_ev     = tuple_ev+                    , lir_safe_over = True })+            -- The dfun *is* the data constructor!+  where+     data_con = tyConSingleDataCon (classTyCon clas)+     tuple_ev = EvDFunApp (dataConWrapId data_con) tys++{- ********************************************************************+*                                                                     *+                   Class lookup for Literals+*                                                                     *+***********************************************************************-}++matchKnownNat :: Class -> [Type] -> TcS LookupInstResult+matchKnownNat clas [ty]     -- clas = KnownNat+  | Just n <- isNumLitTy ty = makeLitDict clas ty (EvNum n)+matchKnownNat _ _           = return NoInstance++matchKnownSymbol :: Class -> [Type] -> TcS LookupInstResult+matchKnownSymbol clas [ty]  -- clas = KnownSymbol+  | Just n <- isStrLitTy ty = makeLitDict clas ty (EvStr n)+matchKnownSymbol _ _       = return NoInstance+++makeLitDict :: Class -> Type -> EvLit -> TcS LookupInstResult+-- makeLitDict adds a coercion that will convert the literal into a dictionary+-- of the appropriate type.  See Note [KnownNat & KnownSymbol and EvLit]+-- in TcEvidence.  The coercion happens in 2 steps:+--+--     Integer -> SNat n     -- representation of literal to singleton+--     SNat n  -> KnownNat n -- singleton to dictionary+--+--     The process is mirrored for Symbols:+--     String    -> SSymbol n+--     SSymbol n -> KnownSymbol n -}+makeLitDict clas ty evLit+    | Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty]+          -- co_dict :: KnownNat n ~ SNat n+    , [ meth ]   <- classMethods clas+    , Just tcRep <- tyConAppTyCon_maybe -- SNat+                      $ funResultTy         -- SNat n+                      $ dropForAlls         -- KnownNat n => SNat n+                      $ idType meth         -- forall n. KnownNat n => SNat n+    , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty]+          -- SNat n ~ Integer+    , let ev_tm = mkEvCast (EvLit evLit) (mkTcSymCo (mkTcTransCo co_dict co_rep))+    = return $ GenInst { lir_new_theta = []+                       , lir_mk_ev     = \_ -> ev_tm+                       , lir_safe_over = True }++    | otherwise+    = panicTcS (text "Unexpected evidence for" <+> ppr (className clas)+                     $$ vcat (map (ppr . idType) (classMethods clas)))+++{- ********************************************************************+*                                                                     *+                   Class lookup for Typeable+*                                                                     *+***********************************************************************-}++-- | Assumes that we've checked that this is the 'Typeable' class,+-- and it was applied to the correct argument.+matchTypeable :: Class -> [Type] -> TcS LookupInstResult+matchTypeable clas [k,t]  -- clas = Typeable+  -- For the first two cases, See Note [No Typeable for polytypes or qualified types]+  | isForAllTy k                      = return NoInstance   -- Polytype+  | isJust (tcSplitPredFunTy_maybe t) = return NoInstance   -- Qualified type++  -- Now cases that do work+  | k `eqType` typeNatKind                 = doTyLit knownNatClassName         t+  | k `eqType` typeSymbolKind              = doTyLit knownSymbolClassName      t+  | isConstraintKind t                     = doTyConApp clas t constraintKindTyCon []+  | Just (arg,ret) <- splitFunTy_maybe t   = doFunTy    clas t arg ret+  | Just (tc, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)]+  , onlyNamedBndrsApplied tc ks            = doTyConApp clas t tc ks+  | Just (f,kt)   <- splitAppTy_maybe t    = doTyApp    clas t f kt++matchTypeable _ _ = return NoInstance++-- | Representation for a type @ty@ of the form @arg -> ret@.+doFunTy :: Class -> Type -> Type -> Type -> TcS LookupInstResult+doFunTy clas ty arg_ty ret_ty+  = do { let preds = map (mk_typeable_pred clas) [arg_ty, ret_ty]+             build_ev [arg_ev, ret_ev] =+                 EvTypeable ty $ EvTypeableTrFun arg_ev ret_ev+             build_ev _ = panic "TcInteract.doFunTy"+       ; return $ GenInst preds build_ev True+       }++-- | Representation for type constructor applied to some kinds.+-- 'onlyNamedBndrsApplied' has ensured that this application results in a type+-- of monomorphic kind (e.g. all kind variables have been instantiated).+doTyConApp :: Class -> Type -> TyCon -> [Kind] -> TcS LookupInstResult+doTyConApp clas ty tc kind_args+  = return $ GenInst (map (mk_typeable_pred clas) kind_args)+                     (\kinds -> EvTypeable ty $ EvTypeableTyCon tc kinds)+                     True++-- | Representation for TyCon applications of a concrete kind. We just use the+-- kind itself, but first we must make sure that we've instantiated all kind-+-- polymorphism, but no more.+onlyNamedBndrsApplied :: TyCon -> [KindOrType] -> Bool+onlyNamedBndrsApplied tc ks+ = all isNamedTyConBinder used_bndrs &&+   not (any isNamedTyConBinder leftover_bndrs)+ where+   bndrs                        = tyConBinders tc+   (used_bndrs, leftover_bndrs) = splitAtList ks bndrs++doTyApp :: Class -> Type -> Type -> KindOrType -> TcS LookupInstResult+-- Representation for an application of a type to a type-or-kind.+--  This may happen when the type expression starts with a type variable.+--  Example (ignoring kind parameter):+--    Typeable (f Int Char)                      -->+--    (Typeable (f Int), Typeable Char)          -->+--    (Typeable f, Typeable Int, Typeable Char)  --> (after some simp. steps)+--    Typeable f+doTyApp clas ty f tk+  | isForAllTy (typeKind f)+  = return NoInstance -- We can't solve until we know the ctr.+  | otherwise+  = return $ GenInst (map (mk_typeable_pred clas) [f, tk])+                     (\[t1,t2] -> EvTypeable ty $ EvTypeableTyApp t1 t2)+                     True++-- Emit a `Typeable` constraint for the given type.+mk_typeable_pred :: Class -> Type -> PredType+mk_typeable_pred clas ty = mkClassPred clas [ typeKind ty, ty ]++  -- Typeable is implied by KnownNat/KnownSymbol. In the case of a type literal+  -- we generate a sub-goal for the appropriate class. See #10348 for what+  -- happens when we fail to do this.+doTyLit :: Name -> Type -> TcS LookupInstResult+doTyLit kc t = do { kc_clas <- tcLookupClass kc+                  ; let kc_pred    = mkClassPred kc_clas [ t ]+                        mk_ev [ev] = EvTypeable t $ EvTypeableTyLit ev+                        mk_ev _    = panic "doTyLit"+                  ; return (GenInst [kc_pred] mk_ev True) }++{- Note [Typeable (T a b c)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For type applications we always decompose using binary application,+via doTyApp, until we get to a *kind* instantiation.  Example+   Proxy :: forall k. k -> *++To solve Typeable (Proxy (* -> *) Maybe) we+  - First decompose with doTyApp,+    to get (Typeable (Proxy (* -> *))) and Typeable Maybe+  - Then solve (Typeable (Proxy (* -> *))) with doTyConApp++If we attempt to short-cut by solving it all at once, via+doTyConApp++(this note is sadly truncated FIXME)+++Note [No Typeable for polytypes or qualified types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do not support impredicative typeable, such as+   Typeable (forall a. a->a)+   Typeable (Eq a => a -> a)+   Typeable (() => Int)+   Typeable (((),()) => Int)++See Trac #9858.  For forall's the case is clear: we simply don't have+a TypeRep for them.  For qualified but not polymorphic types, like+(Eq a => a -> a), things are murkier.  But:++ * We don't need a TypeRep for these things.  TypeReps are for+   monotypes only.++ * Perhaps we could treat `=>` as another type constructor for `Typeable`+   purposes, and thus support things like `Eq Int => Int`, however,+   at the current state of affairs this would be an odd exception as+   no other class works with impredicative types.+   For now we leave it off, until we have a better story for impredicativity.+-}++solveCallStack :: CtEvidence -> EvCallStack -> TcS ()+solveCallStack ev ev_cs = do+  -- We're given ev_cs :: CallStack, but the evidence term should be a+  -- dictionary, so we have to coerce ev_cs to a dictionary for+  -- `IP ip CallStack`. See Note [Overview of implicit CallStacks]+  let ev_tm = mkEvCast (EvCallStack ev_cs) (wrapIP (ctEvPred ev))+  setWantedEvBind (ctEvId ev) ev_tm++{- ********************************************************************+*                                                                     *+                   Class lookup for lifted equality+*                                                                     *+***********************************************************************-}++-- See also Note [The equality types story] in TysPrim+matchLiftedEquality :: [Type] -> TcS LookupInstResult+matchLiftedEquality args+  = return (GenInst { lir_new_theta = [ mkTyConApp eqPrimTyCon args ]+                    , lir_mk_ev     = EvDFunApp (dataConWrapId heqDataCon) args+                    , lir_safe_over = True })++-- See also Note [The equality types story] in TysPrim+matchLiftedCoercible :: [Type] -> TcS LookupInstResult+matchLiftedCoercible args@[k, t1, t2]+  = return (GenInst { lir_new_theta = [ mkTyConApp eqReprPrimTyCon args' ]+                    , lir_mk_ev     = EvDFunApp (dataConWrapId coercibleDataCon)+                                                args+                    , lir_safe_over = True })+  where+    args' = [k, k, t1, t2]+matchLiftedCoercible args = pprPanic "matchLiftedCoercible" (ppr args)+++{- ********************************************************************+*                                                                     *+              Class lookup for overloaded record fields+*                                                                     *+***********************************************************************-}++{-+Note [HasField instances]+~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++    data T y = MkT { foo :: [y] }++and `foo` is in scope.  Then GHC will automatically solve a constraint like++    HasField "foo" (T Int) b++by emitting a new wanted++    T alpha -> [alpha] ~# T Int -> b++and building a HasField dictionary out of the selector function `foo`,+appropriately cast.++The HasField class is defined (in GHC.Records) thus:++    class HasField (x :: k) r a | x r -> a where+      getField :: r -> a++Since this is a one-method class, it is represented as a newtype.+Hence we can solve `HasField "foo" (T Int) b` by taking an expression+of type `T Int -> b` and casting it using the newtype coercion.+Note that++    foo :: forall y . T y -> [y]++so the expression we construct is++    foo @alpha |> co++where++    co :: (T alpha -> [alpha]) ~# HasField "foo" (T Int) b++is built from++    co1 :: (T alpha -> [alpha]) ~# (T Int -> b)++which is the new wanted, and++    co2 :: (T Int -> b) ~# HasField "foo" (T Int) b++which can be derived from the newtype coercion.++If `foo` is not in scope, or has a higher-rank or existentially+quantified type, then the constraint is not solved automatically, but+may be solved by a user-supplied HasField instance.  Similarly, if we+encounter a HasField constraint where the field is not a literal+string, or does not belong to the type, then we fall back on the+normal constraint solver behaviour.+-}++-- See Note [HasField instances]+matchHasField :: DynFlags -> Class -> [Type] -> CtLoc -> TcS LookupInstResult+matchHasField dflags clas tys loc+  = do { fam_inst_envs <- getFamInstEnvs+       ; rdr_env       <- getGlobalRdrEnvTcS+       ; case tys of+           -- We are matching HasField {k} x r a...+           [_k_ty, x_ty, r_ty, a_ty]+               -- x should be a literal string+             | Just x <- isStrLitTy x_ty+               -- r should be an applied type constructor+             , Just (tc, args) <- tcSplitTyConApp_maybe r_ty+               -- use representation tycon (if data family); it has the fields+             , let r_tc = fstOf3 (tcLookupDataFamInst fam_inst_envs tc args)+               -- x should be a field of r+             , Just fl <- lookupTyConFieldLabel x r_tc+               -- the field selector should be in scope+             , Just gre <- lookupGRE_FieldLabel rdr_env fl++             -> do { sel_id <- tcLookupId (flSelector fl)+                   ; (tv_prs, preds, sel_ty) <- tcInstType newMetaTyVars sel_id++                         -- The first new wanted constraint equates the actual+                         -- type of the selector with the type (r -> a) within+                         -- the HasField x r a dictionary.  The preds will+                         -- typically be empty, but if the datatype has a+                         -- "stupid theta" then we have to include it here.+                   ; let theta = mkPrimEqPred sel_ty (mkFunTy r_ty a_ty) : preds++                         -- Use the equality proof to cast the selector Id to+                         -- type (r -> a), then use the newtype coercion to cast+                         -- it to a HasField dictionary.+                         mk_ev (ev1:evs) = EvSelector sel_id tvs evs `EvCast` co+                           where+                             co = mkTcSubCo (evTermCoercion ev1)+                                      `mkTcTransCo` mkTcSymCo co2+                         mk_ev [] = panic "matchHasField.mk_ev"++                         Just (_, co2) = tcInstNewTyCon_maybe (classTyCon clas)+                                                              tys++                         tvs = mkTyVarTys (map snd tv_prs)++                     -- The selector must not be "naughty" (i.e. the field+                     -- cannot have an existentially quantified type), and+                     -- it must not be higher-rank.+                   ; if not (isNaughtyRecordSelector sel_id) && isTauTy sel_ty+                     then do { addUsedGRE True gre+                             ; return GenInst { lir_new_theta = theta+                                              , lir_mk_ev     = mk_ev+                                              , lir_safe_over = True+                                              } }+                     else matchInstEnv dflags clas tys loc }++           _ -> matchInstEnv dflags clas tys loc }
+ typecheck/TcMType.hs view
@@ -0,0 +1,1703 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Monadic type operations++This module contains monadic operations over types that contain+mutable type variables+-}++{-# LANGUAGE CPP, TupleSections, MultiWayIf #-}++module TcMType (+  TcTyVar, TcKind, TcType, TcTauType, TcThetaType, TcTyVarSet,++  --------------------------------+  -- Creating new mutable type variables+  newFlexiTyVar,+  newFlexiTyVarTy,              -- Kind -> TcM TcType+  newFlexiTyVarTys,             -- Int -> Kind -> TcM [TcType]+  newOpenFlexiTyVarTy, newOpenTypeKind,+  newMetaKindVar, newMetaKindVars, newMetaTyVarTyAtLevel,+  cloneMetaTyVar,+  newFmvTyVar, newFskTyVar,++  readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef,+  newMetaDetails, isFilledMetaTyVar, isUnfilledMetaTyVar,++  --------------------------------+  -- Expected types+  ExpType(..), ExpSigmaType, ExpRhoType,+  mkCheckExpType,+  newInferExpType, newInferExpTypeInst, newInferExpTypeNoInst,+  readExpType, readExpType_maybe,+  expTypeToType, checkingExpType_maybe, checkingExpType,+  tauifyExpType, inferResultToType,++  --------------------------------+  -- Creating fresh type variables for pm checking+  genInstSkolTyVarsX,++  --------------------------------+  -- Creating new evidence variables+  newEvVar, newEvVars, newDict,+  newWanted, newWanteds, cloneWanted, cloneWC,+  emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars,+  newTcEvBinds, addTcEvBind,++  newCoercionHole, fillCoercionHole, isFilledCoercionHole,+  unpackCoercionHole, unpackCoercionHole_maybe,+  checkCoercionHole,++  --------------------------------+  -- Instantiation+  newMetaTyVars, newMetaTyVarX, newMetaTyVarsX,+  newMetaSigTyVars, newMetaSigTyVarX,+  newSigTyVar, newWildCardX,+  tcInstType,+  tcInstSkolTyVars,tcInstSkolTyVarsX,+  tcInstSuperSkolTyVarsX,+  tcSkolDFunType, tcSuperSkolTyVars,++  instSkolTyCoVars, freshenTyVarBndrs, freshenCoVarBndrsX,++  --------------------------------+  -- Zonking and tidying+  zonkTidyTcType, zonkTidyOrigin,+  mkTypeErrorThing, mkTypeErrorThingArgs,+  tidyEvVar, tidyCt, tidySkolemInfo,+  skolemiseRuntimeUnk,+  zonkTcTyVar, zonkTcTyVars, zonkTcTyVarToTyVar,+  zonkTyCoVarsAndFV, zonkTcTypeAndFV,+  zonkTyCoVarsAndFVList,+  zonkTcTypeAndSplitDepVars, zonkTcTypesAndSplitDepVars,+  zonkQuantifiedTyVar, defaultTyVar,+  quantifyTyVars, quantifyZonkedTyVars,+  zonkTcTyCoVarBndr, zonkTcTyVarBinder,+  zonkTcType, zonkTcTypes, zonkCo,+  zonkTyCoVarKind, zonkTcTypeMapper,++  zonkEvVar, zonkWC, zonkSimples, zonkId, zonkCt, zonkSkolemInfo,++  tcGetGlobalTyCoVars,++  ------------------------------+  -- Levity polymorphism+  ensureNotLevPoly, checkForLevPoly, checkForLevPolyX, formatLevPolyErr+  ) where++#include "HsVersions.h"++-- friends:+import TyCoRep+import TcType+import Type+import Kind+import Coercion+import Class+import Var++-- others:+import TcRnMonad        -- TcType, amongst others+import TcEvidence+import Id+import Name+import VarSet+import TysWiredIn+import TysPrim+import VarEnv+import NameEnv+import PrelNames+import Util+import Outputable+import FastString+import SrcLoc+import Bag+import Pair+import UniqSet+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Maybes+import Data.List        ( mapAccumL )+import Control.Arrow    ( second )++{-+************************************************************************+*                                                                      *+        Kind variables+*                                                                      *+************************************************************************+-}++mkKindName :: Unique -> Name+mkKindName unique = mkSystemName unique kind_var_occ++kind_var_occ :: OccName -- Just one for all MetaKindVars+                        -- They may be jiggled by tidying+kind_var_occ = mkOccName tvName "k"++newMetaKindVar :: TcM TcKind+newMetaKindVar = do { uniq <- newUnique+                    ; details <- newMetaDetails TauTv+                    ; let kv = mkTcTyVar (mkKindName uniq) liftedTypeKind details+                    ; return (mkTyVarTy kv) }++newMetaKindVars :: Int -> TcM [TcKind]+newMetaKindVars n = mapM (\ _ -> newMetaKindVar) (nOfThem n ())++{-+************************************************************************+*                                                                      *+     Evidence variables; range over constraints we can abstract over+*                                                                      *+************************************************************************+-}++newEvVars :: TcThetaType -> TcM [EvVar]+newEvVars theta = mapM newEvVar theta++--------------++newEvVar :: TcPredType -> TcRnIf gbl lcl EvVar+-- Creates new *rigid* variables for predicates+newEvVar ty = do { name <- newSysName (predTypeOccName ty)+                 ; return (mkLocalIdOrCoVar name ty) }++newWanted :: CtOrigin -> Maybe TypeOrKind -> PredType -> TcM CtEvidence+-- Deals with both equality and non-equality predicates+newWanted orig t_or_k pty+  = do loc <- getCtLocM orig t_or_k+       d <- if isEqPred pty then HoleDest  <$> newCoercionHole+                            else EvVarDest <$> newEvVar pty+       return $ CtWanted { ctev_dest = d+                         , ctev_pred = pty+                         , ctev_nosh = WDeriv+                         , ctev_loc = loc }++newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence]+newWanteds orig = mapM (newWanted orig Nothing)++cloneWanted :: Ct -> TcM CtEvidence+cloneWanted ct+  = newWanted (ctEvOrigin ev) Nothing (ctEvPred ev)+  where+    ev = ctEvidence ct++cloneWC :: WantedConstraints -> TcM WantedConstraints+cloneWC wc@(WC { wc_simple = simples, wc_impl = implics })+  = do { simples' <- mapBagM clone_one simples+       ; implics' <- mapBagM clone_implic implics+       ; return (wc { wc_simple = simples', wc_impl = implics' }) }+  where+    clone_one ct = do { ev <- cloneWanted ct; return (mkNonCanonical ev) }++    clone_implic implic@(Implic { ic_wanted = inner_wanted })+      = do { inner_wanted' <- cloneWC inner_wanted+           ; return (implic { ic_wanted = inner_wanted' }) }++-- | Emits a new Wanted. Deals with both equalities and non-equalities.+emitWanted :: CtOrigin -> TcPredType -> TcM EvTerm+emitWanted origin pty+  = do { ev <- newWanted origin Nothing pty+       ; emitSimple $ mkNonCanonical ev+       ; return $ ctEvTerm ev }++-- | Emits a new equality constraint+emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion+emitWantedEq origin t_or_k role ty1 ty2+  = do { hole <- newCoercionHole+       ; loc <- getCtLocM origin (Just t_or_k)+       ; emitSimple $ mkNonCanonical $+         CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole+                  , ctev_nosh = WDeriv, ctev_loc = loc }+       ; return (mkHoleCo hole role ty1 ty2) }+  where+    pty = mkPrimEqPredRole role ty1 ty2++-- | Creates a new EvVar and immediately emits it as a Wanted.+-- No equality predicates here.+emitWantedEvVar :: CtOrigin -> TcPredType -> TcM EvVar+emitWantedEvVar origin ty+  = do { new_cv <- newEvVar ty+       ; loc <- getCtLocM origin Nothing+       ; let ctev = CtWanted { ctev_dest = EvVarDest new_cv+                             , ctev_pred = ty+                             , ctev_nosh = WDeriv+                             , ctev_loc  = loc }+       ; emitSimple $ mkNonCanonical ctev+       ; return new_cv }++emitWantedEvVars :: CtOrigin -> [TcPredType] -> TcM [EvVar]+emitWantedEvVars orig = mapM (emitWantedEvVar orig)++newDict :: Class -> [TcType] -> TcM DictId+newDict cls tys+  = do { name <- newSysName (mkDictOcc (getOccName cls))+       ; return (mkLocalId name (mkClassPred cls tys)) }++predTypeOccName :: PredType -> OccName+predTypeOccName ty = case classifyPredType ty of+    ClassPred cls _ -> mkDictOcc (getOccName cls)+    EqPred _ _ _    -> mkVarOccFS (fsLit "cobox")+    IrredPred _     -> mkVarOccFS (fsLit "irred")++{-+************************************************************************+*                                                                      *+        Coercion holes+*                                                                      *+************************************************************************+-}++newCoercionHole :: TcM CoercionHole+newCoercionHole+  = do { u <- newUnique+       ; traceTc "New coercion hole:" (ppr u)+       ; ref <- newMutVar Nothing+       ; return $ CoercionHole u ref }++-- | Put a value in a coercion hole+fillCoercionHole :: CoercionHole -> Coercion -> TcM ()+fillCoercionHole (CoercionHole u ref) co+  = do {+#ifdef DEBUG+       ; cts <- readTcRef ref+       ; whenIsJust cts $ \old_co ->+         pprPanic "Filling a filled coercion hole" (ppr u $$ ppr co $$ ppr old_co)+#endif+       ; traceTc "Filling coercion hole" (ppr u <+> text ":=" <+> ppr co)+       ; writeTcRef ref (Just co) }++-- | Is a coercion hole filled in?+isFilledCoercionHole :: CoercionHole -> TcM Bool+isFilledCoercionHole (CoercionHole _ ref) = isJust <$> readTcRef ref++-- | Retrieve the contents of a coercion hole. Panics if the hole+-- is unfilled+unpackCoercionHole :: CoercionHole -> TcM Coercion+unpackCoercionHole hole+  = do { contents <- unpackCoercionHole_maybe hole+       ; case contents of+           Just co -> return co+           Nothing -> pprPanic "Unfilled coercion hole" (ppr hole) }++-- | Retrieve the contents of a coercion hole, if it is filled+unpackCoercionHole_maybe :: CoercionHole -> TcM (Maybe Coercion)+unpackCoercionHole_maybe (CoercionHole _ ref) = readTcRef ref++-- | Check that a coercion is appropriate for filling a hole. (The hole+-- itself is needed only for printing. NB: This must be /lazy/ in the coercion,+-- as it's used in TcHsSyn in the presence of knots.+-- Always returns the checked coercion, but this return value is necessary+-- so that the input coercion is forced only when the output is forced.+checkCoercionHole :: Coercion -> CoercionHole -> Role -> Type -> Type -> TcM Coercion+checkCoercionHole co h r t1 t2+-- co is already zonked, but t1 and t2 might not be+  | debugIsOn+  = do { t1 <- zonkTcType t1+       ; t2 <- zonkTcType t2+       ; let (Pair _t1 _t2, _role) = coercionKindRole co+       ; return $+         ASSERT2( t1 `eqType` _t1 && t2 `eqType` _t2 && r == _role+                , (text "Bad coercion hole" <+>+                   ppr h <> colon <+> vcat [ ppr _t1, ppr _t2, ppr _role+                                           , ppr co, ppr t1, ppr t2+                                           , ppr r ]) )+         co }+  | otherwise+  = return co++{-+************************************************************************+*+    Expected types+*+************************************************************************++Note [ExpType]+~~~~~~~~~~~~~~++An ExpType is used as the "expected type" when type-checking an expression.+An ExpType can hold a "hole" that can be filled in by the type-checker.+This allows us to have one tcExpr that works in both checking mode and+synthesis mode (that is, bidirectional type-checking). Previously, this+was achieved by using ordinary unification variables, but we don't need+or want that generality. (For example, #11397 was caused by doing the+wrong thing with unification variables.) Instead, we observe that these+holes should++1. never be nested+2. never appear as the type of a variable+3. be used linearly (never be duplicated)++By defining ExpType, separately from Type, we can achieve goals 1 and 2+statically.++See also [wiki:Typechecking]++Note [TcLevel of ExpType]+~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++  data G a where+    MkG :: G Bool++  foo MkG = True++This is a classic untouchable-variable / ambiguous GADT return type+scenario. But, with ExpTypes, we'll be inferring the type of the RHS.+And, because there is only one branch of the case, we won't trigger+Note [Case branches must never infer a non-tau type] of TcMatches.+We thus must track a TcLevel in an Inferring ExpType. If we try to+fill the ExpType and find that the TcLevels don't work out, we+fill the ExpType with a tau-tv at the low TcLevel, hopefully to+be worked out later by some means. This is triggered in+test gadt/gadt-escape1.++-}++-- actual data definition is in TcType++-- | Make an 'ExpType' suitable for inferring a type of kind * or #.+newInferExpTypeNoInst :: TcM ExpSigmaType+newInferExpTypeNoInst = newInferExpType False++newInferExpTypeInst :: TcM ExpRhoType+newInferExpTypeInst = newInferExpType True++newInferExpType :: Bool -> TcM ExpType+newInferExpType inst+  = do { u <- newUnique+       ; tclvl <- getTcLevel+       ; traceTc "newOpenInferExpType" (ppr u <+> ppr inst <+> ppr tclvl)+       ; ref <- newMutVar Nothing+       ; return (Infer (IR { ir_uniq = u, ir_lvl = tclvl+                           , ir_ref = ref, ir_inst = inst })) }++-- | Extract a type out of an ExpType, if one exists. But one should always+-- exist. Unless you're quite sure you know what you're doing.+readExpType_maybe :: ExpType -> TcM (Maybe TcType)+readExpType_maybe (Check ty)                   = return (Just ty)+readExpType_maybe (Infer (IR { ir_ref = ref})) = readMutVar ref++-- | Extract a type out of an ExpType. Otherwise, panics.+readExpType :: ExpType -> TcM TcType+readExpType exp_ty+  = do { mb_ty <- readExpType_maybe exp_ty+       ; case mb_ty of+           Just ty -> return ty+           Nothing -> pprPanic "Unknown expected type" (ppr exp_ty) }++-- | Returns the expected type when in checking mode.+checkingExpType_maybe :: ExpType -> Maybe TcType+checkingExpType_maybe (Check ty) = Just ty+checkingExpType_maybe _          = Nothing++-- | Returns the expected type when in checking mode. Panics if in inference+-- mode.+checkingExpType :: String -> ExpType -> TcType+checkingExpType _   (Check ty) = ty+checkingExpType err et         = pprPanic "checkingExpType" (text err $$ ppr et)++tauifyExpType :: ExpType -> TcM ExpType+-- ^ Turn a (Infer hole) type into a (Check alpha),+-- where alpha is a fresh unification variable+tauifyExpType (Check ty)      = return (Check ty)  -- No-op for (Check ty)+tauifyExpType (Infer inf_res) = do { ty <- inferResultToType inf_res+                                   ; return (Check ty) }++-- | Extracts the expected type if there is one, or generates a new+-- TauTv if there isn't.+expTypeToType :: ExpType -> TcM TcType+expTypeToType (Check ty)      = return ty+expTypeToType (Infer inf_res) = inferResultToType inf_res++inferResultToType :: InferResult -> TcM Type+inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl+                      , ir_ref = ref })+  = do { rr  <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy+       ; tau <- newMetaTyVarTyAtLevel tc_lvl (tYPE rr)+             -- See Note [TcLevel of ExpType]+       ; writeMutVar ref (Just tau)+       ; traceTc "Forcing ExpType to be monomorphic:"+                 (ppr u <+> text ":=" <+> ppr tau)+       ; return tau }+++{- *********************************************************************+*                                                                      *+        SkolemTvs (immutable)+*                                                                      *+********************************************************************* -}++tcInstType :: ([TyVar] -> TcM (TCvSubst, [TcTyVar]))+                   -- ^ How to instantiate the type variables+           -> Id                                            -- ^ Type to instantiate+           -> TcM ([(Name, TcTyVar)], TcThetaType, TcType)  -- ^ Result+                -- (type vars, preds (incl equalities), rho)+tcInstType inst_tyvars id+  = case tcSplitForAllTys (idType id) of+        ([],    rho) -> let     -- There may be overloading despite no type variables;+                                --      (?x :: Int) => Int -> Int+                                (theta, tau) = tcSplitPhiTy rho+                            in+                            return ([], theta, tau)++        (tyvars, rho) -> do { (subst, tyvars') <- inst_tyvars tyvars+                            ; let (theta, tau) = tcSplitPhiTy (substTyAddInScope subst rho)+                                  tv_prs       = map tyVarName tyvars `zip` tyvars'+                            ; return (tv_prs, theta, tau) }++tcSkolDFunType :: DFunId -> TcM ([TcTyVar], TcThetaType, TcType)+-- Instantiate a type signature with skolem constants.+-- We could give them fresh names, but no need to do so+tcSkolDFunType dfun+  = do { (tv_prs, theta, tau) <- tcInstType tcInstSuperSkolTyVars dfun+       ; return (map snd tv_prs, theta, tau) }++tcSuperSkolTyVars :: [TyVar] -> (TCvSubst, [TcTyVar])+-- Make skolem constants, but do *not* give them new names, as above+-- Moreover, make them "super skolems"; see comments with superSkolemTv+-- see Note [Kind substitution when instantiating]+-- Precondition: tyvars should be ordered by scoping+tcSuperSkolTyVars = mapAccumL tcSuperSkolTyVar emptyTCvSubst++tcSuperSkolTyVar :: TCvSubst -> TyVar -> (TCvSubst, TcTyVar)+tcSuperSkolTyVar subst tv+  = (extendTvSubstWithClone subst tv new_tv, new_tv)+  where+    kind   = substTyUnchecked subst (tyVarKind tv)+    new_tv = mkTcTyVar (tyVarName tv) kind superSkolemTv++-- | Given a list of @['TyVar']@, skolemize the type variables,+-- returning a substitution mapping the original tyvars to the+-- skolems, and the list of newly bound skolems.  See also+-- tcInstSkolTyVars' for a precondition.  The resulting+-- skolems are non-overlappable; see Note [Overlap and deriving]+-- for an example where this matters.+tcInstSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])+tcInstSkolTyVars = tcInstSkolTyVarsX emptyTCvSubst++tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])+tcInstSkolTyVarsX = tcInstSkolTyVars' False++tcInstSuperSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])+tcInstSuperSkolTyVars = tcInstSuperSkolTyVarsX emptyTCvSubst++tcInstSuperSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])+tcInstSuperSkolTyVarsX subst = tcInstSkolTyVars' True subst++tcInstSkolTyVars' :: Bool -> TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])+-- Precondition: tyvars should be ordered (kind vars first)+-- see Note [Kind substitution when instantiating]+-- Get the location from the monad; this is a complete freshening operation+tcInstSkolTyVars' overlappable subst tvs+  = do { loc <- getSrcSpanM+       ; lvl <- getTcLevel+       ; instSkolTyCoVarsX (mkTcSkolTyVar lvl loc overlappable) subst tvs }++mkTcSkolTyVar :: TcLevel -> SrcSpan -> Bool -> TcTyVarMaker+mkTcSkolTyVar lvl loc overlappable+  = \ uniq old_name kind -> mkTcTyVar (mkInternalName uniq (getOccName old_name) loc)+                                      kind details+  where+    details = SkolemTv (pushTcLevel lvl) overlappable+              -- NB: skolems bump the level++------------------+freshenTyVarBndrs :: [TyVar] -> TcRnIf gbl lcl (TCvSubst, [TyVar])+-- ^ Give fresh uniques to a bunch of TyVars, but they stay+--   as TyVars, rather than becoming TcTyVars+-- Used in FamInst.newFamInst, and Inst.newClsInst+freshenTyVarBndrs = instSkolTyCoVars mk_tv+  where+    mk_tv uniq old_name kind = mkTyVar (setNameUnique old_name uniq) kind++freshenCoVarBndrsX :: TCvSubst -> [CoVar] -> TcRnIf gbl lcl (TCvSubst, [CoVar])+-- ^ Give fresh uniques to a bunch of CoVars+-- Used in FamInst.newFamInst+freshenCoVarBndrsX subst = instSkolTyCoVarsX mk_cv subst+  where+    mk_cv uniq old_name kind = mkCoVar (setNameUnique old_name uniq) kind++------------------+type TcTyVarMaker = Unique -> Name -> Kind -> TyCoVar+instSkolTyCoVars :: TcTyVarMaker -> [TyVar] -> TcRnIf gbl lcl (TCvSubst, [TyCoVar])+instSkolTyCoVars mk_tcv = instSkolTyCoVarsX mk_tcv emptyTCvSubst++instSkolTyCoVarsX :: TcTyVarMaker+                  -> TCvSubst -> [TyCoVar] -> TcRnIf gbl lcl (TCvSubst, [TyCoVar])+instSkolTyCoVarsX mk_tcv = mapAccumLM (instSkolTyCoVarX mk_tcv)++instSkolTyCoVarX :: TcTyVarMaker+                 -> TCvSubst -> TyCoVar -> TcRnIf gbl lcl (TCvSubst, TyCoVar)+instSkolTyCoVarX mk_tcv subst tycovar+  = do  { uniq <- newUnique  -- using a new unique is critical. See+                             -- Note [Skolems in zonkSyntaxExpr] in TcHsSyn+        ; let new_tcv = mk_tcv uniq old_name kind+              subst1 | isTyVar new_tcv+                     = extendTvSubstWithClone subst tycovar new_tcv+                     | otherwise+                     = extendCvSubstWithClone subst tycovar new_tcv+        ; return (subst1, new_tcv) }+  where+    old_name = tyVarName tycovar+    kind     = substTyUnchecked subst (tyVarKind tycovar)++newFskTyVar :: TcType -> TcM TcTyVar+newFskTyVar fam_ty+  = do { uniq <- newUnique+       ; let name = mkSysTvName uniq (fsLit "fsk")+       ; return (mkTcTyVar name (typeKind fam_ty) (FlatSkol fam_ty)) }+{-+Note [Kind substitution when instantiating]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we instantiate a bunch of kind and type variables, first we+expect them to be topologically sorted.+Then we have to instantiate the kind variables, build a substitution+from old variables to the new variables, then instantiate the type+variables substituting the original kind.++Exemple: If we want to instantiate+  [(k1 :: *), (k2 :: *), (a :: k1 -> k2), (b :: k1)]+we want+  [(?k1 :: *), (?k2 :: *), (?a :: ?k1 -> ?k2), (?b :: ?k1)]+instead of the buggous+  [(?k1 :: *), (?k2 :: *), (?a :: k1 -> k2), (?b :: k1)]+++************************************************************************+*                                                                      *+        MetaTvs (meta type variables; mutable)+*                                                                      *+************************************************************************+-}++mkMetaTyVarName :: Unique -> FastString -> Name+-- Makes a /System/ Name, which is eagerly eliminated by+-- the unifier; see TcUnify.nicer_to_update_tv1, and+-- TcCanonical.canEqTyVarTyVar (nicer_to_update_tv2)+mkMetaTyVarName uniq str = mkSysTvName uniq str++newSigTyVar :: Name -> Kind -> TcM TcTyVar+newSigTyVar name kind+  = do { details <- newMetaDetails SigTv+       ; return (mkTcTyVar name kind details) }++newFmvTyVar :: TcType -> TcM TcTyVar+-- Very like newMetaTyVar, except sets mtv_tclvl to one less+-- so that the fmv is untouchable.+newFmvTyVar fam_ty+  = do { uniq <- newUnique+       ; ref  <- newMutVar Flexi+       ; cur_lvl <- getTcLevel+       ; let details = MetaTv { mtv_info  = FlatMetaTv+                              , mtv_ref   = ref+                              , mtv_tclvl = fmvTcLevel cur_lvl }+             name = mkMetaTyVarName uniq (fsLit "s")+       ; return (mkTcTyVar name (typeKind fam_ty) details) }++newMetaDetails :: MetaInfo -> TcM TcTyVarDetails+newMetaDetails info+  = do { ref <- newMutVar Flexi+       ; tclvl <- getTcLevel+       ; return (MetaTv { mtv_info = info+                        , mtv_ref = ref+                        , mtv_tclvl = tclvl }) }++cloneMetaTyVar :: TcTyVar -> TcM TcTyVar+cloneMetaTyVar tv+  = ASSERT( isTcTyVar tv )+    do  { uniq <- newUnique+        ; ref  <- newMutVar Flexi+        ; let name'    = setNameUnique (tyVarName tv) uniq+              details' = case tcTyVarDetails tv of+                           details@(MetaTv {}) -> details { mtv_ref = ref }+                           _ -> pprPanic "cloneMetaTyVar" (ppr tv)+        ; return (mkTcTyVar name' (tyVarKind tv) details') }++-- Works for both type and kind variables+readMetaTyVar :: TyVar -> TcM MetaDetails+readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar )+                      readMutVar (metaTyVarRef tyvar)++isFilledMetaTyVar :: TyVar -> TcM Bool+-- True of a filled-in (Indirect) meta type variable+isFilledMetaTyVar tv+  | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv+  = do  { details <- readMutVar ref+        ; return (isIndirect details) }+  | otherwise = return False++isUnfilledMetaTyVar :: TyVar -> TcM Bool+-- True of a un-filled-in (Flexi) meta type variable+isUnfilledMetaTyVar tv+  | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv+  = do  { details <- readMutVar ref+        ; return (isFlexi details) }+  | otherwise = return False++--------------------+-- Works with both type and kind variables+writeMetaTyVar :: TcTyVar -> TcType -> TcM ()+-- Write into a currently-empty MetaTyVar++writeMetaTyVar tyvar ty+  | not debugIsOn+  = writeMetaTyVarRef tyvar (metaTyVarRef tyvar) ty++-- Everything from here on only happens if DEBUG is on+  | not (isTcTyVar tyvar)+  = WARN( True, text "Writing to non-tc tyvar" <+> ppr tyvar )+    return ()++  | MetaTv { mtv_ref = ref } <- tcTyVarDetails tyvar+  = writeMetaTyVarRef tyvar ref ty++  | otherwise+  = WARN( True, text "Writing to non-meta tyvar" <+> ppr tyvar )+    return ()++--------------------+writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM ()+-- Here the tyvar is for error checking only;+-- the ref cell must be for the same tyvar+writeMetaTyVarRef tyvar ref ty+  | not debugIsOn+  = do { traceTc "writeMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)+                                   <+> text ":=" <+> ppr ty)+       ; writeTcRef ref (Indirect ty) }++  -- Everything from here on only happens if DEBUG is on+  | otherwise+  = do { meta_details <- readMutVar ref;+       -- Zonk kinds to allow the error check to work+       ; zonked_tv_kind <- zonkTcType tv_kind+       ; zonked_ty_kind <- zonkTcType ty_kind+       ; let kind_check_ok = isPredTy tv_kind  -- Don't check kinds for updates+                                               -- to coercion variables+                          || tcEqKind zonked_ty_kind zonked_tv_kind++             kind_msg = hang (text "Ill-kinded update to meta tyvar")+                           2 (    ppr tyvar <+> text "::" <+> (ppr tv_kind $$ ppr zonked_tv_kind)+                              <+> text ":="+                              <+> ppr ty <+> text "::" <+> (ppr ty_kind $$ ppr zonked_ty_kind) )++       ; traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty)++       -- Check for double updates+       ; MASSERT2( isFlexi meta_details, double_upd_msg meta_details )++       -- Check for level OK+       -- See Note [Level check when unifying]+       ; MASSERT2( level_check_ok, level_check_msg )++       -- Check Kinds ok+       ; MASSERT2( kind_check_ok, kind_msg )++       -- Do the write+       ; writeMutVar ref (Indirect ty) }+  where+    tv_kind = tyVarKind tyvar+    ty_kind = typeKind ty++    tv_lvl = tcTyVarLevel tyvar+    ty_lvl = tcTypeLevel ty++    level_check_ok = isFmvTyVar tyvar+                  || not (ty_lvl `strictlyDeeperThan` tv_lvl)+    level_check_msg = ppr ty_lvl $$ ppr tv_lvl $$ ppr tyvar $$ ppr ty++    double_upd_msg details = hang (text "Double update of meta tyvar")+                                2 (ppr tyvar $$ ppr details)+++{- Note [Level check when unifying]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When unifying+     alpha:lvl := ty+we expect that the TcLevel of 'ty' will be <= lvl.+However, during unflatting we do+     fuv:l := ty:(l+1)+which is usually wrong; hence the check isFmmvTyVar in level_check_ok.+See Note [TcLevel assignment] in TcType.+-}++{-+% Generating fresh variables for pattern match check+-}++-- UNINSTANTIATED VERSION OF tcInstSkolTyCoVars+genInstSkolTyVarsX :: SrcSpan -> TCvSubst -> [TyVar]+                   -> TcRnIf gbl lcl (TCvSubst, [TcTyVar])+-- Precondition: tyvars should be scoping-ordered+-- see Note [Kind substitution when instantiating]+-- Get the location from the monad; this is a complete freshening operation+genInstSkolTyVarsX loc subst tvs+  = instSkolTyCoVarsX (mkTcSkolTyVar topTcLevel loc False) subst tvs++{-+************************************************************************+*                                                                      *+        MetaTvs: TauTvs+*                                                                      *+************************************************************************++Note [Never need to instantiate coercion variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+With coercion variables sloshing around in types, it might seem that we+sometimes need to instantiate coercion variables. This would be problematic,+because coercion variables inhabit unboxed equality (~#), and the constraint+solver thinks in terms only of boxed equality (~). The solution is that+we never need to instantiate coercion variables in the first place.++The tyvars that we need to instantiate come from the types of functions,+data constructors, and patterns. These will never be quantified over+coercion variables, except for the special case of the promoted Eq#. But,+that can't ever appear in user code, so we're safe!+-}++newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar+-- Make a new meta tyvar out of thin air+newAnonMetaTyVar meta_info kind+  = do  { uniq <- newUnique+        ; let name = mkMetaTyVarName uniq s+              s = case meta_info of+                        TauTv       -> fsLit "t"+                        FlatMetaTv  -> fsLit "fmv"+                        SigTv       -> fsLit "a"+        ; details <- newMetaDetails meta_info+        ; return (mkTcTyVar name kind details) }++newFlexiTyVar :: Kind -> TcM TcTyVar+newFlexiTyVar kind = newAnonMetaTyVar TauTv kind++newFlexiTyVarTy :: Kind -> TcM TcType+newFlexiTyVarTy kind = do+    tc_tyvar <- newFlexiTyVar kind+    return (mkTyVarTy tc_tyvar)++newFlexiTyVarTys :: Int -> Kind -> TcM [TcType]+newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind)++newOpenTypeKind :: TcM TcKind+newOpenTypeKind+  = do { rr <- newFlexiTyVarTy runtimeRepTy+       ; return (tYPE rr) }++-- | Create a tyvar that can be a lifted or unlifted type.+-- Returns alpha :: TYPE kappa, where both alpha and kappa are fresh+newOpenFlexiTyVarTy :: TcM TcType+newOpenFlexiTyVarTy+  = do { kind <- newOpenTypeKind+       ; newFlexiTyVarTy kind }++newMetaSigTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])+newMetaSigTyVars = mapAccumLM newMetaSigTyVarX emptyTCvSubst++newMetaTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])+-- Instantiate with META type variables+-- Note that this works for a sequence of kind, type, and coercion variables+-- variables.  Eg    [ (k:*), (a:k->k) ]+--             Gives [ (k7:*), (a8:k7->k7) ]+newMetaTyVars = mapAccumLM newMetaTyVarX emptyTCvSubst+    -- emptyTCvSubst has an empty in-scope set, but that's fine here+    -- Since the tyvars are freshly made, they cannot possibly be+    -- captured by any existing for-alls.++newMetaTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)+-- Make a new unification variable tyvar whose Name and Kind come from+-- an existing TyVar. We substitute kind variables in the kind.+newMetaTyVarX subst tyvar = new_meta_tv_x TauTv subst tyvar++newMetaTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])+-- Just like newMetaTyVars, but start with an existing substitution.+newMetaTyVarsX subst = mapAccumLM newMetaTyVarX subst++newMetaSigTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)+-- Just like newMetaTyVarX, but make a SigTv+newMetaSigTyVarX subst tyvar = new_meta_tv_x SigTv subst tyvar++newWildCardX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)+newWildCardX subst tv+  = do { new_tv <- newAnonMetaTyVar TauTv (substTy subst (tyVarKind tv))+       ; return (extendTvSubstWithClone subst tv new_tv, new_tv) }++new_meta_tv_x :: MetaInfo -> TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)+new_meta_tv_x info subst tv+  = do  { uniq <- newUnique+        ; details <- newMetaDetails info+        ; let name   = mkSystemName uniq (getOccName tv)+                       -- See Note [Name of an instantiated type variable]+              kind   = substTyUnchecked subst (tyVarKind tv)+                       -- NOTE: Trac #12549 is fixed so we could use+                       -- substTy here, but the tc_infer_args problem+                       -- is not yet fixed so leaving as unchecked for now.+                       -- OLD NOTE:+                       -- Unchecked because we call newMetaTyVarX from+                       -- tcInstBinderX, which is called from tc_infer_args+                       -- which does not yet take enough trouble to ensure+                       -- the in-scope set is right; e.g. Trac #12785 trips+                       -- if we use substTy here+              new_tv = mkTcTyVar name kind details+              subst1 = extendTvSubstWithClone subst tv new_tv+        ; return (subst1, new_tv) }++newMetaTyVarTyAtLevel :: TcLevel -> TcKind -> TcM TcType+newMetaTyVarTyAtLevel tc_lvl kind+  = do  { uniq <- newUnique+        ; ref  <- newMutVar Flexi+        ; let name = mkMetaTyVarName uniq (fsLit "p")+              details = MetaTv { mtv_info  = TauTv+                               , mtv_ref   = ref+                               , mtv_tclvl = tc_lvl }+        ; return (mkTyVarTy (mkTcTyVar name kind details)) }++{- Note [Name of an instantiated type variable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+At the moment we give a unification variable a System Name, which+influences the way it is tidied; see TypeRep.tidyTyVarBndr.++************************************************************************+*                                                                      *+             Quantification+*                                                                      *+************************************************************************++Note [quantifyTyVars]+~~~~~~~~~~~~~~~~~~~~~+quantifyTyVars is given the free vars of a type that we+are about to wrap in a forall.++It takes these free type/kind variables (partitioned into dependent and+non-dependent variables) and+  1. Zonks them and remove globals and covars+  2. Extends kvs1 with free kind vars in the kinds of tvs (removing globals)+  3. Calls zonkQuantifiedTyVar on each++Step (2) is often unimportant, because the kind variable is often+also free in the type.  Eg+     Typeable k (a::k)+has free vars {k,a}.  But the type (see Trac #7916)+    (f::k->*) (a::k)+has free vars {f,a}, but we must add 'k' as well! Hence step (3).++* This function distinguishes between dependent and non-dependent+  variables only to keep correct defaulting behavior with -XNoPolyKinds.+  With -XPolyKinds, it treats both classes of variables identically.++* quantifyTyVars never quantifies over+    - a coercion variable+    - a runtime-rep variable++Note [quantifyTyVars determinism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The results of quantifyTyVars are wrapped in a forall and can end up in the+interface file. One such example is inferred type signatures. They also affect+the results of optimizations, for example worker-wrapper. This means that to+get deterministic builds quantifyTyVars needs to be deterministic.++To achieve this CandidatesQTvs is backed by deterministic sets which allows them+to be later converted to a list in a deterministic order.++For more information about deterministic sets see+Note [Deterministic UniqFM] in UniqDFM.+-}++quantifyTyVars, quantifyZonkedTyVars+  :: TcTyCoVarSet     -- global tvs+  -> CandidatesQTvs   -- See Note [Dependent type variables] in TcType+  -> TcM [TcTyVar]+-- See Note [quantifyTyVars]+-- Can be given a mixture of TcTyVars and TyVars, in the case of+--   associated type declarations. Also accepts covars, but *never* returns any.++-- The zonked variant assumes everything is already zonked.++quantifyTyVars gbl_tvs (DV { dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs })+  = do { dep_tkvs    <- zonkTyCoVarsAndFVDSet dep_tkvs+       ; nondep_tkvs <- zonkTyCoVarsAndFVDSet nondep_tkvs+       ; gbl_tvs     <- zonkTyCoVarsAndFV gbl_tvs+       ; quantifyZonkedTyVars gbl_tvs (DV { dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs }) }++quantifyZonkedTyVars gbl_tvs dvs@(DV{ dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs })+  = do { traceTc "quantifyZonkedTyVars" (vcat [ppr dvs, ppr gbl_tvs])+       ; let all_cvs = filterVarSet isCoVar $ dVarSetToVarSet dep_tkvs+             dep_kvs = dVarSetElemsWellScoped $+                       dep_tkvs `dVarSetMinusVarSet` gbl_tvs+                                `dVarSetMinusVarSet` closeOverKinds all_cvs+                 -- dVarSetElemsWellScoped: put the kind variables into+                 --    well-scoped order.+                 --    E.g.  [k, (a::k)] not the other way roud+                 -- closeOverKinds all_cvs: do not quantify over coercion+                 --    variables, or any any tvs that a covar depends on++             nondep_tvs = dVarSetElems $+                          (nondep_tkvs `minusDVarSet` dep_tkvs)+                           `dVarSetMinusVarSet` gbl_tvs+                 -- See Note [Dependent type variables] in TcType+                 -- The `minus` dep_tkvs removes any kind-level vars+                 --    e.g. T k (a::k)   Since k appear in a kind it'll+                 --    be in dv_kvs, and is dependent. So remove it from+                 --    dv_tvs which will also contain k+                 -- No worry about dependent covars here;+                 --    they are all in dep_tkvs+                 -- No worry about scoping, because these are all+                 --    type variables+                 -- NB kinds of tvs are zonked by zonkTyCoVarsAndFV++             -- In the non-PolyKinds case, default the kind variables+             -- to *, and zonk the tyvars as usual.  Notice that this+             -- may make quantifyTyVars return a shorter list+             -- than it was passed, but that's ok+       ; poly_kinds  <- xoptM LangExt.PolyKinds+       ; dep_kvs'    <- mapMaybeM (zonk_quant (not poly_kinds)) dep_kvs+       ; nondep_tvs' <- mapMaybeM (zonk_quant False)            nondep_tvs+           -- Because of the order, any kind variables+           -- mentioned in the kinds of the nondep_tvs'+           -- now refer to the dep_kvs'++       ; traceTc "quantifyZonkedTyVars"+           (vcat [ text "globals:" <+> ppr gbl_tvs+                 , text "nondep:"  <+> pprTyVars nondep_tvs+                 , text "dep:"     <+> pprTyVars dep_kvs+                 , text "dep_kvs'" <+> pprTyVars dep_kvs'+                 , text "nondep_tvs'" <+> pprTyVars nondep_tvs' ])++       ; return (dep_kvs' ++ nondep_tvs') }+  where+    zonk_quant default_kind tkv+      | isTcTyVar tkv = zonkQuantifiedTyVar default_kind tkv+      | otherwise     = return $ Just tkv+      -- For associated types, we have the class variables+      -- in scope, and they are TyVars not TcTyVars++zonkQuantifiedTyVar :: Bool     -- True  <=> this is a kind var and -XNoPolyKinds+                                -- False <=> not a kind var or -XPolyKinds+                    -> TcTyVar+                    -> TcM (Maybe TcTyVar)+-- The quantified type variables often include meta type variables+-- we want to freeze them into ordinary type variables, and+-- default their kind (e.g. from TYPE v to TYPE Lifted)+-- The meta tyvar is updated to point to the new skolem TyVar.  Now any+-- bound occurrences of the original type variable will get zonked to+-- the immutable version.+--+-- We leave skolem TyVars alone; they are immutable.+--+-- This function is called on both kind and type variables,+-- but kind variables *only* if PolyKinds is on.+--+-- This returns a tyvar if it should be quantified over;+-- otherwise, it returns Nothing. The latter case happens for+--    * Kind variables, with -XNoPolyKinds: don't quantify over these+--    * RuntimeRep variables: we never quantify over these++zonkQuantifiedTyVar default_kind tv+  = case tcTyVarDetails tv of+      SkolemTv {} -> do { kind <- zonkTcType (tyVarKind tv)+                        ; return $ Just (setTyVarKind tv kind) }+        -- It might be a skolem type variable,+        -- for example from a user type signature++      MetaTv {}+        -> do { mb_tv <- defaultTyVar default_kind tv+              ; case mb_tv of+                  True  -> return Nothing+                  False -> do { tv' <- skolemiseUnboundMetaTyVar tv+                              ; return (Just tv') } }++      _other -> pprPanic "zonkQuantifiedTyVar" (ppr tv) -- FlatSkol, RuntimeUnk++defaultTyVar :: Bool      -- True <=> please default this kind variable to *+             -> TcTyVar   -- Always an unbound meta tyvar+             -> TcM Bool  -- True <=> defaulted away altogether++defaultTyVar default_kind tv+  | isRuntimeRepVar tv && not_sig_tv  -- We never quantify over a RuntimeRep var+  = do { traceTc "Defaulting a RuntimeRep var to LiftedRep" (ppr tv)+       ; writeMetaTyVar tv liftedRepTy+       ; return True }++  | default_kind && not_sig_tv        -- -XNoPolyKinds and this is a kind var+  = do { default_kind_var tv          -- so default it to * if possible+       ; return True }++  | otherwise+  = return False++  where+    -- Do not default SigTvs. Doing so would violate the invariants+    -- on SigTvs; see Note [Signature skolems] in TcType.+    -- Trac #13343 is an example+    not_sig_tv = not (isSigTyVar tv)++    default_kind_var :: TyVar -> TcM ()+       -- defaultKindVar is used exclusively with -XNoPolyKinds+       -- See Note [Defaulting with -XNoPolyKinds]+       -- It takes an (unconstrained) meta tyvar and defaults it.+       -- Works only on vars of type *; for other kinds, it issues an error.+    default_kind_var kv+      | isStarKind (tyVarKind kv)+      = do { traceTc "Defaulting a kind var to *" (ppr kv)+           ; writeMetaTyVar kv liftedTypeKind }+      | otherwise+      = addErr (vcat [ text "Cannot default kind variable" <+> quotes (ppr kv')+                     , text "of kind:" <+> ppr (tyVarKind kv')+                     , text "Perhaps enable PolyKinds or add a kind signature" ])+      where+        (_, kv') = tidyOpenTyCoVar emptyTidyEnv kv++skolemiseRuntimeUnk :: TcTyVar -> TcM TyVar+skolemiseRuntimeUnk tv+  = skolemise_tv tv RuntimeUnk++skolemiseUnboundMetaTyVar :: TcTyVar -> TcM TyVar+skolemiseUnboundMetaTyVar tv+  = skolemise_tv tv (SkolemTv (metaTyVarTcLevel tv) False)++skolemise_tv :: TcTyVar -> TcTyVarDetails -> TcM TyVar+-- We have a Meta tyvar with a ref-cell inside it+-- Skolemise it, so that+--   we are totally out of Meta-tyvar-land+-- We create a skolem TyVar, not a regular TyVar+--   See Note [Zonking to Skolem]+skolemise_tv tv details+  = ASSERT2( isMetaTyVar tv, ppr tv )+    do  { when debugIsOn (check_empty tv)+        ; span <- getSrcSpanM    -- Get the location from "here"+                                 -- ie where we are generalising+        ; kind <- zonkTcType (tyVarKind tv)+        ; let uniq        = getUnique tv+                -- NB: Use same Unique as original tyvar. This is+                -- important for TcHsType.splitTelescopeTvs to work properly++              tv_name     = getOccName tv+              final_name  = mkInternalName uniq tv_name span+              final_tv    = mkTcTyVar final_name kind details++        ; traceTc "Skolemising" (ppr tv <+> text ":=" <+> ppr final_tv)+        ; writeMetaTyVar tv (mkTyVarTy final_tv)+        ; return final_tv }++  where+    check_empty tv       -- [Sept 04] Check for non-empty.+      = when debugIsOn $  -- See note [Silly Type Synonym]+        do { cts <- readMetaTyVar tv+           ; case cts of+               Flexi       -> return ()+               Indirect ty -> WARN( True, ppr tv $$ ppr ty )+                              return () }++{- Note [Defaulting with -XNoPolyKinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++  data Compose f g a = Mk (f (g a))++We infer++  Compose :: forall k1 k2. (k2 -> *) -> (k1 -> k2) -> k1 -> *+  Mk :: forall k1 k2 (f :: k2 -> *) (g :: k1 -> k2) (a :: k1).+        f (g a) -> Compose k1 k2 f g a++Now, in another module, we have -XNoPolyKinds -XDataKinds in effect.+What does 'Mk mean? Pre GHC-8.0 with -XNoPolyKinds,+we just defaulted all kind variables to *. But that's no good here,+because the kind variables in 'Mk aren't of kind *, so defaulting to *+is ill-kinded.++After some debate on #11334, we decided to issue an error in this case.+The code is in defaultKindVar.++Note [What is a meta variable?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A "meta type-variable", also know as a "unification variable" is a placeholder+introduced by the typechecker for an as-yet-unknown monotype.++For example, when we see a call `reverse (f xs)`, we know that we calling+    reverse :: forall a. [a] -> [a]+So we know that the argument `f xs` must be a "list of something". But what is+the "something"? We don't know until we explore the `f xs` a bit more. So we set+out what we do know at the call of `reverse` by instantiate its type with a fresh+meta tyvar, `alpha` say. So now the type of the argument `f xs`, and of the+result, is `[alpha]`. The unification variable `alpha` stands for the+as-yet-unknown type of the elements of the list.++As type inference progresses we may learn more about `alpha`. For example, suppose+`f` has the type+    f :: forall b. b -> [Maybe b]+Then we instantiate `f`'s type with another fresh unification variable, say+`beta`; and equate `f`'s result type with reverse's argument type, thus+`[alpha] ~ [Maybe beta]`.++Now we can solve this equality to learn that `alpha ~ Maybe beta`, so we've+refined our knowledge about `alpha`. And so on.++If you found this Note useful, you may also want to have a look at+Section 5 of "Practical type inference for higher rank types" (Peyton Jones,+Vytiniotis, Weirich and Shields. J. Functional Programming. 2011).++Note [What is zonking?]+~~~~~~~~~~~~~~~~~~~~~~~+GHC relies heavily on mutability in the typechecker for efficient operation.+For this reason, throughout much of the type checking process meta type+variables (the MetaTv constructor of TcTyVarDetails) are represented by mutable+variables (known as TcRefs).++Zonking is the process of ripping out these mutable variables and replacing them+with a real Type. This involves traversing the entire type expression, but the+interesting part of replacing the mutable variables occurs in zonkTyVarOcc.++There are two ways to zonk a Type:++ * zonkTcTypeToType, which is intended to be used at the end of type-checking+   for the final zonk. It has to deal with unfilled metavars, either by filling+   it with a value like Any or failing (determined by the UnboundTyVarZonker+   used).++ * zonkTcType, which will happily ignore unfilled metavars. This is the+   appropriate function to use while in the middle of type-checking.++Note [Zonking to Skolem]+~~~~~~~~~~~~~~~~~~~~~~~~+We used to zonk quantified type variables to regular TyVars.  However, this+leads to problems.  Consider this program from the regression test suite:++  eval :: Int -> String -> String -> String+  eval 0 root actual = evalRHS 0 root actual++  evalRHS :: Int -> a+  evalRHS 0 root actual = eval 0 root actual++It leads to the deferral of an equality (wrapped in an implication constraint)++  forall a. () => ((String -> String -> String) ~ a)++which is propagated up to the toplevel (see TcSimplify.tcSimplifyInferCheck).+In the meantime `a' is zonked and quantified to form `evalRHS's signature.+This has the *side effect* of also zonking the `a' in the deferred equality+(which at this point is being handed around wrapped in an implication+constraint).++Finally, the equality (with the zonked `a') will be handed back to the+simplifier by TcRnDriver.tcRnSrcDecls calling TcSimplify.tcSimplifyTop.+If we zonk `a' with a regular type variable, we will have this regular type+variable now floating around in the simplifier, which in many places assumes to+only see proper TcTyVars.++We can avoid this problem by zonking with a skolem.  The skolem is rigid+(which we require for a quantified variable), but is still a TcTyVar that the+simplifier knows how to deal with.++Note [Silly Type Synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:+        type C u a = u  -- Note 'a' unused++        foo :: (forall a. C u a -> C u a) -> u+        foo x = ...++        bar :: Num u => u+        bar = foo (\t -> t + t)++* From the (\t -> t+t) we get type  {Num d} =>  d -> d+  where d is fresh.++* Now unify with type of foo's arg, and we get:+        {Num (C d a)} =>  C d a -> C d a+  where a is fresh.++* Now abstract over the 'a', but float out the Num (C d a) constraint+  because it does not 'really' mention a.  (see exactTyVarsOfType)+  The arg to foo becomes+        \/\a -> \t -> t+t++* So we get a dict binding for Num (C d a), which is zonked to give+        a = ()+  [Note Sept 04: now that we are zonking quantified type variables+  on construction, the 'a' will be frozen as a regular tyvar on+  quantification, so the floated dict will still have type (C d a).+  Which renders this whole note moot; happily!]++* Then the \/\a abstraction has a zonked 'a' in it.++All very silly.   I think its harmless to ignore the problem.  We'll end up with+a \/\a in the final result but all the occurrences of a will be zonked to ()++************************************************************************+*                                                                      *+              Zonking types+*                                                                      *+************************************************************************++-}++-- | @tcGetGlobalTyCoVars@ returns a fully-zonked set of *scoped* tyvars free in+-- the environment. To improve subsequent calls to the same function it writes+-- the zonked set back into the environment. Note that this returns all+-- variables free in anything (term-level or type-level) in scope. We thus+-- don't have to worry about clashes with things that are not in scope, because+-- if they are reachable, then they'll be returned here.+tcGetGlobalTyCoVars :: TcM TcTyVarSet+tcGetGlobalTyCoVars+  = do { (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv+       ; gbl_tvs  <- readMutVar gtv_var+       ; gbl_tvs' <- zonkTyCoVarsAndFV gbl_tvs+       ; writeMutVar gtv_var gbl_tvs'+       ; return gbl_tvs' }++-- | Zonk a type without using the smart constructors; the result type+-- is available for inspection within the type-checking knot.+zonkTcTypeInKnot :: TcType -> TcM TcType+zonkTcTypeInKnot = mapType (zonkTcTypeMapper { tcm_smart = False }) ()++zonkTcTypeAndFV :: TcType -> TcM DTyCoVarSet+-- Zonk a type and take its free variables+-- With kind polymorphism it can be essential to zonk *first*+-- so that we find the right set of free variables.  Eg+--    forall k1. forall (a:k2). a+-- where k2:=k1 is in the substitution.  We don't want+-- k2 to look free in this type!+-- NB: This might be called from within the knot, so don't use+-- smart constructors. See Note [Zonking within the knot] in TcHsType+zonkTcTypeAndFV ty+  = tyCoVarsOfTypeDSet <$> zonkTcTypeInKnot ty++-- | Zonk a type and call 'candidateQTyVarsOfType' on it.+-- Works within the knot.+zonkTcTypeAndSplitDepVars :: TcType -> TcM CandidatesQTvs+zonkTcTypeAndSplitDepVars ty+  = candidateQTyVarsOfType <$> zonkTcTypeInKnot ty++zonkTcTypesAndSplitDepVars :: [TcType] -> TcM CandidatesQTvs+zonkTcTypesAndSplitDepVars tys+  = candidateQTyVarsOfTypes <$> mapM zonkTcTypeInKnot tys++zonkTyCoVar :: TyCoVar -> TcM TcType+-- Works on TyVars and TcTyVars+zonkTyCoVar tv | isTcTyVar tv = zonkTcTyVar tv+               | isTyVar   tv = mkTyVarTy <$> zonkTyCoVarKind tv+               | otherwise    = ASSERT2( isCoVar tv, ppr tv )+                                mkCoercionTy . mkCoVarCo <$> zonkTyCoVarKind tv+   -- Hackily, when typechecking type and class decls+   -- we have TyVars in scopeadded (only) in+   -- TcHsType.tcTyClTyVars, but it seems+   -- painful to make them into TcTyVars there++zonkTyCoVarsAndFV :: TyCoVarSet -> TcM TyCoVarSet+zonkTyCoVarsAndFV tycovars =+  tyCoVarsOfTypes <$> mapM zonkTyCoVar (nonDetEltsUniqSet tycovars)+  -- It's OK to use nonDetEltsUniqSet here because we immediately forget about+  -- the ordering by turning it into a nondeterministic set and the order+  -- of zonking doesn't matter for determinism.++-- Takes a list of TyCoVars, zonks them and returns a+-- deterministically ordered list of their free variables.+zonkTyCoVarsAndFVList :: [TyCoVar] -> TcM [TyCoVar]+zonkTyCoVarsAndFVList tycovars =+  tyCoVarsOfTypesList <$> mapM zonkTyCoVar tycovars++-- Takes a deterministic set of TyCoVars, zonks them and returns a+-- deterministic set of their free variables.+-- See Note [quantifyTyVars determinism].+zonkTyCoVarsAndFVDSet :: DTyCoVarSet -> TcM DTyCoVarSet+zonkTyCoVarsAndFVDSet tycovars =+  tyCoVarsOfTypesDSet <$> mapM zonkTyCoVar (dVarSetElems tycovars)++zonkTcTyVars :: [TcTyVar] -> TcM [TcType]+zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars++-----------------  Types+zonkTyCoVarKind :: TyCoVar -> TcM TyCoVar+zonkTyCoVarKind tv = do { kind' <- zonkTcType (tyVarKind tv)+                        ; return (setTyVarKind tv kind') }++zonkTcTypes :: [TcType] -> TcM [TcType]+zonkTcTypes tys = mapM zonkTcType tys++{-+************************************************************************+*                                                                      *+              Zonking constraints+*                                                                      *+************************************************************************+-}++zonkImplication :: Implication -> TcM Implication+zonkImplication implic@(Implic { ic_skols  = skols+                               , ic_given  = given+                               , ic_wanted = wanted+                               , ic_info   = info })+  = do { skols'  <- mapM zonkTcTyCoVarBndr skols  -- Need to zonk their kinds!+                                                  -- as Trac #7230 showed+       ; given'  <- mapM zonkEvVar given+       ; info'   <- zonkSkolemInfo info+       ; wanted' <- zonkWCRec wanted+       ; return (implic { ic_skols  = skols'+                        , ic_given  = given'+                        , ic_wanted = wanted'+                        , ic_info   = info' }) }++zonkEvVar :: EvVar -> TcM EvVar+zonkEvVar var = do { ty' <- zonkTcType (varType var)+                   ; return (setVarType var ty') }+++zonkWC :: WantedConstraints -> TcM WantedConstraints+zonkWC wc = zonkWCRec wc++zonkWCRec :: WantedConstraints -> TcM WantedConstraints+zonkWCRec (WC { wc_simple = simple, wc_impl = implic, wc_insol = insol })+  = do { simple' <- zonkSimples simple+       ; implic' <- mapBagM zonkImplication implic+       ; insol'  <- zonkSimples insol+       ; return (WC { wc_simple = simple', wc_impl = implic', wc_insol = insol' }) }++zonkSimples :: Cts -> TcM Cts+zonkSimples cts = do { cts' <- mapBagM zonkCt' cts+                     ; traceTc "zonkSimples done:" (ppr cts')+                     ; return cts' }++zonkCt' :: Ct -> TcM Ct+zonkCt' ct = zonkCt ct++{- Note [zonkCt behaviour]+zonkCt tries to maintain the canonical form of a Ct.  For example,+  - a CDictCan should stay a CDictCan;+  - a CTyEqCan should stay a CTyEqCan (if the LHS stays as a variable.).+  - a CHoleCan should stay a CHoleCan++Why?, for example:+- For CDictCan, the @TcSimplify.expandSuperClasses@ step, which runs after the+  simple wanted and plugin loop, looks for @CDictCan@s. If a plugin is in use,+  constraints are zonked before being passed to the plugin. This means if we+  don't preserve a canonical form, @expandSuperClasses@ fails to expand+  superclasses. This is what happened in Trac #11525.++- For CHoleCan, once we forget that it's a hole, we can never recover that info.++NB: we do not expect to see any CFunEqCans, because zonkCt is only+called on unflattened constraints.+NB: Constraints are always re-flattened etc by the canonicaliser in+@TcCanonical@ even if they come in as CDictCan. Only canonical constraints that+are actually in the inert set carry all the guarantees. So it is okay if zonkCt+creates e.g. a CDictCan where the cc_tyars are /not/ function free.+-}+zonkCt :: Ct -> TcM Ct+zonkCt ct@(CHoleCan { cc_ev = ev })+  = do { ev' <- zonkCtEvidence ev+       ; return $ ct { cc_ev = ev' } }+zonkCt ct@(CDictCan { cc_ev = ev, cc_tyargs = args })+  = do { ev'   <- zonkCtEvidence ev+       ; args' <- mapM zonkTcType args+       ; return $ ct { cc_ev = ev', cc_tyargs = args' } }+zonkCt ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv, cc_rhs = rhs })+  = do { ev'    <- zonkCtEvidence ev+       ; tv_ty' <- zonkTcTyVar tv+       ; case getTyVar_maybe tv_ty' of+           Just tv' -> do { rhs' <- zonkTcType rhs+                          ; return ct { cc_ev    = ev'+                                      , cc_tyvar = tv'+                                      , cc_rhs   = rhs' } }+           Nothing  -> return (mkNonCanonical ev') }+zonkCt ct+  = ASSERT( not (isCFunEqCan ct) )+  -- We do not expect to see any CFunEqCans, because zonkCt is only called on+  -- unflattened constraints.+    do { fl' <- zonkCtEvidence (cc_ev ct)+       ; return (mkNonCanonical fl') }++zonkCtEvidence :: CtEvidence -> TcM CtEvidence+zonkCtEvidence ctev@(CtGiven { ctev_pred = pred })+  = do { pred' <- zonkTcType pred+       ; return (ctev { ctev_pred = pred'}) }+zonkCtEvidence ctev@(CtWanted { ctev_pred = pred, ctev_dest = dest })+  = do { pred' <- zonkTcType pred+       ; let dest' = case dest of+                       EvVarDest ev -> EvVarDest $ setVarType ev pred'+                         -- necessary in simplifyInfer+                       HoleDest h   -> HoleDest h+       ; return (ctev { ctev_pred = pred', ctev_dest = dest' }) }+zonkCtEvidence ctev@(CtDerived { ctev_pred = pred })+  = do { pred' <- zonkTcType pred+       ; return (ctev { ctev_pred = pred' }) }++zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo+zonkSkolemInfo (SigSkol cx ty tv_prs)  = do { ty' <- zonkTcType ty+                                            ; return (SigSkol cx ty' tv_prs) }+zonkSkolemInfo (InferSkol ntys) = do { ntys' <- mapM do_one ntys+                                     ; return (InferSkol ntys') }+  where+    do_one (n, ty) = do { ty' <- zonkTcType ty; return (n, ty') }+zonkSkolemInfo skol_info = return skol_info++{-+%************************************************************************+%*                                                                      *+\subsection{Zonking -- the main work-horses: zonkTcType, zonkTcTyVar}+*                                                                      *+*              For internal use only!                                  *+*                                                                      *+************************************************************************++-}++-- zonkId is used *during* typechecking just to zonk the Id's type+zonkId :: TcId -> TcM TcId+zonkId id+  = do { ty' <- zonkTcType (idType id)+       ; return (Id.setIdType id ty') }++-- | A suitable TyCoMapper for zonking a type inside the knot, and+-- before all metavars are filled in.+zonkTcTypeMapper :: TyCoMapper () TcM+zonkTcTypeMapper = TyCoMapper+  { tcm_smart = True+  , tcm_tyvar = const zonkTcTyVar+  , tcm_covar = const (\cv -> mkCoVarCo <$> zonkTyCoVarKind cv)+  , tcm_hole  = hole+  , tcm_tybinder = \_env tv _vis -> ((), ) <$> zonkTcTyCoVarBndr tv }+  where+    hole :: () -> CoercionHole -> Role -> Type -> Type+         -> TcM Coercion+    hole _ h r t1 t2+      = do { contents <- unpackCoercionHole_maybe h+           ; case contents of+               Just co -> do { co <- zonkCo co+                             ; checkCoercionHole co h r t1 t2 }+               Nothing -> do { t1 <- zonkTcType t1+                             ; t2 <- zonkTcType t2+                             ; return $ mkHoleCo h r t1 t2 } }+++-- For unbound, mutable tyvars, zonkType uses the function given to it+-- For tyvars bound at a for-all, zonkType zonks them to an immutable+--      type variable and zonks the kind too+zonkTcType :: TcType -> TcM TcType+zonkTcType = mapType zonkTcTypeMapper ()++-- | "Zonk" a coercion -- really, just zonk any types in the coercion+zonkCo :: Coercion -> TcM Coercion+zonkCo = mapCoercion zonkTcTypeMapper ()++zonkTcTyCoVarBndr :: TcTyCoVar -> TcM TcTyCoVar+-- A tyvar binder is never a unification variable (MetaTv),+-- rather it is always a skolems.  BUT it may have a kind+-- that has not yet been zonked, and may include kind+-- unification variables.+zonkTcTyCoVarBndr tyvar+    -- can't use isCoVar, because it looks at a TyCon. Argh.+  = ASSERT2( isImmutableTyVar tyvar || (not $ isTyVar tyvar), pprTyVar tyvar )+    updateTyVarKindM zonkTcType tyvar++zonkTcTyVarBinder :: TyVarBndr TcTyVar vis -> TcM (TyVarBndr TcTyVar vis)+zonkTcTyVarBinder (TvBndr tv vis)+  = do { tv' <- zonkTcTyCoVarBndr tv+       ; return (TvBndr tv' vis) }++zonkTcTyVar :: TcTyVar -> TcM TcType+-- Simply look through all Flexis+zonkTcTyVar tv+  | isTcTyVar tv+  = case tcTyVarDetails tv of+      SkolemTv {}   -> zonk_kind_and_return+      RuntimeUnk {} -> zonk_kind_and_return+      FlatSkol ty   -> zonkTcType ty+      MetaTv { mtv_ref = ref }+         -> do { cts <- readMutVar ref+               ; case cts of+                    Flexi       -> zonk_kind_and_return+                    Indirect ty -> zonkTcType ty }++  | otherwise -- coercion variable+  = zonk_kind_and_return+  where+    zonk_kind_and_return = do { z_tv <- zonkTyCoVarKind tv+                              ; return (mkTyVarTy z_tv) }++-- Variant that assumes that any result of zonking is still a TyVar.+-- Should be used only on skolems and SigTvs+zonkTcTyVarToTyVar :: TcTyVar -> TcM TcTyVar+zonkTcTyVarToTyVar tv+  = do { ty <- zonkTcTyVar tv+       ; return (tcGetTyVar "zonkTcTyVarToVar" ty) }++{-+%************************************************************************+%*                                                                      *+                 Tidying+*                                                                      *+************************************************************************+-}++zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType)+zonkTidyTcType env ty = do { ty' <- zonkTcType ty+                           ; return (tidyOpenType env ty') }++-- | Make an 'ErrorThing' storing a type.+mkTypeErrorThing :: TcType -> ErrorThing+mkTypeErrorThing ty = ErrorThing ty (Just $ length $ snd $ repSplitAppTys ty)+                                 zonkTidyTcType+   -- NB: Use *rep*splitAppTys, else we get #11313++-- | Make an 'ErrorThing' storing a type, with some extra args known about+mkTypeErrorThingArgs :: TcType -> Int -> ErrorThing+mkTypeErrorThingArgs ty num_args+  = ErrorThing ty (Just $ (length $ snd $ repSplitAppTys ty) + num_args)+               zonkTidyTcType++zonkTidyOrigin :: TidyEnv -> CtOrigin -> TcM (TidyEnv, CtOrigin)+zonkTidyOrigin env (GivenOrigin skol_info)+  = do { skol_info1 <- zonkSkolemInfo skol_info+       ; let skol_info2 = tidySkolemInfo env skol_info1+       ; return (env, GivenOrigin skol_info2) }+zonkTidyOrigin env orig@(TypeEqOrigin { uo_actual   = act+                                      , uo_expected = exp+                                      , uo_thing    = m_thing })+  = do { (env1, act') <- zonkTidyTcType env  act+       ; (env2, exp') <- zonkTidyTcType env1 exp+       ; (env3, m_thing') <- zonkTidyErrorThing env2 m_thing+       ; return ( env3, orig { uo_actual   = act'+                             , uo_expected = exp'+                             , uo_thing    = m_thing' }) }+zonkTidyOrigin env (KindEqOrigin ty1 m_ty2 orig t_or_k)+  = do { (env1, ty1')   <- zonkTidyTcType env  ty1+       ; (env2, m_ty2') <- case m_ty2 of+                             Just ty2 -> second Just <$> zonkTidyTcType env1 ty2+                             Nothing  -> return (env1, Nothing)+       ; (env3, orig')  <- zonkTidyOrigin env2 orig+       ; return (env3, KindEqOrigin ty1' m_ty2' orig' t_or_k) }+zonkTidyOrigin env (FunDepOrigin1 p1 l1 p2 l2)+  = do { (env1, p1') <- zonkTidyTcType env  p1+       ; (env2, p2') <- zonkTidyTcType env1 p2+       ; return (env2, FunDepOrigin1 p1' l1 p2' l2) }+zonkTidyOrigin env (FunDepOrigin2 p1 o1 p2 l2)+  = do { (env1, p1') <- zonkTidyTcType env  p1+       ; (env2, p2') <- zonkTidyTcType env1 p2+       ; (env3, o1') <- zonkTidyOrigin env2 o1+       ; return (env3, FunDepOrigin2 p1' o1' p2' l2) }+zonkTidyOrigin env orig = return (env, orig)++zonkTidyErrorThing :: TidyEnv -> Maybe ErrorThing+                   -> TcM (TidyEnv, Maybe ErrorThing)+zonkTidyErrorThing env (Just (ErrorThing thing n_args zonker))+  = do { (env', thing') <- zonker env thing+       ; return (env', Just $ ErrorThing thing' n_args zonker) }+zonkTidyErrorThing env Nothing+  = return (env, Nothing)++----------------+tidyCt :: TidyEnv -> Ct -> Ct+-- Used only in error reporting+-- Also converts it to non-canonical+tidyCt env ct+  = case ct of+     CHoleCan { cc_ev = ev }+       -> ct { cc_ev = tidy_ev env ev }+     _ -> mkNonCanonical (tidy_ev env (ctEvidence ct))+  where+    tidy_ev :: TidyEnv -> CtEvidence -> CtEvidence+     -- NB: we do not tidy the ctev_evar field because we don't+     --     show it in error messages+    tidy_ev env ctev@(CtGiven { ctev_pred = pred })+      = ctev { ctev_pred = tidyType env pred }+    tidy_ev env ctev@(CtWanted { ctev_pred = pred })+      = ctev { ctev_pred = tidyType env pred }+    tidy_ev env ctev@(CtDerived { ctev_pred = pred })+      = ctev { ctev_pred = tidyType env pred }++----------------+tidyEvVar :: TidyEnv -> EvVar -> EvVar+tidyEvVar env var = setVarType var (tidyType env (varType var))++----------------+tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo+tidySkolemInfo env (DerivSkol ty)         = DerivSkol (tidyType env ty)+tidySkolemInfo env (SigSkol cx ty tv_prs) = tidySigSkol env cx ty tv_prs+tidySkolemInfo env (InferSkol ids)        = InferSkol (mapSnd (tidyType env) ids)+tidySkolemInfo env (UnifyForAllSkol ty)   = UnifyForAllSkol (tidyType env ty)+tidySkolemInfo _   info                   = info++tidySigSkol :: TidyEnv -> UserTypeCtxt+            -> TcType -> [(Name,TcTyVar)] -> SkolemInfo+-- We need to take special care when tidying SigSkol+-- See Note [SigSkol SkolemInfo] in TcRnTypes+tidySigSkol env cx ty tv_prs+  = SigSkol cx (tidy_ty env ty) tv_prs'+  where+    tv_prs' = mapSnd (tidyTyVarOcc env) tv_prs+    inst_env = mkNameEnv tv_prs'++    tidy_ty env (ForAllTy (TvBndr tv vis) ty)+      = ForAllTy (TvBndr tv' vis) (tidy_ty env' ty)+      where+        (env', tv') = tidy_tv_bndr env tv++    tidy_ty env (FunTy arg res)+      = FunTy (tidyType env arg) (tidy_ty env res)++    tidy_ty env ty = tidyType env ty++    tidy_tv_bndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar)+    tidy_tv_bndr env@(occ_env, subst) tv+      | Just tv' <- lookupNameEnv inst_env (tyVarName tv)+      = ((occ_env, extendVarEnv subst tv tv'), tv')++      | otherwise+      = tidyTyCoVarBndr env tv++-------------------------------------------------------------------------+{-+%************************************************************************+%*                                                                      *+             Levity polymorphism checks+*                                                                      *+************************************************************************++See Note [Levity polymorphism checking] in DsMonad++-}++-- | According to the rules around representation polymorphism+-- (see https://ghc.haskell.org/trac/ghc/wiki/NoSubKinds), no binder+-- can have a representation-polymorphic type. This check ensures+-- that we respect this rule. It is a bit regrettable that this error+-- occurs in zonking, after which we should have reported all errors.+-- But it's hard to see where else to do it, because this can be discovered+-- only after all solving is done. And, perhaps most importantly, this+-- isn't really a compositional property of a type system, so it's+-- not a terrible surprise that the check has to go in an awkward spot.+ensureNotLevPoly :: Type  -- its zonked type+                 -> SDoc  -- where this happened+                 -> TcM ()+ensureNotLevPoly ty doc+  = whenNoErrs $   -- sometimes we end up zonking bogus definitions of type+                   -- forall a. a. See, for example, test ghci/scripts/T9140+    checkForLevPoly doc ty++  -- See Note [Levity polymorphism checking] in DsMonad+checkForLevPoly :: SDoc -> Type -> TcM ()+checkForLevPoly = checkForLevPolyX addErr++checkForLevPolyX :: Monad m+                 => (SDoc -> m ())  -- how to report an error+                 -> SDoc -> Type -> m ()+checkForLevPolyX add_err extra ty+  | isTypeLevPoly ty+  = add_err (formatLevPolyErr ty $$ extra)+  | otherwise+  = return ()++formatLevPolyErr :: Type  -- levity-polymorphic type+                 -> SDoc+formatLevPolyErr ty+  = hang (text "A levity-polymorphic type is not allowed here:")+       2 (vcat [ text "Type:" <+> ppr tidy_ty+               , text "Kind:" <+> ppr tidy_ki ])+  where+    (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty+    tidy_ki             = tidyType tidy_env (typeKind ty)
+ typecheck/TcMatches.hs view
@@ -0,0 +1,1135 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++TcMatches: Typecheck some @Matches@+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleContexts #-}++module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda,+                   TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker,+                   tcStmts, tcStmtsAndThen, tcDoStmts, tcBody,+                   tcDoStmt, tcGuardStmt+       ) where++import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferSigmaNC, tcInferSigma+                              , tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr )++import BasicTypes (LexicalFixity(..))+import HsSyn+import TcRnMonad+import TcEnv+import TcPat+import TcMType+import TcType+import TcBinds+import TcUnify+import Name+import TysWiredIn+import Id+import TyCon+import TysPrim+import TcEvidence+import Outputable+import Util+import SrcLoc+import DynFlags+import PrelNames (monadFailClassName)+import qualified GHC.LanguageExtensions as LangExt++-- Create chunkified tuple tybes for monad comprehensions+import MkCore++import Control.Monad+import Control.Arrow ( second )++#include "HsVersions.h"++{-+************************************************************************+*                                                                      *+\subsection{tcMatchesFun, tcMatchesCase}+*                                                                      *+************************************************************************++@tcMatchesFun@ typechecks a @[Match]@ list which occurs in a+@FunMonoBind@.  The second argument is the name of the function, which+is used in error messages.  It checks that all the equations have the+same number of arguments before using @tcMatches@ to do the work.++Note [Polymorphic expected type for tcMatchesFun]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+tcMatchesFun may be given a *sigma* (polymorphic) type+so it must be prepared to use tcSkolemise to skolemise it.+See Note [sig_tau may be polymorphic] in TcPat.+-}++tcMatchesFun :: Located Name+             -> MatchGroup Name (LHsExpr Name)+             -> ExpRhoType     -- Expected type of function+             -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId))+                                -- Returns type of body+tcMatchesFun fn@(L _ fun_name) matches exp_ty+  = do  {  -- Check that they all have the same no of arguments+           -- Location is in the monad, set the caller so that+           -- any inter-equation error messages get some vaguely+           -- sensible location.        Note: we have to do this odd+           -- ann-grabbing, because we don't always have annotations in+           -- hand when we call tcMatchesFun...+          traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)+        ; checkArgs fun_name matches++        ; (wrap_gen, (wrap_fun, group))+            <- tcSkolemiseET (FunSigCtxt fun_name True) exp_ty $ \ exp_rho ->+                  -- Note [Polymorphic expected type for tcMatchesFun]+               do { (matches', wrap_fun)+                       <- matchExpectedFunTys herald arity exp_rho $+                          \ pat_tys rhs_ty ->+                          tcMatches match_ctxt pat_tys rhs_ty matches+                  ; return (wrap_fun, matches') }+        ; return (wrap_gen <.> wrap_fun, group) }+  where+    arity = matchGroupArity matches+    herald = text "The equation(s) for"+             <+> quotes (ppr fun_name) <+> text "have"+    match_ctxt = MC { mc_what = FunRhs fn Prefix strictness, mc_body = tcBody }+    strictness+      | [L _ match] <- unLoc $ mg_alts matches+      , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match+      = SrcStrict+      | otherwise+      = NoSrcStrict++{-+@tcMatchesCase@ doesn't do the argument-count check because the+parser guarantees that each equation has exactly one argument.+-}++tcMatchesCase :: (Outputable (body Name)) =>+                 TcMatchCtxt body                             -- Case context+              -> TcSigmaType                                  -- Type of scrutinee+              -> MatchGroup Name (Located (body Name))        -- The case alternatives+              -> ExpRhoType                                   -- Type of whole case expressions+              -> TcM (MatchGroup TcId (Located (body TcId)))+                 -- Translated alternatives+                 -- wrapper goes from MatchGroup's ty to expected ty++tcMatchesCase ctxt scrut_ty matches res_ty+  = tcMatches ctxt [mkCheckExpType scrut_ty] res_ty matches++tcMatchLambda :: SDoc -- see Note [Herald for matchExpectedFunTys] in TcUnify+              -> TcMatchCtxt HsExpr+              -> MatchGroup Name (LHsExpr Name)+              -> ExpRhoType   -- deeply skolemised+              -> TcM (MatchGroup TcId (LHsExpr TcId), HsWrapper)+tcMatchLambda herald match_ctxt match res_ty+  = matchExpectedFunTys herald n_pats res_ty $ \ pat_tys rhs_ty ->+    tcMatches match_ctxt pat_tys rhs_ty match+  where+    n_pats | isEmptyMatchGroup match = 1   -- must be lambda-case+           | otherwise               = matchGroupArity match++-- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.++tcGRHSsPat :: GRHSs Name (LHsExpr Name) -> TcRhoType+           -> TcM (GRHSs TcId (LHsExpr TcId))+-- Used for pattern bindings+tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss (mkCheckExpType res_ty)+  where+    match_ctxt = MC { mc_what = PatBindRhs,+                      mc_body = tcBody }++{-+************************************************************************+*                                                                      *+\subsection{tcMatch}+*                                                                      *+************************************************************************++Note [Case branches must never infer a non-tau type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++  case ... of+    ... -> \(x :: forall a. a -> a) -> x+    ... -> \y -> y++Should that type-check? The problem is that, if we check the second branch+first, then we'll get a type (b -> b) for the branches, which won't unify+with the polytype in the first branch. If we check the first branch first,+then everything is OK. This order-dependency is terrible. So we want only+proper tau-types in branches (unless a sigma-type is pushed down).+This is what expTypeToType ensures: it replaces an Infer with a fresh+tau-type.++An even trickier case looks like++  f x True  = x undefined+  f x False = x ()++Here, we see that the arguments must also be non-Infer. Thus, we must+use expTypeToType on the output of matchExpectedFunTys, not the input.++But we make a special case for a one-branch case. This is so that++  f = \(x :: forall a. a -> a) -> x++still gets assigned a polytype.+-}++-- | When the MatchGroup has multiple RHSs, convert an Infer ExpType in the+-- expected type into TauTvs.+-- See Note [Case branches must never infer a non-tau type]+tauifyMultipleMatches :: [LMatch id body]+                      -> [ExpType] -> TcM [ExpType]+tauifyMultipleMatches group exp_tys+  | isSingletonMatchGroup group = return exp_tys+  | otherwise                   = mapM tauifyExpType exp_tys+  -- NB: In the empty-match case, this ensures we fill in the ExpType++-- | Type-check a MatchGroup.+tcMatches :: (Outputable (body Name)) => TcMatchCtxt body+          -> [ExpSigmaType]      -- Expected pattern types+          -> ExpRhoType          -- Expected result-type of the Match.+          -> MatchGroup Name (Located (body Name))+          -> TcM (MatchGroup TcId (Located (body TcId)))++data TcMatchCtxt body   -- c.f. TcStmtCtxt, also in this module+  = MC { mc_what :: HsMatchContext Name,        -- What kind of thing this is+         mc_body :: Located (body Name)         -- Type checker for a body of+                                                -- an alternative+                 -> ExpRhoType+                 -> TcM (Located (body TcId)) }++tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches+                                  , mg_origin = origin })+  = do { rhs_ty:pat_tys <- tauifyMultipleMatches matches (rhs_ty:pat_tys)+            -- See Note [Case branches must never infer a non-tau type]++       ; matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches+       ; pat_tys  <- mapM readExpType pat_tys+       ; rhs_ty   <- readExpType rhs_ty+       ; return (MG { mg_alts = L l matches'+                    , mg_arg_tys = pat_tys+                    , mg_res_ty = rhs_ty+                    , mg_origin = origin }) }++-------------+tcMatch :: (Outputable (body Name)) => TcMatchCtxt body+        -> [ExpSigmaType]        -- Expected pattern types+        -> ExpRhoType            -- Expected result-type of the Match.+        -> LMatch Name (Located (body Name))+        -> TcM (LMatch TcId (Located (body TcId)))++tcMatch ctxt pat_tys rhs_ty match+  = wrapLocM (tc_match ctxt pat_tys rhs_ty) match+  where+    tc_match ctxt pat_tys rhs_ty match@(Match _ pats maybe_rhs_sig grhss)+      = add_match_ctxt match $+        do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $+                                tc_grhss ctxt maybe_rhs_sig grhss rhs_ty+           ; return (Match (mc_what ctxt) pats' Nothing grhss') }++    tc_grhss ctxt Nothing grhss rhs_ty+      = tcGRHSs ctxt grhss rhs_ty       -- No result signature++        -- Result type sigs are no longer supported+    tc_grhss _ (Just {}) _ _+      = panic "tc_ghrss"        -- Rejected by renamer++        -- For (\x -> e), tcExpr has already said "In the expression \x->e"+        -- so we don't want to add "In the lambda abstraction \x->e"+    add_match_ctxt match thing_inside+        = case mc_what ctxt of+            LambdaExpr -> thing_inside+            _          -> addErrCtxt (pprMatchInCtxt match) thing_inside++-------------+tcGRHSs :: TcMatchCtxt body -> GRHSs Name (Located (body Name)) -> ExpRhoType+        -> TcM (GRHSs TcId (Located (body TcId)))++-- Notice that we pass in the full res_ty, so that we get+-- good inference from simple things like+--      f = \(x::forall a.a->a) -> <stuff>+-- We used to force it to be a monotype when there was more than one guard+-- but we don't need to do that any more++tcGRHSs ctxt (GRHSs grhss (L l binds)) res_ty+  = do  { (binds', grhss')+            <- tcLocalBinds binds $+               mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss++        ; return (GRHSs grhss' (L l binds')) }++-------------+tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS Name (Located (body Name))+       -> TcM (GRHS TcId (Located (body TcId)))++tcGRHS ctxt res_ty (GRHS guards rhs)+  = do  { (guards', rhs')+            <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $+               mc_body ctxt rhs+        ; return (GRHS guards' rhs') }+  where+    stmt_ctxt  = PatGuard (mc_what ctxt)++{-+************************************************************************+*                                                                      *+\subsection{@tcDoStmts@ typechecks a {\em list} of do statements}+*                                                                      *+************************************************************************+-}++tcDoStmts :: HsStmtContext Name+          -> Located [LStmt Name (LHsExpr Name)]+          -> ExpRhoType+          -> TcM (HsExpr TcId)          -- Returns a HsDo+tcDoStmts ListComp (L l stmts) res_ty+  = do  { res_ty <- expTypeToType res_ty+        ; (co, elt_ty) <- matchExpectedListTy res_ty+        ; let list_ty = mkListTy elt_ty+        ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts+                            (mkCheckExpType elt_ty)+        ; return $ mkHsWrapCo co (HsDo ListComp (L l stmts') list_ty) }++tcDoStmts PArrComp (L l stmts) res_ty+  = do  { res_ty <- expTypeToType res_ty+        ; (co, elt_ty) <- matchExpectedPArrTy res_ty+        ; let parr_ty = mkPArrTy elt_ty+        ; stmts' <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts+                            (mkCheckExpType elt_ty)+        ; return $ mkHsWrapCo co (HsDo PArrComp (L l stmts') parr_ty) }++tcDoStmts DoExpr (L l stmts) res_ty+  = do  { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty+        ; res_ty <- readExpType res_ty+        ; return (HsDo DoExpr (L l stmts') res_ty) }++tcDoStmts MDoExpr (L l stmts) res_ty+  = do  { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty+        ; res_ty <- readExpType res_ty+        ; return (HsDo MDoExpr (L l stmts') res_ty) }++tcDoStmts MonadComp (L l stmts) res_ty+  = do  { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty+        ; res_ty <- readExpType res_ty+        ; return (HsDo MonadComp (L l stmts') res_ty) }++tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)++tcBody :: LHsExpr Name -> ExpRhoType -> TcM (LHsExpr TcId)+tcBody body res_ty+  = do  { traceTc "tcBody" (ppr res_ty)+        ; tcMonoExpr body res_ty+        }++{-+************************************************************************+*                                                                      *+\subsection{tcStmts}+*                                                                      *+************************************************************************+-}++type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType+type TcCmdStmtChecker  = TcStmtChecker HsCmd  TcRhoType++type TcStmtChecker body rho_type+  =  forall thing. HsStmtContext Name+                -> Stmt Name (Located (body Name))+                -> rho_type                 -- Result type for comprehension+                -> (rho_type -> TcM thing)  -- Checker for what follows the stmt+                -> TcM (Stmt TcId (Located (body TcId)), thing)++tcStmts :: (Outputable (body Name)) => HsStmtContext Name+        -> TcStmtChecker body rho_type   -- NB: higher-rank type+        -> [LStmt Name (Located (body Name))]+        -> rho_type+        -> TcM [LStmt TcId (Located (body TcId))]+tcStmts ctxt stmt_chk stmts res_ty+  = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $+                        const (return ())+       ; return stmts' }++tcStmtsAndThen :: (Outputable (body Name)) => HsStmtContext Name+               -> TcStmtChecker body rho_type    -- NB: higher-rank type+               -> [LStmt Name (Located (body Name))]+               -> rho_type+               -> (rho_type -> TcM thing)+               -> TcM ([LStmt TcId (Located (body TcId))], thing)++-- Note the higher-rank type.  stmt_chk is applied at different+-- types in the equations for tcStmts++tcStmtsAndThen _ _ [] res_ty thing_inside+  = do  { thing <- thing_inside res_ty+        ; return ([], thing) }++-- LetStmts are handled uniformly, regardless of context+tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt (L l binds)) : stmts)+                                                             res_ty thing_inside+  = do  { (binds', (stmts',thing)) <- tcLocalBinds binds $+              tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside+        ; return (L loc (LetStmt (L l binds')) : stmts', thing) }++-- Don't set the error context for an ApplicativeStmt.  It ought to be+-- possible to do this with a popErrCtxt in the tcStmt case for+-- ApplicativeStmt, but it did someting strange and broke a test (ado002).+tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside+  | ApplicativeStmt{} <- stmt+  = do  { (stmt', (stmts', thing)) <-+             stmt_chk ctxt stmt res_ty $ \ res_ty' ->+               tcStmtsAndThen ctxt stmt_chk stmts res_ty'  $+                 thing_inside+        ; return (L loc stmt' : stmts', thing) }++  -- For the vanilla case, handle the location-setting part+  | otherwise+  = do  { (stmt', (stmts', thing)) <-+                setSrcSpan loc                              $+                addErrCtxt (pprStmtInCtxt ctxt stmt)        $+                stmt_chk ctxt stmt res_ty                   $ \ res_ty' ->+                popErrCtxt                                  $+                tcStmtsAndThen ctxt stmt_chk stmts res_ty'  $+                thing_inside+        ; return (L loc stmt' : stmts', thing) }++---------------------------------------------------+--              Pattern guards+---------------------------------------------------++tcGuardStmt :: TcExprStmtChecker+tcGuardStmt _ (BodyStmt guard _ _ _) res_ty thing_inside+  = do  { guard' <- tcMonoExpr guard (mkCheckExpType boolTy)+        ; thing  <- thing_inside res_ty+        ; return (BodyStmt guard' noSyntaxExpr noSyntaxExpr boolTy, thing) }++tcGuardStmt ctxt (BindStmt pat rhs _ _ _) res_ty thing_inside+  = do  { (rhs', rhs_ty) <- tcInferSigmaNC rhs+                                   -- Stmt has a context already+        ; (pat', thing)  <- tcPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs)+                                    pat (mkCheckExpType rhs_ty) $+                            thing_inside res_ty+        ; return (mkTcBindStmt pat' rhs', thing) }++tcGuardStmt _ stmt _ _+  = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)+++---------------------------------------------------+--           List comprehensions and PArrays+--               (no rebindable syntax)+---------------------------------------------------++-- Dealt with separately, rather than by tcMcStmt, because+--   a) PArr isn't (yet) an instance of Monad, so the generality seems overkill+--   b) We have special desugaring rules for list comprehensions,+--      which avoid creating intermediate lists.  They in turn+--      assume that the bind/return operations are the regular+--      polymorphic ones, and in particular don't have any+--      coercion matching stuff in them.  It's hard to avoid the+--      potential for non-trivial coercions in tcMcStmt++tcLcStmt :: TyCon       -- The list/Parray type constructor ([] or PArray)+         -> TcExprStmtChecker++tcLcStmt _ _ (LastStmt body noret _) elt_ty thing_inside+  = do { body' <- tcMonoExprNC body elt_ty+       ; thing <- thing_inside (panic "tcLcStmt: thing_inside")+       ; return (LastStmt body' noret noSyntaxExpr, thing) }++-- A generator, pat <- rhs+tcLcStmt m_tc ctxt (BindStmt pat rhs _ _ _) elt_ty thing_inside+ = do   { pat_ty <- newFlexiTyVarTy liftedTypeKind+        ; rhs'   <- tcMonoExpr rhs (mkCheckExpType $ mkTyConApp m_tc [pat_ty])+        ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $+                            thing_inside elt_ty+        ; return (mkTcBindStmt pat' rhs', thing) }++-- A boolean guard+tcLcStmt _ _ (BodyStmt rhs _ _ _) elt_ty thing_inside+  = do  { rhs'  <- tcMonoExpr rhs (mkCheckExpType boolTy)+        ; thing <- thing_inside elt_ty+        ; return (BodyStmt rhs' noSyntaxExpr noSyntaxExpr boolTy, thing) }++-- ParStmt: See notes with tcMcStmt+tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside+  = do  { (pairs', thing) <- loop bndr_stmts_s+        ; return (ParStmt pairs' noExpr noSyntaxExpr unitTy, thing) }+  where+    -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)+    loop [] = do { thing <- thing_inside elt_ty+                 ; return ([], thing) }         -- matching in the branches++    loop (ParStmtBlock stmts names _ : pairs)+      = do { (stmts', (ids, pairs', thing))+                <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->+                   do { ids <- tcLookupLocalIds names+                      ; (pairs', thing) <- loop pairs+                      ; return (ids, pairs', thing) }+           ; return ( ParStmtBlock stmts' ids noSyntaxExpr : pairs', thing ) }++tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts+                              , trS_bndrs =  bindersMap+                              , trS_by = by, trS_using = using }) elt_ty thing_inside+  = do { let (bndr_names, n_bndr_names) = unzip bindersMap+             unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap)+             -- The inner 'stmts' lack a LastStmt, so the element type+             --  passed in to tcStmtsAndThen is never looked at+       ; (stmts', (bndr_ids, by'))+            <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do+               { by' <- traverse tcInferSigma by+               ; bndr_ids <- tcLookupLocalIds bndr_names+               ; return (bndr_ids, by') }++       ; let m_app ty = mkTyConApp m_tc [ty]++       --------------- Typecheck the 'using' function -------------+       -- using :: ((a,b,c)->t) -> m (a,b,c) -> m (a,b,c)m      (ThenForm)+       --       :: ((a,b,c)->t) -> m (a,b,c) -> m (m (a,b,c)))  (GroupForm)++         -- n_app :: Type -> Type   -- Wraps a 'ty' into '[ty]' for GroupForm+       ; let n_app = case form of+                       ThenForm -> (\ty -> ty)+                       _        -> m_app++             by_arrow :: Type -> Type     -- Wraps 'ty' to '(a->t) -> ty' if the By is present+             by_arrow = case by' of+                          Nothing       -> \ty -> ty+                          Just (_,e_ty) -> \ty -> (alphaTy `mkFunTy` e_ty) `mkFunTy` ty++             tup_ty        = mkBigCoreVarTupTy bndr_ids+             poly_arg_ty   = m_app alphaTy+             poly_res_ty   = m_app (n_app alphaTy)+             using_poly_ty = mkInvForAllTy alphaTyVar $+                             by_arrow $+                             poly_arg_ty `mkFunTy` poly_res_ty++       ; using' <- tcPolyExpr using using_poly_ty+       ; let final_using = fmap (HsWrap (WpTyApp tup_ty)) using'++             -- 'stmts' returns a result of type (m1_ty tuple_ty),+             -- typically something like [(Int,Bool,Int)]+             -- We don't know what tuple_ty is yet, so we use a variable+       ; let mk_n_bndr :: Name -> TcId -> TcId+             mk_n_bndr n_bndr_name bndr_id = mkLocalIdOrCoVar n_bndr_name (n_app (idType bndr_id))++             -- Ensure that every old binder of type `b` is linked up with its+             -- new binder which should have type `n b`+             -- See Note [GroupStmt binder map] in HsExpr+             n_bndr_ids  = zipWith mk_n_bndr n_bndr_names bndr_ids+             bindersMap' = bndr_ids `zip` n_bndr_ids++       -- Type check the thing in the environment with+       -- these new binders and return the result+       ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty)++       ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'+                           , trS_by = fmap fst by', trS_using = final_using+                           , trS_ret = noSyntaxExpr+                           , trS_bind = noSyntaxExpr+                           , trS_fmap = noExpr+                           , trS_bind_arg_ty = unitTy+                           , trS_form = form }, thing) }++tcLcStmt _ _ stmt _ _+  = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)+++---------------------------------------------------+--           Monad comprehensions+--        (supports rebindable syntax)+---------------------------------------------------++tcMcStmt :: TcExprStmtChecker++tcMcStmt _ (LastStmt body noret return_op) res_ty thing_inside+  = do  { (body', return_op')+            <- tcSyntaxOp MCompOrigin return_op [SynRho] res_ty $+               \ [a_ty] ->+               tcMonoExprNC body (mkCheckExpType a_ty)+        ; thing      <- thing_inside (panic "tcMcStmt: thing_inside")+        ; return (LastStmt body' noret return_op', thing) }++-- Generators for monad comprehensions ( pat <- rhs )+--+--   [ body | q <- gen ]  ->  gen :: m a+--                            q   ::   a+--++tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op _) res_ty thing_inside+           -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty+  = do  { ((rhs', pat', thing, new_res_ty), bind_op')+            <- tcSyntaxOp MCompOrigin bind_op+                          [SynRho, SynFun SynAny SynRho] res_ty $+               \ [rhs_ty, pat_ty, new_res_ty] ->+               do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)+                  ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat+                                           (mkCheckExpType pat_ty) $+                                     thing_inside (mkCheckExpType new_res_ty)+                  ; return (rhs', pat', thing, new_res_ty) }++        -- If (but only if) the pattern can fail, typecheck the 'fail' operator+        ; fail_op' <- tcMonadFailOp (MCompPatOrigin pat) pat' fail_op new_res_ty++        ; return (BindStmt pat' rhs' bind_op' fail_op' new_res_ty, thing) }++-- Boolean expressions.+--+--   [ body | stmts, expr ]  ->  expr :: m Bool+--+tcMcStmt _ (BodyStmt rhs then_op guard_op _) res_ty thing_inside+  = do  { -- Deal with rebindable syntax:+          --    guard_op :: test_ty -> rhs_ty+          --    then_op  :: rhs_ty -> new_res_ty -> res_ty+          -- Where test_ty is, for example, Bool+        ; ((thing, rhs', rhs_ty, guard_op'), then_op')+            <- tcSyntaxOp MCompOrigin then_op [SynRho, SynRho] res_ty $+               \ [rhs_ty, new_res_ty] ->+               do { (rhs', guard_op')+                      <- tcSyntaxOp MCompOrigin guard_op [SynAny]+                                    (mkCheckExpType rhs_ty) $+                         \ [test_ty] ->+                         tcMonoExpr rhs (mkCheckExpType test_ty)+                  ; thing <- thing_inside (mkCheckExpType new_res_ty)+                  ; return (thing, rhs', rhs_ty, guard_op') }+        ; return (BodyStmt rhs' then_op' guard_op' rhs_ty, thing) }++-- Grouping statements+--+--   [ body | stmts, then group by e using f ]+--     ->  e :: t+--         f :: forall a. (a -> t) -> m a -> m (m a)+--   [ body | stmts, then group using f ]+--     ->  f :: forall a. m a -> m (m a)++-- We type [ body | (stmts, group by e using f), ... ]+--     f <optional by> [ (a,b,c) | stmts ] >>= \(a,b,c) -> ...body....+--+-- We type the functions as follows:+--     f <optional by> :: m1 (a,b,c) -> m2 (a,b,c)              (ThenForm)+--                     :: m1 (a,b,c) -> m2 (n (a,b,c))          (GroupForm)+--     (>>=) :: m2 (a,b,c)     -> ((a,b,c)   -> res) -> res     (ThenForm)+--           :: m2 (n (a,b,c)) -> (n (a,b,c) -> res) -> res     (GroupForm)+--+tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap+                         , trS_by = by, trS_using = using, trS_form = form+                         , trS_ret = return_op, trS_bind = bind_op+                         , trS_fmap = fmap_op }) res_ty thing_inside+  = do { let star_star_kind = liftedTypeKind `mkFunTy` liftedTypeKind+       ; m1_ty   <- newFlexiTyVarTy star_star_kind+       ; m2_ty   <- newFlexiTyVarTy star_star_kind+       ; tup_ty  <- newFlexiTyVarTy liftedTypeKind+       ; by_e_ty <- newFlexiTyVarTy liftedTypeKind  -- The type of the 'by' expression (if any)++         -- n_app :: Type -> Type   -- Wraps a 'ty' into '(n ty)' for GroupForm+       ; n_app <- case form of+                    ThenForm -> return (\ty -> ty)+                    _        -> do { n_ty <- newFlexiTyVarTy star_star_kind+                                   ; return (n_ty `mkAppTy`) }+       ; let by_arrow :: Type -> Type+             -- (by_arrow res) produces ((alpha->e_ty) -> res)     ('by' present)+             --                          or res                    ('by' absent)+             by_arrow = case by of+                          Nothing -> \res -> res+                          Just {} -> \res -> (alphaTy `mkFunTy` by_e_ty) `mkFunTy` res++             poly_arg_ty  = m1_ty `mkAppTy` alphaTy+             using_arg_ty = m1_ty `mkAppTy` tup_ty+             poly_res_ty  = m2_ty `mkAppTy` n_app alphaTy+             using_res_ty = m2_ty `mkAppTy` n_app tup_ty+             using_poly_ty = mkInvForAllTy alphaTyVar $+                             by_arrow $+                             poly_arg_ty `mkFunTy` poly_res_ty++             -- 'stmts' returns a result of type (m1_ty tuple_ty),+             -- typically something like [(Int,Bool,Int)]+             -- We don't know what tuple_ty is yet, so we use a variable+       ; let (bndr_names, n_bndr_names) = unzip bindersMap+       ; (stmts', (bndr_ids, by', return_op')) <-+            tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts+                           (mkCheckExpType using_arg_ty) $ \res_ty' -> do+                { by' <- case by of+                           Nothing -> return Nothing+                           Just e  -> do { e' <- tcMonoExpr e+                                                   (mkCheckExpType by_e_ty)+                                         ; return (Just e') }++                -- Find the Ids (and hence types) of all old binders+                ; bndr_ids <- tcLookupLocalIds bndr_names++                -- 'return' is only used for the binders, so we know its type.+                --   return :: (a,b,c,..) -> m (a,b,c,..)+                ; (_, return_op') <- tcSyntaxOp MCompOrigin return_op+                                       [synKnownType (mkBigCoreVarTupTy bndr_ids)]+                                       res_ty' $ \ _ -> return ()++                ; return (bndr_ids, by', return_op') }++       --------------- Typecheck the 'bind' function -------------+       -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty+       ; new_res_ty <- newFlexiTyVarTy liftedTypeKind+       ; (_, bind_op')  <- tcSyntaxOp MCompOrigin bind_op+                             [ synKnownType using_res_ty+                             , synKnownType (n_app tup_ty `mkFunTy` new_res_ty) ]+                             res_ty $ \ _ -> return ()++       --------------- Typecheck the 'fmap' function -------------+       ; fmap_op' <- case form of+                       ThenForm -> return noExpr+                       _ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $+                            mkInvForAllTy alphaTyVar $+                            mkInvForAllTy betaTyVar  $+                            (alphaTy `mkFunTy` betaTy)+                            `mkFunTy` (n_app alphaTy)+                            `mkFunTy` (n_app betaTy)++       --------------- Typecheck the 'using' function -------------+       -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c))++       ; using' <- tcPolyExpr using using_poly_ty+       ; let final_using = fmap (HsWrap (WpTyApp tup_ty)) using'++       --------------- Bulding the bindersMap ----------------+       ; let mk_n_bndr :: Name -> TcId -> TcId+             mk_n_bndr n_bndr_name bndr_id = mkLocalIdOrCoVar n_bndr_name (n_app (idType bndr_id))++             -- Ensure that every old binder of type `b` is linked up with its+             -- new binder which should have type `n b`+             -- See Note [GroupStmt binder map] in HsExpr+             n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids+             bindersMap' = bndr_ids `zip` n_bndr_ids++       -- Type check the thing in the environment with+       -- these new binders and return the result+       ; thing <- tcExtendIdEnv n_bndr_ids $+                  thing_inside (mkCheckExpType new_res_ty)++       ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'+                           , trS_by = by', trS_using = final_using+                           , trS_ret = return_op', trS_bind = bind_op'+                           , trS_bind_arg_ty = n_app tup_ty+                           , trS_fmap = fmap_op', trS_form = form }, thing) }++-- A parallel set of comprehensions+--      [ (g x, h x) | ... ; let g v = ...+--                   | ... ; let h v = ... ]+--+-- It's possible that g,h are overloaded, so we need to feed the LIE from the+-- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods).+-- Similarly if we had an existential pattern match:+--+--      data T = forall a. Show a => C a+--+--      [ (show x, show y) | ... ; C x <- ...+--                         | ... ; C y <- ... ]+--+-- Then we need the LIE from (show x, show y) to be simplified against+-- the bindings for x and y.+--+-- It's difficult to do this in parallel, so we rely on the renamer to+-- ensure that g,h and x,y don't duplicate, and simply grow the environment.+-- So the binders of the first parallel group will be in scope in the second+-- group.  But that's fine; there's no shadowing to worry about.+--+-- Note: The `mzip` function will get typechecked via:+--+--   ParStmt [st1::t1, st2::t2, st3::t3]+--+--   mzip :: m st1+--        -> (m st2 -> m st3 -> m (st2, st3))   -- recursive call+--        -> m (st1, (st2, st3))+--+tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op _) res_ty thing_inside+  = do { let star_star_kind = liftedTypeKind `mkFunTy` liftedTypeKind+       ; m_ty   <- newFlexiTyVarTy star_star_kind++       ; let mzip_ty  = mkInvForAllTys [alphaTyVar, betaTyVar] $+                        (m_ty `mkAppTy` alphaTy)+                        `mkFunTy`+                        (m_ty `mkAppTy` betaTy)+                        `mkFunTy`+                        (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])+       ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty++        -- type dummies since we don't know all binder types yet+       ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind))+                       [ names | ParStmtBlock _ names _ <- bndr_stmts_s ]++       -- Typecheck bind:+       ; let tup_tys  = [ mkBigCoreTupTy id_tys | id_tys <- id_tys_s ]+             tuple_ty = mk_tuple_ty tup_tys++       ; (((blocks', thing), inner_res_ty), bind_op')+           <- tcSyntaxOp MCompOrigin bind_op+                         [ synKnownType (m_ty `mkAppTy` tuple_ty)+                         , SynFun (synKnownType tuple_ty) SynRho ] res_ty $+              \ [inner_res_ty] ->+              do { stuff <- loop m_ty (mkCheckExpType inner_res_ty)+                                 tup_tys bndr_stmts_s+                 ; return (stuff, inner_res_ty) }++       ; return (ParStmt blocks' mzip_op' bind_op' inner_res_ty, thing) }++  where+    mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys++       -- loop :: Type                                  -- m_ty+       --      -> ExpRhoType                            -- inner_res_ty+       --      -> [TcType]                              -- tup_tys+       --      -> [ParStmtBlock Name]+       --      -> TcM ([([LStmt TcId], [TcId])], thing)+    loop _ inner_res_ty [] [] = do { thing <- thing_inside inner_res_ty+                                   ; return ([], thing) }+                                   -- matching in the branches++    loop m_ty inner_res_ty (tup_ty_in : tup_tys_in)+                           (ParStmtBlock stmts names return_op : pairs)+      = do { let m_tup_ty = m_ty `mkAppTy` tup_ty_in+           ; (stmts', (ids, return_op', pairs', thing))+                <- tcStmtsAndThen ctxt tcMcStmt stmts (mkCheckExpType m_tup_ty) $+                   \m_tup_ty' ->+                   do { ids <- tcLookupLocalIds names+                      ; let tup_ty = mkBigCoreVarTupTy ids+                      ; (_, return_op') <-+                          tcSyntaxOp MCompOrigin return_op+                                     [synKnownType tup_ty] m_tup_ty' $+                                     \ _ -> return ()+                      ; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs+                      ; return (ids, return_op', pairs', thing) }+           ; return (ParStmtBlock stmts' ids return_op' : pairs', thing) }+    loop _ _ _ _ = panic "tcMcStmt.loop"++tcMcStmt _ stmt _ _+  = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt)+++---------------------------------------------------+--           Do-notation+--        (supports rebindable syntax)+---------------------------------------------------++tcDoStmt :: TcExprStmtChecker++tcDoStmt _ (LastStmt body noret _) res_ty thing_inside+  = do { body' <- tcMonoExprNC body res_ty+       ; thing <- thing_inside (panic "tcDoStmt: thing_inside")+       ; return (LastStmt body' noret noSyntaxExpr, thing) }++tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op _) res_ty thing_inside+  = do  {       -- Deal with rebindable syntax:+                --       (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty+                -- This level of generality is needed for using do-notation+                -- in full generality; see Trac #1537++          ((rhs', pat', new_res_ty, thing), bind_op')+            <- tcSyntaxOp DoOrigin bind_op [SynRho, SynFun SynAny SynRho] res_ty $+                \ [rhs_ty, pat_ty, new_res_ty] ->+                do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)+                   ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat+                                            (mkCheckExpType pat_ty) $+                                      thing_inside (mkCheckExpType new_res_ty)+                   ; return (rhs', pat', new_res_ty, thing) }++        -- If (but only if) the pattern can fail, typecheck the 'fail' operator+        ; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op new_res_ty++        ; return (BindStmt pat' rhs' bind_op' fail_op' new_res_ty, thing) }++tcDoStmt ctxt (ApplicativeStmt pairs mb_join _) res_ty thing_inside+  = do  { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $+                                thing_inside . mkCheckExpType+        ; ((pairs', body_ty, thing), mb_join') <- case mb_join of+            Nothing -> (, Nothing) <$> tc_app_stmts res_ty+            Just join_op ->+              second Just <$>+              (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $+               \ [rhs_ty] -> tc_app_stmts (mkCheckExpType rhs_ty))++        ; return (ApplicativeStmt pairs' mb_join' body_ty, thing) }++tcDoStmt _ (BodyStmt rhs then_op _ _) res_ty thing_inside+  = do  {       -- Deal with rebindable syntax;+                --   (>>) :: rhs_ty -> new_res_ty -> res_ty+        ; ((rhs', rhs_ty, thing), then_op')+            <- tcSyntaxOp DoOrigin then_op [SynRho, SynRho] res_ty $+               \ [rhs_ty, new_res_ty] ->+               do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)+                  ; thing <- thing_inside (mkCheckExpType new_res_ty)+                  ; return (rhs', rhs_ty, thing) }+        ; return (BodyStmt rhs' then_op' noSyntaxExpr rhs_ty, thing) }++tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names+                       , recS_rec_ids = rec_names, recS_ret_fn = ret_op+                       , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op })+         res_ty thing_inside+  = do  { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names+        ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind+        ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys+              tup_ty  = mkBigCoreTupTy tup_elt_tys++        ; tcExtendIdEnv tup_ids $ do+        { ((stmts', (ret_op', tup_rets)), stmts_ty)+                <- tcInferInst $ \ exp_ty ->+                   tcStmtsAndThen ctxt tcDoStmt stmts exp_ty $ \ inner_res_ty ->+                   do { tup_rets <- zipWithM tcCheckId tup_names+                                      (map mkCheckExpType tup_elt_tys)+                             -- Unify the types of the "final" Ids (which may+                             -- be polymorphic) with those of "knot-tied" Ids+                      ; (_, ret_op')+                          <- tcSyntaxOp DoOrigin ret_op [synKnownType tup_ty]+                                        inner_res_ty $ \_ -> return ()+                      ; return (ret_op', tup_rets) }++        ; ((_, mfix_op'), mfix_res_ty)+            <- tcInferInst $ \ exp_ty ->+               tcSyntaxOp DoOrigin mfix_op+                          [synKnownType (mkFunTy tup_ty stmts_ty)] exp_ty $+               \ _ -> return ()++        ; ((thing, new_res_ty), bind_op')+            <- tcSyntaxOp DoOrigin bind_op+                          [ synKnownType mfix_res_ty+                          , synKnownType tup_ty `SynFun` SynRho ]+                          res_ty $+               \ [new_res_ty] ->+               do { thing <- thing_inside (mkCheckExpType new_res_ty)+                  ; return (thing, new_res_ty) }++        ; let rec_ids = takeList rec_names tup_ids+        ; later_ids <- tcLookupLocalIds later_names+        ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids),+                                 ppr later_ids <+> ppr (map idType later_ids)]+        ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids+                          , recS_rec_ids = rec_ids, recS_ret_fn = ret_op'+                          , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'+                          , recS_bind_ty = new_res_ty+                          , recS_later_rets = [], recS_rec_rets = tup_rets+                          , recS_ret_ty = stmts_ty }, thing)+        }}++tcDoStmt _ stmt _ _+  = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)++++---------------------------------------------------+-- MonadFail Proposal warnings+---------------------------------------------------++-- The idea behind issuing MonadFail warnings is that we add them whenever a+-- failable pattern is encountered. However, instead of throwing a type error+-- when the constraint cannot be satisfied, we only issue a warning in+-- TcErrors.hs.++tcMonadFailOp :: CtOrigin+              -> LPat TcId+              -> SyntaxExpr Name     -- The fail op+              -> TcType              -- Type of the whole do-expression+              -> TcRn (SyntaxExpr TcId)  -- Typechecked fail op+-- Get a 'fail' operator expression, to use if the pattern+-- match fails. If the pattern is irrefutatable, just return+-- noSyntaxExpr; it won't be used+tcMonadFailOp orig pat fail_op res_ty+  | isIrrefutableHsPat pat+  = return noSyntaxExpr++  | otherwise+  = do { -- Issue MonadFail warnings+         rebindableSyntax <- xoptM LangExt.RebindableSyntax+       ; desugarFlag      <- xoptM LangExt.MonadFailDesugaring+       ; missingWarning   <- woptM Opt_WarnMissingMonadFailInstances+       ; if | rebindableSyntax && (desugarFlag || missingWarning)+              -> warnRebindableClash pat+            | not desugarFlag && missingWarning+              -> emitMonadFailConstraint pat res_ty+            | otherwise+              -> return ()++        -- Get the fail op itself+        ; snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy]+                             (mkCheckExpType res_ty) $ \_ -> return ()) }++emitMonadFailConstraint :: LPat TcId -> TcType -> TcRn ()+emitMonadFailConstraint pat res_ty+  = do { -- We expect res_ty to be of form (monad_ty arg_ty)+         (_co, (monad_ty, _arg_ty)) <- matchExpectedAppTy res_ty++         -- Emit (MonadFail m), but ignore the evidence; it's+         -- just there to generate a warning+       ; monadFailClass <- tcLookupClass monadFailClassName+       ; _ <- emitWanted (FailablePattern pat)+                         (mkClassPred monadFailClass [monad_ty])+       ; return () }++warnRebindableClash :: LPat TcId -> TcRn ()+warnRebindableClash pattern = addWarnAt+    (Reason Opt_WarnMissingMonadFailInstances)+    (getLoc pattern)+    (text "The failable pattern" <+> quotes (ppr pattern)+     $$+     nest 2 (text "is used together with -XRebindableSyntax."+             <+> text "If this is intentional,"+             $$+             text "compile with -Wno-missing-monadfail-instances."))++{-+Note [Treat rebindable syntax first]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When typechecking+        do { bar; ... } :: IO ()+we want to typecheck 'bar' in the knowledge that it should be an IO thing,+pushing info from the context into the RHS.  To do this, we check the+rebindable syntax first, and push that information into (tcMonoExprNC rhs).+Otherwise the error shows up when cheking the rebindable syntax, and+the expected/inferred stuff is back to front (see Trac #3613).++Note [typechecking ApplicativeStmt]++join ((\pat1 ... patn -> body) <$> e1 <*> ... <*> en)++fresh type variables:+   pat_ty_1..pat_ty_n+   exp_ty_1..exp_ty_n+   t_1..t_(n-1)++body  :: body_ty+(\pat1 ... patn -> body) :: pat_ty_1 -> ... -> pat_ty_n -> body_ty+pat_i :: pat_ty_i+e_i   :: exp_ty_i+<$>   :: (pat_ty_1 -> ... -> pat_ty_n -> body_ty) -> exp_ty_1 -> t_1+<*>_i :: t_(i-1) -> exp_ty_i -> t_i+join :: tn -> res_ty+-}++tcApplicativeStmts+  :: HsStmtContext Name+  -> [(SyntaxExpr Name, ApplicativeArg Name Name)]+  -> ExpRhoType                         -- rhs_ty+  -> (TcRhoType -> TcM t)               -- thing_inside+  -> TcM ([(SyntaxExpr TcId, ApplicativeArg TcId TcId)], Type, t)++tcApplicativeStmts ctxt pairs rhs_ty thing_inside+ = do { body_ty <- newFlexiTyVarTy liftedTypeKind+      ; let arity = length pairs+      ; ts <- replicateM (arity-1) $ newInferExpTypeInst+      ; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind+      ; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind+      ; let fun_ty = mkFunTys pat_tys body_ty++       -- NB. do the <$>,<*> operators first, we don't want type errors here+       --     i.e. goOps before goArgs+       -- See Note [Treat rebindable syntax first]+      ; let (ops, args) = unzip pairs+      ; ops' <- goOps fun_ty (zip3 ops (ts ++ [rhs_ty]) exp_tys)++      -- Typecheck each ApplicativeArg separately+      -- See Note [ApplicativeDo and constraints]+      ; args' <- mapM goArg (zip3 args pat_tys exp_tys)++      -- Bring into scope all the things bound by the args,+      -- and typecheck the thing_inside+      -- See Note [ApplicativeDo and constraints]+      ; res <- tcExtendIdEnv (concatMap get_arg_bndrs args') $+               thing_inside body_ty++      ; return (zip ops' args', body_ty, res) }+  where+    goOps _ [] = return []+    goOps t_left ((op,t_i,exp_ty) : ops)+      = do { (_, op')+               <- tcSyntaxOp DoOrigin op+                             [synKnownType t_left, synKnownType exp_ty] t_i $+                   \ _ -> return ()+           ; t_i <- readExpType t_i+           ; ops' <- goOps t_i ops+           ; return (op' : ops') }++    goArg :: (ApplicativeArg Name Name, Type, Type)+          -> TcM (ApplicativeArg TcId TcId)++    goArg (ApplicativeArgOne pat rhs, pat_ty, exp_ty)+      = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $+        addErrCtxt (pprStmtInCtxt ctxt (mkBindStmt pat rhs))   $+        do { rhs' <- tcMonoExprNC rhs (mkCheckExpType exp_ty)+           ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $+                          return ()+           ; return (ApplicativeArgOne pat' rhs') }++    goArg (ApplicativeArgMany stmts ret pat, pat_ty, exp_ty)+      = do { (stmts', (ret',pat')) <-+                tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $+                \res_ty  -> do+                  { L _ ret' <- tcMonoExprNC (noLoc ret) res_ty+                  ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $+                                 return ()+                  ; return (ret', pat')+                  }+           ; return (ApplicativeArgMany stmts' ret' pat') }++    get_arg_bndrs :: ApplicativeArg TcId TcId -> [Id]+    get_arg_bndrs (ApplicativeArgOne pat _)    = collectPatBinders pat+    get_arg_bndrs (ApplicativeArgMany _ _ pat) = collectPatBinders pat+++{- Note [ApplicativeDo and constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+An applicative-do is supposed to take place in parallel, so+constraints bound in one arm can't possibly be available in another+(Trac #13242).  Our current rule is this (more details and discussion+on the ticket). Consider++   ...stmts...+   ApplicativeStmts [arg1, arg2, ... argN]+   ...more stmts...++where argi :: ApplicativeArg. Each 'argi' itself contains one or more Stmts.+Now, we say that:++* Constraints required by the argi can be solved from+  constraint bound by ...stmts...++* Constraints and existentials bound by the argi are not available+  to solve constraints required either by argj (where i /= j),+  or by ...more stmts....++* Within the stmts of each 'argi' individually, however, constraints bound+  by earlier stmts can be used to solve later ones.++To achieve this, we just typecheck each 'argi' separately, bring all+the variables they bind into scope, and typecheck the thing_inside.++************************************************************************+*                                                                      *+\subsection{Errors and contexts}+*                                                                      *+************************************************************************++@sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same+number of args are used in each equation.+-}++checkArgs :: Name -> MatchGroup Name body -> TcM ()+checkArgs _ (MG { mg_alts = L _ [] })+    = return ()+checkArgs fun (MG { mg_alts = L _ (match1:matches) })+    | null bad_matches+    = return ()+    | otherwise+    = failWithTc (vcat [ text "Equations for" <+> quotes (ppr fun) <+>+                         text "have different numbers of arguments"+                       , nest 2 (ppr (getLoc match1))+                       , nest 2 (ppr (getLoc (head bad_matches)))])+  where+    n_args1 = args_in_match match1+    bad_matches = [m | m <- matches, args_in_match m /= n_args1]++    args_in_match :: LMatch Name body -> Int+    args_in_match (L _ (Match _ pats _ _)) = length pats
+ typecheck/TcMatches.hs-boot view
@@ -0,0 +1,16 @@+module TcMatches where+import HsSyn    ( GRHSs, MatchGroup, LHsExpr )+import TcEvidence( HsWrapper )+import Name     ( Name )+import TcType   ( ExpRhoType, TcRhoType )+import TcRnTypes( TcM, TcId )+import SrcLoc   ( Located )++tcGRHSsPat    :: GRHSs Name (LHsExpr Name)+              -> TcRhoType+              -> TcM (GRHSs TcId (LHsExpr TcId))++tcMatchesFun :: Located Name+             -> MatchGroup Name (LHsExpr Name)+             -> ExpRhoType+             -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId))
+ typecheck/TcPat.hs view
@@ -0,0 +1,1175 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++TcPat: Typechecking patterns+-}++{-# LANGUAGE CPP, RankNTypes, TupleSections #-}+{-# LANGUAGE FlexibleContexts #-}++module TcPat ( tcLetPat, newLetBndr, LetBndrSpec(..)+             , tcPat, tcPat_O, tcPats+             , addDataConStupidTheta, badFieldCon, polyPatSig ) where++#include "HsVersions.h"++import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcSyntaxOpGen, tcInferSigma )++import HsSyn+import TcHsSyn+import TcSigs( TcPragEnv, lookupPragEnv, addInlinePrags )+import TcRnMonad+import Inst+import Id+import Var+import Name+import RdrName+import TcEnv+import TcMType+import TcValidity( arityErr )+import Type ( pprTyVars )+import TcType+import TcUnify+import TcHsType+import TysWiredIn+import TcEvidence+import TyCon+import DataCon+import PatSyn+import ConLike+import PrelNames+import BasicTypes hiding (SuccessFlag(..))+import DynFlags+import SrcLoc+import VarSet+import Util+import Outputable+import qualified GHC.LanguageExtensions as LangExt+import Control.Arrow  ( second )+import ListSetOps ( getNth )++{-+************************************************************************+*                                                                      *+                External interface+*                                                                      *+************************************************************************+-}++tcLetPat :: (Name -> Maybe TcId)+         -> LetBndrSpec+         -> LPat Name -> ExpSigmaType+         -> TcM a+         -> TcM (LPat TcId, a)+tcLetPat sig_fn no_gen pat pat_ty thing_inside+  = do { bind_lvl <- getTcLevel+       ; let ctxt = LetPat { pc_lvl    = bind_lvl+                           , pc_sig_fn = sig_fn+                           , pc_new    = no_gen }+             penv = PE { pe_lazy = True+                       , pe_ctxt = ctxt+                       , pe_orig = PatOrigin }++       ; tc_lpat pat pat_ty penv thing_inside }++-----------------+tcPats :: HsMatchContext Name+       -> [LPat Name]            -- Patterns,+       -> [ExpSigmaType]         --   and their types+       -> TcM a                  --   and the checker for the body+       -> TcM ([LPat TcId], a)++-- This is the externally-callable wrapper function+-- Typecheck the patterns, extend the environment to bind the variables,+-- do the thing inside, use any existentially-bound dictionaries to+-- discharge parts of the returning LIE, and deal with pattern type+-- signatures++--   1. Initialise the PatState+--   2. Check the patterns+--   3. Check the body+--   4. Check that no existentials escape++tcPats ctxt pats pat_tys thing_inside+  = tc_lpats penv pats pat_tys thing_inside+  where+    penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }++tcPat :: HsMatchContext Name+      -> LPat Name -> ExpSigmaType+      -> TcM a                     -- Checker for body+      -> TcM (LPat TcId, a)+tcPat ctxt = tcPat_O ctxt PatOrigin++-- | A variant of 'tcPat' that takes a custom origin+tcPat_O :: HsMatchContext Name+        -> CtOrigin              -- ^ origin to use if the type needs inst'ing+        -> LPat Name -> ExpSigmaType+        -> TcM a                 -- Checker for body+        -> TcM (LPat TcId, a)+tcPat_O ctxt orig pat pat_ty thing_inside+  = tc_lpat pat pat_ty penv thing_inside+  where+    penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = orig }+++{-+************************************************************************+*                                                                      *+                PatEnv, PatCtxt, LetBndrSpec+*                                                                      *+************************************************************************+-}++data PatEnv+  = PE { pe_lazy :: Bool        -- True <=> lazy context, so no existentials allowed+       , pe_ctxt :: PatCtxt     -- Context in which the whole pattern appears+       , pe_orig :: CtOrigin    -- origin to use if the pat_ty needs inst'ing+       }++data PatCtxt+  = LamPat   -- Used for lambdas, case etc+       (HsMatchContext Name)++  | LetPat   -- Used only for let(rec) pattern bindings+             -- See Note [Typing patterns in pattern bindings]+       { pc_lvl    :: TcLevel+                   -- Level of the binding group++       , pc_sig_fn :: Name -> Maybe TcId+                   -- Tells the expected type+                   -- for binders with a signature++       , pc_new :: LetBndrSpec+                -- How to make a new binder+       }        -- for binders without signatures++data LetBndrSpec+  = LetLclBndr            -- We are going to generalise, and wrap in an AbsBinds+                          -- so clone a fresh binder for the local monomorphic Id++  | LetGblBndr TcPragEnv  -- Generalisation plan is NoGen, so there isn't going+                          -- to be an AbsBinds; So we must bind the global version+                          -- of the binder right away.+                          -- And here is the inline-pragma information++instance Outputable LetBndrSpec where+  ppr LetLclBndr      = text "LetLclBndr"+  ppr (LetGblBndr {}) = text "LetGblBndr"++makeLazy :: PatEnv -> PatEnv+makeLazy penv = penv { pe_lazy = True }++inPatBind :: PatEnv -> Bool+inPatBind (PE { pe_ctxt = LetPat {} }) = True+inPatBind (PE { pe_ctxt = LamPat {} }) = False++{- *********************************************************************+*                                                                      *+                Binders+*                                                                      *+********************************************************************* -}++tcPatBndr :: PatEnv -> Name -> ExpSigmaType -> TcM (HsWrapper, TcId)+-- (coi, xp) = tcPatBndr penv x pat_ty+-- Then coi : pat_ty ~ typeof(xp)+--+tcPatBndr penv@(PE { pe_ctxt = LetPat { pc_lvl    = bind_lvl+                                      , pc_sig_fn = sig_fn+                                      , pc_new    = no_gen } })+          bndr_name exp_pat_ty+  -- For the LetPat cases, see+  -- Note [Typechecking pattern bindings] in TcBinds++  | Just bndr_id <- sig_fn bndr_name   -- There is a signature+  = do { wrap <- tcSubTypePat penv exp_pat_ty (idType bndr_id)+           -- See Note [Subsumption check at pattern variables]+       ; traceTc "tcPatBndr(sig)" (ppr bndr_id $$ ppr (idType bndr_id) $$ ppr exp_pat_ty)+       ; return (wrap, bndr_id) }++  | otherwise                          -- No signature+  = do { (co, bndr_ty) <- case exp_pat_ty of+             Check pat_ty    -> promoteTcType bind_lvl pat_ty+             Infer infer_res -> ASSERT( bind_lvl == ir_lvl infer_res )+                                -- If we were under a constructor that bumped+                                -- the level, we'd be in checking mode+                                do { bndr_ty <- inferResultToType infer_res+                                   ; return (mkTcNomReflCo bndr_ty, bndr_ty) }+       ; bndr_id <- newLetBndr no_gen bndr_name bndr_ty+       ; traceTc "tcPatBndr(nosig)" (vcat [ ppr bind_lvl+                                          , ppr exp_pat_ty, ppr bndr_ty, ppr co+                                          , ppr bndr_id ])+       ; return (mkWpCastN co, bndr_id) }++tcPatBndr _ bndr_name pat_ty+  = do { pat_ty <- expTypeToType pat_ty+       ; traceTc "tcPatBndr(not let)" (ppr bndr_name $$ ppr pat_ty)+       ; return (idHsWrapper, mkLocalId bndr_name pat_ty) }+               -- Whether or not there is a sig is irrelevant,+               -- as this is local++newLetBndr :: LetBndrSpec -> Name -> TcType -> TcM TcId+-- Make up a suitable Id for the pattern-binder.+-- See Note [Typechecking pattern bindings], item (4) in TcBinds+--+-- In the polymorphic case when we are going to generalise+--    (plan InferGen, no_gen = LetLclBndr), generate a "monomorphic version"+--    of the Id; the original name will be bound to the polymorphic version+--    by the AbsBinds+-- In the monomorphic case when we are not going to generalise+--    (plan NoGen, no_gen = LetGblBndr) there is no AbsBinds,+--    and we use the original name directly+newLetBndr LetLclBndr name ty+  = do { mono_name <- cloneLocalName name+       ; return (mkLocalId mono_name ty) }+newLetBndr (LetGblBndr prags) name ty+  = addInlinePrags (mkLocalId name ty) (lookupPragEnv prags name)++tcSubTypePat :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper+-- tcSubTypeET with the UserTypeCtxt specialised to GenSigCtxt+-- Used when typechecking patterns+tcSubTypePat penv t1 t2 = tcSubTypeET (pe_orig penv) GenSigCtxt t1 t2++{- Note [Subsumption check at pattern variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we come across a variable with a type signature, we need to do a+subsumption, not equality, check against the context type.  e.g.++    data T = MkT (forall a. a->a)+      f :: forall b. [b]->[b]+      MkT f = blah++Since 'blah' returns a value of type T, its payload is a polymorphic+function of type (forall a. a->a).  And that's enough to bind the+less-polymorphic function 'f', but we need some impedance matching+to witness the instantiation.+++************************************************************************+*                                                                      *+                The main worker functions+*                                                                      *+************************************************************************++Note [Nesting]+~~~~~~~~~~~~~~+tcPat takes a "thing inside" over which the pattern scopes.  This is partly+so that tcPat can extend the environment for the thing_inside, but also+so that constraints arising in the thing_inside can be discharged by the+pattern.++This does not work so well for the ErrCtxt carried by the monad: we don't+want the error-context for the pattern to scope over the RHS.+Hence the getErrCtxt/setErrCtxt stuff in tcMultiple+-}++--------------------+type Checker inp out =  forall r.+                          inp+                       -> PatEnv+                       -> TcM r+                       -> TcM (out, r)++tcMultiple :: Checker inp out -> Checker [inp] [out]+tcMultiple tc_pat args penv thing_inside+  = do  { err_ctxt <- getErrCtxt+        ; let loop _ []+                = do { res <- thing_inside+                     ; return ([], res) }++              loop penv (arg:args)+                = do { (p', (ps', res))+                                <- tc_pat arg penv $+                                   setErrCtxt err_ctxt $+                                   loop penv args+                -- setErrCtxt: restore context before doing the next pattern+                -- See note [Nesting] above++                     ; return (p':ps', res) }++        ; loop penv args }++--------------------+tc_lpat :: LPat Name+        -> ExpSigmaType+        -> PatEnv+        -> TcM a+        -> TcM (LPat TcId, a)+tc_lpat (L span pat) pat_ty penv thing_inside+  = setSrcSpan span $+    do  { (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty)+                                          thing_inside+        ; return (L span pat', res) }++tc_lpats :: PatEnv+         -> [LPat Name] -> [ExpSigmaType]+         -> TcM a+         -> TcM ([LPat TcId], a)+tc_lpats penv pats tys thing_inside+  = ASSERT2( equalLength pats tys, ppr pats $$ ppr tys )+    tcMultiple (\(p,t) -> tc_lpat p t)+                (zipEqual "tc_lpats" pats tys)+                penv thing_inside++--------------------+tc_pat  :: PatEnv+        -> Pat Name+        -> ExpSigmaType  -- Fully refined result type+        -> TcM a                -- Thing inside+        -> TcM (Pat TcId,       -- Translated pattern+                a)              -- Result of thing inside++tc_pat penv (VarPat (L l name)) pat_ty thing_inside+  = do  { (wrap, id) <- tcPatBndr penv name pat_ty+        ; res <- tcExtendIdEnv1 name id thing_inside+        ; pat_ty <- readExpType pat_ty+        ; return (mkHsWrapPat wrap (VarPat (L l id)) pat_ty, res) }++tc_pat penv (ParPat pat) pat_ty thing_inside+  = do  { (pat', res) <- tc_lpat pat pat_ty penv thing_inside+        ; return (ParPat pat', res) }++tc_pat penv (BangPat pat) pat_ty thing_inside+  = do  { (pat', res) <- tc_lpat pat pat_ty penv thing_inside+        ; return (BangPat pat', res) }++tc_pat penv (LazyPat pat) pat_ty thing_inside+  = do  { (pat', (res, pat_ct))+                <- tc_lpat pat pat_ty (makeLazy penv) $+                   captureConstraints thing_inside+                -- Ignore refined penv', revert to penv++        ; emitConstraints pat_ct+        -- captureConstraints/extendConstraints:+        --   see Note [Hopping the LIE in lazy patterns]++        -- Check that the expected pattern type is itself lifted+        ; pat_ty <- readExpType pat_ty+        ; _ <- unifyType noThing (typeKind pat_ty) liftedTypeKind++        ; return (LazyPat pat', res) }++tc_pat _ (WildPat _) pat_ty thing_inside+  = do  { res <- thing_inside+        ; pat_ty <- expTypeToType pat_ty+        ; return (WildPat pat_ty, res) }++tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside+  = do  { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty)+        ; (pat', res) <- tcExtendIdEnv1 name bndr_id $+                         tc_lpat pat (mkCheckExpType $ idType bndr_id)+                                 penv thing_inside+            -- NB: if we do inference on:+            --          \ (y@(x::forall a. a->a)) = e+            -- we'll fail.  The as-pattern infers a monotype for 'y', which then+            -- fails to unify with the polymorphic type for 'x'.  This could+            -- perhaps be fixed, but only with a bit more work.+            --+            -- If you fix it, don't forget the bindInstsOfPatIds!+        ; pat_ty <- readExpType pat_ty+        ; return (mkHsWrapPat wrap (AsPat (L nm_loc bndr_id) pat') pat_ty, res) }++tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside+  = do  {+         -- Expr must have type `forall a1...aN. OPT' -> B`+         -- where overall_pat_ty is an instance of OPT'.+        ; (expr',expr'_inferred) <- tcInferSigma expr++         -- expression must be a function+        ; let expr_orig = lexprCtOrigin expr+              herald    = text "A view pattern expression expects"+        ; (expr_wrap1, [inf_arg_ty], inf_res_ty)+            <- matchActualFunTys herald expr_orig (Just expr) 1 expr'_inferred+            -- expr_wrap1 :: expr'_inferred "->" (inf_arg_ty -> inf_res_ty)++         -- check that overall pattern is more polymorphic than arg type+        ; expr_wrap2 <- tcSubTypePat penv overall_pat_ty inf_arg_ty+            -- expr_wrap2 :: overall_pat_ty "->" inf_arg_ty++         -- pattern must have inf_res_ty+        ; (pat', res) <- tc_lpat pat (mkCheckExpType inf_res_ty) penv thing_inside++        ; overall_pat_ty <- readExpType overall_pat_ty+        ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper+                                    overall_pat_ty inf_res_ty doc+               -- expr_wrap2' :: (inf_arg_ty -> inf_res_ty) "->"+               --                (overall_pat_ty -> inf_res_ty)+              expr_wrap = expr_wrap2' <.> expr_wrap1+              doc = text "When checking the view pattern function:" <+> (ppr expr)+        ; return (ViewPat (mkLHsWrap expr_wrap expr') pat' overall_pat_ty, res) }++-- Type signatures in patterns+-- See Note [Pattern coercions] below+tc_pat penv (SigPatIn pat sig_ty) pat_ty thing_inside+  = do  { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv)+                                                            sig_ty pat_ty+        ; (pat', res) <- tcExtendTyVarEnv2 wcs      $+                         tcExtendTyVarEnv2 tv_binds $+                         tc_lpat pat (mkCheckExpType inner_ty) penv thing_inside+        ; pat_ty <- readExpType pat_ty+        ; return (mkHsWrapPat wrap (SigPatOut pat' inner_ty) pat_ty, res) }++------------------------+-- Lists, tuples, arrays+tc_pat penv (ListPat pats _ Nothing) pat_ty thing_inside+  = do  { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv pat_ty+        ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty))+                                     pats penv thing_inside+        ; pat_ty <- readExpType pat_ty+        ; return (mkHsWrapPat coi (ListPat pats' elt_ty Nothing) pat_ty, res)+        }++tc_pat penv (ListPat pats _ (Just (_,e))) pat_ty thing_inside+  = do  { tau_pat_ty <- expTypeToType pat_ty+        ; ((pats', res, elt_ty), e')+            <- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)]+                                          SynList $+                 \ [elt_ty] ->+                 do { (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty))+                                                 pats penv thing_inside+                    ; return (pats', res, elt_ty) }+        ; return (ListPat pats' elt_ty (Just (tau_pat_ty,e')), res)+        }++tc_pat penv (PArrPat pats _) pat_ty thing_inside+  = do  { (coi, elt_ty) <- matchExpectedPatTy matchExpectedPArrTy penv pat_ty+        ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty))+                                     pats penv thing_inside+        ; pat_ty <- readExpType pat_ty+        ; return (mkHsWrapPat coi (PArrPat pats' elt_ty) pat_ty, res)+        }++tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside+  = do  { let arity = length pats+              tc = tupleTyCon boxity arity+        ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)+                                               penv pat_ty+                     -- Unboxed tuples have RuntimeRep vars, which we discard:+                     -- See Note [Unboxed tuple RuntimeRep vars] in TyCon+        ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys+                                           Boxed   -> arg_tys+        ; (pats', res) <- tc_lpats penv pats (map mkCheckExpType con_arg_tys)+                                   thing_inside++        ; dflags <- getDynFlags++        -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)+        -- so that we can experiment with lazy tuple-matching.+        -- This is a pretty odd place to make the switch, but+        -- it was easy to do.+        ; let+              unmangled_result = TuplePat pats' boxity con_arg_tys+                                 -- pat_ty /= pat_ty iff coi /= IdCo+              possibly_mangled_result+                | gopt Opt_IrrefutableTuples dflags &&+                  isBoxed boxity            = LazyPat (noLoc unmangled_result)+                | otherwise                 = unmangled_result++        ; pat_ty <- readExpType pat_ty+        ; ASSERT( length con_arg_tys == length pats ) -- Syntactically enforced+          return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)+        }++tc_pat penv (SumPat pat alt arity _) pat_ty thing_inside+  = do  { let tc = sumTyCon arity+        ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)+                                               penv pat_ty+        ; -- Drop levity vars, we don't care about them here+          let con_arg_tys = drop arity arg_tys+        ; (pat', res) <- tc_lpat pat (mkCheckExpType (con_arg_tys `getNth` (alt - 1)))+                                 penv thing_inside+        ; pat_ty <- readExpType pat_ty+        ; return (mkHsWrapPat coi (SumPat pat' alt arity con_arg_tys) pat_ty, res)+        }++------------------------+-- Data constructors+tc_pat penv (ConPatIn con arg_pats) pat_ty thing_inside+  = tcConPat penv con pat_ty arg_pats thing_inside++------------------------+-- Literal patterns+tc_pat penv (LitPat simple_lit) pat_ty thing_inside+  = do  { let lit_ty = hsLitType simple_lit+        ; wrap   <- tcSubTypePat penv pat_ty lit_ty+        ; res    <- thing_inside+        ; pat_ty <- readExpType pat_ty+        ; return ( mkHsWrapPat wrap (LitPat simple_lit) pat_ty+                 , res) }++------------------------+-- Overloaded patterns: n, and n+k++-- In the case of a negative literal (the more complicated case),+-- we get+--+--   case v of (-5) -> blah+--+-- becoming+--+--   if v == (negate (fromInteger 5)) then blah else ...+--+-- There are two bits of rebindable syntax:+--   (==)   :: pat_ty -> neg_lit_ty -> Bool+--   negate :: lit_ty -> neg_lit_ty+-- where lit_ty is the type of the overloaded literal 5.+--+-- When there is no negation, neg_lit_ty and lit_ty are the same+tc_pat _ (NPat (L l over_lit) mb_neg eq _) pat_ty thing_inside+  = do  { let orig = LiteralOrigin over_lit+        ; ((lit', mb_neg'), eq')+            <- tcSyntaxOp orig eq [SynType pat_ty, SynAny]+                          (mkCheckExpType boolTy) $+               \ [neg_lit_ty] ->+               let new_over_lit lit_ty = newOverloadedLit over_lit+                                           (mkCheckExpType lit_ty)+               in case mb_neg of+                 Nothing  -> (, Nothing) <$> new_over_lit neg_lit_ty+                 Just neg -> -- Negative literal+                             -- The 'negate' is re-mappable syntax+                   second Just <$>+                   (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $+                    \ [lit_ty] -> new_over_lit lit_ty)++        ; res <- thing_inside+        ; pat_ty <- readExpType pat_ty+        ; return (NPat (L l lit') mb_neg' eq' pat_ty, res) }++{-+Note [NPlusK patterns]+~~~~~~~~~~~~~~~~~~~~~~+From++  case v of x + 5 -> blah++we get++  if v >= 5 then (\x -> blah) (v - 5) else ...++There are two bits of rebindable syntax:+  (>=) :: pat_ty -> lit1_ty -> Bool+  (-)  :: pat_ty -> lit2_ty -> var_ty++lit1_ty and lit2_ty could conceivably be different.+var_ty is the type inferred for x, the variable in the pattern.++If the pushed-down pattern type isn't a tau-type, the two pat_ty's above+could conceivably be different specializations. But this is very much+like the situation in Note [Case branches must be taus] in TcMatches.+So we tauify the pat_ty before proceeding.++Note that we need to type-check the literal twice, because it is used+twice, and may be used at different types. The second HsOverLit stored in the+AST is used for the subtraction operation.+-}++-- See Note [NPlusK patterns]+tc_pat penv (NPlusKPat (L nm_loc name) (L loc lit) _ ge minus _) pat_ty thing_inside+  = do  { pat_ty <- expTypeToType pat_ty+        ; let orig = LiteralOrigin lit+        ; (lit1', ge')+            <- tcSyntaxOp orig ge [synKnownType pat_ty, SynRho]+                                  (mkCheckExpType boolTy) $+               \ [lit1_ty] ->+               newOverloadedLit lit (mkCheckExpType lit1_ty)+        ; ((lit2', minus_wrap, bndr_id), minus')+            <- tcSyntaxOpGen orig minus [synKnownType pat_ty, SynRho] SynAny $+               \ [lit2_ty, var_ty] ->+               do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty)+                  ; (wrap, bndr_id) <- setSrcSpan nm_loc $+                                     tcPatBndr penv name (mkCheckExpType var_ty)+                           -- co :: var_ty ~ idType bndr_id++                           -- minus_wrap is applicable to minus'+                  ; return (lit2', wrap, bndr_id) }++        -- The Report says that n+k patterns must be in Integral+        -- but it's silly to insist on this in the RebindableSyntax case+        ; unlessM (xoptM LangExt.RebindableSyntax) $+          do { icls <- tcLookupClass integralClassName+             ; instStupidTheta orig [mkClassPred icls [pat_ty]] }++        ; res <- tcExtendIdEnv1 name bndr_id thing_inside++        ; let minus'' = minus' { syn_res_wrap =+                                    minus_wrap <.> syn_res_wrap minus' }+              pat' = NPlusKPat (L nm_loc bndr_id) (L loc lit1') lit2'+                               ge' minus'' pat_ty+        ; return (pat', res) }++-- HsSpliced is an annotation produced by 'RnSplice.rnSplicePat'.+-- Here we get rid of it and add the finalizers to the global environment.+--+-- See Note [Delaying modFinalizers in untyped splices] in RnSplice.+tc_pat penv (SplicePat (HsSpliced mod_finalizers (HsSplicedPat pat)))+            pat_ty thing_inside+  = do addModFinalizersWithLclEnv mod_finalizers+       tc_pat penv pat pat_ty thing_inside++tc_pat _ _other_pat _ _ = panic "tc_pat"        -- ConPatOut, SigPatOut+++{-+Note [Hopping the LIE in lazy patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a lazy pattern, we must *not* discharge constraints from the RHS+from dictionaries bound in the pattern.  E.g.+        f ~(C x) = 3+We can't discharge the Num constraint from dictionaries bound by+the pattern C!++So we have to make the constraints from thing_inside "hop around"+the pattern.  Hence the captureConstraints and emitConstraints.++The same thing ensures that equality constraints in a lazy match+are not made available in the RHS of the match. For example+        data T a where { T1 :: Int -> T Int; ... }+        f :: T a -> Int -> a+        f ~(T1 i) y = y+It's obviously not sound to refine a to Int in the right+hand side, because the argument might not match T1 at all!++Finally, a lazy pattern should not bind any existential type variables+because they won't be in scope when we do the desugaring+++************************************************************************+*                                                                      *+        Most of the work for constructors is here+        (the rest is in the ConPatIn case of tc_pat)+*                                                                      *+************************************************************************++[Pattern matching indexed data types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following declarations:++  data family Map k :: * -> *+  data instance Map (a, b) v = MapPair (Map a (Pair b v))++and a case expression++  case x :: Map (Int, c) w of MapPair m -> ...++As explained by [Wrappers for data instance tycons] in MkIds.hs, the+worker/wrapper types for MapPair are++  $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v+  $wMapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v++So, the type of the scrutinee is Map (Int, c) w, but the tycon of MapPair is+:R123Map, which means the straight use of boxySplitTyConApp would give a type+error.  Hence, the smart wrapper function boxySplitTyConAppWithFamily calls+boxySplitTyConApp with the family tycon Map instead, which gives us the family+type list {(Int, c), w}.  To get the correct split for :R123Map, we need to+unify the family type list {(Int, c), w} with the instance types {(a, b), v}+(provided by tyConFamInst_maybe together with the family tycon).  This+unification yields the substitution [a -> Int, b -> c, v -> w], which gives us+the split arguments for the representation tycon :R123Map as {Int, c, w}++In other words, boxySplitTyConAppWithFamily implicitly takes the coercion++  Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v}++moving between representation and family type into account.  To produce type+correct Core, this coercion needs to be used to case the type of the scrutinee+from the family to the representation type.  This is achieved by+unwrapFamInstScrutinee using a CoPat around the result pattern.++Now it might appear seem as if we could have used the previous GADT type+refinement infrastructure of refineAlt and friends instead of the explicit+unification and CoPat generation.  However, that would be wrong.  Why?  The+whole point of GADT refinement is that the refinement is local to the case+alternative.  In contrast, the substitution generated by the unification of+the family type list and instance types needs to be propagated to the outside.+Imagine that in the above example, the type of the scrutinee would have been+(Map x w), then we would have unified {x, w} with {(a, b), v}, yielding the+substitution [x -> (a, b), v -> w].  In contrast to GADT matching, the+instantiation of x with (a, b) must be global; ie, it must be valid in *all*+alternatives of the case expression, whereas in the GADT case it might vary+between alternatives.++RIP GADT refinement: refinements have been replaced by the use of explicit+equality constraints that are used in conjunction with implication constraints+to express the local scope of GADT refinements.+-}++--      Running example:+-- MkT :: forall a b c. (a~[b]) => b -> c -> T a+--       with scrutinee of type (T ty)++tcConPat :: PatEnv -> Located Name+         -> ExpSigmaType           -- Type of the pattern+         -> HsConPatDetails Name -> TcM a+         -> TcM (Pat TcId, a)+tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside+  = do  { con_like <- tcLookupConLike con_name+        ; case con_like of+            RealDataCon data_con -> tcDataConPat penv con_lname data_con+                                                 pat_ty arg_pats thing_inside+            PatSynCon pat_syn -> tcPatSynPat penv con_lname pat_syn+                                             pat_ty arg_pats thing_inside+        }++tcDataConPat :: PatEnv -> Located Name -> DataCon+             -> ExpSigmaType               -- Type of the pattern+             -> HsConPatDetails Name -> TcM a+             -> TcM (Pat TcId, a)+tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside+  = do  { let tycon = dataConTyCon data_con+                  -- For data families this is the representation tycon+              (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _)+                = dataConFullSig data_con+              header = L con_span (RealDataCon data_con)++          -- Instantiate the constructor type variables [a->ty]+          -- This may involve doing a family-instance coercion,+          -- and building a wrapper+        ; (wrap, ctxt_res_tys) <- matchExpectedConTy penv tycon pat_ty+        ; pat_ty <- readExpType pat_ty++          -- Add the stupid theta+        ; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys++        ; let all_arg_tys = eqSpecPreds eq_spec ++ theta ++ arg_tys+        ; checkExistentials ex_tvs all_arg_tys penv+        ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX+                               (zipTvSubst univ_tvs ctxt_res_tys) ex_tvs+                     -- Get location from monad, not from ex_tvs++        ; let -- pat_ty' = mkTyConApp tycon ctxt_res_tys+              -- pat_ty' is type of the actual constructor application+              -- pat_ty' /= pat_ty iff coi /= IdCo++              arg_tys' = substTys tenv arg_tys++        ; traceTc "tcConPat" (vcat [ ppr con_name+                                   , pprTyVars univ_tvs+                                   , pprTyVars ex_tvs+                                   , ppr eq_spec+                                   , ppr theta+                                   , pprTyVars ex_tvs'+                                   , ppr ctxt_res_tys+                                   , ppr arg_tys'+                                   , ppr arg_pats ])+        ; if null ex_tvs && null eq_spec && null theta+          then do { -- The common case; no class bindings etc+                    -- (see Note [Arrows and patterns])+                    (arg_pats', res) <- tcConArgs (RealDataCon data_con) arg_tys'+                                                  arg_pats penv thing_inside+                  ; let res_pat = ConPatOut { pat_con = header,+                                              pat_tvs = [], pat_dicts = [],+                                              pat_binds = emptyTcEvBinds,+                                              pat_args = arg_pats',+                                              pat_arg_tys = ctxt_res_tys,+                                              pat_wrap = idHsWrapper }++                  ; return (mkHsWrapPat wrap res_pat pat_ty, res) }++          else do   -- The general case, with existential,+                    -- and local equality constraints+        { let theta'     = substTheta tenv (eqSpecPreds eq_spec ++ theta)+                           -- order is *important* as we generate the list of+                           -- dictionary binders from theta'+              no_equalities = not (any isNomEqPred theta')+              skol_info = PatSkol (RealDataCon data_con) mc+              mc = case pe_ctxt penv of+                     LamPat mc -> mc+                     LetPat {} -> PatBindRhs++        ; gadts_on    <- xoptM LangExt.GADTs+        ; families_on <- xoptM LangExt.TypeFamilies+        ; checkTc (no_equalities || gadts_on || families_on)+                  (text "A pattern match on a GADT requires the" <+>+                   text "GADTs or TypeFamilies language extension")+                  -- Trac #2905 decided that a *pattern-match* of a GADT+                  -- should require the GADT language flag.+                  -- Re TypeFamilies see also #7156++        ; given <- newEvVars theta'+        ; (ev_binds, (arg_pats', res))+             <- checkConstraints skol_info ex_tvs' given $+                tcConArgs (RealDataCon data_con) arg_tys' arg_pats penv thing_inside++        ; let res_pat = ConPatOut { pat_con   = header,+                                    pat_tvs   = ex_tvs',+                                    pat_dicts = given,+                                    pat_binds = ev_binds,+                                    pat_args  = arg_pats',+                                    pat_arg_tys = ctxt_res_tys,+                                    pat_wrap  = idHsWrapper }+        ; return (mkHsWrapPat wrap res_pat pat_ty, res)+        } }++tcPatSynPat :: PatEnv -> Located Name -> PatSyn+            -> ExpSigmaType                -- Type of the pattern+            -> HsConPatDetails Name -> TcM a+            -> TcM (Pat TcId, a)+tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside+  = do  { let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, ty) = patSynSig pat_syn++        ; (subst, univ_tvs') <- newMetaTyVars univ_tvs++        ; let all_arg_tys = ty : prov_theta ++ arg_tys+        ; checkExistentials ex_tvs all_arg_tys penv+        ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX subst ex_tvs+        ; let ty'         = substTy tenv ty+              arg_tys'    = substTys tenv arg_tys+              prov_theta' = substTheta tenv prov_theta+              req_theta'  = substTheta tenv req_theta++        ; wrap <- tcSubTypePat penv pat_ty ty'+        ; traceTc "tcPatSynPat" (ppr pat_syn $$+                                 ppr pat_ty $$+                                 ppr ty' $$+                                 ppr ex_tvs' $$+                                 ppr prov_theta' $$+                                 ppr req_theta' $$+                                 ppr arg_tys')++        ; prov_dicts' <- newEvVars prov_theta'++        ; let skol_info = case pe_ctxt penv of+                            LamPat mc -> PatSkol (PatSynCon pat_syn) mc+                            LetPat {} -> UnkSkol -- Doesn't matter++        ; req_wrap <- instCall PatOrigin (mkTyVarTys univ_tvs') req_theta'+        ; traceTc "instCall" (ppr req_wrap)++        ; traceTc "checkConstraints {" Outputable.empty+        ; (ev_binds, (arg_pats', res))+             <- checkConstraints skol_info ex_tvs' prov_dicts' $+                tcConArgs (PatSynCon pat_syn) arg_tys' arg_pats penv thing_inside++        ; traceTc "checkConstraints }" (ppr ev_binds)+        ; let res_pat = ConPatOut { pat_con   = L con_span $ PatSynCon pat_syn,+                                    pat_tvs   = ex_tvs',+                                    pat_dicts = prov_dicts',+                                    pat_binds = ev_binds,+                                    pat_args  = arg_pats',+                                    pat_arg_tys = mkTyVarTys univ_tvs',+                                    pat_wrap  = req_wrap }+        ; pat_ty <- readExpType pat_ty+        ; return (mkHsWrapPat wrap res_pat pat_ty, res) }++----------------------------+-- | Convenient wrapper for calling a matchExpectedXXX function+matchExpectedPatTy :: (TcRhoType -> TcM (TcCoercionN, a))+                    -> PatEnv -> ExpSigmaType -> TcM (HsWrapper, a)+-- See Note [Matching polytyped patterns]+-- Returns a wrapper : pat_ty ~R inner_ty+matchExpectedPatTy inner_match (PE { pe_orig = orig }) pat_ty+  = do { pat_ty <- expTypeToType pat_ty+       ; (wrap, pat_rho) <- topInstantiate orig pat_ty+       ; (co, res) <- inner_match pat_rho+       ; traceTc "matchExpectedPatTy" (ppr pat_ty $$ ppr wrap)+       ; return (mkWpCastN (mkTcSymCo co) <.> wrap, res) }++----------------------------+matchExpectedConTy :: PatEnv+                   -> TyCon      -- The TyCon that this data+                                 -- constructor actually returns+                                 -- In the case of a data family this is+                                 -- the /representation/ TyCon+                   -> ExpSigmaType  -- The type of the pattern; in the case+                                    -- of a data family this would mention+                                    -- the /family/ TyCon+                   -> TcM (HsWrapper, [TcSigmaType])+-- See Note [Matching constructor patterns]+-- Returns a wrapper : pat_ty "->" T ty1 ... tyn+matchExpectedConTy (PE { pe_orig = orig }) data_tc exp_pat_ty+  | Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc+         -- Comments refer to Note [Matching constructor patterns]+         -- co_tc :: forall a. T [a] ~ T7 a+  = do { pat_ty <- expTypeToType exp_pat_ty+       ; (wrap, pat_rho) <- topInstantiate orig pat_ty++       ; (subst, tvs') <- newMetaTyVars (tyConTyVars data_tc)+             -- tys = [ty1,ty2]++       ; traceTc "matchExpectedConTy" (vcat [ppr data_tc,+                                             ppr (tyConTyVars data_tc),+                                             ppr fam_tc, ppr fam_args,+                                             ppr exp_pat_ty,+                                             ppr pat_ty,+                                             ppr pat_rho, ppr wrap])+       ; co1 <- unifyType noThing (mkTyConApp fam_tc (substTys subst fam_args)) pat_rho+             -- co1 : T (ty1,ty2) ~N pat_rho+             -- could use tcSubType here... but it's the wrong way round+             -- for actual vs. expected in error messages.++       ; let tys' = mkTyVarTys tvs'+             co2 = mkTcUnbranchedAxInstCo co_tc tys' []+             -- co2 : T (ty1,ty2) ~R T7 ty1 ty2++             full_co = mkTcSubCo (mkTcSymCo co1) `mkTcTransCo` co2+             -- full_co :: pat_rho ~R T7 ty1 ty2++       ; return ( mkWpCastR full_co <.> wrap, tys') }++  | otherwise+  = do { pat_ty <- expTypeToType exp_pat_ty+       ; (wrap, pat_rho) <- topInstantiate orig pat_ty+       ; (coi, tys) <- matchExpectedTyConApp data_tc pat_rho+       ; return (mkWpCastN (mkTcSymCo coi) <.> wrap, tys) }++{-+Note [Matching constructor patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose (coi, tys) = matchExpectedConType data_tc pat_ty++ * In the simple case, pat_ty = tc tys++ * If pat_ty is a polytype, we want to instantiate it+   This is like part of a subsumption check.  Eg+      f :: (forall a. [a]) -> blah+      f [] = blah++ * In a type family case, suppose we have+          data family T a+          data instance T (p,q) = A p | B q+       Then we'll have internally generated+              data T7 p q = A p | B q+              axiom coT7 p q :: T (p,q) ~ T7 p q++       So if pat_ty = T (ty1,ty2), we return (coi, [ty1,ty2]) such that+           coi = coi2 . coi1 : T7 t ~ pat_ty+           coi1 : T (ty1,ty2) ~ pat_ty+           coi2 : T7 ty1 ty2 ~ T (ty1,ty2)++   For families we do all this matching here, not in the unifier,+   because we never want a whisper of the data_tycon to appear in+   error messages; it's a purely internal thing+-}++tcConArgs :: ConLike -> [TcSigmaType]+          -> Checker (HsConPatDetails Name) (HsConPatDetails Id)++tcConArgs con_like arg_tys (PrefixCon arg_pats) penv thing_inside+  = do  { checkTc (con_arity == no_of_args)     -- Check correct arity+                  (arityErr "constructor" con_like con_arity no_of_args)+        ; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys+        ; (arg_pats', res) <- tcMultiple tcConArg pats_w_tys+                                              penv thing_inside+        ; return (PrefixCon arg_pats', res) }+  where+    con_arity  = conLikeArity con_like+    no_of_args = length arg_pats++tcConArgs con_like arg_tys (InfixCon p1 p2) penv thing_inside+  = do  { checkTc (con_arity == 2)      -- Check correct arity+                  (arityErr "constructor" con_like con_arity 2)+        ; let [arg_ty1,arg_ty2] = arg_tys       -- This can't fail after the arity check+        ; ([p1',p2'], res) <- tcMultiple tcConArg [(p1,arg_ty1),(p2,arg_ty2)]+                                              penv thing_inside+        ; return (InfixCon p1' p2', res) }+  where+    con_arity  = conLikeArity con_like++tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside+  = do  { (rpats', res) <- tcMultiple tc_field rpats penv thing_inside+        ; return (RecCon (HsRecFields rpats' dd), res) }+  where+    tc_field :: Checker (LHsRecField Name (LPat Name))+                        (LHsRecField TcId (LPat TcId))+    tc_field (L l (HsRecField (L loc (FieldOcc (L lr rdr) sel)) pat pun)) penv+                                                                    thing_inside+      = do { sel'   <- tcLookupId sel+           ; pat_ty <- setSrcSpan loc $ find_field_ty (occNameFS $ rdrNameOcc rdr)+           ; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside+           ; return (L l (HsRecField (L loc (FieldOcc (L lr rdr) sel')) pat'+                                                                    pun), res) }++    find_field_ty :: FieldLabelString -> TcM TcType+    find_field_ty lbl+        = case [ty | (fl, ty) <- field_tys, flLabel fl == lbl] of++                -- No matching field; chances are this field label comes from some+                -- other record type (or maybe none).  If this happens, just fail,+                -- otherwise we get crashes later (Trac #8570), and similar:+                --      f (R { foo = (a,b) }) = a+b+                -- If foo isn't one of R's fields, we don't want to crash when+                -- typechecking the "a+b".+           [] -> failWith (badFieldCon con_like lbl)++                -- The normal case, when the field comes from the right constructor+           (pat_ty : extras) -> do+                traceTc "find_field" (ppr pat_ty <+> ppr extras)+                ASSERT( null extras ) (return pat_ty)++    field_tys :: [(FieldLabel, TcType)]+    field_tys = zip (conLikeFieldLabels con_like) arg_tys+          -- Don't use zipEqual! If the constructor isn't really a record, then+          -- dataConFieldLabels will be empty (and each field in the pattern+          -- will generate an error below).++tcConArg :: Checker (LPat Name, TcSigmaType) (LPat Id)+tcConArg (arg_pat, arg_ty) penv thing_inside+  = tc_lpat arg_pat (mkCheckExpType arg_ty) penv thing_inside++addDataConStupidTheta :: DataCon -> [TcType] -> TcM ()+-- Instantiate the "stupid theta" of the data con, and throw+-- the constraints into the constraint set+addDataConStupidTheta data_con inst_tys+  | null stupid_theta = return ()+  | otherwise         = instStupidTheta origin inst_theta+  where+    origin = OccurrenceOf (dataConName data_con)+        -- The origin should always report "occurrence of C"+        -- even when C occurs in a pattern+    stupid_theta = dataConStupidTheta data_con+    univ_tvs     = dataConUnivTyVars data_con+    tenv = zipTvSubst univ_tvs (takeList univ_tvs inst_tys)+         -- NB: inst_tys can be longer than the univ tyvars+         --     because the constructor might have existentials+    inst_theta = substTheta tenv stupid_theta++{-+Note [Arrows and patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~+(Oct 07) Arrow notation has the odd property that it involves+"holes in the scope". For example:+  expr :: Arrow a => a () Int+  expr = proc (y,z) -> do+          x <- term -< y+          expr' -< x++Here the 'proc (y,z)' binding scopes over the arrow tails but not the+arrow body (e.g 'term').  As things stand (bogusly) all the+constraints from the proc body are gathered together, so constraints+from 'term' will be seen by the tcPat for (y,z).  But we must *not*+bind constraints from 'term' here, because the desugarer will not make+these bindings scope over 'term'.++The Right Thing is not to confuse these constraints together. But for+now the Easy Thing is to ensure that we do not have existential or+GADT constraints in a 'proc', and to short-cut the constraint+simplification for such vanilla patterns so that it binds no+constraints. Hence the 'fast path' in tcConPat; but it's also a good+plan for ordinary vanilla patterns to bypass the constraint+simplification step.++************************************************************************+*                                                                      *+                Note [Pattern coercions]+*                                                                      *+************************************************************************++In principle, these program would be reasonable:++        f :: (forall a. a->a) -> Int+        f (x :: Int->Int) = x 3++        g :: (forall a. [a]) -> Bool+        g [] = True++In both cases, the function type signature restricts what arguments can be passed+in a call (to polymorphic ones).  The pattern type signature then instantiates this+type.  For example, in the first case,  (forall a. a->a) <= Int -> Int, and we+generate the translated term+        f = \x' :: (forall a. a->a).  let x = x' Int in x 3++From a type-system point of view, this is perfectly fine, but it's *very* seldom useful.+And it requires a significant amount of code to implement, because we need to decorate+the translated pattern with coercion functions (generated from the subsumption check+by tcSub).++So for now I'm just insisting on type *equality* in patterns.  No subsumption.++Old notes about desugaring, at a time when pattern coercions were handled:++A SigPat is a type coercion and must be handled one at at time.  We can't+combine them unless the type of the pattern inside is identical, and we don't+bother to check for that.  For example:++        data T = T1 Int | T2 Bool+        f :: (forall a. a -> a) -> T -> t+        f (g::Int->Int)   (T1 i) = T1 (g i)+        f (g::Bool->Bool) (T2 b) = T2 (g b)++We desugar this as follows:++        f = \ g::(forall a. a->a) t::T ->+            let gi = g Int+            in case t of { T1 i -> T1 (gi i)+                           other ->+            let gb = g Bool+            in case t of { T2 b -> T2 (gb b)+                           other -> fail }}++Note that we do not treat the first column of patterns as a+column of variables, because the coerced variables (gi, gb)+would be of different types.  So we get rather grotty code.+But I don't think this is a common case, and if it was we could+doubtless improve it.++Meanwhile, the strategy is:+        * treat each SigPat coercion (always non-identity coercions)+                as a separate block+        * deal with the stuff inside, and then wrap a binding round+                the result to bind the new variable (gi, gb, etc)+++************************************************************************+*                                                                      *+\subsection{Errors and contexts}+*                                                                      *+************************************************************************++Note [Existential check]+~~~~~~~~~~~~~~~~~~~~~~~~+Lazy patterns can't bind existentials.  They arise in two ways:+  * Let bindings      let { C a b = e } in b+  * Twiddle patterns  f ~(C a b) = e+The pe_lazy field of PatEnv says whether we are inside a lazy+pattern (perhaps deeply)++See also Note [Typechecking pattern bindings] in TcBinds+-}++maybeWrapPatCtxt :: Pat Name -> (TcM a -> TcM b) -> TcM a -> TcM b+-- Not all patterns are worth pushing a context+maybeWrapPatCtxt pat tcm thing_inside+  | not (worth_wrapping pat) = tcm thing_inside+  | otherwise                = addErrCtxt msg $ tcm $ popErrCtxt thing_inside+                               -- Remember to pop before doing thing_inside+  where+   worth_wrapping (VarPat {}) = False+   worth_wrapping (ParPat {}) = False+   worth_wrapping (AsPat {})  = False+   worth_wrapping _           = True+   msg = hang (text "In the pattern:") 2 (ppr pat)++-----------------------------------------------+checkExistentials :: [TyVar]   -- existentials+                  -> [Type]    -- argument types+                  -> PatEnv -> TcM ()+    -- See Note [Existential check]]+    -- See Note [Arrows and patterns]+checkExistentials ex_tvs tys _+  | all (not . (`elemVarSet` tyCoVarsOfTypes tys)) ex_tvs = return ()+checkExistentials _ _ (PE { pe_ctxt = LetPat {}})         = return ()+checkExistentials _ _ (PE { pe_ctxt = LamPat ProcExpr })  = failWithTc existentialProcPat+checkExistentials _ _ (PE { pe_lazy = True })             = failWithTc existentialLazyPat+checkExistentials _ _ _                                   = return ()++existentialLazyPat :: SDoc+existentialLazyPat+  = hang (text "An existential or GADT data constructor cannot be used")+       2 (text "inside a lazy (~) pattern")++existentialProcPat :: SDoc+existentialProcPat+  = text "Proc patterns cannot use existential or GADT data constructors"++badFieldCon :: ConLike -> FieldLabelString -> SDoc+badFieldCon con field+  = hsep [text "Constructor" <+> quotes (ppr con),+          text "does not have field", quotes (ppr field)]++polyPatSig :: TcType -> SDoc+polyPatSig sig_ty+  = hang (text "Illegal polymorphic type signature in pattern:")+       2 (ppr sig_ty)
+ typecheck/TcPatSyn.hs view
@@ -0,0 +1,849 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[TcPatSyn]{Typechecking pattern synonym declarations}+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}++module TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl+                , tcPatSynBuilderBind, tcPatSynBuilderOcc, nonBidirectionalErr+  ) where++import HsSyn+import TcPat+import Type( mkTyVarBinders, mkEmptyTCvSubst+           , tidyTyVarBinders, tidyTypes, tidyType )+import TcRnMonad+import TcSigs( emptyPragEnv, completeSigFromId )+import TcEnv+import TcMType+import TcHsSyn( zonkTyVarBindersX, zonkTcTypeToTypes+              , zonkTcTypeToType, emptyZonkEnv )+import TysPrim+import TysWiredIn  ( runtimeRepTy )+import Name+import SrcLoc+import PatSyn+import NameSet+import Panic+import Outputable+import FastString+import Var+import VarEnv( emptyTidyEnv, mkInScopeSet )+import Id+import IdInfo( RecSelParent(..), setLevityInfoWithType )+import TcBinds+import BasicTypes+import TcSimplify+import TcUnify+import TcType+import TcEvidence+import BuildTyCl+import VarSet+import MkId+import TcTyDecls+import ConLike+import FieldLabel+import Bag+import Util+import ErrUtils+import Control.Monad ( zipWithM )+import Data.List( partition )++#include "HsVersions.h"++{-+************************************************************************+*                                                                      *+                    Type checking a pattern synonym+*                                                                      *+************************************************************************+-}++tcInferPatSynDecl :: PatSynBind Name Name+                  -> TcM (LHsBinds Id, TcGblEnv)+tcInferPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,+                       psb_def = lpat, psb_dir = dir }+  = addPatSynCtxt lname $+    do { traceTc "tcInferPatSynDecl {" $ ppr name+       ; tcCheckPatSynPat lpat++       ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details+       ; (tclvl, wanted, ((lpat', args), pat_ty))+            <- pushLevelAndCaptureConstraints  $+               tcInferNoInst $ \ exp_ty ->+               tcPat PatSyn lpat exp_ty $+               mapM tcLookupId arg_names++       ; let named_taus = (name, pat_ty) : map (\arg -> (getName arg, varType arg)) args++       ; (qtvs, req_dicts, ev_binds) <- simplifyInfer tclvl NoRestrictions []+                                                      named_taus wanted++       ; let (ex_tvs, prov_dicts) = tcCollectEx lpat'+             ex_tv_set  = mkVarSet ex_tvs+             univ_tvs   = filterOut (`elemVarSet` ex_tv_set) qtvs+             prov_theta = map evVarPred prov_dicts+             req_theta  = map evVarPred req_dicts++       ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs)+       ; tc_patsyn_finish lname dir is_infix lpat'+                          (mkTyVarBinders Inferred univ_tvs+                            , req_theta,  ev_binds, req_dicts)+                          (mkTyVarBinders Inferred ex_tvs+                            , mkTyVarTys ex_tvs, prov_theta, map EvId prov_dicts)+                          (map nlHsVar args, map idType args)+                          pat_ty rec_fields }+++tcCheckPatSynDecl :: PatSynBind Name Name+                  -> TcPatSynInfo+                  -> TcM (LHsBinds Id, TcGblEnv)+tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details+                         , psb_def = lpat, psb_dir = dir }+                  TPSI{ patsig_implicit_bndrs = implicit_tvs+                      , patsig_univ_bndrs = explicit_univ_tvs, patsig_prov = prov_theta+                      , patsig_ex_bndrs   = explicit_ex_tvs,   patsig_req  = req_theta+                      , patsig_body_ty    = sig_body_ty }+  = addPatSynCtxt lname $+    do { let decl_arity = length arg_names+             (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details++       ; traceTc "tcCheckPatSynDecl" $+         vcat [ ppr implicit_tvs, ppr explicit_univ_tvs, ppr req_theta+              , ppr explicit_ex_tvs, ppr prov_theta, ppr sig_body_ty ]++       ; tcCheckPatSynPat lpat++       ; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of+                                 Right stuff  -> return stuff+                                 Left missing -> wrongNumberOfParmsErr name decl_arity missing++       -- Complain about:  pattern P :: () => forall x. x -> P x+       -- The existential 'x' should not appear in the result type+       -- Can't check this until we know P's arity+       ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) explicit_ex_tvs+       ; checkTc (null bad_tvs) $+         hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma+                   , text "namely" <+> quotes (ppr pat_ty) ])+            2 (text "mentions existential type variable" <> plural bad_tvs+               <+> pprQuotedList bad_tvs)++         -- See Note [The pattern-synonym signature splitting rule]+       ; let univ_fvs = closeOverKinds $+                        (tyCoVarsOfTypes (pat_ty : req_theta) `extendVarSetList` explicit_univ_tvs)+             (extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) . binderVar) implicit_tvs+             univ_bndrs = extra_univ ++ mkTyVarBinders Specified explicit_univ_tvs+             ex_bndrs   = extra_ex   ++ mkTyVarBinders Specified explicit_ex_tvs+             univ_tvs   = binderVars univ_bndrs+             ex_tvs     = binderVars ex_bndrs++       -- Right!  Let's check the pattern against the signature+       -- See Note [Checking against a pattern signature]+       ; req_dicts <- newEvVars req_theta+       ; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <-+           ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys )+           pushLevelAndCaptureConstraints            $+           tcExtendTyVarEnv univ_tvs                 $+           tcPat PatSyn lpat (mkCheckExpType pat_ty) $+           do { let in_scope    = mkInScopeSet (mkVarSet univ_tvs)+                    empty_subst = mkEmptyTCvSubst in_scope+              ; (subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst ex_tvs+                    -- newMetaTyVarX: see the "Existential type variables"+                    -- part of Note [Checking against a pattern signature]+              ; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs])+              ; traceTc "tcpatsyn2" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs'])+              ; let prov_theta' = substTheta subst prov_theta+                  -- Add univ_tvs to the in_scope set to+                  -- satisfy the substitution invariant. There's no need to+                  -- add 'ex_tvs' as they are already in the domain of the+                  -- substitution.+                  -- See also Note [The substitution invariant] in TyCoRep.+              ; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta'+              ; args'      <- zipWithM (tc_arg subst) arg_names arg_tys+              ; return (ex_tvs', prov_dicts, args') }++       ; let skol_info = SigSkol (PatSynCtxt name) pat_ty []+                         -- The type here is a bit bogus, but we do not print+                         -- the type for PatSynCtxt, so it doesn't matter+                         -- See TcRnTypes Note [Skolem info for pattern synonyms]+       ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info univ_tvs req_dicts wanted++       -- Solve the constraints now, because we are about to make a PatSyn,+       -- which should not contain unification variables and the like (Trac #10997)+       ; simplifyTopImplic implics++       -- ToDo: in the bidirectional case, check that the ex_tvs' are all distinct+       -- Otherwise we may get a type error when typechecking the builder,+       -- when that should be impossible++       ; traceTc "tcCheckPatSynDecl }" $ ppr name+       ; tc_patsyn_finish lname dir is_infix lpat'+                          (univ_bndrs, req_theta, ev_binds, req_dicts)+                          (ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts)+                          (args', arg_tys)+                          pat_ty rec_fields }+  where+    tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr TcId)+    tc_arg subst arg_name arg_ty+      = do {   -- Look up the variable actually bound by lpat+               -- and check that it has the expected type+             arg_id <- tcLookupId arg_name+           ; coi <- unifyType (Just arg_id)+                              (idType arg_id)+                              (substTyUnchecked subst arg_ty)+           ; return (mkLHsWrapCo coi $ nlHsVar arg_id) }++{- Note [Checking against a pattern signature]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When checking the actual supplied pattern against the pattern synonym+signature, we need to be quite careful.++----- Provided constraints+Example++    data T a where+      MkT :: Ord a => a -> T a++    pattern P :: () => Eq a => a -> [T a]+    pattern P x = [MkT x]++We must check that the (Eq a) that P claims to bind (and to+make available to matches against P), is derivable from the+actual pattern.  For example:+    f (P (x::a)) = ...here (Eq a) should be available...+And yes, (Eq a) is derivable from the (Ord a) bound by P's rhs.++----- Existential type variables+Unusually, we instantiate the existential tyvars of the pattern with+*meta* type variables.  For example++    data S where+      MkS :: Eq a => [a] -> S++    pattern P :: () => Eq x => x -> S+    pattern P x <- MkS x++The pattern synonym conceals from its client the fact that MkS has a+list inside it.  The client just thinks it's a type 'x'.  So we must+unify x := [a] during type checking, and then use the instantiating type+[a] (called ex_tys) when building the matcher.  In this case we'll get++   $mP :: S -> (forall x. Ex x => x -> r) -> r -> r+   $mP x k = case x of+               MkS a (d:Eq a) (ys:[a]) -> let dl :: Eq [a]+                                              dl = $dfunEqList d+                                          in k [a] dl ys++All this applies when type-checking the /matching/ side of+a pattern synonym.  What about the /building/ side?++* For Unidirectional, there is no builder++* For ExplicitBidirectional, the builder is completely separate+  code, typechecked in tcPatSynBuilderBind++* For ImplicitBidirectional, the builder is still typechecked in+  tcPatSynBuilderBind, by converting the pattern to an expression and+  typechecking it.++  At one point, for ImplicitBidirectional I used SigTvs (instead of+  TauTvs) in tcCheckPatSynDecl.  But (a) strengthening the check here+  is redundant since tcPatSynBuilderBind does the job, (b) it was+  still incomplete (SigTvs can unify with each other), and (c) it+  didn't even work (Trac #13441 was accepted with+  ExplicitBidirectional, but rejected if expressed in+  ImplicitBidirectional form.  Conclusion: trying to be too clever is+  a bad idea.+-}++collectPatSynArgInfo :: HsPatSynDetails (Located Name) -> ([Name], [Name], Bool)+collectPatSynArgInfo details =+  case details of+    PrefixPatSyn names      -> (map unLoc names, [], False)+    InfixPatSyn name1 name2 -> (map unLoc [name1, name2], [], True)+    RecordPatSyn names ->+      let (vars, sels) = unzip (map splitRecordPatSyn names)+      in (vars, sels, False)++  where+    splitRecordPatSyn :: RecordPatSynField (Located Name) -> (Name, Name)+    splitRecordPatSyn (RecordPatSynField { recordPatSynPatVar = L _ patVar+                                         , recordPatSynSelectorId = L _ selId })+      = (patVar, selId)++addPatSynCtxt :: Located Name -> TcM a -> TcM a+addPatSynCtxt (L loc name) thing_inside+  = setSrcSpan loc $+    addErrCtxt (text "In the declaration for pattern synonym"+                <+> quotes (ppr name)) $+    thing_inside++wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a+wrongNumberOfParmsErr name decl_arity missing+  = failWithTc $+    hang (text "Pattern synonym" <+> quotes (ppr name) <+> ptext (sLit "has")+          <+> speakNOf decl_arity (text "argument"))+       2 (text "but its type signature has" <+> int missing <+> text "fewer arrows")++-------------------------+-- Shared by both tcInferPatSyn and tcCheckPatSyn+tc_patsyn_finish :: Located Name  -- ^ PatSyn Name+                 -> HsPatSynDir Name  -- ^ PatSyn type (Uni/Bidir/ExplicitBidir)+                 -> Bool              -- ^ Whether infix+                 -> LPat Id           -- ^ Pattern of the PatSyn+                 -> ([TcTyVarBinder], [PredType], TcEvBinds, [EvVar])+                 -> ([TcTyVarBinder], [TcType], [PredType], [EvTerm])+                 -> ([LHsExpr TcId], [TcType])   -- ^ Pattern arguments and types+                 -> TcType              -- ^ Pattern type+                 -> [Name]              -- ^ Selector names+                 -- ^ Whether fields, empty if not record PatSyn+                 -> TcM (LHsBinds Id, TcGblEnv)+tc_patsyn_finish lname dir is_infix lpat'+                 (univ_tvs, req_theta, req_ev_binds, req_dicts)+                 (ex_tvs,   ex_tys,    prov_theta,   prov_dicts)+                 (args, arg_tys)+                 pat_ty field_labels+  = do { -- Zonk everything.  We are about to build a final PatSyn+         -- so there had better be no unification variables in there++         (ze, univ_tvs') <- zonkTyVarBindersX emptyZonkEnv univ_tvs+       ; req_theta'      <- zonkTcTypeToTypes ze req_theta+       ; (ze, ex_tvs')   <- zonkTyVarBindersX ze ex_tvs+       ; prov_theta'       <- zonkTcTypeToTypes ze prov_theta+       ; pat_ty'         <- zonkTcTypeToType ze pat_ty+       ; arg_tys'        <- zonkTcTypeToTypes ze arg_tys++       ; let (env1, univ_tvs) = tidyTyVarBinders emptyTidyEnv univ_tvs'+             (env2, ex_tvs)   = tidyTyVarBinders env1 ex_tvs'+             req_theta  = tidyTypes env2 req_theta'+             prov_theta = tidyTypes env2 prov_theta'+             arg_tys    = tidyTypes env2 arg_tys'+             pat_ty     = tidyType  env2 pat_ty'++       ; traceTc "tc_patsyn_finish {" $+           ppr (unLoc lname) $$ ppr (unLoc lpat') $$+           ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$+           ppr (ex_tvs, prov_theta, prov_dicts) $$+           ppr args $$+           ppr arg_tys $$+           ppr pat_ty++       -- Make the 'matcher'+       ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat'+                                         (binderVars univ_tvs, req_theta, req_ev_binds, req_dicts)+                                         (binderVars ex_tvs, ex_tys, prov_theta, prov_dicts)+                                         (args, arg_tys)+                                         pat_ty++       -- Make the 'builder'+       ; builder_id <- mkPatSynBuilderId dir lname+                                         univ_tvs req_theta+                                         ex_tvs   prov_theta+                                         arg_tys pat_ty++         -- TODO: Make this have the proper information+       ; let mkFieldLabel name = FieldLabel { flLabel = occNameFS (nameOccName name)+                                            , flIsOverloaded = False+                                            , flSelector = name }+             field_labels' = map mkFieldLabel field_labels+++       -- Make the PatSyn itself+       ; let patSyn = mkPatSyn (unLoc lname) is_infix+                        (univ_tvs, req_theta)+                        (ex_tvs, prov_theta)+                        arg_tys+                        pat_ty+                        matcher_id builder_id+                        field_labels'++       -- Selectors+       ; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn)+             tything = AConLike (PatSynCon patSyn)+       ; tcg_env <- tcExtendGlobalEnv [tything] $+                    tcRecSelBinds rn_rec_sel_binds++       ; traceTc "tc_patsyn_finish }" empty+       ; return (matcher_bind, tcg_env) }++{-+************************************************************************+*                                                                      *+         Constructing the "matcher" Id and its binding+*                                                                      *+************************************************************************+-}++tcPatSynMatcher :: Located Name+                -> LPat Id+                -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])+                -> ([TcTyVar], [TcType], ThetaType, [EvTerm])+                -> ([LHsExpr TcId], [TcType])+                -> TcType+                -> TcM ((Id, Bool), LHsBinds Id)+-- See Note [Matchers and builders for pattern synonyms] in PatSyn+tcPatSynMatcher (L loc name) lpat+                (univ_tvs, req_theta, req_ev_binds, req_dicts)+                (ex_tvs, ex_tys, prov_theta, prov_dicts)+                (args, arg_tys) pat_ty+  = do { rr_name <- newNameAt (mkTyVarOcc "rep") loc+       ; tv_name <- newNameAt (mkTyVarOcc "r")   loc+       ; let rr_tv  = mkTcTyVar rr_name runtimeRepTy vanillaSkolemTv+             rr     = mkTyVarTy rr_tv+             res_tv = mkTcTyVar tv_name (tYPE rr) vanillaSkolemTv+             res_ty = mkTyVarTy res_tv+             is_unlifted = null args && null prov_dicts+             (cont_args, cont_arg_tys)+               | is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy])+               | otherwise   = (args,                 arg_tys)+             cont_ty = mkInfSigmaTy ex_tvs prov_theta $+                       mkFunTys cont_arg_tys res_ty++             fail_ty  = mkFunTy voidPrimTy res_ty++       ; matcher_name <- newImplicitBinder name mkMatcherOcc+       ; scrutinee    <- newSysLocalId (fsLit "scrut") pat_ty+       ; cont         <- newSysLocalId (fsLit "cont")  cont_ty+       ; fail         <- newSysLocalId (fsLit "fail")  fail_ty++       ; let matcher_tau   = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty+             matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau+             matcher_id    = mkExportedVanillaId matcher_name matcher_sigma+                             -- See Note [Exported LocalIds] in Id++             inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys+             cont' = foldl nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args++             fail' = nlHsApps fail [nlHsVar voidPrimId]++             args = map nlVarPat [scrutinee, cont, fail]+             lwpat = noLoc $ WildPat pat_ty+             cases = if isIrrefutableHsPat lpat+                     then [mkHsCaseAlt lpat  cont']+                     else [mkHsCaseAlt lpat  cont',+                           mkHsCaseAlt lwpat fail']+             body = mkLHsWrap (mkWpLet req_ev_binds) $+                    L (getLoc lpat) $+                    HsCase (nlHsVar scrutinee) $+                    MG{ mg_alts = L (getLoc lpat) cases+                      , mg_arg_tys = [pat_ty]+                      , mg_res_ty = res_ty+                      , mg_origin = Generated+                      }+             body' = noLoc $+                     HsLam $+                     MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr+                                                        args body]+                       , mg_arg_tys = [pat_ty, cont_ty, fail_ty]+                       , mg_res_ty = res_ty+                       , mg_origin = Generated+                       }+             match = mkMatch (mkPrefixFunRhs (L loc name)) []+                             (mkHsLams (rr_tv:res_tv:univ_tvs)+                             req_dicts body')+                             (noLoc EmptyLocalBinds)+             mg = MG{ mg_alts = L (getLoc match) [match]+                    , mg_arg_tys = []+                    , mg_res_ty = res_ty+                    , mg_origin = Generated+                    }++       ; let bind = FunBind{ fun_id = L loc matcher_id+                           , fun_matches = mg+                           , fun_co_fn = idHsWrapper+                           , bind_fvs = emptyNameSet+                           , fun_tick = [] }+             matcher_bind = unitBag (noLoc bind)++       ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))+       ; traceTc "tcPatSynMatcher" (ppr matcher_bind)++       ; return ((matcher_id, is_unlifted), matcher_bind) }++mkPatSynRecSelBinds :: PatSyn+                    -> [FieldLabel]  -- ^ Visible field labels+                    -> HsValBinds Name+mkPatSynRecSelBinds ps fields+  = ValBindsOut selector_binds sigs+  where+    (sigs, selector_binds) = unzip (map mkRecSel fields)+    mkRecSel fld_lbl = mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl++isUnidirectional :: HsPatSynDir a -> Bool+isUnidirectional Unidirectional          = True+isUnidirectional ImplicitBidirectional   = False+isUnidirectional ExplicitBidirectional{} = False++{-+************************************************************************+*                                                                      *+         Constructing the "builder" Id+*                                                                      *+************************************************************************+-}++mkPatSynBuilderId :: HsPatSynDir a -> Located Name+                  -> [TyVarBinder] -> ThetaType+                  -> [TyVarBinder] -> ThetaType+                  -> [Type] -> Type+                  -> TcM (Maybe (Id, Bool))+mkPatSynBuilderId dir (L _ name)+                  univ_bndrs req_theta ex_bndrs prov_theta+                  arg_tys pat_ty+  | isUnidirectional dir+  = return Nothing+  | otherwise+  = do { builder_name <- newImplicitBinder name mkBuilderOcc+       ; let theta          = req_theta ++ prov_theta+             need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta+             builder_sigma  = add_void need_dummy_arg $+                              mkForAllTys univ_bndrs $+                              mkForAllTys ex_bndrs $+                              mkFunTys theta $+                              mkFunTys arg_tys $+                              pat_ty+             builder_id     = mkExportedVanillaId builder_name builder_sigma+              -- See Note [Exported LocalIds] in Id++             builder_id'    = modifyIdInfo (`setLevityInfoWithType` pat_ty) builder_id++       ; return (Just (builder_id', need_dummy_arg)) }+  where++tcPatSynBuilderBind :: PatSynBind Name Name+                    -> TcM (LHsBinds Id)+-- See Note [Matchers and builders for pattern synonyms] in PatSyn+tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat+                         , psb_dir = dir, psb_args = details })+  | isUnidirectional dir+  = return emptyBag++  | Left why <- mb_match_group       -- Can't invert the pattern+  = setSrcSpan (getLoc lpat) $ failWithTc $+    vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym"+                 <+> quotes (ppr name) <> colon)+              2 why+         , text "RHS pattern:" <+> ppr lpat ]++  | Right match_group <- mb_match_group  -- Bidirectional+  = do { patsyn <- tcLookupPatSyn name+       ; let Just (builder_id, need_dummy_arg) = patSynBuilder patsyn+                   -- Bidirectional, so patSynBuilder returns Just++             match_group' | need_dummy_arg = add_dummy_arg match_group+                          | otherwise      = match_group++             bind = FunBind { fun_id      = L loc (idName builder_id)+                            , fun_matches = match_group'+                            , fun_co_fn   = idHsWrapper+                            , bind_fvs    = placeHolderNamesTc+                            , fun_tick    = [] }++             sig = completeSigFromId (PatSynCtxt name) builder_id++       ; traceTc "tcPatSynBuilderBind {" $+         ppr patsyn $$ ppr builder_id <+> dcolon <+> ppr (idType builder_id)+       ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind)+       ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds+       ; return builder_binds }++  | otherwise = panic "tcPatSynBuilderBind"  -- Both cases dealt with+  where+    mb_match_group+       = case dir of+           ExplicitBidirectional explicit_mg -> Right explicit_mg+           ImplicitBidirectional             -> fmap mk_mg (tcPatToExpr args lpat)+           Unidirectional -> panic "tcPatSynBuilderBind"++    mk_mg :: LHsExpr Name -> MatchGroup Name (LHsExpr Name)+    mk_mg body = mkMatchGroup Generated [builder_match]+             where+               builder_args  = [L loc (VarPat (L loc n)) | L loc n <- args]+               builder_match = mkMatch (mkPrefixFunRhs (L loc name))+                                       builder_args body+                                       (noLoc EmptyLocalBinds)++    args = case details of+              PrefixPatSyn args     -> args+              InfixPatSyn arg1 arg2 -> [arg1, arg2]+              RecordPatSyn args     -> map recordPatSynPatVar args++    add_dummy_arg :: MatchGroup Name (LHsExpr Name)+                  -> MatchGroup Name (LHsExpr Name)+    add_dummy_arg mg@(MG { mg_alts = L l [L loc match@(Match { m_pats = pats })] })+      = mg { mg_alts = L l [L loc (match { m_pats = nlWildPatName : pats })] }+    add_dummy_arg other_mg = pprPanic "add_dummy_arg" $+                             pprMatches other_mg++tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr TcId, TcSigmaType)+-- monadic only for failure+tcPatSynBuilderOcc ps+  | Just (builder_id, add_void_arg) <- builder+  , let builder_expr = HsConLikeOut (PatSynCon ps)+        builder_ty   = idType builder_id+  = return $+    if add_void_arg+    then ( builder_expr   -- still just return builder_expr; the void# arg is added+                          -- by dsConLike in the desugarer+         , tcFunResultTy builder_ty )+    else (builder_expr, builder_ty)++  | otherwise  -- Unidirectional+  = nonBidirectionalErr name+  where+    name    = patSynName ps+    builder = patSynBuilder ps++add_void :: Bool -> Type -> Type+add_void need_dummy_arg ty+  | need_dummy_arg = mkFunTy voidPrimTy ty+  | otherwise      = ty++tcPatToExpr :: [Located Name] -> LPat Name -> Either MsgDoc (LHsExpr Name)+-- Given a /pattern/, return an /expression/ that builds a value+-- that matches the pattern.  E.g. if the pattern is (Just [x]),+-- the expression is (Just [x]).  They look the same, but the+-- input uses constructors from HsPat and the output uses constructors+-- from HsExpr.+--+-- Returns (Left r) if the pattern is not invertible, for reason r.+-- See Note [Builder for a bidirectional pattern synonym]+tcPatToExpr args pat = go pat+  where+    lhsVars = mkNameSet (map unLoc args)++    -- Make a prefix con for prefix and infix patterns for simplicity+    mkPrefixConExpr :: Located Name -> [LPat Name] -> Either MsgDoc (HsExpr Name)+    mkPrefixConExpr lcon@(L loc _) pats+      = do { exprs <- mapM go pats+           ; return (foldl (\x y -> HsApp (L loc x) y)+                           (HsVar lcon) exprs) }++    mkRecordConExpr :: Located Name -> HsRecFields Name (LPat Name)+                    -> Either MsgDoc (HsExpr Name)+    mkRecordConExpr con fields+      = do { exprFields <- mapM go fields+           ; return (RecordCon con PlaceHolder noPostTcExpr exprFields) }++    go :: LPat Name -> Either MsgDoc (LHsExpr Name)+    go (L loc p) = L loc <$> go1 p++    go1 :: Pat Name -> Either MsgDoc (HsExpr Name)+    go1 (ConPatIn con info)+      = case info of+          PrefixCon ps  -> mkPrefixConExpr con ps+          InfixCon l r  -> mkPrefixConExpr con [l,r]+          RecCon fields -> mkRecordConExpr con fields++    go1 (SigPatIn pat _) = go1 (unLoc pat)+        -- See Note [Type signatures and the builder expression]++    go1 (VarPat (L l var))+        | var `elemNameSet` lhsVars+        = return $ HsVar (L l var)+        | otherwise+        = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")+    go1 (ParPat pat)                = fmap HsPar $ go pat+    go1 (LazyPat pat)               = go1 (unLoc pat)+    go1 (BangPat pat)               = go1 (unLoc pat)+    go1 (PArrPat pats ptt)          = do { exprs <- mapM go pats+                                         ; return $ ExplicitPArr ptt exprs }+    go1 (ListPat pats ptt reb)      = do { exprs <- mapM go pats+                                         ; return $ ExplicitList ptt (fmap snd reb) exprs }+    go1 (TuplePat pats box _)       = do { exprs <- mapM go pats+                                         ; return $ ExplicitTuple+                                              (map (noLoc . Present) exprs) box }+    go1 (SumPat pat alt arity _)    = do { expr <- go1 (unLoc pat)+                                         ; return $ ExplicitSum alt arity (noLoc expr) PlaceHolder+                                         }+    go1 (LitPat lit)                = return $ HsLit lit+    go1 (NPat (L _ n) mb_neg _ _)+        | Just neg <- mb_neg        = return $ unLoc $ nlHsSyntaxApps neg [noLoc (HsOverLit n)]+        | otherwise                 = return $ HsOverLit n+    go1 (ConPatOut{})               = panic "ConPatOut in output of renamer"+    go1 (SigPatOut{})               = panic "SigPatOut in output of renamer"+    go1 (CoPat{})                   = panic "CoPat in output of renamer"+    go1 p = Left (text "pattern" <+> quotes (ppr p) <+> text "is not invertible")++{- Note [Builder for a bidirectional pattern synonym]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For a bidirectional pattern synonym we need to produce an /expression/+that matches the supplied /pattern/, given values for the arguments+of the pattern synoymy.  For example+  pattern F x y = (Just x, [y])+The 'builder' for F looks like+  $builderF x y = (Just x, [y])++We can't always do this:+ * Some patterns aren't invertible; e.g. view patterns+      pattern F x = (reverse -> x:_)++ * The RHS pattern might bind more variables than the pattern+   synonym, so again we can't invert it+      pattern F x = (x,y)++ * Ditto wildcards+      pattern F x = (x,_)+++Note [Redundant constraints for builder]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The builder can have redundant constraints, which are awkard to eliminate.+Consider+   pattern P = Just 34+To match against this pattern we need (Eq a, Num a).  But to build+(Just 34) we need only (Num a).  Fortunately instTcSigFromId sets+sig_warn_redundant to False.++************************************************************************+*                                                                      *+         Helper functions+*                                                                      *+************************************************************************++Note [As-patterns in pattern synonym definitions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The rationale for rejecting as-patterns in pattern synonym definitions+is that an as-pattern would introduce nonindependent pattern synonym+arguments, e.g. given a pattern synonym like:++        pattern K x y = x@(Just y)++one could write a nonsensical function like++        f (K Nothing x) = ...++or+        g (K (Just True) False) = ...++Note [Type signatures and the builder expression]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   pattern L x = Left x :: Either [a] [b]++In tc{Infer/Check}PatSynDecl we will check that the pattern has the+specified type.  We check the pattern *as a pattern*, so the type+signature is a pattern signature, and so brings 'a' and 'b' into+scope.  But we don't have a way to bind 'a, b' in the LHS, as we do+'x', say.  Nevertheless, the sigature may be useful to constrain+the type.++When making the binding for the *builder*, though, we don't want+  $buildL x = Left x :: Either [a] [b]+because that wil either mean (forall a b. Either [a] [b]), or we'll+get a complaint that 'a' and 'b' are out of scope. (Actually the+latter; Trac #9867.)  No, the job of the signature is done, so when+converting the pattern to an expression (for the builder RHS) we+simply discard the signature.++Note [Record PatSyn Desugaring]+-------------------------------+It is important that prov_theta comes before req_theta as this ordering is used+when desugaring record pattern synonym updates.++Any change to this ordering should make sure to change deSugar/DsExpr.hs if you+want to avoid difficult to decipher core lint errors!+ -}++tcCheckPatSynPat :: LPat Name -> TcM ()+tcCheckPatSynPat = go+  where+    go :: LPat Name -> TcM ()+    go = addLocM go1++    go1 :: Pat Name -> TcM ()+    go1   (ConPatIn _ info)   = mapM_ go (hsConPatArgs info)+    go1   VarPat{}            = return ()+    go1   WildPat{}           = return ()+    go1 p@(AsPat _ _)         = asPatInPatSynErr p+    go1   (LazyPat pat)       = go pat+    go1   (ParPat pat)        = go pat+    go1   (BangPat pat)       = go pat+    go1   (PArrPat pats _)    = mapM_ go pats+    go1   (ListPat pats _ _)  = mapM_ go pats+    go1   (TuplePat pats _ _) = mapM_ go pats+    go1   (SumPat pat _ _ _)  = go pat+    go1   LitPat{}            = return ()+    go1   NPat{}              = return ()+    go1   (SigPatIn pat _)    = go pat+    go1   (ViewPat _ pat _)   = go pat+    go1 p@SplicePat{}         = thInPatSynErr p+    go1 p@NPlusKPat{}         = nPlusKPatInPatSynErr p+    go1   ConPatOut{}         = panic "ConPatOut in output of renamer"+    go1   SigPatOut{}         = panic "SigPatOut in output of renamer"+    go1   CoPat{}             = panic "CoPat in output of renamer"++asPatInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a+asPatInPatSynErr pat+  = failWithTc $+    hang (text "Pattern synonym definition cannot contain as-patterns (@):")+       2 (ppr pat)++thInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a+thInPatSynErr pat+  = failWithTc $+    hang (text "Pattern synonym definition cannot contain Template Haskell:")+       2 (ppr pat)++nPlusKPatInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a+nPlusKPatInPatSynErr pat+  = failWithTc $+    hang (text "Pattern synonym definition cannot contain n+k-pattern:")+       2 (ppr pat)++nonBidirectionalErr :: Outputable name => name -> TcM a+nonBidirectionalErr name = failWithTc $+    text "non-bidirectional pattern synonym"+    <+> quotes (ppr name) <+> text "used in an expression"++-- Walk the whole pattern and for all ConPatOuts, collect the+-- existentially-bound type variables and evidence binding variables.+--+-- These are used in computing the type of a pattern synonym and also+-- in generating matcher functions, since success continuations need+-- to be passed these pattern-bound evidences.+tcCollectEx+  :: LPat Id+  -> ( [TyVar]        -- Existentially-bound type variables+                      -- in correctly-scoped order; e.g. [ k:*, x:k ]+     , [EvVar] )      -- and evidence variables++tcCollectEx pat = go pat+  where+    go :: LPat Id -> ([TyVar], [EvVar])+    go = go1 . unLoc++    go1 :: Pat Id -> ([TyVar], [EvVar])+    go1 (LazyPat p)         = go p+    go1 (AsPat _ p)         = go p+    go1 (ParPat p)          = go p+    go1 (BangPat p)         = go p+    go1 (ListPat ps _ _)    = mergeMany . map go $ ps+    go1 (TuplePat ps _ _)   = mergeMany . map go $ ps+    go1 (SumPat p _ _ _)    = go p+    go1 (PArrPat ps _)      = mergeMany . map go $ ps+    go1 (ViewPat _ p _)     = go p+    go1 con@ConPatOut{}     = merge (pat_tvs con, pat_dicts con) $+                              goConDetails $ pat_args con+    go1 (SigPatOut p _)     = go p+    go1 (CoPat _ p _)       = go1 p+    go1 (NPlusKPat n k _ geq subtract _)+      = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract+    go1 _                   = empty++    goConDetails :: HsConPatDetails Id -> ([TyVar], [EvVar])+    goConDetails (PrefixCon ps) = mergeMany . map go $ ps+    goConDetails (InfixCon p1 p2) = go p1 `merge` go p2+    goConDetails (RecCon HsRecFields{ rec_flds = flds })+      = mergeMany . map goRecFd $ flds++    goRecFd :: LHsRecField Id (LPat Id) -> ([TyVar], [EvVar])+    goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p++    merge (vs1, evs1) (vs2, evs2) = (vs1 ++ vs2, evs1 ++ evs2)+    mergeMany = foldr merge empty+    empty     = ([], [])
+ typecheck/TcPatSyn.hs-boot view
@@ -0,0 +1,19 @@+module TcPatSyn where++import Name      ( Name )+import Id        ( Id )+import HsSyn     ( PatSynBind, LHsBinds )+import TcRnTypes ( TcM, TcPatSynInfo )+import TcRnMonad ( TcGblEnv)+import Outputable ( Outputable )++tcInferPatSynDecl :: PatSynBind Name Name+                  -> TcM (LHsBinds Id, TcGblEnv)++tcCheckPatSynDecl :: PatSynBind Name Name+                  -> TcPatSynInfo+                  -> TcM (LHsBinds Id, TcGblEnv)++tcPatSynBuilderBind :: PatSynBind Name Name -> TcM (LHsBinds Id)++nonBidirectionalErr :: Outputable name => name -> TcM a
+ typecheck/TcPluginM.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE CPP #-}+-- | This module provides an interface for typechecker plugins to+-- access select functions of the 'TcM', principally those to do with+-- reading parts of the state.+module TcPluginM (+#ifdef GHCI+        -- * Basic TcPluginM functionality+        TcPluginM,+        tcPluginIO,+        tcPluginTrace,+        unsafeTcPluginTcM,++        -- * Finding Modules and Names+        FindResult(..),+        findImportedModule,+        lookupOrig,++        -- * Looking up Names in the typechecking environment+        tcLookupGlobal,+        tcLookupTyCon,+        tcLookupDataCon,+        tcLookupClass,+        tcLookup,+        tcLookupId,++        -- * Getting the TcM state+        getTopEnv,+        getEnvs,+        getInstEnvs,+        getFamInstEnvs,+        matchFam,++        -- * Type variables+        newUnique,+        newFlexiTyVar,+        isTouchableTcPluginM,++        -- * Zonking+        zonkTcType,+        zonkCt,++        -- * Creating constraints+        newWanted,+        newDerived,+        newGiven,+        newCoercionHole,++        -- * Manipulating evidence bindings+        newEvVar,+        setEvBind,+        getEvBindsTcPluginM+#endif+    ) where++#ifdef GHCI+import qualified TcRnMonad as TcM+import qualified TcSMonad  as TcS+import qualified TcEnv     as TcM+import qualified TcMType   as TcM+import qualified FamInst   as TcM+import qualified IfaceEnv+import qualified Finder++import FamInstEnv ( FamInstEnv )+import TcRnMonad  ( TcGblEnv, TcLclEnv, Ct, CtLoc, TcPluginM+                  , unsafeTcPluginTcM, getEvBindsTcPluginM+                  , liftIO, traceTc )+import TcMType    ( TcTyVar, TcType )+import TcEnv      ( TcTyThing )+import TcEvidence ( TcCoercion, CoercionHole+                  , EvTerm, EvBind, mkGivenEvBind )+import TcRnTypes  ( CtEvidence(..) )+import Var        ( EvVar )++import Module+import Name+import TyCon+import DataCon+import Class+import HscTypes+import Outputable+import Type+import Id+import InstEnv+import FastString+import Unique+++-- | Perform some IO, typically to interact with an external tool.+tcPluginIO :: IO a -> TcPluginM a+tcPluginIO a = unsafeTcPluginTcM (liftIO a)++-- | Output useful for debugging the compiler.+tcPluginTrace :: String -> SDoc -> TcPluginM ()+tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b)+++findImportedModule :: ModuleName -> Maybe FastString -> TcPluginM FindResult+findImportedModule mod_name mb_pkg = do+    hsc_env <- getTopEnv+    tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg++lookupOrig :: Module -> OccName -> TcPluginM Name+lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod+++tcLookupGlobal :: Name -> TcPluginM TyThing+tcLookupGlobal = unsafeTcPluginTcM . TcM.tcLookupGlobal++tcLookupTyCon :: Name -> TcPluginM TyCon+tcLookupTyCon = unsafeTcPluginTcM . TcM.tcLookupTyCon++tcLookupDataCon :: Name -> TcPluginM DataCon+tcLookupDataCon = unsafeTcPluginTcM . TcM.tcLookupDataCon++tcLookupClass :: Name -> TcPluginM Class+tcLookupClass = unsafeTcPluginTcM . TcM.tcLookupClass++tcLookup :: Name -> TcPluginM TcTyThing+tcLookup = unsafeTcPluginTcM . TcM.tcLookup++tcLookupId :: Name -> TcPluginM Id+tcLookupId = unsafeTcPluginTcM . TcM.tcLookupId+++getTopEnv :: TcPluginM HscEnv+getTopEnv = unsafeTcPluginTcM TcM.getTopEnv++getEnvs :: TcPluginM (TcGblEnv, TcLclEnv)+getEnvs = unsafeTcPluginTcM TcM.getEnvs++getInstEnvs :: TcPluginM InstEnvs+getInstEnvs = unsafeTcPluginTcM TcM.tcGetInstEnvs++getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv)+getFamInstEnvs = unsafeTcPluginTcM TcM.tcGetFamInstEnvs++matchFam :: TyCon -> [Type]+         -> TcPluginM (Maybe (TcCoercion, TcType))+matchFam tycon args = unsafeTcPluginTcM $ TcS.matchFamTcM tycon args++newUnique :: TcPluginM Unique+newUnique = unsafeTcPluginTcM TcM.newUnique++newFlexiTyVar :: Kind -> TcPluginM TcTyVar+newFlexiTyVar = unsafeTcPluginTcM . TcM.newFlexiTyVar++isTouchableTcPluginM :: TcTyVar -> TcPluginM Bool+isTouchableTcPluginM = unsafeTcPluginTcM . TcM.isTouchableTcM++-- Confused by zonking? See Note [What is zonking?] in TcMType.+zonkTcType :: TcType -> TcPluginM TcType+zonkTcType = unsafeTcPluginTcM . TcM.zonkTcType++zonkCt :: Ct -> TcPluginM Ct+zonkCt = unsafeTcPluginTcM . TcM.zonkCt+++-- | Create a new wanted constraint.+newWanted  :: CtLoc -> PredType -> TcPluginM CtEvidence+newWanted loc pty+  = unsafeTcPluginTcM (TcM.newWanted (TcM.ctLocOrigin loc) Nothing pty)++-- | Create a new derived constraint.+newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence+newDerived loc pty = return CtDerived { ctev_pred = pty, ctev_loc = loc }++-- | Create a new given constraint, with the supplied evidence.  This+-- must not be invoked from 'tcPluginInit' or 'tcPluginStop', or it+-- will panic.+newGiven :: CtLoc -> PredType -> EvTerm -> TcPluginM CtEvidence+newGiven loc pty evtm = do+   new_ev <- newEvVar pty+   setEvBind $ mkGivenEvBind new_ev evtm+   return CtGiven { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc }++-- | Create a fresh evidence variable.+newEvVar :: PredType -> TcPluginM EvVar+newEvVar = unsafeTcPluginTcM . TcM.newEvVar++-- | Create a fresh coercion hole.+newCoercionHole :: TcPluginM CoercionHole+newCoercionHole = unsafeTcPluginTcM $ TcM.newCoercionHole++-- | Bind an evidence variable.  This must not be invoked from+-- 'tcPluginInit' or 'tcPluginStop', or it will panic.+setEvBind :: EvBind -> TcPluginM ()+setEvBind ev_bind = do+    tc_evbinds <- getEvBindsTcPluginM+    unsafeTcPluginTcM $ TcM.addTcEvBind tc_evbinds ev_bind+#endif
+ typecheck/TcRnDriver.hs view
@@ -0,0 +1,2640 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[TcMovectle]{Typechecking a whole module}++https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TypeChecker+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}++module TcRnDriver (+        tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType,+        tcRnImportDecls,+        tcRnLookupRdrName,+        getModuleInterface,+        tcRnDeclsi,+        isGHCiMonad,+        runTcInteractive,    -- Used by GHC API clients (Trac #8878)+        tcRnLookupName,+        tcRnGetInfo,+        tcRnModule, tcRnModuleTcRnM,+        tcTopSrcDecls,+        rnTopSrcDecls,+        checkBootDecl, checkHiBootIface',+        findExtraSigImports,+        implicitRequirements,+        checkUnitId,+        mergeSignatures,+        tcRnMergeSignatures,+        instantiateSignature,+        tcRnInstantiateSignature,+        loadUnqualIfaces,+        -- More private...+        badReexportedBootThing,+        checkBootDeclM,+        missingBootThing,+    ) where++import {-# SOURCE #-} TcSplice ( finishTH )+import RnSplice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )+import IfaceEnv( externaliseName )+import TcHsType+import TcMatches+import Inst( deeplyInstantiate )+import TcUnify( checkConstraints )+import RnTypes+import RnExpr+import MkId+import TidyPgm    ( globaliseAndTidyId )+import TysWiredIn ( unitTy, mkListTy )+#ifdef GHCI+import DynamicLoading ( loadPlugins )+import Plugins ( tcPlugin )+#endif++import DynFlags+import HsSyn+import IfaceSyn ( ShowSub(..), showToHeader )+import IfaceType( ShowForAllFlag(..) )+import PrelNames+import RdrName+import TcHsSyn+import TcExpr+import TcRnMonad+import TcRnExports+import TcEvidence+import qualified BooleanFormula as BF+import PprTyThing( pprTyThingInContext )+import MkIface( tyThingToIfaceDecl )+import Coercion( pprCoAxiom )+import CoreFVs( orphNamesOfFamInst )+import FamInst+import InstEnv+import FamInstEnv+import TcAnnotations+import TcBinds+import HeaderInfo       ( mkPrelImports )+import TcDefaults+import TcEnv+import TcRules+import TcForeign+import TcInstDcls+import TcIface+import TcMType+import TcType+import TcSimplify+import TcTyClsDecls+import TcTypeable ( mkTypeableBinds )+import TcBackpack+import LoadIface+import RnNames+import RnEnv+import RnSource+import ErrUtils+import Id+import VarEnv+import Module+import UniqFM+import Name+import NameEnv+import NameSet+import Avail+import TyCon+import SrcLoc+import HscTypes+import ListSetOps+import Outputable+import ConLike+import DataCon+import Type+import Class+import BasicTypes hiding( SuccessFlag(..) )+import CoAxiom+import Annotations+import Data.List ( sortBy, sort )+import Data.Ord+import FastString+import Maybes+import Util+import Bag+import Inst (tcGetInsts)+import qualified GHC.LanguageExtensions as LangExt+import Data.Data ( Data )+import HsDumpAst+import qualified Data.Set as S++import Control.Monad++#include "HsVersions.h"++{-+************************************************************************+*                                                                      *+        Typecheck and rename a module+*                                                                      *+************************************************************************+-}++-- | Top level entry point for typechecker and renamer+tcRnModule :: HscEnv+           -> HscSource+           -> Bool              -- True <=> save renamed syntax+           -> HsParsedModule+           -> IO (Messages, Maybe TcGblEnv)++tcRnModule hsc_env hsc_src save_rn_syntax+   parsedModule@HsParsedModule {hpm_module=L loc this_module}+ | RealSrcSpan real_loc <- loc+ = withTiming (pure dflags)+              (text "Renamer/typechecker"<+>brackets (ppr this_mod))+              (const ()) $+   initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $+          withTcPlugins hsc_env $++          tcRnModuleTcRnM hsc_env hsc_src parsedModule pair++  | otherwise+  = return ((emptyBag, unitBag err_msg), Nothing)++  where+    dflags = hsc_dflags hsc_env+    err_msg = mkPlainErrMsg (hsc_dflags hsc_env) loc $+              text "Module does not have a RealSrcSpan:" <+> ppr this_mod++    this_pkg = thisPackage (hsc_dflags hsc_env)++    pair :: (Module, SrcSpan)+    pair@(this_mod,_)+      | Just (L mod_loc mod) <- hsmodName this_module+      = (mkModule this_pkg mod, mod_loc)++      | otherwise   -- 'module M where' is omitted+      = (mAIN, srcLocSpan (srcSpanStart loc))+++++tcRnModuleTcRnM :: HscEnv+                -> HscSource+                -> HsParsedModule+                -> (Module, SrcSpan)+                -> TcRn TcGblEnv+-- Factored out separately from tcRnModule so that a Core plugin can+-- call the type checker directly+tcRnModuleTcRnM hsc_env hsc_src+                (HsParsedModule {+                   hpm_module =+                      (L loc (HsModule maybe_mod export_ies+                                       import_decls local_decls mod_deprec+                                       maybe_doc_hdr)),+                   hpm_src_files = src_files+                })+                (this_mod, prel_imp_loc)+ = setSrcSpan loc $+   do { let { explicit_mod_hdr = isJust maybe_mod } ;++                -- Load the hi-boot interface for this module, if any+                -- We do this now so that the boot_names can be passed+                -- to tcTyAndClassDecls, because the boot_names are+                -- automatically considered to be loop breakers+        tcg_env <- getGblEnv ;+        boot_info <- tcHiBootIface hsc_src this_mod ;+        setGblEnv (tcg_env { tcg_self_boot = boot_info }) $ do {++        -- Deal with imports; first add implicit prelude+        implicit_prelude <- xoptM LangExt.ImplicitPrelude;+        let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc+                                         implicit_prelude import_decls } ;++        whenWOptM Opt_WarnImplicitPrelude $+             when (notNull prel_imports) $+                  addWarn (Reason Opt_WarnImplicitPrelude) (implicitPreludeWarn) ;++        -- TODO This is a little skeevy; maybe handle a bit more directly+        let { simplifyImport (L _ idecl) = (fmap sl_fs (ideclPkgQual idecl), ideclName idecl) } ;+        raw_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src (moduleName this_mod) ;+        raw_req_imports <- liftIO $+            implicitRequirements hsc_env (map simplifyImport (prel_imports ++ import_decls)) ;+        let { mkImport (Nothing, L _ mod_name) = noLoc $ (simpleImportDecl mod_name) {+                ideclHiding = Just (False, noLoc [])+                } ;+              mkImport _ = panic "mkImport" } ;++        let { all_imports = prel_imports ++ import_decls+                       ++ map mkImport (raw_sig_imports ++ raw_req_imports) } ;++          -- OK now finally rename the imports+        tcg_env <- {-# SCC "tcRnImports" #-}+                   tcRnImports hsc_env all_imports ;++          -- If the whole module is warned about or deprecated+          -- (via mod_deprec) record that in tcg_warns. If we do thereby add+          -- a WarnAll, it will override any subseqent depracations added to tcg_warns+        let { tcg_env1 = case mod_deprec of+                         Just (L _ txt) -> tcg_env { tcg_warns = WarnAll txt }+                         Nothing        -> tcg_env+            } ;++        setGblEnv tcg_env1 $ do {++                -- Rename and type check the declarations+        traceRn "rn1a" empty ;+        tcg_env <- if isHsBootOrSig hsc_src then+                        tcRnHsBootDecls hsc_src local_decls+                   else+                        {-# SCC "tcRnSrcDecls" #-}+                        tcRnSrcDecls explicit_mod_hdr local_decls ;+        setGblEnv tcg_env               $ do {++                -- Process the export list+        traceRn "rn4a: before exports" empty;+        tcg_env <- tcRnExports explicit_mod_hdr export_ies tcg_env ;+        traceRn "rn4b: after exports" empty ;++                -- Check that main is exported (must be after tcRnExports)+        checkMainExported tcg_env ;++        -- Compare the hi-boot iface (if any) with the real thing+        -- Must be done after processing the exports+        tcg_env <- checkHiBootIface tcg_env boot_info ;++        -- The new type env is already available to stuff slurped from+        -- interface files, via TcEnv.setGlobalTypeEnv+        -- It's important that this includes the stuff in checkHiBootIface,+        -- because the latter might add new bindings for boot_dfuns,+        -- which may be mentioned in imported unfoldings++                -- Don't need to rename the Haddock documentation,+                -- it's not parsed by GHC anymore.+        tcg_env <- return (tcg_env { tcg_doc_hdr = maybe_doc_hdr }) ;++                -- Report unused names+                -- Do this /after/ type inference, so that when reporting+                -- a function with no type signature we can give the+                -- inferred type+        reportUnusedNames export_ies tcg_env ;++                -- add extra source files to tcg_dependent_files+        addDependentFiles src_files ;++                -- Dump output and return+        tcDump tcg_env ;+        return tcg_env+    }}}}++implicitPreludeWarn :: SDoc+implicitPreludeWarn+  = text "Module `Prelude' implicitly imported"++{-+************************************************************************+*                                                                      *+                Import declarations+*                                                                      *+************************************************************************+-}++tcRnImports :: HscEnv -> [LImportDecl RdrName] -> TcM TcGblEnv+tcRnImports hsc_env import_decls+  = do  { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ;++        ; this_mod <- getModule+        ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)+              ; dep_mods = imp_dep_mods imports++                -- We want instance declarations from all home-package+                -- modules below this one, including boot modules, except+                -- ourselves.  The 'except ourselves' is so that we don't+                -- get the instances from this module's hs-boot file.  This+                -- filtering also ensures that we don't see instances from+                -- modules batch (@--make@) compiled before this one, but+                -- which are not below this one.+              ; want_instances :: ModuleName -> Bool+              ; want_instances mod = mod `elemUFM` dep_mods+                                   && mod /= moduleName this_mod+              ; (home_insts, home_fam_insts) = hptInstances hsc_env+                                                            want_instances+              } ;++                -- Record boot-file info in the EPS, so that it's+                -- visible to loadHiBootInterface in tcRnSrcDecls,+                -- and any other incrementally-performed imports+        ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;++                -- Update the gbl env+        ; updGblEnv ( \ gbl ->+            gbl {+              tcg_rdr_env      = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env,+              tcg_imports      = tcg_imports gbl `plusImportAvails` imports,+              tcg_rn_imports   = rn_imports,+              tcg_inst_env     = extendInstEnvList (tcg_inst_env gbl) home_insts,+              tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)+                                                      home_fam_insts,+              tcg_hpc          = hpc_info+            }) $ do {++        ; traceRn "rn1" (ppr (imp_dep_mods imports))+                -- Fail if there are any errors so far+                -- The error printing (if needed) takes advantage+                -- of the tcg_env we have now set+--      ; traceIf (text "rdr_env: " <+> ppr rdr_env)+        ; failIfErrsM++                -- Load any orphan-module (including orphan family+                -- instance-module) interfaces, so that their rules and+                -- instance decls will be found.  But filter out a+                -- self hs-boot: these instances will be checked when+                -- we define them locally.+                -- (We don't need to load non-orphan family instance+                -- modules until we either try to use the instances they+                -- define, or define our own family instances, at which+                -- point we need to check them for consistency.)+        ; loadModuleInterfaces (text "Loading orphan modules")+                               (filter (/= this_mod) (imp_orphs imports))++                -- Check type-family consistency between imports.+                -- See Note [The type family instance consistency story]+        ; traceRn "rn1: checking family instance consistency" empty+        ; let { dir_imp_mods = moduleEnvKeys+                             . imp_mods+                             $ imports }+        ; tcg_env <- checkFamInstConsistency (imp_finsts imports) dir_imp_mods ;++        ; return tcg_env } }++{-+************************************************************************+*                                                                      *+        Type-checking the top level of a module+*                                                                      *+************************************************************************+-}++tcRnSrcDecls :: Bool  -- False => no 'module M(..) where' header at all+             -> [LHsDecl RdrName]               -- Declarations+             -> TcM TcGblEnv+tcRnSrcDecls explicit_mod_hdr decls+ = do { -- Do all the declarations+      ; ((tcg_env, tcl_env), lie) <- captureTopConstraints $+              do { (tcg_env, tcl_env) <- tc_rn_src_decls decls++                   -- Check for the 'main' declaration+                   -- Must do this inside the captureTopConstraints+                 ; tcg_env <- setEnvs (tcg_env, tcl_env) $+                              checkMain explicit_mod_hdr+                 ; return (tcg_env, tcl_env) }++      ; setEnvs (tcg_env, tcl_env) $ do {++             --         Simplify constraints+             --+             -- We do this after checkMain, so that we use the type info+             -- that checkMain adds+             --+             -- We do it with both global and local env in scope:+             --  * the global env exposes the instances to simplifyTop+             --  * the local env exposes the local Ids to simplifyTop,+             --    so that we get better error messages (monomorphism restriction)+      ; new_ev_binds <- {-# SCC "simplifyTop" #-}+                        simplifyTop lie++        -- Emit Typeable bindings+      ; tcg_env <- mkTypeableBinds++        -- Finalizers must run after constraints are simplified, or some types+        -- might not be complete when using reify (see #12777).+      ; (tcg_env, tcl_env) <- setGblEnv tcg_env run_th_modfinalizers+      ; setEnvs (tcg_env, tcl_env) $ do {++      ; finishTH++      ; traceTc "Tc9" empty++      ; failIfErrsM     -- Don't zonk if there have been errors+                        -- It's a waste of time; and we may get debug warnings+                        -- about strangely-typed TyCons!+      ; traceTc "Tc10" empty++        -- Zonk the final code.  This must be done last.+        -- Even simplifyTop may do some unification.+        -- This pass also warns about missing type signatures+      ; let { TcGblEnv { tcg_type_env  = type_env,+                         tcg_binds     = binds,+                         tcg_ev_binds  = cur_ev_binds,+                         tcg_imp_specs = imp_specs,+                         tcg_rules     = rules,+                         tcg_vects     = vects,+                         tcg_fords     = fords } = tcg_env+            ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;++      ; (bind_env, ev_binds', binds', fords', imp_specs', rules', vects')+            <- {-# SCC "zonkTopDecls" #-}+               zonkTopDecls all_ev_binds binds rules vects+                            imp_specs fords ;+      ; traceTc "Tc11" empty++      ; let { final_type_env = plusTypeEnv type_env bind_env+            ; tcg_env' = tcg_env { tcg_binds    = binds',+                                   tcg_ev_binds = ev_binds',+                                   tcg_imp_specs = imp_specs',+                                   tcg_rules    = rules',+                                   tcg_vects    = vects',+                                   tcg_fords    = fords' } } ;++      ; setGlobalTypeEnv tcg_env' final_type_env++   }+   } }++-- | Runs TH finalizers and renames and typechecks the top-level declarations+-- that they could introduce.+run_th_modfinalizers :: TcM (TcGblEnv, TcLclEnv)+run_th_modfinalizers = do+  th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv+  th_modfinalizers <- readTcRef th_modfinalizers_var+  if null th_modfinalizers+  then getEnvs+  else do+    writeTcRef th_modfinalizers_var []+    (envs, lie) <- captureTopConstraints $ do+      sequence_ th_modfinalizers+      -- Finalizers can add top-level declarations with addTopDecls.+      tc_rn_src_decls []+    setEnvs envs $ do+      -- Subsequent rounds of finalizers run after any new constraints are+      -- simplified, or some types might not be complete when using reify+      -- (see #12777).+      new_ev_binds <- {-# SCC "simplifyTop2" #-}+                      simplifyTop lie+      updGblEnv (\tcg_env ->+        tcg_env { tcg_ev_binds = tcg_ev_binds tcg_env `unionBags` new_ev_binds }+        )+        -- addTopDecls can add declarations which add new finalizers.+        run_th_modfinalizers++tc_rn_src_decls :: [LHsDecl RdrName]+                -> TcM (TcGblEnv, TcLclEnv)+-- Loops around dealing with each top level inter-splice group+-- in turn, until it's dealt with the entire module+tc_rn_src_decls ds+ = {-# SCC "tc_rn_src_decls" #-}+   do { (first_group, group_tail) <- findSplice ds+                -- If ds is [] we get ([], Nothing)++        -- Deal with decls up to, but not including, the first splice+      ; (tcg_env, rn_decls) <- rnTopSrcDecls first_group+                -- rnTopSrcDecls fails if there are any errors++        -- Get TH-generated top-level declarations and make sure they don't+        -- contain any splices since we don't handle that at the moment+        --+        -- The plumbing here is a bit odd: see Trac #10853+      ; th_topdecls_var <- fmap tcg_th_topdecls getGblEnv+      ; th_ds <- readTcRef th_topdecls_var+      ; writeTcRef th_topdecls_var []++      ; (tcg_env, rn_decls) <-+            if null th_ds+            then return (tcg_env, rn_decls)+            else do { (th_group, th_group_tail) <- findSplice th_ds+                    ; case th_group_tail of+                        { Nothing -> return () ;+                        ; Just (SpliceDecl (L loc _) _, _)+                            -> setSrcSpan loc $+                               addErr (text "Declaration splices are not permitted inside top-level declarations added with addTopDecls")+                        } ;++                    -- Rename TH-generated top-level declarations+                    ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env $+                      rnTopSrcDecls th_group++                    -- Dump generated top-level declarations+                    ; let msg = "top-level declarations added with addTopDecls"+                    ; traceSplice $ SpliceInfo { spliceDescription = msg+                                               , spliceIsDecl    = True+                                               , spliceSource    = Nothing+                                               , spliceGenerated = ppr th_rn_decls }++                    ; return (tcg_env, appendGroups rn_decls th_rn_decls)+                    }++      -- Type check all declarations+      ; (tcg_env, tcl_env) <- setGblEnv tcg_env $+                              tcTopSrcDecls rn_decls++        -- If there is no splice, we're nearly done+      ; setEnvs (tcg_env, tcl_env) $+        case group_tail of+          { Nothing -> return (tcg_env, tcl_env)++            -- If there's a splice, we must carry on+          ; Just (SpliceDecl (L loc splice) _, rest_ds) ->+            do { recordTopLevelSpliceLoc loc++                 -- Rename the splice expression, and get its supporting decls+               ; (spliced_decls, splice_fvs) <- checkNoErrs (rnTopSpliceDecls+                                                             splice)++                 -- Glue them on the front of the remaining decls and loop+               ; setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $+                 tc_rn_src_decls (spliced_decls ++ rest_ds)+               }+          }+      }++{-+************************************************************************+*                                                                      *+        Compiling hs-boot source files, and+        comparing the hi-boot interface with the real thing+*                                                                      *+************************************************************************+-}++tcRnHsBootDecls :: HscSource -> [LHsDecl RdrName] -> TcM TcGblEnv+tcRnHsBootDecls hsc_src decls+   = do { (first_group, group_tail) <- findSplice decls++                -- Rename the declarations+        ; (tcg_env, HsGroup { hs_tyclds = tycl_decls+                            , hs_derivds = deriv_decls+                            , hs_fords  = for_decls+                            , hs_defds  = def_decls+                            , hs_ruleds = rule_decls+                            , hs_vects  = vect_decls+                            , hs_annds  = _+                            , hs_valds  = ValBindsOut val_binds val_sigs })+              <- rnTopSrcDecls first_group+        -- The empty list is for extra dependencies coming from .hs-boot files+        -- See Note [Extra dependencies from .hs-boot files] in RnSource+        ; (gbl_env, lie) <- captureTopConstraints $ setGblEnv tcg_env $ do {+++                -- Check for illegal declarations+        ; case group_tail of+             Just (SpliceDecl d _, _) -> badBootDecl hsc_src "splice" d+             Nothing                  -> return ()+        ; mapM_ (badBootDecl hsc_src "foreign") for_decls+        ; mapM_ (badBootDecl hsc_src "default") def_decls+        ; mapM_ (badBootDecl hsc_src "rule")    rule_decls+        ; mapM_ (badBootDecl hsc_src "vect")    vect_decls++                -- Typecheck type/class/instance decls+        ; traceTc "Tc2 (boot)" empty+        ; (tcg_env, inst_infos, _deriv_binds)+             <- tcTyClsInstDecls tycl_decls deriv_decls val_binds+        ; setGblEnv tcg_env     $ do {++        -- Emit Typeable bindings+        ; tcg_env <- mkTypeableBinds+        ; setGblEnv tcg_env $ do {++                -- Typecheck value declarations+        ; traceTc "Tc5" empty+        ; val_ids <- tcHsBootSigs val_binds val_sigs++                -- Wrap up+                -- No simplification or zonking to do+        ; traceTc "Tc7a" empty+        ; gbl_env <- getGblEnv++                -- Make the final type-env+                -- Include the dfun_ids so that their type sigs+                -- are written into the interface file.+        ; let { type_env0 = tcg_type_env gbl_env+              ; type_env1 = extendTypeEnvWithIds type_env0 val_ids+              ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids+              ; dfun_ids = map iDFunId inst_infos+              }++        ; setGlobalTypeEnv gbl_env type_env2+   }}}+   ; traceTc "boot" (ppr lie); return gbl_env }++badBootDecl :: HscSource -> String -> Located decl -> TcM ()+badBootDecl hsc_src what (L loc _)+  = addErrAt loc (char 'A' <+> text what+      <+> text "declaration is not (currently) allowed in a"+      <+> (case hsc_src of+            HsBootFile -> text "hs-boot"+            HsigFile -> text "hsig"+            _ -> panic "badBootDecl: should be an hsig or hs-boot file")+      <+> text "file")++{-+Once we've typechecked the body of the module, we want to compare what+we've found (gathered in a TypeEnv) with the hi-boot details (if any).+-}++checkHiBootIface :: TcGblEnv -> SelfBootInfo -> TcM TcGblEnv+-- Compare the hi-boot file for this module (if there is one)+-- with the type environment we've just come up with+-- In the common case where there is no hi-boot file, the list+-- of boot_names is empty.++checkHiBootIface tcg_env boot_info+  | NoSelfBoot <- boot_info  -- Common case+  = return tcg_env++  | HsBootFile <- tcg_src tcg_env   -- Current module is already a hs-boot file!+  = return tcg_env++  | SelfBoot { sb_mds = boot_details } <- boot_info+  , TcGblEnv { tcg_binds    = binds+             , tcg_insts    = local_insts+             , tcg_type_env = local_type_env+             , tcg_exports  = local_exports } <- tcg_env+  = do  { -- This code is tricky, see Note [DFun knot-tying]+        ; let boot_dfuns = filter isDFunId (typeEnvIds (md_types boot_details))+              type_env'  = extendTypeEnvWithIds local_type_env boot_dfuns+          -- Why the seq?  Without, we will put a TypeEnv thunk in+          -- tcg_type_env_var.  That thunk will eventually get+          -- forced if we are typechecking interfaces, but that+          -- is no good if we are trying to typecheck the very+          -- DFun we were going to put in.+          -- TODO: Maybe setGlobalTypeEnv should be strict.+        ; tcg_env <- type_env' `seq` setGlobalTypeEnv tcg_env type_env'+        ; dfun_prs <- checkHiBootIface' local_insts type_env'+                                        local_exports boot_details+        ; let dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)+                                     | (boot_dfun, dfun) <- dfun_prs ]++        ; return tcg_env { tcg_binds = binds `unionBags` dfun_binds } }++  | otherwise = panic "checkHiBootIface: unreachable code"++-- Note [DFun knot-tying]+-- ~~~~~~~~~~~~~~~~~~~~~~+-- The 'SelfBootInfo' that is fed into 'checkHiBootIface' comes+-- from typechecking the hi-boot file that we are presently+-- implementing.  Suppose we are typechecking the module A:+-- when we typecheck the hi-boot file, whenever we see an+-- identifier A.T, we knot-tie this identifier to the+-- *local* type environment (via if_rec_types.)  The contract+-- then is that we don't *look* at 'SelfBootInfo' until+-- we've finished typechecking the module and updated the+-- type environment with the new tycons and ids.+--+-- This most works well, but there is one problem: DFuns!+-- In general, it's not possible to know a priori what an+-- hs-boot file named a DFun (see Note [DFun impedance matching]),+-- so we look at the ClsInsts from the boot file to figure out+-- what DFuns to add to the type environment.  But we're not+-- allowed to poke the DFuns of the ClsInsts in the SelfBootInfo+-- until we've added the DFuns to the type environment.  A+-- Gordian knot!+--+-- We cut the knot by a little trick: we first *unconditionally*+-- add all of the boot-declared DFuns to the type environment+-- (so that knot tying works, see Trac #4003), without the+-- actual bindings for them.  Then, we compute the impedance+-- matching bindings, and add them to the environment.+--+-- There is one subtlety to doing this: we have to get the+-- DFuns from md_types, not md_insts, even though involves+-- filtering a bunch of TyThings we don't care about.  The+-- reason is only the TypeEnv in md_types has the actual+-- Id we want to add to the environment; the DFun fields+-- in md_insts are typechecking thunks that will attempt to+-- go through if_rec_types to lookup the real Id... but+-- that's what we're trying to setup right now.++checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo]+                  -> ModDetails -> TcM [(Id, Id)]+-- Variant which doesn't require a full TcGblEnv; you could get the+-- local components from another ModDetails.+--+-- Note [DFun impedance matching]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- We return a list of "impedance-matching" bindings for the dfuns+-- defined in the hs-boot file, such as+--           $fxEqT = $fEqT+-- We need these because the module and hi-boot file might differ in+-- the name it chose for the dfun: the name of a dfun is not+-- uniquely determined by its type; there might be multiple dfuns+-- which, individually, would map to the same name (in which case+-- we have to disambiguate them.)  There's no way for the hi file+-- to know exactly what disambiguation to use... without looking+-- at the hi-boot file itself.+--+-- In fact, the names will always differ because we always pick names+-- prefixed with "$fx" for boot dfuns, and "$f" for real dfuns+-- (so that this impedance matching is always possible).++checkHiBootIface'+        local_insts local_type_env local_exports+        (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts,+                      md_types = boot_type_env, md_exports = boot_exports })+  = do  { traceTc "checkHiBootIface" $ vcat+             [ ppr boot_type_env, ppr boot_insts, ppr boot_exports]++                -- Check the exports of the boot module, one by one+        ; mapM_ check_export boot_exports++                -- Check for no family instances+        ; unless (null boot_fam_insts) $+            panic ("TcRnDriver.checkHiBootIface: Cannot handle family " +++                   "instances in boot files yet...")+            -- FIXME: Why?  The actual comparison is not hard, but what would+            --        be the equivalent to the dfun bindings returned for class+            --        instances?  We can't easily equate tycons...++                -- Check instance declarations+                -- and generate an impedance-matching binding+        ; mb_dfun_prs <- mapM check_inst boot_insts++        ; failIfErrsM++        ; return (catMaybes mb_dfun_prs) }++  where+    check_export boot_avail     -- boot_avail is exported by the boot iface+      | name `elem` dfun_names = return ()+      | isWiredInName name     = return ()      -- No checking for wired-in names.  In particular,+                                                -- 'error' is handled by a rather gross hack+                                                -- (see comments in GHC.Err.hs-boot)++        -- Check that the actual module exports the same thing+      | not (null missing_names)+      = addErrAt (nameSrcSpan (head missing_names))+                 (missingBootThing True (head missing_names) "exported by")++        -- If the boot module does not *define* the thing, we are done+        -- (it simply re-exports it, and names match, so nothing further to do)+      | isNothing mb_boot_thing = return ()++        -- Check that the actual module also defines the thing, and+        -- then compare the definitions+      | Just real_thing <- lookupTypeEnv local_type_env name,+        Just boot_thing <- mb_boot_thing+      = checkBootDeclM True boot_thing real_thing++      | otherwise+      = addErrTc (missingBootThing True name "defined in")+      where+        name          = availName boot_avail+        mb_boot_thing = lookupTypeEnv boot_type_env name+        missing_names = case lookupNameEnv local_export_env name of+                          Nothing    -> [name]+                          Just avail -> availNames boot_avail `minusList` availNames avail++    dfun_names = map getName boot_insts++    local_export_env :: NameEnv AvailInfo+    local_export_env = availsToNameEnv local_exports++    check_inst :: ClsInst -> TcM (Maybe (Id, Id))+        -- Returns a pair of the boot dfun in terms of the equivalent+        -- real dfun. Delicate (like checkBootDecl) because it depends+        -- on the types lining up precisely even to the ordering of+        -- the type variables in the foralls.+    check_inst boot_inst+        = case [dfun | inst <- local_insts,+                       let dfun = instanceDFunId inst,+                       idType dfun `eqType` boot_dfun_ty ] of+            [] -> do { traceTc "check_inst" $ vcat+                          [ text "local_insts"  <+> vcat (map (ppr . idType . instanceDFunId) local_insts)+                          , text "boot_inst"    <+> ppr boot_inst+                          , text "boot_dfun_ty" <+> ppr boot_dfun_ty+                          ]+                     ; addErrTc (instMisMatch True boot_inst)+                     ; return Nothing }+            (dfun:_) -> return (Just (local_boot_dfun, dfun))+                     where+                        local_boot_dfun = Id.mkExportedVanillaId boot_dfun_name (idType dfun)+                           -- Name from the /boot-file/ ClsInst, but type from the dfun+                           -- defined in /this module/.  That ensures that the TyCon etc+                           -- inside the type are the ones defined in this module, not+                           -- the ones gotten from the hi-boot file, which may have+                           -- a lot less info (Trac #T8743, comment:10).+        where+          boot_dfun      = instanceDFunId boot_inst+          boot_dfun_ty   = idType boot_dfun+          boot_dfun_name = idName boot_dfun++-- In general, to perform these checks we have to+-- compare the TyThing from the .hi-boot file to the TyThing+-- in the current source file.  We must be careful to allow alpha-renaming+-- where appropriate, and also the boot declaration is allowed to omit+-- constructors and class methods.+--+-- See rnfail055 for a good test of this stuff.++-- | Compares two things for equivalence between boot-file and normal code,+-- reporting an error if they don't match up.+checkBootDeclM :: Bool  -- ^ True <=> an hs-boot file (could also be a sig)+               -> TyThing -> TyThing -> TcM ()+checkBootDeclM is_boot boot_thing real_thing+  = whenIsJust (checkBootDecl is_boot boot_thing real_thing) $ \ err ->+       addErrAt span+                (bootMisMatch is_boot err real_thing boot_thing)+  where+    -- Here we use the span of the boot thing or, if it doesn't have a sensible+    -- span, that of the real thing,+    span+      | let span = nameSrcSpan (getName boot_thing)+      , isGoodSrcSpan span+      = span+      | otherwise+      = nameSrcSpan (getName real_thing)++-- | Compares the two things for equivalence between boot-file and normal+-- code. Returns @Nothing@ on success or @Just "some helpful info for user"@+-- failure. If the difference will be apparent to the user, @Just empty@ is+-- perfectly suitable.+checkBootDecl :: Bool -> TyThing -> TyThing -> Maybe SDoc++checkBootDecl _ (AnId id1) (AnId id2)+  = ASSERT(id1 == id2)+    check (idType id1 `eqType` idType id2)+          (text "The two types are different")++checkBootDecl is_boot (ATyCon tc1) (ATyCon tc2)+  = checkBootTyCon is_boot tc1 tc2++checkBootDecl _ (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _))+  = pprPanic "checkBootDecl" (ppr dc1)++checkBootDecl _ _ _ = Just empty -- probably shouldn't happen++-- | Combines two potential error messages+andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc+Nothing `andThenCheck` msg     = msg+msg     `andThenCheck` Nothing = msg+Just d1 `andThenCheck` Just d2 = Just (d1 $$ d2)+infixr 0 `andThenCheck`++-- | If the test in the first parameter is True, succeed with @Nothing@;+-- otherwise, return the provided check+checkUnless :: Bool -> Maybe SDoc -> Maybe SDoc+checkUnless True  _ = Nothing+checkUnless False k = k++-- | Run the check provided for every pair of elements in the lists.+-- The provided SDoc should name the element type, in the plural.+checkListBy :: (a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc+            -> Maybe SDoc+checkListBy check_fun as bs whats = go [] as bs+  where+    herald = text "The" <+> whats <+> text "do not match"++    go []   [] [] = Nothing+    go docs [] [] = Just (hang (herald <> colon) 2 (vcat $ reverse docs))+    go docs (x:xs) (y:ys) = case check_fun x y of+      Just doc -> go (doc:docs) xs ys+      Nothing  -> go docs       xs ys+    go _    _  _ = Just (hang (herald <> colon)+                            2 (text "There are different numbers of" <+> whats))++-- | If the test in the first parameter is True, succeed with @Nothing@;+-- otherwise, fail with the given SDoc.+check :: Bool -> SDoc -> Maybe SDoc+check True  _   = Nothing+check False doc = Just doc++-- | A more perspicuous name for @Nothing@, for @checkBootDecl@ and friends.+checkSuccess :: Maybe SDoc+checkSuccess = Nothing++----------------+checkBootTyCon :: Bool -> TyCon -> TyCon -> Maybe SDoc+checkBootTyCon is_boot tc1 tc2+  | not (eqType (tyConKind tc1) (tyConKind tc2))+  = Just $ text "The types have different kinds"    -- First off, check the kind++  | Just c1 <- tyConClass_maybe tc1+  , Just c2 <- tyConClass_maybe tc2+  , let (clas_tvs1, clas_fds1, sc_theta1, _, ats1, op_stuff1)+          = classExtraBigSig c1+        (clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2)+          = classExtraBigSig c2+  , Just env <- eqVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2+  = let+       eqSig (id1, def_meth1) (id2, def_meth2)+         = check (name1 == name2)+                 (text "The names" <+> pname1 <+> text "and" <+> pname2 <+>+                  text "are different") `andThenCheck`+           check (eqTypeX env op_ty1 op_ty2)+                 (text "The types of" <+> pname1 <+>+                  text "are different") `andThenCheck`+           if is_boot+               then check (eqMaybeBy eqDM def_meth1 def_meth2)+                          (text "The default methods associated with" <+> pname1 <+>+                           text "are different")+               else check (subDM op_ty1 def_meth1 def_meth2)+                          (text "The default methods associated with" <+> pname1 <+>+                           text "are not compatible")+         where+          name1 = idName id1+          name2 = idName id2+          pname1 = quotes (ppr name1)+          pname2 = quotes (ppr name2)+          (_, rho_ty1) = splitForAllTys (idType id1)+          op_ty1 = funResultTy rho_ty1+          (_, rho_ty2) = splitForAllTys (idType id2)+          op_ty2 = funResultTy rho_ty2++       eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2)+         = checkBootTyCon is_boot tc1 tc2 `andThenCheck`+           check (eqATDef def_ats1 def_ats2)+                 (text "The associated type defaults differ")++       eqDM (_, VanillaDM)    (_, VanillaDM)    = True+       eqDM (_, GenericDM t1) (_, GenericDM t2) = eqTypeX env t1 t2+       eqDM _ _ = False++       -- NB: first argument is from hsig, second is from real impl.+       -- Order of pattern matching matters.+       subDM _ Nothing _ = True+       subDM _ _ Nothing = False+       -- If the hsig wrote:+       --+       --   f :: a -> a+       --   default f :: a -> a+       --+       -- this should be validly implementable using an old-fashioned+       -- vanilla default method.+       subDM t1 (Just (_, GenericDM t2)) (Just (_, VanillaDM))+        = eqTypeX env t1 t2+       -- This case can occur when merging signatures+       subDM t1 (Just (_, VanillaDM)) (Just (_, GenericDM t2))+        = eqTypeX env t1 t2+       subDM _ (Just (_, VanillaDM)) (Just (_, VanillaDM)) = True+       subDM _ (Just (_, GenericDM t1)) (Just (_, GenericDM t2))+        = eqTypeX env t1 t2++       -- Ignore the location of the defaults+       eqATDef Nothing             Nothing             = True+       eqATDef (Just (ty1, _loc1)) (Just (ty2, _loc2)) = eqTypeX env ty1 ty2+       eqATDef _ _ = False++       eqFD (as1,bs1) (as2,bs2) =+         eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&+         eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)+    in+    checkRoles roles1 roles2 `andThenCheck`+          -- Checks kind of class+    check (eqListBy eqFD clas_fds1 clas_fds2)+          (text "The functional dependencies do not match") `andThenCheck`+    checkUnless (isAbstractTyCon tc1) $+    check (eqListBy (eqTypeX env) sc_theta1 sc_theta2)+          (text "The class constraints do not match") `andThenCheck`+    checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck`+    checkListBy eqAT ats1 ats2 (text "associated types") `andThenCheck`+    check (classMinimalDef c1 `BF.implies` classMinimalDef c2)+        (text "The MINIMAL pragmas are not compatible")++  | Just syn_rhs1 <- synTyConRhs_maybe tc1+  , Just syn_rhs2 <- synTyConRhs_maybe tc2+  , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)+  = ASSERT(tc1 == tc2)+    checkRoles roles1 roles2 `andThenCheck`+    check (eqTypeX env syn_rhs1 syn_rhs2) empty   -- nothing interesting to say++  -- This allows abstract 'data T a' to be implemented using 'type T = ...'+  -- and abstract 'class K a' to be implement using 'type K = ...'+  -- See Note [Synonyms implement abstract data]+  | not is_boot -- don't support for hs-boot yet+  , isAbstractTyCon tc1+  , Just (tvs, ty) <- synTyConDefn_maybe tc2+  , Just (tc2', args) <- tcSplitTyConApp_maybe ty+  = checkSynAbsData tvs ty tc2' args+    -- TODO: When it's a synonym implementing a class, we really+    -- should check if the fundeps are satisfied, but+    -- there is not an obvious way to do this for a constraint synonym.+    -- So for now, let it all through (it won't cause segfaults, anyway).+    -- Tracked at #12704.++  | Just fam_flav1 <- famTyConFlav_maybe tc1+  , Just fam_flav2 <- famTyConFlav_maybe tc2+  = ASSERT(tc1 == tc2)+    let eqFamFlav OpenSynFamilyTyCon   OpenSynFamilyTyCon = True+        eqFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) = True+        -- This case only happens for hsig merging:+        eqFamFlav AbstractClosedSynFamilyTyCon AbstractClosedSynFamilyTyCon = True+        eqFamFlav AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True+        eqFamFlav (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True+        eqFamFlav (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2)+            = eqClosedFamilyAx ax1 ax2+        eqFamFlav (BuiltInSynFamTyCon {}) (BuiltInSynFamTyCon {}) = tc1 == tc2+        eqFamFlav _ _ = False+        injInfo1 = familyTyConInjectivityInfo tc1+        injInfo2 = familyTyConInjectivityInfo tc2+    in+    -- check equality of roles, family flavours and injectivity annotations+    -- (NB: Type family roles are always nominal. But the check is+    -- harmless enough.)+    checkRoles roles1 roles2 `andThenCheck`+    check (eqFamFlav fam_flav1 fam_flav2)+        (ifPprDebug $+            text "Family flavours" <+> ppr fam_flav1 <+> text "and" <+> ppr fam_flav2 <+>+            text "do not match") `andThenCheck`+    check (injInfo1 == injInfo2) (text "Injectivities do not match")++  | isAlgTyCon tc1 && isAlgTyCon tc2+  , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)+  = ASSERT(tc1 == tc2)+    checkRoles roles1 roles2 `andThenCheck`+    check (eqListBy (eqTypeX env)+                     (tyConStupidTheta tc1) (tyConStupidTheta tc2))+          (text "The datatype contexts do not match") `andThenCheck`+    eqAlgRhs tc1 (algTyConRhs tc1) (algTyConRhs tc2)++  | otherwise = Just empty   -- two very different types -- should be obvious+  where+    roles1 = tyConRoles tc1 -- the abstract one+    roles2 = tyConRoles tc2+    roles_msg = text "The roles do not match." $$+                (text "Roles on abstract types default to" <+>+                 quotes (text "representational") <+> text "in boot files.")++    roles_subtype_msg = text "The roles are not compatible:" $$+                        text "Main module:" <+> ppr roles2 $$+                        text "Hsig file:" <+> ppr roles1++    checkRoles r1 r2+      | is_boot || isInjectiveTyCon tc1 Representational -- See Note [Role subtyping]+      = check (r1 == r2) roles_msg+      | otherwise = check (r2 `rolesSubtypeOf` r1) roles_subtype_msg++    -- Note [Role subtyping]+    -- ~~~~~~~~~~~~~~~~~~~~~+    -- In the current formulation of roles, role subtyping is only OK if the+    -- "abstract" TyCon was not representationally injective.  Among the most+    -- notable examples of non representationally injective TyCons are abstract+    -- data, which can be implemented via newtypes (which are not+    -- representationally injective).  The key example is+    -- in this example from #13140:+    --+    --      -- In an hsig file+    --      data T a -- abstract!+    --      type role T nominal+    --+    --      -- Elsewhere+    --      foo :: Coercible (T a) (T b) => a -> b+    --      foo x = x+    --+    -- We must NOT allow foo to typecheck, because if we instantiate+    -- T with a concrete data type with a phantom role would cause+    -- Coercible (T a) (T b) to be provable.  Fortunately, if T is not+    -- representationally injective, we cannot make the inference that a ~N b if+    -- T a ~R T b.+    --+    -- Unconditional role subtyping would be possible if we setup+    -- an extra set of roles saying when we can project out coercions+    -- (we call these proj-roles); then it would NOT be valid to instantiate T+    -- with a data type at phantom since the proj-role subtyping check+    -- would fail.  See #13140 for more details.+    --+    -- One consequence of this is we get no role subtyping for non-abstract+    -- data types in signatures. Suppose you have:+    --+    --      signature A where+    --          type role T nominal+    --          data T a = MkT+    --+    -- If you write this, we'll treat T as injective, and make inferences+    -- like T a ~R T b ==> a ~N b (mkNthCo).  But if we can+    -- subsequently replace T with one at phantom role, we would then be able to+    -- infer things like T Int ~R T Bool which is bad news.+    --+    -- We could allow role subtyping here if we didn't treat *any* data types+    -- defined in signatures as injective.  But this would be a bit surprising,+    -- replacing a data type in a module with one in a signature could cause+    -- your code to stop typechecking (whereas if you made the type abstract,+    -- it is more understandable that the type checker knows less).+    --+    -- It would have been best if this was purely a question of defaults+    -- (i.e., a user could explicitly ask for one behavior or another) but+    -- the current role system isn't expressive enough to do this.+    -- Having explict proj-roles would solve this problem.++    rolesSubtypeOf [] [] = True+    -- NB: this relation is the OPPOSITE of the subroling relation+    rolesSubtypeOf (x:xs) (y:ys) = x >= y && rolesSubtypeOf xs ys+    rolesSubtypeOf _ _ = False++    -- Note [Synonyms implement abstract data]+    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    -- An abstract data type or class can be implemented using a type synonym,+    -- but ONLY if the type synonym is nullary and has no type family+    -- applications.  This arises from two properties of skolem abstract data:+    --+    --    For any T (with some number of paramaters),+    --+    --    1. T is a valid type (it is "curryable"), and+    --+    --    2. T is valid in an instance head (no type families).+    --+    -- See also 'HowAbstract' and Note [Skolem abstract data].++    -- | Given @type T tvs = ty@, where @ty@ decomposes into @tc2' args@,+    -- check that this synonym is an acceptable implementation of @tc1@.+    -- See Note [Synonyms implement abstract data]+    checkSynAbsData :: [TyVar] -> Type -> TyCon -> [Type] -> Maybe SDoc+    checkSynAbsData tvs ty tc2' args =+        check (null (tcTyFamInsts ty))+              (text "Illegal type family application in implementation of abstract data.")+                `andThenCheck`+        check (null tvs)+              (text "Illegal parameterized type synonym in implementation of abstract data." $$+               text "(Try eta reducing your type synonym so that it is nullary.)")+                `andThenCheck`+        -- Don't report roles errors unless the type synonym is nullary+        checkUnless (not (null tvs)) $+            ASSERT( null roles2 )+            -- If we have something like:+            --+            --  signature H where+            --      data T a+            --  module H where+            --      data K a b = ...+            --      type T = K Int+            --+            -- we need to drop the first role of K when comparing!+            checkRoles roles1 (drop (length args) (tyConRoles tc2'))+{-+        -- Hypothetically, if we were allow to non-nullary type synonyms, here+        -- is how you would check the roles+        if length tvs == length roles1+            then checkRoles roles1 roles2+            else case tcSplitTyConApp_maybe ty of+                    Just (tc2', args) ->+                        checkRoles roles1 (drop (length args) (tyConRoles tc2') ++ roles2)+                    Nothing -> Just roles_msg+-}++    eqAlgRhs _ AbstractTyCon _rhs2+      = checkSuccess -- rhs2 is guaranteed to be injective, since it's an AlgTyCon+    eqAlgRhs _  tc1@DataTyCon{} tc2@DataTyCon{} =+        checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors")+    eqAlgRhs _  tc1@NewTyCon{} tc2@NewTyCon{} =+        eqCon (data_con tc1) (data_con tc2)+    eqAlgRhs _ _ _ = Just (text "Cannot match a" <+> quotes (text "data") <+>+                           text "definition with a" <+> quotes (text "newtype") <+>+                           text "definition")++    eqCon c1 c2+      =  check (name1 == name2)+               (text "The names" <+> pname1 <+> text "and" <+> pname2 <+>+                text "differ") `andThenCheck`+         check (dataConIsInfix c1 == dataConIsInfix c2)+               (text "The fixities of" <+> pname1 <+>+                text "differ") `andThenCheck`+         check (eqListBy eqHsBang (dataConImplBangs c1) (dataConImplBangs c2))+               (text "The strictness annotations for" <+> pname1 <+>+                text "differ") `andThenCheck`+         check (map flSelector (dataConFieldLabels c1) == map flSelector (dataConFieldLabels c2))+               (text "The record label lists for" <+> pname1 <+>+                text "differ") `andThenCheck`+         check (eqType (dataConUserType c1) (dataConUserType c2))+               (text "The types for" <+> pname1 <+> text "differ")+      where+        name1 = dataConName c1+        name2 = dataConName c2+        pname1 = quotes (ppr name1)+        pname2 = quotes (ppr name2)++    eqClosedFamilyAx Nothing Nothing  = True+    eqClosedFamilyAx Nothing (Just _) = False+    eqClosedFamilyAx (Just _) Nothing = False+    eqClosedFamilyAx (Just (CoAxiom { co_ax_branches = branches1 }))+                     (Just (CoAxiom { co_ax_branches = branches2 }))+      =  numBranches branches1 == numBranches branches2+      && (and $ zipWith eqClosedFamilyBranch branch_list1 branch_list2)+      where+        branch_list1 = fromBranches branches1+        branch_list2 = fromBranches branches2++    eqClosedFamilyBranch (CoAxBranch { cab_tvs = tvs1, cab_cvs = cvs1+                                     , cab_lhs = lhs1, cab_rhs = rhs1 })+                         (CoAxBranch { cab_tvs = tvs2, cab_cvs = cvs2+                                     , cab_lhs = lhs2, cab_rhs = rhs2 })+      | Just env1 <- eqVarBndrs emptyRnEnv2 tvs1 tvs2+      , Just env  <- eqVarBndrs env1        cvs1 cvs2+      = eqListBy (eqTypeX env) lhs1 lhs2 &&+        eqTypeX env rhs1 rhs2++      | otherwise = False++emptyRnEnv2 :: RnEnv2+emptyRnEnv2 = mkRnEnv2 emptyInScopeSet++----------------+missingBootThing :: Bool -> Name -> String -> SDoc+missingBootThing is_boot name what+  = quotes (ppr name) <+> text "is exported by the"+    <+> (if is_boot then text "hs-boot" else text "hsig")+    <+> text "file, but not"+    <+> text what <+> text "the module"++badReexportedBootThing :: DynFlags -> Bool -> Name -> Name -> SDoc+badReexportedBootThing dflags is_boot name name'+  = withPprStyle (mkUserStyle dflags alwaysQualify AllTheWay) $ vcat+        [ text "The" <+> (if is_boot then text "hs-boot" else text "hsig")+           <+> text "file (re)exports" <+> quotes (ppr name)+        , text "but the implementing module exports a different identifier" <+> quotes (ppr name')+        ]++bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> SDoc+bootMisMatch is_boot extra_info real_thing boot_thing+  = pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc+  where+    to_doc+      = pprTyThingInContext $ showToHeader { ss_forall =+                                              if is_boot+                                                then ShowForAllMust+                                                else ShowForAllWhen }++    real_doc = to_doc real_thing+    boot_doc = to_doc boot_thing++    pprBootMisMatch :: Bool -> SDoc -> TyThing -> SDoc -> SDoc -> SDoc+    pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc+      = vcat+          [ ppr real_thing <+>+            text "has conflicting definitions in the module",+            text "and its" <+>+              (if is_boot+                then text "hs-boot file"+                else text "hsig file"),+            text "Main module:" <+> real_doc,+              (if is_boot+                then text "Boot file:  "+                else text "Hsig file: ")+                <+> boot_doc,+            extra_info+          ]++instMisMatch :: Bool -> ClsInst -> SDoc+instMisMatch is_boot inst+  = hang (ppr inst)+       2 (text "is defined in the" <+>+        (if is_boot then text "hs-boot" else text "hsig")+       <+> text "file, but not in the module itself")++{-+************************************************************************+*                                                                      *+        Type-checking the top level of a module (continued)+*                                                                      *+************************************************************************+-}++rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)+-- Fails if there are any errors+rnTopSrcDecls group+ = do { -- Rename the source decls+        traceRn "rn12" empty ;+        (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ;+        traceRn "rn13" empty ;++        -- save the renamed syntax, if we want it+        let { tcg_env'+                | Just grp <- tcg_rn_decls tcg_env+                  = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }+                | otherwise+                   = tcg_env };++                -- Dump trace of renaming part+        rnDump rn_decls ;+        return (tcg_env', rn_decls)+   }++tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv)+tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,+                         hs_derivds = deriv_decls,+                         hs_fords  = foreign_decls,+                         hs_defds  = default_decls,+                         hs_annds  = annotation_decls,+                         hs_ruleds = rule_decls,+                         hs_vects  = vect_decls,+                         hs_valds  = hs_val_binds@(ValBindsOut val_binds val_sigs) })+ = do {         -- Type-check the type and class decls, and all imported decls+                -- The latter come in via tycl_decls+        traceTc "Tc2 (src)" empty ;++                -- Source-language instances, including derivings,+                -- and import the supporting declarations+        traceTc "Tc3" empty ;+        (tcg_env, inst_infos, ValBindsOut deriv_binds deriv_sigs)+            <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ;++        setGblEnv tcg_env       $ do {++                -- Generate Applicative/Monad proposal (AMP) warnings+        traceTc "Tc3b" empty ;++                -- Generate Semigroup/Monoid warnings+        traceTc "Tc3c" empty ;+        tcSemigroupWarnings ;++                -- Foreign import declarations next.+        traceTc "Tc4" empty ;+        (fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ;+        tcExtendGlobalValEnv fi_ids     $ do {++                -- Default declarations+        traceTc "Tc4a" empty ;+        default_tys <- tcDefaults default_decls ;+        updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {++                -- Value declarations next.+                -- It is important that we check the top-level value bindings+                -- before the GHC-generated derived bindings, since the latter+                -- may be defined in terms of the former. (For instance,+                -- the bindings produced in a Data instance.)+        traceTc "Tc5" empty ;+        tc_envs <- tcTopBinds val_binds val_sigs;+        setEnvs tc_envs $ do {++                -- Now GHC-generated derived bindings, generics, and selectors+                -- Do not generate warnings from compiler-generated code;+                -- hence the use of discardWarnings+        tc_envs@(tcg_env, tcl_env)+            <- discardWarnings (tcTopBinds deriv_binds deriv_sigs) ;+        setEnvs tc_envs $ do {  -- Environment doesn't change now++                -- Second pass over class and instance declarations,+                -- now using the kind-checked decls+        traceTc "Tc6" empty ;+        inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ;++                -- Foreign exports+        traceTc "Tc7" empty ;+        (foe_binds, foe_decls, foe_gres) <- tcForeignExports foreign_decls ;++                -- Annotations+        annotations <- tcAnnotations annotation_decls ;++                -- Rules+        rules <- tcRules rule_decls ;++                -- Vectorisation declarations+        vects <- tcVectDecls vect_decls ;++                -- Wrap up+        traceTc "Tc7a" empty ;+        let { all_binds = inst_binds     `unionBags`+                          foe_binds++            ; fo_gres = fi_gres `unionBags` foe_gres+            ; fo_fvs = foldrBag (\gre fvs -> fvs `addOneFV` gre_name gre)+                                emptyFVs fo_gres++            ; sig_names = mkNameSet (collectHsValBinders hs_val_binds)+                          `minusNameSet` getTypeSigNames val_sigs++                -- Extend the GblEnv with the (as yet un-zonked)+                -- bindings, rules, foreign decls+            ; tcg_env' = tcg_env { tcg_binds   = tcg_binds tcg_env `unionBags` all_binds+                                 , tcg_sigs    = tcg_sigs tcg_env `unionNameSet` sig_names+                                 , tcg_rules   = tcg_rules tcg_env+                                                      ++ flattenRuleDecls rules+                                 , tcg_vects   = tcg_vects tcg_env ++ vects+                                 , tcg_anns    = tcg_anns tcg_env ++ annotations+                                 , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations+                                 , tcg_fords   = tcg_fords tcg_env ++ foe_decls ++ fi_decls+                                 , tcg_dus     = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ;+                                 -- tcg_dus: see Note [Newtype constructor usage in foreign declarations]++        -- See Note [Newtype constructor usage in foreign declarations]+        addUsedGREs (bagToList fo_gres) ;++        return (tcg_env', tcl_env)+    }}}}}}++tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn"+++tcSemigroupWarnings :: TcM ()+tcSemigroupWarnings = do+    traceTc "tcSemigroupWarnings" empty+    let warnFlag = Opt_WarnSemigroup+    tcPreludeClashWarn warnFlag sappendName+    tcMissingParentClassWarn warnFlag monoidClassName semigroupClassName+++-- | Warn on local definitions of names that would clash with future Prelude+-- elements.+--+--   A name clashes if the following criteria are met:+--       1. It would is imported (unqualified) from Prelude+--       2. It is locally defined in the current module+--       3. It has the same literal name as the reference function+--       4. It is not identical to the reference function+tcPreludeClashWarn :: WarningFlag+                   -> Name+                   -> TcM ()+tcPreludeClashWarn warnFlag name = do+    { warn <- woptM warnFlag+    ; when warn $ do+    { traceTc "tcPreludeClashWarn/wouldBeImported" empty+    -- Is the name imported (unqualified) from Prelude? (Point 4 above)+    ; rnImports <- fmap (map unLoc . tcg_rn_imports) getGblEnv+    -- (Note that this automatically handles -XNoImplicitPrelude, as Prelude+    -- will not appear in rnImports automatically if it is set.)++    -- Continue only the name is imported from Prelude+    ; when (importedViaPrelude name rnImports) $ do+      -- Handle 2.-4.+    { rdrElts <- fmap (concat . occEnvElts . tcg_rdr_env) getGblEnv++    ; let clashes :: GlobalRdrElt -> Bool+          clashes x = isLocalDef && nameClashes && isNotInProperModule+            where+              isLocalDef = gre_lcl x == True+              -- Names are identical ...+              nameClashes = nameOccName (gre_name x) == nameOccName name+              -- ... but not the actual definitions, because we don't want to+              -- warn about a bad definition of e.g. <> in Data.Semigroup, which+              -- is the (only) proper place where this should be defined+              isNotInProperModule = gre_name x /= name++          -- List of all offending definitions+          clashingElts :: [GlobalRdrElt]+          clashingElts = filter clashes rdrElts++    ; traceTc "tcPreludeClashWarn/prelude_functions"+                (hang (ppr name) 4 (sep [ppr clashingElts]))++    ; let warn_msg x = addWarnAt (Reason warnFlag) (nameSrcSpan (gre_name x)) (hsep+              [ text "Local definition of"+              , (quotes . ppr . nameOccName . gre_name) x+              , text "clashes with a future Prelude name." ]+              $$+              text "This will become an error in a future release." )+    ; mapM_ warn_msg clashingElts+    }}}++  where++    -- Is the given name imported via Prelude?+    --+    -- Possible scenarios:+    --   a) Prelude is imported implicitly, issue warnings.+    --   b) Prelude is imported explicitly, but without mentioning the name in+    --      question. Issue no warnings.+    --   c) Prelude is imported hiding the name in question. Issue no warnings.+    --   d) Qualified import of Prelude, no warnings.+    importedViaPrelude :: Name+                       -> [ImportDecl Name]+                       -> Bool+    importedViaPrelude name = any importViaPrelude+      where+        isPrelude :: ImportDecl Name -> Bool+        isPrelude imp = unLoc (ideclName imp) == pRELUDE_NAME++        -- Implicit (Prelude) import?+        isImplicit :: ImportDecl Name -> Bool+        isImplicit = ideclImplicit++        -- Unqualified import?+        isUnqualified :: ImportDecl Name -> Bool+        isUnqualified = not . ideclQualified++        -- List of explicitly imported (or hidden) Names from a single import.+        --   Nothing -> No explicit imports+        --   Just (False, <names>) -> Explicit import list of <names>+        --   Just (True , <names>) -> Explicit hiding of <names>+        importListOf :: ImportDecl Name -> Maybe (Bool, [Name])+        importListOf = fmap toImportList . ideclHiding+          where+            toImportList (h, loc) = (h, map (ieName . unLoc) (unLoc loc))++        isExplicit :: ImportDecl Name -> Bool+        isExplicit x = case importListOf x of+            Nothing -> False+            Just (False, explicit)+                -> nameOccName name `elem`    map nameOccName explicit+            Just (True, hidden)+                -> nameOccName name `notElem` map nameOccName hidden++        -- Check whether the given name would be imported (unqualified) from+        -- an import declaration.+        importViaPrelude :: ImportDecl Name -> Bool+        importViaPrelude x = isPrelude x+                          && isUnqualified x+                          && (isImplicit x || isExplicit x)+++-- Notation: is* is for classes the type is an instance of, should* for those+--           that it should also be an instance of based on the corresponding+--           is*.+tcMissingParentClassWarn :: WarningFlag+                         -> Name -- ^ Instances of this ...+                         -> Name -- ^ should also be instances of this+                         -> TcM ()+tcMissingParentClassWarn warnFlag isName shouldName+  = do { warn <- woptM warnFlag+       ; when warn $ do+       { traceTc "tcMissingParentClassWarn" empty+       ; isClass'     <- tcLookupClass_maybe isName+       ; shouldClass' <- tcLookupClass_maybe shouldName+       ; case (isClass', shouldClass') of+              (Just isClass, Just shouldClass) -> do+                  { localInstances <- tcGetInsts+                  ; let isInstance m = is_cls m == isClass+                        isInsts = filter isInstance localInstances+                  ; traceTc "tcMissingParentClassWarn/isInsts" (ppr isInsts)+                  ; forM_ isInsts (checkShouldInst isClass shouldClass)+                  }+              (is',should') ->+                  traceTc "tcMissingParentClassWarn/notIsShould"+                          (hang (ppr isName <> text "/" <> ppr shouldName) 2 (+                            (hsep [ quotes (text "Is"), text "lookup for"+                                  , ppr isName+                                  , text "resulted in", ppr is' ])+                            $$+                            (hsep [ quotes (text "Should"), text "lookup for"+                                  , ppr shouldName+                                  , text "resulted in", ppr should' ])))+       }}+  where+    -- Check whether the desired superclass exists in a given environment.+    checkShouldInst :: Class   -- ^ Class of existing instance+                    -> Class   -- ^ Class there should be an instance of+                    -> ClsInst -- ^ Existing instance+                    -> TcM ()+    checkShouldInst isClass shouldClass isInst+      = do { instEnv <- tcGetInstEnvs+           ; let (instanceMatches, shouldInsts, _)+                    = lookupInstEnv False instEnv shouldClass (is_tys isInst)++           ; traceTc "tcMissingParentClassWarn/checkShouldInst"+                     (hang (ppr isInst) 4+                         (sep [ppr instanceMatches, ppr shouldInsts]))++           -- "<location>: Warning: <type> is an instance of <is> but not+           -- <should>" e.g. "Foo is an instance of Monad but not Applicative"+           ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst+                 warnMsg (Just name:_) =+                      addWarnAt (Reason warnFlag) instLoc $+                           hsep [ (quotes . ppr . nameOccName) name+                                , text "is an instance of"+                                , (ppr . nameOccName . className) isClass+                                , text "but not"+                                , (ppr . nameOccName . className) shouldClass ]+                                <> text "."+                           $$+                           hsep [ text "This will become an error in"+                                , text "a future release." ]+                 warnMsg _ = pure ()+           ; when (null shouldInsts && null instanceMatches) $+                  warnMsg (is_tcs isInst)+           }++    tcLookupClass_maybe :: Name -> TcM (Maybe Class)+    tcLookupClass_maybe name = tcLookupImported_maybe name >>= \case+        Succeeded (ATyCon tc) | cls@(Just _) <- tyConClass_maybe tc -> pure cls+        _else -> pure Nothing+++---------------------------+tcTyClsInstDecls :: [TyClGroup Name]+                 -> [LDerivDecl Name]+                 -> [(RecFlag, LHsBinds Name)]+                 -> TcM (TcGblEnv,            -- The full inst env+                         [InstInfo Name],     -- Source-code instance decls to process;+                                              -- contains all dfuns for this module+                          HsValBinds Name)    -- Supporting bindings for derived instances++tcTyClsInstDecls tycl_decls deriv_decls binds+ = tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $+   tcAddPatSynPlaceholders (getPatSynBinds binds) $+   do { (tcg_env, inst_info, datafam_deriv_info)+          <- tcTyAndClassDecls tycl_decls ;+      ; setGblEnv tcg_env $ do {+          -- With the @TyClDecl@s and @InstDecl@s checked we're ready to+          -- process the deriving clauses, including data family deriving+          -- clauses discovered in @tcTyAndClassDecls@.+          --+          -- Careful to quit now in case there were instance errors, so that+          -- the deriving errors don't pile up as well.+          ; failIfErrsM+          ; let tyclds = tycl_decls >>= group_tyclds+          ; (tcg_env', inst_info', val_binds)+              <- tcInstDeclsDeriv datafam_deriv_info tyclds deriv_decls+          ; setGblEnv tcg_env' $ do {+                failIfErrsM+              ; pure (tcg_env', inst_info' ++ inst_info, val_binds)+      }}}++{- *********************************************************************+*                                                                      *+        Checking for 'main'+*                                                                      *+************************************************************************+-}++checkMain :: Bool  -- False => no 'module M(..) where' header at all+          -> TcM TcGblEnv+-- If we are in module Main, check that 'main' is defined.+checkMain explicit_mod_hdr+ = do   { dflags  <- getDynFlags+        ; tcg_env <- getGblEnv+        ; check_main dflags tcg_env explicit_mod_hdr }++check_main :: DynFlags -> TcGblEnv -> Bool -> TcM TcGblEnv+check_main dflags tcg_env explicit_mod_hdr+ | mod /= main_mod+ = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >>+   return tcg_env++ | otherwise+ = do   { mb_main <- lookupGlobalOccRn_maybe main_fn+                -- Check that 'main' is in scope+                -- It might be imported from another module!+        ; case mb_main of {+             Nothing -> do { traceTc "checkMain fail" (ppr main_mod <+> ppr main_fn)+                           ; complain_no_main+                           ; return tcg_env } ;+             Just main_name -> do++        { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn)+        ; let loc       = srcLocSpan (getSrcLoc main_name)+        ; ioTyCon <- tcLookupTyCon ioTyConName+        ; res_ty <- newFlexiTyVarTy liftedTypeKind+        ; let io_ty = mkTyConApp ioTyCon [res_ty]+              skol_info = SigSkol (FunSigCtxt main_name False) io_ty []+        ; (ev_binds, main_expr)+               <- checkConstraints skol_info [] [] $+                  addErrCtxt mainCtxt    $+                  tcMonoExpr (L loc (HsVar (L loc main_name)))+                             (mkCheckExpType io_ty)++                -- See Note [Root-main Id]+                -- Construct the binding+                --      :Main.main :: IO res_ty = runMainIO res_ty main+        ; run_main_id <- tcLookupId runMainIOName+        ; let { root_main_name =  mkExternalName rootMainKey rOOT_MAIN+                                   (mkVarOccFS (fsLit "main"))+                                   (getSrcSpan main_name)+              ; root_main_id = Id.mkExportedVanillaId root_main_name+                                                      (mkTyConApp ioTyCon [res_ty])+              ; co  = mkWpTyApps [res_ty]+              ; rhs = mkHsDictLet ev_binds $+                      nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr+              ; main_bind = mkVarBind root_main_id rhs }++        ; return (tcg_env { tcg_main  = Just main_name,+                            tcg_binds = tcg_binds tcg_env+                                        `snocBag` main_bind,+                            tcg_dus   = tcg_dus tcg_env+                                        `plusDU` usesOnly (unitFV main_name)+                        -- Record the use of 'main', so that we don't+                        -- complain about it being defined but not used+                 })+    }}}+  where+    mod         = tcg_mod tcg_env+    main_mod    = mainModIs dflags+    main_fn     = getMainFun dflags+    interactive = ghcLink dflags == LinkInMemory++    complain_no_main = checkTc (interactive && not explicit_mod_hdr) noMainMsg+        -- In interactive mode, without an explicit module header, don't+        -- worry about the absence of 'main'.+        -- In other modes, fail altogether, so that we don't go on+        -- and complain a second time when processing the export list.++    mainCtxt  = text "When checking the type of the" <+> pp_main_fn+    noMainMsg = text "The" <+> pp_main_fn+                <+> text "is not defined in module" <+> quotes (ppr main_mod)+    pp_main_fn = ppMainFn main_fn++-- | Get the unqualified name of the function to use as the \"main\" for the main module.+-- Either returns the default name or the one configured on the command line with -main-is+getMainFun :: DynFlags -> RdrName+getMainFun dflags = case mainFunIs dflags of+                      Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn))+                      Nothing -> main_RDR_Unqual++-- If we are in module Main, check that 'main' is exported.+checkMainExported :: TcGblEnv -> TcM ()+checkMainExported tcg_env+  = case tcg_main tcg_env of+      Nothing -> return () -- not the main module+      Just main_name ->+         do { dflags <- getDynFlags+            ; let main_mod = mainModIs dflags+            ; checkTc (main_name `elem` concatMap availNames (tcg_exports tcg_env)) $+                text "The" <+> ppMainFn (nameRdrName main_name) <+>+                text "is not exported by module" <+> quotes (ppr main_mod) }++ppMainFn :: RdrName -> SDoc+ppMainFn main_fn+  | rdrNameOcc main_fn == mainOcc+  = text "IO action" <+> quotes (ppr main_fn)+  | otherwise+  = text "main IO action" <+> quotes (ppr main_fn)++mainOcc :: OccName+mainOcc = mkVarOccFS (fsLit "main")++{-+Note [Root-main Id]+~~~~~~~~~~~~~~~~~~~+The function that the RTS invokes is always :Main.main, which we call+root_main_id.  (Because GHC allows the user to have a module not+called Main as the main module, we can't rely on the main function+being called "Main.main".  That's why root_main_id has a fixed module+":Main".)++This is unusual: it's a LocalId whose Name has a Module from another+module.  Tiresomely, we must filter it out again in MkIface, les we+get two defns for 'main' in the interface file!+++*********************************************************+*                                                       *+                GHCi stuff+*                                                       *+*********************************************************+-}++runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, Maybe a)+-- Initialise the tcg_inst_env with instances from all home modules.+-- This mimics the more selective call to hptInstances in tcRnImports+runTcInteractive hsc_env thing_inside+  = initTcInteractive hsc_env $ withTcPlugins hsc_env $+    do { traceTc "setInteractiveContext" $+            vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt))+                 , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts)+                 , text "ic_rn_gbl_env (LocalDef)" <+>+                      vcat (map ppr [ local_gres | gres <- occEnvElts (ic_rn_gbl_env icxt)+                                                 , let local_gres = filter isLocalGRE gres+                                                 , not (null local_gres) ]) ]+       ; let getOrphans m = fmap (\iface -> mi_module iface+                                          : dep_orphs (mi_deps iface))+                                 (loadSrcInterface (text "runTcInteractive") m+                                                   False Nothing)+       ; orphs <- fmap concat . forM (ic_imports icxt) $ \i ->+            case i of+                IIModule n -> getOrphans n+                IIDecl i -> getOrphans (unLoc (ideclName i))+       ; let imports = emptyImportAvails {+                            imp_orphs = orphs+                        }+       ; (gbl_env, lcl_env) <- getEnvs+       ; let gbl_env' = gbl_env {+                           tcg_rdr_env      = ic_rn_gbl_env icxt+                         , tcg_type_env     = type_env+                         , tcg_inst_env     = extendInstEnvList+                                               (extendInstEnvList (tcg_inst_env gbl_env) ic_insts)+                                               home_insts+                         , tcg_fam_inst_env = extendFamInstEnvList+                                               (extendFamInstEnvList (tcg_fam_inst_env gbl_env)+                                                                     ic_finsts)+                                               home_fam_insts+                         , tcg_field_env    = mkNameEnv con_fields+                              -- setting tcg_field_env is necessary+                              -- to make RecordWildCards work (test: ghci049)+                         , tcg_fix_env      = ic_fix_env icxt+                         , tcg_default      = ic_default icxt+                              -- must calculate imp_orphs of the ImportAvails+                              -- so that instance visibility is done correctly+                         , tcg_imports      = imports+                         }++       ; lcl_env' <- tcExtendLocalTypeEnv lcl_env lcl_ids+       ; setEnvs (gbl_env', lcl_env') thing_inside }+  where+    (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True)++    icxt                     = hsc_IC hsc_env+    (ic_insts, ic_finsts)    = ic_instances icxt+    (lcl_ids, top_ty_things) = partitionWith is_closed (ic_tythings icxt)++    is_closed :: TyThing -> Either (Name, TcTyThing) TyThing+    -- Put Ids with free type variables (always RuntimeUnks)+    -- in the *local* type environment+    -- See Note [Initialising the type environment for GHCi]+    is_closed thing+      | AnId id <- thing+      , not (isTypeClosedLetBndr id)+      = Left (idName id, ATcId { tct_id = id+                               , tct_info = NotLetBound })+      | otherwise+      = Right thing++    type_env1 = mkTypeEnvWithImplicits top_ty_things+    type_env  = extendTypeEnvWithIds type_env1 (map instanceDFunId ic_insts)+                -- Putting the dfuns in the type_env+                -- is just to keep Core Lint happy++    con_fields = [ (dataConName c, dataConFieldLabels c)+                 | ATyCon t <- top_ty_things+                 , c <- tyConDataCons t ]+++{- Note [Initialising the type environment for GHCi]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Most of the the Ids in ic_things, defined by the user in 'let' stmts,+have closed types. E.g.+   ghci> let foo x y = x && not y++However the GHCi debugger creates top-level bindings for Ids whose+types have free RuntimeUnk skolem variables, standing for unknown+types.  If we don't register these free TyVars as global TyVars then+the typechecker will try to quantify over them and fall over in+zonkQuantifiedTyVar. so we must add any free TyVars to the+typechecker's global TyVar set.  That is most conveniently by using+tcExtendLocalTypeEnv, which automatically extends the global TyVar+set.++We do this by splitting out the Ids with open types, using 'is_closed'+to do the partition.  The top-level things go in the global TypeEnv;+the open, NotTopLevel, Ids, with free RuntimeUnk tyvars, go in the+local TypeEnv.++Note that we don't extend the local RdrEnv (tcl_rdr); all the in-scope+things are already in the interactive context's GlobalRdrEnv.+Extending the local RdrEnv isn't terrible, but it means there is an+entry for the same Name in both global and local RdrEnvs, and that+lead to duplicate "perhaps you meant..." suggestions (e.g. T5564).++We don't bother with the tcl_th_bndrs environment either.+-}++-- | The returned [Id] is the list of new Ids bound by this statement. It can+-- be used to extend the InteractiveContext via extendInteractiveContext.+--+-- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound+-- values, coerced to ().+tcRnStmt :: HscEnv -> GhciLStmt RdrName+         -> IO (Messages, Maybe ([Id], LHsExpr Id, FixityEnv))+tcRnStmt hsc_env rdr_stmt+  = runTcInteractive hsc_env $ do {++    -- The real work is done here+    ((bound_ids, tc_expr), fix_env) <- tcUserStmt rdr_stmt ;+    zonked_expr <- zonkTopLExpr tc_expr ;+    zonked_ids  <- zonkTopBndrs bound_ids ;++    failIfErrsM ;  -- we can't do the next step if there are levity polymorphism errors+                   -- test case: ghci/scripts/T13202{,a}++        -- None of the Ids should be of unboxed type, because we+        -- cast them all to HValues in the end!+    mapM_ bad_unboxed (filter (isUnliftedType . idType) zonked_ids) ;++    traceTc "tcs 1" empty ;+    this_mod <- getModule ;+    global_ids <- mapM (externaliseAndTidyId this_mod) zonked_ids ;+        -- Note [Interactively-bound Ids in GHCi] in HscTypes++{- ---------------------------------------------+   At one stage I removed any shadowed bindings from the type_env;+   they are inaccessible but might, I suppose, cause a space leak if we leave them there.+   However, with Template Haskell they aren't necessarily inaccessible.  Consider this+   GHCi session+         Prelude> let f n = n * 2 :: Int+         Prelude> fName <- runQ [| f |]+         Prelude> $(return $ AppE fName (LitE (IntegerL 7)))+         14+         Prelude> let f n = n * 3 :: Int+         Prelude> $(return $ AppE fName (LitE (IntegerL 7)))+   In the last line we use 'fName', which resolves to the *first* 'f'+   in scope. If we delete it from the type env, GHCi crashes because+   it doesn't expect that.++   Hence this code is commented out++-------------------------------------------------- -}++    traceOptTcRn Opt_D_dump_tc+        (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,+               text "Typechecked expr" <+> ppr zonked_expr]) ;++    return (global_ids, zonked_expr, fix_env)+    }+  where+    bad_unboxed id = addErr (sep [text "GHCi can't bind a variable of unlifted type:",+                                  nest 2 (ppr id <+> dcolon <+> ppr (idType id))])++{-+--------------------------------------------------------------------------+                Typechecking Stmts in GHCi++Here is the grand plan, implemented in tcUserStmt++        What you type                   The IO [HValue] that hscStmt returns+        -------------                   ------------------------------------+        let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]+                                        bindings: [x,y,...]++        pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]+                                        bindings: [x,y,...]++        expr (of IO type)       ==>     expr >>= \ it -> return [coerce HVal it]+          [NB: result not printed]      bindings: [it]++        expr (of non-IO type,   ==>     let it = expr in print it >> return [coerce HVal it]+          result showable)              bindings: [it]++        expr (of non-IO type,+          result not showable)  ==>     error+-}++-- | A plan is an attempt to lift some code into the IO monad.+type PlanResult = ([Id], LHsExpr Id)+type Plan = TcM PlanResult++-- | Try the plans in order. If one fails (by raising an exn), try the next.+-- If one succeeds, take it.+runPlans :: [Plan] -> TcM PlanResult+runPlans []     = panic "runPlans"+runPlans [p]    = p+runPlans (p:ps) = tryTcDiscardingErrs (runPlans ps) p++-- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the+-- GHCi 'environment'.+--+-- By 'lift' and 'environment we mean that the code is changed to+-- execute properly in an IO monad. See Note [Interactively-bound Ids+-- in GHCi] in HscTypes for more details. We do this lifting by trying+-- different ways ('plans') of lifting the code into the IO monad and+-- type checking each plan until one succeeds.+tcUserStmt :: GhciLStmt RdrName -> TcM (PlanResult, FixityEnv)++-- An expression typed at the prompt is treated very specially+tcUserStmt (L loc (BodyStmt expr _ _ _))+  = do  { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr)+               -- Don't try to typecheck if the renamer fails!+        ; ghciStep <- getGhciStepIO+        ; uniq <- newUnique+        ; interPrintName <- getInteractivePrintName+        ; let fresh_it  = itName uniq loc+              matches   = [mkMatch (mkPrefixFunRhs (L loc fresh_it)) [] rn_expr+                                   (noLoc emptyLocalBinds)]+              -- [it = expr]+              the_bind  = L loc $ (mkTopFunBind FromSource (L loc fresh_it) matches) { bind_fvs = fvs }+                          -- Care here!  In GHCi the expression might have+                          -- free variables, and they in turn may have free type variables+                          -- (if we are at a breakpoint, say).  We must put those free vars++              -- [let it = expr]+              let_stmt  = L loc $ LetStmt $ noLoc $ HsValBinds $+                          ValBindsOut [(NonRecursive,unitBag the_bind)] []++              -- [it <- e]+              bind_stmt = L loc $ BindStmt (L loc (VarPat (L loc fresh_it)))+                                           (nlHsApp ghciStep rn_expr)+                                           (mkRnSyntaxExpr bindIOName)+                                           noSyntaxExpr+                                           PlaceHolder++              -- [; print it]+              print_it  = L loc $ BodyStmt (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it))+                                           (mkRnSyntaxExpr thenIOName)+                                                  noSyntaxExpr placeHolderType++        -- The plans are:+        --   A. [it <- e; print it]     but not if it::()+        --   B. [it <- e]+        --   C. [let it = e; print it]+        --+        -- Ensure that type errors don't get deferred when type checking the+        -- naked expression. Deferring type errors here is unhelpful because the+        -- expression gets evaluated right away anyway. It also would potentially+        -- emit two redundant type-error warnings, one from each plan.+        ; plan <- unsetGOptM Opt_DeferTypeErrors $+                  unsetGOptM Opt_DeferTypedHoles $ runPlans [+                    -- Plan A+                    do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]+                       ; it_ty <- zonkTcType (idType it_id)+                       ; when (isUnitTy $ it_ty) failM+                       ; return stuff },++                        -- Plan B; a naked bind statment+                    tcGhciStmts [bind_stmt],++                        -- Plan C; check that the let-binding is typeable all by itself.+                        -- If not, fail; if so, try to print it.+                        -- The two-step process avoids getting two errors: one from+                        -- the expression itself, and one from the 'print it' part+                        -- This two-step story is very clunky, alas+                    do { _ <- checkNoErrs (tcGhciStmts [let_stmt])+                                --- checkNoErrs defeats the error recovery of let-bindings+                       ; tcGhciStmts [let_stmt, print_it] } ]++        ; fix_env <- getFixityEnv+        ; return (plan, fix_env) }++tcUserStmt rdr_stmt@(L loc _)+  = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $+           rnStmts GhciStmtCtxt rnLExpr [rdr_stmt] $ \_ -> do+             fix_env <- getFixityEnv+             return (fix_env, emptyFVs)+            -- Don't try to typecheck if the renamer fails!+       ; traceRn "tcRnStmt" (vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs])+       ; rnDump rn_stmt ;++       ; ghciStep <- getGhciStepIO+       ; let gi_stmt+               | (L loc (BindStmt pat expr op1 op2 ty)) <- rn_stmt+                           = L loc $ BindStmt pat (nlHsApp ghciStep expr) op1 op2 ty+               | otherwise = rn_stmt++       ; opt_pr_flag <- goptM Opt_PrintBindResult+       ; let print_result_plan+               | opt_pr_flag                         -- The flag says "print result"+               , [v] <- collectLStmtBinders gi_stmt  -- One binder+                           =  [mk_print_result_plan gi_stmt v]+               | otherwise = []++        -- The plans are:+        --      [stmt; print v]         if one binder and not v::()+        --      [stmt]                  otherwise+       ; plan <- runPlans (print_result_plan ++ [tcGhciStmts [gi_stmt]])+       ; return (plan, fix_env) }+  where+    mk_print_result_plan stmt v+      = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]+           ; v_ty <- zonkTcType (idType v_id)+           ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM+           ; return stuff }+      where+        print_v  = L loc $ BodyStmt (nlHsApp (nlHsVar printName) (nlHsVar v))+                                    (mkRnSyntaxExpr thenIOName) noSyntaxExpr+                                    placeHolderType++-- | Typecheck the statements given and then return the results of the+-- statement in the form 'IO [()]'.+tcGhciStmts :: [GhciLStmt Name] -> TcM PlanResult+tcGhciStmts stmts+ = do { ioTyCon <- tcLookupTyCon ioTyConName ;+        ret_id  <- tcLookupId returnIOName ;            -- return @ IO+        let {+            ret_ty      = mkListTy unitTy ;+            io_ret_ty   = mkTyConApp ioTyCon [ret_ty] ;+            tc_io_stmts = tcStmtsAndThen GhciStmtCtxt tcDoStmt stmts+                                         (mkCheckExpType io_ret_ty) ;+            names = collectLStmtsBinders stmts ;+         } ;++        -- OK, we're ready to typecheck the stmts+        traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;+        ((tc_stmts, ids), lie) <- captureTopConstraints $+                                  tc_io_stmts $ \ _ ->+                                  mapM tcLookupId names  ;+                        -- Look up the names right in the middle,+                        -- where they will all be in scope++        -- Simplify the context+        traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;+        const_binds <- checkNoErrs (simplifyInteractive lie) ;+                -- checkNoErrs ensures that the plan fails if context redn fails++        traceTc "TcRnDriver.tcGhciStmts: done" empty ;+        let {   -- mk_return builds the expression+                --      returnIO @ [()] [coerce () x, ..,  coerce () z]+                --+                -- Despite the inconvenience of building the type applications etc,+                -- this *has* to be done in type-annotated post-typecheck form+                -- because we are going to return a list of *polymorphic* values+                -- coerced to type (). If we built a *source* stmt+                --      return [coerce x, ..., coerce z]+                -- then the type checker would instantiate x..z, and we wouldn't+                -- get their *polymorphic* values.  (And we'd get ambiguity errs+                -- if they were overloaded, since they aren't applied to anything.)+            ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty])+                       (noLoc $ ExplicitList unitTy Nothing (map mk_item ids)) ;+            mk_item id = let ty_args = [idType id, unitTy] in+                         nlHsApp (nlHsTyApp unsafeCoerceId+                                   (map (getRuntimeRep "tcGhciStmts") ty_args ++ ty_args))+                                 (nlHsVar id) ;+            stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)]+        } ;+        return (ids, mkHsDictLet (EvBinds const_binds) $+                     noLoc (HsDo GhciStmtCtxt (noLoc stmts) io_ret_ty))+    }++-- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a)+getGhciStepIO :: TcM (LHsExpr Name)+getGhciStepIO = do+    ghciTy <- getGHCiMonad+    a_tv <- newName (mkTyVarOccFS (fsLit "a"))+    let ghciM   = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv)+        ioM     = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv)++        step_ty = noLoc $ HsForAllTy { hst_bndrs = [noLoc $ UserTyVar (noLoc a_tv)]+                                     , hst_body  = nlHsFunTy ghciM ioM }++        stepTy :: LHsSigWcType Name+        stepTy = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs step_ty)++    return (noLoc $ ExprWithTySig (nlHsVar ghciStepIoMName) stepTy)++isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name)+isGHCiMonad hsc_env ty+  = runTcInteractive hsc_env $ do+        rdrEnv <- getGlobalRdrEnv+        let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty)+        case occIO of+            Just [n] -> do+                let name = gre_name n+                ghciClass <- tcLookupClass ghciIoClassName+                userTyCon <- tcLookupTyCon name+                let userTy = mkTyConApp userTyCon []+                _ <- tcLookupInstance ghciClass [userTy]+                return name++            Just _  -> failWithTc $ text "Ambiguous type!"+            Nothing -> failWithTc $ text ("Can't find type:" ++ ty)++-- | How should we infer a type? See Note [TcRnExprMode]+data TcRnExprMode = TM_Inst    -- ^ Instantiate the type fully (:type)+                  | TM_NoInst  -- ^ Do not instantiate the type (:type +v)+                  | TM_Default -- ^ Default the type eagerly (:type +d)++-- | tcRnExpr just finds the type of an expression+tcRnExpr :: HscEnv+         -> TcRnExprMode+         -> LHsExpr RdrName+         -> IO (Messages, Maybe Type)+tcRnExpr hsc_env mode rdr_expr+  = runTcInteractive hsc_env $+    do {++    (rn_expr, _fvs) <- rnLExpr rdr_expr ;+    failIfErrsM ;++        -- Now typecheck the expression, and generalise its type+        -- it might have a rank-2 type (e.g. :t runST)+    uniq <- newUnique ;+    let { fresh_it  = itName uniq (getLoc rdr_expr)+        ; orig = lexprCtOrigin rn_expr } ;+    (tclvl, lie, res_ty)+          <- pushLevelAndCaptureConstraints $+             do { (_tc_expr, expr_ty) <- tcInferSigma rn_expr+                ; if inst+                  then snd <$> deeplyInstantiate orig expr_ty+                  else return expr_ty } ;++    -- Generalise+    ((qtvs, dicts, _), lie_top) <- captureTopConstraints $+                                   {-# SCC "simplifyInfer" #-}+                                   simplifyInfer tclvl+                                                 infer_mode+                                                 []    {- No sig vars -}+                                                 [(fresh_it, res_ty)]+                                                 lie ;++    -- Ignore the dictionary bindings+    _ <- perhaps_disable_default_warnings $+         simplifyInteractive lie_top ;++    let { all_expr_ty = mkInvForAllTys qtvs (mkLamTypes dicts res_ty) } ;+    ty <- zonkTcType all_expr_ty ;++    -- We normalise type families, so that the type of an expression is the+    -- same as of a bound expression (TcBinds.mkInferredPolyId). See Trac+    -- #10321 for further discussion.+    fam_envs <- tcGetFamInstEnvs ;+    -- normaliseType returns a coercion which we discard, so the Role is+    -- irrelevant+    return (snd (normaliseType fam_envs Nominal ty))+    }+  where+    -- See Note [TcRnExprMode]+    (inst, infer_mode, perhaps_disable_default_warnings) = case mode of+      TM_Inst    -> (True,  NoRestrictions, id)+      TM_NoInst  -> (False, NoRestrictions, id)+      TM_Default -> (True,  EagerDefaulting, unsetWOptM Opt_WarnTypeDefaults)++--------------------------+tcRnImportDecls :: HscEnv+                -> [LImportDecl RdrName]+                -> IO (Messages, Maybe GlobalRdrEnv)+-- Find the new chunk of GlobalRdrEnv created by this list of import+-- decls.  In contract tcRnImports *extends* the TcGblEnv.+tcRnImportDecls hsc_env import_decls+ =  runTcInteractive hsc_env $+    do { gbl_env <- updGblEnv zap_rdr_env $+                    tcRnImports hsc_env import_decls+       ; return (tcg_rdr_env gbl_env) }+  where+    zap_rdr_env gbl_env = gbl_env { tcg_rdr_env = emptyGlobalRdrEnv }++-- tcRnType just finds the kind of a type+tcRnType :: HscEnv+         -> Bool        -- Normalise the returned type+         -> LHsType RdrName+         -> IO (Messages, Maybe (Type, Kind))+tcRnType hsc_env normalise rdr_type+  = runTcInteractive hsc_env $+    setXOptM LangExt.PolyKinds $   -- See Note [Kind-generalise in tcRnType]+    do { (HsWC { hswc_wcs = wcs, hswc_body = rn_type }, _fvs)+               <- rnHsWcType GHCiCtx (mkHsWildCardBndrs rdr_type)+                  -- The type can have wild cards, but no implicit+                  -- generalisation; e.g.   :kind (T _)+       ; failIfErrsM++        -- Now kind-check the type+        -- It can have any rank or kind+        -- First bring into scope any wildcards+       ; traceTc "tcRnType" (vcat [ppr wcs, ppr rn_type])+       ; (ty, kind) <- solveEqualities $+                       tcWildCardBinders wcs  $ \ _ ->+                       tcLHsType rn_type++       -- Do kind generalisation; see Note [Kind-generalise in tcRnType]+       ; kvs <- kindGeneralize kind+       ; ty  <- zonkTcTypeToType emptyZonkEnv ty++       ; ty' <- if normalise+                then do { fam_envs <- tcGetFamInstEnvs+                        ; let (_, ty')+                                = normaliseType fam_envs Nominal ty+                        ; return ty' }+                else return ty ;++       ; return (ty', mkInvForAllTys kvs (typeKind ty')) }++{- Note [TcRnExprMode]+~~~~~~~~~~~~~~~~~~~~~~+How should we infer a type when a user asks for the type of an expression e+at the GHCi prompt? We offer 3 different possibilities, described below. Each+considers this example, with -fprint-explicit-foralls enabled:++  foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String+  :type{,-spec,-def} foo @Int++:type / TM_Inst++  In this mode, we report the type that would be inferred if a variable+  were assigned to expression e, without applying the monomorphism restriction.+  This means we deeply instantiate the type and then regeneralize, as discussed+  in #11376.++  > :type foo @Int+  forall {b} {f :: * -> *}. (Foldable f, Num b) => Int -> f b -> String++  Note that the variables and constraints are reordered here, because this+  is possible during regeneralization. Also note that the variables are+  reported as Inferred instead of Specified.++:type +v / TM_NoInst++  This mode is for the benefit of users using TypeApplications. It does no+  instantiation whatsoever, sometimes meaning that class constraints are not+  solved.++  > :type +v foo @Int+  forall f b. (Show Int, Num b, Foldable f) => Int -> f b -> String++  Note that Show Int is still reported, because the solver never got a chance+  to see it.++:type +d / TM_Default++  This mode is for the benefit of users who wish to see instantiations of+  generalized types, and in particular to instantiate Foldable and Traversable.+  In this mode, any type variable that can be defaulted is defaulted. Because+  GHCi uses -XExtendedDefaultRules, this means that Foldable and Traversable are+  defaulted.++  > :type +d foo @Int+  Int -> [Integer] -> String++  Note that this mode can sometimes lead to a type error, if a type variable is+  used with a defaultable class but cannot actually be defaulted:++  bar :: (Num a, Monoid a) => a -> a+  > :type +d bar+  ** error **++  The error arises because GHC tries to default a but cannot find a concrete+  type in the defaulting list that is both Num and Monoid. (If this list is+  modified to include an element that is both Num and Monoid, the defaulting+  would succeed, of course.)++Note [Kind-generalise in tcRnType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We switch on PolyKinds when kind-checking a user type, so that we will+kind-generalise the type, even when PolyKinds is not otherwise on.+This gives the right default behaviour at the GHCi prompt, where if+you say ":k T", and T has a polymorphic kind, you'd like to see that+polymorphism. Of course.  If T isn't kind-polymorphic you won't get+anything unexpected, but the apparent *loss* of polymorphism, for+types that you know are polymorphic, is quite surprising.  See Trac+#7688 for a discussion.++Note that the goal is to generalise the *kind of the type*, not+the type itself! Example:+  ghci> data T m a = MkT (m a)  -- T :: forall . (k -> *) -> k -> *+  ghci> :k T+We instantiate T to get (T kappa).  We do not want to kind-generalise+that to forall k. T k!  Rather we want to take its kind+   T kappa :: (kappa -> *) -> kappa -> *+and now kind-generalise that kind, to forall k. (k->*) -> k -> *+(It was Trac #10122 that made me realise how wrong the previous+approach was.) -}+++{-+************************************************************************+*                                                                      *+                 tcRnDeclsi+*                                                                      *+************************************************************************++tcRnDeclsi exists to allow class, data, and other declarations in GHCi.+-}++tcRnDeclsi :: HscEnv+           -> [LHsDecl RdrName]+           -> IO (Messages, Maybe TcGblEnv)+tcRnDeclsi hsc_env local_decls+  = runTcInteractive hsc_env $+    tcRnSrcDecls False local_decls++externaliseAndTidyId :: Module -> Id -> TcM Id+externaliseAndTidyId this_mod id+  = do { name' <- externaliseName this_mod (idName id)+       ; return (globaliseAndTidyId (setIdName id name')) }+++{-+************************************************************************+*                                                                      *+        More GHCi stuff, to do with browsing and getting info+*                                                                      *+************************************************************************+-}++-- | ASSUMES that the module is either in the 'HomePackageTable' or is+-- a package module with an interface on disk.  If neither of these is+-- true, then the result will be an error indicating the interface+-- could not be found.+getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe ModIface)+getModuleInterface hsc_env mod+  = runTcInteractive hsc_env $+    loadModuleInterface (text "getModuleInterface") mod++tcRnLookupRdrName :: HscEnv -> Located RdrName+                  -> IO (Messages, Maybe [Name])+-- ^ Find all the Names that this RdrName could mean, in GHCi+tcRnLookupRdrName hsc_env (L loc rdr_name)+  = runTcInteractive hsc_env $+    setSrcSpan loc           $+    do {   -- If the identifier is a constructor (begins with an+           -- upper-case letter), then we need to consider both+           -- constructor and type class identifiers.+         let rdr_names = dataTcOccs rdr_name+       ; names_s <- mapM lookupInfoOccRn rdr_names+       ; let names = concat names_s+       ; when (null names) (addErrTc (text "Not in scope:" <+> quotes (ppr rdr_name)))+       ; return names }++tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing)+tcRnLookupName hsc_env name+  = runTcInteractive hsc_env $+    tcRnLookupName' name++-- To look up a name we have to look in the local environment (tcl_lcl)+-- as well as the global environment, which is what tcLookup does.+-- But we also want a TyThing, so we have to convert:++tcRnLookupName' :: Name -> TcRn TyThing+tcRnLookupName' name = do+   tcthing <- tcLookup name+   case tcthing of+     AGlobal thing    -> return thing+     ATcId{tct_id=id} -> return (AnId id)+     _ -> panic "tcRnLookupName'"++tcRnGetInfo :: HscEnv+            -> Name+            -> IO (Messages, Maybe (TyThing, Fixity, [ClsInst], [FamInst]))++-- Used to implement :info in GHCi+--+-- Look up a RdrName and return all the TyThings it might be+-- A capitalised RdrName is given to us in the DataName namespace,+-- but we want to treat it as *both* a data constructor+--  *and* as a type or class constructor;+-- hence the call to dataTcOccs, and we return up to two results+tcRnGetInfo hsc_env name+  = runTcInteractive hsc_env $+    do { loadUnqualIfaces hsc_env (hsc_IC hsc_env)+           -- Load the interface for all unqualified types and classes+           -- That way we will find all the instance declarations+           -- (Packages have not orphan modules, and we assume that+           --  in the home package all relevant modules are loaded.)++       ; thing  <- tcRnLookupName' name+       ; fixity <- lookupFixityRn name+       ; (cls_insts, fam_insts) <- lookupInsts thing+       ; return (thing, fixity, cls_insts, fam_insts) }+++-- Lookup all class and family instances for a type constructor.+--+-- This function filters all instances in the type environment, so there+-- is a lot of duplicated work if it is called many times in the same+-- type environment. If this becomes a problem, the NameEnv computed+-- in GHC.getNameToInstancesIndex could be cached in TcM and both functions+-- could be changed to consult that index.+lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst])+lookupInsts (ATyCon tc)+  = do  { InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods } <- tcGetInstEnvs+        ; (pkg_fie, home_fie) <- tcGetFamInstEnvs+                -- Load all instances for all classes that are+                -- in the type environment (which are all the ones+                -- we've seen in any interface file so far)++          -- Return only the instances relevant to the given thing, i.e.+          -- the instances whose head contains the thing's name.+        ; let cls_insts =+                 [ ispec        -- Search all+                 | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie+                 , instIsVisible vis_mods ispec+                 , tc_name `elemNameSet` orphNamesOfClsInst ispec ]+        ; let fam_insts =+                 [ fispec+                 | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie+                 , tc_name `elemNameSet` orphNamesOfFamInst fispec ]+        ; return (cls_insts, fam_insts) }+  where+    tc_name     = tyConName tc++lookupInsts _ = return ([],[])++loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM ()+-- Load the interface for everything that is in scope unqualified+-- This is so that we can accurately report the instances for+-- something+loadUnqualIfaces hsc_env ictxt+  = initIfaceTcRn $ do+    mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods))+  where+    this_pkg = thisPackage (hsc_dflags hsc_env)++    unqual_mods = [ nameModule name+                  | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt)+                  , let name = gre_name gre+                  , nameIsFromExternalPackage this_pkg name+                  , isTcOcc (nameOccName name)   -- Types and classes only+                  , unQualOK gre ]               -- In scope unqualified+    doc = text "Need interface for module whose export(s) are in scope unqualified"++++{-+************************************************************************+*                                                                      *+                Degugging output+*                                                                      *+************************************************************************+-}++rnDump :: (Outputable a, Data a) => a -> TcRn ()+-- Dump, with a banner, if -ddump-rn+rnDump rn = do { traceOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" (ppr rn))+               ; traceOptTcRn Opt_D_dump_rn_ast+                 (mkDumpDoc "Renamer" (text (showAstData NoBlankSrcSpan rn))) }++tcDump :: TcGblEnv -> TcRn ()+tcDump env+ = do { dflags <- getDynFlags ;++        -- Dump short output if -ddump-types or -ddump-tc+        when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)+             (printForUserTcRn short_dump) ;++        -- Dump bindings if -ddump-tc+        traceOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump);++        -- Dump bindings as an hsSyn AST if -ddump-tc-ast+        traceOptTcRn Opt_D_dump_tc_ast (mkDumpDoc "Typechecker" ast_dump)+   }+  where+    short_dump = pprTcGblEnv env+    full_dump  = pprLHsBinds (tcg_binds env)+        -- NB: foreign x-d's have undefined's in their types;+        --     hence can't show the tc_fords+    ast_dump = text (showAstData NoBlankSrcSpan (tcg_binds env))++-- It's unpleasant having both pprModGuts and pprModDetails here+pprTcGblEnv :: TcGblEnv -> SDoc+pprTcGblEnv (TcGblEnv { tcg_type_env  = type_env,+                        tcg_insts     = insts,+                        tcg_fam_insts = fam_insts,+                        tcg_rules     = rules,+                        tcg_vects     = vects,+                        tcg_imports   = imports })+  = vcat [ ppr_types type_env+         , ppr_tycons fam_insts type_env+         , ppr_insts insts+         , ppr_fam_insts fam_insts+         , vcat (map ppr rules)+         , vcat (map ppr vects)+         , text "Dependent modules:" <+>+                pprUFM (imp_dep_mods imports) (ppr . sort)+         , text "Dependent packages:" <+>+                ppr (S.toList $ imp_dep_pkgs imports)]+  where         -- The use of sort is just to reduce unnecessary+                -- wobbling in testsuite output++ppr_types :: TypeEnv -> SDoc+ppr_types type_env = sdocWithPprDebug $ \dbg ->+  let+    ids = [id | id <- typeEnvIds type_env, want_sig id]+    want_sig id | dbg+                = True+                | otherwise+                = isExternalName (idName id) &&+                  (not (isDerivedOccName (getOccName id)))+        -- Top-level user-defined things have External names.+        -- Suppress internally-generated things unless -dppr-debug+  in+  text "TYPE SIGNATURES" $$ nest 2 (ppr_sigs ids)++ppr_tycons :: [FamInst] -> TypeEnv -> SDoc+ppr_tycons fam_insts type_env = sdocWithPprDebug $ \dbg ->+  let+    fi_tycons = famInstsRepTyCons fam_insts+    tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon]+    want_tycon tycon | dbg        = True+                     | otherwise  = not (isImplicitTyCon tycon) &&+                                    isExternalName (tyConName tycon) &&+                                    not (tycon `elem` fi_tycons)+  in+  vcat [ text "TYPE CONSTRUCTORS"+       ,   nest 2 (ppr_tydecls tycons)+       , text "COERCION AXIOMS"+       ,   nest 2 (vcat (map pprCoAxiom (typeEnvCoAxioms type_env))) ]++ppr_insts :: [ClsInst] -> SDoc+ppr_insts []     = empty+ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs)++ppr_fam_insts :: [FamInst] -> SDoc+ppr_fam_insts []        = empty+ppr_fam_insts fam_insts =+  text "FAMILY INSTANCES" $$ nest 2 (pprFamInsts fam_insts)++ppr_sigs :: [Var] -> SDoc+ppr_sigs ids+        -- Print type signatures; sort by OccName+  = vcat (map ppr_sig (sortBy (comparing getOccName) ids))+  where+    ppr_sig id = hang (ppr id <+> dcolon) 2 (ppr (tidyTopType (idType id)))++ppr_tydecls :: [TyCon] -> SDoc+ppr_tydecls tycons+  -- Print type constructor info for debug purposes+  -- Sort by OccName to reduce unnecessary changes+  = vcat [ ppr (tyThingToIfaceDecl (ATyCon tc))+         | tc <- sortBy (comparing getOccName) tycons ]+    -- The Outputable instance for IfaceDecl uses+    -- showToIface, which is what we want here, whereas+    -- pprTyThing uses ShowSome.++{-+********************************************************************************++Type Checker Plugins++********************************************************************************+-}++withTcPlugins :: HscEnv -> TcM a -> TcM a+withTcPlugins hsc_env m =+  do plugins <- liftIO (loadTcPlugins hsc_env)+     case plugins of+       [] -> m  -- Common fast case+       _  -> do ev_binds_var <- newTcEvBinds+                (solvers,stops) <- unzip `fmap` mapM (startPlugin ev_binds_var) plugins+                -- This ensures that tcPluginStop is called even if a type+                -- error occurs during compilation (Fix of #10078)+                eitherRes <- tryM $ do+                  updGblEnv (\e -> e { tcg_tc_plugins = solvers }) m+                mapM_ (flip runTcPluginM ev_binds_var) stops+                case eitherRes of+                  Left _ -> failM+                  Right res -> return res+  where+  startPlugin ev_binds_var (TcPlugin start solve stop) =+    do s <- runTcPluginM start ev_binds_var+       return (solve s, stop s)++loadTcPlugins :: HscEnv -> IO [TcPlugin]+#ifndef GHCI+loadTcPlugins _ = return []+#else+loadTcPlugins hsc_env =+ do named_plugins <- loadPlugins hsc_env+    return $ catMaybes $ map load_plugin named_plugins+  where+    load_plugin (_, plug, opts) = tcPlugin plug opts+#endif
+ typecheck/TcRnDriver.hs-boot view
@@ -0,0 +1,12 @@+module TcRnDriver where++import DynFlags (DynFlags)+import Type (TyThing)+import TcRnTypes (TcM)+import Outputable (SDoc)+import Name (Name)++checkBootDeclM :: Bool  -- ^ True <=> an hs-boot file (could also be a sig)+               -> TyThing -> TyThing -> TcM ()+missingBootThing :: Bool -> Name -> String -> SDoc+badReexportedBootThing :: DynFlags -> Bool -> Name -> Name -> SDoc
+ typecheck/TcRnExports.hs view
@@ -0,0 +1,878 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}+module TcRnExports (tcRnExports, exports_from_avail) where++import HsSyn+import PrelNames+import RdrName+import TcRnMonad+import TcEnv+import TcMType+import TcType+import RnNames+import RnEnv+import ErrUtils+import Id+import IdInfo+import Module+import Name+import NameEnv+import NameSet+import Avail+import TyCon+import SrcLoc+import HscTypes+import Outputable+import ConLike+import DataCon+import PatSyn+import FastString+import Maybes+import qualified GHC.LanguageExtensions as LangExt+import Util (capitalise)+++import Control.Monad+import DynFlags+import RnHsDoc          ( rnHsDoc )+import RdrHsSyn        ( setRdrNameSpace )+import Data.Either      ( partitionEithers )++{-+************************************************************************+*                                                                      *+\subsection{Export list processing}+*                                                                      *+************************************************************************++Processing the export list.++You might think that we should record things that appear in the export+list as ``occurrences'' (using @addOccurrenceName@), but you'd be+wrong.  We do check (here) that they are in scope, but there is no+need to slurp in their actual declaration (which is what+@addOccurrenceName@ forces).++Indeed, doing so would big trouble when compiling @PrelBase@, because+it re-exports @GHC@, which includes @takeMVar#@, whose type includes+@ConcBase.StateAndSynchVar#@, and so on...++Note [Exports of data families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose you see (Trac #5306)+        module M where+          import X( F )+          data instance F Int = FInt+What does M export?  AvailTC F [FInt]+                  or AvailTC F [F,FInt]?+The former is strictly right because F isn't defined in this module.+But then you can never do an explicit import of M, thus+    import M( F( FInt ) )+because F isn't exported by M.  Nor can you import FInt alone from here+    import M( FInt )+because we don't have syntax to support that.  (It looks like an import of+the type FInt.)++At one point I implemented a compromise:+  * When constructing exports with no export list, or with module M(+    module M ), we add the parent to the exports as well.+  * But not when you see module M( f ), even if f is a+    class method with a parent.+  * Nor when you see module M( module N ), with N /= M.++But the compromise seemed too much of a hack, so we backed it out.+You just have to use an explicit export list:+    module M( F(..) ) where ...+-}++data ExportAccum        -- The type of the accumulating parameter of+                        -- the main worker function in rnExports+     = ExportAccum+        [LIE Name]             --  Export items with Names+        ExportOccMap           --  Tracks exported occurrence names+        [AvailInfo]            --  The accumulated exported stuff+                                --   Not nub'd!++emptyExportAccum :: ExportAccum+emptyExportAccum = ExportAccum [] emptyOccEnv []++type ExportOccMap = OccEnv (Name, IE RdrName)+        -- Tracks what a particular exported OccName+        --   in an export list refers to, and which item+        --   it came from.  It's illegal to export two distinct things+        --   that have the same occurrence name++tcRnExports :: Bool       -- False => no 'module M(..) where' header at all+          -> Maybe (Located [LIE RdrName]) -- Nothing => no explicit export list+          -> TcGblEnv+          -> RnM TcGblEnv++        -- Complains if two distinct exports have same OccName+        -- Warns about identical exports.+        -- Complains about exports items not in scope++tcRnExports explicit_mod exports+          tcg_env@TcGblEnv { tcg_mod     = this_mod,+                              tcg_rdr_env = rdr_env,+                              tcg_imports = imports,+                              tcg_src     = hsc_src }+ = unsetWOptM Opt_WarnWarningsDeprecations $+       -- Do not report deprecations arising from the export+       -- list, to avoid bleating about re-exporting a deprecated+       -- thing (especially via 'module Foo' export item)+   do   {+        -- If the module header is omitted altogether, then behave+        -- as if the user had written "module Main(main) where..."+        -- EXCEPT in interactive mode, when we behave as if he had+        -- written "module Main where ..."+        -- Reason: don't want to complain about 'main' not in scope+        --         in interactive mode+        ; dflags <- getDynFlags+        ; let real_exports+                 | explicit_mod = exports+                 | ghcLink dflags == LinkInMemory = Nothing+                 | otherwise+                          = Just (noLoc [noLoc+                              (IEVar (noLoc (IEName $ noLoc main_RDR_Unqual)))])+                        -- ToDo: the 'noLoc' here is unhelpful if 'main'+                        --       turns out to be out of scope++        ; let do_it = exports_from_avail real_exports rdr_env imports this_mod+        ; (rn_exports, final_avails)+            <- if hsc_src == HsigFile+                then do (msgs, mb_r) <- tryTc do_it+                        case mb_r of+                            Just r  -> return r+                            Nothing -> addMessages msgs >> failM+                else checkNoErrs $ do_it+        ; let final_ns     = availsToNameSetWithSelectors final_avails++        ; traceRn "rnExports: Exports:" (ppr final_avails)++        ; let new_tcg_env =+                  tcg_env { tcg_exports    = final_avails,+                             tcg_rn_exports = case tcg_rn_exports tcg_env of+                                                Nothing -> Nothing+                                                Just _  -> rn_exports,+                            tcg_dus = tcg_dus tcg_env `plusDU`+                                      usesOnly final_ns }+        ; failIfErrsM+        ; return new_tcg_env }++exports_from_avail :: Maybe (Located [LIE RdrName])+                         -- Nothing => no explicit export list+                   -> GlobalRdrEnv+                   -> ImportAvails+                   -> Module+                   -> RnM (Maybe [LIE Name], [AvailInfo])++exports_from_avail Nothing rdr_env _imports _this_mod+   -- The same as (module M) where M is the current module name,+   -- so that's how we handle it, except we also export the data family+   -- when a data instance is exported.+  = let avails =+          map fix_faminst . gresToAvailInfo+            . filter isLocalGRE . globalRdrEnvElts $ rdr_env+    in return (Nothing, avails)+  where+    -- #11164: when we define a data instance+    -- but not data family, re-export the family+    -- Even though we don't check whether this is actually a data family+    -- only data families can locally define subordinate things (`ns` here)+    -- without locally defining (and instead importing) the parent (`n`)+    fix_faminst (AvailTC n ns flds) =+      let new_ns =+            case ns of+              [] -> [n]+              (p:_) -> if p == n then ns else n:ns+      in AvailTC n new_ns flds++    fix_faminst avail = avail+++exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod+  = do ExportAccum ie_names _ exports+        <-  foldAndRecoverM do_litem emptyExportAccum rdr_items+       let final_exports = nubAvails exports -- Combine families+       return (Just ie_names, final_exports)+  where+    do_litem :: ExportAccum -> LIE RdrName -> RnM ExportAccum+    do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie)++    -- Maps a parent to its in-scope children+    kids_env :: NameEnv [GlobalRdrElt]+    kids_env = mkChildEnv (globalRdrEnvElts rdr_env)+++    imported_modules = [ imv_name imv+                       | xs <- moduleEnvElts $ imp_mods imports+                       , imv <- importedByUser xs ]++    exports_from_item :: ExportAccum -> LIE RdrName -> RnM ExportAccum+    exports_from_item acc@(ExportAccum ie_names occs exports)+                      (L loc (IEModuleContents (L lm mod)))+        | let earlier_mods = [ mod+                             | (L _ (IEModuleContents (L _ mod))) <- ie_names ]+        , mod `elem` earlier_mods    -- Duplicate export of M+        = do { warnIf (Reason Opt_WarnDuplicateExports) True+                      (dupModuleExport mod) ;+               return acc }++        | otherwise+        = do { let { exportValid = (mod `elem` imported_modules)+                                || (moduleName this_mod == mod)+                   ; gre_prs     = pickGREsModExp mod (globalRdrEnvElts rdr_env)+                   ; new_exports = map (availFromGRE . fst) gre_prs+                   ; names       = map (gre_name     . fst) gre_prs+                   ; all_gres    = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs+               }++             ; checkErr exportValid (moduleNotImported mod)+             ; warnIf (Reason Opt_WarnDodgyExports)+                      (exportValid && null gre_prs)+                      (nullModuleExport mod)++             ; traceRn "efa" (ppr mod $$ ppr all_gres)+             ; addUsedGREs all_gres++             ; occs' <- check_occs (IEModuleContents (noLoc mod)) occs names+                      -- This check_occs not only finds conflicts+                      -- between this item and others, but also+                      -- internally within this item.  That is, if+                      -- 'M.x' is in scope in several ways, we'll have+                      -- several members of mod_avails with the same+                      -- OccName.+             ; traceRn "export_mod"+                       (vcat [ ppr mod+                             , ppr new_exports ])+             ; return (ExportAccum (L loc (IEModuleContents (L lm mod)) : ie_names)+                                   occs'+                                   (new_exports ++ exports)) }++    exports_from_item acc@(ExportAccum lie_names occs exports) (L loc ie)+        | isDoc ie+        = do new_ie <- lookup_doc_ie ie+             return (ExportAccum (L loc new_ie : lie_names) occs exports)++        | otherwise+        = do (new_ie, avail) <-+              setSrcSpan loc $ lookup_ie ie+             if isUnboundName (ieName new_ie)+                  then return acc    -- Avoid error cascade+                  else do++                    occs' <- check_occs ie occs (availNames avail)++                    return (ExportAccum (L loc new_ie : lie_names) occs' (avail : exports))++    -------------+    lookup_ie :: IE RdrName -> RnM (IE Name, AvailInfo)+    lookup_ie (IEVar (L l rdr))+        = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr+             return (IEVar (L l (replaceWrappedName rdr name)), avail)++    lookup_ie (IEThingAbs (L l rdr))+        = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr+             return (IEThingAbs (L l (replaceWrappedName rdr name)), avail)++    lookup_ie ie@(IEThingAll n')+        = do+            (n, avail, flds) <- lookup_ie_all ie n'+            let name = unLoc n+            return (IEThingAll (replaceLWrappedName n' (unLoc n))+                   , AvailTC name (name:avail) flds)+++    lookup_ie ie@(IEThingWith l wc sub_rdrs _)+        = do+            (lname, subs, avails, flds)+              <- addExportErrCtxt ie $ lookup_ie_with l sub_rdrs+            (_, all_avail, all_flds) <-+              case wc of+                NoIEWildcard -> return (lname, [], [])+                IEWildcard _ -> lookup_ie_all ie l+            let name = unLoc lname+                subs' = map (replaceLWrappedName l . unLoc) subs+            return (IEThingWith (replaceLWrappedName l name) wc subs'+                                (map noLoc (flds ++ all_flds)),+                    AvailTC name (name : avails ++ all_avail)+                                 (flds ++ all_flds))+++++    lookup_ie _ = panic "lookup_ie"    -- Other cases covered earlier++    lookup_ie_with :: LIEWrappedName RdrName -> [LIEWrappedName RdrName]+                   -> RnM (Located Name, [Located Name], [Name], [FieldLabel])+    lookup_ie_with (L l rdr) sub_rdrs+        = do name <- lookupGlobalOccRn $ ieWrappedName rdr+             (non_flds, flds) <- lookupChildrenExport name+                                                  (map ieLWrappedName sub_rdrs)+             if isUnboundName name+                then return (L l name, [], [name], [])+                else return (L l name, non_flds+                            , map unLoc non_flds+                            , map unLoc flds)+    lookup_ie_all :: IE RdrName -> LIEWrappedName RdrName+                  -> RnM (Located Name, [Name], [FieldLabel])+    lookup_ie_all ie (L l rdr) =+          do name <- lookupGlobalOccRn $ ieWrappedName rdr+             let gres = findChildren kids_env name+                 (non_flds, flds) = classifyGREs gres+             addUsedKids (ieWrappedName rdr) gres+             warnDodgyExports <- woptM Opt_WarnDodgyExports+             when (null gres) $+                  if isTyConName name+                  then when warnDodgyExports $+                           addWarn (Reason Opt_WarnDodgyExports)+                                   (dodgyExportWarn name)+                  else -- This occurs when you export T(..), but+                       -- only import T abstractly, or T is a synonym.+                       addErr (exportItemErr ie)+             return (L l name, non_flds, flds)++    -------------+    lookup_doc_ie :: IE RdrName -> RnM (IE Name)+    lookup_doc_ie (IEGroup lev doc) = do rn_doc <- rnHsDoc doc+                                         return (IEGroup lev rn_doc)+    lookup_doc_ie (IEDoc doc)       = do rn_doc <- rnHsDoc doc+                                         return (IEDoc rn_doc)+    lookup_doc_ie (IEDocNamed str)  = return (IEDocNamed str)+    lookup_doc_ie _ = panic "lookup_doc_ie"    -- Other cases covered earlier++    -- In an export item M.T(A,B,C), we want to treat the uses of+    -- A,B,C as if they were M.A, M.B, M.C+    -- Happily pickGREs does just the right thing+    addUsedKids :: RdrName -> [GlobalRdrElt] -> RnM ()+    addUsedKids parent_rdr kid_gres = addUsedGREs (pickGREs parent_rdr kid_gres)++classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel])+classifyGREs = partitionEithers . map classifyGRE++classifyGRE :: GlobalRdrElt -> Either Name FieldLabel+classifyGRE gre = case gre_par gre of+  FldParent _ Nothing -> Right (FieldLabel (occNameFS (nameOccName n)) False n)+  FldParent _ (Just lbl) -> Right (FieldLabel lbl True n)+  _                      -> Left  n+  where+    n = gre_name gre++isDoc :: IE RdrName -> Bool+isDoc (IEDoc _)      = True+isDoc (IEDocNamed _) = True+isDoc (IEGroup _ _)  = True+isDoc _ = False++-- Renaming and typechecking of exports happens after everything else has+-- been typechecked.++++-- Renaming exports lists is a minefield. Five different things can appear in+-- children export lists ( T(A, B, C) ).+-- 1. Record selectors+-- 2. Type constructors+-- 3. Data constructors+-- 4. Pattern Synonyms+-- 5. Pattern Synonym Selectors+--+-- However, things get put into weird name spaces.+-- 1. Some type constructors are parsed as variables (-.->) for example.+-- 2. All data constructors are parsed as type constructors+-- 3. When there is ambiguity, we default type constructors to data+-- constructors and require the explicit `type` keyword for type+-- constructors.+--+-- This function first establishes the possible namespaces that an+-- identifier might be in (`choosePossibleNameSpaces`).+--+-- Then for each namespace in turn, tries to find the correct identifier+-- there returning the first positive result or the first terminating+-- error.+--+++-- Records the result of looking up a child.+data ChildLookupResult+      = NameNotFound                --  We couldn't find a suitable name+      | NameErr ErrMsg              --  We found an unambiguous name+                                    --  but there's another error+                                    --  we should abort from+      | FoundName Name              --  We resolved to a normal name+      | FoundFL FieldLabel       --  We resolved to a FL++instance Outputable ChildLookupResult where+  ppr NameNotFound = text "NameNotFound"+  ppr (FoundName n) = text "Found:" <+> ppr n+  ppr (FoundFL fls) = text "FoundFL:" <+> ppr fls+  ppr (NameErr _) = text "Error"++-- Left biased accumulation monoid. Chooses the left-most positive occurrence.+instance Monoid ChildLookupResult where+  mempty = NameNotFound+  NameNotFound `mappend` m2 = m2+  NameErr m `mappend` _ = NameErr m -- Abort from the first error+  FoundName n1 `mappend` _ = FoundName n1+  FoundFL fls `mappend` _ = FoundFL fls++lookupChildrenExport :: Name -> [Located RdrName]+                     -> RnM ([Located Name], [Located FieldLabel])+lookupChildrenExport parent rdr_items =+  do+    xs <- mapAndReportM doOne rdr_items+    return $ partitionEithers xs+    where+        -- Pick out the possible namespaces in order of priority+        -- This is a consequence of how the parser parses all+        -- data constructors as type constructors.+        choosePossibleNamespaces :: NameSpace -> [NameSpace]+        choosePossibleNamespaces ns+          | ns == varName = [varName, tcName]+          | ns == tcName  = [dataName, tcName]+          | otherwise = [ns]+        -- Process an individual child+        doOne :: Located RdrName+              -> RnM (Either (Located Name) (Located FieldLabel))+        doOne n = do++          let bareName = unLoc n+              lkup v = lookupExportChild parent (setRdrNameSpace bareName v)++          name <-  tryChildLookupResult $ map lkup $+                    (choosePossibleNamespaces (rdrNameSpace bareName))++          -- Default to data constructors for slightly better error+          -- messages+          let unboundName :: RdrName+              unboundName = if rdrNameSpace bareName == varName+                                then bareName+                                else setRdrNameSpace bareName dataName++          case name of+            NameNotFound -> Left . L (getLoc n) <$> reportUnboundName unboundName+            FoundFL fls -> return $ Right (L (getLoc n) fls)+            FoundName name -> return $ Left (L (getLoc n) name)+            NameErr err_msg -> reportError err_msg >> failM++tryChildLookupResult :: [RnM ChildLookupResult] -> RnM ChildLookupResult+tryChildLookupResult [x] = x+tryChildLookupResult (x:xs) = do+  res <- x+  case res of+    FoundFL {} -> return res+    FoundName {} -> return res+    NameErr {}   -> return res+    _ -> tryChildLookupResult xs+tryChildLookupResult _ = panic "tryChildLookupResult:empty list"++++-- | Also captures the current context+mkNameErr :: SDoc -> TcM ChildLookupResult+mkNameErr errMsg = do+  tcinit <- tcInitTidyEnv+  NameErr <$> mkErrTcM (tcinit, errMsg)+++-- | Used in export lists to lookup the children.+lookupExportChild :: Name -> RdrName -> RnM ChildLookupResult+lookupExportChild parent rdr_name+  | isUnboundName parent+    -- Avoid an error cascade+  = return (FoundName (mkUnboundNameRdr rdr_name))++  | otherwise = do+  gre_env <- getGlobalRdrEnv++  let original_gres = lookupGlobalRdrEnv gre_env (rdrNameOcc rdr_name)+  -- Disambiguate the lookup based on the parent information.+  -- The remaining GREs are things that we *could* export here, note that+  -- this includes things which have `NoParent`. Those are sorted in+  -- `checkPatSynParent`.+  traceRn "lookupExportChild original_gres:" (ppr original_gres)+  case picked_gres original_gres of+    NoOccurrence ->+      noMatchingParentErr original_gres+    UniqueOccurrence g ->+      checkPatSynParent parent (gre_name g)+    DisambiguatedOccurrence g ->+      checkFld g+    AmbiguousOccurrence gres ->+      mkNameClashErr gres+    where+        -- Convert into FieldLabel if necessary+        checkFld :: GlobalRdrElt -> RnM ChildLookupResult+        checkFld g@GRE{gre_name, gre_par} = do+          addUsedGRE True g+          return $ case gre_par of+            FldParent _ mfs ->  do+              FoundFL  (fldParentToFieldLabel gre_name mfs)+            _ -> FoundName gre_name++        fldParentToFieldLabel :: Name -> Maybe FastString -> FieldLabel+        fldParentToFieldLabel name mfs =+          case mfs of+            Nothing ->+              let fs = occNameFS (nameOccName name)+              in FieldLabel fs False name+            Just fs -> FieldLabel fs True name++        -- Called when we fine no matching GREs after disambiguation but+        -- there are three situations where this happens.+        -- 1. There were none to begin with.+        -- 2. None of the matching ones were the parent but+        --  a. They were from an overloaded record field so we can report+        --     a better error+        --  b. The original lookup was actually ambiguous.+        --     For example, the case where overloading is off and two+        --     record fields are in scope from different record+        --     constructors, neither of which is the parent.+        noMatchingParentErr :: [GlobalRdrElt] -> RnM ChildLookupResult+        noMatchingParentErr original_gres = do+          overload_ok <- xoptM LangExt.DuplicateRecordFields+          case original_gres of+            [] ->  return NameNotFound+            [g] -> mkDcErrMsg parent (gre_name g) [p | Just p <- [getParent g]]+            gss@(g:_:_) ->+              if all isRecFldGRE gss && overload_ok+                then mkNameErr (dcErrMsg parent "record selector"+                                  (expectJust "noMatchingParentErr" (greLabel g))+                                  [ppr p | x <- gss, Just p <- [getParent x]])+                else mkNameClashErr gss++        mkNameClashErr :: [GlobalRdrElt] -> RnM ChildLookupResult+        mkNameClashErr gres = do+          addNameClashErrRn rdr_name gres+          return (FoundName (gre_name (head gres)))++        getParent :: GlobalRdrElt -> Maybe Name+        getParent (GRE { gre_par = p } ) =+          case p of+            ParentIs cur_parent -> Just cur_parent+            FldParent { par_is = cur_parent } -> Just cur_parent+            NoParent -> Nothing++        picked_gres :: [GlobalRdrElt] -> DisambigInfo+        picked_gres gres+          | isUnqual rdr_name = mconcat (map right_parent gres)+          | otherwise         = mconcat (map right_parent (pickGREs rdr_name gres))+++        right_parent :: GlobalRdrElt -> DisambigInfo+        right_parent p+          | Just cur_parent <- getParent p+            = if parent == cur_parent+                then DisambiguatedOccurrence p+                else NoOccurrence+          | otherwise+            = UniqueOccurrence p++-- This domain specific datatype is used to record why we decided it was+-- possible that a GRE could be exported with a parent.+data DisambigInfo+       = NoOccurrence+          -- The GRE could never be exported. It has the wrong parent.+       | UniqueOccurrence GlobalRdrElt+          -- The GRE has no parent. It could be a pattern synonym.+       | DisambiguatedOccurrence GlobalRdrElt+          -- The parent of the GRE is the correct parent+       | AmbiguousOccurrence [GlobalRdrElt]+          -- For example, two normal identifiers with the same name are in+          -- scope. They will both be resolved to "UniqueOccurrence" and the+          -- monoid will combine them to this failing case.++instance Monoid DisambigInfo where+  mempty = NoOccurrence+  -- This is the key line: We prefer disambiguated occurrences to other+  -- names. Notice that two disambiguated occurences are not ambiguous as+  -- there is an internal invariant that a list of `DisambigInfo` arises+  -- from a list of GREs which all have the same OccName. Thus, if we ever+  -- have two DisambiguatedOccurences then they must have arisen from the+  -- same GRE and hence it's safe to discard one.+  _ `mappend` DisambiguatedOccurrence g' = DisambiguatedOccurrence g'+  DisambiguatedOccurrence g' `mappend` _ = DisambiguatedOccurrence g'+++  NoOccurrence `mappend` m = m+  m `mappend` NoOccurrence = m+  UniqueOccurrence g `mappend` UniqueOccurrence g' = AmbiguousOccurrence [g, g']+  UniqueOccurrence g `mappend` AmbiguousOccurrence gs = AmbiguousOccurrence (g:gs)+  AmbiguousOccurrence gs `mappend` UniqueOccurrence g' = AmbiguousOccurrence (g':gs)+  AmbiguousOccurrence gs `mappend` AmbiguousOccurrence gs' = AmbiguousOccurrence (gs ++ gs')+++++--+-- Note: [Typing Pattern Synonym Exports]+-- It proved quite a challenge to precisely specify which pattern synonyms+-- should be allowed to be bundled with which type constructors.+-- In the end it was decided to be quite liberal in what we allow. Below is+-- how Simon described the implementation.+--+-- "Personally I think we should Keep It Simple.  All this talk of+--  satisfiability makes me shiver.  I suggest this: allow T( P ) in all+--   situations except where `P`'s type is ''visibly incompatible'' with+--   `T`.+--+--    What does "visibly incompatible" mean?  `P` is visibly incompatible+--    with+--     `T` if+--       * `P`'s type is of form `... -> S t1 t2`+--       * `S` is a data/newtype constructor distinct from `T`+--+--  Nothing harmful happens if we allow `P` to be exported with+--  a type it can't possibly be useful for, but specifying a tighter+--  relationship is very awkward as you have discovered."+--+-- Note that this allows *any* pattern synonym to be bundled with any+-- datatype type constructor. For example, the following pattern `P` can be+-- bundled with any type.+--+-- ```+-- pattern P :: (A ~ f) => f+-- ```+--+-- So we provide basic type checking in order to help the user out, most+-- pattern synonyms are defined with definite type constructors, but don't+-- actually prevent a library author completely confusing their users if+-- they want to.+--+-- So, we check for exactly four things+-- 1. The name arises from a pattern synonym definition. (Either a pattern+--    synonym constructor or a pattern synonym selector)+-- 2. The pattern synonym is only bundled with a datatype or newtype.+-- 3. Check that the head of the result type constructor is an actual type+--    constructor and not a type variable. (See above example)+-- 4. Is so, check that this type constructor is the same as the parent+--    type constructor.+--+--+-- Note: [Types of TyCon]+--+-- This check appears to be overlly complicated, Richard asked why it+-- is not simply just `isAlgTyCon`. The answer for this is that+-- a classTyCon is also an `AlgTyCon` which we explicitly want to disallow.+-- (It is either a newtype or data depending on the number of methods)+--++-- | Given a resolved name in the children export list and a parent. Decide+-- whether we are allowed to export the child with the parent.+-- Invariant: gre_par == NoParent+-- See note [Typing Pattern Synonym Exports]+checkPatSynParent    :: Name   -- ^ Type constructor+                     -> Name   -- ^ Either a+                               --   a) Pattern Synonym Constructor+                               --   b) A pattern synonym selector+               -> TcM ChildLookupResult+checkPatSynParent parent mpat_syn = do+  parent_ty_con <- tcLookupTyCon parent+  mpat_syn_thing <- tcLookupGlobal mpat_syn+  let expected_res_ty =+          mkTyConApp parent_ty_con (mkTyVarTys (tyConTyVars parent_ty_con))++      handlePatSyn errCtxt =+        addErrCtxt errCtxt+        . tc_one_ps_export_with expected_res_ty parent_ty_con+  -- 1. Check that the Id was actually from a thing associated with patsyns+  case mpat_syn_thing of+      AnId i+        | isId i               ->+        case idDetails i of+          RecSelId { sel_tycon = RecSelPatSyn p } -> handlePatSyn (selErr i) p+          _ -> mkDcErrMsg parent mpat_syn []+      AConLike (PatSynCon p)    ->  handlePatSyn (psErr p) p+      _ -> mkDcErrMsg parent mpat_syn []+  where++    psErr = exportErrCtxt "pattern synonym"+    selErr = exportErrCtxt "pattern synonym record selector"++    assocClassErr :: SDoc+    assocClassErr =+      text "Pattern synonyms can be bundled only with datatypes."++    tc_one_ps_export_with :: TcTauType -- ^ TyCon type+                       -> TyCon       -- ^ Parent TyCon+                       -> PatSyn   -- ^ Corresponding bundled PatSyn+                                           -- and pretty printed origin+                       -> TcM ChildLookupResult+    tc_one_ps_export_with expected_res_ty ty_con pat_syn++      -- 2. See note [Types of TyCon]+      | not $ isTyConWithSrcDataCons ty_con = mkNameErr assocClassErr+      -- 3. Is the head a type variable?+      | Nothing <- mtycon = return (FoundName mpat_syn)+      -- 4. Ok. Check they are actually the same type constructor.+      | Just p_ty_con <- mtycon, p_ty_con /= ty_con = mkNameErr typeMismatchError+      -- 5. We passed!+      | otherwise = return (FoundName mpat_syn)++      where+        (_, _, _, _, _, res_ty) = patSynSig pat_syn+        mtycon = fst <$> tcSplitTyConApp_maybe res_ty+        typeMismatchError :: SDoc+        typeMismatchError =+          text "Pattern synonyms can only be bundled with matching type constructors"+              $$ text "Couldn't match expected type of"+              <+> quotes (ppr expected_res_ty)+              <+> text "with actual type of"+              <+> quotes (ppr res_ty)+++++{-===========================================================================-}+++check_occs :: IE RdrName -> ExportOccMap -> [Name] -> RnM ExportOccMap+check_occs ie occs names  -- 'names' are the entities specifed by 'ie'+  = foldlM check occs names+  where+    check occs name+      = case lookupOccEnv occs name_occ of+          Nothing -> return (extendOccEnv occs name_occ (name, ie))++          Just (name', ie')+            | name == name'   -- Duplicate export+            -- But we don't want to warn if the same thing is exported+            -- by two different module exports. See ticket #4478.+            -> do { warnIf (Reason Opt_WarnDuplicateExports)+                           (not (dupExport_ok name ie ie'))+                           (dupExportWarn name_occ ie ie')+                  ; return occs }++            | otherwise    -- Same occ name but different names: an error+            ->  do { global_env <- getGlobalRdrEnv ;+                     addErr (exportClashErr global_env name' name ie' ie) ;+                     return occs }+      where+        name_occ = nameOccName name+++dupExport_ok :: Name -> IE RdrName -> IE RdrName -> Bool+-- The Name is exported by both IEs. Is that ok?+-- "No"  iff the name is mentioned explicitly in both IEs+--        or one of the IEs mentions the name *alone*+-- "Yes" otherwise+--+-- Examples of "no":  module M( f, f )+--                    module M( fmap, Functor(..) )+--                    module M( module Data.List, head )+--+-- Example of "yes"+--    module M( module A, module B ) where+--        import A( f )+--        import B( f )+--+-- Example of "yes" (Trac #2436)+--    module M( C(..), T(..) ) where+--         class C a where { data T a }+--         instance C Int where { data T Int = TInt }+--+-- Example of "yes" (Trac #2436)+--    module Foo ( T ) where+--      data family T a+--    module Bar ( T(..), module Foo ) where+--        import Foo+--        data instance T Int = TInt++dupExport_ok n ie1 ie2+  = not (  single ie1 || single ie2+        || (explicit_in ie1 && explicit_in ie2) )+  where+    explicit_in (IEModuleContents _) = False                   -- module M+    explicit_in (IEThingAll r)+      = nameOccName n == rdrNameOcc (ieWrappedName $ unLoc r)  -- T(..)+    explicit_in _              = True++    single IEVar {}      = True+    single IEThingAbs {} = True+    single _               = False+++dupModuleExport :: ModuleName -> SDoc+dupModuleExport mod+  = hsep [text "Duplicate",+          quotes (text "Module" <+> ppr mod),+          text "in export list"]++moduleNotImported :: ModuleName -> SDoc+moduleNotImported mod+  = text "The export item `module" <+> ppr mod <>+    text "' is not imported"++nullModuleExport :: ModuleName -> SDoc+nullModuleExport mod+  = text "The export item `module" <+> ppr mod <> ptext (sLit "' exports nothing")+++dodgyExportWarn :: Name -> SDoc+dodgyExportWarn item = dodgyMsg (text "export") item++exportErrCtxt :: Outputable o => String -> o -> SDoc+exportErrCtxt herald exp =+  text "In the" <+> text (herald ++ ":") <+> ppr exp+++addExportErrCtxt :: (HasOccName s, OutputableBndr s) => IE s -> TcM a -> TcM a+addExportErrCtxt ie = addErrCtxt exportCtxt+  where+    exportCtxt = text "In the export:" <+> ppr ie++exportItemErr :: IE RdrName -> SDoc+exportItemErr export_item+  = sep [ text "The export item" <+> quotes (ppr export_item),+          text "attempts to export constructors or class methods that are not visible here" ]+++dupExportWarn :: OccName -> IE RdrName -> IE RdrName -> SDoc+dupExportWarn occ_name ie1 ie2+  = hsep [quotes (ppr occ_name),+          text "is exported by", quotes (ppr ie1),+          text "and",            quotes (ppr ie2)]++dcErrMsg :: Outputable a => Name -> String -> a -> [SDoc] -> SDoc+dcErrMsg ty_con what_is thing parents =+          text "The type constructor" <+> quotes (ppr ty_con)+                <+> text "is not the parent of the" <+> text what_is+                <+> quotes (ppr thing) <> char '.'+                $$ text (capitalise what_is)+                <> text "s can only be exported with their parent type constructor."+                $$ (case parents of+                      [] -> empty+                      [_] -> text "Parent:"+                      _  -> text "Parents:") <+> fsep (punctuate comma parents)++mkDcErrMsg :: Name -> Name -> [Name] -> TcM ChildLookupResult+mkDcErrMsg parent thing parents = do+  ty_thing <- tcLookupGlobal thing+  mkNameErr (dcErrMsg parent (tyThingCategory' ty_thing) thing (map ppr parents))+  where+    tyThingCategory' :: TyThing -> String+    tyThingCategory' (AnId i)+      | isRecordSelector i = "record selector"+    tyThingCategory' i = tyThingCategory i+++exportClashErr :: GlobalRdrEnv -> Name -> Name -> IE RdrName -> IE RdrName+               -> MsgDoc+exportClashErr global_env name1 name2 ie1 ie2+  = vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon+         , ppr_export ie1' name1'+         , ppr_export ie2' name2' ]+  where+    occ = nameOccName name1+    ppr_export ie name = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+>+                                       quotes (ppr name))+                                    2 (pprNameProvenance (get_gre name)))++    -- get_gre finds a GRE for the Name, so that we can show its provenance+    get_gre name+        = fromMaybe (pprPanic "exportClashErr" (ppr name)) (lookupGRE_Name global_env name)+    get_loc name = greSrcSpan (get_gre name)+    (name1', ie1', name2', ie2') = if get_loc name1 < get_loc name2+                                   then (name1, ie1, name2, ie2)+                                   else (name2, ie2, name1, ie1)
+ typecheck/TcRnMonad.hs view
@@ -0,0 +1,1855 @@+{-+(c) The University of Glasgow 2006+++Functions for working with the typechecker environment (setters, getters...).+-}++{-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module TcRnMonad(+  -- * Initalisation+  initTc, initTcWithGbl, initTcInteractive, initTcForLookup, initTcRnIf,++  -- * Simple accessors+  discardResult,+  getTopEnv, updTopEnv, getGblEnv, updGblEnv,+  setGblEnv, getLclEnv, updLclEnv, setLclEnv,+  getEnvs, setEnvs,+  xoptM, doptM, goptM, woptM,+  setXOptM, unsetXOptM, unsetGOptM, unsetWOptM,+  whenDOptM, whenGOptM, whenWOptM, whenXOptM,+  getGhcMode,+  withDoDynamicToo,+  getEpsVar,+  getEps,+  updateEps, updateEps_,+  getHpt, getEpsAndHpt,++  -- * Arrow scopes+  newArrowScope, escapeArrowScope,++  -- * Unique supply+  newUnique, newUniqueSupply, newName, newNameAt, cloneLocalName,+  newSysName, newSysLocalId, newSysLocalIds,++  -- * Accessing input/output+  newTcRef, readTcRef, writeTcRef, updTcRef,++  -- * Debugging+  traceTc, traceRn, traceOptTcRn, traceTcRn,+  getPrintUnqualified,+  printForUserTcRn,+  traceIf, traceHiDiffs, traceOptIf,+  debugTc,++  -- * Typechecker global environment+  getIsGHCi, getGHCiMonad, getInteractivePrintName,+  tcIsHsBootOrSig, tcSelfBootInfo, getGlobalRdrEnv,+  getRdrEnvs, getImports,+  getFixityEnv, extendFixityEnv, getRecFieldEnv,+  getDeclaredDefaultTys,+  addDependentFiles,++  -- * Error management+  getSrcSpanM, setSrcSpan, addLocM,+  wrapLocM, wrapLocFstM, wrapLocSndM,+  getErrsVar, setErrsVar,+  addErr,+  failWith, failAt,+  addErrAt, addErrs,+  checkErr,+  addMessages,+  discardWarnings,++  -- * Shared error message stuff: renamer and typechecker+  mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError,+  reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,+  tryTc,+  askNoErrs, discardErrs, tryTcDiscardingErrs,+  checkNoErrs, whenNoErrs,+  ifErrsM, failIfErrsM,+  checkTH, failTH,++  -- * Context management for the type checker+  getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt,+  addLandmarkErrCtxtM, updCtxt, popErrCtxt, getCtLocM, setCtLocM,++  -- * Error message generation (type checker)+  addErrTc, addErrsTc,+  addErrTcM, mkErrTcM,+  failWithTc, failWithTcM,+  checkTc, checkTcM,+  failIfTc, failIfTcM,+  warnIf, warnTc, warnTcM,+  addWarnTc, addWarnTcM, addWarn, addWarnAt, add_warn,+  tcInitTidyEnv, tcInitOpenTidyEnv, mkErrInfo,++  -- * Type constraints+  newTcEvBinds,+  addTcEvBind,+  getTcEvTyCoVars, getTcEvBindsMap,+  chooseUniqueOccTc,+  getConstraintVar, setConstraintVar,+  emitConstraints, emitStaticConstraints, emitSimple, emitSimples,+  emitImplication, emitImplications, emitInsoluble,+  discardConstraints, captureConstraints, tryCaptureConstraints,+  pushLevelAndCaptureConstraints,+  pushTcLevelM_, pushTcLevelM,+  getTcLevel, setTcLevel, isTouchableTcM,+  getLclTypeEnv, setLclTypeEnv,+  traceTcConstraints, emitWildCardHoleConstraints,++  -- * Template Haskell context+  recordThUse, recordThSpliceUse, recordTopLevelSpliceLoc,+  getTopLevelSpliceLocs, keepAlive, getStage, getStageAndBindLevel, setStage,+  addModFinalizersWithLclEnv,++  -- * Safe Haskell context+  recordUnsafeInfer, finalSafeMode, fixSafeInstances,++  -- * Stuff for the renamer's local env+  getLocalRdrEnv, setLocalRdrEnv,++  -- * Stuff for interface decls+  mkIfLclEnv,+  initIfaceTcRn,+  initIfaceCheck,+  initIfaceLcl,+  initIfaceLclWithSubst,+  initIfaceLoad,+  getIfModule,+  failIfM,+  forkM_maybe,+  forkM,+  setImplicitEnvM,++  withException,++  -- * Types etc.+  module TcRnTypes,+  module IOEnv+  ) where++#include "HsVersions.h"++import TcRnTypes        -- Re-export all+import IOEnv            -- Re-export all+import TcEvidence++import HsSyn hiding (LIE)+import HscTypes+import Module+import RdrName+import Name+import Type++import TcType+import InstEnv+import FamInstEnv+import PrelNames++import Id+import VarSet+import VarEnv+import ErrUtils+import SrcLoc+import NameEnv+import NameSet+import Bag+import Outputable+import UniqSupply+import DynFlags+import FastString+import Panic+import Util+import Annotations+import BasicTypes( TopLevelFlag )+import Maybes++import qualified GHC.LanguageExtensions as LangExt++import Control.Exception+import Data.IORef+import Control.Monad+import Data.Set ( Set )+import qualified Data.Set as Set++import {-# SOURCE #-} TcSplice ( runRemoteModFinalizers )+import qualified Data.Map as Map++{-+************************************************************************+*                                                                      *+                        initTc+*                                                                      *+************************************************************************+-}++-- | Setup the initial typechecking environment+initTc :: HscEnv+       -> HscSource+       -> Bool          -- True <=> retain renamed syntax trees+       -> Module+       -> RealSrcSpan+       -> TcM r+       -> IO (Messages, Maybe r)+                -- Nothing => error thrown by the thing inside+                -- (error messages should have been printed already)++initTc hsc_env hsc_src keep_rn_syntax mod loc do_this+ = do { keep_var     <- newIORef emptyNameSet ;+        used_gre_var <- newIORef [] ;+        th_var       <- newIORef False ;+        th_splice_var<- newIORef False ;+        th_locs_var  <- newIORef Set.empty ;+        infer_var    <- newIORef (True, emptyBag) ;+        dfun_n_var   <- newIORef emptyOccSet ;+        type_env_var <- case hsc_type_env_var hsc_env of {+                           Just (_mod, te_var) -> return te_var ;+                           Nothing             -> newIORef emptyNameEnv } ;++        dependent_files_var <- newIORef [] ;+        static_wc_var       <- newIORef emptyWC ;+        th_topdecls_var      <- newIORef [] ;+        th_foreign_files_var <- newIORef [] ;+        th_topnames_var      <- newIORef emptyNameSet ;+        th_modfinalizers_var <- newIORef [] ;+        th_state_var         <- newIORef Map.empty ;+        th_remote_state_var  <- newIORef Nothing ;+        let {+             dflags = hsc_dflags hsc_env ;++             maybe_rn_syntax :: forall a. a -> Maybe a ;+             maybe_rn_syntax empty_val+                | keep_rn_syntax = Just empty_val+                | otherwise      = Nothing ;++             gbl_env = TcGblEnv {+                tcg_th_topdecls      = th_topdecls_var,+                tcg_th_foreign_files = th_foreign_files_var,+                tcg_th_topnames      = th_topnames_var,+                tcg_th_modfinalizers = th_modfinalizers_var,+                tcg_th_state         = th_state_var,+                tcg_th_remote_state  = th_remote_state_var,++                tcg_mod            = mod,+                tcg_semantic_mod   =+                    if thisPackage dflags == moduleUnitId mod+                        then canonicalizeHomeModule dflags (moduleName mod)+                        else mod,+                tcg_src            = hsc_src,+                tcg_rdr_env        = emptyGlobalRdrEnv,+                tcg_fix_env        = emptyNameEnv,+                tcg_field_env      = emptyNameEnv,+                tcg_default        = if moduleUnitId mod == primUnitId+                                     then Just []  -- See Note [Default types]+                                     else Nothing,+                tcg_type_env       = emptyNameEnv,+                tcg_type_env_var   = type_env_var,+                tcg_inst_env       = emptyInstEnv,+                tcg_fam_inst_env   = emptyFamInstEnv,+                tcg_pending_fam_checks = emptyNameEnv,+                tcg_ann_env        = emptyAnnEnv,+                tcg_th_used        = th_var,+                tcg_th_splice_used = th_splice_var,+                tcg_th_top_level_locs+                                   = th_locs_var,+                tcg_exports        = [],+                tcg_imports        = emptyImportAvails,+                tcg_used_gres     = used_gre_var,+                tcg_dus            = emptyDUs,++                tcg_rn_imports     = [],+                tcg_rn_exports     =+                    if hsc_src == HsigFile+                        -- Always retain renamed syntax, so that we can give+                        -- better errors.  (TODO: how?)+                        then Just []+                        else maybe_rn_syntax [],+                tcg_rn_decls       = maybe_rn_syntax emptyRnGroup,+                tcg_tr_module      = Nothing,+                tcg_binds          = emptyLHsBinds,+                tcg_imp_specs      = [],+                tcg_sigs           = emptyNameSet,+                tcg_ev_binds       = emptyBag,+                tcg_warns          = NoWarnings,+                tcg_anns           = [],+                tcg_tcs            = [],+                tcg_insts          = [],+                tcg_fam_insts      = [],+                tcg_rules          = [],+                tcg_fords          = [],+                tcg_vects          = [],+                tcg_patsyns        = [],+                tcg_merged         = [],+                tcg_dfun_n         = dfun_n_var,+                tcg_keep           = keep_var,+                tcg_doc_hdr        = Nothing,+                tcg_hpc            = False,+                tcg_main           = Nothing,+                tcg_self_boot      = NoSelfBoot,+                tcg_safeInfer      = infer_var,+                tcg_dependent_files = dependent_files_var,+                tcg_tc_plugins     = [],+                tcg_top_loc        = loc,+                tcg_static_wc      = static_wc_var,+                tcg_complete_matches = []+             } ;+        } ;++        -- OK, here's the business end!+        initTcWithGbl hsc_env gbl_env loc do_this+    }++-- | Run a 'TcM' action in the context of an existing 'GblEnv'.+initTcWithGbl :: HscEnv+              -> TcGblEnv+              -> RealSrcSpan+              -> TcM r+              -> IO (Messages, Maybe r)+initTcWithGbl hsc_env gbl_env loc do_this+ = do { tvs_var      <- newIORef emptyVarSet+      ; lie_var      <- newIORef emptyWC+      ; errs_var     <- newIORef (emptyBag, emptyBag)+      ; let lcl_env = TcLclEnv {+                tcl_errs       = errs_var,+                tcl_loc        = loc,     -- Should be over-ridden very soon!+                tcl_ctxt       = [],+                tcl_rdr        = emptyLocalRdrEnv,+                tcl_th_ctxt    = topStage,+                tcl_th_bndrs   = emptyNameEnv,+                tcl_arrow_ctxt = NoArrowCtxt,+                tcl_env        = emptyNameEnv,+                tcl_bndrs      = [],+                tcl_tidy       = emptyTidyEnv,+                tcl_tyvars     = tvs_var,+                tcl_lie        = lie_var,+                tcl_tclvl      = topTcLevel+                }++      ; maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $+                     do { r <- tryM do_this+                        ; case r of+                          Right res -> return (Just res)+                          Left _    -> return Nothing }++      -- Check for unsolved constraints+      -- If we succeed (maybe_res = Just r), there should be+      -- no unsolved constraints.  But if we exit via an+      -- exception (maybe_res = Nothing), we may have skipped+      -- solving, so don't panic then (Trac #13466)+      ; lie <- readIORef (tcl_lie lcl_env)+      ; when (isJust maybe_res && not (isEmptyWC lie)) $+        pprPanic "initTc: unsolved constraints" (ppr lie)++        -- Collect any error messages+      ; msgs <- readIORef (tcl_errs lcl_env)++      ; let { final_res | errorsFound dflags msgs = Nothing+                        | otherwise               = maybe_res }++      ; return (msgs, final_res)+      }+  where dflags = hsc_dflags hsc_env++initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a)+-- Initialise the type checker monad for use in GHCi+initTcInteractive hsc_env thing_inside+  = initTc hsc_env HsSrcFile False+           (icInteractiveModule (hsc_IC hsc_env))+           (realSrcLocSpan interactive_src_loc)+           thing_inside+  where+    interactive_src_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1++initTcForLookup :: HscEnv -> TcM a -> IO a+-- The thing_inside is just going to look up something+-- in the environment, so we don't need much setup+initTcForLookup hsc_env thing_inside+  = do { (msgs, m) <- initTcInteractive hsc_env thing_inside+       ; case m of+             Nothing -> throwIO $ mkSrcErr $ snd msgs+             Just x -> return x }++{- Note [Default types]+~~~~~~~~~~~~~~~~~~~~~~~+The Integer type is simply not available in package ghc-prim (it is+declared in integer-gmp).  So we set the defaulting types to (Just+[]), meaning there are no default types, rather then Nothing, which+means "use the default default types of Integer, Double".++If you don't do this, attempted defaulting in package ghc-prim causes+an actual crash (attempting to look up the Integer type).+++************************************************************************+*                                                                      *+                Initialisation+*                                                                      *+************************************************************************+-}++initTcRnIf :: Char              -- Tag for unique supply+           -> HscEnv+           -> gbl -> lcl+           -> TcRnIf gbl lcl a+           -> IO a+initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside+   = do { us     <- mkSplitUniqSupply uniq_tag ;+        ; us_var <- newIORef us ;++        ; let { env = Env { env_top = hsc_env,+                            env_us  = us_var,+                            env_gbl = gbl_env,+                            env_lcl = lcl_env} }++        ; runIOEnv env thing_inside+        }++{-+************************************************************************+*                                                                      *+                Simple accessors+*                                                                      *+************************************************************************+-}++discardResult :: TcM a -> TcM ()+discardResult a = a >> return ()++getTopEnv :: TcRnIf gbl lcl HscEnv+getTopEnv = do { env <- getEnv; return (env_top env) }++updTopEnv :: (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a+updTopEnv upd = updEnv (\ env@(Env { env_top = top }) ->+                          env { env_top = upd top })++getGblEnv :: TcRnIf gbl lcl gbl+getGblEnv = do { env <- getEnv; return (env_gbl env) }++updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a+updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->+                          env { env_gbl = upd gbl })++setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a+setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })++getLclEnv :: TcRnIf gbl lcl lcl+getLclEnv = do { env <- getEnv; return (env_lcl env) }++updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a+updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->+                          env { env_lcl = upd lcl })++setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a+setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })++getEnvs :: TcRnIf gbl lcl (gbl, lcl)+getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }++setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a+setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })++-- Command-line flags++xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool+xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) }++doptM :: DumpFlag -> TcRnIf gbl lcl Bool+doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) }++goptM :: GeneralFlag -> TcRnIf gbl lcl Bool+goptM flag = do { dflags <- getDynFlags; return (gopt flag dflags) }++woptM :: WarningFlag -> TcRnIf gbl lcl Bool+woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) }++setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a+setXOptM flag =+  updTopEnv (\top -> top { hsc_dflags = xopt_set (hsc_dflags top) flag})++unsetXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a+unsetXOptM flag =+  updTopEnv (\top -> top { hsc_dflags = xopt_unset (hsc_dflags top) flag})++unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a+unsetGOptM flag =+  updTopEnv (\top -> top { hsc_dflags = gopt_unset (hsc_dflags top) flag})++unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a+unsetWOptM flag =+  updTopEnv (\top -> top { hsc_dflags = wopt_unset (hsc_dflags top) flag})++-- | Do it flag is true+whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()+whenDOptM flag thing_inside = do b <- doptM flag+                                 when b thing_inside++whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()+whenGOptM flag thing_inside = do b <- goptM flag+                                 when b thing_inside++whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()+whenWOptM flag thing_inside = do b <- woptM flag+                                 when b thing_inside++whenXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()+whenXOptM flag thing_inside = do b <- xoptM flag+                                 when b thing_inside++getGhcMode :: TcRnIf gbl lcl GhcMode+getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }++withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a+withDoDynamicToo =+  updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) ->+              top { hsc_dflags = dynamicTooMkDynamicDynFlags dflags })++getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)+getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }++getEps :: TcRnIf gbl lcl ExternalPackageState+getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }++-- | Update the external package state.  Returns the second result of the+-- modifier function.+--+-- This is an atomic operation and forces evaluation of the modified EPS in+-- order to avoid space leaks.+updateEps :: (ExternalPackageState -> (ExternalPackageState, a))+          -> TcRnIf gbl lcl a+updateEps upd_fn = do+  traceIf (text "updating EPS")+  eps_var <- getEpsVar+  atomicUpdMutVar' eps_var upd_fn++-- | Update the external package state.+--+-- This is an atomic operation and forces evaluation of the modified EPS in+-- order to avoid space leaks.+updateEps_ :: (ExternalPackageState -> ExternalPackageState)+           -> TcRnIf gbl lcl ()+updateEps_ upd_fn = do+  traceIf (text "updating EPS_")+  eps_var <- getEpsVar+  atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ()))++getHpt :: TcRnIf gbl lcl HomePackageTable+getHpt = do { env <- getTopEnv; return (hsc_HPT env) }++getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)+getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)+                  ; return (eps, hsc_HPT env) }++-- | A convenient wrapper for taking a @MaybeErr MsgDoc a@ and throwing+-- an exception if it is an error.+withException :: TcRnIf gbl lcl (MaybeErr MsgDoc a) -> TcRnIf gbl lcl a+withException do_this = do+    r <- do_this+    dflags <- getDynFlags+    case r of+        Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err))+        Succeeded result -> return result++{-+************************************************************************+*                                                                      *+                Arrow scopes+*                                                                      *+************************************************************************+-}++newArrowScope :: TcM a -> TcM a+newArrowScope+  = updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) }++-- Return to the stored environment (from the enclosing proc)+escapeArrowScope :: TcM a -> TcM a+escapeArrowScope+  = updLclEnv $ \ env ->+    case tcl_arrow_ctxt env of+      NoArrowCtxt       -> env+      ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt+                                   , tcl_lie = lie+                                   , tcl_rdr = rdr_env }++{-+************************************************************************+*                                                                      *+                Unique supply+*                                                                      *+************************************************************************+-}++newUnique :: TcRnIf gbl lcl Unique+newUnique+ = do { env <- getEnv ;+        let { u_var = env_us env } ;+        us <- readMutVar u_var ;+        case takeUniqFromSupply us of { (uniq, us') -> do {+        writeMutVar u_var us' ;+        return $! uniq }}}+   -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving+   -- a chain of unevaluated supplies behind.+   -- NOTE 2: we use the uniq in the supply from the MutVar directly, and+   -- throw away one half of the new split supply.  This is safe because this+   -- is the only place we use that unique.  Using the other half of the split+   -- supply is safer, but slower.++newUniqueSupply :: TcRnIf gbl lcl UniqSupply+newUniqueSupply+ = do { env <- getEnv ;+        let { u_var = env_us env } ;+        us <- readMutVar u_var ;+        case splitUniqSupply us of { (us1,us2) -> do {+        writeMutVar u_var us1 ;+        return us2 }}}++cloneLocalName :: Name -> TcM Name+-- Make a fresh Internal name with the same OccName and SrcSpan+cloneLocalName name = newNameAt (nameOccName name) (nameSrcSpan name)++newName :: OccName -> TcM Name+newName occ = do { loc  <- getSrcSpanM+                 ; newNameAt occ loc }++newNameAt :: OccName -> SrcSpan -> TcM Name+newNameAt occ span+  = do { uniq <- newUnique+       ; return (mkInternalName uniq occ span) }++newSysName :: OccName -> TcRnIf gbl lcl Name+newSysName occ+  = do { uniq <- newUnique+       ; return (mkSystemName uniq occ) }++newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId+newSysLocalId fs ty+  = do  { u <- newUnique+        ; return (mkSysLocalOrCoVar fs u ty) }++newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]+newSysLocalIds fs tys+  = do  { us <- newUniqueSupply+        ; return (zipWith (mkSysLocalOrCoVar fs) (uniqsFromSupply us) tys) }++instance MonadUnique (IOEnv (Env gbl lcl)) where+        getUniqueM = newUnique+        getUniqueSupplyM = newUniqueSupply++{-+************************************************************************+*                                                                      *+                Accessing input/output+*                                                                      *+************************************************************************+-}++newTcRef :: a -> TcRnIf gbl lcl (TcRef a)+newTcRef = newMutVar++readTcRef :: TcRef a -> TcRnIf gbl lcl a+readTcRef = readMutVar++writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl ()+writeTcRef = writeMutVar++updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()+-- Returns ()+updTcRef ref fn = liftIO $ do { old <- readIORef ref+                              ; writeIORef ref (fn old) }++{-+************************************************************************+*                                                                      *+                Debugging+*                                                                      *+************************************************************************+-}+++-- Typechecker trace+traceTc :: String -> SDoc -> TcRn ()+traceTc =+  labelledTraceOptTcRn Opt_D_dump_tc_trace++-- Renamer Trace+traceRn :: String -> SDoc -> TcRn ()+traceRn =+  labelledTraceOptTcRn Opt_D_dump_rn_trace++-- | Trace when a certain flag is enabled. This is like `traceOptTcRn`+-- but accepts a string as a label and formats the trace message uniformly.+labelledTraceOptTcRn :: DumpFlag -> String -> SDoc -> TcRn ()+labelledTraceOptTcRn flag herald doc = do+   traceOptTcRn flag (formatTraceMsg herald doc)++formatTraceMsg :: String -> SDoc -> SDoc+formatTraceMsg herald doc = hang (text herald) 2 doc++-- | Output a doc if the given 'DumpFlag' is set.+--+-- By default this logs to stdout+-- However, if the `-ddump-to-file` flag is set,+-- then this will dump output to a file+--+-- Just a wrapper for 'dumpSDoc'+traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()+traceOptTcRn flag doc+  = do { dflags <- getDynFlags+       ; when (dopt flag dflags)+              (traceTcRn flag doc)+       }+++traceTcRn :: DumpFlag -> SDoc -> TcRn ()+-- ^ Unconditionally dump some trace output+--+-- The DumpFlag is used only to set the output filename+-- for --dump-to-file, not to decide whether or not to output+-- That part is done by the caller+traceTcRn flag doc+  = do { dflags   <- getDynFlags+       ; real_doc <- prettyDoc dflags doc+       ; printer  <- getPrintUnqualified dflags+       ; liftIO $ dumpSDoc dflags printer flag "" real_doc  }+  where+    -- Add current location if -dppr-debug+    prettyDoc :: DynFlags -> SDoc -> TcRn SDoc+    prettyDoc dflags doc = if hasPprDebug dflags+       then do { loc  <- getSrcSpanM; return $ mkLocMessage SevOutput loc doc }+       else return doc -- The full location is usually way too much+++getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified+getPrintUnqualified dflags+  = do { rdr_env <- getGlobalRdrEnv+       ; return $ mkPrintUnqualified dflags rdr_env }++-- | Like logInfoTcRn, but for user consumption+printForUserTcRn :: SDoc -> TcRn ()+printForUserTcRn doc+  = do { dflags <- getDynFlags+       ; printer <- getPrintUnqualified dflags+       ; liftIO (printOutputForUser dflags printer doc) }++{-+traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is+available.  Alas, they behave inconsistently with the other stuff;+e.g. are unaffected by -dump-to-file.+-}++traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()+traceIf      = traceOptIf Opt_D_dump_if_trace+traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs+++traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n ()+traceOptIf flag doc+  = whenDOptM flag $    -- No RdrEnv available, so qualify everything+    do { dflags <- getDynFlags+       ; liftIO (putMsg dflags doc) }++{-+************************************************************************+*                                                                      *+                Typechecker global environment+*                                                                      *+************************************************************************+-}++getIsGHCi :: TcRn Bool+getIsGHCi = do { mod <- getModule+               ; return (isInteractiveModule mod) }++getGHCiMonad :: TcRn Name+getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) }++getInteractivePrintName :: TcRn Name+getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) }++tcIsHsBootOrSig :: TcRn Bool+tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) }++tcSelfBootInfo :: TcRn SelfBootInfo+tcSelfBootInfo = do { env <- getGblEnv; return (tcg_self_boot env) }++getGlobalRdrEnv :: TcRn GlobalRdrEnv+getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }++getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)+getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }++getImports :: TcRn ImportAvails+getImports = do { env <- getGblEnv; return (tcg_imports env) }++getFixityEnv :: TcRn FixityEnv+getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }++extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a+extendFixityEnv new_bit+  = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->+                env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})++getRecFieldEnv :: TcRn RecFieldEnv+getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }++getDeclaredDefaultTys :: TcRn (Maybe [Type])+getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }++addDependentFiles :: [FilePath] -> TcRn ()+addDependentFiles fs = do+  ref <- fmap tcg_dependent_files getGblEnv+  dep_files <- readTcRef ref+  writeTcRef ref (fs ++ dep_files)++{-+************************************************************************+*                                                                      *+                Error management+*                                                                      *+************************************************************************+-}++getSrcSpanM :: TcRn SrcSpan+        -- Avoid clash with Name.getSrcLoc+getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env)) }++setSrcSpan :: SrcSpan -> TcRn a -> TcRn a+setSrcSpan (RealSrcSpan real_loc) thing_inside+    = updLclEnv (\env -> env { tcl_loc = real_loc }) thing_inside+-- Don't overwrite useful info with useless:+setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside++addLocM :: (a -> TcM b) -> Located a -> TcM b+addLocM fn (L loc a) = setSrcSpan loc $ fn a++wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)+wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b)++wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)+wrapLocFstM fn (L loc a) =+  setSrcSpan loc $ do+    (b,c) <- fn a+    return (L loc b, c)++wrapLocSndM :: (a -> TcM (b,c)) -> Located a -> TcM (b, Located c)+wrapLocSndM fn (L loc a) =+  setSrcSpan loc $ do+    (b,c) <- fn a+    return (b, L loc c)++-- Reporting errors++getErrsVar :: TcRn (TcRef Messages)+getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }++setErrsVar :: TcRef Messages -> TcRn a -> TcRn a+setErrsVar v = updLclEnv (\ env -> env { tcl_errs =  v })++addErr :: MsgDoc -> TcRn ()+addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg }++failWith :: MsgDoc -> TcRn a+failWith msg = addErr msg >> failM++failAt :: SrcSpan -> MsgDoc -> TcRn a+failAt loc msg = addErrAt loc msg >> failM++addErrAt :: SrcSpan -> MsgDoc -> TcRn ()+-- addErrAt is mainly (exclusively?) used by the renamer, where+-- tidying is not an issue, but it's all lazy so the extra+-- work doesn't matter+addErrAt loc msg = do { ctxt <- getErrCtxt+                      ; tidy_env <- tcInitTidyEnv+                      ; err_info <- mkErrInfo tidy_env ctxt+                      ; addLongErrAt loc msg err_info }++addErrs :: [(SrcSpan,MsgDoc)] -> TcRn ()+addErrs msgs = mapM_ add msgs+             where+               add (loc,msg) = addErrAt loc msg++checkErr :: Bool -> MsgDoc -> TcRn ()+-- Add the error if the bool is False+checkErr ok msg = unless ok (addErr msg)++addMessages :: Messages -> TcRn ()+addMessages msgs1+  = do { errs_var <- getErrsVar ;+         msgs0 <- readTcRef errs_var ;+         writeTcRef errs_var (unionMessages msgs0 msgs1) }++discardWarnings :: TcRn a -> TcRn a+-- Ignore warnings inside the thing inside;+-- used to ignore-unused-variable warnings inside derived code+discardWarnings thing_inside+  = do  { errs_var <- getErrsVar+        ; (old_warns, _) <- readTcRef errs_var++        ; result <- thing_inside++        -- Revert warnings to old_warns+        ; (_new_warns, new_errs) <- readTcRef errs_var+        ; writeTcRef errs_var (old_warns, new_errs)++        ; return result }++{-+************************************************************************+*                                                                      *+        Shared error message stuff: renamer and typechecker+*                                                                      *+************************************************************************+-}++mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg+mkLongErrAt loc msg extra+  = do { dflags <- getDynFlags ;+         printer <- getPrintUnqualified dflags ;+         return $ mkLongErrMsg dflags loc printer msg extra }++mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg+mkErrDocAt loc errDoc+  = do { dflags <- getDynFlags ;+         printer <- getPrintUnqualified dflags ;+         return $ mkErrDoc dflags loc printer errDoc }++addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()+addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError++reportErrors :: [ErrMsg] -> TcM ()+reportErrors = mapM_ reportError++reportError :: ErrMsg -> TcRn ()+reportError err+  = do { traceTc "Adding error:" (pprLocErrMsg err) ;+         errs_var <- getErrsVar ;+         (warns, errs) <- readTcRef errs_var ;+         writeTcRef errs_var (warns, errs `snocBag` err) }++reportWarning :: WarnReason -> ErrMsg -> TcRn ()+reportWarning reason err+  = do { let warn = makeIntoWarning reason err+                    -- 'err' was built by mkLongErrMsg or something like that,+                    -- so it's of error severity.  For a warning we downgrade+                    -- its severity to SevWarning++       ; traceTc "Adding warning:" (pprLocErrMsg warn)+       ; errs_var <- getErrsVar+       ; (warns, errs) <- readTcRef errs_var+       ; writeTcRef errs_var (warns `snocBag` warn, errs) }++try_m :: TcRn r -> TcRn (Either IOEnvFailure r)+-- Does tryM, with a debug-trace on failure+try_m thing+  = do { (mb_r, lie) <- tryCaptureConstraints thing+       ; emitConstraints lie++       -- Debug trace+       ; case mb_r of+            Left exn -> traceTc "tryTc/recoverM recovering from" $+                        text (showException exn)+            Right {} -> return ()++       ; return mb_r }++-----------------------+recoverM :: TcRn r      -- Recovery action; do this if the main one fails+         -> TcRn r      -- Main action: do this first;+                        --  if it generates errors, propagate them all+         -> TcRn r+-- Errors in 'thing' are retained+recoverM recover thing+  = do { mb_res <- try_m thing ;+         case mb_res of+           Left _    -> recover+           Right res -> return res }+++-----------------------++-- | Drop elements of the input that fail, so the result+-- list can be shorter than the argument list+mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]+mapAndRecoverM f = fmap reverse . foldAndRecoverM (\xs x -> (:xs) <$> f x ) []++-- | The accumulator is not updated if the action fails+foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b+foldAndRecoverM _ acc []     = return acc+foldAndRecoverM f acc (x:xs) =+                          do { mb_r <- try_m (f acc x)+                             ; case mb_r of+                                Left _  -> foldAndRecoverM f acc xs+                                Right acc' -> foldAndRecoverM f acc' xs  }++-- | Succeeds if applying the argument to all members of the lists succeeds,+--   but nevertheless runs it on all arguments, to collect all errors.+mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b]+mapAndReportM f xs = checkNoErrs (mapAndRecoverM f xs)++-----------------------+tryTc :: TcRn a -> TcRn (Messages, Maybe a)+-- (tryTc m) executes m, and returns+--      Just r,  if m succeeds (returning r)+--      Nothing, if m fails+-- It also returns all the errors and warnings accumulated by m+-- It always succeeds (never raises an exception)+tryTc thing_inside+ = do { errs_var <- newTcRef emptyMessages ;++        res  <- try_m $  -- Be sure to catch exceptions, so that+                         -- we guaranteed to read the messages out+                         -- of that brand-new errs_var!+                setErrsVar errs_var $+                thing_inside ;++        msgs <- readTcRef errs_var ;++        return (msgs, case res of+                        Left _    -> Nothing+                        Right val -> Just val)+        -- The exception is always the IOEnv built-in+        -- in exception; see IOEnv.failM+   }++-----------------------+discardErrs :: TcRn a -> TcRn a+-- (discardErrs m) runs m,+--   discarding all error messages and warnings generated by m+-- If m fails, discardErrs fails, and vice versa+discardErrs m+ = do { errs_var <- newTcRef emptyMessages+      ; setErrsVar errs_var m }++-----------------------+tryTcDiscardingErrs :: TcM r -> TcM r -> TcM r+-- (tryTcDiscardingErrs recover main) tries 'main';+--      if 'main' succeeds with no error messages, it's the answer+--      otherwise discard everything from 'main', including errors,+--          and try 'recover' instead.+tryTcDiscardingErrs recover main+  = do  { (msgs, mb_res) <- tryTc main+        ; dflags <- getDynFlags+        ; case mb_res of+            Just res | not (errorsFound dflags msgs)+              -> -- 'main' succeeed with no error messages+                 do { addMessages msgs  -- msgs might still have warnings+                    ; return res }++            _ -> -- 'main' failed, or produced an error message+                 recover     -- Discard all errors and warnings entirely+        }++-----------------------+-- (askNoErrs m) runs m+-- If m fails,+--    then (askNoErrs m) fails+-- If m succeeds with result r,+--    then (askNoErrs m) succeeds with result (r, b),+--         where b is True iff m generated no errors+-- Regardless of success or failure,+--   propagate any errors/warnings generated by m+askNoErrs :: TcRn a -> TcRn (a, Bool)+askNoErrs m+  = do { (msgs, mb_res) <- tryTc m+       ; addMessages msgs  -- Always propagate errors+       ; case mb_res of+           Nothing  -> failM+           Just res -> do { dflags <- getDynFlags+                          ; let errs_found = errorsFound dflags msgs+                          ; return (res, not errs_found) } }+-----------------------+checkNoErrs :: TcM r -> TcM r+-- (checkNoErrs m) succeeds iff m succeeds and generates no errors+-- If m fails then (checkNoErrsTc m) fails.+-- If m succeeds, it checks whether m generated any errors messages+--      (it might have recovered internally)+--      If so, it fails too.+-- Regardless, any errors generated by m are propagated to the enclosing context.+checkNoErrs main+  = do  { (res, no_errs) <- askNoErrs main+        ; unless no_errs failM+        ; return res }++-----------------------+whenNoErrs :: TcM () -> TcM ()+whenNoErrs thing = ifErrsM (return ()) thing++ifErrsM :: TcRn r -> TcRn r -> TcRn r+--      ifErrsM bale_out normal+-- does 'bale_out' if there are errors in errors collection+-- otherwise does 'normal'+ifErrsM bale_out normal+ = do { errs_var <- getErrsVar ;+        msgs <- readTcRef errs_var ;+        dflags <- getDynFlags ;+        if errorsFound dflags msgs then+           bale_out+        else+           normal }++failIfErrsM :: TcRn ()+-- Useful to avoid error cascades+failIfErrsM = ifErrsM failM (return ())++checkTH :: a -> String -> TcRn ()+checkTH _ _ = return () -- OK++failTH :: Outputable a => a -> String -> TcRn x+failTH e what  -- Raise an error in a stage-1 compiler+  = failWithTc (vcat [ hang (char 'A' <+> text what+                             <+> text "requires GHC with interpreter support:")+                          2 (ppr e)+                     , text "Perhaps you are using a stage-1 compiler?" ])+++{- *********************************************************************+*                                                                      *+        Context management for the type checker+*                                                                      *+************************************************************************+-}++getErrCtxt :: TcM [ErrCtxt]+getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }++setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a+setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })++-- | Add a fixed message to the error context. This message should not+-- do any tidying.+addErrCtxt :: MsgDoc -> TcM a -> TcM a+addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))++-- | Add a message to the error context. This message may do tidying.+addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a+addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)++-- | Add a fixed landmark message to the error context. A landmark+-- message is always sure to be reported, even if there is a lot of+-- context. It also doesn't count toward the maximum number of contexts+-- reported.+addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a+addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg))++-- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations+-- and tidying.+addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a+addLandmarkErrCtxtM ctxt = updCtxt (\ctxts -> (True, ctxt) : ctxts)++-- Helper function for the above+updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a+updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->+                           env { tcl_ctxt = upd ctxt })++popErrCtxt :: TcM a -> TcM a+popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })++getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc+getCtLocM origin t_or_k+  = do { env <- getLclEnv+       ; return (CtLoc { ctl_origin = origin+                       , ctl_env    = env+                       , ctl_t_or_k = t_or_k+                       , ctl_depth  = initialSubGoalDepth }) }++setCtLocM :: CtLoc -> TcM a -> TcM a+-- Set the SrcSpan and error context from the CtLoc+setCtLocM (CtLoc { ctl_env = lcl }) thing_inside+  = updLclEnv (\env -> env { tcl_loc   = tcl_loc lcl+                           , tcl_bndrs = tcl_bndrs lcl+                           , tcl_ctxt  = tcl_ctxt lcl })+              thing_inside++{-+************************************************************************+*                                                                      *+             Error message generation (type checker)+*                                                                      *+************************************************************************++    The addErrTc functions add an error message, but do not cause failure.+    The 'M' variants pass a TidyEnv that has already been used to+    tidy up the message; we then use it to tidy the context messages+-}++addErrTc :: MsgDoc -> TcM ()+addErrTc err_msg = do { env0 <- tcInitTidyEnv+                      ; addErrTcM (env0, err_msg) }++addErrsTc :: [MsgDoc] -> TcM ()+addErrsTc err_msgs = mapM_ addErrTc err_msgs++addErrTcM :: (TidyEnv, MsgDoc) -> TcM ()+addErrTcM (tidy_env, err_msg)+  = do { ctxt <- getErrCtxt ;+         loc  <- getSrcSpanM ;+         add_err_tcm tidy_env err_msg loc ctxt }++-- Return the error message, instead of reporting it straight away+mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg+mkErrTcM (tidy_env, err_msg)+  = do { ctxt <- getErrCtxt ;+         loc  <- getSrcSpanM ;+         err_info <- mkErrInfo tidy_env ctxt ;+         mkLongErrAt loc err_msg err_info }++-- The failWith functions add an error message and cause failure++failWithTc :: MsgDoc -> TcM a               -- Add an error message and fail+failWithTc err_msg+  = addErrTc err_msg >> failM++failWithTcM :: (TidyEnv, MsgDoc) -> TcM a   -- Add an error message and fail+failWithTcM local_and_msg+  = addErrTcM local_and_msg >> failM++checkTc :: Bool -> MsgDoc -> TcM ()         -- Check that the boolean is true+checkTc True  _   = return ()+checkTc False err = failWithTc err++checkTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()+checkTcM True  _   = return ()+checkTcM False err = failWithTcM err++failIfTc :: Bool -> MsgDoc -> TcM ()         -- Check that the boolean is false+failIfTc False _   = return ()+failIfTc True  err = failWithTc err++failIfTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()+   -- Check that the boolean is false+failIfTcM False _   = return ()+failIfTcM True  err = failWithTcM err+++--         Warnings have no 'M' variant, nor failure++-- | Display a warning if a condition is met.+--   and the warning is enabled+warnIf :: WarnReason -> Bool -> MsgDoc -> TcRn ()+warnIf reason is_bad msg+  = do { warn_on <- case reason of+                       NoReason         -> return True+                       Reason warn_flag -> woptM warn_flag+       ; when (warn_on && is_bad) $+         addWarn reason msg }++-- | Display a warning if a condition is met.+warnTc :: WarnReason -> Bool -> MsgDoc -> TcM ()+warnTc reason warn_if_true warn_msg+  | warn_if_true = addWarnTc reason warn_msg+  | otherwise    = return ()++-- | Display a warning if a condition is met.+warnTcM :: WarnReason -> Bool -> (TidyEnv, MsgDoc) -> TcM ()+warnTcM reason warn_if_true warn_msg+  | warn_if_true = addWarnTcM reason warn_msg+  | otherwise    = return ()++-- | Display a warning in the current context.+addWarnTc :: WarnReason -> MsgDoc -> TcM ()+addWarnTc reason msg+ = do { env0 <- tcInitTidyEnv ;+      addWarnTcM reason (env0, msg) }++-- | Display a warning in a given context.+addWarnTcM :: WarnReason -> (TidyEnv, MsgDoc) -> TcM ()+addWarnTcM reason (env0, msg)+ = do { ctxt <- getErrCtxt ;+        err_info <- mkErrInfo env0 ctxt ;+        add_warn reason msg err_info }++-- | Display a warning for the current source location.+addWarn :: WarnReason -> MsgDoc -> TcRn ()+addWarn reason msg = add_warn reason msg Outputable.empty++-- | Display a warning for a given source location.+addWarnAt :: WarnReason -> SrcSpan -> MsgDoc -> TcRn ()+addWarnAt reason loc msg = add_warn_at reason loc msg Outputable.empty++-- | Display a warning, with an optional flag, for the current source+-- location.+add_warn :: WarnReason -> MsgDoc -> MsgDoc -> TcRn ()+add_warn reason msg extra_info+  = do { loc <- getSrcSpanM+       ; add_warn_at reason loc msg extra_info }++-- | Display a warning, with an optional flag, for a given location.+add_warn_at :: WarnReason -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()+add_warn_at reason loc msg extra_info+  = do { dflags <- getDynFlags ;+         printer <- getPrintUnqualified dflags ;+         let { warn = mkLongWarnMsg dflags loc printer+                                    msg extra_info } ;+         reportWarning reason warn }++tcInitTidyEnv :: TcM TidyEnv+tcInitTidyEnv+  = do  { lcl_env <- getLclEnv+        ; return (tcl_tidy lcl_env) }++-- | Get a 'TidyEnv' that includes mappings for all vars free in the given+-- type. Useful when tidying open types.+tcInitOpenTidyEnv :: [TyCoVar] -> TcM TidyEnv+tcInitOpenTidyEnv tvs+  = do { env1 <- tcInitTidyEnv+       ; let env2 = tidyFreeTyCoVars env1 tvs+       ; return env2 }+++{-+-----------------------------------+        Other helper functions+-}++add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan+            -> [ErrCtxt]+            -> TcM ()+add_err_tcm tidy_env err_msg loc ctxt+ = do { err_info <- mkErrInfo tidy_env ctxt ;+        addLongErrAt loc err_msg err_info }++mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc+-- Tidy the error info, trimming excessive contexts+mkErrInfo env ctxts+--  = do+--       dbg <- hasPprDebug <$> getDynFlags+--       if dbg                -- In -dppr-debug style the output+--          then return empty  -- just becomes too voluminous+--          else go dbg 0 env ctxts+ = go False 0 env ctxts+ where+   go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc+   go _ _ _   [] = return empty+   go dbg n env ((is_landmark, ctxt) : ctxts)+     | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg+     = do { (env', msg) <- ctxt env+          ; let n' = if is_landmark then n else n+1+          ; rest <- go dbg n' env' ctxts+          ; return (msg $$ rest) }+     | otherwise+     = go dbg n env ctxts++mAX_CONTEXTS :: Int     -- No more than this number of non-landmark contexts+mAX_CONTEXTS = 3++-- debugTc is useful for monadic debugging code++debugTc :: TcM () -> TcM ()+debugTc thing+ | debugIsOn = thing+ | otherwise = return ()++{-+************************************************************************+*                                                                      *+             Type constraints+*                                                                      *+************************************************************************+-}++newTcEvBinds :: TcM EvBindsVar+newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap+                  ; tcvs_ref  <- newTcRef emptyVarSet+                  ; uniq <- newUnique+                  ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq)+                  ; return (EvBindsVar { ebv_binds = binds_ref+                                       , ebv_tcvs = tcvs_ref+                                       , ebv_uniq = uniq }) }++getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet+getTcEvTyCoVars (EvBindsVar { ebv_tcvs = ev_ref })+  = readTcRef ev_ref++getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap+getTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref })+  = readTcRef ev_ref++addTcEvBind :: EvBindsVar -> EvBind -> TcM ()+-- Add a binding to the TcEvBinds by side effect+addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind+  = do { traceTc "addTcEvBind" $ ppr u $$+                                 ppr ev_bind+       ; bnds <- readTcRef ev_ref+       ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) }++chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName+chooseUniqueOccTc fn =+  do { env <- getGblEnv+     ; let dfun_n_var = tcg_dfun_n env+     ; set <- readTcRef dfun_n_var+     ; let occ = fn set+     ; writeTcRef dfun_n_var (extendOccSet set occ)+     ; return occ }++getConstraintVar :: TcM (TcRef WantedConstraints)+getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }++setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a+setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })++emitStaticConstraints :: WantedConstraints -> TcM ()+emitStaticConstraints static_lie+  = do { gbl_env <- getGblEnv+       ; updTcRef (tcg_static_wc gbl_env) (`andWC` static_lie) }++emitConstraints :: WantedConstraints -> TcM ()+emitConstraints ct+  = do { lie_var <- getConstraintVar ;+         updTcRef lie_var (`andWC` ct) }++emitSimple :: Ct -> TcM ()+emitSimple ct+  = do { lie_var <- getConstraintVar ;+         updTcRef lie_var (`addSimples` unitBag ct) }++emitSimples :: Cts -> TcM ()+emitSimples cts+  = do { lie_var <- getConstraintVar ;+         updTcRef lie_var (`addSimples` cts) }++emitImplication :: Implication -> TcM ()+emitImplication ct+  = do { lie_var <- getConstraintVar ;+         updTcRef lie_var (`addImplics` unitBag ct) }++emitImplications :: Bag Implication -> TcM ()+emitImplications ct+  = unless (isEmptyBag ct) $+    do { lie_var <- getConstraintVar ;+         updTcRef lie_var (`addImplics` ct) }++emitInsoluble :: Ct -> TcM ()+emitInsoluble ct+  = do { traceTc "emitInsoluble" (ppr ct)+       ; lie_var <- getConstraintVar+       ; updTcRef lie_var (`addInsols` unitBag ct) }++emitInsolubles :: Cts -> TcM ()+emitInsolubles cts+  | isEmptyBag cts = return ()+  | otherwise      = do { traceTc "emitInsolubles" (ppr cts)+                        ; lie_var <- getConstraintVar+                        ; updTcRef lie_var (`addInsols` cts) }++-- | Throw out any constraints emitted by the thing_inside+discardConstraints :: TcM a -> TcM a+discardConstraints thing_inside = fst <$> captureConstraints thing_inside++tryCaptureConstraints :: TcM a -> TcM (Either IOEnvFailure a, WantedConstraints)+-- (captureConstraints_maybe m) runs m,+-- and returns the type constraints it generates+-- It never throws an exception; instead if thing_inside fails,+--   it returns Left exn and the insoluble constraints+tryCaptureConstraints thing_inside+  = do { lie_var <- newTcRef emptyWC+       ; mb_res <- tryM $+                   updLclEnv (\ env -> env { tcl_lie = lie_var }) $+                   thing_inside+       ; lie <- readTcRef lie_var++       -- See Note [Constraints and errors]+       ; let lie_to_keep = case mb_res of+                             Left {}  -> insolublesOnly lie+                             Right {} -> lie++       ; return (mb_res, lie_to_keep) }++captureConstraints :: TcM a -> TcM (a, WantedConstraints)+-- (captureConstraints m) runs m, and returns the type constraints it generates+captureConstraints thing_inside+  = do { (mb_res, lie) <- tryCaptureConstraints thing_inside++            -- See Note [Constraints and errors]+            -- If the thing_inside threw an exception, emit the insoluble+            -- constraints only (returned by tryCaptureConstraints)+            -- so that they are not lost+       ; case mb_res of+           Left _    -> do { emitConstraints lie; failM }+           Right res -> return (res, lie) }++pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a)+pushLevelAndCaptureConstraints thing_inside+  = do { env <- getLclEnv+       ; let tclvl' = pushTcLevel (tcl_tclvl env)+       ; (res, lie) <- setLclEnv (env { tcl_tclvl = tclvl' }) $+                       captureConstraints thing_inside+       ; return (tclvl', lie, res) }++pushTcLevelM_ :: TcM a -> TcM a+pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x++pushTcLevelM :: TcM a -> TcM (a, TcLevel)+-- See Note [TcLevel assignment] in TcType+pushTcLevelM thing_inside+  = do { env <- getLclEnv+       ; let tclvl' = pushTcLevel (tcl_tclvl env)+       ; res <- setLclEnv (env { tcl_tclvl = tclvl' })+                          thing_inside+       ; return (res, tclvl') }++getTcLevel :: TcM TcLevel+getTcLevel = do { env <- getLclEnv+                ; return (tcl_tclvl env) }++setTcLevel :: TcLevel -> TcM a -> TcM a+setTcLevel tclvl thing_inside+  = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside++isTouchableTcM :: TcTyVar -> TcM Bool+isTouchableTcM tv+  = do { env <- getLclEnv+       ; return (isTouchableMetaTyVar (tcl_tclvl env) tv) }++getLclTypeEnv :: TcM TcTypeEnv+getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }++setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a+-- Set the local type envt, but do *not* disturb other fields,+-- notably the lie_var+setLclTypeEnv lcl_env thing_inside+  = updLclEnv upd thing_inside+  where+    upd env = env { tcl_env = tcl_env lcl_env,+                    tcl_tyvars = tcl_tyvars lcl_env }++traceTcConstraints :: String -> TcM ()+traceTcConstraints msg+  = do { lie_var <- getConstraintVar+       ; lie     <- readTcRef lie_var+       ; traceOptTcRn Opt_D_dump_tc_trace $+         hang (text (msg ++ ": LIE:")) 2 (ppr lie)+       }++emitWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM ()+emitWildCardHoleConstraints wcs+  = do { ct_loc <- getCtLocM HoleOrigin Nothing+       ; emitInsolubles $ listToBag $+         map (do_one ct_loc) wcs }+  where+    do_one :: CtLoc -> (Name, TcTyVar) -> Ct+    do_one ct_loc (name, tv)+       = CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv+                                      , ctev_loc  = ct_loc' }+                  , cc_hole = TypeHole (occName name) }+       where+         real_span = case nameSrcSpan name of+                           RealSrcSpan span  -> span+                           UnhelpfulSpan str -> pprPanic "emitWildCardHoleConstraints"+                                                      (ppr name <+> quotes (ftext str))+               -- Wildcards are defined locally, and so have RealSrcSpans+         ct_loc' = setCtLocSpan ct_loc real_span++{- Note [Constraints and errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (Trac #12124):++  foo :: Maybe Int+  foo = return (case Left 3 of+                  Left -> 1  -- Hard error here!+                  _    -> 0)++The call to 'return' will generate a (Monad m) wanted constraint; but+then there'll be "hard error" (i.e. an exception in the TcM monad), from+the unsaturated Left constructor pattern.++We'll recover in tcPolyBinds, using recoverM.  But then the final+tcSimplifyTop will see that (Monad m) constraint, with 'm' utterly+un-filled-in, and will emit a misleading error message.++The underlying problem is that an exception interrupts the constraint+gathering process. Bottom line: if we have an exception, it's best+simply to discard any gathered constraints.  Hence in 'try_m' we+capture the constraints in a fresh variable, and only emit them into+the surrounding context if we exit normally.  If an exception is+raised, simply discard the collected constraints... we have a hard+error to report.  So this capture-the-emit dance isn't as stupid as it+looks :-).++However suppose we throw an exception inside an invocation of+captureConstraints, and discard all the constraints. Some of those+contraints might be "variable out of scope" Hole constraints, and that+might have been the actual original cause of the exception!  For+example (Trac #12529):+   f = p @ Int+Here 'p' is out of scope, so we get an insolube Hole constraint. But+the visible type application fails in the monad (thows an exception).+We must not discard the out-of-scope error.++So we /retain the insoluble constraints/ if there is an exception.+Hence:+  - insolublesOnly in tryCaptureConstraints+  - emitConstraints in the Left case of captureConstraints+++************************************************************************+*                                                                      *+             Template Haskell context+*                                                                      *+************************************************************************+-}++recordThUse :: TcM ()+recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }++recordThSpliceUse :: TcM ()+recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True }++-- | When generating an out-of-scope error message for a variable matching a+-- binding in a later inter-splice group, the typechecker uses the splice+-- locations to provide details in the message about the scope of that binding.+recordTopLevelSpliceLoc :: SrcSpan -> TcM ()+recordTopLevelSpliceLoc (RealSrcSpan real_loc)+  = do { env <- getGblEnv+       ; let locs_var = tcg_th_top_level_locs env+       ; locs0 <- readTcRef locs_var+       ; writeTcRef locs_var (Set.insert real_loc locs0) }+recordTopLevelSpliceLoc (UnhelpfulSpan _) = return ()++getTopLevelSpliceLocs :: TcM (Set RealSrcSpan)+getTopLevelSpliceLocs+  = do { env <- getGblEnv+       ; readTcRef (tcg_th_top_level_locs env) }++keepAlive :: Name -> TcRn ()     -- Record the name in the keep-alive set+keepAlive name+  = do { env <- getGblEnv+       ; traceRn "keep alive" (ppr name)+       ; updTcRef (tcg_keep env) (`extendNameSet` name) }++getStage :: TcM ThStage+getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }++getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))+getStageAndBindLevel name+  = do { env <- getLclEnv;+       ; case lookupNameEnv (tcl_th_bndrs env) name of+           Nothing                  -> return Nothing+           Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) }++setStage :: ThStage -> TcM a -> TcRn a+setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })++-- | Adds the given modFinalizers to the global environment and set them to use+-- the current local environment.+addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()+addModFinalizersWithLclEnv mod_finalizers+  = do lcl_env <- getLclEnv+       th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv+       updTcRef th_modfinalizers_var $ \fins ->+         setLclEnv lcl_env (runRemoteModFinalizers mod_finalizers)+         : fins++{-+************************************************************************+*                                                                      *+             Safe Haskell context+*                                                                      *+************************************************************************+-}++-- | Mark that safe inference has failed+-- See Note [Safe Haskell Overlapping Instances Implementation]+-- although this is used for more than just that failure case.+recordUnsafeInfer :: WarningMessages -> TcM ()+recordUnsafeInfer warns =+    getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns)++-- | Figure out the final correct safe haskell mode+finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode+finalSafeMode dflags tcg_env = do+    safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env)+    return $ case safeHaskell dflags of+        Sf_None | safeInferOn dflags && safeInf -> Sf_Safe+                | otherwise                     -> Sf_None+        s -> s++-- | Switch instances to safe instances if we're in Safe mode.+fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst]+fixSafeInstances sfMode | sfMode /= Sf_Safe = id+fixSafeInstances _ = map fixSafe+  where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True }+                       in inst { is_flag = new_flag }++{-+************************************************************************+*                                                                      *+             Stuff for the renamer's local env+*                                                                      *+************************************************************************+-}++getLocalRdrEnv :: RnM LocalRdrEnv+getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }++setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a+setLocalRdrEnv rdr_env thing_inside+  = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside++{-+************************************************************************+*                                                                      *+             Stuff for interface decls+*                                                                      *+************************************************************************+-}++mkIfLclEnv :: Module -> SDoc -> Bool -> IfLclEnv+mkIfLclEnv mod loc boot+                   = IfLclEnv { if_mod     = mod,+                                if_loc     = loc,+                                if_boot    = boot,+                                if_nsubst  = Nothing,+                                if_implicits_env = Nothing,+                                if_tv_env  = emptyFsEnv,+                                if_id_env  = emptyFsEnv }++-- | Run an 'IfG' (top-level interface monad) computation inside an existing+-- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv'+-- based on 'TcGblEnv'.+initIfaceTcRn :: IfG a -> TcRn a+initIfaceTcRn thing_inside+  = do  { tcg_env <- getGblEnv+        ; dflags <- getDynFlags+        ; let mod = tcg_semantic_mod tcg_env+              -- When we are instantiating a signature, we DEFINITELY+              -- do not want to knot tie.+              is_instantiate = unitIdIsDefinite (thisPackage dflags) &&+                               not (null (thisUnitIdInsts dflags))+        ; let { if_env = IfGblEnv {+                            if_doc = text "initIfaceTcRn",+                            if_rec_types =+                                if is_instantiate+                                    then Nothing+                                    else Just (mod, get_type_env)+                         }+              ; get_type_env = readTcRef (tcg_type_env_var tcg_env) }+        ; setEnvs (if_env, ()) thing_inside }++-- Used when sucking in a ModIface into a ModDetails to put in+-- the HPT.  Notably, unlike initIfaceCheck, this does NOT use+-- hsc_type_env_var (since we're not actually going to typecheck,+-- so this variable will never get updated!)+initIfaceLoad :: HscEnv -> IfG a -> IO a+initIfaceLoad hsc_env do_this+ = do let gbl_env = IfGblEnv {+                        if_doc = text "initIfaceLoad",+                        if_rec_types = Nothing+                    }+      initTcRnIf 'i' hsc_env gbl_env () do_this++initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a+-- Used when checking the up-to-date-ness of the old Iface+-- Initialise the environment with no useful info at all+initIfaceCheck doc hsc_env do_this+ = do let rec_types = case hsc_type_env_var hsc_env of+                         Just (mod,var) -> Just (mod, readTcRef var)+                         Nothing        -> Nothing+          gbl_env = IfGblEnv {+                        if_doc = text "initIfaceCheck" <+> doc,+                        if_rec_types = rec_types+                    }+      initTcRnIf 'i' hsc_env gbl_env () do_this++initIfaceLcl :: Module -> SDoc -> Bool -> IfL a -> IfM lcl a+initIfaceLcl mod loc_doc hi_boot_file thing_inside+  = setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside++-- | Initialize interface typechecking, but with a 'NameShape'+-- to apply when typechecking top-level 'OccName's (see+-- 'lookupIfaceTop')+initIfaceLclWithSubst :: Module -> SDoc -> Bool -> NameShape -> IfL a -> IfM lcl a+initIfaceLclWithSubst mod loc_doc hi_boot_file nsubst thing_inside+  = setLclEnv ((mkIfLclEnv mod loc_doc hi_boot_file) { if_nsubst = Just nsubst }) thing_inside++getIfModule :: IfL Module+getIfModule = do { env <- getLclEnv; return (if_mod env) }++--------------------+failIfM :: MsgDoc -> IfL a+-- The Iface monad doesn't have a place to accumulate errors, so we+-- just fall over fast if one happens; it "shouldn't happen".+-- We use IfL here so that we can get context info out of the local env+failIfM msg+  = do  { env <- getLclEnv+        ; let full_msg = (if_loc env <> colon) $$ nest 2 msg+        ; dflags <- getDynFlags+        ; liftIO (putLogMsg dflags NoReason SevFatal+                   noSrcSpan (defaultErrStyle dflags) full_msg)+        ; failM }++--------------------+forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)+-- Run thing_inside in an interleaved thread.+-- It shares everything with the parent thread, so this is DANGEROUS.+--+-- It returns Nothing if the computation fails+--+-- It's used for lazily type-checking interface+-- signatures, which is pretty benign++forkM_maybe doc thing_inside+ -- NB: Don't share the mutable env_us with the interleaved thread since env_us+ --     does not get updated atomically (e.g. in newUnique and newUniqueSupply).+ = do { child_us <- newUniqueSupply+      ; child_env_us <- newMutVar child_us+        -- see Note [Masking exceptions in forkM_maybe]+      ; unsafeInterleaveM $ uninterruptibleMaskM_ $ updEnv (\env -> env { env_us = child_env_us }) $+        do { traceIf (text "Starting fork {" <+> doc)+           ; mb_res <- tryM $+                       updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $+                       thing_inside+           ; case mb_res of+                Right r  -> do  { traceIf (text "} ending fork" <+> doc)+                                ; return (Just r) }+                Left exn -> do {++                    -- Bleat about errors in the forked thread, if -ddump-if-trace is on+                    -- Otherwise we silently discard errors. Errors can legitimately+                    -- happen when compiling interface signatures (see tcInterfaceSigs)+                      whenDOptM Opt_D_dump_if_trace $ do+                          dflags <- getDynFlags+                          let msg = hang (text "forkM failed:" <+> doc)+                                       2 (text (show exn))+                          liftIO $ putLogMsg dflags+                                             NoReason+                                             SevFatal+                                             noSrcSpan+                                             (defaultErrStyle dflags)+                                             msg++                    ; traceIf (text "} ending fork (badly)" <+> doc)+                    ; return Nothing }+        }}++forkM :: SDoc -> IfL a -> IfL a+forkM doc thing_inside+ = do   { mb_res <- forkM_maybe doc thing_inside+        ; return (case mb_res of+                        Nothing -> pgmError "Cannot continue after interface file error"+                                   -- pprPanic "forkM" doc+                        Just r  -> r) }++setImplicitEnvM :: TypeEnv -> IfL a -> IfL a+setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl { if_implicits_env = Just tenv }) m++{-+Note [Masking exceptions in forkM_maybe]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When using GHC-as-API it must be possible to interrupt snippets of code+executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible+by throwing an asynchronous interrupt to the GHC thread. However, there is a+subtle problem: runStmt first typechecks the code before running it, and the+exception might interrupt the type checker rather than the code. Moreover, the+typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and+more importantly might be inside an exception handler inside that+unsafeInterleaveIO. If that is the case, the exception handler will rethrow the+asynchronous exception as a synchronous exception, and the exception will end+up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed+discussion).  We don't currently know a general solution to this problem, but+we can use uninterruptibleMask_ to avoid the situation.+-}
+ typecheck/TcRnTypes.hs view
@@ -0,0 +1,3499 @@+{-+(c) The University of Glasgow 2006-2012+(c) The GRASP Project, Glasgow University, 1992-2002+++Various types used during typechecking, please see TcRnMonad as well for+operations on these types. You probably want to import it, instead of this+module.++All the monads exported here are built on top of the same IOEnv monad. The+monad functions like a Reader monad in the way it passes the environment+around. This is done to allow the environment to be manipulated in a stack+like fashion when entering expressions... ect.++For state that is global and should be returned at the end (e.g not part+of the stack mechanism), you should use an TcRef (= IORef) to store them.+-}++{-# LANGUAGE CPP, ExistentialQuantification, GeneralizedNewtypeDeriving,+             ViewPatterns #-}++module TcRnTypes(+        TcRnIf, TcRn, TcM, RnM, IfM, IfL, IfG, -- The monad is opaque outside this module+        TcRef,++        -- The environment types+        Env(..),+        TcGblEnv(..), TcLclEnv(..),+        IfGblEnv(..), IfLclEnv(..),+        tcVisibleOrphanMods,++        -- Frontend types (shouldn't really be here)+        FrontendResult(..),++        -- Renamer types+        ErrCtxt, RecFieldEnv,+        ImportAvails(..), emptyImportAvails, plusImportAvails,+        WhereFrom(..), mkModDeps, modDepsElts,++        -- Typechecker types+        TcTypeEnv, TcIdBinderStack, TcIdBinder(..),+        TcTyThing(..), PromotionErr(..),+        IdBindingInfo(..), ClosedTypeId, RhsNames,+        IsGroupClosed(..),+        SelfBootInfo(..),+        pprTcTyThingCategory, pprPECategory, CompleteMatch(..),++        -- Desugaring types+        DsM, DsLclEnv(..), DsGblEnv(..), PArrBuiltin(..),+        DsMetaEnv, DsMetaVal(..), CompleteMatchMap,+        mkCompleteMatchMap, extendCompleteMatchMap,++        -- Template Haskell+        ThStage(..), SpliceType(..), PendingStuff(..),+        topStage, topAnnStage, topSpliceStage,+        ThLevel, impLevel, outerLevel, thLevel,+        ForeignSrcLang(..),++        -- Arrows+        ArrowCtxt(..),++        -- TcSigInfo+        TcSigFun, TcSigInfo(..), TcIdSigInfo(..),+        TcIdSigInst(..), TcPatSynInfo(..),+        isPartialSig, hasCompleteSig,++        -- Canonical constraints+        Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, pprCts,+        singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList,+        isEmptyCts, isCTyEqCan, isCFunEqCan,+        isPendingScDict, superClassesMightHelp,+        isCDictCan_Maybe, isCFunEqCan_maybe,+        isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt,+        isGivenCt, isHoleCt, isOutOfScopeCt, isExprHoleCt, isTypeHoleCt,+        isUserTypeErrorCt, getUserTypeErrorMsg,+        ctEvidence, ctLoc, setCtLoc, ctPred, ctFlavour, ctEqRel, ctOrigin,+        mkTcEqPredLikeEv,+        mkNonCanonical, mkNonCanonicalCt, mkGivens,+        ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel,+        ctEvTerm, ctEvCoercion, ctEvId,+        tyCoVarsOfCt, tyCoVarsOfCts,+        tyCoVarsOfCtList, tyCoVarsOfCtsList,++        WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,+        andWC, unionsWC, mkSimpleWC, mkImplicWC,+        addInsols, getInsolubles, insolublesOnly, addSimples, addImplics,+        tyCoVarsOfWC, dropDerivedWC, dropDerivedSimples, dropDerivedInsols,+        tyCoVarsOfWCList, trulyInsoluble,+        isDroppableDerivedLoc, insolubleImplic,+        arisesFromGivens,++        Implication(..), ImplicStatus(..), isInsolubleStatus, isSolvedStatus,+        SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth,+        bumpSubGoalDepth, subGoalDepthExceeded,+        CtLoc(..), ctLocSpan, ctLocEnv, ctLocLevel, ctLocOrigin,+        ctLocTypeOrKind_maybe,+        ctLocDepth, bumpCtLocDepth,+        setCtLocOrigin, setCtLocEnv, setCtLocSpan,+        CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin,+        ErrorThing(..), mkErrorThing, errorThingNumArgs_maybe,+        TypeOrKind(..), isTypeLevel, isKindLevel,+        pprCtOrigin, pprCtLoc,+        pushErrCtxt, pushErrCtxtSameOrigin,++        SkolemInfo(..), pprSigSkolInfo, pprSkolInfo,+        termEvidenceAllowed,++        CtEvidence(..), TcEvDest(..),+        mkGivenLoc, mkKindLoc, toKindLoc,+        isWanted, isGiven, isDerived, isGivenOrWDeriv,+        ctEvRole,++        -- Constraint solver plugins+        TcPlugin(..), TcPluginResult(..), TcPluginSolver,+        TcPluginM, runTcPluginM, unsafeTcPluginTcM,+        getEvBindsTcPluginM,++        CtFlavour(..), ShadowInfo(..), ctEvFlavour,+        CtFlavourRole, ctEvFlavourRole, ctFlavourRole,+        eqCanRewriteFR, eqMayRewriteFR,+        eqCanDischarge,+        funEqCanDischarge, funEqCanDischargeF,++        -- Pretty printing+        pprEvVarTheta,+        pprEvVars, pprEvVarWithType,++        -- Misc other types+        TcId, TcIdSet,+        Hole(..), holeOcc,+        NameShape(..)++  ) where++#include "HsVersions.h"++import HsSyn+import CoreSyn+import HscTypes+import TcEvidence+import Type+import Class    ( Class )+import TyCon    ( TyCon, tyConKind )+import Coercion ( Coercion, mkHoleCo )+import ConLike  ( ConLike(..) )+import DataCon  ( DataCon, dataConUserType, dataConOrigArgTys )+import PatSyn   ( PatSyn, pprPatSynType )+import Id       ( idType, idName )+import FieldLabel ( FieldLabel )+import TcType+import Annotations+import InstEnv+import FamInstEnv+import PmExpr+import IOEnv+import RdrName+import Name+import NameEnv+import NameSet+import Avail+import Var+import FV+import VarEnv+import Module+import SrcLoc+import VarSet+import ErrUtils+import UniqFM+import UniqSupply+import BasicTypes+import Bag+import DynFlags+import Outputable+import ListSetOps+import FastString+import qualified GHC.LanguageExtensions as LangExt+import Fingerprint+import Util++import Control.Monad (ap, liftM, msum)+#if __GLASGOW_HASKELL__ > 710+import qualified Control.Monad.Fail as MonadFail+#endif+import Data.Set      ( Set )+import qualified Data.Set as S++import Data.List ( sort )+import Data.Map ( Map )+import Data.Dynamic  ( Dynamic )+import Data.Typeable ( TypeRep )+import GHCi.Message+import GHCi.RemoteTypes++import qualified Language.Haskell.TH as TH++-- | A 'NameShape' is a substitution on 'Name's that can be used+-- to refine the identities of a hole while we are renaming interfaces+-- (see 'RnModIface').  Specifically, a 'NameShape' for+-- 'ns_module_name' @A@, defines a mapping from @{A.T}@+-- (for some 'OccName' @T@) to some arbitrary other 'Name'.+--+-- The most intruiging thing about a 'NameShape', however, is+-- how it's constructed.  A 'NameShape' is *implied* by the+-- exported 'AvailInfo's of the implementor of an interface:+-- if an implementor of signature @<H>@ exports @M.T@, you implicitly+-- define a substitution from @{H.T}@ to @M.T@.  So a 'NameShape'+-- is computed from the list of 'AvailInfo's that are exported+-- by the implementation of a module, or successively merged+-- together by the export lists of signatures which are joining+-- together.+--+-- It's not the most obvious way to go about doing this, but it+-- does seem to work!+--+-- NB: Can't boot this and put it in NameShape because then we+-- start pulling in too many DynFlags things.+data NameShape = NameShape {+        ns_mod_name :: ModuleName,+        ns_exports :: [AvailInfo],+        ns_map :: OccEnv Name+    }+++{-+************************************************************************+*                                                                      *+               Standard monad definition for TcRn+    All the combinators for the monad can be found in TcRnMonad+*                                                                      *+************************************************************************++The monad itself has to be defined here, because it is mentioned by ErrCtxt+-}++type TcRnIf a b = IOEnv (Env a b)+type TcRn       = TcRnIf TcGblEnv TcLclEnv    -- Type inference+type IfM lcl    = TcRnIf IfGblEnv lcl         -- Iface stuff+type IfG        = IfM ()                      --    Top level+type IfL        = IfM IfLclEnv                --    Nested+type DsM        = TcRnIf DsGblEnv DsLclEnv    -- Desugaring++-- TcRn is the type-checking and renaming monad: the main monad that+-- most type-checking takes place in.  The global environment is+-- 'TcGblEnv', which tracks all of the top-level type-checking+-- information we've accumulated while checking a module, while the+-- local environment is 'TcLclEnv', which tracks local information as+-- we move inside expressions.++-- | Historical "renaming monad" (now it's just 'TcRn').+type RnM  = TcRn++-- | Historical "type-checking monad" (now it's just 'TcRn').+type TcM  = TcRn++-- We 'stack' these envs through the Reader like monad infrastructure+-- as we move into an expression (although the change is focused in+-- the lcl type).+data Env gbl lcl+  = Env {+        env_top  :: HscEnv,  -- Top-level stuff that never changes+                             -- Includes all info about imported things++        env_us   :: {-# UNPACK #-} !(IORef UniqSupply),+                             -- Unique supply for local variables++        env_gbl  :: gbl,     -- Info about things defined at the top level+                             -- of the module being compiled++        env_lcl  :: lcl      -- Nested stuff; changes as we go into+    }++instance ContainsDynFlags (Env gbl lcl) where+    extractDynFlags env = hsc_dflags (env_top env)++instance ContainsModule gbl => ContainsModule (Env gbl lcl) where+    extractModule env = extractModule (env_gbl env)+++{-+************************************************************************+*                                                                      *+                The interface environments+              Used when dealing with IfaceDecls+*                                                                      *+************************************************************************+-}++data IfGblEnv+  = IfGblEnv {+        -- Some information about where this environment came from;+        -- useful for debugging.+        if_doc :: SDoc,+        -- The type environment for the module being compiled,+        -- in case the interface refers back to it via a reference that+        -- was originally a hi-boot file.+        -- We need the module name so we can test when it's appropriate+        -- to look in this env.+        -- See Note [Tying the knot] in TcIface+        if_rec_types :: Maybe (Module, IfG TypeEnv)+                -- Allows a read effect, so it can be in a mutable+                -- variable; c.f. handling the external package type env+                -- Nothing => interactive stuff, no loops possible+    }++data IfLclEnv+  = IfLclEnv {+        -- The module for the current IfaceDecl+        -- So if we see   f = \x -> x+        -- it means M.f = \x -> x, where M is the if_mod+        -- NB: This is a semantic module, see+        -- Note [Identity versus semantic module]+        if_mod :: Module,++        -- Whether or not the IfaceDecl came from a boot+        -- file or not; we'll use this to choose between+        -- NoUnfolding and BootUnfolding+        if_boot :: Bool,++        -- The field is used only for error reporting+        -- if (say) there's a Lint error in it+        if_loc :: SDoc,+                -- Where the interface came from:+                --      .hi file, or GHCi state, or ext core+                -- plus which bit is currently being examined++        if_nsubst :: Maybe NameShape,++        -- This field is used to make sure "implicit" declarations+        -- (anything that cannot be exported in mi_exports) get+        -- wired up correctly in typecheckIfacesForMerging.  Most+        -- of the time it's @Nothing@.  See Note [Resolving never-exported Names in TcIface]+        -- in TcIface.+        if_implicits_env :: Maybe TypeEnv,++        if_tv_env  :: FastStringEnv TyVar,     -- Nested tyvar bindings+        if_id_env  :: FastStringEnv Id         -- Nested id binding+    }++{-+************************************************************************+*                                                                      *+                Desugarer monad+*                                                                      *+************************************************************************++Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around+a @UniqueSupply@ and some annotations, which+presumably include source-file location information:+-}++-- If '-XParallelArrays' is given, the desugarer populates this table with the corresponding+-- variables found in 'Data.Array.Parallel'.+--+data PArrBuiltin+        = PArrBuiltin+        { lengthPVar         :: Var     -- ^ lengthP+        , replicatePVar      :: Var     -- ^ replicateP+        , singletonPVar      :: Var     -- ^ singletonP+        , mapPVar            :: Var     -- ^ mapP+        , filterPVar         :: Var     -- ^ filterP+        , zipPVar            :: Var     -- ^ zipP+        , crossMapPVar       :: Var     -- ^ crossMapP+        , indexPVar          :: Var     -- ^ (!:)+        , emptyPVar          :: Var     -- ^ emptyP+        , appPVar            :: Var     -- ^ (+:+)+        , enumFromToPVar     :: Var     -- ^ enumFromToP+        , enumFromThenToPVar :: Var     -- ^ enumFromThenToP+        }++data DsGblEnv+        = DsGblEnv+        { ds_mod          :: Module             -- For SCC profiling+        , ds_fam_inst_env :: FamInstEnv         -- Like tcg_fam_inst_env+        , ds_unqual  :: PrintUnqualified+        , ds_msgs    :: IORef Messages          -- Warning messages+        , ds_if_env  :: (IfGblEnv, IfLclEnv)    -- Used for looking up global,+                                                -- possibly-imported things+        , ds_dph_env :: GlobalRdrEnv            -- exported entities of 'Data.Array.Parallel.Prim'+                                                -- iff '-fvectorise' flag was given as well as+                                                -- exported entities of 'Data.Array.Parallel' iff+                                                -- '-XParallelArrays' was given; otherwise, empty+        , ds_parr_bi :: PArrBuiltin             -- desugarar names for '-XParallelArrays'+        , ds_complete_matches :: CompleteMatchMap+           -- Additional complete pattern matches+        }++instance ContainsModule DsGblEnv where+    extractModule = ds_mod++data DsLclEnv = DsLclEnv {+        dsl_meta    :: DsMetaEnv,        -- Template Haskell bindings+        dsl_loc     :: RealSrcSpan,      -- To put in pattern-matching error msgs+        dsl_dicts   :: Bag EvVar,        -- Constraints from GADT pattern-matching+        dsl_tm_cs   :: Bag SimpleEq,+        dsl_pm_iter :: IORef Int         -- no iterations for pmcheck+     }++-- Inside [| |] brackets, the desugarer looks+-- up variables in the DsMetaEnv+type DsMetaEnv = NameEnv DsMetaVal++data DsMetaVal+   = DsBound Id         -- Bound by a pattern inside the [| |].+                        -- Will be dynamically alpha renamed.+                        -- The Id has type THSyntax.Var++   | DsSplice (HsExpr Id) -- These bindings are introduced by+                          -- the PendingSplices on a HsBracketOut+++{-+************************************************************************+*                                                                      *+                Global typechecker environment+*                                                                      *+************************************************************************+-}++-- | 'FrontendResult' describes the result of running the+-- frontend of a Haskell module.  Usually, you'll get+-- a 'FrontendTypecheck', since running the frontend involves+-- typechecking a program, but for an hs-boot merge you'll+-- just get a ModIface, since no actual typechecking occurred.+--+-- This data type really should be in HscTypes, but it needs+-- to have a TcGblEnv which is only defined here.+data FrontendResult+        = FrontendTypecheck TcGblEnv++-- Note [Identity versus semantic module]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- When typechecking an hsig file, it is convenient to keep track+-- of two different "this module" identifiers:+--+--      - The IDENTITY module is simply thisPackage + the module+--        name; i.e. it uniquely *identifies* the interface file+--        we're compiling.  For example, p[A=<A>]:A is an+--        identity module identifying the requirement named A+--        from library p.+--+--      - The SEMANTIC module, which is the actual module that+--        this signature is intended to represent (e.g. if+--        we have a identity module p[A=base:Data.IORef]:A,+--        then the semantic module is base:Data.IORef)+--+-- Which one should you use?+--+--      - In the desugarer and later phases of compilation,+--        identity and semantic modules coincide, since we never compile+--        signatures (we just generate blank object files for+--        hsig files.)+--+--        A corrolary of this is that the following invariant holds at any point+--        past desugaring,+--+--            if I have a Module, this_mod, in hand representing the module+--            currently being compiled,+--            then moduleUnitId this_mod == thisPackage dflags+--+--      - For any code involving Names, we want semantic modules.+--        See lookupIfaceTop in IfaceEnv, mkIface and addFingerprints+--        in MkIface, and tcLookupGlobal in TcEnv+--+--      - When reading interfaces, we want the identity module to+--        identify the specific interface we want (such interfaces+--        should never be loaded into the EPS).  However, if a+--        hole module <A> is requested, we look for A.hi+--        in the home library we are compiling.  (See LoadIface.)+--        Similarly, in RnNames we check for self-imports using+--        identity modules, to allow signatures to import their implementor.+--+--      - For recompilation avoidance, you want the identity module,+--        since that will actually say the specific interface you+--        want to track (and recompile if it changes)++-- | 'TcGblEnv' describes the top-level of the module at the+-- point at which the typechecker is finished work.+-- It is this structure that is handed on to the desugarer+-- For state that needs to be updated during the typechecking+-- phase and returned at end, use a 'TcRef' (= 'IORef').+data TcGblEnv+  = TcGblEnv {+        tcg_mod     :: Module,         -- ^ Module being compiled+        tcg_semantic_mod :: Module,    -- ^ If a signature, the backing module+            -- See also Note [Identity versus semantic module]+        tcg_src     :: HscSource,+          -- ^ What kind of module (regular Haskell, hs-boot, hsig)++        tcg_rdr_env :: GlobalRdrEnv,   -- ^ Top level envt; used during renaming+        tcg_default :: Maybe [Type],+          -- ^ Types used for defaulting. @Nothing@ => no @default@ decl++        tcg_fix_env   :: FixityEnv,     -- ^ Just for things in this module+        tcg_field_env :: RecFieldEnv,   -- ^ Just for things in this module+                                        -- See Note [The interactive package] in HscTypes++        tcg_type_env :: TypeEnv,+          -- ^ Global type env for the module we are compiling now.  All+          -- TyCons and Classes (for this module) end up in here right away,+          -- along with their derived constructors, selectors.+          --+          -- (Ids defined in this module start in the local envt, though they+          --  move to the global envt during zonking)+          --+          -- NB: for what "things in this module" means, see+          -- Note [The interactive package] in HscTypes++        tcg_type_env_var :: TcRef TypeEnv,+                -- Used only to initialise the interface-file+                -- typechecker in initIfaceTcRn, so that it can see stuff+                -- bound in this module when dealing with hi-boot recursions+                -- Updated at intervals (e.g. after dealing with types and classes)++        tcg_inst_env     :: InstEnv,+          -- ^ Instance envt for all /home-package/ modules;+          -- Includes the dfuns in tcg_insts+        tcg_fam_inst_env :: FamInstEnv, -- ^ Ditto for family instances+        tcg_ann_env      :: AnnEnv,     -- ^ And for annotations++        -- | Family instances we have to check for consistency.+        -- Invariant: each FamInst in the list's fi_fam matches the+        -- key of the entry in the 'NameEnv'.  This gets consumed+        -- by 'checkRecFamInstConsistency'.+        -- See Note [Don't check hs-boot type family instances too early]+        tcg_pending_fam_checks :: NameEnv [([FamInst], FamInstEnv)],++                -- Now a bunch of things about this module that are simply+                -- accumulated, but never consulted until the end.+                -- Nevertheless, it's convenient to accumulate them along+                -- with the rest of the info from this module.+        tcg_exports :: [AvailInfo],     -- ^ What is exported+        tcg_imports :: ImportAvails,+          -- ^ Information about what was imported from where, including+          -- things bound in this module. Also store Safe Haskell info+          -- here about transative trusted packaage requirements.++        tcg_dus       :: DefUses,   -- ^ What is defined in this module and what is used.+        tcg_used_gres :: TcRef [GlobalRdrElt],  -- ^ Records occurrences of imported entities+          -- See Note [Tracking unused binding and imports]++        tcg_keep :: TcRef NameSet,+          -- ^ Locally-defined top-level names to keep alive.+          --+          -- "Keep alive" means give them an Exported flag, so that the+          -- simplifier does not discard them as dead code, and so that they+          -- are exposed in the interface file (but not to export to the+          -- user).+          --+          -- Some things, like dict-fun Ids and default-method Ids are "born"+          -- with the Exported flag on, for exactly the above reason, but some+          -- we only discover as we go.  Specifically:+          --+          --   * The to/from functions for generic data types+          --+          --   * Top-level variables appearing free in the RHS of an orphan+          --     rule+          --+          --   * Top-level variables appearing free in a TH bracket++        tcg_th_used :: TcRef Bool,+          -- ^ @True@ <=> Template Haskell syntax used.+          --+          -- We need this so that we can generate a dependency on the+          -- Template Haskell package, because the desugarer is going+          -- to emit loads of references to TH symbols.  The reference+          -- is implicit rather than explicit, so we have to zap a+          -- mutable variable.++        tcg_th_splice_used :: TcRef Bool,+          -- ^ @True@ <=> A Template Haskell splice was used.+          --+          -- Splices disable recompilation avoidance (see #481)++        tcg_th_top_level_locs :: TcRef (Set RealSrcSpan),+          -- ^ Locations of the top-level splices; used for providing details on+          -- scope in error messages for out-of-scope variables++        tcg_dfun_n  :: TcRef OccSet,+          -- ^ Allows us to choose unique DFun names.++        tcg_merged :: [(Module, Fingerprint)],+          -- ^ The requirements we merged with; we always have to recompile+          -- if any of these changed.++        -- The next fields accumulate the payload of the module+        -- The binds, rules and foreign-decl fields are collected+        -- initially in un-zonked form and are finally zonked in tcRnSrcDecls++        tcg_rn_exports :: Maybe [Located (IE Name)],+                -- Nothing <=> no explicit export list+                -- Is always Nothing if we don't want to retain renamed+                -- exports++        tcg_rn_imports :: [LImportDecl Name],+                -- Keep the renamed imports regardless.  They are not+                -- voluminous and are needed if you want to report unused imports++        tcg_rn_decls :: Maybe (HsGroup Name),+          -- ^ Renamed decls, maybe.  @Nothing@ <=> Don't retain renamed+          -- decls.++        tcg_dependent_files :: TcRef [FilePath], -- ^ dependencies from addDependentFile++        tcg_th_topdecls :: TcRef [LHsDecl RdrName],+        -- ^ Top-level declarations from addTopDecls++        tcg_th_foreign_files :: TcRef [(ForeignSrcLang, String)],+        -- ^ Foreign files emitted from TH.++        tcg_th_topnames :: TcRef NameSet,+        -- ^ Exact names bound in top-level declarations in tcg_th_topdecls++        tcg_th_modfinalizers :: TcRef [TcM ()],+        -- ^ Template Haskell module finalizers.+        --+        -- They are computations in the @TcM@ monad rather than @Q@ because we+        -- set them to use particular local environments.++        tcg_th_state :: TcRef (Map TypeRep Dynamic),+        tcg_th_remote_state :: TcRef (Maybe (ForeignRef (IORef QState))),+        -- ^ Template Haskell state++        tcg_ev_binds  :: Bag EvBind,        -- Top-level evidence bindings++        -- Things defined in this module, or (in GHCi)+        -- in the declarations for a single GHCi command.+        -- For the latter, see Note [The interactive package] in HscTypes+        tcg_tr_module :: Maybe Id,           -- Id for $trModule :: GHC.Types.Module+                                             -- for which every module has a top-level defn+                                             -- except in GHCi in which case we have Nothing+        tcg_binds     :: LHsBinds Id,        -- Value bindings in this module+        tcg_sigs      :: NameSet,            -- ...Top-level names that *lack* a signature+        tcg_imp_specs :: [LTcSpecPrag],      -- ...SPECIALISE prags for imported Ids+        tcg_warns     :: Warnings,           -- ...Warnings and deprecations+        tcg_anns      :: [Annotation],       -- ...Annotations+        tcg_tcs       :: [TyCon],            -- ...TyCons and Classes+        tcg_insts     :: [ClsInst],          -- ...Instances+        tcg_fam_insts :: [FamInst],          -- ...Family instances+        tcg_rules     :: [LRuleDecl Id],     -- ...Rules+        tcg_fords     :: [LForeignDecl Id],  -- ...Foreign import & exports+        tcg_vects     :: [LVectDecl Id],     -- ...Vectorisation declarations+        tcg_patsyns   :: [PatSyn],           -- ...Pattern synonyms++        tcg_doc_hdr   :: Maybe LHsDocString, -- ^ Maybe Haddock header docs+        tcg_hpc       :: AnyHpcUsage,        -- ^ @True@ if any part of the+                                             --  prog uses hpc instrumentation.++        tcg_self_boot :: SelfBootInfo,       -- ^ Whether this module has a+                                             -- corresponding hi-boot file++        tcg_main      :: Maybe Name,         -- ^ The Name of the main+                                             -- function, if this module is+                                             -- the main module.++        tcg_safeInfer :: TcRef (Bool, WarningMessages),+        -- ^ Has the typechecker inferred this module as -XSafe (Safe Haskell)+        -- See Note [Safe Haskell Overlapping Instances Implementation],+        -- although this is used for more than just that failure case.++        tcg_tc_plugins :: [TcPluginSolver],+        -- ^ A list of user-defined plugins for the constraint solver.++        tcg_top_loc :: RealSrcSpan,+        -- ^ The RealSrcSpan this module came from++        tcg_static_wc :: TcRef WantedConstraints,+          -- ^ Wanted constraints of static forms.+        -- See Note [Constraints in static forms].+        tcg_complete_matches :: [CompleteMatch]+    }++-- NB: topModIdentity, not topModSemantic!+-- Definition sites of orphan identities will be identity modules, not semantic+-- modules.++-- Note [Constraints in static forms]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- When a static form produces constraints like+--+-- f :: StaticPtr (Bool -> String)+-- f = static show+--+-- we collect them in tcg_static_wc and resolve them at the end+-- of type checking. They need to be resolved separately because+-- we don't want to resolve them in the context of the enclosing+-- expression. Consider+--+-- g :: Show a => StaticPtr (a -> String)+-- g = static show+--+-- If the @Show a0@ constraint that the body of the static form produces was+-- resolved in the context of the enclosing expression, then the body of the+-- static form wouldn't be closed because the Show dictionary would come from+-- g's context instead of coming from the top level.++tcVisibleOrphanMods :: TcGblEnv -> ModuleSet+tcVisibleOrphanMods tcg_env+    = mkModuleSet (tcg_mod tcg_env : imp_orphs (tcg_imports tcg_env))++instance ContainsModule TcGblEnv where+    extractModule env = tcg_semantic_mod env++type RecFieldEnv = NameEnv [FieldLabel]+        -- Maps a constructor name *in this module*+        -- to the fields for that constructor.+        -- This is used when dealing with ".." notation in record+        -- construction and pattern matching.+        -- The FieldEnv deals *only* with constructors defined in *this*+        -- module.  For imported modules, we get the same info from the+        -- TypeEnv++data SelfBootInfo+  = NoSelfBoot    -- No corresponding hi-boot file+  | SelfBoot+       { sb_mds :: ModDetails   -- There was a hi-boot file,+       , sb_tcs :: NameSet }    -- defining these TyCons,+-- What is sb_tcs used for?  See Note [Extra dependencies from .hs-boot files]+-- in RnSource+++{- Note [Tracking unused binding and imports]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We gather two sorts of usage information++ * tcg_dus (defs/uses)+      Records *defined* Names (local, top-level)+          and *used*    Names (local or imported)++      Used (a) to report "defined but not used"+               (see RnNames.reportUnusedNames)+           (b) to generate version-tracking usage info in interface+               files (see MkIface.mkUsedNames)+   This usage info is mainly gathered by the renamer's+   gathering of free-variables++ * tcg_used_gres+      Used only to report unused import declarations++      Records each *occurrence* an *imported* (not locally-defined) entity.+      The occurrence is recorded by keeping a GlobalRdrElt for it.+      These is not the GRE that is in the GlobalRdrEnv; rather it+      is recorded *after* the filtering done by pickGREs.  So it reflect+      /how that occurrence is in scope/.   See Note [GRE filtering] in+      RdrName.+++************************************************************************+*                                                                      *+                The local typechecker environment+*                                                                      *+************************************************************************++Note [The Global-Env/Local-Env story]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+During type checking, we keep in the tcg_type_env+        * All types and classes+        * All Ids derived from types and classes (constructors, selectors)++At the end of type checking, we zonk the local bindings,+and as we do so we add to the tcg_type_env+        * Locally defined top-level Ids++Why?  Because they are now Ids not TcIds.  This final GlobalEnv is+        a) fed back (via the knot) to typechecking the+           unfoldings of interface signatures+        b) used in the ModDetails of this module+-}++data TcLclEnv           -- Changes as we move inside an expression+                        -- Discarded after typecheck/rename; not passed on to desugarer+  = TcLclEnv {+        tcl_loc        :: RealSrcSpan,     -- Source span+        tcl_ctxt       :: [ErrCtxt],       -- Error context, innermost on top+        tcl_tclvl      :: TcLevel,         -- Birthplace for new unification variables++        tcl_th_ctxt    :: ThStage,         -- Template Haskell context+        tcl_th_bndrs   :: ThBindEnv,       -- and binder info+            -- The ThBindEnv records the TH binding level of in-scope Names+            -- defined in this module (not imported)+            -- We can't put this info in the TypeEnv because it's needed+            -- (and extended) in the renamer, for untyed splices++        tcl_arrow_ctxt :: ArrowCtxt,       -- Arrow-notation context++        tcl_rdr :: LocalRdrEnv,         -- Local name envt+                -- Maintained during renaming, of course, but also during+                -- type checking, solely so that when renaming a Template-Haskell+                -- splice we have the right environment for the renamer.+                --+                --   Does *not* include global name envt; may shadow it+                --   Includes both ordinary variables and type variables;+                --   they are kept distinct because tyvar have a different+                --   occurrence constructor (Name.TvOcc)+                -- We still need the unsullied global name env so that+                --   we can look up record field names++        tcl_env  :: TcTypeEnv,    -- The local type environment:+                                  -- Ids and TyVars defined in this module++        tcl_bndrs :: TcIdBinderStack,   -- Used for reporting relevant bindings++        tcl_tidy :: TidyEnv,      -- Used for tidying types; contains all+                                  -- in-scope type variables (but not term variables)++        tcl_tyvars :: TcRef TcTyVarSet, -- The "global tyvars"+                        -- Namely, the in-scope TyVars bound in tcl_env,+                        -- plus the tyvars mentioned in the types of Ids bound+                        -- in tcl_lenv.+                        -- Why mutable? see notes with tcGetGlobalTyCoVars++        tcl_lie  :: TcRef WantedConstraints,    -- Place to accumulate type constraints+        tcl_errs :: TcRef Messages              -- Place to accumulate errors+    }++type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc))+        -- Monadic so that we have a chance+        -- to deal with bound type variables just before error+        -- message construction++        -- Bool:  True <=> this is a landmark context; do not+        --                 discard it when trimming for display++type TcTypeEnv = NameEnv TcTyThing++type ThBindEnv = NameEnv (TopLevelFlag, ThLevel)+   -- Domain = all Ids bound in this module (ie not imported)+   -- The TopLevelFlag tells if the binding is syntactically top level.+   -- We need to know this, because the cross-stage persistence story allows+   -- cross-stage at arbitrary types if the Id is bound at top level.+   --+   -- Nota bene: a ThLevel of 'outerLevel' is *not* the same as being+   -- bound at top level!  See Note [Template Haskell levels] in TcSplice++{- Note [Given Insts]+   ~~~~~~~~~~~~~~~~~~+Because of GADTs, we have to pass inwards the Insts provided by type signatures+and existential contexts. Consider+        data T a where { T1 :: b -> b -> T [b] }+        f :: Eq a => T a -> Bool+        f (T1 x y) = [x]==[y]++The constructor T1 binds an existential variable 'b', and we need Eq [b].+Well, we have it, because Eq a refines to Eq [b], but we can only spot that if we+pass it inwards.++-}++-- | Type alias for 'IORef'; the convention is we'll use this for mutable+-- bits of data in 'TcGblEnv' which are updated during typechecking and+-- returned at the end.+type TcRef a     = IORef a+-- ToDo: when should I refer to it as a 'TcId' instead of an 'Id'?+type TcId        = Id+type TcIdSet     = IdSet++---------------------------+-- The TcIdBinderStack+---------------------------++type TcIdBinderStack = [TcIdBinder]+   -- This is a stack of locally-bound ids, innermost on top+   -- Used ony in error reporting (relevantBindings in TcError)+   -- We can't use the tcl_env type environment, because it doesn't+   --   keep track of the nesting order++data TcIdBinder+  = TcIdBndr+       TcId+       TopLevelFlag    -- Tells whether the binding is syntactically top-level+                       -- (The monomorphic Ids for a recursive group count+                       --  as not-top-level for this purpose.)+  | TcIdBndr_ExpType  -- Variant that allows the type to be specified as+                      -- an ExpType+       Name+       ExpType+       TopLevelFlag++instance Outputable TcIdBinder where+   ppr (TcIdBndr id top_lvl)           = ppr id <> brackets (ppr top_lvl)+   ppr (TcIdBndr_ExpType id _ top_lvl) = ppr id <> brackets (ppr top_lvl)++instance HasOccName TcIdBinder where+    occName (TcIdBndr id _) = (occName (idName id))+    occName (TcIdBndr_ExpType name _ _) = (occName name)++---------------------------+-- Template Haskell stages and levels+---------------------------++data SpliceType = Typed | Untyped++data ThStage    -- See Note [Template Haskell state diagram] in TcSplice+  = Splice SpliceType -- Inside a top-level splice+                      -- This code will be run *at compile time*;+                      --   the result replaces the splice+                      -- Binding level = 0++  | RunSplice (TcRef [ForeignRef (TH.Q ())])+      -- Set when running a splice, i.e. NOT when renaming or typechecking the+      -- Haskell code for the splice. See Note [RunSplice ThLevel].+      --+      -- Contains a list of mod finalizers collected while executing the splice.+      --+      -- 'addModFinalizer' inserts finalizers here, and from here they are taken+      -- to construct an @HsSpliced@ annotation for untyped splices. See Note+      -- [Delaying modFinalizers in untyped splices] in "RnSplice".+      --+      -- For typed splices, the typechecker takes finalizers from here and+      -- inserts them in the list of finalizers in the global environment.+      --+      -- See Note [Collecting modFinalizers in typed splices] in "TcSplice".++  | Comp        -- Ordinary Haskell code+                -- Binding level = 1++  | Brack                       -- Inside brackets+      ThStage                   --   Enclosing stage+      PendingStuff++data PendingStuff+  = RnPendingUntyped              -- Renaming the inside of an *untyped* bracket+      (TcRef [PendingRnSplice])   -- Pending splices in here++  | RnPendingTyped                -- Renaming the inside of a *typed* bracket++  | TcPending                     -- Typechecking the inside of a typed bracket+      (TcRef [PendingTcSplice])   --   Accumulate pending splices here+      (TcRef WantedConstraints)   --     and type constraints here++topStage, topAnnStage, topSpliceStage :: ThStage+topStage       = Comp+topAnnStage    = Splice Untyped+topSpliceStage = Splice Untyped++instance Outputable ThStage where+   ppr (Splice _)    = text "Splice"+   ppr (RunSplice _) = text "RunSplice"+   ppr Comp          = text "Comp"+   ppr (Brack s _)   = text "Brack" <> parens (ppr s)++type ThLevel = Int+    -- NB: see Note [Template Haskell levels] in TcSplice+    -- Incremented when going inside a bracket,+    -- decremented when going inside a splice+    -- NB: ThLevel is one greater than the 'n' in Fig 2 of the+    --     original "Template meta-programming for Haskell" paper++impLevel, outerLevel :: ThLevel+impLevel = 0    -- Imported things; they can be used inside a top level splice+outerLevel = 1  -- Things defined outside brackets++thLevel :: ThStage -> ThLevel+thLevel (Splice _)    = 0+thLevel (RunSplice _) =+    -- See Note [RunSplice ThLevel].+    panic "thLevel: called when running a splice"+thLevel Comp          = 1+thLevel (Brack s _)   = thLevel s + 1++{- Node [RunSplice ThLevel]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The 'RunSplice' stage is set when executing a splice, and only when running a+splice. In particular it is not set when the splice is renamed or typechecked.++'RunSplice' is needed to provide a reference where 'addModFinalizer' can insert+the finalizer (see Note [Delaying modFinalizers in untyped splices]), and+'addModFinalizer' runs when doing Q things. Therefore, It doesn't make sense to+set 'RunSplice' when renaming or typechecking the splice, where 'Splice', 'Brak'+or 'Comp' are used instead.++-}++---------------------------+-- Arrow-notation context+---------------------------++{- Note [Escaping the arrow scope]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In arrow notation, a variable bound by a proc (or enclosed let/kappa)+is not in scope to the left of an arrow tail (-<) or the head of (|..|).+For example++        proc x -> (e1 -< e2)++Here, x is not in scope in e1, but it is in scope in e2.  This can get+a bit complicated:++        let x = 3 in+        proc y -> (proc z -> e1) -< e2++Here, x and z are in scope in e1, but y is not.++We implement this by+recording the environment when passing a proc (using newArrowScope),+and returning to that (using escapeArrowScope) on the left of -< and the+head of (|..|).++All this can be dealt with by the *renamer*. But the type checker needs+to be involved too.  Example (arrowfail001)+  class Foo a where foo :: a -> ()+  data Bar = forall a. Foo a => Bar a+  get :: Bar -> ()+  get = proc x -> case x of Bar a -> foo -< a+Here the call of 'foo' gives rise to a (Foo a) constraint that should not+be captured by the pattern match on 'Bar'.  Rather it should join the+constraints from further out.  So we must capture the constraint bag+from further out in the ArrowCtxt that we push inwards.+-}++data ArrowCtxt   -- Note [Escaping the arrow scope]+  = NoArrowCtxt+  | ArrowCtxt LocalRdrEnv (TcRef WantedConstraints)+++---------------------------+-- TcTyThing+---------------------------++-- | A typecheckable thing available in a local context.  Could be+-- 'AGlobal' 'TyThing', but also lexically scoped variables, etc.+-- See 'TcEnv' for how to retrieve a 'TyThing' given a 'Name'.+data TcTyThing+  = AGlobal TyThing             -- Used only in the return type of a lookup++  | ATcId           -- Ids defined in this module; may not be fully zonked+      { tct_id   :: TcId+      , tct_info :: IdBindingInfo   -- See Note [Meaning of IdBindingInfo]+      }++  | ATyVar  Name TcTyVar        -- The type variable to which the lexically scoped type+                                -- variable is bound. We only need the Name+                                -- for error-message purposes; it is the corresponding+                                -- Name in the domain of the envt++  | ATcTyCon TyCon   -- Used temporarily, during kind checking, for the+                     -- tycons and clases in this recursive group+                     -- The TyCon is always a TcTyCon.  Its kind+                     -- can be a mono-kind or a poly-kind; in TcTyClsDcls see+                     -- Note [Type checking recursive type and class declarations]++  | APromotionErr PromotionErr++data PromotionErr+  = TyConPE          -- TyCon used in a kind before we are ready+                     --     data T :: T -> * where ...+  | ClassPE          -- Ditto Class++  | FamDataConPE     -- Data constructor for a data family+                     -- See Note [AFamDataCon: not promoting data family constructors]+                     -- in TcEnv.+  | PatSynPE         -- Pattern synonyms+                     -- See Note [Don't promote pattern synonyms] in TcEnv++  | RecDataConPE     -- Data constructor in a recursive loop+                     -- See Note [ARecDataCon: recusion and promoting data constructors] in TcTyClsDecls+  | NoDataKindsTC    -- -XDataKinds not enabled (for a tycon)+  | NoDataKindsDC    -- -XDataKinds not enabled (for a datacon)+  | NoTypeInTypeTC   -- -XTypeInType not enabled (for a tycon)+  | NoTypeInTypeDC   -- -XTypeInType not enabled (for a datacon)++instance Outputable TcTyThing where     -- Debugging only+   ppr (AGlobal g)      = ppr g+   ppr elt@(ATcId {})   = text "Identifier" <>+                          brackets (ppr (tct_id elt) <> dcolon+                                 <> ppr (varType (tct_id elt)) <> comma+                                 <+> ppr (tct_info elt))+   ppr (ATyVar n tv)    = text "Type variable" <+> quotes (ppr n) <+> equals <+> ppr tv+   ppr (ATcTyCon tc)    = text "ATcTyCon" <+> ppr tc <+> dcolon <+> ppr (tyConKind tc)+   ppr (APromotionErr err) = text "APromotionErr" <+> ppr err++-- | IdBindingInfo describes how an Id is bound.+--+-- It is used for the following purposes:+-- a) for static forms in TcExpr.checkClosedInStaticForm and+-- b) to figure out when a nested binding can be generalised,+--    in TcBinds.decideGeneralisationPlan.+--+data IdBindingInfo -- See Note [Meaning of IdBindingInfo and ClosedTypeId]+    = NotLetBound+    | ClosedLet+    | NonClosedLet+         RhsNames        -- Used for (static e) checks only+         ClosedTypeId    -- Used for generalisation checks+                         -- and for (static e) checks++-- | IsGroupClosed describes a group of mutually-recursive bindings+data IsGroupClosed+  = IsGroupClosed+      (NameEnv RhsNames)  -- Free var info for the RHS of each binding in the goup+                          -- Used only for (static e) checks++      ClosedTypeId        -- True <=> all the free vars of the group are+                          --          imported or ClosedLet or+                          --          NonClosedLet with ClosedTypeId=True.+                          --          In particular, no tyvars, no NotLetBound++type RhsNames = NameSet   -- Names of variables, mentioned on the RHS of+                          -- a definition, that are not Global or ClosedLet++type ClosedTypeId = Bool+  -- See Note [Meaning of IdBindingInfo and ClosedTypeId]++{- Note [Meaning of IdBindingInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+NotLetBound means that+  the Id is not let-bound (e.g. it is bound in a+  lambda-abstraction or in a case pattern)++ClosedLet means that+   - The Id is let-bound,+   - Any free term variables are also Global or ClosedLet+   - Its type has no free variables (NB: a top-level binding subject+     to the MR might have free vars in its type)+   These ClosedLets can definitely be floated to top level; and we+   may need to do so for static forms.++   Property:   ClosedLet+             is equivalent to+               NonClosedLet emptyNameSet True++(NonClosedLet (fvs::RhsNames) (cl::ClosedTypeId)) means that+   - The Id is let-bound++   - The fvs::RhsNames contains the free names of the RHS,+     excluding Global and ClosedLet ones.++   - For the ClosedTypeId field see Note [Bindings with closed types]++For (static e) to be valid, we need for every 'x' free in 'e',+x's binding must be floatable to top level.  Specifically:+   * x's RhsNames must be non-empty+   * x's type has no free variables+See Note [Grand plan for static forms] in StaticPtrTable.hs.+This test is made in TcExpr.checkClosedInStaticForm.+Actually knowing x's RhsNames (rather than just its emptiness+or otherwise) is just so we can produce better error messages++Note [Bindings with closed types: ClosedTypeId]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++  f x = let g ys = map not ys+        in ...++Can we generalise 'g' under the OutsideIn algorithm?  Yes,+because all g's free variables are top-level; that is they themselves+have no free type variables, and it is the type variables in the+environment that makes things tricky for OutsideIn generalisation.++Here's the invariant:+   If an Id has ClosedTypeId=True (in its IdBindingInfo), then+   the Id's type is /definitely/ closed (has no free type variables).+   Specifically,+       a) The Id's acutal type is closed (has no free tyvars)+       b) Either the Id has a (closed) user-supplied type signature+          or all its free varaibles are Global/ClosedLet+             or NonClosedLet with ClosedTypeId=True.+          In particular, none are NotLetBound.++Why is (b) needed?   Consider+    \x. (x :: Int, let y = x+1 in ...)+Initially x::alpha.  If we happen to typecheck the 'let' before the+(x::Int), y's type will have a free tyvar; but if the other way round+it won't.  So we treat any let-bound variable with a free+non-let-bound variable as not ClosedTypeId, regardless of what the+free vars of its type actually are.++But if it has a signature, all is well:+   \x. ...(let { y::Int; y = x+1 } in+           let { v = y+2 } in ...)...+Here the signature on 'v' makes 'y' a ClosedTypeId, so we can+generalise 'v'.++Note that:++  * A top-level binding may not have ClosedTypeId=True, if it suffers+    from the MR++  * A nested binding may be closed (eg 'g' in the example we started+    with). Indeed, that's the point; whether a function is defined at+    top level or nested is orthogonal to the question of whether or+    not it is closed.++  * A binding may be non-closed because it mentions a lexically scoped+    *type variable*  Eg+        f :: forall a. blah+        f x = let g y = ...(y::a)...++Under OutsideIn we are free to generalise an Id all of whose free+variables have ClosedTypeId=True (or imported).  This is an extension+compared to the JFP paper on OutsideIn, which used "top-level" as a+proxy for "closed".  (It's not a good proxy anyway -- the MR can make+a top-level binding with a free type variable.)+-}++instance Outputable IdBindingInfo where+  ppr NotLetBound = text "NotLetBound"+  ppr ClosedLet = text "TopLevelLet"+  ppr (NonClosedLet fvs closed_type) =+    text "TopLevelLet" <+> ppr fvs <+> ppr closed_type++instance Outputable PromotionErr where+  ppr ClassPE        = text "ClassPE"+  ppr TyConPE        = text "TyConPE"+  ppr PatSynPE       = text "PatSynPE"+  ppr FamDataConPE   = text "FamDataConPE"+  ppr RecDataConPE   = text "RecDataConPE"+  ppr NoDataKindsTC  = text "NoDataKindsTC"+  ppr NoDataKindsDC  = text "NoDataKindsDC"+  ppr NoTypeInTypeTC = text "NoTypeInTypeTC"+  ppr NoTypeInTypeDC = text "NoTypeInTypeDC"++pprTcTyThingCategory :: TcTyThing -> SDoc+pprTcTyThingCategory (AGlobal thing)    = pprTyThingCategory thing+pprTcTyThingCategory (ATyVar {})        = text "Type variable"+pprTcTyThingCategory (ATcId {})         = text "Local identifier"+pprTcTyThingCategory (ATcTyCon {})     = text "Local tycon"+pprTcTyThingCategory (APromotionErr pe) = pprPECategory pe++pprPECategory :: PromotionErr -> SDoc+pprPECategory ClassPE        = text "Class"+pprPECategory TyConPE        = text "Type constructor"+pprPECategory PatSynPE       = text "Pattern synonym"+pprPECategory FamDataConPE   = text "Data constructor"+pprPECategory RecDataConPE   = text "Data constructor"+pprPECategory NoDataKindsTC  = text "Type constructor"+pprPECategory NoDataKindsDC  = text "Data constructor"+pprPECategory NoTypeInTypeTC = text "Type constructor"+pprPECategory NoTypeInTypeDC = text "Data constructor"++{-+************************************************************************+*                                                                      *+        Operations over ImportAvails+*                                                                      *+************************************************************************+-}++-- | 'ImportAvails' summarises what was imported from where, irrespective of+-- whether the imported things are actually used or not.  It is used:+--+--  * when processing the export list,+--+--  * when constructing usage info for the interface file,+--+--  * to identify the list of directly imported modules for initialisation+--    purposes and for optimised overlap checking of family instances,+--+--  * when figuring out what things are really unused+--+data ImportAvails+   = ImportAvails {+        imp_mods :: ImportedMods,+          --      = ModuleEnv [ImportedModsVal],+          -- ^ Domain is all directly-imported modules+          --+          -- See the documentation on ImportedModsVal in HscTypes for the+          -- meaning of the fields.+          --+          -- We need a full ModuleEnv rather than a ModuleNameEnv here,+          -- because we might be importing modules of the same name from+          -- different packages. (currently not the case, but might be in the+          -- future).++        imp_dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface),+          -- ^ Home-package modules needed by the module being compiled+          --+          -- It doesn't matter whether any of these dependencies+          -- are actually /used/ when compiling the module; they+          -- are listed if they are below it at all.  For+          -- example, suppose M imports A which imports X.  Then+          -- compiling M might not need to consult X.hi, but X+          -- is still listed in M's dependencies.++        imp_dep_pkgs :: Set InstalledUnitId,+          -- ^ Packages needed by the module being compiled, whether directly,+          -- or via other modules in this package, or via modules imported+          -- from other packages.++        imp_trust_pkgs :: Set InstalledUnitId,+          -- ^ This is strictly a subset of imp_dep_pkgs and records the+          -- packages the current module needs to trust for Safe Haskell+          -- compilation to succeed. A package is required to be trusted if+          -- we are dependent on a trustworthy module in that package.+          -- While perhaps making imp_dep_pkgs a tuple of (UnitId, Bool)+          -- where True for the bool indicates the package is required to be+          -- trusted is the more logical  design, doing so complicates a lot+          -- of code not concerned with Safe Haskell.+          -- See Note [RnNames . Tracking Trust Transitively]++        imp_trust_own_pkg :: Bool,+          -- ^ Do we require that our own package is trusted?+          -- This is to handle efficiently the case where a Safe module imports+          -- a Trustworthy module that resides in the same package as it.+          -- See Note [RnNames . Trust Own Package]++        imp_orphs :: [Module],+          -- ^ Orphan modules below us in the import tree (and maybe including+          -- us for imported modules)++        imp_finsts :: [Module]+          -- ^ Family instance modules below us in the import tree (and maybe+          -- including us for imported modules)+      }++mkModDeps :: [(ModuleName, IsBootInterface)]+          -> ModuleNameEnv (ModuleName, IsBootInterface)+mkModDeps deps = foldl add emptyUFM deps+               where+                 add env elt@(m,_) = addToUFM env m elt++modDepsElts+  :: ModuleNameEnv (ModuleName, IsBootInterface)+  -> [(ModuleName, IsBootInterface)]+modDepsElts = sort . nonDetEltsUFM+  -- It's OK to use nonDetEltsUFM here because sorting by module names+  -- restores determinism++emptyImportAvails :: ImportAvails+emptyImportAvails = ImportAvails { imp_mods          = emptyModuleEnv,+                                   imp_dep_mods      = emptyUFM,+                                   imp_dep_pkgs      = S.empty,+                                   imp_trust_pkgs    = S.empty,+                                   imp_trust_own_pkg = False,+                                   imp_orphs         = [],+                                   imp_finsts        = [] }++-- | Union two ImportAvails+--+-- This function is a key part of Import handling, basically+-- for each import we create a separate ImportAvails structure+-- and then union them all together with this function.+plusImportAvails ::  ImportAvails ->  ImportAvails ->  ImportAvails+plusImportAvails+  (ImportAvails { imp_mods = mods1,+                  imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1,+                  imp_trust_pkgs = tpkgs1, imp_trust_own_pkg = tself1,+                  imp_orphs = orphs1, imp_finsts = finsts1 })+  (ImportAvails { imp_mods = mods2,+                  imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2,+                  imp_trust_pkgs = tpkgs2, imp_trust_own_pkg = tself2,+                  imp_orphs = orphs2, imp_finsts = finsts2 })+  = ImportAvails { imp_mods          = plusModuleEnv_C (++) mods1 mods2,+                   imp_dep_mods      = plusUFM_C plus_mod_dep dmods1 dmods2,+                   imp_dep_pkgs      = dpkgs1 `S.union` dpkgs2,+                   imp_trust_pkgs    = tpkgs1 `S.union` tpkgs2,+                   imp_trust_own_pkg = tself1 || tself2,+                   imp_orphs         = orphs1 `unionLists` orphs2,+                   imp_finsts        = finsts1 `unionLists` finsts2 }+  where+    plus_mod_dep (m1, boot1) (m2, boot2)+        = WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) )+                -- Check mod-names match+          (m1, boot1 && boot2) -- If either side can "see" a non-hi-boot interface, use that++{-+************************************************************************+*                                                                      *+\subsection{Where from}+*                                                                      *+************************************************************************++The @WhereFrom@ type controls where the renamer looks for an interface file+-}++data WhereFrom+  = ImportByUser IsBootInterface        -- Ordinary user import (perhaps {-# SOURCE #-})+  | ImportBySystem                      -- Non user import.+  | ImportByPlugin                      -- Importing a plugin;+                                        -- See Note [Care with plugin imports] in LoadIface++instance Outputable WhereFrom where+  ppr (ImportByUser is_boot) | is_boot     = text "{- SOURCE -}"+                             | otherwise   = empty+  ppr ImportBySystem                       = text "{- SYSTEM -}"+  ppr ImportByPlugin                       = text "{- PLUGIN -}"+++{- *********************************************************************+*                                                                      *+                Type signatures+*                                                                      *+********************************************************************* -}++-- These data types need to be here only because+-- TcSimplify uses them, and TcSimplify is fairly+-- low down in the module hierarchy++type TcSigFun  = Name -> Maybe TcSigInfo++data TcSigInfo = TcIdSig     TcIdSigInfo+               | TcPatSynSig TcPatSynInfo++data TcIdSigInfo   -- See Note [Complete and partial type signatures]+  = CompleteSig    -- A complete signature with no wildcards,+                   -- so the complete polymorphic type is known.+      { sig_bndr :: TcId          -- The polymorphic Id with that type++      , sig_ctxt :: UserTypeCtxt  -- In the case of type-class default methods,+                                  -- the Name in the FunSigCtxt is not the same+                                  -- as the TcId; the former is 'op', while the+                                  -- latter is '$dmop' or some such++      , sig_loc  :: SrcSpan       -- Location of the type signature+      }++  | PartialSig     -- A partial type signature (i.e. includes one or more+                   -- wildcards). In this case it doesn't make sense to give+                   -- the polymorphic Id, because we are going to /infer/ its+                   -- type, so we can't make the polymorphic Id ab-initio+      { psig_name  :: Name               -- Name of the function; used when report wildcards+      , psig_hs_ty :: LHsSigWcType Name  -- The original partial signature in HsSyn form+      , sig_ctxt   :: UserTypeCtxt+      , sig_loc    :: SrcSpan            -- Location of the type signature+      }+++{- Note [Complete and partial type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A type signature is partial when it contains one or more wildcards+(= type holes).  The wildcard can either be:+* A (type) wildcard occurring in sig_theta or sig_tau. These are+  stored in sig_wcs.+      f :: Bool -> _+      g :: Eq _a => _a -> _a -> Bool+* Or an extra-constraints wildcard, stored in sig_cts:+      h :: (Num a, _) => a -> a++A type signature is a complete type signature when there are no+wildcards in the type signature, i.e. iff sig_wcs is empty and+sig_extra_cts is Nothing.+-}++data TcIdSigInst+  = TISI { sig_inst_sig :: TcIdSigInfo++         , sig_inst_skols :: [(Name, TcTyVar)]+               -- Instantiated type and kind variables, SigTvs+               -- The Name is the Name that the renamer chose;+               --   but the TcTyVar may come from instantiating+               --   the type and hence have a different unique.+               -- No need to keep track of whether they are truly lexically+               --   scoped because the renamer has named them uniquely+               -- See Note [Binding scoped type variables] in TcSigs++         , sig_inst_theta  :: TcThetaType+               -- Instantiated theta.  In the case of a+               -- PartialSig, sig_theta does not include+               -- the extra-constraints wildcard++         , sig_inst_tau :: TcSigmaType   -- Instantiated tau+               -- See Note [sig_inst_tau may be polymorphic]++         -- Relevant for partial signature only+         , sig_inst_wcs   :: [(Name, TcTyVar)]+               -- Like sig_inst_skols, but for wildcards.  The named+               -- wildcards scope over the binding, and hence their+               -- Names may appear in type signatures in the binding++         , sig_inst_wcx   :: Maybe TcTyVar+               -- Extra-constraints wildcard to fill in, if any+         }++{- Note [sig_inst_tau may be polymorphic]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note that "sig_inst_tau" might actually be a polymorphic type,+if the original function had a signature like+   forall a. Eq a => forall b. Ord b => ....+But that's ok: tcMatchesFun (called by tcRhs) can deal with that+It happens, too!  See Note [Polymorphic methods] in TcClassDcl.++Note [Wildcards in partial signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The wildcards in psig_wcs may stand for a type mentioning+the universally-quantified tyvars of psig_ty++E.g.  f :: forall a. _ -> a+      f x = x+We get sig_inst_skols = [a]+       sig_inst_tau   = _22 -> a+       sig_inst_wcs   = [_22]+and _22 in the end is unified with the type 'a'++Moreover the kind of a wildcard in sig_inst_wcs may mention+the universally-quantified tyvars sig_inst_skols+e.g.   f :: t a -> t _+Here we get+   sig_inst_skols = [k:*, (t::k ->*), (a::k)]+   sig_inst_tau   = t a -> t _22+   sig_inst_wcs   = [ _22::k ]+-}++data TcPatSynInfo+  = TPSI {+        patsig_name           :: Name,+        patsig_implicit_bndrs :: [TyVarBinder], -- Implicitly-bound kind vars (Inferred) and+                                                -- implicitly-bound type vars (Specified)+          -- See Note [The pattern-synonym signature splitting rule] in TcPatSyn+        patsig_univ_bndrs     :: [TyVar],       -- Bound by explicit user forall+        patsig_req            :: TcThetaType,+        patsig_ex_bndrs       :: [TyVar],       -- Bound by explicit user forall+        patsig_prov           :: TcThetaType,+        patsig_body_ty        :: TcSigmaType+    }++instance Outputable TcSigInfo where+  ppr (TcIdSig     idsi) = ppr idsi+  ppr (TcPatSynSig tpsi) = text "TcPatSynInfo" <+> ppr tpsi++instance Outputable TcIdSigInfo where+    ppr (CompleteSig { sig_bndr = bndr })+        = ppr bndr <+> dcolon <+> ppr (idType bndr)+    ppr (PartialSig { psig_name = name, psig_hs_ty = hs_ty })+        = text "psig" <+> ppr name <+> dcolon <+> ppr hs_ty++instance Outputable TcIdSigInst where+    ppr (TISI { sig_inst_sig = sig, sig_inst_skols = skols+              , sig_inst_theta = theta, sig_inst_tau = tau })+        = hang (ppr sig) 2 (vcat [ ppr skols, ppr theta <+> darrow <+> ppr tau ])++instance Outputable TcPatSynInfo where+    ppr (TPSI{ patsig_name = name}) = ppr name++isPartialSig :: TcIdSigInst -> Bool+isPartialSig (TISI { sig_inst_sig = PartialSig {} }) = True+isPartialSig _                                       = False++-- | No signature or a partial signature+hasCompleteSig :: TcSigFun -> Name -> Bool+hasCompleteSig sig_fn name+  = case sig_fn name of+      Just (TcIdSig (CompleteSig {})) -> True+      _                               -> False+++{-+************************************************************************+*                                                                      *+*                       Canonical constraints                          *+*                                                                      *+*   These are the constraints the low-level simplifier works with      *+*                                                                      *+************************************************************************+-}++-- The syntax of xi (ξ) types:+-- xi ::= a | T xis | xis -> xis | ... | forall a. tau+-- Two important notes:+--      (i) No type families, unless we are under a ForAll+--      (ii) Note that xi types can contain unexpanded type synonyms;+--           however, the (transitive) expansions of those type synonyms+--           will not contain any type functions, unless we are under a ForAll.+-- We enforce the structure of Xi types when we flatten (TcCanonical)++type Xi = Type       -- In many comments, "xi" ranges over Xi++type Cts = Bag Ct++data Ct+  -- Atomic canonical constraints+  = CDictCan {  -- e.g.  Num xi+      cc_ev     :: CtEvidence, -- See Note [Ct/evidence invariant]++      cc_class  :: Class,+      cc_tyargs :: [Xi],   -- cc_tyargs are function-free, hence Xi++      cc_pend_sc :: Bool   -- See Note [The superclass story] in TcCanonical+                           -- True <=> (a) cc_class has superclasses+                           --          (b) we have not (yet) added those+                           --              superclasses as Givens+    }++  | CIrredEvCan {  -- These stand for yet-unusable predicates+      cc_ev :: CtEvidence   -- See Note [Ct/evidence invariant]+        -- The ctev_pred of the evidence is+        -- of form   (tv xi1 xi2 ... xin)+        --      or   (tv1 ~ ty2)   where the CTyEqCan  kind invariant fails+        --      or   (F tys ~ ty)  where the CFunEqCan kind invariant fails+        -- See Note [CIrredEvCan constraints]+    }++  | CTyEqCan {  -- tv ~ rhs+       -- Invariants:+       --   * See Note [Applying the inert substitution] in TcFlatten+       --   * tv not in tvs(rhs)   (occurs check)+       --   * If tv is a TauTv, then rhs has no foralls+       --       (this avoids substituting a forall for the tyvar in other types)+       --   * typeKind ty `tcEqKind` typeKind tv+       --   * rhs may have at most one top-level cast+       --   * rhs (perhaps under the one cast) is not necessarily function-free,+       --       but it has no top-level function.+       --     E.g. a ~ [F b]  is fine+       --     but  a ~ F b    is not+       --   * If the equality is representational, rhs has no top-level newtype+       --     See Note [No top-level newtypes on RHS of representational+       --     equalities] in TcCanonical+       --   * If rhs (perhaps under the cast) is also a tv, then it is oriented+       --     to give best chance of+       --     unification happening; eg if rhs is touchable then lhs is too+      cc_ev     :: CtEvidence, -- See Note [Ct/evidence invariant]+      cc_tyvar  :: TcTyVar,+      cc_rhs    :: TcType,     -- Not necessarily function-free (hence not Xi)+                               -- See invariants above++      cc_eq_rel :: EqRel       -- INVARIANT: cc_eq_rel = ctEvEqRel cc_ev+    }++  | CFunEqCan {  -- F xis ~ fsk+       -- Invariants:+       --   * isTypeFamilyTyCon cc_fun+       --   * typeKind (F xis) = tyVarKind fsk+       --   * always Nominal role+      cc_ev     :: CtEvidence,  -- See Note [Ct/evidence invariant]+      cc_fun    :: TyCon,       -- A type function++      cc_tyargs :: [Xi],        -- cc_tyargs are function-free (hence Xi)+        -- Either under-saturated or exactly saturated+        --    *never* over-saturated (because if so+        --    we should have decomposed)++      cc_fsk    :: TcTyVar  -- [Given]  always a FlatSkol skolem+                            -- [Wanted] always a FlatMetaTv unification variable+        -- See Note [The flattening story] in TcFlatten+    }++  | CNonCanonical {        -- See Note [NonCanonical Semantics] in TcSMonad+      cc_ev  :: CtEvidence+    }++  | CHoleCan {             -- See Note [Hole constraints]+       -- Treated as an "insoluble" constraint+       -- See Note [Insoluble constraints]+      cc_ev   :: CtEvidence,+      cc_hole :: Hole+    }++-- | An expression or type hole+data Hole = ExprHole UnboundVar+            -- ^ Either an out-of-scope variable or a "true" hole in an+            -- expression (TypedHoles)+          | TypeHole OccName+            -- ^ A hole in a type (PartialTypeSignatures)++holeOcc :: Hole -> OccName+holeOcc (ExprHole uv)  = unboundVarOcc uv+holeOcc (TypeHole occ) = occ++{- Note [Hole constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~+CHoleCan constraints are used for two kinds of holes,+distinguished by cc_hole:++  * For holes in expressions (including variables not in scope)+    e.g.   f x = g _ x++  * For holes in type signatures+    e.g.   f :: _ -> _+           f x = [x,True]++Note [CIrredEvCan constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+CIrredEvCan constraints are used for constraints that are "stuck"+   - we can't solve them (yet)+   - we can't use them to solve other constraints+   - but they may become soluble if we substitute for some+     of the type variables in the constraint++Example 1:  (c Int), where c :: * -> Constraint.  We can't do anything+            with this yet, but if later c := Num, *then* we can solve it++Example 2:  a ~ b, where a :: *, b :: k, where k is a kind variable+            We don't want to use this to substitute 'b' for 'a', in case+            'k' is subequently unifed with (say) *->*, because then+            we'd have ill-kinded types floating about.  Rather we want+            to defer using the equality altogether until 'k' get resolved.++Note [Ct/evidence invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If  ct :: Ct, then extra fields of 'ct' cache precisely the ctev_pred field+of (cc_ev ct), and is fully rewritten wrt the substitution.   Eg for CDictCan,+   ctev_pred (cc_ev ct) = (cc_class ct) (cc_tyargs ct)+This holds by construction; look at the unique place where CDictCan is+built (in TcCanonical).++In contrast, the type of the evidence *term* (ctev_dest / ctev_evar) in+the evidence may *not* be fully zonked; we are careful not to look at it+during constraint solving. See Note [Evidence field of CtEvidence].+-}++mkNonCanonical :: CtEvidence -> Ct+mkNonCanonical ev = CNonCanonical { cc_ev = ev }++mkNonCanonicalCt :: Ct -> Ct+mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct }++mkGivens :: CtLoc -> [EvId] -> [Ct]+mkGivens loc ev_ids+  = map mk ev_ids+  where+    mk ev_id = mkNonCanonical (CtGiven { ctev_evar = ev_id+                                       , ctev_pred = evVarPred ev_id+                                       , ctev_loc = loc })++ctEvidence :: Ct -> CtEvidence+ctEvidence = cc_ev++ctLoc :: Ct -> CtLoc+ctLoc = ctEvLoc . ctEvidence++setCtLoc :: Ct -> CtLoc -> Ct+setCtLoc ct loc = ct { cc_ev = (cc_ev ct) { ctev_loc = loc } }++ctOrigin :: Ct -> CtOrigin+ctOrigin = ctLocOrigin . ctLoc++ctPred :: Ct -> PredType+-- See Note [Ct/evidence invariant]+ctPred ct = ctEvPred (cc_ev ct)++-- | Makes a new equality predicate with the same role as the given+-- evidence.+mkTcEqPredLikeEv :: CtEvidence -> TcType -> TcType -> TcType+mkTcEqPredLikeEv ev+  = case predTypeEqRel pred of+      NomEq  -> mkPrimEqPred+      ReprEq -> mkReprPrimEqPred+  where+    pred = ctEvPred ev++-- | Get the flavour of the given 'Ct'+ctFlavour :: Ct -> CtFlavour+ctFlavour = ctEvFlavour . ctEvidence++-- | Get the equality relation for the given 'Ct'+ctEqRel :: Ct -> EqRel+ctEqRel = ctEvEqRel . ctEvidence++instance Outputable Ct where+  ppr ct = ppr (cc_ev ct) <+> parens pp_sort+    where+      pp_sort = case ct of+         CTyEqCan {}      -> text "CTyEqCan"+         CFunEqCan {}     -> text "CFunEqCan"+         CNonCanonical {} -> text "CNonCanonical"+         CDictCan { cc_pend_sc = pend_sc }+            | pend_sc   -> text "CDictCan(psc)"+            | otherwise -> text "CDictCan"+         CIrredEvCan {}   -> text "CIrredEvCan"+         CHoleCan { cc_hole = hole } -> text "CHoleCan:" <+> ppr (holeOcc hole)++{-+************************************************************************+*                                                                      *+        Simple functions over evidence variables+*                                                                      *+************************************************************************+-}++---------------- Getting free tyvars -------------------------++-- | Returns free variables of constraints as a non-deterministic set+tyCoVarsOfCt :: Ct -> TcTyCoVarSet+tyCoVarsOfCt = fvVarSet . tyCoFVsOfCt++-- | Returns free variables of constraints as a deterministically ordered.+-- list. See Note [Deterministic FV] in FV.+tyCoVarsOfCtList :: Ct -> [TcTyCoVar]+tyCoVarsOfCtList = fvVarList . tyCoFVsOfCt++-- | Returns free variables of constraints as a composable FV computation.+-- See Note [Deterministic FV] in FV.+tyCoFVsOfCt :: Ct -> FV+tyCoFVsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi })+  = tyCoFVsOfType xi `unionFV` FV.unitFV tv+                     `unionFV` tyCoFVsOfType (tyVarKind tv)+tyCoFVsOfCt (CFunEqCan { cc_tyargs = tys, cc_fsk = fsk })+  = tyCoFVsOfTypes tys `unionFV` FV.unitFV fsk+                       `unionFV` tyCoFVsOfType (tyVarKind fsk)+tyCoFVsOfCt (CDictCan { cc_tyargs = tys }) = tyCoFVsOfTypes tys+tyCoFVsOfCt (CIrredEvCan { cc_ev = ev }) = tyCoFVsOfType (ctEvPred ev)+tyCoFVsOfCt (CHoleCan { cc_ev = ev }) = tyCoFVsOfType (ctEvPred ev)+tyCoFVsOfCt (CNonCanonical { cc_ev = ev }) = tyCoFVsOfType (ctEvPred ev)++-- | Returns free variables of a bag of constraints as a non-deterministic+-- set. See Note [Deterministic FV] in FV.+tyCoVarsOfCts :: Cts -> TcTyCoVarSet+tyCoVarsOfCts = fvVarSet . tyCoFVsOfCts++-- | Returns free variables of a bag of constraints as a deterministically+-- odered list. See Note [Deterministic FV] in FV.+tyCoVarsOfCtsList :: Cts -> [TcTyCoVar]+tyCoVarsOfCtsList = fvVarList . tyCoFVsOfCts++-- | Returns free variables of a bag of constraints as a composable FV+-- computation. See Note [Deterministic FV] in FV.+tyCoFVsOfCts :: Cts -> FV+tyCoFVsOfCts = foldrBag (unionFV . tyCoFVsOfCt) emptyFV++-- | Returns free variables of WantedConstraints as a non-deterministic+-- set. See Note [Deterministic FV] in FV.+tyCoVarsOfWC :: WantedConstraints -> TyCoVarSet+-- Only called on *zonked* things, hence no need to worry about flatten-skolems+tyCoVarsOfWC = fvVarSet . tyCoFVsOfWC++-- | Returns free variables of WantedConstraints as a deterministically+-- ordered list. See Note [Deterministic FV] in FV.+tyCoVarsOfWCList :: WantedConstraints -> [TyCoVar]+-- Only called on *zonked* things, hence no need to worry about flatten-skolems+tyCoVarsOfWCList = fvVarList . tyCoFVsOfWC++-- | Returns free variables of WantedConstraints as a composable FV+-- computation. See Note [Deterministic FV] in FV.+tyCoFVsOfWC :: WantedConstraints -> FV+-- Only called on *zonked* things, hence no need to worry about flatten-skolems+tyCoFVsOfWC (WC { wc_simple = simple, wc_impl = implic, wc_insol = insol })+  = tyCoFVsOfCts simple `unionFV`+    tyCoFVsOfBag tyCoFVsOfImplic implic `unionFV`+    tyCoFVsOfCts insol++-- | Returns free variables of Implication as a composable FV computation.+-- See Note [Deterministic FV] in FV.+tyCoFVsOfImplic :: Implication -> FV+-- Only called on *zonked* things, hence no need to worry about flatten-skolems+tyCoFVsOfImplic (Implic { ic_skols = skols+                        , ic_given = givens+                        , ic_wanted = wanted })+  = FV.delFVs (mkVarSet skols `unionVarSet` mkVarSet givens)+      (tyCoFVsOfWC wanted `unionFV` tyCoFVsOfTypes (map evVarPred givens))++tyCoFVsOfBag :: (a -> FV) -> Bag a -> FV+tyCoFVsOfBag tvs_of = foldrBag (unionFV . tvs_of) emptyFV++--------------------------+dropDerivedSimples :: Cts -> Cts+-- Drop all Derived constraints, but make [W] back into [WD],+-- so that if we re-simplify these constraints we will get all+-- the right derived constraints re-generated.  Forgetting this+-- step led to #12936+dropDerivedSimples simples = mapMaybeBag dropDerivedCt simples++dropDerivedCt :: Ct -> Maybe Ct+dropDerivedCt ct+  = case ctEvFlavour ev of+      Wanted WOnly -> Just (ct' { cc_ev = ev_wd })+      Wanted _     -> Just ct'+      _            -> ASSERT( isDerivedCt ct ) Nothing+                      -- simples are all Wanted or Derived+  where+    ev    = ctEvidence ct+    ev_wd = ev { ctev_nosh = WDeriv }+    ct'   = setPendingScDict ct -- See Note [Resetting cc_pend_sc]++{- Note [Resetting cc_pend_sc]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we discard Derived constraints, in dropDerivedSimples, we must+set the cc_pend_sc flag to True, so that if we re-process this+CDictCan we will re-generate its derived superclasses. Otherwise+we might miss some fundeps.  Trac #13662 showed this up.++See Note [The superclass story] in TcCanonical.+-}+++dropDerivedInsols :: Cts -> Cts+-- See Note [Dropping derived constraints]+dropDerivedInsols insols = filterBag keep insols+  where                    -- insols can include Given+    keep ct+      | isDerivedCt ct = not (isDroppableDerivedLoc (ctLoc ct))+      | otherwise      = True++isDroppableDerivedLoc :: CtLoc -> Bool+-- Note [Dropping derived constraints]+isDroppableDerivedLoc loc+  = case ctLocOrigin loc of+      HoleOrigin {}    -> False+      KindEqOrigin {}  -> False+      GivenOrigin {}   -> False+      FunDepOrigin1 {} -> False+      FunDepOrigin2 {} -> False+      _                -> True++arisesFromGivens :: Ct -> Bool+arisesFromGivens ct+  = case ctEvidence ct of+      CtGiven {} -> True+      CtWanted {} -> False+      CtDerived { ctev_loc = loc } -> from_given loc+  where+   from_given :: CtLoc -> Bool+   from_given loc = from_given_origin (ctLocOrigin loc)++   from_given_origin :: CtOrigin -> Bool+   from_given_origin (GivenOrigin {})          = True+   from_given_origin (FunDepOrigin1 _ l1 _ l2) = from_given l1 && from_given l2+   from_given_origin (FunDepOrigin2 _ o1 _ _)  = from_given_origin o1+   from_given_origin _                         = False++{- Note [Dropping derived constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general we discard derived constraints at the end of constraint solving;+see dropDerivedWC.  For example++ * If we have an unsolved [W] (Ord a), we don't want to complain about+   an unsolved [D] (Eq a) as well.++ * If we have [W] a ~ Int, [W] a ~ Bool, improvement will generate+   [D] Int ~ Bool, and we don't want to report that because it's incomprehensible.+   That is why we don't rewrite wanteds with wanteds!++But (tiresomely) we do keep *some* Derived insolubles:++ * Insoluble kind equalities (e.g. [D] * ~ (* -> *)) may arise from+   a type equality a ~ Int#, say.  In future they'll be Wanted, not Derived,+   but at the moment they are Derived.++ * Insoluble derived equalities (e.g. [D] Int ~ Bool) may arise from+   functional dependency interactions, either between Givens or+   Wanteds.  It seems sensible to retain these:+   - For Givens they reflect unreachable code+   - For Wanteds it is arguably better to get a fundep error than+     a no-instance error (Trac #9612)++ * Type holes are derived constraints because they have no evidence+   and we want to keep them so we get the error report++Moreover, we keep *all* derived insolubles under some circumstances:++  * They are looked at by simplifyInfer, to decide whether to+    generalise.  Example: [W] a ~ Int, [W] a ~ Bool+    We get [D] Int ~ Bool, and indeed the constraints are insoluble,+    and we want simplifyInfer to see that, even though we don't+    ultimately want to generate an (inexplicable) error message from++To distinguish these cases we use the CtOrigin.+++************************************************************************+*                                                                      *+                    CtEvidence+         The "flavor" of a canonical constraint+*                                                                      *+************************************************************************+-}++isWantedCt :: Ct -> Bool+isWantedCt = isWanted . cc_ev++isGivenCt :: Ct -> Bool+isGivenCt = isGiven . cc_ev++isDerivedCt :: Ct -> Bool+isDerivedCt = isDerived . cc_ev++isCTyEqCan :: Ct -> Bool+isCTyEqCan (CTyEqCan {})  = True+isCTyEqCan (CFunEqCan {}) = False+isCTyEqCan _              = False++isCDictCan_Maybe :: Ct -> Maybe Class+isCDictCan_Maybe (CDictCan {cc_class = cls })  = Just cls+isCDictCan_Maybe _              = Nothing++isCIrredEvCan :: Ct -> Bool+isCIrredEvCan (CIrredEvCan {}) = True+isCIrredEvCan _                = False++isCFunEqCan_maybe :: Ct -> Maybe (TyCon, [Type])+isCFunEqCan_maybe (CFunEqCan { cc_fun = tc, cc_tyargs = xis }) = Just (tc, xis)+isCFunEqCan_maybe _ = Nothing++isCFunEqCan :: Ct -> Bool+isCFunEqCan (CFunEqCan {}) = True+isCFunEqCan _ = False++isCNonCanonical :: Ct -> Bool+isCNonCanonical (CNonCanonical {}) = True+isCNonCanonical _ = False++isHoleCt:: Ct -> Bool+isHoleCt (CHoleCan {}) = True+isHoleCt _ = False++isOutOfScopeCt :: Ct -> Bool+-- We treat expression holes representing out-of-scope variables a bit+-- differently when it comes to error reporting+isOutOfScopeCt (CHoleCan { cc_hole = ExprHole (OutOfScope {}) }) = True+isOutOfScopeCt _ = False++isExprHoleCt :: Ct -> Bool+isExprHoleCt (CHoleCan { cc_hole = ExprHole {} }) = True+isExprHoleCt _ = False++isTypeHoleCt :: Ct -> Bool+isTypeHoleCt (CHoleCan { cc_hole = TypeHole {} }) = True+isTypeHoleCt _ = False+++{- Note [Custom type errors in constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When GHC reports a type-error about an unsolved-constraint, we check+to see if the constraint contains any custom-type errors, and if so+we report them.  Here are some examples of constraints containing type+errors:++TypeError msg           -- The actual constraint is a type error++TypError msg ~ Int      -- Some type was supposed to be Int, but ended up+                        -- being a type error instead++Eq (TypeError msg)      -- A class constraint is stuck due to a type error++F (TypeError msg) ~ a   -- A type function failed to evaluate due to a type err++It is also possible to have constraints where the type error is nested deeper,+for example see #11990, and also:++Eq (F (TypeError msg))  -- Here the type error is nested under a type-function+                        -- call, which failed to evaluate because of it,+                        -- and so the `Eq` constraint was unsolved.+                        -- This may happen when one function calls another+                        -- and the called function produced a custom type error.+-}++-- | A constraint is considered to be a custom type error, if it contains+-- custom type errors anywhere in it.+-- See Note [Custom type errors in constraints]+getUserTypeErrorMsg :: Ct -> Maybe Type+getUserTypeErrorMsg ct = findUserTypeError (ctPred ct)+  where+  findUserTypeError t = msum ( userTypeError_maybe t+                             : map findUserTypeError (subTys t)+                             )++  subTys t            = case splitAppTys t of+                          (t,[]) ->+                            case splitTyConApp_maybe t of+                              Nothing     -> []+                              Just (_,ts) -> ts+                          (t,ts) -> t : ts+++++isUserTypeErrorCt :: Ct -> Bool+isUserTypeErrorCt ct = case getUserTypeErrorMsg ct of+                         Just _ -> True+                         _      -> False++isPendingScDict :: Ct -> Maybe Ct+-- Says whether cc_pend_sc is True, AND if so flips the flag+isPendingScDict ct@(CDictCan { cc_pend_sc = True })+                  = Just (ct { cc_pend_sc = False })+isPendingScDict _ = Nothing++setPendingScDict :: Ct -> Ct+-- Set the cc_pend_sc flag to True+setPendingScDict ct@(CDictCan { cc_pend_sc = False })+                    = ct { cc_pend_sc = True }+setPendingScDict ct = ct++superClassesMightHelp :: Ct -> Bool+-- ^ True if taking superclasses of givens, or of wanteds (to perhaps+-- expose more equalities or functional dependencies) might help to+-- solve this constraint.  See Note [When superclasses help]+superClassesMightHelp ct+  = isWantedCt ct && not (is_ip ct)+  where+    is_ip (CDictCan { cc_class = cls }) = isIPClass cls+    is_ip _                             = False++{- Note [When superclasses help]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+First read Note [The superclass story] in TcCanonical.++We expand superclasses and iterate only if there is at unsolved wanted+for which expansion of superclasses (e.g. from given constraints)+might actually help. The function superClassesMightHelp tells if+doing this superclass expansion might help solve this constraint.+Note that++  * Superclasses help only for Wanted constraints.  Derived constraints+    are not really "unsolved" and we certainly don't want them to+    trigger superclass expansion. This was a good part of the loop+    in  Trac #11523++  * Even for Wanted constraints, we say "no" for implicit parameters.+    we have [W] ?x::ty, expanding superclasses won't help:+      - Superclasses can't be implicit parameters+      - If we have a [G] ?x:ty2, then we'll have another unsolved+        [D] ty ~ ty2 (from the functional dependency)+        which will trigger superclass expansion.++    It's a bit of a special case, but it's easy to do.  The runtime cost+    is low because the unsolved set is usually empty anyway (errors+    aside), and the first non-imlicit-parameter will terminate the search.++    The special case is worth it (Trac #11480, comment:2) because it+    applies to CallStack constraints, which aren't type errors. If we have+       f :: (C a) => blah+       f x = ...undefined...+    we'll get a CallStack constraint.  If that's the only unsolved+    constraint it'll eventually be solved by defaulting.  So we don't+    want to emit warnings about hitting the simplifier's iteration+    limit.  A CallStack constraint really isn't an unsolved+    constraint; it can always be solved by defaulting.+-}++singleCt :: Ct -> Cts+singleCt = unitBag++andCts :: Cts -> Cts -> Cts+andCts = unionBags++listToCts :: [Ct] -> Cts+listToCts = listToBag++ctsElts :: Cts -> [Ct]+ctsElts = bagToList++consCts :: Ct -> Cts -> Cts+consCts = consBag++snocCts :: Cts -> Ct -> Cts+snocCts = snocBag++extendCtsList :: Cts -> [Ct] -> Cts+extendCtsList cts xs | null xs   = cts+                     | otherwise = cts `unionBags` listToBag xs++andManyCts :: [Cts] -> Cts+andManyCts = unionManyBags++emptyCts :: Cts+emptyCts = emptyBag++isEmptyCts :: Cts -> Bool+isEmptyCts = isEmptyBag++pprCts :: Cts -> SDoc+pprCts cts = vcat (map ppr (bagToList cts))++{-+************************************************************************+*                                                                      *+                Wanted constraints+     These are forced to be in TcRnTypes because+           TcLclEnv mentions WantedConstraints+           WantedConstraint mentions CtLoc+           CtLoc mentions ErrCtxt+           ErrCtxt mentions TcM+*                                                                      *+v%************************************************************************+-}++data WantedConstraints+  = WC { wc_simple :: Cts              -- Unsolved constraints, all wanted+       , wc_impl   :: Bag Implication+       , wc_insol  :: Cts              -- Insoluble constraints, can be+                                       -- wanted, given, or derived+                                       -- See Note [Insoluble constraints]+    }++emptyWC :: WantedConstraints+emptyWC = WC { wc_simple = emptyBag, wc_impl = emptyBag, wc_insol = emptyBag }++mkSimpleWC :: [CtEvidence] -> WantedConstraints+mkSimpleWC cts+  = WC { wc_simple = listToBag (map mkNonCanonical cts)+       , wc_impl = emptyBag+       , wc_insol = emptyBag }++mkImplicWC :: Bag Implication -> WantedConstraints+mkImplicWC implic+  = WC { wc_simple = emptyBag, wc_impl = implic, wc_insol = emptyBag }++isEmptyWC :: WantedConstraints -> Bool+isEmptyWC (WC { wc_simple = f, wc_impl = i, wc_insol = n })+  = isEmptyBag f && isEmptyBag i && isEmptyBag n++andWC :: WantedConstraints -> WantedConstraints -> WantedConstraints+andWC (WC { wc_simple = f1, wc_impl = i1, wc_insol = n1 })+      (WC { wc_simple = f2, wc_impl = i2, wc_insol = n2 })+  = WC { wc_simple = f1 `unionBags` f2+       , wc_impl   = i1 `unionBags` i2+       , wc_insol  = n1 `unionBags` n2 }++unionsWC :: [WantedConstraints] -> WantedConstraints+unionsWC = foldr andWC emptyWC++addSimples :: WantedConstraints -> Bag Ct -> WantedConstraints+addSimples wc cts+  = wc { wc_simple = wc_simple wc `unionBags` cts }+    -- Consider: Put the new constraints at the front, so they get solved first++addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints+addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic }++addInsols :: WantedConstraints -> Bag Ct -> WantedConstraints+addInsols wc cts+  = wc { wc_insol = wc_insol wc `unionBags` cts }++getInsolubles :: WantedConstraints -> Cts+getInsolubles = wc_insol++insolublesOnly :: WantedConstraints -> WantedConstraints+-- Keep only the insolubles+insolublesOnly wc = wc { wc_simple = emptyBag, wc_impl = emptyBag }++dropDerivedWC :: WantedConstraints -> WantedConstraints+-- See Note [Dropping derived constraints]+dropDerivedWC wc@(WC { wc_simple = simples, wc_insol = insols })+  = wc { wc_simple = dropDerivedSimples simples+       , wc_insol  = dropDerivedInsols insols }+    -- The wc_impl implications are already (recursively) filtered++isSolvedStatus :: ImplicStatus -> Bool+isSolvedStatus (IC_Solved {}) = True+isSolvedStatus _              = False++isInsolubleStatus :: ImplicStatus -> Bool+isInsolubleStatus IC_Insoluble = True+isInsolubleStatus _            = False++insolubleImplic :: Implication -> Bool+insolubleImplic ic = isInsolubleStatus (ic_status ic)++insolubleWC :: WantedConstraints -> Bool+insolubleWC (WC { wc_impl = implics, wc_insol = insols })+  =  anyBag trulyInsoluble insols+  || anyBag insolubleImplic implics++trulyInsoluble :: Ct -> Bool+-- Constraints in the wc_insol set which ARE NOT+-- treated as truly insoluble:+--   a) type holes, arising from PartialTypeSignatures,+--   b) "true" expression holes arising from TypedHoles+--+-- A "expression hole" or "type hole" constraint isn't really an error+-- at all; it's a report saying "_ :: Int" here.  But an out-of-scope+-- variable masquerading as expression holes IS treated as truly+-- insoluble, so that it trumps other errors during error reporting.+-- Yuk!+trulyInsoluble insol+  | isHoleCt insol = isOutOfScopeCt insol+  | otherwise      = True++instance Outputable WantedConstraints where+  ppr (WC {wc_simple = s, wc_impl = i, wc_insol = n})+   = text "WC" <+> braces (vcat+        [ ppr_bag (text "wc_simple") s+        , ppr_bag (text "wc_insol") n+        , ppr_bag (text "wc_impl") i ])++ppr_bag :: Outputable a => SDoc -> Bag a -> SDoc+ppr_bag doc bag+ | isEmptyBag bag = empty+ | otherwise      = hang (doc <+> equals)+                       2 (foldrBag (($$) . ppr) empty bag)++{-+************************************************************************+*                                                                      *+                Implication constraints+*                                                                      *+************************************************************************+-}++data Implication+  = Implic {+      ic_tclvl :: TcLevel,       -- TcLevel of unification variables+                                 -- allocated /inside/ this implication++      ic_skols :: [TcTyVar],     -- Introduced skolems+      ic_info  :: SkolemInfo,    -- See Note [Skolems in an implication]+                                 -- See Note [Shadowing in a constraint]++      ic_given  :: [EvVar],      -- Given evidence variables+                                 --   (order does not matter)+                                 -- See Invariant (GivenInv) in TcType++      ic_no_eqs :: Bool,         -- True  <=> ic_givens have no equalities, for sure+                                 -- False <=> ic_givens might have equalities++      ic_env   :: TcLclEnv,      -- Gives the source location and error context+                                 -- for the implication, and hence for all the+                                 -- given evidence variables++      ic_wanted :: WantedConstraints,  -- The wanted++      ic_binds  :: EvBindsVar,    -- Points to the place to fill in the+                                  -- abstraction and bindings.++      ic_needed   :: VarSet,      -- Union of the ics_need fields of any /discarded/+                                  -- solved implications in ic_wanted++      ic_status   :: ImplicStatus+    }++data ImplicStatus+  = IC_Solved     -- All wanteds in the tree are solved, all the way down+       { ics_need :: VarSet     -- Evidence variables bound further out,+                                -- but needed by this solved implication+       , ics_dead :: [EvVar] }  -- Subset of ic_given that are not needed+         -- See Note [Tracking redundant constraints] in TcSimplify++  | IC_Insoluble  -- At least one insoluble constraint in the tree++  | IC_Unsolved   -- Neither of the above; might go either way++instance Outputable Implication where+  ppr (Implic { ic_tclvl = tclvl, ic_skols = skols+              , ic_given = given, ic_no_eqs = no_eqs+              , ic_wanted = wanted, ic_status = status+              , ic_binds = binds, ic_needed = needed , ic_info = info })+   = hang (text "Implic" <+> lbrace)+        2 (sep [ text "TcLevel =" <+> ppr tclvl+               , text "Skolems =" <+> pprTyVars skols+               , text "No-eqs =" <+> ppr no_eqs+               , text "Status =" <+> ppr status+               , hang (text "Given =")  2 (pprEvVars given)+               , hang (text "Wanted =") 2 (ppr wanted)+               , text "Binds =" <+> ppr binds+               , text "Needed =" <+> ppr needed+               , pprSkolInfo info ] <+> rbrace)++instance Outputable ImplicStatus where+  ppr IC_Insoluble   = text "Insoluble"+  ppr IC_Unsolved    = text "Unsolved"+  ppr (IC_Solved { ics_need = vs, ics_dead = dead })+    = text "Solved"+      <+> (braces $ vcat [ text "Dead givens =" <+> ppr dead+                         , text "Needed =" <+> ppr vs ])++{-+Note [Needed evidence variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Th ic_need_evs field holds the free vars of ic_binds, and all the+ic_binds in nested implications.++  * Main purpose: if one of the ic_givens is not mentioned in here, it+    is redundant.++  * solveImplication may drop an implication altogether if it has no+    remaining 'wanteds'. But we still track the free vars of its+    evidence binds, even though it has now disappeared.++Note [Shadowing in a constraint]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We assume NO SHADOWING in a constraint.  Specifically+ * The unification variables are all implicitly quantified at top+   level, and are all unique+ * The skolem variables bound in ic_skols are all freah when the+   implication is created.+So we can safely substitute. For example, if we have+   forall a.  a~Int => ...(forall b. ...a...)...+we can push the (a~Int) constraint inwards in the "givens" without+worrying that 'b' might clash.++Note [Skolems in an implication]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The skolems in an implication are not there to perform a skolem escape+check.  That happens because all the environment variables are in the+untouchables, and therefore cannot be unified with anything at all,+let alone the skolems.++Instead, ic_skols is used only when considering floating a constraint+outside the implication in TcSimplify.floatEqualities or+TcSimplify.approximateImplications++Note [Insoluble constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Some of the errors that we get during canonicalization are best+reported when all constraints have been simplified as much as+possible. For instance, assume that during simplification the+following constraints arise:++ [Wanted]   F alpha ~  uf1+ [Wanted]   beta ~ uf1 beta++When canonicalizing the wanted (beta ~ uf1 beta), if we eagerly fail+we will simply see a message:+    'Can't construct the infinite type  beta ~ uf1 beta'+and the user has no idea what the uf1 variable is.++Instead our plan is that we will NOT fail immediately, but:+    (1) Record the "frozen" error in the ic_insols field+    (2) Isolate the offending constraint from the rest of the inerts+    (3) Keep on simplifying/canonicalizing++At the end, we will hopefully have substituted uf1 := F alpha, and we+will be able to report a more informative error:+    'Can't construct the infinite type beta ~ F alpha beta'++Insoluble constraints *do* include Derived constraints. For example,+a functional dependency might give rise to [D] Int ~ Bool, and we must+report that.  If insolubles did not contain Deriveds, reportErrors would+never see it.+++************************************************************************+*                                                                      *+            Pretty printing+*                                                                      *+************************************************************************+-}++pprEvVars :: [EvVar] -> SDoc    -- Print with their types+pprEvVars ev_vars = vcat (map pprEvVarWithType ev_vars)++pprEvVarTheta :: [EvVar] -> SDoc+pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars)++pprEvVarWithType :: EvVar -> SDoc+pprEvVarWithType v = ppr v <+> dcolon <+> pprType (evVarPred v)++{-+************************************************************************+*                                                                      *+            CtEvidence+*                                                                      *+************************************************************************++Note [Evidence field of CtEvidence]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+During constraint solving we never look at the type of ctev_evar/ctev_dest;+instead we look at the ctev_pred field.  The evtm/evar field+may be un-zonked.++Note [Bind new Givens immediately]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For Givens we make new EvVars and bind them immediately. Two main reasons:+  * Gain sharing.  E.g. suppose we start with g :: C a b, where+       class D a => C a b+       class (E a, F a) => D a+    If we generate all g's superclasses as separate EvTerms we might+    get    selD1 (selC1 g) :: E a+           selD2 (selC1 g) :: F a+           selC1 g :: D a+    which we could do more economically as:+           g1 :: D a = selC1 g+           g2 :: E a = selD1 g1+           g3 :: F a = selD2 g1++  * For *coercion* evidence we *must* bind each given:+      class (a~b) => C a b where ....+      f :: C a b => ....+    Then in f's Givens we have g:(C a b) and the superclass sc(g,0):a~b.+    But that superclass selector can't (yet) appear in a coercion+    (see evTermCoercion), so the easy thing is to bind it to an Id.++So a Given has EvVar inside it rather than (as previously) an EvTerm.++Note [Given in ctEvCoercion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When retrieving the evidence from a Given equality, we update the type of the EvVar+from the ctev_pred field. In Note [Evidence field of CtEvidence], we claim that+the type of the evidence is never looked at -- but this isn't true in the case of+a coercion that is used in a type. (See the comments in Note [Flattening] in TcFlatten+about the FTRNotFollowed case of flattenTyVar.) So, right here where we are retrieving+the coercion from a Given, we update the type to make sure it's zonked.++-}++-- | A place for type-checking evidence to go after it is generated.+-- Wanted equalities are always HoleDest; other wanteds are always+-- EvVarDest.+data TcEvDest+  = EvVarDest EvVar         -- ^ bind this var to the evidence+              -- EvVarDest is always used for non-type-equalities+              -- e.g. class constraints++  | HoleDest  CoercionHole  -- ^ fill in this hole with the evidence+              -- HoleDest is always used for type-equalities+              -- See Note [Coercion holes] in TyCoRep++data CtEvidence+  = CtGiven    -- Truly given, not depending on subgoals+      { ctev_pred :: TcPredType      -- See Note [Ct/evidence invariant]+      , ctev_evar :: EvVar           -- See Note [Evidence field of CtEvidence]+      , ctev_loc  :: CtLoc }+++  | CtWanted   -- Wanted goal+      { ctev_pred :: TcPredType     -- See Note [Ct/evidence invariant]+      , ctev_dest :: TcEvDest+      , ctev_nosh :: ShadowInfo     -- See Note [Constraint flavours]+      , ctev_loc  :: CtLoc }++  | CtDerived  -- A goal that we don't really have to solve and can't+               -- immediately rewrite anything other than a derived+               -- (there's no evidence!) but if we do manage to solve+               -- it may help in solving other goals.+      { ctev_pred :: TcPredType+      , ctev_loc  :: CtLoc }++ctEvPred :: CtEvidence -> TcPredType+-- The predicate of a flavor+ctEvPred = ctev_pred++ctEvLoc :: CtEvidence -> CtLoc+ctEvLoc = ctev_loc++ctEvOrigin :: CtEvidence -> CtOrigin+ctEvOrigin = ctLocOrigin . ctEvLoc++-- | Get the equality relation relevant for a 'CtEvidence'+ctEvEqRel :: CtEvidence -> EqRel+ctEvEqRel = predTypeEqRel . ctEvPred++-- | Get the role relevant for a 'CtEvidence'+ctEvRole :: CtEvidence -> Role+ctEvRole = eqRelRole . ctEvEqRel++ctEvTerm :: CtEvidence -> EvTerm+ctEvTerm ev@(CtWanted { ctev_dest = HoleDest _ }) = EvCoercion $ ctEvCoercion ev+ctEvTerm ev = EvId (ctEvId ev)++-- Always returns a coercion whose type is precisely ctev_pred of the CtEvidence.+-- See also Note [Given in ctEvCoercion]+ctEvCoercion :: CtEvidence -> Coercion+ctEvCoercion (CtGiven { ctev_pred = pred_ty, ctev_evar = ev_id })+  = mkTcCoVarCo (setVarType ev_id pred_ty)  -- See Note [Given in ctEvCoercion]+ctEvCoercion (CtWanted { ctev_dest = dest, ctev_pred = pred })+  | HoleDest hole <- dest+  , Just (role, ty1, ty2) <- getEqPredTys_maybe pred+  = -- ctEvCoercion is only called on type equalities+    -- and they always have HoleDests+    mkHoleCo hole role ty1 ty2+ctEvCoercion ev+  = pprPanic "ctEvCoercion" (ppr ev)++ctEvId :: CtEvidence -> TcId+ctEvId (CtWanted { ctev_dest = EvVarDest ev }) = ev+ctEvId (CtGiven  { ctev_evar = ev }) = ev+ctEvId ctev = pprPanic "ctEvId:" (ppr ctev)++instance Outputable TcEvDest where+  ppr (HoleDest h)   = text "hole" <> ppr h+  ppr (EvVarDest ev) = ppr ev++instance Outputable CtEvidence where+  ppr ev = ppr (ctEvFlavour ev)+           <+> pp_ev+           <+> braces (ppr (ctl_depth (ctEvLoc ev))) <> dcolon+                  -- Show the sub-goal depth too+           <+> ppr (ctEvPred ev)+    where+      pp_ev = case ev of+             CtGiven { ctev_evar = v } -> ppr v+             CtWanted {ctev_dest = d } -> ppr d+             CtDerived {}              -> text "_"++isWanted :: CtEvidence -> Bool+isWanted (CtWanted {}) = True+isWanted _ = False++isGiven :: CtEvidence -> Bool+isGiven (CtGiven {})  = True+isGiven _ = False++isDerived :: CtEvidence -> Bool+isDerived (CtDerived {}) = True+isDerived _              = False++{-+%************************************************************************+%*                                                                      *+            CtFlavour+%*                                                                      *+%************************************************************************++Note [Constraint flavours]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Constraints come in four flavours:++* [G] Given: we have evidence++* [W] Wanted WOnly: we want evidence++* [D] Derived: any solution must satisfy this constraint, but+      we don't need evidence for it.  Examples include:+        - superclasses of [W] class constraints+        - equalities arising from functional dependencies+          or injectivity++* [WD] Wanted WDeriv: a single constraint that represents+                      both [W] and [D]+  We keep them paired as one both for efficiency, and because+  when we have a finite map  F tys -> CFunEqCan, it's inconvenient+  to have two CFunEqCans in the range++The ctev_nosh field of a Wanted distinguishes between [W] and [WD]++Wanted constraints are born as [WD], but are split into [W] and its+"shadow" [D] in TcSMonad.maybeEmitShadow.++See Note [The improvement story and derived shadows] in TcSMonad+-}++data CtFlavour  -- See Note [Constraint flavours]+  = Given+  | Wanted ShadowInfo+  | Derived+  deriving Eq++data ShadowInfo+  = WDeriv   -- [WD] This Wanted constraint has no Derived shadow,+             -- so it behaves like a pair of a Wanted and a Derived+  | WOnly    -- [W] It has a separate derived shadow+             -- See Note [Derived shadows]+  deriving( Eq )++isGivenOrWDeriv :: CtFlavour -> Bool+isGivenOrWDeriv Given           = True+isGivenOrWDeriv (Wanted WDeriv) = True+isGivenOrWDeriv _               = False++instance Outputable CtFlavour where+  ppr Given           = text "[G]"+  ppr (Wanted WDeriv) = text "[WD]"+  ppr (Wanted WOnly)  = text "[W]"+  ppr Derived         = text "[D]"++ctEvFlavour :: CtEvidence -> CtFlavour+ctEvFlavour (CtWanted { ctev_nosh = nosh }) = Wanted nosh+ctEvFlavour (CtGiven {})                    = Given+ctEvFlavour (CtDerived {})                  = Derived++-- | Whether or not one 'Ct' can rewrite another is determined by its+-- flavour and its equality relation. See also+-- Note [Flavours with roles] in TcSMonad+type CtFlavourRole = (CtFlavour, EqRel)++-- | Extract the flavour, role, and boxity from a 'CtEvidence'+ctEvFlavourRole :: CtEvidence -> CtFlavourRole+ctEvFlavourRole ev = (ctEvFlavour ev, ctEvEqRel ev)++-- | Extract the flavour, role, and boxity from a 'Ct'+ctFlavourRole :: Ct -> CtFlavourRole+ctFlavourRole = ctEvFlavourRole . cc_ev++{- Note [eqCanRewrite]+~~~~~~~~~~~~~~~~~~~~~~+(eqCanRewrite ct1 ct2) holds if the constraint ct1 (a CTyEqCan of form+tv ~ ty) can be used to rewrite ct2.  It must satisfy the properties of+a can-rewrite relation, see Definition [Can-rewrite relation] in+TcSMonad.++With the solver handling Coercible constraints like equality constraints,+the rewrite conditions must take role into account, never allowing+a representational equality to rewrite a nominal one.++Note [Wanteds do not rewrite Wanteds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don't allow Wanteds to rewrite Wanteds, because that can give rise+to very confusing type error messages.  A good example is Trac #8450.+Here's another+   f :: a -> Bool+   f x = ( [x,'c'], [x,True] ) `seq` True+Here we get+  [W] a ~ Char+  [W] a ~ Bool+but we do not want to complain about Bool ~ Char!++Note [Deriveds do rewrite Deriveds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+However we DO allow Deriveds to rewrite Deriveds, because that's how+improvement works; see Note [The improvement story] in TcInteract.++However, for now at least I'm only letting (Derived,NomEq) rewrite+(Derived,NomEq) and not doing anything for ReprEq.  If we have+    eqCanRewriteFR (Derived, NomEq) (Derived, _)  = True+then we lose property R2 of Definition [Can-rewrite relation]+in TcSMonad+  R2.  If f1 >= f, and f2 >= f,+       then either f1 >= f2 or f2 >= f1+Consider f1 = (Given, ReprEq)+         f2 = (Derived, NomEq)+          f = (Derived, ReprEq)++I thought maybe we could never get Derived ReprEq constraints, but+we can; straight from the Wanteds during improvement. And from a Derived+ReprEq we could conceivably get a Derived NomEq improvement (by decomposing+a type constructor with Nomninal role), and hence unify.+-}++eqCanRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool+-- Can fr1 actually rewrite fr2?+-- Very important function!+-- See Note [eqCanRewrite]+-- See Note [Wanteds do not rewrite Wanteds]+-- See Note [Deriveds do rewrite Deriveds]+eqCanRewriteFR (Given, NomEq)         (_, _)           = True+eqCanRewriteFR (Given, ReprEq)        (_, ReprEq)      = True+eqCanRewriteFR (Wanted WDeriv, NomEq) (Derived, NomEq) = True+eqCanRewriteFR (Derived,       NomEq) (Derived, NomEq) = True+eqCanRewriteFR _                      _                = False++eqMayRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool+-- Is it /possible/ that fr1 can rewrite fr2?+-- This is used when deciding which inerts to kick out,+-- at which time a [WD] inert may be split into [W] and [D]+eqMayRewriteFR (Wanted WDeriv, NomEq) (Wanted WDeriv, NomEq) = True+eqMayRewriteFR (Derived,       NomEq) (Wanted WDeriv, NomEq) = True+eqMayRewriteFR fr1 fr2 = eqCanRewriteFR fr1 fr2++-----------------+{- Note [funEqCanDischarge]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have two CFunEqCans with the same LHS:+    (x1:F ts ~ f1) `funEqCanDischarge` (x2:F ts ~ f2)+Can we drop x2 in favour of x1, either unifying+f2 (if it's a flatten meta-var) or adding a new Given+(f1 ~ f2), if x2 is a Given?++Answer: yes if funEqCanDischarge is true.+-}++funEqCanDischarge+  :: CtEvidence -> CtEvidence+  -> ( SwapFlag   -- NotSwapped => lhs can discharge rhs+                  -- Swapped    => rhs can discharge lhs+     , Bool)      -- True <=> upgrade non-discharded one+                  --          from [W] to [WD]+-- See Note [funEqCanDischarge]+funEqCanDischarge ev1 ev2+  = ASSERT2( ctEvEqRel ev1 == NomEq, ppr ev1 )+    ASSERT2( ctEvEqRel ev2 == NomEq, ppr ev2 )+    -- CFunEqCans are all Nominal, hence asserts+    funEqCanDischargeF (ctEvFlavour ev1) (ctEvFlavour ev2)++funEqCanDischargeF :: CtFlavour -> CtFlavour -> (SwapFlag, Bool)+funEqCanDischargeF Given           _               = (NotSwapped, False)+funEqCanDischargeF _               Given           = (IsSwapped,  False)+funEqCanDischargeF (Wanted WDeriv) _               = (NotSwapped, False)+funEqCanDischargeF _               (Wanted WDeriv) = (IsSwapped,  True)+funEqCanDischargeF (Wanted WOnly)  (Wanted WOnly)  = (NotSwapped, False)+funEqCanDischargeF (Wanted WOnly)  Derived         = (NotSwapped, True)+funEqCanDischargeF Derived         (Wanted WOnly)  = (IsSwapped,  True)+funEqCanDischargeF Derived         Derived         = (NotSwapped, False)+++{- Note [eqCanDischarge]+~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have two identical CTyEqCan equality constraints+(i.e. both LHS and RHS are the same)+      (x1:a~t) `eqCanDischarge` (xs:a~t)+Can we just drop x2 in favour of x1?++Answer: yes if eqCanDischarge is true.++Note that we do /not/ allow Wanted to discharge Derived.+We must keep both.  Why?  Because the Derived may rewrite+other Deriveds in the model whereas the Wanted cannot.++However a Wanted can certainly discharge an identical Wanted.  So+eqCanDischarge does /not/ define a can-rewrite relation in the+sense of Definition [Can-rewrite relation] in TcSMonad.++We /do/ say that a [W] can discharge a [WD].  In evidence terms it+certainly can, and the /caller/ arranges that the otherwise-lost [D]+is spat out as a new Derived.  -}++eqCanDischarge :: CtEvidence -> CtEvidence -> Bool+-- See Note [eqCanDischarge]+eqCanDischarge ev1 ev2 = eqCanDischargeFR (ctEvFlavourRole ev1)+                                          (ctEvFlavourRole ev2)++eqCanDischargeFR :: CtFlavourRole -> CtFlavourRole -> Bool+eqCanDischargeFR (_, ReprEq) (_, NomEq) = False+eqCanDischargeFR (f1,_)      (f2, _)    = eqCanDischargeF f1 f2++eqCanDischargeF :: CtFlavour -> CtFlavour -> Bool+eqCanDischargeF Given   _                  = True+eqCanDischargeF (Wanted _)      (Wanted _) = True+eqCanDischargeF (Wanted WDeriv) Derived    = True+eqCanDischargeF Derived         Derived    = True+eqCanDischargeF _               _          = False+++{-+************************************************************************+*                                                                      *+            SubGoalDepth+*                                                                      *+************************************************************************++Note [SubGoalDepth]+~~~~~~~~~~~~~~~~~~~+The 'SubGoalDepth' takes care of stopping the constraint solver from looping.++The counter starts at zero and increases. It includes dictionary constraints,+equality simplification, and type family reduction. (Why combine these? Because+it's actually quite easy to mistake one for another, in sufficiently involved+scenarios, like ConstraintKinds.)++The flag -fcontext-stack=n (not very well named!) fixes the maximium+level.++* The counter includes the depth of type class instance declarations.  Example:+     [W] d{7} : Eq [Int]+  That is d's dictionary-constraint depth is 7.  If we use the instance+     $dfEqList :: Eq a => Eq [a]+  to simplify it, we get+     d{7} = $dfEqList d'{8}+  where d'{8} : Eq Int, and d' has depth 8.++  For civilised (decidable) instance declarations, each increase of+  depth removes a type constructor from the type, so the depth never+  gets big; i.e. is bounded by the structural depth of the type.++* The counter also increments when resolving+equalities involving type functions. Example:+  Assume we have a wanted at depth 7:+    [W] d{7} : F () ~ a+  If there is an type function equation "F () = Int", this would be rewritten to+    [W] d{8} : Int ~ a+  and remembered as having depth 8.++  Again, without UndecidableInstances, this counter is bounded, but without it+  can resolve things ad infinitum. Hence there is a maximum level.++* Lastly, every time an equality is rewritten, the counter increases. Again,+  rewriting an equality constraint normally makes progress, but it's possible+  the "progress" is just the reduction of an infinitely-reducing type family.+  Hence we need to track the rewrites.++When compiling a program requires a greater depth, then GHC recommends turning+off this check entirely by setting -freduction-depth=0. This is because the+exact number that works is highly variable, and is likely to change even between+minor releases. Because this check is solely to prevent infinite compilation+times, it seems safe to disable it when a user has ascertained that their program+doesn't loop at the type level.++-}++-- | See Note [SubGoalDepth]+newtype SubGoalDepth = SubGoalDepth Int+  deriving (Eq, Ord, Outputable)++initialSubGoalDepth :: SubGoalDepth+initialSubGoalDepth = SubGoalDepth 0++bumpSubGoalDepth :: SubGoalDepth -> SubGoalDepth+bumpSubGoalDepth (SubGoalDepth n) = SubGoalDepth (n + 1)++maxSubGoalDepth :: SubGoalDepth -> SubGoalDepth -> SubGoalDepth+maxSubGoalDepth (SubGoalDepth n) (SubGoalDepth m) = SubGoalDepth (n `max` m)++subGoalDepthExceeded :: DynFlags -> SubGoalDepth -> Bool+subGoalDepthExceeded dflags (SubGoalDepth d)+  = mkIntWithInf d > reductionDepth dflags++{-+************************************************************************+*                                                                      *+            CtLoc+*                                                                      *+************************************************************************++The 'CtLoc' gives information about where a constraint came from.+This is important for decent error message reporting because+dictionaries don't appear in the original source code.+type will evolve...+-}++data CtLoc = CtLoc { ctl_origin :: CtOrigin+                   , ctl_env    :: TcLclEnv+                   , ctl_t_or_k :: Maybe TypeOrKind  -- OK if we're not sure+                   , ctl_depth  :: !SubGoalDepth }+  -- The TcLclEnv includes particularly+  --    source location:  tcl_loc   :: RealSrcSpan+  --    context:          tcl_ctxt  :: [ErrCtxt]+  --    binder stack:     tcl_bndrs :: TcIdBinderStack+  --    level:            tcl_tclvl :: TcLevel++mkGivenLoc :: TcLevel -> SkolemInfo -> TcLclEnv -> CtLoc+mkGivenLoc tclvl skol_info env+  = CtLoc { ctl_origin = GivenOrigin skol_info+          , ctl_env    = env { tcl_tclvl = tclvl }+          , ctl_t_or_k = Nothing    -- this only matters for error msgs+          , ctl_depth  = initialSubGoalDepth }++mkKindLoc :: TcType -> TcType   -- original *types* being compared+          -> CtLoc -> CtLoc+mkKindLoc s1 s2 loc = setCtLocOrigin (toKindLoc loc)+                        (KindEqOrigin s1 (Just s2) (ctLocOrigin loc)+                                      (ctLocTypeOrKind_maybe loc))++-- | Take a CtLoc and moves it to the kind level+toKindLoc :: CtLoc -> CtLoc+toKindLoc loc = loc { ctl_t_or_k = Just KindLevel }++ctLocEnv :: CtLoc -> TcLclEnv+ctLocEnv = ctl_env++ctLocLevel :: CtLoc -> TcLevel+ctLocLevel loc = tcl_tclvl (ctLocEnv loc)++ctLocDepth :: CtLoc -> SubGoalDepth+ctLocDepth = ctl_depth++ctLocOrigin :: CtLoc -> CtOrigin+ctLocOrigin = ctl_origin++ctLocSpan :: CtLoc -> RealSrcSpan+ctLocSpan (CtLoc { ctl_env = lcl}) = tcl_loc lcl++ctLocTypeOrKind_maybe :: CtLoc -> Maybe TypeOrKind+ctLocTypeOrKind_maybe = ctl_t_or_k++setCtLocSpan :: CtLoc -> RealSrcSpan -> CtLoc+setCtLocSpan ctl@(CtLoc { ctl_env = lcl }) loc = setCtLocEnv ctl (lcl { tcl_loc = loc })++bumpCtLocDepth :: CtLoc -> CtLoc+bumpCtLocDepth loc@(CtLoc { ctl_depth = d }) = loc { ctl_depth = bumpSubGoalDepth d }++setCtLocOrigin :: CtLoc -> CtOrigin -> CtLoc+setCtLocOrigin ctl orig = ctl { ctl_origin = orig }++setCtLocEnv :: CtLoc -> TcLclEnv -> CtLoc+setCtLocEnv ctl env = ctl { ctl_env = env }++pushErrCtxt :: CtOrigin -> ErrCtxt -> CtLoc -> CtLoc+pushErrCtxt o err loc@(CtLoc { ctl_env = lcl })+  = loc { ctl_origin = o, ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } }++pushErrCtxtSameOrigin :: ErrCtxt -> CtLoc -> CtLoc+-- Just add information w/o updating the origin!+pushErrCtxtSameOrigin err loc@(CtLoc { ctl_env = lcl })+  = loc { ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } }++{-+************************************************************************+*                                                                      *+                SkolemInfo+*                                                                      *+************************************************************************+-}++-- SkolemInfo gives the origin of *given* constraints+--   a) type variables are skolemised+--   b) an implication constraint is generated+data SkolemInfo+  = SigSkol -- A skolem that is created by instantiating+            -- a programmer-supplied type signature+            -- Location of the binding site is on the TyVar+            -- See Note [SigSkol SkolemInfo]+       UserTypeCtxt        -- What sort of signature+       TcType              -- Original type signature (before skolemisation)+       [(Name,TcTyVar)]    -- Maps the original name of the skolemised tyvar+                           -- to its instantiated version++  | ClsSkol Class       -- Bound at a class decl++  | DerivSkol Type      -- Bound by a 'deriving' clause;+                        -- the type is the instance we are trying to derive++  | InstSkol            -- Bound at an instance decl+  | InstSC TypeSize     -- A "given" constraint obtained by superclass selection.+                        -- If (C ty1 .. tyn) is the largest class from+                        --    which we made a superclass selection in the chain,+                        --    then TypeSize = sizeTypes [ty1, .., tyn]+                        -- See Note [Solving superclass constraints] in TcInstDcls++  | DataSkol            -- Bound at a data type declaration+  | FamInstSkol         -- Bound at a family instance decl+  | PatSkol             -- An existential type variable bound by a pattern for+      ConLike           -- a data constructor with an existential type.+      (HsMatchContext Name)+             -- e.g.   data T = forall a. Eq a => MkT a+             --        f (MkT x) = ...+             -- The pattern MkT x will allocate an existential type+             -- variable for 'a'.++  | ArrowSkol           -- An arrow form (see TcArrows)++  | IPSkol [HsIPName]   -- Binding site of an implicit parameter++  | RuleSkol RuleName   -- The LHS of a RULE++  | InferSkol [(Name,TcType)]+                        -- We have inferred a type for these (mutually-recursivive)+                        -- polymorphic Ids, and are now checking that their RHS+                        -- constraints are satisfied.++  | BracketSkol         -- Template Haskell bracket++  | UnifyForAllSkol     -- We are unifying two for-all types+       TcType           -- The instantiated type *inside* the forall++  | UnkSkol             -- Unhelpful info (until I improve it)++instance Outputable SkolemInfo where+  ppr = pprSkolInfo++termEvidenceAllowed :: SkolemInfo -> Bool+-- Whether an implication constraint with this SkolemInfo+-- is permitted to have term-level evidence.  There is+-- only one that is not, associated with unifiying+-- forall-types+termEvidenceAllowed (UnifyForAllSkol {}) = False+termEvidenceAllowed _                    = True++pprSkolInfo :: SkolemInfo -> SDoc+-- Complete the sentence "is a rigid type variable bound by..."+pprSkolInfo (SigSkol cx ty _) = pprSigSkolInfo cx ty+pprSkolInfo (IPSkol ips)      = text "the implicit-parameter binding" <> plural ips <+> text "for"+                                 <+> pprWithCommas ppr ips+pprSkolInfo (ClsSkol cls)     = text "the class declaration for" <+> quotes (ppr cls)+pprSkolInfo (DerivSkol pred)  = text "the deriving clause for" <+> quotes (ppr pred)+pprSkolInfo InstSkol          = text "the instance declaration"+pprSkolInfo (InstSC n)        = text "the instance declaration" <> ifPprDebug (parens (ppr n))+pprSkolInfo DataSkol          = text "a data type declaration"+pprSkolInfo FamInstSkol       = text "a family instance declaration"+pprSkolInfo BracketSkol       = text "a Template Haskell bracket"+pprSkolInfo (RuleSkol name)   = text "the RULE" <+> pprRuleName name+pprSkolInfo ArrowSkol         = text "an arrow form"+pprSkolInfo (PatSkol cl mc)   = sep [ pprPatSkolInfo cl+                                    , text "in" <+> pprMatchContext mc ]+pprSkolInfo (InferSkol ids)   = sep [ text "the inferred type of"+                                    , vcat [ ppr name <+> dcolon <+> ppr ty+                                           | (name,ty) <- ids ]]+pprSkolInfo (UnifyForAllSkol ty) = text "the type" <+> ppr ty++-- UnkSkol+-- For type variables the others are dealt with by pprSkolTvBinding.+-- For Insts, these cases should not happen+pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) text "UnkSkol"++pprSigSkolInfo :: UserTypeCtxt -> TcType -> SDoc+-- The type is already tidied+pprSigSkolInfo ctxt ty+  = case ctxt of+       FunSigCtxt f _ -> vcat [ text "the type signature for:"+                              , nest 2 (pprPrefixOcc f <+> dcolon <+> ppr ty) ]+       PatSynCtxt {}  -> pprUserTypeCtxt ctxt  -- See Note [Skolem info for pattern synonyms]+       _              -> vcat [ pprUserTypeCtxt ctxt <> colon+                              , nest 2 (ppr ty) ]++pprPatSkolInfo :: ConLike -> SDoc+pprPatSkolInfo (RealDataCon dc)+  = sep [ text "a pattern with constructor:"+        , nest 2 $ ppr dc <+> dcolon+          <+> pprType (dataConUserType dc) <> comma ]+          -- pprType prints forall's regardless of -fprint-explicit-foralls+          -- which is what we want here, since we might be saying+          -- type variable 't' is bound by ...++pprPatSkolInfo (PatSynCon ps)+  = sep [ text "a pattern with pattern synonym:"+        , nest 2 $ ppr ps <+> dcolon+                   <+> pprPatSynType ps <> comma ]++{- Note [Skolem info for pattern synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For pattern synonym SkolemInfo we have+   SigSkol (PatSynCtxt p) ty _+but the type 'ty' is not very helpful.  The full pattern-synonym type+has the provided and required pieces, which it is inconvenient to+record and display here. So we simply don't display the type at all,+contenting outselves with just the name of the pattern synonym, which+is fine.  We could do more, but it doesn't seem worth it.++Note [SigSkol SkolemInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we (deeply) skolemise a type+   f :: forall a. a -> forall b. b -> a+Then we'll instantiate [a :-> a', b :-> b'], and with the instantiated+      a' -> b' -> a.+But when, in an error message, we report that "b is a rigid type+variable bound by the type signature for f", we want to show the foralls+in the right place.  So we proceed as follows:++* In SigSkol we record+    - the original signature forall a. a -> forall b. b -> a+    - the instantiation mapping [a :-> a', b :-> b']++* Then when tidying in TcMType.tidySkolemInfo, we first tidy a' to+  whatever it tidies to, say a''; and then we walk over the type+  replacing the binder a by the tidied version a'', to give+       forall a''. a'' -> forall b''. b'' -> a''+  We need to do this under function arrows, to match what deeplySkolemise+  does.++* Typically a'' will have a nice pretty name like "a", but the point is+  that the foral-bound variables of the signature we report line up with+  the instantiated skolems lying  around in other types.+++************************************************************************+*                                                                      *+            CtOrigin+*                                                                      *+************************************************************************+-}++data CtOrigin+  = GivenOrigin SkolemInfo++  -- All the others are for *wanted* constraints+  | OccurrenceOf Name              -- Occurrence of an overloaded identifier+  | OccurrenceOfRecSel RdrName     -- Occurrence of a record selector+  | AppOrigin                      -- An application of some kind++  | SpecPragOrigin UserTypeCtxt    -- Specialisation pragma for+                                   -- function or instance++  | TypeEqOrigin { uo_actual   :: TcType+                 , uo_expected :: TcType+                 , uo_thing    :: Maybe ErrorThing+                                  -- ^ The thing that has type "actual"+                 }++  | KindEqOrigin+      TcType (Maybe TcType)     -- A kind equality arising from unifying these two types+      CtOrigin                  -- originally arising from this+      (Maybe TypeOrKind)        -- the level of the eq this arises from++  | IPOccOrigin  HsIPName       -- Occurrence of an implicit parameter+  | OverLabelOrigin FastString  -- Occurrence of an overloaded label++  | LiteralOrigin (HsOverLit Name)      -- Occurrence of a literal+  | NegateOrigin                        -- Occurrence of syntactic negation++  | ArithSeqOrigin (ArithSeqInfo Name) -- [x..], [x..y] etc+  | PArrSeqOrigin  (ArithSeqInfo Name) -- [:x..y:] and [:x,y..z:]+  | SectionOrigin+  | TupleOrigin                        -- (..,..)+  | ExprSigOrigin       -- e :: ty+  | PatSigOrigin        -- p :: ty+  | PatOrigin           -- Instantiating a polytyped pattern at a constructor+  | ProvCtxtOrigin      -- The "provided" context of a pattern synonym signature+        (PatSynBind Name Name) -- Information about the pattern synonym, in particular+                               -- the name and the right-hand side+  | RecordUpdOrigin+  | ViewPatOrigin++  | ScOrigin TypeSize   -- Typechecking superclasses of an instance declaration+                        -- If the instance head is C ty1 .. tyn+                        --    then TypeSize = sizeTypes [ty1, .., tyn]+                        -- See Note [Solving superclass constraints] in TcInstDcls++  | DerivOrigin         -- Typechecking deriving+  | DerivOriginDC DataCon Int+                        -- Checking constraints arising from this data con and field index+  | DerivOriginCoerce Id Type Type+                        -- DerivOriginCoerce id ty1 ty2: Trying to coerce class method `id` from+                        -- `ty1` to `ty2`.+  | StandAloneDerivOrigin -- Typechecking stand-alone deriving+  | DefaultOrigin       -- Typechecking a default decl+  | DoOrigin            -- Arising from a do expression+  | DoPatOrigin (LPat Name) -- Arising from a failable pattern in+                            -- a do expression+  | MCompOrigin         -- Arising from a monad comprehension+  | MCompPatOrigin (LPat Name) -- Arising from a failable pattern in a+                               -- monad comprehension+  | IfOrigin            -- Arising from an if statement+  | ProcOrigin          -- Arising from a proc expression+  | AnnOrigin           -- An annotation++  | FunDepOrigin1       -- A functional dependency from combining+        PredType CtLoc      -- This constraint arising from ...+        PredType CtLoc      -- and this constraint arising from ...++  | FunDepOrigin2       -- A functional dependency from combining+        PredType CtOrigin   -- This constraint arising from ...+        PredType SrcSpan    -- and this top-level instance+        -- We only need a CtOrigin on the first, because the location+        -- is pinned on the entire error message++  | HoleOrigin+  | UnboundOccurrenceOf OccName+  | ListOrigin          -- An overloaded list+  | StaticOrigin        -- A static form+  | FailablePattern (LPat TcId) -- A failable pattern in do-notation for the+                                -- MonadFail Proposal (MFP). Obsolete when+                                -- actual desugaring to MonadFail.fail is live.+  | Shouldn'tHappenOrigin String+                            -- the user should never see this one,+                            -- unless ImpredicativeTypes is on, where all+                            -- bets are off+  | InstProvidedOrigin Module ClsInst+        -- Skolem variable arose when we were testing if an instance+        -- is solvable or not.++-- | A thing that can be stored for error message generation only.+-- It is stored with a function to zonk and tidy the thing.+data ErrorThing+  = forall a. Outputable a => ErrorThing a+                                         (Maybe Arity)  -- # of args, if known+                                         (TidyEnv -> a -> TcM (TidyEnv, a))++-- | Flag to see whether we're type-checking terms or kind-checking types+data TypeOrKind = TypeLevel | KindLevel+  deriving Eq++instance Outputable TypeOrKind where+  ppr TypeLevel = text "TypeLevel"+  ppr KindLevel = text "KindLevel"++isTypeLevel :: TypeOrKind -> Bool+isTypeLevel TypeLevel = True+isTypeLevel KindLevel = False++isKindLevel :: TypeOrKind -> Bool+isKindLevel TypeLevel = False+isKindLevel KindLevel = True++-- | Make an 'ErrorThing' that doesn't need tidying or zonking+mkErrorThing :: Outputable a => a -> ErrorThing+mkErrorThing thing = ErrorThing thing Nothing (\env x -> return (env, x))++-- | Retrieve the # of arguments in the error thing, if known+errorThingNumArgs_maybe :: ErrorThing -> Maybe Arity+errorThingNumArgs_maybe (ErrorThing _ args _) = args++instance Outputable CtOrigin where+  ppr = pprCtOrigin++instance Outputable ErrorThing where+  ppr (ErrorThing thing _ _) = ppr thing++ctoHerald :: SDoc+ctoHerald = text "arising from"++-- | Extract a suitable CtOrigin from a HsExpr+lexprCtOrigin :: LHsExpr Name -> CtOrigin+lexprCtOrigin (L _ e) = exprCtOrigin e++exprCtOrigin :: HsExpr Name -> CtOrigin+exprCtOrigin (HsVar (L _ name)) = OccurrenceOf name+exprCtOrigin (HsUnboundVar uv)  = UnboundOccurrenceOf (unboundVarOcc uv)+exprCtOrigin (HsConLikeOut {})  = panic "exprCtOrigin HsConLikeOut"+exprCtOrigin (HsRecFld f)       = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f)+exprCtOrigin (HsOverLabel _ l)  = OverLabelOrigin l+exprCtOrigin (HsIPVar ip)       = IPOccOrigin ip+exprCtOrigin (HsOverLit lit)    = LiteralOrigin lit+exprCtOrigin (HsLit {})         = Shouldn'tHappenOrigin "concrete literal"+exprCtOrigin (HsLam matches)    = matchesCtOrigin matches+exprCtOrigin (HsLamCase ms)     = matchesCtOrigin ms+exprCtOrigin (HsApp e1 _)       = lexprCtOrigin e1+exprCtOrigin (HsAppType e1 _)   = lexprCtOrigin e1+exprCtOrigin (HsAppTypeOut {})  = panic "exprCtOrigin HsAppTypeOut"+exprCtOrigin (OpApp _ op _ _)   = lexprCtOrigin op+exprCtOrigin (NegApp e _)       = lexprCtOrigin e+exprCtOrigin (HsPar e)          = lexprCtOrigin e+exprCtOrigin (SectionL _ _)     = SectionOrigin+exprCtOrigin (SectionR _ _)     = SectionOrigin+exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple"+exprCtOrigin ExplicitSum{}      = Shouldn'tHappenOrigin "explicit sum"+exprCtOrigin (HsCase _ matches) = matchesCtOrigin matches+exprCtOrigin (HsIf (Just syn) _ _ _) = exprCtOrigin (syn_expr syn)+exprCtOrigin (HsIf {})          = Shouldn'tHappenOrigin "if expression"+exprCtOrigin (HsMultiIf _ rhs)  = lGRHSCtOrigin rhs+exprCtOrigin (HsLet _ e)        = lexprCtOrigin e+exprCtOrigin (HsDo _ _ _)       = DoOrigin+exprCtOrigin (ExplicitList {})  = Shouldn'tHappenOrigin "list"+exprCtOrigin (ExplicitPArr {})  = Shouldn'tHappenOrigin "parallel array"+exprCtOrigin (RecordCon {})     = Shouldn'tHappenOrigin "record construction"+exprCtOrigin (RecordUpd {})     = Shouldn'tHappenOrigin "record update"+exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin+exprCtOrigin (ExprWithTySigOut {}) = panic "exprCtOrigin ExprWithTySigOut"+exprCtOrigin (ArithSeq {})      = Shouldn'tHappenOrigin "arithmetic sequence"+exprCtOrigin (PArrSeq {})       = Shouldn'tHappenOrigin "parallel array sequence"+exprCtOrigin (HsSCC _ _ e)      = lexprCtOrigin e+exprCtOrigin (HsCoreAnn _ _ e)  = lexprCtOrigin e+exprCtOrigin (HsBracket {})     = Shouldn'tHappenOrigin "TH bracket"+exprCtOrigin (HsRnBracketOut {})= Shouldn'tHappenOrigin "HsRnBracketOut"+exprCtOrigin (HsTcBracketOut {})= panic "exprCtOrigin HsTcBracketOut"+exprCtOrigin (HsSpliceE {})     = Shouldn'tHappenOrigin "TH splice"+exprCtOrigin (HsProc {})        = Shouldn'tHappenOrigin "proc"+exprCtOrigin (HsStatic {})      = Shouldn'tHappenOrigin "static expression"+exprCtOrigin (HsArrApp {})      = panic "exprCtOrigin HsArrApp"+exprCtOrigin (HsArrForm {})     = panic "exprCtOrigin HsArrForm"+exprCtOrigin (HsTick _ e)       = lexprCtOrigin e+exprCtOrigin (HsBinTick _ _ e)  = lexprCtOrigin e+exprCtOrigin (HsTickPragma _ _ _ e) = lexprCtOrigin e+exprCtOrigin EWildPat           = panic "exprCtOrigin EWildPat"+exprCtOrigin (EAsPat {})        = panic "exprCtOrigin EAsPat"+exprCtOrigin (EViewPat {})      = panic "exprCtOrigin EViewPat"+exprCtOrigin (ELazyPat {})      = panic "exprCtOrigin ELazyPat"+exprCtOrigin (HsWrap {})        = panic "exprCtOrigin HsWrap"++-- | Extract a suitable CtOrigin from a MatchGroup+matchesCtOrigin :: MatchGroup Name (LHsExpr Name) -> CtOrigin+matchesCtOrigin (MG { mg_alts = alts })+  | L _ [L _ match] <- alts+  , Match { m_grhss = grhss } <- match+  = grhssCtOrigin grhss++  | otherwise+  = Shouldn'tHappenOrigin "multi-way match"++-- | Extract a suitable CtOrigin from guarded RHSs+grhssCtOrigin :: GRHSs Name (LHsExpr Name) -> CtOrigin+grhssCtOrigin (GRHSs { grhssGRHSs = lgrhss }) = lGRHSCtOrigin lgrhss++-- | Extract a suitable CtOrigin from a list of guarded RHSs+lGRHSCtOrigin :: [LGRHS Name (LHsExpr Name)] -> CtOrigin+lGRHSCtOrigin [L _ (GRHS _ (L _ e))] = exprCtOrigin e+lGRHSCtOrigin _ = Shouldn'tHappenOrigin "multi-way GRHS"++pprCtLoc :: CtLoc -> SDoc+-- "arising from ... at ..."+-- Not an instance of Outputable because of the "arising from" prefix+pprCtLoc (CtLoc { ctl_origin = o, ctl_env = lcl})+  = sep [ pprCtOrigin o+        , text "at" <+> ppr (tcl_loc lcl)]++pprCtOrigin :: CtOrigin -> SDoc+-- "arising from ..."+-- Not an instance of Outputable because of the "arising from" prefix+pprCtOrigin (GivenOrigin sk) = ctoHerald <+> ppr sk++pprCtOrigin (SpecPragOrigin ctxt)+  = case ctxt of+       FunSigCtxt n _ -> text "a SPECIALISE pragma for" <+> quotes (ppr n)+       SpecInstCtxt   -> text "a SPECIALISE INSTANCE pragma"+       _              -> text "a SPECIALISE pragma"  -- Never happens I think++pprCtOrigin (FunDepOrigin1 pred1 loc1 pred2 loc2)+  = hang (ctoHerald <+> text "a functional dependency between constraints:")+       2 (vcat [ hang (quotes (ppr pred1)) 2 (pprCtLoc loc1)+               , hang (quotes (ppr pred2)) 2 (pprCtLoc loc2) ])++pprCtOrigin (FunDepOrigin2 pred1 orig1 pred2 loc2)+  = hang (ctoHerald <+> text "a functional dependency between:")+       2 (vcat [ hang (text "constraint" <+> quotes (ppr pred1))+                    2 (pprCtOrigin orig1 )+               , hang (text "instance" <+> quotes (ppr pred2))+                    2 (text "at" <+> ppr loc2) ])++pprCtOrigin (KindEqOrigin t1 (Just t2) _ _)+  = hang (ctoHerald <+> text "a kind equality arising from")+       2 (sep [ppr t1, char '~', ppr t2])++pprCtOrigin (KindEqOrigin t1 Nothing _ _)+  = hang (ctoHerald <+> text "a kind equality when matching")+       2 (ppr t1)++pprCtOrigin (UnboundOccurrenceOf name)+  = ctoHerald <+> text "an undeclared identifier" <+> quotes (ppr name)++pprCtOrigin (DerivOriginDC dc n)+  = hang (ctoHerald <+> text "the" <+> speakNth n+          <+> text "field of" <+> quotes (ppr dc))+       2 (parens (text "type" <+> quotes (ppr ty)))+  where+    ty = dataConOrigArgTys dc !! (n-1)++pprCtOrigin (DerivOriginCoerce meth ty1 ty2)+  = hang (ctoHerald <+> text "the coercion of the method" <+> quotes (ppr meth))+       2 (sep [ text "from type" <+> quotes (ppr ty1)+              , nest 2 $ text "to type" <+> quotes (ppr ty2) ])++pprCtOrigin (DoPatOrigin pat)+    = ctoHerald <+> text "a do statement"+      $$+      text "with the failable pattern" <+> quotes (ppr pat)++pprCtOrigin (MCompPatOrigin pat)+    = ctoHerald <+> hsep [ text "the failable pattern"+           , quotes (ppr pat)+           , text "in a statement in a monad comprehension" ]+pprCtOrigin (FailablePattern pat)+    = ctoHerald <+> text "the failable pattern" <+> quotes (ppr pat)+      $$+      text "(this will become an error in a future GHC release)"++pprCtOrigin (Shouldn'tHappenOrigin note)+  = sdocWithDynFlags $ \dflags ->+    if xopt LangExt.ImpredicativeTypes dflags+    then text "a situation created by impredicative types"+    else+    vcat [ text "<< This should not appear in error messages. If you see this"+         , text "in an error message, please report a bug mentioning" <+> quotes (text note) <+> text "at"+         , text "https://ghc.haskell.org/trac/ghc/wiki/ReportABug >>" ]++pprCtOrigin (ProvCtxtOrigin PSB{ psb_id = (L _ name) })+  = hang (ctoHerald <+> text "the \"provided\" constraints claimed by")+       2 (text "the signature of" <+> quotes (ppr name))++pprCtOrigin (InstProvidedOrigin mod cls_inst)+  = vcat [ text "arising when attempting to show that"+         , ppr cls_inst+         , text "is provided by" <+> quotes (ppr mod)]++pprCtOrigin simple_origin+  = ctoHerald <+> pprCtO simple_origin++-- | Short one-liners+pprCtO :: CtOrigin -> SDoc+pprCtO (OccurrenceOf name)   = hsep [text "a use of", quotes (ppr name)]+pprCtO (OccurrenceOfRecSel name) = hsep [text "a use of", quotes (ppr name)]+pprCtO AppOrigin             = text "an application"+pprCtO (IPOccOrigin name)    = hsep [text "a use of implicit parameter", quotes (ppr name)]+pprCtO (OverLabelOrigin l)   = hsep [text "the overloaded label"+                                    ,quotes (char '#' <> ppr l)]+pprCtO RecordUpdOrigin       = text "a record update"+pprCtO ExprSigOrigin         = text "an expression type signature"+pprCtO PatSigOrigin          = text "a pattern type signature"+pprCtO PatOrigin             = text "a pattern"+pprCtO ViewPatOrigin         = text "a view pattern"+pprCtO IfOrigin              = text "an if expression"+pprCtO (LiteralOrigin lit)   = hsep [text "the literal", quotes (ppr lit)]+pprCtO (ArithSeqOrigin seq)  = hsep [text "the arithmetic sequence", quotes (ppr seq)]+pprCtO (PArrSeqOrigin seq)   = hsep [text "the parallel array sequence", quotes (ppr seq)]+pprCtO SectionOrigin         = text "an operator section"+pprCtO TupleOrigin           = text "a tuple"+pprCtO NegateOrigin          = text "a use of syntactic negation"+pprCtO (ScOrigin n)          = text "the superclasses of an instance declaration"+                               <> ifPprDebug (parens (ppr n))+pprCtO DerivOrigin           = text "the 'deriving' clause of a data type declaration"+pprCtO StandAloneDerivOrigin = text "a 'deriving' declaration"+pprCtO DefaultOrigin         = text "a 'default' declaration"+pprCtO DoOrigin              = text "a do statement"+pprCtO MCompOrigin           = text "a statement in a monad comprehension"+pprCtO ProcOrigin            = text "a proc expression"+pprCtO (TypeEqOrigin t1 t2 _)= text "a type equality" <+> sep [ppr t1, char '~', ppr t2]+pprCtO AnnOrigin             = text "an annotation"+pprCtO HoleOrigin            = text "a use of" <+> quotes (text "_")+pprCtO ListOrigin            = text "an overloaded list"+pprCtO StaticOrigin          = text "a static form"+pprCtO _                     = panic "pprCtOrigin"++{-+Constraint Solver Plugins+-------------------------+-}++type TcPluginSolver = [Ct]    -- given+                   -> [Ct]    -- derived+                   -> [Ct]    -- wanted+                   -> TcPluginM TcPluginResult++newtype TcPluginM a = TcPluginM (EvBindsVar -> TcM a)++instance Functor TcPluginM where+  fmap = liftM++instance Applicative TcPluginM where+  pure x = TcPluginM (const $ pure x)+  (<*>) = ap++instance Monad TcPluginM where+  fail x   = TcPluginM (const $ fail x)+  TcPluginM m >>= k =+    TcPluginM (\ ev -> do a <- m ev+                          runTcPluginM (k a) ev)++#if __GLASGOW_HASKELL__ > 710+instance MonadFail.MonadFail TcPluginM where+  fail x   = TcPluginM (const $ fail x)+#endif++runTcPluginM :: TcPluginM a -> EvBindsVar -> TcM a+runTcPluginM (TcPluginM m) = m++-- | This function provides an escape for direct access to+-- the 'TcM` monad.  It should not be used lightly, and+-- the provided 'TcPluginM' API should be favoured instead.+unsafeTcPluginTcM :: TcM a -> TcPluginM a+unsafeTcPluginTcM = TcPluginM . const++-- | Access the 'EvBindsVar' carried by the 'TcPluginM' during+-- constraint solving.  Returns 'Nothing' if invoked during+-- 'tcPluginInit' or 'tcPluginStop'.+getEvBindsTcPluginM :: TcPluginM EvBindsVar+getEvBindsTcPluginM = TcPluginM return+++data TcPlugin = forall s. TcPlugin+  { tcPluginInit  :: TcPluginM s+    -- ^ Initialize plugin, when entering type-checker.++  , tcPluginSolve :: s -> TcPluginSolver+    -- ^ Solve some constraints.+    -- TODO: WRITE MORE DETAILS ON HOW THIS WORKS.++  , tcPluginStop  :: s -> TcPluginM ()+   -- ^ Clean up after the plugin, when exiting the type-checker.+  }++data TcPluginResult+  = TcPluginContradiction [Ct]+    -- ^ The plugin found a contradiction.+    -- The returned constraints are removed from the inert set,+    -- and recorded as insoluble.++  | TcPluginOk [(EvTerm,Ct)] [Ct]+    -- ^ The first field is for constraints that were solved.+    -- These are removed from the inert set,+    -- and the evidence for them is recorded.+    -- The second field contains new work, that should be processed by+    -- the constraint solver.
+ typecheck/TcRules.hs view
@@ -0,0 +1,365 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1993-1998+++TcRules: Typechecking transformation rules+-}++{-# LANGUAGE ViewPatterns #-}++module TcRules ( tcRules ) where++import HsSyn+import TcRnMonad+import TcSimplify+import TcMType+import TcType+import TcHsType+import TcExpr+import TcEnv+import TcUnify( buildImplicationFor )+import TcEvidence( mkTcCoVarCo )+import Type+import Id+import Var( EvVar )+import Name+import BasicTypes       ( RuleName )+import SrcLoc+import Outputable+import FastString+import Bag+import Data.List( partition )++{-+Note [Typechecking rules]+~~~~~~~~~~~~~~~~~~~~~~~~~+We *infer* the typ of the LHS, and use that type to *check* the type of+the RHS.  That means that higher-rank rules work reasonably well. Here's+an example (test simplCore/should_compile/rule2.hs) produced by Roman:++   foo :: (forall m. m a -> m b) -> m a -> m b+   foo f = ...++   bar :: (forall m. m a -> m a) -> m a -> m a+   bar f = ...++   {-# RULES "foo/bar" foo = bar #-}++He wanted the rule to typecheck.+-}++tcRules :: [LRuleDecls Name] -> TcM [LRuleDecls TcId]+tcRules decls = mapM (wrapLocM tcRuleDecls) decls++tcRuleDecls :: RuleDecls Name -> TcM (RuleDecls TcId)+tcRuleDecls (HsRules src decls)+   = do { tc_decls <- mapM (wrapLocM tcRule) decls+        ; return (HsRules src tc_decls) }++tcRule :: RuleDecl Name -> TcM (RuleDecl TcId)+tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)+  = addErrCtxt (ruleCtxt $ snd $ unLoc name)  $+    do { traceTc "---- Rule ------" (pprFullRuleName name)++        -- Note [Typechecking rules]+       ; (vars, bndr_wanted) <- captureConstraints $+                                tcRuleBndrs hs_bndrs+              -- bndr_wanted constraints can include wildcard hole+              -- constraints, which we should not forget about.+              -- It may mention the skolem type variables bound by+              -- the RULE.  c.f. Trac #10072++       ; let (id_bndrs, tv_bndrs) = partition isId vars+       ; (lhs', lhs_wanted, rhs', rhs_wanted, rule_ty)+            <- tcExtendTyVarEnv tv_bndrs $+               tcExtendIdEnv    id_bndrs $+               do { -- See Note [Solve order for RULES]+                    ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs)+                  ; (rhs', rhs_wanted) <- captureConstraints $+                                          tcMonoExpr rhs (mkCheckExpType rule_ty)+                  ; return (lhs', lhs_wanted, rhs', rhs_wanted, rule_ty) }++       ; traceTc "tcRule 1" (vcat [ pprFullRuleName name+                                  , ppr lhs_wanted+                                  , ppr rhs_wanted ])+       ; let all_lhs_wanted = bndr_wanted `andWC` lhs_wanted+       ; (lhs_evs, residual_lhs_wanted) <- simplifyRule (snd $ unLoc name)+                                              all_lhs_wanted+                                              rhs_wanted++       -- SimplfyRule Plan, step 4+       -- Now figure out what to quantify over+       -- c.f. TcSimplify.simplifyInfer+       -- We quantify over any tyvars free in *either* the rule+       --  *or* the bound variables.  The latter is important.  Consider+       --      ss (x,(y,z)) = (x,z)+       --      RULE:  forall v. fst (ss v) = fst v+       -- The type of the rhs of the rule is just a, but v::(a,(b,c))+       --+       -- We also need to get the completely-uconstrained tyvars of+       -- the LHS, lest they otherwise get defaulted to Any; but we do that+       -- during zonking (see TcHsSyn.zonkRule)++       ; let tpl_ids = lhs_evs ++ id_bndrs+       ; forall_tkvs <- zonkTcTypesAndSplitDepVars $+                        rule_ty : map idType tpl_ids+       ; gbls  <- tcGetGlobalTyCoVars -- Even though top level, there might be top-level+                                      -- monomorphic bindings from the MR; test tc111+       ; qtkvs <- quantifyZonkedTyVars gbls forall_tkvs+       ; traceTc "tcRule" (vcat [ pprFullRuleName name+                                , ppr forall_tkvs+                                , ppr qtkvs+                                , ppr rule_ty+                                , vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ]+                  ])++       -- SimplfyRule Plan, step 5+       -- Simplify the LHS and RHS constraints:+       -- For the LHS constraints we must solve the remaining constraints+       -- (a) so that we report insoluble ones+       -- (b) so that we bind any soluble ones+       ; let skol_info = RuleSkol (snd (unLoc name))+       ; (lhs_implic, lhs_binds) <- buildImplicationFor topTcLevel skol_info qtkvs+                                         lhs_evs residual_lhs_wanted+       ; (rhs_implic, rhs_binds) <- buildImplicationFor topTcLevel skol_info qtkvs+                                         lhs_evs rhs_wanted++       ; emitImplications (lhs_implic `unionBags` rhs_implic)+       ; return (HsRule name act+                    (map (noLoc . RuleBndr . noLoc) (qtkvs ++ tpl_ids))+                    (mkHsDictLet lhs_binds lhs') fv_lhs+                    (mkHsDictLet rhs_binds rhs') fv_rhs) }++tcRuleBndrs :: [LRuleBndr Name] -> TcM [Var]+tcRuleBndrs []+  = return []+tcRuleBndrs (L _ (RuleBndr (L _ name)) : rule_bndrs)+  = do  { ty <- newOpenFlexiTyVarTy+        ; vars <- tcRuleBndrs rule_bndrs+        ; return (mkLocalId name ty : vars) }+tcRuleBndrs (L _ (RuleBndrSig (L _ name) rn_ty) : rule_bndrs)+--  e.g         x :: a->a+--  The tyvar 'a' is brought into scope first, just as if you'd written+--              a::*, x :: a->a+  = do  { let ctxt = RuleSigCtxt name+        ; (_ , tvs, id_ty) <- tcHsPatSigType ctxt rn_ty+        ; let id  = mkLocalIdOrCoVar name id_ty+                    -- See Note [Pattern signature binders] in TcHsType++              -- The type variables scope over subsequent bindings; yuk+        ; vars <- tcExtendTyVarEnv2 tvs $+                  tcRuleBndrs rule_bndrs+        ; return (map snd tvs ++ id : vars) }++ruleCtxt :: FastString -> SDoc+ruleCtxt name = text "When checking the transformation rule" <+>+                doubleQuotes (ftext name)+++{-+*********************************************************************************+*                                                                                 *+              Constraint simplification for rules+*                                                                                 *+***********************************************************************************++Note [The SimplifyRule Plan]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Example.  Consider the following left-hand side of a rule+        f (x == y) (y > z) = ...+If we typecheck this expression we get constraints+        d1 :: Ord a, d2 :: Eq a+We do NOT want to "simplify" to the LHS+        forall x::a, y::a, z::a, d1::Ord a.+          f ((==) (eqFromOrd d1) x y) ((>) d1 y z) = ...+Instead we want+        forall x::a, y::a, z::a, d1::Ord a, d2::Eq a.+          f ((==) d2 x y) ((>) d1 y z) = ...++Here is another example:+        fromIntegral :: (Integral a, Num b) => a -> b+        {-# RULES "foo"  fromIntegral = id :: Int -> Int #-}+In the rule, a=b=Int, and Num Int is a superclass of Integral Int. But+we *dont* want to get+        forall dIntegralInt.+           fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int+because the scsel will mess up RULE matching.  Instead we want+        forall dIntegralInt, dNumInt.+          fromIntegral Int Int dIntegralInt dNumInt = id Int++Even if we have+        g (x == y) (y == z) = ..+where the two dictionaries are *identical*, we do NOT WANT+        forall x::a, y::a, z::a, d1::Eq a+          f ((==) d1 x y) ((>) d1 y z) = ...+because that will only match if the dict args are (visibly) equal.+Instead we want to quantify over the dictionaries separately.++In short, simplifyRuleLhs must *only* squash equalities, leaving+all dicts unchanged, with absolutely no sharing.++Also note that we can't solve the LHS constraints in isolation:+Example   foo :: Ord a => a -> a+          foo_spec :: Int -> Int+          {-# RULE "foo"  foo = foo_spec #-}+Here, it's the RHS that fixes the type variable++HOWEVER, under a nested implication things are different+Consider+  f :: (forall a. Eq a => a->a) -> Bool -> ...+  {-# RULES "foo" forall (v::forall b. Eq b => b->b).+       f b True = ...+    #-}+Here we *must* solve the wanted (Eq a) from the given (Eq a)+resulting from skolemising the argument type of g.  So we+revert to SimplCheck when going under an implication.+++--------- So the SimplifyRule Plan is this -----------------------++* Step 0: typecheck the LHS and RHS to get constraints from each++* Step 1: Simplify the LHS and RHS constraints all together in one bag+          We do this to discover all unification equalities++* Step 2: Zonk the ORIGINAL (unsimplified) LHS constraints, to take+          advantage of those unifications++* Setp 3: Partition the LHS constraints into the ones we will+          quantify over, and the others.+          See Note [RULE quantification over equalities]++* Step 4: Decide on the type variables to quantify over++* Step 5: Simplify the LHS and RHS constraints separately, using the+          quantified constraints as givens++Note [Solve order for RULES]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In step 1 above, we need to be a bit careful about solve order.+Consider+   f :: Int -> T Int+   type instance T Int = Bool++   RULE f 3 = True++From the RULE we get+   lhs-constraints:  T Int ~ alpha+   rhs-constraints:  Bool ~ alpha+where 'alpha' is the type that connects the two.  If we glom them+all together, and solve the RHS constraint first, we might solve+with alpha := Bool.  But then we'd end up with a RULE like++    RULE: f 3 |> (co :: T Int ~ Booo) = True++which is terrible.  We want++    RULE: f 3 = True |> (sym co :: Bool ~ T Int)++So we are careful to solve the LHS constraints first, and *then* the+RHS constraints.  Actually much of this is done by the on-the-fly+constraint solving, so the same order must be observed in+tcRule.+++Note [RULE quantification over equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Deciding which equalities to quantify over is tricky:+ * We do not want to quantify over insoluble equalities (Int ~ Bool)+    (a) because we prefer to report a LHS type error+    (b) because if such things end up in 'givens' we get a bogus+        "inaccessible code" error++ * But we do want to quantify over things like (a ~ F b), where+   F is a type function.++The difficulty is that it's hard to tell what is insoluble!+So we see whether the simplification step yielded any type errors,+and if so refrain from quantifying over *any* equalities.++Note [Quantifying over coercion holes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Equality constraints from the LHS will emit coercion hole Wanteds.+These don't have a name, so we can't quantify over them directly.+Instead, because we really do want to quantify here, invent a new+EvVar for the coercion, fill the hole with the invented EvVar, and+then quantify over the EvVar. Not too tricky -- just some+impedance matching, really.++Note [Simplify cloned constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+At this stage, we're simplifying constraints only for insolubility+and for unification. Note that all the evidence is quickly discarded.+We use a clone of the real constraint. If we don't do this,+then RHS coercion-hole constraints get filled in, only to get filled+in *again* when solving the implications emitted from tcRule. That's+terrible, so we avoid the problem by cloning the constraints.++-}++simplifyRule :: RuleName+             -> WantedConstraints       -- Constraints from LHS+             -> WantedConstraints       -- Constraints from RHS+             -> TcM ( [EvVar]               -- Quantify over these LHS vars+                    , WantedConstraints)    -- Residual un-quantified LHS constraints+-- See Note [The SimplifyRule Plan]+-- NB: This consumes all simple constraints on the LHS, but not+-- any LHS implication constraints.+simplifyRule name lhs_wanted rhs_wanted+  = do {         -- We allow ourselves to unify environment+                 -- variables: runTcS runs with topTcLevel+       ; lhs_clone <- cloneWC lhs_wanted+       ; rhs_clone <- cloneWC rhs_wanted++       -- Note [The SimplifyRule Plan] step 1+       -- First solve the LHS and *then* solve the RHS+       -- Crucially, this performs unifications+       -- See Note [Solve order for RULES]+       -- See Note [Simplify cloned constraints]+       ; insoluble <- runTcSDeriveds $+             do { lhs_resid <- solveWanteds lhs_clone+                ; rhs_resid <- solveWanteds rhs_clone+                ; return ( insolubleWC lhs_resid ||+                           insolubleWC rhs_resid ) }++       -- Note [The SimplifyRule Plan] step 2+       ; zonked_lhs_simples <- zonkSimples (wc_simple lhs_wanted)++       -- Note [The SimplifyRule Plan] step 3+       ; let (quant_cts, no_quant_cts) = partitionBag (quantify_ct insoluble)+                                                      zonked_lhs_simples++       ; quant_evs <- mapM mk_quant_ev (bagToList quant_cts)++       ; traceTc "simplifyRule" $+         vcat [ text "LHS of rule" <+> doubleQuotes (ftext name)+              , text "lhs_wanted" <+> ppr lhs_wanted+              , text "rhs_wanted" <+> ppr rhs_wanted+              , text "zonked_lhs_simples" <+> ppr zonked_lhs_simples+              , text "quant_cts" <+> ppr quant_cts+              , text "no_quant_cts" <+> ppr no_quant_cts+              ]++       ; return (quant_evs, lhs_wanted { wc_simple = no_quant_cts }) }++  where+    quantify_ct :: Bool -> Ct -> Bool+    quantify_ct insol ct+      | EqPred _ t1 t2 <- classifyPredType (ctPred ct)+      = not (insol || t1 `tcEqType` t2)+        -- Note [RULE quantification over equalities]++      | otherwise+      = True++    mk_quant_ev :: Ct -> TcM EvVar+    mk_quant_ev ct+      | CtWanted { ctev_dest = dest, ctev_pred = pred } <- ctEvidence ct+      = case dest of+          EvVarDest ev_id -> return ev_id+          HoleDest hole   -> -- See Note [Quantifying over coercion holes]+                             do { ev_id <- newEvVar pred+                                ; fillCoercionHole hole (mkTcCoVarCo ev_id)+                                ; return ev_id }+    mk_quant_ev ct = pprPanic "mk_quant_ev" (ppr ct)
+ typecheck/TcSMonad.hs view
@@ -0,0 +1,3122 @@+{-# LANGUAGE CPP, TypeFamilies #-}++-- Type definitions for the constraint solver+module TcSMonad (++    -- The work list+    WorkList(..), isEmptyWorkList, emptyWorkList,+    extendWorkListNonEq, extendWorkListCt, extendWorkListDerived,+    extendWorkListCts, extendWorkListEq, extendWorkListFunEq,+    appendWorkList, extendWorkListImplic,+    selectNextWorkItem,+    workListSize, workListWantedCount,+    getWorkList, updWorkListTcS,++    -- The TcS monad+    TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds,+    failTcS, warnTcS, addErrTcS,+    runTcSEqualities,+    nestTcS, nestImplicTcS, setEvBindsTcS, buildImplication,++    runTcPluginTcS, addUsedGRE, addUsedGREs,++    -- Tracing etc+    panicTcS, traceTcS,+    traceFireTcS, bumpStepCountTcS, csTraceTcS,+    wrapErrTcS, wrapWarnTcS,++    -- Evidence creation and transformation+    MaybeNew(..), freshGoals, isFresh, getEvTerm,++    newTcEvBinds,+    newWantedEq, emitNewWantedEq,+    newWanted, newWantedEvVar, newWantedNC, newWantedEvVarNC, newDerivedNC,+    newBoundEvVarId,+    unifyTyVar, unflattenFmv, reportUnifications,+    setEvBind, setWantedEq, setEqIfWanted,+    setWantedEvTerm, setWantedEvBind, setEvBindIfWanted,+    newEvVar, newGivenEvVar, newGivenEvVars,+    emitNewDerived, emitNewDeriveds, emitNewDerivedEq,+    checkReductionDepth,++    getInstEnvs, getFamInstEnvs,                -- Getting the environments+    getTopEnv, getGblEnv, getLclEnv,+    getTcEvBindsVar, getTcLevel,+    getTcEvBindsAndTCVs, getTcEvBindsMap,+    tcLookupClass,+    tcLookupId,++    -- Inerts+    InertSet(..), InertCans(..),+    updInertTcS, updInertCans, updInertDicts, updInertIrreds,+    getNoGivenEqs, setInertCans,+    getInertEqs, getInertCans, getInertGivens,+    getInertInsols,+    emptyInert, getTcSInerts, setTcSInerts,+    matchableGivens, prohibitedSuperClassSolve,+    getUnsolvedInerts,+    removeInertCts, getPendingScDicts,+    addInertCan, addInertEq, insertFunEq,+    emitInsoluble, emitWorkNC, emitWork,+    isImprovable,++    -- The Model+    kickOutAfterUnification,++    -- Inert Safe Haskell safe-overlap failures+    addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask,+    getSafeOverlapFailures,++    -- Inert CDictCans+    DictMap, emptyDictMap, lookupInertDict, findDictsByClass, addDict,+    addDictsByClass, delDict, foldDicts, filterDicts, findDict,++    -- Inert CTyEqCans+    EqualCtList, findTyEqs, foldTyEqs, isInInertEqs,+    lookupFlattenTyVar, lookupInertTyVar,++    -- Inert solved dictionaries+    addSolvedDict, lookupSolvedDict,++    -- Irreds+    foldIrreds,++    -- The flattening cache+    lookupFlatCache, extendFlatCache, newFlattenSkolem,            -- Flatten skolems++    -- Inert CFunEqCans+    updInertFunEqs, findFunEq,+    findFunEqsByTyCon,++    instDFunType,                              -- Instantiation++    -- MetaTyVars+    newFlexiTcSTy, instFlexi, instFlexiX,+    cloneMetaTyVar, demoteUnfilledFmv,+    tcInstType, tcInstSkolTyVarsX,++    TcLevel, isTouchableMetaTyVarTcS,+    isFilledMetaTyVar_maybe, isFilledMetaTyVar,+    zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo,+    zonkTyCoVarsAndFVList,+    zonkSimples, zonkWC,++    -- References+    newTcRef, readTcRef, updTcRef,++    -- Misc+    getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS,+    matchFam, matchFamTcM,+    checkWellStagedDFun,+    pprEq                                    -- Smaller utils, re-exported from TcM+                                             -- TODO (DV): these are only really used in the+                                             -- instance matcher in TcSimplify. I am wondering+                                             -- if the whole instance matcher simply belongs+                                             -- here+) where++#include "HsVersions.h"++import HscTypes++import qualified Inst as TcM+import InstEnv+import FamInst+import FamInstEnv++import qualified TcRnMonad as TcM+import qualified TcMType as TcM+import qualified TcEnv as TcM+       ( checkWellStaged, topIdLvl, tcGetDefaultTys, tcLookupClass, tcLookupId )+import PrelNames( heqTyConKey, eqTyConKey )+import Kind+import TcType+import DynFlags+import Type+import Coercion+import Unify++import TcEvidence+import Class+import TyCon+import TcErrors   ( solverDepthErrorTcS )++import Name+import RdrName ( GlobalRdrEnv, GlobalRdrElt )+import qualified RnEnv as TcM+import Var+import VarEnv+import VarSet+import Outputable+import Bag+import UniqSupply+import Util+import TcRnTypes++import Unique+import UniqFM+import UniqDFM+import Maybes++import TrieMap+import Control.Monad+#if __GLASGOW_HASKELL__ > 710+import qualified Control.Monad.Fail as MonadFail+#endif+import MonadUtils+import Data.IORef+import Data.List ( foldl', partition )++#ifdef DEBUG+import Digraph+import UniqSet+#endif++{-+************************************************************************+*                                                                      *+*                            Worklists                                *+*  Canonical and non-canonical constraints that the simplifier has to  *+*  work on. Including their simplification depths.                     *+*                                                                      *+*                                                                      *+************************************************************************++Note [WorkList priorities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+A WorkList contains canonical and non-canonical items (of all flavors).+Notice that each Ct now has a simplification depth. We may+consider using this depth for prioritization as well in the future.++As a simple form of priority queue, our worklist separates out+equalities (wl_eqs) from the rest of the canonical constraints,+so that it's easier to deal with them first, but the separation+is not strictly necessary. Notice that non-canonical constraints+are also parts of the worklist.++Note [Process derived items last]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We can often solve all goals without processing *any* derived constraints.+The derived constraints are just there to help us if we get stuck.  So+we keep them in a separate list.++Note [Prioritise class equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We prioritise equalities in the solver (see selectWorkItem). But class+constraints like (a ~ b) and (a ~~ b) are actually equalities too;+see Note [The equality types story] in TysPrim.++Failing to prioritise these is inefficient (more kick-outs etc).+But, worse, it can prevent us spotting a "recursive knot" among+Wanted constraints.  See comment:10 of Trac #12734 for a worked-out+example.++So we arrange to put these particular class constraints in the wl_eqs.++  NB: since we do not currently apply the substitution to the+  inert_solved_dicts, the knot-tying still seems a bit fragile.+  But this makes it better.+-}++-- See Note [WorkList priorities]+data WorkList+  = WL { wl_eqs     :: [Ct]  -- Both equality constraints and their+                             -- class-level variants (a~b) and (a~~b);+                             -- See Note [Prioritise class equalities]++       , wl_funeqs  :: [Ct]  -- LIFO stack of goals++       , wl_rest    :: [Ct]++       , wl_deriv   :: [CtEvidence]  -- Implicitly non-canonical+                                     -- See Note [Process derived items last]++       , wl_implics :: Bag Implication  -- See Note [Residual implications]+    }++appendWorkList :: WorkList -> WorkList -> WorkList+appendWorkList+    (WL { wl_eqs = eqs1, wl_funeqs = funeqs1, wl_rest = rest1+        , wl_deriv = ders1, wl_implics = implics1 })+    (WL { wl_eqs = eqs2, wl_funeqs = funeqs2, wl_rest = rest2+        , wl_deriv = ders2, wl_implics = implics2 })+   = WL { wl_eqs     = eqs1     ++ eqs2+        , wl_funeqs  = funeqs1  ++ funeqs2+        , wl_rest    = rest1    ++ rest2+        , wl_deriv   = ders1    ++ ders2+        , wl_implics = implics1 `unionBags`   implics2 }++workListSize :: WorkList -> Int+workListSize (WL { wl_eqs = eqs, wl_funeqs = funeqs, wl_deriv = ders, wl_rest = rest })+  = length eqs + length funeqs + length rest + length ders++workListWantedCount :: WorkList -> Int+workListWantedCount (WL { wl_eqs = eqs, wl_rest = rest })+  = count isWantedCt eqs + count isWantedCt rest++extendWorkListEq :: Ct -> WorkList -> WorkList+extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl }++extendWorkListEqs :: [Ct] -> WorkList -> WorkList+extendWorkListEqs cts wl = wl { wl_eqs = cts ++ wl_eqs wl }++extendWorkListFunEq :: Ct -> WorkList -> WorkList+extendWorkListFunEq ct wl = wl { wl_funeqs = ct : wl_funeqs wl }++extendWorkListNonEq :: Ct -> WorkList -> WorkList+-- Extension by non equality+extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl }++extendWorkListDerived :: CtLoc -> CtEvidence -> WorkList -> WorkList+extendWorkListDerived loc ev wl+  | isDroppableDerivedLoc loc = wl { wl_deriv = ev : wl_deriv wl }+  | otherwise                 = extendWorkListEq (mkNonCanonical ev) wl++extendWorkListDeriveds :: CtLoc -> [CtEvidence] -> WorkList -> WorkList+extendWorkListDeriveds loc evs wl+  | isDroppableDerivedLoc loc = wl { wl_deriv = evs ++ wl_deriv wl }+  | otherwise                 = extendWorkListEqs (map mkNonCanonical evs) wl++extendWorkListImplic :: Bag Implication -> WorkList -> WorkList+extendWorkListImplic implics wl = wl { wl_implics = implics `unionBags` wl_implics wl }++extendWorkListCt :: Ct -> WorkList -> WorkList+-- Agnostic+extendWorkListCt ct wl+ = case classifyPredType (ctPred ct) of+     EqPred NomEq ty1 _+       | Just tc <- tcTyConAppTyCon_maybe ty1+       , isTypeFamilyTyCon tc+       -> extendWorkListFunEq ct wl++     EqPred {}+       -> extendWorkListEq ct wl++     ClassPred cls _  -- See Note [Prioritise class equalites]+       |  cls `hasKey` heqTyConKey+       || cls `hasKey` eqTyConKey+       -> extendWorkListEq ct wl++     _ -> extendWorkListNonEq ct wl++extendWorkListCts :: [Ct] -> WorkList -> WorkList+-- Agnostic+extendWorkListCts cts wl = foldr extendWorkListCt wl cts++isEmptyWorkList :: WorkList -> Bool+isEmptyWorkList (WL { wl_eqs = eqs, wl_funeqs = funeqs+                    , wl_rest = rest, wl_deriv = ders, wl_implics = implics })+  = null eqs && null rest && null funeqs && isEmptyBag implics && null ders++emptyWorkList :: WorkList+emptyWorkList = WL { wl_eqs  = [], wl_rest = []+                   , wl_funeqs = [], wl_deriv = [], wl_implics = emptyBag }++selectWorkItem :: WorkList -> Maybe (Ct, WorkList)+selectWorkItem wl@(WL { wl_eqs = eqs, wl_funeqs = feqs+                      , wl_rest = rest })+  | ct:cts <- eqs  = Just (ct, wl { wl_eqs    = cts })+  | ct:fes <- feqs = Just (ct, wl { wl_funeqs = fes })+  | ct:cts <- rest = Just (ct, wl { wl_rest   = cts })+  | otherwise      = Nothing++getWorkList :: TcS WorkList+getWorkList = do { wl_var <- getTcSWorkListRef+                 ; wrapTcS (TcM.readTcRef wl_var) }++selectDerivedWorkItem  :: WorkList -> Maybe (Ct, WorkList)+selectDerivedWorkItem wl@(WL { wl_deriv = ders })+  | ev:evs <- ders = Just (mkNonCanonical ev, wl { wl_deriv  = evs })+  | otherwise      = Nothing++selectNextWorkItem :: TcS (Maybe Ct)+selectNextWorkItem+  = do { wl_var <- getTcSWorkListRef+       ; wl <- wrapTcS (TcM.readTcRef wl_var)++       ; let try :: Maybe (Ct,WorkList) -> TcS (Maybe Ct) -> TcS (Maybe Ct)+             try mb_work do_this_if_fail+                | Just (ct, new_wl) <- mb_work+                = do { checkReductionDepth (ctLoc ct) (ctPred ct)+                     ; wrapTcS (TcM.writeTcRef wl_var new_wl)+                     ; return (Just ct) }+                | otherwise+                = do_this_if_fail++       ; try (selectWorkItem wl) $++    do { ics <- getInertCans+       ; if inert_count ics == 0+         then return Nothing+         else try (selectDerivedWorkItem wl) (return Nothing) } }++-- Pretty printing+instance Outputable WorkList where+  ppr (WL { wl_eqs = eqs, wl_funeqs = feqs+          , wl_rest = rest, wl_implics = implics, wl_deriv = ders })+   = text "WL" <+> (braces $+     vcat [ ppUnless (null eqs) $+            text "Eqs =" <+> vcat (map ppr eqs)+          , ppUnless (null feqs) $+            text "Funeqs =" <+> vcat (map ppr feqs)+          , ppUnless (null rest) $+            text "Non-eqs =" <+> vcat (map ppr rest)+          , ppUnless (null ders) $+            text "Derived =" <+> vcat (map ppr ders)+          , ppUnless (isEmptyBag implics) $+            sdocWithPprDebug $ \dbg ->+            if dbg  -- Typically we only want the work list for this level+            then text "Implics =" <+> vcat (map ppr (bagToList implics))+            else text "(Implics omitted)"+          ])+++{- *********************************************************************+*                                                                      *+                InertSet: the inert set+*                                                                      *+*                                                                      *+********************************************************************* -}++data InertSet+  = IS { inert_cans :: InertCans+              -- Canonical Given, Wanted, Derived+              -- Sometimes called "the inert set"++       , inert_flat_cache :: ExactFunEqMap (TcCoercion, TcType, CtFlavour)+              -- See Note [Type family equations]+              -- If    F tys :-> (co, rhs, flav),+              -- then  co :: F tys ~ rhs+              --       flav is [G] or [WD]+              --+              -- Just a hash-cons cache for use when flattening only+              -- These include entirely un-processed goals, so don't use+              -- them to solve a top-level goal, else you may end up solving+              -- (w:F ty ~ a) by setting w:=w!  We just use the flat-cache+              -- when allocating a new flatten-skolem.+              -- Not necessarily inert wrt top-level equations (or inert_cans)++              -- NB: An ExactFunEqMap -- this doesn't match via loose types!++       , inert_solved_dicts   :: DictMap CtEvidence+              -- Of form ev :: C t1 .. tn+              -- See Note [Solved dictionaries]+              -- and Note [Do not add superclasses of solved dictionaries]+       }++instance Outputable InertSet where+  ppr is = vcat [ ppr $ inert_cans is+                , ppUnless (null dicts) $+                  text "Solved dicts" <+> vcat (map ppr dicts) ]+         where+           dicts = bagToList (dictsToBag (inert_solved_dicts is))++emptyInert :: InertSet+emptyInert+  = IS { inert_cans = IC { inert_count    = 0+                         , inert_eqs      = emptyDVarEnv+                         , inert_dicts    = emptyDicts+                         , inert_safehask = emptyDicts+                         , inert_funeqs   = emptyFunEqs+                         , inert_irreds   = emptyCts+                         , inert_insols   = emptyCts }+       , inert_flat_cache    = emptyExactFunEqs+       , inert_solved_dicts  = emptyDictMap }+++{- Note [Solved dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we apply a top-level instance declaration, we add the "solved"+dictionary to the inert_solved_dicts.  In general, we use it to avoid+creating a new EvVar when we have a new goal that we have solved in+the past.++But in particular, we can use it to create *recursive* dictionaries.+The simplest, degnerate case is+    instance C [a] => C [a] where ...+If we have+    [W] d1 :: C [x]+then we can apply the instance to get+    d1 = $dfCList d+    [W] d2 :: C [x]+Now 'd1' goes in inert_solved_dicts, and we can solve d2 directly from d1.+    d1 = $dfCList d+    d2 = d1++See Note [Example of recursive dictionaries]+Other notes about solved dictionaries++* See also Note [Do not add superclasses of solved dictionaries]++* The inert_solved_dicts field is not rewritten by equalities, so it may+  get out of date.++Note [Do not add superclasses of solved dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Every member of inert_solved_dicts is the result of applying a dictionary+function, NOT of applying superclass selection to anything.+Consider++        class Ord a => C a where+        instance Ord [a] => C [a] where ...++Suppose we are trying to solve+  [G] d1 : Ord a+  [W] d2 : C [a]++Then we'll use the instance decl to give++  [G] d1 : Ord a     Solved: d2 : C [a] = $dfCList d3+  [W] d3 : Ord [a]++We must not add d4 : Ord [a] to the 'solved' set (by taking the+superclass of d2), otherwise we'll use it to solve d3, without ever+using d1, which would be a catastrophe.++Solution: when extending the solved dictionaries, do not add superclasses.+That's why each element of the inert_solved_dicts is the result of applying+a dictionary function.++Note [Example of recursive dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--- Example 1++    data D r = ZeroD | SuccD (r (D r));++    instance (Eq (r (D r))) => Eq (D r) where+        ZeroD     == ZeroD     = True+        (SuccD a) == (SuccD b) = a == b+        _         == _         = False;++    equalDC :: D [] -> D [] -> Bool;+    equalDC = (==);++We need to prove (Eq (D [])). Here's how we go:++   [W] d1 : Eq (D [])+By instance decl of Eq (D r):+   [W] d2 : Eq [D []]      where   d1 = dfEqD d2+By instance decl of Eq [a]:+   [W] d3 : Eq (D [])      where   d2 = dfEqList d3+                                   d1 = dfEqD d2+Now this wanted can interact with our "solved" d1 to get:+    d3 = d1++-- Example 2:+This code arises in the context of "Scrap Your Boilerplate with Class"++    class Sat a+    class Data ctx a+    instance  Sat (ctx Char)             => Data ctx Char       -- dfunData1+    instance (Sat (ctx [a]), Data ctx a) => Data ctx [a]        -- dfunData2++    class Data Maybe a => Foo a++    instance Foo t => Sat (Maybe t)                             -- dfunSat++    instance Data Maybe a => Foo a                              -- dfunFoo1+    instance Foo a        => Foo [a]                            -- dfunFoo2+    instance                 Foo [Char]                         -- dfunFoo3++Consider generating the superclasses of the instance declaration+         instance Foo a => Foo [a]++So our problem is this+    [G] d0 : Foo t+    [W] d1 : Data Maybe [t]   -- Desired superclass++We may add the given in the inert set, along with its superclasses+  Inert:+    [G] d0 : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  WorkList+    [W] d1 : Data Maybe [t]++Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3+  Inert:+    [G] d0 : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  Solved:+        d1 : Data Maybe [t]+  WorkList:+    [W] d2 : Sat (Maybe [t])+    [W] d3 : Data Maybe t++Now, we may simplify d2 using dfunSat; d2 := dfunSat d4+  Inert:+    [G] d0 : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  Solved:+        d1 : Data Maybe [t]+        d2 : Sat (Maybe [t])+  WorkList:+    [W] d3 : Data Maybe t+    [W] d4 : Foo [t]++Now, we can just solve d3 from d01; d3 := d01+  Inert+    [G] d0 : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  Solved:+        d1 : Data Maybe [t]+        d2 : Sat (Maybe [t])+  WorkList+    [W] d4 : Foo [t]++Now, solve d4 using dfunFoo2;  d4 := dfunFoo2 d5+  Inert+    [G] d0  : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  Solved:+        d1 : Data Maybe [t]+        d2 : Sat (Maybe [t])+        d4 : Foo [t]+  WorkList:+    [W] d5 : Foo t++Now, d5 can be solved! d5 := d0++Result+   d1 := dfunData2 d2 d3+   d2 := dfunSat d4+   d3 := d01+   d4 := dfunFoo2 d5+   d5 := d0+-}++{- *********************************************************************+*                                                                      *+                InertCans: the canonical inerts+*                                                                      *+*                                                                      *+********************************************************************* -}++data InertCans   -- See Note [Detailed InertCans Invariants] for more+  = IC { inert_eqs :: InertEqs+              -- See Note [inert_eqs: the inert equalities]+              -- All CTyEqCans; index is the LHS tyvar+              -- Domain = skolems and untouchables; a touchable would be unified++       , inert_funeqs :: FunEqMap Ct+              -- All CFunEqCans; index is the whole family head type.+              -- All Nominal (that's an invarint of all CFunEqCans)+              -- LHS is fully rewritten (modulo eqCanRewrite constraints)+              --     wrt inert_eqs+              -- Can include all flavours, [G], [W], [WD], [D]+              -- See Note [Type family equations]++       , inert_dicts :: DictMap Ct+              -- Dictionaries only+              -- All fully rewritten (modulo flavour constraints)+              --     wrt inert_eqs++       , inert_safehask :: DictMap Ct+              -- Failed dictionary resolution due to Safe Haskell overlapping+              -- instances restriction. We keep this separate from inert_dicts+              -- as it doesn't cause compilation failure, just safe inference+              -- failure.+              --+              -- ^ See Note [Safe Haskell Overlapping Instances Implementation]+              -- in TcSimplify++       , inert_irreds :: Cts+              -- Irreducible predicates++       , inert_insols :: Cts+              -- Frozen errors (as non-canonicals)++       , inert_count :: Int+              -- Number of Wanted goals in+              --     inert_eqs, inert_dicts, inert_safehask, inert_irreds+              -- Does not include insolubles+              -- When non-zero, keep trying to solved+       }++type InertEqs    = DTyVarEnv EqualCtList+type EqualCtList = [Ct]  -- See Note [EqualCtList invariants]++{- Note [Detailed InertCans Invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The InertCans represents a collection of constraints with the following properties:++  * All canonical++  * No two dictionaries with the same head+  * No two CIrreds with the same type++  * Family equations inert wrt top-level family axioms++  * Dictionaries have no matching top-level instance++  * Given family or dictionary constraints don't mention touchable+    unification variables++  * Non-CTyEqCan constraints are fully rewritten with respect+    to the CTyEqCan equalities (modulo canRewrite of course;+    eg a wanted cannot rewrite a given)++  * CTyEqCan equalities: see Note [Applying the inert substitution]+                         in TcFlatten++Note [EqualCtList invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    * All are equalities+    * All these equalities have the same LHS+    * The list is never empty+    * No element of the list can rewrite any other+    * Derived before Wanted++From the fourth invariant it follows that the list is+   - A single [G], or+   - Zero or one [D] or [WD], followd by any number of [W]++The Wanteds can't rewrite anything which is why we put them last++Note [Type family equations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Type-family equations, CFunEqCans, of form (ev : F tys ~ ty),+live in three places++  * The work-list, of course++  * The inert_funeqs are un-solved but fully processed, and in+    the InertCans. They can be [G], [W], [WD], or [D].++  * The inert_flat_cache.  This is used when flattening, to get maximal+    sharing. Everthing in the inert_flat_cache is [G] or [WD]++    It contains lots of things that are still in the work-list.+    E.g Suppose we have (w1: F (G a) ~ Int), and (w2: H (G a) ~ Int) in the+        work list.  Then we flatten w1, dumping (w3: G a ~ f1) in the work+        list.  Now if we flatten w2 before we get to w3, we still want to+        share that (G a).+    Because it contains work-list things, DO NOT use the flat cache to solve+    a top-level goal.  Eg in the above example we don't want to solve w3+    using w3 itself!++The CFunEqCan Ownership Invariant:++  * Each [G/W/WD] CFunEqCan has a distinct fsk or fmv+    It "owns" that fsk/fmv, in the sense that:+      - reducing a [W/WD] CFunEqCan fills in the fmv+      - unflattening a [W/WD] CFunEqCan fills in the fmv+      (in both cases unless an occurs-check would result)++  * In contrast a [D] CFunEqCan does not "own" its fmv:+      - reducing a [D] CFunEqCan does not fill in the fmv;+        it just generates an equality+      - unflattening ignores [D] CFunEqCans altogether+++Note [inert_eqs: the inert equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Definition [Can-rewrite relation]+A "can-rewrite" relation between flavours, written f1 >= f2, is a+binary relation with the following properties++  (R1) >= is transitive+  (R2) If f1 >= f, and f2 >= f,+       then either f1 >= f2 or f2 >= f1++Lemma.  If f1 >= f then f1 >= f1+Proof.  By property (R2), with f1=f2++Definition [Generalised substitution]+A "generalised substitution" S is a set of triples (a -f-> t), where+  a is a type variable+  t is a type+  f is a flavour+such that+  (WF1) if (a -f1-> t1) in S+           (a -f2-> t2) in S+        then neither (f1 >= f2) nor (f2 >= f1) hold+  (WF2) if (a -f-> t) is in S, then t /= a++Definition [Applying a generalised substitution]+If S is a generalised substitution+   S(f,a) = t,  if (a -fs-> t) in S, and fs >= f+          = a,  otherwise+Application extends naturally to types S(f,t), modulo roles.+See Note [Flavours with roles].++Theorem: S(f,a) is well defined as a function.+Proof: Suppose (a -f1-> t1) and (a -f2-> t2) are both in S,+               and  f1 >= f and f2 >= f+       Then by (R2) f1 >= f2 or f2 >= f1, which contradicts (WF1)++Notation: repeated application.+  S^0(f,t)     = t+  S^(n+1)(f,t) = S(f, S^n(t))++Definition: inert generalised substitution+A generalised substitution S is "inert" iff++  (IG1) there is an n such that+        for every f,t, S^n(f,t) = S^(n+1)(f,t)++By (IG1) we define S*(f,t) to be the result of exahaustively+applying S(f,_) to t.++----------------------------------------------------------------+Our main invariant:+   the inert CTyEqCans should be an inert generalised substitution+----------------------------------------------------------------++Note that inertness is not the same as idempotence.  To apply S to a+type, you may have to apply it recursive.  But inertness does+guarantee that this recursive use will terminate.++Note [Extending the inert equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Theorem [Stability under extension]+   This is the main theorem!+   Suppose we have a "work item"+       a -fw-> t+   and an inert generalised substitution S,+   such that+      (T1) S(fw,a) = a     -- LHS of work-item is a fixpoint of S(fw,_)+      (T2) S(fw,t) = t     -- RHS of work-item is a fixpoint of S(fw,_)+      (T3) a not in t      -- No occurs check in the work item++      (K1) for every (a -fs-> s) in S, then not (fw >= fs)+           Reason: the work item is fully rewritten by S, hence not (fs >= fw)+                   but if (fw >= fs) then the work item could rewrite+                   the inert item++      (K2) for every (b -fs-> s) in S, where b /= a, then+              (K2a) not (fs >= fs)+           or (K2b) fs >= fw+           or (K2c) not (fw >= fs)+           or (K2d) a not in s++      (K3) See Note [K3: completeness of solving]+           If (b -fs-> s) is in S with (fw >= fs), then+        (K3a) If the role of fs is nominal: s /= a+        (K3b) If the role of fs is representational: EITHER+                a not in s, OR+                the path from the top of s to a includes at least one non-newtype++   then the extended substitution T = S+(a -fw-> t)+   is an inert generalised substitution.++Conditions (T1-T3) are established by the canonicaliser+Conditions (K1-K3) are established by TcSMonad.kickOutRewritable++The idea is that+* (T1-2) are guaranteed by exhaustively rewriting the work-item+  with S(fw,_).++* T3 is guaranteed by a simple occurs-check on the work item.+  This is done during canonicalisation, in canEqTyVar;+  (invariant: a CTyEqCan never has an occurs check).++* (K1-3) are the "kick-out" criteria.  (As stated, they are really the+  "keep" criteria.) If the current inert S contains a triple that does+  not satisfy (K1-3), then we remove it from S by "kicking it out",+  and re-processing it.++* Note that kicking out is a Bad Thing, because it means we have to+  re-process a constraint.  The less we kick out, the better.+  TODO: Make sure that kicking out really *is* a Bad Thing. We've assumed+  this but haven't done the empirical study to check.++* Assume we have  G>=G, G>=W and that's all.  Then, when performing+  a unification we add a new given  a -G-> ty.  But doing so does NOT require+  us to kick out an inert wanted that mentions a, because of (K2a).  This+  is a common case, hence good not to kick out.++* Lemma (L2): if not (fw >= fw), then K1-K3 all hold.+  Proof: using Definition [Can-rewrite relation], fw can't rewrite anything+         and so K1-K3 hold.  Intuitively, since fw can't rewrite anything,+         adding it cannot cause any loops+  This is a common case, because Wanteds cannot rewrite Wanteds.++* Lemma (L1): The conditions of the Main Theorem imply that there is no+              (a -fs-> t) in S, s.t.  (fs >= fw).+  Proof. Suppose the contrary (fs >= fw).  Then because of (T1),+  S(fw,a)=a.  But since fs>=fw, S(fw,a) = s, hence s=a.  But now we+  have (a -fs-> a) in S, which contradicts (WF2).++* The extended substitution satisfies (WF1) and (WF2)+  - (K1) plus (L1) guarantee that the extended substitution satisfies (WF1).+  - (T3) guarantees (WF2).++* (K2) is about inertness.  Intuitively, any infinite chain T^0(f,t),+  T^1(f,t), T^2(f,T).... must pass through the new work item infnitely+  often, since the substitution without the work item is inert; and must+  pass through at least one of the triples in S infnitely often.++  - (K2a): if not(fs>=fs) then there is no f that fs can rewrite (fs>=f),+    and hence this triple never plays a role in application S(f,a).+    It is always safe to extend S with such a triple.++    (NB: we could strengten K1) in this way too, but see K3.++  - (K2b): If this holds then, by (T2), b is not in t.  So applying the+    work item does not genenerate any new opportunities for applying S++  - (K2c): If this holds, we can't pass through this triple infinitely+    often, because if we did then fs>=f, fw>=f, hence by (R2)+      * either fw>=fs, contradicting K2c+      * or fs>=fw; so by the argument in K2b we can't have a loop++  - (K2d): if a not in s, we hae no further opportunity to apply the+    work item, similar to (K2b)++  NB: Dimitrios has a PDF that does this in more detail++Key lemma to make it watertight.+  Under the conditions of the Main Theorem,+  forall f st fw >= f, a is not in S^k(f,t), for any k++Also, consider roles more carefully. See Note [Flavours with roles]++Note [K3: completeness of solving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(K3) is not necessary for the extended substitution+to be inert.  In fact K1 could be made stronger by saying+   ... then (not (fw >= fs) or not (fs >= fs))+But it's not enough for S to be inert; we also want completeness.+That is, we want to be able to solve all soluble wanted equalities.+Suppose we have++   work-item   b -G-> a+   inert-item  a -W-> b++Assuming (G >= W) but not (W >= W), this fulfills all the conditions,+so we could extend the inerts, thus:++   inert-items   b -G-> a+                 a -W-> b++But if we kicked-out the inert item, we'd get++   work-item     a -W-> b+   inert-item    b -G-> a++Then rewrite the work-item gives us (a -W-> a), which is soluble via Refl.+So we add one more clause to the kick-out criteria++Another way to understand (K3) is that we treat an inert item+        a -f-> b+in the same way as+        b -f-> a+So if we kick out one, we should kick out the other.  The orientation+is somewhat accidental.++When considering roles, we also need the second clause (K3b). Consider++  inert-item   a -W/R-> b c+  work-item    c -G/N-> a++The work-item doesn't get rewritten by the inert, because (>=) doesn't hold.+We've satisfied conditions (T1)-(T3) and (K1) and (K2). If all we had were+condition (K3a), then we would keep the inert around and add the work item.+But then, consider if we hit the following:++  work-item2   b -G/N-> Id++where++  newtype Id x = Id x++For similar reasons, if we only had (K3a), we wouldn't kick the+representational inert out. And then, we'd miss solving the inert, which+now reduced to reflexivity. The solution here is to kick out representational+inerts whenever the tyvar of a work item is "exposed", where exposed means+not under some proper data-type constructor, like [] or Maybe. See+isTyVarExposed in TcType. This is encoded in (K3b).++Note [Flavours with roles]+~~~~~~~~~~~~~~~~~~~~~~~~~~+The system described in Note [inert_eqs: the inert equalities]+discusses an abstract+set of flavours. In GHC, flavours have two components: the flavour proper,+taken from {Wanted, Derived, Given} and the equality relation (often called+role), taken from {NomEq, ReprEq}.+When substituting w.r.t. the inert set,+as described in Note [inert_eqs: the inert equalities],+we must be careful to respect all components of a flavour.+For example, if we have++  inert set: a -G/R-> Int+             b -G/R-> Bool++  type role T nominal representational++and we wish to compute S(W/R, T a b), the correct answer is T a Bool, NOT+T Int Bool. The reason is that T's first parameter has a nominal role, and+thus rewriting a to Int in T a b is wrong. Indeed, this non-congruence of+substitution means that the proof in Note [The inert equalities] may need+to be revisited, but we don't think that the end conclusion is wrong.+-}++instance Outputable InertCans where+  ppr (IC { inert_eqs = eqs+          , inert_funeqs = funeqs, inert_dicts = dicts+          , inert_safehask = safehask, inert_irreds = irreds+          , inert_insols = insols, inert_count = count })+    = braces $ vcat+      [ ppUnless (isEmptyDVarEnv eqs) $+        text "Equalities:"+          <+> pprCts (foldDVarEnv (\eqs rest -> listToBag eqs `andCts` rest) emptyCts eqs)+      , ppUnless (isEmptyTcAppMap funeqs) $+        text "Type-function equalities =" <+> pprCts (funEqsToBag funeqs)+      , ppUnless (isEmptyTcAppMap dicts) $+        text "Dictionaries =" <+> pprCts (dictsToBag dicts)+      , ppUnless (isEmptyTcAppMap safehask) $+        text "Safe Haskell unsafe overlap =" <+> pprCts (dictsToBag safehask)+      , ppUnless (isEmptyCts irreds) $+        text "Irreds =" <+> pprCts irreds+      , ppUnless (isEmptyCts insols) $+        text "Insolubles =" <+> pprCts insols+      , text "Unsolved goals =" <+> int count+      ]++{- *********************************************************************+*                                                                      *+             Shadow constraints and improvement+*                                                                      *+************************************************************************++Note [The improvement story and derived shadows]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Because Wanteds cannot rewrite Wanteds (see Note [Wanteds do not+rewrite Wanteds] in TcRnTypes), we may miss some opportunities for+solving.  Here's a classic example (indexed-types/should_fail/T4093a)++    Ambiguity check for f: (Foo e ~ Maybe e) => Foo e++    We get [G] Foo e ~ Maybe e+           [W] Foo e ~ Foo ee      -- ee is a unification variable+           [W] Foo ee ~ Maybe ee++    Flatten: [G] Foo e ~ fsk+             [G] fsk ~ Maybe e   -- (A)++             [W] Foo ee ~ fmv+             [W] fmv ~ fsk       -- (B) From Foo e ~ Foo ee+             [W] fmv ~ Maybe ee++    --> rewrite (B) with (A)+             [W] Foo ee ~ fmv+             [W] fmv ~ Maybe e+             [W] fmv ~ Maybe ee++    But now we appear to be stuck, since we don't rewrite Wanteds with+    Wanteds.  This is silly because we can see that ee := e is the+    only solution.++The basic plan is+  * generate Derived constraints that shadow Wanted constraints+  * allow Derived to rewrite Derived+  * in order to cause some unifications to take place+  * that in turn solve the original Wanteds++The ONLY reason for all these Derived equalities is to tell us how to+unify a variable: that is, what Mark Jones calls "improvement".++The same idea is sometimes also called "saturation"; find all the+equalities that must hold in any solution.++Or, equivalently, you can think of the derived shadows as implementing+the "model": an non-idempotent but no-occurs-check substitution,+reflecting *all* *Nominal* equalities (a ~N ty) that are not+immediately soluble by unification.++More specifically, here's how it works (Oct 16):++* Wanted constraints are born as [WD]; this behaves like a+  [W] and a [D] paired together.++* When we are about to add a [WD] to the inert set, if it can+  be rewritten by a [D] a ~ ty, then we split it into [W] and [D],+  putting the latter into the work list (see maybeEmitShadow).++In the example above, we get to the point where we are stuck:+    [WD] Foo ee ~ fmv+    [WD] fmv ~ Maybe e+    [WD] fmv ~ Maybe ee++But now when [WD] fmv ~ Maybe ee is about to be added, we'll+split it into [W] and [D], since the inert [WD] fmv ~ Maybe e+can rewrite it.  Then:+    work item: [D] fmv ~ Maybe ee+    inert:     [W] fmv ~ Maybe ee+               [WD] fmv ~ Maybe e   -- (C)+               [WD] Foo ee ~ fmv++See Note [Splitting WD constraints].  Now the work item is rewritten+by (C) and we soon get ee := e.++Additional notes:++  * The derived shadow equalities live in inert_eqs, along with+    the Givens and Wanteds; see Note [EqualCtList invariants].++  * We make Derived shadows only for Wanteds, not Givens.  So we+    have only [G], not [GD] and [G] plus splitting.  See+    Note [Add derived shadows only for Wanteds]++  * We also get Derived equalities from functional dependencies+    and type-function injectivity; see calls to unifyDerived.++  * This splitting business applies to CFunEqCans too; and then+    we do apply type-function reductions to the [D] CFunEqCan.+    See Note [Reduction for Derived CFunEqCans]++  * It's worth having [WD] rather than just [W] and [D] because+    * efficiency: silly to process the same thing twice+    * inert_funeqs, inert_dicts is a finite map keyed by+      the type; it's inconvenient for it to map to TWO constraints++Note [Splitting WD constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We are about to add a [WD] constraint to the inert set; and we+know that the inert set has fully rewritten it.  Should we split+it into [W] and [D], and put the [D] in the work list for further+work?++* CDictCan (C tys) or CFunEqCan (F tys ~ fsk):+  Yes if the inert set could rewrite tys to make the class constraint,+  or type family, fire.  That is, yes if the inert_eqs intersects+  with the free vars of tys.  For this test we use+  (anyRewritableTyVar True) which ignores casts and coercions in tys,+  because rewriting the casts or coercions won't make the thing fire+  more often.++* CTyEqCan (a ~ ty): Yes if the inert set could rewrite 'a' or 'ty'.+  We need to check both 'a' and 'ty' against the inert set:+    - Inert set contains  [D] a ~ ty2+      Then we want to put [D] a ~ ty in the worklist, so we'll+      get [D] ty ~ ty2 with consequent good things++    - Inert set contains [D] b ~ a, where b is in ty.+      We can't just add [WD] a ~ ty[b] to the inert set, because+      that breaks the inert-set invariants.  If we tried to+      canonicalise another [D] constraint mentioning 'a', we'd+      get an infinite loop++  Moreover we must use (anyRewritableTyVar False) for the RHS,+  because even tyvars in the casts and coercions could give+  an infinite loop if we don't expose it++* Others: nothing is gained by splitting.++Note [Examples of how Derived shadows helps completeness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Trac #10009, a very nasty example:++    f :: (UnF (F b) ~ b) => F b -> ()++    g :: forall a. (UnF (F a) ~ a) => a -> ()+    g _ = f (undefined :: F a)++  For g we get [G] UnF (F a) ~ a+               [WD] UnF (F beta) ~ beta+               [WD] F a ~ F beta+  Flatten:+      [G] g1: F a ~ fsk1         fsk1 := F a+      [G] g2: UnF fsk1 ~ fsk2    fsk2 := UnF fsk1+      [G] g3: fsk2 ~ a++      [WD] w1: F beta ~ fmv1+      [WD] w2: UnF fmv1 ~ fmv2+      [WD] w3: fmv2 ~ beta+      [WD] w4: fmv1 ~ fsk1   -- From F a ~ F beta using flat-cache+                             -- and re-orient to put meta-var on left++Rewrite w2 with w4: [D] d1: UnF fsk1 ~ fmv2+React that with g2: [D] d2: fmv2 ~ fsk2+React that with w3: [D] beta ~ fsk2+            and g3: [D] beta ~ a -- Hooray beta := a+And that is enough to solve everything++Note [Add derived shadows only for Wanteds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We only add shadows for Wanted constraints. That is, we have+[WD] but not [GD]; and maybeEmitShaodw looks only at [WD]+constraints.++It does just possibly make sense ot add a derived shadow for a+Given. If we created a Derived shadow of a Given, it could be+rewritten by other Deriveds, and that could, conceivably, lead to a+useful unification.++But (a) I have been unable to come up with an example of this+        happening+    (b) see Trac #12660 for how adding the derived shadows+        of a Given led to an infinite loop.+    (c) It's unlikely that rewriting derived Givens will lead+        to a unification because Givens don't mention touchable+        unification variables++For (b) there may be other ways to solve the loop, but simply+reraining from adding derived shadows of Givens is particularly+simple.  And it's more efficient too!++Still, here's one possible reason for adding derived shadows+for Givens.  Consider+           work-item [G] a ~ [b], inerts has [D] b ~ a.+If we added the derived shadow (into the work list)+         [D] a ~ [b]+When we process it, we'll rewrite to a ~ [a] and get an+occurs check.  Without it we'll miss the occurs check (reporting+inaccessible code); but that's probably OK.++Note [Keep CDictCan shadows as CDictCan]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+  class C a => D a b+and [G] D a b, [G] C a in the inert set.  Now we insert+[D] b ~ c.  We want to kick out a derived shadow for [D] D a b,+so we can rewrite it with the new constraint, and perhaps get+instance reduction or other consequences.++BUT we do not want to kick out a *non-canonical* (D a b). If we+did, we would do this:+  - rewrite it to [D] D a c, with pend_sc = True+  - use expandSuperClasses to add C a+  - go round again, which solves C a from the givens+This loop goes on for ever and triggers the simpl_loop limit.++Solution: kick out the CDictCan which will have pend_sc = False,+because we've already added its superclasses.  So we won't re-add+them.  If we forget the pend_sc flag, our cunning scheme for avoiding+generating superclasses repeatedly will fail.++See Trac #11379 for a case of this.++Note [Do not do improvement for WOnly]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do improvement between two constraints (e.g. for injectivity+or functional dependencies) only if both are "improvable". And+we improve a constraint wrt the top-level instances only if+it is improvable.++Improvable:     [G] [WD] [D}+Not improvable: [W]++Reasons:++* It's less work: fewer pairs to compare++* Every [W] has a shadow [D] so nothing is lost++* Consider [WD] C Int b,  where 'b' is a skolem, and+    class C a b | a -> b+    instance C Int Bool+  We'll do a fundep on it and emit [D] b ~ Bool+  That will kick out constraint [WD] C Int b+  Then we'll split it to [W] C Int b (keep in inert)+                     and [D] C Int b (in work list)+  When processing the latter we'll rewrite it to+        [D] C Int Bool+  At that point it would be /stupid/ to interact it+  with the inert [W] C Int b in the inert set; after all,+  it's the very constraint from which the [D] C Int Bool+  was split!  We can avoid this by not doing improvement+  on [W] constraints. This came up in Trac #12860.+-}++maybeEmitShadow :: InertCans -> Ct -> TcS Ct+-- See Note [The improvement story and derived shadows]+maybeEmitShadow ics ct+  | let ev = ctEvidence ct+  , CtWanted { ctev_pred = pred, ctev_loc = loc+             , ctev_nosh = WDeriv } <- ev+  , shouldSplitWD (inert_eqs ics) ct+  = do { traceTcS "Emit derived shadow" (ppr ct)+       ; let derived_ev = CtDerived { ctev_pred = pred+                                    , ctev_loc  = loc }+             shadow_ct = ct { cc_ev = derived_ev }+               -- Te shadow constraint keeps the canonical shape.+               -- This just saves work, but is sometimes important;+               -- see Note [Keep CDictCan shadows as CDictCan]+       ; emitWork [shadow_ct]++       ; let ev' = ev { ctev_nosh = WOnly }+             ct' = ct { cc_ev = ev' }+                 -- Record that it now has a shadow+                 -- This is /the/ place we set the flag to WOnly+       ; return ct' }++  | otherwise+  = return ct++shouldSplitWD :: InertEqs -> Ct -> Bool+-- Precondition: 'ct' is [WD], and is inert+-- True <=> we should split ct ito [W] and [D] because+--          the inert_eqs can make progress on the [D]+-- See Note [Splitting WD constraints]++shouldSplitWD inert_eqs (CFunEqCan { cc_tyargs = tys })+  = should_split_match_args inert_eqs tys+    -- We don't need to split if the tv is the RHS fsk++shouldSplitWD inert_eqs (CDictCan { cc_tyargs = tys })+  = should_split_match_args inert_eqs tys+    -- NB True: ignore coercions+    -- See Note [Splitting WD constraints]++shouldSplitWD inert_eqs (CTyEqCan { cc_tyvar = tv, cc_rhs = ty })+  =  tv `elemDVarEnv` inert_eqs+  || anyRewritableTyVar False (`elemDVarEnv` inert_eqs) ty+  -- NB False: do not ignore casts and coercions+  -- See Note [Splitting WD constraints]++shouldSplitWD _ _ = False   -- No point in splitting otherwise++should_split_match_args :: InertEqs -> [TcType] -> Bool+-- True if the inert_eqs can rewrite anything in the argument+-- types, ignoring casts and coercions+should_split_match_args inert_eqs tys+  = any (anyRewritableTyVar True (`elemDVarEnv` inert_eqs)) tys+    -- NB True: ignore casts coercions+    -- See Note [Splitting WD constraints]++isImprovable :: CtEvidence -> Bool+-- See Note [Do not do improvement for WOnly]+isImprovable (CtWanted { ctev_nosh = WOnly }) = False+isImprovable _                                = True+++{- *********************************************************************+*                                                                      *+                   Inert equalities+*                                                                      *+********************************************************************* -}++addTyEq :: InertEqs -> TcTyVar -> Ct -> InertEqs+addTyEq old_eqs tv ct+  = extendDVarEnv_C add_eq old_eqs tv [ct]+  where+    add_eq old_eqs _+      | isWantedCt ct+      , (eq1 : eqs) <- old_eqs+      = eq1 : ct : eqs+      | otherwise+      = ct : old_eqs++foldTyEqs :: (Ct -> b -> b) -> InertEqs -> b -> b+foldTyEqs k eqs z+  = foldDVarEnv (\cts z -> foldr k z cts) z eqs++findTyEqs :: InertCans -> TyVar -> EqualCtList+findTyEqs icans tv = lookupDVarEnv (inert_eqs icans) tv `orElse` []++delTyEq :: InertEqs -> TcTyVar -> TcType -> InertEqs+delTyEq m tv t = modifyDVarEnv (filter (not . isThisOne)) m tv+  where isThisOne (CTyEqCan { cc_rhs = t1 }) = eqType t t1+        isThisOne _                          = False++lookupInertTyVar :: InertEqs -> TcTyVar -> Maybe TcType+lookupInertTyVar ieqs tv+  = case lookupDVarEnv ieqs tv of+      Just (CTyEqCan { cc_rhs = rhs, cc_eq_rel = NomEq } : _ ) -> Just rhs+      _                                                        -> Nothing++lookupFlattenTyVar :: InertEqs -> TcTyVar -> TcType+-- See Note [lookupFlattenTyVar]+lookupFlattenTyVar ieqs ftv+  = lookupInertTyVar ieqs ftv `orElse` mkTyVarTy ftv++{- Note [lookupFlattenTyVar]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have an injective function F and+  inert_funeqs:   F t1 ~ fsk1+                  F t2 ~ fsk2+  inert_eqs:      fsk1 ~ fsk2++We never rewrite the RHS (cc_fsk) of a CFunEqCan.  But we /do/ want to+get the [D] t1 ~ t2 from the injectiveness of F.  So we look up the+cc_fsk of CFunEqCans in the inert_eqs when trying to find derived+equalities arising from injectivity.+-}+++{- *********************************************************************+*                                                                      *+                  Adding an inert+*                                                                      *+************************************************************************++Note [Adding an equality to the InertCans]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When adding an equality to the inerts:++* Split [WD] into [W] and [D] if the inerts can rewrite the latter;+  done by maybeEmitShadow.++* Kick out any constraints that can be rewritten by the thing+  we are adding.  Done by kickOutRewritable.++* Note that unifying a:=ty, is like adding [G] a~ty; just use+  kickOutRewritable with Nominal, Given.  See kickOutAfterUnification.++Note [Kicking out CFunEqCan for fundeps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:+   New:    [D] fmv1 ~ fmv2+   Inert:  [W] F alpha ~ fmv1+           [W] F beta  ~ fmv2++where F is injective. The new (derived) equality certainly can't+rewrite the inerts. But we *must* kick out the first one, to get:++   New:   [W] F alpha ~ fmv1+   Inert: [W] F beta ~ fmv2+          [D] fmv1 ~ fmv2++and now improvement will discover [D] alpha ~ beta. This is important;+eg in Trac #9587.++So in kickOutRewritable we look at all the tyvars of the+CFunEqCan, including the fsk.+-}++addInertEq :: Ct -> TcS ()+-- This is a key function, because of the kick-out stuff+-- Precondition: item /is/ canonical+-- See Note [Adding an equality to the InertCans]+addInertEq ct+  = do { traceTcS "addInertEq {" $+         text "Adding new inert equality:" <+> ppr ct++       ; ics <- getInertCans++       ; ct@(CTyEqCan { cc_tyvar = tv, cc_ev = ev }) <- maybeEmitShadow ics ct++       ; (_, ics1) <- kickOutRewritable (ctEvFlavourRole ev) tv ics++       ; let ics2 = ics1 { inert_eqs   = addTyEq (inert_eqs ics1) tv ct+                         , inert_count = bumpUnsolvedCount ev (inert_count ics1) }+       ; setInertCans ics2++       ; traceTcS "addInertEq }" $ empty }++--------------+addInertCan :: Ct -> TcS ()  -- Constraints *other than* equalities+addInertCan ct+  = do { traceTcS "insertInertCan {" $+         text "Trying to insert new non-eq inert item:" <+> ppr ct++       ; ics <- getInertCans+       ; ct <- maybeEmitShadow ics ct+       ; setInertCans (add_item ics ct)++       ; traceTcS "addInertCan }" $ empty }++add_item :: InertCans -> Ct -> InertCans+add_item ics item@(CFunEqCan { cc_fun = tc, cc_tyargs = tys })+  = ics { inert_funeqs = insertFunEq (inert_funeqs ics) tc tys item }++add_item ics item@(CIrredEvCan { cc_ev = ev })+  = ics { inert_irreds = inert_irreds ics `Bag.snocBag` item+        , inert_count = bumpUnsolvedCount ev (inert_count ics) }+       -- The 'False' is because the irreducible constraint might later instantiate+       -- to an equality.+       -- But since we try to simplify first, if there's a constraint function FC with+       --    type instance FC Int = Show+       -- we'll reduce a constraint (FC Int a) to Show a, and never add an inert irreducible++add_item ics item@(CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })+  = ics { inert_dicts = addDict (inert_dicts ics) cls tys item+        , inert_count = bumpUnsolvedCount ev (inert_count ics) }++add_item _ item+  = pprPanic "upd_inert set: can't happen! Inserting " $+    ppr item   -- CTyEqCan is dealt with by addInertEq+               -- Can't be CNonCanonical, CHoleCan,+               -- because they only land in inert_insols++bumpUnsolvedCount :: CtEvidence -> Int -> Int+bumpUnsolvedCount ev n | isWanted ev = n+1+                       | otherwise   = n+++-----------------------------------------+kickOutRewritable  :: CtFlavourRole  -- Flavour/role of the equality that+                                      -- is being added to the inert set+                    -> TcTyVar        -- The new equality is tv ~ ty+                    -> InertCans+                    -> TcS (Int, InertCans)+kickOutRewritable new_fr new_tv ics+  = do { let (kicked_out, ics') = kick_out_rewritable new_fr new_tv ics+             n_kicked = workListSize kicked_out++       ; unless (n_kicked == 0) $+         do { updWorkListTcS (appendWorkList kicked_out)+            ; csTraceTcS $+              hang (text "Kick out, tv =" <+> ppr new_tv)+                 2 (vcat [ text "n-kicked =" <+> int n_kicked+                         , text "kicked_out =" <+> ppr kicked_out+                         , text "Residual inerts =" <+> ppr ics' ]) }++       ; return (n_kicked, ics') }++kick_out_rewritable :: CtFlavourRole  -- Flavour/role of the equality that+                                      -- is being added to the inert set+                    -> TcTyVar        -- The new equality is tv ~ ty+                    -> InertCans+                    -> (WorkList, InertCans)+-- See Note [kickOutRewritable]+kick_out_rewritable new_fr new_tv ics@(IC { inert_eqs      = tv_eqs+                                        , inert_dicts    = dictmap+                                        , inert_safehask = safehask+                                        , inert_funeqs   = funeqmap+                                        , inert_irreds   = irreds+                                        , inert_insols   = insols+                                        , inert_count    = n })+  | not (new_fr `eqMayRewriteFR` new_fr)+  = (emptyWorkList, ics)+        -- If new_fr can't rewrite itself, it can't rewrite+        -- anything else, so no need to kick out anything.+        -- (This is a common case: wanteds can't rewrite wanteds)+        -- Lemma (L2) in Note [Extending the inert equalities]++  | otherwise+  = (kicked_out, inert_cans_in)+  where+    inert_cans_in = IC { inert_eqs      = tv_eqs_in+                       , inert_dicts    = dicts_in+                       , inert_safehask = safehask   -- ??+                       , inert_funeqs   = feqs_in+                       , inert_irreds   = irs_in+                       , inert_insols   = insols_in+                       , inert_count    = n - workListWantedCount kicked_out }++    kicked_out = WL { wl_eqs    = tv_eqs_out+                    , wl_funeqs = feqs_out+                    , wl_deriv  = []+                    , wl_rest   = bagToList (dicts_out `andCts` irs_out+                                             `andCts` insols_out)+                    , wl_implics = emptyBag }++    (tv_eqs_out, tv_eqs_in) = foldDVarEnv kick_out_eqs ([], emptyDVarEnv) tv_eqs+    (feqs_out,   feqs_in)   = partitionFunEqs  kick_out_ct funeqmap+           -- See Note [Kicking out CFunEqCan for fundeps]+    (dicts_out,  dicts_in)  = partitionDicts   kick_out_ct dictmap+    (irs_out,    irs_in)    = partitionBag     kick_out_ct irreds+    (insols_out, insols_in) = partitionBag     kick_out_ct insols+      -- Kick out even insolubles: See Note [Kick out insolubles]++    fr_may_rewrite :: CtFlavourRole -> Bool+    fr_may_rewrite fs = new_fr `eqMayRewriteFR` fs+        -- Can the new item rewrite the inert item?++    kick_out_ct :: Ct -> Bool+    -- Kick it out if the new CTyEqCan can rewrite the inert one+    -- See Note [kickOutRewritable]+    kick_out_ct ct | let ev = ctEvidence ct+                   = fr_may_rewrite (ctEvFlavourRole ev)+                   && anyRewritableTyVar False (== new_tv) (ctEvPred ev)+                  -- False: ignore casts and coercions+                  -- NB: this includes the fsk of a CFunEqCan.  It can't+                  --     actually be rewritten, but we need to kick it out+                  --     so we get to take advantage of injectivity+                  -- See Note [Kicking out CFunEqCan for fundeps]++    kick_out_eqs :: EqualCtList -> ([Ct], DTyVarEnv EqualCtList)+                 -> ([Ct], DTyVarEnv EqualCtList)+    kick_out_eqs eqs (acc_out, acc_in)+      = (eqs_out ++ acc_out, case eqs_in of+                               []      -> acc_in+                               (eq1:_) -> extendDVarEnv acc_in (cc_tyvar eq1) eqs_in)+      where+        (eqs_in, eqs_out) = partition keep_eq eqs++    -- Implements criteria K1-K3 in Note [Extending the inert equalities]+    keep_eq (CTyEqCan { cc_tyvar = tv, cc_rhs = rhs_ty, cc_ev = ev+                      , cc_eq_rel = eq_rel })+      | tv == new_tv+      = not (fr_may_rewrite fs)  -- (K1)++      | otherwise+      = check_k2 && check_k3+      where+        fs = ctEvFlavourRole ev+        check_k2 = not (fs  `eqMayRewriteFR` fs)                   -- (K2a)+                ||     (fs  `eqMayRewriteFR` new_fr)               -- (K2b)+                || not (fr_may_rewrite  fs)                        -- (K2c)+                || not (new_tv `elemVarSet` tyCoVarsOfType rhs_ty) -- (K2d)++        check_k3+          | fr_may_rewrite fs+          = case eq_rel of+              NomEq  -> not (rhs_ty `eqType` mkTyVarTy new_tv)+              ReprEq -> not (isTyVarExposed new_tv rhs_ty)++          | otherwise+          = True++    keep_eq ct = pprPanic "keep_eq" (ppr ct)++kickOutAfterUnification :: TcTyVar -> TcS Int+kickOutAfterUnification new_tv+  = do { ics <- getInertCans+       ; (n_kicked, ics2) <- kickOutRewritable (Given,NomEq)+                                                 new_tv ics+                     -- Given because the tv := xi is given; NomEq because+                     -- only nominal equalities are solved by unification++       ; setInertCans ics2+       ; return n_kicked }++{- Note [kickOutRewritable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also Note [inert_eqs: the inert equalities].++When we add a new inert equality (a ~N ty) to the inert set,+we must kick out any inert items that could be rewritten by the+new equality, to maintain the inert-set invariants.++  - We want to kick out an existing inert constraint if+    a) the new constraint can rewrite the inert one+    b) 'a' is free in the inert constraint (so that it *will*)+       rewrite it if we kick it out.++    For (b) we use tyCoVarsOfCt, which returns the type variables /and+    the kind variables/ that are directly visible in the type. Hence+    we will have exposed all the rewriting we care about to make the+    most precise kinds visible for matching classes etc. No need to+    kick out constraints that mention type variables whose kinds+    contain this variable!++  - A Derived equality can kick out [D] constraints in inert_eqs,+    inert_dicts, inert_irreds etc.++  - We don't kick out constraints from inert_solved_dicts, and+    inert_solved_funeqs optimistically. But when we lookup we have to+    take the substitution into account+++Note [Kick out insolubles]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have an insoluble alpha ~ [alpha], which is insoluble+because an occurs check.  And then we unify alpha := [Int].+Then we really want to rewrite the insoluble to [Int] ~ [[Int]].+Now it can be decomposed.  Otherwise we end up with a "Can't match+[Int] ~ [[Int]]" which is true, but a bit confusing because the+outer type constructors match.+-}++++--------------+addInertSafehask :: InertCans -> Ct -> InertCans+addInertSafehask ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })+  = ics { inert_safehask = addDict (inert_dicts ics) cls tys item }++addInertSafehask _ item+  = pprPanic "addInertSafehask: can't happen! Inserting " $ ppr item++insertSafeOverlapFailureTcS :: Ct -> TcS ()+-- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify+insertSafeOverlapFailureTcS item+  = updInertCans (\ics -> addInertSafehask ics item)++getSafeOverlapFailures :: TcS Cts+-- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify+getSafeOverlapFailures+ = do { IC { inert_safehask = safehask } <- getInertCans+      ; return $ foldDicts consCts safehask emptyCts }++--------------+addSolvedDict :: CtEvidence -> Class -> [Type] -> TcS ()+-- Add a new item in the solved set of the monad+-- See Note [Solved dictionaries]+addSolvedDict item cls tys+  | isIPPred (ctEvPred item)    -- Never cache "solved" implicit parameters (not sure why!)+  = return ()+  | otherwise+  = do { traceTcS "updSolvedSetTcs:" $ ppr item+       ; updInertTcS $ \ ics ->+             ics { inert_solved_dicts = addDict (inert_solved_dicts ics) cls tys item } }++{- *********************************************************************+*                                                                      *+                  Other inert-set operations+*                                                                      *+********************************************************************* -}++updInertTcS :: (InertSet -> InertSet) -> TcS ()+-- Modify the inert set with the supplied function+updInertTcS upd_fn+  = do { is_var <- getTcSInertsRef+       ; wrapTcS (do { curr_inert <- TcM.readTcRef is_var+                     ; TcM.writeTcRef is_var (upd_fn curr_inert) }) }++getInertCans :: TcS InertCans+getInertCans = do { inerts <- getTcSInerts; return (inert_cans inerts) }++setInertCans :: InertCans -> TcS ()+setInertCans ics = updInertTcS $ \ inerts -> inerts { inert_cans = ics }++updRetInertCans :: (InertCans -> (a, InertCans)) -> TcS a+-- Modify the inert set with the supplied function+updRetInertCans upd_fn+  = do { is_var <- getTcSInertsRef+       ; wrapTcS (do { inerts <- TcM.readTcRef is_var+                     ; let (res, cans') = upd_fn (inert_cans inerts)+                     ; TcM.writeTcRef is_var (inerts { inert_cans = cans' })+                     ; return res }) }++updInertCans :: (InertCans -> InertCans) -> TcS ()+-- Modify the inert set with the supplied function+updInertCans upd_fn+  = updInertTcS $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) }++updInertDicts :: (DictMap Ct -> DictMap Ct) -> TcS ()+-- Modify the inert set with the supplied function+updInertDicts upd_fn+  = updInertCans $ \ ics -> ics { inert_dicts = upd_fn (inert_dicts ics) }++updInertSafehask :: (DictMap Ct -> DictMap Ct) -> TcS ()+-- Modify the inert set with the supplied function+updInertSafehask upd_fn+  = updInertCans $ \ ics -> ics { inert_safehask = upd_fn (inert_safehask ics) }++updInertFunEqs :: (FunEqMap Ct -> FunEqMap Ct) -> TcS ()+-- Modify the inert set with the supplied function+updInertFunEqs upd_fn+  = updInertCans $ \ ics -> ics { inert_funeqs = upd_fn (inert_funeqs ics) }++updInertIrreds :: (Cts -> Cts) -> TcS ()+-- Modify the inert set with the supplied function+updInertIrreds upd_fn+  = updInertCans $ \ ics -> ics { inert_irreds = upd_fn (inert_irreds ics) }++getInertEqs :: TcS (DTyVarEnv EqualCtList)+getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) }++getInertInsols :: TcS Cts+getInertInsols = do { inert <- getInertCans; return (inert_insols inert) }++getInertGivens :: TcS [Ct]+-- Returns the Given constraints in the inert set,+-- with type functions *not* unflattened+getInertGivens+  = do { inerts <- getInertCans+       ; let all_cts = foldDicts (:) (inert_dicts inerts)+                     $ foldFunEqs (:) (inert_funeqs inerts)+                     $ concat (dVarEnvElts (inert_eqs inerts))+       ; return (filter isGivenCt all_cts) }++getPendingScDicts :: TcS [Ct]+-- Find all inert Given dictionaries whose cc_pend_sc flag is True+-- Set the flag to False in the inert set, and return that Ct+getPendingScDicts = updRetInertCans get_sc_dicts+  where+    get_sc_dicts ic@(IC { inert_dicts = dicts })+      = (sc_pend_dicts, ic')+      where+        ic' = ic { inert_dicts = foldr add dicts sc_pend_dicts }++        sc_pend_dicts :: [Ct]+        sc_pend_dicts = foldDicts get_pending dicts []++    get_pending :: Ct -> [Ct] -> [Ct]  -- Get dicts with cc_pend_sc = True+                                       -- but flipping the flag+    get_pending dict dicts+        | Just dict' <- isPendingScDict dict = dict' : dicts+        | otherwise                          = dicts++    add :: Ct -> DictMap Ct -> DictMap Ct+    add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts+        = addDict dicts cls tys ct+    add ct _ = pprPanic "getPendingScDicts" (ppr ct)++getUnsolvedInerts :: TcS ( Bag Implication+                         , Cts     -- Tyvar eqs: a ~ ty+                         , Cts     -- Fun eqs:   F a ~ ty+                         , Cts     -- Insoluble+                         , Cts )   -- All others+-- Return all the unsolved [Wanted] or [Derived] constraints+--+-- Post-condition: the returned simple constraints are all fully zonked+--                     (because they come from the inert set)+--                 the unsolved implics may not be+getUnsolvedInerts+ = do { IC { inert_eqs    = tv_eqs+           , inert_funeqs = fun_eqs+           , inert_irreds = irreds+           , inert_dicts  = idicts+           , inert_insols = insols+           } <- getInertCans++      ; let unsolved_tv_eqs  = foldTyEqs add_if_unsolved tv_eqs emptyCts+            unsolved_fun_eqs = foldFunEqs add_if_wanted fun_eqs emptyCts+            unsolved_irreds  = Bag.filterBag is_unsolved irreds+            unsolved_dicts   = foldDicts add_if_unsolved idicts emptyCts+            unsolved_others  = unsolved_irreds `unionBags` unsolved_dicts+            unsolved_insols  = filterBag is_unsolved insols++      ; implics <- getWorkListImplics++      ; traceTcS "getUnsolvedInerts" $+        vcat [ text " tv eqs =" <+> ppr unsolved_tv_eqs+             , text "fun eqs =" <+> ppr unsolved_fun_eqs+             , text "insols =" <+> ppr unsolved_insols+             , text "others =" <+> ppr unsolved_others+             , text "implics =" <+> ppr implics ]++      ; return ( implics, unsolved_tv_eqs, unsolved_fun_eqs+               , unsolved_insols, unsolved_others) }+  where+    add_if_unsolved :: Ct -> Cts -> Cts+    add_if_unsolved ct cts | is_unsolved ct = ct `consCts` cts+                           | otherwise      = cts++    is_unsolved ct = not (isGivenCt ct)   -- Wanted or Derived++    -- For CFunEqCans we ignore the Derived ones, and keep+    -- only the Wanteds for flattening.  The Derived ones+    -- share a unification variable with the corresponding+    -- Wanted, so we definitely don't want to to participate+    -- in unflattening+    -- See Note [Type family equations]+    add_if_wanted ct cts | isWantedCt ct = ct `consCts` cts+                         | otherwise     = cts++isInInertEqs :: DTyVarEnv EqualCtList -> TcTyVar -> TcType -> Bool+-- True if (a ~N ty) is in the inert set, in either Given or Wanted+isInInertEqs eqs tv rhs+  = case lookupDVarEnv eqs tv of+      Nothing  -> False+      Just cts -> any (same_pred rhs) cts+  where+    same_pred rhs ct+      | CTyEqCan { cc_rhs = rhs2, cc_eq_rel = eq_rel } <- ct+      , NomEq <- eq_rel+      , rhs `eqType` rhs2 = True+      | otherwise         = False++getNoGivenEqs :: TcLevel          -- TcLevel of this implication+               -> [TcTyVar]       -- Skolems of this implication+               -> TcS ( Bool      -- True <=> definitely no residual given equalities+                      , Cts )     -- Insoluble constraints arising from givens+-- See Note [When does an implication have given equalities?]+getNoGivenEqs tclvl skol_tvs+  = do { inerts@(IC { inert_eqs = ieqs, inert_irreds = iirreds+                    , inert_funeqs = funeqs+                    , inert_insols = insols })+              <- getInertCans+       ; let local_fsks = foldFunEqs add_fsk funeqs emptyVarSet++             has_given_eqs = foldrBag ((||) . ev_given_here . ctEvidence) False+                                      (iirreds `unionBags` insols)+                          || anyDVarEnv (eqs_given_here local_fsks) ieqs++       ; traceTcS "getNoGivenEqs" (vcat [ ppr has_given_eqs, ppr inerts+                                        , ppr insols])+       ; return (not has_given_eqs, insols) }+  where+    eqs_given_here :: VarSet -> EqualCtList -> Bool+    eqs_given_here local_fsks [CTyEqCan { cc_tyvar = tv, cc_ev = ev }]+                              -- Givens are always a sigleton+      = not (skolem_bound_here local_fsks tv) && ev_given_here ev+    eqs_given_here _ _ = False++    ev_given_here :: CtEvidence -> Bool+    -- True for a Given bound by the curent implication,+    -- i.e. the current level+    ev_given_here ev+      =  isGiven ev+      && tclvl == ctLocLevel (ctEvLoc ev)++    add_fsk :: Ct -> VarSet -> VarSet+    add_fsk ct fsks | CFunEqCan { cc_fsk = tv, cc_ev = ev } <- ct+                    , isGiven ev = extendVarSet fsks tv+                    | otherwise  = fsks++    skol_tv_set = mkVarSet skol_tvs+    skolem_bound_here local_fsks tv -- See Note [Let-bound skolems]+      = case tcTyVarDetails tv of+          SkolemTv {} -> tv `elemVarSet` skol_tv_set+          FlatSkol {} -> not (tv `elemVarSet` local_fsks)+          _           -> False++-- | Returns Given constraints that might,+-- potentially, match the given pred. This is used when checking to see if a+-- Given might overlap with an instance. See Note [Instance and Given overlap]+-- in TcInteract.+matchableGivens :: CtLoc -> PredType -> InertSet -> Cts+matchableGivens loc_w pred (IS { inert_cans = inert_cans })+  = filterBag matchable_given all_relevant_givens+  where+    -- just look in class constraints and irreds. matchableGivens does get called+    -- for ~R constraints, but we don't need to look through equalities, because+    -- canonical equalities are used for rewriting. We'll only get caught by+    -- non-canonical -- that is, irreducible -- equalities.+    all_relevant_givens :: Cts+    all_relevant_givens+      | Just (clas, _) <- getClassPredTys_maybe pred+      = findDictsByClass (inert_dicts inert_cans) clas+        `unionBags` inert_irreds inert_cans+      | otherwise+      = inert_irreds inert_cans++    matchable_given :: Ct -> Bool+    matchable_given ct+      | CtGiven { ctev_loc = loc_g } <- ctev+      , Just _ <- tcUnifyTys bind_meta_tv [ctEvPred ctev] [pred]+      , not (prohibitedSuperClassSolve loc_g loc_w)+      = True++      | otherwise+      = False+      where+        ctev = cc_ev ct++    bind_meta_tv :: TcTyVar -> BindFlag+    -- Any meta tyvar may be unified later, so we treat it as+    -- bindable when unifying with givens. That ensures that we+    -- conservatively assume that a meta tyvar might get unified with+    -- something that matches the 'given', until demonstrated+    -- otherwise.+    bind_meta_tv tv | isMetaTyVar tv = BindMe+                    | otherwise      = Skolem++prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool+-- See Note [Solving superclass constraints] in TcInstDcls+prohibitedSuperClassSolve from_loc solve_loc+  | GivenOrigin (InstSC given_size) <- ctLocOrigin from_loc+  , ScOrigin wanted_size <- ctLocOrigin solve_loc+  = given_size >= wanted_size+  | otherwise+  = False++{- Note [Unsolved Derived equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In getUnsolvedInerts, we return a derived equality from the inert_eqs+because it is a candidate for floating out of this implication.  We+only float equalities with a meta-tyvar on the left, so we only pull+those out here.++Note [When does an implication have given equalities?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider an implication+   beta => alpha ~ Int+where beta is a unification variable that has already been unified+to () in an outer scope.  Then we can float the (alpha ~ Int) out+just fine. So when deciding whether the givens contain an equality,+we should canonicalise first, rather than just looking at the original+givens (Trac #8644).++So we simply look at the inert, canonical Givens and see if there are+any equalities among them, the calculation of has_given_eqs.  There+are some wrinkles:++ * We must know which ones are bound in *this* implication and which+   are bound further out.  We can find that out from the TcLevel+   of the Given, which is itself recorded in the tcl_tclvl field+   of the TcLclEnv stored in the Given (ev_given_here).++   What about interactions between inner and outer givens?+      - Outer given is rewritten by an inner given, then there must+        have been an inner given equality, hence the “given-eq” flag+        will be true anyway.++      - Inner given rewritten by outer, retains its level (ie. The inner one)++ * We must take account of *potential* equalities, like the one above:+      beta => ...blah...+   If we still don't know what beta is, we conservatively treat it as potentially+   becoming an equality. Hence including 'irreds' in the calculation or has_given_eqs.++ * When flattening givens, we generate Given equalities like+     <F [a]> : F [a] ~ f,+   with Refl evidence, and we *don't* want those to count as an equality+   in the givens!  After all, the entire flattening business is just an+   internal matter, and the evidence does not mention any of the 'givens'+   of this implication.  So we do not treat inert_funeqs as a 'given equality'.++ * See Note [Let-bound skolems] for another wrinkle++ * We do *not* need to worry about representational equalities, because+   these do not affect the ability to float constraints.++Note [Let-bound skolems]+~~~~~~~~~~~~~~~~~~~~~~~~+If   * the inert set contains a canonical Given CTyEqCan (a ~ ty)+and  * 'a' is a skolem bound in this very implication, b++then:+a) The Given is pretty much a let-binding, like+      f :: (a ~ b->c) => a -> a+   Here the equality constraint is like saying+      let a = b->c in ...+   It is not adding any new, local equality  information,+   and hence can be ignored by has_given_eqs++b) 'a' will have been completely substituted out in the inert set,+   so we can safely discard it.  Notably, it doesn't need to be+   returned as part of 'fsks'++For an example, see Trac #9211.+-}++removeInertCts :: [Ct] -> InertCans -> InertCans+-- ^ Remove inert constraints from the 'InertCans', for use when a+-- typechecker plugin wishes to discard a given.+removeInertCts cts icans = foldl' removeInertCt icans cts++removeInertCt :: InertCans -> Ct -> InertCans+removeInertCt is ct =+  case ct of++    CDictCan  { cc_class = cl, cc_tyargs = tys } ->+      is { inert_dicts = delDict (inert_dicts is) cl tys }++    CFunEqCan { cc_fun  = tf,  cc_tyargs = tys } ->+      is { inert_funeqs = delFunEq (inert_funeqs is) tf tys }++    CTyEqCan  { cc_tyvar = x,  cc_rhs    = ty } ->+      is { inert_eqs    = delTyEq (inert_eqs is) x ty }++    CIrredEvCan {}   -> panic "removeInertCt: CIrredEvCan"+    CNonCanonical {} -> panic "removeInertCt: CNonCanonical"+    CHoleCan {}      -> panic "removeInertCt: CHoleCan"+++lookupFlatCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavour))+lookupFlatCache fam_tc tys+  = do { IS { inert_flat_cache = flat_cache+            , inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts+       ; return (firstJusts [lookup_inerts inert_funeqs,+                             lookup_flats flat_cache]) }+  where+    lookup_inerts inert_funeqs+      | Just (CFunEqCan { cc_ev = ctev, cc_fsk = fsk, cc_tyargs = xis })+           <- findFunEq inert_funeqs fam_tc tys+      , tys `eqTypes` xis   -- The lookup might find a near-match; see+                            -- Note [Use loose types in inert set]+      = Just (ctEvCoercion ctev, mkTyVarTy fsk, ctEvFlavour ctev)+      | otherwise = Nothing++    lookup_flats flat_cache = findExactFunEq flat_cache fam_tc tys+++lookupInInerts :: TcPredType -> TcS (Maybe CtEvidence)+-- Is this exact predicate type cached in the solved or canonicals of the InertSet?+lookupInInerts pty+  | ClassPred cls tys <- classifyPredType pty+  = do { inerts <- getTcSInerts+       ; return (lookupSolvedDict inerts cls tys `mplus`+                 lookupInertDict (inert_cans inerts) cls tys) }+  | otherwise -- NB: No caching for equalities, IPs, holes, or errors+  = return Nothing++-- | Look up a dictionary inert. NB: the returned 'CtEvidence' might not+-- match the input exactly. Note [Use loose types in inert set].+lookupInertDict :: InertCans -> Class -> [Type] -> Maybe CtEvidence+lookupInertDict (IC { inert_dicts = dicts }) cls tys+  = case findDict dicts cls tys of+      Just ct -> Just (ctEvidence ct)+      _       -> Nothing++-- | Look up a solved inert. NB: the returned 'CtEvidence' might not+-- match the input exactly. See Note [Use loose types in inert set].+lookupSolvedDict :: InertSet -> Class -> [Type] -> Maybe CtEvidence+-- Returns just if exactly this predicate type exists in the solved.+lookupSolvedDict (IS { inert_solved_dicts = solved }) cls tys+  = case findDict solved cls tys of+      Just ev -> Just ev+      _       -> Nothing++{- *********************************************************************+*                                                                      *+                   Irreds+*                                                                      *+********************************************************************* -}++foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b+foldIrreds k irreds z = foldrBag k z irreds+++{- *********************************************************************+*                                                                      *+                   TcAppMap+*                                                                      *+************************************************************************++Note [Use loose types in inert set]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Say we know (Eq (a |> c1)) and we need (Eq (a |> c2)). One is clearly+solvable from the other. So, we do lookup in the inert set using+loose types, which omit the kind-check.++We must be careful when using the result of a lookup because it may+not match the requsted info exactly!++-}++type TcAppMap a = UniqDFM (ListMap LooseTypeMap a)+    -- Indexed by tycon then the arg types, using "loose" matching, where+    -- we don't require kind equality. This allows, for example, (a |> co)+    -- to match (a).+    -- See Note [Use loose types in inert set]+    -- Used for types and classes; hence UniqDFM+    -- See Note [foldTM determinism] for why we use UniqDFM here++isEmptyTcAppMap :: TcAppMap a -> Bool+isEmptyTcAppMap m = isNullUDFM m++emptyTcAppMap :: TcAppMap a+emptyTcAppMap = emptyUDFM++findTcApp :: TcAppMap a -> Unique -> [Type] -> Maybe a+findTcApp m u tys = do { tys_map <- lookupUDFM m u+                       ; lookupTM tys tys_map }++delTcApp :: TcAppMap a -> Unique -> [Type] -> TcAppMap a+delTcApp m cls tys = adjustUDFM (deleteTM tys) m cls++insertTcApp :: TcAppMap a -> Unique -> [Type] -> a -> TcAppMap a+insertTcApp m cls tys ct = alterUDFM alter_tm m cls+  where+    alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM))++-- mapTcApp :: (a->b) -> TcAppMap a -> TcAppMap b+-- mapTcApp f = mapUDFM (mapTM f)++filterTcAppMap :: (Ct -> Bool) -> TcAppMap Ct -> TcAppMap Ct+filterTcAppMap f m+  = mapUDFM do_tm m+  where+    do_tm tm = foldTM insert_mb tm emptyTM+    insert_mb ct tm+       | f ct      = insertTM tys ct tm+       | otherwise = tm+       where+         tys = case ct of+                CFunEqCan { cc_tyargs = tys } -> tys+                CDictCan  { cc_tyargs = tys } -> tys+                _ -> pprPanic "filterTcAppMap" (ppr ct)++tcAppMapToBag :: TcAppMap a -> Bag a+tcAppMapToBag m = foldTcAppMap consBag m emptyBag++foldTcAppMap :: (a -> b -> b) -> TcAppMap a -> b -> b+foldTcAppMap k m z = foldUDFM (foldTM k) z m+++{- *********************************************************************+*                                                                      *+                   DictMap+*                                                                      *+********************************************************************* -}++type DictMap a = TcAppMap a++emptyDictMap :: DictMap a+emptyDictMap = emptyTcAppMap++-- sizeDictMap :: DictMap a -> Int+-- sizeDictMap m = foldDicts (\ _ x -> x+1) m 0++findDict :: DictMap a -> Class -> [Type] -> Maybe a+findDict m cls tys = findTcApp m (getUnique cls) tys++findDictsByClass :: DictMap a -> Class -> Bag a+findDictsByClass m cls+  | Just tm <- lookupUDFM m cls = foldTM consBag tm emptyBag+  | otherwise                  = emptyBag++delDict :: DictMap a -> Class -> [Type] -> DictMap a+delDict m cls tys = delTcApp m (getUnique cls) tys++addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a+addDict m cls tys item = insertTcApp m (getUnique cls) tys item++addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct+addDictsByClass m cls items+  = addToUDFM m cls (foldrBag add emptyTM items)+  where+    add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm+    add ct _ = pprPanic "addDictsByClass" (ppr ct)++filterDicts :: (Ct -> Bool) -> DictMap Ct -> DictMap Ct+filterDicts f m = filterTcAppMap f m++partitionDicts :: (Ct -> Bool) -> DictMap Ct -> (Bag Ct, DictMap Ct)+partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDicts)+  where+    k ct (yeses, noes) | f ct      = (ct `consBag` yeses, noes)+                       | otherwise = (yeses,              add ct noes)+    add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) m+      = addDict m cls tys ct+    add ct _ = pprPanic "partitionDicts" (ppr ct)++dictsToBag :: DictMap a -> Bag a+dictsToBag = tcAppMapToBag++foldDicts :: (a -> b -> b) -> DictMap a -> b -> b+foldDicts = foldTcAppMap++emptyDicts :: DictMap a+emptyDicts = emptyTcAppMap+++{- *********************************************************************+*                                                                      *+                   FunEqMap+*                                                                      *+********************************************************************* -}++type FunEqMap a = TcAppMap a  -- A map whose key is a (TyCon, [Type]) pair++emptyFunEqs :: TcAppMap a+emptyFunEqs = emptyTcAppMap++findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a+findFunEq m tc tys = findTcApp m (getUnique tc) tys++funEqsToBag :: FunEqMap a -> Bag a+funEqsToBag m = foldTcAppMap consBag m emptyBag++findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a]+-- Get inert function equation constraints that have the given tycon+-- in their head.  Not that the constraints remain in the inert set.+-- We use this to check for derived interactions with built-in type-function+-- constructors.+findFunEqsByTyCon m tc+  | Just tm <- lookupUDFM m tc = foldTM (:) tm []+  | otherwise                 = []++foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b+foldFunEqs = foldTcAppMap++-- mapFunEqs :: (a -> b) -> FunEqMap a -> FunEqMap b+-- mapFunEqs = mapTcApp++-- filterFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> FunEqMap Ct+-- filterFunEqs = filterTcAppMap++insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a+insertFunEq m tc tys val = insertTcApp m (getUnique tc) tys val++partitionFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> ([Ct], FunEqMap Ct)+-- Optimise for the case where the predicate is false+-- partitionFunEqs is called only from kick-out, and kick-out usually+-- kicks out very few equalities, so we want to optimise for that case+partitionFunEqs f m = (yeses, foldr del m yeses)+  where+    yeses = foldTcAppMap k m []+    k ct yeses | f ct      = ct : yeses+               | otherwise = yeses+    del (CFunEqCan { cc_fun = tc, cc_tyargs = tys }) m+        = delFunEq m tc tys+    del ct _ = pprPanic "partitionFunEqs" (ppr ct)++delFunEq :: FunEqMap a -> TyCon -> [Type] -> FunEqMap a+delFunEq m tc tys = delTcApp m (getUnique tc) tys++------------------------------+type ExactFunEqMap a = UniqFM (ListMap TypeMap a)++emptyExactFunEqs :: ExactFunEqMap a+emptyExactFunEqs = emptyUFM++findExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> Maybe a+findExactFunEq m tc tys = do { tys_map <- lookupUFM m (getUnique tc)+                             ; lookupTM tys tys_map }++insertExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> a -> ExactFunEqMap a+insertExactFunEq m tc tys val = alterUFM alter_tm m (getUnique tc)+  where alter_tm mb_tm = Just (insertTM tys val (mb_tm `orElse` emptyTM))++{-+************************************************************************+*                                                                      *+*              The TcS solver monad                                    *+*                                                                      *+************************************************************************++Note [The TcS monad]+~~~~~~~~~~~~~~~~~~~~+The TcS monad is a weak form of the main Tc monad++All you can do is+    * fail+    * allocate new variables+    * fill in evidence variables++Filling in a dictionary evidence variable means to create a binding+for it, so TcS carries a mutable location where the binding can be+added.  This is initialised from the innermost implication constraint.+-}++data TcSEnv+  = TcSEnv {+      tcs_ev_binds    :: EvBindsVar,++      tcs_unified     :: IORef Int,+         -- The number of unification variables we have filled+         -- The important thing is whether it is non-zero++      tcs_count     :: IORef Int, -- Global step count++      tcs_inerts    :: IORef InertSet, -- Current inert set++      -- The main work-list and the flattening worklist+      -- See Note [Work list priorities] and+      tcs_worklist  :: IORef WorkList -- Current worklist+    }++---------------+newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a }++instance Functor TcS where+  fmap f m = TcS $ fmap f . unTcS m++instance Applicative TcS where+  pure x = TcS (\_ -> return x)+  (<*>) = ap++instance Monad TcS where+  fail err  = TcS (\_ -> fail err)+  m >>= k   = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs)++#if __GLASGOW_HASKELL__ > 710+instance MonadFail.MonadFail TcS where+  fail err  = TcS (\_ -> fail err)+#endif++instance MonadUnique TcS where+   getUniqueSupplyM = wrapTcS getUniqueSupplyM++-- Basic functionality+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+wrapTcS :: TcM a -> TcS a+-- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS,+-- and TcS is supposed to have limited functionality+wrapTcS = TcS . const -- a TcM action will not use the TcEvBinds++wrapErrTcS :: TcM a -> TcS a+-- The thing wrapped should just fail+-- There's no static check; it's up to the user+-- Having a variant for each error message is too painful+wrapErrTcS = wrapTcS++wrapWarnTcS :: TcM a -> TcS a+-- The thing wrapped should just add a warning, or no-op+-- There's no static check; it's up to the user+wrapWarnTcS = wrapTcS++failTcS, panicTcS  :: SDoc -> TcS a+warnTcS   :: WarningFlag -> SDoc -> TcS ()+addErrTcS :: SDoc -> TcS ()+failTcS      = wrapTcS . TcM.failWith+warnTcS flag = wrapTcS . TcM.addWarn (Reason flag)+addErrTcS    = wrapTcS . TcM.addErr+panicTcS doc = pprPanic "TcCanonical" doc++traceTcS :: String -> SDoc -> TcS ()+traceTcS herald doc = wrapTcS (TcM.traceTc herald doc)++runTcPluginTcS :: TcPluginM a -> TcS a+runTcPluginTcS m = wrapTcS . runTcPluginM m =<< getTcEvBindsVar++instance HasDynFlags TcS where+    getDynFlags = wrapTcS getDynFlags++getGlobalRdrEnvTcS :: TcS GlobalRdrEnv+getGlobalRdrEnvTcS = wrapTcS TcM.getGlobalRdrEnv++bumpStepCountTcS :: TcS ()+bumpStepCountTcS = TcS $ \env -> do { let ref = tcs_count env+                                    ; n <- TcM.readTcRef ref+                                    ; TcM.writeTcRef ref (n+1) }++csTraceTcS :: SDoc -> TcS ()+csTraceTcS doc+  = wrapTcS $ csTraceTcM (return doc)++traceFireTcS :: CtEvidence -> SDoc -> TcS ()+-- Dump a rule-firing trace+traceFireTcS ev doc+  = TcS $ \env -> csTraceTcM $+    do { n <- TcM.readTcRef (tcs_count env)+       ; tclvl <- TcM.getTcLevel+       ; return (hang (text "Step" <+> int n+                       <> brackets (text "l:" <> ppr tclvl <> comma <>+                                    text "d:" <> ppr (ctLocDepth (ctEvLoc ev)))+                       <+> doc <> colon)+                     4 (ppr ev)) }++csTraceTcM :: TcM SDoc -> TcM ()+-- Constraint-solver tracing, -ddump-cs-trace+csTraceTcM mk_doc+  = do { dflags <- getDynFlags+       ; when (  dopt Opt_D_dump_cs_trace dflags+                  || dopt Opt_D_dump_tc_trace dflags )+              ( do { msg <- mk_doc+                   ; TcM.traceTcRn Opt_D_dump_cs_trace msg }) }++runTcS :: TcS a                -- What to run+       -> TcM (a, EvBindMap)+runTcS tcs+  = do { ev_binds_var <- TcM.newTcEvBinds+       ; res <- runTcSWithEvBinds ev_binds_var tcs+       ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var+       ; return (res, ev_binds) }++-- | This variant of 'runTcS' will keep solving, even when only Deriveds+-- are left around. It also doesn't return any evidence, as callers won't+-- need it.+runTcSDeriveds :: TcS a -> TcM a+runTcSDeriveds tcs+  = do { ev_binds_var <- TcM.newTcEvBinds+       ; runTcSWithEvBinds ev_binds_var tcs }++-- | This can deal only with equality constraints.+runTcSEqualities :: TcS a -> TcM a+runTcSEqualities thing_inside+  = do { ev_binds_var <- TcM.newTcEvBinds+       ; runTcSWithEvBinds ev_binds_var thing_inside }++runTcSWithEvBinds :: EvBindsVar+                  -> TcS a+                  -> TcM a+runTcSWithEvBinds ev_binds_var tcs+  = do { unified_var <- TcM.newTcRef 0+       ; step_count <- TcM.newTcRef 0+       ; inert_var <- TcM.newTcRef emptyInert+       ; wl_var <- TcM.newTcRef emptyWorkList+       ; let env = TcSEnv { tcs_ev_binds      = ev_binds_var+                          , tcs_unified       = unified_var+                          , tcs_count         = step_count+                          , tcs_inerts        = inert_var+                          , tcs_worklist      = wl_var }++             -- Run the computation+       ; res <- unTcS tcs env++       ; count <- TcM.readTcRef step_count+       ; when (count > 0) $+         csTraceTcM $ return (text "Constraint solver steps =" <+> int count)++#ifdef DEBUG+       ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var+       ; checkForCyclicBinds ev_binds+#endif++       ; return res }++#ifdef DEBUG+checkForCyclicBinds :: EvBindMap -> TcM ()+checkForCyclicBinds ev_binds_map+  | null cycles+  = return ()+  | null coercion_cycles+  = TcM.traceTc "Cycle in evidence binds" $ ppr cycles+  | otherwise+  = pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles+  where+    ev_binds = evBindMapBinds ev_binds_map++    cycles :: [[EvBind]]+    cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVerticesUniq edges]++    coercion_cycles = [c | c <- cycles, any is_co_bind c]+    is_co_bind (EvBind { eb_lhs = b }) = isEqPred (varType b)++    edges :: [(EvBind, EvVar, [EvVar])]+    edges = [ (bind, bndr, nonDetEltsUniqSet (evVarsOfTerm rhs))+            | bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) <- bagToList ev_binds ]+            -- It's OK to use nonDetEltsUFM here as+            -- stronglyConnCompFromEdgedVertices is still deterministic even+            -- if the edges are in nondeterministic order as explained in+            -- Note [Deterministic SCC] in Digraph.+#endif++setEvBindsTcS :: EvBindsVar -> TcS a -> TcS a+setEvBindsTcS ref (TcS thing_inside)+ = TcS $ \ env -> thing_inside (env { tcs_ev_binds = ref })++nestImplicTcS :: EvBindsVar+              -> TcLevel -> TcS a+              -> TcS a+nestImplicTcS ref inner_tclvl (TcS thing_inside)+  = TcS $ \ TcSEnv { tcs_unified       = unified_var+                   , tcs_inerts        = old_inert_var+                   , tcs_count         = count+                   } ->+    do { inerts <- TcM.readTcRef old_inert_var+       ; let nest_inert = inerts { inert_flat_cache = emptyExactFunEqs }+                                     -- See Note [Do not inherit the flat cache]+       ; new_inert_var <- TcM.newTcRef nest_inert+       ; new_wl_var    <- TcM.newTcRef emptyWorkList+       ; let nest_env = TcSEnv { tcs_ev_binds      = ref+                               , tcs_unified       = unified_var+                               , tcs_count         = count+                               , tcs_inerts        = new_inert_var+                               , tcs_worklist      = new_wl_var }+       ; res <- TcM.setTcLevel inner_tclvl $+                thing_inside nest_env++#ifdef DEBUG+       -- Perform a check that the thing_inside did not cause cycles+       ; ev_binds <- TcM.getTcEvBindsMap ref+       ; checkForCyclicBinds ev_binds+#endif+       ; return res }++{- Note [Do not inherit the flat cache]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do not want to inherit the flat cache when processing nested+implications.  Consider+   a ~ F b, forall c. b~Int => blah+If we have F b ~ fsk in the flat-cache, and we push that into the+nested implication, we might miss that F b can be rewritten to F Int,+and hence perhpas solve it.  Moreover, the fsk from outside is+flattened out after solving the outer level, but and we don't+do that flattening recursively.+-}++nestTcS ::  TcS a -> TcS a+-- Use the current untouchables, augmenting the current+-- evidence bindings, and solved dictionaries+-- But have no effect on the InertCans, or on the inert_flat_cache+-- (we want to inherit the latter from processing the Givens)+nestTcS (TcS thing_inside)+  = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) ->+    do { inerts <- TcM.readTcRef inerts_var+       ; new_inert_var <- TcM.newTcRef inerts+       ; new_wl_var    <- TcM.newTcRef emptyWorkList+       ; let nest_env = env { tcs_inerts   = new_inert_var+                            , tcs_worklist = new_wl_var }++       ; res <- thing_inside nest_env++       ; new_inerts <- TcM.readTcRef new_inert_var++       -- we want to propogate the safe haskell failures+       ; let old_ic = inert_cans inerts+             new_ic = inert_cans new_inerts+             nxt_ic = old_ic { inert_safehask = inert_safehask new_ic }++       ; TcM.writeTcRef inerts_var  -- See Note [Propagate the solved dictionaries]+                        (inerts { inert_solved_dicts = inert_solved_dicts new_inerts+                                , inert_cans = nxt_ic })++       ; return res }++buildImplication :: SkolemInfo+                 -> [TcTyVar]        -- Skolems+                 -> [EvVar]          -- Givens+                 -> TcS result+                 -> TcS (Bag Implication, TcEvBinds, result)+-- Just like TcUnify.buildImplication, but in the TcS monnad,+-- using the work-list to gather the constraints+buildImplication skol_info skol_tvs givens (TcS thing_inside)+  = TcS $ \ env ->+    do { new_wl_var <- TcM.newTcRef emptyWorkList+       ; tc_lvl <- TcM.getTcLevel+       ; let new_tclvl = pushTcLevel tc_lvl++       ; res <- TcM.setTcLevel new_tclvl $+                thing_inside (env { tcs_worklist = new_wl_var })++       ; wl@WL { wl_eqs = eqs } <- TcM.readTcRef new_wl_var+       ; if null eqs+         then return (emptyBag, emptyTcEvBinds, res)+         else+    do { env <- TcM.getLclEnv+       ; ev_binds_var <- TcM.newTcEvBinds+       ; let wc  = ASSERT2( null (wl_funeqs wl) && null (wl_rest wl) &&+                            null (wl_deriv wl) && null (wl_implics wl), ppr wl )+                   WC { wc_simple = listToCts eqs+                      , wc_impl   = emptyBag+                      , wc_insol  = emptyCts }+             imp = Implic { ic_tclvl  = new_tclvl+                          , ic_skols  = skol_tvs+                          , ic_no_eqs = True+                          , ic_given  = givens+                          , ic_wanted = wc+                          , ic_status = IC_Unsolved+                          , ic_binds  = ev_binds_var+                          , ic_env    = env+                          , ic_needed = emptyVarSet+                          , ic_info   = skol_info }+      ; return (unitBag imp, TcEvBinds ev_binds_var, res) } }++{-+Note [Propagate the solved dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's really quite important that nestTcS does not discard the solved+dictionaries from the thing_inside.+Consider+   Eq [a]+   forall b. empty =>  Eq [a]+We solve the simple (Eq [a]), under nestTcS, and then turn our attention to+the implications.  It's definitely fine to use the solved dictionaries on+the inner implications, and it can make a signficant performance difference+if you do so.+-}++-- Getters and setters of TcEnv fields+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++-- Getter of inerts and worklist+getTcSInertsRef :: TcS (IORef InertSet)+getTcSInertsRef = TcS (return . tcs_inerts)++getTcSWorkListRef :: TcS (IORef WorkList)+getTcSWorkListRef = TcS (return . tcs_worklist)++getTcSInerts :: TcS InertSet+getTcSInerts = getTcSInertsRef >>= wrapTcS . (TcM.readTcRef)++setTcSInerts :: InertSet -> TcS ()+setTcSInerts ics = do { r <- getTcSInertsRef; wrapTcS (TcM.writeTcRef r ics) }++getWorkListImplics :: TcS (Bag Implication)+getWorkListImplics+  = do { wl_var <- getTcSWorkListRef+       ; wl_curr <- wrapTcS (TcM.readTcRef wl_var)+       ; return (wl_implics wl_curr) }++updWorkListTcS :: (WorkList -> WorkList) -> TcS ()+updWorkListTcS f+  = do { wl_var <- getTcSWorkListRef+       ; wl_curr <- wrapTcS (TcM.readTcRef wl_var)+       ; let new_work = f wl_curr+       ; wrapTcS (TcM.writeTcRef wl_var new_work) }++emitWorkNC :: [CtEvidence] -> TcS ()+emitWorkNC evs+  | null evs+  = return ()+  | otherwise+  = emitWork (map mkNonCanonical evs)++emitWork :: [Ct] -> TcS ()+emitWork cts+  = do { traceTcS "Emitting fresh work" (vcat (map ppr cts))+       ; updWorkListTcS (extendWorkListCts cts) }++emitInsoluble :: Ct -> TcS ()+-- Emits a non-canonical constraint that will stand for a frozen error in the inerts.+emitInsoluble ct+  = do { traceTcS "Emit insoluble" (ppr ct $$ pprCtLoc (ctLoc ct))+       ; updInertTcS add_insol }+  where+    this_pred = ctPred ct+    add_insol is@(IS { inert_cans = ics@(IC { inert_insols = old_insols }) })+      | already_there = is+      | otherwise     = is { inert_cans = ics { inert_insols = old_insols `snocCts` ct } }+      where+        already_there = not (isWantedCt ct) && anyBag (tcEqType this_pred . ctPred) old_insols+             -- See Note [Do not add duplicate derived insolubles]++newTcRef :: a -> TcS (TcRef a)+newTcRef x = wrapTcS (TcM.newTcRef x)++readTcRef :: TcRef a -> TcS a+readTcRef ref = wrapTcS (TcM.readTcRef ref)++updTcRef :: TcRef a -> (a->a) -> TcS ()+updTcRef ref upd_fn = wrapTcS (TcM.updTcRef ref upd_fn)++getTcEvBindsVar :: TcS EvBindsVar+getTcEvBindsVar = TcS (return . tcs_ev_binds)++getTcLevel :: TcS TcLevel+getTcLevel = wrapTcS TcM.getTcLevel++getTcEvBindsAndTCVs :: EvBindsVar -> TcS (EvBindMap, TyCoVarSet)+getTcEvBindsAndTCVs ev_binds_var+  = wrapTcS $ do { bnds <- TcM.getTcEvBindsMap ev_binds_var+                 ; tcvs <- TcM.getTcEvTyCoVars ev_binds_var+                 ; return (bnds, tcvs) }++getTcEvBindsMap :: TcS EvBindMap+getTcEvBindsMap+  = do { ev_binds_var <- getTcEvBindsVar+       ; wrapTcS $ TcM.getTcEvBindsMap ev_binds_var }++unifyTyVar :: TcTyVar -> TcType -> TcS ()+-- Unify a meta-tyvar with a type+-- We keep track of how many unifications have happened in tcs_unified,+--+-- We should never unify the same variable twice!+unifyTyVar tv ty+  = ASSERT2( isMetaTyVar tv, ppr tv )+    TcS $ \ env ->+    do { TcM.traceTc "unifyTyVar" (ppr tv <+> text ":=" <+> ppr ty)+       ; TcM.writeMetaTyVar tv ty+       ; TcM.updTcRef (tcs_unified env) (+1) }++unflattenFmv :: TcTyVar -> TcType -> TcS ()+-- Fill a flatten-meta-var, simply by unifying it.+-- This does NOT count as a unification in tcs_unified.+unflattenFmv tv ty+  = ASSERT2( isMetaTyVar tv, ppr tv )+    TcS $ \ _ ->+    do { TcM.traceTc "unflattenFmv" (ppr tv <+> text ":=" <+> ppr ty)+       ; TcM.writeMetaTyVar tv ty }++reportUnifications :: TcS a -> TcS (Int, a)+reportUnifications (TcS thing_inside)+  = TcS $ \ env ->+    do { inner_unified <- TcM.newTcRef 0+       ; res <- thing_inside (env { tcs_unified = inner_unified })+       ; n_unifs <- TcM.readTcRef inner_unified+       ; TcM.updTcRef (tcs_unified env) (+ n_unifs)+       ; return (n_unifs, res) }++getDefaultInfo ::  TcS ([Type], (Bool, Bool))+getDefaultInfo = wrapTcS TcM.tcGetDefaultTys++-- Just get some environments needed for instance looking up and matching+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++getInstEnvs :: TcS InstEnvs+getInstEnvs = wrapTcS $ TcM.tcGetInstEnvs++getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv)+getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs++getTopEnv :: TcS HscEnv+getTopEnv = wrapTcS $ TcM.getTopEnv++getGblEnv :: TcS TcGblEnv+getGblEnv = wrapTcS $ TcM.getGblEnv++getLclEnv :: TcS TcLclEnv+getLclEnv = wrapTcS $ TcM.getLclEnv++tcLookupClass :: Name -> TcS Class+tcLookupClass c = wrapTcS $ TcM.tcLookupClass c++tcLookupId :: Name -> TcS Id+tcLookupId n = wrapTcS $ TcM.tcLookupId n++-- Setting names as used (used in the deriving of Coercible evidence)+-- Too hackish to expose it to TcS? In that case somehow extract the used+-- constructors from the result of solveInteract+addUsedGREs :: [GlobalRdrElt] -> TcS ()+addUsedGREs gres = wrapTcS  $ TcM.addUsedGREs gres++addUsedGRE :: Bool -> GlobalRdrElt -> TcS ()+addUsedGRE warn_if_deprec gre = wrapTcS $ TcM.addUsedGRE warn_if_deprec gre+++-- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++checkWellStagedDFun :: PredType -> DFunId -> CtLoc -> TcS ()+checkWellStagedDFun pred dfun_id loc+  = wrapTcS $ TcM.setCtLocM loc $+    do { use_stage <- TcM.getStage+       ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }+  where+    pp_thing = text "instance for" <+> quotes (ppr pred)+    bind_lvl = TcM.topIdLvl dfun_id++pprEq :: TcType -> TcType -> SDoc+pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2++isTouchableMetaTyVarTcS :: TcTyVar -> TcS Bool+isTouchableMetaTyVarTcS tv+  = do { tclvl <- getTcLevel+       ; return $ isTouchableMetaTyVar tclvl tv }++isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type)+isFilledMetaTyVar_maybe tv+ = case tcTyVarDetails tv of+     MetaTv { mtv_ref = ref }+        -> do { cts <- wrapTcS (TcM.readTcRef ref)+              ; case cts of+                  Indirect ty -> return (Just ty)+                  Flexi       -> return Nothing }+     _ -> return Nothing++isFilledMetaTyVar :: TcTyVar -> TcS Bool+isFilledMetaTyVar tv = wrapTcS (TcM.isFilledMetaTyVar tv)++zonkTyCoVarsAndFV :: TcTyCoVarSet -> TcS TcTyCoVarSet+zonkTyCoVarsAndFV tvs = wrapTcS (TcM.zonkTyCoVarsAndFV tvs)++zonkTyCoVarsAndFVList :: [TcTyCoVar] -> TcS [TcTyCoVar]+zonkTyCoVarsAndFVList tvs = wrapTcS (TcM.zonkTyCoVarsAndFVList tvs)++zonkCo :: Coercion -> TcS Coercion+zonkCo = wrapTcS . TcM.zonkCo++zonkTcType :: TcType -> TcS TcType+zonkTcType ty = wrapTcS (TcM.zonkTcType ty)++zonkTcTypes :: [TcType] -> TcS [TcType]+zonkTcTypes tys = wrapTcS (TcM.zonkTcTypes tys)++zonkTcTyVar :: TcTyVar -> TcS TcType+zonkTcTyVar tv = wrapTcS (TcM.zonkTcTyVar tv)++zonkSimples :: Cts -> TcS Cts+zonkSimples cts = wrapTcS (TcM.zonkSimples cts)++zonkWC :: WantedConstraints -> TcS WantedConstraints+zonkWC wc = wrapTcS (TcM.zonkWC wc)++{-+Note [Do not add duplicate derived insolubles]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general we *must* add an insoluble (Int ~ Bool) even if there is+one such there already, because they may come from distinct call+sites.  Not only do we want an error message for each, but with+-fdefer-type-errors we must generate evidence for each.  But for+*derived* insolubles, we only want to report each one once.  Why?++(a) A constraint (C r s t) where r -> s, say, may generate the same fundep+    equality many times, as the original constraint is successively rewritten.++(b) Ditto the successive iterations of the main solver itself, as it traverses+    the constraint tree. See example below.++Also for *given* insolubles we may get repeated errors, as we+repeatedly traverse the constraint tree.  These are relatively rare+anyway, so removing duplicates seems ok.  (Alternatively we could take+the SrcLoc into account.)++Note that the test does not need to be particularly efficient because+it is only used if the program has a type error anyway.++Example of (b): assume a top-level class and instance declaration:++  class D a b | a -> b+  instance D [a] [a]++Assume we have started with an implication:++  forall c. Eq c => { wc_simple = D [c] c [W] }++which we have simplified to:++  forall c. Eq c => { wc_simple = D [c] c [W]+                    , wc_insols = (c ~ [c]) [D] }++For some reason, e.g. because we floated an equality somewhere else,+we might try to re-solve this implication. If we do not do a+dropDerivedWC, then we will end up trying to solve the following+constraints the second time:++  (D [c] c) [W]+  (c ~ [c]) [D]++which will result in two Deriveds to end up in the insoluble set:++  wc_simple   = D [c] c [W]+  wc_insols = (c ~ [c]) [D], (c ~ [c]) [D]+-}++-- Flatten skolems+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+newFlattenSkolem :: CtFlavour -> CtLoc+                 -> TyCon -> [TcType]                    -- F xis+                 -> TcS (CtEvidence, Coercion, TcTyVar)  -- [G/WD] x:: F xis ~ fsk+newFlattenSkolem flav loc tc xis+  = do { stuff@(ev, co, fsk) <- new_skolem+       ; let fsk_ty = mkTyVarTy fsk+       ; extendFlatCache tc xis (co, fsk_ty, ctEvFlavour ev)+       ; return stuff }+  where+    fam_ty = mkTyConApp tc xis++    new_skolem+      | Given <- flav+      = do { fsk <- wrapTcS (TcM.newFskTyVar fam_ty)+           ; let co = mkNomReflCo fam_ty+           ; ev  <- newGivenEvVar loc (mkPrimEqPred fam_ty (mkTyVarTy fsk),+                                       EvCoercion co)+           ; return (ev, co, fsk) }++      | otherwise  -- Generate a [WD] for both Wanted and Derived+                   -- See Note [No Derived CFunEqCans]+      = do { fmv <- wrapTcS (TcM.newFmvTyVar fam_ty)+           ; (ev, hole_co) <- newWantedEq loc Nominal fam_ty (mkTyVarTy fmv)+           ; return (ev, hole_co, fmv) }++extendFlatCache :: TyCon -> [Type] -> (TcCoercion, TcType, CtFlavour) -> TcS ()+extendFlatCache tc xi_args stuff@(_, ty, fl)+  | isGivenOrWDeriv fl  -- Maintain the invariant that inert_flat_cache+                        -- only has [G] and [WD] CFunEqCans+  = do { dflags <- getDynFlags+       ; when (gopt Opt_FlatCache dflags) $+    do { traceTcS "extendFlatCache" (vcat [ ppr tc <+> ppr xi_args+                                          , ppr fl, ppr ty ])+            -- 'co' can be bottom, in the case of derived items+       ; updInertTcS $ \ is@(IS { inert_flat_cache = fc }) ->+            is { inert_flat_cache = insertExactFunEq fc tc xi_args stuff } } }++  | otherwise+  = return ()++-- Instantiations+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++instDFunType :: DFunId -> [DFunInstType] -> TcS ([TcType], TcThetaType)+instDFunType dfun_id inst_tys+  = wrapTcS $ TcM.instDFunType dfun_id inst_tys++newFlexiTcSTy :: Kind -> TcS TcType+newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd)++cloneMetaTyVar :: TcTyVar -> TcS TcTyVar+cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv)++demoteUnfilledFmv :: TcTyVar -> TcS ()+-- If a flatten-meta-var is still un-filled,+-- turn it into an ordinary meta-var+demoteUnfilledFmv fmv+  = wrapTcS $ do { is_filled <- TcM.isFilledMetaTyVar fmv+                 ; unless is_filled $+                   do { tv_ty <- TcM.newFlexiTyVarTy (tyVarKind fmv)+                      ; TcM.writeMetaTyVar fmv tv_ty } }++instFlexi :: [TKVar] -> TcS TCvSubst+instFlexi = instFlexiX emptyTCvSubst++instFlexiX :: TCvSubst -> [TKVar] -> TcS TCvSubst+instFlexiX subst tvs+  = wrapTcS (foldlM instFlexiHelper subst tvs)++instFlexiHelper :: TCvSubst -> TKVar -> TcM TCvSubst+instFlexiHelper subst tv+  = do { uniq <- TcM.newUnique+       ; details <- TcM.newMetaDetails TauTv+       ; let name = setNameUnique (tyVarName tv) uniq+             kind = substTyUnchecked subst (tyVarKind tv)+             ty'  = mkTyVarTy (mkTcTyVar name kind details)+       ; return (extendTvSubst subst tv ty') }++tcInstType :: ([TyVar] -> TcM (TCvSubst, [TcTyVar]))+                   -- ^ How to instantiate the type variables+           -> Id   -- ^ Type to instantiate+           -> TcS ([(Name, TcTyVar)], TcThetaType, TcType) -- ^ Result+                -- (type vars, preds (incl equalities), rho)+tcInstType inst_tyvars id = wrapTcS (TcM.tcInstType inst_tyvars id)++tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcS (TCvSubst, [TcTyVar])+tcInstSkolTyVarsX subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX subst tvs++-- Creating and setting evidence variables and CtFlavors+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++data MaybeNew = Fresh CtEvidence | Cached EvTerm++isFresh :: MaybeNew -> Bool+isFresh (Fresh {})  = True+isFresh (Cached {}) = False++freshGoals :: [MaybeNew] -> [CtEvidence]+freshGoals mns = [ ctev | Fresh ctev <- mns ]++getEvTerm :: MaybeNew -> EvTerm+getEvTerm (Fresh ctev) = ctEvTerm ctev+getEvTerm (Cached evt) = evt++setEvBind :: EvBind -> TcS ()+setEvBind ev_bind+  = do { evb <- getTcEvBindsVar+       ; wrapTcS $ TcM.addTcEvBind evb ev_bind }++-- | Mark variables as used filling a coercion hole+useVars :: CoVarSet -> TcS ()+useVars vars+  = do { EvBindsVar { ebv_tcvs = ref } <- getTcEvBindsVar+       ; wrapTcS $+         do { tcvs <- TcM.readTcRef ref+            ; let tcvs' = tcvs `unionVarSet` vars+            ; TcM.writeTcRef ref tcvs' } }++-- | Equalities only+setWantedEq :: TcEvDest -> Coercion -> TcS ()+setWantedEq (HoleDest hole) co+  = do { useVars (coVarsOfCo co)+       ; wrapTcS $ TcM.fillCoercionHole hole co }+setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq" (ppr ev)++-- | Equalities only+setEqIfWanted :: CtEvidence -> Coercion -> TcS ()+setEqIfWanted (CtWanted { ctev_dest = dest }) co = setWantedEq dest co+setEqIfWanted _ _ = return ()++-- | Good for equalities and non-equalities+setWantedEvTerm :: TcEvDest -> EvTerm -> TcS ()+setWantedEvTerm (HoleDest hole) tm+  = do { let co = evTermCoercion tm+       ; useVars (coVarsOfCo co)+       ; wrapTcS $ TcM.fillCoercionHole hole co }+setWantedEvTerm (EvVarDest ev) tm = setWantedEvBind ev tm++setWantedEvBind :: EvVar -> EvTerm -> TcS ()+setWantedEvBind ev_id tm = setEvBind (mkWantedEvBind ev_id tm)++setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS ()+setEvBindIfWanted ev tm+  = case ev of+      CtWanted { ctev_dest = dest }+        -> setWantedEvTerm dest tm+      _ -> return ()++newTcEvBinds :: TcS EvBindsVar+newTcEvBinds = wrapTcS TcM.newTcEvBinds++newEvVar :: TcPredType -> TcS EvVar+newEvVar pred = wrapTcS (TcM.newEvVar pred)++newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence+-- Make a new variable of the given PredType,+-- immediately bind it to the given term+-- and return its CtEvidence+-- See Note [Bind new Givens immediately] in TcRnTypes+newGivenEvVar loc (pred, rhs)+  = do { new_ev <- newBoundEvVarId pred rhs+       ; return (CtGiven { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc }) }++-- | Make a new 'Id' of the given type, bound (in the monad's EvBinds) to the+-- given term+newBoundEvVarId :: TcPredType -> EvTerm -> TcS EvVar+newBoundEvVarId pred rhs+  = do { new_ev <- newEvVar pred+       ; setEvBind (mkGivenEvBind new_ev rhs)+       ; return new_ev }++newGivenEvVars :: CtLoc -> [(TcPredType, EvTerm)] -> TcS [CtEvidence]+newGivenEvVars loc pts = mapM (newGivenEvVar loc) pts++emitNewWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS Coercion+-- | Emit a new Wanted equality into the work-list+emitNewWantedEq loc role ty1 ty2+  | otherwise+  = do { (ev, co) <- newWantedEq loc role ty1 ty2+       ; updWorkListTcS $+         extendWorkListEq (mkNonCanonical ev)+       ; return co }++-- | Make a new equality CtEvidence+newWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS (CtEvidence, Coercion)+newWantedEq loc role ty1 ty2+  = do { hole <- wrapTcS $ TcM.newCoercionHole+       ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty)+       ; return ( CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole+                           , ctev_nosh = WDeriv+                           , ctev_loc = loc}+                , mkHoleCo hole role ty1 ty2 ) }+  where+    pty = mkPrimEqPredRole role ty1 ty2++-- no equalities here. Use newWantedEq instead+newWantedEvVarNC :: CtLoc -> TcPredType -> TcS CtEvidence+-- Don't look up in the solved/inerts; we know it's not there+newWantedEvVarNC loc pty+  = do { new_ev <- newEvVar pty+       ; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$+                                         pprCtLoc loc)+       ; return (CtWanted { ctev_pred = pty, ctev_dest = EvVarDest new_ev+                          , ctev_nosh = WDeriv+                          , ctev_loc = loc })}++newWantedEvVar :: CtLoc -> TcPredType -> TcS MaybeNew+-- For anything except ClassPred, this is the same as newWantedEvVarNC+newWantedEvVar loc pty+  = do { mb_ct <- lookupInInerts pty+       ; case mb_ct of+            Just ctev+              | not (isDerived ctev)+              -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev+                    ; return $ Cached (ctEvTerm ctev) }+            _ -> do { ctev <- newWantedEvVarNC loc pty+                    ; return (Fresh ctev) } }++-- deals with both equalities and non equalities. Tries to look+-- up non-equalities in the cache+newWanted :: CtLoc -> PredType -> TcS MaybeNew+newWanted loc pty+  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty+  = Fresh . fst <$> newWantedEq loc role ty1 ty2+  | otherwise+  = newWantedEvVar loc pty++-- deals with both equalities and non equalities. Doesn't do any cache lookups.+newWantedNC :: CtLoc -> PredType -> TcS CtEvidence+newWantedNC loc pty+  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty+  = fst <$> newWantedEq loc role ty1 ty2+  | otherwise+  = newWantedEvVarNC loc pty++emitNewDerived :: CtLoc -> TcPredType -> TcS ()+emitNewDerived loc pred+  = do { ev <- newDerivedNC loc pred+       ; traceTcS "Emitting new derived" (ppr ev)+       ; updWorkListTcS (extendWorkListDerived loc ev) }++emitNewDeriveds :: CtLoc -> [TcPredType] -> TcS ()+emitNewDeriveds loc preds+  | null preds+  = return ()+  | otherwise+  = do { evs <- mapM (newDerivedNC loc) preds+       ; traceTcS "Emitting new deriveds" (ppr evs)+       ; updWorkListTcS (extendWorkListDeriveds loc evs) }++emitNewDerivedEq :: CtLoc -> Role -> TcType -> TcType -> TcS ()+-- Create new equality Derived and put it in the work list+-- There's no caching, no lookupInInerts+emitNewDerivedEq loc role ty1 ty2+  = do { ev <- newDerivedNC loc (mkPrimEqPredRole role ty1 ty2)+       ; traceTcS "Emitting new derived equality" (ppr ev $$ pprCtLoc loc)+       ; updWorkListTcS (extendWorkListDerived loc ev) }++newDerivedNC :: CtLoc -> TcPredType -> TcS CtEvidence+newDerivedNC loc pred+  = do { -- checkReductionDepth loc pred+       ; return (CtDerived { ctev_pred = pred, ctev_loc = loc }) }++-- --------- Check done in TcInteract.selectNewWorkItem???? ---------+-- | Checks if the depth of the given location is too much. Fails if+-- it's too big, with an appropriate error message.+checkReductionDepth :: CtLoc -> TcType   -- ^ type being reduced+                    -> TcS ()+checkReductionDepth loc ty+  = do { dflags <- getDynFlags+       ; when (subGoalDepthExceeded dflags (ctLocDepth loc)) $+         wrapErrTcS $+         solverDepthErrorTcS loc ty }++matchFam :: TyCon -> [Type] -> TcS (Maybe (Coercion, TcType))+matchFam tycon args = wrapTcS $ matchFamTcM tycon args++matchFamTcM :: TyCon -> [Type] -> TcM (Maybe (Coercion, TcType))+-- Given (F tys) return (ty, co), where co :: F tys ~ ty+matchFamTcM tycon args+  = do { fam_envs <- FamInst.tcGetFamInstEnvs+       ; let match_fam_result+              = reduceTyFamApp_maybe fam_envs Nominal tycon args+       ; TcM.traceTc "matchFamTcM" $+         vcat [ text "Matching:" <+> ppr (mkTyConApp tycon args)+              , ppr_res match_fam_result ]+       ; return match_fam_result }+  where+    ppr_res Nothing        = text "Match failed"+    ppr_res (Just (co,ty)) = hang (text "Match succeeded:")+                                2 (vcat [ text "Rewrites to:" <+> ppr ty+                                        , text "Coercion:" <+> ppr co ])++{-+Note [Residual implications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The wl_implics in the WorkList are the residual implication+constraints that are generated while solving or canonicalising the+current worklist.  Specifically, when canonicalising+   (forall a. t1 ~ forall a. t2)+from which we get the implication+   (forall a. t1 ~ t2)+See TcSMonad.deferTcSForAllEq+-}+
+ typecheck/TcSigs.hs view
@@ -0,0 +1,773 @@+{-+(c) The University of Glasgow 2006-2012+(c) The GRASP Project, Glasgow University, 1992-2002++-}++{-# LANGUAGE CPP #-}++module TcSigs(+       TcSigInfo(..),+       TcIdSigInfo(..), TcIdSigInst,+       TcPatSynInfo(..),+       TcSigFun,++       isPartialSig, hasCompleteSig, tcIdSigName, tcSigInfoName,+       completeSigPolyId_maybe,++       tcTySigs, tcUserTypeSig, completeSigFromId,+       tcInstSig,++       TcPragEnv, emptyPragEnv, lookupPragEnv, extendPragEnv,+       mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags, addInlinePrags+   ) where++#include "HsVersions.h"++import HsSyn+import TcHsType+import TcRnTypes+import TcRnMonad+import TcType+import TcMType+import TcValidity ( checkValidType )+import TcUnify( tcSkolemise, unifyType, noThing )+import Inst( topInstantiate )+import TcEnv( tcLookupId )+import TcEvidence( HsWrapper, (<.>) )+import Type( mkTyVarBinders )++import DynFlags+import Var      ( TyVar, tyVarName, tyVarKind )+import Id       ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId )+import PrelNames( mkUnboundName )+import BasicTypes+import Bag( foldrBag )+import Module( getModule )+import Name+import NameEnv+import VarSet+import Outputable+import SrcLoc+import Util( singleton )+import Maybes( orElse )+import Data.Maybe( mapMaybe )+import Control.Monad( unless )+++{- -------------------------------------------------------------+          Note [Overview of type signatures]+----------------------------------------------------------------+Type signatures, including partial signatures, are jolly tricky,+especially on value bindings.  Here's an overview.++    f :: forall a. [a] -> [a]+    g :: forall b. _ -> b++    f = ...g...+    g = ...f...++* HsSyn: a signature in a binding starts of as a TypeSig, in+  type HsBinds.Sig++* When starting a mutually recursive group, like f/g above, we+  call tcTySig on each signature in the group.++* tcTySig: Sig -> TcIdSigInfo+  - For a /complete/ signature, like 'f' above, tcTySig kind-checks+    the HsType, producing a Type, and wraps it in a CompleteSig, and+    extend the type environment with this polymorphic 'f'.++  - For a /partial/signature, like 'g' above, tcTySig does nothing+    Instead it just wraps the pieces in a PartialSig, to be handled+    later.++* tcInstSig: TcIdSigInfo -> TcIdSigInst+  In tcMonoBinds, when looking at an individual binding, we use+  tcInstSig to instantiate the signature forall's in the signature,+  and attribute that instantiated (monomorphic) type to the+  binder.  You can see this in TcBinds.tcLhsId.++  The instantiation does the obvious thing for complete signatures,+  but for /partial/ signatures it starts from the HsSyn, so it+  has to kind-check it etc: tcHsPartialSigType.  It's convenient+  to do this at the same time as instantiation, because we can+  make the wildcards into unification variables right away, raather+  than somehow quantifying over them.  And the "TcLevel" of those+  unification variables is correct because we are in tcMonoBinds.+++Note [Scoped tyvars]+~~~~~~~~~~~~~~~~~~~~+The -XScopedTypeVariables flag brings lexically-scoped type variables+into scope for any explicitly forall-quantified type variables:+        f :: forall a. a -> a+        f x = e+Then 'a' is in scope inside 'e'.++However, we do *not* support this+  - For pattern bindings e.g+        f :: forall a. a->a+        (f,g) = e++Note [Binding scoped type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The type variables *brought into lexical scope* by a type signature+may be a subset of the *quantified type variables* of the signatures,+for two reasons:++* With kind polymorphism a signature like+    f :: forall f a. f a -> f a+  may actually give rise to+    f :: forall k. forall (f::k -> *) (a:k). f a -> f a+  So the sig_tvs will be [k,f,a], but only f,a are scoped.+  NB: the scoped ones are not necessarily the *inital* ones!++* Even aside from kind polymorphism, there may be more instantiated+  type variables than lexically-scoped ones.  For example:+        type T a = forall b. b -> (a,b)+        f :: forall c. T c+  Here, the signature for f will have one scoped type variable, c,+  but two instantiated type variables, c' and b'.++However, all of this only applies to the renamer.  The typechecker+just puts all of them into the type environment; any lexical-scope+errors were dealt with by the renamer.++-}+++{- *********************************************************************+*                                                                      *+             Utility functions for TcSigInfo+*                                                                      *+********************************************************************* -}++tcIdSigName :: TcIdSigInfo -> Name+tcIdSigName (CompleteSig { sig_bndr = id }) = idName id+tcIdSigName (PartialSig { psig_name = n })  = n++tcSigInfoName :: TcSigInfo -> Name+tcSigInfoName (TcIdSig     idsi) = tcIdSigName idsi+tcSigInfoName (TcPatSynSig tpsi) = patsig_name tpsi++completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId+completeSigPolyId_maybe sig+  | TcIdSig sig_info <- sig+  , CompleteSig { sig_bndr = id } <- sig_info = Just id+  | otherwise                                 = Nothing+++{- *********************************************************************+*                                                                      *+               Typechecking user signatures+*                                                                      *+********************************************************************* -}++tcTySigs :: [LSig Name] -> TcM ([TcId], TcSigFun)+tcTySigs hs_sigs+  = checkNoErrs $   -- See Note [Fail eagerly on bad signatures]+    do { ty_sigs_s <- mapAndRecoverM tcTySig hs_sigs+       ; let ty_sigs  = concat ty_sigs_s+             poly_ids = mapMaybe completeSigPolyId_maybe ty_sigs+                        -- The returned [TcId] are the ones for which we have+                        -- a complete type signature.+                        -- See Note [Complete and partial type signatures]+             env = mkNameEnv [(tcSigInfoName sig, sig) | sig <- ty_sigs]+       ; return (poly_ids, lookupNameEnv env) }++tcTySig :: LSig Name -> TcM [TcSigInfo]+tcTySig (L _ (IdSig id))+  = do { let ctxt = FunSigCtxt (idName id) False+                    -- False: do not report redundant constraints+                    -- The user has no control over the signature!+             sig = completeSigFromId ctxt id+       ; return [TcIdSig sig] }++tcTySig (L loc (TypeSig names sig_ty))+  = setSrcSpan loc $+    do { sigs <- sequence [ tcUserTypeSig loc sig_ty (Just name)+                          | L _ name <- names ]+       ; return (map TcIdSig sigs) }++tcTySig (L loc (PatSynSig names sig_ty))+  = setSrcSpan loc $+    do { tpsigs <- sequence [ tcPatSynSig name sig_ty+                            | L _ name <- names ]+       ; return (map TcPatSynSig tpsigs) }++tcTySig _ = return []+++tcUserTypeSig :: SrcSpan -> LHsSigWcType Name -> Maybe Name -> TcM TcIdSigInfo+-- A function or expression type signature+-- Returns a fully quantified type signature; even the wildcards+-- are quantified with ordinary skolems that should be instantiated+--+-- The SrcSpan is what to declare as the binding site of the+-- any skolems in the signature. For function signatures we+-- use the whole `f :: ty' signature; for expression signatures+-- just the type part.+--+-- Just n  => Function type signature       name :: type+-- Nothing => Expression type signature   <expr> :: type+tcUserTypeSig loc hs_sig_ty mb_name+  | isCompleteHsSig hs_sig_ty+  = do { sigma_ty <- tcHsSigWcType ctxt_F hs_sig_ty+       ; return $+         CompleteSig { sig_bndr  = mkLocalId name sigma_ty+                     , sig_ctxt  = ctxt_T+                     , sig_loc   = loc } }+                       -- Location of the <type> in   f :: <type>++  -- Partial sig with wildcards+  | otherwise+  = return (PartialSig { psig_name = name, psig_hs_ty = hs_sig_ty+                       , sig_ctxt = ctxt_F, sig_loc = loc })+  where+    name   = case mb_name of+               Just n  -> n+               Nothing -> mkUnboundName (mkVarOcc "<expression>")+    ctxt_F = case mb_name of+               Just n  -> FunSigCtxt n False+               Nothing -> ExprSigCtxt+    ctxt_T = case mb_name of+               Just n  -> FunSigCtxt n True+               Nothing -> ExprSigCtxt++++completeSigFromId :: UserTypeCtxt -> Id -> TcIdSigInfo+-- Used for instance methods and record selectors+completeSigFromId ctxt id+  = CompleteSig { sig_bndr = id+                , sig_ctxt = ctxt+                , sig_loc  = getSrcSpan id }++isCompleteHsSig :: LHsSigWcType Name -> Bool+-- ^ If there are no wildcards, return a LHsSigType+isCompleteHsSig (HsWC { hswc_wcs = wcs }) = null wcs++{- Note [Fail eagerly on bad signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If a type signature is wrong, fail immediately:++ * the type sigs may bind type variables, so proceeding without them+   can lead to a cascade of errors++ * the type signature might be ambiguous, in which case checking+   the code against the signature will give a very similar error+   to the ambiguity error.++ToDo: this means we fall over if any type sig+is wrong (eg at the top level of the module),+which is over-conservative+-}++{- *********************************************************************+*                                                                      *+        Type checking a pattern synonym signature+*                                                                      *+************************************************************************++Note [Pattern synonym signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Pattern synonym signatures are surprisingly tricky (see Trac #11224 for example).+In general they look like this:++   pattern P :: forall univ_tvs. req_theta+             => forall ex_tvs. prov_theta+             => arg1 -> .. -> argn -> res_ty++For parsing and renaming we treat the signature as an ordinary LHsSigType.++Once we get to type checking, we decompose it into its parts, in tcPatSynSig.++* Note that 'forall univ_tvs' and 'req_theta =>'+        and 'forall ex_tvs'   and 'prov_theta =>'+  are all optional.  We gather the pieces at the the top of tcPatSynSig++* Initially the implicitly-bound tyvars (added by the renamer) include both+  universal and existential vars.++* After we kind-check the pieces and convert to Types, we do kind generalisation.++Note [The pattern-synonym signature splitting rule]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given a pattern signature, we must split+     the kind-generalised variables, and+     the implicitly-bound variables+into universal and existential.  The rule is this+(see discussion on Trac #11224):++     The universal tyvars are the ones mentioned in+          - univ_tvs: the user-specified (forall'd) universals+          - req_theta+          - res_ty+     The existential tyvars are all the rest++For example++   pattern P :: () => b -> T a+   pattern P x = ...++Here 'a' is universal, and 'b' is existential.  But there is a wrinkle:+how do we split the arg_tys from req_ty?  Consider++   pattern Q :: () => b -> S c -> T a+   pattern Q x = ...++This is an odd example because Q has only one syntactic argument, and+so presumably is defined by a view pattern matching a function.  But+it can happen (Trac #11977, #12108).++We don't know Q's arity from the pattern signature, so we have to wait+until we see the pattern declaration itself before deciding res_ty is,+and hence which variables are existential and which are universal.++And that in turn is why TcPatSynInfo has a separate field,+patsig_implicit_bndrs, to capture the implicitly bound type variables,+because we don't yet know how to split them up.++It's a slight compromise, because it means we don't really know the+pattern synonym's real signature until we see its declaration.  So,+for example, in hs-boot file, we may need to think what to do...+(eg don't have any implicitly-bound variables).+-}++tcPatSynSig :: Name -> LHsSigType Name -> TcM TcPatSynInfo+tcPatSynSig name sig_ty+  | HsIB { hsib_vars = implicit_hs_tvs+         , hsib_body = hs_ty }  <- sig_ty+  , (univ_hs_tvs, hs_req,  hs_ty1)     <- splitLHsSigmaTy hs_ty+  , (ex_hs_tvs,   hs_prov, hs_body_ty) <- splitLHsSigmaTy hs_ty1+  = do { (implicit_tvs, (univ_tvs, req, ex_tvs, prov, body_ty))+           <- solveEqualities $+              tcImplicitTKBndrs implicit_hs_tvs $+              tcExplicitTKBndrs univ_hs_tvs  $ \ univ_tvs ->+              tcExplicitTKBndrs ex_hs_tvs    $ \ ex_tvs   ->+              do { req     <- tcHsContext hs_req+                 ; prov    <- tcHsContext hs_prov+                 ; body_ty <- tcHsOpenType hs_body_ty+                     -- A (literal) pattern can be unlifted;+                     -- e.g. pattern Zero <- 0#   (Trac #12094)+                 ; let bound_tvs+                         = unionVarSets [ allBoundVariabless req+                                        , allBoundVariabless prov+                                        , allBoundVariables body_ty+                                        ]+                 ; return ( (univ_tvs, req, ex_tvs, prov, body_ty)+                          , bound_tvs) }++       -- Kind generalisation+       ; kvs <- kindGeneralize $+                build_patsyn_type [] implicit_tvs univ_tvs req+                                  ex_tvs prov body_ty++       -- These are /signatures/ so we zonk to squeeze out any kind+       -- unification variables.  Do this after quantifyTyVars which may+       -- default kind variables to *.+       ; traceTc "about zonk" empty+       ; implicit_tvs <- mapM zonkTcTyCoVarBndr implicit_tvs+       ; univ_tvs     <- mapM zonkTcTyCoVarBndr univ_tvs+       ; ex_tvs       <- mapM zonkTcTyCoVarBndr ex_tvs+       ; req          <- zonkTcTypes req+       ; prov         <- zonkTcTypes prov+       ; body_ty      <- zonkTcType  body_ty++       -- Now do validity checking+       ; checkValidType ctxt $+         build_patsyn_type kvs implicit_tvs univ_tvs req ex_tvs prov body_ty++       -- arguments become the types of binders. We thus cannot allow+       -- levity polymorphism here+       ; let (arg_tys, _) = tcSplitFunTys body_ty+       ; mapM_ (checkForLevPoly empty) arg_tys++       ; traceTc "tcTySig }" $+         vcat [ text "implicit_tvs" <+> ppr_tvs implicit_tvs+              , text "kvs" <+> ppr_tvs kvs+              , text "univ_tvs" <+> ppr_tvs univ_tvs+              , text "req" <+> ppr req+              , text "ex_tvs" <+> ppr_tvs ex_tvs+              , text "prov" <+> ppr prov+              , text "body_ty" <+> ppr body_ty ]+       ; return (TPSI { patsig_name = name+                      , patsig_implicit_bndrs = mkTyVarBinders Inferred kvs +++                                                mkTyVarBinders Specified implicit_tvs+                      , patsig_univ_bndrs     = univ_tvs+                      , patsig_req            = req+                      , patsig_ex_bndrs       = ex_tvs+                      , patsig_prov           = prov+                      , patsig_body_ty        = body_ty }) }+  where+    ctxt = PatSynCtxt name++    build_patsyn_type kvs imp univ req ex prov body+      = mkInvForAllTys kvs $+        mkSpecForAllTys (imp ++ univ) $+        mkFunTys req $+        mkSpecForAllTys ex $+        mkFunTys prov $+        body++ppr_tvs :: [TyVar] -> SDoc+ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv)+                           | tv <- tvs])+++{- *********************************************************************+*                                                                      *+               Instantiating user signatures+*                                                                      *+********************************************************************* -}+++tcInstSig :: TcIdSigInfo -> TcM TcIdSigInst+-- Instantiate a type signature; only used with plan InferGen+tcInstSig sig@(CompleteSig { sig_bndr = poly_id, sig_loc = loc })+  = setSrcSpan loc $  -- Set the binding site of the tyvars+    do { (tv_prs, theta, tau) <- tcInstType newMetaSigTyVars poly_id+              -- See Note [Pattern bindings and complete signatures]++       ; return (TISI { sig_inst_sig   = sig+                      , sig_inst_skols = tv_prs+                      , sig_inst_wcs   = []+                      , sig_inst_wcx   = Nothing+                      , sig_inst_theta = theta+                      , sig_inst_tau   = tau }) }++tcInstSig sig@(PartialSig { psig_hs_ty = hs_ty+                          , sig_ctxt = ctxt+                          , sig_loc = loc })+  = setSrcSpan loc $  -- Set the binding site of the tyvars+    do { (wcs, wcx, tvs, theta, tau) <- tcHsPartialSigType ctxt hs_ty+       ; return (TISI { sig_inst_sig   = sig+                      , sig_inst_skols = map (\tv -> (tyVarName tv, tv)) tvs+                      , sig_inst_wcs   = wcs+                      , sig_inst_wcx   = wcx+                      , sig_inst_theta = theta+                      , sig_inst_tau   = tau }) }+++{- Note [Pattern bindings and complete signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+      data T a = MkT a a+      f :: forall a. a->a+      g :: forall b. b->b+      MkT f g = MkT (\x->x) (\y->y)+Here we'll infer a type from the pattern of 'T a', but if we feed in+the signature types for f and g, we'll end up unifying 'a' and 'b'++So we instantiate f and g's signature with SigTv skolems+(newMetaSigTyVars) that can unify with each other.  If too much+unification takes place, we'll find out when we do the final+impedance-matching check in TcBinds.mkExport++See Note [Signature skolems] in TcType++None of this applies to a function binding with a complete+signature, which doesn't use tcInstSig.  See TcBinds.tcPolyCheck.+-}++{- *********************************************************************+*                                                                      *+                   Pragmas and PragEnv+*                                                                      *+********************************************************************* -}++type TcPragEnv = NameEnv [LSig Name]++emptyPragEnv :: TcPragEnv+emptyPragEnv = emptyNameEnv++lookupPragEnv :: TcPragEnv -> Name -> [LSig Name]+lookupPragEnv prag_fn n = lookupNameEnv prag_fn n `orElse` []++extendPragEnv :: TcPragEnv -> (Name, LSig Name) -> TcPragEnv+extendPragEnv prag_fn (n, sig) = extendNameEnv_Acc (:) singleton prag_fn n sig++---------------+mkPragEnv :: [LSig Name] -> LHsBinds Name -> TcPragEnv+mkPragEnv sigs binds+  = foldl extendPragEnv emptyNameEnv prs+  where+    prs = mapMaybe get_sig sigs++    get_sig :: LSig Name -> Maybe (Name, LSig Name)+    get_sig (L l (SpecSig lnm@(L _ nm) ty inl)) = Just (nm, L l $ SpecSig   lnm ty (add_arity nm inl))+    get_sig (L l (InlineSig lnm@(L _ nm) inl))  = Just (nm, L l $ InlineSig lnm    (add_arity nm inl))+    get_sig (L l (SCCFunSig st lnm@(L _ nm) str))  = Just (nm, L l $ SCCFunSig st lnm str)+    get_sig _                                   = Nothing++    add_arity n inl_prag   -- Adjust inl_sat field to match visible arity of function+      | Inline <- inl_inline inl_prag+        -- add arity only for real INLINE pragmas, not INLINABLE+      = case lookupNameEnv ar_env n of+          Just ar -> inl_prag { inl_sat = Just ar }+          Nothing -> WARN( True, text "mkPragEnv no arity" <+> ppr n )+                     -- There really should be a binding for every INLINE pragma+                     inl_prag+      | otherwise+      = inl_prag++    -- ar_env maps a local to the arity of its definition+    ar_env :: NameEnv Arity+    ar_env = foldrBag lhsBindArity emptyNameEnv binds++lhsBindArity :: LHsBind Name -> NameEnv Arity -> NameEnv Arity+lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env+  = extendNameEnv env (unLoc id) (matchGroupArity ms)+lhsBindArity _ env = env        -- PatBind/VarBind+++-----------------+addInlinePrags :: TcId -> [LSig Name] -> TcM TcId+addInlinePrags poly_id prags_for_me+  | inl@(L _ prag) : inls <- inl_prags+  = do { traceTc "addInlinePrag" (ppr poly_id $$ ppr prag)+       ; unless (null inls) (warn_multiple_inlines inl inls)+       ; return (poly_id `setInlinePragma` prag) }+  | otherwise+  = return poly_id+  where+    inl_prags = [L loc prag | L loc (InlineSig _ prag) <- prags_for_me]++    warn_multiple_inlines _ [] = return ()++    warn_multiple_inlines inl1@(L loc prag1) (inl2@(L _ prag2) : inls)+       | inlinePragmaActivation prag1 == inlinePragmaActivation prag2+       , isEmptyInlineSpec (inlinePragmaSpec prag1)+       =    -- Tiresome: inl1 is put there by virtue of being in a hs-boot loop+            -- and inl2 is a user NOINLINE pragma; we don't want to complain+         warn_multiple_inlines inl2 inls+       | otherwise+       = setSrcSpan loc $+         addWarnTc NoReason+                     (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id)+                       2 (vcat (text "Ignoring all but the first"+                                : map pp_inl (inl1:inl2:inls))))++    pp_inl (L loc prag) = ppr prag <+> parens (ppr loc)+++{- *********************************************************************+*                                                                      *+                   SPECIALISE pragmas+*                                                                      *+************************************************************************++Note [Handling SPECIALISE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The basic idea is this:++   foo :: Num a => a -> b -> a+   {-# SPECIALISE foo :: Int -> b -> Int #-}++We check that+   (forall a b. Num a => a -> b -> a)+      is more polymorphic than+   forall b. Int -> b -> Int+(for which we could use tcSubType, but see below), generating a HsWrapper+to connect the two, something like+      wrap = /\b. <hole> Int b dNumInt+This wrapper is put in the TcSpecPrag, in the ABExport record of+the AbsBinds.+++        f :: (Eq a, Ix b) => a -> b -> Bool+        {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}+        f = <poly_rhs>++From this the typechecker generates++    AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds++    SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX+                      -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])++From these we generate:++    Rule:       forall p, q, (dp:Ix p), (dq:Ix q).+                    f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq++    Spec bind:  f_spec = wrap_fn <poly_rhs>++Note that++  * The LHS of the rule may mention dictionary *expressions* (eg+    $dfIxPair dp dq), and that is essential because the dp, dq are+    needed on the RHS.++  * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it+    can fully specialise it.++++From the TcSpecPrag, in DsBinds we generate a binding for f_spec and a RULE:++   f_spec :: Int -> b -> Int+   f_spec = wrap<f rhs>++   RULE: forall b (d:Num b). f b d = f_spec b++The RULE is generated by taking apart the HsWrapper, which is a little+delicate, but works.++Some wrinkles++1. We don't use full-on tcSubType, because that does co and contra+   variance and that in turn will generate too complex a LHS for the+   RULE.  So we use a single invocation of skolemise /+   topInstantiate in tcSpecWrapper.  (Actually I think that even+   the "deeply" stuff may be too much, because it introduces lambdas,+   though I think it can be made to work without too much trouble.)++2. We need to take care with type families (Trac #5821).  Consider+      type instance F Int = Bool+      f :: Num a => a -> F a+      {-# SPECIALISE foo :: Int -> Bool #-}++  We *could* try to generate an f_spec with precisely the declared type:+      f_spec :: Int -> Bool+      f_spec = <f rhs> Int dNumInt |> co++      RULE: forall d. f Int d = f_spec |> sym co++  but the 'co' and 'sym co' are (a) playing no useful role, and (b) are+  hard to generate.  At all costs we must avoid this:+      RULE: forall d. f Int d |> co = f_spec+  because the LHS will never match (indeed it's rejected in+  decomposeRuleLhs).++  So we simply do this:+    - Generate a constraint to check that the specialised type (after+      skolemiseation) is equal to the instantiated function type.+    - But *discard* the evidence (coercion) for that constraint,+      so that we ultimately generate the simpler code+          f_spec :: Int -> F Int+          f_spec = <f rhs> Int dNumInt++          RULE: forall d. f Int d = f_spec+      You can see this discarding happening in++3. Note that the HsWrapper can transform *any* function with the right+   type prefix+       forall ab. (Eq a, Ix b) => XXX+   regardless of XXX.  It's sort of polymorphic in XXX.  This is+   useful: we use the same wrapper to transform each of the class ops, as+   well as the dict.  That's what goes on in TcInstDcls.mk_meth_spec_prags+-}++tcSpecPrags :: Id -> [LSig Name]+            -> TcM [LTcSpecPrag]+-- Add INLINE and SPECIALSE pragmas+--    INLINE prags are added to the (polymorphic) Id directly+--    SPECIALISE prags are passed to the desugarer via TcSpecPrags+-- Pre-condition: the poly_id is zonked+-- Reason: required by tcSubExp+tcSpecPrags poly_id prag_sigs+  = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs)+       ; unless (null bad_sigs) warn_discarded_sigs+       ; pss <- mapAndRecoverM (wrapLocM (tcSpecPrag poly_id)) spec_sigs+       ; return $ concatMap (\(L l ps) -> map (L l) ps) pss }+  where+    spec_sigs = filter isSpecLSig prag_sigs+    bad_sigs  = filter is_bad_sig prag_sigs+    is_bad_sig s = not (isSpecLSig s || isInlineLSig s || isSCCFunSig s)++    warn_discarded_sigs+      = addWarnTc NoReason+                  (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id)+                      2 (vcat (map (ppr . getLoc) bad_sigs)))++--------------+tcSpecPrag :: TcId -> Sig Name -> TcM [TcSpecPrag]+tcSpecPrag poly_id prag@(SpecSig fun_name hs_tys inl)+-- See Note [Handling SPECIALISE pragmas]+--+-- The Name fun_name in the SpecSig may not be the same as that of the poly_id+-- Example: SPECIALISE for a class method: the Name in the SpecSig is+--          for the selector Id, but the poly_id is something like $cop+-- However we want to use fun_name in the error message, since that is+-- what the user wrote (Trac #8537)+  = addErrCtxt (spec_ctxt prag) $+    do  { warnIf NoReason (not (isOverloadedTy poly_ty || isInlinePragma inl))+                 (text "SPECIALISE pragma for non-overloaded function"+                  <+> quotes (ppr fun_name))+                  -- Note [SPECIALISE pragmas]+        ; spec_prags <- mapM tc_one hs_tys+        ; traceTc "tcSpecPrag" (ppr poly_id $$ nest 2 (vcat (map ppr spec_prags)))+        ; return spec_prags }+  where+    name      = idName poly_id+    poly_ty   = idType poly_id+    spec_ctxt prag = hang (text "In the SPECIALISE pragma") 2 (ppr prag)++    tc_one hs_ty+      = do { spec_ty <- tcHsSigType   (FunSigCtxt name False) hs_ty+           ; wrap    <- tcSpecWrapper (FunSigCtxt name True)  poly_ty spec_ty+           ; return (SpecPrag poly_id wrap inl) }++tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag)++--------------+tcSpecWrapper :: UserTypeCtxt -> TcType -> TcType -> TcM HsWrapper+-- A simpler variant of tcSubType, used for SPECIALISE pragmas+-- See Note [Handling SPECIALISE pragmas], wrinkle 1+tcSpecWrapper ctxt poly_ty spec_ty+  = do { (sk_wrap, inst_wrap)+               <- tcSkolemise ctxt spec_ty $ \ _ spec_tau ->+                  do { (inst_wrap, tau) <- topInstantiate orig poly_ty+                     ; _ <- unifyType noThing spec_tau tau+                            -- Deliberately ignore the evidence+                            -- See Note [Handling SPECIALISE pragmas],+                            --   wrinkle (2)+                     ; return inst_wrap }+       ; return (sk_wrap <.> inst_wrap) }+  where+    orig = SpecPragOrigin ctxt++--------------+tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag]+-- SPECIALISE pragmas for imported things+tcImpPrags prags+  = do { this_mod <- getModule+       ; dflags <- getDynFlags+       ; if (not_specialising dflags) then+            return []+         else do+            { pss <- mapAndRecoverM (wrapLocM tcImpSpec)+                     [L loc (name,prag)+                               | (L loc prag@(SpecSig (L _ name) _ _)) <- prags+                               , not (nameIsLocalOrFrom this_mod name) ]+            ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } }+  where+    -- Ignore SPECIALISE pragmas for imported things+    -- when we aren't specialising, or when we aren't generating+    -- code.  The latter happens when Haddocking the base library;+    -- we don't wnat complaints about lack of INLINABLE pragmas+    not_specialising dflags+      | not (gopt Opt_Specialise dflags) = True+      | otherwise = case hscTarget dflags of+                      HscNothing -> True+                      HscInterpreted -> True+                      _other         -> False++tcImpSpec :: (Name, Sig Name) -> TcM [TcSpecPrag]+tcImpSpec (name, prag)+ = do { id <- tcLookupId name+      ; unless (isAnyInlinePragma (idInlinePragma id))+               (addWarnTc NoReason (impSpecErr name))+      ; tcSpecPrag id prag }++impSpecErr :: Name -> SDoc+impSpecErr name+  = hang (text "You cannot SPECIALISE" <+> quotes (ppr name))+       2 (vcat [ text "because its definition has no INLINE/INLINABLE pragma"+               , parens $ sep+                   [ text "or its defining module" <+> quotes (ppr mod)+                   , text "was compiled without -O"]])+  where+    mod = nameModule name
+ typecheck/TcSimplify.hs view
@@ -0,0 +1,2229 @@+{-# LANGUAGE CPP #-}++module TcSimplify(+       simplifyInfer, InferMode(..),+       growThetaTyVars,+       simplifyAmbiguityCheck,+       simplifyDefault,+       simplifyTop, simplifyTopImplic, captureTopConstraints,+       simplifyInteractive, solveEqualities,+       simplifyWantedsTcM,+       tcCheckSatisfiability,++       -- For Rules we need these+       solveWanteds, solveWantedsAndDrop,+       approximateWC, runTcSDeriveds+  ) where++#include "HsVersions.h"++import Bag+import Class         ( Class, classKey, classTyCon )+import DynFlags      ( WarningFlag ( Opt_WarnMonomorphism )+                     , WarnReason ( Reason )+                     , DynFlags( solverIterations ) )+import Inst+import ListSetOps+import Maybes+import Name+import Outputable+import PrelInfo+import PrelNames+import TcErrors+import TcEvidence+import TcInteract+import TcCanonical   ( makeSuperClasses )+import TcMType   as TcM+import TcRnMonad as TcM+import TcSMonad  as TcS+import TcType+import TrieMap       () -- DV: for now+import Type+import TysWiredIn    ( liftedRepTy )+import Unify         ( tcMatchTyKi )+import Util+import Var+import VarSet+import UniqSet+import BasicTypes    ( IntWithInf, intGtLimit )+import ErrUtils      ( emptyMessages )+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Data.List     ( partition )++{-+*********************************************************************************+*                                                                               *+*                           External interface                                  *+*                                                                               *+*********************************************************************************+-}++captureTopConstraints :: TcM a -> TcM (a, WantedConstraints)+-- (captureTopConstraints m) runs m, and returns the type constraints it+-- generates plus the constraints produced by static forms inside.+-- If it fails with an exception, it reports any insolubles+-- (out of scope variables) before doing so+captureTopConstraints thing_inside+  = do { static_wc_var <- TcM.newTcRef emptyWC ;+       ; (mb_res, lie) <- TcM.updGblEnv (\env -> env { tcg_static_wc = static_wc_var } ) $+                          TcM.tryCaptureConstraints thing_inside+       ; stWC <- TcM.readTcRef static_wc_var++       -- See TcRnMonad Note [Constraints and errors]+       -- If the thing_inside threw an exception, but generated some insoluble+       -- constraints, report the latter before propagating the exception+       -- Otherwise they will be lost altogether+       ; case mb_res of+           Right res -> return (res, lie `andWC` stWC)+           Left {}   -> do { _ <- reportUnsolved lie; failM } }+                -- This call to reportUnsolved is the reason+                -- this function is here instead of TcRnMonad++simplifyTopImplic :: Bag Implication -> TcM ()+simplifyTopImplic implics+  = do { empty_binds <- simplifyTop (mkImplicWC implics)++       -- Since all the inputs are implications the returned bindings will be empty+       ; MASSERT2( isEmptyBag empty_binds, ppr empty_binds )++       ; return () }++simplifyTop :: WantedConstraints -> TcM (Bag EvBind)+-- Simplify top-level constraints+-- Usually these will be implications,+-- but when there is nothing to quantify we don't wrap+-- in a degenerate implication, so we do that here instead+simplifyTop wanteds+  = do { traceTc "simplifyTop {" $ text "wanted = " <+> ppr wanteds+       ; ((final_wc, unsafe_ol), binds1) <- runTcS $+            do { final_wc <- simpl_top wanteds+               ; unsafe_ol <- getSafeOverlapFailures+               ; return (final_wc, unsafe_ol) }+       ; traceTc "End simplifyTop }" empty++       ; traceTc "reportUnsolved {" empty+       ; binds2 <- reportUnsolved final_wc+       ; traceTc "reportUnsolved }" empty++       ; traceTc "reportUnsolved (unsafe overlapping) {" empty+       ; unless (isEmptyCts unsafe_ol) $ do {+           -- grab current error messages and clear, warnAllUnsolved will+           -- update error messages which we'll grab and then restore saved+           -- messages.+           ; errs_var  <- getErrsVar+           ; saved_msg <- TcM.readTcRef errs_var+           ; TcM.writeTcRef errs_var emptyMessages++           ; warnAllUnsolved $ WC { wc_simple = unsafe_ol+                                  , wc_insol = emptyCts+                                  , wc_impl = emptyBag }++           ; whyUnsafe <- fst <$> TcM.readTcRef errs_var+           ; TcM.writeTcRef errs_var saved_msg+           ; recordUnsafeInfer whyUnsafe+           }+       ; traceTc "reportUnsolved (unsafe overlapping) }" empty++       ; return (evBindMapBinds binds1 `unionBags` binds2) }++-- | Type-check a thing that emits only equality constraints, then+-- solve those constraints. Fails outright if there is trouble.+solveEqualities :: TcM a -> TcM a+solveEqualities thing_inside+  = checkNoErrs $  -- See Note [Fail fast on kind errors]+    do { (result, wanted) <- captureConstraints thing_inside+       ; traceTc "solveEqualities {" $ text "wanted = " <+> ppr wanted+       ; final_wc <- runTcSEqualities $ simpl_top wanted+       ; traceTc "End solveEqualities }" empty++       ; traceTc "reportAllUnsolved {" empty+       ; reportAllUnsolved final_wc+       ; traceTc "reportAllUnsolved }" empty+       ; return result }++simpl_top :: WantedConstraints -> TcS WantedConstraints+    -- See Note [Top-level Defaulting Plan]+simpl_top wanteds+  = do { wc_first_go <- nestTcS (solveWantedsAndDrop wanteds)+                            -- This is where the main work happens+       ; try_tyvar_defaulting wc_first_go }+  where+    try_tyvar_defaulting :: WantedConstraints -> TcS WantedConstraints+    try_tyvar_defaulting wc+      | isEmptyWC wc+      = return wc+      | otherwise+      = do { free_tvs <- TcS.zonkTyCoVarsAndFVList (tyCoVarsOfWCList wc)+           ; let meta_tvs = filter (isTyVar <&&> isMetaTyVar) free_tvs+                   -- zonkTyCoVarsAndFV: the wc_first_go is not yet zonked+                   -- filter isMetaTyVar: we might have runtime-skolems in GHCi,+                   -- and we definitely don't want to try to assign to those!+                   -- The isTyVar is needed to weed out coercion variables++           ; defaulted <- mapM defaultTyVarTcS meta_tvs   -- Has unification side effects+           ; if or defaulted+             then do { wc_residual <- nestTcS (solveWanteds wc)+                            -- See Note [Must simplify after defaulting]+                     ; try_class_defaulting wc_residual }+             else try_class_defaulting wc }     -- No defaulting took place++    try_class_defaulting :: WantedConstraints -> TcS WantedConstraints+    try_class_defaulting wc+      | isEmptyWC wc+      = return wc+      | otherwise  -- See Note [When to do type-class defaulting]+      = do { something_happened <- applyDefaultingRules wc+                                   -- See Note [Top-level Defaulting Plan]+           ; if something_happened+             then do { wc_residual <- nestTcS (solveWantedsAndDrop wc)+                     ; try_class_defaulting wc_residual }+                  -- See Note [Overview of implicit CallStacks] in TcEvidence+             else try_callstack_defaulting wc }++    try_callstack_defaulting :: WantedConstraints -> TcS WantedConstraints+    try_callstack_defaulting wc+      | isEmptyWC wc+      = return wc+      | otherwise+      = defaultCallStacks wc++-- | Default any remaining @CallStack@ constraints to empty @CallStack@s.+defaultCallStacks :: WantedConstraints -> TcS WantedConstraints+-- See Note [Overview of implicit CallStacks] in TcEvidence+defaultCallStacks wanteds+  = do simples <- handle_simples (wc_simple wanteds)+       mb_implics <- mapBagM handle_implic (wc_impl wanteds)+       return (wanteds { wc_simple = simples+                       , wc_impl = catBagMaybes mb_implics })++  where++  handle_simples simples+    = catBagMaybes <$> mapBagM defaultCallStack simples++  handle_implic :: Implication -> TcS (Maybe Implication)+  -- The Maybe is because solving the CallStack constraint+  -- may well allow us to discard the implication entirely+  handle_implic implic+    | isSolvedStatus (ic_status implic)+    = return (Just implic)+    | otherwise+    = do { wanteds <- setEvBindsTcS (ic_binds implic) $+                      -- defaultCallStack sets a binding, so+                      -- we must set the correct binding group+                      defaultCallStacks (ic_wanted implic)+         ; setImplicationStatus (implic { ic_wanted = wanteds }) }++  defaultCallStack ct+    | Just _ <- isCallStackPred (ctPred ct)+    = do { solveCallStack (cc_ev ct) EvCsEmpty+         ; return Nothing }++  defaultCallStack ct+    = return (Just ct)+++{- Note [Fail fast on kind errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+solveEqualities is used to solve kind equalities when kind-checking+user-written types. If solving fails we should fail outright, rather+than just accumulate an error message, for two reasons:++  * A kind-bogus type signature may cause a cascade of knock-on+    errors if we let it pass++  * More seriously, we don't have a convenient term-level place to add+    deferred bindings for unsolved kind-equality constraints, so we+    don't build evidence bindings (by usine reportAllUnsolved). That+    means that we'll be left with with a type that has coercion holes+    in it, something like+           <type> |> co-hole+    where co-hole is not filled in.  Eeek!  That un-filled-in+    hole actually causes GHC to crash with "fvProv falls into a hole"+    See Trac #11563, #11520, #11516, #11399++So it's important to use 'checkNoErrs' here!++Note [When to do type-class defaulting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In GHC 7.6 and 7.8.2, we did type-class defaulting only if insolubleWC+was false, on the grounds that defaulting can't help solve insoluble+constraints.  But if we *don't* do defaulting we may report a whole+lot of errors that would be solved by defaulting; these errors are+quite spurious because fixing the single insoluble error means that+defaulting happens again, which makes all the other errors go away.+This is jolly confusing: Trac #9033.++So it seems better to always do type-class defaulting.++However, always doing defaulting does mean that we'll do it in+situations like this (Trac #5934):+   run :: (forall s. GenST s) -> Int+   run = fromInteger 0+We don't unify the return type of fromInteger with the given function+type, because the latter involves foralls.  So we're left with+    (Num alpha, alpha ~ (forall s. GenST s) -> Int)+Now we do defaulting, get alpha := Integer, and report that we can't+match Integer with (forall s. GenST s) -> Int.  That's not totally+stupid, but perhaps a little strange.++Another potential alternative would be to suppress *all* non-insoluble+errors if there are *any* insoluble errors, anywhere, but that seems+too drastic.++Note [Must simplify after defaulting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We may have a deeply buried constraint+    (t:*) ~ (a:Open)+which we couldn't solve because of the kind incompatibility, and 'a' is free.+Then when we default 'a' we can solve the constraint.  And we want to do+that before starting in on type classes.  We MUST do it before reporting+errors, because it isn't an error!  Trac #7967 was due to this.++Note [Top-level Defaulting Plan]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have considered two design choices for where/when to apply defaulting.+   (i) Do it in SimplCheck mode only /whenever/ you try to solve some+       simple constraints, maybe deep inside the context of implications.+       This used to be the case in GHC 7.4.1.+   (ii) Do it in a tight loop at simplifyTop, once all other constraints have+        finished. This is the current story.++Option (i) had many disadvantages:+   a) Firstly, it was deep inside the actual solver.+   b) Secondly, it was dependent on the context (Infer a type signature,+      or Check a type signature, or Interactive) since we did not want+      to always start defaulting when inferring (though there is an exception to+      this, see Note [Default while Inferring]).+   c) It plainly did not work. Consider typecheck/should_compile/DfltProb2.hs:+          f :: Int -> Bool+          f x = const True (\y -> let w :: a -> a+                                      w a = const a (y+1)+                                  in w y)+      We will get an implication constraint (for beta the type of y):+               [untch=beta] forall a. 0 => Num beta+      which we really cannot default /while solving/ the implication, since beta is+      untouchable.++Instead our new defaulting story is to pull defaulting out of the solver loop and+go with option (ii), implemented at SimplifyTop. Namely:+     - First, have a go at solving the residual constraint of the whole+       program+     - Try to approximate it with a simple constraint+     - Figure out derived defaulting equations for that simple constraint+     - Go round the loop again if you did manage to get some equations++Now, that has to do with class defaulting. However there exists type variable /kind/+defaulting. Again this is done at the top-level and the plan is:+     - At the top-level, once you had a go at solving the constraint, do+       figure out /all/ the touchable unification variables of the wanted constraints.+     - Apply defaulting to their kinds++More details in Note [DefaultTyVar].++Note [Safe Haskell Overlapping Instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In Safe Haskell, we apply an extra restriction to overlapping instances. The+motive is to prevent untrusted code provided by a third-party, changing the+behavior of trusted code through type-classes. This is due to the global and+implicit nature of type-classes that can hide the source of the dictionary.++Another way to state this is: if a module M compiles without importing another+module N, changing M to import N shouldn't change the behavior of M.++Overlapping instances with type-classes can violate this principle. However,+overlapping instances aren't always unsafe. They are just unsafe when the most+selected dictionary comes from untrusted code (code compiled with -XSafe) and+overlaps instances provided by other modules.++In particular, in Safe Haskell at a call site with overlapping instances, we+apply the following rule to determine if it is a 'unsafe' overlap:++ 1) Most specific instance, I1, defined in an `-XSafe` compiled module.+ 2) I1 is an orphan instance or a MPTC.+ 3) At least one overlapped instance, Ix, is both:+    A) from a different module than I1+    B) Ix is not marked `OVERLAPPABLE`++This is a slightly involved heuristic, but captures the situation of an+imported module N changing the behavior of existing code. For example, if+condition (2) isn't violated, then the module author M must depend either on a+type-class or type defined in N.++Secondly, when should these heuristics be enforced? We enforced them when the+type-class method call site is in a module marked `-XSafe` or `-XTrustworthy`.+This allows `-XUnsafe` modules to operate without restriction, and for Safe+Haskell inferrence to infer modules with unsafe overlaps as unsafe.++One alternative design would be to also consider if an instance was imported as+a `safe` import or not and only apply the restriction to instances imported+safely. However, since instances are global and can be imported through more+than one path, this alternative doesn't work.++Note [Safe Haskell Overlapping Instances Implementation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++How is this implemented? It's complicated! So we'll step through it all:++ 1) `InstEnv.lookupInstEnv` -- Performs instance resolution, so this is where+    we check if a particular type-class method call is safe or unsafe. We do this+    through the return type, `ClsInstLookupResult`, where the last parameter is a+    list of instances that are unsafe to overlap. When the method call is safe,+    the list is null.++ 2) `TcInteract.matchClassInst` -- This module drives the instance resolution+    / dictionary generation. The return type is `LookupInstResult`, which either+    says no instance matched, or one found, and if it was a safe or unsafe+    overlap.++ 3) `TcInteract.doTopReactDict` -- Takes a dictionary / class constraint and+     tries to resolve it by calling (in part) `matchClassInst`. The resolving+     mechanism has a work list (of constraints) that it process one at a time. If+     the constraint can't be resolved, it's added to an inert set. When compiling+     an `-XSafe` or `-XTrustworthy` module, we follow this approach as we know+     compilation should fail. These are handled as normal constraint resolution+     failures from here-on (see step 6).++     Otherwise, we may be inferring safety (or using `-Wunsafe`), and+     compilation should succeed, but print warnings and/or mark the compiled module+     as `-XUnsafe`. In this case, we call `insertSafeOverlapFailureTcS` which adds+     the unsafe (but resolved!) constraint to the `inert_safehask` field of+     `InertCans`.++ 4) `TcSimplify.simplifyTop`:+       * Call simpl_top, the top-level function for driving the simplifier for+         constraint resolution.++       * Once finished, call `getSafeOverlapFailures` to retrieve the+         list of overlapping instances that were successfully resolved,+         but unsafe. Remember, this is only applicable for generating warnings+         (`-Wunsafe`) or inferring a module unsafe. `-XSafe` and `-XTrustworthy`+         cause compilation failure by not resolving the unsafe constraint at all.++       * For unresolved constraints (all types), call `TcErrors.reportUnsolved`,+         while for resolved but unsafe overlapping dictionary constraints, call+         `TcErrors.warnAllUnsolved`. Both functions convert constraints into a+         warning message for the user.++       * In the case of `warnAllUnsolved` for resolved, but unsafe+         dictionary constraints, we collect the generated warning+         message (pop it) and call `TcRnMonad.recordUnsafeInfer` to+         mark the module we are compiling as unsafe, passing the+         warning message along as the reason.++ 5) `TcErrors.*Unsolved` -- Generates error messages for constraints by+    actually calling `InstEnv.lookupInstEnv` again! Yes, confusing, but all we+    know is the constraint that is unresolved or unsafe. For dictionary, all we+    know is that we need a dictionary of type C, but not what instances are+    available and how they overlap. So we once again call `lookupInstEnv` to+    figure that out so we can generate a helpful error message.++ 6) `TcRnMonad.recordUnsafeInfer` -- Save the unsafe result and reason in an+      IORef called `tcg_safeInfer`.++ 7) `HscMain.tcRnModule'` -- Reads `tcg_safeInfer` after type-checking, calling+    `HscMain.markUnsafeInfer` (passing the reason along) when safe-inferrence+    failed.++Note [No defaulting in the ambiguity check]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When simplifying constraints for the ambiguity check, we use+solveWantedsAndDrop, not simpl_top, so that we do no defaulting.+Trac #11947 was an example:+   f :: Num a => Int -> Int+This is ambiguous of course, but we don't want to default the+(Num alpha) constraint to (Num Int)!  Doing so gives a defaulting+warning, but no error.+-}++------------------+simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM ()+simplifyAmbiguityCheck ty wanteds+  = do { traceTc "simplifyAmbiguityCheck {" (text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wanteds)+       ; (final_wc, _) <- runTcS $ solveWantedsAndDrop wanteds+             -- NB: no defaulting!  See Note [No defaulting in the ambiguity check]++       ; traceTc "End simplifyAmbiguityCheck }" empty++       -- Normally report all errors; but with -XAllowAmbiguousTypes+       -- report only insoluble ones, since they represent genuinely+       -- inaccessible code+       ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes+       ; traceTc "reportUnsolved(ambig) {" empty+       ; unless (allow_ambiguous && not (insolubleWC final_wc))+                (discardResult (reportUnsolved final_wc))+       ; traceTc "reportUnsolved(ambig) }" empty++       ; return () }++------------------+simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind)+simplifyInteractive wanteds+  = traceTc "simplifyInteractive" empty >>+    simplifyTop wanteds++------------------+simplifyDefault :: ThetaType    -- Wanted; has no type variables in it+                -> TcM ()       -- Succeeds if the constraint is soluble+simplifyDefault theta+  = do { traceTc "simplifyDefault" empty+       ; wanteds  <- newWanteds DefaultOrigin theta+       ; unsolved <- runTcSDeriveds (solveWantedsAndDrop (mkSimpleWC wanteds))+       ; traceTc "reportUnsolved {" empty+       ; reportAllUnsolved unsolved+       ; traceTc "reportUnsolved }" empty+       ; return () }++------------------+tcCheckSatisfiability :: Bag EvVar -> TcM Bool+-- Return True if satisfiable, False if definitely contradictory+tcCheckSatisfiability given_ids+  = do { lcl_env <- TcM.getLclEnv+       ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env+       ; (res, _ev_binds) <- runTcS $+             do { traceTcS "checkSatisfiability {" (ppr given_ids)+                ; let given_cts = mkGivens given_loc (bagToList given_ids)+                     -- See Note [Superclasses and satisfiability]+                ; solveSimpleGivens given_cts+                ; insols <- getInertInsols+                ; insols <- try_harder insols+                ; traceTcS "checkSatisfiability }" (ppr insols)+                ; return (isEmptyBag insols) }+       ; return res }+ where+    try_harder :: Cts -> TcS Cts+    -- Maybe we have to search up the superclass chain to find+    -- an unsatisfiable constraint.  Example: pmcheck/T3927b.+    -- At the moment we try just once+    try_harder insols+      | not (isEmptyBag insols)   -- We've found that it's definitely unsatisfiable+      = return insols             -- Hurrah -- stop now.+      | otherwise+      = do { pending_given <- getPendingScDicts+           ; new_given <- makeSuperClasses pending_given+           ; solveSimpleGivens new_given+           ; getInertInsols }++{- Note [Superclasses and satisfiability]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Expand superclasses before starting, because (Int ~ Bool), has+(Int ~~ Bool) as a superclass, which in turn has (Int ~N# Bool)+as a superclass, and it's the latter that is insoluble.  See+Note [The equality types story] in TysPrim.++If we fail to prove unsatisfiability we (arbitrarily) try just once to+find superclasses, using try_harder.  Reason: we might have a type+signature+   f :: F op (Implements push) => ..+where F is a type function.  This happened in Trac #3972.++We could do more than once but we'd have to have /some/ limit: in the+the recursive case, we would go on forever in the common case where+the constraints /are/ satisfiable (Trac #10592 comment:12!).++For stratightforard situations without type functions the try_harder+step does nothing.+++***********************************************************************************+*                                                                                 *+*                            Inference+*                                                                                 *+***********************************************************************************++Note [Inferring the type of a let-bound variable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f x = rhs++To infer f's type we do the following:+ * Gather the constraints for the RHS with ambient level *one more than*+   the current one.  This is done by the call+        pushLevelAndCaptureConstraints (tcMonoBinds...)+   in TcBinds.tcPolyInfer++ * Call simplifyInfer to simplify the constraints and decide what to+   quantify over. We pass in the level used for the RHS constraints,+   here called rhs_tclvl.++This ensures that the implication constraint we generate, if any,+has a strictly-increased level compared to the ambient level outside+the let binding.++-}++-- | How should we choose which constraints to quantify over?+data InferMode = ApplyMR          -- ^ Apply the monomorphism restriction,+                                  -- never quantifying over any constraints+               | EagerDefaulting  -- ^ See Note [TcRnExprMode] in TcRnDriver,+                                  -- the :type +d case; this mode refuses+                                  -- to quantify over any defaultable constraint+               | NoRestrictions   -- ^ Quantify over any constraint that+                                  -- satisfies TcType.pickQuantifiablePreds++instance Outputable InferMode where+  ppr ApplyMR         = text "ApplyMR"+  ppr EagerDefaulting = text "EagerDefaulting"+  ppr NoRestrictions  = text "NoRestrictions"++simplifyInfer :: TcLevel               -- Used when generating the constraints+              -> InferMode+              -> [TcIdSigInst]         -- Any signatures (possibly partial)+              -> [(Name, TcTauType)]   -- Variables to be generalised,+                                       -- and their tau-types+              -> WantedConstraints+              -> TcM ([TcTyVar],    -- Quantify over these type variables+                      [EvVar],      -- ... and these constraints (fully zonked)+                      TcEvBinds)    -- ... binding these evidence variables+simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds+  | isEmptyWC wanteds+  = do { gbl_tvs <- tcGetGlobalTyCoVars+       ; dep_vars <- zonkTcTypesAndSplitDepVars (map snd name_taus)+       ; qtkvs <- quantifyZonkedTyVars gbl_tvs dep_vars+       ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs)+       ; return (qtkvs, [], emptyTcEvBinds) }++  | otherwise+  = do { traceTc "simplifyInfer {"  $ vcat+             [ text "sigs =" <+> ppr sigs+             , text "binds =" <+> ppr name_taus+             , text "rhs_tclvl =" <+> ppr rhs_tclvl+             , text "infer_mode =" <+> ppr infer_mode+             , text "(unzonked) wanted =" <+> ppr wanteds+             ]++       ; let partial_sigs = filter isPartialSig sigs+             psig_theta   = concatMap sig_inst_theta partial_sigs++       -- First do full-blown solving+       -- NB: we must gather up all the bindings from doing+       -- this solving; hence (runTcSWithEvBinds ev_binds_var).+       -- And note that since there are nested implications,+       -- calling solveWanteds will side-effect their evidence+       -- bindings, so we can't just revert to the input+       -- constraint.++       ; tc_lcl_env      <- TcM.getLclEnv+       ; ev_binds_var    <- TcM.newTcEvBinds+       ; psig_theta_vars <- mapM TcM.newEvVar psig_theta+       ; wanted_transformed_incl_derivs+            <- setTcLevel rhs_tclvl $+               runTcSWithEvBinds ev_binds_var $+               do { let loc = mkGivenLoc rhs_tclvl UnkSkol tc_lcl_env+                        psig_givens = mkGivens loc psig_theta_vars+                  ; _ <- solveSimpleGivens psig_givens+                         -- See Note [Add signature contexts as givens]+                  ; solveWanteds wanteds }+       ; wanted_transformed_incl_derivs <- TcM.zonkWC wanted_transformed_incl_derivs++       -- Find quant_pred_candidates, the predicates that+       -- we'll consider quantifying over+       -- NB1: wanted_transformed does not include anything provable from+       --      the psig_theta; it's just the extra bit+       -- NB2: We do not do any defaulting when inferring a type, this can lead+       --      to less polymorphic types, see Note [Default while Inferring]++       ; let wanted_transformed = dropDerivedWC wanted_transformed_incl_derivs+             quant_pred_candidates   -- Fully zonked+                 | insolubleWC wanted_transformed_incl_derivs+                 = []   -- See Note [Quantification with errors]+                        -- NB: must include derived errors in this test,+                        --     hence "incl_derivs"++                 | otherwise+                 = ctsPreds (approximateWC False wanted_transformed)++       -- NB: quant_pred_candidates is already fully zonked++       -- Decide what type variables and constraints to quantify+       -- NB: bound_theta are constraints we want to quantify over,+       --     /apart from/ the psig_theta, which we always quantify over+       ; (qtvs, bound_theta) <- decideQuantification infer_mode rhs_tclvl+                                                     name_taus partial_sigs+                                                     quant_pred_candidates++        -- Emit an implication constraint for the+        -- remaining constraints from the RHS.+        -- We must retain the psig_theta_vars, because we've used them in+        -- evidence bindings constructed by solveWanteds earlier+       ; psig_theta_vars  <- mapM zonkId psig_theta_vars+       ; bound_theta_vars <- mapM TcM.newEvVar bound_theta+       ; let full_theta      = psig_theta      ++ bound_theta+             full_theta_vars = psig_theta_vars ++ bound_theta_vars+             skol_info   = InferSkol [ (name, mkSigmaTy [] full_theta ty)+                                     | (name, ty) <- name_taus ]+                        -- Don't add the quantified variables here, because+                        -- they are also bound in ic_skols and we want them+                        -- to be tidied uniformly++             implic = Implic { ic_tclvl    = rhs_tclvl+                             , ic_skols    = qtvs+                             , ic_no_eqs   = False+                             , ic_given    = full_theta_vars+                             , ic_wanted   = wanted_transformed+                             , ic_status   = IC_Unsolved+                             , ic_binds    = ev_binds_var+                             , ic_info     = skol_info+                             , ic_needed   = emptyVarSet+                             , ic_env      = tc_lcl_env }+       ; emitImplication implic++         -- All done!+       ; traceTc "} simplifyInfer/produced residual implication for quantification" $+         vcat [ text "quant_pred_candidates =" <+> ppr quant_pred_candidates+              , text "psig_theta =" <+> ppr psig_theta+              , text "bound_theta =" <+> ppr bound_theta+              , text "full_theta =" <+> ppr full_theta+              , text "qtvs ="       <+> ppr qtvs+              , text "implic ="     <+> ppr implic ]++       ; return ( qtvs, full_theta_vars, TcEvBinds ev_binds_var ) }+         -- NB: full_theta_vars must be fully zonked+++ctsPreds :: Cts -> [PredType]+ctsPreds cts = [ ctEvPred ev | ct <- bagToList cts+                             , let ev = ctEvidence ct ]++{- Note [Add signature contexts as givens]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (Trac #11016):+  f2 :: (?x :: Int) => _+  f2 = ?x+or this+  f3 :: a ~ Bool => (a, _)+  f3 = (True, False)+or theis+  f4 :: (Ord a, _) => a -> Bool+  f4 x = x==x++We'll use plan InferGen because there are holes in the type.  But:+ * For f2 we want to have the (?x :: Int) constraint floating around+   so that the functional dependencies kick in.  Otherwise the+   occurrence of ?x on the RHS produces constraint (?x :: alpha), and+   we won't unify alpha:=Int.+ * For f3 we want the (a ~ Bool) available to solve the wanted (a ~ Bool)+   in the RHS+ * For f4 we want to use the (Ord a) in the signature to solve the Eq a+   constraint.++Solution: in simplifyInfer, just before simplifying the constraints+gathered from the RHS, add Given constraints for the context of any+type signatures.++************************************************************************+*                                                                      *+                Quantification+*                                                                      *+************************************************************************++Note [Deciding quantification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the monomorphism restriction does not apply, then we quantify as follows:++* Step 1. Take the global tyvars, and "grow" them using the equality+  constraints+     E.g.  if x:alpha is in the environment, and alpha ~ [beta] (which can+          happen because alpha is untouchable here) then do not quantify over+          beta, because alpha fixes beta, and beta is effectively free in+          the environment too++  We also account for the monomorphism restriction; if it applies,+  add the free vars of all the constraints.++  Result is mono_tvs; we will not quantify over these.++* Step 2. Default any non-mono tyvars (i.e ones that are definitely+  not going to become further constrained), and re-simplify the+  candidate constraints.++  Motivation for re-simplification (Trac #7857): imagine we have a+  constraint (C (a->b)), where 'a :: TYPE l1' and 'b :: TYPE l2' are+  not free in the envt, and instance forall (a::*) (b::*). (C a) => C+  (a -> b) The instance doesnt' match while l1,l2 are polymorphic, but+  it will match when we default them to LiftedRep.++  This is all very tiresome.++* Step 3: decide which variables to quantify over, as follows:++  - Take the free vars of the tau-type (zonked_tau_tvs) and "grow"+    them using all the constraints.  These are tau_tvs_plus++  - Use quantifyTyVars to quantify over (tau_tvs_plus - mono_tvs), being+    careful to close over kinds, and to skolemise the quantified tyvars.+    (This actually unifies each quantifies meta-tyvar with a fresh skolem.)++  Result is qtvs.++* Step 4: Filter the constraints using pickQuantifiablePreds and the+  qtvs. We have to zonk the constraints first, so they "see" the+  freshly created skolems.++-}++decideQuantification+  :: InferMode+  -> TcLevel+  -> [(Name, TcTauType)]   -- Variables to be generalised+  -> [TcIdSigInst]         -- Partial type signatures (if any)+  -> [PredType]            -- Candidate theta; already zonked+  -> TcM ( [TcTyVar]       -- Quantify over these (skolems)+         , [PredType] )    -- and this context (fully zonked)+-- See Note [Deciding quantification]+decideQuantification infer_mode rhs_tclvl name_taus psigs candidates+  = do { -- Step 1: find the mono_tvs+       ; (mono_tvs, candidates) <- decideMonoTyVars infer_mode+                                        name_taus psigs candidates++       -- Step 2: default any non-mono tyvars, and re-simplify+       -- This step may do some unification, but result candidates is zonked+       ; candidates <- defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates++       -- Step 3: decide which kind/type variables to quantify over+       ; qtvs <- decideQuantifiedTyVars mono_tvs name_taus psigs candidates++       -- Step 4: choose which of the remaining candidate+       --         predicates to actually quantify over+       -- NB: decideQuantifiedTyVars turned some meta tyvars+       -- into quantified skolems, so we have to zonk again+       ; candidates <- TcM.zonkTcTypes candidates+       ; let theta = pickQuantifiablePreds (mkVarSet qtvs) $+                     mkMinimalBySCs $  -- See Note [Minimize by Superclasses]+                     candidates++       ; traceTc "decideQuantification"+           (vcat [ text "infer_mode:"   <+> ppr infer_mode+                 , text "candidates:"   <+> ppr candidates+                 , text "mono_tvs:"     <+> ppr mono_tvs+                 , text "qtvs:"         <+> ppr qtvs+                 , text "theta:"        <+> ppr theta ])+       ; return (qtvs, theta) }++------------------+decideMonoTyVars :: InferMode+                 -> [(Name,TcType)]+                 -> [TcIdSigInst]+                 -> [PredType]+                 -> TcM (TcTyCoVarSet, [PredType])+-- Decide which tyvars cannot be generalised:+--   (a) Free in the environment+--   (b) Mentioned in a constraint we can't generalise+--   (c) Connected by an equality to (a) or (b)+-- Also return the reduced set of constraint we can generalise+decideMonoTyVars infer_mode name_taus psigs candidates+  = do { (no_quant, yes_quant) <- pick infer_mode candidates++       ; gbl_tvs <- tcGetGlobalTyCoVars+       ; let eq_constraints  = filter isEqPred candidates+             constrained_tvs = tyCoVarsOfTypes no_quant+             mono_tvs1       = growThetaTyVars eq_constraints $+                               gbl_tvs `unionVarSet` constrained_tvs++       -- Always quantify over partial-sig qtvs, so they are not mono+       -- Need to zonk them because they are meta-tyvar SigTvs+       -- Note [Quantification and partial signatures], wrinkle 3+       ; psig_qtvs <- mapM zonkTcTyVarToTyVar $+                      concatMap (map snd . sig_inst_skols) psigs+       ; let mono_tvs = mono_tvs1 `delVarSetList` psig_qtvs++           -- Warn about the monomorphism restriction+       ; warn_mono <- woptM Opt_WarnMonomorphism+       ; when (case infer_mode of { ApplyMR -> warn_mono; _ -> False}) $+         do { taus <- mapM (TcM.zonkTcType . snd) name_taus+            ; warnTc (Reason Opt_WarnMonomorphism)+                     (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus)+                     mr_msg }++       ; traceTc "decideMonoTyVars" $ vcat+           [ text "gbl_tvs =" <+> ppr gbl_tvs+           , text "no_quant =" <+> ppr no_quant+           , text "yes_quant =" <+> ppr yes_quant+           , text "eq_constraints =" <+> ppr eq_constraints+           , text "mono_tvs =" <+> ppr mono_tvs ]++       ; return (mono_tvs, yes_quant) }+  where+    pick :: InferMode -> [PredType] -> TcM ([PredType], [PredType])+    -- Split the candidates into ones we definitely+    -- won't quantify, and ones that we might+    pick NoRestrictions  cand = return ([], cand)+    pick ApplyMR         cand = return (cand, [])+    pick EagerDefaulting cand = do { os <- xoptM LangExt.OverloadedStrings+                                   ; return (partition (is_int_ct os) cand) }++    -- For EagerDefaulting, do not quantify over+    -- over any interactive class constraint+    is_int_ct ovl_strings pred+      | Just (cls, _) <- getClassPredTys_maybe pred+      = isInteractiveClass ovl_strings cls+      | otherwise+      = False++    pp_bndrs = pprWithCommas (quotes . ppr . fst) name_taus+    mr_msg = hang (text "The Monomorphism Restriction applies to the binding"+                   <> plural name_taus <+> text "for" <+> pp_bndrs)+                2 (text "Consider giving a type signature for"+                   <+> if isSingleton name_taus then pp_bndrs+                                                else text "these binders")++-------------------+defaultTyVarsAndSimplify :: TcLevel+                         -> TyCoVarSet+                         -> [PredType]          -- Assumed zonked+                         -> TcM [PredType]      -- Guaranteed zonked+-- Default any tyvar free in the constraints,+-- and re-simplify in case the defaulting allows futher simplification+defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates+  = do {  -- Promote any tyvars that we cannot generalise+          -- See Note [Promote momomorphic tyvars]+       ; outer_tclvl <- TcM.getTcLevel+       ; let prom_tvs = nonDetEltsUniqSet mono_tvs+                        -- It's OK to use nonDetEltsUniqSet here+                        -- because promoteTyVar is commutative+       ; traceTc "decideMonoTyVars: promotion:" (ppr prom_tvs)+       ; proms <- mapM (promoteTyVar outer_tclvl) prom_tvs++       -- Default any kind/levity vars+       ; let DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs}+                = candidateQTyVarsOfTypes candidates+       ; poly_kinds  <- xoptM LangExt.PolyKinds+       ; default_kvs <- mapM (default_one poly_kinds True)+                             (dVarSetElems cand_kvs)+       ; default_tvs <- mapM (default_one poly_kinds False)+                             (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs))+       ; let some_default = or default_kvs || or default_tvs++       ; case () of+           _ | some_default -> simplify_cand candidates+             | or proms     -> mapM TcM.zonkTcType candidates+             | otherwise    -> return candidates+       }+  where+    default_one poly_kinds is_kind_var tv+      | not (isMetaTyVar tv)+      = return False+      | tv `elemVarSet` mono_tvs+      = return False+      | otherwise+      = defaultTyVar (not poly_kinds && is_kind_var) tv++    simplify_cand candidates+      = do { clone_wanteds <- newWanteds DefaultOrigin candidates+           ; WC { wc_simple = simples } <- setTcLevel rhs_tclvl $+                                           simplifyWantedsTcM clone_wanteds+              -- Discard evidence; simples is fully zonked++           ; let new_candidates = ctsPreds simples+           ; traceTc "Simplified after defaulting" $+                      vcat [ text "Before:" <+> ppr candidates+                           , text "After:"  <+> ppr new_candidates ]+           ; return new_candidates }++------------------+decideQuantifiedTyVars+   :: TyCoVarSet        -- Monomorphic tyvars+   -> [(Name,TcType)]   -- Annotated theta and (name,tau) pairs+   -> [TcIdSigInst]     -- Parital signatures+   -> [PredType]        -- Candidates, zonked+   -> TcM [TyVar]+-- Fix what tyvars we are going to quantify over, and quantify them+decideQuantifiedTyVars mono_tvs name_taus psigs candidates+  = do {     -- Why psig_tys? We try to quantify over everything free in here+             -- See Note [Quantification and partial signatures]+             --     wrinkles 2 and 3+       ; psig_tv_tys <- mapM TcM.zonkTcTyVar [ tv | sig <- psigs+                                                  , (_,tv) <- sig_inst_skols sig ]+       ; psig_theta <- mapM TcM.zonkTcType [ pred | sig <- psigs+                                                  , pred <- sig_inst_theta sig ]+       ; tau_tys <- mapM (TcM.zonkTcType . snd) name_taus++       ; let -- Try to quantify over variables free in these types+             psig_tys = psig_tv_tys ++ psig_theta+             seed_tys = psig_tys ++ tau_tys++             -- Now "grow" those seeds to find ones reachable via 'candidates'+             grown_tvs = growThetaTyVars candidates (tyCoVarsOfTypes seed_tys)++       -- Now we have to classify them into kind variables and type variables+       -- (sigh) just for the benefit of -XNoPolyKinds; see quantifyZonkedTyVars+       --+       -- Keep the psig_tys first, so that candidateQTyVarsOfTypes produces+       -- them in that order, so that the final qtvs quantifies in the same+       -- order as the partial signatures do (Trac #13524)+       ; let DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs}+                      = candidateQTyVarsOfTypes $+                        psig_tys ++ candidates ++ tau_tys+             pick     = filterDVarSet (`elemVarSet` grown_tvs)+             dvs_plus = DV { dv_kvs = pick cand_kvs, dv_tvs = pick cand_tvs }++       ; mono_tvs <- TcM.zonkTyCoVarsAndFV mono_tvs+       ; quantifyZonkedTyVars mono_tvs dvs_plus }++------------------+growThetaTyVars :: ThetaType -> TyCoVarSet -> TyVarSet+-- See Note [Growing the tau-tvs using constraints]+-- NB: only returns tyvars, never covars+growThetaTyVars theta tvs+  | null theta = tvs_only+  | otherwise  = filterVarSet isTyVar $+                 transCloVarSet mk_next seed_tvs+  where+    tvs_only = filterVarSet isTyVar tvs+    seed_tvs = tvs `unionVarSet` tyCoVarsOfTypes ips+    (ips, non_ips) = partition isIPPred theta+                         -- See Note [Inheriting implicit parameters] in TcType++    mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones+    mk_next so_far = foldr (grow_one so_far) emptyVarSet non_ips+    grow_one so_far pred tvs+       | pred_tvs `intersectsVarSet` so_far = tvs `unionVarSet` pred_tvs+       | otherwise                          = tvs+       where+         pred_tvs = tyCoVarsOfType pred++{- Note [Promote momomorphic tyvars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Promote any type variables that are free in the environment.  Eg+   f :: forall qtvs. bound_theta => zonked_tau+The free vars of f's type become free in the envt, and hence will show+up whenever 'f' is called.  They may currently at rhs_tclvl, but they+had better be unifiable at the outer_tclvl!  Example: envt mentions+alpha[1]+           tau_ty = beta[2] -> beta[2]+           constraints = alpha ~ [beta]+we don't quantify over beta (since it is fixed by envt)+so we must promote it!  The inferred type is just+  f :: beta -> beta++NB: promoteTyVar ignores coercion variables++Note [Quantification and partial signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When choosing type variables to quantify, the basic plan is to+quantify over all type variables that are+ * free in the tau_tvs, and+ * not forced to be monomorphic (mono_tvs),+   for example by being free in the environment.++However, in the case of a partial type signature, be doing inference+*in the presence of a type signature*. For example:+   f :: _ -> a+   f x = ...+or+   g :: (Eq _a) => _b -> _b+In both cases we use plan InferGen, and hence call simplifyInfer.  But+those 'a' variables are skolems (actually SigTvs), and we should be+sure to quantify over them.  This leads to several wrinkles:++* Wrinkle 1.  In the case of a type error+     f :: _ -> Maybe a+     f x = True && x+  The inferred type of 'f' is f :: Bool -> Bool, but there's a+  left-over error of form (HoleCan (Maybe a ~ Bool)).  The error-reporting+  machine expects to find a binding site for the skolem 'a', so we+  add it to the quantified tyvars.++* Wrinkle 2.  Consider the partial type signature+     f :: (Eq _) => Int -> Int+     f x = x+  In normal cases that makes sense; e.g.+     g :: Eq _a => _a -> _a+     g x = x+  where the signature makes the type less general than it could+  be. But for 'f' we must therefore quantify over the user-annotated+  constraints, to get+     f :: forall a. Eq a => Int -> Int+  (thereby correctly triggering an ambiguity error later).  If we don't+  we'll end up with a strange open type+     f :: Eq alpha => Int -> Int+  which isn't ambiguous but is still very wrong.++  Bottom line: Try to quantify over any variable free in psig_theta,+  just like the tau-part of the type.++* Wrinkle 3 (Trac #13482). Also consider+    f :: forall a. _ => Int -> Int+    f x = if undefined :: a == undefined then x else 0+  Here we get an (Eq a) constraint, but it's not mentioned in the+  psig_theta nor the type of 'f'.  Moreover, if we have+    f :: forall a. a -> _+    f x = not x+  and a constraint (a ~ g), where 'g' is free in the environment,+  we would not usually quanitfy over 'a'.  But here we should anyway+  (leading to a justified subsequent error) since 'a' is explicitly+  quantified by the programmer.++  Bottom line: always quantify over the psig_tvs, regardless.++Note [Quantifying over equality constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Should we quantify over an equality constraint (s ~ t)?  In general, we don't.+Doing so may simply postpone a type error from the function definition site to+its call site.  (At worst, imagine (Int ~ Bool)).++However, consider this+         forall a. (F [a] ~ Int) => blah+Should we quantify over the (F [a] ~ Int)?  Perhaps yes, because at the call+site we will know 'a', and perhaps we have instance  F [Bool] = Int.+So we *do* quantify over a type-family equality where the arguments mention+the quantified variables.++Note [Growing the tau-tvs using constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(growThetaTyVars insts tvs) is the result of extending the set+    of tyvars, tvs, using all conceivable links from pred++E.g. tvs = {a}, preds = {H [a] b, K (b,Int) c, Eq e}+Then growThetaTyVars preds tvs = {a,b,c}++Notice that+   growThetaTyVars is conservative       if v might be fixed by vs+                                         => v `elem` grow(vs,C)++Note [Quantification with errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we find that the RHS of the definition has some absolutely-insoluble+constraints, we abandon all attempts to find a context to quantify+over, and instead make the function fully-polymorphic in whatever+type we have found.  For two reasons+  a) Minimise downstream errors+  b) Avoid spurious errors from this function++But NB that we must include *derived* errors in the check. Example:+    (a::*) ~ Int#+We get an insoluble derived error *~#, and we don't want to discard+it before doing the isInsolubleWC test!  (Trac #8262)++Note [Default while Inferring]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Our current plan is that defaulting only happens at simplifyTop and+not simplifyInfer.  This may lead to some insoluble deferred constraints.+Example:++instance D g => C g Int b++constraint inferred = (forall b. 0 => C gamma alpha b) /\ Num alpha+type inferred       = gamma -> gamma++Now, if we try to default (alpha := Int) we will be able to refine the implication to+  (forall b. 0 => C gamma Int b)+which can then be simplified further to+  (forall b. 0 => D gamma)+Finally, we /can/ approximate this implication with (D gamma) and infer the quantified+type:  forall g. D g => g -> g++Instead what will currently happen is that we will get a quantified type+(forall g. g -> g) and an implication:+       forall g. 0 => (forall b. 0 => C g alpha b) /\ Num alpha++Which, even if the simplifyTop defaults (alpha := Int) we will still be left with an+unsolvable implication:+       forall g. 0 => (forall b. 0 => D g)++The concrete example would be:+       h :: C g a s => g -> a -> ST s a+       f (x::gamma) = (\_ -> x) (runST (h x (undefined::alpha)) + 1)++But it is quite tedious to do defaulting and resolve the implication constraints, and+we have not observed code breaking because of the lack of defaulting in inference, so+we don't do it for now.++++Note [Minimize by Superclasses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we quantify over a constraint, in simplifyInfer we need to+quantify over a constraint that is minimal in some sense: For+instance, if the final wanted constraint is (Eq alpha, Ord alpha),+we'd like to quantify over Ord alpha, because we can just get Eq alpha+from superclass selection from Ord alpha. This minimization is what+mkMinimalBySCs does. Then, simplifyInfer uses the minimal constraint+to check the original wanted.+++Note [Avoid unnecessary constraint simplification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    -------- NB NB NB (Jun 12) -------------+    This note not longer applies; see the notes with Trac #4361.+    But I'm leaving it in here so we remember the issue.)+    ----------------------------------------+When inferring the type of a let-binding, with simplifyInfer,+try to avoid unnecessarily simplifying class constraints.+Doing so aids sharing, but it also helps with delicate+situations like++   instance C t => C [t] where ..++   f :: C [t] => ....+   f x = let g y = ...(constraint C [t])...+         in ...+When inferring a type for 'g', we don't want to apply the+instance decl, because then we can't satisfy (C t).  So we+just notice that g isn't quantified over 't' and partition+the constraints before simplifying.++This only half-works, but then let-generalisation only half-works.++*********************************************************************************+*                                                                                 *+*                                 Main Simplifier                                 *+*                                                                                 *+***********************************************************************************++-}++simplifyWantedsTcM :: [CtEvidence] -> TcM WantedConstraints+-- Solve the specified Wanted constraints+-- Discard the evidence binds+-- Discards all Derived stuff in result+-- Postcondition: fully zonked and unflattened constraints+simplifyWantedsTcM wanted+  = do { traceTc "simplifyWantedsTcM {" (ppr wanted)+       ; (result, _) <- runTcS (solveWantedsAndDrop (mkSimpleWC wanted))+       ; result <- TcM.zonkWC result+       ; traceTc "simplifyWantedsTcM }" (ppr result)+       ; return result }++solveWantedsAndDrop :: WantedConstraints -> TcS WantedConstraints+-- Since solveWanteds returns the residual WantedConstraints,+-- it should always be called within a runTcS or something similar,+-- Result is not zonked+solveWantedsAndDrop wanted+  = do { wc <- solveWanteds wanted+       ; return (dropDerivedWC wc) }++solveWanteds :: WantedConstraints -> TcS WantedConstraints+-- so that the inert set doesn't mindlessly propagate.+-- NB: wc_simples may be wanted /or/ derived now+solveWanteds wc@(WC { wc_simple = simples, wc_insol = insols, wc_impl = implics })+  = do { traceTcS "solveWanteds {" (ppr wc)++       ; wc1 <- solveSimpleWanteds simples+       ; let WC { wc_simple = simples1, wc_insol = insols1, wc_impl = implics1 } = wc1++       ; (floated_eqs, implics2) <- solveNestedImplications (implics `unionBags` implics1)+       ; (no_new_scs, simples2)  <- expandSuperClasses simples1++       ; traceTcS "solveWanteds middle" $ vcat [ text "simples1 =" <+> ppr simples1+                                               , text "simples2 =" <+> ppr simples2 ]++       ; dflags <- getDynFlags+       ; final_wc <- simpl_loop 0 (solverIterations dflags) floated_eqs+                                no_new_scs+                                (WC { wc_simple = simples2, wc_impl = implics2+                                    , wc_insol  = insols `unionBags` insols1 })++       ; bb <- TcS.getTcEvBindsMap+       ; traceTcS "solveWanteds }" $+                 vcat [ text "final wc =" <+> ppr final_wc+                      , text "current evbinds  =" <+> ppr (evBindMapBinds bb) ]++       ; return final_wc }++simpl_loop :: Int -> IntWithInf -> Cts -> Bool+           -> WantedConstraints+           -> TcS WantedConstraints+simpl_loop n limit floated_eqs no_new_deriveds+           wc@(WC { wc_simple = simples, wc_insol = insols, wc_impl = implics })+  | isEmptyBag floated_eqs && no_new_deriveds+  = return wc  -- Done!++  | n `intGtLimit` limit+  = do { -- Add an error (not a warning) if we blow the limit,+         -- Typically if we blow the limit we are going to report some other error+         -- (an unsolved constraint), and we don't want that error to suppress+         -- the iteration limit warning!+         addErrTcS (hang (text "solveWanteds: too many iterations"+                   <+> parens (text "limit =" <+> ppr limit))+                2 (vcat [ text "Unsolved:" <+> ppr wc+                        , ppUnless (isEmptyBag floated_eqs) $+                          text "Floated equalities:" <+> ppr floated_eqs+                        , ppUnless no_new_deriveds $+                          text "New deriveds found"+                        , text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit"+                  ]))+       ; return wc }++  | otherwise+  = do { let n_floated = lengthBag floated_eqs+       ; csTraceTcS $+         text "simpl_loop iteration=" <> int n+         <+> (parens $ hsep [ text "no new deriveds =" <+> ppr no_new_deriveds <> comma+                            , int n_floated <+> text "floated eqs" <> comma+                            , int (lengthBag simples) <+> text "simples to solve" ])++       -- solveSimples may make progress if either float_eqs hold+       ; (unifs1, wc1) <- reportUnifications $+                          solveSimpleWanteds (floated_eqs `unionBags` simples)+                               -- Put floated_eqs first so they get solved first+                               -- NB: the floated_eqs may include /derived/ equalities+                               --     arising from fundeps inside an implication++       ; let WC { wc_simple = simples1, wc_insol = insols1, wc_impl = implics1 } = wc1+       ; (no_new_scs, simples2) <- expandSuperClasses simples1++       -- We have already tried to solve the nested implications once+       -- Try again only if we have unified some meta-variables+       -- (which is a bit like adding more givens+       -- See Note [Cutting off simpl_loop]+       ; (floated_eqs2, implics2) <- if unifs1 == 0 && isEmptyBag implics1+                                     then return (emptyBag, implics)+                                     else solveNestedImplications (implics `unionBags` implics1)++       ; simpl_loop (n+1) limit floated_eqs2 no_new_scs+                    (WC { wc_simple = simples2, wc_impl = implics2+                        , wc_insol  = insols `unionBags` insols1 }) }++expandSuperClasses :: Cts -> TcS (Bool, Cts)+-- If there are any unsolved wanteds, expand one step of+-- superclasses for deriveds+-- Returned Bool is True <=> no new superclass constraints added+-- See Note [The superclass story] in TcCanonical+expandSuperClasses unsolved+  | not (anyBag superClassesMightHelp unsolved)+  = return (True, unsolved)+  | otherwise+  = do { traceTcS "expandSuperClasses {" empty+       ; let (pending_wanted, unsolved') = mapAccumBagL get [] unsolved+             get acc ct | Just ct' <- isPendingScDict ct+                        = (ct':acc, ct')+                        | otherwise+                        = (acc,     ct)+       ; pending_given <- getPendingScDicts+       ; if null pending_given && null pending_wanted+         then do { traceTcS "End expandSuperClasses no-op }" empty+                 ; return (True, unsolved) }+         else+    do { new_given  <- makeSuperClasses pending_given+       ; solveSimpleGivens new_given+       ; new_wanted <- makeSuperClasses pending_wanted+       ; traceTcS "End expandSuperClasses }"+                  (vcat [ text "Given:" <+> ppr pending_given+                        , text "Wanted:" <+> ppr new_wanted ])+       ; return (False, unsolved' `unionBags` listToBag new_wanted) } }++solveNestedImplications :: Bag Implication+                        -> TcS (Cts, Bag Implication)+-- Precondition: the TcS inerts may contain unsolved simples which have+-- to be converted to givens before we go inside a nested implication.+solveNestedImplications implics+  | isEmptyBag implics+  = return (emptyBag, emptyBag)+  | otherwise+  = do { traceTcS "solveNestedImplications starting {" empty+       ; (floated_eqs_s, unsolved_implics) <- mapAndUnzipBagM solveImplication implics+       ; let floated_eqs = concatBag floated_eqs_s++       -- ... and we are back in the original TcS inerts+       -- Notice that the original includes the _insoluble_simples so it was safe to ignore+       -- them in the beginning of this function.+       ; traceTcS "solveNestedImplications end }" $+                  vcat [ text "all floated_eqs ="  <+> ppr floated_eqs+                       , text "unsolved_implics =" <+> ppr unsolved_implics ]++       ; return (floated_eqs, catBagMaybes unsolved_implics) }++solveImplication :: Implication    -- Wanted+                 -> TcS (Cts,      -- All wanted or derived floated equalities: var = type+                         Maybe Implication) -- Simplified implication (empty or singleton)+-- Precondition: The TcS monad contains an empty worklist and given-only inerts+-- which after trying to solve this implication we must restore to their original value+solveImplication imp@(Implic { ic_tclvl  = tclvl+                             , ic_binds  = ev_binds_var+                             , ic_skols  = skols+                             , ic_given  = given_ids+                             , ic_wanted = wanteds+                             , ic_info   = info+                             , ic_status = status+                             , ic_env    = env })+  | isSolvedStatus status+  = return (emptyCts, Just imp)  -- Do nothing++  | otherwise  -- Even for IC_Insoluble it is worth doing more work+               -- The insoluble stuff might be in one sub-implication+               -- and other unsolved goals in another; and we want to+               -- solve the latter as much as possible+  = do { inerts <- getTcSInerts+       ; traceTcS "solveImplication {" (ppr imp $$ text "Inerts" <+> ppr inerts)++         -- Solve the nested constraints+       ; (no_given_eqs, given_insols, residual_wanted)+            <- nestImplicTcS ev_binds_var tclvl $+               do { let loc    = mkGivenLoc tclvl info env+                        givens = mkGivens loc given_ids+                  ; solveSimpleGivens givens++                  ; residual_wanted <- solveWanteds wanteds+                        -- solveWanteds, *not* solveWantedsAndDrop, because+                        -- we want to retain derived equalities so we can float+                        -- them out in floatEqualities++                  ; (no_eqs, given_insols) <- getNoGivenEqs tclvl skols+                        -- Call getNoGivenEqs /after/ solveWanteds, because+                        -- solveWanteds can augment the givens, via expandSuperClasses,+                        -- to reveal given superclass equalities++                  ; return (no_eqs, given_insols, residual_wanted) }++       ; (floated_eqs, residual_wanted)+             <- floatEqualities skols no_given_eqs residual_wanted++       ; traceTcS "solveImplication 2"+           (ppr given_insols $$ ppr residual_wanted)+       ; let final_wanted = residual_wanted `addInsols` given_insols++       ; res_implic <- setImplicationStatus (imp { ic_no_eqs = no_given_eqs+                                                 , ic_wanted = final_wanted })++       ; (evbinds, tcvs) <- TcS.getTcEvBindsAndTCVs ev_binds_var+       ; traceTcS "solveImplication end }" $ vcat+             [ text "no_given_eqs =" <+> ppr no_given_eqs+             , text "floated_eqs =" <+> ppr floated_eqs+             , text "res_implic =" <+> ppr res_implic+             , text "implication evbinds =" <+> ppr (evBindMapBinds evbinds)+             , text "implication tvcs =" <+> ppr tcvs ]++       ; return (floated_eqs, res_implic) }++----------------------+setImplicationStatus :: Implication -> TcS (Maybe Implication)+-- Finalise the implication returned from solveImplication:+--    * Set the ic_status field+--    * Trim the ic_wanted field to remove Derived constraints+-- Precondition: the ic_status field is not already IC_Solved+-- Return Nothing if we can discard the implication altogether+setImplicationStatus implic@(Implic { ic_binds  = ev_binds_var+                                    , ic_status = status+                                    , ic_info   = info+                                    , ic_wanted = wc+                                    , ic_needed = old_discarded_needs+                                    , ic_given  = givens })+ | ASSERT2( not (isSolvedStatus status ), ppr info )+   -- Precondition: we only set the status if it is not already solved+   some_insoluble+ = return $ Just $+   implic { ic_status = IC_Insoluble+          , ic_needed = new_discarded_needs+          , ic_wanted = pruned_wc }++ | some_unsolved+ = do { traceTcS "setImplicationStatus" $+        vcat [ppr givens $$ ppr simples $$ ppr insols $$ ppr mb_implic_needs]+      ; return $ Just $+        implic { ic_status = IC_Unsolved+               , ic_needed = new_discarded_needs+               , ic_wanted = pruned_wc }+   }++ | otherwise  -- Everything is solved; look at the implications+              -- See Note [Tracking redundant constraints]+ = do { ev_binds <- TcS.getTcEvBindsAndTCVs ev_binds_var+      ; let all_needs = neededEvVars ev_binds $+                        solved_implic_needs `unionVarSet` new_discarded_needs++            dead_givens | warnRedundantGivens info+                        = filterOut (`elemVarSet` all_needs) givens+                        | otherwise = []   -- None to report++            final_needs = all_needs `delVarSetList` givens++            discard_entire_implication  -- Can we discard the entire implication?+              =  null dead_givens           -- No warning from this implication+              && isEmptyBag pruned_implics  -- No live children+              && isEmptyVarSet final_needs  -- No needed vars to pass up to parent++            final_status = IC_Solved { ics_need = final_needs+                                     , ics_dead = dead_givens }+            final_implic = implic { ic_status = final_status+                                  , ic_needed = emptyVarSet -- Irrelevant for IC_Solved+                                  , ic_wanted = pruned_wc }++        -- Check that there are no term-level evidence bindings+        -- in the cases where we have no place to put them+      ; MASSERT2( termEvidenceAllowed info || isEmptyEvBindMap (fst ev_binds)+                , ppr info $$ ppr ev_binds )++      ; traceTcS "setImplicationStatus 2" $+        vcat [ppr givens $$ ppr ev_binds $$ ppr all_needs]+      ; return $ if discard_entire_implication+                 then Nothing+                 else Just final_implic }+ where+   WC { wc_simple = simples, wc_impl = implics, wc_insol = insols } = wc++   some_insoluble = insolubleWC wc+   some_unsolved = not (isEmptyBag simples && isEmptyBag insols)+                 || isNothing mb_implic_needs++   pruned_simples = dropDerivedSimples simples+   pruned_insols  = dropDerivedInsols insols+   (pruned_implics, discarded_needs) = partitionBagWith discard_me implics+   pruned_wc = wc { wc_simple = pruned_simples+                  , wc_insol  = pruned_insols+                  , wc_impl   = pruned_implics }+   new_discarded_needs = foldrBag unionVarSet old_discarded_needs discarded_needs++   mb_implic_needs :: Maybe VarSet+        -- Just vs => all implics are IC_Solved, with 'vs' needed+        -- Nothing => at least one implic is not IC_Solved+   mb_implic_needs   = foldrBag add_implic (Just emptyVarSet) pruned_implics+   Just solved_implic_needs = mb_implic_needs++   add_implic implic acc+      | Just vs_acc <- acc+      , IC_Solved { ics_need = vs } <- ic_status implic+      = Just (vs `unionVarSet` vs_acc)+      | otherwise = Nothing++   discard_me :: Implication -> Either Implication VarSet+   discard_me ic+     | IC_Solved { ics_dead = dead_givens, ics_need = needed } <- ic_status ic+                          -- Fully solved+     , null dead_givens   -- No redundant givens to report+     , isEmptyBag (wc_impl (ic_wanted ic))+           -- And no children that might have things to report+     = Right needed+     | otherwise+     = Left ic++warnRedundantGivens :: SkolemInfo -> Bool+warnRedundantGivens (SigSkol ctxt _ _)+  = case ctxt of+       FunSigCtxt _ warn_redundant -> warn_redundant+       ExprSigCtxt                 -> True+       _                           -> False++  -- To think about: do we want to report redundant givens for+  -- pattern synonyms, PatSynSigSkol? c.f Trac #9953, comment:21.+warnRedundantGivens (InstSkol {}) = True+warnRedundantGivens _             = False++neededEvVars :: (EvBindMap, TcTyVarSet) -> VarSet -> VarSet+-- Find all the evidence variables that are "needed",+--    and then delete all those bound by the evidence bindings+-- See Note [Tracking redundant constraints]+neededEvVars (ev_binds, tcvs) initial_seeds+ = (needed `unionVarSet` tcvs) `minusVarSet` bndrs+ where+   seeds  = foldEvBindMap add_wanted initial_seeds ev_binds+   needed = transCloVarSet also_needs seeds+   bndrs  = foldEvBindMap add_bndr emptyVarSet ev_binds++   add_wanted :: EvBind -> VarSet -> VarSet+   add_wanted (EvBind { eb_is_given = is_given, eb_rhs = rhs }) needs+     | is_given  = needs  -- Add the rhs vars of the Wanted bindings only+     | otherwise = evVarsOfTerm rhs `unionVarSet` needs++   also_needs :: VarSet -> VarSet+   also_needs needs+     = nonDetFoldUniqSet add emptyVarSet needs+     -- It's OK to use nonDetFoldUFM here because we immediately forget+     -- about the ordering by creating a set+     where+       add v needs+        | Just ev_bind <- lookupEvBind ev_binds v+        , EvBind { eb_is_given = is_given, eb_rhs = rhs } <- ev_bind+        , is_given+        = evVarsOfTerm rhs `unionVarSet` needs+        | otherwise+        = needs++   add_bndr :: EvBind -> VarSet -> VarSet+   add_bndr (EvBind { eb_lhs = v }) vs = extendVarSet vs v+++{-+Note [Tracking redundant constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+With Opt_WarnRedundantConstraints, GHC can report which+constraints of a type signature (or instance declaration) are+redundant, and can be omitted.  Here is an overview of how it+works:++----- What is a redundant constraint?++* The things that can be redundant are precisely the Given+  constraints of an implication.++* A constraint can be redundant in two different ways:+  a) It is implied by other givens.  E.g.+       f :: (Eq a, Ord a)     => blah   -- Eq a unnecessary+       g :: (Eq a, a~b, Eq b) => blah   -- Either Eq a or Eq b unnecessary+  b) It is not needed by the Wanted constraints covered by the+     implication E.g.+       f :: Eq a => a -> Bool+       f x = True  -- Equality not used++*  To find (a), when we have two Given constraints,+   we must be careful to drop the one that is a naked variable (if poss).+   So if we have+       f :: (Eq a, Ord a) => blah+   then we may find [G] sc_sel (d1::Ord a) :: Eq a+                    [G] d2 :: Eq a+   We want to discard d2 in favour of the superclass selection from+   the Ord dictionary.  This is done by TcInteract.solveOneFromTheOther+   See Note [Replacement vs keeping].++* To find (b) we need to know which evidence bindings are 'wanted';+  hence the eb_is_given field on an EvBind.++----- How tracking works++* When the constraint solver finishes solving all the wanteds in+  an implication, it sets its status to IC_Solved++  - The ics_dead field, of IC_Solved, records the subset of this+    implication's ic_given that are redundant (not needed).++  - The ics_need field of IC_Solved then records all the+    in-scope (given) evidence variables bound by the context, that+    were needed to solve this implication, including all its nested+    implications.  (We remove the ic_given of this implication from+    the set, of course.)++* We compute which evidence variables are needed by an implication+  in setImplicationStatus.  A variable is needed if+    a) it is free in the RHS of a Wanted EvBind,+    b) it is free in the RHS of an EvBind whose LHS is needed,+    c) it is in the ics_need of a nested implication.++* We need to be careful not to discard an implication+  prematurely, even one that is fully solved, because we might+  thereby forget which variables it needs, and hence wrongly+  report a constraint as redundant.  But we can discard it once+  its free vars have been incorporated into its parent; or if it+  simply has no free vars. This careful discarding is also+  handled in setImplicationStatus.++----- Reporting redundant constraints++* TcErrors does the actual warning, in warnRedundantConstraints.++* We don't report redundant givens for *every* implication; only+  for those which reply True to TcSimplify.warnRedundantGivens:++   - For example, in a class declaration, the default method *can*+     use the class constraint, but it certainly doesn't *have* to,+     and we don't want to report an error there.++   - More subtly, in a function definition+       f :: (Ord a, Ord a, Ix a) => a -> a+       f x = rhs+     we do an ambiguity check on the type (which would find that one+     of the Ord a constraints was redundant), and then we check that+     the definition has that type (which might find that both are+     redundant).  We don't want to report the same error twice, so we+     disable it for the ambiguity check.  Hence using two different+     FunSigCtxts, one with the warn-redundant field set True, and the+     other set False in+        - TcBinds.tcSpecPrag+        - TcBinds.tcTySig++  This decision is taken in setImplicationStatus, rather than TcErrors+  so that we can discard implication constraints that we don't need.+  So ics_dead consists only of the *reportable* redundant givens.++----- Shortcomings++Consider (see Trac #9939)+    f2 :: (Eq a, Ord a) => a -> a -> Bool+    -- Ord a redundant, but Eq a is reported+    f2 x y = (x == y)++We report (Eq a) as redundant, whereas actually (Ord a) is.  But it's+really not easy to detect that!+++Note [Cutting off simpl_loop]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is very important not to iterate in simpl_loop unless there is a chance+of progress.  Trac #8474 is a classic example:++  * There's a deeply-nested chain of implication constraints.+       ?x:alpha => ?y1:beta1 => ... ?yn:betan => [W] ?x:Int++  * From the innermost one we get a [D] alpha ~ Int,+    but alpha is untouchable until we get out to the outermost one++  * We float [D] alpha~Int out (it is in floated_eqs), but since alpha+    is untouchable, the solveInteract in simpl_loop makes no progress++  * So there is no point in attempting to re-solve+       ?yn:betan => [W] ?x:Int+    via solveNestedImplications, because we'll just get the+    same [D] again++  * If we *do* re-solve, we'll get an ininite loop. It is cut off by+    the fixed bound of 10, but solving the next takes 10*10*...*10 (ie+    exponentially many) iterations!++Conclusion: we should call solveNestedImplications only if we did+some unification in solveSimpleWanteds; because that's the only way+we'll get more Givens (a unification is like adding a Given) to+allow the implication to make progress.+-}++promoteTyVar :: TcLevel -> TcTyVar  -> TcM Bool+-- When we float a constraint out of an implication we must restore+-- invariant (MetaTvInv) in Note [TcLevel and untouchable type variables] in TcType+-- Return True <=> we did some promotion+-- See Note [Promoting unification variables]+promoteTyVar tclvl tv+  | isFloatedTouchableMetaTyVar tclvl tv+  = do { cloned_tv <- TcM.cloneMetaTyVar tv+       ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl+       ; TcM.writeMetaTyVar tv (mkTyVarTy rhs_tv)+       ; return True }+  | otherwise+  = return False++promoteTyVarTcS :: TcLevel -> TcTyVar  -> TcS ()+-- When we float a constraint out of an implication we must restore+-- invariant (MetaTvInv) in Note [TcLevel and untouchable type variables] in TcType+-- See Note [Promoting unification variables]+-- We don't just call promoteTyVar because we want to use unifyTyVar,+-- not writeMetaTyVar+promoteTyVarTcS tclvl tv+  | isFloatedTouchableMetaTyVar tclvl tv+  = do { cloned_tv <- TcS.cloneMetaTyVar tv+       ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl+       ; unifyTyVar tv (mkTyVarTy rhs_tv) }+  | otherwise+  = return ()++-- | Like 'defaultTyVar', but in the TcS monad.+defaultTyVarTcS :: TcTyVar -> TcS Bool+defaultTyVarTcS the_tv+  | isRuntimeRepVar the_tv+  = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv)+       ; unifyTyVar the_tv liftedRepTy+       ; return True }+  | otherwise+  = return False  -- the common case++approximateWC :: Bool -> WantedConstraints -> Cts+-- Postcondition: Wanted or Derived Cts+-- See Note [ApproximateWC]+approximateWC float_past_equalities wc+  = float_wc emptyVarSet wc+  where+    float_wc :: TcTyCoVarSet -> WantedConstraints -> Cts+    float_wc trapping_tvs (WC { wc_simple = simples, wc_impl = implics })+      = filterBag is_floatable simples `unionBags`+        do_bag (float_implic trapping_tvs) implics+      where+        is_floatable ct = tyCoVarsOfCt ct `disjointVarSet` trapping_tvs++    float_implic :: TcTyCoVarSet -> Implication -> Cts+    float_implic trapping_tvs imp+      | float_past_equalities || ic_no_eqs imp+      = float_wc new_trapping_tvs (ic_wanted imp)+      | otherwise   -- Take care with equalities+      = emptyCts    -- See (1) under Note [ApproximateWC]+      where+        new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp+    do_bag :: (a -> Bag c) -> Bag a -> Bag c+    do_bag f = foldrBag (unionBags.f) emptyBag++{- Note [ApproximateWC]+~~~~~~~~~~~~~~~~~~~~~~~+approximateWC takes a constraint, typically arising from the RHS of a+let-binding whose type we are *inferring*, and extracts from it some+*simple* constraints that we might plausibly abstract over.  Of course+the top-level simple constraints are plausible, but we also float constraints+out from inside, if they are not captured by skolems.++The same function is used when doing type-class defaulting (see the call+to applyDefaultingRules) to extract constraints that that might be defaulted.++There is one caveat:++1.  When infering most-general types (in simplifyInfer), we do *not*+    float anything out if the implication binds equality constraints,+    because that defeats the OutsideIn story.  Consider+       data T a where+         TInt :: T Int+         MkT :: T a++       f TInt = 3::Int++    We get the implication (a ~ Int => res ~ Int), where so far we've decided+      f :: T a -> res+    We don't want to float (res~Int) out because then we'll infer+      f :: T a -> Int+    which is only on of the possible types. (GHC 7.6 accidentally *did*+    float out of such implications, which meant it would happily infer+    non-principal types.)++   HOWEVER (Trac #12797) in findDefaultableGroups we are not worried about+   the most-general type; and we /do/ want to float out of equalities.+   Hence the boolean flag to approximateWC.++------ Historical note -----------+There used to be a second caveat, driven by Trac #8155++   2. We do not float out an inner constraint that shares a type variable+      (transitively) with one that is trapped by a skolem.  Eg+          forall a.  F a ~ beta, Integral beta+      We don't want to float out (Integral beta).  Doing so would be bad+      when defaulting, because then we'll default beta:=Integer, and that+      makes the error message much worse; we'd get+          Can't solve  F a ~ Integer+      rather than+          Can't solve  Integral (F a)++      Moreover, floating out these "contaminated" constraints doesn't help+      when generalising either. If we generalise over (Integral b), we still+      can't solve the retained implication (forall a. F a ~ b).  Indeed,+      arguably that too would be a harder error to understand.++But this transitive closure stuff gives rise to a complex rule for+when defaulting actually happens, and one that was never documented.+Moreover (Trac #12923), the more complex rule is sometimes NOT what+you want.  So I simply removed the extra code to implement the+contamination stuff.  There was zero effect on the testsuite (not even+#8155).+------ End of historical note -----------+++Note [DefaultTyVar]+~~~~~~~~~~~~~~~~~~~+defaultTyVar is used on any un-instantiated meta type variables to+default any RuntimeRep variables to LiftedRep.  This is important+to ensure that instance declarations match.  For example consider++     instance Show (a->b)+     foo x = show (\_ -> True)++Then we'll get a constraint (Show (p ->q)) where p has kind (TYPE r),+and that won't match the typeKind (*) in the instance decl.  See tests+tc217 and tc175.++We look only at touchable type variables. No further constraints+are going to affect these type variables, so it's time to do it by+hand.  However we aren't ready to default them fully to () or+whatever, because the type-class defaulting rules have yet to run.++An alternate implementation would be to emit a derived constraint setting+the RuntimeRep variable to LiftedRep, but this seems unnecessarily indirect.++Note [Promote _and_ default when inferring]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we are inferring a type, we simplify the constraint, and then use+approximateWC to produce a list of candidate constraints.  Then we MUST++  a) Promote any meta-tyvars that have been floated out by+     approximateWC, to restore invariant (MetaTvInv) described in+     Note [TcLevel and untouchable type variables] in TcType.++  b) Default the kind of any meta-tyvars that are not mentioned in+     in the environment.++To see (b), suppose the constraint is (C ((a :: OpenKind) -> Int)), and we+have an instance (C ((x:*) -> Int)).  The instance doesn't match -- but it+should!  If we don't solve the constraint, we'll stupidly quantify over+(C (a->Int)) and, worse, in doing so zonkQuantifiedTyVar will quantify over+(b:*) instead of (a:OpenKind), which can lead to disaster; see Trac #7332.+Trac #7641 is a simpler example.++Note [Promoting unification variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we float an equality out of an implication we must "promote" free+unification variables of the equality, in order to maintain Invariant+(MetaTvInv) from Note [TcLevel and untouchable type variables] in TcType.  for the+leftover implication.++This is absolutely necessary. Consider the following example. We start+with two implications and a class with a functional dependency.++    class C x y | x -> y+    instance C [a] [a]++    (I1)      [untch=beta]forall b. 0 => F Int ~ [beta]+    (I2)      [untch=beta]forall c. 0 => F Int ~ [[alpha]] /\ C beta [c]++We float (F Int ~ [beta]) out of I1, and we float (F Int ~ [[alpha]]) out of I2.+They may react to yield that (beta := [alpha]) which can then be pushed inwards+the leftover of I2 to get (C [alpha] [a]) which, using the FunDep, will mean that+(alpha := a). In the end we will have the skolem 'b' escaping in the untouchable+beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs:++    class C x y | x -> y where+     op :: x -> y -> ()++    instance C [a] [a]++    type family F a :: *++    h :: F Int -> ()+    h = undefined++    data TEx where+      TEx :: a -> TEx++    f (x::beta) =+        let g1 :: forall b. b -> ()+            g1 _ = h [x]+            g2 z = case z of TEx y -> (h [[undefined]], op x [y])+        in (g1 '3', g2 undefined)++++*********************************************************************************+*                                                                               *+*                          Floating equalities                                  *+*                                                                               *+*********************************************************************************++Note [Float Equalities out of Implications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For ordinary pattern matches (including existentials) we float+equalities out of implications, for instance:+     data T where+       MkT :: Eq a => a -> T+     f x y = case x of MkT _ -> (y::Int)+We get the implication constraint (x::T) (y::alpha):+     forall a. [untouchable=alpha] Eq a => alpha ~ Int+We want to float out the equality into a scope where alpha is no+longer untouchable, to solve the implication!++But we cannot float equalities out of implications whose givens may+yield or contain equalities:++      data T a where+        T1 :: T Int+        T2 :: T Bool+        T3 :: T a++      h :: T a -> a -> Int++      f x y = case x of+                T1 -> y::Int+                T2 -> y::Bool+                T3 -> h x y++We generate constraint, for (x::T alpha) and (y :: beta):+   [untouchables = beta] (alpha ~ Int => beta ~ Int)   -- From 1st branch+   [untouchables = beta] (alpha ~ Bool => beta ~ Bool) -- From 2nd branch+   (alpha ~ beta)                                      -- From 3rd branch++If we float the equality (beta ~ Int) outside of the first implication and+the equality (beta ~ Bool) out of the second we get an insoluble constraint.+But if we just leave them inside the implications, we unify alpha := beta and+solve everything.++Principle:+    We do not want to float equalities out which may+    need the given *evidence* to become soluble.++Consequence: classes with functional dependencies don't matter (since there is+no evidence for a fundep equality), but equality superclasses do matter (since+they carry evidence).+-}++floatEqualities :: [TcTyVar] -> Bool+                -> WantedConstraints+                -> TcS (Cts, WantedConstraints)+-- Main idea: see Note [Float Equalities out of Implications]+--+-- Precondition: the wc_simple of the incoming WantedConstraints are+--               fully zonked, so that we can see their free variables+--+-- Postcondition: The returned floated constraints (Cts) are only+--                Wanted or Derived+--+-- Also performs some unifications (via promoteTyVar), adding to+-- monadically-carried ty_binds. These will be used when processing+-- floated_eqs later+--+-- Subtleties: Note [Float equalities from under a skolem binding]+--             Note [Skolem escape]+floatEqualities skols no_given_eqs+                wanteds@(WC { wc_simple = simples })+  | not no_given_eqs  -- There are some given equalities, so don't float+  = return (emptyBag, wanteds)   -- Note [Float Equalities out of Implications]+  | otherwise+  = do { outer_tclvl <- TcS.getTcLevel+       ; mapM_ (promoteTyVarTcS outer_tclvl)+               (tyCoVarsOfCtsList float_eqs)+           -- See Note [Promoting unification variables]++       ; traceTcS "floatEqualities" (vcat [ text "Skols =" <+> ppr skols+                                          , text "Simples =" <+> ppr simples+                                          , text "Floated eqs =" <+> ppr float_eqs])+       ; return ( float_eqs+                , wanteds { wc_simple = remaining_simples } ) }+  where+    skol_set = mkVarSet skols+    (float_eqs, remaining_simples) = partitionBag (usefulToFloat skol_set) simples++usefulToFloat :: VarSet -> Ct -> Bool+usefulToFloat skol_set ct   -- The constraint is un-flattened and de-canonicalised+  = is_meta_var_eq pred &&+    (tyCoVarsOfType pred `disjointVarSet` skol_set)+  where+    pred = ctPred ct++      -- Float out alpha ~ ty, or ty ~ alpha+      -- which might be unified outside+      -- See Note [Which equalities to float]+    is_meta_var_eq pred+      | EqPred NomEq ty1 ty2 <- classifyPredType pred+      = case (tcGetTyVar_maybe ty1, tcGetTyVar_maybe ty2) of+          (Just tv1, _) -> float_tv_eq tv1 ty2+          (_, Just tv2) -> float_tv_eq tv2 ty1+          _             -> False+      | otherwise+      = False++    float_tv_eq tv1 ty2  -- See Note [Which equalities to float]+      =  isMetaTyVar tv1+      && (not (isSigTyVar tv1) || isTyVarTy ty2)++{- Note [Float equalities from under a skolem binding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Which of the simple equalities can we float out?  Obviously, only+ones that don't mention the skolem-bound variables.  But that is+over-eager. Consider+   [2] forall a. F a beta[1] ~ gamma[2], G beta[1] gamma[2] ~ Int+The second constraint doesn't mention 'a'.  But if we float it,+we'll promote gamma[2] to gamma'[1].  Now suppose that we learn that+beta := Bool, and F a Bool = a, and G Bool _ = Int.  Then we'll+we left with the constraint+   [2] forall a. a ~ gamma'[1]+which is insoluble because gamma became untouchable.++Solution: float only constraints that stand a jolly good chance of+being soluble simply by being floated, namely ones of form+      a ~ ty+where 'a' is a currently-untouchable unification variable, but may+become touchable by being floated (perhaps by more than one level).++We had a very complicated rule previously, but this is nice and+simple.  (To see the notes, look at this Note in a version of+TcSimplify prior to Oct 2014).++Note [Which equalities to float]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Which equalities should we float?  We want to float ones where there+is a decent chance that floating outwards will allow unification to+happen.  In particular:++   Float out equalities of form (alpha ~ ty) or (ty ~ alpha), where++   * alpha is a meta-tyvar.++   * And 'alpha' is not a SigTv with 'ty' being a non-tyvar.  In that+     case, floating out won't help either, and it may affect grouping+     of error messages.++Note [Skolem escape]+~~~~~~~~~~~~~~~~~~~~+You might worry about skolem escape with all this floating.+For example, consider+    [2] forall a. (a ~ F beta[2] delta,+                   Maybe beta[2] ~ gamma[1])++The (Maybe beta ~ gamma) doesn't mention 'a', so we float it, and+solve with gamma := beta. But what if later delta:=Int, and+  F b Int = b.+Then we'd get a ~ beta[2], and solve to get beta:=a, and now the+skolem has escaped!++But it's ok: when we float (Maybe beta[2] ~ gamma[1]), we promote beta[2]+to beta[1], and that means the (a ~ beta[1]) will be stuck, as it should be.+++*********************************************************************************+*                                                                               *+*                          Defaulting and disambiguation                        *+*                                                                               *+*********************************************************************************+-}++applyDefaultingRules :: WantedConstraints -> TcS Bool+-- True <=> I did some defaulting, by unifying a meta-tyvar+-- Input WantedConstraints are not necessarily zonked++applyDefaultingRules wanteds+  | isEmptyWC wanteds+  = return False+  | otherwise+  = do { info@(default_tys, _) <- getDefaultInfo+       ; wanteds               <- TcS.zonkWC wanteds++       ; let groups = findDefaultableGroups info wanteds++       ; traceTcS "applyDefaultingRules {" $+                  vcat [ text "wanteds =" <+> ppr wanteds+                       , text "groups  =" <+> ppr groups+                       , text "info    =" <+> ppr info ]++       ; something_happeneds <- mapM (disambigGroup default_tys) groups++       ; traceTcS "applyDefaultingRules }" (ppr something_happeneds)++       ; return (or something_happeneds) }++findDefaultableGroups+    :: ( [Type]+       , (Bool,Bool) )     -- (Overloaded strings, extended default rules)+    -> WantedConstraints   -- Unsolved (wanted or derived)+    -> [(TyVar, [Ct])]+findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds+  | null default_tys+  = []+  | otherwise+  = [ (tv, map fstOf3 group)+    | group@((_,_,tv):_) <- unary_groups+    , defaultable_tyvar tv+    , defaultable_classes (map sndOf3 group) ]+  where+    simples                = approximateWC True wanteds+    (unaries, non_unaries) = partitionWith find_unary (bagToList simples)+    unary_groups           = equivClasses cmp_tv unaries++    unary_groups :: [[(Ct, Class, TcTyVar)]]  -- (C tv) constraints+    unaries      ::  [(Ct, Class, TcTyVar)]   -- (C tv) constraints+    non_unaries  :: [Ct]                      -- and *other* constraints++        -- Finds unary type-class constraints+        -- But take account of polykinded classes like Typeable,+        -- which may look like (Typeable * (a:*))   (Trac #8931)+    find_unary :: Ct -> Either (Ct, Class, TyVar) Ct+    find_unary cc+        | Just (cls,tys)   <- getClassPredTys_maybe (ctPred cc)+        , [ty] <- filterOutInvisibleTypes (classTyCon cls) tys+              -- Ignore invisible arguments for this purpose+        , Just tv <- tcGetTyVar_maybe ty+        , isMetaTyVar tv  -- We might have runtime-skolems in GHCi, and+                          -- we definitely don't want to try to assign to those!+        = Left (cc, cls, tv)+    find_unary cc = Right cc  -- Non unary or non dictionary++    bad_tvs :: TcTyCoVarSet  -- TyVars mentioned by non-unaries+    bad_tvs = mapUnionVarSet tyCoVarsOfCt non_unaries++    cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2++    defaultable_tyvar :: TcTyVar -> Bool+    defaultable_tyvar tv+        = let b1 = isTyConableTyVar tv  -- Note [Avoiding spurious errors]+              b2 = not (tv `elemVarSet` bad_tvs)+          in b1 && (b2 || extended_defaults) -- Note [Multi-parameter defaults]++    defaultable_classes :: [Class] -> Bool+    defaultable_classes clss+        | extended_defaults = any (isInteractiveClass ovl_strings) clss+        | otherwise         = all is_std_class clss && (any (isNumClass ovl_strings) clss)++    -- is_std_class adds IsString to the standard numeric classes,+    -- when -foverloaded-strings is enabled+    is_std_class cls = isStandardClass cls ||+                       (ovl_strings && (cls `hasKey` isStringClassKey))++------------------------------+disambigGroup :: [Type]            -- The default types+              -> (TcTyVar, [Ct])   -- All classes of the form (C a)+                                   --  sharing same type variable+              -> TcS Bool   -- True <=> something happened, reflected in ty_binds++disambigGroup [] _+  = return False+disambigGroup (default_ty:default_tys) group@(the_tv, wanteds)+  = do { traceTcS "disambigGroup {" (vcat [ ppr default_ty, ppr the_tv, ppr wanteds ])+       ; fake_ev_binds_var <- TcS.newTcEvBinds+       ; tclvl             <- TcS.getTcLevel+       ; success <- nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl) try_group++       ; if success then+             -- Success: record the type variable binding, and return+             do { unifyTyVar the_tv default_ty+                ; wrapWarnTcS $ warnDefaulting wanteds default_ty+                ; traceTcS "disambigGroup succeeded }" (ppr default_ty)+                ; return True }+         else+             -- Failure: try with the next type+             do { traceTcS "disambigGroup failed, will try other default types }"+                           (ppr default_ty)+                ; disambigGroup default_tys group } }+  where+    try_group+      | Just subst <- mb_subst+      = do { lcl_env <- TcS.getLclEnv+           ; let loc = CtLoc { ctl_origin = GivenOrigin UnkSkol+                             , ctl_env    = lcl_env+                             , ctl_t_or_k = Nothing+                             , ctl_depth  = initialSubGoalDepth }+           ; wanted_evs <- mapM (newWantedEvVarNC loc . substTy subst . ctPred)+                                wanteds+           ; fmap isEmptyWC $+             solveSimpleWanteds $ listToBag $+             map mkNonCanonical wanted_evs }++      | otherwise+      = return False++    the_ty   = mkTyVarTy the_tv+    mb_subst = tcMatchTyKi the_ty default_ty+      -- Make sure the kinds match too; hence this call to tcMatchTyKi+      -- E.g. suppose the only constraint was (Typeable k (a::k))+      -- With the addition of polykinded defaulting we also want to reject+      -- ill-kinded defaulting attempts like (Eq []) or (Foldable Int) here.++-- In interactive mode, or with -XExtendedDefaultRules,+-- we default Show a to Show () to avoid graututious errors on "show []"+isInteractiveClass :: Bool   -- -XOverloadedStrings?+                   -> Class -> Bool+isInteractiveClass ovl_strings cls+    = isNumClass ovl_strings cls || (classKey cls `elem` interactiveClassKeys)++    -- isNumClass adds IsString to the standard numeric classes,+    -- when -foverloaded-strings is enabled+isNumClass :: Bool   -- -XOverloadedStrings?+           -> Class -> Bool+isNumClass ovl_strings cls+  = isNumericClass cls || (ovl_strings && (cls `hasKey` isStringClassKey))+++{-+Note [Avoiding spurious errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When doing the unification for defaulting, we check for skolem+type variables, and simply don't default them.  For example:+   f = (*)      -- Monomorphic+   g :: Num a => a -> a+   g x = f x x+Here, we get a complaint when checking the type signature for g,+that g isn't polymorphic enough; but then we get another one when+dealing with the (Num a) context arising from f's definition;+we try to unify a with Int (to default it), but find that it's+already been unified with the rigid variable from g's type sig.++Note [Multi-parameter defaults]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+With -XExtendedDefaultRules, we default only based on single-variable+constraints, but do not exclude from defaulting any type variables which also+appear in multi-variable constraints. This means that the following will+default properly:++   default (Integer, Double)++   class A b (c :: Symbol) where+      a :: b -> Proxy c++   instance A Integer c where a _ = Proxy++   main = print (a 5 :: Proxy "5")++Note that if we change the above instance ("instance A Integer") to+"instance A Double", we get an error:++   No instance for (A Integer "5")++This is because the first defaulted type (Integer) has successfully satisfied+its single-parameter constraints (in this case Num).+-}
+ typecheck/TcSplice.hs view
@@ -0,0 +1,2002 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++TcSplice: Template Haskell splices+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE MultiWayIf #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module TcSplice(+     tcSpliceExpr, tcTypedBracket, tcUntypedBracket,+--     runQuasiQuoteExpr, runQuasiQuotePat,+--     runQuasiQuoteDecl, runQuasiQuoteType,+     runAnnotation,++     runMetaE, runMetaP, runMetaT, runMetaD, runQuasi,+     tcTopSpliceExpr, lookupThName_maybe,+     defaultRunMeta, runMeta', runRemoteModFinalizers,+     finishTH+      ) where++#include "HsVersions.h"++import HsSyn+import Annotations+import Name+import TcRnMonad+import TcType++import Outputable+import TcExpr+import SrcLoc+import THNames+import TcUnify+import TcEnv++import Control.Monad++import GHCi.Message+import GHCi.RemoteTypes+import GHCi+import HscMain+        -- These imports are the reason that TcSplice+        -- is very high up the module hierarchy+import RnSplice( traceSplice, SpliceInfo(..) )+import RdrName+import HscTypes+import Convert+import RnExpr+import RnEnv+import RnTypes+import TcHsSyn+import TcSimplify+import Type+import Kind+import NameSet+import TcMType+import TcHsType+import TcIface+import TyCoRep+import FamInst+import FamInstEnv+import InstEnv+import Inst+import NameEnv+import PrelNames+import TysWiredIn+import OccName+import Hooks+import Var+import Module+import LoadIface+import Class+import TyCon+import CoAxiom+import PatSyn+import ConLike+import DataCon+import TcEvidence( TcEvBinds(..) )+import Id+import IdInfo+import DsExpr+import DsMonad+import GHC.Serialized+import ErrUtils+import Util+import Unique+import VarSet           ( isEmptyVarSet, filterVarSet, mkVarSet, elemVarSet )+import Data.List        ( find )+import Data.Maybe+import FastString+import BasicTypes hiding( SuccessFlag(..) )+import Maybes( MaybeErr(..) )+import DynFlags+import Panic+import Lexeme++import qualified Language.Haskell.TH as TH+-- THSyntax gives access to internal functions and data types+import qualified Language.Haskell.TH.Syntax as TH++-- Because GHC.Desugar might not be in the base library of the bootstrapping compiler+import GHC.Desugar      ( AnnotationWrapper(..) )++import qualified Data.IntSet as IntSet+import Control.Exception+import Data.Binary+import Data.Binary.Get+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB+import Data.Dynamic  ( fromDynamic, toDyn )+import qualified Data.Map as Map+import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep )+import Data.Data (Data)+import Data.Proxy    ( Proxy (..) )+import GHC.Exts         ( unsafeCoerce# )++{-+************************************************************************+*                                                                      *+\subsection{Main interface + stubs for the non-GHCI case+*                                                                      *+************************************************************************+-}++tcTypedBracket   :: HsBracket Name -> ExpRhoType -> TcM (HsExpr TcId)+tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> ExpRhoType -> TcM (HsExpr TcId)+tcSpliceExpr     :: HsSplice Name  -> ExpRhoType -> TcM (HsExpr TcId)+        -- None of these functions add constraints to the LIE++-- runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName)+-- runQuasiQuotePat  :: HsQuasiQuote RdrName -> RnM (LPat RdrName)+-- runQuasiQuoteType :: HsQuasiQuote RdrName -> RnM (LHsType RdrName)+-- runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName]++runAnnotation     :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation+{-+************************************************************************+*                                                                      *+\subsection{Quoting an expression}+*                                                                      *+************************************************************************+-}++-- See Note [How brackets and nested splices are handled]+-- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId)+tcTypedBracket brack@(TExpBr expr) res_ty+  = addErrCtxt (quotationCtxtDoc brack) $+    do { cur_stage <- getStage+       ; ps_ref <- newMutVar []+       ; lie_var <- getConstraintVar   -- Any constraints arising from nested splices+                                       -- should get thrown into the constraint set+                                       -- from outside the bracket++       -- Typecheck expr to make sure it is valid,+       -- Throw away the typechecked expression but return its type.+       -- We'll typecheck it again when we splice it in somewhere+       ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var)) $+                                tcInferRhoNC expr+                                -- NC for no context; tcBracket does that++       ; meta_ty <- tcTExpTy expr_ty+       ; ps' <- readMutVar ps_ref+       ; texpco <- tcLookupId unsafeTExpCoerceName+       ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr")+                       (unLoc (mkHsApp (nlHsTyApp texpco [expr_ty])+                                              (noLoc (HsTcBracketOut brack ps'))))+                       meta_ty res_ty }+tcTypedBracket other_brack _+  = pprPanic "tcTypedBracket" (ppr other_brack)++-- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> ExpRhoType -> TcM (HsExpr TcId)+tcUntypedBracket brack ps res_ty+  = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps)+       ; ps' <- mapM tcPendingSplice ps+       ; meta_ty <- tcBrackTy brack+       ; traceTc "tc_bracket done untyped" (ppr meta_ty)+       ; tcWrapResultO (Shouldn'tHappenOrigin "untyped bracket")+                       (HsTcBracketOut brack ps') meta_ty res_ty }++---------------+tcBrackTy :: HsBracket Name -> TcM TcType+tcBrackTy (VarBr _ _) = tcMetaTy nameTyConName  -- Result type is Var (not Q-monadic)+tcBrackTy (ExpBr _)   = tcMetaTy expQTyConName  -- Result type is ExpQ (= Q Exp)+tcBrackTy (TypBr _)   = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ)+tcBrackTy (DecBrG _)  = tcMetaTy decsQTyConName -- Result type is Q [Dec]+tcBrackTy (PatBr _)   = tcMetaTy patQTyConName  -- Result type is PatQ (= Q Pat)+tcBrackTy (DecBrL _)  = panic "tcBrackTy: Unexpected DecBrL"+tcBrackTy (TExpBr _)  = panic "tcUntypedBracket: Unexpected TExpBr"++---------------+tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice+tcPendingSplice (PendingRnSplice flavour splice_name expr)+  = do { res_ty <- tcMetaTy meta_ty_name+       ; expr' <- tcMonoExpr expr (mkCheckExpType res_ty)+       ; return (PendingTcSplice splice_name expr') }+  where+     meta_ty_name = case flavour of+                       UntypedExpSplice  -> expQTyConName+                       UntypedPatSplice  -> patQTyConName+                       UntypedTypeSplice -> typeQTyConName+                       UntypedDeclSplice -> decsQTyConName++---------------+-- Takes a tau and returns the type Q (TExp tau)+tcTExpTy :: TcType -> TcM TcType+tcTExpTy exp_ty+  = do { unless (isTauTy exp_ty) $ addErr (err_msg exp_ty)+       ; q    <- tcLookupTyCon qTyConName+       ; texp <- tcLookupTyCon tExpTyConName+       ; return (mkTyConApp q [mkTyConApp texp [exp_ty]]) }+  where+    err_msg ty+      = vcat [ text "Illegal polytype:" <+> ppr ty+             , text "The type of a Typed Template Haskell expression must" <+>+               text "not have any quantification." ]++quotationCtxtDoc :: HsBracket Name -> SDoc+quotationCtxtDoc br_body+  = hang (text "In the Template Haskell quotation")+         2 (ppr br_body)+++  -- The whole of the rest of the file is the else-branch (ie stage2 only)++{-+Note [How top-level splices are handled]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Top-level splices (those not inside a [| .. |] quotation bracket) are handled+very straightforwardly:++  1. tcTopSpliceExpr: typecheck the body e of the splice $(e)++  2. runMetaT: desugar, compile, run it, and convert result back to+     HsSyn RdrName (of the appropriate flavour, eg HsType RdrName,+     HsExpr RdrName etc)++  3. treat the result as if that's what you saw in the first place+     e.g for HsType, rename and kind-check+         for HsExpr, rename and type-check++     (The last step is different for decls, because they can *only* be+      top-level: we return the result of step 2.)++Note [How brackets and nested splices are handled]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Nested splices (those inside a [| .. |] quotation bracket),+are treated quite differently.++Remember, there are two forms of bracket+         typed   [|| e ||]+   and untyped   [|  e  |]++The life cycle of a typed bracket:+   * Starts as HsBracket++   * When renaming:+        * Set the ThStage to (Brack s RnPendingTyped)+        * Rename the body+        * Result is still a HsBracket++   * When typechecking:+        * Set the ThStage to (Brack s (TcPending ps_var lie_var))+        * Typecheck the body, and throw away the elaborated result+        * Nested splices (which must be typed) are typechecked, and+          the results accumulated in ps_var; their constraints+          accumulate in lie_var+        * Result is a HsTcBracketOut rn_brack pending_splices+          where rn_brack is the incoming renamed bracket++The life cycle of a un-typed bracket:+   * Starts as HsBracket++   * When renaming:+        * Set the ThStage to (Brack s (RnPendingUntyped ps_var))+        * Rename the body+        * Nested splices (which must be untyped) are renamed, and the+          results accumulated in ps_var+        * Result is still (HsRnBracketOut rn_body pending_splices)++   * When typechecking a HsRnBracketOut+        * Typecheck the pending_splices individually+        * Ignore the body of the bracket; just check that the context+          expects a bracket of that type (e.g. a [p| pat |] bracket should+          be in a context needing a (Q Pat)+        * Result is a HsTcBracketOut rn_brack pending_splices+          where rn_brack is the incoming renamed bracket+++In both cases, desugaring happens like this:+  * HsTcBracketOut is desugared by DsMeta.dsBracket.  It++      a) Extends the ds_meta environment with the PendingSplices+         attached to the bracket++      b) Converts the quoted (HsExpr Name) to a CoreExpr that, when+         run, will produce a suitable TH expression/type/decl.  This+         is why we leave the *renamed* expression attached to the bracket:+         the quoted expression should not be decorated with all the goop+         added by the type checker++  * Each splice carries a unique Name, called a "splice point", thus+    ${n}(e).  The name is initialised to an (Unqual "splice") when the+    splice is created; the renamer gives it a unique.++  * When DsMeta (used to desugar the body of the bracket) comes across+    a splice, it looks up the splice's Name, n, in the ds_meta envt,+    to find an (HsExpr Id) that should be substituted for the splice;+    it just desugars it to get a CoreExpr (DsMeta.repSplice).++Example:+    Source:       f = [| Just $(g 3) |]+      The [| |] part is a HsBracket++    Typechecked:  f = [| Just ${s7}(g 3) |]{s7 = g Int 3}+      The [| |] part is a HsBracketOut, containing *renamed*+        (not typechecked) expression+      The "s7" is the "splice point"; the (g Int 3) part+        is a typechecked expression++    Desugared:    f = do { s7 <- g Int 3+                         ; return (ConE "Data.Maybe.Just" s7) }+++Note [Template Haskell state diagram]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here are the ThStages, s, their corresponding level numbers+(the result of (thLevel s)), and their state transitions.+The top level of the program is stage Comp:++     Start here+         |+         V+      -----------     $      ------------   $+      |  Comp   | ---------> |  Splice  | -----|+      |   1     |            |    0     | <----|+      -----------            ------------+        ^     |                ^      |+      $ |     | [||]         $ |      | [||]+        |     v                |      v+   --------------          ----------------+   | Brack Comp |          | Brack Splice |+   |     2      |          |      1       |+   --------------          ----------------++* Normal top-level declarations start in state Comp+       (which has level 1).+  Annotations start in state Splice, since they are+       treated very like a splice (only without a '$')++* Code compiled in state Splice (and only such code)+  will be *run at compile time*, with the result replacing+  the splice++* The original paper used level -1 instead of 0, etc.++* The original paper did not allow a splice within a+  splice, but there is no reason not to. This is the+  $ transition in the top right.++Note [Template Haskell levels]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* Imported things are impLevel (= 0)++* However things at level 0 are not *necessarily* imported.+      eg  $( \b -> ... )   here b is bound at level 0++* In GHCi, variables bound by a previous command are treated+  as impLevel, because we have bytecode for them.++* Variables are bound at the "current level"++* The current level starts off at outerLevel (= 1)++* The level is decremented by splicing $(..)+               incremented by brackets [| |]+               incremented by name-quoting 'f++When a variable is used, we compare+        bind:  binding level, and+        use:   current level at usage site++  Generally+        bind > use      Always error (bound later than used)+                        [| \x -> $(f x) |]++        bind = use      Always OK (bound same stage as used)+                        [| \x -> $(f [| x |]) |]++        bind < use      Inside brackets, it depends+                        Inside splice, OK+                        Inside neither, OK++  For (bind < use) inside brackets, there are three cases:+    - Imported things   OK      f = [| map |]+    - Top-level things  OK      g = [| f |]+    - Non-top-level     Only if there is a liftable instance+                                h = \(x:Int) -> [| x |]++  To track top-level-ness we use the ThBindEnv in TcLclEnv++  For example:+           f = ...+           g1 = $(map ...)         is OK+           g2 = $(f ...)           is not OK; because we havn't compiled f yet++-}++{-+************************************************************************+*                                                                      *+\subsection{Splicing an expression}+*                                                                      *+************************************************************************+-}++tcSpliceExpr splice@(HsTypedSplice _ name expr) res_ty+  = addErrCtxt (spliceCtxtDoc splice) $+    setSrcSpan (getLoc expr)    $ do+    { stage <- getStage+    ; case stage of+          Splice {}            -> tcTopSplice expr res_ty+          Brack pop_stage pend -> tcNestedSplice pop_stage pend name expr res_ty+          RunSplice _          ->+            -- See Note [RunSplice ThLevel] in "TcRnTypes".+            pprPanic ("tcSpliceExpr: attempted to typecheck a splice when " +++                      "running another splice") (ppr splice)+          Comp                 -> tcTopSplice expr res_ty+    }+tcSpliceExpr splice _+  = pprPanic "tcSpliceExpr" (ppr splice)++{- Note [Collecting modFinalizers in typed splices]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++'qAddModFinalizer' of the @Quasi TcM@ instance adds finalizers in the local+environment (see Note [Delaying modFinalizers in untyped splices] in+"RnSplice"). Thus after executing the splice, we move the finalizers to the+finalizer list in the global environment and set them to use the current local+environment (with 'addModFinalizersWithLclEnv').++-}++tcNestedSplice :: ThStage -> PendingStuff -> Name+                -> LHsExpr Name -> ExpRhoType -> TcM (HsExpr Id)+    -- See Note [How brackets and nested splices are handled]+    -- A splice inside brackets+tcNestedSplice pop_stage (TcPending ps_var lie_var) splice_name expr res_ty+  = do { res_ty <- expTypeToType res_ty+       ; meta_exp_ty <- tcTExpTy res_ty+       ; expr' <- setStage pop_stage $+                  setConstraintVar lie_var $+                  tcMonoExpr expr (mkCheckExpType meta_exp_ty)+       ; untypeq <- tcLookupId unTypeQName+       ; let expr'' = mkHsApp (nlHsTyApp untypeq [res_ty]) expr'+       ; ps <- readMutVar ps_var+       ; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps)++       -- The returned expression is ignored; it's in the pending splices+       ; return (panic "tcSpliceExpr") }++tcNestedSplice _ _ splice_name _ _+  = pprPanic "tcNestedSplice: rename stage found" (ppr splice_name)++tcTopSplice :: LHsExpr Name -> ExpRhoType -> TcM (HsExpr Id)+tcTopSplice expr res_ty+  = do { -- Typecheck the expression,+         -- making sure it has type Q (T res_ty)+         res_ty <- expTypeToType res_ty+       ; meta_exp_ty <- tcTExpTy res_ty+       ; zonked_q_expr <- tcTopSpliceExpr Typed $+                          tcMonoExpr expr (mkCheckExpType meta_exp_ty)++         -- See Note [Collecting modFinalizers in typed splices].+       ; modfinalizers_ref <- newTcRef []+         -- Run the expression+       ; expr2 <- setStage (RunSplice modfinalizers_ref) $+                    runMetaE zonked_q_expr+       ; mod_finalizers <- readTcRef modfinalizers_ref+       ; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers+       ; traceSplice (SpliceInfo { spliceDescription = "expression"+                                 , spliceIsDecl      = False+                                 , spliceSource      = Just expr+                                 , spliceGenerated   = ppr expr2 })++         -- Rename and typecheck the spliced-in expression,+         -- making sure it has type res_ty+         -- These steps should never fail; this is a *typed* splice+       ; addErrCtxt (spliceResultDoc expr) $ do+       { (exp3, _fvs) <- rnLExpr expr2+       ; exp4 <- tcMonoExpr exp3 (mkCheckExpType res_ty)+       ; return (unLoc exp4) } }++{-+************************************************************************+*                                                                      *+\subsection{Error messages}+*                                                                      *+************************************************************************+-}++spliceCtxtDoc :: HsSplice Name -> SDoc+spliceCtxtDoc splice+  = hang (text "In the Template Haskell splice")+         2 (pprSplice splice)++spliceResultDoc :: LHsExpr Name -> SDoc+spliceResultDoc expr+  = sep [ text "In the result of the splice:"+        , nest 2 (char '$' <> ppr expr)+        , text "To see what the splice expanded to, use -ddump-splices"]++-------------------+tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr Id) -> TcM (LHsExpr Id)+-- Note [How top-level splices are handled]+-- Type check an expression that is the body of a top-level splice+--   (the caller will compile and run it)+-- Note that set the level to Splice, regardless of the original level,+-- before typechecking the expression.  For example:+--      f x = $( ...$(g 3) ... )+-- The recursive call to tcPolyExpr will simply expand the+-- inner escape before dealing with the outer one++tcTopSpliceExpr isTypedSplice tc_action+  = checkNoErrs $  -- checkNoErrs: must not try to run the thing+                   -- if the type checker fails!+    unsetGOptM Opt_DeferTypeErrors $+                   -- Don't defer type errors.  Not only are we+                   -- going to run this code, but we do an unsafe+                   -- coerce, so we get a seg-fault if, say we+                   -- splice a type into a place where an expression+                   -- is expected (Trac #7276)+    setStage (Splice isTypedSplice) $+    do {    -- Typecheck the expression+         (expr', wanted) <- captureConstraints tc_action+       ; const_binds     <- simplifyTop wanted++          -- Zonk it and tie the knot of dictionary bindings+       ; zonkTopLExpr (mkHsDictLet (EvBinds const_binds) expr') }++{-+************************************************************************+*                                                                      *+        Annotations+*                                                                      *+************************************************************************+-}++runAnnotation target expr = do+    -- Find the classes we want instances for in order to call toAnnotationWrapper+    loc <- getSrcSpanM+    data_class <- tcLookupClass dataClassName+    to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName++    -- Check the instances we require live in another module (we want to execute it..)+    -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr+    -- also resolves the LIE constraints to detect e.g. instance ambiguity+    zonked_wrapped_expr' <- tcTopSpliceExpr Untyped $+           do { (expr', expr_ty) <- tcInferRhoNC expr+                -- We manually wrap the typechecked expression in a call to toAnnotationWrapper+                -- By instantiating the call >here< it gets registered in the+                -- LIE consulted by tcTopSpliceExpr+                -- and hence ensures the appropriate dictionary is bound by const_binds+              ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]+              ; let specialised_to_annotation_wrapper_expr+                      = L loc (HsWrap wrapper+                                      (HsVar (L loc to_annotation_wrapper_id)))+              ; return (L loc (HsApp specialised_to_annotation_wrapper_expr expr')) }++    -- Run the appropriately wrapped expression to get the value of+    -- the annotation and its dictionaries. The return value is of+    -- type AnnotationWrapper by construction, so this conversion is+    -- safe+    serialized <- runMetaAW zonked_wrapped_expr'+    return Annotation {+               ann_target = target,+               ann_value = serialized+           }++convertAnnotationWrapper :: ForeignHValue -> TcM (Either MsgDoc Serialized)+convertAnnotationWrapper fhv = do+  dflags <- getDynFlags+  if gopt Opt_ExternalInterpreter dflags+    then do+      Right <$> runTH THAnnWrapper fhv+    else do+      annotation_wrapper <- liftIO $ wormhole dflags fhv+      return $ Right $+        case unsafeCoerce# annotation_wrapper of+           AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->+               -- Got the value and dictionaries: build the serialized value and+               -- call it a day. We ensure that we seq the entire serialized value+               -- in order that any errors in the user-written code for the+               -- annotation are exposed at this point.  This is also why we are+               -- doing all this stuff inside the context of runMeta: it has the+               -- facilities to deal with user error in a meta-level expression+               seqSerialized serialized `seq` serialized++-- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms+seqSerialized :: Serialized -> ()+seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` ()+++{-+************************************************************************+*                                                                      *+\subsection{Running an expression}+*                                                                      *+************************************************************************+-}++runQuasi :: TH.Q a -> TcM a+runQuasi act = TH.runQ act++runRemoteModFinalizers :: ThModFinalizers -> TcM ()+runRemoteModFinalizers (ThModFinalizers finRefs) = do+  dflags <- getDynFlags+  let withForeignRefs [] f = f []+      withForeignRefs (x : xs) f = withForeignRef x $ \r ->+        withForeignRefs xs $ \rs -> f (r : rs)+  if gopt Opt_ExternalInterpreter dflags then do+    hsc_env <- env_top <$> getEnv+    withIServ hsc_env $ \i -> do+      tcg <- getGblEnv+      th_state <- readTcRef (tcg_th_remote_state tcg)+      case th_state of+        Nothing -> return () -- TH was not started, nothing to do+        Just fhv -> do+          liftIO $ withForeignRef fhv $ \st ->+            withForeignRefs finRefs $ \qrefs ->+              writeIServ i (putMessage (RunModFinalizers st qrefs))+          () <- runRemoteTH i []+          readQResult i+  else do+    qs <- liftIO (withForeignRefs finRefs $ mapM localRef)+    runQuasi $ sequence_ qs++runQResult+  :: (a -> String)+  -> (SrcSpan -> a -> b)+  -> (ForeignHValue -> TcM a)+  -> SrcSpan+  -> ForeignHValue {- TH.Q a -}+  -> TcM b+runQResult show_th f runQ expr_span hval+  = do { th_result <- runQ hval+       ; traceTc "Got TH result:" (text (show_th th_result))+       ; return (f expr_span th_result) }+++-----------------+runMeta :: (MetaHook TcM -> LHsExpr Id -> TcM hs_syn)+        -> LHsExpr Id+        -> TcM hs_syn+runMeta unwrap e+  = do { h <- getHooked runMetaHook defaultRunMeta+       ; unwrap h e }++defaultRunMeta :: MetaHook TcM+defaultRunMeta (MetaE r)+  = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsExpr runTHExp)+defaultRunMeta (MetaP r)+  = fmap r . runMeta' True ppr (runQResult TH.pprint convertToPat runTHPat)+defaultRunMeta (MetaT r)+  = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsType runTHType)+defaultRunMeta (MetaD r)+  = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls runTHDec)+defaultRunMeta (MetaAW r)+  = fmap r . runMeta' False (const empty) (const convertAnnotationWrapper)+    -- We turn off showing the code in meta-level exceptions because doing so exposes+    -- the toAnnotationWrapper function that we slap around the user's code++----------------+runMetaAW :: LHsExpr Id         -- Of type AnnotationWrapper+          -> TcM Serialized+runMetaAW = runMeta metaRequestAW++runMetaE :: LHsExpr Id          -- Of type (Q Exp)+         -> TcM (LHsExpr RdrName)+runMetaE = runMeta metaRequestE++runMetaP :: LHsExpr Id          -- Of type (Q Pat)+         -> TcM (LPat RdrName)+runMetaP = runMeta metaRequestP++runMetaT :: LHsExpr Id          -- Of type (Q Type)+         -> TcM (LHsType RdrName)+runMetaT = runMeta metaRequestT++runMetaD :: LHsExpr Id          -- Of type Q [Dec]+         -> TcM [LHsDecl RdrName]+runMetaD = runMeta metaRequestD++---------------+runMeta' :: Bool                 -- Whether code should be printed in the exception message+         -> (hs_syn -> SDoc)                                    -- how to print the code+         -> (SrcSpan -> ForeignHValue -> TcM (Either MsgDoc hs_syn))        -- How to run x+         -> LHsExpr Id           -- Of type x; typically x = Q TH.Exp, or something like that+         -> TcM hs_syn           -- Of type t+runMeta' show_code ppr_hs run_and_convert expr+  = do  { traceTc "About to run" (ppr expr)+        ; recordThSpliceUse -- seems to be the best place to do this,+                            -- we catch all kinds of splices and annotations.++        -- Check that we've had no errors of any sort so far.+        -- For example, if we found an error in an earlier defn f, but+        -- recovered giving it type f :: forall a.a, it'd be very dodgy+        -- to carry ont.  Mind you, the staging restrictions mean we won't+        -- actually run f, but it still seems wrong. And, more concretely,+        -- see Trac #5358 for an example that fell over when trying to+        -- reify a function with a "?" kind in it.  (These don't occur+        -- in type-correct programs.+        ; failIfErrsM++        -- Desugar+        ; ds_expr <- initDsTc (dsLExpr expr)+        -- Compile and link it; might fail if linking fails+        ; hsc_env <- getTopEnv+        ; src_span <- getSrcSpanM+        ; traceTc "About to run (desugared)" (ppr ds_expr)+        ; either_hval <- tryM $ liftIO $+                         HscMain.hscCompileCoreExpr hsc_env src_span ds_expr+        ; case either_hval of {+            Left exn   -> fail_with_exn "compile and link" exn ;+            Right hval -> do++        {       -- Coerce it to Q t, and run it++                -- Running might fail if it throws an exception of any kind (hence tryAllM)+                -- including, say, a pattern-match exception in the code we are running+                --+                -- We also do the TH -> HS syntax conversion inside the same+                -- exception-cacthing thing so that if there are any lurking+                -- exceptions in the data structure returned by hval, we'll+                -- encounter them inside the try+                --+                -- See Note [Exceptions in TH]+          let expr_span = getLoc expr+        ; either_tval <- tryAllM $+                         setSrcSpan expr_span $ -- Set the span so that qLocation can+                                                -- see where this splice is+             do { mb_result <- run_and_convert expr_span hval+                ; case mb_result of+                    Left err     -> failWithTc err+                    Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result)+                                       ; return $! result } }++        ; case either_tval of+            Right v -> return v+            Left se -> case fromException se of+                         Just IOEnvFailure -> failM -- Error already in Tc monad+                         _ -> fail_with_exn "run" se -- Exception+        }}}+  where+    -- see Note [Concealed TH exceptions]+    fail_with_exn :: Exception e => String -> e -> TcM a+    fail_with_exn phase exn = do+        exn_msg <- liftIO $ Panic.safeShowException exn+        let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:",+                        nest 2 (text exn_msg),+                        if show_code then text "Code:" <+> ppr expr else empty]+        failWithTc msg++{-+Note [Exceptions in TH]+~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have something like this+        $( f 4 )+where+        f :: Int -> Q [Dec]+        f n | n>3       = fail "Too many declarations"+            | otherwise = ...++The 'fail' is a user-generated failure, and should be displayed as a+perfectly ordinary compiler error message, not a panic or anything+like that.  Here's how it's processed:++  * 'fail' is the monad fail.  The monad instance for Q in TH.Syntax+    effectively transforms (fail s) to+        qReport True s >> fail+    where 'qReport' comes from the Quasi class and fail from its monad+    superclass.++  * The TcM monad is an instance of Quasi (see TcSplice), and it implements+    (qReport True s) by using addErr to add an error message to the bag of errors.+    The 'fail' in TcM raises an IOEnvFailure exception++ * 'qReport' forces the message to ensure any exception hidden in unevaluated+   thunk doesn't get into the bag of errors. Otherwise the following splice+   will triger panic (Trac #8987):+        $(fail undefined)+   See also Note [Concealed TH exceptions]++  * So, when running a splice, we catch all exceptions; then for+        - an IOEnvFailure exception, we assume the error is already+                in the error-bag (above)+        - other errors, we add an error to the bag+    and then fail++Note [Concealed TH exceptions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When displaying the error message contained in an exception originated from TH+code, we need to make sure that the error message itself does not contain an+exception.  For example, when executing the following splice:++    $( error ("foo " ++ error "bar") )++the message for the outer exception is a thunk which will throw the inner+exception when evaluated.++For this reason, we display the message of a TH exception using the+'safeShowException' function, which recursively catches any exception thrown+when showing an error message.+++To call runQ in the Tc monad, we need to make TcM an instance of Quasi:+-}++instance TH.Quasi TcM where+  qNewName s = do { u <- newUnique+                  ; let i = getKey u+                  ; return (TH.mkNameU s i) }++  -- 'msg' is forced to ensure exceptions don't escape,+  -- see Note [Exceptions in TH]+  qReport True msg  = seqList msg $ addErr  (text msg)+  qReport False msg = seqList msg $ addWarn NoReason (text msg)++  qLocation = do { m <- getModule+                 ; l <- getSrcSpanM+                 ; r <- case l of+                        UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"+                                                    (ppr l)+                        RealSrcSpan s -> return s+                 ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)+                                  , TH.loc_module   = moduleNameString (moduleName m)+                                  , TH.loc_package  = unitIdString (moduleUnitId m)+                                  , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)+                                  , TH.loc_end = (srcSpanEndLine   r, srcSpanEndCol   r) }) }++  qLookupName       = lookupName+  qReify            = reify+  qReifyFixity nm   = lookupThName nm >>= reifyFixity+  qReifyInstances   = reifyInstances+  qReifyRoles       = reifyRoles+  qReifyAnnotations = reifyAnnotations+  qReifyModule      = reifyModule+  qReifyConStrictness nm = do { nm' <- lookupThName nm+                              ; dc  <- tcLookupDataCon nm'+                              ; let bangs = dataConImplBangs dc+                              ; return (map reifyDecidedStrictness bangs) }++        -- For qRecover, discard error messages if+        -- the recovery action is chosen.  Otherwise+        -- we'll only fail higher up.+  qRecover recover main = tryTcDiscardingErrs recover main+  qRunIO io = liftIO io++  qAddDependentFile fp = do+    ref <- fmap tcg_dependent_files getGblEnv+    dep_files <- readTcRef ref+    writeTcRef ref (fp:dep_files)++  qAddTopDecls thds = do+      l <- getSrcSpanM+      let either_hval = convertToHsDecls l thds+      ds <- case either_hval of+              Left exn -> pprPanic "qAddTopDecls: can't convert top-level declarations" exn+              Right ds -> return ds+      mapM_ (checkTopDecl . unLoc) ds+      th_topdecls_var <- fmap tcg_th_topdecls getGblEnv+      updTcRef th_topdecls_var (\topds -> ds ++ topds)+    where+      checkTopDecl :: HsDecl RdrName -> TcM ()+      checkTopDecl (ValD binds)+        = mapM_ bindName (collectHsBindBinders binds)+      checkTopDecl (SigD _)+        = return ()+      checkTopDecl (AnnD _)+        = return ()+      checkTopDecl (ForD (ForeignImport { fd_name = L _ name }))+        = bindName name+      checkTopDecl _+        = addErr $ text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl"++      bindName :: RdrName -> TcM ()+      bindName (Exact n)+        = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv+             ; updTcRef th_topnames_var (\ns -> extendNameSet ns n)+             }++      bindName name =+          addErr $+          hang (text "The binder" <+> quotes (ppr name) <+> ptext (sLit "is not a NameU."))+             2 (text "Probable cause: you used mkName instead of newName to generate a binding.")++  qAddForeignFile lang str = do+    var <- fmap tcg_th_foreign_files getGblEnv+    updTcRef var ((lang, str) :)++  qAddModFinalizer fin = do+      r <- liftIO $ mkRemoteRef fin+      fref <- liftIO $ mkForeignRef r (freeRemoteRef r)+      addModFinalizerRef fref++  qGetQ :: forall a. Typeable a => TcM (Maybe a)+  qGetQ = do+      th_state_var <- fmap tcg_th_state getGblEnv+      th_state <- readTcRef th_state_var+      -- See #10596 for why we use a scoped type variable here.+      return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic)++  qPutQ x = do+      th_state_var <- fmap tcg_th_state getGblEnv+      updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m)++  qIsExtEnabled = xoptM++  qExtsEnabled = do+    dflags <- hsc_dflags <$> getTopEnv+    return $ map toEnum $ IntSet.elems $ extensionFlags dflags++-- | Adds a mod finalizer reference to the local environment.+addModFinalizerRef :: ForeignRef (TH.Q ()) -> TcM ()+addModFinalizerRef finRef = do+    th_stage <- getStage+    case th_stage of+      RunSplice th_modfinalizers_var -> updTcRef th_modfinalizers_var (finRef :)+      -- This case happens only if a splice is executed and the caller does+      -- not set the 'ThStage' to 'RunSplice' to collect finalizers.+      -- See Note [Delaying modFinalizers in untyped splices] in RnSplice.+      _ ->+        pprPanic "addModFinalizer was called when no finalizers were collected"+                 (ppr th_stage)++-- | Releases the external interpreter state.+finishTH :: TcM ()+finishTH = do+  dflags <- getDynFlags+  when (gopt Opt_ExternalInterpreter dflags) $ do+    tcg <- getGblEnv+    writeTcRef (tcg_th_remote_state tcg) Nothing++runTHExp :: ForeignHValue -> TcM TH.Exp+runTHExp = runTH THExp++runTHPat :: ForeignHValue -> TcM TH.Pat+runTHPat = runTH THPat++runTHType :: ForeignHValue -> TcM TH.Type+runTHType = runTH THType++runTHDec :: ForeignHValue -> TcM [TH.Dec]+runTHDec = runTH THDec++runTH :: Binary a => THResultType -> ForeignHValue -> TcM a+runTH ty fhv = do+  hsc_env <- env_top <$> getEnv+  dflags <- getDynFlags+  if not (gopt Opt_ExternalInterpreter dflags)+    then do+       -- Run it in the local TcM+      hv <- liftIO $ wormhole dflags fhv+      r <- runQuasi (unsafeCoerce# hv :: TH.Q a)+      return r+    else+      -- Run it on the server.  For an overview of how TH works with+      -- Remote GHCi, see Note [Remote Template Haskell] in+      -- libraries/ghci/GHCi/TH.hs.+      withIServ hsc_env $ \i -> do+        rstate <- getTHState i+        loc <- TH.qLocation+        liftIO $+          withForeignRef rstate $ \state_hv ->+          withForeignRef fhv $ \q_hv ->+            writeIServ i (putMessage (RunTH state_hv q_hv ty (Just loc)))+        runRemoteTH i []+        bs <- readQResult i+        return $! runGet get (LB.fromStrict bs)+++-- | communicate with a remotely-running TH computation until it finishes.+-- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs.+runRemoteTH+  :: IServ+  -> [Messages]   --  saved from nested calls to qRecover+  -> TcM ()+runRemoteTH iserv recovers = do+  THMsg msg <- liftIO $ readIServ iserv getTHMessage+  case msg of+    RunTHDone -> return ()+    StartRecover -> do -- Note [TH recover with -fexternal-interpreter]+      v <- getErrsVar+      msgs <- readTcRef v+      writeTcRef v emptyMessages+      runRemoteTH iserv (msgs : recovers)+    EndRecover caught_error -> do+      v <- getErrsVar+      let (prev_msgs, rest) = case recovers of+             [] -> panic "EndRecover"+             a : b -> (a,b)+      if caught_error+        then writeTcRef v prev_msgs+        else updTcRef v (unionMessages prev_msgs)+      runRemoteTH iserv rest+    _other -> do+      r <- handleTHMessage msg+      liftIO $ writeIServ iserv (put r)+      runRemoteTH iserv recovers++-- | Read a value of type QResult from the iserv+readQResult :: Binary a => IServ -> TcM a+readQResult i = do+  qr <- liftIO $ readIServ i get+  case qr of+    QDone a -> return a+    QException str -> liftIO $ throwIO (ErrorCall str)+    QFail str -> fail str++{- Note [TH recover with -fexternal-interpreter]++Recover is slightly tricky to implement.++The meaning of "recover a b" is+ - Do a+   - If it finished successfully, then keep the messages it generated+   - If it failed, discard any messages it generated, and do b++The messages are managed by GHC in the TcM monad, whereas the+exception-handling is done in the ghc-iserv process, so we have to+coordinate between the two.++On the server:+  - emit a StartRecover message+  - run "a" inside a catch+    - if it finishes, emit EndRecover False+    - if it fails, emit EndRecover True, then run "b"++Back in GHC, when we receive:++  StartRecover+    save the current messages and start with an empty set.+  EndRecover caught_error+    Restore the previous messages,+    and merge in the new messages if caught_error is false.+-}++-- | Retrieve (or create, if it hasn't been created already), the+-- remote TH state.  The TH state is a remote reference to an IORef+-- QState living on the server, and we have to pass this to each RunTH+-- call we make.+--+-- The TH state is stored in tcg_th_remote_state in the TcGblEnv.+--+getTHState :: IServ -> TcM (ForeignRef (IORef QState))+getTHState i = do+  tcg <- getGblEnv+  th_state <- readTcRef (tcg_th_remote_state tcg)+  case th_state of+    Just rhv -> return rhv+    Nothing -> do+      hsc_env <- env_top <$> getEnv+      fhv <- liftIO $ mkFinalizedHValue hsc_env =<< iservCall i StartTH+      writeTcRef (tcg_th_remote_state tcg) (Just fhv)+      return fhv++wrapTHResult :: TcM a -> TcM (THResult a)+wrapTHResult tcm = do+  e <- tryM tcm   -- only catch 'fail', treat everything else as catastrophic+  case e of+    Left e -> return (THException (show e))+    Right a -> return (THComplete a)++handleTHMessage :: THMessage a -> TcM a+handleTHMessage msg = case msg of+  NewName a -> wrapTHResult $ TH.qNewName a+  Report b str -> wrapTHResult $ TH.qReport b str+  LookupName b str -> wrapTHResult $ TH.qLookupName b str+  Reify n -> wrapTHResult $ TH.qReify n+  ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n+  ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts+  ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n+  ReifyAnnotations lookup tyrep ->+    wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep)+  ReifyModule m -> wrapTHResult $ TH.qReifyModule m+  ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm+  AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f+  AddModFinalizer r -> do+    hsc_env <- env_top <$> getEnv+    wrapTHResult $ liftIO (mkFinalizedHValue hsc_env r) >>= addModFinalizerRef+  AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs+  AddForeignFile lang str -> wrapTHResult $ TH.qAddForeignFile lang str+  IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext+  ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled+  _ -> panic ("handleTHMessage: unexpected message " ++ show msg)++getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [[Word8]]+getAnnotationsByTypeRep th_name tyrep+  = do { name <- lookupThAnnLookup th_name+       ; topEnv <- getTopEnv+       ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing+       ; tcg <- getGblEnv+       ; let selectedEpsHptAnns = findAnnsByTypeRep epsHptAnns name tyrep+       ; let selectedTcgAnns = findAnnsByTypeRep (tcg_ann_env tcg) name tyrep+       ; return (selectedEpsHptAnns ++ selectedTcgAnns) }++{-+************************************************************************+*                                                                      *+            Instance Testing+*                                                                      *+************************************************************************+-}++reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec]+reifyInstances th_nm th_tys+   = addErrCtxt (text "In the argument of reifyInstances:"+                 <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $+     do { loc <- getSrcSpanM+        ; rdr_ty <- cvt loc (mkThAppTs (TH.ConT th_nm) th_tys)+          -- #9262 says to bring vars into scope, like in HsForAllTy case+          -- of rnHsTyKi+        ; free_vars <- extractHsTyRdrTyVars rdr_ty+        ; let tv_rdrs = freeKiTyVarsAllVars free_vars+          -- Rename  to HsType Name+        ; ((tv_names, rn_ty), _fvs)+            <- bindLRdrNames tv_rdrs $ \ tv_names ->+               do { (rn_ty, fvs) <- rnLHsType doc rdr_ty+                  ; return ((tv_names, rn_ty), fvs) }+        ; (_tvs, ty)+            <- solveEqualities $+               tcImplicitTKBndrsType tv_names $+               fst <$> tcLHsType rn_ty+        ; ty <- zonkTcTypeToType emptyZonkEnv ty+                -- Substitute out the meta type variables+                -- In particular, the type might have kind+                -- variables inside it (Trac #7477)++        ; traceTc "reifyInstances" (ppr ty $$ ppr (typeKind ty))+        ; case splitTyConApp_maybe ty of   -- This expands any type synonyms+            Just (tc, tys)                 -- See Trac #7910+               | Just cls <- tyConClass_maybe tc+               -> do { inst_envs <- tcGetInstEnvs+                     ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys+                     ; traceTc "reifyInstances1" (ppr matches)+                     ; reifyClassInstances cls (map fst matches ++ unifies) }+               | isOpenFamilyTyCon tc+               -> do { inst_envs <- tcGetFamInstEnvs+                     ; let matches = lookupFamInstEnv inst_envs tc tys+                     ; traceTc "reifyInstances2" (ppr matches)+                     ; reifyFamilyInstances tc (map fim_instance matches) }+            _  -> bale_out (hang (text "reifyInstances:" <+> quotes (ppr ty))+                               2 (text "is not a class constraint or type family application")) }+  where+    doc = ClassInstanceCtx+    bale_out msg = failWithTc msg++    cvt :: SrcSpan -> TH.Type -> TcM (LHsType RdrName)+    cvt loc th_ty = case convertToHsType loc th_ty of+                      Left msg -> failWithTc msg+                      Right ty -> return ty++{-+************************************************************************+*                                                                      *+                        Reification+*                                                                      *+************************************************************************+-}++lookupName :: Bool      -- True  <=> type namespace+                        -- False <=> value namespace+           -> String -> TcM (Maybe TH.Name)+lookupName is_type_name s+  = do { lcl_env <- getLocalRdrEnv+       ; case lookupLocalRdrEnv lcl_env rdr_name of+           Just n  -> return (Just (reifyName n))+           Nothing -> do { mb_nm <- lookupGlobalOccRn_maybe rdr_name+                         ; return (fmap reifyName mb_nm) } }+  where+    th_name = TH.mkName s       -- Parses M.x into a base of 'x' and a module of 'M'++    occ_fs :: FastString+    occ_fs = mkFastString (TH.nameBase th_name)++    occ :: OccName+    occ | is_type_name+        = if isLexVarSym occ_fs || isLexCon occ_fs+                             then mkTcOccFS    occ_fs+                             else mkTyVarOccFS occ_fs+        | otherwise+        = if isLexCon occ_fs then mkDataOccFS occ_fs+                             else mkVarOccFS  occ_fs++    rdr_name = case TH.nameModule th_name of+                 Nothing  -> mkRdrUnqual occ+                 Just mod -> mkRdrQual (mkModuleName mod) occ++getThing :: TH.Name -> TcM TcTyThing+getThing th_name+  = do  { name <- lookupThName th_name+        ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)+        ; tcLookupTh name }+        -- ToDo: this tcLookup could fail, which would give a+        --       rather unhelpful error message+  where+    ppr_ns (TH.Name _ (TH.NameG TH.DataName  _pkg _mod)) = text "data"+    ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"+    ppr_ns (TH.Name _ (TH.NameG TH.VarName   _pkg _mod)) = text "var"+    ppr_ns _ = panic "reify/ppr_ns"++reify :: TH.Name -> TcM TH.Info+reify th_name+  = do  { traceTc "reify 1" (text (TH.showName th_name))+        ; thing <- getThing th_name+        ; traceTc "reify 2" (ppr thing)+        ; reifyThing thing }++lookupThName :: TH.Name -> TcM Name+lookupThName th_name = do+    mb_name <- lookupThName_maybe th_name+    case mb_name of+        Nothing   -> failWithTc (notInScope th_name)+        Just name -> return name++lookupThName_maybe :: TH.Name -> TcM (Maybe Name)+lookupThName_maybe th_name+  =  do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)+          -- Pick the first that works+          -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A+        ; return (listToMaybe names) }+  where+    lookup rdr_name+        = do {  -- Repeat much of lookupOccRn, because we want+                -- to report errors in a TH-relevant way+             ; rdr_env <- getLocalRdrEnv+             ; case lookupLocalRdrEnv rdr_env rdr_name of+                 Just name -> return (Just name)+                 Nothing   -> lookupGlobalOccRn_maybe rdr_name }++tcLookupTh :: Name -> TcM TcTyThing+-- This is a specialised version of TcEnv.tcLookup; specialised mainly in that+-- it gives a reify-related error message on failure, whereas in the normal+-- tcLookup, failure is a bug.+tcLookupTh name+  = do  { (gbl_env, lcl_env) <- getEnvs+        ; case lookupNameEnv (tcl_env lcl_env) name of {+                Just thing -> return thing;+                Nothing    ->++          case lookupNameEnv (tcg_type_env gbl_env) name of {+                Just thing -> return (AGlobal thing);+                Nothing    ->++          -- EZY: I don't think this choice matters, no TH in signatures!+          if nameIsLocalOrFrom (tcg_semantic_mod gbl_env) name+          then  -- It's defined in this module+                failWithTc (notInEnv name)++          else+     do { mb_thing <- tcLookupImported_maybe name+        ; case mb_thing of+            Succeeded thing -> return (AGlobal thing)+            Failed msg      -> failWithTc msg+    }}}}++notInScope :: TH.Name -> SDoc+notInScope th_name = quotes (text (TH.pprint th_name)) <+>+                     text "is not in scope at a reify"+        -- Ugh! Rather an indirect way to display the name++notInEnv :: Name -> SDoc+notInEnv name = quotes (ppr name) <+>+                     text "is not in the type environment at a reify"++------------------------------+reifyRoles :: TH.Name -> TcM [TH.Role]+reifyRoles th_name+  = do { thing <- getThing th_name+       ; case thing of+           AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc))+           _ -> failWithTc (text "No roles associated with" <+> (ppr thing))+       }+  where+    reify_role Nominal          = TH.NominalR+    reify_role Representational = TH.RepresentationalR+    reify_role Phantom          = TH.PhantomR++------------------------------+reifyThing :: TcTyThing -> TcM TH.Info+-- The only reason this is monadic is for error reporting,+-- which in turn is mainly for the case when TH can't express+-- some random GHC extension++reifyThing (AGlobal (AnId id))+  = do  { ty <- reifyType (idType id)+        ; let v = reifyName id+        ; case idDetails id of+            ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls))+            RecSelId{sel_tycon=RecSelData tc}+                          -> return (TH.VarI (reifySelector id tc) ty Nothing)+            _             -> return (TH.VarI     v ty Nothing)+    }++reifyThing (AGlobal (ATyCon tc))   = reifyTyCon tc+reifyThing (AGlobal (AConLike (RealDataCon dc)))+  = do  { let name = dataConName dc+        ; ty <- reifyType (idType (dataConWrapId dc))+        ; return (TH.DataConI (reifyName name) ty+                              (reifyName (dataConOrigTyCon dc)))+        }++reifyThing (AGlobal (AConLike (PatSynCon ps)))+  = do { let name = reifyName ps+       ; ty <- reifyPatSynType (patSynSig ps)+       ; return (TH.PatSynI name ty) }++reifyThing (ATcId {tct_id = id})+  = do  { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even+                                        -- though it may be incomplete+        ; ty2 <- reifyType ty1+        ; return (TH.VarI (reifyName id) ty2 Nothing) }++reifyThing (ATyVar tv tv1)+  = do { ty1 <- zonkTcTyVar tv1+       ; ty2 <- reifyType ty1+       ; return (TH.TyVarI (reifyName tv) ty2) }++reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing)++-------------------------------------------+reifyAxBranch :: TyCon -> CoAxBranch -> TcM TH.TySynEqn+reifyAxBranch fam_tc (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs })+            -- remove kind patterns (#8884)+  = do { let lhs_types_only = filterOutInvisibleTypes fam_tc lhs+       ; lhs' <- reifyTypes lhs_types_only+       ; annot_th_lhs <- zipWith3M annotThType (mkIsPolyTvs fam_tvs)+                                   lhs_types_only lhs'+       ; rhs'  <- reifyType rhs+       ; return (TH.TySynEqn annot_th_lhs rhs') }+  where+    fam_tvs = filterOutInvisibleTyVars fam_tc (tyConTyVars fam_tc)++reifyTyCon :: TyCon -> TcM TH.Info+reifyTyCon tc+  | Just cls <- tyConClass_maybe tc+  = reifyClass cls++  | isFunTyCon tc+  = return (TH.PrimTyConI (reifyName tc) 2                False)++  | isPrimTyCon tc+  = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnliftedTyCon tc))++  | isTypeFamilyTyCon tc+  = do { let tvs      = tyConTyVars tc+             res_kind = tyConResKind tc+             resVar   = famTcResVar tc++       ; kind' <- reifyKind res_kind+       ; let (resultSig, injectivity) =+                 case resVar of+                   Nothing   -> (TH.KindSig kind', Nothing)+                   Just name ->+                     let thName   = reifyName name+                         injAnnot = familyTyConInjectivityInfo tc+                         sig = TH.TyVarSig (TH.KindedTV thName kind')+                         inj = case injAnnot of+                                 NotInjective -> Nothing+                                 Injective ms ->+                                     Just (TH.InjectivityAnn thName injRHS)+                                   where+                                     injRHS = map (reifyName . tyVarName)+                                                  (filterByList ms tvs)+                     in (sig, inj)+       ; tvs' <- reifyTyVars tvs (Just tc)+       ; let tfHead =+               TH.TypeFamilyHead (reifyName tc) tvs' resultSig injectivity+       ; if isOpenTypeFamilyTyCon tc+         then do { fam_envs <- tcGetFamInstEnvs+                 ; instances <- reifyFamilyInstances tc+                                  (familyInstances fam_envs tc)+                 ; return (TH.FamilyI (TH.OpenTypeFamilyD tfHead) instances) }+         else do { eqns <-+                     case isClosedSynFamilyTyConWithAxiom_maybe tc of+                       Just ax -> mapM (reifyAxBranch tc) $+                                  fromBranches $ coAxiomBranches ax+                       Nothing -> return []+                 ; return (TH.FamilyI (TH.ClosedTypeFamilyD tfHead eqns)+                      []) } }++  | isDataFamilyTyCon tc+  = do { let tvs      = tyConTyVars tc+             res_kind = tyConResKind tc++       ; kind' <- fmap Just (reifyKind res_kind)++       ; tvs' <- reifyTyVars tvs (Just tc)+       ; fam_envs <- tcGetFamInstEnvs+       ; instances <- reifyFamilyInstances tc (familyInstances fam_envs tc)+       ; return (TH.FamilyI+                       (TH.DataFamilyD (reifyName tc) tvs' kind') instances) }++  | Just (tvs, rhs) <- synTyConDefn_maybe tc  -- Vanilla type synonym+  = do { rhs' <- reifyType rhs+       ; tvs' <- reifyTyVars tvs (Just tc)+       ; return (TH.TyConI+                   (TH.TySynD (reifyName tc) tvs' rhs'))+       }++  | otherwise+  = do  { cxt <- reifyCxt (tyConStupidTheta tc)+        ; let tvs      = tyConTyVars tc+              dataCons = tyConDataCons tc+              -- see Note [Reifying GADT data constructors]+              isGadt   = any (not . null . dataConEqSpec) dataCons+        ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons+        ; r_tvs <- reifyTyVars tvs (Just tc)+        ; let name = reifyName tc+              deriv = []        -- Don't know about deriving+              decl | isNewTyCon tc =+                       TH.NewtypeD cxt name r_tvs Nothing (head cons) deriv+                   | otherwise     =+                       TH.DataD    cxt name r_tvs Nothing       cons  deriv+        ; return (TH.TyConI decl) }++reifyDataCon :: Bool -> [Type] -> DataCon -> TcM TH.Con+-- For GADTs etc, see Note [Reifying GADT data constructors]+reifyDataCon isGadtDataCon tys dc+  = do { let -- used for H98 data constructors+             (ex_tvs, theta, arg_tys)+                 = dataConInstSig dc tys+             -- used for GADTs data constructors+             (g_univ_tvs, g_ex_tvs, g_eq_spec, g_theta, g_arg_tys, g_res_ty)+                 = dataConFullSig dc+             (srcUnpks, srcStricts)+                 = mapAndUnzip reifySourceBang (dataConSrcBangs dc)+             dcdBangs  = zipWith TH.Bang srcUnpks srcStricts+             fields    = dataConFieldLabels dc+             name      = reifyName dc+             -- Universal tvs present in eq_spec need to be filtered out, as+             -- they will not appear anywhere in the type.+             eq_spec_tvs = mkVarSet (map eqSpecTyVar g_eq_spec)+             g_unsbst_univ_tvs = filterOut (`elemVarSet` eq_spec_tvs) g_univ_tvs++       ; r_arg_tys <- reifyTypes (if isGadtDataCon then g_arg_tys else arg_tys)++       ; main_con <-+           if | not (null fields) && not isGadtDataCon ->+                  return $ TH.RecC name (zip3 (map reifyFieldLabel fields)+                                         dcdBangs r_arg_tys)+              | not (null fields) -> do+                  { res_ty <- reifyType g_res_ty+                  ; return $ TH.RecGadtC [name]+                                     (zip3 (map (reifyName . flSelector) fields)+                                      dcdBangs r_arg_tys) res_ty }+                -- We need to check not isGadtDataCon here because GADT+                -- constructors can be declared infix.+                -- See Note [Infix GADT constructors] in TcTyClsDecls.+              | dataConIsInfix dc && not isGadtDataCon ->+                  ASSERT( length arg_tys == 2 ) do+                  { let [r_a1, r_a2] = r_arg_tys+                        [s1,   s2]   = dcdBangs+                  ; return $ TH.InfixC (s1,r_a1) name (s2,r_a2) }+              | isGadtDataCon -> do+                  { res_ty <- reifyType g_res_ty+                  ; return $ TH.GadtC [name] (dcdBangs `zip` r_arg_tys) res_ty }+              | otherwise ->+                  return $ TH.NormalC name (dcdBangs `zip` r_arg_tys)++       ; let (ex_tvs', theta') | isGadtDataCon = ( g_unsbst_univ_tvs ++ g_ex_tvs+                                                 , g_theta )+                               | otherwise     = ( ex_tvs, theta )+             ret_con | null ex_tvs' && null theta' = return main_con+                     | otherwise                   = do+                         { cxt <- reifyCxt theta'+                         ; ex_tvs'' <- reifyTyVars ex_tvs' Nothing+                         ; return (TH.ForallC ex_tvs'' cxt main_con) }+       ; ASSERT( length arg_tys == length dcdBangs )+         ret_con }++-- Note [Reifying GADT data constructors]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- At this point in the compilation pipeline we have no way of telling whether a+-- data type was declared as a H98 data type or as a GADT.  We have to rely on+-- heuristics here.  We look at dcEqSpec field of all data constructors in a+-- data type declaration.  If at least one data constructor has non-empty+-- dcEqSpec this means that the data type must have been declared as a GADT.+-- Consider these declarations:+--+--   data T a where+--      MkT :: forall a. (a ~ Int) => T a+--+--   data T a where+--      MkT :: T Int+--+-- First declaration will be reified as a GADT.  Second declaration will be+-- reified as a normal H98 data type declaration.++------------------------------+reifyClass :: Class -> TcM TH.Info+reifyClass cls+  = do  { cxt <- reifyCxt theta+        ; inst_envs <- tcGetInstEnvs+        ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls)+        ; assocTys <- concatMapM reifyAT ats+        ; ops <- concatMapM reify_op op_stuff+        ; tvs' <- reifyTyVars tvs (Just $ classTyCon cls)+        ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' (assocTys ++ ops)+        ; return (TH.ClassI dec insts) }+  where+    (tvs, fds, theta, _, ats, op_stuff) = classExtraBigSig cls+    fds' = map reifyFunDep fds+    reify_op (op, def_meth)+      = do { ty <- reifyType (idType op)+           ; let nm' = reifyName op+           ; case def_meth of+                Just (_, GenericDM gdm_ty) ->+                  do { gdm_ty' <- reifyType gdm_ty+                     ; return [TH.SigD nm' ty, TH.DefaultSigD nm' gdm_ty'] }+                _ -> return [TH.SigD nm' ty] }++    reifyAT :: ClassATItem -> TcM [TH.Dec]+    reifyAT (ATI tycon def) = do+      tycon' <- reifyTyCon tycon+      case tycon' of+        TH.FamilyI dec _ -> do+          let (tyName, tyArgs) = tfNames dec+          (dec :) <$> maybe (return [])+                            (fmap (:[]) . reifyDefImpl tyName tyArgs . fst)+                            def+        _ -> pprPanic "reifyAT" (text (show tycon'))++    reifyDefImpl :: TH.Name -> [TH.Name] -> Type -> TcM TH.Dec+    reifyDefImpl n args ty =+      TH.TySynInstD n . TH.TySynEqn (map TH.VarT args) <$> reifyType ty++    tfNames :: TH.Dec -> (TH.Name, [TH.Name])+    tfNames (TH.OpenTypeFamilyD (TH.TypeFamilyHead n args _ _))+      = (n, map bndrName args)+    tfNames d = pprPanic "tfNames" (text (show d))++    bndrName :: TH.TyVarBndr -> TH.Name+    bndrName (TH.PlainTV n)    = n+    bndrName (TH.KindedTV n _) = n++------------------------------+-- | Annotate (with TH.SigT) a type if the first parameter is True+-- and if the type contains a free variable.+-- This is used to annotate type patterns for poly-kinded tyvars in+-- reifying class and type instances. See #8953 and th/T8953.+annotThType :: Bool   -- True <=> annotate+            -> TyCoRep.Type -> TH.Type -> TcM TH.Type+  -- tiny optimization: if the type is annotated, don't annotate again.+annotThType _    _  th_ty@(TH.SigT {}) = return th_ty+annotThType True ty th_ty+  | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty+  = do { let ki = typeKind ty+       ; th_ki <- reifyKind ki+       ; return (TH.SigT th_ty th_ki) }+annotThType _    _ th_ty = return th_ty++-- | For every type variable in the input,+-- report whether or not the tv is poly-kinded. This is used to eventually+-- feed into 'annotThType'.+mkIsPolyTvs :: [TyVar] -> [Bool]+mkIsPolyTvs = map is_poly_tv+  where+    is_poly_tv tv = not $+                    isEmptyVarSet $+                    filterVarSet isTyVar $+                    tyCoVarsOfType $+                    tyVarKind tv++------------------------------+reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec]+reifyClassInstances cls insts+  = mapM (reifyClassInstance (mkIsPolyTvs tvs)) insts+  where+    tvs = filterOutInvisibleTyVars (classTyCon cls) (classTyVars cls)++reifyClassInstance :: [Bool]  -- True <=> the corresponding tv is poly-kinded+                              -- includes only *visible* tvs+                   -> ClsInst -> TcM TH.Dec+reifyClassInstance is_poly_tvs i+  = do { cxt <- reifyCxt theta+       ; let vis_types = filterOutInvisibleTypes cls_tc types+       ; thtypes <- reifyTypes vis_types+       ; annot_thtypes <- zipWith3M annotThType is_poly_tvs vis_types thtypes+       ; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) annot_thtypes+       ; return $ (TH.InstanceD over cxt head_ty []) }+  where+     (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun)+     cls_tc   = classTyCon cls+     dfun     = instanceDFunId i+     over     = case overlapMode (is_flag i) of+                  NoOverlap _     -> Nothing+                  Overlappable _  -> Just TH.Overlappable+                  Overlapping _   -> Just TH.Overlapping+                  Overlaps _      -> Just TH.Overlaps+                  Incoherent _    -> Just TH.Incoherent++------------------------------+reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec]+reifyFamilyInstances fam_tc fam_insts+  = mapM (reifyFamilyInstance (mkIsPolyTvs fam_tvs)) fam_insts+  where+    fam_tvs = filterOutInvisibleTyVars fam_tc (tyConTyVars fam_tc)++reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded+                              -- includes only *visible* tvs+                    -> FamInst -> TcM TH.Dec+reifyFamilyInstance is_poly_tvs inst@(FamInst { fi_flavor = flavor+                                              , fi_fam = fam+                                              , fi_tvs = fam_tvs+                                              , fi_tys = lhs+                                              , fi_rhs = rhs })+  = case flavor of+      SynFamilyInst ->+               -- remove kind patterns (#8884)+        do { let lhs_types_only = filterOutInvisibleTypes fam_tc lhs+           ; th_lhs <- reifyTypes lhs_types_only+           ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only+                                                   th_lhs+           ; th_rhs <- reifyType rhs+           ; return (TH.TySynInstD (reifyName fam)+                                   (TH.TySynEqn annot_th_lhs th_rhs)) }++      DataFamilyInst rep_tc ->+        do { let rep_tvs = tyConTyVars rep_tc+                 fam' = reifyName fam++                   -- eta-expand lhs types, because sometimes data/newtype+                   -- instances are eta-reduced; See Trac #9692+                   -- See Note [Eta reduction for data family axioms]+                   -- in TcInstDcls+                 (_rep_tc, rep_tc_args) = splitTyConApp rhs+                 etad_tyvars            = dropList rep_tc_args rep_tvs+                 etad_tys               = mkTyVarTys etad_tyvars+                 eta_expanded_tvs = mkTyVarTys fam_tvs `chkAppend` etad_tys+                 eta_expanded_lhs = lhs `chkAppend` etad_tys+                 dataCons         = tyConDataCons rep_tc+                 -- see Note [Reifying GADT data constructors]+                 isGadt   = any (not . null . dataConEqSpec) dataCons+           ; cons <- mapM (reifyDataCon isGadt eta_expanded_tvs) dataCons+           ; let types_only = filterOutInvisibleTypes fam_tc eta_expanded_lhs+           ; th_tys <- reifyTypes types_only+           ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys+           ; return $+               if isNewTyCon rep_tc+               then TH.NewtypeInstD [] fam' annot_th_tys Nothing (head cons) []+               else TH.DataInstD    [] fam' annot_th_tys Nothing       cons  []+           }+  where+    fam_tc = famInstTyCon inst++------------------------------+reifyType :: TyCoRep.Type -> TcM TH.Type+-- Monadic only because of failure+reifyType ty@(ForAllTy {})  = reify_for_all ty+reifyType (LitTy t)         = do { r <- reifyTyLit t; return (TH.LitT r) }+reifyType (TyVarTy tv)      = return (TH.VarT (reifyName tv))+reifyType (TyConApp tc tys) = reify_tc_app tc tys   -- Do not expand type synonyms here+reifyType (AppTy t1 t2)     = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }+reifyType ty@(FunTy t1 t2)+  | isPredTy t1 = reify_for_all ty  -- Types like ((?x::Int) => Char -> Char)+  | otherwise   = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }+reifyType ty@(CastTy {})    = noTH (sLit "kind casts") (ppr ty)+reifyType ty@(CoercionTy {})= noTH (sLit "coercions in types") (ppr ty)++reify_for_all :: TyCoRep.Type -> TcM TH.Type+reify_for_all ty+  = do { cxt' <- reifyCxt cxt;+       ; tau' <- reifyType tau+       ; tvs' <- reifyTyVars tvs Nothing+       ; return (TH.ForallT tvs' cxt' tau') }+  where+    (tvs, cxt, tau) = tcSplitSigmaTy ty++reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit+reifyTyLit (NumTyLit n) = return (TH.NumTyLit n)+reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s))++reifyTypes :: [Type] -> TcM [TH.Type]+reifyTypes = mapM reifyType++reifyPatSynType+  :: ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) -> TcM TH.Type+-- reifies a pattern synonym's type and returns its *complete* type+-- signature; see NOTE [Pattern synonym signatures and Template+-- Haskell]+reifyPatSynType (univTyVars, req, exTyVars, prov, argTys, resTy)+  = do { univTyVars' <- reifyTyVars univTyVars Nothing+       ; req'        <- reifyCxt req+       ; exTyVars'   <- reifyTyVars exTyVars Nothing+       ; prov'       <- reifyCxt prov+       ; tau'        <- reifyType (mkFunTys argTys resTy)+       ; return $ TH.ForallT univTyVars' req'+                $ TH.ForallT exTyVars' prov' tau' }++reifyKind :: Kind -> TcM TH.Kind+reifyKind  ki+  = do { let (kis, ki') = splitFunTys ki+       ; ki'_rep <- reifyNonArrowKind ki'+       ; kis_rep <- mapM reifyKind kis+       ; return (foldr (TH.AppT . TH.AppT TH.ArrowT) ki'_rep kis_rep) }+  where+    reifyNonArrowKind k | isLiftedTypeKind k = return TH.StarT+                        | isConstraintKind k = return TH.ConstraintT+    reifyNonArrowKind (TyVarTy v)            = return (TH.VarT (reifyName v))+    reifyNonArrowKind (FunTy _ k)            = reifyKind k+    reifyNonArrowKind (ForAllTy _ k)         = reifyKind k+    reifyNonArrowKind (TyConApp kc kis)      = reify_kc_app kc kis+    reifyNonArrowKind (AppTy k1 k2)          = do { k1' <- reifyKind k1+                                                  ; k2' <- reifyKind k2+                                                  ; return (TH.AppT k1' k2')+                                                  }+    reifyNonArrowKind k                      = noTH (sLit "this kind") (ppr k)++reify_kc_app :: TyCon -> [TyCoRep.Kind] -> TcM TH.Kind+reify_kc_app kc kis+  = fmap (mkThAppTs r_kc) (mapM reifyKind vis_kis)+  where+    r_kc | isTupleTyCon kc          = TH.TupleT (tyConArity kc)+         | kc `hasKey` listTyConKey = TH.ListT+         | otherwise                = TH.ConT (reifyName kc)++    vis_kis = filterOutInvisibleTypes kc kis++reifyCxt :: [PredType] -> TcM [TH.Pred]+reifyCxt   = mapM reifyPred++reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep+reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)++reifyTyVars :: [TyVar]+            -> Maybe TyCon  -- the tycon if the tycovars are from a tycon.+                            -- Used to detect which tvs are implicit.+            -> TcM [TH.TyVarBndr]+reifyTyVars tvs m_tc = mapM reify_tv tvs'+  where+    tvs' = case m_tc of+             Just tc -> filterOutInvisibleTyVars tc tvs+             Nothing -> tvs++    -- even if the kind is *, we need to include a kind annotation,+    -- in case a poly-kind would be inferred without the annotation.+    -- See #8953 or test th/T8953+    reify_tv tv = TH.KindedTV name <$> reifyKind kind+      where+        kind = tyVarKind tv+        name = reifyName tv++{-+Note [Kind annotations on TyConApps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A poly-kinded tycon sometimes needs a kind annotation to be unambiguous.+For example:++   type family F a :: k+   type instance F Int  = (Proxy :: * -> *)+   type instance F Bool = (Proxy :: (* -> *) -> *)++It's hard to figure out where these annotations should appear, so we do this:+Suppose the tycon is applied to n arguments. We strip off the first n+arguments of the tycon's kind. If there are any variables left in the result+kind, we put on a kind annotation. But we must be slightly careful: it's+possible that the tycon's kind will have fewer than n arguments, in the case+that the concrete application instantiates a result kind variable with an+arrow kind. So, if we run out of arguments, we conservatively put on a kind+annotation anyway. This should be a rare case, indeed. Here is an example:++   data T1 :: k1 -> k2 -> *+   data T2 :: k1 -> k2 -> *++   type family G (a :: k) :: k+   type instance G T1 = T2++   type instance F Char = (G T1 Bool :: (* -> *) -> *)   -- F from above++Here G's kind is (forall k. k -> k), and the desugared RHS of that last+instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to+the algorithm above, there are 3 arguments to G so we should peel off 3+arguments in G's kind. But G's kind has only two arguments. This is the+rare special case, and we conservatively choose to put the annotation+in.++See #8953 and test th/T8953.+-}++reify_tc_app :: TyCon -> [Type.Type] -> TcM TH.Type+reify_tc_app tc tys+  = do { tys' <- reifyTypes (filterOutInvisibleTypes tc tys)+       ; maybe_sig_t (mkThAppTs r_tc tys') }+  where+    arity       = tyConArity tc+    tc_binders  = tyConBinders tc+    tc_res_kind = tyConResKind tc++    r_tc | isUnboxedSumTyCon tc           = TH.UnboxedSumT (arity `div` 2)+         | isUnboxedTupleTyCon tc         = TH.UnboxedTupleT (arity `div` 2)+         | isPromotedTupleTyCon tc        = TH.PromotedTupleT (arity `div` 2)+             -- See Note [Unboxed tuple RuntimeRep vars] in TyCon+         | isTupleTyCon tc                = if isPromotedDataCon tc+                                            then TH.PromotedTupleT arity+                                            else TH.TupleT arity+         | tc `hasKey` listTyConKey       = TH.ListT+         | tc `hasKey` nilDataConKey      = TH.PromotedNilT+         | tc `hasKey` consDataConKey     = TH.PromotedConsT+         | tc `hasKey` heqTyConKey        = TH.EqualityT+         | tc `hasKey` eqPrimTyConKey     = TH.EqualityT+         | tc `hasKey` eqReprPrimTyConKey = TH.ConT (reifyName coercibleTyCon)+         | isPromotedDataCon tc           = TH.PromotedT (reifyName tc)+         | otherwise                      = TH.ConT (reifyName tc)++    -- See Note [Kind annotations on TyConApps]+    maybe_sig_t th_type+      | needs_kind_sig+      = do { let full_kind = typeKind (mkTyConApp tc tys)+           ; th_full_kind <- reifyKind full_kind+           ; return (TH.SigT th_type th_full_kind) }+      | otherwise+      = return th_type++    needs_kind_sig+      | GT <- compareLength tys tc_binders+      = tcIsTyVarTy tc_res_kind+      | otherwise+      = not . isEmptyVarSet $+        filterVarSet isTyVar $+        tyCoVarsOfType $+        mkTyConKind (dropList tys tc_binders) tc_res_kind++reifyPred :: TyCoRep.PredType -> TcM TH.Pred+reifyPred ty+  -- We could reify the invisible parameter as a class but it seems+  -- nicer to support them properly...+  | isIPPred ty = noTH (sLit "implicit parameters") (ppr ty)+  | otherwise   = reifyType ty++------------------------------+reifyName :: NamedThing n => n -> TH.Name+reifyName thing+  | isExternalName name = mk_varg pkg_str mod_str occ_str+  | otherwise           = TH.mkNameU occ_str (getKey (getUnique name))+        -- Many of the things we reify have local bindings, and+        -- NameL's aren't supposed to appear in binding positions, so+        -- we use NameU.  When/if we start to reify nested things, that+        -- have free variables, we may need to generate NameL's for them.+  where+    name    = getName thing+    mod     = ASSERT( isExternalName name ) nameModule name+    pkg_str = unitIdString (moduleUnitId mod)+    mod_str = moduleNameString (moduleName mod)+    occ_str = occNameString occ+    occ     = nameOccName name+    mk_varg | OccName.isDataOcc occ = TH.mkNameG_d+            | OccName.isVarOcc  occ = TH.mkNameG_v+            | OccName.isTcOcc   occ = TH.mkNameG_tc+            | otherwise             = pprPanic "reifyName" (ppr name)++-- See Note [Reifying field labels]+reifyFieldLabel :: FieldLabel -> TH.Name+reifyFieldLabel fl+  | flIsOverloaded fl+              = TH.Name (TH.mkOccName occ_str) (TH.NameQ (TH.mkModName mod_str))+  | otherwise = TH.mkNameG_v pkg_str mod_str occ_str+  where+    name    = flSelector fl+    mod     = ASSERT( isExternalName name ) nameModule name+    pkg_str = unitIdString (moduleUnitId mod)+    mod_str = moduleNameString (moduleName mod)+    occ_str = unpackFS (flLabel fl)++reifySelector :: Id -> TyCon -> TH.Name+reifySelector id tc+  = case find ((idName id ==) . flSelector) (tyConFieldLabels tc) of+      Just fl -> reifyFieldLabel fl+      Nothing -> pprPanic "reifySelector: missing field" (ppr id $$ ppr tc)++------------------------------+reifyFixity :: Name -> TcM (Maybe TH.Fixity)+reifyFixity name+  = do { (found, fix) <- lookupFixityRn_help name+       ; return (if found then Just (conv_fix fix) else Nothing) }+    where+      conv_fix (BasicTypes.Fixity _ i d) = TH.Fixity i (conv_dir d)+      conv_dir BasicTypes.InfixR = TH.InfixR+      conv_dir BasicTypes.InfixL = TH.InfixL+      conv_dir BasicTypes.InfixN = TH.InfixN++reifyUnpackedness :: DataCon.SrcUnpackedness -> TH.SourceUnpackedness+reifyUnpackedness NoSrcUnpack = TH.NoSourceUnpackedness+reifyUnpackedness SrcNoUnpack = TH.SourceNoUnpack+reifyUnpackedness SrcUnpack   = TH.SourceUnpack++reifyStrictness :: DataCon.SrcStrictness -> TH.SourceStrictness+reifyStrictness NoSrcStrict = TH.NoSourceStrictness+reifyStrictness SrcStrict   = TH.SourceStrict+reifyStrictness SrcLazy     = TH.SourceLazy++reifySourceBang :: DataCon.HsSrcBang+                -> (TH.SourceUnpackedness, TH.SourceStrictness)+reifySourceBang (HsSrcBang _ u s) = (reifyUnpackedness u, reifyStrictness s)++reifyDecidedStrictness :: DataCon.HsImplBang -> TH.DecidedStrictness+reifyDecidedStrictness HsLazy     = TH.DecidedLazy+reifyDecidedStrictness HsStrict   = TH.DecidedStrict+reifyDecidedStrictness HsUnpack{} = TH.DecidedUnpack++------------------------------+lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget+lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm)+lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn))+  = return $ ModuleTarget $+    mkModule (stringToUnitId $ TH.pkgString pn) (mkModuleName $ TH.modString mn)++reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a]+reifyAnnotations th_name+  = do { name <- lookupThAnnLookup th_name+       ; topEnv <- getTopEnv+       ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing+       ; tcg <- getGblEnv+       ; let selectedEpsHptAnns = findAnns deserializeWithData epsHptAnns name+       ; let selectedTcgAnns = findAnns deserializeWithData (tcg_ann_env tcg) name+       ; return (selectedEpsHptAnns ++ selectedTcgAnns) }++------------------------------+modToTHMod :: Module -> TH.Module+modToTHMod m = TH.Module (TH.PkgName $ unitIdString  $ moduleUnitId m)+                         (TH.ModName $ moduleNameString $ moduleName m)++reifyModule :: TH.Module -> TcM TH.ModuleInfo+reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do+  this_mod <- getModule+  let reifMod = mkModule (stringToUnitId pkgString) (mkModuleName mString)+  if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod+    where+      reifyThisModule = do+        usages <- fmap (map modToTHMod . moduleEnvKeys . imp_mods) getImports+        return $ TH.ModuleInfo usages++      reifyFromIface reifMod = do+        iface <- loadInterfaceForModule (text "reifying module from TH for" <+> ppr reifMod) reifMod+        let usages = [modToTHMod m | usage <- mi_usages iface,+                                     Just m <- [usageToModule (moduleUnitId reifMod) usage] ]+        return $ TH.ModuleInfo usages++      usageToModule :: UnitId -> Usage -> Maybe Module+      usageToModule _ (UsageFile {}) = Nothing+      usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn+      usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m+      usageToModule _ (UsageMergedRequirement { usg_mod = m }) = Just m++------------------------------+mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type+mkThAppTs fun_ty arg_tys = foldl TH.AppT fun_ty arg_tys++noTH :: LitString -> SDoc -> TcM a+noTH s d = failWithTc (hsep [text "Can't represent" <+> ptext s <+>+                                text "in Template Haskell:",+                             nest 2 d])++ppr_th :: TH.Ppr a => a -> SDoc+ppr_th x = text (TH.pprint x)++{-+Note [Reifying field labels]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When reifying a datatype declared with DuplicateRecordFields enabled, we want+the reified names of the fields to be labels rather than selector functions.+That is, we want (reify ''T) and (reify 'foo) to produce++    data T = MkT { foo :: Int }+    foo :: T -> Int++rather than++    data T = MkT { $sel:foo:MkT :: Int }+    $sel:foo:MkT :: T -> Int++because otherwise TH code that uses the field names as strings will silently do+the wrong thing.  Thus we use the field label (e.g. foo) as the OccName, rather+than the selector (e.g. $sel:foo:MkT).  Since the Orig name M.foo isn't in the+environment, NameG can't be used to represent such fields.  Instead,+reifyFieldLabel uses NameQ.++However, this means that extracting the field name from the output of reify, and+trying to reify it again, may fail with an ambiguity error if there are multiple+such fields defined in the module (see the test case+overloadedrecflds/should_fail/T11103.hs).  The "proper" fix requires changes to+the TH AST to make it able to represent duplicate record fields.+-}
+ typecheck/TcSplice.hs-boot view
@@ -0,0 +1,40 @@+{-# LANGUAGE CPP #-}++module TcSplice where+import HsSyn    ( HsSplice, HsBracket, HsExpr, LHsExpr )+import HsExpr   ( PendingRnSplice )+import Name     ( Name )+import TcRnTypes( TcM, TcId )+import TcType   ( ExpRhoType )+import Annotations ( Annotation, CoreAnnTarget )++import HsSyn      ( LHsType, LPat, LHsDecl, ThModFinalizers )+import RdrName    ( RdrName )+import TcRnTypes  ( SpliceType )+import qualified Language.Haskell.TH as TH++tcSpliceExpr :: HsSplice Name+             -> ExpRhoType+             -> TcM (HsExpr TcId)++tcUntypedBracket :: HsBracket Name+                 -> [PendingRnSplice]+                 -> ExpRhoType+                 -> TcM (HsExpr TcId)+tcTypedBracket :: HsBracket Name+               -> ExpRhoType+               -> TcM (HsExpr TcId)++runAnnotation     :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation++tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr TcId) -> TcM (LHsExpr TcId)++runMetaE :: LHsExpr TcId -> TcM (LHsExpr RdrName)+runMetaP :: LHsExpr TcId -> TcM (LPat RdrName)+runMetaT :: LHsExpr TcId  -> TcM (LHsType RdrName)+runMetaD :: LHsExpr TcId -> TcM [LHsDecl RdrName]++lookupThName_maybe :: TH.Name -> TcM (Maybe Name)+runQuasi :: TH.Q a -> TcM a+runRemoteModFinalizers :: ThModFinalizers -> TcM ()+finishTH :: TcM ()
+ typecheck/TcTyClsDecls.hs view
@@ -0,0 +1,3092 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1996-1998+++TcTyClsDecls: Typecheck type and class declarations+-}++{-# LANGUAGE CPP, TupleSections, MultiWayIf #-}++module TcTyClsDecls (+        tcTyAndClassDecls, tcAddImplicits,++        -- Functions used by TcInstDcls to check+        -- data/type family instance declarations+        kcDataDefn, tcConDecls, dataDeclChecks, checkValidTyCon,+        tcFamTyPats, tcTyFamInstEqn, famTyConShape,+        tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt,+        wrongKindOfFamily, dataConCtxt+    ) where++#include "HsVersions.h"++import HsSyn+import HscTypes+import BuildTyCl+import TcRnMonad+import TcEnv+import TcValidity+import TcHsSyn+import TcTyDecls+import TcClassDcl+import {-# SOURCE #-} TcInstDcls( tcInstDecls1 )+import TcDeriv (DerivInfo)+import TcUnify+import TcHsType+import TcMType+import TysWiredIn ( unitTy )+import TcType+import RnEnv( RoleAnnotEnv, mkRoleAnnotEnv, lookupRoleAnnot+            , lookupConstructorFields )+import FamInst+import FamInstEnv+import Coercion+import Type+import TyCoRep   -- for checkValidRoles+import Kind+import Class+import CoAxiom+import TyCon+import DataCon+import Id+import Var+import VarEnv+import VarSet+import Module+import Name+import NameSet+import NameEnv+import Outputable+import Maybes+import Unify+import Util+import SrcLoc+import ListSetOps+import DynFlags+import Unique+import BasicTypes+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Data.List++{-+************************************************************************+*                                                                      *+\subsection{Type checking for type and class declarations}+*                                                                      *+************************************************************************++Note [Grouping of type and class declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+tcTyAndClassDecls is called on a list of `TyClGroup`s. Each group is a strongly+connected component of mutually dependent types and classes. We kind check and+type check each group separately to enhance kind polymorphism. Take the+following example:++  type Id a = a+  data X = X (Id Int)++If we were to kind check the two declarations together, we would give Id the+kind * -> *, since we apply it to an Int in the definition of X. But we can do+better than that, since Id really is kind polymorphic, and should get kind+forall (k::*). k -> k. Since it does not depend on anything else, it can be+kind-checked by itself, hence getting the most general kind. We then kind check+X, which works fine because we then know the polymorphic kind of Id, and simply+instantiate k to *.++Note [Check role annotations in a second pass]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Role inference potentially depends on the types of all of the datacons declared+in a mutually recursive group. The validity of a role annotation, in turn,+depends on the result of role inference. Because the types of datacons might+be ill-formed (see #7175 and Note [Checking GADT return types]) we must check+*all* the tycons in a group for validity before checking *any* of the roles.+Thus, we take two passes over the resulting tycons, first checking for general+validity and then checking for valid role annotations.+-}++tcTyAndClassDecls :: [TyClGroup Name]       -- Mutually-recursive groups in+                                            -- dependency order+                  -> TcM ( TcGblEnv         -- Input env extended by types and+                                            -- classes+                                            -- and their implicit Ids,DataCons+                         , [InstInfo Name]  -- Source-code instance decls info+                         , [DerivInfo]      -- data family deriving info+                         )+-- Fails if there are any errors+tcTyAndClassDecls tyclds_s+  -- The code recovers internally, but if anything gave rise to+  -- an error we'd better stop now, to avoid a cascade+  -- Type check each group in dependency order folding the global env+  = checkNoErrs $ fold_env [] [] tyclds_s+  where+    fold_env :: [InstInfo Name]+             -> [DerivInfo]+             -> [TyClGroup Name]+             -> TcM (TcGblEnv, [InstInfo Name], [DerivInfo])+    fold_env inst_info deriv_info []+      = do { gbl_env <- getGblEnv+           ; return (gbl_env, inst_info, deriv_info) }+    fold_env inst_info deriv_info (tyclds:tyclds_s)+      = do { (tcg_env, inst_info', deriv_info') <- tcTyClGroup tyclds+           ; setGblEnv tcg_env $+               -- remaining groups are typechecked in the extended global env.+             fold_env (inst_info' ++ inst_info)+                      (deriv_info' ++ deriv_info)+                      tyclds_s }++tcTyClGroup :: TyClGroup Name+            -> TcM (TcGblEnv, [InstInfo Name], [DerivInfo])+-- Typecheck one strongly-connected component of type, class, and instance decls+-- See Note [TyClGroups and dependency analysis] in HsDecls+tcTyClGroup (TyClGroup { group_tyclds = tyclds+                       , group_roles  = roles+                       , group_instds = instds })+  = do { let role_annots = mkRoleAnnotEnv roles++           -- Step 1: Typecheck the type/class declarations+       ; traceTc "-------- tcTyClGroup ------------" empty+       ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds))+       ; tyclss <- tcTyClDecls tyclds role_annots++           -- Step 1.5: Make sure we don't have any type synonym cycles+       ; traceTc "Starting synonym cycle check" (ppr tyclss)+       ; this_uid <- fmap thisPackage getDynFlags+       ; checkSynCycles this_uid tyclss tyclds+       ; traceTc "Done synonym cycle check" (ppr tyclss)++       ; traceTc "Starting family consistency check" (ppr tyclss)+       ; forM_ tyclss checkRecFamInstConsistency+       ; traceTc "Done family consistency" (ppr tyclss)++           -- Step 2: Perform the validity check on those types/classes+           -- We can do this now because we are done with the recursive knot+           -- Do it before Step 3 (adding implicit things) because the latter+           -- expects well-formed TyCons+       ; traceTc "Starting validity check" (ppr tyclss)+       ; tyclss <- mapM checkValidTyCl tyclss+       ; traceTc "Done validity check" (ppr tyclss)+       ; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss+           -- See Note [Check role annotations in a second pass]++           -- Step 3: Add the implicit things;+           -- we want them in the environment because+           -- they may be mentioned in interface files+       ; tcExtendTyConEnv tyclss $+    do { gbl_env <- tcAddImplicits tyclss+       ; setGblEnv gbl_env $+    do {+            -- Step 4: check instance declarations+       ; (gbl_env, inst_info, datafam_deriv_info) <- tcInstDecls1 instds++       ; return (gbl_env, inst_info, datafam_deriv_info) } } }++tcTyClDecls :: [LTyClDecl Name] -> RoleAnnotEnv -> TcM [TyCon]+tcTyClDecls tyclds role_annots+  = do {    -- Step 1: kind-check this group and returns the final+            -- (possibly-polymorphic) kind of each TyCon and Class+            -- See Note [Kind checking for type and class decls]+         tc_tycons <- kcTyClGroup tyclds+       ; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons))++            -- Step 2: type-check all groups together, returning+            -- the final TyCons and Classes+            --+            -- NB: We have to be careful here to NOT eagerly unfold+            -- type synonyms, as we have not tested for type synonym+            -- loops yet and could fall into a black hole.+       ; fixM $ \ ~rec_tyclss -> do+           { tcg_env <- getGblEnv+           ; let roles = inferRoles (tcg_src tcg_env) role_annots rec_tyclss++                 -- Populate environment with knot-tied ATyCon for TyCons+                 -- NB: if the decls mention any ill-staged data cons+                 -- (see Note [Recusion and promoting data constructors])+                 -- we will have failed already in kcTyClGroup, so no worries here+           ; tcExtendRecEnv (zipRecTyClss tc_tycons rec_tyclss) $++                 -- Also extend the local type envt with bindings giving+                 -- the (polymorphic) kind of each knot-tied TyCon or Class+                 -- See Note [Type checking recursive type and class declarations]+             tcExtendKindEnv (foldl extendEnvWithTcTyCon emptyNameEnv tc_tycons) $++                 -- Kind and type check declarations for this group+               mapM (tcTyClDecl roles) tyclds+           } }+  where+    ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma+                                  , ppr (tyConBinders tc) <> comma+                                  , ppr (tyConResKind tc) ])++zipRecTyClss :: [TcTyCon]+             -> [TyCon]           -- Knot-tied+             -> [(Name,TyThing)]+-- Build a name-TyThing mapping for the TyCons bound by decls+-- being careful not to look at the knot-tied [TyThing]+-- The TyThings in the result list must have a visible ATyCon,+-- because typechecking types (in, say, tcTyClDecl) looks at+-- this outer constructor+zipRecTyClss tc_tycons rec_tycons+  = [ (name, ATyCon (get name)) | tc_tycon <- tc_tycons, let name = getName tc_tycon ]+  where+    rec_tc_env :: NameEnv TyCon+    rec_tc_env = foldr add_tc emptyNameEnv rec_tycons++    add_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon+    add_tc tc env = foldr add_one_tc env (tc : tyConATs tc)++    add_one_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon+    add_one_tc tc env = extendNameEnv env (tyConName tc) tc++    get name = case lookupNameEnv rec_tc_env name of+                 Just tc -> tc+                 other   -> pprPanic "zipRecTyClss" (ppr name <+> ppr other)++{-+************************************************************************+*                                                                      *+                Kind checking+*                                                                      *+************************************************************************++Note [Kind checking for type and class decls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Kind checking is done thus:++   1. Make up a kind variable for each parameter of the declarations,+      and extend the kind environment (which is in the TcLclEnv)++   2. Kind check the declarations++We need to kind check all types in the mutually recursive group+before we know the kind of the type variables.  For example:++  class C a where+     op :: D b => a -> b -> b++  class D c where+     bop :: (Monad c) => ...++Here, the kind of the locally-polymorphic type variable "b"+depends on *all the uses of class D*.  For example, the use of+Monad c in bop's type signature means that D must have kind Type->Type.++Note: we don't treat type synonyms specially (we used to, in the past);+in particular, even if we have a type synonym cycle, we still kind check+it normally, and test for cycles later (checkSynCycles).  The reason+we can get away with this is because we have more systematic TYPE r+inference, which means that we can do unification between kinds that+aren't lifted (this historically was not true.)++The downside of not directly reading off the kinds off the RHS of+type synonyms in topological order is that we don't transparently+support making synonyms of types with higher-rank kinds.  But+you can always specify a CUSK directly to make this work out.+See tc269 for an example.++Open type families+~~~~~~~~~~~~~~~~~~+This treatment of type synonyms only applies to Haskell 98-style synonyms.+General type functions can be recursive, and hence, appear in `alg_decls'.++The kind of an open type family is solely determinded by its kind signature;+hence, only kind signatures participate in the construction of the initial+kind environment (as constructed by `getInitialKind'). In fact, we ignore+instances of families altogether in the following. However, we need to include+the kinds of *associated* families into the construction of the initial kind+environment. (This is handled by `allDecls').+++See also Note [Kind checking recursive type and class declarations]++-}+++-- Note [Missed opportunity to retain higher-rank kinds]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- In 'kcTyClGroup', there is a missed opportunity to make kind+-- inference work in a few more cases.  The idea is analogous+-- to Note [Single function non-recursive binding special-case]:+--+--      * If we have an SCC with a single decl, which is non-recursive,+--        instead of creating a unification variable representing the+--        kind of the decl and unifying it with the rhs, we can just+--        read the type directly of the rhs.+--+--      * Furthermore, we can update our SCC analysis to ignore+--        dependencies on declarations which have CUSKs: we don't+--        have to kind-check these all at once, since we can use+--        the CUSK to initialize the kind environment.+--+-- Unfortunately this requires reworking a bit of the code in+-- 'kcLTyClDecl' so I've decided to punt unless someone shouts about it.+--+kcTyClGroup :: [LTyClDecl Name] -> TcM [TcTyCon]++-- Kind check this group, kind generalize, and return the resulting local env+-- This binds the TyCons and Classes of the group, but not the DataCons+-- See Note [Kind checking for type and class decls]+-- Third return value is Nothing if the tycon be unsaturated; otherwise,+-- the arity+kcTyClGroup decls+  = do  { mod <- getModule+        ; traceTc "kcTyClGroup" (text "module" <+> ppr mod $$ vcat (map ppr decls))++          -- Kind checking;+          --    1. Bind kind variables for decls+          --    2. Kind-check decls+          --    3. Generalise the inferred kinds+          -- See Note [Kind checking for type and class decls]++        ; lcl_env <- solveEqualities $+                     do { -- Step 1: Bind kind variables for all decls+                          initial_kinds <- getInitialKinds decls+                        ; traceTc "kcTyClGroup: initial kinds" $+                          ppr initial_kinds++                        -- Step 2: Set extended envt, kind-check the decls+                        ; tcExtendKindEnv initial_kinds $+                          do { mapM_ kcLTyClDecl decls+                             ; getLclEnv } }++        -- Step 3: generalisation+        -- Kind checking done for this group+        -- Now we have to kind generalize the flexis+        ; res <- concatMapM (generaliseTCD (tcl_env lcl_env)) decls++        ; traceTc "kcTyClGroup result" (vcat (map pp_res res))+        ; return res }++  where+    generalise :: TcTypeEnv -> Name -> TcM TcTyCon+    -- For polymorphic things this is a no-op+    generalise kind_env name+      = do { let tc = case lookupNameEnv kind_env name of+                        Just (ATcTyCon tc) -> tc+                        _ -> pprPanic "kcTyClGroup" (ppr name $$ ppr kind_env)+                 kc_binders  = tyConBinders tc+                 kc_res_kind = tyConResKind tc+                 kc_tyvars   = tyConTyVars tc+           ; kvs <- kindGeneralize (mkTyConKind kc_binders kc_res_kind)+           ; let all_binders = mkNamedTyConBinders Inferred kvs ++ kc_binders++           ; (env, all_binders') <- zonkTyVarBindersX emptyZonkEnv all_binders+           ; kc_res_kind'        <- zonkTcTypeToType env kc_res_kind++                      -- Make sure kc_kind' has the final, zonked kind variables+           ; traceTc "Generalise kind" $+             vcat [ ppr name, ppr kc_binders, ppr kvs, ppr all_binders, ppr kc_res_kind+                  , ppr all_binders', ppr kc_res_kind'+                  , ppr kc_tyvars, ppr (tcTyConScopedTyVars tc)]++           ; return (mkTcTyCon name all_binders' kc_res_kind'+                               (mightBeUnsaturatedTyCon tc)+                               (tcTyConScopedTyVars tc)) }++    generaliseTCD :: TcTypeEnv+                  -> LTyClDecl Name -> TcM [TcTyCon]+    generaliseTCD kind_env (L _ decl)+      | ClassDecl { tcdLName = (L _ name), tcdATs = ats } <- decl+      = do { first <- generalise kind_env name+           ; rest <- mapM ((generaliseFamDecl kind_env) . unLoc) ats+           ; return (first : rest) }++      | FamDecl { tcdFam = fam } <- decl+      = do { res <- generaliseFamDecl kind_env fam+           ; return [res] }++      | otherwise+      = do { res <- generalise kind_env (tcdName decl)+           ; return [res] }++    generaliseFamDecl :: TcTypeEnv+                      -> FamilyDecl Name -> TcM TcTyCon+    generaliseFamDecl kind_env (FamilyDecl { fdLName = L _ name })+      = generalise kind_env name++    pp_res tc = ppr (tyConName tc) <+> dcolon <+> ppr (tyConKind tc)++--------------+mkTcTyConEnv :: TcTyCon -> TcTypeEnv+mkTcTyConEnv tc = unitNameEnv (getName tc) (ATcTyCon tc)++extendEnvWithTcTyCon :: TcTypeEnv -> TcTyCon -> TcTypeEnv+-- Makes a binding to put in the local envt, binding+-- a name to a TcTyCon+extendEnvWithTcTyCon env tc+  = extendNameEnv env (getName tc) (ATcTyCon tc)++--------------+mkPromotionErrorEnv :: [LTyClDecl Name] -> TcTypeEnv+-- Maps each tycon/datacon to a suitable promotion error+--    tc :-> APromotionErr TyConPE+--    dc :-> APromotionErr RecDataConPE+--    See Note [ARecDataCon: Recursion and promoting data constructors]++mkPromotionErrorEnv decls+  = foldr (plusNameEnv . mk_prom_err_env . unLoc)+          emptyNameEnv decls++mk_prom_err_env :: TyClDecl Name -> TcTypeEnv+mk_prom_err_env (ClassDecl { tcdLName = L _ nm, tcdATs = ats })+  = unitNameEnv nm (APromotionErr ClassPE)+    `plusNameEnv`+    mkNameEnv [ (name, APromotionErr TyConPE)+              | L _ (FamilyDecl { fdLName = L _ name }) <- ats ]++mk_prom_err_env (DataDecl { tcdLName = L _ name+                          , tcdDataDefn = HsDataDefn { dd_cons = cons } })+  = unitNameEnv name (APromotionErr TyConPE)+    `plusNameEnv`+    mkNameEnv [ (con, APromotionErr RecDataConPE)+              | L _ con' <- cons, L _ con <- getConNames con' ]++mk_prom_err_env decl+  = unitNameEnv (tcdName decl) (APromotionErr TyConPE)+    -- Works for family declarations too++--------------+getInitialKinds :: [LTyClDecl Name] -> TcM (NameEnv TcTyThing)+-- Maps each tycon to its initial kind,+-- and each datacon to a suitable promotion error+--    tc :-> ATcTyCon (tc:initial_kind)+--    dc :-> APromotionErr RecDataConPE+--    See Note [ARecDataCon: Recursion and promoting data constructors]++getInitialKinds decls+  = tcExtendKindEnv promotion_err_env $+    do { tc_kinds <- mapM (addLocM getInitialKind) decls+       ; return (foldl plusNameEnv promotion_err_env tc_kinds) }+  where+    promotion_err_env = mkPromotionErrorEnv decls++getInitialKind :: TyClDecl Name+               -> TcM (NameEnv TcTyThing)+-- Allocate a fresh kind variable for each TyCon and Class+-- For each tycon, return a NameEnv with+--      name :-> ATcTyCon (TcCyCon with kind k))+-- where k is the kind of tc, derived from the LHS+--       of the definition (and probably including+--       kind unification variables)+--      Example: data T a b = ...+--      return (T, kv1 -> kv2 -> kv3)+--+-- This pass deals with (ie incorporates into the kind it produces)+--   * The kind signatures on type-variable binders+--   * The result kinds signature on a TyClDecl+--+-- No family instances are passed to getInitialKinds++getInitialKind decl@(ClassDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdATs = ats })+  = do { let cusk = hsDeclHasCusk decl+       ; (tycon, inner_prs) <-+           kcHsTyVarBndrs name True cusk False True ktvs $+           do { inner_prs <- getFamDeclInitialKinds (Just cusk) ats+              ; return (constraintKind, inner_prs) }+       ; return (extendEnvWithTcTyCon inner_prs tycon) }++getInitialKind decl@(DataDecl { tcdLName = L _ name+                              , tcdTyVars = ktvs+                              , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig } })+  = do  { (tycon, _) <-+           kcHsTyVarBndrs name True (hsDeclHasCusk decl) False True ktvs $+           do { res_k <- case m_sig of+                           Just ksig -> tcLHsKindSig ksig+                           Nothing   -> return liftedTypeKind+              ; return (res_k, ()) }+        ; return (mkTcTyConEnv tycon) }++getInitialKind (FamDecl { tcdFam = decl })+  = getFamDeclInitialKind Nothing decl++getInitialKind decl@(SynDecl { tcdLName = L _ name+                             , tcdTyVars = ktvs+                             , tcdRhs = rhs })+  = do  { (tycon, _) <- kcHsTyVarBndrs name False (hsDeclHasCusk decl)+                            False {- not open -} True ktvs $+            do  { res_k <- case kind_annotation rhs of+                            Nothing -> newMetaKindVar+                            Just ksig -> tcLHsKindSig ksig+                ; return (res_k, ()) }+        ; return (mkTcTyConEnv tycon) }+  where+    -- Keep this synchronized with 'hsDeclHasCusk'.+    kind_annotation (L _ ty) = case ty of+        HsParTy lty     -> kind_annotation lty+        HsKindSig _ k   -> Just k+        _               -> Nothing++---------------------------------+getFamDeclInitialKinds :: Maybe Bool  -- if assoc., CUSKness of assoc. class+                       -> [LFamilyDecl Name]+                       -> TcM TcTypeEnv+getFamDeclInitialKinds mb_cusk decls+  = do { tc_kinds <- mapM (addLocM (getFamDeclInitialKind mb_cusk)) decls+       ; return (foldr plusNameEnv emptyNameEnv tc_kinds) }++getFamDeclInitialKind :: Maybe Bool  -- if assoc., CUSKness of assoc. class+                      -> FamilyDecl Name+                      -> TcM TcTypeEnv+getFamDeclInitialKind mb_cusk decl@(FamilyDecl { fdLName     = L _ name+                                               , fdTyVars    = ktvs+                                               , fdResultSig = L _ resultSig+                                               , fdInfo      = info })+  = do { (tycon, _) <-+           kcHsTyVarBndrs name unsat cusk open True ktvs $+           do { res_k <- case resultSig of+                      KindSig ki                        -> tcLHsKindSig ki+                      TyVarSig (L _ (KindedTyVar _ ki)) -> tcLHsKindSig ki+                      _ -- open type families have * return kind by default+                        | open                     -> return liftedTypeKind+                        -- closed type families have their return kind inferred+                        -- by default+                        | otherwise                -> newMetaKindVar+              ; return (res_k, ()) }+       ; return (mkTcTyConEnv tycon) }+  where+    cusk  = famDeclHasCusk mb_cusk decl+    (open, unsat) = case info of+      DataFamily         -> (True,  True)+      OpenTypeFamily     -> (True,  False)+      ClosedTypeFamily _ -> (False, False)++------------------------------------------------------------------------+kcLTyClDecl :: LTyClDecl Name -> TcM ()+  -- See Note [Kind checking for type and class decls]+kcLTyClDecl (L loc decl)+  = setSrcSpan loc $ tcAddDeclCtxt decl $ kcTyClDecl decl++kcTyClDecl :: TyClDecl Name -> TcM ()+-- This function is used solely for its side effect on kind variables+-- NB kind signatures on the type variables and+--    result kind signature have already been dealt with+--    by getInitialKind, so we can ignore them here.++kcTyClDecl (DataDecl { tcdLName = L _ name, tcdDataDefn = defn })+  | HsDataDefn { dd_cons = cons, dd_kindSig = Just _ } <- defn+  = mapM_ (wrapLocM kcConDecl) cons+    -- hs_tvs and dd_kindSig already dealt with in getInitialKind+    -- If dd_kindSig is Just, this must be a GADT-style decl,+    --        (see invariants of DataDefn declaration)+    -- so (a) we don't need to bring the hs_tvs into scope, because the+    --        ConDecls bind all their own variables+    --    (b) dd_ctxt is not allowed for GADT-style decls, so we can ignore it++  | HsDataDefn { dd_ctxt = ctxt, dd_cons = cons } <- defn+  = kcTyClTyVars name $+    do  { _ <- tcHsContext ctxt+        ; mapM_ (wrapLocM kcConDecl) cons }++kcTyClDecl (SynDecl { tcdLName = L _ name, tcdRhs = lrhs })+  = kcTyClTyVars name $+    do  { syn_tc <- kcLookupTcTyCon name+        -- NB: check against the result kind that we allocated+        -- in getInitialKinds.+        ; discardResult $ tcCheckLHsType lrhs (tyConResKind syn_tc) }++kcTyClDecl (ClassDecl { tcdLName = L _ name+                      , tcdCtxt = ctxt, tcdSigs = sigs })+  = kcTyClTyVars name $+    do  { _ <- tcHsContext ctxt+        ; mapM_ (wrapLocM kc_sig)     sigs }+  where+    kc_sig (ClassOpSig _ nms op_ty) = kcHsSigType nms op_ty+    kc_sig _                        = return ()++kcTyClDecl (FamDecl (FamilyDecl { fdLName  = L _ fam_tc_name+                                , fdInfo   = fd_info }))+-- closed type families look at their equations, but other families don't+-- do anything here+  = case fd_info of+      ClosedTypeFamily (Just eqns) ->+        do { fam_tc <- kcLookupTcTyCon fam_tc_name+           ; mapM_ (kcTyFamInstEqn (famTyConShape fam_tc)) eqns }+      _ -> return ()++-------------------+kcConDecl :: ConDecl Name -> TcM ()+kcConDecl (ConDeclH98 { con_name = name, con_qvars = ex_tvs+                      , con_cxt = ex_ctxt, con_details = details })+  = addErrCtxt (dataConCtxtName [name]) $+         -- the 'False' says that the existentials don't have a CUSK, as the+         -- concept doesn't really apply here. We just need to bring the variables+         -- into scope.+    do { _ <- kcHsTyVarBndrs (unLoc name) False False False False+                             ((fromMaybe emptyLHsQTvs ex_tvs)) $+              do { _ <- tcHsContext (fromMaybe (noLoc []) ex_ctxt)+                 ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys details)+                 ; return (panic "kcConDecl", ()) }+              -- We don't need to check the telescope here, because that's+              -- done in tcConDecl+       ; return () }++kcConDecl (ConDeclGADT { con_names = names+                       , con_type = ty })+  = addErrCtxt (dataConCtxtName names) $+      do { _ <- tcGadtSigType (ppr names) (unLoc $ head names) ty+         ; return () }+++{-+Note [Recursion and promoting data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don't want to allow promotion in a strongly connected component+when kind checking.++Consider:+  data T f = K (f (K Any))++When kind checking the `data T' declaration the local env contains the+mappings:+  T -> ATcTyCon <some initial kind>+  K -> APromotionErr++APromotionErr is only used for DataCons, and only used during type checking+in tcTyClGroup.+++************************************************************************+*                                                                      *+\subsection{Type checking}+*                                                                      *+************************************************************************++Note [Type checking recursive type and class declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+At this point we have completed *kind-checking* of a mutually+recursive group of type/class decls (done in kcTyClGroup). However,+we discarded the kind-checked types (eg RHSs of data type decls);+note that kcTyClDecl returns ().  There are two reasons:++  * It's convenient, because we don't have to rebuild a+    kinded HsDecl (a fairly elaborate type)++  * It's necessary, because after kind-generalisation, the+    TyCons/Classes may now be kind-polymorphic, and hence need+    to be given kind arguments.++Example:+       data T f a = MkT (f a) (T f a)+During kind-checking, we give T the kind T :: k1 -> k2 -> *+and figure out constraints on k1, k2 etc. Then we generalise+to get   T :: forall k. (k->*) -> k -> *+So now the (T f a) in the RHS must be elaborated to (T k f a).++However, during tcTyClDecl of T (above) we will be in a recursive+"knot". So we aren't allowed to look at the TyCon T itself; we are only+allowed to put it (lazily) in the returned structures.  But when+kind-checking the RHS of T's decl, we *do* need to know T's kind (so+that we can correctly elaboarate (T k f a).  How can we get T's kind+without looking at T?  Delicate answer: during tcTyClDecl, we extend++  *Global* env with T -> ATyCon (the (not yet built) final TyCon for T)+  *Local*  env with T -> ATcTyCon (TcTyCon with the polymorphic kind of T)++Then:++  * During TcHsType.kcTyVar we look in the *local* env, to get the+    known kind for T.++  * But in TcHsType.ds_type (and ds_var_app in particular) we look in+    the *global* env to get the TyCon. But we must be careful not to+    force the TyCon or we'll get a loop.++This fancy footwork (with two bindings for T) is only necessary for the+TyCons or Classes of this recursive group.  Earlier, finished groups,+live in the global env only.++See also Note [Kind checking recursive type and class declarations]++Note [Kind checking recursive type and class declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Before we can type-check the decls, we must kind check them. This+is done by establishing an "initial kind", which is a rather uninformed+guess at a tycon's kind (by counting arguments, mainly) and then+using this initial kind for recursive occurrences.++The initial kind is stored in exactly the same way during kind-checking+as it is during type-checking (Note [Type checking recursive type and class+declarations]): in the *local* environment, with ATcTyCon. But we still+must store *something* in the *global* environment. Even though we+discard the result of kind-checking, we sometimes need to produce error+messages. These error messages will want to refer to the tycons being+checked, except that they don't exist yet, and it would be Terribly+Annoying to get the error messages to refer back to HsSyn. So we+create a TcTyCon and put it in the global env. This tycon can+print out its name and knows its kind,+but any other action taken on it will panic. Note+that TcTyCons are *not* knot-tied, unlike the rather valid but+knot-tied ones that occur during type-checking.++Note [Declarations for wired-in things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For wired-in things we simply ignore the declaration+and take the wired-in information.  That avoids complications.+e.g. the need to make the data constructor worker name for+     a constraint tuple match the wired-in one+-}++tcTyClDecl :: RolesInfo -> LTyClDecl Name -> TcM TyCon+tcTyClDecl roles_info (L loc decl)+  | Just thing <- wiredInNameTyThing_maybe (tcdName decl)+  = case thing of -- See Note [Declarations for wired-in things]+      ATyCon tc -> return tc+      _ -> pprPanic "tcTyClDecl" (ppr thing)++  | otherwise+  = setSrcSpan loc $ tcAddDeclCtxt decl $+    do { traceTc "tcTyAndCl-x" (ppr decl)+       ; tcTyClDecl1 Nothing roles_info decl }++  -- "type family" declarations+tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl Name -> TcM TyCon+tcTyClDecl1 parent _roles_info (FamDecl { tcdFam = fd })+  = tcFamDecl1 parent fd++  -- "type" synonym declaration+tcTyClDecl1 _parent roles_info+            (SynDecl { tcdLName = L _ tc_name, tcdRhs = rhs })+  = ASSERT( isNothing _parent )+    tcTyClTyVars tc_name $ \ binders res_kind ->+    tcTySynRhs roles_info tc_name binders res_kind rhs++  -- "data/newtype" declaration+tcTyClDecl1 _parent roles_info+            (DataDecl { tcdLName = L _ tc_name, tcdDataDefn = defn })+  = ASSERT( isNothing _parent )+    tcTyClTyVars tc_name $ \ tycon_binders res_kind ->+    tcDataDefn roles_info tc_name tycon_binders res_kind defn++tcTyClDecl1 _parent roles_info+            (ClassDecl { tcdLName = L _ class_name+            , tcdCtxt = ctxt, tcdMeths = meths+            , tcdFDs = fundeps, tcdSigs = sigs+            , tcdATs = ats, tcdATDefs = at_defs })+  = ASSERT( isNothing _parent )+    do { clas <- fixM $ \ clas ->+            -- We need the knot because 'clas' is passed into tcClassATs+            tcTyClTyVars class_name $ \ binders res_kind ->+            do { MASSERT( isConstraintKind res_kind )+               ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr binders)+               ; let tycon_name = class_name        -- We use the same name+                     roles = roles_info tycon_name  -- for TyCon and Class++               ; ctxt' <- solveEqualities $ tcHsContext ctxt+               ; ctxt' <- zonkTcTypeToTypes emptyZonkEnv ctxt'+                       -- Squeeze out any kind unification variables+               ; fds'  <- mapM (addLocM tc_fundep) fundeps+               ; sig_stuff <- tcClassSigs class_name sigs meths+               ; at_stuff <- tcClassATs class_name clas ats at_defs+               ; mindef <- tcClassMinimalDef class_name sigs sig_stuff+               -- TODO: Allow us to distinguish between abstract class,+               -- and concrete class with no methods (maybe by+               -- specifying a trailing where or not+               ; is_boot <- tcIsHsBootOrSig+               ; let body | is_boot, null ctxt', null at_stuff, null sig_stuff+                          = Nothing+                          | otherwise+                          = Just (ctxt', at_stuff, sig_stuff, mindef)+               ; clas <- buildClass class_name binders roles fds' body+               ; traceTc "tcClassDecl" (ppr fundeps $$ ppr binders $$+                                        ppr fds')+               ; return clas }++         ; return (classTyCon clas) }+  where+    tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ;+                                ; tvs2' <- mapM (tcLookupTyVar . unLoc) tvs2 ;+                                ; return (tvs1', tvs2') }++tcFamDecl1 :: Maybe Class -> FamilyDecl Name -> TcM TyCon+tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_name)+                              , fdTyVars = tvs, fdResultSig = L _ sig+                              , fdInjectivityAnn = inj })+  | DataFamily <- fam_info+  = tcTyClTyVars tc_name $ \ binders res_kind -> do+  { traceTc "data family:" (ppr tc_name)+  ; checkFamFlag tc_name+  ; (extra_binders, real_res_kind) <- tcDataKindSig res_kind+  ; tc_rep_name <- newTyConRepName tc_name+  ; let tycon = mkFamilyTyCon tc_name (binders `chkAppend` extra_binders)+                              real_res_kind+                              (resultVariableName sig)+                              (DataFamilyTyCon tc_rep_name)+                              parent NotInjective+  ; return tycon }++  | OpenTypeFamily <- fam_info+  = tcTyClTyVars tc_name $ \ binders res_kind -> do+  { traceTc "open type family:" (ppr tc_name)+  ; checkFamFlag tc_name+  ; inj' <- tcInjectivity binders inj+  ; let tycon = mkFamilyTyCon tc_name binders res_kind+                               (resultVariableName sig) OpenSynFamilyTyCon+                               parent inj'+  ; return tycon }++  | ClosedTypeFamily mb_eqns <- fam_info+  = -- Closed type families are a little tricky, because they contain the definition+    -- of both the type family and the equations for a CoAxiom.+    do { traceTc "Closed type family:" (ppr tc_name)+         -- the variables in the header scope only over the injectivity+         -- declaration but this is not involved here+       ; (inj', binders, res_kind)+            <- tcTyClTyVars tc_name+               $ \ binders res_kind ->+               do { inj' <- tcInjectivity binders inj+                  ; return (inj', binders, res_kind) }++       ; checkFamFlag tc_name -- make sure we have -XTypeFamilies++         -- If Nothing, this is an abstract family in a hs-boot file;+         -- but eqns might be empty in the Just case as well+       ; case mb_eqns of+           Nothing   ->+               return $ mkFamilyTyCon tc_name binders res_kind+                                      (resultVariableName sig)+                                      AbstractClosedSynFamilyTyCon parent+                                      inj'+           Just eqns -> do {++         -- Process the equations, creating CoAxBranches+       ; let fam_tc_shape = (tc_name, length $ hsQTvExplicit tvs, binders, res_kind)++       ; branches <- mapM (tcTyFamInstEqn fam_tc_shape Nothing) eqns+         -- Do not attempt to drop equations dominated by earlier+         -- ones here; in the case of mutual recursion with a data+         -- type, we get a knot-tying failure.  Instead we check+         -- for this afterwards, in TcValidity.checkValidCoAxiom+         -- Example: tc265++         -- Create a CoAxiom, with the correct src location. It is Vitally+         -- Important that we do not pass the branches into+         -- newFamInstAxiomName. They have types that have been zonked inside+         -- the knot and we will die if we look at them. This is OK here+         -- because there will only be one axiom, so we don't need to+         -- differentiate names.+         -- See [Zonking inside the knot] in TcHsType+       ; co_ax_name <- newFamInstAxiomName tc_lname []++       ; let mb_co_ax+              | null eqns = Nothing   -- mkBranchedCoAxiom fails on empty list+              | otherwise = Just (mkBranchedCoAxiom co_ax_name fam_tc branches)++             fam_tc = mkFamilyTyCon tc_name binders res_kind (resultVariableName sig)+                      (ClosedSynFamilyTyCon mb_co_ax) parent inj'++         -- We check for instance validity later, when doing validity+         -- checking for the tycon. Exception: checking equations+         -- overlap done by dropDominatedAxioms+       ; return fam_tc } }++  | otherwise = panic "tcFamInst1"  -- Silence pattern-exhaustiveness checker+++-- | Maybe return a list of Bools that say whether a type family was declared+-- injective in the corresponding type arguments. Length of the list is equal to+-- the number of arguments (including implicit kind/coercion arguments).+-- True on position+-- N means that a function is injective in its Nth argument. False means it is+-- not.+tcInjectivity :: [TyConBinder] -> Maybe (LInjectivityAnn Name)+              -> TcM Injectivity+tcInjectivity _ Nothing+  = return NotInjective++  -- User provided an injectivity annotation, so for each tyvar argument we+  -- check whether a type family was declared injective in that argument. We+  -- return a list of Bools, where True means that corresponding type variable+  -- was mentioned in lInjNames (type family is injective in that argument) and+  -- False means that it was not mentioned in lInjNames (type family is not+  -- injective in that type variable). We also extend injectivity information to+  -- kind variables, so if a user declares:+  --+  --   type family F (a :: k1) (b :: k2) = (r :: k3) | r -> a+  --+  -- then we mark both `a` and `k1` as injective.+  -- NB: the return kind is considered to be *input* argument to a type family.+  -- Since injectivity allows to infer input arguments from the result in theory+  -- we should always mark the result kind variable (`k3` in this example) as+  -- injective.  The reason is that result type has always an assigned kind and+  -- therefore we can always infer the result kind if we know the result type.+  -- But this does not seem to be useful in any way so we don't do it.  (Another+  -- reason is that the implementation would not be straightforward.)+tcInjectivity tcbs (Just (L loc (InjectivityAnn _ lInjNames)))+  = setSrcSpan loc $+    do { let tvs = binderVars tcbs+       ; dflags <- getDynFlags+       ; checkTc (xopt LangExt.TypeFamilyDependencies dflags)+                 (text "Illegal injectivity annotation" $$+                  text "Use TypeFamilyDependencies to allow this")+       ; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames+       ; inj_tvs <- mapM zonkTcTyVarToTyVar inj_tvs -- zonk the kinds+       ; let inj_ktvs = filterVarSet isTyVar $  -- no injective coercion vars+                        closeOverKinds (mkVarSet inj_tvs)+       ; let inj_bools = map (`elemVarSet` inj_ktvs) tvs+       ; traceTc "tcInjectivity" (vcat [ ppr tvs, ppr lInjNames, ppr inj_tvs+                                       , ppr inj_ktvs, ppr inj_bools ])+       ; return $ Injective inj_bools }++tcTySynRhs :: RolesInfo+           -> Name+           -> [TyConBinder] -> Kind+           -> LHsType Name -> TcM TyCon+tcTySynRhs roles_info tc_name binders res_kind hs_ty+  = do { env <- getLclEnv+       ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env))+       ; rhs_ty <- solveEqualities $ tcCheckLHsType hs_ty res_kind+       ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty+       ; let roles = roles_info tc_name+             tycon = buildSynTyCon tc_name binders res_kind roles rhs_ty+       ; return tycon }++tcDataDefn :: RolesInfo -> Name+           -> [TyConBinder] -> Kind+           -> HsDataDefn Name -> TcM TyCon+  -- NB: not used for newtype/data instances (whether associated or not)+tcDataDefn roles_info+           tc_name tycon_binders res_kind+         (HsDataDefn { dd_ND = new_or_data, dd_cType = cType+                     , dd_ctxt = ctxt, dd_kindSig = mb_ksig+                     , dd_cons = cons })+ =  do { (extra_bndrs, real_res_kind) <- tcDataKindSig res_kind+       ; let final_bndrs  = tycon_binders `chkAppend` extra_bndrs+             roles        = roles_info tc_name++       ; stupid_tc_theta <- solveEqualities $ tcHsContext ctxt+       ; stupid_theta    <- zonkTcTypeToTypes emptyZonkEnv+                                              stupid_tc_theta+       ; kind_signatures <- xoptM LangExt.KindSignatures+       ; tcg_env         <- getGblEnv+       ; let hsc_src = tcg_src tcg_env++             -- Check that we don't use kind signatures without Glasgow extensions+       ; when (isJust mb_ksig) $+         checkTc (kind_signatures) (badSigTyDecl tc_name)++       ; gadt_syntax <- dataDeclChecks tc_name new_or_data stupid_theta cons++       ; tycon <- fixM $ \ tycon -> do+             { let res_ty = mkTyConApp tycon (mkTyVarTys (binderVars final_bndrs))+             ; data_cons <- tcConDecls tycon (final_bndrs, res_ty) cons+             ; tc_rhs    <- mk_tc_rhs hsc_src tycon data_cons+             ; tc_rep_nm <- newTyConRepName tc_name+             ; return (mkAlgTyCon tc_name+                                  final_bndrs+                                  real_res_kind+                                  roles+                                  (fmap unLoc cType)+                                  stupid_theta tc_rhs+                                  (VanillaAlgTyCon tc_rep_nm)+                                  gadt_syntax) }+       ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tycon_binders $$ ppr extra_bndrs)+       ; return tycon }+  where+    -- In hs-boot, a 'data' declaration with no constructors+    -- indicates an nominally distinct abstract data type.+    mk_tc_rhs HsBootFile _ []+      = return AbstractTyCon++    mk_tc_rhs HsigFile _ [] -- ditto+      = return AbstractTyCon++    mk_tc_rhs _ tycon data_cons+      = case new_or_data of+          DataType -> return (mkDataTyConRhs data_cons)+          NewType  -> ASSERT( not (null data_cons) )+                      mkNewTyConRhs tc_name tycon (head data_cons)++{-+************************************************************************+*                                                                      *+               Typechecking associated types (in class decls)+               (including the associated-type defaults)+*                                                                      *+************************************************************************++Note [Associated type defaults]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The following is an example of associated type defaults:+             class C a where+               data D a++               type F a b :: *+               type F a b = [a]        -- Default++Note that we can get default definitions only for type families, not data+families.+-}++tcClassATs :: Name                  -- The class name (not knot-tied)+           -> Class                 -- The class parent of this associated type+           -> [LFamilyDecl Name]    -- Associated types.+           -> [LTyFamDefltEqn Name] -- Associated type defaults.+           -> TcM [ClassATItem]+tcClassATs class_name cls ats at_defs+  = do {  -- Complain about associated type defaults for non associated-types+         sequence_ [ failWithTc (badATErr class_name n)+                   | n <- map at_def_tycon at_defs+                   , not (n `elemNameSet` at_names) ]+       ; mapM tc_at ats }+  where+    at_def_tycon :: LTyFamDefltEqn Name -> Name+    at_def_tycon (L _ eqn) = unLoc (tfe_tycon eqn)++    at_fam_name :: LFamilyDecl Name -> Name+    at_fam_name (L _ decl) = unLoc (fdLName decl)++    at_names = mkNameSet (map at_fam_name ats)++    at_defs_map :: NameEnv [LTyFamDefltEqn Name]+    -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs'+    at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv+                                          (at_def_tycon at_def) [at_def])+                        emptyNameEnv at_defs++    tc_at at = do { fam_tc <- addLocM (tcFamDecl1 (Just cls)) at+                  ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at)+                                  `orElse` []+                  ; atd <- tcDefaultAssocDecl fam_tc at_defs+                  ; return (ATI fam_tc atd) }++-------------------------+tcDefaultAssocDecl :: TyCon                    -- ^ Family TyCon (not knot-tied)+                   -> [LTyFamDefltEqn Name]         -- ^ Defaults+                   -> TcM (Maybe (Type, SrcSpan))   -- ^ Type checked RHS+tcDefaultAssocDecl _ []+  = return Nothing  -- No default declaration++tcDefaultAssocDecl _ (d1:_:_)+  = failWithTc (text "More than one default declaration for"+                <+> ppr (tfe_tycon (unLoc d1)))++tcDefaultAssocDecl fam_tc [L loc (TyFamEqn { tfe_tycon = L _ tc_name+                                           , tfe_pats = hs_tvs+                                           , tfe_rhs = rhs })]+  | HsQTvs { hsq_implicit = imp_vars, hsq_explicit = exp_vars } <- hs_tvs+  = -- See Note [Type-checking default assoc decls]+    setSrcSpan loc $+    tcAddFamInstCtxt (text "default type instance") tc_name $+    do { traceTc "tcDefaultAssocDecl" (ppr tc_name)+       ; let shape@(fam_tc_name, fam_arity, _, _) = famTyConShape fam_tc++       -- Kind of family check+       ; ASSERT( fam_tc_name == tc_name )+         checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)++       -- Arity check+       ; checkTc (length exp_vars == fam_arity)+                 (wrongNumberOfParmsErr fam_arity)++       -- Typecheck RHS+       ; let pats = HsIB { hsib_vars = imp_vars ++ map hsLTyVarName exp_vars+                         , hsib_body = map hsLTyVarBndrToType exp_vars+                         , hsib_closed = False } -- this field is ignored, anyway+          -- NB: Use tcFamTyPats, not tcTyClTyVars. The latter expects to get+          -- the LHsQTyVars used for declaring a tycon, but the names here+          -- are different.+       ; (pats', rhs_ty)+           <- tcFamTyPats shape Nothing pats+              (discardResult . tcCheckLHsType rhs) $ \tvs pats rhs_kind ->+              do { rhs_ty <- solveEqualities $+                             tcCheckLHsType rhs rhs_kind++                     -- Zonk the patterns etc into the Type world+                 ; (ze, _) <- zonkTyBndrsX emptyZonkEnv tvs+                 ; pats'   <- zonkTcTypeToTypes ze pats+                 ; rhs_ty'  <- zonkTcTypeToType ze rhs_ty+                 ; return (pats', rhs_ty') }++         -- See Note [Type-checking default assoc decls]+       ; case tcMatchTys pats' (mkTyVarTys (tyConTyVars fam_tc)) of+           Just subst -> return (Just (substTyUnchecked subst rhs_ty, loc) )+           Nothing    -> failWithTc (defaultAssocKindErr fam_tc)+           -- We check for well-formedness and validity later,+           -- in checkValidClass+     }++{- Note [Type-checking default assoc decls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this default declaration for an associated type++   class C a where+      type F (a :: k) b :: *+      type F x y = Proxy x -> y++Note that the class variable 'a' doesn't scope over the default assoc+decl (rather oddly I think), and (less oddly) neither does the second+argument 'b' of the associated type 'F', or the kind variable 'k'.+Instead, the default decl is treated more like a top-level type+instance.++However we store the default rhs (Proxy x -> y) in F's TyCon, using+F's own type variables, so we need to convert it to (Proxy a -> b).+We do this by calling tcMatchTys to match them up.  This also ensures+that x's kind matches a's and similarly for y and b.  The error+message isn't great, mind you.  (Trac #11361 was caused by not doing a+proper tcMatchTys here.)  -}++-------------------------+kcTyFamInstEqn :: FamTyConShape -> LTyFamInstEqn Name -> TcM ()+kcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_,_)+    (L loc (TyFamEqn { tfe_tycon = L _ eqn_tc_name+                     , tfe_pats  = pats+                     , tfe_rhs   = hs_ty }))+  = setSrcSpan loc $+    do { checkTc (fam_tc_name == eqn_tc_name)+                 (wrongTyFamName fam_tc_name eqn_tc_name)+       ; discardResult $+         tc_fam_ty_pats fam_tc_shape Nothing -- not an associated type+                        pats (discardResult . (tcCheckLHsType hs_ty)) }++tcTyFamInstEqn :: FamTyConShape -> Maybe ClsInstInfo -> LTyFamInstEqn Name -> TcM CoAxBranch+-- Needs to be here, not in TcInstDcls, because closed families+-- (typechecked here) have TyFamInstEqns+tcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_,_) mb_clsinfo+    (L loc (TyFamEqn { tfe_tycon = L _ eqn_tc_name+                     , tfe_pats  = pats+                     , tfe_rhs   = hs_ty }))+  = ASSERT( fam_tc_name == eqn_tc_name )+    setSrcSpan loc $+    tcFamTyPats fam_tc_shape mb_clsinfo pats+                (discardResult . (tcCheckLHsType hs_ty)) $+                    \tvs pats res_kind ->+    do { rhs_ty <- solveEqualities $ tcCheckLHsType hs_ty res_kind++       ; (ze, tvs') <- zonkTyBndrsX emptyZonkEnv tvs+       ; pats'      <- zonkTcTypeToTypes ze pats+       ; rhs_ty'    <- zonkTcTypeToType ze rhs_ty+       ; traceTc "tcTyFamInstEqn" (ppr fam_tc_name <+> pprTyVars tvs')+          -- don't print out the pats here, as they might be zonked inside the knot+       ; return (mkCoAxBranch tvs' [] pats' rhs_ty'+                              (map (const Nominal) tvs')+                              loc) }++kcDataDefn :: Name                -- ^ the family name, for error msgs only+           -> HsTyPats Name       -- ^ the patterns, for error msgs only+           -> HsDataDefn Name     -- ^ the RHS+           -> TcKind              -- ^ the expected kind+           -> TcM ()+-- Used for 'data instance' only+-- Ordinary 'data' is handled by kcTyClDec+kcDataDefn fam_name (HsIB { hsib_body = pats })+           (HsDataDefn { dd_ctxt = ctxt, dd_cons = cons, dd_kindSig = mb_kind }) res_k+  = do  { _ <- tcHsContext ctxt+        ; checkNoErrs $ mapM_ (wrapLocM kcConDecl) cons+          -- See Note [Failing early in kcDataDefn]+        ; discardResult $+          case mb_kind of+            Nothing -> unifyKind (Just hs_ty_pats) res_k liftedTypeKind+            Just k  -> do { k' <- tcLHsKindSig k+                          ; unifyKind (Just hs_ty_pats) res_k k' } }+  where+    hs_ty_pats = mkHsAppTys (noLoc $ HsTyVar NotPromoted (noLoc fam_name)) pats++{-+Kind check type patterns and kind annotate the embedded type variables.+     type instance F [a] = rhs++ * Here we check that a type instance matches its kind signature, but we do+   not check whether there is a pattern for each type index; the latter+   check is only required for type synonym instances.++Note [tc_fam_ty_pats vs tcFamTyPats]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+tc_fam_ty_pats does the type checking of the patterns, but it doesn't+zonk or generate any desugaring. It is used when kind-checking closed+type families.++tcFamTyPats type checks the patterns, zonks, and then calls thing_inside+to generate a desugaring. It is used during type-checking (not kind-checking).++Note [Type-checking type patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When typechecking the patterns of a family instance declaration, we can't+rely on using the family TyCon, because this is sometimes called+from within a type-checking knot. (Specifically for closed type families.)+The type FamTyConShape gives just enough information to do the job.++See also Note [tc_fam_ty_pats vs tcFamTyPats]++Note [Failing early in kcDataDefn]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to use checkNoErrs when calling kcConDecl. This is because kcConDecl+calls tcConDecl, which checks that the return type of a GADT-like constructor+is actually an instance of the type head. Without the checkNoErrs, potentially+two bad things could happen:++ 1) Duplicate error messages, because tcConDecl will be called again during+    *type* checking (as opposed to kind checking)+ 2) If we just keep blindly forging forward after both kind checking and type+    checking, we can get a panic in rejigConRes. See Trac #8368.+-}++-----------------+type FamTyConShape = (Name, Arity, [TyConBinder], Kind)+  -- See Note [Type-checking type patterns]++famTyConShape :: TyCon -> FamTyConShape+famTyConShape fam_tc+  = ( tyConName fam_tc+    , length $ filterOutInvisibleTyVars fam_tc (tyConTyVars fam_tc)+    , tyConBinders fam_tc+    , tyConResKind fam_tc )++tc_fam_ty_pats :: FamTyConShape+               -> Maybe ClsInstInfo+               -> HsTyPats Name       -- Patterns+               -> (TcKind -> TcM ())  -- Kind checker for RHS+                                      -- result is ignored+               -> TcM ([Type], Kind)+-- Check the type patterns of a type or data family instance+--     type instance F <pat1> <pat2> = <type>+-- The 'tyvars' are the free type variables of pats+--+-- NB: The family instance declaration may be an associated one,+-- nested inside an instance decl, thus+--        instance C [a] where+--          type F [a] = ...+-- In that case, the type variable 'a' will *already be in scope*+-- (and, if C is poly-kinded, so will its kind parameter).++tc_fam_ty_pats (name, _, binders, res_kind) mb_clsinfo+               (HsIB { hsib_body = arg_pats, hsib_vars = tv_names })+               kind_checker+  = do { -- Kind-check and quantify+         -- See Note [Quantifying over family patterns]+         (_, (insted_res_kind, typats)) <- tcImplicitTKBndrs tv_names $+         do { (insting_subst, _leftover_binders, args, leftovers, n)+                <- tcInferArgs name binders (thdOf3 <$> mb_clsinfo) arg_pats+            ; case leftovers of+                hs_ty:_ -> addErrTc $ too_many_args hs_ty n+                _       -> return ()+              -- don't worry about leftover_binders; TcValidity catches them++            ; let insted_res_kind = substTyUnchecked insting_subst res_kind+            ; kind_checker insted_res_kind+            ; return ((insted_res_kind, args), emptyVarSet) }++       ; return (typats, insted_res_kind) }+  where+    too_many_args hs_ty n+      = hang (text "Too many parameters to" <+> ppr name <> colon)+           2 (vcat [ ppr hs_ty <+> text "is unexpected;"+                   , text (if n == 1 then "expected" else "expected only") <+>+                     speakNOf (n-1) (text "parameter") ])++-- See Note [tc_fam_ty_pats vs tcFamTyPats]+tcFamTyPats :: FamTyConShape+            -> Maybe ClsInstInfo+            -> HsTyPats Name         -- patterns+            -> (TcKind -> TcM ())    -- kind-checker for RHS+            -> (   [TcTyVar]         -- Kind and type variables+                -> [TcType]          -- Kind and type arguments+                -> TcKind+                -> TcM a)            -- NB: You can use solveEqualities here.+            -> TcM a+tcFamTyPats fam_shape@(name,_,_,_) mb_clsinfo pats kind_checker thing_inside+  = do { (typats, res_kind)+            <- solveEqualities $  -- See Note [Constraints in patterns]+               tc_fam_ty_pats fam_shape mb_clsinfo pats kind_checker++          {- TODO (RAE): This should be cleverer. Consider this:++                 type family F a++                 data G a where+                   MkG :: F a ~ Bool => G a++                 type family Foo (x :: G a) :: F a+                 type instance Foo MkG = False++             This should probably be accepted. Yet the solveEqualities+             will fail, unable to solve (F a ~ Bool)+             We want to quantify over that proof.+             But see Note [Constraints in patterns]+             below, which is missing this piece. -}+++            -- Find free variables (after zonking) and turn+            -- them into skolems, so that we don't subsequently+            -- replace a meta kind var with (Any *)+            -- Very like kindGeneralize+       ; vars  <- zonkTcTypesAndSplitDepVars typats+       ; qtkvs <- quantifyZonkedTyVars emptyVarSet vars++       ; MASSERT( isEmptyVarSet $ coVarsOfTypes typats )+           -- This should be the case, because otherwise the solveEqualities+           -- above would fail. TODO (RAE): Update once the solveEqualities+           -- bit is cleverer.++       ; traceTc "tcFamTyPats" (ppr name $$ ppr typats $$ ppr qtkvs)+            -- Don't print out too much, as we might be in the knot++       ; tcExtendTyVarEnv qtkvs $+            -- Extend envt with TcTyVars not TyVars, because the+            -- kind checking etc done by thing_inside does not expect+            -- to encounter TyVars; it expects TcTyVars+         thing_inside qtkvs typats res_kind }++{-+Note [Constraints in patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+NB: This isn't the whole story. See comment in tcFamTyPats.++At first glance, it seems there is a complicated story to tell in tcFamTyPats+around constraint solving. After all, type family patterns can now do+GADT pattern-matching, which is jolly complicated. But, there's a key fact+which makes this all simple: everything is at top level! There cannot+be untouchable type variables. There can't be weird interaction between+case branches. There can't be global skolems.++This means that the semantics of type-level GADT matching is a little+different than term level. If we have++  data G a where+    MkGBool :: G Bool++And then++  type family F (a :: G k) :: k+  type instance F MkGBool = True++we get++  axF : F Bool (MkGBool <Bool>) ~ True++Simple! No casting on the RHS, because we can affect the kind parameter+to F.++If we ever introduce local type families, this all gets a lot more+complicated, and will end up looking awfully like term-level GADT+pattern-matching.+++** The new story **++Here is really what we want:++The matcher really can't deal with covars in arbitrary spots in coercions.+But it can deal with covars that are arguments to GADT data constructors.+So we somehow want to allow covars only in precisely those spots, then use+them as givens when checking the RHS. TODO (RAE): Implement plan.+++Note [Quantifying over family patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to quantify over two different lots of kind variables:++First, the ones that come from the kinds of the tyvar args of+tcTyVarBndrsKindGen, as usual+  data family Dist a++  -- Proxy :: forall k. k -> *+  data instance Dist (Proxy a) = DP+  -- Generates  data DistProxy = DP+  --            ax8 k (a::k) :: Dist * (Proxy k a) ~ DistProxy k a+  -- The 'k' comes from the tcTyVarBndrsKindGen (a::k)++Second, the ones that come from the kind argument of the type family+which we pick up using the (tyCoVarsOfTypes typats) in the result of+the thing_inside of tcHsTyvarBndrsGen.+  -- Any :: forall k. k+  data instance Dist Any = DA+  -- Generates  data DistAny k = DA+  --            ax7 k :: Dist k (Any k) ~ DistAny k+  -- The 'k' comes from kindGeneralizeKinds (Any k)++Note [Quantified kind variables of a family pattern]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider   type family KindFam (p :: k1) (q :: k1)+           data T :: Maybe k1 -> k2 -> *+           type instance KindFam (a :: Maybe k) b = T a b -> Int+The HsBSig for the family patterns will be ([k], [a])++Then in the family instance we want to+  * Bring into scope [ "k" -> k:*, "a" -> a:k ]+  * Kind-check the RHS+  * Quantify the type instance over k and k', as well as a,b, thus+       type instance [k, k', a:Maybe k, b:k']+                     KindFam (Maybe k) k' a b = T k k' a b -> Int++Notice that in the third step we quantify over all the visibly-mentioned+type variables (a,b), but also over the implicitly mentioned kind variables+(k, k').  In this case one is bound explicitly but often there will be+none. The role of the kind signature (a :: Maybe k) is to add a constraint+that 'a' must have that kind, and to bring 'k' into scope.++++************************************************************************+*                                                                      *+               Data types+*                                                                      *+************************************************************************+-}++dataDeclChecks :: Name -> NewOrData -> ThetaType -> [LConDecl Name] -> TcM Bool+dataDeclChecks tc_name new_or_data stupid_theta cons+  = do {   -- Check that we don't use GADT syntax in H98 world+         gadtSyntax_ok <- xoptM LangExt.GADTSyntax+       ; let gadt_syntax = consUseGadtSyntax cons+       ; checkTc (gadtSyntax_ok || not gadt_syntax) (badGadtDecl tc_name)++           -- Check that the stupid theta is empty for a GADT-style declaration+       ; checkTc (null stupid_theta || not gadt_syntax) (badStupidTheta tc_name)++         -- Check that a newtype has exactly one constructor+         -- Do this before checking for empty data decls, so that+         -- we don't suggest -XEmptyDataDecls for newtypes+       ; checkTc (new_or_data == DataType || isSingleton cons)+                (newtypeConError tc_name (length cons))++                -- Check that there's at least one condecl,+         -- or else we're reading an hs-boot file, or -XEmptyDataDecls+       ; empty_data_decls <- xoptM LangExt.EmptyDataDecls+       ; is_boot <- tcIsHsBootOrSig  -- Are we compiling an hs-boot file?+       ; checkTc (not (null cons) || empty_data_decls || is_boot)+                 (emptyConDeclsErr tc_name)+       ; return gadt_syntax }+++-----------------------------------+consUseGadtSyntax :: [LConDecl a] -> Bool+consUseGadtSyntax (L _ (ConDeclGADT { }) : _) = True+consUseGadtSyntax _                           = False+                 -- All constructors have same shape++-----------------------------------+tcConDecls :: TyCon -> ([TyConBinder], Type)+           -> [LConDecl Name] -> TcM [DataCon]+  -- Why both the tycon tyvars and binders? Because the tyvars+  -- have all the names and the binders have the visibilities.+tcConDecls rep_tycon (tmpl_bndrs, res_tmpl)+  = concatMapM $ addLocM $+    tcConDecl rep_tycon tmpl_bndrs res_tmpl++tcConDecl :: TyCon             -- Representation tycon. Knot-tied!+          -> [TyConBinder] -> Type+                 -- Return type template (with its template tyvars)+                 --    (tvs, T tys), where T is the family TyCon+          -> ConDecl Name+          -> TcM [DataCon]++tcConDecl rep_tycon tmpl_bndrs res_tmpl+          (ConDeclH98 { con_name = name+                      , con_qvars = hs_qvars, con_cxt = hs_ctxt+                      , con_details = hs_details })+  = addErrCtxt (dataConCtxtName [name]) $+    do { traceTc "tcConDecl 1" (ppr name)+       ; let (hs_kvs, hs_tvs) = case hs_qvars of+               Nothing -> ([], [])+               Just (HsQTvs { hsq_implicit = kvs, hsq_explicit = tvs })+                       -> (kvs, tvs)+       ; (imp_tvs, (exp_tvs, ctxt, arg_tys, field_lbls, stricts))+           <- solveEqualities $+              tcImplicitTKBndrs hs_kvs $+              tcExplicitTKBndrs hs_tvs $ \ exp_tvs ->+              do { traceTc "tcConDecl" (ppr name <+> text "tvs:" <+> ppr hs_tvs)+                 ; ctxt <- tcHsContext (fromMaybe (noLoc []) hs_ctxt)+                 ; btys <- tcConArgs hs_details+                 ; field_lbls <- lookupConstructorFields (unLoc name)+                 ; let (arg_tys, stricts) = unzip btys+                       bound_vars  = allBoundVariabless ctxt `unionVarSet`+                                     allBoundVariabless arg_tys+                 ; return ((exp_tvs, ctxt, arg_tys, field_lbls, stricts), bound_vars)+                 }+         -- imp_tvs are user-written kind variables, without an explicit binding site+         -- exp_tvs have binding sites+         -- the kvs below are those kind variables entirely unmentioned by the user+         --   and discovered only by generalization++             -- Kind generalisation+       ; let all_user_tvs = imp_tvs ++ exp_tvs+       ; vars <- zonkTcTypeAndSplitDepVars (mkSpecForAllTys all_user_tvs $+                                            mkFunTys ctxt $+                                            mkFunTys arg_tys $+                                            unitTy)+                 -- That type is a lie, of course. (It shouldn't end in ()!)+                 -- And we could construct a proper result type from the info+                 -- at hand. But the result would mention only the tmpl_tvs,+                 -- and so it just creates more work to do it right. Really,+                 -- we're doing this to get the right behavior around removing+                 -- any vars bound in exp_binders.++       ; kvs <- quantifyZonkedTyVars (mkVarSet (binderVars tmpl_bndrs)) vars++             -- Zonk to Types+       ; (ze, qkvs)      <- zonkTyBndrsX emptyZonkEnv kvs+       ; (ze, user_qtvs) <- zonkTyBndrsX ze all_user_tvs+       ; arg_tys         <- zonkTcTypeToTypes ze arg_tys+       ; ctxt            <- zonkTcTypeToTypes ze ctxt++       ; fam_envs <- tcGetFamInstEnvs++       -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here+       ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls)+       ; let+           ex_tvs = mkTyVarBinders Inferred qkvs +++                    mkTyVarBinders Specified user_qtvs+           buildOneDataCon (L _ name) = do+             { is_infix <- tcConIsInfixH98 name hs_details+             ; rep_nm   <- newTyConRepName name++             ; buildDataCon fam_envs name is_infix rep_nm+                            stricts Nothing field_lbls+                            (mkDataConUnivTyVarBinders tmpl_bndrs)+                            ex_tvs+                            [{- no eq_preds -}] ctxt arg_tys+                            res_tmpl rep_tycon+                  -- NB:  we put data_tc, the type constructor gotten from the+                  --      constructor type signature into the data constructor;+                  --      that way checkValidDataCon can complain if it's wrong.+             }+       ; traceTc "tcConDecl 2" (ppr name)+       ; mapM buildOneDataCon [name]+       }++tcConDecl rep_tycon tmpl_bndrs res_tmpl+          (ConDeclGADT { con_names = names, con_type = ty })+  = addErrCtxt (dataConCtxtName names) $+    do { traceTc "tcConDecl 1" (ppr names)+       ; (user_tvs, ctxt, stricts, field_lbls, arg_tys, res_ty,hs_details)+           <- tcGadtSigType (ppr names) (unLoc $ head names) ty++       ; vars <- zonkTcTypeAndSplitDepVars (mkSpecForAllTys user_tvs $+                                            mkFunTys ctxt $+                                            mkFunTys arg_tys $+                                            res_ty)+       ; tkvs <- quantifyZonkedTyVars emptyVarSet vars++             -- Zonk to Types+       ; (ze, qtkvs) <- zonkTyBndrsX emptyZonkEnv (tkvs ++ user_tvs)+       ; arg_tys <- zonkTcTypeToTypes ze arg_tys+       ; ctxt    <- zonkTcTypeToTypes ze ctxt+       ; res_ty  <- zonkTcTypeToType ze res_ty++       ; let (univ_tvs, ex_tvs, eq_preds, res_ty', arg_subst)+               = rejigConRes tmpl_bndrs res_tmpl qtkvs res_ty+             -- NB: this is a /lazy/ binding, so we pass five thunks to buildDataCon+             --     without yet forcing the guards in rejigConRes+             -- See Note [Checking GADT return types]++             -- See Note [Wrong visibility for GADTs]+             univ_bndrs = mkTyVarBinders Specified univ_tvs+             ex_bndrs   = mkTyVarBinders Specified ex_tvs++       ; fam_envs <- tcGetFamInstEnvs++       -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here+       ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls)+       ; let+           buildOneDataCon (L _ name) = do+             { is_infix <- tcConIsInfixGADT name hs_details+             ; rep_nm   <- newTyConRepName name++             ; buildDataCon fam_envs name is_infix+                            rep_nm+                            stricts Nothing field_lbls+                            univ_bndrs ex_bndrs eq_preds+                            (substTys arg_subst ctxt)+                            (substTys arg_subst arg_tys)+                            (substTy  arg_subst res_ty')+                            rep_tycon+                  -- NB:  we put data_tc, the type constructor gotten from the+                  --      constructor type signature into the data constructor;+                  --      that way checkValidDataCon can complain if it's wrong.+             }+       ; traceTc "tcConDecl 2" (ppr names)+       ; mapM buildOneDataCon names+       }+++tcGadtSigType :: SDoc -> Name -> LHsSigType Name+              -> TcM ( [TcTyVar], [PredType],[HsSrcBang], [FieldLabel], [Type], Type+                     , HsConDetails (LHsType Name)+                                    (Located [LConDeclField Name]) )+tcGadtSigType doc name ty@(HsIB { hsib_vars = vars })+  = do { let (hs_details', res_ty', cxt, gtvs) = gadtDeclDetails ty+       ; (hs_details, res_ty) <- updateGadtResult failWithTc doc hs_details' res_ty'+       ; (imp_tvs, (exp_tvs, ctxt, arg_tys, res_ty, field_lbls, stricts))+           <- solveEqualities $+              tcImplicitTKBndrs vars $+              tcExplicitTKBndrs gtvs $ \ exp_tvs ->+              do { ctxt <- tcHsContext cxt+                 ; btys <- tcConArgs hs_details+                 ; ty' <- tcHsLiftedType res_ty+                 ; field_lbls <- lookupConstructorFields name+                 ; let (arg_tys, stricts) = unzip btys+                       bound_vars = allBoundVariabless ctxt `unionVarSet`+                                    allBoundVariabless arg_tys++                 ; return ((exp_tvs, ctxt, arg_tys, ty', field_lbls, stricts), bound_vars)+                 }+       ; return (imp_tvs ++ exp_tvs, ctxt, stricts, field_lbls, arg_tys, res_ty, hs_details)+       }++tcConIsInfixH98 :: Name+             -> HsConDetails (LHsType Name) (Located [LConDeclField Name])+             -> TcM Bool+tcConIsInfixH98 _   details+  = case details of+           InfixCon {}  -> return True+           _            -> return False++tcConIsInfixGADT :: Name+             -> HsConDetails (LHsType Name) (Located [LConDeclField Name])+             -> TcM Bool+tcConIsInfixGADT con details+  = case details of+           InfixCon {}  -> return True+           RecCon {}    -> return False+           PrefixCon arg_tys           -- See Note [Infix GADT constructors]+               | isSymOcc (getOccName con)+               , [_ty1,_ty2] <- arg_tys+                  -> do { fix_env <- getFixityEnv+                        ; return (con `elemNameEnv` fix_env) }+               | otherwise -> return False++tcConArgs :: HsConDeclDetails Name+          -> TcM [(TcType, HsSrcBang)]+tcConArgs (PrefixCon btys)+  = mapM tcConArg btys+tcConArgs (InfixCon bty1 bty2)+  = do { bty1' <- tcConArg bty1+       ; bty2' <- tcConArg bty2+       ; return [bty1', bty2'] }+tcConArgs (RecCon fields)+  = mapM tcConArg btys+  where+    -- We need a one-to-one mapping from field_names to btys+    combined = map (\(L _ f) -> (cd_fld_names f,cd_fld_type f)) (unLoc fields)+    explode (ns,ty) = zip ns (repeat ty)+    exploded = concatMap explode combined+    (_,btys) = unzip exploded+++tcConArg :: LHsType Name -> TcM (TcType, HsSrcBang)+tcConArg bty+  = do  { traceTc "tcConArg 1" (ppr bty)+        ; arg_ty <- tcHsOpenType (getBangType bty)+             -- Newtypes can't have unboxed types, but we check+             -- that in checkValidDataCon; this tcConArg stuff+             -- doesn't happen for GADT-style declarations+        ; traceTc "tcConArg 2" (ppr bty)+        ; return (arg_ty, getBangStrictness bty) }++{-+Note [Wrong visibility for GADTs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GADT tyvars shouldn't all be specified, but it's hard to do much better, as+described in #11721, which is duplicated here for convenience:++Consider++  data X a where+    MkX :: b -> Proxy a -> X a++According to the rules around specified vs. generalized variables around+TypeApplications, the type of MkX should be++  MkX :: forall {k} (b :: *) (a :: k). b -> Proxy a -> X a++A few things to note:++  * The k isn't available for TypeApplications (that's why it's in braces),+    because it is not user-written.++  * The b is quantified before the a, because b comes before a in the+    user-written type signature for MkX.++Both of these bullets are currently violated. GHCi reports MkX's type as++  MkX :: forall k (a :: k) b. b -> Proxy a -> X a++It turns out that this is a hard to fix. The problem is that GHC expects data+constructors to have their universal variables followed by their existential+variables, always. And yet that's violated in the desired type for MkX.+Furthermore, given the way that GHC deals with GADT return types ("rejigging",+in technical parlance), it's inconvenient to get the specified/generalized+distinction correct.++Given time constraints, I'm afraid fixing this all won't make it for 8.0.++Happily, there is are easy-to-articulate rules governing GHC's current (wrong)+behavior. In a GADT-syntax data constructor:++  * All kind and type variables are considered specified and available for+    visible type application.++  * Universal variables always come first, in precisely the order they appear+    in the tycon. Note that universals that are constrained by a GADT return+    type are missing from the datacon.++  * Existential variables come next. Their order is determined by a+    user-written forall; or, if there is none, by taking the left-to-right+    order in the datacon's type and doing a stable topological sort. (This+    stable topological sort step is the same as for other user-written type+    signatures.)++Note [Infix GADT constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do not currently have syntax to declare an infix constructor in GADT syntax,+but it makes a (small) difference to the Show instance.  So as a slightly+ad-hoc solution, we regard a GADT data constructor as infix if+  a) it is an operator symbol+  b) it has two arguments+  c) there is a fixity declaration for it+For example:+   infix 6 (:--:)+   data T a where+     (:--:) :: t1 -> t2 -> T Int+++Note [Checking GADT return types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There is a delicacy around checking the return types of a datacon. The+central problem is dealing with a declaration like++  data T a where+    MkT :: T a -> Q a++Note that the return type of MkT is totally bogus. When creating the T+tycon, we also need to create the MkT datacon, which must have a "rejigged"+return type. That is, the MkT datacon's type must be transformed to have+a uniform return type with explicit coercions for GADT-like type parameters.+This rejigging is what rejigConRes does. The problem is, though, that checking+that the return type is appropriate is much easier when done over *Type*,+not *HsType*, and doing a call to tcMatchTy will loop because T isn't fully+defined yet.++So, we want to make rejigConRes lazy and then check the validity of+the return type in checkValidDataCon.  To do this we /always/ return a+5-tuple from rejigConRes (so that we can extract ret_ty from it, which+checkValidDataCon needs), but the first four fields may be bogus if+the return type isn't valid (the last equation for rejigConRes).++This is better than an earlier solution which reduced the number of+errors reported in one pass.  See Trac #7175, and #10836.+-}++-- Example+--   data instance T (b,c) where+--      TI :: forall e. e -> T (e,e)+--+-- The representation tycon looks like this:+--   data :R7T b c where+--      TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1+-- In this case orig_res_ty = T (e,e)++rejigConRes :: [TyConBinder] -> Type    -- Template for result type; e.g.+                                  -- data instance T [a] b c = ...+                                  --      gives template ([a,b,c], T [a] b c)+                                  -- Type must be of kind *!+            -> [TyVar]            -- where MkT :: forall x y z. ...+            -> Type               -- res_ty type must be of kind *+            -> ([TyVar],          -- Universal+                [TyVar],          -- Existential (distinct OccNames from univs)+                [EqSpec],      -- Equality predicates+                Type,          -- Typechecked return type+                TCvSubst)      -- Substitution to apply to argument types+        -- We don't check that the TyCon given in the ResTy is+        -- the same as the parent tycon, because checkValidDataCon will do it++rejigConRes tmpl_bndrs res_tmpl dc_tvs res_ty+        -- E.g.  data T [a] b c where+        --         MkT :: forall x y z. T [(x,y)] z z+        -- The {a,b,c} are the tmpl_tvs, and the {x,y,z} are the dc_tvs+        --     (NB: unlike the H98 case, the dc_tvs are not all existential)+        -- Then we generate+        --      Univ tyvars     Eq-spec+        --          a              a~(x,y)+        --          b              b~z+        --          z+        -- Existentials are the leftover type vars: [x,y]+        -- So we return ([a,b,z], [x,y], [a~(x,y),b~z], T [(x,y)] z z)+  | Just subst <- ASSERT( isLiftedTypeKind (typeKind res_ty) )+                  ASSERT( isLiftedTypeKind (typeKind res_tmpl) )+                  tcMatchTy res_tmpl res_ty+  = let (univ_tvs, raw_eqs, kind_subst) = mkGADTVars tmpl_tvs dc_tvs subst+        raw_ex_tvs = dc_tvs `minusList` univ_tvs+        (arg_subst, substed_ex_tvs)+          = mapAccumL substTyVarBndr kind_subst raw_ex_tvs++        substed_eqs = map (substEqSpec arg_subst) raw_eqs+    in+    (univ_tvs, substed_ex_tvs, substed_eqs, res_ty, arg_subst)++  | otherwise+        -- If the return type of the data constructor doesn't match the parent+        -- type constructor, or the arity is wrong, the tcMatchTy will fail+        --    e.g   data T a b where+        --            T1 :: Maybe a   -- Wrong tycon+        --            T2 :: T [a]     -- Wrong arity+        -- We are detect that later, in checkValidDataCon, but meanwhile+        -- we must do *something*, not just crash.  So we do something simple+        -- albeit bogus, relying on checkValidDataCon to check the+        --  bad-result-type error before seeing that the other fields look odd+        -- See Note [Checking GADT return types]+  = (tmpl_tvs, dc_tvs `minusList` tmpl_tvs, [], res_ty, emptyTCvSubst)+  where+    tmpl_tvs = binderVars tmpl_bndrs++{-+Note [mkGADTVars]+~~~~~~~~~~~~~~~~~++Running example:++data T (k1 :: *) (k2 :: *) (a :: k2) (b :: k2) where+  MkT :: T x1 * (Proxy (y :: x1), z) z++We need the rejigged type to be++  MkT :: forall (x1 :: *) (k2 :: *) (a :: k2) (b :: k2).+         forall (y :: x1) (z :: *).+         (k2 ~ *, a ~ (Proxy x1 y, z), b ~ z)+      => T x1 k2 a b++You might naively expect that z should become a universal tyvar,+not an existential. (After all, x1 becomes a universal tyvar.)+The problem is that the universal tyvars must have exactly the+same kinds as the tyConTyVars. z has kind * while b has kind k2.+So we need an existential tyvar and a heterogeneous equality+constraint. (The b ~ z is a bit redundant with the k2 ~ * that+comes before in that b ~ z implies k2 ~ *. I'm sure we could do+some analysis that could eliminate k2 ~ *. But we don't do this+yet.)++The HsTypes have already been desugared to proper Types:++  T x1 * (Proxy (y :: x1), z) z+becomes+  [x1 :: *, y :: x1, z :: *]. T x1 * (Proxy x1 y, z) z++We start off by matching (T k1 k2 a b) with (T x1 * (Proxy x1 y, z) z). We+know this match will succeed because of the validity check (actually done+later, but laziness saves us -- see Note [Checking GADT return types]).+Thus, we get++  subst := { k1 |-> x1, k2 |-> *, a |-> (Proxy x1 y, z), b |-> z }++Now, we need to figure out what the GADT equalities should be. In this case,+we *don't* want (k1 ~ x1) to be a GADT equality: it should just be a+renaming. The others should be GADT equalities. We also need to make+sure that the universally-quantified variables of the datacon match up+with the tyvars of the tycon, as required for Core context well-formedness.+(This last bit is why we have to rejig at all!)++`choose` walks down the tycon tyvars, figuring out what to do with each one.+It carries two substitutions:+  - t_sub's domain is *template* or *tycon* tyvars, mapping them to variables+    mentioned in the datacon signature.+  - r_sub's domain is *result* tyvars, names written by the programmer in+    the datacon signature. The final rejigged type will use these names, but+    the subst is still needed because sometimes the printed name of these variables+    is different. (See choose_tv_name, below.)++Before explaining the details of `choose`, let's just look at its operation+on our example:++  choose [] [] {} {} [k1, k2, a, b]+  -->          -- first branch of `case` statement+  choose+    univs:    [x1 :: *]+    eq_spec:  []+    t_sub:    {k1 |-> x1}+    r_sub:    {x1 |-> x1}+    t_tvs:    [k2, a, b]+  -->          -- second branch of `case` statement+  choose+    univs:    [k2 :: *, x1 :: *]+    eq_spec:  [k2 ~ *]+    t_sub:    {k1 |-> x1, k2 |-> k2}+    r_sub:    {x1 |-> x1}+    t_tvs:    [a, b]+  -->          -- second branch of `case` statement+  choose+    univs:    [a :: k2, k2 :: *, x1 :: *]+    eq_spec:  [ a ~ (Proxy x1 y, z)+              , k2 ~ * ]+    t_sub:    {k1 |-> x1, k2 |-> k2, a |-> a}+    r_sub:    {x1 |-> x1}+    t_tvs:    [b]+  -->          -- second branch of `case` statement+  choose+    univs:    [b :: k2, a :: k2, k2 :: *, x1 :: *]+    eq_spec:  [ b ~ z+              , a ~ (Proxy x1 y, z)+              , k2 ~ * ]+    t_sub:    {k1 |-> x1, k2 |-> k2, a |-> a, b |-> z}+    r_sub:    {x1 |-> x1}+    t_tvs:    []+  -->          -- end of recursion+  ( [x1 :: *, k2 :: *, a :: k2, b :: k2]+  , [k2 ~ *, a ~ (Proxy x1 y, z), b ~ z]+  , {x1 |-> x1} )++`choose` looks up each tycon tyvar in the matching (it *must* be matched!). If+it finds a bare result tyvar (the first branch of the `case` statement), it+checks to make sure that the result tyvar isn't yet in the list of univ_tvs.+If it is in that list, then we have a repeated variable in the return type,+and we in fact need a GADT equality. We then check to make sure that the+kind of the result tyvar matches the kind of the template tyvar. This+check is what forces `z` to be existential, as it should be, explained above.+Assuming no repeated variables or kind-changing, we wish+to use the variable name given in the datacon signature (that is, `x1` not+`k1`), not the tycon signature (which may have been made up by+GHC). So, we add a mapping from the tycon tyvar to the result tyvar to t_sub.++If we discover that a mapping in `subst` gives us a non-tyvar (the second+branch of the `case` statement), then we have a GADT equality to create.+We create a fresh equality, but we don't extend any substitutions. The+template variable substitution is meant for use in universal tyvar kinds,+and these shouldn't be affected by any GADT equalities.++This whole algorithm is quite delicate, indeed. I (Richard E.) see two ways+of simplifying it:++1) The first branch of the `case` statement is really an optimization, used+in order to get fewer GADT equalities. It might be possible to make a GADT+equality for *every* univ. tyvar, even if the equality is trivial, and then+either deal with the bigger type or somehow reduce it later.++2) This algorithm strives to use the names for type variables as specified+by the user in the datacon signature. If we always used the tycon tyvar+names, for example, this would be simplified. This change would almost+certainly degrade error messages a bit, though.+-}++-- ^ From information about a source datacon definition, extract out+-- what the universal variables and the GADT equalities should be.+-- See Note [mkGADTVars].+mkGADTVars :: [TyVar]    -- ^ The tycon vars+           -> [TyVar]    -- ^ The datacon vars+           -> TCvSubst   -- ^ The matching between the template result type+                         -- and the actual result type+           -> ( [TyVar]+              , [EqSpec]+              , TCvSubst ) -- ^ The univ. variables, the GADT equalities,+                           -- and a subst to apply to the GADT equalities+                           -- and existentials.+mkGADTVars tmpl_tvs dc_tvs subst+  = choose [] [] empty_subst empty_subst tmpl_tvs+  where+    in_scope = mkInScopeSet (mkVarSet tmpl_tvs `unionVarSet` mkVarSet dc_tvs)+               `unionInScope` getTCvInScope subst+    empty_subst = mkEmptyTCvSubst in_scope++    choose :: [TyVar]           -- accumulator of univ tvs, reversed+           -> [EqSpec]          -- accumulator of GADT equalities, reversed+           -> TCvSubst          -- template substitution+           -> TCvSubst          -- res. substitution+           -> [TyVar]           -- template tvs (the univ tvs passed in)+           -> ( [TyVar]         -- the univ_tvs+              , [EqSpec]        -- GADT equalities+              , TCvSubst )       -- a substitution to fix kinds in ex_tvs++    choose univs eqs _t_sub r_sub []+      = (reverse univs, reverse eqs, r_sub)+    choose univs eqs t_sub r_sub (t_tv:t_tvs)+      | Just r_ty <- lookupTyVar subst t_tv+      = case getTyVar_maybe r_ty of+          Just r_tv+            |  not (r_tv `elem` univs)+            ,  tyVarKind r_tv `eqType` (substTy t_sub (tyVarKind t_tv))+            -> -- simple, well-kinded variable substitution.+               choose (r_tv:univs) eqs+                      (extendTvSubst t_sub t_tv r_ty')+                      (extendTvSubst r_sub r_tv r_ty')+                      t_tvs+            where+              r_tv1  = setTyVarName r_tv (choose_tv_name r_tv t_tv)+              r_ty'  = mkTyVarTy r_tv1++               -- not a simple substitution. make an equality predicate+          _ -> choose (t_tv':univs) (mkEqSpec t_tv' r_ty : eqs)+                      t_sub r_sub t_tvs+            where t_tv' = updateTyVarKind (substTy t_sub) t_tv++      | otherwise+      = pprPanic "mkGADTVars" (ppr tmpl_tvs $$ ppr subst)++      -- choose an appropriate name for a univ tyvar.+      -- This *must* preserve the Unique of the result tv, so that we+      -- can detect repeated variables. It prefers user-specified names+      -- over system names. A result variable with a system name can+      -- happen with GHC-generated implicit kind variables.+    choose_tv_name :: TyVar -> TyVar -> Name+    choose_tv_name r_tv t_tv+      | isSystemName r_tv_name+      = setNameUnique t_tv_name (getUnique r_tv_name)++      | otherwise+      = r_tv_name++      where+        r_tv_name = getName r_tv+        t_tv_name = getName t_tv++{-+Note [Substitution in template variables kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++data G (a :: Maybe k) where+  MkG :: G Nothing++With explicit kind variables++data G k (a :: Maybe k) where+  MkG :: G k1 (Nothing k1)++Note how k1 is distinct from k. So, when we match the template+`G k a` against `G k1 (Nothing k1)`, we get a subst+[ k |-> k1, a |-> Nothing k1 ]. Even though this subst has two+mappings, we surely don't want to add (k, k1) to the list of+GADT equalities -- that would be overly complex and would create+more untouchable variables than we need. So, when figuring out+which tyvars are GADT-like and which aren't (the fundamental+job of `choose`), we want to treat `k` as *not* GADT-like.+Instead, we wish to substitute in `a`'s kind, to get (a :: Maybe k1)+instead of (a :: Maybe k). This is the reason for dealing+with a substitution in here.++However, we do not *always* want to substitute. Consider++data H (a :: k) where+  MkH :: H Int++With explicit kind variables:++data H k (a :: k) where+  MkH :: H * Int++Here, we have a kind-indexed GADT. The subst in question is+[ k |-> *, a |-> Int ]. Now, we *don't* want to substitute in `a`'s+kind, because that would give a constructor with the type++MkH :: forall (k :: *) (a :: *). (k ~ *) -> (a ~ Int) -> H k a++The problem here is that a's kind is wrong -- it needs to be k, not *!+So, if the matching for a variable is anything but another bare variable,+we drop the mapping from the substitution before proceeding. This+was not an issue before kind-indexed GADTs because this case could+never happen.++************************************************************************+*                                                                      *+                Validity checking+*                                                                      *+************************************************************************++Validity checking is done once the mutually-recursive knot has been+tied, so we can look at things freely.+-}++checkValidTyCl :: TyCon -> TcM TyCon+checkValidTyCl tc+  = setSrcSpan (getSrcSpan tc) $+    addTyConCtxt tc $+    recoverM recovery_code+             (do { traceTc "Starting validity for tycon" (ppr tc)+                 ; checkValidTyCon tc+                 ; traceTc "Done validity for tycon" (ppr tc)+                 ; return tc })+  where+    recovery_code -- See Note [Recover from validity error]+      = do { traceTc "Aborted validity for tycon" (ppr tc)+           ; return fake_tc }+    fake_tc | isFamilyTyCon tc || isTypeSynonymTyCon tc+            = makeRecoveryTyCon tc+            | otherwise+            = tc++{- Note [Recover from validity error]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We recover from a validity error in a type or class, which allows us+to report multiple validity errors. In the failure case we return a+TyCon of the right kind, but with no interesting behaviour+(makeRecoveryTyCon). Why?  Suppose we have+   type T a = Fun+where Fun is a type family of arity 1.  The RHS is invalid, but we+want to go on checking validity of subsequent type declarations.+So we replace T with an abstract TyCon which will do no harm.+See indexed-types/should_fail/BadSock and Trac #10896++Painfully, though, we *don't* want to do this for classes.+Consider tcfail041:+   class (?x::Int) => C a where ...+   instance C Int+The class is invalid because of the superclass constraint.  But+we still want it to look like a /class/, else the instance bleats+that the instance is mal-formed because it hasn't got a class in+the head.+-}++-------------------------+-- For data types declared with record syntax, we require+-- that each constructor that has a field 'f'+--      (a) has the same result type+--      (b) has the same type for 'f'+-- module alpha conversion of the quantified type variables+-- of the constructor.+--+-- Note that we allow existentials to match because the+-- fields can never meet. E.g+--      data T where+--        T1 { f1 :: b, f2 :: a, f3 ::Int } :: T+--        T2 { f1 :: c, f2 :: c, f3 ::Int } :: T+-- Here we do not complain about f1,f2 because they are existential++checkValidTyCon :: TyCon -> TcM ()+checkValidTyCon tc+  | isPrimTyCon tc   -- Happens when Haddock'ing GHC.Prim+  = return ()++  | otherwise+  = do { traceTc "checkValidTyCon" (ppr tc $$ ppr (tyConClass_maybe tc))+       ; checkValidTyConTyVars tc+       ; if | Just cl <- tyConClass_maybe tc+              -> checkValidClass cl++            | Just syn_rhs <- synTyConRhs_maybe tc+              -> do { checkValidType syn_ctxt syn_rhs+                    ; checkTySynRhs syn_ctxt syn_rhs }++            | Just fam_flav <- famTyConFlav_maybe tc+              -> case fam_flav of+               { ClosedSynFamilyTyCon (Just ax)+                   -> tcAddClosedTypeFamilyDeclCtxt tc $+                      checkValidCoAxiom ax+               ; ClosedSynFamilyTyCon Nothing   -> return ()+               ; AbstractClosedSynFamilyTyCon ->+                 do { hsBoot <- tcIsHsBootOrSig+                    ; checkTc hsBoot $+                      text "You may define an abstract closed type family" $$+                      text "only in a .hs-boot file" }+               ; DataFamilyTyCon {}           -> return ()+               ; OpenSynFamilyTyCon           -> return ()+               ; BuiltInSynFamTyCon _         -> return () }++             | otherwise -> do+               { -- Check the context on the data decl+                 traceTc "cvtc1" (ppr tc)+               ; checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc)++               ; traceTc "cvtc2" (ppr tc)++               ; dflags          <- getDynFlags+               ; existential_ok  <- xoptM LangExt.ExistentialQuantification+               ; gadt_ok         <- xoptM LangExt.GADTs+               ; let ex_ok = existential_ok || gadt_ok+                     -- Data cons can have existential context+               ; mapM_ (checkValidDataCon dflags ex_ok tc) data_cons++                -- Check that fields with the same name share a type+               ; mapM_ check_fields groups }}+  where+    syn_ctxt  = TySynCtxt name+    name      = tyConName tc+    data_cons = tyConDataCons tc++    groups = equivClasses cmp_fld (concatMap get_fields data_cons)+    cmp_fld (f1,_) (f2,_) = flLabel f1 `compare` flLabel f2+    get_fields con = dataConFieldLabels con `zip` repeat con+        -- dataConFieldLabels may return the empty list, which is fine++    -- See Note [GADT record selectors] in TcTyDecls+    -- We must check (a) that the named field has the same+    --                   type in each constructor+    --               (b) that those constructors have the same result type+    --+    -- However, the constructors may have differently named type variable+    -- and (worse) we don't know how the correspond to each other.  E.g.+    --     C1 :: forall a b. { f :: a, g :: b } -> T a b+    --     C2 :: forall d c. { f :: c, g :: c } -> T c d+    --+    -- So what we do is to ust Unify.tcMatchTys to compare the first candidate's+    -- result type against other candidates' types BOTH WAYS ROUND.+    -- If they magically agrees, take the substitution and+    -- apply them to the latter ones, and see if they match perfectly.+    check_fields ((label, con1) : other_fields)+        -- These fields all have the same name, but are from+        -- different constructors in the data type+        = recoverM (return ()) $ mapM_ checkOne other_fields+                -- Check that all the fields in the group have the same type+                -- NB: this check assumes that all the constructors of a given+                -- data type use the same type variables+        where+        (_, _, _, res1) = dataConSig con1+        fty1 = dataConFieldType con1 lbl+        lbl = flLabel label++        checkOne (_, con2)    -- Do it bothways to ensure they are structurally identical+            = do { checkFieldCompat lbl con1 con2 res1 res2 fty1 fty2+                 ; checkFieldCompat lbl con2 con1 res2 res1 fty2 fty1 }+            where+                (_, _, _, res2) = dataConSig con2+                fty2 = dataConFieldType con2 lbl+    check_fields [] = panic "checkValidTyCon/check_fields []"++checkFieldCompat :: FieldLabelString -> DataCon -> DataCon+                 -> Type -> Type -> Type -> Type -> TcM ()+checkFieldCompat fld con1 con2 res1 res2 fty1 fty2+  = do  { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2)+        ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) }+  where+    mb_subst1 = tcMatchTy res1 res2+    mb_subst2 = tcMatchTyX (expectJust "checkFieldCompat" mb_subst1) fty1 fty2++-------------------------------+-- | Check for ill-scoped telescopes in a tycon.+-- For example:+--+-- > data SameKind :: k -> k -> *   -- this is OK+-- > data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d)+--+-- The problem is that @b@ should be bound (implicitly) at the beginning,+-- but its kind mentions @a@, which is not yet in scope. Kind generalization+-- makes a mess of this, and ends up including @a@ twice in the final+-- tyvars. So this function checks for duplicates and, if there are any,+-- produces the appropriate error message.+checkValidTyConTyVars :: TyCon -> TcM ()+checkValidTyConTyVars tc+  = do { -- strip off the duplicates and look for ill-scoped things+         -- but keep the *last* occurrence of each variable, as it's+         -- most likely the one the user wrote+         let stripped_tvs | duplicate_vars+                          = reverse $ nub $ reverse tvs+                          | otherwise+                          = tvs+             vis_tvs      = filterOutInvisibleTyVars tc tvs+             extra | not (vis_tvs `equalLength` stripped_tvs)+                   = text "NB: Implicitly declared kind variables are put first."+                   | otherwise+                   = empty+       ; checkValidTelescope (pprTyVars vis_tvs) stripped_tvs extra+         `and_if_that_doesn't_error`+           -- This triggers on test case dependent/should_fail/InferDependency+           -- It reports errors around Note [Dependent LHsQTyVars] in TcHsType+         when duplicate_vars (+          addErr (vcat [ text "Invalid declaration for" <+>+                         quotes (ppr tc) <> semi <+> text "you must explicitly"+                       , text "declare which variables are dependent on which others."+                       , hang (text "Inferred variable kinds:")+                         2 (vcat (map pp_tv stripped_tvs)) ])) }+  where+    tvs = tyConTyVars tc+    duplicate_vars = sizeVarSet (mkVarSet tvs) < length tvs++    pp_tv tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)++     -- only run try_second if the first reports no errors+    and_if_that_doesn't_error :: TcM () -> TcM () -> TcM ()+    try_first `and_if_that_doesn't_error` try_second+      = recoverM (return ()) $+        do { checkNoErrs try_first+           ; try_second }++-------------------------------+checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM ()+checkValidDataCon dflags existential_ok tc con+  = setSrcSpan (srcLocSpan (getSrcLoc con))     $+    addErrCtxt (dataConCtxt con)                $+    do  { -- Check that the return type of the data constructor+          -- matches the type constructor; eg reject this:+          --   data T a where { MkT :: Bogus a }+          -- It's important to do this first:+          --  see Note [Checking GADT return types]+          --  and c.f. Note [Check role annotations in a second pass]+          let tc_tvs      = tyConTyVars tc+              res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)+              orig_res_ty = dataConOrigResTy con+        ; traceTc "checkValidDataCon" (vcat+              [ ppr con, ppr tc, ppr tc_tvs+              , ppr res_ty_tmpl <+> dcolon <+> ppr (typeKind res_ty_tmpl)+              , ppr orig_res_ty <+> dcolon <+> ppr (typeKind orig_res_ty)])+++        ; checkTc (isJust (tcMatchTy res_ty_tmpl+                                     orig_res_ty))+                  (badDataConTyCon con res_ty_tmpl orig_res_ty)+            -- Note that checkTc aborts if it finds an error. This is+            -- critical to avoid panicking when we call dataConUserType+            -- on an un-rejiggable datacon!++        ; traceTc "checkValidDataCon 2" (ppr (dataConUserType con))++          -- Check that the result type is a *monotype*+          --  e.g. reject this:   MkT :: T (forall a. a->a)+          -- Reason: it's really the argument of an equality constraint+        ; checkValidMonoType orig_res_ty++          -- Check all argument types for validity+        ; checkValidType ctxt (dataConUserType con)+        ; mapM_ (checkForLevPoly empty)+                (dataConOrigArgTys con)++          -- Extra checks for newtype data constructors+        ; when (isNewTyCon tc) (checkNewDataCon con)++          -- Check that existentials are allowed if they are used+        ; checkTc (existential_ok || isVanillaDataCon con)+                  (badExistential con)++          -- Check that UNPACK pragmas and bangs work out+          -- E.g.  reject   data T = MkT {-# UNPACK #-} Int     -- No "!"+          --                data T = MkT {-# UNPACK #-} !a      -- Can't unpack+        ; zipWith3M_ check_bang (dataConSrcBangs con) (dataConImplBangs con) [1..]++        ; traceTc "Done validity of data con" (ppr con <+> ppr (dataConRepType con))+    }+  where+    ctxt = ConArgCtxt (dataConName con)++    check_bang :: HsSrcBang -> HsImplBang -> Int -> TcM ()+    check_bang (HsSrcBang _ _ SrcLazy) _ n+      | not (xopt LangExt.StrictData dflags)+      = addErrTc+          (bad_bang n (text "Lazy annotation (~) without StrictData"))+    check_bang (HsSrcBang _ want_unpack strict_mark) rep_bang n+      | isSrcUnpacked want_unpack, not is_strict+      = addWarnTc NoReason (bad_bang n (text "UNPACK pragma lacks '!'"))+      | isSrcUnpacked want_unpack+      , case rep_bang of { HsUnpack {} -> False; _ -> True }+      , not (gopt Opt_OmitInterfacePragmas dflags)+           -- If not optimising, se don't unpack, so don't complain!+           -- See MkId.dataConArgRep, the (HsBang True) case+      = addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma"))+      where+        is_strict = case strict_mark of+                      NoSrcStrict -> xopt LangExt.StrictData dflags+                      bang        -> isSrcStrict bang++    check_bang _ _ _+      = return ()++    bad_bang n herald+      = hang herald 2 (text "on the" <+> speakNth n+                       <+> text "argument of" <+> quotes (ppr con))+-------------------------------+checkNewDataCon :: DataCon -> TcM ()+-- Further checks for the data constructor of a newtype+checkNewDataCon con+  = do  { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys))+              -- One argument++        ; checkTc (not (isUnliftedType arg_ty1)) $+          text "A newtype cannot have an unlifted argument type"++        ; check_con (null eq_spec) $+          text "A newtype constructor must have a return type of form T a1 ... an"+                -- Return type is (T a b c)++        ; check_con (null theta) $+          text "A newtype constructor cannot have a context in its type"++        ; check_con (null ex_tvs) $+          text "A newtype constructor cannot have existential type variables"+                -- No existentials++        ; checkTc (all ok_bang (dataConSrcBangs con))+                  (newtypeStrictError con)+                -- No strictness annotations+    }+  where+    (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)+      = dataConFullSig con+    check_con what msg+       = checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConUserType con))++    (arg_ty1 : _) = arg_tys++    ok_bang (HsSrcBang _ _ SrcStrict) = False+    ok_bang (HsSrcBang _ _ SrcLazy)   = False+    ok_bang _                         = True++-------------------------------+checkValidClass :: Class -> TcM ()+checkValidClass cls+  = do  { constrained_class_methods <- xoptM LangExt.ConstrainedClassMethods+        ; multi_param_type_classes  <- xoptM LangExt.MultiParamTypeClasses+        ; nullary_type_classes      <- xoptM LangExt.NullaryTypeClasses+        ; fundep_classes            <- xoptM LangExt.FunctionalDependencies+        ; undecidable_super_classes <- xoptM LangExt.UndecidableSuperClasses++        -- Check that the class is unary, unless multiparameter type classes+        -- are enabled; also recognize deprecated nullary type classes+        -- extension (subsumed by multiparameter type classes, Trac #8993)+        ; checkTc (multi_param_type_classes || cls_arity == 1 ||+                    (nullary_type_classes && cls_arity == 0))+                  (classArityErr cls_arity cls)+        ; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls)++        -- Check the super-classes+        ; checkValidTheta (ClassSCCtxt (className cls)) theta++          -- Now check for cyclic superclasses+          -- If there are superclass cycles, checkClassCycleErrs bails.+        ; unless undecidable_super_classes $+          case checkClassCycles cls of+             Just err -> setSrcSpan (getSrcSpan cls) $+                         addErrTc err+             Nothing  -> return ()++        -- Check the class operations.+        -- But only if there have been no earlier errors+        -- See Note [Abort when superclass cycle is detected]+        ; whenNoErrs $+          mapM_ (check_op constrained_class_methods) op_stuff++        -- Check the associated type defaults are well-formed and instantiated+        ; mapM_ check_at at_stuff  }+  where+    (tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls+    cls_arity = length $ filterOutInvisibleTyVars (classTyCon cls) tyvars+       -- Ignore invisible variables+    cls_tv_set = mkVarSet tyvars+    mini_env   = zipVarEnv tyvars (mkTyVarTys tyvars)+    mb_cls     = Just (cls, tyvars, mini_env)++    check_op constrained_class_methods (sel_id, dm)+      = setSrcSpan (getSrcSpan sel_id) $+        addErrCtxt (classOpCtxt sel_id op_ty) $ do+        { traceTc "class op type" (ppr op_ty)+        ; checkValidType ctxt op_ty+                -- This implements the ambiguity check, among other things+                -- Example: tc223+                --   class Error e => Game b mv e | b -> mv e where+                --      newBoard :: MonadState b m => m ()+                -- Here, MonadState has a fundep m->b, so newBoard is fine++           -- a method cannot be levity polymorphic, as we have to store the+           -- method in a dictionary+           -- example of what this prevents:+           --   class BoundedX (a :: TYPE r) where minBound :: a+           -- See Note [Levity polymorphism checking] in DsMonad+        ; checkForLevPoly empty tau1++        ; unless constrained_class_methods $+          mapM_ check_constraint (tail (cls_pred:op_theta))++        ; check_dm ctxt sel_id cls_pred tau2 dm+        }+        where+          ctxt    = FunSigCtxt op_name True -- Report redundant class constraints+          op_name = idName sel_id+          op_ty   = idType sel_id+          (_,cls_pred,tau1) = tcSplitMethodTy op_ty+          -- See Note [Splitting nested sigma types]+          (_,op_theta,tau2) = tcSplitNestedSigmaTys tau1++          check_constraint :: TcPredType -> TcM ()+          check_constraint pred -- See Note [Class method constraints]+            = when (not (isEmptyVarSet pred_tvs) &&+                    pred_tvs `subVarSet` cls_tv_set)+                   (addErrTc (badMethPred sel_id pred))+            where+              pred_tvs = tyCoVarsOfType pred++    check_at (ATI fam_tc m_dflt_rhs)+      = do { checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs)+                     (noClassTyVarErr cls fam_tc)+                        -- Check that the associated type mentions at least+                        -- one of the class type variables+                        -- The check is disabled for nullary type classes,+                        -- since there is no possible ambiguity (Trac #10020)++             -- Check that any default declarations for associated types are valid+           ; whenIsJust m_dflt_rhs $ \ (rhs, loc) ->+             checkValidTyFamEqn mb_cls fam_tc+                                fam_tvs [] (mkTyVarTys fam_tvs) rhs loc }+        where+          fam_tvs = tyConTyVars fam_tc++    check_dm :: UserTypeCtxt -> Id -> PredType -> Type -> DefMethInfo -> TcM ()+    -- Check validity of the /top-level/ generic-default type+    -- E.g for   class C a where+    --             default op :: forall b. (a~b) => blah+    -- we do not want to do an ambiguity check on a type with+    -- a free TyVar 'a' (Trac #11608).  See TcType+    -- Note [TyVars and TcTyVars during type checking] in TcType+    -- Hence the mkDefaultMethodType to close the type.+    check_dm ctxt sel_id vanilla_cls_pred vanilla_tau+             (Just (dm_name, dm_spec@(GenericDM dm_ty)))+      = setSrcSpan (getSrcSpan dm_name) $ do+            -- We have carefully set the SrcSpan on the generic+            -- default-method Name to be that of the generic+            -- default type signature++          -- First, we check that that the method's default type signature+          -- aligns with the non-default type signature.+          -- See Note [Default method type signatures must align]+          let cls_pred = mkClassPred cls $ mkTyVarTys $ classTyVars cls+              -- Note that the second field of this tuple contains the context+              -- of the default type signature, making it apparent that we+              -- ignore method contexts completely when validity-checking+              -- default type signatures. See the end of+              -- Note [Default method type signatures must align]+              -- to learn why this is OK.+              --+              -- See also Note [Splitting nested sigma types]+              -- for an explanation of why we don't use tcSplitSigmaTy here.+              (_, _, dm_tau) = tcSplitNestedSigmaTys dm_ty++              -- Given this class definition:+              --+              --  class C a b where+              --    op         :: forall p q. (Ord a, D p q)+              --               => a -> b -> p -> (a, b)+              --    default op :: forall r s. E r+              --               => a -> b -> s -> (a, b)+              --+              -- We want to match up two types of the form:+              --+              --   Vanilla type sig: C aa bb => aa -> bb -> p -> (aa, bb)+              --   Default type sig: C a  b  => a  -> b  -> s -> (a,  b)+              --+              -- Notice that the two type signatures can be quantified over+              -- different class type variables! Therefore, it's important that+              -- we include the class predicate parts to match up a with aa and+              -- b with bb.+              vanilla_phi_ty = mkPhiTy [vanilla_cls_pred] vanilla_tau+              dm_phi_ty      = mkPhiTy [cls_pred] dm_tau++          traceTc "check_dm" $ vcat+              [ text "vanilla_phi_ty" <+> ppr vanilla_phi_ty+              , text "dm_phi_ty"      <+> ppr dm_phi_ty ]++          -- Actually checking that the types align is done with a call to+          -- tcMatchTys. We need to get a match in both directions to rule+          -- out degenerate cases like these:+          --+          --  class Foo a where+          --    foo1         :: a -> b+          --    default foo1 :: a -> Int+          --+          --    foo2         :: a -> Int+          --    default foo2 :: a -> b+          unless (isJust $ tcMatchTys [dm_phi_ty, vanilla_phi_ty]+                                      [vanilla_phi_ty, dm_phi_ty]) $ addErrTc $+               hang (text "The default type signature for"+                     <+> ppr sel_id <> colon)+                 2 (ppr dm_ty)+            $$ (text "does not match its corresponding"+                <+> text "non-default type signature")++          -- Now do an ambiguity check on the default type signature.+          checkValidType ctxt (mkDefaultMethodType cls sel_id dm_spec)+    check_dm _ _ _ _ _ = return ()++checkFamFlag :: Name -> TcM ()+-- Check that we don't use families without -XTypeFamilies+-- The parser won't even parse them, but I suppose a GHC API+-- client might have a go!+checkFamFlag tc_name+  = do { idx_tys <- xoptM LangExt.TypeFamilies+       ; checkTc idx_tys err_msg }+  where+    err_msg = hang (text "Illegal family declaration for" <+> quotes (ppr tc_name))+                 2 (text "Use TypeFamilies to allow indexed type families")++{- Note [Class method constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Haskell 2010 is supposed to reject+  class C a where+    op :: Eq a => a -> a+where the method type costrains only the class variable(s).  (The extension+-XConstrainedClassMethods switches off this check.)  But regardless+we should not reject+  class C a where+    op :: (?x::Int) => a -> a+as pointed out in Trac #11793. So the test here rejects the program if+  * -XConstrainedClassMethods is off+  * the tyvars of the constraint are non-empty+  * all the tyvars are class tyvars, none are locally quantified++Note [Abort when superclass cycle is detected]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must avoid doing the ambiguity check for the methods (in+checkValidClass.check_op) when there are already errors accumulated.+This is because one of the errors may be a superclass cycle, and+superclass cycles cause canonicalization to loop. Here is a+representative example:++  class D a => C a where+    meth :: D a => ()+  class C a => D a++This fixes Trac #9415, #9739++Note [Default method type signatures must align]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC enforces the invariant that a class method's default type signature+must "align" with that of the method's non-default type signature, as per+GHC Trac #12918. For instance, if you have:++  class Foo a where+    bar :: forall b. Context => a -> b++Then a default type signature for bar must be alpha equivalent to+(forall b. a -> b). That is, the types must be the same modulo differences in+contexts. So the following would be acceptable default type signatures:++    default bar :: forall b. Context1 => a -> b+    default bar :: forall x. Context2 => a -> x++But the following are NOT acceptable default type signatures:++    default bar :: forall b. b -> a+    default bar :: forall x. x+    default bar :: a -> Int++Note that a is bound by the class declaration for Foo itself, so it is+not allowed to differ in the default type signature.++The default type signature (default bar :: a -> Int) deserves special mention,+since (a -> Int) is a straightforward instantiation of (forall b. a -> b). To+write this, you need to declare the default type signature like so:++    default bar :: forall b. (b ~ Int). a -> b++As noted in #12918, there are several reasons to do this:++1. It would make no sense to have a type that was flat-out incompatible with+   the non-default type signature. For instance, if you had:++     class Foo a where+       bar :: a -> Int+       default bar :: a -> Bool++   Then that would always fail in an instance declaration. So this check+   nips such cases in the bud before they have the chance to produce+   confusing error messages.++2. Internally, GHC uses TypeApplications to instantiate the default method in+   an instance. See Note [Default methods in instances] in TcInstDcls.+   Thus, GHC needs to know exactly what the universally quantified type+   variables are, and when instantiated that way, the default method's type+   must match the expected type.++3. Aesthetically, by only allowing the default type signature to differ in its+   context, we are making it more explicit the ways in which the default type+   signature is less polymorphic than the non-default type signature.++You might be wondering: why are the contexts allowed to be different, but not+the rest of the type signature? That's because default implementations often+rely on assumptions that the more general, non-default type signatures do not.+For instance, in the Enum class declaration:++    class Enum a where+      enum :: [a]+      default enum :: (Generic a, GEnum (Rep a)) => [a]+      enum = map to genum++    class GEnum f where+      genum :: [f a]++The default implementation for enum only works for types that are instances of+Generic, and for which their generic Rep type is an instance of GEnum. But+clearly enum doesn't _have_ to use this implementation, so naturally, the+context for enum is allowed to be different to accomodate this. As a result,+when we validity-check default type signatures, we ignore contexts completely.++Note that when checking whether two type signatures match, we must take care to+split as many foralls as it takes to retrieve the tau types we which to check.+See Note [Splitting nested sigma types].++Note [Splitting nested sigma types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this type synonym and class definition:++  type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t++  class Each s t a b where+    each         ::                                      Traversal s t a b+    default each :: (Traversable g, s ~ g a, t ~ g b) => Traversal s t a b++It might seem obvious that the tau types in both type signatures for `each`+are the same, but actually getting GHC to conclude this is surprisingly tricky.+That is because in general, the form of a class method's non-default type+signature is:++  forall a. C a => forall d. D d => E a b++And the general form of a default type signature is:++  forall f. F f => E a f -- The variable `a` comes from the class++So it you want to get the tau types in each type signature, you might find it+reasonable to call tcSplitSigmaTy twice on the non-default type signature, and+call it once on the default type signature. For most classes and methods, this+will work, but Each is a bit of an exceptional case. The way `each` is written,+it doesn't quantify any additional type variables besides those of the Each+class itself, so the non-default type signature for `each` is actually this:++  forall s t a b. Each s t a b => Traversal s t a b++Notice that there _appears_ to only be one forall. But there's actually another+forall lurking in the Traversal type synonym, so if you call tcSplitSigmaTy+twice, you'll also go under the forall in Traversal! That is, you'll end up+with:++  (a -> f b) -> s -> f t++A problem arises because you only call tcSplitSigmaTy once on the default type+signature for `each`, which gives you++  Traversal s t a b++Or, equivalently:++  forall f. Applicative f => (a -> f b) -> s -> f t++This is _not_ the same thing as (a -> f b) -> s -> f t! So now tcMatchTy will+say that the tau types for `each` are not equal.++A solution to this problem is to use tcSplitNestedSigmaTys instead of+tcSplitSigmaTy. tcSplitNestedSigmaTys will always split any foralls that it+sees until it can't go any further, so if you called it on the default type+signature for `each`, it would return (a -> f b) -> s -> f t like we desired.++************************************************************************+*                                                                      *+                Checking role validity+*                                                                      *+************************************************************************+-}++checkValidRoleAnnots :: RoleAnnotEnv -> TyCon -> TcM ()+checkValidRoleAnnots role_annots tc+  | isTypeSynonymTyCon tc = check_no_roles+  | isFamilyTyCon tc      = check_no_roles+  | isAlgTyCon tc         = check_roles+  | otherwise             = return ()+  where+    -- Role annotations are given only on *explicit* variables,+    -- but a tycon stores roles for all variables.+    -- So, we drop the implicit roles (which are all Nominal, anyway).+    name                   = tyConName tc+    tyvars                 = tyConTyVars tc+    roles                  = tyConRoles tc+    (vis_roles, vis_vars)  = unzip $ snd $+                             partitionInvisibles tc (mkTyVarTy . snd) $+                             zip roles tyvars+    role_annot_decl_maybe  = lookupRoleAnnot role_annots name++    check_roles+      = whenIsJust role_annot_decl_maybe $+          \decl@(L loc (RoleAnnotDecl _ the_role_annots)) ->+          addRoleAnnotCtxt name $+          setSrcSpan loc $ do+          { role_annots_ok <- xoptM LangExt.RoleAnnotations+          ; checkTc role_annots_ok $ needXRoleAnnotations tc+          ; checkTc (vis_vars `equalLength` the_role_annots)+                    (wrongNumberOfRoles vis_vars decl)+          ; _ <- zipWith3M checkRoleAnnot vis_vars the_role_annots vis_roles+          -- Representational or phantom roles for class parameters+          -- quickly lead to incoherence. So, we require+          -- IncoherentInstances to have them. See #8773.+          ; incoherent_roles_ok <- xoptM LangExt.IncoherentInstances+          ; checkTc (  incoherent_roles_ok+                    || (not $ isClassTyCon tc)+                    || (all (== Nominal) vis_roles))+                    incoherentRoles++          ; lint <- goptM Opt_DoCoreLinting+          ; when lint $ checkValidRoles tc }++    check_no_roles+      = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl++checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM ()+checkRoleAnnot _  (L _ Nothing)   _  = return ()+checkRoleAnnot tv (L _ (Just r1)) r2+  = when (r1 /= r2) $+    addErrTc $ badRoleAnnot (tyVarName tv) r1 r2++-- This is a double-check on the role inference algorithm. It is only run when+-- -dcore-lint is enabled. See Note [Role inference] in TcTyDecls+checkValidRoles :: TyCon -> TcM ()+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism] in CoreLint+checkValidRoles tc+  | isAlgTyCon tc+    -- tyConDataCons returns an empty list for data families+  = mapM_ check_dc_roles (tyConDataCons tc)+  | Just rhs <- synTyConRhs_maybe tc+  = check_ty_roles (zipVarEnv (tyConTyVars tc) (tyConRoles tc)) Representational rhs+  | otherwise+  = return ()+  where+    check_dc_roles datacon+      = do { traceTc "check_dc_roles" (ppr datacon <+> ppr (tyConRoles tc))+           ; mapM_ (check_ty_roles role_env Representational) $+                    eqSpecPreds eq_spec ++ theta ++ arg_tys }+                    -- See Note [Role-checking data constructor arguments] in TcTyDecls+      where+        (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)+          = dataConFullSig datacon+        univ_roles = zipVarEnv univ_tvs (tyConRoles tc)+              -- zipVarEnv uses zipEqual, but we don't want that for ex_tvs+        ex_roles   = mkVarEnv (map (, Nominal) ex_tvs)+        role_env   = univ_roles `plusVarEnv` ex_roles++    check_ty_roles env role (TyVarTy tv)+      = case lookupVarEnv env tv of+          Just role' -> unless (role' `ltRole` role || role' == role) $+                        report_error $ text "type variable" <+> quotes (ppr tv) <+>+                                       text "cannot have role" <+> ppr role <+>+                                       text "because it was assigned role" <+> ppr role'+          Nothing    -> report_error $ text "type variable" <+> quotes (ppr tv) <+>+                                       text "missing in environment"++    check_ty_roles env Representational (TyConApp tc tys)+      = let roles' = tyConRoles tc in+        zipWithM_ (maybe_check_ty_roles env) roles' tys++    check_ty_roles env Nominal (TyConApp _ tys)+      = mapM_ (check_ty_roles env Nominal) tys++    check_ty_roles _   Phantom ty@(TyConApp {})+      = pprPanic "check_ty_roles" (ppr ty)++    check_ty_roles env role (AppTy ty1 ty2)+      =  check_ty_roles env role    ty1+      >> check_ty_roles env Nominal ty2++    check_ty_roles env role (FunTy ty1 ty2)+      =  check_ty_roles env role ty1+      >> check_ty_roles env role ty2++    check_ty_roles env role (ForAllTy (TvBndr tv _) ty)+      =  check_ty_roles env Nominal (tyVarKind tv)+      >> check_ty_roles (extendVarEnv env tv Nominal) role ty++    check_ty_roles _   _    (LitTy {}) = return ()++    check_ty_roles env role (CastTy t _)+      = check_ty_roles env role t++    check_ty_roles _   role (CoercionTy co)+      = unless (role == Phantom) $+        report_error $ text "coercion" <+> ppr co <+> text "has bad role" <+> ppr role++    maybe_check_ty_roles env role ty+      = when (role == Nominal || role == Representational) $+        check_ty_roles env role ty++    report_error doc+      = addErrTc $ vcat [text "Internal error in role inference:",+                         doc,+                         text "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug"]++{-+************************************************************************+*                                                                      *+                Error messages+*                                                                      *+************************************************************************+-}++tcAddTyFamInstCtxt :: TyFamInstDecl Name -> TcM a -> TcM a+tcAddTyFamInstCtxt decl+  = tcAddFamInstCtxt (text "type instance") (tyFamInstDeclName decl)++tcMkDataFamInstCtxt :: DataFamInstDecl Name -> SDoc+tcMkDataFamInstCtxt decl+  = tcMkFamInstCtxt (pprDataFamInstFlavour decl <+> text "instance")+                    (unLoc (dfid_tycon decl))++tcAddDataFamInstCtxt :: DataFamInstDecl Name -> TcM a -> TcM a+tcAddDataFamInstCtxt decl+  = addErrCtxt (tcMkDataFamInstCtxt decl)++tcMkFamInstCtxt :: SDoc -> Name -> SDoc+tcMkFamInstCtxt flavour tycon+  = hsep [ text "In the" <+> flavour <+> text "declaration for"+         , quotes (ppr tycon) ]++tcAddFamInstCtxt :: SDoc -> Name -> TcM a -> TcM a+tcAddFamInstCtxt flavour tycon thing_inside+  = addErrCtxt (tcMkFamInstCtxt flavour tycon) thing_inside++tcAddClosedTypeFamilyDeclCtxt :: TyCon -> TcM a -> TcM a+tcAddClosedTypeFamilyDeclCtxt tc+  = addErrCtxt ctxt+  where+    ctxt = text "In the equations for closed type family" <+>+           quotes (ppr tc)++resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc+resultTypeMisMatch field_name con1 con2+  = vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,+                text "have a common field" <+> quotes (ppr field_name) <> comma],+          nest 2 $ text "but have different result types"]++fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc+fieldTypeMisMatch field_name con1 con2+  = sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,+         text "give different types for field", quotes (ppr field_name)]++dataConCtxtName :: [Located Name] -> SDoc+dataConCtxtName [con]+   = text "In the definition of data constructor" <+> quotes (ppr con)+dataConCtxtName con+   = text "In the definition of data constructors" <+> interpp'SP con++dataConCtxt :: Outputable a => a -> SDoc+dataConCtxt con = text "In the definition of data constructor" <+> quotes (ppr con)++classOpCtxt :: Var -> Type -> SDoc+classOpCtxt sel_id tau = sep [text "When checking the class method:",+                              nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)]++classArityErr :: Int -> Class -> SDoc+classArityErr n cls+    | n == 0 = mkErr "No" "no-parameter"+    | otherwise = mkErr "Too many" "multi-parameter"+  where+    mkErr howMany allowWhat =+        vcat [text (howMany ++ " parameters for class") <+> quotes (ppr cls),+              parens (text ("Use MultiParamTypeClasses to allow "+                                    ++ allowWhat ++ " classes"))]++classFunDepsErr :: Class -> SDoc+classFunDepsErr cls+  = vcat [text "Fundeps in class" <+> quotes (ppr cls),+          parens (text "Use FunctionalDependencies to allow fundeps")]++badMethPred :: Id -> TcPredType -> SDoc+badMethPred sel_id pred+  = vcat [ hang (text "Constraint" <+> quotes (ppr pred)+                 <+> text "in the type of" <+> quotes (ppr sel_id))+              2 (text "constrains only the class type variables")+         , text "Use ConstrainedClassMethods to allow it" ]++noClassTyVarErr :: Class -> TyCon -> SDoc+noClassTyVarErr clas fam_tc+  = sep [ text "The associated type" <+> quotes (ppr fam_tc)+        , text "mentions none of the type or kind variables of the class" <+>+                quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))]++badDataConTyCon :: DataCon -> Type -> Type -> SDoc+badDataConTyCon data_con res_ty_tmpl actual_res_ty+  = hang (text "Data constructor" <+> quotes (ppr data_con) <+>+                text "returns type" <+> quotes (ppr actual_res_ty))+       2 (text "instead of an instance of its parent type" <+> quotes (ppr res_ty_tmpl))++badGadtDecl :: Name -> SDoc+badGadtDecl tc_name+  = vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name)+         , nest 2 (parens $ text "Use GADTs to allow GADTs") ]++badExistential :: DataCon -> SDoc+badExistential con+  = hang (text "Data constructor" <+> quotes (ppr con) <+>+                text "has existential type variables, a context, or a specialised result type")+       2 (vcat [ ppr con <+> dcolon <+> ppr (dataConUserType con)+               , parens $ text "Use ExistentialQuantification or GADTs to allow this" ])++badStupidTheta :: Name -> SDoc+badStupidTheta tc_name+  = text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name)++newtypeConError :: Name -> Int -> SDoc+newtypeConError tycon n+  = sep [text "A newtype must have exactly one constructor,",+         nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ]++newtypeStrictError :: DataCon -> SDoc+newtypeStrictError con+  = sep [text "A newtype constructor cannot have a strictness annotation,",+         nest 2 $ text "but" <+> quotes (ppr con) <+> text "does"]++newtypeFieldErr :: DataCon -> Int -> SDoc+newtypeFieldErr con_name n_flds+  = sep [text "The constructor of a newtype must have exactly one field",+         nest 2 $ text "but" <+> quotes (ppr con_name) <+> text "has" <+> speakN n_flds]++badSigTyDecl :: Name -> SDoc+badSigTyDecl tc_name+  = vcat [ text "Illegal kind signature" <+>+           quotes (ppr tc_name)+         , nest 2 (parens $ text "Use KindSignatures to allow kind signatures") ]++emptyConDeclsErr :: Name -> SDoc+emptyConDeclsErr tycon+  = sep [quotes (ppr tycon) <+> text "has no constructors",+         nest 2 $ text "(EmptyDataDecls permits this)"]++wrongKindOfFamily :: TyCon -> SDoc+wrongKindOfFamily family+  = text "Wrong category of family instance; declaration was for a"+    <+> kindOfFamily+  where+    kindOfFamily | isTypeFamilyTyCon family = text "type family"+                 | isDataFamilyTyCon family = text "data family"+                 | otherwise = pprPanic "wrongKindOfFamily" (ppr family)++wrongNumberOfParmsErr :: Arity -> SDoc+wrongNumberOfParmsErr max_args+  = text "Number of parameters must match family declaration; expected"+    <+> ppr max_args++defaultAssocKindErr :: TyCon -> SDoc+defaultAssocKindErr fam_tc+  = text "Kind mis-match on LHS of default declaration for"+    <+> quotes (ppr fam_tc)++wrongTyFamName :: Name -> Name -> SDoc+wrongTyFamName fam_tc_name eqn_tc_name+  = hang (text "Mismatched type name in type family instance.")+       2 (vcat [ text "Expected:" <+> ppr fam_tc_name+               , text "  Actual:" <+> ppr eqn_tc_name ])++badRoleAnnot :: Name -> Role -> Role -> SDoc+badRoleAnnot var annot inferred+  = hang (text "Role mismatch on variable" <+> ppr var <> colon)+       2 (sep [ text "Annotation says", ppr annot+              , text "but role", ppr inferred+              , text "is required" ])++wrongNumberOfRoles :: [a] -> LRoleAnnotDecl Name -> SDoc+wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ annots))+  = hang (text "Wrong number of roles listed in role annotation;" $$+          text "Expected" <+> (ppr $ length tyvars) <> comma <+>+          text "got" <+> (ppr $ length annots) <> colon)+       2 (ppr d)++illegalRoleAnnotDecl :: LRoleAnnotDecl Name -> TcM ()+illegalRoleAnnotDecl (L loc (RoleAnnotDecl tycon _))+  = setErrCtxt [] $+    setSrcSpan loc $+    addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$+              text "they are allowed only for datatypes and classes.")++needXRoleAnnotations :: TyCon -> SDoc+needXRoleAnnotations tc+  = text "Illegal role annotation for" <+> ppr tc <> char ';' $$+    text "did you intend to use RoleAnnotations?"++incoherentRoles :: SDoc+incoherentRoles = (text "Roles other than" <+> quotes (text "nominal") <+>+                   text "for class parameters can lead to incoherence.") $$+                  (text "Use IncoherentInstances to allow this; bad role found")++addTyConCtxt :: TyCon -> TcM a -> TcM a+addTyConCtxt tc+  = addErrCtxt ctxt+  where+    name = getName tc+    flav = text (tyConFlavour tc)+    ctxt = hsep [ text "In the", flav+                , text "declaration for", quotes (ppr name) ]++addRoleAnnotCtxt :: Name -> TcM a -> TcM a+addRoleAnnotCtxt name+  = addErrCtxt $+    text "while checking a role annotation for" <+> quotes (ppr name)
+ typecheck/TcTyDecls.hs view
@@ -0,0 +1,1007 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1999+++Analysis functions over data types.  Specifically, detecting recursive types.++This stuff is only used for source-code decls; it's recorded in interface+files for imported data types.+-}++{-# LANGUAGE CPP #-}++module TcTyDecls(+        RolesInfo,+        inferRoles,+        checkSynCycles,+        checkClassCycles,++        -- * Implicits+        tcAddImplicits, mkDefaultMethodType,++        -- * Record selectors+        mkRecSelBinds, mkOneRecordSelector+    ) where++#include "HsVersions.h"++import TcRnMonad+import TcEnv+import TcBinds( tcRecSelBinds )+import RnEnv( RoleAnnotEnv, lookupRoleAnnot )+import TyCoRep( Type(..), Coercion(..), UnivCoProvenance(..) )+import TcType+import TysWiredIn( unitTy )+import MkCore( rEC_SEL_ERROR_ID )+import HsSyn+import Class+import Type+import HscTypes+import TyCon+import ConLike+import DataCon+import Name+import NameEnv+import NameSet hiding (unitFV)+import RdrName ( mkVarUnqual )+import Id+import IdInfo+import VarEnv+import VarSet+import NameSet  ( NameSet, unitNameSet, extendNameSet, elemNameSet )+import Coercion ( ltRole )+import BasicTypes+import SrcLoc+import Unique ( mkBuiltinUnique )+import Outputable+import Util+import Maybes+import Bag+import FastString+import FV+import Module++import Control.Monad++{-+************************************************************************+*                                                                      *+        Cycles in type synonym declarations+*                                                                      *+************************************************************************+-}++synonymTyConsOfType :: Type -> [TyCon]+-- Does not look through type synonyms at all+-- Return a list of synonym tycons+-- Keep this synchronized with 'expandTypeSynonyms'+synonymTyConsOfType ty+  = nameEnvElts (go ty)+  where+     go :: Type -> NameEnv TyCon  -- The NameEnv does duplicate elim+     go (TyConApp tc tys)         = go_tc tc `plusNameEnv` go_s tys+     go (LitTy _)                 = emptyNameEnv+     go (TyVarTy _)               = emptyNameEnv+     go (AppTy a b)               = go a `plusNameEnv` go b+     go (FunTy a b)               = go a `plusNameEnv` go b+     go (ForAllTy _ ty)           = go ty+     go (CastTy ty co)            = go ty `plusNameEnv` go_co co+     go (CoercionTy co)           = go_co co++     -- Note [TyCon cycles through coercions?!]+     -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+     -- Although, in principle, it's possible for a type synonym loop+     -- could go through a coercion (since a coercion can refer to+     -- a TyCon or Type), it doesn't seem possible to actually construct+     -- a Haskell program which tickles this case.  Here is an example+     -- program which causes a coercion:+     --+     --   type family Star where+     --       Star = Type+     --+     --   data T :: Star -> Type+     --   data S :: forall (a :: Type). T a -> Type+     --+     -- Here, the application 'T a' must first coerce a :: Type to a :: Star,+     -- witnessed by the type family.  But if we now try to make Type refer+     -- to a type synonym which in turn refers to Star, we'll run into+     -- trouble: we're trying to define and use the type constructor+     -- in the same recursive group.  Possibly this restriction will be+     -- lifted in the future but for now, this code is "just for completeness+     -- sake".+     go_co (Refl _ ty)            = go ty+     go_co (TyConAppCo _ tc cs)   = go_tc tc `plusNameEnv` go_co_s cs+     go_co (AppCo co co')         = go_co co `plusNameEnv` go_co co'+     go_co (ForAllCo _ co co')    = go_co co `plusNameEnv` go_co co'+     go_co (FunCo _ co co')       = go_co co `plusNameEnv` go_co co'+     go_co (CoVarCo _)            = emptyNameEnv+     go_co (AxiomInstCo _ _ cs)   = go_co_s cs+     go_co (UnivCo p _ ty ty')    = go_prov p `plusNameEnv` go ty `plusNameEnv` go ty'+     go_co (SymCo co)             = go_co co+     go_co (TransCo co co')       = go_co co `plusNameEnv` go_co co'+     go_co (NthCo _ co)           = go_co co+     go_co (LRCo _ co)            = go_co co+     go_co (InstCo co co')        = go_co co `plusNameEnv` go_co co'+     go_co (CoherenceCo co co')   = go_co co `plusNameEnv` go_co co'+     go_co (KindCo co)            = go_co co+     go_co (SubCo co)             = go_co co+     go_co (AxiomRuleCo _ cs)     = go_co_s cs++     go_prov UnsafeCoerceProv     = emptyNameEnv+     go_prov (PhantomProv co)     = go_co co+     go_prov (ProofIrrelProv co)  = go_co co+     go_prov (PluginProv _)       = emptyNameEnv+     go_prov (HoleProv _)         = emptyNameEnv++     go_tc tc | isTypeSynonymTyCon tc = unitNameEnv (tyConName tc) tc+              | otherwise             = emptyNameEnv+     go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys+     go_co_s cos = foldr (plusNameEnv . go_co) emptyNameEnv cos++-- | A monad for type synonym cycle checking, which keeps+-- track of the TyCons which are known to be acyclic, or+-- a failure message reporting that a cycle was found.+newtype SynCycleM a = SynCycleM {+    runSynCycleM :: SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState) }++type SynCycleState = NameSet++instance Functor SynCycleM where+    fmap = liftM++instance Applicative SynCycleM where+    pure x = SynCycleM $ \state -> Right (x, state)+    (<*>) = ap++instance Monad SynCycleM where+    m >>= f = SynCycleM $ \state ->+        case runSynCycleM m state of+            Right (x, state') ->+                runSynCycleM (f x) state'+            Left err -> Left err++failSynCycleM :: SrcSpan -> SDoc -> SynCycleM ()+failSynCycleM loc err = SynCycleM $ \_ -> Left (loc, err)++-- | Test if a 'Name' is acyclic, short-circuiting if we've+-- seen it already.+checkNameIsAcyclic :: Name -> SynCycleM () -> SynCycleM ()+checkNameIsAcyclic n m = SynCycleM $ \s ->+    if n `elemNameSet` s+        then Right ((), s) -- short circuit+        else case runSynCycleM m s of+                Right ((), s') -> Right ((), extendNameSet s' n)+                Left err -> Left err++-- | Checks if any of the passed in 'TyCon's have cycles.+-- Takes the 'UnitId' of the home package (as we can avoid+-- checking those TyCons: cycles never go through foreign packages) and+-- the corresponding @LTyClDecl Name@ for each 'TyCon', so we+-- can give better error messages.+checkSynCycles :: UnitId -> [TyCon] -> [LTyClDecl Name] -> TcM ()+checkSynCycles this_uid tcs tyclds = do+    case runSynCycleM (mapM_ (go emptyNameSet []) tcs) emptyNameSet of+        Left (loc, err) -> setSrcSpan loc $ failWithTc err+        Right _  -> return ()+  where+    -- Try our best to print the LTyClDecl for locally defined things+    lcl_decls = mkNameEnv (zip (map tyConName tcs) tyclds)++    -- Short circuit if we've already seen this Name and concluded+    -- it was acyclic.+    go :: NameSet -> [TyCon] -> TyCon -> SynCycleM ()+    go so_far seen_tcs tc =+        checkNameIsAcyclic (tyConName tc) $ go' so_far seen_tcs tc++    -- Expand type synonyms, complaining if you find the same+    -- type synonym a second time.+    go' :: NameSet -> [TyCon] -> TyCon -> SynCycleM ()+    go' so_far seen_tcs tc+        | n `elemNameSet` so_far+            = failSynCycleM (getSrcSpan (head seen_tcs)) $+                  sep [ text "Cycle in type synonym declarations:"+                      , nest 2 (vcat (map ppr_decl seen_tcs)) ]+        -- Optimization: we don't allow cycles through external packages,+        -- so once we find a non-local name we are guaranteed to not+        -- have a cycle.+        --+        -- This won't hold once we get recursive packages with Backpack,+        -- but for now it's fine.+        | not (isHoleModule mod ||+               moduleUnitId mod == this_uid ||+               isInteractiveModule mod)+            = return ()+        | Just ty <- synTyConRhs_maybe tc =+            go_ty (extendNameSet so_far (tyConName tc)) (tc:seen_tcs) ty+        | otherwise = return ()+      where+        n = tyConName tc+        mod = nameModule n+        ppr_decl tc =+          case lookupNameEnv lcl_decls n of+            Just (L loc decl) -> ppr loc <> colon <+> ppr decl+            Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n <+> text "from external module"+         where+          n = tyConName tc++    go_ty :: NameSet -> [TyCon] -> Type -> SynCycleM ()+    go_ty so_far seen_tcs ty =+        mapM_ (go so_far seen_tcs) (synonymTyConsOfType ty)++{- Note [Superclass cycle check]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The superclass cycle check for C decides if we can statically+guarantee that expanding C's superclass cycles transitively is+guaranteed to terminate.  This is a Haskell98 requirement,+but one that we lift with -XUndecidableSuperClasses.++The worry is that a superclass cycle could make the type checker loop.+More precisely, with a constraint (Given or Wanted)+    C ty1 .. tyn+one approach is to instantiate all of C's superclasses, transitively.+We can only do so if that set is finite.++This potential loop occurs only through superclasses.  This, for+example, is fine+  class C a where+    op :: C b => a -> b -> b+even though C's full definition uses C.++Making the check static also makes it conservative.  Eg+  type family F a+  class F a => C a+Here an instance of (F a) might mention C:+  type instance F [a] = C a+and now we'd have a loop.++The static check works like this, starting with C+  * Look at C's superclass predicates+  * If any is a type-function application,+    or is headed by a type variable, fail+  * If any has C at the head, fail+  * If any has a type class D at the head,+    make the same test with D++A tricky point is: what if there is a type variable at the head?+Consider this:+   class f (C f) => C f+   class c       => Id c+and now expand superclasses for constraint (C Id):+     C Id+ --> Id (C Id)+ --> C Id+ --> ....+Each step expands superclasses one layer, and clearly does not terminate.+-}++checkClassCycles :: Class -> Maybe SDoc+-- Nothing  <=> ok+-- Just err <=> possible cycle error+checkClassCycles cls+  = do { (definite_cycle, err) <- go (unitNameSet (getName cls))+                                     cls (mkTyVarTys (classTyVars cls))+       ; let herald | definite_cycle = text "Superclass cycle for"+                    | otherwise      = text "Potential superclass cycle for"+       ; return (vcat [ herald <+> quotes (ppr cls)+                      , nest 2 err, hint]) }+  where+    hint = text "Use UndecidableSuperClasses to accept this"++    -- Expand superclasses starting with (C a b), complaining+    -- if you find the same class a second time, or a type function+    -- or predicate headed by a type variable+    --+    -- NB: this code duplicates TcType.transSuperClasses, but+    --     with more error message generation clobber+    -- Make sure the two stay in sync.+    go :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc)+    go so_far cls tys = firstJusts $+                        map (go_pred so_far) $+                        immSuperClasses cls tys++    go_pred :: NameSet -> PredType -> Maybe (Bool, SDoc)+       -- Nothing <=> ok+       -- Just (True, err)  <=> definite cycle+       -- Just (False, err) <=> possible cycle+    go_pred so_far pred  -- NB: tcSplitTyConApp looks through synonyms+       | Just (tc, tys) <- tcSplitTyConApp_maybe pred+       = go_tc so_far pred tc tys+       | hasTyVarHead pred+       = Just (False, hang (text "one of whose superclass constraints is headed by a type variable:")+                         2 (quotes (ppr pred)))+       | otherwise+       = Nothing++    go_tc :: NameSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc)+    go_tc so_far pred tc tys+      | isFamilyTyCon tc+      = Just (False, hang (text "one of whose superclass constraints is headed by a type family:")+                        2 (quotes (ppr pred)))+      | Just cls <- tyConClass_maybe tc+      = go_cls so_far cls tys+      | otherwise   -- Equality predicate, for example+      = Nothing++    go_cls :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc)+    go_cls so_far cls tys+       | cls_nm `elemNameSet` so_far+       = Just (True, text "one of whose superclasses is" <+> quotes (ppr cls))+       | isCTupleClass cls+       = go so_far cls tys+       | otherwise+       = do { (b,err) <- go  (so_far `extendNameSet` cls_nm) cls tys+          ; return (b, text "one of whose superclasses is" <+> quotes (ppr cls)+                       $$ err) }+       where+         cls_nm = getName cls++{-+************************************************************************+*                                                                      *+        Role inference+*                                                                      *+************************************************************************++Note [Role inference]+~~~~~~~~~~~~~~~~~~~~~+The role inference algorithm datatype definitions to infer the roles on the+parameters. Although these roles are stored in the tycons, we can perform this+algorithm on the built tycons, as long as we don't peek at an as-yet-unknown+roles field! Ah, the magic of laziness.++First, we choose appropriate initial roles. For families and classes, roles+(including initial roles) are N. For datatypes, we start with the role in the+role annotation (if any), or otherwise use Phantom. This is done in+initialRoleEnv1.++The function irGroup then propagates role information until it reaches a+fixpoint, preferring N over (R or P) and R over P. To aid in this, we have a+monad RoleM, which is a combination reader and state monad. In its state are+the current RoleEnv, which gets updated by role propagation, and an update+bit, which we use to know whether or not we've reached the fixpoint. The+environment of RoleM contains the tycon whose parameters we are inferring, and+a VarEnv from parameters to their positions, so we can update the RoleEnv.+Between tycons, this reader information is missing; it is added by+addRoleInferenceInfo.++There are two kinds of tycons to consider: algebraic ones (excluding classes)+and type synonyms. (Remember, families don't participate -- all their parameters+are N.) An algebraic tycon processes each of its datacons, in turn. Note that+a datacon's universally quantified parameters might be different from the parent+tycon's parameters, so we use the datacon's univ parameters in the mapping from+vars to positions. Note also that we don't want to infer roles for existentials+(they're all at N, too), so we put them in the set of local variables. As an+optimisation, we skip any tycons whose roles are already all Nominal, as there+nowhere else for them to go. For synonyms, we just analyse their right-hand sides.++irType walks through a type, looking for uses of a variable of interest and+propagating role information. Because anything used under a phantom position+is at phantom and anything used under a nominal position is at nominal, the+irType function can assume that anything it sees is at representational. (The+other possibilities are pruned when they're encountered.)++The rest of the code is just plumbing.++How do we know that this algorithm is correct? It should meet the following+specification:++Let Z be a role context -- a mapping from variables to roles. The following+rules define the property (Z |- t : r), where t is a type and r is a role:++Z(a) = r'        r' <= r+------------------------- RCVar+Z |- a : r++---------- RCConst+Z |- T : r               -- T is a type constructor++Z |- t1 : r+Z |- t2 : N+-------------- RCApp+Z |- t1 t2 : r++forall i<=n. (r_i is R or N) implies Z |- t_i : r_i+roles(T) = r_1 .. r_n+---------------------------------------------------- RCDApp+Z |- T t_1 .. t_n : R++Z, a:N |- t : r+---------------------- RCAll+Z |- forall a:k.t : r+++We also have the following rules:++For all datacon_i in type T, where a_1 .. a_n are universally quantified+and b_1 .. b_m are existentially quantified, and the arguments are t_1 .. t_p,+then if forall j<=p, a_1 : r_1 .. a_n : r_n, b_1 : N .. b_m : N |- t_j : R,+then roles(T) = r_1 .. r_n++roles(->) = R, R+roles(~#) = N, N++With -dcore-lint on, the output of this algorithm is checked in checkValidRoles,+called from checkValidTycon.++Note [Role-checking data constructor arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  data T a where+    MkT :: Eq b => F a -> (a->a) -> T (G a)++Then we want to check the roles at which 'a' is used+in MkT's type.  We want to work on the user-written type,+so we need to take into account+  * the arguments:   (F a) and (a->a)+  * the context:     C a b+  * the result type: (G a)   -- this is in the eq_spec+++Note [Coercions in role inference]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Is (t |> co1) representationally equal to (t |> co2)? Of course they are! Changing+the kind of a type is totally irrelevant to the representation of that type. So,+we want to totally ignore coercions when doing role inference. This includes omitting+any type variables that appear in nominal positions but only within coercions.+-}++type RolesInfo = Name -> [Role]++type RoleEnv = NameEnv [Role]        -- from tycon names to roles++-- This, and any of the functions it calls, must *not* look at the roles+-- field of a tycon we are inferring roles about!+-- See Note [Role inference]+inferRoles :: HscSource -> RoleAnnotEnv -> [TyCon] -> Name -> [Role]+inferRoles hsc_src annots tycons+  = let role_env  = initialRoleEnv hsc_src annots tycons+        role_env' = irGroup role_env tycons in+    \name -> case lookupNameEnv role_env' name of+      Just roles -> roles+      Nothing    -> pprPanic "inferRoles" (ppr name)++initialRoleEnv :: HscSource -> RoleAnnotEnv -> [TyCon] -> RoleEnv+initialRoleEnv hsc_src annots = extendNameEnvList emptyNameEnv .+                                map (initialRoleEnv1 hsc_src annots)++initialRoleEnv1 :: HscSource -> RoleAnnotEnv -> TyCon -> (Name, [Role])+initialRoleEnv1 hsc_src annots_env tc+  | isFamilyTyCon tc      = (name, map (const Nominal) bndrs)+  | isAlgTyCon tc         = (name, default_roles)+  | isTypeSynonymTyCon tc = (name, default_roles)+  | otherwise             = pprPanic "initialRoleEnv1" (ppr tc)+  where name         = tyConName tc+        bndrs        = tyConBinders tc+        argflags     = map tyConBinderArgFlag bndrs+        num_exps     = count isVisibleArgFlag argflags++          -- if the number of annotations in the role annotation decl+          -- is wrong, just ignore it. We check this in the validity check.+        role_annots+          = case lookupRoleAnnot annots_env name of+              Just (L _ (RoleAnnotDecl _ annots))+                | annots `lengthIs` num_exps -> map unLoc annots+              _                              -> replicate num_exps Nothing+        default_roles = build_default_roles argflags role_annots++        build_default_roles (argf : argfs) (m_annot : ras)+          | isVisibleArgFlag argf+          = (m_annot `orElse` default_role) : build_default_roles argfs ras+        build_default_roles (_argf : argfs) ras+          = Nominal : build_default_roles argfs ras+        build_default_roles [] [] = []+        build_default_roles _ _ = pprPanic "initialRoleEnv1 (2)"+                                           (vcat [ppr tc, ppr role_annots])++        default_role+          | isClassTyCon tc               = Nominal+          -- Note [Default roles for abstract TyCons in hs-boot/hsig]+          | HsBootFile <- hsc_src+          , isAbstractTyCon tc            = Representational+          | HsigFile   <- hsc_src+          , isAbstractTyCon tc            = Nominal+          | otherwise                     = Phantom++-- Note [Default roles for abstract TyCons in hs-boot/hsig]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- What should the default role for an abstract TyCon be?+--+-- Originally, we inferred phantom role for abstract TyCons+-- in hs-boot files, because the type variables were never used.+--+-- This was silly, because the role of the abstract TyCon+-- was required to match the implementation, and the roles of+-- data types are almost never phantom.  Thus, in ticket #9204,+-- the default was changed so be representational (the most common case).  If+-- the implementing data type was actually nominal, you'd get an easy+-- to understand error, and add the role annotation yourself.+--+-- Then Backpack was added, and with it we added role *subtyping*+-- the matching judgment: if an abstract TyCon has a nominal+-- parameter, it's OK to implement it with a representational+-- parameter.  But now, the representational default is not a good+-- one, because you should *only* request representational if+-- you're planning to do coercions. To be maximally flexible+-- with what data types you will accept, you want the default+-- for hsig files is nominal.  We don't allow role subtyping+-- with hs-boot files (it's good practice to give an exactly+-- accurate role here, because any types that use the abstract+-- type will propagate the role information.)++irGroup :: RoleEnv -> [TyCon] -> RoleEnv+irGroup env tcs+  = let (env', update) = runRoleM env $ mapM_ irTyCon tcs in+    if update+    then irGroup env' tcs+    else env'++irTyCon :: TyCon -> RoleM ()+irTyCon tc+  | isAlgTyCon tc+  = do { old_roles <- lookupRoles tc+       ; unless (all (== Nominal) old_roles) $  -- also catches data families,+                                                -- which don't want or need role inference+         irTcTyVars tc $+         do { mapM_ (irType emptyVarSet) (tyConStupidTheta tc)  -- See #8958+            ; whenIsJust (tyConClass_maybe tc) irClass+            ; mapM_ irDataCon (visibleDataCons $ algTyConRhs tc) }}++  | Just ty <- synTyConRhs_maybe tc+  = irTcTyVars tc $+    irType emptyVarSet ty++  | otherwise+  = return ()++-- any type variable used in an associated type must be Nominal+irClass :: Class -> RoleM ()+irClass cls+  = mapM_ ir_at (classATs cls)+  where+    cls_tvs    = classTyVars cls+    cls_tv_set = mkVarSet cls_tvs++    ir_at at_tc+      = mapM_ (updateRole Nominal) nvars+      where nvars = filter (`elemVarSet` cls_tv_set) $ tyConTyVars at_tc++-- See Note [Role inference]+irDataCon :: DataCon -> RoleM ()+irDataCon datacon+  = setRoleInferenceVars univ_tvs $+    irExTyVars ex_tvs $ \ ex_var_set ->+    mapM_ (irType ex_var_set)+          (map tyVarKind ex_tvs ++ eqSpecPreds eq_spec ++ theta ++ arg_tys)+      -- See Note [Role-checking data constructor arguments]+  where+    (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)+      = dataConFullSig datacon++irType :: VarSet -> Type -> RoleM ()+irType = go+  where+    go lcls (TyVarTy tv)       = unless (tv `elemVarSet` lcls) $+                                 updateRole Representational tv+    go lcls (AppTy t1 t2)      = go lcls t1 >> markNominal lcls t2+    go lcls (TyConApp tc tys)  = do { roles <- lookupRolesX tc+                                    ; zipWithM_ (go_app lcls) roles tys }+    go lcls (ForAllTy tvb ty)  = do { let tv = binderVar tvb+                                          lcls' = extendVarSet lcls tv+                                    ; markNominal lcls (tyVarKind tv)+                                    ; go lcls' ty }+    go lcls (FunTy arg res)    = go lcls arg >> go lcls res+    go _    (LitTy {})         = return ()+      -- See Note [Coercions in role inference]+    go lcls (CastTy ty _)      = go lcls ty+    go _    (CoercionTy _)     = return ()++    go_app _ Phantom _ = return ()                 -- nothing to do here+    go_app lcls Nominal ty = markNominal lcls ty  -- all vars below here are N+    go_app lcls Representational ty = go lcls ty++irTcTyVars :: TyCon -> RoleM a -> RoleM a+irTcTyVars tc thing+  = setRoleInferenceTc (tyConName tc) $ go (tyConTyVars tc)+  where+    go []       = thing+    go (tv:tvs) = do { markNominal emptyVarSet (tyVarKind tv)+                     ; addRoleInferenceVar tv $ go tvs }++irExTyVars :: [TyVar] -> (TyVarSet -> RoleM a) -> RoleM a+irExTyVars orig_tvs thing = go emptyVarSet orig_tvs+  where+    go lcls []       = thing lcls+    go lcls (tv:tvs) = do { markNominal lcls (tyVarKind tv)+                          ; go (extendVarSet lcls tv) tvs }++markNominal :: TyVarSet   -- local variables+            -> Type -> RoleM ()+markNominal lcls ty = let nvars = fvVarList (FV.delFVs lcls $ get_ty_vars ty) in+                      mapM_ (updateRole Nominal) nvars+  where+     -- get_ty_vars gets all the tyvars (no covars!) from a type *without*+     -- recurring into coercions. Recall: coercions are totally ignored during+     -- role inference. See [Coercions in role inference]+    get_ty_vars :: Type -> FV+    get_ty_vars (TyVarTy tv)      = unitFV tv+    get_ty_vars (AppTy t1 t2)     = get_ty_vars t1 `unionFV` get_ty_vars t2+    get_ty_vars (FunTy t1 t2)     = get_ty_vars t1 `unionFV` get_ty_vars t2+    get_ty_vars (TyConApp _ tys)  = mapUnionFV get_ty_vars tys+    get_ty_vars (ForAllTy tvb ty) = tyCoFVsBndr tvb (get_ty_vars ty)+    get_ty_vars (LitTy {})        = emptyFV+    get_ty_vars (CastTy ty _)     = get_ty_vars ty+    get_ty_vars (CoercionTy _)    = emptyFV++-- like lookupRoles, but with Nominal tags at the end for oversaturated TyConApps+lookupRolesX :: TyCon -> RoleM [Role]+lookupRolesX tc+  = do { roles <- lookupRoles tc+       ; return $ roles ++ repeat Nominal }++-- gets the roles either from the environment or the tycon+lookupRoles :: TyCon -> RoleM [Role]+lookupRoles tc+  = do { env <- getRoleEnv+       ; case lookupNameEnv env (tyConName tc) of+           Just roles -> return roles+           Nothing    -> return $ tyConRoles tc }++-- tries to update a role; won't ever update a role "downwards"+updateRole :: Role -> TyVar -> RoleM ()+updateRole role tv+  = do { var_ns <- getVarNs+       ; name <- getTyConName+       ; case lookupVarEnv var_ns tv of+           Nothing -> pprPanic "updateRole" (ppr name $$ ppr tv $$ ppr var_ns)+           Just n  -> updateRoleEnv name n role }++-- the state in the RoleM monad+data RoleInferenceState = RIS { role_env  :: RoleEnv+                              , update    :: Bool }++-- the environment in the RoleM monad+type VarPositions = VarEnv Int++-- See [Role inference]+newtype RoleM a = RM { unRM :: Maybe Name   -- of the tycon+                            -> VarPositions+                            -> Int          -- size of VarPositions+                            -> RoleInferenceState+                            -> (a, RoleInferenceState) }++instance Functor RoleM where+    fmap = liftM++instance Applicative RoleM where+    pure x = RM $ \_ _ _ state -> (x, state)+    (<*>) = ap++instance Monad RoleM where+  a >>= f  = RM $ \m_info vps nvps state ->+                  let (a', state') = unRM a m_info vps nvps state in+                  unRM (f a') m_info vps nvps state'++runRoleM :: RoleEnv -> RoleM () -> (RoleEnv, Bool)+runRoleM env thing = (env', update)+  where RIS { role_env = env', update = update }+          = snd $ unRM thing Nothing emptyVarEnv 0 state+        state = RIS { role_env  = env+                    , update    = False }++setRoleInferenceTc :: Name -> RoleM a -> RoleM a+setRoleInferenceTc name thing = RM $ \m_name vps nvps state ->+                                ASSERT( isNothing m_name )+                                ASSERT( isEmptyVarEnv vps )+                                ASSERT( nvps == 0 )+                                unRM thing (Just name) vps nvps state++addRoleInferenceVar :: TyVar -> RoleM a -> RoleM a+addRoleInferenceVar tv thing+  = RM $ \m_name vps nvps state ->+    ASSERT( isJust m_name )+    unRM thing m_name (extendVarEnv vps tv nvps) (nvps+1) state++setRoleInferenceVars :: [TyVar] -> RoleM a -> RoleM a+setRoleInferenceVars tvs thing+  = RM $ \m_name _vps _nvps state ->+    ASSERT( isJust m_name )+    unRM thing m_name (mkVarEnv (zip tvs [0..])) (panic "setRoleInferenceVars")+         state++getRoleEnv :: RoleM RoleEnv+getRoleEnv = RM $ \_ _ _ state@(RIS { role_env = env }) -> (env, state)++getVarNs :: RoleM VarPositions+getVarNs = RM $ \_ vps _ state -> (vps, state)++getTyConName :: RoleM Name+getTyConName = RM $ \m_name _ _ state ->+                    case m_name of+                      Nothing   -> panic "getTyConName"+                      Just name -> (name, state)++updateRoleEnv :: Name -> Int -> Role -> RoleM ()+updateRoleEnv name n role+  = RM $ \_ _ _ state@(RIS { role_env = role_env }) -> ((),+         case lookupNameEnv role_env name of+           Nothing -> pprPanic "updateRoleEnv" (ppr name)+           Just roles -> let (before, old_role : after) = splitAt n roles in+                         if role `ltRole` old_role+                         then let roles' = before ++ role : after+                                  role_env' = extendNameEnv role_env name roles' in+                              RIS { role_env = role_env', update = True }+                         else state )+++{- *********************************************************************+*                                                                      *+                Building implicits+*                                                                      *+********************************************************************* -}++tcAddImplicits :: [TyCon] -> TcM TcGblEnv+-- Given a [TyCon], add to the TcGblEnv+--   * extend the TypeEnv with their implicitTyThings+--   * extend the TypeEnv with any default method Ids+--   * add bindings for record selectors+--   * add bindings for type representations for the TyThings+tcAddImplicits tycons+  = discardWarnings $+    tcExtendGlobalEnvImplicit implicit_things  $+    tcExtendGlobalValEnv def_meth_ids          $+    do { traceTc "tcAddImplicits" $ vcat+            [ text "tycons" <+> ppr tycons+            , text "implicits" <+> ppr implicit_things ]+       ; tcRecSelBinds (mkRecSelBinds tycons) }+ where+   implicit_things = concatMap implicitTyConThings tycons+   def_meth_ids    = mkDefaultMethodIds tycons++mkDefaultMethodIds :: [TyCon] -> [Id]+-- We want to put the default-method Ids (both vanilla and generic)+-- into the type environment so that they are found when we typecheck+-- the filled-in default methods of each instance declaration+-- See Note [Default method Ids and Template Haskell]+mkDefaultMethodIds tycons+  = [ mkExportedVanillaId dm_name (mkDefaultMethodType cls sel_id dm_spec)+    | tc <- tycons+    , Just cls <- [tyConClass_maybe tc]+    , (sel_id, Just (dm_name, dm_spec)) <- classOpItems cls ]++mkDefaultMethodType :: Class -> Id -> DefMethSpec Type -> Type+-- Returns the top-level type of the default method+mkDefaultMethodType _ sel_id VanillaDM        = idType sel_id+mkDefaultMethodType cls _   (GenericDM dm_ty) = mkSpecSigmaTy cls_tvs [pred] dm_ty+   where+     cls_tvs = classTyVars cls+     pred    = mkClassPred cls (mkTyVarTys cls_tvs)++{-+************************************************************************+*                                                                      *+                Building record selectors+*                                                                      *+************************************************************************+-}++{-+Note [Default method Ids and Template Haskell]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (Trac #4169):+   class Numeric a where+     fromIntegerNum :: a+     fromIntegerNum = ...++   ast :: Q [Dec]+   ast = [d| instance Numeric Int |]++When we typecheck 'ast' we have done the first pass over the class decl+(in tcTyClDecls), but we have not yet typechecked the default-method+declarations (because they can mention value declarations).  So we+must bring the default method Ids into scope first (so they can be seen+when typechecking the [d| .. |] quote, and typecheck them later.+-}++{-+************************************************************************+*                                                                      *+                Building record selectors+*                                                                      *+************************************************************************+-}++mkRecSelBinds :: [TyCon] -> HsValBinds Name+-- NB We produce *un-typechecked* bindings, rather like 'deriving'+--    This makes life easier, because the later type checking will add+--    all necessary type abstractions and applications+mkRecSelBinds tycons+  = ValBindsOut binds sigs+  where+    (sigs, binds) = unzip rec_sels+    rec_sels = map mkRecSelBind [ (tc,fld)+                                | tc <- tycons+                                , fld <- tyConFieldLabels tc ]++mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, (RecFlag, LHsBinds Name))+mkRecSelBind (tycon, fl)+  = mkOneRecordSelector all_cons (RecSelData tycon) fl+  where+    all_cons = map RealDataCon (tyConDataCons tycon)++mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel+                    -> (LSig Name, (RecFlag, LHsBinds Name))+mkOneRecordSelector all_cons idDetails fl+  = (L loc (IdSig sel_id), (NonRecursive, unitBag (L loc sel_bind)))+  where+    loc    = getSrcSpan sel_name+    lbl      = flLabel fl+    sel_name = flSelector fl++    sel_id = mkExportedLocalId rec_details sel_name sel_ty+    rec_details = RecSelId { sel_tycon = idDetails, sel_naughty = is_naughty }++    -- Find a representative constructor, con1+    cons_w_field = conLikesWithFields all_cons [lbl]+    con1 = ASSERT( not (null cons_w_field) ) head cons_w_field++    -- Selector type; Note [Polymorphic selectors]+    field_ty   = conLikeFieldType con1 lbl+    data_tvs   = tyCoVarsOfTypesWellScoped inst_tys+    data_tv_set= mkVarSet data_tvs+    is_naughty = not (tyCoVarsOfType field_ty `subVarSet` data_tv_set)+    (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty+    sel_ty | is_naughty = unitTy  -- See Note [Naughty record selectors]+           | otherwise  = mkSpecForAllTys data_tvs          $+                          mkPhiTy (conLikeStupidTheta con1) $   -- Urgh!+                          mkFunTy data_ty                   $+                          mkSpecForAllTys field_tvs         $+                          mkPhiTy field_theta               $+                          -- req_theta is empty for normal DataCon+                          mkPhiTy req_theta                 $+                          field_tau++    -- Make the binding: sel (C2 { fld = x }) = x+    --                   sel (C7 { fld = x }) = x+    --    where cons_w_field = [C2,C7]+    sel_bind = mkTopFunBind Generated sel_lname alts+      where+        alts | is_naughty = [mkSimpleMatch (mkPrefixFunRhs sel_lname)+                                           [] unit_rhs]+             | otherwise =  map mk_match cons_w_field ++ deflt+    mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname)+                                 [L loc (mk_sel_pat con)]+                                 (L loc (HsVar (L loc field_var)))+    mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields)+    rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }+    rec_field  = noLoc (HsRecField+                        { hsRecFieldLbl+                           = L loc (FieldOcc (L loc $ mkVarUnqual lbl) sel_name)+                        , hsRecFieldArg = L loc (VarPat (L loc field_var))+                        , hsRecPun = False })+    sel_lname = L loc sel_name+    field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc++    -- Add catch-all default case unless the case is exhaustive+    -- We do this explicitly so that we get a nice error message that+    -- mentions this particular record selector+    deflt | all dealt_with all_cons = []+          | otherwise = [mkSimpleMatch CaseAlt+                            [L loc (WildPat placeHolderType)]+                            (mkHsApp (L loc (HsVar+                                            (L loc (getName rEC_SEL_ERROR_ID))))+                                     (L loc (HsLit msg_lit)))]++        -- Do not add a default case unless there are unmatched+        -- constructors.  We must take account of GADTs, else we+        -- get overlap warning messages from the pattern-match checker+        -- NB: we need to pass type args for the *representation* TyCon+        --     to dataConCannotMatch, hence the calculation of inst_tys+        --     This matters in data families+        --              data instance T Int a where+        --                 A :: { fld :: Int } -> T Int Bool+        --                 B :: { fld :: Int } -> T Int Char+    dealt_with :: ConLike -> Bool+    dealt_with (PatSynCon _) = False -- We can't predict overlap+    dealt_with con@(RealDataCon dc) =+      con `elem` cons_w_field || dataConCannotMatch inst_tys dc++    (univ_tvs, _, eq_spec, _, req_theta, _, data_ty) = conLikeFullSig con1++    eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec)+    inst_tys = substTyVars eq_subst univ_tvs++    unit_rhs = mkLHsTupleExpr []+    msg_lit = HsStringPrim NoSourceText (fastStringToByteString lbl)++{-+Note [Polymorphic selectors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We take care to build the type of a polymorphic selector in the right+order, so that visible type application works.++  data Ord a => T a = MkT { field :: forall b. (Num a, Show b) => (a, b) }++We want++  field :: forall a. Ord a => T a -> forall b. (Num a, Show b) => (a, b)++Note [Naughty record selectors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A "naughty" field is one for which we can't define a record+selector, because an existential type variable would escape.  For example:+        data T = forall a. MkT { x,y::a }+We obviously can't define+        x (MkT v _) = v+Nevertheless we *do* put a RecSelId into the type environment+so that if the user tries to use 'x' as a selector we can bleat+helpfully, rather than saying unhelpfully that 'x' is not in scope.+Hence the sel_naughty flag, to identify record selectors that don't really exist.++In general, a field is "naughty" if its type mentions a type variable that+isn't in the result type of the constructor.  Note that this *allows*+GADT record selectors (Note [GADT record selectors]) whose types may look+like     sel :: T [a] -> a++For naughty selectors we make a dummy binding+   sel = ()+so that the later type-check will add them to the environment, and they'll be+exported.  The function is never called, because the typechecker spots the+sel_naughty field.++Note [GADT record selectors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For GADTs, we require that all constructors with a common field 'f' have the same+result type (modulo alpha conversion).  [Checked in TcTyClsDecls.checkValidTyCon]+E.g.+        data T where+          T1 { f :: Maybe a } :: T [a]+          T2 { f :: Maybe a, y :: b  } :: T [a]+          T3 :: T Int++and now the selector takes that result type as its argument:+   f :: forall a. T [a] -> Maybe a++Details: the "real" types of T1,T2 are:+   T1 :: forall r a.   (r~[a]) => a -> T r+   T2 :: forall r a b. (r~[a]) => a -> b -> T r++So the selector loooks like this:+   f :: forall a. T [a] -> Maybe a+   f (a:*) (t:T [a])+     = case t of+         T1 c   (g:[a]~[c]) (v:Maybe c)       -> v `cast` Maybe (right (sym g))+         T2 c d (g:[a]~[c]) (v:Maybe c) (w:d) -> v `cast` Maybe (right (sym g))+         T3 -> error "T3 does not have field f"++Note the forall'd tyvars of the selector are just the free tyvars+of the result type; there may be other tyvars in the constructor's+type (e.g. 'b' in T2).++Note the need for casts in the result!++Note [Selector running example]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's OK to combine GADTs and type families.  Here's a running example:++        data instance T [a] where+          T1 { fld :: b } :: T [Maybe b]++The representation type looks like this+        data :R7T a where+          T1 { fld :: b } :: :R7T (Maybe b)++and there's coercion from the family type to the representation type+        :CoR7T a :: T [a] ~ :R7T a++The selector we want for fld looks like this:++        fld :: forall b. T [Maybe b] -> b+        fld = /\b. \(d::T [Maybe b]).+              case d `cast` :CoR7T (Maybe b) of+                T1 (x::b) -> x++The scrutinee of the case has type :R7T (Maybe b), which can be+gotten by appying the eq_spec to the univ_tvs of the data con.++-}
+ typecheck/TcType.hs view
@@ -0,0 +1,2576 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[TcType]{Types used in the typechecker}++This module provides the Type interface for front-end parts of the+compiler.  These parts++        * treat "source types" as opaque:+                newtypes, and predicates are meaningful.+        * look through usage types++The "tc" prefix is for "TypeChecker", because the type checker+is the principal client.+-}++{-# LANGUAGE CPP, MultiWayIf, FlexibleContexts #-}++module TcType (+  --------------------------------+  -- Types+  TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType,+  TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet,+  TcKind, TcCoVar, TcTyCoVar, TcTyVarBinder, TcTyCon,++  ExpType(..), InferResult(..), ExpSigmaType, ExpRhoType, mkCheckExpType,++  SyntaxOpType(..), synKnownType, mkSynFunTys,++  -- TcLevel+  TcLevel(..), topTcLevel, pushTcLevel, isTopTcLevel,+  strictlyDeeperThan, sameDepthAs, fmvTcLevel,+  tcTypeLevel, tcTyVarLevel, maxTcLevel,++  --------------------------------+  -- MetaDetails+  UserTypeCtxt(..), pprUserTypeCtxt, isSigMaybe,+  TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv,+  MetaDetails(Flexi, Indirect), MetaInfo(..),+  isImmutableTyVar, isSkolemTyVar, isMetaTyVar,  isMetaTyVarTy, isTyVarTy,+  isSigTyVar, isOverlappableTyVar,  isTyConableTyVar,+  isFskTyVar, isFmvTyVar, isFlattenTyVar,+  isAmbiguousTyVar, metaTyVarRef, metaTyVarInfo,+  isFlexi, isIndirect, isRuntimeUnkSkol,+  metaTyVarTcLevel, setMetaTyVarTcLevel, metaTyVarTcLevel_maybe,+  isTouchableMetaTyVar, isTouchableOrFmv,+  isFloatedTouchableMetaTyVar,++  --------------------------------+  -- Builders+  mkPhiTy, mkInfSigmaTy, mkSpecSigmaTy, mkSigmaTy,+  mkNakedTyConApp, mkNakedAppTys, mkNakedAppTy,+  mkNakedCastTy,++  --------------------------------+  -- Splitters+  -- These are important because they do not look through newtypes+  getTyVar,+  tcSplitForAllTy_maybe,+  tcSplitForAllTys, tcSplitPiTys, tcSplitForAllTyVarBndrs,+  tcSplitPhiTy, tcSplitPredFunTy_maybe,+  tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcFunResultTyN,+  tcSplitFunTysN,+  tcSplitTyConApp, tcSplitTyConApp_maybe,+  tcRepSplitTyConApp_maybe, tcRepSplitTyConApp_maybe',+  tcTyConAppTyCon, tcTyConAppTyCon_maybe, tcTyConAppArgs,+  tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcRepSplitAppTy_maybe,+  tcGetTyVar_maybe, tcGetTyVar, nextRole,+  tcSplitSigmaTy, tcSplitNestedSigmaTys, tcDeepSplitSigmaTy_maybe,++  ---------------------------------+  -- Predicates.+  -- Again, newtypes are opaque+  eqType, eqTypes, nonDetCmpType, nonDetCmpTypes, eqTypeX,+  pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis,+  isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy,+  isFloatingTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,+  isIntegerTy, isBoolTy, isUnitTy, isCharTy, isCallStackTy, isCallStackPred,+  isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy,+  isPredTy, isTyVarClassPred, isTyVarExposed, isInsolubleOccursCheck,+  checkValidClsArgs, hasTyVarHead,+  isRigidEqPred, isRigidTy,++  ---------------------------------+  -- Misc type manipulators++  deNoteType,+  orphNamesOfType, orphNamesOfCo,+  orphNamesOfTypes, orphNamesOfCoCon,+  getDFunTyKey,+  evVarPred_maybe, evVarPred,++  ---------------------------------+  -- Predicate types+  mkMinimalBySCs, transSuperClasses,+  pickQuantifiablePreds, pickCapturedPreds,+  immSuperClasses,+  isImprovementPred,++  -- * Finding type instances+  tcTyFamInsts,++  -- * Finding "exact" (non-dead) type variables+  exactTyCoVarsOfType, exactTyCoVarsOfTypes,+  candidateQTyVarsOfType, candidateQTyVarsOfTypes, CandidatesQTvs(..),+  anyRewritableTyVar,++  -- * Extracting bound variables+  allBoundVariables, allBoundVariabless,++  ---------------------------------+  -- Foreign import and export+  isFFIArgumentTy,     -- :: DynFlags -> Safety -> Type -> Bool+  isFFIImportResultTy, -- :: DynFlags -> Type -> Bool+  isFFIExportResultTy, -- :: Type -> Bool+  isFFIExternalTy,     -- :: Type -> Bool+  isFFIDynTy,          -- :: Type -> Type -> Bool+  isFFIPrimArgumentTy, -- :: DynFlags -> Type -> Bool+  isFFIPrimResultTy,   -- :: DynFlags -> Type -> Bool+  isFFILabelTy,        -- :: Type -> Bool+  isFFITy,             -- :: Type -> Bool+  isFunPtrTy,          -- :: Type -> Bool+  tcSplitIOType_maybe, -- :: Type -> Maybe Type++  --------------------------------+  -- Rexported from Kind+  Kind, typeKind,+  liftedTypeKind,+  constraintKind,+  isLiftedTypeKind, isUnliftedTypeKind, classifiesTypeWithValues,++  --------------------------------+  -- Rexported from Type+  Type, PredType, ThetaType, TyBinder, ArgFlag(..),++  mkForAllTy, mkForAllTys, mkInvForAllTys, mkSpecForAllTys, mkInvForAllTy,+  mkFunTy, mkFunTys,+  mkTyConApp, mkAppTy, mkAppTys,+  mkTyConTy, mkTyVarTy,+  mkTyVarTys,++  isClassPred, isEqPred, isNomEqPred, isIPPred,+  mkClassPred,+  isDictLikeTy,+  tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy,+  isRuntimeRepVar, isKindLevPoly,+  isVisibleBinder, isInvisibleBinder,++  -- Type substitutions+  TCvSubst(..),         -- Representation visible to a few friends+  TvSubstEnv, emptyTCvSubst,+  zipTvSubst,+  mkTvSubstPrs, notElemTCvSubst, unionTCvSubst,+  getTvSubstEnv, setTvSubstEnv, getTCvInScope, extendTCvInScope,+  extendTCvInScopeList, extendTCvInScopeSet, extendTvSubstAndInScope,+  Type.lookupTyVar, Type.extendTCvSubst, Type.substTyVarBndr,+  Type.extendTvSubst,+  isInScope, mkTCvSubst, mkTvSubst, zipTyEnv, zipCoEnv,+  Type.substTy, substTys, substTyWith, substTyWithCoVars,+  substTyAddInScope,+  substTyUnchecked, substTysUnchecked, substThetaUnchecked,+  substTyWithUnchecked,+  substCoUnchecked, substCoWithUnchecked,+  substTheta,++  isUnliftedType,       -- Source types are always lifted+  isUnboxedTupleType,   -- Ditto+  isPrimitiveType,++  tcView, coreView,++  tyCoVarsOfType, tyCoVarsOfTypes, closeOverKinds,+  tyCoFVsOfType, tyCoFVsOfTypes,+  tyCoVarsOfTypeDSet, tyCoVarsOfTypesDSet, closeOverKindsDSet,+  tyCoVarsOfTypeList, tyCoVarsOfTypesList,+  noFreeVarsOfType,++  --------------------------------+  -- Transforming Types to TcTypes+  toTcType,    -- :: Type -> TcType+  toTcTypeBag, -- :: Bag EvVar -> Bag EvVar++  pprKind, pprParendKind, pprSigmaType,+  pprType, pprParendType, pprTypeApp, pprTyThingCategory, tyThingCategory,+  pprTheta, pprThetaArrowTy, pprClassPred,+  pprTvBndr, pprTvBndrs,++  TypeSize, sizeType, sizeTypes, toposortTyVars++  ) where++#include "HsVersions.h"++-- friends:+import Kind+import TyCoRep+import Class+import Var+import ForeignCall+import VarSet+import Coercion+import Type+import RepType+import TyCon++-- others:+import DynFlags+import CoreFVs+import Name -- hiding (varName)+            -- We use this to make dictionaries for type literals.+            -- Perhaps there's a better way to do this?+import NameSet+import VarEnv+import PrelNames+import TysWiredIn( coercibleClass, unitTyCon, unitTyConKey+                 , listTyCon, constraintKind )+import BasicTypes+import Util+import Bag+import Maybes+import Outputable+import FastString+import ErrUtils( Validity(..), MsgDoc, isValid )+import FV+import qualified GHC.LanguageExtensions as LangExt++import Data.IORef+import Data.Functor.Identity++{-+************************************************************************+*                                                                      *+              Types+*                                                                      *+************************************************************************++The type checker divides the generic Type world into the+following more structured beasts:++sigma ::= forall tyvars. phi+        -- A sigma type is a qualified type+        --+        -- Note that even if 'tyvars' is empty, theta+        -- may not be: e.g.   (?x::Int) => Int++        -- Note that 'sigma' is in prenex form:+        -- all the foralls are at the front.+        -- A 'phi' type has no foralls to the right of+        -- an arrow++phi :: theta => rho++rho ::= sigma -> rho+     |  tau++-- A 'tau' type has no quantification anywhere+-- Note that the args of a type constructor must be taus+tau ::= tyvar+     |  tycon tau_1 .. tau_n+     |  tau_1 tau_2+     |  tau_1 -> tau_2++-- In all cases, a (saturated) type synonym application is legal,+-- provided it expands to the required form.++Note [TcTyVars in the typechecker]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The typechecker uses a lot of type variables with special properties,+notably being a unification variable with a mutable reference.  These+use the 'TcTyVar' variant of Var.Var.++However, the type checker and constraint solver can encounter type+variables that use the 'TyVar' variant of Var.Var, for a couple of+reasons:++  - When unifying or flattening under (forall a. ty)++  - When typechecking a class decl, say+       class C (a :: k) where+          foo :: T a -> Int+    We have first kind-check the header; fix k and (a:k) to be+    TyVars, bring 'k' and 'a' into scope, and kind check the+    signature for 'foo'.  In doing so we call solveEqualities to+    solve any kind equalities in foo's signature.  So the solver+    may see free occurrences of 'k'.++It's convenient to simply treat these TyVars as skolem constants,+which of course they are.  So++* Var.tcTyVarDetails succeeds on a TyVar, returning+  vanillaSkolemTv, as well as on a TcTyVar.++* tcIsTcTyVar returns True for both TyVar and TcTyVar variants+  of Var.Var.  The "tc" prefix means "a type variable that can be+  encountered by the typechecker".++This is a bit of a change from an earlier era when we remoselessly+insisted on real TcTyVars in the type checker.  But that seems+unnecessary (for skolems, TyVars are fine) and it's now very hard+to guarantee, with the advent of kind equalities.++Note [Coercion variables in free variable lists]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are several places in the GHC codebase where functions like+tyCoVarsOfType, tyCoVarsOfCt, et al. are used to compute the free type+variables of a type. The "Co" part of these functions' names shouldn't be+dismissed, as it is entirely possible that they will include coercion variables+in addition to type variables! As a result, there are some places in TcType+where we must take care to check that a variable is a _type_ variable (using+isTyVar) before calling tcTyVarDetails--a partial function that is not defined+for coercion variables--on the variable. Failing to do so led to+GHC Trac #12785.+-}++-- See Note [TcTyVars in the typechecker]+type TcTyVar = TyVar    -- Used only during type inference+type TcCoVar = CoVar    -- Used only during type inference+type TcType = Type      -- A TcType can have mutable type variables+type TcTyCoVar = Var    -- Either a TcTyVar or a CoVar+        -- Invariant on ForAllTy in TcTypes:+        --      forall a. T+        -- a cannot occur inside a MutTyVar in T; that is,+        -- T is "flattened" before quantifying over a++type TcTyVarBinder = TyVarBinder+type TcTyCon       = TyCon   -- these can be the TcTyCon constructor++-- These types do not have boxy type variables in them+type TcPredType     = PredType+type TcThetaType    = ThetaType+type TcSigmaType    = TcType+type TcRhoType      = TcType  -- Note [TcRhoType]+type TcTauType      = TcType+type TcKind         = Kind+type TcTyVarSet     = TyVarSet+type TcTyCoVarSet   = TyCoVarSet+type TcDTyVarSet    = DTyVarSet+type TcDTyCoVarSet  = DTyCoVarSet+++{- *********************************************************************+*                                                                      *+          ExpType: an "expected type" in the type checker+*                                                                      *+********************************************************************* -}++-- | An expected type to check against during type-checking.+-- See Note [ExpType] in TcMType, where you'll also find manipulators.+data ExpType = Check TcType+             | Infer !InferResult++data InferResult+  = IR { ir_uniq :: Unique  -- For debugging only+       , ir_lvl  :: TcLevel -- See Note [TcLevel of ExpType] in TcMType+       , ir_inst :: Bool    -- True <=> deeply instantiate before returning+                            --           i.e. return a RhoType+                            -- False <=> do not instantiate before returning+                            --           i.e. return a SigmaType+       , ir_ref  :: IORef (Maybe TcType) }+         -- The type that fills in this hole should be a Type,+         -- that is, its kind should be (TYPE rr) for some rr++type ExpSigmaType = ExpType+type ExpRhoType   = ExpType++instance Outputable ExpType where+  ppr (Check ty) = text "Check" <> braces (ppr ty)+  ppr (Infer ir) = ppr ir++instance Outputable InferResult where+  ppr (IR { ir_uniq = u, ir_lvl = lvl+          , ir_inst = inst })+    = text "Infer" <> braces (ppr u <> comma <> ppr lvl <+> ppr inst)++-- | Make an 'ExpType' suitable for checking.+mkCheckExpType :: TcType -> ExpType+mkCheckExpType = Check+++{- *********************************************************************+*                                                                      *+          SyntaxOpType+*                                                                      *+********************************************************************* -}++-- | What to expect for an argument to a rebindable-syntax operator.+-- Quite like 'Type', but allows for holes to be filled in by tcSyntaxOp.+-- The callback called from tcSyntaxOp gets a list of types; the meaning+-- of these types is determined by a left-to-right depth-first traversal+-- of the 'SyntaxOpType' tree. So if you pass in+--+-- > SynAny `SynFun` (SynList `SynFun` SynType Int) `SynFun` SynAny+--+-- you'll get three types back: one for the first 'SynAny', the /element/+-- type of the list, and one for the last 'SynAny'. You don't get anything+-- for the 'SynType', because you've said positively that it should be an+-- Int, and so it shall be.+--+-- This is defined here to avoid defining it in TcExpr.hs-boot.+data SyntaxOpType+  = SynAny     -- ^ Any type+  | SynRho     -- ^ A rho type, deeply skolemised or instantiated as appropriate+  | SynList    -- ^ A list type. You get back the element type of the list+  | SynFun SyntaxOpType SyntaxOpType+               -- ^ A function.+  | SynType ExpType   -- ^ A known type.+infixr 0 `SynFun`++-- | Like 'SynType' but accepts a regular TcType+synKnownType :: TcType -> SyntaxOpType+synKnownType = SynType . mkCheckExpType++-- | Like 'mkFunTys' but for 'SyntaxOpType'+mkSynFunTys :: [SyntaxOpType] -> ExpType -> SyntaxOpType+mkSynFunTys arg_tys res_ty = foldr SynFun (SynType res_ty) arg_tys+++{-+Note [TcRhoType]+~~~~~~~~~~~~~~~~+A TcRhoType has no foralls or contexts at the top, or to the right of an arrow+  YES    (forall a. a->a) -> Int+  NO     forall a. a ->  Int+  NO     Eq a => a -> a+  NO     Int -> forall a. a -> Int+++************************************************************************+*                                                                      *+        TyVarDetails, MetaDetails, MetaInfo+*                                                                      *+************************************************************************++TyVarDetails gives extra info about type variables, used during type+checking.  It's attached to mutable type variables only.+It's knot-tied back to Var.hs.  There is no reason in principle+why Var.hs shouldn't actually have the definition, but it "belongs" here.++Note [Signature skolems]+~~~~~~~~~~~~~~~~~~~~~~~~+A SigTv is a specialised variant of TauTv, with the following invarints:++    * A SigTv can be unified only with a TyVar,+      not with any other type++    * Its MetaDetails, if filled in, will always be another SigTv+      or a SkolemTv++SigTvs are only distinguished to improve error messages.+Consider this++  f :: forall a. [a] -> Int+  f (x::b : xs) = 3++Here 'b' is a lexically scoped type variable, but it turns out to be+the same as the skolem 'a'.  So we make them both SigTvs, which can unify+with each other.++Similarly consider+  data T (a:k1) = MkT (S a)+  data S (b:k2) = MkS (T b)+When doing kind inference on {S,T} we don't want *skolems* for k1,k2,+because they end up unifying; we want those SigTvs again.++SigTvs are used *only* for pattern type signatures.++Note [TyVars and TcTyVars during type checking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The Var type has constructors TyVar and TcTyVar.  They are used+as follows:++* TcTyVar: used /only/ during type checking.  Should never appear+  afterwards.  May contain a mutable field, in the MetaTv case.++* TyVar: is never seen by the constraint solver, except locally+  inside a type like (forall a. [a] ->[a]), where 'a' is a TyVar.+  We instantiate these with TcTyVars before exposing the type+  to the constraint solver.++I have swithered about the latter invariant, excluding TyVars from the+constraint solver.  It's not strictly essential, and indeed+(historically but still there) Var.tcTyVarDetails returns+vanillaSkolemTv for a TyVar.++But ultimately I want to seeparate Type from TcType, and in that case+we would need to enforce the separation.+-}++-- A TyVarDetails is inside a TyVar+-- See Note [TyVars and TcTyVars]+data TcTyVarDetails+  = SkolemTv      -- A skolem+       TcLevel    -- Level of the implication that binds it+       Bool       -- True <=> this skolem type variable can be overlapped+                  --          when looking up instances+                  -- See Note [Binding when looking up instances] in InstEnv++  | FlatSkol      -- A flatten-skolem.  It stands for the TcType, and zonking+       TcType     -- will replace it by that type.+                  -- See Note [The flattening story] in TcFlatten++  | RuntimeUnk    -- Stands for an as-yet-unknown type in the GHCi+                  -- interactive context++  | MetaTv { mtv_info  :: MetaInfo+           , mtv_ref   :: IORef MetaDetails+           , mtv_tclvl :: TcLevel }  -- See Note [TcLevel and untouchable type variables]++vanillaSkolemTv, superSkolemTv :: TcTyVarDetails+-- See Note [Binding when looking up instances] in InstEnv+vanillaSkolemTv = SkolemTv (pushTcLevel topTcLevel) False  -- Might be instantiated+superSkolemTv   = SkolemTv (pushTcLevel topTcLevel) True   -- Treat this as a completely distinct type++-----------------------------+data MetaDetails+  = Flexi  -- Flexi type variables unify to become Indirects+  | Indirect TcType++data MetaInfo+   = TauTv         -- This MetaTv is an ordinary unification variable+                   -- A TauTv is always filled in with a tau-type, which+                   -- never contains any ForAlls.++   | SigTv         -- A variant of TauTv, except that it should not be+                   -- unified with a type, only with a type variable+                   -- See Note [Signature skolems]++   | FlatMetaTv    -- A flatten meta-tyvar+                   -- It is a meta-tyvar, but it is always untouchable, with level 0+                   -- See Note [The flattening story] in TcFlatten++instance Outputable MetaDetails where+  ppr Flexi         = text "Flexi"+  ppr (Indirect ty) = text "Indirect" <+> ppr ty++pprTcTyVarDetails :: TcTyVarDetails -> SDoc+-- For debugging+pprTcTyVarDetails (RuntimeUnk {})  = text "rt"+pprTcTyVarDetails (FlatSkol {})    = text "fsk"+pprTcTyVarDetails (SkolemTv lvl True)  = text "ssk" <> colon <> ppr lvl+pprTcTyVarDetails (SkolemTv lvl False) = text "sk"  <> colon <> ppr lvl+pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_tclvl = tclvl })+  = pp_info <> colon <> ppr tclvl+  where+    pp_info = case info of+                TauTv      -> text "tau"+                SigTv      -> text "sig"+                FlatMetaTv -> text "fuv"+++{- *********************************************************************+*                                                                      *+          UserTypeCtxt+*                                                                      *+********************************************************************* -}++-------------------------------------+-- UserTypeCtxt describes the origin of the polymorphic type+-- in the places where we need to an expression has that type++data UserTypeCtxt+  = FunSigCtxt      -- Function type signature, when checking the type+                    -- Also used for types in SPECIALISE pragmas+       Name              -- Name of the function+       Bool              -- True <=> report redundant constraints+                            -- This is usually True, but False for+                            --   * Record selectors (not important here)+                            --   * Class and instance methods.  Here+                            --     the code may legitimately be more+                            --     polymorphic than the signature+                            --     generated from the class+                            --     declaration++  | InfSigCtxt Name     -- Inferred type for function+  | ExprSigCtxt         -- Expression type signature+  | TypeAppCtxt         -- Visible type application+  | ConArgCtxt Name     -- Data constructor argument+  | TySynCtxt Name      -- RHS of a type synonym decl+  | PatSynCtxt Name     -- Type sig for a pattern synonym+  | PatSigCtxt          -- Type sig in pattern+                        --   eg  f (x::t) = ...+                        --   or  (x::t, y) = e+  | RuleSigCtxt Name    -- LHS of a RULE forall+                        --    RULE "foo" forall (x :: a -> a). f (Just x) = ...+  | ResSigCtxt          -- Result type sig+                        --      f x :: t = ....+  | ForSigCtxt Name     -- Foreign import or export signature+  | DefaultDeclCtxt     -- Types in a default declaration+  | InstDeclCtxt        -- An instance declaration+  | SpecInstCtxt        -- SPECIALISE instance pragma+  | ThBrackCtxt         -- Template Haskell type brackets [t| ... |]+  | GenSigCtxt          -- Higher-rank or impredicative situations+                        -- e.g. (f e) where f has a higher-rank type+                        -- We might want to elaborate this+  | GhciCtxt            -- GHCi command :kind <type>++  | ClassSCCtxt Name    -- Superclasses of a class+  | SigmaCtxt           -- Theta part of a normal for-all type+                        --      f :: <S> => a -> a+  | DataTyCtxt Name     -- The "stupid theta" part of a data decl+                        --      data <S> => T a = MkT a++{-+-- Notes re TySynCtxt+-- We allow type synonyms that aren't types; e.g.  type List = []+--+-- If the RHS mentions tyvars that aren't in scope, we'll+-- quantify over them:+--      e.g.    type T = a->a+-- will become  type T = forall a. a->a+--+-- With gla-exts that's right, but for H98 we should complain.+-}+++pprUserTypeCtxt :: UserTypeCtxt -> SDoc+pprUserTypeCtxt (FunSigCtxt n _)  = text "the type signature for" <+> quotes (ppr n)+pprUserTypeCtxt (InfSigCtxt n)    = text "the inferred type for" <+> quotes (ppr n)+pprUserTypeCtxt (RuleSigCtxt n)   = text "a RULE for" <+> quotes (ppr n)+pprUserTypeCtxt ExprSigCtxt       = text "an expression type signature"+pprUserTypeCtxt TypeAppCtxt       = text "a type argument"+pprUserTypeCtxt (ConArgCtxt c)    = text "the type of the constructor" <+> quotes (ppr c)+pprUserTypeCtxt (TySynCtxt c)     = text "the RHS of the type synonym" <+> quotes (ppr c)+pprUserTypeCtxt ThBrackCtxt       = text "a Template Haskell quotation [t|...|]"+pprUserTypeCtxt PatSigCtxt        = text "a pattern type signature"+pprUserTypeCtxt ResSigCtxt        = text "a result type signature"+pprUserTypeCtxt (ForSigCtxt n)    = text "the foreign declaration for" <+> quotes (ppr n)+pprUserTypeCtxt DefaultDeclCtxt   = text "a type in a `default' declaration"+pprUserTypeCtxt InstDeclCtxt      = text "an instance declaration"+pprUserTypeCtxt SpecInstCtxt      = text "a SPECIALISE instance pragma"+pprUserTypeCtxt GenSigCtxt        = text "a type expected by the context"+pprUserTypeCtxt GhciCtxt          = text "a type in a GHCi command"+pprUserTypeCtxt (ClassSCCtxt c)   = text "the super-classes of class" <+> quotes (ppr c)+pprUserTypeCtxt SigmaCtxt         = text "the context of a polymorphic type"+pprUserTypeCtxt (DataTyCtxt tc)   = text "the context of the data type declaration for" <+> quotes (ppr tc)+pprUserTypeCtxt (PatSynCtxt n)    = text "the signature for pattern synonym" <+> quotes (ppr n)++isSigMaybe :: UserTypeCtxt -> Maybe Name+isSigMaybe (FunSigCtxt n _) = Just n+isSigMaybe (ConArgCtxt n)   = Just n+isSigMaybe (ForSigCtxt n)   = Just n+isSigMaybe (PatSynCtxt n)   = Just n+isSigMaybe _                = Nothing+++{- *********************************************************************+*                                                                      *+                Untoucable type variables+*                                                                      *+********************************************************************* -}++newtype TcLevel = TcLevel Int deriving( Eq, Ord )+  -- See Note [TcLevel and untouchable type variables] for what this Int is+  -- See also Note [TcLevel assignment]++{-+Note [TcLevel and untouchable type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* Each unification variable (MetaTv)+  and each Implication+  has a level number (of type TcLevel)++* INVARIANTS.  In a tree of Implications,++    (ImplicInv) The level number of an Implication is+                STRICTLY GREATER THAN that of its parent++    (MetaTvInv) The level number of a unification variable is+                LESS THAN OR EQUAL TO that of its parent+                implication++* A unification variable is *touchable* if its level number+  is EQUAL TO that of its immediate parent implication.++* INVARIANT+    (GivenInv)  The free variables of the ic_given of an+                implication are all untouchable; ie their level+                numbers are LESS THAN the ic_tclvl of the implication++Note [Skolem escape prevention]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We only unify touchable unification variables.  Because of+(MetaTvInv), there can be no occurrences of the variable further out,+so the unification can't cause the skolems to escape. Example:+     data T = forall a. MkT a (a->Int)+     f x (MkT v f) = length [v,x]+We decide (x::alpha), and generate an implication like+      [1]forall a. (a ~ alpha[0])+But we must not unify alpha:=a, because the skolem would escape.++For the cases where we DO want to unify, we rely on floating the+equality.   Example (with same T)+     g x (MkT v f) = x && True+We decide (x::alpha), and generate an implication like+      [1]forall a. (Bool ~ alpha[0])+We do NOT unify directly, bur rather float out (if the constraint+does not mention 'a') to get+      (Bool ~ alpha[0]) /\ [1]forall a.()+and NOW we can unify alpha.++The same idea of only unifying touchables solves another problem.+Suppose we had+   (F Int ~ uf[0])  /\  [1](forall a. C a => F Int ~ beta[1])+In this example, beta is touchable inside the implication. The+first solveSimpleWanteds step leaves 'uf' un-unified. Then we move inside+the implication where a new constraint+       uf  ~  beta+emerges. If we (wrongly) spontaneously solved it to get uf := beta,+the whole implication disappears but when we pop out again we are left with+(F Int ~ uf) which will be unified by our final zonking stage and+uf will get unified *once more* to (F Int).++Note [TcLevel assignment]+~~~~~~~~~~~~~~~~~~~~~~~~~+We arrange the TcLevels like this++   0   Level for flatten meta-vars+   1   Top level+   2   First-level implication constraints+   3   Second-level implication constraints+   ...etc...++The flatten meta-vars are all at level 0, just to make them untouchable.+-}++maxTcLevel :: TcLevel -> TcLevel -> TcLevel+maxTcLevel (TcLevel a) (TcLevel b) = TcLevel (a `max` b)++fmvTcLevel :: TcLevel -> TcLevel+-- See Note [TcLevel assignment]+fmvTcLevel _ = TcLevel 0++topTcLevel :: TcLevel+-- See Note [TcLevel assignment]+topTcLevel = TcLevel 1   -- 1 = outermost level++isTopTcLevel :: TcLevel -> Bool+isTopTcLevel (TcLevel 1) = True+isTopTcLevel _           = False++pushTcLevel :: TcLevel -> TcLevel+-- See Note [TcLevel assignment]+pushTcLevel (TcLevel us) = TcLevel (us + 1)++strictlyDeeperThan :: TcLevel -> TcLevel -> Bool+strictlyDeeperThan (TcLevel tv_tclvl) (TcLevel ctxt_tclvl)+  = tv_tclvl > ctxt_tclvl++sameDepthAs :: TcLevel -> TcLevel -> Bool+sameDepthAs (TcLevel ctxt_tclvl) (TcLevel tv_tclvl)+  = ctxt_tclvl == tv_tclvl   -- NB: invariant ctxt_tclvl >= tv_tclvl+                             --     So <= would be equivalent++checkTcLevelInvariant :: TcLevel -> TcLevel -> Bool+-- Checks (MetaTvInv) from Note [TcLevel and untouchable type variables]+checkTcLevelInvariant (TcLevel ctxt_tclvl) (TcLevel tv_tclvl)+  = ctxt_tclvl >= tv_tclvl++tcTyVarLevel :: TcTyVar -> TcLevel+tcTyVarLevel tv+  = ASSERT2( tcIsTcTyVar tv, ppr tv )+    case tcTyVarDetails tv of+          MetaTv { mtv_tclvl = tv_lvl } -> tv_lvl+          SkolemTv tv_lvl _             -> tv_lvl+          FlatSkol ty                   -> tcTypeLevel ty+          RuntimeUnk                    -> topTcLevel++tcTypeLevel :: TcType -> TcLevel+-- Max level of any free var of the type+tcTypeLevel ty+  = foldDVarSet add topTcLevel (tyCoVarsOfTypeDSet ty)+  where+    add v lvl+      | isTcTyVar v = lvl `maxTcLevel` tcTyVarLevel v+      | otherwise   = lvl++instance Outputable TcLevel where+  ppr (TcLevel us) = ppr us++{- *********************************************************************+*                                                                      *+    Finding type family instances+*                                                                      *+************************************************************************+-}++-- | Finds outermost type-family applications occuring in a type,+-- after expanding synonyms.  In the list (F, tys) that is returned+-- we guarantee that tys matches F's arity.  For example, given+--    type family F a :: * -> *    (arity 1)+-- calling tcTyFamInsts on (Maybe (F Int Bool) will return+--     (F, [Int]), not (F, [Int,Bool])+--+-- This is important for its use in deciding termination of type+-- instances (see Trac #11581).  E.g.+--    type instance G [Int] = ...(F Int <big type>)...+-- we don't need to take <big type> into account when asking if+-- the calls on the RHS are smaller than the LHS+tcTyFamInsts :: Type -> [(TyCon, [Type])]+tcTyFamInsts ty+  | Just exp_ty <- tcView ty    = tcTyFamInsts exp_ty+tcTyFamInsts (TyVarTy _)        = []+tcTyFamInsts (TyConApp tc tys)+  | isTypeFamilyTyCon tc        = [(tc, take (tyConArity tc) tys)]+  | otherwise                   = concat (map tcTyFamInsts tys)+tcTyFamInsts (LitTy {})         = []+tcTyFamInsts (ForAllTy bndr ty) = tcTyFamInsts (binderKind bndr)+                                  ++ tcTyFamInsts ty+tcTyFamInsts (FunTy ty1 ty2)    = tcTyFamInsts ty1 ++ tcTyFamInsts ty2+tcTyFamInsts (AppTy ty1 ty2)    = tcTyFamInsts ty1 ++ tcTyFamInsts ty2+tcTyFamInsts (CastTy ty _)      = tcTyFamInsts ty+tcTyFamInsts (CoercionTy _)     = []  -- don't count tyfams in coercions,+                                      -- as they never get normalized, anyway++{-+************************************************************************+*                                                                      *+          The "exact" free variables of a type+*                                                                      *+************************************************************************++Note [Silly type synonym]+~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  type T a = Int+What are the free tyvars of (T x)?  Empty, of course!+Here's the example that Ralf Laemmel showed me:+  foo :: (forall a. C u a -> C u a) -> u+  mappend :: Monoid u => u -> u -> u++  bar :: Monoid u => u+  bar = foo (\t -> t `mappend` t)+We have to generalise at the arg to f, and we don't+want to capture the constraint (Monad (C u a)) because+it appears to mention a.  Pretty silly, but it was useful to him.++exactTyCoVarsOfType is used by the type checker to figure out exactly+which type variables are mentioned in a type.  It's also used in the+smart-app checking code --- see TcExpr.tcIdApp++On the other hand, consider a *top-level* definition+  f = (\x -> x) :: T a -> T a+If we don't abstract over 'a' it'll get fixed to GHC.Prim.Any, and then+if we have an application like (f "x") we get a confusing error message+involving Any.  So the conclusion is this: when generalising+  - at top level use tyCoVarsOfType+  - in nested bindings use exactTyCoVarsOfType+See Trac #1813 for example.+-}++exactTyCoVarsOfType :: Type -> TyCoVarSet+-- Find the free type variables (of any kind)+-- but *expand* type synonyms.  See Note [Silly type synonym] above.+exactTyCoVarsOfType ty+  = go ty+  where+    go ty | Just ty' <- tcView ty = go ty'  -- This is the key line+    go (TyVarTy tv)         = unitVarSet tv `unionVarSet` go (tyVarKind tv)+    go (TyConApp _ tys)     = exactTyCoVarsOfTypes tys+    go (LitTy {})           = emptyVarSet+    go (AppTy fun arg)      = go fun `unionVarSet` go arg+    go (FunTy arg res)      = go arg `unionVarSet` go res+    go (ForAllTy bndr ty)   = delBinderVar (go ty) bndr `unionVarSet` go (binderKind bndr)+    go (CastTy ty co)       = go ty `unionVarSet` goCo co+    go (CoercionTy co)      = goCo co++    goCo (Refl _ ty)        = go ty+    goCo (TyConAppCo _ _ args)= goCos args+    goCo (AppCo co arg)     = goCo co `unionVarSet` goCo arg+    goCo (ForAllCo tv k_co co)+      = goCo co `delVarSet` tv `unionVarSet` goCo k_co+    goCo (FunCo _ co1 co2)   = goCo co1 `unionVarSet` goCo co2+    goCo (CoVarCo v)         = unitVarSet v `unionVarSet` go (varType v)+    goCo (AxiomInstCo _ _ args) = goCos args+    goCo (UnivCo p _ t1 t2)  = goProv p `unionVarSet` go t1 `unionVarSet` go t2+    goCo (SymCo co)          = goCo co+    goCo (TransCo co1 co2)   = goCo co1 `unionVarSet` goCo co2+    goCo (NthCo _ co)        = goCo co+    goCo (LRCo _ co)         = goCo co+    goCo (InstCo co arg)     = goCo co `unionVarSet` goCo arg+    goCo (CoherenceCo c1 c2) = goCo c1 `unionVarSet` goCo c2+    goCo (KindCo co)         = goCo co+    goCo (SubCo co)          = goCo co+    goCo (AxiomRuleCo _ c)   = goCos c++    goCos cos = foldr (unionVarSet . goCo) emptyVarSet cos++    goProv UnsafeCoerceProv     = emptyVarSet+    goProv (PhantomProv kco)    = goCo kco+    goProv (ProofIrrelProv kco) = goCo kco+    goProv (PluginProv _)       = emptyVarSet+    goProv (HoleProv _)         = emptyVarSet++exactTyCoVarsOfTypes :: [Type] -> TyVarSet+exactTyCoVarsOfTypes tys = mapUnionVarSet exactTyCoVarsOfType tys++anyRewritableTyVar :: Bool -> (TcTyVar -> Bool)+                   -> TcType -> Bool+-- (anyRewritableTyVar ignore_cos pred ty) returns True+--    if the 'pred' returns True of free TyVar in 'ty'+-- Do not look inside casts and coercions if 'ignore_cos' is True+-- See Note [anyRewritableTyVar]+anyRewritableTyVar ignore_cos pred ty+  = go emptyVarSet ty+  where+    go_tv bound tv | tv `elemVarSet` bound = False+                   | otherwise             = pred tv++    go bound (TyVarTy tv)     = go_tv bound tv+    go _     (LitTy {})       = False+    go bound (TyConApp _ tys) = any (go bound) tys+    go bound (AppTy fun arg)  = go bound fun || go bound arg+    go bound (FunTy arg res)  = go bound arg || go bound res+    go bound (ForAllTy tv ty) = go (bound `extendVarSet` binderVar tv) ty+    go bound (CastTy ty co)   = go bound ty || go_co bound co+    go bound (CoercionTy co)  = go_co bound co++    go_co bound co+      | ignore_cos = False+      | otherwise  = anyVarSet (go_tv bound) (tyCoVarsOfCo co)+      -- We don't have an equivalent of anyRewritableTyVar for coercions+      -- (at least not yet) so take the free vars and test them++{- Note [anyRewritableTyVar]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+anyRewritableTyVar is used during kick-out from the inert set,+to decide if, given a new equality (a ~ ty), we should kick out+a constraint C.  Rather than gather free variables and see if 'a'+is among them, we instead pass in a predicate; this is just efficiency.+-}++{- *********************************************************************+*                                                                      *+          Bound variables in a type+*                                                                      *+********************************************************************* -}++-- | Find all variables bound anywhere in a type.+-- See also Note [Scope-check inferred kinds] in TcHsType+allBoundVariables :: Type -> TyVarSet+allBoundVariables ty = fvVarSet $ go ty+  where+    go :: Type -> FV+    go (TyVarTy tv)     = go (tyVarKind tv)+    go (TyConApp _ tys) = mapUnionFV go tys+    go (AppTy t1 t2)    = go t1 `unionFV` go t2+    go (FunTy t1 t2)    = go t1 `unionFV` go t2+    go (ForAllTy (TvBndr tv _) t2) = FV.unitFV tv `unionFV`+                                    go (tyVarKind tv) `unionFV` go t2+    go (LitTy {})       = emptyFV+    go (CastTy ty _)    = go ty+    go (CoercionTy {})  = emptyFV+      -- any types mentioned in a coercion should also be mentioned in+      -- a type.++allBoundVariabless :: [Type] -> TyVarSet+allBoundVariabless = mapUnionVarSet allBoundVariables++{- *********************************************************************+*                                                                      *+          Type and kind variables in a type+*                                                                      *+********************************************************************* -}++data CandidatesQTvs  -- See Note [Dependent type variables]+                     -- See Note [CandidatesQTvs determinism]+  = DV { dv_kvs :: DTyCoVarSet  -- "kind" variables (dependent)+       , dv_tvs :: DTyVarSet    -- "type" variables (non-dependent)+         -- A variable may appear in both sets+         -- E.g.   T k (x::k)    The first occurrence of k makes it+         --                      show up in dv_tvs, the second in dv_kvs+         -- See Note [Dependent type variables]+    }++instance Monoid CandidatesQTvs where+   mempty = DV { dv_kvs = emptyDVarSet, dv_tvs = emptyDVarSet }+   mappend (DV { dv_kvs = kv1, dv_tvs = tv1 })+           (DV { dv_kvs = kv2, dv_tvs = tv2 })+          = DV { dv_kvs = kv1 `unionDVarSet` kv2+               , dv_tvs = tv1 `unionDVarSet` tv2}++instance Outputable CandidatesQTvs where+  ppr (DV {dv_kvs = kvs, dv_tvs = tvs })+    = text "DV" <+> braces (sep [ text "dv_kvs =" <+> ppr kvs+                                , text "dv_tvs =" <+> ppr tvs ])++{- Note [Dependent type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In Haskell type inference we quantify over type variables; but we only+quantify over /kind/ variables when -XPolyKinds is on.  Without -XPolyKinds+we default the kind variables to *.++So, to support this defaulting, and only for that reason, when+collecting the free vars of a type, prior to quantifying, we must keep+the type and kind variables separate.++But what does that mean in a system where kind variables /are/ type+variables? It's a fairly arbitrary distinction based on how the+variables appear:++  - "Kind variables" appear in the kind of some other free variable+     PLUS any free coercion variables++     These are the ones we default to * if -XPolyKinds is off++  - "Type variables" are all free vars that are not kind variables++E.g.  In the type    T k (a::k)+      'k' is a kind variable, because it occurs in the kind of 'a',+          even though it also appears at "top level" of the type+      'a' is a type variable, because it doesn't++We gather these variables using a CandidatesQTvs record:+  DV { dv_kvs: Variables free in the kind of a free type variable+               or of a forall-bound type variable+     , dv_tvs: Variables sytactically free in the type }++So:  dv_kvs            are the kind variables of the type+     (dv_tvs - dv_kvs) are the type variable of the type++Note that++* A variable can occur in both.+      T k (x::k)    The first occurrence of k makes it+                    show up in dv_tvs, the second in dv_kvs++* We include any coercion variables in the "dependent",+  "kind-variable" set because we never quantify over them.++* Both sets are un-ordered, of course.++* The "kind variables" might depend on each other; e.g+     (k1 :: k2), (k2 :: *)+  The "type variables" do not depend on each other; if+  one did, it'd be classified as a kind variable!++Note [CandidatesQTvs determinism and order]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* Determinism: when we quantify over type variables we decide the+  order in which they appear in the final type. Because the order of+  type variables in the type can end up in the interface file and+  affects some optimizations like worker-wrapper, we want this order to+  be deterministic.++  To achieve that we use deterministic sets of variables that can be+  converted to lists in a deterministic order. For more information+  about deterministic sets see Note [Deterministic UniqFM] in UniqDFM.++* Order: as well as being deterministic, we use an+  accumulating-parameter style for candidateQTyVarsOfType so that we+  add variables one at a time, left to right.  That means we tend to+  produce the variables in left-to-right order.  This is just to make+  it bit more predicatable for the programmer.+-}++-- | Worker for 'splitDepVarsOfType'. This might output the same var+-- in both sets, if it's used in both a type and a kind.+-- See Note [CandidatesQTvs determinism and order]+-- See Note [Dependent type variables]+candidateQTyVarsOfType :: Type -> CandidatesQTvs+candidateQTyVarsOfType = split_dvs emptyVarSet mempty++split_dvs :: VarSet -> CandidatesQTvs -> Type -> CandidatesQTvs+split_dvs bound dvs ty+  = go dvs ty+  where+    go dv (AppTy t1 t2)    = go (go dv t1) t2+    go dv (TyConApp _ tys) = foldl go dv tys+    go dv (FunTy arg res)  = go (go dv arg) res+    go dv (LitTy {})       = dv+    go dv (CastTy ty co)   = go dv ty `mappend` go_co co+    go dv (CoercionTy co)  = dv `mappend` go_co co++    go dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) (TyVarTy tv)+      | tv `elemVarSet` bound+      = dv+      | otherwise+      = DV { dv_kvs = kvs `unionDVarSet`+                      kill_bound (tyCoVarsOfTypeDSet (tyVarKind tv))+           , dv_tvs = tvs `extendDVarSet` tv }++    go dv (ForAllTy (TvBndr tv _) ty)+      = DV { dv_kvs = kvs `unionDVarSet`+                      kill_bound (tyCoVarsOfTypeDSet (tyVarKind tv))+           , dv_tvs = tvs }+      where+        DV { dv_kvs = kvs, dv_tvs = tvs } = split_dvs (bound `extendVarSet` tv) dv ty++    go_co co = DV { dv_kvs = kill_bound (tyCoVarsOfCoDSet co)+                  , dv_tvs = emptyDVarSet }++    kill_bound free+      | isEmptyVarSet bound = free+      | otherwise           = filterDVarSet (not . (`elemVarSet` bound)) free++-- | Like 'splitDepVarsOfType', but over a list of types+candidateQTyVarsOfTypes :: [Type] -> CandidatesQTvs+candidateQTyVarsOfTypes = foldl (split_dvs emptyVarSet) mempty++{-+************************************************************************+*                                                                      *+                Predicates+*                                                                      *+************************************************************************+-}++tcIsTcTyVar :: TcTyVar -> Bool+-- See Note [TcTyVars in the typechecker]+tcIsTcTyVar tv = isTyVar tv++isTouchableOrFmv :: TcLevel -> TcTyVar -> Bool+isTouchableOrFmv ctxt_tclvl tv+  = ASSERT2( tcIsTcTyVar tv, ppr tv )+    case tcTyVarDetails tv of+      MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info }+        -> ASSERT2( checkTcLevelInvariant ctxt_tclvl tv_tclvl,+                    ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl )+           case info of+             FlatMetaTv -> True+             _          -> tv_tclvl `sameDepthAs` ctxt_tclvl+      _          -> False++isTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool+isTouchableMetaTyVar ctxt_tclvl tv+  | isTyVar tv -- See Note [Coercion variables in free variable lists]+  = ASSERT2( tcIsTcTyVar tv, ppr tv )+    case tcTyVarDetails tv of+      MetaTv { mtv_tclvl = tv_tclvl }+        -> ASSERT2( checkTcLevelInvariant ctxt_tclvl tv_tclvl,+                    ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl )+           tv_tclvl `sameDepthAs` ctxt_tclvl+      _ -> False+  | otherwise = False++isFloatedTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool+isFloatedTouchableMetaTyVar ctxt_tclvl tv+  | isTyVar tv -- See Note [Coercion variables in free variable lists]+  = ASSERT2( tcIsTcTyVar tv, ppr tv )+    case tcTyVarDetails tv of+      MetaTv { mtv_tclvl = tv_tclvl } -> tv_tclvl `strictlyDeeperThan` ctxt_tclvl+      _ -> False+  | otherwise = False++isImmutableTyVar :: TyVar -> Bool+isImmutableTyVar tv = isSkolemTyVar tv++isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar,+  isMetaTyVar, isAmbiguousTyVar,+  isFmvTyVar, isFskTyVar, isFlattenTyVar :: TcTyVar -> Bool++isTyConableTyVar tv+        -- True of a meta-type variable that can be filled in+        -- with a type constructor application; in particular,+        -- not a SigTv+  | isTyVar tv -- See Note [Coercion variables in free variable lists]+  = ASSERT2( tcIsTcTyVar tv, ppr tv )+    case tcTyVarDetails tv of+        MetaTv { mtv_info = SigTv } -> False+        _                           -> True+  | otherwise = True++isFmvTyVar tv+  = ASSERT2( tcIsTcTyVar tv, ppr tv )+    case tcTyVarDetails tv of+        MetaTv { mtv_info = FlatMetaTv } -> True+        _                                -> False++-- | True of both given and wanted flatten-skolems (fak and usk)+isFlattenTyVar tv+  = ASSERT2( tcIsTcTyVar tv, ppr tv )+    case tcTyVarDetails tv of+        FlatSkol {}                      -> True+        MetaTv { mtv_info = FlatMetaTv } -> True+        _                                -> False++-- | True of FlatSkol skolems only+isFskTyVar tv+  = ASSERT2( tcIsTcTyVar tv, ppr tv )+    case tcTyVarDetails tv of+        FlatSkol {} -> True+        _           -> False++isSkolemTyVar tv+  = ASSERT2( tcIsTcTyVar tv, ppr tv )+    case tcTyVarDetails tv of+        MetaTv {} -> False+        _other    -> True++isOverlappableTyVar tv+  | isTyVar tv -- See Note [Coercion variables in free variable lists]+  = ASSERT2( tcIsTcTyVar tv, ppr tv )+    case tcTyVarDetails tv of+        SkolemTv _ overlappable -> overlappable+        _                       -> False+  | otherwise = False++isMetaTyVar tv+  | isTyVar tv -- See Note [Coercion variables in free variable lists]+  = ASSERT2( tcIsTcTyVar tv, ppr tv )+    case tcTyVarDetails tv of+        MetaTv {} -> True+        _         -> False+  | otherwise = False++-- isAmbiguousTyVar is used only when reporting type errors+-- It picks out variables that are unbound, namely meta+-- type variables and the RuntimUnk variables created by+-- RtClosureInspect.zonkRTTIType.  These are "ambiguous" in+-- the sense that they stand for an as-yet-unknown type+isAmbiguousTyVar tv+  | isTyVar tv -- See Note [Coercion variables in free variable lists]+  = case tcTyVarDetails tv of+        MetaTv {}     -> True+        RuntimeUnk {} -> True+        _             -> False+  | otherwise = False++isMetaTyVarTy :: TcType -> Bool+isMetaTyVarTy (TyVarTy tv) = isMetaTyVar tv+isMetaTyVarTy _            = False++metaTyVarInfo :: TcTyVar -> MetaInfo+metaTyVarInfo tv+  = case tcTyVarDetails tv of+      MetaTv { mtv_info = info } -> info+      _ -> pprPanic "metaTyVarInfo" (ppr tv)++metaTyVarTcLevel :: TcTyVar -> TcLevel+metaTyVarTcLevel tv+  = case tcTyVarDetails tv of+      MetaTv { mtv_tclvl = tclvl } -> tclvl+      _ -> pprPanic "metaTyVarTcLevel" (ppr tv)++metaTyVarTcLevel_maybe :: TcTyVar -> Maybe TcLevel+metaTyVarTcLevel_maybe tv+  = case tcTyVarDetails tv of+      MetaTv { mtv_tclvl = tclvl } -> Just tclvl+      _                            -> Nothing++metaTyVarRef :: TyVar -> IORef MetaDetails+metaTyVarRef tv+  = case tcTyVarDetails tv of+        MetaTv { mtv_ref = ref } -> ref+        _ -> pprPanic "metaTyVarRef" (ppr tv)++setMetaTyVarTcLevel :: TcTyVar -> TcLevel -> TcTyVar+setMetaTyVarTcLevel tv tclvl+  = case tcTyVarDetails tv of+      details@(MetaTv {}) -> setTcTyVarDetails tv (details { mtv_tclvl = tclvl })+      _ -> pprPanic "metaTyVarTcLevel" (ppr tv)++isSigTyVar :: Var -> Bool+isSigTyVar tv+  = case tcTyVarDetails tv of+        MetaTv { mtv_info = SigTv } -> True+        _                           -> False++isFlexi, isIndirect :: MetaDetails -> Bool+isFlexi Flexi = True+isFlexi _     = False++isIndirect (Indirect _) = True+isIndirect _            = False++isRuntimeUnkSkol :: TyVar -> Bool+-- Called only in TcErrors; see Note [Runtime skolems] there+isRuntimeUnkSkol x+  | RuntimeUnk <- tcTyVarDetails x = True+  | otherwise                      = False++{-+************************************************************************+*                                                                      *+\subsection{Tau, sigma and rho}+*                                                                      *+************************************************************************+-}++mkSigmaTy :: [TyVarBinder] -> [PredType] -> Type -> Type+mkSigmaTy bndrs theta tau = mkForAllTys bndrs (mkPhiTy theta tau)++-- | Make a sigma ty where all type variables are 'Inferred'. That is,+-- they cannot be used with visible type application.+mkInfSigmaTy :: [TyVar] -> [PredType] -> Type -> Type+mkInfSigmaTy tyvars ty = mkSigmaTy (mkTyVarBinders Inferred tyvars) ty++-- | Make a sigma ty where all type variables are "specified". That is,+-- they can be used with visible type application+mkSpecSigmaTy :: [TyVar] -> [PredType] -> Type -> Type+mkSpecSigmaTy tyvars ty = mkSigmaTy (mkTyVarBinders Specified tyvars) ty++mkPhiTy :: [PredType] -> Type -> Type+mkPhiTy = mkFunTys++---------------+getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to+                                -- construct a dictionary function name+getDFunTyKey ty | Just ty' <- coreView ty = getDFunTyKey ty'+getDFunTyKey (TyVarTy tv)            = getOccName tv+getDFunTyKey (TyConApp tc _)         = getOccName tc+getDFunTyKey (LitTy x)               = getDFunTyLitKey x+getDFunTyKey (AppTy fun _)           = getDFunTyKey fun+getDFunTyKey (FunTy _ _)             = getOccName funTyCon+getDFunTyKey (ForAllTy _ t)          = getDFunTyKey t+getDFunTyKey (CastTy ty _)           = getDFunTyKey ty+getDFunTyKey t@(CoercionTy _)        = pprPanic "getDFunTyKey" (ppr t)++getDFunTyLitKey :: TyLit -> OccName+getDFunTyLitKey (NumTyLit n) = mkOccName Name.varName (show n)+getDFunTyLitKey (StrTyLit n) = mkOccName Name.varName (show n)  -- hm++---------------+mkNakedTyConApp :: TyCon -> [Type] -> Type+-- Builds a TyConApp+--   * without being strict in TyCon,+--   * without satisfying the invariants of TyConApp+-- A subsequent zonking will establish the invariants+-- See Note [Type-checking inside the knot] in TcHsType+mkNakedTyConApp tc tys = TyConApp tc tys++mkNakedAppTys :: Type -> [Type] -> Type+-- See Note [Type-checking inside the knot] in TcHsType+mkNakedAppTys ty1                []   = ty1+mkNakedAppTys (TyConApp tc tys1) tys2 = mkNakedTyConApp tc (tys1 ++ tys2)+mkNakedAppTys ty1                tys2 = foldl AppTy ty1 tys2++mkNakedAppTy :: Type -> Type -> Type+-- See Note [Type-checking inside the knot] in TcHsType+mkNakedAppTy ty1 ty2 = mkNakedAppTys ty1 [ty2]++mkNakedCastTy :: Type -> Coercion -> Type+-- Do simple, fast compaction; especially dealing with Refl+-- for which it's plain stupid to create a cast+-- This simple function killed off a huge number of Refl casts+-- in types, at birth.+-- Note that it's fine to do this even for a "mkNaked" function,+-- because we don't look at TyCons.  isReflCo checks if the coercion+-- is structurally Refl; it does not check for shape k ~ k.+mkNakedCastTy ty co | isReflCo co = ty+mkNakedCastTy (CastTy ty co1) co2 = CastTy ty (co1 `mkTransCo` co2)+mkNakedCastTy ty co = CastTy ty co++{-+************************************************************************+*                                                                      *+\subsection{Expanding and splitting}+*                                                                      *+************************************************************************++These tcSplit functions are like their non-Tc analogues, but+        *) they do not look through newtypes++However, they are non-monadic and do not follow through mutable type+variables.  It's up to you to make sure this doesn't matter.+-}++-- | Splits a forall type into a list of 'TyBinder's and the inner type.+-- Always succeeds, even if it returns an empty list.+tcSplitPiTys :: Type -> ([TyBinder], Type)+tcSplitPiTys = splitPiTys++tcSplitForAllTy_maybe :: Type -> Maybe (TyVarBinder, Type)+tcSplitForAllTy_maybe ty | Just ty' <- tcView ty = tcSplitForAllTy_maybe ty'+tcSplitForAllTy_maybe (ForAllTy tv ty) = Just (tv, ty)+tcSplitForAllTy_maybe _                = Nothing++-- | Like 'tcSplitPiTys', but splits off only named binders, returning+-- just the tycovars.+tcSplitForAllTys :: Type -> ([TyVar], Type)+tcSplitForAllTys = splitForAllTys++-- | Like 'tcSplitForAllTys', but splits off only named binders.+tcSplitForAllTyVarBndrs :: Type -> ([TyVarBinder], Type)+tcSplitForAllTyVarBndrs = splitForAllTyVarBndrs++-- | Is this a ForAllTy with a named binder?+tcIsForAllTy :: Type -> Bool+tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty'+tcIsForAllTy (ForAllTy {}) = True+tcIsForAllTy _             = False++tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type)+-- Split off the first predicate argument from a type+tcSplitPredFunTy_maybe ty+  | Just ty' <- tcView ty = tcSplitPredFunTy_maybe ty'+tcSplitPredFunTy_maybe (FunTy arg res)+  | isPredTy arg = Just (arg, res)+tcSplitPredFunTy_maybe _+  = Nothing++tcSplitPhiTy :: Type -> (ThetaType, Type)+tcSplitPhiTy ty+  = split ty []+  where+    split ty ts+      = case tcSplitPredFunTy_maybe ty of+          Just (pred, ty) -> split ty (pred:ts)+          Nothing         -> (reverse ts, ty)++-- | Split a sigma type into its parts.+tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type)+tcSplitSigmaTy ty = case tcSplitForAllTys ty of+                        (tvs, rho) -> case tcSplitPhiTy rho of+                                        (theta, tau) -> (tvs, theta, tau)++-- | Split a sigma type into its parts, going underneath as many @ForAllTy@s+-- as possible. For example, given this type synonym:+--+-- @+-- type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t+-- @+--+-- if you called @tcSplitSigmaTy@ on this type:+--+-- @+-- forall s t a b. Each s t a b => Traversal s t a b+-- @+--+-- then it would return @([s,t,a,b], [Each s t a b], Traversal s t a b)@. But+-- if you instead called @tcSplitNestedSigmaTys@ on the type, it would return+-- @([s,t,a,b,f], [Each s t a b, Applicative f], (a -> f b) -> s -> f t)@.+tcSplitNestedSigmaTys :: Type -> ([TyVar], ThetaType, Type)+-- NB: This is basically a pure version of deeplyInstantiate (from Inst) that+-- doesn't compute an HsWrapper.+tcSplitNestedSigmaTys ty+    -- If there's a forall, split it apart and try splitting the rho type+    -- underneath it.+  | Just (arg_tys, tvs1, theta1, rho1) <- tcDeepSplitSigmaTy_maybe ty+  = let (tvs2, theta2, rho2) = tcSplitNestedSigmaTys rho1+    in (tvs1 ++ tvs2, theta1 ++ theta2, mkFunTys arg_tys rho2)+    -- If there's no forall, we're done.+  | otherwise = ([], [], ty)++-----------------------+tcDeepSplitSigmaTy_maybe+  :: TcSigmaType -> Maybe ([TcType], [TyVar], ThetaType, TcSigmaType)+-- Looks for a *non-trivial* quantified type, under zero or more function arrows+-- By "non-trivial" we mean either tyvars or constraints are non-empty++tcDeepSplitSigmaTy_maybe ty+  | Just (arg_ty, res_ty)           <- tcSplitFunTy_maybe ty+  , Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe res_ty+  = Just (arg_ty:arg_tys, tvs, theta, rho)++  | (tvs, theta, rho) <- tcSplitSigmaTy ty+  , not (null tvs && null theta)+  = Just ([], tvs, theta, rho)++  | otherwise = Nothing++-----------------------+tcTyConAppTyCon :: Type -> TyCon+tcTyConAppTyCon ty+  = case tcTyConAppTyCon_maybe ty of+      Just tc -> tc+      Nothing -> pprPanic "tcTyConAppTyCon" (pprType ty)++-- | Like 'tcRepSplitTyConApp_maybe', but only returns the 'TyCon'.+tcTyConAppTyCon_maybe :: Type -> Maybe TyCon+tcTyConAppTyCon_maybe ty+  | Just ty' <- tcView ty = tcTyConAppTyCon_maybe ty'+tcTyConAppTyCon_maybe (TyConApp tc _)+  = Just tc+tcTyConAppTyCon_maybe (FunTy _ _)+  = Just funTyCon+tcTyConAppTyCon_maybe _+  = Nothing++tcTyConAppArgs :: Type -> [Type]+tcTyConAppArgs ty = case tcSplitTyConApp_maybe ty of+                        Just (_, args) -> args+                        Nothing        -> pprPanic "tcTyConAppArgs" (pprType ty)++tcSplitTyConApp :: Type -> (TyCon, [Type])+tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of+                        Just stuff -> stuff+                        Nothing    -> pprPanic "tcSplitTyConApp" (pprType ty)++-- | Like 'tcRepSplitTyConApp_maybe', but returns 'Nothing' if,+--+-- 1. the type is structurally not a type constructor application, or+--+-- 2. the type is a function type (e.g. application of 'funTyCon'), but we+--    currently don't even enough information to fully determine its RuntimeRep+--    variables. For instance, @FunTy (a :: k) Int@.+--+-- By contrast 'tcRepSplitTyConApp_maybe' panics in the second case.+--+-- The behavior here is needed during canonicalization; see Note [FunTy and+-- decomposing tycon applications] in TcCanonical for details.+tcRepSplitTyConApp_maybe' :: HasCallStack => Type -> Maybe (TyCon, [Type])+tcRepSplitTyConApp_maybe' (TyConApp tc tys)          = Just (tc, tys)+tcRepSplitTyConApp_maybe' (FunTy arg res)+  | Just arg_rep <- getRuntimeRep_maybe arg+  , Just res_rep <- getRuntimeRep_maybe res+  = Just (funTyCon, [arg_rep, res_rep, arg, res])+tcRepSplitTyConApp_maybe' _                          = Nothing+++-----------------------+tcSplitFunTys :: Type -> ([Type], Type)+tcSplitFunTys ty = case tcSplitFunTy_maybe ty of+                        Nothing        -> ([], ty)+                        Just (arg,res) -> (arg:args, res')+                                       where+                                          (args,res') = tcSplitFunTys res++tcSplitFunTy_maybe :: Type -> Maybe (Type, Type)+tcSplitFunTy_maybe ty | Just ty' <- tcView ty         = tcSplitFunTy_maybe ty'+tcSplitFunTy_maybe (FunTy arg res) | not (isPredTy arg) = Just (arg, res)+tcSplitFunTy_maybe _                                    = Nothing+        -- Note the typeKind guard+        -- Consider     (?x::Int) => Bool+        -- We don't want to treat this as a function type!+        -- A concrete example is test tc230:+        --      f :: () -> (?p :: ()) => () -> ()+        --+        --      g = f () ()++tcSplitFunTysN :: Arity                      -- N: Number of desired args+               -> TcRhoType+               -> Either Arity               -- Number of missing arrows+                        ([TcSigmaType],      -- Arg types (always N types)+                         TcSigmaType)        -- The rest of the type+-- ^ Split off exactly the specified number argument types+-- Returns+--  (Left m) if there are 'm' missing arrows in the type+--  (Right (tys,res)) if the type looks like t1 -> ... -> tn -> res+tcSplitFunTysN n ty+ | n == 0+ = Right ([], ty)+ | Just (arg,res) <- tcSplitFunTy_maybe ty+ = case tcSplitFunTysN (n-1) res of+     Left m            -> Left m+     Right (args,body) -> Right (arg:args, body)+ | otherwise+ = Left n++tcSplitFunTy :: Type -> (Type, Type)+tcSplitFunTy  ty = expectJust "tcSplitFunTy" (tcSplitFunTy_maybe ty)++tcFunArgTy :: Type -> Type+tcFunArgTy    ty = fst (tcSplitFunTy ty)++tcFunResultTy :: Type -> Type+tcFunResultTy ty = snd (tcSplitFunTy ty)++-- | Strips off n *visible* arguments and returns the resulting type+tcFunResultTyN :: HasDebugCallStack => Arity -> Type -> Type+tcFunResultTyN n ty+  | Right (_, res_ty) <- tcSplitFunTysN n ty+  = res_ty+  | otherwise+  = pprPanic "tcFunResultTyN" (ppr n <+> ppr ty)++-----------------------+tcSplitAppTy_maybe :: Type -> Maybe (Type, Type)+tcSplitAppTy_maybe ty | Just ty' <- tcView ty = tcSplitAppTy_maybe ty'+tcSplitAppTy_maybe ty = tcRepSplitAppTy_maybe ty++tcSplitAppTy :: Type -> (Type, Type)+tcSplitAppTy ty = case tcSplitAppTy_maybe ty of+                    Just stuff -> stuff+                    Nothing    -> pprPanic "tcSplitAppTy" (pprType ty)++tcSplitAppTys :: Type -> (Type, [Type])+tcSplitAppTys ty+  = go ty []+  where+    go ty args = case tcSplitAppTy_maybe ty of+                   Just (ty', arg) -> go ty' (arg:args)+                   Nothing         -> (ty,args)++-----------------------+tcGetTyVar_maybe :: Type -> Maybe TyVar+tcGetTyVar_maybe ty | Just ty' <- tcView ty = tcGetTyVar_maybe ty'+tcGetTyVar_maybe (TyVarTy tv)   = Just tv+tcGetTyVar_maybe _              = Nothing++tcGetTyVar :: String -> Type -> TyVar+tcGetTyVar msg ty = expectJust msg (tcGetTyVar_maybe ty)++tcIsTyVarTy :: Type -> Bool+tcIsTyVarTy ty | Just ty' <- tcView ty = tcIsTyVarTy ty'+tcIsTyVarTy (CastTy ty _) = tcIsTyVarTy ty  -- look through casts, as+                                            -- this is only used for+                                            -- e.g., FlexibleContexts+tcIsTyVarTy (TyVarTy _)   = True+tcIsTyVarTy _             = False++-----------------------+tcSplitDFunTy :: Type -> ([TyVar], [Type], Class, [Type])+-- Split the type of a dictionary function+-- We don't use tcSplitSigmaTy,  because a DFun may (with NDP)+-- have non-Pred arguments, such as+--     df :: forall m. (forall b. Eq b => Eq (m b)) -> C m+--+-- Also NB splitFunTys, not tcSplitFunTys;+-- the latter  specifically stops at PredTy arguments,+-- and we don't want to do that here+tcSplitDFunTy ty+  = case tcSplitForAllTys ty   of { (tvs, rho)    ->+    case splitFunTys rho       of { (theta, tau)  ->+    case tcSplitDFunHead tau   of { (clas, tys)   ->+    (tvs, theta, clas, tys) }}}++tcSplitDFunHead :: Type -> (Class, [Type])+tcSplitDFunHead = getClassPredTys++tcSplitMethodTy :: Type -> ([TyVar], PredType, Type)+-- A class method (selector) always has a type like+--   forall as. C as => blah+-- So if the class looks like+--   class C a where+--     op :: forall b. (Eq a, Ix b) => a -> b+-- the class method type looks like+--  op :: forall a. C a => forall b. (Eq a, Ix b) => a -> b+--+-- tcSplitMethodTy just peels off the outer forall and+-- that first predicate+tcSplitMethodTy ty+  | (sel_tyvars,sel_rho) <- tcSplitForAllTys ty+  , Just (first_pred, local_meth_ty) <- tcSplitPredFunTy_maybe sel_rho+  = (sel_tyvars, first_pred, local_meth_ty)+  | otherwise+  = pprPanic "tcSplitMethodTy" (ppr ty)+++{- *********************************************************************+*                                                                      *+            Type equalities+*                                                                      *+********************************************************************* -}++tcEqKind :: TcKind -> TcKind -> Bool+tcEqKind = tcEqType++tcEqType :: TcType -> TcType -> Bool+-- tcEqType is a proper implements the same Note [Non-trivial definitional+-- equality] (in TyCoRep) as `eqType`, but Type.eqType believes (* ==+-- Constraint), and that is NOT what we want in the type checker!+tcEqType ty1 ty2+  = isNothing (tc_eq_type tcView ki1 ki2) &&+    isNothing (tc_eq_type tcView ty1 ty2)+  where+    ki1 = typeKind ty1+    ki2 = typeKind ty2++-- | Just like 'tcEqType', but will return True for types of different kinds+-- as long as their non-coercion structure is identical.+tcEqTypeNoKindCheck :: TcType -> TcType -> Bool+tcEqTypeNoKindCheck ty1 ty2+  = isNothing $ tc_eq_type tcView ty1 ty2++-- | Like 'tcEqType', but returns information about whether the difference+-- is visible in the case of a mismatch.+-- @Nothing@    : the types are equal+-- @Just True@  : the types differ, and the point of difference is visible+-- @Just False@ : the types differ, and the point of difference is invisible+tcEqTypeVis :: TcType -> TcType -> Maybe Bool+tcEqTypeVis ty1 ty2+  = tc_eq_type tcView ty1 ty2 <!> invis (tc_eq_type tcView ki1 ki2)+  where+    ki1 = typeKind ty1+    ki2 = typeKind ty2++      -- convert Just True to Just False+    invis :: Maybe Bool -> Maybe Bool+    invis = fmap (const False)++(<!>) :: Maybe Bool -> Maybe Bool -> Maybe Bool+Nothing        <!> x         = x+Just True      <!> _         = Just True+Just _vis      <!> Just True = Just True+Just vis       <!> _         = Just vis+infixr 3 <!>++-- | Real worker for 'tcEqType'. No kind check!+tc_eq_type :: (TcType -> Maybe TcType)  -- ^ @tcView@, if you want unwrapping+           -> Type -> Type -> Maybe Bool+tc_eq_type view_fun orig_ty1 orig_ty2 = go True orig_env orig_ty1 orig_ty2+  where+    go :: Bool -> RnEnv2 -> Type -> Type -> Maybe Bool+    go vis env t1 t2 | Just t1' <- view_fun t1 = go vis env t1' t2+    go vis env t1 t2 | Just t2' <- view_fun t2 = go vis env t1 t2'++    go vis env (TyVarTy tv1)       (TyVarTy tv2)+      = check vis $ rnOccL env tv1 == rnOccR env tv2++    go vis _   (LitTy lit1)        (LitTy lit2)+      = check vis $ lit1 == lit2++    go vis env (ForAllTy (TvBndr tv1 vis1) ty1)+               (ForAllTy (TvBndr tv2 vis2) ty2)+      = go (isVisibleArgFlag vis1) env (tyVarKind tv1) (tyVarKind tv2)+          <!> go vis (rnBndr2 env tv1 tv2) ty1 ty2+          <!> check vis (vis1 == vis2)+    -- Make sure we handle all FunTy cases since falling through to the+    -- AppTy case means that tcRepSplitAppTy_maybe may see an unzonked+    -- kind variable, which causes things to blow up.+    go vis env (FunTy arg1 res1) (FunTy arg2 res2)+      = go vis env arg1 arg2 <!> go vis env res1 res2+    go vis env ty (FunTy arg res)+      = eqFunTy vis env arg res ty+    go vis env (FunTy arg res) ty+      = eqFunTy vis env arg res ty++      -- See Note [Equality on AppTys] in Type+    go vis env (AppTy s1 t1)        ty2+      | Just (s2, t2) <- tcRepSplitAppTy_maybe ty2+      = go vis env s1 s2 <!> go vis env t1 t2+    go vis env ty1                  (AppTy s2 t2)+      | Just (s1, t1) <- tcRepSplitAppTy_maybe ty1+      = go vis env s1 s2 <!> go vis env t1 t2+    go vis env (TyConApp tc1 ts1)   (TyConApp tc2 ts2)+      = check vis (tc1 == tc2) <!> gos (tc_vis vis tc1) env ts1 ts2+    go vis env (CastTy t1 _)        t2              = go vis env t1 t2+    go vis env t1                   (CastTy t2 _)   = go vis env t1 t2+    go _   _   (CoercionTy {})      (CoercionTy {}) = Nothing+    go vis _   _                    _               = Just vis++    gos _      _   []       []       = Nothing+    gos (v:vs) env (t1:ts1) (t2:ts2) = go v env t1 t2 <!> gos vs env ts1 ts2+    gos (v:_)  _   _        _        = Just v+    gos _      _   _        _        = panic "tc_eq_type"++    tc_vis :: Bool -> TyCon -> [Bool]+    tc_vis True tc = viss ++ repeat True+       -- the repeat True is necessary because tycons can legitimately+       -- be oversaturated+      where+        bndrs = tyConBinders tc+        viss  = map (isVisibleArgFlag . tyConBinderArgFlag) bndrs+    tc_vis False _ = repeat False  -- if we're not in a visible context, our args+                                   -- aren't either++    check :: Bool -> Bool -> Maybe Bool+    check _   True  = Nothing+    check vis False = Just vis++    orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2]++    -- @eqFunTy arg res ty@ is True when @ty@ equals @FunTy arg res@. This is+    -- sometimes hard to know directly because @ty@ might have some casts+    -- obscuring the FunTy. And 'splitAppTy' is difficult because we can't+    -- always extract a RuntimeRep (see Note [xyz]) if the kind of the arg or+    -- res is unzonked/unflattened. Thus this function, which handles this+    -- corner case.+    eqFunTy :: Bool -> RnEnv2 -> Type -> Type -> Type -> Maybe Bool+    eqFunTy vis env arg res (FunTy arg' res')+      = go vis env arg arg' <!> go vis env res res'+    eqFunTy vis env arg res ty@(AppTy{})+      | Just (tc, [_, _, arg', res']) <- get_args ty []+      , tc == funTyCon+      = go vis env arg arg' <!> go vis env res res'+      where+        get_args :: Type -> [Type] -> Maybe (TyCon, [Type])+        get_args (AppTy f x)       args = get_args f (x:args)+        get_args (CastTy t _)      args = get_args t args+        get_args (TyConApp tc tys) args = Just (tc, tys ++ args)+        get_args _                 _    = Nothing+    eqFunTy vis _ _ _ _+      = Just vis++-- | Like 'pickyEqTypeVis', but returns a Bool for convenience+pickyEqType :: TcType -> TcType -> Bool+-- Check when two types _look_ the same, _including_ synonyms.+-- So (pickyEqType String [Char]) returns False+-- This ignores kinds and coercions, because this is used only for printing.+pickyEqType ty1 ty2+  = isNothing $+    tc_eq_type (const Nothing) ty1 ty2++{- *********************************************************************+*                                                                      *+                       Predicate types+*                                                                      *+************************************************************************++Deconstructors and tests on predicate types++Note [Kind polymorphic type classes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    class C f where...   -- C :: forall k. k -> Constraint+    g :: forall (f::*). C f => f -> f++Here the (C f) in the signature is really (C * f), and we+don't want to complain that the * isn't a type variable!+-}++isTyVarClassPred :: PredType -> Bool+isTyVarClassPred ty = case getClassPredTys_maybe ty of+    Just (_, tys) -> all isTyVarTy tys+    _             -> False++-------------------------+checkValidClsArgs :: Bool -> Class -> [KindOrType] -> Bool+-- If the Bool is True (flexible contexts), return True (i.e. ok)+-- Otherwise, check that the type (not kind) args are all headed by a tyvar+--   E.g. (Eq a) accepted, (Eq (f a)) accepted, but (Eq Int) rejected+-- This function is here rather than in TcValidity because it is+-- called from TcSimplify, which itself is imported by TcValidity+checkValidClsArgs flexible_contexts cls kts+  | flexible_contexts = True+  | otherwise         = all hasTyVarHead tys+  where+    tys = filterOutInvisibleTypes (classTyCon cls) kts++hasTyVarHead :: Type -> Bool+-- Returns true of (a t1 .. tn), where 'a' is a type variable+hasTyVarHead ty                 -- Haskell 98 allows predicates of form+  | tcIsTyVarTy ty = True       --      C (a ty1 .. tyn)+  | otherwise                   -- where a is a type variable+  = case tcSplitAppTy_maybe ty of+       Just (ty, _) -> hasTyVarHead ty+       Nothing      -> False++evVarPred_maybe :: EvVar -> Maybe PredType+evVarPred_maybe v = if isPredTy ty then Just ty else Nothing+  where ty = varType v++evVarPred :: EvVar -> PredType+evVarPred var+ | debugIsOn+  = case evVarPred_maybe var of+      Just pred -> pred+      Nothing   -> pprPanic "tcEvVarPred" (ppr var <+> ppr (varType var))+ | otherwise+  = varType var++------------------+-- | When inferring types, should we quantify over a given predicate?+-- Generally true of classes; generally false of equality constraints.+-- Equality constraints that mention quantified type variables and+-- implicit variables complicate the story. See Notes+-- [Inheriting implicit parameters] and [Quantifying over equality constraints]+pickQuantifiablePreds+  :: TyVarSet           -- Quantifying over these+  -> TcThetaType        -- Proposed constraints to quantify+  -> TcThetaType        -- A subset that we can actually quantify+-- This function decides whether a particular constraint should be+-- quantified over, given the type variables that are being quantified+pickQuantifiablePreds qtvs theta+  = let flex_ctxt = True in  -- Quantify over non-tyvar constraints, even without+                             -- -XFlexibleContexts: see Trac #10608, #10351+         -- flex_ctxt <- xoptM Opt_FlexibleContexts+    filter (pick_me flex_ctxt) theta+  where+    pick_me flex_ctxt pred+      = case classifyPredType pred of++          ClassPred cls tys+            | Just {} <- isCallStackPred pred+              -- NEVER infer a CallStack constraint+              -- Otherwise, we let the constraints bubble up to be+              -- solved from the outer context, or be defaulted when we+              -- reach the top-level.+              -- see Note [Overview of implicit CallStacks]+              -> False++            | isIPClass cls    -> True -- See note [Inheriting implicit parameters]++            | otherwise+              -> pick_cls_pred flex_ctxt cls tys++          EqPred ReprEq ty1 ty2 -> pick_cls_pred flex_ctxt coercibleClass [ty1, ty2]+            -- representational equality is like a class constraint++          EqPred NomEq ty1 ty2  -> quant_fun ty1 || quant_fun ty2+          IrredPred ty          -> tyCoVarsOfType ty `intersectsVarSet` qtvs++    pick_cls_pred flex_ctxt cls tys+      = tyCoVarsOfTypes tys `intersectsVarSet` qtvs+        && (checkValidClsArgs flex_ctxt cls tys)+           -- Only quantify over predicates that checkValidType+           -- will pass!  See Trac #10351.++    -- See Note [Quantifying over equality constraints]+    quant_fun ty+      = case tcSplitTyConApp_maybe ty of+          Just (tc, tys) | isTypeFamilyTyCon tc+                         -> tyCoVarsOfTypes tys `intersectsVarSet` qtvs+          _ -> False++pickCapturedPreds+  :: TyVarSet           -- Quantifying over these+  -> TcThetaType        -- Proposed constraints to quantify+  -> TcThetaType        -- A subset that we can actually quantify+-- A simpler version of pickQuantifiablePreds, used to winnow down+-- the inferred constrains of a group of bindings, into those for+-- one particular identifier+pickCapturedPreds qtvs theta+  = filter captured theta+  where+    captured pred = isIPPred pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs)+++-- Superclasses++type PredWithSCs = (PredType, [PredType])++mkMinimalBySCs :: [PredType] -> [PredType]+-- Remove predicates that can be deduced from others by superclasses,+-- including duplicate predicates. The result is a subset of the input.+mkMinimalBySCs ptys = go preds_with_scs []+ where+   preds_with_scs :: [PredWithSCs]+   preds_with_scs = [ (pred, pred : transSuperClasses pred)+                    | pred <- ptys ]++   go :: [PredWithSCs]   -- Work list+      -> [PredWithSCs]   -- Accumulating result+      -> [PredType]+   go [] min_preds = map fst min_preds+   go (work_item@(p,_) : work_list) min_preds+     | p `in_cloud` work_list || p `in_cloud` min_preds+     = go work_list min_preds+     | otherwise+     = go work_list (work_item : min_preds)++   in_cloud :: PredType -> [PredWithSCs] -> Bool+   in_cloud p ps = or [ p `eqType` p' | (_, scs) <- ps, p' <- scs ]++transSuperClasses :: PredType -> [PredType]+-- (transSuperClasses p) returns (p's superclasses) not including p+-- Stop if you encounter the same class again+-- See Note [Expanding superclasses]+transSuperClasses p+  = go emptyNameSet p+  where+    go :: NameSet -> PredType -> [PredType]+    go rec_clss p+       | ClassPred cls tys <- classifyPredType p+       , let cls_nm = className cls+       , not (cls_nm `elemNameSet` rec_clss)+       , let rec_clss' | isCTupleClass cls = rec_clss+                       | otherwise         = rec_clss `extendNameSet` cls_nm+       = [ p' | sc <- immSuperClasses cls tys+              , p'  <- sc : go rec_clss' sc ]+       | otherwise+       = []++immSuperClasses :: Class -> [Type] -> [PredType]+immSuperClasses cls tys+  = substTheta (zipTvSubst tyvars tys) sc_theta+  where+    (tyvars,sc_theta,_,_) = classBigSig cls++isImprovementPred :: PredType -> Bool+-- Either it's an equality, or has some functional dependency+isImprovementPred ty+  = case classifyPredType ty of+      EqPred NomEq t1 t2 -> not (t1 `tcEqType` t2)+      EqPred ReprEq _ _  -> False+      ClassPred cls _    -> classHasFds cls+      IrredPred {}       -> True -- Might have equalities after reduction?++{- Note [Expanding superclasses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we expand superclasses, we use the following algorithm:++expand( so_far, pred ) returns the transitive superclasses of pred,+                               not including pred itself+ 1. If pred is not a class constraint, return empty set+       Otherwise pred = C ts+ 2. If C is in so_far, return empty set (breaks loops)+ 3. Find the immediate superclasses constraints of (C ts)+ 4. For each such sc_pred, return (sc_pred : expand( so_far+C, D ss )++Notice that++ * With normal Haskell-98 classes, the loop-detector will never bite,+   so we'll get all the superclasses.++ * Since there is only a finite number of distinct classes, expansion+   must terminate.++ * The loop breaking is a bit conservative. Notably, a tuple class+   could contain many times without threatening termination:+      (Eq a, (Ord a, Ix a))+   And this is try of any class that we can statically guarantee+   as non-recursive (in some sense).  For now, we just make a special+   case for tuples.  Something better would be cool.++See also TcTyDecls.checkClassCycles.++Note [Inheriting implicit parameters]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:++        f x = (x::Int) + ?y++where f is *not* a top-level binding.+From the RHS of f we'll get the constraint (?y::Int).+There are two types we might infer for f:++        f :: Int -> Int++(so we get ?y from the context of f's definition), or++        f :: (?y::Int) => Int -> Int++At first you might think the first was better, because then+?y behaves like a free variable of the definition, rather than+having to be passed at each call site.  But of course, the WHOLE+IDEA is that ?y should be passed at each call site (that's what+dynamic binding means) so we'd better infer the second.++BOTTOM LINE: when *inferring types* you must quantify over implicit+parameters, *even if* they don't mention the bound type variables.+Reason: because implicit parameters, uniquely, have local instance+declarations. See pickQuantifiablePreds.++Note [Quantifying over equality constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Should we quantify over an equality constraint (s ~ t)?  In general, we don't.+Doing so may simply postpone a type error from the function definition site to+its call site.  (At worst, imagine (Int ~ Bool)).++However, consider this+         forall a. (F [a] ~ Int) => blah+Should we quantify over the (F [a] ~ Int).  Perhaps yes, because at the call+site we will know 'a', and perhaps we have instance  F [Bool] = Int.+So we *do* quantify over a type-family equality where the arguments mention+the quantified variables.++************************************************************************+*                                                                      *+\subsection{Predicates}+*                                                                      *+************************************************************************+-}++isSigmaTy :: TcType -> Bool+-- isSigmaTy returns true of any qualified type.  It doesn't+-- *necessarily* have any foralls.  E.g+--        f :: (?x::Int) => Int -> Int+isSigmaTy ty | Just ty' <- tcView ty = isSigmaTy ty'+isSigmaTy (ForAllTy {}) = True+isSigmaTy (FunTy a _)   = isPredTy a+isSigmaTy _             = False++isRhoTy :: TcType -> Bool   -- True of TcRhoTypes; see Note [TcRhoType]+isRhoTy ty | Just ty' <- tcView ty = isRhoTy ty'+isRhoTy (ForAllTy {}) = False+isRhoTy (FunTy a r)   = not (isPredTy a) && isRhoTy r+isRhoTy _             = True++-- | Like 'isRhoTy', but also says 'True' for 'Infer' types+isRhoExpTy :: ExpType -> Bool+isRhoExpTy (Check ty) = isRhoTy ty+isRhoExpTy (Infer {}) = True++isOverloadedTy :: Type -> Bool+-- Yes for a type of a function that might require evidence-passing+-- Used only by bindLocalMethods+isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty'+isOverloadedTy (ForAllTy _  ty) = isOverloadedTy ty+isOverloadedTy (FunTy a _)      = isPredTy a+isOverloadedTy _                = False++isFloatTy, isDoubleTy, isIntegerTy, isIntTy, isWordTy, isBoolTy,+    isUnitTy, isCharTy, isAnyTy :: Type -> Bool+isFloatTy      = is_tc floatTyConKey+isDoubleTy     = is_tc doubleTyConKey+isIntegerTy    = is_tc integerTyConKey+isIntTy        = is_tc intTyConKey+isWordTy       = is_tc wordTyConKey+isBoolTy       = is_tc boolTyConKey+isUnitTy       = is_tc unitTyConKey+isCharTy       = is_tc charTyConKey+isAnyTy        = is_tc anyTyConKey++-- | Does a type represent a floating-point number?+isFloatingTy :: Type -> Bool+isFloatingTy ty = isFloatTy ty || isDoubleTy ty++-- | Is a type 'String'?+isStringTy :: Type -> Bool+isStringTy ty+  = case tcSplitTyConApp_maybe ty of+      Just (tc, [arg_ty]) -> tc == listTyCon && isCharTy arg_ty+      _                   -> False++-- | Is a type a 'CallStack'?+isCallStackTy :: Type -> Bool+isCallStackTy ty+  | Just tc <- tyConAppTyCon_maybe ty+  = tc `hasKey` callStackTyConKey+  | otherwise+  = False++-- | Is a 'PredType' a 'CallStack' implicit parameter?+--+-- If so, return the name of the parameter.+isCallStackPred :: PredType -> Maybe FastString+isCallStackPred pred+  | Just (str, ty) <- isIPPred_maybe pred+  , isCallStackTy ty+  = Just str+  | otherwise+  = Nothing++is_tc :: Unique -> Type -> Bool+-- Newtypes are opaque to this+is_tc uniq ty = case tcSplitTyConApp_maybe ty of+                        Just (tc, _) -> uniq == getUnique tc+                        Nothing      -> False++-- | Does the given tyvar appear in the given type outside of any+-- non-newtypes? Assume we're looking for @a@. Says "yes" for+-- @a@, @N a@, @b a@, @a b@, @b (N a)@. Says "no" for+-- @[a]@, @Maybe a@, @T a@, where @N@ is a newtype and @T@ is a datatype.+isTyVarExposed :: TcTyVar -> TcType -> Bool+isTyVarExposed tv (TyVarTy tv')   = tv == tv'+isTyVarExposed tv (TyConApp tc tys)+  | isNewTyCon tc                 = any (isTyVarExposed tv) tys+  | otherwise                     = False+isTyVarExposed _  (LitTy {})      = False+isTyVarExposed tv (AppTy fun arg) = isTyVarExposed tv fun+                                 || isTyVarExposed tv arg+isTyVarExposed _  (ForAllTy {})   = False+isTyVarExposed _  (FunTy {})      = False+isTyVarExposed tv (CastTy ty _)   = isTyVarExposed tv ty+isTyVarExposed _  (CoercionTy {}) = False++-- | Is the equality+--        a ~r ...a....+-- definitely insoluble or not?+--      a ~r Maybe a      -- Definitely insoluble+--      a ~N ...(F a)...  -- Not definitely insoluble+--                        -- Perhaps (F a) reduces to Int+--      a ~R ...(N a)...  -- Not definitely insoluble+--                        -- Perhaps newtype N a = MkN Int+-- See Note [Occurs check error] in+-- TcCanonical for the motivation for this function.+isInsolubleOccursCheck :: EqRel -> TcTyVar -> TcType -> Bool+isInsolubleOccursCheck eq_rel tv ty+  = go ty+  where+    go ty | Just ty' <- tcView ty = go ty'+    go (TyVarTy tv') = tv == tv' || go (tyVarKind tv')+    go (LitTy {})    = False+    go (AppTy t1 t2) = go t1 || go t2+    go (FunTy t1 t2) = go t1 || go t2+    go (ForAllTy (TvBndr tv' _) inner_ty)+      | tv' == tv = False+      | otherwise = go (tyVarKind tv') || go inner_ty+    go (CastTy ty _)  = go ty   -- ToDo: what about the coercion+    go (CoercionTy _) = False   -- ToDo: what about the coercion+    go (TyConApp tc tys)+      | isGenerativeTyCon tc role = any go tys+      | otherwise                 = False++    role = eqRelRole eq_rel++isRigidTy :: TcType -> Bool+isRigidTy ty+  | Just (tc,_) <- tcSplitTyConApp_maybe ty = isGenerativeTyCon tc Nominal+  | Just {} <- tcSplitAppTy_maybe ty        = True+  | isForAllTy ty                           = True+  | otherwise                               = False++isRigidEqPred :: TcLevel -> PredTree -> Bool+-- ^ True of all Nominal equalities that are solidly insoluble+-- This means all equalities *except*+--   * Meta-tv non-SigTv on LHS+--   * Meta-tv SigTv on LHS, tyvar on right+isRigidEqPred tc_lvl (EqPred NomEq ty1 _)+  | Just tv1 <- tcGetTyVar_maybe ty1+  = ASSERT2( tcIsTcTyVar tv1, ppr tv1 )+    not (isMetaTyVar tv1) || isTouchableMetaTyVar tc_lvl tv1++  | otherwise  -- LHS is not a tyvar+  = True++isRigidEqPred _ _ = False  -- Not an equality++{-+************************************************************************+*                                                                      *+\subsection{Transformation of Types to TcTypes}+*                                                                      *+************************************************************************+-}++toTcType :: Type -> TcType+-- The constraint solver expects EvVars to have TcType, in which the+-- free type variables are TcTyVars. So we convert from Type to TcType here+-- A bit tiresome; but one day I expect the two types to be entirely separate+-- in which case we'll definitely need to do this+toTcType = runIdentity . to_tc_type emptyVarSet++toTcTypeBag :: Bag EvVar -> Bag EvVar -- All TyVars are transformed to TcTyVars+toTcTypeBag evvars = mapBag (\tv -> setTyVarKind tv (toTcType (tyVarKind tv))) evvars++to_tc_mapper :: TyCoMapper VarSet Identity+to_tc_mapper+  = TyCoMapper { tcm_smart    = False   -- more efficient not to use smart ctors+               , tcm_tyvar    = tyvar+               , tcm_covar    = covar+               , tcm_hole     = hole+               , tcm_tybinder = tybinder }+  where+    tyvar :: VarSet -> TyVar -> Identity Type+    tyvar ftvs tv+      | Just var <- lookupVarSet ftvs tv = return $ TyVarTy var+      | isTcTyVar tv = TyVarTy <$> updateTyVarKindM (to_tc_type ftvs) tv+      | otherwise+      = do { kind' <- to_tc_type ftvs (tyVarKind tv)+           ; return $ TyVarTy $ mkTcTyVar (tyVarName tv) kind' vanillaSkolemTv }++    covar :: VarSet -> CoVar -> Identity Coercion+    covar ftvs cv+      | Just var <- lookupVarSet ftvs cv = return $ CoVarCo var+      | otherwise = CoVarCo <$> updateVarTypeM (to_tc_type ftvs) cv++    hole :: VarSet -> CoercionHole -> Role -> Type -> Type+         -> Identity Coercion+    hole ftvs h r t1 t2 = mkHoleCo h r <$> to_tc_type ftvs t1+                                       <*> to_tc_type ftvs t2++    tybinder :: VarSet -> TyVar -> ArgFlag -> Identity (VarSet, TyVar)+    tybinder ftvs tv _vis = do { kind' <- to_tc_type ftvs (tyVarKind tv)+                               ; let tv' = mkTcTyVar (tyVarName tv) kind'+                                                     vanillaSkolemTv+                               ; return (ftvs `extendVarSet` tv', tv') }++to_tc_type :: VarSet -> Type -> Identity TcType+to_tc_type = mapType to_tc_mapper++{-+************************************************************************+*                                                                      *+\subsection{Misc}+*                                                                      *+************************************************************************++Note [Visible type application]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC implements a generalisation of the algorithm described in the+"Visible Type Application" paper (available from+http://www.cis.upenn.edu/~sweirich/publications.html). A key part+of that algorithm is to distinguish user-specified variables from inferred+variables. For example, the following should typecheck:++  f :: forall a b. a -> b -> b+  f = const id++  g = const id++  x = f @Int @Bool 5 False+  y = g 5 @Bool False++The idea is that we wish to allow visible type application when we are+instantiating a specified, fixed variable. In practice, specified, fixed+variables are either written in a type signature (or+annotation), OR are imported from another module. (We could do better here,+for example by doing SCC analysis on parts of a module and considering any+type from outside one's SCC to be fully specified, but this is very confusing to+users. The simple rule above is much more straightforward and predictable.)++So, both of f's quantified variables are specified and may be instantiated.+But g has no type signature, so only id's variable is specified (because id+is imported). We write the type of g as forall {a}. a -> forall b. b -> b.+Note that the a is in braces, meaning it cannot be instantiated with+visible type application.++Tracking specified vs. inferred variables is done conveniently by a field+in TyBinder.++-}++deNoteType :: Type -> Type+-- Remove all *outermost* type synonyms and other notes+deNoteType ty | Just ty' <- coreView ty = deNoteType ty'+deNoteType ty = ty++{-+Find the free tycons and classes of a type.  This is used in the front+end of the compiler.+-}++{-+************************************************************************+*                                                                      *+\subsection[TysWiredIn-ext-type]{External types}+*                                                                      *+************************************************************************++The compiler's foreign function interface supports the passing of a+restricted set of types as arguments and results (the restricting factor+being the )+-}++tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type)+-- (tcSplitIOType_maybe t) returns Just (IO,t',co)+--              if co : t ~ IO t'+--              returns Nothing otherwise+tcSplitIOType_maybe ty+  = case tcSplitTyConApp_maybe ty of+        Just (io_tycon, [io_res_ty])+         | io_tycon `hasKey` ioTyConKey ->+            Just (io_tycon, io_res_ty)+        _ ->+            Nothing++isFFITy :: Type -> Bool+-- True for any TyCon that can possibly be an arg or result of an FFI call+isFFITy ty = isValid (checkRepTyCon legalFFITyCon ty)++isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity+-- Checks for valid argument type for a 'foreign import'+isFFIArgumentTy dflags safety ty+   = checkRepTyCon (legalOutgoingTyCon dflags safety) ty++isFFIExternalTy :: Type -> Validity+-- Types that are allowed as arguments of a 'foreign export'+isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty++isFFIImportResultTy :: DynFlags -> Type -> Validity+isFFIImportResultTy dflags ty+  = checkRepTyCon (legalFIResultTyCon dflags) ty++isFFIExportResultTy :: Type -> Validity+isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty++isFFIDynTy :: Type -> Type -> Validity+-- The type in a foreign import dynamic must be Ptr, FunPtr, or a newtype of+-- either, and the wrapped function type must be equal to the given type.+-- We assume that all types have been run through normaliseFfiType, so we don't+-- need to worry about expanding newtypes here.+isFFIDynTy expected ty+    -- Note [Foreign import dynamic]+    -- In the example below, expected would be 'CInt -> IO ()', while ty would+    -- be 'FunPtr (CDouble -> IO ())'.+    | Just (tc, [ty']) <- splitTyConApp_maybe ty+    , tyConUnique tc `elem` [ptrTyConKey, funPtrTyConKey]+    , eqType ty' expected+    = IsValid+    | otherwise+    = NotValid (vcat [ text "Expected: Ptr/FunPtr" <+> pprParendType expected <> comma+                     , text "  Actual:" <+> ppr ty ])++isFFILabelTy :: Type -> Validity+-- The type of a foreign label must be Ptr, FunPtr, or a newtype of either.+isFFILabelTy ty = checkRepTyCon ok ty+  where+    ok tc | tc `hasKey` funPtrTyConKey || tc `hasKey` ptrTyConKey+          = IsValid+          | otherwise+          = NotValid (text "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)")++isFFIPrimArgumentTy :: DynFlags -> Type -> Validity+-- Checks for valid argument type for a 'foreign import prim'+-- Currently they must all be simple unlifted types, or the well-known type+-- Any, which can be used to pass the address to a Haskell object on the heap to+-- the foreign function.+isFFIPrimArgumentTy dflags ty+  | isAnyTy ty = IsValid+  | otherwise  = checkRepTyCon (legalFIPrimArgTyCon dflags) ty++isFFIPrimResultTy :: DynFlags -> Type -> Validity+-- Checks for valid result type for a 'foreign import prim' Currently+-- it must be an unlifted type, including unboxed tuples, unboxed+-- sums, or the well-known type Any.+isFFIPrimResultTy dflags ty+  | isAnyTy ty = IsValid+  | otherwise = checkRepTyCon (legalFIPrimResultTyCon dflags) ty++isFunPtrTy :: Type -> Bool+isFunPtrTy ty+  | Just (tc, [_]) <- splitTyConApp_maybe ty+  = tc `hasKey` funPtrTyConKey+  | otherwise+  = False++-- normaliseFfiType gets run before checkRepTyCon, so we don't+-- need to worry about looking through newtypes or type functions+-- here; that's already been taken care of.+checkRepTyCon :: (TyCon -> Validity) -> Type -> Validity+checkRepTyCon check_tc ty+  = case splitTyConApp_maybe ty of+      Just (tc, tys)+        | isNewTyCon tc -> NotValid (hang msg 2 (mk_nt_reason tc tys $$ nt_fix))+        | otherwise     -> case check_tc tc of+                             IsValid        -> IsValid+                             NotValid extra -> NotValid (msg $$ extra)+      Nothing -> NotValid (quotes (ppr ty) <+> text "is not a data type")+  where+    msg = quotes (ppr ty) <+> text "cannot be marshalled in a foreign call"+    mk_nt_reason tc tys+      | null tys  = text "because its data constructor is not in scope"+      | otherwise = text "because the data constructor for"+                    <+> quotes (ppr tc) <+> text "is not in scope"+    nt_fix = text "Possible fix: import the data constructor to bring it into scope"++{-+Note [Foreign import dynamic]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A dynamic stub must be of the form 'FunPtr ft -> ft' where ft is any foreign+type.  Similarly, a wrapper stub must be of the form 'ft -> IO (FunPtr ft)'.++We use isFFIDynTy to check whether a signature is well-formed. For example,+given a (illegal) declaration like:++foreign import ccall "dynamic"+  foo :: FunPtr (CDouble -> IO ()) -> CInt -> IO ()++isFFIDynTy will compare the 'FunPtr' type 'CDouble -> IO ()' with the curried+result type 'CInt -> IO ()', and return False, as they are not equal.+++----------------------------------------------+These chaps do the work; they are not exported+----------------------------------------------+-}++legalFEArgTyCon :: TyCon -> Validity+legalFEArgTyCon tc+  -- It's illegal to make foreign exports that take unboxed+  -- arguments.  The RTS API currently can't invoke such things.  --SDM 7/2000+  = boxedMarshalableTyCon tc++legalFIResultTyCon :: DynFlags -> TyCon -> Validity+legalFIResultTyCon dflags tc+  | tc == unitTyCon         = IsValid+  | otherwise               = marshalableTyCon dflags tc++legalFEResultTyCon :: TyCon -> Validity+legalFEResultTyCon tc+  | tc == unitTyCon         = IsValid+  | otherwise               = boxedMarshalableTyCon tc++legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Validity+-- Checks validity of types going from Haskell -> external world+legalOutgoingTyCon dflags _ tc+  = marshalableTyCon dflags tc++legalFFITyCon :: TyCon -> Validity+-- True for any TyCon that can possibly be an arg or result of an FFI call+legalFFITyCon tc+  | isUnliftedTyCon tc = IsValid+  | tc == unitTyCon    = IsValid+  | otherwise          = boxedMarshalableTyCon tc++marshalableTyCon :: DynFlags -> TyCon -> Validity+marshalableTyCon dflags tc+  | isUnliftedTyCon tc+  , not (isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc)+  , not (null (tyConPrimRep tc)) -- Note [Marshalling void]+  = validIfUnliftedFFITypes dflags+  | otherwise+  = boxedMarshalableTyCon tc++boxedMarshalableTyCon :: TyCon -> Validity+boxedMarshalableTyCon tc+   | getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey+                         , int32TyConKey, int64TyConKey+                         , wordTyConKey, word8TyConKey, word16TyConKey+                         , word32TyConKey, word64TyConKey+                         , floatTyConKey, doubleTyConKey+                         , ptrTyConKey, funPtrTyConKey+                         , charTyConKey+                         , stablePtrTyConKey+                         , boolTyConKey+                         ]+  = IsValid++  | otherwise = NotValid empty++legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity+-- Check args of 'foreign import prim', only allow simple unlifted types.+-- Strictly speaking it is unnecessary to ban unboxed tuples and sums here since+-- currently they're of the wrong kind to use in function args anyway.+legalFIPrimArgTyCon dflags tc+  | isUnliftedTyCon tc+  , not (isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc)+  = validIfUnliftedFFITypes dflags+  | otherwise+  = NotValid unlifted_only++legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity+-- Check result type of 'foreign import prim'. Allow simple unlifted+-- types and also unboxed tuple and sum result types.+legalFIPrimResultTyCon dflags tc+  | isUnliftedTyCon tc+  , isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc+     || not (null (tyConPrimRep tc))   -- Note [Marshalling void]+  = validIfUnliftedFFITypes dflags++  | otherwise+  = NotValid unlifted_only++unlifted_only :: MsgDoc+unlifted_only = text "foreign import prim only accepts simple unlifted types"++validIfUnliftedFFITypes :: DynFlags -> Validity+validIfUnliftedFFITypes dflags+  | xopt LangExt.UnliftedFFITypes dflags =  IsValid+  | otherwise = NotValid (text "To marshal unlifted types, use UnliftedFFITypes")++{-+Note [Marshalling void]+~~~~~~~~~~~~~~~~~~~~~~~+We don't treat State# (whose PrimRep is VoidRep) as marshalable.+In turn that means you can't write+        foreign import foo :: Int -> State# RealWorld++Reason: the back end falls over with panic "primRepHint:VoidRep";+        and there is no compelling reason to permit it+-}++{-+************************************************************************+*                                                                      *+        The "Paterson size" of a type+*                                                                      *+************************************************************************+-}++{-+Note [Paterson conditions on PredTypes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We are considering whether *class* constraints terminate+(see Note [Paterson conditions]). Precisely, the Paterson conditions+would have us check that "the constraint has fewer constructors and variables+(taken together and counting repetitions) than the head.".++However, we can be a bit more refined by looking at which kind of constraint+this actually is. There are two main tricks:++ 1. It seems like it should be OK not to count the tuple type constructor+    for a PredType like (Show a, Eq a) :: Constraint, since we don't+    count the "implicit" tuple in the ThetaType itself.++    In fact, the Paterson test just checks *each component* of the top level+    ThetaType against the size bound, one at a time. By analogy, it should be+    OK to return the size of the *largest* tuple component as the size of the+    whole tuple.++ 2. Once we get into an implicit parameter or equality we+    can't get back to a class constraint, so it's safe+    to say "size 0".  See Trac #4200.++NB: we don't want to detect PredTypes in sizeType (and then call+sizePred on them), or we might get an infinite loop if that PredType+is irreducible. See Trac #5581.+-}++type TypeSize = IntWithInf++sizeType :: Type -> TypeSize+-- Size of a type: the number of variables and constructors+-- Ignore kinds altogether+sizeType = go+  where+    go ty | Just exp_ty <- tcView ty = go exp_ty+    go (TyVarTy {})              = 1+    go (TyConApp tc tys)+      | isTypeFamilyTyCon tc     = infinity  -- Type-family applications can+                                           -- expand to any arbitrary size+      | otherwise                = sizeTypes (filterOutInvisibleTypes tc tys) + 1+    go (LitTy {})                = 1+    go (FunTy arg res)           = go arg + go res + 1+    go (AppTy fun arg)           = go fun + go arg+    go (ForAllTy (TvBndr tv vis) ty)+        | isVisibleArgFlag vis   = go (tyVarKind tv) + go ty + 1+        | otherwise              = go ty + 1+    go (CastTy ty _)             = go ty+    go (CoercionTy {})           = 0++sizeTypes :: [Type] -> TypeSize+sizeTypes tys = sum (map sizeType tys)
+ typecheck/TcType.hs-boot view
@@ -0,0 +1,8 @@+module TcType where+import Outputable( SDoc )++data MetaDetails++data TcTyVarDetails+pprTcTyVarDetails :: TcTyVarDetails -> SDoc+vanillaSkolemTv :: TcTyVarDetails
+ typecheck/TcTypeNats.hs view
@@ -0,0 +1,757 @@+{-# LANGUAGE LambdaCase #-}++module TcTypeNats+  ( typeNatTyCons+  , typeNatCoAxiomRules+  , BuiltInSynFamily(..)++  , typeNatAddTyCon+  , typeNatMulTyCon+  , typeNatExpTyCon+  , typeNatLeqTyCon+  , typeNatSubTyCon+  , typeNatCmpTyCon+  , typeSymbolCmpTyCon+  , typeSymbolAppendTyCon+  ) where++import Type+import Pair+import TcType     ( TcType, tcEqType )+import TyCon      ( TyCon, FamTyConFlav(..), mkFamilyTyCon+                  , Injectivity(..) )+import Coercion   ( Role(..) )+import TcRnTypes  ( Xi )+import CoAxiom    ( CoAxiomRule(..), BuiltInSynFamily(..), TypeEqn )+import Name       ( Name, BuiltInSyntax(..) )+import TysWiredIn+import TysPrim    ( mkTemplateAnonTyConBinders )+import PrelNames  ( gHC_TYPELITS+                  , gHC_TYPENATS+                  , typeNatAddTyFamNameKey+                  , typeNatMulTyFamNameKey+                  , typeNatExpTyFamNameKey+                  , typeNatLeqTyFamNameKey+                  , typeNatSubTyFamNameKey+                  , typeNatCmpTyFamNameKey+                  , typeSymbolCmpTyFamNameKey+                  , typeSymbolAppendFamNameKey+                  )+import FastString ( FastString+                  , fsLit, nilFS, nullFS, unpackFS, mkFastString, appendFS+                  )+import qualified Data.Map as Map+import Data.Maybe ( isJust )+import Data.List  ( isPrefixOf, isSuffixOf )++{-------------------------------------------------------------------------------+Built-in type constructors for functions on type-level nats+-}++typeNatTyCons :: [TyCon]+typeNatTyCons =+  [ typeNatAddTyCon+  , typeNatMulTyCon+  , typeNatExpTyCon+  , typeNatLeqTyCon+  , typeNatSubTyCon+  , typeNatCmpTyCon+  , typeSymbolCmpTyCon+  , typeSymbolAppendTyCon+  ]++typeNatAddTyCon :: TyCon+typeNatAddTyCon = mkTypeNatFunTyCon2 name+  BuiltInSynFamily+    { sfMatchFam      = matchFamAdd+    , sfInteractTop   = interactTopAdd+    , sfInteractInert = interactInertAdd+    }+  where+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "+")+            typeNatAddTyFamNameKey typeNatAddTyCon++typeNatSubTyCon :: TyCon+typeNatSubTyCon = mkTypeNatFunTyCon2 name+  BuiltInSynFamily+    { sfMatchFam      = matchFamSub+    , sfInteractTop   = interactTopSub+    , sfInteractInert = interactInertSub+    }+  where+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "-")+            typeNatSubTyFamNameKey typeNatSubTyCon++typeNatMulTyCon :: TyCon+typeNatMulTyCon = mkTypeNatFunTyCon2 name+  BuiltInSynFamily+    { sfMatchFam      = matchFamMul+    , sfInteractTop   = interactTopMul+    , sfInteractInert = interactInertMul+    }+  where+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "*")+            typeNatMulTyFamNameKey typeNatMulTyCon++typeNatExpTyCon :: TyCon+typeNatExpTyCon = mkTypeNatFunTyCon2 name+  BuiltInSynFamily+    { sfMatchFam      = matchFamExp+    , sfInteractTop   = interactTopExp+    , sfInteractInert = interactInertExp+    }+  where+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "^")+                typeNatExpTyFamNameKey typeNatExpTyCon++typeNatLeqTyCon :: TyCon+typeNatLeqTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ])+    boolTy+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    NotInjective++  where+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "<=?")+                typeNatLeqTyFamNameKey typeNatLeqTyCon+  ops = BuiltInSynFamily+    { sfMatchFam      = matchFamLeq+    , sfInteractTop   = interactTopLeq+    , sfInteractInert = interactInertLeq+    }++typeNatCmpTyCon :: TyCon+typeNatCmpTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ])+    orderingKind+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    NotInjective++  where+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "CmpNat")+                typeNatCmpTyFamNameKey typeNatCmpTyCon+  ops = BuiltInSynFamily+    { sfMatchFam      = matchFamCmpNat+    , sfInteractTop   = interactTopCmpNat+    , sfInteractInert = \_ _ _ _ -> []+    }++typeSymbolCmpTyCon :: TyCon+typeSymbolCmpTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [ typeSymbolKind, typeSymbolKind ])+    orderingKind+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    NotInjective++  where+  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "CmpSymbol")+                typeSymbolCmpTyFamNameKey typeSymbolCmpTyCon+  ops = BuiltInSynFamily+    { sfMatchFam      = matchFamCmpSymbol+    , sfInteractTop   = interactTopCmpSymbol+    , sfInteractInert = \_ _ _ _ -> []+    }++typeSymbolAppendTyCon :: TyCon+typeSymbolAppendTyCon = mkTypeSymbolFunTyCon2 name+  BuiltInSynFamily+    { sfMatchFam      = matchFamAppendSymbol+    , sfInteractTop   = interactTopAppendSymbol+    , sfInteractInert = interactInertAppendSymbol+    }+  where+  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "AppendSymbol")+                typeSymbolAppendFamNameKey typeSymbolAppendTyCon+++++-- Make a binary built-in constructor of kind: Nat -> Nat -> Nat+mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon+mkTypeNatFunTyCon2 op tcb =+  mkFamilyTyCon op+    (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ])+    typeNatKind+    Nothing+    (BuiltInSynFamTyCon tcb)+    Nothing+    NotInjective++-- Make a binary built-in constructor of kind: Symbol -> Symbol -> Symbol+mkTypeSymbolFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon+mkTypeSymbolFunTyCon2 op tcb =+  mkFamilyTyCon op+    (mkTemplateAnonTyConBinders [ typeSymbolKind, typeSymbolKind ])+    typeSymbolKind+    Nothing+    (BuiltInSynFamTyCon tcb)+    Nothing+    NotInjective+++{-------------------------------------------------------------------------------+Built-in rules axioms+-------------------------------------------------------------------------------}++-- If you add additional rules, please remember to add them to+-- `typeNatCoAxiomRules` also.+axAddDef+  , axMulDef+  , axExpDef+  , axLeqDef+  , axCmpNatDef+  , axCmpSymbolDef+  , axAppendSymbolDef+  , axAdd0L+  , axAdd0R+  , axMul0L+  , axMul0R+  , axMul1L+  , axMul1R+  , axExp1L+  , axExp0R+  , axExp1R+  , axLeqRefl+  , axCmpNatRefl+  , axCmpSymbolRefl+  , axLeq0L+  , axSubDef+  , axSub0R+  , axAppendSymbol0R+  , axAppendSymbol0L+  :: CoAxiomRule++axAddDef = mkBinAxiom "AddDef" typeNatAddTyCon $+              \x y -> Just $ num (x + y)++axMulDef = mkBinAxiom "MulDef" typeNatMulTyCon $+              \x y -> Just $ num (x * y)++axExpDef = mkBinAxiom "ExpDef" typeNatExpTyCon $+              \x y -> Just $ num (x ^ y)++axLeqDef = mkBinAxiom "LeqDef" typeNatLeqTyCon $+              \x y -> Just $ bool (x <= y)++axCmpNatDef   = mkBinAxiom "CmpNatDef" typeNatCmpTyCon+              $ \x y -> Just $ ordering (compare x y)++axCmpSymbolDef =+  CoAxiomRule+    { coaxrName      = fsLit "CmpSymbolDef"+    , coaxrAsmpRoles = [Nominal, Nominal]+    , coaxrRole      = Nominal+    , coaxrProves    = \cs ->+        do [Pair s1 s2, Pair t1 t2] <- return cs+           s2' <- isStrLitTy s2+           t2' <- isStrLitTy t2+           return (mkTyConApp typeSymbolCmpTyCon [s1,t1] ===+                   ordering (compare s2' t2')) }++axAppendSymbolDef = CoAxiomRule+    { coaxrName      = fsLit "AppendSymbolDef"+    , coaxrAsmpRoles = [Nominal, Nominal]+    , coaxrRole      = Nominal+    , coaxrProves    = \cs ->+        do [Pair s1 s2, Pair t1 t2] <- return cs+           s2' <- isStrLitTy s2+           t2' <- isStrLitTy t2+           let z = mkStrLitTy (appendFS s2' t2')+           return (mkTyConApp typeSymbolAppendTyCon [s1, t1] === z)+    }++axSubDef = mkBinAxiom "SubDef" typeNatSubTyCon $+              \x y -> fmap num (minus x y)++axAdd0L     = mkAxiom1 "Add0L"    $ \(Pair s t) -> (num 0 .+. s) === t+axAdd0R     = mkAxiom1 "Add0R"    $ \(Pair s t) -> (s .+. num 0) === t+axSub0R     = mkAxiom1 "Sub0R"    $ \(Pair s t) -> (s .-. num 0) === t+axMul0L     = mkAxiom1 "Mul0L"    $ \(Pair s _) -> (num 0 .*. s) === num 0+axMul0R     = mkAxiom1 "Mul0R"    $ \(Pair s _) -> (s .*. num 0) === num 0+axMul1L     = mkAxiom1 "Mul1L"    $ \(Pair s t) -> (num 1 .*. s) === t+axMul1R     = mkAxiom1 "Mul1R"    $ \(Pair s t) -> (s .*. num 1) === t+axExp1L     = mkAxiom1 "Exp1L"    $ \(Pair s _) -> (num 1 .^. s) === num 1+axExp0R     = mkAxiom1 "Exp0R"    $ \(Pair s _) -> (s .^. num 0) === num 1+axExp1R     = mkAxiom1 "Exp1R"    $ \(Pair s t) -> (s .^. num 1) === t+axLeqRefl   = mkAxiom1 "LeqRefl"  $ \(Pair s _) -> (s <== s) === bool True+axCmpNatRefl    = mkAxiom1 "CmpNatRefl"+                $ \(Pair s _) -> (cmpNat s s) === ordering EQ+axCmpSymbolRefl = mkAxiom1 "CmpSymbolRefl"+                $ \(Pair s _) -> (cmpSymbol s s) === ordering EQ+axLeq0L     = mkAxiom1 "Leq0L"    $ \(Pair s _) -> (num 0 <== s) === bool True+axAppendSymbol0R  = mkAxiom1 "Concat0R"+            $ \(Pair s t) -> (mkStrLitTy nilFS `appendSymbol` s) === t+axAppendSymbol0L  = mkAxiom1 "Concat0L"+            $ \(Pair s t) -> (s `appendSymbol` mkStrLitTy nilFS) === t++typeNatCoAxiomRules :: Map.Map FastString CoAxiomRule+typeNatCoAxiomRules = Map.fromList $ map (\x -> (coaxrName x, x))+  [ axAddDef+  , axMulDef+  , axExpDef+  , axLeqDef+  , axCmpNatDef+  , axCmpSymbolDef+  , axAppendSymbolDef+  , axAdd0L+  , axAdd0R+  , axMul0L+  , axMul0R+  , axMul1L+  , axMul1R+  , axExp1L+  , axExp0R+  , axExp1R+  , axLeqRefl+  , axCmpNatRefl+  , axCmpSymbolRefl+  , axLeq0L+  , axSubDef+  , axAppendSymbol0R+  , axAppendSymbol0L+  ]++++{-------------------------------------------------------------------------------+Various utilities for making axioms and types+-------------------------------------------------------------------------------}++(.+.) :: Type -> Type -> Type+s .+. t = mkTyConApp typeNatAddTyCon [s,t]++(.-.) :: Type -> Type -> Type+s .-. t = mkTyConApp typeNatSubTyCon [s,t]++(.*.) :: Type -> Type -> Type+s .*. t = mkTyConApp typeNatMulTyCon [s,t]++(.^.) :: Type -> Type -> Type+s .^. t = mkTyConApp typeNatExpTyCon [s,t]++(<==) :: Type -> Type -> Type+s <== t = mkTyConApp typeNatLeqTyCon [s,t]++cmpNat :: Type -> Type -> Type+cmpNat s t = mkTyConApp typeNatCmpTyCon [s,t]++cmpSymbol :: Type -> Type -> Type+cmpSymbol s t = mkTyConApp typeSymbolCmpTyCon [s,t]++appendSymbol :: Type -> Type -> Type+appendSymbol s t = mkTyConApp typeSymbolAppendTyCon [s, t]++(===) :: Type -> Type -> Pair Type+x === y = Pair x y++num :: Integer -> Type+num = mkNumLitTy++bool :: Bool -> Type+bool b = if b then mkTyConApp promotedTrueDataCon []+              else mkTyConApp promotedFalseDataCon []++isBoolLitTy :: Type -> Maybe Bool+isBoolLitTy tc =+  do (tc,[]) <- splitTyConApp_maybe tc+     case () of+       _ | tc == promotedFalseDataCon -> return False+         | tc == promotedTrueDataCon  -> return True+         | otherwise                   -> Nothing++orderingKind :: Kind+orderingKind = mkTyConApp orderingTyCon []++ordering :: Ordering -> Type+ordering o =+  case o of+    LT -> mkTyConApp promotedLTDataCon []+    EQ -> mkTyConApp promotedEQDataCon []+    GT -> mkTyConApp promotedGTDataCon []++isOrderingLitTy :: Type -> Maybe Ordering+isOrderingLitTy tc =+  do (tc1,[]) <- splitTyConApp_maybe tc+     case () of+       _ | tc1 == promotedLTDataCon -> return LT+         | tc1 == promotedEQDataCon -> return EQ+         | tc1 == promotedGTDataCon -> return GT+         | otherwise                -> Nothing++known :: (Integer -> Bool) -> TcType -> Bool+known p x = case isNumLitTy x of+              Just a  -> p a+              Nothing -> False+++++-- For the definitional axioms+mkBinAxiom :: String -> TyCon ->+              (Integer -> Integer -> Maybe Type) -> CoAxiomRule+mkBinAxiom str tc f =+  CoAxiomRule+    { coaxrName      = fsLit str+    , coaxrAsmpRoles = [Nominal, Nominal]+    , coaxrRole      = Nominal+    , coaxrProves    = \cs ->+        do [Pair s1 s2, Pair t1 t2] <- return cs+           s2' <- isNumLitTy s2+           t2' <- isNumLitTy t2+           z   <- f s2' t2'+           return (mkTyConApp tc [s1,t1] === z)+    }++++mkAxiom1 :: String -> (TypeEqn -> TypeEqn) -> CoAxiomRule+mkAxiom1 str f =+  CoAxiomRule+    { coaxrName      = fsLit str+    , coaxrAsmpRoles = [Nominal]+    , coaxrRole      = Nominal+    , coaxrProves    = \case [eqn] -> Just (f eqn)+                             _     -> Nothing+    }+++{-------------------------------------------------------------------------------+Evaluation+-------------------------------------------------------------------------------}++matchFamAdd :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+matchFamAdd [s,t]+  | Just 0 <- mbX = Just (axAdd0L, [t], t)+  | Just 0 <- mbY = Just (axAdd0R, [s], s)+  | Just x <- mbX, Just y <- mbY =+    Just (axAddDef, [s,t], num (x + y))+  where mbX = isNumLitTy s+        mbY = isNumLitTy t+matchFamAdd _ = Nothing++matchFamSub :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+matchFamSub [s,t]+  | Just 0 <- mbY = Just (axSub0R, [s], s)+  | Just x <- mbX, Just y <- mbY, Just z <- minus x y =+    Just (axSubDef, [s,t], num z)+  where mbX = isNumLitTy s+        mbY = isNumLitTy t+matchFamSub _ = Nothing++matchFamMul :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+matchFamMul [s,t]+  | Just 0 <- mbX = Just (axMul0L, [t], num 0)+  | Just 0 <- mbY = Just (axMul0R, [s], num 0)+  | Just 1 <- mbX = Just (axMul1L, [t], t)+  | Just 1 <- mbY = Just (axMul1R, [s], s)+  | Just x <- mbX, Just y <- mbY =+    Just (axMulDef, [s,t], num (x * y))+  where mbX = isNumLitTy s+        mbY = isNumLitTy t+matchFamMul _ = Nothing++matchFamExp :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+matchFamExp [s,t]+  | Just 0 <- mbY = Just (axExp0R, [s], num 1)+  | Just 1 <- mbX = Just (axExp1L, [t], num 1)+  | Just 1 <- mbY = Just (axExp1R, [s], s)+  | Just x <- mbX, Just y <- mbY =+    Just (axExpDef, [s,t], num (x ^ y))+  where mbX = isNumLitTy s+        mbY = isNumLitTy t+matchFamExp _ = Nothing++matchFamLeq :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+matchFamLeq [s,t]+  | Just 0 <- mbX = Just (axLeq0L, [t], bool True)+  | Just x <- mbX, Just y <- mbY =+    Just (axLeqDef, [s,t], bool (x <= y))+  | tcEqType s t  = Just (axLeqRefl, [s], bool True)+  where mbX = isNumLitTy s+        mbY = isNumLitTy t+matchFamLeq _ = Nothing++matchFamCmpNat :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+matchFamCmpNat [s,t]+  | Just x <- mbX, Just y <- mbY =+    Just (axCmpNatDef, [s,t], ordering (compare x y))+  | tcEqType s t = Just (axCmpNatRefl, [s], ordering EQ)+  where mbX = isNumLitTy s+        mbY = isNumLitTy t+matchFamCmpNat _ = Nothing++matchFamCmpSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+matchFamCmpSymbol [s,t]+  | Just x <- mbX, Just y <- mbY =+    Just (axCmpSymbolDef, [s,t], ordering (compare x y))+  | tcEqType s t = Just (axCmpSymbolRefl, [s], ordering EQ)+  where mbX = isStrLitTy s+        mbY = isStrLitTy t+matchFamCmpSymbol _ = Nothing++matchFamAppendSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+matchFamAppendSymbol [s,t]+  | Just x <- mbX, nullFS x = Just (axAppendSymbol0R, [t], t)+  | Just y <- mbY, nullFS y = Just (axAppendSymbol0L, [s], s)+  | Just x <- mbX, Just y <- mbY =+    Just (axAppendSymbolDef, [s,t], mkStrLitTy (appendFS x y))+  where+  mbX = isStrLitTy s+  mbY = isStrLitTy t+matchFamAppendSymbol _ = Nothing++{-------------------------------------------------------------------------------+Interact with axioms+-------------------------------------------------------------------------------}++interactTopAdd :: [Xi] -> Xi -> [Pair Type]+interactTopAdd [s,t] r+  | Just 0 <- mbZ = [ s === num 0, t === num 0 ]                          -- (s + t ~ 0) => (s ~ 0, t ~ 0)+  | Just x <- mbX, Just z <- mbZ, Just y <- minus z x = [t === num y]     -- (5 + t ~ 8) => (t ~ 3)+  | Just y <- mbY, Just z <- mbZ, Just x <- minus z y = [s === num x]     -- (s + 5 ~ 8) => (s ~ 3)+  where+  mbX = isNumLitTy s+  mbY = isNumLitTy t+  mbZ = isNumLitTy r+interactTopAdd _ _ = []++{-+Note [Weakened interaction rule for subtraction]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++A simpler interaction here might be:++  `s - t ~ r` --> `t + r ~ s`++This would enable us to reuse all the code for addition.+Unfortunately, this works a little too well at the moment.+Consider the following example:++    0 - 5 ~ r --> 5 + r ~ 0 --> (5 = 0, r = 0)++This (correctly) spots that the constraint cannot be solved.++However, this may be a problem if the constraint did not+need to be solved in the first place!  Consider the following example:++f :: Proxy (If (5 <=? 0) (0 - 5) (5 - 0)) -> Proxy 5+f = id++Currently, GHC is strict while evaluating functions, so this does not+work, because even though the `If` should evaluate to `5 - 0`, we+also evaluate the "then" branch which generates the constraint `0 - 5 ~ r`,+which fails.++So, for the time being, we only add an improvement when the RHS is a constant,+which happens to work OK for the moment, although clearly we need to do+something more general.+-}+interactTopSub :: [Xi] -> Xi -> [Pair Type]+interactTopSub [s,t] r+  | Just z <- mbZ = [ s === (num z .+. t) ]         -- (s - t ~ 5) => (5 + t ~ s)+  where+  mbZ = isNumLitTy r+interactTopSub _ _ = []++++++interactTopMul :: [Xi] -> Xi -> [Pair Type]+interactTopMul [s,t] r+  | Just 1 <- mbZ = [ s === num 1, t === num 1 ]                        -- (s * t ~ 1)  => (s ~ 1, t ~ 1)+  | Just x <- mbX, Just z <- mbZ, Just y <- divide z x = [t === num y]  -- (3 * t ~ 15) => (t ~ 5)+  | Just y <- mbY, Just z <- mbZ, Just x <- divide z y = [s === num x]  -- (s * 3 ~ 15) => (s ~ 5)+  where+  mbX = isNumLitTy s+  mbY = isNumLitTy t+  mbZ = isNumLitTy r+interactTopMul _ _ = []++interactTopExp :: [Xi] -> Xi -> [Pair Type]+interactTopExp [s,t] r+  | Just 0 <- mbZ = [ s === num 0 ]                                       -- (s ^ t ~ 0) => (s ~ 0)+  | Just x <- mbX, Just z <- mbZ, Just y <- logExact  z x = [t === num y] -- (2 ^ t ~ 8) => (t ~ 3)+  | Just y <- mbY, Just z <- mbZ, Just x <- rootExact z y = [s === num x] -- (s ^ 2 ~ 9) => (s ~ 3)+  where+  mbX = isNumLitTy s+  mbY = isNumLitTy t+  mbZ = isNumLitTy r+interactTopExp _ _ = []++interactTopLeq :: [Xi] -> Xi -> [Pair Type]+interactTopLeq [s,t] r+  | Just 0 <- mbY, Just True <- mbZ = [ s === num 0 ]                     -- (s <= 0) => (s ~ 0)+  where+  mbY = isNumLitTy t+  mbZ = isBoolLitTy r+interactTopLeq _ _ = []++interactTopCmpNat :: [Xi] -> Xi -> [Pair Type]+interactTopCmpNat [s,t] r+  | Just EQ <- isOrderingLitTy r = [ s === t ]+interactTopCmpNat _ _ = []++interactTopCmpSymbol :: [Xi] -> Xi -> [Pair Type]+interactTopCmpSymbol [s,t] r+  | Just EQ <- isOrderingLitTy r = [ s === t ]+interactTopCmpSymbol _ _ = []++interactTopAppendSymbol :: [Xi] -> Xi -> [Pair Type]+interactTopAppendSymbol [s,t] r+  -- (AppendSymbol a b ~ "") => (a ~ "", b ~ "")+  | Just z <- mbZ, nullFS z =+    [s === mkStrLitTy nilFS, t === mkStrLitTy nilFS ]++  -- (AppendSymbol "foo" b ~ "foobar") => (b ~ "bar")+  | Just x <- fmap unpackFS mbX, Just z <- fmap unpackFS mbZ, x `isPrefixOf` z =+    [ t === mkStrLitTy (mkFastString $ drop (length x) z) ]++  -- (AppendSymbol f "bar" ~ "foobar") => (f ~ "foo")+  | Just y <- fmap unpackFS mbY, Just z <- fmap unpackFS mbZ, y `isSuffixOf` z =+    [ t === mkStrLitTy (mkFastString $ take (length z - length y) z) ]++  where+  mbX = isStrLitTy s+  mbY = isStrLitTy t+  mbZ = isStrLitTy r++interactTopAppendSymbol _ _ = []++{-------------------------------------------------------------------------------+Interaction with inerts+-------------------------------------------------------------------------------}++interactInertAdd :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]+interactInertAdd [x1,y1] z1 [x2,y2] z2+  | sameZ && tcEqType x1 x2         = [ y1 === y2 ]+  | sameZ && tcEqType y1 y2         = [ x1 === x2 ]+  where sameZ = tcEqType z1 z2+interactInertAdd _ _ _ _ = []++interactInertSub :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]+interactInertSub [x1,y1] z1 [x2,y2] z2+  | sameZ && tcEqType x1 x2         = [ y1 === y2 ]+  | sameZ && tcEqType y1 y2         = [ x1 === x2 ]+  where sameZ = tcEqType z1 z2+interactInertSub _ _ _ _ = []++interactInertMul :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]+interactInertMul [x1,y1] z1 [x2,y2] z2+  | sameZ && known (/= 0) x1 && tcEqType x1 x2 = [ y1 === y2 ]+  | sameZ && known (/= 0) y1 && tcEqType y1 y2 = [ x1 === x2 ]+  where sameZ   = tcEqType z1 z2++interactInertMul _ _ _ _ = []++interactInertExp :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]+interactInertExp [x1,y1] z1 [x2,y2] z2+  | sameZ && known (> 1) x1 && tcEqType x1 x2 = [ y1 === y2 ]+  | sameZ && known (> 0) y1 && tcEqType y1 y2 = [ x1 === x2 ]+  where sameZ = tcEqType z1 z2++interactInertExp _ _ _ _ = []+++interactInertLeq :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]+interactInertLeq [x1,y1] z1 [x2,y2] z2+  | bothTrue && tcEqType x1 y2 && tcEqType y1 x2 = [ x1 === y1 ]+  | bothTrue && tcEqType y1 x2                 = [ (x1 <== y2) === bool True ]+  | bothTrue && tcEqType y2 x1                 = [ (x2 <== y1) === bool True ]+  where bothTrue = isJust $ do True <- isBoolLitTy z1+                               True <- isBoolLitTy z2+                               return ()++interactInertLeq _ _ _ _ = []+++interactInertAppendSymbol :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]+interactInertAppendSymbol [x1,y1] z1 [x2,y2] z2+  | sameZ && tcEqType x1 x2         = [ y1 === y2 ]+  | sameZ && tcEqType y1 y2         = [ x1 === x2 ]+  where sameZ = tcEqType z1 z2+interactInertAppendSymbol _ _ _ _ = []++++{- -----------------------------------------------------------------------------+These inverse functions are used for simplifying propositions using+concrete natural numbers.+----------------------------------------------------------------------------- -}++-- | Subtract two natural numbers.+minus :: Integer -> Integer -> Maybe Integer+minus x y = if x >= y then Just (x - y) else Nothing++-- | Compute the exact logarithm of a natural number.+-- The logarithm base is the second argument.+logExact :: Integer -> Integer -> Maybe Integer+logExact x y = do (z,True) <- genLog x y+                  return z+++-- | Divide two natural numbers.+divide :: Integer -> Integer -> Maybe Integer+divide _ 0  = Nothing+divide x y  = case divMod x y of+                (a,0) -> Just a+                _     -> Nothing++-- | Compute the exact root of a natural number.+-- The second argument specifies which root we are computing.+rootExact :: Integer -> Integer -> Maybe Integer+rootExact x y = do (z,True) <- genRoot x y+                   return z++++{- | Compute the the n-th root of a natural number, rounded down to+the closest natural number.  The boolean indicates if the result+is exact (i.e., True means no rounding was done, False means rounded down).+The second argument specifies which root we are computing. -}+genRoot :: Integer -> Integer -> Maybe (Integer, Bool)+genRoot _  0    = Nothing+genRoot x0 1    = Just (x0, True)+genRoot x0 root = Just (search 0 (x0+1))+  where+  search from to = let x = from + div (to - from) 2+                       a = x ^ root+                   in case compare a x0 of+                        EQ              -> (x, True)+                        LT | x /= from  -> search x to+                           | otherwise  -> (from, False)+                        GT | x /= to    -> search from x+                           | otherwise  -> (from, False)++{- | Compute the logarithm of a number in the given base, rounded down to the+closest integer.  The boolean indicates if we the result is exact+(i.e., True means no rounding happened, False means we rounded down).+The logarithm base is the second argument. -}+genLog :: Integer -> Integer -> Maybe (Integer, Bool)+genLog x 0    = if x == 1 then Just (0, True) else Nothing+genLog _ 1    = Nothing+genLog 0 _    = Nothing+genLog x base = Just (exactLoop 0 x)+  where+  exactLoop s i+    | i == 1     = (s,True)+    | i < base   = (s,False)+    | otherwise  =+        let s1 = s + 1+        in s1 `seq` case divMod i base of+                      (j,r)+                        | r == 0    -> exactLoop s1 j+                        | otherwise -> (underLoop s1 j, False)++  underLoop s i+    | i < base  = s+    | otherwise = let s1 = s + 1 in s1 `seq` underLoop s1 (div i base)
+ typecheck/TcTypeNats.hs-boot view
@@ -0,0 +1,5 @@+module TcTypeNats where++import TyCon (TyCon)++typeNatTyCons :: [TyCon]
+ typecheck/TcTypeable.hs view
@@ -0,0 +1,701 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1999+-}++{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module TcTypeable(mkTypeableBinds) where+++import BasicTypes ( SourceText(..), Boxity(..), neverInlinePragma )+import TcBinds( addTypecheckedBinds )+import IfaceEnv( newGlobalBinder )+import TyCoRep( Type(..), TyLit(..) )+import TcEnv+import TcEvidence ( mkWpTyApps )+import TcRnMonad+import HscTypes ( lookupId )+import PrelNames+import TysPrim ( primTyCons )+import TysWiredIn ( tupleTyCon, sumTyCon, runtimeRepTyCon+                  , vecCountTyCon, vecElemTyCon+                  , nilDataCon, consDataCon )+import Id+import Type+import Kind ( isTYPEApp )+import TyCon+import DataCon+import Name ( Name, getOccName )+import OccName+import Module+import HsSyn+import DynFlags+import Bag+import Var ( TyVarBndr(..) )+import TrieMap+import Constants+import Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints)+import Outputable+import FastString ( FastString, mkFastString, fsLit )++import Control.Monad.Trans.State+import Control.Monad.Trans.Class (lift)+import Data.Maybe ( isJust )+import Data.Word( Word64 )++{- Note [Grand plan for Typeable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The overall plan is this:++1. Generate a binding for each module p:M+   (done in TcTypeable by mkModIdBindings)+       M.$trModule :: GHC.Types.Module+       M.$trModule = Module "p" "M"+   ("tr" is short for "type representation"; see GHC.Types)++   We might want to add the filename too.+   This can be used for the lightweight stack-tracing stuff too++   Record the Name M.$trModule in the tcg_tr_module field of TcGblEnv++2. Generate a binding for every data type declaration T in module M,+       M.$tcT :: GHC.Types.TyCon+       M.$tcT = TyCon ...fingerprint info...+                      $trModule+                      "T"+                      0#+                      kind_rep++   Here 0# is the number of arguments expected by the tycon to fully determine+   its kind. kind_rep is a value of type GHC.Types.KindRep, which gives a+   recipe for computing the kind of an instantiation of the tycon (see+   Note [Representing TyCon kinds] later in this file for details).++   We define (in TyCon)++        type TyConRepName = Name++   to use for these M.$tcT "tycon rep names". Note that these must be+   treated as "never exported" names by Backpack (see+   Note [Handling never-exported TyThings under Backpack]). Consequently+   they get slightly special treatment in RnModIface.rnIfaceDecl.++3. Record the TyConRepName in T's TyCon, including for promoted+   data and type constructors, and kinds like * and #.++   The TyConRepName is not an "implicit Id".  It's more like a record+   selector: the TyCon knows its name but you have to go to the+   interface file to find its type, value, etc++4. Solve Typeable constraints.  This is done by a custom Typeable solver,+   currently in TcInteract, that use M.$tcT so solve (Typeable T).++There are many wrinkles:++* The timing of when we produce this bindings is rather important: they must be+  defined after the rest of the module has been typechecked since we need to be+  able to lookup Module and TyCon in the type environment and we may be+  currently compiling GHC.Types (where they are defined).++* GHC.Prim doesn't have any associated object code, so we need to put the+  representations for types defined in this module elsewhere. We chose this+  place to be GHC.Types. TcTypeable.mkPrimTypeableBinds is responsible for+  injecting the bindings for the GHC.Prim representions when compiling+  GHC.Types.++* TyCon.tyConRepModOcc is responsible for determining where to find+  the representation binding for a given type. This is where we handle+  the special case for GHC.Prim.++* To save space and reduce dependencies, we need use quite low-level+  representations for TyCon and Module.  See GHC.Types+  Note [Runtime representation of modules and tycons]++* The KindReps can unfortunately get quite large. Moreover, the simplifier will+  float out various pieces of them, resulting in numerous top-level bindings.+  Consequently we mark the KindRep bindings as noinline, ensuring that the+  float-outs don't make it into the interface file. This is important since+  there is generally little benefit to inlining KindReps and they would+  otherwise strongly affect compiler performance.++* In general there are lots of things of kind *, * -> *, and * -> * -> *. To+  reduce the number of bindings we need to produce, we generate their KindReps+  once in GHC.Types. These are referred to as "built-in" KindReps below.++* Even though KindReps aren't inlined, this scheme still has more of an effect on+  compilation time than I'd like. This is especially true in the case of+  families of type constructors (e.g. tuples and unboxed sums). The problem is+  particularly bad in the case of sums, since each arity-N tycon brings with it+  N promoted datacons, each with a KindRep whose size also scales with N.+  Consequently we currently simply don't allow sums to be Typeable.++  In general we might consider moving some or all of this generation logic back+  to the solver since the performance hit we take in doing this at+  type-definition time is non-trivial and Typeable isn't very widely used. This+  is discussed in #13261.++-}++-- | Generate the Typeable bindings for a module. This is the only+-- entry-point of this module and is invoked by the typechecker driver in+-- 'tcRnSrcDecls'.+--+-- See Note [Grand plan for Typeable] in TcTypeable.+mkTypeableBinds :: TcM TcGblEnv+mkTypeableBinds+  = do { -- Create a binding for $trModule.+         -- Do this before processing any data type declarations,+         -- which need tcg_tr_module to be initialised+       ; tcg_env <- mkModIdBindings+         -- Now we can generate the TyCon representations...+         -- First we handle the primitive TyCons if we are compiling GHC.Types+       ; (tcg_env, prim_todos) <- setGblEnv tcg_env mkPrimTypeableTodos++         -- Then we produce bindings for the user-defined types in this module.+       ; setGblEnv tcg_env $+    do { mod <- getModule+       ; let tycons = filter needs_typeable_binds (tcg_tcs tcg_env)+             mod_id = case tcg_tr_module tcg_env of  -- Should be set by now+                        Just mod_id -> mod_id+                        Nothing     -> pprPanic "tcMkTypeableBinds" (ppr tycons)+       ; traceTc "mkTypeableBinds" (ppr tycons)+       ; this_mod_todos <- todoForTyCons mod mod_id tycons+       ; mkTypeRepTodoBinds (this_mod_todos : prim_todos)+       } }+  where+    needs_typeable_binds tc+      | tc `elem` [runtimeRepTyCon, vecCountTyCon, vecElemTyCon]+      = False+      | otherwise =+          isAlgTyCon tc+       || isDataFamilyTyCon tc+       || isClassTyCon tc+++{- *********************************************************************+*                                                                      *+            Building top-level binding for $trModule+*                                                                      *+********************************************************************* -}++mkModIdBindings :: TcM TcGblEnv+mkModIdBindings+  = do { mod <- getModule+       ; loc <- getSrcSpanM+       ; mod_nm        <- newGlobalBinder mod (mkVarOcc "$trModule") loc+       ; trModuleTyCon <- tcLookupTyCon trModuleTyConName+       ; let mod_id = mkExportedVanillaId mod_nm (mkTyConApp trModuleTyCon [])+       ; mod_bind      <- mkVarBind mod_id <$> mkModIdRHS mod++       ; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv+       ; return (tcg_env { tcg_tr_module = Just mod_id }+                 `addTypecheckedBinds` [unitBag mod_bind]) }++mkModIdRHS :: Module -> TcM (LHsExpr Id)+mkModIdRHS mod+  = do { trModuleDataCon <- tcLookupDataCon trModuleDataConName+       ; trNameLit <- mkTrNameLit+       ; return $ nlHsDataCon trModuleDataCon+                  `nlHsApp` trNameLit (unitIdFS (moduleUnitId mod))+                  `nlHsApp` trNameLit (moduleNameFS (moduleName mod))+       }++{- *********************************************************************+*                                                                      *+                Building type-representation bindings+*                                                                      *+********************************************************************* -}++-- | Information we need about a 'TyCon' to generate its representation. We+-- carry the 'Id' in order to share it between the generation of the @TyCon@ and+-- @KindRep@ bindings.+data TypeableTyCon+    = TypeableTyCon+      { tycon        :: !TyCon+      , tycon_rep_id :: !Id+      }++-- | A group of 'TyCon's in need of type-rep bindings.+data TypeRepTodo+    = TypeRepTodo+      { mod_rep_expr    :: LHsExpr Id       -- ^ Module's typerep binding+      , pkg_fingerprint :: !Fingerprint     -- ^ Package name fingerprint+      , mod_fingerprint :: !Fingerprint     -- ^ Module name fingerprint+      , todo_tycons     :: [TypeableTyCon]+        -- ^ The 'TyCon's in need of bindings kinds+      }+    | ExportedKindRepsTodo [(Kind, Id)]+      -- ^ Build exported 'KindRep' bindings for the given set of kinds.++todoForTyCons :: Module -> Id -> [TyCon] -> TcM TypeRepTodo+todoForTyCons mod mod_id tycons = do+    trTyConTy <- mkTyConTy <$> tcLookupTyCon trTyConTyConName+    let mk_rep_id :: TyConRepName -> Id+        mk_rep_id rep_name = mkExportedVanillaId rep_name trTyConTy++    let typeable_tycons :: [TypeableTyCon]+        typeable_tycons =+            [ TypeableTyCon { tycon = tc''+                            , tycon_rep_id = mk_rep_id rep_name+                            }+            | tc     <- tycons+            , tc'    <- tc : tyConATs tc+              -- We need type representations for any associated types+            , let promoted = map promoteDataCon (tyConDataCons tc')+            , tc''   <- tc' : promoted+              -- Don't make bindings for data-family instance tycons.+              -- Do, however, make them for their promoted datacon (see #13915).+            , not $ isFamInstTyCon tc''+            , Just rep_name <- pure $ tyConRepName_maybe tc''+            , typeIsTypeable $ dropForAlls $ tyConKind tc''+            ]+    return TypeRepTodo { mod_rep_expr    = nlHsVar mod_id+                       , pkg_fingerprint = pkg_fpr+                       , mod_fingerprint = mod_fpr+                       , todo_tycons     = typeable_tycons+                       }+  where+    mod_fpr = fingerprintString $ moduleNameString $ moduleName mod+    pkg_fpr = fingerprintString $ unitIdString $ moduleUnitId mod++todoForExportedKindReps :: [(Kind, Name)] -> TcM TypeRepTodo+todoForExportedKindReps kinds = do+    trKindRepTy <- mkTyConTy <$> tcLookupTyCon kindRepTyConName+    let mkId (k, name) = (k, mkExportedVanillaId name trKindRepTy)+    return $ ExportedKindRepsTodo $ map mkId kinds++-- | Generate TyCon bindings for a set of type constructors+mkTypeRepTodoBinds :: [TypeRepTodo] -> TcM TcGblEnv+mkTypeRepTodoBinds [] = getGblEnv+mkTypeRepTodoBinds todos+  = do { stuff <- collect_stuff++         -- First extend the type environment with all of the bindings+         -- which we are going to produce since we may need to refer to them+         -- while generating kind representations (namely, when we want to+         -- represent a TyConApp in a kind, we must be able to look up the+         -- TyCon associated with the applied type constructor).+       ; let produced_bndrs :: [Id]+             produced_bndrs = [ tycon_rep_id+                              | todo@(TypeRepTodo{}) <- todos+                              , TypeableTyCon {..} <- todo_tycons todo+                              ] +++                              [ rep_id+                              | ExportedKindRepsTodo kinds <- todos+                              , (_, rep_id) <- kinds+                              ]+       ; gbl_env <- tcExtendGlobalValEnv produced_bndrs getGblEnv++       ; let mk_binds :: TypeRepTodo -> KindRepM [LHsBinds Id]+             mk_binds todo@(TypeRepTodo {}) =+                 mapM (mkTyConRepBinds stuff todo) (todo_tycons todo)+             mk_binds (ExportedKindRepsTodo kinds) =+                 mkExportedKindReps stuff kinds >> return []++       ; (gbl_env, binds) <- setGblEnv gbl_env+                             $ runKindRepM (mapM mk_binds todos)+       ; return $ gbl_env `addTypecheckedBinds` concat binds }++-- | Generate bindings for the type representation of a wired-in 'TyCon's+-- defined by the virtual "GHC.Prim" module. This is where we inject the+-- representation bindings for these primitive types into "GHC.Types"+--+-- See Note [Grand plan for Typeable] in this module.+mkPrimTypeableTodos :: TcM (TcGblEnv, [TypeRepTodo])+mkPrimTypeableTodos+  = do { mod <- getModule+       ; if mod == gHC_TYPES+           then do { -- Build Module binding for GHC.Prim+                     trModuleTyCon <- tcLookupTyCon trModuleTyConName+                   ; let ghc_prim_module_id =+                             mkExportedVanillaId trGhcPrimModuleName+                                                 (mkTyConTy trModuleTyCon)++                   ; ghc_prim_module_bind <- mkVarBind ghc_prim_module_id+                                             <$> mkModIdRHS gHC_PRIM++                     -- Extend our environment with above+                   ; gbl_env <- tcExtendGlobalValEnv [ghc_prim_module_id]+                                                     getGblEnv+                   ; let gbl_env' = gbl_env `addTypecheckedBinds`+                                    [unitBag ghc_prim_module_bind]++                     -- Build TypeRepTodos for built-in KindReps+                   ; todo1 <- todoForExportedKindReps builtInKindReps+                     -- Build TypeRepTodos for types in GHC.Prim+                   ; todo2 <- todoForTyCons gHC_PRIM ghc_prim_module_id+                                            ghcPrimTypeableTyCons+                   ; return ( gbl_env' , [todo1, todo2])+                   }+           else do gbl_env <- getGblEnv+                   return (gbl_env, [])+       }++-- | This is the list of primitive 'TyCon's for which we must generate bindings+-- in "GHC.Types". This should include all types defined in "GHC.Prim".+--+-- The majority of the types we need here are contained in 'primTyCons'.+-- However, not all of them: in particular unboxed tuples are absent since we+-- don't want to include them in the original name cache. See+-- Note [Built-in syntax and the OrigNameCache] in IfaceEnv for more.+ghcPrimTypeableTyCons :: [TyCon]+ghcPrimTypeableTyCons = concat+    [ [ runtimeRepTyCon, vecCountTyCon, vecElemTyCon+      , funTyCon, tupleTyCon Unboxed 0 ]+    , map (tupleTyCon Unboxed) [2..mAX_TUPLE_SIZE]+    , map sumTyCon [2..mAX_SUM_SIZE]+    , primTyCons+    ]++data TypeableStuff+    = Stuff { dflags         :: DynFlags+            , trTyConDataCon :: DataCon         -- ^ of @TyCon@+            , trNameLit      :: FastString -> LHsExpr Id+                                                -- ^ To construct @TrName@s+              -- The various TyCon and DataCons of KindRep+            , kindRepTyCon           :: TyCon+            , kindRepTyConAppDataCon :: DataCon+            , kindRepVarDataCon      :: DataCon+            , kindRepAppDataCon      :: DataCon+            , kindRepFunDataCon      :: DataCon+            , kindRepTYPEDataCon     :: DataCon+            , kindRepTypeLitSDataCon :: DataCon+            , typeLitSymbolDataCon   :: DataCon+            , typeLitNatDataCon      :: DataCon+            }++-- | Collect various tidbits which we'll need to generate TyCon representations.+collect_stuff :: TcM TypeableStuff+collect_stuff = do+    dflags <- getDynFlags+    trTyConDataCon         <- tcLookupDataCon trTyConDataConName+    kindRepTyCon           <- tcLookupTyCon   kindRepTyConName+    kindRepTyConAppDataCon <- tcLookupDataCon kindRepTyConAppDataConName+    kindRepVarDataCon      <- tcLookupDataCon kindRepVarDataConName+    kindRepAppDataCon      <- tcLookupDataCon kindRepAppDataConName+    kindRepFunDataCon      <- tcLookupDataCon kindRepFunDataConName+    kindRepTYPEDataCon     <- tcLookupDataCon kindRepTYPEDataConName+    kindRepTypeLitSDataCon <- tcLookupDataCon kindRepTypeLitSDataConName+    typeLitSymbolDataCon   <- tcLookupDataCon typeLitSymbolDataConName+    typeLitNatDataCon      <- tcLookupDataCon typeLitNatDataConName+    trNameLit              <- mkTrNameLit+    return Stuff {..}++-- | Lookup the necessary pieces to construct the @trNameLit@. We do this so we+-- can save the work of repeating lookups when constructing many TyCon+-- representations.+mkTrNameLit :: TcM (FastString -> LHsExpr Id)+mkTrNameLit = do+    trNameSDataCon <- tcLookupDataCon trNameSDataConName+    let trNameLit :: FastString -> LHsExpr Id+        trNameLit fs = nlHsPar $ nlHsDataCon trNameSDataCon+                       `nlHsApp` nlHsLit (mkHsStringPrimLit fs)+    return trNameLit++-- | Make Typeable bindings for the given 'TyCon'.+mkTyConRepBinds :: TypeableStuff -> TypeRepTodo+                -> TypeableTyCon -> KindRepM (LHsBinds Id)+mkTyConRepBinds stuff@(Stuff {..}) todo (TypeableTyCon {..})+  = do -- Make a KindRep+       let (bndrs, kind) = splitForAllTyVarBndrs (tyConKind tycon)+       liftTc $ traceTc "mkTyConKindRepBinds"+                        (ppr tycon $$ ppr (tyConKind tycon) $$ ppr kind)+       let ctx = mkDeBruijnContext (map binderVar bndrs)+       kind_rep <- getKindRep stuff ctx kind++       -- Make the TyCon binding+       let tycon_rep_rhs = mkTyConRepTyConRHS stuff todo tycon kind_rep+           tycon_rep_bind = mkVarBind tycon_rep_id tycon_rep_rhs+       return $ unitBag tycon_rep_bind++-- | Here is where we define the set of Typeable types. These exclude type+-- families and polytypes.+tyConIsTypeable :: TyCon -> Bool+tyConIsTypeable tc =+       isJust (tyConRepName_maybe tc)+    && typeIsTypeable (dropForAlls $ tyConKind tc)+      -- Ensure that the kind of the TyCon, with its initial foralls removed,+      -- is representable (e.g. has no higher-rank polymorphism or type+      -- synonyms).++-- | Is a particular 'Type' representable by @Typeable@? Here we look for+-- polytypes and types containing casts (which may be, for instance, a type+-- family).+typeIsTypeable :: Type -> Bool+-- We handle types of the form (TYPE rep) specifically to avoid+-- looping on (tyConIsTypeable RuntimeRep)+typeIsTypeable ty+  | Just ty' <- coreView ty         = typeIsTypeable ty'+typeIsTypeable ty+  | Just _ <- isTYPEApp ty          = True+typeIsTypeable (TyVarTy _)          = True+typeIsTypeable (AppTy a b)          = typeIsTypeable a && typeIsTypeable b+typeIsTypeable (FunTy a b)          = typeIsTypeable a && typeIsTypeable b+typeIsTypeable (TyConApp tc args)   = tyConIsTypeable tc+                                   && all typeIsTypeable args+typeIsTypeable (ForAllTy{})         = False+typeIsTypeable (LitTy _)            = True+typeIsTypeable (CastTy{})           = False+typeIsTypeable (CoercionTy{})       = False++-- | Maps kinds to 'KindRep' bindings. This binding may either be defined in+-- some other module (in which case the @Maybe (LHsExpr Id@ will be 'Nothing')+-- or a binding which we generated in the current module (in which case it will+-- be 'Just' the RHS of the binding).+type KindRepEnv = TypeMap (Id, Maybe (LHsExpr Id))++-- | A monad within which we will generate 'KindRep's. Here we keep an+-- environment containing 'KindRep's which we've already generated so we can+-- re-use them opportunistically.+newtype KindRepM a = KindRepM { unKindRepM :: StateT KindRepEnv TcRn a }+                   deriving (Functor, Applicative, Monad)++liftTc :: TcRn a -> KindRepM a+liftTc = KindRepM . lift++-- | We generate @KindRep@s for a few common kinds in @GHC.Types@ so that they+-- can be reused across modules.+builtInKindReps :: [(Kind, Name)]+builtInKindReps =+    [ (star, starKindRepName)+    , (mkFunTy star star, starArrStarKindRepName)+    , (mkFunTys [star, star] star, starArrStarArrStarKindRepName)+    ]+  where+    star = liftedTypeKind++initialKindRepEnv :: TcRn KindRepEnv+initialKindRepEnv = foldlM add_kind_rep emptyTypeMap builtInKindReps+  where+    add_kind_rep acc (k,n) = do+        id <- tcLookupId n+        return $! extendTypeMap acc k (id, Nothing)++-- | Performed while compiling "GHC.Types" to generate the built-in 'KindRep's.+mkExportedKindReps :: TypeableStuff+                   -> [(Kind, Id)]  -- ^ the kinds to generate bindings for+                   -> KindRepM ()+mkExportedKindReps stuff@(Stuff {..}) = mapM_ kindrep_binding+  where+    empty_scope = mkDeBruijnContext []++    kindrep_binding :: (Kind, Id) -> KindRepM ()+    kindrep_binding (kind, rep_bndr) = do+        -- We build the binding manually here instead of using mkKindRepRhs+        -- since the latter would find the built-in 'KindRep's in the+        -- 'KindRepEnv' (by virtue of being in 'initialKindRepEnv').+        rhs <- mkKindRepRhs stuff empty_scope kind+        addKindRepBind empty_scope kind rep_bndr rhs++addKindRepBind :: CmEnv -> Kind -> Id -> LHsExpr Id -> KindRepM ()+addKindRepBind in_scope k bndr rhs =+    KindRepM $ modify' $+    \env -> extendTypeMapWithScope env in_scope k (bndr, Just rhs)++-- | Run a 'KindRepM' and add the produced 'KindRep's to the typechecking+-- environment.+runKindRepM :: KindRepM a -> TcRn (TcGblEnv, a)+runKindRepM (KindRepM action) = do+    kindRepEnv <- initialKindRepEnv+    (res, reps_env) <- runStateT action kindRepEnv+    let rep_binds = foldTypeMap to_bind_pair [] reps_env+        to_bind_pair (bndr, Just rhs) rest = (bndr, rhs) : rest+        to_bind_pair (_, Nothing) rest = rest+    tcg_env <- tcExtendGlobalValEnv (map fst rep_binds) getGblEnv+    let binds = map (uncurry mkVarBind) rep_binds+        tcg_env' = tcg_env `addTypecheckedBinds` [listToBag binds]+    return (tcg_env', res)++-- | Produce or find a 'KindRep' for the given kind.+getKindRep :: TypeableStuff -> CmEnv  -- ^ in-scope kind variables+           -> Kind   -- ^ the kind we want a 'KindRep' for+           -> KindRepM (LHsExpr Id)+getKindRep stuff@(Stuff {..}) in_scope = go+  where+    go :: Kind -> KindRepM (LHsExpr Id)+    go = KindRepM . StateT . go'++    go' :: Kind -> KindRepEnv -> TcRn (LHsExpr Id, KindRepEnv)+    go' k env+        -- Look through type synonyms+      | Just k' <- tcView k = go' k' env++        -- We've already generated the needed KindRep+      | Just (id, _) <- lookupTypeMapWithScope env in_scope k+      = return (nlHsVar id, env)++        -- We need to construct a new KindRep binding+      | otherwise+      = do -- Place a NOINLINE pragma on KindReps since they tend to be quite+           -- large and bloat interface files.+           rep_bndr <- (`setInlinePragma` neverInlinePragma)+                   <$> newSysLocalId (fsLit "$krep") (mkTyConTy kindRepTyCon)++           -- do we need to tie a knot here?+           flip runStateT env $ unKindRepM $ do+               rhs <- mkKindRepRhs stuff in_scope k+               addKindRepBind in_scope k rep_bndr rhs+               return $ nlHsVar rep_bndr++-- | Construct the right-hand-side of the 'KindRep' for the given 'Kind' and+-- in-scope kind variable set.+mkKindRepRhs :: TypeableStuff+             -> CmEnv       -- ^ in-scope kind variables+             -> Kind        -- ^ the kind we want a 'KindRep' for+             -> KindRepM (LHsExpr Id) -- ^ RHS expression+mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep+  where+    new_kind_rep k+        -- We handle TYPE separately to make it clear to consumers+        -- (e.g. serializers) that there is a loop here (as+        -- TYPE :: RuntimeRep -> TYPE 'LiftedRep)+      | Just rr <- isTYPEApp k+      = return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` nlHsDataCon rr++    new_kind_rep (TyVarTy v)+      | Just idx <- lookupCME in_scope v+      = return $ nlHsDataCon kindRepVarDataCon+                 `nlHsApp` nlHsIntLit (fromIntegral idx)+      | otherwise+      = pprPanic "mkTyConKindRepBinds.go(tyvar)" (ppr v)++    new_kind_rep (AppTy t1 t2)+      = do rep1 <- getKindRep stuff in_scope t1+           rep2 <- getKindRep stuff in_scope t2+           return $ nlHsDataCon kindRepAppDataCon+                    `nlHsApp` rep1 `nlHsApp` rep2++    new_kind_rep k@(TyConApp tc tys)+      | Just rep_name <- tyConRepName_maybe tc+      = do rep_id <- liftTc $ lookupId rep_name+           tys' <- mapM (getKindRep stuff in_scope) tys+           return $ nlHsDataCon kindRepTyConAppDataCon+                    `nlHsApp` nlHsVar rep_id+                    `nlHsApp` mkList (mkTyConTy kindRepTyCon) tys'+      | otherwise+      = pprPanic "mkTyConKindRepBinds(TyConApp)" (ppr tc $$ ppr k)++    new_kind_rep (ForAllTy (TvBndr var _) ty)+      = pprPanic "mkTyConKindRepBinds(ForAllTy)" (ppr var $$ ppr ty)++    new_kind_rep (FunTy t1 t2)+      = do rep1 <- getKindRep stuff in_scope t1+           rep2 <- getKindRep stuff in_scope t2+           return $ nlHsDataCon kindRepFunDataCon+                    `nlHsApp` rep1 `nlHsApp` rep2++    new_kind_rep (LitTy (NumTyLit n))+      = return $ nlHsDataCon kindRepTypeLitSDataCon+                 `nlHsApp` nlHsDataCon typeLitNatDataCon+                 `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show n)++    new_kind_rep (LitTy (StrTyLit s))+      = return $ nlHsDataCon kindRepTypeLitSDataCon+                 `nlHsApp` nlHsDataCon typeLitSymbolDataCon+                 `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show s)++    new_kind_rep (CastTy ty co)+      = pprPanic "mkTyConKindRepBinds.go(cast)" (ppr ty $$ ppr co)++    new_kind_rep (CoercionTy co)+      = pprPanic "mkTyConKindRepBinds.go(coercion)" (ppr co)++-- | Produce the right-hand-side of a @TyCon@ representation.+mkTyConRepTyConRHS :: TypeableStuff -> TypeRepTodo+                   -> TyCon      -- ^ the 'TyCon' we are producing a binding for+                   -> LHsExpr Id -- ^ its 'KindRep'+                   -> LHsExpr Id+mkTyConRepTyConRHS (Stuff {..}) todo tycon kind_rep+  =           nlHsDataCon trTyConDataCon+    `nlHsApp` nlHsLit (word64 dflags high)+    `nlHsApp` nlHsLit (word64 dflags low)+    `nlHsApp` mod_rep_expr todo+    `nlHsApp` trNameLit (mkFastString tycon_str)+    `nlHsApp` nlHsLit (int n_kind_vars)+    `nlHsApp` kind_rep+  where+    n_kind_vars = length $ filter isNamedTyConBinder (tyConBinders tycon)+    tycon_str = add_tick (occNameString (getOccName tycon))+    add_tick s | isPromotedDataCon tycon = '\'' : s+               | otherwise               = s++    -- This must match the computation done in+    -- Data.Typeable.Internal.mkTyConFingerprint.+    Fingerprint high low = fingerprintFingerprints [ pkg_fingerprint todo+                                                   , mod_fingerprint todo+                                                   , fingerprintString tycon_str+                                                   ]++    int :: Int -> HsLit+    int n = HsIntPrim (SourceText $ show n) (toInteger n)++word64 :: DynFlags -> Word64 -> HsLit+word64 dflags n+  | wORD_SIZE dflags == 4 = HsWord64Prim NoSourceText (toInteger n)+  | otherwise             = HsWordPrim   NoSourceText (toInteger n)++{-+Note [Representing TyCon kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++One of the operations supported by Typeable is typeRepKind,++    typeRepKind :: TypeRep (a :: k) -> TypeRep k++Implementing this is a bit tricky. To see why let's consider the TypeRep+encoding of `Proxy Int` where++    data Proxy (a :: k) :: Type++which looks like,++    $tcProxy :: TyCon+    $trInt   :: TypeRep Int+    $trType  :: TypeRep Type++    $trProxyType :: TypeRep (Proxy :: Type -> Type)+    $trProxyType = TrTyCon $tcProxy+                           [$trType]  -- kind variable instantiation++    $trProxy :: TypeRep (Proxy Int)+    $trProxy = TrApp $trProxyType $trInt++Note how $trProxyType encodes only the kind variables of the TyCon+instantiation. To compute the kind (Proxy Int) we need to have a recipe to+compute the kind of a concrete instantiation of Proxy. We call this recipe a+KindRep and store it in the TyCon produced for Proxy,++    type KindBndr = Int   -- de Bruijn index++    data KindRep = KindRepTyConApp TyCon [KindRep]+                 | KindRepVar !KindBndr+                 | KindRepApp KindRep KindRep+                 | KindRepFun KindRep KindRep++The KindRep for Proxy would look like,++    $tkProxy :: KindRep+    $tkProxy = KindRepFun (KindRepVar 0) (KindRepTyConApp $trType [])+++data Maybe a = Nothing | Just a++'Just :: a -> Maybe a++F :: forall k. k -> forall k'. k' -> Type+-}++mkList :: Type -> [LHsExpr Id] -> LHsExpr Id+mkList ty = foldr consApp (nilExpr ty)+  where+    cons = consExpr ty+    consApp :: LHsExpr Id -> LHsExpr Id -> LHsExpr Id+    consApp x xs = cons `nlHsApp` x `nlHsApp` xs++    nilExpr :: Type -> LHsExpr Id+    nilExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon nilDataCon)++    consExpr :: Type -> LHsExpr Id+    consExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon consDataCon)
+ typecheck/TcUnify.hs view
@@ -0,0 +1,2116 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Type subsumption and unification+-}++{-# LANGUAGE CPP, MultiWayIf, TupleSections, ScopedTypeVariables #-}++module TcUnify (+  -- Full-blown subsumption+  tcWrapResult, tcWrapResultO, tcSkolemise, tcSkolemiseET,+  tcSubTypeHR, tcSubTypeO, tcSubType_NC, tcSubTypeDS,+  tcSubTypeDS_NC_O, tcSubTypeET,+  checkConstraints, buildImplicationFor,++  -- Various unifications+  unifyType, unifyTheta, unifyKind, noThing,+  uType, promoteTcType,+  swapOverTyVars, canSolveByUnification,++  --------------------------------+  -- Holes+  tcInferInst, tcInferNoInst,+  matchExpectedListTy,+  matchExpectedPArrTy,+  matchExpectedTyConApp,+  matchExpectedAppTy,+  matchExpectedFunTys,+  matchActualFunTys, matchActualFunTysPart,+  matchExpectedFunKind,++  wrapFunResCoercion,++  occCheckExpand, metaTyVarUpdateOK,+  occCheckForErrors, OccCheckResult(..)++  ) where++#include "HsVersions.h"++import HsSyn+import TyCoRep+import TcMType+import TcRnMonad+import TcType+import Type+import Coercion+import TcEvidence+import Name ( isSystemName )+import Inst+import TyCon+import TysWiredIn+import TysPrim( tYPE )+import Var+import VarSet+import VarEnv+import ErrUtils+import DynFlags+import BasicTypes+import Name   ( Name )+import Bag+import Util+import Pair( pFst )+import qualified GHC.LanguageExtensions as LangExt+import Outputable+import FastString++import Control.Monad+import Control.Arrow ( second )++{-+************************************************************************+*                                                                      *+             matchExpected functions+*                                                                      *+************************************************************************++Note [Herald for matchExpectedFunTys]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The 'herald' always looks like:+   "The equation(s) for 'f' have"+   "The abstraction (\x.e) takes"+   "The section (+ x) expects"+   "The function 'f' is applied to"++This is used to construct a message of form++   The abstraction `\Just 1 -> ...' takes two arguments+   but its type `Maybe a -> a' has only one++   The equation(s) for `f' have two arguments+   but its type `Maybe a -> a' has only one++   The section `(f 3)' requires 'f' to take two arguments+   but its type `Int -> Int' has only one++   The function 'f' is applied to two arguments+   but its type `Int -> Int' has only one++Note [matchExpectedFunTys]+~~~~~~~~~~~~~~~~~~~~~~~~~~+matchExpectedFunTys checks that a sigma has the form+of an n-ary function.  It passes the decomposed type to the+thing_inside, and returns a wrapper to coerce between the two types++It's used wherever a language construct must have a functional type,+namely:+        A lambda expression+        A function definition+     An operator section++This function must be written CPS'd because it needs to fill in the+ExpTypes produced for arguments before it can fill in the ExpType+passed in.++-}++-- Use this one when you have an "expected" type.+matchExpectedFunTys :: forall a.+                       SDoc   -- See Note [Herald for matchExpectedFunTys]+                    -> Arity+                    -> ExpRhoType  -- deeply skolemised+                    -> ([ExpSigmaType] -> ExpRhoType -> TcM a)+                          -- must fill in these ExpTypes here+                    -> TcM (a, HsWrapper)+-- If    matchExpectedFunTys n ty = (_, wrap)+-- then  wrap : (t1 -> ... -> tn -> ty_r) ~> ty,+--   where [t1, ..., tn], ty_r are passed to the thing_inside+matchExpectedFunTys herald arity orig_ty thing_inside+  = case orig_ty of+      Check ty -> go [] arity ty+      _        -> defer [] arity orig_ty+  where+    go acc_arg_tys 0 ty+      = do { result <- thing_inside (reverse acc_arg_tys) (mkCheckExpType ty)+           ; return (result, idHsWrapper) }++    go acc_arg_tys n ty+      | Just ty' <- tcView ty = go acc_arg_tys n ty'++    go acc_arg_tys n (FunTy arg_ty res_ty)+      = ASSERT( not (isPredTy arg_ty) )+        do { (result, wrap_res) <- go (mkCheckExpType arg_ty : acc_arg_tys)+                                      (n-1) res_ty+           ; return ( result+                    , mkWpFun idHsWrapper wrap_res arg_ty res_ty doc ) }+      where+        doc = text "When inferring the argument type of a function with type" <+>+              quotes (ppr orig_ty)++    go acc_arg_tys n ty@(TyVarTy tv)+      | isMetaTyVar tv+      = do { cts <- readMetaTyVar tv+           ; case cts of+               Indirect ty' -> go acc_arg_tys n ty'+               Flexi        -> defer acc_arg_tys n (mkCheckExpType ty) }++       -- In all other cases we bale out into ordinary unification+       -- However unlike the meta-tyvar case, we are sure that the+       -- number of arguments doesn't match arity of the original+       -- type, so we can add a bit more context to the error message+       -- (cf Trac #7869).+       --+       -- It is not always an error, because specialized type may have+       -- different arity, for example:+       --+       -- > f1 = f2 'a'+       -- > f2 :: Monad m => m Bool+       -- > f2 = undefined+       --+       -- But in that case we add specialized type into error context+       -- anyway, because it may be useful. See also Trac #9605.+    go acc_arg_tys n ty = addErrCtxtM mk_ctxt $+                          defer acc_arg_tys n (mkCheckExpType ty)++    ------------+    defer :: [ExpSigmaType] -> Arity -> ExpRhoType -> TcM (a, HsWrapper)+    defer acc_arg_tys n fun_ty+      = do { more_arg_tys <- replicateM n newInferExpTypeNoInst+           ; res_ty       <- newInferExpTypeInst+           ; result       <- thing_inside (reverse acc_arg_tys ++ more_arg_tys) res_ty+           ; more_arg_tys <- mapM readExpType more_arg_tys+           ; res_ty       <- readExpType res_ty+           ; let unif_fun_ty = mkFunTys more_arg_tys res_ty+           ; wrap <- tcSubTypeDS AppOrigin GenSigCtxt unif_fun_ty fun_ty+                         -- Not a good origin at all :-(+           ; return (result, wrap) }++    ------------+    mk_ctxt :: TidyEnv -> TcM (TidyEnv, MsgDoc)+    mk_ctxt env = do { (env', ty) <- zonkTidyTcType env orig_tc_ty+                     ; let (args, _) = tcSplitFunTys ty+                           n_actual = length args+                           (env'', orig_ty') = tidyOpenType env' orig_tc_ty+                     ; return ( env''+                              , mk_fun_tys_msg orig_ty' ty n_actual arity herald) }+      where+        orig_tc_ty = checkingExpType "matchExpectedFunTys" orig_ty+            -- this is safe b/c we're called from "go"++-- Like 'matchExpectedFunTys', but used when you have an "actual" type,+-- for example in function application+matchActualFunTys :: Outputable a+                  => SDoc   -- See Note [Herald for matchExpectedFunTys]+                  -> CtOrigin+                  -> Maybe a   -- the thing with type TcSigmaType+                  -> Arity+                  -> TcSigmaType+                  -> TcM (HsWrapper, [TcSigmaType], TcSigmaType)+-- If    matchActualFunTys n ty = (wrap, [t1,..,tn], ty_r)+-- then  wrap : ty ~> (t1 -> ... -> tn -> ty_r)+matchActualFunTys herald ct_orig mb_thing arity ty+  = matchActualFunTysPart herald ct_orig mb_thing arity ty [] arity++-- | Variant of 'matchActualFunTys' that works when supplied only part+-- (that is, to the right of some arrows) of the full function type+matchActualFunTysPart :: Outputable a+                      => SDoc -- See Note [Herald for matchExpectedFunTys]+                      -> CtOrigin+                      -> Maybe a  -- the thing with type TcSigmaType+                      -> Arity+                      -> TcSigmaType+                      -> [TcSigmaType] -- reversed args. See (*) below.+                      -> Arity   -- overall arity of the function, for errs+                      -> TcM (HsWrapper, [TcSigmaType], TcSigmaType)+matchActualFunTysPart herald ct_orig mb_thing arity orig_ty+                      orig_old_args full_arity+  = go arity orig_old_args orig_ty+-- Does not allocate unnecessary meta variables: if the input already is+-- a function, we just take it apart.  Not only is this efficient,+-- it's important for higher rank: the argument might be of form+--              (forall a. ty) -> other+-- If allocated (fresh-meta-var1 -> fresh-meta-var2) and unified, we'd+-- hide the forall inside a meta-variable++-- (*) Sometimes it's necessary to call matchActualFunTys with only part+-- (that is, to the right of some arrows) of the type of the function in+-- question. (See TcExpr.tcArgs.) This argument is the reversed list of+-- arguments already seen (that is, not part of the TcSigmaType passed+-- in elsewhere).++  where+    -- This function has a bizarre mechanic: it accumulates arguments on+    -- the way down and also builds an argument list on the way up. Why:+    -- 1. The returns args list and the accumulated args list might be different.+    --    The accumulated args include all the arg types for the function,+    --    including those from before this function was called. The returned+    --    list should include only those arguments produced by this call of+    --    matchActualFunTys+    --+    -- 2. The HsWrapper can be built only on the way up. It seems (more)+    --    bizarre to build the HsWrapper but not the arg_tys.+    --+    -- Refactoring is welcome.+    go :: Arity+       -> [TcSigmaType] -- accumulator of arguments (reversed)+       -> TcSigmaType   -- the remainder of the type as we're processing+       -> TcM (HsWrapper, [TcSigmaType], TcSigmaType)+    go 0 _ ty = return (idHsWrapper, [], ty)++    go n acc_args ty+      | not (null tvs && null theta)+      = do { (wrap1, rho) <- topInstantiate ct_orig ty+           ; (wrap2, arg_tys, res_ty) <- go n acc_args rho+           ; return (wrap2 <.> wrap1, arg_tys, res_ty) }+      where+        (tvs, theta, _) = tcSplitSigmaTy ty++    go n acc_args ty+      | Just ty' <- tcView ty = go n acc_args ty'++    go n acc_args (FunTy arg_ty res_ty)+      = ASSERT( not (isPredTy arg_ty) )+        do { (wrap_res, tys, ty_r) <- go (n-1) (arg_ty : acc_args) res_ty+           ; return ( mkWpFun idHsWrapper wrap_res arg_ty ty_r doc+                    , arg_ty : tys, ty_r ) }+      where+        doc = text "When inferring the argument type of a function with type" <+>+              quotes (ppr orig_ty)++    go n acc_args ty@(TyVarTy tv)+      | isMetaTyVar tv+      = do { cts <- readMetaTyVar tv+           ; case cts of+               Indirect ty' -> go n acc_args ty'+               Flexi        -> defer n ty }++       -- In all other cases we bale out into ordinary unification+       -- However unlike the meta-tyvar case, we are sure that the+       -- number of arguments doesn't match arity of the original+       -- type, so we can add a bit more context to the error message+       -- (cf Trac #7869).+       --+       -- It is not always an error, because specialized type may have+       -- different arity, for example:+       --+       -- > f1 = f2 'a'+       -- > f2 :: Monad m => m Bool+       -- > f2 = undefined+       --+       -- But in that case we add specialized type into error context+       -- anyway, because it may be useful. See also Trac #9605.+    go n acc_args ty = addErrCtxtM (mk_ctxt (reverse acc_args) ty) $+                       defer n ty++    ------------+    defer n fun_ty+      = do { arg_tys <- replicateM n newOpenFlexiTyVarTy+           ; res_ty  <- newOpenFlexiTyVarTy+           ; let unif_fun_ty = mkFunTys arg_tys res_ty+           ; co <- unifyType mb_thing fun_ty unif_fun_ty+           ; return (mkWpCastN co, arg_tys, res_ty) }++    ------------+    mk_ctxt :: [TcSigmaType] -> TcSigmaType -> TidyEnv -> TcM (TidyEnv, MsgDoc)+    mk_ctxt arg_tys res_ty env+      = do { let ty = mkFunTys arg_tys res_ty+           ; (env1, zonked) <- zonkTidyTcType env ty+                   -- zonking might change # of args+           ; let (zonked_args, _) = tcSplitFunTys zonked+                 n_actual         = length zonked_args+                 (env2, unzonked) = tidyOpenType env1 ty+           ; return ( env2+                    , mk_fun_tys_msg unzonked zonked n_actual full_arity herald) }++mk_fun_tys_msg :: TcType  -- the full type passed in (unzonked)+               -> TcType  -- the full type passed in (zonked)+               -> Arity   -- the # of args found+               -> Arity   -- the # of args wanted+               -> SDoc    -- overall herald+               -> SDoc+mk_fun_tys_msg full_ty ty n_args full_arity herald+  = herald <+> speakNOf full_arity (text "argument") <> comma $$+    if n_args == full_arity+      then text "its type is" <+> quotes (pprType full_ty) <>+           comma $$+           text "it is specialized to" <+> quotes (pprType ty)+      else sep [text "but its type" <+> quotes (pprType ty),+                if n_args == 0 then text "has none"+                else text "has only" <+> speakN n_args]++----------------------+matchExpectedListTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType)+-- Special case for lists+matchExpectedListTy exp_ty+ = do { (co, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty+      ; return (co, elt_ty) }++----------------------+matchExpectedPArrTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType)+-- Special case for parrs+matchExpectedPArrTy exp_ty+  = do { (co, [elt_ty]) <- matchExpectedTyConApp parrTyCon exp_ty+       ; return (co, elt_ty) }++---------------------+matchExpectedTyConApp :: TyCon                -- T :: forall kv1 ... kvm. k1 -> ... -> kn -> *+                      -> TcRhoType            -- orig_ty+                      -> TcM (TcCoercionN,    -- T k1 k2 k3 a b c ~N orig_ty+                              [TcSigmaType])  -- Element types, k1 k2 k3 a b c++-- It's used for wired-in tycons, so we call checkWiredInTyCon+-- Precondition: never called with FunTyCon+-- Precondition: input type :: *+-- Postcondition: (T k1 k2 k3 a b c) is well-kinded++matchExpectedTyConApp tc orig_ty+  = ASSERT(tc /= funTyCon) go orig_ty+  where+    go ty+       | Just ty' <- tcView ty+       = go ty'++    go ty@(TyConApp tycon args)+       | tc == tycon  -- Common case+       = return (mkTcNomReflCo ty, args)++    go (TyVarTy tv)+       | isMetaTyVar tv+       = do { cts <- readMetaTyVar tv+            ; case cts of+                Indirect ty -> go ty+                Flexi       -> defer }++    go _ = defer++    -- If the common case does not occur, instantiate a template+    -- T k1 .. kn t1 .. tm, and unify with the original type+    -- Doing it this way ensures that the types we return are+    -- kind-compatible with T.  For example, suppose we have+    --       matchExpectedTyConApp T (f Maybe)+    -- where data T a = MkT a+    -- Then we don't want to instantate T's data constructors with+    --    (a::*) ~ Maybe+    -- because that'll make types that are utterly ill-kinded.+    -- This happened in Trac #7368+    defer+      = do { (_, arg_tvs) <- newMetaTyVars (tyConTyVars tc)+           ; traceTc "matchExpectedTyConApp" (ppr tc $$ ppr (tyConTyVars tc) $$ ppr arg_tvs)+           ; let args = mkTyVarTys arg_tvs+                 tc_template = mkTyConApp tc args+           ; co <- unifyType noThing tc_template orig_ty+           ; return (co, args) }++----------------------+matchExpectedAppTy :: TcRhoType                         -- orig_ty+                   -> TcM (TcCoercion,                   -- m a ~N orig_ty+                           (TcSigmaType, TcSigmaType))  -- Returns m, a+-- If the incoming type is a mutable type variable of kind k, then+-- matchExpectedAppTy returns a new type variable (m: * -> k); note the *.++matchExpectedAppTy orig_ty+  = go orig_ty+  where+    go ty+      | Just ty' <- tcView ty = go ty'++      | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty+      = return (mkTcNomReflCo orig_ty, (fun_ty, arg_ty))++    go (TyVarTy tv)+      | isMetaTyVar tv+      = do { cts <- readMetaTyVar tv+           ; case cts of+               Indirect ty -> go ty+               Flexi       -> defer }++    go _ = defer++    -- Defer splitting by generating an equality constraint+    defer+      = do { ty1 <- newFlexiTyVarTy kind1+           ; ty2 <- newFlexiTyVarTy kind2+           ; co <- unifyType noThing (mkAppTy ty1 ty2) orig_ty+           ; return (co, (ty1, ty2)) }++    orig_kind = typeKind orig_ty+    kind1 = mkFunTy liftedTypeKind orig_kind+    kind2 = liftedTypeKind    -- m :: * -> k+                              -- arg type :: *++{-+************************************************************************+*                                                                      *+                Subsumption checking+*                                                                      *+************************************************************************++Note [Subsumption checking: tcSubType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+All the tcSubType calls have the form+                tcSubType actual_ty expected_ty+which checks+                actual_ty <= expected_ty++That is, that a value of type actual_ty is acceptable in+a place expecting a value of type expected_ty.  I.e. that++    actual ty   is more polymorphic than   expected_ty++It returns a coercion function+        co_fn :: actual_ty ~ expected_ty+which takes an HsExpr of type actual_ty into one of type+expected_ty.++These functions do not actually check for subsumption. They check if+expected_ty is an appropriate annotation to use for something of type+actual_ty. This difference matters when thinking about visible type+application. For example,++   forall a. a -> forall b. b -> b+      DOES NOT SUBSUME+   forall a b. a -> b -> b++because the type arguments appear in a different order. (Neither does+it work the other way around.) BUT, these types are appropriate annotations+for one another. Because the user directs annotations, it's OK if some+arguments shuffle around -- after all, it's what the user wants.+Bottom line: none of this changes with visible type application.++There are a number of wrinkles (below).++Notice that Wrinkle 1 and 2 both require eta-expansion, which technically+may increase termination.  We just put up with this, in exchange for getting+more predictable type inference.++Wrinkle 1: Note [Deep skolemisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want   (forall a. Int -> a -> a)  <=  (Int -> forall a. a->a)+(see section 4.6 of "Practical type inference for higher rank types")+So we must deeply-skolemise the RHS before we instantiate the LHS.++That is why tc_sub_type starts with a call to tcSkolemise (which does the+deep skolemisation), and then calls the DS variant (which assumes+that expected_ty is deeply skolemised)++Wrinkle 2: Note [Co/contra-variance of subsumption checking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider  g :: (Int -> Int) -> Int+  f1 :: (forall a. a -> a) -> Int+  f1 = g++  f2 :: (forall a. a -> a) -> Int+  f2 x = g x+f2 will typecheck, and it would be odd/fragile if f1 did not.+But f1 will only typecheck if we have that+    (Int->Int) -> Int  <=  (forall a. a->a) -> Int+And that is only true if we do the full co/contravariant thing+in the subsumption check.  That happens in the FunTy case of+tcSubTypeDS_NC_O, and is the sole reason for the WpFun form of+HsWrapper.++Another powerful reason for doing this co/contra stuff is visible+in Trac #9569, involving instantiation of constraint variables,+and again involving eta-expansion.++Wrinkle 3: Note [Higher rank types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider tc150:+  f y = \ (x::forall a. a->a). blah+The following happens:+* We will infer the type of the RHS, ie with a res_ty = alpha.+* Then the lambda will split  alpha := beta -> gamma.+* And then we'll check tcSubType IsSwapped beta (forall a. a->a)++So it's important that we unify beta := forall a. a->a, rather than+skolemising the type.+-}+++-- | Call this variant when you are in a higher-rank situation and+-- you know the right-hand type is deeply skolemised.+tcSubTypeHR :: Outputable a+            => CtOrigin    -- ^ of the actual type+            -> Maybe a     -- ^ If present, it has type ty_actual+            -> TcSigmaType -> ExpRhoType -> TcM HsWrapper+tcSubTypeHR orig = tcSubTypeDS_NC_O orig GenSigCtxt++------------------------+tcSubTypeET :: CtOrigin -> UserTypeCtxt+            -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper+-- If wrap = tc_sub_type_et t1 t2+--    => wrap :: t1 ~> t2+tcSubTypeET orig ctxt (Check ty_actual) ty_expected+  = tc_sub_tc_type eq_orig orig ctxt ty_actual ty_expected+  where+    eq_orig = TypeEqOrigin { uo_actual   = ty_expected+                           , uo_expected = ty_actual+                           , uo_thing    = Nothing }++tcSubTypeET _ _ (Infer inf_res) ty_expected+  = ASSERT2( not (ir_inst inf_res), ppr inf_res $$ ppr ty_expected )+    do { co <- fillInferResult ty_expected inf_res+       ; return (mkWpCastN (mkTcSymCo co)) }++------------------------+tcSubTypeO :: CtOrigin      -- ^ of the actual type+           -> UserTypeCtxt  -- ^ of the expected type+           -> TcSigmaType+           -> ExpRhoType+           -> TcM HsWrapper+tcSubTypeO orig ctxt ty_actual ty_expected+  = addSubTypeCtxt ty_actual ty_expected $+    do { traceTc "tcSubTypeDS_O" (vcat [ pprCtOrigin orig+                                       , pprUserTypeCtxt ctxt+                                       , ppr ty_actual+                                       , ppr ty_expected ])+       ; tcSubTypeDS_NC_O orig ctxt noThing ty_actual ty_expected }++addSubTypeCtxt :: TcType -> ExpType -> TcM a -> TcM a+addSubTypeCtxt ty_actual ty_expected thing_inside+ | isRhoTy ty_actual        -- If there is no polymorphism involved, the+ , isRhoExpTy ty_expected   -- TypeEqOrigin stuff (added by the _NC functions)+ = thing_inside             -- gives enough context by itself+ | otherwise+ = addErrCtxtM mk_msg thing_inside+  where+    mk_msg tidy_env+      = do { (tidy_env, ty_actual)   <- zonkTidyTcType tidy_env ty_actual+                   -- might not be filled if we're debugging. ugh.+           ; mb_ty_expected          <- readExpType_maybe ty_expected+           ; (tidy_env, ty_expected) <- case mb_ty_expected of+                                          Just ty -> second mkCheckExpType <$>+                                                     zonkTidyTcType tidy_env ty+                                          Nothing -> return (tidy_env, ty_expected)+           ; ty_expected             <- readExpType ty_expected+           ; (tidy_env, ty_expected) <- zonkTidyTcType tidy_env ty_expected+           ; let msg = vcat [ hang (text "When checking that:")+                                 4 (ppr ty_actual)+                            , nest 2 (hang (text "is more polymorphic than:")+                                         2 (ppr ty_expected)) ]+           ; return (tidy_env, msg) }++---------------+-- The "_NC" variants do not add a typechecker-error context;+-- the caller is assumed to do that++tcSubType_NC :: UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper+-- Checks that actual <= expected+-- Returns HsWrapper :: actual ~ expected+tcSubType_NC ctxt ty_actual ty_expected+  = do { traceTc "tcSubType_NC" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected])+       ; tc_sub_tc_type origin origin ctxt ty_actual ty_expected }+  where+    origin = TypeEqOrigin { uo_actual   = ty_actual+                          , uo_expected = ty_expected+                          , uo_thing    = Nothing }++tcSubTypeDS :: CtOrigin -> UserTypeCtxt -> TcSigmaType -> ExpRhoType -> TcM HsWrapper+-- Just like tcSubType, but with the additional precondition that+-- ty_expected is deeply skolemised (hence "DS")+tcSubTypeDS orig ctxt ty_actual ty_expected+  = addSubTypeCtxt ty_actual ty_expected $+    do { traceTc "tcSubTypeDS_NC" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected])+       ; tcSubTypeDS_NC_O orig ctxt noThing ty_actual ty_expected }++tcSubTypeDS_NC_O :: Outputable a+                 => CtOrigin   -- origin used for instantiation only+                 -> UserTypeCtxt+                 -> Maybe a+                 -> TcSigmaType -> ExpRhoType -> TcM HsWrapper+-- Just like tcSubType, but with the additional precondition that+-- ty_expected is deeply skolemised+tcSubTypeDS_NC_O inst_orig ctxt m_thing ty_actual ty_expected+  = case ty_expected of+      Infer inf_res -> fillInferResult_Inst inst_orig ty_actual inf_res+      Check ty      -> tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty+         where+           eq_orig = TypeEqOrigin { uo_actual = ty_actual, uo_expected = ty+                                  , uo_thing = mkErrorThing <$> m_thing }++---------------+tc_sub_tc_type :: CtOrigin   -- used when calling uType+               -> CtOrigin   -- used when instantiating+               -> UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper+-- If wrap = tc_sub_type t1 t2+--    => wrap :: t1 ~> t2+tc_sub_tc_type eq_orig inst_orig ctxt ty_actual ty_expected+  | is_poly ty_expected      -- See Note [Don't skolemise unnecessarily]+  , not (is_poly ty_actual)+  = do { traceTc "tc_sub_tc_type (drop to equality)" $+         vcat [ text "ty_actual   =" <+> ppr ty_actual+              , text "ty_expected =" <+> ppr ty_expected ]+       ; mkWpCastN <$>+         uType eq_orig TypeLevel ty_actual ty_expected }++  | otherwise   -- This is the general case+  = do { traceTc "tc_sub_tc_type (general case)" $+         vcat [ text "ty_actual   =" <+> ppr ty_actual+              , text "ty_expected =" <+> ppr ty_expected ]+       ; (sk_wrap, inner_wrap) <- tcSkolemise ctxt ty_expected $+                                                   \ _ sk_rho ->+                                  tc_sub_type_ds eq_orig inst_orig ctxt+                                                 ty_actual sk_rho+       ; return (sk_wrap <.> inner_wrap) }+  where+    is_poly ty+      | isForAllTy ty                        = True+      | Just (_, res) <- splitFunTy_maybe ty = is_poly res+      | otherwise                            = False+      -- NB *not* tcSplitFunTy, because here we want+      -- to decompose type-class arguments too+++{- Note [Don't skolemise unnecessarily]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we are trying to solve+    (Char->Char) <= (forall a. a->a)+We could skolemise the 'forall a', and then complain+that (Char ~ a) is insoluble; but that's a pretty obscure+error.  It's better to say that+    (Char->Char) ~ (forall a. a->a)+fails.++In general,+ * if the RHS type an outermost forall (i.e. skolemisation+   is the next thing we'd do)+ * and the LHS has no top-level polymorphism (but looking deeply)+then we can revert to simple equality.+-}++---------------+tc_sub_type_ds :: CtOrigin    -- used when calling uType+               -> CtOrigin    -- used when instantiating+               -> UserTypeCtxt -> TcSigmaType -> TcRhoType -> TcM HsWrapper+-- If wrap = tc_sub_type_ds t1 t2+--    => wrap :: t1 ~> t2+-- Here is where the work actually happens!+-- Precondition: ty_expected is deeply skolemised+tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty_expected+  = do { traceTc "tc_sub_type_ds" $+         vcat [ text "ty_actual   =" <+> ppr ty_actual+              , text "ty_expected =" <+> ppr ty_expected ]+       ; go ty_actual ty_expected }+  where+    go ty_a ty_e | Just ty_a' <- tcView ty_a = go ty_a' ty_e+                 | Just ty_e' <- tcView ty_e = go ty_a  ty_e'++    go (TyVarTy tv_a) ty_e+      = do { lookup_res <- lookupTcTyVar tv_a+           ; case lookup_res of+               Filled ty_a' ->+                 do { traceTc "tcSubTypeDS_NC_O following filled act meta-tyvar:"+                        (ppr tv_a <+> text "-->" <+> ppr ty_a')+                    ; tc_sub_type_ds eq_orig inst_orig ctxt ty_a' ty_e }+               Unfilled _   -> unify }++    -- Historical note (Sept 16): there was a case here for+    --    go ty_a (TyVarTy alpha)+    -- which, in the impredicative case unified  alpha := ty_a+    -- where th_a is a polytype.  Not only is this probably bogus (we+    -- simply do not have decent story for imprdicative types), but it+    -- caused Trac #12616 because (also bizarrely) 'deriving' code had+    -- -XImpredicativeTypes on.  I deleted the entire case.++    go (FunTy act_arg act_res) (FunTy exp_arg exp_res)+      | not (isPredTy act_arg)+      , not (isPredTy exp_arg)+      = -- See Note [Co/contra-variance of subsumption checking]+        do { res_wrap <- tc_sub_type_ds eq_orig inst_orig  ctxt act_res exp_res+           ; arg_wrap <- tc_sub_tc_type eq_orig given_orig ctxt exp_arg act_arg+           ; return (mkWpFun arg_wrap res_wrap exp_arg exp_res doc) }+               -- arg_wrap :: exp_arg ~> act_arg+               -- res_wrap :: act-res ~> exp_res+      where+        given_orig = GivenOrigin (SigSkol GenSigCtxt exp_arg [])+        doc = text "When checking that" <+> quotes (ppr ty_actual) <+>+              text "is more polymorphic than" <+> quotes (ppr ty_expected)++    go ty_a ty_e+      | let (tvs, theta, _) = tcSplitSigmaTy ty_a+      , not (null tvs && null theta)+      = do { (in_wrap, in_rho) <- topInstantiate inst_orig ty_a+           ; body_wrap <- tc_sub_type_ds+                            (eq_orig { uo_actual = in_rho+                                     , uo_expected = ty_expected })+                            inst_orig ctxt in_rho ty_e+           ; return (body_wrap <.> in_wrap) }++      | otherwise   -- Revert to unification+      = inst_and_unify+         -- It's still possible that ty_actual has nested foralls. Instantiate+         -- these, as there's no way unification will succeed with them in.+         -- See typecheck/should_compile/T11305 for an example of when this+         -- is important. The problem is that we're checking something like+         --  a -> forall b. b -> b     <=   alpha beta gamma+         -- where we end up with alpha := (->)++    inst_and_unify = do { (wrap, rho_a) <- deeplyInstantiate inst_orig ty_actual++                           -- if we haven't recurred through an arrow, then+                           -- the eq_orig will list ty_actual. In this case,+                           -- we want to update the origin to reflect the+                           -- instantiation. If we *have* recurred through+                           -- an arrow, it's better not to update.+                        ; let eq_orig' = case eq_orig of+                                TypeEqOrigin { uo_actual   = orig_ty_actual }+                                  |  orig_ty_actual `tcEqType` ty_actual+                                  ,  not (isIdHsWrapper wrap)+                                  -> eq_orig { uo_actual = rho_a }+                                _ -> eq_orig++                        ; cow <- uType eq_orig' TypeLevel rho_a ty_expected+                        ; return (mkWpCastN cow <.> wrap) }+++     -- use versions without synonyms expanded+    unify = mkWpCastN <$> uType eq_orig TypeLevel ty_actual ty_expected++-----------------+-- needs both un-type-checked (for origins) and type-checked (for wrapping)+-- expressions+tcWrapResult :: HsExpr Name -> HsExpr TcId -> TcSigmaType -> ExpRhoType+             -> TcM (HsExpr TcId)+tcWrapResult rn_expr = tcWrapResultO (exprCtOrigin rn_expr)++-- | Sometimes we don't have a @HsExpr Name@ to hand, and this is more+-- convenient.+tcWrapResultO :: CtOrigin -> HsExpr TcId -> TcSigmaType -> ExpRhoType+               -> TcM (HsExpr TcId)+tcWrapResultO orig expr actual_ty res_ty+  = do { traceTc "tcWrapResult" (vcat [ text "Actual:  " <+> ppr actual_ty+                                      , text "Expected:" <+> ppr res_ty ])+       ; cow <- tcSubTypeDS_NC_O orig GenSigCtxt+                                 (Just expr) actual_ty res_ty+       ; return (mkHsWrap cow expr) }++-----------------------------------+wrapFunResCoercion+        :: [TcType]        -- Type of args+        -> HsWrapper       -- HsExpr a -> HsExpr b+        -> TcM HsWrapper   -- HsExpr (arg_tys -> a) -> HsExpr (arg_tys -> b)+wrapFunResCoercion arg_tys co_fn_res+  | isIdHsWrapper co_fn_res+  = return idHsWrapper+  | null arg_tys+  = return co_fn_res+  | otherwise+  = do  { arg_ids <- newSysLocalIds (fsLit "sub") arg_tys+        ; return (mkWpLams arg_ids <.> co_fn_res <.> mkWpEvVarApps arg_ids) }+++{- **********************************************************************+%*                                                                      *+            ExpType functions: tcInfer, fillInferResult+%*                                                                      *+%********************************************************************* -}++-- | Infer a type using a fresh ExpType+-- See also Note [ExpType] in TcMType+-- Does not attempt to instantiate the inferred type+tcInferNoInst :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)+tcInferNoInst = tcInfer False++tcInferInst :: (ExpRhoType -> TcM a) -> TcM (a, TcRhoType)+tcInferInst = tcInfer True++tcInfer :: Bool -> (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)+tcInfer instantiate tc_check+  = do { res_ty <- newInferExpType instantiate+       ; result <- tc_check res_ty+       ; res_ty <- readExpType res_ty+       ; return (result, res_ty) }++fillInferResult_Inst :: CtOrigin -> TcType -> InferResult -> TcM HsWrapper+-- If wrap = fillInferResult_Inst t1 t2+--    => wrap :: t1 ~> t2+-- See Note [Deep instantiation of InferResult]+fillInferResult_Inst orig ty inf_res@(IR { ir_inst = instantiate_me })+  | instantiate_me+  = do { (wrap, rho) <- deeplyInstantiate orig ty+       ; co <- fillInferResult rho inf_res+       ; return (mkWpCastN co <.> wrap) }++  | otherwise+  = do { co <- fillInferResult ty inf_res+       ; return (mkWpCastN co) }++fillInferResult :: TcType -> InferResult -> TcM TcCoercionN+-- If wrap = fillInferResult t1 t2+--    => wrap :: t1 ~> t2+fillInferResult orig_ty (IR { ir_uniq = u, ir_lvl = res_lvl+                            , ir_ref = ref })+  = do { (ty_co, ty_to_fill_with) <- promoteTcType res_lvl orig_ty++       ; traceTc "Filling ExpType" $+         ppr u <+> text ":=" <+> ppr ty_to_fill_with++       ; when debugIsOn (check_hole ty_to_fill_with)++       ; writeTcRef ref (Just ty_to_fill_with)++       ; return ty_co }+  where+    check_hole ty   -- Debug check only+      = do { let ty_lvl = tcTypeLevel ty+           ; MASSERT2( not (ty_lvl `strictlyDeeperThan` res_lvl),+                       ppr u $$ ppr res_lvl $$ ppr ty_lvl $$+                       ppr ty <+> ppr (typeKind ty) $$ ppr orig_ty )+           ; cts <- readTcRef ref+           ; case cts of+               Just already_there -> pprPanic "writeExpType"+                                       (vcat [ ppr u+                                             , ppr ty+                                             , ppr already_there ])+               Nothing -> return () }++{- Note [Deep instantiation of InferResult]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In some cases we want to deeply instantiate before filling in+an InferResult, and in some cases not.  That's why InferReult+has the ir_inst flag.++* ir_inst = True: deeply instantantiate++  Consider+    f x = (*)+  We want to instantiate the type of (*) before returning, else we+  will infer the type+    f :: forall {a}. a -> forall b. Num b => b -> b -> b+  This is surely confusing for users.++  And worse, the the monomorphism restriction won't properly. The MR is+  dealt with in simplifyInfer, and simplifyInfer has no way of+  instantiating. This could perhaps be worked around, but it may be+  hard to know even when instantiation should happen.++  Another reason.  Consider+       f :: (?x :: Int) => a -> a+       g y = let ?x = 3::Int in f+  Here want to instantiate f's type so that the ?x::Int constraint+  gets discharged by the enclosing implicit-parameter binding.++* ir_inst = False: do not instantantiate++  Consider this (which uses visible type application):++    (let { f :: forall a. a -> a; f x = x } in f) @Int++  We'll call TcExpr.tcInferFun to infer the type of the (let .. in f)+  And we don't want to instantite the type of 'f' when we reach it,+  else the outer visible type application won't work+-}++{- *********************************************************************+*                                                                      *+              Promoting types+*                                                                      *+********************************************************************* -}++promoteTcType :: TcLevel -> TcType -> TcM (TcCoercion, TcType)+-- See Note [Promoting a type]+-- promoteTcType level ty = (co, ty')+--   * Returns ty'  whose max level is just 'level'+--             and  whose kind is ~# to the kind of 'ty'+--             and  whose kind has form TYPE rr+--   * and co :: ty ~ ty'+--   * and emits constraints to justify the coercion+promoteTcType dest_lvl ty+  = do { cur_lvl <- getTcLevel+       ; if (cur_lvl `sameDepthAs` dest_lvl)+         then dont_promote_it+         else promote_it }+  where+    promote_it :: TcM (TcCoercion, TcType)+    promote_it  -- Emit a constraint  (alpha :: TYPE rr) ~ ty+                -- where alpha and rr are fresh and from level dest_lvl+      = do { rr      <- newMetaTyVarTyAtLevel dest_lvl runtimeRepTy+           ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (tYPE rr)+           ; let eq_orig = TypeEqOrigin { uo_actual   = ty+                                        , uo_expected = prom_ty+                                        , uo_thing    = Nothing }++           ; co <- emitWantedEq eq_orig TypeLevel Nominal ty prom_ty+           ; return (co, prom_ty) }++    dont_promote_it :: TcM (TcCoercion, TcType)+    dont_promote_it  -- Check that ty :: TYPE rr, for some (fresh) rr+      = do { res_kind <- newOpenTypeKind+           ; let ty_kind = typeKind ty+                 kind_orig = TypeEqOrigin { uo_actual   = ty_kind+                                          , uo_expected = res_kind+                                          , uo_thing    = Nothing }+           ; ki_co <- uType kind_orig KindLevel (typeKind ty) res_kind+           ; let co = mkTcNomReflCo ty `mkTcCoherenceRightCo` ki_co+           ; return (co, ty `mkCastTy` ki_co) }++{- Note [Promoting a type]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (Trac #12427)++  data T where+    MkT :: (Int -> Int) -> a -> T++  h y = case y of MkT v w -> v++We'll infer the RHS type with an expected type ExpType of+  (IR { ir_lvl = l, ir_ref = ref, ... )+where 'l' is the TcLevel of the RHS of 'h'.  Then the MkT pattern+match will increase the level, so we'll end up in tcSubType, trying to+unify the type of v,+  v :: Int -> Int+with the expected type.  But this attempt takes place at level (l+1),+rightly so, since v's type could have mentioned existential variables,+(like w's does) and we want to catch that.++So we+  - create a new meta-var alpha[l+1]+  - fill in the InferRes ref cell 'ref' with alpha+  - emit an equality constraint, thus+        [W] alpha[l+1] ~ (Int -> Int)++That constraint will float outwards, as it should, unless v's+type mentions a skolem-captured variable.++This approach fails if v has a higher rank type; see+Note [Promotion and higher rank types]+++Note [Promotion and higher rank types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If v had a higher-rank type, say v :: (forall a. a->a) -> Int,+then we'd emit an equality+        [W] alpha[l+1] ~ ((forall a. a->a) -> Int)+which will sadly fail because we can't unify a unification variable+with a polytype.  But there is nothing really wrong with the program+here.++We could just about solve this by "promote the type" of v, to expose+its polymorphic "shape" while still leaving constraints that will+prevent existential escape.  But we must be careful!  Exposing+the "shape" of the type is precisely what we must NOT do under+a GADT pattern match!  So in this case we might promote the type+to+        (forall a. a->a) -> alpha[l+1]+and emit the constraint+        [W] alpha[l+1] ~ Int+Now the poromoted type can fill the ref cell, while the emitted+equality can float or not, according to the usual rules.++But that's not quite right!  We are exposing the arrow! We could+deal with that too:+        (forall a. mu[l+1] a a) -> alpha[l+1]+with constraints+        [W] alpha[l+1] ~ Int+        [W] mu[l+1] ~ (->)+Here we abstract over the '->' inside the forall, in case that+is subject to an equality constraint from a GADT match.++Note that we kept the outer (->) because that's part of+the polymorphic "shape".  And becauuse of impredicativity,+GADT matches can't give equalities that affect polymorphic+shape.++This reasoning just seems too complicated, so I decided not+to do it.  These higher-rank notes are just here to record+the thinking.+-}++{- *********************************************************************+*                                                                      *+                    Generalisation+*                                                                      *+********************************************************************* -}++-- | Take an "expected type" and strip off quantifiers to expose the+-- type underneath, binding the new skolems for the @thing_inside@.+-- The returned 'HsWrapper' has type @specific_ty -> expected_ty@.+tcSkolemise :: UserTypeCtxt -> TcSigmaType+            -> ([TcTyVar] -> TcType -> TcM result)+         -- ^ These are only ever used for scoped type variables.+            -> TcM (HsWrapper, result)+        -- ^ The expression has type: spec_ty -> expected_ty++tcSkolemise ctxt expected_ty thing_inside+   -- We expect expected_ty to be a forall-type+   -- If not, the call is a no-op+  = do  { traceTc "tcSkolemise" Outputable.empty+        ; (wrap, tv_prs, given, rho') <- deeplySkolemise expected_ty++        ; lvl <- getTcLevel+        ; when debugIsOn $+              traceTc "tcSkolemise" $ vcat [+                ppr lvl,+                text "expected_ty" <+> ppr expected_ty,+                text "inst tyvars" <+> ppr tv_prs,+                text "given"       <+> ppr given,+                text "inst type"   <+> ppr rho' ]++        -- Generally we must check that the "forall_tvs" havn't been constrained+        -- The interesting bit here is that we must include the free variables+        -- of the expected_ty.  Here's an example:+        --       runST (newVar True)+        -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))+        -- for (newVar True), with s fresh.  Then we unify with the runST's arg type+        -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.+        -- So now s' isn't unconstrained because it's linked to a.+        --+        -- However [Oct 10] now that the untouchables are a range of+        -- TcTyVars, all this is handled automatically with no need for+        -- extra faffing around++        ; let tvs' = map snd tv_prs+              skol_info = SigSkol ctxt expected_ty tv_prs++        ; (ev_binds, result) <- checkConstraints skol_info tvs' given $+                                thing_inside tvs' rho'++        ; return (wrap <.> mkWpLet ev_binds, result) }+          -- The ev_binds returned by checkConstraints is very+          -- often empty, in which case mkWpLet is a no-op++-- | Variant of 'tcSkolemise' that takes an ExpType+tcSkolemiseET :: UserTypeCtxt -> ExpSigmaType+              -> (ExpRhoType -> TcM result)+              -> TcM (HsWrapper, result)+tcSkolemiseET _ et@(Infer {}) thing_inside+  = (idHsWrapper, ) <$> thing_inside et+tcSkolemiseET ctxt (Check ty) thing_inside+  = tcSkolemise ctxt ty $ \_ -> thing_inside . mkCheckExpType++checkConstraints :: SkolemInfo+                 -> [TcTyVar]           -- Skolems+                 -> [EvVar]             -- Given+                 -> TcM result+                 -> TcM (TcEvBinds, result)++checkConstraints skol_info skol_tvs given thing_inside+  = do { (implics, ev_binds, result)+            <- buildImplication skol_info skol_tvs given thing_inside+       ; emitImplications implics+       ; return (ev_binds, result) }++buildImplication :: SkolemInfo+                 -> [TcTyVar]           -- Skolems+                 -> [EvVar]             -- Given+                 -> TcM result+                 -> TcM (Bag Implication, TcEvBinds, result)+buildImplication skol_info skol_tvs given thing_inside+  = do { tc_lvl <- getTcLevel+       ; deferred_type_errors <- goptM Opt_DeferTypeErrors <||>+                                 goptM Opt_DeferTypedHoles+       ; if null skol_tvs && null given && (not deferred_type_errors ||+                                            not (isTopTcLevel tc_lvl))+         then do { res <- thing_inside+                 ; return (emptyBag, emptyTcEvBinds, res) }+      -- Fast path.  We check every function argument with+      -- tcPolyExpr, which uses tcSkolemise and hence checkConstraints.+      -- But with the solver producing unlifted equalities, we need+      -- to have an EvBindsVar for them when they might be deferred to+      -- runtime. Otherwise, they end up as top-level unlifted bindings,+      -- which are verboten. See also Note [Deferred errors for coercion holes]+      -- in TcErrors.+         else+    do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside+       ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_tvs given wanted+       ; return (implics, ev_binds, result) }}++buildImplicationFor :: TcLevel -> SkolemInfo -> [TcTyVar]+                   -> [EvVar] -> WantedConstraints+                   -> TcM (Bag Implication, TcEvBinds)+buildImplicationFor tclvl skol_info skol_tvs given wanted+  | isEmptyWC wanted && null given+             -- Optimisation : if there are no wanteds, and no givens+             -- don't generate an implication at all.+             -- Reason for the (null given): we don't want to lose+             -- the "inaccessible alternative" error check+  = return (emptyBag, emptyTcEvBinds)++  | otherwise+  = ASSERT2( all isSkolemTyVar skol_tvs, ppr skol_tvs )+    do { ev_binds_var <- newTcEvBinds+       ; env <- getLclEnv+       ; let implic = Implic { ic_tclvl = tclvl+                             , ic_skols = skol_tvs+                             , ic_no_eqs = False+                             , ic_given = given+                             , ic_wanted = wanted+                             , ic_status  = IC_Unsolved+                             , ic_binds = ev_binds_var+                             , ic_env = env+                             , ic_needed = emptyVarSet+                             , ic_info = skol_info }++       ; return (unitBag implic, TcEvBinds ev_binds_var) }++{-+************************************************************************+*                                                                      *+                Boxy unification+*                                                                      *+************************************************************************++The exported functions are all defined as versions of some+non-exported generic functions.+-}++unifyType :: Outputable a => Maybe a   -- ^ If present, has type 'ty1'+          -> TcTauType -> TcTauType -> TcM TcCoercionN+-- Actual and expected types+-- Returns a coercion : ty1 ~ ty2+unifyType thing ty1 ty2 = uType origin TypeLevel ty1 ty2+  where+    origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2+                          , uo_thing  = mkErrorThing <$> thing }++-- | Use this instead of 'Nothing' when calling 'unifyType' without+-- a good "thing" (where the "thing" has the "actual" type passed in)+-- This has an 'Outputable' instance, avoiding amgiguity problems.+noThing :: Maybe (HsExpr Name)+noThing = Nothing++unifyKind :: Outputable a => Maybe a -> TcKind -> TcKind -> TcM CoercionN+unifyKind thing ty1 ty2 = uType origin KindLevel ty1 ty2+  where origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2+                              , uo_thing  = mkErrorThing <$> thing }++---------------+unifyPred :: PredType -> PredType -> TcM TcCoercionN+-- Actual and expected types+unifyPred = unifyType noThing++---------------+unifyTheta :: TcThetaType -> TcThetaType -> TcM [TcCoercionN]+-- Actual and expected types+unifyTheta theta1 theta2+  = do  { checkTc (equalLength theta1 theta2)+                  (vcat [text "Contexts differ in length",+                         nest 2 $ parens $ text "Use RelaxedPolyRec to allow this"])+        ; zipWithM unifyPred theta1 theta2 }++{-+%************************************************************************+%*                                                                      *+                 uType and friends+%*                                                                      *+%************************************************************************++uType is the heart of the unifier.+-}++uType, uType_defer+  :: CtOrigin+  -> TypeOrKind+  -> TcType    -- ty1 is the *actual* type+  -> TcType    -- ty2 is the *expected* type+  -> TcM Coercion++--------------+-- It is always safe to defer unification to the main constraint solver+-- See Note [Deferred unification]+uType_defer origin t_or_k ty1 ty2+  = do { co <- emitWantedEq origin t_or_k Nominal ty1 ty2++       -- Error trace only+       -- NB. do *not* call mkErrInfo unless tracing is on,+       --     because it is hugely expensive (#5631)+       ; whenDOptM Opt_D_dump_tc_trace $ do+            { ctxt <- getErrCtxt+            ; doc <- mkErrInfo emptyTidyEnv ctxt+            ; traceTc "utype_defer" (vcat [ppr co, ppr ty1,+                                           ppr ty2, pprCtOrigin origin, doc])+            }+       ; return co }++--------------+uType origin t_or_k orig_ty1 orig_ty2+  = do { tclvl <- getTcLevel+       ; traceTc "u_tys" $ vcat+              [ text "tclvl" <+> ppr tclvl+              , sep [ ppr orig_ty1, text "~", ppr orig_ty2]+              , pprCtOrigin origin]+       ; co <- go orig_ty1 orig_ty2+       ; if isReflCo co+            then traceTc "u_tys yields no coercion" Outputable.empty+            else traceTc "u_tys yields coercion:" (ppr co)+       ; return co }+  where+    go :: TcType -> TcType -> TcM Coercion+        -- The arguments to 'go' are always semantically identical+        -- to orig_ty{1,2} except for looking through type synonyms++        -- Variables; go for uVar+        -- Note that we pass in *original* (before synonym expansion),+        -- so that type variables tend to get filled in with+        -- the most informative version of the type+    go (TyVarTy tv1) ty2+      = do { lookup_res <- lookupTcTyVar tv1+           ; case lookup_res of+               Filled ty1   -> do { traceTc "found filled tyvar" (ppr tv1 <+> text ":->" <+> ppr ty1)+                                  ; go ty1 ty2 }+               Unfilled _ -> uUnfilledVar origin t_or_k NotSwapped tv1 ty2 }+    go ty1 (TyVarTy tv2)+      = do { lookup_res <- lookupTcTyVar tv2+           ; case lookup_res of+               Filled ty2   -> do { traceTc "found filled tyvar" (ppr tv2 <+> text ":->" <+> ppr ty2)+                                  ; go ty1 ty2 }+               Unfilled _ -> uUnfilledVar origin t_or_k IsSwapped tv2 ty1 }++      -- See Note [Expanding synonyms during unification]+    go ty1@(TyConApp tc1 []) (TyConApp tc2 [])+      | tc1 == tc2+      = return $ mkReflCo Nominal ty1++        -- See Note [Expanding synonyms during unification]+        --+        -- Also NB that we recurse to 'go' so that we don't push a+        -- new item on the origin stack. As a result if we have+        --   type Foo = Int+        -- and we try to unify  Foo ~ Bool+        -- we'll end up saying "can't match Foo with Bool"+        -- rather than "can't match "Int with Bool".  See Trac #4535.+    go ty1 ty2+      | Just ty1' <- tcView ty1 = go ty1' ty2+      | Just ty2' <- tcView ty2 = go ty1  ty2'++    go (CastTy t1 co1) t2+      = do { co_tys <- go t1 t2+           ; return (mkCoherenceLeftCo co_tys co1) }++    go t1 (CastTy t2 co2)+      = do { co_tys <- go t1 t2+           ; return (mkCoherenceRightCo co_tys co2) }++        -- Functions (or predicate functions) just check the two parts+    go (FunTy fun1 arg1) (FunTy fun2 arg2)+      = do { co_l <- uType origin t_or_k fun1 fun2+           ; co_r <- uType origin t_or_k arg1 arg2+           ; return $ mkFunCo Nominal co_l co_r }++        -- Always defer if a type synonym family (type function)+        -- is involved.  (Data families behave rigidly.)+    go ty1@(TyConApp tc1 _) ty2+      | isTypeFamilyTyCon tc1 = defer ty1 ty2+    go ty1 ty2@(TyConApp tc2 _)+      | isTypeFamilyTyCon tc2 = defer ty1 ty2++    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)+      -- See Note [Mismatched type lists and application decomposition]+      | tc1 == tc2, length tys1 == length tys2+      = ASSERT2( isGenerativeTyCon tc1 Nominal, ppr tc1 )+        do { cos <- zipWithM (uType origin t_or_k) tys1 tys2+           ; return $ mkTyConAppCo Nominal tc1 cos }++    go (LitTy m) ty@(LitTy n)+      | m == n+      = return $ mkNomReflCo ty++        -- See Note [Care with type applications]+        -- Do not decompose FunTy against App;+        -- it's often a type error, so leave it for the constraint solver+    go (AppTy s1 t1) (AppTy s2 t2)+      = go_app s1 t1 s2 t2++    go (AppTy s1 t1) (TyConApp tc2 ts2)+      | Just (ts2', t2') <- snocView ts2+      = ASSERT( mightBeUnsaturatedTyCon tc2 )+        go_app s1 t1 (TyConApp tc2 ts2') t2'++    go (TyConApp tc1 ts1) (AppTy s2 t2)+      | Just (ts1', t1') <- snocView ts1+      = ASSERT( mightBeUnsaturatedTyCon tc1 )+        go_app (TyConApp tc1 ts1') t1' s2 t2++    go (CoercionTy co1) (CoercionTy co2)+      = do { let ty1 = coercionType co1+                 ty2 = coercionType co2+           ; kco <- uType (KindEqOrigin orig_ty1 (Just orig_ty2) origin+                                        (Just t_or_k))+                          KindLevel+                          ty1 ty2+           ; return $ mkProofIrrelCo Nominal kco co1 co2 }++        -- Anything else fails+        -- E.g. unifying for-all types, which is relative unusual+    go ty1 ty2 = defer ty1 ty2++    ------------------+    defer ty1 ty2   -- See Note [Check for equality before deferring]+      | ty1 `tcEqType` ty2 = return (mkNomReflCo ty1)+      | otherwise          = uType_defer origin t_or_k ty1 ty2++    ------------------+    go_app s1 t1 s2 t2+      = do { co_s <- uType origin t_or_k s1 s2+           ; co_t <- uType origin t_or_k t1 t2+           ; return $ mkAppCo co_s co_t }++{- Note [Check for equality before deferring]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Particularly in ambiguity checks we can get equalities like (ty ~ ty).+If ty involves a type function we may defer, which isn't very sensible.+An egregious example of this was in test T9872a, which has a type signature+       Proxy :: Proxy (Solutions Cubes)+Doing the ambiguity check on this signature generates the equality+   Solutions Cubes ~ Solutions Cubes+and currently the constraint solver normalises both sides at vast cost.+This little short-cut in 'defer' helps quite a bit.++Note [Care with type applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note: type applications need a bit of care!+They can match FunTy and TyConApp, so use splitAppTy_maybe+NB: we've already dealt with type variables and Notes,+so if one type is an App the other one jolly well better be too++Note [Mismatched type lists and application decomposition]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we find two TyConApps, you might think that the argument lists+are guaranteed equal length.  But they aren't. Consider matching+        w (T x) ~ Foo (T x y)+We do match (w ~ Foo) first, but in some circumstances we simply create+a deferred constraint; and then go ahead and match (T x ~ T x y).+This came up in Trac #3950.++So either+   (a) either we must check for identical argument kinds+       when decomposing applications,++   (b) or we must be prepared for ill-kinded unification sub-problems++Currently we adopt (b) since it seems more robust -- no need to maintain+a global invariant.++Note [Expanding synonyms during unification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We expand synonyms during unification, but:+ * We expand *after* the variable case so that we tend to unify+   variables with un-expanded type synonym. This just makes it+   more likely that the inferred types will mention type synonyms+   understandable to the user++ * We expand *before* the TyConApp case.  For example, if we have+      type Phantom a = Int+   and are unifying+      Phantom Int ~ Phantom Char+   it is *wrong* to unify Int and Char.++ * The problem case immediately above can happen only with arguments+   to the tycon. So we check for nullary tycons *before* expanding.+   This is particularly helpful when checking (* ~ *), because * is+   now a type synonym.++Note [Deferred Unification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We may encounter a unification ty1 ~ ty2 that cannot be performed syntactically,+and yet its consistency is undetermined. Previously, there was no way to still+make it consistent. So a mismatch error was issued.++Now these unifications are deferred until constraint simplification, where type+family instances and given equations may (or may not) establish the consistency.+Deferred unifications are of the form+                F ... ~ ...+or              x ~ ...+where F is a type function and x is a type variable.+E.g.+        id :: x ~ y => x -> y+        id e = e++involves the unification x = y. It is deferred until we bring into account the+context x ~ y to establish that it holds.++If available, we defer original types (rather than those where closed type+synonyms have already been expanded via tcCoreView).  This is, as usual, to+improve error messages.+++************************************************************************+*                                                                      *+                 uVar and friends+*                                                                      *+************************************************************************++@uVar@ is called when at least one of the types being unified is a+variable.  It does {\em not} assume that the variable is a fixed point+of the substitution; rather, notice that @uVar@ (defined below) nips+back into @uTys@ if it turns out that the variable is already bound.+-}++----------+uUnfilledVar :: CtOrigin+             -> TypeOrKind+             -> SwapFlag+             -> TcTyVar        -- Tyvar 1+             -> TcTauType      -- Type 2+             -> TcM Coercion+-- "Unfilled" means that the variable is definitely not a filled-in meta tyvar+--            It might be a skolem, or untouchable, or meta++uUnfilledVar origin t_or_k swapped tv1 ty2+  = do { ty2 <- zonkTcType ty2+             -- Zonk to expose things to the+             -- occurs check, and so that if ty2+             -- looks like a type variable then it+             -- /is/ a type variable+       ; uUnfilledVar1 origin t_or_k swapped tv1 ty2 }++----------+uUnfilledVar1 :: CtOrigin+              -> TypeOrKind+              -> SwapFlag+              -> TcTyVar        -- Tyvar 1+              -> TcTauType      -- Type 2, zonked+              -> TcM Coercion+uUnfilledVar1 origin t_or_k swapped tv1 ty2+  | Just tv2 <- tcGetTyVar_maybe ty2+  = go tv2++  | otherwise+  = uUnfilledVar2 origin t_or_k swapped tv1 ty2++  where+    -- 'go' handles the case where both are+    -- tyvars so we might want to swap+    go tv2 | tv1 == tv2  -- Same type variable => no-op+           = return (mkNomReflCo (mkTyVarTy tv1))++           | swapOverTyVars tv1 tv2   -- Distinct type variables+           = uUnfilledVar2 origin t_or_k (flipSwap swapped)+                           tv2 (mkTyVarTy tv1)++           | otherwise+           = uUnfilledVar2 origin t_or_k swapped tv1 ty2++----------+uUnfilledVar2 :: CtOrigin+              -> TypeOrKind+              -> SwapFlag+              -> TcTyVar        -- Tyvar 1+              -> TcTauType      -- Type 2, zonked+              -> TcM Coercion+uUnfilledVar2 origin t_or_k swapped tv1 ty2+  = do { dflags  <- getDynFlags+       ; cur_lvl <- getTcLevel+       ; go dflags cur_lvl }+  where+    go dflags cur_lvl+      | canSolveByUnification cur_lvl tv1 ty2+      , Just ty2' <- metaTyVarUpdateOK dflags tv1 ty2+      = do { co_k <- uType kind_origin KindLevel (typeKind ty2') (tyVarKind tv1)+           ; co   <- updateMeta tv1 ty2' co_k+           ; return (maybe_sym swapped co) }++      | otherwise+      = unSwap swapped (uType_defer origin t_or_k) ty1 ty2+               -- Occurs check or an untouchable: just defer+               -- NB: occurs check isn't necessarily fatal:+               --     eg tv1 occured in type family parameter++    ty1 = mkTyVarTy tv1+    kind_origin = KindEqOrigin ty1 (Just ty2) origin (Just t_or_k)++-- | apply sym iff swapped+maybe_sym :: SwapFlag -> Coercion -> Coercion+maybe_sym IsSwapped  = mkSymCo+maybe_sym NotSwapped = id++swapOverTyVars :: TcTyVar -> TcTyVar -> Bool+swapOverTyVars tv1 tv2+  | isFmvTyVar tv1 = False  -- See Note [Fmv Orientation Invariant]+  | isFmvTyVar tv2 = True++  | Just lvl1 <- metaTyVarTcLevel_maybe tv1+      -- If tv1 is touchable, swap only if tv2 is also+      -- touchable and it's strictly better to update the latter+      -- But see Note [Avoid unnecessary swaps]+  = case metaTyVarTcLevel_maybe tv2 of+      Nothing   -> False+      Just lvl2 | lvl2 `strictlyDeeperThan` lvl1 -> True+                | lvl1 `strictlyDeeperThan` lvl2 -> False+                | otherwise                      -> nicer_to_update tv2++  -- So tv1 is not a meta tyvar+  -- If only one is a meta tyvar, put it on the left+  -- This is not because it'll be solved; but because+  -- the floating step looks for meta tyvars on the left+  | isMetaTyVar tv2 = True++  -- So neither is a meta tyvar (including FlatMetaTv)++  -- If only one is a flatten skolem, put it on the left+  -- See Note [Eliminate flat-skols]+  | not (isFlattenTyVar tv1), isFlattenTyVar tv2 = True++  | otherwise = False++  where+    nicer_to_update tv2+      =  (isSigTyVar tv1                 && not (isSigTyVar tv2))+      || (isSystemName (Var.varName tv2) && not (isSystemName (Var.varName tv1)))++-- @trySpontaneousSolve wi@ solves equalities where one side is a+-- touchable unification variable.+-- Returns True <=> spontaneous solve happened+canSolveByUnification :: TcLevel -> TcTyVar -> TcType -> Bool+canSolveByUnification tclvl tv xi+  | isTouchableMetaTyVar tclvl tv+  = case metaTyVarInfo tv of+      SigTv -> is_tyvar xi+      _     -> True++  | otherwise    -- Untouchable+  = False+  where+    is_tyvar xi+      = case tcGetTyVar_maybe xi of+          Nothing -> False+          Just tv -> case tcTyVarDetails tv of+                       MetaTv { mtv_info = info }+                                   -> case info of+                                        SigTv -> True+                                        _     -> False+                       SkolemTv {} -> True+                       FlatSkol {} -> False+                       RuntimeUnk  -> True++{- Note [Fmv Orientation Invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+   * We always orient a constraint+        fmv ~ alpha+     with fmv on the left, even if alpha is+     a touchable unification variable++Reason: doing it the other way round would unify alpha:=fmv, but that+really doesn't add any info to alpha.  But a later constraint alpha ~+Int might unlock everything.  Comment:9 of #12526 gives a detailed+example.++WARNING: I've gone to and fro on this one several times.+I'm now pretty sure that unifying alpha:=fmv is a bad idea!+So orienting with fmvs on the left is a good thing.++This example comes from IndTypesPerfMerge. (Others include+T10226, T10009.)+    From the ambiguity check for+      f :: (F a ~ a) => a+    we get:+          [G] F a ~ a+          [WD] F alpha ~ alpha, alpha ~ a++    From Givens we get+          [G] F a ~ fsk, fsk ~ a++    Now if we flatten we get+          [WD] alpha ~ fmv, F alpha ~ fmv, alpha ~ a++    Now, if we unified alpha := fmv, we'd get+          [WD] F fmv ~ fmv, [WD] fmv ~ a+    And now we are stuck.++So instead the Fmv Orientation Invariant puts te fmv on the+left, giving+      [WD] fmv ~ alpha, [WD] F alpha ~ fmv, [WD] alpha ~ a++    Now we get alpha:=a, and everything works out++Note [Prevent unification with type families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We prevent unification with type families because of an uneasy compromise.+It's perfectly sound to unify with type families, and it even improves the+error messages in the testsuite. It also modestly improves performance, at+least in some cases. But it's disastrous for test case perf/compiler/T3064.+Here is the problem: Suppose we have (F ty) where we also have [G] F ty ~ a.+What do we do? Do we reduce F? Or do we use the given? Hard to know what's+best. GHC reduces. This is a disaster for T3064, where the type's size+spirals out of control during reduction. (We're not helped by the fact that+the flattener re-flattens all the arguments every time around.) If we prevent+unification with type families, then the solver happens to use the equality+before expanding the type family.++It would be lovely in the future to revisit this problem and remove this+extra, unnecessary check. But we retain it for now as it seems to work+better in practice.++Note [Refactoring hazard: checkTauTvUpdate]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+I (Richard E.) have a sad story about refactoring this code, retained here+to prevent others (or a future me!) from falling into the same traps.++It all started with #11407, which was caused by the fact that the TyVarTy+case of defer_me didn't look in the kind. But it seemed reasonable to+simply remove the defer_me check instead.++It referred to two Notes (since removed) that were out of date, and the+fast_check code in occurCheckExpand seemed to do just about the same thing as+defer_me. The one piece that defer_me did that wasn't repeated by+occurCheckExpand was the type-family check. (See Note [Prevent unification+with type families].) So I checked the result of occurCheckExpand for any+type family occurrences and deferred if there were any. This was done+in commit e9bf7bb5cc9fb3f87dd05111aa23da76b86a8967 .++This approach turned out not to be performant, because the expanded+type was bigger than the original type, and tyConsOfType (needed to+see if there are any type family occurrences) looks through type+synonyms. So it then struck me that we could dispense with the+defer_me check entirely. This simplified the code nicely, and it cut+the allocations in T5030 by half. But, as documented in Note [Prevent+unification with type families], this destroyed performance in+T3064. Regardless, I missed this regression and the change was+committed as 3f5d1a13f112f34d992f6b74656d64d95a3f506d .++Bottom lines:+ * defer_me is back, but now fixed w.r.t. #11407.+ * Tread carefully before you start to refactor here. There can be+   lots of hard-to-predict consequences.++Note [Type synonyms and the occur check]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generally speaking we try to update a variable with type synonyms not+expanded, which improves later error messages, unless looking+inside a type synonym may help resolve a spurious occurs check+error. Consider:+          type A a = ()++          f :: (A a -> a -> ()) -> ()+          f = \ _ -> ()++          x :: ()+          x = f (\ x p -> p x)++We will eventually get a constraint of the form t ~ A t. The ok function above will+properly expand the type (A t) to just (), which is ok to be unified with t. If we had+unified with the original type A t, we would lead the type checker into an infinite loop.++Hence, if the occurs check fails for a type synonym application, then (and *only* then),+the ok function expands the synonym to detect opportunities for occurs check success using+the underlying definition of the type synonym.++The same applies later on in the constraint interaction code; see TcInteract,+function @occ_check_ok@.++Note [Non-TcTyVars in TcUnify]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Because the same code is now shared between unifying types and unifying+kinds, we sometimes will see proper TyVars floating around the unifier.+Example (from test case polykinds/PolyKinds12):++    type family Apply (f :: k1 -> k2) (x :: k1) :: k2+    type instance Apply g y = g y++When checking the instance declaration, we first *kind-check* the LHS+and RHS, discovering that the instance really should be++    type instance Apply k3 k4 (g :: k3 -> k4) (y :: k3) = g y++During this kind-checking, all the tyvars will be TcTyVars. Then, however,+as a second pass, we desugar the RHS (which is done in functions prefixed+with "tc" in TcTyClsDecls"). By this time, all the kind-vars are proper+TyVars, not TcTyVars, get some kind unification must happen.++Thus, we always check if a TyVar is a TcTyVar before asking if it's a+meta-tyvar.++This used to not be necessary for type-checking (that is, before * :: *)+because expressions get desugared via an algorithm separate from+type-checking (with wrappers, etc.). Types get desugared very differently,+causing this wibble in behavior seen here.+-}++data LookupTyVarResult  -- The result of a lookupTcTyVar call+  = Unfilled TcTyVarDetails     -- SkolemTv or virgin MetaTv+  | Filled   TcType++lookupTcTyVar :: TcTyVar -> TcM LookupTyVarResult+lookupTcTyVar tyvar+  | MetaTv { mtv_ref = ref } <- details+  = do { meta_details <- readMutVar ref+       ; case meta_details of+           Indirect ty -> return (Filled ty)+           Flexi -> do { is_touchable <- isTouchableTcM tyvar+                             -- Note [Unifying untouchables]+                       ; if is_touchable then+                            return (Unfilled details)+                         else+                            return (Unfilled vanillaSkolemTv) } }+  | otherwise+  = return (Unfilled details)+  where+    details = tcTyVarDetails tyvar++-- | Fill in a meta-tyvar+updateMeta :: TcTyVar            -- ^ tv to fill in, tv :: k1+           -> TcType             -- ^ ty2 :: k2+           -> Coercion           -- ^ kind_co :: k2 ~N k1+           -> TcM Coercion       -- ^ :: tv ~N ty2 (= ty2 |> kind_co ~N ty2)+updateMeta tv1 ty2 kind_co+  = do { let ty2'     = ty2 `mkCastTy` kind_co+             ty2_refl = mkNomReflCo ty2+             co       = mkCoherenceLeftCo ty2_refl kind_co+       ; writeMetaTyVar tv1 ty2'+       ; return co }++{-+Note [Unifying untouchables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We treat an untouchable type variable as if it was a skolem.  That+ensures it won't unify with anything.  It's a slight had, because+we return a made-up TcTyVarDetails, but I think it works smoothly.+-}++-- | Breaks apart a function kind into its pieces.+matchExpectedFunKind :: Arity           -- ^ # of args remaining, only for errors+                     -> TcType          -- ^ type, only for errors+                     -> TcKind          -- ^ function kind+                     -> TcM (Coercion, TcKind, TcKind)+                                  -- ^ co :: old_kind ~ arg -> res+matchExpectedFunKind num_args_remaining ty = go+  where+    go k | Just k' <- tcView k = go k'++    go k@(TyVarTy kvar)+      | isTcTyVar kvar, isMetaTyVar kvar+      = do { maybe_kind <- readMetaTyVar kvar+           ; case maybe_kind of+                Indirect fun_kind -> go fun_kind+                Flexi ->             defer k }++    go k@(FunTy arg res) = return (mkNomReflCo k, arg, res)+    go other             = defer other++    defer k+      = do { arg_kind <- newMetaKindVar+           ; res_kind <- newMetaKindVar+           ; let new_fun = mkFunTy arg_kind res_kind+                 thing   = mkTypeErrorThingArgs ty num_args_remaining+                 origin  = TypeEqOrigin { uo_actual   = k+                                        , uo_expected = new_fun+                                        , uo_thing    = Just thing+                                        }+           ; co <- uType origin KindLevel k new_fun+           ; return (co, arg_kind, res_kind) }+++{- *********************************************************************+*                                                                      *+                 Occurrence checking+*                                                                      *+********************************************************************* -}+++{- Note [Occurs check expansion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(occurCheckExpand tv xi) expands synonyms in xi just enough to get rid+of occurrences of tv outside type function arguments, if that is+possible; otherwise, it returns Nothing.++For example, suppose we have+  type F a b = [a]+Then+  occCheckExpand b (F Int b) = Just [Int]+but+  occCheckExpand a (F a Int) = Nothing++We don't promise to do the absolute minimum amount of expanding+necessary, but we try not to do expansions we don't need to.  We+prefer doing inner expansions first.  For example,+  type F a b = (a, Int, a, [a])+  type G b   = Char+We have+  occCheckExpand b (F (G b)) = Just (F Char)+even though we could also expand F to get rid of b.++The two variants of the function are to support TcUnify.checkTauTvUpdate,+which wants to prevent unification with type families. For more on this+point, see Note [Prevent unification with type families] in TcUnify.++Note [Occurrence checking: look inside kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we are considering unifying+   (alpha :: *)  ~  Int -> (beta :: alpha -> alpha)+This may be an error (what is that alpha doing inside beta's kind?),+but we must not make the mistake of actuallyy unifying or we'll+build an infinite data structure.  So when looking for occurrences+of alpha in the rhs, we must look in the kinds of type variables+that occur there.++NB: we may be able to remove the problem via expansion; see+    Note [Occurs check expansion].  So we have to try that.++Note [Checking for foralls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Unless we have -XImpredicativeTypes (which is a totally unsupported+feature), we do not want to unify+    alpha ~ (forall a. a->a) -> Int+So we look for foralls hidden inside the type, and it's convenient+to do that at the same time as the occurs check (which looks for+occurrences of alpha).++However, it's not just a question of looking for foralls /anywhere/!+Consider+   (alpha :: forall k. k->*)  ~  (beta :: forall k. k->*)+This is legal; e.g. dependent/should_compile/T11635.++We don't want to reject it because of the forall in beta's kind,+but (see Note [Occurrence checking: look inside kinds]) we do+need to look in beta's kind.  So we carry a flag saying if a 'forall'+is OK, and sitch the flag on when stepping inside a kind.++Why is it OK?  Why does it not count as impredicative polymorphism?+The reason foralls are bad is because we reply on "seeing" foralls+when doing implicit instantiation.  But the forall inside the kind is+fine.  We'll generate a kind equality constraint+  (forall k. k->*) ~ (forall k. k->*)+to check that the kinds of lhs and rhs are compatible.  If alpha's+kind had instead been+  (alpha :: kappa)+then this kind equality would rightly complain about unifying kappa+with (forall k. k->*)++-}++data OccCheckResult a+  = OC_OK a+  | OC_Bad     -- Forall or type family+  | OC_Occurs++instance Functor OccCheckResult where+      fmap = liftM++instance Applicative OccCheckResult where+      pure = OC_OK+      (<*>) = ap++instance Monad OccCheckResult where+  OC_OK x    >>= k = k x+  OC_Bad     >>= _ = OC_Bad+  OC_Occurs  >>= _ = OC_Occurs++occCheckForErrors :: DynFlags -> TcTyVar -> Type -> OccCheckResult ()+-- Just for error-message generation; so we return OccCheckResult+-- so the caller can report the right kind of error+-- Check whether+--   a) the given variable occurs in the given type.+--   b) there is a forall in the type (unless we have -XImpredicativeTypes)+occCheckForErrors dflags tv ty+  = case preCheck dflags True tv ty of+      OC_OK _   -> OC_OK ()+      OC_Bad    -> OC_Bad+      OC_Occurs -> case occCheckExpand tv ty of+                     Nothing -> OC_Occurs+                     Just _  -> OC_OK ()++----------------+metaTyVarUpdateOK :: DynFlags+                  -> TcTyVar             -- tv :: k1+                  -> TcType              -- ty :: k2+                  -> Maybe TcType        -- possibly-expanded ty+-- (metaTyFVarUpdateOK tv ty)+-- We are about to update the meta-tyvar tv with ty+-- Check (a) that tv doesn't occur in ty (occurs check)+--       (b) that ty does not have any foralls+--           (in the impredicative case), or type functions+--+-- We have two possible outcomes:+-- (1) Return the type to update the type variable with,+--        [we know the update is ok]+-- (2) Return Nothing,+--        [the update might be dodgy]+--+-- Note that "Nothing" does not mean "definite error".  For example+--   type family F a+--   type instance F Int = Int+-- consider+--   a ~ F a+-- This is perfectly reasonable, if we later get a ~ Int.  For now, though,+-- we return Nothing, leaving it to the later constraint simplifier to+-- sort matters out.+--+-- See Note [Refactoring hazard: checkTauTvUpdate]++metaTyVarUpdateOK dflags tv ty+  = case preCheck dflags False tv ty of+         -- False <=> type families not ok+         -- See Note [Prevent unification with type families]+      OC_OK _   -> Just ty+      OC_Bad    -> Nothing  -- forall or type function+      OC_Occurs -> occCheckExpand tv ty++preCheck :: DynFlags -> Bool -> TcTyVar -> TcType -> OccCheckResult ()+-- A quick check for+--   (a) a forall type (unless -XImpredivativeTypes)+--   (b) a type family+--   (c) an occurrence of the type variable (occurs check)+--+-- For (a) and (b) we check only the top level of the type, NOT+-- inside the kinds of variables it mentions.  But for (c) we do+-- look in the kinds of course.++preCheck dflags ty_fam_ok tv ty+  = fast_check ty+  where+    details          = tcTyVarDetails tv+    impredicative_ok = canUnifyWithPolyType dflags details++    ok :: OccCheckResult ()+    ok = OC_OK ()++    fast_check :: TcType -> OccCheckResult ()+    fast_check (TyVarTy tv')+      | tv == tv' = OC_Occurs+      | otherwise = fast_check_occ (tyVarKind tv')+           -- See Note [Occurrence checking: look inside kinds]++    fast_check (TyConApp tc tys)+      | bad_tc tc              = OC_Bad+      | otherwise              = mapM fast_check tys >> ok+    fast_check (LitTy {})      = ok+    fast_check (FunTy a r)     = fast_check a   >> fast_check r+    fast_check (AppTy fun arg) = fast_check fun >> fast_check arg+    fast_check (CastTy ty co)  = fast_check ty  >> fast_check_co co+    fast_check (CoercionTy co) = fast_check_co co+    fast_check (ForAllTy (TvBndr tv' _) ty)+       | not impredicative_ok = OC_Bad+       | tv == tv'            = ok+       | otherwise = do { fast_check_occ (tyVarKind tv')+                        ; fast_check_occ ty }+       -- Under a forall we look only for occurrences of+       -- the type variable++     -- For kinds, we only do an occurs check; we do not worry+     -- about type families or foralls+     -- See Note [Checking for foralls]+    fast_check_occ k | tv `elemVarSet` tyCoVarsOfType k = OC_Occurs+                     | otherwise                        = ok++     -- For coercions, we are only doing an occurs check here;+     -- no bother about impredicativity in coercions, as they're+     -- inferred+    fast_check_co co | tv `elemVarSet` tyCoVarsOfCo co = OC_Occurs+                     | otherwise                       = ok++    bad_tc :: TyCon -> Bool+    bad_tc tc+      | not (impredicative_ok || isTauTyCon tc)     = True+      | not (ty_fam_ok        || isFamFreeTyCon tc) = True+      | otherwise                                   = False++occCheckExpand :: TcTyVar -> TcType -> Maybe TcType+-- See Note [Occurs check expansion]+-- We may have needed to do some type synonym unfolding in order to+-- get rid of the variable (or forall), so we also return the unfolded+-- version of the type, which is guaranteed to be syntactically free+-- of the given type variable.  If the type is already syntactically+-- free of the variable, then the same type is returned.+occCheckExpand tv ty+  = go emptyVarEnv ty+  where+    go :: VarEnv TyVar -> Type -> Maybe Type+          -- The VarEnv carries mappings necessary+          -- because of kind expansion+    go env (TyVarTy tv')+      | tv == tv'                         = Nothing+      | Just tv'' <- lookupVarEnv env tv' = return (mkTyVarTy tv'')+      | otherwise                         = do { k' <- go env (tyVarKind tv')+                                               ; return (mkTyVarTy $+                                                         setTyVarKind tv' k') }+           -- See Note [Occurrence checking: look inside kinds]++    go _   ty@(LitTy {}) = return ty+    go env (AppTy ty1 ty2) = do { ty1' <- go env ty1+                                ; ty2' <- go env ty2+                                ; return (mkAppTy ty1' ty2') }+    go env (FunTy ty1 ty2) = do { ty1' <- go env ty1+                                ; ty2' <- go env ty2+                                ; return (mkFunTy ty1' ty2') }+    go env ty@(ForAllTy (TvBndr tv' vis) body_ty)+       | tv == tv'         = return ty+       | otherwise         = do { ki' <- go env (tyVarKind tv')+                                ; let tv'' = setTyVarKind tv' ki'+                                      env' = extendVarEnv env tv' tv''+                                ; body' <- go env' body_ty+                                ; return (ForAllTy (TvBndr tv'' vis) body') }++    -- For a type constructor application, first try expanding away the+    -- offending variable from the arguments.  If that doesn't work, next+    -- see if the type constructor is a type synonym, and if so, expand+    -- it and try again.+    go env ty@(TyConApp tc tys)+      = case mapM (go env) tys of+          Just tys' -> return (mkTyConApp tc tys')+          Nothing | Just ty' <- tcView ty -> go env ty'+                  | otherwise             -> Nothing+                      -- Failing that, try to expand a synonym++    go env (CastTy ty co) =  do { ty' <- go env ty+                                ; co' <- go_co env co+                                ; return (mkCastTy ty' co') }+    go env (CoercionTy co) = do { co' <- go_co env co+                                ; return (mkCoercionTy co') }++    ------------------+    go_co env (Refl r ty)               = do { ty' <- go env ty+                                             ; return (mkReflCo r ty') }+      -- Note: Coercions do not contain type synonyms+    go_co env (TyConAppCo r tc args)    = do { args' <- mapM (go_co env) args+                                             ; return (mkTyConAppCo r tc args') }+    go_co env (AppCo co arg)            = do { co' <- go_co env co+                                             ; arg' <- go_co env arg+                                             ; return (mkAppCo co' arg') }+    go_co env co@(ForAllCo tv' kind_co body_co)+      | tv == tv'         = return co+      | otherwise         = do { kind_co' <- go_co env kind_co+                               ; let tv'' = setTyVarKind tv' $+                                            pFst (coercionKind kind_co')+                                     env' = extendVarEnv env tv' tv''+                               ; body' <- go_co env' body_co+                               ; return (ForAllCo tv'' kind_co' body') }+    go_co env (FunCo r co1 co2)         = do { co1' <- go_co env co1+                                             ; co2' <- go_co env co2+                                             ; return (mkFunCo r co1' co2') }+    go_co env (CoVarCo c)               = do { k' <- go env (varType c)+                                             ; return (mkCoVarCo (setVarType c k')) }+    go_co env (AxiomInstCo ax ind args) = do { args' <- mapM (go_co env) args+                                             ; return (mkAxiomInstCo ax ind args') }+    go_co env (UnivCo p r ty1 ty2)      = do { p' <- go_prov env p+                                             ; ty1' <- go env ty1+                                             ; ty2' <- go env ty2+                                             ; return (mkUnivCo p' r ty1' ty2') }+    go_co env (SymCo co)                = do { co' <- go_co env co+                                             ; return (mkSymCo co') }+    go_co env (TransCo co1 co2)         = do { co1' <- go_co env co1+                                             ; co2' <- go_co env co2+                                             ; return (mkTransCo co1' co2') }+    go_co env (NthCo n co)              = do { co' <- go_co env co+                                             ; return (mkNthCo n co') }+    go_co env (LRCo lr co)              = do { co' <- go_co env co+                                             ; return (mkLRCo lr co') }+    go_co env (InstCo co arg)           = do { co' <- go_co env co+                                             ; arg' <- go_co env arg+                                             ; return (mkInstCo co' arg') }+    go_co env (CoherenceCo co1 co2)     = do { co1' <- go_co env co1+                                             ; co2' <- go_co env co2+                                             ; return (mkCoherenceCo co1' co2') }+    go_co env (KindCo co)               = do { co' <- go_co env co+                                             ; return (mkKindCo co') }+    go_co env (SubCo co)                = do { co' <- go_co env co+                                             ; return (mkSubCo co') }+    go_co env (AxiomRuleCo ax cs)       = do { cs' <- mapM (go_co env) cs+                                             ; return (mkAxiomRuleCo ax cs') }++    ------------------+    go_prov _   UnsafeCoerceProv    = return UnsafeCoerceProv+    go_prov env (PhantomProv co)    = PhantomProv <$> go_co env co+    go_prov env (ProofIrrelProv co) = ProofIrrelProv <$> go_co env co+    go_prov _   p@(PluginProv _)    = return p+    go_prov _   p@(HoleProv _)      = return p++canUnifyWithPolyType :: DynFlags -> TcTyVarDetails -> Bool+canUnifyWithPolyType dflags details+  = case details of+      MetaTv { mtv_info = SigTv }    -> False+      MetaTv { mtv_info = TauTv }    -> xopt LangExt.ImpredicativeTypes dflags+      _other                         -> True+          -- We can have non-meta tyvars in given constraints
+ typecheck/TcUnify.hs-boot view
@@ -0,0 +1,14 @@+module TcUnify where+import TcType     ( TcTauType )+import TcRnTypes  ( TcM )+import TcEvidence ( TcCoercion )+import Outputable ( Outputable )+import HsExpr     ( HsExpr )+import Name       ( Name )++-- This boot file exists only to tie the knot between+--              TcUnify and Inst++unifyType :: Outputable a => Maybe a -> TcTauType -> TcTauType -> TcM TcCoercion+unifyKind :: Outputable a => Maybe a -> TcTauType -> TcTauType -> TcM TcCoercion+noThing   :: Maybe (HsExpr Name)
+ typecheck/TcValidity.hs view
@@ -0,0 +1,2040 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++{-# LANGUAGE CPP, TupleSections, ViewPatterns #-}++module TcValidity (+  Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,+  ContextKind(..), expectedKindInCtxt,+  checkValidTheta, checkValidFamPats,+  checkValidInstance, validDerivPred,+  checkInstTermination, checkTySynRhs,+  ClsInstInfo, checkValidCoAxiom, checkValidCoAxBranch,+  checkValidTyFamEqn,+  arityErr, badATErr,+  checkValidTelescope, checkZonkValidTelescope, checkValidInferredKinds,+  allDistinctTyVars+  ) where++#include "HsVersions.h"++import Maybes++-- friends:+import TcUnify    ( tcSubType_NC )+import TcSimplify ( simplifyAmbiguityCheck )+import TyCoRep+import TcType hiding ( sizeType, sizeTypes )+import TcMType+import PrelNames+import Type+import Coercion+import Kind+import CoAxiom+import Class+import TyCon++-- others:+import HsSyn            -- HsType+import TcRnMonad        -- TcType, amongst others+import TcEnv       ( tcGetInstEnvs )+import FunDeps+import InstEnv     ( InstMatch, lookupInstEnv )+import FamInstEnv  ( isDominatedBy, injectiveBranches,+                     InjectivityCheckResult(..) )+import FamInst     ( makeInjectivityErrors )+import Name+import VarEnv+import VarSet+import UniqSet+import Var         ( TyVarBndr(..), mkTyVar )+import ErrUtils+import DynFlags+import Util+import ListSetOps+import SrcLoc+import Outputable+import BasicTypes+import Module+import Unique      ( mkAlphaTyVarUnique )+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Data.List        ( (\\) )++{-+************************************************************************+*                                                                      *+          Checking for ambiguity+*                                                                      *+************************************************************************++Note [The ambiguity check for type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+checkAmbiguity is a check on *user-supplied type signatures*.  It is+*purely* there to report functions that cannot possibly be called.  So for+example we want to reject:+   f :: C a => Int+The idea is there can be no legal calls to 'f' because every call will+give rise to an ambiguous constraint.  We could soundly omit the+ambiguity check on type signatures entirely, at the expense of+delaying ambiguity errors to call sites.  Indeed, the flag+-XAllowAmbiguousTypes switches off the ambiguity check.++What about things like this:+   class D a b | a -> b where ..+   h :: D Int b => Int+The Int may well fix 'b' at the call site, so that signature should+not be rejected.  Moreover, using *visible* fundeps is too+conservative.  Consider+   class X a b where ...+   class D a b | a -> b where ...+   instance D a b => X [a] b where...+   h :: X a b => a -> a+Here h's type looks ambiguous in 'b', but here's a legal call:+   ...(h [True])...+That gives rise to a (X [Bool] beta) constraint, and using the+instance means we need (D Bool beta) and that fixes 'beta' via D's+fundep!++Behind all these special cases there is a simple guiding principle.+Consider++  f :: <type>+  f = ...blah...++  g :: <type>+  g = f++You would think that the definition of g would surely typecheck!+After all f has exactly the same type, and g=f. But in fact f's type+is instantiated and the instantiated constraints are solved against+the originals, so in the case an ambiguous type it won't work.+Consider our earlier example f :: C a => Int.  Then in g's definition,+we'll instantiate to (C alpha) and try to deduce (C alpha) from (C a),+and fail.++So in fact we use this as our *definition* of ambiguity.  We use a+very similar test for *inferred* types, to ensure that they are+unambiguous. See Note [Impedance matching] in TcBinds.++This test is very conveniently implemented by calling+    tcSubType <type> <type>+This neatly takes account of the functional dependecy stuff above,+and implicit parameter (see Note [Implicit parameters and ambiguity]).+And this is what checkAmbiguity does.++What about this, though?+   g :: C [a] => Int+Is every call to 'g' ambiguous?  After all, we might have+   instance C [a] where ...+at the call site.  So maybe that type is ok!  Indeed even f's+quintessentially ambiguous type might, just possibly be callable:+with -XFlexibleInstances we could have+  instance C a where ...+and now a call could be legal after all!  Well, we'll reject this+unless the instance is available *here*.++Note [When to call checkAmbiguity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We call checkAmbiguity+   (a) on user-specified type signatures+   (b) in checkValidType++Conncerning (b), you might wonder about nested foralls.  What about+    f :: forall b. (forall a. Eq a => b) -> b+The nested forall is ambiguous.  Originally we called checkAmbiguity+in the forall case of check_type, but that had two bad consequences:+  * We got two error messages about (Eq b) in a nested forall like this:+       g :: forall a. Eq a => forall b. Eq b => a -> a+  * If we try to check for ambiguity of an nested forall like+    (forall a. Eq a => b), the implication constraint doesn't bind+    all the skolems, which results in "No skolem info" in error+    messages (see Trac #10432).++To avoid this, we call checkAmbiguity once, at the top, in checkValidType.+(I'm still a bit worried about unbound skolems when the type mentions+in-scope type variables.)++In fact, because of the co/contra-variance implemented in tcSubType,+this *does* catch function f above. too.++Concerning (a) the ambiguity check is only used for *user* types, not+for types coming from inteface files.  The latter can legitimately+have ambiguous types. Example++   class S a where s :: a -> (Int,Int)+   instance S Char where s _ = (1,1)+   f:: S a => [a] -> Int -> (Int,Int)+   f (_::[a]) x = (a*x,b)+        where (a,b) = s (undefined::a)++Here the worker for f gets the type+        fw :: forall a. S a => Int -> (# Int, Int #)+++Note [Implicit parameters and ambiguity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Only a *class* predicate can give rise to ambiguity+An *implicit parameter* cannot.  For example:+        foo :: (?x :: [a]) => Int+        foo = length ?x+is fine.  The call site will supply a particular 'x'++Furthermore, the type variables fixed by an implicit parameter+propagate to the others.  E.g.+        foo :: (Show a, ?x::[a]) => Int+        foo = show (?x++?x)+The type of foo looks ambiguous.  But it isn't, because at a call site+we might have+        let ?x = 5::Int in foo+and all is well.  In effect, implicit parameters are, well, parameters,+so we can take their type variables into account as part of the+"tau-tvs" stuff.  This is done in the function 'FunDeps.grow'.+-}++checkAmbiguity :: UserTypeCtxt -> Type -> TcM ()+checkAmbiguity ctxt ty+  | wantAmbiguityCheck ctxt+  = do { traceTc "Ambiguity check for" (ppr ty)+         -- Solve the constraints eagerly because an ambiguous type+         -- can cause a cascade of further errors.  Since the free+         -- tyvars are skolemised, we can safely use tcSimplifyTop+       ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes+       ; (_wrap, wanted) <- addErrCtxt (mk_msg allow_ambiguous) $+                            captureConstraints $+                            tcSubType_NC ctxt ty ty+       ; simplifyAmbiguityCheck ty wanted++       ; traceTc "Done ambiguity check for" (ppr ty) }++  | otherwise+  = return ()+ where+   mk_msg allow_ambiguous+     = vcat [ text "In the ambiguity check for" <+> what+            , ppUnless allow_ambiguous ambig_msg ]+   ambig_msg = text "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes"+   what | Just n <- isSigMaybe ctxt = quotes (ppr n)+        | otherwise                 = pprUserTypeCtxt ctxt++wantAmbiguityCheck :: UserTypeCtxt -> Bool+wantAmbiguityCheck ctxt+  = case ctxt of  -- See Note [When we don't check for ambiguity]+      GhciCtxt     -> False+      TySynCtxt {} -> False+      _            -> True++checkUserTypeError :: Type -> TcM ()+-- Check to see if the type signature mentions "TypeError blah"+-- anywhere in it, and fail if so.+--+-- Very unsatisfactorily (Trac #11144) we need to tidy the type+-- because it may have come from an /inferred/ signature, not a+-- user-supplied one.  This is really only a half-baked fix;+-- the other errors in checkValidType don't do tidying, and so+-- may give bad error messages when given an inferred type.+checkUserTypeError = check+  where+  check ty+    | Just msg     <- userTypeError_maybe ty  = fail_with msg+    | Just (_,ts)  <- splitTyConApp_maybe ty  = mapM_ check ts+    | Just (t1,t2) <- splitAppTy_maybe ty     = check t1 >> check t2+    | Just (_,t1)  <- splitForAllTy_maybe ty  = check t1+    | otherwise                               = return ()++  fail_with msg = do { env0 <- tcInitTidyEnv+                     ; let (env1, tidy_msg) = tidyOpenType env0 msg+                     ; failWithTcM (env1, pprUserTypeErrorTy tidy_msg) }+++{- Note [When we don't check for ambiguity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a few places we do not want to check a user-specified type for ambiguity++* GhciCtxt: Allow ambiguous types in GHCi's :kind command+  E.g.   type family T a :: *  -- T :: forall k. k -> *+  Then :k T should work in GHCi, not complain that+  (T k) is ambiguous!++* TySynCtxt: type T a b = C a b => blah+  It may be that when we /use/ T, we'll give an 'a' or 'b' that somehow+  cure the ambiguity.  So we defer the ambiguity check to the use site.++  There is also an implementation reason (Trac #11608).  In the RHS of+  a type synonym we don't (currently) instantiate 'a' and 'b' with+  TcTyVars before calling checkValidType, so we get asertion failures+  from doing an ambiguity check on a type with TyVars in it.  Fixing this+  would not be hard, but let's wait till there's a reason.+++************************************************************************+*                                                                      *+          Checking validity of a user-defined type+*                                                                      *+************************************************************************++When dealing with a user-written type, we first translate it from an HsType+to a Type, performing kind checking, and then check various things that should+be true about it.  We don't want to perform these checks at the same time+as the initial translation because (a) they are unnecessary for interface-file+types and (b) when checking a mutually recursive group of type and class decls,+we can't "look" at the tycons/classes yet.  Also, the checks are rather+diverse, and used to really mess up the other code.++One thing we check for is 'rank'.++        Rank 0:         monotypes (no foralls)+        Rank 1:         foralls at the front only, Rank 0 inside+        Rank 2:         foralls at the front, Rank 1 on left of fn arrow,++        basic ::= tyvar | T basic ... basic++        r2  ::= forall tvs. cxt => r2a+        r2a ::= r1 -> r2a | basic+        r1  ::= forall tvs. cxt => r0+        r0  ::= r0 -> r0 | basic++Another thing is to check that type synonyms are saturated.+This might not necessarily show up in kind checking.+        type A i = i+        data T k = MkT (k Int)+        f :: T A        -- BAD!+-}++checkValidType :: UserTypeCtxt -> Type -> TcM ()+-- Checks that a user-written type is valid for the given context+-- Assumes argument is fully zonked+-- Not used for instance decls; checkValidInstance instead+checkValidType ctxt ty+  = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (typeKind ty))+       ; rankn_flag  <- xoptM LangExt.RankNTypes+       ; impred_flag <- xoptM LangExt.ImpredicativeTypes+       ; let gen_rank :: Rank -> Rank+             gen_rank r | rankn_flag = ArbitraryRank+                        | otherwise  = r++             rank1 = gen_rank r1+             rank0 = gen_rank r0++             r0 = rankZeroMonoType+             r1 = LimitedRank True r0++             rank+               = case ctxt of+                 DefaultDeclCtxt-> MustBeMonoType+                 ResSigCtxt     -> MustBeMonoType+                 PatSigCtxt     -> rank0+                 RuleSigCtxt _  -> rank1+                 TySynCtxt _    -> rank0++                 ExprSigCtxt    -> rank1+                 TypeAppCtxt | impred_flag -> ArbitraryRank+                             | otherwise   -> tyConArgMonoType+                    -- Normally, ImpredicativeTypes is handled in check_arg_type,+                    -- but visible type applications don't go through there.+                    -- So we do this check here.++                 FunSigCtxt {}  -> rank1+                 InfSigCtxt _   -> ArbitraryRank        -- Inferred type+                 ConArgCtxt _   -> rank1 -- We are given the type of the entire+                                         -- constructor, hence rank 1+                 PatSynCtxt _   -> rank1++                 ForSigCtxt _   -> rank1+                 SpecInstCtxt   -> rank1+                 ThBrackCtxt    -> rank1+                 GhciCtxt       -> ArbitraryRank+                 _              -> panic "checkValidType"+                                          -- Can't happen; not used for *user* sigs++       ; env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty)++        -- Check the internal validity of the type itself+       ; check_type env ctxt rank ty++       ; checkUserTypeError ty++       -- Check for ambiguous types.  See Note [When to call checkAmbiguity]+       -- NB: this will happen even for monotypes, but that should be cheap;+       --     and there may be nested foralls for the subtype test to examine+       ; checkAmbiguity ctxt ty++       ; traceTc "checkValidType done" (ppr ty <+> text "::" <+> ppr (typeKind ty)) }++checkValidMonoType :: Type -> TcM ()+-- Assumes argument is fully zonked+checkValidMonoType ty+  = do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty)+       ; check_type env SigmaCtxt MustBeMonoType ty }++checkTySynRhs :: UserTypeCtxt -> TcType -> TcM ()+checkTySynRhs ctxt ty+  | returnsConstraintKind actual_kind+  = do { ck <- xoptM LangExt.ConstraintKinds+       ; if ck+         then  when (isConstraintKind actual_kind)+                    (do { dflags <- getDynFlags+                        ; check_pred_ty emptyTidyEnv dflags ctxt ty })+         else addErrTcM (constraintSynErr emptyTidyEnv actual_kind) }++  | otherwise+  = return ()+  where+    actual_kind = typeKind ty++-- | The kind expected in a certain context.+data ContextKind = TheKind Kind   -- ^ a specific kind+                 | AnythingKind   -- ^ any kind will do+                 | OpenKind       -- ^ something of the form @TYPE _@++-- Depending on the context, we might accept any kind (for instance, in a TH+-- splice), or only certain kinds (like in type signatures).+expectedKindInCtxt :: UserTypeCtxt -> ContextKind+expectedKindInCtxt (TySynCtxt _)   = AnythingKind+expectedKindInCtxt ThBrackCtxt     = AnythingKind+expectedKindInCtxt GhciCtxt        = AnythingKind+-- The types in a 'default' decl can have varying kinds+-- See Note [Extended defaults]" in TcEnv+expectedKindInCtxt DefaultDeclCtxt = AnythingKind+expectedKindInCtxt TypeAppCtxt     = AnythingKind+expectedKindInCtxt (ForSigCtxt _)  = TheKind liftedTypeKind+expectedKindInCtxt InstDeclCtxt    = TheKind constraintKind+expectedKindInCtxt SpecInstCtxt    = TheKind constraintKind+expectedKindInCtxt _               = OpenKind++{-+Note [Higher rank types]+~~~~~~~~~~~~~~~~~~~~~~~~+Technically+            Int -> forall a. a->a+is still a rank-1 type, but it's not Haskell 98 (Trac #5957).  So the+validity checker allow a forall after an arrow only if we allow it+before -- that is, with Rank2Types or RankNTypes+-}++data Rank = ArbitraryRank         -- Any rank ok++          | LimitedRank   -- Note [Higher rank types]+                 Bool     -- Forall ok at top+                 Rank     -- Use for function arguments++          | MonoType SDoc   -- Monotype, with a suggestion of how it could be a polytype++          | MustBeMonoType  -- Monotype regardless of flags+++rankZeroMonoType, tyConArgMonoType, synArgMonoType, constraintMonoType :: Rank+rankZeroMonoType   = MonoType (text "Perhaps you intended to use RankNTypes or Rank2Types")+tyConArgMonoType   = MonoType (text "GHC doesn't yet support impredicative polymorphism")+synArgMonoType     = MonoType (text "Perhaps you intended to use LiberalTypeSynonyms")+constraintMonoType = MonoType (text "A constraint must be a monotype")++funArgResRank :: Rank -> (Rank, Rank)             -- Function argument and result+funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank)+funArgResRank other_rank               = (other_rank, other_rank)++forAllAllowed :: Rank -> Bool+forAllAllowed ArbitraryRank             = True+forAllAllowed (LimitedRank forall_ok _) = forall_ok+forAllAllowed _                         = False++----------------------------------------+check_type :: TidyEnv -> UserTypeCtxt -> Rank -> Type -> TcM ()+-- The args say what the *type context* requires, independent+-- of *flag* settings.  You test the flag settings at usage sites.+--+-- Rank is allowed rank for function args+-- Rank 0 means no for-alls anywhere++check_type env ctxt rank ty+  | not (null tvs && null theta)+  = do  { traceTc "check_type" (ppr ty $$ ppr (forAllAllowed rank))+        ; checkTcM (forAllAllowed rank) (forAllTyErr env rank ty)+                -- Reject e.g. (Maybe (?x::Int => Int)),+                -- with a decent error message++        ; check_valid_theta env' SigmaCtxt theta+                -- Allow     type T = ?x::Int => Int -> Int+                -- but not   type T = ?x::Int++        ; check_type env' ctxt rank tau      -- Allow foralls to right of arrow+        ; checkTcM (not (any (`elemVarSet` tyCoVarsOfType phi_kind) tvs))+                   (forAllEscapeErr env' ty tau_kind)+        }+  where+    (tvs, theta, tau) = tcSplitSigmaTy ty+    tau_kind          = typeKind tau+    (env', _)         = tidyTyCoVarBndrs env tvs++    phi_kind | null theta = tau_kind+             | otherwise  = liftedTypeKind+        -- If there are any constraints, the kind is *. (#11405)++check_type _ _ _ (TyVarTy _) = return ()++check_type env ctxt rank (FunTy arg_ty res_ty)+  = do  { check_type env ctxt arg_rank arg_ty+        ; check_type env ctxt res_rank res_ty }+  where+    (arg_rank, res_rank) = funArgResRank rank++check_type env ctxt rank (AppTy ty1 ty2)+  = do  { check_arg_type env ctxt rank ty1+        ; check_arg_type env ctxt rank ty2 }++check_type env ctxt rank ty@(TyConApp tc tys)+  | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc+  = check_syn_tc_app env ctxt rank ty tc tys+  | isUnboxedTupleTyCon tc = check_ubx_tuple  env ctxt      ty    tys+  | otherwise              = mapM_ (check_arg_type env ctxt rank) tys++check_type _ _ _ (LitTy {}) = return ()++check_type env ctxt rank (CastTy ty _) = check_type env ctxt rank ty++check_type _ _ _ ty = pprPanic "check_type" (ppr ty)++----------------------------------------+check_syn_tc_app :: TidyEnv -> UserTypeCtxt -> Rank -> KindOrType+                 -> TyCon -> [KindOrType] -> TcM ()+-- Used for type synonyms and type synonym families,+-- which must be saturated,+-- but not data families, which need not be saturated+check_syn_tc_app env ctxt rank ty tc tys+  | tc_arity <= length tys   -- Saturated+       -- Check that the synonym has enough args+       -- This applies equally to open and closed synonyms+       -- It's OK to have an *over-applied* type synonym+       --      data Tree a b = ...+       --      type Foo a = Tree [a]+       --      f :: Foo a b -> ...+  = do  { -- See Note [Liberal type synonyms]+        ; liberal <- xoptM LangExt.LiberalTypeSynonyms+        ; if not liberal || isTypeFamilyTyCon tc then+                -- For H98 and synonym families, do check the type args+                mapM_ check_arg tys++          else  -- In the liberal case (only for closed syns), expand then check+          case tcView ty of+             Just ty' -> check_type env ctxt rank ty'+             Nothing  -> pprPanic "check_tau_type" (ppr ty)  }++  | GhciCtxt <- ctxt  -- Accept under-saturated type synonyms in+                      -- GHCi :kind commands; see Trac #7586+  = mapM_ check_arg tys++  | otherwise+  = failWithTc (tyConArityErr tc tys)+  where+    tc_arity  = tyConArity tc+    check_arg | isTypeFamilyTyCon tc = check_arg_type  env ctxt rank+              | otherwise            = check_type      env ctxt synArgMonoType++----------------------------------------+check_ubx_tuple :: TidyEnv -> UserTypeCtxt -> KindOrType+                -> [KindOrType] -> TcM ()+check_ubx_tuple env ctxt ty tys+  = do  { ub_tuples_allowed <- xoptM LangExt.UnboxedTuples+        ; checkTcM ub_tuples_allowed (ubxArgTyErr env ty)++        ; impred <- xoptM LangExt.ImpredicativeTypes+        ; let rank' = if impred then ArbitraryRank else tyConArgMonoType+                -- c.f. check_arg_type+                -- However, args are allowed to be unlifted, or+                -- more unboxed tuples, so can't use check_arg_ty+        ; mapM_ (check_type env ctxt rank') tys }++----------------------------------------+check_arg_type :: TidyEnv -> UserTypeCtxt -> Rank -> KindOrType -> TcM ()+-- The sort of type that can instantiate a type variable,+-- or be the argument of a type constructor.+-- Not an unboxed tuple, but now *can* be a forall (since impredicativity)+-- Other unboxed types are very occasionally allowed as type+-- arguments depending on the kind of the type constructor+--+-- For example, we want to reject things like:+--+--      instance Ord a => Ord (forall s. T s a)+-- and+--      g :: T s (forall b.b)+--+-- NB: unboxed tuples can have polymorphic or unboxed args.+--     This happens in the workers for functions returning+--     product types with polymorphic components.+--     But not in user code.+-- Anyway, they are dealt with by a special case in check_tau_type++check_arg_type _ _ _ (CoercionTy {}) = return ()++check_arg_type env ctxt rank ty+  = do  { impred <- xoptM LangExt.ImpredicativeTypes+        ; let rank' = case rank of          -- Predictive => must be monotype+                        MustBeMonoType     -> MustBeMonoType  -- Monotype, regardless+                        _other | impred    -> ArbitraryRank+                               | otherwise -> tyConArgMonoType+                        -- Make sure that MustBeMonoType is propagated,+                        -- so that we don't suggest -XImpredicativeTypes in+                        --    (Ord (forall a.a)) => a -> a+                        -- and so that if it Must be a monotype, we check that it is!++        ; check_type env ctxt rank' ty }++----------------------------------------+forAllTyErr :: TidyEnv -> Rank -> Type -> (TidyEnv, SDoc)+forAllTyErr env rank ty+   = ( env+     , vcat [ hang herald 2 (ppr_tidy env ty)+            , suggestion ] )+  where+    (tvs, _theta, _tau) = tcSplitSigmaTy ty+    herald | null tvs  = text "Illegal qualified type:"+           | otherwise = text "Illegal polymorphic type:"+    suggestion = case rank of+                   LimitedRank {} -> text "Perhaps you intended to use RankNTypes or Rank2Types"+                   MonoType d     -> d+                   _              -> Outputable.empty -- Polytype is always illegal++forAllEscapeErr :: TidyEnv -> Type -> Kind -> (TidyEnv, SDoc)+forAllEscapeErr env ty tau_kind+  = ( env+    , hang (vcat [ text "Quantified type's kind mentions quantified type variable"+                 , text "(skolem escape)" ])+         2 (vcat [ text "   type:" <+> ppr_tidy env ty+                 , text "of kind:" <+> ppr_tidy env tau_kind ]) )++ubxArgTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc)+ubxArgTyErr env ty = (env, sep [text "Illegal unboxed tuple type as function argument:", ppr_tidy env ty])++{-+Note [Liberal type synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If -XLiberalTypeSynonyms is on, expand closed type synonyms *before*+doing validity checking.  This allows us to instantiate a synonym defn+with a for-all type, or with a partially-applied type synonym.+        e.g.   type T a b = a+               type S m   = m ()+               f :: S (T Int)+Here, T is partially applied, so it's illegal in H98.  But if you+expand S first, then T we get just+               f :: Int+which is fine.++IMPORTANT: suppose T is a type synonym.  Then we must do validity+checking on an appliation (T ty1 ty2)++        *either* before expansion (i.e. check ty1, ty2)+        *or* after expansion (i.e. expand T ty1 ty2, and then check)+        BUT NOT BOTH++If we do both, we get exponential behaviour!!++  data TIACons1 i r c = c i ::: r c+  type TIACons2 t x = TIACons1 t (TIACons1 t x)+  type TIACons3 t x = TIACons2 t (TIACons1 t x)+  type TIACons4 t x = TIACons2 t (TIACons2 t x)+  type TIACons7 t x = TIACons4 t (TIACons3 t x)+++************************************************************************+*                                                                      *+\subsection{Checking a theta or source type}+*                                                                      *+************************************************************************++Note [Implicit parameters in instance decls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Implicit parameters _only_ allowed in type signatures; not in instance+decls, superclasses etc. The reason for not allowing implicit params in+instances is a bit subtle.  If we allowed+  instance (?x::Int, Eq a) => Foo [a] where ...+then when we saw+     (e :: (?x::Int) => t)+it would be unclear how to discharge all the potential uses of the ?x+in e.  For example, a constraint Foo [Int] might come out of e, and+applying the instance decl would show up two uses of ?x.  Trac #8912.+-}++checkValidTheta :: UserTypeCtxt -> ThetaType -> TcM ()+-- Assumes argument is fully zonked+checkValidTheta ctxt theta+  = do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypesList theta)+       ; addErrCtxtM (checkThetaCtxt ctxt theta) $+         check_valid_theta env ctxt theta }++-------------------------+check_valid_theta :: TidyEnv -> UserTypeCtxt -> [PredType] -> TcM ()+check_valid_theta _ _ []+  = return ()+check_valid_theta env ctxt theta+  = do { dflags <- getDynFlags+       ; warnTcM (Reason Opt_WarnDuplicateConstraints)+                 (wopt Opt_WarnDuplicateConstraints dflags && notNull dups)+                 (dupPredWarn env dups)+       ; traceTc "check_valid_theta" (ppr theta)+       ; mapM_ (check_pred_ty env dflags ctxt) theta }+  where+    (_,dups) = removeDups nonDetCmpType theta+    -- It's OK to use nonDetCmpType because dups only appears in the+    -- warning++-------------------------+{- Note [Validity checking for constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We look through constraint synonyms so that we can see the underlying+constraint(s).  For example+   type Foo = ?x::Int+   instance Foo => C T+We should reject the instance because it has an implicit parameter in+the context.++But we record, in 'under_syn', whether we have looked under a synonym+to avoid requiring language extensions at the use site.  Main example+(Trac #9838):++   {-# LANGUAGE ConstraintKinds #-}+   module A where+      type EqShow a = (Eq a, Show a)++   module B where+      import A+      foo :: EqShow a => a -> String++We don't want to require ConstraintKinds in module B.+-}++check_pred_ty :: TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> TcM ()+-- Check the validity of a predicate in a signature+-- See Note [Validity checking for constraints]+check_pred_ty env dflags ctxt pred+  = do { check_type env SigmaCtxt constraintMonoType pred+       ; check_pred_help False env dflags ctxt pred }++check_pred_help :: Bool    -- True <=> under a type synonym+                -> TidyEnv+                -> DynFlags -> UserTypeCtxt+                -> PredType -> TcM ()+check_pred_help under_syn env dflags ctxt pred+  | Just pred' <- tcView pred  -- Switch on under_syn when going under a+                                 -- synonym (Trac #9838, yuk)+  = check_pred_help True env dflags ctxt pred'+  | otherwise+  = case splitTyConApp_maybe pred of+      Just (tc, tys)+        | isTupleTyCon tc+        -> check_tuple_pred under_syn env dflags ctxt pred tys+           -- NB: this equality check must come first, because (~) is a class,+           -- too.+        | tc `hasKey` heqTyConKey ||+          tc `hasKey` eqTyConKey ||+          tc `hasKey` eqPrimTyConKey+        -> check_eq_pred env dflags pred tc tys+        | Just cls <- tyConClass_maybe tc+        -> check_class_pred env dflags ctxt pred cls tys  -- Includes Coercible+      _ -> check_irred_pred under_syn env dflags ctxt pred++check_eq_pred :: TidyEnv -> DynFlags -> PredType -> TyCon -> [TcType] -> TcM ()+check_eq_pred env dflags pred tc tys+  =         -- Equational constraints are valid in all contexts if type+            -- families are permitted+    do { checkTc (length tys == tyConArity tc) (tyConArityErr tc tys)+       ; checkTcM (xopt LangExt.TypeFamilies dflags+                   || xopt LangExt.GADTs dflags)+                  (eqPredTyErr env pred) }++check_tuple_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> [PredType] -> TcM ()+check_tuple_pred under_syn env dflags ctxt pred ts+  = do { -- See Note [ConstraintKinds in predicates]+         checkTcM (under_syn || xopt LangExt.ConstraintKinds dflags)+                  (predTupleErr env pred)+       ; mapM_ (check_pred_help under_syn env dflags ctxt) ts }+    -- This case will not normally be executed because without+    -- -XConstraintKinds tuple types are only kind-checked as *++check_irred_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> TcM ()+check_irred_pred under_syn env dflags ctxt pred+    -- The predicate looks like (X t1 t2) or (x t1 t2) :: Constraint+    -- where X is a type function+  = do { -- If it looks like (x t1 t2), require ConstraintKinds+         --   see Note [ConstraintKinds in predicates]+         -- But (X t1 t2) is always ok because we just require ConstraintKinds+         -- at the definition site (Trac #9838)+        failIfTcM (not under_syn && not (xopt LangExt.ConstraintKinds dflags)+                                && hasTyVarHead pred)+                  (predIrredErr env pred)++         -- Make sure it is OK to have an irred pred in this context+         -- See Note [Irreducible predicates in superclasses]+       ; failIfTcM (is_superclass ctxt+                    && not (xopt LangExt.UndecidableInstances dflags)+                    && has_tyfun_head pred)+                   (predSuperClassErr env pred) }+  where+    is_superclass ctxt = case ctxt of { ClassSCCtxt _ -> True; _ -> False }+    has_tyfun_head ty+      = case tcSplitTyConApp_maybe ty of+          Just (tc, _) -> isTypeFamilyTyCon tc+          Nothing      -> False++{- Note [ConstraintKinds in predicates]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Don't check for -XConstraintKinds under a type synonym, because that+was done at the type synonym definition site; see Trac #9838+e.g.   module A where+          type C a = (Eq a, Ix a)   -- Needs -XConstraintKinds+       module B where+          import A+          f :: C a => a -> a        -- Does *not* need -XConstraintKinds++Note [Irreducible predicates in superclasses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Allowing type-family calls in class superclasses is somewhat dangerous+because we can write:++ type family Fooish x :: * -> Constraint+ type instance Fooish () = Foo+ class Fooish () a => Foo a where++This will cause the constraint simplifier to loop because every time we canonicalise a+(Foo a) class constraint we add a (Fooish () a) constraint which will be immediately+solved to add+canonicalise another (Foo a) constraint.  -}++-------------------------+check_class_pred :: TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> Class -> [TcType] -> TcM ()+check_class_pred env dflags ctxt pred cls tys+  | isIPClass cls+  = do { check_arity+       ; checkTcM (okIPCtxt ctxt) (badIPPred env pred) }++  | otherwise+  = do { check_arity+       ; warn_simp <- woptM Opt_WarnSimplifiableClassConstraints+       ; when warn_simp check_simplifiable_class_constraint+       ; checkTcM arg_tys_ok (predTyVarErr env pred) }+  where+    check_arity = checkTc (classArity cls == length tys)+                          (tyConArityErr (classTyCon cls) tys)++    -- Check the arguments of a class constraint+    flexible_contexts = xopt LangExt.FlexibleContexts     dflags+    undecidable_ok    = xopt LangExt.UndecidableInstances dflags+    arg_tys_ok = case ctxt of+        SpecInstCtxt -> True    -- {-# SPECIALISE instance Eq (T Int) #-} is fine+        InstDeclCtxt -> checkValidClsArgs (flexible_contexts || undecidable_ok) cls tys+                                -- Further checks on head and theta+                                -- in checkInstTermination+        _            -> checkValidClsArgs flexible_contexts cls tys++    -- See Note [Simplifiable given constraints]+    check_simplifiable_class_constraint+       | xopt LangExt.MonoLocalBinds dflags+       = return ()+       | DataTyCtxt {} <- ctxt   -- Don't do this check for the "stupid theta"+       = return ()               -- of a data type declaration+       | otherwise+       = do { envs <- tcGetInstEnvs+            ; case lookupInstEnv False envs cls tys of+                 ([m], [], _) -> addWarnTc (Reason Opt_WarnSimplifiableClassConstraints)+                                           (simplifiable_constraint_warn m)+                 _ -> return () }++    simplifiable_constraint_warn :: InstMatch -> SDoc+    simplifiable_constraint_warn (match, _)+     = vcat [ hang (text "The constraint" <+> quotes (ppr (tidyType env pred)))+                 2 (text "matches an instance declaration")+            , ppr match+            , hang (text "This makes type inference for inner bindings fragile;")+                 2 (text "either use MonoLocalBinds, or simplify it using the instance") ]++{- Note [Simplifiable given constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A type signature like+   f :: Eq [(a,b)] => a -> b+is very fragile, for reasons described at length in TcInteract+Note [Instance and Given overlap].  As that Note discusses, for the+most part the clever stuff in TcInteract means that we don't use a+top-level instance if a local Given might fire, so there is no+fragility. But if we /infer/ the type of a local let-binding, things+can go wrong (Trac #11948 is an example, discussed in the Note).++So this warning is switched on only if we have NoMonoLocalBinds; in+that case the warning discourages users from writing simplifiable+class constraints.++The warning only fires if the constraint in the signature+matches the top-level instances in only one way, and with no+unifiers -- that is, under the same circumstances that+TcInteract.matchInstEnv fires an interaction with the top+level instances.  For example (Trac #13526), consider++  instance {-# OVERLAPPABLE #-} Eq (T a) where ...+  instance                   Eq (T Char) where ..+  f :: Eq (T a) => ...++We don't want to complain about this, even though the context+(Eq (T a)) matches an instance, because the user may be+deliberately deferring the choice so that the Eq (T Char)+has a chance to fire when 'f' is called.  And the fragility+only matters when there's a risk that the instance might+fire instead of the local 'given'; and there is no such+risk in this case.  Just use the same rules as for instance+firing!+-}++-------------------------+okIPCtxt :: UserTypeCtxt -> Bool+  -- See Note [Implicit parameters in instance decls]+okIPCtxt (FunSigCtxt {})        = True+okIPCtxt (InfSigCtxt {})        = True+okIPCtxt ExprSigCtxt            = True+okIPCtxt TypeAppCtxt            = True+okIPCtxt PatSigCtxt             = True+okIPCtxt ResSigCtxt             = True+okIPCtxt GenSigCtxt             = True+okIPCtxt (ConArgCtxt {})        = True+okIPCtxt (ForSigCtxt {})        = True  -- ??+okIPCtxt ThBrackCtxt            = True+okIPCtxt GhciCtxt               = True+okIPCtxt SigmaCtxt              = True+okIPCtxt (DataTyCtxt {})        = True+okIPCtxt (PatSynCtxt {})        = True+okIPCtxt (TySynCtxt {})         = True   -- e.g.   type Blah = ?x::Int+                                         -- Trac #11466++okIPCtxt (ClassSCCtxt {})  = False+okIPCtxt (InstDeclCtxt {}) = False+okIPCtxt (SpecInstCtxt {}) = False+okIPCtxt (RuleSigCtxt {})  = False+okIPCtxt DefaultDeclCtxt   = False++{-+Note [Kind polymorphic type classes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+MultiParam check:++    class C f where...   -- C :: forall k. k -> Constraint+    instance C Maybe where...++  The dictionary gets type [C * Maybe] even if it's not a MultiParam+  type class.++Flexibility check:++    class C f where...   -- C :: forall k. k -> Constraint+    data D a = D a+    instance C D where++  The dictionary gets type [C * (D *)]. IA0_TODO it should be+  generalized actually.+-}++checkThetaCtxt :: UserTypeCtxt -> ThetaType -> TidyEnv -> TcM (TidyEnv, SDoc)+checkThetaCtxt ctxt theta env+  = return ( env+           , vcat [ text "In the context:" <+> pprTheta (tidyTypes env theta)+                  , text "While checking" <+> pprUserTypeCtxt ctxt ] )++eqPredTyErr, predTupleErr, predIrredErr, predSuperClassErr :: TidyEnv -> PredType -> (TidyEnv, SDoc)+eqPredTyErr  env pred+  = ( env+    , text "Illegal equational constraint" <+> ppr_tidy env pred $$+      parens (text "Use GADTs or TypeFamilies to permit this") )+predTupleErr env pred+  = ( env+    , hang (text "Illegal tuple constraint:" <+> ppr_tidy env pred)+         2 (parens constraintKindsMsg) )+predIrredErr env pred+  = ( env+    , hang (text "Illegal constraint:" <+> ppr_tidy env pred)+         2 (parens constraintKindsMsg) )+predSuperClassErr env pred+  = ( env+    , hang (text "Illegal constraint" <+> quotes (ppr_tidy env pred)+            <+> text "in a superclass context")+         2 (parens undecidableMsg) )++predTyVarErr :: TidyEnv -> PredType -> (TidyEnv, SDoc)+predTyVarErr env pred+  = (env+    , vcat [ hang (text "Non type-variable argument")+                2 (text "in the constraint:" <+> ppr_tidy env pred)+           , parens (text "Use FlexibleContexts to permit this") ])++badIPPred :: TidyEnv -> PredType -> (TidyEnv, SDoc)+badIPPred env pred+  = ( env+    , text "Illegal implicit parameter" <+> quotes (ppr_tidy env pred) )++constraintSynErr :: TidyEnv -> Type -> (TidyEnv, SDoc)+constraintSynErr env kind+  = ( env+    , hang (text "Illegal constraint synonym of kind:" <+> quotes (ppr_tidy env kind))+         2 (parens constraintKindsMsg) )++dupPredWarn :: TidyEnv -> [[PredType]] -> (TidyEnv, SDoc)+dupPredWarn env dups+  = ( env+    , text "Duplicate constraint" <> plural primaryDups <> text ":"+      <+> pprWithCommas (ppr_tidy env) primaryDups )+  where+    primaryDups = map head dups++tyConArityErr :: TyCon -> [TcType] -> SDoc+-- For type-constructor arity errors, be careful to report+-- the number of /visible/ arguments required and supplied,+-- ignoring the /invisible/ arguments, which the user does not see.+-- (e.g. Trac #10516)+tyConArityErr tc tks+  = arityErr (tyConFlavour tc) (tyConName tc)+             tc_type_arity tc_type_args+  where+    vis_tks = filterOutInvisibleTypes tc tks++    -- tc_type_arity = number of *type* args expected+    -- tc_type_args  = number of *type* args encountered+    tc_type_arity = count isVisibleTyConBinder (tyConBinders tc)+    tc_type_args  = length vis_tks++arityErr :: Outputable a => String -> a -> Int -> Int -> SDoc+arityErr what name n m+  = hsep [ text "The" <+> text what, quotes (ppr name), text "should have",+           n_arguments <> comma, text "but has been given",+           if m==0 then text "none" else int m]+    where+        n_arguments | n == 0 = text "no arguments"+                    | n == 1 = text "1 argument"+                    | True   = hsep [int n, text "arguments"]++{-+************************************************************************+*                                                                      *+\subsection{Checking for a decent instance head type}+*                                                                      *+************************************************************************++@checkValidInstHead@ checks the type {\em and} its syntactic constraints:+it must normally look like: @instance Foo (Tycon a b c ...) ...@++The exceptions to this syntactic checking: (1)~if the @GlasgowExts@+flag is on, or (2)~the instance is imported (they must have been+compiled elsewhere). In these cases, we let them go through anyway.++We can also have instances for functions: @instance Foo (a -> b) ...@.+-}++checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM ()+checkValidInstHead ctxt clas cls_args+  = do { dflags <- getDynFlags++       ; mod <- getModule+       ; checkTc (getUnique clas `notElem` abstractClassKeys ||+                  nameModule (getName clas) == mod)+                 (instTypeErr clas cls_args abstract_class_msg)++       ; when (clas `hasKey` hasFieldClassNameKey) $+             checkHasFieldInst clas cls_args++           -- Check language restrictions;+           -- but not for SPECIALISE instance pragmas+       ; let ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args+       ; unless spec_inst_prag $+         do { checkTc (xopt LangExt.TypeSynonymInstances dflags ||+                       all tcInstHeadTyNotSynonym ty_args)+                 (instTypeErr clas cls_args head_type_synonym_msg)+            ; checkTc (xopt LangExt.FlexibleInstances dflags ||+                       all tcInstHeadTyAppAllTyVars ty_args)+                 (instTypeErr clas cls_args head_type_args_tyvars_msg)+            ; checkTc (xopt LangExt.MultiParamTypeClasses dflags ||+                       length ty_args == 1 ||  -- Only count type arguments+                       (xopt LangExt.NullaryTypeClasses dflags &&+                        null ty_args))+                 (instTypeErr clas cls_args head_one_type_msg) }++       ; mapM_ checkValidTypePat ty_args }+  where+    spec_inst_prag = case ctxt of { SpecInstCtxt -> True; _ -> False }++    head_type_synonym_msg = parens (+                text "All instance types must be of the form (T t1 ... tn)" $$+                text "where T is not a synonym." $$+                text "Use TypeSynonymInstances if you want to disable this.")++    head_type_args_tyvars_msg = parens (vcat [+                text "All instance types must be of the form (T a1 ... an)",+                text "where a1 ... an are *distinct type variables*,",+                text "and each type variable appears at most once in the instance head.",+                text "Use FlexibleInstances if you want to disable this."])++    head_one_type_msg = parens (+                text "Only one type can be given in an instance head." $$+                text "Use MultiParamTypeClasses if you want to allow more, or zero.")++    abstract_class_msg =+                text "Manual instances of this class are not permitted."++tcInstHeadTyNotSynonym :: Type -> Bool+-- Used in Haskell-98 mode, for the argument types of an instance head+-- These must not be type synonyms, but everywhere else type synonyms+-- are transparent, so we need a special function here+tcInstHeadTyNotSynonym ty+  = case ty of  -- Do not use splitTyConApp,+                -- because that expands synonyms!+        TyConApp tc _ -> not (isTypeSynonymTyCon tc)+        _ -> True++tcInstHeadTyAppAllTyVars :: Type -> Bool+-- Used in Haskell-98 mode, for the argument types of an instance head+-- These must be a constructor applied to type variable arguments.+-- But we allow kind instantiations.+tcInstHeadTyAppAllTyVars ty+  | Just (tc, tys) <- tcSplitTyConApp_maybe (dropCasts ty)+  = ok (filterOutInvisibleTypes tc tys)  -- avoid kinds++  | otherwise+  = False+  where+        -- Check that all the types are type variables,+        -- and that each is distinct+    ok tys = equalLength tvs tys && hasNoDups tvs+           where+             tvs = mapMaybe tcGetTyVar_maybe tys++dropCasts :: Type -> Type+-- See Note [Casts during validity checking]+-- This function can turn a well-kinded type into an ill-kinded+-- one, so I've kept it local to this module+-- To consider: drop only UnivCo(HoleProv) casts+dropCasts (CastTy ty _)     = dropCasts ty+dropCasts (AppTy t1 t2)     = mkAppTy (dropCasts t1) (dropCasts t2)+dropCasts (FunTy t1 t2)     = mkFunTy (dropCasts t1) (dropCasts t2)+dropCasts (TyConApp tc tys) = mkTyConApp tc (map dropCasts tys)+dropCasts (ForAllTy b ty)   = ForAllTy (dropCastsB b) (dropCasts ty)+dropCasts ty                = ty  -- LitTy, TyVarTy, CoercionTy++dropCastsB :: TyVarBinder -> TyVarBinder+dropCastsB b = b   -- Don't bother in the kind of a forall++abstractClassKeys :: [Unique]+abstractClassKeys = [ heqTyConKey+                    , eqTyConKey+                    , coercibleTyConKey+                    ] -- See Note [Equality class instances]++instTypeErr :: Class -> [Type] -> SDoc -> SDoc+instTypeErr cls tys msg+  = hang (hang (text "Illegal instance declaration for")+             2 (quotes (pprClassPred cls tys)))+       2 msg++-- | See Note [Validity checking of HasField instances]+checkHasFieldInst :: Class -> [Type] -> TcM ()+checkHasFieldInst cls tys@[_k_ty, x_ty, r_ty, _a_ty] =+  case splitTyConApp_maybe r_ty of+    Nothing -> whoops (text "Record data type must be specified")+    Just (tc, _)+      | isFamilyTyCon tc+                  -> whoops (text "Record data type may not be a data family")+      | otherwise -> case isStrLitTy x_ty of+       Just lbl+         | isJust (lookupTyConFieldLabel lbl tc)+                     -> whoops (ppr tc <+> text "already has a field"+                                       <+> quotes (ppr lbl))+         | otherwise -> return ()+       Nothing+         | null (tyConFieldLabels tc) -> return ()+         | otherwise -> whoops (ppr tc <+> text "has fields")+  where+    whoops = addErrTc . instTypeErr cls tys+checkHasFieldInst _ tys = pprPanic "checkHasFieldInst" (ppr tys)++{- Note [Casts during validity checking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the (bogus)+     instance Eq Char#+We elaborate to  'Eq (Char# |> UnivCo(hole))'  where the hole is an+insoluble equality constraint for * ~ #.  We'll report the insoluble+constraint separately, but we don't want to *also* complain that Eq is+not applied to a type constructor.  So we look gaily look through+CastTys here.++Another example:  Eq (Either a).  Then we actually get a cast in+the middle:+   Eq ((Either |> g) a)+++Note [Validity checking of HasField instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The HasField class has magic constraint solving behaviour (see Note+[HasField instances] in TcInteract).  However, we permit users to+declare their own instances, provided they do not clash with the+built-in behaviour.  In particular, we forbid:++  1. `HasField _ r _` where r is a variable++  2. `HasField _ (T ...) _` if T is a data family+     (because it might have fields introduced later)++  3. `HasField x (T ...) _` where x is a variable,+      if T has any fields at all++  4. `HasField "foo" (T ...) _` if T has a "foo" field++The usual functional dependency checks also apply.+++Note [Valid 'deriving' predicate]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+validDerivPred checks for OK 'deriving' context.  See Note [Exotic+derived instance contexts] in TcDeriv.  However the predicate is+here because it uses sizeTypes, fvTypes.++It checks for three things++  * No repeated variables (hasNoDups fvs)++  * No type constructors.  This is done by comparing+        sizeTypes tys == length (fvTypes tys)+    sizeTypes counts variables and constructors; fvTypes returns variables.+    So if they are the same, there must be no constructors.  But there+    might be applications thus (f (g x)).++    Note that tys only includes the visible arguments of the class type+    constructor. Including the non-vivisble arguments can cause the following,+    perfectly valid instance to be rejected:+       class Category (cat :: k -> k -> *) where ...+       newtype T (c :: * -> * -> *) a b = MkT (c a b)+       instance Category c => Category (T c) where ...+    since the first argument to Category is a non-visible *, which sizeTypes+    would count as a constructor! See Trac #11833.++  * Also check for a bizarre corner case, when the derived instance decl+    would look like+       instance C a b => D (T a) where ...+    Note that 'b' isn't a parameter of T.  This gives rise to all sorts of+    problems; in particular, it's hard to compare solutions for equality+    when finding the fixpoint, and that means the inferContext loop does+    not converge.  See Trac #5287.++Note [Equality class instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We can't have users writing instances for the equality classes. But we+still need to be able to write instances for them ourselves. So we allow+instances only in the defining module.++-}++validDerivPred :: TyVarSet -> PredType -> Bool+-- See Note [Valid 'deriving' predicate]+validDerivPred tv_set pred+  = case classifyPredType pred of+       ClassPred cls tys -> cls `hasKey` typeableClassKey+                -- Typeable constraints are bigger than they appear due+                -- to kind polymorphism, but that's OK+                       || check_tys cls tys+       EqPred {}       -> False  -- reject equality constraints+       _               -> True   -- Non-class predicates are ok+  where+    check_tys cls tys+              = hasNoDups fvs+                   -- use sizePred to ignore implicit args+                && sizePred pred == fromIntegral (length fvs)+                && all (`elemVarSet` tv_set) fvs+      where tys' = filterOutInvisibleTypes (classTyCon cls) tys+            fvs  = fvTypes tys'++{-+************************************************************************+*                                                                      *+\subsection{Checking instance for termination}+*                                                                      *+************************************************************************+-}++{- Note [Instances and constraint synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Currently, we don't allow instances for constraint synonyms at all.+Consider these (Trac #13267):+  type C1 a = Show (a -> Bool)+  instance C1 Int where    -- I1+    show _ = "ur"++This elicits "show is not a (visible) method of class C1", which isn't+a great message. But it comes from the renamer, so it's hard to improve.++This needs a bit more care:+  type C2 a = (Show a, Show Int)+  instance C2 Int           -- I2++If we use (splitTyConApp_maybe tau) in checkValidInstance to decompose+the instance head, we'll expand the synonym on fly, and it'll look like+  instance (%,%) (Show Int, Show Int)+and we /really/ don't want that.  So we carefully do /not/ expand+synonyms, by matching on TyConApp directly.+-}++checkValidInstance :: UserTypeCtxt -> LHsSigType Name -> Type+                   -> TcM ([TyVar], ThetaType, Class, [Type])+checkValidInstance ctxt hs_type ty+  | not is_tc_app+  = failWithTc (text "Instance head is not headed by a class")++  | isNothing mb_cls+  = failWithTc (vcat [ text "Illegal instance for a" <+> text (tyConFlavour tc)+                     , text "A class instance must be for a class" ])++  | not arity_ok+  = failWithTc (text "Arity mis-match in instance head")++  | otherwise+  = do  { setSrcSpan head_loc (checkValidInstHead ctxt clas inst_tys)+        ; traceTc "checkValidInstance {" (ppr ty)+        ; checkValidTheta ctxt theta++        -- The Termination and Coverate Conditions+        -- Check that instance inference will terminate (if we care)+        -- For Haskell 98 this will already have been done by checkValidTheta,+        -- but as we may be using other extensions we need to check.+        --+        -- Note that the Termination Condition is *more conservative* than+        -- the checkAmbiguity test we do on other type signatures+        --   e.g.  Bar a => Bar Int is ambiguous, but it also fails+        --   the termination condition, because 'a' appears more often+        --   in the constraint than in the head+        ; undecidable_ok <- xoptM LangExt.UndecidableInstances+        ; if undecidable_ok+          then checkAmbiguity ctxt ty+          else checkInstTermination inst_tys theta++        ; traceTc "cvi 2" (ppr ty)++        ; case (checkInstCoverage undecidable_ok clas theta inst_tys) of+            IsValid      -> return ()   -- Check succeeded+            NotValid msg -> addErrTc (instTypeErr clas inst_tys msg)++        ; traceTc "End checkValidInstance }" empty++        ; return (tvs, theta, clas, inst_tys) }+  where+    (tvs, theta, tau)    = tcSplitSigmaTy ty+    is_tc_app            = case tau of { TyConApp {} -> True; _ -> False }+    TyConApp tc inst_tys = tau   -- See Note [Instances and constraint synonyms]+    mb_cls               = tyConClass_maybe tc+    Just clas            = mb_cls+    arity_ok             = inst_tys `lengthIs` classArity clas++        -- The location of the "head" of the instance+    head_loc = getLoc (getLHsInstDeclHead hs_type)++{-+Note [Paterson conditions]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Termination test: the so-called "Paterson conditions" (see Section 5 of+"Understanding functional dependencies via Constraint Handling Rules,+JFP Jan 2007).++We check that each assertion in the context satisfies:+ (1) no variable has more occurrences in the assertion than in the head, and+ (2) the assertion has fewer constructors and variables (taken together+     and counting repetitions) than the head.+This is only needed with -fglasgow-exts, as Haskell 98 restrictions+(which have already been checked) guarantee termination.++The underlying idea is that++    for any ground substitution, each assertion in the+    context has fewer type constructors than the head.+-}++checkInstTermination :: [TcType] -> ThetaType -> TcM ()+-- See Note [Paterson conditions]+checkInstTermination tys theta+  = check_preds theta+  where+   head_fvs  = fvTypes tys+   head_size = sizeTypes tys++   check_preds :: [PredType] -> TcM ()+   check_preds preds = mapM_ check preds++   check :: PredType -> TcM ()+   check pred+     = case classifyPredType pred of+         EqPred {}    -> return ()  -- See Trac #4200.+         IrredPred {} -> check2 pred (sizeType pred)+         ClassPred cls tys+           | isTerminatingClass cls+           -> return ()++           | isCTupleClass cls  -- Look inside tuple predicates; Trac #8359+           -> check_preds tys++           | otherwise+           -> check2 pred (sizeTypes $ filterOutInvisibleTypes (classTyCon cls) tys)+                       -- Other ClassPreds++   check2 pred pred_size+     | not (null bad_tvs)     = addErrTc (noMoreMsg bad_tvs what)+     | pred_size >= head_size = addErrTc (smallerMsg what)+     | otherwise              = return ()+     where+        what    = text "constraint" <+> quotes (ppr pred)+        bad_tvs = fvType pred \\ head_fvs++smallerMsg :: SDoc -> SDoc+smallerMsg what+  = vcat [ hang (text "The" <+> what)+              2 (text "is no smaller than the instance head")+         , parens undecidableMsg ]++noMoreMsg :: [TcTyVar] -> SDoc -> SDoc+noMoreMsg tvs what+  = vcat [ hang (text "Variable" <> plural tvs <+> quotes (pprWithCommas ppr tvs)+                <+> occurs <+> text "more often")+              2 (sep [ text "in the" <+> what+                     , text "than in the instance head" ])+         , parens undecidableMsg ]+  where+   occurs = if isSingleton tvs then text "occurs"+                               else text "occur"++undecidableMsg, constraintKindsMsg :: SDoc+undecidableMsg     = text "Use UndecidableInstances to permit this"+constraintKindsMsg = text "Use ConstraintKinds to permit this"++{-+Note [Associated type instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We allow this:+  class C a where+    type T x a+  instance C Int where+    type T (S y) Int = y+    type T Z     Int = Char++Note that+  a) The variable 'x' is not bound by the class decl+  b) 'x' is instantiated to a non-type-variable in the instance+  c) There are several type instance decls for T in the instance++All this is fine.  Of course, you can't give any *more* instances+for (T ty Int) elsewhere, because it's an *associated* type.++Note [Checking consistent instantiation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See Trac #11450 for background discussion on this check.++  class C a b where+    type T a x b++With this class decl, if we have an instance decl+  instance C ty1 ty2 where ...+then the type instance must look like+     type T ty1 v ty2 = ...+with exactly 'ty1' for 'a', 'ty2' for 'b', and some type 'v' for 'x'.+For example:++  instance C [p] Int+    type T [p] y Int = (p,y,y)++Note that++* We used to allow completely different bound variables in the+  associated type instance; e.g.+    instance C [p] Int+      type T [q] y Int = ...+  But from GHC 8.2 onwards, we don't.  It's much simpler this way.+  See Trac #11450.++* When the class variable isn't used on the RHS of the type instance,+  it's tempting to allow wildcards, thus+    instance C [p] Int+      type T [_] y Int = (y,y)+  But it's awkward to do the test, and it doesn't work if the+  variable is repeated:+    instance C (p,p) Int+      type T (_,_) y Int = (y,y)+  Even though 'p' is not used on the RHS, we still need to use 'p'+  on the LHS to establish the repeated pattern.  So to keep it simple+  we just require equality.++* For variables in associated type families that are not bound by the class+  itself, we do _not_ check if they are over-specific. In other words,+  it's perfectly acceptable to have an instance like this:++    instance C [p] Int where+      type T [p] (Maybe x) Int = x++  While the first and third arguments to T are required to be exactly [p] and+  Int, respectively, since they are bound by C, the second argument is allowed+  to be more specific than just a type variable. Furthermore, it is permissible+  to define multiple equations for T that differ only in the non-class-bound+  argument:++    instance C [p] Int where+      type T [p] (Maybe x)    Int = x+      type T [p] (Either x y) Int = x -> y++  We once considered requiring that non-class-bound variables in associated+  type family instances be instantiated with distinct type variables. However,+  that requirement proved too restrictive in practice, as there were examples+  of extremely simple associated type family instances that this check would+  reject, and fixing them required tiresome boilerplate in the form of+  auxiliary type families. For instance, you would have to define the above+  example as:++    instance C [p] Int where+      type T [p] x Int = CAux x++    type family CAux x where+      CAux (Maybe x)    = x+      CAux (Either x y) = x -> y++  We decided that this restriction wasn't buying us much, so we opted not+  to pursue that design (see also GHC Trac #13398).++Implementation+  * Form the mini-envt from the class type variables a,b+    to the instance decl types [p],Int:   [a->[p], b->Int]++  * Look at the tyvars a,x,b of the type family constructor T+    (it shares tyvars with the class C)++  * Apply the mini-evnt to them, and check that the result is+    consistent with the instance types [p] y Int. (where y can be any type, as+    it is not scoped over the class type variables.++We make all the instance type variables scope over the+type instances, of course, which picks up non-obvious kinds.  Eg+   class Foo (a :: k) where+      type F a+   instance Foo (b :: k -> k) where+      type F b = Int+Here the instance is kind-indexed and really looks like+      type F (k->k) (b::k->k) = Int+But if the 'b' didn't scope, we would make F's instance too+poly-kinded.+-}++-- | Extra information about the parent instance declaration, needed+-- when type-checking associated types. The 'Class' is the enclosing+-- class, the [TyVar] are the type variable of the instance decl,+-- and and the @VarEnv Type@ maps class variables to their instance+-- types.+type ClsInstInfo = (Class, [TyVar], VarEnv Type)++type AssocInstArgShape = (Maybe Type, Type)+  -- AssocInstArgShape is used only for associated family instances+  --    (mb_exp, actual)+  -- mb_exp = Just ty  => this arg corresponds to a class variable+  --        = Nothing  => it doesn't correspond to a class variable+  -- e.g.  class C b where+  --          type F a b c+  --       instance C [x] where+  --          type F p [x] q+  -- We get [AssocInstArgShape] = [ (Nothing,  p)+  --                              , (Just [x], [x])+  --                              , (Nothing,  q)]++checkConsistentFamInst+               :: Maybe ClsInstInfo+               -> TyCon              -- ^ Family tycon+               -> [TyVar]            -- ^ Type variables of the family instance+               -> [Type]             -- ^ Type patterns from instance+               -> TcM ()+-- See Note [Checking consistent instantiation]++checkConsistentFamInst Nothing _ _ _ = return ()+checkConsistentFamInst (Just (clas, inst_tvs, mini_env)) fam_tc _at_tvs at_tys+  = do { -- Check that the associated type indeed comes from this class+         checkTc (Just clas == tyConAssoc_maybe fam_tc)+                 (badATErr (className clas) (tyConName fam_tc))++       -- Check type args first (more comprehensible)+       ; checkTc (all check_arg type_shapes)   pp_wrong_at_arg++       -- And now kind args+       ; checkTc (all check_arg kind_shapes)+                 (pp_wrong_at_arg $$ ppSuggestExplicitKinds)++       ; traceTc "cfi" (vcat [ ppr inst_tvs+                             , ppr arg_shapes+                             , ppr mini_env ]) }+  where+    arg_shapes :: [AssocInstArgShape]+    arg_shapes = [ (lookupVarEnv mini_env fam_tc_tv, at_ty)+                 | (fam_tc_tv, at_ty) <- tyConTyVars fam_tc `zip` at_tys ]++    (kind_shapes, type_shapes) = partitionInvisibles fam_tc snd arg_shapes++    check_arg :: AssocInstArgShape -> Bool+    check_arg (Just exp_ty, at_ty) = exp_ty `tcEqType` at_ty+    check_arg (Nothing,     _    ) = True -- Arg position does not correspond+                                          -- to a class variable++    pp_wrong_at_arg+      = vcat [ text "Type indexes must match class instance head"+             , pp_exp_act ]++    pp_exp_act+      = vcat [ text "Expected:" <+> ppr (mkTyConApp fam_tc expected_args)+             , text "  Actual:" <+> ppr (mkTyConApp fam_tc at_tys)+             , sdocWithDynFlags $ \dflags ->+               ppWhen (has_poly_args dflags) $+               vcat [ text "where the `<tv>' arguments are type variables,"+                    , text "distinct from each other and from the instance variables" ] ]++    expected_args = [ exp_ty `orElse` mk_tv at_ty | (exp_ty, at_ty) <- arg_shapes ]+    mk_tv at_ty   = mkTyVarTy (mkTyVar tv_name (typeKind at_ty))+    tv_name = mkInternalName (mkAlphaTyVarUnique 1) (mkTyVarOcc "<tv>") noSrcSpan++    has_poly_args dflags = any (isNothing . fst) shapes+      where+        shapes | gopt Opt_PrintExplicitKinds dflags = arg_shapes+               | otherwise                          = type_shapes++badATErr :: Name -> Name -> SDoc+badATErr clas op+  = hsep [text "Class", quotes (ppr clas),+          text "does not have an associated type", quotes (ppr op)]+++{-+************************************************************************+*                                                                      *+        Checking type instance well-formedness and termination+*                                                                      *+************************************************************************+-}++checkValidCoAxiom :: CoAxiom Branched -> TcM ()+checkValidCoAxiom ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches })+  = do { mapM_ (checkValidCoAxBranch Nothing fam_tc) branch_list+       ; foldlM_ check_branch_compat [] branch_list }+  where+    branch_list = fromBranches branches+    injectivity = familyTyConInjectivityInfo fam_tc++    check_branch_compat :: [CoAxBranch]    -- previous branches in reverse order+                        -> CoAxBranch      -- current branch+                        -> TcM [CoAxBranch]-- current branch : previous branches+    -- Check for+    --   (a) this branch is dominated by previous ones+    --   (b) failure of injectivity+    check_branch_compat prev_branches cur_branch+      | cur_branch `isDominatedBy` prev_branches+      = do { addWarnAt NoReason (coAxBranchSpan cur_branch) $+             inaccessibleCoAxBranch ax cur_branch+           ; return prev_branches }+      | otherwise+      = do { check_injectivity prev_branches cur_branch+           ; return (cur_branch : prev_branches) }++     -- Injectivity check: check whether a new (CoAxBranch) can extend+     -- already checked equations without violating injectivity+     -- annotation supplied by the user.+     -- See Note [Verifying injectivity annotation] in FamInstEnv+    check_injectivity prev_branches cur_branch+      | Injective inj <- injectivity+      = do { let conflicts =+                     fst $ foldl (gather_conflicts inj prev_branches cur_branch)+                                 ([], 0) prev_branches+           ; mapM_ (\(err, span) -> setSrcSpan span $ addErr err)+                   (makeInjectivityErrors ax cur_branch inj conflicts) }+      | otherwise+      = return ()++    gather_conflicts inj prev_branches cur_branch (acc, n) branch+               -- n is 0-based index of branch in prev_branches+      = case injectiveBranches inj cur_branch branch of+          InjectivityUnified ax1 ax2+            | ax1 `isDominatedBy` (replace_br prev_branches n ax2)+                -> (acc, n + 1)+            | otherwise+                -> (branch : acc, n + 1)+          InjectivityAccepted -> (acc, n + 1)++    -- Replace n-th element in the list. Assumes 0-based indexing.+    replace_br :: [CoAxBranch] -> Int -> CoAxBranch -> [CoAxBranch]+    replace_br brs n br = take n brs ++ [br] ++ drop (n+1) brs+++-- Check that a "type instance" is well-formed (which includes decidability+-- unless -XUndecidableInstances is given).+--+checkValidCoAxBranch :: Maybe ClsInstInfo+                     -> TyCon -> CoAxBranch -> TcM ()+checkValidCoAxBranch mb_clsinfo fam_tc+                    (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs+                                , cab_lhs = typats+                                , cab_rhs = rhs, cab_loc = loc })+  = checkValidTyFamEqn mb_clsinfo fam_tc tvs cvs typats rhs loc++-- | Do validity checks on a type family equation, including consistency+-- with any enclosing class instance head, termination, and lack of+-- polytypes.+checkValidTyFamEqn :: Maybe ClsInstInfo+                   -> TyCon   -- ^ of the type family+                   -> [TyVar] -- ^ bound tyvars in the equation+                   -> [CoVar] -- ^ bound covars in the equation+                   -> [Type]  -- ^ type patterns+                   -> Type    -- ^ rhs+                   -> SrcSpan+                   -> TcM ()+checkValidTyFamEqn mb_clsinfo fam_tc tvs cvs typats rhs loc+  = setSrcSpan loc $+    do { checkValidFamPats mb_clsinfo fam_tc tvs cvs typats++         -- The argument patterns, and RHS, are all boxed tau types+         -- E.g  Reject type family F (a :: k1) :: k2+         --             type instance F (forall a. a->a) = ...+         --             type instance F Int#             = ...+         --             type instance F Int              = forall a. a->a+         --             type instance F Int              = Int#+         -- See Trac #9357+       ; checkValidMonoType rhs++         -- We have a decidable instance unless otherwise permitted+       ; undecidable_ok <- xoptM LangExt.UndecidableInstances+       ; unless undecidable_ok $+           mapM_ addErrTc (checkFamInstRhs typats (tcTyFamInsts rhs)) }++-- Make sure that each type family application is+--   (1) strictly smaller than the lhs,+--   (2) mentions no type variable more often than the lhs, and+--   (3) does not contain any further type family instances.+--+checkFamInstRhs :: [Type]                  -- lhs+                -> [(TyCon, [Type])]       -- type family instances+                -> [MsgDoc]+checkFamInstRhs lhsTys famInsts+  = mapMaybe check famInsts+  where+   size = sizeTypes lhsTys+   fvs  = fvTypes lhsTys+   check (tc, tys)+      | not (all isTyFamFree tys) = Just (nestedMsg what)+      | not (null bad_tvs)        = Just (noMoreMsg bad_tvs what)+      | size <= sizeTypes tys     = Just (smallerMsg what)+      | otherwise                 = Nothing+      where+        what    = text "type family application" <+> quotes (pprType (TyConApp tc tys))+        bad_tvs = fvTypes tys \\ fvs++checkValidFamPats :: Maybe ClsInstInfo -> TyCon -> [TyVar] -> [CoVar] -> [Type] -> TcM ()+-- Patterns in a 'type instance' or 'data instance' decl should+-- a) contain no type family applications+--    (vanilla synonyms are fine, though)+-- b) properly bind all their free type variables+--    e.g. we disallow (Trac #7536)+--         type T a = Int+--         type instance F (T a) = a+-- c) Have the right number of patterns+-- d) For associated types, are consistently instantiated+checkValidFamPats mb_clsinfo fam_tc tvs cvs ty_pats+  = do { -- A family instance must have exactly the same number of type+         -- parameters as the family declaration.  You can't write+         --     type family F a :: * -> *+         --     type instance F Int y = y+         -- because then the type (F Int) would be like (\y.y)+         checkTc (length ty_pats == fam_arity) $+           wrongNumberOfParmsErr (fam_arity - count isInvisibleTyConBinder fam_bndrs)+             -- report only explicit arguments++       ; mapM_ checkValidTypePat ty_pats++       ; let unbound_tcvs = filterOut (`elemVarSet` exactTyCoVarsOfTypes ty_pats) (tvs ++ cvs)+       ; checkTc (null unbound_tcvs) (famPatErr fam_tc unbound_tcvs ty_pats)++         -- Check that type patterns match the class instance head+       ; checkConsistentFamInst mb_clsinfo fam_tc tvs ty_pats }+  where+     fam_arity = tyConArity fam_tc+     fam_bndrs = tyConBinders fam_tc+++checkValidTypePat :: Type -> TcM ()+-- Used for type patterns in class instances,+-- and in type/data family instances+checkValidTypePat pat_ty+  = do { -- Check that pat_ty is a monotype+         checkValidMonoType pat_ty+             -- One could imagine generalising to allow+             --      instance C (forall a. a->a)+             -- but we don't know what all the consequences might be++          -- Ensure that no type family instances occur a type pattern+       ; checkTc (isTyFamFree pat_ty) $+         tyFamInstIllegalErr pat_ty }++isTyFamFree :: Type -> Bool+-- ^ Check that a type does not contain any type family applications.+isTyFamFree = null . tcTyFamInsts++-- Error messages++wrongNumberOfParmsErr :: Arity -> SDoc+wrongNumberOfParmsErr exp_arity+  = text "Number of parameters must match family declaration; expected"+    <+> ppr exp_arity++inaccessibleCoAxBranch :: CoAxiom br -> CoAxBranch -> SDoc+inaccessibleCoAxBranch fi_ax cur_branch+  = text "Type family instance equation is overlapped:" $$+    nest 2 (pprCoAxBranch fi_ax cur_branch)++tyFamInstIllegalErr :: Type -> SDoc+tyFamInstIllegalErr ty+  = hang (text "Illegal type synonym family application in instance" <>+         colon) 2 $+      ppr ty++nestedMsg :: SDoc -> SDoc+nestedMsg what+  = sep [ text "Illegal nested" <+> what+        , parens undecidableMsg ]++famPatErr :: TyCon -> [TyVar] -> [Type] -> SDoc+famPatErr fam_tc tvs pats+  = hang (text "Family instance purports to bind type variable" <> plural tvs+          <+> pprQuotedList tvs)+       2 (hang (text "but the real LHS (expanding synonyms) is:")+             2 (pprTypeApp fam_tc (map expandTypeSynonyms pats) <+>+                text "= ..."))++{-+************************************************************************+*                                                                      *+   Telescope checking+*                                                                      *+************************************************************************++Note [Bad telescopes]+~~~~~~~~~~~~~~~~~~~~~+Now that we can mix type and kind variables, there are an awful lot of+ways to shoot yourself in the foot. Here are some.++  data SameKind :: k -> k -> *   -- just to force unification++1.  data T1 a k (b :: k) (x :: SameKind a b)++The problem here is that we discover that a and b should have the same+kind. But this kind mentions k, which is bound *after* a.+(Testcase: dependent/should_fail/BadTelescope)++2.  data T2 a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d)++Note that b is not bound. Yet its kind mentions a. Because we have+a nice rule that all implicitly bound variables come before others,+this is bogus. (We could probably figure out to put b between a and c.+But I think this is doing users a disservice, in the long run.)+(Testcase: dependent/should_fail/BadTelescope4)++3. t3 :: forall a. (forall k (b :: k). SameKind a b) -> ()++This is a straightforward skolem escape. Note that a and b need to have+the same kind.+(Testcase: polykinds/T11142)++How do we deal with all of this? For TyCons, we have checkValidTyConTyVars.+That function looks to see if any of the tyConTyVars are repeated, but+it's really a telescope check. It works because all tycons are kind-generalized.+If there is a bad telescope, the kind-generalization will end up generalizing+over a variable bound later in the telescope.++For non-tycons, we do scope checking when we bring tyvars into scope,+in tcImplicitTKBndrs and tcExplicitTKBndrs. Note that we also have to+sort implicit binders into a well-scoped order whenever we have implicit+binders to worry about. This is done in quantifyTyVars and in+tcImplicitTKBndrs.+-}++-- | Check a list of binders to see if they make a valid telescope.+-- The key property we're checking for is scoping. For example:+-- > data SameKind :: k -> k -> *+-- > data X a k (b :: k) (c :: SameKind a b)+-- Kind inference says that a's kind should be k. But that's impossible,+-- because k isn't in scope when a is bound. This check has to come before+-- general validity checking, because once we kind-generalise, this sort+-- of problem is harder to spot (as we'll generalise over the unbound+-- k in a's type.) See also Note [Bad telescopes].+checkValidTelescope :: SDoc        -- the original user-written telescope+                    -> [TyVar]     -- explicit vars (not necessarily zonked)+                    -> SDoc        -- note to put at bottom of message+                    -> TcM ()+checkValidTelescope hs_tvs orig_tvs extra+  = discardResult $ checkZonkValidTelescope hs_tvs orig_tvs extra++-- | Like 'checkZonkValidTelescope', but returns the zonked tyvars+checkZonkValidTelescope :: SDoc+                        -> [TyVar]+                        -> SDoc+                        -> TcM [TyVar]+checkZonkValidTelescope hs_tvs orig_tvs extra+  = do { orig_tvs <- mapM zonkTyCoVarKind orig_tvs+       ; let (_, sorted_tidied_tvs) = tidyTyCoVarBndrs emptyTidyEnv $+                                      toposortTyVars orig_tvs+       ; unless (go [] emptyVarSet orig_tvs) $+         addErr $+         vcat [ hang (text "These kind and type variables:" <+> hs_tvs $$+                      text "are out of dependency order. Perhaps try this ordering:")+                   2 (sep (map pprTyVar sorted_tidied_tvs))+              , extra ]+       ; return orig_tvs }++  where+    go :: [TyVar]  -- misplaced variables+       -> TyVarSet -> [TyVar] -> Bool+    go errs in_scope [] = null (filter (`elemVarSet` in_scope) errs)+        -- report an error only when the variable in the kind is brought+        -- into scope later in the telescope. Otherwise, we'll just quantify+        -- over it in kindGeneralize, as we should.++    go errs in_scope  (tv:tvs)+      = let bad_tvs = filterOut (`elemVarSet` in_scope) $+                      tyCoVarsOfTypeList (tyVarKind tv)+        in go (bad_tvs ++ errs) (in_scope `extendVarSet` tv) tvs++-- | After inferring kinds of type variables, check to make sure that the+-- inferred kinds any of the type variables bound in a smaller scope.+-- This is a skolem escape check. See also Note [Bad telescopes].+checkValidInferredKinds :: [TyVar]     -- ^ vars to check (zonked)+                        -> TyVarSet    -- ^ vars out of scope+                        -> SDoc        -- ^ suffix to error message+                        -> TcM ()+checkValidInferredKinds orig_kvs out_of_scope extra+  = do { let bad_pairs = [ (tv, kv)+                         | kv <- orig_kvs+                         , Just tv <- map (lookupVarSet out_of_scope)+                                          (tyCoVarsOfTypeList (tyVarKind kv)) ]+             report (tidyTyVarOcc env -> tv, tidyTyVarOcc env -> kv)+               = addErr $+                 text "The kind of variable" <+>+                 quotes (ppr kv) <> text ", namely" <+>+                 quotes (ppr (tyVarKind kv)) <> comma $$+                 text "depends on variable" <+>+                 quotes (ppr tv) <+> text "from an inner scope" $$+                 text "Perhaps bind" <+> quotes (ppr kv) <+>+                 text "sometime after binding" <+>+                 quotes (ppr tv) $$+                 extra+       ; mapM_ report bad_pairs }++  where+    (env1, _) = tidyTyCoVarBndrs emptyTidyEnv orig_kvs+    (env, _)  = tidyTyCoVarBndrs env1         (nonDetEltsUniqSet out_of_scope)+      -- It's OK to use nonDetEltsUniqSet here because it's only used for+      -- generating the error message++{-+************************************************************************+*                                                                      *+\subsection{Auxiliary functions}+*                                                                      *+************************************************************************+-}++-- Free variables of a type, retaining repetitions, and expanding synonyms+fvType :: Type -> [TyCoVar]+fvType ty | Just exp_ty <- tcView ty = fvType exp_ty+fvType (TyVarTy tv)          = [tv]+fvType (TyConApp _ tys)      = fvTypes tys+fvType (LitTy {})            = []+fvType (AppTy fun arg)       = fvType fun ++ fvType arg+fvType (FunTy arg res)       = fvType arg ++ fvType res+fvType (ForAllTy (TvBndr tv _) ty)+  = fvType (tyVarKind tv) +++    filter (/= tv) (fvType ty)+fvType (CastTy ty co)        = fvType ty ++ fvCo co+fvType (CoercionTy co)       = fvCo co++fvTypes :: [Type] -> [TyVar]+fvTypes tys                = concat (map fvType tys)++fvCo :: Coercion -> [TyCoVar]+fvCo (Refl _ ty)            = fvType ty+fvCo (TyConAppCo _ _ args)  = concatMap fvCo args+fvCo (AppCo co arg)         = fvCo co ++ fvCo arg+fvCo (ForAllCo tv h co)     = filter (/= tv) (fvCo co) ++ fvCo h+fvCo (FunCo _ co1 co2)      = fvCo co1 ++ fvCo co2+fvCo (CoVarCo v)            = [v]+fvCo (AxiomInstCo _ _ args) = concatMap fvCo args+fvCo (UnivCo p _ t1 t2)     = fvProv p ++ fvType t1 ++ fvType t2+fvCo (SymCo co)             = fvCo co+fvCo (TransCo co1 co2)      = fvCo co1 ++ fvCo co2+fvCo (NthCo _ co)           = fvCo co+fvCo (LRCo _ co)            = fvCo co+fvCo (InstCo co arg)        = fvCo co ++ fvCo arg+fvCo (CoherenceCo co1 co2)  = fvCo co1 ++ fvCo co2+fvCo (KindCo co)            = fvCo co+fvCo (SubCo co)             = fvCo co+fvCo (AxiomRuleCo _ cs)     = concatMap fvCo cs++fvProv :: UnivCoProvenance -> [TyCoVar]+fvProv UnsafeCoerceProv    = []+fvProv (PhantomProv co)    = fvCo co+fvProv (ProofIrrelProv co) = fvCo co+fvProv (PluginProv _)      = []+fvProv (HoleProv h)        = pprPanic "fvProv falls into a hole" (ppr h)++sizeType :: Type -> Int+-- Size of a type: the number of variables and constructors+sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty+sizeType (TyVarTy {})      = 1+sizeType (TyConApp _ tys)  = sizeTypes tys + 1+sizeType (LitTy {})        = 1+sizeType (AppTy fun arg)   = sizeType fun + sizeType arg+sizeType (FunTy arg res)   = sizeType arg + sizeType res + 1+sizeType (ForAllTy _ ty)   = sizeType ty+sizeType (CastTy ty _)     = sizeType ty+sizeType (CoercionTy _)    = 1++sizeTypes :: [Type] -> Int+sizeTypes = sum . map sizeType++-- Size of a predicate+--+-- We are considering whether class constraints terminate.+-- Equality constraints and constraints for the implicit+-- parameter class always termiante so it is safe to say "size 0".+-- (Implicit parameter constraints always terminate because+-- there are no instances for them---they are only solved by+-- "local instances" in expressions).+-- See Trac #4200.+sizePred :: PredType -> Int+sizePred ty = goClass ty+  where+    goClass p = go (classifyPredType p)++    go (ClassPred cls tys')+      | isTerminatingClass cls = 0+      | otherwise = sizeTypes (filterOutInvisibleTypes (classTyCon cls) tys')+    go (EqPred {})        = 0+    go (IrredPred ty)     = sizeType ty++-- | When this says "True", ignore this class constraint during+-- a termination check+isTerminatingClass :: Class -> Bool+isTerminatingClass cls+  = isIPClass cls+    || cls `hasKey` typeableClassKey+    || cls `hasKey` coercibleTyConKey+    || cls `hasKey` eqTyConKey+    || cls `hasKey` heqTyConKey++-- | Tidy before printing a type+ppr_tidy :: TidyEnv -> Type -> SDoc+ppr_tidy env ty = pprType (tidyType env ty)++allDistinctTyVars :: TyVarSet -> [KindOrType] -> Bool+-- (allDistinctTyVars tvs tys) returns True if tys are+-- a) all tyvars+-- b) all distinct+-- c) disjoint from tvs+allDistinctTyVars _    [] = True+allDistinctTyVars tkvs (ty : tys)+  = case getTyVar_maybe ty of+      Nothing -> False+      Just tv | tv `elemVarSet` tkvs -> False+              | otherwise -> allDistinctTyVars (tkvs `extendVarSet` tv) tys
+ types/Class.hs view
@@ -0,0 +1,360 @@+-- (c) The University of Glasgow 2006+-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998+--+-- The @Class@ datatype++{-# LANGUAGE CPP #-}++module Class (+        Class,+        ClassOpItem,+        ClassATItem(..),+        ClassMinimalDef,+        DefMethInfo, pprDefMethInfo,++        FunDep, pprFundeps, pprFunDep,++        mkClass, mkAbstractClass, classTyVars, classArity,+        classKey, className, classATs, classATItems, classTyCon, classMethods,+        classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta,+        classAllSelIds, classSCSelId, classMinimalDef, classHasFds,+        isAbstractClass,+        naturallyCoherentClass+    ) where++#include "HsVersions.h"++import {-# SOURCE #-} TyCon     ( TyCon )+import {-# SOURCE #-} TyCoRep   ( Type, PredType, pprType )+import Var+import Name+import BasicTypes+import Unique+import Util+import SrcLoc+import PrelNames    ( eqTyConKey, coercibleTyConKey, typeableClassKey,+                      heqTyConKey )+import Outputable+import BooleanFormula (BooleanFormula, mkTrue)++import qualified Data.Data as Data++{-+************************************************************************+*                                                                      *+\subsection[Class-basic]{@Class@: basic definition}+*                                                                      *+************************************************************************++A @Class@ corresponds to a Greek kappa in the static semantics:+-}++data Class+  = Class {+        classTyCon :: TyCon,    -- The data type constructor for+                                -- dictionaries of this class+                                -- See Note [ATyCon for classes] in TyCoRep++        className :: Name,              -- Just the cached name of the TyCon+        classKey  :: Unique,            -- Cached unique of TyCon++        classTyVars  :: [TyVar],        -- The class kind and type variables;+                                        -- identical to those of the TyCon++        classFunDeps :: [FunDep TyVar],  -- The functional dependencies++        classBody :: ClassBody -- Superclasses, ATs, methods++     }++--  | e.g.+--+-- >  class C a b c | a b -> c, a c -> b where...+--+--  Here fun-deps are [([a,b],[c]), ([a,c],[b])]+--+--  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'',++-- For details on above see note [Api annotations] in ApiAnnotation+type FunDep a = ([a],[a])++type ClassOpItem = (Id, DefMethInfo)+        -- Selector function; contains unfolding+        -- Default-method info++type DefMethInfo = Maybe (Name, DefMethSpec Type)+   -- Nothing                    No default method+   -- Just ($dm, VanillaDM)      A polymorphic default method, name $dm+   -- Just ($gm, GenericDM ty)   A generic default method, name $gm, type ty+   --                              The generic dm type is *not* quantified+   --                              over the class variables; ie has the+   --                              class variables free++data ClassATItem+  = ATI TyCon         -- See Note [Associated type tyvar names]+        (Maybe (Type, SrcSpan))+                      -- Default associated type (if any) from this template+                      -- Note [Associated type defaults]++type ClassMinimalDef = BooleanFormula Name -- Required methods++data ClassBody+  = AbstractClass+  | ConcreteClass {+        -- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b)+        -- We need value-level selectors for both the dictionary+        -- superclasses and the equality superclasses+        classSCThetaStuff :: [PredType],     -- Immediate superclasses,+        classSCSels  :: [Id],           -- Selector functions to extract the+                                        --   superclasses from a+                                        --   dictionary of this class+        -- Associated types+        classATStuff :: [ClassATItem],  -- Associated type families++        -- Class operations (methods, not superclasses)+        classOpStuff :: [ClassOpItem],  -- Ordered by tag++        -- Minimal complete definition+        classMinimalDefStuff :: ClassMinimalDef+    }+    -- TODO: maybe super classes should be allowed in abstract class definitions++classMinimalDef :: Class -> ClassMinimalDef+classMinimalDef Class{ classBody = ConcreteClass{ classMinimalDefStuff = d } } = d+classMinimalDef _ = mkTrue -- TODO: make sure this is the right direction++{-+Note [Associated type defaults]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The following is an example of associated type defaults:+   class C a where+     data D a r++     type F x a b :: *+     type F p q r = (p,q)->r    -- Default++Note that++ * The TyCons for the associated types *share type variables* with the+   class, so that we can tell which argument positions should be+   instantiated in an instance decl.  (The first for 'D', the second+   for 'F'.)++ * We can have default definitions only for *type* families,+   not data families++ * In the default decl, the "patterns" should all be type variables,+   but (in the source language) they don't need to be the same as in+   the 'type' decl signature or the class.  It's more like a+   free-standing 'type instance' declaration.++ * HOWEVER, in the internal ClassATItem we rename the RHS to match the+   tyConTyVars of the family TyCon.  So in the example above we'd get+   a ClassATItem of+        ATI F ((x,a) -> b)+   So the tyConTyVars of the family TyCon bind the free vars of+   the default Type rhs++The @mkClass@ function fills in the indirect superclasses.++The SrcSpan is for the entire original declaration.+-}++mkClass :: Name -> [TyVar]+        -> [FunDep TyVar]+        -> [PredType] -> [Id]+        -> [ClassATItem]+        -> [ClassOpItem]+        -> ClassMinimalDef+        -> TyCon+        -> Class++mkClass cls_name tyvars fds super_classes superdict_sels at_stuff+        op_stuff mindef tycon+  = Class { classKey     = nameUnique cls_name,+            className    = cls_name,+                -- NB:  tyConName tycon = cls_name,+                -- But it takes a module loop to assert it here+            classTyVars  = tyvars,+            classFunDeps = fds,+            classBody = ConcreteClass {+                    classSCThetaStuff = super_classes,+                    classSCSels  = superdict_sels,+                    classATStuff = at_stuff,+                    classOpStuff = op_stuff,+                    classMinimalDefStuff = mindef+                },+            classTyCon   = tycon }++mkAbstractClass :: Name -> [TyVar]+        -> [FunDep TyVar]+        -> TyCon+        -> Class++mkAbstractClass cls_name tyvars fds tycon+  = Class { classKey     = nameUnique cls_name,+            className    = cls_name,+                -- NB:  tyConName tycon = cls_name,+                -- But it takes a module loop to assert it here+            classTyVars  = tyvars,+            classFunDeps = fds,+            classBody = AbstractClass,+            classTyCon   = tycon }++{-+Note [Associated type tyvar names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The TyCon of an associated type should use the same variable names as its+parent class. Thus+    class C a b where+      type F b x a :: *+We make F use the same Name for 'a' as C does, and similary 'b'.++The reason for this is when checking instances it's easier to match+them up, to ensure they match.  Eg+    instance C Int [d] where+      type F [d] x Int = ....+we should make sure that the first and third args match the instance+header.++Having the same variables for class and tycon is also used in checkValidRoles+(in TcTyClsDecls) when checking a class's roles.+++************************************************************************+*                                                                      *+\subsection[Class-selectors]{@Class@: simple selectors}+*                                                                      *+************************************************************************++The rest of these functions are just simple selectors.+-}++classArity :: Class -> Arity+classArity clas = length (classTyVars clas)+        -- Could memoise this++classAllSelIds :: Class -> [Id]+-- Both superclass-dictionary and method selectors+classAllSelIds c@(Class { classBody = ConcreteClass { classSCSels = sc_sels }})+  = sc_sels ++ classMethods c+classAllSelIds c = ASSERT( null (classMethods c) ) []++classSCSelId :: Class -> Int -> Id+-- Get the n'th superclass selector Id+-- where n is 0-indexed, and counts+--    *all* superclasses including equalities+classSCSelId (Class { classBody = ConcreteClass { classSCSels = sc_sels } }) n+  = ASSERT( n >= 0 && n < length sc_sels )+    sc_sels !! n+classSCSelId c n = pprPanic "classSCSelId" (ppr c <+> ppr n)++classMethods :: Class -> [Id]+classMethods (Class { classBody = ConcreteClass { classOpStuff = op_stuff } })+  = [op_sel | (op_sel, _) <- op_stuff]+classMethods _ = []++classOpItems :: Class -> [ClassOpItem]+classOpItems (Class { classBody = ConcreteClass { classOpStuff = op_stuff }})+  = op_stuff+classOpItems _ = []++classATs :: Class -> [TyCon]+classATs (Class { classBody = ConcreteClass { classATStuff = at_stuff } })+  = [tc | ATI tc _ <- at_stuff]+classATs _ = []++classATItems :: Class -> [ClassATItem]+classATItems (Class { classBody = ConcreteClass { classATStuff = at_stuff }})+  = at_stuff+classATItems _ = []++classSCTheta :: Class -> [PredType]+classSCTheta (Class { classBody = ConcreteClass { classSCThetaStuff = theta_stuff }})+  = theta_stuff+classSCTheta _ = []++classTvsFds :: Class -> ([TyVar], [FunDep TyVar])+classTvsFds c = (classTyVars c, classFunDeps c)++classHasFds :: Class -> Bool+classHasFds (Class { classFunDeps = fds }) = not (null fds)++classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem])+classBigSig (Class {classTyVars = tyvars,+                    classBody = AbstractClass})+  = (tyvars, [], [], [])+classBigSig (Class {classTyVars = tyvars,+                    classBody = ConcreteClass {+                        classSCThetaStuff = sc_theta,+                        classSCSels = sc_sels,+                        classOpStuff = op_stuff+                    }})+  = (tyvars, sc_theta, sc_sels, op_stuff)++classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [ClassATItem], [ClassOpItem])+classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,+                         classBody = AbstractClass})+  = (tyvars, fundeps, [], [], [], [])+classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,+                         classBody = ConcreteClass {+                             classSCThetaStuff = sc_theta, classSCSels = sc_sels,+                             classATStuff = ats, classOpStuff = op_stuff+                         }})+  = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff)++isAbstractClass :: Class -> Bool+isAbstractClass Class{ classBody = AbstractClass } = True+isAbstractClass _ = False++-- | If a class is "naturally coherent", then we needn't worry at all, in any+-- way, about overlapping/incoherent instances. Just solve the thing!+naturallyCoherentClass :: Class -> Bool+-- See also Note [The equality class story] in TysPrim.+naturallyCoherentClass cls+  = cls `hasKey` heqTyConKey ||+    cls `hasKey` eqTyConKey ||+    cls `hasKey` coercibleTyConKey ||+    cls `hasKey` typeableClassKey++{-+************************************************************************+*                                                                      *+\subsection[Class-instances]{Instance declarations for @Class@}+*                                                                      *+************************************************************************++We compare @Classes@ by their keys (which include @Uniques@).+-}++instance Eq Class where+    c1 == c2 = classKey c1 == classKey c2+    c1 /= c2 = classKey c1 /= classKey c2++instance Uniquable Class where+    getUnique c = classKey c++instance NamedThing Class where+    getName clas = className clas++instance Outputable Class where+    ppr c = ppr (getName c)++pprDefMethInfo :: DefMethInfo -> SDoc+pprDefMethInfo Nothing                  = empty   -- No default method+pprDefMethInfo (Just (n, VanillaDM))    = text "Default method" <+> ppr n+pprDefMethInfo (Just (n, GenericDM ty)) = text "Generic default method"+                                          <+> ppr n <+> dcolon <+> pprType ty++pprFundeps :: Outputable a => [FunDep a] -> SDoc+pprFundeps []  = empty+pprFundeps fds = hsep (vbar : punctuate comma (map pprFunDep fds))++pprFunDep :: Outputable a => FunDep a -> SDoc+pprFunDep (us, vs) = hsep [interppSP us, arrow, interppSP vs]++instance Data.Data Class where+    -- don't traverse?+    toConstr _   = abstractConstr "Class"+    gunfold _ _  = error "gunfold"+    dataTypeOf _ = mkNoRepType "Class"
+ types/CoAxiom.hs view
@@ -0,0 +1,517 @@+-- (c) The University of Glasgow 2012++{-# LANGUAGE CPP, DataKinds, DeriveDataTypeable, GADTs, KindSignatures,+             ScopedTypeVariables, StandaloneDeriving, RoleAnnotations #-}++-- | Module for coercion axioms, used to represent type family instances+-- and newtypes++module CoAxiom (+       BranchFlag, Branched, Unbranched, BranchIndex, Branches,+       manyBranches, unbranched,+       fromBranches, numBranches,+       mapAccumBranches,++       CoAxiom(..), CoAxBranch(..),++       toBranchedAxiom, toUnbranchedAxiom,+       coAxiomName, coAxiomArity, coAxiomBranches,+       coAxiomTyCon, isImplicitCoAxiom, coAxiomNumPats,+       coAxiomNthBranch, coAxiomSingleBranch_maybe, coAxiomRole,+       coAxiomSingleBranch, coAxBranchTyVars, coAxBranchCoVars,+       coAxBranchRoles,+       coAxBranchLHS, coAxBranchRHS, coAxBranchSpan, coAxBranchIncomps,+       placeHolderIncomps,++       Role(..), fsFromRole,++       CoAxiomRule(..), TypeEqn,+       BuiltInSynFamily(..), trivialBuiltInFamily+       ) where++import {-# SOURCE #-} TyCoRep ( Type, pprType )+import {-# SOURCE #-} TyCon ( TyCon )+import Outputable+import FastString+import Name+import Unique+import Var+import Util+import Binary+import Pair+import BasicTypes+import Data.Typeable ( Typeable )+import SrcLoc+import qualified Data.Data as Data+import Data.Array+import Data.List ( mapAccumL )++#include "HsVersions.h"++{-+Note [Coercion axiom branches]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In order to allow closed type families, an axiom needs to contain an+ordered list of alternatives, called branches. The kind of the coercion built+from an axiom is determined by which index is used when building the coercion+from the axiom.++For example, consider the axiom derived from the following declaration:++type family F a where+  F [Int] = Bool+  F [a]   = Double+  F (a b) = Char++This will give rise to this axiom:++axF :: {                                         F [Int] ~ Bool+       ; forall (a :: *).                        F [a]   ~ Double+       ; forall (k :: *) (a :: k -> *) (b :: k). F (a b) ~ Char+       }++The axiom is used with the AxiomInstCo constructor of Coercion. If we wish+to have a coercion showing that F (Maybe Int) ~ Char, it will look like++axF[2] <*> <Maybe> <Int> :: F (Maybe Int) ~ Char+-- or, written using concrete-ish syntax --+AxiomInstCo axF 2 [Refl *, Refl Maybe, Refl Int]++Note that the index is 0-based.++For type-checking, it is also necessary to check that no previous pattern+can unify with the supplied arguments. After all, it is possible that some+of the type arguments are lambda-bound type variables whose instantiation may+cause an earlier match among the branches. We wish to prohibit this behavior,+so the type checker rules out the choice of a branch where a previous branch+can unify. See also [Apartness] in FamInstEnv.hs.++For example, the following is malformed, where 'a' is a lambda-bound type+variable:++axF[2] <*> <a> <Bool> :: F (a Bool) ~ Char++Why? Because a might be instantiated with [], meaning that branch 1 should+apply, not branch 2. This is a vital consistency check; without it, we could+derive Int ~ Bool, and that is a Bad Thing.++Note [Branched axioms]+~~~~~~~~~~~~~~~~~~~~~~+Although a CoAxiom has the capacity to store many branches, in certain cases,+we want only one. These cases are in data/newtype family instances, newtype+coercions, and type family instances.+Furthermore, these unbranched axioms are used in a+variety of places throughout GHC, and it would difficult to generalize all of+that code to deal with branched axioms, especially when the code can be sure+of the fact that an axiom is indeed a singleton. At the same time, it seems+dangerous to assume singlehood in various places through GHC.++The solution to this is to label a CoAxiom with a phantom type variable+declaring whether it is known to be a singleton or not. The branches+are stored using a special datatype, declared below, that ensures that the+type variable is accurate.++************************************************************************+*                                                                      *+                    Branches+*                                                                      *+************************************************************************+-}++type BranchIndex = Int  -- The index of the branch in the list of branches+                        -- Counting from zero++-- promoted data type+data BranchFlag = Branched | Unbranched+type Branched = 'Branched+type Unbranched = 'Unbranched+-- By using type synonyms for the promoted constructors, we avoid needing+-- DataKinds and the promotion quote in client modules. This also means that+-- we don't need to export the term-level constructors, which should never be used.++newtype Branches (br :: BranchFlag)+  = MkBranches { unMkBranches :: Array BranchIndex CoAxBranch }+type role Branches nominal++manyBranches :: [CoAxBranch] -> Branches Branched+manyBranches brs = ASSERT( snd bnds >= fst bnds )+                   MkBranches (listArray bnds brs)+  where+    bnds = (0, length brs - 1)++unbranched :: CoAxBranch -> Branches Unbranched+unbranched br = MkBranches (listArray (0, 0) [br])++toBranched :: Branches br -> Branches Branched+toBranched = MkBranches . unMkBranches++toUnbranched :: Branches br -> Branches Unbranched+toUnbranched (MkBranches arr) = ASSERT( bounds arr == (0,0) )+                                MkBranches arr++fromBranches :: Branches br -> [CoAxBranch]+fromBranches = elems . unMkBranches++branchesNth :: Branches br -> BranchIndex -> CoAxBranch+branchesNth (MkBranches arr) n = arr ! n++numBranches :: Branches br -> Int+numBranches (MkBranches arr) = snd (bounds arr) + 1++-- | The @[CoAxBranch]@ passed into the mapping function is a list of+-- all previous branches, reversed+mapAccumBranches :: ([CoAxBranch] -> CoAxBranch -> CoAxBranch)+                  -> Branches br -> Branches br+mapAccumBranches f (MkBranches arr)+  = MkBranches (listArray (bounds arr) (snd $ mapAccumL go [] (elems arr)))+  where+    go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch)+    go prev_branches cur_branch = ( cur_branch : prev_branches+                                  , f prev_branches cur_branch )+++{-+************************************************************************+*                                                                      *+                    Coercion axioms+*                                                                      *+************************************************************************++Note [Storing compatibility]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+During axiom application, we need to be aware of which branches are compatible+with which others. The full explanation is in Note [Compatibility] in+FamInstEnv. (The code is placed there to avoid a dependency from CoAxiom on+the unification algorithm.) Although we could theoretically compute+compatibility on the fly, this is silly, so we store it in a CoAxiom.++Specifically, each branch refers to all other branches with which it is+incompatible. This list might well be empty, and it will always be for the+first branch of any axiom.++CoAxBranches that do not (yet) belong to a CoAxiom should have a panic thunk+stored in cab_incomps. The incompatibilities are properly a property of the+axiom as a whole, and they are computed only when the final axiom is built.++During serialization, the list is converted into a list of the indices+of the branches.+-}++-- | A 'CoAxiom' is a \"coercion constructor\", i.e. a named equality axiom.++-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism] in coreSyn/CoreLint.hs+data CoAxiom br+  = CoAxiom                   -- Type equality axiom.+    { co_ax_unique   :: Unique        -- Unique identifier+    , co_ax_name     :: Name          -- Name for pretty-printing+    , co_ax_role     :: Role          -- Role of the axiom's equality+    , co_ax_tc       :: TyCon         -- The head of the LHS patterns+                                      -- e.g.  the newtype or family tycon+    , co_ax_branches :: Branches br   -- The branches that form this axiom+    , co_ax_implicit :: Bool          -- True <=> the axiom is "implicit"+                                      -- See Note [Implicit axioms]+         -- INVARIANT: co_ax_implicit == True implies length co_ax_branches == 1.+    }++data CoAxBranch+  = CoAxBranch+    { cab_loc      :: SrcSpan       -- Location of the defining equation+                                    -- See Note [CoAxiom locations]+    , cab_tvs      :: [TyVar]       -- Bound type variables; not necessarily fresh+                                    -- See Note [CoAxBranch type variables]+    , cab_cvs      :: [CoVar]       -- Bound coercion variables+                                    -- Always empty, for now.+                                    -- See Note [Constraints in patterns]+                                    -- in TcTyClsDecls+    , cab_roles    :: [Role]        -- See Note [CoAxBranch roles]+    , cab_lhs      :: [Type]        -- Type patterns to match against+                                    -- See Note [CoAxiom saturation]+    , cab_rhs      :: Type          -- Right-hand side of the equality+    , cab_incomps  :: [CoAxBranch]  -- The previous incompatible branches+                                    -- See Note [Storing compatibility]+    }+  deriving Data.Data++toBranchedAxiom :: CoAxiom br -> CoAxiom Branched+toBranchedAxiom (CoAxiom unique name role tc branches implicit)+  = CoAxiom unique name role tc (toBranched branches) implicit++toUnbranchedAxiom :: CoAxiom br -> CoAxiom Unbranched+toUnbranchedAxiom (CoAxiom unique name role tc branches implicit)+  = CoAxiom unique name role tc (toUnbranched branches) implicit++coAxiomNumPats :: CoAxiom br -> Int+coAxiomNumPats = length . coAxBranchLHS . (flip coAxiomNthBranch 0)++coAxiomNthBranch :: CoAxiom br -> BranchIndex -> CoAxBranch+coAxiomNthBranch (CoAxiom { co_ax_branches = bs }) index+  = branchesNth bs index++coAxiomArity :: CoAxiom br -> BranchIndex -> Arity+coAxiomArity ax index+  = length tvs + length cvs+  where+    CoAxBranch { cab_tvs = tvs, cab_cvs = cvs } = coAxiomNthBranch ax index++coAxiomName :: CoAxiom br -> Name+coAxiomName = co_ax_name++coAxiomRole :: CoAxiom br -> Role+coAxiomRole = co_ax_role++coAxiomBranches :: CoAxiom br -> Branches br+coAxiomBranches = co_ax_branches++coAxiomSingleBranch_maybe :: CoAxiom br -> Maybe CoAxBranch+coAxiomSingleBranch_maybe (CoAxiom { co_ax_branches = MkBranches arr })+  | snd (bounds arr) == 0+  = Just $ arr ! 0+  | otherwise+  = Nothing++coAxiomSingleBranch :: CoAxiom Unbranched -> CoAxBranch+coAxiomSingleBranch (CoAxiom { co_ax_branches = MkBranches arr })+  = arr ! 0++coAxiomTyCon :: CoAxiom br -> TyCon+coAxiomTyCon = co_ax_tc++coAxBranchTyVars :: CoAxBranch -> [TyVar]+coAxBranchTyVars = cab_tvs++coAxBranchCoVars :: CoAxBranch -> [CoVar]+coAxBranchCoVars = cab_cvs++coAxBranchLHS :: CoAxBranch -> [Type]+coAxBranchLHS = cab_lhs++coAxBranchRHS :: CoAxBranch -> Type+coAxBranchRHS = cab_rhs++coAxBranchRoles :: CoAxBranch -> [Role]+coAxBranchRoles = cab_roles++coAxBranchSpan :: CoAxBranch -> SrcSpan+coAxBranchSpan = cab_loc++isImplicitCoAxiom :: CoAxiom br -> Bool+isImplicitCoAxiom = co_ax_implicit++coAxBranchIncomps :: CoAxBranch -> [CoAxBranch]+coAxBranchIncomps = cab_incomps++-- See Note [Compatibility checking] in FamInstEnv+placeHolderIncomps :: [CoAxBranch]+placeHolderIncomps = panic "placeHolderIncomps"++{- Note [CoAxiom saturation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* When co++Note [CoAxBranch type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the case of a CoAxBranch of an associated type-family instance,+we use the *same* type variables (where possible) as the+enclosing class or instance.  Consider+   class C a b where+     type F x b+     type F [y] b = ...     -- Second param must be b++   instance C Int [z] where+     type F Int [z] = ...   -- Second param must be [z]++In the CoAxBranch in the instance decl (F Int [z]) we use the+same 'z', so that it's easy to check that that type is the same+as that in the instance header.++Similarly in the CoAxBranch for the default decl for F in the+class decl, we use the same 'b' to make the same check easy.++So, unlike FamInsts, there is no expectation that the cab_tvs+are fresh wrt each other, or any other CoAxBranch.++Note [CoAxBranch roles]+~~~~~~~~~~~~~~~~~~~~~~~+Consider this code:++  newtype Age = MkAge Int+  newtype Wrap a = MkWrap a++  convert :: Wrap Age -> Int+  convert (MkWrap (MkAge i)) = i++We want this to compile to:++  NTCo:Wrap :: forall a. Wrap a ~R a+  NTCo:Age  :: Age ~R Int+  convert = \x -> x |> (NTCo:Wrap[0] NTCo:Age[0])++But, note that NTCo:Age is at role R. Thus, we need to be able to pass+coercions at role R into axioms. However, we don't *always* want to be able to+do this, as it would be disastrous with type families. The solution is to+annotate the arguments to the axiom with roles, much like we annotate tycon+tyvars. Where do these roles get set? Newtype axioms inherit their roles from+the newtype tycon; family axioms are all at role N.++Note [CoAxiom locations]+~~~~~~~~~~~~~~~~~~~~~~~~+The source location of a CoAxiom is stored in two places in the+datatype tree.+  * The first is in the location info buried in the Name of the+    CoAxiom. This span includes all of the branches of a branched+    CoAxiom.+  * The second is in the cab_loc fields of the CoAxBranches.++In the case of a single branch, we can extract the source location of+the branch from the name of the CoAxiom. In other cases, we need an+explicit SrcSpan to correctly store the location of the equation+giving rise to the FamInstBranch.++Note [Implicit axioms]+~~~~~~~~~~~~~~~~~~~~~~+See also Note [Implicit TyThings] in HscTypes+* A CoAxiom arising from data/type family instances is not "implicit".+  That is, it has its own IfaceAxiom declaration in an interface file++* The CoAxiom arising from a newtype declaration *is* "implicit".+  That is, it does not have its own IfaceAxiom declaration in an+  interface file; instead the CoAxiom is generated by type-checking+  the newtype declaration+-}++instance Eq (CoAxiom br) where+    a == b = getUnique a == getUnique b+    a /= b = getUnique a /= getUnique b++instance Uniquable (CoAxiom br) where+    getUnique = co_ax_unique++instance Outputable (CoAxiom br) where+    ppr = ppr . getName++instance NamedThing (CoAxiom br) where+    getName = co_ax_name++instance Typeable br => Data.Data (CoAxiom br) where+    -- don't traverse?+    toConstr _   = abstractConstr "CoAxiom"+    gunfold _ _  = error "gunfold"+    dataTypeOf _ = mkNoRepType "CoAxiom"++instance Outputable CoAxBranch where+  ppr (CoAxBranch { cab_loc = loc+                  , cab_lhs = lhs+                  , cab_rhs = rhs }) =+    text "CoAxBranch" <+> parens (ppr loc) <> colon+      <+> brackets (fsep (punctuate comma (map pprType lhs)))+      <+> text "=>" <+> pprType rhs++{-+************************************************************************+*                                                                      *+                    Roles+*                                                                      *+************************************************************************++Roles are defined here to avoid circular dependencies.+-}++-- See Note [Roles] in Coercion+-- defined here to avoid cyclic dependency with Coercion+--+-- Order of constructors matters: the Ord instance coincides with the *super*typing+-- relation on roles.+data Role = Nominal | Representational | Phantom+  deriving (Eq, Ord, Data.Data)++-- These names are slurped into the parser code. Changing these strings+-- will change the **surface syntax** that GHC accepts! If you want to+-- change only the pretty-printing, do some replumbing. See+-- mkRoleAnnotDecl in RdrHsSyn+fsFromRole :: Role -> FastString+fsFromRole Nominal          = fsLit "nominal"+fsFromRole Representational = fsLit "representational"+fsFromRole Phantom          = fsLit "phantom"++instance Outputable Role where+  ppr = ftext . fsFromRole++instance Binary Role where+  put_ bh Nominal          = putByte bh 1+  put_ bh Representational = putByte bh 2+  put_ bh Phantom          = putByte bh 3++  get bh = do tag <- getByte bh+              case tag of 1 -> return Nominal+                          2 -> return Representational+                          3 -> return Phantom+                          _ -> panic ("get Role " ++ show tag)++{-+************************************************************************+*                                                                      *+                    CoAxiomRule+              Rules for building Evidence+*                                                                      *+************************************************************************++Conditional axioms.  The general idea is that a `CoAxiomRule` looks like this:++    forall as. (r1 ~ r2, s1 ~ s2) => t1 ~ t2++My intention is to reuse these for both (~) and (~#).+The short-term plan is to use this datatype to represent the type-nat axioms.+In the longer run, it may be good to unify this and `CoAxiom`,+as `CoAxiom` is the special case when there are no assumptions.+-}++-- | A more explicit representation for `t1 ~ t2`.+type TypeEqn = Pair Type++-- | For now, we work only with nominal equality.+data CoAxiomRule = CoAxiomRule+  { coaxrName      :: FastString+  , coaxrAsmpRoles :: [Role]    -- roles of parameter equations+  , coaxrRole      :: Role      -- role of resulting equation+  , coaxrProves    :: [TypeEqn] -> Maybe TypeEqn+        -- ^ coaxrProves returns @Nothing@ when it doesn't like+        -- the supplied arguments.  When this happens in a coercion+        -- that means that the coercion is ill-formed, and Core Lint+        -- checks for that.+  }++instance Data.Data CoAxiomRule where+  -- don't traverse?+  toConstr _   = abstractConstr "CoAxiomRule"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "CoAxiomRule"++instance Uniquable CoAxiomRule where+  getUnique = getUnique . coaxrName++instance Eq CoAxiomRule where+  x == y = coaxrName x == coaxrName y++instance Ord CoAxiomRule where+  compare x y = compare (coaxrName x) (coaxrName y)++instance Outputable CoAxiomRule where+  ppr = ppr . coaxrName+++-- Type checking of built-in families+data BuiltInSynFamily = BuiltInSynFamily+  { sfMatchFam      :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+  , sfInteractTop   :: [Type] -> Type -> [TypeEqn]+  , sfInteractInert :: [Type] -> Type ->+                       [Type] -> Type -> [TypeEqn]+  }++-- Provides default implementations that do nothing.+trivialBuiltInFamily :: BuiltInSynFamily+trivialBuiltInFamily = BuiltInSynFamily+  { sfMatchFam      = \_ -> Nothing+  , sfInteractTop   = \_ _ -> []+  , sfInteractInert = \_ _ _ _ -> []+  }
+ types/Coercion.hs view
@@ -0,0 +1,1961 @@+{-+(c) The University of Glasgow 2006+-}++{-# LANGUAGE RankNTypes, CPP, MultiWayIf, FlexibleContexts #-}++-- | Module for (a) type kinds and (b) type coercions,+-- as used in System FC. See 'CoreSyn.Expr' for+-- more on System FC and how coercions fit into it.+--+module Coercion (+        -- * Main data type+        Coercion, CoercionN, CoercionR, CoercionP,+        UnivCoProvenance, CoercionHole, LeftOrRight(..),+        Var, CoVar, TyCoVar,+        Role(..), ltRole,++        -- ** Functions over coercions+        coVarTypes, coVarKind, coVarKindsTypesRole, coVarRole,+        coercionType, coercionKind, coercionKinds,+        mkCoercionType,+        coercionRole, coercionKindRole,++        -- ** Constructing coercions+        mkReflCo, mkRepReflCo, mkNomReflCo,+        mkCoVarCo, mkCoVarCos,+        mkAxInstCo, mkUnbranchedAxInstCo,+        mkAxInstRHS, mkUnbranchedAxInstRHS,+        mkAxInstLHS, mkUnbranchedAxInstLHS,+        mkPiCo, mkPiCos, mkCoCast,+        mkSymCo, mkTransCo, mkTransAppCo,+        mkNthCo, mkNthCoRole, mkLRCo,+        mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo, mkFunCos,+        mkForAllCo, mkForAllCos, mkHomoForAllCos, mkHomoForAllCos_NoRefl,+        mkPhantomCo, mkHomoPhantomCo, toPhantomCo,+        mkUnsafeCo, mkHoleCo, mkUnivCo, mkSubCo,+        mkAxiomInstCo, mkProofIrrelCo,+        downgradeRole, maybeSubCo, mkAxiomRuleCo,+        mkCoherenceCo, mkCoherenceRightCo, mkCoherenceLeftCo,+        mkKindCo, castCoercionKind,++        mkHeteroCoercionType,++        -- ** Decomposition+        instNewTyCon_maybe,++        NormaliseStepper, NormaliseStepResult(..), composeSteppers,+        mapStepResult, unwrapNewTypeStepper,+        topNormaliseNewType_maybe, topNormaliseTypeX,++        decomposeCo, decomposeFunCo, getCoVar_maybe,+        splitTyConAppCo_maybe,+        splitAppCo_maybe,+        splitFunCo_maybe,+        splitForAllCo_maybe,++        nthRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe,++        pickLR,++        isReflCo, isReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe,+        isReflCoVar_maybe,++        -- ** Coercion variables+        mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique,+        isCoVar_maybe,++        -- ** Free variables+        tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo,+        tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoDSet,+        coercionSize,++        -- ** Substitution+        CvSubstEnv, emptyCvSubstEnv,+        lookupCoVar,+        substCo, substCos, substCoVar, substCoVars, substCoWith,+        substCoVarBndr,+        extendTvSubstAndInScope, getCvSubstEnv,++        -- ** Lifting+        liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx,+        emptyLiftingContext, extendLiftingContext,+        liftCoSubstVarBndrCallback, isMappedByLC,++        mkSubstLiftingContext, zapLiftingContext,+        substForAllCoBndrCallbackLC, lcTCvSubst, lcInScopeSet,++        LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight,+        substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight,++        -- ** Comparison+        eqCoercion, eqCoercionX,++        -- ** Forcing evaluation of coercions+        seqCo,++        -- * Pretty-printing+        pprCo, pprParendCo, pprCoBndr,+        pprCoAxiom, pprCoAxBranch, pprCoAxBranchHdr,++        -- * Tidying+        tidyCo, tidyCos,++        -- * Other+        promoteCoercion+       ) where++#include "HsVersions.h"++import TyCoRep+import Type+import TyCon+import CoAxiom+import Var+import VarEnv+import Name hiding ( varName )+import Util+import BasicTypes+import Outputable+import Unique+import Pair+import SrcLoc+import PrelNames+import TysPrim          ( eqPhantPrimTyCon )+import ListSetOps+import Maybes+import UniqFM++import Control.Monad (foldM)+import Control.Arrow ( first )+import Data.Function ( on )++{-+%************************************************************************+%*                                                                      *+     -- The coercion arguments always *precisely* saturate+     -- arity of (that branch of) the CoAxiom.  If there are+     -- any left over, we use AppCo.  See+     -- See [Coercion axioms applied to coercions] in TyCoRep++\subsection{Coercion variables}+%*                                                                      *+%************************************************************************+-}++coVarName :: CoVar -> Name+coVarName = varName++setCoVarUnique :: CoVar -> Unique -> CoVar+setCoVarUnique = setVarUnique++setCoVarName :: CoVar -> Name -> CoVar+setCoVarName   = setVarName+++{-+%************************************************************************+%*                                                                      *+                   Pretty-printing coercions+%*                                                                      *+%************************************************************************++@pprCo@ is the standard @Coercion@ printer; the overloaded @ppr@+function is defined to use this.  @pprParendCo@ is the same, except it+puts parens around the type, except for the atomic cases.+@pprParendCo@ works just by setting the initial context precedence+very high.+-}++-- Outputable instances are in TyCoRep, to avoid orphans++pprCo, pprParendCo :: Coercion -> SDoc+pprCo       co = ppr_co TopPrec   co+pprParendCo co = ppr_co TyConPrec co++ppr_co :: TyPrec -> Coercion -> SDoc+ppr_co _ (Refl r ty) = angleBrackets (ppr ty) <> ppr_role r++ppr_co _ (TyConAppCo r tc cos) = pprTcAppCo TyConPrec ppr_co tc cos <> ppr_role r+ppr_co p (AppCo co arg)        = maybeParen p TyConPrec $+                                 pprCo co <+> ppr_co TyConPrec arg+ppr_co p co@(ForAllCo {})      = ppr_forall_co p co+ppr_co p co@(FunCo {})         = ppr_fun_co p co+ppr_co _ (CoVarCo cv)          = parenSymOcc (getOccName cv) (ppr cv)+ppr_co p (AxiomInstCo con index args)+  = pprPrefixApp p (ppr (getName con) <> brackets (ppr index))+                   (map (ppr_co TyConPrec) args)++ppr_co p co@(TransCo {}) = maybeParen p FunPrec $+                           case trans_co_list co [] of+                             [] -> panic "ppr_co"+                             (co:cos) -> sep ( ppr_co FunPrec co+                                             : [ char ';' <+> ppr_co FunPrec co | co <- cos])+ppr_co p (InstCo co arg) = maybeParen p TyConPrec $+                           pprParendCo co <> text "@" <> ppr_co TopPrec arg++ppr_co p (UnivCo UnsafeCoerceProv r ty1 ty2)+  = pprPrefixApp p (text "UnsafeCo" <+> ppr r)+                   [pprParendType ty1, pprParendType ty2]+ppr_co _ (UnivCo p r t1 t2)+  = char 'U'+    <> parens (ppr_prov <> comma <+> ppr t1 <> comma <+> ppr t2)+    <> ppr_role r+  where+    ppr_prov = case p of+      HoleProv h          -> text "hole:"   <> ppr h+      PhantomProv kind_co -> text "phant:"  <> ppr kind_co+      ProofIrrelProv co   -> text "irrel:"  <> ppr co+      PluginProv s        -> text "plugin:" <> text s+      UnsafeCoerceProv    -> text "unsafe"++ppr_co p (SymCo co)          = pprPrefixApp p (text "Sym") [pprParendCo co]+ppr_co p (NthCo n co)        = pprPrefixApp p (text "Nth:" <> int n) [pprParendCo co]+ppr_co p (LRCo sel co)       = pprPrefixApp p (ppr sel) [pprParendCo co]+ppr_co p (CoherenceCo c1 c2) = maybeParen p TyConPrec $+                               (ppr_co FunPrec c1) <+> (text "|>") <+>+                               (ppr_co FunPrec c2)+ppr_co p (KindCo co)         = pprPrefixApp p (text "kind") [pprParendCo co]+ppr_co p (SubCo co)         = pprPrefixApp p (text "Sub") [pprParendCo co]+ppr_co p (AxiomRuleCo co cs) = maybeParen p TopPrec $ ppr_axiom_rule_co co cs++ppr_axiom_rule_co :: CoAxiomRule -> [Coercion] -> SDoc+ppr_axiom_rule_co co ps = ppr (coaxrName co) <+> parens (interpp'SP ps)++ppr_role :: Role -> SDoc+ppr_role r = underscore <> pp_role+  where pp_role = case r of+                    Nominal          -> char 'N'+                    Representational -> char 'R'+                    Phantom          -> char 'P'++trans_co_list :: Coercion -> [Coercion] -> [Coercion]+trans_co_list (TransCo co1 co2) cos = trans_co_list co1 (trans_co_list co2 cos)+trans_co_list co                cos = co : cos++ppr_fun_co :: TyPrec -> Coercion -> SDoc+ppr_fun_co p co = pprArrowChain p (split co)+  where+    split :: Coercion -> [SDoc]+    split (FunCo _ arg res)+      = ppr_co FunPrec arg : split res+    split co = [ppr_co TopPrec co]++ppr_forall_co :: TyPrec -> Coercion -> SDoc+ppr_forall_co p (ForAllCo tv h co)+  = maybeParen p FunPrec $+    sep [pprCoBndr (tyVarName tv) h, ppr_co TopPrec co]+ppr_forall_co _ _ = panic "ppr_forall_co"++pprCoBndr :: Name -> Coercion -> SDoc+pprCoBndr name eta =+  forAllLit <+> parens (ppr name <+> dcolon <+> ppr eta) <> dot++pprCoAxiom :: CoAxiom br -> SDoc+pprCoAxiom ax@(CoAxiom { co_ax_branches = branches })+  = hang (text "axiom" <+> ppr ax <+> dcolon)+       2 (vcat (map (ppr_co_ax_branch (const ppr) ax) $ fromBranches branches))++pprCoAxBranch :: CoAxiom br -> CoAxBranch -> SDoc+pprCoAxBranch = ppr_co_ax_branch pprRhs+  where+    pprRhs fam_tc (TyConApp tycon _)+      | isDataFamilyTyCon fam_tc+      = pprDataCons tycon+    pprRhs _ rhs = ppr rhs++pprCoAxBranchHdr :: CoAxiom br -> BranchIndex -> SDoc+pprCoAxBranchHdr ax index = pprCoAxBranch ax (coAxiomNthBranch ax index)++ppr_co_ax_branch :: (TyCon -> Type -> SDoc) -> CoAxiom br -> CoAxBranch -> SDoc+ppr_co_ax_branch ppr_rhs+              (CoAxiom { co_ax_tc = fam_tc, co_ax_name = name })+              (CoAxBranch { cab_tvs = tvs+                          , cab_cvs = cvs+                          , cab_lhs = lhs+                          , cab_rhs = rhs+                          , cab_loc = loc })+  = foldr1 (flip hangNotEmpty 2)+        [ pprUserForAll (mkTyVarBinders Inferred (tvs ++ cvs))+        , pprTypeApp fam_tc lhs <+> equals <+> ppr_rhs fam_tc rhs+        , text "-- Defined" <+> pprLoc loc ]+  where+        pprLoc loc+          | isGoodSrcSpan loc+          = text "at" <+> ppr (srcSpanStart loc)++          | otherwise+          = text "in" <+>+              quotes (ppr (nameModule name))++{-+%************************************************************************+%*                                                                      *+        Destructing coercions+%*                                                                      *+%************************************************************************++Note [Function coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~+Remember that+  (->) :: forall r1 r2. TYPE r1 -> TYPE r2 -> TYPE LiftedRep++Hence+  FunCo r co1 co2 :: (s1->t1) ~r (s2->t2)+is short for+  TyConAppCo (->) co_rep1 co_rep2 co1 co2+where co_rep1, co_rep2 are the coercions on the representations.+-}+++-- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into+-- a list of 'Coercion's of kinds @A ~ D@, @B ~ E@ and @E ~ F@. Hence:+--+-- > decomposeCo 3 c = [nth 0 c, nth 1 c, nth 2 c]+decomposeCo :: Arity -> Coercion -> [Coercion]+decomposeCo arity co+  = [mkNthCo n co | n <- [0..(arity-1)] ]+           -- Remember, Nth is zero-indexed++decomposeFunCo :: Coercion -> (Coercion, Coercion)+-- Expects co :: (s1 -> t1) ~ (s2 -> t2)+-- Returns (co1 :: s1~s2, co2 :: t1~t2)+-- See Note [Function coercions] for the "2" and "3"+decomposeFunCo co = ASSERT2( all_ok, ppr co )+                    (mkNthCo 2 co, mkNthCo 3 co)+  where+    Pair s1t1 s2t2 = coercionKind co+    all_ok = isFunTy s1t1 && isFunTy s2t2++-- | Attempts to obtain the type variable underlying a 'Coercion'+getCoVar_maybe :: Coercion -> Maybe CoVar+getCoVar_maybe (CoVarCo cv) = Just cv+getCoVar_maybe _            = Nothing++-- | Attempts to tease a coercion apart into a type constructor and the application+-- of a number of coercion arguments to that constructor+splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion])+splitTyConAppCo_maybe (Refl r ty)+  = do { (tc, tys) <- splitTyConApp_maybe ty+       ; let args = zipWith mkReflCo (tyConRolesX r tc) tys+       ; return (tc, args) }+splitTyConAppCo_maybe (TyConAppCo _ tc cos) = Just (tc, cos)+splitTyConAppCo_maybe (FunCo _ arg res)     = Just (funTyCon, cos)+  where cos = [mkRuntimeRepCo arg, mkRuntimeRepCo res, arg, res]+splitTyConAppCo_maybe _                     = Nothing++-- first result has role equal to input; third result is Nominal+splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion)+-- ^ Attempt to take a coercion application apart.+splitAppCo_maybe (AppCo co arg) = Just (co, arg)+splitAppCo_maybe (TyConAppCo r tc args)+  | mightBeUnsaturatedTyCon tc || args `lengthExceeds` tyConArity tc+    -- Never create unsaturated type family apps!+  , Just (args', arg') <- snocView args+  , Just arg'' <- setNominalRole_maybe arg'+  = Just ( mkTyConAppCo r tc args', arg'' )+       -- Use mkTyConAppCo to preserve the invariant+       --  that identity coercions are always represented by Refl++splitAppCo_maybe (Refl r ty)+  | Just (ty1, ty2) <- splitAppTy_maybe ty+  = Just (mkReflCo r ty1, mkNomReflCo ty2)+splitAppCo_maybe _ = Nothing++splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion)+splitFunCo_maybe (FunCo _ arg res) = Just (arg, res)+splitFunCo_maybe _ = Nothing++splitForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion)+splitForAllCo_maybe (ForAllCo tv k_co co) = Just (tv, k_co, co)+splitForAllCo_maybe _                     = Nothing++-------------------------------------------------------+-- and some coercion kind stuff++coVarTypes :: CoVar -> Pair Type+coVarTypes cv+  | (_, _, ty1, ty2, _) <- coVarKindsTypesRole cv+  = Pair ty1 ty2++coVarKindsTypesRole :: CoVar -> (Kind,Kind,Type,Type,Role)+coVarKindsTypesRole cv+ | Just (tc, [k1,k2,ty1,ty2]) <- splitTyConApp_maybe (varType cv)+ = let role+         | tc `hasKey` eqPrimTyConKey     = Nominal+         | tc `hasKey` eqReprPrimTyConKey = Representational+         | otherwise                      = panic "coVarKindsTypesRole"+   in (k1,k2,ty1,ty2,role)+ | otherwise = pprPanic "coVarKindsTypesRole, non coercion variable"+                        (ppr cv $$ ppr (varType cv))++coVarKind :: CoVar -> Type+coVarKind cv+  = ASSERT( isCoVar cv )+    varType cv++coVarRole :: CoVar -> Role+coVarRole cv+  | tc `hasKey` eqPrimTyConKey+  = Nominal+  | tc `hasKey` eqReprPrimTyConKey+  = Representational+  | otherwise+  = pprPanic "coVarRole: unknown tycon" (ppr cv <+> dcolon <+> ppr (varType cv))++  where+    tc = case tyConAppTyCon_maybe (varType cv) of+           Just tc0 -> tc0+           Nothing  -> pprPanic "coVarRole: not tyconapp" (ppr cv)++-- | Makes a coercion type from two types: the types whose equality+-- is proven by the relevant 'Coercion'+mkCoercionType :: Role -> Type -> Type -> Type+mkCoercionType Nominal          = mkPrimEqPred+mkCoercionType Representational = mkReprPrimEqPred+mkCoercionType Phantom          = \ty1 ty2 ->+  let ki1 = typeKind ty1+      ki2 = typeKind ty2+  in+  TyConApp eqPhantPrimTyCon [ki1, ki2, ty1, ty2]++mkHeteroCoercionType :: Role -> Kind -> Kind -> Type -> Type -> Type+mkHeteroCoercionType Nominal          = mkHeteroPrimEqPred+mkHeteroCoercionType Representational = mkHeteroReprPrimEqPred+mkHeteroCoercionType Phantom          = panic "mkHeteroCoercionType"++-- | Given a coercion @co1 :: (a :: TYPE r1) ~ (b :: TYPE r2)@,+-- produce a coercion @rep_co :: r1 ~ r2@.+mkRuntimeRepCo :: Coercion -> Coercion+mkRuntimeRepCo co+  = mkNthCo 0 kind_co+  where+    kind_co = mkKindCo co  -- kind_co :: TYPE r1 ~ TYPE r2+                           -- (up to silliness with Constraint)++isReflCoVar_maybe :: CoVar -> Maybe Coercion+-- If cv :: t~t then isReflCoVar_maybe cv = Just (Refl t)+isReflCoVar_maybe cv+  | Pair ty1 ty2 <- coVarTypes cv+  , ty1 `eqType` ty2+  = Just (Refl (coVarRole cv) ty1)+  | otherwise+  = Nothing++-- | Tests if this coercion is obviously reflexive. Guaranteed to work+-- very quickly. Sometimes a coercion can be reflexive, but not obviously+-- so. c.f. 'isReflexiveCo'+isReflCo :: Coercion -> Bool+isReflCo (Refl {}) = True+isReflCo _         = False++-- | Returns the type coerced if this coercion is reflexive. Guaranteed+-- to work very quickly. Sometimes a coercion can be reflexive, but not+-- obviously so. c.f. 'isReflexiveCo_maybe'+isReflCo_maybe :: Coercion -> Maybe (Type, Role)+isReflCo_maybe (Refl r ty) = Just (ty, r)+isReflCo_maybe _           = Nothing++-- | Slowly checks if the coercion is reflexive. Don't call this in a loop,+-- as it walks over the entire coercion.+isReflexiveCo :: Coercion -> Bool+isReflexiveCo = isJust . isReflexiveCo_maybe++-- | Extracts the coerced type from a reflexive coercion. This potentially+-- walks over the entire coercion, so avoid doing this in a loop.+isReflexiveCo_maybe :: Coercion -> Maybe (Type, Role)+isReflexiveCo_maybe (Refl r ty) = Just (ty, r)+isReflexiveCo_maybe co+  | ty1 `eqType` ty2+  = Just (ty1, r)+  | otherwise+  = Nothing+  where (Pair ty1 ty2, r) = coercionKindRole co++{-+%************************************************************************+%*                                                                      *+            Building coercions+%*                                                                      *+%************************************************************************++These "smart constructors" maintain the invariants listed in the definition+of Coercion, and they perform very basic optimizations.++Note [Role twiddling functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++There are a plethora of functions for twiddling roles:++mkSubCo: Requires a nominal input coercion and always produces a+representational output. This is used when you (the programmer) are sure you+know exactly that role you have and what you want.++downgradeRole_maybe: This function takes both the input role and the output role+as parameters. (The *output* role comes first!) It can only *downgrade* a+role -- that is, change it from N to R or P, or from R to P. This one-way+behavior is why there is the "_maybe". If an upgrade is requested, this+function produces Nothing. This is used when you need to change the role of a+coercion, but you're not sure (as you're writing the code) of which roles are+involved.++This function could have been written using coercionRole to ascertain the role+of the input. But, that function is recursive, and the caller of downgradeRole_maybe+often knows the input role. So, this is more efficient.++downgradeRole: This is just like downgradeRole_maybe, but it panics if the+conversion isn't a downgrade.++setNominalRole_maybe: This is the only function that can *upgrade* a coercion.+The result (if it exists) is always Nominal. The input can be at any role. It+works on a "best effort" basis, as it should never be strictly necessary to+upgrade a coercion during compilation. It is currently only used within GHC in+splitAppCo_maybe. In order to be a proper inverse of mkAppCo, the second+coercion that splitAppCo_maybe returns must be nominal. But, it's conceivable+that splitAppCo_maybe is operating over a TyConAppCo that uses a+representational coercion. Hence the need for setNominalRole_maybe.+splitAppCo_maybe, in turn, is used only within coercion optimization -- thus,+it is not absolutely critical that setNominalRole_maybe be complete.++Note that setNominalRole_maybe will never upgrade a phantom UnivCo. Phantom+UnivCos are perfectly type-safe, whereas representational and nominal ones are+not. Indeed, `unsafeCoerce` is implemented via a representational UnivCo.+(Nominal ones are no worse than representational ones, so this function *will*+change a UnivCo Representational to a UnivCo Nominal.)++Conal Elliott also came across a need for this function while working with the+GHC API, as he was decomposing Core casts. The Core casts use representational+coercions, as they must, but his use case required nominal coercions (he was+building a GADT). So, that's why this function is exported from this module.++One might ask: shouldn't downgradeRole_maybe just use setNominalRole_maybe as+appropriate? I (Richard E.) have decided not to do this, because upgrading a+role is bizarre and a caller should have to ask for this behavior explicitly.++Note [mkTransAppCo]+~~~~~~~~~~~~~~~~~~~+Suppose we have++  co1 :: a ~R Maybe+  co2 :: b ~R Int++and we want++  co3 :: a b ~R Maybe Int++This seems sensible enough. But, we can't let (co3 = co1 co2), because+that's ill-roled! Note that mkAppCo requires a *nominal* second coercion.++The way around this is to use transitivity:++  co3 = (co1 <b>_N) ; (Maybe co2) :: a b ~R Maybe Int++Or, it's possible everything is the other way around:++  co1' :: Maybe ~R a+  co2' :: Int   ~R b++and we want++  co3' :: Maybe Int ~R a b++then++  co3' = (Maybe co2') ; (co1' <b>_N)++This is exactly what `mkTransAppCo` builds for us. Information for all+the arguments tends to be to hand at call sites, so it's quicker than+using, say, coercionKind.++-}++mkReflCo :: Role -> Type -> Coercion+mkReflCo r ty+  = Refl r ty++-- | Make a representational reflexive coercion+mkRepReflCo :: Type -> Coercion+mkRepReflCo = mkReflCo Representational++-- | Make a nominal reflexive coercion+mkNomReflCo :: Type -> Coercion+mkNomReflCo = mkReflCo Nominal++-- | Apply a type constructor to a list of coercions. It is the+-- caller's responsibility to get the roles correct on argument coercions.+mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion+mkTyConAppCo r tc cos+  | tc `hasKey` funTyConKey+  , [_rep1, _rep2, co1, co2] <- cos   -- See Note [Function coercions]+  = -- (a :: TYPE ra) -> (b :: TYPE rb)  ~  (c :: TYPE rc) -> (d :: TYPE rd)+    -- rep1 :: ra  ~  rc        rep2 :: rb  ~  rd+    -- co1  :: a   ~  c         co2  :: b   ~  d+    mkFunCo r co1 co2++               -- Expand type synonyms+  | Just (tv_co_prs, rhs_ty, leftover_cos) <- expandSynTyCon_maybe tc cos+  = mkAppCos (liftCoSubst r (mkLiftingContext tv_co_prs) rhs_ty) leftover_cos++  | Just tys_roles <- traverse isReflCo_maybe cos+  = Refl r (mkTyConApp tc (map fst tys_roles))    -- See Note [Refl invariant]++  | otherwise = TyConAppCo r tc cos++-- | Build a function 'Coercion' from two other 'Coercion's. That is,+-- given @co1 :: a ~ b@ and @co2 :: x ~ y@ produce @co :: (a -> x) ~ (b -> y)@.+mkFunCo :: Role -> Coercion -> Coercion -> Coercion+mkFunCo r co1 co2+    -- See Note [Refl invariant]+  | Just (ty1, _) <- isReflCo_maybe co1+  , Just (ty2, _) <- isReflCo_maybe co2+  = Refl r (mkFunTy ty1 ty2)+  | otherwise = FunCo r co1 co2++-- | Make nested function 'Coercion's+mkFunCos :: Role -> [Coercion] -> Coercion -> Coercion+mkFunCos r cos res_co = foldr (mkFunCo r) res_co cos++-- | Apply a 'Coercion' to another 'Coercion'.+-- The second coercion must be Nominal, unless the first is Phantom.+-- If the first is Phantom, then the second can be either Phantom or Nominal.+mkAppCo :: Coercion     -- ^ :: t1 ~r t2+        -> Coercion     -- ^ :: s1 ~N s2, where s1 :: k1, s2 :: k2+        -> Coercion     -- ^ :: t1 s1 ~r t2 s2+mkAppCo (Refl r ty1) arg+  | Just (ty2, _) <- isReflCo_maybe arg+  = Refl r (mkAppTy ty1 ty2)++  | Just (tc, tys) <- splitTyConApp_maybe ty1+    -- Expand type synonyms; a TyConAppCo can't have a type synonym (Trac #9102)+  = mkTyConAppCo r tc (zip_roles (tyConRolesX r tc) tys)+  where+    zip_roles (r1:_)  []            = [downgradeRole r1 Nominal arg]+    zip_roles (r1:rs) (ty1:tys)     = mkReflCo r1 ty1 : zip_roles rs tys+    zip_roles _       _             = panic "zip_roles" -- but the roles are infinite...++mkAppCo (TyConAppCo r tc args) arg+  = case r of+      Nominal          -> mkTyConAppCo Nominal tc (args ++ [arg])+      Representational -> mkTyConAppCo Representational tc (args ++ [arg'])+        where new_role = (tyConRolesRepresentational tc) !! (length args)+              arg'     = downgradeRole new_role Nominal arg+      Phantom          -> mkTyConAppCo Phantom tc (args ++ [toPhantomCo arg])+mkAppCo co arg = AppCo co  arg+-- Note, mkAppCo is careful to maintain invariants regarding+-- where Refl constructors appear; see the comments in the definition+-- of Coercion and the Note [Refl invariant] in TyCoRep.++-- | Applies multiple 'Coercion's to another 'Coercion', from left to right.+-- See also 'mkAppCo'.+mkAppCos :: Coercion+         -> [Coercion]+         -> Coercion+mkAppCos co1 cos = foldl mkAppCo co1 cos++-- | Like `mkAppCo`, but allows the second coercion to be other than+-- nominal. See Note [mkTransAppCo]. Role r3 cannot be more stringent+-- than either r1 or r2.+mkTransAppCo :: Role         -- ^ r1+             -> Coercion     -- ^ co1 :: ty1a ~r1 ty1b+             -> Type         -- ^ ty1a+             -> Type         -- ^ ty1b+             -> Role         -- ^ r2+             -> Coercion     -- ^ co2 :: ty2a ~r2 ty2b+             -> Type         -- ^ ty2a+             -> Type         -- ^ ty2b+             -> Role         -- ^ r3+             -> Coercion     -- ^ :: ty1a ty2a ~r3 ty1b ty2b+mkTransAppCo r1 co1 ty1a ty1b r2 co2 ty2a ty2b r3+-- How incredibly fiddly! Is there a better way??+  = case (r1, r2, r3) of+      (_,                _,                Phantom)+        -> mkPhantomCo kind_co (mkAppTy ty1a ty2a) (mkAppTy ty1b ty2b)+        where -- ty1a :: k1a -> k2a+              -- ty1b :: k1b -> k2b+              -- ty2a :: k1a+              -- ty2b :: k1b+              -- ty1a ty2a :: k2a+              -- ty1b ty2b :: k2b+              kind_co1 = mkKindCo co1        -- :: k1a -> k2a ~N k1b -> k2b+              kind_co  = mkNthCo 1 kind_co1  -- :: k2a ~N k2b++      (_,                _,                Nominal)+        -> ASSERT( r1 == Nominal && r2 == Nominal )+           mkAppCo co1 co2+      (Nominal,          Nominal,          Representational)+        -> mkSubCo (mkAppCo co1 co2)+      (_,                Nominal,          Representational)+        -> ASSERT( r1 == Representational )+           mkAppCo co1 co2+      (Nominal,          Representational, Representational)+        -> go (mkSubCo co1)+      (_               , _,                Representational)+        -> ASSERT( r1 == Representational && r2 == Representational )+           go co1+  where+    go co1_repr+      | Just (tc1b, tys1b) <- splitTyConApp_maybe ty1b+      , nextRole ty1b == r2+      = (mkAppCo co1_repr (mkNomReflCo ty2a)) `mkTransCo`+        (mkTyConAppCo Representational tc1b+           (zipWith mkReflCo (tyConRolesRepresentational tc1b) tys1b+            ++ [co2]))++      | Just (tc1a, tys1a) <- splitTyConApp_maybe ty1a+      , nextRole ty1a == r2+      = (mkTyConAppCo Representational tc1a+           (zipWith mkReflCo (tyConRolesRepresentational tc1a) tys1a+            ++ [co2]))+        `mkTransCo`+        (mkAppCo co1_repr (mkNomReflCo ty2b))++      | otherwise+      = pprPanic "mkTransAppCo" (vcat [ ppr r1, ppr co1, ppr ty1a, ppr ty1b+                                      , ppr r2, ppr co2, ppr ty2a, ppr ty2b+                                      , ppr r3 ])++-- | Make a Coercion from a tyvar, a kind coercion, and a body coercion.+-- The kind of the tyvar should be the left-hand kind of the kind coercion.+mkForAllCo :: TyVar -> Coercion -> Coercion -> Coercion+mkForAllCo tv kind_co co+  | Refl r ty <- co+  , Refl {} <- kind_co+  = Refl r (mkInvForAllTy tv ty)+  | otherwise+  = ForAllCo tv kind_co co++-- | Make nested ForAllCos+mkForAllCos :: [(TyVar, Coercion)] -> Coercion -> Coercion+mkForAllCos bndrs (Refl r ty)+  = let (refls_rev'd, non_refls_rev'd) = span (isReflCo . snd) (reverse bndrs) in+    foldl (flip $ uncurry ForAllCo)+          (Refl r $ mkInvForAllTys (reverse (map fst refls_rev'd)) ty)+          non_refls_rev'd+mkForAllCos bndrs co = foldr (uncurry ForAllCo) co bndrs++-- | Make a Coercion quantified over a type variable;+-- the variable has the same type in both sides of the coercion+mkHomoForAllCos :: [TyVar] -> Coercion -> Coercion+mkHomoForAllCos tvs (Refl r ty)+  = Refl r (mkInvForAllTys tvs ty)+mkHomoForAllCos tvs ty = mkHomoForAllCos_NoRefl tvs ty++-- | Like 'mkHomoForAllCos', but doesn't check if the inner coercion+-- is reflexive.+mkHomoForAllCos_NoRefl :: [TyVar] -> Coercion -> Coercion+mkHomoForAllCos_NoRefl tvs orig_co = foldr go orig_co tvs+  where+    go tv co = ForAllCo tv (mkNomReflCo (tyVarKind tv)) co++mkCoVarCo :: CoVar -> Coercion+-- cv :: s ~# t+-- See Note [mkCoVarCo]+mkCoVarCo cv = CoVarCo cv++mkCoVarCos :: [CoVar] -> [Coercion]+mkCoVarCos = map mkCoVarCo++{- Note [mkCoVarCo]+~~~~~~~~~~~~~~~~~~~+In the past, mkCoVarCo optimised (c :: t~t) to (Refl t).  That is+valid (although see Note [Unbound RULE binders] in Rules), but+it's a relatively expensive test and perhaps better done in+optCoercion.  Not a big deal either way.+-}++-- | Extract a covar, if possible. This check is dirty. Be ashamed+-- of yourself. (It's dirty because it cares about the structure of+-- a coercion, which is morally reprehensible.)+isCoVar_maybe :: Coercion -> Maybe CoVar+isCoVar_maybe (CoVarCo cv) = Just cv+isCoVar_maybe _            = Nothing++mkAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [Type] -> [Coercion]+           -> Coercion+-- mkAxInstCo can legitimately be called over-staturated;+-- i.e. with more type arguments than the coercion requires+mkAxInstCo role ax index tys cos+  | arity == n_tys = downgradeRole role ax_role $+                     mkAxiomInstCo ax_br index (rtys `chkAppend` cos)+  | otherwise      = ASSERT( arity < n_tys )+                     downgradeRole role ax_role $+                     mkAppCos (mkAxiomInstCo ax_br index+                                             (ax_args `chkAppend` cos))+                              leftover_args+  where+    n_tys         = length tys+    ax_br         = toBranchedAxiom ax+    branch        = coAxiomNthBranch ax_br index+    tvs           = coAxBranchTyVars branch+    arity         = length tvs+    arg_roles     = coAxBranchRoles branch+    rtys          = zipWith mkReflCo (arg_roles ++ repeat Nominal) tys+    (ax_args, leftover_args)+                  = splitAt arity rtys+    ax_role       = coAxiomRole ax++-- worker function; just checks to see if it should produce Refl+mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion+mkAxiomInstCo ax index args+  = ASSERT( coAxiomArity ax index == length args )+    AxiomInstCo ax index args++-- to be used only with unbranched axioms+mkUnbranchedAxInstCo :: Role -> CoAxiom Unbranched+                     -> [Type] -> [Coercion] -> Coercion+mkUnbranchedAxInstCo role ax tys cos+  = mkAxInstCo role ax 0 tys cos++mkAxInstRHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type+-- Instantiate the axiom with specified types,+-- returning the instantiated RHS+-- A companion to mkAxInstCo:+--    mkAxInstRhs ax index tys = snd (coercionKind (mkAxInstCo ax index tys))+mkAxInstRHS ax index tys cos+  = ASSERT( tvs `equalLength` tys1 )+    mkAppTys rhs' tys2+  where+    branch       = coAxiomNthBranch ax index+    tvs          = coAxBranchTyVars branch+    cvs          = coAxBranchCoVars branch+    (tys1, tys2) = splitAtList tvs tys+    rhs'         = substTyWith tvs tys1 $+                   substTyWithCoVars cvs cos $+                   coAxBranchRHS branch++mkUnbranchedAxInstRHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type+mkUnbranchedAxInstRHS ax = mkAxInstRHS ax 0++-- | Return the left-hand type of the axiom, when the axiom is instantiated+-- at the types given.+mkAxInstLHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type+mkAxInstLHS ax index tys cos+  = ASSERT( tvs `equalLength` tys1 )+    mkTyConApp fam_tc (lhs_tys `chkAppend` tys2)+  where+    branch       = coAxiomNthBranch ax index+    tvs          = coAxBranchTyVars branch+    cvs          = coAxBranchCoVars branch+    (tys1, tys2) = splitAtList tvs tys+    lhs_tys      = substTysWith tvs tys1 $+                   substTysWithCoVars cvs cos $+                   coAxBranchLHS branch+    fam_tc       = coAxiomTyCon ax++-- | Instantiate the left-hand side of an unbranched axiom+mkUnbranchedAxInstLHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type+mkUnbranchedAxInstLHS ax = mkAxInstLHS ax 0++-- | Manufacture an unsafe coercion from thin air.+--   Currently (May 14) this is used only to implement the+--   @unsafeCoerce#@ primitive.  Optimise by pushing+--   down through type constructors.+mkUnsafeCo :: Role -> Type -> Type -> Coercion+mkUnsafeCo role ty1 ty2+  = mkUnivCo UnsafeCoerceProv role ty1 ty2++-- | Make a coercion from a coercion hole+mkHoleCo :: CoercionHole -> Role+         -> Type -> Type -> Coercion+mkHoleCo h r t1 t2 = mkUnivCo (HoleProv h) r t1 t2++-- | Make a universal coercion between two arbitrary types.+mkUnivCo :: UnivCoProvenance+         -> Role       -- ^ role of the built coercion, "r"+         -> Type       -- ^ t1 :: k1+         -> Type       -- ^ t2 :: k2+         -> Coercion   -- ^ :: t1 ~r t2+mkUnivCo prov role ty1 ty2+  | ty1 `eqType` ty2 = Refl role ty1+  | otherwise        = UnivCo prov role ty1 ty2++-- | Create a symmetric version of the given 'Coercion' that asserts+--   equality between the same types but in the other "direction", so+--   a kind of @t1 ~ t2@ becomes the kind @t2 ~ t1@.+mkSymCo :: Coercion -> Coercion++-- Do a few simple optimizations, but don't bother pushing occurrences+-- of symmetry to the leaves; the optimizer will take care of that.+mkSymCo co@(Refl {})              = co+mkSymCo    (SymCo co)             = co+mkSymCo    (SubCo (SymCo co))     = SubCo co+mkSymCo co                        = SymCo co++-- | Create a new 'Coercion' by composing the two given 'Coercion's transitively.+--   (co1 ; co2)+mkTransCo :: Coercion -> Coercion -> Coercion+mkTransCo co1 (Refl {}) = co1+mkTransCo (Refl {}) co2 = co2+mkTransCo co1 co2       = TransCo co1 co2++-- the Role is the desired one. It is the caller's responsibility to make+-- sure this request is reasonable+mkNthCoRole :: Role -> Int -> Coercion -> Coercion+mkNthCoRole role n co+  = downgradeRole role nth_role $ nth_co+  where+    nth_co = mkNthCo n co+    nth_role = coercionRole nth_co++mkNthCo :: Int -> Coercion -> Coercion+mkNthCo 0 (Refl _ ty)+  | Just (tv, _) <- splitForAllTy_maybe ty+  = Refl Nominal (tyVarKind tv)+mkNthCo n (Refl r ty)+  = ASSERT2( ok_tc_app ty n, ppr n $$ ppr ty )+    mkReflCo r' (tyConAppArgN n ty)+  where tc = tyConAppTyCon ty+        r' = nthRole r tc n++        ok_tc_app :: Type -> Int -> Bool+        ok_tc_app ty n+          | Just (_, tys) <- splitTyConApp_maybe ty+          = tys `lengthExceeds` n+          | isForAllTy ty  -- nth:0 pulls out a kind coercion from a hetero forall+          = n == 0+          | otherwise+          = False++mkNthCo 0 (ForAllCo _ kind_co _) = kind_co+  -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2)+  -- then (nth 0 co :: k1 ~ k2)++mkNthCo n co@(FunCo _ arg res)+  -- See Note [Function coercions]+  -- If FunCo _ arg_co res_co ::   (s1:TYPE sk1 -> s2:TYPE sk2)+  --                             ~ (t1:TYPE tk1 -> t2:TYPE tk2)+  -- Then we want to behave as if co was+  --    TyConAppCo argk_co resk_co arg_co res_co+  -- where+  --    argk_co :: sk1 ~ tk1  =  mkNthCo 0 (mkKindCo arg_co)+  --    resk_co :: sk2 ~ tk2  =  mkNthCo 0 (mkKindCo res_co)+  --                             i.e. mkRuntimeRepCo+  = case n of+      0 -> mkRuntimeRepCo arg+      1 -> mkRuntimeRepCo res+      2 -> arg+      3 -> res+      _ -> pprPanic "mkNthCo(FunCo)" (ppr n $$ ppr co)++mkNthCo n (TyConAppCo _ _ arg_cos) = arg_cos `getNth` n++mkNthCo n co = NthCo n co++mkLRCo :: LeftOrRight -> Coercion -> Coercion+mkLRCo lr (Refl eq ty) = Refl eq (pickLR lr (splitAppTy ty))+mkLRCo lr co           = LRCo lr co++-- | Instantiates a 'Coercion'.+mkInstCo :: Coercion -> Coercion -> Coercion+mkInstCo (ForAllCo tv _kind_co body_co) (Refl _ arg)+  = substCoWithUnchecked [tv] [arg] body_co+mkInstCo co arg = InstCo co arg++-- This could work harder to produce Refl coercions, but that would be+-- quite inefficient. Seems better not to try.+mkCoherenceCo :: Coercion -> Coercion -> Coercion+mkCoherenceCo co1 (Refl {}) = co1+mkCoherenceCo (CoherenceCo co1 co2) co3+  = CoherenceCo co1 (co2 `mkTransCo` co3)+mkCoherenceCo co1 co2     = CoherenceCo co1 co2++-- | A CoherenceCo c1 c2 applies the coercion c2 to the left-hand type+-- in the kind of c1. This function uses sym to get the coercion on the+-- right-hand type of c1. Thus, if c1 :: s ~ t, then mkCoherenceRightCo c1 c2+-- has the kind (s ~ (t |> c2)) down through type constructors.+-- The second coercion must be representational.+mkCoherenceRightCo :: Coercion -> Coercion -> Coercion+mkCoherenceRightCo c1 c2 = mkSymCo (mkCoherenceCo (mkSymCo c1) c2)++-- | An explicitly directed synonym of mkCoherenceCo. The second+-- coercion must be representational.+mkCoherenceLeftCo :: Coercion -> Coercion -> Coercion+mkCoherenceLeftCo = mkCoherenceCo++infixl 5 `mkCoherenceCo`+infixl 5 `mkCoherenceRightCo`+infixl 5 `mkCoherenceLeftCo`++-- | Given @co :: (a :: k) ~ (b :: k')@ produce @co' :: k ~ k'@.+mkKindCo :: Coercion -> Coercion+mkKindCo (Refl _ ty) = Refl Nominal (typeKind ty)+mkKindCo (UnivCo (PhantomProv h) _ _ _)    = h+mkKindCo (UnivCo (ProofIrrelProv h) _ _ _) = h+mkKindCo co+  | Pair ty1 ty2 <- coercionKind co+       -- generally, calling coercionKind during coercion creation is a bad idea,+       -- as it can lead to exponential behavior. But, we don't have nested mkKindCos,+       -- so it's OK here.+  , let tk1 = typeKind ty1+        tk2 = typeKind ty2+  , tk1 `eqType` tk2+  = Refl Nominal tk1+  | otherwise+  = KindCo co++-- input coercion is Nominal; see also Note [Role twiddling functions]+mkSubCo :: Coercion -> Coercion+mkSubCo (Refl Nominal ty) = Refl Representational ty+mkSubCo (TyConAppCo Nominal tc cos)+  = TyConAppCo Representational tc (applyRoles tc cos)+mkSubCo (FunCo Nominal arg res)+  = FunCo Representational+          (downgradeRole Representational Nominal arg)+          (downgradeRole Representational Nominal res)+mkSubCo co = ASSERT2( coercionRole co == Nominal, ppr co <+> ppr (coercionRole co) )+             SubCo co++-- | Changes a role, but only a downgrade. See Note [Role twiddling functions]+downgradeRole_maybe :: Role   -- ^ desired role+                    -> Role   -- ^ current role+                    -> Coercion -> Maybe Coercion+-- In (downgradeRole_maybe dr cr co) it's a precondition that+--                                   cr = coercionRole co+downgradeRole_maybe Representational Nominal co = Just (mkSubCo co)+downgradeRole_maybe Nominal Representational _  = Nothing+downgradeRole_maybe Phantom Phantom          co = Just co+downgradeRole_maybe Phantom _                co = Just (toPhantomCo co)+downgradeRole_maybe _ Phantom                _  = Nothing+downgradeRole_maybe _ _                      co = Just co++-- | Like 'downgradeRole_maybe', but panics if the change isn't a downgrade.+-- See Note [Role twiddling functions]+downgradeRole :: Role  -- desired role+              -> Role  -- current role+              -> Coercion -> Coercion+downgradeRole r1 r2 co+  = case downgradeRole_maybe r1 r2 co of+      Just co' -> co'+      Nothing  -> pprPanic "downgradeRole" (ppr co)++-- | If the EqRel is ReprEq, makes a SubCo; otherwise, does nothing.+-- Note that the input coercion should always be nominal.+maybeSubCo :: EqRel -> Coercion -> Coercion+maybeSubCo NomEq  = id+maybeSubCo ReprEq = mkSubCo+++mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion+mkAxiomRuleCo = AxiomRuleCo++-- | Make a "coercion between coercions".+mkProofIrrelCo :: Role       -- ^ role of the created coercion, "r"+               -> Coercion   -- ^ :: phi1 ~N phi2+               -> Coercion   -- ^ g1 :: phi1+               -> Coercion   -- ^ g2 :: phi2+               -> Coercion   -- ^ :: g1 ~r g2++-- if the two coercion prove the same fact, I just don't care what+-- the individual coercions are.+mkProofIrrelCo r (Refl {}) g  _  = Refl r (CoercionTy g)+mkProofIrrelCo r kco       g1 g2 = mkUnivCo (ProofIrrelProv kco) r+                                     (mkCoercionTy g1) (mkCoercionTy g2)++{-+%************************************************************************+%*                                                                      *+   Roles+%*                                                                      *+%************************************************************************+-}++-- | Converts a coercion to be nominal, if possible.+-- See Note [Role twiddling functions]+setNominalRole_maybe :: Coercion -> Maybe Coercion+setNominalRole_maybe co+  | Nominal <- coercionRole co = Just co+setNominalRole_maybe (SubCo co)  = Just co+setNominalRole_maybe (Refl _ ty) = Just $ Refl Nominal ty+setNominalRole_maybe (TyConAppCo Representational tc cos)+  = do { cos' <- mapM setNominalRole_maybe cos+       ; return $ TyConAppCo Nominal tc cos' }+setNominalRole_maybe (FunCo Representational co1 co2)+  = do { co1' <- setNominalRole_maybe co1+       ; co2' <- setNominalRole_maybe co2+       ; return $ FunCo Nominal co1' co2'+       }+setNominalRole_maybe (SymCo co)+  = SymCo <$> setNominalRole_maybe co+setNominalRole_maybe (TransCo co1 co2)+  = TransCo <$> setNominalRole_maybe co1 <*> setNominalRole_maybe co2+setNominalRole_maybe (AppCo co1 co2)+  = AppCo <$> setNominalRole_maybe co1 <*> pure co2+setNominalRole_maybe (ForAllCo tv kind_co co)+  = ForAllCo tv kind_co <$> setNominalRole_maybe co+setNominalRole_maybe (NthCo n co)+  = NthCo n <$> setNominalRole_maybe co+setNominalRole_maybe (InstCo co arg)+  = InstCo <$> setNominalRole_maybe co <*> pure arg+setNominalRole_maybe (CoherenceCo co1 co2)+  = CoherenceCo <$> setNominalRole_maybe co1 <*> pure co2+setNominalRole_maybe (UnivCo prov _ co1 co2)+  | case prov of UnsafeCoerceProv -> True   -- it's always unsafe+                 PhantomProv _    -> False  -- should always be phantom+                 ProofIrrelProv _ -> True   -- it's always safe+                 PluginProv _     -> False  -- who knows? This choice is conservative.+                 HoleProv _       -> False  -- no no no.+  = Just $ UnivCo prov Nominal co1 co2+setNominalRole_maybe _ = Nothing++-- | Make a phantom coercion between two types. The coercion passed+-- in must be a nominal coercion between the kinds of the+-- types.+mkPhantomCo :: Coercion -> Type -> Type -> Coercion+mkPhantomCo h t1 t2+  = mkUnivCo (PhantomProv h) Phantom t1 t2++-- | Make a phantom coercion between two types of the same kind.+mkHomoPhantomCo :: Type -> Type -> Coercion+mkHomoPhantomCo t1 t2+  = ASSERT( k1 `eqType` typeKind t2 )+    mkPhantomCo (mkNomReflCo k1) t1 t2+  where+    k1 = typeKind t1++-- takes any coercion and turns it into a Phantom coercion+toPhantomCo :: Coercion -> Coercion+toPhantomCo co+  = mkPhantomCo (mkKindCo co) ty1 ty2+  where Pair ty1 ty2 = coercionKind co++-- Convert args to a TyConAppCo Nominal to the same TyConAppCo Representational+applyRoles :: TyCon -> [Coercion] -> [Coercion]+applyRoles tc cos+  = zipWith (\r -> downgradeRole r Nominal) (tyConRolesRepresentational tc) cos++-- the Role parameter is the Role of the TyConAppCo+-- defined here because this is intimiately concerned with the implementation+-- of TyConAppCo+tyConRolesX :: Role -> TyCon -> [Role]+tyConRolesX Representational tc = tyConRolesRepresentational tc+tyConRolesX role             _  = repeat role++tyConRolesRepresentational :: TyCon -> [Role]+tyConRolesRepresentational tc = tyConRoles tc ++ repeat Nominal++nthRole :: Role -> TyCon -> Int -> Role+nthRole Nominal _ _ = Nominal+nthRole Phantom _ _ = Phantom+nthRole Representational tc n+  = (tyConRolesRepresentational tc) `getNth` n++ltRole :: Role -> Role -> Bool+-- Is one role "less" than another?+--     Nominal < Representational < Phantom+ltRole Phantom          _       = False+ltRole Representational Phantom = True+ltRole Representational _       = False+ltRole Nominal          Nominal = False+ltRole Nominal          _       = True++-------------------------------++-- | like mkKindCo, but aggressively & recursively optimizes to avoid using+-- a KindCo constructor. The output role is nominal.+promoteCoercion :: Coercion -> Coercion++-- First cases handles anything that should yield refl.+promoteCoercion co = case co of++    _ | ki1 `eqType` ki2+      -> mkNomReflCo (typeKind ty1)+     -- no later branch should return refl+     --    The ASSERT( False )s throughout+     -- are these cases explicitly, but they should never fire.++    Refl _ ty -> ASSERT( False )+                 mkNomReflCo (typeKind ty)++    TyConAppCo _ tc args+      | Just co' <- instCoercions (mkNomReflCo (tyConKind tc)) args+      -> co'+      | otherwise+      -> mkKindCo co++    AppCo co1 arg+      | Just co' <- instCoercion (coercionKind (mkKindCo co1))+                                 (promoteCoercion co1) arg+      -> co'+      | otherwise+      -> mkKindCo co++    ForAllCo _ _ g+      -> promoteCoercion g++    FunCo _ _ _+      -> mkNomReflCo liftedTypeKind++    CoVarCo {}+      -> mkKindCo co++    AxiomInstCo {}+      -> mkKindCo co++    UnivCo UnsafeCoerceProv _ t1 t2+      -> mkUnsafeCo Nominal (typeKind t1) (typeKind t2)+    UnivCo (PhantomProv kco) _ _ _+      -> kco+    UnivCo (ProofIrrelProv kco) _ _ _+      -> kco+    UnivCo (PluginProv _) _ _ _+      -> mkKindCo co+    UnivCo (HoleProv _) _ _ _+      -> mkKindCo co++    SymCo g+      -> mkSymCo (promoteCoercion g)++    TransCo co1 co2+      -> mkTransCo (promoteCoercion co1) (promoteCoercion co2)++    NthCo n co1+      | Just (_, args) <- splitTyConAppCo_maybe co1+      , n < length args+      -> promoteCoercion (args !! n)++      | Just _ <- splitForAllCo_maybe co+      , n == 0+      -> ASSERT( False ) mkNomReflCo liftedTypeKind++      | otherwise+      -> mkKindCo co++    LRCo lr co1+      | Just (lco, rco) <- splitAppCo_maybe co1+      -> case lr of+           CLeft  -> promoteCoercion lco+           CRight -> promoteCoercion rco++      | otherwise+      -> mkKindCo co++    InstCo g _+      -> promoteCoercion g++    CoherenceCo g h+      -> mkSymCo h `mkTransCo` promoteCoercion g++    KindCo _+      -> ASSERT( False )+         mkNomReflCo liftedTypeKind++    SubCo g+      -> promoteCoercion g++    AxiomRuleCo {}+      -> mkKindCo co++  where+    Pair ty1 ty2 = coercionKind co+    ki1 = typeKind ty1+    ki2 = typeKind ty2++-- | say @g = promoteCoercion h@. Then, @instCoercion g w@ yields @Just g'@,+-- where @g' = promoteCoercion (h w)@.+-- fails if this is not possible, if @g@ coerces between a forall and an ->+-- or if second parameter has a representational role and can't be used+-- with an InstCo. The result role matches is representational.+instCoercion :: Pair Type -- type of the first coercion+             -> Coercion  -- ^ must be nominal+             -> Coercion+             -> Maybe Coercion+instCoercion (Pair lty rty) g w+  | isForAllTy lty && isForAllTy rty+  , Just w' <- setNominalRole_maybe w+  = Just $ mkInstCo g w'+  | isFunTy lty && isFunTy rty+  = Just $ mkNthCo 3 g -- extract result type, which is the 4th argument to (->)+  | otherwise -- one forall, one funty...+  = Nothing+  where++instCoercions :: Coercion -> [Coercion] -> Maybe Coercion+instCoercions g ws+  = let arg_ty_pairs = map coercionKind ws in+    snd <$> foldM go (coercionKind g, g) (zip arg_ty_pairs ws)+  where+    go :: (Pair Type, Coercion) -> (Pair Type, Coercion)+       -> Maybe (Pair Type, Coercion)+    go (g_tys, g) (w_tys, w)+      = do { g' <- instCoercion g_tys g w+           ; return (piResultTy <$> g_tys <*> w_tys, g') }++-- | Creates a new coercion with both of its types casted by different casts+-- castCoercionKind g h1 h2, where g :: t1 ~ t2, has type (t1 |> h1) ~ (t2 |> h2)+-- The second and third coercions must be nominal.+castCoercionKind :: Coercion -> Coercion -> Coercion -> Coercion+castCoercionKind g h1 h2+  = g `mkCoherenceLeftCo` h1 `mkCoherenceRightCo` h2++-- See note [Newtype coercions] in TyCon++mkPiCos :: Role -> [Var] -> Coercion -> Coercion+mkPiCos r vs co = foldr (mkPiCo r) co vs++-- | Make a forall 'Coercion', where both types related by the coercion+-- are quantified over the same type variable.+mkPiCo  :: Role -> Var -> Coercion -> Coercion+mkPiCo r v co | isTyVar v = mkHomoForAllCos [v] co+              | otherwise = mkFunCo r (mkReflCo r (varType v)) co++-- The second coercion is sometimes lifted (~) and sometimes unlifted (~#).+-- So, we have to make sure to supply the right parameter to decomposeCo.+-- mkCoCast (c :: s1 ~# t1) (g :: (s1 ~# s2) ~# (t1 ~# t2)) :: s2 ~# t2+-- Both coercions *must* have the same role.+mkCoCast :: Coercion -> Coercion -> Coercion+mkCoCast c g+  = mkSymCo g1 `mkTransCo` c `mkTransCo` g2+  where+       -- g  :: (s1 ~# s2) ~# (t1 ~#  t2)+       -- g1 :: s1 ~# t1+       -- g2 :: s2 ~# t2+    (_, args) = splitTyConApp (pFst $ coercionKind g)+    n_args = length args+    co_list = decomposeCo n_args g+    g1 = co_list `getNth` (n_args - 2)+    g2 = co_list `getNth` (n_args - 1)++{-+%************************************************************************+%*                                                                      *+            Newtypes+%*                                                                      *+%************************************************************************+-}++-- | If @co :: T ts ~ rep_ty@ then:+--+-- > instNewTyCon_maybe T ts = Just (rep_ty, co)+--+-- Checks for a newtype, and for being saturated+instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion)+instNewTyCon_maybe tc tys+  | Just (tvs, ty, co_tc) <- unwrapNewTyConEtad_maybe tc  -- Check for newtype+  , tvs `leLength` tys                                    -- Check saturated enough+  = Just (applyTysX tvs ty tys, mkUnbranchedAxInstCo Representational co_tc tys [])+  | otherwise+  = Nothing++{-+************************************************************************+*                                                                      *+         Type normalisation+*                                                                      *+************************************************************************+-}++-- | A function to check if we can reduce a type by one step. Used+-- with 'topNormaliseTypeX'.+type NormaliseStepper ev = RecTcChecker+                         -> TyCon     -- tc+                         -> [Type]    -- tys+                         -> NormaliseStepResult ev++-- | The result of stepping in a normalisation function.+-- See 'topNormaliseTypeX'.+data NormaliseStepResult ev+  = NS_Done   -- ^ Nothing more to do+  | NS_Abort  -- ^ Utter failure. The outer function should fail too.+  | NS_Step RecTcChecker Type ev    -- ^ We stepped, yielding new bits;+                                    -- ^ ev is evidence;+                                    -- Usually a co :: old type ~ new type++mapStepResult :: (ev1 -> ev2)+              -> NormaliseStepResult ev1 -> NormaliseStepResult ev2+mapStepResult f (NS_Step rec_nts ty ev) = NS_Step rec_nts ty (f ev)+mapStepResult _ NS_Done                 = NS_Done+mapStepResult _ NS_Abort                = NS_Abort++-- | Try one stepper and then try the next, if the first doesn't make+-- progress.+-- So if it returns NS_Done, it means that both steppers are satisfied+composeSteppers :: NormaliseStepper ev -> NormaliseStepper ev+                -> NormaliseStepper ev+composeSteppers step1 step2 rec_nts tc tys+  = case step1 rec_nts tc tys of+      success@(NS_Step {}) -> success+      NS_Done              -> step2 rec_nts tc tys+      NS_Abort             -> NS_Abort++-- | A 'NormaliseStepper' that unwraps newtypes, careful not to fall into+-- a loop. If it would fall into a loop, it produces 'NS_Abort'.+unwrapNewTypeStepper :: NormaliseStepper Coercion+unwrapNewTypeStepper rec_nts tc tys+  | Just (ty', co) <- instNewTyCon_maybe tc tys+  = case checkRecTc rec_nts tc of+      Just rec_nts' -> NS_Step rec_nts' ty' co+      Nothing       -> NS_Abort++  | otherwise+  = NS_Done++-- | A general function for normalising the top-level of a type. It continues+-- to use the provided 'NormaliseStepper' until that function fails, and then+-- this function returns. The roles of the coercions produced by the+-- 'NormaliseStepper' must all be the same, which is the role returned from+-- the call to 'topNormaliseTypeX'.+--+-- Typically ev is Coercion.+--+-- If topNormaliseTypeX step plus ty = Just (ev, ty')+-- then ty ~ev1~ t1 ~ev2~ t2 ... ~evn~ ty'+-- and ev = ev1 `plus` ev2 `plus` ... `plus` evn+-- If it returns Nothing then no newtype unwrapping could happen+topNormaliseTypeX :: NormaliseStepper ev -> (ev -> ev -> ev)+                  -> Type -> Maybe (ev, Type)+topNormaliseTypeX stepper plus ty+ | Just (tc, tys) <- splitTyConApp_maybe ty+ , NS_Step rec_nts ty' ev <- stepper initRecTc tc tys+ = go rec_nts ev ty'+ | otherwise+ = Nothing+ where+    go rec_nts ev ty+      | Just (tc, tys) <- splitTyConApp_maybe ty+      = case stepper rec_nts tc tys of+          NS_Step rec_nts' ty' ev' -> go rec_nts' (ev `plus` ev') ty'+          NS_Done  -> Just (ev, ty)+          NS_Abort -> Nothing++      | otherwise+      = Just (ev, ty)++topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type)+-- ^ Sometimes we want to look through a @newtype@ and get its associated coercion.+-- This function strips off @newtype@ layers enough to reveal something that isn't+-- a @newtype@.  Specifically, here's the invariant:+--+-- > topNormaliseNewType_maybe rec_nts ty = Just (co, ty')+--+-- then (a)  @co : ty0 ~ ty'@.+--      (b)  ty' is not a newtype.+--+-- The function returns @Nothing@ for non-@newtypes@,+-- or unsaturated applications+--+-- This function does *not* look through type families, because it has no access to+-- the type family environment. If you do have that at hand, consider to use+-- topNormaliseType_maybe, which should be a drop-in replacement for+-- topNormaliseNewType_maybe+-- If topNormliseNewType_maybe ty = Just (co, ty'), then co : ty ~R ty'+topNormaliseNewType_maybe ty+  = topNormaliseTypeX unwrapNewTypeStepper mkTransCo ty++{-+%************************************************************************+%*                                                                      *+                   Comparison of coercions+%*                                                                      *+%************************************************************************+-}++-- | Syntactic equality of coercions+eqCoercion :: Coercion -> Coercion -> Bool+eqCoercion = eqType `on` coercionType++-- | Compare two 'Coercion's, with respect to an RnEnv2+eqCoercionX :: RnEnv2 -> Coercion -> Coercion -> Bool+eqCoercionX env = eqTypeX env `on` coercionType++{-+%************************************************************************+%*                                                                      *+                   "Lifting" substitution+           [(TyCoVar,Coercion)] -> Type -> Coercion+%*                                                                      *+%************************************************************************++Note [Lifting coercions over types: liftCoSubst]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The KPUSH rule deals with this situation+   data T a = MkK (a -> Maybe a)+   g :: T t1 ~ K t2+   x :: t1 -> Maybe t1++   case (K @t1 x) |> g of+     K (y:t2 -> Maybe t2) -> rhs++We want to push the coercion inside the constructor application.+So we do this++   g' :: t1~t2  =  Nth 0 g++   case K @t2 (x |> g' -> Maybe g') of+     K (y:t2 -> Maybe t2) -> rhs++The crucial operation is that we+  * take the type of K's argument: a -> Maybe a+  * and substitute g' for a+thus giving *coercion*.  This is what liftCoSubst does.++In the presence of kind coercions, this is a bit+of a hairy operation. So, we refer you to the paper introducing kind coercions,+available at www.cis.upenn.edu/~sweirich/papers/fckinds-extended.pdf+-}++-- ----------------------------------------------------+-- See Note [Lifting coercions over types: liftCoSubst]+-- ----------------------------------------------------++data LiftingContext = LC TCvSubst LiftCoEnv+  -- in optCoercion, we need to lift when optimizing InstCo.+  -- See Note [Optimising InstCo] in OptCoercion+  -- We thus propagate the substitution from OptCoercion here.++instance Outputable LiftingContext where+  ppr (LC _ env) = hang (text "LiftingContext:") 2 (ppr env)++type LiftCoEnv = VarEnv Coercion+     -- Maps *type variables* to *coercions*.+     -- That's the whole point of this function!++-- like liftCoSubstWith, but allows for existentially-bound types as well+liftCoSubstWithEx :: Role          -- desired role for output coercion+                  -> [TyVar]       -- universally quantified tyvars+                  -> [Coercion]    -- coercions to substitute for those+                  -> [TyVar]       -- existentially quantified tyvars+                  -> [Type]        -- types to be bound to ex vars+                  -> (Type -> Coercion, [Type]) -- (lifting function, converted ex args)+liftCoSubstWithEx role univs omegas exs rhos+  = let theta = mkLiftingContext (zipEqual "liftCoSubstWithExU" univs omegas)+        psi   = extendLiftingContextEx theta (zipEqual "liftCoSubstWithExX" exs rhos)+    in (ty_co_subst psi role, substTyVars (lcSubstRight psi) exs)++liftCoSubstWith :: Role -> [TyCoVar] -> [Coercion] -> Type -> Coercion+-- NB: This really can be called with CoVars, when optimising axioms.+liftCoSubstWith r tvs cos ty+  = liftCoSubst r (mkLiftingContext $ zipEqual "liftCoSubstWith" tvs cos) ty++-- | @liftCoSubst role lc ty@ produces a coercion (at role @role@)+-- that coerces between @lc_left(ty)@ and @lc_right(ty)@, where+-- @lc_left@ is a substitution mapping type variables to the left-hand+-- types of the mapped coercions in @lc@, and similar for @lc_right@.+liftCoSubst :: Role -> LiftingContext -> Type -> Coercion+liftCoSubst r lc@(LC subst env) ty+  | isEmptyVarEnv env = Refl r (substTy subst ty)+  | otherwise         = ty_co_subst lc r ty++emptyLiftingContext :: InScopeSet -> LiftingContext+emptyLiftingContext in_scope = LC (mkEmptyTCvSubst in_scope) emptyVarEnv++mkLiftingContext :: [(TyCoVar,Coercion)] -> LiftingContext+mkLiftingContext pairs+  = LC (mkEmptyTCvSubst $ mkInScopeSet $ tyCoVarsOfCos (map snd pairs))+       (mkVarEnv pairs)++mkSubstLiftingContext :: TCvSubst -> LiftingContext+mkSubstLiftingContext subst = LC subst emptyVarEnv++-- | Extend a lifting context with a new /type/ mapping.+extendLiftingContext :: LiftingContext  -- ^ original LC+                     -> TyVar           -- ^ new variable to map...+                     -> Coercion        -- ^ ...to this lifted version+                     -> LiftingContext+extendLiftingContext (LC subst env) tv arg+  = ASSERT( isTyVar tv )+    LC subst (extendVarEnv env tv arg)++-- | Extend a lifting context with existential-variable bindings.+-- This follows the lifting context extension definition in the+-- "FC with Explicit Kind Equality" paper.+extendLiftingContextEx :: LiftingContext    -- ^ original lifting context+                       -> [(TyVar,Type)]    -- ^ ex. var / value pairs+                       -> LiftingContext+-- Note that this is more involved than extendLiftingContext. That function+-- takes a coercion to extend with, so it's assumed that the caller has taken+-- into account any of the kind-changing stuff worried about here.+extendLiftingContextEx lc [] = lc+extendLiftingContextEx lc@(LC subst env) ((v,ty):rest)+-- This function adds bindings for *Nominal* coercions. Why? Because it+-- works with existentially bound variables, which are considered to have+-- nominal roles.+  = let lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfType ty)+                 (extendVarEnv env v (mkSymCo $ mkCoherenceCo+                                         (mkNomReflCo ty)+                                         (ty_co_subst lc Nominal (tyVarKind v))))+    in extendLiftingContextEx lc' rest++-- | Erase the environments in a lifting context+zapLiftingContext :: LiftingContext -> LiftingContext+zapLiftingContext (LC subst _) = LC (zapTCvSubst subst) emptyVarEnv++-- | Like 'substForAllCoBndr', but works on a lifting context+substForAllCoBndrCallbackLC :: Bool+                            -> (Coercion -> Coercion)+                            -> LiftingContext -> TyVar -> Coercion+                            -> (LiftingContext, TyVar, Coercion)+substForAllCoBndrCallbackLC sym sco (LC subst lc_env) tv co+  = (LC subst' lc_env, tv', co')+  where+    (subst', tv', co') = substForAllCoBndrCallback sym sco subst tv co++-- | The \"lifting\" operation which substitutes coercions for type+--   variables in a type to produce a coercion.+--+--   For the inverse operation, see 'liftCoMatch'+ty_co_subst :: LiftingContext -> Role -> Type -> Coercion+ty_co_subst lc role ty+  = go role ty+  where+    go :: Role -> Type -> Coercion+    go Phantom ty          = lift_phantom ty+    go r (TyVarTy tv)      = expectJust "ty_co_subst bad roles" $+                             liftCoSubstTyVar lc r tv+    go r (AppTy ty1 ty2)   = mkAppCo (go r ty1) (go Nominal ty2)+    go r (TyConApp tc tys) = mkTyConAppCo r tc (zipWith go (tyConRolesX r tc) tys)+    go r (FunTy ty1 ty2)   = mkFunCo r (go r ty1) (go r ty2)+    go r (ForAllTy (TvBndr v _) ty)+                           = let (lc', v', h) = liftCoSubstVarBndr lc v in+                             mkForAllCo v' h $! ty_co_subst lc' r ty+    go r ty@(LitTy {})     = ASSERT( r == Nominal )+                             mkReflCo r ty+    go r (CastTy ty co)    = castCoercionKind (go r ty) (substLeftCo lc co)+                                                        (substRightCo lc co)+    go r (CoercionTy co)   = mkProofIrrelCo r kco (substLeftCo lc co)+                                                  (substRightCo lc co)+      where kco = go Nominal (coercionType co)++    lift_phantom ty = mkPhantomCo (go Nominal (typeKind ty))+                                  (substTy (lcSubstLeft  lc) ty)+                                  (substTy (lcSubstRight lc) ty)++{-+Note [liftCoSubstTyVar]+~~~~~~~~~~~~~~~~~~~~~~~~~+This function can fail if a coercion in the environment is of too low a role.++liftCoSubstTyVar is called from two places: in liftCoSubst (naturally), and+also in matchAxiom in OptCoercion. From liftCoSubst, the so-called lifting+lemma guarantees that the roles work out. If we fail in this+case, we really should panic -- something is deeply wrong. But, in matchAxiom,+failing is fine. matchAxiom is trying to find a set of coercions+that match, but it may fail, and this is healthy behavior.+-}++-- See Note [liftCoSubstTyVar]+liftCoSubstTyVar :: LiftingContext -> Role -> TyVar -> Maybe Coercion+liftCoSubstTyVar (LC subst env) r v+  | Just co_arg <- lookupVarEnv env v+  = downgradeRole_maybe r (coercionRole co_arg) co_arg++  | otherwise+  = Just $ Refl r (substTyVar subst v)++liftCoSubstVarBndr :: LiftingContext -> TyVar+                   -> (LiftingContext, TyVar, Coercion)+liftCoSubstVarBndr lc tv+  = let (lc', tv', h, _) = liftCoSubstVarBndrCallback callback lc tv in+    (lc', tv', h)+  where+    callback lc' ty' = (ty_co_subst lc' Nominal ty', ())++-- the callback must produce a nominal coercion+liftCoSubstVarBndrCallback :: (LiftingContext -> Type -> (Coercion, a))+                           -> LiftingContext -> TyVar+                           -> (LiftingContext, TyVar, Coercion, a)+liftCoSubstVarBndrCallback fun lc@(LC subst cenv) old_var+  = ( LC (subst `extendTCvInScope` new_var) new_cenv+    , new_var, eta, stuff )+  where+    old_kind     = tyVarKind old_var+    (eta, stuff) = fun lc old_kind+    Pair k1 _    = coercionKind eta+    new_var      = uniqAway (getTCvInScope subst) (setVarType old_var k1)++    lifted   = Refl Nominal (TyVarTy new_var)+    new_cenv = extendVarEnv cenv old_var lifted++-- | Is a var in the domain of a lifting context?+isMappedByLC :: TyCoVar -> LiftingContext -> Bool+isMappedByLC tv (LC _ env) = tv `elemVarEnv` env++-- If [a |-> g] is in the substitution and g :: t1 ~ t2, substitute a for t1+-- If [a |-> (g1, g2)] is in the substitution, substitute a for g1+substLeftCo :: LiftingContext -> Coercion -> Coercion+substLeftCo lc co+  = substCo (lcSubstLeft lc) co++-- Ditto, but for t2 and g2+substRightCo :: LiftingContext -> Coercion -> Coercion+substRightCo lc co+  = substCo (lcSubstRight lc) co++-- | Apply "sym" to all coercions in a 'LiftCoEnv'+swapLiftCoEnv :: LiftCoEnv -> LiftCoEnv+swapLiftCoEnv = mapVarEnv mkSymCo++lcSubstLeft :: LiftingContext -> TCvSubst+lcSubstLeft (LC subst lc_env) = liftEnvSubstLeft subst lc_env++lcSubstRight :: LiftingContext -> TCvSubst+lcSubstRight (LC subst lc_env) = liftEnvSubstRight subst lc_env++liftEnvSubstLeft :: TCvSubst -> LiftCoEnv -> TCvSubst+liftEnvSubstLeft = liftEnvSubst pFst++liftEnvSubstRight :: TCvSubst -> LiftCoEnv -> TCvSubst+liftEnvSubstRight = liftEnvSubst pSnd++liftEnvSubst :: (forall a. Pair a -> a) -> TCvSubst -> LiftCoEnv -> TCvSubst+liftEnvSubst selector subst lc_env+  = composeTCvSubst (TCvSubst emptyInScopeSet tenv cenv) subst+  where+    pairs            = nonDetUFMToList lc_env+                       -- It's OK to use nonDetUFMToList here because we+                       -- immediately forget the ordering by creating+                       -- a VarEnv+    (tpairs, cpairs) = partitionWith ty_or_co pairs+    tenv             = mkVarEnv_Directly tpairs+    cenv             = mkVarEnv_Directly cpairs++    ty_or_co :: (Unique, Coercion) -> Either (Unique, Type) (Unique, Coercion)+    ty_or_co (u, co)+      | Just equality_co <- isCoercionTy_maybe equality_ty+      = Right (u, equality_co)+      | otherwise+      = Left (u, equality_ty)+      where+        equality_ty = selector (coercionKind co)++-- | Extract the underlying substitution from the LiftingContext+lcTCvSubst :: LiftingContext -> TCvSubst+lcTCvSubst (LC subst _) = subst++-- | Get the 'InScopeSet' from a 'LiftingContext'+lcInScopeSet :: LiftingContext -> InScopeSet+lcInScopeSet (LC subst _) = getTCvInScope subst++{-+%************************************************************************+%*                                                                      *+            Sequencing on coercions+%*                                                                      *+%************************************************************************+-}++seqCo :: Coercion -> ()+seqCo (Refl r ty)               = r `seq` seqType ty+seqCo (TyConAppCo r tc cos)     = r `seq` tc `seq` seqCos cos+seqCo (AppCo co1 co2)           = seqCo co1 `seq` seqCo co2+seqCo (ForAllCo tv k co)        = seqType (tyVarKind tv) `seq` seqCo k+                                                         `seq` seqCo co+seqCo (FunCo r co1 co2)         = r `seq` seqCo co1 `seq` seqCo co2+seqCo (CoVarCo cv)              = cv `seq` ()+seqCo (AxiomInstCo con ind cos) = con `seq` ind `seq` seqCos cos+seqCo (UnivCo p r t1 t2)+  = seqProv p `seq` r `seq` seqType t1 `seq` seqType t2+seqCo (SymCo co)                = seqCo co+seqCo (TransCo co1 co2)         = seqCo co1 `seq` seqCo co2+seqCo (NthCo n co)              = n `seq` seqCo co+seqCo (LRCo lr co)              = lr `seq` seqCo co+seqCo (InstCo co arg)           = seqCo co `seq` seqCo arg+seqCo (CoherenceCo co1 co2)     = seqCo co1 `seq` seqCo co2+seqCo (KindCo co)               = seqCo co+seqCo (SubCo co)                = seqCo co+seqCo (AxiomRuleCo _ cs)        = seqCos cs++seqProv :: UnivCoProvenance -> ()+seqProv UnsafeCoerceProv    = ()+seqProv (PhantomProv co)    = seqCo co+seqProv (ProofIrrelProv co) = seqCo co+seqProv (PluginProv _)      = ()+seqProv (HoleProv _)        = ()++seqCos :: [Coercion] -> ()+seqCos []       = ()+seqCos (co:cos) = seqCo co `seq` seqCos cos++{-+%************************************************************************+%*                                                                      *+             The kind of a type, and of a coercion+%*                                                                      *+%************************************************************************++Note [Computing a coercion kind and role]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To compute a coercion's kind is straightforward: see coercionKind.+But to compute a coercion's role, in the case for NthCo we need+its kind as well.  So if we have two separate functions (one for kinds+and one for roles) we can get exponentially bad behaviour, since each+NthCo node makes a separate call to coercionKind, which traverses the+sub-tree again.  This was part of the problem in Trac #9233.++Solution: compute both together; hence coercionKindRole.  We keep a+separate coercionKind function because it's a bit more efficient if+the kind is all you want.+-}++coercionType :: Coercion -> Type+coercionType co = case coercionKindRole co of+  (Pair ty1 ty2, r) -> mkCoercionType r ty1 ty2++------------------+-- | If it is the case that+--+-- > c :: (t1 ~ t2)+--+-- i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@.++coercionKind :: Coercion -> Pair Type+coercionKind co = go co+  where+    go (Refl _ ty)          = Pair ty ty+    go (TyConAppCo _ tc cos)= mkTyConApp tc <$> (sequenceA $ map go cos)+    go (AppCo co1 co2)      = mkAppTy <$> go co1 <*> go co2+    go (ForAllCo tv1 k_co co)+      = let Pair _ k2          = go k_co+            tv2                = setTyVarKind tv1 k2+            Pair ty1 ty2       = go co+            subst = zipTvSubst [tv1] [TyVarTy tv2 `mk_cast_ty` mkSymCo k_co]+            ty2' = substTyAddInScope subst ty2 in+            -- We need free vars of ty2 in scope to satisfy the invariant+            -- from Note [The substitution invariant]+            -- This is doing repeated substitutions and probably doesn't+            -- need to, see #11735+        mkInvForAllTy <$> Pair tv1 tv2 <*> Pair ty1 ty2'+    go (FunCo _ co1 co2)    = mkFunTy <$> go co1 <*> go co2+    go (CoVarCo cv)         = coVarTypes cv+    go (AxiomInstCo ax ind cos)+      | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs+                   , cab_lhs = lhs, cab_rhs = rhs } <- coAxiomNthBranch ax ind+      , let Pair tycos1 tycos2 = sequenceA (map go cos)+            (tys1, cotys1) = splitAtList tvs tycos1+            (tys2, cotys2) = splitAtList tvs tycos2+            cos1           = map stripCoercionTy cotys1+            cos2           = map stripCoercionTy cotys2+      = ASSERT( cos `equalLength` (tvs ++ cvs) )+                  -- Invariant of AxiomInstCo: cos should+                  -- exactly saturate the axiom branch+        Pair (substTyWith tvs tys1 $+              substTyWithCoVars cvs cos1 $+              mkTyConApp (coAxiomTyCon ax) lhs)+             (substTyWith tvs tys2 $+              substTyWithCoVars cvs cos2 rhs)+    go (UnivCo _ _ ty1 ty2)   = Pair ty1 ty2+    go (SymCo co)             = swap $ go co+    go (TransCo co1 co2)      = Pair (pFst $ go co1) (pSnd $ go co2)+    go g@(NthCo d co)+      | Just argss <- traverse tyConAppArgs_maybe tys+      = ASSERT( and $ ((d <) . length) <$> argss )+        (`getNth` d) <$> argss++      | d == 0+      , Just splits <- traverse splitForAllTy_maybe tys+      = (tyVarKind . fst) <$> splits++      | otherwise+      = pprPanic "coercionKind" (ppr g)+      where+        tys = go co+    go (LRCo lr co)         = (pickLR lr . splitAppTy) <$> go co+    go (InstCo aco arg)     = go_app aco [arg]+    go (CoherenceCo g h)+      = let Pair ty1 ty2 = go g in+        Pair (mkCastTy ty1 h) ty2+    go (KindCo co)          = typeKind <$> go co+    go (SubCo co)           = go co+    go (AxiomRuleCo ax cos) = expectJust "coercionKind" $+                              coaxrProves ax (map go cos)++    go_app :: Coercion -> [Coercion] -> Pair Type+    -- Collect up all the arguments and apply all at once+    -- See Note [Nested InstCos]+    go_app (InstCo co arg) args = go_app co (arg:args)+    go_app co              args = piResultTys <$> go co <*> (sequenceA $ map go args)++    -- The real mkCastTy is too slow, and we can easily have nested ForAllCos.+    mk_cast_ty :: Type -> Coercion -> Type+    mk_cast_ty ty (Refl {}) = ty+    mk_cast_ty ty co        = CastTy ty co++-- | Apply 'coercionKind' to multiple 'Coercion's+coercionKinds :: [Coercion] -> Pair [Type]+coercionKinds tys = sequenceA $ map coercionKind tys++-- | Get a coercion's kind and role.+-- Why both at once?  See Note [Computing a coercion kind and role]+coercionKindRole :: Coercion -> (Pair Type, Role)+coercionKindRole = go+  where+    go (Refl r ty) = (Pair ty ty, r)+    go (TyConAppCo r tc cos)+      = (mkTyConApp tc <$> (sequenceA $ map coercionKind cos), r)+    go (AppCo co1 co2)+      = let (tys1, r1) = go co1 in+        (mkAppTy <$> tys1 <*> coercionKind co2, r1)+    go (ForAllCo tv1 k_co co)+      = let Pair _ k2          = coercionKind k_co+            tv2                = setTyVarKind tv1 k2+            (Pair ty1 ty2, r)  = go co+            subst = zipTvSubst [tv1] [TyVarTy tv2 `mkCastTy` mkSymCo k_co]+            ty2' = substTyAddInScope subst ty2 in+            -- We need free vars of ty2 in scope to satisfy the invariant+            -- from Note [The substitution invariant]+            -- This is doing repeated substitutions and probably doesn't+            -- need to, see #11735+        (mkInvForAllTy <$> Pair tv1 tv2 <*> Pair ty1 ty2', r)+    go (FunCo r co1 co2)+      = (mkFunTy <$> coercionKind co1 <*> coercionKind co2, r)+    go (CoVarCo cv) = (coVarTypes cv, coVarRole cv)+    go co@(AxiomInstCo ax _ _) = (coercionKind co, coAxiomRole ax)+    go (UnivCo _ r ty1 ty2)  = (Pair ty1 ty2, r)+    go (SymCo co) = first swap $ go co+    go (TransCo co1 co2)+      = let (tys1, r) = go co1 in+        (Pair (pFst tys1) (pSnd $ coercionKind co2), r)+    go (NthCo d co)+      | Just (tv1, _) <- splitForAllTy_maybe ty1+      = ASSERT( d == 0 )+        let (tv2, _) = splitForAllTy ty2 in+        (tyVarKind <$> Pair tv1 tv2, Nominal)++      | otherwise+      = let (tc1,  args1) = splitTyConApp ty1+            (_tc2, args2) = splitTyConApp ty2+        in+        ASSERT2( tc1 == _tc2, ppr d $$ ppr tc1 $$ ppr _tc2 )+        ((`getNth` d) <$> Pair args1 args2, nthRole r tc1 d)++      where+        (Pair ty1 ty2, r) = go co+    go co@(LRCo {}) = (coercionKind co, Nominal)+    go (InstCo co arg) = go_app co [arg]+    go (CoherenceCo co1 co2)+      = let (Pair t1 t2, r) = go co1 in+        (Pair (t1 `mkCastTy` co2) t2, r)+    go co@(KindCo {}) = (coercionKind co, Nominal)+    go (SubCo co) = (coercionKind co, Representational)+    go co@(AxiomRuleCo ax _) = (coercionKind co, coaxrRole ax)++    go_app :: Coercion -> [Coercion] -> (Pair Type, Role)+    -- Collect up all the arguments and apply all at once+    -- See Note [Nested InstCos]+    go_app (InstCo co arg) args = go_app co (arg:args)+    go_app co              args+      = let (pair, r) = go co in+        (piResultTys <$> pair <*> (sequenceA $ map coercionKind args), r)++-- | Retrieve the role from a coercion.+coercionRole :: Coercion -> Role+coercionRole = snd . coercionKindRole+  -- There's not a better way to do this, because NthCo needs the *kind*+  -- and role of its argument. Luckily, laziness should generally avoid+  -- the need for computing kinds in other cases.++{-+Note [Nested InstCos]+~~~~~~~~~~~~~~~~~~~~~+In Trac #5631 we found that 70% of the entire compilation time was+being spent in coercionKind!  The reason was that we had+   (g @ ty1 @ ty2 .. @ ty100)    -- The "@s" are InstCos+where+   g :: forall a1 a2 .. a100. phi+If we deal with the InstCos one at a time, we'll do this:+   1.  Find the kind of (g @ ty1 .. @ ty99) : forall a100. phi'+   2.  Substitute phi'[ ty100/a100 ], a single tyvar->type subst+But this is a *quadratic* algorithm, and the blew up Trac #5631.+So it's very important to do the substitution simultaneously;+cf Type.piResultTys (which in fact we call here).++-}
+ types/Coercion.hs-boot view
@@ -0,0 +1,51 @@+{-# LANGUAGE FlexibleContexts #-}++module Coercion where++import {-# SOURCE #-} TyCoRep+import {-# SOURCE #-} TyCon++import BasicTypes ( LeftOrRight )+import CoAxiom+import Var+import Outputable+import Pair+import Util++mkReflCo :: Role -> Type -> Coercion+mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion+mkAppCo :: Coercion -> Coercion -> Coercion+mkForAllCo :: TyVar -> Coercion -> Coercion -> Coercion+mkFunCo :: Role -> Coercion -> Coercion -> Coercion+mkCoVarCo :: CoVar -> Coercion+mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion+mkPhantomCo :: Coercion -> Type -> Type -> Coercion+mkUnsafeCo :: Role -> Type -> Type -> Coercion+mkUnivCo :: UnivCoProvenance -> Role -> Type -> Type -> Coercion+mkSymCo :: Coercion -> Coercion+mkTransCo :: Coercion -> Coercion -> Coercion+mkNthCo :: Int -> Coercion -> Coercion+mkLRCo :: LeftOrRight -> Coercion -> Coercion+mkInstCo :: Coercion -> Coercion -> Coercion+mkCoherenceCo :: Coercion -> Coercion -> Coercion+mkKindCo :: Coercion -> Coercion+mkSubCo :: Coercion -> Coercion+mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion++mkFunCos :: Role -> [Coercion] -> Coercion -> Coercion++isReflCo :: Coercion -> Bool+isReflexiveCo :: Coercion -> Bool+coVarKindsTypesRole :: CoVar -> (Kind, Kind, Type, Type, Role)+coVarRole :: CoVar -> Role++mkCoercionType :: Role -> Type -> Type -> Type++data LiftingContext+liftCoSubst :: Role -> LiftingContext -> Type -> Coercion+seqCo :: Coercion -> ()++coercionKind :: Coercion -> Pair Type+coercionType :: Coercion -> Type++pprCo :: Coercion -> SDoc
+ types/FamInstEnv.hs view
@@ -0,0 +1,1724 @@+-- (c) The University of Glasgow 2006+--+-- FamInstEnv: Type checked family instance declarations++{-# LANGUAGE CPP, GADTs, ScopedTypeVariables #-}++module FamInstEnv (+        FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS,+        famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon,+        pprFamInst, pprFamInsts,+        mkImportedFamInst,++        FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs,+        extendFamInstEnv, extendFamInstEnvList,+        famInstEnvElts, famInstEnvSize, familyInstances,++        -- * CoAxioms+        mkCoAxBranch, mkBranchedCoAxiom, mkUnbranchedCoAxiom, mkSingleCoAxiom,+        mkNewTypeCoAxiom,++        FamInstMatch(..),+        lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvByTyCon,++        isDominatedBy, apartnessCheck,++        -- Injectivity+        InjectivityCheckResult(..),+        lookupFamInstEnvInjectivityConflicts, injectiveBranches,++        -- Normalisation+        topNormaliseType, topNormaliseType_maybe,+        normaliseType, normaliseTcApp,+        reduceTyFamApp_maybe,+        pmTopNormaliseType_maybe,++        -- Flattening+        flattenTys+    ) where++#include "HsVersions.h"++import Unify+import Type+import TyCoRep+import TyCon+import DataCon (DataCon)+import Coercion+import CoAxiom+import VarSet+import VarEnv+import Name+import PrelNames ( eqPrimTyConKey )+import UniqDFM+import Outputable+import Maybes+import TrieMap+import Unique+import Util+import Var+import Pair+import SrcLoc+import FastString+import MonadUtils+import Control.Monad+import Data.List( mapAccumL, find )++{-+************************************************************************+*                                                                      *+          Type checked family instance heads+*                                                                      *+************************************************************************++Note [FamInsts and CoAxioms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* CoAxioms and FamInsts are just like+  DFunIds  and ClsInsts++* A CoAxiom is a System-FC thing: it can relate any two types++* A FamInst is a Haskell source-language thing, corresponding+  to a type/data family instance declaration.+    - The FamInst contains a CoAxiom, which is the evidence+      for the instance++    - The LHS of the CoAxiom is always of form F ty1 .. tyn+      where F is a type family+-}++data FamInst  -- See Note [FamInsts and CoAxioms]+  = FamInst { fi_axiom  :: CoAxiom Unbranched -- The new coercion axiom+                                              -- introduced by this family+                                              -- instance+                 -- INVARIANT: apart from freshening (see below)+                 --    fi_tvs = cab_tvs of the (single) axiom branch+                 --    fi_cvs = cab_cvs ...ditto...+                 --    fi_tys = cab_lhs ...ditto...+                 --    fi_rhs = cab_rhs ...ditto...++            , fi_flavor :: FamFlavor++            -- Everything below here is a redundant,+            -- cached version of the two things above+            -- except that the TyVars are freshened+            , fi_fam   :: Name          -- Family name++                -- Used for "rough matching"; same idea as for class instances+                -- See Note [Rough-match field] in InstEnv+            , fi_tcs   :: [Maybe Name]  -- Top of type args+                -- INVARIANT: fi_tcs = roughMatchTcs fi_tys++            -- Used for "proper matching"; ditto+            , fi_tvs :: [TyVar]      -- Template tyvars for full match+            , fi_cvs :: [CoVar]      -- Template covars for full match+                 -- Like ClsInsts, these variables are always fresh+                 -- See Note [Template tyvars are fresh] in InstEnv++            , fi_tys    :: [Type]       --   The LHS type patterns+            -- May be eta-reduced; see Note [Eta reduction for data families]++            , fi_rhs :: Type         --   the RHS, with its freshened vars+            }++data FamFlavor+  = SynFamilyInst         -- A synonym family+  | DataFamilyInst TyCon  -- A data family, with its representation TyCon++{- Note [Eta reduction for data families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this+   data family T a b :: *+   newtype instance T Int a = MkT (IO a) deriving( Monad )+We'd like this to work.++From the 'newtype instance' you might think we'd get:+   newtype TInt a = MkT (IO a)+   axiom ax1 a :: T Int a ~ TInt a   -- The newtype-instance part+   axiom ax2 a :: TInt a ~ IO a      -- The newtype part++But now what can we do?  We have this problem+   Given:   d  :: Monad IO+   Wanted:  d' :: Monad (T Int) = d |> ????+What coercion can we use for the ???++Solution: eta-reduce both axioms, thus:+   axiom ax1 :: T Int ~ TInt+   axiom ax2 :: TInt ~ IO+Now+   d' = d |> Monad (sym (ax2 ; ax1))++This eta reduction happens for data instances as well as newtype+instances. Here we want to eta-reduce the data family axiom.+All this is done in TcInstDcls.tcDataFamInstDecl.++See also Note [Newtype eta] in TyCon.++Bottom line:+  For a FamInst with fi_flavour = DataFamilyInst rep_tc,+  - fi_tvs may be shorter than tyConTyVars of rep_tc+  - fi_tys may be shorter than tyConArity of the family tycon+       i.e. LHS is unsaturated+  - fi_rhs will be (rep_tc fi_tvs)+       i.e. RHS is un-saturated++  But when fi_flavour = SynFamilyInst,+  - fi_tys has the exact arity of the family tycon+-}++-- Obtain the axiom of a family instance+famInstAxiom :: FamInst -> CoAxiom Unbranched+famInstAxiom = fi_axiom++-- Split the left-hand side of the FamInst+famInstSplitLHS :: FamInst -> (TyCon, [Type])+famInstSplitLHS (FamInst { fi_axiom = axiom, fi_tys = lhs })+  = (coAxiomTyCon axiom, lhs)++-- Get the RHS of the FamInst+famInstRHS :: FamInst -> Type+famInstRHS = fi_rhs++-- Get the family TyCon of the FamInst+famInstTyCon :: FamInst -> TyCon+famInstTyCon = coAxiomTyCon . famInstAxiom++-- Return the representation TyCons introduced by data family instances, if any+famInstsRepTyCons :: [FamInst] -> [TyCon]+famInstsRepTyCons fis = [tc | FamInst { fi_flavor = DataFamilyInst tc } <- fis]++-- Extracts the TyCon for this *data* (or newtype) instance+famInstRepTyCon_maybe :: FamInst -> Maybe TyCon+famInstRepTyCon_maybe fi+  = case fi_flavor fi of+       DataFamilyInst tycon -> Just tycon+       SynFamilyInst        -> Nothing++dataFamInstRepTyCon :: FamInst -> TyCon+dataFamInstRepTyCon fi+  = case fi_flavor fi of+       DataFamilyInst tycon -> tycon+       SynFamilyInst        -> pprPanic "dataFamInstRepTyCon" (ppr fi)++{-+************************************************************************+*                                                                      *+        Pretty printing+*                                                                      *+************************************************************************+-}++instance NamedThing FamInst where+   getName = coAxiomName . fi_axiom++instance Outputable FamInst where+   ppr = pprFamInst++-- Prints the FamInst as a family instance declaration+-- NB: FamInstEnv.pprFamInst is used only for internal, debug printing+--     See pprTyThing.pprFamInst for printing for the user+pprFamInst :: FamInst -> SDoc+pprFamInst famInst+  = hang (pprFamInstHdr famInst) 2 (ifPprDebug debug_stuff)+  where+    ax = fi_axiom famInst+    debug_stuff = vcat [ text "Coercion axiom:" <+> ppr ax+                       , text "Tvs:" <+> ppr (fi_tvs famInst)+                       , text "LHS:" <+> ppr (fi_tys famInst)+                       , text "RHS:" <+> ppr (fi_rhs famInst) ]++pprFamInstHdr :: FamInst -> SDoc+pprFamInstHdr fi@(FamInst {fi_flavor = flavor})+  = pprTyConSort <+> pp_instance <+> pp_head+  where+    -- For *associated* types, say "type T Int = blah"+    -- For *top level* type instances, say "type instance T Int = blah"+    pp_instance+      | isTyConAssoc fam_tc = empty+      | otherwise           = text "instance"++    (fam_tc, etad_lhs_tys) = famInstSplitLHS fi+    vanilla_pp_head = pprTypeApp fam_tc etad_lhs_tys++    pp_head | DataFamilyInst rep_tc <- flavor+            , isAlgTyCon rep_tc+            , let extra_tvs = dropList etad_lhs_tys (tyConTyVars rep_tc)+            , not (null extra_tvs)+            = getPprStyle $ \ sty ->+              if debugStyle sty+              then vanilla_pp_head   -- With -dppr-debug just show it as-is+              else pprTypeApp fam_tc (etad_lhs_tys ++ mkTyVarTys extra_tvs)+                     -- Without -dppr-debug, eta-expand+                     -- See Trac #8674+                     -- (This is probably over the top now that we use this+                     --  only for internal debug printing; PprTyThing.pprFamInst+                     --  is used for user-level printing.)+            | otherwise+            = vanilla_pp_head++    pprTyConSort = case flavor of+                     SynFamilyInst        -> text "type"+                     DataFamilyInst tycon+                       | isDataTyCon     tycon -> text "data"+                       | isNewTyCon      tycon -> text "newtype"+                       | isAbstractTyCon tycon -> text "data"+                       | otherwise             -> text "WEIRD" <+> ppr tycon++pprFamInsts :: [FamInst] -> SDoc+pprFamInsts finsts = vcat (map pprFamInst finsts)++{-+Note [Lazy axiom match]+~~~~~~~~~~~~~~~~~~~~~~~+It is Vitally Important that mkImportedFamInst is *lazy* in its axiom+parameter. The axiom is loaded lazily, via a forkM, in TcIface. Sometime+later, mkImportedFamInst is called using that axiom. However, the axiom+may itself depend on entities which are not yet loaded as of the time+of the mkImportedFamInst. Thus, if mkImportedFamInst eagerly looks at the+axiom, a dependency loop spontaneously appears and GHC hangs. The solution+is simply for mkImportedFamInst never, ever to look inside of the axiom+until everything else is good and ready to do so. We can assume that this+readiness has been achieved when some other code pulls on the axiom in the+FamInst. Thus, we pattern match on the axiom lazily (in the where clause,+not in the parameter list) and we assert the consistency of names there+also.+-}++-- Make a family instance representation from the information found in an+-- interface file.  In particular, we get the rough match info from the iface+-- (instead of computing it here).+mkImportedFamInst :: Name               -- Name of the family+                  -> [Maybe Name]       -- Rough match info+                  -> CoAxiom Unbranched -- Axiom introduced+                  -> FamInst            -- Resulting family instance+mkImportedFamInst fam mb_tcs axiom+  = FamInst {+      fi_fam    = fam,+      fi_tcs    = mb_tcs,+      fi_tvs    = tvs,+      fi_cvs    = cvs,+      fi_tys    = tys,+      fi_rhs    = rhs,+      fi_axiom  = axiom,+      fi_flavor = flavor }+  where+     -- See Note [Lazy axiom match]+     ~(CoAxBranch { cab_lhs = tys+                  , cab_tvs = tvs+                  , cab_cvs = cvs+                  , cab_rhs = rhs }) = coAxiomSingleBranch axiom++         -- Derive the flavor for an imported FamInst rather disgustingly+         -- Maybe we should store it in the IfaceFamInst?+     flavor = case splitTyConApp_maybe rhs of+                Just (tc, _)+                  | Just ax' <- tyConFamilyCoercion_maybe tc+                  , ax' == axiom+                  -> DataFamilyInst tc+                _ -> SynFamilyInst++{-+************************************************************************+*                                                                      *+                FamInstEnv+*                                                                      *+************************************************************************++Note [FamInstEnv]+~~~~~~~~~~~~~~~~~+A FamInstEnv maps a family name to the list of known instances for that family.++The same FamInstEnv includes both 'data family' and 'type family' instances.+Type families are reduced during type inference, but not data families;+the user explains when to use a data family instance by using constructors+and pattern matching.++Nevertheless it is still useful to have data families in the FamInstEnv:++ - For finding overlaps and conflicts++ - For finding the representation type...see FamInstEnv.topNormaliseType+   and its call site in Simplify++ - In standalone deriving instance Eq (T [Int]) we need to find the+   representation type for T [Int]++Note [Varying number of patterns for data family axioms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For data families, the number of patterns may vary between instances.+For example+   data family T a b+   data instance T Int a = T1 a | T2+   data instance T Bool [a] = T3 a++Then we get a data type for each instance, and an axiom:+   data TInt a = T1 a | T2+   data TBoolList a = T3 a++   axiom ax7   :: T Int ~ TInt   -- Eta-reduced+   axiom ax8 a :: T Bool [a] ~ TBoolList a++These two axioms for T, one with one pattern, one with two;+see Note [Eta reduction for data families]++Note [FamInstEnv determinism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We turn FamInstEnvs into a list in some places that don't directly affect+the ABI. That happens in family consistency checks and when producing output+for `:info`. Unfortunately that nondeterminism is nonlocal and it's hard+to tell what it affects without following a chain of functions. It's also+easy to accidentally make that nondeterminism affect the ABI. Furthermore+the envs should be relatively small, so it should be free to use deterministic+maps here. Testing with nofib and validate detected no difference between+UniqFM and UniqDFM.+See Note [Deterministic UniqFM].+-}++type FamInstEnv = UniqDFM FamilyInstEnv  -- Maps a family to its instances+     -- See Note [FamInstEnv]+     -- See Note [FamInstEnv determinism]++type FamInstEnvs = (FamInstEnv, FamInstEnv)+     -- External package inst-env, Home-package inst-env++newtype FamilyInstEnv+  = FamIE [FamInst]     -- The instances for a particular family, in any order++instance Outputable FamilyInstEnv where+  ppr (FamIE fs) = text "FamIE" <+> vcat (map ppr fs)++-- INVARIANTS:+--  * The fs_tvs are distinct in each FamInst+--      of a range value of the map (so we can safely unify them)++emptyFamInstEnvs :: (FamInstEnv, FamInstEnv)+emptyFamInstEnvs = (emptyFamInstEnv, emptyFamInstEnv)++emptyFamInstEnv :: FamInstEnv+emptyFamInstEnv = emptyUDFM++famInstEnvElts :: FamInstEnv -> [FamInst]+famInstEnvElts fi = [elt | FamIE elts <- eltsUDFM fi, elt <- elts]+  -- See Note [FamInstEnv determinism]++famInstEnvSize :: FamInstEnv -> Int+famInstEnvSize = nonDetFoldUDFM (\(FamIE elt) sum -> sum + length elt) 0+  -- It's OK to use nonDetFoldUDFM here since we're just computing the+  -- size.++familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst]+familyInstances (pkg_fie, home_fie) fam+  = get home_fie ++ get pkg_fie+  where+    get env = case lookupUDFM env fam of+                Just (FamIE insts) -> insts+                Nothing                      -> []++extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv+extendFamInstEnvList inst_env fis = foldl extendFamInstEnv inst_env fis++extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv+extendFamInstEnv inst_env+                 ins_item@(FamInst {fi_fam = cls_nm})+  = addToUDFM_C add inst_env cls_nm (FamIE [ins_item])+  where+    add (FamIE items) _ = FamIE (ins_item:items)++{-+************************************************************************+*                                                                      *+                Compatibility+*                                                                      *+************************************************************************++Note [Apartness]+~~~~~~~~~~~~~~~~+In dealing with closed type families, we must be able to check that one type+will never reduce to another. This check is called /apartness/. The check+is always between a target (which may be an arbitrary type) and a pattern.+Here is how we do it:++apart(target, pattern) = not (unify(flatten(target), pattern))++where flatten (implemented in flattenTys, below) converts all type-family+applications into fresh variables. (See Note [Flattening].)++Note [Compatibility]+~~~~~~~~~~~~~~~~~~~~+Two patterns are /compatible/ if either of the following conditions hold:+1) The patterns are apart.+2) The patterns unify with a substitution S, and their right hand sides+equal under that substitution.++For open type families, only compatible instances are allowed. For closed+type families, the story is slightly more complicated. Consider the following:++type family F a where+  F Int = Bool+  F a   = Int++g :: Show a => a -> F a+g x = length (show x)++Should that type-check? No. We need to allow for the possibility that 'a'+might be Int and therefore 'F a' should be Bool. We can simplify 'F a' to Int+only when we can be sure that 'a' is not Int.++To achieve this, after finding a possible match within the equations, we have to+go back to all previous equations and check that, under the+substitution induced by the match, other branches are surely apart. (See+Note [Apartness].) This is similar to what happens with class+instance selection, when we need to guarantee that there is only a match and+no unifiers. The exact algorithm is different here because the the+potentially-overlapping group is closed.++As another example, consider this:++type family G x where+  G Int = Bool+  G a   = Double++type family H y+-- no instances++Now, we want to simplify (G (H Char)). We can't, because (H Char) might later+simplify to be Int. So, (G (H Char)) is stuck, for now.++While everything above is quite sound, it isn't as expressive as we'd like.+Consider this:++type family J a where+  J Int = Int+  J a   = a++Can we simplify (J b) to b? Sure we can. Yes, the first equation matches if+b is instantiated with Int, but the RHSs coincide there, so it's all OK.++So, the rule is this: when looking up a branch in a closed type family, we+find a branch that matches the target, but then we make sure that the target+is apart from every previous *incompatible* branch. We don't check the+branches that are compatible with the matching branch, because they are either+irrelevant (clause 1 of compatible) or benign (clause 2 of compatible).+-}++-- See Note [Compatibility]+compatibleBranches :: CoAxBranch -> CoAxBranch -> Bool+compatibleBranches (CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 })+                   (CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 })+  = case tcUnifyTysFG (const BindMe) lhs1 lhs2 of+      SurelyApart -> True+      Unifiable subst+        | Type.substTyAddInScope subst rhs1 `eqType`+          Type.substTyAddInScope subst rhs2+        -> True+      _ -> False++-- | Result of testing two type family equations for injectiviy.+data InjectivityCheckResult+   = InjectivityAccepted+    -- ^ Either RHSs are distinct or unification of RHSs leads to unification of+    -- LHSs+   | InjectivityUnified CoAxBranch CoAxBranch+    -- ^ RHSs unify but LHSs don't unify under that substitution.  Relevant for+    -- closed type families where equation after unification might be+    -- overlpapped (in which case it is OK if they don't unify).  Constructor+    -- stores axioms after unification.++-- | Check whether two type family axioms don't violate injectivity annotation.+injectiveBranches :: [Bool] -> CoAxBranch -> CoAxBranch+                  -> InjectivityCheckResult+injectiveBranches injectivity+                  ax1@(CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 })+                  ax2@(CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 })+  -- See Note [Verifying injectivity annotation]. This function implements first+  -- check described there.+  = let getInjArgs  = filterByList injectivity+    in case tcUnifyTyWithTFs True rhs1 rhs2 of -- True = two-way pre-unification+       Nothing -> InjectivityAccepted -- RHS are different, so equations are+                                      -- injective.+       Just subst -> -- RHS unify under a substitution+        let lhs1Subst = Type.substTys subst (getInjArgs lhs1)+            lhs2Subst = Type.substTys subst (getInjArgs lhs2)+        -- If LHSs are equal under the substitution used for RHSs then this pair+        -- of equations does not violate injectivity annotation. If LHSs are not+        -- equal under that substitution then this pair of equations violates+        -- injectivity annotation, but for closed type families it still might+        -- be the case that one LHS after substitution is unreachable.+        in if eqTypes lhs1Subst lhs2Subst+           then InjectivityAccepted+           else InjectivityUnified ( ax1 { cab_lhs = Type.substTys subst lhs1+                                         , cab_rhs = Type.substTy  subst rhs1 })+                                   ( ax2 { cab_lhs = Type.substTys subst lhs2+                                         , cab_rhs = Type.substTy  subst rhs2 })++-- takes a CoAxiom with unknown branch incompatibilities and computes+-- the compatibilities+-- See Note [Storing compatibility] in CoAxiom+computeAxiomIncomps :: [CoAxBranch] -> [CoAxBranch]+computeAxiomIncomps branches+  = snd (mapAccumL go [] branches)+  where+    go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch)+    go prev_brs cur_br+       = (cur_br : prev_brs, new_br)+       where+         new_br = cur_br { cab_incomps = mk_incomps prev_brs cur_br }++    mk_incomps :: [CoAxBranch] -> CoAxBranch -> [CoAxBranch]+    mk_incomps prev_brs cur_br+       = filter (not . compatibleBranches cur_br) prev_brs++{-+************************************************************************+*                                                                      *+           Constructing axioms+    These functions are here because tidyType / tcUnifyTysFG+    are not available in CoAxiom++    Also computeAxiomIncomps is too sophisticated for CoAxiom+*                                                                      *+************************************************************************++Note [Tidy axioms when we build them]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We print out axioms and don't want to print stuff like+    F k k a b = ...+Instead we must tidy those kind variables.  See Trac #7524.+-}++-- all axiom roles are Nominal, as this is only used with type families+mkCoAxBranch :: [TyVar] -- original, possibly stale, tyvars+             -> [CoVar] -- possibly stale covars+             -> [Type]  -- LHS patterns+             -> Type    -- RHS+             -> [Role]+             -> SrcSpan+             -> CoAxBranch+mkCoAxBranch tvs cvs lhs rhs roles loc+  = CoAxBranch { cab_tvs     = tvs1+               , cab_cvs     = cvs1+               , cab_lhs     = tidyTypes env lhs+               , cab_roles   = roles+               , cab_rhs     = tidyType  env rhs+               , cab_loc     = loc+               , cab_incomps = placeHolderIncomps }+  where+    (env1, tvs1) = tidyTyCoVarBndrs emptyTidyEnv tvs+    (env,  cvs1) = tidyTyCoVarBndrs env1         cvs+    -- See Note [Tidy axioms when we build them]++-- all of the following code is here to avoid mutual dependencies with+-- Coercion+mkBranchedCoAxiom :: Name -> TyCon -> [CoAxBranch] -> CoAxiom Branched+mkBranchedCoAxiom ax_name fam_tc branches+  = CoAxiom { co_ax_unique   = nameUnique ax_name+            , co_ax_name     = ax_name+            , co_ax_tc       = fam_tc+            , co_ax_role     = Nominal+            , co_ax_implicit = False+            , co_ax_branches = manyBranches (computeAxiomIncomps branches) }++mkUnbranchedCoAxiom :: Name -> TyCon -> CoAxBranch -> CoAxiom Unbranched+mkUnbranchedCoAxiom ax_name fam_tc branch+  = CoAxiom { co_ax_unique   = nameUnique ax_name+            , co_ax_name     = ax_name+            , co_ax_tc       = fam_tc+            , co_ax_role     = Nominal+            , co_ax_implicit = False+            , co_ax_branches = unbranched (branch { cab_incomps = [] }) }++mkSingleCoAxiom :: Role -> Name+                -> [TyVar] -> [CoVar] -> TyCon -> [Type] -> Type+                -> CoAxiom Unbranched+-- Make a single-branch CoAxiom, incluidng making the branch itself+-- Used for both type family (Nominal) and data family (Representational)+-- axioms, hence passing in the Role+mkSingleCoAxiom role ax_name tvs cvs fam_tc lhs_tys rhs_ty+  = CoAxiom { co_ax_unique   = nameUnique ax_name+            , co_ax_name     = ax_name+            , co_ax_tc       = fam_tc+            , co_ax_role     = role+            , co_ax_implicit = False+            , co_ax_branches = unbranched (branch { cab_incomps = [] }) }+  where+    branch = mkCoAxBranch tvs cvs lhs_tys rhs_ty+                          (map (const Nominal) tvs)+                          (getSrcSpan ax_name)++-- | Create a coercion constructor (axiom) suitable for the given+--   newtype 'TyCon'. The 'Name' should be that of a new coercion+--   'CoAxiom', the 'TyVar's the arguments expected by the @newtype@ and+--   the type the appropriate right hand side of the @newtype@, with+--   the free variables a subset of those 'TyVar's.+mkNewTypeCoAxiom :: Name -> TyCon -> [TyVar] -> [Role] -> Type -> CoAxiom Unbranched+mkNewTypeCoAxiom name tycon tvs roles rhs_ty+  = CoAxiom { co_ax_unique   = nameUnique name+            , co_ax_name     = name+            , co_ax_implicit = True  -- See Note [Implicit axioms] in TyCon+            , co_ax_role     = Representational+            , co_ax_tc       = tycon+            , co_ax_branches = unbranched (branch { cab_incomps = [] }) }+  where+    branch = mkCoAxBranch tvs [] (mkTyVarTys tvs) rhs_ty+                          roles (getSrcSpan name)++{-+************************************************************************+*                                                                      *+                Looking up a family instance+*                                                                      *+************************************************************************++@lookupFamInstEnv@ looks up in a @FamInstEnv@, using a one-way match.+Multiple matches are only possible in case of type families (not data+families), and then, it doesn't matter which match we choose (as the+instances are guaranteed confluent).++We return the matching family instances and the type instance at which it+matches.  For example, if we lookup 'T [Int]' and have a family instance++  data instance T [a] = ..++desugared to++  data :R42T a = ..+  coe :Co:R42T a :: T [a] ~ :R42T a++we return the matching instance '(FamInst{.., fi_tycon = :R42T}, Int)'.+-}++-- when matching a type family application, we get a FamInst,+-- and the list of types the axiom should be applied to+data FamInstMatch = FamInstMatch { fim_instance :: FamInst+                                 , fim_tys      :: [Type]+                                 , fim_cos      :: [Coercion]+                                 }+  -- See Note [Over-saturated matches]++instance Outputable FamInstMatch where+  ppr (FamInstMatch { fim_instance = inst+                    , fim_tys      = tys+                    , fim_cos      = cos })+    = text "match with" <+> parens (ppr inst) <+> ppr tys <+> ppr cos++lookupFamInstEnvByTyCon :: FamInstEnvs -> TyCon -> [FamInst]+lookupFamInstEnvByTyCon (pkg_ie, home_ie) fam_tc+  = get pkg_ie ++ get home_ie+  where+    get ie = case lookupUDFM ie fam_tc of+               Nothing          -> []+               Just (FamIE fis) -> fis++lookupFamInstEnv+    :: FamInstEnvs+    -> TyCon -> [Type]          -- What we are looking for+    -> [FamInstMatch]           -- Successful matches+-- Precondition: the tycon is saturated (or over-saturated)++lookupFamInstEnv+   = lookup_fam_inst_env match+   where+     match _ _ tpl_tys tys = tcMatchTys tpl_tys tys++lookupFamInstEnvConflicts+    :: FamInstEnvs+    -> FamInst          -- Putative new instance+    -> [FamInstMatch]   -- Conflicting matches (don't look at the fim_tys field)+-- E.g. when we are about to add+--    f : type instance F [a] = a->a+-- we do (lookupFamInstConflicts f [b])+-- to find conflicting matches+--+-- Precondition: the tycon is saturated (or over-saturated)++lookupFamInstEnvConflicts envs fam_inst@(FamInst { fi_axiom = new_axiom })+  = lookup_fam_inst_env my_unify envs fam tys+  where+    (fam, tys) = famInstSplitLHS fam_inst+        -- In example above,   fam tys' = F [b]++    my_unify (FamInst { fi_axiom = old_axiom }) tpl_tvs tpl_tys _+       = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tvs,+                  (ppr fam <+> ppr tys) $$+                  (ppr tpl_tvs <+> ppr tpl_tys) )+                -- Unification will break badly if the variables overlap+                -- They shouldn't because we allocate separate uniques for them+         if compatibleBranches (coAxiomSingleBranch old_axiom) new_branch+           then Nothing+           else Just noSubst+      -- Note [Family instance overlap conflicts]++    noSubst = panic "lookupFamInstEnvConflicts noSubst"+    new_branch = coAxiomSingleBranch new_axiom++--------------------------------------------------------------------------------+--                 Type family injectivity checking bits                      --+--------------------------------------------------------------------------------++{- Note [Verifying injectivity annotation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Injectivity means that the RHS of a type family uniquely determines the LHS (see+Note [Type inference for type families with injectivity]).  User informs about+injectivity using an injectivity annotation and it is GHC's task to verify that+that annotation is correct wrt. to type family equations. Whenever we see a new+equation of a type family we need to make sure that adding this equation to+already known equations of a type family does not violate injectivity annotation+supplied by the user (see Note [Injectivity annotation]).  Of course if the type+family has no injectivity annotation then no check is required.  But if a type+family has injectivity annotation we need to make sure that the following+conditions hold:++1. For each pair of *different* equations of a type family, one of the following+   conditions holds:++   A:  RHSs are different.++   B1: OPEN TYPE FAMILIES: If the RHSs can be unified under some substitution+       then it must be possible to unify the LHSs under the same substitution.+       Example:++          type family FunnyId a = r | r -> a+          type instance FunnyId Int = Int+          type instance FunnyId a = a++       RHSs of these two equations unify under [ a |-> Int ] substitution.+       Under this substitution LHSs are equal therefore these equations don't+       violate injectivity annotation.++   B2: CLOSED TYPE FAMILIES: If the RHSs can be unified under some+       substitution then either the LHSs unify under the same substitution or+       the LHS of the latter equation is overlapped by earlier equations.+       Example 1:++          type family SwapIntChar a = r | r -> a where+              SwapIntChar Int  = Char+              SwapIntChar Char = Int+              SwapIntChar a    = a++       Say we are checking the last two equations. RHSs unify under [ a |->+       Int ] substitution but LHSs don't. So we apply the substitution to LHS+       of last equation and check whether it is overlapped by any of previous+       equations. Since it is overlapped by the first equation we conclude+       that pair of last two equations does not violate injectivity+       annotation.++   A special case of B is when RHSs unify with an empty substitution ie. they+   are identical.++   If any of the above two conditions holds we conclude that the pair of+   equations does not violate injectivity annotation. But if we find a pair+   of equations where neither of the above holds we report that this pair+   violates injectivity annotation because for a given RHS we don't have a+   unique LHS. (Note that (B) actually implies (A).)++   Note that we only take into account these LHS patterns that were declared+   as injective.++2. If a RHS of a type family equation is a bare type variable then+   all LHS variables (including implicit kind variables) also have to be bare.+   In other words, this has to be a sole equation of that type family and it has+   to cover all possible patterns.  So for example this definition will be+   rejected:++      type family W1 a = r | r -> a+      type instance W1 [a] = a++   If it were accepted we could call `W1 [W1 Int]`, which would reduce to+   `W1 Int` and then by injectivity we could conclude that `[W1 Int] ~ Int`,+   which is bogus.++3. If a RHS of a type family equation is a type family application then the type+   family is rejected as not injective.++4. If a LHS type variable that is declared as injective is not mentioned on+   injective position in the RHS then the type family is rejected as not+   injective.  "Injective position" means either an argument to a type+   constructor or argument to a type family on injective position.++See also Note [Injective type families] in TyCon+-}+++-- | Check whether an open type family equation can be added to already existing+-- instance environment without causing conflicts with supplied injectivity+-- annotations.  Returns list of conflicting axioms (type instance+-- declarations).+lookupFamInstEnvInjectivityConflicts+    :: [Bool]         -- injectivity annotation for this type family instance+                      -- INVARIANT: list contains at least one True value+    ->  FamInstEnvs   -- all type instances seens so far+    ->  FamInst       -- new type instance that we're checking+    -> [CoAxBranch]   -- conflicting instance delcarations+lookupFamInstEnvInjectivityConflicts injList (pkg_ie, home_ie)+                             fam_inst@(FamInst { fi_axiom = new_axiom })+  -- See Note [Verifying injectivity annotation]. This function implements+  -- check (1.B1) for open type families described there.+  = lookup_inj_fam_conflicts home_ie ++ lookup_inj_fam_conflicts pkg_ie+    where+      fam        = famInstTyCon fam_inst+      new_branch = coAxiomSingleBranch new_axiom++      -- filtering function used by `lookup_inj_fam_conflicts` to check whether+      -- a pair of equations conflicts with the injectivity annotation.+      isInjConflict (FamInst { fi_axiom = old_axiom })+          | InjectivityAccepted <-+            injectiveBranches injList (coAxiomSingleBranch old_axiom) new_branch+          = False -- no conflict+          | otherwise = True++      lookup_inj_fam_conflicts ie+          | isOpenFamilyTyCon fam, Just (FamIE insts) <- lookupUDFM ie fam+          = map (coAxiomSingleBranch . fi_axiom) $+            filter isInjConflict insts+          | otherwise = []+++--------------------------------------------------------------------------------+--                    Type family overlap checking bits                       --+--------------------------------------------------------------------------------++{-+Note [Family instance overlap conflicts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+- In the case of data family instances, any overlap is fundamentally a+  conflict (as these instances imply injective type mappings).++- In the case of type family instances, overlap is admitted as long as+  the right-hand sides of the overlapping rules coincide under the+  overlap substitution.  eg+       type instance F a Int = a+       type instance F Int b = b+  These two overlap on (F Int Int) but then both RHSs are Int,+  so all is well. We require that they are syntactically equal;+  anything else would be difficult to test for at this stage.+-}++------------------------------------------------------------+-- Might be a one-way match or a unifier+type MatchFun =  FamInst                -- The FamInst template+              -> TyVarSet -> [Type]     --   fi_tvs, fi_tys of that FamInst+              -> [Type]                 -- Target to match against+              -> Maybe TCvSubst++lookup_fam_inst_env'          -- The worker, local to this module+    :: MatchFun+    -> FamInstEnv+    -> TyCon -> [Type]        -- What we are looking for+    -> [FamInstMatch]+lookup_fam_inst_env' match_fun ie fam match_tys+  | isOpenFamilyTyCon fam+  , Just (FamIE insts) <- lookupUDFM ie fam+  = find insts    -- The common case+  | otherwise = []+  where++    find [] = []+    find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, fi_cvs = tpl_cvs+                        , fi_tys = tpl_tys }) : rest)+        -- Fast check for no match, uses the "rough match" fields+      | instanceCantMatch rough_tcs mb_tcs+      = find rest++        -- Proper check+      | Just subst <- match_fun item (mkVarSet tpl_tvs) tpl_tys match_tys1+      = (FamInstMatch { fim_instance = item+                      , fim_tys      = substTyVars subst tpl_tvs `chkAppend` match_tys2+                      , fim_cos      = ASSERT( all (isJust . lookupCoVar subst) tpl_cvs )+                                       substCoVars subst tpl_cvs+                      })+        : find rest++        -- No match => try next+      | otherwise+      = find rest++      where+        (rough_tcs, match_tys1, match_tys2) = split_tys tpl_tys++      -- Precondition: the tycon is saturated (or over-saturated)++    -- Deal with over-saturation+    -- See Note [Over-saturated matches]+    split_tys tpl_tys+      | isTypeFamilyTyCon fam+      = pre_rough_split_tys++      | otherwise+      = let (match_tys1, match_tys2) = splitAtList tpl_tys match_tys+            rough_tcs = roughMatchTcs match_tys1+        in (rough_tcs, match_tys1, match_tys2)++    (pre_match_tys1, pre_match_tys2) = splitAt (tyConArity fam) match_tys+    pre_rough_split_tys+      = (roughMatchTcs pre_match_tys1, pre_match_tys1, pre_match_tys2)++lookup_fam_inst_env           -- The worker, local to this module+    :: MatchFun+    -> FamInstEnvs+    -> TyCon -> [Type]        -- What we are looking for+    -> [FamInstMatch]         -- Successful matches++-- Precondition: the tycon is saturated (or over-saturated)++lookup_fam_inst_env match_fun (pkg_ie, home_ie) fam tys+  =  lookup_fam_inst_env' match_fun home_ie fam tys+  ++ lookup_fam_inst_env' match_fun pkg_ie  fam tys++{-+Note [Over-saturated matches]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's ok to look up an over-saturated type constructor.  E.g.+     type family F a :: * -> *+     type instance F (a,b) = Either (a->b)++The type instance gives rise to a newtype TyCon (at a higher kind+which you can't do in Haskell!):+     newtype FPair a b = FP (Either (a->b))++Then looking up (F (Int,Bool) Char) will return a FamInstMatch+     (FPair, [Int,Bool,Char])+The "extra" type argument [Char] just stays on the end.++We handle data families and type families separately here:++ * For type families, all instances of a type family must have the+   same arity, so we can precompute the split between the match_tys+   and the overflow tys. This is done in pre_rough_split_tys.++ * For data family instances, though, we need to re-split for each+   instance, because the breakdown might be different for each+   instance.  Why?  Because of eta reduction; see+   Note [Eta reduction for data families].+-}++-- checks if one LHS is dominated by a list of other branches+-- in other words, if an application would match the first LHS, it is guaranteed+-- to match at least one of the others. The RHSs are ignored.+-- This algorithm is conservative:+--   True -> the LHS is definitely covered by the others+--   False -> no information+-- It is currently (Oct 2012) used only for generating errors for+-- inaccessible branches. If these errors go unreported, no harm done.+-- This is defined here to avoid a dependency from CoAxiom to Unify+isDominatedBy :: CoAxBranch -> [CoAxBranch] -> Bool+isDominatedBy branch branches+  = or $ map match branches+    where+      lhs = coAxBranchLHS branch+      match (CoAxBranch { cab_lhs = tys })+        = isJust $ tcMatchTys tys lhs++{-+************************************************************************+*                                                                      *+                Choosing an axiom application+*                                                                      *+************************************************************************++The lookupFamInstEnv function does a nice job for *open* type families,+but we also need to handle closed ones when normalising a type:+-}++reduceTyFamApp_maybe :: FamInstEnvs+                     -> Role              -- Desired role of result coercion+                     -> TyCon -> [Type]+                     -> Maybe (Coercion, Type)+-- Attempt to do a *one-step* reduction of a type-family application+--    but *not* newtypes+-- Works on type-synonym families always; data-families only if+--     the role we seek is representational+-- It does *not* normlise the type arguments first, so this may not+--     go as far as you want. If you want normalised type arguments,+--     use normaliseTcArgs first.+--+-- The TyCon can be oversaturated.+-- Works on both open and closed families+--+-- Always returns a *homogeneous* coercion -- type family reductions are always+-- homogeneous+reduceTyFamApp_maybe envs role tc tys+  | Phantom <- role+  = Nothing++  | case role of+      Representational -> isOpenFamilyTyCon     tc+      _                -> isOpenTypeFamilyTyCon tc+       -- If we seek a representational coercion+       -- (e.g. the call in topNormaliseType_maybe) then we can+       -- unwrap data families as well as type-synonym families;+       -- otherwise only type-synonym families+  , FamInstMatch { fim_instance = FamInst { fi_axiom = ax }+                 , fim_tys      = inst_tys+                 , fim_cos      = inst_cos } : _ <- lookupFamInstEnv envs tc tys+      -- NB: Allow multiple matches because of compatible overlap++  = let co = mkUnbranchedAxInstCo role ax inst_tys inst_cos+        ty = pSnd (coercionKind co)+    in Just (co, ty)++  | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe tc+  , Just (ind, inst_tys, inst_cos) <- chooseBranch ax tys+  = let co = mkAxInstCo role ax ind inst_tys inst_cos+        ty = pSnd (coercionKind co)+    in Just (co, ty)++  | Just ax           <- isBuiltInSynFamTyCon_maybe tc+  , Just (coax,ts,ty) <- sfMatchFam ax tys+  = let co = mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts)+    in Just (co, ty)++  | otherwise+  = Nothing++-- The axiom can be oversaturated. (Closed families only.)+chooseBranch :: CoAxiom Branched -> [Type]+             -> Maybe (BranchIndex, [Type], [Coercion])  -- found match, with args+chooseBranch axiom tys+  = do { let num_pats = coAxiomNumPats axiom+             (target_tys, extra_tys) = splitAt num_pats tys+             branches = coAxiomBranches axiom+       ; (ind, inst_tys, inst_cos)+           <- findBranch (fromBranches branches) target_tys+       ; return ( ind, inst_tys `chkAppend` extra_tys, inst_cos ) }++-- The axiom must *not* be oversaturated+findBranch :: [CoAxBranch]             -- branches to check+           -> [Type]                   -- target types+           -> Maybe (BranchIndex, [Type], [Coercion])+    -- coercions relate requested types to returned axiom LHS at role N+findBranch branches target_tys+  = go 0 branches+  where+    go ind (branch@(CoAxBranch { cab_tvs = tpl_tvs, cab_cvs = tpl_cvs+                               , cab_lhs = tpl_lhs+                               , cab_incomps = incomps }) : rest)+      = let in_scope = mkInScopeSet (unionVarSets $+                            map (tyCoVarsOfTypes . coAxBranchLHS) incomps)+            -- See Note [Flattening] below+            flattened_target = flattenTys in_scope target_tys+        in case tcMatchTys tpl_lhs target_tys of+        Just subst -- matching worked. now, check for apartness.+          |  apartnessCheck flattened_target branch+          -> -- matching worked & we're apart from all incompatible branches.+             -- success+             ASSERT( all (isJust . lookupCoVar subst) tpl_cvs )+             Just (ind, substTyVars subst tpl_tvs, substCoVars subst tpl_cvs)++        -- failure. keep looking+        _ -> go (ind+1) rest++    -- fail if no branches left+    go _ [] = Nothing++-- | Do an apartness check, as described in the "Closed Type Families" paper+-- (POPL '14). This should be used when determining if an equation+-- ('CoAxBranch') of a closed type family can be used to reduce a certain target+-- type family application.+apartnessCheck :: [Type]     -- ^ /flattened/ target arguments. Make sure+                             -- they're flattened! See Note [Flattening].+                             -- (NB: This "flat" is a different+                             -- "flat" than is used in TcFlatten.)+               -> CoAxBranch -- ^ the candidate equation we wish to use+                             -- Precondition: this matches the target+               -> Bool       -- ^ True <=> equation can fire+apartnessCheck flattened_target (CoAxBranch { cab_incomps = incomps })+  = all (isSurelyApart+         . tcUnifyTysFG (const BindMe) flattened_target+         . coAxBranchLHS) incomps+  where+    isSurelyApart SurelyApart = True+    isSurelyApart _           = False++{-+************************************************************************+*                                                                      *+                Looking up a family instance+*                                                                      *+************************************************************************++Note [Normalising types]+~~~~~~~~~~~~~~~~~~~~~~~~+The topNormaliseType function removes all occurrences of type families+and newtypes from the top-level structure of a type. normaliseTcApp does+the type family lookup and is fairly straightforward. normaliseType is+a little more involved.++The complication comes from the fact that a type family might be used in the+kind of a variable bound in a forall. We wish to remove this type family+application, but that means coming up with a fresh variable (with the new+kind). Thus, we need a substitution to be built up as we recur through the+type. However, an ordinary TCvSubst just won't do: when we hit a type variable+whose kind has changed during normalisation, we need both the new type+variable *and* the coercion. We could conjure up a new VarEnv with just this+property, but a usable substitution environment already exists:+LiftingContexts from the liftCoSubst family of functions, defined in Coercion.+A LiftingContext maps a type variable to a coercion and a coercion variable to+a pair of coercions. Let's ignore coercion variables for now. Because the+coercion a type variable maps to contains the destination type (via+coercionKind), we don't need to store that destination type separately. Thus,+a LiftingContext has what we need: a map from type variables to (Coercion,+Type) pairs.++We also benefit because we can piggyback on the liftCoSubstVarBndr function to+deal with binders. However, I had to modify that function to work with this+application. Thus, we now have liftCoSubstVarBndrCallback, which takes+a function used to process the kind of the binder. We don't wish+to lift the kind, but instead normalise it. So, we pass in a callback function+that processes the kind of the binder.++After that brilliant explanation of all this, I'm sure you've forgotten the+dangling reference to coercion variables. What do we do with those? Nothing at+all. The point of normalising types is to remove type family applications, but+there's no sense in removing these from coercions. We would just get back a+new coercion witnessing the equality between the same types as the original+coercion. Because coercions are irrelevant anyway, there is no point in doing+this. So, whenever we encounter a coercion, we just say that it won't change.+That's what the CoercionTy case is doing within normalise_type.++Note [Normalisation and type synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to be a bit careful about normalising in the presence of type+synonyms (Trac #13035).  Suppose S is a type synonym, and we have+   S t1 t2+If S is family-free (on its RHS) we can just normalise t1 and t2 and+reconstruct (S t1' t2').   Expanding S could not reveal any new redexes+because type families are saturated.++But if S has a type family on its RHS we expand /before/ normalising+the args t1, t2.  If we normalise t1, t2 first, we'll re-normalise them+after expansion, and that can lead to /exponential/ behavour; see Trac #13035.++Notice, though, that expanding first can in principle duplicate t1,t2,+which might contain redexes. I'm sure you could conjure up an exponential+case by that route too, but it hasn't happened in practice yet!+-}++topNormaliseType :: FamInstEnvs -> Type -> Type+topNormaliseType env ty = case topNormaliseType_maybe env ty of+                            Just (_co, ty') -> ty'+                            Nothing         -> ty++topNormaliseType_maybe :: FamInstEnvs -> Type -> Maybe (Coercion, Type)++-- ^ Get rid of *outermost* (or toplevel)+--      * type function redex+--      * data family redex+--      * newtypes+-- returning an appropriate Representational coercion.  Specifically, if+--   topNormaliseType_maybe env ty = Just (co, ty')+-- then+--   (a) co :: ty ~R ty'+--   (b) ty' is not a newtype, and is not a type-family or data-family redex+--+-- However, ty' can be something like (Maybe (F ty)), where+-- (F ty) is a redex.++topNormaliseType_maybe env ty+  = topNormaliseTypeX stepper mkTransCo ty+  where+    stepper = unwrapNewTypeStepper `composeSteppers` tyFamStepper++    tyFamStepper rec_nts tc tys  -- Try to step a type/data family+      = let (args_co, ntys) = normaliseTcArgs env Representational tc tys in+          -- NB: It's OK to use normaliseTcArgs here instead of+          -- normalise_tc_args (which takes the LiftingContext described+          -- in Note [Normalising types]) because the reduceTyFamApp below+          -- works only at top level. We'll never recur in this function+          -- after reducing the kind of a bound tyvar.++        case reduceTyFamApp_maybe env Representational tc ntys of+          Just (co, rhs) -> NS_Step rec_nts rhs (args_co `mkTransCo` co)+          _              -> NS_Done++---------------+pmTopNormaliseType_maybe :: FamInstEnvs -> Type -> Maybe (Type, [DataCon], Type)+-- ^ Get rid of *outermost* (or toplevel)+--      * type function redex+--      * data family redex+--      * newtypes+--+-- Behaves exactly like `topNormaliseType_maybe`, but instead of returning a+-- coercion, it returns useful information for issuing pattern matching+-- warnings. See Note [Type normalisation for EmptyCase] for details.+pmTopNormaliseType_maybe env typ+  = do ((ty_f,tm_f), ty) <- topNormaliseTypeX stepper comb typ+       return (eq_src_ty ty (typ : ty_f [ty]), tm_f [], ty)+  where+    -- Find the first type in the sequence of rewrites that is a data type,+    -- newtype, or a data family application (not the representation tycon!).+    -- This is the one that is equal (in source Haskell) to the initial type.+    -- If none is found in the list, then all of them are type family+    -- applications, so we simply return the last one, which is the *simplest*.+    eq_src_ty :: Type -> [Type] -> Type+    eq_src_ty ty tys = maybe ty id (find is_alg_or_data_family tys)++    is_alg_or_data_family :: Type -> Bool+    is_alg_or_data_family ty = isClosedAlgType ty || isDataFamilyAppType ty++    -- For efficiency, represent both lists as difference lists.+    -- comb performs the concatenation, for both lists.+    comb (tyf1, tmf1) (tyf2, tmf2) = (tyf1 . tyf2, tmf1 . tmf2)++    stepper = newTypeStepper `composeSteppers` tyFamStepper++    -- A 'NormaliseStepper' that unwraps newtypes, careful not to fall into+    -- a loop. If it would fall into a loop, it produces 'NS_Abort'.+    newTypeStepper :: NormaliseStepper ([Type] -> [Type],[DataCon] -> [DataCon])+    newTypeStepper rec_nts tc tys+      | Just (ty', _co) <- instNewTyCon_maybe tc tys+      = case checkRecTc rec_nts tc of+          Just rec_nts' -> let tyf = ((TyConApp tc tys):)+                               tmf = ((tyConSingleDataCon tc):)+                           in  NS_Step rec_nts' ty' (tyf, tmf)+          Nothing       -> NS_Abort+      | otherwise+      = NS_Done++    tyFamStepper :: NormaliseStepper ([Type] -> [Type], [DataCon] -> [DataCon])+    tyFamStepper rec_nts tc tys  -- Try to step a type/data family+      = let (_args_co, ntys) = normaliseTcArgs env Representational tc tys in+          -- NB: It's OK to use normaliseTcArgs here instead of+          -- normalise_tc_args (which takes the LiftingContext described+          -- in Note [Normalising types]) because the reduceTyFamApp below+          -- works only at top level. We'll never recur in this function+          -- after reducing the kind of a bound tyvar.++        case reduceTyFamApp_maybe env Representational tc ntys of+          Just (_co, rhs) -> NS_Step rec_nts rhs ((rhs:), id)+          _               -> NS_Done++{- Note [Type normalisation for EmptyCase]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+EmptyCase is an exception for pattern matching, since it is strict. This means+that it boils down to checking whether the type of the scrutinee is inhabited.+Function pmTopNormaliseType_maybe gets rid of the outermost type function/data+family redex and newtypes, in search of an algebraic type constructor, which is+easier to check for inhabitation.++It returns 3 results instead of one, because there are 2 subtle points:+1. Newtypes are isomorphic to the underlying type in core but not in the source+   language,+2. The representational data family tycon is used internally but should not be+   shown to the user++Hence, if pmTopNormaliseType_maybe env ty = Just (src_ty, dcs, core_ty), then+  (a) src_ty is the rewritten type which we can show to the user. That is, the+      type we get if we rewrite type families but not data families or+      newtypes.+  (b) dcs is the list of data constructors "skipped", every time we normalise a+      newtype to it's core representation, we keep track of the source data+      constructor.+  (c) core_ty is the rewritten type. That is,+        pmTopNormaliseType_maybe env ty = Just (src_ty, dcs, core_ty)+      implies+        topNormaliseType_maybe env ty = Just (co, core_ty)+      for some coercion co.++To see how all cases come into play, consider the following example:++  data family T a :: *+  data instance T Int = T1 | T2 Bool+  -- Which gives rise to FC:+  --   data T a+  --   data R:TInt = T1 | T2 Bool+  --   axiom ax_ti : T Int ~R R:TInt++  newtype G1 = MkG1 (T Int)+  newtype G2 = MkG2 G1++  type instance F Int  = F Char+  type instance F Char = G2++In this case pmTopNormaliseType_maybe env (F Int) results in++  Just (G2, [MkG2,MkG1], R:TInt)++Which means that in source Haskell:+  - G2 is equivalent to F Int (in contrast, G1 isn't).+  - if (x : R:TInt) then (MkG2 (MkG1 x) : F Int).+-}++---------------+normaliseTcApp :: FamInstEnvs -> Role -> TyCon -> [Type] -> (Coercion, Type)+-- See comments on normaliseType for the arguments of this function+normaliseTcApp env role tc tys+  = initNormM env role (tyCoVarsOfTypes tys) $+    normalise_tc_app tc tys++-- See Note [Normalising types] about the LiftingContext+normalise_tc_app :: TyCon -> [Type] -> NormM (Coercion, Type)+normalise_tc_app tc tys+  | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys+  , not (isFamFreeTyCon tc)  -- Expand and try again+  = -- A synonym with type families in the RHS+    -- Expand and try again+    -- See Note [Normalisation and type synonyms]+    normalise_type (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys')++  | not (isTypeFamilyTyCon tc)+  = -- A synonym with no type families in the RHS; or data type etc+    -- Just normalise the arguments and rebuild+    do { (args_co, ntys) <- normalise_tc_args tc tys+       ; return (args_co, mkTyConApp tc ntys) }++  | otherwise+  = -- A type-family application+    do { env <- getEnv+       ; role <- getRole+       ; (args_co, ntys) <- normalise_tc_args tc tys+       ; case reduceTyFamApp_maybe env role tc ntys of+           Just (first_co, ty')+             -> do { (rest_co,nty) <- normalise_type ty'+                   ; return ( args_co `mkTransCo` first_co `mkTransCo` rest_co+                            , nty ) }+           _ -> -- No unique matching family instance exists;+                -- we do not do anything+                return (args_co, mkTyConApp tc ntys) }++---------------+-- | Normalise arguments to a tycon+normaliseTcArgs :: FamInstEnvs          -- ^ env't with family instances+                -> Role                 -- ^ desired role of output coercion+                -> TyCon                -- ^ tc+                -> [Type]               -- ^ tys+                -> (Coercion, [Type])   -- ^ co :: tc tys ~ tc new_tys+normaliseTcArgs env role tc tys+  = initNormM env role (tyCoVarsOfTypes tys) $+    normalise_tc_args tc tys++normalise_tc_args :: TyCon -> [Type]             -- tc tys+                  -> NormM (Coercion, [Type])    -- (co, new_tys), where+                                                 -- co :: tc tys ~ tc new_tys+normalise_tc_args tc tys+  = do { role <- getRole+       ; (cois, ntys) <- zipWithAndUnzipM normalise_type_role+                                          tys (tyConRolesX role tc)+       ; return (mkTyConAppCo role tc cois, ntys) }+  where+    normalise_type_role ty r = withRole r $ normalise_type ty++---------------+normaliseType :: FamInstEnvs+              -> Role  -- desired role of coercion+              -> Type -> (Coercion, Type)+normaliseType env role ty+  = initNormM env role (tyCoVarsOfType ty) $ normalise_type ty++normalise_type :: Type                     -- old type+               -> NormM (Coercion, Type)   -- (coercion,new type), where+                                         -- co :: old-type ~ new_type+-- Normalise the input type, by eliminating *all* type-function redexes+-- but *not* newtypes (which are visible to the programmer)+-- Returns with Refl if nothing happens+-- Does nothing to newtypes+-- The returned coercion *must* be *homogeneous*+-- See Note [Normalising types]+-- Try to not to disturb type synonyms if possible++normalise_type ty+  = go ty+  where+    go (TyConApp tc tys) = normalise_tc_app tc tys+    go ty@(LitTy {})     = do { r <- getRole+                              ; return (mkReflCo r ty, ty) }+    go (AppTy ty1 ty2)+      = do { (co,  nty1) <- go ty1+           ; (arg, nty2) <- withRole Nominal $ go ty2+           ; return (mkAppCo co arg, mkAppTy nty1 nty2) }+    go (FunTy ty1 ty2)+      = do { (co1, nty1) <- go ty1+           ; (co2, nty2) <- go ty2+           ; r <- getRole+           ; return (mkFunCo r co1 co2, mkFunTy nty1 nty2) }+    go (ForAllTy (TvBndr tyvar vis) ty)+      = do { (lc', tv', h, ki') <- normalise_tyvar_bndr tyvar+           ; (co, nty)          <- withLC lc' $ normalise_type ty+           ; let tv2 = setTyVarKind tv' ki'+           ; return (mkForAllCo tv' h co, ForAllTy (TvBndr tv2 vis) nty) }+    go (TyVarTy tv)    = normalise_tyvar tv+    go (CastTy ty co)+      = do { (nco, nty) <- go ty+           ; lc <- getLC+           ; let co' = substRightCo lc co+           ; return (castCoercionKind nco co co', mkCastTy nty co') }+    go (CoercionTy co)+      = do { lc <- getLC+           ; r <- getRole+           ; let right_co = substRightCo lc co+           ; return ( mkProofIrrelCo r+                         (liftCoSubst Nominal lc (coercionType co))+                         co right_co+                    , mkCoercionTy right_co ) }++normalise_tyvar :: TyVar -> NormM (Coercion, Type)+normalise_tyvar tv+  = ASSERT( isTyVar tv )+    do { lc <- getLC+       ; r  <- getRole+       ; return $ case liftCoSubstTyVar lc r tv of+           Just co -> (co, pSnd $ coercionKind co)+           Nothing -> (mkReflCo r ty, ty) }+  where ty = mkTyVarTy tv++normalise_tyvar_bndr :: TyVar -> NormM (LiftingContext, TyVar, Coercion, Kind)+normalise_tyvar_bndr tv+  = do { lc1 <- getLC+       ; env <- getEnv+       ; let callback lc ki = runNormM (normalise_type ki) env lc Nominal+       ; return $ liftCoSubstVarBndrCallback callback lc1 tv }++-- | a monad for the normalisation functions, reading 'FamInstEnvs',+-- a 'LiftingContext', and a 'Role'.+newtype NormM a = NormM { runNormM ::+                            FamInstEnvs -> LiftingContext -> Role -> a }++initNormM :: FamInstEnvs -> Role+          -> TyCoVarSet   -- the in-scope variables+          -> NormM a -> a+initNormM env role vars (NormM thing_inside)+  = thing_inside env lc role+  where+    in_scope = mkInScopeSet vars+    lc       = emptyLiftingContext in_scope++getRole :: NormM Role+getRole = NormM (\ _ _ r -> r)++getLC :: NormM LiftingContext+getLC = NormM (\ _ lc _ -> lc)++getEnv :: NormM FamInstEnvs+getEnv = NormM (\ env _ _ -> env)++withRole :: Role -> NormM a -> NormM a+withRole r thing = NormM $ \ envs lc _old_r -> runNormM thing envs lc r++withLC :: LiftingContext -> NormM a -> NormM a+withLC lc thing = NormM $ \ envs _old_lc r -> runNormM thing envs lc r++instance Monad NormM where+  ma >>= fmb = NormM $ \env lc r ->+               let a = runNormM ma env lc r in+               runNormM (fmb a) env lc r++instance Functor NormM where+  fmap = liftM+instance Applicative NormM where+  pure x = NormM $ \ _ _ _ -> x+  (<*>)  = ap++{-+************************************************************************+*                                                                      *+              Flattening+*                                                                      *+************************************************************************++Note [Flattening]+~~~~~~~~~~~~~~~~~+As described in "Closed type families with overlapping equations"+http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf+we need to flatten core types before unifying them, when checking for "surely-apart"+against earlier equations of a closed type family.+Flattening means replacing all top-level uses of type functions with+fresh variables, *taking care to preserve sharing*. That is, the type+(Either (F a b) (F a b)) should flatten to (Either c c), never (Either+c d).++Here is a nice example of why it's all necessary:++  type family F a b where+    F Int Bool = Char+    F a   b    = Double+  type family G a         -- open, no instances++How do we reduce (F (G Float) (G Float))? The first equation clearly doesn't match,+while the second equation does. But, before reducing, we must make sure that the+target can never become (F Int Bool). Well, no matter what G Float becomes, it+certainly won't become *both* Int and Bool, so indeed we're safe reducing+(F (G Float) (G Float)) to Double.++This is necessary not only to get more reductions (which we might be+willing to give up on), but for substitutivity. If we have (F x x), we+can see that (F x x) can reduce to Double. So, it had better be the+case that (F blah blah) can reduce to Double, no matter what (blah)+is!  Flattening as done below ensures this.++flattenTys is defined here because of module dependencies.+-}++data FlattenEnv = FlattenEnv { fe_type_map :: TypeMap TyVar+                             , fe_subst    :: TCvSubst }++emptyFlattenEnv :: InScopeSet -> FlattenEnv+emptyFlattenEnv in_scope+  = FlattenEnv { fe_type_map = emptyTypeMap+               , fe_subst    = mkEmptyTCvSubst in_scope }++-- See Note [Flattening]+flattenTys :: InScopeSet -> [Type] -> [Type]+flattenTys in_scope tys = snd $ coreFlattenTys env tys+  where+    -- when we hit a type function, we replace it with a fresh variable+    -- but, we need to make sure that this fresh variable isn't mentioned+    -- *anywhere* in the types we're flattening, even if locally-bound in+    -- a forall. That way, we can ensure consistency both within and outside+    -- of that forall.+    all_in_scope = in_scope `extendInScopeSetSet` allTyVarsInTys tys+    env          = emptyFlattenEnv all_in_scope++coreFlattenTys :: FlattenEnv -> [Type] -> (FlattenEnv, [Type])+coreFlattenTys = go []+  where+    go rtys env []         = (env, reverse rtys)+    go rtys env (ty : tys)+      = let (env', ty') = coreFlattenTy env ty in+        go (ty' : rtys) env' tys++coreFlattenTy :: FlattenEnv -> Type -> (FlattenEnv, Type)+coreFlattenTy = go+  where+    go env ty | Just ty' <- coreView ty = go env ty'++    go env (TyVarTy tv)    = (env, substTyVar (fe_subst env) tv)+    go env (AppTy ty1 ty2) = let (env1, ty1') = go env  ty1+                                 (env2, ty2') = go env1 ty2 in+                             (env2, AppTy ty1' ty2')+    go env (TyConApp tc tys)+         -- NB: Don't just check if isFamilyTyCon: this catches *data* families,+         -- which are generative and thus can be preserved during flattening+      | not (isGenerativeTyCon tc Nominal)+      = let (env', tv) = coreFlattenTyFamApp env tc tys in+        (env', mkTyVarTy tv)++      | otherwise+      = let (env', tys') = coreFlattenTys env tys in+        (env', mkTyConApp tc tys')++    go env (FunTy ty1 ty2) = let (env1, ty1') = go env  ty1+                                 (env2, ty2') = go env1 ty2 in+                             (env2, mkFunTy ty1' ty2')++    go env (ForAllTy (TvBndr tv vis) ty)+      = let (env1, tv') = coreFlattenVarBndr env tv+            (env2, ty') = go env1 ty in+        (env2, ForAllTy (TvBndr tv' vis) ty')++    go env ty@(LitTy {}) = (env, ty)++    go env (CastTy ty co) = let (env1, ty') = go env ty+                                (env2, co') = coreFlattenCo env1 co in+                            (env2, CastTy ty' co')++    go env (CoercionTy co) = let (env', co') = coreFlattenCo env co in+                             (env', CoercionTy co')++-- when flattening, we don't care about the contents of coercions.+-- so, just return a fresh variable of the right (flattened) type+coreFlattenCo :: FlattenEnv -> Coercion -> (FlattenEnv, Coercion)+coreFlattenCo env co+  = (env2, mkCoVarCo covar)+  where+    (env1, kind') = coreFlattenTy env (coercionType co)+    fresh_name    = mkFlattenFreshCoName+    subst1        = fe_subst env1+    in_scope      = getTCvInScope subst1+    covar         = uniqAway in_scope (mkCoVar fresh_name kind')+    env2          = env1 { fe_subst = subst1 `extendTCvInScope` covar }++coreFlattenVarBndr :: FlattenEnv -> TyVar -> (FlattenEnv, TyVar)+coreFlattenVarBndr env tv+  | kind' `eqType` kind+  = ( env { fe_subst = extendTvSubst old_subst tv (mkTyVarTy tv) }+             -- override any previous binding for tv+    , tv)++  | otherwise+  = let new_tv    = uniqAway (getTCvInScope old_subst) (setTyVarKind tv kind')+        new_subst = extendTvSubstWithClone old_subst tv new_tv+    in+    (env' { fe_subst = new_subst }, new_tv)+  where+    kind          = tyVarKind tv+    (env', kind') = coreFlattenTy env kind+    old_subst     = fe_subst env++coreFlattenTyFamApp :: FlattenEnv+                    -> TyCon         -- type family tycon+                    -> [Type]        -- args+                    -> (FlattenEnv, TyVar)+coreFlattenTyFamApp env fam_tc fam_args+  = case lookupTypeMap type_map fam_ty of+      Just tv -> (env, tv)+              -- we need fresh variables here, but this is called far from+              -- any good source of uniques. So, we just use the fam_tc's unique+              -- and trust uniqAway to avoid clashes. Recall that the in_scope set+              -- contains *all* tyvars, even locally bound ones elsewhere in the+              -- overall type, so this really is fresh.+      Nothing -> let tyvar_name = mkFlattenFreshTyName fam_tc+                     tv = uniqAway (getTCvInScope subst) $+                          mkTyVar tyvar_name (typeKind fam_ty)+                     env' = env { fe_type_map = extendTypeMap type_map fam_ty tv+                                , fe_subst = extendTCvInScope subst tv }+                 in (env', tv)+  where fam_ty   = mkTyConApp fam_tc fam_args+        FlattenEnv { fe_type_map = type_map+                   , fe_subst = subst } = env++-- | Get the set of all type variables mentioned anywhere in the list+-- of types. These variables are not necessarily free.+allTyVarsInTys :: [Type] -> VarSet+allTyVarsInTys []       = emptyVarSet+allTyVarsInTys (ty:tys) = allTyVarsInTy ty `unionVarSet` allTyVarsInTys tys++-- | Get the set of all type variables mentioned anywhere in a type.+allTyVarsInTy :: Type -> VarSet+allTyVarsInTy = go+  where+    go (TyVarTy tv)      = unitVarSet tv+    go (TyConApp _ tys)  = allTyVarsInTys tys+    go (AppTy ty1 ty2)   = (go ty1) `unionVarSet` (go ty2)+    go (FunTy ty1 ty2)   = (go ty1) `unionVarSet` (go ty2)+    go (ForAllTy (TvBndr tv _) ty) = unitVarSet tv     `unionVarSet`+                                     go (tyVarKind tv) `unionVarSet`+                                     go ty+                                     -- Don't remove the tv from the set!+    go (LitTy {})        = emptyVarSet+    go (CastTy ty co)    = go ty `unionVarSet` go_co co+    go (CoercionTy co)   = go_co co++    go_co (Refl _ ty)           = go ty+    go_co (TyConAppCo _ _ args) = go_cos args+    go_co (AppCo co arg)        = go_co co `unionVarSet` go_co arg+    go_co (ForAllCo tv h co)+      = unionVarSets [unitVarSet tv, go_co co, go_co h]+    go_co (FunCo _ c1 c2)       = go_co c1 `unionVarSet` go_co c2+    go_co (CoVarCo cv)          = unitVarSet cv+    go_co (AxiomInstCo _ _ cos) = go_cos cos+    go_co (UnivCo p _ t1 t2)    = go_prov p `unionVarSet` go t1 `unionVarSet` go t2+    go_co (SymCo co)            = go_co co+    go_co (TransCo c1 c2)       = go_co c1 `unionVarSet` go_co c2+    go_co (NthCo _ co)          = go_co co+    go_co (LRCo _ co)           = go_co co+    go_co (InstCo co arg)       = go_co co `unionVarSet` go_co arg+    go_co (CoherenceCo c1 c2)   = go_co c1 `unionVarSet` go_co c2+    go_co (KindCo co)           = go_co co+    go_co (SubCo co)            = go_co co+    go_co (AxiomRuleCo _ cs)    = go_cos cs++    go_cos = foldr (unionVarSet . go_co) emptyVarSet++    go_prov UnsafeCoerceProv    = emptyVarSet+    go_prov (PhantomProv co)    = go_co co+    go_prov (ProofIrrelProv co) = go_co co+    go_prov (PluginProv _)      = emptyVarSet+    go_prov (HoleProv _)        = emptyVarSet++mkFlattenFreshTyName :: Uniquable a => a -> Name+mkFlattenFreshTyName unq+  = mkSysTvName (getUnique unq) (fsLit "flt")++mkFlattenFreshCoName :: Name+mkFlattenFreshCoName+  = mkSystemVarName (deriveUnique eqPrimTyConKey 71) (fsLit "flc")
+ types/InstEnv.hs view
@@ -0,0 +1,996 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[InstEnv]{Utilities for typechecking instance declarations}++The bits common to TcInstDcls and TcDeriv.+-}++{-# LANGUAGE CPP, DeriveDataTypeable #-}++module InstEnv (+        DFunId, InstMatch, ClsInstLookupResult,+        OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,+        ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances,+        instanceHead, instanceSig, mkLocalInstance, mkImportedInstance,+        instanceDFunId, tidyClsInstDFun, instanceRoughTcs,+        fuzzyClsInstCmp, orphNamesOfClsInst,++        InstEnvs(..), VisibleOrphanModules, InstEnv,+        emptyInstEnv, extendInstEnv, deleteFromInstEnv, identicalClsInstHead,+        extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv, instEnvElts,+        memberInstEnv, instIsVisible,+        classInstances, instanceBindFun,+        instanceCantMatch, roughMatchTcs,+        isOverlappable, isOverlapping, isIncoherent+    ) where++#include "HsVersions.h"++import TcType -- InstEnv is really part of the type checker,+              -- and depends on TcType in many ways+import CoreSyn ( IsOrphan(..), isOrphan, chooseOrphanAnchor )+import Module+import Class+import Var+import VarSet+import Name+import NameSet+import Unify+import Outputable+import ErrUtils+import BasicTypes+import UniqDFM+import Util+import Id+import Data.Data        ( Data )+import Data.Maybe       ( isJust, isNothing )++{-+************************************************************************+*                                                                      *+           ClsInst: the data type for type-class instances+*                                                                      *+************************************************************************+-}++-- | A type-class instance. Note that there is some tricky laziness at work+-- here. See Note [ClsInst laziness and the rough-match fields] for more+-- details.+data ClsInst+  = ClsInst {   -- Used for "rough matching"; see+                -- Note [ClsInst laziness and the rough-match fields]+                -- INVARIANT: is_tcs = roughMatchTcs is_tys+               is_cls_nm :: Name        -- ^ Class name+             , is_tcs  :: [Maybe Name]  -- ^ Top of type args++               -- | @is_dfun_name = idName . is_dfun@.+               --+               -- We use 'is_dfun_name' for the visibility check,+               -- 'instIsVisible', which needs to know the 'Module' which the+               -- dictionary is defined in. However, we cannot use the 'Module'+               -- attached to 'is_dfun' since doing so would mean we would+               -- potentially pull in an entire interface file unnecessarily.+               -- This was the cause of #12367.+             , is_dfun_name :: Name++                -- Used for "proper matching"; see Note [Proper-match fields]+             , is_tvs  :: [TyVar]       -- Fresh template tyvars for full match+                                        -- See Note [Template tyvars are fresh]+             , is_cls  :: Class         -- The real class+             , is_tys  :: [Type]        -- Full arg types (mentioning is_tvs)+                -- INVARIANT: is_dfun Id has type+                --      forall is_tvs. (...) => is_cls is_tys+                -- (modulo alpha conversion)++             , is_dfun :: DFunId -- See Note [Haddock assumptions]++             , is_flag :: OverlapFlag   -- See detailed comments with+                                        -- the decl of BasicTypes.OverlapFlag+             , is_orphan :: IsOrphan+    }+  deriving Data++-- | A fuzzy comparison function for class instances, intended for sorting+-- instances before displaying them to the user.+fuzzyClsInstCmp :: ClsInst -> ClsInst -> Ordering+fuzzyClsInstCmp x y =+    stableNameCmp (is_cls_nm x) (is_cls_nm y) `mappend`+    mconcat (map cmp (zip (is_tcs x) (is_tcs y)))+  where+    cmp (Nothing, Nothing) = EQ+    cmp (Nothing, Just _) = LT+    cmp (Just _, Nothing) = GT+    cmp (Just x, Just y) = stableNameCmp x y++isOverlappable, isOverlapping, isIncoherent :: ClsInst -> Bool+isOverlappable i = hasOverlappableFlag (overlapMode (is_flag i))+isOverlapping  i = hasOverlappingFlag  (overlapMode (is_flag i))+isIncoherent   i = hasIncoherentFlag   (overlapMode (is_flag i))++{-+Note [ClsInst laziness and the rough-match fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we load 'instance A.C B.T' from A.hi, but suppose that the type B.T is+otherwise unused in the program. Then it's stupid to load B.hi, the data type+declaration for B.T -- and perhaps further instance declarations!++We avoid this as follows:++* is_cls_nm, is_tcs, is_dfun_name are all Names. We can poke them to our heart's+  content.++* Proper-match fields. is_dfun, and its related fields is_tvs, is_cls, is_tys+  contain TyVars, Class, Type, Class etc, and so are all lazy thunks. When we+  poke any of these fields we'll typecheck the DFunId declaration, and hence+  pull in interfaces that it refers to. See Note [Proper-match fields].++* Rough-match fields. During instance lookup, we use the is_cls_nm :: Name and+  is_tcs :: [Maybe Name] fields to perform a "rough match", *without* poking+  inside the DFunId. The rough-match fields allow us to say "definitely does not+  match", based only on Names.++  This laziness is very important; see Trac #12367. Try hard to avoid pulling on+  the structured fields unless you really need the instance.++* Another place to watch is InstEnv.instIsVisible, which needs the module to+  which the ClsInst belongs. We can get this from is_dfun_name.++* In is_tcs,+    Nothing  means that this type arg is a type variable++    (Just n) means that this type arg is a+                TyConApp with a type constructor of n.+                This is always a real tycon, never a synonym!+                (Two different synonyms might match, but two+                different real tycons can't.)+                NB: newtypes are not transparent, though!+-}++{-+Note [Template tyvars are fresh]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The is_tvs field of a ClsInst has *completely fresh* tyvars.+That is, they are+  * distinct from any other ClsInst+  * distinct from any tyvars free in predicates that may+    be looked up in the class instance environment+Reason for freshness: we use unification when checking for overlap+etc, and that requires the tyvars to be distinct.++The invariant is checked by the ASSERT in lookupInstEnv'.++Note [Proper-match fields]+~~~~~~~~~~~~~~~~~~~~~~~~~+The is_tvs, is_cls, is_tys fields are simply cached values, pulled+out (lazily) from the dfun id. They are cached here simply so+that we don't need to decompose the DFunId each time we want+to match it.  The hope is that the rough-match fields mean+that we often never poke the proper-match fields.++However, note that:+ * is_tvs must be a superset of the free vars of is_tys++ * is_tvs, is_tys may be alpha-renamed compared to the ones in+   the dfun Id++Note [Haddock assumptions]+~~~~~~~~~~~~~~~~~~~~~~~~~~+For normal user-written instances, Haddock relies on++ * the SrcSpan of+ * the Name of+ * the is_dfun of+ * an Instance++being equal to++  * the SrcSpan of+  * the instance head type of+  * the InstDecl used to construct the Instance.+-}++instanceDFunId :: ClsInst -> DFunId+instanceDFunId = is_dfun++tidyClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst+tidyClsInstDFun tidy_dfun ispec+  = ispec { is_dfun = tidy_dfun (is_dfun ispec) }++instanceRoughTcs :: ClsInst -> [Maybe Name]+instanceRoughTcs = is_tcs+++instance NamedThing ClsInst where+   getName ispec = getName (is_dfun ispec)++instance Outputable ClsInst where+   ppr = pprInstance++pprInstance :: ClsInst -> SDoc+-- Prints the ClsInst as an instance declaration+pprInstance ispec+  = hang (pprInstanceHdr ispec)+       2 (vcat [ text "--" <+> pprDefinedAt (getName ispec)+               , ifPprDebug (ppr (is_dfun ispec)) ])++-- * pprInstanceHdr is used in VStudio to populate the ClassView tree+pprInstanceHdr :: ClsInst -> SDoc+-- Prints the ClsInst as an instance declaration+pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun })+  = text "instance" <+> ppr flag <+> pprSigmaType (idType dfun)++pprInstances :: [ClsInst] -> SDoc+pprInstances ispecs = vcat (map pprInstance ispecs)++instanceHead :: ClsInst -> ([TyVar], Class, [Type])+-- Returns the head, using the fresh tyavs from the ClsInst+instanceHead (ClsInst { is_tvs = tvs, is_tys = tys, is_dfun = dfun })+   = (tvs, cls, tys)+   where+     (_, _, cls, _) = tcSplitDFunTy (idType dfun)++-- | Collects the names of concrete types and type constructors that make+-- up the head of a class instance. For instance, given `class Foo a b`:+--+-- `instance Foo (Either (Maybe Int) a) Bool` would yield+--      [Either, Maybe, Int, Bool]+--+-- Used in the implementation of ":info" in GHCi.+--+-- The 'tcSplitSigmaTy' is because of+--      instance Foo a => Baz T where ...+-- The decl is an orphan if Baz and T are both not locally defined,+--      even if Foo *is* locally defined+orphNamesOfClsInst :: ClsInst -> NameSet+orphNamesOfClsInst (ClsInst { is_cls_nm = cls_nm, is_tys = tys })+  = orphNamesOfTypes tys `unionNameSet` unitNameSet cls_nm++instanceSig :: ClsInst -> ([TyVar], [Type], Class, [Type])+-- Decomposes the DFunId+instanceSig ispec = tcSplitDFunTy (idType (is_dfun ispec))++mkLocalInstance :: DFunId -> OverlapFlag+                -> [TyVar] -> Class -> [Type]+                -> ClsInst+-- Used for local instances, where we can safely pull on the DFunId.+-- Consider using newClsInst instead; this will also warn if+-- the instance is an orphan.+mkLocalInstance dfun oflag tvs cls tys+  = ClsInst { is_flag = oflag, is_dfun = dfun+            , is_tvs = tvs+            , is_dfun_name = dfun_name+            , is_cls = cls, is_cls_nm = cls_name+            , is_tys = tys, is_tcs = roughMatchTcs tys+            , is_orphan = orph+            }+  where+    cls_name = className cls+    dfun_name = idName dfun+    this_mod = ASSERT( isExternalName dfun_name ) nameModule dfun_name+    is_local name = nameIsLocalOrFrom this_mod name++        -- Compute orphanhood.  See Note [Orphans] in InstEnv+    (cls_tvs, fds) = classTvsFds cls+    arg_names = [filterNameSet is_local (orphNamesOfType ty) | ty <- tys]++    -- See Note [When exactly is an instance decl an orphan?]+    orph | is_local cls_name = NotOrphan (nameOccName cls_name)+         | all notOrphan mb_ns  = ASSERT( not (null mb_ns) ) head mb_ns+         | otherwise         = IsOrphan++    notOrphan NotOrphan{} = True+    notOrphan _ = False++    mb_ns :: [IsOrphan]    -- One for each fundep; a locally-defined name+                           -- that is not in the "determined" arguments+    mb_ns | null fds   = [choose_one arg_names]+          | otherwise  = map do_one fds+    do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- cls_tvs `zip` arg_names+                                            , not (tv `elem` rtvs)]++    choose_one nss = chooseOrphanAnchor (unionNameSets nss)++mkImportedInstance :: Name         -- ^ the name of the class+                   -> [Maybe Name] -- ^ the types which the class was applied to+                   -> Name         -- ^ the 'Name' of the dictionary binding+                   -> DFunId       -- ^ the 'Id' of the dictionary.+                   -> OverlapFlag  -- ^ may this instance overlap?+                   -> IsOrphan     -- ^ is this instance an orphan?+                   -> ClsInst+-- Used for imported instances, where we get the rough-match stuff+-- from the interface file+-- The bound tyvars of the dfun are guaranteed fresh, because+-- the dfun has been typechecked out of the same interface file+mkImportedInstance cls_nm mb_tcs dfun_name dfun oflag orphan+  = ClsInst { is_flag = oflag, is_dfun = dfun+            , is_tvs = tvs, is_tys = tys+            , is_dfun_name = dfun_name+            , is_cls_nm = cls_nm, is_cls = cls, is_tcs = mb_tcs+            , is_orphan = orphan }+  where+    (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)++{-+Note [When exactly is an instance decl an orphan?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  (see MkIface.instanceToIfaceInst, which implements this)+Roughly speaking, an instance is an orphan if its head (after the =>)+mentions nothing defined in this module.++Functional dependencies complicate the situation though. Consider++  module M where { class C a b | a -> b }++and suppose we are compiling module X:++  module X where+        import M+        data T = ...+        instance C Int T where ...++This instance is an orphan, because when compiling a third module Y we+might get a constraint (C Int v), and we'd want to improve v to T.  So+we must make sure X's instances are loaded, even if we do not directly+use anything from X.++More precisely, an instance is an orphan iff++  If there are no fundeps, then at least of the names in+  the instance head is locally defined.++  If there are fundeps, then for every fundep, at least one of the+  names free in a *non-determined* part of the instance head is+  defined in this module.++(Note that these conditions hold trivially if the class is locally+defined.)+++************************************************************************+*                                                                      *+                InstEnv, ClsInstEnv+*                                                                      *+************************************************************************++A @ClsInstEnv@ all the instances of that class.  The @Id@ inside a+ClsInstEnv mapping is the dfun for that instance.++If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then++        forall a b, C t1 t2 t3  can be constructed by dfun++or, to put it another way, we have++        instance (...) => C t1 t2 t3,  witnessed by dfun+-}++---------------------------------------------------+{-+Note [InstEnv determinism]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We turn InstEnvs into a list in some places that don't directly affect+the ABI. That happens when we create output for `:info`.+Unfortunately that nondeterminism is nonlocal and it's hard to tell what it+affects without following a chain of functions. It's also easy to accidentally+make that nondeterminism affect the ABI. Furthermore the envs should be+relatively small, so it should be free to use deterministic maps here.+Testing with nofib and validate detected no difference between UniqFM and+UniqDFM. See also Note [Deterministic UniqFM]+-}++type InstEnv = UniqDFM ClsInstEnv      -- Maps Class to instances for that class+  -- See Note [InstEnv determinism]++-- | 'InstEnvs' represents the combination of the global type class instance+-- environment, the local type class instance environment, and the set of+-- transitively reachable orphan modules (according to what modules have been+-- directly imported) used to test orphan instance visibility.+data InstEnvs = InstEnvs {+        ie_global  :: InstEnv,               -- External-package instances+        ie_local   :: InstEnv,               -- Home-package instances+        ie_visible :: VisibleOrphanModules   -- Set of all orphan modules transitively+                                             -- reachable from the module being compiled+                                             -- See Note [Instance lookup and orphan instances]+    }++-- | Set of visible orphan modules, according to what modules have been directly+-- imported.  This is based off of the dep_orphs field, which records+-- transitively reachable orphan modules (modules that define orphan instances).+type VisibleOrphanModules = ModuleSet++newtype ClsInstEnv+  = ClsIE [ClsInst]    -- The instances for a particular class, in any order++instance Outputable ClsInstEnv where+  ppr (ClsIE is) = pprInstances is++-- INVARIANTS:+--  * The is_tvs are distinct in each ClsInst+--      of a ClsInstEnv (so we can safely unify them)++-- Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry:+--      [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]+-- The "a" in the pattern must be one of the forall'd variables in+-- the dfun type.++emptyInstEnv :: InstEnv+emptyInstEnv = emptyUDFM++instEnvElts :: InstEnv -> [ClsInst]+instEnvElts ie = [elt | ClsIE elts <- eltsUDFM ie, elt <- elts]+  -- See Note [InstEnv determinism]++-- | Test if an instance is visible, by checking that its origin module+-- is in 'VisibleOrphanModules'.+-- See Note [Instance lookup and orphan instances]+instIsVisible :: VisibleOrphanModules -> ClsInst -> Bool+instIsVisible vis_mods ispec+  -- NB: Instances from the interactive package always are visible. We can't+  -- add interactive modules to the set since we keep creating new ones+  -- as a GHCi session progresses.+  | isInteractiveModule mod     = True+  | IsOrphan <- is_orphan ispec = mod `elemModuleSet` vis_mods+  | otherwise                   = True+  where+    mod = nameModule $ is_dfun_name ispec++classInstances :: InstEnvs -> Class -> [ClsInst]+classInstances (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods }) cls+  = get home_ie ++ get pkg_ie+  where+    get env = case lookupUDFM env cls of+                Just (ClsIE insts) -> filter (instIsVisible vis_mods) insts+                Nothing            -> []++-- | Checks for an exact match of ClsInst in the instance environment.+-- We use this when we do signature checking in TcRnDriver+memberInstEnv :: InstEnv -> ClsInst -> Bool+memberInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm } ) =+    maybe False (\(ClsIE items) -> any (identicalDFunType ins_item) items)+          (lookupUDFM inst_env cls_nm)+ where+  identicalDFunType cls1 cls2 =+    eqType (varType (is_dfun cls1)) (varType (is_dfun cls2))++extendInstEnvList :: InstEnv -> [ClsInst] -> InstEnv+extendInstEnvList inst_env ispecs = foldl extendInstEnv inst_env ispecs++extendInstEnv :: InstEnv -> ClsInst -> InstEnv+extendInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm })+  = addToUDFM_C add inst_env cls_nm (ClsIE [ins_item])+  where+    add (ClsIE cur_insts) _ = ClsIE (ins_item : cur_insts)++deleteFromInstEnv :: InstEnv -> ClsInst -> InstEnv+deleteFromInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm })+  = adjustUDFM adjust inst_env cls_nm+  where+    adjust (ClsIE items) = ClsIE (filterOut (identicalClsInstHead ins_item) items)++identicalClsInstHead :: ClsInst -> ClsInst -> Bool+-- ^ True when when the instance heads are the same+-- e.g.  both are   Eq [(a,b)]+-- Used for overriding in GHCi+-- Obviously should be insenstive to alpha-renaming+identicalClsInstHead (ClsInst { is_cls_nm = cls_nm1, is_tcs = rough1, is_tys = tys1 })+                     (ClsInst { is_cls_nm = cls_nm2, is_tcs = rough2, is_tys = tys2 })+  =  cls_nm1 == cls_nm2+  && not (instanceCantMatch rough1 rough2)  -- Fast check for no match, uses the "rough match" fields+  && isJust (tcMatchTys tys1 tys2)+  && isJust (tcMatchTys tys2 tys1)++{-+************************************************************************+*                                                                      *+        Looking up an instance+*                                                                      *+************************************************************************++@lookupInstEnv@ looks up in a @InstEnv@, using a one-way match.  Since+the env is kept ordered, the first match must be the only one.  The+thing we are looking up can have an arbitrary "flexi" part.++Note [Instance lookup and orphan instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we are compiling a module M, and we have a zillion packages+loaded, and we are looking up an instance for C (T W).  If we find a+match in module 'X' from package 'p', should be "in scope"; that is,++  is p:X in the transitive closure of modules imported from M?++The difficulty is that the "zillion packages" might include ones loaded+through earlier invocations of the GHC API, or earlier module loads in GHCi.+They might not be in the dependencies of M itself; and if not, the instances+in them should not be visible.  Trac #2182, #8427.++There are two cases:+  * If the instance is *not an orphan*, then module X defines C, T, or W.+    And in order for those types to be involved in typechecking M, it+    must be that X is in the transitive closure of M's imports.  So we+    can use the instance.++  * If the instance *is an orphan*, the above reasoning does not apply.+    So we keep track of the set of orphan modules transitively below M;+    this is the ie_visible field of InstEnvs, of type VisibleOrphanModules.++    If module p:X is in this set, then we can use the instance, otherwise+    we can't.++Note [Rules for instance lookup]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+These functions implement the carefully-written rules in the user+manual section on "overlapping instances". At risk of duplication,+here are the rules.  If the rules change, change this text and the+user manual simultaneously.  The link may be this:+http://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#instance-overlap++The willingness to be overlapped or incoherent is a property of the+instance declaration itself, controlled as follows:++ * An instance is "incoherent"+   if it has an INCOHERENT pragma, or+   if it appears in a module compiled with -XIncoherentInstances.++ * An instance is "overlappable"+   if it has an OVERLAPPABLE or OVERLAPS pragma, or+   if it appears in a module compiled with -XOverlappingInstances, or+   if the instance is incoherent.++ * An instance is "overlapping"+   if it has an OVERLAPPING or OVERLAPS pragma, or+   if it appears in a module compiled with -XOverlappingInstances, or+   if the instance is incoherent.+     compiled with -XOverlappingInstances.++Now suppose that, in some client module, we are searching for an instance+of the target constraint (C ty1 .. tyn). The search works like this.++ * Find all instances I that match the target constraint; that is, the+   target constraint is a substitution instance of I. These instance+   declarations are the candidates.++ * Find all non-candidate instances that unify with the target+   constraint. Such non-candidates instances might match when the+   target constraint is further instantiated. If all of them are+   incoherent, proceed; if not, the search fails.++ * Eliminate any candidate IX for which both of the following hold:+   * There is another candidate IY that is strictly more specific;+     that is, IY is a substitution instance of IX but not vice versa.++   * Either IX is overlappable or IY is overlapping.++ * If only one candidate remains, pick it. Otherwise if all remaining+   candidates are incoherent, pick an arbitrary candidate. Otherwise fail.++Note [Overlapping instances]   (NB: these notes are quite old)+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Overlap is permitted, but only in such a way that one can make+a unique choice when looking up.  That is, overlap is only permitted if+one template matches the other, or vice versa.  So this is ok:++  [a]  [Int]++but this is not++  (Int,a)  (b,Int)++If overlap is permitted, the list is kept most specific first, so that+the first lookup is the right choice.+++For now we just use association lists.++\subsection{Avoiding a problem with overlapping}++Consider this little program:++\begin{pseudocode}+     class C a        where c :: a+     class C a => D a where d :: a++     instance C Int where c = 17+     instance D Int where d = 13++     instance C a => C [a] where c = [c]+     instance ({- C [a], -} D a) => D [a] where d = c++     instance C [Int] where c = [37]++     main = print (d :: [Int])+\end{pseudocode}++What do you think `main' prints  (assuming we have overlapping instances, and+all that turned on)?  Well, the instance for `D' at type `[a]' is defined to+be `c' at the same type, and we've got an instance of `C' at `[Int]', so the+answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because+the `C [Int]' instance is more specific).++Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong.  That+was easy ;-)  Let's just consult hugs for good measure.  Wait - if I use old+hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it+doesn't even compile!  What's going on!?++What hugs complains about is the `D [a]' instance decl.++\begin{pseudocode}+     ERROR "mj.hs" (line 10): Cannot build superclass instance+     *** Instance            : D [a]+     *** Context supplied    : D a+     *** Required superclass : C [a]+\end{pseudocode}++You might wonder what hugs is complaining about.  It's saying that you+need to add `C [a]' to the context of the `D [a]' instance (as appears+in comments).  But there's that `C [a]' instance decl one line above+that says that I can reduce the need for a `C [a]' instance to the+need for a `C a' instance, and in this case, I already have the+necessary `C a' instance (since we have `D a' explicitly in the+context, and `C' is a superclass of `D').++Unfortunately, the above reasoning indicates a premature commitment to the+generic `C [a]' instance.  I.e., it prematurely rules out the more specific+instance `C [Int]'.  This is the mistake that ghc-4.06 makes.  The fix is to+add the context that hugs suggests (uncomment the `C [a]'), effectively+deferring the decision about which instance to use.++Now, interestingly enough, 4.04 has this same bug, but it's covered up+in this case by a little known `optimization' that was disabled in+4.06.  Ghc-4.04 silently inserts any missing superclass context into+an instance declaration.  In this case, it silently inserts the `C+[a]', and everything happens to work out.++(See `basicTypes/MkId:mkDictFunId' for the code in question.  Search for+`Mark Jones', although Mark claims no credit for the `optimization' in+question, and would rather it stopped being called the `Mark Jones+optimization' ;-)++So, what's the fix?  I think hugs has it right.  Here's why.  Let's try+something else out with ghc-4.04.  Let's add the following line:++    d' :: D a => [a]+    d' = c++Everyone raise their hand who thinks that `d :: [Int]' should give a+different answer from `d' :: [Int]'.  Well, in ghc-4.04, it does.  The+`optimization' only applies to instance decls, not to regular+bindings, giving inconsistent behavior.++Old hugs had this same bug.  Here's how we fixed it: like GHC, the+list of instances for a given class is ordered, so that more specific+instances come before more generic ones.  For example, the instance+list for C might contain:+    ..., C Int, ..., C a, ...+When we go to look for a `C Int' instance we'll get that one first.+But what if we go looking for a `C b' (`b' is unconstrained)?  We'll+pass the `C Int' instance, and keep going.  But if `b' is+unconstrained, then we don't know yet if the more specific instance+will eventually apply.  GHC keeps going, and matches on the generic `C+a'.  The fix is to, at each step, check to see if there's a reverse+match, and if so, abort the search.  This prevents hugs from+prematurely chosing a generic instance when a more specific one+exists.++--Jeff+v+BUT NOTE [Nov 2001]: we must actually *unify* not reverse-match in+this test.  Suppose the instance envt had+    ..., forall a b. C a a b, ..., forall a b c. C a b c, ...+(still most specific first)+Now suppose we are looking for (C x y Int), where x and y are unconstrained.+        C x y Int  doesn't match the template {a,b} C a a b+but neither does+        C a a b  match the template {x,y} C x y Int+But still x and y might subsequently be unified so they *do* match.++Simple story: unify, don't match.+-}++type DFunInstType = Maybe Type+        -- Just ty   => Instantiate with this type+        -- Nothing   => Instantiate with any type of this tyvar's kind+        -- See Note [DFunInstType: instantiating types]++type InstMatch = (ClsInst, [DFunInstType])++type ClsInstLookupResult+     = ( [InstMatch]     -- Successful matches+       , [ClsInst]       -- These don't match but do unify+       , [InstMatch] )   -- Unsafe overlapped instances under Safe Haskell+                         -- (see Note [Safe Haskell Overlapping Instances] in+                         -- TcSimplify).++{-+Note [DFunInstType: instantiating types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A successful match is a ClsInst, together with the types at which+        the dfun_id in the ClsInst should be instantiated+The instantiating types are (Either TyVar Type)s because the dfun+might have some tyvars that *only* appear in arguments+        dfun :: forall a b. C a b, Ord b => D [a]+When we match this against D [ty], we return the instantiating types+        [Just ty, Nothing]+where the 'Nothing' indicates that 'b' can be freely instantiated.+(The caller instantiates it to a flexi type variable, which will+ presumably later become fixed via functional dependencies.)+-}++-- |Look up an instance in the given instance environment. The given class application must match exactly+-- one instance and the match may not contain any flexi type variables.  If the lookup is unsuccessful,+-- yield 'Left errorMessage'.+lookupUniqueInstEnv :: InstEnvs+                    -> Class -> [Type]+                    -> Either MsgDoc (ClsInst, [Type])+lookupUniqueInstEnv instEnv cls tys+  = case lookupInstEnv False instEnv cls tys of+      ([(inst, inst_tys)], _, _)+             | noFlexiVar -> Right (inst, inst_tys')+             | otherwise  -> Left $ text "flexible type variable:" <+>+                                    (ppr $ mkTyConApp (classTyCon cls) tys)+             where+               inst_tys'  = [ty | Just ty <- inst_tys]+               noFlexiVar = all isJust inst_tys+      _other -> Left $ text "instance not found" <+>+                       (ppr $ mkTyConApp (classTyCon cls) tys)++lookupInstEnv' :: InstEnv          -- InstEnv to look in+               -> VisibleOrphanModules   -- But filter against this+               -> Class -> [Type]  -- What we are looking for+               -> ([InstMatch],    -- Successful matches+                   [ClsInst])     -- These don't match but do unify+-- The second component of the result pair happens when we look up+--      Foo [a]+-- in an InstEnv that has entries for+--      Foo [Int]+--      Foo [b]+-- Then which we choose would depend on the way in which 'a'+-- is instantiated.  So we report that Foo [b] is a match (mapping b->a)+-- but Foo [Int] is a unifier.  This gives the caller a better chance of+-- giving a suitable error message++lookupInstEnv' ie vis_mods cls tys+  = lookup ie+  where+    rough_tcs  = roughMatchTcs tys+    all_tvs    = all isNothing rough_tcs++    --------------+    lookup env = case lookupUDFM env cls of+                   Nothing -> ([],[])   -- No instances for this class+                   Just (ClsIE insts) -> find [] [] insts++    --------------+    find ms us [] = (ms, us)+    find ms us (item@(ClsInst { is_tcs = mb_tcs, is_tvs = tpl_tvs+                              , is_tys = tpl_tys }) : rest)+      | not (instIsVisible vis_mods item)+      = find ms us rest  -- See Note [Instance lookup and orphan instances]++        -- Fast check for no match, uses the "rough match" fields+      | instanceCantMatch rough_tcs mb_tcs+      = find ms us rest++      | Just subst <- tcMatchTys tpl_tys tys+      = find ((item, map (lookupTyVar subst) tpl_tvs) : ms) us rest++        -- Does not match, so next check whether the things unify+        -- See Note [Overlapping instances] and Note [Incoherent instances]+      | isIncoherent item+      = find ms us rest++      | otherwise+      = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tv_set,+                 (ppr cls <+> ppr tys <+> ppr all_tvs) $$+                 (ppr tpl_tvs <+> ppr tpl_tys)+                )+                -- Unification will break badly if the variables overlap+                -- They shouldn't because we allocate separate uniques for them+                -- See Note [Template tyvars are fresh]+        case tcUnifyTys instanceBindFun tpl_tys tys of+            Just _   -> find ms (item:us) rest+            Nothing  -> find ms us        rest+      where+        tpl_tv_set = mkVarSet tpl_tvs++---------------+-- This is the common way to call this function.+lookupInstEnv :: Bool              -- Check Safe Haskell overlap restrictions+              -> InstEnvs          -- External and home package inst-env+              -> Class -> [Type]   -- What we are looking for+              -> ClsInstLookupResult+-- ^ See Note [Rules for instance lookup]+-- ^ See Note [Safe Haskell Overlapping Instances] in TcSimplify+-- ^ See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify+lookupInstEnv check_overlap_safe+              (InstEnvs { ie_global = pkg_ie+                        , ie_local = home_ie+                        , ie_visible = vis_mods })+              cls+              tys+  = -- pprTrace "lookupInstEnv" (ppr cls <+> ppr tys $$ ppr home_ie) $+    (final_matches, final_unifs, unsafe_overlapped)+  where+    (home_matches, home_unifs) = lookupInstEnv' home_ie vis_mods cls tys+    (pkg_matches,  pkg_unifs)  = lookupInstEnv' pkg_ie  vis_mods cls tys+    all_matches = home_matches ++ pkg_matches+    all_unifs   = home_unifs   ++ pkg_unifs+    final_matches = foldr insert_overlapping [] all_matches+        -- Even if the unifs is non-empty (an error situation)+        -- we still prune the matches, so that the error message isn't+        -- misleading (complaining of multiple matches when some should be+        -- overlapped away)++    unsafe_overlapped+       = case final_matches of+           [match] -> check_safe match+           _       -> []++    -- If the selected match is incoherent, discard all unifiers+    final_unifs = case final_matches of+                    (m:_) | isIncoherent (fst m) -> []+                    _                            -> all_unifs++    -- NOTE [Safe Haskell isSafeOverlap]+    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    -- We restrict code compiled in 'Safe' mode from overriding code+    -- compiled in any other mode. The rationale is that code compiled+    -- in 'Safe' mode is code that is untrusted by the ghc user. So+    -- we shouldn't let that code change the behaviour of code the+    -- user didn't compile in 'Safe' mode since that's the code they+    -- trust. So 'Safe' instances can only overlap instances from the+    -- same module. A same instance origin policy for safe compiled+    -- instances.+    check_safe (inst,_)+        = case check_overlap_safe && unsafeTopInstance inst of+                -- make sure it only overlaps instances from the same module+                True -> go [] all_matches+                -- most specific is from a trusted location.+                False -> []+        where+            go bad [] = bad+            go bad (i@(x,_):unchecked) =+                if inSameMod x || isOverlappable x+                    then go bad unchecked+                    else go (i:bad) unchecked++            inSameMod b =+                let na = getName $ getName inst+                    la = isInternalName na+                    nb = getName $ getName b+                    lb = isInternalName nb+                in (la && lb) || (nameModule na == nameModule nb)++    -- We consider the most specific instance unsafe when it both:+    --   (1) Comes from a module compiled as `Safe`+    --   (2) Is an orphan instance, OR, an instance for a MPTC+    unsafeTopInstance inst = isSafeOverlap (is_flag inst) &&+        (isOrphan (is_orphan inst) || classArity (is_cls inst) > 1)++---------------+insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch]+-- ^ Add a new solution, knocking out strictly less specific ones+-- See Note [Rules for instance lookup]+insert_overlapping new_item [] = [new_item]+insert_overlapping new_item@(new_inst,_) (old_item@(old_inst,_) : old_items)+  | new_beats_old        -- New strictly overrides old+  , not old_beats_new+  , new_inst `can_override` old_inst+  = insert_overlapping new_item old_items++  | old_beats_new        -- Old strictly overrides new+  , not new_beats_old+  , old_inst `can_override` new_inst+  = old_item : old_items++  -- Discard incoherent instances; see Note [Incoherent instances]+  | isIncoherent old_inst      -- Old is incoherent; discard it+  = insert_overlapping new_item old_items+  | isIncoherent new_inst      -- New is incoherent; discard it+  = old_item : old_items++  -- Equal or incomparable, and neither is incoherent; keep both+  | otherwise+  = old_item : insert_overlapping new_item old_items+  where++    new_beats_old = new_inst `more_specific_than` old_inst+    old_beats_new = old_inst `more_specific_than` new_inst++    -- `instB` can be instantiated to match `instA`+    -- or the two are equal+    instA `more_specific_than` instB+      = isJust (tcMatchTys (is_tys instB) (is_tys instA))++    instA `can_override` instB+       = isOverlapping instA || isOverlappable instB+       -- Overlap permitted if either the more specific instance+       -- is marked as overlapping, or the more general one is+       -- marked as overlappable.+       -- Latest change described in: Trac #9242.+       -- Previous change: Trac #3877, Dec 10.++{-+Note [Incoherent instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+For some classes, the choice of a particular instance does not matter, any one+is good. E.g. consider++        class D a b where { opD :: a -> b -> String }+        instance D Int b where ...+        instance D a Int where ...++        g (x::Int) = opD x x  -- Wanted: D Int Int++For such classes this should work (without having to add an "instance D Int+Int", and using -XOverlappingInstances, which would then work). This is what+-XIncoherentInstances is for: Telling GHC "I don't care which instance you use;+if you can use one, use it."++Should this logic only work when *all* candidates have the incoherent flag, or+even when all but one have it? The right choice is the latter, which can be+justified by comparing the behaviour with how -XIncoherentInstances worked when+it was only about the unify-check (note [Overlapping instances]):++Example:+        class C a b c where foo :: (a,b,c)+        instance C [a] b Int+        instance [incoherent] [Int] b c+        instance [incoherent] C a Int c+Thanks to the incoherent flags,+        [Wanted]  C [a] b Int+works: Only instance one matches, the others just unify, but are marked+incoherent.++So I can write+        (foo :: ([a],b,Int)) :: ([Int], Int, Int).+but if that works then I really want to be able to write+        foo :: ([Int], Int, Int)+as well. Now all three instances from above match. None is more specific than+another, so none is ruled out by the normal overlapping rules. One of them is+not incoherent, but we still want this to compile. Hence the+"all-but-one-logic".++The implementation is in insert_overlapping, where we remove matching+incoherent instances as long as there are others.++++************************************************************************+*                                                                      *+        Binding decisions+*                                                                      *+************************************************************************+-}++instanceBindFun :: TyCoVar -> BindFlag+instanceBindFun tv | isOverlappableTyVar tv = Skolem+                   | otherwise              = BindMe+   -- Note [Binding when looking up instances]++{-+Note [Binding when looking up instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When looking up in the instance environment, or family-instance environment,+we are careful about multiple matches, as described above in+Note [Overlapping instances]++The key_tys can contain skolem constants, and we can guarantee that those+are never going to be instantiated to anything, so we should not involve+them in the unification test.  Example:+        class Foo a where { op :: a -> Int }+        instance Foo a => Foo [a]       -- NB overlap+        instance Foo [Int]              -- NB overlap+        data T = forall a. Foo a => MkT a+        f :: T -> Int+        f (MkT x) = op [x,x]+The op [x,x] means we need (Foo [a]).  Without the filterVarSet we'd+complain, saying that the choice of instance depended on the instantiation+of 'a'; but of course it isn't *going* to be instantiated.++We do this only for isOverlappableTyVar skolems.  For example we reject+        g :: forall a => [a] -> Int+        g x = op x+on the grounds that the correct instance depends on the instantiation of 'a'+-}
+ types/Kind.hs view
@@ -0,0 +1,192 @@+-- (c) The University of Glasgow 2006-2012++{-# LANGUAGE CPP #-}+module Kind (+        -- * Main data type+        Kind, typeKind,++        -- ** Predicates on Kinds+        isLiftedTypeKind, isUnliftedTypeKind,+        isConstraintKind,+        isTYPEApp,+        returnsTyCon, returnsConstraintKind,+        isConstraintKindCon,+        okArrowArgKind, okArrowResultKind,++        classifiesTypeWithValues,+        isStarKind, isStarKindSynonymTyCon,+        tcIsStarKind,+        isKindLevPoly+       ) where++#include "HsVersions.h"++import {-# SOURCE #-} Type    ( typeKind, coreView, tcView+                              , splitTyConApp_maybe )+import {-# SOURCE #-} DataCon ( DataCon )++import TyCoRep+import TyCon+import PrelNames++import Outputable+import Util++{-+************************************************************************+*                                                                      *+        Functions over Kinds+*                                                                      *+************************************************************************++Note [Kind Constraint and kind *]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The kind Constraint is the kind of classes and other type constraints.+The special thing about types of kind Constraint is that+ * They are displayed with double arrow:+     f :: Ord a => a -> a+ * They are implicitly instantiated at call sites; so the type inference+   engine inserts an extra argument of type (Ord a) at every call site+   to f.++However, once type inference is over, there is *no* distinction between+Constraint and *.  Indeed we can have coercions between the two. Consider+   class C a where+     op :: a -> a+For this single-method class we may generate a newtype, which in turn+generates an axiom witnessing+    C a ~ (a -> a)+so on the left we have Constraint, and on the right we have *.+See Trac #7451.++Bottom line: although '*' and 'Constraint' are distinct TyCons, with+distinct uniques, they are treated as equal at all times except+during type inference.+-}++isConstraintKind :: Kind -> Bool+isConstraintKindCon :: TyCon -> Bool++isConstraintKindCon   tc = tyConUnique tc == constraintKindTyConKey++isConstraintKind (TyConApp tc _) = isConstraintKindCon tc+isConstraintKind _               = False++isTYPEApp :: Kind -> Maybe DataCon+isTYPEApp (TyConApp tc args)+  | tc `hasKey` tYPETyConKey+  , [arg] <- args+  , Just (tc, []) <- splitTyConApp_maybe arg+  , Just dc <- isPromotedDataCon_maybe tc+  = Just dc+isTYPEApp _ = Nothing++-- | Does the given type "end" in the given tycon? For example @k -> [a] -> *@+-- ends in @*@ and @Maybe a -> [a]@ ends in @[]@.+returnsTyCon :: Unique -> Type -> Bool+returnsTyCon tc_u (ForAllTy _ ty)  = returnsTyCon tc_u ty+returnsTyCon tc_u (FunTy    _ ty)  = returnsTyCon tc_u ty+returnsTyCon tc_u (TyConApp tc' _) = tc' `hasKey` tc_u+returnsTyCon _  _                  = False++returnsConstraintKind :: Kind -> Bool+returnsConstraintKind = returnsTyCon constraintKindTyConKey++-- | Tests whether the given kind (which should look like @TYPE x@)+-- is something other than a constructor tree (that is, constructors at every node).+isKindLevPoly :: Kind -> Bool+isKindLevPoly k = ASSERT2( isStarKind k || _is_type, ppr k )+                      -- the isStarKind check is necessary b/c of Constraint+                  go k+  where+    go ty | Just ty' <- coreView ty = go ty'+    go TyVarTy{}         = True+    go AppTy{}           = True  -- it can't be a TyConApp+    go (TyConApp tc tys) = isFamilyTyCon tc || any go tys+    go ForAllTy{}        = True+    go (FunTy t1 t2)     = go t1 || go t2+    go LitTy{}           = False+    go CastTy{}          = True+    go CoercionTy{}      = True++    _is_type+      | TyConApp typ [_] <- k+      = typ `hasKey` tYPETyConKey+      | otherwise+      = False+++--------------------------------------------+--            Kinding for arrow (->)+-- Says when a kind is acceptable on lhs or rhs of an arrow+--     arg -> res+--+-- See Note [Levity polymorphism]++okArrowArgKind, okArrowResultKind :: Kind -> Bool+okArrowArgKind    = classifiesTypeWithValues+okArrowResultKind = classifiesTypeWithValues++-----------------------------------------+--              Subkinding+-- The tc variants are used during type-checking, where ConstraintKind+-- is distinct from all other kinds+-- After type-checking (in core), Constraint and liftedTypeKind are+-- indistinguishable++-- | Does this classify a type allowed to have values? Responds True to things+-- like *, #, TYPE Lifted, TYPE v, Constraint.+classifiesTypeWithValues :: Kind -> Bool+-- ^ True of any sub-kind of OpenTypeKind+classifiesTypeWithValues t | Just t' <- coreView t = classifiesTypeWithValues t'+classifiesTypeWithValues (TyConApp tc [_]) = tc `hasKey` tYPETyConKey+classifiesTypeWithValues _ = False++-- | Is this kind equivalent to *?+tcIsStarKind :: Kind -> Bool+tcIsStarKind k | Just k' <- tcView k = isStarKind k'+tcIsStarKind (TyConApp tc [TyConApp ptr_rep []])+  =  tc      `hasKey` tYPETyConKey+  && ptr_rep `hasKey` liftedRepDataConKey+tcIsStarKind _ = False++-- | Is this kind equivalent to *?+isStarKind :: Kind -> Bool+isStarKind k | Just k' <- coreView k = isStarKind k'+isStarKind (TyConApp tc [TyConApp ptr_rep []])+  =  tc      `hasKey` tYPETyConKey+  && ptr_rep `hasKey` liftedRepDataConKey+isStarKind _ = False+                              -- See Note [Kind Constraint and kind *]++-- | Is the tycon @Constraint@?+isStarKindSynonymTyCon :: TyCon -> Bool+isStarKindSynonymTyCon tc = tc `hasKey` constraintKindTyConKey+++{- Note [Levity polymorphism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Is this type legal?+   (a :: TYPE rep) -> Int+   where 'rep :: RuntimeRep'++You might think not, because no lambda can have a+runtime-rep-polymorphic binder.  So no lambda has the+above type.  BUT here's a way it can be useful (taken from+Trac #12708):++  data T rep (a :: TYPE rep)+     = MkT (a -> Int)++  x1 :: T LiftedRep Int+  x1 =  MkT LiftedRep Int  (\x::Int -> 3)++  x2 :: T IntRep Int#+  x2 = MkT IntRep Int# (\x:Int# -> 3)++Note that the lambdas are just fine!++Hence, okArrowArgKind and okArrowResultKind both just+check that the type is of the form (TYPE r) for some+representation type r.+-}
+ types/OptCoercion.hs view
@@ -0,0 +1,968 @@+-- (c) The University of Glasgow 2006++{-# LANGUAGE CPP #-}++-- The default iteration limit is a bit too low for the definitions+-- in this module.+#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}+#endif++module OptCoercion ( optCoercion, checkAxInstCo ) where++#include "HsVersions.h"++import DynFlags+import TyCoRep+import Coercion+import Type hiding( substTyVarBndr, substTy )+import TcType       ( exactTyCoVarsOfType )+import TyCon+import CoAxiom+import VarSet+import VarEnv+import Outputable+import FamInstEnv ( flattenTys )+import Pair+import ListSetOps ( getNth )+import Util+import Unify+import InstEnv+import Control.Monad   ( zipWithM )++{-+%************************************************************************+%*                                                                      *+                 Optimising coercions+%*                                                                      *+%************************************************************************++Note [Optimising coercion optimisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Looking up a coercion's role or kind is linear in the size of the+coercion. Thus, doing this repeatedly during the recursive descent+of coercion optimisation is disastrous. We must be careful to avoid+doing this if at all possible.++Because it is generally easy to know a coercion's components' roles+from the role of the outer coercion, we pass down the known role of+the input in the algorithm below. We also keep functions opt_co2+and opt_co3 separate from opt_co4, so that the former two do Phantom+checks that opt_co4 can avoid. This is a big win because Phantom coercions+rarely appear within non-phantom coercions -- only in some TyConAppCos+and some AxiomInstCos. We handle these cases specially by calling+opt_co2.++Note [Optimising InstCo]+~~~~~~~~~~~~~~~~~~~~~~~~+When we have (InstCo (ForAllCo tv h g) g2), we want to optimise.++Let's look at the typing rules.++h : k1 ~ k2+tv:k1 |- g : t1 ~ t2+-----------------------------+ForAllCo tv h g : (all tv:k1.t1) ~ (all tv:k2.t2[tv |-> tv |> sym h])++g1 : (all tv:k1.t1') ~ (all tv:k2.t2')+g2 : s1 ~ s2+--------------------+InstCo g1 g2 : t1'[tv |-> s1] ~ t2'[tv |-> s2]++We thus want some coercion proving this:++  (t1[tv |-> s1]) ~ (t2[tv |-> s2 |> sym h])++If we substitute the *type* tv for the *coercion*+(g2 `mkCoherenceRightCo` sym h) in g, we'll get this result exactly.+This is bizarre,+though, because we're substituting a type variable with a coercion. However,+this operation already exists: it's called *lifting*, and defined in Coercion.+We just need to enhance the lifting operation to be able to deal with+an ambient substitution, which is why a LiftingContext stores a TCvSubst.++-}++optCoercion :: TCvSubst -> Coercion -> NormalCo+-- ^ optCoercion applies a substitution to a coercion,+--   *and* optimises it to reduce its size+optCoercion env co+  | hasNoOptCoercion unsafeGlobalDynFlags = substCo env co+  | debugIsOn+  = let out_co = opt_co1 lc False co+        (Pair in_ty1  in_ty2,  in_role)  = coercionKindRole co+        (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co+    in+    ASSERT2( substTyUnchecked env in_ty1 `eqType` out_ty1 &&+             substTyUnchecked env in_ty2 `eqType` out_ty2 &&+             in_role == out_role+           , text "optCoercion changed types!"+             $$ hang (text "in_co:") 2 (ppr co)+             $$ hang (text "in_ty1:") 2 (ppr in_ty1)+             $$ hang (text "in_ty2:") 2 (ppr in_ty2)+             $$ hang (text "out_co:") 2 (ppr out_co)+             $$ hang (text "out_ty1:") 2 (ppr out_ty1)+             $$ hang (text "out_ty2:") 2 (ppr out_ty2)+             $$ hang (text "subst:") 2 (ppr env) )+    out_co++  | otherwise         = opt_co1 lc False co+  where+    lc = mkSubstLiftingContext env++type NormalCo    = Coercion+  -- Invariants:+  --  * The substitution has been fully applied+  --  * For trans coercions (co1 `trans` co2)+  --       co1 is not a trans, and neither co1 nor co2 is identity++type NormalNonIdCo = NormalCo  -- Extra invariant: not the identity++-- | Do we apply a @sym@ to the result?+type SymFlag = Bool++-- | Do we force the result to be representational?+type ReprFlag = Bool++-- | Optimize a coercion, making no assumptions. All coercions in+-- the lifting context are already optimized (and sym'd if nec'y)+opt_co1 :: LiftingContext+        -> SymFlag+        -> Coercion -> NormalCo+opt_co1 env sym co = opt_co2 env sym (coercionRole co) co++-- See Note [Optimising coercion optimisation]+-- | Optimize a coercion, knowing the coercion's role. No other assumptions.+opt_co2 :: LiftingContext+        -> SymFlag+        -> Role   -- ^ The role of the input coercion+        -> Coercion -> NormalCo+opt_co2 env sym Phantom co = opt_phantom env sym co+opt_co2 env sym r       co = opt_co3 env sym Nothing r co++-- See Note [Optimising coercion optimisation]+-- | Optimize a coercion, knowing the coercion's non-Phantom role.+opt_co3 :: LiftingContext -> SymFlag -> Maybe Role -> Role -> Coercion -> NormalCo+opt_co3 env sym (Just Phantom)          _ co = opt_phantom env sym co+opt_co3 env sym (Just Representational) r co = opt_co4_wrap env sym True  r co+  -- if mrole is Just Nominal, that can't be a downgrade, so we can ignore+opt_co3 env sym _                       r co = opt_co4_wrap env sym False r co++-- See Note [Optimising coercion optimisation]+-- | Optimize a non-phantom coercion.+opt_co4, opt_co4_wrap :: LiftingContext -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo++opt_co4_wrap = opt_co4+{-+opt_co4_wrap env sym rep r co+  = pprTrace "opt_co4_wrap {"+    ( vcat [ text "Sym:" <+> ppr sym+           , text "Rep:" <+> ppr rep+           , text "Role:" <+> ppr r+           , text "Co:" <+> ppr co ]) $+    ASSERT( r == coercionRole co )+    let result = opt_co4 env sym rep r co in+    pprTrace "opt_co4_wrap }" (ppr co $$ text "---" $$ ppr result) $+    result+-}++opt_co4 env _   rep r (Refl _r ty)+  = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$+                      text "Found role:" <+> ppr _r   $$+                      text "Type:" <+> ppr ty )+    liftCoSubst (chooseRole rep r) env ty++opt_co4 env sym rep r (SymCo co)  = opt_co4_wrap env (not sym) rep r co+  -- surprisingly, we don't have to do anything to the env here. This is+  -- because any "lifting" substitutions in the env are tied to ForAllCos,+  -- which treat their left and right sides differently. We don't want to+  -- exchange them.++opt_co4 env sym rep r g@(TyConAppCo _r tc cos)+  = ASSERT( r == _r )+    case (rep, r) of+      (True, Nominal) ->+        mkTyConAppCo Representational tc+                     (zipWith3 (opt_co3 env sym)+                               (map Just (tyConRolesRepresentational tc))+                               (repeat Nominal)+                               cos)+      (False, Nominal) ->+        mkTyConAppCo Nominal tc (map (opt_co4_wrap env sym False Nominal) cos)+      (_, Representational) ->+                      -- must use opt_co2 here, because some roles may be P+                      -- See Note [Optimising coercion optimisation]+        mkTyConAppCo r tc (zipWith (opt_co2 env sym)+                                   (tyConRolesRepresentational tc)  -- the current roles+                                   cos)+      (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g)++opt_co4 env sym rep r (AppCo co1 co2)+  = mkAppCo (opt_co4_wrap env sym rep r co1)+            (opt_co4_wrap env sym False Nominal co2)++opt_co4 env sym rep r (ForAllCo tv k_co co)+  = case optForAllCoBndr env sym tv k_co of+      (env', tv', k_co') -> mkForAllCo tv' k_co' $+                            opt_co4_wrap env' sym rep r co+     -- Use the "mk" functions to check for nested Refls++opt_co4 env sym rep r (FunCo _r co1 co2)+  = ASSERT( r == _r )+    if rep+    then mkFunCo Representational co1' co2'+    else mkFunCo r co1' co2'+  where+    co1' = opt_co4_wrap env sym rep r co1+    co2' = opt_co4_wrap env sym rep r co2++opt_co4 env sym rep r (CoVarCo cv)+  | Just co <- lookupCoVar (lcTCvSubst env) cv+  = opt_co4_wrap (zapLiftingContext env) sym rep r co++  | ty1 `eqType` ty2   -- See Note [Optimise CoVarCo to Refl]+  = Refl (chooseRole rep r) ty1++  | otherwise+  = ASSERT( isCoVar cv1 )+    wrapRole rep r $ wrapSym sym $+    CoVarCo cv1++  where+    Pair ty1 ty2 = coVarTypes cv1++    cv1 = case lookupInScope (lcInScopeSet env) cv of+             Just cv1 -> cv1+             Nothing  -> WARN( True, text "opt_co: not in scope:"+                                     <+> ppr cv $$ ppr env)+                         cv+          -- cv1 might have a substituted kind!+++opt_co4 env sym rep r (AxiomInstCo con ind cos)+    -- Do *not* push sym inside top-level axioms+    -- e.g. if g is a top-level axiom+    --   g a : f a ~ a+    -- then (sym (g ty)) /= g (sym ty) !!+  = ASSERT( r == coAxiomRole con )+    wrapRole rep (coAxiomRole con) $+    wrapSym sym $+                       -- some sub-cos might be P: use opt_co2+                       -- See Note [Optimising coercion optimisation]+    AxiomInstCo con ind (zipWith (opt_co2 env False)+                                 (coAxBranchRoles (coAxiomNthBranch con ind))+                                 cos)+      -- Note that the_co does *not* have sym pushed into it++opt_co4 env sym rep r (UnivCo prov _r t1 t2)+  = ASSERT( r == _r )+    opt_univ env sym prov (chooseRole rep r) t1 t2++opt_co4 env sym rep r (TransCo co1 co2)+                      -- sym (g `o` h) = sym h `o` sym g+  | sym       = opt_trans in_scope co2' co1'+  | otherwise = opt_trans in_scope co1' co2'+  where+    co1' = opt_co4_wrap env sym rep r co1+    co2' = opt_co4_wrap env sym rep r co2+    in_scope = lcInScopeSet env+++opt_co4 env sym rep r co@(NthCo {}) = opt_nth_co env sym rep r co++opt_co4 env sym rep r (LRCo lr co)+  | Just pr_co <- splitAppCo_maybe co+  = ASSERT( r == Nominal )+    opt_co4_wrap env sym rep Nominal (pick_lr lr pr_co)+  | Just pr_co <- splitAppCo_maybe co'+  = ASSERT( r == Nominal )+    if rep+    then opt_co4_wrap (zapLiftingContext env) False True Nominal (pick_lr lr pr_co)+    else pick_lr lr pr_co+  | otherwise+  = wrapRole rep Nominal $ LRCo lr co'+  where+    co' = opt_co4_wrap env sym False Nominal co++    pick_lr CLeft  (l, _) = l+    pick_lr CRight (_, r) = r++-- See Note [Optimising InstCo]+opt_co4 env sym rep r (InstCo co1 arg)+    -- forall over type...+  | Just (tv, kind_co, co_body) <- splitForAllCo_maybe co1+  = opt_co4_wrap (extendLiftingContext env tv+                    (arg' `mkCoherenceRightCo` mkSymCo kind_co))+                 sym rep r co_body++    -- See if it is a forall after optimization+    -- If so, do an inefficient one-variable substitution, then re-optimize++    -- forall over type...+  | Just (tv', kind_co', co_body') <- splitForAllCo_maybe co1'+  = opt_co4_wrap (extendLiftingContext (zapLiftingContext env) tv'+                    (arg' `mkCoherenceRightCo` mkSymCo kind_co'))+            False False r' co_body'++  | otherwise = InstCo co1' arg'+  where+    co1' = opt_co4_wrap env sym rep r co1+    r'   = chooseRole rep r+    arg' = opt_co4_wrap env sym False Nominal arg++opt_co4 env sym rep r (CoherenceCo co1 co2)+  | TransCo col1 cor1 <- co1+  = opt_co4_wrap env sym rep r (mkTransCo (mkCoherenceCo col1 co2) cor1)++  | TransCo col1' cor1' <- co1'+  = if sym then opt_trans in_scope col1'+                  (optCoercion (zapTCvSubst (lcTCvSubst env))+                               (mkCoherenceRightCo cor1' co2'))+           else opt_trans in_scope (mkCoherenceCo col1' co2') cor1'++  | otherwise+  = wrapSym sym $ mkCoherenceCo (opt_co4_wrap env False rep r co1) co2'+  where co1' = opt_co4_wrap env sym   rep   r       co1+        co2' = opt_co4_wrap env False False Nominal co2+        in_scope = lcInScopeSet env++opt_co4 env sym _rep r (KindCo co)+  = ASSERT( r == Nominal )+    let kco' = promoteCoercion co in+    case kco' of+      KindCo co' -> promoteCoercion (opt_co1 env sym co')+      _          -> opt_co4_wrap env sym False Nominal kco'+  -- This might be able to be optimized more to do the promotion+  -- and substitution/optimization at the same time++opt_co4 env sym _ r (SubCo co)+  = ASSERT( r == Representational )+    opt_co4_wrap env sym True Nominal co++-- This could perhaps be optimized more.+opt_co4 env sym rep r (AxiomRuleCo co cs)+  = ASSERT( r == coaxrRole co )+    wrapRole rep r $+    wrapSym sym $+    AxiomRuleCo co (zipWith (opt_co2 env False) (coaxrAsmpRoles co) cs)++{- Note [Optimise CoVarCo to Refl]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have (c :: t~t) we can optimise it to Refl. That increases the+chances of floating the Refl upwards; e.g. Maybe c --> Refl (Maybe t)++We do so here in optCoercion, not in mkCoVarCo; see Note [mkCoVarCo]+in Coercion.+-}++-------------+-- | Optimize a phantom coercion. The input coercion may not necessarily+-- be a phantom, but the output sure will be.+opt_phantom :: LiftingContext -> SymFlag -> Coercion -> NormalCo+opt_phantom env sym co+  = opt_univ env sym (PhantomProv (mkKindCo co)) Phantom ty1 ty2+  where+    Pair ty1 ty2 = coercionKind co++{- Note [Differing kinds]+   ~~~~~~~~~~~~~~~~~~~~~~+The two types may not have the same kind (although that would be very unusual).+But even if they have the same kind, and the same type constructor, the number+of arguments in a `CoTyConApp` can differ. Consider++  Any :: forall k. k++  Any * Int                      :: *+  Any (*->*) Maybe Int  :: *++Hence the need to compare argument lengths; see Trac #13658+ -}++opt_univ :: LiftingContext -> SymFlag -> UnivCoProvenance -> Role+         -> Type -> Type -> Coercion+opt_univ env sym (PhantomProv h) _r ty1 ty2+  | sym       = mkPhantomCo h' ty2' ty1'+  | otherwise = mkPhantomCo h' ty1' ty2'+  where+    h' = opt_co4 env sym False Nominal h+    ty1' = substTy (lcSubstLeft  env) ty1+    ty2' = substTy (lcSubstRight env) ty2++opt_univ env sym prov role oty1 oty2+  | Just (tc1, tys1) <- splitTyConApp_maybe oty1+  , Just (tc2, tys2) <- splitTyConApp_maybe oty2+  , tc1 == tc2+  , equalLength tys1 tys2 -- see Note [Differing kinds]+      -- NB: prov must not be the two interesting ones (ProofIrrel & Phantom);+      -- Phantom is already taken care of, and ProofIrrel doesn't relate tyconapps+  = let roles    = tyConRolesX role tc1+        arg_cos  = zipWith3 (mkUnivCo prov) roles tys1 tys2+        arg_cos' = zipWith (opt_co4 env sym False) roles arg_cos+    in+    mkTyConAppCo role tc1 arg_cos'++  -- can't optimize the AppTy case because we can't build the kind coercions.++  | Just (tv1, ty1) <- splitForAllTy_maybe oty1+  , Just (tv2, ty2) <- splitForAllTy_maybe oty2+      -- NB: prov isn't interesting here either+  = let k1   = tyVarKind tv1+        k2   = tyVarKind tv2+        eta  = mkUnivCo prov Nominal k1 k2+          -- eta gets opt'ed soon, but not yet.+        ty2' = substTyWith [tv2] [TyVarTy tv1 `mkCastTy` eta] ty2++        (env', tv1', eta') = optForAllCoBndr env sym tv1 eta+    in+    mkForAllCo tv1' eta' (opt_univ env' sym prov role ty1 ty2')++  | otherwise+  = let ty1 = substTyUnchecked (lcSubstLeft  env) oty1+        ty2 = substTyUnchecked (lcSubstRight env) oty2+        (a, b) | sym       = (ty2, ty1)+               | otherwise = (ty1, ty2)+    in+    mkUnivCo prov' role a b++  where+    prov' = case prov of+      UnsafeCoerceProv   -> prov+      PhantomProv kco    -> PhantomProv $ opt_co4_wrap env sym False Nominal kco+      ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco+      PluginProv _       -> prov+      HoleProv h         -> pprPanic "opt_univ fell into a hole" (ppr h)+++-------------+-- NthCo must be handled separately, because it's the one case where we can't+-- tell quickly what the component coercion's role is from the containing+-- coercion. To avoid repeated coercionRole calls as opt_co1 calls opt_co2,+-- we just look for nested NthCo's, which can happen in practice.+opt_nth_co :: LiftingContext -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo+opt_nth_co env sym rep r = go []+  where+    go ns (NthCo n co) = go (n:ns) co+      -- previous versions checked if the tycon is decomposable. This+      -- is redundant, because a non-decomposable tycon under an NthCo+      -- is entirely bogus. See docs/core-spec/core-spec.pdf.+    go ns co+      = opt_nths ns co++      -- try to resolve 1 Nth+    push_nth n (Refl r1 ty)+      | Just (tc, args) <- splitTyConApp_maybe ty+      = Just (Refl (nthRole r1 tc n) (args `getNth` n))+      | n == 0+      , Just (tv, _) <- splitForAllTy_maybe ty+      = Just (Refl Nominal (tyVarKind tv))+    push_nth n (TyConAppCo _ _ cos)+      = Just (cos `getNth` n)+    push_nth 0 (ForAllCo _ eta _)+      = Just eta+    push_nth _ _ = Nothing++      -- input coercion is *not* yet sym'd or opt'd+    opt_nths [] co = opt_co4_wrap env sym rep r co+    opt_nths (n:ns) co+      | Just co' <- push_nth n co+      = opt_nths ns co'++      -- here, the co isn't a TyConAppCo, so we opt it, hoping to get+      -- a TyConAppCo as output. We don't know the role, so we use+      -- opt_co1. This is slightly annoying, because opt_co1 will call+      -- coercionRole, but as long as we don't have a long chain of+      -- NthCo's interspersed with some other coercion former, we should+      -- be OK.+    opt_nths ns co = opt_nths' ns (opt_co1 env sym co)++      -- input coercion *is* sym'd and opt'd+    opt_nths' [] co+      = if rep && (r == Nominal)+            -- propagate the SubCo:+        then opt_co4_wrap (zapLiftingContext env) False True r co+        else co+    opt_nths' (n:ns) co+      | Just co' <- push_nth n co+      = opt_nths' ns co'+    opt_nths' ns co = wrapRole rep r (mk_nths ns co)++    mk_nths [] co = co+    mk_nths (n:ns) co = mk_nths ns (mkNthCo n co)++-------------+opt_transList :: InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]+opt_transList is = zipWith (opt_trans is)++opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo+opt_trans is co1 co2+  | isReflCo co1 = co2+  | otherwise    = opt_trans1 is co1 co2++opt_trans1 :: InScopeSet -> NormalNonIdCo -> NormalCo -> NormalCo+-- First arg is not the identity+opt_trans1 is co1 co2+  | isReflCo co2 = co1+  | otherwise    = opt_trans2 is co1 co2++opt_trans2 :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> NormalCo+-- Neither arg is the identity+opt_trans2 is (TransCo co1a co1b) co2+    -- Don't know whether the sub-coercions are the identity+  = opt_trans is co1a (opt_trans is co1b co2)++opt_trans2 is co1 co2+  | Just co <- opt_trans_rule is co1 co2+  = co++opt_trans2 is co1 (TransCo co2a co2b)+  | Just co1_2a <- opt_trans_rule is co1 co2a+  = if isReflCo co1_2a+    then co2b+    else opt_trans1 is co1_2a co2b++opt_trans2 _ co1 co2+  = mkTransCo co1 co2++------+-- Optimize coercions with a top-level use of transitivity.+opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo++-- Push transitivity through matching destructors+opt_trans_rule is in_co1@(NthCo d1 co1) in_co2@(NthCo d2 co2)+  | d1 == d2+  , co1 `compatible_co` co2+  = fireTransRule "PushNth" in_co1 in_co2 $+    mkNthCo d1 (opt_trans is co1 co2)++opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2)+  | d1 == d2+  , co1 `compatible_co` co2+  = fireTransRule "PushLR" in_co1 in_co2 $+    mkLRCo d1 (opt_trans is co1 co2)++-- Push transitivity inside instantiation+opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2)+  | ty1 `eqCoercion` ty2+  , co1 `compatible_co` co2+  = fireTransRule "TrPushInst" in_co1 in_co2 $+    mkInstCo (opt_trans is co1 co2) ty1++opt_trans_rule is in_co1@(UnivCo p1 r1 tyl1 _tyr1)+                  in_co2@(UnivCo p2 r2 _tyl2 tyr2)+  | Just prov' <- opt_trans_prov p1 p2+  = ASSERT( r1 == r2 )+    fireTransRule "UnivCo" in_co1 in_co2 $+    mkUnivCo prov' r1 tyl1 tyr2+  where+    -- if the provenances are different, opt'ing will be very confusing+    opt_trans_prov UnsafeCoerceProv      UnsafeCoerceProv      = Just UnsafeCoerceProv+    opt_trans_prov (PhantomProv kco1)    (PhantomProv kco2)+      = Just $ PhantomProv $ opt_trans is kco1 kco2+    opt_trans_prov (ProofIrrelProv kco1) (ProofIrrelProv kco2)+      = Just $ ProofIrrelProv $ opt_trans is kco1 kco2+    opt_trans_prov (PluginProv str1)     (PluginProv str2)     | str1 == str2 = Just p1+    opt_trans_prov _ _ = Nothing++-- Push transitivity down through matching top-level constructors.+opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2)+  | tc1 == tc2+  = ASSERT( r1 == r2 )+    fireTransRule "PushTyConApp" in_co1 in_co2 $+    mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2)++opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b)+  = fireTransRule "TrPushApp" in_co1 in_co2 $+    mkAppCo (opt_trans is co1a co2a)+            (opt_trans is co1b co2b)++-- Eta rules+opt_trans_rule is co1@(TyConAppCo r tc cos1) co2+  | Just cos2 <- etaTyConAppCo_maybe tc co2+  = ASSERT( length cos1 == length cos2 )+    fireTransRule "EtaCompL" co1 co2 $+    mkTyConAppCo r tc (opt_transList is cos1 cos2)++opt_trans_rule is co1 co2@(TyConAppCo r tc cos2)+  | Just cos1 <- etaTyConAppCo_maybe tc co1+  = ASSERT( length cos1 == length cos2 )+    fireTransRule "EtaCompR" co1 co2 $+    mkTyConAppCo r tc (opt_transList is cos1 cos2)++opt_trans_rule is co1@(AppCo co1a co1b) co2+  | Just (co2a,co2b) <- etaAppCo_maybe co2+  = fireTransRule "EtaAppL" co1 co2 $+    mkAppCo (opt_trans is co1a co2a)+            (opt_trans is co1b co2b)++opt_trans_rule is co1 co2@(AppCo co2a co2b)+  | Just (co1a,co1b) <- etaAppCo_maybe co1+  = fireTransRule "EtaAppR" co1 co2 $+    mkAppCo (opt_trans is co1a co2a)+            (opt_trans is co1b co2b)++-- Push transitivity inside forall+opt_trans_rule is co1 co2+  | ForAllCo tv1 eta1 r1 <- co1+  , Just (tv2,eta2,r2) <- etaForAllCo_maybe co2+  = push_trans tv1 eta1 r1 tv2 eta2 r2++  | ForAllCo tv2 eta2 r2 <- co2+  , Just (tv1,eta1,r1) <- etaForAllCo_maybe co1+  = push_trans tv1 eta1 r1 tv2 eta2 r2++  where+  push_trans tv1 eta1 r1 tv2 eta2 r2+    = fireTransRule "EtaAllTy" co1 co2 $+      mkForAllCo tv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2')+    where+      is' = is `extendInScopeSet` tv1+      r2' = substCoWithUnchecked [tv2] [TyVarTy tv1] r2++-- Push transitivity inside axioms+opt_trans_rule is co1 co2++  -- See Note [Why call checkAxInstCo during optimisation]+  -- TrPushSymAxR+  | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe+  , True <- sym+  , Just cos2 <- matchAxiom sym con ind co2+  , let newAxInst = AxiomInstCo con ind (opt_transList is (map mkSymCo cos2) cos1)+  , Nothing <- checkAxInstCo newAxInst+  = fireTransRule "TrPushSymAxR" co1 co2 $ SymCo newAxInst++  -- TrPushAxR+  | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe+  , False <- sym+  , Just cos2 <- matchAxiom sym con ind co2+  , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2)+  , Nothing <- checkAxInstCo newAxInst+  = fireTransRule "TrPushAxR" co1 co2 newAxInst++  -- TrPushSymAxL+  | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe+  , True <- sym+  , Just cos1 <- matchAxiom (not sym) con ind co1+  , let newAxInst = AxiomInstCo con ind (opt_transList is cos2 (map mkSymCo cos1))+  , Nothing <- checkAxInstCo newAxInst+  = fireTransRule "TrPushSymAxL" co1 co2 $ SymCo newAxInst++  -- TrPushAxL+  | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe+  , False <- sym+  , Just cos1 <- matchAxiom (not sym) con ind co1+  , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2)+  , Nothing <- checkAxInstCo newAxInst+  = fireTransRule "TrPushAxL" co1 co2 newAxInst++  -- TrPushAxSym/TrPushSymAx+  | Just (sym1, con1, ind1, cos1) <- co1_is_axiom_maybe+  , Just (sym2, con2, ind2, cos2) <- co2_is_axiom_maybe+  , con1 == con2+  , ind1 == ind2+  , sym1 == not sym2+  , let branch = coAxiomNthBranch con1 ind1+        qtvs = coAxBranchTyVars branch ++ coAxBranchCoVars branch+        lhs  = coAxNthLHS con1 ind1+        rhs  = coAxBranchRHS branch+        pivot_tvs = exactTyCoVarsOfType (if sym2 then rhs else lhs)+  , all (`elemVarSet` pivot_tvs) qtvs+  = fireTransRule "TrPushAxSym" co1 co2 $+    if sym2+       -- TrPushAxSym+    then liftCoSubstWith role qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs+       -- TrPushSymAx+    else liftCoSubstWith role qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs+  where+    co1_is_axiom_maybe = isAxiom_maybe co1+    co2_is_axiom_maybe = isAxiom_maybe co2+    role = coercionRole co1 -- should be the same as coercionRole co2!++opt_trans_rule is co1 co2+  | Just (lco, lh) <- isCohRight_maybe co1+  , Just (rco, rh) <- isCohLeft_maybe co2+  , (coercionType lh) `eqType` (coercionType rh)+  = opt_trans_rule is lco rco++opt_trans_rule _ co1 co2        -- Identity rule+  | (Pair ty1 _, r) <- coercionKindRole co1+  , Pair _ ty2 <- coercionKind co2+  , ty1 `eqType` ty2+  = fireTransRule "RedTypeDirRefl" co1 co2 $+    Refl r ty2++opt_trans_rule _ _ _ = Nothing++fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion+fireTransRule _rule _co1 _co2 res+  = -- pprTrace ("Trans rule fired: " ++ _rule) (vcat [ppr _co1, ppr _co2, ppr res]) $+    Just res++{-+Note [Conflict checking with AxiomInstCo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following type family and axiom:++type family Equal (a :: k) (b :: k) :: Bool+type instance where+  Equal a a = True+  Equal a b = False+--+Equal :: forall k::*. k -> k -> Bool+axEqual :: { forall k::*. forall a::k. Equal k a a ~ True+           ; forall k::*. forall a::k. forall b::k. Equal k a b ~ False }++We wish to disallow (axEqual[1] <*> <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+types/FamInstEnv.hs.++Note [Why call checkAxInstCo during optimisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is possible that otherwise-good-looking optimisations meet with disaster+in the presence of axioms with multiple equations. Consider++type family Equal (a :: *) (b :: *) :: Bool where+  Equal a a = True+  Equal a b = False+type family Id (a :: *) :: * where+  Id a = a++axEq :: { [a::*].       Equal a a ~ True+        ; [a::*, b::*]. Equal a b ~ False }+axId :: [a::*]. Id a ~ a++co1 = Equal (axId[0] Int) (axId[0] Bool)+  :: Equal (Id Int) (Id Bool) ~  Equal Int Bool+co2 = axEq[1] <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.+-}++-- | Check to make sure that an AxInstCo is internally consistent.+-- Returns the conflicting branch, if it exists+-- See Note [Conflict checking with AxiomInstCo]+checkAxInstCo :: Coercion -> Maybe CoAxBranch+-- defined here to avoid dependencies in Coercion+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism] in CoreLint+checkAxInstCo (AxiomInstCo ax ind cos)+  = let branch       = coAxiomNthBranch ax ind+        tvs          = coAxBranchTyVars branch+        cvs          = coAxBranchCoVars branch+        incomps      = coAxBranchIncomps branch+        (tys, cotys) = splitAtList tvs (map (pFst . coercionKind) cos)+        co_args      = map stripCoercionTy cotys+        subst        = zipTvSubst tvs tys `composeTCvSubst`+                       zipCvSubst cvs co_args+        target   = Type.substTys subst (coAxBranchLHS branch)+        in_scope = mkInScopeSet $+                   unionVarSets (map (tyCoVarsOfTypes . coAxBranchLHS) incomps)+        flattened_target = flattenTys in_scope target in+    check_no_conflict flattened_target incomps+  where+    check_no_conflict :: [Type] -> [CoAxBranch] -> Maybe CoAxBranch+    check_no_conflict _    [] = Nothing+    check_no_conflict flat (b@CoAxBranch { cab_lhs = lhs_incomp } : rest)+         -- See Note [Apartness] in FamInstEnv+      | SurelyApart <- tcUnifyTysFG instanceBindFun flat lhs_incomp+      = check_no_conflict flat rest+      | otherwise+      = Just b+checkAxInstCo _ = Nothing+++-----------+wrapSym :: SymFlag -> Coercion -> Coercion+wrapSym sym co | sym       = SymCo co+               | otherwise = co++-- | Conditionally set a role to be representational+wrapRole :: ReprFlag+         -> Role         -- ^ current role+         -> Coercion -> Coercion+wrapRole False _       = id+wrapRole True  current = downgradeRole Representational current++-- | If we require a representational role, return that. Otherwise,+-- return the "default" role provided.+chooseRole :: ReprFlag+           -> Role    -- ^ "default" role+           -> Role+chooseRole True _ = Representational+chooseRole _    r = r++-----------+isAxiom_maybe :: Coercion -> Maybe (Bool, CoAxiom Branched, Int, [Coercion])+isAxiom_maybe (SymCo co)+  | Just (sym, con, ind, cos) <- isAxiom_maybe co+  = Just (not sym, con, ind, cos)+isAxiom_maybe (AxiomInstCo con ind cos)+  = Just (False, con, ind, cos)+isAxiom_maybe _ = Nothing++matchAxiom :: Bool -- True = match LHS, False = match RHS+           -> CoAxiom br -> Int -> Coercion -> Maybe [Coercion]+matchAxiom sym ax@(CoAxiom { co_ax_tc = tc }) ind co+  | CoAxBranch { cab_tvs = qtvs+               , cab_cvs = []   -- can't infer these, so fail if there are any+               , cab_roles = roles+               , cab_lhs = lhs+               , cab_rhs = rhs } <- coAxiomNthBranch ax ind+  , Just subst <- liftCoMatch (mkVarSet qtvs)+                              (if sym then (mkTyConApp tc lhs) else rhs)+                              co+  , all (`isMappedByLC` subst) qtvs+  = zipWithM (liftCoSubstTyVar subst) roles qtvs++  | otherwise+  = Nothing++-------------+-- destruct a CoherenceCo+isCohLeft_maybe :: Coercion -> Maybe (Coercion, Coercion)+isCohLeft_maybe (CoherenceCo co1 co2) = Just (co1, co2)+isCohLeft_maybe _                     = Nothing++-- destruct a (sym (co1 |> co2)).+-- if isCohRight_maybe co = Just (co1, co2), then (sym co1) `mkCohRightCo` co2 = co+isCohRight_maybe :: Coercion -> Maybe (Coercion, Coercion)+isCohRight_maybe (SymCo (CoherenceCo co1 co2)) = Just (mkSymCo co1, co2)+isCohRight_maybe _                             = Nothing++-------------+compatible_co :: Coercion -> Coercion -> Bool+-- Check whether (co1 . co2) will be well-kinded+compatible_co co1 co2+  = x1 `eqType` x2+  where+    Pair _ x1 = coercionKind co1+    Pair x2 _ = coercionKind co2++-------------+{-+etaForAllCo_maybe+~~~~~~~~~~~~~~~~~+Suppose we have++  g : all a1:k1.t1  ~  all a2:k2.t2++but g is *not* a ForAllCo. We want to eta-expand it. So, we do this:++  g' = all a1:(ForAllKindCo g).(InstCo g (a1 `mkCoherenceRightCo` ForAllKindCo g))++Call the kind coercion h1 and the body coercion h2. We can see that++  h2 : t1 ~ t2[a2 |-> (a1 |> h2)]++According to the typing rule for ForAllCo, we get that++  g' : all a1:k1.t1  ~  all a1:k2.(t2[a2 |-> (a1 |> h2)][a1 |-> a1 |> sym h2])++or++  g' : all a1:k1.t1  ~  all a1:k2.(t2[a2 |-> a1])++as desired.+-}+etaForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion)+-- Try to make the coercion be of form (forall tv:kind_co. co)+etaForAllCo_maybe co+  | ForAllCo tv kind_co r <- co+  = Just (tv, kind_co, r)++  | Pair ty1 ty2  <- coercionKind co+  , Just (tv1, _) <- splitForAllTy_maybe ty1+  , isForAllTy ty2+  , let kind_co = mkNthCo 0 co+  = Just ( tv1, kind_co+         , mkInstCo co (mkNomReflCo (TyVarTy tv1) `mkCoherenceRightCo` kind_co) )++  | otherwise+  = Nothing++etaAppCo_maybe :: Coercion -> Maybe (Coercion,Coercion)+-- If possible, split a coercion+--   g :: t1a t1b ~ t2a t2b+-- into a pair of coercions (left g, right g)+etaAppCo_maybe co+  | Just (co1,co2) <- splitAppCo_maybe co+  = Just (co1,co2)+  | (Pair ty1 ty2, Nominal) <- coercionKindRole co+  , Just (_,t1) <- splitAppTy_maybe ty1+  , Just (_,t2) <- splitAppTy_maybe ty2+  , let isco1 = isCoercionTy t1+  , let isco2 = isCoercionTy t2+  , isco1 == isco2+  = Just (LRCo CLeft co, LRCo CRight co)+  | otherwise+  = Nothing++etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion]+-- If possible, split a coercion+--       g :: T s1 .. sn ~ T t1 .. tn+-- into [ Nth 0 g :: s1~t1, ..., Nth (n-1) g :: sn~tn ]+etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2)+  = ASSERT( tc == tc2 ) Just cos2++etaTyConAppCo_maybe tc co+  | mightBeUnsaturatedTyCon tc+  , (Pair ty1 ty2, r) <- coercionKindRole co+  , Just (tc1, tys1)  <- splitTyConApp_maybe ty1+  , Just (tc2, tys2)  <- splitTyConApp_maybe ty2+  , tc1 == tc2+  , isInjectiveTyCon tc r  -- See Note [NthCo and newtypes] in TyCoRep+  , let n = length tys1+  = ASSERT( tc == tc1 )+    ASSERT( n == length tys2 )+    Just (decomposeCo n co)+    -- NB: n might be <> tyConArity tc+    -- e.g.   data family T a :: * -> *+    --        g :: T a b ~ T c d++  | otherwise+  = Nothing++{-+Note [Eta for AppCo]+~~~~~~~~~~~~~~~~~~~~+Suppose we have+   g :: s1 t1 ~ s2 t2++Then we can't necessarily make+   left  g :: s1 ~ s2+   right g :: t1 ~ t2+because it's possible that+   s1 :: * -> *         t1 :: *+   s2 :: (*->*) -> *    t2 :: * -> *+and in that case (left g) does not have the same+kind on either side.++It's enough to check that+  kind t1 = kind t2+because if g is well-kinded then+  kind (s1 t2) = kind (s2 t2)+and these two imply+  kind s1 = kind s2++-}++optForAllCoBndr :: LiftingContext -> Bool+                -> TyVar -> Coercion -> (LiftingContext, TyVar, Coercion)+optForAllCoBndr env sym+  = substForAllCoBndrCallbackLC sym (opt_co4_wrap env sym False Nominal) env
+ types/TyCoRep.hs view
@@ -0,0 +1,2866 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1998+\section[TyCoRep]{Type and Coercion - friends' interface}++Note [The Type-related module hierarchy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  Class+  CoAxiom+  TyCon    imports Class, CoAxiom+  TyCoRep  imports Class, CoAxiom, TyCon+  TysPrim  imports TyCoRep ( including mkTyConTy )+  Kind     imports TysPrim ( mainly for primitive kinds )+  Type     imports Kind+  Coercion imports Type+-}++-- We expose the relevant stuff from this module via the Type module+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE CPP, DeriveDataTypeable, MultiWayIf #-}+{-# LANGUAGE ImplicitParams #-}++module TyCoRep (+        TyThing(..), tyThingCategory, pprTyThingCategory, pprShortTyThing,++        -- * Types+        Type(..),+        TyLit(..),+        KindOrType, Kind,+        PredType, ThetaType,      -- Synonyms+        ArgFlag(..),++        -- * Coercions+        Coercion(..),+        UnivCoProvenance(..), CoercionHole(..),+        CoercionN, CoercionR, CoercionP, KindCoercion,++        -- * Functions over types+        mkTyConTy, mkTyVarTy, mkTyVarTys,+        mkFunTy, mkFunTys, mkForAllTy, mkForAllTys,+        mkPiTy, mkPiTys,+        isLiftedTypeKind, isUnliftedTypeKind,+        isCoercionType, isRuntimeRepTy, isRuntimeRepVar,+        isRuntimeRepKindedTy, dropRuntimeRepArgs,+        sameVis,++        -- * Functions over binders+        TyBinder(..), TyVarBinder,+        binderVar, binderVars, binderKind, binderArgFlag,+        delBinderVar,+        isInvisibleArgFlag, isVisibleArgFlag,+        isInvisibleBinder, isVisibleBinder,++        -- * Functions over coercions+        pickLR,++        -- * Pretty-printing+        pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs,+        pprSigmaType,+        pprTheta, pprForAll, pprUserForAll,+        pprTyVar, pprTyVars,+        pprThetaArrowTy, pprClassPred,+        pprKind, pprParendKind, pprTyLit,+        TyPrec(..), maybeParen, pprTcAppCo,+        pprPrefixApp, pprArrowChain,+        pprDataCons, ppSuggestExplicitKinds,++        -- * Free variables+        tyCoVarsOfType, tyCoVarsOfTypeDSet, tyCoVarsOfTypes, tyCoVarsOfTypesDSet,+        tyCoFVsBndr, tyCoFVsOfType, tyCoVarsOfTypeList,+        tyCoFVsOfTypes, tyCoVarsOfTypesList,+        closeOverKindsDSet, closeOverKindsFV, closeOverKindsList,+        coVarsOfType, coVarsOfTypes,+        coVarsOfCo, coVarsOfCos,+        tyCoVarsOfCo, tyCoVarsOfCos,+        tyCoVarsOfCoDSet,+        tyCoFVsOfCo, tyCoFVsOfCos,+        tyCoVarsOfCoList, tyCoVarsOfProv,+        closeOverKinds,++        noFreeVarsOfType, noFreeVarsOfCo,++        -- * Substitutions+        TCvSubst(..), TvSubstEnv, CvSubstEnv,+        emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubstEnv, composeTCvSubst,+        emptyTCvSubst, mkEmptyTCvSubst, isEmptyTCvSubst,+        mkTCvSubst, mkTvSubst,+        getTvSubstEnv,+        getCvSubstEnv, getTCvInScope, getTCvSubstRangeFVs,+        isInScope, notElemTCvSubst,+        setTvSubstEnv, setCvSubstEnv, zapTCvSubst,+        extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet,+        extendTCvSubst,+        extendCvSubst, extendCvSubstWithClone,+        extendTvSubst, extendTvSubstBinder, extendTvSubstWithClone,+        extendTvSubstList, extendTvSubstAndInScope,+        unionTCvSubst, zipTyEnv, zipCoEnv, mkTyCoInScopeSet,+        zipTvSubst, zipCvSubst,+        mkTvSubstPrs,++        substTyWith, substTyWithCoVars, substTysWith, substTysWithCoVars,+        substCoWith,+        substTy, substTyAddInScope,+        substTyUnchecked, substTysUnchecked, substThetaUnchecked,+        substTyWithUnchecked,+        substCoUnchecked, substCoWithUnchecked,+        substTyWithInScope,+        substTys, substTheta,+        lookupTyVar, substTyVarBndr,+        substCo, substCos, substCoVar, substCoVars, lookupCoVar,+        substCoVarBndr, cloneTyVarBndr, cloneTyVarBndrs,+        substTyVar, substTyVars,+        substForAllCoBndr,+        substTyVarBndrCallback, substForAllCoBndrCallback,+        checkValidSubst, isValidTCvSubst,++        -- * Tidying type related things up for printing+        tidyType,      tidyTypes,+        tidyOpenType,  tidyOpenTypes,+        tidyOpenKind,+        tidyTyCoVarBndr, tidyTyCoVarBndrs, tidyFreeTyCoVars,+        tidyOpenTyCoVar, tidyOpenTyCoVars,+        tidyTyVarOcc,+        tidyTopType,+        tidyKind,+        tidyCo, tidyCos,+        tidyTyVarBinder, tidyTyVarBinders,++        -- * Sizes+        typeSize, coercionSize, provSize+    ) where++#include "HsVersions.h"++import {-# SOURCE #-} DataCon( dataConFullSig+                             , dataConUnivTyVarBinders, dataConExTyVarBinders+                             , DataCon, filterEqSpec )+import {-# SOURCE #-} Type( isPredTy, isCoercionTy, mkAppTy, mkCastTy+                          , tyCoVarsOfTypesWellScoped+                          , tyCoVarsOfTypeWellScoped+                          , coreView, typeKind )+   -- Transitively pulls in a LOT of stuff, better to break the loop++import {-# SOURCE #-} Coercion+import {-# SOURCE #-} ConLike ( ConLike(..), conLikeName )+import {-# SOURCE #-} ToIface( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndr+                             , toIfaceTyCon, toIfaceTcArgs, toIfaceCoercion )++-- friends:+import IfaceType+import Var+import VarEnv+import VarSet+import Name hiding ( varName )+import TyCon+import Class+import CoAxiom+import FV++-- others+import BasicTypes ( LeftOrRight(..), TyPrec(..), maybeParen, pickLR )+import PrelNames+import Outputable+import DynFlags+import FastString+import Pair+import UniqSupply+import Util+import UniqFM+import UniqSet++-- libraries+import qualified Data.Data as Data hiding ( TyCon )+import Data.List+import Data.IORef ( IORef )   -- for CoercionHole++{-+%************************************************************************+%*                                                                      *+                        TyThing+%*                                                                      *+%************************************************************************++Despite the fact that DataCon has to be imported via a hi-boot route,+this module seems the right place for TyThing, because it's needed for+funTyCon and all the types in TysPrim.++It is also SOURCE-imported into Name.hs+++Note [ATyCon for classes]+~~~~~~~~~~~~~~~~~~~~~~~~~+Both classes and type constructors are represented in the type environment+as ATyCon.  You can tell the difference, and get to the class, with+   isClassTyCon :: TyCon -> Bool+   tyConClass_maybe :: TyCon -> Maybe Class+The Class and its associated TyCon have the same Name.+-}++-- | A global typecheckable-thing, essentially anything that has a name.+-- Not to be confused with a 'TcTyThing', which is also a typecheckable+-- thing but in the *local* context.  See 'TcEnv' for how to retrieve+-- a 'TyThing' given a 'Name'.+data TyThing+  = AnId     Id+  | AConLike ConLike+  | ATyCon   TyCon       -- TyCons and classes; see Note [ATyCon for classes]+  | ACoAxiom (CoAxiom Branched)++instance Outputable TyThing where+  ppr = pprShortTyThing++instance NamedThing TyThing where       -- Can't put this with the type+  getName (AnId id)     = getName id    -- decl, because the DataCon instance+  getName (ATyCon tc)   = getName tc    -- isn't visible there+  getName (ACoAxiom cc) = getName cc+  getName (AConLike cl) = conLikeName cl++pprShortTyThing :: TyThing -> SDoc+-- c.f. PprTyThing.pprTyThing, which prints all the details+pprShortTyThing thing+  = pprTyThingCategory thing <+> quotes (ppr (getName thing))++pprTyThingCategory :: TyThing -> SDoc+pprTyThingCategory = text . capitalise . tyThingCategory++tyThingCategory :: TyThing -> String+tyThingCategory (ATyCon tc)+  | isClassTyCon tc = "class"+  | otherwise       = "type constructor"+tyThingCategory (ACoAxiom _) = "coercion axiom"+tyThingCategory (AnId   _)   = "identifier"+tyThingCategory (AConLike (RealDataCon _)) = "data constructor"+tyThingCategory (AConLike (PatSynCon _))  = "pattern synonym"+++{- **********************************************************************+*                                                                       *+                        Type+*                                                                       *+********************************************************************** -}++-- | The key representation of types within the compiler++type KindOrType = Type -- See Note [Arguments to type constructors]++-- | The key type representing kinds in the compiler.+type Kind = Type++-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism] in coreSyn/CoreLint.hs+data Type+  -- See Note [Non-trivial definitional equality]+  = TyVarTy Var -- ^ Vanilla type or kind variable (*never* a coercion variable)++  | AppTy+        Type+        Type            -- ^ Type application to something other than a 'TyCon'. Parameters:+                        --+                        --  1) Function: must /not/ be a 'TyConApp',+                        --     must be another 'AppTy', or 'TyVarTy'+                        --+                        --  2) Argument type++  | TyConApp+        TyCon+        [KindOrType]    -- ^ Application of a 'TyCon', including newtypes /and/ synonyms.+                        -- Invariant: saturated applications of 'FunTyCon' must+                        -- use 'FunTy' and saturated synonyms must use their own+                        -- constructors. However, /unsaturated/ 'FunTyCon's+                        -- do appear as 'TyConApp's.+                        -- Parameters:+                        --+                        -- 1) Type constructor being applied to.+                        --+                        -- 2) Type arguments. Might not have enough type arguments+                        --    here to saturate the constructor.+                        --    Even type synonyms are not necessarily saturated;+                        --    for example unsaturated type synonyms+                        --    can appear as the right hand side of a type synonym.++  | ForAllTy+        {-# UNPACK #-} !TyVarBinder+        Type            -- ^ A Π type.++  | FunTy Type Type     -- ^ t1 -> t2   Very common, so an important special case++  | LitTy TyLit     -- ^ Type literals are similar to type constructors.++  | CastTy+        Type+        KindCoercion  -- ^ A kind cast. The coercion is always nominal.+                      -- INVARIANT: The cast is never refl.+                      -- INVARIANT: The cast is "pushed down" as far as it+                      -- can go. See Note [Pushing down casts]++  | CoercionTy+        Coercion    -- ^ Injection of a Coercion into a type+                    -- This should only ever be used in the RHS of an AppTy,+                    -- in the list of a TyConApp, when applying a promoted+                    -- GADT data constructor++  deriving Data.Data+++-- NOTE:  Other parts of the code assume that type literals do not contain+-- types or type variables.+data TyLit+  = NumTyLit Integer+  | StrTyLit FastString+  deriving (Eq, Ord, Data.Data)++{- Note [Arguments to type constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Because of kind polymorphism, in addition to type application we now+have kind instantiation. We reuse the same notations to do so.++For example:++  Just (* -> *) Maybe+  Right * Nat Zero++are represented by:++  TyConApp (PromotedDataCon Just) [* -> *, Maybe]+  TyConApp (PromotedDataCon Right) [*, Nat, (PromotedDataCon Zero)]++Important note: Nat is used as a *kind* and not as a type. This can be+confusing, since type-level Nat and kind-level Nat are identical. We+use the kind of (PromotedDataCon Right) to know if its arguments are+kinds or types.++This kind instantiation only happens in TyConApp currently.++Note [Pushing down casts]+~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have (a :: k1 -> *), (b :: k1), and (co :: * ~ q).+The type (a b |> co) is `eqType` to ((a |> co') b), where+co' = (->) <k1> co. Thus, to make this visible to functions+that inspect types, we always push down coercions, preferring+the second form. Note that this also applies to TyConApps!++Note [Non-trivial definitional equality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Is Int |> <*> the same as Int? YES! In order to reduce headaches,+we decide that any reflexive casts in types are just ignored. More+generally, the `eqType` function, which defines Core's type equality+relation, ignores casts and coercion arguments, as long as the+two types have the same kind. This allows us to be a little sloppier+in keeping track of coercions, which is a good thing. It also means+that eqType does not depend on eqCoercion, which is also a good thing.++Why is this sensible? That is, why is something different than α-equivalence+appropriate for the implementation of eqType?++Anything smaller than ~ and homogeneous is an appropriate definition for+equality. The type safety of FC depends only on ~. Let's say η : τ ~ σ. Any+expression of type τ can be transmuted to one of type σ at any point by+casting. The same is true of types of type τ. So in some sense, τ and σ are+interchangeable.++But let's be more precise. If we examine the typing rules of FC (say, those in+http://www.cis.upenn.edu/~eir/papers/2015/equalities/equalities-extended.pdf)+there are several places where the same metavariable is used in two different+premises to a rule. (For example, see Ty_App.) There is an implicit equality+check here. What definition of equality should we use? By convention, we use+α-equivalence. Take any rule with one (or more) of these implicit equality+checks. Then there is an admissible rule that uses ~ instead of the implicit+check, adding in casts as appropriate.++The only problem here is that ~ is heterogeneous. To make the kinds work out+in the admissible rule that uses ~, it is necessary to homogenize the+coercions. That is, if we have η : (τ : κ1) ~ (σ : κ2), then we don't use η;+we use η |> kind η, which is homogeneous.++The effect of this all is that eqType, the implementation of the implicit+equality check, can use any homogeneous relation that is smaller than ~, as+those rules must also be admissible.++What would go wrong if we insisted on the casts matching? See the beginning of+Section 8 in the unpublished paper above. Theoretically, nothing at all goes+wrong. But in practical terms, getting the coercions right proved to be+nightmarish. And types would explode: during kind-checking, we often produce+reflexive kind coercions. When we try to cast by these, mkCastTy just discards+them. But if we used an eqType that distinguished between Int and Int |> <*>,+then we couldn't discard -- the output of kind-checking would be enormous,+and we would need enormous casts with lots of CoherenceCo's to straighten+them out.++Would anything go wrong if eqType respected type families? No, not at all. But+that makes eqType rather hard to implement.++Thus, the guideline for eqType is that it should be the largest+easy-to-implement relation that is still smaller than ~ and homogeneous. The+precise choice of relation is somewhat incidental, as long as the smart+constructors and destructors in Type respect whatever relation is chosen.++Another helpful principle with eqType is this:++ ** If (t1 eqType t2) then I can replace t1 by t2 anywhere. **++This principle also tells us that eqType must relate only types with the+same kinds.+-}++{- **********************************************************************+*                                                                       *+                  TyBinder and ArgFlag+*                                                                       *+********************************************************************** -}++-- | A 'TyBinder' represents an argument to a function. TyBinders can be dependent+-- ('Named') or nondependent ('Anon'). They may also be visible or not.+-- See Note [TyBinders]+data TyBinder+  = Named TyVarBinder   -- A type-lambda binder+  | Anon Type           -- A term-lambda binder+                        -- Visibility is determined by the type (Constraint vs. *)+  deriving Data.Data++-- | Remove the binder's variable from the set, if the binder has+-- a variable.+delBinderVar :: VarSet -> TyVarBinder -> VarSet+delBinderVar vars (TvBndr tv _) = vars `delVarSet` tv++-- | Does this binder bind an invisible argument?+isInvisibleBinder :: TyBinder -> Bool+isInvisibleBinder (Named (TvBndr _ vis)) = isInvisibleArgFlag vis+isInvisibleBinder (Anon ty)              = isPredTy ty++-- | Does this binder bind a visible argument?+isVisibleBinder :: TyBinder -> Bool+isVisibleBinder = not . isInvisibleBinder+++{- Note [TyBinders]+~~~~~~~~~~~~~~~~~~~+A ForAllTy contains a TyVarBinder.  But a type can be decomposed+to a telescope consisting of a [TyBinder]++A TyBinder represents the type of binders -- that is, the type of an+argument to a Pi-type. GHC Core currently supports two different+Pi-types:++ * A non-dependent function type,+   written with ->, e.g. ty1 -> ty2+   represented as FunTy ty1 ty2. These are+   lifted to Coercions with the corresponding FunCo.++ * A dependent compile-time-only polytype,+   written with forall, e.g.  forall (a:*). ty+   represented as ForAllTy (TvBndr a v) ty++Both Pi-types classify terms/types that take an argument. In other+words, if `x` is either a function or a polytype, `x arg` makes sense+(for an appropriate `arg`).+++Note [TyBinders and ArgFlags]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A ForAllTy contains a TyVarBinder.  Each TyVarBinder is equipped+with a ArgFlag, which says whether or not arguments for this+binder should be visible (explicit) in source Haskell.++-----------------------------------------------------------------------+                                            Occurrences look like this+ TyBinder          GHC displays type as     in Haskell souce code+-----------------------------------------------------------------------+In the type of a term+ Anon:             f :: type -> type         Arg required:     f x+ Named Inferred:   f :: forall {a}. type     Arg not allowed:  f+ Named Specified:  f :: forall a. type       Arg optional:     f  or  f @Int+ Named Required:         Illegal: See Note [No Required TyBinder in terms]++In the kind of a type+ Anon:             T :: kind -> kind         Required:            T *+ Named Inferred:   T :: forall {k}. kind     Arg not allowed:     T+ Named Specified:  T :: forall k. kind       Arg not allowed[1]:  T+ Named Required:   T :: forall k -> kind     Required:            T *+------------------------------------------------------------------------++[1] In types, in the Specified case, it would make sense to allow+    optional kind applications, thus (T @*), but we have not+    yet implemented that++---- Examples of where the different visiblities come from -----++In term declarations:++* Inferred.  Function defn, with no signature:  f1 x = x+  We infer f1 :: forall {a}. a -> a, with 'a' Inferred+  It's Inferred because it doesn't appear in any+  user-written signature for f1++* Specified.  Function defn, with signature (implicit forall):+     f2 :: a -> a; f2 x = x+  So f2 gets the type f2 :: forall a. a->a, with 'a' Specified+  even though 'a' is not bound in the source code by an explicit forall++* Specified.  Function defn, with signature (explicit forall):+     f3 :: forall a. a -> a; f3 x = x+  So f3 gets the type f3 :: forall a. a->a, with 'a' Specified++* Inferred/Specified.  Function signature with inferred kind polymorphism.+     f4 :: a b -> Int+  So 'f4' gets the type f4 :: forall {k} (a:k->*) (b:k). a b -> Int+  Here 'k' is Inferred (it's not mentioned in the type),+  but 'a' and 'b' are Specified.++* Specified.  Function signature with explicit kind polymorphism+     f5 :: a (b :: k) -> Int+  This time 'k' is Specified, because it is mentioned explicitly,+  so we get f5 :: forall (k:*) (a:k->*) (b:k). a b -> Int++* Similarly pattern synonyms:+  Inferred - from inferred types (e.g. no pattern type signature)+           - or from inferred kind polymorphism++In type declarations:++* Inferred (k)+     data T1 a b = MkT1 (a b)+  Here T1's kind is  T1 :: forall {k:*}. (k->*) -> k -> *+  The kind variable 'k' is Inferred, since it is not mentioned++  Note that 'a' and 'b' correspond to /Anon/ TyBinders in T1's kind,+  and Anon binders don't have a visibility flag. (Or you could think+  of Anon having an implicit Required flag.)++* Specified (k)+     data T2 (a::k->*) b = MkT (a b)+  Here T's kind is  T :: forall (k:*). (k->*) -> k -> *+  The kind variable 'k' is Specified, since it is mentioned in+  the signature.++* Required (k)+     data T k (a::k->*) b = MkT (a b)+  Here T's kind is  T :: forall k:* -> (k->*) -> k -> *+  The kind is Required, since it bound in a positional way in T's declaration+  Every use of T must be explicitly applied to a kind++* Inferred (k1), Specified (k)+     data T a b (c :: k) = MkT (a b) (Proxy c)+  Here T's kind is  T :: forall {k1:*} (k:*). (k1->*) -> k1 -> k -> *+  So 'k' is Specified, because it appears explicitly,+  but 'k1' is Inferred, because it does not++---- Printing -----++ We print forall types with enough syntax to tell you their visiblity+ flag.  But this is not source Haskell, and these types may not all+ be parsable.++ Specified: a list of Specified binders is written between `forall` and `.`:+               const :: forall a b. a -> b -> a++ Inferred:  with -fprint-explicit-foralls, Inferred binders are written+            in braces:+               f :: forall {k} (a:k). S k a -> Int+            Otherwise, they are printed like Specified binders.++ Required: binders are put between `forall` and `->`:+              T :: forall k -> *++---- Other points -----++* In classic Haskell, all named binders (that is, the type variables in+  a polymorphic function type f :: forall a. a -> a) have been Inferred.++* Inferred variables correspond to "generalized" variables from the+  Visible Type Applications paper (ESOP'16).++Note [No Required TyBinder in terms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don't allow Required foralls for term variables, including pattern+synonyms and data constructors.  Why?  Because then an application+would need a /compulsory/ type argument (possibly without an "@"?),+thus (f Int); and we don't have concrete syntax for that.++We could change this decision, but Required, Named TyBinders are rare+anyway.  (Most are Anons.)+-}+++{- **********************************************************************+*                                                                       *+                        PredType+*                                                                       *+********************************************************************** -}+++-- | A type of the form @p@ of kind @Constraint@ represents a value whose type is+-- the Haskell predicate @p@, where a predicate is what occurs before+-- the @=>@ in a Haskell type.+--+-- We use 'PredType' as documentation to mark those types that we guarantee to have+-- this kind.+--+-- It can be expanded into its representation, but:+--+-- * The type checker must treat it as opaque+--+-- * The rest of the compiler treats it as transparent+--+-- Consider these examples:+--+-- > f :: (Eq a) => a -> Int+-- > g :: (?x :: Int -> Int) => a -> Int+-- > h :: (r\l) => {r} => {l::Int | r}+--+-- Here the @Eq a@ and @?x :: Int -> Int@ and @r\l@ are all called \"predicates\"+type PredType = Type++-- | A collection of 'PredType's+type ThetaType = [PredType]++{-+(We don't support TREX records yet, but the setup is designed+to expand to allow them.)++A Haskell qualified type, such as that for f,g,h above, is+represented using+        * a FunTy for the double arrow+        * with a type of kind Constraint as the function argument++The predicate really does turn into a real extra argument to the+function.  If the argument has type (p :: Constraint) then the predicate p is+represented by evidence of type p.+++%************************************************************************+%*                                                                      *+            Simple constructors+%*                                                                      *+%************************************************************************++These functions are here so that they can be used by TysPrim,+which in turn is imported by Type+-}++-- named with "Only" to prevent naive use of mkTyVarTy+mkTyVarTy  :: TyVar   -> Type+mkTyVarTy v = ASSERT2( isTyVar v, ppr v <+> dcolon <+> ppr (tyVarKind v) )+                  TyVarTy v++mkTyVarTys :: [TyVar] -> [Type]+mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy++infixr 3 `mkFunTy`      -- Associates to the right+-- | Make an arrow type+mkFunTy :: Type -> Type -> Type+mkFunTy arg res = FunTy arg res++-- | Make nested arrow types+mkFunTys :: [Type] -> Type -> Type+mkFunTys tys ty = foldr mkFunTy ty tys++mkForAllTy :: TyVar -> ArgFlag -> Type -> Type+mkForAllTy tv vis ty = ForAllTy (TvBndr tv vis) ty++-- | Wraps foralls over the type using the provided 'TyVar's from left to right+mkForAllTys :: [TyVarBinder] -> Type -> Type+mkForAllTys tyvars ty = foldr ForAllTy ty tyvars++mkPiTy :: TyBinder -> Type -> Type+mkPiTy (Anon ty1) ty2 = FunTy ty1 ty2+mkPiTy (Named tvb) ty = ForAllTy tvb ty++mkPiTys :: [TyBinder] -> Type -> Type+mkPiTys tbs ty = foldr mkPiTy ty tbs++-- | Does this type classify a core (unlifted) Coercion?+-- At either role nominal or representational+--    (t1 ~# t2) or (t1 ~R# t2)+isCoercionType :: Type -> Bool+isCoercionType (TyConApp tc tys)+  | (tc `hasKey` eqPrimTyConKey) || (tc `hasKey` eqReprPrimTyConKey)+  , length tys == 4+  = True+isCoercionType _ = False+++-- | Create the plain type constructor type which has been applied to no type arguments at all.+mkTyConTy :: TyCon -> Type+mkTyConTy tycon = TyConApp tycon []++{-+Some basic functions, put here to break loops eg with the pretty printer+-}++is_TYPE :: (   Type    -- the single argument to TYPE; not a synonym+            -> Bool )  -- what to return+        -> Kind -> Bool+is_TYPE f ki | Just ki' <- coreView ki = is_TYPE f ki'+is_TYPE f (TyConApp tc [arg])+  | tc `hasKey` tYPETyConKey+  = go arg+    where+      go ty | Just ty' <- coreView ty = go ty'+      go ty = f ty+is_TYPE _ _ = False++-- | This version considers Constraint to be distinct from *. Returns True+-- if the argument is equivalent to Type and False otherwise.+isLiftedTypeKind :: Kind -> Bool+isLiftedTypeKind = is_TYPE is_lifted+  where+    is_lifted (TyConApp lifted_rep []) = lifted_rep `hasKey` liftedRepDataConKey+    is_lifted _                        = False++-- | Returns True if the kind classifies unlifted types and False otherwise.+-- Note that this returns False for levity-polymorphic kinds, which may+-- be specialized to a kind that classifies unlifted types.+isUnliftedTypeKind :: Kind -> Bool+isUnliftedTypeKind = is_TYPE is_unlifted+  where+    is_unlifted (TyConApp rr _args) = not (rr `hasKey` liftedRepDataConKey)+    is_unlifted _                   = False++-- | Is this the type 'RuntimeRep'?+isRuntimeRepTy :: Type -> Bool+isRuntimeRepTy ty | Just ty' <- coreView ty = isRuntimeRepTy ty'+isRuntimeRepTy (TyConApp tc []) = tc `hasKey` runtimeRepTyConKey+isRuntimeRepTy _ = False++-- | Is this a type of kind RuntimeRep? (e.g. LiftedRep)+isRuntimeRepKindedTy :: Type -> Bool+isRuntimeRepKindedTy = isRuntimeRepTy . typeKind++-- | Is a tyvar of type 'RuntimeRep'?+isRuntimeRepVar :: TyVar -> Bool+isRuntimeRepVar = isRuntimeRepTy . tyVarKind++-- | Drops prefix of RuntimeRep constructors in 'TyConApp's. Useful for e.g.+-- dropping 'LiftedRep arguments of unboxed tuple TyCon applications:+--+--   dropRuntimeRepArgs [ 'LiftedRep, 'IntRep+--                      , String, Int# ] == [String, Int#]+--+dropRuntimeRepArgs :: [Type] -> [Type]+dropRuntimeRepArgs = dropWhile isRuntimeRepKindedTy++{-+%************************************************************************+%*                                                                      *+            Coercions+%*                                                                      *+%************************************************************************+-}++-- | A 'Coercion' is concrete evidence of the equality/convertibility+-- of two types.++-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism] in coreSyn/CoreLint.hs+data Coercion+  -- Each constructor has a "role signature", indicating the way roles are+  -- propagated through coercions.+  --    -  P, N, and R stand for coercions of the given role+  --    -  e stands for a coercion of a specific unknown role+  --           (think "role polymorphism")+  --    -  "e" stands for an explicit role parameter indicating role e.+  --    -   _ stands for a parameter that is not a Role or Coercion.++  -- These ones mirror the shape of types+  = -- Refl :: "e" -> _ -> e+    Refl Role Type  -- See Note [Refl invariant]+          -- Invariant: applications of (Refl T) to a bunch of identity coercions+          --            always show up as Refl.+          -- For example  (Refl T) (Refl a) (Refl b) shows up as (Refl (T a b)).++          -- Applications of (Refl T) to some coercions, at least one of+          -- which is NOT the identity, show up as TyConAppCo.+          -- (They may not be fully saturated however.)+          -- ConAppCo coercions (like all coercions other than Refl)+          -- are NEVER the identity.++          -- Use (Refl Representational _), not (SubCo (Refl Nominal _))++  -- These ones simply lift the correspondingly-named+  -- Type constructors into Coercions++  -- TyConAppCo :: "e" -> _ -> ?? -> e+  -- See Note [TyConAppCo roles]+  | TyConAppCo Role TyCon [Coercion]    -- lift TyConApp+               -- The TyCon is never a synonym;+               -- we expand synonyms eagerly+               -- But it can be a type function++  | AppCo Coercion CoercionN             -- lift AppTy+          -- AppCo :: e -> N -> e++  -- See Note [Forall coercions]+  | ForAllCo TyVar KindCoercion Coercion+         -- ForAllCo :: _ -> N -> e -> e++  | FunCo Role Coercion Coercion         -- lift FunTy+         -- FunCo :: "e" -> e -> e -> e++  -- These are special+  | CoVarCo CoVar      -- :: _ -> (N or R)+                       -- result role depends on the tycon of the variable's type++    -- AxiomInstCo :: e -> _ -> [N] -> e+  | AxiomInstCo (CoAxiom Branched) BranchIndex [Coercion]+     -- See also [CoAxiom index]+     -- The coercion arguments always *precisely* saturate+     -- arity of (that branch of) the CoAxiom. If there are+     -- any left over, we use AppCo.+     -- See [Coercion axioms applied to coercions]++  | UnivCo UnivCoProvenance Role Type Type+      -- :: _ -> "e" -> _ -> _ -> e++  | SymCo Coercion             -- :: e -> e+  | TransCo Coercion Coercion  -- :: e -> e -> e++    -- The number coercions should match exactly the expectations+    -- of the CoAxiomRule (i.e., the rule is fully saturated).+  | AxiomRuleCo CoAxiomRule [Coercion]++  | NthCo  Int         Coercion     -- Zero-indexed; decomposes (T t0 ... tn)+    -- :: _ -> e -> ?? (inverse of TyConAppCo, see Note [TyConAppCo roles])+    -- Using NthCo on a ForAllCo gives an N coercion always+    -- See Note [NthCo and newtypes]++  | LRCo   LeftOrRight CoercionN     -- Decomposes (t_left t_right)+    -- :: _ -> N -> N+  | InstCo Coercion CoercionN+    -- :: e -> N -> e+    -- See Note [InstCo roles]++  -- Coherence applies a coercion to the left-hand type of another coercion+  -- See Note [Coherence]+  | CoherenceCo Coercion KindCoercion+     -- :: e -> N -> e++  -- Extract a kind coercion from a (heterogeneous) type coercion+  -- NB: all kind coercions are Nominal+  | KindCo Coercion+     -- :: e -> N++  | SubCo CoercionN                  -- Turns a ~N into a ~R+    -- :: N -> R++  deriving Data.Data++type CoercionN = Coercion       -- always nominal+type CoercionR = Coercion       -- always representational+type CoercionP = Coercion       -- always phantom+type KindCoercion = CoercionN   -- always nominal++{-+Note [Refl invariant]+~~~~~~~~~~~~~~~~~~~~~+Invariant 1:++Coercions have the following invariant+     Refl is always lifted as far as possible.++You might think that a consequencs is:+     Every identity coercions has Refl at the root++But that's not quite true because of coercion variables.  Consider+     g         where g :: Int~Int+     Left h    where h :: Maybe Int ~ Maybe Int+etc.  So the consequence is only true of coercions that+have no coercion variables.++Note [Coercion axioms applied to coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The reason coercion axioms can be applied to coercions and not just+types is to allow for better optimization.  There are some cases where+we need to be able to "push transitivity inside" an axiom in order to+expose further opportunities for optimization.++For example, suppose we have++  C a : t[a] ~ F a+  g   : b ~ c++and we want to optimize++  sym (C b) ; t[g] ; C c++which has the kind++  F b ~ F c++(stopping through t[b] and t[c] along the way).++We'd like to optimize this to just F g -- but how?  The key is+that we need to allow axioms to be instantiated by *coercions*,+not just by types.  Then we can (in certain cases) push+transitivity inside the axiom instantiations, and then react+opposite-polarity instantiations of the same axiom.  In this+case, e.g., we match t[g] against the LHS of (C c)'s kind, to+obtain the substitution  a |-> g  (note this operation is sort+of the dual of lifting!) and hence end up with++  C g : t[b] ~ F c++which indeed has the same kind as  t[g] ; C c.++Now we have++  sym (C b) ; C g++which can be optimized to F g.++Note [CoAxiom index]+~~~~~~~~~~~~~~~~~~~~+A CoAxiom has 1 or more branches. Each branch has contains a list+of the free type variables in that branch, the LHS type patterns,+and the RHS type for that branch. When we apply an axiom to a list+of coercions, we must choose which branch of the axiom we wish to+use, as the different branches may have different numbers of free+type variables. (The number of type patterns is always the same+among branches, but that doesn't quite concern us here.)++The Int in the AxiomInstCo constructor is the 0-indexed number+of the chosen branch.++Note [Forall coercions]+~~~~~~~~~~~~~~~~~~~~~~~+Constructing coercions between forall-types can be a bit tricky,+because the kinds of the bound tyvars can be different.++The typing rule is:+++  kind_co : k1 ~ k2+  tv1:k1 |- co : t1 ~ t2+  -------------------------------------------------------------------+  ForAllCo tv1 kind_co co : all tv1:k1. t1  ~+                            all tv1:k2. (t2[tv1 |-> tv1 |> sym kind_co])++First, the TyVar stored in a ForAllCo is really an optimisation: this field+should be a Name, as its kind is redundant. Thinking of the field as a Name+is helpful in understanding what a ForAllCo means.++The idea is that kind_co gives the two kinds of the tyvar. See how, in the+conclusion, tv1 is assigned kind k1 on the left but kind k2 on the right.++Of course, a type variable can't have different kinds at the same time. So,+we arbitrarily prefer the first kind when using tv1 in the inner coercion+co, which shows that t1 equals t2.++The last wrinkle is that we need to fix the kinds in the conclusion. In+t2, tv1 is assumed to have kind k1, but it has kind k2 in the conclusion of+the rule. So we do a kind-fixing substitution, replacing (tv1:k1) with+(tv1:k2) |> sym kind_co. This substitution is slightly bizarre, because it+mentions the same name with different kinds, but it *is* well-kinded, noting+that `(tv1:k2) |> sym kind_co` has kind k1.++This all really would work storing just a Name in the ForAllCo. But we can't+add Names to, e.g., VarSets, and there generally is just an impedance mismatch+in a bunch of places. So we use tv1. When we need tv2, we can use+setTyVarKind.++Note [Coherence]+~~~~~~~~~~~~~~~~+The Coherence typing rule is thus:++  g1 : s ~ t    s : k1    g2 : k1 ~ k2+  ------------------------------------+  CoherenceCo g1 g2 : (s |> g2) ~ t++While this looks (and is) unsymmetric, a combination of other coercion+combinators can make the symmetric version.++For role information, see Note [Roles and kind coercions].++Note [Predicate coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+   g :: a~b+How can we coerce between types+   ([c]~a) => [a] -> c+and+   ([c]~b) => [b] -> c+where the equality predicate *itself* differs?++Answer: we simply treat (~) as an ordinary type constructor, so these+types really look like++   ((~) [c] a) -> [a] -> c+   ((~) [c] b) -> [b] -> c++So the coercion between the two is obviously++   ((~) [c] g) -> [g] -> c++Another way to see this to say that we simply collapse predicates to+their representation type (see Type.coreView and Type.predTypeRep).++This collapse is done by mkPredCo; there is no PredCo constructor+in Coercion.  This is important because we need Nth to work on+predicates too:+    Nth 1 ((~) [c] g) = g+See Simplify.simplCoercionF, which generates such selections.++Note [Roles]+~~~~~~~~~~~~+Roles are a solution to the GeneralizedNewtypeDeriving problem, articulated+in Trac #1496. The full story is in docs/core-spec/core-spec.pdf. Also, see+http://ghc.haskell.org/trac/ghc/wiki/RolesImplementation++Here is one way to phrase the problem:++Given:+newtype Age = MkAge Int+type family F x+type instance F Age = Bool+type instance F Int = Char++This compiles down to:+axAge :: Age ~ Int+axF1 :: F Age ~ Bool+axF2 :: F Int ~ Char++Then, we can make:+(sym (axF1) ; F axAge ; axF2) :: Bool ~ Char++Yikes!++The solution is _roles_, as articulated in "Generative Type Abstraction and+Type-level Computation" (POPL 2010), available at+http://www.seas.upenn.edu/~sweirich/papers/popl163af-weirich.pdf++The specification for roles has evolved somewhat since that paper. For the+current full details, see the documentation in docs/core-spec. Here are some+highlights.++We label every equality with a notion of type equivalence, of which there are+three options: Nominal, Representational, and Phantom. A ground type is+nominally equivalent only with itself. A newtype (which is considered a ground+type in Haskell) is representationally equivalent to its representation.+Anything is "phantomly" equivalent to anything else. We use "N", "R", and "P"+to denote the equivalences.++The axioms above would be:+axAge :: Age ~R Int+axF1 :: F Age ~N Bool+axF2 :: F Age ~N Char++Then, because transitivity applies only to coercions proving the same notion+of equivalence, the above construction is impossible.++However, there is still an escape hatch: we know that any two types that are+nominally equivalent are representationally equivalent as well. This is what+the form SubCo proves -- it "demotes" a nominal equivalence into a+representational equivalence. So, it would seem the following is possible:++sub (sym axF1) ; F axAge ; sub axF2 :: Bool ~R Char   -- WRONG++What saves us here is that the arguments to a type function F, lifted into a+coercion, *must* prove nominal equivalence. So, (F axAge) is ill-formed, and+we are safe.++Roles are attached to parameters to TyCons. When lifting a TyCon into a+coercion (through TyConAppCo), we need to ensure that the arguments to the+TyCon respect their roles. For example:++data T a b = MkT a (F b)++If we know that a1 ~R a2, then we know (T a1 b) ~R (T a2 b). But, if we know+that b1 ~R b2, we know nothing about (T a b1) and (T a b2)! This is because+the type function F branches on b's *name*, not representation. So, we say+that 'a' has role Representational and 'b' has role Nominal. The third role,+Phantom, is for parameters not used in the type's definition. Given the+following definition++data Q a = MkQ Int++the Phantom role allows us to say that (Q Bool) ~R (Q Char), because we+can construct the coercion Bool ~P Char (using UnivCo).++See the paper cited above for more examples and information.++Note [TyConAppCo roles]+~~~~~~~~~~~~~~~~~~~~~~~+The TyConAppCo constructor has a role parameter, indicating the role at+which the coercion proves equality. The choice of this parameter affects+the required roles of the arguments of the TyConAppCo. To help explain+it, assume the following definition:++  type instance F Int = Bool   -- Axiom axF : F Int ~N Bool+  newtype Age = MkAge Int      -- Axiom axAge : Age ~R Int+  data Foo a = MkFoo a         -- Role on Foo's parameter is Representational++TyConAppCo Nominal Foo axF : Foo (F Int) ~N Foo Bool+  For (TyConAppCo Nominal) all arguments must have role Nominal. Why?+  So that Foo Age ~N Foo Int does *not* hold.++TyConAppCo Representational Foo (SubCo axF) : Foo (F Int) ~R Foo Bool+TyConAppCo Representational Foo axAge       : Foo Age     ~R Foo Int+  For (TyConAppCo Representational), all arguments must have the roles+  corresponding to the result of tyConRoles on the TyCon. This is the+  whole point of having roles on the TyCon to begin with. So, we can+  have Foo Age ~R Foo Int, if Foo's parameter has role R.++  If a Representational TyConAppCo is over-saturated (which is otherwise fine),+  the spill-over arguments must all be at Nominal. This corresponds to the+  behavior for AppCo.++TyConAppCo Phantom Foo (UnivCo Phantom Int Bool) : Foo Int ~P Foo Bool+  All arguments must have role Phantom. This one isn't strictly+  necessary for soundness, but this choice removes ambiguity.++The rules here dictate the roles of the parameters to mkTyConAppCo+(should be checked by Lint).++Note [NthCo and newtypes]+~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++  newtype N a = MkN Int+  type role N representational++This yields axiom++  NTCo:N :: forall a. N a ~R Int++We can then build++  co :: forall a b. N a ~R N b+  co = NTCo:N a ; sym (NTCo:N b)++for any `a` and `b`. Because of the role annotation on N, if we use+NthCo, we'll get out a representational coercion. That is:++  NthCo 0 co :: forall a b. a ~R b++Yikes! Clearly, this is terrible. The solution is simple: forbid+NthCo to be used on newtypes if the internal coercion is representational.++This is not just some corner case discovered by a segfault somewhere;+it was discovered in the proof of soundness of roles and described+in the "Safe Coercions" paper (ICFP '14).++Note [InstCo roles]+~~~~~~~~~~~~~~~~~~~+Here is (essentially) the typing rule for InstCo:++g :: (forall a. t1) ~r (forall a. t2)+w :: s1 ~N s2+------------------------------- InstCo+InstCo g w :: (t1 [a |-> s1]) ~r (t2 [a |-> s2])++Note that the Coercion w *must* be nominal. This is necessary+because the variable a might be used in a "nominal position"+(that is, a place where role inference would require a nominal+role) in t1 or t2. If we allowed w to be representational, we+could get bogus equalities.++A more nuanced treatment might be able to relax this condition+somewhat, by checking if t1 and/or t2 use their bound variables+in nominal ways. If not, having w be representational is OK.+++%************************************************************************+%*                                                                      *+                UnivCoProvenance+%*                                                                      *+%************************************************************************++A UnivCo is a coercion whose proof does not directly express its role+and kind (indeed for some UnivCos, like UnsafeCoerceProv, there /is/+no proof).++The different kinds of UnivCo are described by UnivCoProvenance.  Really+each is entirely separate, but they all share the need to represent their+role and kind, which is done in the UnivCo constructor.++-}++-- | For simplicity, we have just one UnivCo that represents a coercion from+-- some type to some other type, with (in general) no restrictions on the+-- type. The UnivCoProvenance specifies more exactly what the coercion really+-- is and why a program should (or shouldn't!) trust the coercion.+-- It is reasonable to consider each constructor of 'UnivCoProvenance'+-- as a totally independent coercion form; their only commonality is+-- that they don't tell you what types they coercion between. (That info+-- is in the 'UnivCo' constructor of 'Coercion'.+data UnivCoProvenance+  = UnsafeCoerceProv   -- ^ From @unsafeCoerce#@. These are unsound.++  | PhantomProv KindCoercion -- ^ See Note [Phantom coercions]. Only in Phantom+                             -- roled coercions++  | ProofIrrelProv KindCoercion  -- ^ From the fact that any two coercions are+                                 --   considered equivalent. See Note [ProofIrrelProv].+                                 -- Can be used in Nominal or Representational coercions++  | PluginProv String  -- ^ From a plugin, which asserts that this coercion+                       --   is sound. The string is for the use of the plugin.++  | HoleProv CoercionHole  -- ^ See Note [Coercion holes]+  deriving Data.Data++instance Outputable UnivCoProvenance where+  ppr UnsafeCoerceProv   = text "(unsafeCoerce#)"+  ppr (PhantomProv _)    = text "(phantom)"+  ppr (ProofIrrelProv _) = text "(proof irrel.)"+  ppr (PluginProv str)   = parens (text "plugin" <+> brackets (text str))+  ppr (HoleProv hole)    = parens (text "hole" <> ppr hole)++-- | A coercion to be filled in by the type-checker. See Note [Coercion holes]+data CoercionHole+  = CoercionHole { chUnique   :: Unique   -- ^ used only for debugging+                 , chCoercion :: IORef (Maybe Coercion)+                 }++instance Data.Data CoercionHole where+  -- don't traverse?+  toConstr _   = abstractConstr "CoercionHole"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "CoercionHole"++instance Outputable CoercionHole where+  ppr (CoercionHole u _) = braces (ppr u)+++{- Note [Phantom coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+     data T a = T1 | T2+Then we have+     T s ~R T t+for any old s,t. The witness for this is (TyConAppCo T Rep co),+where (co :: s ~P t) is a phantom coercion built with PhantomProv.+The role of the UnivCo is always Phantom.  The Coercion stored is the+(nominal) kind coercion between the types+   kind(s) ~N kind (t)++Note [Coercion holes]+~~~~~~~~~~~~~~~~~~~~~~~~+During typechecking, constraint solving for type classes works by+  - Generate an evidence Id,  d7 :: Num a+  - Wrap it in a Wanted constraint, [W] d7 :: Num a+  - Use the evidence Id where the evidence is needed+  - Solve the constraint later+  - When solved, add an enclosing let-binding  let d7 = .... in ....+    which actually binds d7 to the (Num a) evidence++For equality constraints we use a different strategy.  See Note [The+equality types story] in TysPrim for background on equality constraints.+  - For boxed equality constraints, (t1 ~N t2) and (t1 ~R t2), it's just+    like type classes above. (Indeed, boxed equality constraints *are* classes.)+  - But for /unboxed/ equality constraints (t1 ~R# t2) and (t1 ~N# t2)+    we use a different plan++For unboxed equalities:+  - Generate a CoercionHole, a mutable variable just like a unification+    variable+  - Wrap the CoercionHole in a Wanted constraint; see TcRnTypes.TcEvDest+  - Use the CoercionHole in a Coercion, via HoleProv+  - Solve the constraint later+  - When solved, fill in the CoercionHole by side effect, instead of+    doing the let-binding thing++The main reason for all this is that there may be no good place to let-bind+the evidence for unboxed equalities:+  - We emit constraints for kind coercions, to be used+    to cast a type's kind. These coercions then must be used in types. Because+    they might appear in a top-level type, there is no place to bind these+   (unlifted) coercions in the usual way.++  - A coercion for (forall a. t1) ~ forall a. t2) will look like+       forall a. (coercion for t1~t2)+    But the coercion for (t1~t2) may mention 'a', and we don't have let-bindings+    within coercions.  We could add them, but coercion holes are easier.++Other notes about HoleCo:++ * INVARIANT: CoercionHole and HoleProv are used only during type checking,+   and should never appear in Core. Just like unification variables; a Type+   can contain a TcTyVar, but only during type checking. If, one day, we+   use type-level information to separate out forms that can appear during+   type-checking vs forms that can appear in core proper, holes in Core will+   be ruled out.++ * The Unique carried with a coercion hole is used solely for debugging.++ * Coercion holes can be compared for equality only like other coercions:+   only by looking at the types coerced.++ * We don't use holes for other evidence because other evidence wants to+   be /shared/. But coercions are entirely erased, so there's little+   benefit to sharing.++Note [ProofIrrelProv]+~~~~~~~~~~~~~~~~~~~~~+A ProofIrrelProv is a coercion between coercions. For example:++  data G a where+    MkG :: G Bool++In core, we get++  G :: * -> *+  MkG :: forall (a :: *). (a ~ Bool) -> G a++Now, consider 'MkG -- that is, MkG used in a type -- and suppose we want+a proof that ('MkG co1 a1) ~ ('MkG co2 a2). This will have to be++  TyConAppCo Nominal MkG [co3, co4]+  where+    co3 :: co1 ~ co2+    co4 :: a1 ~ a2++Note that+  co1 :: a1 ~ Bool+  co2 :: a2 ~ Bool++Here,+  co3 = UnivCo (ProofIrrelProv co5) Nominal (CoercionTy co1) (CoercionTy co2)+  where+    co5 :: (a1 ~ Bool) ~ (a2 ~ Bool)+    co5 = TyConAppCo Nominal (~) [<*>, <*>, co4, <Bool>]+++%************************************************************************+%*                                                                      *+                 Free variables of types and coercions+%*                                                                      *+%************************************************************************+-}++{- Note [Free variables of types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The family of functions tyCoVarsOfType, tyCoVarsOfTypes etc, returns+a VarSet that is closed over the types of its variables.  More precisely,+  if    S = tyCoVarsOfType( t )+  and   (a:k) is in S+  then  tyCoVarsOftype( k ) is a subset of S++Example: The tyCoVars of this ((a:* -> k) Int) is {a, k}.++We could /not/ close over the kinds of the variable occurrences, and+instead do so at call sites, but it seems that we always want to do+so, so it's easiest to do it here.+-}+++-- | Returns free variables of a type, including kind variables as+-- a non-deterministic set. For type synonyms it does /not/ expand the+-- synonym.+tyCoVarsOfType :: Type -> TyCoVarSet+-- See Note [Free variables of types]+tyCoVarsOfType ty = fvVarSet $ tyCoFVsOfType ty++-- | `tyVarsOfType` that returns free variables of a type in a deterministic+-- set. For explanation of why using `VarSet` is not deterministic see+-- Note [Deterministic FV] in FV.+tyCoVarsOfTypeDSet :: Type -> DTyCoVarSet+-- See Note [Free variables of types]+tyCoVarsOfTypeDSet ty = fvDVarSet $ tyCoFVsOfType ty++-- | `tyVarsOfType` that returns free variables of a type in deterministic+-- order. For explanation of why using `VarSet` is not deterministic see+-- Note [Deterministic FV] in FV.+tyCoVarsOfTypeList :: Type -> [TyCoVar]+-- See Note [Free variables of types]+tyCoVarsOfTypeList ty = fvVarList $ tyCoFVsOfType ty++-- | The worker for `tyVarsOfType` and `tyVarsOfTypeList`.+-- The previous implementation used `unionVarSet` which is O(n+m) and can+-- make the function quadratic.+-- It's exported, so that it can be composed with+-- other functions that compute free variables.+-- See Note [FV naming conventions] in FV.+--+-- Eta-expanded because that makes it run faster (apparently)+-- See Note [FV eta expansion] in FV for explanation.+tyCoFVsOfType :: Type -> FV+-- See Note [Free variables of types]+tyCoFVsOfType (TyVarTy v)        a b c = (unitFV v `unionFV` tyCoFVsOfType (tyVarKind v)) a b c+tyCoFVsOfType (TyConApp _ tys)   a b c = tyCoFVsOfTypes tys a b c+tyCoFVsOfType (LitTy {})         a b c = emptyFV a b c+tyCoFVsOfType (AppTy fun arg)    a b c = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) a b c+tyCoFVsOfType (FunTy arg res)    a b c = (tyCoFVsOfType arg `unionFV` tyCoFVsOfType res) a b c+tyCoFVsOfType (ForAllTy bndr ty) a b c = tyCoFVsBndr bndr (tyCoFVsOfType ty)  a b c+tyCoFVsOfType (CastTy ty co)     a b c = (tyCoFVsOfType ty `unionFV` tyCoFVsOfCo co) a b c+tyCoFVsOfType (CoercionTy co)    a b c = tyCoFVsOfCo co a b c++tyCoFVsBndr :: TyVarBinder -> FV -> FV+-- Free vars of (forall b. <thing with fvs>)+tyCoFVsBndr (TvBndr tv _) fvs = (delFV tv fvs)+                                `unionFV` tyCoFVsOfType (tyVarKind tv)++-- | Returns free variables of types, including kind variables as+-- a non-deterministic set. For type synonyms it does /not/ expand the+-- synonym.+tyCoVarsOfTypes :: [Type] -> TyCoVarSet+-- See Note [Free variables of types]+tyCoVarsOfTypes tys = fvVarSet $ tyCoFVsOfTypes tys++-- | Returns free variables of types, including kind variables as+-- a non-deterministic set. For type synonyms it does /not/ expand the+-- synonym.+tyCoVarsOfTypesSet :: TyVarEnv Type -> TyCoVarSet+-- See Note [Free variables of types]+tyCoVarsOfTypesSet tys = fvVarSet $ tyCoFVsOfTypes $ nonDetEltsUFM tys+  -- It's OK to use nonDetEltsUFM here because we immediately forget the+  -- ordering by returning a set++-- | Returns free variables of types, including kind variables as+-- a deterministic set. For type synonyms it does /not/ expand the+-- synonym.+tyCoVarsOfTypesDSet :: [Type] -> DTyCoVarSet+-- See Note [Free variables of types]+tyCoVarsOfTypesDSet tys = fvDVarSet $ tyCoFVsOfTypes tys++-- | Returns free variables of types, including kind variables as+-- a deterministically ordered list. For type synonyms it does /not/ expand the+-- synonym.+tyCoVarsOfTypesList :: [Type] -> [TyCoVar]+-- See Note [Free variables of types]+tyCoVarsOfTypesList tys = fvVarList $ tyCoFVsOfTypes tys++tyCoFVsOfTypes :: [Type] -> FV+-- See Note [Free variables of types]+tyCoFVsOfTypes (ty:tys) fv_cand in_scope acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfTypes tys) fv_cand in_scope acc+tyCoFVsOfTypes []       fv_cand in_scope acc = emptyFV fv_cand in_scope acc++tyCoVarsOfCo :: Coercion -> TyCoVarSet+-- See Note [Free variables of types]+tyCoVarsOfCo co = fvVarSet $ tyCoFVsOfCo co++-- | Get a deterministic set of the vars free in a coercion+tyCoVarsOfCoDSet :: Coercion -> DTyCoVarSet+-- See Note [Free variables of types]+tyCoVarsOfCoDSet co = fvDVarSet $ tyCoFVsOfCo co++tyCoVarsOfCoList :: Coercion -> [TyCoVar]+-- See Note [Free variables of types]+tyCoVarsOfCoList co = fvVarList $ tyCoFVsOfCo co++tyCoFVsOfCo :: Coercion -> FV+-- Extracts type and coercion variables from a coercion+-- See Note [Free variables of types]+tyCoFVsOfCo (Refl _ ty)         fv_cand in_scope acc = tyCoFVsOfType ty fv_cand in_scope acc+tyCoFVsOfCo (TyConAppCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc+tyCoFVsOfCo (AppCo co arg) fv_cand in_scope acc+  = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc+tyCoFVsOfCo (ForAllCo tv kind_co co) fv_cand in_scope acc+  = (delFV tv (tyCoFVsOfCo co) `unionFV` tyCoFVsOfCo kind_co) fv_cand in_scope acc+tyCoFVsOfCo (FunCo _ co1 co2)    fv_cand in_scope acc+  = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc+tyCoFVsOfCo (CoVarCo v) fv_cand in_scope acc+  = (unitFV v `unionFV` tyCoFVsOfType (varType v)) fv_cand in_scope acc+tyCoFVsOfCo (AxiomInstCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc+tyCoFVsOfCo (UnivCo p _ t1 t2) fv_cand in_scope acc+  = (tyCoFVsOfProv p `unionFV` tyCoFVsOfType t1+                         `unionFV` tyCoFVsOfType t2) fv_cand in_scope acc+tyCoFVsOfCo (SymCo co)          fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc+tyCoFVsOfCo (TransCo co1 co2)   fv_cand in_scope acc = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc+tyCoFVsOfCo (NthCo _ co)        fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc+tyCoFVsOfCo (LRCo _ co)         fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc+tyCoFVsOfCo (InstCo co arg)     fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc+tyCoFVsOfCo (CoherenceCo c1 c2) fv_cand in_scope acc = (tyCoFVsOfCo c1 `unionFV` tyCoFVsOfCo c2) fv_cand in_scope acc+tyCoFVsOfCo (KindCo co)         fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc+tyCoFVsOfCo (SubCo co)          fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc+tyCoFVsOfCo (AxiomRuleCo _ cs)  fv_cand in_scope acc = tyCoFVsOfCos cs fv_cand in_scope acc++tyCoVarsOfProv :: UnivCoProvenance -> TyCoVarSet+tyCoVarsOfProv prov = fvVarSet $ tyCoFVsOfProv prov++tyCoFVsOfProv :: UnivCoProvenance -> FV+tyCoFVsOfProv UnsafeCoerceProv    fv_cand in_scope acc = emptyFV fv_cand in_scope acc+tyCoFVsOfProv (PhantomProv co)    fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc+tyCoFVsOfProv (ProofIrrelProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc+tyCoFVsOfProv (PluginProv _)      fv_cand in_scope acc = emptyFV fv_cand in_scope acc+tyCoFVsOfProv (HoleProv _)        fv_cand in_scope acc = emptyFV fv_cand in_scope acc++tyCoVarsOfCos :: [Coercion] -> TyCoVarSet+tyCoVarsOfCos cos = fvVarSet $ tyCoFVsOfCos cos++tyCoVarsOfCosSet :: CoVarEnv Coercion -> TyCoVarSet+tyCoVarsOfCosSet cos = fvVarSet $ tyCoFVsOfCos $ nonDetEltsUFM cos+  -- It's OK to use nonDetEltsUFM here because we immediately forget the+  -- ordering by returning a set++tyCoFVsOfCos :: [Coercion] -> FV+tyCoFVsOfCos []       fv_cand in_scope acc = emptyFV fv_cand in_scope acc+tyCoFVsOfCos (co:cos) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCos cos) fv_cand in_scope acc++coVarsOfType :: Type -> CoVarSet+coVarsOfType (TyVarTy v)         = coVarsOfType (tyVarKind v)+coVarsOfType (TyConApp _ tys)    = coVarsOfTypes tys+coVarsOfType (LitTy {})          = emptyVarSet+coVarsOfType (AppTy fun arg)     = coVarsOfType fun `unionVarSet` coVarsOfType arg+coVarsOfType (FunTy arg res)     = coVarsOfType arg `unionVarSet` coVarsOfType res+coVarsOfType (ForAllTy (TvBndr tv _) ty)+  = (coVarsOfType ty `delVarSet` tv)+    `unionVarSet` coVarsOfType (tyVarKind tv)+coVarsOfType (CastTy ty co)      = coVarsOfType ty `unionVarSet` coVarsOfCo co+coVarsOfType (CoercionTy co)     = coVarsOfCo co++coVarsOfTypes :: [Type] -> TyCoVarSet+coVarsOfTypes tys = mapUnionVarSet coVarsOfType tys++coVarsOfCo :: Coercion -> CoVarSet+-- Extract *coercion* variables only.  Tiresome to repeat the code, but easy.+coVarsOfCo (Refl _ ty)         = coVarsOfType ty+coVarsOfCo (TyConAppCo _ _ args) = coVarsOfCos args+coVarsOfCo (AppCo co arg)      = coVarsOfCo co `unionVarSet` coVarsOfCo arg+coVarsOfCo (ForAllCo tv kind_co co)+  = coVarsOfCo co `delVarSet` tv `unionVarSet` coVarsOfCo kind_co+coVarsOfCo (FunCo _ co1 co2)   = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2+coVarsOfCo (CoVarCo v)         = unitVarSet v `unionVarSet` coVarsOfType (varType v)+coVarsOfCo (AxiomInstCo _ _ args) = coVarsOfCos args+coVarsOfCo (UnivCo p _ t1 t2)  = coVarsOfProv p `unionVarSet` coVarsOfTypes [t1, t2]+coVarsOfCo (SymCo co)          = coVarsOfCo co+coVarsOfCo (TransCo co1 co2)   = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2+coVarsOfCo (NthCo _ co)        = coVarsOfCo co+coVarsOfCo (LRCo _ co)         = coVarsOfCo co+coVarsOfCo (InstCo co arg)     = coVarsOfCo co `unionVarSet` coVarsOfCo arg+coVarsOfCo (CoherenceCo c1 c2) = coVarsOfCos [c1, c2]+coVarsOfCo (KindCo co)         = coVarsOfCo co+coVarsOfCo (SubCo co)          = coVarsOfCo co+coVarsOfCo (AxiomRuleCo _ cs)  = coVarsOfCos cs++coVarsOfProv :: UnivCoProvenance -> CoVarSet+coVarsOfProv UnsafeCoerceProv    = emptyVarSet+coVarsOfProv (PhantomProv co)    = coVarsOfCo co+coVarsOfProv (ProofIrrelProv co) = coVarsOfCo co+coVarsOfProv (PluginProv _)      = emptyVarSet+coVarsOfProv (HoleProv _)        = emptyVarSet++coVarsOfCos :: [Coercion] -> CoVarSet+coVarsOfCos cos = mapUnionVarSet coVarsOfCo cos++-- | Add the kind variables free in the kinds of the tyvars in the given set.+-- Returns a non-deterministic set.+closeOverKinds :: TyVarSet -> TyVarSet+closeOverKinds = fvVarSet . closeOverKindsFV . nonDetEltsUniqSet+  -- It's OK to use nonDetEltsUniqSet here because we immediately forget+  -- about the ordering by returning a set.++-- | Given a list of tyvars returns a deterministic FV computation that+-- returns the given tyvars with the kind variables free in the kinds of the+-- given tyvars.+closeOverKindsFV :: [TyVar] -> FV+closeOverKindsFV tvs =+  mapUnionFV (tyCoFVsOfType . tyVarKind) tvs `unionFV` mkFVs tvs++-- | Add the kind variables free in the kinds of the tyvars in the given set.+-- Returns a deterministically ordered list.+closeOverKindsList :: [TyVar] -> [TyVar]+closeOverKindsList tvs = fvVarList $ closeOverKindsFV tvs++-- | Add the kind variables free in the kinds of the tyvars in the given set.+-- Returns a deterministic set.+closeOverKindsDSet :: DTyVarSet -> DTyVarSet+closeOverKindsDSet = fvDVarSet . closeOverKindsFV . dVarSetElems++-- | Returns True if this type has no free variables. Should be the same as+-- isEmptyVarSet . tyCoVarsOfType, but faster in the non-forall case.+noFreeVarsOfType :: Type -> Bool+noFreeVarsOfType (TyVarTy _)      = False+noFreeVarsOfType (AppTy t1 t2)    = noFreeVarsOfType t1 && noFreeVarsOfType t2+noFreeVarsOfType (TyConApp _ tys) = all noFreeVarsOfType tys+noFreeVarsOfType ty@(ForAllTy {}) = isEmptyVarSet (tyCoVarsOfType ty)+noFreeVarsOfType (FunTy t1 t2)    = noFreeVarsOfType t1 && noFreeVarsOfType t2+noFreeVarsOfType (LitTy _)        = True+noFreeVarsOfType (CastTy ty co)   = noFreeVarsOfType ty && noFreeVarsOfCo co+noFreeVarsOfType (CoercionTy co)  = noFreeVarsOfCo co++-- | Returns True if this coercion has no free variables. Should be the same as+-- isEmptyVarSet . tyCoVarsOfCo, but faster in the non-forall case.+noFreeVarsOfCo :: Coercion -> Bool+noFreeVarsOfCo (Refl _ ty)            = noFreeVarsOfType ty+noFreeVarsOfCo (TyConAppCo _ _ args)  = all noFreeVarsOfCo args+noFreeVarsOfCo (AppCo c1 c2)          = noFreeVarsOfCo c1 && noFreeVarsOfCo c2+noFreeVarsOfCo co@(ForAllCo {})       = isEmptyVarSet (tyCoVarsOfCo co)+noFreeVarsOfCo (FunCo _ c1 c2)        = noFreeVarsOfCo c1 && noFreeVarsOfCo c2+noFreeVarsOfCo (CoVarCo _)            = False+noFreeVarsOfCo (AxiomInstCo _ _ args) = all noFreeVarsOfCo args+noFreeVarsOfCo (UnivCo p _ t1 t2)     = noFreeVarsOfProv p &&+                                        noFreeVarsOfType t1 &&+                                        noFreeVarsOfType t2+noFreeVarsOfCo (SymCo co)             = noFreeVarsOfCo co+noFreeVarsOfCo (TransCo co1 co2)      = noFreeVarsOfCo co1 && noFreeVarsOfCo co2+noFreeVarsOfCo (NthCo _ co)           = noFreeVarsOfCo co+noFreeVarsOfCo (LRCo _ co)            = noFreeVarsOfCo co+noFreeVarsOfCo (InstCo co1 co2)       = noFreeVarsOfCo co1 && noFreeVarsOfCo co2+noFreeVarsOfCo (CoherenceCo co1 co2)  = noFreeVarsOfCo co1 && noFreeVarsOfCo co2+noFreeVarsOfCo (KindCo co)            = noFreeVarsOfCo co+noFreeVarsOfCo (SubCo co)             = noFreeVarsOfCo co+noFreeVarsOfCo (AxiomRuleCo _ cs)     = all noFreeVarsOfCo cs++-- | Returns True if this UnivCoProv has no free variables. Should be the same as+-- isEmptyVarSet . tyCoVarsOfProv, but faster in the non-forall case.+noFreeVarsOfProv :: UnivCoProvenance -> Bool+noFreeVarsOfProv UnsafeCoerceProv    = True+noFreeVarsOfProv (PhantomProv co)    = noFreeVarsOfCo co+noFreeVarsOfProv (ProofIrrelProv co) = noFreeVarsOfCo co+noFreeVarsOfProv (PluginProv {})     = True+noFreeVarsOfProv (HoleProv {})       = True -- matches with coVarsOfProv, but I'm unsure++{-+%************************************************************************+%*                                                                      *+                        Substitutions+      Data type defined here to avoid unnecessary mutual recursion+%*                                                                      *+%************************************************************************+-}++-- | Type & coercion substitution+--+-- #tcvsubst_invariant#+-- The following invariants must hold of a 'TCvSubst':+--+-- 1. The in-scope set is needed /only/ to+-- guide the generation of fresh uniques+--+-- 2. In particular, the /kind/ of the type variables in+-- the in-scope set is not relevant+--+-- 3. The substitution is only applied ONCE! This is because+-- in general such application will not reach a fixed point.+data TCvSubst+  = TCvSubst InScopeSet -- The in-scope type and kind variables+             TvSubstEnv -- Substitutes both type and kind variables+             CvSubstEnv -- Substitutes coercion variables+        -- See Note [Apply Once]+        -- and Note [Extending the TvSubstEnv]+        -- and Note [Substituting types and coercions]+        -- and Note [The substitution invariant]++-- | A substitution of 'Type's for 'TyVar's+--                 and 'Kind's for 'KindVar's+type TvSubstEnv = TyVarEnv Type+        -- A TvSubstEnv is used both inside a TCvSubst (with the apply-once+        -- invariant discussed in Note [Apply Once]), and also independently+        -- in the middle of matching, and unification (see Types.Unify)+        -- So you have to look at the context to know if it's idempotent or+        -- apply-once or whatever++-- | A substitution of 'Coercion's for 'CoVar's+type CvSubstEnv = CoVarEnv Coercion++{-+Note [Apply Once]+~~~~~~~~~~~~~~~~~+We use TCvSubsts to instantiate things, and we might instantiate+        forall a b. ty+\with the types+        [a, b], or [b, a].+So the substitution might go [a->b, b->a].  A similar situation arises in Core+when we find a beta redex like+        (/\ a /\ b -> e) b a+Then we also end up with a substitution that permutes type variables. Other+variations happen to; for example [a -> (a, b)].++        ****************************************************+        *** So a TCvSubst must be applied precisely once ***+        ****************************************************++A TCvSubst is not idempotent, but, unlike the non-idempotent substitution+we use during unifications, it must not be repeatedly applied.++Note [Extending the TvSubstEnv]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See #tcvsubst_invariant# for the invariants that must hold.++This invariant allows a short-cut when the subst envs are empty:+if the TvSubstEnv and CvSubstEnv are empty --- i.e. (isEmptyTCvSubst subst)+holds --- then (substTy subst ty) does nothing.++For example, consider:+        (/\a. /\b:(a~Int). ...b..) Int+We substitute Int for 'a'.  The Unique of 'b' does not change, but+nevertheless we add 'b' to the TvSubstEnv, because b's kind does change++This invariant has several crucial consequences:++* In substTyVarBndr, we need extend the TvSubstEnv+        - if the unique has changed+        - or if the kind has changed++* In substTyVar, we do not need to consult the in-scope set;+  the TvSubstEnv is enough++* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty++Note [Substituting types and coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Types and coercions are mutually recursive, and either may have variables+"belonging" to the other. Thus, every time we wish to substitute in a+type, we may also need to substitute in a coercion, and vice versa.+However, the constructor used to create type variables is distinct from+that of coercion variables, so we carry two VarEnvs in a TCvSubst. Note+that it would be possible to use the CoercionTy constructor to combine+these environments, but that seems like a false economy.++Note that the TvSubstEnv should *never* map a CoVar (built with the Id+constructor) and the CvSubstEnv should *never* map a TyVar. Furthermore,+the range of the TvSubstEnv should *never* include a type headed with+CoercionTy.++Note [The substitution invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When calling (substTy subst ty) it should be the case that+the in-scope set in the substitution is a superset of both:++  * The free vars of the range of the substitution+  * The free vars of ty minus the domain of the substitution++If we want to substitute [a -> ty1, b -> ty2] I used to+think it was enough to generate an in-scope set that includes+fv(ty1,ty2).  But that's not enough; we really should also take the+free vars of the type we are substituting into!  Example:+     (forall b. (a,b,x)) [a -> List b]+Then if we use the in-scope set {b}, there is a danger we will rename+the forall'd variable to 'x' by mistake, getting this:+     (forall x. (List b, x, x))++Breaking this invariant caused the bug from #11371.+-}++emptyTvSubstEnv :: TvSubstEnv+emptyTvSubstEnv = emptyVarEnv++emptyCvSubstEnv :: CvSubstEnv+emptyCvSubstEnv = emptyVarEnv++composeTCvSubstEnv :: InScopeSet+                   -> (TvSubstEnv, CvSubstEnv)+                   -> (TvSubstEnv, CvSubstEnv)+                   -> (TvSubstEnv, CvSubstEnv)+-- ^ @(compose env1 env2)(x)@ is @env1(env2(x))@; i.e. apply @env2@ then @env1@.+-- It assumes that both are idempotent.+-- Typically, @env1@ is the refinement to a base substitution @env2@+composeTCvSubstEnv in_scope (tenv1, cenv1) (tenv2, cenv2)+  = ( tenv1 `plusVarEnv` mapVarEnv (substTy subst1) tenv2+    , cenv1 `plusVarEnv` mapVarEnv (substCo subst1) cenv2 )+        -- First apply env1 to the range of env2+        -- Then combine the two, making sure that env1 loses if+        -- both bind the same variable; that's why env1 is the+        --  *left* argument to plusVarEnv, because the right arg wins+  where+    subst1 = TCvSubst in_scope tenv1 cenv1++-- | Composes two substitutions, applying the second one provided first,+-- like in function composition.+composeTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst+composeTCvSubst (TCvSubst is1 tenv1 cenv1) (TCvSubst is2 tenv2 cenv2)+  = TCvSubst is3 tenv3 cenv3+  where+    is3 = is1 `unionInScope` is2+    (tenv3, cenv3) = composeTCvSubstEnv is3 (tenv1, cenv1) (tenv2, cenv2)++emptyTCvSubst :: TCvSubst+emptyTCvSubst = TCvSubst emptyInScopeSet emptyTvSubstEnv emptyCvSubstEnv++mkEmptyTCvSubst :: InScopeSet -> TCvSubst+mkEmptyTCvSubst is = TCvSubst is emptyTvSubstEnv emptyCvSubstEnv++isEmptyTCvSubst :: TCvSubst -> Bool+         -- See Note [Extending the TvSubstEnv]+isEmptyTCvSubst (TCvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv++mkTCvSubst :: InScopeSet -> (TvSubstEnv, CvSubstEnv) -> TCvSubst+mkTCvSubst in_scope (tenv, cenv) = TCvSubst in_scope tenv cenv++mkTvSubst :: InScopeSet -> TvSubstEnv -> TCvSubst+-- ^ Make a TCvSubst with specified tyvar subst and empty covar subst+mkTvSubst in_scope tenv = TCvSubst in_scope tenv emptyCvSubstEnv++getTvSubstEnv :: TCvSubst -> TvSubstEnv+getTvSubstEnv (TCvSubst _ env _) = env++getCvSubstEnv :: TCvSubst -> CvSubstEnv+getCvSubstEnv (TCvSubst _ _ env) = env++getTCvInScope :: TCvSubst -> InScopeSet+getTCvInScope (TCvSubst in_scope _ _) = in_scope++-- | Returns the free variables of the types in the range of a substitution as+-- a non-deterministic set.+getTCvSubstRangeFVs :: TCvSubst -> VarSet+getTCvSubstRangeFVs (TCvSubst _ tenv cenv)+    = unionVarSet tenvFVs cenvFVs+  where+    tenvFVs = tyCoVarsOfTypesSet tenv+    cenvFVs = tyCoVarsOfCosSet cenv++isInScope :: Var -> TCvSubst -> Bool+isInScope v (TCvSubst in_scope _ _) = v `elemInScopeSet` in_scope++notElemTCvSubst :: Var -> TCvSubst -> Bool+notElemTCvSubst v (TCvSubst _ tenv cenv)+  | isTyVar v+  = not (v `elemVarEnv` tenv)+  | otherwise+  = not (v `elemVarEnv` cenv)++setTvSubstEnv :: TCvSubst -> TvSubstEnv -> TCvSubst+setTvSubstEnv (TCvSubst in_scope _ cenv) tenv = TCvSubst in_scope tenv cenv++setCvSubstEnv :: TCvSubst -> CvSubstEnv -> TCvSubst+setCvSubstEnv (TCvSubst in_scope tenv _) cenv = TCvSubst in_scope tenv cenv++zapTCvSubst :: TCvSubst -> TCvSubst+zapTCvSubst (TCvSubst in_scope _ _) = TCvSubst in_scope emptyVarEnv emptyVarEnv++extendTCvInScope :: TCvSubst -> Var -> TCvSubst+extendTCvInScope (TCvSubst in_scope tenv cenv) var+  = TCvSubst (extendInScopeSet in_scope var) tenv cenv++extendTCvInScopeList :: TCvSubst -> [Var] -> TCvSubst+extendTCvInScopeList (TCvSubst in_scope tenv cenv) vars+  = TCvSubst (extendInScopeSetList in_scope vars) tenv cenv++extendTCvInScopeSet :: TCvSubst -> VarSet -> TCvSubst+extendTCvInScopeSet (TCvSubst in_scope tenv cenv) vars+  = TCvSubst (extendInScopeSetSet in_scope vars) tenv cenv++extendTCvSubst :: TCvSubst -> TyCoVar -> Type -> TCvSubst+extendTCvSubst subst v ty+  | isTyVar v+  = extendTvSubst subst v ty+  | CoercionTy co <- ty+  = extendCvSubst subst v co+  | otherwise+  = pprPanic "extendTCvSubst" (ppr v <+> text "|->" <+> ppr ty)++extendTvSubst :: TCvSubst -> TyVar -> Type -> TCvSubst+extendTvSubst (TCvSubst in_scope tenv cenv) tv ty+  = TCvSubst in_scope (extendVarEnv tenv tv ty) cenv++extendTvSubstBinder :: TCvSubst -> TyBinder -> Type -> TCvSubst+extendTvSubstBinder subst (Named bndr) ty+  = extendTvSubst subst (binderVar bndr) ty+extendTvSubstBinder subst (Anon _)     _+  = subst++extendTvSubstWithClone :: TCvSubst -> TyVar -> TyVar -> TCvSubst+-- Adds a new tv -> tv mapping, /and/ extends the in-scope set+extendTvSubstWithClone (TCvSubst in_scope tenv cenv) tv tv'+  = TCvSubst (extendInScopeSetSet in_scope new_in_scope)+             (extendVarEnv tenv tv (mkTyVarTy tv'))+             cenv+  where+    new_in_scope = tyCoVarsOfType (tyVarKind tv') `extendVarSet` tv'++extendCvSubst :: TCvSubst -> CoVar -> Coercion -> TCvSubst+extendCvSubst (TCvSubst in_scope tenv cenv) v co+  = TCvSubst in_scope tenv (extendVarEnv cenv v co)++extendCvSubstWithClone :: TCvSubst -> CoVar -> CoVar -> TCvSubst+extendCvSubstWithClone (TCvSubst in_scope tenv cenv) cv cv'+  = TCvSubst (extendInScopeSetSet in_scope new_in_scope)+             tenv+             (extendVarEnv cenv cv (mkCoVarCo cv'))+  where+    new_in_scope = tyCoVarsOfType (varType cv') `extendVarSet` cv'++extendTvSubstAndInScope :: TCvSubst -> TyVar -> Type -> TCvSubst+-- Also extends the in-scope set+extendTvSubstAndInScope (TCvSubst in_scope tenv cenv) tv ty+  = TCvSubst (in_scope `extendInScopeSetSet` tyCoVarsOfType ty)+             (extendVarEnv tenv tv ty)+             cenv++extendTvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst+extendTvSubstList subst tvs tys+  = foldl2 extendTvSubst subst tvs tys++unionTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst+-- Works when the ranges are disjoint+unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2)+  = ASSERT( not (tenv1 `intersectsVarEnv` tenv2)+         && not (cenv1 `intersectsVarEnv` cenv2) )+    TCvSubst (in_scope1 `unionInScope` in_scope2)+             (tenv1     `plusVarEnv`   tenv2)+             (cenv1     `plusVarEnv`   cenv2)++-- mkTvSubstPrs and zipTvSubst generate the in-scope set from+-- the types given; but it's just a thunk so with a bit of luck+-- it'll never be evaluated++-- | Generates an in-scope set from the free variables in a list of types+-- and a list of coercions+mkTyCoInScopeSet :: [Type] -> [Coercion] -> InScopeSet+mkTyCoInScopeSet tys cos+  = mkInScopeSet (tyCoVarsOfTypes tys `unionVarSet` tyCoVarsOfCos cos)++-- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming+-- environment. No CoVars, please!+zipTvSubst :: [TyVar] -> [Type] -> TCvSubst+zipTvSubst tvs tys+  | debugIsOn+  , not (all isTyVar tvs) || length tvs /= length tys+  = pprTrace "zipTvSubst" (ppr tvs $$ ppr tys) emptyTCvSubst+  | otherwise+  = mkTvSubst (mkInScopeSet (tyCoVarsOfTypes tys)) tenv+  where+    tenv = zipTyEnv tvs tys++-- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming+-- environment.  No TyVars, please!+zipCvSubst :: [CoVar] -> [Coercion] -> TCvSubst+zipCvSubst cvs cos+  | debugIsOn+  , not (all isCoVar cvs) || length cvs /= length cos+  = pprTrace "zipCvSubst" (ppr cvs $$ ppr cos) emptyTCvSubst+  | otherwise+  = TCvSubst (mkInScopeSet (tyCoVarsOfCos cos)) emptyTvSubstEnv cenv+  where+    cenv = zipCoEnv cvs cos++-- | Generates the in-scope set for the 'TCvSubst' from the types in the+-- incoming environment. No CoVars, please!+mkTvSubstPrs :: [(TyVar, Type)] -> TCvSubst+mkTvSubstPrs prs =+    ASSERT2( onlyTyVarsAndNoCoercionTy, text "prs" <+> ppr prs )+    mkTvSubst in_scope tenv+  where tenv = mkVarEnv prs+        in_scope = mkInScopeSet $ tyCoVarsOfTypes $ map snd prs+        onlyTyVarsAndNoCoercionTy =+          and [ isTyVar tv && not (isCoercionTy ty)+              | (tv, ty) <- prs ]++zipTyEnv :: [TyVar] -> [Type] -> TvSubstEnv+zipTyEnv tyvars tys+  = ASSERT( all (not . isCoercionTy) tys )+    mkVarEnv (zipEqual "zipTyEnv" tyvars tys)+        -- There used to be a special case for when+        --      ty == TyVarTy tv+        -- (a not-uncommon case) in which case the substitution was dropped.+        -- But the type-tidier changes the print-name of a type variable without+        -- changing the unique, and that led to a bug.   Why?  Pre-tidying, we had+        -- a type {Foo t}, where Foo is a one-method class.  So Foo is really a newtype.+        -- And it happened that t was the type variable of the class.  Post-tiding,+        -- it got turned into {Foo t2}.  The ext-core printer expanded this using+        -- sourceTypeRep, but that said "Oh, t == t2" because they have the same unique,+        -- and so generated a rep type mentioning t not t2.+        --+        -- Simplest fix is to nuke the "optimisation"++zipCoEnv :: [CoVar] -> [Coercion] -> CvSubstEnv+zipCoEnv cvs cos = mkVarEnv (zipEqual "zipCoEnv" cvs cos)++instance Outputable TCvSubst where+  ppr (TCvSubst ins tenv cenv)+    = brackets $ sep[ text "TCvSubst",+                      nest 2 (text "In scope:" <+> ppr ins),+                      nest 2 (text "Type env:" <+> ppr tenv),+                      nest 2 (text "Co env:" <+> ppr cenv) ]++{-+%************************************************************************+%*                                                                      *+                Performing type or kind substitutions+%*                                                                      *+%************************************************************************++Note [Sym and ForAllCo]+~~~~~~~~~~~~~~~~~~~~~~~+In OptCoercion, we try to push "sym" out to the leaves of a coercion. But,+how do we push sym into a ForAllCo? It's a little ugly.++Here is the typing rule:++h : k1 ~# k2+(tv : k1) |- g : ty1 ~# ty2+----------------------------+ForAllCo tv h g : (ForAllTy (tv : k1) ty1) ~#+                  (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h]))++Here is what we want:++ForAllCo tv h' g' : (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h])) ~#+                    (ForAllTy (tv : k1) ty1)+++Because the kinds of the type variables to the right of the colon are the kinds+coerced by h', we know (h' : k2 ~# k1). Thus, (h' = sym h).++Now, we can rewrite ty1 to be (ty1[tv |-> tv |> sym h' |> h']). We thus want++ForAllCo tv h' g' :+  (ForAllTy (tv : k2) (ty2[tv |-> tv |> h'])) ~#+  (ForAllTy (tv : k1) (ty1[tv |-> tv |> h'][tv |-> tv |> sym h']))++We thus see that we want++g' : ty2[tv |-> tv |> h'] ~# ty1[tv |-> tv |> h']++and thus g' = sym (g[tv |-> tv |> h']).++Putting it all together, we get this:++sym (ForAllCo tv h g)+==>+ForAllCo tv (sym h) (sym g[tv |-> tv |> sym h])++-}++-- | Type substitution, see 'zipTvSubst'+substTyWith :: HasCallStack => [TyVar] -> [Type] -> Type -> Type+-- Works only if the domain of the substitution is a+-- superset of the type being substituted into+substTyWith tvs tys = ASSERT( length tvs == length tys )+                      substTy (zipTvSubst tvs tys)++-- | Type substitution, see 'zipTvSubst'. Disables sanity checks.+-- The problems that the sanity checks in substTy catch are described in+-- Note [The substitution invariant].+-- The goal of #11371 is to migrate all the calls of substTyUnchecked to+-- substTy and remove this function. Please don't use in new code.+substTyWithUnchecked :: [TyVar] -> [Type] -> Type -> Type+substTyWithUnchecked tvs tys+  = ASSERT( length tvs == length tys )+    substTyUnchecked (zipTvSubst tvs tys)++-- | Substitute tyvars within a type using a known 'InScopeSet'.+-- Pre-condition: the 'in_scope' set should satisfy Note [The substitution+-- invariant]; specifically it should include the free vars of 'tys',+-- and of 'ty' minus the domain of the subst.+substTyWithInScope :: InScopeSet -> [TyVar] -> [Type] -> Type -> Type+substTyWithInScope in_scope tvs tys ty =+  ASSERT( length tvs == length tys )+  substTy (mkTvSubst in_scope tenv) ty+  where tenv = zipTyEnv tvs tys++-- | Coercion substitution, see 'zipTvSubst'+substCoWith :: HasCallStack => [TyVar] -> [Type] -> Coercion -> Coercion+substCoWith tvs tys = ASSERT( length tvs == length tys )+                      substCo (zipTvSubst tvs tys)++-- | Coercion substitution, see 'zipTvSubst'. Disables sanity checks.+-- The problems that the sanity checks in substCo catch are described in+-- Note [The substitution invariant].+-- The goal of #11371 is to migrate all the calls of substCoUnchecked to+-- substCo and remove this function. Please don't use in new code.+substCoWithUnchecked :: [TyVar] -> [Type] -> Coercion -> Coercion+substCoWithUnchecked tvs tys+  = ASSERT( length tvs == length tys )+    substCoUnchecked (zipTvSubst tvs tys)++++-- | Substitute covars within a type+substTyWithCoVars :: [CoVar] -> [Coercion] -> Type -> Type+substTyWithCoVars cvs cos = substTy (zipCvSubst cvs cos)++-- | Type substitution, see 'zipTvSubst'+substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type]+substTysWith tvs tys = ASSERT( length tvs == length tys )+                       substTys (zipTvSubst tvs tys)++-- | Type substitution, see 'zipTvSubst'+substTysWithCoVars :: [CoVar] -> [Coercion] -> [Type] -> [Type]+substTysWithCoVars cvs cos = ASSERT( length cvs == length cos )+                             substTys (zipCvSubst cvs cos)++-- | Substitute within a 'Type' after adding the free variables of the type+-- to the in-scope set. This is useful for the case when the free variables+-- aren't already in the in-scope set or easily available.+-- See also Note [The substitution invariant].+substTyAddInScope :: TCvSubst -> Type -> Type+substTyAddInScope subst ty =+  substTy (extendTCvInScopeSet subst $ tyCoVarsOfType ty) ty++-- | When calling `substTy` it should be the case that the in-scope set in+-- the substitution is a superset of the free vars of the range of the+-- substitution.+-- See also Note [The substitution invariant].+isValidTCvSubst :: TCvSubst -> Bool+isValidTCvSubst (TCvSubst in_scope tenv cenv) =+  (tenvFVs `varSetInScope` in_scope) &&+  (cenvFVs `varSetInScope` in_scope)+  where+  tenvFVs = tyCoVarsOfTypesSet tenv+  cenvFVs = tyCoVarsOfCosSet cenv++-- | This checks if the substitution satisfies the invariant from+-- Note [The substitution invariant].+checkValidSubst :: HasCallStack => TCvSubst -> [Type] -> [Coercion] -> a -> a+checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a+  = ASSERT2( isValidTCvSubst subst,+             text "in_scope" <+> ppr in_scope $$+             text "tenv" <+> ppr tenv $$+             text "tenvFVs"+               <+> ppr (tyCoVarsOfTypesSet tenv) $$+             text "cenv" <+> ppr cenv $$+             text "cenvFVs"+               <+> ppr (tyCoVarsOfCosSet cenv) $$+             text "tys" <+> ppr tys $$+             text "cos" <+> ppr cos )+    ASSERT2( tysCosFVsInScope,+             text "in_scope" <+> ppr in_scope $$+             text "tenv" <+> ppr tenv $$+             text "cenv" <+> ppr cenv $$+             text "tys" <+> ppr tys $$+             text "cos" <+> ppr cos $$+             text "needInScope" <+> ppr needInScope )+    a+  where+  substDomain = nonDetKeysUFM tenv ++ nonDetKeysUFM cenv+    -- It's OK to use nonDetKeysUFM here, because we only use this list to+    -- remove some elements from a set+  needInScope = (tyCoVarsOfTypes tys `unionVarSet` tyCoVarsOfCos cos)+                  `delListFromUniqSet_Directly` substDomain+  tysCosFVsInScope = needInScope `varSetInScope` in_scope+++-- | Substitute within a 'Type'+-- The substitution has to satisfy the invariants described in+-- Note [The substitution invariant].+substTy :: HasCallStack => TCvSubst -> Type  -> Type+substTy subst ty+  | isEmptyTCvSubst subst = ty+  | otherwise             = checkValidSubst subst [ty] [] $+                            subst_ty subst ty++-- | Substitute within a 'Type' disabling the sanity checks.+-- The problems that the sanity checks in substTy catch are described in+-- Note [The substitution invariant].+-- The goal of #11371 is to migrate all the calls of substTyUnchecked to+-- substTy and remove this function. Please don't use in new code.+substTyUnchecked :: TCvSubst -> Type -> Type+substTyUnchecked subst ty+                 | isEmptyTCvSubst subst = ty+                 | otherwise             = subst_ty subst ty++-- | Substitute within several 'Type's+-- The substitution has to satisfy the invariants described in+-- Note [The substitution invariant].+substTys :: HasCallStack => TCvSubst -> [Type] -> [Type]+substTys subst tys+  | isEmptyTCvSubst subst = tys+  | otherwise = checkValidSubst subst tys [] $ map (subst_ty subst) tys++-- | Substitute within several 'Type's disabling the sanity checks.+-- The problems that the sanity checks in substTys catch are described in+-- Note [The substitution invariant].+-- The goal of #11371 is to migrate all the calls of substTysUnchecked to+-- substTys and remove this function. Please don't use in new code.+substTysUnchecked :: TCvSubst -> [Type] -> [Type]+substTysUnchecked subst tys+                 | isEmptyTCvSubst subst = tys+                 | otherwise             = map (subst_ty subst) tys++-- | Substitute within a 'ThetaType'+-- The substitution has to satisfy the invariants described in+-- Note [The substitution invariant].+substTheta :: HasCallStack => TCvSubst -> ThetaType -> ThetaType+substTheta = substTys++-- | Substitute within a 'ThetaType' disabling the sanity checks.+-- The problems that the sanity checks in substTys catch are described in+-- Note [The substitution invariant].+-- The goal of #11371 is to migrate all the calls of substThetaUnchecked to+-- substTheta and remove this function. Please don't use in new code.+substThetaUnchecked :: TCvSubst -> ThetaType -> ThetaType+substThetaUnchecked = substTysUnchecked+++subst_ty :: TCvSubst -> Type -> Type+-- subst_ty is the main workhorse for type substitution+--+-- Note that the in_scope set is poked only if we hit a forall+-- so it may often never be fully computed+subst_ty subst ty+   = go ty+  where+    go (TyVarTy tv)      = substTyVar subst tv+    go (AppTy fun arg)   = mkAppTy (go fun) $! (go arg)+                -- The mkAppTy smart constructor is important+                -- we might be replacing (a Int), represented with App+                -- by [Int], represented with TyConApp+    go (TyConApp tc tys) = let args = map go tys+                           in  args `seqList` TyConApp tc args+    go (FunTy arg res)   = (FunTy $! go arg) $! go res+    go (ForAllTy (TvBndr tv vis) ty)+                         = case substTyVarBndrUnchecked subst tv of+                             (subst', tv') ->+                               (ForAllTy $! ((TvBndr $! tv') vis)) $!+                                            (subst_ty subst' ty)+    go (LitTy n)         = LitTy $! n+    go (CastTy ty co)    = (mkCastTy $! (go ty)) $! (subst_co subst co)+    go (CoercionTy co)   = CoercionTy $! (subst_co subst co)++substTyVar :: TCvSubst -> TyVar -> Type+substTyVar (TCvSubst _ tenv _) tv+  = ASSERT( isTyVar tv )+    case lookupVarEnv tenv tv of+      Just ty -> ty+      Nothing -> TyVarTy tv++substTyVars :: TCvSubst -> [TyVar] -> [Type]+substTyVars subst = map $ substTyVar subst++lookupTyVar :: TCvSubst -> TyVar  -> Maybe Type+        -- See Note [Extending the TCvSubst]+lookupTyVar (TCvSubst _ tenv _) tv+  = ASSERT( isTyVar tv )+    lookupVarEnv tenv tv++-- | Substitute within a 'Coercion'+-- The substitution has to satisfy the invariants described in+-- Note [The substitution invariant].+substCo :: HasCallStack => TCvSubst -> Coercion -> Coercion+substCo subst co+  | isEmptyTCvSubst subst = co+  | otherwise = checkValidSubst subst [] [co] $ subst_co subst co++-- | Substitute within a 'Coercion' disabling sanity checks.+-- The problems that the sanity checks in substCo catch are described in+-- Note [The substitution invariant].+-- The goal of #11371 is to migrate all the calls of substCoUnchecked to+-- substCo and remove this function. Please don't use in new code.+substCoUnchecked :: TCvSubst -> Coercion -> Coercion+substCoUnchecked subst co+  | isEmptyTCvSubst subst = co+  | otherwise = subst_co subst co++-- | Substitute within several 'Coercion's+-- The substitution has to satisfy the invariants described in+-- Note [The substitution invariant].+substCos :: HasCallStack => TCvSubst -> [Coercion] -> [Coercion]+substCos subst cos+  | isEmptyTCvSubst subst = cos+  | otherwise = checkValidSubst subst [] cos $ map (subst_co subst) cos++subst_co :: TCvSubst -> Coercion -> Coercion+subst_co subst co+  = go co+  where+    go_ty :: Type -> Type+    go_ty = subst_ty subst++    go :: Coercion -> Coercion+    go (Refl r ty)           = mkReflCo r $! go_ty ty+    go (TyConAppCo r tc args)= let args' = map go args+                               in  args' `seqList` mkTyConAppCo r tc args'+    go (AppCo co arg)        = (mkAppCo $! go co) $! go arg+    go (ForAllCo tv kind_co co)+      = case substForAllCoBndrUnchecked subst tv kind_co of { (subst', tv', kind_co') ->+          ((mkForAllCo $! tv') $! kind_co') $! subst_co subst' co }+    go (FunCo r co1 co2)     = (mkFunCo r $! go co1) $! go co2+    go (CoVarCo cv)          = substCoVar subst cv+    go (AxiomInstCo con ind cos) = mkAxiomInstCo con ind $! map go cos+    go (UnivCo p r t1 t2)    = (((mkUnivCo $! go_prov p) $! r) $!+                                (go_ty t1)) $! (go_ty t2)+    go (SymCo co)            = mkSymCo $! (go co)+    go (TransCo co1 co2)     = (mkTransCo $! (go co1)) $! (go co2)+    go (NthCo d co)          = mkNthCo d $! (go co)+    go (LRCo lr co)          = mkLRCo lr $! (go co)+    go (InstCo co arg)       = (mkInstCo $! (go co)) $! go arg+    go (CoherenceCo co1 co2) = (mkCoherenceCo $! (go co1)) $! (go co2)+    go (KindCo co)           = mkKindCo $! (go co)+    go (SubCo co)            = mkSubCo $! (go co)+    go (AxiomRuleCo c cs)    = let cs1 = map go cs+                                in cs1 `seqList` AxiomRuleCo c cs1++    go_prov UnsafeCoerceProv     = UnsafeCoerceProv+    go_prov (PhantomProv kco)    = PhantomProv (go kco)+    go_prov (ProofIrrelProv kco) = ProofIrrelProv (go kco)+    go_prov p@(PluginProv _)     = p+    go_prov p@(HoleProv _)       = p+      -- NB: this last case is a little suspicious, but we need it. Originally,+      -- there was a panic here, but it triggered from deeplySkolemise. Because+      -- we only skolemise tyvars that are manually bound, this operation makes+      -- sense, even over a coercion with holes.++substForAllCoBndr :: TCvSubst -> TyVar -> Coercion -> (TCvSubst, TyVar, Coercion)+substForAllCoBndr subst+  = substForAllCoBndrCallback False (substCo subst) subst++-- | Like 'substForAllCoBndr', but disables sanity checks.+-- The problems that the sanity checks in substCo catch are described in+-- Note [The substitution invariant].+-- The goal of #11371 is to migrate all the calls of substCoUnchecked to+-- substCo and remove this function. Please don't use in new code.+substForAllCoBndrUnchecked :: TCvSubst -> TyVar -> Coercion -> (TCvSubst, TyVar, Coercion)+substForAllCoBndrUnchecked subst+  = substForAllCoBndrCallback False (substCoUnchecked subst) subst++-- See Note [Sym and ForAllCo]+substForAllCoBndrCallback :: Bool  -- apply sym to binder?+                          -> (Coercion -> Coercion)  -- transformation to kind co+                          -> TCvSubst -> TyVar -> Coercion+                          -> (TCvSubst, TyVar, Coercion)+substForAllCoBndrCallback sym sco (TCvSubst in_scope tenv cenv)+                          old_var old_kind_co+  = ( TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv+    , new_var, new_kind_co )+  where+    new_env | no_change && not sym = delVarEnv tenv old_var+            | sym       = extendVarEnv tenv old_var $+                            TyVarTy new_var `CastTy` new_kind_co+            | otherwise = extendVarEnv tenv old_var (TyVarTy new_var)++    no_kind_change = noFreeVarsOfCo old_kind_co+    no_change = no_kind_change && (new_var == old_var)++    new_kind_co | no_kind_change = old_kind_co+                | otherwise      = sco old_kind_co++    Pair new_ki1 _ = coercionKind new_kind_co++    new_var  = uniqAway in_scope (setTyVarKind old_var new_ki1)++substCoVar :: TCvSubst -> CoVar -> Coercion+substCoVar (TCvSubst _ _ cenv) cv+  = case lookupVarEnv cenv cv of+      Just co -> co+      Nothing -> CoVarCo cv++substCoVars :: TCvSubst -> [CoVar] -> [Coercion]+substCoVars subst cvs = map (substCoVar subst) cvs++lookupCoVar :: TCvSubst -> Var  -> Maybe Coercion+lookupCoVar (TCvSubst _ _ cenv) v = lookupVarEnv cenv v++substTyVarBndr :: HasCallStack => TCvSubst -> TyVar -> (TCvSubst, TyVar)+substTyVarBndr = substTyVarBndrCallback substTy++-- | Like 'substTyVarBndr' but disables sanity checks.+-- The problems that the sanity checks in substTy catch are described in+-- Note [The substitution invariant].+-- The goal of #11371 is to migrate all the calls of substTyUnchecked to+-- substTy and remove this function. Please don't use in new code.+substTyVarBndrUnchecked :: TCvSubst -> TyVar -> (TCvSubst, TyVar)+substTyVarBndrUnchecked = substTyVarBndrCallback substTyUnchecked++-- | Substitute a tyvar in a binding position, returning an+-- extended subst and a new tyvar.+substTyVarBndrCallback :: (TCvSubst -> Type -> Type)  -- ^ the subst function+                       -> TCvSubst -> TyVar -> (TCvSubst, TyVar)+substTyVarBndrCallback subst_fn subst@(TCvSubst in_scope tenv cenv) old_var+  = ASSERT2( _no_capture, pprTyVar old_var $$ pprTyVar new_var $$ ppr subst )+    ASSERT( isTyVar old_var )+    (TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv, new_var)+  where+    new_env | no_change = delVarEnv tenv old_var+            | otherwise = extendVarEnv tenv old_var (TyVarTy new_var)++    _no_capture = not (new_var `elemVarSet` tyCoVarsOfTypesSet tenv)+    -- Assertion check that we are not capturing something in the substitution++    old_ki = tyVarKind old_var+    no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed+    no_change = no_kind_change && (new_var == old_var)+        -- no_change means that the new_var is identical in+        -- all respects to the old_var (same unique, same kind)+        -- See Note [Extending the TCvSubst]+        --+        -- In that case we don't need to extend the substitution+        -- to map old to new.  But instead we must zap any+        -- current substitution for the variable. For example:+        --      (\x.e) with id_subst = [x |-> e']+        -- Here we must simply zap the substitution for x++    new_var | no_kind_change = uniqAway in_scope old_var+            | otherwise = uniqAway in_scope $+                          setTyVarKind old_var (subst_fn subst old_ki)+        -- The uniqAway part makes sure the new variable is not already in scope++substCoVarBndr :: TCvSubst -> CoVar -> (TCvSubst, CoVar)+substCoVarBndr subst@(TCvSubst in_scope tenv cenv) old_var+  = ASSERT( isCoVar old_var )+    (TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var)+  where+    new_co         = mkCoVarCo new_var+    no_kind_change = all noFreeVarsOfType [t1, t2]+    no_change      = new_var == old_var && no_kind_change++    new_cenv | no_change = delVarEnv cenv old_var+             | otherwise = extendVarEnv cenv old_var new_co++    new_var = uniqAway in_scope subst_old_var+    subst_old_var = mkCoVar (varName old_var) new_var_type++    (_, _, t1, t2, role) = coVarKindsTypesRole old_var+    t1' = substTy subst t1+    t2' = substTy subst t2+    new_var_type = mkCoercionType role t1' t2'+                  -- It's important to do the substitution for coercions,+                  -- because they can have free type variables++cloneTyVarBndr :: TCvSubst -> TyVar -> Unique -> (TCvSubst, TyVar)+cloneTyVarBndr subst@(TCvSubst in_scope tv_env cv_env) tv uniq+  = ASSERT2( isTyVar tv, ppr tv )   -- I think it's only called on TyVars+    (TCvSubst (extendInScopeSet in_scope tv')+              (extendVarEnv tv_env tv (mkTyVarTy tv')) cv_env, tv')+  where+    old_ki = tyVarKind tv+    no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed++    tv1 | no_kind_change = tv+        | otherwise      = setTyVarKind tv (substTy subst old_ki)++    tv' = setVarUnique tv1 uniq++cloneTyVarBndrs :: TCvSubst -> [TyVar] -> UniqSupply -> (TCvSubst, [TyVar])+cloneTyVarBndrs subst []     _usupply = (subst, [])+cloneTyVarBndrs subst (t:ts)  usupply = (subst'', tv:tvs)+  where+    (uniq, usupply') = takeUniqFromSupply usupply+    (subst' , tv )   = cloneTyVarBndr subst t uniq+    (subst'', tvs)   = cloneTyVarBndrs subst' ts usupply'++{-+%************************************************************************+%*                                                                      *+                   Pretty-printing types++       Defined very early because of debug printing in assertions+%*                                                                      *+%************************************************************************++@pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is+defined to use this.  @pprParendType@ is the same, except it puts+parens around the type, except for the atomic cases.  @pprParendType@+works just by setting the initial context precedence very high.++Note [Precedence in types]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We don't keep the fixity of type operators in the operator. So the pretty printer+follows the following precedence order:+   Type constructor application   binds more tightly than+   Operator applications          which bind more tightly than+   Function arrow++So we might see  a :+: T b -> c+meaning          (a :+: (T b)) -> c++Maybe operator applications should bind a bit less tightly?++Anyway, that's the current story; it is used consistently for Type and HsType.+-}++------------------++pprType, pprParendType :: Type -> SDoc+pprType       = pprIfaceType       . tidyToIfaceType+pprParendType = pprParendIfaceType . tidyToIfaceType++pprTyLit :: TyLit -> SDoc+pprTyLit = pprIfaceTyLit . toIfaceTyLit++pprKind, pprParendKind :: Kind -> SDoc+pprKind       = pprType+pprParendKind = pprParendType++tidyToIfaceType :: Type -> IfaceType+-- It's vital to tidy before converting to an IfaceType+-- or nested binders will become indistinguishable!+--+-- Also for the free type variables, tell toIfaceTypeX to+-- leave them as IfaceFreeTyVar.  This is super-important+-- for debug printing.+tidyToIfaceType ty = toIfaceTypeX (mkVarSet free_tcvs) (tidyType env ty)+  where+    env       = tidyFreeTyCoVars emptyTidyEnv free_tcvs+    free_tcvs = tyCoVarsOfTypeWellScoped ty++------------+pprClassPred :: Class -> [Type] -> SDoc+pprClassPred clas tys = pprTypeApp (classTyCon clas) tys++------------+pprTheta :: ThetaType -> SDoc+pprTheta = pprIfaceContext . map tidyToIfaceType++pprThetaArrowTy :: ThetaType -> SDoc+pprThetaArrowTy = pprIfaceContextArr . map tidyToIfaceType++------------------+instance Outputable Type where+    ppr ty = pprType ty++instance Outputable TyLit where+   ppr = pprTyLit++------------------++pprSigmaType :: Type -> SDoc+pprSigmaType = pprIfaceSigmaType ShowForAllWhen . tidyToIfaceType++pprForAll :: [TyVarBinder] -> SDoc+pprForAll tvs = pprIfaceForAll (map toIfaceForAllBndr tvs)++-- | Print a user-level forall; see Note [When to print foralls]+pprUserForAll :: [TyVarBinder] -> SDoc+pprUserForAll = pprUserIfaceForAll . map toIfaceForAllBndr++pprTvBndrs :: [TyVarBinder] -> SDoc+pprTvBndrs tvs = sep (map pprTvBndr tvs)++pprTvBndr :: TyVarBinder -> SDoc+pprTvBndr = pprTyVar . binderVar++pprTyVars :: [TyVar] -> SDoc+pprTyVars tvs = sep (map pprTyVar tvs)++pprTyVar :: TyVar -> SDoc+-- Print a type variable binder with its kind (but not if *)+-- Here we do not go via IfaceType, because the duplication with+-- pprIfaceTvBndr is minimal, and the loss of uniques etc in+-- debug printing is disastrous+pprTyVar tv+  | isLiftedTypeKind kind = ppr tv+  | otherwise             = parens (ppr tv <+> dcolon <+> ppr kind)+  where+    kind = tyVarKind tv++instance Outputable TyBinder where+  ppr (Anon ty) = text "[anon]" <+> ppr ty+  ppr (Named (TvBndr v Required))  = ppr v+  ppr (Named (TvBndr v Specified)) = char '@' <> ppr v+  ppr (Named (TvBndr v Inferred))  = braces (ppr v)++-----------------+instance Outputable Coercion where -- defined here to avoid orphans+  ppr = pprCo++{-+Note [When to print foralls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Mostly we want to print top-level foralls when (and only when) the user specifies+-fprint-explicit-foralls.  But when kind polymorphism is at work, that suppresses+too much information; see Trac #9018.++So I'm trying out this rule: print explicit foralls if+  a) User specifies -fprint-explicit-foralls, or+  b) Any of the quantified type variables has a kind+     that mentions a kind variable++This catches common situations, such as a type siguature+     f :: m a+which means+      f :: forall k. forall (m :: k->*) (a :: k). m a+We really want to see both the "forall k" and the kind signatures+on m and a.  The latter comes from pprTvBndr.++Note [Infix type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+With TypeOperators you can say++   f :: (a ~> b) -> b++and the (~>) is considered a type variable.  However, the type+pretty-printer in this module will just see (a ~> b) as++   App (App (TyVarTy "~>") (TyVarTy "a")) (TyVarTy "b")++So it'll print the type in prefix form.  To avoid confusion we must+remember to parenthesise the operator, thus++   (~>) a b -> b++See Trac #2766.+-}++pprDataCons :: TyCon -> SDoc+pprDataCons = sepWithVBars . fmap pprDataConWithArgs . tyConDataCons+  where+    sepWithVBars [] = empty+    sepWithVBars docs = sep (punctuate (space <> vbar) docs)++pprDataConWithArgs :: DataCon -> SDoc+pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc]+  where+    (_univ_tvs, _ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc+    univ_bndrs = dataConUnivTyVarBinders dc+    ex_bndrs   = dataConExTyVarBinders dc+    forAllDoc = pprUserForAll $ (filterEqSpec eq_spec univ_bndrs ++ ex_bndrs)+    thetaDoc  = pprThetaArrowTy theta+    argsDoc   = hsep (fmap pprParendType arg_tys)+++pprTypeApp :: TyCon -> [Type] -> SDoc+pprTypeApp tc tys+  = pprIfaceTypeApp TopPrec (toIfaceTyCon tc)+                            (toIfaceTcArgs tc tys)+    -- TODO: toIfaceTcArgs seems rather wasteful here++pprTcAppCo :: TyPrec -> (TyPrec -> Coercion -> SDoc)+           -> TyCon -> [Coercion] -> SDoc+pprTcAppCo p _pp tc cos+  = pprIfaceCoTcApp p (toIfaceTyCon tc) (map toIfaceCoercion cos)++------------------++pprPrefixApp :: TyPrec -> SDoc -> [SDoc] -> SDoc+pprPrefixApp = pprIfacePrefixApp++----------------+pprArrowChain :: TyPrec -> [SDoc] -> SDoc+-- pprArrowChain p [a,b,c]  generates   a -> b -> c+pprArrowChain _ []         = empty+pprArrowChain p (arg:args) = maybeParen p FunPrec $+                             sep [arg, sep (map (arrow <+>) args)]++ppSuggestExplicitKinds :: SDoc+-- Print a helpful suggstion about -fprint-explicit-kinds,+-- if it is not already on+ppSuggestExplicitKinds+  = sdocWithDynFlags $ \ dflags ->+    ppUnless (gopt Opt_PrintExplicitKinds dflags) $+    text "Use -fprint-explicit-kinds to see the kind arguments"++{-+%************************************************************************+%*                                                                      *+\subsection{TidyType}+%*                                                                      *+%************************************************************************+-}++-- | This tidies up a type for printing in an error message, or in+-- an interface file.+--+-- It doesn't change the uniques at all, just the print names.+tidyTyCoVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar])+tidyTyCoVarBndrs (occ_env, subst) tvs+    = mapAccumL tidyTyCoVarBndr tidy_env' tvs+  where+    -- Seed the occ_env with clashes among the names, see+    -- Node [Tidying multiple names at once] in OccName+    -- Se still go through tidyTyCoVarBndr so that each kind variable is tidied+    -- with the correct tidy_env+    occs = map getHelpfulOccName tvs+    tidy_env' = (avoidClashesOccEnv occ_env occs, subst)++tidyTyCoVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)+tidyTyCoVarBndr tidy_env@(occ_env, subst) tyvar+  = case tidyOccName occ_env (getHelpfulOccName tyvar) of+      (occ_env', occ') -> ((occ_env', subst'), tyvar')+        where+          subst' = extendVarEnv subst tyvar tyvar'+          tyvar' = setTyVarKind (setTyVarName tyvar name') kind'+          kind'  = tidyKind tidy_env (tyVarKind tyvar)+          name'  = tidyNameOcc name occ'+          name   = tyVarName tyvar++getHelpfulOccName :: TyCoVar -> OccName+getHelpfulOccName tyvar = occ1+  where+    name = tyVarName tyvar+    occ  = getOccName name+    -- A TcTyVar with a System Name is probably a unification variable;+    -- when we tidy them we give them a trailing "0" (or 1 etc)+    -- so that they don't take precedence for the un-modified name+    -- Plus, indicating a unification variable in this way is a+    -- helpful clue for users+    occ1 | isSystemName name+         , isTcTyVar tyvar+         = mkTyVarOcc (occNameString occ ++ "0")+         | otherwise+         = occ++tidyTyVarBinder :: TidyEnv -> TyVarBndr TyVar vis+                -> (TidyEnv, TyVarBndr TyVar vis)+tidyTyVarBinder tidy_env (TvBndr tv vis)+  = (tidy_env', TvBndr tv' vis)+  where+    (tidy_env', tv') = tidyTyCoVarBndr tidy_env tv++tidyTyVarBinders :: TidyEnv -> [TyVarBndr TyVar vis]+                 -> (TidyEnv, [TyVarBndr TyVar vis])+tidyTyVarBinders = mapAccumL tidyTyVarBinder++---------------+tidyFreeTyCoVars :: TidyEnv -> [TyCoVar] -> TidyEnv+-- ^ Add the free 'TyVar's to the env in tidy form,+-- so that we can tidy the type they are free in+tidyFreeTyCoVars (full_occ_env, var_env) tyvars+  = fst (tidyOpenTyCoVars (full_occ_env, var_env) tyvars)++        ---------------+tidyOpenTyCoVars :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar])+tidyOpenTyCoVars env tyvars = mapAccumL tidyOpenTyCoVar env tyvars++---------------+tidyOpenTyCoVar :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)+-- ^ Treat a new 'TyCoVar' as a binder, and give it a fresh tidy name+-- using the environment if one has not already been allocated. See+-- also 'tidyTyCoVarBndr'+tidyOpenTyCoVar env@(_, subst) tyvar+  = case lookupVarEnv subst tyvar of+        Just tyvar' -> (env, tyvar')              -- Already substituted+        Nothing     ->+          let env' = tidyFreeTyCoVars env (tyCoVarsOfTypeList (tyVarKind tyvar))+          in tidyTyCoVarBndr env' tyvar  -- Treat it as a binder++---------------+tidyTyVarOcc :: TidyEnv -> TyVar -> TyVar+tidyTyVarOcc env@(_, subst) tv+  = case lookupVarEnv subst tv of+        Nothing  -> updateTyVarKind (tidyType env) tv+        Just tv' -> tv'++---------------+tidyTypes :: TidyEnv -> [Type] -> [Type]+tidyTypes env tys = map (tidyType env) tys++---------------+tidyType :: TidyEnv -> Type -> Type+tidyType _   (LitTy n)            = LitTy n+tidyType env (TyVarTy tv)         = TyVarTy (tidyTyVarOcc env tv)+tidyType env (TyConApp tycon tys) = let args = tidyTypes env tys+                                    in args `seqList` TyConApp tycon args+tidyType env (AppTy fun arg)      = (AppTy $! (tidyType env fun)) $! (tidyType env arg)+tidyType env (FunTy fun arg)      = (FunTy $! (tidyType env fun)) $! (tidyType env arg)+tidyType env (ty@(ForAllTy{}))    = mkForAllTys' (zip tvs' vis) $! tidyType env' body_ty+  where+    (tvs, vis, body_ty) = splitForAllTys' ty+    (env', tvs') = tidyTyCoVarBndrs env tvs+tidyType env (CastTy ty co)       = (CastTy $! tidyType env ty) $! (tidyCo env co)+tidyType env (CoercionTy co)      = CoercionTy $! (tidyCo env co)+++-- The following two functions differ from mkForAllTys and splitForAllTys in that+-- they expect/preserve the ArgFlag argument. Thes belong to types/Type.hs, but+-- how should they be named?+mkForAllTys' :: [(TyVar, ArgFlag)] -> Type -> Type+mkForAllTys' tvvs ty = foldr strictMkForAllTy ty tvvs+  where+    strictMkForAllTy (tv,vis) ty = (ForAllTy $! ((TvBndr $! tv) $! vis)) $! ty++splitForAllTys' :: Type -> ([TyVar], [ArgFlag], Type)+splitForAllTys' ty = go ty [] []+  where+    go (ForAllTy (TvBndr tv vis) ty) tvs viss = go ty (tv:tvs) (vis:viss)+    go ty                            tvs viss = (reverse tvs, reverse viss, ty)+++---------------+-- | Grabs the free type variables, tidies them+-- and then uses 'tidyType' to work over the type itself+tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])+tidyOpenTypes env tys+  = (env', tidyTypes (trimmed_occ_env, var_env) tys)+  where+    (env'@(_, var_env), tvs') = tidyOpenTyCoVars env $+                                tyCoVarsOfTypesWellScoped tys+    trimmed_occ_env = initTidyOccEnv (map getOccName tvs')+      -- The idea here was that we restrict the new TidyEnv to the+      -- _free_ vars of the types, so that we don't gratuitously rename+      -- the _bound_ variables of the types.++---------------+tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)+tidyOpenType env ty = let (env', [ty']) = tidyOpenTypes env [ty] in+                      (env', ty')++---------------+-- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment)+tidyTopType :: Type -> Type+tidyTopType ty = tidyType emptyTidyEnv ty++---------------+tidyOpenKind :: TidyEnv -> Kind -> (TidyEnv, Kind)+tidyOpenKind = tidyOpenType++tidyKind :: TidyEnv -> Kind -> Kind+tidyKind = tidyType++----------------+tidyCo :: TidyEnv -> Coercion -> Coercion+tidyCo env@(_, subst) co+  = go co+  where+    go (Refl r ty)           = Refl r (tidyType env ty)+    go (TyConAppCo r tc cos) = let args = map go cos+                               in args `seqList` TyConAppCo r tc args+    go (AppCo co1 co2)       = (AppCo $! go co1) $! go co2+    go (ForAllCo tv h co)    = ((ForAllCo $! tvp) $! (go h)) $! (tidyCo envp co)+                               where (envp, tvp) = tidyTyCoVarBndr env tv+            -- the case above duplicates a bit of work in tidying h and the kind+            -- of tv. But the alternative is to use coercionKind, which seems worse.+    go (FunCo r co1 co2)     = (FunCo r $! go co1) $! go co2+    go (CoVarCo cv)          = case lookupVarEnv subst cv of+                                 Nothing  -> CoVarCo cv+                                 Just cv' -> CoVarCo cv'+    go (AxiomInstCo con ind cos) = let args = map go cos+                               in  args `seqList` AxiomInstCo con ind args+    go (UnivCo p r t1 t2)    = (((UnivCo $! (go_prov p)) $! r) $!+                                tidyType env t1) $! tidyType env t2+    go (SymCo co)            = SymCo $! go co+    go (TransCo co1 co2)     = (TransCo $! go co1) $! go co2+    go (NthCo d co)          = NthCo d $! go co+    go (LRCo lr co)          = LRCo lr $! go co+    go (InstCo co ty)        = (InstCo $! go co) $! go ty+    go (CoherenceCo co1 co2) = (CoherenceCo $! go co1) $! go co2+    go (KindCo co)           = KindCo $! go co+    go (SubCo co)            = SubCo $! go co+    go (AxiomRuleCo ax cos)  = let cos1 = tidyCos env cos+                               in cos1 `seqList` AxiomRuleCo ax cos1++    go_prov UnsafeCoerceProv    = UnsafeCoerceProv+    go_prov (PhantomProv co)    = PhantomProv (go co)+    go_prov (ProofIrrelProv co) = ProofIrrelProv (go co)+    go_prov p@(PluginProv _)    = p+    go_prov p@(HoleProv _)      = p++tidyCos :: TidyEnv -> [Coercion] -> [Coercion]+tidyCos env = map (tidyCo env)+++{- *********************************************************************+*                                                                      *+                   typeSize, coercionSize+*                                                                      *+********************************************************************* -}++-- NB: We put typeSize/coercionSize here because they are mutually+--     recursive, and have the CPR property.  If we have mutual+--     recursion across a hi-boot file, we don't get the CPR property+--     and these functions allocate a tremendous amount of rubbish.+--     It's not critical (because typeSize is really only used in+--     debug mode, but I tripped over an example (T5642) in which+--     typeSize was one of the biggest single allocators in all of GHC.+--     And it's easy to fix, so I did.++-- NB: typeSize does not respect `eqType`, in that two types that+--     are `eqType` may return different sizes. This is OK, because this+--     function is used only in reporting, not decision-making.++typeSize :: Type -> Int+typeSize (LitTy {})                 = 1+typeSize (TyVarTy {})               = 1+typeSize (AppTy t1 t2)              = typeSize t1 + typeSize t2+typeSize (FunTy t1 t2)              = typeSize t1 + typeSize t2+typeSize (ForAllTy (TvBndr tv _) t) = typeSize (tyVarKind tv) + typeSize t+typeSize (TyConApp _ ts)            = 1 + sum (map typeSize ts)+typeSize (CastTy ty co)             = typeSize ty + coercionSize co+typeSize (CoercionTy co)            = coercionSize co++coercionSize :: Coercion -> Int+coercionSize (Refl _ ty)         = typeSize ty+coercionSize (TyConAppCo _ _ args) = 1 + sum (map coercionSize args)+coercionSize (AppCo co arg)      = coercionSize co + coercionSize arg+coercionSize (ForAllCo _ h co)   = 1 + coercionSize co + coercionSize h+coercionSize (FunCo _ co1 co2)   = 1 + coercionSize co1 + coercionSize co2+coercionSize (CoVarCo _)         = 1+coercionSize (AxiomInstCo _ _ args) = 1 + sum (map coercionSize args)+coercionSize (UnivCo p _ t1 t2)  = 1 + provSize p + typeSize t1 + typeSize t2+coercionSize (SymCo co)          = 1 + coercionSize co+coercionSize (TransCo co1 co2)   = 1 + coercionSize co1 + coercionSize co2+coercionSize (NthCo _ co)        = 1 + coercionSize co+coercionSize (LRCo  _ co)        = 1 + coercionSize co+coercionSize (InstCo co arg)     = 1 + coercionSize co + coercionSize arg+coercionSize (CoherenceCo c1 c2) = 1 + coercionSize c1 + coercionSize c2+coercionSize (KindCo co)         = 1 + coercionSize co+coercionSize (SubCo co)          = 1 + coercionSize co+coercionSize (AxiomRuleCo _ cs)  = 1 + sum (map coercionSize cs)++provSize :: UnivCoProvenance -> Int+provSize UnsafeCoerceProv    = 1+provSize (PhantomProv co)    = 1 + coercionSize co+provSize (ProofIrrelProv co) = 1 + coercionSize co+provSize (PluginProv _)      = 1+provSize (HoleProv h)        = pprPanic "provSize hits a hole" (ppr h)
+ types/TyCoRep.hs-boot view
@@ -0,0 +1,23 @@+module TyCoRep where++import Outputable ( SDoc )+import Data.Data  ( Data )++data Type+data TyThing+data Coercion+data UnivCoProvenance+data TCvSubst+data TyLit+data TyBinder++type PredType = Type+type Kind = Type+type ThetaType = [PredType]++pprKind :: Kind -> SDoc+pprType :: Type -> SDoc++instance Data Type+  -- To support Data instances in CoAxiom+
+ types/TyCon.hs view
@@ -0,0 +1,2433 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++The @TyCon@ datatype+-}++{-# LANGUAGE CPP, FlexibleInstances #-}++module TyCon(+        -- * Main TyCon data types+        TyCon, AlgTyConRhs(..), visibleDataCons,+        AlgTyConFlav(..), isNoParent,+        FamTyConFlav(..), Role(..), Injectivity(..),+        RuntimeRepInfo(..),++        -- * TyConBinder+        TyConBinder, TyConBndrVis(..),+        mkNamedTyConBinder, mkNamedTyConBinders,+        mkAnonTyConBinder, mkAnonTyConBinders,+        tyConBinderArgFlag, isNamedTyConBinder,+        isVisibleTyConBinder, isInvisibleTyConBinder,++        -- ** Field labels+        tyConFieldLabels, lookupTyConFieldLabel,++        -- ** Constructing TyCons+        mkAlgTyCon,+        mkClassTyCon,+        mkFunTyCon,+        mkPrimTyCon,+        mkKindTyCon,+        mkLiftedPrimTyCon,+        mkTupleTyCon,+        mkSumTyCon,+        mkSynonymTyCon,+        mkFamilyTyCon,+        mkPromotedDataCon,+        mkTcTyCon,++        -- ** Predicates on TyCons+        isAlgTyCon, isVanillaAlgTyCon,+        isClassTyCon, isFamInstTyCon,+        isFunTyCon,+        isPrimTyCon,+        isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon,+        isUnboxedSumTyCon, isPromotedTupleTyCon,+        isTypeSynonymTyCon,+        mightBeUnsaturatedTyCon,+        isPromotedDataCon, isPromotedDataCon_maybe,+        isKindTyCon, isLiftedTypeKindTyConName,+        isTauTyCon, isFamFreeTyCon,++        isDataTyCon, isProductTyCon, isDataProductTyCon_maybe,+        isDataSumTyCon_maybe,+        isEnumerationTyCon,+        isNewTyCon, isAbstractTyCon,+        isFamilyTyCon, isOpenFamilyTyCon,+        isTypeFamilyTyCon, isDataFamilyTyCon,+        isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe,+        familyTyConInjectivityInfo,+        isBuiltInSynFamTyCon_maybe,+        isUnliftedTyCon,+        isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon, isGenInjAlgRhs,+        isTyConAssoc, tyConAssoc_maybe,+        isImplicitTyCon,+        isTyConWithSrcDataCons,+        isTcTyCon, isTcLevPoly,++        -- ** Extracting information out of TyCons+        tyConName,+        tyConSkolem,+        tyConKind,+        tyConUnique,+        tyConTyVars,+        tyConCType, tyConCType_maybe,+        tyConDataCons, tyConDataCons_maybe,+        tyConSingleDataCon_maybe, tyConSingleDataCon,+        tyConSingleAlgDataCon_maybe,+        tyConFamilySize,+        tyConStupidTheta,+        tyConArity,+        tyConRoles,+        tyConFlavour,+        tyConTuple_maybe, tyConClass_maybe, tyConATs,+        tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe,+        tyConFamilyResVar_maybe,+        synTyConDefn_maybe, synTyConRhs_maybe,+        famTyConFlav_maybe, famTcResVar,+        algTyConRhs,+        newTyConRhs, newTyConEtadArity, newTyConEtadRhs,+        unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe,+        newTyConDataCon_maybe,+        algTcFields,+        tyConRuntimeRepInfo,+        tyConBinders, tyConResKind,+        tcTyConScopedTyVars,++        -- ** Manipulating TyCons+        expandSynTyCon_maybe,+        makeRecoveryTyCon,+        newTyConCo, newTyConCo_maybe,+        pprPromotionQuote, mkTyConKind,++        -- * Runtime type representation+        TyConRepName, tyConRepName_maybe,+        mkPrelTyConRepName,+        tyConRepModOcc,++        -- * Primitive representations of Types+        PrimRep(..), PrimElemRep(..),+        isVoidRep, isGcPtrRep,+        primRepSizeW, primElemRepSizeB,+        primRepIsFloat,++        -- * Recursion breaking+        RecTcChecker, initRecTc, checkRecTc++) where++#include "HsVersions.h"++import {-# SOURCE #-} TyCoRep    ( Kind, Type, PredType, pprType )+import {-# SOURCE #-} TysWiredIn ( runtimeRepTyCon, constraintKind+                                 , vecCountTyCon, vecElemTyCon, liftedTypeKind+                                 , mkFunKind, mkForAllKind )+import {-# SOURCE #-} DataCon    ( DataCon, dataConExTyVars, dataConFieldLabels+                                 , dataConTyCon )++import Binary+import Var+import Class+import BasicTypes+import DynFlags+import ForeignCall+import Name+import NameEnv+import CoAxiom+import PrelNames+import Maybes+import Outputable+import FastStringEnv+import FieldLabel+import Constants+import Util+import Unique( tyConRepNameUnique, dataConRepNameUnique )+import UniqSet+import Module++import qualified Data.Data as Data++{-+-----------------------------------------------+        Notes about type families+-----------------------------------------------++Note [Type synonym families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* Type synonym families, also known as "type functions", map directly+  onto the type functions in FC:++        type family F a :: *+        type instance F Int = Bool+        ..etc...++* Reply "yes" to isTypeFamilyTyCon, and isFamilyTyCon++* From the user's point of view (F Int) and Bool are simply+  equivalent types.++* A Haskell 98 type synonym is a degenerate form of a type synonym+  family.++* Type functions can't appear in the LHS of a type function:+        type instance F (F Int) = ...   -- BAD!++* Translation of type family decl:+        type family F a :: *+  translates to+    a FamilyTyCon 'F', whose FamTyConFlav is OpenSynFamilyTyCon++        type family G a :: * where+          G Int = Bool+          G Bool = Char+          G a = ()+  translates to+    a FamilyTyCon 'G', whose FamTyConFlav is ClosedSynFamilyTyCon, with the+    appropriate CoAxiom representing the equations++We also support injective type families -- see Note [Injective type families]++Note [Data type families]+~~~~~~~~~~~~~~~~~~~~~~~~~+See also Note [Wrappers for data instance tycons] in MkId.hs++* Data type families are declared thus+        data family T a :: *+        data instance T Int = T1 | T2 Bool++  Here T is the "family TyCon".++* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon++* The user does not see any "equivalent types" as he did with type+  synonym families.  He just sees constructors with types+        T1 :: T Int+        T2 :: Bool -> T Int++* Here's the FC version of the above declarations:++        data T a+        data R:TInt = T1 | T2 Bool+        axiom ax_ti : T Int ~R R:TInt++  Note that this is a *representational* coercion+  The R:TInt is the "representation TyCons".+  It has an AlgTyConFlav of+        DataFamInstTyCon T [Int] ax_ti++* The axiom ax_ti may be eta-reduced; see+  Note [Eta reduction for data family axioms] in TcInstDcls++* The data constructor T2 has a wrapper (which is what the+  source-level "T2" invokes):++        $WT2 :: Bool -> T Int+        $WT2 b = T2 b `cast` sym ax_ti++* A data instance can declare a fully-fledged GADT:++        data instance T (a,b) where+          X1 :: T (Int,Bool)+          X2 :: a -> b -> T (a,b)++  Here's the FC version of the above declaration:++        data R:TPair a where+          X1 :: R:TPair Int Bool+          X2 :: a -> b -> R:TPair a b+        axiom ax_pr :: T (a,b)  ~R  R:TPair a b++        $WX1 :: forall a b. a -> b -> T (a,b)+        $WX1 a b (x::a) (y::b) = X2 a b x y `cast` sym (ax_pr a b)++  The R:TPair are the "representation TyCons".+  We have a bit of work to do, to unpick the result types of the+  data instance declaration for T (a,b), to get the result type in the+  representation; e.g.  T (a,b) --> R:TPair a b++  The representation TyCon R:TList, has an AlgTyConFlav of++        DataFamInstTyCon T [(a,b)] ax_pr++* Notice that T is NOT translated to a FC type function; it just+  becomes a "data type" with no constructors, which can be coerced inot+  into R:TInt, R:TPair by the axioms.  These axioms+  axioms come into play when (and *only* when) you+        - use a data constructor+        - do pattern matching+  Rather like newtype, in fact++  As a result++  - T behaves just like a data type so far as decomposition is concerned++  - (T Int) is not implicitly converted to R:TInt during type inference.+    Indeed the latter type is unknown to the programmer.++  - There *is* an instance for (T Int) in the type-family instance+    environment, but it is only used for overlap checking++  - It's fine to have T in the LHS of a type function:+    type instance F (T a) = [a]++  It was this last point that confused me!  The big thing is that you+  should not think of a data family T as a *type function* at all, not+  even an injective one!  We can't allow even injective type functions+  on the LHS of a type function:+        type family injective G a :: *+        type instance F (G Int) = Bool+  is no good, even if G is injective, because consider+        type instance G Int = Bool+        type instance F Bool = Char++  So a data type family is not an injective type function. It's just a+  data type with some axioms that connect it to other data types.++* The tyConTyVars of the representation tycon are the tyvars that the+  user wrote in the patterns. This is important in TcDeriv, where we+  bring these tyvars into scope before type-checking the deriving+  clause. This fact is arranged for in TcInstDecls.tcDataFamInstDecl.++Note [Associated families and their parent class]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+*Associated* families are just like *non-associated* families, except+that they have a famTcParent field of (Just cls), which identifies the+parent class.++However there is an important sharing relationship between+  * the tyConTyVars of the parent Class+  * the tyConTyvars of the associated TyCon++   class C a b where+     data T p a+     type F a q b++Here the 'a' and 'b' are shared with the 'Class'; that is, they have+the same Unique.++This is important. In an instance declaration we expect+  * all the shared variables to be instantiated the same way+  * the non-shared variables of the associated type should not+    be instantiated at all++  instance C [x] (Tree y) where+     data T p [x] = T1 x | T2 p+     type F [x] q (Tree y) = (x,y,q)++Note [TyCon Role signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Every tycon has a role signature, assigning a role to each of the tyConTyVars+(or of equal length to the tyConArity, if there are no tyConTyVars). An+example demonstrates these best: say we have a tycon T, with parameters a at+nominal, b at representational, and c at phantom. Then, to prove+representational equality between T a1 b1 c1 and T a2 b2 c2, we need to have+nominal equality between a1 and a2, representational equality between b1 and+b2, and nothing in particular (i.e., phantom equality) between c1 and c2. This+might happen, say, with the following declaration:++  data T a b c where+    MkT :: b -> T Int b c++Data and class tycons have their roles inferred (see inferRoles in TcTyDecls),+as do vanilla synonym tycons. Family tycons have all parameters at role N,+though it is conceivable that we could relax this restriction. (->)'s and+tuples' parameters are at role R. Each primitive tycon declares its roles;+it's worth noting that (~#)'s parameters are at role N. Promoted data+constructors' type arguments are at role R. All kind arguments are at role+N.++Note [Unboxed tuple RuntimeRep vars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The contents of an unboxed tuple may have any representation. Accordingly,+the kind of the unboxed tuple constructor is runtime-representation+polymorphic. For example,++   (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep). TYPE q -> TYPE r -> #++These extra tyvars (v and w) cause some delicate processing around tuples,+where we used to be able to assume that the tycon arity and the+datacon arity were the same.++Note [Injective type families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We allow injectivity annotations for type families (both open and closed):++  type family F (a :: k) (b :: k) = r | r -> a+  type family G a b = res | res -> a b where ...++Injectivity information is stored in the `famTcInj` field of `FamilyTyCon`.+`famTcInj` maybe stores a list of Bools, where each entry corresponds to a+single element of `tyConTyVars` (both lists should have identical length). If no+injectivity annotation was provided `famTcInj` is Nothing. From this follows an+invariant that if `famTcInj` is a Just then at least one element in the list+must be True.++See also:+ * [Injectivity annotation] in HsDecls+ * [Renaming injectivity annotation] in RnSource+ * [Verifying injectivity annotation] in FamInstEnv+ * [Type inference for type families with injectivity] in TcInteract++************************************************************************+*                                                                      *+                    TyConBinder+*                                                                      *+************************************************************************+-}++type TyConBinder = TyVarBndr TyVar TyConBndrVis++data TyConBndrVis+  = NamedTCB ArgFlag+  | AnonTCB++mkAnonTyConBinder :: TyVar -> TyConBinder+mkAnonTyConBinder tv = TvBndr tv AnonTCB++mkAnonTyConBinders :: [TyVar] -> [TyConBinder]+mkAnonTyConBinders tvs = map mkAnonTyConBinder tvs++mkNamedTyConBinder :: ArgFlag -> TyVar -> TyConBinder+-- The odd argument order supports currying+mkNamedTyConBinder vis tv = TvBndr tv (NamedTCB vis)++mkNamedTyConBinders :: ArgFlag -> [TyVar] -> [TyConBinder]+-- The odd argument order supports currying+mkNamedTyConBinders vis tvs = map (mkNamedTyConBinder vis) tvs++tyConBinderArgFlag :: TyConBinder -> ArgFlag+tyConBinderArgFlag (TvBndr _ (NamedTCB vis)) = vis+tyConBinderArgFlag (TvBndr _ AnonTCB)        = Required++isNamedTyConBinder :: TyConBinder -> Bool+isNamedTyConBinder (TvBndr _ (NamedTCB {})) = True+isNamedTyConBinder _                        = False++isVisibleTyConBinder :: TyVarBndr tv TyConBndrVis -> Bool+-- Works for IfaceTyConBinder too+isVisibleTyConBinder (TvBndr _ (NamedTCB vis)) = isVisibleArgFlag vis+isVisibleTyConBinder (TvBndr _ AnonTCB)        = True++isInvisibleTyConBinder :: TyVarBndr tv TyConBndrVis -> Bool+-- Works for IfaceTyConBinder too+isInvisibleTyConBinder tcb = not (isVisibleTyConBinder tcb)++mkTyConKind :: [TyConBinder] -> Kind -> Kind+mkTyConKind bndrs res_kind = foldr mk res_kind bndrs+  where+    mk :: TyConBinder -> Kind -> Kind+    mk (TvBndr tv AnonTCB)        k = mkFunKind (tyVarKind tv) k+    mk (TvBndr tv (NamedTCB vis)) k = mkForAllKind tv vis k++{- Note [The binders/kind/arity fields of a TyCon]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+All TyCons have this group of fields+  tyConBinders :: [TyConBinder]+  tyConResKind :: Kind+  tyConTyVars  :: [TyVra] -- Cached = binderVars tyConBinders+  tyConKind    :: Kind    -- Cached = mkTyConKind tyConBinders tyConResKind+  tyConArity   :: Arity   -- Cached = length tyConBinders++They fit together like so:++* tyConBinders gives the telescope of type variables on the LHS of the+  type declaration.  For example:++    type App a (b :: k) = a b++  tyConBinders = [ TvBndr (k::*)   (NamedTCB Inferred)+                 , TvBndr (a:k->*) AnonTCB+                 , TvBndr (b:k)    AnonTCB ]++  Note that that are three binders here, including the+  kind variable k.++  See Note [TyBinders and ArgFlags] in TyCoRep for what+  the visibility flag means.++* Each TyConBinder tyConBinders has a TyVar, and that TyVar may+  scope over some other part of the TyCon's definition. Eg+      type T a = a->a+  we have+      tyConBinders = [ TvBndr (a:*) AnonTCB ]+      synTcRhs     = a->a+  So the 'a' scopes over the synTcRhs++* From the tyConBinders and tyConResKind we can get the tyConKind+  E.g for our App example:+      App :: forall k. (k->*) -> k -> *++  We get a 'forall' in the kind for each NamedTCB, and an arrow+  for each AnonTCB++  tyConKind is the full kind of the TyCon, not just the result kind++* tyConArity is the arguments this TyCon must be applied to, to be+  considered saturated.  Here we mean "applied to in the actual Type",+  not surface syntax; i.e. including implicit kind variables.+  So it's just (length tyConBinders)+-}++instance Outputable tv => Outputable (TyVarBndr tv TyConBndrVis) where+  ppr (TvBndr v AnonTCB)              = ppr v+  ppr (TvBndr v (NamedTCB Required))  = ppr v+  ppr (TvBndr v (NamedTCB Specified)) = char '@' <> ppr v+  ppr (TvBndr v (NamedTCB Inferred))  = braces (ppr v)++instance Binary TyConBndrVis where+  put_ bh AnonTCB        = putByte bh 0+  put_ bh (NamedTCB vis) = do { putByte bh 1; put_ bh vis }++  get bh = do { h <- getByte bh+              ; case h of+                  0 -> return AnonTCB+                  _ -> do { vis <- get bh; return (NamedTCB vis) } }+++{- *********************************************************************+*                                                                      *+               The TyCon type+*                                                                      *+************************************************************************+-}+++-- | TyCons represent type constructors. Type constructors are introduced by+-- things such as:+--+-- 1) Data declarations: @data Foo = ...@ creates the @Foo@ type constructor of+--    kind @*@+--+-- 2) Type synonyms: @type Foo = ...@ creates the @Foo@ type constructor+--+-- 3) Newtypes: @newtype Foo a = MkFoo ...@ creates the @Foo@ type constructor+--    of kind @* -> *@+--+-- 4) Class declarations: @class Foo where@ creates the @Foo@ type constructor+--    of kind @*@+--+-- This data type also encodes a number of primitive, built in type constructors+-- such as those for function and tuple types.++-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism] in coreSyn/CoreLint.hs+data TyCon+  = -- | The function type constructor, @(->)@+    FunTyCon {+        tyConUnique :: Unique,   -- ^ A Unique of this TyCon. Invariant:+                                 -- identical to Unique of Name stored in+                                 -- tyConName field.++        tyConName   :: Name,     -- ^ Name of the constructor++        -- See Note [The binders/kind/arity fields of a TyCon]+        tyConBinders :: [TyConBinder], -- ^ Full binders+        tyConResKind :: Kind,             -- ^ Result kind+        tyConKind    :: Kind,             -- ^ Kind of this TyCon+        tyConArity   :: Arity,            -- ^ Arity++        tcRepName :: TyConRepName+    }++  -- | Algebraic data types, from+  --     - @data@ declarations+  --     - @newtype@ declarations+  --     - data instance declarations+  --     - type instance declarations+  --     - the TyCon generated by a class declaration+  --     - boxed tuples+  --     - unboxed tuples+  --     - constraint tuples+  -- All these constructors are lifted and boxed except unboxed tuples+  -- which should have an 'UnboxedAlgTyCon' parent.+  -- Data/newtype/type /families/ are handled by 'FamilyTyCon'.+  -- See 'AlgTyConRhs' for more information.+  | AlgTyCon {+        tyConUnique  :: Unique,  -- ^ A Unique of this TyCon. Invariant:+                                 -- identical to Unique of Name stored in+                                 -- tyConName field.++        tyConName    :: Name,    -- ^ Name of the constructor++        -- See Note [The binders/kind/arity fields of a TyCon]+        tyConBinders :: [TyConBinder], -- ^ Full binders+        tyConTyVars  :: [TyVar],          -- ^ TyVar binders+        tyConResKind :: Kind,             -- ^ Result kind+        tyConKind    :: Kind,             -- ^ Kind of this TyCon+        tyConArity   :: Arity,            -- ^ Arity++              -- The tyConTyVars scope over:+              --+              -- 1. The 'algTcStupidTheta'+              -- 2. The cached types in algTyConRhs.NewTyCon+              -- 3. The family instance types if present+              --+              -- Note that it does /not/ scope over the data+              -- constructors.++        tcRoles      :: [Role],  -- ^ The role for each type variable+                                 -- This list has length = tyConArity+                                 -- See also Note [TyCon Role signatures]++        tyConCType   :: Maybe CType,-- ^ The C type that should be used+                                    -- for this type when using the FFI+                                    -- and CAPI++        algTcGadtSyntax  :: Bool,   -- ^ Was the data type declared with GADT+                                    -- syntax?  If so, that doesn't mean it's a+                                    -- true GADT; only that the "where" form+                                    -- was used.  This field is used only to+                                    -- guide pretty-printing++        algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data+                                        -- type (always empty for GADTs).  A+                                        -- \"stupid theta\" is the context to+                                        -- the left of an algebraic type+                                        -- declaration, e.g. @Eq a@ in the+                                        -- declaration @data Eq a => T a ...@.++        algTcRhs    :: AlgTyConRhs, -- ^ Contains information about the+                                    -- data constructors of the algebraic type++        algTcFields :: FieldLabelEnv, -- ^ Maps a label to information+                                      -- about the field++        algTcParent :: AlgTyConFlav -- ^ Gives the class or family declaration+                                       -- 'TyCon' for derived 'TyCon's representing+                                       -- class or family instances, respectively.++    }++  -- | Represents type synonyms+  | SynonymTyCon {+        tyConUnique  :: Unique,  -- ^ A Unique of this TyCon. Invariant:+                                 -- identical to Unique of Name stored in+                                 -- tyConName field.++        tyConName    :: Name,    -- ^ Name of the constructor++        -- See Note [The binders/kind/arity fields of a TyCon]+        tyConBinders :: [TyConBinder], -- ^ Full binders+        tyConTyVars  :: [TyVar],          -- ^ TyVar binders+        tyConResKind :: Kind,             -- ^ Result kind+        tyConKind    :: Kind,             -- ^ Kind of this TyCon+        tyConArity   :: Arity,            -- ^ Arity+             -- tyConTyVars scope over: synTcRhs++        tcRoles      :: [Role],  -- ^ The role for each type variable+                                 -- This list has length = tyConArity+                                 -- See also Note [TyCon Role signatures]++        synTcRhs     :: Type,    -- ^ Contains information about the expansion+                                 -- of the synonym++        synIsTau     :: Bool,   -- True <=> the RHS of this synonym does not+                                 --          have any foralls, after expanding any+                                 --          nested synonyms+        synIsFamFree  :: Bool    -- True <=> the RHS of this synonym does not mention+                                 --          any type synonym families (data families+                                 --          are fine), again after expanding any+                                 --          nested synonyms+    }++  -- | Represents families (both type and data)+  -- Argument roles are all Nominal+  | FamilyTyCon {+        tyConUnique  :: Unique,  -- ^ A Unique of this TyCon. Invariant:+                                 -- identical to Unique of Name stored in+                                 -- tyConName field.++        tyConName    :: Name,    -- ^ Name of the constructor++        -- See Note [The binders/kind/arity fields of a TyCon]+        tyConBinders :: [TyConBinder], -- ^ Full binders+        tyConTyVars  :: [TyVar],          -- ^ TyVar binders+        tyConResKind :: Kind,             -- ^ Result kind+        tyConKind    :: Kind,             -- ^ Kind of this TyCon+        tyConArity   :: Arity,            -- ^ Arity+            -- tyConTyVars connect an associated family TyCon+            -- with its parent class; see TcValidity.checkConsistentFamInst++        famTcResVar  :: Maybe Name,   -- ^ Name of result type variable, used+                                      -- for pretty-printing with --show-iface+                                      -- and for reifying TyCon in Template+                                      -- Haskell++        famTcFlav    :: FamTyConFlav, -- ^ Type family flavour: open, closed,+                                      -- abstract, built-in. See comments for+                                      -- FamTyConFlav++        famTcParent  :: Maybe Class,  -- ^ For *associated* type/data families+                                      -- The class in whose declaration the family is declared+                                      -- See Note [Associated families and their parent class]++        famTcInj     :: Injectivity   -- ^ is this a type family injective in+                                      -- its type variables? Nothing if no+                                      -- injectivity annotation was given+    }++  -- | Primitive types; cannot be defined in Haskell. This includes+  -- the usual suspects (such as @Int#@) as well as foreign-imported+  -- types and kinds (@*@, @#@, and @?@)+  | PrimTyCon {+        tyConUnique   :: Unique, -- ^ A Unique of this TyCon. Invariant:+                                 -- identical to Unique of Name stored in+                                 -- tyConName field.++        tyConName     :: Name,   -- ^ Name of the constructor++        -- See Note [The binders/kind/arity fields of a TyCon]+        tyConBinders :: [TyConBinder], -- ^ Full binders+        tyConResKind :: Kind,             -- ^ Result kind+        tyConKind    :: Kind,             -- ^ Kind of this TyCon+        tyConArity   :: Arity,            -- ^ Arity++        tcRoles       :: [Role], -- ^ The role for each type variable+                                 -- This list has length = tyConArity+                                 -- See also Note [TyCon Role signatures]++        isUnlifted   :: Bool,    -- ^ Most primitive tycons are unlifted (may+                                 -- not contain bottom) but other are lifted,+                                 -- e.g. @RealWorld@+                                 -- Only relevant if tyConKind = *++        primRepName :: Maybe TyConRepName   -- Only relevant for kind TyCons+                                            -- i.e, *, #, ?+    }++  -- | Represents promoted data constructor.+  | PromotedDataCon {          -- See Note [Promoted data constructors]+        tyConUnique  :: Unique,     -- ^ Same Unique as the data constructor+        tyConName    :: Name,       -- ^ Same Name as the data constructor++        -- See Note [The binders/kind/arity fields of a TyCon]+        tyConBinders :: [TyConBinder], -- ^ Full binders+        tyConResKind :: Kind,             -- ^ Result kind+        tyConKind    :: Kind,             -- ^ Kind of this TyCon+        tyConArity   :: Arity,            -- ^ Arity++        tcRoles       :: [Role],    -- ^ Roles: N for kind vars, R for type vars+        dataCon       :: DataCon,   -- ^ Corresponding data constructor+        tcRepName     :: TyConRepName,+        promDcRepInfo :: RuntimeRepInfo  -- ^ See comments with 'RuntimeRepInfo'+    }++  -- | These exist only during a recursive type/class type-checking knot.+  | TcTyCon {+        tyConUnique :: Unique,+        tyConName   :: Name,+        tyConUnsat  :: Bool,  -- ^ can this tycon be unsaturated?++        -- See Note [The binders/kind/arity fields of a TyCon]+        tyConBinders :: [TyConBinder], -- ^ Full binders+        tyConTyVars  :: [TyVar],          -- ^ TyVar binders+        tyConResKind :: Kind,             -- ^ Result kind+        tyConKind    :: Kind,             -- ^ Kind of this TyCon+        tyConArity   :: Arity,            -- ^ Arity++        tcTyConScopedTyVars :: [TyVar] -- ^ Scoped tyvars over the+                                       -- tycon's body. See Note [TcTyCon]+      }++-- | Represents right-hand-sides of 'TyCon's for algebraic types+data AlgTyConRhs++    -- | Says that we know nothing about this data type, except that+    -- it's represented by a pointer.  Used when we export a data type+    -- abstractly into an .hi file.+  = AbstractTyCon++    -- | Information about those 'TyCon's derived from a @data@+    -- declaration. This includes data types with no constructors at+    -- all.+  | DataTyCon {+        data_cons :: [DataCon],+                          -- ^ The data type constructors; can be empty if the+                          --   user declares the type to have no constructors+                          --+                          -- INVARIANT: Kept in order of increasing 'DataCon'+                          -- tag (see the tag assignment in DataCon.mkDataCon)++        is_enum :: Bool   -- ^ Cached value: is this an enumeration type?+                          --   See Note [Enumeration types]+    }++  | TupleTyCon {                   -- A boxed, unboxed, or constraint tuple+        data_con :: DataCon,       -- NB: it can be an *unboxed* tuple+        tup_sort :: TupleSort      -- ^ Is this a boxed, unboxed or constraint+                                   -- tuple?+    }++  | SumTyCon {+        data_cons :: [DataCon]+    }++  -- | Information about those 'TyCon's derived from a @newtype@ declaration+  | NewTyCon {+        data_con :: DataCon,    -- ^ The unique constructor for the @newtype@.+                                --   It has no existentials++        nt_rhs :: Type,         -- ^ Cached value: the argument type of the+                                -- constructor, which is just the representation+                                -- type of the 'TyCon' (remember that @newtype@s+                                -- do not exist at runtime so need a different+                                -- representation type).+                                --+                                -- The free 'TyVar's of this type are the+                                -- 'tyConTyVars' from the corresponding 'TyCon'++        nt_etad_rhs :: ([TyVar], Type),+                        -- ^ Same as the 'nt_rhs', but this time eta-reduced.+                        -- Hence the list of 'TyVar's in this field may be+                        -- shorter than the declared arity of the 'TyCon'.++                        -- See Note [Newtype eta]+        nt_co :: CoAxiom Unbranched+                             -- The axiom coercion that creates the @newtype@+                             -- from the representation 'Type'.++                             -- See Note [Newtype coercions]+                             -- Invariant: arity = #tvs in nt_etad_rhs;+                             -- See Note [Newtype eta]+                             -- Watch out!  If any newtypes become transparent+                             -- again check Trac #1072.+    }++-- | Some promoted datacons signify extra info relevant to GHC. For example,+-- the @IntRep@ constructor of @RuntimeRep@ corresponds to the 'IntRep'+-- constructor of 'PrimRep'. This data structure allows us to store this+-- information right in the 'TyCon'. The other approach would be to look+-- up things like @RuntimeRep@'s @PrimRep@ by known-key every time.+data RuntimeRepInfo+  = NoRRI       -- ^ an ordinary promoted data con+  | RuntimeRep ([Type] -> [PrimRep])+      -- ^ A constructor of @RuntimeRep@. The argument to the function should+      -- be the list of arguments to the promoted datacon.+  | VecCount Int         -- ^ A constructor of @VecCount@+  | VecElem PrimElemRep  -- ^ A constructor of @VecElem@++-- | Extract those 'DataCon's that we are able to learn about.  Note+-- that visibility in this sense does not correspond to visibility in+-- the context of any particular user program!+visibleDataCons :: AlgTyConRhs -> [DataCon]+visibleDataCons (AbstractTyCon {})            = []+visibleDataCons (DataTyCon{ data_cons = cs }) = cs+visibleDataCons (NewTyCon{ data_con = c })    = [c]+visibleDataCons (TupleTyCon{ data_con = c })  = [c]+visibleDataCons (SumTyCon{ data_cons = cs })  = cs++-- ^ Both type classes as well as family instances imply implicit+-- type constructors.  These implicit type constructors refer to their parent+-- structure (ie, the class or family from which they derive) using a type of+-- the following form.+data AlgTyConFlav+  = -- | An ordinary type constructor has no parent.+    VanillaAlgTyCon+       TyConRepName++    -- | An unboxed type constructor. The TyConRepName is a Maybe since we+    -- currently don't allow unboxed sums to be Typeable since there are too+    -- many of them. See #13276.+  | UnboxedAlgTyCon+       (Maybe TyConRepName)++  -- | Type constructors representing a class dictionary.+  -- See Note [ATyCon for classes] in TyCoRep+  | ClassTyCon+        Class           -- INVARIANT: the classTyCon of this Class is the+                        -- current tycon+        TyConRepName++  -- | Type constructors representing an *instance* of a *data* family.+  -- Parameters:+  --+  --  1) The type family in question+  --+  --  2) Instance types; free variables are the 'tyConTyVars'+  --  of the current 'TyCon' (not the family one). INVARIANT:+  --  the number of types matches the arity of the family 'TyCon'+  --+  --  3) A 'CoTyCon' identifying the representation+  --  type with the type instance family+  | DataFamInstTyCon          -- See Note [Data type families]+        (CoAxiom Unbranched)  -- The coercion axiom.+               -- A *Representational* coercion,+               -- of kind   T ty1 ty2   ~R   R:T a b c+               -- where T is the family TyCon,+               -- and R:T is the representation TyCon (ie this one)+               -- and a,b,c are the tyConTyVars of this TyCon+               --+               -- BUT may be eta-reduced; see TcInstDcls+               --     Note [Eta reduction for data family axioms]++          -- Cached fields of the CoAxiom, but adjusted to+          -- use the tyConTyVars of this TyCon+        TyCon   -- The family TyCon+        [Type]  -- Argument types (mentions the tyConTyVars of this TyCon)+                -- Match in length the tyConTyVars of the family TyCon++        -- E.g.  data instance T [a] = ...+        -- gives a representation tycon:+        --      data R:TList a = ...+        --      axiom co a :: T [a] ~ R:TList a+        -- with R:TList's algTcParent = DataFamInstTyCon T [a] co++instance Outputable AlgTyConFlav where+    ppr (VanillaAlgTyCon {})        = text "Vanilla ADT"+    ppr (UnboxedAlgTyCon {})        = text "Unboxed ADT"+    ppr (ClassTyCon cls _)          = text "Class parent" <+> ppr cls+    ppr (DataFamInstTyCon _ tc tys) = text "Family parent (family instance)"+                                      <+> ppr tc <+> sep (map pprType tys)++-- | Checks the invariants of a 'AlgTyConFlav' given the appropriate type class+-- name, if any+okParent :: Name -> AlgTyConFlav -> Bool+okParent _       (VanillaAlgTyCon {})            = True+okParent _       (UnboxedAlgTyCon {})            = True+okParent tc_name (ClassTyCon cls _)              = tc_name == tyConName (classTyCon cls)+okParent _       (DataFamInstTyCon _ fam_tc tys) = tyConArity fam_tc == length tys++isNoParent :: AlgTyConFlav -> Bool+isNoParent (VanillaAlgTyCon {}) = True+isNoParent _                   = False++--------------------++data Injectivity+  = NotInjective+  | Injective [Bool]   -- 1-1 with tyConTyVars (incl kind vars)+  deriving( Eq )++-- | Information pertaining to the expansion of a type synonym (@type@)+data FamTyConFlav+  = -- | Represents an open type family without a fixed right hand+    -- side.  Additional instances can appear at any time.+    --+    -- These are introduced by either a top level declaration:+    --+    -- > data family T a :: *+    --+    -- Or an associated data type declaration, within a class declaration:+    --+    -- > class C a b where+    -- >   data T b :: *+     DataFamilyTyCon+       TyConRepName++     -- | An open type synonym family  e.g. @type family F x y :: * -> *@+   | OpenSynFamilyTyCon++   -- | A closed type synonym family  e.g.+   -- @type family F x where { F Int = Bool }@+   | ClosedSynFamilyTyCon (Maybe (CoAxiom Branched))+     -- See Note [Closed type families]++   -- | A closed type synonym family declared in an hs-boot file with+   -- type family F a where ..+   | AbstractClosedSynFamilyTyCon++   -- | Built-in type family used by the TypeNats solver+   | BuiltInSynFamTyCon BuiltInSynFamily++instance Outputable FamTyConFlav where+    ppr (DataFamilyTyCon n) = text "data family" <+> ppr n+    ppr OpenSynFamilyTyCon = text "open type family"+    ppr (ClosedSynFamilyTyCon Nothing) = text "closed type family"+    ppr (ClosedSynFamilyTyCon (Just coax)) = text "closed type family" <+> ppr coax+    ppr AbstractClosedSynFamilyTyCon = text "abstract closed type family"+    ppr (BuiltInSynFamTyCon _) = text "built-in type family"++{- Note [Closed type families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* In an open type family you can add new instances later.  This is the+  usual case.++* In a closed type family you can only put equations where the family+  is defined.++A non-empty closed type family has a single axiom with multiple+branches, stored in the 'ClosedSynFamilyTyCon' constructor.  A closed+type family with no equations does not have an axiom, because there is+nothing for the axiom to prove!+++Note [Promoted data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+All data constructors can be promoted to become a type constructor,+via the PromotedDataCon alternative in TyCon.++* The TyCon promoted from a DataCon has the *same* Name and Unique as+  the DataCon.  Eg. If the data constructor Data.Maybe.Just(unique 78,+  say) is promoted to a TyCon whose name is Data.Maybe.Just(unique 78)++* Small note: We promote the *user* type of the DataCon.  Eg+     data T = MkT {-# UNPACK #-} !(Bool, Bool)+  The promoted kind is+     MkT :: (Bool,Bool) -> T+  *not*+     MkT :: Bool -> Bool -> T++Note [Enumeration types]+~~~~~~~~~~~~~~~~~~~~~~~~+We define datatypes with no constructors to *not* be+enumerations; this fixes trac #2578,  Otherwise we+end up generating an empty table for+  <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 Trac #4528.++Note [Newtype coercions]+~~~~~~~~~~~~~~~~~~~~~~~~+The NewTyCon field nt_co is a CoAxiom which is used for coercing from+the representation type of the newtype, to the newtype itself. For+example,++   newtype T a = MkT (a -> a)++the NewTyCon for T will contain nt_co = CoT where CoT t : T t ~ t -> t.++In the case that the right hand side is a type application+ending with the same type variables as the left hand side, we+"eta-contract" the coercion.  So if we had++   newtype S a = MkT [a]++then we would generate the arity 0 axiom CoS : S ~ [].  The+primary reason we do this is to make newtype deriving cleaner.++In the paper we'd write+        axiom CoT : (forall t. T t) ~ (forall t. [t])+and then when we used CoT at a particular type, s, we'd say+        CoT @ s+which encodes as (TyConApp instCoercionTyCon [TyConApp CoT [], s])++Note [Newtype eta]+~~~~~~~~~~~~~~~~~~+Consider+        newtype Parser a = MkParser (IO a) deriving Monad+Are these two types equal (to Core)?+        Monad Parser+        Monad IO+which we need to make the derived instance for Monad Parser.++Well, yes.  But to see that easily we eta-reduce the RHS type of+Parser, in this case to ([], Froogle), so that even unsaturated applications+of Parser will work right.  This eta reduction is done when the type+constructor is built, and cached in NewTyCon.++Here's an example that I think showed up in practice+Source code:+        newtype T a = MkT [a]+        newtype Foo m = MkFoo (forall a. m a -> Int)++        w1 :: Foo []+        w1 = ...++        w2 :: Foo T+        w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x)++After desugaring, and discarding the data constructors for the newtypes,+we get:+        w2 = w1 `cast` Foo CoT+so the coercion tycon CoT must have+        kind:    T ~ []+ and    arity:   0++Note [TcTyCon]+~~~~~~~~~~~~~~+TcTyCons are used for tow distinct purposes++1.  When recovering from a type error in a type declaration,+    we want to put the erroneous TyCon in the environment in a+    way that won't lead to more errors.  We use a TcTyCon for this;+    see makeRecoveryTyCon.++2.  When checking a type/class declaration (in module TcTyClsDecls), we come+    upon knowledge of the eventual tycon in bits and pieces. First, we use+    getInitialKinds to look over the user-provided kind signature of a tycon+    (including, for example, the number of parameters written to the tycon)+    to get an initial shape of the tycon's kind. Then, using these initial+    kinds, we kind-check the body of the tycon (class methods, data constructors,+    etc.), filling in the metavariables in the tycon's initial kind.+    We then generalize to get the tycon's final, fixed kind. Finally, once+    this has happened for all tycons in a mutually recursive group, we+    can desugar the lot.++    For convenience, we store partially-known tycons in TcTyCons, which+    might store meta-variables. These TcTyCons are stored in the local+    environment in TcTyClsDecls, until the real full TyCons can be created+    during desugaring. A desugared program should never have a TcTyCon.++    A challenging piece in all of this is that we end up taking three separate+    passes over every declaration: one in getInitialKind (this pass look only+    at the head, not the body), one in kcTyClDecls (to kind-check the body),+    and a final one in tcTyClDecls (to desugar). In the latter two passes,+    we need to connect the user-written type variables in an LHsQTyVars+    with the variables in the tycon's inferred kind. Because the tycon might+    not have a CUSK, this matching up is, in general, quite hard to do.+    (Look through the git history between Dec 2015 and Apr 2016 for+    TcHsType.splitTelescopeTvs!) Instead of trying, we just store the list+    of type variables to bring into scope in the later passes when we create+    a TcTyCon in getInitialKinds. Much easier this way! These tyvars are+    brought into scope in kcTyClTyVars and tcTyClTyVars, both in TcHsType.++    It is important that the scoped type variables not be zonked, as some+    scoped type variables come into existence as SigTvs. If we zonk, the+    Unique will change and the user-written occurrences won't match up with+    what we expect.++    In a TcTyCon, everything is zonked (except the scoped vars) after+    the kind-checking pass.++************************************************************************+*                                                                      *+                 TyConRepName+*                                                                      *+********************************************************************* -}++type TyConRepName = Name -- The Name of the top-level declaration+                         --    $tcMaybe :: Data.Typeable.Internal.TyCon+                         --    $tcMaybe = TyCon { tyConName = "Maybe", ... }++tyConRepName_maybe :: TyCon -> Maybe TyConRepName+tyConRepName_maybe (FunTyCon   { tcRepName = rep_nm })+  = Just rep_nm+tyConRepName_maybe (PrimTyCon  { primRepName = mb_rep_nm })+  = mb_rep_nm+tyConRepName_maybe (AlgTyCon { algTcParent = parent })+  | VanillaAlgTyCon rep_nm <- parent = Just rep_nm+  | ClassTyCon _ rep_nm    <- parent = Just rep_nm+  | UnboxedAlgTyCon rep_nm <- parent = rep_nm+tyConRepName_maybe (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm })+  = Just rep_nm+tyConRepName_maybe (PromotedDataCon { tcRepName = rep_nm })+  = Just rep_nm+tyConRepName_maybe _ = Nothing++-- | Make a 'Name' for the 'Typeable' representation of the given wired-in type+mkPrelTyConRepName :: Name -> TyConRepName+-- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable.+mkPrelTyConRepName tc_name  -- Prelude tc_name is always External,+                            -- so nameModule will work+  = mkExternalName rep_uniq rep_mod rep_occ (nameSrcSpan tc_name)+  where+    name_occ  = nameOccName tc_name+    name_mod  = nameModule  tc_name+    name_uniq = nameUnique  tc_name+    rep_uniq | isTcOcc name_occ = tyConRepNameUnique   name_uniq+             | otherwise        = dataConRepNameUnique name_uniq+    (rep_mod, rep_occ) = tyConRepModOcc name_mod name_occ++-- | The name (and defining module) for the Typeable representation (TyCon) of a+-- type constructor.+--+-- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable.+tyConRepModOcc :: Module -> OccName -> (Module, OccName)+tyConRepModOcc tc_module tc_occ = (rep_module, mkTyConRepOcc tc_occ)+  where+    rep_module+      | tc_module == gHC_PRIM = gHC_TYPES+      | otherwise             = tc_module+++{- *********************************************************************+*                                                                      *+                 PrimRep+*                                                                      *+************************************************************************++Note [rep swamp]++GHC has a rich selection of types that represent "primitive types" of+one kind or another.  Each of them makes a different set of+distinctions, and mostly the differences are for good reasons,+although it's probably true that we could merge some of these.++Roughly in order of "includes more information":++ - A Width (cmm/CmmType) is simply a binary value with the specified+   number of bits.  It may represent a signed or unsigned integer, a+   floating-point value, or an address.++    data Width = W8 | W16 | W32 | W64 | W80 | W128++ - Size, which is used in the native code generator, is Width ++   floating point information.++   data Size = II8 | II16 | II32 | II64 | FF32 | FF64 | FF80++   it is necessary because e.g. the instruction to move a 64-bit float+   on x86 (movsd) is different from the instruction to move a 64-bit+   integer (movq), so the mov instruction is parameterised by Size.++ - CmmType wraps Width with more information: GC ptr, float, or+   other value.++    data CmmType = CmmType CmmCat Width++    data CmmCat     -- "Category" (not exported)+       = GcPtrCat   -- GC pointer+       | BitsCat    -- Non-pointer+       | FloatCat   -- Float++   It is important to have GcPtr information in Cmm, since we generate+   info tables containing pointerhood for the GC from this.  As for+   why we have float (and not signed/unsigned) here, see Note [Signed+   vs unsigned].++ - ArgRep makes only the distinctions necessary for the call and+   return conventions of the STG machine.  It is essentially CmmType+   + void.++ - PrimRep makes a few more distinctions than ArgRep: it divides+   non-GC-pointers into signed/unsigned and addresses, information+   that is necessary for passing these values to foreign functions.++There's another tension here: whether the type encodes its size in+bytes, or whether its size depends on the machine word size.  Width+and CmmType have the size built-in, whereas ArgRep and PrimRep do not.++This means to turn an ArgRep/PrimRep into a CmmType requires DynFlags.++On the other hand, CmmType includes some "nonsense" values, such as+CmmType GcPtrCat W32 on a 64-bit machine.+-}++-- | A 'PrimRep' is an abstraction of a type.  It contains information that+-- the code generator needs in order to pass arguments, return results,+-- and store values of this type.+data PrimRep+  = VoidRep+  | LiftedRep+  | UnliftedRep   -- ^ Unlifted pointer+  | IntRep        -- ^ Signed, word-sized value+  | WordRep       -- ^ Unsigned, word-sized value+  | Int64Rep      -- ^ Signed, 64 bit value (with 32-bit words only)+  | Word64Rep     -- ^ Unsigned, 64 bit value (with 32-bit words only)+  | AddrRep       -- ^ A pointer, but /not/ to a Haskell value (use '(Un)liftedRep')+  | FloatRep+  | DoubleRep+  | VecRep Int PrimElemRep  -- ^ A vector+  deriving( Eq, Show )++data PrimElemRep+  = Int8ElemRep+  | Int16ElemRep+  | Int32ElemRep+  | Int64ElemRep+  | Word8ElemRep+  | Word16ElemRep+  | Word32ElemRep+  | Word64ElemRep+  | FloatElemRep+  | DoubleElemRep+   deriving( Eq, Show )++instance Outputable PrimRep where+  ppr r = text (show r)++instance Outputable PrimElemRep where+  ppr r = text (show r)++isVoidRep :: PrimRep -> Bool+isVoidRep VoidRep = True+isVoidRep _other  = False++isGcPtrRep :: PrimRep -> Bool+isGcPtrRep LiftedRep   = True+isGcPtrRep UnliftedRep = True+isGcPtrRep _           = False++-- | Find the size of a 'PrimRep', in words+primRepSizeW :: DynFlags -> PrimRep -> Int+primRepSizeW _      IntRep           = 1+primRepSizeW _      WordRep          = 1+primRepSizeW dflags Int64Rep         = wORD64_SIZE `quot` wORD_SIZE dflags+primRepSizeW dflags Word64Rep        = wORD64_SIZE `quot` wORD_SIZE dflags+primRepSizeW _      FloatRep         = 1    -- NB. might not take a full word+primRepSizeW dflags DoubleRep        = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags+primRepSizeW _      AddrRep          = 1+primRepSizeW _      LiftedRep        = 1+primRepSizeW _      UnliftedRep      = 1+primRepSizeW _      VoidRep          = 0+primRepSizeW dflags (VecRep len rep) = len * primElemRepSizeB rep `quot` wORD_SIZE dflags++primElemRepSizeB :: PrimElemRep -> Int+primElemRepSizeB Int8ElemRep   = 1+primElemRepSizeB Int16ElemRep  = 2+primElemRepSizeB Int32ElemRep  = 4+primElemRepSizeB Int64ElemRep  = 8+primElemRepSizeB Word8ElemRep  = 1+primElemRepSizeB Word16ElemRep = 2+primElemRepSizeB Word32ElemRep = 4+primElemRepSizeB Word64ElemRep = 8+primElemRepSizeB FloatElemRep  = 4+primElemRepSizeB DoubleElemRep = 8++-- | Return if Rep stands for floating type,+-- returns Nothing for vector types.+primRepIsFloat :: PrimRep -> Maybe Bool+primRepIsFloat  FloatRep     = Just True+primRepIsFloat  DoubleRep    = Just True+primRepIsFloat  (VecRep _ _) = Nothing+primRepIsFloat  _            = Just False+++{-+************************************************************************+*                                                                      *+                             Field labels+*                                                                      *+************************************************************************+-}++-- | The labels for the fields of this particular 'TyCon'+tyConFieldLabels :: TyCon -> [FieldLabel]+tyConFieldLabels tc = dFsEnvElts $ tyConFieldLabelEnv tc++-- | The labels for the fields of this particular 'TyCon'+tyConFieldLabelEnv :: TyCon -> FieldLabelEnv+tyConFieldLabelEnv tc+  | isAlgTyCon tc = algTcFields tc+  | otherwise     = emptyDFsEnv++-- | Look up a field label belonging to this 'TyCon'+lookupTyConFieldLabel :: FieldLabelString -> TyCon -> Maybe FieldLabel+lookupTyConFieldLabel lbl tc = lookupDFsEnv (tyConFieldLabelEnv tc) lbl++-- | Make a map from strings to FieldLabels from all the data+-- constructors of this algebraic tycon+fieldsOfAlgTcRhs :: AlgTyConRhs -> FieldLabelEnv+fieldsOfAlgTcRhs rhs = mkDFsEnv [ (flLabel fl, fl)+                                | fl <- dataConsFields (visibleDataCons rhs) ]+  where+    -- Duplicates in this list will be removed by 'mkFsEnv'+    dataConsFields dcs = concatMap dataConFieldLabels dcs+++{-+************************************************************************+*                                                                      *+\subsection{TyCon Construction}+*                                                                      *+************************************************************************++Note: the TyCon constructors all take a Kind as one argument, even though+they could, in principle, work out their Kind from their other arguments.+But to do so they need functions from Types, and that makes a nasty+module mutual-recursion.  And they aren't called from many places.+So we compromise, and move their Kind calculation to the call site.+-}++-- | Given the name of the function type constructor and it's kind, create the+-- corresponding 'TyCon'. It is recomended to use 'TyCoRep.funTyCon' if you want+-- this functionality+mkFunTyCon :: Name -> [TyConBinder] -> Name -> TyCon+mkFunTyCon name binders rep_nm+  = FunTyCon {+        tyConUnique  = nameUnique name,+        tyConName    = name,+        tyConBinders = binders,+        tyConResKind = liftedTypeKind,+        tyConKind    = mkTyConKind binders liftedTypeKind,+        tyConArity   = length binders,+        tcRepName    = rep_nm+    }++-- | This is the making of an algebraic 'TyCon'. Notably, you have to+-- pass in the generic (in the -XGenerics sense) information about the+-- type constructor - you can get hold of it easily (see Generics+-- module)+mkAlgTyCon :: Name+           -> [TyConBinder]  -- ^ Binders of the 'TyCon'+           -> Kind              -- ^ Result kind+           -> [Role]            -- ^ The roles for each TyVar+           -> Maybe CType       -- ^ The C type this type corresponds to+                                --   when using the CAPI FFI+           -> [PredType]        -- ^ Stupid theta: see 'algTcStupidTheta'+           -> AlgTyConRhs       -- ^ Information about data constructors+           -> AlgTyConFlav      -- ^ What flavour is it?+                                -- (e.g. vanilla, type family)+           -> Bool              -- ^ Was the 'TyCon' declared with GADT syntax?+           -> TyCon+mkAlgTyCon name binders res_kind roles cType stupid rhs parent gadt_syn+  = AlgTyCon {+        tyConName        = name,+        tyConUnique      = nameUnique name,+        tyConBinders     = binders,+        tyConResKind     = res_kind,+        tyConKind        = mkTyConKind binders res_kind,+        tyConArity       = length binders,+        tyConTyVars      = binderVars binders,+        tcRoles          = roles,+        tyConCType       = cType,+        algTcStupidTheta = stupid,+        algTcRhs         = rhs,+        algTcFields      = fieldsOfAlgTcRhs rhs,+        algTcParent      = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent,+        algTcGadtSyntax  = gadt_syn+    }++-- | Simpler specialization of 'mkAlgTyCon' for classes+mkClassTyCon :: Name -> [TyConBinder]+             -> [Role] -> AlgTyConRhs -> Class+             -> Name -> TyCon+mkClassTyCon name binders roles rhs clas tc_rep_name+  = mkAlgTyCon name binders constraintKind roles Nothing [] rhs+               (ClassTyCon clas tc_rep_name)+               False++mkTupleTyCon :: Name+             -> [TyConBinder]+             -> Kind    -- ^ Result kind of the 'TyCon'+             -> Arity   -- ^ Arity of the tuple 'TyCon'+             -> DataCon+             -> TupleSort    -- ^ Whether the tuple is boxed or unboxed+             -> AlgTyConFlav+             -> TyCon+mkTupleTyCon name binders res_kind arity con sort parent+  = AlgTyCon {+        tyConUnique      = nameUnique name,+        tyConName        = name,+        tyConBinders     = binders,+        tyConTyVars      = binderVars binders,+        tyConResKind     = res_kind,+        tyConKind        = mkTyConKind binders res_kind,+        tyConArity       = arity,+        tcRoles          = replicate arity Representational,+        tyConCType       = Nothing,+        algTcGadtSyntax  = False,+        algTcStupidTheta = [],+        algTcRhs         = TupleTyCon { data_con = con,+                                        tup_sort = sort },+        algTcFields      = emptyDFsEnv,+        algTcParent      = parent+    }++mkSumTyCon :: Name+             -> [TyConBinder]+             -> Kind    -- ^ Kind of the resulting 'TyCon'+             -> Arity   -- ^ Arity of the sum+             -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars'+             -> [DataCon]+             -> AlgTyConFlav+             -> TyCon+mkSumTyCon name binders res_kind arity tyvars cons parent+  = AlgTyCon {+        tyConUnique      = nameUnique name,+        tyConName        = name,+        tyConBinders     = binders,+        tyConTyVars      = tyvars,+        tyConResKind     = res_kind,+        tyConKind        = mkTyConKind binders res_kind,+        tyConArity       = arity,+        tcRoles          = replicate arity Representational,+        tyConCType       = Nothing,+        algTcGadtSyntax  = False,+        algTcStupidTheta = [],+        algTcRhs         = SumTyCon { data_cons = cons },+        algTcFields      = emptyDFsEnv,+        algTcParent      = parent+    }++-- | Makes a tycon suitable for use during type-checking.+-- The only real need for this is for printing error messages during+-- a recursive type/class type-checking knot. It has a kind because+-- TcErrors sometimes calls typeKind.+-- See also Note [Kind checking recursive type and class declarations]+-- in TcTyClsDecls.+mkTcTyCon :: Name+          -> [TyConBinder]+          -> Kind                -- ^ /result/ kind only+          -> Bool                -- ^ Can this be unsaturated?+          -> [TyVar]             -- ^ Scoped type variables, see Note [TcTyCon]+          -> TyCon+mkTcTyCon name binders res_kind unsat scoped_tvs+  = TcTyCon { tyConUnique  = getUnique name+            , tyConName    = name+            , tyConTyVars  = binderVars binders+            , tyConBinders = binders+            , tyConResKind = res_kind+            , tyConKind    = mkTyConKind binders res_kind+            , tyConUnsat   = unsat+            , tyConArity   = length binders+            , tcTyConScopedTyVars = scoped_tvs }++-- | Create an unlifted primitive 'TyCon', such as @Int#@.+mkPrimTyCon :: Name -> [TyConBinder]+            -> Kind   -- ^ /result/ kind, never levity-polymorphic+            -> [Role] -> TyCon+mkPrimTyCon name binders res_kind roles+  = mkPrimTyCon' name binders res_kind roles True (Just $ mkPrelTyConRepName name)++-- | Kind constructors+mkKindTyCon :: Name -> [TyConBinder]+            -> Kind  -- ^ /result/ kind+            -> [Role] -> Name -> TyCon+mkKindTyCon name binders res_kind roles rep_nm+  = tc+  where+    tc = mkPrimTyCon' name binders res_kind roles False (Just rep_nm)++-- | Create a lifted primitive 'TyCon' such as @RealWorld@+mkLiftedPrimTyCon :: Name -> [TyConBinder]+                  -> Kind   -- ^ /result/ kind+                  -> [Role] -> TyCon+mkLiftedPrimTyCon name binders res_kind roles+  = mkPrimTyCon' name binders res_kind roles False (Just rep_nm)+  where rep_nm = mkPrelTyConRepName name++mkPrimTyCon' :: Name -> [TyConBinder]+             -> Kind    -- ^ /result/ kind, never levity-polymorphic+                        -- (If you need a levity-polymorphic PrimTyCon, change+                        --  isTcLevPoly.)+             -> [Role]+             -> Bool -> Maybe TyConRepName -> TyCon+mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm+  = PrimTyCon {+        tyConName    = name,+        tyConUnique  = nameUnique name,+        tyConBinders = binders,+        tyConResKind = res_kind,+        tyConKind    = mkTyConKind binders res_kind,+        tyConArity   = length roles,+        tcRoles      = roles,+        isUnlifted   = is_unlifted,+        primRepName  = rep_nm+    }++-- | Create a type synonym 'TyCon'+mkSynonymTyCon :: Name -> [TyConBinder] -> Kind   -- ^ /result/ kind+               -> [Role] -> Type -> Bool -> Bool -> TyCon+mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free+  = SynonymTyCon {+        tyConName    = name,+        tyConUnique  = nameUnique name,+        tyConBinders = binders,+        tyConResKind = res_kind,+        tyConKind    = mkTyConKind binders res_kind,+        tyConArity   = length binders,+        tyConTyVars  = binderVars binders,+        tcRoles      = roles,+        synTcRhs     = rhs,+        synIsTau     = is_tau,+        synIsFamFree = is_fam_free+    }++-- | Create a type family 'TyCon'+mkFamilyTyCon :: Name -> [TyConBinder] -> Kind  -- ^ /result/ kind+              -> Maybe Name -> FamTyConFlav+              -> Maybe Class -> Injectivity -> TyCon+mkFamilyTyCon name binders res_kind resVar flav parent inj+  = FamilyTyCon+      { tyConUnique  = nameUnique name+      , tyConName    = name+      , tyConBinders = binders+      , tyConResKind = res_kind+      , tyConKind    = mkTyConKind binders res_kind+      , tyConArity   = length binders+      , tyConTyVars  = binderVars binders+      , famTcResVar  = resVar+      , famTcFlav    = flav+      , famTcParent  = parent+      , famTcInj     = inj+      }+++-- | Create a promoted data constructor 'TyCon'+-- Somewhat dodgily, we give it the same Name+-- as the data constructor itself; when we pretty-print+-- the TyCon we add a quote; see the Outputable TyCon instance+mkPromotedDataCon :: DataCon -> Name -> TyConRepName+                  -> [TyConBinder] -> Kind -> [Role]+                  -> RuntimeRepInfo -> TyCon+mkPromotedDataCon con name rep_name binders res_kind roles rep_info+  = PromotedDataCon {+        tyConUnique   = nameUnique name,+        tyConName     = name,+        tyConArity    = length roles,+        tcRoles       = roles,+        tyConBinders  = binders,+        tyConResKind  = res_kind,+        tyConKind     = mkTyConKind binders res_kind,+        dataCon       = con,+        tcRepName     = rep_name,+        promDcRepInfo = rep_info+  }++isFunTyCon :: TyCon -> Bool+isFunTyCon (FunTyCon {}) = True+isFunTyCon _             = False++-- | Test if the 'TyCon' is algebraic but abstract (invisible data constructors)+isAbstractTyCon :: TyCon -> Bool+isAbstractTyCon (AlgTyCon { algTcRhs = AbstractTyCon }) = True+isAbstractTyCon _ = False++-- | Make an fake, recovery 'TyCon' from an existing one.+-- Used when recovering from errors+makeRecoveryTyCon :: TyCon -> TyCon+makeRecoveryTyCon tc+  = mkTcTyCon (tyConName tc)+              (tyConBinders tc) (tyConResKind tc)+              (mightBeUnsaturatedTyCon tc) [{- no scoped vars -}]++-- | Does this 'TyCon' represent something that cannot be defined in Haskell?+isPrimTyCon :: TyCon -> Bool+isPrimTyCon (PrimTyCon {}) = True+isPrimTyCon _              = False++-- | Is this 'TyCon' unlifted (i.e. cannot contain bottom)? Note that this can+-- only be true for primitive and unboxed-tuple 'TyCon's+isUnliftedTyCon :: TyCon -> Bool+isUnliftedTyCon (PrimTyCon  {isUnlifted = is_unlifted})+  = is_unlifted+isUnliftedTyCon (AlgTyCon { algTcRhs = rhs } )+  | TupleTyCon { tup_sort = sort } <- rhs+  = not (isBoxed (tupleSortBoxity sort))+isUnliftedTyCon (AlgTyCon { algTcRhs = rhs } )+  | SumTyCon {} <- rhs+  = True+isUnliftedTyCon _ = False++-- | Returns @True@ if the supplied 'TyCon' resulted from either a+-- @data@ or @newtype@ declaration+isAlgTyCon :: TyCon -> Bool+isAlgTyCon (AlgTyCon {})   = True+isAlgTyCon _               = False++-- | Returns @True@ for vanilla AlgTyCons -- that is, those created+-- with a @data@ or @newtype@ declaration.+isVanillaAlgTyCon :: TyCon -> Bool+isVanillaAlgTyCon (AlgTyCon { algTcParent = VanillaAlgTyCon _ }) = True+isVanillaAlgTyCon _                                              = False++isDataTyCon :: TyCon -> Bool+-- ^ Returns @True@ for data types that are /definitely/ represented by+-- heap-allocated constructors.  These are scrutinised by Core-level+-- @case@ expressions, and they get info tables allocated for them.+--+-- Generally, the function will be true for all @data@ types and false+-- for @newtype@s, unboxed tuples, unboxed sums and type family+-- 'TyCon's. But it is not guaranteed to return @True@ in all cases+-- that it could.+--+-- NB: for a data type family, only the /instance/ 'TyCon's+--     get an info table.  The family declaration 'TyCon' does not+isDataTyCon (AlgTyCon {algTcRhs = rhs})+  = case rhs of+        TupleTyCon { tup_sort = sort }+                           -> isBoxed (tupleSortBoxity sort)+        SumTyCon {}        -> False+        DataTyCon {}       -> True+        NewTyCon {}        -> False+        AbstractTyCon {}   -> False      -- We don't know, so return False+isDataTyCon _ = False++-- | 'isInjectiveTyCon' is true of 'TyCon's for which this property holds+-- (where X is the role passed in):+--   If (T a1 b1 c1) ~X (T a2 b2 c2), then (a1 ~X1 a2), (b1 ~X2 b2), and (c1 ~X3 c2)+-- (where X1, X2, and X3, are the roles given by tyConRolesX tc X)+-- See also Note [Decomposing equality] in TcCanonical+isInjectiveTyCon :: TyCon -> Role -> Bool+isInjectiveTyCon _                             Phantom          = False+isInjectiveTyCon (FunTyCon {})                 _                = True+isInjectiveTyCon (AlgTyCon {})                 Nominal          = True+isInjectiveTyCon (AlgTyCon {algTcRhs = rhs})   Representational+  = isGenInjAlgRhs rhs+isInjectiveTyCon (SynonymTyCon {})             _                = False+isInjectiveTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ })+                                               Nominal          = True+isInjectiveTyCon (FamilyTyCon { famTcInj = Injective inj }) Nominal = and inj+isInjectiveTyCon (FamilyTyCon {})              _                = False+isInjectiveTyCon (PrimTyCon {})                _                = True+isInjectiveTyCon (PromotedDataCon {})          _                = True+isInjectiveTyCon (TcTyCon {})                  _                = True+  -- Reply True for TcTyCon to minimise knock on type errors+  -- See Note [TcTyCon] item (1)++-- | 'isGenerativeTyCon' is true of 'TyCon's for which this property holds+-- (where X is the role passed in):+--   If (T tys ~X t), then (t's head ~X T).+-- See also Note [Decomposing equality] in TcCanonical+isGenerativeTyCon :: TyCon -> Role -> Bool+isGenerativeTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) Nominal = True+isGenerativeTyCon (FamilyTyCon {}) _ = False+  -- in all other cases, injectivity implies generativity+isGenerativeTyCon tc               r = isInjectiveTyCon tc r++-- | Is this an 'AlgTyConRhs' of a 'TyCon' that is generative and injective+-- with respect to representational equality?+isGenInjAlgRhs :: AlgTyConRhs -> Bool+isGenInjAlgRhs (TupleTyCon {})          = True+isGenInjAlgRhs (SumTyCon {})            = True+isGenInjAlgRhs (DataTyCon {})           = True+isGenInjAlgRhs (AbstractTyCon {})       = False+isGenInjAlgRhs (NewTyCon {})            = False++-- | Is this 'TyCon' that for a @newtype@+isNewTyCon :: TyCon -> Bool+isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True+isNewTyCon _                                   = False++-- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it expands+-- into, and (possibly) a coercion from the representation type to the @newtype@.+-- Returns @Nothing@ if this is not possible.+unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched)+unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs,+                                 algTcRhs = NewTyCon { nt_co = co,+                                                       nt_rhs = rhs }})+                           = Just (tvs, rhs, co)+unwrapNewTyCon_maybe _     = Nothing++unwrapNewTyConEtad_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched)+unwrapNewTyConEtad_maybe (AlgTyCon { algTcRhs = NewTyCon { nt_co = co,+                                                           nt_etad_rhs = (tvs,rhs) }})+                           = Just (tvs, rhs, co)+unwrapNewTyConEtad_maybe _ = Nothing++isProductTyCon :: TyCon -> Bool+-- True of datatypes or newtypes that have+--   one, non-existential, data constructor+-- See Note [Product types]+isProductTyCon tc@(AlgTyCon {})+  = case algTcRhs tc of+      TupleTyCon {} -> True+      DataTyCon{ data_cons = [data_con] }+                    -> null (dataConExTyVars data_con)+      NewTyCon {}   -> True+      _             -> False+isProductTyCon _ = False++isDataProductTyCon_maybe :: TyCon -> Maybe DataCon+-- True of datatypes (not newtypes) with+--   one, vanilla, data constructor+-- See Note [Product types]+isDataProductTyCon_maybe (AlgTyCon { algTcRhs = rhs })+  = case rhs of+       DataTyCon { data_cons = [con] }+         | null (dataConExTyVars con)  -- non-existential+         -> Just con+       TupleTyCon { data_con = con }+         -> Just con+       _ -> Nothing+isDataProductTyCon_maybe _ = Nothing++isDataSumTyCon_maybe :: TyCon -> Maybe [DataCon]+isDataSumTyCon_maybe (AlgTyCon { algTcRhs = rhs })+  = case rhs of+      DataTyCon { data_cons = cons }+        | length cons > 1+        , all (null . dataConExTyVars) cons -- FIXME(osa): Why do we need this?+        -> Just cons+      SumTyCon { data_cons = cons }+        | all (null . dataConExTyVars) cons -- FIXME(osa): Why do we need this?+        -> Just cons+      _ -> Nothing+isDataSumTyCon_maybe _ = Nothing++{- Note [Product types]+~~~~~~~~~~~~~~~~~~~~~~~+A product type is+ * A data type (not a newtype)+ * With one, boxed data constructor+ * That binds no existential type variables++The main point is that product types are amenable to unboxing for+  * Strict function calls; we can transform+        f (D a b) = e+    to+        fw a b = e+    via the worker/wrapper transformation.  (Question: couldn't this+    work for existentials too?)++  * CPR for function results; we can transform+        f x y = let ... in D a b+    to+        fw x y = let ... in (# a, b #)++Note that the data constructor /can/ have evidence arguments: equality+constraints, type classes etc.  So it can be GADT.  These evidence+arguments are simply value arguments, and should not get in the way.+-}+++-- | Is this a 'TyCon' representing a regular H98 type synonym (@type@)?+isTypeSynonymTyCon :: TyCon -> Bool+isTypeSynonymTyCon (SynonymTyCon {}) = True+isTypeSynonymTyCon _                 = False++isTauTyCon :: TyCon -> Bool+isTauTyCon (SynonymTyCon { synIsTau = is_tau }) = is_tau+isTauTyCon _                                    = True++isFamFreeTyCon :: TyCon -> Bool+isFamFreeTyCon (SynonymTyCon { synIsFamFree = fam_free }) = fam_free+isFamFreeTyCon (FamilyTyCon { famTcFlav = flav })         = isDataFamFlav flav+isFamFreeTyCon _                                          = True++-- As for newtypes, it is in some contexts important to distinguish between+-- closed synonyms and synonym families, as synonym families have no unique+-- right hand side to which a synonym family application can expand.+--++-- | True iff we can decompose (T a b c) into ((T a b) c)+--   I.e. is it injective and generative w.r.t nominal equality?+--   That is, if (T a b) ~N d e f, is it always the case that+--            (T ~N d), (a ~N e) and (b ~N f)?+-- Specifically NOT true of synonyms (open and otherwise)+--+-- It'd be unusual to call mightBeUnsaturatedTyCon on a regular H98+-- type synonym, because you should probably have expanded it first+-- But regardless, it's not decomposable+mightBeUnsaturatedTyCon :: TyCon -> Bool+mightBeUnsaturatedTyCon (SynonymTyCon {})                  = False+mightBeUnsaturatedTyCon (FamilyTyCon  { famTcFlav = flav}) = isDataFamFlav flav+mightBeUnsaturatedTyCon (TcTyCon { tyConUnsat = unsat })   = unsat+mightBeUnsaturatedTyCon _other                             = True++-- | Is this an algebraic 'TyCon' declared with the GADT syntax?+isGadtSyntaxTyCon :: TyCon -> Bool+isGadtSyntaxTyCon (AlgTyCon { algTcGadtSyntax = res }) = res+isGadtSyntaxTyCon _                                    = False++-- | Is this an algebraic 'TyCon' which is just an enumeration of values?+isEnumerationTyCon :: TyCon -> Bool+-- See Note [Enumeration types] in TyCon+isEnumerationTyCon (AlgTyCon { tyConArity = arity, algTcRhs = rhs })+  = case rhs of+       DataTyCon { is_enum = res } -> res+       TupleTyCon {}               -> arity == 0+       _                           -> False+isEnumerationTyCon _ = False++-- | Is this a 'TyCon', synonym or otherwise, that defines a family?+isFamilyTyCon :: TyCon -> Bool+isFamilyTyCon (FamilyTyCon {}) = True+isFamilyTyCon _                = False++-- | Is this a 'TyCon', synonym or otherwise, that defines a family with+-- instances?+isOpenFamilyTyCon :: TyCon -> Bool+isOpenFamilyTyCon (FamilyTyCon {famTcFlav = flav })+  | OpenSynFamilyTyCon <- flav = True+  | DataFamilyTyCon {} <- flav = True+isOpenFamilyTyCon _            = False++-- | Is this a synonym 'TyCon' that can have may have further instances appear?+isTypeFamilyTyCon :: TyCon -> Bool+isTypeFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = not (isDataFamFlav flav)+isTypeFamilyTyCon _                                  = False++-- | Is this a synonym 'TyCon' that can have may have further instances appear?+isDataFamilyTyCon :: TyCon -> Bool+isDataFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = isDataFamFlav flav+isDataFamilyTyCon _                                  = False++-- | Is this an open type family TyCon?+isOpenTypeFamilyTyCon :: TyCon -> Bool+isOpenTypeFamilyTyCon (FamilyTyCon {famTcFlav = OpenSynFamilyTyCon }) = True+isOpenTypeFamilyTyCon _                                               = False++-- | Is this a non-empty closed type family? Returns 'Nothing' for+-- abstract or empty closed families.+isClosedSynFamilyTyConWithAxiom_maybe :: TyCon -> Maybe (CoAxiom Branched)+isClosedSynFamilyTyConWithAxiom_maybe+  (FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb}) = mb+isClosedSynFamilyTyConWithAxiom_maybe _               = Nothing++-- | Try to read the injectivity information from a FamilyTyCon.+-- For every other TyCon this function panics.+familyTyConInjectivityInfo :: TyCon -> Injectivity+familyTyConInjectivityInfo (FamilyTyCon { famTcInj = inj }) = inj+familyTyConInjectivityInfo _ = panic "familyTyConInjectivityInfo"++isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily+isBuiltInSynFamTyCon_maybe+  (FamilyTyCon {famTcFlav = BuiltInSynFamTyCon ops }) = Just ops+isBuiltInSynFamTyCon_maybe _                          = Nothing++isDataFamFlav :: FamTyConFlav -> Bool+isDataFamFlav (DataFamilyTyCon {}) = True   -- Data family+isDataFamFlav _                    = False  -- Type synonym family++-- | Are we able to extract information 'TyVar' to class argument list+-- mapping from a given 'TyCon'?+isTyConAssoc :: TyCon -> Bool+isTyConAssoc tc = isJust (tyConAssoc_maybe tc)++tyConAssoc_maybe :: TyCon -> Maybe Class+tyConAssoc_maybe (FamilyTyCon { famTcParent = mb_cls }) = mb_cls+tyConAssoc_maybe _                                      = Nothing++-- The unit tycon didn't used to be classed as a tuple tycon+-- but I thought that was silly so I've undone it+-- If it can't be for some reason, it should be a AlgTyCon+isTupleTyCon :: TyCon -> Bool+-- ^ Does this 'TyCon' represent a tuple?+--+-- NB: when compiling @Data.Tuple@, the tycons won't reply @True@ to+-- 'isTupleTyCon', because they are built as 'AlgTyCons'.  However they+-- get spat into the interface file as tuple tycons, so I don't think+-- it matters.+isTupleTyCon (AlgTyCon { algTcRhs = TupleTyCon {} }) = True+isTupleTyCon _ = False++tyConTuple_maybe :: TyCon -> Maybe TupleSort+tyConTuple_maybe (AlgTyCon { algTcRhs = rhs })+  | TupleTyCon { tup_sort = sort} <- rhs = Just sort+tyConTuple_maybe _                       = Nothing++-- | Is this the 'TyCon' for an unboxed tuple?+isUnboxedTupleTyCon :: TyCon -> Bool+isUnboxedTupleTyCon (AlgTyCon { algTcRhs = rhs })+  | TupleTyCon { tup_sort = sort } <- rhs+  = not (isBoxed (tupleSortBoxity sort))+isUnboxedTupleTyCon _ = False++-- | Is this the 'TyCon' for a boxed tuple?+isBoxedTupleTyCon :: TyCon -> Bool+isBoxedTupleTyCon (AlgTyCon { algTcRhs = rhs })+  | TupleTyCon { tup_sort = sort } <- rhs+  = isBoxed (tupleSortBoxity sort)+isBoxedTupleTyCon _ = False++-- | Is this the 'TyCon' for an unboxed sum?+isUnboxedSumTyCon :: TyCon -> Bool+isUnboxedSumTyCon (AlgTyCon { algTcRhs = rhs })+  | SumTyCon {} <- rhs+  = True+isUnboxedSumTyCon _ = False++-- | Is this the 'TyCon' for a /promoted/ tuple?+isPromotedTupleTyCon :: TyCon -> Bool+isPromotedTupleTyCon tyCon+  | Just dataCon <- isPromotedDataCon_maybe tyCon+  , isTupleTyCon (dataConTyCon dataCon) = True+  | otherwise                           = False++-- | Is this a PromotedDataCon?+isPromotedDataCon :: TyCon -> Bool+isPromotedDataCon (PromotedDataCon {}) = True+isPromotedDataCon _                    = False++-- | Retrieves the promoted DataCon if this is a PromotedDataCon;+isPromotedDataCon_maybe :: TyCon -> Maybe DataCon+isPromotedDataCon_maybe (PromotedDataCon { dataCon = dc }) = Just dc+isPromotedDataCon_maybe _ = Nothing++-- | Is this tycon really meant for use at the kind level? That is,+-- should it be permitted without -XDataKinds?+isKindTyCon :: TyCon -> Bool+isKindTyCon tc = getUnique tc `elementOfUniqSet` kindTyConKeys++-- | These TyCons should be allowed at the kind level, even without+-- -XDataKinds.+kindTyConKeys :: UniqSet Unique+kindTyConKeys = unionManyUniqSets+  ( mkUniqSet [ liftedTypeKindTyConKey, starKindTyConKey, unicodeStarKindTyConKey+              , constraintKindTyConKey, tYPETyConKey ]+  : map (mkUniqSet . tycon_with_datacons) [ runtimeRepTyCon+                                          , vecCountTyCon, vecElemTyCon ] )+  where+    tycon_with_datacons tc = getUnique tc : map getUnique (tyConDataCons tc)++isLiftedTypeKindTyConName :: Name -> Bool+isLiftedTypeKindTyConName+  = (`hasKey` liftedTypeKindTyConKey) <||>+    (`hasKey` starKindTyConKey) <||>+    (`hasKey` unicodeStarKindTyConKey)++-- | Identifies implicit tycons that, in particular, do not go into interface+-- files (because they are implicitly reconstructed when the interface is+-- read).+--+-- Note that:+--+-- * Associated families are implicit, as they are re-constructed from+--   the class declaration in which they reside, and+--+-- * Family instances are /not/ implicit as they represent the instance body+--   (similar to a @dfun@ does that for a class instance).+--+-- * Tuples are implicit iff they have a wired-in name+--   (namely: boxed and unboxed tupeles are wired-in and implicit,+--            but constraint tuples are not)+isImplicitTyCon :: TyCon -> Bool+isImplicitTyCon (FunTyCon {})        = True+isImplicitTyCon (PrimTyCon {})       = True+isImplicitTyCon (PromotedDataCon {}) = True+isImplicitTyCon (AlgTyCon { algTcRhs = rhs, tyConName = name })+  | TupleTyCon {} <- rhs             = isWiredInName name+  | SumTyCon {} <- rhs               = True+  | otherwise                        = False+isImplicitTyCon (FamilyTyCon { famTcParent = parent }) = isJust parent+isImplicitTyCon (SynonymTyCon {})    = False+isImplicitTyCon (TcTyCon {})         = False++tyConCType_maybe :: TyCon -> Maybe CType+tyConCType_maybe tc@(AlgTyCon {}) = tyConCType tc+tyConCType_maybe _ = Nothing++-- | Is this a TcTyCon? (That is, one only used during type-checking?)+isTcTyCon :: TyCon -> Bool+isTcTyCon (TcTyCon {}) = True+isTcTyCon _            = False++-- | Could this TyCon ever be levity-polymorphic when fully applied?+-- True is safe. False means we're sure. Does only a quick check+-- based on the TyCon's category.+-- Precondition: The fully-applied TyCon has kind (TYPE blah)+isTcLevPoly :: TyCon -> Bool+isTcLevPoly FunTyCon{}           = False+isTcLevPoly (AlgTyCon { algTcParent = UnboxedAlgTyCon _ }) = True+isTcLevPoly AlgTyCon{}           = False+isTcLevPoly SynonymTyCon{}       = True+isTcLevPoly FamilyTyCon{}        = True+isTcLevPoly PrimTyCon{}          = False+isTcLevPoly TcTyCon{}            = False+isTcLevPoly tc@PromotedDataCon{} = pprPanic "isTcLevPoly datacon" (ppr tc)++{-+-----------------------------------------------+--      Expand type-constructor applications+-----------------------------------------------+-}++expandSynTyCon_maybe+        :: TyCon+        -> [tyco]                 -- ^ Arguments to 'TyCon'+        -> Maybe ([(TyVar,tyco)],+                  Type,+                  [tyco])         -- ^ Returns a 'TyVar' substitution, the body+                                  -- type of the synonym (not yet substituted)+                                  -- and any arguments remaining from the+                                  -- application++-- ^ Expand a type synonym application, if any+expandSynTyCon_maybe tc tys+  | SynonymTyCon { tyConTyVars = tvs, synTcRhs = rhs, tyConArity = arity } <- tc+  = case arity `compare` length tys of+        LT -> Just (tvs `zip` tys, rhs, drop arity tys)+        EQ -> Just (tvs `zip` tys, rhs, [])+        GT -> Nothing+   | otherwise+   = Nothing++----------------++-- | Check if the tycon actually refers to a proper `data` or `newtype`+--  with user defined constructors rather than one from a class or other+--  construction.+isTyConWithSrcDataCons :: TyCon -> Bool+isTyConWithSrcDataCons (AlgTyCon { algTcRhs = rhs, algTcParent = parent }) =+  case rhs of+    DataTyCon {}  -> isSrcParent+    NewTyCon {}   -> isSrcParent+    TupleTyCon {} -> isSrcParent+    _ -> False+  where+    isSrcParent = isNoParent parent+isTyConWithSrcDataCons _ = False+++-- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no+-- constructors could be found+tyConDataCons :: TyCon -> [DataCon]+-- It's convenient for tyConDataCons to return the+-- empty list for type synonyms etc+tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` []++-- | Determine the 'DataCon's originating from the given 'TyCon', if the 'TyCon'+-- is the sort that can have any constructors (note: this does not include+-- abstract algebraic types)+tyConDataCons_maybe :: TyCon -> Maybe [DataCon]+tyConDataCons_maybe (AlgTyCon {algTcRhs = rhs})+  = case rhs of+       DataTyCon { data_cons = cons } -> Just cons+       NewTyCon { data_con = con }    -> Just [con]+       TupleTyCon { data_con = con }  -> Just [con]+       SumTyCon { data_cons = cons }  -> Just cons+       _                              -> Nothing+tyConDataCons_maybe _ = Nothing++-- | If the given 'TyCon' has a /single/ data constructor, i.e. it is a @data@+-- type with one alternative, a tuple type or a @newtype@ then that constructor+-- is returned. If the 'TyCon' has more than one constructor, or represents a+-- primitive or function type constructor then @Nothing@ is returned. In any+-- other case, the function panics+tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon+tyConSingleDataCon_maybe (AlgTyCon { algTcRhs = rhs })+  = case rhs of+      DataTyCon { data_cons = [c] } -> Just c+      TupleTyCon { data_con = c }   -> Just c+      NewTyCon { data_con = c }     -> Just c+      _                             -> Nothing+tyConSingleDataCon_maybe _           = Nothing++tyConSingleDataCon :: TyCon -> DataCon+tyConSingleDataCon tc+  = case tyConSingleDataCon_maybe tc of+      Just c  -> c+      Nothing -> pprPanic "tyConDataCon" (ppr tc)++tyConSingleAlgDataCon_maybe :: TyCon -> Maybe DataCon+-- Returns (Just con) for single-constructor+-- *algebraic* data types *not* newtypes+tyConSingleAlgDataCon_maybe (AlgTyCon { algTcRhs = rhs })+  = case rhs of+      DataTyCon { data_cons = [c] } -> Just c+      TupleTyCon { data_con = c }   -> Just c+      _                             -> Nothing+tyConSingleAlgDataCon_maybe _        = Nothing++-- | Determine the number of value constructors a 'TyCon' has. Panics if the+-- 'TyCon' is not algebraic or a tuple+tyConFamilySize  :: TyCon -> Int+tyConFamilySize tc@(AlgTyCon { algTcRhs = rhs })+  = case rhs of+      DataTyCon { data_cons = cons } -> length cons+      NewTyCon {}                    -> 1+      TupleTyCon {}                  -> 1+      SumTyCon { data_cons = cons }  -> length cons+      _                              -> pprPanic "tyConFamilySize 1" (ppr tc)+tyConFamilySize tc = pprPanic "tyConFamilySize 2" (ppr tc)++-- | Extract an 'AlgTyConRhs' with information about data constructors from an+-- algebraic or tuple 'TyCon'. Panics for any other sort of 'TyCon'+algTyConRhs :: TyCon -> AlgTyConRhs+algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs+algTyConRhs other = pprPanic "algTyConRhs" (ppr other)++-- | Extract type variable naming the result of injective type family+tyConFamilyResVar_maybe :: TyCon -> Maybe Name+tyConFamilyResVar_maybe (FamilyTyCon {famTcResVar = res}) = res+tyConFamilyResVar_maybe _                                 = Nothing++-- | Get the list of roles for the type parameters of a TyCon+tyConRoles :: TyCon -> [Role]+-- See also Note [TyCon Role signatures]+tyConRoles tc+  = case tc of+    { FunTyCon {}                         -> const_role Representational+    ; AlgTyCon { tcRoles = roles }        -> roles+    ; SynonymTyCon { tcRoles = roles }    -> roles+    ; FamilyTyCon {}                      -> const_role Nominal+    ; PrimTyCon { tcRoles = roles }       -> roles+    ; PromotedDataCon { tcRoles = roles } -> roles+    ; TcTyCon {}                          -> const_role Nominal+    }+  where+    const_role r = replicate (tyConArity tc) r++-- | Extract the bound type variables and type expansion of a type synonym+-- 'TyCon'. Panics if the 'TyCon' is not a synonym+newTyConRhs :: TyCon -> ([TyVar], Type)+newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rhs = rhs }})+    = (tvs, rhs)+newTyConRhs tycon = pprPanic "newTyConRhs" (ppr tycon)++-- | The number of type parameters that need to be passed to a newtype to+-- resolve it. May be less than in the definition if it can be eta-contracted.+newTyConEtadArity :: TyCon -> Int+newTyConEtadArity (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }})+        = length (fst tvs_rhs)+newTyConEtadArity tycon = pprPanic "newTyConEtadArity" (ppr tycon)++-- | Extract the bound type variables and type expansion of an eta-contracted+-- type synonym 'TyCon'.  Panics if the 'TyCon' is not a synonym+newTyConEtadRhs :: TyCon -> ([TyVar], Type)+newTyConEtadRhs (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }}) = tvs_rhs+newTyConEtadRhs tycon = pprPanic "newTyConEtadRhs" (ppr tycon)++-- | Extracts the @newtype@ coercion from such a 'TyCon', which can be used to+-- construct something with the @newtype@s type from its representation type+-- (right hand side). If the supplied 'TyCon' is not a @newtype@, returns+-- @Nothing@+newTyConCo_maybe :: TyCon -> Maybe (CoAxiom Unbranched)+newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = Just co+newTyConCo_maybe _                                               = Nothing++newTyConCo :: TyCon -> CoAxiom Unbranched+newTyConCo tc = case newTyConCo_maybe tc of+                 Just co -> co+                 Nothing -> pprPanic "newTyConCo" (ppr tc)++newTyConDataCon_maybe :: TyCon -> Maybe DataCon+newTyConDataCon_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = con }}) = Just con+newTyConDataCon_maybe _ = Nothing++-- | Find the \"stupid theta\" of the 'TyCon'. A \"stupid theta\" is the context+-- to the left of an algebraic type declaration, e.g. @Eq a@ in the declaration+-- @data Eq a => T a ...@+tyConStupidTheta :: TyCon -> [PredType]+tyConStupidTheta (AlgTyCon {algTcStupidTheta = stupid}) = stupid+tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon)++-- | Extract the 'TyVar's bound by a vanilla type synonym+-- and the corresponding (unsubstituted) right hand side.+synTyConDefn_maybe :: TyCon -> Maybe ([TyVar], Type)+synTyConDefn_maybe (SynonymTyCon {tyConTyVars = tyvars, synTcRhs = ty})+  = Just (tyvars, ty)+synTyConDefn_maybe _ = Nothing++-- | Extract the information pertaining to the right hand side of a type synonym+-- (@type@) declaration.+synTyConRhs_maybe :: TyCon -> Maybe Type+synTyConRhs_maybe (SynonymTyCon {synTcRhs = rhs}) = Just rhs+synTyConRhs_maybe _                               = Nothing++-- | Extract the flavour of a type family (with all the extra information that+-- it carries)+famTyConFlav_maybe :: TyCon -> Maybe FamTyConFlav+famTyConFlav_maybe (FamilyTyCon {famTcFlav = flav}) = Just flav+famTyConFlav_maybe _                                = Nothing++-- | Is this 'TyCon' that for a class instance?+isClassTyCon :: TyCon -> Bool+isClassTyCon (AlgTyCon {algTcParent = ClassTyCon {}}) = True+isClassTyCon _                                        = False++-- | If this 'TyCon' is that for a class instance, return the class it is for.+-- Otherwise returns @Nothing@+tyConClass_maybe :: TyCon -> Maybe Class+tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas _}) = Just clas+tyConClass_maybe _                                            = Nothing++-- | Return the associated types of the 'TyCon', if any+tyConATs :: TyCon -> [TyCon]+tyConATs (AlgTyCon {algTcParent = ClassTyCon clas _}) = classATs clas+tyConATs _                                            = []++----------------------------------------------------------------------------+-- | Is this 'TyCon' that for a data family instance?+isFamInstTyCon :: TyCon -> Bool+isFamInstTyCon (AlgTyCon {algTcParent = DataFamInstTyCon {} })+  = True+isFamInstTyCon _ = False++tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom Unbranched)+tyConFamInstSig_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax f ts })+  = Just (f, ts, ax)+tyConFamInstSig_maybe _ = Nothing++-- | If this 'TyCon' is that of a data family instance, return the family in question+-- and the instance types. Otherwise, return @Nothing@+tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type])+tyConFamInst_maybe (AlgTyCon {algTcParent = DataFamInstTyCon _ f ts })+  = Just (f, ts)+tyConFamInst_maybe _ = Nothing++-- | If this 'TyCon' is that of a data family instance, return a 'TyCon' which+-- represents a coercion identifying the representation type with the type+-- instance family.  Otherwise, return @Nothing@+tyConFamilyCoercion_maybe :: TyCon -> Maybe (CoAxiom Unbranched)+tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax _ _ })+  = Just ax+tyConFamilyCoercion_maybe _ = Nothing++-- | Extract any 'RuntimeRepInfo' from this TyCon+tyConRuntimeRepInfo :: TyCon -> RuntimeRepInfo+tyConRuntimeRepInfo (PromotedDataCon { promDcRepInfo = rri }) = rri+tyConRuntimeRepInfo _                                         = NoRRI+  -- could panic in that second case. But Douglas Adams told me not to.++{-+************************************************************************+*                                                                      *+\subsection[TyCon-instances]{Instance declarations for @TyCon@}+*                                                                      *+************************************************************************++@TyCon@s are compared by comparing their @Unique@s.+-}++instance Eq TyCon where+    a == b = getUnique a == getUnique b+    a /= b = getUnique a /= getUnique b++instance Uniquable TyCon where+    getUnique tc = tyConUnique tc++instance Outputable TyCon where+  -- At the moment a promoted TyCon has the same Name as its+  -- corresponding TyCon, so we add the quote to distinguish it here+  ppr tc = pprPromotionQuote tc <> ppr (tyConName tc)++tyConFlavour :: TyCon -> String+tyConFlavour (AlgTyCon { algTcParent = parent, algTcRhs = rhs })+  | ClassTyCon _ _ <- parent = "class"+  | otherwise = case rhs of+                  TupleTyCon { tup_sort = sort }+                     | isBoxed (tupleSortBoxity sort) -> "tuple"+                     | otherwise                      -> "unboxed tuple"+                  SumTyCon {}        -> "unboxed sum"+                  DataTyCon {}       -> "data type"+                  NewTyCon {}        -> "newtype"+                  AbstractTyCon {}   -> "abstract type"+tyConFlavour (FamilyTyCon { famTcFlav = flav })+  | isDataFamFlav flav            = "data family"+  | otherwise                     = "type family"+tyConFlavour (SynonymTyCon {})    = "type synonym"+tyConFlavour (FunTyCon {})        = "built-in type"+tyConFlavour (PrimTyCon {})       = "built-in type"+tyConFlavour (PromotedDataCon {}) = "promoted data constructor"+tyConFlavour tc@(TcTyCon {})+  = pprPanic "tyConFlavour sees a TcTyCon" (ppr tc)++pprPromotionQuote :: TyCon -> SDoc+-- Promoted data constructors already have a tick in their OccName+pprPromotionQuote tc+  = case tc of+      PromotedDataCon {} -> char '\'' -- Always quote promoted DataCons in types+      _                  -> empty++instance NamedThing TyCon where+    getName = tyConName++instance Data.Data TyCon where+    -- don't traverse?+    toConstr _   = abstractConstr "TyCon"+    gunfold _ _  = error "gunfold"+    dataTypeOf _ = mkNoRepType "TyCon"++instance Binary Injectivity where+    put_ bh NotInjective   = putByte bh 0+    put_ bh (Injective xs) = putByte bh 1 >> put_ bh xs++    get bh = do { h <- getByte bh+                ; case h of+                    0 -> return NotInjective+                    _ -> do { xs <- get bh+                            ; return (Injective xs) } }++{-+************************************************************************+*                                                                      *+           Walking over recursive TyCons+*                                                                      *+************************************************************************++Note [Expanding newtypes and products]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When expanding a type to expose a data-type constructor, we need to be+careful about newtypes, lest we fall into an infinite loop. Here are+the key examples:++  newtype Id  x = MkId x+  newtype Fix f = MkFix (f (Fix f))+  newtype T     = MkT (T -> T)++  Type           Expansion+ --------------------------+  T              T -> T+  Fix Maybe      Maybe (Fix Maybe)+  Id (Id Int)    Int+  Fix Id         NO NO NO++Notice that+ * We can expand T, even though it's recursive.+ * We can expand Id (Id Int), even though the Id shows up+   twice at the outer level, because Id is non-recursive++So, when expanding, we keep track of when we've seen a recursive+newtype at outermost level; and bail out if we see it again.++We sometimes want to do the same for product types, so that the+strictness analyser doesn't unbox infinitely deeply.++More precisely, we keep a *count* of how many times we've seen it.+This is to account for+   data instance T (a,b) = MkT (T a) (T b)+Then (Trac #10482) if we have a type like+        T (Int,(Int,(Int,(Int,Int))))+we can still unbox deeply enough during strictness analysis.+We have to treat T as potentially recursive, but it's still+good to be able to unwrap multiple layers.++The function that manages all this is checkRecTc.+-}++data RecTcChecker = RC !Int (NameEnv Int)+  -- The upper bound, and the number of times+  -- we have encountered each TyCon++initRecTc :: RecTcChecker+-- Intialise with a fixed max bound of 100+-- We should probably have a flag for this+initRecTc = RC 100 emptyNameEnv++checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker+-- Nothing      => Recursion detected+-- Just rec_tcs => Keep going+checkRecTc (RC bound rec_nts) tc+  = case lookupNameEnv rec_nts tc_name of+      Just n | n >= bound -> Nothing+             | otherwise  -> Just (RC bound (extendNameEnv rec_nts tc_name (n+1)))+      Nothing             -> Just (RC bound (extendNameEnv rec_nts tc_name 1))+  where+    tc_name = tyConName tc++-- | Returns whether or not this 'TyCon' is definite, or a hole+-- that may be filled in at some later point.  See Note [Skolem abstract data]+tyConSkolem :: TyCon -> Bool+tyConSkolem = isHoleName . tyConName++-- Note [Skolem abstract data]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Skolem abstract data arises from data declarations in an hsig file.+--+-- The best analogy is to interpret the types declared in signature files as+-- elaborating to universally quantified type variables; e.g.,+--+--    unit p where+--        signature H where+--            data T+--            data S+--        module M where+--            import H+--            f :: (T ~ S) => a -> b+--            f x = x+--+-- elaborates as (with some fake structural types):+--+--    p :: forall t s. { f :: forall a b. t ~ s => a -> b }+--    p = { f = \x -> x } -- ill-typed+--+-- It is clear that inside p, t ~ s is not provable (and+-- if we tried to write a function to cast t to s, that+-- would not work), but if we call p @Int @Int, clearly Int ~ Int+-- is provable.  The skolem variables are all distinct from+-- one another, but we can't make assumptions like "f is+-- inaccessible", because the skolem variables will get+-- instantiated eventually!+--+-- Skolem abstractness can apply to "non-abstract" data as well):+--+--    unit p where+--        signature H1 where+--            data T = MkT+--        signature H2 where+--            data T = MkT+--        module M where+--            import qualified H1+--            import qualified H2+--            f :: (H1.T ~ H2.T) => a -> b+--            f x = x+--+-- This is why the test is on the original name of the TyCon,+-- not whether it is abstract or not.
+ types/TyCon.hs-boot view
@@ -0,0 +1,7 @@+module TyCon where++data TyCon++isTupleTyCon        :: TyCon -> Bool+isUnboxedTupleTyCon :: TyCon -> Bool+isFunTyCon          :: TyCon -> Bool
+ types/Type.hs view
@@ -0,0 +1,2464 @@+-- (c) The University of Glasgow 2006+-- (c) The GRASP/AQUA Project, Glasgow University, 1998+--+-- Type - public interface++{-# LANGUAGE CPP, FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Main functions for manipulating types and type-related things+module Type (+        -- Note some of this is just re-exports from TyCon..++        -- * Main data types representing Types+        -- $type_classification++        -- $representation_types+        TyThing(..), Type, ArgFlag(..), KindOrType, PredType, ThetaType,+        Var, TyVar, isTyVar, TyCoVar, TyBinder, TyVarBinder,++        -- ** Constructing and deconstructing types+        mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, repGetTyVar_maybe,+        getCastedTyVar_maybe, tyVarKind,++        mkAppTy, mkAppTys, splitAppTy, splitAppTys, repSplitAppTys,+        splitAppTy_maybe, repSplitAppTy_maybe, tcRepSplitAppTy_maybe,++        mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe,+        splitFunTys, funResultTy, funArgTy,++        mkTyConApp, mkTyConTy,+        tyConAppTyCon_maybe, tyConAppTyConPicky_maybe,+        tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs,+        splitTyConApp_maybe, splitTyConApp, tyConAppArgN, nextRole,+        tcRepSplitTyConApp_maybe, tcSplitTyConApp_maybe,+        splitListTyConApp_maybe,+        repSplitTyConApp_maybe,++        mkForAllTy, mkForAllTys, mkInvForAllTys, mkSpecForAllTys,+        mkVisForAllTys, mkInvForAllTy,+        splitForAllTys, splitForAllTyVarBndrs,+        splitForAllTy_maybe, splitForAllTy,+        splitPiTy_maybe, splitPiTy, splitPiTys,+        mkPiTy, mkPiTys, mkTyConBindersPreferAnon,+        mkLamType, mkLamTypes,+        piResultTy, piResultTys,+        applyTysX, dropForAlls,++        mkNumLitTy, isNumLitTy,+        mkStrLitTy, isStrLitTy,++        getRuntimeRep_maybe, getRuntimeRepFromKind_maybe,++        mkCastTy, mkCoercionTy, splitCastTy_maybe,++        userTypeError_maybe, pprUserTypeErrorTy,++        coAxNthLHS,+        stripCoercionTy, splitCoercionType_maybe,++        splitPiTysInvisible, filterOutInvisibleTypes,+        filterOutInvisibleTyVars, partitionInvisibles,+        synTyConResKind,++        modifyJoinResTy, setJoinResTy,++        -- Analyzing types+        TyCoMapper(..), mapType, mapCoercion,++        -- (Newtypes)+        newTyConInstRhs,++        -- Pred types+        mkFamilyTyConApp,+        isDictLikeTy,+        mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole,+        equalityTyCon,+        mkHeteroPrimEqPred, mkHeteroReprPrimEqPred,+        mkClassPred,+        isClassPred, isEqPred, isNomEqPred,+        isIPPred, isIPPred_maybe, isIPTyCon, isIPClass,+        isCTupleClass,++        -- Deconstructing predicate types+        PredTree(..), EqRel(..), eqRelRole, classifyPredType,+        getClassPredTys, getClassPredTys_maybe,+        getEqPredTys, getEqPredTys_maybe, getEqPredRole,+        predTypeEqRel,++        -- ** Binders+        sameVis,+        mkTyVarBinder, mkTyVarBinders,+        mkAnonBinder,+        isAnonTyBinder, isNamedTyBinder,+        binderVar, binderVars, binderKind, binderArgFlag,+        tyBinderType,+        binderRelevantType_maybe, caseBinder,+        isVisibleArgFlag, isInvisibleArgFlag, isVisibleBinder, isInvisibleBinder,+        tyConBindersTyBinders,+        mkTyBinderTyConBinder,++        -- ** Common type constructors+        funTyCon,++        -- ** Predicates on types+        isTyVarTy, isFunTy, isDictTy, isPredTy, isCoercionTy,+        isCoercionTy_maybe, isCoercionType, isForAllTy,+        isPiTy, isTauTy, isFamFreeTy,++        isValidJoinPointType,++        -- (Lifting and boxity)+        isLiftedType_maybe, isUnliftedType, isUnboxedTupleType, isUnboxedSumType,+        isAlgType, isClosedAlgType, isDataFamilyAppType,+        isPrimitiveType, isStrictType,+        isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy,+        dropRuntimeRepArgs,+        getRuntimeRep, getRuntimeRepFromKind,++        -- * Main data types representing Kinds+        Kind,++        -- ** Finding the kind of a type+        typeKind, isTypeLevPoly, resultIsLevPoly,++        -- ** Common Kind+        liftedTypeKind,++        -- * Type free variables+        tyCoFVsOfType, tyCoFVsBndr,+        tyCoVarsOfType, tyCoVarsOfTypes,+        tyCoVarsOfTypeDSet,+        coVarsOfType,+        coVarsOfTypes, closeOverKinds, closeOverKindsList,+        noFreeVarsOfType,+        splitVisVarsOfType, splitVisVarsOfTypes,+        expandTypeSynonyms,+        typeSize,++        -- * Well-scoped lists of variables+        dVarSetElemsWellScoped, toposortTyVars, tyCoVarsOfTypeWellScoped,+        tyCoVarsOfTypesWellScoped,++        -- * Type comparison+        eqType, eqTypeX, eqTypes, nonDetCmpType, nonDetCmpTypes, nonDetCmpTypeX,+        nonDetCmpTypesX, nonDetCmpTc,+        eqVarBndrs,++        -- * Forcing evaluation of types+        seqType, seqTypes,++        -- * Other views onto Types+        coreView, tcView,++        tyConsOfType,++        -- * Main type substitution data types+        TvSubstEnv,     -- Representation widely visible+        TCvSubst(..),    -- Representation visible to a few friends++        -- ** Manipulating type substitutions+        emptyTvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst,++        mkTCvSubst, zipTvSubst, mkTvSubstPrs,+        notElemTCvSubst,+        getTvSubstEnv, setTvSubstEnv,+        zapTCvSubst, getTCvInScope, getTCvSubstRangeFVs,+        extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet,+        extendTCvSubst, extendCvSubst,+        extendTvSubst, extendTvSubstBinder,+        extendTvSubstList, extendTvSubstAndInScope,+        extendTvSubstWithClone,+        isInScope, composeTCvSubstEnv, composeTCvSubst, zipTyEnv, zipCoEnv,+        isEmptyTCvSubst, unionTCvSubst,++        -- ** Performing substitution on types and kinds+        substTy, substTys, substTyWith, substTysWith, substTheta,+        substTyAddInScope,+        substTyUnchecked, substTysUnchecked, substThetaUnchecked,+        substTyWithUnchecked,+        substCoUnchecked, substCoWithUnchecked,+        substTyVarBndr, substTyVar, substTyVars,+        cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar,++        -- * Pretty-printing+        pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprShortTyThing,+        pprTvBndr, pprTvBndrs, pprForAll, pprUserForAll,+        pprSigmaType, ppSuggestExplicitKinds,+        pprTheta, pprThetaArrowTy, pprClassPred,+        pprKind, pprParendKind, pprSourceTyCon,+        TyPrec(..), maybeParen,+        pprTyVar, pprTyVars, pprPrefixApp, pprArrowChain,++        -- * Tidying type related things up for printing+        tidyType,      tidyTypes,+        tidyOpenType,  tidyOpenTypes,+        tidyOpenKind,+        tidyTyCoVarBndr, tidyTyCoVarBndrs, tidyFreeTyCoVars,+        tidyOpenTyCoVar, tidyOpenTyCoVars,+        tidyTyVarOcc,+        tidyTopType,+        tidyKind,+        tidyTyVarBinder, tidyTyVarBinders+    ) where++#include "HsVersions.h"++import BasicTypes++-- We import the representation and primitive functions from TyCoRep.+-- Many things are reexported, but not the representation!++import Kind+import TyCoRep++-- friends:+import Var+import VarEnv+import VarSet+import UniqSet++import Class+import TyCon+import TysPrim+import {-# SOURCE #-} TysWiredIn ( listTyCon, typeNatKind+                                 , typeSymbolKind, liftedTypeKind )+import PrelNames+import CoAxiom+import {-# SOURCE #-} Coercion++-- others+import Util+import Outputable+import FastString+import Pair+import ListSetOps+import Digraph+import Unique ( nonDetCmpUnique )+import SrcLoc  ( SrcSpan )+import OccName ( OccName )+import Name    ( mkInternalName )++import Maybes           ( orElse )+import Data.Maybe       ( isJust, mapMaybe )+import Control.Monad    ( guard )+import Control.Arrow    ( first, second )++-- $type_classification+-- #type_classification#+--+-- Types are one of:+--+-- [Unboxed]            Iff its representation is other than a pointer+--                      Unboxed types are also unlifted.+--+-- [Lifted]             Iff it has bottom as an element.+--                      Closures always have lifted types: i.e. any+--                      let-bound identifier in Core must have a lifted+--                      type. Operationally, a lifted object is one that+--                      can be entered.+--                      Only lifted types may be unified with a type variable.+--+-- [Algebraic]          Iff it is a type with one or more constructors, whether+--                      declared with @data@ or @newtype@.+--                      An algebraic type is one that can be deconstructed+--                      with a case expression. This is /not/ the same as+--                      lifted types, because we also include unboxed+--                      tuples in this classification.+--+-- [Data]               Iff it is a type declared with @data@, or a boxed tuple.+--+-- [Primitive]          Iff it is a built-in type that can't be expressed in Haskell.+--+-- Currently, all primitive types are unlifted, but that's not necessarily+-- the case: for example, @Int@ could be primitive.+--+-- Some primitive types are unboxed, such as @Int#@, whereas some are boxed+-- but unlifted (such as @ByteArray#@).  The only primitive types that we+-- classify as algebraic are the unboxed tuples.+--+-- Some examples of type classifications that may make this a bit clearer are:+--+-- @+-- Type          primitive       boxed           lifted          algebraic+-- -----------------------------------------------------------------------------+-- Int#          Yes             No              No              No+-- ByteArray#    Yes             Yes             No              No+-- (\# a, b \#)  Yes             No              No              Yes+-- (\# a | b \#) Yes             No              No              Yes+-- (  a, b  )    No              Yes             Yes             Yes+-- [a]           No              Yes             Yes             Yes+-- @++-- $representation_types+-- A /source type/ is a type that is a separate type as far as the type checker is+-- concerned, but which has a more low-level representation as far as Core-to-Core+-- passes and the rest of the back end is concerned.+--+-- You don't normally have to worry about this, as the utility functions in+-- this module will automatically convert a source into a representation type+-- if they are spotted, to the best of it's abilities. If you don't want this+-- to happen, use the equivalent functions from the "TcType" module.++{-+************************************************************************+*                                                                      *+                Type representation+*                                                                      *+************************************************************************++Note [coreView vs tcView]+~~~~~~~~~~~~~~~~~~~~~~~~~+So far as the typechecker is concerned, 'Constraint' and 'TYPE LiftedRep' are distinct kinds.++But in Core these two are treated as identical.++We implement this by making 'coreView' convert 'Constraint' to 'TYPE LiftedRep' on the fly.+The function tcView (used in the type checker) does not do this.++See also Trac #11715, which tracks removing this inconsistency.++-}++{-# INLINE coreView #-}+coreView :: Type -> Maybe Type+-- ^ This function Strips off the /top layer only/ of a type synonym+-- application (if any) its underlying representation type.+-- Returns Nothing if there is nothing to look through.+-- This function considers 'Constraint' to be a synonym of @TYPE LiftedRep@.+--+-- By being non-recursive and inlined, this case analysis gets efficiently+-- joined onto the case analysis that the caller is already doing+coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys+  = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys')+               -- The free vars of 'rhs' should all be bound by 'tenv', so it's+               -- ok to use 'substTy' here.+               -- See also Note [The substitution invariant] in TyCoRep.+               -- Its important to use mkAppTys, rather than (foldl AppTy),+               -- because the function part might well return a+               -- partially-applied type constructor; indeed, usually will!+coreView (TyConApp tc [])+  | isStarKindSynonymTyCon tc+  = Just liftedTypeKind++coreView _ = Nothing++-- | Gives the typechecker view of a type. This unwraps synonyms but+-- leaves 'Constraint' alone. c.f. coreView, which turns Constraint into+-- TYPE LiftedRep. Returns Nothing if no unwrapping happens.+-- See also Note [coreView vs tcView] in Type.+{-# INLINE tcView #-}+tcView :: Type -> Maybe Type+tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys+  = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys')+               -- The free vars of 'rhs' should all be bound by 'tenv', so it's+               -- ok to use 'substTy' here.+               -- See also Note [The substitution invariant] in TyCoRep.+               -- Its important to use mkAppTys, rather than (foldl AppTy),+               -- because the function part might well return a+               -- partially-applied type constructor; indeed, usually will!+tcView _ = Nothing++-----------------------------------------------+expandTypeSynonyms :: Type -> Type+-- ^ Expand out all type synonyms.  Actually, it'd suffice to expand out+-- just the ones that discard type variables (e.g.  type Funny a = Int)+-- But we don't know which those are currently, so we just expand all.+--+-- 'expandTypeSynonyms' only expands out type synonyms mentioned in the type,+-- not in the kinds of any TyCon or TyVar mentioned in the type.+--+-- Keep this synchronized with 'synonymTyConsOfType'+expandTypeSynonyms ty+  = go (mkEmptyTCvSubst in_scope) ty+  where+    in_scope = mkInScopeSet (tyCoVarsOfType ty)++    go subst (TyConApp tc tys)+      | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc expanded_tys+      = let subst' = mkTvSubst in_scope (mkVarEnv tenv)+            -- Make a fresh substitution; rhs has nothing to+            -- do with anything that has happened so far+            -- NB: if you make changes here, be sure to build an+            --     /idempotent/ substitution, even in the nested case+            --        type T a b = a -> b+            --        type S x y = T y x+            -- (Trac #11665)+        in  mkAppTys (go subst' rhs) tys'+      | otherwise+      = TyConApp tc expanded_tys+      where+        expanded_tys = (map (go subst) tys)++    go _     (LitTy l)     = LitTy l+    go subst (TyVarTy tv)  = substTyVar subst tv+    go subst (AppTy t1 t2) = mkAppTy (go subst t1) (go subst t2)+    go subst (FunTy arg res)+      = mkFunTy (go subst arg) (go subst res)+    go subst (ForAllTy (TvBndr tv vis) t)+      = let (subst', tv') = substTyVarBndrCallback go subst tv in+        ForAllTy (TvBndr tv' vis) (go subst' t)+    go subst (CastTy ty co)  = mkCastTy (go subst ty) (go_co subst co)+    go subst (CoercionTy co) = mkCoercionTy (go_co subst co)++    go_co subst (Refl r ty)+      = mkReflCo r (go subst ty)+       -- NB: coercions are always expanded upon creation+    go_co subst (TyConAppCo r tc args)+      = mkTyConAppCo r tc (map (go_co subst) args)+    go_co subst (AppCo co arg)+      = mkAppCo (go_co subst co) (go_co subst arg)+    go_co subst (ForAllCo tv kind_co co)+      = let (subst', tv', kind_co') = go_cobndr subst tv kind_co in+        mkForAllCo tv' kind_co' (go_co subst' co)+    go_co subst (FunCo r co1 co2)+      = mkFunCo r (go_co subst co1) (go_co subst co2)+    go_co subst (CoVarCo cv)+      = substCoVar subst cv+    go_co subst (AxiomInstCo ax ind args)+      = mkAxiomInstCo ax ind (map (go_co subst) args)+    go_co subst (UnivCo p r t1 t2)+      = mkUnivCo (go_prov subst p) r (go subst t1) (go subst t2)+    go_co subst (SymCo co)+      = mkSymCo (go_co subst co)+    go_co subst (TransCo co1 co2)+      = mkTransCo (go_co subst co1) (go_co subst co2)+    go_co subst (NthCo n co)+      = mkNthCo n (go_co subst co)+    go_co subst (LRCo lr co)+      = mkLRCo lr (go_co subst co)+    go_co subst (InstCo co arg)+      = mkInstCo (go_co subst co) (go_co subst arg)+    go_co subst (CoherenceCo co1 co2)+      = mkCoherenceCo (go_co subst co1) (go_co subst co2)+    go_co subst (KindCo co)+      = mkKindCo (go_co subst co)+    go_co subst (SubCo co)+      = mkSubCo (go_co subst co)+    go_co subst (AxiomRuleCo ax cs) = AxiomRuleCo ax (map (go_co subst) cs)++    go_prov _     UnsafeCoerceProv    = UnsafeCoerceProv+    go_prov subst (PhantomProv co)    = PhantomProv (go_co subst co)+    go_prov subst (ProofIrrelProv co) = ProofIrrelProv (go_co subst co)+    go_prov _     p@(PluginProv _)    = p+    go_prov _     (HoleProv h)        = pprPanic "expandTypeSynonyms hit a hole" (ppr h)++      -- the "False" and "const" are to accommodate the type of+      -- substForAllCoBndrCallback, which is general enough to+      -- handle coercion optimization (which sometimes swaps the+      -- order of a coercion)+    go_cobndr subst = substForAllCoBndrCallback False (go_co subst) subst++{-+************************************************************************+*                                                                      *+   Analyzing types+*                                                                      *+************************************************************************++These functions do a map-like operation over types, performing some operation+on all variables and binding sites. Primarily used for zonking.++Note [Efficiency for mapCoercion ForAllCo case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As noted in Note [Forall coercions] in TyCoRep, a ForAllCo is a bit redundant.+It stores a TyVar and a Coercion, where the kind of the TyVar always matches+the left-hand kind of the coercion. This is convenient lots of the time, but+not when mapping a function over a coercion.++The problem is that tcm_tybinder will affect the TyVar's kind and+mapCoercion will affect the Coercion, and we hope that the results will be+the same. Even if they are the same (which should generally happen with+correct algorithms), then there is an efficiency issue. In particular,+this problem seems to make what should be a linear algorithm into a potentially+exponential one. But it's only going to be bad in the case where there's+lots of foralls in the kinds of other foralls. Like this:++  forall a : (forall b : (forall c : ...). ...). ...++This construction seems unlikely. So we'll do the inefficient, easy way+for now.++Note [Specialising mappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+These INLINABLE pragmas are indispensable. mapType/mapCoercion are used+to implement zonking, and it's vital that they get specialised to the TcM+monad. This specialisation happens automatically (that is, without a+SPECIALISE pragma) as long as the definitions are INLINABLE. For example,+this one change made a 20% allocation difference in perf/compiler/T5030.++-}++-- | This describes how a "map" operation over a type/coercion should behave+data TyCoMapper env m+  = TyCoMapper+      { tcm_smart :: Bool -- ^ Should the new type be created with smart+                         -- constructors?+      , tcm_tyvar :: env -> TyVar -> m Type+      , tcm_covar :: env -> CoVar -> m Coercion+      , tcm_hole  :: env -> CoercionHole -> Role+                  -> Type -> Type -> m Coercion+          -- ^ What to do with coercion holes. See Note [Coercion holes] in+          -- TyCoRep.++      , tcm_tybinder :: env -> TyVar -> ArgFlag -> m (env, TyVar)+          -- ^ The returned env is used in the extended scope+      }++{-# INLINABLE mapType #-}  -- See Note [Specialising mappers]+mapType :: Monad m => TyCoMapper env m -> env -> Type -> m Type+mapType mapper@(TyCoMapper { tcm_smart = smart, tcm_tyvar = tyvar+                           , tcm_tybinder = tybinder })+        env ty+  = go ty+  where+    go (TyVarTy tv) = tyvar env tv+    go (AppTy t1 t2) = mkappty <$> go t1 <*> go t2+    go t@(TyConApp _ []) = return t  -- avoid allocation in this exceedingly+                                     -- common case (mostly, for *)+    go (TyConApp tc tys) = mktyconapp tc <$> mapM go tys+    go (FunTy arg res)   = FunTy <$> go arg <*> go res+    go (ForAllTy (TvBndr tv vis) inner)+      = do { (env', tv') <- tybinder env tv vis+           ; inner' <- mapType mapper env' inner+           ; return $ ForAllTy (TvBndr tv' vis) inner' }+    go ty@(LitTy {})   = return ty+    go (CastTy ty co)  = mkcastty <$> go ty <*> mapCoercion mapper env co+    go (CoercionTy co) = CoercionTy <$> mapCoercion mapper env co++    (mktyconapp, mkappty, mkcastty)+      | smart     = (mkTyConApp, mkAppTy, mkCastTy)+      | otherwise = (TyConApp,   AppTy,   CastTy)++{-# INLINABLE mapCoercion #-}  -- See Note [Specialising mappers]+mapCoercion :: Monad m+            => TyCoMapper env m -> env -> Coercion -> m Coercion+mapCoercion mapper@(TyCoMapper { tcm_smart = smart, tcm_covar = covar+                               , tcm_hole = cohole, tcm_tybinder = tybinder })+            env co+  = go co+  where+    go (Refl r ty) = Refl r <$> mapType mapper env ty+    go (TyConAppCo r tc args)+      = mktyconappco r tc <$> mapM go args+    go (AppCo c1 c2) = mkappco <$> go c1 <*> go c2+    go (ForAllCo tv kind_co co)+      = do { kind_co' <- go kind_co+           ; (env', tv') <- tybinder env tv Inferred+           ; co' <- mapCoercion mapper env' co+           ; return $ mkforallco tv' kind_co' co' }+        -- See Note [Efficiency for mapCoercion ForAllCo case]+    go (FunCo r c1 c2) = mkFunCo r <$> go c1 <*> go c2+    go (CoVarCo cv) = covar env cv+    go (AxiomInstCo ax i args)+      = mkaxiominstco ax i <$> mapM go args+    go (UnivCo (HoleProv hole) r t1 t2)+      = cohole env hole r t1 t2+    go (UnivCo p r t1 t2)+      = mkunivco <$> go_prov p <*> pure r+                 <*> mapType mapper env t1 <*> mapType mapper env t2+    go (SymCo co) = mksymco <$> go co+    go (TransCo c1 c2) = mktransco <$> go c1 <*> go c2+    go (AxiomRuleCo r cos) = AxiomRuleCo r <$> mapM go cos+    go (NthCo i co)        = mknthco i <$> go co+    go (LRCo lr co)        = mklrco lr <$> go co+    go (InstCo co arg)     = mkinstco <$> go co <*> go arg+    go (CoherenceCo c1 c2) = mkcoherenceco <$> go c1 <*> go c2+    go (KindCo co)         = mkkindco <$> go co+    go (SubCo co)          = mksubco <$> go co++    go_prov UnsafeCoerceProv    = return UnsafeCoerceProv+    go_prov (PhantomProv co)    = PhantomProv <$> go co+    go_prov (ProofIrrelProv co) = ProofIrrelProv <$> go co+    go_prov p@(PluginProv _)    = return p+    go_prov (HoleProv _)        = panic "mapCoercion"++    ( mktyconappco, mkappco, mkaxiominstco, mkunivco+      , mksymco, mktransco, mknthco, mklrco, mkinstco, mkcoherenceco+      , mkkindco, mksubco, mkforallco)+      | smart+      = ( mkTyConAppCo, mkAppCo, mkAxiomInstCo, mkUnivCo+        , mkSymCo, mkTransCo, mkNthCo, mkLRCo, mkInstCo, mkCoherenceCo+        , mkKindCo, mkSubCo, mkForAllCo )+      | otherwise+      = ( TyConAppCo, AppCo, AxiomInstCo, UnivCo+        , SymCo, TransCo, NthCo, LRCo, InstCo, CoherenceCo+        , KindCo, SubCo, ForAllCo )++{-+************************************************************************+*                                                                      *+\subsection{Constructor-specific functions}+*                                                                      *+************************************************************************+++---------------------------------------------------------------------+                                TyVarTy+                                ~~~~~~~+-}++-- | Attempts to obtain the type variable underlying a 'Type', and panics with the+-- given message if this is not a type variable type. See also 'getTyVar_maybe'+getTyVar :: String -> Type -> TyVar+getTyVar msg ty = case getTyVar_maybe ty of+                    Just tv -> tv+                    Nothing -> panic ("getTyVar: " ++ msg)++isTyVarTy :: Type -> Bool+isTyVarTy ty = isJust (getTyVar_maybe ty)++-- | Attempts to obtain the type variable underlying a 'Type'+getTyVar_maybe :: Type -> Maybe TyVar+getTyVar_maybe ty | Just ty' <- coreView ty = getTyVar_maybe ty'+                  | otherwise               = repGetTyVar_maybe ty++-- | If the type is a tyvar, possibly under a cast, returns it, along+-- with the coercion. Thus, the co is :: kind tv ~R kind type+getCastedTyVar_maybe :: Type -> Maybe (TyVar, Coercion)+getCastedTyVar_maybe ty | Just ty' <- coreView ty = getCastedTyVar_maybe ty'+getCastedTyVar_maybe (CastTy (TyVarTy tv) co)     = Just (tv, co)+getCastedTyVar_maybe (TyVarTy tv)+  = Just (tv, mkReflCo Nominal (tyVarKind tv))+getCastedTyVar_maybe _                            = Nothing++-- | Attempts to obtain the type variable underlying a 'Type', without+-- any expansion+repGetTyVar_maybe :: Type -> Maybe TyVar+repGetTyVar_maybe (TyVarTy tv) = Just tv+repGetTyVar_maybe _            = Nothing++{-+---------------------------------------------------------------------+                                AppTy+                                ~~~~~+We need to be pretty careful with AppTy to make sure we obey the+invariant that a TyConApp is always visibly so.  mkAppTy maintains the+invariant: use it.++Note [Decomposing fat arrow c=>t]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Can we unify (a b) with (Eq a => ty)?   If we do so, we end up with+a partial application like ((=>) Eq a) which doesn't make sense in+source Haskell.  In contrast, we *can* unify (a b) with (t1 -> t2).+Here's an example (Trac #9858) of how you might do it:+   i :: (Typeable a, Typeable b) => Proxy (a b) -> TypeRep+   i p = typeRep p++   j = i (Proxy :: Proxy (Eq Int => Int))+The type (Proxy (Eq Int => Int)) is only accepted with -XImpredicativeTypes,+but suppose we want that.  But then in the call to 'i', we end+up decomposing (Eq Int => Int), and we definitely don't want that.++This really only applies to the type checker; in Core, '=>' and '->'+are the same, as are 'Constraint' and '*'.  But for now I've put+the test in repSplitAppTy_maybe, which applies throughout, because+the other calls to splitAppTy are in Unify, which is also used by+the type checker (e.g. when matching type-function equations).++-}++-- | Applies a type to another, as in e.g. @k a@+mkAppTy :: Type -> Type -> Type+mkAppTy (TyConApp tc tys) ty2 = mkTyConApp tc (tys ++ [ty2])+mkAppTy ty1               ty2 = AppTy ty1 ty2+        -- Note that the TyConApp could be an+        -- under-saturated type synonym.  GHC allows that; e.g.+        --      type Foo k = k a -> k a+        --      type Id x = x+        --      foo :: Foo Id -> Foo Id+        --+        -- Here Id is partially applied in the type sig for Foo,+        -- but once the type synonyms are expanded all is well++mkAppTys :: Type -> [Type] -> Type+mkAppTys ty1                []   = ty1+mkAppTys (TyConApp tc tys1) tys2 = mkTyConApp tc (tys1 ++ tys2)+mkAppTys ty1                tys2 = foldl AppTy ty1 tys2++-------------+splitAppTy_maybe :: Type -> Maybe (Type, Type)+-- ^ Attempt to take a type application apart, whether it is a+-- function, type constructor, or plain type application. Note+-- that type family applications are NEVER unsaturated by this!+splitAppTy_maybe ty | Just ty' <- coreView ty+                    = splitAppTy_maybe ty'+splitAppTy_maybe ty = repSplitAppTy_maybe ty++-------------+repSplitAppTy_maybe :: Type -> Maybe (Type,Type)+-- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that+-- any Core view stuff is already done+repSplitAppTy_maybe (FunTy ty1 ty2)+  | Just rep1 <- getRuntimeRep_maybe ty1+  , Just rep2 <- getRuntimeRep_maybe ty2+  = Just (TyConApp funTyCon [rep1, rep2, ty1], ty2)++  | otherwise+  = pprPanic "repSplitAppTy_maybe" (ppr ty1 $$ ppr ty2)+repSplitAppTy_maybe (AppTy ty1 ty2)+  = Just (ty1, ty2)+repSplitAppTy_maybe (TyConApp tc tys)+  | mightBeUnsaturatedTyCon tc || tys `lengthExceeds` tyConArity tc+  , Just (tys', ty') <- snocView tys+  = Just (TyConApp tc tys', ty')    -- Never create unsaturated type family apps!+repSplitAppTy_maybe _other = Nothing++-- this one doesn't braek apart (c => t).+-- See Note [Decomposing fat arrow c=>t]+-- Defined here to avoid module loops between Unify and TcType.+tcRepSplitAppTy_maybe :: Type -> Maybe (Type,Type)+-- ^ Does the AppTy split as in 'tcSplitAppTy_maybe', but assumes that+-- any coreView stuff is already done. Refuses to look through (c => t)+tcRepSplitAppTy_maybe (FunTy ty1 ty2)+  | isConstraintKind (typeKind ty1)+  = Nothing  -- See Note [Decomposing fat arrow c=>t]++  | Just rep1 <- getRuntimeRep_maybe ty1+  , Just rep2 <- getRuntimeRep_maybe ty2+  = Just (TyConApp funTyCon [rep1, rep2, ty1], ty2)++  | otherwise+  = pprPanic "repSplitAppTy_maybe" (ppr ty1 $$ ppr ty2)+tcRepSplitAppTy_maybe (AppTy ty1 ty2)    = Just (ty1, ty2)+tcRepSplitAppTy_maybe (TyConApp tc tys)+  | mightBeUnsaturatedTyCon tc || tys `lengthExceeds` tyConArity tc+  , Just (tys', ty') <- snocView tys+  = Just (TyConApp tc tys', ty')    -- Never create unsaturated type family apps!+tcRepSplitAppTy_maybe _other = Nothing++-- | Split a type constructor application into its type constructor and+-- applied types. Note that this may fail in the case of a 'FunTy' with an+-- argument of unknown kind 'FunTy' (e.g. @FunTy (a :: k) Int@. since the kind+-- of @a@ isn't of the form @TYPE rep@). Consequently, you may need to zonk your+-- type before using this function.+--+-- If you only need the 'TyCon', consider using 'tcTyConAppTyCon_maybe'.+tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type])+-- Defined here to avoid module loops between Unify and TcType.+tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty'+tcSplitTyConApp_maybe ty                         = tcRepSplitTyConApp_maybe ty++-- | Like 'tcSplitTyConApp_maybe' but doesn't look through type synonyms.+tcRepSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type])+-- Defined here to avoid module loops between Unify and TcType.+tcRepSplitTyConApp_maybe (TyConApp tc tys)          = Just (tc, tys)+tcRepSplitTyConApp_maybe (FunTy arg res)+  | Just arg_rep <- getRuntimeRep_maybe arg+  , Just res_rep <- getRuntimeRep_maybe res+  = Just (funTyCon, [arg_rep, res_rep, arg, res])++  | otherwise+  = pprPanic "tcRepSplitTyConApp_maybe" (ppr arg $$ ppr res)+tcRepSplitTyConApp_maybe _                          = Nothing+++-------------+splitAppTy :: Type -> (Type, Type)+-- ^ Attempts to take a type application apart, as in 'splitAppTy_maybe',+-- and panics if this is not possible+splitAppTy ty = case splitAppTy_maybe ty of+                Just pr -> pr+                Nothing -> panic "splitAppTy"++-------------+splitAppTys :: Type -> (Type, [Type])+-- ^ Recursively splits a type as far as is possible, leaving a residual+-- type being applied to and the type arguments applied to it. Never fails,+-- even if that means returning an empty list of type applications.+splitAppTys ty = split ty ty []+  where+    split orig_ty ty args | Just ty' <- coreView ty = split orig_ty ty' args+    split _       (AppTy ty arg)        args = split ty ty (arg:args)+    split _       (TyConApp tc tc_args) args+      = let -- keep type families saturated+            n | mightBeUnsaturatedTyCon tc = 0+              | otherwise                  = tyConArity tc+            (tc_args1, tc_args2) = splitAt n tc_args+        in+        (TyConApp tc tc_args1, tc_args2 ++ args)+    split _   (FunTy ty1 ty2) args+      | Just rep1 <- getRuntimeRep_maybe ty1+      , Just rep2 <- getRuntimeRep_maybe ty2+      = ASSERT( null args )+        (TyConApp funTyCon [], [rep1, rep2, ty1, ty2])++      | otherwise+      = pprPanic "splitAppTys" (ppr ty1 $$ ppr ty2 $$ ppr args)+    split orig_ty _                     args  = (orig_ty, args)++-- | Like 'splitAppTys', but doesn't look through type synonyms+repSplitAppTys :: Type -> (Type, [Type])+repSplitAppTys ty = split ty []+  where+    split (AppTy ty arg) args = split ty (arg:args)+    split (TyConApp tc tc_args) args+      = let n | mightBeUnsaturatedTyCon tc = 0+              | otherwise                  = tyConArity tc+            (tc_args1, tc_args2) = splitAt n tc_args+        in+        (TyConApp tc tc_args1, tc_args2 ++ args)+    split (FunTy ty1 ty2) args+      | Just rep1 <- getRuntimeRep_maybe ty1+      , Just rep2 <- getRuntimeRep_maybe ty2+      = ASSERT( null args )+        (TyConApp funTyCon [], [rep1, rep2, ty1, ty2])++      | otherwise+      = pprPanic "repSplitAppTys" (ppr ty1 $$ ppr ty2 $$ ppr args)+    split ty args = (ty, args)++{-+                      LitTy+                      ~~~~~+-}++mkNumLitTy :: Integer -> Type+mkNumLitTy n = LitTy (NumTyLit n)++-- | Is this a numeric literal. We also look through type synonyms.+isNumLitTy :: Type -> Maybe Integer+isNumLitTy ty | Just ty1 <- coreView ty = isNumLitTy ty1+isNumLitTy (LitTy (NumTyLit n)) = Just n+isNumLitTy _                    = Nothing++mkStrLitTy :: FastString -> Type+mkStrLitTy s = LitTy (StrTyLit s)++-- | Is this a symbol literal. We also look through type synonyms.+isStrLitTy :: Type -> Maybe FastString+isStrLitTy ty | Just ty1 <- coreView ty = isStrLitTy ty1+isStrLitTy (LitTy (StrTyLit s)) = Just s+isStrLitTy _                    = Nothing+++-- | Is this type a custom user error?+-- If so, give us the kind and the error message.+userTypeError_maybe :: Type -> Maybe Type+userTypeError_maybe t+  = do { (tc, _kind : msg : _) <- splitTyConApp_maybe t+          -- There may be more than 2 arguments, if the type error is+          -- used as a type constructor (e.g. at kind `Type -> Type`).++       ; guard (tyConName tc == errorMessageTypeErrorFamName)+       ; return msg }++-- | Render a type corresponding to a user type error into a SDoc.+pprUserTypeErrorTy :: Type -> SDoc+pprUserTypeErrorTy ty =+  case splitTyConApp_maybe ty of++    -- Text "Something"+    Just (tc,[txt])+      | tyConName tc == typeErrorTextDataConName+      , Just str <- isStrLitTy txt -> ftext str++    -- ShowType t+    Just (tc,[_k,t])+      | tyConName tc == typeErrorShowTypeDataConName -> ppr t++    -- t1 :<>: t2+    Just (tc,[t1,t2])+      | tyConName tc == typeErrorAppendDataConName ->+        pprUserTypeErrorTy t1 <> pprUserTypeErrorTy t2++    -- t1 :$$: t2+    Just (tc,[t1,t2])+      | tyConName tc == typeErrorVAppendDataConName ->+        pprUserTypeErrorTy t1 $$ pprUserTypeErrorTy t2++    -- An uneavaluated type function+    _ -> ppr ty+++++{-+---------------------------------------------------------------------+                                FunTy+                                ~~~~~++Note [Representation of function types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Functions (e.g. Int -> Char) are can be thought of as being applications+of funTyCon (known in Haskell surface syntax as (->)),++    (->) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)+                   (a :: TYPE r1) (b :: TYPE r2).+            a -> b -> Type++However, for efficiency's sake we represent saturated applications of (->)+with FunTy. For instance, the type,++    (->) r1 r2 a b++is equivalent to,++    FunTy (Anon a) b++Note how the RuntimeReps are implied in the FunTy representation. For this+reason we must be careful when recontructing the TyConApp representation (see,+for instance, splitTyConApp_maybe).++In the compiler we maintain the invariant that all saturated applications of+(->) are represented with FunTy.++See #11714.+-}++isFunTy :: Type -> Bool+isFunTy ty = isJust (splitFunTy_maybe ty)++splitFunTy :: Type -> (Type, Type)+-- ^ Attempts to extract the argument and result types from a type, and+-- panics if that is not possible. See also 'splitFunTy_maybe'+splitFunTy ty | Just ty' <- coreView ty = splitFunTy ty'+splitFunTy (FunTy arg res) = (arg, res)+splitFunTy other           = pprPanic "splitFunTy" (ppr other)++splitFunTy_maybe :: Type -> Maybe (Type, Type)+-- ^ Attempts to extract the argument and result types from a type+splitFunTy_maybe ty | Just ty' <- coreView ty = splitFunTy_maybe ty'+splitFunTy_maybe (FunTy arg res) = Just (arg, res)+splitFunTy_maybe _               = Nothing++splitFunTys :: Type -> ([Type], Type)+splitFunTys ty = split [] ty ty+  where+    split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty'+    split args _       (FunTy arg res) = split (arg:args) res res+    split args orig_ty _               = (reverse args, orig_ty)++funResultTy :: Type -> Type+-- ^ Extract the function result type and panic if that is not possible+funResultTy ty | Just ty' <- coreView ty = funResultTy ty'+funResultTy (FunTy _ res) = res+funResultTy ty            = pprPanic "funResultTy" (ppr ty)++funArgTy :: Type -> Type+-- ^ Extract the function argument type and panic if that is not possible+funArgTy ty | Just ty' <- coreView ty = funArgTy ty'+funArgTy (FunTy arg _res) = arg+funArgTy ty               = pprPanic "funArgTy" (ppr ty)++piResultTy :: Type -> Type ->  Type+piResultTy ty arg = case piResultTy_maybe ty arg of+                      Just res -> res+                      Nothing  -> pprPanic "piResultTy" (ppr ty $$ ppr arg)++piResultTy_maybe :: Type -> Type -> Maybe Type++-- ^ Just like 'piResultTys' but for a single argument+-- Try not to iterate 'piResultTy', because it's inefficient to substitute+-- one variable at a time; instead use 'piResultTys"+piResultTy_maybe ty arg+  | Just ty' <- coreView ty = piResultTy_maybe ty' arg++  | FunTy _ res <- ty+  = Just res++  | ForAllTy (TvBndr tv _) res <- ty+  = let empty_subst = mkEmptyTCvSubst $ mkInScopeSet $+                      tyCoVarsOfTypes [arg,res]+    in Just (substTy (extendTvSubst empty_subst tv arg) res)++  | otherwise+  = Nothing++-- | (piResultTys f_ty [ty1, .., tyn]) gives the type of (f ty1 .. tyn)+--   where f :: f_ty+-- 'piResultTys' is interesting because:+--      1. 'f_ty' may have more for-alls than there are args+--      2. Less obviously, it may have fewer for-alls+-- For case 2. think of:+--   piResultTys (forall a.a) [forall b.b, Int]+-- This really can happen, but only (I think) in situations involving+-- undefined.  For example:+--       undefined :: forall a. a+-- Term: undefined @(forall b. b->b) @Int+-- This term should have type (Int -> Int), but notice that+-- there are more type args than foralls in 'undefined's type.++-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism] in coreSyn/CoreLint.hs++-- This is a heavily used function (e.g. from typeKind),+-- so we pay attention to efficiency, especially in the special case+-- where there are no for-alls so we are just dropping arrows from+-- a function type/kind.+piResultTys :: Type -> [Type] -> Type+piResultTys ty [] = ty+piResultTys ty orig_args@(arg:args)+  | Just ty' <- coreView ty+  = piResultTys ty' orig_args++  | FunTy _ res <- ty+  = piResultTys res args++  | ForAllTy (TvBndr tv _) res <- ty+  = go (extendVarEnv emptyTvSubstEnv tv arg) res args++  | otherwise+  = pprPanic "piResultTys1" (ppr ty $$ ppr orig_args)+  where+    in_scope = mkInScopeSet (tyCoVarsOfTypes (ty:orig_args))++    go :: TvSubstEnv -> Type -> [Type] -> Type+    go tv_env ty [] = substTy (mkTvSubst in_scope tv_env) ty++    go tv_env ty all_args@(arg:args)+      | Just ty' <- coreView ty+      = go tv_env ty' all_args++      | FunTy _ res <- ty+      = go tv_env res args++      | ForAllTy (TvBndr tv _) res <- ty+      = go (extendVarEnv tv_env tv arg) res args++      | TyVarTy tv <- ty+      , Just ty' <- lookupVarEnv tv_env tv+        -- Deals with piResultTys (forall a. a) [forall b.b, Int]+      = piResultTys ty' all_args++      | otherwise+      = pprPanic "piResultTys2" (ppr ty $$ ppr orig_args $$ ppr all_args)++applyTysX :: [TyVar] -> Type -> [Type] -> Type+-- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys+-- Assumes that (/\tvs. body_ty) is closed+applyTysX tvs body_ty arg_tys+  = ASSERT2( length arg_tys >= n_tvs, pp_stuff )+    ASSERT2( tyCoVarsOfType body_ty `subVarSet` mkVarSet tvs, pp_stuff )+    mkAppTys (substTyWith tvs (take n_tvs arg_tys) body_ty)+             (drop n_tvs arg_tys)+  where+    pp_stuff = vcat [ppr tvs, ppr body_ty, ppr arg_tys]+    n_tvs = length tvs++{-+---------------------------------------------------------------------+                                TyConApp+                                ~~~~~~~~+-}++-- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to+-- its arguments.  Applies its arguments to the constructor from left to right.+mkTyConApp :: TyCon -> [Type] -> Type+mkTyConApp tycon tys+  | isFunTyCon tycon+  , [_rep1,_rep2,ty1,ty2] <- tys+  = FunTy ty1 ty2++  | otherwise+  = TyConApp tycon tys++-- splitTyConApp "looks through" synonyms, because they don't+-- mean a distinct type, but all other type-constructor applications+-- including functions are returned as Just ..++-- | Retrieve the tycon heading this type, if there is one. Does /not/+-- look through synonyms.+tyConAppTyConPicky_maybe :: Type -> Maybe TyCon+tyConAppTyConPicky_maybe (TyConApp tc _) = Just tc+tyConAppTyConPicky_maybe (FunTy {})      = Just funTyCon+tyConAppTyConPicky_maybe _               = Nothing+++-- | The same as @fst . splitTyConApp@+tyConAppTyCon_maybe :: Type -> Maybe TyCon+tyConAppTyCon_maybe ty | Just ty' <- coreView ty = tyConAppTyCon_maybe ty'+tyConAppTyCon_maybe (TyConApp tc _) = Just tc+tyConAppTyCon_maybe (FunTy {})      = Just funTyCon+tyConAppTyCon_maybe _               = Nothing++tyConAppTyCon :: Type -> TyCon+tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr ty)++-- | The same as @snd . splitTyConApp@+tyConAppArgs_maybe :: Type -> Maybe [Type]+tyConAppArgs_maybe ty | Just ty' <- coreView ty = tyConAppArgs_maybe ty'+tyConAppArgs_maybe (TyConApp _ tys) = Just tys+tyConAppArgs_maybe (FunTy arg res)+  | Just rep1 <- getRuntimeRep_maybe arg+  , Just rep2 <- getRuntimeRep_maybe res+  = Just [rep1, rep2, arg, res]+tyConAppArgs_maybe _                = Nothing++tyConAppArgs :: Type -> [Type]+tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty)++tyConAppArgN :: Int -> Type -> Type+-- Executing Nth+tyConAppArgN n ty+  = case tyConAppArgs_maybe ty of+      Just tys -> ASSERT2( n < length tys, ppr n <+> ppr tys ) tys `getNth` n+      Nothing  -> pprPanic "tyConAppArgN" (ppr n <+> ppr ty)++-- | Attempts to tease a type apart into a type constructor and the application+-- of a number of arguments to that constructor. Panics if that is not possible.+-- See also 'splitTyConApp_maybe'+splitTyConApp :: Type -> (TyCon, [Type])+splitTyConApp ty = case splitTyConApp_maybe ty of+                   Just stuff -> stuff+                   Nothing    -> pprPanic "splitTyConApp" (ppr ty)++-- | Attempts to tease a type apart into a type constructor and the application+-- of a number of arguments to that constructor+splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])+splitTyConApp_maybe ty | Just ty' <- coreView ty = splitTyConApp_maybe ty'+splitTyConApp_maybe ty                           = repSplitTyConApp_maybe ty++-- | Like 'splitTyConApp_maybe', but doesn't look through synonyms. This+-- assumes the synonyms have already been dealt with.+repSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])+repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)+repSplitTyConApp_maybe (FunTy arg res)+  | Just rep1 <- getRuntimeRep_maybe arg+  , Just rep2 <- getRuntimeRep_maybe res+  = Just (funTyCon, [rep1, rep2, arg, res])+  | otherwise+  = pprPanic "repSplitTyConApp_maybe"+             (ppr arg $$ ppr res $$ ppr (typeKind res))+repSplitTyConApp_maybe _ = Nothing++-- | Attempts to tease a list type apart and gives the type of the elements if+-- successful (looks through type synonyms)+splitListTyConApp_maybe :: Type -> Maybe Type+splitListTyConApp_maybe ty = case splitTyConApp_maybe ty of+  Just (tc,[e]) | tc == listTyCon -> Just e+  _other                          -> Nothing++-- | What is the role assigned to the next parameter of this type? Usually,+-- this will be 'Nominal', but if the type is a 'TyConApp', we may be able to+-- do better. The type does *not* have to be well-kinded when applied for this+-- to work!+nextRole :: Type -> Role+nextRole ty+  | Just (tc, tys) <- splitTyConApp_maybe ty+  , let num_tys = length tys+  , num_tys < tyConArity tc+  = tyConRoles tc `getNth` num_tys++  | otherwise+  = Nominal++newTyConInstRhs :: TyCon -> [Type] -> Type+-- ^ Unwrap one 'layer' of newtype on a type constructor and its+-- arguments, using an eta-reduced version of the @newtype@ if possible.+-- This requires tys to have at least @newTyConInstArity tycon@ elements.+newTyConInstRhs tycon tys+    = ASSERT2( tvs `leLength` tys, ppr tycon $$ ppr tys $$ ppr tvs )+      applyTysX tvs rhs tys+  where+    (tvs, rhs) = newTyConEtadRhs tycon++{-+---------------------------------------------------------------------+                           CastTy+                           ~~~~~~+A casted type has its *kind* casted into something new.++Note [No reflexive casts in types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As far as possible, we would like to maintain the following property:++  (*) If (t1 `eqType` t2), then t1 and t2 are treated identically within GHC.++The (*) property is very useful, because we have a tendency to compare two+types to see if they're equal, and then arbitrarily choose one. We don't+want this arbitrary choice to then matter later on. Maintaining (*) means+that every function that looks at a structure of a type must think about+casts. In places where we directly pattern-match, this consideration is+forced by consideration of the CastTy constructor.++But, when we call a splitXXX function, it's easy to ignore the possibility+of casts. In particular, splitTyConApp is used extensively, and we don't+want it to fail on (T a b c |> co). Happily, if we have+  (T a b c |> co) `eqType` (T d e f)+then co must be reflexive. Why? eqType checks that the kinds are equal, as+well as checking that (a `eqType` d), (b `eqType` e), and (c `eqType` f).+By the kind check, we know that (T a b c |> co) and (T d e f) have the same+kind. So the only way that co could be non-reflexive is for (T a b c) to have+a different kind than (T d e f). But because T's kind is closed (all tycon kinds+are closed), the only way for this to happen is that one of the arguments has+to differ, leading to a contradiction. Thus, co is reflexive.++Accordingly, by eliminating reflexive casts, splitTyConApp need not worry+about outermost casts to uphold (*).++Unforunately, that's not the end of the story. Consider comparing+  (T a b c)      =?       (T a b |> (co -> <Type>)) (c |> sym co)+These two types have the same kind (Type), but the left type is a TyConApp+while the right type is not. To handle this case, we will have to implement+some variant of the dreaded KPush algorithm (c.f. CoreOpt.pushCoDataCon).+This stone is left unturned for now, meaning that we don't yet uphold (*).++The other place where (*) will be hard to guarantee is in splitAppTy, because+I (Richard E) can't think of a way to push coercions into AppTys. The good+news here is that splitAppTy is not used all that much, and so all clients of+that function can simply be told to use splitCastTy as well, in order to+uphold (*). This, too, is left undone, for now.++-}++splitCastTy_maybe :: Type -> Maybe (Type, Coercion)+splitCastTy_maybe ty | Just ty' <- coreView ty = splitCastTy_maybe ty'+splitCastTy_maybe (CastTy ty co)               = Just (ty, co)+splitCastTy_maybe _                            = Nothing++-- | Make a 'CastTy'. The Coercion must be nominal. Checks the+-- Coercion for reflexivity, dropping it if it's reflexive.+-- See Note [No reflexive casts in types]+mkCastTy :: Type -> Coercion -> Type+mkCastTy ty co | isReflexiveCo co = ty+-- NB: Do the slow check here. This is important to keep the splitXXX+-- functions working properly. Otherwise, we may end up with something+-- like (((->) |> something_reflexive_but_not_obviously_so) biz baz)+-- fails under splitFunTy_maybe. This happened with the cheaper check+-- in test dependent/should_compile/dynamic-paper.++mkCastTy (CastTy ty co1) co2 = mkCastTy ty (co1 `mkTransCo` co2)+mkCastTy ty co = CastTy ty co++tyConBindersTyBinders :: [TyConBinder] -> [TyBinder]+-- Return the tyConBinders in TyBinder form+tyConBindersTyBinders = map to_tyb+  where+    to_tyb (TvBndr tv (NamedTCB vis)) = Named (TvBndr tv vis)+    to_tyb (TvBndr tv AnonTCB)        = Anon (tyVarKind tv)++{-+--------------------------------------------------------------------+                            CoercionTy+                            ~~~~~~~~~~+CoercionTy allows us to inject coercions into types. A CoercionTy+should appear only in the right-hand side of an application.+-}++mkCoercionTy :: Coercion -> Type+mkCoercionTy = CoercionTy++isCoercionTy :: Type -> Bool+isCoercionTy (CoercionTy _) = True+isCoercionTy _              = False++isCoercionTy_maybe :: Type -> Maybe Coercion+isCoercionTy_maybe (CoercionTy co) = Just co+isCoercionTy_maybe _               = Nothing++stripCoercionTy :: Type -> Coercion+stripCoercionTy (CoercionTy co) = co+stripCoercionTy ty              = pprPanic "stripCoercionTy" (ppr ty)++{-+---------------------------------------------------------------------+                                SynTy+                                ~~~~~++Notes on type synonyms+~~~~~~~~~~~~~~~~~~~~~~+The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try+to return type synonyms wherever possible. Thus++        type Foo a = a -> a++we want+        splitFunTys (a -> Foo a) = ([a], Foo a)+not                                ([a], a -> a)++The reason is that we then get better (shorter) type signatures in+interfaces.  Notably this plays a role in tcTySigs in TcBinds.hs.+++---------------------------------------------------------------------+                                ForAllTy+                                ~~~~~~~~+-}++-- | Make a dependent forall over an Inferred (as opposed to Specified)+-- variable+mkInvForAllTy :: TyVar -> Type -> Type+mkInvForAllTy tv ty = ASSERT( isTyVar tv )+                      ForAllTy (TvBndr tv Inferred) ty++-- | Like mkForAllTys, but assumes all variables are dependent and Inferred,+-- a common case+mkInvForAllTys :: [TyVar] -> Type -> Type+mkInvForAllTys tvs ty = ASSERT( all isTyVar tvs )+                        foldr mkInvForAllTy ty tvs++-- | Like mkForAllTys, but assumes all variables are dependent and specified,+-- a common case+mkSpecForAllTys :: [TyVar] -> Type -> Type+mkSpecForAllTys tvs = ASSERT( all isTyVar tvs )+                     mkForAllTys [ TvBndr tv Specified | tv <- tvs ]++-- | Like mkForAllTys, but assumes all variables are dependent and visible+mkVisForAllTys :: [TyVar] -> Type -> Type+mkVisForAllTys tvs = ASSERT( all isTyVar tvs )+                     mkForAllTys [ TvBndr tv Required | tv <- tvs ]++mkLamType  :: Var -> Type -> Type+-- ^ Makes a @(->)@ type or an implicit forall type, depending+-- on whether it is given a type variable or a term variable.+-- This is used, for example, when producing the type of a lambda.+-- Always uses Inferred binders.+mkLamTypes :: [Var] -> Type -> Type+-- ^ 'mkLamType' for multiple type or value arguments++mkLamType v ty+   | isTyVar v = ForAllTy (TvBndr v Inferred) ty+   | otherwise = FunTy    (varType v)          ty++mkLamTypes vs ty = foldr mkLamType ty vs++-- | Given a list of type-level vars and a result type, makes TyBinders, preferring+-- anonymous binders if the variable is, in fact, not dependent.+-- All binders are /visible/.+mkTyConBindersPreferAnon :: [TyVar] -> Type -> [TyConBinder]+mkTyConBindersPreferAnon vars inner_ty = fst (go vars)+  where+    go :: [TyVar] -> ([TyConBinder], VarSet) -- also returns the free vars+    go [] = ([], tyCoVarsOfType inner_ty)+    go (v:vs) |  v `elemVarSet` fvs+              = ( TvBndr v (NamedTCB Required) : binders+                , fvs `delVarSet` v `unionVarSet` kind_vars )+              | otherwise+              = ( TvBndr v AnonTCB : binders+                , fvs `unionVarSet` kind_vars )+      where+        (binders, fvs) = go vs+        kind_vars      = tyCoVarsOfType $ tyVarKind v++-- | Take a ForAllTy apart, returning the list of tyvars and the result type.+-- This always succeeds, even if it returns only an empty list. Note that the+-- result type returned may have free variables that were bound by a forall.+splitForAllTys :: Type -> ([TyVar], Type)+splitForAllTys ty = split ty ty []+  where+    split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs+    split _       (ForAllTy (TvBndr tv _) ty) tvs = split ty ty (tv:tvs)+    split orig_ty _                           tvs = (reverse tvs, orig_ty)++-- | Like 'splitPiTys' but split off only /named/ binders.+splitForAllTyVarBndrs :: Type -> ([TyVarBinder], Type)+splitForAllTyVarBndrs ty = split ty ty []+  where+    split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs+    split _       (ForAllTy b res) bs  = split res res (b:bs)+    split orig_ty _                bs  = (reverse bs, orig_ty)++-- | Checks whether this is a proper forall (with a named binder)+isForAllTy :: Type -> Bool+isForAllTy ty | Just ty' <- coreView ty = isForAllTy ty'+isForAllTy (ForAllTy {}) = True+isForAllTy _             = False++-- | Is this a function or forall?+isPiTy :: Type -> Bool+isPiTy ty | Just ty' <- coreView ty = isForAllTy ty'+isPiTy (ForAllTy {}) = True+isPiTy (FunTy {})    = True+isPiTy _             = False++-- | Take a forall type apart, or panics if that is not possible.+splitForAllTy :: Type -> (TyVar, Type)+splitForAllTy ty+  | Just answer <- splitForAllTy_maybe ty = answer+  | otherwise                             = pprPanic "splitForAllTy" (ppr ty)++-- | Drops all ForAllTys+dropForAlls :: Type -> Type+dropForAlls ty = go ty+  where+    go ty | Just ty' <- coreView ty = go ty'+    go (ForAllTy _ res)            = go res+    go res                         = res++-- | Attempts to take a forall type apart, but only if it's a proper forall,+-- with a named binder+splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)+splitForAllTy_maybe ty = go ty+  where+    go ty | Just ty' <- coreView ty = go ty'+    go (ForAllTy (TvBndr tv _) ty) = Just (tv, ty)+    go _                           = Nothing++-- | Attempts to take a forall type apart; works with proper foralls and+-- functions+splitPiTy_maybe :: Type -> Maybe (TyBinder, Type)+splitPiTy_maybe ty = go ty+  where+    go ty | Just ty' <- coreView ty = go ty'+    go (ForAllTy bndr ty) = Just (Named bndr, ty)+    go (FunTy arg res)    = Just (Anon arg, res)+    go _                  = Nothing++-- | Takes a forall type apart, or panics+splitPiTy :: Type -> (TyBinder, Type)+splitPiTy ty+  | Just answer <- splitPiTy_maybe ty = answer+  | otherwise                         = pprPanic "splitPiTy" (ppr ty)++-- | Split off all TyBinders to a type, splitting both proper foralls+-- and functions+splitPiTys :: Type -> ([TyBinder], Type)+splitPiTys ty = split ty ty []+  where+    split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs+    split _       (ForAllTy b res) bs  = split res res (Named b  : bs)+    split _       (FunTy arg res)  bs  = split res res (Anon arg : bs)+    split orig_ty _                bs  = (reverse bs, orig_ty)++-- Like splitPiTys, but returns only *invisible* binders, including constraints+-- Stops at the first visible binder+splitPiTysInvisible :: Type -> ([TyBinder], Type)+splitPiTysInvisible ty = split ty ty []+   where+    split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs+    split _       (ForAllTy b@(TvBndr _ vis) res) bs+      | isInvisibleArgFlag vis         = split res res (Named b  : bs)+    split _       (FunTy arg res)  bs+      | isPredTy arg                   = split res res (Anon arg : bs)+    split orig_ty _                bs  = (reverse bs, orig_ty)++-- | Given a tycon and its arguments, filters out any invisible arguments+filterOutInvisibleTypes :: TyCon -> [Type] -> [Type]+filterOutInvisibleTypes tc tys = snd $ partitionInvisibles tc id tys++-- | Like 'filterOutInvisibles', but works on 'TyVar's+filterOutInvisibleTyVars :: TyCon -> [TyVar] -> [TyVar]+filterOutInvisibleTyVars tc tvs = snd $ partitionInvisibles tc mkTyVarTy tvs++-- | Given a tycon and a list of things (which correspond to arguments),+-- partitions the things into+--      Inferred or Specified ones and+--      Required ones+-- The callback function is necessary for this scenario:+--+-- > T :: forall k. k -> k+-- > partitionInvisibles T [forall m. m -> m -> m, S, R, Q]+--+-- After substituting, we get+--+-- > T (forall m. m -> m -> m) :: (forall m. m -> m -> m) -> forall n. n -> n -> n+--+-- Thus, the first argument is invisible, @S@ is visible, @R@ is invisible again,+-- and @Q@ is visible.+--+-- If you're absolutely sure that your tycon's kind doesn't end in a variable,+-- it's OK if the callback function panics, as that's the only time it's+-- consulted.+partitionInvisibles :: TyCon -> (a -> Type) -> [a] -> ([a], [a])+partitionInvisibles tc get_ty = go emptyTCvSubst (tyConKind tc)+  where+    go _ _ [] = ([], [])+    go subst (ForAllTy (TvBndr tv vis) res_ki) (x:xs)+      | isVisibleArgFlag vis = second (x :) (go subst' res_ki xs)+      | otherwise            = first  (x :) (go subst' res_ki xs)+      where+        subst' = extendTvSubst subst tv (get_ty x)+    go subst (TyVarTy tv) xs+      | Just ki <- lookupTyVar subst tv = go subst ki xs+    go _ _ xs = ([], xs)  -- something is ill-kinded. But this can happen+                          -- when printing errors. Assume everything is visible.++-- @isTauTy@ tests if a type has no foralls+isTauTy :: Type -> Bool+isTauTy ty | Just ty' <- coreView ty = isTauTy ty'+isTauTy (TyVarTy _)           = True+isTauTy (LitTy {})            = True+isTauTy (TyConApp tc tys)     = all isTauTy tys && isTauTyCon tc+isTauTy (AppTy a b)           = isTauTy a && isTauTy b+isTauTy (FunTy a b)           = isTauTy a && isTauTy b+isTauTy (ForAllTy {})         = False+isTauTy (CastTy ty _)         = isTauTy ty+isTauTy (CoercionTy _)        = False  -- Not sure about this++{-+%************************************************************************+%*                                                                      *+   TyBinders+%*                                                                      *+%************************************************************************+-}++-- | Make a named binder+mkTyVarBinder :: ArgFlag -> Var -> TyVarBinder+mkTyVarBinder vis var = TvBndr var vis++-- | Make many named binders+mkTyVarBinders :: ArgFlag -> [TyVar] -> [TyVarBinder]+mkTyVarBinders vis = map (mkTyVarBinder vis)++-- | Make an anonymous binder+mkAnonBinder :: Type -> TyBinder+mkAnonBinder = Anon++-- | Does this binder bind a variable that is /not/ erased? Returns+-- 'True' for anonymous binders.+isAnonTyBinder :: TyBinder -> Bool+isAnonTyBinder (Named {}) = False+isAnonTyBinder (Anon {})  = True++isNamedTyBinder :: TyBinder -> Bool+isNamedTyBinder (Named {}) = True+isNamedTyBinder (Anon {})  = False++tyBinderType :: TyBinder -> Type+-- Barely used+tyBinderType (Named tvb) = binderKind tvb+tyBinderType (Anon ty)   = ty++-- | Extract a relevant type, if there is one.+binderRelevantType_maybe :: TyBinder -> Maybe Type+binderRelevantType_maybe (Named {}) = Nothing+binderRelevantType_maybe (Anon ty)  = Just ty++-- | Like 'maybe', but for binders.+caseBinder :: TyBinder           -- ^ binder to scrutinize+           -> (TyVarBinder -> a) -- ^ named case+           -> (Type -> a)        -- ^ anonymous case+           -> a+caseBinder (Named v) f _ = f v+caseBinder (Anon t)  _ d = d t++-- | Manufacture a new 'TyConBinder' from a 'TyBinder'. Anonymous+-- 'TyBinder's are still assigned names as 'TyConBinder's, so we need+-- the extra gunk with which to construct a 'Name'. Used when producing+-- tyConTyVars from a datatype kind signature. Defined here to avoid module+-- loops.+mkTyBinderTyConBinder :: TyBinder -> SrcSpan -> Unique -> OccName -> TyConBinder+mkTyBinderTyConBinder (Named (TvBndr tv argf)) _ _ _ = TvBndr tv (NamedTCB argf)+mkTyBinderTyConBinder (Anon kind) loc uniq occ+  = TvBndr (mkTyVar (mkInternalName uniq occ loc) kind) AnonTCB++{-+%************************************************************************+%*                                                                      *+                         Pred+*                                                                      *+************************************************************************++Predicates on PredType++Note [isPredTy complications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+You would think that we could define+  isPredTy ty = isConstraintKind (typeKind ty)+But there are a number of complications:++* isPredTy is used when printing types, which can happen in debug+  printing during type checking of not-fully-zonked types.  So it's+  not cool to say isConstraintKind (typeKind ty) because, absent+  zonking, the type might be ill-kinded, and typeKind crashes. Hence the+  rather tiresome story here++* isPredTy must return "True" to *unlifted* coercions, such as (t1 ~# t2)+  and (t1 ~R# t2), which are not of kind Constraint!  Currently they are+  of kind #.++* If we do form the type '(C a => C [a]) => blah', then we'd like to+  print it as such. But that means that isPredTy must return True for+  (C a => C [a]).  Admittedly that type is illegal in Haskell, but we+  want to print it nicely in error messages.+-}++-- | Is the type suitable to classify a given/wanted in the typechecker?+isPredTy :: Type -> Bool+-- See Note [isPredTy complications]+isPredTy ty = go ty []+  where+    go :: Type -> [KindOrType] -> Bool+    go (AppTy ty1 ty2)   args       = go ty1 (ty2 : args)+    go (TyVarTy tv)      args       = go_k (tyVarKind tv) args+    go (TyConApp tc tys) args       = ASSERT( null args )  -- TyConApp invariant+                                      go_tc tc tys+    go (FunTy arg res) []+      | isPredTy arg                = isPredTy res   -- (Eq a => C a)+      | otherwise                   = False          -- (Int -> Bool)+    go (ForAllTy _ ty) []           = go ty []+    go (CastTy _ co) args           = go_k (pSnd (coercionKind co)) args+    go _ _ = False++    go_tc :: TyCon -> [KindOrType] -> Bool+    go_tc tc args+      | tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey+                  = length args == 4  -- ~# and ~R# sadly have result kind #+                                      -- not Constraint; but we still want+                                      -- isPredTy to reply True.+      | otherwise = go_k (tyConKind tc) args++    go_k :: Kind -> [KindOrType] -> Bool+    -- True <=> ('k' applied to 'kts') = Constraint+    go_k k [] = isConstraintKind k+    go_k k (arg:args) = case piResultTy_maybe k arg of+                          Just k' -> go_k k' args+                          Nothing -> WARN( True, text "isPredTy" <+> ppr ty )+                                     False+       -- This last case shouldn't happen under most circumstances. It can+       -- occur if we call isPredTy during kind checking, especially if one+       -- of the following happens:+       --+       -- 1. There is actually a kind error.  Example in which this showed up:+       --    polykinds/T11399+       -- 2. A type constructor application appears to be oversaturated. An+       --    example of this occurred in GHC Trac #13187:+       --+       --      {-# LANGUAGE PolyKinds #-}+       --      type Const a b = b+       --      f :: Const Int (,) Bool Char -> Char+       --+       --    This code is actually fine, since Const is polymorphic in its+       --    return kind. It does show that isPredTy could possibly report a+       --    false negative if a constraint is similarly oversaturated, but+       --    it's hard to do better than isPredTy currently does without+       --    zonking, so we punt on such cases for now.++isClassPred, isEqPred, isNomEqPred, isIPPred :: PredType -> Bool+isClassPred ty = case tyConAppTyCon_maybe ty of+    Just tyCon | isClassTyCon tyCon -> True+    _                               -> False+isEqPred ty = case tyConAppTyCon_maybe ty of+    Just tyCon -> tyCon `hasKey` eqPrimTyConKey+               || tyCon `hasKey` eqReprPrimTyConKey+    _          -> False++isNomEqPred ty = case tyConAppTyCon_maybe ty of+    Just tyCon -> tyCon `hasKey` eqPrimTyConKey+    _          -> False++isIPPred ty = case tyConAppTyCon_maybe ty of+    Just tc -> isIPTyCon tc+    _       -> False++isIPTyCon :: TyCon -> Bool+isIPTyCon tc = tc `hasKey` ipClassKey+  -- Class and its corresponding TyCon have the same Unique++isIPClass :: Class -> Bool+isIPClass cls = cls `hasKey` ipClassKey++isCTupleClass :: Class -> Bool+isCTupleClass cls = isTupleTyCon (classTyCon cls)++isIPPred_maybe :: Type -> Maybe (FastString, Type)+isIPPred_maybe ty =+  do (tc,[t1,t2]) <- splitTyConApp_maybe ty+     guard (isIPTyCon tc)+     x <- isStrLitTy t1+     return (x,t2)++{-+Make PredTypes++--------------------- Equality types ---------------------------------+-}++-- | Makes a lifted equality predicate at the given role+mkPrimEqPredRole :: Role -> Type -> Type -> PredType+mkPrimEqPredRole Nominal          = mkPrimEqPred+mkPrimEqPredRole Representational = mkReprPrimEqPred+mkPrimEqPredRole Phantom          = panic "mkPrimEqPredRole phantom"++-- | Creates a primitive type equality predicate.+-- Invariant: the types are not Coercions+mkPrimEqPred :: Type -> Type -> Type+mkPrimEqPred ty1 ty2+  = TyConApp eqPrimTyCon [k1, k2, ty1, ty2]+  where+    k1 = typeKind ty1+    k2 = typeKind ty2++-- | Creates a primite type equality predicate with explicit kinds+mkHeteroPrimEqPred :: Kind -> Kind -> Type -> Type -> Type+mkHeteroPrimEqPred k1 k2 ty1 ty2 = TyConApp eqPrimTyCon [k1, k2, ty1, ty2]++-- | Creates a primitive representational type equality predicate+-- with explicit kinds+mkHeteroReprPrimEqPred :: Kind -> Kind -> Type -> Type -> Type+mkHeteroReprPrimEqPred k1 k2 ty1 ty2+  = TyConApp eqReprPrimTyCon [k1, k2, ty1, ty2]++-- | Try to split up a coercion type into the types that it coerces+splitCoercionType_maybe :: Type -> Maybe (Type, Type)+splitCoercionType_maybe ty+  = do { (tc, [_, _, ty1, ty2]) <- splitTyConApp_maybe ty+       ; guard $ tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey+       ; return (ty1, ty2) }++mkReprPrimEqPred :: Type -> Type -> Type+mkReprPrimEqPred ty1  ty2+  = TyConApp eqReprPrimTyCon [k1, k2, ty1, ty2]+  where+    k1 = typeKind ty1+    k2 = typeKind ty2++equalityTyCon :: Role -> TyCon+equalityTyCon Nominal          = eqPrimTyCon+equalityTyCon Representational = eqReprPrimTyCon+equalityTyCon Phantom          = eqPhantPrimTyCon++-- --------------------- Dictionary types ---------------------------------++mkClassPred :: Class -> [Type] -> PredType+mkClassPred clas tys = TyConApp (classTyCon clas) tys++isDictTy :: Type -> Bool+isDictTy = isClassPred++isDictLikeTy :: Type -> Bool+-- Note [Dictionary-like types]+isDictLikeTy ty | Just ty' <- coreView ty = isDictLikeTy ty'+isDictLikeTy ty = case splitTyConApp_maybe ty of+        Just (tc, tys) | isClassTyCon tc -> True+                       | isTupleTyCon tc -> all isDictLikeTy tys+        _other                           -> False++{-+Note [Dictionary-like types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Being "dictionary-like" means either a dictionary type or a tuple thereof.+In GHC 6.10 we build implication constraints which construct such tuples,+and if we land up with a binding+    t :: (C [a], Eq [a])+    t = blah+then we want to treat t as cheap under "-fdicts-cheap" for example.+(Implication constraints are normally inlined, but sadly not if the+occurrence is itself inside an INLINE function!  Until we revise the+handling of implication constraints, that is.)  This turned out to+be important in getting good arities in DPH code.  Example:++    class C a+    class D a where { foo :: a -> a }+    instance C a => D (Maybe a) where { foo x = x }++    bar :: (C a, C b) => a -> b -> (Maybe a, Maybe b)+    {-# INLINE bar #-}+    bar x y = (foo (Just x), foo (Just y))++Then 'bar' should jolly well have arity 4 (two dicts, two args), but+we ended up with something like+   bar = __inline_me__ (\d1,d2. let t :: (D (Maybe a), D (Maybe b)) = ...+                                in \x,y. <blah>)++This is all a bit ad-hoc; eg it relies on knowing that implication+constraints build tuples.+++Decomposing PredType+-}++-- | A choice of equality relation. This is separate from the type 'Role'+-- because 'Phantom' does not define a (non-trivial) equality relation.+data EqRel = NomEq | ReprEq+  deriving (Eq, Ord)++instance Outputable EqRel where+  ppr NomEq  = text "nominal equality"+  ppr ReprEq = text "representational equality"++eqRelRole :: EqRel -> Role+eqRelRole NomEq  = Nominal+eqRelRole ReprEq = Representational++data PredTree = ClassPred Class [Type]+              | EqPred EqRel Type Type+              | IrredPred PredType++classifyPredType :: PredType -> PredTree+classifyPredType ev_ty = case splitTyConApp_maybe ev_ty of+    Just (tc, [_, _, ty1, ty2])+      | tc `hasKey` eqReprPrimTyConKey    -> EqPred ReprEq ty1 ty2+      | tc `hasKey` eqPrimTyConKey        -> EqPred NomEq ty1 ty2+    Just (tc, tys)+      | Just clas <- tyConClass_maybe tc  -> ClassPred clas tys+    _                                     -> IrredPred ev_ty++getClassPredTys :: PredType -> (Class, [Type])+getClassPredTys ty = case getClassPredTys_maybe ty of+        Just (clas, tys) -> (clas, tys)+        Nothing          -> pprPanic "getClassPredTys" (ppr ty)++getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])+getClassPredTys_maybe ty = case splitTyConApp_maybe ty of+        Just (tc, tys) | Just clas <- tyConClass_maybe tc -> Just (clas, tys)+        _ -> Nothing++getEqPredTys :: PredType -> (Type, Type)+getEqPredTys ty+  = case splitTyConApp_maybe ty of+      Just (tc, [_, _, ty1, ty2])+        |  tc `hasKey` eqPrimTyConKey+        || tc `hasKey` eqReprPrimTyConKey+        -> (ty1, ty2)+      _ -> pprPanic "getEqPredTys" (ppr ty)++getEqPredTys_maybe :: PredType -> Maybe (Role, Type, Type)+getEqPredTys_maybe ty+  = case splitTyConApp_maybe ty of+      Just (tc, [_, _, ty1, ty2])+        | tc `hasKey` eqPrimTyConKey     -> Just (Nominal, ty1, ty2)+        | tc `hasKey` eqReprPrimTyConKey -> Just (Representational, ty1, ty2)+      _ -> Nothing++getEqPredRole :: PredType -> Role+getEqPredRole ty = eqRelRole (predTypeEqRel ty)++-- | Get the equality relation relevant for a pred type.+predTypeEqRel :: PredType -> EqRel+predTypeEqRel ty+  | Just (tc, _) <- splitTyConApp_maybe ty+  , tc `hasKey` eqReprPrimTyConKey+  = ReprEq+  | otherwise+  = NomEq++{-+%************************************************************************+%*                                                                      *+         Well-scoped tyvars+*                                                                      *+************************************************************************+-}++-- | Do a topological sort on a list of tyvars,+--   so that binders occur before occurrences+-- E.g. given  [ a::k, k::*, b::k ]+-- it'll return a well-scoped list [ k::*, a::k, b::k ]+--+-- This is a deterministic sorting operation+-- (that is, doesn't depend on Uniques).+toposortTyVars :: [TyVar] -> [TyVar]+toposortTyVars tvs = reverse $+                     [ tv | (tv, _, _) <- topologicalSortG $+                                          graphFromEdgedVerticesOrd nodes ]+  where+    var_ids :: VarEnv Int+    var_ids = mkVarEnv (zip tvs [1..])++    nodes = [ ( tv+              , lookupVarEnv_NF var_ids tv+              , mapMaybe (lookupVarEnv var_ids)+                         (tyCoVarsOfTypeList (tyVarKind tv)) )+            | tv <- tvs ]++-- | Extract a well-scoped list of variables from a deterministic set of+-- variables. The result is deterministic.+-- NB: There used to exist varSetElemsWellScoped :: VarSet -> [Var] which+-- took a non-deterministic set and produced a non-deterministic+-- well-scoped list. If you care about the list being well-scoped you also+-- most likely care about it being in deterministic order.+dVarSetElemsWellScoped :: DVarSet -> [Var]+dVarSetElemsWellScoped = toposortTyVars . dVarSetElems++-- | Get the free vars of a type in scoped order+tyCoVarsOfTypeWellScoped :: Type -> [TyVar]+tyCoVarsOfTypeWellScoped = toposortTyVars . tyCoVarsOfTypeList++-- | Get the free vars of types in scoped order+tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar]+tyCoVarsOfTypesWellScoped = toposortTyVars . tyCoVarsOfTypesList++{-+************************************************************************+*                                                                      *+\subsection{Type families}+*                                                                      *+************************************************************************+-}++mkFamilyTyConApp :: TyCon -> [Type] -> Type+-- ^ Given a family instance TyCon and its arg types, return the+-- corresponding family type.  E.g:+--+-- > data family T a+-- > data instance T (Maybe b) = MkT b+--+-- Where the instance tycon is :RTL, so:+--+-- > mkFamilyTyConApp :RTL Int  =  T (Maybe Int)+mkFamilyTyConApp tc tys+  | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc+  , let tvs = tyConTyVars tc+        fam_subst = ASSERT2( length tvs == length tys, ppr tc <+> ppr tys )+                    zipTvSubst tvs tys+  = mkTyConApp fam_tc (substTys fam_subst fam_tys)+  | otherwise+  = mkTyConApp tc tys++-- | Get the type on the LHS of a coercion induced by a type/data+-- family instance.+coAxNthLHS :: CoAxiom br -> Int -> Type+coAxNthLHS ax ind =+  mkTyConApp (coAxiomTyCon ax) (coAxBranchLHS (coAxiomNthBranch ax ind))++-- | Pretty prints a 'TyCon', using the family instance in case of a+-- representation tycon.  For example:+--+-- > data T [a] = ...+--+-- In that case we want to print @T [a]@, where @T@ is the family 'TyCon'+pprSourceTyCon :: TyCon -> SDoc+pprSourceTyCon tycon+  | Just (fam_tc, tys) <- tyConFamInst_maybe tycon+  = ppr $ fam_tc `TyConApp` tys        -- can't be FunTyCon+  | otherwise+  = ppr tycon++-- @isTauTy@ tests if a type has no foralls+isFamFreeTy :: Type -> Bool+isFamFreeTy ty | Just ty' <- coreView ty = isFamFreeTy ty'+isFamFreeTy (TyVarTy _)       = True+isFamFreeTy (LitTy {})        = True+isFamFreeTy (TyConApp tc tys) = all isFamFreeTy tys && isFamFreeTyCon tc+isFamFreeTy (AppTy a b)       = isFamFreeTy a && isFamFreeTy b+isFamFreeTy (FunTy a b)       = isFamFreeTy a && isFamFreeTy b+isFamFreeTy (ForAllTy _ ty)   = isFamFreeTy ty+isFamFreeTy (CastTy ty _)     = isFamFreeTy ty+isFamFreeTy (CoercionTy _)    = False  -- Not sure about this++{-+************************************************************************+*                                                                      *+\subsection{Liftedness}+*                                                                      *+************************************************************************+-}++-- | Returns Just True if this type is surely lifted, Just False+-- if it is surely unlifted, Nothing if we can't be sure (i.e., it is+-- levity polymorphic), and panics if the kind does not have the shape+-- TYPE r.+isLiftedType_maybe :: HasDebugCallStack => Type -> Maybe Bool+isLiftedType_maybe ty = go (getRuntimeRep "isLiftedType_maybe" ty)+  where+    go rr | Just rr' <- coreView rr = go rr'+    go (TyConApp lifted_rep [])+      | lifted_rep `hasKey` liftedRepDataConKey = Just True+    go (TyConApp {}) = Just False -- everything else is unlifted+    go _             = Nothing    -- levity polymorphic++-- | See "Type#type_classification" for what an unlifted type is.+-- Panics on levity polymorphic types.+isUnliftedType :: HasDebugCallStack => Type -> Bool+        -- isUnliftedType returns True for forall'd unlifted types:+        --      x :: forall a. Int#+        -- I found bindings like these were getting floated to the top level.+        -- They are pretty bogus types, mind you.  It would be better never to+        -- construct them+isUnliftedType ty+  = not (isLiftedType_maybe ty `orElse`+         pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty)))++-- | Extract the RuntimeRep classifier of a type. For instance,+-- @getRuntimeRep_maybe Int = LiftedRep@. Returns 'Nothing' if this is not+-- possible.+getRuntimeRep_maybe :: HasDebugCallStack+                    => Type -> Maybe Type+getRuntimeRep_maybe = getRuntimeRepFromKind_maybe . typeKind++-- | Extract the RuntimeRep classifier of a type. For instance,+-- @getRuntimeRep_maybe Int = LiftedRep@. Panics if this is not possible.+getRuntimeRep :: HasDebugCallStack+              => String   -- ^ Printed in case of an error+              -> Type -> Type+getRuntimeRep err ty =+    case getRuntimeRep_maybe ty of+      Just r  -> r+      Nothing -> pprPanic "getRuntimeRep"+                          (text err $$ ppr ty <+> dcolon <+> ppr (typeKind ty))++-- | Extract the RuntimeRep classifier of a type from its kind. For example,+-- @getRuntimeRepFromKind * = LiftedRep@; Panics if this is not possible.+getRuntimeRepFromKind :: HasDebugCallStack+                      => String -> Type -> Type+getRuntimeRepFromKind err k =+    case getRuntimeRepFromKind_maybe k of+      Just r  -> r+      Nothing -> pprPanic "getRuntimeRepFromKind"+                          (text err $$ ppr k <+> dcolon <+> ppr (typeKind k))++-- | Extract the RuntimeRep classifier of a type from its kind. For example,+-- @getRuntimeRepFromKind * = LiftedRep@; Returns 'Nothing' if this is not+-- possible.+getRuntimeRepFromKind_maybe :: HasDebugCallStack+                            => Type -> Maybe Type+getRuntimeRepFromKind_maybe = go+  where+    go k | Just k' <- coreView k = go k'+    go k+      | Just (_tc, [arg]) <- splitTyConApp_maybe k+      = ASSERT2( _tc `hasKey` tYPETyConKey, ppr k )+        Just arg+    go _ = Nothing++isUnboxedTupleType :: Type -> Bool+isUnboxedTupleType ty+  = tyConAppTyCon (getRuntimeRep "isUnboxedTupleType" 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 "isUnboxedSumType" ty) `hasKey` sumRepDataConKey++-- | See "Type#type_classification" for what an algebraic type is.+-- Should only be applied to /types/, as opposed to e.g. partially+-- saturated type constructors+isAlgType :: Type -> Bool+isAlgType ty+  = case splitTyConApp_maybe ty of+      Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )+                            isAlgTyCon tc+      _other             -> False++-- | See "Type#type_classification" for what an algebraic type is.+-- Should only be applied to /types/, as opposed to e.g. partially+-- saturated type constructors. Closed type constructors are those+-- with a fixed right hand side, as opposed to e.g. associated types+isClosedAlgType :: Type -> Bool+isClosedAlgType ty+  = case splitTyConApp_maybe ty of+      Just (tc, ty_args) | isAlgTyCon tc && not (isFamilyTyCon tc)+             -> ASSERT2( ty_args `lengthIs` tyConArity tc, ppr ty ) True+      _other -> False++-- | Check whether a type is a data family type+isDataFamilyAppType :: Type -> Bool+isDataFamilyAppType ty = case tyConAppTyCon_maybe ty of+                           Just tc -> isDataFamilyTyCon tc+                           _       -> False++-- | Computes whether an argument (or let right hand side) should+-- be computed strictly or lazily, based only on its type.+-- Currently, it's just 'isUnliftedType'. Panics on levity-polymorphic types.+isStrictType :: HasDebugCallStack => Type -> Bool+isStrictType = isUnliftedType++isPrimitiveType :: Type -> Bool+-- ^ Returns true of types that are opaque to Haskell.+isPrimitiveType ty = case splitTyConApp_maybe ty of+                        Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )+                                              isPrimTyCon tc+                        _                  -> False++{-+************************************************************************+*                                                                      *+\subsection{Join points}+*                                                                      *+************************************************************************+-}++-- | Determine whether a type could be the type of a join point of given total+-- arity, according to the polymorphism rule. A join point cannot be polymorphic+-- in its return type, since given+--   join j @a @b x y z = e1 in e2,+-- the types of e1 and e2 must be the same, and a and b are not in scope for e2.+-- (See Note [The polymorphism rule of join points] in CoreSyn.) Returns False+-- also if the type simply doesn't have enough arguments.+--+-- Note that we need to know how many arguments (type *and* value) the putative+-- join point takes; for instance, if+--   j :: forall a. a -> Int+-- then j could be a binary join point returning an Int, but it could *not* be a+-- unary join point returning a -> Int.+--+-- TODO: See Note [Excess polymorphism and join points]+isValidJoinPointType :: JoinArity -> Type -> Bool+isValidJoinPointType arity ty+  = valid_under emptyVarSet arity ty+  where+    valid_under tvs arity ty+      | arity == 0+      = isEmptyVarSet (tvs `intersectVarSet` tyCoVarsOfType ty)+      | Just (t, ty') <- splitForAllTy_maybe ty+      = valid_under (tvs `extendVarSet` t) (arity-1) ty'+      | Just (_, res_ty) <- splitFunTy_maybe ty+      = valid_under tvs (arity-1) res_ty+      | otherwise+      = False++{-+************************************************************************+*                                                                      *+\subsection{Sequencing on types}+*                                                                      *+************************************************************************+-}++seqType :: Type -> ()+seqType (LitTy n)                   = n `seq` ()+seqType (TyVarTy tv)                = tv `seq` ()+seqType (AppTy t1 t2)               = seqType t1 `seq` seqType t2+seqType (FunTy t1 t2)               = seqType t1 `seq` seqType t2+seqType (TyConApp tc tys)           = tc `seq` seqTypes tys+seqType (ForAllTy (TvBndr tv _) ty) = seqType (tyVarKind tv) `seq` seqType ty+seqType (CastTy ty co)              = seqType ty `seq` seqCo co+seqType (CoercionTy co)             = seqCo co++seqTypes :: [Type] -> ()+seqTypes []       = ()+seqTypes (ty:tys) = seqType ty `seq` seqTypes tys++{-+************************************************************************+*                                                                      *+                Comparison for types+        (We don't use instances so that we know where it happens)+*                                                                      *+************************************************************************++Note [Equality on AppTys]+~~~~~~~~~~~~~~~~~~~~~~~~~+In our cast-ignoring equality, we want to say that the following two+are equal:++  (Maybe |> co) (Int |> co')   ~?       Maybe Int++But the left is an AppTy while the right is a TyConApp. The solution is+to use repSplitAppTy_maybe to break up the TyConApp into its pieces and+then continue. Easy to do, but also easy to forget to do.++-}++eqType :: Type -> Type -> Bool+-- ^ Type equality on source types. Does not look through @newtypes@ or+-- 'PredType's, but it does look through type synonyms.+-- This first checks that the kinds of the types are equal and then+-- checks whether the types are equal, ignoring casts and coercions.+-- (The kind check is a recursive call, but since all kinds have type+-- @Type@, there is no need to check the types of kinds.)+-- See also Note [Non-trivial definitional equality] in TyCoRep.+eqType t1 t2 = isEqual $ nonDetCmpType t1 t2+  -- It's OK to use nonDetCmpType here and eqType is deterministic,+  -- nonDetCmpType does equality deterministically++-- | Compare types with respect to a (presumably) non-empty 'RnEnv2'.+eqTypeX :: RnEnv2 -> Type -> Type -> Bool+eqTypeX env t1 t2 = isEqual $ nonDetCmpTypeX env t1 t2+  -- It's OK to use nonDetCmpType here and eqTypeX is deterministic,+  -- nonDetCmpTypeX does equality deterministically++-- | Type equality on lists of types, looking through type synonyms+-- but not newtypes.+eqTypes :: [Type] -> [Type] -> Bool+eqTypes tys1 tys2 = isEqual $ nonDetCmpTypes tys1 tys2+  -- It's OK to use nonDetCmpType here and eqTypes is deterministic,+  -- nonDetCmpTypes does equality deterministically++eqVarBndrs :: RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2+-- Check that the var lists are the same length+-- and have matching kinds; if so, extend the RnEnv2+-- Returns Nothing if they don't match+eqVarBndrs env [] []+ = Just env+eqVarBndrs env (tv1:tvs1) (tv2:tvs2)+ | eqTypeX env (tyVarKind tv1) (tyVarKind tv2)+ = eqVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2+eqVarBndrs _ _ _= Nothing++-- Now here comes the real worker++{-+Note [nonDetCmpType nondeterminism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+nonDetCmpType is implemented in terms of nonDetCmpTypeX. nonDetCmpTypeX+uses nonDetCmpTc which compares TyCons by their Unique value. Using Uniques for+ordering leads to nondeterminism. We hit the same problem in the TyVarTy case,+comparing type variables is nondeterministic, note the call to nonDetCmpVar in+nonDetCmpTypeX.+See Note [Unique Determinism] for more details.+-}++nonDetCmpType :: Type -> Type -> Ordering+nonDetCmpType t1 t2+  -- we know k1 and k2 have the same kind, because they both have kind *.+  = nonDetCmpTypeX rn_env t1 t2+  where+    rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes [t1, t2]))++nonDetCmpTypes :: [Type] -> [Type] -> Ordering+nonDetCmpTypes ts1 ts2 = nonDetCmpTypesX rn_env ts1 ts2+  where+    rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes (ts1 ++ ts2)))++-- | An ordering relation between two 'Type's (known below as @t1 :: k1@+-- and @t2 :: k2@)+data TypeOrdering = TLT  -- ^ @t1 < t2@+                  | TEQ  -- ^ @t1 ~ t2@ and there are no casts in either,+                         -- therefore we can conclude @k1 ~ k2@+                  | TEQX -- ^ @t1 ~ t2@ yet one of the types contains a cast so+                         -- they may differ in kind.+                  | TGT  -- ^ @t1 > t2@+                  deriving (Eq, Ord, Enum, Bounded)++nonDetCmpTypeX :: RnEnv2 -> Type -> Type -> Ordering  -- Main workhorse+    -- See Note [Non-trivial definitional equality] in TyCoRep+nonDetCmpTypeX env orig_t1 orig_t2 =+    case go env orig_t1 orig_t2 of+      -- If there are casts then we also need to do a comparison of the kinds of+      -- the types being compared+      TEQX          -> toOrdering $ go env k1 k2+      ty_ordering   -> toOrdering ty_ordering+  where+    k1 = typeKind orig_t1+    k2 = typeKind orig_t2++    toOrdering :: TypeOrdering -> Ordering+    toOrdering TLT  = LT+    toOrdering TEQ  = EQ+    toOrdering TEQX = EQ+    toOrdering TGT  = GT++    liftOrdering :: Ordering -> TypeOrdering+    liftOrdering LT = TLT+    liftOrdering EQ = TEQ+    liftOrdering GT = TGT++    thenCmpTy :: TypeOrdering -> TypeOrdering -> TypeOrdering+    thenCmpTy TEQ  rel  = rel+    thenCmpTy TEQX rel  = hasCast rel+    thenCmpTy rel  _    = rel++    hasCast :: TypeOrdering -> TypeOrdering+    hasCast TEQ = TEQX+    hasCast rel = rel++    -- Returns both the resulting ordering relation between the two types+    -- and whether either contains a cast.+    go :: RnEnv2 -> Type -> Type -> TypeOrdering+    go env t1 t2+      | Just t1' <- coreView t1 = go env t1' t2+      | Just t2' <- coreView t2 = go env t1 t2'++    go env (TyVarTy tv1)       (TyVarTy tv2)+      = liftOrdering $ rnOccL env tv1 `nonDetCmpVar` rnOccR env tv2+    go env (ForAllTy (TvBndr tv1 _) t1) (ForAllTy (TvBndr tv2 _) t2)+      = go env (tyVarKind tv1) (tyVarKind tv2)+        `thenCmpTy` go (rnBndr2 env tv1 tv2) t1 t2+        -- See Note [Equality on AppTys]+    go env (AppTy s1 t1) ty2+      | Just (s2, t2) <- repSplitAppTy_maybe ty2+      = go env s1 s2 `thenCmpTy` go env t1 t2+    go env ty1 (AppTy s2 t2)+      | Just (s1, t1) <- repSplitAppTy_maybe ty1+      = go env s1 s2 `thenCmpTy` go env t1 t2+    go env (FunTy s1 t1) (FunTy s2 t2)+      = go env s1 s2 `thenCmpTy` go env t1 t2+    go env (TyConApp tc1 tys1) (TyConApp tc2 tys2)+      = liftOrdering (tc1 `nonDetCmpTc` tc2) `thenCmpTy` gos env tys1 tys2+    go _   (LitTy l1)          (LitTy l2)          = liftOrdering (compare l1 l2)+    go env (CastTy t1 _)       t2                  = hasCast $ go env t1 t2+    go env t1                  (CastTy t2 _)       = hasCast $ go env t1 t2++    go _   (CoercionTy {})     (CoercionTy {})     = TEQ++        -- Deal with the rest: TyVarTy < CoercionTy < AppTy < LitTy < TyConApp < ForAllTy+    go _ ty1 ty2+      = liftOrdering $ (get_rank ty1) `compare` (get_rank ty2)+      where get_rank :: Type -> Int+            get_rank (CastTy {})+              = pprPanic "nonDetCmpTypeX.get_rank" (ppr [ty1,ty2])+            get_rank (TyVarTy {})    = 0+            get_rank (CoercionTy {}) = 1+            get_rank (AppTy {})      = 3+            get_rank (LitTy {})      = 4+            get_rank (TyConApp {})   = 5+            get_rank (FunTy {})      = 6+            get_rank (ForAllTy {})   = 7++    gos :: RnEnv2 -> [Type] -> [Type] -> TypeOrdering+    gos _   []         []         = TEQ+    gos _   []         _          = TLT+    gos _   _          []         = TGT+    gos env (ty1:tys1) (ty2:tys2) = go env ty1 ty2 `thenCmpTy` gos env tys1 tys2++-------------+nonDetCmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering+nonDetCmpTypesX _   []        []        = EQ+nonDetCmpTypesX env (t1:tys1) (t2:tys2) = nonDetCmpTypeX env t1 t2+                                      `thenCmp` nonDetCmpTypesX env tys1 tys2+nonDetCmpTypesX _   []        _         = LT+nonDetCmpTypesX _   _         []        = GT++-------------+-- | Compare two 'TyCon's. NB: This should /never/ see the "star synonyms",+-- as recognized by Kind.isStarKindSynonymTyCon. See Note+-- [Kind Constraint and kind *] in Kind.+-- See Note [nonDetCmpType nondeterminism]+nonDetCmpTc :: TyCon -> TyCon -> Ordering+nonDetCmpTc tc1 tc2+  = ASSERT( not (isStarKindSynonymTyCon tc1) && not (isStarKindSynonymTyCon tc2) )+    u1 `nonDetCmpUnique` u2+  where+    u1  = tyConUnique tc1+    u2  = tyConUnique tc2++{-+************************************************************************+*                                                                      *+        The kind of a type+*                                                                      *+************************************************************************+-}++typeKind :: Type -> Kind+typeKind (TyConApp tc tys)     = piResultTys (tyConKind tc) tys+typeKind (AppTy fun arg)       = piResultTy (typeKind fun) arg+typeKind (LitTy l)             = typeLiteralKind l+typeKind (FunTy {})            = liftedTypeKind+typeKind (ForAllTy _ ty)       = typeKind ty+typeKind (TyVarTy tyvar)       = tyVarKind tyvar+typeKind (CastTy _ty co)       = pSnd $ coercionKind co+typeKind (CoercionTy co)       = coercionType co++typeLiteralKind :: TyLit -> Kind+typeLiteralKind l =+  case l of+    NumTyLit _ -> typeNatKind+    StrTyLit _ -> typeSymbolKind++-- | Returns True if a type is levity polymorphic. Should be the same+-- as (isKindLevPoly . typeKind) but much faster.+-- Precondition: The type has kind (TYPE blah)+isTypeLevPoly :: Type -> Bool+isTypeLevPoly = go+  where+    go ty@(TyVarTy {})                           = check_kind ty+    go ty@(AppTy {})                             = check_kind ty+    go ty@(TyConApp tc _) | not (isTcLevPoly tc) = False+                          | otherwise            = check_kind ty+    go (ForAllTy _ ty)                           = go ty+    go (FunTy {})                                = False+    go (LitTy {})                                = False+    go ty@(CastTy {})                            = check_kind ty+    go ty@(CoercionTy {})                        = pprPanic "isTypeLevPoly co" (ppr ty)++    check_kind = isKindLevPoly . typeKind++-- | Looking past all pi-types, is the end result potentially levity polymorphic?+-- Example: True for (forall r (a :: TYPE r). String -> a)+-- Example: False for (forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b -> Type)+resultIsLevPoly :: Type -> Bool+resultIsLevPoly = isTypeLevPoly . snd . splitPiTys++{-+%************************************************************************+%*                                                                      *+        Miscellaneous functions+%*                                                                      *+%************************************************************************++-}+-- | All type constructors occurring in the type; looking through type+--   synonyms, but not newtypes.+--  When it finds a Class, it returns the class TyCon.+tyConsOfType :: Type -> UniqSet TyCon+tyConsOfType ty+  = go ty+  where+     go :: Type -> UniqSet TyCon  -- The UniqSet does duplicate elim+     go ty | Just ty' <- coreView ty = go ty'+     go (TyVarTy {})                = emptyUniqSet+     go (LitTy {})                  = emptyUniqSet+     go (TyConApp tc tys)           = go_tc tc `unionUniqSets` go_s tys+     go (AppTy a b)                 = go a `unionUniqSets` go b+     go (FunTy a b)                 = go a `unionUniqSets` go b `unionUniqSets` go_tc funTyCon+     go (ForAllTy (TvBndr tv _) ty) = go ty `unionUniqSets` go (tyVarKind tv)+     go (CastTy ty co)              = go ty `unionUniqSets` go_co co+     go (CoercionTy co)             = go_co co++     go_co (Refl _ ty)             = go ty+     go_co (TyConAppCo _ tc args)  = go_tc tc `unionUniqSets` go_cos args+     go_co (AppCo co arg)          = go_co co `unionUniqSets` go_co arg+     go_co (ForAllCo _ kind_co co) = go_co kind_co `unionUniqSets` go_co co+     go_co (FunCo _ co1 co2)       = go_co co1 `unionUniqSets` go_co co2+     go_co (AxiomInstCo ax _ args) = go_ax ax `unionUniqSets` go_cos args+     go_co (UnivCo p _ t1 t2)      = go_prov p `unionUniqSets` go t1 `unionUniqSets` go t2+     go_co (CoVarCo {})            = emptyUniqSet+     go_co (SymCo co)              = go_co co+     go_co (TransCo co1 co2)       = go_co co1 `unionUniqSets` go_co co2+     go_co (NthCo _ co)            = go_co co+     go_co (LRCo _ co)             = go_co co+     go_co (InstCo co arg)         = go_co co `unionUniqSets` go_co arg+     go_co (CoherenceCo co1 co2)   = go_co co1 `unionUniqSets` go_co co2+     go_co (KindCo co)             = go_co co+     go_co (SubCo co)              = go_co co+     go_co (AxiomRuleCo _ cs)      = go_cos cs++     go_prov UnsafeCoerceProv    = emptyUniqSet+     go_prov (PhantomProv co)    = go_co co+     go_prov (ProofIrrelProv co) = go_co co+     go_prov (PluginProv _)      = emptyUniqSet+     go_prov (HoleProv _)        = emptyUniqSet+        -- this last case can happen from the tyConsOfType used from+        -- checkTauTvUpdate++     go_s tys     = foldr (unionUniqSets . go)     emptyUniqSet tys+     go_cos cos   = foldr (unionUniqSets . go_co)  emptyUniqSet cos++     go_tc tc = unitUniqSet tc+     go_ax ax = go_tc $ coAxiomTyCon ax++-- | Find the result 'Kind' of a type synonym,+-- after applying it to its 'arity' number of type variables+-- Actually this function works fine on data types too,+-- but they'd always return '*', so we never need to ask+synTyConResKind :: TyCon -> Kind+synTyConResKind tycon = piResultTys (tyConKind tycon) (mkTyVarTys (tyConTyVars tycon))++-- | Retrieve the free variables in this type, splitting them based+-- on whether they are used visibly or invisibly. Invisible ones come+-- first.+splitVisVarsOfType :: Type -> Pair TyCoVarSet+splitVisVarsOfType orig_ty = Pair invis_vars vis_vars+  where+    Pair invis_vars1 vis_vars = go orig_ty+    invis_vars = invis_vars1 `minusVarSet` vis_vars++    go (TyVarTy tv)      = Pair (tyCoVarsOfType $ tyVarKind tv) (unitVarSet tv)+    go (AppTy t1 t2)     = go t1 `mappend` go t2+    go (TyConApp tc tys) = go_tc tc tys+    go (FunTy t1 t2)     = go t1 `mappend` go t2+    go (ForAllTy (TvBndr tv _) ty)+      = ((`delVarSet` tv) <$> go ty) `mappend`+        (invisible (tyCoVarsOfType $ tyVarKind tv))+    go (LitTy {}) = mempty+    go (CastTy ty co) = go ty `mappend` invisible (tyCoVarsOfCo co)+    go (CoercionTy co) = invisible $ tyCoVarsOfCo co++    invisible vs = Pair vs emptyVarSet++    go_tc tc tys = let (invis, vis) = partitionInvisibles tc id tys in+                   invisible (tyCoVarsOfTypes invis) `mappend` foldMap go vis++splitVisVarsOfTypes :: [Type] -> Pair TyCoVarSet+splitVisVarsOfTypes = foldMap splitVisVarsOfType++modifyJoinResTy :: Int            -- Number of binders to skip+                -> (Type -> Type) -- Function to apply to result type+                -> Type           -- Type of join point+                -> Type           -- New type+-- INVARIANT: If any of the first n binders are foralls, those tyvars cannot+-- appear in the original result type. See isValidJoinPointType.+modifyJoinResTy orig_ar f orig_ty+  = go orig_ar orig_ty+  where+    go 0 ty = f ty+    go n ty | Just (arg_bndr, res_ty) <- splitPiTy_maybe ty+            = mkPiTy arg_bndr (go (n-1) res_ty)+            | otherwise+            = pprPanic "modifyJoinResTy" (ppr orig_ar <+> ppr orig_ty)++setJoinResTy :: Int  -- Number of binders to skip+             -> Type -- New result type+             -> Type -- Type of join point+             -> Type -- New type+-- INVARIANT: Same as for modifyJoinResTy+setJoinResTy ar new_res_ty ty+  = modifyJoinResTy ar (const new_res_ty) ty
+ types/Type.hs-boot view
@@ -0,0 +1,26 @@+{-# LANGUAGE FlexibleContexts #-}++module Type where+import TyCon+import Var ( TyVar )+import {-# SOURCE #-} TyCoRep( Type, Coercion, Kind )+import Util++isPredTy     :: Type -> Bool+isCoercionTy :: Type -> Bool++mkAppTy :: Type -> Type -> Type+mkCastTy :: Type -> Coercion -> Type+piResultTy :: Type -> Type -> Type++typeKind :: Type -> Kind+eqType :: Type -> Type -> Bool++partitionInvisibles :: TyCon -> (a -> Type) -> [a] -> ([a], [a])++coreView :: Type -> Maybe Type+tcView :: Type -> Maybe Type++tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar]+tyCoVarsOfTypeWellScoped :: Type -> [TyVar]+splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])
+ types/Unify.hs view
@@ -0,0 +1,1344 @@+-- (c) The University of Glasgow 2006++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}++module Unify (+        tcMatchTy, tcMatchTyKi,+        tcMatchTys, tcMatchTyKis,+        tcMatchTyX, tcMatchTysX, tcMatchTyKisX,+        ruleMatchTyKiX,++        -- * Rough matching+        roughMatchTcs, instanceCantMatch,+        typesCantMatch,++        -- Side-effect free unification+        tcUnifyTy, tcUnifyTyKi, tcUnifyTys, tcUnifyTyKis,+        tcUnifyTysFG, tcUnifyTyWithTFs,+        BindFlag(..),+        UnifyResult, UnifyResultM(..),++        -- Matching a type against a lifted type (coercion)+        liftCoMatch+   ) where++#include "HsVersions.h"++import Var+import VarEnv+import VarSet+import Kind+import Name( Name )+import Type hiding ( getTvSubstEnv )+import Coercion hiding ( getCvSubstEnv )+import TyCon+import TyCoRep hiding ( getTvSubstEnv, getCvSubstEnv )+import Util+import Pair+import Outputable+import UniqFM+import UniqSet++import Control.Monad+#if __GLASGOW_HASKELL__ > 710+import qualified Control.Monad.Fail as MonadFail+#endif+import Control.Applicative hiding ( empty )+import qualified Control.Applicative++{-++Unification is much tricker than you might think.++1. The substitution we generate binds the *template type variables*+   which are given to us explicitly.++2. We want to match in the presence of foralls;+        e.g     (forall a. t1) ~ (forall b. t2)++   That is what the RnEnv2 is for; it does the alpha-renaming+   that makes it as if a and b were the same variable.+   Initialising the RnEnv2, so that it can generate a fresh+   binder when necessary, entails knowing the free variables of+   both types.++3. We must be careful not to bind a template type variable to a+   locally bound variable.  E.g.+        (forall a. x) ~ (forall b. b)+   where x is the template type variable.  Then we do not want to+   bind x to a/b!  This is a kind of occurs check.+   The necessary locals accumulate in the RnEnv2.+-}++-- | @tcMatchTy t1 t2@ produces a substitution (over fvs(t1))+-- @s@ such that @s(t1)@ equals @t2@.+-- The returned substitution might bind coercion variables,+-- if the variable is an argument to a GADT constructor.+--+-- Precondition: typeKind ty1 `eqType` typeKind ty2+--+-- We don't pass in a set of "template variables" to be bound+-- by the match, because tcMatchTy (and similar functions) are+-- always used on top-level types, so we can bind any of the+-- free variables of the LHS.+tcMatchTy :: Type -> Type -> Maybe TCvSubst+tcMatchTy ty1 ty2 = tcMatchTys [ty1] [ty2]++-- | Like 'tcMatchTy', but allows the kinds of the types to differ,+-- and thus matches them as well.+tcMatchTyKi :: Type -> Type -> Maybe TCvSubst+tcMatchTyKi ty1 ty2 = tcMatchTyKis [ty1] [ty2]++-- | This is similar to 'tcMatchTy', but extends a substitution+tcMatchTyX :: TCvSubst            -- ^ Substitution to extend+           -> Type                -- ^ Template+           -> Type                -- ^ Target+           -> Maybe TCvSubst+tcMatchTyX subst ty1 ty2 = tcMatchTysX subst [ty1] [ty2]++-- | Like 'tcMatchTy' but over a list of types.+tcMatchTys :: [Type]         -- ^ Template+           -> [Type]         -- ^ Target+           -> Maybe TCvSubst -- ^ One-shot; in principle the template+                             -- variables could be free in the target+tcMatchTys tys1 tys2+  = tcMatchTysX (mkEmptyTCvSubst in_scope) tys1 tys2+  where+    in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2)++-- | Like 'tcMatchTyKi' but over a list of types.+tcMatchTyKis :: [Type]         -- ^ Template+             -> [Type]         -- ^ Target+             -> Maybe TCvSubst -- ^ One-shot substitution+tcMatchTyKis tys1 tys2+  = tcMatchTyKisX (mkEmptyTCvSubst in_scope) tys1 tys2+  where+    in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2)++-- | Like 'tcMatchTys', but extending a substitution+tcMatchTysX :: TCvSubst       -- ^ Substitution to extend+            -> [Type]         -- ^ Template+            -> [Type]         -- ^ Target+            -> Maybe TCvSubst -- ^ One-shot substitution+tcMatchTysX subst tys1 tys2+  = tc_match_tys_x False subst tys1 tys2++-- | Like 'tcMatchTyKis', but extending a substitution+tcMatchTyKisX :: TCvSubst        -- ^ Substitution to extend+              -> [Type]          -- ^ Template+              -> [Type]          -- ^ Target+              -> Maybe TCvSubst  -- ^ One-shot substitution+tcMatchTyKisX subst tys1 tys2+  = tc_match_tys_x True subst tys1 tys2++-- | Worker for 'tcMatchTysX' and 'tcMatchTyKisX'+tc_match_tys_x :: Bool          -- ^ match kinds?+               -> TCvSubst+               -> [Type]+               -> [Type]+               -> Maybe TCvSubst+tc_match_tys_x match_kis (TCvSubst in_scope tv_env cv_env) tys1 tys2+  = case tc_unify_tys (const BindMe)+                      False  -- Matching, not unifying+                      False  -- Not an injectivity check+                      match_kis+                      (mkRnEnv2 in_scope) tv_env cv_env tys1 tys2 of+      Unifiable (tv_env', cv_env')+        -> Just $ TCvSubst in_scope tv_env' cv_env'+      _ -> Nothing++-- | This one is called from the expression matcher,+-- which already has a MatchEnv in hand+ruleMatchTyKiX+  :: TyCoVarSet          -- ^ template variables+  -> RnEnv2+  -> TvSubstEnv          -- ^ type substitution to extend+  -> Type                -- ^ Template+  -> Type                -- ^ Target+  -> Maybe TvSubstEnv+ruleMatchTyKiX tmpl_tvs rn_env tenv tmpl target+-- See Note [Kind coercions in Unify]+  = case tc_unify_tys (matchBindFun tmpl_tvs) False False+                      True -- <-- this means to match the kinds+                      rn_env tenv emptyCvSubstEnv [tmpl] [target] of+      Unifiable (tenv', _) -> Just tenv'+      _                    -> Nothing++matchBindFun :: TyCoVarSet -> TyVar -> BindFlag+matchBindFun tvs tv = if tv `elemVarSet` tvs then BindMe else Skolem+++{- *********************************************************************+*                                                                      *+                Rough matching+*                                                                      *+********************************************************************* -}++-- See Note [Rough match] field in InstEnv++roughMatchTcs :: [Type] -> [Maybe Name]+roughMatchTcs tys = map rough tys+  where+    rough ty+      | Just (ty', _) <- splitCastTy_maybe ty   = rough ty'+      | Just (tc,_)   <- splitTyConApp_maybe ty = Just (tyConName tc)+      | otherwise                               = Nothing++instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool+-- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot+-- possibly be instantiated to actual, nor vice versa;+-- False is non-committal+instanceCantMatch (mt : ts) (ma : as) = itemCantMatch mt ma || instanceCantMatch ts as+instanceCantMatch _         _         =  False  -- Safe++itemCantMatch :: Maybe Name -> Maybe Name -> Bool+itemCantMatch (Just t) (Just a) = t /= a+itemCantMatch _        _        = False+++{-+************************************************************************+*                                                                      *+                GADTs+*                                                                      *+************************************************************************++Note [Pruning dead case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider        data T a where+                   T1 :: T Int+                   T2 :: T a++                newtype X = MkX Int+                newtype Y = MkY Char++                type family F a+                type instance F Bool = Int++Now consider    case x of { T1 -> e1; T2 -> e2 }++The question before the house is this: if I know something about the type+of x, can I prune away the T1 alternative?++Suppose x::T Char.  It's impossible to construct a (T Char) using T1,+        Answer = YES we can prune the T1 branch (clearly)++Suppose x::T (F a), where 'a' is in scope.  Then 'a' might be instantiated+to 'Bool', in which case x::T Int, so+        ANSWER = NO (clearly)++We see here that we want precisely the apartness check implemented within+tcUnifyTysFG. So that's what we do! Two types cannot match if they are surely+apart. Note that since we are simply dropping dead code, a conservative test+suffices.+-}++-- | Given a list of pairs of types, are any two members of a pair surely+-- apart, even after arbitrary type function evaluation and substitution?+typesCantMatch :: [(Type,Type)] -> Bool+-- See Note [Pruning dead case alternatives]+typesCantMatch prs = any (uncurry cant_match) prs+  where+    cant_match :: Type -> Type -> Bool+    cant_match t1 t2 = case tcUnifyTysFG (const BindMe) [t1] [t2] of+      SurelyApart -> True+      _           -> False++{-+************************************************************************+*                                                                      *+             Unification+*                                                                      *+************************************************************************++Note [Fine-grained unification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Do the types (x, x) and ([y], y) unify? The answer is seemingly "no" --+no substitution to finite types makes these match. But, a substitution to+*infinite* types can unify these two types: [x |-> [[[...]]], y |-> [[[...]]] ].+Why do we care? Consider these two type family instances:++type instance F x x   = Int+type instance F [y] y = Bool++If we also have++type instance Looper = [Looper]++then the instances potentially overlap. The solution is to use unification+over infinite terms. This is possible (see [1] for lots of gory details), but+a full algorithm is a little more power than we need. Instead, we make a+conservative approximation and just omit the occurs check.++[1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf++tcUnifyTys considers an occurs-check problem as the same as general unification+failure.++tcUnifyTysFG ("fine-grained") returns one of three results: success, occurs-check+failure ("MaybeApart"), or general failure ("SurelyApart").++See also Trac #8162.++It's worth noting that unification in the presence of infinite types is not+complete. This means that, sometimes, a closed type family does not reduce+when it should. See test case indexed-types/should_fail/Overlap15 for an+example.++Note [The substitution in MaybeApart]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The constructor MaybeApart carries data with it, typically a TvSubstEnv. Why?+Because consider unifying these:++(a, a, Int) ~ (b, [b], Bool)++If we go left-to-right, we start with [a |-> b]. Then, on the middle terms, we+apply the subst we have so far and discover that we need [b |-> [b]]. Because+this fails the occurs check, we say that the types are MaybeApart (see above+Note [Fine-grained unification]). But, we can't stop there! Because if we+continue, we discover that Int is SurelyApart from Bool, and therefore the+types are apart. This has practical consequences for the ability for closed+type family applications to reduce. See test case+indexed-types/should_compile/Overlap14.++Note [Unifying with skolems]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we discover that two types unify if and only if a skolem variable is+substituted, we can't properly unify the types. But, that skolem variable+may later be instantiated with a unifyable type. So, we return maybeApart+in these cases.++Note [Lists of different lengths are MaybeApart]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is unusual to call tcUnifyTys or tcUnifyTysFG with lists of different+lengths. The place where we know this can happen is from compatibleBranches in+FamInstEnv, when checking data family instances. Data family instances may be+eta-reduced; see Note [Eta reduction for data family axioms] in TcInstDcls.++We wish to say that++  D :: * -> * -> *+  axDF1 :: D Int ~ DFInst1+  axDF2 :: D Int Bool ~ DFInst2++overlap. If we conclude that lists of different lengths are SurelyApart, then+it will look like these do *not* overlap, causing disaster. See Trac #9371.++In usages of tcUnifyTys outside of family instances, we always use tcUnifyTys,+which can't tell the difference between MaybeApart and SurelyApart, so those+usages won't notice this design choice.+-}++-- | Simple unification of two types; all type variables are bindable+-- Precondition: the kinds are already equal+tcUnifyTy :: Type -> Type       -- All tyvars are bindable+          -> Maybe TCvSubst+                       -- A regular one-shot (idempotent) substitution+tcUnifyTy t1 t2 = tcUnifyTys (const BindMe) [t1] [t2]++-- | Like 'tcUnifyTy', but also unifies the kinds+tcUnifyTyKi :: Type -> Type -> Maybe TCvSubst+tcUnifyTyKi t1 t2 = tcUnifyTyKis (const BindMe) [t1] [t2]++-- | Unify two types, treating type family applications as possibly unifying+-- with anything and looking through injective type family applications.+-- Precondition: kinds are the same+tcUnifyTyWithTFs :: Bool  -- ^ True <=> do two-way unification;+                          --   False <=> do one-way matching.+                          --   See end of sec 5.2 from the paper+                 -> Type -> Type -> Maybe TCvSubst+-- This algorithm is an implementation of the "Algorithm U" presented in+-- the paper "Injective type families for Haskell", Figures 2 and 3.+-- The code is incorporated with the standard unifier for convenience, but+-- its operation should match the specification in the paper.+tcUnifyTyWithTFs twoWay t1 t2+  = case tc_unify_tys (const BindMe) twoWay True False+                       rn_env emptyTvSubstEnv emptyCvSubstEnv+                       [t1] [t2] of+      Unifiable  (subst, _) -> Just $ niFixTCvSubst subst+      MaybeApart (subst, _) -> Just $ niFixTCvSubst subst+      -- we want to *succeed* in questionable cases. This is a+      -- pre-unification algorithm.+      SurelyApart      -> Nothing+  where+    rn_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [t1, t2]++-----------------+tcUnifyTys :: (TyCoVar -> BindFlag)+           -> [Type] -> [Type]+           -> Maybe TCvSubst+                                -- ^ A regular one-shot (idempotent) substitution+                                -- that unifies the erased types. See comments+                                -- for 'tcUnifyTysFG'++-- The two types may have common type variables, and indeed do so in the+-- second call to tcUnifyTys in FunDeps.checkClsFD+tcUnifyTys bind_fn tys1 tys2+  = case tcUnifyTysFG bind_fn tys1 tys2 of+      Unifiable result -> Just result+      _                -> Nothing++-- | Like 'tcUnifyTys' but also unifies the kinds+tcUnifyTyKis :: (TyCoVar -> BindFlag)+             -> [Type] -> [Type]+             -> Maybe TCvSubst+tcUnifyTyKis bind_fn tys1 tys2+  = case tcUnifyTyKisFG bind_fn tys1 tys2 of+      Unifiable result -> Just result+      _                -> Nothing++-- This type does double-duty. It is used in the UM (unifier monad) and to+-- return the final result. See Note [Fine-grained unification]+type UnifyResult = UnifyResultM TCvSubst+data UnifyResultM a = Unifiable a        -- the subst that unifies the types+                    | MaybeApart a       -- the subst has as much as we know+                                         -- it must be part of an most general unifier+                                         -- See Note [The substitution in MaybeApart]+                    | SurelyApart+                    deriving Functor++instance Applicative UnifyResultM where+  pure  = Unifiable+  (<*>) = ap++instance Monad UnifyResultM where++  SurelyApart  >>= _ = SurelyApart+  MaybeApart x >>= f = case f x of+                         Unifiable y -> MaybeApart y+                         other       -> other+  Unifiable x  >>= f = f x++instance Alternative UnifyResultM where+  empty = SurelyApart++  a@(Unifiable {})  <|> _                 = a+  _                 <|> b@(Unifiable {})  = b+  a@(MaybeApart {}) <|> _                 = a+  _                 <|> b@(MaybeApart {}) = b+  SurelyApart       <|> SurelyApart       = SurelyApart++instance MonadPlus UnifyResultM++-- | @tcUnifyTysFG bind_tv tys1 tys2@ attepts to find a substitution @s@ (whose+-- domain elements all respond 'BindMe' to @bind_tv@) such that+-- @s(tys1)@ and that of @s(tys2)@ are equal, as witnessed by the returned+-- Coercions. This version requires that the kinds of the types are the same,+-- if you unify left-to-right.+tcUnifyTysFG :: (TyVar -> BindFlag)+             -> [Type] -> [Type]+             -> UnifyResult+tcUnifyTysFG bind_fn tys1 tys2+  = tc_unify_tys_fg False bind_fn tys1 tys2++tcUnifyTyKisFG :: (TyVar -> BindFlag)+               -> [Type] -> [Type]+               -> UnifyResult+tcUnifyTyKisFG bind_fn tys1 tys2+  = tc_unify_tys_fg True bind_fn tys1 tys2++tc_unify_tys_fg :: Bool+                -> (TyVar -> BindFlag)+                -> [Type] -> [Type]+                -> UnifyResult+tc_unify_tys_fg match_kis bind_fn tys1 tys2+  = do { (env, _) <- tc_unify_tys bind_fn True False match_kis env+                                  emptyTvSubstEnv emptyCvSubstEnv+                                  tys1 tys2+       ; return $ niFixTCvSubst env }+  where+    vars = tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2+    env  = mkRnEnv2 $ mkInScopeSet vars++-- | This function is actually the one to call the unifier -- a little+-- too general for outside clients, though.+tc_unify_tys :: (TyVar -> BindFlag)+             -> AmIUnifying -- ^ True <=> unify; False <=> match+             -> Bool        -- ^ True <=> doing an injectivity check+             -> Bool        -- ^ True <=> treat the kinds as well+             -> RnEnv2+             -> TvSubstEnv  -- ^ substitution to extend+             -> CvSubstEnv+             -> [Type] -> [Type]+             -> UnifyResultM (TvSubstEnv, CvSubstEnv)+tc_unify_tys bind_fn unif inj_check match_kis rn_env tv_env cv_env tys1 tys2+  = initUM tv_env cv_env $+    do { when match_kis $+         unify_tys env kis1 kis2+       ; unify_tys env tys1 tys2+       ; (,) <$> getTvSubstEnv <*> getCvSubstEnv }+  where+    env = UMEnv { um_bind_fun = bind_fn+                , um_unif     = unif+                , um_inj_tf   = inj_check+                , um_rn_env   = rn_env }++    kis1 = map typeKind tys1+    kis2 = map typeKind tys2++instance Outputable a => Outputable (UnifyResultM a) where+  ppr SurelyApart    = text "SurelyApart"+  ppr (Unifiable x)  = text "Unifiable" <+> ppr x+  ppr (MaybeApart x) = text "MaybeApart" <+> ppr x++{-+************************************************************************+*                                                                      *+                Non-idempotent substitution+*                                                                      *+************************************************************************++Note [Non-idempotent substitution]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+During unification we use a TvSubstEnv/CvSubstEnv pair that is+  (a) non-idempotent+  (b) loop-free; ie repeatedly applying it yields a fixed point++Note [Finding the substitution fixpoint]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Finding the fixpoint of a non-idempotent substitution arising from a+unification is harder than it looks, because of kinds.  Consider+   T k (H k (f:k)) ~ T * (g:*)+If we unify, we get the substitution+   [ k -> *+   , g -> H k (f:k) ]+To make it idempotent we don't want to get just+   [ k -> *+   , g -> H * (f:k) ]+We also want to substitute inside f's kind, to get+   [ k -> *+   , g -> H k (f:*) ]+If we don't do this, we may apply the substitution to something,+and get an ill-formed type, i.e. one where typeKind will fail.+This happened, for example, in Trac #9106.++This is the reason for extending env with [f:k -> f:*], in the+definition of env' in niFixTvSubst+-}++niFixTCvSubst :: TvSubstEnv -> TCvSubst+-- Find the idempotent fixed point of the non-idempotent substitution+-- See Note [Finding the substitution fixpoint]+-- ToDo: use laziness instead of iteration?+niFixTCvSubst tenv = f tenv+  where+    f tenv+        | not_fixpoint = f (mapVarEnv (substTy subst') tenv)+        | otherwise    = subst+        where+          not_fixpoint  = anyVarSet in_domain range_tvs+          in_domain tv  = tv `elemVarEnv` tenv++          range_tvs     = nonDetFoldUFM (unionVarSet . tyCoVarsOfType) emptyVarSet tenv+                          -- It's OK to use nonDetFoldUFM here because we+                          -- forget the order immediately by creating a set+          subst         = mkTvSubst (mkInScopeSet range_tvs) tenv++             -- env' extends env by replacing any free type with+             -- that same tyvar with a substituted kind+             -- See note [Finding the substitution fixpoint]+          tenv'  = extendVarEnvList tenv [ (rtv, mkTyVarTy $+                                                 setTyVarKind rtv $+                                                 substTy subst $+                                                 tyVarKind rtv)+                                         | rtv <- nonDetEltsUniqSet range_tvs+                                         -- It's OK to use nonDetEltsUniqSet here+                                         -- because we forget the order+                                         -- immediatedly by putting it in VarEnv+                                         , not (in_domain rtv) ]+          subst' = mkTvSubst (mkInScopeSet range_tvs) tenv'++niSubstTvSet :: TvSubstEnv -> TyCoVarSet -> TyCoVarSet+-- Apply the non-idempotent substitution to a set of type variables,+-- remembering that the substitution isn't necessarily idempotent+-- This is used in the occurs check, before extending the substitution+niSubstTvSet tsubst tvs+  = nonDetFoldUniqSet (unionVarSet . get) emptyVarSet tvs+  -- It's OK to nonDetFoldUFM here because we immediately forget the+  -- ordering by creating a set.+  where+    get tv+      | Just ty <- lookupVarEnv tsubst tv+      = niSubstTvSet tsubst (tyCoVarsOfType ty)++      | otherwise+      = unitVarSet tv++{-+************************************************************************+*                                                                      *+                unify_ty: the main workhorse+*                                                                      *+************************************************************************++Note [Specification of unification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The pure unifier, unify_ty, defined in this module, tries to work out+a substitution to make two types say True to eqType. NB: eqType is+itself not purely syntactic; it accounts for CastTys;+see Note [Non-trivial definitional equality] in TyCoRep++Unlike the "impure unifiers" in the typechecker (the eager unifier in+TcUnify, and the constraint solver itself in TcCanonical), the pure+unifier It does /not/ work up to ~.++The algorithm implemented here is rather delicate, and we depend on it+to uphold certain properties. This is a summary of these required+properties. Any reference to "flattening" refers to the flattening+algorithm in FamInstEnv (See Note [Flattening] in FamInstEnv), not+the flattening algorithm in the solver.++Notation:+ θ,φ    substitutions+ ξ    type-function-free types+ τ,σ  other types+ τ♭   type τ, flattened++ ≡    eqType++(U1) Soundness.+     If (unify τ₁ τ₂) = Unifiable θ, then θ(τ₁) ≡ θ(τ₂).+     θ is a most general unifier for τ₁ and τ₂.++(U2) Completeness.+     If (unify ξ₁ ξ₂) = SurelyApart,+     then there exists no substitution θ such that θ(ξ₁) ≡ θ(ξ₂).++These two properties are stated as Property 11 in the "Closed Type Families"+paper (POPL'14). Below, this paper is called [CTF].++(U3) Apartness under substitution.+     If (unify ξ τ♭) = SurelyApart, then (unify ξ θ(τ)♭) = SurelyApart,+     for any θ. (Property 12 from [CTF])++(U4) Apart types do not unify.+     If (unify ξ τ♭) = SurelyApart, then there exists no θ+     such that θ(ξ) = θ(τ). (Property 13 from [CTF])++THEOREM. Completeness w.r.t ~+    If (unify τ₁♭ τ₂♭) = SurelyApart,+    then there exists no proof that (τ₁ ~ τ₂).++PROOF. See appendix of [CTF].+++The unification algorithm is used for type family injectivity, as described+in the "Injective Type Families" paper (Haskell'15), called [ITF]. When run+in this mode, it has the following properties.++(I1) If (unify σ τ) = SurelyApart, then σ and τ are not unifiable, even+     after arbitrary type family reductions. Note that σ and τ are+     not flattened here.++(I2) If (unify σ τ) = MaybeApart θ, and if some+     φ exists such that φ(σ) ~ φ(τ), then φ extends θ.+++Furthermore, the RULES matching algorithm requires this property,+but only when using this algorithm for matching:++(M1) If (match σ τ) succeeds with θ, then all matchable tyvars+     in σ are bound in θ.++     Property M1 means that we must extend the substitution with,+     say (a ↦ a) when appropriate during matching.+     See also Note [Self-substitution when matching].++(M2) Completeness of matching.+     If θ(σ) = τ, then (match σ τ) = Unifiable φ,+     where θ is an extension of φ.++Sadly, property M2 and I2 conflict. Consider++type family F1 a b where+  F1 Int    Bool   = Char+  F1 Double String = Char++Consider now two matching problems:++P1. match (F1 a Bool) (F1 Int Bool)+P2. match (F1 a Bool) (F1 Double String)++In case P1, we must find (a ↦ Int) to satisfy M2.+In case P2, we must /not/ find (a ↦ Double), in order to satisfy I2. (Note+that the correct mapping for I2 is (a ↦ Int). There is no way to discover+this, but we musn't map a to anything else!)++We thus must parameterize the algorithm over whether it's being used+for an injectivity check (refrain from looking at non-injective arguments+to type families) or not (do indeed look at those arguments).  This is+implemented  by the uf_inj_tf field of UmEnv.++(It's all a question of whether or not to include equation (7) from Fig. 2+of [ITF].)++This extra parameter is a bit fiddly, perhaps, but seemingly less so than+having two separate, almost-identical algorithms.++Note [Self-substitution when matching]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What should happen when we're *matching* (not unifying) a1 with a1? We+should get a substitution [a1 |-> a1]. A successful match should map all+the template variables (except ones that disappear when expanding synonyms).+But when unifying, we don't want to do this, because we'll then fall into+a loop.++This arrangement affects the code in three places:+ - If we're matching a refined template variable, don't recur. Instead, just+   check for equality. That is, if we know [a |-> Maybe a] and are matching+   (a ~? Maybe Int), we want to just fail.++ - Skip the occurs check when matching. This comes up in two places, because+   matching against variables is handled separately from matching against+   full-on types.++Note that this arrangement was provoked by a real failure, where the same+unique ended up in the template as in the target. (It was a rule firing when+compiling Data.List.NonEmpty.)++Note [Matching coercion variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:++   type family F a++   data G a where+     MkG :: F a ~ Bool => G a++   type family Foo (x :: G a) :: F a+   type instance Foo MkG = False++We would like that to be accepted. For that to work, we need to introduce+a coercion variable on the left an then use it on the right. Accordingly,+at use sites of Foo, we need to be able to use matching to figure out the+value for the coercion. (See the desugared version:++   axFoo :: [a :: *, c :: F a ~ Bool]. Foo (MkG c) = False |> (sym c)++) We never want this action to happen during *unification* though, when+all bets are off.++Note [Kind coercions in Unify]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We wish to match/unify while ignoring casts. But, we can't just ignore+them completely, or we'll end up with ill-kinded substitutions. For example,+say we're matching `a` with `ty |> co`. If we just drop the cast, we'll+return [a |-> ty], but `a` and `ty` might have different kinds. We can't+just match/unify their kinds, either, because this might gratuitously+fail. After all, `co` is the witness that the kinds are the same -- they+may look nothing alike.++So, we pass a kind coercion to the match/unify worker. This coercion witnesses+the equality between the substed kind of the left-hand type and the substed+kind of the right-hand type. Note that we do not unify kinds at the leaves+(as we did previously). We thus have++INVARIANT: In the call+    unify_ty ty1 ty2 kco+it must be that subst(kco) :: subst(kind(ty1)) ~N subst(kind(ty2)), where+`subst` is the ambient substitution in the UM monad.++To get this coercion, we first have to match/unify+the kinds before looking at the types. Happily, we need look only one level+up, as all kinds are guaranteed to have kind *.++When we're working with type applications (either TyConApp or AppTy) we+need to worry about establishing INVARIANT, as the kinds of the function+& arguments aren't (necessarily) included in the kind of the result.+When unifying two TyConApps, this is easy, because the two TyCons are+the same. Their kinds are thus the same. As long as we unify left-to-right,+we'll be sure to unify types' kinds before the types themselves. (For example,+think about Proxy :: forall k. k -> *. Unifying the first args matches up+the kinds of the second args.)++For AppTy, we must unify the kinds of the functions, but once these are+unified, we can continue unifying arguments without worrying further about+kinds.++The interface to this module includes both "...Ty" functions and+"...TyKi" functions. The former assume that INVARIANT is already+established, either because the kinds are the same or because the+list of types being passed in are the well-typed arguments to some+type constructor (see two paragraphs above). The latter take a separate+pre-pass over the kinds to establish INVARIANT. Sometimes, it's important+not to take the second pass, as it caused #12442.++We thought, at one point, that this was all unnecessary: why should+casts be in types in the first place? But they are sometimes. In+dependent/should_compile/KindEqualities2, we see, for example the+constraint Num (Int |> (blah ; sym blah)).  We naturally want to find+a dictionary for that constraint, which requires dealing with+coercions in this manner.+-}++-------------- unify_ty: the main workhorse -----------++type AmIUnifying = Bool   -- True  <=> Unifying+                          -- False <=> Matching++unify_ty :: UMEnv+         -> Type -> Type  -- Types to be unified and a co+         -> Coercion      -- A coercion between their kinds+                          -- See Note [Kind coercions in Unify]+         -> UM ()+-- See Note [Specification of unification]+-- Respects newtypes, PredTypes++unify_ty env ty1 ty2 kco+    -- TODO: More commentary needed here+  | Just ty1' <- tcView ty1   = unify_ty env ty1' ty2 kco+  | Just ty2' <- tcView ty2   = unify_ty env ty1 ty2' kco+  | CastTy ty1' co <- ty1     = unify_ty env ty1' ty2 (co `mkTransCo` kco)+  | CastTy ty2' co <- ty2     = unify_ty env ty1 ty2' (kco `mkTransCo` mkSymCo co)++unify_ty env (TyVarTy tv1) ty2 kco+  = uVar env tv1 ty2 kco+unify_ty env ty1 (TyVarTy tv2) kco+  | um_unif env  -- If unifying, can swap args+  = uVar (umSwapRn env) tv2 ty1 (mkSymCo kco)++unify_ty env ty1 ty2 _kco+  | Just (tc1, tys1) <- mb_tc_app1+  , Just (tc2, tys2) <- mb_tc_app2+  , tc1 == tc2 || (tcIsStarKind ty1 && tcIsStarKind ty2)+  = if isInjectiveTyCon tc1 Nominal+    then unify_tys env tys1 tys2+    else do { let inj | isTypeFamilyTyCon tc1+                      = case familyTyConInjectivityInfo tc1 of+                               NotInjective -> repeat False+                               Injective bs -> bs+                      | otherwise+                      = repeat False++                  (inj_tys1, noninj_tys1) = partitionByList inj tys1+                  (inj_tys2, noninj_tys2) = partitionByList inj tys2++            ; unify_tys env inj_tys1 inj_tys2+            ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification]+              don'tBeSoSure $ unify_tys env noninj_tys1 noninj_tys2 }++  | Just (tc1, _) <- mb_tc_app1+  , not (isGenerativeTyCon tc1 Nominal)+    -- E.g.   unify_ty (F ty1) b  =  MaybeApart+    --        because the (F ty1) behaves like a variable+    --        NB: if unifying, we have already dealt+    --            with the 'ty2 = variable' case+  = maybeApart++  | Just (tc2, _) <- mb_tc_app2+  , not (isGenerativeTyCon tc2 Nominal)+  , um_unif env+    -- E.g.   unify_ty [a] (F ty2) =  MaybeApart, when unifying (only)+    --        because the (F ty2) behaves like a variable+    --        NB: we have already dealt with the 'ty1 = variable' case+  = maybeApart++  where+    mb_tc_app1 = tcSplitTyConApp_maybe ty1+    mb_tc_app2 = tcSplitTyConApp_maybe ty2++        -- Applications need a bit of care!+        -- They can match FunTy and TyConApp, so use splitAppTy_maybe+        -- NB: we've already dealt with type variables,+        -- so if one type is an App the other one jolly well better be too+unify_ty env (AppTy ty1a ty1b) ty2 _kco+  | Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2+  = unify_ty_app env ty1a [ty1b] ty2a [ty2b]++unify_ty env ty1 (AppTy ty2a ty2b) _kco+  | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1+  = unify_ty_app env ty1a [ty1b] ty2a [ty2b]++unify_ty _ (LitTy x) (LitTy y) _kco | x == y = return ()++unify_ty env (ForAllTy (TvBndr tv1 _) ty1) (ForAllTy (TvBndr tv2 _) ty2) kco+  = do { unify_ty env (tyVarKind tv1) (tyVarKind tv2) (mkNomReflCo liftedTypeKind)+       ; let env' = umRnBndr2 env tv1 tv2+       ; unify_ty env' ty1 ty2 kco }++-- See Note [Matching coercion variables]+unify_ty env (CoercionTy co1) (CoercionTy co2) kco+  = do { c_subst <- getCvSubstEnv+       ; case co1 of+           CoVarCo cv+             | not (um_unif env)+             , not (cv `elemVarEnv` c_subst)+             , BindMe <- tvBindFlagL env cv+             -> do { checkRnEnvRCo env co2+                   ; let (co_l, co_r) = decomposeFunCo kco+                      -- cv :: t1 ~ t2+                      -- co2 :: s1 ~ s2+                      -- co_l :: t1 ~ s1+                      -- co_r :: t2 ~ s2+                   ; extendCvEnv cv (co_l `mkTransCo`+                                     co2 `mkTransCo`+                                     mkSymCo co_r) }+           _ -> return () }++unify_ty _ _ _ _ = surelyApart++unify_ty_app :: UMEnv -> Type -> [Type] -> Type -> [Type] -> UM ()+unify_ty_app env ty1 ty1args ty2 ty2args+  | Just (ty1', ty1a) <- repSplitAppTy_maybe ty1+  , Just (ty2', ty2a) <- repSplitAppTy_maybe ty2+  = unify_ty_app env ty1' (ty1a : ty1args) ty2' (ty2a : ty2args)++  | otherwise+  = do { let ki1 = typeKind ty1+             ki2 = typeKind ty2+           -- See Note [Kind coercions in Unify]+       ; unify_ty  env ki1 ki2 (mkNomReflCo liftedTypeKind)+       ; unify_ty  env ty1 ty2 (mkNomReflCo ki1)+       ; unify_tys env ty1args ty2args }++unify_tys :: UMEnv -> [Type] -> [Type] -> UM ()+unify_tys env orig_xs orig_ys+  = go orig_xs orig_ys+  where+    go []     []     = return ()+    go (x:xs) (y:ys)+      -- See Note [Kind coercions in Unify]+      = do { unify_ty env x y (mkNomReflCo $ typeKind x)+           ; go xs ys }+    go _ _ = maybeApart  -- See Note [Lists of different lengths are MaybeApart]++---------------------------------+uVar :: UMEnv+     -> TyVar           -- Variable to be unified+     -> Type            -- with this Type+     -> Coercion        -- :: kind tv ~N kind ty+     -> UM ()++uVar env tv1 ty kco+ = do { -- Check to see whether tv1 is refined by the substitution+        subst <- getTvSubstEnv+      ; case (lookupVarEnv subst tv1) of+          Just ty' | um_unif env                 -- Unifying, so+                   -> unify_ty env ty' ty kco   -- call back into unify+                   | otherwise+                   -> -- Matching, we don't want to just recur here.+                      -- this is because the range of the subst is the target+                      -- type, not the template type. So, just check for+                      -- normal type equality.+                      guard ((ty' `mkCastTy` kco) `eqType` ty)+          Nothing  -> uUnrefined env tv1 ty ty kco } -- No, continue++uUnrefined :: UMEnv+           -> TyVar             -- variable to be unified+           -> Type              -- with this Type+           -> Type              -- (version w/ expanded synonyms)+           -> Coercion          -- :: kind tv ~N kind ty+           -> UM ()++-- We know that tv1 isn't refined++uUnrefined env tv1 ty2 ty2' kco+  | Just ty2'' <- coreView ty2'+  = uUnrefined env tv1 ty2 ty2'' kco    -- Unwrap synonyms+                -- This is essential, in case we have+                --      type Foo a = a+                -- and then unify a ~ Foo a++  | TyVarTy tv2 <- ty2'+  = do { let tv1' = umRnOccL env tv1+             tv2' = umRnOccR env tv2+           -- See Note [Self-substitution when matching]+       ; when (tv1' /= tv2' || not (um_unif env)) $ do+       { subst <- getTvSubstEnv+          -- Check to see whether tv2 is refined+       ; case lookupVarEnv subst tv2 of+         {  Just ty' | um_unif env -> uUnrefined env tv1 ty' ty' kco+         ;  _                      -> do+       {   -- So both are unrefined++           -- And then bind one or the other,+           -- depending on which is bindable+       ; let b1  = tvBindFlagL env tv1+             b2  = tvBindFlagR env tv2+             ty1 = mkTyVarTy tv1+       ; case (b1, b2) of+           (BindMe, _) -> do { checkRnEnvR env ty2 -- make sure ty2 is not a local+                             ; extendTvEnv tv1 (ty2 `mkCastTy` mkSymCo kco) }+           (_, BindMe) | um_unif env+                       -> do { checkRnEnvL env ty1 -- ditto for ty1+                             ; extendTvEnv tv2 (ty1 `mkCastTy` kco) }++           _ | tv1' == tv2' -> return ()+             -- How could this happen? If we're only matching and if+             -- we're comparing forall-bound variables.++           _ -> maybeApart -- See Note [Unification with skolems]+  }}}}++uUnrefined env tv1 ty2 ty2' kco -- ty2 is not a type variable+  = do { occurs <- elemNiSubstSet tv1 (tyCoVarsOfType ty2')+       ; if um_unif env && occurs  -- See Note [Self-substitution when matching]+         then maybeApart       -- Occurs check, see Note [Fine-grained unification]+         else do bindTv env tv1 (ty2 `mkCastTy` mkSymCo kco) }+            -- Bind tyvar to the synonym if poss++elemNiSubstSet :: TyVar -> TyCoVarSet -> UM Bool+elemNiSubstSet v set+  = do { tsubst <- getTvSubstEnv+       ; return $ v `elemVarSet` niSubstTvSet tsubst set }++bindTv :: UMEnv -> TyVar -> Type -> UM ()+bindTv env tv ty    -- ty is not a variable+  = do  { checkRnEnvR env ty -- make sure ty mentions no local variables+        ; case tvBindFlagL env tv of+            Skolem -> maybeApart  -- See Note [Unification with skolems]+            BindMe -> extendTvEnv tv ty+        }++{-+%************************************************************************+%*                                                                      *+                Binding decisions+*                                                                      *+************************************************************************+-}++data BindFlag+  = BindMe      -- A regular type variable++  | Skolem      -- This type variable is a skolem constant+                -- Don't bind it; it only matches itself+  deriving Eq++{-+************************************************************************+*                                                                      *+                Unification monad+*                                                                      *+************************************************************************+-}++data UMEnv = UMEnv { um_bind_fun :: TyVar -> BindFlag+                                       -- User-supplied BindFlag function+                   , um_unif     :: AmIUnifying+                   , um_inj_tf   :: Bool         -- Checking for injectivity?+                          -- See (end of) Note [Specification of unification]+                   , um_rn_env   :: RnEnv2 }++data UMState = UMState+                   { um_tv_env   :: TvSubstEnv+                   , um_cv_env   :: CvSubstEnv }++newtype UM a = UM { unUM :: UMState -> UnifyResultM (UMState, a) }++instance Functor UM where+      fmap = liftM++instance Applicative UM where+      pure a = UM (\s -> pure (s, a))+      (<*>)  = ap++instance Monad UM where+  fail _   = UM (\_ -> SurelyApart) -- failed pattern match+  m >>= k  = UM (\state ->+                  do { (state', v) <- unUM m state+                     ; unUM (k v) state' })++-- need this instance because of a use of 'guard' above+instance Alternative UM where+  empty     = UM (\_ -> Control.Applicative.empty)+  m1 <|> m2 = UM (\state ->+                  unUM m1 state <|>+                  unUM m2 state)++instance MonadPlus UM++#if __GLASGOW_HASKELL__ > 710+instance MonadFail.MonadFail UM where+    fail _   = UM (\_ -> SurelyApart) -- failed pattern match+#endif++initUM :: TvSubstEnv  -- subst to extend+       -> CvSubstEnv+       -> UM a -> UnifyResultM a+initUM subst_env cv_subst_env um+  = case unUM um state of+      Unifiable (_, subst)  -> Unifiable subst+      MaybeApart (_, subst) -> MaybeApart subst+      SurelyApart           -> SurelyApart+  where+    state = UMState { um_tv_env = subst_env+                    , um_cv_env = cv_subst_env }++tvBindFlagL :: UMEnv -> TyVar -> BindFlag+tvBindFlagL env tv+  | inRnEnvL (um_rn_env env) tv = Skolem+  | otherwise                   = um_bind_fun env tv++tvBindFlagR :: UMEnv -> TyVar -> BindFlag+tvBindFlagR env tv+  | inRnEnvR (um_rn_env env) tv = Skolem+  | otherwise                   = um_bind_fun env tv++getTvSubstEnv :: UM TvSubstEnv+getTvSubstEnv = UM $ \state -> Unifiable (state, um_tv_env state)++getCvSubstEnv :: UM CvSubstEnv+getCvSubstEnv = UM $ \state -> Unifiable (state, um_cv_env state)++extendTvEnv :: TyVar -> Type -> UM ()+extendTvEnv tv ty = UM $ \state ->+  Unifiable (state { um_tv_env = extendVarEnv (um_tv_env state) tv ty }, ())++extendCvEnv :: CoVar -> Coercion -> UM ()+extendCvEnv cv co = UM $ \state ->+  Unifiable (state { um_cv_env = extendVarEnv (um_cv_env state) cv co }, ())++umRnBndr2 :: UMEnv -> TyCoVar -> TyCoVar -> UMEnv+umRnBndr2 env v1 v2+  = env { um_rn_env = rnBndr2 (um_rn_env env) v1 v2 }++checkRnEnv :: (RnEnv2 -> VarEnv Var) -> UMEnv -> VarSet -> UM ()+checkRnEnv get_set env varset = UM $ \ state ->+  let env_vars = get_set (um_rn_env env) in+  if isEmptyVarEnv env_vars || (getUniqSet varset `disjointVarEnv` env_vars)+     -- NB: That isEmptyVarSet is a critical optimization; it+     -- means we don't have to calculate the free vars of+     -- the type, often saving quite a bit of allocation.+  then Unifiable  (state, ())+  else MaybeApart (state, ())++-- | Converts any SurelyApart to a MaybeApart+don'tBeSoSure :: UM () -> UM ()+don'tBeSoSure um = UM $ \ state ->+  case unUM um state of+    SurelyApart -> MaybeApart (state, ())+    other       -> other++checkRnEnvR :: UMEnv -> Type -> UM ()+checkRnEnvR env ty = checkRnEnv rnEnvR env (tyCoVarsOfType ty)++checkRnEnvL :: UMEnv -> Type -> UM ()+checkRnEnvL env ty = checkRnEnv rnEnvL env (tyCoVarsOfType ty)++checkRnEnvRCo :: UMEnv -> Coercion -> UM ()+checkRnEnvRCo env co = checkRnEnv rnEnvR env (tyCoVarsOfCo co)++umRnOccL :: UMEnv -> TyVar -> TyVar+umRnOccL env v = rnOccL (um_rn_env env) v++umRnOccR :: UMEnv -> TyVar -> TyVar+umRnOccR env v = rnOccR (um_rn_env env) v++umSwapRn :: UMEnv -> UMEnv+umSwapRn env = env { um_rn_env = rnSwap (um_rn_env env) }++maybeApart :: UM ()+maybeApart = UM (\state -> MaybeApart (state, ()))++surelyApart :: UM a+surelyApart = UM (\_ -> SurelyApart)++{-+%************************************************************************+%*                                                                      *+            Matching a (lifted) type against a coercion+%*                                                                      *+%************************************************************************++This section defines essentially an inverse to liftCoSubst. It is defined+here to avoid a dependency from Coercion on this module.++-}++data MatchEnv = ME { me_tmpls :: TyVarSet+                   , me_env   :: RnEnv2 }++-- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'.  In particular, if+--   @liftCoMatch vars ty co == Just s@, then @listCoSubst s ty == co@,+--   where @==@ there means that the result of 'liftCoSubst' has the same+--   type as the original co; but may be different under the hood.+--   That is, it matches a type against a coercion of the same+--   "shape", and returns a lifting substitution which could have been+--   used to produce the given coercion from the given type.+--   Note that this function is incomplete -- it might return Nothing+--   when there does indeed exist a possible lifting context.+--+-- This function is incomplete in that it doesn't respect the equality+-- in `eqType`. That is, it's possible that this will succeed for t1 and+-- fail for t2, even when t1 `eqType` t2. That's because it depends on+-- there being a very similar structure between the type and the coercion.+-- This incompleteness shouldn't be all that surprising, especially because+-- it depends on the structure of the coercion, which is a silly thing to do.+--+-- The lifting context produced doesn't have to be exacting in the roles+-- of the mappings. This is because any use of the lifting context will+-- also require a desired role. Thus, this algorithm prefers mapping to+-- nominal coercions where it can do so.+liftCoMatch :: TyCoVarSet -> Type -> Coercion -> Maybe LiftingContext+liftCoMatch tmpls ty co+  = do { cenv1 <- ty_co_match menv emptyVarEnv ki ki_co ki_ki_co ki_ki_co+       ; cenv2 <- ty_co_match menv cenv1       ty co+                              (mkNomReflCo co_lkind) (mkNomReflCo co_rkind)+       ; return (LC (mkEmptyTCvSubst in_scope) cenv2) }+  where+    menv     = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope }+    in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co)+    -- Like tcMatchTy, assume all the interesting variables+    -- in ty are in tmpls++    ki       = typeKind ty+    ki_co    = promoteCoercion co+    ki_ki_co = mkNomReflCo liftedTypeKind++    Pair co_lkind co_rkind = coercionKind ki_co++-- | 'ty_co_match' does all the actual work for 'liftCoMatch'.+ty_co_match :: MatchEnv   -- ^ ambient helpful info+            -> LiftCoEnv  -- ^ incoming subst+            -> Type       -- ^ ty, type to match+            -> Coercion   -- ^ co, coercion to match against+            -> Coercion   -- ^ :: kind of L type of substed ty ~N L kind of co+            -> Coercion   -- ^ :: kind of R type of substed ty ~N R kind of co+            -> Maybe LiftCoEnv+ty_co_match menv subst ty co lkco rkco+  | Just ty' <- coreView ty = ty_co_match menv subst ty' co lkco rkco++  -- handle Refl case:+  | tyCoVarsOfType ty `isNotInDomainOf` subst+  , Just (ty', _) <- isReflCo_maybe co+  , ty `eqType` ty'+  = Just subst++  where+    isNotInDomainOf :: VarSet -> VarEnv a -> Bool+    isNotInDomainOf set env+      = noneSet (\v -> elemVarEnv v env) set++    noneSet :: (Var -> Bool) -> VarSet -> Bool+    noneSet f = allVarSet (not . f)++ty_co_match menv subst ty co lkco rkco+  | CastTy ty' co' <- ty+  = ty_co_match menv subst ty' co (co' `mkTransCo` lkco) (co' `mkTransCo` rkco)++  | CoherenceCo co1 co2 <- co+  = ty_co_match menv subst ty co1 (lkco `mkTransCo` mkSymCo co2) rkco++  | SymCo co' <- co+  = swapLiftCoEnv <$> ty_co_match menv (swapLiftCoEnv subst) ty co' rkco lkco++  -- Match a type variable against a non-refl coercion+ty_co_match menv subst (TyVarTy tv1) co lkco rkco+  | Just co1' <- lookupVarEnv subst tv1' -- tv1' is already bound to co1+  = if eqCoercionX (nukeRnEnvL rn_env) co1' co+    then Just subst+    else Nothing       -- no match since tv1 matches two different coercions++  | tv1' `elemVarSet` me_tmpls menv           -- tv1' is a template var+  = if any (inRnEnvR rn_env) (tyCoVarsOfCoList co)+    then Nothing      -- occurs check failed+    else Just $ extendVarEnv subst tv1' $+                castCoercionKind co (mkSymCo lkco) (mkSymCo rkco)++  | otherwise+  = Nothing++  where+    rn_env = me_env menv+    tv1' = rnOccL rn_env tv1++  -- just look through SubCo's. We don't really care about roles here.+ty_co_match menv subst ty (SubCo co) lkco rkco+  = ty_co_match menv subst ty co lkco rkco++ty_co_match menv subst (AppTy ty1a ty1b) co _lkco _rkco+  | Just (co2, arg2) <- splitAppCo_maybe co     -- c.f. Unify.match on AppTy+  = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2]+ty_co_match menv subst ty1 (AppCo co2 arg2) _lkco _rkco+  | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1+       -- yes, the one from Type, not TcType; this is for coercion optimization+  = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2]++ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo _ tc2 cos) _lkco _rkco+  = ty_co_match_tc menv subst tc1 tys tc2 cos+ty_co_match menv subst (FunTy ty1 ty2) co _lkco _rkco+    -- Despite the fact that (->) is polymorphic in four type variables (two+    -- runtime rep and two types), we shouldn't need to explicitly unify the+    -- runtime reps here; unifying the types themselves should be sufficient.+    -- See Note [Representation of function types].+  | Just (tc, [_,_,co1,co2]) <- splitTyConAppCo_maybe co+  , tc == funTyCon+  = let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) [co1,co2]+    in ty_co_match_args menv subst [ty1, ty2] [co1, co2] lkcos rkcos++ty_co_match menv subst (ForAllTy (TvBndr tv1 _) ty1)+                       (ForAllCo tv2 kind_co2 co2)+                       lkco rkco+  = do { subst1 <- ty_co_match menv subst (tyVarKind tv1) kind_co2+                               ki_ki_co ki_ki_co+       ; let rn_env0 = me_env menv+             rn_env1 = rnBndr2 rn_env0 tv1 tv2+             menv'   = menv { me_env = rn_env1 }+       ; ty_co_match menv' subst1 ty1 co2 lkco rkco }+  where+    ki_ki_co = mkNomReflCo liftedTypeKind++ty_co_match _ subst (CoercionTy {}) _ _ _+  = Just subst -- don't inspect coercions++ty_co_match menv subst ty co lkco rkco+  | Just co' <- pushRefl co = ty_co_match menv subst ty co' lkco rkco+  | otherwise               = Nothing++ty_co_match_tc :: MatchEnv -> LiftCoEnv+               -> TyCon -> [Type]+               -> TyCon -> [Coercion]+               -> Maybe LiftCoEnv+ty_co_match_tc menv subst tc1 tys1 tc2 cos2+  = do { guard (tc1 == tc2)+       ; ty_co_match_args menv subst tys1 cos2 lkcos rkcos }+  where+    Pair lkcos rkcos+      = traverse (fmap mkNomReflCo . coercionKind) cos2++ty_co_match_app :: MatchEnv -> LiftCoEnv+                -> Type -> [Type] -> Coercion -> [Coercion]+                -> Maybe LiftCoEnv+ty_co_match_app menv subst ty1 ty1args co2 co2args+  | Just (ty1', ty1a) <- repSplitAppTy_maybe ty1+  , Just (co2', co2a) <- splitAppCo_maybe co2+  = ty_co_match_app menv subst ty1' (ty1a : ty1args) co2' (co2a : co2args)++  | otherwise+  = do { subst1 <- ty_co_match menv subst ki1 ki2 ki_ki_co ki_ki_co+       ; let Pair lkco rkco = mkNomReflCo <$> coercionKind ki2+       ; subst2 <- ty_co_match menv subst1 ty1 co2 lkco rkco+       ; let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) co2args+       ; ty_co_match_args menv subst2 ty1args co2args lkcos rkcos }+  where+    ki1 = typeKind ty1+    ki2 = promoteCoercion co2+    ki_ki_co = mkNomReflCo liftedTypeKind++ty_co_match_args :: MatchEnv -> LiftCoEnv -> [Type]+                 -> [Coercion] -> [Coercion] -> [Coercion]+                 -> Maybe LiftCoEnv+ty_co_match_args _    subst []       []         _ _ = Just subst+ty_co_match_args menv subst (ty:tys) (arg:args) (lkco:lkcos) (rkco:rkcos)+  = do { subst' <- ty_co_match menv subst ty arg lkco rkco+       ; ty_co_match_args menv subst' tys args lkcos rkcos }+ty_co_match_args _    _     _        _          _ _ = Nothing++pushRefl :: Coercion -> Maybe Coercion+pushRefl (Refl Nominal (AppTy ty1 ty2))+  = Just (AppCo (Refl Nominal ty1) (mkNomReflCo ty2))+pushRefl (Refl r (FunTy ty1 ty2))+  | Just rep1 <- getRuntimeRep_maybe ty1+  , Just rep2 <- getRuntimeRep_maybe ty2+  = Just (TyConAppCo r funTyCon [ mkReflCo r rep1, mkReflCo r rep2+                                , mkReflCo r ty1,  mkReflCo r ty2 ])+pushRefl (Refl r (TyConApp tc tys))+  = Just (TyConAppCo r tc (zipWith mkReflCo (tyConRolesX r tc) tys))+pushRefl (Refl r (ForAllTy (TvBndr tv _) ty))+  = Just (mkHomoForAllCos_NoRefl [tv] (Refl r ty))+    -- NB: NoRefl variant. Otherwise, we get a loop!+pushRefl (Refl r (CastTy ty co))  = Just (castCoercionKind (Refl r ty) co co)+pushRefl _                        = Nothing
+ utils/Bag.hs view
@@ -0,0 +1,332 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Bag: an unordered collection with duplicates+-}++{-# LANGUAGE ScopedTypeVariables, CPP #-}++module Bag (+        Bag, -- abstract type++        emptyBag, unitBag, unionBags, unionManyBags,+        mapBag,+        elemBag, lengthBag,+        filterBag, partitionBag, partitionBagWith,+        concatBag, catBagMaybes, foldBag, foldrBag, foldlBag,+        isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, allBag,+        listToBag, bagToList, mapAccumBagL,+        concatMapBag, mapMaybeBag,+        foldrBagM, foldlBagM, mapBagM, mapBagM_,+        flatMapBagM, flatMapBagPairM,+        mapAndUnzipBagM, mapAccumBagLM,+        anyBagM, filterBagM+    ) where++import Outputable+import Util++import MonadUtils+import Control.Monad+import Data.Data+import Data.Maybe( mapMaybe )+import Data.List ( partition, mapAccumL )+import qualified Data.Foldable as Foldable++infixr 3 `consBag`+infixl 3 `snocBag`++data Bag a+  = EmptyBag+  | UnitBag a+  | TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty+  | ListBag [a]             -- INVARIANT: the list is non-empty++emptyBag :: Bag a+emptyBag = EmptyBag++unitBag :: a -> Bag a+unitBag  = UnitBag++lengthBag :: Bag a -> Int+lengthBag EmptyBag        = 0+lengthBag (UnitBag {})    = 1+lengthBag (TwoBags b1 b2) = lengthBag b1 + lengthBag b2+lengthBag (ListBag xs)    = length xs++elemBag :: Eq a => a -> Bag a -> Bool+elemBag _ EmptyBag        = False+elemBag x (UnitBag y)     = x == y+elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2+elemBag x (ListBag ys)    = any (x ==) ys++unionManyBags :: [Bag a] -> Bag a+unionManyBags xs = foldr unionBags EmptyBag xs++-- This one is a bit stricter! The bag will get completely evaluated.++unionBags :: Bag a -> Bag a -> Bag a+unionBags EmptyBag b = b+unionBags b EmptyBag = b+unionBags b1 b2      = TwoBags b1 b2++consBag :: a -> Bag a -> Bag a+snocBag :: Bag a -> a -> Bag a++consBag elt bag = (unitBag elt) `unionBags` bag+snocBag bag elt = bag `unionBags` (unitBag elt)++isEmptyBag :: Bag a -> Bool+isEmptyBag EmptyBag = True+isEmptyBag _        = False -- NB invariants++isSingletonBag :: Bag a -> Bool+isSingletonBag EmptyBag      = False+isSingletonBag (UnitBag _)   = True+isSingletonBag (TwoBags _ _) = False          -- Neither is empty+isSingletonBag (ListBag xs)  = isSingleton xs++filterBag :: (a -> Bool) -> Bag a -> Bag a+filterBag _    EmptyBag = EmptyBag+filterBag pred b@(UnitBag val) = if pred val then b else EmptyBag+filterBag pred (TwoBags b1 b2) = sat1 `unionBags` sat2+    where sat1 = filterBag pred b1+          sat2 = filterBag pred b2+filterBag pred (ListBag vs)    = listToBag (filter pred vs)++filterBagM :: Monad m => (a -> m Bool) -> Bag a -> m (Bag a)+filterBagM _    EmptyBag = return EmptyBag+filterBagM pred b@(UnitBag val) = do+  flag <- pred val+  if flag then return b+          else return EmptyBag+filterBagM pred (TwoBags b1 b2) = do+  sat1 <- filterBagM pred b1+  sat2 <- filterBagM pred b2+  return (sat1 `unionBags` sat2)+filterBagM pred (ListBag vs) = do+  sat <- filterM pred vs+  return (listToBag sat)++allBag :: (a -> Bool) -> Bag a -> Bool+allBag _ EmptyBag        = True+allBag p (UnitBag v)     = p v+allBag p (TwoBags b1 b2) = allBag p b1 && allBag p b2+allBag p (ListBag xs)    = all p xs++anyBag :: (a -> Bool) -> Bag a -> Bool+anyBag _ EmptyBag        = False+anyBag p (UnitBag v)     = p v+anyBag p (TwoBags b1 b2) = anyBag p b1 || anyBag p b2+anyBag p (ListBag xs)    = any p xs++anyBagM :: Monad m => (a -> m Bool) -> Bag a -> m Bool+anyBagM _ EmptyBag        = return False+anyBagM p (UnitBag v)     = p v+anyBagM p (TwoBags b1 b2) = do flag <- anyBagM p b1+                               if flag then return True+                                       else anyBagM p b2+anyBagM p (ListBag xs)    = anyM p xs++concatBag :: Bag (Bag a) -> Bag a+concatBag bss = foldrBag add emptyBag bss+  where+    add bs rs = bs `unionBags` rs++catBagMaybes :: Bag (Maybe a) -> Bag a+catBagMaybes bs = foldrBag add emptyBag bs+  where+    add Nothing rs = rs+    add (Just x) rs = x `consBag` rs++partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -},+                                         Bag a {- Don't -})+partitionBag _    EmptyBag = (EmptyBag, EmptyBag)+partitionBag pred b@(UnitBag val)+    = if pred val then (b, EmptyBag) else (EmptyBag, b)+partitionBag pred (TwoBags b1 b2)+    = (sat1 `unionBags` sat2, fail1 `unionBags` fail2)+  where (sat1, fail1) = partitionBag pred b1+        (sat2, fail2) = partitionBag pred b2+partitionBag pred (ListBag vs) = (listToBag sats, listToBag fails)+  where (sats, fails) = partition pred vs+++partitionBagWith :: (a -> Either b c) -> Bag a+                    -> (Bag b {- Left  -},+                        Bag c {- Right -})+partitionBagWith _    EmptyBag = (EmptyBag, EmptyBag)+partitionBagWith pred (UnitBag val)+    = case pred val of+         Left a  -> (UnitBag a, EmptyBag)+         Right b -> (EmptyBag, UnitBag b)+partitionBagWith pred (TwoBags b1 b2)+    = (sat1 `unionBags` sat2, fail1 `unionBags` fail2)+  where (sat1, fail1) = partitionBagWith pred b1+        (sat2, fail2) = partitionBagWith pred b2+partitionBagWith pred (ListBag vs) = (listToBag sats, listToBag fails)+  where (sats, fails) = partitionWith pred vs++foldBag :: (r -> r -> r) -- Replace TwoBags with this; should be associative+        -> (a -> r)      -- Replace UnitBag with this+        -> r             -- Replace EmptyBag with this+        -> Bag a+        -> r++{- Standard definition+foldBag t u e EmptyBag        = e+foldBag t u e (UnitBag x)     = u x+foldBag t u e (TwoBags b1 b2) = (foldBag t u e b1) `t` (foldBag t u e b2)+foldBag t u e (ListBag xs)    = foldr (t.u) e xs+-}++-- More tail-recursive definition, exploiting associativity of "t"+foldBag _ _ e EmptyBag        = e+foldBag t u e (UnitBag x)     = u x `t` e+foldBag t u e (TwoBags b1 b2) = foldBag t u (foldBag t u e b2) b1+foldBag t u e (ListBag xs)    = foldr (t.u) e xs++foldrBag :: (a -> r -> r) -> r+         -> Bag a+         -> r++foldrBag _ z EmptyBag        = z+foldrBag k z (UnitBag x)     = k x z+foldrBag k z (TwoBags b1 b2) = foldrBag k (foldrBag k z b2) b1+foldrBag k z (ListBag xs)    = foldr k z xs++foldlBag :: (r -> a -> r) -> r+         -> Bag a+         -> r++foldlBag _ z EmptyBag        = z+foldlBag k z (UnitBag x)     = k z x+foldlBag k z (TwoBags b1 b2) = foldlBag k (foldlBag k z b1) b2+foldlBag k z (ListBag xs)    = foldl k z xs++foldrBagM :: (Monad m) => (a -> b -> m b) -> b -> Bag a -> m b+foldrBagM _ z EmptyBag        = return z+foldrBagM k z (UnitBag x)     = k x z+foldrBagM k z (TwoBags b1 b2) = do { z' <- foldrBagM k z b2; foldrBagM k z' b1 }+foldrBagM k z (ListBag xs)    = foldrM k z xs++foldlBagM :: (Monad m) => (b -> a -> m b) -> b -> Bag a -> m b+foldlBagM _ z EmptyBag        = return z+foldlBagM k z (UnitBag x)     = k z x+foldlBagM k z (TwoBags b1 b2) = do { z' <- foldlBagM k z b1; foldlBagM k z' b2 }+foldlBagM k z (ListBag xs)    = foldlM k z xs++mapBag :: (a -> b) -> Bag a -> Bag b+mapBag _ EmptyBag        = EmptyBag+mapBag f (UnitBag x)     = UnitBag (f x)+mapBag f (TwoBags b1 b2) = TwoBags (mapBag f b1) (mapBag f b2)+mapBag f (ListBag xs)    = ListBag (map f xs)++concatMapBag :: (a -> Bag b) -> Bag a -> Bag b+concatMapBag _ EmptyBag        = EmptyBag+concatMapBag f (UnitBag x)     = f x+concatMapBag f (TwoBags b1 b2) = unionBags (concatMapBag f b1) (concatMapBag f b2)+concatMapBag f (ListBag xs)    = foldr (unionBags . f) emptyBag xs++mapMaybeBag :: (a -> Maybe b) -> Bag a -> Bag b+mapMaybeBag _ EmptyBag        = EmptyBag+mapMaybeBag f (UnitBag x)     = case f x of+                                  Nothing -> EmptyBag+                                  Just y  -> UnitBag y+mapMaybeBag f (TwoBags b1 b2) = unionBags (mapMaybeBag f b1) (mapMaybeBag f b2)+mapMaybeBag f (ListBag xs)    = ListBag (mapMaybe f xs)++mapBagM :: Monad m => (a -> m b) -> Bag a -> m (Bag b)+mapBagM _ EmptyBag        = return EmptyBag+mapBagM f (UnitBag x)     = do r <- f x+                               return (UnitBag r)+mapBagM f (TwoBags b1 b2) = do r1 <- mapBagM f b1+                               r2 <- mapBagM f b2+                               return (TwoBags r1 r2)+mapBagM f (ListBag    xs) = do rs <- mapM f xs+                               return (ListBag rs)++mapBagM_ :: Monad m => (a -> m b) -> Bag a -> m ()+mapBagM_ _ EmptyBag        = return ()+mapBagM_ f (UnitBag x)     = f x >> return ()+mapBagM_ f (TwoBags b1 b2) = mapBagM_ f b1 >> mapBagM_ f b2+mapBagM_ f (ListBag    xs) = mapM_ f xs++flatMapBagM :: Monad m => (a -> m (Bag b)) -> Bag a -> m (Bag b)+flatMapBagM _ EmptyBag        = return EmptyBag+flatMapBagM f (UnitBag x)     = f x+flatMapBagM f (TwoBags b1 b2) = do r1 <- flatMapBagM f b1+                                   r2 <- flatMapBagM f b2+                                   return (r1 `unionBags` r2)+flatMapBagM f (ListBag    xs) = foldrM k EmptyBag xs+  where+    k x b2 = do { b1 <- f x; return (b1 `unionBags` b2) }++flatMapBagPairM :: Monad m => (a -> m (Bag b, Bag c)) -> Bag a -> m (Bag b, Bag c)+flatMapBagPairM _ EmptyBag        = return (EmptyBag, EmptyBag)+flatMapBagPairM f (UnitBag x)     = f x+flatMapBagPairM f (TwoBags b1 b2) = do (r1,s1) <- flatMapBagPairM f b1+                                       (r2,s2) <- flatMapBagPairM f b2+                                       return (r1 `unionBags` r2, s1 `unionBags` s2)+flatMapBagPairM f (ListBag    xs) = foldrM k (EmptyBag, EmptyBag) xs+  where+    k x (r2,s2) = do { (r1,s1) <- f x+                     ; return (r1 `unionBags` r2, s1 `unionBags` s2) }++mapAndUnzipBagM :: Monad m => (a -> m (b,c)) -> Bag a -> m (Bag b, Bag c)+mapAndUnzipBagM _ EmptyBag        = return (EmptyBag, EmptyBag)+mapAndUnzipBagM f (UnitBag x)     = do (r,s) <- f x+                                       return (UnitBag r, UnitBag s)+mapAndUnzipBagM f (TwoBags b1 b2) = do (r1,s1) <- mapAndUnzipBagM f b1+                                       (r2,s2) <- mapAndUnzipBagM f b2+                                       return (TwoBags r1 r2, TwoBags s1 s2)+mapAndUnzipBagM f (ListBag xs)    = do ts <- mapM f xs+                                       let (rs,ss) = unzip ts+                                       return (ListBag rs, ListBag ss)++mapAccumBagL ::(acc -> x -> (acc, y)) -- ^ combining funcction+            -> acc                    -- ^ initial state+            -> Bag x                  -- ^ inputs+            -> (acc, Bag y)           -- ^ final state, outputs+mapAccumBagL _ s EmptyBag        = (s, EmptyBag)+mapAccumBagL f s (UnitBag x)     = let (s1, x1) = f s x in (s1, UnitBag x1)+mapAccumBagL f s (TwoBags b1 b2) = let (s1, b1') = mapAccumBagL f s  b1+                                       (s2, b2') = mapAccumBagL f s1 b2+                                   in (s2, TwoBags b1' b2')+mapAccumBagL f s (ListBag xs)    = let (s', xs') = mapAccumL f s xs+                                   in (s', ListBag xs')++mapAccumBagLM :: Monad m+            => (acc -> x -> m (acc, y)) -- ^ combining funcction+            -> acc                      -- ^ initial state+            -> Bag x                    -- ^ inputs+            -> m (acc, Bag y)           -- ^ final state, outputs+mapAccumBagLM _ s EmptyBag        = return (s, EmptyBag)+mapAccumBagLM f s (UnitBag x)     = do { (s1, x1) <- f s x; return (s1, UnitBag x1) }+mapAccumBagLM f s (TwoBags b1 b2) = do { (s1, b1') <- mapAccumBagLM f s  b1+                                       ; (s2, b2') <- mapAccumBagLM f s1 b2+                                       ; return (s2, TwoBags b1' b2') }+mapAccumBagLM f s (ListBag xs)    = do { (s', xs') <- mapAccumLM f s xs+                                       ; return (s', ListBag xs') }++listToBag :: [a] -> Bag a+listToBag [] = EmptyBag+listToBag vs = ListBag vs++bagToList :: Bag a -> [a]+bagToList b = foldrBag (:) [] b++instance (Outputable a) => Outputable (Bag a) where+    ppr bag = braces (pprWithCommas ppr (bagToList bag))++instance Data a => Data (Bag a) where+  gfoldl k z b = z listToBag `k` bagToList b -- traverse abstract type abstractly+  toConstr _   = abstractConstr $ "Bag("++show (typeOf (undefined::a))++")"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "Bag"+  dataCast1 x  = gcast1 x++instance Foldable.Foldable Bag where+    foldr = foldrBag
+ utils/Binary.hs view
@@ -0,0 +1,1194 @@+{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}++{-# OPTIONS_GHC -O -funbox-strict-fields #-}+-- We always optimise this, otherwise performance of a non-optimised+-- compiler is severely affected++--+-- (c) The University of Glasgow 2002-2006+--+-- Binary I/O library, with special tweaks for GHC+--+-- Based on the nhc98 Binary library, which is copyright+-- (c) Malcolm Wallace and Colin Runciman, University of York, 1998.+-- Under the terms of the license for that software, we must tell you+-- where you can obtain the original version of the Binary library, namely+--     http://www.cs.york.ac.uk/fp/nhc98/++module Binary+  ( {-type-}  Bin,+    {-class-} Binary(..),+    {-type-}  BinHandle,+    SymbolTable, Dictionary,++   openBinMem,+--   closeBin,++   seekBin,+   seekBy,+   tellBin,+   castBin,+   isEOFBin,+   withBinBuffer,++   writeBinMem,+   readBinMem,++   putAt, getAt,++   -- * For writing instances+   putByte,+   getByte,++   -- * Lazy Binary I/O+   lazyGet,+   lazyPut,++   -- * User data+   UserData(..), getUserData, setUserData,+   newReadState, newWriteState,+   putDictionary, getDictionary, putFS,+  ) where++#include "HsVersions.h"++-- The *host* architecture version:+#include "MachDeps.h"++import {-# SOURCE #-} Name (Name)+import FastString+import Panic+import UniqFM+import FastMutInt+import Fingerprint+import BasicTypes+import SrcLoc++import Foreign+import Data.Array+import Data.ByteString (ByteString)+import qualified Data.ByteString.Internal as BS+import qualified Data.ByteString.Unsafe   as BS+import Data.IORef+import Data.Char                ( ord, chr )+import Data.Time+#if MIN_VERSION_base(4,10,0)+import Type.Reflection+import Type.Reflection.Unsafe+import Data.Kind (Type)+import GHC.Exts (RuntimeRep(..), VecCount(..), VecElem(..))+#else+import Data.Typeable+#endif+import Control.Monad            ( when )+import System.IO as IO+import System.IO.Unsafe         ( unsafeInterleaveIO )+import System.IO.Error          ( mkIOError, eofErrorType )+import GHC.Real                 ( Ratio(..) )+import GHC.Serialized++type BinArray = ForeignPtr Word8++---------------------------------------------------------------+-- BinHandle+---------------------------------------------------------------++data BinHandle+  = BinMem {                     -- binary data stored in an unboxed array+     bh_usr :: UserData,         -- sigh, need parameterized modules :-)+     _off_r :: !FastMutInt,      -- the current offset+     _sz_r  :: !FastMutInt,      -- size of the array (cached)+     _arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))+    }+        -- XXX: should really store a "high water mark" for dumping out+        -- the binary data to a file.++getUserData :: BinHandle -> UserData+getUserData bh = bh_usr bh++setUserData :: BinHandle -> UserData -> BinHandle+setUserData bh us = bh { bh_usr = us }++-- | Get access to the underlying buffer.+--+-- It is quite important that no references to the 'ByteString' leak out of the+-- continuation lest terrible things happen.+withBinBuffer :: BinHandle -> (ByteString -> IO a) -> IO a+withBinBuffer (BinMem _ ix_r _ arr_r) action = do+  arr <- readIORef arr_r+  ix <- readFastMutInt ix_r+  withForeignPtr arr $ \ptr ->+    BS.unsafePackCStringLen (castPtr ptr, ix) >>= action+++---------------------------------------------------------------+-- Bin+---------------------------------------------------------------++newtype Bin a = BinPtr Int+  deriving (Eq, Ord, Show, Bounded)++castBin :: Bin a -> Bin b+castBin (BinPtr i) = BinPtr i++---------------------------------------------------------------+-- class Binary+---------------------------------------------------------------++class Binary a where+    put_   :: BinHandle -> a -> IO ()+    put    :: BinHandle -> a -> IO (Bin a)+    get    :: BinHandle -> IO a++    -- define one of put_, put.  Use of put_ is recommended because it+    -- is more likely that tail-calls can kick in, and we rarely need the+    -- position return value.+    put_ bh a = do _ <- put bh a; return ()+    put bh a  = do p <- tellBin bh; put_ bh a; return p++putAt  :: Binary a => BinHandle -> Bin a -> a -> IO ()+putAt bh p x = do seekBin bh p; put_ bh x; return ()++getAt  :: Binary a => BinHandle -> Bin a -> IO a+getAt bh p = do seekBin bh p; get bh++openBinMem :: Int -> IO BinHandle+openBinMem size+ | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"+ | otherwise = do+   arr <- mallocForeignPtrBytes size+   arr_r <- newIORef arr+   ix_r <- newFastMutInt+   writeFastMutInt ix_r 0+   sz_r <- newFastMutInt+   writeFastMutInt sz_r size+   return (BinMem noUserData ix_r sz_r arr_r)++tellBin :: BinHandle -> IO (Bin a)+tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)++seekBin :: BinHandle -> Bin a -> IO ()+seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do+  sz <- readFastMutInt sz_r+  if (p >= sz)+        then do expandBin h p; writeFastMutInt ix_r p+        else writeFastMutInt ix_r p++seekBy :: BinHandle -> Int -> IO ()+seekBy h@(BinMem _ ix_r sz_r _) off = do+  sz <- readFastMutInt sz_r+  ix <- readFastMutInt ix_r+  let ix' = ix + off+  if (ix' >= sz)+        then do expandBin h ix'; writeFastMutInt ix_r ix'+        else writeFastMutInt ix_r ix'++isEOFBin :: BinHandle -> IO Bool+isEOFBin (BinMem _ ix_r sz_r _) = do+  ix <- readFastMutInt ix_r+  sz <- readFastMutInt sz_r+  return (ix >= sz)++writeBinMem :: BinHandle -> FilePath -> IO ()+writeBinMem (BinMem _ ix_r _ arr_r) fn = do+  h <- openBinaryFile fn WriteMode+  arr <- readIORef arr_r+  ix  <- readFastMutInt ix_r+  withForeignPtr arr $ \p -> hPutBuf h p ix+  hClose h++readBinMem :: FilePath -> IO BinHandle+-- Return a BinHandle with a totally undefined State+readBinMem filename = do+  h <- openBinaryFile filename ReadMode+  filesize' <- hFileSize h+  let filesize = fromIntegral filesize'+  arr <- mallocForeignPtrBytes filesize+  count <- withForeignPtr arr $ \p -> hGetBuf h p filesize+  when (count /= filesize) $+       error ("Binary.readBinMem: only read " ++ show count ++ " bytes")+  hClose h+  arr_r <- newIORef arr+  ix_r <- newFastMutInt+  writeFastMutInt ix_r 0+  sz_r <- newFastMutInt+  writeFastMutInt sz_r filesize+  return (BinMem noUserData ix_r sz_r arr_r)++-- expand the size of the array to include a specified offset+expandBin :: BinHandle -> Int -> IO ()+expandBin (BinMem _ _ sz_r arr_r) off = do+   sz <- readFastMutInt sz_r+   let sz' = head (dropWhile (<= off) (iterate (* 2) sz))+   arr <- readIORef arr_r+   arr' <- mallocForeignPtrBytes sz'+   withForeignPtr arr $ \old ->+     withForeignPtr arr' $ \new ->+       copyBytes new old sz+   writeFastMutInt sz_r sz'+   writeIORef arr_r arr'++-- -----------------------------------------------------------------------------+-- Low-level reading/writing of bytes++putPrim :: BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()+putPrim h@(BinMem _ ix_r sz_r arr_r) size f = do+  ix <- readFastMutInt ix_r+  sz <- readFastMutInt sz_r+  when (ix + size > sz) $+    expandBin h (ix + size)+  arr <- readIORef arr_r+  withForeignPtr arr $ \op -> f (op `plusPtr` ix)+  writeFastMutInt ix_r (ix + size)++getPrim :: BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a+getPrim (BinMem _ ix_r sz_r arr_r) size f = do+  ix <- readFastMutInt ix_r+  sz <- readFastMutInt sz_r+  when (ix + size > sz) $+      ioError (mkIOError eofErrorType "Data.Binary.getPrim" Nothing Nothing)+  arr <- readIORef arr_r+  w <- withForeignPtr arr $ \op -> f (op `plusPtr` ix)+  writeFastMutInt ix_r (ix + size)+  return w++putWord8 :: BinHandle -> Word8 -> IO ()+putWord8 h w = putPrim h 1 (\op -> poke op w)++getWord8 :: BinHandle -> IO Word8+getWord8 h = getPrim h 1 peek++putWord16 :: BinHandle -> Word16 -> IO ()+putWord16 h w = putPrim h 2 (\op -> do+  pokeElemOff op 0 (fromIntegral (w `shiftR` 8))+  pokeElemOff op 1 (fromIntegral (w .&. 0xFF))+  )++getWord16 :: BinHandle -> IO Word16+getWord16 h = getPrim h 2 (\op -> do+  w0 <- fromIntegral <$> peekElemOff op 0+  w1 <- fromIntegral <$> peekElemOff op 1+  return $! w0 `shiftL` 8 .|. w1+  )++putWord32 :: BinHandle -> Word32 -> IO ()+putWord32 h w = putPrim h 4 (\op -> do+  pokeElemOff op 0 (fromIntegral (w `shiftR` 24))+  pokeElemOff op 1 (fromIntegral ((w `shiftR` 16) .&. 0xFF))+  pokeElemOff op 2 (fromIntegral ((w `shiftR` 8) .&. 0xFF))+  pokeElemOff op 3 (fromIntegral (w .&. 0xFF))+  )++getWord32 :: BinHandle -> IO Word32+getWord32 h = getPrim h 4 (\op -> do+  w0 <- fromIntegral <$> peekElemOff op 0+  w1 <- fromIntegral <$> peekElemOff op 1+  w2 <- fromIntegral <$> peekElemOff op 2+  w3 <- fromIntegral <$> peekElemOff op 3++  return $! (w0 `shiftL` 24) .|.+            (w1 `shiftL` 16) .|.+            (w2 `shiftL` 8)  .|.+            w3+  )++putWord64 :: BinHandle -> Word64 -> IO ()+putWord64 h w = putPrim h 8 (\op -> do+  pokeElemOff op 0 (fromIntegral (w `shiftR` 56))+  pokeElemOff op 1 (fromIntegral ((w `shiftR` 48) .&. 0xFF))+  pokeElemOff op 2 (fromIntegral ((w `shiftR` 40) .&. 0xFF))+  pokeElemOff op 3 (fromIntegral ((w `shiftR` 32) .&. 0xFF))+  pokeElemOff op 4 (fromIntegral ((w `shiftR` 24) .&. 0xFF))+  pokeElemOff op 5 (fromIntegral ((w `shiftR` 16) .&. 0xFF))+  pokeElemOff op 6 (fromIntegral ((w `shiftR` 8) .&. 0xFF))+  pokeElemOff op 7 (fromIntegral (w .&. 0xFF))+  )++getWord64 :: BinHandle -> IO Word64+getWord64 h = getPrim h 8 (\op -> do+  w0 <- fromIntegral <$> peekElemOff op 0+  w1 <- fromIntegral <$> peekElemOff op 1+  w2 <- fromIntegral <$> peekElemOff op 2+  w3 <- fromIntegral <$> peekElemOff op 3+  w4 <- fromIntegral <$> peekElemOff op 4+  w5 <- fromIntegral <$> peekElemOff op 5+  w6 <- fromIntegral <$> peekElemOff op 6+  w7 <- fromIntegral <$> peekElemOff op 7++  return $! (w0 `shiftL` 56) .|.+            (w1 `shiftL` 48) .|.+            (w2 `shiftL` 40) .|.+            (w3 `shiftL` 32) .|.+            (w4 `shiftL` 24) .|.+            (w5 `shiftL` 16) .|.+            (w6 `shiftL` 8)  .|.+            w7+  )++putByte :: BinHandle -> Word8 -> IO ()+putByte bh w = putWord8 bh w++getByte :: BinHandle -> IO Word8+getByte h = getWord8 h++-- -----------------------------------------------------------------------------+-- Primitve Word writes++instance Binary Word8 where+  put_ = putWord8+  get  = getWord8++instance Binary Word16 where+  put_ h w = putWord16 h w+  get h = getWord16 h++instance Binary Word32 where+  put_ h w = putWord32 h w+  get h = getWord32 h++instance Binary Word64 where+  put_ h w = putWord64 h w+  get h = getWord64 h++-- -----------------------------------------------------------------------------+-- Primitve Int writes++instance Binary Int8 where+  put_ h w = put_ h (fromIntegral w :: Word8)+  get h    = do w <- get h; return $! (fromIntegral (w::Word8))++instance Binary Int16 where+  put_ h w = put_ h (fromIntegral w :: Word16)+  get h    = do w <- get h; return $! (fromIntegral (w::Word16))++instance Binary Int32 where+  put_ h w = put_ h (fromIntegral w :: Word32)+  get h    = do w <- get h; return $! (fromIntegral (w::Word32))++instance Binary Int64 where+  put_ h w = put_ h (fromIntegral w :: Word64)+  get h    = do w <- get h; return $! (fromIntegral (w::Word64))++-- -----------------------------------------------------------------------------+-- Instances for standard types++instance Binary () where+    put_ _ () = return ()+    get  _    = return ()++instance Binary Bool where+    put_ bh b = putByte bh (fromIntegral (fromEnum b))+    get  bh   = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))++instance Binary Char where+    put_  bh c = put_ bh (fromIntegral (ord c) :: Word32)+    get  bh   = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))++instance Binary Int where+    put_ bh i = put_ bh (fromIntegral i :: Int64)+    get  bh = do+        x <- get bh+        return $! (fromIntegral (x :: Int64))++instance Binary a => Binary [a] where+    put_ bh l = do+        let len = length l+        if (len < 0xff)+          then putByte bh (fromIntegral len :: Word8)+          else do putByte bh 0xff; put_ bh (fromIntegral len :: Word32)+        mapM_ (put_ bh) l+    get bh = do+        b <- getByte bh+        len <- if b == 0xff+                  then get bh+                  else return (fromIntegral b :: Word32)+        let loop 0 = return []+            loop n = do a <- get bh; as <- loop (n-1); return (a:as)+        loop len++instance (Binary a, Binary b) => Binary (a,b) where+    put_ bh (a,b) = do put_ bh a; put_ bh b+    get bh        = do a <- get bh+                       b <- get bh+                       return (a,b)++instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where+    put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c+    get bh          = do a <- get bh+                         b <- get bh+                         c <- get bh+                         return (a,b,c)++instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where+    put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d+    get bh            = do a <- get bh+                           b <- get bh+                           c <- get bh+                           d <- get bh+                           return (a,b,c,d)++instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d, e) where+    put_ bh (a,b,c,d, e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e;+    get bh               = do a <- get bh+                              b <- get bh+                              c <- get bh+                              d <- get bh+                              e <- get bh+                              return (a,b,c,d,e)++instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d, e, f) where+    put_ bh (a,b,c,d, e, f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f;+    get bh                  = do a <- get bh+                                 b <- get bh+                                 c <- get bh+                                 d <- get bh+                                 e <- get bh+                                 f <- get bh+                                 return (a,b,c,d,e,f)++instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) => Binary (a,b,c,d,e,f,g) where+    put_ bh (a,b,c,d,e,f,g) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; put_ bh g+    get bh                  = do a <- get bh+                                 b <- get bh+                                 c <- get bh+                                 d <- get bh+                                 e <- get bh+                                 f <- get bh+                                 g <- get bh+                                 return (a,b,c,d,e,f,g)++instance Binary a => Binary (Maybe a) where+    put_ bh Nothing  = putByte bh 0+    put_ bh (Just a) = do putByte bh 1; put_ bh a+    get bh           = do h <- getWord8 bh+                          case h of+                            0 -> return Nothing+                            _ -> do x <- get bh; return (Just x)++instance (Binary a, Binary b) => Binary (Either a b) where+    put_ bh (Left  a) = do putByte bh 0; put_ bh a+    put_ bh (Right b) = do putByte bh 1; put_ bh b+    get bh            = do h <- getWord8 bh+                           case h of+                             0 -> do a <- get bh ; return (Left a)+                             _ -> do b <- get bh ; return (Right b)++instance Binary UTCTime where+    put_ bh u = do put_ bh (utctDay u)+                   put_ bh (utctDayTime u)+    get bh = do day <- get bh+                dayTime <- get bh+                return $ UTCTime { utctDay = day, utctDayTime = dayTime }++instance Binary Day where+    put_ bh d = put_ bh (toModifiedJulianDay d)+    get bh = do i <- get bh+                return $ ModifiedJulianDay { toModifiedJulianDay = i }++instance Binary DiffTime where+    put_ bh dt = put_ bh (toRational dt)+    get bh = do r <- get bh+                return $ fromRational r++--to quote binary-0.3 on this code idea,+--+-- TODO  This instance is not architecture portable.  GMP stores numbers as+-- arrays of machine sized words, so the byte format is not portable across+-- architectures with different endianess and word size.+--+-- This makes it hard (impossible) to make an equivalent instance+-- with code that is compilable with non-GHC.  Do we need any instance+-- Binary Integer, and if so, does it have to be blazing fast?  Or can+-- we just change this instance to be portable like the rest of the+-- instances? (binary package has code to steal for that)+--+-- yes, we need Binary Integer and Binary Rational in basicTypes/Literal.hs++instance Binary Integer where+    put_ bh i+      | i >= lo32 && i <= hi32 = do+          putWord8 bh 0+          put_ bh (fromIntegral i :: Int32)+      | otherwise = do+          putWord8 bh 1+          put_ bh (show i)+      where+        lo32 = fromIntegral (minBound :: Int32)+        hi32 = fromIntegral (maxBound :: Int32)++    get bh = do+      int_kind <- getWord8 bh+      case int_kind of+        0 -> fromIntegral <$> (get bh :: IO Int32)+        _ -> do str <- get bh+                case reads str of+                  [(i, "")] -> return i+                  _ -> fail ("Binary integer: got " ++ show str)++    {-+    -- This code is currently commented out.+    -- See https://ghc.haskell.org/trac/ghc/ticket/3379#comment:10 for+    -- discussion.++    put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)+    put_ bh (J# s# a#) = do+        putByte bh 1+        put_ bh (I# s#)+        let sz# = sizeofByteArray# a#  -- in *bytes*+        put_ bh (I# sz#)  -- in *bytes*+        putByteArray bh a# sz#++    get bh = do+        b <- getByte bh+        case b of+          0 -> do (I# i#) <- get bh+                  return (S# i#)+          _ -> do (I# s#) <- get bh+                  sz <- get bh+                  (BA a#) <- getByteArray bh sz+                  return (J# s# a#)++putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()+putByteArray bh a s# = loop 0#+  where loop n#+           | n# ==# s# = return ()+           | otherwise = do+                putByte bh (indexByteArray a n#)+                loop (n# +# 1#)++getByteArray :: BinHandle -> Int -> IO ByteArray+getByteArray bh (I# sz) = do+  (MBA arr) <- newByteArray sz+  let loop n+           | n ==# sz = return ()+           | otherwise = do+                w <- getByte bh+                writeByteArray arr n w+                loop (n +# 1#)+  loop 0#+  freezeByteArray arr+    -}++{-+data ByteArray = BA ByteArray#+data MBA = MBA (MutableByteArray# RealWorld)++newByteArray :: Int# -> IO MBA+newByteArray sz = IO $ \s ->+  case newByteArray# sz s of { (# s, arr #) ->+  (# s, MBA arr #) }++freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray+freezeByteArray arr = IO $ \s ->+  case unsafeFreezeByteArray# arr s of { (# s, arr #) ->+  (# s, BA arr #) }++writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()+writeByteArray arr i (W8# w) = IO $ \s ->+  case writeWord8Array# arr i w s of { s ->+  (# s, () #) }++indexByteArray :: ByteArray# -> Int# -> Word8+indexByteArray a# n# = W8# (indexWord8Array# a# n#)++-}+instance (Binary a) => Binary (Ratio a) where+    put_ bh (a :% b) = do put_ bh a; put_ bh b+    get bh = do a <- get bh; b <- get bh; return (a :% b)++instance Binary (Bin a) where+  put_ bh (BinPtr i) = put_ bh (fromIntegral i :: Int32)+  get bh = do i <- get bh; return (BinPtr (fromIntegral (i :: Int32)))++-- -----------------------------------------------------------------------------+-- Instances for Data.Typeable stuff++#if MIN_VERSION_base(4,10,0)+instance Binary TyCon where+    put_ bh tc = do+        put_ bh (tyConPackage tc)+        put_ bh (tyConModule tc)+        put_ bh (tyConName tc)+        put_ bh (tyConKindArgs tc)+        put_ bh (tyConKindRep tc)+    get bh =+        mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh+#else+instance Binary TyCon where+    put_ bh tc = do+        put_ bh (tyConPackage tc)+        put_ bh (tyConModule tc)+        put_ bh (tyConName tc)+    get bh =+        mkTyCon3 <$> get bh <*> get bh <*> get bh+#endif++#if MIN_VERSION_base(4,10,0)+instance Binary VecCount where+    put_ bh = putByte bh . fromIntegral . fromEnum+    get bh = toEnum . fromIntegral <$> getByte bh++instance Binary VecElem where+    put_ bh = putByte bh . fromIntegral . fromEnum+    get bh = toEnum . fromIntegral <$> getByte bh++instance Binary RuntimeRep where+    put_ bh (VecRep a b)    = putByte bh 0 >> put_ bh a >> put_ bh b+    put_ bh (TupleRep reps) = putByte bh 1 >> put_ bh reps+    put_ bh (SumRep reps)   = putByte bh 2 >> put_ bh reps+    put_ bh LiftedRep       = putByte bh 3+    put_ bh UnliftedRep     = putByte bh 4+    put_ bh IntRep          = putByte bh 5+    put_ bh WordRep         = putByte bh 6+    put_ bh Int64Rep        = putByte bh 7+    put_ bh Word64Rep       = putByte bh 8+    put_ bh AddrRep         = putByte bh 9+    put_ bh FloatRep        = putByte bh 10+    put_ bh DoubleRep       = putByte bh 11++    get bh = do+        tag <- getByte bh+        case tag of+          0  -> VecRep <$> get bh <*> get bh+          1  -> TupleRep <$> get bh+          2  -> SumRep <$> get bh+          3  -> pure LiftedRep+          4  -> pure UnliftedRep+          5  -> pure IntRep+          6  -> pure WordRep+          7  -> pure Int64Rep+          8  -> pure Word64Rep+          9  -> pure AddrRep+          10 -> pure FloatRep+          11 -> pure DoubleRep+          _  -> fail "Binary.putRuntimeRep: invalid tag"++instance Binary KindRep where+    put_ bh (KindRepTyConApp tc k) = putByte bh 0 >> put_ bh tc >> put_ bh k+    put_ bh (KindRepVar bndr) = putByte bh 1 >> put_ bh bndr+    put_ bh (KindRepApp a b) = putByte bh 2 >> put_ bh a >> put_ bh b+    put_ bh (KindRepFun a b) = putByte bh 3 >> put_ bh a >> put_ bh b+    put_ bh (KindRepTYPE r) = putByte bh 4 >> put_ bh r+    put_ bh (KindRepTypeLit sort r) = putByte bh 5 >> put_ bh sort >> put_ bh r++    get bh = do+        tag <- getByte bh+        case tag of+          0 -> KindRepTyConApp <$> get bh <*> get bh+          1 -> KindRepVar <$> get bh+          2 -> KindRepApp <$> get bh <*> get bh+          3 -> KindRepFun <$> get bh <*> get bh+          4 -> KindRepTYPE <$> get bh+          5 -> KindRepTypeLit <$> get bh <*> get bh+          _ -> fail "Binary.putKindRep: invalid tag"++instance Binary TypeLitSort where+    put_ bh TypeLitSymbol = putByte bh 0+    put_ bh TypeLitNat = putByte bh 1+    get bh = do+        tag <- getByte bh+        case tag of+          0 -> pure TypeLitSymbol+          1 -> pure TypeLitNat+          _ -> fail "Binary.putTypeLitSort: invalid tag"++putTypeRep :: BinHandle -> TypeRep a -> IO ()+-- Special handling for TYPE, (->), and RuntimeRep due to recursive kind+-- relations.+-- See Note [Mutually recursive representations of primitive types]+putTypeRep bh rep+  | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type)+  = put_ bh (0 :: Word8)+putTypeRep bh (Con' con ks) = do+    put_ bh (1 :: Word8)+    put_ bh con+    put_ bh ks+putTypeRep bh (App f x) = do+    put_ bh (2 :: Word8)+    putTypeRep bh f+    putTypeRep bh x+putTypeRep bh (Fun arg res) = do+    put_ bh (3 :: Word8)+    putTypeRep bh arg+    putTypeRep bh res+putTypeRep _ _ = fail "Binary.putTypeRep: Impossible"++getSomeTypeRep :: BinHandle -> IO SomeTypeRep+getSomeTypeRep bh = do+    tag <- get bh :: IO Word8+    case tag of+        0 -> return $ SomeTypeRep (typeRep :: TypeRep Type)+        1 -> do con <- get bh :: IO TyCon+                ks <- get bh :: IO [SomeTypeRep]+                return $ SomeTypeRep $ mkTrCon con ks++        2 -> do SomeTypeRep f <- getSomeTypeRep bh+                SomeTypeRep x <- getSomeTypeRep bh+                case typeRepKind f of+                  Fun arg res ->+                      case arg `eqTypeRep` typeRepKind x of+                        Just HRefl ->+                            case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of+                              Just HRefl -> return $ SomeTypeRep $ mkTrApp f x+                              _ -> failure "Kind mismatch in type application" []+                        _ -> failure "Kind mismatch in type application"+                             [ "    Found argument of kind: " ++ show (typeRepKind x)+                             , "    Where the constructor:  " ++ show f+                             , "    Expects kind:           " ++ show arg+                             ]+                  _ -> failure "Applied non-arrow"+                       [ "    Applied type: " ++ show f+                       , "    To argument:  " ++ show x+                       ]+        3 -> do SomeTypeRep arg <- getSomeTypeRep bh+                SomeTypeRep res <- getSomeTypeRep bh+                case typeRepKind arg `eqTypeRep` (typeRep :: TypeRep Type) of+                  Just HRefl ->+                      case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of+                        Just HRefl -> return $ SomeTypeRep $ Fun arg res+                        Nothing -> failure "Kind mismatch" []+                  _ -> failure "Kind mismatch" []+        _ -> failure "Invalid SomeTypeRep" []+  where+    failure description info =+        fail $ unlines $ [ "Binary.getSomeTypeRep: "++description ]+                      ++ map ("    "++) info++instance Typeable a => Binary (TypeRep (a :: k)) where+    put_ = putTypeRep+    get bh = do+        SomeTypeRep rep <- getSomeTypeRep bh+        case rep `eqTypeRep` expected of+            Just HRefl -> pure rep+            Nothing    -> fail $ unlines+                               [ "Binary: Type mismatch"+                               , "    Deserialized type: " ++ show rep+                               , "    Expected type:     " ++ show expected+                               ]+     where expected = typeRep :: TypeRep a++instance Binary SomeTypeRep where+    put_ bh (SomeTypeRep rep) = putTypeRep bh rep+    get = getSomeTypeRep+#else+instance Binary TypeRep where+    put_ bh type_rep = do+        let (ty_con, child_type_reps) = splitTyConApp type_rep+        put_ bh ty_con+        put_ bh child_type_reps+    get bh = do+        ty_con <- get bh+        child_type_reps <- get bh+        return (mkTyConApp ty_con child_type_reps)+#endif++-- -----------------------------------------------------------------------------+-- Lazy reading/writing++lazyPut :: Binary a => BinHandle -> a -> IO ()+lazyPut bh a = do+    -- output the obj with a ptr to skip over it:+    pre_a <- tellBin bh+    put_ bh pre_a       -- save a slot for the ptr+    put_ bh a           -- dump the object+    q <- tellBin bh     -- q = ptr to after object+    putAt bh pre_a q    -- fill in slot before a with ptr to q+    seekBin bh q        -- finally carry on writing at q++lazyGet :: Binary a => BinHandle -> IO a+lazyGet bh = do+    p <- get bh -- a BinPtr+    p_a <- tellBin bh+    a <- unsafeInterleaveIO $ do+        -- NB: Use a fresh off_r variable in the child thread, for thread+        -- safety.+        off_r <- newFastMutInt+        getAt bh { _off_r = off_r } p_a+    seekBin bh p -- skip over the object for now+    return a++-- -----------------------------------------------------------------------------+-- UserData+-- -----------------------------------------------------------------------------++-- | Information we keep around during interface file+-- serialization/deserialization. Namely we keep the functions for serializing+-- and deserializing 'Name's and 'FastString's. We do this because we actually+-- use serialization in two distinct settings,+--+-- * When serializing interface files themselves+--+-- * When computing the fingerprint of an IfaceDecl (which we computing by+--   hashing its Binary serialization)+--+-- These two settings have different needs while serializing Names:+--+-- * Names in interface files are serialized via a symbol table (see Note+--   [Symbol table representation of names] in BinIface).+--+-- * During fingerprinting a binding Name is serialized as the OccName and a+--   non-binding Name is serialized as the fingerprint of the thing they+--   represent. See Note [Fingerprinting IfaceDecls] for further discussion.+--+data UserData =+   UserData {+        -- for *deserialising* only:+        ud_get_name :: BinHandle -> IO Name,+        ud_get_fs   :: BinHandle -> IO FastString,++        -- for *serialising* only:+        ud_put_nonbinding_name :: BinHandle -> Name -> IO (),+        -- ^ serialize a non-binding 'Name' (e.g. a reference to another+        -- binding).+        ud_put_binding_name :: BinHandle -> Name -> IO (),+        -- ^ serialize a binding 'Name' (e.g. the name of an IfaceDecl)+        ud_put_fs   :: BinHandle -> FastString -> IO ()+   }++newReadState :: (BinHandle -> IO Name)   -- ^ how to deserialize 'Name's+             -> (BinHandle -> IO FastString)+             -> UserData+newReadState get_name get_fs+  = UserData { ud_get_name = get_name,+               ud_get_fs   = get_fs,+               ud_put_nonbinding_name = undef "put_nonbinding_name",+               ud_put_binding_name    = undef "put_binding_name",+               ud_put_fs   = undef "put_fs"+             }++newWriteState :: (BinHandle -> Name -> IO ())+                 -- ^ how to serialize non-binding 'Name's+              -> (BinHandle -> Name -> IO ())+                 -- ^ how to serialize binding 'Name's+              -> (BinHandle -> FastString -> IO ())+              -> UserData+newWriteState put_nonbinding_name put_binding_name put_fs+  = UserData { ud_get_name = undef "get_name",+               ud_get_fs   = undef "get_fs",+               ud_put_nonbinding_name = put_nonbinding_name,+               ud_put_binding_name    = put_binding_name,+               ud_put_fs   = put_fs+             }++noUserData :: a+noUserData = undef "UserData"++undef :: String -> a+undef s = panic ("Binary.UserData: no " ++ s)++---------------------------------------------------------+-- The Dictionary+---------------------------------------------------------++type Dictionary = Array Int FastString -- The dictionary+                                       -- Should be 0-indexed++putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO ()+putDictionary bh sz dict = do+  put_ bh sz+  mapM_ (putFS bh) (elems (array (0,sz-1) (nonDetEltsUFM dict)))+    -- It's OK to use nonDetEltsUFM here because the elements have indices+    -- that array uses to create order++getDictionary :: BinHandle -> IO Dictionary+getDictionary bh = do+  sz <- get bh+  elems <- sequence (take sz (repeat (getFS bh)))+  return (listArray (0,sz-1) elems)++---------------------------------------------------------+-- The Symbol Table+---------------------------------------------------------++-- On disk, the symbol table is an array of IfExtName, when+-- reading it in we turn it into a SymbolTable.++type SymbolTable = Array Int Name++---------------------------------------------------------+-- Reading and writing FastStrings+---------------------------------------------------------++putFS :: BinHandle -> FastString -> IO ()+putFS bh fs = putBS bh $ fastStringToByteString fs++getFS :: BinHandle -> IO FastString+getFS bh = do+  l  <- get bh :: IO Int+  getPrim bh l (\src -> pure $! mkFastStringBytes src l )++putBS :: BinHandle -> ByteString -> IO ()+putBS bh bs =+  BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do+    put_ bh l+    putPrim bh l (\op -> BS.memcpy op (castPtr ptr) l)++getBS :: BinHandle -> IO ByteString+getBS bh = do+  l <- get bh :: IO Int+  BS.create l $ \dest -> do+    getPrim bh l (\src -> BS.memcpy dest src l)++instance Binary ByteString where+  put_ bh f = putBS bh f+  get bh = getBS bh++instance Binary FastString where+  put_ bh f =+    case getUserData bh of+        UserData { ud_put_fs = put_fs } -> put_fs bh f++  get bh =+    case getUserData bh of+        UserData { ud_get_fs = get_fs } -> get_fs bh++-- Here to avoid loop+instance Binary LeftOrRight where+   put_ bh CLeft  = putByte bh 0+   put_ bh CRight = putByte bh 1++   get bh = do { h <- getByte bh+               ; case h of+                   0 -> return CLeft+                   _ -> return CRight }++instance Binary Fingerprint where+  put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2+  get  h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2)++instance Binary FunctionOrData where+    put_ bh IsFunction = putByte bh 0+    put_ bh IsData     = putByte bh 1+    get bh = do+        h <- getByte bh+        case h of+          0 -> return IsFunction+          1 -> return IsData+          _ -> panic "Binary FunctionOrData"++instance Binary TupleSort where+    put_ bh BoxedTuple      = putByte bh 0+    put_ bh UnboxedTuple    = putByte bh 1+    put_ bh ConstraintTuple = putByte bh 2+    get bh = do+      h <- getByte bh+      case h of+        0 -> do return BoxedTuple+        1 -> do return UnboxedTuple+        _ -> do return ConstraintTuple++instance Binary Activation where+    put_ bh NeverActive = do+            putByte bh 0+    put_ bh AlwaysActive = do+            putByte bh 1+    put_ bh (ActiveBefore src aa) = do+            putByte bh 2+            put_ bh src+            put_ bh aa+    put_ bh (ActiveAfter src ab) = do+            putByte bh 3+            put_ bh src+            put_ bh ab+    get bh = do+            h <- getByte bh+            case h of+              0 -> do return NeverActive+              1 -> do return AlwaysActive+              2 -> do src <- get bh+                      aa <- get bh+                      return (ActiveBefore src aa)+              _ -> do src <- get bh+                      ab <- get bh+                      return (ActiveAfter src ab)++instance Binary InlinePragma where+    put_ bh (InlinePragma s a b c d) = do+            put_ bh s+            put_ bh a+            put_ bh b+            put_ bh c+            put_ bh d++    get bh = do+           s <- get bh+           a <- get bh+           b <- get bh+           c <- get bh+           d <- get bh+           return (InlinePragma s a b c d)++instance Binary RuleMatchInfo where+    put_ bh FunLike = putByte bh 0+    put_ bh ConLike = putByte bh 1+    get bh = do+            h <- getByte bh+            if h == 1 then return ConLike+                      else return FunLike++instance Binary InlineSpec where+    put_ bh EmptyInlineSpec = putByte bh 0+    put_ bh Inline          = putByte bh 1+    put_ bh Inlinable       = putByte bh 2+    put_ bh NoInline        = putByte bh 3++    get bh = do h <- getByte bh+                case h of+                  0 -> return EmptyInlineSpec+                  1 -> return Inline+                  2 -> return Inlinable+                  _ -> return NoInline++instance Binary RecFlag where+    put_ bh Recursive = do+            putByte bh 0+    put_ bh NonRecursive = do+            putByte bh 1+    get bh = do+            h <- getByte bh+            case h of+              0 -> do return Recursive+              _ -> do return NonRecursive++instance Binary OverlapMode where+    put_ bh (NoOverlap    s) = putByte bh 0 >> put_ bh s+    put_ bh (Overlaps     s) = putByte bh 1 >> put_ bh s+    put_ bh (Incoherent   s) = putByte bh 2 >> put_ bh s+    put_ bh (Overlapping  s) = putByte bh 3 >> put_ bh s+    put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s+    get bh = do+        h <- getByte bh+        case h of+            0 -> (get bh) >>= \s -> return $ NoOverlap s+            1 -> (get bh) >>= \s -> return $ Overlaps s+            2 -> (get bh) >>= \s -> return $ Incoherent s+            3 -> (get bh) >>= \s -> return $ Overlapping s+            4 -> (get bh) >>= \s -> return $ Overlappable s+            _ -> panic ("get OverlapMode" ++ show h)+++instance Binary OverlapFlag where+    put_ bh flag = do put_ bh (overlapMode flag)+                      put_ bh (isSafeOverlap flag)+    get bh = do+        h <- get bh+        b <- get bh+        return OverlapFlag { overlapMode = h, isSafeOverlap = b }++instance Binary FixityDirection where+    put_ bh InfixL = do+            putByte bh 0+    put_ bh InfixR = do+            putByte bh 1+    put_ bh InfixN = do+            putByte bh 2+    get bh = do+            h <- getByte bh+            case h of+              0 -> do return InfixL+              1 -> do return InfixR+              _ -> do return InfixN++instance Binary Fixity where+    put_ bh (Fixity src aa ab) = do+            put_ bh src+            put_ bh aa+            put_ bh ab+    get bh = do+          src <- get bh+          aa <- get bh+          ab <- get bh+          return (Fixity src aa ab)++instance Binary WarningTxt where+    put_ bh (WarningTxt s w) = do+            putByte bh 0+            put_ bh s+            put_ bh w+    put_ bh (DeprecatedTxt s d) = do+            putByte bh 1+            put_ bh s+            put_ bh d++    get bh = do+            h <- getByte bh+            case h of+              0 -> do s <- get bh+                      w <- get bh+                      return (WarningTxt s w)+              _ -> do s <- get bh+                      d <- get bh+                      return (DeprecatedTxt s d)++instance Binary StringLiteral where+  put_ bh (StringLiteral st fs) = do+            put_ bh st+            put_ bh fs+  get bh = do+            st <- get bh+            fs <- get bh+            return (StringLiteral st fs)++instance Binary a => Binary (GenLocated SrcSpan a) where+    put_ bh (L l x) = do+            put_ bh l+            put_ bh x++    get bh = do+            l <- get bh+            x <- get bh+            return (L l x)++instance Binary SrcSpan where+  put_ bh (RealSrcSpan ss) = do+          putByte bh 0+          put_ bh (srcSpanFile ss)+          put_ bh (srcSpanStartLine ss)+          put_ bh (srcSpanStartCol ss)+          put_ bh (srcSpanEndLine ss)+          put_ bh (srcSpanEndCol ss)++  put_ bh (UnhelpfulSpan s) = do+          putByte bh 1+          put_ bh s++  get bh = do+          h <- getByte bh+          case h of+            0 -> do f <- get bh+                    sl <- get bh+                    sc <- get bh+                    el <- get bh+                    ec <- get bh+                    return (mkSrcSpan (mkSrcLoc f sl sc)+                                      (mkSrcLoc f el ec))+            _ -> do s <- get bh+                    return (UnhelpfulSpan s)++instance Binary Serialized where+    put_ bh (Serialized the_type bytes) = do+        put_ bh the_type+        put_ bh bytes+    get bh = do+        the_type <- get bh+        bytes <- get bh+        return (Serialized the_type bytes)++instance Binary SourceText where+  put_ bh NoSourceText = putByte bh 0+  put_ bh (SourceText s) = do+        putByte bh 1+        put_ bh s++  get bh = do+    h <- getByte bh+    case h of+      0 -> return NoSourceText+      1 -> do+        s <- get bh+        return (SourceText s)+      _ -> panic $ "Binary SourceText:" ++ show h
+ utils/BooleanFormula.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable,+             DeriveTraversable #-}++--------------------------------------------------------------------------------+-- | Boolean formulas without quantifiers and without negation.+-- Such a formula consists of variables, conjunctions (and), and disjunctions (or).+--+-- This module is used to represent minimal complete definitions for classes.+--+module BooleanFormula (+        BooleanFormula(..), LBooleanFormula,+        mkFalse, mkTrue, mkAnd, mkOr, mkVar,+        isFalse, isTrue,+        eval, simplify, isUnsatisfied,+        implies, impliesAtom,+        pprBooleanFormula, pprBooleanFormulaNice+  ) where++import Data.List ( nub, intersperse )+import Data.Data++import MonadUtils+import Outputable+import Binary+import SrcLoc+import Unique+import UniqSet++----------------------------------------------------------------------+-- Boolean formula type and smart constructors+----------------------------------------------------------------------++type LBooleanFormula a = Located (BooleanFormula a)++data BooleanFormula a = Var a | And [LBooleanFormula a] | Or [LBooleanFormula a]+                      | Parens (LBooleanFormula a)+  deriving (Eq, Data, Functor, Foldable, Traversable)++mkVar :: a -> BooleanFormula a+mkVar = Var++mkFalse, mkTrue :: BooleanFormula a+mkFalse = Or []+mkTrue = And []++-- Convert a Bool to a BooleanFormula+mkBool :: Bool -> BooleanFormula a+mkBool False = mkFalse+mkBool True  = mkTrue++-- Make a conjunction, and try to simplify+mkAnd :: Eq a => [LBooleanFormula a] -> BooleanFormula a+mkAnd = maybe mkFalse (mkAnd' . nub) . concatMapM fromAnd+  where+  -- See Note [Simplification of BooleanFormulas]+  fromAnd :: LBooleanFormula a -> Maybe [LBooleanFormula a]+  fromAnd (L _ (And xs)) = Just xs+     -- assume that xs are already simplified+     -- otherwise we would need: fromAnd (And xs) = concat <$> traverse fromAnd xs+  fromAnd (L _ (Or [])) = Nothing+     -- in case of False we bail out, And [..,mkFalse,..] == mkFalse+  fromAnd x = Just [x]+  mkAnd' [x] = unLoc x+  mkAnd' xs = And xs++mkOr :: Eq a => [LBooleanFormula a] -> BooleanFormula a+mkOr = maybe mkTrue (mkOr' . nub) . concatMapM fromOr+  where+  -- See Note [Simplification of BooleanFormulas]+  fromOr (L _ (Or xs)) = Just xs+  fromOr (L _ (And [])) = Nothing+  fromOr x = Just [x]+  mkOr' [x] = unLoc x+  mkOr' xs = Or xs+++{-+Note [Simplification of BooleanFormulas]+~~~~~~~~~~~~~~~~~~~~~~+The smart constructors (`mkAnd` and `mkOr`) do some attempt to simplify expressions. In particular,+ 1. Collapsing nested ands and ors, so+     `(mkAnd [x, And [y,z]]`+    is represented as+     `And [x,y,z]`+    Implemented by `fromAnd`/`fromOr`+ 2. Collapsing trivial ands and ors, so+     `mkAnd [x]` becomes just `x`.+    Implemented by mkAnd' / mkOr'+ 3. Conjunction with false, disjunction with true is simplified, i.e.+     `mkAnd [mkFalse,x]` becomes `mkFalse`.+ 4. Common subexpression elimination:+     `mkAnd [x,x,y]` is reduced to just `mkAnd [x,y]`.++This simplification is not exhaustive, in the sense that it will not produce+the smallest possible equivalent expression. For example,+`Or [And [x,y], And [x]]` could be simplified to `And [x]`, but it currently+is not. A general simplifier would need to use something like BDDs.++The reason behind the (crude) simplifier is to make for more user friendly+error messages. E.g. for the code+  > class Foo a where+  >     {-# MINIMAL bar, (foo, baq | foo, quux) #-}+  > instance Foo Int where+  >     bar = ...+  >     baz = ...+  >     quux = ...+We don't show a ridiculous error message like+    Implement () and (either (`foo' and ()) or (`foo' and ()))+-}++----------------------------------------------------------------------+-- Evaluation and simplification+----------------------------------------------------------------------++isFalse :: BooleanFormula a -> Bool+isFalse (Or []) = True+isFalse _ = False++isTrue :: BooleanFormula a -> Bool+isTrue (And []) = True+isTrue _ = False++eval :: (a -> Bool) -> BooleanFormula a -> Bool+eval f (Var x)  = f x+eval f (And xs) = all (eval f . unLoc) xs+eval f (Or xs)  = any (eval f . unLoc) xs+eval f (Parens x) = eval f (unLoc x)++-- Simplify a boolean formula.+-- The argument function should give the truth of the atoms, or Nothing if undecided.+simplify :: Eq a => (a -> Maybe Bool) -> BooleanFormula a -> BooleanFormula a+simplify f (Var a) = case f a of+  Nothing -> Var a+  Just b  -> mkBool b+simplify f (And xs) = mkAnd (map (\(L l x) -> L l (simplify f x)) xs)+simplify f (Or xs) = mkOr (map (\(L l x) -> L l (simplify f x)) xs)+simplify f (Parens x) = simplify f (unLoc x)++-- Test if a boolean formula is satisfied when the given values are assigned to the atoms+-- if it is, returns Nothing+-- if it is not, return (Just remainder)+isUnsatisfied :: Eq a => (a -> Bool) -> BooleanFormula a -> Maybe (BooleanFormula a)+isUnsatisfied f bf+    | isTrue bf' = Nothing+    | otherwise  = Just bf'+  where+  f' x = if f x then Just True else Nothing+  bf' = simplify f' bf++-- prop_simplify:+--   eval f x == True   <==>  isTrue  (simplify (Just . f) x)+--   eval f x == False  <==>  isFalse (simplify (Just . f) x)++-- If the boolean formula holds, does that mean that the given atom is always true?+impliesAtom :: Eq a => BooleanFormula a -> a -> Bool+Var x  `impliesAtom` y = x == y+And xs `impliesAtom` y = any (\x -> (unLoc x) `impliesAtom` y) xs+           -- we have all of xs, so one of them implying y is enough+Or  xs `impliesAtom` y = all (\x -> (unLoc x) `impliesAtom` y) xs+Parens x `impliesAtom` y = (unLoc x) `impliesAtom` y++implies :: Uniquable a => BooleanFormula a -> BooleanFormula a -> Bool+implies e1 e2 = go (Clause emptyUniqSet [e1]) (Clause emptyUniqSet [e2])+  where+    go :: Uniquable a => Clause a -> Clause a -> Bool+    go l@Clause{ clauseExprs = hyp:hyps } r =+        case hyp of+            Var x | memberClauseAtoms x r -> True+                  | otherwise -> go (extendClauseAtoms l x) { clauseExprs = hyps } r+            Parens hyp' -> go l { clauseExprs = unLoc hyp':hyps }     r+            And hyps'  -> go l { clauseExprs = map unLoc hyps' ++ hyps } r+            Or hyps'   -> all (\hyp' -> go l { clauseExprs = unLoc hyp':hyps } r) hyps'+    go l r@Clause{ clauseExprs = con:cons } =+        case con of+            Var x | memberClauseAtoms x l -> True+                  | otherwise -> go l (extendClauseAtoms r x) { clauseExprs = cons }+            Parens con' -> go l r { clauseExprs = unLoc con':cons }+            And cons'   -> all (\con' -> go l r { clauseExprs = unLoc con':cons }) cons'+            Or cons'    -> go l r { clauseExprs = map unLoc cons' ++ cons }+    go _ _ = False++-- A small sequent calculus proof engine.+data Clause a = Clause {+        clauseAtoms :: UniqSet a,+        clauseExprs :: [BooleanFormula a]+    }+extendClauseAtoms :: Uniquable a => Clause a -> a -> Clause a+extendClauseAtoms c x = c { clauseAtoms = addOneToUniqSet (clauseAtoms c) x }++memberClauseAtoms :: Uniquable a => a -> Clause a -> Bool+memberClauseAtoms x c = x `elementOfUniqSet` clauseAtoms c++----------------------------------------------------------------------+-- Pretty printing+----------------------------------------------------------------------++-- Pretty print a BooleanFormula,+-- using the arguments as pretty printers for Var, And and Or respectively+pprBooleanFormula' :: (Rational -> a -> SDoc)+                   -> (Rational -> [SDoc] -> SDoc)+                   -> (Rational -> [SDoc] -> SDoc)+                   -> Rational -> BooleanFormula a -> SDoc+pprBooleanFormula' pprVar pprAnd pprOr = go+  where+  go p (Var x)  = pprVar p x+  go p (And []) = cparen (p > 0) $ empty+  go p (And xs) = pprAnd p (map (go 3 . unLoc) xs)+  go _ (Or  []) = keyword $ text "FALSE"+  go p (Or  xs) = pprOr p (map (go 2 . unLoc) xs)+  go p (Parens x) = go p (unLoc x)++-- Pretty print in source syntax, "a | b | c,d,e"+pprBooleanFormula :: (Rational -> a -> SDoc) -> Rational -> BooleanFormula a -> SDoc+pprBooleanFormula pprVar = pprBooleanFormula' pprVar pprAnd pprOr+  where+  pprAnd p = cparen (p > 3) . fsep . punctuate comma+  pprOr  p = cparen (p > 2) . fsep . intersperse vbar++-- Pretty print human in readable format, "either `a' or `b' or (`c', `d' and `e')"?+pprBooleanFormulaNice :: Outputable a => BooleanFormula a -> SDoc+pprBooleanFormulaNice = pprBooleanFormula' pprVar pprAnd pprOr 0+  where+  pprVar _ = quotes . ppr+  pprAnd p = cparen (p > 1) . pprAnd'+  pprAnd' [] = empty+  pprAnd' [x,y] = x <+> text "and" <+> y+  pprAnd' xs@(_:_) = fsep (punctuate comma (init xs)) <> text ", and" <+> last xs+  pprOr p xs = cparen (p > 1) $ text "either" <+> sep (intersperse (text "or") xs)++instance (OutputableBndr a) => Outputable (BooleanFormula a) where+  ppr = pprBooleanFormulaNormal++pprBooleanFormulaNormal :: (OutputableBndr a)+                        => BooleanFormula a -> SDoc+pprBooleanFormulaNormal = go+  where+    go (Var x)    = pprPrefixOcc x+    go (And xs)   = fsep $ punctuate comma (map (go . unLoc) xs)+    go (Or [])    = keyword $ text "FALSE"+    go (Or xs)    = fsep $ intersperse vbar (map (go . unLoc) xs)+    go (Parens x) = parens (go $ unLoc x)+++----------------------------------------------------------------------+-- Binary+----------------------------------------------------------------------++instance Binary a => Binary (BooleanFormula a) where+  put_ bh (Var x)    = putByte bh 0 >> put_ bh x+  put_ bh (And xs)   = putByte bh 1 >> put_ bh xs+  put_ bh (Or  xs)   = putByte bh 2 >> put_ bh xs+  put_ bh (Parens x) = putByte bh 3 >> put_ bh x++  get bh = do+    h <- getByte bh+    case h of+      0 -> Var    <$> get bh+      1 -> And    <$> get bh+      2 -> Or     <$> get bh+      _ -> Parens <$> get bh
+ utils/BufWrite.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE BangPatterns #-}++-----------------------------------------------------------------------------+--+-- Fast write-buffered Handles+--+-- (c) The University of Glasgow 2005-2006+--+-- This is a simple abstraction over Handles that offers very fast write+-- buffering, but without the thread safety that Handles provide.  It's used+-- to save time in Pretty.printDoc.+--+-----------------------------------------------------------------------------++module BufWrite (+        BufHandle(..),+        newBufHandle,+        bPutChar,+        bPutStr,+        bPutFS,+        bPutFZS,+        bPutLitString,+        bFlush,+  ) where++import FastString+import FastMutInt++import Control.Monad    ( when )+import Data.ByteString (ByteString)+import qualified Data.ByteString.Unsafe as BS+import Data.Char        ( ord )+import Foreign+import Foreign.C.String+import System.IO++-- -----------------------------------------------------------------------------++data BufHandle = BufHandle {-#UNPACK#-}!(Ptr Word8)+                           {-#UNPACK#-}!FastMutInt+                           Handle++newBufHandle :: Handle -> IO BufHandle+newBufHandle hdl = do+  ptr <- mallocBytes buf_size+  r <- newFastMutInt+  writeFastMutInt r 0+  return (BufHandle ptr r hdl)++buf_size :: Int+buf_size = 8192++bPutChar :: BufHandle -> Char -> IO ()+bPutChar b@(BufHandle buf r hdl) !c = do+  i <- readFastMutInt r+  if (i >= buf_size)+        then do hPutBuf hdl buf buf_size+                writeFastMutInt r 0+                bPutChar b c+        else do pokeElemOff buf i (fromIntegral (ord c) :: Word8)+                writeFastMutInt r (i+1)++bPutStr :: BufHandle -> String -> IO ()+bPutStr (BufHandle buf r hdl) !str = do+  i <- readFastMutInt r+  loop str i+  where loop "" !i = do writeFastMutInt r i; return ()+        loop (c:cs) !i+           | i >= buf_size = do+                hPutBuf hdl buf buf_size+                loop (c:cs) 0+           | otherwise = do+                pokeElemOff buf i (fromIntegral (ord c))+                loop cs (i+1)++bPutFS :: BufHandle -> FastString -> IO ()+bPutFS b fs = bPutBS b $ fastStringToByteString fs++bPutFZS :: BufHandle -> FastZString -> IO ()+bPutFZS b fs = bPutBS b $ fastZStringToByteString fs++bPutBS :: BufHandle -> ByteString -> IO ()+bPutBS b bs = BS.unsafeUseAsCStringLen bs $ bPutCStringLen b++bPutCStringLen :: BufHandle -> CStringLen -> IO ()+bPutCStringLen b@(BufHandle buf r hdl) cstr@(ptr, len) = do+  i <- readFastMutInt r+  if (i + len) >= buf_size+        then do hPutBuf hdl buf i+                writeFastMutInt r 0+                if (len >= buf_size)+                    then hPutBuf hdl ptr len+                    else bPutCStringLen b cstr+        else do+                copyBytes (buf `plusPtr` i) ptr len+                writeFastMutInt r (i + len)++bPutLitString :: BufHandle -> LitString -> Int -> IO ()+bPutLitString b@(BufHandle buf r hdl) a len = a `seq` do+  i <- readFastMutInt r+  if (i+len) >= buf_size+        then do hPutBuf hdl buf i+                writeFastMutInt r 0+                if (len >= buf_size)+                    then hPutBuf hdl a len+                    else bPutLitString b a len+        else do+                copyBytes (buf `plusPtr` i) a len+                writeFastMutInt r (i+len)++bFlush :: BufHandle -> IO ()+bFlush (BufHandle buf r hdl) = do+  i <- readFastMutInt r+  when (i > 0) $ hPutBuf hdl buf i+  free buf+  return ()
+ utils/Digraph.hs view
@@ -0,0 +1,502 @@+-- (c) The University of Glasgow 2006++{-# LANGUAGE CPP, ScopedTypeVariables #-}++module Digraph(+        Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq,++        SCC(..), Node, flattenSCC, flattenSCCs,+        stronglyConnCompG,+        topologicalSortG, dfsTopSortG,+        verticesG, edgesG, hasVertexG,+        reachableG, reachablesG, transposeG,+        outdegreeG, indegreeG,+        vertexGroupsG, emptyG,+        componentsG,++        findCycle,++        -- For backwards compatibility with the simpler version of Digraph+        stronglyConnCompFromEdgedVerticesOrd,+        stronglyConnCompFromEdgedVerticesOrdR,+        stronglyConnCompFromEdgedVerticesUniq,+        stronglyConnCompFromEdgedVerticesUniqR,+    ) where++#include "HsVersions.h"++------------------------------------------------------------------------------+-- A version of the graph algorithms described in:+--+-- ``Lazy Depth-First Search and Linear IntGraph Algorithms in Haskell''+--   by David King and John Launchbury+--+-- Also included is some additional code for printing tree structures ...+--+-- If you ever find yourself in need of algorithms for classifying edges,+-- or finding connected/biconnected components, consult the history; Sigbjorn+-- Finne contributed some implementations in 1997, although we've since+-- removed them since they were not used anywhere in GHC.+------------------------------------------------------------------------------+++import Util        ( minWith, count )+import Outputable+import Maybes      ( expectJust )+import MonadUtils  ( allM )++-- Extensions+import Control.Monad    ( filterM, liftM, liftM2 )+import Control.Monad.ST++-- std interfaces+import Data.Maybe+import Data.Array+import Data.List hiding (transpose)+import Data.Array.ST+import qualified Data.Map as Map+import qualified Data.Set as Set++import qualified Data.Graph as G+import Data.Graph hiding (Graph, Edge, transposeG, reachable)+import Data.Tree+import Unique+import UniqFM++{-+************************************************************************+*                                                                      *+*      Graphs and Graph Construction+*                                                                      *+************************************************************************++Note [Nodes, keys, vertices]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+ * A 'node' is a big blob of client-stuff++ * Each 'node' has a unique (client) 'key', but the latter+        is in Ord and has fast comparison++ * Digraph then maps each 'key' to a Vertex (Int) which is+        arranged densely in 0.n+-}++data Graph node = Graph {+    gr_int_graph      :: IntGraph,+    gr_vertex_to_node :: Vertex -> node,+    gr_node_to_vertex :: node -> Maybe Vertex+  }++data Edge node = Edge node node++type Node key payload = (payload, key, [key])+     -- The payload is user data, just carried around in this module+     -- The keys are ordered+     -- The [key] are the dependencies of the node;+     --    it's ok to have extra keys in the dependencies that+     --    are not the key of any Node in the graph++emptyGraph :: Graph a+emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing)++-- See Note [Deterministic SCC]+graphFromEdgedVertices+        :: ReduceFn key payload+        -> [Node key payload]           -- The graph; its ok for the+                                        -- out-list to contain keys which aren't+                                        -- a vertex key, they are ignored+        -> Graph (Node key payload)+graphFromEdgedVertices _reduceFn []            = emptyGraph+graphFromEdgedVertices reduceFn edged_vertices =+  Graph graph vertex_fn (key_vertex . key_extractor)+  where key_extractor (_, k, _) = k+        (bounds, vertex_fn, key_vertex, numbered_nodes) =+          reduceFn edged_vertices key_extractor+        graph = array bounds [ (v, sort $ mapMaybe key_vertex ks)+                             | (v, (_, _, ks)) <- numbered_nodes]+                -- We normalize outgoing edges by sorting on node order, so+                -- that the result doesn't depend on the order of the edges++-- See Note [Deterministic SCC]+-- See Note [reduceNodesIntoVertices implementations]+graphFromEdgedVerticesOrd+        :: Ord key+        => [Node key payload]           -- The graph; its ok for the+                                        -- out-list to contain keys which aren't+                                        -- a vertex key, they are ignored+        -> Graph (Node key payload)+graphFromEdgedVerticesOrd = graphFromEdgedVertices reduceNodesIntoVerticesOrd++-- See Note [Deterministic SCC]+-- See Note [reduceNodesIntoVertices implementations]+graphFromEdgedVerticesUniq+        :: Uniquable key+        => [Node key payload]           -- The graph; its ok for the+                                        -- out-list to contain keys which aren't+                                        -- a vertex key, they are ignored+        -> Graph (Node key payload)+graphFromEdgedVerticesUniq = graphFromEdgedVertices reduceNodesIntoVerticesUniq++type ReduceFn key payload =+  [Node key payload] -> (Node key payload -> key) ->+    (Bounds, Vertex -> Node key payload+    , key -> Maybe Vertex, [(Vertex, Node key payload)])++{-+Note [reduceNodesIntoVertices implementations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+reduceNodesIntoVertices is parameterized by the container type.+This is to accomodate key types that don't have an Ord instance+and hence preclude the use of Data.Map. An example of such type+would be Unique, there's no way to implement Ord Unique+deterministically.++For such types, there's a version with a Uniquable constraint.+This leaves us with two versions of every function that depends on+reduceNodesIntoVertices, one with Ord constraint and the other with+Uniquable constraint.+For example: graphFromEdgedVerticesOrd and graphFromEdgedVerticesUniq.++The Uniq version should be a tiny bit more efficient since it uses+Data.IntMap internally.+-}+reduceNodesIntoVertices+  :: ([(key, Vertex)] -> m)+  -> (key -> m -> Maybe Vertex)+  -> ReduceFn key payload+reduceNodesIntoVertices fromList lookup nodes key_extractor =+  (bounds, (!) vertex_map, key_vertex, numbered_nodes)+  where+    max_v           = length nodes - 1+    bounds          = (0, max_v) :: (Vertex, Vertex)++    -- Keep the order intact to make the result depend on input order+    -- instead of key order+    numbered_nodes  = zip [0..] nodes+    vertex_map      = array bounds numbered_nodes++    key_map = fromList+      [ (key_extractor node, v) | (v, node) <- numbered_nodes ]+    key_vertex k = lookup k key_map++-- See Note [reduceNodesIntoVertices implementations]+reduceNodesIntoVerticesOrd :: Ord key => ReduceFn key payload+reduceNodesIntoVerticesOrd = reduceNodesIntoVertices Map.fromList Map.lookup++-- See Note [reduceNodesIntoVertices implementations]+reduceNodesIntoVerticesUniq :: Uniquable key => ReduceFn key payload+reduceNodesIntoVerticesUniq = reduceNodesIntoVertices listToUFM (flip lookupUFM)++{-+************************************************************************+*                                                                      *+*      SCC+*                                                                      *+************************************************************************+-}++type WorkItem key payload+  = (Node key payload,  -- Tip of the path+     [payload])         -- Rest of the path;+                        --  [a,b,c] means c depends on b, b depends on a++-- | Find a reasonably short cycle a->b->c->a, in a strongly+-- connected component.  The input nodes are presumed to be+-- a SCC, so you can start anywhere.+findCycle :: forall payload key. Ord key+          => [Node key payload]     -- The nodes.  The dependencies can+                                    -- contain extra keys, which are ignored+          -> Maybe [payload]        -- A cycle, starting with node+                                    -- so each depends on the next+findCycle graph+  = go Set.empty (new_work root_deps []) []+  where+    env :: Map.Map key (Node key payload)+    env = Map.fromList [ (key, node) | node@(_, key, _) <- graph ]++    -- Find the node with fewest dependencies among the SCC modules+    -- This is just a heuristic to find some plausible root module+    root :: Node key payload+    root = fst (minWith snd [ (node, count (`Map.member` env) deps)+                            | node@(_,_,deps) <- graph ])+    (root_payload,root_key,root_deps) = root+++    -- 'go' implements Dijkstra's algorithm, more or less+    go :: Set.Set key   -- Visited+       -> [WorkItem key payload]        -- Work list, items length n+       -> [WorkItem key payload]        -- Work list, items length n+1+       -> Maybe [payload]               -- Returned cycle+       -- Invariant: in a call (go visited ps qs),+       --            visited = union (map tail (ps ++ qs))++    go _       [] [] = Nothing  -- No cycles+    go visited [] qs = go visited qs []+    go visited (((payload,key,deps), path) : ps) qs+       | key == root_key           = Just (root_payload : reverse path)+       | key `Set.member` visited  = go visited ps qs+       | key `Map.notMember` env   = go visited ps qs+       | otherwise                 = go (Set.insert key visited)+                                        ps (new_qs ++ qs)+       where+         new_qs = new_work deps (payload : path)++    new_work :: [key] -> [payload] -> [WorkItem key payload]+    new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ]++{-+************************************************************************+*                                                                      *+*      Strongly Connected Component wrappers for Graph+*                                                                      *+************************************************************************++Note: the components are returned topologically sorted: later components+depend on earlier ones, but not vice versa i.e. later components only have+edges going from them to earlier ones.+-}++{-+Note [Deterministic SCC]+~~~~~~~~~~~~~~~~~~~~~~~~+stronglyConnCompFromEdgedVerticesUniq,+stronglyConnCompFromEdgedVerticesUniqR,+stronglyConnCompFromEdgedVerticesOrd and+stronglyConnCompFromEdgedVerticesOrdR+provide a following guarantee:+Given a deterministically ordered list of nodes it returns a deterministically+ordered list of strongly connected components, where the list of vertices+in an SCC is also deterministically ordered.+Note that the order of edges doesn't need to be deterministic for this to work.+We use the order of nodes to normalize the order of edges.+-}++stronglyConnCompG :: Graph node -> [SCC node]+stronglyConnCompG graph = decodeSccs graph forest+  where forest = {-# SCC "Digraph.scc" #-} scc (gr_int_graph graph)++decodeSccs :: Graph node -> Forest Vertex -> [SCC node]+decodeSccs Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn } forest+  = map decode forest+  where+    decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]+                       | otherwise         = AcyclicSCC (vertex_fn v)+    decode other = CyclicSCC (dec other [])+      where dec (Node v ts) vs = vertex_fn v : foldr dec vs ts+    mentions_itself v = v `elem` (graph ! v)+++-- The following two versions are provided for backwards compatibility:+-- See Note [Deterministic SCC]+-- See Note [reduceNodesIntoVertices implementations]+stronglyConnCompFromEdgedVerticesOrd+        :: Ord key+        => [Node key payload]+        -> [SCC payload]+stronglyConnCompFromEdgedVerticesOrd+  = map (fmap get_node) . stronglyConnCompFromEdgedVerticesOrdR+  where get_node (n, _, _) = n++-- The following two versions are provided for backwards compatibility:+-- See Note [Deterministic SCC]+-- See Note [reduceNodesIntoVertices implementations]+stronglyConnCompFromEdgedVerticesUniq+        :: Uniquable key+        => [Node key payload]+        -> [SCC payload]+stronglyConnCompFromEdgedVerticesUniq+  = map (fmap get_node) . stronglyConnCompFromEdgedVerticesUniqR+  where get_node (n, _, _) = n++-- The "R" interface is used when you expect to apply SCC to+-- (some of) the result of SCC, so you dont want to lose the dependency info+-- See Note [Deterministic SCC]+-- See Note [reduceNodesIntoVertices implementations]+stronglyConnCompFromEdgedVerticesOrdR+        :: Ord key+        => [Node key payload]+        -> [SCC (Node key payload)]+stronglyConnCompFromEdgedVerticesOrdR =+  stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesOrd++-- The "R" interface is used when you expect to apply SCC to+-- (some of) the result of SCC, so you dont want to lose the dependency info+-- See Note [Deterministic SCC]+-- See Note [reduceNodesIntoVertices implementations]+stronglyConnCompFromEdgedVerticesUniqR+        :: Uniquable key+        => [Node key payload]+        -> [SCC (Node key payload)]+stronglyConnCompFromEdgedVerticesUniqR =+  stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesUniq++{-+************************************************************************+*                                                                      *+*      Misc wrappers for Graph+*                                                                      *+************************************************************************+-}++topologicalSortG :: Graph node -> [node]+topologicalSortG graph = map (gr_vertex_to_node graph) result+  where result = {-# SCC "Digraph.topSort" #-} topSort (gr_int_graph graph)++dfsTopSortG :: Graph node -> [[node]]+dfsTopSortG graph =+  map (map (gr_vertex_to_node graph) . flatten) $ dfs g (topSort g)+  where+    g = gr_int_graph graph++reachableG :: Graph node -> node -> [node]+reachableG graph from = map (gr_vertex_to_node graph) result+  where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from)+        result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) [from_vertex]++reachablesG :: Graph node -> [node] -> [node]+reachablesG graph froms = map (gr_vertex_to_node graph) result+  where result = {-# SCC "Digraph.reachable" #-}+                 reachable (gr_int_graph graph) vs+        vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ]++hasVertexG :: Graph node -> node -> Bool+hasVertexG graph node = isJust $ gr_node_to_vertex graph node++verticesG :: Graph node -> [node]+verticesG graph = map (gr_vertex_to_node graph) $ vertices (gr_int_graph graph)++edgesG :: Graph node -> [Edge node]+edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ edges (gr_int_graph graph)+  where v2n = gr_vertex_to_node graph++transposeG :: Graph node -> Graph node+transposeG graph = Graph (G.transposeG (gr_int_graph graph))+                         (gr_vertex_to_node graph)+                         (gr_node_to_vertex graph)++outdegreeG :: Graph node -> node -> Maybe Int+outdegreeG = degreeG outdegree++indegreeG :: Graph node -> node -> Maybe Int+indegreeG = degreeG indegree++degreeG :: (G.Graph -> Table Int) -> Graph node -> node -> Maybe Int+degreeG degree graph node = let table = degree (gr_int_graph graph)+                            in fmap ((!) table) $ gr_node_to_vertex graph node++vertexGroupsG :: Graph node -> [[node]]+vertexGroupsG graph = map (map (gr_vertex_to_node graph)) result+  where result = vertexGroups (gr_int_graph graph)++emptyG :: Graph node -> Bool+emptyG g = graphEmpty (gr_int_graph g)++componentsG :: Graph node -> [[node]]+componentsG graph = map (map (gr_vertex_to_node graph) . flatten)+                  $ components (gr_int_graph graph)++{-+************************************************************************+*                                                                      *+*      Showing Graphs+*                                                                      *+************************************************************************+-}++instance Outputable node => Outputable (Graph node) where+    ppr graph = vcat [+                  hang (text "Vertices:") 2 (vcat (map ppr $ verticesG graph)),+                  hang (text "Edges:") 2 (vcat (map ppr $ edgesG graph))+                ]++instance Outputable node => Outputable (Edge node) where+    ppr (Edge from to) = ppr from <+> text "->" <+> ppr to++graphEmpty :: G.Graph -> Bool+graphEmpty g = lo > hi+  where (lo, hi) = bounds g++{-+************************************************************************+*                                                                      *+*      IntGraphs+*                                                                      *+************************************************************************+-}++type IntGraph = G.Graph++{-+------------------------------------------------------------+-- Depth first search numbering+------------------------------------------------------------+-}++-- Data.Tree has flatten for Tree, but nothing for Forest+preorderF           :: Forest a -> [a]+preorderF ts         = concat (map flatten ts)++{-+------------------------------------------------------------+-- Finding reachable vertices+------------------------------------------------------------+-}++-- This generalizes reachable which was found in Data.Graph+reachable    :: IntGraph -> [Vertex] -> [Vertex]+reachable g vs = preorderF (dfs g vs)++{-+------------------------------------------------------------+-- Total ordering on groups of vertices+------------------------------------------------------------++The plan here is to extract a list of groups of elements of the graph+such that each group has no dependence except on nodes in previous+groups (i.e. in particular they may not depend on nodes in their own+group) and is maximal such group.++Clearly we cannot provide a solution for cyclic graphs.++We proceed by iteratively removing elements with no outgoing edges+and their associated edges from the graph.++This probably isn't very efficient and certainly isn't very clever.+-}++type Set s    = STArray s Vertex Bool++mkEmpty      :: Bounds -> ST s (Set s)+mkEmpty bnds  = newArray bnds False++contains     :: Set s -> Vertex -> ST s Bool+contains m v  = readArray m v++include      :: Set s -> Vertex -> ST s ()+include m v   = writeArray m v True++vertexGroups :: IntGraph -> [[Vertex]]+vertexGroups g = runST (mkEmpty (bounds g) >>= \provided -> vertexGroupsS provided g next_vertices)+  where next_vertices = noOutEdges g++noOutEdges :: IntGraph -> [Vertex]+noOutEdges g = [ v | v <- vertices g, null (g!v)]++vertexGroupsS :: Set s -> IntGraph -> [Vertex] -> ST s [[Vertex]]+vertexGroupsS provided g to_provide+  = if null to_provide+    then do {+          all_provided <- allM (provided `contains`) (vertices g)+        ; if all_provided+          then return []+          else error "vertexGroup: cyclic graph"+        }+    else do {+          mapM_ (include provided) to_provide+        ; to_provide' <- filterM (vertexReady provided g) (vertices g)+        ; rest <- vertexGroupsS provided g to_provide'+        ; return $ to_provide : rest+        }++vertexReady :: Set s -> IntGraph -> Vertex -> ST s Bool+vertexReady provided g v = liftM2 (&&) (liftM not $ provided `contains` v) (allM (provided `contains`) (g!v))
+ utils/Encoding.hs view
@@ -0,0 +1,448 @@+{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}+{-# OPTIONS_GHC -O #-}+-- We always optimise this, otherwise performance of a non-optimised+-- compiler is severely affected++-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow, 1997-2006+--+-- Character encodings+--+-- -----------------------------------------------------------------------------++module Encoding (+        -- * UTF-8+        utf8DecodeChar#,+        utf8PrevChar,+        utf8CharStart,+        utf8DecodeChar,+        utf8DecodeByteString,+        utf8DecodeStringLazy,+        utf8EncodeChar,+        utf8EncodeString,+        utf8EncodedLength,+        countUTF8Chars,++        -- * Z-encoding+        zEncodeString,+        zDecodeString,++        -- * Base62-encoding+        toBase62,+        toBase62Padded+  ) where++import Foreign+import Foreign.ForeignPtr.Unsafe+import Data.Char+import qualified Data.Char as Char+import Numeric+import GHC.IO++import Data.ByteString (ByteString)+import qualified Data.ByteString.Internal as BS++import GHC.Exts++-- -----------------------------------------------------------------------------+-- UTF-8++-- We can't write the decoder as efficiently as we'd like without+-- resorting to unboxed extensions, unfortunately.  I tried to write+-- an IO version of this function, but GHC can't eliminate boxed+-- results from an IO-returning function.+--+-- We assume we can ignore overflow when parsing a multibyte character here.+-- To make this safe, we add extra sentinel bytes to unparsed UTF-8 sequences+-- before decoding them (see StringBuffer.hs).++{-# INLINE utf8DecodeChar# #-}+utf8DecodeChar# :: Addr# -> (# Char#, Int# #)+utf8DecodeChar# a# =+  let !ch0 = word2Int# (indexWord8OffAddr# a# 0#) in+  case () of+    _ | isTrue# (ch0 <=# 0x7F#) -> (# chr# ch0, 1# #)++      | isTrue# ((ch0 >=# 0xC0#) `andI#` (ch0 <=# 0xDF#)) ->+        let !ch1 = word2Int# (indexWord8OffAddr# a# 1#) in+        if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else+        (# chr# (((ch0 -# 0xC0#) `uncheckedIShiftL#` 6#) +#+                  (ch1 -# 0x80#)),+           2# #)++      | isTrue# ((ch0 >=# 0xE0#) `andI#` (ch0 <=# 0xEF#)) ->+        let !ch1 = word2Int# (indexWord8OffAddr# a# 1#) in+        if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else+        let !ch2 = word2Int# (indexWord8OffAddr# a# 2#) in+        if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else+        (# chr# (((ch0 -# 0xE0#) `uncheckedIShiftL#` 12#) +#+                 ((ch1 -# 0x80#) `uncheckedIShiftL#` 6#)  +#+                  (ch2 -# 0x80#)),+           3# #)++     | isTrue# ((ch0 >=# 0xF0#) `andI#` (ch0 <=# 0xF8#)) ->+        let !ch1 = word2Int# (indexWord8OffAddr# a# 1#) in+        if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else+        let !ch2 = word2Int# (indexWord8OffAddr# a# 2#) in+        if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else+        let !ch3 = word2Int# (indexWord8OffAddr# a# 3#) in+        if isTrue# ((ch3 <# 0x80#) `orI#` (ch3 >=# 0xC0#)) then fail 3# else+        (# chr# (((ch0 -# 0xF0#) `uncheckedIShiftL#` 18#) +#+                 ((ch1 -# 0x80#) `uncheckedIShiftL#` 12#) +#+                 ((ch2 -# 0x80#) `uncheckedIShiftL#` 6#)  +#+                  (ch3 -# 0x80#)),+           4# #)++      | otherwise -> fail 1#+  where+        -- all invalid sequences end up here:+        fail :: Int# -> (# Char#, Int# #)+        fail nBytes# = (# '\0'#, nBytes# #)+        -- '\xFFFD' would be the usual replacement character, but+        -- that's a valid symbol in Haskell, so will result in a+        -- confusing parse error later on.  Instead we use '\0' which+        -- will signal a lexer error immediately.++utf8DecodeChar :: Ptr Word8 -> (Char, Int)+utf8DecodeChar (Ptr a#) =+  case utf8DecodeChar# a# of (# c#, nBytes# #) -> ( C# c#, I# nBytes# )++-- UTF-8 is cleverly designed so that we can always figure out where+-- the start of the current character is, given any position in a+-- stream.  This function finds the start of the previous character,+-- assuming there *is* a previous character.+utf8PrevChar :: Ptr Word8 -> IO (Ptr Word8)+utf8PrevChar p = utf8CharStart (p `plusPtr` (-1))++utf8CharStart :: Ptr Word8 -> IO (Ptr Word8)+utf8CharStart p = go p+ where go p = do w <- peek p+                 if w >= 0x80 && w < 0xC0+                        then go (p `plusPtr` (-1))+                        else return p++utf8DecodeByteString :: ByteString -> [Char]+utf8DecodeByteString (BS.PS ptr offset len)+  = utf8DecodeStringLazy ptr offset len++utf8DecodeStringLazy :: ForeignPtr Word8 -> Int -> Int -> [Char]+utf8DecodeStringLazy fptr offset len+  = unsafeDupablePerformIO $ unpack start+  where+    !start = unsafeForeignPtrToPtr fptr `plusPtr` offset+    !end = start `plusPtr` len++    unpack p+        | p >= end  = touchForeignPtr fptr >> return []+        | otherwise =+            case utf8DecodeChar# (unPtr p) of+                (# c#, nBytes# #) -> do+                  rest <- unsafeDupableInterleaveIO $ unpack (p `plusPtr#` nBytes#)+                  return (C# c# : rest)++countUTF8Chars :: Ptr Word8 -> Int -> IO Int+countUTF8Chars ptr len = go ptr 0+  where+        !end = ptr `plusPtr` len++        go p !n+           | p >= end = return n+           | otherwise  = do+                case utf8DecodeChar# (unPtr p) of+                  (# _, nBytes# #) -> go (p `plusPtr#` nBytes#) (n+1)++unPtr :: Ptr a -> Addr#+unPtr (Ptr a) = a++plusPtr# :: Ptr a -> Int# -> Ptr a+plusPtr# ptr nBytes# = ptr `plusPtr` (I# nBytes#)++utf8EncodeChar :: Char -> Ptr Word8 -> IO (Ptr Word8)+utf8EncodeChar c ptr =+  let x = ord c in+  case () of+    _ | x > 0 && x <= 0x007f -> do+          poke ptr (fromIntegral x)+          return (ptr `plusPtr` 1)+        -- NB. '\0' is encoded as '\xC0\x80', not '\0'.  This is so that we+        -- can have 0-terminated UTF-8 strings (see GHC.Base.unpackCStringUtf8).+      | x <= 0x07ff -> do+          poke ptr (fromIntegral (0xC0 .|. ((x `shiftR` 6) .&. 0x1F)))+          pokeElemOff ptr 1 (fromIntegral (0x80 .|. (x .&. 0x3F)))+          return (ptr `plusPtr` 2)+      | x <= 0xffff -> do+          poke ptr (fromIntegral (0xE0 .|. (x `shiftR` 12) .&. 0x0F))+          pokeElemOff ptr 1 (fromIntegral (0x80 .|. (x `shiftR` 6) .&. 0x3F))+          pokeElemOff ptr 2 (fromIntegral (0x80 .|. (x .&. 0x3F)))+          return (ptr `plusPtr` 3)+      | otherwise -> do+          poke ptr (fromIntegral (0xF0 .|. (x `shiftR` 18)))+          pokeElemOff ptr 1 (fromIntegral (0x80 .|. ((x `shiftR` 12) .&. 0x3F)))+          pokeElemOff ptr 2 (fromIntegral (0x80 .|. ((x `shiftR` 6) .&. 0x3F)))+          pokeElemOff ptr 3 (fromIntegral (0x80 .|. (x .&. 0x3F)))+          return (ptr `plusPtr` 4)++utf8EncodeString :: Ptr Word8 -> String -> IO ()+utf8EncodeString ptr str = go ptr str+  where go !_   []     = return ()+        go ptr (c:cs) = do+          ptr' <- utf8EncodeChar c ptr+          go ptr' cs++utf8EncodedLength :: String -> Int+utf8EncodedLength str = go 0 str+  where go !n [] = n+        go n (c:cs)+          | ord c > 0 && ord c <= 0x007f = go (n+1) cs+          | ord c <= 0x07ff = go (n+2) cs+          | ord c <= 0xffff = go (n+3) cs+          | otherwise       = go (n+4) cs++-- -----------------------------------------------------------------------------+-- The Z-encoding++{-+This is the main name-encoding and decoding function.  It encodes any+string into a string that is acceptable as a C name.  This is done+right before we emit a symbol name into the compiled C or asm code.+Z-encoding of strings is cached in the FastString interface, so we+never encode the same string more than once.++The basic encoding scheme is this.++* Tuples (,,,) are coded as Z3T++* Alphabetic characters (upper and lower) and digits+        all translate to themselves;+        except 'Z', which translates to 'ZZ'+        and    'z', which translates to 'zz'+  We need both so that we can preserve the variable/tycon distinction++* Most other printable characters translate to 'zx' or 'Zx' for some+        alphabetic character x++* The others translate as 'znnnU' where 'nnn' is the decimal number+        of the character++        Before          After+        --------------------------+        Trak            Trak+        foo_wib         foozuwib+        >               zg+        >1              zg1+        foo#            foozh+        foo##           foozhzh+        foo##1          foozhzh1+        fooZ            fooZZ+        :+              ZCzp+        ()              Z0T     0-tuple+        (,,,,)          Z5T     5-tuple+        (# #)           Z1H     unboxed 1-tuple (note the space)+        (#,,,,#)        Z5H     unboxed 5-tuple+                (NB: There is no Z1T nor Z0H.)+-}++type UserString = String        -- As the user typed it+type EncodedString = String     -- Encoded form+++zEncodeString :: UserString -> EncodedString+zEncodeString cs = case maybe_tuple cs of+                Just n  -> n            -- Tuples go to Z2T etc+                Nothing -> go cs+          where+                go []     = []+                go (c:cs) = encode_digit_ch c ++ go' cs+                go' []     = []+                go' (c:cs) = encode_ch c ++ go' cs++unencodedChar :: Char -> Bool   -- True for chars that don't need encoding+unencodedChar 'Z' = False+unencodedChar 'z' = False+unencodedChar c   =  c >= 'a' && c <= 'z'+                  || c >= 'A' && c <= 'Z'+                  || c >= '0' && c <= '9'++-- If a digit is at the start of a symbol then we need to encode it.+-- Otherwise package names like 9pH-0.1 give linker errors.+encode_digit_ch :: Char -> EncodedString+encode_digit_ch c | c >= '0' && c <= '9' = encode_as_unicode_char c+encode_digit_ch c | otherwise            = encode_ch c++encode_ch :: Char -> EncodedString+encode_ch c | unencodedChar c = [c]     -- Common case first++-- Constructors+encode_ch '('  = "ZL"   -- Needed for things like (,), and (->)+encode_ch ')'  = "ZR"   -- For symmetry with (+encode_ch '['  = "ZM"+encode_ch ']'  = "ZN"+encode_ch ':'  = "ZC"+encode_ch 'Z'  = "ZZ"++-- Variables+encode_ch 'z'  = "zz"+encode_ch '&'  = "za"+encode_ch '|'  = "zb"+encode_ch '^'  = "zc"+encode_ch '$'  = "zd"+encode_ch '='  = "ze"+encode_ch '>'  = "zg"+encode_ch '#'  = "zh"+encode_ch '.'  = "zi"+encode_ch '<'  = "zl"+encode_ch '-'  = "zm"+encode_ch '!'  = "zn"+encode_ch '+'  = "zp"+encode_ch '\'' = "zq"+encode_ch '\\' = "zr"+encode_ch '/'  = "zs"+encode_ch '*'  = "zt"+encode_ch '_'  = "zu"+encode_ch '%'  = "zv"+encode_ch c    = encode_as_unicode_char c++encode_as_unicode_char :: Char -> EncodedString+encode_as_unicode_char c = 'z' : if isDigit (head hex_str) then hex_str+                                                           else '0':hex_str+  where hex_str = showHex (ord c) "U"+  -- ToDo: we could improve the encoding here in various ways.+  -- eg. strings of unicode characters come out as 'z1234Uz5678U', we+  -- could remove the 'U' in the middle (the 'z' works as a separator).++zDecodeString :: EncodedString -> UserString+zDecodeString [] = []+zDecodeString ('Z' : d : rest)+  | isDigit d = decode_tuple   d rest+  | otherwise = decode_upper   d : zDecodeString rest+zDecodeString ('z' : d : rest)+  | isDigit d = decode_num_esc d rest+  | otherwise = decode_lower   d : zDecodeString rest+zDecodeString (c   : rest) = c : zDecodeString rest++decode_upper, decode_lower :: Char -> Char++decode_upper 'L' = '('+decode_upper 'R' = ')'+decode_upper 'M' = '['+decode_upper 'N' = ']'+decode_upper 'C' = ':'+decode_upper 'Z' = 'Z'+decode_upper ch  = {-pprTrace "decode_upper" (char ch)-} ch++decode_lower 'z' = 'z'+decode_lower 'a' = '&'+decode_lower 'b' = '|'+decode_lower 'c' = '^'+decode_lower 'd' = '$'+decode_lower 'e' = '='+decode_lower 'g' = '>'+decode_lower 'h' = '#'+decode_lower 'i' = '.'+decode_lower 'l' = '<'+decode_lower 'm' = '-'+decode_lower 'n' = '!'+decode_lower 'p' = '+'+decode_lower 'q' = '\''+decode_lower 'r' = '\\'+decode_lower 's' = '/'+decode_lower 't' = '*'+decode_lower 'u' = '_'+decode_lower 'v' = '%'+decode_lower ch  = {-pprTrace "decode_lower" (char ch)-} ch++-- Characters not having a specific code are coded as z224U (in hex)+decode_num_esc :: Char -> EncodedString -> UserString+decode_num_esc d rest+  = go (digitToInt d) rest+  where+    go n (c : rest) | isHexDigit c = go (16*n + digitToInt c) rest+    go n ('U' : rest)           = chr n : zDecodeString rest+    go n other = error ("decode_num_esc: " ++ show n ++  ' ':other)++decode_tuple :: Char -> EncodedString -> UserString+decode_tuple d rest+  = go (digitToInt d) rest+  where+        -- NB. recurse back to zDecodeString after decoding the tuple, because+        -- the tuple might be embedded in a longer name.+    go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest+    go 0 ('T':rest)     = "()" ++ zDecodeString rest+    go n ('T':rest)     = '(' : replicate (n-1) ',' ++ ")" ++ zDecodeString rest+    go 1 ('H':rest)     = "(# #)" ++ zDecodeString rest+    go n ('H':rest)     = '(' : '#' : replicate (n-1) ',' ++ "#)" ++ zDecodeString rest+    go n other = error ("decode_tuple: " ++ show n ++ ' ':other)++{-+Tuples are encoded as+        Z3T or Z3H+for 3-tuples or unboxed 3-tuples respectively.  No other encoding starts+        Z<digit>++* "(# #)" is the tycon for an unboxed 1-tuple (not 0-tuple)+  There are no unboxed 0-tuples.++* "()" is the tycon for a boxed 0-tuple.+  There are no boxed 1-tuples.+-}++maybe_tuple :: UserString -> Maybe EncodedString++maybe_tuple "(# #)" = Just("Z1H")+maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of+                                 (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H")+                                 _                  -> Nothing+maybe_tuple "()" = Just("Z0T")+maybe_tuple ('(' : cs)       = case count_commas (0::Int) cs of+                                 (n, ')' : _) -> Just ('Z' : shows (n+1) "T")+                                 _            -> Nothing+maybe_tuple _                = Nothing++count_commas :: Int -> String -> (Int, String)+count_commas n (',' : cs) = count_commas (n+1) cs+count_commas n cs         = (n,cs)+++{-+************************************************************************+*                                                                      *+                        Base 62+*                                                                      *+************************************************************************++Note [Base 62 encoding 128-bit integers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Instead of base-62 encoding a single 128-bit integer+(ceil(21.49) characters), we'll base-62 a pair of 64-bit integers+(2 * ceil(10.75) characters).  Luckily for us, it's the same number of+characters!+-}++--------------------------------------------------------------------------+-- Base 62++-- The base-62 code is based off of 'locators'+-- ((c) Operational Dynamics Consulting, BSD3 licensed)++-- | Size of a 64-bit word when written as a base-62 string+word64Base62Len :: Int+word64Base62Len = 11++-- | Converts a 64-bit word into a base-62 string+toBase62Padded :: Word64 -> String+toBase62Padded w = pad ++ str+  where+    pad = replicate len '0'+    len = word64Base62Len - length str -- 11 == ceil(64 / lg 62)+    str = toBase62 w++toBase62 :: Word64 -> String+toBase62 w = showIntAtBase 62 represent w ""+  where+    represent :: Int -> Char+    represent x+        | x < 10 = Char.chr (48 + x)+        | x < 36 = Char.chr (65 + x - 10)+        | x < 62 = Char.chr (97 + x - 36)+        | otherwise = error "represent (base 62): impossible!"
+ utils/Exception.hs view
@@ -0,0 +1,81 @@+{-# OPTIONS_GHC -fno-warn-deprecations #-}+module Exception+    (+    module Control.Exception,+    module Exception+    )+    where++import Control.Exception+import Control.Monad.IO.Class++catchIO :: IO a -> (IOException -> IO a) -> IO a+catchIO = Control.Exception.catch++handleIO :: (IOException -> IO a) -> IO a -> IO a+handleIO = flip catchIO++tryIO :: IO a -> IO (Either IOException a)+tryIO = try++-- | A monad that can catch exceptions.  A minimal definition+-- requires a definition of 'gcatch'.+--+-- Implementations on top of 'IO' should implement 'gmask' to+-- eventually call the primitive 'Control.Exception.mask'.+-- These are used for+-- implementations that support asynchronous exceptions.  The default+-- implementations of 'gbracket' and 'gfinally' use 'gmask'+-- thus rarely require overriding.+--+class MonadIO m => ExceptionMonad m where++  -- | Generalised version of 'Control.Exception.catch', allowing an arbitrary+  -- exception handling monad instead of just 'IO'.+  gcatch :: Exception e => m a -> (e -> m a) -> m a++  -- | Generalised version of 'Control.Exception.mask_', allowing an arbitrary+  -- exception handling monad instead of just 'IO'.+  gmask :: ((m a -> m a) -> m b) -> m b++  -- | Generalised version of 'Control.Exception.bracket', allowing an arbitrary+  -- exception handling monad instead of just 'IO'.+  gbracket :: m a -> (a -> m b) -> (a -> m c) -> m c++  -- | Generalised version of 'Control.Exception.finally', allowing an arbitrary+  -- exception handling monad instead of just 'IO'.+  gfinally :: m a -> m b -> m a++  gbracket before after thing =+    gmask $ \restore -> do+      a <- before+      r <- restore (thing a) `gonException` after a+      _ <- after a+      return r++  a `gfinally` sequel =+    gmask $ \restore -> do+      r <- restore a `gonException` sequel+      _ <- sequel+      return r++instance ExceptionMonad IO where+  gcatch    = Control.Exception.catch+  gmask f   = mask (\x -> f x)++gtry :: (ExceptionMonad m, Exception e) => m a -> m (Either e a)+gtry act = gcatch (act >>= \a -> return (Right a))+                  (\e -> return (Left e))++-- | Generalised version of 'Control.Exception.handle', allowing an arbitrary+-- exception handling monad instead of just 'IO'.+ghandle :: (ExceptionMonad m, Exception e) => (e -> m a) -> m a -> m a+ghandle = flip gcatch++-- | Always executes the first argument.  If this throws an exception the+-- second argument is executed and the exception is raised again.+gonException :: (ExceptionMonad m) => m a -> m b -> m a+gonException ioA cleanup = ioA `gcatch` \e ->+                             do _ <- cleanup+                                liftIO $ throwIO (e :: SomeException)+
+ utils/FV.hs view
@@ -0,0 +1,199 @@+{-+(c) Bartosz Nitka, Facebook 2015++Utilities for efficiently and deterministically computing free variables.++-}++{-# LANGUAGE BangPatterns #-}++module FV (+        -- * Deterministic free vars computations+        FV, InterestingVarFun,++        -- * Running the computations+        fvVarListVarSet, fvVarList, fvVarSet, fvDVarSet,++        -- ** Manipulating those computations+        unitFV,+        emptyFV,+        mkFVs,+        unionFV,+        unionsFV,+        delFV,+        delFVs,+        filterFV,+        mapUnionFV,+    ) where++import Var+import VarSet++-- | Predicate on possible free variables: returns @True@ iff the variable is+-- interesting+type InterestingVarFun = Var -> Bool++-- Note [Deterministic FV]+-- ~~~~~~~~~~~~~~~~~~~~~~~+-- When computing free variables, the order in which you get them affects+-- the results of floating and specialization. If you use UniqFM to collect+-- them and then turn that into a list, you get them in nondeterministic+-- order as described in Note [Deterministic UniqFM] in UniqDFM.++-- A naive algorithm for free variables relies on merging sets of variables.+-- Merging costs O(n+m) for UniqFM and for UniqDFM there's an additional log+-- factor. It's cheaper to incrementally add to a list and use a set to check+-- for duplicates.+type FV = InterestingVarFun+             -- Used for filtering sets as we build them+          -> VarSet+             -- Locally bound variables+          -> ([Var], VarSet)+             -- List to preserve ordering and set to check for membership,+             -- so that the list doesn't have duplicates+             -- For explanation of why using `VarSet` is not deterministic see+             -- Note [Deterministic UniqFM] in UniqDFM.+          -> ([Var], VarSet)++-- Note [FV naming conventions]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- To get the performance and determinism that FV provides, FV computations+-- need to built up from smaller FV computations and then evaluated with+-- one of `fvVarList`, `fvDVarSet`, `fvVarListVarSet`. That means the functions+-- returning FV need to be exported.+--+-- The conventions are:+--+-- a) non-deterministic functions:+--   * a function that returns VarSet+--       e.g. `tyVarsOfType`+-- b) deterministic functions:+--   * a worker that returns FV+--       e.g. `tyFVsOfType`+--   * a function that returns [Var]+--       e.g. `tyVarsOfTypeList`+--   * a function that returns DVarSet+--       e.g. `tyVarsOfTypeDSet`+--+-- Where tyVarsOfType, tyVarsOfTypeList, tyVarsOfTypeDSet are implemented+-- in terms of the worker evaluated with fvVarSet, fvVarList, fvDVarSet+-- respectively.++-- | Run a free variable computation, returning a list of distinct free+-- variables in deterministic order and a non-deterministic set containing+-- those variables.+fvVarListVarSet :: FV ->  ([Var], VarSet)+fvVarListVarSet fv = fv (const True) emptyVarSet ([], emptyVarSet)++-- | Run a free variable computation, returning a list of distinct free+-- variables in deterministic order.+fvVarList :: FV -> [Var]+fvVarList = fst . fvVarListVarSet++-- | Run a free variable computation, returning a deterministic set of free+-- variables. Note that this is just a wrapper around the version that+-- returns a deterministic list. If you need a list you should use+-- `fvVarList`.+fvDVarSet :: FV -> DVarSet+fvDVarSet = mkDVarSet . fst . fvVarListVarSet++-- | Run a free variable computation, returning a non-deterministic set of+-- free variables. Don't use if the set will be later converted to a list+-- and the order of that list will impact the generated code.+fvVarSet :: FV -> VarSet+fvVarSet = snd . fvVarListVarSet++-- Note [FV eta expansion]+-- ~~~~~~~~~~~~~~~~~~~~~~~+-- Let's consider an eta-reduced implementation of freeVarsOf using FV:+--+-- freeVarsOf (App a b) = freeVarsOf a `unionFV` freeVarsOf b+--+-- If GHC doesn't eta-expand it, after inlining unionFV we end up with+--+-- freeVarsOf = \x ->+--   case x of+--     App a b -> \fv_cand in_scope acc ->+--       freeVarsOf a fv_cand in_scope $! freeVarsOf b fv_cand in_scope $! acc+--+-- which has to create a thunk, resulting in more allocations.+--+-- On the other hand if it is eta-expanded:+--+-- freeVarsOf (App a b) fv_cand in_scope acc =+--   (freeVarsOf a `unionFV` freeVarsOf b) fv_cand in_scope acc+--+-- after inlining unionFV we have:+--+-- freeVarsOf = \x fv_cand in_scope acc ->+--   case x of+--     App a b ->+--       freeVarsOf a fv_cand in_scope $! freeVarsOf b fv_cand in_scope $! acc+--+-- which saves allocations.+--+-- GHC when presented with knowledge about all the call sites, correctly+-- eta-expands in this case. Unfortunately due to the fact that freeVarsOf gets+-- exported to be composed with other functions, GHC doesn't have that+-- information and has to be more conservative here.+--+-- Hence functions that get exported and return FV need to be manually+-- eta-expanded. See also #11146.++-- | Add a variable - when free, to the returned free variables.+-- Ignores duplicates and respects the filtering function.+unitFV :: Id -> FV+unitFV var fv_cand in_scope acc@(have, haveSet)+  | var `elemVarSet` in_scope = acc+  | var `elemVarSet` haveSet = acc+  | fv_cand var = (var:have, extendVarSet haveSet var)+  | otherwise = acc+{-# INLINE unitFV #-}++-- | Return no free variables.+emptyFV :: FV+emptyFV _ _ acc = acc+{-# INLINE emptyFV #-}++-- | Union two free variable computations.+unionFV :: FV -> FV -> FV+unionFV fv1 fv2 fv_cand in_scope acc =+  fv1 fv_cand in_scope $! fv2 fv_cand in_scope $! acc+{-# INLINE unionFV #-}++-- | Mark the variable as not free by putting it in scope.+delFV :: Var -> FV -> FV+delFV var fv fv_cand !in_scope acc =+  fv fv_cand (extendVarSet in_scope var) acc+{-# INLINE delFV #-}++-- | Mark many free variables as not free.+delFVs :: VarSet -> FV -> FV+delFVs vars fv fv_cand !in_scope acc =+  fv fv_cand (in_scope `unionVarSet` vars) acc+{-# INLINE delFVs #-}++-- | Filter a free variable computation.+filterFV :: InterestingVarFun -> FV -> FV+filterFV fv_cand2 fv fv_cand1 in_scope acc =+  fv (\v -> fv_cand1 v && fv_cand2 v) in_scope acc+{-# INLINE filterFV #-}++-- | Map a free variable computation over a list and union the results.+mapUnionFV :: (a -> FV) -> [a] -> FV+mapUnionFV _f [] _fv_cand _in_scope acc = acc+mapUnionFV f (a:as) fv_cand in_scope acc =+  mapUnionFV f as fv_cand in_scope $! f a fv_cand in_scope $! acc+{-# INLINABLE mapUnionFV #-}++-- | Union many free variable computations.+unionsFV :: [FV] -> FV+unionsFV fvs fv_cand in_scope acc = mapUnionFV id fvs fv_cand in_scope acc+{-# INLINE unionsFV #-}++-- | Add multiple variables - when free, to the returned free variables.+-- Ignores duplicates and respects the filtering function.+mkFVs :: [Var] -> FV+mkFVs vars fv_cand in_scope acc =+  mapUnionFV unitFV vars fv_cand in_scope acc+{-# INLINE mkFVs #-}
+ utils/FastFunctions.hs view
@@ -0,0 +1,19 @@+{-+(c) The University of Glasgow, 2000-2006+-}++{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}++module FastFunctions (+    inlinePerformIO,+  ) where++#include "HsVersions.h"++import GHC.Exts+import GHC.IO   (IO(..))++-- Just like unsafePerformIO, but we inline it.+{-# INLINE inlinePerformIO #-}+inlinePerformIO :: IO a -> a+inlinePerformIO (IO m) = case m realWorld# of (# _, r #)   -> r
+ utils/FastMutInt.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}+{-# OPTIONS_GHC -O #-}+-- We always optimise this, otherwise performance of a non-optimised+-- compiler is severely affected+--+-- (c) The University of Glasgow 2002-2006+--+-- Unboxed mutable Ints++module FastMutInt(+        FastMutInt, newFastMutInt,+        readFastMutInt, writeFastMutInt,++        FastMutPtr, newFastMutPtr,+        readFastMutPtr, writeFastMutPtr+  ) where++import Data.Bits+import GHC.Base+import GHC.Ptr++newFastMutInt :: IO FastMutInt+readFastMutInt :: FastMutInt -> IO Int+writeFastMutInt :: FastMutInt -> Int -> IO ()++newFastMutPtr :: IO FastMutPtr+readFastMutPtr :: FastMutPtr -> IO (Ptr a)+writeFastMutPtr :: FastMutPtr -> Ptr a -> IO ()++data FastMutInt = FastMutInt (MutableByteArray# RealWorld)++newFastMutInt = IO $ \s ->+  case newByteArray# size s of { (# s, arr #) ->+  (# s, FastMutInt arr #) }+  where !(I# size) = finiteBitSize (0 :: Int)++readFastMutInt (FastMutInt arr) = IO $ \s ->+  case readIntArray# arr 0# s of { (# s, i #) ->+  (# s, I# i #) }++writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s ->+  case writeIntArray# arr 0# i s of { s ->+  (# s, () #) }++data FastMutPtr = FastMutPtr (MutableByteArray# RealWorld)++newFastMutPtr = IO $ \s ->+  case newByteArray# size s of { (# s, arr #) ->+  (# s, FastMutPtr arr #) }+  -- GHC assumes 'sizeof (Int) == sizeof (Ptr a)'+  where !(I# size) = finiteBitSize (0 :: Int)++readFastMutPtr (FastMutPtr arr) = IO $ \s ->+  case readAddrArray# arr 0# s of { (# s, i #) ->+  (# s, Ptr i #) }++writeFastMutPtr (FastMutPtr arr) (Ptr i) = IO $ \s ->+  case writeAddrArray# arr 0# i s of { s ->+  (# s, () #) }
+ utils/FastString.hs view
@@ -0,0 +1,620 @@+-- (c) The University of Glasgow, 1997-2006++{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples,+    GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -O -funbox-strict-fields #-}+-- We always optimise this, otherwise performance of a non-optimised+-- compiler is severely affected++-- |+-- There are two principal string types used internally by GHC:+--+-- ['FastString']+--+--   * A compact, hash-consed, representation of character strings.+--   * Comparison is O(1), and you can get a 'Unique.Unique' from them.+--   * Generated by 'fsLit'.+--   * Turn into 'Outputable.SDoc' with 'Outputable.ftext'.+--+-- ['LitString']+--+--   * Just a wrapper for the @Addr#@ of a C string (@Ptr CChar@).+--   * Practically no operations.+--   * Outputing them is fast.+--   * Generated by 'sLit'.+--   * Turn into 'Outputable.SDoc' with 'Outputable.ptext'+--   * Requires manual memory management.+--     Improper use may lead to memory leaks or dangling pointers.+--   * It assumes Latin-1 as the encoding, therefore it cannot represent+--     arbitrary Unicode strings.+--+-- Use 'LitString' unless you want the facilities of 'FastString'.+module FastString+       (+        -- * ByteString+        fastStringToByteString,+        mkFastStringByteString,+        fastZStringToByteString,+        unsafeMkByteString,+        hashByteString,++        -- * FastZString+        FastZString,+        hPutFZS,+        zString,+        lengthFZS,++        -- * FastStrings+        FastString(..),     -- not abstract, for now.++        -- ** Construction+        fsLit,+        mkFastString,+        mkFastStringBytes,+        mkFastStringByteList,+        mkFastStringForeignPtr,+        mkFastString#,++        -- ** Deconstruction+        unpackFS,           -- :: FastString -> String+        bytesFS,            -- :: FastString -> [Word8]++        -- ** Encoding+        zEncodeFS,++        -- ** Operations+        uniqueOfFS,+        lengthFS,+        nullFS,+        appendFS,+        headFS,+        tailFS,+        concatFS,+        consFS,+        nilFS,++        -- ** Outputing+        hPutFS,++        -- ** Internal+        getFastStringTable,+        hasZEncoding,++        -- * LitStrings+        LitString,++        -- ** Construction+        sLit,+        mkLitString#,+        mkLitString,++        -- ** Deconstruction+        unpackLitString,++        -- ** Operations+        lengthLS+       ) where++#include "HsVersions.h"++import Encoding+import FastFunctions+import Panic+import Util++import Control.DeepSeq+import Control.Monad+import Data.ByteString (ByteString)+import qualified Data.ByteString          as BS+import qualified Data.ByteString.Char8    as BSC+import qualified Data.ByteString.Internal as BS+import qualified Data.ByteString.Unsafe   as BS+import Foreign.C+import GHC.Exts+import System.IO+import System.IO.Unsafe ( unsafePerformIO )+import Data.Data+import Data.IORef       ( IORef, newIORef, readIORef, atomicModifyIORef' )+import Data.Maybe       ( isJust )+import Data.Char+import Data.List        ( elemIndex )++import GHC.IO           ( IO(..), unsafeDupablePerformIO )++import Foreign++#if STAGE >= 2+import GHC.Conc.Sync    (sharedCAF)+#endif++import GHC.Base         ( unpackCString# )++#define hASH_TBL_SIZE          4091+#define hASH_TBL_SIZE_UNBOXED  4091#+++fastStringToByteString :: FastString -> ByteString+fastStringToByteString f = fs_bs f++fastZStringToByteString :: FastZString -> ByteString+fastZStringToByteString (FastZString bs) = bs++-- This will drop information if any character > '\xFF'+unsafeMkByteString :: String -> ByteString+unsafeMkByteString = BSC.pack++hashByteString :: ByteString -> Int+hashByteString bs+    = inlinePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) ->+      return $ hashStr (castPtr ptr) len++-- -----------------------------------------------------------------------------++newtype FastZString = FastZString ByteString+  deriving NFData++hPutFZS :: Handle -> FastZString -> IO ()+hPutFZS handle (FastZString bs) = BS.hPut handle bs++zString :: FastZString -> String+zString (FastZString bs) =+    inlinePerformIO $ BS.unsafeUseAsCStringLen bs peekCAStringLen++lengthFZS :: FastZString -> Int+lengthFZS (FastZString bs) = BS.length bs++mkFastZStringString :: String -> FastZString+mkFastZStringString str = FastZString (BSC.pack str)++-- -----------------------------------------------------------------------------++{-|+A 'FastString' is an array of bytes, hashed to support fast O(1)+comparison.  It is also associated with a character encoding, so that+we know how to convert a 'FastString' to the local encoding, or to the+Z-encoding used by the compiler internally.++'FastString's support a memoized conversion to the Z-encoding via zEncodeFS.+-}++data FastString = FastString {+      uniq    :: {-# UNPACK #-} !Int, -- unique id+      n_chars :: {-# UNPACK #-} !Int, -- number of chars+      fs_bs   :: {-# UNPACK #-} !ByteString,+      fs_ref  :: {-# UNPACK #-} !(IORef (Maybe FastZString))+  }++instance Eq FastString where+  f1 == f2  =  uniq f1 == uniq f2++instance Ord FastString where+    -- Compares lexicographically, not by unique+    a <= b = case cmpFS a b of { LT -> True;  EQ -> True;  GT -> False }+    a <  b = case cmpFS a b of { LT -> True;  EQ -> False; GT -> False }+    a >= b = case cmpFS a b of { LT -> False; EQ -> True;  GT -> True  }+    a >  b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True  }+    max x y | x >= y    =  x+            | otherwise =  y+    min x y | x <= y    =  x+            | otherwise =  y+    compare a b = cmpFS a b++instance IsString FastString where+    fromString = fsLit++instance Monoid FastString where+    mempty = nilFS+    mappend = appendFS+    mconcat = concatFS++instance Show FastString where+   show fs = show (unpackFS fs)++instance Data FastString where+  -- don't traverse?+  toConstr _   = abstractConstr "FastString"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "FastString"++cmpFS :: FastString -> FastString -> Ordering+cmpFS f1@(FastString u1 _ _ _) f2@(FastString u2 _ _ _) =+  if u1 == u2 then EQ else+  compare (fastStringToByteString f1) (fastStringToByteString f2)++foreign import ccall unsafe "ghc_memcmp"+  memcmp :: Ptr a -> Ptr b -> Int -> IO Int++-- -----------------------------------------------------------------------------+-- Construction++{-+Internally, the compiler will maintain a fast string symbol table, providing+sharing and fast comparison. Creation of new @FastString@s then covertly does a+lookup, re-using the @FastString@ if there was a hit.++The design of the FastString hash table allows for lockless concurrent reads+and updates to multiple buckets with low synchronization overhead.++See Note [Updating the FastString table] on how it's updated.+-}+data FastStringTable =+ FastStringTable+    {-# UNPACK #-} !(IORef Int)  -- the unique ID counter shared with all buckets+    (MutableArray# RealWorld (IORef [FastString])) -- the array of mutable buckets++string_table :: FastStringTable+{-# NOINLINE string_table #-}+string_table = unsafePerformIO $ do+  uid <- newIORef 603979776 -- ord '$' * 0x01000000+  tab <- IO $ \s1# -> case newArray# hASH_TBL_SIZE_UNBOXED (panic "string_table") s1# of+                          (# s2#, arr# #) ->+                              (# s2#, FastStringTable uid arr# #)+  forM_ [0.. hASH_TBL_SIZE-1] $ \i -> do+     bucket <- newIORef []+     updTbl tab i bucket++  -- use the support wired into the RTS to share this CAF among all images of+  -- libHSghc+#if STAGE < 2+  return tab+#else+  sharedCAF tab getOrSetLibHSghcFastStringTable++-- from the RTS; thus we cannot use this mechanism when STAGE<2; the previous+-- RTS might not have this symbol+foreign import ccall unsafe "getOrSetLibHSghcFastStringTable"+  getOrSetLibHSghcFastStringTable :: Ptr a -> IO (Ptr a)+#endif++{-++We include the FastString table in the `sharedCAF` mechanism because we'd like+FastStrings created by a Core plugin to have the same uniques as corresponding+strings created by the host compiler itself.  For example, this allows plugins+to lookup known names (eg `mkTcOcc "MySpecialType"`) in the GlobalRdrEnv or+even re-invoke the parser.++In particular, the following little sanity test was failing in a plugin+prototyping safe newtype-coercions: GHC.NT.Type.NT was imported, but could not+be looked up /by the plugin/.++   let rdrName = mkModuleName "GHC.NT.Type" `mkRdrQual` mkTcOcc "NT"+   putMsgS $ showSDoc dflags $ ppr $ lookupGRE_RdrName rdrName $ mg_rdr_env guts++`mkTcOcc` involves the lookup (or creation) of a FastString.  Since the+plugin's FastString.string_table is empty, constructing the RdrName also+allocates new uniques for the FastStrings "GHC.NT.Type" and "NT".  These+uniques are almost certainly unequal to the ones that the host compiler+originally assigned to those FastStrings.  Thus the lookup fails since the+domain of the GlobalRdrEnv is affected by the RdrName's OccName's FastString's+unique.++Maintaining synchronization of the two instances of this global is rather+difficult because of the uses of `unsafePerformIO` in this module.  Not+synchronizing them risks breaking the rather major invariant that two+FastStrings with the same unique have the same string. Thus we use the+lower-level `sharedCAF` mechanism that relies on Globals.c.++-}++lookupTbl :: FastStringTable -> Int -> IO (IORef [FastString])+lookupTbl (FastStringTable _ arr#) (I# i#) =+  IO $ \ s# -> readArray# arr# i# s#++updTbl :: FastStringTable -> Int -> IORef [FastString] -> IO ()+updTbl (FastStringTable _uid arr#) (I# i#) ls = do+  (IO $ \ s# -> case writeArray# arr# i# ls s# of { s2# -> (# s2#, () #) })++mkFastString# :: Addr# -> FastString+mkFastString# a# = mkFastStringBytes ptr (ptrStrLength ptr)+  where ptr = Ptr a#++{- Note [Updating the FastString table]++The procedure goes like this:++1. Read the relevant bucket and perform a look up of the string.+2. If it exists, return it.+3. Otherwise grab a unique ID, create a new FastString and atomically attempt+   to update the relevant bucket with this FastString:++   * Double check that the string is not in the bucket. Another thread may have+     inserted it while we were creating our string.+   * Return the existing FastString if it exists. The one we preemptively+     created will get GCed.+   * Otherwise, insert and return the string we created.+-}++{- Note [Double-checking the bucket]++It is not necessary to check the entire bucket the second time. We only have to+check the strings that are new to the bucket since the last time we read it.+-}++mkFastStringWith :: (Int -> IO FastString) -> Ptr Word8 -> Int -> IO FastString+mkFastStringWith mk_fs !ptr !len = do+    let hash = hashStr ptr len+    bucket <- lookupTbl string_table hash+    ls1 <- readIORef bucket+    res <- bucket_match ls1 len ptr+    case res of+        Just v  -> return v+        Nothing -> do+            n <- get_uid+            new_fs <- mk_fs n++            atomicModifyIORef' bucket $ \ls2 ->+                -- Note [Double-checking the bucket]+                let delta_ls = case ls1 of+                        []  -> ls2+                        l:_ -> case l `elemIndex` ls2 of+                            Nothing  -> panic "mkFastStringWith"+                            Just idx -> take idx ls2++                -- NB: Might as well use inlinePerformIO, since the call to+                -- bucket_match doesn't perform any IO that could be floated+                -- out of this closure or erroneously duplicated.+                in case inlinePerformIO (bucket_match delta_ls len ptr) of+                    Nothing -> (new_fs:ls2, new_fs)+                    Just fs -> (ls2,fs)+  where+    !(FastStringTable uid _arr) = string_table++    get_uid = atomicModifyIORef' uid $ \n -> (n+1,n)++mkFastStringBytes :: Ptr Word8 -> Int -> FastString+mkFastStringBytes !ptr !len =+    -- NB: Might as well use unsafeDupablePerformIO, since mkFastStringWith is+    -- idempotent.+    unsafeDupablePerformIO $+        mkFastStringWith (copyNewFastString ptr len) ptr len++-- | Create a 'FastString' from an existing 'ForeignPtr'; the difference+-- between this and 'mkFastStringBytes' is that we don't have to copy+-- the bytes if the string is new to the table.+mkFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString+mkFastStringForeignPtr ptr !fp len+    = mkFastStringWith (mkNewFastString fp ptr len) ptr len++-- | Create a 'FastString' from an existing 'ForeignPtr'; the difference+-- between this and 'mkFastStringBytes' is that we don't have to copy+-- the bytes if the string is new to the table.+mkFastStringByteString :: ByteString -> FastString+mkFastStringByteString bs =+    inlinePerformIO $+      BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> do+        let ptr' = castPtr ptr+        mkFastStringWith (mkNewFastStringByteString bs ptr' len) ptr' len++-- | Creates a UTF-8 encoded 'FastString' from a 'String'+mkFastString :: String -> FastString+mkFastString str =+  inlinePerformIO $ do+    let l = utf8EncodedLength str+    buf <- mallocForeignPtrBytes l+    withForeignPtr buf $ \ptr -> do+      utf8EncodeString ptr str+      mkFastStringForeignPtr ptr buf l++-- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@+mkFastStringByteList :: [Word8] -> FastString+mkFastStringByteList str =+  inlinePerformIO $ do+    let l = Prelude.length str+    buf <- mallocForeignPtrBytes l+    withForeignPtr buf $ \ptr -> do+      pokeArray (castPtr ptr) str+      mkFastStringForeignPtr ptr buf l++-- | Creates a Z-encoded 'FastString' from a 'String'+mkZFastString :: String -> FastZString+mkZFastString = mkFastZStringString++bucket_match :: [FastString] -> Int -> Ptr Word8 -> IO (Maybe FastString)+bucket_match [] _ _ = return Nothing+bucket_match (v@(FastString _ _ bs _):ls) len ptr+      | len == BS.length bs = do+         b <- BS.unsafeUseAsCString bs $ \buf ->+             cmpStringPrefix ptr (castPtr buf) len+         if b then return (Just v)+              else bucket_match ls len ptr+      | otherwise =+         bucket_match ls len ptr++mkNewFastString :: ForeignPtr Word8 -> Ptr Word8 -> Int -> Int+                -> IO FastString+mkNewFastString fp ptr len uid = do+  ref <- newIORef Nothing+  n_chars <- countUTF8Chars ptr len+  return (FastString uid n_chars (BS.fromForeignPtr fp 0 len) ref)++mkNewFastStringByteString :: ByteString -> Ptr Word8 -> Int -> Int+                          -> IO FastString+mkNewFastStringByteString bs ptr len uid = do+  ref <- newIORef Nothing+  n_chars <- countUTF8Chars ptr len+  return (FastString uid n_chars bs ref)++copyNewFastString :: Ptr Word8 -> Int -> Int -> IO FastString+copyNewFastString ptr len uid = do+  fp <- copyBytesToForeignPtr ptr len+  ref <- newIORef Nothing+  n_chars <- countUTF8Chars ptr len+  return (FastString uid n_chars (BS.fromForeignPtr fp 0 len) ref)++copyBytesToForeignPtr :: Ptr Word8 -> Int -> IO (ForeignPtr Word8)+copyBytesToForeignPtr ptr len = do+  fp <- mallocForeignPtrBytes len+  withForeignPtr fp $ \ptr' -> copyBytes ptr' ptr len+  return fp++cmpStringPrefix :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool+cmpStringPrefix ptr1 ptr2 len =+ do r <- memcmp ptr1 ptr2 len+    return (r == 0)+++hashStr  :: Ptr Word8 -> Int -> Int+ -- use the Addr to produce a hash value between 0 & m (inclusive)+hashStr (Ptr a#) (I# len#) = loop 0# 0#+   where+    loop h n | isTrue# (n ==# len#) = I# h+             | otherwise  = loop h2 (n +# 1#)+          where !c = ord# (indexCharOffAddr# a# n)+                !h2 = (c +# (h *# 128#)) `remInt#`+                      hASH_TBL_SIZE#++-- -----------------------------------------------------------------------------+-- Operations++-- | Returns the length of the 'FastString' in characters+lengthFS :: FastString -> Int+lengthFS f = n_chars f++-- | Returns @True@ if this 'FastString' is not Z-encoded but already has+-- a Z-encoding cached (used in producing stats).+hasZEncoding :: FastString -> Bool+hasZEncoding (FastString _ _ _ ref) =+      inlinePerformIO $ do+        m <- readIORef ref+        return (isJust m)++-- | Returns @True@ if the 'FastString' is empty+nullFS :: FastString -> Bool+nullFS f = BS.null (fs_bs f)++-- | Unpacks and decodes the FastString+unpackFS :: FastString -> String+unpackFS (FastString _ _ bs _) = utf8DecodeByteString bs++-- | Gives the UTF-8 encoded bytes corresponding to a 'FastString'+bytesFS :: FastString -> [Word8]+bytesFS fs = BS.unpack $ fastStringToByteString fs++-- | Returns a Z-encoded version of a 'FastString'.  This might be the+-- original, if it was already Z-encoded.  The first time this+-- function is applied to a particular 'FastString', the results are+-- memoized.+--+zEncodeFS :: FastString -> FastZString+zEncodeFS fs@(FastString _ _ _ ref) =+      inlinePerformIO $ do+        m <- readIORef ref+        case m of+          Just zfs -> return zfs+          Nothing -> do+            atomicModifyIORef' ref $ \m' -> case m' of+              Nothing  -> let zfs = mkZFastString (zEncodeString (unpackFS fs))+                          in (Just zfs, zfs)+              Just zfs -> (m', zfs)++appendFS :: FastString -> FastString -> FastString+appendFS fs1 fs2 = mkFastStringByteString+                 $ BS.append (fastStringToByteString fs1)+                             (fastStringToByteString fs2)++concatFS :: [FastString] -> FastString+concatFS = mkFastStringByteString . BS.concat . map fs_bs++headFS :: FastString -> Char+headFS (FastString _ 0 _ _) = panic "headFS: Empty FastString"+headFS (FastString _ _ bs _) =+  inlinePerformIO $ BS.unsafeUseAsCString bs $ \ptr ->+         return (fst (utf8DecodeChar (castPtr ptr)))++tailFS :: FastString -> FastString+tailFS (FastString _ 0 _ _) = panic "tailFS: Empty FastString"+tailFS (FastString _ _ bs _) =+    inlinePerformIO $ BS.unsafeUseAsCString bs $ \ptr ->+    do let (_, n) = utf8DecodeChar (castPtr ptr)+       return $! mkFastStringByteString (BS.drop n bs)++consFS :: Char -> FastString -> FastString+consFS c fs = mkFastString (c : unpackFS fs)++uniqueOfFS :: FastString -> Int+uniqueOfFS (FastString u _ _ _) = u++nilFS :: FastString+nilFS = mkFastString ""++-- -----------------------------------------------------------------------------+-- Stats++getFastStringTable :: IO [[FastString]]+getFastStringTable = do+  buckets <- forM [0.. hASH_TBL_SIZE-1] $ \idx -> do+    bucket <- lookupTbl string_table idx+    readIORef bucket+  return buckets++-- -----------------------------------------------------------------------------+-- Outputting 'FastString's++-- |Outputs a 'FastString' with /no decoding at all/, that is, you+-- get the actual bytes in the 'FastString' written to the 'Handle'.+hPutFS :: Handle -> FastString -> IO ()+hPutFS handle fs = BS.hPut handle $ fastStringToByteString fs++-- ToDo: we'll probably want an hPutFSLocal, or something, to output+-- in the current locale's encoding (for error messages and suchlike).++-- -----------------------------------------------------------------------------+-- LitStrings, here for convenience only.++-- | A 'LitString' is a pointer to some null-terminated array of bytes.+type LitString = Ptr Word8+--Why do we recalculate length every time it's requested?+--If it's commonly needed, we should perhaps have+--data LitString = LitString {-#UNPACK#-}!Addr# {-#UNPACK#-}!Int#++-- | Wrap an unboxed address into a 'LitString'.+mkLitString# :: Addr# -> LitString+mkLitString# a# = Ptr a#++-- | Encode a 'String' into a newly allocated 'LitString' using Latin-1+-- encoding.  The original string must not contain non-Latin-1 characters+-- (above codepoint @0xff@).+{-# INLINE mkLitString #-}+mkLitString :: String -> LitString+mkLitString s =+ unsafePerformIO (do+   p <- mallocBytes (length s + 1)+   let+     loop :: Int -> String -> IO ()+     loop !n [] = pokeByteOff p n (0 :: Word8)+     loop n (c:cs) = do+        pokeByteOff p n (fromIntegral (ord c) :: Word8)+        loop (1+n) cs+   loop 0 s+   return p+ )++-- | Decode a 'LitString' back into a 'String' using Latin-1 encoding.+-- This does not free the memory associated with 'LitString'.+unpackLitString :: LitString -> String+unpackLitString (Ptr p) = unpackCString# p++-- | Compute the length of a 'LitString', which must necessarily be+-- null-terminated.+lengthLS :: LitString -> Int+lengthLS = ptrStrLength++-- -----------------------------------------------------------------------------+-- under the carpet++foreign import ccall unsafe "ghc_strlen"+  ptrStrLength :: Ptr Word8 -> Int++{-# NOINLINE sLit #-}+sLit :: String -> LitString+sLit x  = mkLitString x++{-# NOINLINE fsLit #-}+fsLit :: String -> FastString+fsLit x = mkFastString x++{-# RULES "slit"+    forall x . sLit  (unpackCString# x) = mkLitString#  x #-}+{-# RULES "fslit"+    forall x . fsLit (unpackCString# x) = mkFastString# x #-}
+ utils/FastStringEnv.hs view
@@ -0,0 +1,98 @@+{-+%+% (c) The University of Glasgow 2006+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998+%+\section[FastStringEnv]{@FastStringEnv@: FastString environments}+-}++module FastStringEnv (+        -- * FastString environments (maps)+        FastStringEnv,++        -- ** Manipulating these environments+        mkFsEnv,+        emptyFsEnv, unitFsEnv,+        extendFsEnv_C, extendFsEnv_Acc, extendFsEnv,+        extendFsEnvList, extendFsEnvList_C,+        filterFsEnv,+        plusFsEnv, plusFsEnv_C, alterFsEnv,+        lookupFsEnv, lookupFsEnv_NF, delFromFsEnv, delListFromFsEnv,+        elemFsEnv, mapFsEnv,++        -- * Deterministic FastString environments (maps)+        DFastStringEnv,++        -- ** Manipulating these environments+        mkDFsEnv, emptyDFsEnv, dFsEnvElts, lookupDFsEnv+    ) where++import UniqFM+import UniqDFM+import Maybes+import FastString+++-- | A non-deterministic set of FastStrings.+-- See Note [Deterministic UniqFM] in UniqDFM for explanation why it's not+-- deterministic and why it matters. Use DFastStringEnv if the set eventually+-- gets converted into a list or folded over in a way where the order+-- changes the generated code.+type FastStringEnv a = UniqFM a  -- Domain is FastString++emptyFsEnv         :: FastStringEnv a+mkFsEnv            :: [(FastString,a)] -> FastStringEnv a+alterFsEnv         :: (Maybe a-> Maybe a) -> FastStringEnv a -> FastString -> FastStringEnv a+extendFsEnv_C      :: (a->a->a) -> FastStringEnv a -> FastString -> a -> FastStringEnv a+extendFsEnv_Acc    :: (a->b->b) -> (a->b) -> FastStringEnv b -> FastString -> a -> FastStringEnv b+extendFsEnv        :: FastStringEnv a -> FastString -> a -> FastStringEnv a+plusFsEnv          :: FastStringEnv a -> FastStringEnv a -> FastStringEnv a+plusFsEnv_C        :: (a->a->a) -> FastStringEnv a -> FastStringEnv a -> FastStringEnv a+extendFsEnvList    :: FastStringEnv a -> [(FastString,a)] -> FastStringEnv a+extendFsEnvList_C  :: (a->a->a) -> FastStringEnv a -> [(FastString,a)] -> FastStringEnv a+delFromFsEnv       :: FastStringEnv a -> FastString -> FastStringEnv a+delListFromFsEnv   :: FastStringEnv a -> [FastString] -> FastStringEnv a+elemFsEnv          :: FastString -> FastStringEnv a -> Bool+unitFsEnv          :: FastString -> a -> FastStringEnv a+lookupFsEnv        :: FastStringEnv a -> FastString -> Maybe a+lookupFsEnv_NF     :: FastStringEnv a -> FastString -> a+filterFsEnv        :: (elt -> Bool) -> FastStringEnv elt -> FastStringEnv elt+mapFsEnv           :: (elt1 -> elt2) -> FastStringEnv elt1 -> FastStringEnv elt2++emptyFsEnv                = emptyUFM+unitFsEnv x y             = unitUFM x y+extendFsEnv x y z         = addToUFM x y z+extendFsEnvList x l       = addListToUFM x l+lookupFsEnv x y           = lookupUFM x y+alterFsEnv                = alterUFM+mkFsEnv     l             = listToUFM l+elemFsEnv x y             = elemUFM x y+plusFsEnv x y             = plusUFM x y+plusFsEnv_C f x y         = plusUFM_C f x y+extendFsEnv_C f x y z     = addToUFM_C f x y z+mapFsEnv f x              = mapUFM f x+extendFsEnv_Acc x y z a b = addToUFM_Acc x y z a b+extendFsEnvList_C x y z   = addListToUFM_C x y z+delFromFsEnv x y          = delFromUFM x y+delListFromFsEnv x y      = delListFromUFM x y+filterFsEnv x y           = filterUFM x y++lookupFsEnv_NF env n = expectJust "lookupFsEnv_NF" (lookupFsEnv env n)++-- Deterministic FastStringEnv+-- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need+-- DFastStringEnv.++type DFastStringEnv a = UniqDFM a  -- Domain is FastString++emptyDFsEnv :: DFastStringEnv a+emptyDFsEnv = emptyUDFM++dFsEnvElts :: DFastStringEnv a -> [a]+dFsEnvElts = eltsUDFM++mkDFsEnv :: [(FastString,a)] -> DFastStringEnv a+mkDFsEnv l = listToUDFM l++lookupDFsEnv :: DFastStringEnv a -> FastString -> Maybe a+lookupDFsEnv = lookupUDFM
+ utils/Fingerprint.hsc view
@@ -0,0 +1,46 @@+{-# LANGUAGE CPP #-}++-- ----------------------------------------------------------------------------+--+--  (c) The University of Glasgow 2006+--+-- Fingerprints for recompilation checking and ABI versioning.+--+-- http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance+--+-- ----------------------------------------------------------------------------++module Fingerprint (+        readHexFingerprint,+        fingerprintByteString,+        -- * Re-exported from GHC.Fingerprint+        Fingerprint(..), fingerprint0,+        fingerprintFingerprints,+        fingerprintData,+        fingerprintString,+        getFileHash+   ) where++#include "md5.h"+##include "HsVersions.h"++import Foreign+import GHC.IO+import Numeric          ( readHex )++import qualified Data.ByteString as BS+import qualified Data.ByteString.Unsafe as BS++import GHC.Fingerprint++-- useful for parsing the output of 'md5sum', should we want to do that.+readHexFingerprint :: String -> Fingerprint+readHexFingerprint s = Fingerprint w1 w2+ where (s1,s2) = splitAt 16 s+       [(w1,"")] = readHex s1+       [(w2,"")] = readHex (take 16 s2)++-- this can move to GHC.Fingerprint in GHC 8.6+fingerprintByteString :: BS.ByteString -> Fingerprint+fingerprintByteString bs = unsafeDupablePerformIO $+  BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> fingerprintData (castPtr ptr) len
+ utils/FiniteMap.hs view
@@ -0,0 +1,29 @@+-- Some extra functions to extend Data.Map++module FiniteMap (+        insertList,+        insertListWith,+        deleteList,+        foldRight, foldRightWithKey+    ) where++import Data.Map (Map)+import qualified Data.Map as Map++insertList :: Ord key => [(key,elt)] -> Map key elt -> Map key elt+insertList xs m = foldl (\m (k, v) -> Map.insert k v m) m xs++insertListWith :: Ord key+               => (elt -> elt -> elt)+               -> [(key,elt)]+               -> Map key elt+               -> Map key elt+insertListWith f xs m0 = foldl (\m (k, v) -> Map.insertWith f k v m) m0 xs++deleteList :: Ord key => [key] -> Map key elt -> Map key elt+deleteList ks m = foldl (flip Map.delete) m ks++foldRight        :: (elt -> a -> a) -> a -> Map key elt -> a+foldRight        = Map.foldr+foldRightWithKey :: (key -> elt -> a -> a) -> a -> Map key elt -> a+foldRightWithKey = Map.foldrWithKey
+ utils/GraphBase.hs view
@@ -0,0 +1,105 @@++-- | Types for the general graph colorer.+module GraphBase (+        Triv,+        Graph (..),+        initGraph,+        graphMapModify,++        Node  (..),     newNode,+)+++where++import UniqSet+import UniqFM+++-- | A fn to check if a node is trivially colorable+--      For graphs who's color classes are disjoint then a node is 'trivially colorable'+--      when it has less neighbors and exclusions than available colors for that node.+--+--      For graph's who's color classes overlap, ie some colors alias other colors, then+--      this can be a bit more tricky. There is a general way to calculate this, but+--      it's likely be too slow for use in the code. The coloring algorithm takes+--      a canned function which can be optimised by the user to be specific to the+--      specific graph being colored.+--+--      for details, see  "A Generalised Algorithm for Graph-Coloring Register Allocation"+--                              Smith, Ramsey, Holloway - PLDI 2004.+--+type Triv k cls color+        =  cls                  -- the class of the node we're trying to color.+        -> UniqSet k            -- the node's neighbors.+        -> UniqSet color        -- the node's exclusions.+        -> Bool+++-- | The Interference graph.+--      There used to be more fields, but they were turfed out in a previous revision.+--      maybe we'll want more later..+--+data Graph k cls color+        = Graph {+        -- | All active nodes in the graph.+          graphMap              :: UniqFM (Node k cls color)  }+++-- | An empty graph.+initGraph :: Graph k cls color+initGraph+        = Graph+        { graphMap              = emptyUFM }+++-- | Modify the finite map holding the nodes in the graph.+graphMapModify+        :: (UniqFM (Node k cls color) -> UniqFM (Node k cls color))+        -> Graph k cls color -> Graph k cls color++graphMapModify f graph+        = graph { graphMap      = f (graphMap graph) }++++-- | Graph nodes.+--      Represents a thing that can conflict with another thing.+--      For the register allocater the nodes represent registers.+--+data Node k cls color+        = Node {+        -- | A unique identifier for this node.+          nodeId                :: k++        -- | The class of this node,+        --      determines the set of colors that can be used.+        , nodeClass             :: cls++        -- | The color of this node, if any.+        , nodeColor             :: Maybe color++        -- | Neighbors which must be colored differently to this node.+        , nodeConflicts         :: UniqSet k++        -- | Colors that cannot be used by this node.+        , nodeExclusions        :: UniqSet color++        -- | Colors that this node would prefer to be, in decending order.+        , nodePreference        :: [color]++        -- | Neighbors that this node would like to be colored the same as.+        , nodeCoalesce          :: UniqSet k }+++-- | An empty node.+newNode :: k -> cls -> Node k cls color+newNode k cls+        = Node+        { nodeId                = k+        , nodeClass             = cls+        , nodeColor             = Nothing+        , nodeConflicts         = emptyUniqSet+        , nodeExclusions        = emptyUniqSet+        , nodePreference        = []+        , nodeCoalesce          = emptyUniqSet }
+ utils/GraphColor.hs view
@@ -0,0 +1,371 @@+-- | Graph Coloring.+--      This is a generic graph coloring library, abstracted over the type of+--      the node keys, nodes and colors.+--++module GraphColor (+        module GraphBase,+        module GraphOps,+        module GraphPpr,+        colorGraph+)++where++import GraphBase+import GraphOps+import GraphPpr++import Unique+import UniqFM+import UniqSet+import Outputable++import Data.Maybe+import Data.List+++-- | Try to color a graph with this set of colors.+--      Uses Chaitin's algorithm to color the graph.+--      The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes+--      are pushed onto a stack and removed from the graph.+--      Once this process is complete the graph can be colored by removing nodes from+--      the stack (ie in reverse order) and assigning them colors different to their neighbors.+--+colorGraph+        :: ( Uniquable  k, Uniquable cls,  Uniquable  color+           , Eq cls, Ord k+           , Outputable k, Outputable cls, Outputable color)+        => Bool                         -- ^ whether to do iterative coalescing+        -> Int                          -- ^ how many times we've tried to color this graph so far.+        -> UniqFM (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).+        -> Triv   k cls color           -- ^ fn to decide whether a node is trivially colorable.+        -> (Graph k cls color -> k)     -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable.+        -> Graph  k cls color           -- ^ the graph to color.++        -> ( Graph k cls color          -- the colored graph.+           , UniqSet k                  -- the set of nodes that we couldn't find a color for.+           , UniqFM  k )                -- map of regs (r1 -> r2) that were coalesced+                                        --       r1 should be replaced by r2 in the source++colorGraph iterative spinCount colors triv spill graph0+ = let+        -- If we're not doing iterative coalescing then do an aggressive coalescing first time+        --      around and then conservative coalescing for subsequent passes.+        --+        --      Aggressive coalescing is a quick way to get rid of many reg-reg moves. However, if+        --      there is a lot of register pressure and we do it on every round then it can make the+        --      graph less colorable and prevent the algorithm from converging in a sensible number+        --      of cycles.+        --+        (graph_coalesced, kksCoalesce1)+         = if iterative+                then (graph0, [])+                else if spinCount == 0+                        then coalesceGraph True  triv graph0+                        else coalesceGraph False triv graph0++        -- run the scanner to slurp out all the trivially colorable nodes+        --      (and do coalescing if iterative coalescing is enabled)+        (ksTriv, ksProblems, kksCoalesce2)+                = colorScan iterative triv spill graph_coalesced++        -- If iterative coalescing is enabled, the scanner will coalesce the graph as does its business.+        --      We need to apply all the coalescences found by the scanner to the original+        --      graph before doing assignColors.+        --+        --      Because we've got the whole, non-pruned graph here we turn on aggressive coalecing+        --      to force all the (conservative) coalescences found during scanning.+        --+        (graph_scan_coalesced, _)+                = mapAccumL (coalesceNodes True triv) graph_coalesced kksCoalesce2++        -- color the trivially colorable nodes+        --      during scanning, keys of triv nodes were added to the front of the list as they were found+        --      this colors them in the reverse order, as required by the algorithm.+        (graph_triv, ksNoTriv)+                = assignColors colors graph_scan_coalesced ksTriv++        -- try and color the problem nodes+        --      problem nodes are the ones that were left uncolored because they weren't triv.+        --      theres a change we can color them here anyway.+        (graph_prob, ksNoColor)+                = assignColors colors graph_triv ksProblems++        -- if the trivially colorable nodes didn't color then something is probably wrong+        --      with the provided triv function.+        --+   in   if not $ null ksNoTriv+         then   pprPanic "colorGraph: trivially colorable nodes didn't color!" -- empty+                        (  empty+                        $$ text "ksTriv    = " <> ppr ksTriv+                        $$ text "ksNoTriv  = " <> ppr ksNoTriv+                        $$ text "colors    = " <> ppr colors+                        $$ empty+                        $$ dotGraph (\_ -> text "white") triv graph_triv)++         else   ( graph_prob+                , mkUniqSet ksNoColor   -- the nodes that didn't color (spills)+                , if iterative+                        then (listToUFM kksCoalesce2)+                        else (listToUFM kksCoalesce1))+++-- | Scan through the conflict graph separating out trivially colorable and+--      potentially uncolorable (problem) nodes.+--+--      Checking whether a node is trivially colorable or not is a resonably expensive operation,+--      so after a triv node is found and removed from the graph it's no good to return to the 'start'+--      of the graph and recheck a bunch of nodes that will probably still be non-trivially colorable.+--+--      To ward against this, during each pass through the graph we collect up a list of triv nodes+--      that were found, and only remove them once we've finished the pass. The more nodes we can delete+--      at once the more likely it is that nodes we've already checked will become trivially colorable+--      for the next pass.+--+--      TODO:   add work lists to finding triv nodes is easier.+--              If we've just scanned the graph, and removed triv nodes, then the only+--              nodes that we need to rescan are the ones we've removed edges from.++colorScan+        :: ( Uniquable k, Uniquable cls, Uniquable color+           , Ord k,       Eq cls+           , Outputable k, Outputable cls)+        => Bool                         -- ^ whether to do iterative coalescing+        -> Triv k cls color             -- ^ fn to decide whether a node is trivially colorable+        -> (Graph k cls color -> k)     -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable.+        -> Graph k cls color            -- ^ the graph to scan++        -> ([k], [k], [(k, k)])         --  triv colorable nodes, problem nodes, pairs of nodes to coalesce++colorScan iterative triv spill graph+        = colorScan_spin iterative triv spill graph [] [] []++colorScan_spin+        :: ( Uniquable k, Uniquable cls, Uniquable color+           , Ord k,       Eq cls+           , Outputable k, Outputable cls)+        => Bool+        -> Triv k cls color+        -> (Graph k cls color -> k)+        -> Graph k cls color+        -> [k]+        -> [k]+        -> [(k, k)]+        -> ([k], [k], [(k, k)])++colorScan_spin iterative triv spill graph+        ksTriv ksSpill kksCoalesce++        -- if the graph is empty then we're done+        | isNullUFM $ graphMap graph+        = (ksTriv, ksSpill, reverse kksCoalesce)++        -- Simplify:+        --      Look for trivially colorable nodes.+        --      If we can find some then remove them from the graph and go back for more.+        --+        | nsTrivFound@(_:_)+                <-  scanGraph   (\node -> triv  (nodeClass node) (nodeConflicts node) (nodeExclusions node)++                                  -- for iterative coalescing we only want non-move related+                                  --    nodes here+                                  && (not iterative || isEmptyUniqSet (nodeCoalesce node)))+                        $ graph++        , ksTrivFound   <- map nodeId nsTrivFound+        , graph2        <- foldr (\k g -> let Just g' = delNode k g+                                          in  g')+                                graph ksTrivFound++        = colorScan_spin iterative triv spill graph2+                (ksTrivFound ++ ksTriv)+                ksSpill+                kksCoalesce++        -- Coalesce:+        --      If we're doing iterative coalescing and no triv nodes are available+        --      then it's time for a coalescing pass.+        | iterative+        = case coalesceGraph False triv graph of++                -- we were able to coalesce something+                --      go back to Simplify and see if this frees up more nodes to be trivially colorable.+                (graph2, kksCoalesceFound @(_:_))+                 -> colorScan_spin iterative triv spill graph2+                        ksTriv ksSpill (reverse kksCoalesceFound ++ kksCoalesce)++                -- Freeze:+                -- nothing could be coalesced (or was triv),+                --      time to choose a node to freeze and give up on ever coalescing it.+                (graph2, [])+                 -> case freezeOneInGraph graph2 of++                        -- we were able to freeze something+                        --      hopefully this will free up something for Simplify+                        (graph3, True)+                         -> colorScan_spin iterative triv spill graph3+                                ksTriv ksSpill kksCoalesce++                        -- we couldn't find something to freeze either+                        --      time for a spill+                        (graph3, False)+                         -> colorScan_spill iterative triv spill graph3+                                ksTriv ksSpill kksCoalesce++        -- spill time+        | otherwise+        = colorScan_spill iterative triv spill graph+                ksTriv ksSpill kksCoalesce+++-- Select:+-- we couldn't find any triv nodes or things to freeze or coalesce,+--      and the graph isn't empty yet.. We'll have to choose a spill+--      candidate and leave it uncolored.+--+colorScan_spill+        :: ( Uniquable k, Uniquable cls, Uniquable color+           , Ord k,       Eq cls+           , Outputable k, Outputable cls)+        => Bool+        -> Triv k cls color+        -> (Graph k cls color -> k)+        -> Graph k cls color+        -> [k]+        -> [k]+        -> [(k, k)]+        -> ([k], [k], [(k, k)])++colorScan_spill iterative triv spill graph+        ksTriv ksSpill kksCoalesce++ = let  kSpill          = spill graph+        Just graph'     = delNode kSpill graph+   in   colorScan_spin iterative triv spill graph'+                ksTriv (kSpill : ksSpill) kksCoalesce+++-- | Try to assign a color to all these nodes.++assignColors+        :: ( Uniquable k, Uniquable cls, Uniquable color+           , Outputable cls)+        => UniqFM (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).+        -> Graph k cls color            -- ^ the graph+        -> [k]                          -- ^ nodes to assign a color to.+        -> ( Graph k cls color          -- the colored graph+           , [k])                       -- the nodes that didn't color.++assignColors colors graph ks+        = assignColors' colors graph [] ks++ where  assignColors' _ graph prob []+                = (graph, prob)++        assignColors' colors graph prob (k:ks)+         = case assignColor colors k graph of++                -- couldn't color this node+                Nothing         -> assignColors' colors graph (k : prob) ks++                -- this node colored ok, so do the rest+                Just graph'     -> assignColors' colors graph' prob ks+++        assignColor colors u graph+                | Just c        <- selectColor colors graph u+                = Just (setColor u c graph)++                | otherwise+                = Nothing++++-- | Select a color for a certain node+--      taking into account preferences, neighbors and exclusions.+--      returns Nothing if no color can be assigned to this node.+--+selectColor+        :: ( Uniquable k, Uniquable cls, Uniquable color+           , Outputable cls)+        => UniqFM (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).+        -> Graph k cls color            -- ^ the graph+        -> k                            -- ^ key of the node to select a color for.+        -> Maybe color++selectColor colors graph u+ = let  -- lookup the node+        Just node       = lookupNode graph u++        -- lookup the available colors for the class of this node.+        colors_avail+         = case lookupUFM colors (nodeClass node) of+                Nothing -> pprPanic "selectColor: no colors available for class " (ppr (nodeClass node))+                Just cs -> cs++        -- find colors we can't use because they're already being used+        --      by a node that conflicts with this one.+        Just nsConflicts+                        = sequence+                        $ map (lookupNode graph)+                        $ nonDetEltsUniqSet+                        $ nodeConflicts node+                        -- See Note [Unique Determinism and code generation]++        colors_conflict = mkUniqSet+                        $ catMaybes+                        $ map nodeColor nsConflicts++        -- the prefs of our neighbors+        colors_neighbor_prefs+                        = mkUniqSet+                        $ concat $ map nodePreference nsConflicts++        -- colors that are still valid for us+        colors_ok_ex    = minusUniqSet colors_avail (nodeExclusions node)+        colors_ok       = minusUniqSet colors_ok_ex colors_conflict++        -- the colors that we prefer, and are still ok+        colors_ok_pref  = intersectUniqSets+                                (mkUniqSet $ nodePreference node) colors_ok++        -- the colors that we could choose while being nice to our neighbors+        colors_ok_nice  = minusUniqSet+                                colors_ok colors_neighbor_prefs++        -- the best of all possible worlds..+        colors_ok_pref_nice+                        = intersectUniqSets+                                colors_ok_nice colors_ok_pref++        -- make the decision+        chooseColor++                -- everyone is happy, yay!+                | not $ isEmptyUniqSet colors_ok_pref_nice+                , c : _         <- filter (\x -> elementOfUniqSet x colors_ok_pref_nice)+                                        (nodePreference node)+                = Just c++                -- we've got one of our preferences+                | not $ isEmptyUniqSet colors_ok_pref+                , c : _         <- filter (\x -> elementOfUniqSet x colors_ok_pref)+                                        (nodePreference node)+                = Just c++                -- it wasn't a preference, but it was still ok+                | not $ isEmptyUniqSet colors_ok+                , c : _         <- nonDetEltsUniqSet colors_ok+                -- See Note [Unique Determinism and code generation]+                = Just c++                -- no colors were available for us this time.+                --      looks like we're going around the loop again..+                | otherwise+                = Nothing++   in   chooseColor+++
+ utils/GraphOps.hs view
@@ -0,0 +1,678 @@+-- | Basic operations on graphs.+--++module GraphOps (+        addNode,        delNode,        getNode,       lookupNode,     modNode,+        size,+        union,+        addConflict,    delConflict,    addConflicts,+        addCoalesce,    delCoalesce,+        addExclusion,   addExclusions,+        addPreference,+        coalesceNodes,  coalesceGraph,+        freezeNode,     freezeOneInGraph, freezeAllInGraph,+        scanGraph,+        setColor,+        validateGraph,+        slurpNodeConflictCount+)+where++import GraphBase++import Outputable+import Unique+import UniqSet+import UniqFM++import Data.List        hiding (union)+import Data.Maybe++-- | Lookup a node from the graph.+lookupNode+        :: Uniquable k+        => Graph k cls color+        -> k -> Maybe (Node  k cls color)++lookupNode graph k+        = lookupUFM (graphMap graph) k+++-- | Get a node from the graph, throwing an error if it's not there+getNode+        :: Uniquable k+        => Graph k cls color+        -> k -> Node k cls color++getNode graph k+ = case lookupUFM (graphMap graph) k of+        Just node       -> node+        Nothing         -> panic "ColorOps.getNode: not found"+++-- | Add a node to the graph, linking up its edges+addNode :: Uniquable k+        => k -> Node k cls color+        -> Graph k cls color -> Graph k cls color++addNode k node graph+ = let+        -- add back conflict edges from other nodes to this one+        map_conflict =+          nonDetFoldUniqSet+            -- It's OK to use nonDetFoldUFM here because the+            -- operation is commutative+            (adjustUFM_C (\n -> n { nodeConflicts =+                                      addOneToUniqSet (nodeConflicts n) k}))+            (graphMap graph)+            (nodeConflicts node)++        -- add back coalesce edges from other nodes to this one+        map_coalesce =+          nonDetFoldUniqSet+            -- It's OK to use nonDetFoldUFM here because the+            -- operation is commutative+            (adjustUFM_C (\n -> n { nodeCoalesce =+                                      addOneToUniqSet (nodeCoalesce n) k}))+            map_conflict+            (nodeCoalesce node)++  in    graph+        { graphMap      = addToUFM map_coalesce k node}+++-- | Delete a node and all its edges from the graph.+delNode :: (Uniquable k)+        => k -> Graph k cls color -> Maybe (Graph k cls color)++delNode k graph+        | Just node     <- lookupNode graph k+        = let   -- delete conflict edges from other nodes to this one.+                graph1  = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph+                        $ nonDetEltsUniqSet (nodeConflicts node)++                -- delete coalesce edge from other nodes to this one.+                graph2  = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1+                        $ nonDetEltsUniqSet (nodeCoalesce node)+                        -- See Note [Unique Determinism and code generation]++                -- delete the node+                graph3  = graphMapModify (\fm -> delFromUFM fm k) graph2++          in    Just graph3++        | otherwise+        = Nothing+++-- | Modify a node in the graph.+--      returns Nothing if the node isn't present.+--+modNode :: Uniquable k+        => (Node k cls color -> Node k cls color)+        -> k -> Graph k cls color -> Maybe (Graph k cls color)++modNode f k graph+ = case lookupNode graph k of+        Just Node{}+         -> Just+         $  graphMapModify+                 (\fm   -> let  Just node       = lookupUFM fm k+                                node'           = f node+                           in   addToUFM fm k node')+                graph++        Nothing -> Nothing+++-- | Get the size of the graph, O(n)+size    :: Graph k cls color -> Int++size graph+        = sizeUFM $ graphMap graph+++-- | Union two graphs together.+union   :: Graph k cls color -> Graph k cls color -> Graph k cls color++union   graph1 graph2+        = Graph+        { graphMap              = plusUFM (graphMap graph1) (graphMap graph2) }+++-- | Add a conflict between nodes to the graph, creating the nodes required.+--      Conflicts are virtual regs which need to be colored differently.+addConflict+        :: Uniquable k+        => (k, cls) -> (k, cls)+        -> Graph k cls color -> Graph k cls color++addConflict (u1, c1) (u2, c2)+ = let  addNeighbor u c u'+                = adjustWithDefaultUFM+                        (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' })+                        (newNode u c)  { nodeConflicts = unitUniqSet u' }+                        u++   in   graphMapModify+        ( addNeighbor u1 c1 u2+        . addNeighbor u2 c2 u1)+++-- | Delete a conflict edge. k1 -> k2+--      returns Nothing if the node isn't in the graph+delConflict+        :: Uniquable k+        => k -> k+        -> Graph k cls color -> Maybe (Graph k cls color)++delConflict k1 k2+        = modNode+                (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 })+                k1+++-- | Add some conflicts to the graph, creating nodes if required.+--      All the nodes in the set are taken to conflict with each other.+addConflicts+        :: Uniquable k+        => UniqSet k -> (k -> cls)+        -> Graph k cls color -> Graph k cls color++addConflicts conflicts getClass++        -- just a single node, but no conflicts, create the node anyway.+        | (u : [])      <- nonDetEltsUniqSet conflicts+        = graphMapModify+        $ adjustWithDefaultUFM+                id+                (newNode u (getClass u))+                u++        | otherwise+        = graphMapModify+        $ \fm -> foldl' (\g u  -> addConflictSet1 u getClass conflicts g) fm+                $ nonDetEltsUniqSet conflicts+                -- See Note [Unique Determinism and code generation]+++addConflictSet1 :: Uniquable k+                => k -> (k -> cls) -> UniqSet k+                -> UniqFM (Node k cls color)+                -> UniqFM (Node k cls color)+addConflictSet1 u getClass set+ = case delOneFromUniqSet set u of+    set' -> adjustWithDefaultUFM+                (\node -> node                  { nodeConflicts = unionUniqSets set' (nodeConflicts node) } )+                (newNode u (getClass u))        { nodeConflicts = set' }+                u+++-- | Add an exclusion to the graph, creating nodes if required.+--      These are extra colors that the node cannot use.+addExclusion+        :: (Uniquable k, Uniquable color)+        => k -> (k -> cls) -> color+        -> Graph k cls color -> Graph k cls color++addExclusion u getClass color+        = graphMapModify+        $ adjustWithDefaultUFM+                (\node -> node                  { nodeExclusions = addOneToUniqSet (nodeExclusions node) color })+                (newNode u (getClass u))        { nodeExclusions = unitUniqSet color }+                u++addExclusions+        :: (Uniquable k, Uniquable color)+        => k -> (k -> cls) -> [color]+        -> Graph k cls color -> Graph k cls color++addExclusions u getClass colors graph+        = foldr (addExclusion u getClass) graph colors+++-- | Add a coalescence edge to the graph, creating nodes if requried.+--      It is considered adventageous to assign the same color to nodes in a coalesence.+addCoalesce+        :: Uniquable k+        => (k, cls) -> (k, cls)+        -> Graph k cls color -> Graph k cls color++addCoalesce (u1, c1) (u2, c2)+ = let  addCoalesce u c u'+         =      adjustWithDefaultUFM+                        (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' })+                        (newNode u c)  { nodeCoalesce = unitUniqSet u' }+                        u++   in   graphMapModify+        ( addCoalesce u1 c1 u2+        . addCoalesce u2 c2 u1)+++-- | Delete a coalescence edge (k1 -> k2) from the graph.+delCoalesce+        :: Uniquable k+        => k -> k+        -> Graph k cls color    -> Maybe (Graph k cls color)++delCoalesce k1 k2+        = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 })+                k1+++-- | Add a color preference to the graph, creating nodes if required.+--      The most recently added preference is the most prefered.+--      The algorithm tries to assign a node it's prefered color if possible.+--+addPreference+        :: Uniquable k+        => (k, cls) -> color+        -> Graph k cls color -> Graph k cls color++addPreference (u, c) color+        = graphMapModify+        $ adjustWithDefaultUFM+                (\node -> node { nodePreference = color : (nodePreference node) })+                (newNode u c)  { nodePreference = [color] }+                u+++-- | Do aggressive coalescing on this graph.+--      returns the new graph and the list of pairs of nodes that got coalesced together.+--      for each pair, the resulting node will have the least key and be second in the pair.+--+coalesceGraph+        :: (Uniquable k, Ord k, Eq cls, Outputable k)+        => Bool                 -- ^ If True, coalesce nodes even if this might make the graph+                                --      less colorable (aggressive coalescing)+        -> Triv k cls color+        -> Graph k cls color+        -> ( Graph k cls color+           , [(k, k)])          -- pairs of nodes that were coalesced, in the order that the+                                --      coalescing was applied.++coalesceGraph aggressive triv graph+        = coalesceGraph' aggressive triv graph []++coalesceGraph'+        :: (Uniquable k, Ord k, Eq cls, Outputable k)+        => Bool+        -> Triv k cls color+        -> Graph k cls color+        -> [(k, k)]+        -> ( Graph k cls color+           , [(k, k)])+coalesceGraph' aggressive triv graph kkPairsAcc+ = let+        -- find all the nodes that have coalescence edges+        cNodes  = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node))+                $ nonDetEltsUFM $ graphMap graph+                -- See Note [Unique Determinism and code generation]++        -- build a list of pairs of keys for node's we'll try and coalesce+        --      every pair of nodes will appear twice in this list+        --      ie [(k1, k2), (k2, k1) ... ]+        --      This is ok, GrapOps.coalesceNodes handles this and it's convenient for+        --      build a list of what nodes get coalesced together for later on.+        --+        cList   = [ (nodeId node1, k2)+                        | node1 <- cNodes+                        , k2    <- nonDetEltsUniqSet $ nodeCoalesce node1 ]+                        -- See Note [Unique Determinism and code generation]++        -- do the coalescing, returning the new graph and a list of pairs of keys+        --      that got coalesced together.+        (graph', mPairs)+                = mapAccumL (coalesceNodes aggressive triv) graph cList++        -- keep running until there are no more coalesces can be found+   in   case catMaybes mPairs of+         []     -> (graph', reverse kkPairsAcc)+         pairs  -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc)+++-- | Coalesce this pair of nodes unconditionally \/ aggressively.+--      The resulting node is the one with the least key.+--+--      returns: Just    the pair of keys if the nodes were coalesced+--                       the second element of the pair being the least one+--+--               Nothing if either of the nodes weren't in the graph++coalesceNodes+        :: (Uniquable k, Ord k, Eq cls)+        => Bool                 -- ^ If True, coalesce nodes even if this might make the graph+                                --      less colorable (aggressive coalescing)+        -> Triv  k cls color+        -> Graph k cls color+        -> (k, k)               -- ^ keys of the nodes to be coalesced+        -> (Graph k cls color, Maybe (k, k))++coalesceNodes aggressive triv graph (k1, k2)+        | (kMin, kMax)  <- if k1 < k2+                                then (k1, k2)+                                else (k2, k1)++        -- the nodes being coalesced must be in the graph+        , Just nMin     <- lookupNode graph kMin+        , Just nMax     <- lookupNode graph kMax++        -- can't coalesce conflicting modes+        , not $ elementOfUniqSet kMin (nodeConflicts nMax)+        , not $ elementOfUniqSet kMax (nodeConflicts nMin)++        -- can't coalesce the same node+        , nodeId nMin /= nodeId nMax++        = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax++        -- don't do the coalescing after all+        | otherwise+        = (graph, Nothing)++coalesceNodes_merge+        :: (Uniquable k, Eq cls)+        => Bool+        -> Triv  k cls color+        -> Graph k cls color+        -> k -> k+        -> Node k cls color+        -> Node k cls color+        -> (Graph k cls color, Maybe (k, k))++coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax++        -- sanity checks+        | nodeClass nMin /= nodeClass nMax+        = error "GraphOps.coalesceNodes: can't coalesce nodes of different classes."++        | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax))+        = error "GraphOps.coalesceNodes: can't coalesce colored nodes."++        ---+        | otherwise+        = let+                -- the new node gets all the edges from its two components+                node    =+                 Node   { nodeId                = kMin+                        , nodeClass             = nodeClass nMin+                        , nodeColor             = Nothing++                        -- nodes don't conflict with themselves..+                        , nodeConflicts+                                = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax))+                                        `delOneFromUniqSet` kMin+                                        `delOneFromUniqSet` kMax++                        , nodeExclusions        = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax)+                        , nodePreference        = nodePreference nMin ++ nodePreference nMax++                        -- nodes don't coalesce with themselves..+                        , nodeCoalesce+                                = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax))+                                        `delOneFromUniqSet` kMin+                                        `delOneFromUniqSet` kMax+                        }++          in    coalesceNodes_check aggressive triv graph kMin kMax node++coalesceNodes_check+        :: Uniquable k+        => Bool+        -> Triv  k cls color+        -> Graph k cls color+        -> k -> k+        -> Node k cls color+        -> (Graph k cls color, Maybe (k, k))++coalesceNodes_check aggressive triv graph kMin kMax node++        -- Unless we're coalescing aggressively, if the result node is not trivially+        --      colorable then don't do the coalescing.+        | not aggressive+        , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)+        = (graph, Nothing)++        | otherwise+        = let -- delete the old nodes from the graph and add the new one+                Just graph1     = delNode kMax graph+                Just graph2     = delNode kMin graph1+                graph3          = addNode kMin node graph2++          in    (graph3, Just (kMax, kMin))+++-- | Freeze a node+--      This is for the iterative coalescer.+--      By freezing a node we give up on ever coalescing it.+--      Move all its coalesce edges into the frozen set - and update+--      back edges from other nodes.+--+freezeNode+        :: Uniquable k+        => k                    -- ^ key of the node to freeze+        -> Graph k cls color    -- ^ the graph+        -> Graph k cls color    -- ^ graph with that node frozen++freezeNode k+  = graphMapModify+  $ \fm ->+    let -- freeze all the edges in the node to be frozen+        Just node = lookupUFM fm k+        node'   = node+                { nodeCoalesce          = emptyUniqSet }++        fm1     = addToUFM fm k node'++        -- update back edges pointing to this node+        freezeEdge k node+         = if elementOfUniqSet k (nodeCoalesce node)+                then node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k }+                else node       -- panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set"+                                -- If the edge isn't actually in the coelesce set then just ignore it.++        fm2     = nonDetFoldUniqSet (adjustUFM_C (freezeEdge k)) fm1+                    -- It's OK to use nonDetFoldUFM here because the operation+                    -- is commutative+                        $ nodeCoalesce node++    in  fm2+++-- | Freeze one node in the graph+--      This if for the iterative coalescer.+--      Look for a move related node of low degree and freeze it.+--+--      We probably don't need to scan the whole graph looking for the node of absolute+--      lowest degree. Just sample the first few and choose the one with the lowest+--      degree out of those. Also, we don't make any distinction between conflicts of different+--      classes.. this is just a heuristic, after all.+--+--      IDEA:   freezing a node might free it up for Simplify.. would be good to check for triv+--              right here, and add it to a worklist if known triv\/non-move nodes.+--+freezeOneInGraph+        :: (Uniquable k)+        => Graph k cls color+        -> ( Graph k cls color          -- the new graph+           , Bool )                     -- whether we found a node to freeze++freezeOneInGraph graph+ = let  compareNodeDegree n1 n2+                = compare (sizeUniqSet $ nodeConflicts n1) (sizeUniqSet $ nodeConflicts n2)++        candidates+                = sortBy compareNodeDegree+                $ take 5        -- 5 isn't special, it's just a small number.+                $ scanGraph (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) graph++   in   case candidates of++         -- there wasn't anything available to freeze+         []     -> (graph, False)++         -- we found something to freeze+         (n : _)+          -> ( freezeNode (nodeId n) graph+             , True)+++-- | Freeze all the nodes in the graph+--      for debugging the iterative allocator.+--+freezeAllInGraph+        :: (Uniquable k)+        => Graph k cls color+        -> Graph k cls color++freezeAllInGraph graph+        = foldr freezeNode graph+                $ map nodeId+                $ nonDetEltsUFM $ graphMap graph+                -- See Note [Unique Determinism and code generation]+++-- | Find all the nodes in the graph that meet some criteria+--+scanGraph+        :: (Node k cls color -> Bool)+        -> Graph k cls color+        -> [Node k cls color]++scanGraph match graph+        = filter match $ nonDetEltsUFM $ graphMap graph+          -- See Note [Unique Determinism and code generation]+++-- | validate the internal structure of a graph+--      all its edges should point to valid nodes+--      If they don't then throw an error+--+validateGraph+        :: (Uniquable k, Outputable k, Eq color)+        => SDoc                         -- ^ extra debugging info to display on error+        -> Bool                         -- ^ whether this graph is supposed to be colored.+        -> Graph k cls color            -- ^ graph to validate+        -> Graph k cls color            -- ^ validated graph++validateGraph doc isColored graph++        -- Check that all edges point to valid nodes.+        | edges         <- unionManyUniqSets+                                (  (map nodeConflicts       $ nonDetEltsUFM $ graphMap graph)+                                ++ (map nodeCoalesce        $ nonDetEltsUFM $ graphMap graph))++        , nodes         <- mkUniqSet $ map nodeId $ nonDetEltsUFM $ graphMap graph+        , badEdges      <- minusUniqSet edges nodes+        , not $ isEmptyUniqSet badEdges+        = pprPanic "GraphOps.validateGraph"+                (  text "Graph has edges that point to non-existent nodes"+                $$ text "  bad edges: " <> pprUFM (getUniqSet badEdges) (vcat . map ppr)+                $$ doc )++        -- Check that no conflicting nodes have the same color+        | badNodes      <- filter (not . (checkNode graph))+                        $ nonDetEltsUFM $ graphMap graph+                           -- See Note [Unique Determinism and code generation]+        , not $ null badNodes+        = pprPanic "GraphOps.validateGraph"+                (  text "Node has same color as one of it's conflicts"+                $$ text "  bad nodes: " <> hcat (map (ppr . nodeId) badNodes)+                $$ doc)++        -- If this is supposed to be a colored graph,+        --      check that all nodes have a color.+        | isColored+        , badNodes      <- filter (\n -> isNothing $ nodeColor n)+                        $  nonDetEltsUFM $ graphMap graph+        , not $ null badNodes+        = pprPanic "GraphOps.validateGraph"+                (  text "Supposably colored graph has uncolored nodes."+                $$ text "  uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes)+                $$ doc )+++        -- graph looks ok+        | otherwise+        = graph+++-- | If this node is colored, check that all the nodes which+--      conflict with it have different colors.+checkNode+        :: (Uniquable k, Eq color)+        => Graph k cls color+        -> Node  k cls color+        -> Bool                 -- ^ True if this node is ok++checkNode graph node+        | Just color            <- nodeColor node+        , Just neighbors        <- sequence $ map (lookupNode graph)+                                $  nonDetEltsUniqSet $ nodeConflicts node+            -- See Note [Unique Determinism and code generation]++        , neighbourColors       <- catMaybes $ map nodeColor neighbors+        , elem color neighbourColors+        = False++        | otherwise+        = True++++-- | Slurp out a map of how many nodes had a certain number of conflict neighbours++slurpNodeConflictCount+        :: Graph k cls color+        -> UniqFM (Int, Int)    -- ^ (conflict neighbours, num nodes with that many conflicts)++slurpNodeConflictCount graph+        = addListToUFM_C+                (\(c1, n1) (_, n2) -> (c1, n1 + n2))+                emptyUFM+        $ map   (\node+                  -> let count  = sizeUniqSet $ nodeConflicts node+                     in  (count, (count, 1)))+        $ nonDetEltsUFM+        -- See Note [Unique Determinism and code generation]+        $ graphMap graph+++-- | Set the color of a certain node+setColor+        :: Uniquable k+        => k -> color+        -> Graph k cls color -> Graph k cls color++setColor u color+        = graphMapModify+        $ adjustUFM_C+                (\n -> n { nodeColor = Just color })+                u+++{-# INLINE adjustWithDefaultUFM #-}+adjustWithDefaultUFM+        :: Uniquable k+        => (a -> a) -> a -> k+        -> UniqFM a -> UniqFM a++adjustWithDefaultUFM f def k map+        = addToUFM_C+                (\old _ -> f old)+                map+                k def++-- Argument order different from UniqFM's adjustUFM+{-# INLINE adjustUFM_C #-}+adjustUFM_C+        :: Uniquable k+        => (a -> a)+        -> k -> UniqFM a -> UniqFM a++adjustUFM_C f k map+ = case lookupUFM map k of+        Nothing -> map+        Just a  -> addToUFM map k (f a)+
+ utils/GraphPpr.hs view
@@ -0,0 +1,171 @@++-- | Pretty printing of graphs.++module GraphPpr (+        dumpGraph,+        dotGraph+)+where++import GraphBase++import Outputable+import Unique+import UniqSet+import UniqFM++import Data.List+import Data.Maybe+++-- | Pretty print a graph in a somewhat human readable format.+dumpGraph+        :: (Outputable k, Outputable color)+        => Graph k cls color -> SDoc++dumpGraph graph+        =  text "Graph"+        $$ pprUFM (graphMap graph) (vcat . map dumpNode)++dumpNode+        :: (Outputable k, Outputable color)+        => Node k cls color -> SDoc++dumpNode node+        =  text "Node " <> ppr (nodeId node)+        $$ text "conflicts "+                <> parens (int (sizeUniqSet $ nodeConflicts node))+                <> text " = "+                <> ppr (nodeConflicts node)++        $$ text "exclusions "+                <> parens (int (sizeUniqSet $ nodeExclusions node))+                <> text " = "+                <> ppr (nodeExclusions node)++        $$ text "coalesce "+                <> parens (int (sizeUniqSet $ nodeCoalesce node))+                <> text " = "+                <> ppr (nodeCoalesce node)++        $$ space++++-- | Pretty print a graph in graphviz .dot format.+--      Conflicts get solid edges.+--      Coalescences get dashed edges.+dotGraph+        :: ( Uniquable k+           , Outputable k, Outputable cls, Outputable color)+        => (color -> SDoc)  -- ^ What graphviz color to use for each node color+                            --  It's usually safe to return X11 style colors here,+                            --  ie "red", "green" etc or a hex triplet #aaff55 etc+        -> Triv k cls color+        -> Graph k cls color -> SDoc++dotGraph colorMap triv graph+ = let  nodes   = nonDetEltsUFM $ graphMap graph+                  -- See Note [Unique Determinism and code generation]+   in   vcat+                (  [ text "graph G {" ]+                ++ map (dotNode colorMap triv) nodes+                ++ (catMaybes $ snd $ mapAccumL dotNodeEdges emptyUniqSet nodes)+                ++ [ text "}"+                   , space ])+++dotNode :: ( Outputable k, Outputable cls, Outputable color)+        => (color -> SDoc)+        -> Triv k cls color+        -> Node k cls color -> SDoc++dotNode colorMap triv node+ = let  name    = ppr $ nodeId node+        cls     = ppr $ nodeClass node++        excludes+                = hcat $ punctuate space+                $ map (\n -> text "-" <> ppr n)+                $ nonDetEltsUniqSet $ nodeExclusions node+                -- See Note [Unique Determinism and code generation]++        preferences+                = hcat $ punctuate space+                $ map (\n -> text "+" <> ppr n)+                $ nodePreference node++        expref  = if and [isEmptyUniqSet (nodeExclusions node), null (nodePreference node)]+                        then empty+                        else text "\\n" <> (excludes <+> preferences)++        -- if the node has been colored then show that,+        --      otherwise indicate whether it looks trivially colorable.+        color+                | Just c        <- nodeColor node+                = text "\\n(" <> ppr c <> text ")"++                | triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)+                = text "\\n(" <> text "triv" <> text ")"++                | otherwise+                = text "\\n(" <> text "spill?" <> text ")"++        label   =  name <> text " :: " <> cls+                <> expref+                <> color++        pcolorC = case nodeColor node of+                        Nothing -> text "style=filled fillcolor=white"+                        Just c  -> text "style=filled fillcolor=" <> doubleQuotes (colorMap c)+++        pout    = text "node [label=" <> doubleQuotes label <> space <> pcolorC <> text "]"+                <> space <> doubleQuotes name+                <> text ";"++ in     pout+++-- | Nodes in the graph are doubly linked, but we only want one edge for each+--      conflict if the graphviz graph. Traverse over the graph, but make sure+--      to only print the edges for each node once.++dotNodeEdges+        :: ( Uniquable k+           , Outputable k)+        => UniqSet k+        -> Node k cls color+        -> (UniqSet k, Maybe SDoc)++dotNodeEdges visited node+        | elementOfUniqSet (nodeId node) visited+        = ( visited+          , Nothing)++        | otherwise+        = let   dconflicts+                        = map (dotEdgeConflict (nodeId node))+                        $ nonDetEltsUniqSet+                        -- See Note [Unique Determinism and code generation]+                        $ minusUniqSet (nodeConflicts node) visited++                dcoalesces+                        = map (dotEdgeCoalesce (nodeId node))+                        $ nonDetEltsUniqSet+                        -- See Note [Unique Determinism and code generation]+                        $ minusUniqSet (nodeCoalesce node) visited++                out     =  vcat dconflicts+                        $$ vcat dcoalesces++          in    ( addOneToUniqSet visited (nodeId node)+                , Just out)++        where   dotEdgeConflict u1 u2+                        = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2)+                        <> text ";"++                dotEdgeCoalesce u1 u2+                        = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2)+                        <> space <> text "[ style = dashed ];"
+ utils/IOEnv.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE CPP #-}++--+-- (c) The University of Glasgow 2002-2006+--+-- The IO Monad with an environment+--+-- The environment is passed around as a Reader monad but+-- as its in the IO monad, mutable references can be used+-- for updating state.+--++module IOEnv (+        IOEnv, -- Instance of Monad++        -- Monad utilities+        module MonadUtils,++        -- Errors+        failM, failWithM,+        IOEnvFailure(..),++        -- Getting at the environment+        getEnv, setEnv, updEnv,++        runIOEnv, unsafeInterleaveM, uninterruptibleMaskM_,+        tryM, tryAllM, tryMostM, fixM,++        -- I/O operations+        IORef, newMutVar, readMutVar, writeMutVar, updMutVar,+        atomicUpdMutVar, atomicUpdMutVar'+  ) where++import DynFlags+import Exception+import Module+import Panic++import Data.IORef       ( IORef, newIORef, readIORef, writeIORef, modifyIORef,+                          atomicModifyIORef, atomicModifyIORef' )+import System.IO.Unsafe ( unsafeInterleaveIO )+import System.IO        ( fixIO )+import Control.Monad+#if __GLASGOW_HASKELL__ > 710+import qualified Control.Monad.Fail as MonadFail+#endif+import MonadUtils+import Control.Applicative (Alternative(..))++----------------------------------------------------------------------+-- Defining the monad type+----------------------------------------------------------------------+++newtype IOEnv env a = IOEnv (env -> IO a)++unIOEnv :: IOEnv env a -> (env -> IO a)+unIOEnv (IOEnv m) = m++instance Monad (IOEnv m) where+    (>>=)  = thenM+    (>>)   = (*>)+    fail _ = failM -- Ignore the string++#if __GLASGOW_HASKELL__ > 710+instance MonadFail.MonadFail (IOEnv m) where+    fail _ = failM -- Ignore the string+#endif+++instance Applicative (IOEnv m) where+    pure = returnM+    IOEnv f <*> IOEnv x = IOEnv (\ env -> f env <*> x env )+    (*>) = thenM_++instance Functor (IOEnv m) where+    fmap f (IOEnv m) = IOEnv (\ env -> fmap f (m env))++returnM :: a -> IOEnv env a+returnM a = IOEnv (\ _ -> return a)++thenM :: IOEnv env a -> (a -> IOEnv env b) -> IOEnv env b+thenM (IOEnv m) f = IOEnv (\ env -> do { r <- m env ;+                                         unIOEnv (f r) env })++thenM_ :: IOEnv env a -> IOEnv env b -> IOEnv env b+thenM_ (IOEnv m) f = IOEnv (\ env -> do { _ <- m env ; unIOEnv f env })++failM :: IOEnv env a+failM = IOEnv (\ _ -> throwIO IOEnvFailure)++failWithM :: String -> IOEnv env a+failWithM s = IOEnv (\ _ -> ioError (userError s))++data IOEnvFailure = IOEnvFailure++instance Show IOEnvFailure where+    show IOEnvFailure = "IOEnv failure"++instance Exception IOEnvFailure++instance ExceptionMonad (IOEnv a) where+  gcatch act handle =+      IOEnv $ \s -> unIOEnv act s `gcatch` \e -> unIOEnv (handle e) s+  gmask f =+      IOEnv $ \s -> gmask $ \io_restore ->+                             let+                                g_restore (IOEnv m) = IOEnv $ \s -> io_restore (m s)+                             in+                                unIOEnv (f g_restore) s++instance ContainsDynFlags env => HasDynFlags (IOEnv env) where+    getDynFlags = do env <- getEnv+                     return $ extractDynFlags env++instance ContainsModule env => HasModule (IOEnv env) where+    getModule = do env <- getEnv+                   return $ extractModule env++----------------------------------------------------------------------+-- Fundamental combinators specific to the monad+----------------------------------------------------------------------+++---------------------------+runIOEnv :: env -> IOEnv env a -> IO a+runIOEnv env (IOEnv m) = m env+++---------------------------+{-# NOINLINE fixM #-}+  -- Aargh!  Not inlining fixM alleviates a space leak problem.+  -- Normally fixM is used with a lazy tuple match: if the optimiser is+  -- shown the definition of fixM, it occasionally transforms the code+  -- in such a way that the code generator doesn't spot the selector+  -- thunks.  Sigh.++fixM :: (a -> IOEnv env a) -> IOEnv env a+fixM f = IOEnv (\ env -> fixIO (\ r -> unIOEnv (f r) env))+++---------------------------+tryM :: IOEnv env r -> IOEnv env (Either IOEnvFailure r)+-- Reflect UserError exceptions (only) into IOEnv monad+-- Other exceptions are not caught; they are simply propagated as exns+--+-- The idea is that errors in the program being compiled will give rise+-- to UserErrors.  But, say, pattern-match failures in GHC itself should+-- not be caught here, else they'll be reported as errors in the program+-- begin compiled!+tryM (IOEnv thing) = IOEnv (\ env -> tryIOEnvFailure (thing env))++tryIOEnvFailure :: IO a -> IO (Either IOEnvFailure a)+tryIOEnvFailure = try++-- XXX We shouldn't be catching everything, e.g. timeouts+tryAllM :: IOEnv env r -> IOEnv env (Either SomeException r)+-- Catch *all* exceptions+-- This is used when running a Template-Haskell splice, when+-- even a pattern-match failure is a programmer error+tryAllM (IOEnv thing) = IOEnv (\ env -> try (thing env))++tryMostM :: IOEnv env r -> IOEnv env (Either SomeException r)+tryMostM (IOEnv thing) = IOEnv (\ env -> tryMost (thing env))++---------------------------+unsafeInterleaveM :: IOEnv env a -> IOEnv env a+unsafeInterleaveM (IOEnv m) = IOEnv (\ env -> unsafeInterleaveIO (m env))++uninterruptibleMaskM_ :: IOEnv env a -> IOEnv env a+uninterruptibleMaskM_ (IOEnv m) = IOEnv (\ env -> uninterruptibleMask_ (m env))++----------------------------------------------------------------------+-- Alternative/MonadPlus+----------------------------------------------------------------------++instance Alternative (IOEnv env) where+    empty   = IOEnv (const empty)+    m <|> n = IOEnv (\env -> unIOEnv m env <|> unIOEnv n env)++instance MonadPlus (IOEnv env)++----------------------------------------------------------------------+-- Accessing input/output+----------------------------------------------------------------------++instance MonadIO (IOEnv env) where+    liftIO io = IOEnv (\ _ -> io)++newMutVar :: a -> IOEnv env (IORef a)+newMutVar val = liftIO (newIORef val)++writeMutVar :: IORef a -> a -> IOEnv env ()+writeMutVar var val = liftIO (writeIORef var val)++readMutVar :: IORef a -> IOEnv env a+readMutVar var = liftIO (readIORef var)++updMutVar :: IORef a -> (a -> a) -> IOEnv env ()+updMutVar var upd = liftIO (modifyIORef var upd)++-- | Atomically update the reference.  Does not force the evaluation of the+-- new variable contents.  For strict update, use 'atomicUpdMutVar''.+atomicUpdMutVar :: IORef a -> (a -> (a, b)) -> IOEnv env b+atomicUpdMutVar var upd = liftIO (atomicModifyIORef var upd)++-- | Strict variant of 'atomicUpdMutVar'.+atomicUpdMutVar' :: IORef a -> (a -> (a, b)) -> IOEnv env b+atomicUpdMutVar' var upd = liftIO (atomicModifyIORef' var upd)++----------------------------------------------------------------------+-- Accessing the environment+----------------------------------------------------------------------++getEnv :: IOEnv env env+{-# INLINE getEnv #-}+getEnv = IOEnv (\ env -> return env)++-- | Perform a computation with a different environment+setEnv :: env' -> IOEnv env' a -> IOEnv env a+{-# INLINE setEnv #-}+setEnv new_env (IOEnv m) = IOEnv (\ _ -> m new_env)++-- | Perform a computation with an altered environment+updEnv :: (env -> env') -> IOEnv env' a -> IOEnv env a+{-# INLINE updEnv #-}+updEnv upd (IOEnv m) = IOEnv (\ env -> m (upd env))
+ utils/Json.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE GADTs #-}+module Json where++import Outputable+import Data.Char+import Numeric++-- | Simple data type to represent JSON documents.+data JsonDoc where+  JSNull :: JsonDoc+  JSBool :: Bool -> JsonDoc+  JSInt  :: Int  -> JsonDoc+  JSString :: String -> JsonDoc+  JSArray :: [JsonDoc] -> JsonDoc+  JSObject :: [(String, JsonDoc)] -> JsonDoc+++-- This is simple and slow as it is only used for error reporting+renderJSON :: JsonDoc -> SDoc+renderJSON d =+  case d of+    JSNull -> text "null"+    JSBool b -> text $ if b then "true" else "false"+    JSInt    n -> ppr n+    JSString s -> doubleQuotes $ text $ escapeJsonString s+    JSArray as -> brackets $ pprList renderJSON as+    JSObject fs -> braces $ pprList renderField fs+  where+    renderField :: (String, JsonDoc) -> SDoc+    renderField (s, j) = doubleQuotes (text s) <>  colon <+> renderJSON j++    pprList pp xs = hcat (punctuate comma (map pp xs))++escapeJsonString :: String -> String+escapeJsonString = concatMap escapeChar+  where+    escapeChar '\b' = "\\b"+    escapeChar '\f' = "\\f"+    escapeChar '\n' = "\\n"+    escapeChar '\r' = "\\r"+    escapeChar '\t' = "\\t"+    escapeChar '"'  = "\""+    escapeChar '\\'  = "\\\\"+    escapeChar c | isControl c || fromEnum c >= 0x7f  = uni_esc c+    escapeChar c = [c]++    uni_esc c = "\\u" ++ (pad 4 (showHex (fromEnum c) ""))++    pad n cs  | len < n   = replicate (n-len) '0' ++ cs+                          | otherwise = cs+                                   where len = length cs++class ToJson a where+  json :: a -> JsonDoc
+ utils/ListSetOps.hs view
@@ -0,0 +1,155 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[ListSetOps]{Set-like operations on lists}+-}++{-# LANGUAGE CPP #-}++module ListSetOps (+        unionLists, minusList,++        -- Association lists+        Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing,++        -- Duplicate handling+        hasNoDups, runs, removeDups, findDupsEq,+        equivClasses,++        -- Indexing+        getNth+   ) where++#include "HsVersions.h"++import Outputable+import Util++import Data.List++getNth :: Outputable a => [a] -> Int -> a+getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n $$ ppr xs )+             xs !! n++{-+************************************************************************+*                                                                      *+        Treating lists as sets+        Assumes the lists contain no duplicates, but are unordered+*                                                                      *+************************************************************************+-}+++unionLists :: (Outputable a, Eq a) => [a] -> [a] -> [a]+-- Assumes that the arguments contain no duplicates+unionLists xs ys+  = WARN(length xs > 100 || length ys > 100, ppr xs $$ ppr ys)+    [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys++minusList :: (Eq a) => [a] -> [a] -> [a]+-- Everything in the first list that is not in the second list:+minusList xs ys = [ x | x <- xs, isn'tIn "minusList" x ys]++{-+************************************************************************+*                                                                      *+\subsection[Utils-assoc]{Association lists}+*                                                                      *+************************************************************************++Inefficient finite maps based on association lists and equality.+-}++-- A finite mapping based on equality and association lists+type Assoc a b = [(a,b)]++assoc             :: (Eq a) => String -> Assoc a b -> a -> b+assocDefault      :: (Eq a) => b -> Assoc a b -> a -> b+assocUsing        :: (a -> a -> Bool) -> String -> Assoc a b -> a -> b+assocMaybe        :: (Eq a) => Assoc a b -> a -> Maybe b+assocDefaultUsing :: (a -> a -> Bool) -> b -> Assoc a b -> a -> b++assocDefaultUsing _  deflt []             _   = deflt+assocDefaultUsing eq deflt ((k,v) : rest) key+  | k `eq` key = v+  | otherwise  = assocDefaultUsing eq deflt rest key++assoc crash_msg         list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key+assocDefault deflt      list key = assocDefaultUsing (==) deflt list key+assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key++assocMaybe alist key+  = lookup alist+  where+    lookup []             = Nothing+    lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest++{-+************************************************************************+*                                                                      *+\subsection[Utils-dups]{Duplicate-handling}+*                                                                      *+************************************************************************+-}++hasNoDups :: (Eq a) => [a] -> Bool++hasNoDups xs = f [] xs+  where+    f _           []     = True+    f seen_so_far (x:xs) = if x `is_elem` seen_so_far+                           then False+                           else f (x:seen_so_far) xs++    is_elem = isIn "hasNoDups"++equivClasses :: (a -> a -> Ordering) -- Comparison+             -> [a]+             -> [[a]]++equivClasses _         []  = []+equivClasses _   stuff@[_] = [stuff]+equivClasses cmp items     = runs eq (sortBy cmp items)+  where+    eq a b = case cmp a b of { EQ -> True; _ -> False }++{-+The first cases in @equivClasses@ above are just to cut to the point+more quickly...++@runs@ groups a list into a list of lists, each sublist being a run of+identical elements of the input list. It is passed a predicate @p@ which+tells when two elements are equal.+-}++runs :: (a -> a -> Bool) -- Equality+     -> [a]+     -> [[a]]++runs _ []     = []+runs p (x:xs) = case (span (p x) xs) of+                (first, rest) -> (x:first) : (runs p rest)++removeDups :: (a -> a -> Ordering) -- Comparison function+           -> [a]+           -> ([a],     -- List with no duplicates+               [[a]])   -- List of duplicate groups.  One representative from+                        -- each group appears in the first result++removeDups _   []  = ([], [])+removeDups _   [x] = ([x],[])+removeDups cmp xs+  = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') ->+    (xs', dups) }+  where+    collect_dups _           []         = panic "ListSetOps: removeDups"+    collect_dups dups_so_far [x]        = (dups_so_far,      x)+    collect_dups dups_so_far dups@(x:_) = (dups:dups_so_far, x)++findDupsEq :: (a->a->Bool) -> [a] -> [[a]]+findDupsEq _  [] = []+findDupsEq eq (x:xs) | null eq_xs  = findDupsEq eq xs+                     | otherwise   = (x:eq_xs) : findDupsEq eq neq_xs+    where (eq_xs, neq_xs) = partition (eq x) xs
+ utils/ListT.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-------------------------------------------------------------------------+-- |+-- Module      : Control.Monad.Logic+-- Copyright   : (c) Dan Doel+-- License     : BSD3+--+-- Maintainer  : dan.doel@gmail.com+-- Stability   : experimental+-- Portability : non-portable (multi-parameter type classes)+--+-- A backtracking, logic programming monad.+--+--    Adapted from the paper+--    /Backtracking, Interleaving, and Terminating+--        Monad Transformers/, by+--    Oleg Kiselyov, Chung-chieh Shan, Daniel P. Friedman, Amr Sabry+--    (<http://www.cs.rutgers.edu/~ccshan/logicprog/ListT-icfp2005.pdf>).+-------------------------------------------------------------------------++module ListT (+    ListT(..),+    runListT,+    select,+    fold+  ) where++import Control.Applicative++import Control.Monad++-------------------------------------------------------------------------+-- | A monad transformer for performing backtracking computations+-- layered over another monad 'm'+newtype ListT m a =+    ListT { unListT :: forall r. (a -> m r -> m r) -> m r -> m r }++select :: Monad m => [a] -> ListT m a+select xs = foldr (<|>) mzero (map pure xs)++fold :: ListT m a -> (a -> m r -> m r) -> m r -> m r+fold = runListT++-------------------------------------------------------------------------+-- | Runs a ListT computation with the specified initial success and+-- failure continuations.+runListT :: ListT m a -> (a -> m r -> m r) -> m r -> m r+runListT = unListT++instance Functor (ListT f) where+    fmap f lt = ListT $ \sk fk -> unListT lt (sk . f) fk++instance Applicative (ListT f) where+    pure a = ListT $ \sk fk -> sk a fk+    f <*> a = ListT $ \sk fk -> unListT f (\g fk' -> unListT a (sk . g) fk') fk++instance Alternative (ListT f) where+    empty = ListT $ \_ fk -> fk+    f1 <|> f2 = ListT $ \sk fk -> unListT f1 sk (unListT f2 sk fk)++instance Monad (ListT m) where+    m >>= f = ListT $ \sk fk -> unListT m (\a fk' -> unListT (f a) sk fk') fk+    fail _ = ListT $ \_ fk -> fk++instance MonadPlus (ListT m) where+    mzero = ListT $ \_ fk -> fk+    m1 `mplus` m2 = ListT $ \sk fk -> unListT m1 sk (unListT m2 sk fk)
+ utils/Maybes.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++module Maybes (+        module Data.Maybe,++        MaybeErr(..), -- Instance of Monad+        failME, isSuccess,++        orElse,+        firstJust, firstJusts,+        whenIsJust,+        expectJust,++        -- * MaybeT+        MaybeT(..), liftMaybeT, tryMaybeT+    ) where++import Control.Monad+import Control.Monad.Trans.Maybe+import Control.Exception (catch, SomeException(..))+import Data.Maybe+import Util (HasCallStack)++infixr 4 `orElse`++{-+************************************************************************+*                                                                      *+\subsection[Maybe type]{The @Maybe@ type}+*                                                                      *+************************************************************************+-}++firstJust :: Maybe a -> Maybe a -> Maybe a+firstJust a b = firstJusts [a, b]++-- | Takes a list of @Maybes@ and returns the first @Just@ if there is one, or+-- @Nothing@ otherwise.+firstJusts :: [Maybe a] -> Maybe a+firstJusts = msum++expectJust :: HasCallStack => String -> Maybe a -> a+{-# INLINE expectJust #-}+expectJust _   (Just x) = x+expectJust err Nothing  = error ("expectJust " ++ err)++whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()+whenIsJust (Just x) f = f x+whenIsJust Nothing  _ = return ()++-- | Flipped version of @fromMaybe@, useful for chaining.+orElse :: Maybe a -> a -> a+orElse = flip fromMaybe++{-+************************************************************************+*                                                                      *+\subsection[MaybeT type]{The @MaybeT@ monad transformer}+*                                                                      *+************************************************************************+-}++-- We had our own MaybeT in the past. Now we reuse transformer's MaybeT++liftMaybeT :: Monad m => m a -> MaybeT m a+liftMaybeT act = MaybeT $ Just `liftM` act++-- | Try performing an 'IO' action, failing on error.+tryMaybeT :: IO a -> MaybeT IO a+tryMaybeT action = MaybeT $ catch (Just `fmap` action) handler+  where+    handler (SomeException _) = return Nothing++{-+************************************************************************+*                                                                      *+\subsection[MaybeErr type]{The @MaybeErr@ type}+*                                                                      *+************************************************************************+-}++data MaybeErr err val = Succeeded val | Failed err++instance Functor (MaybeErr err) where+  fmap = liftM++instance Applicative (MaybeErr err) where+  pure  = Succeeded+  (<*>) = ap++instance Monad (MaybeErr err) where+  Succeeded v >>= k = k v+  Failed e    >>= _ = Failed e++isSuccess :: MaybeErr err val -> Bool+isSuccess (Succeeded {}) = True+isSuccess (Failed {})    = False++failME :: err -> MaybeErr err val+failME e = Failed e
+ utils/MonadUtils.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE CPP #-}++-- | Utilities related to Monad and Applicative classes+--   Mostly for backwards compatibility.++module MonadUtils+        ( Applicative(..)+        , (<$>)++        , MonadFix(..)+        , MonadIO(..)++        , liftIO1, liftIO2, liftIO3, liftIO4++        , zipWith3M, zipWith3M_, zipWith4M, zipWithAndUnzipM+        , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M, mapAndUnzip5M+        , mapAccumLM+        , mapSndM+        , concatMapM+        , mapMaybeM+        , fmapMaybeM, fmapEitherM+        , anyM, allM, orM+        , foldlM, foldlM_, foldrM+        , maybeMapM+        , whenM, unlessM+        ) where++-------------------------------------------------------------------------------+-- Imports+-------------------------------------------------------------------------------++import Maybes++import Control.Monad+import Control.Monad.Fix+import Control.Monad.IO.Class+#if __GLASGOW_HASKELL__ < 800+import Control.Monad.Trans.Error () -- for orphan `instance MonadPlus IO`+#endif++-------------------------------------------------------------------------------+-- Lift combinators+--  These are used throughout the compiler+-------------------------------------------------------------------------------++-- | Lift an 'IO' operation with 1 argument into another monad+liftIO1 :: MonadIO m => (a -> IO b) -> a -> m b+liftIO1 = (.) liftIO++-- | Lift an 'IO' operation with 2 arguments into another monad+liftIO2 :: MonadIO m => (a -> b -> IO c) -> a -> b -> m c+liftIO2 = ((.).(.)) liftIO++-- | Lift an 'IO' operation with 3 arguments into another monad+liftIO3 :: MonadIO m => (a -> b -> c -> IO d) -> a -> b -> c -> m d+liftIO3 = ((.).((.).(.))) liftIO++-- | Lift an 'IO' operation with 4 arguments into another monad+liftIO4 :: MonadIO m => (a -> b -> c -> d -> IO e) -> a -> b -> c -> d -> m e+liftIO4 = (((.).(.)).((.).(.))) liftIO++-------------------------------------------------------------------------------+-- Common functions+--  These are used throughout the compiler+-------------------------------------------------------------------------------++zipWith3M :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d]+zipWith3M _ []     _      _      = return []+zipWith3M _ _      []     _      = return []+zipWith3M _ _      _      []     = return []+zipWith3M f (x:xs) (y:ys) (z:zs)+  = do { r  <- f x y z+       ; rs <- zipWith3M f xs ys zs+       ; return $ r:rs+       }++zipWith3M_ :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m ()+zipWith3M_ f as bs cs = do { _ <- zipWith3M f as bs cs+                           ; return () }++zipWith4M :: Monad m => (a -> b -> c -> d -> m e)+          -> [a] -> [b] -> [c] -> [d] -> m [e]+zipWith4M _ []     _      _      _      = return []+zipWith4M _ _      []     _      _      = return []+zipWith4M _ _      _      []     _      = return []+zipWith4M _ _      _      _      []     = return []+zipWith4M f (x:xs) (y:ys) (z:zs) (a:as)+  = do { r  <- f x y z a+       ; rs <- zipWith4M f xs ys zs as+       ; return $ r:rs+       }+++zipWithAndUnzipM :: Monad m+                 => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d])+{-# INLINABLE zipWithAndUnzipM #-}+-- See Note [flatten_many performance] in TcFlatten for why this+-- pragma is essential.+zipWithAndUnzipM f (x:xs) (y:ys)+  = do { (c, d) <- f x y+       ; (cs, ds) <- zipWithAndUnzipM f xs ys+       ; return (c:cs, d:ds) }+zipWithAndUnzipM _ _ _ = return ([], [])++-- | mapAndUnzipM for triples+mapAndUnzip3M :: Monad m => (a -> m (b,c,d)) -> [a] -> m ([b],[c],[d])+mapAndUnzip3M _ []     = return ([],[],[])+mapAndUnzip3M f (x:xs) = do+    (r1,  r2,  r3)  <- f x+    (rs1, rs2, rs3) <- mapAndUnzip3M f xs+    return (r1:rs1, r2:rs2, r3:rs3)++mapAndUnzip4M :: Monad m => (a -> m (b,c,d,e)) -> [a] -> m ([b],[c],[d],[e])+mapAndUnzip4M _ []     = return ([],[],[],[])+mapAndUnzip4M f (x:xs) = do+    (r1,  r2,  r3,  r4)  <- f x+    (rs1, rs2, rs3, rs4) <- mapAndUnzip4M f xs+    return (r1:rs1, r2:rs2, r3:rs3, r4:rs4)++mapAndUnzip5M :: Monad m => (a -> m (b,c,d,e,f)) -> [a] -> m ([b],[c],[d],[e],[f])+mapAndUnzip5M _ [] = return ([],[],[],[],[])+mapAndUnzip5M f (x:xs) = do+    (r1, r2, r3, r4, r5)      <- f x+    (rs1, rs2, rs3, rs4, rs5) <- mapAndUnzip5M f xs+    return (r1:rs1, r2:rs2, r3:rs3, r4:rs4, r5:rs5)++-- | Monadic version of mapAccumL+mapAccumLM :: Monad m+            => (acc -> x -> m (acc, y)) -- ^ combining function+            -> acc                      -- ^ initial state+            -> [x]                      -- ^ inputs+            -> m (acc, [y])             -- ^ final state, outputs+mapAccumLM _ s []     = return (s, [])+mapAccumLM f s (x:xs) = do+    (s1, x')  <- f s x+    (s2, xs') <- mapAccumLM f s1 xs+    return    (s2, x' : xs')++-- | Monadic version of mapSnd+mapSndM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)]+mapSndM _ []         = return []+mapSndM f ((a,b):xs) = do { c <- f b; rs <- mapSndM f xs; return ((a,c):rs) }++-- | Monadic version of concatMap+concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]+concatMapM f xs = liftM concat (mapM f xs)++-- | Monadic version of mapMaybe+mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b]+mapMaybeM f = liftM catMaybes . mapM f++-- | Monadic version of fmap+fmapMaybeM :: (Monad m) => (a -> m b) -> Maybe a -> m (Maybe b)+fmapMaybeM _ Nothing  = return Nothing+fmapMaybeM f (Just x) = f x >>= (return . Just)++-- | Monadic version of fmap+fmapEitherM :: Monad m => (a -> m b) -> (c -> m d) -> Either a c -> m (Either b d)+fmapEitherM fl _ (Left  a) = fl a >>= (return . Left)+fmapEitherM _ fr (Right b) = fr b >>= (return . Right)++-- | Monadic version of 'any', aborts the computation at the first @True@ value+anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool+anyM _ []     = return False+anyM f (x:xs) = do b <- f x+                   if b then return True+                        else anyM f xs++-- | Monad version of 'all', aborts the computation at the first @False@ value+allM :: Monad m => (a -> m Bool) -> [a] -> m Bool+allM _ []     = return True+allM f (b:bs) = (f b) >>= (\bv -> if bv then allM f bs else return False)++-- | Monadic version of or+orM :: Monad m => m Bool -> m Bool -> m Bool+orM m1 m2 = m1 >>= \x -> if x then return True else m2++-- | Monadic version of foldl+foldlM :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a+foldlM = foldM++-- | Monadic version of foldl that discards its result+foldlM_ :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m ()+foldlM_ = foldM_++-- | Monadic version of foldr+foldrM        :: (Monad m) => (b -> a -> m a) -> a -> [b] -> m a+foldrM _ z []     = return z+foldrM k z (x:xs) = do { r <- foldrM k z xs; k x r }++-- | Monadic version of fmap specialised for Maybe+maybeMapM :: Monad m => (a -> m b) -> (Maybe a -> m (Maybe b))+maybeMapM _ Nothing  = return Nothing+maybeMapM m (Just x) = liftM Just $ m x++-- | Monadic version of @when@, taking the condition in the monad+whenM :: Monad m => m Bool -> m () -> m ()+whenM mb thing = do { b <- mb+                    ; when b thing }++-- | Monadic version of @unless@, taking the condition in the monad+unlessM :: Monad m => m Bool -> m () -> m ()+unlessM condM acc = do { cond <- condM+                       ; unless cond acc }
+ utils/OrdList.hs view
@@ -0,0 +1,128 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1993-1998+++This is useful, general stuff for the Native Code Generator.++Provide trees (of instructions), so that lists of instructions+can be appended in linear time.+-}++{-# LANGUAGE CPP #-}+module OrdList (+        OrdList,+        nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, lastOL,+        mapOL, fromOL, toOL, foldrOL, foldlOL+) where++import Outputable++#if __GLASGOW_HASKELL__ > 710+import Data.Semigroup   ( Semigroup )+import qualified Data.Semigroup as Semigroup+#endif++infixl 5  `appOL`+infixl 5  `snocOL`+infixr 5  `consOL`++data OrdList a+  = None+  | One a+  | Many [a]          -- Invariant: non-empty+  | Cons a (OrdList a)+  | Snoc (OrdList a) a+  | Two (OrdList a) -- Invariant: non-empty+        (OrdList a) -- Invariant: non-empty++instance Outputable a => Outputable (OrdList a) where+  ppr ol = ppr (fromOL ol)  -- Convert to list and print that++#if __GLASGOW_HASKELL__ > 710+instance Semigroup (OrdList a) where+  (<>) = appOL+#endif++instance Monoid (OrdList a) where+  mempty = nilOL+  mappend = appOL+  mconcat = concatOL++instance Functor OrdList where+  fmap = mapOL++instance Foldable OrdList where+  foldr = foldrOL++instance Traversable OrdList where+  traverse f xs = toOL <$> traverse f (fromOL xs)++nilOL    :: OrdList a+isNilOL  :: OrdList a -> Bool++unitOL   :: a           -> OrdList a+snocOL   :: OrdList a   -> a         -> OrdList a+consOL   :: a           -> OrdList a -> OrdList a+appOL    :: OrdList a   -> OrdList a -> OrdList a+concatOL :: [OrdList a] -> OrdList a+lastOL   :: OrdList a   -> a++nilOL        = None+unitOL as    = One as+snocOL as   b    = Snoc as b+consOL a    bs   = Cons a bs+concatOL aas = foldr appOL None aas++lastOL None        = panic "lastOL"+lastOL (One a)     = a+lastOL (Many as)   = last as+lastOL (Cons _ as) = lastOL as+lastOL (Snoc _ a)  = a+lastOL (Two _ as)  = lastOL as++isNilOL None = True+isNilOL _    = False++None  `appOL` b     = b+a     `appOL` None  = a+One a `appOL` b     = Cons a b+a     `appOL` One b = Snoc a b+a     `appOL` b     = Two a b++fromOL :: OrdList a -> [a]+fromOL a = go a []+  where go None       acc = acc+        go (One a)    acc = a : acc+        go (Cons a b) acc = a : go b acc+        go (Snoc a b) acc = go a (b:acc)+        go (Two a b)  acc = go a (go b acc)+        go (Many xs)  acc = xs ++ acc++mapOL :: (a -> b) -> OrdList a -> OrdList b+mapOL _ None = None+mapOL f (One x) = One (f x)+mapOL f (Cons x xs) = Cons (f x) (mapOL f xs)+mapOL f (Snoc xs x) = Snoc (mapOL f xs) (f x)+mapOL f (Two x y) = Two (mapOL f x) (mapOL f y)+mapOL f (Many xs) = Many (map f xs)++foldrOL :: (a->b->b) -> b -> OrdList a -> b+foldrOL _ z None        = z+foldrOL k z (One x)     = k x z+foldrOL k z (Cons x xs) = k x (foldrOL k z xs)+foldrOL k z (Snoc xs x) = foldrOL k (k x z) xs+foldrOL k z (Two b1 b2) = foldrOL k (foldrOL k z b2) b1+foldrOL k z (Many xs)   = foldr k z xs++foldlOL :: (b->a->b) -> b -> OrdList a -> b+foldlOL _ z None        = z+foldlOL k z (One x)     = k z x+foldlOL k z (Cons x xs) = foldlOL k (k z x) xs+foldlOL k z (Snoc xs x) = k (foldlOL k z xs) x+foldlOL k z (Two b1 b2) = foldlOL k (foldlOL k z b1) b2+foldlOL k z (Many xs)   = foldl k z xs++toOL :: [a] -> OrdList a+toOL [] = None+toOL xs = Many xs
+ utils/Outputable.hs view
@@ -0,0 +1,1194 @@+{-# LANGUAGE CPP, ImplicitParams #-}+{-+(c) The University of Glasgow 2006-2012+(c) The GRASP Project, Glasgow University, 1992-1998+-}++-- | This module defines classes and functions for pretty-printing. It also+-- exports a number of helpful debugging and other utilities such as 'trace' and 'panic'.+--+-- The interface to this module is very similar to the standard Hughes-PJ pretty printing+-- module, except that it exports a number of additional functions that are rarely used,+-- and works over the 'SDoc' type.+module Outputable (+        -- * Type classes+        Outputable(..), OutputableBndr(..),++        -- * Pretty printing combinators+        SDoc, runSDoc, initSDocContext,+        docToSDoc, sdocWithPprDebug,+        interppSP, interpp'SP,+        pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor,+        pprWithBars,+        empty, isEmpty, nest,+        char,+        text, ftext, ptext, ztext,+        int, intWithCommas, integer, float, double, rational, doublePrec,+        parens, cparen, brackets, braces, quotes, quote,+        doubleQuotes, angleBrackets, paBrackets,+        semi, comma, colon, dcolon, space, equals, dot, vbar,+        arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt,+        lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,+        blankLine, forAllLit, kindStar, bullet,+        (<>), (<+>), hcat, hsep,+        ($$), ($+$), vcat,+        sep, cat,+        fsep, fcat,+        hang, hangNotEmpty, punctuate, ppWhen, ppUnless,+        speakNth, speakN, speakNOf, plural, isOrAre, doOrDoes,+        unicodeSyntax,++        coloured, keyword,++        -- * Converting 'SDoc' into strings and outputing it+        printSDoc, printSDocLn, printForUser, printForUserPartWay,+        printForC, bufLeftRenderSDoc,+        pprCode, mkCodeStyle,+        showSDoc, showSDocUnsafe, showSDocOneLine,+        showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine,+        showSDocUnqual, showPpr,+        renderWithStyle,++        pprInfixVar, pprPrefixVar,+        pprHsChar, pprHsString, pprHsBytes,++        primFloatSuffix, primCharSuffix, primWordSuffix, primDoubleSuffix,+        primInt64Suffix, primWord64Suffix, primIntSuffix,++        pprPrimChar, pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64,++        pprFastFilePath,++        -- * Controlling the style in which output is printed+        BindingSite(..),++        PprStyle, CodeStyle(..), PrintUnqualified(..),+        QueryQualifyName, QueryQualifyModule, QueryQualifyPackage,+        reallyAlwaysQualify, reallyAlwaysQualifyNames,+        alwaysQualify, alwaysQualifyNames, alwaysQualifyModules,+        neverQualify, neverQualifyNames, neverQualifyModules,+        alwaysQualifyPackages, neverQualifyPackages,+        QualifyName(..), queryQual,+        sdocWithDynFlags, sdocWithPlatform,+        getPprStyle, withPprStyle, withPprStyleDoc, setStyleColoured,+        pprDeeper, pprDeeperList, pprSetDepth,+        codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,+        ifPprDebug, qualName, qualModule, qualPackage,+        mkErrStyle, defaultErrStyle, defaultDumpStyle, mkDumpStyle, defaultUserStyle,+        mkUserStyle, cmdlineParserStyle, Depth(..),++        -- * Error handling and debugging utilities+        pprPanic, pprSorry, assertPprPanic, pprPgmError,+        pprTrace, pprTraceDebug, pprTraceIt, warnPprTrace, pprSTrace,+        trace, pgmError, panic, sorry, assertPanic,+        pprDebugAndThen, callStackDoc+    ) where++import {-# SOURCE #-}   DynFlags( DynFlags, hasPprDebug, hasNoDebugOutput,+                                  targetPlatform, pprUserLength, pprCols,+                                  useUnicode, useUnicodeSyntax,+                                  shouldUseColor, unsafeGlobalDynFlags )+import {-# SOURCE #-}   Module( UnitId, Module, ModuleName, moduleName )+import {-# SOURCE #-}   OccName( OccName )++import BufWrite (BufHandle)+import FastString+import qualified Pretty+import Util+import Platform+import qualified PprColour as Col+import Pretty           ( Doc, Mode(..) )+import Panic+import GHC.Serialized+import GHC.LanguageExtensions (Extension)++import Control.Exception (finally)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.Char+import qualified Data.Map as M+import Data.Int+import qualified Data.IntMap as IM+import Data.Set (Set)+import qualified Data.Set as Set+import Data.String+import Data.Word+import System.IO        ( Handle )+import System.FilePath+import Text.Printf+import Numeric (showFFloat)+import Data.Graph (SCC(..))+import Data.List (intersperse)++import GHC.Fingerprint+import GHC.Show         ( showMultiLineString )++{-+************************************************************************+*                                                                      *+\subsection{The @PprStyle@ data type}+*                                                                      *+************************************************************************+-}++data PprStyle+  = PprUser PrintUnqualified Depth Coloured+                -- Pretty-print in a way that will make sense to the+                -- ordinary user; must be very close to Haskell+                -- syntax, etc.+                -- Assumes printing tidied code: non-system names are+                -- printed without uniques.++  | PprDump PrintUnqualified+                -- For -ddump-foo; less verbose than PprDebug, but more than PprUser+                -- Does not assume tidied code: non-external names+                -- are printed with uniques.++  | PprDebug    -- Full debugging output++  | PprCode CodeStyle+                -- Print code; either C or assembler++data CodeStyle = CStyle         -- The format of labels differs for C and assembler+               | AsmStyle++data Depth = AllTheWay+           | PartWay Int        -- 0 => stop++data Coloured+  = Uncoloured+  | Coloured++-- -----------------------------------------------------------------------------+-- Printing original names++-- | When printing code that contains original names, we need to map the+-- original names back to something the user understands.  This is the+-- purpose of the triple of functions that gets passed around+-- when rendering 'SDoc'.+data PrintUnqualified = QueryQualify {+    queryQualifyName    :: QueryQualifyName,+    queryQualifyModule  :: QueryQualifyModule,+    queryQualifyPackage :: QueryQualifyPackage+}++-- | given an /original/ name, this function tells you which module+-- name it should be qualified with when printing for the user, if+-- any.  For example, given @Control.Exception.catch@, which is in scope+-- as @Exception.catch@, this function will return @Just "Exception"@.+-- Note that the return value is a ModuleName, not a Module, because+-- in source code, names are qualified by ModuleNames.+type QueryQualifyName = Module -> OccName -> QualifyName++-- | For a given module, we need to know whether to print it with+-- a package name to disambiguate it.+type QueryQualifyModule = Module -> Bool++-- | For a given package, we need to know whether to print it with+-- the component id to disambiguate it.+type QueryQualifyPackage = UnitId -> Bool++-- See Note [Printing original names] in HscTypes+data QualifyName   -- Given P:M.T+  = NameUnqual           -- It's in scope unqualified as "T"+                         -- OR nothing called "T" is in scope++  | NameQual ModuleName  -- It's in scope qualified as "X.T"++  | NameNotInScope1      -- It's not in scope at all, but M.T is not bound+                         -- in the current scope, so we can refer to it as "M.T"++  | NameNotInScope2      -- It's not in scope at all, and M.T is already bound in+                         -- the current scope, so we must refer to it as "P:M.T"++instance Outputable QualifyName where+  ppr NameUnqual      = text "NameUnqual"+  ppr (NameQual _mod) = text "NameQual"  -- can't print the mod without module loops :(+  ppr NameNotInScope1 = text "NameNotInScope1"+  ppr NameNotInScope2 = text "NameNotInScope2"++reallyAlwaysQualifyNames :: QueryQualifyName+reallyAlwaysQualifyNames _ _ = NameNotInScope2++-- | NB: This won't ever show package IDs+alwaysQualifyNames :: QueryQualifyName+alwaysQualifyNames m _ = NameQual (moduleName m)++neverQualifyNames :: QueryQualifyName+neverQualifyNames _ _ = NameUnqual++alwaysQualifyModules :: QueryQualifyModule+alwaysQualifyModules _ = True++neverQualifyModules :: QueryQualifyModule+neverQualifyModules _ = False++alwaysQualifyPackages :: QueryQualifyPackage+alwaysQualifyPackages _ = True++neverQualifyPackages :: QueryQualifyPackage+neverQualifyPackages _ = False++reallyAlwaysQualify, alwaysQualify, neverQualify :: PrintUnqualified+reallyAlwaysQualify+              = QueryQualify reallyAlwaysQualifyNames+                             alwaysQualifyModules+                             alwaysQualifyPackages+alwaysQualify = QueryQualify alwaysQualifyNames+                             alwaysQualifyModules+                             alwaysQualifyPackages+neverQualify  = QueryQualify neverQualifyNames+                             neverQualifyModules+                             neverQualifyPackages++defaultUserStyle :: DynFlags -> PprStyle+defaultUserStyle dflags = mkUserStyle dflags neverQualify AllTheWay++defaultDumpStyle :: DynFlags -> PprStyle+ -- Print without qualifiers to reduce verbosity, unless -dppr-debug+defaultDumpStyle dflags+   |  hasPprDebug dflags = PprDebug+   |  otherwise          = PprDump neverQualify++mkDumpStyle :: DynFlags -> PrintUnqualified -> PprStyle+mkDumpStyle dflags print_unqual+   | hasPprDebug dflags = PprDebug+   | otherwise          = PprDump print_unqual++defaultErrStyle :: DynFlags -> PprStyle+-- Default style for error messages, when we don't know PrintUnqualified+-- It's a bit of a hack because it doesn't take into account what's in scope+-- Only used for desugarer warnings, and typechecker errors in interface sigs+-- NB that -dppr-debug will still get into PprDebug style+defaultErrStyle dflags = mkErrStyle dflags neverQualify++-- | Style for printing error messages+mkErrStyle :: DynFlags -> PrintUnqualified -> PprStyle+mkErrStyle dflags qual =+   mkUserStyle dflags qual (PartWay (pprUserLength dflags))++cmdlineParserStyle :: DynFlags -> PprStyle+cmdlineParserStyle dflags = mkUserStyle dflags alwaysQualify AllTheWay++mkUserStyle :: DynFlags -> PrintUnqualified -> Depth -> PprStyle+mkUserStyle dflags unqual depth+   | hasPprDebug dflags = PprDebug+   | otherwise          = PprUser unqual depth Uncoloured++setStyleColoured :: Bool -> PprStyle -> PprStyle+setStyleColoured col style =+  case style of+    PprUser q d _ -> PprUser q d c+    _             -> style+  where+    c | col       = Coloured+      | otherwise = Uncoloured++instance Outputable PprStyle where+  ppr (PprUser {})  = text "user-style"+  ppr (PprCode {})  = text "code-style"+  ppr (PprDump {})  = text "dump-style"+  ppr (PprDebug {}) = text "debug-style"++{-+Orthogonal to the above printing styles are (possibly) some+command-line flags that affect printing (often carried with the+style).  The most likely ones are variations on how much type info is+shown.++The following test decides whether or not we are actually generating+code (either C or assembly), or generating interface files.++************************************************************************+*                                                                      *+\subsection{The @SDoc@ data type}+*                                                                      *+************************************************************************+-}++-- | Represents a pretty-printable document.+--+-- To display an 'SDoc', use 'printSDoc', 'printSDocLn', 'bufLeftRenderSDoc',+-- or 'renderWithStyle'.  Avoid calling 'runSDoc' directly as it breaks the+-- abstraction layer.+newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc }++data SDocContext = SDC+  { sdocStyle      :: !PprStyle+  , sdocLastColour :: !Col.PprColour+    -- ^ The most recently used colour.  This allows nesting colours.+  , sdocDynFlags   :: !DynFlags+  }++instance IsString SDoc where+  fromString = text++initSDocContext :: DynFlags -> PprStyle -> SDocContext+initSDocContext dflags sty = SDC+  { sdocStyle = sty+  , sdocLastColour = Col.colReset+  , sdocDynFlags = dflags+  }++withPprStyle :: PprStyle -> SDoc -> SDoc+withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty}++-- | This is not a recommended way to render 'SDoc', since it breaks the+-- abstraction layer of 'SDoc'.  Prefer to use 'printSDoc', 'printSDocLn',+-- 'bufLeftRenderSDoc', or 'renderWithStyle' instead.+withPprStyleDoc :: DynFlags -> PprStyle -> SDoc -> Doc+withPprStyleDoc dflags sty d = runSDoc d (initSDocContext dflags sty)++sdocWithPprDebug :: (Bool -> SDoc) -> SDoc+sdocWithPprDebug f = sdocWithDynFlags $ \dflags -> f (hasPprDebug dflags)++pprDeeper :: SDoc -> SDoc+pprDeeper d = SDoc $ \ctx -> case ctx of+  SDC{sdocStyle=PprUser _ (PartWay 0) _} -> Pretty.text "..."+  SDC{sdocStyle=PprUser q (PartWay n) c} ->+    runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1)) c}+  _ -> runSDoc d ctx++-- | Truncate a list that is longer than the current depth.+pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc+pprDeeperList f ds+  | null ds   = f []+  | otherwise = SDoc work+ where+  work ctx@SDC{sdocStyle=PprUser q (PartWay n) c}+   | n==0      = Pretty.text "..."+   | otherwise =+      runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1)) c}+   where+     go _ [] = []+     go i (d:ds) | i >= n    = [text "...."]+                 | otherwise = d : go (i+1) ds+  work other_ctx = runSDoc (f ds) other_ctx++pprSetDepth :: Depth -> SDoc -> SDoc+pprSetDepth depth doc = SDoc $ \ctx ->+    case ctx of+        SDC{sdocStyle=PprUser q _ c} ->+            runSDoc doc ctx{sdocStyle = PprUser q depth c}+        _ ->+            runSDoc doc ctx++getPprStyle :: (PprStyle -> SDoc) -> SDoc+getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx++sdocWithDynFlags :: (DynFlags -> SDoc) -> SDoc+sdocWithDynFlags f = SDoc $ \ctx -> runSDoc (f (sdocDynFlags ctx)) ctx++sdocWithPlatform :: (Platform -> SDoc) -> SDoc+sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform)++qualName :: PprStyle -> QueryQualifyName+qualName (PprUser q _ _) mod occ = queryQualifyName q mod occ+qualName (PprDump q)     mod occ = queryQualifyName q mod occ+qualName _other          mod _   = NameQual (moduleName mod)++qualModule :: PprStyle -> QueryQualifyModule+qualModule (PprUser q _ _)  m = queryQualifyModule q m+qualModule (PprDump q)      m = queryQualifyModule q m+qualModule _other          _m = True++qualPackage :: PprStyle -> QueryQualifyPackage+qualPackage (PprUser q _ _)  m = queryQualifyPackage q m+qualPackage (PprDump q)      m = queryQualifyPackage q m+qualPackage _other          _m = True++queryQual :: PprStyle -> PrintUnqualified+queryQual s = QueryQualify (qualName s)+                           (qualModule s)+                           (qualPackage s)++codeStyle :: PprStyle -> Bool+codeStyle (PprCode _)     = True+codeStyle _               = False++asmStyle :: PprStyle -> Bool+asmStyle (PprCode AsmStyle)  = True+asmStyle _other              = False++dumpStyle :: PprStyle -> Bool+dumpStyle (PprDump {}) = True+dumpStyle _other       = False++debugStyle :: PprStyle -> Bool+debugStyle PprDebug = True+debugStyle _other   = False++userStyle ::  PprStyle -> Bool+userStyle (PprUser {}) = True+userStyle _other       = False++ifPprDebug :: SDoc -> SDoc        -- Empty for non-debug style+ifPprDebug d = SDoc $ \ctx ->+    case ctx of+        SDC{sdocStyle=PprDebug} -> runSDoc d ctx+        _                       -> Pretty.empty++-- | The analog of 'Pretty.printDoc_' for 'SDoc', which tries to make sure the+--   terminal doesn't get screwed up by the ANSI color codes if an exception+--   is thrown during pretty-printing.+printSDoc :: Mode -> DynFlags -> Handle -> PprStyle -> SDoc -> IO ()+printSDoc mode dflags handle sty doc =+  Pretty.printDoc_ mode cols handle (runSDoc doc ctx)+    `finally`+      Pretty.printDoc_ mode cols handle+        (runSDoc (coloured Col.colReset empty) ctx)+  where+    cols = pprCols dflags+    ctx = initSDocContext dflags sty++-- | Like 'printSDoc' but appends an extra newline.+printSDocLn :: Mode -> DynFlags -> Handle -> PprStyle -> SDoc -> IO ()+printSDocLn mode dflags handle sty doc =+  printSDoc mode dflags handle sty (doc $$ text "")++printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO ()+printForUser dflags handle unqual doc+  = printSDocLn PageMode dflags handle+               (mkUserStyle dflags unqual AllTheWay) doc++printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc+                    -> IO ()+printForUserPartWay dflags handle d unqual doc+  = printSDocLn PageMode dflags handle+                (mkUserStyle dflags unqual (PartWay d)) doc++-- | Like 'printSDocLn' but specialized with 'LeftMode' and+-- @'PprCode' 'CStyle'@.  This is typically used to output C-- code.+printForC :: DynFlags -> Handle -> SDoc -> IO ()+printForC dflags handle doc =+  printSDocLn LeftMode dflags handle (PprCode CStyle) doc++-- | An efficient variant of 'printSDoc' specialized for 'LeftMode' that+-- outputs to a 'BufHandle'.+bufLeftRenderSDoc :: DynFlags -> BufHandle -> PprStyle -> SDoc -> IO ()+bufLeftRenderSDoc dflags bufHandle sty doc =+  Pretty.bufLeftRender bufHandle (runSDoc doc (initSDocContext dflags sty))++pprCode :: CodeStyle -> SDoc -> SDoc+pprCode cs d = withPprStyle (PprCode cs) d++mkCodeStyle :: CodeStyle -> PprStyle+mkCodeStyle = PprCode++-- Can't make SDoc an instance of Show because SDoc is just a function type+-- However, Doc *is* an instance of Show+-- showSDoc just blasts it out as a string+showSDoc :: DynFlags -> SDoc -> String+showSDoc dflags sdoc = renderWithStyle dflags sdoc (defaultUserStyle dflags)++-- showSDocUnsafe is unsafe, because `unsafeGlobalDynFlags` might not be+-- initialised yet.+showSDocUnsafe :: SDoc -> String+showSDocUnsafe sdoc = showSDoc unsafeGlobalDynFlags sdoc++showPpr :: Outputable a => DynFlags -> a -> String+showPpr dflags thing = showSDoc dflags (ppr thing)++showSDocUnqual :: DynFlags -> SDoc -> String+-- Only used by Haddock+showSDocUnqual dflags sdoc = showSDoc dflags sdoc++showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String+-- Allows caller to specify the PrintUnqualified to use+showSDocForUser dflags unqual doc+ = renderWithStyle dflags doc (mkUserStyle dflags unqual AllTheWay)++showSDocDump :: DynFlags -> SDoc -> String+showSDocDump dflags d = renderWithStyle dflags d (defaultDumpStyle dflags)++showSDocDebug :: DynFlags -> SDoc -> String+showSDocDebug dflags d = renderWithStyle dflags d PprDebug++renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String+renderWithStyle dflags sdoc sty+  = let s = Pretty.style{ Pretty.mode = PageMode,+                          Pretty.lineLength = pprCols dflags }+    in Pretty.renderStyle s $ runSDoc sdoc (initSDocContext dflags sty)++-- This shows an SDoc, but on one line only. It's cheaper than a full+-- showSDoc, designed for when we're getting results like "Foo.bar"+-- and "foo{uniq strictness}" so we don't want fancy layout anyway.+showSDocOneLine :: DynFlags -> SDoc -> String+showSDocOneLine dflags d+ = let s = Pretty.style{ Pretty.mode = OneLineMode,+                         Pretty.lineLength = pprCols dflags } in+   Pretty.renderStyle s $+      runSDoc d (initSDocContext dflags (defaultUserStyle dflags))++showSDocDumpOneLine :: DynFlags -> SDoc -> String+showSDocDumpOneLine dflags d+ = let s = Pretty.style{ Pretty.mode = OneLineMode,+                         Pretty.lineLength = irrelevantNCols } in+   Pretty.renderStyle s $+      runSDoc d (initSDocContext dflags (defaultDumpStyle dflags))++irrelevantNCols :: Int+-- Used for OneLineMode and LeftMode when number of cols isn't used+irrelevantNCols = 1++isEmpty :: DynFlags -> SDoc -> Bool+isEmpty dflags sdoc = Pretty.isEmpty $ runSDoc sdoc dummySDocContext+   where dummySDocContext = initSDocContext dflags PprDebug++docToSDoc :: Doc -> SDoc+docToSDoc d = SDoc (\_ -> d)++empty    :: SDoc+char     :: Char       -> SDoc+text     :: String     -> SDoc+ftext    :: FastString -> SDoc+ptext    :: LitString  -> SDoc+ztext    :: FastZString -> SDoc+int      :: Int        -> SDoc+integer  :: Integer    -> SDoc+float    :: Float      -> SDoc+double   :: Double     -> SDoc+rational :: Rational   -> SDoc++empty       = docToSDoc $ Pretty.empty+char c      = docToSDoc $ Pretty.char c++text s      = docToSDoc $ Pretty.text s+{-# INLINE text #-}   -- Inline so that the RULE Pretty.text will fire++ftext s     = docToSDoc $ Pretty.ftext s+ptext s     = docToSDoc $ Pretty.ptext s+ztext s     = docToSDoc $ Pretty.ztext s+int n       = docToSDoc $ Pretty.int n+integer n   = docToSDoc $ Pretty.integer n+float n     = docToSDoc $ Pretty.float n+double n    = docToSDoc $ Pretty.double n+rational n  = docToSDoc $ Pretty.rational n++-- | @doublePrec p n@ shows a floating point number @n@ with @p@+-- digits of precision after the decimal point.+doublePrec :: Int -> Double -> SDoc+doublePrec p n = text (showFFloat (Just p) n "")++parens, braces, brackets, quotes, quote,+        paBrackets, doubleQuotes, angleBrackets :: SDoc -> SDoc++parens d        = SDoc $ Pretty.parens . runSDoc d+braces d        = SDoc $ Pretty.braces . runSDoc d+brackets d      = SDoc $ Pretty.brackets . runSDoc d+quote d         = SDoc $ Pretty.quote . runSDoc d+doubleQuotes d  = SDoc $ Pretty.doubleQuotes . runSDoc d+angleBrackets d = char '<' <> d <> char '>'+paBrackets d    = text "[:" <> d <> text ":]"++cparen :: Bool -> SDoc -> SDoc+cparen b d = SDoc $ Pretty.maybeParens b . runSDoc d++-- 'quotes' encloses something in single quotes...+-- but it omits them if the thing begins or ends in a single quote+-- so that we don't get `foo''.  Instead we just have foo'.+quotes d =+      sdocWithDynFlags $ \dflags ->+      if useUnicode dflags+      then char '‘' <> d <> char '’'+      else SDoc $ \sty ->+           let pp_d = runSDoc d sty+               str  = show pp_d+           in case (str, snocView str) of+             (_, Just (_, '\'')) -> pp_d+             ('\'' : _, _)       -> pp_d+             _other              -> Pretty.quotes pp_d++semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc+arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc+lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc++blankLine  = docToSDoc $ Pretty.text ""+dcolon     = unicodeSyntax (char '∷') (docToSDoc $ Pretty.text "::")+arrow      = unicodeSyntax (char '→') (docToSDoc $ Pretty.text "->")+larrow     = unicodeSyntax (char '←') (docToSDoc $ Pretty.text "<-")+darrow     = unicodeSyntax (char '⇒') (docToSDoc $ Pretty.text "=>")+arrowt     = unicodeSyntax (char '⤚') (docToSDoc $ Pretty.text ">-")+larrowt    = unicodeSyntax (char '⤙') (docToSDoc $ Pretty.text "-<")+arrowtt    = unicodeSyntax (char '⤜') (docToSDoc $ Pretty.text ">>-")+larrowtt   = unicodeSyntax (char '⤛') (docToSDoc $ Pretty.text "-<<")+semi       = docToSDoc $ Pretty.semi+comma      = docToSDoc $ Pretty.comma+colon      = docToSDoc $ Pretty.colon+equals     = docToSDoc $ Pretty.equals+space      = docToSDoc $ Pretty.space+underscore = char '_'+dot        = char '.'+vbar       = char '|'+lparen     = docToSDoc $ Pretty.lparen+rparen     = docToSDoc $ Pretty.rparen+lbrack     = docToSDoc $ Pretty.lbrack+rbrack     = docToSDoc $ Pretty.rbrack+lbrace     = docToSDoc $ Pretty.lbrace+rbrace     = docToSDoc $ Pretty.rbrace++forAllLit :: SDoc+forAllLit = unicodeSyntax (char '∀') (text "forall")++kindStar :: SDoc+kindStar = unicodeSyntax (char '★') (char '*')++bullet :: SDoc+bullet = unicode (char '•') (char '*')++unicodeSyntax :: SDoc -> SDoc -> SDoc+unicodeSyntax unicode plain = sdocWithDynFlags $ \dflags ->+    if useUnicode dflags && useUnicodeSyntax dflags+    then unicode+    else plain++unicode :: SDoc -> SDoc -> SDoc+unicode unicode plain = sdocWithDynFlags $ \dflags ->+    if useUnicode dflags+    then unicode+    else plain++nest :: Int -> SDoc -> SDoc+-- ^ Indent 'SDoc' some specified amount+(<>) :: SDoc -> SDoc -> SDoc+-- ^ Join two 'SDoc' together horizontally without a gap+(<+>) :: SDoc -> SDoc -> SDoc+-- ^ Join two 'SDoc' together horizontally with a gap between them+($$) :: SDoc -> SDoc -> SDoc+-- ^ Join two 'SDoc' together vertically; if there is+-- no vertical overlap it "dovetails" the two onto one line+($+$) :: SDoc -> SDoc -> SDoc+-- ^ Join two 'SDoc' together vertically++nest n d    = SDoc $ Pretty.nest n . runSDoc d+(<>) d1 d2  = SDoc $ \sty -> (Pretty.<>)  (runSDoc d1 sty) (runSDoc d2 sty)+(<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>) (runSDoc d1 sty) (runSDoc d2 sty)+($$) d1 d2  = SDoc $ \sty -> (Pretty.$$)  (runSDoc d1 sty) (runSDoc d2 sty)+($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty)++hcat :: [SDoc] -> SDoc+-- ^ Concatenate 'SDoc' horizontally+hsep :: [SDoc] -> SDoc+-- ^ Concatenate 'SDoc' horizontally with a space between each one+vcat :: [SDoc] -> SDoc+-- ^ Concatenate 'SDoc' vertically with dovetailing+sep :: [SDoc] -> SDoc+-- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits+cat :: [SDoc] -> SDoc+-- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits+fsep :: [SDoc] -> SDoc+-- ^ A paragraph-fill combinator. It's much like sep, only it+-- keeps fitting things on one line until it can't fit any more.+fcat :: [SDoc] -> SDoc+-- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'+++hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds]+hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds]+vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds]+sep ds  = SDoc $ \sty -> Pretty.sep  [runSDoc d sty | d <- ds]+cat ds  = SDoc $ \sty -> Pretty.cat  [runSDoc d sty | d <- ds]+fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds]+fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds]++hang :: SDoc  -- ^ The header+      -> Int  -- ^ Amount to indent the hung body+      -> SDoc -- ^ The hung body, indented and placed below the header+      -> SDoc+hang d1 n d2   = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty)++-- | This behaves like 'hang', but does not indent the second document+-- when the header is empty.+hangNotEmpty :: SDoc -> Int -> SDoc -> SDoc+hangNotEmpty d1 n d2 =+    SDoc $ \sty -> Pretty.hangNotEmpty (runSDoc d1 sty) n (runSDoc d2 sty)++punctuate :: SDoc   -- ^ The punctuation+          -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements+          -> [SDoc] -- ^ Punctuated list+punctuate _ []     = []+punctuate p (d:ds) = go d ds+                   where+                     go d [] = [d]+                     go d (e:es) = (d <> p) : go e es++ppWhen, ppUnless :: Bool -> SDoc -> SDoc+ppWhen True  doc = doc+ppWhen False _   = empty++ppUnless True  _   = empty+ppUnless False doc = doc++-- | Apply the given colour\/style for the argument.+--+-- Only takes effect if colours are enabled.+coloured :: Col.PprColour -> SDoc -> SDoc+coloured col sdoc =+  sdocWithDynFlags $ \dflags ->+    if shouldUseColor dflags+    then SDoc $ \ctx@SDC{ sdocLastColour = lastCol } ->+         case ctx of+           SDC{ sdocStyle = PprUser _ _ Coloured } ->+             let ctx' = ctx{ sdocLastColour = lastCol `mappend` col } in+             Pretty.zeroWidthText (Col.renderColour col)+               Pretty.<> runSDoc sdoc ctx'+               Pretty.<> Pretty.zeroWidthText (Col.renderColourAfresh lastCol)+           _ -> runSDoc sdoc ctx+    else sdoc++keyword :: SDoc -> SDoc+keyword = coloured Col.colBold++{-+************************************************************************+*                                                                      *+\subsection[Outputable-class]{The @Outputable@ class}+*                                                                      *+************************************************************************+-}++-- | Class designating that some type has an 'SDoc' representation+class Outputable a where+        ppr :: a -> SDoc+        pprPrec :: Rational -> a -> SDoc+                -- 0 binds least tightly+                -- We use Rational because there is always a+                -- Rational between any other two Rationals++        ppr = pprPrec 0+        pprPrec _ = ppr++instance Outputable Char where+    ppr c = text [c]++instance Outputable Bool where+    ppr True  = text "True"+    ppr False = text "False"++instance Outputable Ordering where+    ppr LT = text "LT"+    ppr EQ = text "EQ"+    ppr GT = text "GT"++instance Outputable Int32 where+   ppr n = integer $ fromIntegral n++instance Outputable Int64 where+   ppr n = integer $ fromIntegral n++instance Outputable Int where+    ppr n = int n++instance Outputable Word16 where+    ppr n = integer $ fromIntegral n++instance Outputable Word32 where+    ppr n = integer $ fromIntegral n++instance Outputable Word where+    ppr n = integer $ fromIntegral n++instance Outputable () where+    ppr _ = text "()"++instance (Outputable a) => Outputable [a] where+    ppr xs = brackets (fsep (punctuate comma (map ppr xs)))++instance (Outputable a) => Outputable (Set a) where+    ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s))))++instance (Outputable a, Outputable b) => Outputable (a, b) where+    ppr (x,y) = parens (sep [ppr x <> comma, ppr y])++instance Outputable a => Outputable (Maybe a) where+    ppr Nothing  = text "Nothing"+    ppr (Just x) = text "Just" <+> ppr x++instance (Outputable a, Outputable b) => Outputable (Either a b) where+    ppr (Left x)  = text "Left"  <+> ppr x+    ppr (Right y) = text "Right" <+> ppr y++-- ToDo: may not be used+instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where+    ppr (x,y,z) =+      parens (sep [ppr x <> comma,+                   ppr y <> comma,+                   ppr z ])++instance (Outputable a, Outputable b, Outputable c, Outputable d) =>+         Outputable (a, b, c, d) where+    ppr (a,b,c,d) =+      parens (sep [ppr a <> comma,+                   ppr b <> comma,+                   ppr c <> comma,+                   ppr d])++instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>+         Outputable (a, b, c, d, e) where+    ppr (a,b,c,d,e) =+      parens (sep [ppr a <> comma,+                   ppr b <> comma,+                   ppr c <> comma,+                   ppr d <> comma,+                   ppr e])++instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f) =>+         Outputable (a, b, c, d, e, f) where+    ppr (a,b,c,d,e,f) =+      parens (sep [ppr a <> comma,+                   ppr b <> comma,+                   ppr c <> comma,+                   ppr d <> comma,+                   ppr e <> comma,+                   ppr f])++instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f, Outputable g) =>+         Outputable (a, b, c, d, e, f, g) where+    ppr (a,b,c,d,e,f,g) =+      parens (sep [ppr a <> comma,+                   ppr b <> comma,+                   ppr c <> comma,+                   ppr d <> comma,+                   ppr e <> comma,+                   ppr f <> comma,+                   ppr g])++instance Outputable FastString where+    ppr fs = ftext fs           -- Prints an unadorned string,+                                -- no double quotes or anything++instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where+    ppr m = ppr (M.toList m)+instance (Outputable elt) => Outputable (IM.IntMap elt) where+    ppr m = ppr (IM.toList m)++instance Outputable Fingerprint where+    ppr (Fingerprint w1 w2) = text (printf "%016x%016x" w1 w2)++instance Outputable a => Outputable (SCC a) where+   ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v))+   ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs)))++instance Outputable Serialized where+    ppr (Serialized the_type bytes) = int (length bytes) <+> text "of type" <+> text (show the_type)++instance Outputable Extension where+    ppr = text . show++{-+************************************************************************+*                                                                      *+\subsection{The @OutputableBndr@ class}+*                                                                      *+************************************************************************+-}++-- | 'BindingSite' is used to tell the thing that prints binder what+-- language construct is binding the identifier.  This can be used+-- to decide how much info to print.+-- Also see Note [Binding-site specific printing] in PprCore+data BindingSite+    = LambdaBind  -- ^ The x in   (\x. e)+    | CaseBind    -- ^ The x in   case scrut of x { (y,z) -> ... }+    | CasePatBind -- ^ The y,z in case scrut of x { (y,z) -> ... }+    | LetBind     -- ^ The x in   (let x = rhs in e)++-- | When we print a binder, we often want to print its type too.+-- The @OutputableBndr@ class encapsulates this idea.+class Outputable a => OutputableBndr a where+   pprBndr :: BindingSite -> a -> SDoc+   pprBndr _b x = ppr x++   pprPrefixOcc, pprInfixOcc :: a -> SDoc+      -- Print an occurrence of the name, suitable either in the+      -- prefix position of an application, thus   (f a b) or  ((+) x)+      -- or infix position,                 thus   (a `f` b) or  (x + y)++   bndrIsJoin_maybe :: a -> Maybe Int+   bndrIsJoin_maybe _ = Nothing+      -- When pretty-printing we sometimes want to find+      -- whether the binder is a join point.  You might think+      -- we could have a function of type (a->Var), but Var+      -- isn't available yet, alas++{-+************************************************************************+*                                                                      *+\subsection{Random printing helpers}+*                                                                      *+************************************************************************+-}++-- We have 31-bit Chars and will simply use Show instances of Char and String.++-- | Special combinator for showing character literals.+pprHsChar :: Char -> SDoc+pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))+            | otherwise      = text (show c)++-- | Special combinator for showing string literals.+pprHsString :: FastString -> SDoc+pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs)))++-- | Special combinator for showing bytestring literals.+pprHsBytes :: ByteString -> SDoc+pprHsBytes bs = let escaped = concatMap escape $ BS.unpack bs+                in vcat (map text (showMultiLineString escaped)) <> char '#'+    where escape :: Word8 -> String+          escape w = let c = chr (fromIntegral w)+                     in if isAscii c+                        then [c]+                        else '\\' : show w++-- Postfix modifiers for unboxed literals.+-- See Note [Printing of literals in Core] in `basicTypes/Literal.hs`.+primCharSuffix, primFloatSuffix, primIntSuffix :: SDoc+primDoubleSuffix, primWordSuffix, primInt64Suffix, primWord64Suffix :: SDoc+primCharSuffix   = char '#'+primFloatSuffix  = char '#'+primIntSuffix    = char '#'+primDoubleSuffix = text "##"+primWordSuffix   = text "##"+primInt64Suffix  = text "L#"+primWord64Suffix = text "L##"++-- | Special combinator for showing unboxed literals.+pprPrimChar :: Char -> SDoc+pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64 :: Integer -> SDoc+pprPrimChar c   = pprHsChar c <> primCharSuffix+pprPrimInt i    = integer i   <> primIntSuffix+pprPrimWord w   = integer w   <> primWordSuffix+pprPrimInt64 i  = integer i   <> primInt64Suffix+pprPrimWord64 w = integer w   <> primWord64Suffix++---------------------+-- Put a name in parens if it's an operator+pprPrefixVar :: Bool -> SDoc -> SDoc+pprPrefixVar is_operator pp_v+  | is_operator = parens pp_v+  | otherwise   = pp_v++-- Put a name in backquotes if it's not an operator+pprInfixVar :: Bool -> SDoc -> SDoc+pprInfixVar is_operator pp_v+  | is_operator = pp_v+  | otherwise   = char '`' <> pp_v <> char '`'++---------------------+pprFastFilePath :: FastString -> SDoc+pprFastFilePath path = text $ normalise $ unpackFS path++{-+************************************************************************+*                                                                      *+\subsection{Other helper functions}+*                                                                      *+************************************************************************+-}++pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use+              -> [a]         -- ^ The things to be pretty printed+              -> SDoc        -- ^ 'SDoc' where the things have been pretty printed,+                             -- comma-separated and finally packed into a paragraph.+pprWithCommas pp xs = fsep (punctuate comma (map pp xs))++pprWithBars :: (a -> SDoc) -- ^ The pretty printing function to use+            -> [a]         -- ^ The things to be pretty printed+            -> SDoc        -- ^ 'SDoc' where the things have been pretty printed,+                           -- bar-separated and finally packed into a paragraph.+pprWithBars pp xs = fsep (intersperse vbar (map pp xs))++-- | Returns the separated concatenation of the pretty printed things.+interppSP  :: Outputable a => [a] -> SDoc+interppSP  xs = sep (map ppr xs)++-- | Returns the comma-separated concatenation of the pretty printed things.+interpp'SP :: Outputable a => [a] -> SDoc+interpp'SP xs = sep (punctuate comma (map ppr xs))++-- | Returns the comma-separated concatenation of the quoted pretty printed things.+--+-- > [x,y,z]  ==>  `x', `y', `z'+pprQuotedList :: Outputable a => [a] -> SDoc+pprQuotedList = quotedList . map ppr++quotedList :: [SDoc] -> SDoc+quotedList xs = hsep (punctuate comma (map quotes xs))++quotedListWithOr :: [SDoc] -> SDoc+-- [x,y,z]  ==>  `x', `y' or `z'+quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> text "or" <+> quotes (last xs)+quotedListWithOr xs = quotedList xs++quotedListWithNor :: [SDoc] -> SDoc+-- [x,y,z]  ==>  `x', `y' nor `z'+quotedListWithNor xs@(_:_:_) = quotedList (init xs) <+> text "nor" <+> quotes (last xs)+quotedListWithNor xs = quotedList xs++{-+************************************************************************+*                                                                      *+\subsection{Printing numbers verbally}+*                                                                      *+************************************************************************+-}++intWithCommas :: Integral a => a -> SDoc+-- Prints a big integer with commas, eg 345,821+intWithCommas n+  | n < 0     = char '-' <> intWithCommas (-n)+  | q == 0    = int (fromIntegral r)+  | otherwise = intWithCommas q <> comma <> zeroes <> int (fromIntegral r)+  where+    (q,r) = n `quotRem` 1000+    zeroes | r >= 100  = empty+           | r >= 10   = char '0'+           | otherwise = text "00"++-- | Converts an integer to a verbal index:+--+-- > speakNth 1 = text "first"+-- > speakNth 5 = text "fifth"+-- > speakNth 21 = text "21st"+speakNth :: Int -> SDoc+speakNth 1 = text "first"+speakNth 2 = text "second"+speakNth 3 = text "third"+speakNth 4 = text "fourth"+speakNth 5 = text "fifth"+speakNth 6 = text "sixth"+speakNth n = hcat [ int n, text suffix ]+  where+    suffix | n <= 20       = "th"       -- 11,12,13 are non-std+           | last_dig == 1 = "st"+           | last_dig == 2 = "nd"+           | last_dig == 3 = "rd"+           | otherwise     = "th"++    last_dig = n `rem` 10++-- | Converts an integer to a verbal multiplicity:+--+-- > speakN 0 = text "none"+-- > speakN 5 = text "five"+-- > speakN 10 = text "10"+speakN :: Int -> SDoc+speakN 0 = text "none"  -- E.g.  "he has none"+speakN 1 = text "one"   -- E.g.  "he has one"+speakN 2 = text "two"+speakN 3 = text "three"+speakN 4 = text "four"+speakN 5 = text "five"+speakN 6 = text "six"+speakN n = int n++-- | Converts an integer and object description to a statement about the+-- multiplicity of those objects:+--+-- > speakNOf 0 (text "melon") = text "no melons"+-- > speakNOf 1 (text "melon") = text "one melon"+-- > speakNOf 3 (text "melon") = text "three melons"+speakNOf :: Int -> SDoc -> SDoc+speakNOf 0 d = text "no" <+> d <> char 's'+speakNOf 1 d = text "one" <+> d                 -- E.g. "one argument"+speakNOf n d = speakN n <+> d <> char 's'               -- E.g. "three arguments"++-- | Determines the pluralisation suffix appropriate for the length of a list:+--+-- > plural [] = char 's'+-- > plural ["Hello"] = empty+-- > plural ["Hello", "World"] = char 's'+plural :: [a] -> SDoc+plural [_] = empty  -- a bit frightening, but there you are+plural _   = char 's'++-- | Determines the form of to be appropriate for the length of a list:+--+-- > isOrAre [] = text "are"+-- > isOrAre ["Hello"] = text "is"+-- > isOrAre ["Hello", "World"] = text "are"+isOrAre :: [a] -> SDoc+isOrAre [_] = text "is"+isOrAre _   = text "are"++-- | Determines the form of to do appropriate for the length of a list:+--+-- > doOrDoes [] = text "do"+-- > doOrDoes ["Hello"] = text "does"+-- > doOrDoes ["Hello", "World"] = text "do"+doOrDoes :: [a] -> SDoc+doOrDoes [_] = text "does"+doOrDoes _   = text "do"++{-+************************************************************************+*                                                                      *+\subsection{Error handling}+*                                                                      *+************************************************************************+-}++callStackDoc :: HasCallStack => SDoc+callStackDoc =+    hang (text "Call stack:") 4 (vcat $ map text $ lines prettyCurrentCallStack)++pprPanic :: HasCallStack => String -> SDoc -> a+-- ^ Throw an exception saying "bug in GHC"+pprPanic s doc = panicDoc s (doc $$ callStackDoc)++pprSorry :: String -> SDoc -> a+-- ^ Throw an exception saying "this isn't finished yet"+pprSorry    = sorryDoc+++pprPgmError :: String -> SDoc -> a+-- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)+pprPgmError = pgmErrorDoc++pprTraceDebug :: String -> SDoc -> a -> a+pprTraceDebug str doc x+   | debugIsOn && hasPprDebug unsafeGlobalDynFlags = pprTrace str doc x+   | otherwise                                     = x++pprTrace :: String -> SDoc -> a -> a+-- ^ If debug output is on, show some 'SDoc' on the screen+pprTrace str doc x+   | hasNoDebugOutput unsafeGlobalDynFlags = x+   | otherwise                             =+      pprDebugAndThen unsafeGlobalDynFlags trace (text str) doc x++-- | @pprTraceIt desc x@ is equivalent to @pprTrace desc (ppr x) x@+pprTraceIt :: Outputable a => String -> a -> a+pprTraceIt desc x = pprTrace desc (ppr x) x+++-- | If debug output is on, show some 'SDoc' on the screen along+-- with a call stack when available.+pprSTrace :: HasCallStack => SDoc -> a -> a+pprSTrace doc = pprTrace "" (doc $$ callStackDoc)++warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a+-- ^ Just warn about an assertion failure, recording the given file and line number.+-- Should typically be accessed with the WARN macros+warnPprTrace _     _     _     _    x | not debugIsOn     = x+warnPprTrace _     _file _line _msg x+   | hasNoDebugOutput unsafeGlobalDynFlags = x+warnPprTrace False _file _line _msg x = x+warnPprTrace True   file  line  msg x+  = pprDebugAndThen unsafeGlobalDynFlags trace heading msg x+  where+    heading = hsep [text "WARNING: file", text file <> comma, text "line", int line]++-- | Panic with an assertation failure, recording the given file and+-- line number. Should typically be accessed with the ASSERT family of macros+assertPprPanic :: HasCallStack => String -> Int -> SDoc -> a+assertPprPanic _file _line msg+  = pprPanic "ASSERT failed!" doc+  where+    doc = sep [ msg, callStackDoc ]++pprDebugAndThen :: DynFlags -> (String -> a) -> SDoc -> SDoc -> a+pprDebugAndThen dflags cont heading pretty_msg+ = cont (showSDocDump dflags doc)+ where+     doc = sep [heading, nest 2 pretty_msg]
+ utils/Outputable.hs-boot view
@@ -0,0 +1,5 @@+module Outputable where++data SDoc++showSDocUnsafe :: SDoc -> String
+ utils/Pair.hs view
@@ -0,0 +1,54 @@+{-+A simple homogeneous pair type with useful Functor, Applicative, and+Traversable instances.+-}++{-# LANGUAGE CPP #-}++module Pair ( Pair(..), unPair, toPair, swap, pLiftFst, pLiftSnd ) where++#include "HsVersions.h"++import Outputable++data Pair a = Pair { pFst :: a, pSnd :: a }+-- Note that Pair is a *unary* type constructor+-- whereas (,) is binary++-- The important thing about Pair is that it has a *homogenous*+-- Functor instance, so you can easily apply the same function+-- to both components+instance Functor Pair where+  fmap f (Pair x y) = Pair (f x) (f y)++instance Applicative Pair where+  pure x = Pair x x+  (Pair f g) <*> (Pair x y) = Pair (f x) (g y)++instance Foldable Pair where+  foldMap f (Pair x y) = f x `mappend` f y++instance Traversable Pair where+  traverse f (Pair x y) = Pair <$> f x <*> f y++instance Monoid a => Monoid (Pair a) where+  mempty = Pair mempty mempty+  Pair a1 b1 `mappend` Pair a2 b2 = Pair (a1 `mappend` a2) (b1 `mappend` b2)++instance Outputable a => Outputable (Pair a) where+  ppr (Pair a b) = ppr a <+> char '~' <+> ppr b++unPair :: Pair a -> (a,a)+unPair (Pair x y) = (x,y)++toPair :: (a,a) -> Pair a+toPair (x,y) = Pair x y++swap :: Pair a -> Pair a+swap (Pair x y) = Pair y x++pLiftFst :: (a -> a) -> Pair a -> Pair a+pLiftFst f (Pair a b) = Pair (f a) b++pLiftSnd :: (a -> a) -> Pair a -> Pair a+pLiftSnd f (Pair a b) = Pair a (f b)
+ utils/Panic.hs view
@@ -0,0 +1,298 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP Project, Glasgow University, 1992-2000++Defines basic functions for printing error messages.++It's hard to put these functions anywhere else without causing+some unnecessary loops in the module dependency graph.+-}++{-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-}++module Panic (+     GhcException(..), showGhcException,+     throwGhcException, throwGhcExceptionIO,+     handleGhcException,+     progName,+     pgmError,++     panic, sorry, assertPanic, trace,+     panicDoc, sorryDoc, pgmErrorDoc,++     Exception.Exception(..), showException, safeShowException,+     try, tryMost, throwTo,++     withSignalHandlers,+) where+#include "HsVersions.h"++import {-# SOURCE #-} Outputable (SDoc, showSDocUnsafe)++import Config+import Exception++import Control.Monad.IO.Class+import Control.Concurrent+import Debug.Trace        ( trace )+import System.IO.Unsafe+import System.Environment++#ifndef mingw32_HOST_OS+import System.Posix.Signals as S+#endif++#if defined(mingw32_HOST_OS)+import GHC.ConsoleHandler as S+#endif++import GHC.Stack+import System.Mem.Weak  ( deRefWeak )++-- | GHC's own exception type+--   error messages all take the form:+--+--  @+--      <location>: <error>+--  @+--+--   If the location is on the command line, or in GHC itself, then+--   <location>="ghc".  All of the error types below correspond to+--   a <location> of "ghc", except for ProgramError (where the string is+--  assumed to contain a location already, so we don't print one).++data GhcException+  -- | Some other fatal signal (SIGHUP,SIGTERM)+  = Signal Int++  -- | Prints the short usage msg after the error+  | UsageError   String++  -- | A problem with the command line arguments, but don't print usage.+  | CmdLineError String++  -- | The 'impossible' happened.+  | Panic        String+  | PprPanic     String SDoc++  -- | The user tickled something that's known not to work yet,+  --   but we're not counting it as a bug.+  | Sorry        String+  | PprSorry     String SDoc++  -- | An installation problem.+  | InstallationError String++  -- | An error in the user's code, probably.+  | ProgramError    String+  | PprProgramError String SDoc++instance Exception GhcException++instance Show GhcException where+  showsPrec _ e@(ProgramError _) = showGhcException e+  showsPrec _ e@(CmdLineError _) = showString "<command line>: " . showGhcException e+  showsPrec _ e = showString progName . showString ": " . showGhcException e+++-- | The name of this GHC.+progName :: String+progName = unsafePerformIO (getProgName)+{-# NOINLINE progName #-}+++-- | Short usage information to display when we are given the wrong cmd line arguments.+short_usage :: String+short_usage = "Usage: For basic information, try the `--help' option."+++-- | Show an exception as a string.+showException :: Exception e => e -> String+showException = show++-- | Show an exception which can possibly throw other exceptions.+-- Used when displaying exception thrown within TH code.+safeShowException :: Exception e => e -> IO String+safeShowException e = do+    -- ensure the whole error message is evaluated inside try+    r <- try (return $! forceList (showException e))+    case r of+        Right msg -> return msg+        Left e' -> safeShowException (e' :: SomeException)+    where+        forceList [] = []+        forceList xs@(x : xt) = x `seq` forceList xt `seq` xs++-- | Append a description of the given exception to this string.+--+-- Note that this uses 'DynFlags.unsafeGlobalDynFlags', which may have some+-- uninitialized fields if invoked before 'GHC.initGhcMonad' has been called.+-- If the error message to be printed includes a pretty-printer document+-- which forces one of these fields this call may bottom.+showGhcException :: GhcException -> ShowS+showGhcException exception+ = case exception of+        UsageError str+         -> showString str . showChar '\n' . showString short_usage++        CmdLineError str        -> showString str+        PprProgramError str  sdoc  ->+            showString str . showString "\n\n" .+            showString (showSDocUnsafe sdoc)+        ProgramError str        -> showString str+        InstallationError str   -> showString str+        Signal n                -> showString "signal: " . shows n++        PprPanic  s sdoc ->+            panicMsg $ showString s . showString "\n\n"+                     . showString (showSDocUnsafe sdoc)+        Panic s -> panicMsg (showString s)++        PprSorry  s sdoc ->+            sorryMsg $ showString s . showString "\n\n"+                     . showString (showSDocUnsafe sdoc)+        Sorry s -> sorryMsg (showString s)+  where+    sorryMsg :: ShowS -> ShowS+    sorryMsg s =+        showString "sorry! (unimplemented feature or known bug)\n"+      . showString ("  (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t")+      . s . showString "\n"++    panicMsg :: ShowS -> ShowS+    panicMsg s =+        showString "panic! (the 'impossible' happened)\n"+      . showString ("  (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t")+      . s . showString "\n\n"+      . showString "Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug\n"+++throwGhcException :: GhcException -> a+throwGhcException = Exception.throw++throwGhcExceptionIO :: GhcException -> IO a+throwGhcExceptionIO = Exception.throwIO++handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a+handleGhcException = ghandle+++-- | Panics and asserts.+panic, sorry, pgmError :: String -> a+panic    x = unsafeDupablePerformIO $ do+   stack <- ccsToStrings =<< getCurrentCCS x+   if null stack+      then throwGhcException (Panic x)+      else throwGhcException (Panic (x ++ '\n' : renderStack stack))++sorry    x = throwGhcException (Sorry x)+pgmError x = throwGhcException (ProgramError x)++panicDoc, sorryDoc, pgmErrorDoc :: String -> SDoc -> a+panicDoc    x doc = throwGhcException (PprPanic        x doc)+sorryDoc    x doc = throwGhcException (PprSorry        x doc)+pgmErrorDoc x doc = throwGhcException (PprProgramError x doc)+++-- | Throw an failed assertion exception for a given filename and line number.+assertPanic :: String -> Int -> a+assertPanic file line =+  Exception.throw (Exception.AssertionFailed+           ("ASSERT failed! file " ++ file ++ ", line " ++ show line))+++-- | Like try, but pass through UserInterrupt and Panic exceptions.+--   Used when we want soft failures when reading interface files, for example.+--   TODO: I'm not entirely sure if this is catching what we really want to catch+tryMost :: IO a -> IO (Either SomeException a)+tryMost action = do r <- try action+                    case r of+                        Left se ->+                            case fromException se of+                                -- Some GhcException's we rethrow,+                                Just (Signal _)  -> throwIO se+                                Just (Panic _)   -> throwIO se+                                -- others we return+                                Just _           -> return (Left se)+                                Nothing ->+                                    case fromException se of+                                        -- All IOExceptions are returned+                                        Just (_ :: IOException) ->+                                            return (Left se)+                                        -- Anything else is rethrown+                                        Nothing -> throwIO se+                        Right v -> return (Right v)++-- | We use reference counting for signal handlers+{-# NOINLINE signalHandlersRefCount #-}+#if !defined(mingw32_HOST_OS)+signalHandlersRefCount :: MVar (Word, Maybe (S.Handler,S.Handler+                                            ,S.Handler,S.Handler))+#else+signalHandlersRefCount :: MVar (Word, Maybe S.Handler)+#endif+signalHandlersRefCount = unsafePerformIO $ newMVar (0,Nothing)+++-- | Temporarily install standard signal handlers for catching ^C, which just+-- throw an exception in the current thread.+withSignalHandlers :: (ExceptionMonad m, MonadIO m) => m a -> m a+withSignalHandlers act = do+  main_thread <- liftIO myThreadId+  wtid <- liftIO (mkWeakThreadId main_thread)++  let+      interrupt = do+        r <- deRefWeak wtid+        case r of+          Nothing -> return ()+          Just t  -> throwTo t UserInterrupt++#if !defined(mingw32_HOST_OS)+  let installHandlers = do+        let installHandler' a b = installHandler a b Nothing+        hdlQUIT <- installHandler' sigQUIT  (Catch interrupt)+        hdlINT  <- installHandler' sigINT   (Catch interrupt)+        -- see #3656; in the future we should install these automatically for+        -- all Haskell programs in the same way that we install a ^C handler.+        let fatal_signal n = throwTo main_thread (Signal (fromIntegral n))+        hdlHUP  <- installHandler' sigHUP   (Catch (fatal_signal sigHUP))+        hdlTERM <- installHandler' sigTERM  (Catch (fatal_signal sigTERM))+        return (hdlQUIT,hdlINT,hdlHUP,hdlTERM)++  let uninstallHandlers (hdlQUIT,hdlINT,hdlHUP,hdlTERM) = do+        _ <- installHandler sigQUIT  hdlQUIT Nothing+        _ <- installHandler sigINT   hdlINT  Nothing+        _ <- installHandler sigHUP   hdlHUP  Nothing+        _ <- installHandler sigTERM  hdlTERM Nothing+        return ()+#else+  -- GHC 6.3+ has support for console events on Windows+  -- NOTE: running GHCi under a bash shell for some reason requires+  -- you to press Ctrl-Break rather than Ctrl-C to provoke+  -- an interrupt.  Ctrl-C is getting blocked somewhere, I don't know+  -- why --SDM 17/12/2004+  let sig_handler ControlC = interrupt+      sig_handler Break    = interrupt+      sig_handler _        = return ()++  let installHandlers   = installHandler (Catch sig_handler)+  let uninstallHandlers = installHandler -- directly install the old handler+#endif++  -- install signal handlers if necessary+  let mayInstallHandlers = liftIO $ modifyMVar_ signalHandlersRefCount $ \case+        (0,Nothing)     -> do+          hdls <- installHandlers+          return (1,Just hdls)+        (c,oldHandlers) -> return (c+1,oldHandlers)++  -- uninstall handlers if necessary+  let mayUninstallHandlers = liftIO $ modifyMVar_ signalHandlersRefCount $ \case+        (1,Just hdls)   -> do+          _ <- uninstallHandlers hdls+          return (0,Nothing)+        (c,oldHandlers) -> return (c-1,oldHandlers)++  mayInstallHandlers+  act `gfinally` mayUninstallHandlers
+ utils/Platform.hs view
@@ -0,0 +1,172 @@++-- | A description of the platform we're compiling for.+--+module Platform (+        Platform(..),+        Arch(..),+        OS(..),+        ArmISA(..),+        ArmISAExt(..),+        ArmABI(..),+        PPC_64ABI(..),++        target32Bit,+        isARM,+        osElfTarget,+        osMachOTarget,+        osSubsectionsViaSymbols,+        platformUsesFrameworks,+        platformBinariesAreStaticLibs,+)++where++-- | Contains enough information for the native code generator to emit+--      code for this platform.+data Platform+        = Platform {+              platformArch                     :: Arch,+              platformOS                       :: OS,+              -- Word size in bytes (i.e. normally 4 or 8,+              -- for 32bit and 64bit platforms respectively)+              platformWordSize                 :: {-# UNPACK #-} !Int,+              platformUnregisterised           :: Bool,+              platformHasGnuNonexecStack       :: Bool,+              platformHasIdentDirective        :: Bool,+              platformHasSubsectionsViaSymbols :: Bool,+              platformIsCrossCompiling         :: Bool+          }+        deriving (Read, Show, Eq)+++-- | Architectures that the native code generator knows about.+--      TODO: It might be nice to extend these constructors with information+--      about what instruction set extensions an architecture might support.+--+data Arch+        = ArchUnknown+        | ArchX86+        | ArchX86_64+        | ArchPPC+        | ArchPPC_64+          { ppc_64ABI :: PPC_64ABI+          }+        | ArchSPARC+        | ArchSPARC64+        | ArchARM+          { armISA    :: ArmISA+          , armISAExt :: [ArmISAExt]+          , armABI    :: ArmABI+          }+        | ArchARM64+        | ArchAlpha+        | ArchMipseb+        | ArchMipsel+        | ArchJavaScript+        deriving (Read, Show, Eq)++isARM :: Arch -> Bool+isARM (ArchARM {}) = True+isARM ArchARM64    = True+isARM _ = False++-- | Operating systems that the native code generator knows about.+--      Having OSUnknown should produce a sensible default, but no promises.+data OS+        = OSUnknown+        | OSLinux+        | OSDarwin+        | OSiOS+        | OSSolaris2+        | OSMinGW32+        | OSFreeBSD+        | OSDragonFly+        | OSOpenBSD+        | OSNetBSD+        | OSKFreeBSD+        | OSHaiku+        | OSQNXNTO+        | OSAndroid+        | OSAIX+        deriving (Read, Show, Eq)++-- | ARM Instruction Set Architecture, Extensions and ABI+--+data ArmISA+    = ARMv5+    | ARMv6+    | ARMv7+    deriving (Read, Show, Eq)++data ArmISAExt+    = VFPv2+    | VFPv3+    | VFPv3D16+    | NEON+    | IWMMX2+    deriving (Read, Show, Eq)++data ArmABI+    = SOFT+    | SOFTFP+    | HARD+    deriving (Read, Show, Eq)++-- | PowerPC 64-bit ABI+--+data PPC_64ABI+    = ELF_V1+    | ELF_V2+    deriving (Read, Show, Eq)++-- | This predicate tells us whether the platform is 32-bit.+target32Bit :: Platform -> Bool+target32Bit p = platformWordSize p == 4++-- | This predicate tells us whether the OS supports ELF-like shared libraries.+osElfTarget :: OS -> Bool+osElfTarget OSLinux     = True+osElfTarget OSFreeBSD   = True+osElfTarget OSDragonFly = True+osElfTarget OSOpenBSD   = True+osElfTarget OSNetBSD    = True+osElfTarget OSSolaris2  = True+osElfTarget OSDarwin    = False+osElfTarget OSiOS       = False+osElfTarget OSMinGW32   = False+osElfTarget OSKFreeBSD  = True+osElfTarget OSHaiku     = True+osElfTarget OSQNXNTO    = False+osElfTarget OSAndroid   = True+osElfTarget OSAIX       = False+osElfTarget OSUnknown   = False+ -- Defaulting to False is safe; it means don't rely on any+ -- ELF-specific functionality.  It is important to have a default for+ -- portability, otherwise we have to answer this question for every+ -- new platform we compile on (even unreg).++-- | This predicate tells us whether the OS support Mach-O shared libraries.+osMachOTarget :: OS -> Bool+osMachOTarget OSDarwin = True+osMachOTarget _ = False++osUsesFrameworks :: OS -> Bool+osUsesFrameworks OSDarwin = True+osUsesFrameworks OSiOS    = True+osUsesFrameworks _        = False++platformUsesFrameworks :: Platform -> Bool+platformUsesFrameworks = osUsesFrameworks . platformOS++osBinariesAreStaticLibs :: OS -> Bool+osBinariesAreStaticLibs OSiOS = True+osBinariesAreStaticLibs _     = False++osSubsectionsViaSymbols :: OS -> Bool+osSubsectionsViaSymbols OSDarwin = True+osSubsectionsViaSymbols OSiOS    = True+osSubsectionsViaSymbols _        = False++platformBinariesAreStaticLibs :: Platform -> Bool+platformBinariesAreStaticLibs = osBinariesAreStaticLibs . platformOS+
+ utils/PprColour.hs view
@@ -0,0 +1,95 @@+module PprColour where+import Data.Maybe (fromMaybe)+import Util (OverridingBool(..), split)++-- | A colour\/style for use with 'coloured'.+newtype PprColour = PprColour { renderColour :: String }++-- | Allow colours to be combined (e.g. bold + red);+--   In case of conflict, right side takes precedence.+instance Monoid PprColour where+  mempty = PprColour mempty+  PprColour s1 `mappend` PprColour s2 = PprColour (s1 `mappend` s2)++renderColourAfresh :: PprColour -> String+renderColourAfresh c = renderColour (colReset `mappend` c)++colCustom :: String -> PprColour+colCustom "" = mempty+colCustom s  = PprColour ("\27[" ++ s ++ "m")++colReset :: PprColour+colReset = colCustom "0"++colBold :: PprColour+colBold = colCustom ";1"++colBlackFg :: PprColour+colBlackFg = colCustom "30"++colRedFg :: PprColour+colRedFg = colCustom "31"++colGreenFg :: PprColour+colGreenFg = colCustom "32"++colYellowFg :: PprColour+colYellowFg = colCustom "33"++colBlueFg :: PprColour+colBlueFg = colCustom "34"++colMagentaFg :: PprColour+colMagentaFg = colCustom "35"++colCyanFg :: PprColour+colCyanFg = colCustom "36"++colWhiteFg :: PprColour+colWhiteFg = colCustom "37"++data Scheme =+  Scheme+  { sHeader  :: PprColour+  , sMessage :: PprColour+  , sWarning :: PprColour+  , sError   :: PprColour+  , sFatal   :: PprColour+  , sMargin  :: PprColour+  }++defaultScheme :: Scheme+defaultScheme =+  Scheme+  { sHeader  = mempty+  , sMessage = colBold+  , sWarning = colBold `mappend` colMagentaFg+  , sError   = colBold `mappend` colRedFg+  , sFatal   = colBold `mappend` colRedFg+  , sMargin  = colBold `mappend` colBlueFg+  }++-- | Parse the colour scheme from a string (presumably from the @GHC_COLORS@+-- environment variable).+parseScheme :: String -> (OverridingBool, Scheme) -> (OverridingBool, Scheme)+parseScheme "always" (_, cs) = (Always, cs)+parseScheme "auto"   (_, cs) = (Auto,   cs)+parseScheme "never"  (_, cs) = (Never,  cs)+parseScheme input    (b, cs) =+  ( b+  , Scheme+    { sHeader  = fromMaybe (sHeader cs)  (lookup "header" table)+    , sMessage = fromMaybe (sMessage cs) (lookup "message" table)+    , sWarning = fromMaybe (sWarning cs) (lookup "warning" table)+    , sError   = fromMaybe (sError cs)   (lookup "error"   table)+    , sFatal   = fromMaybe (sFatal cs)   (lookup "fatal"   table)+    , sMargin  = fromMaybe (sMargin cs)  (lookup "margin"  table)+    }+  )+  where+    table = do+      w <- split ':' input+      let (k, v') = break (== '=') w+      case v' of+        '=' : v -> return (k, colCustom v)+        _ -> []
+ utils/Pretty.hs view
@@ -0,0 +1,1050 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Pretty+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  David Terei <code@davidterei.com>+-- Stability   :  stable+-- Portability :  portable+--+-- John Hughes's and Simon Peyton Jones's Pretty Printer Combinators+--+-- Based on /The Design of a Pretty-printing Library/+-- in Advanced Functional Programming,+-- Johan Jeuring and Erik Meijer (eds), LNCS 925+-- <http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps>+--+-----------------------------------------------------------------------------++{-+Note [Differences between libraries/pretty and compiler/utils/Pretty.hs]++For historical reasons, there are two different copies of `Pretty` in the GHC+source tree:+ * `libraries/pretty` is a submodule containing+   https://github.com/haskell/pretty. This is the `pretty` library as released+   on hackage. It is used by several other libraries in the GHC source tree+   (e.g. template-haskell and Cabal).+ * `compiler/utils/Pretty.hs` (this module). It is used by GHC only.++There is an ongoing effort in https://github.com/haskell/pretty/issues/1 and+https://ghc.haskell.org/trac/ghc/ticket/10735 to try to get rid of GHC's copy+of Pretty.++Currently, GHC's copy of Pretty resembles pretty-1.1.2.0, with the following+major differences:+ * GHC's copy uses `Faststring` for performance reasons.+ * GHC's copy has received a backported bugfix for #12227, which was+   released as pretty-1.1.3.4 ("Remove harmful $! forcing in beside",+   https://github.com/haskell/pretty/pull/35).++Other differences are minor. Both copies define some extra functions and+instances not defined in the other copy. To see all differences, do this in a+ghc git tree:++    $ cd libraries/pretty+    $ git checkout v1.1.2.0+    $ cd -+    $ vimdiff compiler/utils/Pretty.hs \+              libraries/pretty/src/Text/PrettyPrint/HughesPJ.hs++For parity with `pretty-1.1.2.1`, the following two `pretty` commits would+have to be backported:+  * "Resolve foldr-strictness stack overflow bug"+    (307b8173f41cd776eae8f547267df6d72bff2d68)+  * "Special-case reduce for horiz/vert"+    (c57c7a9dfc49617ba8d6e4fcdb019a3f29f1044c)+This has not been done sofar, because these commits seem to cause more+allocation in the compiler (see thomie's comments in+https://github.com/haskell/pretty/pull/9).+-}++module Pretty (++        -- * The document type+        Doc, TextDetails(..),++        -- * Constructing documents++        -- ** Converting values into documents+        char, text, ftext, ptext, ztext, sizedText, zeroWidthText,+        int, integer, float, double, rational,++        -- ** Simple derived documents+        semi, comma, colon, space, equals,+        lparen, rparen, lbrack, rbrack, lbrace, rbrace,++        -- ** Wrapping documents in delimiters+        parens, brackets, braces, quotes, quote, doubleQuotes,+        maybeParens,++        -- ** Combining documents+        empty,+        (<>), (<+>), hcat, hsep,+        ($$), ($+$), vcat,+        sep, cat,+        fsep, fcat,+        nest,+        hang, hangNotEmpty, punctuate,++        -- * Predicates on documents+        isEmpty,++        -- * Rendering documents++        -- ** Rendering with a particular style+        Style(..),+        style,+        renderStyle,+        Mode(..),++        -- ** General rendering+        fullRender,++        -- ** GHC-specific rendering+        printDoc, printDoc_,+        bufLeftRender -- performance hack++  ) where++import BufWrite+import FastString+import Panic+import System.IO+import Prelude hiding (error)++--for a RULES+import GHC.Base ( unpackCString# )+import GHC.Ptr  ( Ptr(..) )++-- Don't import Util( assertPanic ) because it makes a loop in the module structure+++-- ---------------------------------------------------------------------------+-- The Doc calculus++{-+Laws for $$+~~~~~~~~~~~+<a1>    (x $$ y) $$ z   = x $$ (y $$ z)+<a2>    empty $$ x      = x+<a3>    x $$ empty      = x++        ...ditto $+$...++Laws for <>+~~~~~~~~~~~+<b1>    (x <> y) <> z   = x <> (y <> z)+<b2>    empty <> x      = empty+<b3>    x <> empty      = x++        ...ditto <+>...++Laws for text+~~~~~~~~~~~~~+<t1>    text s <> text t        = text (s++t)+<t2>    text "" <> x            = x, if x non-empty++** because of law n6, t2 only holds if x doesn't+** start with `nest'.+++Laws for nest+~~~~~~~~~~~~~+<n1>    nest 0 x                = x+<n2>    nest k (nest k' x)      = nest (k+k') x+<n3>    nest k (x <> y)         = nest k x <> nest k y+<n4>    nest k (x $$ y)         = nest k x $$ nest k y+<n5>    nest k empty            = empty+<n6>    x <> nest k y           = x <> y, if x non-empty++** Note the side condition on <n6>!  It is this that+** makes it OK for empty to be a left unit for <>.++Miscellaneous+~~~~~~~~~~~~~+<m1>    (text s <> x) $$ y = text s <> ((text "" <> x) $$+                                         nest (-length s) y)++<m2>    (x $$ y) <> z = x $$ (y <> z)+        if y non-empty+++Laws for list versions+~~~~~~~~~~~~~~~~~~~~~~+<l1>    sep (ps++[empty]++qs)   = sep (ps ++ qs)+        ...ditto hsep, hcat, vcat, fill...++<l2>    nest k (sep ps) = sep (map (nest k) ps)+        ...ditto hsep, hcat, vcat, fill...++Laws for oneLiner+~~~~~~~~~~~~~~~~~+<o1>    oneLiner (nest k p) = nest k (oneLiner p)+<o2>    oneLiner (x <> y)   = oneLiner x <> oneLiner y++You might think that the following verion of <m1> would+be neater:++<3 NO>  (text s <> x) $$ y = text s <> ((empty <> x)) $$+                                         nest (-length s) y)++But it doesn't work, for if x=empty, we would have++        text s $$ y = text s <> (empty $$ nest (-length s) y)+                    = text s <> nest (-length s) y+-}++-- ---------------------------------------------------------------------------+-- Operator fixity++infixl 6 <>+infixl 6 <+>+infixl 5 $$, $+$+++-- ---------------------------------------------------------------------------+-- The Doc data type++-- | The abstract type of documents.+-- A Doc represents a *set* of layouts. A Doc with+-- no occurrences of Union or NoDoc represents just one layout.+data Doc+  = Empty                                            -- empty+  | NilAbove Doc                                     -- text "" $$ x+  | TextBeside !TextDetails {-# UNPACK #-} !Int Doc  -- text s <> x+  | Nest {-# UNPACK #-} !Int Doc                     -- nest k x+  | Union Doc Doc                                    -- ul `union` ur+  | NoDoc                                            -- The empty set of documents+  | Beside Doc Bool Doc                              -- True <=> space between+  | Above Doc Bool Doc                               -- True <=> never overlap++{-+Here are the invariants:++1) The argument of NilAbove is never Empty. Therefore+   a NilAbove occupies at least two lines.++2) The argument of @TextBeside@ is never @Nest@.++3) The layouts of the two arguments of @Union@ both flatten to the same+   string.++4) The arguments of @Union@ are either @TextBeside@, or @NilAbove@.++5) A @NoDoc@ may only appear on the first line of the left argument of an+   union. Therefore, the right argument of an union can never be equivalent+   to the empty set (@NoDoc@).++6) An empty document is always represented by @Empty@.  It can't be+   hidden inside a @Nest@, or a @Union@ of two @Empty@s.++7) The first line of every layout in the left argument of @Union@ is+   longer than the first line of any layout in the right argument.+   (1) ensures that the left argument has a first line.  In view of+   (3), this invariant means that the right argument must have at+   least two lines.++Notice the difference between+   * NoDoc (no documents)+   * Empty (one empty document; no height and no width)+   * text "" (a document containing the empty string;+              one line high, but has no width)+-}+++-- | RDoc is a "reduced GDoc", guaranteed not to have a top-level Above or Beside.+type RDoc = Doc++-- | The TextDetails data type+--+-- A TextDetails represents a fragment of text that will be+-- output at some point.+data TextDetails = Chr  {-# UNPACK #-} !Char -- ^ A single Char fragment+                 | Str  String -- ^ A whole String fragment+                 | PStr FastString                      -- a hashed string+                 | ZStr FastZString                     -- a z-encoded string+                 | LStr {-# UNPACK #-} !LitString {-#UNPACK #-} !Int+                   -- a '\0'-terminated array of bytes++instance Show Doc where+  showsPrec _ doc cont = fullRender (mode style) (lineLength style)+                                    (ribbonsPerLine style)+                                    txtPrinter cont doc+++-- ---------------------------------------------------------------------------+-- Values and Predicates on GDocs and TextDetails++-- | A document of height and width 1, containing a literal character.+char :: Char -> Doc+char c = textBeside_ (Chr c) 1 Empty++-- | A document of height 1 containing a literal string.+-- 'text' satisfies the following laws:+--+-- * @'text' s '<>' 'text' t = 'text' (s'++'t)@+--+-- * @'text' \"\" '<>' x = x@, if @x@ non-empty+--+-- The side condition on the last law is necessary because @'text' \"\"@+-- has height 1, while 'empty' has no height.+text :: String -> Doc+text s = case length s of {sl -> textBeside_ (Str s)  sl Empty}+{-# NOINLINE [0] text #-}   -- Give the RULE a chance to fire+                            -- It must wait till after phase 1 when+                            -- the unpackCString first is manifested++-- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the+-- intermediate packing/unpacking of the string.+{-# RULES+  "text/str" forall a. text (unpackCString# a) = ptext (Ptr a)+ #-}++ftext :: FastString -> Doc+ftext s = case lengthFS s of {sl -> textBeside_ (PStr s) sl Empty}++ptext :: LitString -> Doc+ptext s = case lengthLS s of {sl -> textBeside_ (LStr s sl) sl Empty}++ztext :: FastZString -> Doc+ztext s = case lengthFZS s of {sl -> textBeside_ (ZStr s) sl Empty}++-- | Some text with any width. (@text s = sizedText (length s) s@)+sizedText :: Int -> String -> Doc+sizedText l s = textBeside_ (Str s) l Empty++-- | Some text, but without any width. Use for non-printing text+-- such as a HTML or Latex tags+zeroWidthText :: String -> Doc+zeroWidthText = sizedText 0++-- | The empty document, with no height and no width.+-- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere+-- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc.+empty :: Doc+empty = Empty++-- | Returns 'True' if the document is empty+isEmpty :: Doc -> Bool+isEmpty Empty = True+isEmpty _     = False++-- | Produce spacing for indenting the amount specified.+--+-- an old version inserted tabs being 8 columns apart in the output.+spaces :: Int -> String+spaces !n = replicate n ' '++{-+Q: What is the reason for negative indentation (i.e. argument to indent+   is < 0) ?++A:+This indicates an error in the library client's code.+If we compose a <> b, and the first line of b is more indented than some+other lines of b, the law <n6> (<> eats nests) may cause the pretty+printer to produce an invalid layout:++doc       |0123345+------------------+d1        |a...|+d2        |...b|+          |c...|++d1<>d2    |ab..|+         c|....|++Consider a <> b, let `s' be the length of the last line of `a', `k' the+indentation of the first line of b, and `k0' the indentation of the+left-most line b_i of b.++The produced layout will have negative indentation if `k - k0 > s', as+the first line of b will be put on the (s+1)th column, effectively+translating b horizontally by (k-s). Now if the i^th line of b has an+indentation k0 < (k-s), it is translated out-of-page, causing+`negative indentation'.+-}+++semi   :: Doc -- ^ A ';' character+comma  :: Doc -- ^ A ',' character+colon  :: Doc -- ^ A ':' character+space  :: Doc -- ^ A space character+equals :: Doc -- ^ A '=' character+lparen :: Doc -- ^ A '(' character+rparen :: Doc -- ^ A ')' character+lbrack :: Doc -- ^ A '[' character+rbrack :: Doc -- ^ A ']' character+lbrace :: Doc -- ^ A '{' character+rbrace :: Doc -- ^ A '}' character+semi   = char ';'+comma  = char ','+colon  = char ':'+space  = char ' '+equals = char '='+lparen = char '('+rparen = char ')'+lbrack = char '['+rbrack = char ']'+lbrace = char '{'+rbrace = char '}'++spaceText, nlText :: TextDetails+spaceText = Chr ' '+nlText    = Chr '\n'++int      :: Int      -> Doc -- ^ @int n = text (show n)@+integer  :: Integer  -> Doc -- ^ @integer n = text (show n)@+float    :: Float    -> Doc -- ^ @float n = text (show n)@+double   :: Double   -> Doc -- ^ @double n = text (show n)@+rational :: Rational -> Doc -- ^ @rational n = text (show n)@+int      n = text (show n)+integer  n = text (show n)+float    n = text (show n)+double   n = text (show n)+rational n = text (show n)++parens       :: Doc -> Doc -- ^ Wrap document in @(...)@+brackets     :: Doc -> Doc -- ^ Wrap document in @[...]@+braces       :: Doc -> Doc -- ^ Wrap document in @{...}@+quotes       :: Doc -> Doc -- ^ Wrap document in @\'...\'@+quote        :: Doc -> Doc+doubleQuotes :: Doc -> Doc -- ^ Wrap document in @\"...\"@+quotes p       = char '`' <> p <> char '\''+quote p        = char '\'' <> p+doubleQuotes p = char '"' <> p <> char '"'+parens p       = char '(' <> p <> char ')'+brackets p     = char '[' <> p <> char ']'+braces p       = char '{' <> p <> char '}'++-- | Apply 'parens' to 'Doc' if boolean is true.+maybeParens :: Bool -> Doc -> Doc+maybeParens False = id+maybeParens True = parens++-- ---------------------------------------------------------------------------+-- Structural operations on GDocs++-- | Perform some simplification of a built up @GDoc@.+reduceDoc :: Doc -> RDoc+reduceDoc (Beside p g q) = beside p g (reduceDoc q)+reduceDoc (Above  p g q) = above  p g (reduceDoc q)+reduceDoc p              = p++-- | List version of '<>'.+hcat :: [Doc] -> Doc+hcat = reduceAB . foldr (beside_' False) empty++-- | List version of '<+>'.+hsep :: [Doc] -> Doc+hsep = reduceAB . foldr (beside_' True)  empty++-- | List version of '$$'.+vcat :: [Doc] -> Doc+vcat = reduceAB . foldr (above_' False) empty++-- | Nest (or indent) a document by a given number of positions+-- (which may also be negative).  'nest' satisfies the laws:+--+-- * @'nest' 0 x = x@+--+-- * @'nest' k ('nest' k' x) = 'nest' (k+k') x@+--+-- * @'nest' k (x '<>' y) = 'nest' k z '<>' 'nest' k y@+--+-- * @'nest' k (x '$$' y) = 'nest' k x '$$' 'nest' k y@+--+-- * @'nest' k 'empty' = 'empty'@+--+-- * @x '<>' 'nest' k y = x '<>' y@, if @x@ non-empty+--+-- The side condition on the last law is needed because+-- 'empty' is a left identity for '<>'.+nest :: Int -> Doc -> Doc+nest k p = mkNest k (reduceDoc p)++-- | @hang d1 n d2 = sep [d1, nest n d2]@+hang :: Doc -> Int -> Doc -> Doc+hang d1 n d2 = sep [d1, nest n d2]++-- | Apply 'hang' to the arguments if the first 'Doc' is not empty.+hangNotEmpty :: Doc -> Int -> Doc -> Doc+hangNotEmpty d1 n d2 = if isEmpty d1+                       then d2+                       else hang d1 n d2++-- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@+punctuate :: Doc -> [Doc] -> [Doc]+punctuate _ []     = []+punctuate p (x:xs) = go x xs+                   where go y []     = [y]+                         go y (z:zs) = (y <> p) : go z zs++-- mkNest checks for Nest's invariant that it doesn't have an Empty inside it+mkNest :: Int -> Doc -> Doc+mkNest k _ | k `seq` False = undefined+mkNest k (Nest k1 p)       = mkNest (k + k1) p+mkNest _ NoDoc             = NoDoc+mkNest _ Empty             = Empty+mkNest 0 p                 = p+mkNest k p                 = nest_ k p++-- mkUnion checks for an empty document+mkUnion :: Doc -> Doc -> Doc+mkUnion Empty _ = Empty+mkUnion p q     = p `union_` q++beside_' :: Bool -> Doc -> Doc -> Doc+beside_' _ p Empty = p+beside_' g p q     = Beside p g q++above_' :: Bool -> Doc -> Doc -> Doc+above_' _ p Empty = p+above_' g p q     = Above p g q++reduceAB :: Doc -> Doc+reduceAB (Above  Empty _ q) = q+reduceAB (Beside Empty _ q) = q+reduceAB doc                = doc++nilAbove_ :: RDoc -> RDoc+nilAbove_ = NilAbove++-- Arg of a TextBeside is always an RDoc+textBeside_ :: TextDetails -> Int -> RDoc -> RDoc+textBeside_ = TextBeside++nest_ :: Int -> RDoc -> RDoc+nest_ = Nest++union_ :: RDoc -> RDoc -> RDoc+union_ = Union+++-- ---------------------------------------------------------------------------+-- Vertical composition @$$@++-- | Above, except that if the last line of the first argument stops+-- at least one position before the first line of the second begins,+-- these two lines are overlapped.  For example:+--+-- >    text "hi" $$ nest 5 (text "there")+--+-- lays out as+--+-- >    hi   there+--+-- rather than+--+-- >    hi+-- >         there+--+-- '$$' is associative, with identity 'empty', and also satisfies+--+-- * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty.+--+($$) :: Doc -> Doc -> Doc+p $$  q = above_ p False q++-- | Above, with no overlapping.+-- '$+$' is associative, with identity 'empty'.+($+$) :: Doc -> Doc -> Doc+p $+$ q = above_ p True q++above_ :: Doc -> Bool -> Doc -> Doc+above_ p _ Empty = p+above_ Empty _ q = q+above_ p g q     = Above p g q++above :: Doc -> Bool -> RDoc -> RDoc+above (Above p g1 q1)  g2 q2 = above p g1 (above q1 g2 q2)+above p@(Beside{})     g  q  = aboveNest (reduceDoc p) g 0 (reduceDoc q)+above p g q                  = aboveNest p             g 0 (reduceDoc q)++-- Specification: aboveNest p g k q = p $g$ (nest k q)+aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc+aboveNest _                   _ k _ | k `seq` False = undefined+aboveNest NoDoc               _ _ _ = NoDoc+aboveNest (p1 `Union` p2)     g k q = aboveNest p1 g k q `union_`+                                      aboveNest p2 g k q++aboveNest Empty               _ k q = mkNest k q+aboveNest (Nest k1 p)         g k q = nest_ k1 (aboveNest p g (k - k1) q)+                                  -- p can't be Empty, so no need for mkNest++aboveNest (NilAbove p)        g k q = nilAbove_ (aboveNest p g k q)+aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest+                                    where+                                      !k1  = k - sl+                                      rest = case p of+                                                Empty -> nilAboveNest g k1 q+                                                _     -> aboveNest  p g k1 q+aboveNest (Above {})          _ _ _ = error "aboveNest Above"+aboveNest (Beside {})         _ _ _ = error "aboveNest Beside"++-- Specification: text s <> nilaboveNest g k q+--              = text s <> (text "" $g$ nest k q)+nilAboveNest :: Bool -> Int -> RDoc -> RDoc+nilAboveNest _ k _           | k `seq` False = undefined+nilAboveNest _ _ Empty       = Empty+                               -- Here's why the "text s <>" is in the spec!+nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q+nilAboveNest g k q           | not g && k > 0      -- No newline if no overlap+                             = textBeside_ (Str (spaces k)) k q+                             | otherwise           -- Put them really above+                             = nilAbove_ (mkNest k q)+++-- ---------------------------------------------------------------------------+-- Horizontal composition @<>@++-- We intentionally avoid Data.Monoid.(<>) here due to interactions of+-- Data.Monoid.(<>) and (<+>).  See+-- http://www.haskell.org/pipermail/libraries/2011-November/017066.html++-- | Beside.+-- '<>' is associative, with identity 'empty'.+(<>) :: Doc -> Doc -> Doc+p <>  q = beside_ p False q++-- | Beside, separated by space, unless one of the arguments is 'empty'.+-- '<+>' is associative, with identity 'empty'.+(<+>) :: Doc -> Doc -> Doc+p <+> q = beside_ p True  q++beside_ :: Doc -> Bool -> Doc -> Doc+beside_ p _ Empty = p+beside_ Empty _ q = q+beside_ p g q     = Beside p g q++-- Specification: beside g p q = p <g> q+beside :: Doc -> Bool -> RDoc -> RDoc+beside NoDoc               _ _   = NoDoc+beside (p1 `Union` p2)     g q   = beside p1 g q `union_` beside p2 g q+beside Empty               _ q   = q+beside (Nest k p)          g q   = nest_ k $! beside p g q+beside p@(Beside p1 g1 q1) g2 q2+         | g1 == g2              = beside p1 g1 $! beside q1 g2 q2+         | otherwise             = beside (reduceDoc p) g2 q2+beside p@(Above{})         g q   = let !d = reduceDoc p in beside d g q+beside (NilAbove p)        g q   = nilAbove_ $! beside p g q+beside (TextBeside s sl p) g q   = textBeside_ s sl rest+                               where+                                  rest = case p of+                                           Empty -> nilBeside g q+                                           _     -> beside p g q++-- Specification: text "" <> nilBeside g p+--              = text "" <g> p+nilBeside :: Bool -> RDoc -> RDoc+nilBeside _ Empty         = Empty -- Hence the text "" in the spec+nilBeside g (Nest _ p)    = nilBeside g p+nilBeside g p | g         = textBeside_ spaceText 1 p+              | otherwise = p+++-- ---------------------------------------------------------------------------+-- Separate, @sep@++-- Specification: sep ps  = oneLiner (hsep ps)+--                         `union`+--                          vcat ps++-- | Either 'hsep' or 'vcat'.+sep  :: [Doc] -> Doc+sep = sepX True   -- Separate with spaces++-- | Either 'hcat' or 'vcat'.+cat :: [Doc] -> Doc+cat = sepX False  -- Don't++sepX :: Bool -> [Doc] -> Doc+sepX _ []     = empty+sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps+++-- Specification: sep1 g k ys = sep (x : map (nest k) ys)+--                            = oneLiner (x <g> nest k (hsep ys))+--                              `union` x $$ nest k (vcat ys)+sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc+sep1 _ _                   k _  | k `seq` False = undefined+sep1 _ NoDoc               _ _  = NoDoc+sep1 g (p `Union` q)       k ys = sep1 g p k ys `union_`+                                  aboveNest q False k (reduceDoc (vcat ys))++sep1 g Empty               k ys = mkNest k (sepX g ys)+sep1 g (Nest n p)          k ys = nest_ n (sep1 g p (k - n) ys)++sep1 _ (NilAbove p)        k ys = nilAbove_+                                  (aboveNest p False k (reduceDoc (vcat ys)))+sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys)+sep1 _ (Above {})          _ _  = error "sep1 Above"+sep1 _ (Beside {})         _ _  = error "sep1 Beside"++-- Specification: sepNB p k ys = sep1 (text "" <> p) k ys+-- Called when we have already found some text in the first item+-- We have to eat up nests+sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc+sepNB g (Nest _ p) k ys+  = sepNB g p k ys -- Never triggered, because of invariant (2)+sepNB g Empty k ys+  = oneLiner (nilBeside g (reduceDoc rest)) `mkUnion`+    -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...)+    nilAboveNest False k (reduceDoc (vcat ys))+  where+    rest | g         = hsep ys+         | otherwise = hcat ys+sepNB g p k ys+  = sep1 g p k ys+++-- ---------------------------------------------------------------------------+-- @fill@++-- | \"Paragraph fill\" version of 'cat'.+fcat :: [Doc] -> Doc+fcat = fill False++-- | \"Paragraph fill\" version of 'sep'.+fsep :: [Doc] -> Doc+fsep = fill True++-- Specification:+--+-- fill g docs = fillIndent 0 docs+--+-- fillIndent k [] = []+-- fillIndent k [p] = p+-- fillIndent k (p1:p2:ps) =+--    oneLiner p1 <g> fillIndent (k + length p1 + g ? 1 : 0)+--                               (remove_nests (oneLiner p2) : ps)+--     `Union`+--    (p1 $*$ nest (-k) (fillIndent 0 ps))+--+-- $*$ is defined for layouts (not Docs) as+-- layout1 $*$ layout2 | hasMoreThanOneLine layout1 = layout1 $$ layout2+--                     | otherwise                  = layout1 $+$ layout2++fill :: Bool -> [Doc] -> RDoc+fill _ []     = empty+fill g (p:ps) = fill1 g (reduceDoc p) 0 ps++fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc+fill1 _ _                   k _  | k `seq` False = undefined+fill1 _ NoDoc               _ _  = NoDoc+fill1 g (p `Union` q)       k ys = fill1 g p k ys `union_`+                                   aboveNest q False k (fill g ys)+fill1 g Empty               k ys = mkNest k (fill g ys)+fill1 g (Nest n p)          k ys = nest_ n (fill1 g p (k - n) ys)+fill1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (fill g ys))+fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys)+fill1 _ (Above {})          _ _  = error "fill1 Above"+fill1 _ (Beside {})         _ _  = error "fill1 Beside"++fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc+fillNB _ _           k _  | k `seq` False = undefined+fillNB g (Nest _ p)  k ys   = fillNB g p k ys+                              -- Never triggered, because of invariant (2)+fillNB _ Empty _ []         = Empty+fillNB g Empty k (Empty:ys) = fillNB g Empty k ys+fillNB g Empty k (y:ys)     = fillNBE g k y ys+fillNB g p k ys             = fill1 g p k ys+++fillNBE :: Bool -> Int -> Doc -> [Doc] -> Doc+fillNBE g k y ys+  = nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k' ys)+    -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...)+    `mkUnion` nilAboveNest False k (fill g (y:ys))+  where k' = if g then k - 1 else k++elideNest :: Doc -> Doc+elideNest (Nest _ d) = d+elideNest d          = d++-- ---------------------------------------------------------------------------+-- Selecting the best layout++best :: Int   -- Line length+     -> Int   -- Ribbon length+     -> RDoc+     -> RDoc  -- No unions in here!+best w0 r = get w0+  where+    get :: Int          -- (Remaining) width of line+        -> Doc -> Doc+    get w _ | w == 0 && False = undefined+    get _ Empty               = Empty+    get _ NoDoc               = NoDoc+    get w (NilAbove p)        = nilAbove_ (get w p)+    get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)+    get w (Nest k p)          = nest_ k (get (w - k) p)+    get w (p `Union` q)       = nicest w r (get w p) (get w q)+    get _ (Above {})          = error "best get Above"+    get _ (Beside {})         = error "best get Beside"++    get1 :: Int         -- (Remaining) width of line+         -> Int         -- Amount of first line already eaten up+         -> Doc         -- This is an argument to TextBeside => eat Nests+         -> Doc         -- No unions in here!++    get1 w _ _ | w == 0 && False  = undefined+    get1 _ _  Empty               = Empty+    get1 _ _  NoDoc               = NoDoc+    get1 w sl (NilAbove p)        = nilAbove_ (get (w - sl) p)+    get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p)+    get1 w sl (Nest _ p)          = get1 w sl p+    get1 w sl (p `Union` q)       = nicest1 w r sl (get1 w sl p)+                                                   (get1 w sl q)+    get1 _ _  (Above {})          = error "best get1 Above"+    get1 _ _  (Beside {})         = error "best get1 Beside"++nicest :: Int -> Int -> Doc -> Doc -> Doc+nicest !w !r = nicest1 w r 0++nicest1 :: Int -> Int -> Int -> Doc -> Doc -> Doc+nicest1 !w !r !sl p q | fits ((w `min` r) - sl) p = p+                      | otherwise                 = q++fits :: Int  -- Space available+     -> Doc+     -> Bool -- True if *first line* of Doc fits in space available+fits n _ | n < 0           = False+fits _ NoDoc               = False+fits _ Empty               = True+fits _ (NilAbove _)        = True+fits n (TextBeside _ sl p) = fits (n - sl) p+fits _ (Above {})          = error "fits Above"+fits _ (Beside {})         = error "fits Beside"+fits _ (Union {})          = error "fits Union"+fits _ (Nest {})           = error "fits Nest"++-- | @first@ returns its first argument if it is non-empty, otherwise its second.+first :: Doc -> Doc -> Doc+first p q | nonEmptySet p = p -- unused, because (get OneLineMode) is unused+          | otherwise     = q++nonEmptySet :: Doc -> Bool+nonEmptySet NoDoc              = False+nonEmptySet (_ `Union` _)      = True+nonEmptySet Empty              = True+nonEmptySet (NilAbove _)       = True+nonEmptySet (TextBeside _ _ p) = nonEmptySet p+nonEmptySet (Nest _ p)         = nonEmptySet p+nonEmptySet (Above {})         = error "nonEmptySet Above"+nonEmptySet (Beside {})        = error "nonEmptySet Beside"++-- @oneLiner@ returns the one-line members of the given set of @GDoc@s.+oneLiner :: Doc -> Doc+oneLiner NoDoc               = NoDoc+oneLiner Empty               = Empty+oneLiner (NilAbove _)        = NoDoc+oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)+oneLiner (Nest k p)          = nest_ k (oneLiner p)+oneLiner (p `Union` _)       = oneLiner p+oneLiner (Above {})          = error "oneLiner Above"+oneLiner (Beside {})         = error "oneLiner Beside"+++-- ---------------------------------------------------------------------------+-- Rendering++-- | A rendering style.+data Style+  = Style { mode           :: Mode  -- ^ The rendering mode+          , lineLength     :: Int   -- ^ Length of line, in chars+          , ribbonsPerLine :: Float -- ^ Ratio of line length to ribbon length+          }++-- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@).+style :: Style+style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode }++-- | Rendering mode.+data Mode = PageMode     -- ^ Normal+          | ZigZagMode   -- ^ With zig-zag cuts+          | LeftMode     -- ^ No indentation, infinitely long lines+          | OneLineMode  -- ^ All on one line++-- | Render the @Doc@ to a String using the given @Style@.+renderStyle :: Style -> Doc -> String+renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s)+                txtPrinter ""++-- | Default TextDetails printer+txtPrinter :: TextDetails -> String -> String+txtPrinter (Chr c)   s  = c:s+txtPrinter (Str s1)  s2 = s1 ++ s2+txtPrinter (PStr s1) s2 = unpackFS s1 ++ s2+txtPrinter (ZStr s1) s2 = zString s1 ++ s2+txtPrinter (LStr s1 _) s2 = unpackLitString s1 ++ s2++-- | The general rendering interface.+fullRender :: Mode                     -- ^ Rendering mode+           -> Int                      -- ^ Line length+           -> Float                    -- ^ Ribbons per line+           -> (TextDetails -> a -> a)  -- ^ What to do with text+           -> a                        -- ^ What to do at the end+           -> Doc                      -- ^ The document+           -> a                        -- ^ Result+fullRender OneLineMode _ _ txt end doc+  = easyDisplay spaceText (\_ y -> y) txt end (reduceDoc doc)+fullRender LeftMode    _ _ txt end doc+  = easyDisplay nlText first txt end (reduceDoc doc)++fullRender m lineLen ribbons txt rest doc+  = display m lineLen ribbonLen txt rest doc'+  where+    doc' = best bestLineLen ribbonLen (reduceDoc doc)++    bestLineLen, ribbonLen :: Int+    ribbonLen   = round (fromIntegral lineLen / ribbons)+    bestLineLen = case m of+                      ZigZagMode -> maxBound+                      _          -> lineLen++easyDisplay :: TextDetails+             -> (Doc -> Doc -> Doc)+             -> (TextDetails -> a -> a)+             -> a+             -> Doc+             -> a+easyDisplay nlSpaceText choose txt end+  = lay+  where+    lay NoDoc              = error "easyDisplay: NoDoc"+    lay (Union p q)        = lay (choose p q)+    lay (Nest _ p)         = lay p+    lay Empty              = end+    lay (NilAbove p)       = nlSpaceText `txt` lay p+    lay (TextBeside s _ p) = s `txt` lay p+    lay (Above {})         = error "easyDisplay Above"+    lay (Beside {})        = error "easyDisplay Beside"++display :: Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Doc -> a+display m !page_width !ribbon_width txt end doc+  = case page_width - ribbon_width of { gap_width ->+    case gap_width `quot` 2 of { shift ->+    let+        lay k _            | k `seq` False = undefined+        lay k (Nest k1 p)  = lay (k + k1) p+        lay _ Empty        = end+        lay k (NilAbove p) = nlText `txt` lay k p+        lay k (TextBeside s sl p)+            = case m of+                    ZigZagMode |  k >= gap_width+                               -> nlText `txt` (+                                  Str (replicate shift '/') `txt` (+                                  nlText `txt`+                                  lay1 (k - shift) s sl p ))++                               |  k < 0+                               -> nlText `txt` (+                                  Str (replicate shift '\\') `txt` (+                                  nlText `txt`+                                  lay1 (k + shift) s sl p ))++                    _ -> lay1 k s sl p+        lay _ (Above {})   = error "display lay Above"+        lay _ (Beside {})  = error "display lay Beside"+        lay _ NoDoc        = error "display lay NoDoc"+        lay _ (Union {})   = error "display lay Union"++        lay1 !k s !sl p    = let !r = k + sl+                             in indent k (s `txt` lay2 r p)++        lay2 k _ | k `seq` False   = undefined+        lay2 k (NilAbove p)        = nlText `txt` lay k p+        lay2 k (TextBeside s sl p) = s `txt` lay2 (k + sl) p+        lay2 k (Nest _ p)          = lay2 k p+        lay2 _ Empty               = end+        lay2 _ (Above {})          = error "display lay2 Above"+        lay2 _ (Beside {})         = error "display lay2 Beside"+        lay2 _ NoDoc               = error "display lay2 NoDoc"+        lay2 _ (Union {})          = error "display lay2 Union"++        -- optimise long indentations using LitString chunks of 8 spaces+        indent !n r | n >= 8    = LStr (sLit "        ") 8 `txt`+                                  indent (n - 8) r+                    | otherwise = Str (spaces n) `txt` r+    in+    lay 0 doc+    }}++printDoc :: Mode -> Int -> Handle -> Doc -> IO ()+-- printDoc adds a newline to the end+printDoc mode cols hdl doc = printDoc_ mode cols hdl (doc $$ text "")++printDoc_ :: Mode -> Int -> Handle -> Doc -> IO ()+-- printDoc_ does not add a newline at the end, so that+-- successive calls can output stuff on the same line+-- Rather like putStr vs putStrLn+printDoc_ LeftMode _ hdl doc+  = do { printLeftRender hdl doc; hFlush hdl }+printDoc_ mode pprCols hdl doc+  = do { fullRender mode pprCols 1.5 put done doc ;+         hFlush hdl }+  where+    put (Chr c)  next = hPutChar hdl c >> next+    put (Str s)  next = hPutStr  hdl s >> next+    put (PStr s) next = hPutStr  hdl (unpackFS s) >> next+                        -- NB. not hPutFS, we want this to go through+                        -- the I/O library's encoding layer. (#3398)+    put (ZStr s) next = hPutFZS  hdl s >> next+    put (LStr s l) next = hPutLitString hdl s l >> next++    done = return () -- hPutChar hdl '\n'++  -- some versions of hPutBuf will barf if the length is zero+hPutLitString :: Handle -> Ptr a -> Int -> IO ()+hPutLitString handle a l = if l == 0+                            then return ()+                            else hPutBuf handle a l++-- Printing output in LeftMode is performance critical: it's used when+-- dumping C and assembly output, so we allow ourselves a few dirty+-- hacks:+--+-- (1) we specialise fullRender for LeftMode with IO output.+--+-- (2) we add a layer of buffering on top of Handles.  Handles+--     don't perform well with lots of hPutChars, which is mostly+--     what we're doing here, because Handles have to be thread-safe+--     and async exception-safe.  We only have a single thread and don't+--     care about exceptions, so we add a layer of fast buffering+--     over the Handle interface.++printLeftRender :: Handle -> Doc -> IO ()+printLeftRender hdl doc = do+  b <- newBufHandle hdl+  bufLeftRender b doc+  bFlush b++bufLeftRender :: BufHandle -> Doc -> IO ()+bufLeftRender b doc = layLeft b (reduceDoc doc)++layLeft :: BufHandle -> Doc -> IO ()+layLeft b _ | b `seq` False  = undefined -- make it strict in b+layLeft _ NoDoc              = error "layLeft: NoDoc"+layLeft b (Union p q)        = layLeft b (first p q)+layLeft b (Nest _ p)         = layLeft b p+layLeft b Empty              = bPutChar b '\n'+layLeft b (NilAbove p)       = bPutChar b '\n' >> layLeft b p+layLeft b (TextBeside s _ p) = put b s >> layLeft b p+ where+    put b _ | b `seq` False = undefined+    put b (Chr c)    = bPutChar b c+    put b (Str s)    = bPutStr  b s+    put b (PStr s)   = bPutFS   b s+    put b (ZStr s)   = bPutFZS  b s+    put b (LStr s l) = bPutLitString b s l+layLeft _ _                  = panic "layLeft: Unhandled case"++-- Define error=panic, for easier comparison with libraries/pretty.+error :: String -> a+error = panic
+ utils/State.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE UnboxedTuples #-}++module State where++newtype State s a = State { runState' :: s -> (# a, s #) }++instance Functor (State s) where+    fmap f m  = State $ \s -> case runState' m s of+                              (# r, s' #) -> (# f r, s' #)++instance Applicative (State s) where+   pure x   = State $ \s -> (# x, s #)+   m <*> n  = State $ \s -> case runState' m s of+                            (# f, s' #) -> case runState' n s' of+                                           (# x, s'' #) -> (# f x, s'' #)++instance Monad (State s) where+    m >>= n  = State $ \s -> case runState' m s of+                             (# r, s' #) -> runState' (n r) s'++get :: State s s+get = State $ \s -> (# s, s #)++gets :: (s -> a) -> State s a+gets f = State $ \s -> (# f s, s #)++put :: s -> State s ()+put s' = State $ \_ -> (# (), s' #)++modify :: (s -> s) -> State s ()+modify f = State $ \s -> (# (), f s #)+++evalState :: State s a -> s -> a+evalState s i = case runState' s i of+                (# a, _ #) -> a+++execState :: State s a -> s -> s+execState s i = case runState' s i of+                (# _, s' #) -> s'+++runState :: State s a -> s -> (a, s)+runState s i = case runState' s i of+               (# a, s' #) -> (a, s')
+ utils/Stream.hs view
@@ -0,0 +1,104 @@+-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow 2012+--+-- Monadic streams+--+-- -----------------------------------------------------------------------------+module Stream (+    Stream(..), yield, liftIO,+    collect, fromList,+    Stream.map, Stream.mapM, Stream.mapAccumL+  ) where++import Control.Monad++-- |+-- @Stream m a b@ is a computation in some Monad @m@ that delivers a sequence+-- of elements of type @a@ followed by a result of type @b@.+--+-- More concretely, a value of type @Stream m a b@ can be run using @runStream@+-- in the Monad @m@, and it delivers either+--+--  * the final result: @Left b@, or+--  * @Right (a,str)@, where @a@ is the next element in the stream, and @str@+--    is a computation to get the rest of the stream.+--+-- Stream is itself a Monad, and provides an operation 'yield' that+-- produces a new element of the stream.  This makes it convenient to turn+-- existing monadic computations into streams.+--+-- The idea is that Stream is useful for making a monadic computation+-- that produces values from time to time.  This can be used for+-- knitting together two complex monadic operations, so that the+-- producer does not have to produce all its values before the+-- consumer starts consuming them.  We make the producer into a+-- Stream, and the consumer pulls on the stream each time it wants a+-- new value.+--+newtype Stream m a b = Stream { runStream :: m (Either b (a, Stream m a b)) }++instance Monad f => Functor (Stream f a) where+  fmap = liftM++instance Monad m => Applicative (Stream m a) where+  pure a = Stream (return (Left a))+  (<*>) = ap++instance Monad m => Monad (Stream m a) where++  Stream m >>= k = Stream $ do+                r <- m+                case r of+                  Left b        -> runStream (k b)+                  Right (a,str) -> return (Right (a, str >>= k))++yield :: Monad m => a -> Stream m a ()+yield a = Stream (return (Right (a, return ())))++liftIO :: IO a -> Stream IO b a+liftIO io = Stream $ io >>= return . Left++-- | Turn a Stream into an ordinary list, by demanding all the elements.+collect :: Monad m => Stream m a () -> m [a]+collect str = go str []+ where+  go str acc = do+    r <- runStream str+    case r of+      Left () -> return (reverse acc)+      Right (a, str') -> go str' (a:acc)++-- | Turn a list into a 'Stream', by yielding each element in turn.+fromList :: Monad m => [a] -> Stream m a ()+fromList = mapM_ yield++-- | Apply a function to each element of a 'Stream', lazily+map :: Monad m => (a -> b) -> Stream m a x -> Stream m b x+map f str = Stream $ do+   r <- runStream str+   case r of+     Left x -> return (Left x)+     Right (a, str') -> return (Right (f a, Stream.map f str'))++-- | Apply a monadic operation to each element of a 'Stream', lazily+mapM :: Monad m => (a -> m b) -> Stream m a x -> Stream m b x+mapM f str = Stream $ do+   r <- runStream str+   case r of+     Left x -> return (Left x)+     Right (a, str') -> do+        b <- f a+        return (Right (b, Stream.mapM f str'))++-- | analog of the list-based 'mapAccumL' on Streams.  This is a simple+-- way to map over a Stream while carrying some state around.+mapAccumL :: Monad m => (c -> a -> m (c,b)) -> c -> Stream m a ()+          -> Stream m b c+mapAccumL f c str = Stream $ do+  r <- runStream str+  case r of+    Left  () -> return (Left c)+    Right (a, str') -> do+      (c',b) <- f c a+      return (Right (b, mapAccumL f c' str'))
+ utils/StringBuffer.hs view
@@ -0,0 +1,310 @@+{-+(c) The University of Glasgow 2006+(c) The University of Glasgow, 1997-2006+++Buffers for scanning string input stored in external arrays.+-}++{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-}+{-# OPTIONS_GHC -O #-}+-- We always optimise this, otherwise performance of a non-optimised+-- compiler is severely affected++module StringBuffer+       (+        StringBuffer(..),+        -- non-abstract for vs\/HaskellService++         -- * Creation\/destruction+        hGetStringBuffer,+        hGetStringBufferBlock,+        appendStringBuffers,+        stringToStringBuffer,++        -- * Inspection+        nextChar,+        currentChar,+        prevChar,+        atEnd,++        -- * Moving and comparison+        stepOn,+        offsetBytes,+        byteDiff,+        atLine,++        -- * Conversion+        lexemeToString,+        lexemeToFastString,++         -- * Parsing integers+        parseUnsignedInteger,+       ) where++#include "HsVersions.h"++import Encoding+import FastString+import FastFunctions+import Outputable+import Util++import Data.Maybe+import Control.Exception+import System.IO+import System.IO.Unsafe         ( unsafePerformIO )+import GHC.IO.Encoding.UTF8     ( mkUTF8 )+import GHC.IO.Encoding.Failure  ( CodingFailureMode(IgnoreCodingFailure) )++import GHC.Exts++import Foreign++-- -----------------------------------------------------------------------------+-- The StringBuffer type++-- |A StringBuffer is an internal pointer to a sized chunk of bytes.+-- The bytes are intended to be *immutable*.  There are pure+-- operations to read the contents of a StringBuffer.+--+-- A StringBuffer may have a finalizer, depending on how it was+-- obtained.+--+data StringBuffer+ = StringBuffer {+     buf :: {-# UNPACK #-} !(ForeignPtr Word8),+     len :: {-# UNPACK #-} !Int,        -- length+     cur :: {-# UNPACK #-} !Int         -- current pos+  }+  -- The buffer is assumed to be UTF-8 encoded, and furthermore+  -- we add three '\0' bytes to the end as sentinels so that the+  -- decoder doesn't have to check for overflow at every single byte+  -- of a multibyte sequence.++instance Show StringBuffer where+        showsPrec _ s = showString "<stringbuffer("+                      . shows (len s) . showString "," . shows (cur s)+                      . showString ")>"++-- -----------------------------------------------------------------------------+-- Creation / Destruction++-- | Read a file into a 'StringBuffer'.  The resulting buffer is automatically+-- managed by the garbage collector.+hGetStringBuffer :: FilePath -> IO StringBuffer+hGetStringBuffer fname = do+   h <- openBinaryFile fname ReadMode+   size_i <- hFileSize h+   offset_i <- skipBOM h size_i 0  -- offset is 0 initially+   let size = fromIntegral $ size_i - offset_i+   buf <- mallocForeignPtrArray (size+3)+   withForeignPtr buf $ \ptr -> do+     r <- if size == 0 then return 0 else hGetBuf h ptr size+     hClose h+     if (r /= size)+        then ioError (userError "short read of file")+        else newUTF8StringBuffer buf ptr size++hGetStringBufferBlock :: Handle -> Int -> IO StringBuffer+hGetStringBufferBlock handle wanted+    = do size_i <- hFileSize handle+         offset_i <- hTell handle >>= skipBOM handle size_i+         let size = min wanted (fromIntegral $ size_i-offset_i)+         buf <- mallocForeignPtrArray (size+3)+         withForeignPtr buf $ \ptr ->+             do r <- if size == 0 then return 0 else hGetBuf handle ptr size+                if r /= size+                   then ioError (userError $ "short read of file: "++show(r,size,size_i,handle))+                   else newUTF8StringBuffer buf ptr size++-- | Skip the byte-order mark if there is one (see #1744 and #6016),+-- and return the new position of the handle in bytes.+--+-- This is better than treating #FEFF as whitespace,+-- because that would mess up layout.  We don't have a concept+-- of zero-width whitespace in Haskell: all whitespace codepoints+-- have a width of one column.+skipBOM :: Handle -> Integer -> Integer -> IO Integer+skipBOM h size offset =+  -- Only skip BOM at the beginning of a file.+  if size > 0 && offset == 0+    then do+      -- Validate assumption that handle is in binary mode.+      ASSERTM( hGetEncoding h >>= return . isNothing )+      -- Temporarily select utf8 encoding with error ignoring,+      -- to make `hLookAhead` and `hGetChar` return full Unicode characters.+      bracket_ (hSetEncoding h safeEncoding) (hSetBinaryMode h True) $ do+        c <- hLookAhead h+        if c == '\xfeff'+          then hGetChar h >> hTell h+          else return offset+    else return offset+  where+    safeEncoding = mkUTF8 IgnoreCodingFailure++newUTF8StringBuffer :: ForeignPtr Word8 -> Ptr Word8 -> Int -> IO StringBuffer+newUTF8StringBuffer buf ptr size = do+  pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0]+  -- sentinels for UTF-8 decoding+  return $ StringBuffer buf size 0++appendStringBuffers :: StringBuffer -> StringBuffer -> IO StringBuffer+appendStringBuffers sb1 sb2+    = do newBuf <- mallocForeignPtrArray (size+3)+         withForeignPtr newBuf $ \ptr ->+          withForeignPtr (buf sb1) $ \sb1Ptr ->+           withForeignPtr (buf sb2) $ \sb2Ptr ->+             do copyArray ptr (sb1Ptr `advancePtr` cur sb1) sb1_len+                copyArray (ptr `advancePtr` sb1_len) (sb2Ptr `advancePtr` cur sb2) sb2_len+                pokeArray (ptr `advancePtr` size) [0,0,0]+                return (StringBuffer newBuf size 0)+    where sb1_len = calcLen sb1+          sb2_len = calcLen sb2+          calcLen sb = len sb - cur sb+          size =  sb1_len + sb2_len++-- | Encode a 'String' into a 'StringBuffer' as UTF-8.  The resulting buffer+-- is automatically managed by the garbage collector.+stringToStringBuffer :: String -> StringBuffer+stringToStringBuffer str =+ unsafePerformIO $ do+  let size = utf8EncodedLength str+  buf <- mallocForeignPtrArray (size+3)+  withForeignPtr buf $ \ptr -> do+    utf8EncodeString ptr str+    pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0]+    -- sentinels for UTF-8 decoding+  return (StringBuffer buf size 0)++-- -----------------------------------------------------------------------------+-- Grab a character++-- | Return the first UTF-8 character of a nonempty 'StringBuffer' and as well+-- the remaining portion (analogous to 'Data.List.uncons').  __Warning:__ The+-- behavior is undefined if the 'StringBuffer' is empty.  The result shares+-- the same buffer as the original.  Similar to 'utf8DecodeChar', if the+-- character cannot be decoded as UTF-8, '\0' is returned.+{-# INLINE nextChar #-}+nextChar :: StringBuffer -> (Char,StringBuffer)+nextChar (StringBuffer buf len (I# cur#)) =+  -- Getting our fingers dirty a little here, but this is performance-critical+  inlinePerformIO $ do+    withForeignPtr buf $ \(Ptr a#) -> do+        case utf8DecodeChar# (a# `plusAddr#` cur#) of+          (# c#, nBytes# #) ->+             let cur' = I# (cur# +# nBytes#) in+             return (C# c#, StringBuffer buf len cur')++-- | Return the first UTF-8 character of a nonempty 'StringBuffer' (analogous+-- to 'Data.List.head').  __Warning:__ The behavior is undefined if the+-- 'StringBuffer' is empty.  Similar to 'utf8DecodeChar', if the character+-- cannot be decoded as UTF-8, '\0' is returned.+currentChar :: StringBuffer -> Char+currentChar = fst . nextChar++prevChar :: StringBuffer -> Char -> Char+prevChar (StringBuffer _   _   0)   deflt = deflt+prevChar (StringBuffer buf _   cur) _     =+  inlinePerformIO $ do+    withForeignPtr buf $ \p -> do+      p' <- utf8PrevChar (p `plusPtr` cur)+      return (fst (utf8DecodeChar p'))++-- -----------------------------------------------------------------------------+-- Moving++-- | Return a 'StringBuffer' with the first UTF-8 character removed (analogous+-- to 'Data.List.tail').  __Warning:__ The behavior is undefined if the+-- 'StringBuffer' is empty.  The result shares the same buffer as the+-- original.+stepOn :: StringBuffer -> StringBuffer+stepOn s = snd (nextChar s)++-- | Return a 'StringBuffer' with the first @n@ bytes removed.  __Warning:__+-- If there aren't enough characters, the returned 'StringBuffer' will be+-- invalid and any use of it may lead to undefined behavior.  The result+-- shares the same buffer as the original.+offsetBytes :: Int                      -- ^ @n@, the number of bytes+            -> StringBuffer+            -> StringBuffer+offsetBytes i s = s { cur = cur s + i }++-- | Compute the difference in offset between two 'StringBuffer's that share+-- the same buffer.  __Warning:__ The behavior is undefined if the+-- 'StringBuffer's use separate buffers.+byteDiff :: StringBuffer -> StringBuffer -> Int+byteDiff s1 s2 = cur s2 - cur s1++-- | Check whether a 'StringBuffer' is empty (analogous to 'Data.List.null').+atEnd :: StringBuffer -> Bool+atEnd (StringBuffer _ l c) = l == c++-- | Computes a 'StringBuffer' which points to the first character of the+-- wanted line. Lines begin at 1.+atLine :: Int -> StringBuffer -> Maybe StringBuffer+atLine line sb@(StringBuffer buf len _) =+  inlinePerformIO $+    withForeignPtr buf $ \p -> do+      p' <- skipToLine line len p+      if p' == nullPtr+        then return Nothing+        else+          let+            delta = p' `minusPtr` p+          in return $ Just (sb { cur = delta+                               , len = len - delta+                               })++skipToLine :: Int -> Int -> Ptr Word8 -> IO (Ptr Word8)+skipToLine !line !len !op0 = go 1 op0+  where+    !opend = op0 `plusPtr` len++    go !i_line !op+      | op >= opend    = pure nullPtr+      | i_line == line = pure op+      | otherwise      = do+          w <- peek op :: IO Word8+          case w of+            10 -> go (i_line + 1) (plusPtr op 1)+            13 -> do+              -- this is safe because a 'StringBuffer' is+              -- guaranteed to have 3 bytes sentinel values.+              w' <- peek (plusPtr op 1) :: IO Word8+              case w' of+                10 -> go (i_line + 1) (plusPtr op 2)+                _  -> go (i_line + 1) (plusPtr op 1)+            _  -> go i_line (plusPtr op 1)++-- -----------------------------------------------------------------------------+-- Conversion++-- | Decode the first @n@ bytes of a 'StringBuffer' as UTF-8 into a 'String'.+-- Similar to 'utf8DecodeChar', if the character cannot be decoded as UTF-8,+-- they will be replaced with '\0'.+lexemeToString :: StringBuffer+               -> Int                   -- ^ @n@, the number of bytes+               -> String+lexemeToString _ 0 = ""+lexemeToString (StringBuffer buf _ cur) bytes =+  utf8DecodeStringLazy buf cur bytes++lexemeToFastString :: StringBuffer+                   -> Int               -- ^ @n@, the number of bytes+                   -> FastString+lexemeToFastString _ 0 = nilFS+lexemeToFastString (StringBuffer buf _ cur) len =+   inlinePerformIO $+     withForeignPtr buf $ \ptr ->+       return $! mkFastStringBytes (ptr `plusPtr` cur) len++-- -----------------------------------------------------------------------------+-- Parsing integer strings in various bases+parseUnsignedInteger :: StringBuffer -> Int -> Integer -> (Char->Int) -> Integer+parseUnsignedInteger (StringBuffer buf _ cur) len radix char_to_int+  = inlinePerformIO $ withForeignPtr buf $ \ptr -> return $! let+    go i x | i == len  = x+           | otherwise = case fst (utf8DecodeChar (ptr `plusPtr` (cur + i))) of+               char -> go (i + 1) (x * radix + toInteger (char_to_int char))+  in go 0 0
+ utils/UnVarGraph.hs view
@@ -0,0 +1,136 @@+{-++Copyright (c) 2014 Joachim Breitner++A data structure for undirected graphs of variables+(or in plain terms: Sets of unordered pairs of numbers)+++This is very specifically tailored for the use in CallArity. In particular it+stores the graph as a union of complete and complete bipartite graph, which+would be very expensive to store as sets of edges or as adjanceny lists.++It does not normalize the graphs. This means that g `unionUnVarGraph` g is+equal to g, but twice as expensive and large.++-}+module UnVarGraph+    ( UnVarSet+    , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets+    , delUnVarSet+    , elemUnVarSet, isEmptyUnVarSet+    , UnVarGraph+    , emptyUnVarGraph+    , unionUnVarGraph, unionUnVarGraphs+    , completeGraph, completeBipartiteGraph+    , neighbors+    , delNode+    ) where++import Id+import VarEnv+import UniqFM+import Outputable+import Data.List+import Bag+import Unique++import qualified Data.IntSet as S++-- We need a type for sets of variables (UnVarSet).+-- We do not use VarSet, because for that we need to have the actual variable+-- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet.+-- Therefore, use a IntSet directly (which is likely also a bit more efficient).++-- Set of uniques, i.e. for adjancet nodes+newtype UnVarSet = UnVarSet (S.IntSet)+    deriving Eq++k :: Var -> Int+k v = getKey (getUnique v)++emptyUnVarSet :: UnVarSet+emptyUnVarSet = UnVarSet S.empty++elemUnVarSet :: Var -> UnVarSet -> Bool+elemUnVarSet v (UnVarSet s) = k v `S.member` s+++isEmptyUnVarSet :: UnVarSet -> Bool+isEmptyUnVarSet (UnVarSet s) = S.null s++delUnVarSet :: UnVarSet -> Var -> UnVarSet+delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s++mkUnVarSet :: [Var] -> UnVarSet+mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs++varEnvDom :: VarEnv a -> UnVarSet+varEnvDom ae = UnVarSet $ ufmToSet_Directly ae++unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet+unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2)++unionUnVarSets :: [UnVarSet] -> UnVarSet+unionUnVarSets = foldr unionUnVarSet emptyUnVarSet++instance Outputable UnVarSet where+    ppr (UnVarSet s) = braces $+        hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s]+++-- The graph type. A list of complete bipartite graphs+data Gen = CBPG UnVarSet UnVarSet -- complete bipartite+         | CG   UnVarSet          -- complete+newtype UnVarGraph = UnVarGraph (Bag Gen)++emptyUnVarGraph :: UnVarGraph+emptyUnVarGraph = UnVarGraph emptyBag++unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph+{-+Premature optimisation, it seems.+unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])+    | s1 == s3 && s2 == s4+    = pprTrace "unionUnVarGraph fired" empty $+      completeGraph (s1 `unionUnVarSet` s2)+unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])+    | s2 == s3 && s1 == s4+    = pprTrace "unionUnVarGraph fired2" empty $+      completeGraph (s1 `unionUnVarSet` s2)+-}+unionUnVarGraph (UnVarGraph g1) (UnVarGraph g2)+    = -- pprTrace "unionUnVarGraph" (ppr (length g1, length g2)) $+      UnVarGraph (g1 `unionBags` g2)++unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph+unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph++-- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B }+completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph+completeBipartiteGraph s1 s2 = prune $ UnVarGraph $ unitBag $ CBPG s1 s2++completeGraph :: UnVarSet -> UnVarGraph+completeGraph s = prune $ UnVarGraph $ unitBag $ CG s++neighbors :: UnVarGraph -> Var -> UnVarSet+neighbors (UnVarGraph g) v = unionUnVarSets $ concatMap go $ bagToList g+  where go (CG s)       = (if v `elemUnVarSet` s then [s] else [])+        go (CBPG s1 s2) = (if v `elemUnVarSet` s1 then [s2] else []) +++                          (if v `elemUnVarSet` s2 then [s1] else [])++delNode :: UnVarGraph -> Var -> UnVarGraph+delNode (UnVarGraph g) v = prune $ UnVarGraph $ mapBag go g+  where go (CG s)       = CG (s `delUnVarSet` v)+        go (CBPG s1 s2) = CBPG (s1 `delUnVarSet` v) (s2 `delUnVarSet` v)++prune :: UnVarGraph -> UnVarGraph+prune (UnVarGraph g) = UnVarGraph $ filterBag go g+  where go (CG s)       = not (isEmptyUnVarSet s)+        go (CBPG s1 s2) = not (isEmptyUnVarSet s1) && not (isEmptyUnVarSet s2)++instance Outputable Gen where+    ppr (CG s)       = ppr s  <> char '²'+    ppr (CBPG s1 s2) = ppr s1 <+> char 'x' <+> ppr s2+instance Outputable UnVarGraph where+    ppr (UnVarGraph g) = ppr g
+ utils/UniqDFM.hs view
@@ -0,0 +1,398 @@+{-+(c) Bartosz Nitka, Facebook, 2015++UniqDFM: Specialised deterministic finite maps, for things with @Uniques@.++Basically, the things need to be in class @Uniquable@, and we use the+@getUnique@ method to grab their @Uniques@.++This is very similar to @UniqFM@, the major difference being that the order of+folding is not dependent on @Unique@ ordering, giving determinism.+Currently the ordering is determined by insertion order.++See Note [Unique Determinism] in Unique for explanation why @Unique@ ordering+is not deterministic.+-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall #-}++module UniqDFM (+        -- * Unique-keyed deterministic mappings+        UniqDFM,       -- abstract type++        -- ** Manipulating those mappings+        emptyUDFM,+        unitUDFM,+        addToUDFM,+        addToUDFM_C,+        addListToUDFM,+        delFromUDFM,+        delListFromUDFM,+        adjustUDFM,+        alterUDFM,+        mapUDFM,+        plusUDFM,+        plusUDFM_C,+        lookupUDFM, lookupUDFM_Directly,+        elemUDFM,+        foldUDFM,+        eltsUDFM,+        filterUDFM, filterUDFM_Directly,+        isNullUDFM,+        sizeUDFM,+        intersectUDFM, udfmIntersectUFM,+        intersectsUDFM,+        disjointUDFM, disjointUdfmUfm,+        minusUDFM,+        listToUDFM,+        udfmMinusUFM,+        partitionUDFM,+        anyUDFM, allUDFM,+        pprUDFM,++        udfmToList,+        udfmToUfm,+        nonDetFoldUDFM,+        alwaysUnsafeUfmToUdfm,+    ) where++import Unique           ( Uniquable(..), Unique, getKey )+import Outputable++import qualified Data.IntMap as M+import Data.Data+import Data.List (sortBy)+import Data.Function (on)+import UniqFM (UniqFM, listToUFM_Directly, nonDetUFMToList, ufmToIntMap)++-- Note [Deterministic UniqFM]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- A @UniqDFM@ is just like @UniqFM@ with the following additional+-- property: the function `udfmToList` returns the elements in some+-- deterministic order not depending on the Unique key for those elements.+--+-- If the client of the map performs operations on the map in deterministic+-- order then `udfmToList` returns them in deterministic order.+--+-- There is an implementation cost: each element is given a serial number+-- as it is added, and `udfmToList` sorts it's result by this serial+-- number. So you should only use `UniqDFM` if you need the deterministic+-- property.+--+-- `foldUDFM` also preserves determinism.+--+-- Normal @UniqFM@ when you turn it into a list will use+-- Data.IntMap.toList function that returns the elements in the order of+-- the keys. The keys in @UniqFM@ are always @Uniques@, so you end up with+-- with a list ordered by @Uniques@.+-- The order of @Uniques@ is known to be not stable across rebuilds.+-- See Note [Unique Determinism] in Unique.+--+--+-- There's more than one way to implement this. The implementation here tags+-- every value with the insertion time that can later be used to sort the+-- values when asked to convert to a list.+--+-- An alternative would be to have+--+--   data UniqDFM ele = UDFM (M.IntMap ele) [ele]+--+-- where the list determines the order. This makes deletion tricky as we'd+-- only accumulate elements in that list, but makes merging easier as you+-- can just merge both structures independently.+-- Deletion can probably be done in amortized fashion when the size of the+-- list is twice the size of the set.++-- | A type of values tagged with insertion time+data TaggedVal val =+  TaggedVal+    val+    {-# UNPACK #-} !Int -- ^ insertion time+  deriving Data++taggedFst :: TaggedVal val -> val+taggedFst (TaggedVal v _) = v++taggedSnd :: TaggedVal val -> Int+taggedSnd (TaggedVal _ i) = i++instance Eq val => Eq (TaggedVal val) where+  (TaggedVal v1 _) == (TaggedVal v2 _) = v1 == v2++instance Functor TaggedVal where+  fmap f (TaggedVal val i) = TaggedVal (f val) i++-- | Type of unique deterministic finite maps+data UniqDFM ele =+  UDFM+    !(M.IntMap (TaggedVal ele)) -- A map where keys are Unique's values and+                                -- values are tagged with insertion time.+                                -- The invariant is that all the tags will+                                -- be distinct within a single map+    {-# UNPACK #-} !Int         -- Upper bound on the values' insertion+                                -- time. See Note [Overflow on plusUDFM]+  deriving (Data, Functor)++emptyUDFM :: UniqDFM elt+emptyUDFM = UDFM M.empty 0++unitUDFM :: Uniquable key => key -> elt -> UniqDFM elt+unitUDFM k v = UDFM (M.singleton (getKey $ getUnique k) (TaggedVal v 0)) 1++addToUDFM :: Uniquable key => UniqDFM elt -> key -> elt  -> UniqDFM elt+addToUDFM m k v = addToUDFM_Directly m (getUnique k) v++addToUDFM_Directly :: UniqDFM elt -> Unique -> elt -> UniqDFM elt+addToUDFM_Directly (UDFM m i) u v+  = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1)+  where+    tf (TaggedVal new_v _) (TaggedVal _ old_i) = TaggedVal new_v old_i+      -- Keep the old tag, but insert the new value+      -- This means that udfmToList typically returns elements+      -- in the order of insertion, rather than the reverse++addToUDFM_Directly_C+  :: (elt -> elt -> elt)   -- old -> new -> result+  -> UniqDFM elt+  -> Unique -> elt+  -> UniqDFM elt+addToUDFM_Directly_C f (UDFM m i) u v+  = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1)+    where+      tf (TaggedVal new_v _) (TaggedVal old_v old_i)+         = TaggedVal (f old_v new_v) old_i+          -- Flip the arguments, because M.insertWith uses  (new->old->result)+          --                         but f            needs (old->new->result)+          -- Like addToUDFM_Directly, keep the old tag++addToUDFM_C+  :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result+  -> UniqDFM elt -- old+  -> key -> elt -- new+  -> UniqDFM elt -- result+addToUDFM_C f m k v = addToUDFM_Directly_C f m (getUnique k) v++addListToUDFM :: Uniquable key => UniqDFM elt -> [(key,elt)] -> UniqDFM elt+addListToUDFM = foldl (\m (k, v) -> addToUDFM m k v)++addListToUDFM_Directly :: UniqDFM elt -> [(Unique,elt)] -> UniqDFM elt+addListToUDFM_Directly = foldl (\m (k, v) -> addToUDFM_Directly m k v)++addListToUDFM_Directly_C+  :: (elt -> elt -> elt) -> UniqDFM elt -> [(Unique,elt)] -> UniqDFM elt+addListToUDFM_Directly_C f = foldl (\m (k, v) -> addToUDFM_Directly_C f m k v)++delFromUDFM :: Uniquable key => UniqDFM elt -> key -> UniqDFM elt+delFromUDFM (UDFM m i) k = UDFM (M.delete (getKey $ getUnique k) m) i++plusUDFM_C :: (elt -> elt -> elt) -> UniqDFM elt -> UniqDFM elt -> UniqDFM elt+plusUDFM_C f udfml@(UDFM _ i) udfmr@(UDFM _ j)+  -- we will use the upper bound on the tag as a proxy for the set size,+  -- to insert the smaller one into the bigger one+  | i > j = insertUDFMIntoLeft_C f udfml udfmr+  | otherwise = insertUDFMIntoLeft_C f udfmr udfml++-- Note [Overflow on plusUDFM]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- There are multiple ways of implementing plusUDFM.+-- The main problem that needs to be solved is overlap on times of+-- insertion between different keys in two maps.+-- Consider:+--+-- A = fromList [(a, (x, 1))]+-- B = fromList [(b, (y, 1))]+--+-- If you merge them naively you end up with:+--+-- C = fromList [(a, (x, 1)), (b, (y, 1))]+--+-- Which loses information about ordering and brings us back into+-- non-deterministic world.+--+-- The solution I considered before would increment the tags on one of the+-- sets by the upper bound of the other set. The problem with this approach+-- is that you'll run out of tags for some merge patterns.+-- Say you start with A with upper bound 1, you merge A with A to get A' and+-- the upper bound becomes 2. You merge A' with A' and the upper bound+-- doubles again. After 64 merges you overflow.+-- This solution would have the same time complexity as plusUFM, namely O(n+m).+--+-- The solution I ended up with has time complexity of+-- O(m log m + m * min (n+m, W)) where m is the smaller set.+-- It simply inserts the elements of the smaller set into the larger+-- set in the order that they were inserted into the smaller set. That's+-- O(m log m) for extracting the elements from the smaller set in the+-- insertion order and O(m * min(n+m, W)) to insert them into the bigger+-- set.++plusUDFM :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt+plusUDFM udfml@(UDFM _ i) udfmr@(UDFM _ j)+  -- we will use the upper bound on the tag as a proxy for the set size,+  -- to insert the smaller one into the bigger one+  | i > j = insertUDFMIntoLeft udfml udfmr+  | otherwise = insertUDFMIntoLeft udfmr udfml++insertUDFMIntoLeft :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt+insertUDFMIntoLeft udfml udfmr = addListToUDFM_Directly udfml $ udfmToList udfmr++insertUDFMIntoLeft_C+  :: (elt -> elt -> elt) -> UniqDFM elt -> UniqDFM elt -> UniqDFM elt+insertUDFMIntoLeft_C f udfml udfmr =+  addListToUDFM_Directly_C f udfml $ udfmToList udfmr++lookupUDFM :: Uniquable key => UniqDFM elt -> key -> Maybe elt+lookupUDFM (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey $ getUnique k) m++lookupUDFM_Directly :: UniqDFM elt -> Unique -> Maybe elt+lookupUDFM_Directly (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey k) m++elemUDFM :: Uniquable key => key -> UniqDFM elt -> Bool+elemUDFM k (UDFM m _i) = M.member (getKey $ getUnique k) m++-- | Performs a deterministic fold over the UniqDFM.+-- It's O(n log n) while the corresponding function on `UniqFM` is O(n).+foldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a+foldUDFM k z m = foldr k z (eltsUDFM m)++-- | Performs a nondeterministic fold over the UniqDFM.+-- It's O(n), same as the corresponding function on `UniqFM`.+-- If you use this please provide a justification why it doesn't introduce+-- nondeterminism.+nonDetFoldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a+nonDetFoldUDFM k z (UDFM m _i) = foldr k z $ map taggedFst $ M.elems m++eltsUDFM :: UniqDFM elt -> [elt]+eltsUDFM (UDFM m _i) =+  map taggedFst $ sortBy (compare `on` taggedSnd) $ M.elems m++filterUDFM :: (elt -> Bool) -> UniqDFM elt -> UniqDFM elt+filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i++filterUDFM_Directly :: (Unique -> elt -> Bool) -> UniqDFM elt -> UniqDFM elt+filterUDFM_Directly p (UDFM m i) = UDFM (M.filterWithKey p' m) i+  where+  p' k (TaggedVal v _) = p (getUnique k) v++-- | Converts `UniqDFM` to a list, with elements in deterministic order.+-- It's O(n log n) while the corresponding function on `UniqFM` is O(n).+udfmToList :: UniqDFM elt -> [(Unique, elt)]+udfmToList (UDFM m _i) =+  [ (getUnique k, taggedFst v)+  | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ]++isNullUDFM :: UniqDFM elt -> Bool+isNullUDFM (UDFM m _) = M.null m++sizeUDFM :: UniqDFM elt -> Int+sizeUDFM (UDFM m _i) = M.size m++intersectUDFM :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt+intersectUDFM (UDFM x i) (UDFM y _j) = UDFM (M.intersection x y) i+  -- M.intersection is left biased, that means the result will only have+  -- a subset of elements from the left set, so `i` is a good upper bound.++udfmIntersectUFM :: UniqDFM elt -> UniqFM elt -> UniqDFM elt+udfmIntersectUFM (UDFM x i) y = UDFM (M.intersection x (ufmToIntMap y)) i+  -- M.intersection is left biased, that means the result will only have+  -- a subset of elements from the left set, so `i` is a good upper bound.++intersectsUDFM :: UniqDFM elt -> UniqDFM elt -> Bool+intersectsUDFM x y = isNullUDFM (x `intersectUDFM` y)++disjointUDFM :: UniqDFM elt -> UniqDFM elt -> Bool+disjointUDFM (UDFM x _i) (UDFM y _j) = M.null (M.intersection x y)++disjointUdfmUfm :: UniqDFM elt -> UniqFM elt2 -> Bool+disjointUdfmUfm (UDFM x _i) y = M.null (M.intersection x (ufmToIntMap y))++minusUDFM :: UniqDFM elt1 -> UniqDFM elt2 -> UniqDFM elt1+minusUDFM (UDFM x i) (UDFM y _j) = UDFM (M.difference x y) i+  -- M.difference returns a subset of a left set, so `i` is a good upper+  -- bound.++udfmMinusUFM :: UniqDFM elt1 -> UniqFM elt2 -> UniqDFM elt1+udfmMinusUFM (UDFM x i) y = UDFM (M.difference x (ufmToIntMap y)) i+  -- M.difference returns a subset of a left set, so `i` is a good upper+  -- bound.++-- | Partition UniqDFM into two UniqDFMs according to the predicate+partitionUDFM :: (elt -> Bool) -> UniqDFM elt -> (UniqDFM elt, UniqDFM elt)+partitionUDFM p (UDFM m i) =+  case M.partition (p . taggedFst) m of+    (left, right) -> (UDFM left i, UDFM right i)++-- | Delete a list of elements from a UniqDFM+delListFromUDFM  :: Uniquable key => UniqDFM elt -> [key] -> UniqDFM elt+delListFromUDFM = foldl delFromUDFM++-- | This allows for lossy conversion from UniqDFM to UniqFM+udfmToUfm :: UniqDFM elt -> UniqFM elt+udfmToUfm (UDFM m _i) =+  listToUFM_Directly [(getUnique k, taggedFst tv) | (k, tv) <- M.toList m]++listToUDFM :: Uniquable key => [(key,elt)] -> UniqDFM elt+listToUDFM = foldl (\m (k, v) -> addToUDFM m k v) emptyUDFM++listToUDFM_Directly :: [(Unique, elt)] -> UniqDFM elt+listToUDFM_Directly = foldl (\m (u, v) -> addToUDFM_Directly m u v) emptyUDFM++-- | Apply a function to a particular element+adjustUDFM :: Uniquable key => (elt -> elt) -> UniqDFM elt -> key -> UniqDFM elt+adjustUDFM f (UDFM m i) k = UDFM (M.adjust (fmap f) (getKey $ getUnique k) m) i++-- | The expression (alterUDFM f k map) alters value x at k, or absence+-- thereof. alterUDFM can be used to insert, delete, or update a value in+-- UniqDFM. Use addToUDFM, delFromUDFM or adjustUDFM when possible, they are+-- more efficient.+alterUDFM+  :: Uniquable key+  => (Maybe elt -> Maybe elt)  -- How to adjust+  -> UniqDFM elt               -- old+  -> key                       -- new+  -> UniqDFM elt               -- result+alterUDFM f (UDFM m i) k =+  UDFM (M.alter alterf (getKey $ getUnique k) m) (i + 1)+  where+  alterf Nothing = inject $ f Nothing+  alterf (Just (TaggedVal v _)) = inject $ f (Just v)+  inject Nothing = Nothing+  inject (Just v) = Just $ TaggedVal v i++-- | Map a function over every value in a UniqDFM+mapUDFM :: (elt1 -> elt2) -> UniqDFM elt1 -> UniqDFM elt2+mapUDFM f (UDFM m i) = UDFM (M.map (fmap f) m) i++anyUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool+anyUDFM p (UDFM m _i) = M.foldr ((||) . p . taggedFst) False m++allUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool+allUDFM p (UDFM m _i) = M.foldr ((&&) . p . taggedFst) True m++instance Monoid (UniqDFM a) where+  mempty = emptyUDFM+  mappend = plusUDFM++-- This should not be used in commited code, provided for convenience to+-- make ad-hoc conversions when developing+alwaysUnsafeUfmToUdfm :: UniqFM elt -> UniqDFM elt+alwaysUnsafeUfmToUdfm = listToUDFM_Directly . nonDetUFMToList++-- Output-ery++instance Outputable a => Outputable (UniqDFM a) where+    ppr ufm = pprUniqDFM ppr ufm++pprUniqDFM :: (a -> SDoc) -> UniqDFM a -> SDoc+pprUniqDFM ppr_elt ufm+  = brackets $ fsep $ punctuate comma $+    [ ppr uq <+> text ":->" <+> ppr_elt elt+    | (uq, elt) <- udfmToList ufm ]++pprUDFM :: UniqDFM a    -- ^ The things to be pretty printed+       -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements+       -> SDoc          -- ^ 'SDoc' where the things have been pretty+                        -- printed+pprUDFM ufm pp = pp (eltsUDFM ufm)
+ utils/UniqDSet.hs view
@@ -0,0 +1,103 @@+-- (c) Bartosz Nitka, Facebook, 2015++-- |+-- Specialised deterministic sets, for things with @Uniques@+--+-- Based on @UniqDFMs@ (as you would expect).+-- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need it.+--+-- Basically, the things need to be in class @Uniquable@.++module UniqDSet (+        -- * Unique set type+        UniqDSet,    -- type synonym for UniqFM a++        -- ** Manipulating these sets+        delOneFromUniqDSet, delListFromUniqDSet,+        emptyUniqDSet,+        unitUniqDSet,+        mkUniqDSet,+        addOneToUniqDSet, addListToUniqDSet,+        unionUniqDSets, unionManyUniqDSets,+        minusUniqDSet, uniqDSetMinusUniqSet,+        intersectUniqDSets,+        intersectsUniqDSets,+        foldUniqDSet,+        elementOfUniqDSet,+        filterUniqDSet,+        sizeUniqDSet,+        isEmptyUniqDSet,+        lookupUniqDSet,+        uniqDSetToList,+        partitionUniqDSet+    ) where++import UniqDFM+import UniqSet+import Unique++type UniqDSet a = UniqDFM a++emptyUniqDSet :: UniqDSet a+emptyUniqDSet = emptyUDFM++unitUniqDSet :: Uniquable a => a -> UniqDSet a+unitUniqDSet x = unitUDFM x x++mkUniqDSet :: Uniquable a => [a]  -> UniqDSet a+mkUniqDSet = foldl addOneToUniqDSet emptyUniqDSet++addOneToUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a+addOneToUniqDSet set x = addToUDFM set x x++addListToUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a+addListToUniqDSet = foldl addOneToUniqDSet++delOneFromUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a+delOneFromUniqDSet = delFromUDFM++delListFromUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a+delListFromUniqDSet = delListFromUDFM++unionUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a+unionUniqDSets = plusUDFM++unionManyUniqDSets :: [UniqDSet a] -> UniqDSet a+unionManyUniqDSets [] = emptyUniqDSet+unionManyUniqDSets sets = foldr1 unionUniqDSets sets++minusUniqDSet :: UniqDSet a -> UniqDSet a -> UniqDSet a+minusUniqDSet = minusUDFM++uniqDSetMinusUniqSet :: UniqDSet a -> UniqSet a -> UniqDSet a+uniqDSetMinusUniqSet xs ys = udfmMinusUFM xs (getUniqSet ys)++intersectUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a+intersectUniqDSets = intersectUDFM++intersectsUniqDSets :: UniqDSet a -> UniqDSet a -> Bool+intersectsUniqDSets = intersectsUDFM++foldUniqDSet :: (a -> b -> b) -> b -> UniqDSet a -> b+foldUniqDSet = foldUDFM++elementOfUniqDSet :: Uniquable a => a -> UniqDSet a -> Bool+elementOfUniqDSet = elemUDFM++filterUniqDSet :: (a -> Bool) -> UniqDSet a -> UniqDSet a+filterUniqDSet = filterUDFM++sizeUniqDSet :: UniqDSet a -> Int+sizeUniqDSet = sizeUDFM++isEmptyUniqDSet :: UniqDSet a -> Bool+isEmptyUniqDSet = isNullUDFM++lookupUniqDSet :: Uniquable a => UniqDSet a -> a -> Maybe a+lookupUniqDSet = lookupUDFM++uniqDSetToList :: UniqDSet a -> [a]+uniqDSetToList = eltsUDFM++partitionUniqDSet :: (a -> Bool) -> UniqDSet a -> (UniqDSet a, UniqDSet a)+partitionUniqDSet = partitionUDFM
+ utils/UniqFM.hs view
@@ -0,0 +1,411 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1994-1998+++UniqFM: Specialised finite maps, for things with @Uniques@.++Basically, the things need to be in class @Uniquable@, and we use the+@getUnique@ method to grab their @Uniques@.++(A similar thing to @UniqSet@, as opposed to @Set@.)++The interface is based on @FiniteMap@s, but the implementation uses+@Data.IntMap@, which is both maintained and faster than the past+implementation (see commit log).++The @UniqFM@ interface maps directly to Data.IntMap, only+``Data.IntMap.union'' is left-biased and ``plusUFM'' right-biased+and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order+of arguments of combining function.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -Wall #-}++module UniqFM (+        -- * Unique-keyed mappings+        UniqFM,       -- abstract type++        -- ** Manipulating those mappings+        emptyUFM,+        unitUFM,+        unitDirectlyUFM,+        listToUFM,+        listToUFM_Directly,+        listToUFM_C,+        addToUFM,addToUFM_C,addToUFM_Acc,+        addListToUFM,addListToUFM_C,+        addToUFM_Directly,+        addListToUFM_Directly,+        adjustUFM, alterUFM,+        adjustUFM_Directly,+        delFromUFM,+        delFromUFM_Directly,+        delListFromUFM,+        delListFromUFM_Directly,+        plusUFM,+        plusUFM_C,+        plusUFM_CD,+        plusMaybeUFM_C,+        plusUFMList,+        minusUFM,+        intersectUFM,+        intersectUFM_C,+        disjointUFM,+        equalKeysUFM,+        nonDetFoldUFM, foldUFM, nonDetFoldUFM_Directly,+        anyUFM, allUFM, seqEltsUFM,+        mapUFM, mapUFM_Directly,+        elemUFM, elemUFM_Directly,+        filterUFM, filterUFM_Directly, partitionUFM,+        sizeUFM,+        isNullUFM,+        lookupUFM, lookupUFM_Directly,+        lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,+        nonDetEltsUFM, eltsUFM, nonDetKeysUFM,+        ufmToSet_Directly,+        nonDetUFMToList, ufmToIntMap,+        pprUniqFM, pprUFM, pprUFMWithKeys, pluralUFM+    ) where++import Unique           ( Uniquable(..), Unique, getKey )+import Outputable++import Data.List (foldl')++import qualified Data.IntMap as M+#if MIN_VERSION_containers(0,5,9)+import qualified Data.IntMap.Merge.Lazy as M+import Control.Applicative (Const (..))+import qualified Data.Monoid as Mon+#endif+import qualified Data.IntSet as S+import Data.Typeable+import Data.Data+#if __GLASGOW_HASKELL__ > 710+import Data.Semigroup   ( Semigroup )+import qualified Data.Semigroup as Semigroup+#endif+++newtype UniqFM ele = UFM (M.IntMap ele)+  deriving (Data, Eq, Functor, Typeable)+  -- We used to derive Traversable and Foldable, but they were nondeterministic+  -- and not obvious at the call site. You can use explicit nonDetEltsUFM+  -- and fold a list if needed.+  -- See Note [Deterministic UniqFM] in UniqDFM to learn about determinism.++emptyUFM :: UniqFM elt+emptyUFM = UFM M.empty++isNullUFM :: UniqFM elt -> Bool+isNullUFM (UFM m) = M.null m++unitUFM :: Uniquable key => key -> elt -> UniqFM elt+unitUFM k v = UFM (M.singleton (getKey $ getUnique k) v)++-- when you've got the Unique already+unitDirectlyUFM :: Unique -> elt -> UniqFM elt+unitDirectlyUFM u v = UFM (M.singleton (getKey u) v)++listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt+listToUFM = foldl (\m (k, v) -> addToUFM m k v) emptyUFM++listToUFM_Directly :: [(Unique, elt)] -> UniqFM elt+listToUFM_Directly = foldl (\m (u, v) -> addToUFM_Directly m u v) emptyUFM++listToUFM_C+  :: Uniquable key+  => (elt -> elt -> elt)+  -> [(key, elt)]+  -> UniqFM elt+listToUFM_C f = foldl (\m (k, v) -> addToUFM_C f m k v) emptyUFM++addToUFM :: Uniquable key => UniqFM elt -> key -> elt  -> UniqFM elt+addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m)++addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt+addListToUFM = foldl (\m (k, v) -> addToUFM m k v)++addListToUFM_Directly :: UniqFM elt -> [(Unique,elt)] -> UniqFM elt+addListToUFM_Directly = foldl (\m (k, v) -> addToUFM_Directly m k v)++addToUFM_Directly :: UniqFM elt -> Unique -> elt -> UniqFM elt+addToUFM_Directly (UFM m) u v = UFM (M.insert (getKey u) v m)++addToUFM_C+  :: Uniquable key+  => (elt -> elt -> elt)  -- old -> new -> result+  -> UniqFM elt           -- old+  -> key -> elt           -- new+  -> UniqFM elt           -- result+-- Arguments of combining function of M.insertWith and addToUFM_C are flipped.+addToUFM_C f (UFM m) k v =+  UFM (M.insertWith (flip f) (getKey $ getUnique k) v m)++addToUFM_Acc+  :: Uniquable key+  => (elt -> elts -> elts)  -- Add to existing+  -> (elt -> elts)          -- New element+  -> UniqFM elts            -- old+  -> key -> elt             -- new+  -> UniqFM elts            -- result+addToUFM_Acc exi new (UFM m) k v =+  UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m)++alterUFM+  :: Uniquable key+  => (Maybe elt -> Maybe elt)  -- How to adjust+  -> UniqFM elt                -- old+  -> key                       -- new+  -> UniqFM elt                -- result+alterUFM f (UFM m) k = UFM (M.alter f (getKey $ getUnique k) m)++addListToUFM_C+  :: Uniquable key+  => (elt -> elt -> elt)+  -> UniqFM elt -> [(key,elt)]+  -> UniqFM elt+addListToUFM_C f = foldl (\m (k, v) -> addToUFM_C f m k v)++adjustUFM :: Uniquable key => (elt -> elt) -> UniqFM elt -> key -> UniqFM elt+adjustUFM f (UFM m) k = UFM (M.adjust f (getKey $ getUnique k) m)++adjustUFM_Directly :: (elt -> elt) -> UniqFM elt -> Unique -> UniqFM elt+adjustUFM_Directly f (UFM m) u = UFM (M.adjust f (getKey u) m)++delFromUFM :: Uniquable key => UniqFM elt -> key    -> UniqFM elt+delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m)++delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt+delListFromUFM = foldl delFromUFM++delListFromUFM_Directly :: UniqFM elt -> [Unique] -> UniqFM elt+delListFromUFM_Directly = foldl delFromUFM_Directly++delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt+delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m)++-- Bindings in right argument shadow those in the left+plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt+-- M.union is left-biased, plusUFM should be right-biased.+plusUFM (UFM x) (UFM y) = UFM (M.union y x)+     -- Note (M.union y x), with arguments flipped+     -- M.union is left-biased, plusUFM should be right-biased.++plusUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> UniqFM elt -> UniqFM elt+plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y)++-- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the+-- combinding function and `d1` resp. `d2` as the default value if+-- there is no entry in `m1` reps. `m2`. The domain is the union of+-- the domains of `m1` and `m2`.+--+-- Representative example:+--+-- @+-- plusUFM_CD f {A: 1, B: 2} 23 {B: 3, C: 4} 42+--    == {A: f 1 42, B: f 2 3, C: f 23 4 }+-- @+plusUFM_CD+  :: (elt -> elt -> elt)+  -> UniqFM elt  -- map X+  -> elt         -- default for X+  -> UniqFM elt  -- map Y+  -> elt         -- default for Y+  -> UniqFM elt+plusUFM_CD f (UFM xm) dx (UFM ym) dy+  = UFM $ M.mergeWithKey+      (\_ x y -> Just (x `f` y))+      (M.map (\x -> x `f` dy))+      (M.map (\y -> dx `f` y))+      xm ym++plusMaybeUFM_C :: (elt -> elt -> Maybe elt)+               -> UniqFM elt -> UniqFM elt -> UniqFM elt+plusMaybeUFM_C f (UFM xm) (UFM ym)+    = UFM $ M.mergeWithKey+        (\_ x y -> x `f` y)+        id+        id+        xm ym++plusUFMList :: [UniqFM elt] -> UniqFM elt+plusUFMList = foldl' plusUFM emptyUFM++minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1+minusUFM (UFM x) (UFM y) = UFM (M.difference x y)++intersectUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1+intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y)++intersectUFM_C+  :: (elt1 -> elt2 -> elt3)+  -> UniqFM elt1+  -> UniqFM elt2+  -> UniqFM elt3+intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y)++disjointUFM :: UniqFM elt1 -> UniqFM elt2 -> Bool+disjointUFM (UFM x) (UFM y) = M.null (M.intersection x y)++foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a+foldUFM k z (UFM m) = M.foldr k z m++mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2+mapUFM f (UFM m) = UFM (M.map f m)++mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2+mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m)++filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt+filterUFM p (UFM m) = UFM (M.filter p m)++filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt+filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . getUnique) m)++partitionUFM :: (elt -> Bool) -> UniqFM elt -> (UniqFM elt, UniqFM elt)+partitionUFM p (UFM m) =+  case M.partition p m of+    (left, right) -> (UFM left, UFM right)++sizeUFM :: UniqFM elt -> Int+sizeUFM (UFM m) = M.size m++elemUFM :: Uniquable key => key -> UniqFM elt -> Bool+elemUFM k (UFM m) = M.member (getKey $ getUnique k) m++elemUFM_Directly :: Unique -> UniqFM elt -> Bool+elemUFM_Directly u (UFM m) = M.member (getKey u) m++lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt+lookupUFM (UFM m) k = M.lookup (getKey $ getUnique k) m++-- when you've got the Unique already+lookupUFM_Directly :: UniqFM elt -> Unique -> Maybe elt+lookupUFM_Directly (UFM m) u = M.lookup (getKey u) m++lookupWithDefaultUFM :: Uniquable key => UniqFM elt -> elt -> key -> elt+lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m++lookupWithDefaultUFM_Directly :: UniqFM elt -> elt -> Unique -> elt+lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m++eltsUFM :: UniqFM elt -> [elt]+eltsUFM (UFM m) = M.elems m++ufmToSet_Directly :: UniqFM elt -> S.IntSet+ufmToSet_Directly (UFM m) = M.keysSet m++anyUFM :: (elt -> Bool) -> UniqFM elt -> Bool+anyUFM p (UFM m) = M.foldr ((||) . p) False m++allUFM :: (elt -> Bool) -> UniqFM elt -> Bool+allUFM p (UFM m) = M.foldr ((&&) . p) True m++seqEltsUFM :: ([elt] -> ()) -> UniqFM elt -> ()+seqEltsUFM seqList = seqList . nonDetEltsUFM+  -- It's OK to use nonDetEltsUFM here because the type guarantees that+  -- the only interesting thing this function can do is to force the+  -- elements.++-- See Note [Deterministic UniqFM] to learn about nondeterminism.+-- If you use this please provide a justification why it doesn't introduce+-- nondeterminism.+nonDetEltsUFM :: UniqFM elt -> [elt]+nonDetEltsUFM (UFM m) = M.elems m++-- See Note [Deterministic UniqFM] to learn about nondeterminism.+-- If you use this please provide a justification why it doesn't introduce+-- nondeterminism.+nonDetKeysUFM :: UniqFM elt -> [Unique]+nonDetKeysUFM (UFM m) = map getUnique $ M.keys m++-- See Note [Deterministic UniqFM] to learn about nondeterminism.+-- If you use this please provide a justification why it doesn't introduce+-- nondeterminism.+nonDetFoldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a+nonDetFoldUFM k z (UFM m) = M.foldr k z m++-- See Note [Deterministic UniqFM] to learn about nondeterminism.+-- If you use this please provide a justification why it doesn't introduce+-- nondeterminism.+nonDetFoldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a+nonDetFoldUFM_Directly k z (UFM m) = M.foldrWithKey (k . getUnique) z m++-- See Note [Deterministic UniqFM] to learn about nondeterminism.+-- If you use this please provide a justification why it doesn't introduce+-- nondeterminism.+nonDetUFMToList :: UniqFM elt -> [(Unique, elt)]+nonDetUFMToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m++ufmToIntMap :: UniqFM elt -> M.IntMap elt+ufmToIntMap (UFM m) = m++-- Determines whether two 'UniqFm's contain the same keys.+equalKeysUFM :: UniqFM a -> UniqFM b -> Bool+#if MIN_VERSION_containers(0,5,9)+equalKeysUFM (UFM m1) (UFM m2) = Mon.getAll $ getConst $+      M.mergeA (M.traverseMissing (\_ _ -> Const (Mon.All False)))+               (M.traverseMissing (\_ _ -> Const (Mon.All False)))+               (M.zipWithAMatched (\_ _ _ -> Const (Mon.All True))) m1 m2+#else+equalKeysUFM (UFM m1) (UFM m2) = M.keys m1 == M.keys m2+#endif++-- Instances++#if __GLASGOW_HASKELL__ > 710+instance Semigroup (UniqFM a) where+  (<>) = plusUFM+#endif++instance Monoid (UniqFM a) where+    mempty = emptyUFM+    mappend = plusUFM++-- Output-ery++instance Outputable a => Outputable (UniqFM a) where+    ppr ufm = pprUniqFM ppr ufm++pprUniqFM :: (a -> SDoc) -> UniqFM a -> SDoc+pprUniqFM ppr_elt ufm+  = brackets $ fsep $ punctuate comma $+    [ ppr uq <+> text ":->" <+> ppr_elt elt+    | (uq, elt) <- nonDetUFMToList ufm ]+  -- It's OK to use nonDetUFMToList here because we only use it for+  -- pretty-printing.++-- | Pretty-print a non-deterministic set.+-- The order of variables is non-deterministic and for pretty-printing that+-- shouldn't be a problem.+-- Having this function helps contain the non-determinism created with+-- nonDetEltsUFM.+pprUFM :: UniqFM a      -- ^ The things to be pretty printed+       -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements+       -> SDoc          -- ^ 'SDoc' where the things have been pretty+                        -- printed+pprUFM ufm pp = pp (nonDetEltsUFM ufm)++-- | Pretty-print a non-deterministic set.+-- The order of variables is non-deterministic and for pretty-printing that+-- shouldn't be a problem.+-- Having this function helps contain the non-determinism created with+-- nonDetUFMToList.+pprUFMWithKeys+       :: UniqFM a                -- ^ The things to be pretty printed+       -> ([(Unique, a)] -> SDoc) -- ^ The pretty printing function to use on the elements+       -> SDoc                    -- ^ 'SDoc' where the things have been pretty+                                  -- printed+pprUFMWithKeys ufm pp = pp (nonDetUFMToList ufm)++-- | Determines the pluralisation suffix appropriate for the length of a set+-- in the same way that plural from Outputable does for lists.+pluralUFM :: UniqFM a -> SDoc+pluralUFM ufm+  | sizeUFM ufm == 1 = empty+  | otherwise = char 's'
+ utils/UniqSet.hs view
@@ -0,0 +1,206 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1994-1998++\section[UniqSet]{Specialised sets, for things with @Uniques@}++Based on @UniqFMs@ (as you would expect).++Basically, the things need to be in class @Uniquable@.+-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}++module UniqSet (+        -- * Unique set type+        UniqSet,    -- type synonym for UniqFM a+        getUniqSet,+        pprUniqSet,++        -- ** Manipulating these sets+        emptyUniqSet,+        unitUniqSet,+        mkUniqSet,+        addOneToUniqSet, addListToUniqSet,+        delOneFromUniqSet, delOneFromUniqSet_Directly, delListFromUniqSet,+        delListFromUniqSet_Directly,+        unionUniqSets, unionManyUniqSets,+        minusUniqSet, uniqSetMinusUFM,+        intersectUniqSets,+        restrictUniqSetToUFM,+        uniqSetAny, uniqSetAll,+        elementOfUniqSet,+        elemUniqSet_Directly,+        filterUniqSet,+        filterUniqSet_Directly,+        sizeUniqSet,+        isEmptyUniqSet,+        lookupUniqSet,+        lookupUniqSet_Directly,+        partitionUniqSet,+        mapUniqSet,+        unsafeUFMToUniqSet,+        nonDetEltsUniqSet,+        nonDetKeysUniqSet,+        nonDetFoldUniqSet,+        nonDetFoldUniqSet_Directly+    ) where++import UniqFM+import Unique+import Data.Coerce+import Outputable+import Data.Foldable (foldl')+import Data.Data+#if __GLASGOW_HASKELL__ >= 801+import qualified Data.Semigroup+#endif++{-+************************************************************************+*                                                                      *+\subsection{The signature of the module}+*                                                                      *+************************************************************************+-}++emptyUniqSet :: UniqSet a+unitUniqSet :: Uniquable a => a -> UniqSet a+mkUniqSet :: Uniquable a => [a]  -> UniqSet a++addOneToUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a+addListToUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a++delOneFromUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a+delOneFromUniqSet_Directly :: UniqSet a -> Unique -> UniqSet a+delListFromUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a+delListFromUniqSet_Directly :: UniqSet a -> [Unique] -> UniqSet a++unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a+unionManyUniqSets :: [UniqSet a] -> UniqSet a+minusUniqSet  :: UniqSet a -> UniqSet a -> UniqSet a+intersectUniqSets :: UniqSet a -> UniqSet a -> UniqSet a+restrictUniqSetToUFM :: UniqSet a -> UniqFM b -> UniqSet a+uniqSetMinusUFM :: UniqSet a -> UniqFM b -> UniqSet a++elementOfUniqSet :: Uniquable a => a -> UniqSet a -> Bool+elemUniqSet_Directly :: Unique -> UniqSet a -> Bool+filterUniqSet :: (a -> Bool) -> UniqSet a -> UniqSet a+filterUniqSet_Directly :: (Unique -> elt -> Bool) -> UniqSet elt -> UniqSet elt+partitionUniqSet :: (a -> Bool) -> UniqSet a -> (UniqSet a, UniqSet a)++sizeUniqSet :: UniqSet a -> Int+isEmptyUniqSet :: UniqSet a -> Bool+lookupUniqSet :: Uniquable a => UniqSet b -> a -> Maybe b+lookupUniqSet_Directly :: UniqSet a -> Unique -> Maybe a++nonDetEltsUniqSet :: UniqSet elt -> [elt]+nonDetKeysUniqSet :: UniqSet elt -> [Unique]++-- See Note [Deterministic UniqFM] to learn about nondeterminism.+-- If you use this please provide a justification why it doesn't introduce+-- nondeterminism.+nonDetFoldUniqSet :: (elt -> a -> a) -> a -> UniqSet elt -> a++-- See Note [Deterministic UniqFM] to learn about nondeterminism.+-- If you use this please provide a justification why it doesn't introduce+-- nondeterminism.+nonDetFoldUniqSet_Directly:: (Unique -> elt -> a -> a) -> a -> UniqSet elt -> a++mapUniqSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b++{-+************************************************************************+*                                                                      *+\subsection{Implementation using ``UniqFM''}+*                                                                      *+************************************************************************+-}++-- Note [Unsound mapUniqSet]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~+-- UniqSet has the following invariant:+--   The keys in the map are the uniques of the values+-- It means that to implement mapUniqSet you'd have to update+-- both the keys and the values. There used to be an implementation+-- that only updated the values and it's been removed, because it broke+-- the invariant.++newtype UniqSet a = UniqSet {getUniqSet' :: UniqFM a} deriving Data++-- Two 'UniqSet's are considered equal if they contain the same+-- uniques.+instance Eq (UniqSet a) where+  UniqSet a == UniqSet b = equalKeysUFM a b++getUniqSet :: UniqSet a -> UniqFM a+getUniqSet = getUniqSet'++-- | 'unsafeUFMToUniqSet' converts a @'UniqFM' a@ into a @'UniqSet' a@+-- assuming, without checking, that it maps each 'Unique' to a value+-- that has that 'Unique'. See Note [Unsound mapUniqSet].+unsafeUFMToUniqSet :: UniqFM a -> UniqSet a+unsafeUFMToUniqSet = UniqSet++instance Outputable a => Outputable (UniqSet a) where+    ppr = pprUniqSet ppr+#if __GLASGOW_HASKELL__ >= 801+instance Data.Semigroup.Semigroup (UniqSet a) where+  (<>) = mappend+#endif+instance Monoid (UniqSet a) where+  mempty = UniqSet mempty+  UniqSet s `mappend` UniqSet t = UniqSet (s `mappend` t)++pprUniqSet :: (a -> SDoc) -> UniqSet a -> SDoc+pprUniqSet f (UniqSet s) = pprUniqFM f s++emptyUniqSet = UniqSet emptyUFM+unitUniqSet x = UniqSet $ unitUFM x x+mkUniqSet = foldl' addOneToUniqSet emptyUniqSet++addOneToUniqSet (UniqSet set) x = UniqSet (addToUFM set x x)+addListToUniqSet = foldl' addOneToUniqSet++delOneFromUniqSet (UniqSet s) a = UniqSet (delFromUFM s a)+delOneFromUniqSet_Directly (UniqSet s) u = UniqSet (delFromUFM_Directly s u)+delListFromUniqSet (UniqSet s) l = UniqSet (delListFromUFM s l)+delListFromUniqSet_Directly (UniqSet s) l =+    UniqSet (delListFromUFM_Directly s l)++unionUniqSets (UniqSet s) (UniqSet t) = UniqSet (plusUFM s t)++unionManyUniqSets = foldl' (flip unionUniqSets) emptyUniqSet++minusUniqSet (UniqSet s) (UniqSet t) = UniqSet (minusUFM s t)+uniqSetMinusUFM (UniqSet s) t = UniqSet (minusUFM s t)+++intersectUniqSets (UniqSet s) (UniqSet t) = UniqSet (intersectUFM s t)+restrictUniqSetToUFM (UniqSet s) m = UniqSet (intersectUFM s m)++elementOfUniqSet a (UniqSet s) = elemUFM a s+elemUniqSet_Directly a (UniqSet s) = elemUFM_Directly a s+filterUniqSet p (UniqSet s) = UniqSet (filterUFM p s)+filterUniqSet_Directly f (UniqSet s) = UniqSet (filterUFM_Directly f s)++partitionUniqSet p (UniqSet s) = coerce (partitionUFM p s)++sizeUniqSet (UniqSet s) = sizeUFM s+isEmptyUniqSet (UniqSet s) = isNullUFM s+lookupUniqSet (UniqSet s) k = lookupUFM s k+lookupUniqSet_Directly (UniqSet s) k = lookupUFM_Directly s k++uniqSetAny :: (a -> Bool) -> UniqSet a -> Bool+uniqSetAny p (UniqSet s) = anyUFM p s++uniqSetAll :: (a -> Bool) -> UniqSet a -> Bool+uniqSetAll p (UniqSet s) = allUFM p s++nonDetFoldUniqSet c n (UniqSet s) = nonDetFoldUFM c n s+nonDetFoldUniqSet_Directly f n (UniqSet s) = nonDetFoldUFM_Directly f n s+nonDetEltsUniqSet = nonDetEltsUFM . getUniqSet'+nonDetKeysUniqSet = nonDetKeysUFM . getUniqSet'++mapUniqSet f = mkUniqSet . map f . nonDetEltsUniqSet
+ utils/Util.hs view
@@ -0,0 +1,1371 @@+-- (c) The University of Glasgow 2006++{-# LANGUAGE CPP #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE BangPatterns #-}+#if __GLASGOW_HASKELL__ < 800+-- For CallStack business+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE FlexibleContexts #-}+#endif++-- | Highly random utility functions+--+module Util (+        -- * Flags dependent on the compiler build+        ghciSupported, debugIsOn, ncgDebugIsOn,+        ghciTablesNextToCode,+        isWindowsHost, isDarwinHost,++        -- * General list processing+        zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,+        zipLazy, stretchZipWith, zipWithAndUnzip,++        zipWithLazy, zipWith3Lazy,++        filterByList, filterByLists, partitionByList,++        unzipWith,++        mapFst, mapSnd, chkAppend,+        mapAndUnzip, mapAndUnzip3, mapAccumL2,+        nOfThem, filterOut, partitionWith, splitEithers,++        dropWhileEndLE, spanEnd,++        foldl1', foldl2, count, all2,++        lengthExceeds, lengthIs, lengthAtLeast,+        listLengthCmp, atLength,+        equalLength, compareLength, leLength,++        isSingleton, only, singleton,+        notNull, snocView,++        isIn, isn'tIn,++        chunkList,++        changeLast,++        -- * Tuples+        fstOf3, sndOf3, thdOf3,+        firstM, first3M,+        fst3, snd3, third3,+        uncurry3,+        liftFst, liftSnd,++        -- * List operations controlled by another list+        takeList, dropList, splitAtList, split,+        dropTail, capitalise,++        -- * For loop+        nTimes,++        -- * Sorting+        sortWith, minWith, nubSort,++        -- * Comparisons+        isEqual, eqListBy, eqMaybeBy,+        thenCmp, cmpList,+        removeSpaces,+        (<&&>), (<||>),++        -- * Edit distance+        fuzzyMatch, fuzzyLookup,++        -- * Transitive closures+        transitiveClosure,++        -- * Strictness+        seqList,++        -- * Module names+        looksLikeModuleName,+        looksLikePackageName,++        -- * Argument processing+        getCmd, toCmdArgs, toArgs,++        -- * Integers+        exactLog2,++        -- * Floating point+        readRational,++        -- * read helpers+        maybeRead, maybeReadFuzzy,++        -- * IO-ish utilities+        doesDirNameExist,+        getModificationUTCTime,+        modificationTimeIfExists,+        hSetTranslit,++        global, consIORef, globalM,+        sharedGlobal, sharedGlobalM,++        -- * Filenames and paths+        Suffix,+        splitLongestPrefix,+        escapeSpaces,+        Direction(..), reslash,+        makeRelativeTo,++        -- * Utils for defining Data instances+        abstractConstr, abstractDataType, mkNoRepType,++        -- * Utils for printing C code+        charToC,++        -- * Hashing+        hashString,++        -- * Call stacks+#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)+        GHC.Stack.CallStack,+#endif+        HasCallStack,+        HasDebugCallStack,+        prettyCurrentCallStack,++        -- * Utils for flags+        OverridingBool(..),+        overrideWith,+    ) where++#include "HsVersions.h"++import Exception+import Panic++import Data.Data+import Data.IORef       ( IORef, newIORef, atomicModifyIORef' )+import System.IO.Unsafe ( unsafePerformIO )+import Data.List        hiding (group)++import GHC.Exts+import qualified GHC.Stack++import Control.Applicative ( liftA2 )+import Control.Monad    ( liftM )+import GHC.IO.Encoding (mkTextEncoding, textEncodingName)+import GHC.Conc.Sync ( sharedCAF )+import System.IO (Handle, hGetEncoding, hSetEncoding)+import System.IO.Error as IO ( isDoesNotExistError )+import System.Directory ( doesDirectoryExist, getModificationTime )+import System.FilePath++import Data.Char        ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper)+import Data.Int+import Data.Ratio       ( (%) )+import Data.Ord         ( comparing )+import Data.Bits+import Data.Word+import qualified Data.IntMap as IM+import qualified Data.Set as Set++import Data.Time++infixr 9 `thenCmp`++{-+************************************************************************+*                                                                      *+\subsection{Is DEBUG on, are we on Windows, etc?}+*                                                                      *+************************************************************************++These booleans are global constants, set by CPP flags.  They allow us to+recompile a single module (this one) to change whether or not debug output+appears. They sometimes let us avoid even running CPP elsewhere.++It's important that the flags are literal constants (True/False). Then,+with -0, tests of the flags in other modules will simplify to the correct+branch of the conditional, thereby dropping debug code altogether when+the flags are off.+-}++ghciSupported :: Bool+#ifdef GHCI+ghciSupported = True+#else+ghciSupported = False+#endif++debugIsOn :: Bool+#ifdef DEBUG+debugIsOn = True+#else+debugIsOn = False+#endif++ncgDebugIsOn :: Bool+#ifdef NCG_DEBUG+ncgDebugIsOn = True+#else+ncgDebugIsOn = False+#endif++ghciTablesNextToCode :: Bool+#ifdef GHCI_TABLES_NEXT_TO_CODE+ghciTablesNextToCode = True+#else+ghciTablesNextToCode = False+#endif++isWindowsHost :: Bool+#ifdef mingw32_HOST_OS+isWindowsHost = True+#else+isWindowsHost = False+#endif++isDarwinHost :: Bool+#ifdef darwin_HOST_OS+isDarwinHost = True+#else+isDarwinHost = False+#endif++{-+************************************************************************+*                                                                      *+\subsection{A for loop}+*                                                                      *+************************************************************************+-}++-- | Compose a function with itself n times.  (nth rather than twice)+nTimes :: Int -> (a -> a) -> (a -> a)+nTimes 0 _ = id+nTimes 1 f = f+nTimes n f = f . nTimes (n-1) f++fstOf3   :: (a,b,c) -> a+sndOf3   :: (a,b,c) -> b+thdOf3   :: (a,b,c) -> c+fstOf3      (a,_,_) =  a+sndOf3      (_,b,_) =  b+thdOf3      (_,_,c) =  c++fst3 :: (a -> d) -> (a, b, c) -> (d, b, c)+fst3 f (a, b, c) = (f a, b, c)++snd3 :: (b -> d) -> (a, b, c) -> (a, d, c)+snd3 f (a, b, c) = (a, f b, c)++third3 :: (c -> d) -> (a, b, c) -> (a, b, d)+third3 f (a, b, c) = (a, b, f c)++uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d+uncurry3 f (a, b, c) = f a b c++liftFst :: (a -> b) -> (a, c) -> (b, c)+liftFst f (a,c) = (f a, c)++liftSnd :: (a -> b) -> (c, a) -> (c, b)+liftSnd f (c,a) = (c, f a)++firstM :: Monad m => (a -> m c) -> (a, b) -> m (c, b)+firstM f (x, y) = liftM (\x' -> (x', y)) (f x)++first3M :: Monad m => (a -> m d) -> (a, b, c) -> m (d, b, c)+first3M f (x, y, z) = liftM (\x' -> (x', y, z)) (f x)++{-+************************************************************************+*                                                                      *+\subsection[Utils-lists]{General list processing}+*                                                                      *+************************************************************************+-}++filterOut :: (a->Bool) -> [a] -> [a]+-- ^ Like filter, only it reverses the sense of the test+filterOut _ [] = []+filterOut p (x:xs) | p x       = filterOut p xs+                   | otherwise = x : filterOut p xs++partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])+-- ^ Uses a function to determine which of two output lists an input element should join+partitionWith _ [] = ([],[])+partitionWith f (x:xs) = case f x of+                         Left  b -> (b:bs, cs)+                         Right c -> (bs, c:cs)+    where (bs,cs) = partitionWith f xs++splitEithers :: [Either a b] -> ([a], [b])+-- ^ Teases a list of 'Either's apart into two lists+splitEithers [] = ([],[])+splitEithers (e : es) = case e of+                        Left x -> (x:xs, ys)+                        Right y -> (xs, y:ys)+    where (xs,ys) = splitEithers es++chkAppend :: [a] -> [a] -> [a]+-- Checks for the second arguemnt being empty+-- Used in situations where that situation is common+chkAppend xs ys+  | null ys   = xs+  | otherwise = xs ++ ys++{-+A paranoid @zip@ (and some @zipWith@ friends) that checks the lists+are of equal length.  Alastair Reid thinks this should only happen if+DEBUGging on; hey, why not?+-}++zipEqual        :: String -> [a] -> [b] -> [(a,b)]+zipWithEqual    :: String -> (a->b->c) -> [a]->[b]->[c]+zipWith3Equal   :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]+zipWith4Equal   :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]++#ifndef DEBUG+zipEqual      _ = zip+zipWithEqual  _ = zipWith+zipWith3Equal _ = zipWith3+zipWith4Equal _ = zipWith4+#else+zipEqual _   []     []     = []+zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs+zipEqual msg _      _      = panic ("zipEqual: unequal lists:"++msg)++zipWithEqual msg z (a:as) (b:bs)=  z a b : zipWithEqual msg z as bs+zipWithEqual _   _ [] []        =  []+zipWithEqual msg _ _ _          =  panic ("zipWithEqual: unequal lists:"++msg)++zipWith3Equal msg z (a:as) (b:bs) (c:cs)+                                =  z a b c : zipWith3Equal msg z as bs cs+zipWith3Equal _   _ [] []  []   =  []+zipWith3Equal msg _ _  _   _    =  panic ("zipWith3Equal: unequal lists:"++msg)++zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)+                                =  z a b c d : zipWith4Equal msg z as bs cs ds+zipWith4Equal _   _ [] [] [] [] =  []+zipWith4Equal msg _ _  _  _  _  =  panic ("zipWith4Equal: unequal lists:"++msg)+#endif++-- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~)+zipLazy :: [a] -> [b] -> [(a,b)]+zipLazy []     _       = []+zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys++-- | 'zipWithLazy' is like 'zipWith' but is lazy in the second list.+-- The length of the output is always the same as the length of the first+-- list.+zipWithLazy :: (a -> b -> c) -> [a] -> [b] -> [c]+zipWithLazy _ []     _       = []+zipWithLazy f (a:as) ~(b:bs) = f a b : zipWithLazy f as bs++-- | 'zipWith3Lazy' is like 'zipWith3' but is lazy in the second and third lists.+-- The length of the output is always the same as the length of the first+-- list.+zipWith3Lazy :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]+zipWith3Lazy _ []     _       _       = []+zipWith3Lazy f (a:as) ~(b:bs) ~(c:cs) = f a b c : zipWith3Lazy f as bs cs++-- | 'filterByList' takes a list of Bools and a list of some elements and+-- filters out these elements for which the corresponding value in the list of+-- Bools is False. This function does not check whether the lists have equal+-- length.+filterByList :: [Bool] -> [a] -> [a]+filterByList (True:bs)  (x:xs) = x : filterByList bs xs+filterByList (False:bs) (_:xs) =     filterByList bs xs+filterByList _          _      = []++-- | 'filterByLists' takes a list of Bools and two lists as input, and+-- outputs a new list consisting of elements from the last two input lists. For+-- each Bool in the list, if it is 'True', then it takes an element from the+-- former list. If it is 'False', it takes an element from the latter list.+-- The elements taken correspond to the index of the Bool in its list.+-- For example:+--+-- @+-- filterByLists [True, False, True, False] \"abcd\" \"wxyz\" = \"axcz\"+-- @+--+-- This function does not check whether the lists have equal length.+filterByLists :: [Bool] -> [a] -> [a] -> [a]+filterByLists (True:bs)  (x:xs) (_:ys) = x : filterByLists bs xs ys+filterByLists (False:bs) (_:xs) (y:ys) = y : filterByLists bs xs ys+filterByLists _          _      _      = []++-- | 'partitionByList' takes a list of Bools and a list of some elements and+-- partitions the list according to the list of Bools. Elements corresponding+-- to 'True' go to the left; elements corresponding to 'False' go to the right.+-- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@+-- This function does not check whether the lists have equal+-- length.+partitionByList :: [Bool] -> [a] -> ([a], [a])+partitionByList = go [] []+  where+    go trues falses (True  : bs) (x : xs) = go (x:trues) falses bs xs+    go trues falses (False : bs) (x : xs) = go trues (x:falses) bs xs+    go trues falses _ _ = (reverse trues, reverse falses)++stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]+-- ^ @stretchZipWith p z f xs ys@ stretches @ys@ by inserting @z@ in+-- the places where @p@ returns @True@++stretchZipWith _ _ _ []     _ = []+stretchZipWith p z f (x:xs) ys+  | p x       = f x z : stretchZipWith p z f xs ys+  | otherwise = case ys of+                []     -> []+                (y:ys) -> f x y : stretchZipWith p z f xs ys++mapFst :: (a->c) -> [(a,b)] -> [(c,b)]+mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]++mapFst f xys = [(f x, y) | (x,y) <- xys]+mapSnd f xys = [(x, f y) | (x,y) <- xys]++mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])++mapAndUnzip _ [] = ([], [])+mapAndUnzip f (x:xs)+  = let (r1,  r2)  = f x+        (rs1, rs2) = mapAndUnzip f xs+    in+    (r1:rs1, r2:rs2)++mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])++mapAndUnzip3 _ [] = ([], [], [])+mapAndUnzip3 f (x:xs)+  = let (r1,  r2,  r3)  = f x+        (rs1, rs2, rs3) = mapAndUnzip3 f xs+    in+    (r1:rs1, r2:rs2, r3:rs3)++zipWithAndUnzip :: (a -> b -> (c,d)) -> [a] -> [b] -> ([c],[d])+zipWithAndUnzip f (a:as) (b:bs)+  = let (r1,  r2)  = f a b+        (rs1, rs2) = zipWithAndUnzip f as bs+    in+    (r1:rs1, r2:rs2)+zipWithAndUnzip _ _ _ = ([],[])++mapAccumL2 :: (s1 -> s2 -> a -> (s1, s2, b)) -> s1 -> s2 -> [a] -> (s1, s2, [b])+mapAccumL2 f s1 s2 xs = (s1', s2', ys)+  where ((s1', s2'), ys) = mapAccumL (\(s1, s2) x -> case f s1 s2 x of+                                                       (s1', s2', y) -> ((s1', s2'), y))+                                     (s1, s2) xs++nOfThem :: Int -> a -> [a]+nOfThem n thing = replicate n thing++-- | @atLength atLen atEnd ls n@ unravels list @ls@ to position @n@. Precisely:+--+-- @+--  atLength atLenPred atEndPred ls n+--   | n < 0         = atLenPred ls+--   | length ls < n = atEndPred (n - length ls)+--   | otherwise     = atLenPred (drop n ls)+-- @+atLength :: ([a] -> b)   -- Called when length ls >= n, passed (drop n ls)+                         --    NB: arg passed to this function may be []+         -> b            -- Called when length ls <  n+         -> [a]+         -> Int+         -> b+atLength atLenPred atEnd ls0 n0+  | n0 < 0    = atLenPred ls0+  | otherwise = go n0 ls0+  where+    -- go's first arg n >= 0+    go 0 ls     = atLenPred ls+    go _ []     = atEnd           -- n > 0 here+    go n (_:xs) = go (n-1) xs++-- Some special cases of atLength:++-- | @(lengthExceeds xs n) = (length xs > n)@+lengthExceeds :: [a] -> Int -> Bool+lengthExceeds lst n+  | n < 0+  = True+  | otherwise+  = atLength notNull False lst n++lengthAtLeast :: [a] -> Int -> Bool+lengthAtLeast = atLength (const True) False++-- | @(lengthIs xs n) = (length xs == n)@+lengthIs :: [a] -> Int -> Bool+lengthIs lst n+  | n < 0+  = False+  | otherwise+  = atLength null False lst n++listLengthCmp :: [a] -> Int -> Ordering+listLengthCmp = atLength atLen atEnd+ where+  atEnd = LT    -- Not yet seen 'n' elts, so list length is < n.++  atLen []     = EQ+  atLen _      = GT++equalLength :: [a] -> [b] -> Bool+equalLength []     []     = True+equalLength (_:xs) (_:ys) = equalLength xs ys+equalLength _      _      = False++compareLength :: [a] -> [b] -> Ordering+compareLength []     []     = EQ+compareLength (_:xs) (_:ys) = compareLength xs ys+compareLength []     _      = LT+compareLength _      []     = GT++leLength :: [a] -> [b] -> Bool+-- ^ True if length xs <= length ys+leLength xs ys = case compareLength xs ys of+                   LT -> True+                   EQ -> True+                   GT -> False++----------------------------+singleton :: a -> [a]+singleton x = [x]++isSingleton :: [a] -> Bool+isSingleton [_] = True+isSingleton _   = False++notNull :: [a] -> Bool+notNull [] = False+notNull _  = True++only :: [a] -> a+#ifdef DEBUG+only [a] = a+#else+only (a:_) = a+#endif+only _ = panic "Util: only"++-- Debugging/specialising versions of \tr{elem} and \tr{notElem}++isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool++# ifndef DEBUG+isIn    _msg x ys = x `elem` ys+isn'tIn _msg x ys = x `notElem` ys++# else /* DEBUG */+isIn msg x ys+  = elem100 0 x ys+  where+    elem100 :: Eq a => Int -> a -> [a] -> Bool+    elem100 _ _ [] = False+    elem100 i x (y:ys)+      | i > 100 = trace ("Over-long elem in " ++ msg) (x `elem` (y:ys))+      | otherwise = x == y || elem100 (i + 1) x ys++isn'tIn msg x ys+  = notElem100 0 x ys+  where+    notElem100 :: Eq a => Int -> a -> [a] -> Bool+    notElem100 _ _ [] =  True+    notElem100 i x (y:ys)+      | i > 100 = trace ("Over-long notElem in " ++ msg) (x `notElem` (y:ys))+      | otherwise = x /= y && notElem100 (i + 1) x ys+# endif /* DEBUG */+++-- | Split a list into chunks of /n/ elements+chunkList :: Int -> [a] -> [[a]]+chunkList _ [] = []+chunkList n xs = as : chunkList n bs where (as,bs) = splitAt n xs++-- | Replace the last element of a list with another element.+changeLast :: [a] -> a -> [a]+changeLast []     _  = panic "changeLast"+changeLast [_]    x  = [x]+changeLast (x:xs) x' = x : changeLast xs x'++{-+************************************************************************+*                                                                      *+\subsubsection{Sort utils}+*                                                                      *+************************************************************************+-}++minWith :: Ord b => (a -> b) -> [a] -> a+minWith get_key xs = ASSERT( not (null xs) )+                     head (sortWith get_key xs)++nubSort :: Ord a => [a] -> [a]+nubSort = Set.toAscList . Set.fromList++{-+************************************************************************+*                                                                      *+\subsection[Utils-transitive-closure]{Transitive closure}+*                                                                      *+************************************************************************++This algorithm for transitive closure is straightforward, albeit quadratic.+-}++transitiveClosure :: (a -> [a])         -- Successor function+                  -> (a -> a -> Bool)   -- Equality predicate+                  -> [a]+                  -> [a]                -- The transitive closure++transitiveClosure succ eq xs+ = go [] xs+ where+   go done []                      = done+   go done (x:xs) | x `is_in` done = go done xs+                  | otherwise      = go (x:done) (succ x ++ xs)++   _ `is_in` []                 = False+   x `is_in` (y:ys) | eq x y    = True+                    | otherwise = x `is_in` ys++{-+************************************************************************+*                                                                      *+\subsection[Utils-accum]{Accumulating}+*                                                                      *+************************************************************************++A combination of foldl with zip.  It works with equal length lists.+-}++foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc+foldl2 _ z [] [] = z+foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs+foldl2 _ _ _      _      = panic "Util: foldl2"++all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool+-- True if the lists are the same length, and+-- all corresponding elements satisfy the predicate+all2 _ []     []     = True+all2 p (x:xs) (y:ys) = p x y && all2 p xs ys+all2 _ _      _      = False++-- Count the number of times a predicate is true++count :: (a -> Bool) -> [a] -> Int+count p = go 0+  where go !n [] = n+        go !n (x:xs) | p x       = go (n+1) xs+                     | otherwise = go n xs++{-+@splitAt@, @take@, and @drop@ but with length of another+list giving the break-off point:+-}++takeList :: [b] -> [a] -> [a]+-- (takeList as bs) trims bs to the be same length+-- as as, unless as is longer in which case it's a no-op+takeList [] _ = []+takeList (_:xs) ls =+   case ls of+     [] -> []+     (y:ys) -> y : takeList xs ys++dropList :: [b] -> [a] -> [a]+dropList [] xs    = xs+dropList _  xs@[] = xs+dropList (_:xs) (_:ys) = dropList xs ys+++splitAtList :: [b] -> [a] -> ([a], [a])+splitAtList [] xs     = ([], xs)+splitAtList _ xs@[]   = (xs, xs)+splitAtList (_:xs) (y:ys) = (y:ys', ys'')+    where+      (ys', ys'') = splitAtList xs ys++-- drop from the end of a list+dropTail :: Int -> [a] -> [a]+-- Specification: dropTail n = reverse . drop n . reverse+-- Better implemention due to Joachim Breitner+-- http://www.joachim-breitner.de/blog/archives/600-On-taking-the-last-n-elements-of-a-list.html+dropTail n xs+  = go (drop n xs) xs+  where+    go (_:ys) (x:xs) = x : go ys xs+    go _      _      = []  -- Stop when ys runs out+                           -- It'll always run out before xs does++-- dropWhile from the end of a list. This is similar to Data.List.dropWhileEnd,+-- but is lazy in the elements and strict in the spine. For reasonably short lists,+-- such as path names and typical lines of text, dropWhileEndLE is generally+-- faster than dropWhileEnd. Its advantage is magnified when the predicate is+-- expensive--using dropWhileEndLE isSpace to strip the space off a line of text+-- is generally much faster than using dropWhileEnd isSpace for that purpose.+-- Specification: dropWhileEndLE p = reverse . dropWhile p . reverse+-- Pay attention to the short-circuit (&&)! The order of its arguments is the only+-- difference between dropWhileEnd and dropWhileEndLE.+dropWhileEndLE :: (a -> Bool) -> [a] -> [a]+dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) []++-- | @spanEnd p l == reverse (span p (reverse l))@. The first list+-- returns actually comes after the second list (when you look at the+-- input list).+spanEnd :: (a -> Bool) -> [a] -> ([a], [a])+spanEnd p l = go l [] [] l+  where go yes _rev_yes rev_no [] = (yes, reverse rev_no)+        go yes rev_yes  rev_no (x:xs)+          | p x       = go yes (x : rev_yes) rev_no                  xs+          | otherwise = go xs  []            (x : rev_yes ++ rev_no) xs+++snocView :: [a] -> Maybe ([a],a)+        -- Split off the last element+snocView [] = Nothing+snocView xs = go [] xs+            where+                -- Invariant: second arg is non-empty+              go acc [x]    = Just (reverse acc, x)+              go acc (x:xs) = go (x:acc) xs+              go _   []     = panic "Util: snocView"++split :: Char -> String -> [String]+split c s = case rest of+                []     -> [chunk]+                _:rest -> chunk : split c rest+  where (chunk, rest) = break (==c) s++-- | Convert a word to title case by capitalising the first letter+capitalise :: String -> String+capitalise [] = []+capitalise (c:cs) = toUpper c : cs+++{-+************************************************************************+*                                                                      *+\subsection[Utils-comparison]{Comparisons}+*                                                                      *+************************************************************************+-}++isEqual :: Ordering -> Bool+-- Often used in (isEqual (a `compare` b))+isEqual GT = False+isEqual EQ = True+isEqual LT = False++thenCmp :: Ordering -> Ordering -> Ordering+{-# INLINE thenCmp #-}+thenCmp EQ       ordering = ordering+thenCmp ordering _        = ordering++eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool+eqListBy _  []     []     = True+eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys+eqListBy _  _      _      = False++eqMaybeBy :: (a ->a->Bool) -> Maybe a -> Maybe a -> Bool+eqMaybeBy _  Nothing  Nothing  = True+eqMaybeBy eq (Just x) (Just y) = eq x y+eqMaybeBy _  _        _        = False++cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering+    -- `cmpList' uses a user-specified comparer++cmpList _   []     [] = EQ+cmpList _   []     _  = LT+cmpList _   _      [] = GT+cmpList cmp (a:as) (b:bs)+  = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }++removeSpaces :: String -> String+removeSpaces = dropWhileEndLE isSpace . dropWhile isSpace++-- Boolean operators lifted to Applicative+(<&&>) :: Applicative f => f Bool -> f Bool -> f Bool+(<&&>) = liftA2 (&&)+infixr 3 <&&> -- same as (&&)++(<||>) :: Applicative f => f Bool -> f Bool -> f Bool+(<||>) = liftA2 (||)+infixr 2 <||> -- same as (||)++{-+************************************************************************+*                                                                      *+\subsection{Edit distance}+*                                                                      *+************************************************************************+-}++-- | Find the "restricted" Damerau-Levenshtein edit distance between two strings.+-- See: <http://en.wikipedia.org/wiki/Damerau-Levenshtein_distance>.+-- Based on the algorithm presented in "A Bit-Vector Algorithm for Computing+-- Levenshtein and Damerau Edit Distances" in PSC'02 (Heikki Hyyro).+-- See http://www.cs.uta.fi/~helmu/pubs/psc02.pdf and+--     http://www.cs.uta.fi/~helmu/pubs/PSCerr.html for an explanation+restrictedDamerauLevenshteinDistance :: String -> String -> Int+restrictedDamerauLevenshteinDistance str1 str2+  = restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2+  where+    m = length str1+    n = length str2++restrictedDamerauLevenshteinDistanceWithLengths+  :: Int -> Int -> String -> String -> Int+restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2+  | m <= n+  = if n <= 32 -- n must be larger so this check is sufficient+    then restrictedDamerauLevenshteinDistance' (undefined :: Word32) m n str1 str2+    else restrictedDamerauLevenshteinDistance' (undefined :: Integer) m n str1 str2++  | otherwise+  = if m <= 32 -- m must be larger so this check is sufficient+    then restrictedDamerauLevenshteinDistance' (undefined :: Word32) n m str2 str1+    else restrictedDamerauLevenshteinDistance' (undefined :: Integer) n m str2 str1++restrictedDamerauLevenshteinDistance'+  :: (Bits bv, Num bv) => bv -> Int -> Int -> String -> String -> Int+restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2+  | [] <- str1 = n+  | otherwise  = extractAnswer $+                 foldl' (restrictedDamerauLevenshteinDistanceWorker+                             (matchVectors str1) top_bit_mask vector_mask)+                        (0, 0, m_ones, 0, m) str2+  where+    m_ones@vector_mask = (2 ^ m) - 1+    top_bit_mask = (1 `shiftL` (m - 1)) `asTypeOf` _bv_dummy+    extractAnswer (_, _, _, _, distance) = distance++restrictedDamerauLevenshteinDistanceWorker+      :: (Bits bv, Num bv) => IM.IntMap bv -> bv -> bv+      -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int)+restrictedDamerauLevenshteinDistanceWorker str1_mvs top_bit_mask vector_mask+                                           (pm, d0, vp, vn, distance) char2+  = seq str1_mvs $ seq top_bit_mask $ seq vector_mask $+    seq pm' $ seq d0' $ seq vp' $ seq vn' $+    seq distance'' $ seq char2 $+    (pm', d0', vp', vn', distance'')+  where+    pm' = IM.findWithDefault 0 (ord char2) str1_mvs++    d0' = ((((sizedComplement vector_mask d0) .&. pm') `shiftL` 1) .&. pm)+      .|. ((((pm' .&. vp) + vp) .&. vector_mask) `xor` vp) .|. pm' .|. vn+          -- No need to mask the shiftL because of the restricted range of pm++    hp' = vn .|. sizedComplement vector_mask (d0' .|. vp)+    hn' = d0' .&. vp++    hp'_shift = ((hp' `shiftL` 1) .|. 1) .&. vector_mask+    hn'_shift = (hn' `shiftL` 1) .&. vector_mask+    vp' = hn'_shift .|. sizedComplement vector_mask (d0' .|. hp'_shift)+    vn' = d0' .&. hp'_shift++    distance' = if hp' .&. top_bit_mask /= 0 then distance + 1 else distance+    distance'' = if hn' .&. top_bit_mask /= 0 then distance' - 1 else distance'++sizedComplement :: Bits bv => bv -> bv -> bv+sizedComplement vector_mask vect = vector_mask `xor` vect++matchVectors :: (Bits bv, Num bv) => String -> IM.IntMap bv+matchVectors = snd . foldl' go (0 :: Int, IM.empty)+  where+    go (ix, im) char = let ix' = ix + 1+                           im' = IM.insertWith (.|.) (ord char) (2 ^ ix) im+                       in seq ix' $ seq im' $ (ix', im')++{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance'+                      :: Word32 -> Int -> Int -> String -> String -> Int #-}+{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance'+                      :: Integer -> Int -> Int -> String -> String -> Int #-}++{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker+               :: IM.IntMap Word32 -> Word32 -> Word32+               -> (Word32, Word32, Word32, Word32, Int)+               -> Char -> (Word32, Word32, Word32, Word32, Int) #-}+{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker+               :: IM.IntMap Integer -> Integer -> Integer+               -> (Integer, Integer, Integer, Integer, Int)+               -> Char -> (Integer, Integer, Integer, Integer, Int) #-}++{-# SPECIALIZE INLINE sizedComplement :: Word32 -> Word32 -> Word32 #-}+{-# SPECIALIZE INLINE sizedComplement :: Integer -> Integer -> Integer #-}++{-# SPECIALIZE matchVectors :: String -> IM.IntMap Word32 #-}+{-# SPECIALIZE matchVectors :: String -> IM.IntMap Integer #-}++fuzzyMatch :: String -> [String] -> [String]+fuzzyMatch key vals = fuzzyLookup key [(v,v) | v <- vals]++-- | Search for possible matches to the users input in the given list,+-- returning a small number of ranked results+fuzzyLookup :: String -> [(String,a)] -> [a]+fuzzyLookup user_entered possibilites+  = map fst $ take mAX_RESULTS $ sortBy (comparing snd)+    [ (poss_val, distance) | (poss_str, poss_val) <- possibilites+                       , let distance = restrictedDamerauLevenshteinDistance+                                            poss_str user_entered+                       , distance <= fuzzy_threshold ]+  where+    -- Work out an approriate match threshold:+    -- We report a candidate if its edit distance is <= the threshold,+    -- The threshold is set to about a quarter of the # of characters the user entered+    --   Length    Threshold+    --     1         0          -- Don't suggest *any* candidates+    --     2         1          -- for single-char identifiers+    --     3         1+    --     4         1+    --     5         1+    --     6         2+    --+    fuzzy_threshold = truncate $ fromIntegral (length user_entered + 2) / (4 :: Rational)+    mAX_RESULTS = 3++{-+************************************************************************+*                                                                      *+\subsection[Utils-pairs]{Pairs}+*                                                                      *+************************************************************************+-}++unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]+unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs++seqList :: [a] -> b -> b+seqList [] b = b+seqList (x:xs) b = x `seq` seqList xs b+++{-+************************************************************************+*                                                                      *+                        Globals and the RTS+*                                                                      *+************************************************************************++When a plugin is loaded, it currently gets linked against a *newly+loaded* copy of the GHC package. This would not be a problem, except+that the new copy has its own mutable state that is not shared with+that state that has already been initialized by the original GHC+package.++(Note that if the GHC executable was dynamically linked this+wouldn't be a problem, because we could share the GHC library it+links to; this is only a problem if DYNAMIC_GHC_PROGRAMS=NO.)++The solution is to make use of @sharedCAF@ through @sharedGlobal@+for globals that are shared between multiple copies of ghc packages.+-}++-- Global variables:++global :: a -> IORef a+global a = unsafePerformIO (newIORef a)++consIORef :: IORef [a] -> a -> IO ()+consIORef var x = do+  atomicModifyIORef' var (\xs -> (x:xs,()))++globalM :: IO a -> IORef a+globalM ma = unsafePerformIO (ma >>= newIORef)++-- Shared global variables:++sharedGlobal :: a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a+sharedGlobal a get_or_set = unsafePerformIO $+  newIORef a >>= flip sharedCAF get_or_set++sharedGlobalM :: IO a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a+sharedGlobalM ma get_or_set = unsafePerformIO $+  ma >>= newIORef >>= flip sharedCAF get_or_set++-- Module names:++looksLikeModuleName :: String -> Bool+looksLikeModuleName [] = False+looksLikeModuleName (c:cs) = isUpper c && go cs+  where go [] = True+        go ('.':cs) = looksLikeModuleName cs+        go (c:cs)   = (isAlphaNum c || c == '_' || c == '\'') && go cs++-- Similar to 'parse' for Distribution.Package.PackageName,+-- but we don't want to depend on Cabal.+looksLikePackageName :: String -> Bool+looksLikePackageName = all (all isAlphaNum <&&> not . (all isDigit)) . split '-'++{-+Akin to @Prelude.words@, but acts like the Bourne shell, treating+quoted strings as Haskell Strings, and also parses Haskell [String]+syntax.+-}++getCmd :: String -> Either String             -- Error+                           (String, String) -- (Cmd, Rest)+getCmd s = case break isSpace $ dropWhile isSpace s of+           ([], _) -> Left ("Couldn't find command in " ++ show s)+           res -> Right res++toCmdArgs :: String -> Either String             -- Error+                              (String, [String]) -- (Cmd, Args)+toCmdArgs s = case getCmd s of+              Left err -> Left err+              Right (cmd, s') -> case toArgs s' of+                                 Left err -> Left err+                                 Right args -> Right (cmd, args)++toArgs :: String -> Either String   -- Error+                           [String] -- Args+toArgs str+    = case dropWhile isSpace str of+      s@('[':_) -> case reads s of+                   [(args, spaces)]+                    | all isSpace spaces ->+                       Right args+                   _ ->+                       Left ("Couldn't read " ++ show str ++ " as [String]")+      s -> toArgs' s+ where+  toArgs' :: String -> Either String [String]+  -- Remove outer quotes:+  -- > toArgs' "\"foo\" \"bar baz\""+  -- Right ["foo", "bar baz"]+  --+  -- Keep inner quotes:+  -- > toArgs' "-DFOO=\"bar baz\""+  -- Right ["-DFOO=\"bar baz\""]+  toArgs' s = case dropWhile isSpace s of+              [] -> Right []+              ('"' : _) -> do+                    -- readAsString removes outer quotes+                    (arg, rest) <- readAsString s+                    (arg:) `fmap` toArgs' rest+              s' -> case break (isSpace <||> (== '"')) s' of+                    (argPart1, s''@('"':_)) -> do+                        (argPart2, rest) <- readAsString s''+                        -- show argPart2 to keep inner quotes+                        ((argPart1 ++ show argPart2):) `fmap` toArgs' rest+                    (arg, s'') -> (arg:) `fmap` toArgs' s''++  readAsString :: String -> Either String (String, String)+  readAsString s = case reads s of+                [(arg, rest)]+                    -- rest must either be [] or start with a space+                    | all isSpace (take 1 rest) ->+                    Right (arg, rest)+                _ ->+                    Left ("Couldn't read " ++ show s ++ " as String")+-----------------------------------------------------------------------------+-- Integers++-- This algorithm for determining the $\log_2$ of exact powers of 2 comes+-- from GCC.  It requires bit manipulation primitives, and we use GHC+-- extensions.  Tough.++exactLog2 :: Integer -> Maybe Integer+exactLog2 x+  = if (x <= 0 || x >= 2147483648) then+       Nothing+    else+       if (x .&. (-x)) /= x then+          Nothing+       else+          Just (pow2 x)+  where+    pow2 x | x == 1 = 0+           | otherwise = 1 + pow2 (x `shiftR` 1)+++{-+-- -----------------------------------------------------------------------------+-- Floats+-}++readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"+readRational__ r = do+     (n,d,s) <- readFix r+     (k,t)   <- readExp s+     return ((n%1)*10^^(k-d), t)+ where+     readFix r = do+        (ds,s)  <- lexDecDigits r+        (ds',t) <- lexDotDigits s+        return (read (ds++ds'), length ds', t)++     readExp (e:s) | e `elem` "eE" = readExp' s+     readExp s                     = return (0,s)++     readExp' ('+':s) = readDec s+     readExp' ('-':s) = do (k,t) <- readDec s+                           return (-k,t)+     readExp' s       = readDec s++     readDec s = do+        (ds,r) <- nonnull isDigit s+        return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],+                r)++     lexDecDigits = nonnull isDigit++     lexDotDigits ('.':s) = return (span isDigit s)+     lexDotDigits s       = return ("",s)++     nonnull p s = do (cs@(_:_),t) <- return (span p s)+                      return (cs,t)++readRational :: String -> Rational -- NB: *does* handle a leading "-"+readRational top_s+  = case top_s of+      '-' : xs -> - (read_me xs)+      xs       -> read_me xs+  where+    read_me s+      = case (do { (x,"") <- readRational__ s ; return x }) of+          [x] -> x+          []  -> error ("readRational: no parse:"        ++ top_s)+          _   -> error ("readRational: ambiguous parse:" ++ top_s)+++-----------------------------------------------------------------------------+-- read helpers++maybeRead :: Read a => String -> Maybe a+maybeRead str = case reads str of+                [(x, "")] -> Just x+                _         -> Nothing++maybeReadFuzzy :: Read a => String -> Maybe a+maybeReadFuzzy str = case reads str of+                     [(x, s)]+                      | all isSpace s ->+                         Just x+                     _ ->+                         Nothing++-----------------------------------------------------------------------------+-- Verify that the 'dirname' portion of a FilePath exists.+--+doesDirNameExist :: FilePath -> IO Bool+doesDirNameExist fpath = doesDirectoryExist (takeDirectory fpath)++-----------------------------------------------------------------------------+-- Backwards compatibility definition of getModificationTime++getModificationUTCTime :: FilePath -> IO UTCTime+getModificationUTCTime = getModificationTime++-- --------------------------------------------------------------+-- check existence & modification time at the same time++modificationTimeIfExists :: FilePath -> IO (Maybe UTCTime)+modificationTimeIfExists f = do+  (do t <- getModificationUTCTime f; return (Just t))+        `catchIO` \e -> if isDoesNotExistError e+                        then return Nothing+                        else ioError e++-- --------------------------------------------------------------+-- Change the character encoding of the given Handle to transliterate+-- on unsupported characters instead of throwing an exception++hSetTranslit :: Handle -> IO ()+hSetTranslit h = do+    menc <- hGetEncoding h+    case fmap textEncodingName menc of+        Just name | '/' `notElem` name -> do+            enc' <- mkTextEncoding $ name ++ "//TRANSLIT"+            hSetEncoding h enc'+        _ -> return ()++-- split a string at the last character where 'pred' is True,+-- returning a pair of strings. The first component holds the string+-- up (but not including) the last character for which 'pred' returned+-- True, the second whatever comes after (but also not including the+-- last character).+--+-- If 'pred' returns False for all characters in the string, the original+-- string is returned in the first component (and the second one is just+-- empty).+splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)+splitLongestPrefix str pred+  | null r_pre = (str,           [])+  | otherwise  = (reverse (tail r_pre), reverse r_suf)+                           -- 'tail' drops the char satisfying 'pred'+  where (r_suf, r_pre) = break pred (reverse str)++escapeSpaces :: String -> String+escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""++type Suffix = String++--------------------------------------------------------------+-- * Search path+--------------------------------------------------------------++data Direction = Forwards | Backwards++reslash :: Direction -> FilePath -> FilePath+reslash d = f+    where f ('/'  : xs) = slash : f xs+          f ('\\' : xs) = slash : f xs+          f (x    : xs) = x     : f xs+          f ""          = ""+          slash = case d of+                  Forwards -> '/'+                  Backwards -> '\\'++makeRelativeTo :: FilePath -> FilePath -> FilePath+this `makeRelativeTo` that = directory </> thisFilename+    where (thisDirectory, thisFilename) = splitFileName this+          thatDirectory = dropFileName that+          directory = joinPath $ f (splitPath thisDirectory)+                                   (splitPath thatDirectory)++          f (x : xs) (y : ys)+           | x == y = f xs ys+          f xs ys = replicate (length ys) ".." ++ xs++{-+************************************************************************+*                                                                      *+\subsection[Utils-Data]{Utils for defining Data instances}+*                                                                      *+************************************************************************++These functions helps us to define Data instances for abstract types.+-}++abstractConstr :: String -> Constr+abstractConstr n = mkConstr (abstractDataType n) ("{abstract:"++n++"}") [] Prefix++abstractDataType :: String -> DataType+abstractDataType n = mkDataType n [abstractConstr n]++{-+************************************************************************+*                                                                      *+\subsection[Utils-C]{Utils for printing C code}+*                                                                      *+************************************************************************+-}++charToC :: Word8 -> String+charToC w =+  case chr (fromIntegral w) of+        '\"' -> "\\\""+        '\'' -> "\\\'"+        '\\' -> "\\\\"+        c | c >= ' ' && c <= '~' -> [c]+          | otherwise -> ['\\',+                         chr (ord '0' + ord c `div` 64),+                         chr (ord '0' + ord c `div` 8 `mod` 8),+                         chr (ord '0' + ord c         `mod` 8)]++{-+************************************************************************+*                                                                      *+\subsection[Utils-Hashing]{Utils for hashing}+*                                                                      *+************************************************************************+-}++-- | A sample hash function for Strings.  We keep multiplying by the+-- golden ratio and adding.  The implementation is:+--+-- > hashString = foldl' f golden+-- >   where f m c = fromIntegral (ord c) * magic + hashInt32 m+-- >         magic = 0xdeadbeef+--+-- Where hashInt32 works just as hashInt shown above.+--+-- Knuth argues that repeated multiplication by the golden ratio+-- will minimize gaps in the hash space, and thus it's a good choice+-- for combining together multiple keys to form one.+--+-- Here we know that individual characters c are often small, and this+-- produces frequent collisions if we use ord c alone.  A+-- particular problem are the shorter low ASCII and ISO-8859-1+-- character strings.  We pre-multiply by a magic twiddle factor to+-- obtain a good distribution.  In fact, given the following test:+--+-- > testp :: Int32 -> Int+-- > testp k = (n - ) . length . group . sort . map hs . take n $ ls+-- >   where ls = [] : [c : l | l <- ls, c <- ['\0'..'\xff']]+-- >         hs = foldl' f golden+-- >         f m c = fromIntegral (ord c) * k + hashInt32 m+-- >         n = 100000+--+-- We discover that testp magic = 0.+hashString :: String -> Int32+hashString = foldl' f golden+   where f m c = fromIntegral (ord c) * magic + hashInt32 m+         magic = fromIntegral (0xdeadbeef :: Word32)++golden :: Int32+golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32+-- was -1640531527 = round ((sqrt 5 - 1) * 2^31) :: Int32+-- but that has bad mulHi properties (even adding 2^32 to get its inverse)+-- Whereas the above works well and contains no hash duplications for+-- [-32767..65536]++-- | A sample (and useful) hash function for Int32,+-- implemented by extracting the uppermost 32 bits of the 64-bit+-- result of multiplying by a 33-bit constant.  The constant is from+-- Knuth, derived from the golden ratio:+--+-- > golden = round ((sqrt 5 - 1) * 2^32)+--+-- We get good key uniqueness on small inputs+-- (a problem with previous versions):+--  (length $ group $ sort $ map hashInt32 [-32767..65536]) == 65536 + 32768+--+hashInt32 :: Int32 -> Int32+hashInt32 x = mulHi x golden + x++-- hi 32 bits of a x-bit * 32 bit -> 64-bit multiply+mulHi :: Int32 -> Int32 -> Int32+mulHi a b = fromIntegral (r `shiftR` 32)+   where r :: Int64+         r = fromIntegral a * fromIntegral b++-- | A compatibility wrapper for the @GHC.Stack.HasCallStack@ constraint.+#if __GLASGOW_HASKELL__ >= 800+type HasCallStack = GHC.Stack.HasCallStack+#elif MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)+type HasCallStack = (?callStack :: GHC.Stack.CallStack)+-- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1+#else+type HasCallStack = (() :: Constraint)+#endif++-- | A call stack constraint, but only when 'isDebugOn'.+#if DEBUG+type HasDebugCallStack = HasCallStack+#else+type HasDebugCallStack = (() :: Constraint)+#endif++-- | Pretty-print the current callstack+#if __GLASGOW_HASKELL__ >= 800+prettyCurrentCallStack :: HasCallStack => String+prettyCurrentCallStack = GHC.Stack.prettyCallStack GHC.Stack.callStack+#elif MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)+prettyCurrentCallStack :: (?callStack :: GHC.Stack.CallStack) => String+prettyCurrentCallStack = GHC.Stack.showCallStack ?callStack+#else+prettyCurrentCallStack :: HasCallStack => String+prettyCurrentCallStack = "Call stack unavailable"+#endif++data OverridingBool+  = Auto+  | Always+  | Never+  deriving Show++overrideWith :: Bool -> OverridingBool -> Bool+overrideWith b Auto   = b+overrideWith _ Always = True+overrideWith _ Never  = False
+ utils/md5.h view
@@ -0,0 +1,24 @@+/* MD5 message digest */+#ifndef _MD5_H+#define _MD5_H++#include "HsFFI.h"++typedef HsWord32 word32;+typedef HsWord8  byte;++struct MD5Context {+        word32 buf[4];+        word32 bytes[2];+        word32 in[16];+};++void MD5Init(struct MD5Context *context);+void MD5Update(struct MD5Context *context, byte const *buf, int len);+void MD5Final(byte digest[16], struct MD5Context *context);+void MD5Transform(word32 buf[4], word32 const in[16]);++#endif /* _MD5_H */+++
+ vectorise/Vectorise.hs view
@@ -0,0 +1,356 @@+-- Main entry point to the vectoriser.  It is invoked iff the option '-fvectorise' is passed.+--+-- This module provides the function 'vectorise', which vectorises an entire (desugared) module.+-- It vectorises all type declarations and value bindings.  It also processes all VECTORISE pragmas+-- (aka vectorisation declarations), which can lead to the vectorisation of imported data types+-- and the enrichment of imported functions with vectorised versions.++module Vectorise ( vectorise )+where++import Vectorise.Type.Env+import Vectorise.Type.Type+import Vectorise.Convert+import Vectorise.Utils.Hoisting+import Vectorise.Exp+import Vectorise.Env+import Vectorise.Monad++import HscTypes hiding      ( MonadThings(..) )+import CoreUnfold           ( mkInlineUnfoldingWithArity )+import PprCore+import CoreSyn+import CoreMonad            ( CoreM, getHscEnv )+import Type+import Id+import DynFlags+import Outputable+import Util                 ( zipLazy )+import MonadUtils++import Control.Monad+++-- |Vectorise a single module.+--+vectorise :: ModGuts -> CoreM ModGuts+vectorise guts+ = do { hsc_env <- getHscEnv+      ; liftIO $ vectoriseIO hsc_env guts+      }++-- Vectorise a single monad, given the dynamic compiler flags and HscEnv.+--+vectoriseIO :: HscEnv -> ModGuts -> IO ModGuts+vectoriseIO hsc_env guts+ = do {   -- Get information about currently loaded external packages.+      ; eps <- hscEPS hsc_env++          -- Combine vectorisation info from the current module, and external ones.+      ; let info = hptVectInfo hsc_env `plusVectInfo` eps_vect_info eps++          -- Run the main VM computation.+      ; Just (info', guts') <- initV hsc_env guts info (vectModule guts)+      ; return (guts' { mg_vect_info = info' })+      }++-- Vectorise a single module, in the VM monad.+--+vectModule :: ModGuts -> VM ModGuts+vectModule guts@(ModGuts { mg_tcs        = tycons+                         , mg_binds      = binds+                         , mg_fam_insts  = fam_insts+                         , mg_vect_decls = vect_decls+                         })+ = do { dumpOptVt Opt_D_dump_vt_trace "Before vectorisation" $+          pprCoreBindings binds++          -- Pick out all 'VECTORISE [SCALAR] type' and 'VECTORISE class' pragmas+      ; let ty_vect_decls  = [vd | vd@(VectType _ _ _) <- vect_decls]+            cls_vect_decls = [vd | vd@(VectClass _)    <- vect_decls]++          -- Vectorise the type environment.  This will add vectorised+          -- type constructors, their representations, and the+          -- corresponding data constructors.  Moreover, we produce+          -- bindings for dfuns and family instances of the classes+          -- and type families used in the DPH library to represent+          -- array types.+      ; (new_tycons, new_fam_insts, tc_binds) <- vectTypeEnv tycons ty_vect_decls cls_vect_decls++          -- Family instance environment for /all/ home-package modules including those instances+          -- generated by 'vectTypeEnv'.+      ; (_, fam_inst_env) <- readGEnv global_fam_inst_env++          -- Vectorise all the top level bindings and VECTORISE declarations on imported identifiers+          -- NB: Need to vectorise the imported bindings first (local bindings may depend on them).+      ; let impBinds = [(imp_id, expr) | Vect imp_id expr <- vect_decls, isGlobalId imp_id]+      ; binds_imp <- mapM vectImpBind impBinds+      ; binds_top <- mapM vectTopBind binds++      ; return $ guts { mg_tcs          = tycons ++ new_tycons+                        -- we produce no new classes or instances, only new class type constructors+                        -- and dfuns+                      , mg_binds        = Rec tc_binds : (binds_top ++ binds_imp)+                      , mg_fam_inst_env = fam_inst_env+                      , mg_fam_insts    = fam_insts ++ new_fam_insts+                      }+      }++-- Try to vectorise a top-level binding.  If it doesn't vectorise, or if it is entirely scalar, then+-- omit vectorisation of that binding.+--+-- For example, for the binding+--+-- @+--    foo :: Int -> Int+--    foo = \x -> x + x+-- @+--+-- we get+-- @+--    foo  :: Int -> Int+--    foo  = \x -> vfoo $: x+--+--    v_foo :: Closure void vfoo lfoo+--    v_foo = closure vfoo lfoo void+--+--    vfoo :: Void -> Int -> Int+--    vfoo = ...+--+--    lfoo :: PData Void -> PData Int -> PData Int+--    lfoo = ...+-- @+--+-- @vfoo@ is the "vectorised", or scalar, version that does the same as the original function foo,+-- but takes an explicit environment.+--+-- @lfoo@ is the "lifted" version that works on arrays.+--+-- @v_foo@ combines both of these into a `Closure` that also contains the environment.+--+-- The original binding @foo@ is rewritten to call the vectorised version present in the closure.+--+-- Vectorisation may be suppressed by annotating a binding with a 'NOVECTORISE' pragma.  If this+-- pragma is used in a group of mutually recursive bindings, either all or no binding must have+-- the pragma.  If only some bindings are annotated, a fatal error is being raised. (In the case of+-- scalar bindings, we only omit vectorisation if all bindings in a group are scalar.)+--+-- FIXME: Once we support partial vectorisation, we may be able to vectorise parts of a group, or+--   we may emit a warning and refrain from vectorising the entire group.+--+vectTopBind :: CoreBind -> VM CoreBind+vectTopBind b@(NonRec var expr)+  = do+    { traceVt "= Vectorise non-recursive top-level variable" (ppr var)++    ; (hasNoVect, vectDecl) <- lookupVectDecl var+    ; if hasNoVect+      then do+      {   -- 'NOVECTORISE' pragma => leave this binding as it is+      ; traceVt "NOVECTORISE" $ ppr var+      ; return b+      }+      else do+    { vectRhs <- case vectDecl of+        Just (_, expr') ->+            -- 'VECTORISE' pragma => just use the provided vectorised rhs+          do+          { traceVt "VECTORISE" $ ppr var+          ; addGlobalParallelVar var+          ; return $ Just (False, inlineMe, expr')+          }+        Nothing         ->+            -- no pragma => standard vectorisation of rhs+          do+          { traceVt "[Vanilla]" $ ppr var <+> char '=' <+> ppr expr+          ; vectTopExpr var expr+          }+    ; hs <- takeHoisted -- make sure we clean those out (even if we skip)+    ; case vectRhs of+      { Nothing ->+          -- scalar binding => leave this binding as it is+          do+          { traceVt "scalar binding [skip]" $ ppr var+          ; return b+          }+      ; Just (parBind, inline, expr') -> do+    {+       -- vanilla case => create an appropriate top-level binding & add it to the vectorisation map+    ; when parBind $+        addGlobalParallelVar var+    ; var' <- vectTopBinder var inline expr'++        -- We replace the original top-level binding by a value projected from the vectorised+        -- closure and add any newly created hoisted top-level bindings.+    ; cexpr <- tryConvert var var' expr+    ; return . Rec $ (var, cexpr) : (var', expr') : hs+    } } } }+    `orElseErrV`+    do+    { emitVt "  Could NOT vectorise top-level binding" $ ppr var+    ; return b+    }+vectTopBind b@(Rec binds)+  = do+    { traceVt "= Vectorise recursive top-level variables" $ ppr vars++    ; vectDecls <- mapM lookupVectDecl vars+    ; let hasNoVects = map fst vectDecls+    ; if and hasNoVects+      then do+      {   -- 'NOVECTORISE' pragmas => leave this entire binding group as it is+      ; traceVt "NOVECTORISE" $ ppr vars+      ; return b+      }+      else do+    { if or hasNoVects+      then do+        {   -- Inconsistent 'NOVECTORISE' pragmas => bail out+        ; dflags <- getDynFlags+        ; cantVectorise dflags noVectoriseErr (ppr b)+        }+      else do+    { traceVt "[Vanilla]" $ vcat [ppr var <+> char '=' <+> ppr expr | (var, expr) <- binds]++       -- For all bindings *with* a pragma, just use the pragma-supplied vectorised expression+    ; newBindsWPragma  <- concat <$>+                          sequence [ vectTopBindAndConvert bind inlineMe expr'+                                   | (bind, (_, Just (_, expr'))) <- zip binds vectDecls]++        -- Standard vectorisation of all rhses that are *without* a pragma.+        -- NB: The reason for 'fixV' is rather subtle: 'vectTopBindAndConvert' adds entries for+        --     the bound variables in the recursive group to the vectorisation map, which in turn+        --     are needed by 'vectPolyExprs' (unless it returns 'Nothing').+    ; let bindsWOPragma = [bind | (bind, (_, Nothing)) <- zip binds vectDecls]+    ; (newBinds, _) <- fixV $+        \ ~(_, exprs') ->+          do+          {   -- Create appropriate top-level bindings, enter them into the vectorisation map, and+              -- vectorise the right-hand sides+          ; newBindsWOPragma <- concat <$>+                                sequence [vectTopBindAndConvert bind inline expr+                                         | (bind, ~(inline, expr)) <- zipLazy bindsWOPragma exprs']+                                         -- irrefutable pattern and 'zipLazy' to tie the knot;+                                         -- hence, can't use 'zipWithM'+          ; vectRhses <- vectTopExprs bindsWOPragma+          ; hs <- takeHoisted -- make sure we clean those out (even if we skip)++          ; case vectRhses of+              Nothing ->+                -- scalar bindings => skip all bindings except those with pragmas and retract the+                --   entries into the vectorisation map for the scalar bindings+                do+                { traceVt "scalar bindings [skip]" $ ppr vars+                ; mapM_ (undefGlobalVar . fst) bindsWOPragma+                ; return (bindsWOPragma ++ newBindsWPragma, exprs')+                }+              Just (parBind, exprs') ->+                -- vanilla case => record parallel variables and return the final bindings+                do+                { when parBind $+                    mapM_ addGlobalParallelVar vars+                ; return (newBindsWOPragma ++ newBindsWPragma ++ hs, exprs')+                }+          }+    ; return $ Rec newBinds+    } } }+    `orElseErrV`+    do+    { emitVt "  Could NOT vectorise top-level bindings" $ ppr vars+    ; return b+    }+  where+    vars = map fst binds+    noVectoriseErr = "NOVECTORISE must be used on all or no bindings of a recursive group"++    -- Replace the original top-level bindings by a values projected from the vectorised+    -- closures and add any newly created hoisted top-level bindings to the group.+    vectTopBindAndConvert (var, expr) inline expr'+      = do+        { var'  <- vectTopBinder var inline expr'+        ; cexpr <- tryConvert var var' expr+        ; return [(var, cexpr), (var', expr')]+        }++-- Add a vectorised binding to an imported top-level variable that has a VECTORISE pragma+-- in this module.+--+-- RESTRICTION: Currently, we cannot use the pragma for mutually recursive definitions.+--+vectImpBind :: (Id, CoreExpr) -> VM CoreBind+vectImpBind (var, expr)+  = do+    { traceVt "= Add vectorised binding to imported variable" (ppr var)++    ; var' <- vectTopBinder var inlineMe expr+    ; return $ NonRec var' expr+    }++-- |Make the vectorised version of this top level binder, and add the mapping between it and the+-- original to the state. For some binder @foo@ the vectorised version is @$v_foo@+--+-- NOTE: 'vectTopBinder' *MUST* be lazy in inline and expr because of how it is used inside of+--       'fixV' in 'vectTopBind'.+--+vectTopBinder :: Var      -- ^ Name of the binding.+              -> Inline   -- ^ Whether it should be inlined, used to annotate it.+              -> CoreExpr -- ^ RHS of binding, used to set the 'Unfolding' of the returned 'Var'.+              -> VM Var   -- ^ Name of the vectorised binding.+vectTopBinder var inline expr+ = do {   -- Vectorise the type attached to the var.+      ; vty  <- vectType (idType var)++          -- If there is a vectorisation declaration for this binding, make sure its type matches+      ; (_, vectDecl) <- lookupVectDecl var+      ; case vectDecl of+          Nothing             -> return ()+          Just (vdty, _)+            | eqType vty vdty -> return ()+            | otherwise       ->+              do+              { dflags <- getDynFlags+              ; cantVectorise dflags ("Type mismatch in vectorisation pragma for " ++ showPpr dflags var) $+                  (text "Expected type" <+> ppr vty)+                  $$+                  (text "Inferred type" <+> ppr vdty)+              }+          -- Make the vectorised version of binding's name, and set the unfolding used for inlining+      ; var' <- liftM (`setIdUnfolding` unfolding)+                $  mkVectId var vty++          -- Add the mapping between the plain and vectorised name to the state.+      ; defGlobalVar var var'++      ; return var'+    }+  where+    unfolding = case inline of+                  Inline arity -> mkInlineUnfoldingWithArity arity expr+                  DontInline   -> noUnfolding+{-+!!!TODO: dfuns and unfoldings:+           -- Do not inline the dfun; instead give it a magic DFunFunfolding+           -- See Note [ClassOp/DFun selection]+           -- See also note [Single-method classes]+        dfun_id_w_fun+           | isNewTyCon class_tc+           = dfun_id `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }+           | otherwise+           = dfun_id `setIdUnfolding`  mkDFunUnfolding dfun_ty dfun_args+                     `setInlinePragma` dfunInlinePragma+ -}++-- |Project out the vectorised version of a binding from some closure, or return the original body+-- if that doesn't work.+--+tryConvert :: Var       -- ^Name of the original binding (eg @foo@)+           -> Var       -- ^Name of vectorised version of binding (eg @$vfoo@)+           -> CoreExpr  -- ^The original body of the binding.+           -> VM CoreExpr+tryConvert var vect_var rhs+  = fromVect (idType var) (Var vect_var)+    `orElseErrV`+    do+    { emitVt "  Could NOT call vectorised from original version" $ ppr var <+> dcolon <+> ppr (idType var)+    ; return rhs+    }
+ vectorise/Vectorise/Builtins.hs view
@@ -0,0 +1,35 @@+-- Types and functions declared in 'Data.Array.Parallel.Prim' and used by the vectoriser.+--+-- The @Builtins@ structure holds the name of all the things in 'Data.Array.Parallel.Prim' that+-- appear in code generated by the vectoriser.++module Vectorise.Builtins (+  -- * Restrictions+  mAX_DPH_SCALAR_ARGS,++  -- * Builtins+  Builtins(..),++  -- * Wrapped selectors+  selTy, selsTy,+  selReplicate,+  selTags,+  selElements,+  selsLength,+  sumTyCon,+  prodTyCon,+  prodDataCon,+  replicatePD_PrimVar,+  emptyPD_PrimVar,+  packByTagPD_PrimVar,+  combinePDVar,+  combinePD_PrimVar,+  scalarZip,+  closureCtrFun,++  -- * Initialisation+  initBuiltins, initBuiltinVars,+) where++import Vectorise.Builtins.Base+import Vectorise.Builtins.Initialise
+ vectorise/Vectorise/Builtins/Base.hs view
@@ -0,0 +1,217 @@+-- |Builtin types and functions used by the vectoriser. These are all defined in+-- 'Data.Array.Parallel.Prim'.++module Vectorise.Builtins.Base (+  -- * Hard config+  mAX_DPH_PROD,+  mAX_DPH_SUM,+  mAX_DPH_COMBINE,+  mAX_DPH_SCALAR_ARGS,+  aLL_DPH_PRIM_TYCONS,++  -- * Builtins+  Builtins(..),++  -- * Projections+  selTy, selsTy,+  selReplicate,+  selTags,+  selElements,+  selsLength,+  sumTyCon,+  prodTyCon,+  prodDataCon,+  replicatePD_PrimVar,+  emptyPD_PrimVar,+  packByTagPD_PrimVar,+  combinePDVar,+  combinePD_PrimVar,+  scalarZip,+  closureCtrFun+) where++import TysPrim+import BasicTypes+import Class+import CoreSyn+import TysWiredIn hiding (sumTyCon)+import Type+import TyCon+import DataCon+import NameEnv+import Name+import Outputable++import Data.Array+++-- Cardinality of the various families of types and functions exported by the DPH library.++mAX_DPH_PROD :: Int+mAX_DPH_PROD = 5++mAX_DPH_SUM :: Int+mAX_DPH_SUM = 2++mAX_DPH_COMBINE :: Int+mAX_DPH_COMBINE = 2++mAX_DPH_SCALAR_ARGS :: Int+mAX_DPH_SCALAR_ARGS = 8++-- Types from 'GHC.Prim' supported by DPH+--+aLL_DPH_PRIM_TYCONS :: [Name]+aLL_DPH_PRIM_TYCONS = map tyConName [intPrimTyCon, {- floatPrimTyCon, -} doublePrimTyCon]+++-- |Holds the names of the types and functions from 'Data.Array.Parallel.Prim' that are used by the+-- vectoriser.+--+data Builtins+        = Builtins+        { parrayTyCon          :: TyCon                     -- ^ PArray+        , pdataTyCon           :: TyCon                     -- ^ PData+        , pdatasTyCon          :: TyCon                     -- ^ PDatas+        , prClass              :: Class                     -- ^ PR+        , prTyCon              :: TyCon                     -- ^ PR+        , preprTyCon           :: TyCon                     -- ^ PRepr+        , paClass              :: Class                     -- ^ PA+        , paTyCon              :: TyCon                     -- ^ PA+        , paDataCon            :: DataCon                   -- ^ PA+        , paPRSel              :: Var                       -- ^ PA+        , replicatePDVar       :: Var                       -- ^ replicatePD+        , replicatePD_PrimVars :: NameEnv Var               -- ^ replicatePD_Int# etc.+        , emptyPDVar           :: Var                       -- ^ emptyPD+        , emptyPD_PrimVars     :: NameEnv Var               -- ^ emptyPD_Int# etc.+        , packByTagPDVar       :: Var                       -- ^ packByTagPD+        , packByTagPD_PrimVars :: NameEnv Var               -- ^ packByTagPD_Int# etc.+        , combinePDVars        :: Array Int Var             -- ^ combinePD+        , combinePD_PrimVarss  :: Array Int (NameEnv Var)   -- ^ combine2PD_Int# etc.+        , scalarClass          :: Class                     -- ^ Scalar+        , scalarZips           :: Array Int Var             -- ^ map, zipWith, zipWith3+        , voidTyCon            :: TyCon                     -- ^ Void+        , voidVar              :: Var                       -- ^ void+        , fromVoidVar          :: Var                       -- ^ fromVoid+        , sumTyCons            :: Array Int TyCon           -- ^ Sum2 .. Sum3+        , wrapTyCon            :: TyCon                     -- ^ Wrap+        , pvoidVar             :: Var                       -- ^ pvoid+        , pvoidsVar            :: Var                       -- ^ pvoids+        , closureTyCon         :: TyCon                     -- ^ :->+        , closureVar           :: Var                       -- ^ closure+        , liftedClosureVar     :: Var                       -- ^ liftedClosure+        , applyVar             :: Var                       -- ^ $:+        , liftedApplyVar       :: Var                       -- ^ liftedApply+        , closureCtrFuns       :: Array Int Var             -- ^ closure1 .. closure3+        , selTys               :: Array Int Type            -- ^ Sel2+        , selsTys              :: Array Int Type            -- ^ Sels2+        , selsLengths          :: Array Int CoreExpr        -- ^ lengthSels2+        , selReplicates        :: Array Int CoreExpr        -- ^ replicate2+        , selTagss             :: Array Int CoreExpr        -- ^ tagsSel2+        , selElementss         :: Array (Int, Int) CoreExpr -- ^ elementsSel2_0 .. elementsSel_2_1+        , liftingContext       :: Var                       -- ^ lc+        }+++-- Projections ----------------------------------------------------------------+-- We use these wrappers instead of indexing the `Builtin` structure directly+-- because they give nicer panic messages if the indexed thing cannot be found.++selTy :: Int -> Builtins -> Type+selTy           = indexBuiltin "selTy" selTys++selsTy :: Int -> Builtins -> Type+selsTy          = indexBuiltin "selsTy" selsTys++selsLength :: Int -> Builtins -> CoreExpr+selsLength      = indexBuiltin "selLength" selsLengths++selReplicate :: Int -> Builtins -> CoreExpr+selReplicate    = indexBuiltin "selReplicate" selReplicates++selTags :: Int -> Builtins -> CoreExpr+selTags         = indexBuiltin "selTags" selTagss++selElements :: Int -> Int -> Builtins -> CoreExpr+selElements i j = indexBuiltin "selElements" selElementss (i, j)++sumTyCon :: Int -> Builtins -> TyCon+sumTyCon        = indexBuiltin "sumTyCon" sumTyCons++prodTyCon :: Int -> Builtins -> TyCon+prodTyCon n _+  | n >= 2 && n <= mAX_DPH_PROD+  = tupleTyCon Boxed n+  | otherwise+  = pprPanic "prodTyCon" (ppr n)++prodDataCon :: Int -> Builtins -> DataCon+prodDataCon n bi+ = case tyConDataCons (prodTyCon n bi) of+    [con] -> con+    _ -> pprPanic "prodDataCon" (ppr n)++replicatePD_PrimVar :: TyCon -> Builtins -> Var+replicatePD_PrimVar tc bi+  = lookupEnvBuiltin "replicatePD_PrimVar" (replicatePD_PrimVars bi) (tyConName tc)++emptyPD_PrimVar :: TyCon -> Builtins -> Var+emptyPD_PrimVar tc bi+  = lookupEnvBuiltin "emptyPD_PrimVar" (emptyPD_PrimVars bi) (tyConName tc)++packByTagPD_PrimVar :: TyCon -> Builtins -> Var+packByTagPD_PrimVar tc bi+  = lookupEnvBuiltin "packByTagPD_PrimVar" (packByTagPD_PrimVars bi) (tyConName tc)++combinePDVar :: Int -> Builtins -> Var+combinePDVar = indexBuiltin "combinePDVar" combinePDVars++combinePD_PrimVar :: Int -> TyCon -> Builtins -> Var+combinePD_PrimVar i tc bi+  = lookupEnvBuiltin "combinePD_PrimVar"+      (indexBuiltin "combinePD_PrimVar" combinePD_PrimVarss i bi) (tyConName tc)++scalarZip :: Int -> Builtins -> Var+scalarZip = indexBuiltin "scalarZip" scalarZips++closureCtrFun :: Int -> Builtins -> Var+closureCtrFun = indexBuiltin "closureCtrFun" closureCtrFuns++-- | Get an element from one of the arrays of `Builtins`.+--   Panic if the indexed thing is not in the array.+indexBuiltin :: (Ix i, Outputable i)+             => String                   -- ^ Name of the selector we've used, for panic messages.+             -> (Builtins -> Array i a)  -- ^ Field selector for the `Builtins`.+             -> i                        -- ^ Index into the array.+             -> Builtins+             -> a+indexBuiltin fn f i bi+  | inRange (bounds xs) i = xs ! i+  | otherwise+  = pprSorry "Vectorise.Builtins.indexBuiltin"+    (vcat [ text ""+    , text "DPH builtin function '" <> text fn <> text "' of size '" <> ppr i <>+      text "' is not yet implemented."+    , text "This function does not appear in your source program, but it is needed"+    , text "to compile your code in the backend. This is a known, current limitation"+    , text "of DPH. If you want it to work, you should send mail to ghc-commits@haskell.org"+    , text "and ask what you can do to help (it might involve some GHC hacking)."])+  where xs = f bi+++-- | Get an entry from one of a 'NameEnv' of `Builtins`. Panic if the named item is not in the array.+lookupEnvBuiltin :: String                    -- Function name for error messages+                 -> NameEnv a                 -- Name environment+                 -> Name                      -- Index into the name environment+                 -> a+lookupEnvBuiltin fn env n+  | Just r <- lookupNameEnv env n = r+  | otherwise+  = pprSorry "Vectorise.Builtins.lookupEnvBuiltin"+    (vcat [ text ""+    , text "DPH builtin function '" <> text fn <> text "_" <> ppr n <>+      text "' is not yet implemented."+    , text "This function does not appear in your source program, but it is needed"+    , text "to compile your code in the backend. This is a known, current limitation"+    , text "of DPH. If you want it to work, you should send mail to ghc-commits@haskell.org"+    , text "and ask what you can do to help (it might involve some GHC hacking)."])
+ vectorise/Vectorise/Builtins/Initialise.hs view
@@ -0,0 +1,232 @@+-- Set up the data structures provided by 'Vectorise.Builtins'.++module Vectorise.Builtins.Initialise (+  -- * Initialisation+  initBuiltins, initBuiltinVars+) where++import Vectorise.Builtins.Base++import BasicTypes+import TysPrim+import DsMonad+import TysWiredIn+import DataCon+import TyCon+import Class+import CoreSyn+import Type+import NameEnv+import Name+import Id+import FastString+import Outputable++import Control.Monad+import Data.Array+++-- |Create the initial map of builtin types and functions.+--+initBuiltins :: DsM Builtins+initBuiltins+ = do {   -- 'PArray: representation type for parallel arrays+      ; parrayTyCon <- externalTyCon (fsLit "PArray")++          -- 'PData': type family mapping array element types to array representation types+          -- Not all backends use `PDatas`.+      ; pdataTyCon  <- externalTyCon (fsLit "PData")+      ; pdatasTyCon <- externalTyCon (fsLit "PDatas")++          -- 'PR': class of basic array operators operating on 'PData' types+      ; prClass     <- externalClass (fsLit "PR")+      ; let prTyCon     = classTyCon prClass++          -- 'PRepr': type family mapping element types to representation types+      ; preprTyCon  <- externalTyCon (fsLit "PRepr")++          -- 'PA': class of basic operations on arrays (parametrised by the element type)+      ; paClass     <- externalClass (fsLit "PA")+      ; let paTyCon     = classTyCon paClass+            [paDataCon] = tyConDataCons paTyCon+            paPRSel     = classSCSelId paClass 0++          -- Functions on array representations+      ; replicatePDVar <- externalVar (fsLit "replicatePD")+      ; replicate_vars <- mapM externalVar (suffixed "replicatePA" aLL_DPH_PRIM_TYCONS)+      ; emptyPDVar     <- externalVar (fsLit "emptyPD")+      ; empty_vars     <- mapM externalVar (suffixed "emptyPA" aLL_DPH_PRIM_TYCONS)+      ; packByTagPDVar <- externalVar (fsLit "packByTagPD")+      ; packByTag_vars <- mapM externalVar (suffixed "packByTagPA" aLL_DPH_PRIM_TYCONS)+      ; let combineNamesD = [("combine" ++ show i ++ "PD") | i <- [2..mAX_DPH_COMBINE]]+      ; let combineNamesA = [("combine" ++ show i ++ "PA") | i <- [2..mAX_DPH_COMBINE]]+      ; combines       <- mapM externalVar (map mkFastString combineNamesD)+      ; combines_vars  <- mapM (mapM externalVar) $+                            map (\name -> suffixed name aLL_DPH_PRIM_TYCONS) combineNamesA+      ; let replicatePD_PrimVars = mkNameEnv (zip aLL_DPH_PRIM_TYCONS replicate_vars)+            emptyPD_PrimVars     = mkNameEnv (zip aLL_DPH_PRIM_TYCONS empty_vars)+            packByTagPD_PrimVars = mkNameEnv (zip aLL_DPH_PRIM_TYCONS packByTag_vars)+            combinePDVars        = listArray (2, mAX_DPH_COMBINE) combines+            combinePD_PrimVarss  = listArray (2, mAX_DPH_COMBINE)+                                     [ mkNameEnv (zip aLL_DPH_PRIM_TYCONS vars)+                                     | vars <- combines_vars]++          -- 'Scalar': class moving between plain unboxed arrays and 'PData' representations+      ; scalarClass <- externalClass (fsLit "Scalar")++          -- N-ary maps ('zipWith' family)+      ; scalar_map       <- externalVar (fsLit "scalar_map")+      ; scalar_zip2      <- externalVar (fsLit "scalar_zipWith")+      ; scalar_zips      <- mapM externalVar (numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS)+      ; let scalarZips   = listArray (1, mAX_DPH_SCALAR_ARGS)+                                     (scalar_map : scalar_zip2 : scalar_zips)++          -- Types and functions for generic type representations+      ; voidTyCon        <- externalTyCon (fsLit "Void")+      ; voidVar          <- externalVar   (fsLit "void")+      ; fromVoidVar      <- externalVar   (fsLit "fromVoid")+      ; sum_tcs          <- mapM externalTyCon (numbered "Sum" 2 mAX_DPH_SUM)+      ; let sumTyCons    = listArray (2, mAX_DPH_SUM) sum_tcs+      ; wrapTyCon        <- externalTyCon (fsLit "Wrap")+      ; pvoidVar         <- externalVar   (fsLit "pvoid")+      ; pvoidsVar        <- externalVar   (fsLit "pvoids#")++          -- Types and functions for closure conversion+      ; closureTyCon     <- externalTyCon (fsLit ":->")+      ; closureVar       <- externalVar   (fsLit "closure")+      ; liftedClosureVar <- externalVar   (fsLit "liftedClosure")+      ; applyVar         <- externalVar   (fsLit "$:")+      ; liftedApplyVar   <- externalVar   (fsLit "liftedApply")+      ; closures         <- mapM externalVar (numbered "closure" 1 mAX_DPH_SCALAR_ARGS)+      ; let closureCtrFuns = listArray (1, mAX_DPH_SCALAR_ARGS) closures++          -- Types and functions for selectors+      ; sel_tys          <- mapM externalType (numbered "Sel"  2 mAX_DPH_SUM)+      ; sels_tys         <- mapM externalType (numbered "Sels" 2 mAX_DPH_SUM)+      ; sels_length      <- mapM externalFun  (numbered_hash "lengthSels"   2 mAX_DPH_SUM)+      ; sel_replicates   <- mapM externalFun  (numbered_hash "replicateSel" 2 mAX_DPH_SUM)+      ; sel_tags         <- mapM externalFun  (numbered "tagsSel" 2 mAX_DPH_SUM)+      ; sel_elements     <- mapM mk_elements [(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]]+      ; let selTys        = listArray (2, mAX_DPH_SUM) sel_tys+            selsTys       = listArray (2, mAX_DPH_SUM) sels_tys+            selsLengths   = listArray (2, mAX_DPH_SUM) sels_length+            selReplicates = listArray (2, mAX_DPH_SUM) sel_replicates+            selTagss      = listArray (2, mAX_DPH_SUM) sel_tags+            selElementss  = array     ((2, 0), (mAX_DPH_SUM, mAX_DPH_SUM)) sel_elements++          -- Distinct local variable+      ; liftingContext  <- liftM (\u -> mkSysLocalOrCoVar (fsLit "lc") u intPrimTy) newUnique++      ; return $ Builtins+               { parrayTyCon          = parrayTyCon+               , pdataTyCon           = pdataTyCon+               , pdatasTyCon          = pdatasTyCon+               , preprTyCon           = preprTyCon+               , prClass              = prClass+               , prTyCon              = prTyCon+               , paClass              = paClass+               , paTyCon              = paTyCon+               , paDataCon            = paDataCon+               , paPRSel              = paPRSel+               , replicatePDVar       = replicatePDVar+               , replicatePD_PrimVars = replicatePD_PrimVars+               , emptyPDVar           = emptyPDVar+               , emptyPD_PrimVars     = emptyPD_PrimVars+               , packByTagPDVar       = packByTagPDVar+               , packByTagPD_PrimVars = packByTagPD_PrimVars+               , combinePDVars        = combinePDVars+               , combinePD_PrimVarss  = combinePD_PrimVarss+               , scalarClass          = scalarClass+               , scalarZips           = scalarZips+               , voidTyCon            = voidTyCon+               , voidVar              = voidVar+               , fromVoidVar          = fromVoidVar+               , sumTyCons            = sumTyCons+               , wrapTyCon            = wrapTyCon+               , pvoidVar             = pvoidVar+               , pvoidsVar            = pvoidsVar+               , closureTyCon         = closureTyCon+               , closureVar           = closureVar+               , liftedClosureVar     = liftedClosureVar+               , applyVar             = applyVar+               , liftedApplyVar       = liftedApplyVar+               , closureCtrFuns       = closureCtrFuns+               , selTys               = selTys+               , selsTys              = selsTys+               , selsLengths          = selsLengths+               , selReplicates        = selReplicates+               , selTagss             = selTagss+               , selElementss         = selElementss+               , liftingContext       = liftingContext+               }+      }+  where+    suffixed :: String -> [Name] -> [FastString]+    suffixed pfx ns = [mkFastString (pfx ++ "_" ++ (occNameString . nameOccName) n) | n <- ns]++    -- Make a list of numbered strings in some range, eg foo3, foo4, foo5+    numbered :: String -> Int -> Int -> [FastString]+    numbered pfx m n = [mkFastString (pfx ++ show i) | i <- [m..n]]++    numbered_hash :: String -> Int -> Int -> [FastString]+    numbered_hash pfx m n = [mkFastString (pfx ++ show i ++ "#") | i <- [m..n]]++    mk_elements :: (Int, Int) -> DsM ((Int, Int), CoreExpr)+    mk_elements (i,j)+      = do { v <- externalVar $ mkFastString ("elementsSel" ++ show i ++ "_" ++ show j ++ "#")+           ; return ((i, j), Var v)+           }++-- |Get the mapping of names in the Prelude to names in the DPH library.+--+initBuiltinVars :: Builtins -> DsM [(Var, Var)]+-- FIXME: must be replaced by VECTORISE pragmas!!!+initBuiltinVars (Builtins { })+  = do+      cvars <- mapM externalVar cfs+      return $ zip (map dataConWorkId cons) cvars+  where+    (cons, cfs) = unzip preludeDataCons++    preludeDataCons :: [(DataCon, FastString)]+    preludeDataCons+      = [mk_tup n (mkFastString $ "tup" ++ show n) | n <- [2..5]]+      where+        mk_tup n name = (tupleDataCon Boxed n, name)+++-- Auxiliary look up functions -----------------------------------------------++-- |Lookup a variable given its name and the module that contains it.+externalVar :: FastString -> DsM Var+externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId+++-- |Like `externalVar` but wrap the `Var` in a `CoreExpr`.+externalFun :: FastString -> DsM CoreExpr+externalFun fs = Var <$> externalVar fs+++-- |Lookup a 'TyCon' in 'Data.Array.Parallel.Prim', given its name.+--  Panic if there isn't one.+externalTyCon :: FastString -> DsM TyCon+externalTyCon fs = dsLookupDPHRdrEnv (mkTcOccFS fs) >>= dsLookupTyCon+++-- |Lookup some `Type` in 'Data.Array.Parallel.Prim', given its name.+externalType :: FastString -> DsM Type+externalType fs+ = do  tycon <- externalTyCon fs+       return $ mkTyConApp tycon []+++-- |Lookup a 'Class' in 'Data.Array.Parallel.Prim', given its name.+externalClass :: FastString -> DsM Class+externalClass fs+  = do { tycon <- dsLookupDPHRdrEnv (mkClsOccFS fs) >>= dsLookupTyCon+       ; case tyConClass_maybe tycon of+           Nothing  -> pprPanic "Vectorise.Builtins.Initialise" $+                         text "Data.Array.Parallel.Prim." <>+                         ftext fs <+> text "is not a type class"+           Just cls -> return cls+       }
+ vectorise/Vectorise/Convert.hs view
@@ -0,0 +1,105 @@+module Vectorise.Convert+  ( fromVect+  )+where++import Vectorise.Monad+import Vectorise.Builtins+import Vectorise.Type.Type++import CoreSyn+import TyCon+import Type+import TyCoRep+import NameSet+import FastString+import Outputable++import Control.Applicative+import Prelude -- avoid redundant import warning due to AMP++-- |Convert a vectorised expression such that it computes the non-vectorised equivalent of its+-- value.+--+-- For functions, we eta expand the function and convert the arguments and result:++-- For example+-- @+--    \(x :: Double) ->+--    \(y :: Double) ->+--    ($v_foo $: x) $: y+-- @+--+-- We use the type of the original binding to work out how many outer lambdas to add.+--+fromVect :: Type        -- ^ The type of the original binding.+         -> CoreExpr    -- ^ Expression giving the closure to use, eg @$v_foo@.+         -> VM CoreExpr++-- Convert the type to the core view if it isn't already.+--+fromVect ty expr+  | Just ty' <- coreView ty+  = fromVect ty' expr++-- For each function constructor in the original type we add an outer+-- lambda to bind the parameter variable, and an inner application of it.+fromVect (FunTy arg_ty res_ty) expr+  = do+      arg     <- newLocalVar (fsLit "x") arg_ty+      varg    <- toVect arg_ty (Var arg)+      varg_ty <- vectType arg_ty+      vres_ty <- vectType res_ty+      apply   <- builtin applyVar+      body    <- fromVect res_ty+               $ Var apply `mkTyApps` [varg_ty, vres_ty] `mkApps` [expr, varg]+      return $ Lam arg body++-- If the type isn't a function, then we can't current convert it unless the type is scalar (i.e.,+-- is identical to the non-vectorised version).+--+fromVect ty expr+  = identityConv ty >> return expr++-- Convert an expression such that it evaluates to the vectorised equivalent of the value of the+-- original expression.+--+-- WARNING: Currently only works for the scalar types, where the vectorised value coincides with the+--          original one.+--+toVect :: Type -> CoreExpr -> VM CoreExpr+toVect ty expr = identityConv ty >> return expr++-- |Check that the type is neutral under type vectorisation — i.e., all involved type constructor+-- are not altered by vectorisation as they contain no parallel arrays.+--+identityConv :: Type -> VM ()+identityConv ty+  | Just ty' <- coreView ty+  = identityConv ty'+identityConv (TyConApp tycon tys)+  = do { mapM_ identityConv tys+       ; identityConvTyCon tycon+       }+identityConv (LitTy {})      = noV $ text "identityConv: not sure about literal types under vectorisation"+identityConv (TyVarTy {})    = noV $ text "identityConv: type variable changes under vectorisation"+identityConv (AppTy {})      = noV $ text "identityConv: type appl. changes under vectorisation"+identityConv (FunTy {})      = noV $ text "identityConv: function type changes under vectorisation"+identityConv (ForAllTy {})   = noV $ text "identityConv: quantified type changes under vectorisation"+identityConv (CastTy {})     = noV $ text "identityConv: not sure about casted types under vectorisation"+identityConv (CoercionTy {}) = noV $ text "identityConv: not sure about coercions under vectorisation"++-- |Check that this type constructor is not changed by vectorisation — i.e., it does not embed any+-- parallel arrays.+--+identityConvTyCon :: TyCon -> VM ()+identityConvTyCon tc+  = do+    { isParallel <- (tyConName tc `elemNameSet`) <$> globalParallelTyCons+    ; parray     <- builtin parrayTyCon+    ; if isParallel && not (tc == parray)+      then noV idErr+      else return ()+    }+  where+    idErr = text "identityConvTyCon: type constructor contains parallel arrays" <+> ppr tc
+ vectorise/Vectorise/Env.hs view
@@ -0,0 +1,238 @@+module Vectorise.Env (+  Scope(..),++  -- * Local Environments+  LocalEnv(..),+  emptyLocalEnv,++  -- * Global Environments+  GlobalEnv(..),+  initGlobalEnv,+  extendImportedVarsEnv,+  extendFamEnv,+  setPAFunsEnv,+  setPRFunsEnv,+  modVectInfo+) where++import HscTypes+import InstEnv+import FamInstEnv+import CoreSyn+import Type+import Class+import TyCon+import DataCon+import VarEnv+import VarSet+import Var+import NameSet+import Name+import NameEnv+import FastString+import UniqDFM+import UniqSet+++import Data.Maybe+++-- |Indicates what scope something (a variable) is in.+--+data Scope a b+        = Global a+        | Local  b+++-- LocalEnv -------------------------------------------------------------------++-- |The local environment.+--+data LocalEnv+        = LocalEnv+        { local_vars      :: VarEnv (Var, Var)+          -- ^Mapping from local variables to their vectorised and lifted versions.++        , local_tyvars     :: [TyVar]+          -- ^In-scope type variables.++        , local_tyvar_pa   :: VarEnv CoreExpr+          -- ^Mapping from tyvars to their PA dictionaries.++        , local_bind_name  :: FastString+          -- ^Local binding name. This is only used to generate better names for hoisted+          -- expressions.+        }++-- |Create an empty local environment.+--+emptyLocalEnv :: LocalEnv+emptyLocalEnv = LocalEnv+                { local_vars      = emptyVarEnv+                , local_tyvars    = []+                , local_tyvar_pa  = emptyVarEnv+                , local_bind_name = fsLit "fn"+                }+++-- GlobalEnv ------------------------------------------------------------------++-- |The global environment: entities that exist at top-level.+--+data GlobalEnv+        = GlobalEnv+        { global_vect_avoid           :: Bool+          -- ^'True' implies to avoid vectorisation as far as possible.++        , global_vars                 :: VarEnv Var+          -- ^Mapping from global variables to their vectorised versions — aka the /vectorisation+          -- map/.++        , global_parallel_vars        :: DVarSet+          -- ^The domain of 'global_vars'.+          --+          -- This information is not redundant as it is impossible to extract the domain from a+          -- 'VarEnv' (which is keyed on uniques alone). Moreover, we have mapped variables that+          -- do not involve parallelism — e.g., the workers of vectorised, but scalar data types.+          -- In addition, workers of parallel data types that we could not vectorise also need to+          -- be tracked.++        , global_vect_decls           :: VarEnv (Maybe (Type, CoreExpr))+          -- ^Mapping from global variables that have a vectorisation declaration to the right-hand+          -- side of that declaration and its type and mapping variables that have NOVECTORISE+          -- declarations to 'Nothing'.++        , global_tycons               :: NameEnv TyCon+          -- ^Mapping from TyCons to their vectorised versions. The vectorised version will be+          -- identical to the original version if it is not changed by vectorisation. In any case,+          -- if a tycon appears in the domain of this mapping, it was successfully vectorised.++        , global_parallel_tycons      :: NameSet+          -- ^Type constructors whose definition directly or indirectly includes a parallel type,+          -- such as '[::]'.+          --+          -- NB: This information is not redundant as some types have got a mapping in+          --     'global_tycons' (to a type other than themselves) and are still not parallel. An+          --     example is '(->)'. Moreover, some types have *not* got a mapping in 'global_tycons'+          --     (because they couldn't be vectorised), but still contain parallel types.++        , global_datacons             :: NameEnv DataCon+          -- ^Mapping from DataCons to their vectorised versions.++        , global_pa_funs              :: NameEnv Var+          -- ^Mapping from TyCons to their PA dfuns.++        , global_pr_funs              :: NameEnv Var+          -- ^Mapping from TyCons to their PR dfuns.++        , global_inst_env             :: InstEnvs+          -- ^External package inst-env & home-package inst-env for class instances.++        , global_fam_inst_env         :: FamInstEnvs+          -- ^External package inst-env & home-package inst-env for family instances.++        , global_bindings             :: [(Var, CoreExpr)]+          -- ^Hoisted bindings — temporary storage for toplevel bindings during code gen.+        }++-- |Create an initial global environment.+--+-- We add scalar variables and type constructors identified by vectorisation pragmas already here+-- to the global table, so that we can query scalarness during vectorisation, and especially, when+-- vectorising the scalar entities' definitions themselves.+--+initGlobalEnv :: Bool+              -> VectInfo+              -> [CoreVect]+              -> InstEnvs+              -> FamInstEnvs+              -> GlobalEnv+initGlobalEnv vectAvoid info vectDecls instEnvs famInstEnvs+  = GlobalEnv+  { global_vect_avoid           = vectAvoid+  , global_vars                 = mapVarEnv snd $ udfmToUfm $ vectInfoVar info+  , global_vect_decls           = mkVarEnv vects+  , global_parallel_vars        = vectInfoParallelVars info+  , global_parallel_tycons      = vectInfoParallelTyCons info+  , global_tycons               = mapNameEnv snd $ vectInfoTyCon info+  , global_datacons             = mapNameEnv snd $ vectInfoDataCon info+  , global_pa_funs              = emptyNameEnv+  , global_pr_funs              = emptyNameEnv+  , global_inst_env             = instEnvs+  , global_fam_inst_env         = famInstEnvs+  , global_bindings             = []+  }+  where+    vects         = [(var, Just (ty, exp)) | Vect   var   exp@(Var rhs_var) <- vectDecls+                                           , let ty = varType rhs_var] +++                                        -- FIXME: we currently only allow RHSes consisting of a+                                        --   single variable to be able to obtain the type without+                                        --   inference — see also 'TcBinds.tcVect'+                    [(var, Nothing)        | NoVect var                     <- vectDecls]+++-- Operators on Global Environments -------------------------------------------++-- |Extend the list of global variables in an environment.+--+extendImportedVarsEnv :: [(Var, Var)] -> GlobalEnv -> GlobalEnv+extendImportedVarsEnv ps genv+  = genv { global_vars = extendVarEnvList (global_vars genv) ps }++-- |Extend the list of type family instances.+--+extendFamEnv :: [FamInst] -> GlobalEnv -> GlobalEnv+extendFamEnv new genv+  = genv { global_fam_inst_env = (g_fam_inst, extendFamInstEnvList l_fam_inst new) }+  where (g_fam_inst, l_fam_inst) = global_fam_inst_env genv++-- |Set the list of PA functions in an environment.+--+setPAFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv+setPAFunsEnv ps genv = genv { global_pa_funs = mkNameEnv ps }++-- |Set the list of PR functions in an environment.+--+setPRFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv+setPRFunsEnv ps genv = genv { global_pr_funs = mkNameEnv ps }++-- |Compute vectorisation information that goes into 'ModGuts' (and is stored in interface files).+-- The incoming 'vectInfo' is that from the 'HscEnv' and 'EPS'.  The outgoing one contains only the+-- declarations for the currently compiled module; this includes variables, type constructors, and+-- data constructors referenced in VECTORISE pragmas, even if they are defined in an imported+-- module.+--+-- The variables explicitly include class selectors and dfuns.+--+modVectInfo :: GlobalEnv -> [Id] -> [TyCon] -> [CoreVect]-> VectInfo -> VectInfo+modVectInfo env mg_ids mg_tyCons vectDecls info+  = info+    { vectInfoVar            = mk_denv ids     (global_vars     env)+    , vectInfoTyCon          = mk_env tyCons   (global_tycons   env)+    , vectInfoDataCon        = mk_env dataCons (global_datacons env)+    , vectInfoParallelVars   = (global_parallel_vars   env `minusDVarSet`  vectInfoParallelVars   info)+                               `udfmIntersectUFM` (getUniqSet $ mkVarSet ids)+    , vectInfoParallelTyCons =  global_parallel_tycons env `minusNameSet` vectInfoParallelTyCons info+    }+  where+    vectIds         = [id    | Vect     id    _   <- vectDecls] +++                      [id    | VectInst id        <- vectDecls]+    vectTypeTyCons  = [tycon | VectType _ tycon _ <- vectDecls] +++                      [tycon | VectClass tycon    <- vectDecls]+    vectDataCons    = concatMap tyConDataCons vectTypeTyCons+    ids             = mg_ids ++ vectIds ++ dataConIds ++ selIds+    tyCons          = mg_tyCons ++ vectTypeTyCons+    dataCons        = concatMap tyConDataCons mg_tyCons ++ vectDataCons+    dataConIds      = map dataConWorkId dataCons+    selIds          = concat [ classAllSelIds cls+                             | tycon <- tyCons+                             , cls <- maybeToList . tyConClass_maybe $ tycon]++    -- Produce an entry for every declaration that is mentioned in the domain of the 'inspectedEnv'+    mk_env decls inspectedEnv = mkNameEnv $ mk_assoc_env decls inspectedEnv+    mk_denv decls inspectedEnv = listToUDFM $ mk_assoc_env decls inspectedEnv+    mk_assoc_env decls inspectedEnv+      = [(name, (decl, to))+        | decl     <- decls+        , let name = getName decl+        , Just to  <- [lookupNameEnv inspectedEnv name]]
+ vectorise/Vectorise/Exp.hs view
@@ -0,0 +1,1257 @@+{-# LANGUAGE CPP, TupleSections #-}++-- |Vectorisation of expressions.++module Vectorise.Exp+  (   -- * Vectorise right-hand sides of toplevel bindings+    vectTopExpr+  , vectTopExprs+  , vectScalarFun+  , vectScalarDFun+  )+where++#include "HsVersions.h"++import Vectorise.Type.Type+import Vectorise.Var+import Vectorise.Convert+import Vectorise.Vect+import Vectorise.Env+import Vectorise.Monad+import Vectorise.Builtins+import Vectorise.Utils++import CoreUtils+import MkCore+import CoreSyn+import CoreFVs+import Class+import DataCon+import TyCon+import TcType+import Type+import TyCoRep+import Var+import VarEnv+import VarSet+import NameSet+import Id+import BasicTypes( isStrongLoopBreaker )+import Literal+import TysPrim+import Outputable+import FastString+import DynFlags+import Util++import Control.Monad+import Data.Maybe+import Data.List+++-- Main entry point to vectorise expressions -----------------------------------++-- |Vectorise a polymorphic expression that forms a *non-recursive* binding.+--+-- Return 'Nothing' if the expression is scalar; otherwise, the first component of the result+-- (which is of type 'Bool') indicates whether the expression is parallel (i.e., whether it is+-- tagged as 'VIParr').+--+-- We have got the non-recursive case as a special case as it doesn't require to compute+-- vectorisation information twice.+--+vectTopExpr :: Var -> CoreExpr -> VM (Maybe (Bool, Inline, CoreExpr))+vectTopExpr var expr+  = do+    { exprVI <- encapsulateScalars <=< vectAvoidInfo emptyVarSet . freeVars $ expr+    ; if isVIEncaps exprVI+      then+        return Nothing+      else do+      { vExpr <- closedV $+                   inBind var $+                     vectAnnPolyExpr False exprVI+      ; inline <- computeInline exprVI+      ; return $ Just (isVIParr exprVI, inline, vectorised vExpr)+      }+    }++-- Compute the inlining hint for the right-hand side of a top-level binding.+--+computeInline :: CoreExprWithVectInfo -> VM Inline+computeInline ((_, VIDict), _)     = return $ DontInline+computeInline (_, AnnTick _ expr)  = computeInline expr+computeInline expr@(_, AnnLam _ _) = Inline <$> polyArity tvs+  where+    (tvs, _) = collectAnnTypeBinders expr+computeInline _expr                = return $ DontInline++-- |Vectorise a recursive group of top-level polymorphic expressions.+--+-- Return 'Nothing' if the expression group is scalar; otherwise, the first component of the result+-- (which is of type 'Bool') indicates whether the expressions are parallel (i.e., whether they are+-- tagged as 'VIParr').+--+vectTopExprs :: [(Var, CoreExpr)] -> VM (Maybe (Bool, [(Inline, CoreExpr)]))+vectTopExprs binds+  = do+    { exprVIs <- mapM (vectAvoidAndEncapsulate emptyVarSet) exprs+    ; if all isVIEncaps exprVIs+        -- if all bindings are scalar => don't vectorise this group of bindings+      then return Nothing+      else do+      {   -- non-scalar bindings need to be vectorised+      ; let areVIParr = any isVIParr exprVIs+      ; revised_exprVIs <- if not areVIParr+                             -- if no binding is parallel => 'exprVIs' is ready for vectorisation+                           then return exprVIs+                             -- if any binding is parallel => recompute the vectorisation info+                           else mapM (vectAvoidAndEncapsulate (mkVarSet vars)) exprs++      ; vExprs <- zipWithM vect vars revised_exprVIs+      ; return $ Just (areVIParr, vExprs)+      }+    }+  where+    (vars, exprs) = unzip binds++    vectAvoidAndEncapsulate pvs = encapsulateScalars <=< vectAvoidInfo pvs . freeVars++    vect var exprVI+      = do+        { vExpr  <- closedV $+                      inBind var $+                        vectAnnPolyExpr (isStrongLoopBreaker $ idOccInfo var) exprVI+        ; inline <- computeInline exprVI+        ; return (inline, vectorised vExpr)+        }++-- |Vectorise a polymorphic expression annotated with vectorisation information.+--+-- The special case of dictionary functions is currently handled separately. (Would be neater to+-- integrate them, though!)+--+vectAnnPolyExpr :: Bool -> CoreExprWithVectInfo -> VM VExpr+vectAnnPolyExpr loop_breaker (_, AnnTick tickish expr)+    -- traverse through ticks+  = vTick tickish <$> vectAnnPolyExpr loop_breaker expr+vectAnnPolyExpr loop_breaker expr+  | isVIDict expr+    -- special case the right-hand side of dictionary functions+  = (, undefined) <$> vectDictExpr (deAnnotate expr)+  | otherwise+    -- collect and vectorise type abstractions; then, descent into the body+  = polyAbstract tvs $ \args ->+      mapVect (mkLams $ tvs ++ args) <$> vectFnExpr False loop_breaker mono+  where+    (tvs, mono) = collectAnnTypeBinders expr++-- Encapsulate every purely sequential subexpression of a (potentially) parallel expression into a+-- lambda abstraction over all its free variables followed by the corresponding application to those+-- variables.  We can, then, avoid the vectorisation of the ensapsulated subexpressions.+--+-- Preconditions:+--+-- * All free variables and the result type must be /simple/ types.+-- * The expression is sufficiently complex (to warrant special treatment).  For now, that is+--   every expression that is not constant and contains at least one operation.+--+--+-- The user has an option to choose between aggressive and minimal vectorisation avoidance. With+-- minimal vectorisation avoidance, we only encapsulate individual scalar operations. With+-- aggressive vectorisation avoidance, we encapsulate subexpression that are as big as possible.+--+encapsulateScalars :: CoreExprWithVectInfo -> VM CoreExprWithVectInfo+encapsulateScalars ce@(_, AnnType _ty)+  = return ce+encapsulateScalars ce@((_, VISimple), AnnVar _v)+      -- NB: diverts from the paper: encapsulate scalar variables (including functions)+  = liftSimpleAndCase ce+encapsulateScalars ce@(_, AnnVar _v)+  = return ce+encapsulateScalars ce@(_, AnnLit _)+  = return ce+encapsulateScalars ((fvs, vi), AnnTick tck expr)+  = do+    { encExpr <- encapsulateScalars expr+    ; return ((fvs, vi), AnnTick tck encExpr)+    }+encapsulateScalars ce@((fvs, vi), AnnLam bndr expr)+  = do+    { vectAvoid <- isVectAvoidanceAggressive+    ; varsS     <- allScalarVarTypeSet fvs+        -- NB: diverts from the paper: we need to check the scalarness of bound variables as well,+        --     as 'vectScalarFun' will handle them just the same as those introduced for the 'fvs'+        --     by encapsulation.+    ; bndrsS    <- allScalarVarType bndrs+    ; case (vi, vectAvoid && varsS && bndrsS) of+        (VISimple, True) -> liftSimpleAndCase ce+        _                -> do+                            { encExpr <- encapsulateScalars expr+                            ; return ((fvs, vi), AnnLam bndr encExpr)+                            }+    }+  where+    (bndrs, _) = collectAnnBndrs ce+encapsulateScalars ce@((fvs, vi), AnnApp ce1 ce2)+  = do+    { vectAvoid <- isVectAvoidanceAggressive+    ; varsS     <- allScalarVarTypeSet fvs+    ; case (vi, (vectAvoid || isSimpleApplication ce) && varsS) of+        (VISimple, True) -> liftSimpleAndCase ce+        _                -> do+                            { encCe1 <- encapsulateScalars ce1+                            ; encCe2 <- encapsulateScalars ce2+                            ; return ((fvs, vi), AnnApp encCe1 encCe2)+                            }+    }+  where+    isSimpleApplication :: CoreExprWithVectInfo -> Bool+    isSimpleApplication (_, AnnTick _ ce)                 = isSimpleApplication ce+    isSimpleApplication (_, AnnCast ce _)                 = isSimpleApplication ce+    isSimpleApplication ce                  | isSimple ce = True+    isSimpleApplication (_, AnnApp ce1 ce2)               = isSimple ce1 && isSimpleApplication ce2+    isSimpleApplication _                                 = False+    --+    isSimple :: CoreExprWithVectInfo -> Bool+    isSimple (_, AnnType {})   = True+    isSimple (_, AnnVar  {})   = True+    isSimple (_, AnnLit  {})   = True+    isSimple (_, AnnTick _ ce) = isSimple ce+    isSimple (_, AnnCast ce _) = isSimple ce+    isSimple _                 = False+encapsulateScalars ce@((fvs, vi), AnnCase scrut bndr ty alts)+  = do+    { vectAvoid <- isVectAvoidanceAggressive+    ; varsS     <- allScalarVarTypeSet fvs+    ; case (vi, vectAvoid && varsS) of+        (VISimple, True) -> liftSimpleAndCase ce+        _                -> do+                            { encScrut <- encapsulateScalars scrut+                            ; encAlts  <- mapM encAlt alts+                            ; return ((fvs, vi), AnnCase encScrut bndr ty encAlts)+                            }+    }+  where+    encAlt (con, bndrs, expr) = (con, bndrs,) <$> encapsulateScalars expr+encapsulateScalars ce@((fvs, vi), AnnLet (AnnNonRec bndr expr1) expr2)+  = do+    { vectAvoid <- isVectAvoidanceAggressive+    ; varsS     <- allScalarVarTypeSet fvs+    ; case (vi, vectAvoid && varsS) of+        (VISimple, True) -> liftSimpleAndCase ce+        _                -> do+                            { encExpr1 <- encapsulateScalars expr1+                            ; encExpr2 <- encapsulateScalars expr2+                            ; return ((fvs, vi), AnnLet (AnnNonRec bndr encExpr1) encExpr2)+                            }+    }+encapsulateScalars ce@((fvs, vi), AnnLet (AnnRec binds) expr)+  = do+    { vectAvoid <- isVectAvoidanceAggressive+    ; varsS     <- allScalarVarTypeSet fvs+    ; case (vi, vectAvoid && varsS) of+        (VISimple, True) -> liftSimpleAndCase ce+        _                -> do+                            { encBinds <- mapM encBind binds+                            ; encExpr  <- encapsulateScalars expr+                            ; return ((fvs, vi), AnnLet (AnnRec encBinds) encExpr)+                            }+    }+ where+   encBind (bndr, expr) = (bndr,) <$> encapsulateScalars expr+encapsulateScalars ((fvs, vi), AnnCast expr coercion)+  = do+    { encExpr <- encapsulateScalars expr+    ; return ((fvs, vi), AnnCast encExpr coercion)+    }+encapsulateScalars _+  = panic "Vectorise.Exp.encapsulateScalars: unknown constructor"++-- Lambda-lift the given simple expression and apply it to the abstracted free variables.+--+-- If the expression is a case expression scrutinising anything, but a scalar type, then lift+-- each alternative individually.+--+liftSimpleAndCase :: CoreExprWithVectInfo -> VM CoreExprWithVectInfo+liftSimpleAndCase aexpr@((fvs, _vi), AnnCase expr bndr t alts)+  = do+    { vi <- vectAvoidInfoTypeOf expr+    ; if (vi == VISimple)+      then+        liftSimple aexpr  -- if the scrutinee is scalar, we need no special treatment+      else do+      { alts' <- mapM (\(ac, bndrs, aexpr) -> (ac, bndrs,) <$> liftSimpleAndCase aexpr) alts+      ; return ((fvs, vi), AnnCase expr bndr t alts')+      }+    }+liftSimpleAndCase aexpr = liftSimple aexpr++liftSimple :: CoreExprWithVectInfo -> VM CoreExprWithVectInfo+liftSimple ((fvs, vi), AnnVar v)+  | v `elemDVarSet` fvs               -- special case to avoid producing: (\v -> v) v+  && not (isToplevel v)               --   NB: if 'v' not free or is toplevel, we must get the 'VIEncaps'+  = return $ ((fvs, vi), AnnVar v)+liftSimple aexpr@((fvs_orig, VISimple), expr)+  = do+    { let liftedExpr = mkAnnApps (mkAnnLams (reverse vars) fvs expr) vars++    ; traceVt "encapsulate:" $ ppr (deAnnotate aexpr) $$ text "==>" $$ ppr (deAnnotate liftedExpr)++    ; return $ liftedExpr+    }+  where+    vars = dVarSetElems fvs+    fvs  = filterDVarSet (not . isToplevel) fvs_orig -- only include 'Id's that are not toplevel++    mkAnnLams :: [Var] -> DVarSet -> AnnExpr' Var (DVarSet, VectAvoidInfo) -> CoreExprWithVectInfo+    mkAnnLams []     fvs expr = ASSERT(isEmptyDVarSet fvs)+                                ((emptyDVarSet, VIEncaps), expr)+    mkAnnLams (v:vs) fvs expr = mkAnnLams vs (fvs `delDVarSet` v) (AnnLam v ((fvs, VIEncaps), expr))++    mkAnnApps :: CoreExprWithVectInfo -> [Var] -> CoreExprWithVectInfo+    mkAnnApps aexpr []     = aexpr+    mkAnnApps aexpr (v:vs) = mkAnnApps (mkAnnApp aexpr v) vs++    mkAnnApp :: CoreExprWithVectInfo -> Var -> CoreExprWithVectInfo+    mkAnnApp aexpr@((fvs, _vi), _expr) v+      = ((fvs `extendDVarSet` v, VISimple), AnnApp aexpr ((unitDVarSet v, VISimple), AnnVar v))+liftSimple aexpr+  = pprPanic "Vectorise.Exp.liftSimple: not simple" $ ppr (deAnnotate aexpr)++isToplevel :: Var -> Bool+isToplevel v | isId v    = case realIdUnfolding v of+                             NoUnfolding                     -> False+                             BootUnfolding                   -> False+                             OtherCon      {}                -> True+                             DFunUnfolding {}                -> True+                             CoreUnfolding {uf_is_top = top} -> top+             | otherwise = False++-- |Vectorise an expression.+--+vectExpr :: CoreExprWithVectInfo -> VM VExpr++vectExpr aexpr+    -- encapsulated expression of functional type => try to vectorise as a scalar subcomputation+  | (isFunTy . annExprType $ aexpr) && isVIEncaps aexpr+  = vectFnExpr True False aexpr+    -- encapsulated constant => vectorise as a scalar constant+  | isVIEncaps aexpr+  = traceVt "vectExpr (encapsulated constant):" (ppr . deAnnotate $ aexpr) >>+    vectConst (deAnnotate aexpr)++vectExpr (_, AnnVar v)+  = vectVar v++vectExpr (_, AnnLit lit)+  = vectConst $ Lit lit++vectExpr aexpr@(_, AnnLam _ _)+  = traceVt "vectExpr [AnnLam]:" (ppr . deAnnotate $ aexpr) >>+    vectFnExpr True False aexpr++  -- SPECIAL CASE: Vectorise/lift 'patError @ ty err' by only vectorising/lifting the type 'ty';+  --   its only purpose is to abort the program, but we need to adjust the type to keep CoreLint+  --   happy.+-- FIXME: can't be do this with a VECTORISE pragma on 'pAT_ERROR_ID' now?+vectExpr (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType ty)) err)+  | v == pAT_ERROR_ID+  = do+    { (vty, lty) <- vectAndLiftType ty+    ; return (mkCoreApps (Var v) [Type (getRuntimeRep "vectExpr" vty), Type vty, err'], mkCoreApps (Var v) [Type lty, err'])+    }+  where+    err' = deAnnotate err++  -- type application (handle multiple consecutive type applications simultaneously to ensure the+  -- PA dictionaries are put at the right places)+vectExpr e@(_, AnnApp _ arg)+  | isAnnTypeArg arg+  = vectPolyApp e++  -- Lifted literal+vectExpr (_, AnnApp (_, AnnVar v) (_, AnnLit lit))+  | Just _con <- isDataConId_maybe v+  = do+    { let vexpr = App (Var v) (Lit lit)+    ; lexpr <- liftPD vexpr+    ; return (vexpr, lexpr)+    }++  -- value application (dictionary or user value)+vectExpr e@(_, AnnApp fn arg)+  | isPredTy arg_ty   -- dictionary application (whose result is not a dictionary)+  = vectPolyApp e+  | otherwise         -- user value+  = do+    {   -- vectorise the types+    ; varg_ty <- vectType arg_ty+    ; vres_ty <- vectType res_ty++        -- vectorise the function and argument expression+    ; vfn  <- vectExpr fn+    ; varg <- vectExpr arg++        -- the vectorised function is a closure; apply it to the vectorised argument+    ; mkClosureApp varg_ty vres_ty vfn varg+    }+  where+    (arg_ty, res_ty) = splitFunTy . exprType $ deAnnotate fn++vectExpr (_, AnnCase scrut bndr ty alts)+  | Just (tycon, ty_args) <- splitTyConApp_maybe scrut_ty+  , isAlgTyCon tycon+  = vectAlgCase tycon ty_args scrut bndr ty alts+  | otherwise+  = do+    { dflags <- getDynFlags+    ; cantVectorise dflags "Can't vectorise expression (no algebraic type constructor)" $+        ppr scrut_ty+    }+  where+    scrut_ty = exprType (deAnnotate scrut)++vectExpr (_, AnnLet (AnnNonRec bndr rhs) body)+  = do+    { traceVt "let binding (non-recursive)" Outputable.empty+    ; vrhs <- localV $+                inBind bndr $+                  vectAnnPolyExpr False rhs+    ; traceVt "let body (non-recursive)" Outputable.empty+    ; (vbndr, vbody) <- vectBndrIn bndr (vectExpr body)+    ; return $ vLet (vNonRec vbndr vrhs) vbody+    }++vectExpr (_, AnnLet (AnnRec bs) body)+  = do+    { (vbndrs, (vrhss, vbody)) <- vectBndrsIn bndrs $ do+                                  { traceVt "let bindings (recursive)" Outputable.empty+                                  ; vrhss <- zipWithM vect_rhs bndrs rhss+                                  ; traceVt "let body (recursive)" Outputable.empty+                                  ; vbody <- vectExpr body+                                  ; return (vrhss, vbody)+                                  }+    ; return $ vLet (vRec vbndrs vrhss) vbody+    }+  where+    (bndrs, rhss) = unzip bs++    vect_rhs bndr rhs = localV $+                          inBind bndr $+                            vectAnnPolyExpr (isStrongLoopBreaker $ idOccInfo bndr) rhs++vectExpr (_, AnnTick tickish expr)+  = vTick tickish <$> vectExpr expr++vectExpr (_, AnnType ty)+  = vType <$> vectType ty++vectExpr e+  = do+    { dflags <- getDynFlags+    ; cantVectorise dflags "Can't vectorise expression (vectExpr)" $ ppr (deAnnotate e)+    }++-- |Vectorise an expression that *may* have an outer lambda abstraction. If the expression is marked+-- as encapsulated ('VIEncaps'), vectorise it as a scalar computation (using a generalised scalar+-- zip).+--+-- We do not handle type variables at this point, as they will already have been stripped off by+-- 'vectPolyExpr'. We also only have to worry about one set of dictionary arguments as we (1) only+-- deal with Haskell 2011 and (2) class selectors are vectorised elsewhere.+--+vectFnExpr :: Bool                  -- ^If we process the RHS of a binding, whether that binding+                                    --  should be inlined+           -> Bool                  -- ^Whether the binding is a loop breaker+           -> CoreExprWithVectInfo  -- ^Expression to vectorise; must have an outer `AnnLam`+           -> VM VExpr+vectFnExpr inline loop_breaker aexpr@(_ann, AnnLam bndr body)+    -- predicate abstraction: leave as a normal abstraction, but vectorise the predicate type+  | isId bndr+    && isPredTy (idType bndr)+  = do+    { vBndr <- vectBndr bndr+    ; vbody <- vectFnExpr inline loop_breaker body+    ; return $ mapVect (mkLams [vectorised vBndr]) vbody+    }+    -- encapsulated non-predicate abstraction: vectorise as a scalar computation+  | isId bndr && isVIEncaps aexpr+  = vectScalarFun . deAnnotate $ aexpr+    -- non-predicate abstraction: vectorise as a non-scalar computation+  | isId bndr+  = vectLam inline loop_breaker aexpr+  | otherwise+  = do+    { dflags <- getDynFlags+    ; cantVectorise dflags "Vectorise.Exp.vectFnExpr: Unexpected type lambda" $+        ppr (deAnnotate aexpr)+    }+vectFnExpr _ _ aexpr+    -- encapsulated function: vectorise as a scalar computation+  | (isFunTy . annExprType $ aexpr) && isVIEncaps aexpr+  = vectScalarFun . deAnnotate $ aexpr+  | otherwise+    -- not an abstraction: vectorise as a non-scalar vanilla expression+    -- NB: we can get here due to the recursion in the first case above and from 'vectAnnPolyExpr'+  = vectExpr aexpr++-- |Vectorise type and dictionary applications.+--+-- These are always headed by a variable (as we don't support higher-rank polymorphism), but may+-- involve two sets of type variables and dictionaries. Consider,+--+-- > class C a where+-- >   m :: D b => b -> a+--+-- The type of 'm' is 'm :: forall a. C a => forall b. D b => b -> a'.+--+vectPolyApp :: CoreExprWithVectInfo -> VM VExpr+vectPolyApp e0+  = case e4 of+      (_, AnnVar var)+        -> do {   -- get the vectorised form of the variable+              ; vVar <- lookupVar var+              ; traceVt "vectPolyApp of" (ppr var)++                  -- vectorise type and dictionary arguments+              ; vDictsOuter <- mapM vectDictExpr (map deAnnotate dictsOuter)+              ; vDictsInner <- mapM vectDictExpr (map deAnnotate dictsInner)+              ; vTysOuter   <- mapM vectType     tysOuter+              ; vTysInner   <- mapM vectType     tysInner++              ; let reconstructOuter v = (`mkApps` vDictsOuter) <$> polyApply v vTysOuter++              ; case vVar of+                  Local (vv, lv)+                    -> do { MASSERT( null dictsInner )    -- local vars cannot be class selectors+                          ; traceVt "  LOCAL" (text "")+                          ; (,) <$> reconstructOuter (Var vv) <*> reconstructOuter (Var lv)+                          }+                  Global vv+                    | isDictComp var                      -- dictionary computation+                    -> do {   -- in a dictionary computation, the innermost, non-empty set of+                              -- arguments are non-vectorised arguments, where no 'PA'dictionaries+                              -- are needed for the type variables+                          ; ve <- if null dictsInner+                                  then+                                    return $ Var vv `mkTyApps` vTysOuter `mkApps` vDictsOuter+                                  else+                                    reconstructOuter+                                      (Var vv `mkTyApps` vTysInner `mkApps` vDictsInner)+                          ; traceVt "  GLOBAL (dict):" (ppr ve)+                          ; vectConst ve+                          }+                    | otherwise                           -- non-dictionary computation+                    -> do { MASSERT( null dictsInner )+                          ; ve <- reconstructOuter (Var vv)+                          ; traceVt "  GLOBAL (non-dict):" (ppr ve)+                          ; vectConst ve+                          }+              }+      _ -> pprSorry "Cannot vectorise programs with higher-rank types:" (ppr . deAnnotate $ e0)+  where+    -- if there is only one set of variables or dictionaries, it will be the outer set+    (e1, dictsOuter) = collectAnnDictArgs e0+    (e2, tysOuter)   = collectAnnTypeArgs e1+    (e3, dictsInner) = collectAnnDictArgs e2+    (e4, tysInner)   = collectAnnTypeArgs e3+    --+    isDictComp var = (isJust . isClassOpId_maybe $ var) || isDFunId var++-- |Vectorise the body of a dfun.+--+-- Dictionary computations are special for the following reasons.  The application of dictionary+-- functions are always saturated, so there is no need to create closures.  Dictionary computations+-- don't depend on array values, so they are always scalar computations whose result we can+-- replicate (instead of executing them in parallel).+--+-- NB: To keep things simple, we are not rewriting any of the bindings introduced in a dictionary+--     computation.  Consequently, the variable case needs to deal with cases where binders are+--     in the vectoriser environments and where that is not the case.+--+vectDictExpr :: CoreExpr -> VM CoreExpr+vectDictExpr (Var var)+  = do { mb_scope <- lookupVar_maybe var+       ; case mb_scope of+           Nothing                -> return $ Var var   -- binder from within the dict. computation+           Just (Local (vVar, _)) -> return $ Var vVar  -- local vectorised variable+           Just (Global vVar)     -> return $ Var vVar  -- global vectorised variable+       }+vectDictExpr (Lit lit)+  = pprPanic "Vectorise.Exp.vectDictExpr: literal in dictionary computation" (ppr lit)+vectDictExpr (Lam bndr e)+  = Lam bndr <$> vectDictExpr e+vectDictExpr (App fn arg)+  = App <$> vectDictExpr fn <*> vectDictExpr arg+vectDictExpr (Case e bndr ty alts)+  = Case <$> vectDictExpr e <*> pure bndr <*> vectType ty <*> mapM vectDictAlt alts+  where+    vectDictAlt (con, bs, e) = (,,) <$> vectDictAltCon con <*> pure bs <*> vectDictExpr e+    --+    vectDictAltCon (DataAlt datacon) = DataAlt <$> maybeV dataConErr (lookupDataCon datacon)+      where+        dataConErr = text "Cannot vectorise data constructor:" <+> ppr datacon+    vectDictAltCon (LitAlt lit)      = return $ LitAlt lit+    vectDictAltCon DEFAULT           = return DEFAULT+vectDictExpr (Let bnd body)+  = Let <$> vectDictBind bnd <*> vectDictExpr body+  where+    vectDictBind (NonRec bndr e) = NonRec bndr <$> vectDictExpr e+    vectDictBind (Rec bnds)      = Rec <$> mapM (\(bndr, e) -> (bndr,) <$> vectDictExpr e) bnds+vectDictExpr e@(Cast _e _coe)+  = pprSorry "Vectorise.Exp.vectDictExpr: cast" (ppr e)+vectDictExpr (Tick tickish e)+  = Tick tickish <$> vectDictExpr e+vectDictExpr (Type ty)+  = Type <$> vectType ty+vectDictExpr (Coercion coe)+  = pprSorry "Vectorise.Exp.vectDictExpr: coercion" (ppr coe)++-- |Vectorise an expression of functional type, where all arguments and the result are of primitive+-- types (i.e., 'Int', 'Float', 'Double' etc., which have instances of the 'Scalar' type class) and+-- which does not contain any subcomputations that involve parallel arrays.  Such functionals do not+-- require the full blown vectorisation transformation; instead, they can be lifted by application+-- of a member of the zipWith family (i.e., 'map', 'zipWith', zipWith3', etc.)+--+-- Dictionary functions are also scalar functions (as dictionaries themselves are not vectorised,+-- instead they become dictionaries of vectorised methods).  We treat them differently, though see+-- "Note [Scalar dfuns]" in 'Vectorise'.+--+vectScalarFun :: CoreExpr -> VM VExpr+vectScalarFun expr+  = do+    { traceVt "vectScalarFun:" (ppr expr)+    ; let (arg_tys, res_ty) = splitFunTys (exprType expr)+    ; mkScalarFun arg_tys res_ty expr+    }++-- Generate code for a scalar function by generating a scalar closure.  If the function is a+-- dictionary function, vectorise it as dictionary code.+--+mkScalarFun :: [Type] -> Type -> CoreExpr -> VM VExpr+mkScalarFun arg_tys res_ty expr+  | isPredTy res_ty+  = do { vExpr <- vectDictExpr expr+       ; return (vExpr, unused)+       }+  | otherwise+  = do { traceVt "mkScalarFun: " $ ppr expr $$ text "  ::" <+>+                                   ppr (mkFunTys arg_tys res_ty)++       ; fn_var  <- hoistExpr (fsLit "fn") expr DontInline+       ; zipf    <- zipScalars arg_tys res_ty+       ; clo     <- scalarClosure arg_tys res_ty (Var fn_var) (zipf `App` Var fn_var)+       ; clo_var <- hoistExpr (fsLit "clo") clo DontInline+       ; lclo    <- liftPD (Var clo_var)+       ; return (Var clo_var, lclo)+       }+  where+    unused = error "Vectorise.Exp.mkScalarFun: we don't lift dictionary expressions"++-- |Vectorise a dictionary function that has a 'VECTORISE SCALAR instance' pragma.+--+-- In other words, all methods in that dictionary are scalar functions — to be vectorised with+-- 'vectScalarFun'.  The dictionary "function" itself may be a constant, though.+--+-- NB: You may think that we could implement this function guided by the struture of the Core+--     expression of the right-hand side of the dictionary function.  We cannot proceed like this as+--     'vectScalarDFun' must also work for *imported* dfuns, where we don't necessarily have access+--     to the Core code of the unvectorised dfun.+--+-- Here an example — assume,+--+-- > class Eq a where { (==) :: a -> a -> Bool }+-- > instance (Eq a, Eq b) => Eq (a, b) where { (==) = ... }+-- > {-# VECTORISE SCALAR instance Eq (a, b) }+--+-- The unvectorised dfun for the above instance has the following signature:+--+-- > $dEqPair :: forall a b. Eq a -> Eq b -> Eq (a, b)+--+-- We generate the following (scalar) vectorised dfun (liberally using TH notation):+--+-- > $v$dEqPair :: forall a b. V:Eq a -> V:Eq b -> V:Eq (a, b)+-- > $v$dEqPair = /\a b -> \dEqa :: V:Eq a -> \dEqb :: V:Eq b ->+-- >                D:V:Eq $(vectScalarFun True recFns+-- >                         [| (==) @(a, b) ($dEqPair @a @b $(unVect dEqa) $(unVect dEqb)) |])+--+-- NB:+-- * '(,)' vectorises to '(,)' — hence, the type constructor in the result type remains the same.+-- * We share the '$(unVect di)' sub-expressions between the different selectors, but duplicate+--   the application of the unvectorised dfun, to enable the dictionary selection rules to fire.+--+vectScalarDFun :: Var        -- ^ Original dfun+               -> VM CoreExpr+vectScalarDFun var+  = do {   -- bring the type variables into scope+       ; mapM_ defLocalTyVar tvs++           -- vectorise dictionary argument types and generate variables for them+       ; vTheta     <- mapM vectType theta+       ; vThetaBndr <- mapM (newLocalVar (fsLit "vd")) vTheta+       ; let vThetaVars = varsToCoreExprs vThetaBndr++           -- vectorise superclass dictionaries and methods as scalar expressions+       ; thetaVars  <- mapM (newLocalVar (fsLit "d")) theta+       ; thetaExprs <- zipWithM unVectDict theta vThetaVars+       ; let thetaDictBinds = zipWith NonRec thetaVars thetaExprs+             dict           = Var var `mkTyApps` (mkTyVarTys tvs) `mkVarApps` thetaVars+             scsOps         = map (\selId -> varToCoreExpr selId `mkTyApps` tys `mkApps` [dict])+                                  selIds+       ; vScsOps <- mapM (\e -> vectorised <$> vectScalarFun e) scsOps++           -- vectorised applications of the class-dictionary data constructor+       ; Just vDataCon <- lookupDataCon dataCon+       ; vTys          <- mapM vectType tys+       ; let vBody = thetaDictBinds `mkLets` mkCoreConApps vDataCon (map Type vTys ++ vScsOps)++       ; return $ mkLams (tvs ++ vThetaBndr) vBody+       }+  where+    ty                   = varType var+    (tvs, theta, pty)    = tcSplitSigmaTy  ty        -- 'theta' is the instance context+    (cls, tys)           = tcSplitDFunHead pty       -- 'pty' is the instance head+    selIds               = classAllSelIds cls+    dataCon              = classDataCon cls++-- Build a value of the dictionary before vectorisation from original, unvectorised type and an+-- expression computing the vectorised dictionary.+--+-- Given the vectorised version of a dictionary 'vd :: V:C vt1..vtn', generate code that computes+-- the unvectorised version, thus:+--+-- > D:C op1 .. opm+-- > where+-- >   opi = $(fromVect opTyi [| vSeli @vt1..vtk vd |])+--+-- where 'opTyi' is the type of the i-th superclass or op of the unvectorised dictionary.+--+unVectDict :: Type -> CoreExpr -> VM CoreExpr+unVectDict ty e+  = do { vTys <- mapM vectType tys+       ; let meths = map (\sel -> Var sel `mkTyApps` vTys `mkApps` [e]) selIds+       ; scOps <- zipWithM fromVect methTys meths+       ; return $ mkCoreConApps dataCon (map Type tys ++ scOps)+       }+  where+    (tycon, tys) = splitTyConApp ty+    Just dataCon = isDataProductTyCon_maybe tycon+    Just cls     = tyConClass_maybe tycon+    methTys      = dataConInstArgTys dataCon tys+    selIds       = classAllSelIds cls++-- Vectorise an 'n'-ary lambda abstraction by building a set of 'n' explicit closures.+--+-- All non-dictionary free variables go into the closure's environment, whereas the dictionary+-- variables are passed explicit (as conventional arguments) into the body during closure+-- construction.+--+vectLam :: Bool                 -- ^ Should the RHS of a binding be inlined?+        -> Bool                 -- ^ Whether the binding is a loop breaker.+        -> CoreExprWithVectInfo -- ^ Body of abstraction.+        -> VM VExpr+vectLam inline loop_breaker expr@((fvs, _vi), AnnLam _ _)+ = do { traceVt "fully vectorise a lambda expression" (ppr . deAnnotate $ expr)++      ; let (bndrs, body) = collectAnnValBinders expr++          -- grab the in-scope type variables+      ; tyvars <- localTyVars++          -- collect and vectorise all /local/ free variables+      ; vfvs <- readLEnv $ \env ->+                  [ (var, fromJust mb_vv)+                  | var <- dVarSetElems fvs+                  , let mb_vv = lookupVarEnv (local_vars env) var+                  , isJust mb_vv         -- its local == is in local var env+                  ]+          -- separate dictionary from non-dictionary variables in the free variable set+      ; let (vvs_dict, vvs_nondict)     = partition (isPredTy . varType . fst) vfvs+            (_fvs_dict, vfvs_dict)      = unzip vvs_dict+            (fvs_nondict, vfvs_nondict) = unzip vvs_nondict++          -- compute the type of the vectorised closure+      ; arg_tys <- mapM (vectType . idType) bndrs+      ; res_ty  <- vectType (exprType $ deAnnotate body)++      ; let arity      = length fvs_nondict + length bndrs+            vfvs_dict' = map vectorised vfvs_dict+      ; buildClosures tyvars vfvs_dict' vfvs_nondict arg_tys res_ty+        . hoistPolyVExpr tyvars vfvs_dict' (maybe_inline arity)+        $ do {   -- generate the vectorised body of the lambda abstraction+             ; lc              <- builtin liftingContext+             ; (vbndrs, vbody) <- vectBndrsIn (fvs_nondict ++ bndrs) $ vectExpr body++             ; vbody' <- break_loop lc res_ty vbody+             ; return $ vLams lc vbndrs vbody'+             }+      }+  where+    maybe_inline n | inline    = Inline n+                   | otherwise = DontInline++    -- If this is the body of a binding marked as a loop breaker, add a recursion termination test+    -- to the /lifted/ version of the function body.  The termination tests checks if the lifting+    -- context is empty.  If so, it returns an empty array of the (lifted) result type instead of+    -- executing the function body.  This is the test from the last line (defining \mathcal{L}')+    -- in Figure 6 of HtM.+    break_loop lc ty (ve, le)+      | loop_breaker+      = do { dflags <- getDynFlags+           ; empty <- emptyPD ty+           ; lty   <- mkPDataType ty+           ; return (ve, mkWildCase (Var lc) intPrimTy lty+                           [(DEFAULT, [], le),+                            (LitAlt (mkMachInt dflags 0), [], empty)])+           }+      | otherwise = return (ve, le)+vectLam _ _ _ = panic "Vectorise.Exp.vectLam: not a lambda"++-- Vectorise an algebraic case expression.+--+-- We convert+--+--   case e :: t of v { ... }+--+-- to+--+--   V:    let v' = e in case v' of _ { ... }+--   L:    let v' = e in case v' `cast` ... of _ { ... }+--+--   When lifting, we have to do it this way because v must have the type+--   [:V(T):] but the scrutinee must be cast to the representation type. We also+--   have to handle the case where v is a wild var correctly.+--++-- FIXME: this is too lazy...is it?+vectAlgCase :: TyCon -> [Type] -> CoreExprWithVectInfo -> Var -> Type+            -> [(AltCon, [Var], CoreExprWithVectInfo)]+            -> VM VExpr+vectAlgCase _tycon _ty_args scrut bndr ty [(DEFAULT, [], body)]+  = do+    { traceVt "scrutinee (DEFAULT only)" Outputable.empty+    ; vscrut         <- vectExpr scrut+    ; (vty, lty)     <- vectAndLiftType ty+    ; traceVt "alternative body (DEFAULT only)" Outputable.empty+    ; (vbndr, vbody) <- vectBndrIn bndr (vectExpr body)+    ; return $ vCaseDEFAULT vscrut vbndr vty lty vbody+    }+vectAlgCase _tycon _ty_args scrut bndr ty [(DataAlt _, [], body)]+  = do+    { traceVt "scrutinee (one shot w/o binders)" Outputable.empty+    ; vscrut         <- vectExpr scrut+    ; (vty, lty)     <- vectAndLiftType ty+    ; traceVt "alternative body (one shot w/o binders)" Outputable.empty+    ; (vbndr, vbody) <- vectBndrIn bndr (vectExpr body)+    ; return $ vCaseDEFAULT vscrut vbndr vty lty vbody+    }+vectAlgCase _tycon _ty_args scrut bndr ty [(DataAlt dc, bndrs, body)]+  = do+    { traceVt "scrutinee (one shot w/ binders)" Outputable.empty+    ; vexpr      <- vectExpr scrut+    ; (vty, lty) <- vectAndLiftType ty+    ; traceVt "alternative body (one shot w/ binders)" Outputable.empty+    ; (vbndr, (vbndrs, (vect_body, lift_body)))+        <- vect_scrut_bndr+         . vectBndrsIn bndrs+         $ vectExpr body+    ; let (vect_bndrs, lift_bndrs) = unzip vbndrs+    ; (vscrut, lscrut, pdata_dc) <- pdataUnwrapScrut (vVar vbndr)+    ; vect_dc <- maybeV dataConErr (lookupDataCon dc)++    ; let vcase = mk_wild_case vscrut vty vect_dc  vect_bndrs vect_body+          lcase = mk_wild_case lscrut lty pdata_dc lift_bndrs lift_body++    ; return $ vLet (vNonRec vbndr vexpr) (vcase, lcase)+    }+  where+    vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr (fsLit "scrut")+                    | otherwise         = vectBndrIn bndr++    mk_wild_case expr ty dc bndrs body+      = mkWildCase expr (exprType expr) ty [(DataAlt dc, bndrs, body)]++    dataConErr = (text "vectAlgCase: data constructor not vectorised" <+> ppr dc)++vectAlgCase tycon _ty_args scrut bndr ty alts+  = do+    { traceVt "scrutinee (general case)" Outputable.empty+    ; vexpr <- vectExpr scrut++    ; vect_tc     <- vectTyCon tycon+    ; (vty, lty)  <- vectAndLiftType ty++    ; let arity = length (tyConDataCons vect_tc)+    ; sel_ty <- builtin (selTy arity)+    ; sel_bndr <- newLocalVar (fsLit "sel") sel_ty+    ; let sel = Var sel_bndr++    ; traceVt "alternatives' body (general case)" Outputable.empty+    ; (vbndr, valts) <- vect_scrut_bndr+                      $ mapM (proc_alt arity sel vty lty) alts'+    ; let (vect_dcs, vect_bndrss, lift_bndrss, vbodies) = unzip4 valts++    ; (vect_scrut, lift_scrut, pdata_dc) <- pdataUnwrapScrut (vVar vbndr)++    ; let (vect_bodies, lift_bodies) = unzip vbodies++    ; vdummy <- newDummyVar (exprType vect_scrut)+    ; ldummy <- newDummyVar (exprType lift_scrut)+    ; let vect_case = Case vect_scrut vdummy vty+                           (zipWith3 mk_vect_alt vect_dcs vect_bndrss vect_bodies)++    ; lc <- builtin liftingContext+    ; lbody <- combinePD vty (Var lc) sel lift_bodies+    ; let lift_case = Case lift_scrut ldummy lty+                           [(DataAlt pdata_dc, sel_bndr : concat lift_bndrss,+                             lbody)]++    ; return . vLet (vNonRec vbndr vexpr)+             $ (vect_case, lift_case)+    }+  where+    vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr (fsLit "scrut")+                    | otherwise         = vectBndrIn bndr++    alts' = sortBy (\(alt1, _, _) (alt2, _, _) -> cmp alt1 alt2) alts++    cmp (DataAlt dc1) (DataAlt dc2) = dataConTag dc1 `compare` dataConTag dc2+    cmp DEFAULT       DEFAULT       = EQ+    cmp DEFAULT       _             = LT+    cmp _             DEFAULT       = GT+    cmp _             _             = panic "vectAlgCase/cmp"++    proc_alt arity sel _ lty (DataAlt dc, bndrs, body@((fvs_body, _), _))+      = do+          dflags <- getDynFlags+          vect_dc <- maybeV dataConErr (lookupDataCon dc)+          let ntag = dataConTagZ vect_dc+              tag  = mkDataConTag dflags vect_dc+              fvs  = fvs_body `delDVarSetList` bndrs++          sel_tags  <- liftM (`App` sel) (builtin (selTags arity))+          lc        <- builtin liftingContext+          elems     <- builtin (selElements arity ntag)++          (vbndrs, vbody)+            <- vectBndrsIn bndrs+             . localV+             $ do+               { binds    <- mapM (pack_var (Var lc) sel_tags tag)+                           . filter isLocalId+                           $ dVarSetElems fvs+               ; traceVt "case alternative:" (ppr . deAnnotate $ body)+               ; (ve, le) <- vectExpr body+               ; return (ve, Case (elems `App` sel) lc lty+                             [(DEFAULT, [], (mkLets (concat binds) le))])+               }+                 -- empty    <- emptyPD vty+                 -- return (ve, Case (elems `App` sel) lc lty+                 --             [(DEFAULT, [], Let (NonRec flags_var flags_expr)+                 --                             $ mkLets (concat binds) le),+                 --               (LitAlt (mkMachInt 0), [], empty)])+          let (vect_bndrs, lift_bndrs) = unzip vbndrs+          return (vect_dc, vect_bndrs, lift_bndrs, vbody)+      where+        dataConErr = (text "vectAlgCase: data constructor not vectorised" <+> ppr dc)++    proc_alt _ _ _ _ _ = panic "vectAlgCase/proc_alt"++    mk_vect_alt vect_dc bndrs body = (DataAlt vect_dc, bndrs, body)++      -- Pack a variable for a case alternative context *if* the variable is vectorised. If it+      -- isn't, ignore it as scalar variables don't need to be packed.+    pack_var len tags t v+      = do+        { r <- lookupVar_maybe v+        ; case r of+            Just (Local (vv, lv)) ->+              do+              { lv'  <- cloneVar lv+              ; expr <- packByTagPD (idType vv) (Var lv) len tags t+              ; updLEnv (\env -> env { local_vars = extendVarEnv (local_vars env) v (vv, lv') })+              ; return [(NonRec lv' expr)]+              }+            _ -> return []+        }+++-- Support to compute information for vectorisation avoidance ------------------++-- Annotation for Core AST nodes that describes how they should be handled during vectorisation+-- and especially if vectorisation of the corresponding computation can be avoided.+--+data VectAvoidInfo = VIParr       -- tree contains parallel computations+                   | VISimple     -- result type is scalar & no parallel subcomputation+                   | VIComplex    -- any result type, no parallel subcomputation+                   | VIEncaps     -- tree encapsulated by 'liftSimple'+                   | VIDict       -- dictionary computation (never parallel)+                   deriving (Eq, Show)++-- Core expression annotated with free variables and vectorisation-specific information.+--+type CoreExprWithVectInfo = AnnExpr Id (DVarSet, VectAvoidInfo)++-- Yield the type of an annotated core expression.+--+annExprType :: AnnExpr Var ann -> Type+annExprType = exprType . deAnnotate++-- Project the vectorisation information from an annotated Core expression.+--+vectAvoidInfoOf :: CoreExprWithVectInfo -> VectAvoidInfo+vectAvoidInfoOf ((_, vi), _) = vi++-- Is this a 'VIParr' node?+--+isVIParr :: CoreExprWithVectInfo -> Bool+isVIParr = (== VIParr) . vectAvoidInfoOf++-- Is this a 'VIEncaps' node?+--+isVIEncaps :: CoreExprWithVectInfo -> Bool+isVIEncaps = (== VIEncaps) . vectAvoidInfoOf++-- Is this a 'VIDict' node?+--+isVIDict :: CoreExprWithVectInfo -> Bool+isVIDict = (== VIDict) . vectAvoidInfoOf++-- 'VIParr' if either argument is 'VIParr'; otherwise, the first argument.+--+unlessVIParr :: VectAvoidInfo -> VectAvoidInfo -> VectAvoidInfo+unlessVIParr _  VIParr = VIParr+unlessVIParr vi _      = vi++-- 'VIParr' if either arguments vectorisation information is 'VIParr'; otherwise, the vectorisation+-- information of the first argument is produced.+--+unlessVIParrExpr :: VectAvoidInfo -> CoreExprWithVectInfo -> VectAvoidInfo+infixl `unlessVIParrExpr`+unlessVIParrExpr e1 e2 = e1 `unlessVIParr` vectAvoidInfoOf e2++-- Compute Core annotations to determine for which subexpressions we can avoid vectorisation.+--+-- * The first argument is the set of free, local variables whose evaluation may entail parallelism.+--+vectAvoidInfo :: VarSet -> CoreExprWithFVs -> VM CoreExprWithVectInfo+vectAvoidInfo pvs ce@(_, AnnVar v)+  = do+    { gpvs <- globalParallelVars+    ; vi <- if v `elemVarSet` pvs || v `elemDVarSet` gpvs+            then return VIParr+            else vectAvoidInfoTypeOf ce+    ; viTrace ce vi []+    ; when (vi == VIParr) $+        traceVt "  reason:" $ if v `elemVarSet` pvs  then text "local"  else+                              if v `elemDVarSet` gpvs then text "global" else text "parallel type"++    ; return ((fvs, vi), AnnVar v)+    }+  where+    fvs = freeVarsOf ce++vectAvoidInfo _pvs ce@(_, AnnLit lit)+  = do+    { vi <- vectAvoidInfoTypeOf ce+    ; viTrace ce vi []+    ; return ((fvs, vi), AnnLit lit)+    }+  where+    fvs = freeVarsOf ce++vectAvoidInfo pvs ce@(_, AnnApp e1 e2)+  = do+    { ceVI <- vectAvoidInfoTypeOf ce+    ; eVI1 <- vectAvoidInfo pvs e1+    ; eVI2 <- vectAvoidInfo pvs e2+    ; let vi = ceVI `unlessVIParrExpr` eVI1 `unlessVIParrExpr` eVI2+    -- ; viTrace ce vi [eVI1, eVI2]+    ; return ((fvs, vi), AnnApp eVI1 eVI2)+    }+  where+    fvs = freeVarsOf ce++vectAvoidInfo pvs ce@(_, AnnLam var body)+  = do+    { bodyVI <- vectAvoidInfo pvs body+    ; varVI  <- vectAvoidInfoType $ varType var+    ; let vi = vectAvoidInfoOf bodyVI `unlessVIParr` varVI+    -- ; viTrace ce vi [bodyVI]+    ; return ((fvs, vi), AnnLam var bodyVI)+    }+  where+    fvs = freeVarsOf ce++vectAvoidInfo pvs ce@(_, AnnLet (AnnNonRec var e) body)+  = do+    { ceVI       <- vectAvoidInfoTypeOf ce+    ; eVI        <- vectAvoidInfo pvs e+    ; isScalarTy <- isScalar $ varType var+    ; (bodyVI, vi) <- if isVIParr eVI && not isScalarTy+        then do -- binding is parallel+        { bodyVI <- vectAvoidInfo (pvs `extendVarSet` var) body+        ; return (bodyVI, VIParr)+        }+        else do -- binding doesn't affect parallelism+        { bodyVI <- vectAvoidInfo pvs body+        ; return (bodyVI, ceVI `unlessVIParrExpr` bodyVI)+        }+    -- ; viTrace ce vi [eVI, bodyVI]+    ; return ((fvs, vi), AnnLet (AnnNonRec var eVI) bodyVI)+    }+  where+    fvs = freeVarsOf ce++vectAvoidInfo pvs ce@(_, AnnLet (AnnRec bnds) body)+  = do+    { ceVI         <- vectAvoidInfoTypeOf ce+    ; bndsVI       <- mapM (vectAvoidInfoBnd pvs) bnds+    ; parrBndrs    <- map fst <$> filterM isVIParrBnd bndsVI+    ; if not . null $ parrBndrs+      then do         -- body may trigger parallelism via at least one binding+        { new_pvs <- filterM ((not <$>) . isScalar . varType) parrBndrs+        ; let extendedPvs = pvs `extendVarSetList` new_pvs+        ; bndsVI <- mapM (vectAvoidInfoBnd extendedPvs) bnds+        ; bodyVI <- vectAvoidInfo extendedPvs body+        -- ; viTrace ce VIParr (map snd bndsVI ++ [bodyVI])+        ; return ((fvs, VIParr), AnnLet (AnnRec bndsVI) bodyVI)+        }+      else do         -- demanded bindings cannot trigger parallelism+        { bodyVI <- vectAvoidInfo pvs body+        ; let vi = ceVI `unlessVIParrExpr` bodyVI+        -- ; viTrace ce vi (map snd bndsVI ++ [bodyVI])+        ; return ((fvs, vi), AnnLet (AnnRec bndsVI) bodyVI)+        }+    }+  where+    fvs = freeVarsOf ce+    vectAvoidInfoBnd pvs (var, e) = (var,) <$> vectAvoidInfo pvs e++    isVIParrBnd (var, eVI)+      = do+        { isScalarTy <- isScalar (varType var)+        ; return $ isVIParr eVI && not isScalarTy+        }++vectAvoidInfo pvs ce@(_, AnnCase e var ty alts)+  = do+    { ceVI           <- vectAvoidInfoTypeOf ce+    ; eVI            <- vectAvoidInfo pvs e+    ; altsVI         <- mapM (vectAvoidInfoAlt (isVIParr eVI)) alts+    ; let alteVIs = [eVI | (_, _, eVI) <- altsVI]+          vi      =  foldl unlessVIParrExpr ceVI (eVI:alteVIs)  -- NB: same effect as in the paper+    -- ; viTrace ce vi (eVI : alteVIs)+    ; return ((fvs, vi), AnnCase eVI var ty altsVI)+    }+  where+    fvs = freeVarsOf ce+    vectAvoidInfoAlt scrutIsPar (con, bndrs, e)+      = do+        { allScalar <- allScalarVarType bndrs+        ; let altPvs | scrutIsPar && not allScalar = pvs `extendVarSetList` bndrs+                     | otherwise                   = pvs+        ; (con, bndrs,) <$> vectAvoidInfo altPvs e+        }++vectAvoidInfo pvs ce@(_, AnnCast e (fvs_ann, ann))+  = do+    { eVI <- vectAvoidInfo pvs e+    ; return ((fvs, vectAvoidInfoOf eVI), AnnCast eVI ((freeVarsOfAnn fvs_ann, VISimple), ann))+    }+  where+    fvs = freeVarsOf ce++vectAvoidInfo pvs ce@(_, AnnTick tick e)+  = do+    { eVI <- vectAvoidInfo pvs e+    ; return ((fvs, vectAvoidInfoOf eVI), AnnTick tick eVI)+    }+  where+    fvs = freeVarsOf ce++vectAvoidInfo _pvs ce@(_, AnnType ty)+  = return ((fvs, VISimple), AnnType ty)+  where+    fvs = freeVarsOf ce++vectAvoidInfo _pvs ce@(_, AnnCoercion coe)+  = return ((fvs, VISimple), AnnCoercion coe)+  where+    fvs = freeVarsOf ce++-- Compute vectorisation avoidance information for a type.+--+vectAvoidInfoType :: Type -> VM VectAvoidInfo+vectAvoidInfoType ty+  | isPredTy ty+  = return VIDict+  | Just (arg, res) <- splitFunTy_maybe ty+  = do+    { argVI <- vectAvoidInfoType arg+    ; resVI <- vectAvoidInfoType res+    ; case (argVI, resVI) of+        (VISimple, VISimple) -> return VISimple   -- NB: diverts from the paper: scalar functions+        (_       , VIDict)   -> return VIDict+        _                    -> return $ VIComplex `unlessVIParr` argVI `unlessVIParr` resVI+    }+  | otherwise+  = do+    { parr <- maybeParrTy ty+    ; if parr+      then return VIParr+      else do+    { scalar <- isScalar ty+    ; if scalar+      then return VISimple+      else return VIComplex+    } }++-- Compute vectorisation avoidance information for the type of a Core expression (with FVs).+--+vectAvoidInfoTypeOf :: AnnExpr Var ann -> VM VectAvoidInfo+vectAvoidInfoTypeOf = vectAvoidInfoType . annExprType++-- Checks whether the type might be a parallel array type.+--+maybeParrTy :: Type -> VM Bool+maybeParrTy ty+    -- looking through newtypes+  | Just ty'      <- coreView ty+  = (== VIParr) <$> vectAvoidInfoType ty'+    -- decompose constructor applications+  | Just (tc, ts) <- splitTyConApp_maybe ty+  = do+    { isParallel <- (tyConName tc `elemNameSet`) <$> globalParallelTyCons+    ; if isParallel+      then return True+      else or <$> mapM maybeParrTy ts+    }+  -- must be a Named ForAllTy because anon ones respond to splitTyConApp_maybe+maybeParrTy (ForAllTy _ ty) = maybeParrTy ty+maybeParrTy _               = return False++-- Are the types of all variables in the 'Scalar' class or toplevel variables?+--+-- NB: 'liftSimple' does not abstract over toplevel variables.+--+allScalarVarType :: [Var] -> VM Bool+allScalarVarType vs = and <$> mapM isScalarOrToplevel vs+  where+    isScalarOrToplevel v | isToplevel v = return True+                         | otherwise    = isScalar (varType v)++-- Are the types of all variables in the set in the 'Scalar' class or toplevel variables?+--+allScalarVarTypeSet :: DVarSet -> VM Bool+allScalarVarTypeSet = allScalarVarType . dVarSetElems++-- Debugging support+--+viTrace :: CoreExprWithFVs -> VectAvoidInfo -> [CoreExprWithVectInfo] -> VM ()+viTrace ce vi vTs+  = traceVt ("vect info: " ++ show vi ++ "[" +++             (concat $ map ((++ " ") . show . vectAvoidInfoOf) vTs) ++ "]")+            (ppr $ deAnnotate ce)
+ vectorise/Vectorise/Generic/Description.hs view
@@ -0,0 +1,292 @@+-- |Compute a description of the generic representation that we use for a user defined data type.+--+-- During vectorisation, we generate a PRepr and PA instance for each user defined+-- data type. The PA dictionary contains methods to convert the user type to and+-- from our generic representation. This module computes a description of what+-- that generic representation is.+--+module Vectorise.Generic.Description+  ( CompRepr(..)+  , ProdRepr(..)+  , ConRepr(..)+  , SumRepr(..)+  , tyConRepr+  , sumReprType+  , compOrigType+  )+where++import Vectorise.Utils+import Vectorise.Monad+import Vectorise.Builtins++import CoreSyn+import DataCon+import TyCon+import Type+import Control.Monad+import Outputable+++-- | Describes the generic representation of a data type.+--   If the data type has multiple constructors then we bundle them+--   together into a generic sum type.+data SumRepr+        =  -- | Data type has no data constructors.+           EmptySum++        -- | Data type has a single constructor.+        | UnarySum ConRepr++        -- | Data type has multiple constructors.+        | Sum  { -- | Representation tycon for the sum (eg Sum2)+                 repr_sum_tc    :: TyCon++               -- | PData version of the sum tycon     (eg PDataSum2)+               --   This TyCon doesn't appear explicitly in the source program.+               --   See Note [PData TyCons].+               , repr_psum_tc   :: TyCon++               -- | PDatas version of the sum tycon    (eg PDatasSum2)+               , repr_psums_tc  :: TyCon++               -- | Type of the selector               (eg Sel2)+               , repr_sel_ty    :: Type++               -- | Type of multi-selector             (eg Sel2s)+               , repr_sels_ty   :: Type++               -- | Function to get the length of a Sels of this type.+               , repr_selsLength_v :: CoreExpr++               -- | Type of each data constructor.+               , repr_con_tys   :: [Type]++               -- | Generic representation types of each data constructor.+               , repr_cons      :: [ConRepr]+               }+++-- | Describes the representation type of a data constructor.+data ConRepr+        = ConRepr+                { repr_dc       :: DataCon+                , repr_prod     :: ProdRepr+                }++-- | Describes the representation type of the fields \/ components of a constructor.+--   If the data constructor has multiple fields then we bundle them+--   together into a generic product type.+data ProdRepr+        = -- | Data constructor has no fields.+          EmptyProd++        -- | Data constructor has a single field.+        | UnaryProd CompRepr++        -- | Data constructor has several fields.+        | Prod { -- | Representation tycon for the product (eg Tuple2)+                 repr_tup_tc   :: TyCon++                 -- | PData  version of the product tycon  (eg PDataTuple2)+               , repr_ptup_tc  :: TyCon++                 -- | PDatas version of the product tycon  (eg PDatasTuple2s)+                 --   Not all lifted backends use `PDatas`.+               , repr_ptups_tc :: TyCon++                 -- | Types of each field.+               , repr_comp_tys :: [Type]++                 -- | Generic representation types for each field.+               , repr_comps    :: [CompRepr]+               }+++-- | Describes the representation type of a data constructor field.+data CompRepr+        = Keep Type+               CoreExpr     -- PR dictionary for the type+        | Wrap Type+++-------------------------------------------------------------------------------++-- |Determine the generic representation of a data type, given its tycon.+--+tyConRepr :: TyCon -> VM SumRepr+tyConRepr tc+  = sum_repr (tyConDataCons tc)+  where+    -- Build the representation type for a data type with the given constructors.+    -- The representation types for each individual constructor are bundled+    -- together into a generic sum type.+    sum_repr :: [DataCon] -> VM SumRepr+    sum_repr []    = return EmptySum+    sum_repr [con] = liftM UnarySum (con_repr con)+    sum_repr cons+     = do  let arity    = length cons+           rs           <- mapM con_repr cons+           tys          <- mapM conReprType rs++           -- Get the 'Sum' tycon of this arity (eg Sum2).+           sum_tc       <- builtin (sumTyCon arity)++           -- Get the 'PData' and 'PDatas' tycons for the sum.+           psum_tc      <- pdataReprTyConExact  sum_tc+           psums_tc     <- pdatasReprTyConExact sum_tc++           sel_ty       <- builtin (selTy      arity)+           sels_ty      <- builtin (selsTy     arity)+           selsLength_v <- builtin (selsLength arity)+           return $ Sum+                  { repr_sum_tc         = sum_tc+                  , repr_psum_tc        = psum_tc+                  , repr_psums_tc       = psums_tc+                  , repr_sel_ty         = sel_ty+                  , repr_sels_ty        = sels_ty+                  , repr_selsLength_v   = selsLength_v+                  , repr_con_tys        = tys+                  , repr_cons           = rs+                  }++    -- Build the representation type for a single data constructor.+    con_repr con   = liftM (ConRepr con) (prod_repr (dataConRepArgTys con))++    -- Build the representation type for the fields of a data constructor.+    -- The representation types for each individual field are bundled+    -- together into a generic product type.+    prod_repr :: [Type] -> VM ProdRepr+    prod_repr []   = return EmptyProd+    prod_repr [ty] = liftM UnaryProd (comp_repr ty)+    prod_repr tys+     = do  let arity    = length tys+           rs           <- mapM comp_repr tys+           tys'         <- mapM compReprType rs++           -- Get the Prod \/ Tuple tycon of this arity (eg Tuple2)+           tup_tc       <- builtin (prodTyCon arity)++           -- Get the 'PData' and 'PDatas' tycons for the product.+           ptup_tc      <- pdataReprTyConExact  tup_tc+           ptups_tc     <- pdatasReprTyConExact tup_tc++           return $ Prod+                  { repr_tup_tc   = tup_tc+                  , repr_ptup_tc  = ptup_tc+                  , repr_ptups_tc = ptups_tc+                  , repr_comp_tys = tys'+                  , repr_comps    = rs+                  }++    -- Build the representation type for a single data constructor field.+    comp_repr ty = liftM (Keep ty) (prDictOfReprType ty)+                   `orElseV` return (Wrap ty)++-- |Yield the type of this sum representation.+--+sumReprType :: SumRepr -> VM Type+sumReprType EmptySum     = voidType+sumReprType (UnarySum r) = conReprType r+sumReprType (Sum { repr_sum_tc  = sum_tc, repr_con_tys = tys })+  = return $ mkTyConApp sum_tc tys++-- Yield the type of this constructor representation.+--+conReprType :: ConRepr -> VM Type+conReprType (ConRepr _ r) = prodReprType r++-- Yield the type of of this product representation.+--+prodReprType :: ProdRepr -> VM Type+prodReprType EmptyProd     = voidType+prodReprType (UnaryProd r) = compReprType r+prodReprType (Prod { repr_tup_tc = tup_tc, repr_comp_tys = tys })+  = return $ mkTyConApp tup_tc tys++-- Yield the type of this data constructor field \/ component representation.+--+compReprType :: CompRepr -> VM Type+compReprType (Keep ty _) = return ty+compReprType (Wrap ty)   = mkWrapType ty++-- |Yield the original component type of a data constructor component representation.+--+compOrigType :: CompRepr -> Type+compOrigType (Keep ty _) = ty+compOrigType (Wrap ty)   = ty+++-- Outputable instances -------------------------------------------------------+instance Outputable SumRepr where+ ppr ss+  = case ss of+        EmptySum+         -> text "EmptySum"++        UnarySum con+         -> sep [text "UnarySum", ppr con]++        Sum sumtc psumtc psumstc selty selsty selsLength contys cons+         -> text "Sum" $+$ braces (nest 4+                $ sep   [ text "repr_sum_tc       = " <> ppr sumtc+                        , text "repr_psum_tc      = " <> ppr psumtc+                        , text "repr_psums_tc     = " <> ppr psumstc+                        , text "repr_sel_ty       = " <> ppr selty+                        , text "repr_sels_ty      = " <> ppr selsty+                        , text "repr_selsLength_v = " <> ppr selsLength+                        , text "repr_con_tys      = " <> ppr contys+                        , text "repr_cons         = " <> ppr cons])+++instance Outputable ConRepr where+ ppr (ConRepr dc pr)+        = text "ConRepr" $+$ braces (nest 4+                $ sep   [ text "repr_dc      = " <> ppr dc+                        , text "repr_prod    = " <> ppr pr])+++instance Outputable ProdRepr where+ ppr ss+  = case ss of+        EmptyProd+         -> text "EmptyProd"++        UnaryProd cr+         -> sep [text "UnaryProd", ppr cr]++        Prod tuptcs ptuptcs ptupstcs comptys comps+         -> sep [text "Prod", ppr tuptcs, ppr ptuptcs, ppr ptupstcs, ppr comptys, ppr comps]+++instance Outputable CompRepr where+ ppr ss+  = case ss of+        Keep t ce+         -> text "Keep" $+$ sep [ppr t, ppr ce]++        Wrap t+         -> sep [text "Wrap", ppr t]+++-- Notes ----------------------------------------------------------------------+{-+Note [PData TyCons]+~~~~~~~~~~~~~~~~~~~+When PData is a type family, the compiler generates a type constructor for each+instance, which is named after the family and instance type. This type+constructor does not appear in the source program. Rather, it is implicitly+defined by the data instance. For example with:++  data family PData a++  data instance PData (Sum2 a b)+        = PSum2  U.Sel2+                 (PData a)+                 (PData b)++The type constructor corresponding to the instance will be named 'PDataSum2',+and this is what we will get in the repr_psum_tc field of SumRepr.Sum.++-}+
+ vectorise/Vectorise/Generic/PADict.hs view
@@ -0,0 +1,126 @@++module Vectorise.Generic.PADict+  ( buildPADict+  ) where++import Vectorise.Monad+import Vectorise.Builtins+import Vectorise.Generic.Description+import Vectorise.Generic.PAMethods ( buildPAScAndMethods )+import Vectorise.Utils++import BasicTypes+import CoreSyn+import CoreUtils+import CoreUnfold+import Module+import TyCon+import CoAxiom+import Type+import Id+import Var+import Name+import FastString+++-- |Build the PA dictionary function for some type and hoist it to top level.+--+-- The PA dictionary holds fns that convert values to and from their vectorised representations.+--+-- @Recall the definition:+--    class PR (PRepr a) => PA a where+--      toPRepr      :: a -> PRepr a+--      fromPRepr    :: PRepr a -> a+--      toArrPRepr   :: PData a -> PData (PRepr a)+--      fromArrPRepr :: PData (PRepr a) -> PData a+--      toArrPReprs   :: PDatas a         -> PDatas (PRepr a)+--      fromArrPReprs :: PDatas (PRepr a) -> PDatas a+--+-- Example:+--    df :: forall a. PR (PRepr a) -> PA a -> PA (T a)+--    df = /\a. \(c:PR (PRepr a)) (d:PA a). MkPA c ($PR_df a d) ($toPRepr a d) ...+--    $dPR_df :: forall a. PA a -> PR (PRepr (T a))+--    $dPR_df = ....+--    $toRepr :: forall a. PA a -> T a -> PRepr (T a)+--    $toPRepr = ...+-- The "..." stuff is filled in by buildPAScAndMethods+-- @+--+buildPADict+        :: TyCon        -- ^ tycon of the type being vectorised.+        -> CoAxiom Unbranched+                        -- ^ Coercion between the type and+                        --     its vectorised representation.+        -> TyCon        -- ^ PData  instance tycon+        -> TyCon        -- ^ PDatas instance tycon+        -> SumRepr      -- ^ representation used for the type being vectorised.+        -> VM Var       -- ^ name of the top-level dictionary function.++buildPADict vect_tc prepr_ax pdata_tc pdatas_tc repr+ = polyAbstract tvs $ \args ->    -- The args are the dictionaries we lambda abstract over; and they+                                  -- are put in the envt, so when we need a (PA a) we can find it in+                                  -- the envt; they don't include the silent superclass args yet+   do { mod <- liftDs getModule+      ; let dfun_name = mkLocalisedOccName mod mkPADFunOcc vect_tc_name++          -- The superclass dictionary is a (silent) argument if the tycon is polymorphic...+      ; let mk_super_ty = do { r <- mkPReprType inst_ty+                             ; pr_cls <- builtin prClass+                             ; return $ mkClassPred pr_cls [r]+                             }+      ; super_tys  <- sequence [mk_super_ty | not (null tvs)]+      ; super_args <- mapM (newLocalVar (fsLit "pr")) super_tys+      ; let val_args = super_args ++ args+            all_args = tvs ++ val_args++          -- ...it is constant otherwise+      ; super_consts <- sequence [prDictOfPReprInstTyCon inst_ty prepr_ax [] | null tvs]++          -- Get ids for each of the methods in the dictionary, including superclass+      ; paMethodBuilders <- buildPAScAndMethods+      ; method_ids       <- mapM (method val_args dfun_name) paMethodBuilders++          -- Expression to build the dictionary.+      ; pa_dc  <- builtin paDataCon+      ; let dict = mkLams all_args (mkConApp pa_dc con_args)+            con_args = Type inst_ty+                     : map Var super_args  -- the superclass dictionary is either+                    ++ super_consts        -- lambda-bound or constant+                    ++ map (method_call val_args) method_ids++          -- Build the type of the dictionary function.+      ; pa_cls <- builtin paClass+      ; let dfun_ty = mkInvForAllTys tvs+                    $ mkFunTys (map varType val_args)+                               (mkClassPred pa_cls [inst_ty])++          -- Set the unfolding for the inliner.+      ; raw_dfun <- newExportedVar dfun_name dfun_ty+      ; let dfun_unf = mkDFunUnfolding all_args pa_dc con_args+            dfun = raw_dfun `setIdUnfolding`  dfun_unf+                            `setInlinePragma` dfunInlinePragma++          -- Add the new binding to the top-level environment.+      ; hoistBinding dfun dict+      ; return dfun+      }+  where+    tvs          = tyConTyVars vect_tc+    arg_tys      = mkTyVarTys tvs+    inst_ty      = mkTyConApp vect_tc arg_tys+    vect_tc_name = getName vect_tc++    method args dfun_name (name, build)+     = localV+     $ do  expr     <- build vect_tc prepr_ax pdata_tc pdatas_tc repr+           let body = mkLams (tvs ++ args) expr+           raw_var  <- newExportedVar (method_name dfun_name name) (exprType body)+           let var  = raw_var+                      `setIdUnfolding` mkInlineUnfoldingWithArity+                                         (length args) body+                      `setInlinePragma` alwaysInlinePragma+           hoistBinding var body+           return var++    method_call args id        = mkApps (Var id) (map Type arg_tys ++ map Var args)+    method_name dfun_name name = mkVarOcc $ occNameString dfun_name ++ ('$' : name)
+ vectorise/Vectorise/Generic/PAMethods.hs view
@@ -0,0 +1,584 @@++-- | Generate methods for the PA class.+--+--   TODO: there is a large amount of redundancy here between the+--   a, PData a, and PDatas a forms. See if we can factor some of this out.+--+module Vectorise.Generic.PAMethods+  ( buildPReprTyCon+  , buildPAScAndMethods+  ) where++import Vectorise.Utils+import Vectorise.Monad+import Vectorise.Builtins+import Vectorise.Generic.Description+import CoreSyn+import CoreUtils+import FamInstEnv+import MkCore            ( mkWildCase, mkCoreLet )+import TyCon+import CoAxiom+import Type+import OccName+import Coercion+import MkId+import FamInst+import TysPrim( intPrimTy )++import DynFlags+import FastString+import MonadUtils+import Control.Monad+import Outputable+++buildPReprTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst+buildPReprTyCon orig_tc vect_tc repr+ = do name      <- mkLocalisedName mkPReprTyConOcc (tyConName orig_tc)+      rhs_ty    <- sumReprType repr+      prepr_tc  <- builtin preprTyCon+      let axiom = mkSingleCoAxiom Nominal name tyvars [] prepr_tc instTys rhs_ty+      liftDs $ newFamInst SynFamilyInst axiom+  where+    tyvars = tyConTyVars vect_tc+    instTys = [mkTyConApp vect_tc . mkTyVarTys $ tyConTyVars vect_tc]++-- buildPAScAndMethods --------------------------------------------------------++-- | This says how to build the PR superclass and methods of PA+--   Recall the definition of the PA class:+--+--   @+--    class class PR (PRepr a) => PA a where+--      toPRepr       :: a                -> PRepr a+--      fromPRepr     :: PRepr a          -> a+--+--      toArrPRepr    :: PData a          -> PData (PRepr a)+--      fromArrPRepr  :: PData (PRepr a)  -> PData a+--+--      toArrPReprs   :: PDatas a         -> PDatas (PRepr a)+--      fromArrPReprs :: PDatas (PRepr a) -> PDatas a+--   @+--+type PAInstanceBuilder+        =  TyCon        -- ^ Vectorised TyCon+        -> CoAxiom Unbranched+                        -- ^ Coercion to the representation TyCon+        -> TyCon        -- ^ 'PData'  TyCon+        -> TyCon        -- ^ 'PDatas' TyCon+        -> SumRepr      -- ^ Description of generic representation.+        -> VM CoreExpr  -- ^ Instance function.+++buildPAScAndMethods :: VM [(String, PAInstanceBuilder)]+buildPAScAndMethods+ = return [ ("toPRepr",       buildToPRepr)+          , ("fromPRepr",     buildFromPRepr)+          , ("toArrPRepr",    buildToArrPRepr)+          , ("fromArrPRepr",  buildFromArrPRepr)+          , ("toArrPReprs",   buildToArrPReprs)+          , ("fromArrPReprs", buildFromArrPReprs)]+++-- buildToPRepr ---------------------------------------------------------------+-- | Build the 'toRepr' method of the PA class.+buildToPRepr :: PAInstanceBuilder+buildToPRepr vect_tc repr_ax _ _ repr+ = do let arg_ty = mkTyConApp vect_tc ty_args++      -- Get the representation type of the argument.+      res_ty <- mkPReprType arg_ty++      -- Var to bind the argument+      arg    <- newLocalVar (fsLit "x") arg_ty++      -- Build the expression to convert the argument to the generic representation.+      result <- to_sum (Var arg) arg_ty res_ty repr++      return $ Lam arg result+  where+    ty_args        = mkTyVarTys (tyConTyVars vect_tc)++    wrap_repr_inst = wrapTypeUnbranchedFamInstBody repr_ax ty_args []++    -- CoreExp to convert the given argument to the generic representation.+    -- We start by doing a case branch on the possible data constructors.+    to_sum :: CoreExpr -> Type -> Type -> SumRepr -> VM CoreExpr+    to_sum _ _ _ EmptySum+     = do void <- builtin voidVar+          return $ wrap_repr_inst $ Var void++    to_sum arg arg_ty res_ty (UnarySum r)+     = do (pat, vars, body) <- con_alt r+          return $ mkWildCase arg arg_ty res_ty+                   [(pat, vars, wrap_repr_inst body)]++    to_sum arg arg_ty res_ty (Sum { repr_sum_tc  = sum_tc+                                  , repr_con_tys = tys+                                  , repr_cons    =  cons })+     = do alts <- mapM con_alt cons+          let alts' = [(pat, vars, wrap_repr_inst+                                   $ mkConApp sum_con (map Type tys ++ [body]))+                        | ((pat, vars, body), sum_con)+                            <- zip alts (tyConDataCons sum_tc)]+          return $ mkWildCase arg arg_ty res_ty alts'++    con_alt (ConRepr con r)+     = do (vars, body) <- to_prod r+          return (DataAlt con, vars, body)++    -- CoreExp to convert data constructor fields to the generic representation.+    to_prod :: ProdRepr -> VM ([Var], CoreExpr)+    to_prod EmptyProd+     = do void <- builtin voidVar+          return ([], Var void)++    to_prod (UnaryProd comp)+     = do var  <- newLocalVar (fsLit "x") (compOrigType comp)+          body <- to_comp (Var var) comp+          return ([var], body)++    to_prod (Prod { repr_tup_tc   = tup_tc+                  , repr_comp_tys = tys+                  , repr_comps    = comps })+     = do vars  <- newLocalVars (fsLit "x") (map compOrigType comps)+          exprs <- zipWithM to_comp (map Var vars) comps+          let [tup_con] = tyConDataCons tup_tc+          return (vars, mkConApp tup_con (map Type tys ++ exprs))++    -- CoreExp to convert a data constructor component to the generic representation.+    to_comp :: CoreExpr -> CompRepr -> VM CoreExpr+    to_comp expr (Keep _ _) = return expr+    to_comp expr (Wrap ty)  = wrapNewTypeBodyOfWrap expr ty+++-- buildFromPRepr -------------------------------------------------------------++-- |Build the 'fromPRepr' method of the PA class.+--+buildFromPRepr :: PAInstanceBuilder+buildFromPRepr vect_tc repr_ax _ _ repr+  = do+      arg_ty <- mkPReprType res_ty+      arg <- newLocalVar (fsLit "x") arg_ty++      result <- from_sum (unwrapTypeUnbranchedFamInstScrut repr_ax ty_args [] (Var arg))+                         repr+      return $ Lam arg result+  where+    ty_args = mkTyVarTys (tyConTyVars vect_tc)+    res_ty  = mkTyConApp vect_tc ty_args++    from_sum _ EmptySum+     = do dummy <- builtin fromVoidVar+          return $ Var dummy `App` Type res_ty++    from_sum expr (UnarySum r) = from_con expr r+    from_sum expr (Sum { repr_sum_tc  = sum_tc+                       , repr_con_tys = tys+                       , repr_cons    = cons })+     = do vars  <- newLocalVars (fsLit "x") tys+          es    <- zipWithM from_con (map Var vars) cons+          return $ mkWildCase expr (exprType expr) res_ty+                   [(DataAlt con, [var], e)+                      | (con, var, e) <- zip3 (tyConDataCons sum_tc) vars es]++    from_con expr (ConRepr con r)+      = from_prod expr (mkConApp con $ map Type ty_args) r++    from_prod _ con EmptyProd = return con+    from_prod expr con (UnaryProd r)+     = do e <- from_comp expr r+          return $ con `App` e++    from_prod expr con (Prod { repr_tup_tc   = tup_tc+                             , repr_comp_tys = tys+                             , repr_comps    = comps+                             })+     = do vars <- newLocalVars (fsLit "y") tys+          es   <- zipWithM from_comp (map Var vars) comps+          let [tup_con] = tyConDataCons tup_tc+          return $ mkWildCase expr (exprType expr) res_ty+                   [(DataAlt tup_con, vars, con `mkApps` es)]++    from_comp expr (Keep _ _) = return expr+    from_comp expr (Wrap ty)  = unwrapNewTypeBodyOfWrap expr ty+++-- buildToArrRepr -------------------------------------------------------------++-- |Build the 'toArrRepr' method of the PA class.+--+buildToArrPRepr :: PAInstanceBuilder+buildToArrPRepr vect_tc repr_co pdata_tc _ r+ = do arg_ty <- mkPDataType el_ty+      res_ty <- mkPDataType =<< mkPReprType el_ty+      arg    <- newLocalVar (fsLit "xs") arg_ty++      pdata_co <- mkBuiltinCo pdataTyCon+      let co           = mkAppCo pdata_co+                       $ mkSymCo+                       $ mkUnbranchedAxInstCo Nominal repr_co ty_args []++          scrut   = unwrapFamInstScrut pdata_tc ty_args (Var arg)++      (vars, result) <- to_sum r++      return . Lam arg+             $ mkWildCase scrut (mkTyConApp pdata_tc ty_args) res_ty+               [(DataAlt pdata_dc, vars, mkCast result co)]+  where+    ty_args    = mkTyVarTys $ tyConTyVars vect_tc+    el_ty      = mkTyConApp vect_tc ty_args+    [pdata_dc] = tyConDataCons pdata_tc++    to_sum ss+     = case ss of+        EmptySum    -> builtin pvoidVar >>= \pvoid -> return ([], Var pvoid)+        UnarySum r  -> to_con r+        Sum{}+         -> do  let psum_tc     =  repr_psum_tc ss+                let [psum_con]  =  tyConDataCons psum_tc+                (vars, exprs)   <- mapAndUnzipM to_con (repr_cons ss)+                sel             <- newLocalVar (fsLit "sel") (repr_sel_ty ss)+                return ( sel : concat vars+                       , wrapFamInstBody psum_tc (repr_con_tys ss)+                         $ mkConApp psum_con+                         $ map Type (repr_con_tys ss) ++ (Var sel : exprs))++    to_prod ss+     = case ss of+        EmptyProd    -> builtin pvoidVar >>= \pvoid -> return ([], Var pvoid)+        UnaryProd r+         -> do  pty  <- mkPDataType (compOrigType r)+                var  <- newLocalVar (fsLit "x") pty+                expr <- to_comp (Var var) r+                return ([var], expr)+        Prod{}+         -> do  let [ptup_con]  = tyConDataCons (repr_ptup_tc ss)+                ptys   <- mapM (mkPDataType . compOrigType) (repr_comps ss)+                vars   <- newLocalVars (fsLit "x") ptys+                exprs  <- zipWithM to_comp (map Var vars) (repr_comps ss)+                return ( vars+                       , wrapFamInstBody (repr_ptup_tc ss) (repr_comp_tys ss)+                         $ mkConApp ptup_con+                         $ map Type (repr_comp_tys ss) ++ exprs)++    to_con (ConRepr _ r)    = to_prod r++    to_comp expr (Keep _ _) = return expr+    to_comp expr (Wrap ty)  = wrapNewTypeBodyOfPDataWrap expr ty+++-- buildFromArrPRepr ----------------------------------------------------------++-- |Build the 'fromArrPRepr' method for the PA class.+--+buildFromArrPRepr :: PAInstanceBuilder+buildFromArrPRepr vect_tc repr_co pdata_tc _ r+ = do arg_ty <- mkPDataType =<< mkPReprType el_ty+      res_ty <- mkPDataType el_ty+      arg    <- newLocalVar (fsLit "xs") arg_ty++      pdata_co <- mkBuiltinCo pdataTyCon+      let co           = mkAppCo pdata_co+                       $ mkUnbranchedAxInstCo Nominal repr_co var_tys []++      let scrut        = mkCast (Var arg) co++      let mk_result args+            = wrapFamInstBody pdata_tc var_tys+            $ mkConApp pdata_con+            $ map Type var_tys ++ args++      (expr, _) <- fixV $ \ ~(_, args) ->+                     from_sum res_ty (mk_result args) scrut r++      return $ Lam arg expr+ where+    var_tys     = mkTyVarTys $ tyConTyVars vect_tc+    el_ty       = mkTyConApp vect_tc var_tys+    [pdata_con] = tyConDataCons pdata_tc++    from_sum res_ty res expr ss+     = case ss of+        EmptySum    -> return (res, [])+        UnarySum r  -> from_con res_ty res expr r+        Sum {}+         -> do  let psum_tc    =  repr_psum_tc ss+                let [psum_con] =  tyConDataCons psum_tc+                sel            <- newLocalVar (fsLit "sel") (repr_sel_ty ss)+                ptys           <- mapM mkPDataType (repr_con_tys ss)+                vars           <- newLocalVars (fsLit "xs") ptys+                (res', args)   <- fold from_con res_ty res (map Var vars) (repr_cons ss)+                let scrut      =  unwrapFamInstScrut psum_tc (repr_con_tys ss) expr+                let body       =  mkWildCase scrut (exprType scrut) res_ty+                                    [(DataAlt psum_con, sel : vars, res')]+                return (body, Var sel : args)++    from_prod res_ty res expr ss+     = case ss of+        EmptyProd   -> return (res, [])+        UnaryProd r -> from_comp res_ty res expr r+        Prod {}+         -> do  let ptup_tc    =  repr_ptup_tc ss+                let [ptup_con] =  tyConDataCons ptup_tc+                ptys           <- mapM mkPDataType (repr_comp_tys ss)+                vars           <- newLocalVars (fsLit "ys") ptys+                (res', args)   <- fold from_comp res_ty res (map Var vars) (repr_comps ss)+                let scrut      =  unwrapFamInstScrut ptup_tc (repr_comp_tys ss) expr+                let body       =  mkWildCase scrut (exprType scrut) res_ty+                                    [(DataAlt ptup_con, vars, res')]+                return (body, args)++    from_con res_ty res expr (ConRepr _ r) = from_prod res_ty res expr r++    from_comp _ res expr (Keep _ _) = return (res, [expr])+    from_comp _ res expr (Wrap ty)  = do { expr' <- unwrapNewTypeBodyOfPDataWrap expr ty+                                         ; return (res, [expr'])+                                         }++    fold f res_ty res exprs rs+      = foldrM f' (res, []) (zip exprs rs)+      where+        f' (expr, r) (res, args)+         = do (res', args') <- f res_ty res expr r+              return (res', args' ++ args)+++-- buildToArrPReprs -----------------------------------------------------------+-- | Build the 'toArrPReprs' instance for the PA class.+--   This converts a PData of elements into the generic representation.+buildToArrPReprs :: PAInstanceBuilder+buildToArrPReprs vect_tc repr_co _ pdatas_tc r+ = do+    -- The argument type of the instance.+    --  eg: 'PDatas (Tree a b)'+    arg_ty    <- mkPDatasType el_ty++    -- The result type.+    --  eg: 'PDatas (PRepr (Tree a b))'+    res_ty    <- mkPDatasType =<< mkPReprType el_ty++    -- Variable to bind the argument to the instance+    -- eg: (xss :: PDatas (Tree a b))+    varg      <- newLocalVar (fsLit "xss") arg_ty++    -- Coercion to case between the (PRepr a) type and its instance.+    pdatas_co <- mkBuiltinCo pdatasTyCon+    let co           = mkAppCo pdatas_co+                     $ mkSymCo+                     $ mkUnbranchedAxInstCo Nominal repr_co ty_args []++    let scrut        = unwrapFamInstScrut pdatas_tc ty_args (Var varg)+    (vars, result)  <- to_sum r++    return  $ Lam varg+            $ mkWildCase scrut (mkTyConApp pdatas_tc ty_args) res_ty+                    [(DataAlt pdatas_dc, vars, mkCast result co)]++ where+    -- The element type of the argument.+    --  eg: 'Tree a b'.+    ty_args = mkTyVarTys $ tyConTyVars vect_tc+    el_ty   = mkTyConApp vect_tc ty_args++    -- PDatas data constructor+    [pdatas_dc] = tyConDataCons pdatas_tc++    to_sum ss+     = case ss of+        -- We can't convert data types with no data.+        -- See Note: [Empty PDatas].+        EmptySum        -> do dflags <- getDynFlags+                              return ([], errorEmptyPDatas dflags el_ty)+        UnarySum r      -> do dflags <- getDynFlags+                              to_con (errorEmptyPDatas dflags el_ty) r++        Sum{}+         -> do  let psums_tc     = repr_psums_tc ss+                let [psums_con]  = tyConDataCons psums_tc+                sels             <- newLocalVar (fsLit "sels") (repr_sels_ty ss)++                -- Take the number of selectors to serve as the length of+                -- and PDatas Void arrays in the product. See Note [Empty PDatas].+                let xSums        =  App (repr_selsLength_v ss) (Var sels)++                xSums_var <- newLocalVar (fsLit "xsum") intPrimTy++                (vars, exprs)    <- mapAndUnzipM (to_con xSums_var) (repr_cons ss)+                return ( sels : concat vars+                       , wrapFamInstBody psums_tc (repr_con_tys ss)+                         $ mkCoreLet (NonRec xSums_var xSums)+                                 -- mkCoreLet ensures that the let/app invariant holds+                         $ mkConApp psums_con+                         $ map Type (repr_con_tys ss) ++ (Var sels : exprs))++    to_prod xSums ss+     = case ss of+        EmptyProd+         -> do  pvoids  <- builtin pvoidsVar+                return ([], App (Var pvoids) (Var xSums) )++        UnaryProd r+         -> do  pty  <- mkPDatasType (compOrigType r)+                var  <- newLocalVar (fsLit "x") pty+                expr <- to_comp (Var var) r+                return ([var], expr)++        Prod{}+         -> do  let [ptups_con]  = tyConDataCons (repr_ptups_tc ss)+                ptys   <- mapM (mkPDatasType . compOrigType) (repr_comps ss)+                vars   <- newLocalVars (fsLit "x") ptys+                exprs  <- zipWithM to_comp (map Var vars) (repr_comps ss)+                return ( vars+                       , wrapFamInstBody (repr_ptups_tc ss) (repr_comp_tys ss)+                         $ mkConApp ptups_con+                         $ map Type (repr_comp_tys ss) ++ exprs)++    to_con xSums (ConRepr _ r)+        = to_prod xSums r++    to_comp expr (Keep _ _) = return expr+    to_comp expr (Wrap ty)  = wrapNewTypeBodyOfPDatasWrap expr ty+++-- buildFromArrPReprs ---------------------------------------------------------+buildFromArrPReprs :: PAInstanceBuilder+buildFromArrPReprs vect_tc repr_co _ pdatas_tc r+ = do+    -- The argument type of the instance.+    --  eg: 'PDatas (PRepr (Tree a b))'+    arg_ty      <- mkPDatasType =<< mkPReprType el_ty++    -- The result type.+    --  eg: 'PDatas (Tree a b)'+    res_ty      <- mkPDatasType el_ty++    -- Variable to bind the argument to the instance+    -- eg: (xss :: PDatas (PRepr (Tree a b)))+    varg        <- newLocalVar (fsLit "xss") arg_ty++    -- Build the coercion between PRepr and the instance type+    pdatas_co <- mkBuiltinCo pdatasTyCon+    let co           = mkAppCo pdatas_co+                     $ mkUnbranchedAxInstCo Nominal repr_co var_tys []++    let scrut        = mkCast (Var varg) co++    let mk_result args+            = wrapFamInstBody pdatas_tc var_tys+            $ mkConApp pdatas_con+            $ map Type var_tys ++ args++    (expr, _) <- fixV $ \ ~(_, args) ->+                     from_sum res_ty (mk_result args) scrut r++    return $ Lam varg expr+ where+    -- The element type of the argument.+    --  eg: 'Tree a b'.+    ty_args      = mkTyVarTys $ tyConTyVars vect_tc+    el_ty        = mkTyConApp vect_tc ty_args++    var_tys      = mkTyVarTys $ tyConTyVars vect_tc+    [pdatas_con] = tyConDataCons pdatas_tc++    from_sum res_ty res expr ss+     = case ss of+        -- We can't convert data types with no data.+        -- See Note: [Empty PDatas].+        EmptySum        -> do dflags <- getDynFlags+                              return (res, errorEmptyPDatas dflags el_ty)+        UnarySum r      -> from_con res_ty res expr r++        Sum {}+         -> do  let psums_tc    =  repr_psums_tc ss+                let [psums_con] =  tyConDataCons psums_tc+                sel             <- newLocalVar (fsLit "sels") (repr_sels_ty ss)+                ptys            <- mapM mkPDatasType (repr_con_tys ss)+                vars            <- newLocalVars (fsLit "xs") ptys+                (res', args)    <- fold from_con res_ty res (map Var vars) (repr_cons ss)+                let scrut       =  unwrapFamInstScrut psums_tc (repr_con_tys ss) expr+                let body        =  mkWildCase scrut (exprType scrut) res_ty+                                    [(DataAlt psums_con, sel : vars, res')]+                return (body, Var sel : args)++    from_prod res_ty res expr ss+     = case ss of+        EmptyProd   -> return (res, [])+        UnaryProd r -> from_comp res_ty res expr r+        Prod {}+         -> do  let ptups_tc    =  repr_ptups_tc ss+                let [ptups_con] =  tyConDataCons ptups_tc+                ptys            <- mapM mkPDatasType (repr_comp_tys ss)+                vars            <- newLocalVars (fsLit "ys") ptys+                (res', args)    <- fold from_comp res_ty res (map Var vars) (repr_comps ss)+                let scrut       =  unwrapFamInstScrut ptups_tc (repr_comp_tys ss) expr+                let body        =  mkWildCase scrut (exprType scrut) res_ty+                                    [(DataAlt ptups_con, vars, res')]+                return (body, args)++    from_con res_ty res expr (ConRepr _ r)+        = from_prod res_ty res expr r++    from_comp _ res expr (Keep _ _) = return (res, [expr])+    from_comp _ res expr (Wrap ty)  = do { expr' <- unwrapNewTypeBodyOfPDatasWrap expr ty+                                         ; return (res, [expr'])+                                         }++    fold f res_ty res exprs rs+      = foldrM f' (res, []) (zip exprs rs)+      where+        f' (expr, r) (res, args)+         = do (res', args') <- f res_ty res expr r+              return (res', args' ++ args)+++-- Notes ----------------------------------------------------------------------+{-+Note [Empty PDatas]+~~~~~~~~~~~~~~~~~~~+We don't support "empty" data types like the following:++  data Empty0+  data Empty1 = MkEmpty1+  data Empty2 = MkEmpty2 Empty0+  ...++There is no parallel data associcated with these types, so there is no where+to store the length of the PDatas array with our standard representation.++Enumerations like the following are ok:+  data Bool = True | False++The native and generic representations are:+  type instance (PDatas Bool)        = VPDs:Bool Sels2+  type instance (PDatas (Repr Bool)) = PSum2s Sels2 (PDatas Void) (PDatas Void)++To take the length of a (PDatas Bool) we take the length of the contained Sels2.+When converting a (PDatas Bool) to a (PDatas (Repr Bool)) we use this length to+initialise the two (PDatas Void) arrays.++However, with this:+  data Empty1 = MkEmpty1++The native and generic representations would be:+  type instance (PDatas Empty1)        = VPDs:Empty1+  type instance (PDatas (Repr Empty1)) = PVoids Int++The 'Int' argument of PVoids is supposed to store the length of the PDatas+array. When converting the (PDatas Empty1) to a (PDatas (Repr Empty1)) we+need to come up with a value for it, but there isn't one.++To fix this we'd need to add an Int field to VPDs:Empty1 as well, but that's+too much hassle and there's no point running a parallel computation on no+data anyway.+-}+errorEmptyPDatas :: DynFlags -> Type -> a+errorEmptyPDatas dflags tc+    = cantVectorise dflags "Vectorise.PAMethods"+    $ vcat  [ text "Cannot vectorise data type with no parallel data " <> quotes (ppr tc)+            , text "Data types to be vectorised must contain at least one constructor"+            , text "with at least one field." ]
+ vectorise/Vectorise/Generic/PData.hs view
@@ -0,0 +1,168 @@++-- | Build instance tycons for the PData and PDatas type families.+--+--   TODO: the PData and PDatas cases are very similar.+--   We should be able to factor out the common parts.+module Vectorise.Generic.PData+  ( buildPDataTyCon+  , buildPDatasTyCon )+where++import Vectorise.Monad+import Vectorise.Builtins+import Vectorise.Generic.Description+import Vectorise.Utils+import Vectorise.Env( GlobalEnv( global_fam_inst_env ) )++import BasicTypes ( SourceText(..) )+import BuildTyCl+import DataCon+import TyCon+import Type+import FamInst+import FamInstEnv+import TcMType+import Name+import Util+import MonadUtils+import Control.Monad+++-- buildPDataTyCon ------------------------------------------------------------+-- | Build the PData instance tycon for a given type constructor.+buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst+buildPDataTyCon orig_tc vect_tc repr+ = fixV $ \fam_inst ->+   do let repr_tc = dataFamInstRepTyCon fam_inst+      name' <- mkLocalisedName mkPDataTyConOcc orig_name+      rhs   <- buildPDataTyConRhs orig_name vect_tc repr_tc repr+      pdata <- builtin pdataTyCon+      buildDataFamInst name' pdata vect_tc rhs+ where+    orig_name = tyConName orig_tc++buildDataFamInst :: Name -> TyCon -> TyCon -> AlgTyConRhs -> VM FamInst+buildDataFamInst name' fam_tc vect_tc rhs+ = do { axiom_name <- mkDerivedName mkInstTyCoOcc name'++      ; (_, tyvars') <- liftDs $ freshenTyVarBndrs tyvars+      ; let ax       = mkSingleCoAxiom Representational axiom_name tyvars' [] fam_tc pat_tys rep_ty+            tys'     = mkTyVarTys tyvars'+            rep_ty   = mkTyConApp rep_tc tys'+            pat_tys  = [mkTyConApp vect_tc tys']+            rep_tc   = mkAlgTyCon name'+                           (mkTyConBindersPreferAnon tyvars' liftedTypeKind)+                           liftedTypeKind+                           (map (const Nominal) tyvars')+                           Nothing+                           []          -- no stupid theta+                           rhs+                           (DataFamInstTyCon ax fam_tc pat_tys)+                           False       -- not GADT syntax+      ; liftDs $ newFamInst (DataFamilyInst rep_tc) ax }+ where+    tyvars    = tyConTyVars vect_tc++buildPDataTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs+buildPDataTyConRhs orig_name vect_tc repr_tc repr+ = do data_con <- buildPDataDataCon orig_name vect_tc repr_tc repr+      return $ DataTyCon { data_cons = [data_con], is_enum = False }+++buildPDataDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon+buildPDataDataCon orig_name vect_tc repr_tc repr+ = do let tvs   = tyConTyVars vect_tc+      dc_name   <- mkLocalisedName mkPDataDataConOcc orig_name+      comp_tys  <- mkSumTys repr_sel_ty mkPDataType repr+      fam_envs  <- readGEnv global_fam_inst_env+      rep_nm    <- liftDs $ newTyConRepName dc_name+      liftDs $ buildDataCon fam_envs dc_name+                            False                  -- not infix+                            rep_nm+                            (map (const no_bang) comp_tys)+                            (Just $ map (const HsLazy) comp_tys)+                            []                     -- no field labels+                            (mkTyVarBinders Specified tvs)+                            []                     -- no existentials+                            []                     -- no eq spec+                            []                     -- no context+                            comp_tys+                            (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))+                            repr_tc+  where+    no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict+++-- buildPDatasTyCon -----------------------------------------------------------+-- | Build the PDatas instance tycon for a given type constructor.+buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst+buildPDatasTyCon orig_tc vect_tc repr+ = fixV $ \fam_inst ->+   do let repr_tc = dataFamInstRepTyCon fam_inst+      name'       <- mkLocalisedName mkPDatasTyConOcc orig_name+      rhs         <- buildPDatasTyConRhs orig_name vect_tc repr_tc repr+      pdatas     <- builtin pdatasTyCon+      buildDataFamInst name' pdatas vect_tc rhs+ where+    orig_name = tyConName orig_tc++buildPDatasTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs+buildPDatasTyConRhs orig_name vect_tc repr_tc repr+ = do data_con <- buildPDatasDataCon orig_name vect_tc repr_tc repr+      return $ DataTyCon { data_cons = [data_con], is_enum = False }+++buildPDatasDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon+buildPDatasDataCon orig_name vect_tc repr_tc repr+ = do let tvs   = tyConTyVars vect_tc+      dc_name        <- mkLocalisedName mkPDatasDataConOcc orig_name++      comp_tys  <- mkSumTys repr_sels_ty mkPDatasType repr+      fam_envs <- readGEnv global_fam_inst_env+      rep_nm   <- liftDs $ newTyConRepName dc_name+      liftDs $ buildDataCon fam_envs dc_name+                            False                  -- not infix+                            rep_nm+                            (map (const no_bang) comp_tys)+                            (Just $ map (const HsLazy) comp_tys)+                            []                     -- no field labels+                            (mkTyVarBinders Specified tvs)+                            []                     -- no existentials+                            []                     -- no eq spec+                            []                     -- no context+                            comp_tys+                            (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))+                            repr_tc+  where+     no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict+++-- Utils ----------------------------------------------------------------------+-- | Flatten a SumRepr into a list of data constructor types.+mkSumTys+        :: (SumRepr -> Type)+        -> (Type -> VM Type)+        -> SumRepr+        -> VM [Type]++mkSumTys repr_selX_ty mkTc repr+ = sum_tys repr+ where+    sum_tys EmptySum      = return []+    sum_tys (UnarySum r)  = con_tys r+    sum_tys d@(Sum { repr_cons   = cons })+      = liftM (repr_selX_ty d :) (concatMapM con_tys cons)++    con_tys (ConRepr _ r)  = prod_tys r++    prod_tys EmptyProd     = return []+    prod_tys (UnaryProd r) = liftM singleton (comp_ty r)+    prod_tys (Prod { repr_comps = comps }) = mapM comp_ty comps++    comp_ty r = mkTc (compOrigType r)++{-+mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type])+mk_fam_inst fam_tc arg_tc+  = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc])+-}
+ vectorise/Vectorise/Monad.hs view
@@ -0,0 +1,195 @@+module Vectorise.Monad (+  module Vectorise.Monad.Base,+  module Vectorise.Monad.Naming,+  module Vectorise.Monad.Local,+  module Vectorise.Monad.Global,+  module Vectorise.Monad.InstEnv,+  initV,++  -- * Builtins+  liftBuiltinDs,+  builtin,+  builtins,++  -- * Variables+  lookupVar,+  lookupVar_maybe,+  addGlobalParallelVar,+  addGlobalParallelTyCon,+) where++import Vectorise.Monad.Base+import Vectorise.Monad.Naming+import Vectorise.Monad.Local+import Vectorise.Monad.Global+import Vectorise.Monad.InstEnv+import Vectorise.Builtins+import Vectorise.Env++import CoreSyn+import TcRnMonad+import DsMonad+import HscTypes hiding ( MonadThings(..) )+import DynFlags+import MonadUtils (liftIO)+import InstEnv+import Class+import TyCon+import NameSet+import VarSet+import VarEnv+import Var+import Id+import Name+import ErrUtils+import Outputable+import Module++import Control.Monad (join)++-- |Run a vectorisation computation.+--+initV :: HscEnv+      -> ModGuts+      -> VectInfo+      -> VM a+      -> IO (Maybe (VectInfo, a))+initV hsc_env guts info thing_inside+  = do { dumpIfVtTrace "Incoming VectInfo" (ppr info)++       ; (_, res) <- initDsWithModGuts hsc_env guts go+       ; case join res of+           Nothing+             -> dumpIfVtTrace "Vectorisation FAILED!" empty+           Just (info', _)+             -> dumpIfVtTrace "Outgoing VectInfo" (ppr info')++       ; return $ join res+       }+  where+    dflags = hsc_dflags hsc_env++    dumpIfVtTrace = dumpIfSet_dyn dflags Opt_D_dump_vt_trace++    bindsToIds (NonRec v _)   = [v]+    bindsToIds (Rec    binds) = map fst binds++    ids = concatMap bindsToIds (mg_binds guts)++    go+      = do {   -- set up tables of builtin entities+           ; builtins        <- initBuiltins+           ; builtin_vars    <- initBuiltinVars builtins++               -- set up class and type family envrionments+           ; eps <- liftIO $ hscEPS hsc_env+           ; let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)+                 instEnvs    = InstEnvs (eps_inst_env     eps)+                                        (mg_inst_env     guts)+                                        (mkModuleSet (dep_orphs (mg_deps guts)))+                 builtin_pas = initClassDicts instEnvs (paClass builtins)  -- grab all 'PA' and..+                 builtin_prs = initClassDicts instEnvs (prClass builtins)  -- ..'PR' class instances++               -- construct the initial global environment+           ; let genv = extendImportedVarsEnv builtin_vars+                        . setPAFunsEnv        builtin_pas+                        . setPRFunsEnv        builtin_prs+                        $ initGlobalEnv (gopt Opt_VectorisationAvoidance dflags)+                                        info (mg_vect_decls guts) instEnvs famInstEnvs++               -- perform vectorisation+           ; r <- runVM thing_inside builtins genv emptyLocalEnv+           ; case r of+               Yes genv _ x -> return $ Just (new_info genv, x)+               No reason    -> do { unqual <- mkPrintUnqualifiedDs+                                  ; liftIO $+                                      printOutputForUser dflags unqual $+                                        mkDumpDoc "Warning: vectorisation failure:" reason+                                  ; return Nothing+                                  }+           }++    new_info genv = modVectInfo genv ids (mg_tcs guts) (mg_vect_decls guts) info++    -- For a given DPH class, produce a mapping from type constructor (in head position) to the+    -- instance dfun for that type constructor and class.  (DPH class instances cannot overlap in+    -- head constructors.)+    --+    initClassDicts :: InstEnvs -> Class -> [(Name, Var)]+    initClassDicts insts cls = map find $ classInstances insts cls+      where+        find i | [Just tc] <- instanceRoughTcs i = (tc, instanceDFunId i)+               | otherwise                       = pprPanic invalidInstance (ppr i)++    invalidInstance = "Invalid DPH instance (overlapping in head constructor)"++-- Builtins -------------------------------------------------------------------++-- |Lift a desugaring computation using the `Builtins` into the vectorisation monad.+--+liftBuiltinDs :: (Builtins -> DsM a) -> VM a+liftBuiltinDs p = VM $ \bi genv lenv -> do { x <- p bi; return (Yes genv lenv x)}++-- |Project something from the set of builtins.+--+builtin :: (Builtins -> a) -> VM a+builtin f = VM $ \bi genv lenv -> return (Yes genv lenv (f bi))++-- |Lift a function using the `Builtins` into the vectorisation monad.+--+builtins :: (a -> Builtins -> b) -> VM (a -> b)+builtins f = VM $ \bi genv lenv -> return (Yes genv lenv (`f` bi))+++-- Var ------------------------------------------------------------------------++-- |Lookup the vectorised, and if local, also the lifted version of a variable.+--+-- * If it's in the global environment we get the vectorised version.+-- * If it's in the local environment we get both the vectorised and lifted version.+--+lookupVar :: Var -> VM (Scope Var (Var, Var))+lookupVar v+  = do { mb_res <- lookupVar_maybe v+       ; case mb_res of+           Just x  -> return x+           Nothing ->+               do dflags <- getDynFlags+                  dumpVar dflags v+       }++lookupVar_maybe :: Var -> VM (Maybe (Scope Var (Var, Var)))+lookupVar_maybe v+ = do { r <- readLEnv $ \env -> lookupVarEnv (local_vars env) v+      ; case r of+          Just e  -> return $ Just (Local e)+          Nothing -> fmap Global <$> (readGEnv $ \env -> lookupVarEnv (global_vars env) v)+      }++dumpVar :: DynFlags -> Var -> a+dumpVar dflags var+  | Just _    <- isClassOpId_maybe var+  = cantVectorise dflags "ClassOpId not vectorised:" (ppr var)+  | otherwise+  = cantVectorise dflags "Variable not vectorised:" (ppr var)+++-- Global parallel entities ----------------------------------------------------++-- |Mark the given variable as parallel — i.e., executing the associated code might involve+-- parallel array computations.+--+addGlobalParallelVar :: Var -> VM ()+addGlobalParallelVar var+  = do { traceVt "addGlobalParallelVar" (ppr var)+       ; updGEnv $ \env -> env{global_parallel_vars = extendDVarSet (global_parallel_vars env) var}+       }++-- |Mark the given type constructor as parallel — i.e., its values might embed parallel arrays.+--+addGlobalParallelTyCon :: TyCon -> VM ()+addGlobalParallelTyCon tycon+  = do { traceVt "addGlobalParallelTyCon" (ppr tycon)+       ; updGEnv $ \env ->+           env{global_parallel_tycons = extendNameSet (global_parallel_tycons env) (tyConName tycon)}+       }
+ vectorise/Vectorise/Monad/Base.hs view
@@ -0,0 +1,243 @@+-- |The Vectorisation monad.++module Vectorise.Monad.Base (+  -- * The Vectorisation Monad+  VResult(..),+  VM(..),++  -- * Lifting+  liftDs,++  -- * Error Handling+  cantVectorise,+  maybeCantVectorise,+  maybeCantVectoriseM,++  -- * Debugging+  emitVt, traceVt, dumpOptVt, dumpVt,++  -- * Control+  noV, traceNoV,+  ensureV, traceEnsureV,+  onlyIfV,+  tryV, tryErrV,+  maybeV,  traceMaybeV,+  orElseV, orElseErrV,+  fixV,+) where++import Vectorise.Builtins+import Vectorise.Env++import DsMonad+import TcRnMonad+import ErrUtils+import Outputable+import DynFlags++import Control.Monad+++-- The Vectorisation Monad ----------------------------------------------------++-- |Vectorisation can either succeed with new envionment and a value, or return with failure+-- (including a description of the reason for failure).+--+data VResult a+  = Yes GlobalEnv LocalEnv a+  | No  SDoc++newtype VM a+  = VM { runVM :: Builtins -> GlobalEnv -> LocalEnv -> DsM (VResult a) }++instance Monad VM where+  VM p >>= f = VM $ \bi genv lenv -> do+                                       r <- p bi genv lenv+                                       case r of+                                         Yes genv' lenv' x -> runVM (f x) bi genv' lenv'+                                         No reason         -> return $ No reason++instance Applicative VM where+  pure x = VM $ \_ genv lenv -> return (Yes genv lenv x)+  (<*>) = ap++instance Functor VM where+  fmap = liftM++instance MonadIO VM where+  liftIO = liftDs . liftIO++instance HasDynFlags VM where+    getDynFlags = liftDs getDynFlags++-- Lifting --------------------------------------------------------------------++-- |Lift a desugaring computation into the vectorisation monad.+--+liftDs :: DsM a -> VM a+liftDs p = VM $ \_ genv lenv -> do { x <- p; return (Yes genv lenv x) }+++-- Error Handling -------------------------------------------------------------++-- |Throw a `pgmError` saying we can't vectorise something.+--+cantVectorise :: DynFlags -> String -> SDoc -> a+cantVectorise dflags s d = pgmError+                  . showSDoc dflags+                  $ vcat [text "*** Vectorisation error ***",+                          nest 4 $ sep [text s, nest 4 d]]++-- |Like `fromJust`, but `pgmError` on Nothing.+--+maybeCantVectorise :: DynFlags -> String -> SDoc -> Maybe a -> a+maybeCantVectorise dflags s d Nothing  = cantVectorise dflags s d+maybeCantVectorise _ _ _ (Just x) = x++-- |Like `maybeCantVectorise` but in a `Monad`.+--+maybeCantVectoriseM :: (Monad m, HasDynFlags m)+                    => String -> SDoc -> m (Maybe a) -> m a+maybeCantVectoriseM s d p+  = do+      r <- p+      case r of+        Just x  -> return x+        Nothing ->+            do dflags <- getDynFlags+               cantVectorise dflags s d+++-- Debugging ------------------------------------------------------------------++-- |Output a trace message if -ddump-vt-trace is active.+--+emitVt :: String -> SDoc -> VM ()+emitVt herald doc+  = liftDs $ do+      dflags <- getDynFlags+      liftIO . printOutputForUser dflags alwaysQualify $+        hang (text herald) 2 doc++-- |Output a trace message if -ddump-vt-trace is active.+--+traceVt :: String -> SDoc -> VM ()+traceVt herald doc+  = liftDs $ traceOptIf Opt_D_dump_vt_trace $ hang (text herald) 2 doc++-- |Dump the given program conditionally.+--+dumpOptVt :: DumpFlag -> String -> SDoc -> VM ()+dumpOptVt flag header doc+  = do { b <- liftDs $ doptM flag+       ; if b+         then dumpVt header doc+         else return ()+       }++-- |Dump the given program unconditionally.+--+dumpVt :: String -> SDoc -> VM ()+dumpVt header doc+  = do { unqual <- liftDs mkPrintUnqualifiedDs+       ; dflags <- liftDs getDynFlags+       ; liftIO $ printOutputForUser dflags unqual (mkDumpDoc header doc)+       }+++-- Control --------------------------------------------------------------------++-- |Return some result saying we've failed.+--+noV :: SDoc -> VM a+noV reason = VM $ \_ _ _ -> return $ No reason++-- |Like `traceNoV` but also emit some trace message to stderr.+--+traceNoV :: String -> SDoc -> VM a+traceNoV s d = pprTrace s d $ noV d++-- |If `True` then carry on, otherwise fail.+--+ensureV :: SDoc -> Bool -> VM ()+ensureV reason  False = noV reason+ensureV _reason True  = return ()++-- |Like `ensureV` but if we fail then emit some trace message to stderr.+--+traceEnsureV :: String -> SDoc -> Bool -> VM ()+traceEnsureV s d False = traceNoV s d+traceEnsureV _ _ True  = return ()++-- |If `True` then return the first argument, otherwise fail.+--+onlyIfV :: SDoc -> Bool -> VM a -> VM a+onlyIfV reason b p = ensureV reason b >> p++-- |Try some vectorisation computaton.+--+-- If it succeeds then return `Just` the result; otherwise, return `Nothing` after emitting a+-- failure message.+--+tryErrV :: VM a -> VM (Maybe a)+tryErrV (VM p) = VM $ \bi genv lenv ->+  do+    r <- p bi genv lenv+    case r of+      Yes genv' lenv' x -> return (Yes genv' lenv' (Just x))+      No reason         -> do { unqual <- mkPrintUnqualifiedDs+                              ; dflags <- getDynFlags+                              ; liftIO $+                                  printInfoForUser dflags unqual $+                                    text "Warning: vectorisation failure:" <+> reason+                              ; return (Yes genv  lenv  Nothing)+                              }++-- |Try some vectorisation computaton.+--+-- If it succeeds then return `Just` the result; otherwise, return `Nothing` without emitting a+-- failure message.+--+tryV :: VM a -> VM (Maybe a)+tryV (VM p) = VM $ \bi genv lenv ->+  do+    r <- p bi genv lenv+    case r of+      Yes genv' lenv' x -> return (Yes genv' lenv' (Just x))+      No _reason        -> return (Yes genv  lenv  Nothing)++-- |If `Just` then return the value, otherwise fail.+--+maybeV :: SDoc -> VM (Maybe a) -> VM a+maybeV reason p = maybe (noV reason) return =<< p++-- |Like `maybeV` but emit a message to stderr if we fail.+--+traceMaybeV :: String -> SDoc -> VM (Maybe a) -> VM a+traceMaybeV s d p = maybe (traceNoV s d) return =<< p++-- |Try the first computation,+--+--   * if it succeeds then take the returned value,+--   * if it fails then run the second computation instead while emitting a failure message.+--+orElseErrV :: VM a -> VM a -> VM a+orElseErrV p q = maybe q return =<< tryErrV p++-- |Try the first computation,+--+--   * if it succeeds then take the returned value,+--   * if it fails then run the second computation instead without emitting a failure message.+--+orElseV :: VM a -> VM a -> VM a+orElseV p q = maybe q return =<< tryV p++-- |Fixpoint in the vectorisation monad.+--+fixV :: (a -> VM a) -> VM a+fixV f = VM (\bi genv lenv -> fixDs $ \r -> runVM (f (unYes r)) bi genv lenv )+  where+    -- NOTE: It is essential that we are lazy in r above so do not replace+    --       calls to this function by an explicit case.+    unYes (Yes _ _ x) = x+    unYes (No reason) = pprPanic "Vectorise.Monad.Base.fixV: no result" reason
+ vectorise/Vectorise/Monad/Global.hs view
@@ -0,0 +1,237 @@+-- Operations on the global state of the vectorisation monad.++module Vectorise.Monad.Global (+  readGEnv,+  setGEnv,+  updGEnv,++  -- * Configuration+  isVectAvoidanceAggressive,++  -- * Vars+  defGlobalVar, undefGlobalVar,++  -- * Vectorisation declarations+  lookupVectDecl,++  -- * Scalars+  globalParallelVars, globalParallelTyCons,++  -- * TyCons+  lookupTyCon,+  defTyConName, defTyCon, globalVectTyCons,++  -- * Datacons+  lookupDataCon,+  defDataCon,++  -- * PA Dictionaries+  lookupTyConPA,+  defTyConPAs,++  -- * PR Dictionaries+  lookupTyConPR+) where++import Vectorise.Monad.Base+import Vectorise.Env++import CoreSyn+import Type+import TyCon+import DataCon+import DynFlags+import NameEnv+import NameSet+import Name+import VarEnv+import VarSet+import Var as Var+import Outputable+++-- Global Environment ---------------------------------------------------------++-- |Project something from the global environment.+--+readGEnv :: (GlobalEnv -> a) -> VM a+readGEnv f  = VM $ \_ genv lenv -> return (Yes genv lenv (f genv))++-- |Set the value of the global environment.+--+setGEnv :: GlobalEnv -> VM ()+setGEnv genv  = VM $ \_ _ lenv -> return (Yes genv lenv ())++-- |Update the global environment using the provided function.+--+updGEnv :: (GlobalEnv -> GlobalEnv) -> VM ()+updGEnv f = VM $ \_ genv lenv -> return (Yes (f genv) lenv ())+++-- Configuration --------------------------------------------------------------++-- |Should we avoid as much vectorisation as possible?+--+-- Set by '-f[no]-vectorisation-avoidance'+--+isVectAvoidanceAggressive :: VM Bool+isVectAvoidanceAggressive = readGEnv global_vect_avoid+++-- Vars -----------------------------------------------------------------------++-- |Add a mapping between a global var and its vectorised version to the state.+--+defGlobalVar :: Var -> Var -> VM ()+defGlobalVar v v'+  = do { traceVt "add global var mapping:" (ppr v <+> text "-->" <+> ppr v')++           -- check for duplicate vectorisation+       ; currentDef <- readGEnv $ \env -> lookupVarEnv (global_vars env) v+       ; case currentDef of+           Just old_v' ->+               do dflags <- getDynFlags+                  cantVectorise dflags "Variable is already vectorised:" $+                            ppr v <+> moduleOf v old_v'+           Nothing     -> return ()++       ; updGEnv  $ \env -> env { global_vars = extendVarEnv (global_vars env) v v' }+       }+  where+    moduleOf var var' | var == var'+                      = text "vectorises to itself"+                      | Just mod <- nameModule_maybe (Var.varName var')+                      = text "in module" <+> ppr mod+                      | otherwise+                      = text "in the current module"++-- |Remove the mapping of a variable in the vectorisation map.+--+undefGlobalVar :: Var -> VM ()+undefGlobalVar v+  = do+    { traceVt "REMOVING global var mapping:" (ppr v)+    ; updGEnv  $ \env -> env { global_vars = delVarEnv (global_vars env) v }+    }+++-- Vectorisation declarations -------------------------------------------------++-- |Check whether a variable has a vectorisation declaration.+--+-- The first component of the result indicates whether the variable has a 'NOVECTORISE' declaration.+-- The second component contains the given type and expression in case of a 'VECTORISE' declaration.+--+lookupVectDecl :: Var -> VM (Bool, Maybe (Type, CoreExpr))+lookupVectDecl var+  = readGEnv $ \env ->+      case lookupVarEnv (global_vect_decls env) var of+        Nothing -> (False, Nothing)+        Just Nothing  -> (True, Nothing)+        Just vectDecl -> (False, vectDecl)+++-- Parallel entities -----------------------------------------------------------++-- |Get the set of global parallel variables.+--+globalParallelVars :: VM DVarSet+globalParallelVars = readGEnv global_parallel_vars++-- |Get the set of all parallel type constructors (those that may embed parallelism) including both+-- both those parallel type constructors declared in an imported module and those declared in the+-- current module.+--+globalParallelTyCons :: VM NameSet+globalParallelTyCons = readGEnv global_parallel_tycons+++-- TyCons ---------------------------------------------------------------------++-- |Determine the vectorised version of a `TyCon`. The vectorisation map in the global environment+-- contains a vectorised version if the original `TyCon` embeds any parallel arrays.+--+lookupTyCon :: TyCon -> VM (Maybe TyCon)+lookupTyCon tc+  = readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc)++-- |Add a mapping between plain and vectorised `TyCon`s to the global environment.+--+-- The second argument is only to enable tracing for (mutually) recursively defined type+-- constructors, where we /must not/ pull at the vectorised type constructors (because that would+-- pull too early at the recursive knot).+--+defTyConName :: TyCon -> Name -> TyCon -> VM ()+defTyConName tc nameOfTc' tc'+  = do { traceVt "add global tycon mapping:" (ppr tc <+> text "-->" <+> ppr nameOfTc')++           -- check for duplicate vectorisation+       ; currentDef <- readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc)+       ; case currentDef of+           Just old_tc' ->+               do dflags <- getDynFlags+                  cantVectorise dflags "Type constructor or class is already vectorised:" $+                            ppr tc <+> moduleOf tc old_tc'+           Nothing     -> return ()++       ; updGEnv $ \env ->+           env { global_tycons = extendNameEnv (global_tycons env) (tyConName tc) tc' }+       }+  where+    moduleOf tc tc' | tc == tc'+                    = text "vectorises to itself"+                    | Just mod <- nameModule_maybe (tyConName tc')+                    = text "in module" <+> ppr mod+                    | otherwise+                    = text "in the current module"++-- |Add a mapping between plain and vectorised `TyCon`s to the global environment.+--+defTyCon :: TyCon -> TyCon -> VM ()+defTyCon tc tc' = defTyConName tc (tyConName tc') tc'++-- |Get the set of all vectorised type constructors.+--+globalVectTyCons :: VM (NameEnv TyCon)+globalVectTyCons = readGEnv global_tycons+++-- DataCons -------------------------------------------------------------------++-- |Lookup the vectorised version of a `DataCon` from the global environment.+--+lookupDataCon :: DataCon -> VM (Maybe DataCon)+lookupDataCon dc+  | isTupleTyCon (dataConTyCon dc)+  = return (Just dc)+  | otherwise+  = readGEnv $ \env -> lookupNameEnv (global_datacons env) (dataConName dc)++-- |Add the mapping between plain and vectorised `DataCon`s to the global environment.+--+defDataCon :: DataCon -> DataCon -> VM ()+defDataCon dc dc' = updGEnv $ \env ->+  env { global_datacons = extendNameEnv (global_datacons env) (dataConName dc) dc' }+++-- 'PA' dictionaries ------------------------------------------------------------++-- |Lookup the 'PA' dfun of a vectorised type constructor in the global environment.+--+lookupTyConPA :: TyCon -> VM (Maybe Var)+lookupTyConPA tc+  = readGEnv $ \env -> lookupNameEnv (global_pa_funs env) (tyConName tc)++-- |Associate vectorised type constructors with the dfun of their 'PA' instances in the global+-- environment.+--+defTyConPAs :: [(TyCon, Var)] -> VM ()+defTyConPAs ps = updGEnv $ \env ->+  env { global_pa_funs = extendNameEnvList (global_pa_funs env)+                                           [(tyConName tc, pa) | (tc, pa) <- ps] }+++-- PR Dictionaries ------------------------------------------------------------++lookupTyConPR :: TyCon -> VM (Maybe Var)+lookupTyConPR tc = readGEnv $ \env -> lookupNameEnv (global_pr_funs env) (tyConName tc)
+ vectorise/Vectorise/Monad/InstEnv.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE CPP #-}++module Vectorise.Monad.InstEnv+  ( existsInst+  , lookupInst+  , lookupFamInst+  )+where++import Vectorise.Monad.Global+import Vectorise.Monad.Base+import Vectorise.Env++import DynFlags+import FamInstEnv+import InstEnv+import Class+import Type+import TyCon+import Outputable+import Util+++#include "HsVersions.h"+++-- Check whether a unique class instance for a given class and type arguments exists.+--+existsInst :: Class -> [Type] -> VM Bool+existsInst cls tys+  = do { instEnv <- readGEnv global_inst_env+       ; return $ either (const False) (const True) (lookupUniqueInstEnv instEnv cls tys)+       }++-- Look up the dfun of a class instance.+--+-- The match must be unique —i.e., match exactly one instance— but the+-- type arguments used for matching may be more specific than those of+-- the class instance declaration.  The found class instances must not have+-- any type variables in the instance context that do not appear in the+-- instances head (i.e., no flexi vars); for details for what this means,+-- see the docs at InstEnv.lookupInstEnv.+--+lookupInst :: Class -> [Type] -> VM (DFunId, [Type])+lookupInst cls tys+  = do { instEnv <- readGEnv global_inst_env+       ; case lookupUniqueInstEnv instEnv cls tys of+           Right (inst, inst_tys) -> return (instanceDFunId inst, inst_tys)+           Left  err              ->+               do dflags <- getDynFlags+                  cantVectorise dflags "Vectorise.Monad.InstEnv.lookupInst:" err+       }++-- Look up a family instance.+--+-- The match must be unique - ie, match exactly one instance - but the+-- type arguments used for matching may be more specific than those of+-- the family instance declaration.+--+-- Return the family instance and its type instance.  For example, if we have+--+--  lookupFamInst 'T' '[Int]' yields (':R42T', 'Int')+--+-- then we have a coercion (ie, type instance of family instance coercion)+--+--  :Co:R42T Int :: T [Int] ~ :R42T Int+--+-- which implies that :R42T was declared as 'data instance T [a]'.+--+lookupFamInst :: TyCon -> [Type] -> VM FamInstMatch+lookupFamInst tycon tys+  = ASSERT( isOpenFamilyTyCon tycon )+    do { instEnv <- readGEnv global_fam_inst_env+       ; case lookupFamInstEnv instEnv tycon tys of+           [match] -> return match+           _other                ->+             do dflags <- getDynFlags+                cantVectorise dflags "Vectorise.Monad.InstEnv.lookupFamInst: not found: "+                           (ppr $ mkTyConApp tycon tys)+       }
+ vectorise/Vectorise/Monad/Local.hs view
@@ -0,0 +1,100 @@+module Vectorise.Monad.Local+  ( readLEnv+  , setLEnv+  , updLEnv+  , localV+  , closedV+  , getBindName+  , inBind+  , lookupTyVarPA+  , defLocalTyVar+  , defLocalTyVarWithPA+  , localTyVars+  )+where++import Vectorise.Monad.Base+import Vectorise.Env++import CoreSyn+import Name+import VarEnv+import Var+import FastString++-- Local Environment ----------------------------------------------------------++-- |Project something from the local environment.+--+readLEnv :: (LocalEnv -> a) -> VM a+readLEnv f  = VM $ \_ genv lenv -> return (Yes genv lenv (f lenv))++-- |Set the local environment.+--+setLEnv :: LocalEnv -> VM ()+setLEnv lenv  = VM $ \_ genv _ -> return (Yes genv lenv ())++-- |Update the environment using the provided function.+--+updLEnv :: (LocalEnv -> LocalEnv) -> VM ()+updLEnv f  = VM $ \_ genv lenv -> return (Yes genv (f lenv) ())++-- |Perform a computation in its own local environment.+-- This does not alter the environment of the current state.+--+localV :: VM a -> VM a+localV p+  = do+    { env <- readLEnv id+    ; x   <- p+    ; setLEnv env+    ; return x+    }++-- |Perform a computation in an empty local environment.+--+closedV :: VM a -> VM a+closedV p+  = do+    { env <- readLEnv id+    ; setLEnv (emptyLocalEnv { local_bind_name = local_bind_name env })+    ; x   <- p+    ; setLEnv env+    ; return x+    }++-- |Get the name of the local binding currently being vectorised.+--+getBindName :: VM FastString+getBindName = readLEnv local_bind_name++-- |Run a vectorisation computation in a local environment,+-- with this id set as the current binding.+--+inBind :: Id -> VM a -> VM a+inBind id p+  = do updLEnv $ \env -> env { local_bind_name = occNameFS (getOccName id) }+       p++-- |Lookup a PA tyvars from the local environment.+lookupTyVarPA :: Var -> VM (Maybe CoreExpr)+lookupTyVarPA tv+   = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv++-- |Add a tyvar to the local environment.+defLocalTyVar :: TyVar -> VM ()+defLocalTyVar tv = updLEnv $ \env ->+  env { local_tyvars   = tv : local_tyvars env+      , local_tyvar_pa = local_tyvar_pa env `delVarEnv` tv+      }++-- |Add mapping between a tyvar and pa dictionary to the local environment.+defLocalTyVarWithPA :: TyVar -> CoreExpr -> VM ()+defLocalTyVarWithPA tv pa = updLEnv $ \env ->+  env { local_tyvars   = tv : local_tyvars env+      , local_tyvar_pa = extendVarEnv (local_tyvar_pa env) tv pa+      }++-- |Get the set of tyvars from the local environment.+localTyVars :: VM [TyVar]+localTyVars = readLEnv (reverse . local_tyvars)
+ vectorise/Vectorise/Monad/Naming.hs view
@@ -0,0 +1,130 @@+-- |Computations in the vectorisation monad concerned with naming and fresh variable generation.++module Vectorise.Monad.Naming+  ( mkLocalisedName+  , mkDerivedName+  , mkVectId+  , cloneVar+  , newExportedVar+  , newLocalVar+  , newLocalVars+  , newDummyVar+  , newTyVar+  , newCoVar+  )+where++import Vectorise.Monad.Base++import DsMonad+import TcType+import Type+import Var+import Module+import Name+import SrcLoc+import MkId+import Id+import IdInfo( IdDetails(VanillaId) )+import FastString++import Control.Monad+++-- Naming ---------------------------------------------------------------------++-- |Create a localised variant of a name, using the provided function to transform its `OccName`.+--+-- If the name external, encode the original name's module into the new 'OccName'.  The result is+-- always an internal system name.+--+mkLocalisedName :: (Maybe String -> OccName -> OccName) -> Name -> VM Name+mkLocalisedName mk_occ name+  = do { mod <- liftDs getModule+       ; u   <- liftDs newUnique+       ; let occ_name = mkLocalisedOccName mod mk_occ name++             new_name | isExternalName name = mkExternalName u mod occ_name (nameSrcSpan name)+                      | otherwise           = mkSystemName   u     occ_name++       ; return new_name }++mkDerivedName :: (OccName -> OccName) -> Name -> VM Name+-- Similar to mkLocalisedName, but assumes the+-- incoming name is from this module.+-- Works on External names only+mkDerivedName mk_occ name+  = do { u   <- liftDs newUnique+       ; return (mkExternalName u (nameModule name)+                                  (mk_occ (nameOccName name))+                                  (nameSrcSpan name)) }++-- |Produce the vectorised variant of an `Id` with the given vectorised type, while taking care that+-- vectorised dfun ids must be dfuns again.+--+-- Force the new name to be a system name and, if the original was an external name, disambiguate+-- the new name with the module name of the original.+--+mkVectId :: Id -> Type -> VM Id+mkVectId id ty+  = do { name <- mkLocalisedName mkVectOcc (getName id)+       ; let id' | isDFunId id     = MkId.mkDictFunId name tvs theta cls tys+                 | isExportedId id = Id.mkExportedLocalId VanillaId name ty+                 | otherwise       = Id.mkLocalIdOrCoVar name ty+       ; return id'+       }+  where+    -- Decompose a dictionary function signature: \forall tvs. theta -> cls tys+    -- NB: We do *not* use closures '(:->)' for vectorised predicate abstraction as dictionary+    --     functions are always fully applied.+    (tvs, theta, pty) = tcSplitSigmaTy  ty+    (cls, tys)        = tcSplitDFunHead pty++-- |Make a fresh instance of this var, with a new unique.+--+cloneVar :: Var -> VM Var+cloneVar var = liftM (setIdUnique var) (liftDs newUnique)++-- |Make a fresh exported variable with the given type.+--+newExportedVar :: OccName -> Type -> VM Var+newExportedVar occ_name ty+ = do mod <- liftDs getModule+      u   <- liftDs newUnique++      let name = mkExternalName u mod occ_name noSrcSpan++      return $ Id.mkExportedLocalId VanillaId name ty++-- |Make a fresh local variable with the given type.+-- The variable's name is formed using the given string as the prefix.+--+newLocalVar :: FastString -> Type -> VM Var+newLocalVar fs ty+ = do u <- liftDs newUnique+      return $ mkSysLocalOrCoVar fs u ty++-- |Make several fresh local variables with the given types.+-- The variable's names are formed using the given string as the prefix.+--+newLocalVars :: FastString -> [Type] -> VM [Var]+newLocalVars fs = mapM (newLocalVar fs)++-- |Make a new local dummy variable.+--+newDummyVar :: Type -> VM Var+newDummyVar = newLocalVar (fsLit "vv")++-- |Make a fresh type variable with the given kind.+-- The variable's name is formed using the given string as the prefix.+--+newTyVar :: FastString -> Kind -> VM Var+newTyVar fs k+ = do u <- liftDs newUnique+      return $ mkTyVar (mkSysTvName u fs) k++-- |Make a fresh coercion variable with the given kind.+newCoVar :: FastString -> Kind -> VM Var+newCoVar fs k+  = do u <- liftDs newUnique+       return $ mkCoVar (mkSystemVarName u fs) k
+ vectorise/Vectorise/Type/Classify.hs view
@@ -0,0 +1,128 @@+-- Extract from a list of type constructors those (1) which need to be vectorised and (2) those+-- that could be, but need not be vectorised (as a scalar representation is sufficient and more+-- efficient).  The type constructors that cannot be vectorised will be dropped.+--+-- A type constructor will only be vectorised if it is+--+-- (1) a data type constructor, with vanilla data constructors (i.e., data constructors admitted by+--     Haskell 98) and+-- (2) at least one of the type constructors that appears in its definition is also vectorised.+--+-- If (1) is met, but not (2), the type constructor may appear in vectorised code, but there is no+-- need to vectorise that type constructor itself.  This holds, for example, for all enumeration+-- types.  As '([::])' is being vectorised, any type constructor whose definition involves+-- '([::])', either directly or indirectly, will be vectorised.++module Vectorise.Type.Classify+  ( classifyTyCons+  )+where++import NameSet+import UniqSet+import UniqFM+import DataCon+import TyCon+import TyCoRep+import qualified Type+import PrelNames+import Digraph++-- |From a list of type constructors, extract those that can be vectorised, returning them in two+-- sets, where the first result list /must be/ vectorised and the second result list /need not be/+-- vectorised. The third result list are those type constructors that we cannot convert (either+-- because they use language extensions or because they dependent on type constructors for which+-- no vectorised version is available).+--+-- NB: In order to be able to vectorise a type constructor, we require members of the depending set+--     (i.e., those type constructors that the current one depends on) to be vectorised only if they+--     are also parallel (i.e., appear in the second argument to the function).+--+-- The first argument determines the /conversion status/ of external type constructors as follows:+--+-- * tycons which have converted versions are mapped to 'True'+-- * tycons which are not changed by vectorisation are mapped to 'False'+-- * tycons which haven't been converted (because they can't or weren't vectorised) are not+--   elements of the map+--+classifyTyCons :: UniqFM Bool                  -- ^type constructor vectorisation status+               -> NameSet                      -- ^tycons involving parallel arrays+               -> [TyCon]                      -- ^type constructors that need to be classified+               -> ( [TyCon]                    -- to be converted+                  , [TyCon]                    -- need not be converted (but could be)+                  , [TyCon]                    -- involve parallel arrays (whether converted or not)+                  , [TyCon]                    -- can't be converted+                  )+classifyTyCons convStatus parTyCons tcs = classify [] [] [] [] convStatus parTyCons (tyConGroups tcs)+  where+    classify conv keep par novect _  _   []               = (conv, keep, par, novect)+    classify conv keep par novect cs pts ((tcs, ds) : rs)+      | can_convert && must_convert+      = classify (tcs ++ conv) keep (par ++ tcs_par) novect (cs `addListToUFM` [(tc, True)  | tc <- tcs]) pts' rs+      | can_convert+      = classify conv (tcs ++ keep) (par ++ tcs_par) novect (cs `addListToUFM` [(tc, False) | tc <- tcs]) pts' rs+      | otherwise+      = classify conv keep (par ++ tcs_par) (tcs ++ novect) cs pts' rs+      where+        refs = ds `delListFromUniqSet` tcs++          -- the tycons that directly or indirectly depend on parallel arrays+        tcs_par | uniqSetAny ((`elemNameSet` parTyCons) . tyConName) refs = tcs+                | otherwise = []++        pts' = pts `extendNameSetList` map tyConName tcs_par++        can_convert  = (isEmptyUniqSet (filterUniqSet ((`elemNameSet` pts) . tyConName) (refs `uniqSetMinusUFM` cs))+                        && all convertable tcs)+                       || isShowClass tcs+        must_convert = anyUFM id (intersectUFM_C const cs (getUniqSet refs))+                       && (not . isShowClass $ tcs)++        -- We currently admit Haskell 2011-style data and newtype declarations as well as type+        -- constructors representing classes.+        convertable tc+          = (isDataTyCon tc || isNewTyCon tc) && all isVanillaDataCon (tyConDataCons tc)+            || isClassTyCon tc++        -- !!!FIXME: currently we allow 'Show' in vectorised code without actually providing a+        --   vectorised definition (to be able to vectorise 'Num')+        isShowClass [tc] = tyConName tc == showClassName+        isShowClass _    = False++-- Used to group type constructors into mutually dependent groups.+--+type TyConGroup = ([TyCon], UniqSet TyCon)++-- Compute mutually recursive groups of tycons in topological order.+--+tyConGroups :: [TyCon] -> [TyConGroup]+tyConGroups tcs = map mk_grp (stronglyConnCompFromEdgedVerticesUniq edges)+  where+    edges = [((tc, ds), tc, nonDetEltsUniqSet ds) | tc <- tcs+                                , let ds = tyConsOfTyCon tc]+            -- It's OK to use nonDetEltsUniqSet here as+            -- stronglyConnCompFromEdgedVertices is still deterministic even+            -- if the edges are in nondeterministic order as explained in+            -- Note [Deterministic SCC] in Digraph.++    mk_grp (AcyclicSCC (tc, ds)) = ([tc], ds)+    mk_grp (CyclicSCC els)       = (tcs, unionManyUniqSets dss)+      where+        (tcs, dss) = unzip els++-- |Collect the set of TyCons used by the representation of some data type.+--+tyConsOfTyCon :: TyCon -> UniqSet TyCon+tyConsOfTyCon = tyConsOfTypes . concatMap dataConRepArgTys . tyConDataCons++-- |Collect the set of TyCons that occur in these types.+--+tyConsOfTypes :: [Type] -> UniqSet TyCon+tyConsOfTypes = unionManyUniqSets . map tyConsOfType++-- |Collect the set of TyCons that occur in this type.+--+tyConsOfType :: Type -> UniqSet TyCon+tyConsOfType ty = filterUniqSet not_tuple_or_unlifted $ Type.tyConsOfType ty+  where not_tuple_or_unlifted tc = not (isUnliftedTyCon tc || isTupleTyCon tc)+
+ vectorise/Vectorise/Type/Env.hs view
@@ -0,0 +1,455 @@+{-# LANGUAGE CPP #-}++-- Vectorise a modules type and class declarations.+--+-- This produces new type constructors and family instances top be included in the module toplevel+-- as well as bindings for worker functions, dfuns, and the like.++module Vectorise.Type.Env (+  vectTypeEnv,+) where++#include "HsVersions.h"++import Vectorise.Env+import Vectorise.Vect+import Vectorise.Monad+import Vectorise.Builtins+import Vectorise.Type.TyConDecl+import Vectorise.Type.Classify+import Vectorise.Generic.PADict+import Vectorise.Generic.PAMethods+import Vectorise.Generic.PData+import Vectorise.Generic.Description+import Vectorise.Utils++import CoreSyn+import CoreUtils+import CoreUnfold+import DataCon+import TyCon+import CoAxiom+import Type+import FamInstEnv+import Id+import MkId+import NameEnv+import NameSet+import UniqFM+import OccName+import Unique++import Util+import Outputable+import DynFlags+import FastString+import MonadUtils++import Control.Monad+import Data.Maybe+import Data.List+++-- Note [Pragmas to vectorise tycons]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- All imported type constructors that are not mapped to a vectorised type in the vectorisation map+-- (possibly because the defining module was not compiled with vectorisation) may be used in scalar+-- code encapsulated in vectorised code. If a such a type constructor 'T' is a member of the+-- 'Scalar' class (and hence also of 'PData' and 'PRepr'), it may also be used in vectorised code,+-- where 'T' represents itself, but the representation of 'T' still remains opaque in vectorised+-- code (i.e., it can only be used in scalar code).+--+-- An example is the treatment of 'Int'. 'Int's can be used in vectorised code and remain unchanged+-- by vectorisation.  However, the representation of 'Int' by the 'I#' data constructor wrapping an+-- 'Int#' is not exposed in vectorised code. Instead, computations involving the representation need+-- to be confined to scalar code.+--+-- VECTORISE pragmas for type constructors cover four different flavours of vectorising data type+-- constructors:+--+-- (1) Data type constructor 'T' that together with its constructors 'Cn' may be used in vectorised+--     code, where 'T' and the 'Cn' are automatically vectorised in the same manner as data types+--     declared in a vectorised module.  This includes the case where the vectoriser determines that+--     the original representation of 'T' may be used in vectorised code (as it does not embed any+--     parallel arrays.)  This case is for type constructors that are *imported* from a non-+--     vectorised module, but that we want to use with full vectorisation support.+--+--     An example is the treatment of 'Ordering' and '[]'.  The former remains unchanged by+--     vectorisation, whereas the latter is fully vectorised.+--+--     'PData' and 'PRepr' instances are automatically generated by the vectoriser.+--+--     Type constructors declared with {-# VECTORISE type T #-} are treated in this manner.+--+-- (2) Data type constructor 'T' that may be used in vectorised code, where 'T' is represented by an+--     explicitly given 'Tv', but the representation of 'T' is opaque in vectorised code (i.e., the+--     constructors of 'T' may not occur in vectorised code).+--+--     An example is the treatment of '[::]'. The type '[::]' can be used in vectorised code and is+--     vectorised to 'PArray'. However, the representation of '[::]' is not exposed in vectorised+--     code. Instead, computations involving the representation need to be confined to scalar code.+--+--     'PData' and 'PRepr' instances need to be explicitly supplied for 'T' (they are not generated+--     by the vectoriser).+--+--     Type constructors declared with {-# VECTORISE type T = Tv #-} are treated in this manner+--     manner. (The vectoriser never treats a type constructor automatically in this manner.)+--+-- (3) Data type constructor 'T' that does not contain any parallel arrays and has explicitly+--     provided 'PData' and 'PRepr' instances (and maybe also a 'Scalar' instance), which together+--     with the type's constructors 'Cn' may be used in vectorised code. The type 'T' and its+--     constructors 'Cn' are represented by themselves in vectorised code.+--+--     An example is 'Bool', which is represented by itself in vectorised code (as it cannot embed+--     any parallel arrays).  However, we do not want any automatic generation of class and family+--     instances, which is why Case (1) does not apply.+--+--     'PData' and 'PRepr' instances need to be explicitly supplied for 'T' (they are not generated+--     by the vectoriser).+--+--     Type constructors declared with {-# VECTORISE SCALAR type T #-} are treated in this manner.+--+-- (4) Data type constructor 'T' that does not contain any parallel arrays and that, in vectorised+--     code, is represented by an explicitly given 'Tv', but the representation of 'T' is opaque in+--     vectorised code and 'T' is regarded to be scalar — i.e., it may be used in encapsulated+--     scalar subcomputations.+--+--     An example is the treatment of '(->)'. Types '(->)' can be used in vectorised code and are+--     vectorised to '(:->)'.  However, the representation of '(->)' is not exposed in vectorised+--     code. Instead, computations involving the representation need to be confined to scalar code+--     and may be part of encapsulated scalar computations.+--+--     'PData' and 'PRepr' instances need to be explicitly supplied for 'T' (they are not generated+--     by the vectoriser).+--+--     Type constructors declared with {-# VECTORISE SCALAR type T = Tv #-} are treated in this+--     manner. (The vectoriser never treats a type constructor automatically in this manner.)+--+-- In addition, we have also got a single pragma form for type classes: {-# VECTORISE class C #-}.+-- It implies that the class type constructor may be used in vectorised code together with its data+-- constructor.  We generally produce a vectorised version of the data type and data constructor.+-- We do not generate 'PData' and 'PRepr' instances for class type constructors.  This pragma is the+-- default for all type classes declared in a vectorised module, but the pragma can also be used+-- explitly on imported classes.++-- Note [Vectorising classes]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- We vectorise classes essentially by just vectorising their desugared Core representation, but we+-- do generate a 'Class' structure along the way (see 'Vectorise.Type.TyConDecl.vectTyConDecl').+--+-- Here is an example illustrating the mapping — assume+--+--   class Num a where+--     (+) :: a -> a -> a+--+-- It desugars to+--+--   data Num a = D:Num { (+) :: a -> a -> a }+--+-- which we vectorise to+--+--  data V:Num a = D:V:Num { ($v+) :: PArray a :-> PArray a :-> PArray a }+--+-- while adding the following entries to the vectorisation map:+--+--   tycon  : Num   --> V:Num+--   datacon: D:Num --> D:V:Num+--   var    : (+) --> ($v+)++-- |Vectorise type constructor including class type constructors.+--+vectTypeEnv :: [TyCon]                   -- Type constructors defined in this module+            -> [CoreVect]                -- All 'VECTORISE [SCALAR] type' declarations in this module+            -> [CoreVect]                -- All 'VECTORISE class' declarations in this module+            -> VM ( [TyCon]              -- old TyCons ++ new TyCons+                  , [FamInst]            -- New type family instances.+                  , [(Var, CoreExpr)])   -- New top level bindings.+vectTypeEnv tycons vectTypeDecls vectClassDecls+  = do { traceVt "** vectTypeEnv" $ ppr tycons++       ; let   -- {-# VECTORISE type T -#} (ONLY the imported tycons)+             impVectTyCons          = (   [tycon | VectType False tycon Nothing <- vectTypeDecls]+                                       ++ [tycon | VectClass tycon              <- vectClassDecls])+                                      \\ tycons++               -- {-# VECTORISE type T = Tv -#} (imported & local tycons with an /RHS/)+             vectTyConsWithRHS      = [ (tycon, rhs)+                                      | VectType False tycon (Just rhs) <- vectTypeDecls]++               -- {-# VECTORISE SCALAR type T = Tv -#} (imported & local tycons with an /RHS/)+             scalarTyConsWithRHS    = [ (tycon, rhs)+                                      | VectType True  tycon (Just rhs) <- vectTypeDecls]++               -- {-# VECTORISE SCALAR type T -#} (imported & local /scalar/ tycons without an RHS)+             scalarTyConsNoRHS      = [tycon | VectType True tycon Nothing <- vectTypeDecls]++               -- Check that is not a VECTORISE SCALAR tycon nor VECTORISE tycons with explicit rhs?+             vectSpecialTyConNames  = mkNameSet . map tyConName $+                                        scalarTyConsNoRHS +++                                        map fst (vectTyConsWithRHS ++ scalarTyConsWithRHS)+             notVectSpecialTyCon tc = not $ (tyConName tc) `elemNameSet` vectSpecialTyConNames++         -- Build a map containing all vectorised type constructor. If the vectorised type+         -- constructor differs from the original one, then it is mapped to 'True'; if they are+         -- both the same, then it maps to 'False'.+       ; vectTyCons          <- globalVectTyCons+       ; let vectTyConBase    = mapUFM_Directly isDistinct vectTyCons    -- 'True' iff tc /= V[[tc]]+             isDistinct u tc  = u /= getUnique tc+             vectTyConFlavour = vectTyConBase+                                `plusNameEnv`+                                mkNameEnv [ (tyConName tycon, True)+                                          | (tycon, _) <- vectTyConsWithRHS ++ scalarTyConsWithRHS]+                                `plusNameEnv`+                                mkNameEnv [ (tyConName tycon, False)  -- original representation+                                          | tycon <- scalarTyConsNoRHS]+++           -- Split the list of 'TyCons' into the ones (1) that we must vectorise and those (2)+           -- that we could, but don't need to vectorise.  Type constructors that are not data+           -- type constructors or use non-Haskell98 features are being dropped.  They may not+           -- appear in vectorised code.  (We also drop the local type constructors appearing in a+           -- VECTORISE SCALAR pragma or a VECTORISE pragma with an explicit right-hand side, as+           -- these are being handled separately.  NB: Some type constructors may be marked SCALAR+           -- /and/ have an explicit right-hand side.)+           --+           -- Furthermore, 'par_tcs' are those type constructors (converted or not) whose+           -- definition, directly or indirectly, depends on parallel arrays. Finally, 'drop_tcs'+           -- are all type constructors that cannot be vectorised.+       ; parallelTyCons <- (`extendNameSetList` map (tyConName . fst) vectTyConsWithRHS) <$>+                             globalParallelTyCons+       ; let maybeVectoriseTyCons = filter notVectSpecialTyCon tycons ++ impVectTyCons+             (conv_tcs, keep_tcs, par_tcs, drop_tcs)+               = classifyTyCons vectTyConFlavour parallelTyCons maybeVectoriseTyCons++       ; traceVt " known parallel : " $ ppr parallelTyCons+       ; traceVt " VECT SCALAR    : " $ ppr (scalarTyConsNoRHS ++ map fst scalarTyConsWithRHS)+       ; traceVt " VECT [class]   : " $ ppr impVectTyCons+       ; traceVt " VECT with rhs  : " $ ppr (map fst (vectTyConsWithRHS ++ scalarTyConsWithRHS))+       ; traceVt " -- after classification (local and VECT [class] tycons) --" Outputable.empty+       ; traceVt " reuse          : " $ ppr keep_tcs+       ; traceVt " convert        : " $ ppr conv_tcs++           -- warn the user about unvectorised type constructors+       ; let explanation    = text "(They use unsupported language extensions"+                          $$  text "or depend on type constructors that are" <+>+                              text "not vectorised)"+             drop_tcs_nosyn = filter (not . isTypeFamilyTyCon) .+                              filter (not . isTypeSynonymTyCon) $ drop_tcs+       ; unless (null drop_tcs_nosyn) $+           emitVt "Warning: cannot vectorise these type constructors:" $+             pprQuotedList drop_tcs_nosyn $$ explanation++       ; mapM_ addParallelTyConAndCons $ par_tcs ++ map fst vectTyConsWithRHS++       ; let mapping =+                    -- Type constructors that we found we don't need to vectorise and those+                    -- declared VECTORISE SCALAR /without/ an explicit right-hand side, use the same+                    -- representation in both unvectorised and vectorised code; they are not+                    -- abstract.+                  [(tycon, tycon, False) | tycon <- keep_tcs ++ scalarTyConsNoRHS]+                    -- We do the same for type constructors declared VECTORISE SCALAR /without/+                    -- an explicit right-hand side+               ++ [(tycon, vTycon, True) | (tycon, vTycon) <- vectTyConsWithRHS ++ scalarTyConsWithRHS]+       ; syn_tcs <- catMaybes <$> mapM defTyConDataCons mapping++           -- Vectorise all the data type declarations that we can and must vectorise (enter the+           -- type and data constructors into the vectorisation map on-the-fly.)+       ; new_tcs <- vectTyConDecls conv_tcs++       ; let dumpTc tc vTc = traceVt "---" (ppr tc <+> text "::" <+> ppr (dataConSig tc) $$+                                            ppr vTc <+> text "::" <+> ppr (dataConSig vTc))+             dataConSig tc | Just dc <- tyConSingleDataCon_maybe tc = dataConRepType dc+                           | otherwise                              = panic "dataConSig"+       ; zipWithM_ dumpTc (filter isClassTyCon conv_tcs) (filter isClassTyCon new_tcs)++           -- We don't need new representation types for dictionary constructors. The constructors+           -- are always fully applied, and we don't need to lift them to arrays as a dictionary+           -- of a particular type always has the same value.+       ; let orig_tcs = filter (not . isClassTyCon) $ keep_tcs ++ conv_tcs+             vect_tcs = filter (not . isClassTyCon) $ keep_tcs ++ new_tcs++           -- Build 'PRepr' and 'PData' instance type constructors and family instances for all+           -- type constructors with vectorised representations.+       ; reprs      <- mapM tyConRepr vect_tcs+       ; repr_fis   <- zipWith3M buildPReprTyCon  orig_tcs vect_tcs reprs+       ; pdata_fis  <- zipWith3M buildPDataTyCon  orig_tcs vect_tcs reprs+       ; pdatas_fis <- zipWith3M buildPDatasTyCon orig_tcs vect_tcs reprs++       ; let fam_insts  = repr_fis ++ pdata_fis ++ pdatas_fis+             repr_axs   = map famInstAxiom repr_fis+             pdata_tcs  = famInstsRepTyCons pdata_fis+             pdatas_tcs = famInstsRepTyCons pdatas_fis++       ; updGEnv $ extendFamEnv fam_insts++           -- Generate workers for the vectorised data constructors, dfuns for the 'PA' instances of+           -- the vectorised type constructors, and associate the type constructors with their dfuns+           -- in the global environment.  We get back the dfun bindings (which we will subsequently+           -- inject into the modules toplevel).+       ; (_, binds) <- fixV $ \ ~(dfuns, _) ->+           do { defTyConPAs (zipLazy vect_tcs dfuns)++                  -- Query the 'PData' instance type constructors for type constructors that have a+                  -- VECTORISE SCALAR type pragma without an explicit right-hand side (this is Item+                  --  (3) of "Note [Pragmas to vectorise tycons]" above).+              ; pdata_scalar_tcs <- mapM pdataReprTyConExact scalarTyConsNoRHS++                  -- Build workers for all vectorised data constructors (except abstract ones)+              ; sequence_ $+                  zipWith3 vectDataConWorkers (orig_tcs  ++ scalarTyConsNoRHS)+                                              (vect_tcs  ++ scalarTyConsNoRHS)+                                              (pdata_tcs ++ pdata_scalar_tcs)++                  -- Build a 'PA' dictionary for all type constructors (except abstract ones & those+                  -- defined with an explicit right-hand side where the dictionary is user-supplied)+              ; dfuns <- sequence $+                           zipWith4 buildTyConPADict+                                    vect_tcs+                                    repr_axs+                                    pdata_tcs+                                    pdatas_tcs++              ; binds <- takeHoisted+              ; return (dfuns, binds)+              }++           -- Return the vectorised variants of type constructors as well as the generated instance+           -- type constructors, family instances, and dfun bindings.+       ; return ( new_tcs ++ pdata_tcs ++ pdatas_tcs ++ syn_tcs+                , fam_insts, binds)+       }+  where+    addParallelTyConAndCons tycon+      = do+        { addGlobalParallelTyCon tycon+        ; mapM_ addGlobalParallelVar [ id | dc <- tyConDataCons tycon+                                          , AnId id <- dataConImplicitTyThings dc ]+                                          -- Ignoring the promoted tycon; hope that's ok+        }++    -- Add a mapping from the original to vectorised type constructor to the vectorisation map.+    -- Unless the type constructor is abstract, also mappings from the original's data constructors+    -- to the vectorised type's data constructors.+    --+    -- We have three cases: (1) original and vectorised type constructor are the same, (2) the+    -- name of the vectorised type constructor is canonical (as prescribed by 'mkVectTyConOcc'), or+    -- (3) the name is not canonical.  In the third case, we additionally introduce a type synonym+    -- with the canonical name that is set equal to the non-canonical name (so that we find the+    -- right type constructor when reading vectorisation information from interface files).+    --+    defTyConDataCons (origTyCon, vectTyCon, isAbstract)+      = do+        { canonName <- mkLocalisedName mkVectTyConOcc origName+        ; if    origName == vectName                             -- Case (1)+             || vectName == canonName                            -- Case (2)+          then do+          { defTyCon origTyCon vectTyCon                         -- T  --> vT+          ; defDataCons                                          -- Ci --> vCi+          ; return Nothing+          }+          else do                                                 -- Case (3)+          { let synTyCon = mkSyn canonName (mkTyConTy vectTyCon)  -- type S = vT+          ; defTyCon origTyCon synTyCon                           -- T  --> S+          ; defDataCons                                           -- Ci --> vCi+          ; return $ Just synTyCon+          }+        }+      where+        origName  = tyConName origTyCon+        vectName  = tyConName vectTyCon++        mkSyn canonName ty = buildSynTyCon canonName [] (typeKind ty) [] ty++        defDataCons+          | isAbstract = return ()+          | otherwise+          = do { MASSERT(length (tyConDataCons origTyCon) == length (tyConDataCons vectTyCon))+               ; zipWithM_ defDataCon (tyConDataCons origTyCon) (tyConDataCons vectTyCon)+               }+++-- Helpers --------------------------------------------------------------------++buildTyConPADict :: TyCon -> CoAxiom Unbranched -> TyCon -> TyCon -> VM Var+buildTyConPADict vect_tc prepr_ax pdata_tc pdatas_tc+ = tyConRepr vect_tc >>= buildPADict vect_tc prepr_ax pdata_tc pdatas_tc++-- Produce a custom-made worker for the data constructors of a vectorised data type.  This includes+-- all data constructors that may be used in vectorised code — i.e., all data constructors of data+-- types with 'VECTORISE [SCALAR] type' pragmas with an explicit right-hand side.  Also adds a mapping+-- from the original to vectorised worker into the vectorisation map.+--+-- FIXME: It's not nice that we need create a special worker after the data constructors has+--   already been constructed.  Also, I don't think the worker is properly added to the data+--   constructor.  Seems messy.+vectDataConWorkers :: TyCon -> TyCon -> TyCon -> VM ()+vectDataConWorkers orig_tc vect_tc arr_tc+  = do { traceVt "Building vectorised worker for datatype" (ppr orig_tc)++       ; bs <- sequence+             . zipWith3 def_worker  (tyConDataCons orig_tc) rep_tys+             $ zipWith4 mk_data_con (tyConDataCons vect_tc)+                                    rep_tys+                                    (inits rep_tys)+                                    (tail $ tails rep_tys)+        ; mapM_ (uncurry hoistBinding) bs+        }+  where+    tyvars   = tyConTyVars vect_tc+    var_tys  = mkTyVarTys tyvars+    ty_args  = map Type var_tys+    res_ty   = mkTyConApp vect_tc var_tys++    cons     = tyConDataCons vect_tc+    arity    = length cons+    [arr_dc] = tyConDataCons arr_tc++    rep_tys  = map dataConRepArgTys $ tyConDataCons vect_tc++    mk_data_con con tys pre post+      = do dflags <- getDynFlags+           liftM2 (,) (vect_data_con con)+                      (lift_data_con tys pre post (mkDataConTag dflags con))++    sel_replicate len tag+      | arity > 1 = do+                      rep <- builtin (selReplicate arity)+                      return [rep `mkApps` [len, tag]]++      | otherwise = return []++    vect_data_con con = return $ mkConApp con ty_args+    lift_data_con tys pre_tys post_tys tag+      = do+          len  <- builtin liftingContext+          args <- mapM (newLocalVar (fsLit "xs"))+                  =<< mapM mkPDataType tys++          sel  <- sel_replicate (Var len) tag++          pre   <- mapM emptyPD (concat pre_tys)+          post  <- mapM emptyPD (concat post_tys)++          return . mkLams (len : args)+                 . wrapFamInstBody arr_tc var_tys+                 . mkConApp arr_dc+                 $ ty_args ++ sel ++ pre ++ map Var args ++ post++    def_worker data_con arg_tys mk_body+      = do+          arity <- polyArity tyvars+          body <- closedV+                . inBind orig_worker+                . polyAbstract tyvars $ \args ->+                  liftM (mkLams (tyvars ++ args) . vectorised)+                $ buildClosures tyvars [] [] arg_tys res_ty mk_body++          raw_worker <- mkVectId orig_worker (exprType body)+          let vect_worker = raw_worker `setIdUnfolding`+                              mkInlineUnfoldingWithArity arity body+          defGlobalVar orig_worker vect_worker+          return (vect_worker, body)+      where+        orig_worker = dataConWorkId data_con
+ vectorise/Vectorise/Type/TyConDecl.hs view
@@ -0,0 +1,214 @@++module Vectorise.Type.TyConDecl (+  vectTyConDecls+) where++import Vectorise.Type.Type+import Vectorise.Monad+import Vectorise.Env( GlobalEnv( global_fam_inst_env ) )+import BuildTyCl( TcMethInfo, buildClass, buildDataCon, newTyConRepName )+import OccName+import Class+import Type+import TyCon+import DataCon+import DynFlags+import BasicTypes( DefMethSpec(..) )+import SrcLoc( SrcSpan, noSrcSpan )+import Var+import Name+import Outputable+import Util+import Control.Monad+++-- |Vectorise some (possibly recursively defined) type constructors.+--+vectTyConDecls :: [TyCon] -> VM [TyCon]+vectTyConDecls tcs = fixV $ \tcs' ->+  do { names' <- mapM (mkLocalisedName mkVectTyConOcc . tyConName) tcs+     ; mapM_ (uncurry (uncurry defTyConName)) (tcs `zip` names' `zipLazy` tcs')+     ; zipWithM vectTyConDecl tcs names'+     }++-- |Vectorise a single type constructor.+--+vectTyConDecl :: TyCon -> Name -> VM TyCon+vectTyConDecl tycon name'++      -- Type constructor representing a type class+  | Just cls <- tyConClass_maybe tycon+  = do { unless (null $ classATs cls) $+           do dflags <- getDynFlags+              cantVectorise dflags "Associated types are not yet supported" (ppr cls)++           -- vectorise superclass constraint (types)+       ; theta' <- mapM vectType (classSCTheta cls)++           -- vectorise method selectors+       ; let opItems      = classOpItems cls+             Just datacon = tyConSingleDataCon_maybe tycon+             argTys       = dataConRepArgTys datacon                      -- all selector types+             opTys        = drop (length argTys - length opItems) argTys  -- only method types+       ; methods' <- sequence [ vectMethod id meth ty | ((id, meth), ty) <- zip opItems opTys]++           -- construct the vectorised class (this also creates the class type constructors and its+           -- data constructor)+           --+           -- NB: 'buildClass' attaches new quantifiers and dictionaries to the method types+       ; cls' <- liftDs $+                   buildClass+                     name'                      -- new name: "V:Class"+                     (tyConBinders tycon)       -- keep original kind+                     (map (const Nominal) (tyConRoles tycon)) -- all role are N for safety+                     (snd . classTvsFds $ cls)  -- keep the original functional dependencies+                     (Just (+                         theta',                 -- superclasses+                         [],                     -- no associated types (for the moment)+                         methods',               -- method info+                         (classMinimalDef cls))) -- Inherit minimal complete definition from cls++           -- the original dictionary constructor must map to the vectorised one+       ; let tycon'        = classTyCon cls'+             Just datacon  = tyConSingleDataCon_maybe tycon+             Just datacon' = tyConSingleDataCon_maybe tycon'+       ; defDataCon datacon datacon'++           -- the original superclass and methods selectors must map to the vectorised ones+       ; let selIds  = classAllSelIds cls+             selIds' = classAllSelIds cls'+       ; zipWithM_ defGlobalVar selIds selIds'++           -- return the type constructor of the vectorised class+       ; return tycon'+       }++       -- Regular algebraic type constructor — for now, Haskell 2011-style only+  | isAlgTyCon tycon+  = do { unless (all isVanillaDataCon (tyConDataCons tycon)) $+           do dflags <- getDynFlags+              cantVectorise dflags "Currently only Haskell 2011 datatypes are supported" (ppr tycon)++           -- vectorise the data constructor of the class tycon+       ; rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon)++           -- keep the original GADT flags+       ; let gadt_flag = isGadtSyntaxTyCon tycon++           -- build the vectorised type constructor+       ; tc_rep_name <- mkDerivedName mkTyConRepOcc name'+       ; return $ mkAlgTyCon+                    name'                   -- new name+                    (tyConBinders tycon)+                    (tyConResKind tycon)    -- keep original kind+                    (map (const Nominal) (tyConRoles tycon)) -- all roles are N for safety+                    Nothing+                    []                      -- no stupid theta+                    rhs'                    -- new constructor defs+                    (VanillaAlgTyCon tc_rep_name)+                    gadt_flag               -- whether in GADT syntax+       }++  -- some other crazy thing that we don't handle+  | otherwise+  = do dflags <- getDynFlags+       cantVectorise dflags "Can't vectorise exotic type constructor" (ppr tycon)++-- |Vectorise a class method.  (Don't enter it into the vectorisation map yet.)+--+vectMethod :: Id -> DefMethInfo -> Type -> VM TcMethInfo+vectMethod id defMeth ty+ = do {   -- Vectorise the method type.+      ; ty' <- vectType ty++          -- Create a name for the vectorised method.+      ; id' <- mkVectId id ty'++      ; return  (Var.varName id', ty', defMethSpecOfDefMeth defMeth)+      }++-- | Convert a `DefMethInfo` to a `DefMethSpec`, which discards the name field in+--   the `DefMeth` constructor of the `DefMeth`.+defMethSpecOfDefMeth :: DefMethInfo -> Maybe (DefMethSpec (SrcSpan, Type))+defMethSpecOfDefMeth Nothing = Nothing+defMethSpecOfDefMeth (Just (_, VanillaDM))    = Just VanillaDM+defMethSpecOfDefMeth (Just (_, GenericDM ty)) = Just (GenericDM (noSrcSpan, ty))++-- |Vectorise the RHS of an algebraic type.+--+vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs+vectAlgTyConRhs tc (AbstractTyCon {})+  = do dflags <- getDynFlags+       cantVectorise dflags "Can't vectorise imported abstract type" (ppr tc)+vectAlgTyConRhs _tc (DataTyCon { data_cons = data_cons+                               , is_enum   = is_enum+                               })+  = do { data_cons' <- mapM vectDataCon data_cons+       ; zipWithM_ defDataCon data_cons data_cons'+       ; return $ DataTyCon { data_cons = data_cons'+                            , is_enum   = is_enum+                            }+       }++vectAlgTyConRhs tc (TupleTyCon { data_con = con })+  = vectAlgTyConRhs tc (DataTyCon { data_cons = [con], is_enum = False })+    -- I'm not certain this is what you want to do for tuples,+    -- but it's the behaviour we had before I refactored the+    -- representation of AlgTyConRhs to add tuples++vectAlgTyConRhs tc (SumTyCon { data_cons = cons })+  = -- FIXME (osa): I'm pretty sure this is broken.. TupleTyCon case is probably+    -- also broken when the tuple is unboxed.+    vectAlgTyConRhs tc (DataTyCon { data_cons = cons+                                  , is_enum = all (((==) 0) . dataConRepArity) cons })++vectAlgTyConRhs tc (NewTyCon {})+  = do dflags <- getDynFlags+       cantVectorise dflags noNewtypeErr (ppr tc)+  where+    noNewtypeErr = "Vectorisation of newtypes not supported yet; please use a 'data' declaration"++-- |Vectorise a data constructor by vectorising its argument and return types..+--+vectDataCon :: DataCon -> VM DataCon+vectDataCon dc+  | not . null $ ex_tvs+  = do dflags <- getDynFlags+       cantVectorise dflags "Can't vectorise constructor with existential type variables yet" (ppr dc)+  | not . null $ eq_spec+  = do dflags <- getDynFlags+       cantVectorise dflags "Can't vectorise constructor with equality context yet" (ppr dc)+  | not . null $ dataConFieldLabels dc+  = do dflags <- getDynFlags+       cantVectorise dflags "Can't vectorise constructor with labelled fields yet" (ppr dc)+  | not . null $ theta+  = do dflags <- getDynFlags+       cantVectorise dflags "Can't vectorise constructor with constraint context yet" (ppr dc)+  | otherwise+  = do { name'   <- mkLocalisedName mkVectDataConOcc name+       ; tycon'  <- vectTyCon tycon+       ; arg_tys <- mapM vectType rep_arg_tys+       ; let ret_ty = mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs)+       ; fam_envs  <- readGEnv global_fam_inst_env+       ; rep_nm    <- liftDs $ newTyConRepName name'+       ; liftDs $ buildDataCon fam_envs+                    name'+                    (dataConIsInfix dc)            -- infix if the original is+                    rep_nm+                    (dataConSrcBangs dc)           -- strictness as original constructor+                    (Just $ dataConImplBangs dc)+                    []                             -- no labelled fields for now+                    univ_bndrs                     -- universally quantified vars+                    []                             -- no existential tvs for now+                    []                             -- no equalities for now+                    []                             -- no context for now+                    arg_tys                        -- argument types+                    ret_ty                         -- return type+                    tycon'                         -- representation tycon+       }+  where+    name        = dataConName dc+    rep_arg_tys = dataConRepArgTys dc+    tycon       = dataConTyCon dc+    (univ_tvs, ex_tvs, eq_spec, theta, _arg_tys, _res_ty) = dataConFullSig dc+    univ_bndrs  = dataConUnivTyVarBinders dc
+ vectorise/Vectorise/Type/Type.hs view
@@ -0,0 +1,87 @@+-- Apply the vectorisation transformation to types. This is the \mathcal{L}_t scheme in HtM.++module Vectorise.Type.Type+  ( vectTyCon+  , vectAndLiftType+  , vectType+  )+where++import Vectorise.Utils+import Vectorise.Monad+import Vectorise.Builtins+import TcType+import Type+import TyCoRep+import TyCon+import Control.Monad+import Control.Applicative+import Data.Maybe+import Outputable+import Prelude -- avoid redundant import warning due to AMP++-- |Vectorise a type constructor. Unless there is a vectorised version (stripped of embedded+-- parallel arrays), the vectorised version is the same as the original.+--+vectTyCon :: TyCon -> VM TyCon+vectTyCon tc = maybe tc id <$> lookupTyCon tc++-- |Produce the vectorised and lifted versions of a type.+--+-- NB: Here we are limited to properly handle predicates at the toplevel only.  Anything embedded+--     in what is called the 'body_ty' below will end up as an argument to the type family 'PData'.+--+vectAndLiftType :: Type -> VM (Type, Type)+vectAndLiftType ty | Just ty' <- coreView ty = vectAndLiftType ty'+vectAndLiftType ty+  = do { padicts  <- liftM catMaybes $ mapM paDictArgType tyvars+       ; vmono_ty <- vectType mono_ty+       ; lmono_ty <- mkPDataType vmono_ty+       ; return (abstractType tyvars (padicts ++ theta) vmono_ty,+                 abstractType tyvars (padicts ++ theta) lmono_ty)+       }+  where+    (tyvars, phiTy)  = splitForAllTys ty+    (theta, mono_ty) = tcSplitPhiTy phiTy++-- |Vectorise a type.+--+-- For each quantified var we need to add a PA dictionary out the front of the type.+-- So          forall a.         C  a => a -> a+-- turns into  forall a. PA a => Cv a => a :-> a+--+vectType :: Type -> VM Type+vectType ty+  | Just ty'  <- coreView ty+  = vectType ty'+vectType (TyVarTy tv)      = return $ TyVarTy tv+vectType (LitTy l)         = return $ LitTy l+vectType (AppTy ty1 ty2)   = AppTy <$> vectType ty1 <*> vectType ty2+vectType (TyConApp tc tys) = TyConApp <$> vectTyCon tc <*> mapM vectType tys+vectType (FunTy ty1 ty2)+  | isPredTy ty1+  = mkFunTy <$> vectType ty1 <*> vectType ty2   -- don't build a closure for dictionary abstraction+  | otherwise+  = TyConApp <$> builtin closureTyCon <*> mapM vectType [ty1, ty2]+vectType ty@(ForAllTy {})+ = do {   -- strip off consecutive foralls+      ; let (tyvars, tyBody) = splitForAllTys ty++          -- vectorise the body+      ; vtyBody <- vectType tyBody++          -- make a PA dictionary for each of the type variables+      ; dictsPA <- liftM catMaybes $ mapM paDictArgType tyvars++          -- add the PA dictionaries after the foralls+      ; return $ abstractType tyvars dictsPA vtyBody+      }+vectType ty@(CastTy {})+  = pprSorry "Vectorise.Type.Type.vectType: CastTy" (ppr ty)+vectType ty@(CoercionTy {})+  = pprSorry "Vectorise.Type.Type.vectType: CoercionTy" (ppr ty)++-- |Add quantified vars and dictionary parameters to the front of a type.+--+abstractType :: [TyVar] -> [Type] -> Type -> Type+abstractType tyvars dicts = mkInvForAllTys tyvars . mkFunTys dicts
+ vectorise/Vectorise/Utils.hs view
@@ -0,0 +1,165 @@+module Vectorise.Utils (+  module Vectorise.Utils.Base,+  module Vectorise.Utils.Closure,+  module Vectorise.Utils.Hoisting,+  module Vectorise.Utils.PADict,+  module Vectorise.Utils.Poly,++  -- * Annotated Exprs+  collectAnnTypeArgs,+  collectAnnDictArgs,+  collectAnnTypeBinders,+  collectAnnValBinders,+  isAnnTypeArg,++  -- * PD Functions+  replicatePD, emptyPD, packByTagPD,+  combinePD, liftPD,++  -- * Scalars+  isScalar, zipScalars, scalarClosure,++  -- * Naming+  newLocalVar+) where++import Vectorise.Utils.Base+import Vectorise.Utils.Closure+import Vectorise.Utils.Hoisting+import Vectorise.Utils.PADict+import Vectorise.Utils.Poly+import Vectorise.Monad+import Vectorise.Builtins+import CoreSyn+import CoreUtils+import Id+import Type+import Control.Monad+++-- Annotated Exprs ------------------------------------------------------------++collectAnnTypeArgs :: AnnExpr b ann -> (AnnExpr b ann, [Type])+collectAnnTypeArgs expr = go expr []+  where+    go (_, AnnApp f (_, AnnType ty)) tys = go f (ty : tys)+    go e                             tys = (e, tys)++collectAnnDictArgs :: AnnExpr Var ann -> (AnnExpr Var ann, [AnnExpr Var ann])+collectAnnDictArgs expr = go expr []+  where+    go e@(_, AnnApp f arg) dicts+      | isPredTy . exprType . deAnnotate $ arg = go f (arg : dicts)+      | otherwise                              = (e, dicts)+    go e                        dicts          = (e, dicts)++collectAnnTypeBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann)+collectAnnTypeBinders expr = go [] expr+  where+    go bs (_, AnnLam b e) | isTyVar b = go (b : bs) e+    go bs e                           = (reverse bs, e)++-- |Collect all consecutive value binders that are not dictionaries.+--+collectAnnValBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann)+collectAnnValBinders expr = go [] expr+  where+    go bs (_, AnnLam b e) | isId b+                          && (not . isPredTy . idType $ b) = go (b : bs) e+    go bs e                                                = (reverse bs, e)++isAnnTypeArg :: AnnExpr b ann -> Bool+isAnnTypeArg (_, AnnType _) = True+isAnnTypeArg _              = False+++-- PD "Parallel Data" Functions -----------------------------------------------+--+--   Given some data that has a PA dictionary, we can convert it to its+--   representation type, perform some operation on the data, then convert it back.+--+--   In the DPH backend, the types of these functions are defined+--   in dph-common/D.A.P.Lifted/PArray.hs+--++-- |An empty array of the given type.+--+emptyPD :: Type -> VM CoreExpr+emptyPD = paMethod emptyPDVar emptyPD_PrimVar++-- |Produce an array containing copies of a given element.+--+replicatePD :: CoreExpr     -- ^ Number of copies in the resulting array.+            -> CoreExpr     -- ^ Value to replicate.+            -> VM CoreExpr+replicatePD len x+  = liftM (`mkApps` [len,x])+        $ paMethod replicatePDVar replicatePD_PrimVar (exprType x)++-- |Select some elements from an array that correspond to a particular tag value and pack them into a new+-- array.+--+-- > packByTagPD Int# [:23, 42, 95, 50, 27, 49:]  3 [:1, 2, 1, 2, 3, 2:] 2+-- >   ==> [:42, 50, 49:]+--+packByTagPD :: Type       -- ^ Element type.+            -> CoreExpr   -- ^ Source array.+            -> CoreExpr   -- ^ Length of resulting array.+            -> CoreExpr   -- ^ Tag values of elements in source array.+            -> CoreExpr   -- ^ The tag value for the elements to select.+            -> VM CoreExpr+packByTagPD ty xs len tags t+  = liftM (`mkApps` [xs, len, tags, t])+          (paMethod packByTagPDVar packByTagPD_PrimVar ty)++-- |Combine some arrays based on a selector.  The selector says which source array to choose for each+-- element of the resulting array.+--+combinePD :: Type         -- ^ Element type+          -> CoreExpr     -- ^ Length of resulting array+          -> CoreExpr     -- ^ Selector.+          -> [CoreExpr]   -- ^ Arrays to combine.+          -> VM CoreExpr+combinePD ty len sel xs+  = liftM (`mkApps` (len : sel : xs))+          (paMethod (combinePDVar n) (combinePD_PrimVar n) ty)+  where+    n = length xs++-- |Like `replicatePD` but use the lifting context in the vectoriser state.+--+liftPD :: CoreExpr -> VM CoreExpr+liftPD x+  = do+      lc <- builtin liftingContext+      replicatePD (Var lc) x+++-- Scalars --------------------------------------------------------------------++isScalar :: Type -> VM Bool+isScalar ty+  = do+    { scalar <- builtin scalarClass+    ; existsInst scalar [ty]+    }++zipScalars :: [Type] -> Type -> VM CoreExpr+zipScalars arg_tys res_ty+  = do+    { scalar <- builtin scalarClass+    ; (dfuns, _) <- mapAndUnzipM (\ty -> lookupInst scalar [ty]) ty_args+    ; zipf <- builtin (scalarZip $ length arg_tys)+    ; return $ Var zipf `mkTyApps` ty_args `mkApps` map Var dfuns+    }+    where+      ty_args = arg_tys ++ [res_ty]++scalarClosure :: [Type] -> Type -> CoreExpr -> CoreExpr -> VM CoreExpr+scalarClosure arg_tys res_ty scalar_fun array_fun+  = do+    { ctr <- builtin (closureCtrFun $ length arg_tys)+    ; pas <- mapM paDictOfType (init arg_tys)+    ; return $ Var ctr `mkTyApps` (arg_tys ++ [res_ty])+                       `mkApps`   (pas ++ [scalar_fun, array_fun])+    }
+ vectorise/Vectorise/Utils/Base.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE CPP #-}++module Vectorise.Utils.Base+  ( voidType+  , newLocalVVar++  , mkDataConTag, dataConTagZ+  , mkWrapType+  , mkClosureTypes+  , mkPReprType+  , mkPDataType, mkPDatasType+  , splitPrimTyCon+  , mkBuiltinCo++  , wrapNewTypeBodyOfWrap+  , unwrapNewTypeBodyOfWrap+  , wrapNewTypeBodyOfPDataWrap+  , unwrapNewTypeBodyOfPDataWrap+  , wrapNewTypeBodyOfPDatasWrap+  , unwrapNewTypeBodyOfPDatasWrap++  , pdataReprTyCon+  , pdataReprTyConExact+  , pdatasReprTyConExact+  , pdataUnwrapScrut++  , preprFamInst+) where++import Vectorise.Monad+import Vectorise.Vect+import Vectorise.Builtins++import CoreSyn+import CoreUtils+import FamInstEnv+import Coercion+import Type+import TyCon+import DataCon+import MkId+import DynFlags+import FastString++#include "HsVersions.h"++-- Simple Types ---------------------------------------------------------------++voidType :: VM Type+voidType = mkBuiltinTyConApp voidTyCon []+++-- Name Generation ------------------------------------------------------------++newLocalVVar :: FastString -> Type -> VM VVar+newLocalVVar fs vty+  = do+      lty <- mkPDataType vty+      vv  <- newLocalVar fs vty+      lv  <- newLocalVar fs lty+      return (vv,lv)+++-- Constructors ---------------------------------------------------------------++mkDataConTag :: DynFlags -> DataCon -> CoreExpr+mkDataConTag dflags = mkIntLitInt dflags . dataConTagZ++dataConTagZ :: DataCon -> Int+dataConTagZ con = dataConTag con - fIRST_TAG+++-- Type Construction ----------------------------------------------------------++-- |Make an application of the 'Wrap' type constructor.+--+mkWrapType :: Type -> VM Type+mkWrapType ty = mkBuiltinTyConApp wrapTyCon [ty]++-- |Make an application of the closure type constructor.+--+mkClosureTypes :: [Type] -> Type -> VM Type+mkClosureTypes = mkBuiltinTyConApps closureTyCon++-- |Make an application of the 'PRepr' type constructor.+--+mkPReprType :: Type -> VM Type+mkPReprType ty = mkBuiltinTyConApp preprTyCon [ty]++-- | Make an application of the 'PData' tycon to some argument.+--+mkPDataType :: Type -> VM Type+mkPDataType ty = mkBuiltinTyConApp pdataTyCon [ty]++-- | Make an application of the 'PDatas' tycon to some argument.+--+mkPDatasType :: Type -> VM Type+mkPDatasType ty = mkBuiltinTyConApp pdatasTyCon [ty]++-- Make an application of a builtin type constructor to some arguments.+--+mkBuiltinTyConApp :: (Builtins -> TyCon) -> [Type] -> VM Type+mkBuiltinTyConApp get_tc tys+  = do { tc <- builtin get_tc+       ; return $ mkTyConApp tc tys+       }++-- Make a cascading application of a builtin type constructor.+--+mkBuiltinTyConApps :: (Builtins -> TyCon) -> [Type] -> Type -> VM Type+mkBuiltinTyConApps get_tc tys ty+ = do { tc <- builtin get_tc+      ; return $ foldr (mk tc) ty tys+      }+  where+    mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2]+++-- Type decomposition ---------------------------------------------------------++-- |Checks if a type constructor is defined in 'GHC.Prim' (e.g., 'Int#'); if so, returns it.+--+splitPrimTyCon :: Type -> Maybe TyCon+splitPrimTyCon ty+  | Just (tycon, []) <- splitTyConApp_maybe ty+  , isPrimTyCon tycon+  = Just tycon+  | otherwise = Nothing+++-- Coercion Construction -----------------------------------------------------++-- |Make a representational coercion to some builtin type.+--+mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion+mkBuiltinCo get_tc+  = do { tc <- builtin get_tc+       ; return $ mkTyConAppCo Representational tc []+       }+++-- Wrapping and unwrapping the 'Wrap' newtype ---------------------------------++-- |Apply the constructor wrapper of the 'Wrap' /newtype/.+--+wrapNewTypeBodyOfWrap :: CoreExpr -> Type -> VM CoreExpr+wrapNewTypeBodyOfWrap e ty+  = do { wrap_tc <- builtin wrapTyCon+       ; return $ wrapNewTypeBody wrap_tc [ty] e+       }++-- |Strip the constructor wrapper of the 'Wrap' /newtype/.+--+unwrapNewTypeBodyOfWrap :: CoreExpr -> Type -> VM CoreExpr+unwrapNewTypeBodyOfWrap e ty+  = do { wrap_tc <- builtin wrapTyCon+       ; return $ unwrapNewTypeBody wrap_tc [ty] e+       }++-- |Apply the constructor wrapper of the 'PData' /newtype/ instance of 'Wrap'.+--+wrapNewTypeBodyOfPDataWrap :: CoreExpr -> Type -> VM CoreExpr+wrapNewTypeBodyOfPDataWrap e ty+  = do { wrap_tc  <- builtin wrapTyCon+       ; pwrap_tc <- pdataReprTyConExact wrap_tc+       ; return $ wrapNewTypeBody pwrap_tc [ty] e+       }++-- |Strip the constructor wrapper of the 'PData' /newtype/ instance of 'Wrap'.+--+unwrapNewTypeBodyOfPDataWrap :: CoreExpr -> Type -> VM CoreExpr+unwrapNewTypeBodyOfPDataWrap e ty+  = do { wrap_tc  <- builtin wrapTyCon+       ; pwrap_tc <- pdataReprTyConExact wrap_tc+       ; return $ unwrapNewTypeBody pwrap_tc [ty] (unwrapFamInstScrut pwrap_tc [ty] e)+       }++-- |Apply the constructor wrapper of the 'PDatas' /newtype/ instance of 'Wrap'.+--+wrapNewTypeBodyOfPDatasWrap :: CoreExpr -> Type -> VM CoreExpr+wrapNewTypeBodyOfPDatasWrap e ty+  = do { wrap_tc  <- builtin wrapTyCon+       ; pwrap_tc <- pdatasReprTyConExact wrap_tc+       ; return $ wrapNewTypeBody pwrap_tc [ty] e+       }++-- |Strip the constructor wrapper of the 'PDatas' /newtype/ instance of 'Wrap'.+--+unwrapNewTypeBodyOfPDatasWrap :: CoreExpr -> Type -> VM CoreExpr+unwrapNewTypeBodyOfPDatasWrap e ty+  = do { wrap_tc  <- builtin wrapTyCon+       ; pwrap_tc <- pdatasReprTyConExact wrap_tc+       ; return $ unwrapNewTypeBody pwrap_tc [ty] (unwrapFamInstScrut pwrap_tc [ty] e)+       }+++-- 'PData' representation types ----------------------------------------------++-- |Get the representation tycon of the 'PData' data family for a given type.+--+-- This tycon does not appear explicitly in the source program — see Note [PData TyCons] in+-- 'Vectorise.Generic.Description':+--+--   @pdataReprTyCon {Sum2} = {PDataSum2}@+--+-- The type for which we look up a 'PData' instance may be more specific than the type in the+-- instance declaration.  In that case the second component of the result will be more specific than+-- a set of distinct type variables.+--+pdataReprTyCon :: Type -> VM (TyCon, [Type])+pdataReprTyCon ty+  = do+    { FamInstMatch { fim_instance = famInst+                   , fim_tys      = tys } <- builtin pdataTyCon >>= (`lookupFamInst` [ty])+    ; return (dataFamInstRepTyCon famInst, tys)+    }++-- |Get the representation tycon of the 'PData' data family for a given type constructor.+--+-- For example, for a binary type constructor 'T', we determine the representation type constructor+-- for 'PData (T a b)'.+--+pdataReprTyConExact :: TyCon -> VM TyCon+pdataReprTyConExact tycon+  = do {   -- look up the representation tycon; if there is a match at all, it will be be exact+       ;   -- (i.e.,' _tys' will be distinct type variables)+       ; (ptycon, _tys) <- pdataReprTyCon (tycon `mkTyConApp` mkTyVarTys (tyConTyVars tycon))+       ; return ptycon+       }++-- |Get the representation tycon of the 'PDatas' data family for a given type constructor.+--+-- For example, for a binary type constructor 'T', we determine the representation type constructor+-- for 'PDatas (T a b)'.+--+pdatasReprTyConExact :: TyCon -> VM TyCon+pdatasReprTyConExact tycon+  = do {   -- look up the representation tycon; if there is a match at all, it will be be exact+       ; (FamInstMatch { fim_instance = ptycon }) <- pdatasReprTyCon (tycon `mkTyConApp` mkTyVarTys (tyConTyVars tycon))+       ; return $ dataFamInstRepTyCon ptycon+       }+  where+    pdatasReprTyCon ty = builtin pdatasTyCon >>= (`lookupFamInst` [ty])++-- |Unwrap a 'PData' representation scrutinee.+--+pdataUnwrapScrut :: VExpr -> VM (CoreExpr, CoreExpr, DataCon)+pdataUnwrapScrut (ve, le)+  = do { (tc, arg_tys) <- pdataReprTyCon ty+       ; let [dc] = tyConDataCons tc+       ; return (ve, unwrapFamInstScrut tc arg_tys le, dc)+       }+  where+    ty = exprType ve+++-- 'PRepr' representation types ----------------------------------------------++-- |Get the representation tycon of the 'PRepr' type family for a given type.+--+preprFamInst :: Type -> VM FamInstMatch+preprFamInst ty = builtin preprTyCon >>= (`lookupFamInst` [ty])
+ vectorise/Vectorise/Utils/Closure.hs view
@@ -0,0 +1,161 @@+-- |Utils concerning closure construction and application.++module Vectorise.Utils.Closure+  ( mkClosure+  , mkClosureApp+  , buildClosures+  )+where++import Vectorise.Builtins+import Vectorise.Vect+import Vectorise.Monad+import Vectorise.Utils.Base+import Vectorise.Utils.PADict+import Vectorise.Utils.Hoisting++import CoreSyn+import Type+import MkCore+import CoreUtils+import TyCon+import DataCon+import MkId+import TysWiredIn+import BasicTypes( Boxity(..) )+import FastString+++-- |Make a closure.+--+mkClosure :: Type       -- ^ Type of the argument.+          -> Type       -- ^ Type of the result.+          -> Type       -- ^ Type of the environment.+          -> VExpr      -- ^ The function to apply.+          -> VExpr      -- ^ The environment to use.+          -> VM VExpr+mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv)+ = do dict <- paDictOfType env_ty+      mkv  <- builtin closureVar+      mkl  <- builtin liftedClosureVar+      return (Var mkv `mkTyApps` [arg_ty, res_ty, env_ty] `mkApps` [dict, vfn, lfn, venv],+              Var mkl `mkTyApps` [arg_ty, res_ty, env_ty] `mkApps` [dict, vfn, lfn, lenv])++-- |Make a closure application.+--+mkClosureApp :: Type      -- ^ Type of the argument.+             -> Type      -- ^ Type of the result.+             -> VExpr     -- ^ Closure to apply.+             -> VExpr     -- ^ Argument to use.+             -> VM VExpr+mkClosureApp arg_ty res_ty (vclo, lclo) (varg, larg)+ = do vapply <- builtin applyVar+      lapply <- builtin liftedApplyVar+      lc     <- builtin liftingContext+      return (Var vapply `mkTyApps` [arg_ty, res_ty] `mkApps` [vclo, varg],+              Var lapply `mkTyApps` [arg_ty, res_ty] `mkApps` [Var lc, lclo, larg])++-- |Build a set of 'n' closures corresponding to an 'n'-ary vectorised function.  The length of+-- the list of types of arguments determines the arity.+--+-- In addition to a set of type variables, a set of value variables is passed during closure+-- /construction/.  In contrast, the closure environment and the arguments are passed during closure+-- application.+--+buildClosures :: [TyVar]    -- ^ Type variables passed during closure construction.+              -> [Var]      -- ^ Variables passed during closure construction.+              -> [VVar]     -- ^ Variables in the environment.+              -> [Type]     -- ^ Type of the arguments.+              -> Type       -- ^ Type of result.+              -> VM VExpr+              -> VM VExpr+buildClosures _tvs _vars _env [] _res_ty mk_body+ = mk_body+buildClosures tvs vars env [arg_ty] res_ty mk_body+ =  buildClosure tvs vars env arg_ty res_ty mk_body+buildClosures tvs vars env (arg_ty : arg_tys) res_ty mk_body+ = do { res_ty' <- mkClosureTypes arg_tys res_ty+      ; arg     <- newLocalVVar (fsLit "x") arg_ty+      ; buildClosure tvs vars env arg_ty res_ty'+          . hoistPolyVExpr tvs vars (Inline (length env + 1))+          $ do { lc     <- builtin liftingContext+               ; clo    <- buildClosures tvs vars (env ++ [arg]) arg_tys res_ty mk_body+               ; return $ vLams lc (env ++ [arg]) clo+               }+      }++-- Build a closure taking one extra argument during closure application.+--+-- (clo <x1,...,xn> <f,f^>, aclo (Arr lc xs1 ... xsn) <f,f^>)+--   where+--     f  = \env v -> case env of <x1,...,xn> -> e x1 ... xn v+--     f^ = \env v -> case env of Arr l xs1 ... xsn -> e^ l x1 ... xn v+--+-- In addition to a set of type variables, a set of value variables is passed during closure+-- /construction/.  In contrast, the closure environment and the closure argument are passed during+-- closure application.+--+buildClosure :: [TyVar]         -- ^Type variables passed during closure construction.+             -> [Var]           -- ^Variables passed during closure construction.+             -> [VVar]          -- ^Variables in the environment.+             -> Type            -- ^Type of the closure argument.+             -> Type            -- ^Type of the result.+             -> VM VExpr+             -> VM VExpr+buildClosure tvs vars vvars arg_ty res_ty mk_body+  = do { (env_ty, env, bind) <- buildEnv vvars+       ; env_bndr <- newLocalVVar (fsLit "env") env_ty+       ; arg_bndr <- newLocalVVar (fsLit "arg") arg_ty++           -- generate the closure function as a hoisted binding+       ; fn <- hoistPolyVExpr tvs vars (Inline 2) $+                 do { lc     <- builtin liftingContext+                    ; body   <- mk_body+                    ; return . vLams lc [env_bndr, arg_bndr]+                             $ bind (vVar env_bndr)+                                    (vVarApps lc body (vvars ++ [arg_bndr]))+                    }++       ; mkClosure arg_ty res_ty env_ty fn env+       }++-- Build the environment for a single closure.+--+buildEnv :: [VVar] -> VM (Type, VExpr, VExpr -> VExpr -> VExpr)+buildEnv []+ = do+      ty    <- voidType+      void  <- builtin voidVar+      pvoid <- builtin pvoidVar+      return (ty, vVar (void, pvoid), \_ body -> body)+buildEnv [v]+ = return (vVarType v, vVar v,+           \env body -> vLet (vNonRec v env) body)+buildEnv vs+ = do (lenv_tc, lenv_tyargs) <- pdataReprTyCon ty++      let venv_con   = tupleDataCon Boxed (length vs)+          [lenv_con] = tyConDataCons lenv_tc++          venv       = mkCoreTup (map Var vvs)+          lenv       = Var (dataConWrapId lenv_con)+                       `mkTyApps` lenv_tyargs+                       `mkApps`   map Var lvs++          vbind env body = mkWildCase env ty (exprType body)+                           [(DataAlt venv_con, vvs, body)]++          lbind env body =+            let scrut = unwrapFamInstScrut lenv_tc lenv_tyargs env+            in+            mkWildCase scrut (exprType scrut) (exprType body)+              [(DataAlt lenv_con, lvs, body)]++          bind (venv, lenv) (vbody, lbody) = (vbind venv vbody,+                                              lbind lenv lbody)++      return (ty, (venv, lenv), bind)+  where+    (vvs, lvs) = unzip vs+    tys        = map vVarType vs+    ty         = mkBoxedTupleTy tys
+ vectorise/Vectorise/Utils/Hoisting.hs view
@@ -0,0 +1,98 @@+module Vectorise.Utils.Hoisting+  ( Inline(..)+  , addInlineArity+  , inlineMe++  , hoistBinding+  , hoistExpr+  , hoistVExpr+  , hoistPolyVExpr+  , takeHoisted+  )+where++import Vectorise.Monad+import Vectorise.Env+import Vectorise.Vect+import Vectorise.Utils.Poly++import CoreSyn+import CoreUtils+import CoreUnfold+import Type+import Id+import BasicTypes  (Arity)+import FastString+import Control.Monad+import Control.Applicative+import Prelude -- avoid redundant import warning due to AMP++-- Inline ---------------------------------------------------------------------++-- |Records whether we should inline a particular binding.+--+data Inline+        = Inline Arity+        | DontInline++-- |Add to the arity contained within an `Inline`, if any.+--+addInlineArity :: Inline -> Int -> Inline+addInlineArity (Inline m) n = Inline (m+n)+addInlineArity DontInline _ = DontInline++-- |Says to always inline a binding.+--+inlineMe :: Inline+inlineMe = Inline 0+++-- Hoisting --------------------------------------------------------------------++hoistBinding :: Var -> CoreExpr -> VM ()+hoistBinding v e = updGEnv $ \env ->+  env { global_bindings = (v,e) : global_bindings env }++hoistExpr :: FastString -> CoreExpr -> Inline -> VM Var+hoistExpr fs expr inl+  = do+      var <- mk_inline `liftM` newLocalVar fs (exprType expr)+      hoistBinding var expr+      return var+  where+    mk_inline var = case inl of+                      Inline arity -> var `setIdUnfolding`+                                      mkInlineUnfoldingWithArity arity expr+                      DontInline   -> var++hoistVExpr :: VExpr -> Inline -> VM VVar+hoistVExpr (ve, le) inl+  = do+      fs <- getBindName+      vv <- hoistExpr ('v' `consFS` fs) ve inl+      lv <- hoistExpr ('l' `consFS` fs) le (addInlineArity inl 1)+      return (vv, lv)++-- |Hoist a polymorphic vectorised expression into a new top-level binding (representing a closure+-- function).+--+-- The hoisted expression is parameterised by (1) a set of type variables and (2) a set of value+-- variables that are passed as conventional type and value arguments.  The latter is implicitly+-- extended by the set of 'PA' dictionaries required for the type variables.+--+hoistPolyVExpr :: [TyVar] -> [Var] -> Inline -> VM VExpr -> VM VExpr+hoistPolyVExpr tvs vars inline p+  = do { inline' <- addInlineArity inline . (+ length vars) <$> polyArity tvs+       ; expr <- closedV . polyAbstract tvs $ \args ->+                   mapVect (mkLams $ tvs ++ args ++ vars) <$> p+       ; fn   <- hoistVExpr expr inline'+       ; let varArgs = varsToCoreExprs vars+       ; mapVect (\e -> e `mkApps` varArgs) <$> polyVApply (vVar fn) (mkTyVarTys tvs)+       }++takeHoisted :: VM [(Var, CoreExpr)]+takeHoisted+  = do+      env <- readGEnv id+      setGEnv $ env { global_bindings = [] }+      return $ global_bindings env
+ vectorise/Vectorise/Utils/PADict.hs view
@@ -0,0 +1,229 @@+module Vectorise.Utils.PADict (+  paDictArgType,+  paDictOfType,+  paMethod,+  prDictOfReprType,+  prDictOfPReprInstTyCon+) where++import Vectorise.Monad+import Vectorise.Builtins+import Vectorise.Utils.Base++import CoreSyn+import CoreUtils+import FamInstEnv+import Coercion+import Type+import TyCoRep+import TyCon+import CoAxiom+import Var+import Outputable+import DynFlags+import FastString+import Control.Monad+++-- |Construct the PA argument type for the tyvar. For the tyvar (v :: *) it's+-- just PA v. For (v :: (* -> *) -> *) it's+--+-- > forall (a :: * -> *). (forall (b :: *). PA b -> PA (a b)) -> PA (v a)+--+paDictArgType :: TyVar -> VM (Maybe Type)+paDictArgType tv = go (mkTyVarTy tv) (tyVarKind tv)+  where+    go ty (FunTy k1 k2)+      = do+          tv   <- if isCoercionType k1+                  then newCoVar (fsLit "c") k1+                  else newTyVar (fsLit "a") k1+          mty1 <- go (mkTyVarTy tv) k1+          case mty1 of+            Just ty1 -> do+                          mty2 <- go (mkAppTy ty (mkTyVarTy tv)) k2+                          return $ fmap (mkInvForAllTy tv . mkFunTy ty1) mty2+            Nothing  -> go ty k2++    go ty k+      | isLiftedTypeKind k+      = do+          pa_cls <- builtin paClass+          return $ Just $ mkClassPred pa_cls [ty]++    go _ _ = return Nothing+++-- |Get the PA dictionary for some type+--+paDictOfType :: Type -> VM CoreExpr+paDictOfType ty+  = paDictOfTyApp ty_fn ty_args+  where+    (ty_fn, ty_args) = splitAppTys ty++    paDictOfTyApp :: Type -> [Type] -> VM CoreExpr+    paDictOfTyApp ty_fn ty_args+        | Just ty_fn' <- coreView ty_fn+        = paDictOfTyApp ty_fn' ty_args++    -- for type variables, look up the dfun and apply to the PA dictionaries+    -- of the type arguments+    paDictOfTyApp (TyVarTy tv) ty_args+      = do+        { dfun <- maybeCantVectoriseM "No PA dictionary for type variable"+                                      (ppr tv <+> text "in" <+> ppr ty)+                $ lookupTyVarPA tv+        ; dicts <- mapM paDictOfType ty_args+        ; return $ dfun `mkTyApps` ty_args `mkApps` dicts+        }++    -- for tycons, we also need to apply the dfun to the PR dictionary of+    -- the representation type if the tycon is polymorphic+    paDictOfTyApp (TyConApp tc []) ty_args+      = do+        { dfun <- maybeCantVectoriseM noPADictErr (ppr tc <+> text "in" <+> ppr ty)+                $ lookupTyConPA tc+        ; super <- super_dict tc ty_args+        ; dicts <- mapM paDictOfType ty_args+        ; return $ Var dfun `mkTyApps` ty_args `mkApps` super `mkApps` dicts+        }+      where+        noPADictErr = "No PA dictionary for type constructor (did you import 'Data.Array.Parallel'?)"++        super_dict _     []      = return []+        super_dict tycon ty_args+          = do+            { pr <- prDictOfPReprInst (TyConApp tycon ty_args)+            ; return [pr]+            }++    paDictOfTyApp _ _ = getDynFlags >>= failure++    failure dflags = cantVectorise dflags "Can't construct PA dictionary for type" (ppr ty)++-- |Produce code that refers to a method of the 'PA' class.+--+paMethod :: (Builtins -> Var) -> (TyCon -> Builtins -> Var) -> Type -> VM CoreExpr+paMethod _ query ty+  | Just tycon <- splitPrimTyCon ty             -- Is 'ty' from 'GHC.Prim' (e.g., 'Int#')?+  = liftM Var $ builtin (query tycon)+paMethod method _ ty+  = do+    { fn   <- builtin method+    ; dict <- paDictOfType ty+    ; return $ mkApps (Var fn) [Type ty, dict]+    }++-- |Given a type @ty@, return the PR dictionary for @PRepr ty@.+--+prDictOfPReprInst :: Type -> VM CoreExpr+prDictOfPReprInst ty+  = do+    { (FamInstMatch { fim_instance = prepr_fam, fim_tys = prepr_args })+          <- preprFamInst ty+    ; prDictOfPReprInstTyCon ty (famInstAxiom prepr_fam) prepr_args+    }++-- |Given a type @ty@, its PRepr synonym tycon and its type arguments,+-- return the PR @PRepr ty@. Suppose we have:+--+-- > type instance PRepr (T a1 ... an) = t+--+-- which is internally translated into+--+-- > type :R:PRepr a1 ... an = t+--+-- and the corresponding coercion. Then,+--+-- > prDictOfPReprInstTyCon (T a1 ... an) :R:PRepr u1 ... un = PR (T u1 ... un)+--+-- Note that @ty@ is only used for error messages+--+prDictOfPReprInstTyCon :: Type -> CoAxiom Unbranched -> [Type] -> VM CoreExpr+prDictOfPReprInstTyCon _ty prepr_ax prepr_args+  = do+      let rhs = mkUnbranchedAxInstRHS prepr_ax prepr_args []+      dict <- prDictOfReprType' rhs+      pr_co <- mkBuiltinCo prTyCon+      let co = mkAppCo pr_co+             $ mkSymCo+             $ mkUnbranchedAxInstCo Nominal prepr_ax prepr_args []+      return $ mkCast dict co++-- |Get the PR dictionary for a type. The argument must be a representation+-- type.+--+prDictOfReprType :: Type -> VM CoreExpr+prDictOfReprType ty+  | Just (tycon, tyargs) <- splitTyConApp_maybe ty+    = do+        prepr <- builtin preprTyCon+        if tycon == prepr+          then do+                 let [ty'] = tyargs+                 pa <- paDictOfType ty'+                 sel <- builtin paPRSel+                 return $ Var sel `App` Type ty' `App` pa+          else do+                 -- a representation tycon must have a PR instance+                 dfun <- maybeV (text "look up PR dictionary for" <+> ppr tycon) $+                           lookupTyConPR tycon+                 prDFunApply dfun tyargs++  | otherwise+    = do+        -- it is a tyvar or an application of a tyvar+        -- determine the PR dictionary from its PA dictionary+        --+        -- NOTE: This assumes that PRepr t ~ t is for all representation types+        -- t+        --+        -- FIXME: This doesn't work for kinds other than * at the moment. We'd+        -- have to simply abstract the term over the missing type arguments.+        pa    <- paDictOfType ty+        prsel <- builtin paPRSel+        return $ Var prsel `mkApps` [Type ty, pa]++prDictOfReprType' :: Type -> VM CoreExpr+prDictOfReprType' ty = prDictOfReprType ty `orElseV`+                       do dflags <- getDynFlags+                          cantVectorise dflags "No PR dictionary for representation type"+                                        (ppr ty)++-- | Apply a tycon's PR dfun to dictionary arguments (PR or PA) corresponding+-- to the argument types.+prDFunApply :: Var -> [Type] -> VM CoreExpr+prDFunApply dfun tys+  | Just [] <- ctxs    -- PR (a :-> b) doesn't have a context+  = return $ Var dfun `mkTyApps` tys++  | Just tycons <- ctxs+  , length tycons == length tys+  = do+      pa <- builtin paTyCon+      pr <- builtin prTyCon+      dflags <- getDynFlags+      args <- zipWithM (dictionary dflags pa pr) tys tycons+      return $ Var dfun `mkTyApps` tys `mkApps` args++  | otherwise = do dflags <- getDynFlags+                   invalid dflags+  where+    -- the dfun's contexts - if its type is (PA a, PR b) => PR (C a b) then+    -- ctxs is Just [PA, PR]+    ctxs = fmap (map fst)+         $ sequence+         $ map splitTyConApp_maybe+         $ fst+         $ splitFunTys+         $ snd+         $ splitForAllTys+         $ varType dfun++    dictionary dflags pa pr ty tycon+      | tycon == pa = paDictOfType ty+      | tycon == pr = prDictOfReprType ty+      | otherwise   = invalid dflags++    invalid dflags = cantVectorise dflags "Invalid PR dfun type" (ppr (varType dfun) <+> ppr tys)
+ vectorise/Vectorise/Utils/Poly.hs view
@@ -0,0 +1,72 @@+-- |Auxiliary functions to vectorise type abstractions.++module Vectorise.Utils.Poly+  ( polyAbstract+  , polyApply+  , polyVApply+  , polyArity+  )+where++import Vectorise.Vect+import Vectorise.Monad+import Vectorise.Utils.PADict+import CoreSyn+import Type+import FastString+import Control.Monad+++-- Vectorisation of type arguments -------------------------------------------------------------++-- |Vectorise under the 'PA' dictionary variables corresponding to a set of type arguments.+--+-- The dictionary variables are new local variables that are entered into the local vectorisation+-- map.+--+-- The purpose of this function is to introduce the additional 'PA' dictionary arguments that are+-- needed when vectorising type abstractions.+--+polyAbstract :: [TyVar] -> ([Var] -> VM a) -> VM a+polyAbstract tvs p+  = localV+  $ do { mdicts <- mapM mk_dict_var tvs+       ; zipWithM_ (\tv -> maybe (defLocalTyVar tv)+                                 (defLocalTyVarWithPA tv . Var)) tvs mdicts+       ; p (mk_args mdicts)+       }+  where+    mk_dict_var tv+      = do { r <- paDictArgType tv+           ; case r of+               Just ty -> liftM Just (newLocalVar (fsLit "dPA") ty)+               Nothing -> return Nothing+           }++    mk_args mdicts = [dict | Just dict <- mdicts]++-- |Determine the number of 'PA' dictionary arguments required for a set of type variables (depends+-- on their kinds).+--+polyArity :: [TyVar] -> VM Int+polyArity tvs+  = do { tys <- mapM paDictArgType tvs+       ; return $ length [() | Just _ <- tys]+       }++-- |Apply a expression to its type arguments as well as 'PA' dictionaries for these type arguments.+--+polyApply :: CoreExpr -> [Type] -> VM CoreExpr+polyApply expr tys+ = do { dicts <- mapM paDictOfType tys+      ; return $ expr `mkTyApps` tys `mkApps` dicts+      }++-- |Apply a vectorised expression to a set of type arguments together with 'PA' dictionaries for+-- these type arguments.+--+polyVApply :: VExpr -> [Type] -> VM VExpr+polyVApply expr tys+ = do { dicts <- mapM paDictOfType tys+      ; return $ mapVect (\e -> e `mkTyApps` tys `mkApps` dicts) expr+      }
+ vectorise/Vectorise/Var.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE TupleSections #-}++-- |Vectorise variables and literals.++module Vectorise.Var+  ( vectBndr+  , vectBndrNew+  , vectBndrIn+  , vectBndrNewIn+  , vectBndrsIn+  , vectVar+  , vectConst+  )+where++import Vectorise.Utils+import Vectorise.Monad+import Vectorise.Env+import Vectorise.Vect+import Vectorise.Type.Type+import CoreSyn+import Type+import VarEnv+import Id+import FastString+import Control.Applicative+import Prelude -- avoid redundant import warning due to AMP++-- Binders ----------------------------------------------------------------------------------------++-- |Vectorise a binder variable, along with its attached type.+--+vectBndr :: Var -> VM VVar+vectBndr v+ = do (vty, lty) <- vectAndLiftType (idType v)+      let vv = v `Id.setIdType` vty+          lv = v `Id.setIdType` lty++      updLEnv (mapTo vv lv)++      return  (vv, lv)+  where+    mapTo vv lv env = env { local_vars = extendVarEnv (local_vars env) v (vv, lv) }++-- |Vectorise a binder variable, along with its attached type, but give the result a new name.+--+vectBndrNew :: Var -> FastString -> VM VVar+vectBndrNew v fs+ = do vty <- vectType (idType v)+      vv  <- newLocalVVar fs vty+      updLEnv (upd vv)+      return vv+  where+    upd vv env = env { local_vars = extendVarEnv (local_vars env) v vv }++-- |Vectorise a binder then run a computation with that binder in scope.+--+vectBndrIn :: Var -> VM a -> VM (VVar, a)+vectBndrIn v p+ = localV+ $ do vv <- vectBndr v+      x <- p+      return (vv, x)++-- |Vectorise a binder, give it a new name, then run a computation with that binder in scope.+--+vectBndrNewIn :: Var -> FastString -> VM a -> VM (VVar, a)+vectBndrNewIn v fs p+ = localV+ $ do vv <- vectBndrNew v fs+      x  <- p+      return (vv, x)++-- |Vectorise some binders, then run a computation with them in scope.+--+vectBndrsIn :: [Var] -> VM a -> VM ([VVar], a)+vectBndrsIn vs p+ = localV+ $ do vvs <- mapM vectBndr vs+      x   <- p+      return (vvs, x)+++-- Variables --------------------------------------------------------------------------------------++-- |Vectorise a variable, producing the vectorised and lifted versions.+--+vectVar :: Var -> VM VExpr+vectVar var+  = do { vVar <- lookupVar var+       ; case vVar of+           Local (vv, lv) -> return (Var vv, Var lv) -- local variables have a vect & lifted version+           Global vv      -> vectConst (Var vv)      -- global variables get replicated+       }+++-- Constants --------------------------------------------------------------------------------------++-- |Constants are lifted by replication along the integer context in the `VM` state for the number+-- of elements in the result array.+--+vectConst :: CoreExpr -> VM VExpr+vectConst c = (c,) <$> liftPD c
+ vectorise/Vectorise/Vect.hs view
@@ -0,0 +1,126 @@+-- |Simple vectorised constructors and projections.+--+module Vectorise.Vect+  ( Vect, VVar, VExpr, VBind++  , vectorised+  , lifted+  , mapVect++  , vVarType+  , vNonRec+  , vRec+  , vVar+  , vType+  , vTick+  , vLet+  , vLams+  , vVarApps+  , vCaseDEFAULT+  )+where++import CoreSyn+import Type           ( Type )+import Var++-- |Contains the vectorised and lifted versions of some thing.+--+type Vect a = (a,a)+type VVar   = Vect Var+type VExpr  = Vect CoreExpr+type VBind  = Vect CoreBind++-- |Get the vectorised version of a thing.+--+vectorised :: Vect a -> a+vectorised = fst++-- |Get the lifted version of a thing.+--+lifted :: Vect a -> a+lifted = snd++-- |Apply some function to both the vectorised and lifted versions of a thing.+--+mapVect :: (a -> b) -> Vect a -> Vect b+mapVect f (x, y) = (f x, f y)++-- |Combine vectorised and lifted versions of two things componentwise.+--+zipWithVect :: (a -> b -> c) -> Vect a -> Vect b -> Vect c+zipWithVect f (x1, y1) (x2, y2) = (f x1 x2, f y1 y2)++-- |Get the type of a vectorised variable.+--+vVarType :: VVar -> Type+vVarType = varType . vectorised++-- |Wrap a vectorised variable as a vectorised expression.+--+vVar :: VVar -> VExpr+vVar = mapVect Var++-- |Wrap a vectorised type as a vectorised expression.+--+vType :: Type -> VExpr+vType ty = (Type ty, Type ty)++-- |Make a vectorised note.+--+vTick :: Tickish Id -> VExpr -> VExpr+vTick = mapVect . Tick++-- |Make a vectorised non-recursive binding.+--+vNonRec :: VVar -> VExpr -> VBind+vNonRec = zipWithVect NonRec++-- |Make a vectorised recursive binding.+--+vRec :: [VVar] -> [VExpr] -> VBind+vRec vs es = (Rec (zip vvs ves), Rec (zip lvs les))+  where+    (vvs, lvs) = unzip vs+    (ves, les) = unzip es++-- |Make a vectorised let expression.+--+vLet :: VBind -> VExpr -> VExpr+vLet = zipWithVect Let++-- |Make a vectorised lambda abstraction.+--+-- The lifted version also binds the lifting context 'lc'.+--+vLams :: Var      -- ^ Var bound to the lifting context.+      -> [VVar]   -- ^ Parameter vars for the abstraction.+      -> VExpr    -- ^ Body of the abstraction.+      -> VExpr+vLams lc vs (ve, le)+  = (mkLams vvs ve, mkLams (lc:lvs) le)+  where+    (vvs, lvs) = unzip vs++-- |Apply an expression to a set of argument variables.+--+-- The lifted version is also applied to the variable of the lifting context.+--+vVarApps :: Var -> VExpr -> [VVar] -> VExpr+vVarApps lc (ve, le) vvs+  = (ve `mkVarApps` vs, le `mkVarApps` (lc : ls))+  where+    (vs, ls) = unzip vvs+++vCaseDEFAULT :: VExpr  -- scrutinee+             -> VVar   -- bnder+             -> Type   -- type of vectorised version+             -> Type   -- type of lifted version+             -> VExpr  -- body of alternative.+             -> VExpr+vCaseDEFAULT (vscrut, lscrut) (vbndr, lbndr) vty lty (vbody, lbody)+  = (Case vscrut vbndr vty (mkDEFAULT vbody),+     Case lscrut lbndr lty (mkDEFAULT lbody))+  where+    mkDEFAULT e = [(DEFAULT, [], e)]